SUBROUTINE PUTDX2(CDTLMADJ) 9
#if defined (DOC)
*
***s/r PUTDX2 - Communicating Delta X to the TLM
*
*
*Author : P. Gauthier *ARMA/MSC June 15, 2001
*Revision:
* S. Pellerin *ARMA/SMC Nov. 2001
*
* M. Buehner *ARMA/MSC August 2002
* - Added character argument to allow use in SV calculation
*
* S. Pellerin *ARMA/SMC March 2003
* - Added char argument E to allow additional TLM intergration
* for 4Dvar diagnostic purposes
* S. Pellerin, ARMA, August 2008
* - Added calls to 'tmg_*' subroutines
* C. Charette *ARMA/SMC April 2006
* - Added chemistry tracers
*
* ------------------
* Arguments: CDTLMADJ = 'P' write state vector for 4Dvar
* 'F' write state from forward integration for SV
* 'N' write state from nonlinear forward integration for SV
* 'A' write state for adjoint integration for SV
* 'E' write state vector for 4Dvar and request
* additional integration of TLM without
* profile output and adjoint integration
* (event EVN_TLME)
* ------------------
*
* ----------------
* Writes the model state GD0 in the Prof_File 'dwgf.prof'
* Input: GD0(:,:,:)
* Output: Prof_File 'delta_x.type9'
#endif
*
use modstag, only: r1qm2_s, lstagwinds
implicit none
include 'prof_f.h'
#include "pardim.cdk"
#include "comdim.cdk"
#include "comlun.cdk"
#include "comgd0.cdk"
#include "comgem.cdk"
#include "comstate.cdk"
#include "comcva.cdk"
#include "comvfiles.cdk"
#include "comcst.cdk"
#include "comchem.cdk"
*
character CDTLMADJ
*
* local variables
*
integer ihdlin, ihdlout, istat, iulout, istag
integer prof_wrrec, ievent,ininj
*
REAL*8, POINTER::DLBUFF(:,:),DLBUFF2D(:)
INTEGER ICOUNT, JLAT, JLON, JLEV, jj
INTEGER ITRLEV, JTR
character(len=128) :: clprof
character(len=3) :: clsim3d
*
real*8 :: dlconphy_vv(njbeg:njend)
*
* Adjustment for the computation of wind images...
*
if(lstagwinds) then
dlconphy_vv(:) = ra*r1qm2_s(:)
else
dlconphy_vv(:) = conphy(:)
end if
*
if(CDTLMADJ.eq.'E') nsim3d = nsim3d + 1
if(CDTLMADJ.eq.'P' .or. CDTLMADJ.eq.'E') THEN
clprof = trim(CEXC4DV) // '/dwgf.prof'
WRITE(NULOUT,*)'PUTDX2 - SENDING MODEL STATE ON GRID POINTS'
S ,' TO TLM for simulation number ',nsim3d
elseif(CDTLMADJ.eq.'F'.or.CDTLMADJ.eq.'N') THEN
clprof = trim(CEXC4DV) // '/dwgf.prof'
WRITE(NULOUT,*)'PUTDX2 - SENDING MODEL STATE ON GRID POINTS'
S ,' TO TLM for simulation number ',nsim3d
elseif(CDTLMADJ.eq.'A') THEN
clprof = trim(CEXC4DV) // '/dwga1.prof'
WRITE(NULOUT,*)'PUTDX2 - SENDING MODEL STATE ON GRID POINTS'
S ,' TO ADJ for simulation number ',nsim3d
endif
ALLOCATE(DLBUFF(NI*NJ,NFLEV),stat=istat)
IHDLOUT = PROF_OPEN(clprof,'WRITE','FILE')
call mvbits(ni,0,16,ininj,16)
call mvbits(nj,0,16,ininj,0)
istat = prof_pvar(ihdlout,ininj,prm_ninj)
if (lstagwinds) then
istag = 1
else
istag = 0
endif
istat = prof_pvar(ihdlout,istag,prm_stag)
*
* 3D fields
* ----------
*
if(istat == 0) then
IF(NGEXIST(NGUU).EQ.1) THEN
*
DLBUFF(:,:) = 0.
if(CDTLMADJ.eq.'F'.or.CDTLMADJ.eq.'P'.or.CDTLMADJ.eq.'E'.or
& .CDTLMADJ.eq.'N') THEN
DO JLEV = 1, NFLEV
ICOUNT = 0
DO JLAT = 1, NJ
DO JLON = 1, NI
ICOUNT = ICOUNT + 1
DLBUFF(ICOUNT,JLEV) = UT0(JLON,JLEV,JLAT)*conphy(jlat)
END DO
END DO
END DO
elseif(CDTLMADJ.eq.'A') THEN
DO JLEV = 1, NFLEV
ICOUNT = 0
DO JLAT = 1, NJ
DO JLON = 1, NI
ICOUNT = ICOUNT + 1
DLBUFF(ICOUNT,JLEV) = UT0(JLON,JLEV,JLAT)*conima(jlat)
END DO
END DO
END DO
endif
ISTAT = PROF_PVAR(IHDLOUT,DLBUFF,V3D_UTRU) + istat
END IF
*
IF(NGEXIST(NGVV).EQ.1) THEN
DLBUFF(:,:) = 0.
if(CDTLMADJ.eq.'F'.or.CDTLMADJ.eq.'P'.or.CDTLMADJ.eq.'E'.or
& .CDTLMADJ.eq.'N') THEN
DO JLEV = 1, NFLEV
ICOUNT = 0
DO JLAT = 1, NJ
DO JLON = 1, NI
ICOUNT = ICOUNT + 1
DLBUFF(ICOUNT,JLEV) = VT0(JLON,JLEV,JLAT)*dlconphy_vv(jlat)
END DO
END DO
END DO
elseif(CDTLMADJ.eq.'A') THEN
DO JLEV = 1, NFLEV
ICOUNT = 0
DO JLAT = 1, NJ
DO JLON = 1, NI
ICOUNT = ICOUNT + 1
DLBUFF(ICOUNT,JLEV) = VT0(JLON,JLEV,JLAT)*conima(jlat)
END DO
END DO
END DO
endif
ISTAT = PROF_PVAR(IHDLOUT,DLBUFF,V3D_VTRU) + istat
END IF
*
IF(NGEXIST(NGTT).EQ.1) THEN
DLBUFF(:,:) = 0.
DO JLEV = 1, NFLEV
ICOUNT = 0
DO JLAT = 1, NJ
DO JLON = 1, NI
ICOUNT = ICOUNT + 1
DLBUFF(ICOUNT,JLEV) = TT0(JLON,JLEV,JLAT)
END DO
END DO
END DO
ISTAT = PROF_PVAR(IHDLOUT,DLBUFF,V3D_TEMP) + istat
END IF
*
IF(NGEXIST(NGQ).EQ.1) THEN
DLBUFF(:,:) = 0.
DO JLEV = 1, NFLEV
ICOUNT = 0
DO JLAT = 1, NJ
DO JLON = 1, NI
ICOUNT = ICOUNT + 1
DLBUFF(ICOUNT,JLEV) = Q0(JLON,JLEV,JLAT)
END DO
END DO
END DO
ISTAT = PROF_PVAR(IHDLOUT,DLBUFF,V3D_SPHU) + istat
END IF
*
* TRACERS
*
IF(NGCMT .GT. 0) THEN
DO JTR = 1,NGCMT
IF(NGEXIST(NGTR(JTR)).EQ.1) THEN
DLBUFF(:,:) = 0.
DO JLEV = 1, NFLEV
ITRLEV = (JTR-1)*NFLEV + JLEV
ICOUNT = 0
DO JLAT = 1, NJ
DO JLON = 1, NI
ICOUNT = ICOUNT + 1
DLBUFF(ICOUNT,JLEV) = GTR0(JLON,ITRLEV,JLAT)
END DO
END DO
END DO
IF(CGCMT(JTR) .EQ. 'O3') THEN
ISTAT = PROF_PVAR(IHDLOUT,DLBUFF,V3D_O3) + istat
ELSEIF(CGCMT(JTR) .EQ. 'CH4') THEN
ISTAT = PROF_PVAR(IHDLOUT,DLBUFF,V3D_CH4) + istat
ELSEIF(CGCMT(JTR) .EQ. 'N2O') THEN
ISTAT = PROF_PVAR(IHDLOUT,DLBUFF,V3D_N2O) + istat
END IF
END IF
END DO
ENDIF
endif
if(istat == 0) then
ISTAT = PROF_PVAR(IHDLOUT,nsim3d,PRM_EVNT)
C The size of the second dimension of the 3D vectors being different of
C the size of the 2D vectors... 2D vars need to be stored in a different
C record
DEALLOCATE(DLBUFF)
call tmg_start(81,'PROF_R+W')
istat = prof_wrrec(ihdlout)
call tmg_stop(81)
else
ISTAT = PROF_PVAR(IHDLOUT,evn_ferr,PRM_EVNT)
ISTAT = PROF_CLOSE(IHDLOUT)
call abort3d(nulout,'PUTDX2')
endif
*
* 2D fields
*
ALLOCATE(DLBUFF2D(NI*NJ),stat=istat)
!
IF(NGEXIST(NGPS).EQ.1) THEN
DLBUFF2D(:) = 0.
ICOUNT = 0
DO JLAT = 1, NJ
DO JLON = 1, NI
ICOUNT = ICOUNT + 1
DLBUFF2D(ICOUNT) = GPS0(JLON,1,JLAT)
END DO
END DO
ISTAT = PROF_PVAR(IHDLOUT,DLBUFF2D,V2D_PSUR) + istat
END IF
*
IF(NGEXIST(NGTG).EQ.1) THEN
DLBUFF2D(:) = 0.
ICOUNT = 0
DO JLAT = 1, NJ
DO JLON = 1, NI
ICOUNT = ICOUNT + 1
DLBUFF2D(ICOUNT) = GTG0(JLON,1,JLAT)
END DO
END DO
write(nulout,*)'!!!WRITING TG!!!'
ISTAT = PROF_PVAR(IHDLOUT,DLBUFF2D,V2D_TGRN) + istat
END IF
*
if(istat == 0) then
ISTAT = PROF_PVAR(IHDLOUT,nsim3d,PRM_EVNT)
*
* The size of the second dimension of the 3D vectors being different of
C the size of the 2D vectors... 2D vars need to be stored in a different
C record
DEALLOCATE(DLBUFF2D)
call tmg_start(81,'PROF_R+W')
istat = prof_wrrec(ihdlout)
call tmg_stop(81)
ISTAT = PROF_CLOSE(IHDLOUT)
clprof = trim(CEXC4DV) // '/evnt.prof'
if(CDTLMADJ.eq.'P') THEN
WRITE(NULOUT,*)'PUTDX2 - SENDING EVN_TLMO SIGNAL :',EVN_TLMO
IHDLOUT = PROF_OPEN(clprof,'WRITE','FILE')
ISTAT = PROF_PVAR(IHDLOUT,EVN_TLMO,PRM_EVNT)
elseif(CDTLMADJ.eq.'F') THEN
WRITE(NULOUT,*)'PUTDX2 - SENDING EVN_TLMX SIGNAL :',EVN_TLMX
IHDLOUT = PROF_OPEN(clprof,'WRITE','FILE')
ISTAT = PROF_PVAR(IHDLOUT,EVN_TLMX,PRM_EVNT)
elseif(CDTLMADJ.eq.'N') THEN
WRITE(NULOUT,*)'PUTDX2 - SENDING EVN_NLMX SIGNAL :',EVN_NLMX
IHDLOUT = PROF_OPEN(clprof,'WRITE','FILE')
ISTAT = PROF_PVAR(IHDLOUT,EVN_NLMX,PRM_EVNT)
elseif(CDTLMADJ.eq.'A') THEN
WRITE(NULOUT,*)'PUTDX2 - SENDING EVN_ADJX SIGNAL :',EVN_ADJX
IHDLOUT = PROF_OPEN(clprof,'WRITE','FILE')
ISTAT = PROF_PVAR(IHDLOUT,EVN_ADJX,PRM_EVNT)
elseif(CDTLMADJ.eq.'E') THEN
WRITE(NULOUT,*)'PUTDX2 - SENDING EVN_TLME SIGNAL :',EVN_TLME
IHDLOUT = PROF_OPEN(clprof,'WRITE','FILE')
ISTAT = PROF_PVAR(IHDLOUT,EVN_TLME,PRM_EVNT)
endif
call tmg_start(81,'PROF_R+W')
istat = prof_wrrec(ihdlout)
call tmg_stop(81)
ISTAT = PROF_CLOSE(IHDLOUT)
else
ISTAT = PROF_PVAR(IHDLOUT,evn_ferr,PRM_EVNT)
call tmg_start(81,'PROF_R+W')
istat = prof_wrrec(ihdlout)
call tmg_stop(81)
ISTAT = PROF_CLOSE(IHDLOUT)
clprof = trim(CEXC4DV) // '/evnt.prof'
WRITE(NULOUT,*)'PUTDX2 - SENDING EVN_FERR SIGNAL :',EVN_FERR
IHDLOUT = PROF_OPEN(clprof,'WRITE','FILE')
ISTAT = PROF_PVAR(IHDLOUT,EVN_FERR,PRM_EVNT)
call tmg_start(81,'PROF_R+W')
istat = prof_wrrec(ihdlout)
ISTAT = PROF_CLOSE(IHDLOUT)
call tmg_stop(81)
call abort3d(nulout,'PUTDX2')
endif
END SUBROUTINE PUTDX2