!-------------------------------------- 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 --------------------------------------
copyright (C) 2001 MSC-RPN COMM %%%MC2%%%
***s/r hzd_nudeln_ad
*
#include "model_macros_f.h"
subroutine hzd_nudeln_ad (rfd,sfd,lminx,lmaxx,lminy,lmaxy,lnk,nu, 4
$ is,js,m,n)
implicit none
*
integer lminx,lmaxx,lminy,lmaxy,lnk,is,js,m,n
real rfd (lminx:lmaxx,lminy:lmaxy,lnk),
$ sfd (lminx:lmaxx,lminy:lmaxy,lnk)
real*8 nu
*
*AUTHORs M. Tanguay
*
*revision
* v3_30 - Tanguay M. - initial MPI version
*
*OBJECT
*
* ADJOINT of
* *******************************************************************
* * *
* * OPERATOR nu_DEL2_n *
* * *
* * n successive calls to this subroutine produces *
* * *
* * ---------------- *
* * | n | *
* * the equivalent of a diffusion: | -(-nu_DEL2) | *
* * | | *
* * ---------------- *
* * *
* * *
* * *
* * Each call applies a 9-point filter *
* * *
* * [ Shuman, M.W.R. #57, p.357-361, eq #5. ] *
* * *
* * to the difference: rfd - sfd. *
* * *
* * *
* *******************************************************************
*
*EXTERNALS
#include "glb_ld.cdk"
*
**
integer i,j,k,id,jd,iff,jf
real wk(l_minx:l_maxx,l_miny:l_maxy,lnk)
real*8 c1,c2,c3,one,two,four
parameter(one=1.d0,two=2.d0,four=4.d0)
*
real*8, parameter :: ZERO_8 = 0.0
*----------------------------------------------------------------------
*
id = 1+pil_w
jd = 1+pil_s
iff= l_ni-pil_e-is*east
jf = l_nj-pil_n-js*north
*
c1 = nu*(one-two*nu)
c2 = nu**2
c3 = nu*four*(nu-one)
*
!$omp parallel
*
!$omp do
do k=1,lnk
do j=l_miny,l_maxy
do i=l_minx,l_maxx
wk(i,j,k) = ZERO_8
end do
end do
end do
!$omp end do
*
!$omp do
do k=lnk,1,-1
if (m.eq.n) then
do j=jf,jd,-1
do i=iff,id,-1
*
sfd(i ,j+1,k) = c1*(rfd(i,j,k)) + sfd(i ,j+1,k)
sfd(i+1,j ,k) = c1*(rfd(i,j,k)) + sfd(i+1,j ,k)
sfd(i ,j-1,k) = c1*(rfd(i,j,k)) + sfd(i ,j-1,k)
sfd(i-1,j ,k) = c1*(rfd(i,j,k)) + sfd(i-1,j ,k)
*
sfd(i-1,j+1,k) = c2*(rfd(i,j,k)) + sfd(i-1,j+1,k)
sfd(i+1,j+1,k) = c2*(rfd(i,j,k)) + sfd(i+1,j+1,k)
sfd(i-1,j-1,k) = c2*(rfd(i,j,k)) + sfd(i-1,j-1,k)
sfd(i+1,j-1,k) = c2*(rfd(i,j,k)) + sfd(i+1,j-1,k)
*
sfd(i ,j ,k) = c3* rfd(i,j,k) + sfd(i ,j ,k)
*
end do
end do
else
do j=jf,jd,-1
do i=iff,id,-1
*
rfd(i,j,k) = sfd(i,j,k) + rfd(i,j,k)
wk (i,j,k) = sfd(i,j,k) + wk(i,j,k)
sfd(i,j,k) = ZERO_8
*
end do
end do
do j=jf,jd,-1
do i=iff,id,-1
*
sfd(i ,j+1,k) = c1*(wk(i,j,k)) + sfd(i ,j+1,k)
sfd(i+1,j ,k) = c1*(wk(i,j,k)) + sfd(i+1,j ,k)
sfd(i ,j-1,k) = c1*(wk(i,j,k)) + sfd(i ,j-1,k)
sfd(i-1,j ,k) = c1*(wk(i,j,k)) + sfd(i-1,j ,k)
*
sfd(i-1,j+1,k) = c2*(wk(i,j,k)) + sfd(i-1,j+1,k)
sfd(i+1,j+1,k) = c2*(wk(i,j,k)) + sfd(i+1,j+1,k)
sfd(i-1,j-1,k) = c2*(wk(i,j,k)) + sfd(i-1,j-1,k)
sfd(i+1,j-1,k) = c2*(wk(i,j,k)) + sfd(i+1,j-1,k)
*
sfd(i ,j ,k) = c3* wk(i,j,k) + sfd(i ,j ,k)
*
wk(i,j,k) = ZERO_8
*
end do
end do
endif
*
if (m.eq.1) then
do j=jd-1,jf+1
do i=id-1,iff+1
rfd(i,j,k) = sfd(i,j,k) + rfd(i,j,k)
sfd(i,j,k) = ZERO_8
end do
end do
else if (m.eq.2) then
do j=jd-1,jf+1
do i=id-1,iff+1
rfd(i,j,k) = sfd(i,j,k) + rfd(i,j,k)
sfd(i,j,k) = - sfd(i,j,k)
end do
end do
else
do j=jd-1+south,jf+1-north
do i=id-1+west,iff+1-east
rfd(i,j,k) = sfd(i,j,k) + rfd(i,j,k)
sfd(i,j,k) = - sfd(i,j,k)
end do
end do
endif
end do
!$omp end do
*
!$omp end parallel
*
*----------------------------------------------------------------------
return
end