!-------------------------------------- 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 - calddqr - horizontal divergence and horizontal relative
* vorticity from pi* vertical coordinates to pressure
*
#include "model_macros_f.h"
*
subroutine calddqr( F_diver, F_relv, F_wlnph, F_ui , F_vi, F_dpdx, 1,2
$ F_dpdy , F_dudp, F_dvdp, F_wrk, DIST_DIM, Nk)
implicit none
*
integer DIST_DIM, Nk
real F_diver(DIST_SHAPE, Nk), F_relv(DIST_SHAPE, Nk)
real F_wlnph (DIST_SHAPE, Nk), F_wrk (DIST_SHAPE, Nk)
real F_ui (DIST_SHAPE, Nk), F_vi (DIST_SHAPE, Nk)
real F_dpdx (DIST_SHAPE, Nk), F_dpdy(DIST_SHAPE, Nk)
real F_dudp (DIST_SHAPE, Nk), F_dvdp(DIST_SHAPE, Nk)
*
*author
* Andre Methot - cmc - nov 95 - v0_16
*
*revision
* v2_00 - Lee/Desgagne - initial MPI version (from calddqr v1_03)
* v3_00 - Desgagne & Lee - Lam configuration
* v3_21 - Lee V. - Output Optimization
* v3_30 - Lee V. - LAM output correction
*
*object
* calculate DD and QQ from DS and QS
***********************************************************************
*
* Given pi* coordinate horizontal divergence
* and pi* coordinate horizontal vorticity
*
* the pressure coordinate horizontal divergence and
* pressure coordinate horizontal vorticity are obtained
* with the following:
*
* dU dP dV dP
* DIV | = DIV | + __ . __ + __ . __
* | | dP dX dP dY
* P pi*
*
* dV dP dU dP
* VOR | = VOR | + __ . __ - __ . __
* | | dP dX dP dY
* P pi*
* where P is pressure or log of pressure.
*
**********************************************************************
*
*
*arguments
* Name I/O Description
*----------------------------------------------------------------
* F_diver I/O - divergence
* F_relv I/O - relative vorticity
* F_wlnph I - log of hydrostatique pressure
* F_ui I - image wind u-component
* F_vi I - image wind v-component
* F_dpdx - work field
* F_dpdy - work field
* F_dudp - work field
* F_dvdp - work field
* F_wrk - work field
*
*implicits
#include "glb_ld.cdk"
#include "geomg.cdk"
#include "intuv.cdk"
#include "inuvl.cdk"
*
**
integer i, j, k, i0, in, j0, jn,i00
real*8 fact1
real*8 inv_geomg_cyv_8(l_miny:l_maxy)
*
* ---------------------------------------------------------------
*
* Compute dP/dX and dU/dP and put on phi grid
* -------------------------------------------
call rpn_comm_xch_halo (F_wlnph,LDIST_DIM,l_ni,l_nj,G_nk,
$ G_halox,G_haloy,G_periodx,G_periody,l_ni,0)
* F_dpdx and F_dudp are on U grid
i0 = 1
in = l_niu
j0 = 1
jn = l_nj
call verder(F_dvdp , F_ui, F_wlnph, 2.0, 2.0, LDIST_DIM,
$ G_nk,i0,in,j0,jn)
do j=1-G_haloy,l_nj+G_haloy
inv_geomg_cyv_8(j) = 1.0/geomg_cyv_8(j)
enddo
*
!$omp parallel private (fact1,i00)
!$omp& shared (inv_geomg_cyv_8)
!$omp do
do k=1,l_nk
do j=j0,jn
fact1 = 1. / geomg_cy_8(j)
do i=i0,in
F_dpdy(i,j,k)= ( F_wlnph(i+1,j,k) - F_wlnph(i,j,k) )
% / geomg_hx_8(i)*fact1
F_dvdp(i,j,k)= F_dvdp(i,j,k)*fact1
end do
end do
end do
!$omp enddo
*
* interpolate results to phi grid
*
!$omp single
call rpn_comm_xch_halo (F_dpdy,LDIST_DIM,l_ni,l_nj,G_nk,
$ G_halox,G_haloy,G_periodx,G_periody,l_ni,0)
call rpn_comm_xch_halo (F_dvdp,LDIST_DIM,l_ni,l_nj,G_nk,
$ G_halox,G_haloy,G_periodx,G_periody,l_ni,0)
!$omp end single
i00=i0
if ((G_lam).and.(l_west)) i00 = 2
*
!$omp do
do k=1,l_nk
do j = j0, jn
do i = i00, in
F_dpdx(i,j,k)= (1.0-intuv_c0xux_8(i-1)) * F_dpdy(i-1,j,k) +
$ intuv_c0xux_8(i-1) * F_dpdy(i ,j,k)
F_dudp(i,j,k)= (1.0-intuv_c0xux_8(i-1)) * F_dvdp(i-1,j,k) +
$ intuv_c0xux_8(i-1) * F_dvdp(i ,j,k)
end do
end do
end do
!$omp enddo
!$omp end parallel
*
* Compute dP/dY and dV/dP and put on phi grid
* -------------------------------------------
*
i0 = 1
in = l_ni
j0 = 1
jn = l_njv
if (l_south) j0 = 2
*
!$omp parallel shared (inv_geomg_cyv_8)
!$omp do
do k=1,l_nk
do j = j0, jn
do i = i0, in
F_dpdy(i,j,k)= (1.0 - intuv_c0yvy_8(j-1)) *
$ (F_wlnph(i,j,k)-F_wlnph(i,j-1,k))*
$ geomg_cyv2_8(j-1)*geomg_invhsy_8(j-1) * inv_geomg_cyv_8(j-1) +
$ intuv_c0yvy_8(j-1) *
$ (F_wlnph(i,j+1,k)-F_wlnph(i,j,k))*
$ geomg_cyv2_8(j)*geomg_invhsy_8(j) * inv_geomg_cyv_8(j)
end do
end do
if (.not.G_lam) then
if (l_south) then
do i = i0, in
F_dpdy(i,1,k) = intuv_c0yvy_8(0)
$ *(F_wlnph(i,2,k)-F_wlnph(i,1,k))*
$ geomg_cyv2_8(1)*geomg_invhsy_8(1)* inv_geomg_cyv_8(1)
end do
endif
if (l_north) then
do i = i0, in
F_dpdy(i,l_nj,k)=(1.-intuv_c0yvy_8(l_nj-1))*
$ (F_wlnph(i,l_nj,k)-F_wlnph(i,l_nj-1,k))*
$ geomg_cyv2_8(l_nj-1)*geomg_invhsy_8(l_nj-1)*inv_geomg_cyv_8(l_nj-1)
end do
endif
endif
end do
!$omp enddo
*
!$omp single
call verder(F_wrk ,F_vi, F_wlnph, 2.0, 2.0, LDIST_DIM,G_nk,
$ i0,in,1,jn)
*
call rpn_comm_xch_halo (F_wrk,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,l_nk
do j = j0, jn
do i = i0, in
F_dvdp(i,j,k)=
$ (1.0-intuv_c0yvy_8(j-1)) * F_wrk(i,j-1,k)*inv_geomg_cyv_8(j-1)+
$ intuv_c0yvy_8(j-1) * F_wrk(i,j ,k)*inv_geomg_cyv_8(j)
end do
end do
if (.not.G_lam) then
if (l_south) then
do i = i0, in
F_dvdp(i,1,k) = intuv_c0yvy_8(0) *
$ F_wrk(i,1,k)* inv_geomg_cyv_8(1)
end do
endif
if (l_north) then
do i = i0, in
F_dvdp(i,l_nj,k)=(1.-intuv_c0yvy_8(l_nj-1)) *
$ F_wrk(i,l_nj-1,k) * inv_geomg_cyv_8(l_nj-1)
end do
endif
endif
end do
!$omp enddo
!$omp end parallel
*
* Combine terms
* ----------------------------------------------
*
i0 = 1
in = l_ni
j0 = 1
jn = l_nj
if (G_lam) then
if (l_west) i0 = 2
if (l_south)j0 = 2
jn = l_njv
in = l_niu
endif
*
!$omp parallel shared (inv_geomg_cyv_8)
!$omp do
do k=1,l_nk
do j= j0, jn
do i= i0, in
F_diver(i,j,k)= F_diver(i,j,k)+(F_dudp (i,j,k)*F_dpdx(i,j,k) +
% F_dvdp (i,j,k)*F_dpdy(i,j,k) )
F_relv (i,j,k)= F_relv (i,j,k)+(F_dvdp (i,j,k)*F_dpdx(i,j,k) -
% F_dudp (i,j,k)*F_dpdy(i,j,k) )
end do
end do
end do
!$omp enddo
if (G_lam) then
if (l_west) then
!$omp do
do k=1,G_nk
do j=j0,l_njv
F_diver(1,j,k)=F_diver(2,j,k)
F_relv(1,j,k)=F_relv(2,j,k)
enddo
enddo
!$omp enddo
endif
if (l_east) then
!$omp do
do k=1,G_nk
do j=j0,l_njv
F_diver(l_ni,j,k)=F_diver(l_niu,j,k)
F_relv(l_ni,j,k)=F_relv(l_niu,j,k)
enddo
enddo
!$omp enddo
endif
if (l_south) then
!$omp do
do k=1,G_nk
do i=1,l_ni
F_diver(i,1,k)=F_diver(i,2,k)
F_relv(i,1,k)=F_relv(i,2,k)
enddo
enddo
!$omp enddo
endif
if (l_north) then
!$omp do
do k=1,G_nk
do i=1,l_ni
F_diver(i,l_nj,k)=F_diver(i,l_njv,k)
F_relv(i,l_nj,k)=F_relv(i,l_njv,k)
enddo
enddo
!$omp enddo
endif
endif
!$omp end parallel
*
* ---------------------------------------------------------------
*
return
end