!-------------------------------------- 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 MODHUI - MODIFICATION DE HU EN HAUT DE 300 MB
*
#include "phy_macros_f.h"
SUBROUTINE MODHUI(HU,TX,PX,LNPS,MODP,SWTT,SWPH,,3
$ NI,NK,N)
*
#include "impnone.cdk"
*
INTEGER NI, NK, N, MODP
REAL HU(NI,NK), TX(NI,NK)
REAL PX(NK), LNPS(NI,*)
REAL ES1,PN1,ES2,PN2
LOGICAL SWTT, SWPR, SWPH
*
*Author
* C. GIRARD - MAR 93
*
*Revision
* 001 B. Dugas (Apr 1996) - Modifications for hybrid
* coordinate in sef model
* 002 G. Pellerin (Mar 1996) - Revised interpolation above 300mb
* level with limit above 150mb
* 003 B. Bilodeau (Jan 2001) - Automatic arrays
*
*Object
* To recalculate the specific humidity over 300MB.
* by using the zeroth order interpolation
* and keeping one of the following constant:
* A) The relative humidity when the temperature decreases
* to simulate what happens below the tropopause.
* or
* B) The specific humidity when the temperature increases
* to simulate what happens above the tropopause.
*
*Arguments
*
* -Output-
* HU Specific humidity in kg/kg
*
* -Input-
* TX temperature or virtual temperature in Kelvins
* PX See 'MODP'
* LNPS See 'MODP'
* MODP pressure mode (SI units only):
* =0; pressure level in PX
* =1; sigma level in PX and PS(surface pressure) in LNPS
* =2; sigma level in PX and logarithm of sigma level in
* LNPS
* =3; all points of pressure in LNPS(NI,*) in Pascals
* =4; sigma level in PX and logarithm of sigma level in
* LNPS(in millibars unless using SI units)
* =5; logarithm of pressure level in PX(in millibars unless
* using SI units)
* SWTT if .TRUE., we pass TT as an argument
* if .FALSE.,we pass TV as an argument
* SWPH if .TRUE., water and ice phase considered
* if .FALSE.,water phase only for all temperatures.
* NI Horizontal dimension
* NK Vertical dimension
* N Number of points to process
*
*IMPLICITES
#include "consphy.cdk"
*MODULES
EXTERNAL INCTPHY
*
**
*--------------------------------------------------------------------
*
REAL Qsat,Qnot,HRnot
REAL ALPHA, HREL, HRPRIM, QPRIM
*
*
************************************************************************
* AUTOMATIC ARRAYS
************************************************************************
*
AUTOMATIC (PN , REAL , (N))
AUTOMATIC (PN0 , REAL , (N))
*
************************************************************************
*
REAL E, TD
INTEGER K,K0, I
*
#include "dintern.cdk"
#include "fintern.cdk"
*--------------------------------------------------------------------
#include "initcph.cdk"
*
*
*
DO 10 K0=NK-1,1,-1
*
K=K0
#include "modpr2.cdk"
*
DO I=1,N
PN0(I)=PN(I)
ENDDO
*
K=K0+1
#include "modpr2.cdk"
*
K=K0
Qnot = 2.5E-6
DO 300 I=1,N
*--------------------------------------------------------------------
IF(PN0(I).LT.3.E4) THEN
*--------------------------------------------------------------------
IF(SWPH) THEN
Qsat=FOQST(TX(I,K),PN0(I))
ELSE
Qsat=FOQSA(TX(I,K),PN0(I))
ENDIF
*--------------------------------------------------------------------
IF(PN0(I).LT.1.50E4) THEN
*--------------------------------------------------------------------
HU(I,K) = min(Qnot,0.8*qsat)
ELSE
PN1 = PN0(I)
PN2 = PN(I)
ALPHA = (PN1 - 1.5E4) /1.5E4
QPRIM = ALPHA * HU(I,K+1) + (1.-ALPHA) * Qnot
*
IF(SWPH) THEN
HREL = FOHR ( HU(I,K+1) , TX(I,K+1), PN2)
ELSE
HREL = FOHRA( HU(I,K+1) , TX(I,K+1), PN2)
ENDIF
*
HRPRIM = ALPHA * HREL + (1.-ALPHA) * 0.8
HU(I,K) = min( QPRIM , HRPRIM * Qsat)
ENDIF
*--------------------------------------------------------------------
ENDIF
*--------------------------------------------------------------------
300 CONTINUE
*
10 CONTINUE
*
*
RETURN
CONTAINS
#include "fintern90.cdk"
END