!-------------------------------------- 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 adw_main_1_wnd_settls_ad - ADJ of adw_main_1_wnd_settls
*
#include "model_macros_f.h"
*
subroutine adw_main_1_wnd_settls_ad ( F_u, F_v, F_w, F_nit, F_njt, F_nk ) 1,4
*
implicit none
*
integer F_nit, F_njt, F_nk
*
real F_u(F_nit,F_njt,F_nk),
% F_v(F_nit,F_njt,F_nk),
% F_w(F_nit,F_njt,F_nk)
*
*author
* monique tanguay
*
*revision
* v2_31 - Tanguay M. - initial MPI version
* v3_00 - Tanguay M. - adapt to restructured adw_main
* v3_11 - Tanguay M. - AIXport+Opti+OpenMP for TLM-ADJ
* v3_21 - Tanguay M. - Revision Openmp
* v3_30 - Tanguay M. - Validation for LAM version
* v3_31 - Tanguay M. - SETTLS option
*
*language
* fortran 77
*
*object
* see id section
*
*ADJ of
*arguments
*______________________________________________________________________
* | | |
* NAME | DESCRIPTION | I/O |
*--------------|-------------------------------------------------|-----|
* F_u | u components of winds on advection grid | o |
* F_v | v components of winds on advection grid | o |
* F_w | w components of winds on advection grid | o |
* | | |
* F_nit | \ total number of points in x,y direction in | i |
* F_njt | / advection grid (including halos) | i |
* | | |
* F_nk | number of levels | i |
*______________|_________________________________________________|_____|
*
*implicits
#include "glb_ld.cdk"
#include "glb_pil.cdk"
#include "adw.cdk"
#include "lun.cdk"
#include "inuvl.cdk"
#include "vth.cdk"
#include "vt1.cdk"
#include "vtw.cdk"
*
*modules
integer vmmlod, vmmget, vmmuld
external vmmlod, vmmget, vmmuld
************************************************************************
integer pnerr, pnlkey1(30), pnlod
*
integer i, j, k, i0, in, j0, jn, n, dest_ni
real*8 ONE_8,sc_8,ZERO_8
parameter( ONE_8 = 1.0 )
parameter( ZERO_8 = 0.0 )
*
real, dimension(:,:,:,:) ,allocatable :: in0
*
real u_wrk(LDIST_SHAPE,l_nk),v_wrk(LDIST_SHAPE,l_nk),w_wrk(LDIST_SHAPE,l_nk)
real uth_w(LDIST_SHAPE,l_nk),vth_w(LDIST_SHAPE,l_nk),wth_w(LDIST_SHAPE,l_nk)
*
************************************************************************
if (Lun_debug_L) write (Lun_out,1000)
*
* Zero adjoint variables
* ----------------------
u_wrk = 0.
v_wrk = 0.
w_wrk = 0.
uth_w = 0.
vth_w = 0.
wth_w = 0.
*
if (G_lam) allocate ( in0(LDIST_SHAPE,l_nk,3) )
*
pnlkey1(1) = VMM_KEY(uth)
pnlkey1(2) = VMM_KEY(vth)
pnlkey1(3) = VMM_KEY(psdth)
pnlkey1(4) = VMM_KEY(ut1)
pnlkey1(5) = VMM_KEY(vt1)
pnlkey1(6) = VMM_KEY(psdt1)
pnlkey1(7) = VMM_KEY(utw)
pnlkey1(8) = VMM_KEY(vtw)
pnlkey1(9) = VMM_KEY(psdtw)
*
pnerr = vmmlod(pnlkey1,9)
*
pnerr = VMM_GET_VAR(uth)
pnerr = VMM_GET_VAR(vth)
pnerr = VMM_GET_VAR(psdth)
pnerr = VMM_GET_VAR(ut1)
pnerr = VMM_GET_VAR(vt1)
pnerr = VMM_GET_VAR(psdt1)
pnerr = VMM_GET_VAR(utw)
pnerr = VMM_GET_VAR(vtw)
pnerr = VMM_GET_VAR(psdtw)
*
!$omp parallel private(i0,in,j0,jn,sc_8)
*
***********************************************************************
* ADJ of
* Adjust wind fields to advection grid
***********************************************************************
if (.not.G_lam) then
*
if ( l_north ) then
*
call adw_pols_ad (F_w,Adw_wx_8,Adw_njc+1,Adw_nic,Adw_halox,
% Adw_njc,Adw_haloy,l_nk)
*
call adw_polw_ad (F_u,F_v,Adw_cx_8,Adw_sx_8,Adw_wx_8,
% Adw_sy_8,Adw_njc+1,Adw_nic,Adw_halox,Adw_njc,Adw_haloy,l_nk)
*
endif
*
if ( l_south ) then
*
call adw_pols_ad (F_w,Adw_wx_8,0,Adw_nic,Adw_halox,Adw_njc,
% Adw_haloy,l_nk)
*
call adw_polw_ad (F_u,F_v,Adw_cx_8,Adw_sx_8,Adw_wx_8,
% Adw_sy_8,0,Adw_nic,Adw_halox,Adw_njc,Adw_haloy,l_nk)
*
endif
*
endif
*
if (G_lam) then
n=0
dest_ni=l_ni
else
n=999
dest_ni=G_ni
endif
*
if (G_lam) then
!$omp do
do k=1,l_nk
do j=l_miny,l_maxy
do i=l_minx,l_maxx
in0(i,j,k,1) = w_wrk(i,j,k)
in0(i,j,k,2) = v_wrk(i,j,k)
in0(i,j,k,3) = u_wrk(i,j,k)
end do
end do
end do
!$omp end do
endif
*
!$omp single
call rpn_comm_adj_halox ( w_wrk, LDIST_DIM, l_ni, l_nj, l_nk,
% Adw_halox, Adw_haloy, G_periodx, G_periody, F_w, 1-Adw_halox,
% Adw_nic+Adw_halox, 1-Adw_haloy, Adw_njc+Adw_haloy, dest_ni, n)
*
call rpn_comm_adj_halox ( v_wrk, LDIST_DIM, l_ni, l_nj, l_nk,
% Adw_halox, Adw_haloy, G_periodx, G_periody, F_v, 1-Adw_halox,
% Adw_nic+Adw_halox, 1-Adw_haloy, Adw_njc+Adw_haloy, dest_ni, n)
*
call rpn_comm_adj_halox ( u_wrk, LDIST_DIM, l_ni, l_nj, l_nk,
% Adw_halox, Adw_haloy, G_periodx, G_periody, F_u, 1-Adw_halox,
% Adw_nic+Adw_halox, 1-Adw_haloy, Adw_njc+Adw_haloy, dest_ni, n)
!$omp end single
*
if (G_lam) then
!$omp do
do k=1,l_nk
do j=l_miny,l_maxy
do i=l_minx,l_maxx
w_wrk(i,j,k) = in0(i,j,k,1) + w_wrk(i,j,k)
v_wrk(i,j,k) = in0(i,j,k,2) + v_wrk(i,j,k)
u_wrk(i,j,k) = in0(i,j,k,3) + u_wrk(i,j,k)
C in0(i,j,k,1) = ZERO_8
C in0(i,j,k,2) = ZERO_8
C in0(i,j,k,3) = ZERO_8
end do
end do
end do
!$omp end do
endif
*
* Zero adjoint variables
* ----------------------
!$omp do
do k = 1, F_nk
do j = 1, F_njt
do i = 1, F_nit
F_w(i,j,k) = ZERO_8
F_v(i,j,k) = ZERO_8
F_u(i,j,k) = ZERO_8
enddo
enddo
enddo
!$omp enddo
*
***********************************************************************
* ADJ of
* Image to component
***********************************************************************
i0=1
in=l_ni
j0=1
jn=l_nj
if (G_lam) then
if (l_west) i0 = 3
if (l_east) in = l_niu - 1
endif
*
!$omp do
do k = 1,l_nk
do j = j0,jn
*
sc_8 = ONE_8/Adw_cy_8(j)
*
do i = i0,in
*
uth (i,j,k) = sc_8 * uth(i,j,k)
*
F_u (i,j,k) = sc_8 * u_wrk(i,j,k) + F_u(i,j,k)
u_wrk(i,j,k) = ZERO_8
*
enddo
enddo
enddo
!$omp enddo
*
i0=1
in=l_ni
j0=1
jn=l_nj
if (G_lam) then
if (l_south) j0 = 3
if (l_north) jn = l_njv - 1
endif
*
!$omp do
do k = 1,l_nk
do j = j0,jn
*
sc_8 = ONE_8/Adw_cy_8(j)
*
do i = i0,in
*
vth (i,j,k) = sc_8 * vth(i,j,k)
*
F_v (i,j,k) = sc_8 * v_wrk(i,j,k) + F_v(i,j,k)
v_wrk(i,j,k) = ZERO_8
*
enddo
enddo
enddo
!$omp enddo
*
!$omp do
do k=1,l_nk
do j=l_miny,l_maxy
do i=l_minx,l_maxx
wth_w(i,j,k) = psdth(i,j,k) + wth_w(i,j,k)
psdth(i,j,k) = ZERO_8
enddo
enddo
enddo
!$omp enddo
*
***********************************************************************
* ADJ of
* Interpolate advection winds to geopotential grid
* F_u and F_v are used as work space
***********************************************************************
!$omp do
do k=1,l_nk
*
i0 = 1
in = l_ni
j0 = 1
jn = l_njv
if (l_south) j0 = 3
if (l_north) jn = l_njv - 1
*
if (.not.G_lam) then
*
if (l_north) then
do i = i0, in
*
vth_w(i,jn+1,k) = inuvl_wyvy3_8(jn+1,3) * vth(i,jn+1,k) + vth_w(i,jn+1,k)
vth_w(i,jn ,k) = inuvl_wyvy3_8(jn+1,2) * vth(i,jn+1,k) + vth_w(i,jn ,k)
vth_w(i,jn-1,k) = inuvl_wyvy3_8(jn+1,1) * vth(i,jn+1,k) + vth_w(i,jn-1,k)
vth (i,jn+1,k) = ZERO_8
*
vth_w(i,jn+1,k) = inuvl_wyvy3_8(jn+2,2) * vth(i,jn+2,k) + vth_w(i,jn+1,k)
vth_w(i,jn ,k) = inuvl_wyvy3_8(jn+2,1) * vth(i,jn+2,k) + vth_w(i,jn ,k)
vth (i,jn+2,k) = ZERO_8
*
v_wrk(i,jn+1,k) = inuvl_wyvy3_8(jn+1,3) * F_v(i,jn+1,k) + v_wrk(i,jn+1,k)
v_wrk(i,jn ,k) = inuvl_wyvy3_8(jn+1,2) * F_v(i,jn+1,k) + v_wrk(i,jn ,k)
v_wrk(i,jn-1,k) = inuvl_wyvy3_8(jn+1,1) * F_v(i,jn+1,k) + v_wrk(i,jn-1,k)
F_v (i,jn+1,k) = ZERO_8
*
v_wrk(i,jn+1,k) = inuvl_wyvy3_8(jn+2,2) * F_v(i,jn+2,k) + v_wrk(i,jn+1,k)
v_wrk(i,jn ,k) = inuvl_wyvy3_8(jn+2,1) * F_v(i,jn+2,k) + v_wrk(i,jn ,k)
F_v (i,jn+2,k) = ZERO_8
*
end do
endif
if (l_south) then
do i = i0, in
*
vth_w(i,j0, k) = inuvl_wyvy3_8(j0-1,4) * vth(i,j0-1,k) + vth_w(i,j0, k)
vth_w(i,j0-1,k) = inuvl_wyvy3_8(j0-1,3) * vth(i,j0-1,k) + vth_w(i,j0-1,k)
vth_w(i,j0-2,k) = inuvl_wyvy3_8(j0-1,2) * vth(i,j0-1,k) + vth_w(i,j0-2,k)
vth (i,j0-1,k) = ZERO_8
*
vth_w(i,j0-1,k) = inuvl_wyvy3_8(j0-2,4) * vth(i,j0-2,k) + vth_w(i,j0-1,k)
vth_w(i,j0-2,k) = inuvl_wyvy3_8(j0-2,3) * vth(i,j0-2,k) + vth_w(i,j0-2,k)
vth (i,j0-2,k) = ZERO_8
*
v_wrk(i,j0, k) = inuvl_wyvy3_8(j0-1,4) * F_v(i,j0-1,k) + v_wrk(i,j0, k)
v_wrk(i,j0-1,k) = inuvl_wyvy3_8(j0-1,3) * F_v(i,j0-1,k) + v_wrk(i,j0-1,k)
v_wrk(i,j0-2,k) = inuvl_wyvy3_8(j0-1,2) * F_v(i,j0-1,k) + v_wrk(i,j0-2,k)
F_v (i,j0-1,k) = ZERO_8
*
v_wrk(i,j0-1,k) = inuvl_wyvy3_8(j0-2,4) * F_v(i,j0-2,k) + v_wrk(i,j0-1,k)
v_wrk(i,j0-2,k) = inuvl_wyvy3_8(j0-2,3) * F_v(i,j0-2,k) + v_wrk(i,j0-2,k)
F_v (i,j0-2,k) = ZERO_8
*
end do
endif
*
endif
*
do j = jn, j0, -1
do i = in, i0, -1
*
vth_w(i,j+1,k) = inuvl_wyvy3_8(j,4) * vth(i,j,k) + vth_w(i,j+1,k)
vth_w(i,j ,k) = inuvl_wyvy3_8(j,3) * vth(i,j,k) + vth_w(i,j ,k)
vth_w(i,j-1,k) = inuvl_wyvy3_8(j,2) * vth(i,j,k) + vth_w(i,j-1,k)
vth_w(i,j-2,k) = inuvl_wyvy3_8(j,1) * vth(i,j,k) + vth_w(i,j-2,k)
vth (i,j, k) = ZERO_8
*
v_wrk(i,j+1,k) = inuvl_wyvy3_8(j,4) * F_v(i,j,k) + v_wrk(i,j+1,k)
v_wrk(i,j ,k) = inuvl_wyvy3_8(j,3) * F_v(i,j,k) + v_wrk(i,j ,k)
v_wrk(i,j-1,k) = inuvl_wyvy3_8(j,2) * F_v(i,j,k) + v_wrk(i,j-1,k)
v_wrk(i,j-2,k) = inuvl_wyvy3_8(j,1) * F_v(i,j,k) + v_wrk(i,j-2,k)
F_v (i,j, k) = ZERO_8
*
end do
end do
*
i0 = 1
in = l_niu
j0 = 1
jn = l_nj
if (G_lam) then
if (l_west) i0 = 3
if (l_east) in = l_niu - 1
endif
*
do j = jn,j0,-1
do i = in,i0,-1
*
uth_w(i+1,j,k) = inuvl_wxux3_8(i,4) * uth(i,j,k) + uth_w(i+1,j,k)
uth_w(i ,j,k) = inuvl_wxux3_8(i,3) * uth(i,j,k) + uth_w(i ,j,k)
uth_w(i-1,j,k) = inuvl_wxux3_8(i,2) * uth(i,j,k) + uth_w(i-1,j,k)
uth_w(i-2,j,k) = inuvl_wxux3_8(i,1) * uth(i,j,k) + uth_w(i-2,j,k)
uth (i, j,k) = ZERO_8
*
u_wrk(i+1,j,k) = inuvl_wxux3_8(i,4) * F_u(i,j,k) + u_wrk(i+1,j,k)
u_wrk(i ,j,k) = inuvl_wxux3_8(i,3) * F_u(i,j,k) + u_wrk(i ,j,k)
u_wrk(i-1,j,k) = inuvl_wxux3_8(i,2) * F_u(i,j,k) + u_wrk(i-1,j,k)
u_wrk(i-2,j,k) = inuvl_wxux3_8(i,1) * F_u(i,j,k) + u_wrk(i-2,j,k)
F_u (i, j,k) = ZERO_8
*
end do
end do
*
end do
!$omp enddo
*
!$omp single
call rpn_comm_adj_halo (vth_w,LDIST_DIM,l_ni,l_njv,G_nk,
% G_halox,G_haloy,G_periodx,G_periody,l_ni,0)
!$omp end single
*
* Zero vth_w halo
* ---------------
!$omp do
do k=1,G_nk
do j=l_miny,0
do i=l_minx,l_maxx
vth_w(i,j,k) = ZERO_8
end do
end do
do j=l_njv+1,l_maxy
do i=l_minx ,l_maxx
vth_w(i,j,k) = ZERO_8
end do
end do
do i=l_minx,0
do j=l_miny,l_maxy
vth_w(i,j,k) = ZERO_8
end do
end do
do i=l_ni+1,l_maxx
do j=l_miny,l_maxy
vth_w(i,j,k) = ZERO_8
end do
end do
end do
!$omp enddo
*
!$omp single
call rpn_comm_adj_halo (uth_w,LDIST_DIM,l_niu,l_nj, G_nk,
% G_halox,G_haloy,G_periodx,G_periody,l_ni,0)
!$omp end single
*
* Zero uth_w halo
* --------------
!$omp do
do k=1,G_nk
do j=l_miny,0
do i=l_minx,l_maxx
uth_w(i,j,k) = ZERO_8
end do
end do
do j=l_nj+1,l_maxy
do i=l_minx,l_maxx
uth_w(i,j,k) = ZERO_8
end do
end do
do i=l_minx,0
do j=l_miny,l_maxy
uth_w(i,j,k) = ZERO_8
end do
end do
do i=l_niu+1,l_maxx
do j=l_miny ,l_maxy
uth_w(i,j,k) = ZERO_8
end do
end do
end do
!$omp enddo
*
!$omp single
call rpn_comm_adj_halo (v_wrk,LDIST_DIM,l_ni,l_njv,G_nk,
% G_halox,G_haloy,G_periodx,G_periody,l_ni,0)
!$omp end single
*
* Zero v_wrk halo
* ---------------
!$omp do
do k=1,G_nk
do j=l_miny,0
do i=l_minx,l_maxx
v_wrk(i,j,k) = ZERO_8
end do
end do
do j=l_njv+1,l_maxy
do i=l_minx ,l_maxx
v_wrk(i,j,k) = ZERO_8
end do
end do
do i=l_minx,0
do j=l_miny,l_maxy
v_wrk(i,j,k) = ZERO_8
end do
end do
do i=l_ni+1,l_maxx
do j=l_miny,l_maxy
v_wrk(i,j,k) = ZERO_8
end do
end do
end do
!$omp enddo
*
!$omp single
call rpn_comm_adj_halo (u_wrk,LDIST_DIM,l_niu,l_nj, G_nk,
% G_halox,G_haloy,G_periodx,G_periody,l_ni,0)
!$omp end single
*
* Zero u_wrk halo
* ---------------
!$omp do
do k=1,G_nk
do j=l_miny,0
do i=l_minx,l_maxx
u_wrk(i,j,k) = ZERO_8
end do
end do
do j=l_nj+1,l_maxy
do i=l_minx,l_maxx
u_wrk(i,j,k) = ZERO_8
end do
end do
do i=l_minx,0
do j=l_miny,l_maxy
u_wrk(i,j,k) = ZERO_8
end do
end do
do i=l_niu+1,l_maxx
do j=l_miny ,l_maxy
u_wrk(i,j,k) = ZERO_8
end do
end do
end do
!$omp enddo
*
* ---------------------------------------------------------------------------------------------------
* ADJ of
* F_u,F_v_F_w will contain winds components to be interpolated when evaluating upstream positions
* uth,vth,wth will contain winds components NOT to be interpolated when evaluating upstream positions
* ---------------------------------------------------------------------------------------------------
!$omp do
do k=1,l_nk
do j=l_miny,l_maxy
do i=l_minx,l_maxx
*
psdt1(i,j,k) = wth_w(i,j,k) + psdt1(i,j,k)
wth_w(i,j,k) = ZERO_8
*
vt1 (i,j,k) = vth_w(i,j,k) + vt1(i,j,k)
vth_w(i,j,k) = ZERO_8
*
ut1 (i,j,k) = uth_w(i,j,k) + ut1(i,j,k)
uth_w(i,j,k) = ZERO_8
*
enddo
enddo
enddo
!$omp enddo
*
!$omp do
do k=1,l_nk
do j=l_miny,l_maxy
do i=l_minx,l_maxx
*
ut1 (i,j,k) = 2.* u_wrk(i,j,k) + ut1(i,j,k)
utw (i,j,k) = - u_wrk(i,j,k) + utw(i,j,k)
u_wrk(i,j,k) = ZERO_8
*
vt1 (i,j,k) = 2.* v_wrk(i,j,k) + vt1(i,j,k)
vtw (i,j,k) = - v_wrk(i,j,k) + vtw(i,j,k)
v_wrk(i,j,k) = ZERO_8
*
psdt1(i,j,k) = 2.* w_wrk(i,j,k) + psdt1(i,j,k)
psdtw(i,j,k) = - w_wrk(i,j,k) + psdtw(i,j,k)
w_wrk(i,j,k) = ZERO_8
enddo
enddo
enddo
!$omp enddo
*
!$omp end parallel
*
pnerr = vmmuld(-1,0)
*
if (G_lam) deallocate ( in0 )
*
1000 format(3X,'ADJ of PREPARE WINDS: (S/R ADW_MAIN_1_WND_SETTLS_AD)')
return
end