subroutine bmass(pgdpsi,pgdchi,kibeg,kiend,kjbeg,kjend,knk) 1
#if defined (DOC)
*
***s/r bmass - Constructs Total increments from grid-point balanced temperature and lnps
* from input grid-point (PSI,CHI) increments during minimization
* .
* Purpose
* . As part of the transform to build the unbalanced temperature and lnps
* analysis variables.
*
*Author : Luc Fillion *ARMA/AES May 15, 1998
*
*Revision: L. Fillion/M. Buehner - 20 jul 98
* . - Based on empirical balance from linear regression analysis
*Revision: L. Fillion - 4 dec 98
* . - Remove comgd1.cdk. Wasnt used.
*Revision: L. Fillion - 4 dec 98
* . - Change documentation since bmass is now used
* to build total increments.
*Revision: C. Charette - 9 dec 98
* . - Added new parameters to dimension fields
* This is now necessary because bmass is
* also used in diag3dvar.
* L. Fillion *ARMA/AES 4 mar 1999
* . - Filter T increments to remove projection on Kernel of Hydrostatic operator.
*
* C. Charette *ARMA/AES SEP 1999
* - Operator PTOT as a function of latitude
* P. Koclas CMC Apr 2003
* -changed loop nesting order and added opemp for ibm conversion
* Y.J. Rochon *ARQX Nov 2008
* - Addition of new balance components
* Y.Yang ARQI Jan 2010
* - merge to v10.2.2:
* add ' include "comcva.cdk" '
* use of NFLEVPTOT
* - indentation of DOC part
*
*Arguments
*
* In
* pgdpsi : Grid-point del(PSI)
* pgdchi : Grid-point del(CHI)
* Out
* pgdchi : Grid-point partial del(CHI)
* tt1 : Grid-point Total (balanced+Unbal) Temperature increment (del T)
* gps1 : Grid-point Total (balanced+unbal) log surface-pressure increment (del lnps)
* .
*Revision:
#endif
C
IMPLICIT NONE
#include "pardim.cdk"
#include "comdim.cdk"
#include "comlun.cdk"
#include "comcst.cdk"
#include "comgem.cdk"
#include "comleg.cdk"
#include "comgd0.cdk"
#include "comcorr.cdk"
#include "comcva.cdk"
C
INTEGER ILON, JLEV, JLON, JLAT, JLA
integer ilen,ierr,jk1,jk2
INTEGER KIBEG,KIEND,KJBEG,KJEND,KNK
REAL*8 pgdpsi(KIBEG:KIEND,KNK,KJBEG:KJEND)
REAL*8 pgdchi(KIBEG:KIEND,KNK,KJBEG:KJEND)
*
REAL*8 zcon,zcoriolis
REAL*8 zp(KIBEG:KIEND,KNK,KJBEG:KJEND)
POINTER (pxzp,zp)
INTEGER thdid,numthd,omp_get_thread_num,omp_get_num_threads
*
*modules
external hpalloc
C
C 1. Allocate ZP array
C ---------------------
C
100 CONTINUE
ILEN=(KJEND-KJBEG+1)*NFLEV*(KIEND-KIBEG+1)
CALL HPALLOC(pxzp,MAX(1,ILEN),IERR,8)
C
C 2. (del P)b = f del(PSI)
C ------------------------
C
c ibal_utpp_uc=0
c ibal_tbpp_cc=0
200 CONTINUE
!$OMP PARALLEL DO PRIVATE(jlev,jlat,ilon,zcoriolis,jlon)
DO JLAT = 1, NJ
ILON = NILON(JLAT)
ZCORIOLIS = 2.*ROMEGA*RMU(JLAT)
DO JLEV = 1, NFLEVPTOT
DO JLON = 1, ILON
zp(JLON,JLEV,JLAT) = ZCORIOLIS*pGDPSI(JLON,JLEV,JLAT)
END DO
END DO
c
c 3. Use P_to_T to derive T_b and lnPs_b from P_b
c and add to del(Tu), del(psu) to build total increments
c ---------------------------------------------------------
c
300 continue
C
DO JLON = 1, ILON
do jk2=1,NFLEVPTOT
do jk1=1,NFLEV
tt0(jlon,jk1,jlat)=tt0(jlon,jk1,jlat)
+ +PtoT(jk1,jk2,jlat)*zp(jlon,jk2,jlat)
enddo
gps0(jlon,1,jlat)=gps0(jlon,1,jlat) +
+ PtoT(NFLEV+1,jk2,jlat)*zp(jlon,jk2,jlat)
enddo
END DO
C
if (ibal_utpp_uc.eq.1.and.ibal_tbpp_cc.eq.1) then
DO JLON = 1, ILON
do jk1=1,NFLEV
tt0(jlon,jk1,jlat)=tt0(jlon,jk1,jlat)
+ +bal_utpp_uc(jk1,jlat)*pGDCHI(jlon,jk1,jlat)
C
pGDCHI(jlon,jk1,jlat)=pGDCHI(jlon,jk1,jlat)
+ +bal_tbpp_cc(jk1,jlat)*
+ sum(PtoT(jk1,1:nflev,jlat)*zp(jlon,1:nflev,jlat))
end do
END DO
else if (ibal_utpp_uc.eq.1) then
DO JLON = 1, ILON
do jk1=1,NFLEV
tt0(jlon,jk1,jlat)=tt0(jlon,jk1,jlat)
+ +bal_utpp_uc(jk1,jlat)*pGDCHI(jlon,jk1,jlat)
end do
END DO
end if
C
END DO
!$OMP END PARALLEL DO
c
c 4. Filter del(T)
c ----------------
c
400 continue
cluc call ttflt(zp(1,1,1)) ! filters tt0
C
C 5. Deallocate local array
C -------------------------
C
500 CONTINUE
CALL HPDEALLC(pxzp,IERR,1)
IF(IERR.NE.0)THEN
CALL ABORT3D(NULOUT,'BMASS: Problem with zp.')
END IF
C
C
RETURN
END