!-------------------------------------- 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_phystep - Read (Write) from (on) TRAJ WA file at each time step
* in the physics interface
#include "model_macros_f.h"
*
subroutine v4d_rwtraj_phystep(F_up,F_vp,F_tp,F_qp,F_trp, 3,27
$ F_um,F_vm,F_tm ,F_trm,
$ DIST_DIM,Nk)
*
implicit none
*
integer DIST_DIM,Nk
real F_up (DIST_SHAPE,Nk) , F_vp (DIST_SHAPE,Nk),
$ F_tp (DIST_SHAPE,Nk) , F_qp (DIST_SHAPE,Nk),
$ F_trp(DIST_SHAPE,Nk) ,
$ F_um (DIST_SHAPE,Nk) , F_vm (DIST_SHAPE,Nk),
$ F_tm (DIST_SHAPE,Nk) , F_trm(DIST_SHAPE,Nk)
*
*author
* S. Laroche
*
*revision
* v3_00 - Laroche S. - initial version (from v4d_rwtraj)
* v3_01 - Laroche S. - check if hucond.ne.1
* v3_03 - Tanguay M. - adapt to changes in v4d_rwtraj
* v3_11 - Tanguay M. - ADJ of digital filter
* v3_30 - Tanguay M. - adapt TL/AD to itf
* - Validation for LAM Nonhyd
*
*object
* see id section
*
*arguments
* none
*
*implicits
#include "glb_ld.cdk"
#include "lun.cdk"
#include "lctl.cdk"
#include "v4dg.cdk"
#include "cstv.cdk"
#include "schm.cdk"
#include "itf_phy_busind.cdk"
#include "init.cdk"
#include "rstr.cdk"
*
*modules
integer numtr,istep,i,j,k,n,iadd,iaddold
*
logical plpr_L
*
* Work arrays
* -----------
real work(l_ni*l_nj*l_nk)
*
* ______________________________________________________
*
if(Lctl_step .gt.100 ) call gem_stop('v4d_rwtraj_phystep',-1)
if(hucond.ne.1) then
write(Lun_out,*) 'hucond should be equal to 1'
call gem_stop('v4d_rwtraj_phystep',-1)
endif
* ______________________________________________________
*
numtr = 10
*
* 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_qp,work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iuntr,iadd,plpr_L,'QP', V4dg_ad_L,0,-1)
*
iaddold = iadd
iadd = V4dg_addtab_tl(3,istep,1) + 0*l_ni*l_nj*l_nk
call v4d_rwfld (F_um,work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iuntr,iadd,plpr_L,'UM', V4dg_ad_L,0,-1)
iadd = iaddold
*
iaddold = iadd
iadd = V4dg_addtab_tl(3,istep,1) + 1*l_ni*l_nj*l_nk
call v4d_rwfld (F_vm,work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iuntr,iadd,plpr_L,'VM', V4dg_ad_L,0,-1)
iadd = iaddold
*
iaddold = iadd
iadd = V4dg_addtab_tl(3,istep,1) + 5*l_ni*l_nj*l_nk
call v4d_rwfld (F_tm,work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iuntr,iadd,plpr_L,'TM', V4dg_ad_L,0,-1)
iadd = iaddold
*
iaddold = iadd
iadd = V4dg_addtab_tl(3,istep,1) + 9*l_ni*l_nj*l_nk
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)
iadd = iaddold
*
call v4d_rwfld (F_up,work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iuntr,iadd,plpr_L,'UP', V4dg_ad_L,0,-1)
*
call v4d_rwfld (F_vp,work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iuntr,iadd,plpr_L,'VP', V4dg_ad_L,0,-1)
*
call v4d_rwfld (F_tp,work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iuntr,iadd,plpr_L,'TP', V4dg_ad_L,0,-1)
*
call v4d_rwfld (F_trp,work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iuntr,iadd,plpr_L,'TRP', V4dg_ad_L,0,-1)
*
*
* Restore TRAJECTORY
* ------------------
call itf_phy_uvgridscal ( F_um, F_vm, LDIST_DIM, l_nk, .true. )
do k=1,l_nk
do j=1,l_nj
do i=1,l_ni
F_tm(i,j,k) = F_tm(i,j,k) + Cstv_tstr_8
end do
end do
end do
*
endif
*
* ADJOINT MODEL
* -------------
if(V4dg_ad_L) then
*
call v4d_rwfld (F_trp,work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iuntr,iadd,plpr_L,'TRP', V4dg_ad_L,
% l_ni*l_nj*l_nk,-1)
*
call v4d_rwfld (F_tp,work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iuntr,iadd,plpr_L,'TP', V4dg_ad_L,
% l_ni*l_nj*l_nk,-1)
*
call v4d_rwfld (F_vp,work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iuntr,iadd,plpr_L,'VP', V4dg_ad_L,
% l_ni*l_nj*l_nk,-1)
*
call v4d_rwfld (F_up,work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iuntr,iadd,plpr_L,'UP', V4dg_ad_L,
% l_ni*l_nj*l_nk,-1)
*
iaddold = iadd
iadd = V4dg_addtab_tl(3,istep,1) + 9*l_ni*l_nj*l_nk
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)
iadd = iaddold
*
iaddold = iadd
iadd = V4dg_addtab_tl(3,istep,1) + 5*l_ni*l_nj*l_nk
call v4d_rwfld (F_tm,work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iuntr,iadd,plpr_L,'TM', V4dg_ad_L,
% l_ni*l_nj*l_nk,-1)
iadd = iaddold
*
iaddold = iadd
iadd = V4dg_addtab_tl(3,istep,1) + 1*l_ni*l_nj*l_nk
call v4d_rwfld (F_vm,work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iuntr,iadd,plpr_L,'VM', V4dg_ad_L,
% l_ni*l_nj*l_nk,-1)
iadd = iaddold
*
iaddold = iadd
iadd = V4dg_addtab_tl(3,istep,1) + 0*l_ni*l_nj*l_nk
call v4d_rwfld (F_um,work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iuntr,iadd,plpr_L,'UM', V4dg_ad_L,
% l_ni*l_nj*l_nk,-1)
iadd = iaddold
*
call v4d_rwfld (F_qp,work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iuntr,iadd,plpr_L,'QP', V4dg_ad_L,
% l_ni*l_nj*1,-1)
*
* Restore TRAJECTORY
* ------------------
call itf_phy_uvgridscal ( F_um, F_vm, LDIST_DIM, l_nk, .true. )
do k=1,l_nk
do j=1,l_nj
do i=1,l_ni
F_tm(i,j,k) = F_tm(i,j,k) + Cstv_tstr_8
end do
end do
end do
*
endif
*
* -----------------
* Write TRAJ Fields
* -----------------
elseif(V4dg_rwtr.eq.1) then
*
* Store starting TLM address
* --------------------------
V4dg_addtab_tl(numtr,istep,1) = V4dg_addtr
iadd = V4dg_addtr
*
call v4d_rwfld (F_qp,work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iuntr,iadd,plpr_L,'QP',V4dg_ad_L,0,1)
*
call v4d_rwfld (F_up,work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iuntr,iadd,plpr_L,'UP',V4dg_ad_L,0,1)
*
call v4d_rwfld (F_vp,work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iuntr,iadd,plpr_L,'VP',V4dg_ad_L,0,1)
*
call v4d_rwfld (F_tp,work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iuntr,iadd,plpr_L,'TP',V4dg_ad_L,0,1)
*
call v4d_rwfld (F_trp,work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iuntr,iadd,plpr_L,'TRP',V4dg_ad_L,0,1)
*
*
* Store starting ADJOINT address
* ------------------------------
V4dg_addtab_ad(numtr,istep,1) = iadd - l_ni*l_nj*l_nk
V4dg_addtr = iadd
*
endif
*
return
end