!-------------------------------------- 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 e_findmod - Search in the neibourhood for land or a
* sea-water grid points and perform appropriate
* modifications to geophysical fields.
*
subroutine e_findmod (F_mdmg_L, F_h2o_L, F_dbg_L, F_pass, 2
$ F_nii, F_njj, F_mg, F_al, F_gl, F_hs, F_sd,
$ F_vg, F_zp, F_lh, F_w1,
% fnis, fnjs, fni, fnj, F_trouv_L)
*
#include "impnone.cdk"
*
logical F_mdmg_L, F_h2o_L, F_dbg_L, F_trouv_L
integer F_pass, F_nii, F_njj, fnis,fnjs,fni,fnj
real F_mg(fnis,fnjs), F_al(fnis,fnjs), F_gl(fnis,fnjs)
real F_hs(fnis,fnjs), F_sd(fnis,fnjs), F_vg(fnis,fnjs)
real F_zp(fnis,fnjs), F_lh(fnis,fnjs), F_w1(fnis,fnjs)
*
*author
* Andre Methot - cmc- may 1994
*
*revision
* v2_00 - Desgagne M. - initial MPI version (from e_findmod v1_03)
* v2_20 - Pellerin P. - routine is implemented in GEMNTR
*
*object
* This subroutine modifies mask dependant variables
* at a given grid point by importing selected neighbourhood's
* values. The selection criteria is the mask.
*
* The routine may be called to transform either a water grid
* point into a land grid point OR a land grid point into a water
* grid point.
*
* It can also be called in order to assign water attributes to
* a water point (MG<0.5) having land attributes or to
* assign land attributes to a land point (MG>=0.5) having water
* attributes.
*
*
* ASSIGNMENT OF WATER ATTRIBUTES (flh20=.true.)
* ---------------------------------------------
*
* For a given grid point (F_nii,F_njj) the albedo (AL), ice
* coverage (GL) , ZP , LH, and snow depth (SD) are recalculated
* as the average
* of thoses fields from WATER grid points in the neighbourhood.
* The vegetation type (VG) is taken directly from one neighbourh
* since averaging this field doesn't make sense.
*
* If F_mdmg_L is true, the land/water mask (MG) will be modified.
* This call leads to a tranformation from a land grid point to a water
* grid point.
* In this case, in addition to GL, SD, ZP, LH, and AL, the soil
* moisture (HS)
* and the vegetation type (VG) are also recalculated using WATER point
* values. The updated HS is the average from WATER neighbours as for
* GL, SD and AL. However the vegetation type (VG) is taken directly from
* neighbourh since averaging this field doesn't make sense.
*
* The algorithm search for WATER points within "F_pass"
* grid points from the given grid point (F_nii,F_njj).
* First the algorithm search for WATER points in the closest
* neighbourhood using indicies F_nii-1,F_nii+1 and F_njj-1,F_njj+1.
* If one or more than one WATER point is found in this first
* pass, the average fields are calculated and assigned to
* the given grid point and the routine is over.
*
* If no WATER grid point are found in the first pass,
* it then search farther away using indices F_nii-2,F_nii+2 and
* F_njj-2, F_njj+2. Again if one or more than one WATER point is
* found in this second pass, the average fields are calculated
* and assigned to the given grid point and the routine is over.
*
* The algorithm continues with successive pass until it
* find at least one WATER point or until it reach the given
* limit "F_pass". If the algorithm performs "F_pass" without
* finding any WATER point, then no modification of geophysical
* fields is done. In this case the FLAG "F_trouv_L" will be
* returned to FALSE indicating the faillure.
*
* Precautions are taken to make sure that the search
* in the neighbourhood is not going outside of the grid's
* limits (fni,fnj).
* Modified grid point are flagged in a returned work field
* to ensure that such recalculated values are not used to
* modify other neighbours in futur calls.
*
*
* ASSIGNMENT OF LAND ATTRIBUTES:
* ------------------------------
*
* If flh20 is FALSE then, LAND point are search for.
* The algorithm described above works the same way but
* it works with LAND points rather than WATER points.
*
*arguments
* Name I/O Description
*----------------------------------------------------------------
* F_mdmg_L I
*----------------------------------------------------------------
*
*implicites
*
real prmg, prhs, prgl, pral, prsd, prvg, przp, prlh
logical pltrouv
integer i, j, pnpass, pnknt
integer pni1m, pni2m, pni1p, pni2p, pnjm, pnjp
**
* ------------------------------------------------------------
*
* initial values
*
prmg = 0.
prhs = 0.
prgl = 0.
pral = 0.
prsd = 0.
prvg = 0.
przp = 0.
prlh = 0.
pnknt = 0
F_trouv_L = .false.
F_w1(F_nii,F_njj)=0.
if ( F_dbg_L ) then
write(6,600)
write(6,605) F_nii, F_njj,
% F_mg(F_nii,F_njj), F_al(F_nii,F_njj),
% F_hs(F_nii,F_njj), F_gl(F_nii,F_njj),
% F_sd(F_nii,F_njj), F_vg(F_nii,F_njj)
endif
*
* Beginning of the search for WATER/LAND POINTS.
*
* This is the pass loop
*
do 50 pnpass=1,F_pass
*
* the lower and higher row indicies are recalculated
pni1m = F_nii - pnpass
pni1p = F_nii + pnpass
*
pni2m = 0
pni2p = 0
*
* if row indicies are going out of row limits The pass will be
* splited into two process.
* The second pass will be done with pni2m and pni2p indicies.
*
if ( pni1m .lt. 1 ) then
pni2m = fni + pni1m
pni2p = fni
pni1m = 1
else if ( pni1p .gt. fni ) then
pni2m = fni + pni1m
pni2p = fni
pni1p = fni
endif
*
* the lower and higher column indicies are recalculated
pnjm = F_njj - pnpass
pnjp = F_njj + pnpass
*
* if column indicies are going out of column limits, the
* pass will be restricted inside limits.
*
if ( pnjm .lt. 1 ) then
pnjm = 1
else if ( pnjp .gt. fnj ) then
pnjp = fnj
endif
10 continue
do i=pni1m, pni1p
do j=pnjm , pnjp
pltrouv = ( (.not. F_h2o_L) .and. (F_mg(i,j) .ge. 0.5) )
% .or. ( F_h2o_L .and. (F_mg(i,j) .lt. 0.5) )
if ( pltrouv .and. F_w1(i,j).le.0.5 ) then
prmg = prmg + F_mg(i,j)
pral = pral + F_al(i,j)
prhs = prhs + F_hs(i,j)
prgl = prgl + F_gl(i,j)
prsd = prsd + F_sd(i,j)
prvg = F_vg(i,j)
przp = przp + F_zp(i,j)
prlh = prlh + F_lh(i,j)
F_w1(F_nii,F_njj)=1.0
pnknt = pnknt + 1
F_trouv_L = .true.
end if
end do
end do
*
* one pass is completed if pni2m is 0
*
* otherwise the first part of a splited pass is
* completed and we then have to update indicies and do the
* second part of the pass from label 10.
*
if ( pni2m .ne. 0 ) then
pni1m = pni2m
pni1p = pni2p
pni2m = 0
pni2p = 0
goto 10
endif
*
* Here, one pass is completed.
*
* If at least one point is found then the fields
* are recalculated with the average of the neighbours found.
if ( F_trouv_L ) then
F_al(F_nii,F_njj) = pral / float(pnknt)
F_gl(F_nii,F_njj) = prgl / float(pnknt)
F_sd(F_nii,F_njj) = prsd / float(pnknt)
if ( F_mdmg_L ) then
F_mg(F_nii,F_njj) = prmg / float(pnknt)
F_hs(F_nii,F_njj) = prhs / float(pnknt)
F_vg(F_nii,F_njj) = prvg
F_zp(F_nii,F_njj) = przp / float(pnknt)
F_lh(F_nii,F_njj) = prlh / float(pnknt)
if ( F_dbg_L )
% write(6,615) F_nii, F_njj,
% F_mg(F_nii,F_njj), F_al(F_nii,F_njj),
% F_hs(F_nii,F_njj), F_gl(F_nii,F_njj),
% F_sd(F_nii,F_njj), F_vg(F_nii,F_njj),
% pnpass, pnknt
else if ( F_dbg_L ) then
write(6,620) F_nii, F_njj,
% F_al(F_nii,F_njj), F_gl(F_nii,F_njj),
% F_sd(F_nii,F_njj), F_vg(F_nii,F_njj),
% pnpass, pnknt
end if
goto 60
*
* RETURNS if at least one point was found
*
end if
50 continue
*
60 continue
600 format(/,'S/R e_findmod point(i,j)',13x,'MG',7x,'AL',7x,'HS',7x,
% 'GL',7x,'SD',7x,'VG')
605 format( 'S/R e_findmod',2i5,3x,'Initial ',6F9.5)
615 format( 'S/R e_findmod',2i5,3x,'Modified',6F9.5,' after',i3,' pass. ',i3)
620 format( 'S/R e_findmod',2i5,3x,'Modified',4F9.5,' after',i3,' pass. ',i3)
return
end