!-------------------------------------- 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 itf_phy_vmmprep - load all fields required by the physics
*
#include "model_macros_f.h"
*
subroutine itf_phy_vmmprep 1,15
$ (F_pvptr,NPTR, F_trp, F_trm, F_tp, F_qp, F_vtm, DIST_DIM,Nk )
*
implicit none
*
integer NPTR,DIST_DIM,Nk
integer*8 F_pvptr(NPTR)
real F_trp(DIST_SHAPE,Nk,*), F_trm(DIST_SHAPE,Nk,*)
real F_tp(DIST_SHAPE,Nk),F_qp(DIST_SHAPE,Nk),F_vtm(LDIST_SHAPE,Nk)
*
*author
* Michel Roch - rpn - april 1994
*
*revision
* v2_00 - Desgagne M. - initial MPI version
* v2_31 - Desgagne - clean up and introduce h2o tracers
* v3_00 - Laroche S. - adaptation for v4d
* v3_12 - Leduc A-M. - Add arguments gzm and topo
* v3_20 - Lee V. - Corrected loop i=1,p_nj to i-1,p_ni
* v3_21 - Dugas B. - Add F_busdyn(p_phis) = topo
* v3_30 - Tanguay M. - adapt TL/AD to pvptr
* v3_30 - Lee V. - removed clipping from tracers
* v3_31 - Bilodeau B. - offline mode: TT (and not VT) from entry
* no interpolation of winds
*
*object
*
*arguments
* Name I/O Description
*----------------------------------------------------------------
* F_up
*----------------------------------------------------------------
*
*implicits
#include "glb_ld.cdk"
#include "geomg.cdk"
#include "cstv.cdk"
#include "lun.cdk"
#include "dcst.cdk"
#include "schm.cdk"
#include "itf_phy_config.cdk"
#include "itf_phy_buses.cdk"
#include "inuvl.cdk"
#include "vt1.cdk"
#include "vt0.cdk"
#include "itf_phy_busind.cdk"
#include "p_geof.cdk"
#include "itf_phy_vmm.cdk"
*
**
integer vmmlod,vmmget,vmmuln
external vmmlod,vmmget,vmmuln
*
integer err, key(12), i, j, k, n, i0, j0, in, jn, nksurf,
$ keyd(NPTR), keyp(phyt_ntr), keym(phyt_ntr), keyp_, keym_
real dt, dzsedi, dzmin, dzmin_, sigsfc, trp, trm, con(l_nj)
real summqj(LDIST_SHAPE,Nk), sumpqj(LDIST_SHAPE,Nk),
$ vmm (LDIST_SHAPE,Nk)
pointer (patrp, trp(LDIST_SHAPE,*)),(patrm, trm(LDIST_SHAPE,*))
pointer (pavmm, vmm)
*
* ________________________________________________________________
*
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(fit1)
key( 8) = VMM_KEY(topo)
key( 9) = VMM_KEY(qt0)
key( 10) = VMM_KEY(qt1)
err = vmmlod(key,10)
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(fit1)
err = VMM_GET_VAR(topo)
err = VMM_GET_VAR(qt0)
err = VMM_GET_VAR(qt1)
*
keyd(1) = VMM_KEY(p_uplus)
keyd(2) = VMM_KEY(p_vplus)
keyd(3) = VMM_KEY(p_tplus)
keyd(4) = VMM_KEY(p_umoins)
keyd(5) = VMM_KEY(p_vmoins)
keyd(6) = VMM_KEY(p_tmoins)
keyd(7) = VMM_KEY(p_gzmoins6)
keyd(8) = VMM_KEY(p_omegap)
keyd(9) = VMM_KEY(p_sigm)
keyd(10) = VMM_KEY(p_phis)
keyd(11) = VMM_KEY(p_pplus)
keyd(12) = VMM_KEY(p_pmoins)
keyd(13) = VMM_KEY(p_dxdy)
keyd(14) = VMM_KEY(p_eponmod)
keyd(15) = VMM_KEY(p_fcpf)
keyd(16) = VMM_KEY(p_fcpw)
keyd(17) = VMM_KEY(p_sigt)
err = vmmlod(keyd,17)
err = VMM_GET_VAR(p_uplus)
err = VMM_GET_VAR(p_vplus)
err = VMM_GET_VAR(p_tplus)
err = VMM_GET_VAR(p_umoins)
err = VMM_GET_VAR(p_vmoins)
err = VMM_GET_VAR(p_tmoins)
err = VMM_GET_VAR(p_gzmoins6)
err = VMM_GET_VAR(p_omegap)
err = VMM_GET_VAR(p_sigm)
err = VMM_GET_VAR(p_phis)
err = VMM_GET_VAR(p_pplus)
err = VMM_GET_VAR(p_pmoins)
err = VMM_GET_VAR(p_dxdy)
err = VMM_GET_VAR(p_eponmod)
err = VMM_GET_VAR(p_fcpf)
err = VMM_GET_VAR(p_fcpw)
err = VMM_GET_VAR(p_sigt)
*
****************************************************
* Copy variables at time t- and t* in workfields *
****************************************************
*
do k=1,l_nk
do j= 1, l_nj
do i= 1, l_ni
p_umoins (i,j,k) = ut0 (i,j,k)
p_vmoins (i,j,k) = vt0 (i,j,k)
F_vtm (i,j,k) = tt0 (i,j,k)
p_gzmoins6(i,j,k) = fit1(i,j,k) - topo(i,j)
p_uplus (i,j,k) = ut1 (i,j,k)
p_vplus (i,j,k) = vt1 (i,j,k)
F_tp (i,j,k) = tt1 (i,j,k)
end do
end do
end do
*
if (Schm_hydro_L) then
do k= 1, l_nk
do j= 1, l_nj
do i= 1, l_ni
F_qp(i,j,k) = qt1(i,j,k)
enddo
enddo
enddo
do j= 1, l_nj
do i= 1, l_ni
p_pplus (i,j) = exp(qt1(i,j,l_nk))
p_pmoins(i,j) = exp(qt0(i,j,l_nk))
end do
end do
err = vmmuln(key,10)
else
err = vmmuln(key,8)
key(11) = VMM_KEY(qpt0)
key(12) = VMM_KEY(qpt1)
err = vmmlod(key(11),2)
err = VMM_GET_VAR(qpt0)
err = VMM_GET_VAR(qpt1)
do k= 1, l_nk
do j= 1, l_nj
do i= 1, l_ni
F_qp(i,j,k) = qt1(i,j,k) - qpt1(i,j,k)
enddo
enddo
enddo
do j= 1, l_nj
do i= 1, l_ni
p_pmoins(i,j) = exp( qt0(i,j,l_nk) - qpt0(i,j,l_nk) )
p_pplus(i,j) = exp( qt1(i,j,l_nk) - qpt1(i,j,l_nk) )
end do
end do
err = vmmuln(key(9),4)
endif
*
* Compute sigma levels from F_qp
* --------------------------------
do k=1,l_nk
do j=1,l_nj
do i=1,l_ni
p_sigm(i,j,k) = exp(F_qp(i,j,k)-F_qp(i,j,l_nk))
end do
end do
end do
*
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)
*No Clipping for tracers, it will be done in the PHYSICS
do n=1,phyt_ntr
err = vmmget(keyp(n),patrp,trp)
err = vmmget(keym(n),patrm,trm)
do k=1,l_nk
do j= 1, l_nj
do i= 1, l_ni
F_trp(i,j,k,n) = trp(i,j,k)
F_trm(i,j,k,n) = trm(i,j,k)
end do
end do
enddo
enddo
err = vmmuln(keyp,phyt_ntr)
err = vmmuln(keym,phyt_ntr)
endif
*
key(1) = VMM_KEY(st1)
key(2) = VMM_KEY(psdt1)
key(3) = VMM_KEY(tdt1)
err = vmmlod (key,3)
err = VMM_GET_VAR(st1)
err = VMM_GET_VAR(psdt1)
err = VMM_GET_VAR(tdt1)
*
call calomeg(p_omegap,psdt1,tdt1,st1,LDIST_DIM,l_nk,1,l_ni,1,l_nj)
*
*C dzmin determines the micro-physical timestep for sedimentation
*
* dzsedi is the minimal thickness of the sedimentation layer.
* Get default value from the physics package.
*
call phy_optr('DZSEDI',dzsedi,1,'GET',Lun_out.gt.0,err )
*
* The mixed-phase microphysics scheme combines the lower model
* layers (excluding the lowest) to compute a sedimentation
* timestep that is not too short in order to save on computing
* time. In order to do that, the dynamics must compute NKSURF
* (the index of the eta level just below dzsedi) and DZMIN (the
* minimal thickness in the domain, taking into account the
* combined levels).
*
dt = Cstv_dt_8
sigsfc=1.-(min(dt,dzsedi))/10000.
do k=G_nk-1,1,-1
if (geomg_hybm(k).lt.sigsfc) go to 100
end do
100 nksurf = min(G_nk-1,k+1)
*
dzmin_=1.e+5
if ( nksurf .eq. G_nk-1 ) then
*C The sedimentation is made
*C over all model levels
do j= 1, l_nj
do i= 1, l_ni
dzmin_= min(1.0d0*(dzmin_),
$ Dcst_rgasd_8*(1.0d0*(F_tp(i,j,G_nk-1)+ F_tp(i,j,G_nk-2)))/2.d0/
$ Dcst_grav_8*log(1.0d0*(geomg_hybm(G_nk-1)/geomg_hybm(G_nk-2))))
end do
end do
*
else
*C The sedimentation is made
*C over a reduced set of levels
do j= 1, l_nj
do i= 1, l_ni
dzmin_= min(1.0d0*(dzmin_),
$ Dcst_rgasd_8*(1.0d0*(F_tp(i,j,nksurf-1)+F_tp(i,j,nksurf-2)))/2.d0/
$ Dcst_grav_8 *log(1.0d0*(geomg_hybm(nksurf-1)/geomg_hybm(nksurf-2))))
dzmin_= min(1.0d0*(dzmin_),
$ Dcst_rgasd_8*(1.0d0*(F_tp(i,j,G_nk-1)+F_tp(i,j,nksurf-1)))/2.d0/
$ Dcst_grav_8 *log(1.0d0*(geomg_hybm(G_nk-1)/geomg_hybm(nksurf-1))))
end do
end do
*
endif
*
call rpn_comm_ALLREDUCE (dzmin_,dzmin,1,"MPI_REAL",
$ "MPI_MIN","grid",err)
*
* send dzmin and nksurf to the physics
call phycom ('dzmin' ,dzmin ,1,'set')
call phycom ('nksurf',nksurf,1,'set')
*
*C interpolate wind images at time t1 and t2
* -----------------------------------------
*
if (.not.schm_offline_L) then
call itf_phy_uvgridscal (p_uplus ,p_vplus ,LDIST_DIM,l_nk,.true.)
call itf_phy_uvgridscal (p_umoins,p_vmoins,LDIST_DIM,l_nk,.true.)
*
do j=1,l_nj
con(j) = ( 1.0/cos(geomg_y_8(j))) * Dcst_rayt_8
enddo
do k=1,l_nk
do j= 1, l_nj
do i= 1, l_ni
p_uplus(i,j,k) = p_uplus(i,j,k)*con(j)
p_umoins(i,j,k) = p_umoins(i,j,k)*con(j)
p_vplus(i,j,k) = p_vplus(i,j,k)*con(j)
p_vmoins(i,j,k) = p_vmoins(i,j,k)*con(j)
enddo
enddo
enddo
endif
*
*C Compute temperature from virtual temperature
* --------------------------------------------
*
call itf_phy_padbuf(F_tp,l_minx,l_maxx,l_miny,l_maxy,Nk)
call itf_phy_padbuf(F_trp,l_minx,l_maxx,l_miny,l_maxy,Nk)
call itf_phy_padbuf(F_trm,l_minx,l_maxx,l_miny,l_maxy,Nk)
call itf_phy_padbuf(F_vtm,l_minx,l_maxx,l_miny,l_maxy,Nk)
*
if(Schm_wload_L)then
*
summqj = 0.
sumpqj = 0.
* Sum over Hydrometeors, note: 'HU' is in position 1
do n = 2, h2o_ntr
do k = 1, Nk
do j= 1, l_nj
do i = 1, l_ni
summqj(i,j,k)=summqj(i,j,k)+F_trm(i,j,k,n)
sumpqj(i,j,k)=sumpqj(i,j,k)+F_trp(i,j,k,n)
end do
end do
end do
end do
call itf_phy_padbuf(summqj,l_minx,l_maxx,l_miny,l_maxy,Nk)
call itf_phy_padbuf(sumpqj,l_minx,l_maxx,l_miny,l_maxy,Nk)
call mfottvh ( p_tplus ,F_tp,
$ F_trp(l_minx,l_miny,1,1),sumpqj,
$ (l_maxx-l_minx+1)*(l_maxy-l_miny+1),Nk,
$ (l_maxx-l_minx+1)*(l_maxy-l_miny+1) )
call mfottvh ( p_tmoins,F_vtm,
$ F_trm(l_minx,l_miny,1,1),summqj,
$ (l_maxx-l_minx+1)*(l_maxy-l_miny+1),Nk,
$ (l_maxx-l_minx+1)*(l_maxy-l_miny+1) )
*
else
*
if (.not.schm_offline_L) then
call mfottv ( p_tplus ,F_tp,
$ F_trp(l_minx,l_miny,1,1),
$ (l_maxx-l_minx+1)*(l_maxy-l_miny+1),Nk,
$ (l_maxx-l_minx+1)*(l_maxy-l_miny+1) )
call mfottv ( p_tmoins,F_vtm,
$ F_trm(l_minx,l_miny,1,1),
$ (l_maxx-l_minx+1)*(l_maxy-l_miny+1),Nk,
$ (l_maxx-l_minx+1)*(l_maxy-l_miny+1) )
*
else
*
* Copy TPLUS and TMOINS directly (no virtual temperature)
do k=1,Nk
do j=1,l_nj
do i=1,l_ni
p_tplus (i,j,k) = F_tp (i,j,k)
p_tmoins(i,j,k) = F_vtm(i,j,k)
end do
end do
end do
endif
*
endif
*
* The following hardcoding of fcpf, fcpw and eponmod will be
* a source of difference for future acide test with physics
do j=1,l_nj
do i=1,l_ni
p_phis(i,j)= topo(i,j)
p_dxdy(i,j)= geomg_hxu_8(i-1)*geomg_hyv_8(j-1)*
$ Dcst_rayt_8*Dcst_rayt_8*geomg_cy_8(j)
p_fcpf(i,j) = 2.
p_fcpw(i,j) = 1.
p_eponmod(i,j) = 1.
enddo
enddo
*
if (.not. G_lam) then
do j=1,l_nj
do i=1,l_ni
p_fcpf (i,j) = P_fcpkuo_fcpf(i,j)
p_fcpw (i,j) = P_fcpkuo_fcpw(i,j)
p_eponmod(i,j) = P_lmvd_vlsp (i,j)
enddo
enddo
endif
*
* Surface fields:
* pointers are stored the same order as the common block p_phy
* inside F_pvptr
do i=1,COMMON_SIZE(p_phy)
keyd(i) = p_phy_first(i)
err = vmmget(keyd(i),pavmm,vmm)
F_pvptr(i) = pavmm
enddo
*
* ________________________________________________________________
*
return
end