!-------------------------------------- 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 initw2 -- initialize vertical nonhydrostatic wind "wt1"
*
#include "model_macros_f.h"
*
subroutine initw2 ( F_wt1, F_mul, F_mu, F_uu, F_vv, F_psd, F_fi, 3,2
$ F_tt, F_ss, DIST_DIM )
implicit none
*
integer DIST_DIM
real F_wt1(DIST_SHAPE,*),F_ss (DIST_SHAPE ),F_uu (DIST_SHAPE,*),
$ F_vv (DIST_SHAPE,*),F_psd(DIST_SHAPE,*),F_fi (DIST_SHAPE,*),
$ F_tt (DIST_SHAPE,*),F_mul(DIST_SHAPE,*),F_mu (DIST_SHAPE,*)
*
*author
* S. Edouard - november 2001 - hybrid version
*
*revisions
* v2_31 - Edouard S. - initial version
* v3_02 - Edouard S. - correct a bug
* v3_21 - Desgagne M. - OpenMP optimization
* v3_30 - Lee V. - use of geomg_invhsy_8, moved j0,jn,ng before
* parallel region
*
*object
* compute the vertical wind diagonostically in the hybrid coordinate
*
*****************************************************************************************
* *
* Assume hydrostatic & adiabatic, the vertical wind "wt1" (DZ/Dt) *
* can be approximated with the equation *
* *
* / pi* \ *
* |/ gnk |*
* || |*
* || / / \ \ / \|*
* DZ __ R T || b __ | | /\A + /\b exp(s) | | * . * | /\A + /\b exp(s) ||*
* -- = V.\/Z + --- ||-- \/.| V | ---------------- | | d pi - pi | ---------------- ||*
* Dt g pi|| z | | /\A + /\b | | | /\A + /\b ||*
* || gnk \ \ / / \ /|*
* (TERM1) || |*
* |/ pi* (TERM2) |*
* \ 1 / *
* *
* where *
* *
* D( )/Dt is the total derivative: pronounced as "d-( ) over d-t" *
* *
* /\A = 1 - db/dz *
* *
* /\A + /\b exp(s) *
* ---------------- = 1 + db/dz (exp(s) -1) *
* /\A + /\b *
*****************************************************************************************
*
*
*arguments
* Name I/O Description
*----------------------------------------------------------------
* F_wt1 O vertical velocity ( DZ/Dt )
* F_uu I x component of hor. velocity
* F_vv I y component of hor. velocity
* F_psd I vertical velocity ( pi star dot )
* F_fi I geopotential
* F_tt I virtual temperature
* F_ss I ln (pi / z )
* s s
*----------------------------------------------------------------
*
*implicits
#include "glb_ld.cdk"
#include "geomg.cdk"
#include "intuv.cdk"
#include "inuvl.cdk"
#include "dcst.cdk"
#include "cstv.cdk"
#include "schm.cdk"
*
*modules
integer i, j, k, j0, jn, in1, in2, jn1, jn2, ng
real wk1 (DIST_SHAPE,G_nk), wk2 (DIST_SHAPE,G_nk),
$ wk3 (DIST_SHAPE,G_nk), wk4 (DIST_SHAPE,G_nk)
**
* __________________________________________________________________
*
call rpn_comm_xch_halo ( F_fi, LDIST_DIM, l_ni, l_nj, G_nk,
$ G_halox,G_haloy,G_periodx,G_periody,l_ni,0 )
*
in1= l_ni
in2= l_niu
jn1= l_nj
jn2= l_njv
j0 = 1
jn = l_njv
if (l_south) j0 = 3
if (l_north) jn = l_njv - 1
* ng is used in hatoprg
ng = (l_maxx-l_minx+1)*(l_maxy-l_miny+1)
*
****************************************************
* TERM1: HORIZONTAL ADVECTION OF GEOGRAPHIC HEIGHT *
****************************************************
*
* Gradient of geopotential
* ~~~~~~~~~~~~~~~~~~~~~~~~
!$omp parallel
*
!$omp do
do k = 1, G_nk
F_mul(:,:,k) = 0.
F_mu (:,:,k) = 0.
wk1 (:,:,k) = 0.
wk2 (:,:,k) = 0.
wk3 (:,:,k) = 0.
wk4 (:,:,k) = 0.
do j = 1, jn1
do i = 1, in2
wk1(i,j,k) = ( F_fi(i+1,j,k) - F_fi(i,j,k) ) / geomg_hx_8(i)
$ * F_uu(i,j,k) / Dcst_grav_8
end do
end do
do j = 1, jn2
do i = 1, in1
wk2(i,j,k) = ( F_fi(i,j+1,k)-F_fi(i,j,k) ) * geomg_cyv2_8(j)
$ * geomg_invhsy_8(j) * F_vv(i,j,k) / Dcst_grav_8
end do
end do
end do
!$omp enddo
*
* Interpolate from staggered grids to basic grid
*
!$omp single
call rpn_comm_xch_halo ( wk1, LDIST_DIM, l_niu,l_nj,G_nk,
$ G_halox,G_haloy,G_periodx,G_periody,l_ni,0 )
call rpn_comm_xch_halo ( wk2, LDIST_DIM, l_ni,l_njv,G_nk,
$ G_halox,G_haloy,G_periodx,G_periody,l_ni,0 )
!$omp end single
*
!$omp do
do k = 1, G_nk
do j = 1, jn1
do i = 1, in2
wk3(i,j,k) = inuvl_wxux3_8(i,1) * wk1(i-2,j,k)
$ + inuvl_wxux3_8(i,2) * wk1(i-1,j,k)
$ + inuvl_wxux3_8(i,3) * wk1(i ,j,k)
$ + inuvl_wxux3_8(i,4) * wk1(i+1,j,k)
end do
end do
end do
!$omp enddo
*
!$omp do
do k=1,G_nk
do j = j0, jn
do i = 1, in1
wk1(i,j,k) = inuvl_wyvy3_8(j,1) * wk2(i,j-2,k)
$ + inuvl_wyvy3_8(j,2) * wk2(i,j-1,k)
$ + inuvl_wyvy3_8(j,3) * wk2(i,j ,k)
$ + inuvl_wyvy3_8(j,4) * wk2(i,j+1,k)
end do
end do
if (l_south) then
do i = 1, in1
wk1(i,j0-2,k) = inuvl_wyvy3_8(j0-2,3) * wk2(i,j0-2,k)
$ + inuvl_wyvy3_8(j0-2,4) * wk2(i,j0-1,k)
wk1(i,j0-1,k) = inuvl_wyvy3_8(j0-1,2) * wk2(i,j0-2,k)
$ + inuvl_wyvy3_8(j0-1,3) * wk2(i,j0-1,k)
$ + inuvl_wyvy3_8(j0-1,4) * wk2(i,j0 ,k)
end do
endif
if (l_north) then
do i = 1, in1
wk1(i,jn+2,k) = inuvl_wyvy3_8(jn+2,1) * wk2(i,jn ,k)
$ + inuvl_wyvy3_8(jn+2,2) * wk2(i,jn+1,k)
wk1(i,jn+1,k) = inuvl_wyvy3_8(jn+1,1) * wk2(i,jn-1,k)
$ + inuvl_wyvy3_8(jn+1,2) * wk2(i,jn ,k)
$ + inuvl_wyvy3_8(jn+1,3) * wk2(i,jn+1,k)
end do
endif
do j = 1, jn1
do i = 1, in1
F_wt1(i,j,k) = ( wk3(i,j,k) + wk1(i,j,k) ) / geomg_cy2_8(j)
wk1(i,j,k) = 1 + geomg_dpib(k) * (exp(F_ss(i,j)) - 1.0)
end do
end do
end do
!$omp enddo
*
*********
* TERM2 *
*********
*
* Prepare key factors of TERM2
*
!$omp single
call rpn_comm_xch_halo ( wk1, LDIST_DIM,l_ni,l_nj,G_nk,
$ G_halox,G_haloy,G_periodx,G_periody,l_ni,0 )
!$omp end single
*
!$omp do
do k=1,G_nk
do j = 1, jn1
do i = 1, in1
wk3(i,j,k) = ((1.-intuv_c0xxu_8(i))*wk1(i ,j,k)
$ + intuv_c0xxu_8(i) * wk1(i+1,j,k))*F_uu(i,j,k)
end do
end do
do j = 1, jn2
do i = 1, in1
wk4(i,j,k) = ((1.-intuv_c0yyv_8(j))*wk1(i,j ,k)
$ + intuv_c0yyv_8(j) * wk1(i,j+1,k))*F_vv(i,j,k)
end do
end do
end do
!$omp enddo
*
!$omp single
call rpn_comm_xch_halo ( wk3, LDIST_DIM, l_niu,l_nj,G_nk,
$ G_halox,G_haloy,G_periodx,G_periody,l_ni,0 )
call rpn_comm_xch_halo ( wk4, LDIST_DIM, l_ni,l_njv,G_nk,
$ G_halox,G_haloy,G_periodx,G_periody,l_ni,0 )
!$omp end single
*
!$omp do
do k=1,G_nk
call caldiv_2 ( wk2(minx,miny,k), wk3(minx,miny,k),
$ wk4(minx,miny,k), LDIST_DIM, 1 )
end do
!$omp enddo
!$omp end parallel
*
* Vertical integration over pi*
*
call hatoprg (wk4,wk2,1.0,geomg_hz_8,ng,G_nk)
*
!$omp parallel
!$omp do
do k = 1, G_nk
do j = 1, jn1
do i = 1, in1
F_wt1(i,j,k) = F_wt1(i,j,k) +
$ Dcst_rgasd_8 * F_tt(i,j,k) / Dcst_grav_8 /
$ ( geomg_pia(k) + geomg_pib(k)*exp(F_ss(i,j)) ) *
$ ( wk4(i,j,1) * geomg_pib(k) / Cstv_pisrf_8 -
$ F_psd(i,j,k) * wk1(i,j,k) )
end do
end do
end do
!$omp enddo
*
!$omp end parallel
* __________________________________________________________________
*
return
end