!copyright (C) 2001 MSC-RPN COMM %%%RPNPHY%%%
#include "phy_macros_f.h"
SUBROUTINE CLDWIN(BM,FM,T,HU,PS,TRAV,SIGMA,NI,NK,SATUCO) 1
#include "impnone.cdk"
*
INTEGER NI,NK
REAL FM(NI,NK),BM(NI,NK)
REAL T(NI,NK),HU(NI,NK)
REAL PS(NI)
REAL TRAV(NI,NK)
REAL SIGMA(NI,NK)
*
LOGICAL SATUCO
*
*
*Author
* Janusz Pudykiewicz (Nov. 1985)
*
*Revision
* 001 J. Mailhot (March 1993) 0 <= RH <= 1
* 002 R. Sarrazin (May 1994) Bugs correction
* and function funb0 func0
* 003 B. Bilodeau (Aug 1994) New physics interface
* 004 R. Sarrazin (June 95) Corrections; add cloud fraction
* 005 B. Bilodeau (Jan 2001) Automatic arrays
* 006 M. Lepine (March 2003) - CVMG... Replacements
*
*Object
* to initialize the cloud water field
*
*Arguments
*
* - Output -
* BM stratiform cloud fraction
* FM cloud water field
*
* - Input -
* T temperature
* HU specific humidity
* PS surface pressure
* TRAV work space
* SIGMA vertical discretization
* NI X-(horizontal grid dimension)
* NK number of vertical levels
* SATUCO .TRUE. if water/ice phase for saturation
* .FALSE. if water phase only for saturation
*
**
*
* STATEMENT FUNCTION:
*----------------------
*
* > FQSAT(XT,XP)=
* >*
* > X0.622/((XP/100.)*EXP(5418./XT - 21.656) - 0.378)
*
* USE COMDECKS FROM PHYSICS LIBRARY ----------------
* *
REAL TEMP1,PTCI,PUSBG1,PSGBT,WMR
*
************************************************************************
* AUTOMATIC ARRAYS
************************************************************************
*
AUTOMATIC (WPU0 , REAL , (NI))
*
************************************************************************
*
REAL FUNB0,FUNC0
REAL YPU0,XWFLO,XSIGMA,YPSGBT,YPUSG1,YPUS,YPTCI,XTTM,XW1
*
REAL PU0,PUS,PMR,XT
INTEGER NIK,K,I
*
PARAMETER (PU0 = 0.85 )
PARAMETER (PUS = 1.0 )
PARAMETER (PMR = 0.2E-3)
PARAMETER (PUSBG1 = 0.99)
PARAMETER (PSGBT = 0.8)
PARAMETER (PTCI = 238.)
*
#include "comphy.cdk"
#include "consphy.cdk"
#include "dintern.cdk"
#include "fintern.cdk"
*
*
*____FUNCTION USED FOR CORRECTING OF THE U00 FOR SIGMA>0.9
*
FUNB0(YPU0,XWFLO,XSIGMA,YPSGBT,YPUSG1)=
* YPU0+XWFLO*((XSIGMA-YPSGBT)/(1.-YPSGBT))*
* (YPUSG1-YPU0)
*
*____FUNCTION USED FOR CORRECTING OF THE U00 FOR CIRRUS LEVEL
*
FUNC0(YPUS,YPTCI,XW1,XTTM)=
* YPUS-((YPUS-XW1)/(1.+0.15*(YPTCI-XTTM)))
*
*
*
*______COMMON VALUES
*
NIK = NI * NK
*
*-----------------------------------------------------------
*
* INITIALISATION OF THE CLOUD WATER CONTAIN
* USING EMPIRICAL RELATION BETWEEN RELATIVE
* HUMIDITY AND PARTIAL CLOUD COVER.
*
*___1) COMPUTE RELATIVE HUMIDITY
*
*
* -----------------------------------------
IF(SATUCO) THEN
DO 100 K=1,NK
DO 100 I=1,NI
*
TRAV(I,K) = HU(I,K) /
* FOQST( T(I,K) , PS(I)*SIGMA(I,K))
*
TRAV(I,K) = MAX( 0.0 , MIN(TRAV(I,K),1.0) )
*
100 CONTINUE
ELSE
DO 101 K=1,NK
DO 101 I=1,NI
*
TRAV(I,K) = HU(I,K) /
* FOQSA( T(I,K) , PS(I)*SIGMA(I,K))
*
TRAV(I,K) = MAX( 0.0 , MIN(TRAV(I,K),1.0) )
*
101 CONTINUE
ENDIF
*
DO 10 K=1,NK
*
* correction to pu0 near ground
*
TEMP1 = 0.75
DO 77 I=1,NI
WPU0(I)=PU0
* 0.5 on continent, 1.0 over ocean
IF( SIGMA(I,K) .GE. PSGBT )
$ WPU0(I)=FUNB0(PU0,TEMP1,SIGMA(I,K),PSGBT,PUSBG1)
77 CONTINUE
*
* correction to pu0 for low temperatures
*
DO 79 I=1,NI
if (T(I,K).LE.PTCI) then
TEMP1 = WPU0(I)
WPU0(I) = FUNC0(PUS,PTCI,TEMP1,T(I,K))
endif
79 CONTINUE
*
*
*___2) COMPUTE PARTIAL CLOUD COVER
*
*
*
DO 200 I=1,NI
*
if ((TRAV(I,K).GE.WPU0(I)).AND.(TRAV(I,K).LE.PUS)) then
BM(I,K)=((TRAV(I,K)-WPU0(I))/(PUS-WPU0(I)))
else
BM(I,K) = 0.
endif
*
200 CONTINUE
*
*
DO 300 I=1,NI
*
BM(I,K) = 1. - SQRT( 1. - BM(I,K) )
*
300 CONTINUE
*
*
*___3) ESTIMATE CLOUD WATER CONTAIN FROM PARTIAL CLOUD
* COVER.
*
DO 400 I=1,NI
*
* reduce pmr for cold temperature
*
IF( T(I,K) .LT. 268. ) THEN
WMR=PMR/(1.0+0.5*(268.-T(I,K))**0.5)
ELSE
WMR=PMR
ENDIF
*
if(TRAV(I,K).LE.PUS) then
FM(I,K)=.9*BM(I,K)*WMR
else
FM(I,K)= BM(I,K)*WMR
endif
*
400 CONTINUE
*
10 CONTINUE
*
*--------------------------------------------------------
*
RETURN
END