!-------------------------------------- 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 itf_phy_psetiw - allocate and prepare indices and weights
* for the second physics set option
*
#include "model_macros_f.h"
*
subroutine itf_phy_psetiw (F_lunout) 1,2
*
implicit none
*
integer F_lunout
*author
* Bernard dugas - RPN - November 2002 (based on A. Methot's P_FCPFW)
*
*revision
* v3_02 - Dugas B. - initial version
* v3_30 - Desgagne et al. - renamed from P_PSETIW to itf_phy_psetiw
*
*object
* Prepare indicies and weights for the second physics set option.
* This option allow the use of two different physics. The first one
* in the central high-resolution window and a second set, presumably
* appropriate to regions outside of this central window, with an
* optionnal blending region where both sets are in use.
*
* The weights are "1." in the central region and "0." in the other
* region, outside of the blending area. The weights vary linearly
* in the blending area.
*
*
*arguments
* None
*
*implicits
#include "glb_ld.cdk"
#include "itf_phy_config.cdk"
*
**
real*8 prsecondw
integer i, j, i_glob, j_glob, pnerr
*
* ---------------------------------------------------------------
*
if (F_lunout.gt.0) write(F_lunout,1000)
*
*
***********************************************************************
*C Allocate memory for 2D amplification factor field
***********************************************************************
*
call hpalloc(P_pset_secondi_, 4 * l_nj, pnerr, 0)
call hpalloc(P_pset_secondw_, l_ni * l_nj, pnerr, 8)
*
***********************************************************************
*C Put constraints on blending parameters
***********************************************************************
*
if (P_pset_xofsetr.eq.-1) then
*
P_pset_xofset = max( P_pset_xofset, 0 )
P_pset_xofset = min( P_pset_xofset, (G_ni-2)/2 )
*
P_pset_xofsetr = P_pset_xofset
if (F_lunout.gt.0) write(F_lunout,1001) P_pset_xofset
*
else
*
P_pset_xofset = max( P_pset_xofset , 0 )
P_pset_xofsetr = max( P_pset_xofsetr, 0 )
*
if (P_pset_xofset+P_pset_xofsetr .gt. G_ni-2) then
if (F_lunout.gt.0) write(F_lunout,1002)
call gem_stop( 'p_psetiw',-1 )
endif
*
endif
*
P_pset_xblnd = max( P_pset_xblnd, 1 )
P_pset_xblnd = min( P_pset_xblnd,
$ ( max( 1,
$ ( G_ni-P_pset_xofset-P_pset_xofsetr ) / 2 ) ) )
*
if (P_pset_yofsett.eq.-1) then
*
P_pset_yofset = max( P_pset_yofset, 0 )
P_pset_yofset = min( P_pset_yofset, (G_nj-2)/2 )
*
P_pset_yofsett = P_pset_yofset
if (F_lunout.gt.0) write(F_lunout,1003) P_pset_yofset
*
else
*
P_pset_yofset = max( P_pset_yofset , 0 )
P_pset_yofsett = max( P_pset_yofsett, 0 )
*
if (P_pset_yofset+P_pset_yofsett .gt. G_nj-2) then
if (F_lunout.gt.0) write(F_lunout,1004)
call gem_stop( 'p_psetiw',-2 )
endif
*
endif
*
P_pset_yblnd = max( P_pset_yblnd, 1 )
P_pset_yblnd = min( P_pset_yblnd,
$ ( max( 1,
$ ( G_nj-P_pset_yofset-P_pset_yofsett ) / 2 ) ) )
*
***********************************************************************
*C Initialize the entire local domain to the second set ONLY
***********************************************************************
*
do j=1,l_nj
P_pset_secondi(1,j) = 1
P_pset_secondi(2,j) = l_ni+1
P_pset_secondi(3,j) = 0
P_pset_secondi(4,j) = 0
do i=1,l_ni
P_pset_secondw(i,j) = 0.
enddo
enddo
*
do j=1,l_nj
*
j_glob = l_j0+j-1
*
if
$ (( j_glob .lt. G_nj-P_pset_yofsett+1 ) .and.
$ ( j_glob .gt. P_pset_yofset )) then
*
***********************************************************************
*C Compute weights for Y direction
***********************************************************************
*
if
$ ( j_glob .lt. P_pset_yofset+P_pset_yblnd ) then
*
prsecondw = dble( j_glob - P_pset_yofset )
$ / dble( P_pset_yblnd )
*
elseif
$ ( j_glob .lt. G_nj-P_pset_yofsett-P_pset_yblnd+2 ) then
*
prsecondw = 1.0
*
else
*
prsecondw = dble( G_nj-P_pset_yofsett-j_glob+1 )
$ / dble( P_pset_yblnd )
*
endif
*
if
$ (( l_i0 .lt. G_ni-P_pset_xofsetr+1 ) .and.
$ ( l_i0+l_ni-1 .gt. P_pset_xofset )) then
*
***********************************************************************
*C Define the column boundaries for the
*C two physics sets at the current row
***********************************************************************
*
P_pset_secondi(1,j) = P_pset_xofset +2-l_i0
P_pset_secondi(4,j) = G_ni-P_pset_xofsetr+1-l_i0
P_pset_secondi(2,j) = P_pset_secondi(1,j)+P_pset_xblnd-1
P_pset_secondi(3,j) = P_pset_secondi(4,j)-P_pset_xblnd+1
*
if (prsecondw.lt.1.0)
$ P_pset_secondi(2,j) = P_pset_secondi(3,j)+1
*
***********************************************************************
*C Compute the relevant 2D weights
***********************************************************************
*
do i= 1,l_ni
*
i_glob=l_i0+i-1
*
if
$ (( i_glob .gt. P_pset_xofset ) .and.
$ ( i_glob .lt. P_pset_xofset+P_pset_xblnd )) then
*
P_pset_secondw(i,j) =
$ prsecondw * dble( i_glob-P_pset_xofset )
$ / dble( P_pset_xblnd )
*
elseif
$ (( i_glob .ge. P_pset_xofset +P_pset_xblnd ) .and.
$ ( i_glob .lt. G_ni-P_pset_xofsetr-P_pset_xblnd+2 )) then
*
P_pset_secondw(i,j) = prsecondw
*
elseif
$ (( i_glob .ge. G_ni-P_pset_xofsetr-P_pset_xblnd+2 ) .and.
$ ( i_glob .lt. G_ni-P_pset_xofsetr+1 )) then
*
P_pset_secondw(i,j) =
$ prsecondw * dble( G_ni-P_pset_xofsetr-i_glob+1 )
$ / dble( P_pset_xblnd )
endif
*
enddo
*
endif
*
endif
*
enddo
*
return
*
1000 format(/'ALLOCATE AND PREPARE INDICES AND WEIGHTS FOR ',
% /'SECOND PHYSICS OPTION (S/R itf_phy_psetiw)'
% /'====================================================')
1001 format(/'P_pset_xofsetr reset to ',I5)
1002 format(/'P_pset_xofset+P_pset_xofsetr greater than G_ni-2')
1003 format(/'P_pset_yofsett reset to ',I5)
1004 format(/'P_pset_yofset+P_pset_yofsett greater than G_nj-2')
*
end