!-------------------------------------- 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_modhs - Modification soil moisture field to ensure coherency
* due to mask discrepency and merge with climatology
*
subroutine e_modhs() 1,2
*
implicit none
*
*author andre methot - cmc- feb 1996 - v0_18
*
*revision
* v2_20 - P. Pellerin - transfer from the gemdm to e_gemntr
* v3_30 - Desgagne M. - renamed comdecks for new PHYSICS interface
*
*object
*
* This subroutine performs changes in HS ANALYSED field IF requiered
*
* Those changes are needed to avoid so called water-holes
* on model water grid points perceived as land grid points by
* the analysis. This happends where model resolves bays and lakes
* unresolved by the analysis.
*
* Also, model land grid points perceived as water grid points
* by the land/water the analysis can lead to inconsistencies.
* This append where model resolve peninsula and islands
* unresolved by the analysis.
*
*arguments
*
*implicit
#include "e_grids.cdk"
#include "e_geol.cdk"
* comdecks used also in GEMPP
#include "model_macros_f.h"
#include "dcst.cdk"
#include "itf_phy_buses.cdk"
#include "geobus.cdk"
**
integer i, j, im, offk
real prmax, prpoa, prcon, prlat, prlon
real wk1(nifi*njfi), wk2(nifi*njfi)
*
* ------------------------------------------------------------
*
write(6, 600)
*
prmax=0.01
*
* --------------------------------------
* generation of a mask independant field
* --------------------------------------
*
if ( E_geol_hsanl_L .and. ( .not. E_geol_hscon_L ) ) then
*
do i=1,nifi*njfi
if (geobus(mh+i-1).lt.0.5) then
wk2(i)=1.0
else
wk2(i)=0.0
endif
end do
call liebman_2(geobus(hs),wk2,prmax,nifi,njfi)
do i=1,nifi*njfi
geobus(hs+i-1) = max(geobus(hs+i-1),0.)
geobus(hs+i-1) = min(geobus(hs+i-1),1.)
if ( geobus(mh+i-1).lt.0.5 .and.
$ geobus(hs+i-1).lt.prmax ) geobus(hs+i-1) = 0.
enddo
*
if ( E_geol_hsreg_L ) then
*
do i=1,nifi*njfi
if (geobus(mg+i-1).lt.0.5) then
wk2(i)=1.0
else
wk2(i)=0.0
endif
end do
call liebman_2(geobus(hsc),wk2,prmax,nifi,njfi)
do i=1,nifi*njfi
geobus(hsc+i-1)= max(geobus(hsc+i-1),0.)
geobus(hsc+i-1)= min(geobus(hsc+i-1),1.)
if (geobus(mg+i-1 ) .lt. 0.5 .and.
$ geobus(hsc+i-1) .lt. prmax ) geobus(hsc+i-1) = 0.
enddo
endif
*
endif
*
* --------------------------------------------------------------
* merge analysis with climatology outside lat-lon box delimiting
* the domain in which the analysis is to be used
* --------------------------------------------------------------
*
if ( E_geol_hsreg_L ) then
prcon = 180./Dcst_pi_8
do i=1,nifi*njfi
prlat=geobus(la+i-1)*prcon
prlon=geobus(lo+i-1)*prcon
if ( prlon .lt. 0 ) prlon = 360. + prlon
if ( ( prlat .lt. E_geol_hss ) .or.
% ( prlat .gt. E_geol_hsn ) .or.
% ( prlon .lt. E_geol_hsw ) .or.
% ( prlon .gt. E_geol_hse ) ) then
* This is outside de lat-lon box
geobus(hs+i-1)=geobus(hsc+i-1)
else
* This point is inside the lat-lon box
if ( prlat .lt. (E_geol_hss + 2.) ) then
* This point is on the southern edge
prpoa = ( prlat - E_geol_hss ) / 2.
geobus(hs+i-1) = prpoa*geobus(hs+i-1)
% + (1.-prpoa)*geobus(hsc+i-1)
else if ( prlat .gt. (E_geol_hsn - 2.) ) then
* This point is on the northern edge
prpoa = ( E_geol_hsn - prlat ) / 2.
geobus(hs+i-1) = prpoa*geobus(hs+i-1)
% + (1.-prpoa)*geobus(hsc+i-1)
endif
if ( prlon .lt. (E_geol_hsw + 2.) ) then
* This point is on the western edge
prpoa = ( prlon - E_geol_hsw ) / 2.
geobus(hs+i-1) = prpoa*geobus(hs+i-1)
% + (1.-prpoa)*geobus(hsc+i-1)
else if ( prlon .gt. (E_geol_hse - 2.) ) then
* This point is on the eastern edge
prpoa = ( E_geol_hse - prlon ) / 2.
geobus(hs+i-1) = prpoa*geobus(hs+i-1)
% + (1.-prpoa)*geobus(hsc+i-1)
endif
endif
end do
endif
*
600 format(/,' MODIFICATION OF SOIL MOISTURE FIELD (S/R E_MODHS)')
* ------------------------------------------------------------
*
return
end