!-------------------------------------- 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 hzd_del2_ad - ADJ of hzd_del2
*
#include "model_macros_f.h"
*
subroutine hzd_del2_ad (F_sol, F_rhs_8, F_opsxp0_8, F_opsyp0_8, 26
$ F_aix_8,F_bix_8,F_cix_8,F_dix_8,
$ F_aiy_8,F_biy_8,F_ciy_8,F_g1_8,F_g2_8,
$ DIST_DIM,Nk, Gni,Gnj, lnjs_nh,
$ nk12s, nk12, ni22s, ni22, fnjb)
*
implicit none
*
integer DIST_DIM, Nk, Gni, Gnj, lnjs_nh,
$ nk12s, nk12, ni22s, ni22, fnjb
*
*
real F_sol(DIST_SHAPE,Nk)
real*8 F_rhs_8,F_opsxp0_8(*),F_opsyp0_8(*),
$ F_aix_8(lnjs_nh,Gni),F_bix_8(lnjs_nh,Gni),
$ F_cix_8(lnjs_nh,Gni),F_dix_8(lnjs_nh,Gni),
$ F_aiy_8(ni22s,Gnj),F_biy_8(ni22s,Gnj),F_ciy_8(ni22s,Gnj),
$ F_g1_8(PYDIST_SHAPE,nk12s,*),F_g2_8(nk12s,ni22s,*)
*
*author
* M.Tanguay
*
*revision
* v2_10 - Tanguay M. - initial MPI version
* v2_21 - Tanguay M. - remove vertical modulation
* v2_31 - Tanguay M. - adapt to f90 native dynamic memory allocation
* v3_11 - Tanguay M. - AIXport+Opti+OpenMP for TLM-ADJ
*
*object
* see id section
*
*arguments
* Name I/O Description
*----------------------------------------------------------------
* F_sol I/O result
* F_rhs_8 I/O r.h.s. of horizontal diffusion equation
*
*----------------------------------------------------------------
*
*implicit
#include "glb_ld.cdk"
#include "ptopo.cdk"
*
integer i, j, k, cnt, dim, k0, kn, k1, klon, ktotal
real*8 g1_8(nk12*l_nj,Gni), ax_8(nk12*l_nj,Gni), cx_8(nk12*l_nj,Gni),
$ g2_8(nk12*ni22,Gnj), ay_8(nk12*ni22,Gnj), cy_8(nk12*ni22,Gnj)
*
real*8 ZERO_8
parameter (ZERO_8=0.0)
integer cntmax
**
* __________________________________________________________________
*
!$omp parallel
*
* Zero adjoint variables
* ----------------------
dim = nk12*l_nj*Gni
*
!$omp do
do i = 1,dim
g1_8(i,1) = ZERO_8
enddo
!$omp enddo
*
dim = nk12*ni22*Gnj
*
!$omp do
do i = 1,dim
g2_8(i,1) = ZERO_8
enddo
!$omp enddo
*
!$omp end parallel
*
call rpn_comm_transpose48 ( F_sol , Minx, Maxx, Gni,1, ARRAY1DY,
% ARRAY1DY, 1, nk12s, Nk , F_g1_8, 1
% ,1.0d0,0.d0)
*
call rpn_comm_transpose ( F_g1_8, Miny, Maxy, Gnj, nk12s,
% 1, ni22s, Gni, F_g2_8, 2, 2 )
*
!$omp parallel
*
* ----------------
* START TRAJECTORY
* ----------------
*
* ___ Calcul le long de Y
*
!$omp do
do j = 1, fnjb
do k = 1, nk12
do i = 1, ni22
cnt = k + (i-1)*nk12
ay_8 (cnt,j) = F_aiy_8(i,j)
cy_8 (cnt,j) = F_ciy_8(i,j)
enddo
enddo
enddo
!$omp enddo
*
cntmax= ni22*nk12
*
* --------------
* END TRAJECTORY
* --------------
*
* ADJ of
* ___ Calcul le long de Y
*
!$omp do
do j = fnjb,1,-1
cnt = cntmax + 1
do i = ni22,1,-1
do k = nk12,1,-1
cnt = cnt - 1
g2_8(cnt,j) = F_g2_8(k,i,j) + g2_8(cnt,j)
F_g2_8(k,i,j) = ZERO_8
end do
enddo
enddo
!$omp enddo
*
ktotal= ni22*nk12
klon = (ktotal+Ptopo_npeOpenMP)/Ptopo_npeOpenMP
*
!$omp do
do k1=1,Ptopo_npeOpenMP
k0=1+klon*(k1-1)
kn=min(ktotal,klon*k1)
*
do j = 1,fnjb-1
do k = kn,k0,-1
g2_8(k,j+1) = - cy_8(k,j)*g2_8(k,j) + g2_8(k,j+1)
end do
end do
*
do j = fnjb,2,-1
do k = kn,k0,-1
g2_8(k,j-1) = - ay_8(k,j)*g2_8(k,j) + g2_8(k,j-1)
end do
end do
*
enddo
!$omp enddo
*
!$omp do
do j = fnjb,1,-1
do k = nk12,1,-1
do i = ni22,1,-1
cnt = k + (i-1)*nk12
F_g2_8(k,i,j) = F_biy_8(i,j)*F_opsyp0_8(j)*g2_8(cnt,j) + F_g2_8(k,i,j)
g2_8(cnt,j) = ZERO_8
enddo
enddo
enddo
!$omp end do
*
!$omp single
call rpn_comm_transpose ( F_g1_8, YDIST_DIM, Gnj, nk12s,
% 1, ni22s, Gni, F_g2_8, -2, 2 )
!$omp end single
*
* ----------------
* START TRAJECTORY
* ----------------
*
!$omp do
do i = 1, Gni-1
cnt = 0
do j = 1, l_nj
do k = 1, nk12
cnt = cnt + 1
ax_8(cnt,i) = F_aix_8(j,i)
cx_8(cnt,i) = F_cix_8(j,i)
enddo
enddo
enddo
!$omp enddo
*
cntmax=cnt
*
* --------------
* END TRAJECTORY
* --------------
*
!$omp do
do i = Gni - 1,1,-1
do k = nk12,1,-1
do j = l_nj,1,-1
cnt = k + (j-1)*nk12
g1_8(cnt,i) = F_g1_8(j,k,i) + g1_8(cnt,i)
C F_g1_8(j,k,Gni) = F_dix_8(j,i)*F_g1_8(j,k,i) + F_g1_8(j,k,Gni)
C F_g1_8(j,k,i) = ZERO_8
enddo
enddo
enddo
!$omp enddo
*
cnt = cntmax + 1
*
!$omp do
do j = l_nj,1,-1
do k = nk12,1,-1
cnt = cnt - 1
*
do i = Gni - 1,1,-1
C g1_8(cnt,i) = F_g1_8(j,k,i) + g1_8(cnt,i)
F_g1_8(j,k,Gni) = F_dix_8(j,i)*F_g1_8(j,k,i) + F_g1_8(j,k,Gni)
F_g1_8(j,k,i) = ZERO_8
enddo
enddo
enddo
!$omp enddo
*
!$omp do
do k = nk12,1,-1
do j = l_nj,1,-1
cnt = k + (j-1)*nk12
g1_8(cnt,Gni-1) = F_aix_8(j,1 )*F_g1_8(j,k,Gni) + g1_8(cnt,Gni-1)
g1_8(cnt,1 ) = F_cix_8(j,Gni)*F_g1_8(j,k,Gni) + g1_8(cnt,1 )
g1_8(cnt,Gni ) = F_bix_8(j,Gni)*F_g1_8(j,k,Gni) + g1_8(cnt,Gni )
F_g1_8(j,k,Gni) = ZERO_8
enddo
enddo
!$omp enddo
*
ktotal= l_nj*nk12
klon = (ktotal+Ptopo_npeOpenMP)/Ptopo_npeOpenMP
*
!$omp do
do k1=1,Ptopo_npeOpenMP
k0=1+klon*(k1-1)
kn=min(ktotal,klon*k1)
*
do i = 1,Gni-2
do k = kn,k0,-1
g1_8(k,i+1) = - cx_8(k,i)*g1_8(k,i) + g1_8(k,i+1)
end do
end do
*
do i = Gni-1,2,-1
do k = kn,k0,-1
g1_8(k,i-1) = - ax_8(k,i)*g1_8(k,i) + g1_8(k,i-1)
end do
end do
end do
!$omp enddo
*
!$omp do
do i = Gni-1,1,-1
cnt = cntmax + 1
do j = l_nj,1,-1
do k = nk12,1,-1
cnt = cnt - 1
F_g1_8(j,k,i) = F_bix_8(j,i)*F_opsxp0_8(i)*g1_8(cnt,i) + F_g1_8(j,k,i)
g1_8(cnt,i) = ZERO_8
enddo
enddo
enddo
!$omp enddo
*
!$omp do
do k = nk12,1,-1
do j = l_nj,1,-1
cnt = k + (j-1)*nk12
F_g1_8(j,k,Gni) = F_opsxp0_8(Gni)*g1_8(cnt,Gni) + F_g1_8(j,k,Gni)
g1_8(cnt,Gni) = ZERO_8
enddo
enddo
!$omp enddo
!$omp end parallel
*
call rpn_comm_transpose48 ( F_sol , XDIST_DIM, Gni,1, ARRAY1DY,
% ARRAY1DY, 1, nk12s, Nk , F_g1_8, -1
% ,1.0d0,0.d0)
*
* __________________________________________________________________
return
end