subroutine getdx(CDTLMADJ) 11
*
* Author: Simon
*
* Purpose: Get Adjoint values of perturbations from adjoint
* model
* Revisions:
* M. Tanguay *RPN/SMC Feb. 2002
* - Add adjust for change of norm
* - Fix to adjoint image winds->true winds conversion
* M. Buehner *ARMA/MSC August 2002
* - Added character argument to allow use in SV calculation
* P. Gauthier *ARMA/MSC August 2003
* . Adjustment for staggered winds
* S. Pellerin, ARMA, August 2008
* .Added calls to 'tmg_*' subroutines
* C. Charette ARMA 2007
* .Added TR family
*
* ------------------
* Arguments: CDTLMADJ = 'A' read adjoint state vector for 4Dvar or SV
* 'X' read adjoint state for SV without norm adjustment (RWT)
* 'F' read state from forward integration for SV
* ------------------
use modstag, only: r1qm2_s, lstagwinds
implicit none
*
include 'prof_f.h'
#include "comlun.cdk"
#include "comdim.cdk"
#include "comcva.cdk"
#include "comstate.cdk"
#include "comgd0.cdk"
#include "pardim.cdk"
#include "comgem.cdk"
#include "comvfiles.cdk"
#include "comleg.cdk"
#include "comcst.cdk"
#include "comchem.cdk"
*
character CDTLMADJ
*
* Local variables
*
integer :: prof_rdrec,ihdl,istat,ievent,prof_wrrec
integer :: jlev,icount,jlat, jlon,idim2d, jgl, imax, jstag
INTEGER :: ITRLEV, JTR
integer, dimension(2) :: idim
character (len=128) :: clprof
real*8, pointer, dimension(:,:) :: zbuff
real*8, pointer, dimension(:) :: zbuff2d
*
real*8 :: dlconphy_vv(njbeg:njend)
*
nullify(zbuff,zbuff2d)
* Opening Prof_File
*
if(CDTLMADJ.eq.'A'.or.CDTLMADJ.eq.'X') THEN
clprof = trim(CEXC4DV) // '/dwga.prof'
write(nulout,*
& )'GETDX: Reading adjoint data from simulation no. ',nsim3d
elseif(CDTLMADJ.eq.'F') THEN
clprof = trim(CEXC4DV) // '/dwgf1.prof'
write(nulout,*
& )'GETDX: Reading TLM data from simulation no. ',nsim3d
endif
write(nulout,*) 'BEFORE PROF_OPEN'
call vflush(nulout)
call tmg_start(82,'I/O_WAIT')
ihdl = prof_open(clprof,'READ','FILE')
call tmg_stop(82)
write(nulout,*) 'AFTER PROF_OPEN'
call vflush(nulout)
call tmg_start(81,'PROF_R+W')
istat = prof_rdrec(ihdl)
call tmg_stop(81)
istat = prof_gvar(ihdl,ievent,prm_evnt)
if(ievent.eq.nsim3d) then
write(nulout,*) 'GETDX: Data received for simulation no. '
& ,ievent
if(ngexist(nguu).eq.1) then
istat = prof_gvar(ihdl,zbuff,v3d_utru)
idim = ubound(zbuff)
if (ni*nj.ne.idim(1)) then
write(nulout,*) 'IN GETDXAD, BUFFER has NI*NJ = '
S ,idim(1),' NFLEV = ',idim(2)
write(nulout,*) 'Internal dimensions are Ni = ', ni
S ,' NJ = ',nj,' NFLEV = ',nflev
call abort3d(nulout
& ,'GETDXAD- Inconsistent model states FOR UU')
end if
if(CDTLMADJ.eq.'A'.or.CDTLMADJ.eq.'X') THEN
do jlev = 1, nflev
icount = 0
do jlat = 1, nj
do jlon = 1, ni
icount = icount + 1
ut0(jlon,jlev,jlat) = zbuff(icount,jlev)*conphy(jlat)
end do
end do
end do
elseif(CDTLMADJ.eq.'F') THEN
do jlev = 1, nflev
icount = 0
do jlat = 1, nj
do jlon = 1, ni
icount = icount + 1
ut0(jlon,jlev,jlat) = zbuff(icount,jlev)/conphy(jlat)
end do
end do
end do
endif
end if
*
if(ngexist(ngvv).eq.1) then
if(lstagwinds) then
dlconphy_vv(:) = ra*r1qm2_s(:)
else
dlconphy_vv(:) = conphy(:)
end if
istat = prof_gvar(ihdl,zbuff,v3d_vtru)
idim = ubound(ZBUFF)
if (ni*nj.ne.idim(1)) then
write(nulout,*) 'IN GETDXAD, BUFFER has NI*NJ = '
S ,idim(1),' NFLEV = ',idim(2)
write(nulout,*) 'Internal dimensions are Ni = ', ni
S ,' NJ = ',nj,' NFLEV = ',nflev
call abort3d(nulout
& ,'GETDXAD- Inconsistent model states FOR VV')
end if
if(CDTLMADJ.eq.'A'.or.CDTLMADJ.eq.'X') THEN
if (lstagwinds) then
jstag = nj -1
else
jstag = nj
endif
do jlev = 1, nflev
icount = 0
do jlat = 1, jstag
do jlon = 1, ni
icount = icount + 1
vt0(jlon,jlev,jlat) = zbuff(icount,jlev)*dlconphy_vv(jlat)
end do
end do
end do
elseif(CDTLMADJ.eq.'F') THEN
if (lstagwinds) then
jstag = nj -1
else
jstag = nj
endif
do jlev = 1, nflev
icount = 0
do jlat = 1, jstag
do jlon = 1, ni
icount = icount + 1
vt0(jlon,jlev,jlat) = zbuff(icount,jlev)/dlconphy_vv(jlat)
end do
end do
end do
endif
end if
*
if(ngexist(ngtt).eq.1) then
ISTAT = PROF_GVAR(IHDL,ZBUFF,V3D_TEMP)
IDIM = UBOUND(ZBUFF)
IF (NI*NJ.NE.IDIM(1)) THEN
WRITE(NULOUT,*) 'IN GETDXAD, BUFFER has NI*NJ = '
S ,idim(1),' NFLEV = ',idim(2)
write(nulout,*) 'Internal dimensions are Ni = ', ni
S ,' NJ = ',nj,' NFLEV = ',nflev
call abort3d(nulout
& ,'GETDXAD- Inconsistent model states FOR TT')
end if
DO JLEV = 1, NFLEV
ICOUNT = 0
DO JLAT = 1, NJ
DO JLON = 1, NI
ICOUNT = ICOUNT + 1
TT0(JLON,JLEV,JLAT) = ZBUFF(ICOUNT,JLEV)
END DO
END DO
END DO
END IF
*
IF(NGEXIST(NGQ).EQ.1) THEN
ISTAT = PROF_GVAR(IHDL,ZBUFF,V3D_SPHU)
IDIM = UBOUND(ZBUFF)
IF (NI*NJ.NE.IDIM(1)) THEN
WRITE(NULOUT,*) 'IN GETDXAD, BUFFER has NI*NJ = '
S ,idim(1),' NFLEV = ',idim(2)
write(nulout,*) 'Internal dimensions are Ni = ', ni
S ,' NJ = ',nj,' NFLEV = ',nflev
call abort3d(nulout
& ,'GETDXAD- Inconsistent model states FOR Q')
end if
DO JLEV = 1, NFLEV
ICOUNT = 0
DO JLAT = 1, NJ
DO JLON = 1, NI
ICOUNT = ICOUNT + 1
Q0(JLON,JLEV,JLAT) = ZBUFF(ICOUNT,JLEV)
END DO
END DO
END DO
END IF
*
* TRACERS
*
IF(NGCMT .GT. 0) THEN
DO JTR = 1,NGCMT
IF(NGEXIST(NGTR(JTR)).EQ.1) THEN
IF(CGCMT(JTR) .EQ. 'O3') THEN
ISTAT = PROF_GVAR(IHDL,ZBUFF,V3D_O3)
ELSEIF(CGCMT(JTR) .EQ. 'CH4') THEN
ISTAT = PROF_GVAR(IHDL,ZBUFF,V3D_CH4)
ELSEIF(CGCMT(JTR) .EQ. 'N2O') THEN
ISTAT = PROF_GVAR(IHDL,ZBUFF,V3D_N2O)
END IF
IDIM = UBOUND(ZBUFF)
IF (NI*NJ.NE.IDIM(1)) THEN
WRITE(NULOUT,*) 'IN GETDXAD, BUFFER has NI*NJ = '
S ,idim(1),' NFLEV = ',idim(2)
write(nulout,*) 'Internal dimensions are Ni = ', ni
S ,' NJ = ',nj,' NFLEV = ',nflev
write(nulout,*) 'Inconsistent model states FOR TRACER= '
& ,CGCMT(JTR)
call abort3d(nulout
& ,'GETDXAD- Inconsistent model states FOR TRACER')
end if
DO JLEV = 1, NFLEV
ITRLEV = (JTR-1)*NFLEV + JLEV
ICOUNT = 0
DO JLAT = 1, NJ
DO JLON = 1, NI
ICOUNT = ICOUNT + 1
GTR0(JLON,ITRLEV,JLAT) = ZBUFF(ICOUNT,JLEV)
END DO
END DO
END DO
END IF
END DO
ENDIF
*
deallocate(ZBUFF)
call tmg_start(81,'PROF_R+W')
istat = prof_rdrec(ihdl)
call tmg_stop(81)
istat = prof_gvar(ihdl,ievent,prm_evnt) + istat
IF(NGEXIST(NGPS).EQ.1) THEN
ISTAT = PROF_GVAR(IHDL,ZBUFF2D,V2D_PSUR)
IDIM2D = UBOUND(ZBUFF2D,1)
IF (NI*NJ.NE.IDIM2D) THEN
WRITE(NULOUT,*) 'IN GETDXAD, BUFFER2D has NI*NJ = '
S ,idim2d
write(nulout,*) 'Internal dimensions should be Ni = ', ni
S ,' NJ = ',nj,' NFLEV = ',nflev
call abort3d(nulout
& ,'GETDXAD- Inconsistent model states FOR PS')
end if
*
ICOUNT = 0
DO JLAT = 1, NJ
DO JLON = 1, NI
ICOUNT = ICOUNT + 1
GPS0(JLON,1,JLAT)= ZBUFF2D(ICOUNT)
END DO
END DO
END IF
*
IF(NGEXIST(NGTG).EQ.1) THEN
c ISTAT = PROF_GVAR(IHDL,ZBUFF2D,V2D_TGRN)
c IDIM2D = UBOUND(ZBUFF2D,1)
c IF (NI*NJ.NE.IDIM2D) THEN
c WRITE(NULOUT,*) 'IN GETDXAD, BUFFER2D has NI*NJ = '
c S ,idim2d
c write(nulout,*) 'Internal dimensions should be Ni = ', ni
c S ,' NJ = ',nj,' NFLEV = ',nflev
c call abort3d(nulout
c & ,'GETDXAD- Inconsistent model states for PS')
c end if
c *
c ICOUNT = 0
c DO JLAT = 1, NJ
c DO JLON = 1, NI
c ICOUNT = ICOUNT + 1
c GTG0(JLON,1,JLAT)= ZBUFF2D(ICOUNT)
c END DO
c END DO
ICOUNT = 0
DO JLAT = 1, NJ
DO JLON = 1, NI
ICOUNT = ICOUNT + 1
GTG0(JLON,1,JLAT)= 0.0
END DO
END DO
END IF
*
deallocate (ZBUFF2D)
istat = prof_close(ihdl,.true.)
*
* Add adjustment for change of norm as in BILINAD
* -----------------------------------------------
if(CDTLMADJ.eq.'A') THEN
do jgl = 1, nj
imax = nilon(jgl)
do jlev = 1, nkgdim
do jlon = 1, imax
gd(jlon,jlev,jgl) = gd(jlon,jlev,jgl) *
+ nilon(jgl) / rwt(jgl)
enddo
enddo
enddo
endif
else
write(nulout,*)
& 'GETDXAD - ERROR - ABNORMAL TERMINATION : ievent = ',ievent
clprof = 'dwgf.prof'
IHDL = PROF_OPEN(clprof,'WRITE','FILE')
ISTAT = PROF_PVAR(IHDL,evn_ferr,PRM_EVNT)
call tmg_start(81,'PROF_R+W')
istat = prof_wrrec(ihdl)
istat = prof_close(ihdl)
call tmg_stop(81)
call abort3d(nulout,'GETDXAD')
endif
*
end subroutine getdx