!-------------------------------------- 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 hdif_phy_ad - ADJ of hdif_phy_ad
*
#include "model_macros_f.h"
*
subroutine hdif_phy_ad () 1,10
*
implicit none
*
*author M.Tanguay
*
*revision
* v3_03 - Tanguay M. - initial MPI version
* v3_30 - Tanguay M. - adapt to bcs
* v3_31 - Tanguay M. - add rwnd_L
* v3_31 - Tanguay M. - Control BC
*
*object
* see id section
*
*arguments
*
*implicits
#include "glb_ld.cdk"
#include "schm.cdk"
#include "lctl.cdk"
#include "v4dg.cdk"
#include "vt1m.cdk"
#include "hzd.cdk"
#include "eigv.cdk"
#include "fft.cdk"
#include "vspng.cdk"
#include "ifd.cdk"
#include "hspng.cdk"
*
integer vmmlod,vmmuld,vmmget
external vmmlod,vmmuld,vmmget
*
integer pnerr,pnlkey1(2),i,j,k
*
real w1pipt1m(LDIST_SHAPE,l_nk),w2pipt1m(LDIST_SHAPE,l_nk),
% z1pipt1m(LDIST_SHAPE,l_nk),z2pipt1m(LDIST_SHAPE,l_nk),
% z1qpt1m (LDIST_SHAPE,l_nk),z2qpt1m (LDIST_SHAPE,l_nk)
* ________________________________________________________________
*
if (Hspng_nj.ge.1) call gem_stop ('HSNPG TL-AD not up to date',-1)
*
if (G_lam .and. ifd_ftype.ne.'BMF') then
* ADJ of
* Impose Lateral BCs within Pil regions
call v4d_nest_bcs_ad
* ADJ of
* Update Lateral BCs with data that has seen physics
call nest_update_ad
endif
*
* Adjoint of
* Physics timestep & Horizontal diffusion & Vertical sponge
* ---------------------------------------------------------
*
if ( Schm_hdlast_L) goto 10
if (.not.Schm_hdlast_L) goto 30
*
10 continue
*
* Go to Adjoint of
* Horizontal diffusion & Vertical sponge
* --------------------------------------
goto 50
*
20 continue
*
* Adjoint of
* Physics timestep
* ----------------
if ( Schm_phyms_L ) call p_main_ad (Lctl_step)
*
return
*
30 continue
*
* Adjoint of
* Physics timestep
* ----------------
if ( Schm_phyms_L ) call p_main_ad (Lctl_step)
*
* Go to Adjoint of
* Horizontal diffusion & Vertical sponge
* --------------------------------------
goto 50
*
40 continue
*
return
*
50 continue
*
* --------------------------------------------------------------
* COMMON SECTION (START) of Schm_hdlast_L and .not.Schm_hdlast_L
* --------------------------------------------------------------
*
* Adjoint of
* Horizontal diffusion & Vertical sponge
* --------------------------------------
*
* Recover TRAJ needed in all diffusions
* -------------------------------------
if (Hzd_fact_L.or.Hzd_ho_L.or.Vspng_nk.gt.0) then
*
* Recover TRAJ PIPT1,QPT1M (No Hyd) before HZD diffusion
* ------------------------------------------------------
call v4d_rwtraj (2)
*
* HZD Diffusion of TRAJ PIPT1,QPT1M
* ---------------------------------
if (Hzd_fact_L.or.Hzd_ho_L) then
*
* Preserve TRAJ PIPT1,QPT1M before HZD diffusion if .not.Schm_hydro_L
* -------------------------------------------------------------------
if(.not.Schm_hydro_L) then
*
pnlkey1(1) = VMM_KEY(pipt1m)
pnlkey1(2) = VMM_KEY(qpt1m )
pnerr = vmmlod(pnlkey1,2)
*
pnerr = VMM_GET_VAR(pipt1m)
pnerr = VMM_GET_VAR(qpt1m )
*
do k=1,l_nk
do j=1,l_nj
do i=1,l_ni
z1pipt1m(i,j,k) = pipt1m(i,j,k)
z1qpt1m (i,j,k) = qpt1m (i,j,k)
enddo
enddo
enddo
*
pnerr = vmmuld(-1,0)
*
endif
*
call hzd_main_tr ()
*
* Preserve HZD diffusion of TRAJ PIPT1 if Schm_hydro_L
* ----------------------------------------------------
if(Schm_hydro_L) then
*
pnlkey1(1) = VMM_KEY(pipt1m)
pnerr = vmmlod(pnlkey1,1)
pnerr = VMM_GET_VAR(pipt1m)
*
do k=1,l_nk
do j=1,l_nj
do i=1,l_ni
w1pipt1m(i,j,k) = pipt1m(i,j,k)
enddo
enddo
enddo
*
pnerr = vmmuld(-1,0)
*
endif
*
endif
*
* VSNPG Diffusion of TRAJ PIPT1,QPT1M
* -----------------------------------
if (Vspng_nk.gt.0) then
*
* Preserve TRAJ PIPT1,QPT1M before VSPNG diffusion if .not.Schm_hydro_L
* ---------------------------------------------------------------------
if(.not.Schm_hydro_L) then
*
pnlkey1(1) = VMM_KEY(pipt1m)
pnlkey1(2) = VMM_KEY(qpt1m )
pnerr = vmmlod(pnlkey1,2)
*
pnerr = VMM_GET_VAR(pipt1m)
pnerr = VMM_GET_VAR(qpt1m )
*
do k=1,l_nk
do j=1,l_nj
do i=1,l_ni
z2pipt1m(i,j,k) = pipt1m(i,j,k)
z2qpt1m (i,j,k) = qpt1m (i,j,k)
enddo
enddo
enddo
*
pnerr = vmmuld(-1,0)
*
endif
*
call vspng_main_tr ()
*
* Preserve VSPNG diffusion of TRAJ PIPT1 if Schm_hydro_L
* ------------------------------------------------------
if(Schm_hydro_L) then
*
pnlkey1(1) = VMM_KEY(pipt1m)
pnerr = vmmlod(pnlkey1,1)
pnerr = VMM_GET_VAR(pipt1m)
*
do k=1,l_nk
do j=1,l_nj
do i=1,l_ni
w2pipt1m(i,j,k) = pipt1m(i,j,k)
enddo
enddo
enddo
*
pnerr = vmmuld(-1,0)
*
endif
*
endif
*
endif
*
* Recover TRAJ needed in vspng_main_ad
* ------------------------------------
if (Vspng_nk.gt.0) then
*
pnlkey1(1) = VMM_KEY(pipt1m)
if(.not.Schm_hydro_L) then
pnlkey1(2) = VMM_KEY(qpt1m )
pnerr = vmmlod(pnlkey1,2)
else
pnerr = vmmlod(pnlkey1,1)
endif
pnerr = VMM_GET_VAR(pipt1m)
if(.not.Schm_hydro_L) pnerr = VMM_GET_VAR(qpt1m )
*
* Recall TRAJ PIPT1,QPT1M before VSPNG diffusion if .not.Schm_hydro_L
* -------------------------------------------------------------------
if(.not.Schm_hydro_L) then
do k=1,l_nk
do j=1,l_nj
do i=1,l_ni
pipt1m(i,j,k) = z2pipt1m(i,j,k)
qpt1m (i,j,k) = z2qpt1m (i,j,k)
enddo
enddo
enddo
*
* Recall VSPNG diffusion of TRAJ PIPT1 if Schm_hydro_L
* ----------------------------------------------------
else
do k=1,l_nk
do j=1,l_nj
do i=1,l_ni
pipt1m(i,j,k) = w2pipt1m(i,j,k)
enddo
enddo
enddo
endif
*
pnerr = vmmuld(-1,0)
*
endif
*
* Adjoint of vspng_main_tl
* ------------------------
call vspng_main_ad
*
* Recover TRAJ needed in hzd_main_ad
* ----------------------------------
if (Hzd_fact_L.or.Hzd_ho_L) then
*
pnlkey1(1) = VMM_KEY(pipt1m)
if(.not.Schm_hydro_L) then
pnlkey1(2) = VMM_KEY(qpt1m )
pnerr = vmmlod(pnlkey1,2)
else
pnerr = vmmlod(pnlkey1,1)
endif
pnerr = VMM_GET_VAR(pipt1m)
if(.not.Schm_hydro_L) pnerr = VMM_GET_VAR(qpt1m )
*
* Recall TRAJ PIPT1,QPT1M before HZD diffusion if .not.Schm_hydro_L
* -----------------------------------------------------------------
if(.not.Schm_hydro_L) then
do k=1,l_nk
do j=1,l_nj
do i=1,l_ni
pipt1m(i,j,k) = z1pipt1m(i,j,k)
qpt1m (i,j,k) = z1qpt1m (i,j,k)
enddo
enddo
enddo
*
* Recall HZD diffusion of TRAJ PIPT1 if Schm_hydro_L
* --------------------------------------------------
else
do k=1,l_nk
do j=1,l_nj
do i=1,l_ni
pipt1m(i,j,k) = w1pipt1m(i,j,k)
enddo
enddo
enddo
endif
*
pnerr = vmmuld(-1,0)
*
endif
*
* Adjoint of hzd_main_tl
* ----------------------
call hzd_main_ad
*
* ------------------------------------------------------------
* COMMON SECTION (END) of Schm_hdlast_L and .not.Schm_hdlast_L
* ------------------------------------------------------------
if( Schm_hdlast_L) goto 20
if(.not.Schm_hdlast_L) goto 40
*
end