!-------------------------------------- LICENCE BEGIN ------------------------------------
!Environment Canada - Atmospheric Science and Technology License/Disclaimer,
!                     version 3; Last Modified: May 7, 2008.
!This is free but copyrighted software; you can use/redistribute/modify it under the terms
!of the Environment Canada - Atmospheric Science and Technology License/Disclaimer
!version 3 or (at your option) any later version that should be found at:
!http://collaboration.cmc.ec.gc.ca/science/rpn.comm/license.html
!
!This software is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY;
!without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
!See the above mentioned License/Disclaimer for more details.
!You should have received a copy of the License/Disclaimer along with this software;
!if not, you can write to: EC-RPN COMM Group, 2121 TransCanada, suite 500, Dorval (Quebec),
!CANADA, H9P 1J3; or send e-mail to service.rpn@ec.gc.ca
!-------------------------------------- LICENCE END --------------------------------------
!

      subroutine bmass(pgdpsi,pgdchi,kibeg,kiend,kjbeg,kjend,knk) 2,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
*L. Fillion ARMA/EC - 3 Jul 2008 - Apply scaling factor to T-increment in SW mode...
*
*Arguments
*
* In
*    pgdpsi : Grid-point del(PSI)
*    pgdchi : Grid-point del(CHI)
* Out
*    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"
#include "comsim.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,zscalt
      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
 200  CONTINUE
      if(lsw) then
        zscalt = 0.1
        DO JLAT = 1, NJ
          ILON = NILON(JLAT)
          ZCORIOLIS = 2.*ROMEGA*RMU(JLAT)
          DO JLON = 1, ILON
            zp(JLON,mk,JLAT) = ZCORIOLIS*pGDPSI(JLON,mk,JLAT)
            tt0(jlon,mk,jlat)=tt0(jlon,mk,jlat) +
     +            zscalt*zp(jlon,mk,jlat)
          END DO
        END DO
      endif
!
      if(.not.lsw) then
c
!$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
        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
      END DO
!$OMP END PARALLEL DO
      endif
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