!-------------------------------------- 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 sol_parite_2_ad - ADJ of sol_parite_2
*
#include "model_macros_f.h"
*
subroutine sol_parite_2_ad ( Sol, Rhs, evxevec,oddxevec, 1
$ Minx, Maxx, Miny, Maxy, njl,
$ Minz, Maxz, Nk, Nkl,
$ Gni, Gnj, Minij, Maxij, L_nij,
$ minx1, maxx1, minx2, maxx2,nx3,
$ F_npex1, F_npey1, ai, bi, ci,
$ fdg1,fdg2,fdwfft,fdg12,NSTOR,nev)
*
implicit none
*
integer F_npex1 , F_npey1
integer minx1, maxx1, minx2, maxx2,nx3
Real*8 ai(minx1:maxx1,minx2:maxx2,nx3),
$ bi(minx1:maxx1,minx2:maxx2,nx3),
$ ci(minx1:maxx1,minx2:maxx2,nx3)
*
integer Minx, Maxx, Miny, Maxy, njl,
$ Minz, Maxz, Nk , Nkl ,
$ Gni , Gnj , Minij, Maxij, L_nij,NSTOR,nev
real*8 Rhs(Minx:Maxx,Miny:Maxy,Nk), Sol(Minx:Maxx,Miny:Maxy,Nk)
real*8 evxevec(NSTOR*NSTOR),oddxevec(NSTOR*NSTOR)
real*8 fdwfft(Miny:Maxy,Minz:Maxz,Gni)
real*8 fdg1(Miny:Maxy,Minz:Maxz,Gni+F_npex1)
real*8 fdg2(Minz:Maxz,Minij:Maxij,Gnj+F_npey1)
real*8 fdg12(Miny:Maxy,Minz:Maxz,Gni)
*
*author M.Tanguay
*
*revision
* v3_02 - Tanguay M. - initial version
* v3_11 - Tanguay M. - AIXport+Opti+OpenMP for TLM-ADJ
* v3_20 - Tanguay M. - Correction OpenMP
*
*object
* see id section
*
*ADJ of
*arguments
* o - Sol - result
* i - Rhs - r.h.s. of elliptic equation
* i - ev-Xevec - Even eigenvectors
* i - odd-Xevec- Odd eigenvectors
* i - Gni - number of points in x-direction
* i - Gnj - number of points in y-direction
*
#include "ptopo.cdk"
*
integer i,k,nevi,gnii,ki0,kin,kkii,kilon,kitotal,ki,jr,j
*
real*8 ZERO_8, ONE_8
parameter( ZERO_8 = 0.0 )
parameter( ONE_8 = 1.0 )
* ___________________________________________________
*
*ADJ of
* combine even and odd parts
*
call rpn_comm_transpose( Sol, Minx, Maxx, Gni, (Maxy-Miny+1),
% Minz, Maxz, Nk, fdg1, 1, 2)
*
!$omp parallel
!$omp%
*
if( Gni.eq.(2*(Gni/2)) ) then
!$omp do
do k= 1,Nkl
do j= 1,njl
fdg12(j,k,nev) = fdg1(j,k,nev) + fdg12(j,k,nev)
fdg1 (j,k,nev) = ZERO_8
enddo
enddo
!$omp enddo
endif
*
!$omp end parallel
*
* ---------------------------------------
* This loop has to be removed from OPENMP
* but the reason is unknown
* ---------------------------------------
*
C!$omp parallel private(nevi,gnii)
*
C!$omp do
do k= Nkl,1,-1
do i= (Gni+1)/2,2,-1
gnii=Gni+2-i
nevi=nev-1+i
do j= njl,1,-1
*
fdg12(j,k,i) = fdg1(j,k,gnii) + fdg12(j,k,i)
fdg12(j,k,nevi) = -fdg1(j,k,gnii) + fdg12(j,k,nevi)
fdg1 (j,k,gnii) = ZERO_8
*
fdg12(j,k,i) = fdg1(j,k,i) + fdg12(j,k,i)
fdg12(j,k,nevi) = fdg1(j,k,i) + fdg12(j,k,nevi)
fdg1 (j,k,i) = ZERO_8
*
enddo
enddo
enddo
C!$omp enddo
*
C!$omp end parallel
*
!$omp parallel private(ki0,kin,kkii,jr)
!$omp% shared(kitotal,kilon,ai,bi,ci)
*
!$omp do
do k= 1,Nkl
do j= 1,njl
fdg12(j,k,1) = fdg1(j,k,1) + fdg12(j,k,1)
fdg1 (j,k,1) = ZERO_8
enddo
enddo
!$omp enddo
*
* ADJ of
* inverse projection ( r = x * w )
*
c call mxma8( oddxevec, NSTOR,1,
c % fdg12 (1,1,nev+1),(Maxy-Miny+1) * (Maxz-Minz+1), 1,
c % fdwfft(1,1,nev+1),(Maxy-Miny+1) * (Maxz-Minz+1), 1,
c % Gni-nev, Gni-nev, (Maxy-Miny+1) * Nkl )
*
!$omp do
do k=1,Nkl
call dgemm('N','N', (Maxy-Miny+1), Gni-nev, Gni-nev,
. 1._8, fdg12(1,k,nev+1),
. (Maxy-Miny+1)* (Maxz-Minz+1),oddxevec, NSTOR,
. 0._8, fdwfft(1,k,nev+1),
. (Maxy-Miny+1)* (Maxz-Minz+1))
enddo
!$omp enddo
*
c call mxma8( evxevec, NSTOR,1,
c % fdg12 (1,1,1), (Maxy-Miny+1) * (Maxz-Minz+1), 1,
c % fdwfft(1,1,1), (Maxy-Miny+1) * (Maxz-Minz+1), 1,
c % nev, nev, (Maxy-Miny+1) * Nkl )
*
!$omp do
do k=1,Nkl
call dgemm('N','N', (Maxy-Miny+1), nev, nev,
. 1._8, fdg12(1,k,1),
. (Maxy-Miny+1)* (Maxz-Minz+1),evxevec, NSTOR,
. 0._8, fdwfft(1,k,1),
. (Maxy-Miny+1)* (Maxz-Minz+1))
enddo
!$omp enddo
*
!$omp single
call rpn_comm_transpose
$ ( fdwfft, Miny, Maxy, Gnj, (Maxz-Minz+1),
$ Minij, Maxij, Gni, fdg2, 2, 2 )
!$omp end single
*
kitotal = (Maxz-Minz+1)*L_nij
kilon = (kitotal + Ptopo_npeOpenMP)/ Ptopo_npeOpenMP
*
!$omp do
do kkii = Ptopo_npeOpenMP,1,-1
*
ki0 = 1 + kilon*(kkii-1)
kin = min(kitotal, kilon*kkii)
*
do j = 1,Gnj-1
jr = j + 1
C do ki= (Maxz-Minz+1)*L_nij,1,-1
do ki= kin, ki0, -1
fdg2(ki,i,jr) = - ci(ki,i,j) * fdg2(ki,i,j) + fdg2(ki,i,jr)
enddo
enddo
*
do j =Gnj,2,-1
jr = j - 1
C do ki= (Maxz-Minz+1)*L_nij,1,-1
do ki= kin, ki0, -1
fdg2(ki,i,jr) = - ai(ki,i,j) * fdg2(ki,i,j) + fdg2(ki,i,jr)
fdg2(ki,i,j) = bi(ki,i,j) * fdg2(ki,i,j)
enddo
enddo
*
j =1
C do ki= (Maxz-Minz+1) *L_nij,1,-1
do ki= kin, ki0, -1
fdg2(ki,1,j) = bi(ki,1,j)*fdg2(ki,1,j)
enddo
enddo
!$omp enddo
*
!$omp single
call rpn_comm_transpose
$ ( fdwfft, Miny, Maxy, Gnj, (Maxz-Minz+1),
$ Minij, Maxij, Gni, fdg2, -2, 2 )
!$omp end single
*
* ADJ of
* projection ( wfft = x transposed * g )
*
C call mxma8( oddxevec, 1,NSTOR,
C % fdwfft(1,1,nev+1),(Maxy-Miny+1) * (Maxz-Minz+1), 1,
C % fdg12 (1,1,nev+1),(Maxy-Miny+1) * (Maxz-Minz+1), 1,
C % Gni-nev, Gni-nev, (Maxy-Miny+1) * Nkl )
*
!$omp do
do k=1,Nkl
call dgemm('N','T', (Maxy-Miny+1),Gni-nev,Gni-nev,
. 1._8, fdwfft(1,k,nev+1),
. (Maxy-Miny+1) * (Maxz-Minz+1),oddxevec, NSTOR,
. 0._8, fdg12(1,k,nev+1),
. (Maxy-Miny+1) * (Maxz-Minz+1))
enddo
!$omp end do
*
C call mxma8( evxevec, 1,NSTOR,
C % fdwfft(1,1,1), (Maxy-Miny+1) * (Maxz-Minz+1), 1,
C % fdg12 (1,1,1), (Maxy-Miny+1) * (Maxz-Minz+1), 1,
C % nev, nev, (Maxy-Miny+1) * Nkl )
*
!$omp do
do k=1,Nkl
call dgemm('N','T', (Maxy-Miny+1), nev, nev,
. 1._8, fdwfft(1,k,1),
. (Maxy-Miny+1) * (Maxz-Minz+1),evxevec, NSTOR,
. 0._8, fdg12(1,k,1),
. (Maxy-Miny+1) * (Maxz-Minz+1))
enddo
!$omp end do
*
* ADJ of
* odd part of rhs
*
!$omp do
do k=Nkl,1,-1
do i=Gni-nev,1,-1
do j=njl,1,-1
fdg1 (j,k,i+1) = fdg12(j,k,i+nev) + fdg1(j,k,i+1)
fdg1 (j,k,Gni+1-i) = -fdg12(j,k,i+nev) + fdg1(j,k,Gni+1-i)
fdg12(j,k,i+nev) = ZERO_8
enddo
enddo
enddo
!$omp enddo
*
* ADJ of
* even part of rhs
*
if(Gni.eq.(2*(Gni/2)) ) then
!$omp do
do k=Nkl,1,-1
do j=njl,1,-1
fdg1 (j,k,nev) = fdg12(j,k,nev) + fdg1(j,k,nev)
fdg12(j,k,nev) = ZERO_8
enddo
enddo
!$omp enddo
endif
*
!$omp do
do i= (Gni+1)/2,2,-1
do k=Nkl,1,-1
do j=njl,1,-1
fdg1 (j,k,i) = fdg12(j,k,i) + fdg1(j,k,i)
fdg1 (j,k,Gni+2-i) = fdg12(j,k,i) + fdg1(j,k,Gni+2-i)
fdg12(j,k,i) = ZERO_8
enddo
enddo
enddo
!$omp enddo
*
!$omp do
do k=1,Nkl
do j=1,njl
fdg1 (j,k,1) = fdg12(j,k,1) + fdg1(j,k,1)
fdg12(j,k,1) = ZERO_8
enddo
enddo
!$omp enddo
*
!$omp do
do i= 1,Gni
do k= Nkl+1,Maxz
do j= Miny,Maxy
fdwfft(j,k,i)=ZERO_8
enddo
enddo
*
do k= Minz,Maxz
do j= njl+1,Maxy
fdg1 (j,k,i)=ZERO_8
fdg12(j,k,i)=ZERO_8
enddo
enddo
enddo
!$omp enddo
*
!$omp end parallel
*
call rpn_comm_transpose( Rhs, Minx, Maxx, Gni, (Maxy-Miny+1),
% Minz, Maxz, Nk, fdg1, -1,2 )
*
return
end