!-------------------------------------- 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 balptot(pttb,ppsb,pgdpsi,pgdchi, 1,1
& kibeg,kiend,kjbeg,kjend,knk)
#if defined (DOC)
*
***s/r balptot - Constructs grid-point balanced temperature and lnps
* from input grid-point (PSI,CHI) increments during minimization
* using linear-regression matrix PtoT
* .
* Purpose
* . Used in DIAG3DVAR to construct Tb, psb.
*
*Author : Luc Fillion *ARMA/AES 15 feb 1999
*
*Revision:
* C. Charette *ARMA/AES 17 feb 1999
* - Initialize pttb ppsb to zero
*
* C. Charette *ARMA/AES SEP 1999
* - Operator PTOT as a function of latitude
*
*Arguments
*
* In
* pgdpsi : Grid-point del(PSI)
* pgdchi : Grid-point del(CHI)
* Out
* pttb : Grid-point balanced Temperature increment (del Tb)
* ppsb : Grid-point balanced surface-pressure increment (del psb)
* .
*Revision:
#endif
C
IMPLICIT NONE
#include "comdim.cdk"
#include "comlun.cdk"
#include "comcst.cdk"
#include "comleg.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 pttb(KIBEG:KIEND,KNK,KJBEG:KJEND)
REAL*8 ppsb(KIBEG:KIEND,1,KJBEG:KJEND)
*
logical llprint
integer ik
REAL*8 zcon,zcoriolis,zetapt,zetae1,zpscon
REAL*8 zp(ni,nflev,nj)
POINTER (pxzp,zp)
*
*modules
external hpalloc
*
**
llprint = .false.
C
C 1. Allocate ZP array
C ---------------------
C
100 CONTINUE
ILEN=ni*nflev*nj
CALL HPALLOC(pxzp,MAX(1,ILEN),IERR,8)
C
C 2. (del P)b = f del(PSI)
C ------------------------
C
200 CONTINUE
DO JLEV = 1, NFLEV
DO JLAT = 1, NJ
ILON = NI
ZCORIOLIS = 2.*ROMEGA*RMU(JLAT)
DO JLON = 1, ILON
zp(JLON,JLEV,JLAT) = ZCORIOLIS*pGDPSI(JLON,JLEV,JLAT)
END DO
END DO
END DO
c
c 3. Derive T_b and Ps_b from P_b
c -------------------------------
c
300 continue
DO JLAT = 1, NJ
ILON = NI
DO JLON = 1, ILON
do jk1=1,NFLEV
pttb(jlon,jk1,jlat)= 0.0
enddo
ENDDO
ENDDO
DO JLAT = 1, NJ
ILON = NI
DO JLON = 1, ILON
ppsb(jlon,1,jlat)= 0.0
enddo
ENDDO
c
DO JLAT = 1, NJ
ILON = NI
DO JLON = 1, ILON
do jk1=1,NFLEV
do jk2=1,NFLEVPTOT
pttb(jlon,jk1,jlat)=pttb(jlon,jk1,jlat) +
+ PtoT(jk1,jk2,jlat)*zp(jlon,jk2,jlat)
enddo
enddo
do jk2=1,NFLEVPTOT
ppsb(jlon,1,jlat)=ppsb(jlon,1,jlat) +
+ PtoT(NFLEV+1,jk2,jlat)*zp(jlon,jk2,jlat)
enddo
END DO
END DO
C
C 4. Deallocate local array
C -------------------------
C
400 CONTINUE
CALL HPDEALLC(pxzp,IERR,1)
IF(IERR.NE.0)THEN
CALL ABORT3D(NULOUT,'BALPTOT: Problem with zp.')
END IF
C
C
RETURN
END