!-------------------------------------- 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_rwnest - Read (Write) from (on) NESTING WA file at each time step
*
#include "model_macros_f.h"
*
subroutine v4d_rwnest 4,56
*
implicit none
*
*author
* M.Tanguay
*
*revision
* v3_03 - Tanguay M. - Adjoint Lam configuration
* v3_30 - Tanguay M. - Validation for LAM version
*
*object
* Read (Write) from (on) NESTING WA file at each time step
*
* ------------------------------------------------------------
* NOTE: NESTING fields are fixed for different non-linear jobs
* In TLM and ADJ runs, the FIXED nesting fields are kept
* in NESTM and NEST should be set to ZERO
* ------------------------------------------------------------
*
*arguments
* none
*
*implicits
#include "glb_ld.cdk"
#include "lun.cdk"
#include "geomg.cdk"
#include "lctl.cdk"
#include "nest.cdk"
#include "nestm.cdk"
#include "tr3d.cdk"
#include "v4dg.cdk"
#include "schm.cdk"
*
*modules
integer vmmlod,vmmget,vmmuld
external vmmlod,vmmget,vmmuld
integer pnerr, pnlkey1(20), key2(Tr3d_ntr),key2_, key2m(Tr3d_ntr), key2m_,
% pnlod, istep, iadd, err, igroup, n
*
real trf,trfm
pointer (patrf, trf(LDIST_SHAPE,*)),(patrfm, trfm(LDIST_SHAPE,*))
*
logical plpr_L
*
* Work arrays
* -----------
real work(l_ni*l_nj*l_nk)
* ______________________________________________________
*
*
* Flag to trace storing and retrieving of trajectory
* --------------------------------------------------
plpr_L = .false.
plpr_L = plpr_L.and.Lun_out.gt.0
*
istep = Lctl_step
*
* -------------
* NESTING state
* -------------
*
* ----------------
* Read TRAJ Fields
* ----------------
if(V4dg_rwnest.eq.0) then
*
* Recover starting address
* ------------------------
if(V4dg_ad_L) iadd = V4dg_addnes_ad(istep,1)
if(V4dg_tl_L.or.V4dg_di_L) iadd = V4dg_addnes_tl(istep,1)
*
if(V4dg_tl_L.or.V4dg_di_L) igroup=0
if(V4dg_ad_L) igroup=3
*
100 continue
*
if(V4dg_tl_L.or.V4dg_di_L) igroup=igroup+1
if(V4dg_ad_L) igroup=igroup-1
*
if((V4dg_tl_L.or.V4dg_di_L).and.igroup.eq.3) goto 120
if( V4dg_ad_L .and.igroup.eq.0) goto 120
*
* -------
* GROUP=1
* -------
if(igroup.eq.1) then
*
if(V4dg_tl_L.or.V4dg_ad_L) then
*
pnlkey1(1) = VMM_KEY(nestm_um)
pnlkey1(2) = VMM_KEY(nestm_vm)
pnlkey1(3) = VMM_KEY(nestm_tm)
pnlkey1(4) = VMM_KEY(nestm_psdm)
pnlkey1(5) = VMM_KEY(nestm_pipm)
pnlkey1(6) = VMM_KEY(nestm_fipm)
pnlkey1(7) = VMM_KEY(nestm_tdm)
pnlkey1(8) = VMM_KEY(nestm_fim)
pnlkey1(9) = VMM_KEY(nestm_qm)
pnlkey1(10)= VMM_KEY(nestm_sm)
pnlkey1(11)= VMM_KEY(nestm_tpm)
pnlod = 11
*
if (.not.Schm_hydro_L) then
pnlkey1(pnlod+1)=VMM_KEY(nestm_wm)
pnlkey1(pnlod+2)=VMM_KEY(nestm_mum)
pnlod = pnlod+2
endif
*
* - - - - - - - - - - - - - - -
pnerr = vmmlod(pnlkey1,pnlod)
* - - - - - - - - - - - - - - -
pnerr = VMM_GET_VAR(nestm_um)
pnerr = VMM_GET_VAR(nestm_vm)
pnerr = VMM_GET_VAR(nestm_tm)
pnerr = VMM_GET_VAR(nestm_psdm)
pnerr = VMM_GET_VAR(nestm_pipm)
pnerr = VMM_GET_VAR(nestm_fipm)
pnerr = VMM_GET_VAR(nestm_tdm)
pnerr = VMM_GET_VAR(nestm_fim)
pnerr = VMM_GET_VAR(nestm_qm)
pnerr = VMM_GET_VAR(nestm_sm)
pnerr = VMM_GET_VAR(nestm_tpm)
*
if (.not.Schm_hydro_L) then
err = VMM_GET_VAR(nestm_wm)
err = VMM_GET_VAR(nestm_mum)
endif
*
elseif(V4dg_di_L) then
*
pnlkey1(1) = VMM_KEY(nest_u)
pnlkey1(2) = VMM_KEY(nest_v)
pnlkey1(3) = VMM_KEY(nest_t)
pnlkey1(4) = VMM_KEY(nest_psd)
pnlkey1(5) = VMM_KEY(nest_pip)
pnlkey1(6) = VMM_KEY(nest_fip)
pnlkey1(7) = VMM_KEY(nest_td)
pnlkey1(8) = VMM_KEY(nest_fi)
pnlkey1(9) = VMM_KEY(nest_q)
pnlkey1(10)= VMM_KEY(nest_s)
pnlkey1(11)= VMM_KEY(nest_tp)
pnlod = 11
*
if (.not.Schm_hydro_L) then
pnlkey1(pnlod+1)=VMM_KEY(nest_w)
pnlkey1(pnlod+2)=VMM_KEY(nest_mu)
pnlod = pnlod+2
endif
*
* - - - - - - - - - - - - - - -
pnerr = vmmlod(pnlkey1,pnlod)
* - - - - - - - - - - - - - - -
pnerr = VMM_GET_VAR(nest_u)
pnerr = VMM_GET_VAR(nest_v)
pnerr = VMM_GET_VAR(nest_t)
pnerr = VMM_GET_VAR(nest_psd)
pnerr = VMM_GET_VAR(nest_pip)
pnerr = VMM_GET_VAR(nest_fip)
pnerr = VMM_GET_VAR(nest_td)
pnerr = VMM_GET_VAR(nest_fi)
pnerr = VMM_GET_VAR(nest_q)
pnerr = VMM_GET_VAR(nest_s)
pnerr = VMM_GET_VAR(nest_tp)
*
if (.not.Schm_hydro_L) then
err = VMM_GET_VAR(nest_w)
err = VMM_GET_VAR(nest_mu)
endif
*
endif
*
* FORWARD MODEL
* -------------
if(V4dg_di_L) then
*
call v4d_rwfld (nest_u, work, l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iunns,iadd,plpr_L,'N_U', V4dg_ad_L,0,-1)
*
call v4d_rwfld (nest_v, work, l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iunns,iadd,plpr_L,'N_V', V4dg_ad_L,0,-1)
*
call v4d_rwfld (nest_t, work, l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iunns,iadd,plpr_L,'N_T', V4dg_ad_L,0,-1)
*
call v4d_rwfld (nest_psd,work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iunns,iadd,plpr_L,'N_PSD', V4dg_ad_L,0,-1)
*
call v4d_rwfld (nest_pip,work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iunns,iadd,plpr_L,'N_PIP', V4dg_ad_L,0,-1)
*
call v4d_rwfld (nest_fip,work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iunns,iadd,plpr_L,'N_FIP', V4dg_ad_L,0,-1)
*
call v4d_rwfld (nest_td, work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iunns,iadd,plpr_L,'N_TD', V4dg_ad_L,0,-1)
*
call v4d_rwfld (nest_fi, work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iunns,iadd,plpr_L,'N_FI', V4dg_ad_L,0,-1)
*
call v4d_rwfld (nest_q, work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iunns,iadd,plpr_L,'N_Q', V4dg_ad_L,0,-1)
*
call v4d_rwfld (nest_s, work, l_ni,l_nj,LDIST_DIM,1,
% V4dg_iunns,iadd,plpr_L,'N_S', V4dg_ad_L,0,-1)
*
call v4d_rwfld (nest_tp, work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iunns,iadd,plpr_L,'N_TP', V4dg_ad_L,0,-1)
*
if (.not.Schm_hydro_L) then
*
call v4d_rwfld (nest_w, work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iunns,iadd,plpr_L,'N_W', V4dg_ad_L,0,-1)
call v4d_rwfld (nest_mu, work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iunns,iadd,plpr_L,'N_MU', V4dg_ad_L,0,-1)
*
endif
*
endif
*
* TANGENT LINEAR MODEL
* --------------------
if(V4dg_tl_L) then
*
call v4d_rwfld (nestm_um, work, l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iunns,iadd,plpr_L,'NM_UM', V4dg_ad_L,0,-1)
*
call v4d_rwfld (nestm_vm, work, l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iunns,iadd,plpr_L,'NM_VM', V4dg_ad_L,0,-1)
*
call v4d_rwfld (nestm_tm, work, l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iunns,iadd,plpr_L,'NM_TM', V4dg_ad_L,0,-1)
*
call v4d_rwfld (nestm_psdm,work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iunns,iadd,plpr_L,'NM_PSDM', V4dg_ad_L,0,-1)
*
call v4d_rwfld (nestm_pipm,work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iunns,iadd,plpr_L,'NM_PIPM', V4dg_ad_L,0,-1)
*
call v4d_rwfld (nestm_fipm,work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iunns,iadd,plpr_L,'NM_FIPM', V4dg_ad_L,0,-1)
*
call v4d_rwfld (nestm_tdm, work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iunns,iadd,plpr_L,'NM_TDM', V4dg_ad_L,0,-1)
*
call v4d_rwfld (nestm_fim, work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iunns,iadd,plpr_L,'NM_FIM', V4dg_ad_L,0,-1)
*
call v4d_rwfld (nestm_qm, work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iunns,iadd,plpr_L,'NM_QM', V4dg_ad_L,0,-1)
*
call v4d_rwfld (nestm_sm, work, l_ni,l_nj,LDIST_DIM,1,
% V4dg_iunns,iadd,plpr_L,'NM_SM', V4dg_ad_L,0,-1)
*
call v4d_rwfld (nestm_tpm, work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iunns,iadd,plpr_L,'NM_TPM', V4dg_ad_L,0,-1)
*
if (.not.Schm_hydro_L) then
*
call v4d_rwfld (nestm_wm, work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iunns,iadd,plpr_L,'NM_WM', V4dg_ad_L,0,-1)
call v4d_rwfld (nestm_mum, work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iunns,iadd,plpr_L,'NM_MUM', V4dg_ad_L,0,-1)
*
endif
*
endif
*
* ADJOINT MODEL
* -------------
if(V4dg_ad_L) then
*
if (.not.Schm_hydro_L) then
*
call v4d_rwfld (nestm_mum, work, l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iunns,iadd,plpr_L,'NM_MUM', V4dg_ad_L,
% l_ni*l_nj*l_nk,-1)
*
call v4d_rwfld (nestm_wm, work, l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iunns,iadd,plpr_L,'NM_WM', V4dg_ad_L,
% l_ni*l_nj*l_nk,-1)
*
endif
*
call v4d_rwfld (nestm_tpm, work, l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iunns,iadd,plpr_L,'NM_TPM', V4dg_ad_L,
% l_ni*l_nj,-1)
*
call v4d_rwfld (nestm_sm, work,l_ni,l_nj,LDIST_DIM,1,
% V4dg_iunns,iadd,plpr_L,'NM_SM', V4dg_ad_L,
% l_ni*l_nj*l_nk,-1)
*
call v4d_rwfld (nestm_qm, work, l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iunns,iadd,plpr_L,'NM_QM', V4dg_ad_L,
% l_ni*l_nj*l_nk,-1)
*
call v4d_rwfld (nestm_fim, work, l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iunns,iadd,plpr_L,'NM_FIM', V4dg_ad_L,
% l_ni*l_nj*l_nk,-1)
*
call v4d_rwfld (nestm_tdm, work, l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iunns,iadd,plpr_L,'NM_TDM', V4dg_ad_L,
% l_ni*l_nj*l_nk,-1)
*
call v4d_rwfld (nestm_fipm,work, l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iunns,iadd,plpr_L,'NM_FIPM', V4dg_ad_L,
% l_ni*l_nj*l_nk,-1)
*
call v4d_rwfld (nestm_pipm,work, l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iunns,iadd,plpr_L,'NM_PIPM', V4dg_ad_L,
% l_ni*l_nj*l_nk,-1)
*
call v4d_rwfld (nestm_psdm,work, l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iunns,iadd,plpr_L,'NM_PSDM', V4dg_ad_L,
% l_ni*l_nj*l_nk,-1)
*
call v4d_rwfld (nestm_tm,work, l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iunns,iadd,plpr_L,'NM_TM', V4dg_ad_L,
% l_ni*l_nj*l_nk,-1)
*
call v4d_rwfld (nestm_vm, work, l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iunns,iadd,plpr_L,'NM_VM', V4dg_ad_L,
% l_ni*l_nj*l_nk,-1)
*
call v4d_rwfld (nestm_um, work, l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iunns,iadd,plpr_L,'NM_UM', V4dg_ad_L,
% l_ni*l_nj*l_nk,-1)
*
endif
*
err = vmmuld(pnlkey1,pnlod)
*
goto 100
*
endif
*
* -------
* GROUP=2
* -------
if(igroup.eq.2) then
*
if(V4dg_di_L) then
key2_ = VMM_KEY (nest_tr)
do n=1,Tr3d_ntr
key2(n) = key2_ + n
end do
endif
*
if(V4dg_tl_L.or.V4dg_ad_L) then
key2m_ = VMM_KEY (nestm_trm)
do n=1,Tr3d_ntr
key2m(n) = key2m_ + n
end do
endif
*
if (Tr3d_ntr.gt.0) then
if(V4dg_di_L ) err = vmmlod(key2, Tr3d_ntr)
if(V4dg_tl_L.or.V4dg_ad_L) err = vmmlod(key2m,Tr3d_ntr)
do n=1,Tr3d_ntr
if(V4dg_di_L ) err = vmmget(key2 (n),patrf, trf )
if(V4dg_tl_L.or.V4dg_ad_L) err = vmmget(key2m(n),patrfm,trfm)
*
if(V4dg_di_L) then
call v4d_rwfld (trf, work, l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iunns,iadd,plpr_L,'N_TR', V4dg_ad_L,0,-1)
endif
if(V4dg_tl_L) then
call v4d_rwfld (trfm,work, l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iunns,iadd,plpr_L,'NM_TRM', V4dg_ad_L,0,-1)
endif
if(V4dg_ad_L) then
call v4d_rwfld (trfm,work, l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iunns,iadd,plpr_L,'NM_TRM', V4dg_ad_L,
% l_ni*l_nj*l_nk,-1)
endif
end do
if(V4dg_di_L ) err = vmmuld(key2, Tr3d_ntr)
if(V4dg_tl_L.or.V4dg_ad_L) err = vmmuld(key2m,Tr3d_ntr)
endif
*
goto 100
*
endif
*
* -----------------
* Write TRAJ Fields
* -----------------
elseif(V4dg_rwnest.eq.1) then
*
igroup=0
*
110 continue
*
igroup=igroup+1
if(igroup.eq.3) goto 120
*
* -------
* GROUP=1
* -------
if(igroup.eq.1) then
*
pnlkey1(1) = VMM_KEY(nest_u)
pnlkey1(2) = VMM_KEY(nest_v)
pnlkey1(3) = VMM_KEY(nest_t)
pnlkey1(4) = VMM_KEY(nest_psd)
pnlkey1(5) = VMM_KEY(nest_pip)
pnlkey1(6) = VMM_KEY(nest_fip)
pnlkey1(7) = VMM_KEY(nest_td)
pnlkey1(8) = VMM_KEY(nest_fi)
pnlkey1(9) = VMM_KEY(nest_q)
pnlkey1(10)= VMM_KEY(nest_s)
pnlkey1(11)= VMM_KEY(nest_tp)
pnlod = 11
*
if (.not.Schm_hydro_L) then
pnlkey1(pnlod+1)=VMM_KEY(nest_w)
pnlkey1(pnlod+2)=VMM_KEY(nest_mu)
pnlod = pnlod+2
endif
*
* - - - - - - - - - - - - - - -
pnerr = vmmlod(pnlkey1,pnlod)
* - - - - - - - - - - - - - - -
*
pnerr = VMM_GET_VAR(nest_u)
pnerr = VMM_GET_VAR(nest_v)
pnerr = VMM_GET_VAR(nest_t)
pnerr = VMM_GET_VAR(nest_psd)
pnerr = VMM_GET_VAR(nest_pip)
pnerr = VMM_GET_VAR(nest_fip)
pnerr = VMM_GET_VAR(nest_td)
pnerr = VMM_GET_VAR(nest_fi)
pnerr = VMM_GET_VAR(nest_q)
pnerr = VMM_GET_VAR(nest_s)
pnerr = VMM_GET_VAR(nest_tp)
*
if (.not.Schm_hydro_L) then
err = VMM_GET_VAR(nest_w)
err = VMM_GET_VAR(nest_mu)
endif
*
* Store starting TLM address
* --------------------------
V4dg_addnes_tl(istep,1) = V4dg_addns
iadd = V4dg_addns
*
call v4d_rwfld (nest_u, work, l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iunns,iadd,plpr_L,'N_U', V4dg_ad_L,0,1)
*
call v4d_rwfld (nest_v, work, l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iunns,iadd,plpr_L,'N_V', V4dg_ad_L,0,1)
*
call v4d_rwfld (nest_t, work, l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iunns,iadd,plpr_L,'N_T', V4dg_ad_L,0,1)
*
call v4d_rwfld (nest_psd,work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iunns,iadd,plpr_L,'N_PSD', V4dg_ad_L,0,1)
*
call v4d_rwfld (nest_pip,work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iunns,iadd,plpr_L,'N_PIP', V4dg_ad_L,0,1)
*
call v4d_rwfld (nest_fip,work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iunns,iadd,plpr_L,'N_FIP', V4dg_ad_L,0,1)
*
call v4d_rwfld (nest_td, work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iunns,iadd,plpr_L,'N_TD', V4dg_ad_L,0,1)
*
call v4d_rwfld (nest_fi, work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iunns,iadd,plpr_L,'N_FI', V4dg_ad_L,0,1)
*
call v4d_rwfld (nest_q, work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iunns,iadd,plpr_L,'N_Q', V4dg_ad_L,0,1)
*
call v4d_rwfld (nest_s, work, l_ni,l_nj,LDIST_DIM,1,
% V4dg_iunns,iadd,plpr_L,'N_S', V4dg_ad_L,0,1)
*
call v4d_rwfld (nest_tp, work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iunns,iadd,plpr_L,'N_TP', V4dg_ad_L,0,1)
*
if (.not.Schm_hydro_L) then
*
call v4d_rwfld (nest_w, work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iunns,iadd,plpr_L,'N_W', V4dg_ad_L,0,1)
*
call v4d_rwfld (nest_mu, work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iunns,iadd,plpr_L,'N_MU', V4dg_ad_L,0,1)
*
endif
*
err = vmmuld(pnlkey1,pnlod)
*
goto 110
*
endif
*
* -------
* GROUP=2
* -------
if(igroup.eq.2) then
*
key2_ = VMM_KEY (nest_tr)
do n=1,Tr3d_ntr
key2(n) = key2_ + n
end do
if (Tr3d_ntr.gt.0) then
err = vmmlod(key2,Tr3d_ntr)
do n=1,Tr3d_ntr
err = vmmget(key2(n),patrf,trf)
*
call v4d_rwfld (trf, work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iunns,iadd,plpr_L,'N_TR', V4dg_ad_L,0,1)
enddo
err = vmmuld(key2,Tr3d_ntr)
endif
* Store starting ADJOINT address
* ------------------------------
V4dg_addnes_ad(istep,1) = iadd - l_ni*l_nj*l_nk
V4dg_addns = iadd
*
goto 110
*
endif
*
endif
*
120 continue
*
return
end