!-------------------------------------- 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 acv2gdgl 1,8
#if defined (DOC)
*
***s/r acv2gdgl - Adjoint of cv2gdgl.ftn
* .
*Author : Luc Fillion - ARMA/EC - 13 Jul 2009.
* .
*Revision:
*: Luc Fillion - ARMA/EC - 11 may 2010. Limit printout to processor 0.
*: Luc Fillion - ARMA/EC - 17 may 2010. Introduce hemispheric spectral transform.
#endif
C
USE procs_topo
IMPLICIT NONE
#include "pardim.cdk"
#include "comdim.cdk"
#include "comcst.cdk"
#include "comgem.cdk"
#include "comleg.cdk"
#include "comcva.cdk"
#include "comsp.cdk"
#include "comspg.cdk"
#include "comgd0.cdk"
#include "compstat.cdk"
#include "comcorr.cdk"
#include "comcse1.cdk"
#include "comstate.cdk"
#include "comlun.cdk"
!
integer idum1,idum2,idum3,idum4
INTEGER ILEN
INTEGER JN,JM,JK,ILA,inj
real zmin,zmax
REAL*8 SQ2
REAL*8 ,ALLOCATABLE,DIMENSION(:,:,:) :: zsp,zsp2
INTEGER ILENGD, IERR, ILON, JLEV, JLON, JLAT, JLA
REAL*8 Z1SA2,ZNORMPSI, ZNORMCHI
REAL*8 ZGDPSI(NIBEG:NIEND,NFLEV,NJBEG:NJEND)
S ,ZGDCHI(NIBEG:NIEND,NFLEV,NJBEG:NJEND)
real*8 zgd(ni,nkgdim,nj)
!
INTEGER :: NTRUNCHF,JN0,INS,JNS,thdid,numthd
INTEGER :: omp_get_thread_num, omp_get_num_threads
real*8 two
!
!!
inj = nj
if(lcva_hsp) inj = njlath
call spgda
!
two = 2.d0
!
!*7. Adjoint of: Rederive the vorticity and divergence from PSI and CHI
! ------------------------------------------------------------------
!
Z1SA2 = 1./(RA*RA)
!$OMP PARALLEL DO
DO JLEV = 1, NFLEV
DO JLA = 1, NLA
SPVOR(JLA,1,JLEV) = SPVOR(JLA,1,JLEV)*Z1SA2*RNNP1(JLA)
SPVOR(JLA,2,JLEV) = SPVOR(JLA,2,JLEV)*Z1SA2*RNNP1(JLA)
SPDIV(JLA,1,JLEV) = SPDIV(JLA,1,JLEV)*Z1SA2*RNNP1(JLA)
SPDIV(JLA,2,JLEV) = SPDIV(JLA,2,JLEV)*Z1SA2*RNNP1(JLA)
END DO
END DO
!$OMP END PARALLEL DO
!
!*6. Adjoint of: Spectral transform all fields
! -----------------------------------------
!
if(lcva_hsp) then
CALL SPEREE_hem(nksdim,SP,GD
& ,NLA,NIBEG,NIEND,NJBEG,NJEND,NKSDIM)
else
CALL SPEREE(NKSDIM,SP,GD
& ,NLA,NIBEG,NIEND,NJBEG,NJEND,NKSDIM)
endif
!
!*5. Adjoint of: Apply 3D amplification factor after constructing full variables
! ---------------------------------------------------------------------------
!
DO JLAT = 1, inj
DO JLEV = 1, NKGDIM
DO JLON = 1, NI
GD(JLON,JLEV,JLAT)=
& GD(JLON,JLEV,JLAT)*damplibg(JLON,JLEV,JLAT)
END DO
END DO
END DO
!
DO JLAT = 1, inj
ILON = NILON(JLAT)
DO JLEV = 1, NFLEV
DO JLON = 1, ILON
ZGDPSI(JLON,JLEV,JLAT) = UT0(JLON,JLEV,JLAT)
ZGDCHI(JLON,JLEV,JLAT) = VT0(JLON,JLEV,JLAT)
END DO
END DO
END DO
!
!*4. Adjoint of: Apply INMI balancing of increment
! ---------------------------------------------
!
if(linmi) then
!cluc call abalgl(zgdpsi,zgdchi)
endif
!
!*3. Adjoint of: Denormalize
! -----------------------
!
IF(myid == 0) THEN
! write(nulout,*) 'acv2gdgl: luse3dstd = ',LUSE3DSTD
endif
!
IF(LUSE3DSTD) THEN
DO JLEV = 1, NFLEV
DO JLAT = 1, inj
ILON = NILON(JLAT)
DO JLON = 1, ILON
UT0(JLON,JLEV,JLAT)=
& ZGDPSI(JLON,JLEV,JLAT)*RGSIGUU3D(JLON,JLEV,JLAT)
VT0(JLON,JLEV,JLAT)=
& ZGDCHI(JLON,JLEV,JLAT)*RGSIGVV3D(JLON,JLEV,JLAT)
TT0(JLON,JLEV,JLAT)=
& TT0(JLON,JLEV,JLAT)*RGSIGTT3D(JLON,JLEV,JLAT)
Q0(JLON,JLEV,JLAT)=
& Q0(JLON,JLEV,JLAT)*RGSIGQ3D(JLON,JLEV,JLAT)
END DO
END DO
END DO
DO JLAT = 1, inj
ILON = NILON(JLAT)
DO JLON = 1, ILON
GPS0(JLON,1,JLAT)=
& GPS0(JLON,1,JLAT)*RGSIGPS3D(JLON,1,JLAT)
END DO
END DO
IF(nsexist(nstg).eq.1) THEN
DO JLAT = 1, inj
ILON = NILON(JLAT)
DO JLON = 1, ILON
GTG0(JLON,1,JLAT)=
& GTG0(JLON,1,JLAT)*RGSIGTG3D(JLON,1,JLAT)
END DO
END DO
ENDIF
ELSE
CALL FGERR('M')
!$OMP PARALLEL DO PRIVATE(ILON,ZNORMPSI,ZNORMCHI)
DO JLAT = 1, inj
ILON = NILON(JLAT)
DO JLEV = 1, NFLEV
ZNORMPSI = RGSIGUU(JLAT,JLEV)
ZNORMCHI = RGSIGVV(JLAT,JLEV)
DO JLON = 1, ILON
UT0(JLON,JLEV,JLAT)
& = ZGDPSI(JLON,JLEV,JLAT)*ZNORMPSI
VT0(JLON,JLEV,JLAT)
& = ZGDCHI(JLON,JLEV,JLAT)*ZNORMCHI
END DO
END DO
END DO
!$OMP END PARALLEL DO
ENDIF
!
!*2. Adjoint of: Build gridpoint PSI,CHI
! -----------------------------------
!
if(lcva_hsp) then
CALL REESPE_hem(NKSDIM,SP,GD
& ,NLA,NIBEG,NIEND,NJBEG,NJEND,NKSDIM)
else
CALL REESPE(NKSDIM,SP,GD
& ,NLA,NIBEG,NIEND,NJBEG,NJEND,NKSDIM)
endif
!
!*1. Adjoint of: Undo preconditioning
! --------------------------------
!
call sqrtcgl ! symmetric self-adjoint sub
!
return
end