!-------------------------------------- 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_ad -- ADJ of initw2_tl
*
#include "model_macros_f.h"
*
subroutine initw2_ad ( F_wt1, F_mul, F_mu,F_uu, F_vv, F_psd, F_fi, F_tt, F_ss, 1,10
$ F_uum,F_vvm,F_psdm,F_fim,F_ttm,F_ssm,
$ 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,*)
*
real F_ssm (DIST_SHAPE ),F_uum (DIST_SHAPE,*),
$ F_vvm (DIST_SHAPE,*),F_psdm(DIST_SHAPE,*),F_fim (DIST_SHAPE,*),
$ F_ttm (DIST_SHAPE,*)
*
*author
* M.Tanguay
*
*revision
* v3_03 - Tanguay M. - initial MPI version
* v3_30 - Tanguay M. - Change parameters of initw2
* - use of geomg_invhsy_8, moved j0,jn,ng before
* parallel region as in initw2
*
*object
* see id section
* -------------------------------------------------
* REMARK: INPUT TRAJ: ssm, uum, vvm, psdm, fim, ttm
* -------------------------------------------------
*
*ADJ of
*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)
real wk1m(DIST_SHAPE,G_nk), wk2m(DIST_SHAPE,G_nk),
$ wk3m(DIST_SHAPE,G_nk), wk4m(DIST_SHAPE,G_nk)
*
real*8, parameter :: ZERO_8 = 0.0
* __________________________________________________________________
*
* TRAJECTORY
* ----------
call rpn_comm_xch_halo ( F_fim, 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)
*
!$omp parallel shared( j0,jn,in1,in2,jn1,jn2,ng )
!$omp do
do k = 1,G_nk
*
* Zero adjoint variables
* ----------------------
wk1(:,:,k) = 0.
wk2(:,:,k) = 0.
wk3(:,:,k) = 0.
wk4(:,:,k) = 0.
*
* ----------------
* START TRAJECTORY
* ----------------
wk1m(:,:,k)= 0.
wk2m(:,:,k)= 0.
wk3m(:,:,k)= 0.
wk4m(:,:,k)= 0.
*
end do
!$omp enddo
*
****************************************************
* TERM1: HORIZONTAL ADVECTION OF GEOGRAPHIC HEIGHT *
****************************************************
*
* Gradient of geopotential
* ~~~~~~~~~~~~~~~~~~~~~~~~
*
!$omp do
do k = 1, G_nk
do j = 1, jn1
do i = 1, in2
*
wk1m(i,j,k) = ( F_fim(i+1,j,k) - F_fim(i,j,k) ) / Geomg_hx_8(i)
$ * F_uum(i,j,k) / Dcst_grav_8
*
end do
end do
do j = 1, jn2
do i = 1, in1
*
wk2m(i,j,k) = ( F_fim(i,j+1,k) - F_fim(i,j,k) ) *
$ Geomg_cyv2_8(j) * Geomg_invhsy_8(j)
$ * F_vvm(i,j,k) / Dcst_grav_8
*
end do
end do
end do
!$omp end do
*
* Interpolate from staggered grids to basic grid
*
!$omp single
call rpn_comm_xch_halo ( wk1m, LDIST_DIM, l_niu,l_nj,G_nk,
$ G_halox,G_haloy,G_periodx,G_periody,l_ni,0 )
call rpn_comm_xch_halo ( wk2m, 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
*
wk3m(i,j,k) = inuvl_wxux3_8(i,1) * wk1m(i-2,j,k)
$ + inuvl_wxux3_8(i,2) * wk1m(i-1,j,k)
$ + inuvl_wxux3_8(i,3) * wk1m(i ,j,k)
$ + inuvl_wxux3_8(i,4) * wk1m(i+1,j,k)
*
end do
end do
end do
!$omp end do
*
j0 = 1
jn = l_njv
if (l_south) j0 = 3
if (l_north) jn = l_njv - 1
!$omp do
do k=1,G_nk
do j = j0, jn
do i = 1, in1
*
wk1m(i,j,k) = inuvl_wyvy3_8(j,1) * wk2m(i,j-2,k)
% + inuvl_wyvy3_8(j,2) * wk2m(i,j-1,k)
% + inuvl_wyvy3_8(j,3) * wk2m(i,j ,k)
% + inuvl_wyvy3_8(j,4) * wk2m(i,j+1,k)
*
end do
end do
if (l_south) then
do i = 1, in1
*
wk1m(i,j0-2,k)= inuvl_wyvy3_8(j0-2,3) * wk2m(i,j0-2,k)
% + inuvl_wyvy3_8(j0-2,4) * wk2m(i,j0-1,k)
wk1m(i,j0-1,k)= inuvl_wyvy3_8(j0-1,2) * wk2m(i,j0-2,k)
% + inuvl_wyvy3_8(j0-1,3) * wk2m(i,j0-1,k)
% + inuvl_wyvy3_8(j0-1,4) * wk2m(i,j0 ,k)
*
end do
endif
if (l_north) then
do i = 1, in1
*
wk1m(i,jn+2,k)= inuvl_wyvy3_8(jn+2,1) * wk2m(i,jn ,k)
% + inuvl_wyvy3_8(jn+2,2) * wk2m(i,jn+1,k)
wk1m(i,jn+1,k)= inuvl_wyvy3_8(jn+1,1) * wk2m(i,jn-1,k)
% + inuvl_wyvy3_8(jn+1,2) * wk2m(i,jn ,k)
% + inuvl_wyvy3_8(jn+1,3) * wk2m(i,jn+1,k)
*
end do
endif
*
do j = 1, jn1
do i = 1, in1
*
C F_wt1m(i,j,k) = ( wk3m(i,j,k) + wk1m(i,j,k) ) / Geomg_cy2_8(j)
wk1m(i,j,k) = 1 + Geomg_dpib(k) * (exp(F_ssm(i,j)) - 1.0)
*
end do
end do
end do
!$omp end do
*
*********
* TERM2 *
*********
*
* Prepare key factors of TERM2
*
!$omp single
call rpn_comm_xch_halo ( wk1m,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
*
wk3m(i,j,k) = ((1.-intuv_c0xxu_8(i))*wk1m(i ,j,k)
% + intuv_c0xxu_8(i) *wk1m(i+1,j,k))*F_uum(i,j,k)
*
end do
end do
do j = 1, jn2
do i = 1, in1
*
wk4m(i,j,k) = ((1.-intuv_c0yyv_8(j))*wk1m(i,j ,k)
% + intuv_c0yyv_8(j) *wk1m(i,j+1,k))*F_vvm(i,j,k)
*
end do
end do
end do
!$omp end do
*
!$omp single
call rpn_comm_xch_halo ( wk3m, LDIST_DIM, l_niu,l_nj,G_nk,
$ G_halox,G_haloy,G_periodx,G_periody,l_ni,0 )
call rpn_comm_xch_halo ( wk4m, 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
*
* TRAJECTORY
* ----------
call caldiv_2 ( wk2m(minx,miny,k), wk3m(minx,miny,k),
% wk4m(minx,miny,k), LDIST_DIM, 1 )
*
enddo
!$omp enddo
*
!$omp end parallel
*
* Vertical integration over pi*
*
call hatoprg (wk4m,wk2m,1.0,Geomg_hz_8,ng,G_nk)
*
* --------------
* END TRAJECTORY
* --------------
*
* --------------------------
* START ADJOINT CALCULATIONS
* --------------------------
*
*ADJ of
*********
* TERM2 *
*********
*
!$omp parallel shared( j0,jn,in1,in2,jn1,jn2,ng )
!$omp do
do j = jn1, 1,-1
do k = G_nk,1,-1
do i = in1, 1,-1
*
F_ss(i,j) =
$ -( Dcst_rgasd_8 * F_ttm(i,j,k) / Dcst_grav_8 /
$ ( Geomg_pia(k) + Geomg_pib(k)*exp(F_ssm(i,j)) )**2 *
$ ( Geomg_pib(k)*exp(F_ssm(i,j))*F_wt1(i,j,k))
$ ) *
$ ( wk4m(i,j,1) * Geomg_pib(k) / Cstv_pisrf_8 -
$ F_psdm(i,j,k) * wk1m(i,j,k) ) + F_ss(i,j)
*
F_tt(i,j,k) =
$ Dcst_rgasd_8 * F_wt1(i,j,k) / Dcst_grav_8 /
$ ( Geomg_pia(k) + Geomg_pib(k)*exp(F_ssm(i,j)) ) *
$ ( wk4m(i,j,1) * Geomg_pib(k) / Cstv_pisrf_8 -
$ F_psdm(i,j,k) * wk1m(i,j,k) ) + F_tt (i,j,k)
*
wk4(i,j,1) =
$ Dcst_rgasd_8 * F_ttm(i,j,k) / Dcst_grav_8 /
$ ( Geomg_pia(k) + Geomg_pib(k)*exp(F_ssm(i,j)) ) *
$ ( F_wt1(i,j,k) * Geomg_pib(k) / Cstv_pisrf_8 ) + wk4 (i,j,1)
*
wk1(i,j,k) =
$ Dcst_rgasd_8 * F_ttm(i,j,k) / Dcst_grav_8 /
$ ( Geomg_pia(k) + Geomg_pib(k)*exp(F_ssm(i,j)) ) *
$ ( - F_psdm(i,j,k) * F_wt1(i,j,k) ) + wk1(i,j,k)
*
F_psd(i,j,k) =
$ Dcst_rgasd_8 * F_ttm(i,j,k) / Dcst_grav_8 /
$ ( Geomg_pia(k) + Geomg_pib(k)*exp(F_ssm(i,j)) ) *
$ ( F_wt1(i,j,k) * wk1m (i,j,k) ) + F_psd(i,j,k)
*
end do
end do
end do
!$omp end do
!$omp end parallel
*
* ADJ of
* Vertical integration over pi*
*
call hatoprg0_ad (wk4,wk2,1.0,Geomg_hz_8,ng,G_nk)
*
!$omp parallel shared( j0,jn,in1,in2,jn1,jn2,ng )
*
!$omp do
do k=G_nk,1,-1
*
call caldiv_2_ad ( wk2(minx,miny,k), wk3(minx,miny,k),
% wk4(minx,miny,k), LDIST_DIM, 1 )
*
enddo
!$omp enddo
*
!$omp single
call rpn_comm_adj_halo ( wk4, LDIST_DIM, l_ni,l_njv,G_nk,
$ G_halox,G_haloy,G_periodx,G_periody,l_ni,0 )
call rpn_comm_adj_halo ( wk3, LDIST_DIM, l_niu,l_nj,G_nk,
$ G_halox,G_haloy,G_periodx,G_periody,l_ni,0 )
*
call v4d_zerohalo ( wk4,l_ni,l_njv,LDIST_DIM, l_nk)
call v4d_zerohalo ( wk3,l_niu,l_nj,LDIST_DIM, l_nk)
!$omp end single
*
!$omp do
do k=G_nk,1,-1
do j = jn2,1,-1
do i = in1,1,-1
*
wk1 (i,j+1,k) = ( intuv_c0yyv_8(j) *wk4 (i,j, k))*F_vvm(i,j,k) + wk1 (i,j+1,k)
wk1 (i,j ,k) = ((1.-intuv_c0yyv_8(j))*wk4 (i,j, k))*F_vvm(i,j,k) + wk1 (i,j ,k)
F_vv(i,j, k) = ((1.-intuv_c0yyv_8(j))*wk1m(i,j, k)
% + intuv_c0yyv_8(j) *wk1m(i,j+1,k))*wk4 (i,j,k) + F_vv(i,j, k)
wk4 (i,j, k) = ZERO_8
*
end do
end do
*
do j = jn1,1,-1
do i = in1,1,-1
*
wk1 (i+1,j,k) = ( intuv_c0xxu_8(i) *wk3 (i, j,k))*F_uum(i,j,k) + wk1 (i+1,j,k)
wk1 (i ,j,k) = ((1.-intuv_c0xxu_8(i))*wk3 (i, j,k))*F_uum(i,j,k) + wk1 (i ,j,k)
F_uu(i, j,k) = ((1.-intuv_c0xxu_8(i))*wk1m(i ,j,k)
% + intuv_c0xxu_8(i) *wk1m(i+1,j,k))*wk3 (i,j,k) + F_uu(i, j,k)
wk3 (i, j,k) = ZERO_8
*
end do
end do
end do
!$omp end do
*
!$omp end parallel
*
* Prepare key factors of TERM2
*
call rpn_comm_adj_halo ( wk1, LDIST_DIM,l_ni,l_nj,G_nk,
$ G_halox,G_haloy,G_periodx,G_periody,l_ni,0 )
*
call v4d_zerohalo ( wk1,l_ni,l_nj,LDIST_DIM, l_nk)
*
****************************************************
* TERM1: HORIZONTAL ADVECTION OF GEOGRAPHIC HEIGHT *
****************************************************
*
!$omp parallel shared( j0,jn,in1,in2,jn1,jn2,ng )
!$omp do
do j = jn1, 1,-1
do k = G_nk,1,-1
do i = in1, 1,-1
*
F_ss (i,j) = Geomg_dpib(k) * (exp(F_ssm(i,j))*wk1(i,j,k)) + F_ss(i,j)
wk1 (i,j,k) = ZERO_8
*
wk3 (i,j,k) = ( F_wt1(i,j,k) ) / Geomg_cy2_8(j) + wk3(i,j,k)
wk1 (i,j,k) = ( F_wt1(i,j,k) ) / Geomg_cy2_8(j) + wk1(i,j,k)
F_wt1(i,j,k) = ZERO_8
*
end do
end do
end do
!$omp end do
!$omp end parallel
*
!$omp parallel shared( j0,jn,in1,in2,jn1,jn2,ng )
*
!$omp do
do k = G_nk,1,-1
if (l_north) then
do i = 1, in1
*
wk2(i,jn-1,k) = inuvl_wyvy3_8(jn+1,1) * wk1(i,jn+1,k) + wk2(i,jn-1,k)
wk2(i,jn ,k) = inuvl_wyvy3_8(jn+1,2) * wk1(i,jn+1,k) + wk2(i,jn ,k)
wk2(i,jn+1,k) = inuvl_wyvy3_8(jn+1,3) * wk1(i,jn+1,k) + wk2(i,jn+1,k)
wk1(i,jn+1,k) = ZERO_8
*
wk2(i,jn ,k) = inuvl_wyvy3_8(jn+2,1) * wk1(i,jn+2,k) + wk2(i,jn ,k)
wk2(i,jn+1,k) = inuvl_wyvy3_8(jn+2,2) * wk1(i,jn+2,k) + wk2(i,jn+1,k)
wk1(i,jn+2,k) = ZERO_8
*
end do
endif
if (l_south) then
do i = 1, in1
*
wk2(i,j0-2,k) = inuvl_wyvy3_8(j0-1,2) * wk1(i,j0-1,k) + wk2(i,j0-2,k)
wk2(i,j0-1,k) = inuvl_wyvy3_8(j0-1,3) * wk1(i,j0-1,k) + wk2(i,j0-1,k)
wk2(i,j0 ,k) = inuvl_wyvy3_8(j0-1,4) * wk1(i,j0-1,k) + wk2(i,j0 ,k)
wk1(i,j0-1,k) = ZERO_8
*
wk2(i,j0-2,k) = inuvl_wyvy3_8(j0-2,3) * wk1(i,j0-2,k) + wk2(i,j0-2,k)
wk2(i,j0-1,k) = inuvl_wyvy3_8(j0-2,4) * wk1(i,j0-2,k) + wk2(i,j0-1,k)
wk1(i,j0-2,k) = ZERO_8
*
end do
endif
do j = jn,j0,-1
do i = in1,1,-1
*
wk2(i,j-2,k) = inuvl_wyvy3_8(j,1) * wk1(i,j,k) + wk2(i,j-2,k)
wk2(i,j-1,k) = inuvl_wyvy3_8(j,2) * wk1(i,j,k) + wk2(i,j-1,k)
wk2(i,j ,k) = inuvl_wyvy3_8(j,3) * wk1(i,j,k) + wk2(i,j ,k)
wk2(i,j+1,k) = inuvl_wyvy3_8(j,4) * wk1(i,j,k) + wk2(i,j+1,k)
wk1(i,j, k) = ZERO_8
*
end do
end do
end do
!$omp end do
*
!$omp do
do k = G_nk,1,-1
do j = jn1,1,-1
do i = in2,1,-1
*
wk1(i-2,j,k) = inuvl_wxux3_8(i,1) * wk3(i,j,k) + wk1(i-2,j,k)
wk1(i-1,j,k) = inuvl_wxux3_8(i,2) * wk3(i,j,k) + wk1(i-1,j,k)
wk1(i ,j,k) = inuvl_wxux3_8(i,3) * wk3(i,j,k) + wk1(i ,j,k)
wk1(i+1,j,k) = inuvl_wxux3_8(i,4) * wk3(i,j,k) + wk1(i+1,j,k)
wk3(i, j,k) = ZERO_8
end do
end do
end do
!$omp end do
*
* ADJ of
* Interpolate from staggered grids to basic grid
*
!$omp single
*
* ADJ
* ---
call rpn_comm_adj_halo ( wk2, LDIST_DIM, l_ni,l_njv,G_nk,
$ G_halox,G_haloy,G_periodx,G_periody,l_ni,0 )
call rpn_comm_adj_halo ( wk1, LDIST_DIM, l_niu,l_nj,G_nk,
$ G_halox,G_haloy,G_periodx,G_periody,l_ni,0 )
*
call v4d_zerohalo ( wk2,l_ni,l_njv,LDIST_DIM, l_nk)
call v4d_zerohalo ( wk1,l_niu,l_nj,LDIST_DIM, l_nk)
*
!$omp end single
*
!$omp do
do k = G_nk,1,-1
do j = jn2,1,-1
do i = in1,1,-1
*
F_fi (i,j+1,k) = ( wk2 (i,j,k)) *
$ Geomg_cyv2_8(j) * Geomg_invhsy_8(j)
$ * F_vvm(i,j,k) / Dcst_grav_8 + F_fi (i,j+1,k)
F_fi (i,j, k) = ( - wk2 (i,j,k)) *
$ Geomg_cyv2_8(j) * Geomg_invhsy_8(j)
$ * F_vvm(i,j,k) / Dcst_grav_8 + F_fi (i,j, k)
F_vv (i,j, k) = ( F_fim(i,j+1,k) - F_fim(i,j,k) ) *
$ Geomg_cyv2_8(j) * Geomg_invhsy_8(j)
$ * wk2 (i,j,k) / Dcst_grav_8 + F_vv(i,j, k)
wk2 (i,j, k) = ZERO_8
*
end do
end do
do j = jn1,1,-1
do i = in2,1,-1
*
F_fi (i+1,j,k) = ( wk1(i,j,k) ) / Geomg_hx_8(i)
$ * F_uum(i,j,k) / Dcst_grav_8 + F_fi (i+1,j,k)
F_fi (i, j,k) = (-wk1(i,j,k) ) / Geomg_hx_8(i)
$ * F_uum(i,j,k) / Dcst_grav_8 + F_fi (i, j,k)
F_uu (i, j,k) = ( F_fim(i+1,j,k) - F_fim(i,j,k) ) / Geomg_hx_8(i)
$ * wk1(i,j,k) / Dcst_grav_8 + F_uu (i, j,k)
wk1 (i, j,k) = ZERO_8
*
end do
end do
end do
!$omp end do
*
* Gradient of geopotential
* ~~~~~~~~~~~~~~~~~~~~~~~~
*
!$omp single
*
call rpn_comm_adj_halo ( F_fi, LDIST_DIM, l_ni, l_nj, G_nk,
$ G_halox,G_haloy,G_periodx,G_periody,l_ni,0 )
*
call v4d_zerohalo ( F_fi,l_ni,l_nj,LDIST_DIM, l_nk)
*
!$omp end single
*
!$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.
end do
!$omp end do
*
!$omp end parallel
*
* ------------------------
* END ADJOINT CALCULATIONS
* ------------------------
* __________________________________________________________________
*
return
end