!-------------------------------------- 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 p_vmmphy_ad - adjoint of load all fields required by the physics
*
#include "model_macros_f.h"
*
subroutine p_vmmphy_ad( F_up, F_vp, F_wp, F_tp, F_qp, F_trp, 1,2
$ F_um, F_vm, F_tm, F_trm,
$ F_lnpsm, F_sig, DIST_DIM, Nk )
*
implicit none
*
integer DIST_DIM,Nk
real F_up (DIST_SHAPE,Nk), F_vp (DIST_SHAPE,Nk) ,
$ F_wp (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,*),
$ F_lnpsm(DIST_SHAPE), F_sig(DIST_SHAPE,Nk)
*
*author
* Stephane Laroche - January 2002
*
*revision
* v3_00 - Laroche S. - initial MPI version
* v3_20 - Laroche S. - cleanup pil_#
* v3_21 - Tanguay M. - Revision Openmp
* v3_30 - Tanguay M. - adapt TL/AD to itf
* - Validation for LAM version
*
*object
*
*arguments
* Name I/O Description
*----------------------------------------------------------------
* F_up
*----------------------------------------------------------------
*
*implicits
#include "glb_ld.cdk"
#include "geomg.cdk"
#include "cstv.cdk"
#include "dcst.cdk"
#include "schm.cdk"
#include "p_cond.cdk"
#include "inuvl.cdk"
#include "vt1.cdk"
#include "vt0.cdk"
#include "itf_phy_busind.cdk"
*
**
integer vmmlod,vmmget,vmmuln
external vmmlod,vmmget,vmmuln
*
integer*8 pnt_trp(phyt_ntr),pnt_trm(phyt_ntr)
integer err, key(10), i, j, k, n, i0, j0, in, jn, nksurf,
$ keyp(h2o_ntr), keym(h2o_ntr), keyp_, keym_
real dt, dzmin, dzmin_, sigsfc, trp, trm
real*8, parameter :: ZERO_8 = 0.0
real wk1(LDIST_SHAPE),wk2(LDIST_SHAPE),wk3(LDIST_SHAPE),
$ wk4(LDIST_SHAPE)
pointer (patrp, trp(LDIST_SHAPE,*)),(patrm, trm(LDIST_SHAPE,*))
*
* ________________________________________________________________
*
keyp_ = VMM_KEY (trt1)
keym_ = VMM_KEY (trt0)
if (phyt_ntr.gt.0) then
do n=1,phyt_ntr
keyp(n) = keyp_ + n
keym(n) = keym_ + n
end do
err = vmmlod(keyp,phyt_ntr)
err = vmmlod(keym,phyt_ntr)
do n=1,phyt_ntr
err = vmmget(keyp(n),patrp,trp)
pnt_trp(n) = patrp
err = vmmget(keym(n),patrm,trm)
pnt_trm(n) = patrm
end do
endif
*
key( 1) = VMM_KEY(ut0)
key( 2) = VMM_KEY(vt0)
key( 3) = VMM_KEY(tt0)
key( 4) = VMM_KEY(ut1)
key( 5) = VMM_KEY(vt1)
key( 6) = VMM_KEY(tt1)
key( 7) = VMM_KEY(qt0)
key( 8) = VMM_KEY(qt1)
err = vmmlod(key,8)
err = VMM_GET_VAR(ut0)
err = VMM_GET_VAR(vt0)
err = VMM_GET_VAR(tt0)
err = VMM_GET_VAR(ut1)
err = VMM_GET_VAR(vt1)
err = VMM_GET_VAR(tt1)
err = VMM_GET_VAR(qt0)
err = VMM_GET_VAR(qt1)
if (.not.Schm_hydro_L) then
key(9 ) = VMM_KEY(qpt0)
key(10) = VMM_KEY(qpt1)
err = vmmlod(key(9),2)
err = VMM_GET_VAR(qpt0)
err = VMM_GET_VAR(qpt1)
endif
*
*
*C interpolate wind images at time t1 and t2
* -----------------------------------------
*
call itf_phy_uvgridscal0_ad( F_up, F_vp, LDIST_DIM, l_nk, .true. )
call itf_phy_uvgridscal0_ad( F_um, F_vm, LDIST_DIM, l_nk, .true. )
*
!$omp parallel
*
****************************************************
* Copy variables at time t- and t* in workfields *
****************************************************
*
!$omp do
do k=1,l_nk
do j= 1, l_nj
do i= 1, l_ni
ut0(i,j,k) = ut0(i,j,k) + F_um(i,j,k)
vt0(i,j,k) = vt0(i,j,k) + F_vm(i,j,k)
tt0(i,j,k) = tt0(i,j,k) + F_tm(i,j,k)
ut1(i,j,k) = ut1(i,j,k) + F_up(i,j,k)
vt1(i,j,k) = vt1(i,j,k) + F_vp(i,j,k)
tt1(i,j,k) = tt1(i,j,k) + F_tp(i,j,k)
F_um(i,j,k) = ZERO_8
F_vm(i,j,k) = ZERO_8
F_tm(i,j,k) = ZERO_8
F_up(i,j,k) = ZERO_8
F_vp(i,j,k) = ZERO_8
F_tp(i,j,k) = ZERO_8
end do
end do
end do
!$omp end do
*
*
if (Schm_hydro_L) then
!$omp do
do k= 1,l_nk
*
if(k.eq.1) then
do j= 1, l_nj
do i= 1, l_ni
qt0(i,j,l_nk) = qt0(i,j,l_nk) + F_lnpsm(i,j)
F_lnpsm(i,j) = ZERO_8
end do
end do
endif
*
do j= 1, l_nj
do i= 1, l_ni
qt1(i,j,k) = qt1(i,j,k) + F_qp(i,j,k)
F_qp(i,j,k) = ZERO_8
end do
end do
*
end do
!$omp end do
else
!$omp do
do k= 1,l_nk
*
if(k.eq.1) then
do j= 1, l_nj
do i= 1, l_ni
qt0 (i,j,l_nk) = qt0 (i,j,l_nk) + F_lnpsm(i,j)
qpt0(i,j,l_nk) = qpt0(i,j,l_nk) - F_lnpsm(i,j)
F_lnpsm(i,j) = ZERO_8
end do
end do
endif
*
do j= 1, l_nj
do i= 1, l_ni
qt1 (i,j,k) = qt1 (i,j,k) + F_qp(i,j,k)
qpt1(i,j,k) = qpt1(i,j,k) - F_qp(i,j,k)
F_qp(i,j,k) = ZERO_8
end do
end do
*
end do
!$omp end do
*
endif
*
if (h2o_ntr.gt.0) then
do n=1,h2o_ntr
patrp = pnt_trp(n)
patrm = pnt_trm(n)
!$omp do
do k=1,l_nk
do j= 1, l_nj
do i= 1, l_ni
trp(i,j,k) = trp(i,j,k) + F_trp(i,j,k,n)
trm(i,j,k) = trm(i,j,k) + F_trm(i,j,k,n)
F_trp(i,j,k,n) = ZERO_8
F_trm(i,j,k,n) = ZERO_8
end do
end do
end do
!$omp end do
end do
endif
*
!$omp end parallel
*
*
*
* No impact from vertical motion
*
*
*
*
* No send dzmin and nksurf to the physics
*
*
*
* ________________________________________________________________
*
return
end