!-------------------------------------- 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 PUTDX2(CDTLMADJ) 20,3
#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
* L. Fillion *ARMA/SMC 16 May 2005 - Allow Limited-Area Analysis Option.
* L. Fillion *ARMA/SMC 14 Dec 2005 - Transfer only non-extended fields; i.e. (mni_in,mnj_in)
* L. Fillion *ARMA/EC 6 Apr 2006 - INMI option: TL.
* L. Fillion *ARMA/EC 10 may 2007 - INMI option: ADJ.
* L. Fillion *ARMA/EC 14 Aug 2007 - Update to v_10_0_3.
* L. Fillion *ARMA/EC 12 Jan 2009 - Update to v_10_1_2.
* ------------------
* 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)
* 'I' write initial state for short forward time integration required by INMI.
* 'J' write state for adjoint integration for INMI
* ------------------
*
* ----------------
* 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 "comgrd_param.cdk"
#include "comgemla.cdk"
#include "comgdpar.cdk"
*
character CDTLMADJ
*
* local variables
*
integer ini,inj
integer ihdlin, ihdlout, istat, iulout, istag
integer prof_wrrec, ievent,ininj
*
REAL*8, POINTER::DLBUFF(:,:),DLBUFF2D(:)
REAL*8, POINTER::z3d(:,:,:)
integer ICOUNT, JLAT, JLON, JLEV, ji,jj,jk
integer idum1,idum2,idum3,idum4
character(len=128) :: clprof
character(len=3) :: clsim3d
*
real*8 zmin,zmax
real*8 :: dlconphy_vv(njbeg:njend)
*
* Adjustment for the computation of wind images...
*
if(grd_typ.eq.'LU') then
ini = mni_in
inj = mnj_in
else
ini = ni
inj = nj
endif
!
if(lstagwinds) then
if(grd_typ.ne.'LU') then
dlconphy_vv(:) = ra*r1qm2_s(:)
else
do jj=1,inj
dlconphy_vv(jj) = rrcos_an(1,jj) ! 1./cosh(theta)
enddo
endif
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'.or.CDTLMADJ.eq.'I'.or.CDTLMADJ.eq.'K') 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'.or.CDTLMADJ.eq.'J'.or.CDTLMADJ.eq.'L') 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(ini*inj,NFLEV),stat=istat)
ALLOCATE(z3d(ini,NFLEV,inj),stat=istat)
IHDLOUT = PROF_OPEN(clprof,'WRITE','FILE')
call mvbits(ini,0,16,ininj,16)
call mvbits(inj,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
*
do jk=1,nflev
do jj=1,inj
do ji=1,ini
z3d(ji,jk,jj)=ut0(ji,jk,jj)
enddo
enddo
enddo
! call maxmin(z3d,ini,inj,nflev,zmin,zmax,
! & idum1,idum2,idum3,idum4,'putdx2 ',
! & 'U0')
!
DLBUFF(:,:) = 0.
if(CDTLMADJ.eq.'F'.or.CDTLMADJ.eq.'P'.or.CDTLMADJ.eq.'E'.or
& .CDTLMADJ.eq.'N'.or.CDTLMADJ.eq.'I'.or.CDTLMADJ.eq.'K') THEN
DO JLEV = 1, NFLEV
ICOUNT = 0
DO JLAT = 1, inj
DO JLON = 1, ini
ICOUNT = ICOUNT + 1
DLBUFF(ICOUNT,JLEV) = UT0(JLON,JLEV,JLAT)*conphy(jlat)
END DO
END DO
END DO
elseif(CDTLMADJ.eq.'A'.or.CDTLMADJ.eq.'J'.or.CDTLMADJ.eq.'L') THEN
DO JLEV = 1, NFLEV
ICOUNT = 0
DO JLAT = 1, inj
DO JLON = 1, ini
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
do jk=1,nflev
do jj=1,inj
do ji=1,ini
z3d(ji,jk,jj)=vt0(ji,jk,jj)
enddo
enddo
enddo
! call maxmin(z3d,ini,inj,nflev,zmin,zmax,
! & idum1,idum2,idum3,idum4,'putdx2 ',
! & 'V0')
DLBUFF(:,:) = 0.
if(CDTLMADJ.eq.'F'.or.CDTLMADJ.eq.'P'.or.CDTLMADJ.eq.'E'.or
& .CDTLMADJ.eq.'N'.or.CDTLMADJ.eq.'I'.or.CDTLMADJ.eq.'K') THEN
DO JLEV = 1, NFLEV
ICOUNT = 0
DO JLAT = 1, inj
DO JLON = 1, ini
ICOUNT = ICOUNT + 1
DLBUFF(ICOUNT,JLEV) = VT0(JLON,JLEV,JLAT)*dlconphy_vv(jlat)
END DO
END DO
END DO
elseif(CDTLMADJ.eq.'A'.or.CDTLMADJ.eq.'J'.or.CDTLMADJ.eq.'L') THEN
DO JLEV = 1, NFLEV
ICOUNT = 0
DO JLAT = 1, inj
DO JLON = 1, ini
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
do jk=1,nflev
do jj=1,inj
do ji=1,ini
z3d(ji,jk,jj)=tt0(ji,jk,jj)
enddo
enddo
enddo
! call maxmin(z3d,ini,inj,nflev,zmin,zmax,
! & idum1,idum2,idum3,idum4,'putdx2 ',
! & 'T0')
DLBUFF(:,:) = 0.
DO JLEV = 1, NFLEV
ICOUNT = 0
DO JLAT = 1, inj
DO JLON = 1, ini
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, inj
DO JLON = 1, ini
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
endif
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(DLBUFF)
DEALLOCATE(z3d)
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(ini*inj),stat=istat)
!
IF(NGEXIST(NGPS).EQ.1) THEN
DLBUFF2D(:) = 0.
ICOUNT = 0
DO JLAT = 1, inj
DO JLON = 1, ini
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, inj
DO JLON = 1, ini
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)
elseif(CDTLMADJ.eq.'I') THEN
WRITE(NULOUT,*)'PUTDX2 - SENDING EVN_TLMI SIGNAL :',EVN_TLMI
IHDLOUT = PROF_OPEN(clprof,'WRITE','FILE')
ISTAT = PROF_PVAR(IHDLOUT,EVN_TLMI,PRM_EVNT)
elseif(CDTLMADJ.eq.'J') THEN
WRITE(NULOUT,*)'PUTDX2 - SENDING EVN_ADJI SIGNAL :',EVN_ADJI
IHDLOUT = PROF_OPEN(clprof,'WRITE','FILE')
ISTAT = PROF_PVAR(IHDLOUT,EVN_ADJI,PRM_EVNT)
elseif(CDTLMADJ.eq.'K') THEN
WRITE(NULOUT,*)'PUTDX2 - SENDING EVN_TLMJ SIGNAL :',EVN_TLMJ
IHDLOUT = PROF_OPEN(clprof,'WRITE','FILE')
ISTAT = PROF_PVAR(IHDLOUT,EVN_TLMJ,PRM_EVNT)
elseif(CDTLMADJ.eq.'L') THEN
WRITE(NULOUT,*)'PUTDX2 - SENDING EVN_ADJJ SIGNAL :',EVN_ADJJ
IHDLOUT = PROF_OPEN(clprof,'WRITE','FILE')
ISTAT = PROF_PVAR(IHDLOUT,EVN_ADJJ,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)
istat = prof_wrrec(ihdlout)
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