!-------------------------------------- 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_ad - ADJ of adw_main_tl
*
#include "model_macros_f.h"
*
subroutine adw_main_ad ( F_it ) 1,12
*
implicit none
*
integer F_it
*
*author
* monique tanguay
*
*revision
* v2_31 - Tanguay M. - initial MPI version
* v3_00 - Tanguay M. - adapt to restructured adw_main
* v3_20 - Tanguay M. - Option of storing instead of redoing TRAJ
* v3_21 - Tanguay M. - Revision Openmp
* v3_30 - Tanguay M. - Adapt TL/AD to Adw_interp_type_S
* v3_31 - Tanguay M. - SETTLS option
*
*language
* fortran 77
*
*object
* see id section
*
*arguments
*______________________________________________________________________
* | | |
* NAME | DESCRIPTION | I/O |
*--------|-------------------------------------------------------|-----|
* F_it | total number of iterations for trajectories | i |
*________|_______________________________________________________|_____|
*
*implicits
#include "glb_ld.cdk"
#include "lun.cdk"
#include "adw.cdk"
#include "vthm.cdk"
#include "v4dr.cdk"
#include "orh.cdk"
#include "schm.cdk"
*
integer vmmlod, vmmget, vmmuld
external vmmlod, vmmget, vmmuld
integer pnerr, pnlkey1(30), pnlod
*
integer nijk,nijkag,n
real , dimension (Adw_nit*Adw_njt*l_nk) :: u,v,w
real , dimension (Adw_nit*Adw_njt*l_nk) :: um,vm,wm,uwork,vwork,wwork
*
* -----------------------
* Define extra space TRAJ
* -----------------------
real xthm_1 (l_ni*l_nj*l_nk), ythm_1 (l_ni*l_nj*l_nk), zthm_1 (l_ni*l_nj*l_nk)
real xcthm_1(l_ni*l_nj*l_nk), ycthm_1(l_ni*l_nj*l_nk), zcthm_1(l_ni*l_nj*l_nk)
*
real*8, parameter :: ZERO_8 = 0.0
*
logical step_settls_L
*
***********************************************************************
if (Adw_interp_type_S(1:5).ne.'LAG3D')
$ call gem_stop ('ADW_MAIN_AD: Adw_interp_type_S(1:5).ne.LAG3D not done',-1)
*
if (V4dr_redotr_L) call gem_stop ('ADW_MAIN_AD: REDOTR not done',-1)
*
***********************************************************************
if (Lun_debug_L) write (Lun_out,1000)
*
step_settls_L = .NOT.(Orh_crank_L.or..not.Schm_settls_L)
*
nijk = l_ni*l_nj*l_nk
nijkag = Adw_nit*Adw_njt*l_nk
*
* Zero adjoint variables
* ----------------------
!$omp parallel do
do n=1,nijkag
u(n) = ZERO_8
v(n) = ZERO_8
w(n) = ZERO_8
enddo
!$omp end parallel do
*
* ------------------
* TRAJECTORY (START)
* ------------------
*
* ----------------------------
if (.not.step_settls_L) then
* ----------------------------
*
call adw_main_1_wnd_tr ( um, vm, wm, Adw_nit, Adw_njt, l_nk)
*
* ----
else
* ----
*
* Recover TRAJ WINDS T1 and TW
* ----------------------------
call v4d_rwtraj (16)
*
call adw_main_1_wnd_settls_tr ( um, vm, wm, Adw_nit, Adw_njt, l_nk)
*
* -----
endif
* -----
*
* -------------------------------------------
* Preserve fields in extra space TRAJ (START)
* -------------------------------------------
pnlkey1(1) = VMM_KEY(xthm)
pnlkey1(2) = VMM_KEY(ythm)
pnlkey1(3) = VMM_KEY(zthm)
pnlkey1(4) = VMM_KEY(xcthm)
pnlkey1(5) = VMM_KEY(ycthm)
pnlkey1(6) = VMM_KEY(zcthm)
pnlod = 6
*
pnerr = vmmlod(pnlkey1,pnlod)
*
pnerr = VMM_GET_VAR(xthm)
pnerr = VMM_GET_VAR(ythm)
pnerr = VMM_GET_VAR(zthm)
pnerr = VMM_GET_VAR(xcthm)
pnerr = VMM_GET_VAR(ycthm)
pnerr = VMM_GET_VAR(zcthm)
*
!$omp parallel
*
!$omp do
do n=1,nijk
xthm_1 (n) = xthm (n)
ythm_1 (n) = ythm (n)
zthm_1 (n) = zthm (n)
xcthm_1(n) = xcthm(n)
ycthm_1(n) = ycthm(n)
zcthm_1(n) = zcthm(n)
enddo
!$omp enddo
*
!$omp do
do n=1,nijkag
uwork(n) = um(n)
vwork(n) = vm(n)
wwork(n) = wm(n)
enddo
!$omp enddo
*
!$omp end parallel
*
pnerr = vmmuld(-1,0)
*
* -----------------------------------------
* Preserve fields in extra space TRAJ (END)
* -----------------------------------------
*
* Recover TRAJ positions
* ----------------------
call v4d_rwtraj (13,um,vm,wm)
*
* ----------------
* TRAJECTORY (END)
* ----------------
*
* ADJOINT CALCULATIONS
* --------------------
call adw_main_3_int_ad ( u, v, w, um, vm, wm )
*
* ------------------------------------------
* Reset fields from extra space TRAJ (START)
* ------------------------------------------
pnlkey1(1) = VMM_KEY(xthm)
pnlkey1(2) = VMM_KEY(ythm)
pnlkey1(3) = VMM_KEY(zthm)
pnlkey1(4) = VMM_KEY(xcthm)
pnlkey1(5) = VMM_KEY(ycthm)
pnlkey1(6) = VMM_KEY(zcthm)
pnlod = 6
*
pnerr = vmmlod(pnlkey1,pnlod)
*
pnerr = VMM_GET_VAR(xthm)
pnerr = VMM_GET_VAR(ythm)
pnerr = VMM_GET_VAR(zthm)
pnerr = VMM_GET_VAR(xcthm)
pnerr = VMM_GET_VAR(ycthm)
pnerr = VMM_GET_VAR(zcthm)
*
!$omp parallel
*
!$omp do
do n=1,nijk
xthm (n) = xthm_1 (n)
ythm (n) = ythm_1 (n)
zthm (n) = zthm_1 (n)
xcthm(n) = xcthm_1(n)
ycthm(n) = ycthm_1(n)
zcthm(n) = zcthm_1(n)
enddo
!$omp enddo
*
!$omp do
do n=1,nijkag
um(n) = uwork(n)
vm(n) = vwork(n)
wm(n) = wwork(n)
enddo
!$omp enddo
*
!$omp end parallel
*
pnerr = vmmuld(-1,0)
*
* ----------------------------------------
* Reset fields from extra space TRAJ (END)
* ----------------------------------------
* ----------------------------
if (.not.step_settls_L) then
* ----------------------------
*
call adw_main_2_pos_ad ( F_it, u, v, w, um, vm, wm )
*
call adw_main_1_wnd_ad ( u, v, w, Adw_nit, Adw_njt, l_nk)
*
* ----
else
* ----
*
* Recover TRAJ XT1 YT1 ZT1
* ------------------------
call v4d_rwtraj (15)
*
call adw_main_2_pos_settls_ad ( F_it, u, v, w, um, vm, wm )
*
call adw_main_1_wnd_settls_ad ( u, v, w, Adw_nit, Adw_njt, l_nk)
*
* -----
endif
* -----
***********************************************************************
*
1000 format(3X,'ADJ of ADVECTE THE RIGHT-HAND-SIDES: (S/R ADW_MAIN_AD)')
*
return
end