!-------------------------------------- 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 abmass(pgdpsi,pgdchi) 1,1
#if defined (DOC)
*
***s/r abmass - Adjoint of bmass:
* Constructs Adjoint grid-point balanced (PSI,CHI)
* from input grid-point adjoint balanced temperature and lnps vrbls.
* N.B.: Values of adjoint vrbls (PSI,CHI) on entry assumed in (arguments) resp.
* .
* Purpose
* . As part of the transform to build the adjoint of unbalanced temperature and lnps
* analysis variables.
*
*Author : Luc Fillion/Mark Buehner *ARMA/AES Jul 20, 1998
*
*Revision: L. Fillion - *ARMA/AES- 4 mar 1999
* . Add adjoint of temperature filter
*
* C. Charette *ARMA/AES SEP 1999
* - Operator PTOT as a function of latitude
* P. Koclas JP Toviessi Apr 2003
* -add openmp for ibm conversion
* L. Fillion ARMA/EC - 3 Jul 2008 - Apply scaling factor to T-increment in SW mode...
*
*Arguments:
*
*Out
* pgdpsi : Grid-point values of adjoint variable PSI*
* pgdchi : Grid-point values of adjoint variable CHI*
* .
*Revision:
#endif
C
IMPLICIT NONE
#include "pardim.cdk"
#include "comdim.cdk"
#include "comlun.cdk"
#include "comcst.cdk"
#include "comleg.cdk"
#include "comgem.cdk"
#include "comgd0.cdk"
#include "comcorr.cdk"
#include "comcva.cdk"
#include "comsim.cdk"
C
real*8 pgdpsi(NIBEG:NIEND,nflev,NJBEG:NJEND)
real*8 pgdchi(NIBEG:NIEND,nflev,NJBEG:NJEND)
*
INTEGER ILON, JLEV, JLON, JLAT, jk1, jk2, ilen, ierr
REAL*8 zcon,ZCORIOLIS,zscalt
REAL*8 zp(NIBEG:NIEND,nflev,NJBEG:NJEND)
POINTER (pxzp,zp)
*
*modules
external hpalloc
C
C 1. Allocate ZP array
C ---------------------
C
100 CONTINUE
ILEN=(NJEND-NJBEG+1)*NFLEV*(NIEND-NIBEG+1)
CALL HPALLOC(pxzp,MAX(1,ILEN),IERR,8)
C
C 2. (PSI)* = (PSI)* + Ht Nt (T,lnps)*
C ------------------------------------
C
200 CONTINUE
C
C 2.1 Compute adjoint of T filering
C
cluc call attflt(zp(1,1,1))
C
C 2.2 Compute Nt (T,lnps)*, Result in zp
C
if(lsw) then
zscalt = 0.1
DO JLAT = 1, NJ
ZCORIOLIS = 2.*ROMEGA*RMU(JLAT)
ILON = NILON(JLAT)
DO JLON = 1, ILON
zp(jlon,mk,jlat) = 0.0
zp(jlon,mk,jlat) = zp(jlon,mk,jlat)+
& zscalt*tt0(jlon,mk,jlat)
pGDPSI(JLON,mk,JLAT) = ZCORIOLIS*zp(JLON,mk,JLAT)
S + pGDPSI(JLON,mk,JLAT)
c pGDCHI(JLON,mk,JLAT) = pGDCHI(JLON,mk,JLAT)
END DO
END DO ! Loop over JLAT
endif
!
if(.not.lsw) then
!
!$OMP PARALLEL DO PRIVATE(ILON,JLAT,JLON,jk1,jk2)
!$OMP+ PRIVATE(jlev,zcoriolis)
DO JLAT = 1, NJ
ILON = NILON(JLAT)
DO JLON = 1, ILON
do jk1=1,NFLEVPTOT
zp(jlon,jk1,jlat) = 0.0
do jk2=1,NFLEV
zp(jlon,jk1,jlat) = zp(jlon,jk1,jlat)+
+ PtoT(jk2,jk1,jlat)*tt0(jlon,jk2,jlat)
enddo
enddo
do jk1=1,NFLEVPTOT
zp(jlon,jk1,jlat) = zp(jlon,jk1,jlat)+
+ PtoT(NFLEV+1,jk1,jlat)*gps0(jlon,1,jlat)
enddo
END DO
! END DO
C
C 2.3 Compute (PSI)* = (PSI)* + Ht Nt (T,lnps)*
C
ZCORIOLIS = 2.*ROMEGA*RMU(JLAT)
DO JLEV = 1, NFLEVPTOT
DO JLON = 1, ILON
pGDPSI(JLON,JLEV,JLAT) = ZCORIOLIS*zp(JLON,JLEV,JLAT)
S + pGDPSI(JLON,JLEV,JLAT)
c pGDCHI(JLON,JLEV,JLAT) = pGDCHI(JLON,JLEV,JLAT)
END DO
END DO
END DO ! Loop over JLAT
!$OMP END PARALLEL DO
endif
C
C 3. Deallocate local array
C -------------------------
C
300 CONTINUE
CALL HPDEALLC(pxzp,IERR,1)
IF(IERR.NE.0)THEN
CALL ABORT3D(NULOUT,'BMASS: Problem with zp.')
END IF
C
C
RETURN
END