!-------------------------------------- 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_trajsp_ad - ADJ of adw_trajsp_tl
*
#include "model_macros_f.h"
*
subroutine adw_trajsp_ad ( F_lon, F_lat, F_x, F_y, F_z, F_u, F_v, 2
% F_latm,F_xm,F_ym,F_zm,F_um,F_vm,
% F_dt,i0,in,j0,jn)
*
implicit none
*
real F_lon (*),F_lat (*),F_x (*),F_y (*),F_z (*),F_u (*),F_v (*),F_dt
real F_latm(*),F_xm(*),F_ym(*),F_zm(*),F_um(*),F_vm(*)
integer i0,in,j0,jn
*
*author
* monique tanguay
*
*revision
* v2_31 - Tanguay M. - initial MPI version
* v3_00 - Tanguay M. - adapt to restructured adw_main
* v3_02 - Tanguay M. - correction when abs(F_zm)=1
* v3_11 - Tanguay M. - AIXport+Opti+OpenMP for TLM-ADJ
* v3_20 - Tanguay M. - Move division when denominators are zero
*
*language
* fortran 77
*
*object
* see id section
*
*ADJ of
*arguments
*______________________________________________________________________
* | | |
* NAME | DESCRIPTION | I/O |
*--------------|-------------------------------------------------|-----|
* | | |
* F_lon | upwind longitudes at central time | o |
* F_lat | upwind latitudes at central time | o |
* F_x | upwind x cartesian positions at central time | o |
* F_y | upwind y cartesian positions at central time | o |
* F_z | upwind z cartesian positions at central time | o |
* F_u | real E-W wind components at upwind positions | i |
* F_v | real N-S wind components at upwind positions | i |
* F_dt | timestep lenght | i |
*______________|_________________________________________________|_____|
*
*implicits
#include "glb_ld.cdk"
#include "adw.cdk"
#include "dcst.cdk"
*
************************************************************************
integer n, ij, nij, vnij, i, j, k
*
real*8 pdsa_8, pdca_8, pdcai_8, pdso_8, pdco_8, pdx_8, pdy_8, pdz_8,
% pdux_8, pduy_8, pduz_8, pdsinal_8, pdcosal_8, r2pi_8, TWO_8, ZERO_8
*
parameter (TWO_8 = 2.0)
parameter (ZERO_8= 0.0)
*
real*8 pdsam_8, pdcam_8, pdcaim_8, pdsom_8, pdcom_8,
% pduxm_8, pduym_8, pduzm_8, pdsinalm_8, pdcosalm_8,
% pduxm1_8,pduym1_8,pduzm1_8, pdsinalm1_8,pdsinalm2_8
*
real*8 rsxyzm_8(i0:in,j0:jn), rxyzm_8
*
real*8 xcosm_8(i0:in,j0:jn), ycosm_8(i0:in,j0:jn)
real*8 xsinm_8(i0:in,j0:jn), ysinm_8(i0:in,j0:jn)
real*8 yrecm_8(i0:in,j0:jn)
*
real*8 cos2m_8 (i0:in,j0:jn), suv2m_8 (i0:in,j0:jn), sz2m_8 (i0:in,j0:jn)
real*8 xy2m_8 (i0:in,j0:jn), slam_8 (i0:in,j0:jn)
real*8 rcos2m_8(i0:in,j0:jn)
real*8 rxy2m_8 (i0:in,j0:jn)
*
real zm3
*
real F_xm1(l_ni*l_nj*l_nk)
real F_ym1(l_ni*l_nj*l_nk)
real F_zm1(l_ni*l_nj*l_nk)
*
************************************************************************
nij = l_ni*l_nj
vnij = (in-i0+1)*(jn-j0+1)
*
r2pi_8 = TWO_8 * Dcst_pi_8
************************************************************************
*
* Zero adjoint work space
* -----------------------
pdsa_8 = ZERO_8
pdca_8 = ZERO_8
pdcai_8 = ZERO_8
pdso_8 = ZERO_8
pdco_8 = ZERO_8
pdux_8 = ZERO_8
pduy_8 = ZERO_8
pduz_8 = ZERO_8
pdsinal_8= ZERO_8
pdcosal_8= ZERO_8
*
* START REBUILD TRAJECTORY
* ------------------------
!$omp parallel do private (n,ij,
!$omp% pdsa_8,pdca_8,pdcai_8,pdso_8,pdco_8,pdx_8,pdy_8,pdz_8,
!$omp% pdux_8, pduy_8, pduz_8, pdsinal_8, pdcosal_8,
!$omp% pdsam_8,pdcam_8,pdcaim_8,pdsom_8,pdcom_8,
!$omp% pduxm_8,pduym_8,pduzm_8,pdsinalm_8,pdcosalm_8,
!$omp% pduxm1_8,pduym1_8,pduzm1_8, pdsinalm1_8,pdsinalm2_8,
!$omp% rsxyzm_8, rxyzm_8,
!$omp% xcosm_8,ycosm_8,xsinm_8,ysinm_8,yrecm_8,
!$omp% cos2m_8,suv2m_8,sz2m_8,xy2m_8,slam_8,
!$omp% rcos2m_8,rxy2m_8,zm3)
do k=l_nk,1,-1
*
* Pre-calculations (START)
* ------------------------
do j=j0,jn
do i=i0,in
n = (k-1)*nij + ((j-1)*l_ni) + i
*
xcosm_8(i,j) = F_latm(n)
suv2m_8(i,j) = sqrt( F_um(n) ** 2 + F_vm(n) ** 2 )
xsinm_8(i,j) = suv2m_8(i,j) * F_dt
*
end do
end do
*
call vcos(ycosm_8, xcosm_8, vnij)
call vsin(ysinm_8, xsinm_8, vnij)
call vrec(yrecm_8, ycosm_8, vnij)
*
* Pre-calculations (END)
* ----------------------
*
do j=jn,j0,-1
do i=in,i0,-1
n = (k-1)*nij + ((j-1)*l_ni) + i
*
ij = mod( n-1, nij ) + 1
************************************************************************
* cartesian coordinates of grid points *
************************************************************************
pdx_8 = Adw_cx2d_8(ij)
pdy_8 = Adw_sx2d_8(ij)
pdz_8 = Adw_sy2d_8(ij)
************************************************************************
* if very small wind set upwind point to grid point *
************************************************************************
if ( abs(F_um(n))+abs(F_vm(n)) .ge. 1.e-10 ) then
*
pdx_8 = pdx_8 * Adw_cy2d_8(ij)
pdy_8 = pdy_8 * Adw_cy2d_8(ij)
*
************************************************************************
* sin and cosin of first guess of upwind positions *
************************************************************************
pdsam_8 = F_zm(n)
pdcam_8 = ycosm_8(i,j)
pdcaim_8 = yrecm_8(i,j)
pdsom_8 = F_ym(n) * pdcaim_8
pdcom_8 = F_xm(n) * pdcaim_8
*
************************************************************************
* wind components in cartesian coordinate at upwind positions *
************************************************************************
pduxm1_8 = ( - F_um(n) * pdsom_8 - F_vm(n) * pdcom_8 * pdsam_8 )
pduym1_8 = ( F_um(n) * pdcom_8 - F_vm(n) * pdsom_8 * pdsam_8 )
pduzm1_8 = F_vm(n) * pdcam_8
*
pdsinalm1_8 = pdx_8 * pduxm1_8 + pdy_8 * pduym1_8 + pdz_8 * pduzm1_8
pduxm_8 = pduxm1_8 - pdx_8 * pdsinalm1_8
pduym_8 = pduym1_8 - pdy_8 * pdsinalm1_8
pduzm_8 = pduzm1_8 - pdz_8 * pdsinalm1_8
*
rsxyzm_8(i,j)= 1./sqrt( pduxm_8 * pduxm_8 + pduym_8 * pduym_8 + pduzm_8 * pduzm_8 )
*
pdcosalm_8 = sqrt( ( 1.0 + ysinm_8(i,j) ) * ( 1.0 - ysinm_8(i,j) ) )
pdsinalm2_8 = ysinm_8(i,j) * rsxyzm_8(i,j)
*
F_xm1(n) = F_xm(n)
F_ym1(n) = F_ym(n)
F_zm1(n) = F_zm(n)
*
F_xm(n) = pdcosalm_8 * pdx_8 - pdsinalm2_8 * pduxm_8
F_ym(n) = pdcosalm_8 * pdy_8 - pdsinalm2_8 * pduym_8
F_zm(n) = pdcosalm_8 * pdz_8 - pdsinalm2_8 * pduzm_8
*
endif
*
enddo
enddo
*
* Pre-calculations (START)
* ------------------------
do j=j0,jn
do i=i0,in
n = (k-1)*nij + ((j-1)*l_ni) + i
zm3 = F_zm(n)
*
if ( F_zm(n) .lt. -1.0D0 ) then
zm3 = -1.0D0
elseif ( F_zm(n) .gt. 1.0D0 ) then
zm3 = 1.0D0
endif
*
sz2m_8 (i,j) = sqrt(1.0 - zm3*zm3)
xy2m_8 (i,j) = F_xm(n)*F_xm(n) + F_ym(n)*F_ym(n)
cos2m_8(i,j) = ycosm_8(i,j) **2
*
enddo
enddo
*
call vrec(rxy2m_8, xy2m_8, vnij)
call vsin(slam_8, xcosm_8, vnij)
call vrec(rcos2m_8, cos2m_8, vnij)
*
* Pre-calculations (END)
* ----------------------
*
* END REBUILD TRAJECTORY
* ----------------------
*
do j=jn,j0,-1
do i=in,i0,-1
n = (k-1)*nij + ((j-1)*l_ni) + i
*
ij = mod( n-1, nij ) + 1
*
* ------------------------------------------------------------------
* ADJOINT of DO LOOP
* ------------------------------------------------------------------
*
* TRAJECTORY
* ----------
************************************************************************
* cartesian coordinates of grid points *
************************************************************************
pdx_8 = Adw_cx2d_8(ij)
pdy_8 = Adw_sx2d_8(ij)
pdz_8 = Adw_sy2d_8(ij)
*
zm3 = F_zm(n)
*
if ( F_zm(n) .lt. -1.0D0 ) then
zm3 = -1.0D0
elseif ( F_zm(n) .gt. 1.0D0 ) then
zm3 = 1.0D0
endif
*
* ADJ
* ---
F_y(n) = F_xm(n)*F_lon(n)*rxy2m_8(i,j) + F_y(n)
F_x(n) = -F_ym(n)*F_lon(n)*rxy2m_8(i,j) + F_x(n)
F_lon(n) = ZERO_8
*
if ( abs(zm3) .ne. 1.0D0 ) then
F_z(n) = F_lat(n) / sz2m_8(i,j) + F_z(n)
F_lat(n) = ZERO_8
else
F_lat(n) = 0.0D0
endif
*
if ( F_zm(n) .lt. -1.0D0 ) then
F_z (n) = 0.0D0
elseif ( F_zm(n) .gt. 1.0D0 ) then
F_z (n) = 0.0D0
endif
*
************************************************************************
* if very small wind set upwind point to grid point *
************************************************************************
if ( abs(F_um(n))+abs(F_vm(n)) .ge. 1.e-10 ) then
*
* TRAJECTORY
* ----------
pdx_8 = pdx_8 * Adw_cy2d_8(ij)
pdy_8 = pdy_8 * Adw_cy2d_8(ij)
*
* TRAJECTORY
* ----------
************************************************************************
* sin and cosin of first guess of upwind positions *
************************************************************************
pdsam_8 = F_zm1(n)
pdcam_8 = ycosm_8(i,j)
pdcaim_8 = yrecm_8(i,j)
pdsom_8 = F_ym1(n) * pdcaim_8
pdcom_8 = F_xm1(n) * pdcaim_8
*
* TRAJECTORY
* ----------
************************************************************************
* wind components in cartesian coordinate at upwind positions *
************************************************************************
pduxm1_8 = ( - F_um(n) * pdsom_8 - F_vm(n) * pdcom_8 * pdsam_8 )
pduym1_8 = ( F_um(n) * pdcom_8 - F_vm(n) * pdsom_8 * pdsam_8 )
pduzm1_8 = F_vm(n) * pdcam_8
*
* TRAJECTORY
* ----------
pdsinalm1_8 = pdx_8 * pduxm1_8 + pdy_8 * pduym1_8 + pdz_8 * pduzm1_8
pduxm_8 = pduxm1_8 - pdx_8 * pdsinalm1_8
pduym_8 = pduym1_8 - pdy_8 * pdsinalm1_8
pduzm_8 = pduzm1_8 - pdz_8 * pdsinalm1_8
*
pdcosalm_8 = sqrt( ( 1.0 + ysinm_8(i,j) ) * ( 1.0 - ysinm_8(i,j) ) )
pdsinalm2_8 = ysinm_8(i,j) * rsxyzm_8(i,j)
*
rxyzm_8 = 1./( pduxm_8 * pduxm_8 + pduym_8 * pduym_8 + pduzm_8 * pduzm_8 )
*
* ADJ
* ---
pdcosal_8 = F_x(n) * pdx_8
% + F_y(n) * pdy_8
% + F_z(n) * pdz_8
pdsinal_8 = - F_x(n) * pduxm_8
% - F_y(n) * pduym_8
% - F_z(n) * pduzm_8
*
pdux_8 = -pdsinalm2_8 * pduxm_8 * pdsinal_8 * rxyzm_8
% -pdsinalm2_8 * F_x(n)
*
pduy_8 = -pdsinalm2_8 * pduym_8 * pdsinal_8 * rxyzm_8
% -pdsinalm2_8 * F_y(n)
*
pduz_8 = -pdsinalm2_8 * pduzm_8 * pdsinal_8 * rxyzm_8
% -pdsinalm2_8 * F_z(n)
*
pdsinal_8 = pdsinal_8 * rsxyzm_8(i,j)
*
F_u(n) = -F_dt* ysinm_8(i,j)* F_um(n)*pdcosal_8/ suv2m_8(i,j) + F_u(n)
F_v(n) = -F_dt* ysinm_8(i,j)* F_vm(n)*pdcosal_8/ suv2m_8(i,j) + F_v(n)
F_u(n) = F_dt* pdcosalm_8 * F_um(n)*pdsinal_8/ suv2m_8(i,j) + F_u(n)
F_v(n) = F_dt* pdcosalm_8 * F_vm(n)*pdsinal_8/ suv2m_8(i,j) + F_v(n)
*
* ADJ
* ---
pdsinal_8 = - pdx_8 * pdux_8 - pdy_8 * pduy_8 - pdz_8 * pduz_8
*
pdux_8 = pdx_8 * pdsinal_8 + pdux_8
pduy_8 = pdy_8 * pdsinal_8 + pduy_8
pduz_8 = pdz_8 * pdsinal_8 + pduz_8
*
************************************************************************
* ADJ of
* wind components in cartesian coordinate at upwind positions *
************************************************************************
F_u(n) = - pdux_8 * pdsom_8
% + pduy_8 * pdcom_8 + F_u(n)
F_v(n) = - pdux_8 * pdcom_8 * pdsam_8
% - pduy_8 * pdsom_8 * pdsam_8
% + pduz_8 * pdcam_8 + F_v(n)
*
pdco_8 = - F_vm(n) *( pdux_8 * pdsam_8 )
% + F_um(n) * pduy_8
F_x(n) = pdco_8 * pdcaim_8
*
pdso_8 = - F_um(n) * pdux_8
% - F_vm(n) *( pduy_8 * pdsam_8 )
F_y(n) = pdso_8 * pdcaim_8
*
************************************************************************
* ADJ of
* sin and cosin of first guess of upwind positions *
************************************************************************
pdcai_8 = F_ym1(n) * pdso_8 +
% F_xm1(n) * pdco_8
F_lat(n)= -slam_8(i,j) * (-pdcai_8 * rcos2m_8(i,j) + F_vm(n) * pduz_8)
*
F_z(n) = - F_vm(n) *( pdcom_8 * pdux_8 )
% - F_vm(n) *( pdsom_8 * pduy_8 )
*
else
*
* -------------
* NOTHING TO DO
* -------------
*
endif
*
enddo
enddo
*
enddo
!$omp end parallel do
*
return
end