!-------------------------------------- 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_tl - TLM of uv2tdpsd
*
#include "model_macros_f.h"
*
subroutine uv2tdpsd_tl( F_td, F_psd, F_uu, F_vv, F_ss, 3,6
% F_tdm,F_psdm,F_uum,F_vvm,F_ssm,
% DIST_DIM, Nk )
*
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),
$ F_tdm(DIST_SHAPE,Nk),F_psdm(DIST_SHAPE,Nk),
$ F_uum(DIST_SHAPE,Nk),F_vvm (DIST_SHAPE,Nk),
$ F_ssm(DIST_SHAPE)
*
*author
* M.Tanguay
*
*revision
* v2_10 - Tanguay M. - initial MPI version
* v2_31 - Tanguay M. - adapt for vertical hybrid coordinate
* v3_00 - Laroche S. - cleanup
* v3_03 - Tanguay M. - split call to rpn_comm_xch_halo for uv
* v3_11 - Tanguay M. - AIXport+Opti+OpenMP for TLM-ADJ
* v3_21 - Tanguay M. - Revision Openmp
* v3_30 - Tanguay M. - adapt TL/AD to itf
*
*object
* see id section
*
*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 |
* | s s | | |
* F_uum | traj of x component of velocity | 3D |i |
* F_vvm | traj of y component of velocity | 3D |i |
* F_ssm | traj of ln ( pi / z ) | 2D |i |
* | s s | | |
*__________|_____________________________________________|___________|___|
*
*implicits
#include "glb_ld.cdk"
#include "cstv.cdk"
#include "dcst.cdk"
#include "schm.cdk"
#include "geomg.cdk"
#include "intuv.cdk"
#include "inuvl.cdk"
*
integer i, j, k, ng
real pr1, prsc, pr1m
real uv(DIST_SHAPE,Nk,2), dvi(DIST_SHAPE,Nk)
real uvm(DIST_SHAPE,Nk,2),dvim(DIST_SHAPE,Nk)
real*8 expfm_8(l_niu+1,l_njv+1), expfm1m_8(l_niu+1,l_njv+1),
$ inv_Geomg_hx_8(l_ni), gratio_8(l_nj), inv_Geomg_cy2_8(l_nj),
$ dpib1m_8(l_niu+1,l_njv+1), inv1m_8(l_niu+1,l_njv+1),
$ dpib2m_8(l_niu+1,l_njv+1), inv2m_8(l_niu+1,l_njv+1)
* ________________________________________________________________
*
*
* ----------------
* START TRAJECTORY
* ----------------
*
call rpn_comm_xch_halo( F_ssm, LDIST_DIM, l_ni, l_nj , 1,
$ G_halox,G_haloy,G_periodx,G_periody,l_ni,0)
*
!$omp parallel private (pr1,pr1m,dpib1m_8,dpib2m_8,
!$omp$ inv1m_8,inv2m_8) shared (ng,l_nk,prsc)
*
!$omp do
do k=1,G_nk
*
* TRAJECTORY
* ----------
F_tdm (:,:,k ) = 0.
uvm (:,:,k,:) = 0.
*
if (k.eq.1) then
do j = 1,l_njv+1
do i = 1,l_niu+1
expfm_8 (i,j) = exp(F_ssm(i,j))
expfm1m_8(i,j) = expfm_8(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_nj
gratio_8(j) = Geomg_cyv2_8(j) / Geomg_hsy_8(j)
inv_Geomg_cy2_8(j) = 1.0d0 / Geomg_cy2_8(j)
end do
endif
*
end do
!$omp enddo
*
* b) compute \/ . ( V dpi/dpi )
!$omp do
do k=1,G_nk
do j = 1, l_nj
do i = 1, l_niu
uvm(i,j,k,1) = F_uum(i,j,k) * (
$ (1.-intuv_c0xxu_8(i))*(1.+(Geomg_dpib(k)*expfm1m_8(i ,j)))
$ + intuv_c0xxu_8(i) *(1.+(Geomg_dpib(k)*expfm1m_8(i+1,j))) )
end do
end do
do j = 1, l_njv
do i = 1, l_ni
uvm(i,j,k,2) = F_vvm(i,j,k) * (
$ (1.-intuv_c0yyv_8(j))*(1.+(Geomg_dpib(k)*expfm1m_8(i,j )))
$ + intuv_c0yyv_8(j) *(1.+(Geomg_dpib(k)*expfm1m_8(i,j+1))) )
end do
end do
end do
!$omp enddo
*
!$omp single
*
call rpn_comm_xch_halo (uvm, LDIST_DIM, l_niu,l_nj,
$ G_nk,G_halox,G_haloy,G_periodx,G_periody,l_ni,0 )
call rpn_comm_xch_halo (uvm(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_tdm(minx,miny,k), uvm(minx,miny,k,1),
$ uvm(minx,miny,k,2), LDIST_DIM, 1 )
end do
!$omp enddo
!$omp end parallel
*
* *
* pi
* / gnk
* | __ * *
* c) compute | \/ . ( V dpi/dpi ) dpi
* |
* / *
* pi
* k
*
ng = (l_maxx-l_minx+1)*(l_maxy-l_miny+1)
call hatoprg (dvim,F_tdm,1.0,Geomg_hz_8,ng,G_nk)
*
* .*
* dpi
* Compute D + ---- integrated vertically
* ------- *
* dpi
*
*
* compute V . \/ (dpi/dpi )
*
!$omp parallel private (pr1,pr1m,dpib1m_8,dpib2m_8,
!$omp$ inv1m_8,inv2m_8) shared (ng,l_nk,prsc)
!$omp do
do k=1,G_nk
do j=1,l_nj
do i=1,l_ni
*
pr1m = 1.0 + Geomg_dpib(k) * expfm1m_8(i,j)
F_psdm(i,j,k) = (dvim(i,j,k) + ((Geomg_pib(k)/
$ Geomg_pib(G_nk)) -1) * dvim(i,j,1))/pr1m
*
end do
end do
*
do j = 1, l_nj
do i = 1, l_niu
uvm(i,j,k,1) = (F_ssm(i+1,j)-F_ssm(i,j))*inv_Geomg_hx_8(i)*F_uum(i,j,k)
end do
end do
*
do j = 1, l_njv
do i = 1, l_ni
uvm(i,j,k,2) = (F_ssm(i,j+1) - F_ssm(i,j))*gratio_8(j)*F_vvm(i,j,k)
end do
end do
*
end do
!$omp enddo
!$omp end parallel
*
call itf_phy_uvgridscal ( uvm(minx,miny,1,1), uvm(minx,miny,1,2),
$ LDIST_DIM, l_nk, .true.)
*
* Compute total divergence
* ------------------------
prsc = 1./Geomg_pib(G_nk)
*
!$omp parallel private (pr1,pr1m,dpib1m_8,dpib2m_8,
!$omp$ inv1m_8,inv2m_8) shared (ng,l_nk,prsc)
!$omp do
do k=1,G_nk
do j= 1, l_nj
do i= 1, l_ni
*
pr1m = (uvm(i,j,k,1)+uvm(i,j,k,2))*inv_Geomg_cy2_8(j)
F_tdm(i,j,k)= Geomg_dpib(k)* (prsc*dvim(i,j,1)
$ -expfm_8(i,j) * pr1m)
$ -F_psdm(i,j,k)*expfm1m_8(i,j)*Geomg_dpia(k)
*
enddo
enddo
enddo
!$omp enddo
*
* --------------
* END TRAJECTORY
* --------------
* ________________________________________________________________
*
* ---------
* START TLM
* ---------
*
!$omp single
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 end single
*
* __ *
* b) compute \/ . ( V dpi/dpi )
*
!$omp do
do k=1,G_nk
*
F_td (:,:,k ) = 0.
uv (:,:,k,:) = 0.
*
do j = 1, l_nj
do i = 1, l_niu
*
uv(i,j,k,1) = ((1.-intuv_c0xxu_8(i))*( Geomg_dpib(k)* expfm_8(i, j)*F_ss(i,j))
% + intuv_c0xxu_8(i) *( Geomg_dpib(k)* expfm_8(i+1,j)*F_ss(i+1,j)))*F_uum(i,j,k) +
% ((1.-intuv_c0xxu_8(i))*(1.+Geomg_dpib(k)* expfm1m_8(i,j))
% + intuv_c0xxu_8(i) *(1.+Geomg_dpib(k)* expfm1m_8(i+1,j)))*F_uu (i,j,k)
*
end do
end do
do j = 1, l_njv
do i = 1, l_ni
*
uv(i,j,k,2) = ((1.-intuv_c0yyv_8(j))*( Geomg_dpib(k)* expfm_8(i,j)*F_ss(i,j))
% + intuv_c0yyv_8(j) *( Geomg_dpib(k)* expfm_8(i,j+1)*F_ss(i,j+1)))*F_vvm(i,j,k) +
% ((1.-intuv_c0yyv_8(j))*(1.+Geomg_dpib(k)* expfm1m_8(i,j) )
% + intuv_c0yyv_8(j) *(1.+Geomg_dpib(k)* expfm1m_8(i,j+1)))*F_vv (i,j,k)
end do
end do
end do
!$omp end do
*
!$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 end do
* *
* pi
* / gnk
* | __ * *
* c) compute | \/ . ( V dpi/dpi ) dpi
* |
* / *
* pi
* k
*
!$omp end parallel
ng = (l_maxx-l_minx+1)*(l_maxy-l_miny+1)
call hatoprg (dvi,F_td,1.0,Geomg_hz_8,ng,G_nk)
*
* .*
* d) compute pi
* k
*
* .*
* dpi
* Compute D + ---- integrated vertically
* ------- *
* dpi
*
* compute V . \/ (dpi/dpi )
*
!$omp parallel private (pr1,pr1m,dpib1m_8,dpib2m_8,
!$omp$ inv1m_8,inv2m_8) shared (ng,l_nk,prsc)
!$omp do
do k=1,G_nk
do j=1,l_nj
do i=1,l_ni
*
pr1m = 1.0 + Geomg_dpib(k) * expfm1m_8(i,j)
pr1 = Geomg_dpib(k) *(expfm_8(i,j)*F_ss(i,j))
F_psd(i,j,k) =(dvi (i,j,k)+((Geomg_pib(k)/Geomg_pib(G_nk))-1)*dvi (i,j,1))/pr1m
$ - pr1*((dvim(i,j,k)+((Geomg_pib(k)/Geomg_pib(G_nk))-1)*dvim(i,j,1))/pr1m**2)
*
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_uum(i,j,k)
$ + ((F_ssm(i+1,j)-F_ssm(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_8(j))*F_vvm(i,j,k)
$ + ((F_ssm(i,j+1) - F_ssm(i,j))*gratio_8(j))*F_vv (i,j,k)
*
end do
end do
end do
!$omp end do
!$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,pr1m,dpib1m_8,dpib2m_8,
!$omp$ inv1m_8,inv2m_8) shared (ng,l_nk,prsc)
!$omp do
do k=1,G_nk
*
do j= 1, l_njv+1
do i= 1, l_niu+1
dpib1m_8(i,j) = ( 1.0d0 + Geomg_dpib(k)* expfm1m_8(i,j) )
dpib2m_8(i,j) = dpib1m_8(i,j) * dpib1m_8(i,j)
end do
end do
call vrec ( inv1m_8, dpib1m_8, (l_niu+1)*(l_njv+1) )
call vrec ( inv2m_8, dpib2m_8, (l_niu+1)*(l_njv+1) )
*
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)
pr1m = (uvm(i,j,k,1)+uvm(i,j,k,2))*inv_Geomg_cy2_8(j)
*
F_td(i,j,k) = Geomg_dpib(k)* (prsc*dvi(i,j,1)
$ - expfm_8(i,j)*F_ss(i,j)*pr1m
$ - expfm_8(i,j) *pr1)
$ -F_psd (i,j,k)*(expfm_8(i,j) -1.)*Geomg_dpia(k)
$ -F_psdm(i,j,k)*(expfm_8(i,j) *F_ss(i,j) )*Geomg_dpia(k)
*
F_td(i,j,k) = F_td (i,j,k) * inv1m_8(i,j)
$ - (Geomg_dpib(k)*(exp(F_ssm(i,j))*F_ss(i,j)))
$ *( F_tdm(i,j,k) * inv2m_8(i,j) )
*
F_tdm(i,j,k) = F_tdm(i,j,k) * inv1m_8(i,j)
*
enddo
enddo
*
* Boundary conditions for vertical velocity
*
if(k.eq.1) then
*
* TRAJECTORY
* ----------
F_psdm(:,:, 1) = 0.
F_psdm(:,:,G_nk) = 0.
*
* TLM
* ---
F_psd(:,:, 1) = 0.
F_psd(:,:,G_nk) = 0.
*
endif
*
enddo
!$omp enddo
*
!$omp end parallel
*
* ________________________________________________________________
*
return
end