!-------------------------------------- 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/P Mkcldtop
#include "phy_macros_f.h"
SUBROUTINE Mkcldtop (kcldtop,sigh,ni,nk) 1
*
#include "impnone.cdk"
integer kcldtop
real ps, pcldtop
parameter (ps=100., pcldtop=10.)
integer ni,nk
real sigh(ni,nk)
*
*Author
* C. Girard (Jan 97) - Connection to Relaxed Arakawa-Schubert
*
*Revisions
*001 G. Pellerin (Avr 97) - Standard Documentation
*002 G. Pellerin (Mai 03) - Conversion IBM
* - calls to vslog routine (from massvp4 library)
* - calls to exponen4 (to calculate power function '**')
*
*Object
* determine maximum level k allowed for clouds
*
*Arguments
* - Input -
* ni horizontal dimension
* nk vertical dimension
* sigh local sigma levels
*
* - Output -
* kcldtop maximum level k allowed for clouds
*
**
*
integer k
real p
*
kcldtop=1
do k=1,nk
p=sigh(1,k)*ps
if (p.lt.pcldtop) kcldtop=k+1
enddo
c
return
end
*** S/P Mras0
SUBROUTINE Mras0 (tchange,qchange,precip,nuage, 2,4
& cck,ilab,dbdt,lsun,
& tj,qj,ps,sige,
& dt,j,Cp,grav,hlatent,xkap,
& nk,ni,nikp1)
*
#include "impnone.cdk"
*
integer j,ni,nk,nikp1
real dt,Cp,grav,hlatent,xkap,ptop
real tchange(ni,nk), qchange(ni,nk), precip(ni), nuage(ni,nk)
real cck(ni,nk), dbdt(ni), tj(ni,nk), qj(ni,nk)
real ps(ni), sige(ni,nk+1)
integer ilab(ni,nk)
logical lsun
*
*Author
* C. Girard (Jan 97) - Connection to Relaxed Arakawa-Schubert
*
*Revisions
*001 G. Pellerin (Avr 97) - Standard Documentation
*002 B. Bilodeau (Jan 01) - Automatic arrays
*003 G. Pellerin (Mai 03) - Conversion IBM
* - calls to vslog routine (from massvp4 library)
* - calls to exponen4 (to calculate power function '**')
*004 B. Bilodeau (Aug 03) - exponen4 replaced by vspown1
*
*Object
* to compute convective effects using Relaxed Arakawa-Schubert
* convective scheme.
*
*Arguments
* - Input -
* ni horizontal dimension
* nk vertical dimension
* nikp1 total slab dimension
* dt Timestep
* j Index of the row for which calculations are done
* (used only for zonal diagnostics extraction)
* Cp Specific heat at constant pressure
* grav Acceleration due to gravity
* hlatent Latent Heat of condensation
* xkap R/Cp, where R is the gas constant
* sige Sigma levels
* pkappa: Exner function
* qsatvp: Saturated vapor pressure (mb)
*
* - Input/Output -
* tchange temperature tendency due to convection
* qchange vapour tendency due to convection
* -Input/Output-
* ilab flag array: a large scale convergence control as input,
* an indication of convective activity as output
* -Outputs-
* cck estimated cumulus cloud cover
* precip liquid convective precipitation rate
* nuage cloudiness ?
* dbdt estimated averaged cloud fraction growth rate
* lsun condensation switch
* tj temperature at (t+dt) before convection
* qj specific humidity at (t+dt) before convection
* ps surface pressure at (t+dt)
*
**
*
#include "tables.cdk"
#include "comras.cdk"
integer jj
COMMON /point/ jj
logical lbotop, lcontrl
real frac,p00,crtmsf,formf,pscale
real temp1
integer nkp1,nkm1,nik,ncrnd,krmin,krmax
integer i,k,iseed
*
*
************************************************************************
* AUTOMATIC ARRAYS
************************************************************************
*
AUTOMATIC ( W1 , REAL , (NIKP1,13) )
AUTOMATIC ( PRS , REAL , (NIKP1 ) )
AUTOMATIC ( PRH , REAL , (NIKP1 ) )
AUTOMATIC ( PRJ , REAL , (NIKP1 ) )
AUTOMATIC ( POI , REAL , (NIKP1 ) )
AUTOMATIC ( QOI , REAL , (NIKP1 ) )
AUTOMATIC ( UOI , REAL , (NIKP1 ) )
AUTOMATIC ( VOI , REAL , (NIKP1 ) )
AUTOMATIC ( CMASS , REAL , (NIKP1 ) )
AUTOMATIC ( W2 , REAL , (NI ,21) )
AUTOMATIC ( W3 , REAL , (NI*6 ) )
AUTOMATIC ( PSJ , REAL , (NI ) )
AUTOMATIC ( temp , REAL , (NI ) )
AUTOMATIC ( SIGF , REAL , (NK+1 ) )
AUTOMATIC ( RASAL , REAL , (NK ) )
*
************************************************************************
c
c
c
c PRS(nikp1) ! p at interface levels
c PRJ(nikp1) ! (p/p00)**kappa at interface levels
c POI(nikp1) ! potential temp at data levels
c UOI(nikp1) ! 1st wind component at data levels
c VOI(nikp1) ! 2nd wind component at data levels
c QOI(nikp1) ! q at data levels
c cmass(nikp1) conv. mass flux
c RASAL(nk) ! array of relaxation coefs to be set
c
levap=.false.
lbotop=.true.
lcontrl=.false.
if(lsun) levap=.false.
c
nkp1=nk+1
nkm1=nk-1
nik=ni*nk
c
pscale=10. ! to compute p(mb) from psj(kgP),ptop and sigf
ptop=0.
c
krmin=0 !
krmax=0 ! with =0=ncrnd clouds can be as high as kcldtop
ncrnd=0 ! number of random produced clouds; 0=sequential
frac=0.1 ! frac=amin1(0.1, 4.e-6*dt/(sigf(nk+1)-sigf(nk)))
p00=1000. ! reference pressure in mb
crtmsf=0. ! used for cloud calculation only
c
do k=1,nk+1
sigf(k)=sige(1,k)
enddo
c
do i=1,ni
psj(i)=.001*ps(i) ! de ps(Pascal) a psj(kgPascal)
enddo
c
c compute p(mb) and (p/p00)**kappa at all levels
c compute theta at data levels
c
call Mpxkap (PRS,PRJ,psj,sige,pkappa,ptop,
& pscale,npkappa,ni,nkp1)
call Mraspkh (PRH,PRJ,PRS,xkap,ni,nkp1)
c
do k=1,nk
RASAL(k)=0.1
do i=1,ni
POI(i+(k-1)*ni)=tj(i,k)/PRH(i+(k-1)*ni)
QOI(i+(k-1)*ni)=qj(i,k)
UOI(i+(k-1)*ni)=0.
VOI(i+(k-1)*ni)=0.
cmass(i+(k-1)*ni)=0.
enddo
enddo
c
C call Nrsetc (precip,ni,0.) ! accumulated precip =0
C call Nrsetc (nuage,nik,0.) ! accumulated cloudiness =0
C call Nrsetc (tchange,nik,0.) ! accumulated heating rate =0
C call Nrsetc (qchange,nik,0.) ! accumulated moistening rate=0
call Mrasrc (RASAL,sigf,dt,nk) ! set relaxation coefficients
c
c
call Mras (ni,ni,nk,dt,nkp1,nkm1,lcontrl,
& iseed,ncrnd,krmin,krmax,frac,RASAL,lbotop,
& Cp,hlatent,xkap,grav,p00,crtmsf,
& POI,QOI,UOI,VOI,PRS,PRJ,
& precip,nuage,tchange,qchange,
& w1(1,1),w1(1,2),w1(1,3),w1(1,4),w1(1,5),
& w1(1,6),w1(1,7),w1(1,8),w1(1,9),
& w1(1,10),w1(1,11),w1(1,12),
& w2(1,1),w2(1,2),w2(1,3),w2(1,4),w2(1,5),w2(1,6),
& w2(1,7),w2(1,8),w2(1,9),w2(1,10),w2(1,11),w2(1,12),
& w2(1,13),w2(1,14),w2(1,15),w2(1,16),w2(1,17),
& w2(1,18),w2(1,19),w2(1,20),qsatvp,nqsatvp,cmass,
& w3,w2(1,21))
c
if(lsun) then
c
do k=1,nk
do i=1,ni
if(tchange(i,k).gt.0.) then
ilab(i,k)=2
else
ilab(i,k)=0
endif
enddo
enddo
c
do i=1,ni
temp(i) = max( 1.e-12, .001*precip(i) )
enddo
call vslog (temp,temp,ni)
do i=1,ni
dbdt(i) = 2.5 + .125 * temp(i)
dbdt(i) = max( min( dbdt(i) , 0.5 ) , 0.0 )
enddo
c
do k=1,nk
do i=1,ni
temp1=(sige(i,k)*1.25)*(sige(i,k)*1.25)
formf = min( temp1 , 1.0 )
if(ilab(i,k).eq.2.and.sige(i,k+1).lt.0.95) then
cck(i,k) = dbdt(i) * formf
else
cck(i,k) = 0.
endif
enddo
enddo
c
do i=1,ni
dbdt(i)=dbdt(i)*1.389e-04
enddo
c
endif
c
c
c
return
end
*** S/P Mpxkap
SUBROUTINE Mpxkap (p,pk,ps,sig,pkappa,ptop,pscale,npkappa,ni,nk) 1
*
#include "impnone.cdk"
integer ni,nk,npkappa
real p(ni,nk), pk(ni,nk), ps(ni), sig(ni,nk), pkappa(npkappa)
real ptop,pscale
*
*Author
* S. Moorthi and M. Suarez (July 92) - Relaxed Arakawa-Schubert
*
*Revisions
*001 G. Pellerin (Avr 97) - Standard Documentation
*002 G. Pellerin (Mai 03) - Conversion IBM
* - calls to vslog routine (from massvp4 library)
* - calls to exponen4 (to calculate power function '**')
*003 B. Bilodeau (Aug 03) - exponen4 replaced by vspown1
*
*Object
* This routine computes (p/p00)**xkappa by using a linear interpolation
* between values from a look-up table. First, given pa=p-ptop it
* determines the largest value of p1<pa such that p1 is an integer
* multiple of pkappa(3). px-ip is the weight w=(pa-p1)/pkappa(3)
* Also compute p at sigma levels (change units).
*
*Arguments
* - Input -
* NPKAPPA dimension of pkappa
* NQSATVP dimension of qsatvp
* SIG Sigma levels
* PSCALE to compute p(mb) from psj(kgP),ptop and sigf
* PS Surface pressure
* PKAPPA Exner function
* PTOP Model top pressure
* NI horizontal dimension
* NK vertical dimension
*
* - Output -
* P pressure at corresponding sigma levels
* PK corresponding table pressure
*
**
*
integer i, ip, k
real rdp, sf, px
*
rdp=1./pkappa(3)
do 1 k=1,nk
do 1 i=1,ni
sf=rdp*sig(i,k)
px=ps(i)*sf ! p-ptop in units of pkappa(3)
ip=int(px) ! p1 in units of pkappa(3)
p(i,k)=(ps(i)*sig(i,k)+ptop)*pscale
pk(i,k)=1./(pkappa(ip+4)+(px-ip)*(pkappa(ip+5)-pkappa(ip+4)))
1 continue
c
return
end
*** S/P Mracritn
SUBROUTINE Mracritn(LEN,PL, PLB, ACR) 1
*
#include "impnone.cdk"
INTEGER LEN
REAL PL(LEN), PLB(LEN), ACR(LEN)
*
*Author
* S. Moorthi and M. Suarez (July 92) - Relaxed Arakawa-Schubert
*
*Revisions
*001 G. Pellerin (Avr 97) - Standard Documentation
*002 G. Pellerin (Mai 03) - Conversion IBM
*
*Object
* determine maximum level k allowed for clouds
*
*Arguments
* - Input -
* LEN inner dimension of input arrays
* PL top pressure
* PLB bottom pressure
*
* - Output -
* ACR maximum level k allowed for clouds
*
**
*
INTEGER I, IWK
clee REAL IWK(LEN)
*
#include "rasdata.cdk"
*
*
DO 20 I=1,LEN
clee IWK(I) = PL(I) * 0.02 - 0.999999999
clee IF (IWK(I) .GT. 1) THEN
clee IF (IWK(I) .LE. 15) THEN
clee ACR(I) = AC(IWK(I)) + PL(I) * AD(IWK(I))
IWK = PL(I) * 0.02 - 0.999999999
IF (IWK .GT. 1) THEN
IF (IWK .LE. 15) THEN
ACR(I) = AC(IWK) + PL(I) * AD(IWK)
ELSE
ACR(I) = A(15)
ENDIF
ELSE
ACR(I) = ACTOP
ENDIF
20 CONTINUE
DO 25 I=1,LEN
ACR(I) = ACR(I) * (PLB(I) - PL(I))
25 CONTINUE
RETURN
END
*** S/P Mras
SUBROUTINE Mras (LEN, LENC, K, DT, KP1, KM1, lcontrl 1,3
+, ISEED, NCRND, KRMIN, KRMAX, FRAC, RASAL, BOTOP
+, CP, ALHL, RKAP, GRAV, P00, CRTMSF
+, POI, QOI, UOI, VOI, PRS, PRJ
+, CUP, CLM, Q1, Q2
+, ALF, BET, GAM, PRH, PRI, HOI, ETA, TCU, QCU
+, HST, QOL, GMH
+, TX1, TX2, TX3, TX4, TX5, TX6, TX7, TX8, TX9
+, WFN, AKM, QS1, CLF, UHT, VHT, WLQ, PCU
+, IA, I1, I2, qsatvp, nqsatvp, cmass, work1, qeq)
*
#include "impnone.cdk"
*
integer len, lenc, k, kp1, km1, ncrnd, krmin, krmax, nqsatvp
real dt, frac, cp, alhl, rkap, grav, p00, crtmsf
REAL POI(LEN,K), QOI(LEN,K), PRS(LEN,KP1), PRJ(LEN,KP1),
* UOI(LEN,K), VOI(LEN,K)
REAL Q1(LEN,K), Q2(LEN,K), CLM(LEN,K), CUP(LEN),
* TCU(LEN,K), QCU(LEN,K), cmass(len,k)
REAL ALF(LEN,K), BET(LEN,K), GAM(LEN,K), GMH(LENC,K),
* ETA(LENC,K), HOI(LENC,K), HST(LENC,K), QOL(LENC,K),
* PRH(LEN,K), PRI(LEN,K)
REAL TX1(LENC), TX2(LENC), TX3(LENC), TX4(LENC), TX5(LENC),
* TX6(LENC), TX7(LENC), TX8(LENC), TX9(LENC),
* WFN(LENC), AKM(LENC), QS1(LENC), WLQ(LENC), PCU(LENC),
* UHT(LENC), VHT(LENC), CLF(LENC), qeq(lenc)
INTEGER IA(LENC), I1(LENC), I2(LENC), ISEED
REAL RASAL(KM1), qsatvp (nqsatvp)
real work1(lenc,6)
logical botop, lcontrl
*
*Author
* S. Moorthi and M. Suarez (July 92) - Relaxed Arakawa-Schubert
* Laboratory for Atmospheres
* NASA/GSFC, Greenbelt, MD 20771.
*
*Revisions
* Luc Fillion - Jan 1996 - Random generator made compatible with
* 1dvar library.
* G. Pellerin (Avr 97) - Standard Documentation
* G. Pellerin (Mai 03) - Conversion IBM
*
*Object
* This is a plug-compatible driver for subroutine CLOUD. CLOUD does
* the adjustment calculation for a single cloud and is also a
* plug-compatible routine. Subroutine RAS decides the sequence
* in which clouds are called and updates the soundings between calls.
* The way in which the relaxation is done is thus easily changed
* by modifying RAS. Most of the complicated calculations of
* Moorthi and Suarez (1992, MWR) are contained in the CLOUD routine.
* It is probably advisable, at least initially, to treat CLOUD
* as a black box that computes the single cloud adjustments. RAS,
* on the other hand, can be tailored to each GCM's configuration
* (ie, number and placement of levels, nature of boundary layer,
* time step and frequency with which RAS is called). This version
* of RAS is the one used in the ARIES GCM at Goddard and already
* provides considerable flexibility in controlling the adjustment
* through the argument list.
*
*Arguments
* - Input -
* LEN The inner dimension of update and input arrays.
* LENC The number of soundings processes in a single call.
* LENC is thus the horizontal dimension over which
* convection is invoked.
* RAS works on the first LENC of the LEN soundings
* passed. This allows working on pieces of the world
* say for multitasking, without declaring temporary arrays
* and copying the data to and from them. This is an f77
* version. An F90 version would have to allow more
* flexibility in the argument declarations. Obviously
* (LENC<=LEN).
* K Number of vertical layers (increasing downwards).
* Need not be the same as the number of layers in the
* GCM, since it is the outer dimension. The bottom layer
* (K) is the subcloud layer.
* DT Time step in seconds
* KP1 number of vertical layers + 1
* KM1 number of vertical layers - 1
* NCRND Number random cloud-types between KRMIN and KRMAX to be
* invoked in a single call to RASE
* KRMIN Index of the top most level to which random clouds may
* be invoked
* KRMAX Index of the bottom most level to which random clouds
* may be invoked. KRMIN should be .LE. KRMAX. If NCRND
* is specified as zero, then all cloud-types below the
* level KRMAX will be called sequentially.
* FRAC Fraction of the PBL (layer K) mass allowed to be used
* by a cloud-type in time DT
* RASAL Array of dimension K-1 containing relaxation parameters
* (< 1.) for cloud-types detraining at levels 1 to K-1
* BOTOP A logical variable -- .true. if sequential clouds are
* called from bottom to top and .false. if top to bottom.
* CP Specific heat at constant pressure
* ALHL Latent Heat of condensation
* RKAP R/Cp, where R is the gas constant
* GRAV Acceleration due to gravity
* P00 A reference pressure in hPa, useually 1000 hPa
* CRTMSF Critical value of mass flux above which cloudiness at
* the detrainment layer of that cloud-type is assumed.
* Affects only cloudiness calculation.
* POI 2D array of dimension (LEN,K) containing potential
* temperature. Updated but not initialized by RAS.
* QOI 2D array of dimension (LEN,K) containing specific
* humidity. Updated but not initialized by RAS.
* UOI 2D array of dimension (LEN,K) containing u-wind
* Used onlly with cumulus friction.
* Updated but not initialized by RAS.
* VOI 2D array of dimension (LEN,K) containing v-wind
* Used onlly with cumulus friction.
* Updated but not initialized by RAS.
* PRS 2D array of dimension (LEN,K+1) containing pressure
* in hPa at the interfaces of K-layers from top of the
* atmosphere to the bottom. Not modified.
* PRJ 2D array of dimension (LEN,K+1) containing (PRS/P00) **
* RKAP. i.e. Exner function at layer edges. Not modified.
* QSATVP tabulated values for saturation vapor pressure as a
* function of T
* NQSATVP dimension of qsatvp
* LCONTRL If false, indicates that this is a run for computing
* effects of perturbations for Jacobian calculation.
* In that case, must not do test on precip amount
* because the control value may be just above the
* threshhold but the perturb value just below, and then
* the latter is set to zero yielding large error in
* the differences used to compute the Jacobian.
* ISEED not used
*
* - Output -
* CUP 1D array of length LEN containing accumulated
* precipitation in mm/sec.
* Updated but not initialized by RAS.
* CLM 2D array of dimension (LEN,K) containing cloudiness
* Updated but not initialized by RAS.
* Q1 2D array of dimension (LEN,K) containing accumulated
* convective heating (K/sec). Updated but not
* initialized by RAS.
* Q2 2D array of dimension (LEN,K) containing accumulated
* convective drying (kg/kg/sec).
* Updated but not initialized by RAS.
* cmass convective mass flux
*
* - Input -
* WORK1 work field (lenc,6)
* TCU work field (lenc,k)
* QCU work field (lenc,k)
* ALF work field (lenc,k)
* BET work field (lenc,k)
* GAM work field (lenc,k)
* PRH work field (lenc,k)
* PRI work field (lenc,k)
* HOI work field (lenc,k)
* ETA work field (lenc,k)
* HST work field (lenc,k)
* QOL work field (lenc,k)
* GMH work field (lenc,k)
* TX1 work field (lenc)
* TX2 work field (lenc)
* TX3 work field (lenc)
* TX4 work field (lenc)
* TX5 work field (lenc)
* TX6 work field (lenc)
* TX7 work field (lenc)
* TX8 work field (lenc)
* TX9 work field (lenc)
* WFN work field (lenc)
* AKM work field (lenc)
* QS1 work field (lenc)
* CLF work field (lenc)
* UHT work field (lenc)
* VHT work field (lenc)
* WLQ work field (lenc)
* PCU work field (lenc)
* IA work field (lenc)
* I1 work field (lenc)
* I2 work field (lenc)
* QEQ work field (lenc)
*
*Notes
* For tuning:
* parameter FACM in routine = MRACRITN for determining
* critical value for convection: 1<= facm < 2. (This appear
* to have little effect)
* variable frac in routine = Msub1 for definining the fraction of
* mass in lowest layer available for convective flux in 1 time
* step
* parameter PT8 in routine = MRNCL should be between 0.8 and 0.2.
* Smaller values wil reduce the amount of shallow convection
* array rc in routine = Mrasrc are relaxation parameters,
* determined by the the time scales (parameters) t1 and t2
* for convective equilibriation to occur.
* parameter critprec in routine = Mras removes adjustment in
* vertical comumns where the rates of precip are small.
* critprec=minimum precip (mm/day) allowed.
* Columns with slower rates are treated as nonconvective
* (heating, moistening, precip set to 0)
*
**
*
integer icm, jj
real critprec, critfac, daylen, one
Parameter (critprec=3., daylen=24.*60.*60.)
Parameter (critfac=critprec/daylen)
*
PARAMETER (ICM=100)
PARAMETER (ONE=1.0)
COMMON /point/ jj
integer i, ib, irnd, kcr, kfx, l, ncmx, nc
INTEGER IC(ICM)
#include "comras.cdk"
real onbdt, fracs, rasalf, ttmax1
LOGICAL SETRAS
real ran2
external ran2
C Have CLOUD recompute QSAT parameters, layer p**kappa etc on each call
C In the GCM, for economy, I compute these outside RAS and assume they
C do not as each cloud adjusts the sounding in RAS.
ONBDT = ONE / DT
FRACS = FRAC * ONBDT
C Set number of clouds to adjust during this call to RAS, NCMX,
C and the cloud calling sequence, IC. This allows various
C combinations of randomly and sequentially called clouds.
KCR = MIN(KM1,KRMAX)
KFX = KM1 - KCR
NCMX = KFX + NCRND
IF (KFX .GT. 0) THEN
IF (BOTOP) THEN
DO 20 NC=1,KFX
IC(NC) = K - NC
20 CONTINUE
ELSE
DO 25 NC=KFX,1,-1
IC(NC) = K - NC
25 CONTINUE
ENDIF
ENDIF
IF (NCRND .GT. 0) THEN
DO 30 I=1,NCRND
IRND = (RAN2(I)-0.0005)*(KCR-KRMIN+1)
IC(KFX+I) = IRND + KRMIN
30 CONTINUE
ENDIF
C Loop over clouds to be adjusted during this call
SETRAS = .TRUE.
DO 100 NC=1,NCMX
IB = IC(NC)
RASALF = RASAL(IB)*ONBDT
CALL Mras2 (LEN, LENC, K, IB, RASALF, SETRAS, FRACS, KP1
*, CP, ALHL, RKAP, GRAV, P00, CRTMSF
*, POI, QOI, UOI, VOI, PRS, PRJ
*, PCU, CLM(1,IB), TCU, QCU
*, ALF, BET, GAM, PRH, PRI, HOI, ETA
*, HST, QOL, GMH
*, TX1, TX2, TX3, TX4, TX5, TX6, TX7, TX8, TX9
*, WFN, AKM, QS1, CLF, UHT, VHT, WLQ
*, IA, I1, I2, qsatvp, nqsatvp, cmass, nc)
SETRAS=.FALSE.
DO 50 L=IB,K
DO 40 I=1,LENC
c Update pot. temp. and humidity.
POI(I,L) = POI(I,L) + TCU(I,L) * DT
QOI(I,L) = QOI(I,L) + QCU(I,L) * DT
C Cumulus friction should be disabled be commenting the next 2 lines
c UOI(I,L) = UOI(I,L) + HST(I,L) * DT
c VOI(I,L) = VOI(I,L) + QOL(I,L) * DT
C Heating and moitening diagnostics
Q1(I,L) = Q1(I,L) + TCU(I,L) * PRH(I,L)
Q2(I,L) = Q2(I,L) + QCU(I,L)
40 CONTINUE
50 CONTINUE
*
*
C RAINFALL DIAGNOSTIC (MM/TIMESTEP)
do I=1,LENC
pcu(i) = PCU(I) * DT
enddo
c
c re-evaporation of rain
c
if(levap) then
DO L=IB,K
c
DO I=1,LENC
ttmax1= POI(I,L)*PRH(I,L)
work1(I,1)= ttmax1 ! TTMAX(I)
work1(I,2)= ttmax1 ! ttold(i)
work1(I,3)= QOI(I,L) ! QQMAX(I)
work1(I,4)=.5*(PRS(I,L+1)+PRS(I,L)) ! PLMAX(I)
work1(I,5)= (PRS(I,L+1)-PRS(I,L)) ! DPLMAX(I)
work1(I,6)= .25 ! CLFRMAX(I)
ENDDO
CALL Mras3 (LENC,work1,work1(1,3),pcu,work1(1,4),work1(1,5),
+ work1(1,6),dt,grav,cp,alhl,qsatvp,qeq,nqsatvp)
C Heating and moistening diagnostics ONBDT= 1/dt
DO I=1,LENC
Q1(I,L) = Q1(I,L) + (work1(i,1) - work1(i,2))*ONBDT
Q2(I,L) = Q2(I,L) + (work1(i,3) - qoi(i,L))*ONBDT
ENDDO
ENDDO
endif
*
*
C RAINFALL DIAGNOSTIC (MM/SEC) ONBDT= 1/dt
do I=1,LENC
CUP(I) = CUP(I) + PCU(I) * ONBDT
enddo
100 CONTINUE
c
c remove weak convection based on precip rate
c
if (lcontrl) then
do I=1,lenc
IF (cup(i).lt.critfac) then
cup(I)=0.
do L=1,K
q1(I,L)=0.
q2(I,L)=0.
enddo
endif
enddo
endif ! test on lcontrl
RETURN
END
*** S/P Mrasrc
SUBROUTINE Mrasrc (rc,sigf,dti,nk) 1
*
#include "impnone.cdk"
integer nk
real rc(nk-1), sigf(nk+1)
real dti
*
*Author
* S. Moorthi and M. Suarez (July 92) - Relaxed Arakawa-Schubert
*
*Revisions
* G. Pellerin (Avr 97) - Standard Documentation
*
*Object
* Set relaxation coefficients for RAS as a function of depth.
* The times t1 and t2 are those for clouds of depths ds1 and ds2 to
* equilibriate the environment (depths in sigma).
* Formula is linear in depth measured in terms of sigma (necessary
* since coefs must apply to all points adjusted in each slice)
* rt = a + b * delta s
* Linear coefficients determined by the pair of points
* (t1,ds1), (t2,ds2). Relaxation time scale in sec.
* Relaxation coefficient must be less than or equal to 0.3
* rc = min (0.3, dti/rt)
*Arguments
* - Input -
* SIGF sigma levels
* DTI timestep
* NK vertical dimension
*
* - Output -
* RC Relaxation coefficient
*
**
*
real t1, ds1, t2, ds2, b, a
parameter (t1=3.*60.*60., ds1=0.7, t2=60.*60., ds2=0.1)
parameter (b=(t1-t2)/(ds1-ds2), a=t1-b*ds1)
integer k, nkp1
real rt
*
nkp1=nk+1
do k=1,nk-1
rt=a+b*(sigf(nkp1)-sigf(k))
rc(k)=amin1(0.3,dti/rt)
enddo
c
return
end
*** S/P Mraspkh
SUBROUTINE Mraspkh (pkh,pkf,pf,xkap,ni,nk) 1
*
#include "impnone.cdk"
integer ni, nk
real pkh(ni,nk), pkf(ni,nk), pf(ni,nk), xkap
*Author
* S. Moorthi and M. Suarez (July 92) - Relaxed Arakawa-Schubert
*
*Revisions
*001 G. Pellerin (Avr 97) - Standard Documentation
*002 G. Pellerin (Mai 03) - Conversion IBM
*
*Object
* Compute data level values of (poo/p)**k using Arakawa scheme
*
*Arguments
* - Input -
* XKAP R/Cp, where R is the gas constant
* NI horizontal dimension
* NK vertical dimension
* PKF p at interface levels
*
* - Output -
* PKH potential temperature at data levels
*
**
integer i, k
real xkap1
*
xkap1=xkap+1
do k=1,nk-1
do i=1,ni
pkh(i,k)=(pkf(i,k+1)*pf(i,k+1)-pkf(i,k)*pf(i,k))/
& ((pf(i,k+1)-pf(i,k))*xkap1)
enddo ! loop over i
enddo ! loop over k
return
end
*
*** S/P Mras2
SUBROUTINE Mras2 (LEN, LENC, K, IC, RASALF, SETRAS, FRAC, KP1 1,3
*, CP, ALHL, RKAP, GRAV, P00, CRTMSF
*, POI, QOI, UOI, VOI, PRS, PRJ
*, PCU, CLM, TCU, QCU
*, ALF, BET, GAM, PRH, PRI, HOL, ETA
*, HST, QOL, GMH
*, TX1, TX2, TX3, TX4, TX5, TX6, TX7, TX8, ALM
*, WFN, AKM, QS1, CLF, UHT, VHT, WLQ
*, IA, I1, I2, qsatvp, nqsatvp, cmass, nc)
*
#include "impnone.cdk"
*
integer len, lenc, k, ic, kp1, nqsatvp, nc
REAL POI(LEN,K), QOI(LEN,K), PRS(LEN,K+1),
* UOI(LEN,K), VOI(LEN,K), PRJ(LEN,K+1),
* CLM(LEN)
REAL CMASS(LEN,K), RASALF, FRAC, CP, ALHL, RKAP, GRAV, P00, CRTMSF
REAL TCU(LEN,K),QCU(LEN,K),PCU(LENC)
REAL PRH(LEN,K),ALF(LEN,K),BET(LEN,K),GAM(LEN,K),PRI(LEN,K)
REAL TX1(LENC),TX2(LENC),TX3(LENC),TX4(LENC),TX5(LENC)
REAL AKM(LENC), WFN(LENC)
REAL HOL(LENC,K), ETA(LENC,K),
+ GMH(LENC,K), ALM(LENC), WLQ(LENC), QS1(LENC),
+ TX6(LENC), TX7(LENC), TX8(LENC),
+ UHT(LENC), VHT(LENC), CLF(LENC)
INTEGER IA(LENC), I1(LENC), I2(LENC)
REAL HST(LENC,K),QOL(LENC,K)
REAL QSATVP(NQSATVP)
LOGICAL SETRAS
*
*Author
* S. Moorthi and M. Suarez (July 92) - Relaxed Arakawa-Schubert
*
*Revisions
*001 G. Pellerin (Avr 97) - Standard Documentation
*002 G. Pellerin (Mai 03) - Conversion IBM
*
*Object
* determine maximum level k allowed for clouds
*
*Arguments
*
* - Input -
* LEN The inner dimension of update and input arrays.
* LENC The number of soundings processes in a single call.
* LENC is thus the horizontal dimension over which
* convection is invoked.
* RAS works on the first LENC of the LEN soundings
* passed. This allows working on pieces of the world
* say for multitasking, without declaring temporary arrays
* and copying the data to and from them. This is an f77
* version. An F90 version would have to allow more
* flexibility in the argument declarations. Obviously
* (LENC<=LEN).
* IC number of clouds to adjust
* RASALF relaxation parameters
* K Number of vertical layers (increasing downwards).
* Need not be the same as the number of layers in the
* GCM, since it is the outer dimension. The bottom layer
* (K) is the subcloud layer.
*
* DT Time step in seconds
* NCRND Number random cloud-types between KRMIN and KRMAX to be
* invoked in a single call to RASE
* KRMIN Index of the top most level to which random clouds may
* be invoked
* KRMAX Index of the bottom most level to which random clouds
* may be invoked. KRMIN should be .LE. KRMAX. If NCRND
* is specified as zero, then all cloud-types below the
* level KRMAX will be called sequentially.
* FRAC Fraction of the PBL (layer K) mass allowed to be used
* by a cloud-type in time DT
* KP1 Number of levels +1
* NC key integer for SETRAS=.true
* RASAL Array of dimension K-1 containing relaxation parameters
* (< 1.) for cloud-types detraining at levels 1 to K-1
* BOTOP A logical variable -- .true. if sequential clouds are
* called from bottom to top and .false. if top to bottom.
* CP Specific heat at constant pressure
* ALHL Latent Heat of condensation
* RKAP R/Cp, where R is the gas constant
* GRAV Acceleration due to gravity
* P00 A reference pressure in hPa, useually 1000 hPa
* CRTMSF Critical value of mass flux above which cloudiness at
* the detrainment layer of that cloud-type is assumed.
* Affects only cloudiness calculation.
* POI 2D array of dimension (LEN,K) containing potential
* temperature. Updated but not initialized by RAS.
* QOI 2D array of dimension (LEN,K) containing specific
* humidity. Updated but not initialized by RAS.
* UOI 2D array of dimension (LEN,K) containing u-wind
* Used onlly with cumulus friction.
* Updated but not initialized by RAS.
* VOI 2D array of dimension (LEN,K) containing v-wind
* Used onlly with cumulus friction.
* Updated but not initialized by RAS.
* PRS 2D array of dimension (LEN,K+1) containing pressure
* in hPa at the interfaces of K-layers from top of the
* atmosphere to the bottom. Not modified.
* PRJ 2D array of dimension (LEN,K+1) containing (PRS/P00) **
* RKAP. i.e. Exner function at layer edges. Not modified.
* QSATVP tabulated values for saturation vapor pressure as a
* function of T
* NQSATVP dimension of qsatvp
* LCONTRL If false, indicates that this is a run for computing
* effects of perturbations for Jacobian calculation.
* In that case, must not do test on precip amount
* because the control value may be just above the
* threshhold but the perturb value just below, and then
* the latter is set to zero yielding large error in
* the differences used to compute the Jacobian.
* SETRAS unused
* ETA Temporary work field
*
* - Input/Output -
* HOL specific humidity tendency
*
* - Output -
* CUP 1D array of length LEN containing accumulated
* precipitation in mm/sec.
* Updated but not initialized by RAS.
* CLM 2D array of dimension (LEN,K) containing cloudiness
* Updated but not initialized by RAS.
* Q1 2D array of dimension (LEN,K) containing accumulated
* convective heating (K/sec). Updated but not
* initialized by RAS.
* Q2 2D array of dimension (LEN,K) containing accumulated
* convective drying (kg/kg/sec).
* Updated but not initialized by RAS.
* cmass convective mass flux
*
* - Input -
* TCU work field (lenc,k)
* QCU work field (lenc,k)
* ALF work field (lenc,k)
* BET work field (lenc,k)
* GAM work field (lenc,k)
* PRH work field (lenc,k)
* PRI work field (lenc,k)
* HOI work field (lenc,k)
* ETA work field (lenc,k)
* HST work field (lenc,k)
* QOL work field (lenc,k)
* GMH work field (lenc,k)
* TX1 work field (lenc)
* TX2 work field (lenc)
* TX3 work field (lenc)
* TX4 work field (lenc)
* TX5 work field (lenc)
* TX6 work field (lenc)
* TX7 work field (lenc)
* TX8 work field (lenc)
* TX9 work field (lenc)
* WFN work field (lenc)
* AKM work field (lenc)
* QS1 work field (lenc)
* CLF work field (lenc)
* UHT work field (lenc)
* VHT work field (lenc)
* WLQ work field (lenc)
* PCU work field (lenc)
* IA work field (lenc)
* I1 work field (lenc)
* I2 work field (lenc)
*
*
**
*
real daylen, half, one, zero, cmb2pa, rhmax
PARAMETER (DAYLEN=86400.0, HALF=0.5, ONE=1.0, ZERO=0.0)
PARAMETER (CMB2PA=100.0)
PARAMETER (RHMAX=0.9999)
integer km1, ic1, i, l, len1, len2, isav, len11
integer lena, lenb, lena1, ii
real rkapp1, onebcp, albcp, onebg, cpbg, twobal, tem1, tem
real tem2
clee SAVE
C CFPP$ EXPAND (QSAT)
RKAPP1 = 1.0 + RKAP
ONEBCP = 1.0 / CP
ALBCP = ALHL * ONEBCP
ONEBG = 1.0 / GRAV
CPBG = CP * ONEBG
TWOBAL = 2.0 / ALHL
KM1 = K - 1
IC1 = IC + 1
C SETTIING ALF, BET, GAM, PRH, AND PRI : DONE ONLY WHEN SETRAS=.T.
Clee IF (SETRAS) THEN
IF (NC.eq.1) THEN
DO 2050 L=1,K
DO 2030 I=1,LENC
PRH(I,L) = (PRJ(I,L+1)*PRS(I,L+1) - PRJ(I,L)*PRS(I,L))
* / ((PRS(I,L+1)-PRS(I,L)) * RKAPP1)
2030 CONTINUE
2050 CONTINUE
DO 2070 L=1,K
DO I=1,LENC
TX3(I) = POI(I,L) * PRH(I,L)
TX1(I) = (PRS(I,L) + PRS(I,L+1)) * 0.5
ENDDO
CALL MRQSAT (TX3,TX1,TX2,TX4,.TRUE.,lenc,qsatvp,nqsatvp)
DO I=1,LENC
* TX4(I)= tx4(i) *CP/ALHL
ALF(I,L) = TX2(I) - TX4(I) * tx3(I)
BET(I,L) = TX4(I) * PRH(I,L)
GAM(I,L) = 1.0 / ((1.0 + TX4(I)*ALBCP) * PRH(I,L))
PRI(I,L) = (CP/CMB2PA) / (PRS(I,L+1) - PRS(I,L))
ENDDO
2070 CONTINUE
clee SETRAS = .FALSE.
ENDIF
DO 10 L=1,K
DO 10 I=1,LEN
TCU(I,L) = 0.0
QCU(I,L) = 0.0
10 CONTINUE
DO 30 I=1,LENC
TX1(I) = PRJ(I,K+1) * POI(I,K)
QS1(I) = ALF(I,K) + BET(I,K)*POI(I,K)
QOL(I,K) = AMIN1(QS1(I)*RHMAX,QOI(I,K))
HOL(I,K) = TX1(I)*CP + QOL(I,K)*ALHL
ETA(I,K) = ZERO
TX2(I) = (PRJ(I,K+1) - PRJ(I,K)) * POI(I,K) * CP
30 CONTINUE
IF (IC .LT. KM1) THEN
DO 3703 L=KM1,IC1,-1
DO 50 I=1,LENC
QS1(I) = ALF(I,L) + BET(I,L)*POI(I,L)
QOL(I,L) = AMIN1(QS1(I)*RHMAX,QOI(I,L))
TEM1 = TX2(I) + PRJ(I,L+1) * POI(I,L) * CP
HOL(I,L) = TEM1 + QOL(I,L )* ALHL
HST(I,L) = TEM1 + QS1(I) * ALHL
TX1(I) = (PRJ(I,L+1) - PRJ(I,L)) * POI(I,L)
ETA(I,L) = ETA(I,L+1) + TX1(I)*CPBG
TX2(I) = TX2(I) + TX1(I)*CP
50 CONTINUE
3703 CONTINUE
ENDIF
DO 70 I=1,LENC
HOL(I,IC) = TX2(I)
QS1(I) = ALF(I,IC) + BET(I,IC)*POI(I,IC)
QOL(I,IC) = AMIN1(QS1(I)*RHMAX,QOI(I,IC))
TEM1 = TX2(I) + PRJ(I,IC1) * POI(I,IC) * CP
HOL(I,IC) = TEM1 + QOL(I,IC) * ALHL
HST(I,IC) = TEM1 + QS1(I) * ALHL
TX3(I ) = (PRJ(I,IC1) - PRH(I,IC)) * POI(I,IC)
ETA(I,IC) = ETA(I,IC1) + CPBG * TX3(I)
70 CONTINUE
DO 130 I=1,LENC
TX2(I) = HOL(I,K) - HST(I,IC)
TX1(I) = ZERO
130 CONTINUE
C ENTRAINMENT PARAMETER
DO 160 L=IC,KM1
DO 160 I=1,LENC
TX1(I) = TX1(I) + (HST(I,IC) - HOL(I,L)) * (ETA(I,L) - ETA(I,L+1))
160 CONTINUE
LEN1 = 0
LEN2 = 0
ISAV = 0
DO 195 I=1,LENC
IF (TX1(I) .GT. ZERO .AND. TX2(I) .GT. ZERO) THEN
LEN1 = LEN1 + 1
IA(LEN1) = I
ALM(LEN1) = TX2(I) / TX1(I)
ENDIF
195 CONTINUE
LEN2 = LEN1
if (IC1 .lt. K) then
DO 196 I=1,LENC
IF (TX2(I) .LE. 0.0 .AND. (HOL(I,K) .GT. HST(I,IC1))) THEN
LEN2 = LEN2 + 1
IA(LEN2) = I
ALM(LEN2) = 0.0
ENDIF
196 CONTINUE
endif
IF (LEN2 .EQ. 0) THEN
DO 5010 I=1,LENC*K
HST(I,1) = 0.0
QOL(I,1) = 0.0
5010 CONTINUE
DO 5020 I=1,LENC
PCU(I) = 0.0
5020 CONTINUE
RETURN
ENDIF
LEN11 = LEN1 + 1
C NORMALIZED MASSFLUX
DO 250 I=1,LEN2
ETA(I,K) = 1.0
II = IA(I)
TX2(I) = 0.5 * (PRS(II,IC) + PRS(II,IC1))
TX4(I) = PRS(II,K)
250 CONTINUE
DO 252 I=LEN11,LEN2
WFN(I) = 0.0
II = IA(I)
IF (HST(II,IC1) .LT. HST(II,IC)) THEN
TX6(I) = (HST(II,IC1)-HOL(II,K))/(HST(II,IC1)-HST(II,IC))
ELSE
TX6(I) = 0.0
ENDIF
TX2(I) = 0.5 * (PRS(II,IC1)+PRS(II,IC1+1)) * (1.0-TX6(I))
* + TX2(I) * TX6(I)
252 CONTINUE
CALL MRACRITN(LEN2, TX2, TX4, TX3)
DO 260 L=KM1,IC,-1
DO 255 I=1,LEN2
TX1(I) = ETA(IA(I),L)
255 CONTINUE
DO 260 I=1,LEN2
ETA(I,L) = 1.0 + ALM(I) * TX1(I)
260 CONTINUE
C CLOUD WORKFUNCTION
IF (LEN1 .GT. 0) THEN
DO 270 I=1,LEN1
II = IA(I)
WFN(I) = - GAM(II,IC) * (PRJ(II,IC1) - PRH(II,IC))
* * HST(II,IC) * ETA(I,IC1)
270 CONTINUE
ENDIF
DO 290 I=1,LEN2
II = IA(I)
TX1(I) = HOL(II,K)
290 CONTINUE
IF (IC1 .LE. KM1) THEN
DO 380 L=KM1,IC1,-1
DO 380 I=1,LEN2
II = IA(I)
TEM = TX1(I) + (ETA(I,L) - ETA(I,L+1)) * HOL(II,L)
PCU(I) = PRJ(II,L+1) - PRH(II,L)
TEM1 = ETA(I,L+1) * PCU(I)
TX1(I) = TX1(I)*PCU(I)
PCU(I) = PRH(II,L) - PRJ(II,L)
TEM1 = (TEM1 + ETA(I,L) * PCU(I)) * HST(II,L)
TX1(I) = TX1(I) + TEM*PCU(I)
WFN(I) = WFN(I) + (TX1(I) - TEM1) * GAM(II,L)
TX1(I) = TEM
380 CONTINUE
ENDIF
LENA = 0
IF (LEN1 .GT. 0) THEN
DO 512 I=1,LEN1
II = IA(I)
WFN(I) = WFN(I) + TX1(I) * GAM(II,IC)*(PRJ(II,IC1)-PRH(II,IC))
* - TX3(I)
IF (WFN(I) .GT. 0.0) THEN
LENA = LENA + 1
I1(LENA) = IA(I)
I2(LENA) = I
TX1(LENA) = WFN(I)
TX2(LENA) = QS1(IA(I))
TX6(LENA) = 1.0
ENDIF
512 CONTINUE
ENDIF
LENB = LENA
DO 515 I=LEN11,LEN2
WFN(I) = WFN(I) - TX3(I)
IF (WFN(I) .GT. 0.0 .AND. TX6(I) .GT. 0.0) THEN
LENB = LENB + 1
I1(LENB) = IA(I)
I2(LENB) = I
TX1(LENB) = WFN(I)
TX2(LENB) = QS1(IA(I))
TX4(LENB) = TX6(I)
ENDIF
515 CONTINUE
IF (LENB .LE. 0) THEN
DO 5030 I=1,LENC*K
HST(I,1) = 0.0
QOL(I,1) = 0.0
5030 CONTINUE
DO 5040 I=1,LENC
PCU(I) = 0.0
5040 CONTINUE
RETURN
ENDIF
DO 516 I=1,LENB
WFN(I) = TX1(I)
QS1(I) = TX2(I)
516 CONTINUE
DO 520 L=IC,K
DO 517 I=1,LENB
TX1(I) = ETA(I2(I),L)
517 CONTINUE
DO 520 I=1,LENB
ETA(I,L) = TX1(I)
520 CONTINUE
LENA1 = LENA + 1
DO 510 I=1,LENA
II = I1(I)
TX8(I) = HST(II,IC) - HOL(II,IC)
510 CONTINUE
DO 530 I=LENA1,LENB
II = I1(I)
TX6(I) = TX4(I)
TEM = TX6(I) * (HOL(II,IC)-HOL(II,IC1)) + HOL(II,IC1)
TX8(I) = HOL(II,K) - TEM
TEM1 = TX6(I) * (QOL(II,IC)-QOL(II,IC1)) + QOL(II,IC1)
TX5(I) = TEM - TEM1 * ALHL
QS1(I) = TEM1 + TX8(I)*(ONE/ALHL)
TX3(I) = HOL(II,IC)
530 CONTINUE
DO 620 I=1,LENB
II = I1(I)
WLQ(I) = QOL(II,K) - QS1(I) * ETA(I,IC)
UHT(I) = UOI(II,K) - UOI(II,IC) * ETA(I,IC)
VHT(I) = VOI(II,K) - VOI(II,IC) * ETA(I,IC)
TX7(I) = HOL(II,K)
620 CONTINUE
DO 635 L=KM1,IC,-1
DO 630 I=1,LENB
II = I1(I)
TEM = ETA(I,L) - ETA(I,L+1)
WLQ(I) = WLQ(I) + TEM * QOL(II,L)
UHT(I) = UHT(I) + TEM * UOI(II,L)
VHT(I) = VHT(I) + TEM * VOI(II,L)
630 CONTINUE
635 CONTINUE
C CALCULATE GS AND PART OF AKM (THAT REQUIRES ETA)
DO 690 I=1,LENB
II = I1(I)
c TX7(I) = HOL(II,K)
TEM = (POI(II,KM1) - POI(II,K)) / (PRH(II,K) - PRH(II,KM1))
HOL(I,K) = TEM * (PRJ(II,K)-PRH(II,KM1))*PRH(II,K)*PRI(II,K)
HOL(I,KM1) = TEM * (PRH(II,K)-PRJ(II,K))*PRH(II,KM1)*PRI(II,KM1)
AKM(I) = ZERO
TX2(I) = 0.5 * (PRS(II,IC) + PRS(II,IC1))
690 CONTINUE
IF (IC1 .LE. KM1) THEN
DO 750 L=KM1,IC1,-1
DO 750 I=1,LENB
II = I1(I)
TEM = (POI(II,L-1) - POI(II,L)) * ETA(I,L)
* / (PRH(II,L) - PRH(II,L-1))
HOL(I,L) = TEM * (PRJ(II,L)-PRH(II,L-1)) * PRH(II,L)
* * PRI(II,L) + HOL(I,L)
HOL(I,L-1) = TEM * (PRH(II,L)-PRJ(II,L)) * PRH(II,L-1)
* * PRI(II,L-1)
AKM(I) = AKM(I) - HOL(I,L)
* * (ETA(I,L) * (PRH(II,L)-PRJ(II,L)) +
* ETA(I,L+1) * (PRJ(II,L+1)-PRH(II,L))) / PRH(II,L)
750 CONTINUE
ENDIF
CALL MRNCL(LENB, TX2, TX1, CLF)
DO 770 I=1,LENB
TX2(I) = (ONE - TX1(I)) * WLQ(I)
WLQ(I) = TX1(I) * WLQ(I)
TX1(I) = HOL(I,IC)
770 CONTINUE
DO 790 I=LENA1, LENB
II = I1(I)
TX1(I) = TX1(I) + (TX5(I)-TX3(I)+QOL(II,IC)*ALHL)*(PRI(II,IC)/CP)
790 CONTINUE
DO 800 I=1,LENB
HOL(I,IC) = TX1(I) - TX2(I) * ALBCP * PRI(I1(I),IC)
800 CONTINUE
IF (LENA .GT. 0) THEN
DO 810 I=1,LENA
II = I1(I)
AKM(I) = AKM(I) - ETA(I,IC1) * (PRJ(II,IC1) - PRH(II,IC))
* * TX1(I) / PRH(II,IC)
810 CONTINUE
ENDIF
C CALCULATE GH
DO 830 I=1,LENB
II = I1(I)
TX3(I) = QOL(II,KM1) - QOL(II,K)
GMH(I,K) = HOL(I,K) + TX3(I) * PRI(II,K) * (ALBCP*HALF)
AKM(I) = AKM(I) + GAM(II,KM1)*(PRJ(II,K)-PRH(II,KM1))
* * GMH(I,K)
830 CONTINUE
IF (IC1 .LE. KM1) THEN
DO 840 L=KM1,IC1,-1
DO 840 I=1,LENB
II = I1(I)
TX2(I) = TX3(I)
TX3(I) = (QOL(II,L-1) - QOL(II,L)) * ETA(I,L)
TX2(I) = TX2(I) + TX3(I)
GMH(I,L) = HOL(I,L) + TX2(I) * PRI(II,L) * (ALBCP*HALF)
840 CONTINUE
ENDIF
DO 850 I=LENA1,LENB
TX3(I) = TX3(I) + TWOBAL
* * (TX7(I) - TX8(I) - TX5(I) - QOL(I1(I),IC)*ALHL)
850 CONTINUE
DO 860 I=1,LENB
GMH(I,IC) = TX1(I) + PRI(I1(I),IC) * ONEBCP
* * (TX3(I)*(ALHL*HALF) + ETA(I,IC) * TX8(I))
860 CONTINUE
C CALCULATE HC PART OF AKM
IF (IC1 .LE. KM1) THEN
DO 870 I=1,LENB
TX1(I) = GMH(I,K)
870 CONTINUE
DO 3725 L=KM1,IC1,-1
DO 880 I=1,LENB
II = I1(I)
TX1(I) = TX1(I) + (ETA(I,L) - ETA(I,L+1)) * GMH(I,L)
TX2(I) = GAM(II,L-1) * (PRJ(II,L) - PRH(II,L-1))
880 CONTINUE
IF (L .EQ. IC1) THEN
DO 890 I=LENA1,LENB
TX2(I) = ZERO
890 CONTINUE
ENDIF
DO 900 I=1,LENB
II = I1(I)
AKM(I) = AKM(I) + TX1(I) *
* (TX2(I) + GAM(II,L)*(PRH(II,L)-PRJ(II,L)))
900 CONTINUE
3725 CONTINUE
ENDIF
DO 920 I=LENA1,LENB
II = I1(I)
TX2(I) = 0.5 * (PRS(II,IC) + PRS(II,IC1))
* + 0.5*(PRS(II,IC+2) - PRS(II,IC)) * (ONE-TX6(I))
TX1(I) = PRS(II,IC1)
TX5(I) = 0.5 * (PRS(II,IC1) + PRS(II,IC+2))
IF ((TX2(I) .GE. TX1(I)) .AND. (TX2(I) .LT. TX5(I))) THEN
TX6(I) = ONE - (TX2(I) - TX1(I)) / (TX5(I) - TX1(I))
TEM = PRI(II,IC1) / PRI(II,IC)
HOL(I,IC1) = HOL(I,IC1) + HOL(I,IC) * TEM
HOL(I,IC) = ZERO
GMH(I,IC1) = GMH(I,IC1) + GMH(I,IC) * TEM
GMH(I,IC) = ZERO
ELSEIF (TX2(I) .LT. TX1(I)) THEN
TX6(I) = 1.0
ELSE
TX6(I) = 0.0
ENDIF
920 CONTINUE
clee PCU(:) = 0.0
do I=1,LENC
PCU(I) = 0.0
enddo
DO 970 I=1,LENB
II = I1(I)
IF (AKM(I) .LT. ZERO .AND. WLQ(I) .GE. 0.0) THEN
WFN(I) = - TX6(I) * WFN(I) * RASALF / AKM(I)
ELSE
WFN(I) = ZERO
ENDIF
TEM = (PRS(II,K+1)-PRS(II,K))*(CMB2PA*FRAC)
WFN(I) = AMIN1(WFN(I), TEM)
C compute cloud amount
TX1(I) = CLM(II)
IF (WFN(I) .GT. CRTMSF) TX1(I) = TX1(I) + CLF(I)
IF (TX1(I) .GT. ONE) TX1(I) = ONE
C PRECIPITATION
PCU(II) = WLQ(I) * WFN(I) * ONEBG
C CUMULUS FRICTION AT THE BOTTOM LAYER
TX4(I) = WFN(I) * (1.0/ALHL)
TX5(I) = WFN(I) * ONEBCP
970 CONTINUE
Clee----------------------------------------------------
C compute cloud mass flux for diagnostic output
DO L=IC+1,K
DO I=1,LENB
II = I1(I)
CMASS(II,L)= CMASS(II,L)+ ETA(I,L)*WFN(I)*ONEBG
ENDDO
ENDDO
c--------------------------------------------------------
DO 975 I=1,LENB
II = I1(I)
CLM(II) = TX1(I)
975 CONTINUE
C THETA AND Q CHANGE DUE TO CLOUD TYPE IC
c TEMA = 0.0
c TEMB = 0.0
DO 990 L=IC,K
DO 980 I=1,LENB
II = I1(I)
TEM = (GMH(I,L) - HOL(I,L)) * TX4(I)
TEM1 = HOL(I,L) * TX5(I)
TCU(II,L) = TEM1 / PRH(II,L)
QCU(II,L) = TEM
980 CONTINUE
c I = I1(IP1)
c TEM = (PRS(I,L+1)-PRS(I,L)) * (ONEBG*100.0)
c TEMA = TEMA + TCU(I,L) * PRH(I,L) * TEM * (CP/ALHL)
c TEMB = TEMB + QCU(I,L) * TEM
990 CONTINUE
DO 992 L=1,K
DO 992 I=1,LENC
HST(I,L) = 0.0
QOL(I,L) = 0.0
992 CONTINUE
C CUMULUS FRICTION AT THE BOTTOM LAYER
DO 995 I=1,LENB
II = I1(I)
TX5(I) = TX5(I) * HALF
TEM = TX5(I) * PRI(II,K)
TX1(I) = (UOI(II,KM1) - UOI(II,K))
TX2(I) = (VOI(II,KM1) - VOI(II,K))
HST(II,K) = TEM * TX1(I)
QOL(II,K) = TEM * TX2(I)
995 CONTINUE
C CUMULUS FRICTION AT ALL OTHER LEVELS
DO 1020 L=KM1,IC1,-1
DO 1010 I=1,LENB
II = I1(I)
TEM = TX5(I) * PRI(II,L)
TEM1 = TX1(I)
TEM2 = TX2(I)
TX1(I) = (UOI(II,L-1) - UOI(II,L)) * ETA(I,L)
TX2(I) = (VOI(II,L-1) - VOI(II,L)) * ETA(I,L)
TX3(I) = (TX1(I) + TEM1) * TEM
TX4(I) = (TX2(I) + TEM2) * TEM
1010 CONTINUE
DO 1020 I=1,LENB
II = I1(I)
HST(II,L) = TX3(I)
QOL(II,L) = TX4(I)
1020 CONTINUE
DO 1030 I=1,LENB
II = I1(I)
IF (TX6(I) .GE. 1.0) THEN
TEM = TX5(I) * PRI(II,IC)
ELSE
TEM = 0.0
ENDIF
TX1(I) = (TX1(I) + UHT(I) + UHT(I)) * TEM
TX2(I) = (TX2(I) + VHT(I) + VHT(I)) * TEM
1030 CONTINUE
DO 1040 I=1,LENB
II = I1(I)
HST(II,IC) = TX1(I)
QOL(II,IC) = TX2(I)
1040 CONTINUE
c temu = 0.0
c temv = 0.0
c do 1050 l=1,k
c do 1050 i=1,lenb
c ii = i1(ip1)
c ii = i1(i)
c temu = temu + hst(ii,l) / pri(ii,l) * cp
c temv = temv + qol(ii,l) / pri(ii,l) * cp
c1050 continue
C PENETRATIVE CONVECTION CALCULATION OVER
RETURN
END
*** S/P Mras3
SUBROUTINE Mras3 (irun,tl,ql,rain,pl,dpl,clfrac,dt,grav,cp,alhl, 1
& qsatvp,qeq,nqsatvp)
*
#include "impnone.cdk"
*
integer irun, nqsatvp
real tl(irun),ql(irun),rain(irun),pl(irun),dpl(irun)
real clfrac(irun)
real dt, grav, cp, alhl, eps
real qeq(irun), qsatvp(nqsatvp)
*
*Author
* S. Moorthi and M. Suarez (July 92) - Relaxed Arakawa-Schubert
*
*Revisions
*001 G. Pellerin (Avr 97) - Standard Documentation
*002 G. Pellerin (Mai 03) - Conversion IBM
*
*Object
* Calculate the amount of re-evaporation of rain in a
* single level as a function of the rain rate and
* moisture deficit amount. [Sud and Molod, MWR 1988]
*
*Arguments
* - Input -
* IRUN The number of grid points to calculate
* TL Temperature in deg K
* QL Specific Humidity in kg/kg
* RAIN Input rain rate in mm per time step
* PL Mid-level pressure in mb
* DPL pressure thickness of layer in mb
* CLFRAC Fraction of layer into which re-evaporation occurs
* DT Time step over which input rain occured in seconds
* GRAV Acceleration due to gravity
* CP Specific heat at constant pressure
* ALHL Latent Heat of condensation
* QSATVP tabulated values for saturation vapor pressure as a
* function of T
* NQSATVP dimension of qsatvp
* QEQ work field
*
* - Output -
* RCON Resulting rain amount after re-evaporation in mm per
* time step
*
*
**
*
real actevap,arearat,deltaq,mass,massinv,potevap
real teq,qsteq,dqdt
real elocp,gravcon,afc,facx
real temp1(irun),temp2(irun)
integer I
integer ipron
real rtrron, esfac, erfac, txron, vron, dron, dqdta
*
gravcon = 100./grav
elocp = alhl/cp
eps = .622
facx = 0.578
afc = -(1.04E-4*dt)*(3600./dt)**facx
rtrron=1./qsatvp(3)
esfac=18.01/28.97
erfac=(1.-esfac)/esfac
! arearat = 1. - exp( afc*(rain(i)*sqrt(pl(I)*0.001))**0.578 )
do I = 1,irun
temp1(i) = pl(I)*0.001
enddo
call vssqrt (temp1,temp1,irun)
do I = 1,irun
temp2(i) = rain(i)*temp1(i)
! temp2(i) = afc*(rain(i)*temp1(i))**facx
enddo
call vspown1 (temp2,temp2,facx,irun)
! do I = 1,irun
! temp2(i) = afc*temp2(i)
! enddo
! call vsexp(temp2,temp2,irun)
! end arearat
do I = 1,irun
if(rain(i).gt.0.) then
teq = tl(i)
qeq(i) = ql(i)
txron=(teq-qsatvp(2))*rtrron
ipron=int(txron)
vron=qsatvp(ipron+4)+(txron-ipron)*
& (qsatvp(ipron+5)-qsatvp(ipron+4))
dron=1./(.1*pl(i)-eps*erfac*vron)
qsteq=eps*vron*dron
dqdta = (qsatvp(ipron+5)-qsatvp(ipron+4))*rtrron
dqdt = (dqdta + erfac*qsteq) * dron
deltaq=(qsteq-qeq(i))/(1.+elocp*dqdt)
qeq(i)=qeq(i)+deltaq*.5
teq=teq-deltaq*elocp*.5
txron=(teq-qsatvp(2))*rtrron
ipron=int(txron)
vron=qsatvp(ipron+4)+(txron-ipron)*
& (qsatvp(ipron+5)-qsatvp(ipron+4))
dron=1./(.1*pl(i)-eps*erfac*vron)
qsteq=eps*vron*dron
dqdta = (qsatvp(ipron+5)-qsatvp(ipron+4))*rtrron
dqdt = (dqdta + erfac*qsteq) * dron
deltaq=(qsteq-qeq(i))/(1.+elocp*dqdt)
qeq(i)=qeq(i)+deltaq
teq=teq-deltaq*elocp
if(qeq(i).GT.ql(i)) then
mass = dpl(i) * gravcon
massinv = 1./mass
potevap = (qeq(i)-ql(i))*mass
arearat = 1. - exp(afc*temp2(i))
actevap = min( rain(i), potevap*arearat*min(1.,clfrac(i)) )
rain(I) = rain(I) - actevap
ql(I) = ql(I) + actevap*massinv
tl(I) = tl(I) - actevap*massinv*elocp
endif
endif
enddo
c
return
end
*** S/P MrncL
SUBROUTINE MrncL(LEN, PL, RNO, CLF) 1
*
#include "impnone.cdk"
*
INTEGER LEN
REAL PL(LEN), RNO(LEN), CLF(LEN)
*
*Author
* S. Moorthi and M. Suarez (July 92) - Relaxed Arakawa-Schubert
*
*Revisions
*001 G. Pellerin (Avr 97) - Standard Documentation
*002 G. Pellerin (Mai 03) - Conversion IBM
*
*Object
* determine maximum level k allowed for clouds
*
*Arguments
* - Input -
* LEN horizontal dimension
*
* - Output -
* CLF cloud fraction
*
**
*
integer i
real pt1, pfac, p4, p6, cucld, cfac, p5, p8, pt8
*
PARAMETER (P5=500.0, P8=800.0, PT8=0.3, PT1=1.0)
PARAMETER (PFAC=(PT1-PT8)/(P8-P5))
PARAMETER (P4=400.0, P6=401.0)
PARAMETER (CUCLD=0.5,CFAC=CUCLD/(P6-P4))
*
DO 10 I=1,LEN
RNO(I) = PT1
CLF(I) = CUCLD
IF (PL(I) .GE. P5 .AND. PL(I) .LE. P8) THEN
RNO(I) = (P8-PL(I))*PFAC + PT8
ELSEIF (PL(I) .GT. P8 ) THEN
RNO(I) = PT8
ENDIF
IF (PL(I) .GE. P4 .AND. PL(I) .LE. P6) THEN
CLF(I) = (P6-PL(I))*CFAC
ELSEIF (PL(I) .GT. P6 ) THEN
CLF(I) = 0.0
ENDIF
10 CONTINUE
RETURN
END
*** S/P Mrqsat
SUBROUTINE Mrqsat(TT,P,Q,DQDT,LDQDT,lenc,qsatvp,nqsatvp) 1
*
#include "impnone.cdk"
*
integer lenc, nqsatvp
real tt(lenc), p(lenc), q(lenc), dqdt(lenc), qsatvp(nqsatvp)
logical ldqdt
*
*Author
* S. Moorthi and M. Suarez (July 92) - Relaxed Arakawa-Schubert
*
*Revisions
*001 G. Pellerin (Avr 97) - Standard Documentation
*002 G. Pellerin (Mai 03) - Conversion IBM
*
*Object
* compute saturation specific humidity and its derivative
* with repect to temperature. A modification of RAS software to
* use MAMS1 table lookup.
*
*Arguments
*
* - Output -
* DQDT saturation specific humidity
*
* - Input -
* LDQDT logical switch to calculate DQDT
* TT Temperature in deg K
* Q Specific Humidity in kg/kg
* P pressure level in mb
* LENC horizontal dimension over which convection is invoked
* QSATVP tabulated values for saturation vapor pressure as a
* function of T
* NQSATVP dimension of qsatvp
*
**
*
integer i, ip
real airmw, h2omw, one, esfac, erfac, ep2, rtr
real tx, v, d, dqdta
parameter ( airmw = 28.97 )
parameter ( h2omw = 18.01 )
parameter ( one = 1.0 )
parameter (esfac = h2omw/airmw )
parameter (erfac = (one-esfac)/esfac )
parameter (ep2=0.622)
*
rtr=1./qsatvp(3)
*
do i=1,lenc
tx=(tt(i)-qsatvp(2))*rtr
ip=int(tx)
v=qsatvp(ip+4)+(tx-ip)*(qsatvp(ip+5)-qsatvp(ip+4))
d=1./(.1*p(i)-ep2*erfac*v)
c
c tx is t-tmin in units of qsatvp(2)
c factor of 0.1 before p changes from mb to cb (v in units of cb)
c
q(i)=ep2*v*d
c
if (ldqdt) then
dqdta = (qsatvp(ip+5)-qsatvp(ip+4))*rtr
dqdt(i) = (dqdta + erfac*q(i)) * d
endif
enddo
c
return
end
*** S/P RAN2
FUNCTION RAN2(IDUM) 1
*
#include "impnone.cdk"
*
INTEGER IDUM
REAL RAN2
*
*AUTHOR PRESS, FLANNERY, TEUKOLSKY, VETTERLING
*
* BOOK-TITLE
* NUMERICAL RECIPES
* The Art of Scientific Computing
*
*LANGUAGE FORTRAN 77
*
*OBJECT Returns a random deviate between 0.0 and 1.0.
*
*ARGUMENTS
* - Input/Output -
* IDUM if negative, initialize or reinitialize the sequence
*
**
REAL R(97), RM1, RM2
INTEGER IA1,IA2,IA3,IC1,IC2,IC3,IFF,IX1,IX2,IX3,J,M1,M2,M3
PARAMETER (M1=259200,IA1=7141,IC1=54773,RM1=3.8580247E-6)
PARAMETER (M2=134456,IA2=8121,IC2=28411,RM2=7.4373773E-6)
PARAMETER (M3=243000,IA3=4561,IC3=51349)
COMMON /RANNUM/ R,IX1,IX2,IX3,IFF
IF (IDUM.LT.0.OR.IFF.EQ.0) THEN
IFF=1
IX1=MOD(IC1-IDUM,M1)
IX1=MOD(IA1*IX1+IC1,M1)
IX2=MOD(IX1,M2)
IX1=MOD(IA1*IX1+IC1,M1)
IX3=MOD(IX1,M3)
DO 11 J=1,97
IX1=MOD(IA1*IX1+IC1,M1)
IX2=MOD(IA2*IX2+IC2,M2)
R(J)=(FLOAT(IX1)+FLOAT(IX2)*RM2)*RM1
11 CONTINUE
IDUM=1
ENDIF
IX1=MOD(IA1*IX1+IC1,M1)
IX2=MOD(IA2*IX2+IC2,M2)
IX3=MOD(IA3*IX3+IC3,M3)
J=1+(97*IX3)/M3
IF(J.GT.97.OR.J.LT.1)PAUSE
RAN2=R(J)
R(J)=(FLOAT(IX1)+FLOAT(IX2)*RM2)*RM1
RETURN
END
BLOCK DATA RAN2_DATA
*
REAL R(97)
INTEGER IFF,IX1,IX2,IX3
*
COMMON /RANNUM/ R,IX1,IX2,IX3,IFF
*
DATA IFF /0/
*
END BLOCK DATA RAN2_DATA