!-------------------------------------- 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_tl - TLM of adw_trajsp
*
#include "model_macros_f.h"
*
subroutine adw_trajsp_tl ( F_lon, F_lat, F_x, F_y, F_z, F_u, F_v, 2
% F_lonm,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_lonm(*),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
*
*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
*
real*8 pdsam_8, pdcam_8, pdcaim_8, pdsom_8, pdcom_8,
% pduxm_8, pduym_8, pduzm_8, pdcosalm_8,
% pduxm1_8,pduym1_8,pduzm1_8, pdsinalm1_8,pdsinalm2_8
*
real*8 rsxyzm_8, 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*8 xasinm_8(i0:in,j0:jn), yasinm_8(i0:in,j0:jn)
real*8 xatanm_8(i0:in,j0:jn), yatanm_8(i0:in,j0:jn), zatanm_8(i0:in,j0:jn)
*
real *8 r2pi_8, TWO_8
parameter (TWO_8 = 2.0)
************************************************************************
nij = l_ni*l_nj
vnij = (in-i0+1)*(jn-j0+1)
*
r2pi_8 = TWO_8 * Dcst_pi_8
************************************************************************
*
!$omp parallel do private (n,ij,xcosm_8,ycosm_8,xsinm_8,ysinm_8,yrecm_8,
!$omp% cos2m_8,suv2m_8,sz2m_8,xy2m_8,slam_8,rcos2m_8,
!$omp% rxy2m_8,xasinm_8,yasinm_8,xatanm_8,yatanm_8,
!$omp% zatanm_8,pdsa_8,pdca_8,pdcai_8,pdso_8,pdco_8,pdx_8,
!$omp% pdy_8,pdz_8,pdux_8,pduy_8,pduz_8,pdsinal_8,pdcosal_8,
!$omp% pdsam_8,pdcam_8,pdcaim_8,pdsom_8,pdcom_8,pduxm_8,pduym_8,
!$omp% pduzm_8,pdcosalm_8,pduxm1_8,pduym1_8,pduzm1_8,pdsinalm1_8,
!$omp% pdsinalm2_8,rsxyzm_8,rxyzm_8)
*
do k=1,l_nk
*
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 vsin(slam_8, xcosm_8, vnij)
call vrec(yrecm_8, ycosm_8, vnij)
*
do j=j0,jn
do i=i0,in
cos2m_8(i,j) = ycosm_8(i,j) **2
end do
end do
*
call vrec(rcos2m_8, cos2m_8, vnij)
*
do j=j0,jn
do i=i0,in
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 *
************************************************************************
* TRAJECTORY
* ----------
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
*
* TLM
* ---
pdsa_8 = F_z(n)
pdca_8 = -slam_8(i,j) * F_lat(n)
pdcai_8 = -pdca_8 * rcos2m_8(i,j)
pdso_8 = F_ym(n) * pdcai_8 + F_y(n) * pdcaim_8
pdco_8 = F_xm(n) * pdcai_8 + F_x(n) * pdcaim_8
*
************************************************************************
* wind components in cartesian coordinate at upwind positions *
************************************************************************
* TRAJECTORY
* ----------
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
*
* TLM
* ---
pdux_8 = - F_um(n) * pdso_8 - F_vm(n) * ( pdcom_8 * pdsa_8 + pdco_8 * pdsam_8)
% - F_u (n) * pdsom_8 - F_v (n) * pdcom_8 * pdsam_8
pduy_8 = F_um(n) * pdco_8 - F_vm(n) * ( pdsom_8 * pdsa_8 + pdso_8 * pdsam_8)
% + F_u (n) * pdcom_8 - F_v (n) * pdsom_8 * pdsam_8
pduz_8 = F_vm(n) * pdca_8 + F_v(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
*
rsxyzm_8 = 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
*
rxyzm_8 = 1./( pduxm_8 * pduxm_8 + pduym_8 * pduym_8 + pduzm_8 * pduzm_8 )
*
* TLM
* ---
pdsinal_8 = pdx_8 * pdux_8 + pdy_8 * pduy_8 + pdz_8 * pduz_8
pdux_8 = pdux_8 - pdx_8 * pdsinal_8
pduy_8 = pduy_8 - pdy_8 * pdsinal_8
pduz_8 = pduz_8 - pdz_8 * pdsinal_8
*
pdsinal_8 = F_dt*pdcosalm_8 *(F_um(n)*F_u(n)+F_vm(n)*F_v(n))/suv2m_8(i,j)
pdcosal_8 = -F_dt*ysinm_8(i,j)*(F_um(n)*F_u(n)+F_vm(n)*F_v(n))/suv2m_8(i,j)
pdsinal_8 =
% pdsinal_8 * rsxyzm_8
% - pdsinalm2_8 * ( pduxm_8 * pdux_8 + pduym_8 * pduy_8 + pduzm_8 * pduz_8 ) * rxyzm_8
*
* TRAJECTORY
* ----------
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
*
* TLM
* ---
F_x(n) = pdcosal_8 * pdx_8 - pdsinal_8 * pduxm_8 - pdsinalm2_8 * pdux_8
F_y(n) = pdcosal_8 * pdy_8 - pdsinal_8 * pduym_8 - pdsinalm2_8 * pduy_8
F_z(n) = pdcosal_8 * pdz_8 - pdsinal_8 * pduzm_8 - pdsinalm2_8 * pduz_8
*
endif
*
* TRAJECTORY + TLM
* ----------------
* Replace the following line by two IF blocks:
* F_zm(n) = min(1.0D0,max(F_zm(n),-1.0D0))
*
if ( F_zm(n) .lt. -1.0D0 ) then
F_zm(n) = -1.0D0
F_z (n) = 0.0D0
elseif ( F_zm(n) .gt. 1.0D0 ) then
F_zm(n) = 1.0D0
F_z (n) = 0.0D0
endif
*
xasinm_8(i,j) = F_zm(n)
xatanm_8(i,j) = F_xm(n)
yatanm_8(i,j) = F_ym(n)
sz2m_8 (i,j) = sqrt(1.0 - F_zm(n)*F_zm(n))
xy2m_8 (i,j) = F_xm(n)*F_xm(n) + F_ym(n)*F_ym(n)
*
enddo
enddo
*
call vasin ( yasinm_8, xasinm_8, vnij )
call vatan2 ( zatanm_8, yatanm_8, xatanm_8, vnij )
call vrec ( rxy2m_8, xy2m_8, vnij )
*
do j=j0,jn
do i=i0,in
n = (k-1)*nij + ((j-1)*l_ni) + i
*
* TRAJECTORY
* ----------
F_latm(n) = yasinm_8(i,j)
F_lonm(n) = zatanm_8(i,j)
*
* TLM
* ---
if ( abs(F_zm(n)) .ne. 1.0D0 ) then
F_lat(n) = F_z(n) / sz2m_8(i,j)
else
F_lat(n) = 0.0D0
endif
F_lon(n) = (F_xm(n)*F_y (n) - F_ym(n)*F_x (n)) * rxy2m_8(i,j)
*
* TRAJECTORY + TLM
* ----------------
if ( F_lonm(n) .lt. 0.0 ) F_lonm(n) = F_lonm(n) + r2pi_8
end do
end do
*
enddo
!$omp end parallel do
*
return
end