!-------------------------------------- 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 PUTDX 2,2
#if defined (DOC)
*
***s/r PUTDX - Communicating Delta X to the TLM
*
*
*Author : P. Gauthier *ARMA/MSC June 15, 2001
*Revision:
* S. Pellerin *ARMA/SMC Nov. 2001
* Luc Fillion - ARMA/EC - Mar 2005 - Introduce LAM4D.
* Luc Fillion - ARMA/EC - 14 Aug 2007 - Update to v_10_0_3.
*
* ----------------
* Writes the model state GD0 in the Prof_File 'dwgf.prof'
* Input: GD0(:,:,:)
* Output: Prof_File 'delta_x.type9'
#endif
*
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 "comgrd_param.cdk"
*
* local variables
integer ini,inj
integer ihdlin, ihdlout, istat, iulout
integer prof_wrrec, prof_rdrec,ievent,ininj
*
REAL*8, POINTER::DLBUFF(:,:),DLBUFF2D(:)
INTEGER ICOUNT, JLAT, JLON, JLEV, jj
character(len=128) :: clprof
character(len=3) :: clsim3d
*
*
clprof = trim(CEXC4DV) // '/dwgf.prof'
WRITE(NULOUT,*)'PUTDX - SENDING MODEL STATE ON GRID POINTS'
S ,' TO TLM for simulation number ',nsim3d
!
if(grd_typ.eq.'LU') then
ini = mni_in
inj = mnj_in
else
ini = ni
inj = nj
endif
!
ALLOCATE(DLBUFF(ini*inj,NFLEV),stat=istat)
IHDLOUT = PROF_OPEN(clprof,'WRITE','FILE')
call mvbits(inj,0,16,ininj,16)
call mvbits(inj,0,16,ininj,0)
! istat = prof_pvar(ihdlout,ininj,prm_ninj)
! istat = prof_pvar(ihdlout,nsim3d,prm_evnt)
! istat = prof_wrrec(ihdlout)
*
* 3D fields
* ----------
*
if(istat == 0) then
IF(NGEXIST(NGUU).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) = UT0(JLON,JLEV,JLAT)*conphy(jlat)
END DO
END DO
END DO
ISTAT = PROF_PVAR(IHDLOUT,DLBUFF,V3D_UTRU) + istat
END IF
*
IF(NGEXIST(NGVV).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) = VT0(JLON,JLEV,JLAT)*conphy(jlat)
END DO
END DO
END DO
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, 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,ininj,prm_ninj)
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)
istat = prof_wrrec(ihdlout)
else
ISTAT = PROF_PVAR(IHDLOUT,evn_ferr,PRM_EVNT)
ISTAT = PROF_CLOSE(IHDLOUT)
call abort3d(nulout,'PUTDX')
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
ISTAT = PROF_PVAR(IHDLOUT,DLBUFF2D,V2D_TGRN) + istat
END IF
*
if(istat == 0) then
istat = prof_pvar(ihdlout,ininj,prm_ninj)
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)
istat = prof_wrrec(ihdlout)
ISTAT = PROF_CLOSE(IHDLOUT)
clprof = trim(CEXC4DV) // '/evnt.prof'
WRITE(NULOUT,*)'PUTDX - SENDING EVN_TLMO SIGNAL :',EVN_TLMO
IHDLOUT = PROF_OPEN(clprof,'WRITE','FILE')
ISTAT = PROF_PVAR(IHDLOUT,EVN_TLMO,PRM_EVNT)
istat = prof_wrrec(ihdlout)
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,*)'PUTDX - SENDING EVN_FERR SIGNAL :',EVN_FERR
IHDLOUT = PROF_OPEN(clprof,'WRITE','FILE')
ISTAT = PROF_PVAR(IHDLOUT,EVN_FERR,PRM_EVNT)
istat = prof_wrrec(ihdlout)
ISTAT = PROF_CLOSE(IHDLOUT)
call abort3d(nulout,'PUTDX')
endif
END SUBROUTINE PUTDX