!-------------------------------------- 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 --------------------------------------
***s/r v4d_rwobfr- 1)Read (Write) from (on) OBSERVATIONS WA file at required time step
* - 2)Read (Write) from (on) FORCINGS WA file at required time step
*
#include "model_macros_f.h"
*
subroutine v4d_rwobfr (F_icode) 4,28
*
#include "impnone.cdk"
*
integer F_icode
*
*author
* M.Tanguay
*
*revision
* v2_10 - Tanguay M. - initial MPI version
* v2_31 - Tanguay M. - change parameters of v4d_rwfld
* v3_01 - Morneau J. - add V4dg_rwob.eq.2 to write
* observations from OBSERVATION VMM variable
*
*object
* see id section
*
*arguments
* Name I/O Description
*----------------------------------------------------------------
* F_icode I If F_icode=1 :Treat OBSERVATIONS
* If F_icode=2 :Treat FORCINGS
*----------------------------------------------------------------
*
*implicits
#include "glb_ld.cdk"
#include "lun.cdk"
#include "v4dg.cdk"
#include "v4d_vmm.cdk"
#include "vt1.cdk"
*
*modules
integer vmmlod,vmmget,vmmuld
external vmmlod,vmmget,vmmuld
*
integer pnerr, pnlkey1(4)
*
logical plpr_L
*
real work(l_ni,l_nj,l_nk)
*
* ----------------------------------------------------
* Flag to trace storing and retrieving of observations
* ----------------------------------------------------
plpr_L = .false.
plpr_L = plpr_L.and.Lun_out.gt.0
*
* ------------------
* Treat OBSERVATIONS
* ------------------
if(F_icode.eq.1) then
*
if(V4dg_rwob.eq.0) then
if (lun_out > 0) write(lun_out,9000)
* ----------------------------
* Read OBSERVATIONS at time T1
* ----------------------------
*
pnlkey1(1) = VMM_KEY(ut1r )
pnlkey1(2) = VMM_KEY(vt1r )
pnlkey1(3) = VMM_KEY(tpt1r)
pnlkey1(4) = VMM_KEY(st1r )
*
* - - - - - - - - - - - - -
pnerr = vmmlod(pnlkey1,4)
* - - - - - - - - - - - - -
pnerr = VMM_GET_VAR(ut1r )
pnerr = VMM_GET_VAR(vt1r )
pnerr = VMM_GET_VAR(tpt1r)
pnerr = VMM_GET_VAR(st1r )
*
* NLM or TLM run
* --------------
if(V4dg_di_L.or.V4dg_tl_L) then
*
call v4d_rwfld (ut1r, work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iunob,V4dg_addob,plpr_L,'UT1R', V4dg_ad_L,0,-1)
*
call v4d_rwfld (vt1r, work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iunob,V4dg_addob,plpr_L,'VT1R', V4dg_ad_L,0,-1)
*
call v4d_rwfld (tpt1r,work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iunob,V4dg_addob,plpr_L,'TPT1R',V4dg_ad_L,0,-1)
*
call v4d_rwfld (st1r, work,l_ni,l_nj,LDIST_DIM,1,
% V4dg_iunob,V4dg_addob,plpr_L,'ST1R', V4dg_ad_L,0,-1)
*
* ADJ run
* -------
elseif(V4dg_ad_L) then
*
call v4d_rwfld (st1r, work,l_ni,l_nj,LDIST_DIM,1,
% V4dg_iunob,V4dg_addob,plpr_L,'ST1R ',V4dg_ad_L,
% l_ni*l_nj*l_nk,-1)
*
call v4d_rwfld (tpt1r,work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iunob,V4dg_addob,plpr_L,'TPT1R',V4dg_ad_L,
% l_ni*l_nj*l_nk,-1)
*
call v4d_rwfld (vt1r, work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iunob,V4dg_addob,plpr_L,'VT1R ',V4dg_ad_L,
% l_ni*l_nj*l_nk,-1)
*
call v4d_rwfld (ut1r, work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iunob,V4dg_addob,plpr_L,'UT1R ',V4dg_ad_L,
% l_ni*l_nj ,-1)
*
endif
*
elseif(V4dg_rwob.eq.1) then
if (lun_out > 0) write(lun_out,9010)
* -----------------------------
* Write OBSERVATIONS at time T1
* -----------------------------
*
pnlkey1(1) = VMM_KEY(ut1 )
pnlkey1(2) = VMM_KEY(vt1 )
pnlkey1(3) = VMM_KEY(tpt1)
pnlkey1(4) = VMM_KEY(st1 )
*
* - - - - - - - - - - - - -
pnerr = vmmlod(pnlkey1,4)
* - - - - - - - - - - - - -
pnerr = VMM_GET_VAR(ut1 )
pnerr = VMM_GET_VAR(vt1 )
pnerr = VMM_GET_VAR(tpt1)
pnerr = VMM_GET_VAR(st1 )
*
call v4d_rwfld (ut1, work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iunob,V4dg_addob,plpr_L,'UT1 ',V4dg_ad_L,0,1)
*
call v4d_rwfld (vt1, work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iunob,V4dg_addob,plpr_L,'VT1 ',V4dg_ad_L,0,1)
*
call v4d_rwfld (tpt1,work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iunob,V4dg_addob,plpr_L,'TPT1',V4dg_ad_L,0,1)
*
call v4d_rwfld (st1, work,l_ni,l_nj,LDIST_DIM,1,
% V4dg_iunob,V4dg_addob,plpr_L,'ST1 ',V4dg_ad_L,0,1)
*
elseif(V4dg_rwob.eq.2) then
if (lun_out > 0) write(lun_out,9010)
* -----------------------------
* Write OBSERVATIONS at time T1
* -----------------------------
*
pnlkey1(1) = VMM_KEY(ut1r )
pnlkey1(2) = VMM_KEY(vt1r )
pnlkey1(3) = VMM_KEY(tpt1r)
pnlkey1(4) = VMM_KEY(st1r )
*
* - - - - - - - - - - - - -
pnerr = vmmlod(pnlkey1,4)
* - - - - - - - - - - - - -
pnerr = VMM_GET_VAR(ut1r )
pnerr = VMM_GET_VAR(vt1r )
pnerr = VMM_GET_VAR(tpt1r)
pnerr = VMM_GET_VAR(st1r )
*
call v4d_rwfld (ut1r, work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iunob,V4dg_addob,plpr_L,'UT1R',V4dg_ad_L,0,1)
*
call v4d_rwfld (vt1r, work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iunob,V4dg_addob,plpr_L,'VT1R',V4dg_ad_L,0,1)
*
call v4d_rwfld (tpt1r,work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iunob,V4dg_addob,plpr_L,'TPT1R',V4dg_ad_L,0,1)
*
call v4d_rwfld (st1r, work,l_ni,l_nj,LDIST_DIM,1,
% V4dg_iunob,V4dg_addob,plpr_L,'ST1R ',V4dg_ad_L,0,1)
*
endif
*
endif
*
* --------------
* Treat FORCINGS
* --------------
if(F_icode.eq.2) then
*
if(V4dg_rwfr.eq.0) then
if (lun_out > 0) write(lun_out,9050)
* -----------------------------------------
* Read fields needed in FORCINGS at time T1
* -----------------------------------------
*
pnlkey1(1) = VMM_KEY(ut1c )
pnlkey1(2) = VMM_KEY(vt1c )
pnlkey1(3) = VMM_KEY(tpt1c)
pnlkey1(4) = VMM_KEY(st1c )
*
* - - - - - - - - - - - - -
pnerr = vmmlod(pnlkey1,4)
* - - - - - - - - - - - - -
pnerr = VMM_GET_VAR(ut1c )
pnerr = VMM_GET_VAR(vt1c )
pnerr = VMM_GET_VAR(tpt1c)
pnerr = VMM_GET_VAR(st1c )
*
* NLM or TLM run
* --------------
if(V4dg_di_L.or.V4dg_tl_L) then
*
call v4d_rwfld (ut1c,work, l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iunfr,V4dg_addfr,plpr_L,'UT1C ',V4dg_ad_L,0,-1)
*
call v4d_rwfld (vt1c,work, l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iunfr,V4dg_addfr,plpr_L,'VT1C ',V4dg_ad_L,0,-1)
*
call v4d_rwfld (tpt1c,work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iunfr,V4dg_addfr,plpr_L,'TPT1C',V4dg_ad_L,0,-1)
*
call v4d_rwfld (st1c,work, l_ni,l_nj,LDIST_DIM,1,
% V4dg_iunfr,V4dg_addfr,plpr_L,'ST1C ',V4dg_ad_L,0,-1)
*
elseif(V4dg_ad_L) then
*
call v4d_rwfld (st1c, work,l_ni,l_nj,LDIST_DIM,1,
% V4dg_iunfr,V4dg_addfr,plpr_L,'ST1C ',V4dg_ad_L,
% l_ni*l_nj*l_nk,-1)
*
call v4d_rwfld (tpt1c,work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iunfr,V4dg_addfr,plpr_L,'TPT1C',V4dg_ad_L,
% l_ni*l_nj*l_nk,-1)
*
call v4d_rwfld (vt1c, work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iunfr,V4dg_addfr,plpr_L,'VT1C ',V4dg_ad_L,
% l_ni*l_nj*l_nk,-1)
*
call v4d_rwfld (ut1c, work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iunfr,V4dg_addfr,plpr_L,'UT1C ',V4dg_ad_L,
% l_ni*l_nj ,-1)
*
endif
*
elseif(V4dg_rwfr.eq.1) then
if (lun_out > 0) write(lun_out,9060)
* ------------------------------------------
* Write fields needed in FORCINGS at time T1
* ------------------------------------------
*
pnlkey1(1) = VMM_KEY(ut1 )
pnlkey1(2) = VMM_KEY(vt1 )
pnlkey1(3) = VMM_KEY(tpt1)
pnlkey1(4) = VMM_KEY(st1 )
*
* - - - - - - - - - - - - -
pnerr = vmmlod(pnlkey1,4)
* - - - - - - - - - - - - -
pnerr = VMM_GET_VAR(ut1 )
pnerr = VMM_GET_VAR(vt1 )
pnerr = VMM_GET_VAR(tpt1)
pnerr = VMM_GET_VAR(st1 )
*
call v4d_rwfld (ut1, work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iunfr,V4dg_addfr,plpr_L,'UT1 ',V4dg_ad_L,0,1)
*
call v4d_rwfld (vt1, work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iunfr,V4dg_addfr,plpr_L,'VT1 ',V4dg_ad_L,0,1)
*
call v4d_rwfld (tpt1,work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iunfr,V4dg_addfr,plpr_L,'TPT1',V4dg_ad_L,0,1)
*
call v4d_rwfld (st1, work,l_ni,l_nj,LDIST_DIM,1,
% V4dg_iunfr,V4dg_addfr,plpr_L,'ST1 ',V4dg_ad_L,0,1)
*
endif
*
endif
*
pnerr = vmmuld(-1,0)
if (lun_out > 0) write(Lun_out,9900)
*
9000 format(
+/,'BEGIN READ OBSERVATION WA FILES (V4D_RWOBFR)',
+/,'===================================================')
9010 format(
+/,'BEGIN WRITE OBSERVATION WA FILES (V4D_RWOBFR)',
+/,'===================================================')
9050 format(
+/,'BEGIN READ FORCINGS WA FILES (V4D_RWOBFR)',
+/,'===================================================')
9060 format(
+/,'BEGIN WRITE FORCINGS WA FILES (V4D_RWOBFR)',
+/,'===================================================')
9900 format(
+/,'END R/W OBS/FORCING WA FILES (V4D_RWOBFR)',
+/,'===================================================')
*
return
end