!-------------------------------------- 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 out_dyn_ad - Prepare adjoint fields as seen by MODULOPT
* and call OUT_DYN
*
#include "model_macros_f.h"
*
subroutine out_dyn_ad 4,3
*
implicit none
*
*author
* M.Tanguay
*
*revision
* v2_10 - Tanguay M. - initial MPI version
* v2_31 - Tanguay M. - adapt for tracers in tr3d
* v3_00 - Tanguay M. - move true winds adjoint to blocuv
* - No preconditioning if V4dg_4dvar_L (done in 3D-Var)
* v3_01 - Tanguay M. - add V4dg_sgvc_L
* v3_03 - Tanguay M. - Adjoint NoHyd configuration
* v3_20 - Tanguay M. - Modification when imguv_L=.FALSE.
* v3_20 - Tanguay M. - Change name of subroutine
* v3_30 - Tanguay M. - Correction to make sure adjoint not affected by output
*
*object
* see id section
*
* NOTE: OUT_DYN may need to fill the halos.
* It is why OUT_DYN_AD keeps track of the
* original fields
*
*arguments
* none
*
*implicits
#include "glb_ld.cdk"
#include "lun.cdk"
#include "geomg.cdk"
#include "dcst.cdk"
#include "p_geof.cdk"
#include "vt1.cdk"
#include "v4dc.cdk"
#include "dimout.cdk"
#include "tr3d.cdk"
#include "v4dg.cdk"
#include "schm.cdk"
*
*modules
integer doout, vmmlod, vmmget, vmmuld
external doout, vmmlod, vmmget, vmmuld
integer pnerr, pnlkey1(7), key1(Tr3d_ntr),
$ key1_, err, i, j, k, m, n
real tr,z
pointer (patr, tr(LDIST_SHAPE,*))
*
integer dostep(MAXSET), dostep_max
*
logical imguv_L
*
real w_u (LDIST_SHAPE,l_nk), w_v (LDIST_SHAPE,l_nk)
real w_tp (LDIST_SHAPE,l_nk), w_t (LDIST_SHAPE,l_nk)
real w_fip(LDIST_SHAPE,l_nk), w_fi(LDIST_SHAPE,l_nk)
real w_tr (LDIST_SHAPE,l_nk,Tr3d_ntr)
real w_s (LDIST_SHAPE)
*
real*8 pdsc1_8
*
* Check if output is required
* ---------------------------
dostep_max = doout(dostep,1)
*
if (dostep_max .le. 0) goto 999
*
if(Lun_out.gt.0) write (Lun_out,1000)
*
* Get fields in memory
* --------------------
pnlkey1(1) = VMM_KEY(ut1 )
pnlkey1(2) = VMM_KEY(vt1 )
pnlkey1(3) = VMM_KEY(tpt1)
pnlkey1(4) = VMM_KEY(tt1)
pnlkey1(5) = VMM_KEY(st1)
pnlkey1(6) = VMM_KEY(fipt1 )
pnlkey1(7) = VMM_KEY(fit1 )
pnerr = vmmlod(pnlkey1,7)
*
* - - - - - - - - - - - - -
pnerr = VMM_GET_VAR(ut1 )
pnerr = VMM_GET_VAR(vt1 )
pnerr = VMM_GET_VAR(tpt1)
pnerr = VMM_GET_VAR(tt1)
pnerr = VMM_GET_VAR(st1)
pnerr = VMM_GET_VAR(fipt1 )
pnerr = VMM_GET_VAR(fit1 )
* - - - - - - - - - - - - -
*
* Keep original fields (PART1)
* ----------------------------
do k=1,l_nk
do j=l_miny,l_maxy
do i=l_minx,l_maxx
w_u (i,j,k) = ut1 (i,j,k)
w_v (i,j,k) = vt1 (i,j,k)
w_tp(i,j,k) = tpt1(i,j,k)
w_t (i,j,k) = tt1 (i,j,k)
end do
end do
end do
*
imguv_L = V4dg_imguv_L
*
if (.not.V4dg_imguv_L) then
*
V4dg_imguv_L = .true.
*
* Inverse the action of uv2img_ad
* -------------------------------
do j= 1, l_njv
pdsc1_8 = Dcst_rayt_8 / Geomg_cyv_8(j)
do k=1,G_nk
do i= 1, l_ni
vt1(i,j,k) = pdsc1_8 * vt1(i,j,k)
end do
end do
end do
*
do j= 1, l_nj
pdsc1_8 = Dcst_rayt_8 / Geomg_cy_8(j)
do k=1,G_nk
do i= 1, l_niu
ut1(i,j,k) = pdsc1_8 * ut1(i,j,k)
end do
end do
end do
*
endif
*
do j=l_miny,l_maxy
do i=l_minx,l_maxx
w_s(i,j) = st1(i,j)
end do
end do
*
do k=1,l_nk
do j=l_miny,l_maxy
do i=l_minx,l_maxx
w_fip(i,j,k) = fipt1 (i,j,k)
w_fi (i,j,k) = fit1 (i,j,k)
end do
end do
end do
*
if(.not.(V4dg_4dvar_L.or.V4dg_sgvc_L)) then
*
* SIMULATE V4D_CAIN_AD (PART1)
* ----------------------------
m = 0
do k=1,l_nk
do j=1,l_nj
do i=1,l_niu
m = m+1
if(V4dc_scalp(m).eq.0.) then
z = 0.
else
z = 1./V4dc_scalp(m)
endif
ut1(i,j,k) = ut1(i,j,k)*z
end do
end do
end do
*
do k=1,l_nk
do j=1,l_njv
do i=1,l_ni
m = m+1
if(V4dc_scalp(m).eq.0.) then
z = 0.
else
z = 1./V4dc_scalp(m)
endif
vt1(i,j,k) = vt1(i,j,k)*z
end do
end do
end do
*
do k=1,l_nk
do j=1,l_nj
do i=1,l_ni
m = m+1
if(V4dc_scalp(m).eq.0.) then
z = 0.
else
z = 1./V4dc_scalp(m)
endif
tpt1(i,j,k) = tpt1(i,j,k)*z
end do
end do
end do
*
do j=1,l_nj
do i=1,l_ni
m = m+1
if(V4dc_scalp(m).eq.0.) then
z = 0.
else
z = 1./V4dc_scalp(m)
endif
st1(i,j) = st1(i,j)*z
end do
end do
*
if (.not. Schm_hydro_L) then
*
do k=1,l_nk
do j=1,l_nj
do i=1,l_ni
m = m+1
if(V4dc_scalp(m).eq.0.) then
z = 0.
else
z = 1./V4dc_scalp(m)
endif
fipt1(i,j,k) = fipt1(i,j,k)*z
end do
end do
end do
*
endif
*
endif
*
pnerr = vmmuld(-1,0)
*
key1_ = VMM_KEY (trt1)
do n=1,Tr3d_ntr
key1(n) = key1_ + n
end do
*
if (Tr3d_ntr.gt.0) then
err = vmmlod(key1,Tr3d_ntr)
do n=1,Tr3d_ntr
err = vmmget(key1(n),patr,tr)
*
* Keep original fields (PART2)
* ----------------------------
do k=1,l_nk
do j=l_miny,l_maxy
do i=l_minx,l_maxx
w_tr(i,j,k,n) = tr(i,j,k)
end do
end do
end do
*
if(.not.(V4dg_4dvar_L.or.V4dg_sgvc_L)) then
*
* SIMULATE V4D_CAIN_AD (PART2)
* ----------------------------
do k=1,l_nk
do j=1,l_nj
do i=1,l_ni
m = m+1
if(V4dc_scalp(m).eq.0.) then
z = 0.
else
z = 1./V4dc_scalp(m)
endif
tr(i,j,k) = tr(i,j,k)*z
end do
end do
end do
*
endif
*
end do
err = vmmuld(key1,Tr3d_ntr)
endif
* ______________________________________________________
*
if(m.ne.V4dc_ncv.and..not.(V4dg_4dvar_L.or.V4dg_sgvc_L)) call gem_stop('out_dyn_ad',-1)
* ______________________________________________________
*
* Perform output if required
* --------------------------
call out_dyn (.true.,-1)
*
* Reset original fields
* ---------------------
pnlkey1(1) = VMM_KEY(ut1 )
pnlkey1(2) = VMM_KEY(vt1 )
pnlkey1(3) = VMM_KEY(tpt1)
pnlkey1(4) = VMM_KEY(tt1)
pnlkey1(5) = VMM_KEY(st1)
pnlkey1(6) = VMM_KEY(fipt1 )
pnlkey1(7) = VMM_KEY(fit1 )
pnerr = vmmlod(pnlkey1,7)
*
* - - - - - - - - - - - - -
pnerr = VMM_GET_VAR(ut1 )
pnerr = VMM_GET_VAR(vt1 )
pnerr = VMM_GET_VAR(tpt1)
pnerr = VMM_GET_VAR(tt1)
pnerr = VMM_GET_VAR(st1)
pnerr = VMM_GET_VAR(fipt1 )
pnerr = VMM_GET_VAR(fit1 )
* - - - - - - - - - - - - -
*
do k=1,l_nk
do j=l_miny,l_maxy
do i=l_minx,l_maxx
ut1 (i,j,k) = w_u (i,j,k)
vt1 (i,j,k) = w_v (i,j,k)
tpt1(i,j,k) = w_tp(i,j,k)
tt1 (i,j,k) = w_t (i,j,k)
end do
end do
end do
*
do j=l_miny,l_maxy
do i=l_minx,l_maxx
st1(i,j) = w_s(i,j)
end do
end do
*
do k=1,l_nk
do j=l_miny,l_maxy
do i=l_minx,l_maxx
fipt1 (i,j,k) = w_fip(i,j,k)
fit1 (i,j,k) = w_fi (i,j,k)
end do
end do
end do
*
pnerr = vmmuld(-1,0)
*
key1_ = VMM_KEY (trt1)
do n=1,Tr3d_ntr
key1(n) = key1_ + n
end do
*
if (Tr3d_ntr.gt.0) then
err = vmmlod(key1,Tr3d_ntr)
do n=1,Tr3d_ntr
err = vmmget(key1(n),patr,tr)
do k=1,l_nk
do j=l_miny,l_maxy
do i=l_minx,l_maxx
tr(i,j,k) = w_tr(i,j,k,n)
end do
end do
end do
end do
err = vmmuld(key1,Tr3d_ntr)
endif
*
if(.not.imguv_L) V4dg_imguv_L = .false.
*
* __________________________________________________________________
*
return
*
999 continue
*
if(Lun_out.gt.0) write (Lun_out,1001)
*
1000 format(' OUT_DYN_AD - PERFORMING REQUIRED ADJOINT OUTPUT')
1001 format(' OUT_DYN_AD - NO ADJOINT OUTPUT REQUIRED')
*
return
end