!-------------------------------------- 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_phydro - Set phi' hydrostatic in control variable F
*
#include "model_macros_f.h"
*
subroutine v4d_phydro (Ndim,F) 2,3
*
#include "impnone.cdk"
*
integer Ndim
real F(Ndim)
*
*author
* M.Tanguay
*
*revision
* v3_03 - Tanguay M. - initial MPI version
*
*object
* see id section
*
*arguments
* none
*
*implicits
#include "glb_ld.cdk"
#include "schm.cdk"
#include "ind.cdk"
#include "indm.cdk"
#include "p_geof.cdk"
#include "tr3d.cdk"
*
integer vmmlod,vmmget,vmmuld
external vmmlod,vmmget,vmmuld
*
integer key1(1),err,i,j,k,m,n
*
real fipt1_w,fit1_w,tpt1_w,st1_w
pointer (fipt1_w_,fipt1_w(LDIST_SHAPE,l_nk)),(fit1_w_,fit1_w (LDIST_SHAPE,l_nk)),
% ( tpt1_w_, tpt1_w(LDIST_SHAPE,l_nk)),( st1_w_, st1_w (LDIST_SHAPE ))
* ______________________________________________________
*
call hpalloc (fipt1_w_,(l_maxy-l_miny+1)*(l_maxx-l_minx+1)*l_nk,err,1)
call hpalloc ( fit1_w_,(l_maxy-l_miny+1)*(l_maxx-l_minx+1)*l_nk,err,1)
call hpalloc ( tpt1_w_,(l_maxy-l_miny+1)*(l_maxx-l_minx+1)*l_nk,err,1)
call hpalloc ( st1_w_,(l_maxy-l_miny+1)*(l_maxx-l_minx+1) ,err,1)
*
* Get TOPO field in memory
* ------------------------
key1(1) = VMM_KEY(topo)
*
err = vmmlod(key1,1)
*
err = VMM_GET_VAR(topo)
*
* -----------------------------------------
* Recall tpt1 and st1 in control variable F
* -----------------------------------------
*
m = 0
*
* Do nothing with u wind
* ----------------------
do k=1,l_nk
do j=1,l_nj
do i=1,l_niu
m = m+1
end do
end do
enddo
*
* Do nothing with v wind
* ----------------------
do k=1,l_nk
do j=1,l_njv
do i=1,l_ni
m = m+1
end do
end do
end do
*
* Recall tp
* ---------
do k=1,l_nk
do j=1,l_nj
do i=1,l_ni
m = m+1
tpt1_w(i,j,k) = F(m)
end do
end do
end do
*
* Recall s
* --------
do j=1,l_nj
do i=1,l_ni
m = m+1
st1_w(i,j) = F(m)
end do
end do
*
* Do nothing with fip
* -------------------
if (.not. Schm_hydro_L) then
*
do k=1,l_nk
do j=1,l_nj
do i=1,l_ni
m = m+1
end do
end do
end do
*
endif
*
* Do nothing with 3D Tracers
* --------------------------
if (Tr3d_ntr.gt.0) then
do n=1,Tr3d_ntr
do k=1,l_nk
do j=1,l_nj
do i=1,l_ni
m = m+1
end do
end do
end do
end do
endif
* ______________________________________________________
*
if(m.ne.Ndim) call gem_stop('v4d_phydro 1',-1)
* ______________________________________________________
*
Ind_fi_ = fit1_w_
Ind_fip_ = fipt1_w_
Ind_s_ = st1_w_
Ind_tp_ = tpt1_w_
Ind_topo_= topo_
*
* -------------------------------------------
* Set dependent variables phi',phi from T',s'
* -------------------------------------------
call vtap ()
*
err = vmmuld(-1,0)
*
* ------------------------------------------
* Set phi' hydrostatic in control variable F
* ------------------------------------------
*
m = 0
*
* Do nothing with u wind
* ----------------------
do k=1,l_nk
do j=1,l_nj
do i=1,l_niu
m = m+1
end do
end do
enddo
*
* Do nothing with v wind
* ----------------------
do k=1,l_nk
do j=1,l_njv
do i=1,l_ni
m = m+1
end do
end do
end do
*
* Do nothing with tp
* ------------------
do k=1,l_nk
do j=1,l_nj
do i=1,l_ni
m = m+1
end do
end do
end do
*
* Do nothing with s
* -----------------
do j=1,l_nj
do i=1,l_ni
m = m+1
end do
end do
*
* Replace fip
* -----------
if (.not. Schm_hydro_L) then
*
do k=1,l_nk
do j=1,l_nj
do i=1,l_ni
m = m+1
F(m) = fipt1_w(i,j,k)
end do
end do
end do
*
endif
*
* Do nothing with 3D Tracers
* --------------------------
if (Tr3d_ntr.gt.0) then
do n=1,Tr3d_ntr
do k=1,l_nk
do j=1,l_nj
do i=1,l_ni
m = m+1
end do
end do
end do
end do
endif
*
call hpdeallc (fipt1_w_,err,1)
call hpdeallc ( fit1_w_,err,1)
call hpdeallc ( tpt1_w_,err,1)
call hpdeallc ( st1_w_,err,1)
* ______________________________________________________
*
if(m.ne.Ndim) call gem_stop('v4d_phydro 2',-1)
* ______________________________________________________
*
return
end