!-------------------------------------- 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_3_int_ad - ADJ of adw_main_3_int_tl
*
#include "model_macros_f.h"
*
subroutine adw_main_3_int_ad ( F_u, F_v, F_w, F_um, F_vm, F_wm ) 1,7
*
implicit none
*
real F_u (*),F_v (*),F_w (*)
real F_um(*),F_vm(*),F_wm(*)
*
*author
* monique tanguay
*
*revision
* v2_31 - Tanguay M. - initial MPI version
* v3_00 - Tanguay M. - adapt to restructured adw_main
* v3_00 - Tanguay M. - restore vectorization in adjoint of semi-Lag.
* v3_02 - Tanguay M. - restore tracers monotone if V4dg_conf.ne.0
* v3_03 - Tanguay M. - Adjoint Lam and Nohyd configuration
* v3_11 - Tanguay M. - Remove restoration of vectorization in adjoint of semi-Lag
* - Introduce key Adw_mono_L
* v3_11 - Lee V. - OpenMP for ADW_MAIN_3_INT_AD
* v3_20 - Tanguay M. - Tracers and basic fields in same OPENMP loop
* - Lagrange 3D
* v3_21 - Tanguay M. - Call adw_main_3_intlag_ad based on Adw_lag3d_L
* v3_30 - Tanguay M. - Adapt TL/AD to Adw_interp_type_S
* v3_31 - Tanguay M. - Introduce time extrapolation
* v3_31 - Tanguay M. - new scope for operator + adw_cliptraj (LAM)
*
*language
* fortran 77
*
*object
* see id section
*
*ADJ of
*arguments
*______________________________________________________________________
* | | |
* NAME | DESCRIPTION | I/O |
*--------|-------------------------------------------------------|-----|
* | | |
* | | |
* F_u,F_v| 3 components of upstream positions at t1 at input | iw |
* F_w | used as work field afterward | |
*________|_______________________________________________________|_____|
*
*implicits
#include "glb_ld.cdk"
#include "glb_pil.cdk"
#include "ptopo.cdk"
#include "geomg.cdk"
#include "orh.cdk"
#include "lun.cdk"
#include "schm.cdk"
#include "offc.cdk"
#include "cstv.cdk"
#include "rhsc.cdk"
#include "v4dg.cdk"
#include "adw.cdk"
cvl#include "tr2d.cdk"
#include "tr3d.cdk"
#include "vt1.cdk"
#include "vt0.cdk"
#include "adwm.cdk"
#include "rhscm.cdk"
#include "vt1m.cdk"
#include "vt0m.cdk"
*
*modules
integer vmmlod, vmmget, vmmuld
external vmmlod, vmmget, vmmuld
************************************************************************
integer i0,in,j0,jn,n,nij,nijk,nijkag,i,j,k,kk,dest_ni,nn,ii,pnerr,
$ pnlkey1(10+Tr3d_ntr),pnlkey2(10+Tr3d_ntr),
$ pnlkey3(10+Tr3d_ntr),pnlkeys(10+Tr3d_ntr),pnlkey4(10+Tr3d_ntr),
$ key1(Tr3d_ntr),key0(Tr3d_ntr),key0m(Tr3d_ntr),
$ key1_,key0_,key0m_,pnlod,err
*
real*8 aaa_8
real*8, parameter :: ZERO_8 = 0.0
*
logical wind_L, mono_L
*
real u (Adw_nit*Adw_njt*l_nk,Tr3d_ntr+7)
real um(Adw_nit*Adw_njt*l_nk,Tr3d_ntr+7)
*
real in0(LDIST_SHAPE,l_nk,Tr3d_ntr+7)
*
real fin1(LDIST_SHAPE,l_nk),finm1(LDIST_SHAPE,l_nk)
real fin,finm
pointer (pafin,fin(LDIST_SHAPE,*)),(pafinm,finm(LDIST_SHAPE,*))
*
real F_um_ref(l_ni*l_nj*l_nk),F_vm_ref(l_ni*l_nj*l_nk)
*
* ---------------------------------------------------
* Allocate extra space TRAJ (x y z upstream position)
* ---------------------------------------------------
real um_1(l_ni*l_nj*l_nk),vm_1(l_ni*l_nj*l_nk)
real wm_1(l_ni*l_nj*l_nk)
real capx1(Adw_nit*Adw_njt*l_nk,Tr3d_ntr+7)
real capy1(Adw_nit*Adw_njt*l_nk,Tr3d_ntr+7)
real capz1(Adw_nit*Adw_njt*l_nk,Tr3d_ntr+7)
real cz1 (Adw_nit*Adw_njt*l_nk,Tr3d_ntr+7)
*
* -----------------------
* Define extra work space
* -----------------------
real work1(LDIST_SHAPE,l_nk),work
pointer (pawork,work(LDIST_SHAPE,*))
*
real worx1(LDIST_SHAPE,l_nk),worx
pointer (paworx,worx(LDIST_SHAPE,*))
* ______________________________________________________
*
if ( Adw_interp_type_S(1:5).ne.'LAG3D' )
$ call gem_stop ('ADW_MAIN_3_INT_AD: Adw_interp_type_S(1:5).ne.LAG3D not done',-1)
*
cvl if ( Tr2d_ntr.ne.0 ) call gem_stop('adw_main_3_int_ad',-1)
* ______________________________________________________
*
if ( Adw_interp_type_S(1:5).eq.'LAG3D' ) then
call adw_main_3_intlag_ad ( F_u, F_v, F_w, F_um, F_vm, F_wm )
return
endif
*
if (Lun_debug_L) write (Lun_out,1000)
*
nij = l_ni *l_nj
nijk = l_ni *l_nj *l_nk
nijkag = Adw_nit*Adw_njt*l_nk
call hpalloc(Adw_capx1_ ,nijk, err,1)
call hpalloc(Adw_capy1_ ,nijk, err,1)
call hpalloc(Adw_capz1_ ,nijk, err,1)
call hpalloc(Adw_n1_ ,nijk, err,1)
call hpalloc(Adw_xdd1_ ,nijk, err,1)
call hpalloc(Adw_xgg1_ ,nijk, err,1)
call hpalloc(Adw_ydd1_ ,nijk, err,1)
call hpalloc(Adw_ygg1_ ,nijk, err,1)
call hpalloc(Adw_cz1_ ,nijk, err,1)
call hpalloc(Adw_c1_ ,nijk, err,1)
call hpalloc(Adw_wrkb_ ,nijk, err,1)
call hpalloc(Adw_wrkc_ ,nijk, err,1)
*
call hpalloc(Adwm_capx1m_ ,nijk, err,1)
call hpalloc(Adwm_capy1m_ ,nijk, err,1)
call hpalloc(Adwm_capz1m_ ,nijk, err,1)
call hpalloc(Adwm_n1m_ ,nijk, err,1)
call hpalloc(Adwm_xdd1m_ ,nijk, err,1)
call hpalloc(Adwm_xgg1m_ ,nijk, err,1)
call hpalloc(Adwm_ydd1m_ ,nijk, err,1)
call hpalloc(Adwm_ygg1m_ ,nijk, err,1)
call hpalloc(Adwm_cz1m_ ,nijk, err,1)
call hpalloc(Adwm_c1m_ ,nijk, err,1)
call hpalloc(Adwm_wrkbm_ ,nijk, err,1)
call hpalloc(Adwm_wrkcm_ ,nijk, err,1)
*
* TRAJECTORY
* ----------
i0=1
in=l_ni
j0=1
jn=l_nj
if (G_lam) then
if (l_west) i0=pil_w
if (l_east) in=l_niu - pil_e + 2
if (l_south) j0=pil_s
if (l_north) jn=l_njv - pil_n + 2
*
do i = 1,l_ni*l_nj*l_nk
F_um_ref(i) = F_um(i)
F_vm_ref(i) = F_vm(i)
enddo
*
call adw_cliptraj ( F_um, F_vm, i0, in, j0, jn, 'IN3_TR')
endif
*
!$omp parallel private(n,kk)
!$omp$ shared(capx1,capy1,capz1,cz1,u,um_1,vm_1,wm_1)
*
* Zero adjoint variables
* ----------------------
!$omp do
do n=1,nijk
Adw_capx1(n) = ZERO_8
Adw_capy1(n) = ZERO_8
Adw_capz1(n) = ZERO_8
Adw_n1 (n) = ZERO_8
Adw_xdd1 (n) = ZERO_8
Adw_xgg1 (n) = ZERO_8
Adw_ydd1 (n) = ZERO_8
Adw_ygg1 (n) = ZERO_8
Adw_cz1 (n) = ZERO_8
Adw_c1 (n) = ZERO_8
Adw_wrkb (n) = ZERO_8
Adw_wrkc (n) = ZERO_8
enddo
!$omp enddo
!$omp do
do kk=1,Tr3d_ntr+7
do n=1,nijk
capx1(n,kk) = ZERO_8
capy1(n,kk) = ZERO_8
capz1(n,kk) = ZERO_8
cz1 (n,kk) = ZERO_8
enddo
enddo
!$omp enddo
!$omp do
do kk=1,Tr3d_ntr+7
do n=1,Adw_nit*Adw_njt*l_nk
u(n,kk) = ZERO_8
enddo
enddo
!$omp enddo
*
************************************************************************
*
* ----------------------------------------------------
* Preserve x y z upstream position in extra space TRAJ
* ----------------------------------------------------
!$omp do
do n =1,nijk
um_1(n) = F_um(n)
vm_1(n) = F_vm(n)
wm_1(n) = F_wm(n)
enddo
!$omp enddo
*
!$omp end parallel
*
* ----------
* TRAJECTORY
* ----------
if( .not. Adw_interp_type_S(1:5).eq.'LAG3D' ) then
call adw_setint ( Adwm_n1m,Adwm_capx1m,Adwm_xgg1m,Adwm_xdd1m,Adwm_capy1m,Adwm_ygg1m,
% Adwm_ydd1m, Adwm_capz1m, Adwm_cz1m, F_um, F_vm, F_wm,
% .true., .true., .false., nijk,i0,in,j0,jn,l_nk)
else
* ----------------------------
* Keep positions in CAP fields
* ----------------------------
!$omp parallel do private(n)
do k=1,l_nk
do j=j0,jn
do i=i0,in
n = (k-1)*nij + ((j-1)*l_ni) + i
Adwm_capx1m(n) = F_um(n)
Adwm_capy1m(n) = F_vm(n)
Adwm_capz1m(n) = F_wm(n)
end do
end do
end do
!$omp end parallel do
endif
*
if (G_lam) then
nn=0
dest_ni=l_ni
else
nn=999
dest_ni=G_ni
endif
*
* --------------------
* ADJOINT CALCULATIONS
* --------------------
***********************************************************************
* ADJ of
* Perform interpolation
***********************************************************************
*
* ----------------------------------
* NOTE: F_u F_v used as WORK SPACE
* NOTE: F_um F_vm used as WORK SPACE
* ----------------------------------
*
pnlod = 0
*
if (.not. Schm_hydro_L) then
*
pnlod = pnlod+1
pnlkey1(pnlod) = VMM_KEY(rvv)
pnlkey2(pnlod) = VMM_KEY(rvvm)
pnlkey3(pnlod) = 0
pnlkey4(pnlod) = 0
pnlkeys(pnlod) = 2
*
pnlod = pnlod+1
pnlkey1(pnlod) = VMM_KEY(rw)
pnlkey2(pnlod) = VMM_KEY(rwm)
pnlkey3(pnlod) = 0
pnlkey4(pnlod) = 0
pnlkeys(pnlod) = 2
*
endif
pnlod = pnlod+1
pnlkey1(pnlod) = VMM_KEY(rth)
pnlkey2(pnlod) = VMM_KEY(rthm)
pnlkey3(pnlod) = 0
pnlkey4(pnlod) = 0
pnlkeys(pnlod) = 2
pnlod = pnlod+1
pnlkey1(pnlod) = VMM_KEY(rcn)
pnlkey2(pnlod) = VMM_KEY(rcnm)
pnlkey3(pnlod) = 0
pnlkey4(pnlod) = 0
pnlkeys(pnlod) = 2
pnlod = pnlod+1
pnlkey1(pnlod) = VMM_KEY(rvw1)
pnlkey2(pnlod) = VMM_KEY(rvw1m)
pnlkey3(pnlod) = VMM_KEY(rvw2)
pnlkey4(pnlod) = 0
pnlkeys(pnlod) = 3
pnlod = pnlod+1
pnlkey1(pnlod) = VMM_KEY(ruw1)
pnlkey2(pnlod) = VMM_KEY(ruw1m)
pnlkey3(pnlod) = VMM_KEY(ruw2)
pnlkey4(pnlod) = 0
pnlkeys(pnlod) = 3
*
if ( Orh_icn .eq. Schm_itcn. or. .not.Orh_crank_L ) then
*
aaa_8 = ( Offc_a1_8 / Offc_b0_8 )/ Cstv_dt_8
*
key1_ = VMM_KEY (trt1)
key0_ = VMM_KEY (trt0)
key0m_= VMM_KEY (trt0m)
*
do n=1,Tr3d_ntr
key1 (n)= key1_ + n
key0 (n)= key0_ + n
key0m(n)= key0m_ + n
pnlod = pnlod+1
pnlkey1(pnlod) = key0 (n)
pnlkey2(pnlod) = key0m(n)
pnlkey3(pnlod) = 0
pnlkey4(pnlod) = key1 (n)
pnlkeys(pnlod) = 1
end do
*
endif
*
pnerr = vmmlod(pnlkey1,pnlod)
pnerr = vmmlod(pnlkey2,pnlod)
pnerr = vmmlod(pnlkey3,pnlod)
pnerr = vmmlod(pnlkey4,pnlod)
*
do kk=1,pnlod
pafinm = loc(finm1)
pnerr = vmmget(pnlkey2(kk),pafinm,finm)
call rpn_comm_xch_halox (finm, LDIST_DIM, l_ni, l_nj, l_nk,
% Adw_halox, Adw_haloy, G_periodx, G_periody,um(1,kk), -Adw_halox+1,
% Adw_nic+Adw_halox, -Adw_haloy+1, Adw_njc+Adw_haloy, dest_ni, nn)
enddo
*
* Transfer field in extra work space
* ----------------------------------
!$omp parallel private(wind_L,mono_L,pnerr,err,ii,i,j,k,
!$omp$ finm1,pafinm,fin1,pafin,
!$omp$ work1,pawork,worx1,paworx)
!$omp$ shared(u,um,capx1,capy1,capz1,cz1,in0,
!$omp$ pnlkey1,pnlkey2,pnlkey3,pnlkey4,pnlkeys,pnlod)
!$omp do
do kk=1,pnlod
pafin = loc(fin1)
pnerr = vmmget(pnlkey1(kk),pafin,fin)
*
mono_L = .false.
*
if (pnlkeys(kk).eq.1) then
mono_L = Adw_mono_L
do k=1,G_nk
do j=1,l_nj
do i=1,l_ni
fin(i,j,k) = Cstv_tau_8*fin(i,j,k)
end do
end do
end do
endif
*
pawork = loc(work1)
*
if (pnlkeys(kk).eq.3) then
pnerr = vmmget(pnlkey3(kk),pawork,work)
wind_L = .true.
else
* Transfer field in extra work space
* ----------------------------------
wind_L = .false.
do k=1,l_nk
do j=l_miny,l_maxy
do i=l_minx,l_maxx
work(i,j,k) = fin(i,j,k)
fin(i,j,k) = ZERO_8
enddo
enddo
enddo
endif
*
* Adjoint of interpolation
* ------------------------
call adw_interp_ad (work, u(1,kk), um(1,kk),
% capx1(1,kk),capy1(1,kk),capz1(1,kk),cz1(1,kk),
% wind_L, mono_L, LDIST_DIM, l_nk,i0,in,j0,jn)
*
if (G_lam) then
do k=1,l_nk
do j=l_miny,l_maxy
do i=l_minx,l_maxx
in0(i,j,k,kk) = fin(i,j,k)
end do
end do
end do
endif
enddo
!$omp enddo
!$omp single
do kk=1,pnlod
pnerr = vmmget(pnlkey1(kk),pafin,fin)
call rpn_comm_adj_halox (fin, LDIST_DIM, l_ni, l_nj, l_nk,
% Adw_halox, Adw_haloy, G_periodx, G_periody, u(1,kk), -Adw_halox+1,
% Adw_nic+Adw_halox, -Adw_haloy+1, Adw_njc+Adw_haloy, dest_ni, nn)
enddo
!$omp end single
*
!$omp do
do kk=1,pnlod
*
if (pnlkeys(kk).eq.1) then
*
paworx = loc(worx1)
pafin = loc(fin1)
*
pnerr = vmmget(pnlkey1(kk),pafin,fin)
pnerr = vmmget(pnlkey4(kk),paworx,worx)
*
do k=1,G_nk
do j=1,l_nj
do i=1,l_ni
worx(i,j,k) = - aaa_8*fin(i,j,k) + worx(i,j,k)
fin (i,j,k) = ZERO_8
end do
end do
end do
*
endif
*
do ii=1,Adw_nit*Adw_njt*l_nk
u(ii,kk) = ZERO_8
enddo
*
if (G_lam) then
pnerr = vmmget(pnlkey1(kk),pafin,fin)
do k=1,l_nk
do j=l_miny,l_maxy
do i=l_minx,l_maxx
fin(i,j,k) = in0(i,j,k,kk) + fin(i,j,k)
C in0(i,j,k,kk) = ZERO_8
end do
end do
end do
endif
*
err = vmmuld(pnlkey1(kk),1)
err = vmmuld(pnlkey2(kk),1)
err = vmmuld(pnlkey3(kk),1)
err = vmmuld(pnlkey4(kk),1)
*
enddo
!$omp enddo
*
!$omp do
do n = 1, nijk
do kk=1,pnlod
Adw_capx1(n) = Adw_capx1(n) + capx1(n,kk)
Adw_capy1(n) = Adw_capy1(n) + capy1(n,kk)
Adw_capz1(n) = Adw_capz1(n) + capz1(n,kk)
Adw_cz1 (n) = Adw_cz1(n) + cz1(n,kk)
enddo
enddo
!$omp end do
!$omp end parallel
*
************************************************************************
*
* ---------------------------------------------------
* Reset x y z upstream position from extra space TRAJ
* ---------------------------------------------------
if( .not. Adw_interp_type_S(1:5).eq.'LAG3D' ) then
call adw_setint_ad ( Adw_n1, Adw_capx1, Adw_xgg1, Adw_xdd1, Adw_capy1, Adw_ygg1,
% Adw_ydd1, Adw_capz1, Adw_cz1, F_u, F_v, F_w,
% um_1, vm_1, wm_1,
% .true., .true., .false., nijk,i0,in,j0,jn,l_nk)
else
* ADJ of Keep positions in CAP fields
* -----------------------------------
!$omp parallel do private(n)
do k=1,l_nk
do j=j0,jn
do i=i0,in
n = (k-1)*nij + ((j-1)*l_ni) + i
*
F_w(n) = Adw_capz1(n) + F_w(n)
F_v(n) = Adw_capy1(n) + F_v(n)
F_u(n) = Adw_capx1(n) + F_u(n)
*
Adw_capz1(n) = ZERO_8
Adw_capy1(n) = ZERO_8
Adw_capx1(n) = ZERO_8
end do
end do
end do
!$omp end parallel do
endif
*
if (G_lam) call adw_cliptraj_ad ( F_u, F_v, F_um_ref, F_vm_ref, i0, in, j0, jn, 'IN3_AD')
*
***********************************************************************
* Deallocate
***********************************************************************
call hpdeallc(Adw_capx1_ ,err,1)
call hpdeallc(Adw_capy1_ ,err,1)
call hpdeallc(Adw_capz1_ ,err,1)
call hpdeallc(Adw_n1_ ,err,1)
call hpdeallc(Adw_xdd1_ ,err,1)
call hpdeallc(Adw_xgg1_ ,err,1)
call hpdeallc(Adw_ydd1_ ,err,1)
call hpdeallc(Adw_ygg1_ ,err,1)
call hpdeallc(Adw_cz1_ ,err,1)
call hpdeallc(Adw_c1_ ,err,1)
call hpdeallc(Adw_wrkb_ ,err,1)
call hpdeallc(Adw_wrkc_ ,err,1)
*
call hpdeallc(Adwm_capx1m_ ,err,1)
call hpdeallc(Adwm_capy1m_ ,err,1)
call hpdeallc(Adwm_capz1m_ ,err,1)
call hpdeallc(Adwm_n1m_ ,err,1)
call hpdeallc(Adwm_xdd1m_ ,err,1)
call hpdeallc(Adwm_xgg1m_ ,err,1)
call hpdeallc(Adwm_ydd1m_ ,err,1)
call hpdeallc(Adwm_ygg1m_ ,err,1)
call hpdeallc(Adwm_cz1m_ ,err,1)
call hpdeallc(Adwm_c1m_ ,err,1)
call hpdeallc(Adwm_wrkbm_ ,err,1)
call hpdeallc(Adwm_wrkcm_ ,err,1)
*
1000 format(3X,'ADJ of ADVECT THE RIGHT-HAND-SIDES: (S/R ADW_MAIN_3_INT_AD)')
*
return
end