!-------------------------------------- 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_rwtraj_apply - Read (Write) from (on) TRAJ WA file at each time step
* in the physics interface
#include "model_macros_f.h"
*
subroutine v4d_rwtraj_apply(F_tdu,F_tdv,F_tdt,F_trm,F_st1,DIST_DIM,Nk) 3,16
*
implicit none
*
integer DIST_DIM,Nk
real F_tdu (DIST_SHAPE,Nk) , F_tdv (DIST_SHAPE,Nk),
$ F_tdt (DIST_SHAPE,Nk) , F_trm(DIST_SHAPE,Nk), F_st1(DIST_SHAPE)
*
*
*author
* S. Laroche
*
*revision
* v3_00 - Laroche S. - initial version (from v4d_rwtraj)
* v3_11 - Tanguay M. - ADJ of digital filter
* v3_30 - Tanguay M. - Validation for LAM Nonhyd
* v3_31 - Tanguay M. - No vmmuld (otherwise may affect itf_phy_apply)
*
*object
* see id section
*
*arguments
* none
*
*implicits
#include "glb_ld.cdk"
#include "lun.cdk"
#include "lctl.cdk"
#include "vt1.cdk"
#include "v4dg.cdk"
#include "schm.cdk"
#include "dcst.cdk"
#include "init.cdk"
#include "rstr.cdk"
*
*modules
integer vmmlod,vmmget,vmmuld
external vmmlod,vmmget,vmmuld
integer pnerr,pnlkey1(1),istep,i,j,k,n,iadd
integer numtr
*
logical plpr_L
*
* Work arrays
* -----------
real work(l_ni*l_nj*l_nk)
*
* ______________________________________________________
*
if(Lctl_step .gt.100 ) call gem_stop('v4d_rwtraj_apply',-1)
* ______________________________________________________
*
numtr = 11
*
* Flag to trace storing and retrieving of trajectory
* --------------------------------------------------
plpr_L = .false.
plpr_L = plpr_L.and.Lun_out.gt.0
*
istep = Lctl_step
*
* Create a monotonic function of time step (istep) to allow for
* unique addresses when digital filter is in use
* -------------------------------------------------------------
if(Init_balgm_L.and.Rstri_idon_L) istep = Lctl_step - (Init_dfnp-1)/2 + Init_dfnp - 1
*
* ----------------
* Read TRAJ Fields
* ----------------
if(V4dg_rwtr.eq.0) then
*
* Recover starting address
* ------------------------
if(V4dg_ad_L) iadd = V4dg_addtab_ad(numtr,istep,1)
if(V4dg_tl_L) iadd = V4dg_addtab_tl(numtr,istep,1)
*
*
* TANGENT LINEAR MODEL
* --------------------
if(V4dg_tl_L) then
*
*
call v4d_rwfld (F_tdu,work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iuntr,iadd,plpr_L,'TDU', V4dg_ad_L,0,-1)
*
call v4d_rwfld (F_tdv,work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iuntr,iadd,plpr_L,'TDV', V4dg_ad_L,0,-1)
*
call v4d_rwfld (F_tdt,work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iuntr,iadd,plpr_L,'TDT', V4dg_ad_L,0,-1)
*
call v4d_rwfld (F_trm,work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iuntr,iadd,plpr_L,'TRM', V4dg_ad_L,0,-1)
*
call v4d_rwfld (F_st1,work,l_ni,l_nj,LDIST_DIM,1,
% V4dg_iuntr,iadd,plpr_L,'ST1', V4dg_ad_L,0,-1)
*
*
**
endif
*
* ADJOINT MODEL
* -------------
if(V4dg_ad_L) then
*
*
call v4d_rwfld (F_st1,work,l_ni,l_nj,LDIST_DIM,1,
% V4dg_iuntr,iadd,plpr_L,'ST1', V4dg_ad_L,
% l_ni*l_nj*l_nk,-1)
*
call v4d_rwfld (F_trm,work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iuntr,iadd,plpr_L,'TRM', V4dg_ad_L,
% l_ni*l_nj*l_nk,-1)
*
call v4d_rwfld (F_tdt,work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iuntr,iadd,plpr_L,'TDT', V4dg_ad_L,
% l_ni*l_nj*l_nk,-1)
*
call v4d_rwfld (F_tdv,work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iuntr,iadd,plpr_L,'TDV', V4dg_ad_L,
% l_ni*l_nj*l_nk,-1)
*
call v4d_rwfld (F_tdu,work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iuntr,iadd,plpr_L,'TDU', V4dg_ad_L,
% l_ni*l_nj*l_nk,-1)
*
endif
*
* -----------------
* Write TRAJ Fields
* -----------------
elseif(V4dg_rwtr.eq.1) then
*
pnlkey1(1) = VMM_KEY(st1)
pnerr = vmmlod(pnlkey1,1)
pnerr = VMM_GET_VAR(st1)
*
* Store starting TLM address
* --------------------------
V4dg_addtab_tl(numtr,istep,1) = V4dg_addtr
iadd = V4dg_addtr
*
call v4d_rwfld (F_tdu,work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iuntr,iadd,plpr_L,'TDU',V4dg_ad_L,0,1)
*
call v4d_rwfld (F_tdv,work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iuntr,iadd,plpr_L,'TDV',V4dg_ad_L,0,1)
*
call v4d_rwfld (F_tdt,work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iuntr,iadd,plpr_L,'TDT',V4dg_ad_L,0,1)
*
call v4d_rwfld (F_trm,work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iuntr,iadd,plpr_L,'TRM',V4dg_ad_L,0,1)
*
call v4d_rwfld (st1,work,l_ni,l_nj,LDIST_DIM,1,
% V4dg_iuntr,iadd,plpr_L,'ST1',V4dg_ad_L,0,1)
*
*
* Store starting ADJOINT address
* ------------------------------
V4dg_addtab_ad(numtr,istep,1) = iadd - l_ni*l_nj
V4dg_addtr = iadd
*
endif
*
C pnerr = vmmuld(-1,0)
*
return
end