!-------------------------------------- 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_set_vmm_dep_ad - ADJ of v4d_set_vmm_dep_tl
*
#include "model_macros_f.h"
*
subroutine v4d_set_vmm_dep_ad 1,2
*
implicit none
*
integer ipart
*
*author
* M.Tanguay
*
*revision
* v3_31 - Tanguay M. - initial MPI version
* v3_31 - Tanguay M. - Control BC
*
*object
*
* see id section
*
*implicits
#include "glb_ld.cdk"
#include "lun.cdk"
#include "cstv.cdk"
#include "dcst.cdk"
#include "geomg.cdk"
#include "schm.cdk"
#include "vt1.cdk"
#include "vtx.cdk"
#include "vt1m.cdk"
#include "ind.cdk"
#include "indm.cdk"
#include "v4dg.cdk"
#include "p_geof.cdk"
*
integer vmmlod,vmmget,vmmuld
external vmmlod,vmmget,vmmuld
*
integer key1(50),nvar,err,i,j,k
real pr1, pr2
*
real wpipt1m(LDIST_SHAPE,l_nk)
*
real*8, parameter :: ZERO_8 = 0.0
* __________________________________________________________________
*
*
if (Lun_out.gt.0) write(Lun_out,1000)
*
* Get VMM fields in memory
* ------------------------
key1( 1) = VMM_KEY( fit1)
key1( 2) = VMM_KEY( ut1)
key1( 3) = VMM_KEY( vt1)
key1( 4) = VMM_KEY( tt1)
key1( 5) = VMM_KEY( qt1)
key1( 6) = VMM_KEY(fipt1)
key1( 7) = VMM_KEY( st1)
key1( 8) = VMM_KEY(pipt1)
key1( 9) = VMM_KEY( tpt1)
key1(10) = VMM_KEY(tplt1)
key1(11) = VMM_KEY( gptx)
key1(12) = VMM_KEY(psdt1)
key1(13) = VMM_KEY( tdt1)
key1(14) = VMM_KEY( topo)
nvar=14
*
* TRAJECTORY
* ----------
key1(nvar+1) = VMM_KEY( ut1m)
key1(nvar+2) = VMM_KEY( vt1m)
key1(nvar+3) = VMM_KEY(tpt1m)
key1(nvar+4) = VMM_KEY( st1m)
nvar=nvar+4
*
err = vmmlod(key1,nvar)
*
err = VMM_GET_VAR( fit1)
err = VMM_GET_VAR( ut1)
err = VMM_GET_VAR( vt1)
err = VMM_GET_VAR( tt1)
err = VMM_GET_VAR( qt1)
err = VMM_GET_VAR(fipt1)
err = VMM_GET_VAR( st1)
err = VMM_GET_VAR(pipt1)
err = VMM_GET_VAR( tpt1)
err = VMM_GET_VAR(tplt1)
err = VMM_GET_VAR( gptx)
err = VMM_GET_VAR(psdt1)
err = VMM_GET_VAR( tdt1)
err = VMM_GET_VAR( topo)
*
* TRAJECTORY
* ----------
err = VMM_GET_VAR( ut1m)
err = VMM_GET_VAR( vt1m)
err = VMM_GET_VAR( tpt1m)
err = VMM_GET_VAR( st1m)
*
Ind_fi_ = fit1_
Ind_u_ = ut1_
Ind_v_ = vt1_
Ind_t_ = tt1_
Ind_q_ = qt1_
Ind_fip_ = fipt1_
Ind_s_ = st1_
Ind_pip_ = pipt1_
Ind_tp_ = tpt1_
Ind_tpl_ = tplt1_
Ind_gp_ = gptx_
Ind_psd_ = psdt1_
Ind_td_ = tdt1_
Ind_topo_= topo_
*
Indm_um_ = ut1m_
Indm_vm_ = vt1m_
Indm_tpm_= tpt1m_
Indm_sm_ = st1m_
*
* ADJ of
* Compute total divergence and vertical velocity
* ----------------------------------------------
call uv2tdpsd_ad( Ind_td,Ind_psd,Ind_u, Ind_v, Ind_s,
$ Indm_um,Indm_vm,Indm_sm,
$ LDIST_DIM,l_nk)
*
!$omp parallel private (pr1,pr2)
*
* ----------------
* START TRAJECTORY
* ----------------
*
* Recover pipt1m as in V4D_PREDAT_TL
* ----------------------------------
!$omp do
do k=1,G_nk
*
if(k.eq.1) then
do j= 1, l_nj
do i= 1, l_ni
*
wpipt1m(i,j,1) = 0.
*
end do
end do
*
else
do j= 1, l_nj
do i= 1, l_ni
*
wpipt1m(i,j,k) = Geomg_pia(k)+Geomg_pib(k)*exp(Indm_sm(i,j))
% - Geomg_z_8(k)
*
end do
end do
endif
*
end do
!$omp end do
*
* --------------
* END TRAJECTORY
* --------------
*
* ADJ of
* Compute P and T'
* lin
* ------------------
!$omp do
do j= 1,l_nj
do k=G_nk,1,-1
pr1 = Dcst_rgasd_8 * Cstv_tstr_8 * Geomg_pib(k) / Geomg_z_8(k)
pr2 = Cstv_tstr_8*(Geomg_pib(k)/Geomg_z_8(k) - Geomg_dpib(k))
do i= 1,l_ni
*
* ADJ
* ---
Ind_s(i,j) = pr2 * Ind_tpl(i,j,k) + Ind_s(i,j)
*
* ADJ
* ---
Ind_pip(i,j,k) =
% (-1)*(
% (Cstv_tstr_8+Indm_tpm(i,j,k) )*
% (1.0+Geomg_dpib(k)*(exp(Indm_sm(i,j))-1.) )*
% Geomg_z_8(k) / (Geomg_z_8(k) + wpipt1m(i,j,k))**2
% )*Ind_tpl(i,j,k) + Ind_pip(i,j,k)
Ind_s(i,j) =
% (Cstv_tstr_8+Indm_tpm(i,j,k) )*
% ( Geomg_dpib(k)* exp(Indm_sm(i,j))*Ind_tpl(i,j,k) )*
% Geomg_z_8(k) / (Geomg_z_8(k) + wpipt1m(i,j,k)) + Ind_s(i,j)
Ind_tp(i,j,k) =
% ( Ind_tpl(i,j,k) )*
% (1.0+Geomg_dpib(k)*(exp(Indm_sm(i,j))-1.) )*
% Geomg_z_8(k) / (Geomg_z_8(k) + wpipt1m(i,j,k)) + Ind_tp(i,j,k)
*
Ind_tpl(i,j,k) = ZERO_8
*
Ind_fip(i,j,k) = Ind_gp(i,j,k) + Ind_fip(i,j,k)
Ind_s (i,j) = pr1 * Ind_gp(i,j,k) + Ind_s (i,j)
Ind_gp (i,j,k) = ZERO_8
*
end do
end do
end do
!$omp end do
*
* ADJ of
* Compute pi'
* -----------
*
!$omp do
do j= 1, l_nj
do i= 1, l_ni
*
Ind_pip(i,j,1) = ZERO_8
*
end do
end do
!$omp end do
*
!$omp do
do j= 1, l_nj
do k=2,G_nk
do i= 1, l_ni
*
Ind_s (i,j) = Geomg_pib(k)*exp(Indm_sm(i,j))* Ind_pip(i,j,k) + Ind_s(i,j)
Ind_pip(i,j,k) = ZERO_8
*
end do
end do
end do
!$omp end do
*
* ADJ of
* Compute q
* ---------
!$omp do
do j= 1, l_nj
do k=G_nk,1,-1
do i= 1, l_ni
*
Ind_s(i,j) = ( Geomg_pib(k)*exp(Indm_sm(i,j))*Ind_q(i,j,k) )/
% ( Geomg_pia(k) + Geomg_pib(k)*exp(Indm_sm(i,j)) )
% + Ind_s(i,j)
Ind_q(i,j,k) = ZERO_8
end do
end do
end do
!$omp end do
*
* ADJ of
* Compute T from T'
* -----------------
!$omp do
do k=1,G_nk
do j= 1, l_nj
do i= 1, l_ni
*
Ind_tp(i,j,k) = Ind_t(i,j,k) + Ind_tp(i,j,k)
Ind_t (i,j,k) = ZERO_8
*
end do
end do
end do
!$omp end do
*
!$omp end parallel
*
* ADJ of
* -------------------------------------------------------------
* Set dependent variables phi',phi from T',s' when Schm_hydro_L
* -------------------------------------------------------------
if (Schm_hydro_L) call vtap_ad ()
*
err = vmmuld(key1,nvar)
*
1000 format(//,'PREPROCESSING DATA: (S/R V4D_SET_VMM_AD)',
% /,'========================================',//)
*
* __________________________________________________________________
return
end