!-------------------------------------- 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 liebman_2 - modifiy a portion of input field by overrelaxation
*
subroutine liebman_2 ( F_field, F_mask, F_max, F_ni, F_nj) 3
*
#include "impnone.cdk"
*
integer F_ni, F_nj
real F_field(F_ni,F_nj), F_mask(F_ni,F_nj), F_max
*
*author
* Alain Patoine - after version v1_03 of liebman.ftn
*
*revision
* v2_00 - Desgagne M. - initial MPI version (from liebman v1_03)
*
*object
*
*arguments
* Name I/O Description
*----------------------------------------------------------------
* F_field I/O
*----------------------------------------------------------------
* _____________________________________________________________________
* | | | |
* NAME | DESCRIPTION |DIMENSIONS |IN|
* | | |OU|
* --------|---------------------------------------------|-----------|--|
* F_field | field to be treated | F_ni, F_nj|io|
* --------|---------------------------------------------|-----------|--|
* F_mask | mask: 0 -> don't modify | F_ni, F_nj| i|
* | 1 -> modify | | |
* --------|---------------------------------------------|-----------|--|
* F_max | convergence criteria | scalar | i|
* --------|---------------------------------------------|-----------|--|
* F_ni | number of points in x-direction | scalar | i|
* F_nj | number of points in y-direction | scalar | i|
* ----------------------------------------------------------------------
*
*
integer i, j, pnj, n, pnitmax, pnl, pnr
*
real prfact, prmod, prmax, prvals, prvaln, prmass, prmasn
real wk1 (F_ni,F_nj+2), wk2 (F_ni,F_nj+2)
**
**********************************************************************
*
* WE INITIALISE A FEW THINGS
* --------------------------
*
* prfact = overrelaxation coefficient / 4.
* overrelaxation coefficient must be between 1. and 2.
*
* pnitmax = maximum number of iterations
*
**********************************************************************
prfact = 1.75 * 0.25
pnitmax = 100
**********************************************************************
*
* --> Put the average of the last position
* in the north pole position ........... (F_nj+2)
*
* --> Rearrange rows of data (F_nj) -> (F_nj+1)
* (F_nj-1) -> (F_nj)
* . .
* . .
* (1) -> (2)
*
* Put the average of the first position
* in the south pole position ........... (1)
*
**********************************************************************
pnj = F_nj+2
*
prvals = 0.0
prvaln = 0.0
prmass = 0.0
prmasn = 0.0
*
do i=1,F_ni
prvals = prvals + F_field(i,1 )
prvaln = prvaln + F_field(i,F_nj)
prmass = amax1 ( prmass, F_mask(i,1 ) )
prmasn = amax1 ( prmasn, F_mask(i,F_nj) )
enddo
prvals = prvals / F_ni
prvaln = prvaln / F_ni
do i=1,F_ni
wk1 (i,1 ) = prvals
wk2 (i,1 ) = prmass
wk1 (i,F_nj+2) = prvaln
wk2 (i,F_nj+2) = prmasn
enddo
*
do j=1,F_nj
do i=1,F_ni
wk1(i,j+1) = F_field(i,j)
wk2(i,j+1) = F_mask (i,j)
enddo
enddo
**********************************************************************
* Begin iterations *
**********************************************************************
do 100 n=1,pnitmax
*
prmax = 0.0
* ****************************************************************
* * South pole *
* ****************************************************************
if ( wk2(1,1) .gt. 0.5 ) then
*
prmod = 0.0
*
do i=1,F_ni
prmod = prmod + wk1(i,2)
enddo
*
prmod = prfact * ( prmod - F_ni * wk1(1,1) )
prmod = prmod * 4.0 / F_ni
*
prmax = amax1 ( prmax, abs(prmod) )
*
do i=1,F_ni
wk1(i,1) = wk1(i,1) + prmod
enddo
*
endif
* *****************************************************************
* * Interior of domain *
* *****************************************************************
do j=2,pnj-1
do i=1,F_ni
pnl = i-1
pnr = i+1
*
if ( i .eq. 1 ) pnl = F_ni
if ( i .eq. F_ni ) pnr = 1
*
if ( wk2(i,j) .gt. 0.5 ) then
prmod = prfact * (wk1(pnl,j) + wk1(pnr,j) +
% wk1(i,j-1) + wk1(i,j+1) -
% 4.*wk1(i,j))
*
prmax = amax1 ( prmax, abs(prmod) )
*
wk1(i,j) = wk1(i,j) + prmod
endif
enddo
enddo
* ****************************************************************
* * North pole *
* ****************************************************************
if ( wk2(1,pnj) .gt. 0.5 ) then
*
prmod = 0.0
*
do i=1,F_ni
prmod = prmod + wk1(i,pnj-1)
enddo
*
prmod = prfact * ( prmod - F_ni * wk1(1,pnj) )
prmod = prmod * 4.0 / F_ni
*
prmax = amax1 ( prmax, abs(prmod) )
*
do i=1,F_ni
wk1(i,pnj) = wk1(i,pnj) + prmod
enddo
*
endif
**********************************************************************
if ( prmax .lt. F_max ) go to 200
*
100 continue
200 continue
*
do j=1,F_nj
do i=1,F_ni
F_field (i,j) = wk1 (i,j+1)
enddo
enddo
*
return
end