!-------------------------------------- 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 tstpdyn_ad - ADJ of tstpdyn_tl
*
#include "model_macros_f.h"
*
subroutine tstpdyn_ad ( F_fnitraj ) 2,23
*
implicit none
*
integer F_fnitraj
*
*author
* M.Tanguay
*
*revision
* v2_10 - Tanguay M. - initial MPI version
* v2_21 - Tanguay M. - ADJ of HO option
* - ADJ of vertical sponge layer
* v2_31 - Tanguay M. - adapt ADJ to new advection code,
* hybrid coord., tracer tr3d and
* diffusion in gem_run
* v3_00 - Tanguay M. - adapt to restructured adw_main
* v3_02 - Tanguay M. - ADJ of Eigv_parity_L and Hspng_main done
* v3_03 - Tanguay M. - Adjoint NoHyd configuration
* v3_20 - Tanguay M. - Option of storing instead of redoing TRAJ
* v3_21 - Tanguay M. - Revision Openmp
* v3_30 - Tanguay M. - add parameter iln in sol_main
* v3_31 - Tanguay M. - Introduce time extrapolation
*
*object
* see id section
*
*arguments
* Name I/O Description
*----------------------------------------------------------------
* F_fnitraj I number of iterations to compute upstream
* positions
*----------------------------------------------------------------
*
*implicits
#include "glb_ld.cdk"
#include "lun.cdk"
#include "cstv.cdk"
#include "schm.cdk"
#include "orh.cdk"
#include "sol.cdk"
#include "nl.cdk"
#include "v4dg.cdk"
#include "nlm.cdk"
#include "vt1m.cdk"
#include "vt0m.cdk"
#include "rhscm.cdk"
#include "orhm.cdk"
#include "tr3d.cdk"
#include "lctl.cdk"
#include "v4dr.cdk"
*
*modules
integer vmmlod,vmmuld,vmmget
external vmmlod,vmmuld,vmmget
*
integer pnerr, pnlkey1(10), key0m(Tr3d_ntr), keyorm(Tr3d_ntr),
$ key0m_, keyorm_, err, iln, dim, ilntrj, i, j, k, n
*
real tr0m,orm
pointer (patr0m, tr0m(LDIST_SHAPE,*)),(paorm, orm(LDIST_SHAPE,*))
*
real prdth
*
real*8, parameter :: ZERO_8 = 0.0
* ______________________________________________________
*
prdth = Cstv_dt_8/2.
*
if (Lun_debug_L) write(Lun_out,1000)
*
* ----------------
* START TRAJECTORY
* ----------------
*
* Recover TRAJ predictive variables
* ---------------------------------
if ( (Orh_crank_L .and. Orh_icn.eq.Schm_itcn) .or. .not.Orh_crank_L ) call v4d_rwtraj (3)
*
call rhs_tr
*
* Recover TRAJ Positions TH
* -------------------------
call v4d_rwtraj (4)
*
* Recover TRAJ Winds TH
* ---------------------
call v4d_rwtraj (5)
*
call adw_main_tr ( F_fnitraj )
*
call pre_tr ()
*
dim = (l_maxx-l_minx+1)*(l_maxy-l_miny+1)*l_nk
call hpalloc (nlm_num_ , dim, err,1)
call hpalloc (nlm_nvm_ , dim, err,1)
call hpalloc (nlm_nthm_ , dim, err,1)
call hpalloc (nlm_ncnm_ , dim, err,1)
nlm_n3m_ = 0
nlm_n3pm_ = 0
if (.not. Schm_hydro_L) then
call hpalloc (nlm_n3m_ , dim, err,1)
call hpalloc (nlm_n3pm_ , dim, err,1)
endif
*
* --------------
* END TRAJECTORY
* --------------
if (Lun_debug_L) write (Lun_out,1005) Schm_itnlh
*
* ADJ
* ---
dim = (l_maxx-l_minx+1)*(l_maxy-l_miny+1)*l_nk
call hpalloc (nl_nu_ , dim, err,1)
call hpalloc (nl_nv_ , dim, err,1)
call hpalloc (nl_nth_ , dim, err,1)
call hpalloc (nl_ncn_ , dim, err,1)
nl_n3_ = 0
nl_n3p_ = 0
if (.not. Schm_hydro_L) then
call hpalloc (nl_n3_ , dim, err,1)
call hpalloc (nl_n3p_ , dim, err,1)
endif
*
* Zero adjoint variables
* ----------------------
!$omp parallel
!$omp do
do k = 1,l_nk
do j = l_miny,l_maxy
do i = l_minx,l_maxx
nl_nu (i,j,k) = ZERO_8
nl_nv (i,j,k) = ZERO_8
nl_nth(i,j,k) = ZERO_8
nl_ncn(i,j,k) = ZERO_8
enddo
enddo
enddo
!$omp enddo
if (.not. Schm_hydro_L) then
!$omp do
do k = 1,l_nk
do j = l_miny,l_maxy
do i = l_minx,l_maxx
nl_n3 (i,j,k) = ZERO_8
nl_n3p (i,j,k) = ZERO_8
enddo
enddo
enddo
!$omp enddo
endif
!$omp end parallel
*
do 100 iln=Schm_itnlh,1,-1
*
* ----------------
* START TRAJECTORY
* ----------------
ilntrj = 1
*
if (Orh_icn.ne.1) then
*
* Recover fields at T0 and TX used as INPUT but changed by updating (subr. BAC)
* -----------------------------------------------------------------------------
call v4d_rwtraj (6)
*
else
*
* Recover fields at T0 used as INPUT but changed by updating (subr. BAC)
* ----------------------------------------------------------------------
call frstgss_tr
*
* Recover fields at TX used as INPUT but changed by updating (subr. BAC)
* ----------------------------------------------------------------------
if (.not. Schm_hydro_L) call v4d_rwtraj (7)
*
endif
*
if (iln.gt.1) then
*
do ilntrj=1,iln-1
*
call nli_tr ()
*
if ( V4dr_redotr_L ) then
*
call sol_main_tr (iln)
*
else
*
* Recover TRAJ GPTX at end of SOL_MAIN
* ------------------------------------
V4dr_iln = ilntrj
call v4d_rwtraj (9)
*
endif
*
call bac_tr ( ilntrj, Schm_itnlh )
*
enddo
*
endif
*
call nli_tr ()
*
if ( V4dr_redotr_L ) then
*
call sol_main_tr (iln)
*
else
*
* Recover TRAJ GPTX at end of SOL_MAIN
* ------------------------------------
V4dr_iln = iln
call v4d_rwtraj (9)
*
endif
*
* --------------
* END TRAJECTORY
* --------------
*
call bac_ad ( iln, Schm_itnlh )
*
call sol_main_ad (iln)
*
call nli_ad ()
*
100 continue
*
* TRAJECTORY
* ----------
call hpdeallc(nlm_num_ , err)
call hpdeallc(nlm_nvm_ , err)
call hpdeallc(nlm_nthm_, err)
call hpdeallc(nlm_ncnm_, err)
if (.not. Schm_hydro_L) then
call hpdeallc(nlm_n3m_ , err)
call hpdeallc(nlm_n3pm_, err)
endif
*
* ADJ
* ---
call hpdeallc(nl_nu_ , err)
call hpdeallc(nl_nv_ , err)
call hpdeallc(nl_nth_, err)
call hpdeallc(nl_ncn_, err)
if (.not. Schm_hydro_L) then
call hpdeallc(nl_n3_ , err)
call hpdeallc(nl_n3p_, err)
endif
*
if (Orh_icn.eq.1) call frstgss_ad( )
*
* START TRAJECTORY
* ----------------
* Recover TRAJ RHS (RUMW2,RVMW2) before PRE
* -----------------------------------------
pnlkey1(1) = VMM_KEY(ruw2m)
pnlkey1(2) = VMM_KEY(rvw2m)
pnlkey1(3) = VMM_KEY(oruw2m)
pnlkey1(4) = VMM_KEY(orvw2m)
pnerr = vmmlod(pnlkey1,4)
pnerr = VMM_GET_VAR(ruw2m)
pnerr = VMM_GET_VAR(rvw2m)
pnerr = VMM_GET_VAR(oruw2m)
pnerr = VMM_GET_VAR(orvw2m)
*
!$omp parallel do
do k=1,l_nk
do j=1,l_nj
do i=1,l_ni
ruw2m(i,j,k) = oruw2m(i,j,k)
rvw2m(i,j,k) = orvw2m(i,j,k)
end do
end do
end do
!$omp end parallel do
pnerr = vmmuld(-1,0)
*
* END TRAJECTORY
* --------------
*
call pre_ad ()
*
* START TRAJECTORY
* ----------------
* Recover TRAJ RHS (RCNM,RTHM) before ADW_MAIN_AD
* -----------------------------------------------
pnlkey1(1) = VMM_KEY(rcnm)
pnlkey1(2) = VMM_KEY(rthm)
pnlkey1(3) = VMM_KEY(orcnm)
pnlkey1(4) = VMM_KEY(orthm)
if (.not. Schm_hydro_L) then
pnlkey1(5) = VMM_KEY(rwm)
pnlkey1(6) = VMM_KEY(rvvm)
pnlkey1(7) = VMM_KEY(orwm)
pnlkey1(8) = VMM_KEY(orvvm)
pnerr = vmmlod(pnlkey1,8)
else
pnerr = vmmlod(pnlkey1,4)
endif
*
pnerr = VMM_GET_VAR(rcnm)
pnerr = VMM_GET_VAR(rthm)
pnerr = VMM_GET_VAR(orcnm)
pnerr = VMM_GET_VAR(orthm)
if (.not. Schm_hydro_L) then
pnerr = VMM_GET_VAR(rwm)
pnerr = VMM_GET_VAR(rvvm)
pnerr = VMM_GET_VAR(orwm)
pnerr = VMM_GET_VAR(orvvm)
endif
*
!$omp parallel
*
!$omp do
do k=1,l_nk
do j=1,l_nj
do i=1,l_ni
rcnm(i,j,k) = orcnm(i,j,k)
rthm(i,j,k) = orthm(i,j,k)
end do
end do
end do
!$omp end do
if (.not. Schm_hydro_L) then
!$omp do
do k=1,l_nk
do j=1,l_nj
do i=1,l_ni
rwm (i,j,k) = orwm (i,j,k)
rvvm(i,j,k) = orvvm(i,j,k)
end do
end do
end do
!$omp end do
endif
*
!$omp end parallel
*
pnerr = vmmuld(-1,0)
*
* Recover TRAJ ORTR before ADW_MAIN_AD
* ------------------------------------
if ( Orh_icn .eq. Schm_itcn. or. .not.Orh_crank_L ) then
*
key0m_ = VMM_KEY (trt0m)
keyorm_= VMM_KEY (ortrm)
do n=1,Tr3d_ntr
key0m (n) = key0m_ + n
keyorm(n) = keyorm_ + n
end do
if (Tr3d_ntr.gt.0) then
err = vmmlod(key0m, Tr3d_ntr)
err = vmmlod(keyorm,Tr3d_ntr)
do n=1,Tr3d_ntr
err = vmmget(key0m (n),patr0m,tr0m)
err = vmmget(keyorm(n),paorm, orm)
!$omp parallel do
do k=1,l_nk
do j=1,l_nj
do i=1,l_ni
tr0m(i,j,k) = orm(i,j,k)
end do
end do
end do
!$omp end parallel do
end do
err = vmmuld(key0m, Tr3d_ntr)
err = vmmuld(keyorm,Tr3d_ntr)
endif
*
endif
*
* END TRAJECTORY
* --------------
*
call adw_main_ad ( F_fnitraj )
*
call rhs_ad ()
*
* ---------------------------------------------------------------
*
1000 format(
+ 3X,'ADJ of PERFORM A DYNAMICAL STEP: (S/R TSTPDYN_AD)',
+/3X,'=================================================',/)
1005 format(
$3X,'ADJ of ITERATING SCHM_ITNLH=',I3,' TIMES TO SOLVE NON-LINEAR '
$ 'HELMHOLTZ PROBLEM',/)
return
end