!-------------------------------------- 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_trajex_tl - TLM of adw_trajex
*
#include "model_macros_f.h"
*
subroutine adw_trajex_tl ( F_xto, F_yto, F_xcto, F_ycto, 3
% F_zcto, F_xctm, F_yctm, F_zctm,
% F_xto_m, F_yto_m, F_xcto_m,F_ycto_m,
% F_zcto_m,F_xctm_m,F_yctm_m,F_zctm_m,i0,in,j0,jn)
*
implicit none
*
real F_xto (*), F_yto (*), F_xcto(*), F_ycto(*),
% F_zcto(*), F_xctm(*), F_yctm(*), F_zctm(*)
*
real F_xto_m (*), F_yto_m (*), F_xcto_m(*), F_ycto_m(*),
% F_zcto_m(*), F_xctm_m(*), F_yctm_m(*), F_zctm_m(*)
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_01 - Tanguay M. - correction minmax_m = +-1
* v3_11 - Tanguay M. - AIXport+Opti+OpenMP for TLM-ADJ
*
*language
* fortran 77
*
*object
* see id section
*
*arguments
*______________________________________________________________________
* | | |
* NAME | DESCRIPTION | I/O |
*--------------|-------------------------------------------------|-----|
* | | |
* F_xto | upstream x positions at origin | o |
* F_yto | upstream y positions at origin | o |
* F_xcto | upstream x cartesian positions at origin | o |
* F_ycto | upstream y cartesian positions at origin | o |
* F_zcto | upstream z cartesian positions at origin | o |
* F_xctm | upstream x cartesian positions at mid-traj. | i |
* F_yctm | upstream y cartesian positions at mid-traj. | i |
* F_zctm | upstream z cartesian positions at mid-traj. | i |
*______________|_________________________________________________|_____|
*
*implicits
#include "glb_ld.cdk"
#include "adw.cdk"
#include "dcst.cdk"
*
************************************************************************
integer i, j, k, n, ij, nij, vnij
*
real*8 prx_8, pry_8, prz_8, prdot2_8, r2pi_8, prdot2m_8, TWO_8
*
real minmax, minmax_m, nodiv0_m
*
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 sminm_8 (i0:in,j0:jn), rsminm_8(i0:in,j0:jn)
real*8 xym_8 (i0:in,j0:jn), rxym_8 (i0:in,j0:jn)
*
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 private(n,ij,i,j,k,
!$omp& prx_8,pry_8,prz_8,prdot2_8,prdot2m_8,
!$omp& minmax, minmax_m, nodiv0_m,
!$omp& sminm_8,rsminm_8,xasinm_8,yasinm_8,
!$omp$ xatanm_8,yatanm_8,zatanm_8,xym_8,rxym_8)
!$omp do
do k=1,l_nk
*
do j=j0,jn
do i=i0,in
n = (k-1)*nij+((j-1)*l_ni) + i
*
ij = mod( n-1, nij ) + 1
*
pry_8 = dble(Adw_cy2d_8(ij))
prx_8 = dble(Adw_cx2d_8(ij)) * pry_8
pry_8 = dble(Adw_sx2d_8(ij)) * pry_8
prz_8 = dble(Adw_sy2d_8(ij))
*
* TRAJECTORY
* ----------
prdot2m_8= 2.0 * ( prx_8 * dble(F_xctm_m(n)) +
% pry_8 * dble(F_yctm_m(n)) +
% prz_8 * dble(F_zctm_m(n)) )
*
F_xcto_m(n) = prdot2m_8 * dble(F_xctm_m(n)) - prx_8
F_ycto_m(n) = prdot2m_8 * dble(F_yctm_m(n)) - pry_8
F_zcto_m(n) = prdot2m_8 * dble(F_zctm_m(n)) - prz_8
*
xym_8(i,j) = F_xcto_m(n)*F_xcto_m(n) + F_ycto_m(n)*F_ycto_m(n)
*
xatanm_8(i,j)= F_xcto_m(n)
yatanm_8(i,j)= F_ycto_m(n)
xasinm_8(i,j)= max(-1.,min(1.,F_zcto_m(n)))
*
* TLM
* ---
prdot2_8= 2.0 * ( prx_8 * dble(F_xctm(n)) +
% pry_8 * dble(F_yctm(n)) +
% prz_8 * dble(F_zctm(n)) )
*
F_xcto(n) = prdot2m_8 * dble(F_xctm(n)) + prdot2_8 * dble(F_xctm_m(n))
F_ycto(n) = prdot2m_8 * dble(F_yctm(n)) + prdot2_8 * dble(F_yctm_m(n))
F_zcto(n) = prdot2m_8 * dble(F_zctm(n)) + prdot2_8 * dble(F_zctm_m(n))
*
* NOTE: nodiv0_m is used to allow valid 1/smin_8
* ----------------------------------------------
minmax_m = F_zcto_m(n)
nodiv0_m = minmax_m
if (F_zcto_m(n).ge.1.) then
minmax_m = 1.
nodiv0_m = 0.
elseif (F_zcto_m(n).le.-1.) then
minmax_m =-1.
nodiv0_m = 0.
endif
*
sminm_8(i,j) = sqrt( 1.0-nodiv0_m*nodiv0_m )
*
enddo
enddo
*
* Pre-calculations
* ----------------
call vatan2(zatanm_8, yatanm_8, xatanm_8, vnij)
call vasin (yasinm_8, xasinm_8, vnij)
call vrec (rxym_8, xym_8, vnij)
call vrec (rsminm_8, sminm_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
*
F_xto_m(n) = zatanm_8(i,j)
F_yto_m(n) = yasinm_8(i,j)
*
F_xto(n) = (F_ycto(n)*F_xcto_m(n) - F_ycto_m(n)*F_xcto(n)) * rxym_8(i,j)
*
if ( F_xto_m(n) .lt. 0.0 ) F_xto_m(n) = F_xto_m(n) + r2pi_8
*
* The following min statement is expanded as two IF blocks:
* minmax_m = max(-1.,min(1.,F_zcto_m(n)))
*
minmax = F_zcto(n)
if (F_zcto_m(n).ge.1.) then
minmax = 0.
F_yto(n) = 0.
elseif (F_zcto_m(n).le.-1.) then
minmax = 0.
F_yto(n) = 0.
else
F_yto(n) = minmax * rsminm_8(i,j)
endif
*
enddo
enddo
*
enddo
!$omp enddo
!$omp end parallel
*
return
end