!-------------------------------------- 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_main_2_pos - calculate upstream positions at th and t1
*
#include "model_macros_f.h"
*
subroutine adw_main_2_pos ( F_it, F_u, F_v, F_w ) 1,28
*
implicit none
*
integer F_it
real F_u(*),F_v(*),F_w(*)
*
*author
* alain patoine
*
*revision
* v2_31 - Desgagne M. - removed stkmemw
* v2_31 - Tanguay M. - gem_stop if Adw_fro_a.gt.0.and.V4dg_conf.ne.0
* v3_00 - Desgagne & Lee - Lam configuration
* v3_02 - Lee V. - revert adw_exch_1 for GLB only, added adw_ckbd_lam
* v3_10 - Corbeil & Desgagne & Lee - AIXport+Opti+OpenMP
* v3_20 - Valin & Tanguay - Optimized SETINT/TRILIN
* v3_20 - Gravel S. - Change test a lower and upper boundaries
* v3_20 - Tanguay M. - Improve alarm when points outside advection grid
* v3_20 - Dugas B. - correct calculation for LAM when Glb_pil gt 7
* v3_21 - Lee V. - bug correction, yth should not be modified.
* v3_31 - Desgagne M. - new scope for operator + adw_cliptraj (LAM)
* v3_31 - Tanguay M. - Do adjoint of outsiders in advection
* v3_31 - Tanguay M. - SETTLS option
*
*language
* fortran 77
*
*object
* see id section
*
*arguments
*______________________________________________________________________
* | | |
* NAME | DESCRIPTION | I/O |
*--------|-------------------------------------------------------|-----|
* F_it | total number of iterations for trajectory | i |
* | | |
* F_u,F_v| input: 3 components of wind on advection grid | io |
* F_w | output: 3 components of upstream positions at t1 | |
*________|_______________________________________________________|_____|
*
*implicits
#include "glb_ld.cdk"
#include "glb_pil.cdk"
#include "lun.cdk"
#include "geomg.cdk"
#include "adw.cdk"
#include "dcst.cdk"
#include "cstv.cdk"
#include "vth.cdk"
#include "vt1.cdk"
#include "v4dg.cdk"
#include "lctl.cdk"
#include "step.cdk"
#include "orh.cdk"
#include "schm.cdk"
#include "ptopo.cdk"
*
*modules
integer vmmlod, vmmget, vmmuld
external vmmlod, vmmget, vmmuld
************************************************************************
logical doh
*
integer pnerr, pnlkey1(30), pnlod
*
integer i, j, k, n, ij, ijk, nij, nijk, it
integer i1,j1,k1,nn
*
integer outside,sum_outside,ier
*
integer, dimension(l_ni*l_nj*l_nk) :: n1
real, dimension(l_ni*l_nj*l_nk) :: capx1,capy1,capz1
real, dimension(l_ni*l_nj*l_nk) :: wrkx1,wrky1,wrkz1,wrkc1,wrk_yth,zt1_w1,zt1_w2
integer, dimension(:), allocatable :: n2
real, dimension(:), allocatable :: capx2,capy2,capz2
real, dimension(:), allocatable :: xpos2,ypos2,zpos2
*
real dummy, dth
real*8 r2pi_8,two,half,pdp,pdm
parameter (two = 2.0,half=0.5)
integer i0,in,j0,jn
*
logical done_once_L,step2_settls_L
save done_once_L
data done_once_L /.false./
*
************************************************************************
if (Lun_debug_L) write (Lun_out,1000)
*
step2_settls_L = Schm_settls_L.and.Orh_crank_L.and.Orh_icn.eq.Schm_itcn
*
nij = l_ni *l_nj
nijk = l_ni *l_nj *l_nk
*
r2pi_8 = two * Dcst_pi_8
dth = Cstv_dt_8/2.
pdp = 1.d0 + 1.d-6
pdm = 1.d0 - 1.d-6
************************************************************************
*
pnlkey1(1) = VMM_KEY(xth)
pnlkey1(2) = VMM_KEY(yth)
pnlkey1(3) = VMM_KEY(zth)
pnlkey1(4) = VMM_KEY(xcth)
pnlkey1(5) = VMM_KEY(ycth)
pnlkey1(6) = VMM_KEY(zcth)
pnlkey1(7) = VMM_KEY(xct1)
pnlkey1(8) = VMM_KEY(yct1)
pnlkey1(9) = VMM_KEY(zct1)
pnlod = 9
if (step2_settls_L) then
pnlkey1(pnlod+1) = VMM_KEY(xt1)
pnlkey1(pnlod+2) = VMM_KEY(yt1)
pnlkey1(pnlod+3) = VMM_KEY(zt1)
pnlod = pnlod+3
endif
*
pnerr = vmmlod(pnlkey1,pnlod)
*
pnerr = VMM_GET_VAR(xth)
pnerr = VMM_GET_VAR(yth)
pnerr = VMM_GET_VAR(zth)
pnerr = VMM_GET_VAR(xcth)
pnerr = VMM_GET_VAR(ycth)
pnerr = VMM_GET_VAR(zcth)
pnerr = VMM_GET_VAR(xct1)
pnerr = VMM_GET_VAR(yct1)
pnerr = VMM_GET_VAR(zct1)
if (step2_settls_L) then
pnerr = VMM_GET_VAR(xt1)
pnerr = VMM_GET_VAR(yt1)
pnerr = VMM_GET_VAR(zt1)
endif
*
i0=1
in=l_ni
j0=1
jn=l_nj
if (G_lam) then
if (l_west) i0=pil_w
if (l_east) in=l_niu - pil_e + 2
if (l_south) j0=pil_s
if (l_north) jn=l_njv - pil_n + 2
endif
c if (Acid_test_L)
c % call glbstat (xth,'Xth',1,l_ni,1,l_nj,G_nk,4+acid_i0,G_ni-3-acid_in,
c % 4+acid_j0,G_nj-3-acid_jn,1,1)
c call glbstat (xcth,'Xcth',1,l_ni,1,l_nj,G_nk,5+acid_i0,G_ni-4-acid_in,
c % 5+acid_j0,G_nj-4-acid_jn,1,1)
c endif
************************************************************************
do it=1,F_it
************************************************************************
doh = .false.
if (it .eq. 1) doh = .true.
*
do n = 1,nijk
wrk_yth(n) = yth(n)
enddo
if (G_lam) then
*
call adw_cliptraj ( xth, wrk_yth, i0, in, j0, jn, 'IN1POS' )
*
else
*
call adw_exch_1 ( wrkx1, wrky1, wrkz1, wrkc1,xth,wrk_yth,zth )
*
if ( V4dg_conf.ne.0.0 ) then
*
outside = 0
*
if ( Adw_fro_a .gt. 0 ) outside = 1
*
sum_outside = 0
call rpn_comm_Allreduce(outside,sum_outside,1,"MPI_INTEGER",
$ "MPI_SUM","grid",ier)
*
if(sum_outside.ne.0.and..not.done_once_L.and.Ptopo_myproc.eq.0) then
write(Lun_out,*) 'NUMBER OF PE WITH OUTSIDERS IN ADW_MAIN_2_POS AT current TIME-CN-IT = ',sum_outside
call flush(Lun_out)
endif
*
endif
*
allocate(capx2(max(1,Adw_fro_a)),
% capy2(max(1,Adw_fro_a)),
% capz2(max(1,Adw_fro_a)),
% xpos2 (max(1,Adw_fro_a)),
% ypos2 (max(1,Adw_fro_a)),
% zpos2 (max(1,Adw_fro_a)),
% n2 (max(1,Adw_fro_a)) )
call adw_exch_2 ( xpos2, ypos2, zpos2,
% wrkx1, wrky1, wrkz1,
% Adw_fro_n, Adw_fro_s, Adw_fro_a,
% Adw_for_n, Adw_for_s, Adw_for_a, 3 )
*
endif
*
if( .not. Adw_nosetint_L ) then
*
call adw_setint ( n1, capx1, dummy, dummy, capy1, dummy,
% dummy, capz1, dummy, xth, wrk_yth, zth,
% doh, .true., .true.,nijk,i0,in,j0,jn,l_nk)
*
call adw_trilin (wrkx1,F_u,1.0,n1,capx1,capy1,capz1,nijk,i0,in,j0,jn,l_nk)
call adw_trilin (wrky1,F_v,1.0,n1,capx1,capy1,capz1,nijk,i0,in,j0,jn,l_nk)
*
else
*
Adw_hor_L = doh
Adw_ver_L = .true.
call adw_trilin_turbo (wrkx1,F_u,1.0,xth,wrk_yth,zth,capz1,
% Adw_Fn_I,nijk,i0,in,j0,jn,l_nk)
call adw_trilin_turbo (wrky1,F_v,1.0,xth,wrk_yth,zth,capz1,
% Adw_Fn_I,nijk,i0,in,j0,jn,l_nk)
*
endif
c if (Acid_test_L)
c %call glbstat (wrkx1,'wrkX',1,l_ni,1,l_nj,G_nk,4+acid_i0,G_ni-3-acid_in,
c % 4+acid_j0,G_nj-3-acid_jn,1,G_nk)
*
if (.not.G_lam) then
if ( Adw_fro_a .gt. 0 ) then
*
*
if ( Adw_ckbd_L ) call adw_ckbd ( ypos2 )
*
call adw_setint ( n2, capx2, dummy, dummy, capy2, dummy,
% dummy, capz2, dummy, xpos2, ypos2, zpos2,
% .true., .true., .true., Adw_fro_a,1,Adw_fro_a,1,1,1)
*
call adw_trilin ( xpos2, F_u, 1.0, n2, capx2, capy2, capz2,
% Adw_fro_a,1,Adw_fro_a,1,1,1)
call adw_trilin ( ypos2, F_v, 1.0, n2, capx2, capy2, capz2,
% Adw_fro_a,1,Adw_fro_a,1,1,1)
*
endif
*
call adw_exch_2 ( wrkz1, wrk_yth, dummy,
% xpos2, ypos2, dummy,
% Adw_for_n, Adw_for_s, Adw_for_a,
% Adw_fro_n, Adw_fro_s, Adw_fro_a, 2)
*
if ( Adw_for_a .gt. 0 )
% call adw_exch_3 ( wrkx1, wrky1, wrkz1, wrk_yth, wrkc1, 2 )
*
deallocate(capx2,capy2,capz2,xpos2,ypos2,zpos2,n2)
endif
************************************************************************
call adw_trajsp ( xth, yth, xcth, ycth, zcth, wrkx1, wrky1, dth,
% i0,in,j0,jn)
************************************************************************
do n = 1,nijk
wrk_yth(n) = yth(n)
enddo
c if (Acid_test_L)
c call glbstat (xth,'Xth',1,l_ni,1,l_nj,G_nk,4+acid_i0,G_ni-3-acid_in,
c % 4+acid_in,G_nj-3-acid_jn,1,1)
c call glbstat (xcth,'Xcth',1,l_ni,1,l_nj,G_nk,5+acid_i0,G_ni-4-acid_in,
c % 5+acid_in,G_nj-4-acid_jn,1,1)
*
if (G_lam) then
*
call adw_cliptraj ( xth, wrk_yth, i0, in, j0, jn, 'IN2POS' )
*
else
*
call adw_exch_1 ( wrkx1, wrky1, wrkz1, wrkc1,xth,wrk_yth,zth )
*
allocate(capx2(max(1,Adw_fro_a)),
% capy2(max(1,Adw_fro_a)),
% capz2(max(1,Adw_fro_a)),
% xpos2 (max(1,Adw_fro_a)),
% ypos2 (max(1,Adw_fro_a)),
% zpos2 (max(1,Adw_fro_a)),
% n2 (max(1,Adw_fro_a)) )
*
call adw_exch_2 ( xpos2, ypos2, zpos2,
% wrkx1, wrky1, wrkz1,
% Adw_fro_n, Adw_fro_s, Adw_fro_a,
% Adw_for_n, Adw_for_s, Adw_for_a, 3 )
*
endif
*
if( .not. Adw_nosetint_L ) then
*
call adw_setint ( n1, capx1, dummy, dummy, capy1, dummy,
% dummy, capz1, dummy, xth, wrk_yth, zth,
% .true., .false., .true., nijk,i0,in,j0,jn,l_nk)
*
call adw_trilin (wrkx1,F_w,-dth,n1,capx1,capy1,capz1,nijk,i0,in,j0,jn,l_nk)
*
else
*
Adw_hor_L = .true.
Adw_ver_L = .false.
call adw_trilin_turbo (wrkx1,F_w,-dth,xth,wrk_yth,zth,capz1,
% Adw_Fn_I,nijk,i0,in,j0,jn,l_nk)
*
endif
*
if (.not.G_lam) then
if ( Adw_fro_a .gt. 0 ) then
*
if ( Adw_ckbd_L ) call adw_ckbd ( ypos2 )
*
call adw_setint ( n2, capx2, dummy, dummy, capy2, dummy,
% dummy, capz2, dummy, xpos2, ypos2, zpos2,
% .true., .true., .true., Adw_fro_a,1,Adw_fro_a,1,1,1)
*
call adw_trilin ( xpos2, F_w, -dth, n2, capx2,capy2,capz2,
% Adw_fro_a,1,Adw_fro_a,1,1,1)
*
endif
*
call adw_exch_2 ( wrkz1, dummy, dummy,
% xpos2, dummy, dummy,
% Adw_for_n, Adw_for_s, Adw_for_a,
% Adw_fro_n, Adw_fro_s, Adw_fro_a, 1)
*
if ( Adw_for_a .gt. 0 )
% call adw_exch_3 ( wrkx1, dummy, wrkz1, dummy, wrkc1, 1 )
*
deallocate(capx2,capy2,capz2,xpos2,ypos2,zpos2,n2)
endif
************************************************************************
*
!$omp parallel private(n)
!$omp do
do k = 2,l_nk-1
do j = j0,jn
do i = i0,in
n = (k-1)*nij + ((j-1)*l_ni) + i
zth(n) = Geomg_z_8(k) + two*wrkx1(n)
zth(n) = min( pdm*Geomg_z_8(l_nk),
% max( 1.0d0*zth(n), pdp*Geomg_z_8(1) ) )
zth(n) = half*(zth(n) + Geomg_z_8(k))
enddo
enddo
enddo
!$omp enddo
!$omp end parallel
************************************************************************
enddo ! end of iterations loop
************************************************************************
call adw_trajex (F_u, F_v, xct1, yct1, zct1, xcth, ycth, zcth,
% i0,in,j0,jn)
*
* Keep xt1,yt1,zt1 positions (used in adw_main_2_int_settls_sw at next timesteps)
* -------------------------------------------------------------------------------
if (step2_settls_L) then
*
do i=1,l_ni*l_nj*l_nk
xt1(i) = F_u(i)
yt1(i) = F_v(i)
enddo
*
k = 1
do j = 1, l_nj
do i = 1, l_ni
ijk=(k-1)*nij+(j-1)*l_ni+i
zt1(ijk) = Geomg_z_8(k)
enddo
enddo
*
k = l_nk
do j = 1, l_nj
do i = 1, l_ni
ijk=(k-1)*nij+(j-1)*l_ni+i
zt1(ijk) = Geomg_z_8(k)
enddo
enddo
*
zt1_w1 = zt1
*
!$omp parallel private(n)
!$omp do
do k = 2,l_nk-1
do j = j0,jn
do i = i0,in
n = (k-1)*nij + ((j-1)*l_ni) + i
zt1(n) = Geomg_z_8(k) + two*wrkx1(n)
zt1_w1(n) = Geomg_z_8(k) + two*wrkx1(n)
zt1(n) = min( pdm*Geomg_z_8(l_nk),
% max( 1.0d0*zt1(n), pdp*Geomg_z_8(1) ) )
enddo
enddo
enddo
!$omp enddo
!$omp end parallel
*
if ( V4dg_conf.ne.0 .and. V4dg_oktr_L ) then
*
zt1_w2 = zt1
zt1 = zt1_w1
*
* Store TRAJ ZT1 mid-calculation
* ------------------------------
call v4d_rwtraj (17)
*
zt1 = zt1_w2
*
endif
*
endif
*
!$omp parallel private(n)
!$omp do
do j = j0,jn
do i = i0,in
n = ((j-1)*l_ni) + i !for k=1
F_w(n) = Geomg_z_8(1)
n = (l_nk-1)*nij+((j-1)*l_ni) + i !for k=l_nk
F_w(n) = Geomg_z_8(l_nk)
enddo
enddo
!$omp enddo
!$omp do
do k = 2,l_nk-1
do j = j0,jn
do i = i0,in
n=(k-1)*nij+((j-1)*l_ni) + i
F_w(n) = zth(n) - Geomg_z_8(k)
F_w(n) = Geomg_z_8(k) + 2.0 * F_w(n)
enddo
enddo
enddo
!$omp enddo
!$omp end parallel
*
pnerr = vmmuld(-1,0)
*
if (V4dg_conf.ne.0.and.Lctl_step.eq.Step_total.and.Orh_icn.eq.Schm_itcn) done_once_L = .true.
*
1000 format(3X,'CALC UPSTREAM POSITIONS: (S/R ADW_MAIN_2_POS)')
return
end