!-------------------------------------- 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 uv2tdpsd - Computes total divergence &
* vertical velocity diagnostically
*
#include "model_macros_f.h"
*
subroutine uv2tdpsd (F_td, F_psd, F_uu, F_vv, F_ss, DIST_DIM, Nk) 6,3
*
implicit none
*
integer DIST_DIM, Nk
real F_td(DIST_SHAPE,Nk), F_psd(DIST_SHAPE,Nk),
$ F_uu(DIST_SHAPE,Nk), F_vv (DIST_SHAPE,Nk),
$ F_ss(DIST_SHAPE)
*
*authors
* Methot et Patoine - sept 1995 - cmc
*
*revision
* v2_00 - Desgagne M. - initial MPI version (from uv2tdpsd v1_03)
* v2_30 - Edouard S. - adapt for vertical hybrid coordinate
* v3_00 - Desgagne & Lee - Lam configuration
* v3_03 - Desgagne M. - split call to rpn_comm_xch_halo for uv
* v3_10 - Corbeil & Desgagne & Lee - AIXport+Opti+OpenMP
* v3_21 - Desgagne M. - Optimization
* v3_30 - Lee V. - Zero psd only if k=1,k=G_nk
*
*object
*******************************************************************************
* *
* The switch & = 0 (1) for a linear (non-linear) model. *
* l *
* *
* d / dpi \ dpi *
* -- | ln -- * | + D + --- * = 0 (1) *
* dt \ dpi / dpi *
* *
* *
* d / dpi \ __ / dpi \ d / . * dpi \ *
* -- | -- * | + \/ . | V -- * | + -- | pi -- * | = 0 (2) *
* dt \ dpi / \ dpi / dpi \ dpi / *
* *
* *
* 1) Integrate (2) from pi to pi *
* 1 gnk *
* *
* * *
* pi *
* / gnk *
* | *
* dpi | __ / dpi \ * *
* -- | = - | \/ . | V -- * | dpi = 0 (3) *
* dt | * | \ dpi / *
* pi | *
* gnk / * *
* pi *
* 1 *
* *
* dpi b dpi *
* and, -- | = -- -- | since pi = b exp(s) (4) *
* dt | * b dt | * *
* pi gnk pi *
* k gnk *
* *
* *
* 2) Integrate (2) from pi to pi with (3) and (4) gives : *
* k gnk *
* *
* * *
* pi *
* / 1 *
* * / | \ *
* . * dpi | | __ / dpi \ * b dpi | *
* pi = -- | | \/ . | V -- * | dpi - -- -- | | *
* dpi | | \ dpi / b dt | * | *
* \ | gnk pi / *
* / * gnk *
* pi *
* *
* 3) From (1) , we get : *
* *
* . * * / \ *
* dpi dpi | d / dpi \ __ dpi . * d / dpi \ | *
* D + -- * = - -- | -- | -- | + V . \/ -- + pi -- | -- * | | *
* dpi dpi | * \ dt / * * \ dpi / | *
* \ dpi dpi dpi / *
* *
* with, *
* d / dpi \ / __ 2 __ 2 __ __ *
* -- | -- * | = | ( \/ A + \/ b exp(s) )( \/A + \/b ) - *
* * \ dpi / \ __ __ __ 2 __ 2 \ *
* dpi ( \/A + \/b exp(s))(\/ A + \/ b ) | / *
* / *
* __ __ 3 *
* ( \/A + \/b ) *
* *
*******************************************************************************
*
*arguments
*______________________________________________________________________
* | | | |
* NAME | DESCRIPTION | DIMENSION |I/O|
*--------|---------------------------------------------|-----------|---|
* F_td | total divergence | 3D | o |
* F_psd | vertical velocity ( pi*-dot ) | 3D | o |
*--------|---------------------------------------------|-----------|---|
* F_uu | x component of velocity | 3D | i |
* F_vv | y component of velocity | 3D | i |
* F_ss | ln ( pi / z ) | 2D | i |
*________|_____________________________________________|___________|___|
*
*implicits
#include "glb_ld.cdk"
#include "geomg.cdk"
#include "intuv.cdk"
*
*modules
*
integer i, j, k, ng
real pr1, prsc
real uv(DIST_SHAPE,Nk,2),dvi(DIST_SHAPE,Nk),w1(DIST_SHAPE,Nk)
real*8 expf(l_niu+1,l_njv+1), expfm1(l_niu+1,l_njv+1),
$ inv_geomg_hx_8(l_ni), gratio(l_nj), inv_geomg_cy2_8(l_nj)
**
* ________________________________________________________________
*
call rpn_comm_xch_halo( F_ss, LDIST_DIM, l_ni, l_nj , 1,
% G_halox,G_haloy,G_periodx,G_periody,l_ni,0)
*
!$omp parallel
*
!$omp do
do k = 1, Nk
F_td (:,:,k ) = 0.
uv (:,:,k,:) = 0.
if (k.eq.1) then
do j = 1,l_njv+1
do i = 1,l_niu+1
expf (i,j) = exp(F_ss(i,j))
expfm1(i,j) = expf(i,j) - 1.0d0
end do
end do
do i = 1, l_niu
inv_geomg_hx_8(i) = 1.0d0 / geomg_hx_8(i)
end do
do j = 1, l_njv
gratio(j) = geomg_cyv2_8(j) / geomg_hsy_8(j)
inv_geomg_cy2_8(j) = 1.0d0 / geomg_cy2_8(j)
end do
inv_geomg_cy2_8(l_nj) = 1.0d0 / geomg_cy2_8(l_nj)
endif
end do
!$omp enddo
* __ *
* compute \/ . ( V dpi/dpi )
*
!$omp do
do k=1,G_nk
do j = 1, l_nj
do i = 1, l_niu
uv(i,j,k,1) = F_uu(i,j,k) * (
$ (1.-intuv_c0xxu_8(i))*(1.+(geomg_dpib(k)*expfm1(i,j)))
$ + intuv_c0xxu_8(i) *(1.+(geomg_dpib(k)*expfm1(i+1,j))) )
end do
end do
do j = 1, l_njv
do i = 1, l_ni
uv(i,j,k,2) = F_vv(i,j,k) * (
$ (1.-intuv_c0yyv_8(j))*(1.+(geomg_dpib(k)*expfm1(i,j)))
$ + intuv_c0yyv_8(j) *(1.+(geomg_dpib(k)*expfm1(i,j+1))) )
end do
end do
end do
!$omp enddo
*
!$omp single
call rpn_comm_xch_halo (uv, LDIST_DIM, l_niu,l_nj,
$ G_nk,G_halox,G_haloy,G_periodx,G_periody,l_ni,0 )
call rpn_comm_xch_halo (uv(minx,miny,1,2), 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 ( F_td(minx,miny,k), uv(minx,miny,k,1),
$ uv(minx,miny,k,2), LDIST_DIM, 1 )
end do
!$omp enddo
*
* *
* pi
* / gnk
* | __ * *
* compute | \/ . ( V dpi/dpi ) dpi
* |
* / *
* pi
* k
*
ng = (l_maxx-l_minx+1)*(l_maxy-l_miny+1)
call hatoprg (dvi,F_td,1.0,geomg_hz_8,ng,G_nk)
*
* .*
* compute pi
* k
*
!$omp do
do k=1,G_nk
do j=1,l_nj
do i=1,l_ni
pr1 = 1.0 + geomg_dpib(k) * expfm1(i,j)
F_psd(i,j,k) = (dvi(i,j,k) + ((geomg_pib(k)/
% geomg_pib(G_nk)) -1) * dvi(i,j,1))/pr1
end do
end do
do j = 1, l_nj
do i = 1, l_niu
uv(i,j,k,1) = (F_ss(i+1,j)-F_ss(i,j)) *
$ inv_geomg_hx_8(i) * F_uu(i,j,k)
end do
end do
do j = 1, l_njv
do i = 1, l_ni
uv(i,j,k,2) = (F_ss(i,j+1)-F_ss(i,j)) *
$ gratio(j) * F_vv(i,j,k)
end do
end do
end do
!$omp enddo
!$omp end parallel
*
call itf_phy_uvgridscal ( uv(minx,miny,1,1), uv(minx,miny,1,2),
$ LDIST_DIM, l_nk, .true. )
*
* Compute total divergence
* ------------------------
prsc = 1./geomg_pib(G_nk)
!$omp parallel private(pr1)
!$omp do
do k=1,G_nk
do j= 1, l_nj
do i= 1, l_ni
pr1 = (uv(i,j,k,1)+uv(i,j,k,2))*inv_geomg_cy2_8(j)
F_td(i,j,k) =
$ geomg_dpib(k)*(prsc*dvi(i,j,1)-expf(i,j)*pr1)
$ - F_psd(i,j,k)*expfm1(i,j)*geomg_dpia(k)
F_td(i,j,k) = F_td(i,j,k)/(1+geomg_dpib(k)*expfm1(i,j))
enddo
enddo
* for openmp, the k must be checked to apply the zero
if (k.eq.1.or.k.eq.G_nk) F_psd(:,:, k) = 0.
enddo
!$omp enddo
*
!$omp end parallel
*
* ________________________________________________________________
*
return
end