/[MITgcm]/MITgcm/pkg/fizhi/fizhi_moist.F
ViewVC logotype

Diff of /MITgcm/pkg/fizhi/fizhi_moist.F

Parent Directory Parent Directory | Revision Log Revision Log | View Revision Graph Revision Graph | View Patch Patch

revision 1.3 by molod, Thu Jun 24 19:57:02 2004 UTC revision 1.29 by jmc, Wed Mar 2 00:44:59 2005 UTC
# Line 1  Line 1 
1  C $Header$  C $Header$
2  C $Name$  C $Name$
3    
4  #include "CPP_OPTIONS.h"  #include "FIZHI_OPTIONS.h"
5        subroutine moistio (ndmoist,istrip,npcs,pz,tz,qz,bi,bj,        subroutine moistio (ndmoist,istrip,npcs,
6       .   ntracer,ptracer,       .   lowlevel,midlevel,nltop,nsubmin,nsubmax,Lup,
7       .   pkht,qqz,dumoist,dvmoist,dtmoist,dqmoist,       .   pz,plz,plze,dpres,pkht,pkl,uz,vz,tz,qz,bi,bj,ntracerin,ptracer,
8       .   im,jm,lm,sige,sig,dsig,ptop,       .   qqz,dumoist,dvmoist,dtmoist,dqmoist,cumfric,
9         .   im,jm,lm,ptop,
10       .   iras,rainlsp,rainconv,snowfall,       .   iras,rainlsp,rainconv,snowfall,
11       .   nswcld,cldtot_sw,cldras_sw,cldlsp_sw,nswlz,swlz,       .   nswcld,cldtot_sw,cldras_sw,cldlsp_sw,nswlz,swlz,
12       .   nlwcld,cldtot_lw,cldras_lw,cldlsp_lw,nlwlz,lwlz,       .   nlwcld,cldtot_lw,cldras_lw,cldlsp_lw,nlwlz,lwlz,
13       .   lpnt,myid)       .   lpnt,myid)
14    
15           implicit none
16    
17  #ifdef ALLOW_DIAGNOSTICS  #ifdef ALLOW_DIAGNOSTICS
18  #include "diagnostics.h"  #include "SIZE.h"
19    #include "DIAGNOSTICS_SIZE.h"
20    #include "DIAGNOSTICS.h"
21  #endif  #endif
22    
23  c Input Variables  c Input Variables
24  c ---------------  c ---------------
25        integer ndmoist,istrip,npcs,myid,bi,bj        integer im,jm,lm
26          integer ndmoist,istrip,npcs
27        integer im,jm,lm                        integer bi,bj,ntracerin,ptracer        
28        real  ptop                              integer lowlevel,midlevel,nltop,nsubmin,nsubmax,Lup
29        real  sige(lm+1)                        _RL pz(im,jm),plz(im,jm,lm),plze(im,jm,lm+1),dpres(im,jm,lm)
30        real   sig(lm)                          _RL pkht(im,jm,lm+1),pkl(im,jm,lm)
31        real  dsig(lm)                          _RL tz(im,jm,lm),qz(im,jm,lm,ntracerin)      
32          _RL uz(im,jm,lm),vz(im,jm,lm)      
33        integer ntracer,ptracer                _RL qqz(im,jm,lm)
34          _RL dumoist(im,jm,lm),dvmoist(im,jm,lm)
35        real pz(im,jm)                          _RL dtmoist(im,jm,lm),dqmoist(im,jm,lm,ntracerin)
36        real tz(im,jm,lm)                      logical cumfric
37        real qz(im,jm,lm,ntracer)              _RL ptop
38          integer iras
39        real  pkht(im,jm,lm)                    _RL rainlsp(im,jm),rainconv(im,jm),snowfall(im,jm)
40          integer nswcld,nswlz
41        real   qqz(im,jm,lm)                    _RL cldlsp_sw(im,jm,lm),cldras_sw(im,jm,lm)
42          _RL cldtot_sw(im,jm,lm),swlz(im,jm,lm)
43        real dumoist(im,jm,lm)                  integer nlwcld,nlwlz
44        real dvmoist(im,jm,lm)                  _RL  cldlsp_lw(im,jm,lm),cldras_lw(im,jm,lm)
45        real dtmoist(im,jm,lm)                  _RL  cldtot_lw(im,jm,lm),lwlz(im,jm,lm)
46        real dqmoist(im,jm,lm,ntracer)          logical lpnt
47          integer myid
       integer iras                      
       real   rainlsp(im,jm)            
       real  rainconv(im,jm)            
       real  snowfall(im,jm)            
   
       integer nswcld,nswlz              
       real  cldlsp_sw(im,jm,lm)        
       real  cldras_sw(im,jm,lm)        
       real  cldtot_sw(im,jm,lm)        
       real       swlz(im,jm,lm)        
   
       integer nlwcld,nlwlz              
       real  cldlsp_lw(im,jm,lm)        
       real  cldras_lw(im,jm,lm)        
       real  cldtot_lw(im,jm,lm)        
       real       lwlz(im,jm,lm)        
   
       logical lpnt                      
48    
49  c Local Variables  c Local Variables
50  c ---------------  c ---------------
51        integer    ncrnd,nsecf,nsubmax        integer    ncrnd,nsecf
52    
53        real       fracqq, rh,temp1,temp2,dum        _RL       fracqq, dum
54        integer    snowcrit, lup        integer    snowcrit
55        parameter (fracqq = 0.1)        parameter (fracqq = 0.1)
56          _RL one
57          parameter (one=1.)
58    
59        real   cldsr(im,jm,lm)        _RL   cldsr(im,jm,lm)
60        real   srcld(istrip,lm)        _RL   srcld(istrip,lm)
61    
62        real plev        _RL plev
63        real cldnow,cldlsp_mem,cldras_mem,cldras,watnow,watmin,cldmin        _RL cldnow,cldlsp_mem,cldlsp,cldras_mem,cldras
64        real cldprs(im,jm),cldtmp(im,jm)        _RL watnow,watmin,cldmin
65        real cldhi (im,jm),cldlow(im,jm)        _RL cldprs(im,jm),cldtmp(im,jm)
66        real cldmid(im,jm),totcld(im,jm)        _RL cldhi (im,jm),cldlow(im,jm)
67        integer midlevel,lowlevel        _RL cldmid(im,jm),totcld(im,jm)
68    
69        real   CLDLS(im,jm,lm)  , CPEN(im,jm,lm)        _RL   CLDLS(im,jm,lm)  , CPEN(im,jm,lm)
70        real    tmpimjm(im,jm)        _RL    tmpimjm(im,jm)
71        real    lsp_new(im,jm)        _RL    lsp_new(im,jm)
72        real   conv_new(im,jm)        _RL   conv_new(im,jm)
73        real   snow_new(im,jm)        _RL   snow_new(im,jm)
74    
75        real  qqcolmin(im,jm)        _RL  qqcolmin(im,jm)
76        real  qqcolmax(im,jm)        _RL  qqcolmax(im,jm)
77        integer levpbl(im,jm)        integer levpbl(im,jm)
78    
79  c Gathered Arrays for Variable Cloud Base  c Gathered Arrays for Variable Cloud Base
80  c ---------------------------------------  c ---------------------------------------
81        real    raincgath(im*jm)        _RL    raincgath(im*jm)
82        real     pigather(im*jm)        _RL     pigather(im*jm)
83        real     thgather(im*jm,lm)        _RL     thgather(im*jm,lm)
84        real     shgather(im*jm,lm)        _RL     shgather(im*jm,lm)
85        real    pkzgather(im*jm,lm)        _RL    pkzgather(im*jm,lm)
86        real    pkegather(im*jm,lm)        _RL    pkegather(im*jm,lm+1)
87        real    tmpgather(im*jm,lm)        _RL    plzgather(im*jm,lm)
88        real   deltgather(im*jm,lm)        _RL    plegather(im*jm,lm+1)
89        real   delqgather(im*jm,lm)        _RL     dpgather(im*jm,lm)
90        real      ugather(im*jm,lm,ntracer)        _RL    tmpgather(im*jm,lm)
91        real   delugather(im*jm,lm,ntracer)        _RL   deltgather(im*jm,lm)
92        real     deltrnev(im*jm,lm)        _RL   delqgather(im*jm,lm)
93        real     delqrnev(im*jm,lm)        _RL      ugather(im*jm,lm,ntracerin+2-ptracer)
94          _RL   delugather(im*jm,lm,ntracerin+2-ptracer)
95          _RL     deltrnev(im*jm,lm)
96          _RL     delqrnev(im*jm,lm)
97    
98        integer  nindeces(lm)        integer  nindeces(lm)
99        integer  pblindex(im*jm)        integer  pblindex(im*jm)
# Line 109  c -------------------------------------- Line 101  c --------------------------------------
101    
102  c Stripped Arrays  c Stripped Arrays
103  c ---------------  c ---------------
104        real saveth (istrip,lm)        _RL saveth (istrip,lm)
105        real saveq  (istrip,lm)        _RL saveq  (istrip,lm)
106        real saveu  (istrip,lm,ntracer)        _RL saveu  (istrip,lm,ntracerin+2-ptracer)
107        real usubcl (istrip,   ntracer)        _RL usubcl (istrip,   ntracerin+2-ptracer)
108    
109        real     ple(istrip,lm+1), gam(istrip,lm)        _RL     ple(istrip,lm+1)
110        real      TL(ISTRIP,lm)  , SHL(ISTRIP,lm)        _RL      dp(istrip,lm)
111        real      PL(ISTRIP,lm)  , PLK(ISTRIP,lm)        _RL      TL(ISTRIP,lm)  , SHL(ISTRIP,lm)
112        real    PLKE(ISTRIP,lm+1)        _RL      PL(ISTRIP,lm)  , PLK(ISTRIP,lm)
113        real      TH(ISTRIP,lm)  ,CVTH(ISTRIP,lm)        _RL    PLKE(ISTRIP,lm+1)
114        real   SHSAT(ISTRIP,lm)  , CVQ(ISTRIP,lm)        _RL      TH(ISTRIP,lm)  ,CVTH(ISTRIP,lm)
115        real      UL(ISTRIP,lm,ntracer)        _RL   CVQ(ISTRIP,lm)
116        real     cvu(istrip,lm,ntracer)        _RL      UL(ISTRIP,lm,ntracerin+2-ptracer)
117        real  CLMAXO(ISTRIP,lm),CLBOTH(ISTRIP,lm)        _RL     cvu(istrip,lm,ntracerin+2-ptracer)
118        real  CLSBTH(ISTRIP,lm)        _RL  CLMAXO(ISTRIP,lm),CLBOTH(ISTRIP,lm)
119        real    TMP1(ISTRIP,lm),  TMP2(ISTRIP,lm)        _RL  CLSBTH(ISTRIP,lm)
120        real    TMP3(ISTRIP,lm),  TMP4(ISTRIP,lm+1)        _RL    TMP1(ISTRIP,lm),  TMP2(ISTRIP,lm)
121        real    TMP5(ISTRIP,lm+1)        _RL    TMP3(ISTRIP,lm),  TMP4(ISTRIP,lm+1)
122          _RL    TMP5(ISTRIP,lm+1)
123        integer   ITMP1(ISTRIP,lm), ITMP2(ISTRIP,lm)        integer   ITMP1(ISTRIP,lm), ITMP2(ISTRIP,lm)
       integer   ITMP3(ISTRIP,lm)  
124    
125        real   PRECIP(ISTRIP), PCMID(ISTRIP), PCNET(ISTRIP)        _RL   PRECIP(ISTRIP), PCNET(ISTRIP)
126        real   PCLOW (ISTRIP),    SP(ISTRIP),  PREP(ISTRIP)        _RL   SP(ISTRIP),  PREP(ISTRIP)
127        real   PCPEN (ISTRIP,lm)        _RL   PCPEN (ISTRIP,lm)
128        integer pbl(istrip),depths(lm)        integer pbl(istrip),depths(lm)
129    
130        real   cldlz(istrip,lm), cldwater(im,jm,lm)        _RL   cldlz(istrip,lm), cldwater(im,jm,lm)
131        real   rhfrac(istrip), rhmin, pup, ppbl, rhcrit(istrip,lm)        _RL   rhfrac(istrip), rhmin, pup, ppbl, rhcrit(istrip,lm)
132        real   offset, alpha, rasmax        _RL   offset, alpha, rasmax
133    
134        logical first        logical first
135        logical lras        logical lras
136        real    clfrac (istrip,lm)        _RL    clfrac (istrip,lm)
137        real    cldmas (istrip,lm)        _RL    cldmas (istrip,lm)
138        real    detrain(istrip,lm)        _RL    detrain(istrip,lm)
139        real    psubcld    (istrip), psubcldg (im,jm)        _RL    psubcld    (istrip), psubcldg (im,jm)
140        real    psubcld_cnt(istrip), psubcldgc(im,jm)        _RL    psubcld_cnt(istrip), psubcldgc(im,jm)
141        real rnd(lm/2)        _RL rnd(lm/2)
142        DATA      FIRST /.TRUE./        DATA      FIRST /.TRUE./
143    
144        integer imstp,nltop,nsubcl,nlras,nsubmin        integer imstp,nsubcl,nlras
145        integer i,j,iloop,index,l,nn,num,numdeps,nt        integer i,j,iloop,indx,indgath,l,nn,num,numdeps,nt
146        real tmstp,tminv,sday,grav,alhl,cp,elocp,gamfac        _RL tmstp,tminv,sday,grav,alhl,cp,elocp,gamfac
147        real rkappa,p0kappa,p0kinv,ptopkap,pcheck        _RL rkappa,p0kappa,p0kinv,ptopkap,pcheck
148        real tice,getcon,pi        _RL tice,getcon,pi
149          integer ntracer,ntracedim, ntracex
150    
151  C **********************************************************************  C **********************************************************************
152  C ****                     INITIALIZATION                           ****  C ****                     INITIALIZATION                           ****
153  C **********************************************************************  C **********************************************************************
154    
155    C Add U and V components to tracer array for cumulus friction
156    
157          if(cumfric) then
158           ntracer = ntracerin + 2
159          else
160           ntracer = ntracerin
161          endif
162          ntracedim= max(ntracer-ptracer,1)
163          ntracex= ntracer-ptracer
164        IMSTP  = nsecf(NDMOIST)        IMSTP  = nsecf(NDMOIST)
165        TMSTP  = FLOAT(IMSTP)        TMSTP  = FLOAT(IMSTP)
166        TMINV  = 1. /  TMSTP        TMINV  = 1. /  TMSTP
# Line 192  C Threshold for Cloud Liquid Water Memor Line 194  C Threshold for Cloud Liquid Water Memor
194        tice     = getcon('FREEZING-POINT')        tice     = getcon('FREEZING-POINT')
195        PI       = 4.*atan(1.)        PI       = 4.*atan(1.)
196    
197  c Determine Upper  Level for Cumulus Convection  c Determine Total number of Random Clouds to Check
 c and Total number of Random Clouds to Check  
198  c ---------------------------------------------  c ---------------------------------------------
   
       NLTOP = 1  
       DO L=1,lm  
        PCHECK = (1000.-ptop)*SIG(L) + PTOP  
        IF (PCHECK.GE.10.) THEN  
         NLTOP = L  
         GO TO 2  
        ENDIF  
       ENDDO  
  2    CONTINUE  
199        ncrnd = (lm-nltop+1)/2        ncrnd = (lm-nltop+1)/2
200    
201  c Determine Minimum Number of Levels in Sub-Cloud (50 mb) Layer        if(first .and. myid.eq.1 .and. bi.eq.1 ) then
 c -------------------------------------------------------------  
       nsubmin = lm  
       nsubmax = 1  
       DO L=lm-1,1,-1  
           PCHECK = (1000.-ptop)*SIG(L) + PTOP  
       IF( PCHECK.GE.950.0 ) nsubmin = L  
       IF( PCHECK.GE.750.0 ) nsubmax = L  
       ENDDO  
   
       if(first .and. myid.eq.0) then  
202         print *         print *
203         print *,'Top Level Allowed for Convection : ',nltop,         print *,'Top Level Allowed for Convection : ',nltop
204       .                    ' (',(1000.-ptop)*SIG(nltop) + PTOP,' mb)'         print *,'          Highest Sub-Cloud Level: ',nsubmax
205         print *,'          Highest Sub-Cloud Level: ',nsubmax,         print *,'          Lowest  Sub-Cloud Level: ',nsubmin
      .                    ' (',(1000.-ptop)*SIG(nsubmax) + PTOP,' mb)'  
        print *,'          Lowest  Sub-Cloud Level: ',nsubmin,  
      .                    ' (',(1000.-ptop)*SIG(nsubmin) + PTOP,' mb)'  
206         print *,'    Total Number of Random Clouds: ',ncrnd         print *,'    Total Number of Random Clouds: ',ncrnd
207         print *         print *
208         first = .false.         first = .false.
# Line 264  c -------------------------------------- Line 242  c --------------------------------------
242    
243  c Set up the array of indeces of subcloud levels for the gathering  c Set up the array of indeces of subcloud levels for the gathering
244  c ----------------------------------------------------------------  c ----------------------------------------------------------------
245        index = 0        indx = 0
246        do L = nsubmin,nltop,-1        do L = nsubmin,nltop,-1
247         do j = 1,jm         do j = 1,jm
248         do i = 1,im         do i = 1,im
249          if(levpbl(i,j).eq.L) then          if(levpbl(i,j).eq.L) then
250           index = index + 1           indx = indx + 1
251           pblindex(index) = (j-1)*im + i           pblindex(indx) = (j-1)*im + i
252          endif          endif
253         enddo         enddo
254         enddo         enddo
255        enddo        enddo
256    
257        do index = 1,im*jm        do indx = 1,im*jm
258         levgather(index) = levpbl(pblindex(index),1)         levgather(indx) = levpbl(pblindex(indx),1)
259          pigather(index) =     pz(pblindex(index),1)          pigather(indx) =     pz(pblindex(indx),1)
260            pkegather(indx,lm+1) = pkht(pblindex(indx),1,lm+1)
261            plegather(indx,lm+1) = plze(pblindex(indx),1,lm+1)
262        enddo        enddo
263    
264        do L = 1,lm        do L = 1,lm
265         do index = 1,im*jm         do indx = 1,im*jm
266           thgather(index,L) =   tz(pblindex(index),1,L)           thgather(indx,L) = tz(pblindex(indx),1,L)
267           shgather(index,L) =   qz(pblindex(index),1,L,1)           shgather(indx,L) = qz(pblindex(indx),1,L,1)
268          pkegather(index,L) = pkht(pblindex(index),1,L)          pkegather(indx,L) = pkht(pblindex(indx),1,L)
269            pkzgather(indx,L) = pkl(pblindex(indx),1,L)
270            plegather(indx,L) = plze(pblindex(indx),1,L)
271            plzgather(indx,L) = plz(pblindex(indx),1,L)
272             dpgather(indx,L) = dpres(pblindex(indx),1,L)
273         enddo         enddo
274        enddo        enddo
275        do nt = 1,ntracer-ptracer  C General Tracers
276    C----------------
277          do nt = 1,ntracerin-ptracer
278        do L = 1,lm        do L = 1,lm
279         do index = 1,im*jm         do indx = 1,im*jm
280          ugather(index,L,nt) = qz(pblindex(index),1,L,nt+ptracer)          ugather(indx,L,nt) = qz(pblindex(indx),1,L,nt+ptracer)
281         enddo         enddo
282        enddo        enddo
283        enddo        enddo
284    
285        call pkappa(pigather,pkegather,pkzgather,ptop,sige,dsig,im,jm,lm)        if(cumfric) then
286    C Cumulus Friction - load u and v wind components into tracer array
287    C------------------------------------------------------------------
288          do L = 1,lm
289           do indx = 1,im*jm
290            ugather(indx,L,ntracerin-ptracer+1) = uz(pblindex(indx),1,L)
291            ugather(indx,L,ntracerin-ptracer+2) = vz(pblindex(indx),1,L)
292           enddo
293          enddo
294    
295          endif
296    
297  c bump the counter for number of calls to convection  c bump the counter for number of calls to convection
298  c --------------------------------------------------  c --------------------------------------------------
# Line 310  c -------------------------------------- Line 306  c --------------------------------------
306        do l=1,lm        do l=1,lm
307        do j=1,jm        do j=1,jm
308        do i=1,im        do i=1,im
309          dumoist(i,j,l) = 0.
310          dvmoist(i,j,l) = 0.
311        dtmoist(i,j,l) = 0.        dtmoist(i,j,l) = 0.
312          do nt = 1,ntracer          do nt = 1,ntracerin
313          dqmoist(i,j,l,nt) = 0.          dqmoist(i,j,l,nt) = 0.
314          enddo          enddo
315        enddo        enddo
# Line 330  C ************************************** Line 328  C **************************************
328    
329         CALL STRIP (  pigather, SP      ,im*jm,ISTRIP,1 ,NN )         CALL STRIP (  pigather, SP      ,im*jm,ISTRIP,1 ,NN )
330         CALL STRIP ( pkzgather, PLK     ,im*jm,ISTRIP,lm,NN )         CALL STRIP ( pkzgather, PLK     ,im*jm,ISTRIP,lm,NN )
331         CALL STRIP ( pkegather, PLKE    ,im*jm,ISTRIP,lm,NN )         CALL STRIP ( pkegather, PLKE    ,im*jm,ISTRIP,lm+1,NN )
332           CALL STRIP ( plzgather, PL      ,im*jm,ISTRIP,lm,NN )
333           CALL STRIP ( plegather, PLE     ,im*jm,ISTRIP,lm+1,NN )
334           CALL STRIP (  dpgather, dp      ,im*jm,ISTRIP,lm,NN )
335         CALL STRIP (  thgather, TH      ,im*jm,ISTRIP,lm,NN )         CALL STRIP (  thgather, TH      ,im*jm,ISTRIP,lm,NN )
336         CALL STRIP (  shgather, SHL     ,im*jm,ISTRIP,lm,NN )         CALL STRIP (  shgather, SHL     ,im*jm,ISTRIP,lm,NN )
337         CALL STRINT( levgather, pbl     ,im*jm,ISTRIP,1 ,NN )         CALL STRINT( levgather, pbl     ,im*jm,ISTRIP,1 ,NN )
338    
339         do nt = 1,ntracer-ptracer         do nt = 1,ntracer-ptracer
340         call strip ( ugather(1,1,nt), ul(1,1,nt),im*jm,istrip,lm,nn )          call strip ( ugather(1,1,nt), ul(1,1,nt),im*jm,istrip,lm,nn )
341         enddo         enddo
342    
       do l = 1,lm  
       do i = 1,istrip  
        PL(I,L) =  SIG(L)*SP(I) + PTOP  
       PLE(I,L) = SIGE(L)*SP(I) + PTOP  
       enddo  
       enddo  
   
       do i = 1,istrip  
       PLE(I,lm+1) = SP(I) + PTOP  
       enddo  
   
343  C **********************************************************************  C **********************************************************************
344  C ****        SETUP FOR RAS CUMULUS PARAMETERIZATION                ****  C ****        SETUP FOR RAS CUMULUS PARAMETERIZATION                ****
345  C **********************************************************************  C **********************************************************************
# Line 380  C ************************************** Line 370  C **************************************
370         endif         endif
371        enddo        enddo
372    
   
373  C Initiate a do-loop around RAS for the number of different  C Initiate a do-loop around RAS for the number of different
374  C    sub-cloud layer depths in this strip  C    sub-cloud layer depths in this strip
375  C --If all subcloud depths are the same, execute loop once  C --If all subcloud depths are the same, execute loop once
# Line 445  c ------------------------------- Line 434  c -------------------------------
434         ENDDO         ENDDO
435         DO L=2,lm         DO L=2,lm
436         DO I=num,num+nindeces(nsubcl)-1         DO I=num,num+nindeces(nsubcl)-1
437          TMP5(I,L) = PLKE(I,L-1)*P0KINV          TMP5(I,L) = PLKE(I,L)*P0KINV
438         ENDDO         ENDDO
439         ENDDO         ENDDO
440         DO  I=num,num+nindeces(nsubcl)-1         DO  I=num,num+nindeces(nsubcl)-1
441          TMP4(I,lm+1) = PLE (I,lm+1)          TMP4(I,lm+1) = PLE (I,lm+1)
442          TMP5(I,lm+1) = PLKE(I,lm)*P0KINV          TMP5(I,lm+1) = PLKE(I,lm+1)*P0KINV
443         ENDDO         ENDDO
444         DO 113 I=num,num+nindeces(nsubcl)-1         DO 113 I=num,num+nindeces(nsubcl)-1
445          TMP4(I,NSUBCL+1) = PLE (I,lm+1)          TMP4(I,NSUBCL+1) = PLE (I,lm+1)
446          TMP5(I,NSUBCL+1) = PLKE(I,lm)*P0KINV          TMP5(I,NSUBCL+1) = PLKE(I,lm+1)*P0KINV
447   113   CONTINUE   113   CONTINUE
448    
449        do i=num,num+nindeces(nsubcl)-1        do i=num,num+nindeces(nsubcl)-1
# Line 491  C Top level of atan func above this rh_t Line 480  C Top level of atan func above this rh_t
480           rhcrit(i,L) = 1.           rhcrit(i,L) = 1.
481         enddo         enddo
482         do L = 1, nsubcl-1         do L = 1, nsubcl-1
483          pcheck = (1000.-ptop)*sig(L) + ptop          pcheck = pl(i,L)
484          if (pcheck .le. pup) then          if (pcheck .le. pup) then
485           rhcrit(i,L) = rhmin           rhcrit(i,L) = rhmin
486          else          else
487           ppbl = (1000.-ptop)*sig(nsubcl) + ptop           ppbl = pl(i,nsubcl)
488           rhcrit(i,L) = rhmin + (1.-rhmin)/(19.) *           rhcrit(i,L) = rhmin + (1.-rhmin)/(19.) *
489       .      ((atan( (2.*(pcheck-pup)/(ppbl-pup)-1.) *       .      ((atan( (2.*(pcheck-pup)/(ppbl-pup)-1.) *
490       .       tan(20.*pi/21.-0.5*pi) )       .       tan(20.*pi/21.-0.5*pi) )
# Line 516  c -------------------------------------- Line 505  c --------------------------------------
505        enddo        enddo
506    
507        CALL RAS ( NN,istrip,nindeces(nsubcl),NLRAS,NLTOP,lm,TMSTP        CALL RAS ( NN,istrip,nindeces(nsubcl),NLRAS,NLTOP,lm,TMSTP
508       1, UL(num,1,1),ntracer-ptracer,TH(num,NLTOP),SHL(num,NLTOP)       1, UL(num,1,1),ntracedim,ntracex,TH(num,NLTOP),SHL(num,NLTOP)
509       2, TMP4(num,NLTOP), TMP5(num,NLTOP),rnd, ncrnd, PCPEN(num,NLTOP)       2, TMP4(num,NLTOP), TMP5(num,NLTOP),rnd, ncrnd, PCPEN(num,NLTOP)
510       3, CLBOTH(num,NLTOP), CLFRAC(num,NLTOP)       3, CLBOTH(num,NLTOP), CLFRAC(num,NLTOP)
511       4, cldmas(num,nltop), detrain(num,nltop)       4, cldmas(num,nltop), detrain(num,nltop)
# Line 525  c -------------------------------------- Line 514  c --------------------------------------
514  c Compute Diagnostic CLDMAS in RAS Subcloud Layers  c Compute Diagnostic CLDMAS in RAS Subcloud Layers
515  c ------------------------------------------------  c ------------------------------------------------
516         do L=nsubcl,lm         do L=nsubcl,lm
         dum = dsig(L)/(1.0-sige(nsubcl))  
517         do I=num,num+nindeces(nsubcl)-1         do I=num,num+nindeces(nsubcl)-1
518            dum = dp(i,L)/(ple(i,lm+1)-ple(i,nsubcl))
519          cldmas(i,L) = cldmas(i,L-1) - dum*cldmas(i,nsubcl-1)          cldmas(i,L) = cldmas(i,L-1) - dum*cldmas(i,nsubcl-1)
520         enddo         enddo
521         enddo         enddo
# Line 640  C ************************************** Line 629  C **************************************
629        ENDDO        ENDDO
630        ENDDO        ENDDO
631    
632         CALL RNEVP (NN,ISTRIP,lm,TL,SHL,PCPEN,PL,CLFRAC,SP,DSIG,PLKE,         CALL RNEVP (NN,ISTRIP,lm,TL,SHL,PCPEN,PL,CLFRAC,SP,DP,PLKE,
633       .  PLK,TH,TMP1,TMP2,TMP3,ITMP1,ITMP2,PCNET,PRECIP,       .  PLK,TH,TMP1,TMP2,TMP3,ITMP1,ITMP2,PCNET,PRECIP,
634       .  CLSBTH,TMSTP,1.,cp,grav,alhl,gamfac,cldlz,rhcrit,offset,alpha)       .  CLSBTH,TMSTP,one,cp,grav,alhl,gamfac,cldlz,rhcrit,offset,alpha)
635    
636  C **********************************************************************  C **********************************************************************
637  C ****                     TENDENCY UPDATES                         ****  C ****                     TENDENCY UPDATES                         ****
# Line 729  c  snow algorthm: Line 718  c  snow algorthm:
718  c  if temperature profile from the surface level to 700 mb  c  if temperature profile from the surface level to 700 mb
719  c  uniformaly c  below zero, then precipitation (total) is  c  uniformaly c  below zero, then precipitation (total) is
720  c  snowfall.  Else there is no snow.  c  snowfall.  Else there is no snow.
 c  For version of level 70, the sigma level corresponding  
 c  to 700mb (assume the surface pressure is 1000mb) is  
 c  the 13th level from the surface  
 c   Runhua Yang Aug. 24 98  
 c  added pcheck for 700mb - sharon sept 18, 1998  
721  c-------------------------------------------------------  c-------------------------------------------------------
722    
         pup = 700.  
         do L = lm, 1, -1  
           pcheck = (1000.-ptop)*sig(L) + ptop  
           if (pcheck .ge. pup) then  
             lup = L  
           endif  
         enddo  
723          do i = 1,istrip          do i = 1,istrip
724            snowcrit=0            snowcrit=0
725            do l=lup,lm            do l=lup,lm
# Line 812  c ------------ Line 789  c ------------
789       .                                              cldsr(1,1,L),im*jm)       .                                              cldsr(1,1,L),im*jm)
790        enddo        enddo
791    
792  c Tracers  c General Tracers
793  c -------  c ---------------
794        do nt = 1,ntracer-ptracer        do nt = 1,ntracerin-ptracer
795         do L = 1,lm         do L = 1,lm
796         call back2grd (delugather(1,L,nt),pblindex,         call back2grd (delugather(1,L,nt),pblindex,
797       .                                 dqmoist(1,1,L,ptracer+nt),im*jm)       .                                 dqmoist(1,1,L,ptracer+nt),im*jm)
798         enddo         enddo
799        enddo        enddo
800    
801          if(cumfric) then
802    
803  C **********************************************************************  c U and V for cumulus friction
804  C                          BUMP DIAGNOSTICS  c ----------------------------
805  C **********************************************************************        do L = 1,lm
806           call back2grd (delugather(1,L,ntracerin-ptracer+1),pblindex,
807  c Determine Level Indices for Low-Mid-High Cloud Regions       .                                 dumoist(1,1,L),im*jm)
808  c ------------------------------------------------------         call back2grd (delugather(1,L,ntracerin-ptracer+2),pblindex,
809        lowlevel = lm       .                                 dvmoist(1,1,L),im*jm)
       midlevel = lm  
       do L = lm-1,1,-1  
       pcheck = (1000.-ptop)*sig(l) + ptop  
       if (pcheck.gt.700.0) lowlevel = L  
       if (pcheck.gt.400.0) midlevel = L  
810        enddo        enddo
811    
812    C Remove pi-weighting for u and v tendencies
 c Clear-Sky (Above 400mb) Temperature  
 c -----------------------------------  
       if( itmpuclr.ne.0 .or. isphuclr.ne.0 ) then  
813        do j = 1,jm        do j = 1,jm
814        do i = 1,im        do i = 1,im
815        totcld(i,j) = 0.0         tmpimjm(i,j) = 1./pz(i,j)
816        enddo        enddo
817        enddo        enddo
818        do L = 1,midlevel        do L = 1,lm
819        do j = 1,jm        do j = 1,jm
820        do i = 1,im        do i = 1,im
821         if(cldls(i,j,L).ne.0.0.or.cpen(i,j,L).ne.0.0)totcld(i,j) = 1.0         dumoist(i,j,L) = dumoist(i,j,L) * tmpimjm(i,j)
822           dvmoist(i,j,L) = dvmoist(i,j,L) * tmpimjm(i,j)
823        enddo        enddo
824        enddo        enddo
825        enddo        enddo
826        do L = 1,lm  
827         if( itmpuclr.ne.0 ) then  
         do i = 1,im*jm  
         if( totcld(i,1).eq.0.0 ) then  
          qdiag(i,1,itmpuclr +L-1,bi,bj) =  
      .         qdiag(i,1,itmpuclr +L-1,bi,bj) + tz(i,1,L)*pkzgather(i,L)  
          qdiag(i,1,itmpuclrc+L-1,bi,bj) =  
      .                            qdiag(i,1,itmpuclrc+L-1,bi,bj)+1.0  
         endif  
         enddo  
        endif  
   
        if( isphuclr.ne.0 ) then  
         do i = 1,im*jm  
         if( totcld(i,1).eq.0.0 ) then  
          qdiag(i,1,isphuclr +L-1,bi,bj) =  
      .              qdiag(i,1,isphuclr +L-1,bi,bj) + qz(i,1,L,1)*1000.0  
          qdiag(i,1,isphuclrc+L-1,bi,bj) =  
      .                      qdiag(i,1,isphuclrc+L-1,bi,bj) + 1.0  
         endif  
         enddo  
        endif  
       enddo  
828        endif        endif
829    
830    C **********************************************************************
831    C                          BUMP DIAGNOSTICS
832    C **********************************************************************
833    
834    
835  c Sub-Cloud Layer  c Sub-Cloud Layer
836  c -------------------------  c -------------------------
837        if( ipsubcld.ne.0 ) then        if( ipsubcld.ne.0 ) then
# Line 908  c Moist Processes Heating Rate Line 863  c Moist Processes Heating Rate
863  c ----------------------------  c ----------------------------
864        if(imoistt.gt.0) then        if(imoistt.gt.0) then
865        do L = 1,lm        do L = 1,lm
866        do i = 1,im*jm        do j = 1,jm
867        qdiag(i,1,imoistt+L-1,bi,bj) = qdiag(i,1,imoistt+L-1,bi,bj) +        do i = 1,im
868       .                      (dtmoist(i,1,L)*sday*pkzgather(i,L)/pz(i,1))         indgath = (j-1)*im + i
869          qdiag(i,j,imoistt+L-1,bi,bj) = qdiag(i,j,imoistt+L-1,bi,bj) +
870         .    (dtmoist(i,j,L)*sday*pkzgather(indgath,L)/pz(i,j))
871          enddo
872        enddo        enddo
873        enddo        enddo
874        endif        endif
# Line 928  c ------------------------------- Line 886  c -------------------------------
886        enddo        enddo
887        endif        endif
888    
889    c Moist Processes Change in U-Momentum (Cumulus Friction)
890    c ------------------------------------------------------
891          if(iudiag1.gt.0) then
892          do L = 1,lm
893          do j = 1,jm
894          do i = 1,im
895           indgath = (j-1)*im + i
896          qdiag(i,j,iudiag1+L-1,bi,bj) = qdiag(i,j,iudiag1+L-1,bi,bj) +
897         .    dumoist(i,j,L)*sday
898          enddo
899          enddo
900          enddo
901          endif
902    
903    c Moist Processes Change in V-Momentum (Cumulus Friction)
904    c ------------------------------------------------------
905          if(iudiag2.gt.0) then
906          do L = 1,lm
907          do j = 1,jm
908          do i = 1,im
909           indgath = (j-1)*im + i
910          qdiag(i,j,iudiag2+L-1,bi,bj) = qdiag(i,j,iudiag2+L-1,bi,bj) +
911         .    dvmoist(i,j,L)*sday
912          enddo
913          enddo
914          enddo
915          endif
916    
917  c Cloud Mass Flux  c Cloud Mass Flux
918  c ---------------  c ---------------
919        if(icldmas.gt.0) then        if(icldmas.gt.0) then
920        do L = 1,lm        do L = 1,lm
921        do i = 1,im*jm        do j = 1,jm
922        qdiag(i,1,icldmas+L-1,bi,bj) = qdiag(i,1,icldmas+L-1,bi,bj) +        do i = 1,im
923       .                                                  tmpgather(i,L)         indgath = (j-1)*im + i
924          qdiag(i,j,icldmas+L-1,bi,bj) = qdiag(i,j,icldmas+L-1,bi,bj) +
925         .                               tmpgather(indgath,L)
926          enddo
927        enddo        enddo
928        enddo        enddo
929        endif        endif
# Line 943  c Detrained Cloud Mass Flux Line 932  c Detrained Cloud Mass Flux
932  c -------------------------  c -------------------------
933        if(idtrain.gt.0) then        if(idtrain.gt.0) then
934        do L = 1,lm        do L = 1,lm
935        do i = 1,im*jm        do j = 1,jm
936        qdiag(i,1,idtrain+L-1,bi,bj) = qdiag(i,1,idtrain+L-1,bi,bj) +        do i = 1,im
937       .                                                  pkegather(i,L)         indgath = (j-1)*im + i
938          qdiag(i,j,idtrain+L-1,bi,bj) = qdiag(i,j,idtrain+L-1,bi,bj) +
939         .                                pkegather(indgath,L)
940          enddo
941        enddo        enddo
942        enddo        enddo
943        endif        endif
# Line 954  c Grid-Scale Condensational Heating Rate Line 946  c Grid-Scale Condensational Heating Rate
946  c --------------------------------------  c --------------------------------------
947        if(idtls.gt.0) then        if(idtls.gt.0) then
948        do L = 1,lm        do L = 1,lm
949        do i = 1,im*jm        do j = 1,jm
950        qdiag(i,1,idtls+L-1,bi,bj) = qdiag(i,1,idtls+L-1,bi,bj) +        do i = 1,im
951       .                                                  deltrnev(i,L)         indgath = (j-1)*im + i
952          qdiag(i,j,idtls+L-1,bi,bj) = qdiag(i,j,idtls+L-1,bi,bj) +
953         .                               deltrnev(indgath,L)
954          enddo
955        enddo        enddo
956        enddo        enddo
957        endif        endif
# Line 965  c Grid-Scale Condensational Moistening R Line 960  c Grid-Scale Condensational Moistening R
960  c -----------------------------------------  c -----------------------------------------
961        if(idqls.gt.0) then        if(idqls.gt.0) then
962        do L = 1,lm        do L = 1,lm
963        do i = 1,im*jm        do j = 1,jm
964        qdiag(i,1,idqls+L-1,bi,bj) = qdiag(i,1,idqls+L-1,bi,bj) +        do i = 1,im
965       .                                                  delqrnev(i,L)         indgath = (j-1)*im + i
966          qdiag(i,j,idqls+L-1,bi,bj) = qdiag(i,j,idqls+L-1,bi,bj) +
967         .                                delqrnev(indgath,L)
968          enddo
969        enddo        enddo
970        enddo        enddo
971        endif        endif
# Line 988  c ------------------- Line 986  c -------------------
986  c Convective Precipitation  c Convective Precipitation
987  c ------------------------  c ------------------------
988        if(iprecon.gt.0) then        if(iprecon.gt.0) then
989        do i = 1,im*jm        do j = 1,jm
990        qdiag(i,1,iprecon,bi,bj) = qdiag(i,1,iprecon,bi,bj) +        do i = 1,im
991       .                                         raincgath(i)*sday*tminv         indgath = (j-1)*im + i
992          qdiag(i,j,iprecon,bi,bj) = qdiag(i,j,iprecon,bi,bj) +
993         .                      raincgath(indgath)*sday*tminv
994          enddo
995        enddo        enddo
996        endif        endif
997    
# Line 1031  c ------------------------------------ Line 1032  c ------------------------------------
1032    
1033        do L = 1,lm        do L = 1,lm
1034        do i = 1,im*jm        do i = 1,im*jm
1035         plev = sig(L)*pz(i,1)+ptop         plev = pl(i,L)
1036    
1037  c Compute Time-averaged Cloud and Water Amounts for Longwave Radiation  c Compute Time-averaged Cloud and Water Amounts for Longwave Radiation
1038  c --------------------------------------------------------------------  c --------------------------------------------------------------------
# Line 1093  c -------------------------------------- Line 1094  c --------------------------------------
1094        enddo        enddo
1095        enddo        enddo
1096    
1097  c Compute Instantanious Total 2-D Cloud Fraction  c Compute Instantaneous Total 2-D Cloud Fraction
1098  c ----------------------------------------------  c ----------------------------------------------
1099        do j = 1,jm        do j = 1,jm
1100        do i = 1,im        do i = 1,im
# Line 1144  C ************************************** Line 1145  C **************************************
1145         nlwcld   = nlwcld   + 1         nlwcld   = nlwcld   + 1
1146         nswcld   = nswcld   + 1         nswcld   = nswcld   + 1
1147    
1148    #ifdef ALLOW_DIAGNOSTICS
1149           if( (bi.eq.1) .and. (bj.eq.1) ) then
1150         nmoistt  = nmoistt  + 1         nmoistt  = nmoistt  + 1
1151         nmoistq  = nmoistq  + 1         nmoistq  = nmoistq  + 1
1152         npreacc  = npreacc  + 1         npreacc  = npreacc  + 1
# Line 1154  C ************************************** Line 1157  C **************************************
1157    
1158         ndtls  = ndtls  + 1         ndtls  = ndtls  + 1
1159         ndqls  = ndqls  + 1         ndqls  = ndqls  + 1
1160    
1161           nudiag1  = nudiag1  + 1
1162           nudiag2  = nudiag2  + 1
1163    
1164           endif
1165    #endif
1166    
1167        RETURN        RETURN
1168        END        END
1169        SUBROUTINE RAS( NN, LEN, LENC, K, NLTOP, nlayr, DT        SUBROUTINE RAS( NN, LNG, LENC, K, NLTOP, nlayr, DT
1170       *,               UOI, ntracer, POI, QOI, PRS, PRJ, rnd, ncrnd       *,      UOI, ntracedim, ntracer, POI, QOI, PRS, PRJ, rnd, ncrnd
1171       *,               RAINS, CLN, CLF, cldmas, detrain       *,      RAINS, CLN, CLF, cldmas, detrain
1172       *,               cp,grav,rkappa,alhl,rhfrac,rasmax )       *,      cp,grav,rkappa,alhl,rhfrac,rasmax )
1173  C  C
1174  C*********************************************************************  C*********************************************************************
 C*********************** ARIES   MODEL *******************************  
1175  C********************* SUBROUTINE  RAS   *****************************  C********************* SUBROUTINE  RAS   *****************************
1176  C********************** 16 MARCH   1988 ******************************  C********************** 16 MARCH   1988 ******************************
1177  C*********************************************************************  C*********************************************************************
1178  C  C
1179          implicit none
1180    
1181    C Argument List
1182          integer nn,lng,lenc,k,nltop,nlayr
1183          integer ntracedim, ntracer
1184          integer ncrnd
1185          _RL dt
1186          _RL UOI(lng,nlayr,ntracedim),   POI(lng,K)
1187          _RL QOI(lng,K), PRS(lng,K+1), PRJ(lng,K+1)
1188          _RL rnd(ncrnd)
1189          _RL RAINS(lng,K), CLN(lng,K), CLF(lng,K)
1190          _RL cldmas(lng,K), detrain(lng,K)
1191          _RL cp,grav,rkappa,alhl,rhfrac(lng),rasmax
1192    
1193    C Local Variables
1194          _RL TCU(lng,K), QCU(lng,K)
1195          _RL ucu(lng,K,ntracedim)
1196          _RL ALF(lng,K), BET(lng,K), GAM(lng,K)
1197         *,         ETA(lng,K), HOI(lng,K)
1198         *,         PRH(lng,K), PRI(lng,K)
1199          _RL HST(lng,K), QOL(lng,K), GMH(lng,K)
1200    
1201          _RL TX1(lng), TX2(lng), TX3(lng), TX4(lng), TX5(lng)
1202         *,         TX6(lng), TX7(lng), TX8(lng), TX9(lng)
1203         *,         TX11(lng), TX12(lng), TX13(lng), TX14(lng,ntracedim)
1204         *,         TX15(lng)
1205         *,         WFN(lng)
1206          integer IA1(lng), IA2(lng), IA3(lng)
1207          _RL cloudn(lng), pcu(lng)
1208    
1209          integer krmin,icm
1210          _RL rknob, cmb2pa
1211        PARAMETER (KRMIN=01)        PARAMETER (KRMIN=01)
1212        PARAMETER (ICM=1000)        PARAMETER (ICM=1000)
1213        PARAMETER (CMB2PA=100.0)        PARAMETER (CMB2PA=100.0)
1214        PARAMETER (rknob = 10.)        PARAMETER (rknob = 10.)
 C  
       integer ntracer  
       integer nltop,nlayr  
       DIMENSION UOI(len,nlayr,ntracer),   POI(len,K)  
       DIMENSION QOI(len,K), PRS(len,K+1), PRJ(len,K+1)  
       dimension rnd(ncrnd)  
 C  
       DIMENSION RAINS(len,K), CLN(len,K), CLF(len,K)  
       DIMENSION cldmas(len,K), detrain(len,K)  
       DIMENSION TCU(len,K), QCU(len,K)  
       real ucu(len,K,ntracer)  
       DIMENSION ALF(len,K), BET(len,K), GAM(len,K)  
      *,         ETA(len,K), HOI(len,K)  
      *,         PRH(len,K), PRI(len,K)  
       DIMENSION HST(len,K), QOL(len,K), GMH(len,K)  
   
       DIMENSION TX1(len), TX2(len), TX3(len), TX4(len), TX5(len)  
      *,         TX6(len), TX7(len), TX8(len), TX9(len)  
      *,         TX11(len), TX12(len), TX13(len), TX14(len,ntracer)  
      *,         TX15(len), TX16(len)  
      *,         WFN(len), IA1(len), IA2(len), IA3(len)  
       DIMENSION cloudn(len), pcu(len)  
1215    
1216        real rhfrac(len),rasmax        integer IC(ICM),   IRND(icm)
1217          _RL cmass(lng,K)
       DIMENSION IC(ICM),   IRND(icm)  
       dimension cmass(len,K)  
1218        LOGICAL SETRAS        LOGICAL SETRAS
1219          integer ifound
1220           do L = 1,k        _RL temp
1221           do I = 1,LENC        _RL thbef(lng,K)
1222           rains(i,l) = 0.  
1223           enddo        integer i,L,nc,ib,nt
1224           enddo        integer km1,kp1,kprv,kcr,kfx,ncmx
1225          _RL p00, crtmsf, frac, rasblf
1226    
1227          do L = 1,k
1228          do I = 1,LENC
1229           rains(i,l) = 0.
1230          enddo
1231          enddo
1232    
1233        p00 = 1000.        p00 = 1000.
1234        crtmsf = 0.        crtmsf = 0.
# Line 1214  C The numerator here is the fraction of Line 1237  C The numerator here is the fraction of
1237  C      allowed to entrain into the cloud  C      allowed to entrain into the cloud
1238    
1239  CCC   FRAC = 1./dt  CCC   FRAC = 1./dt
1240    CCC   FRAC = 0.5/dt
1241        FRAC = 0.5/dt        FRAC = 0.5/dt
1242    
1243        KM1    = K  - 1        KM1    = K  - 1
# Line 1259  c ------------------------------- Line 1283  c -------------------------------
1283        cloudn(i) = 0.0        cloudn(i) = 0.0
1284        enddo        enddo
1285    
1286         CALL CLOUD(nn,LEN, LENC, K, NLTOP, nlayr, IB, RASBLF,SETRAS,FRAC         CALL CLOUD(nn,lng, LENC, K, NLTOP, nlayr, IB, RASBLF,SETRAS,FRAC
1287       *,           CP,  ALHL, RKAPPA, GRAV, P00, CRTMSF       *,           CP,  ALHL, RKAPPA, GRAV, P00, CRTMSF
1288       *,           POI, QOI, UOI, Ntracer, PRS, PRJ       *,           POI, QOI, UOI, ntracedim, Ntracer, PRS, PRJ
1289       *,           PCU, CLOUDN, TCU, QCU, UCU, CMASS       *,           PCU, CLOUDN, TCU, QCU, UCU, CMASS
1290       *,           ALF, BET, GAM, PRH, PRI, HOI, ETA       *,           ALF, BET, GAM, PRH, PRI, HOI, ETA
1291       *,           HST, QOL, GMH       *,           HST, QOL, GMH
# Line 1304  c ***************************** Line 1328  c *****************************
1328    
1329        DO L=IB,K        DO L=IB,K
1330         DO I=1,LENC         DO I=1,LENC
1331            thbef(I,L) = POI(I,L)
1332          POI(I,L) = POI(I,L) + TCU(I,L) * DT * rhfrac(i)          POI(I,L) = POI(I,L) + TCU(I,L) * DT * rhfrac(i)
1333          QOI(I,L) = QOI(I,L) + QCU(I,L) * DT * rhfrac(i)          QOI(I,L) = QOI(I,L) + QCU(I,L) * DT * rhfrac(i)
1334         ENDDO         ENDDO
# Line 1319  c ***************************** Line 1344  c *****************************
1344         rains(I,ib) = rains(I,ib) + PCU(I)*dt * rhfrac(i)         rains(I,ib) = rains(I,ib) + PCU(I)*dt * rhfrac(i)
1345        ENDDO        ENDDO
1346    
1347          do i = 1,lenc
1348           ifound = 0
1349           do L = 1,k
1350            if(tcu(i,L).ne.0.)ifound = ifound + 1
1351           enddo
1352           if(ifound.ne.0) then
1353    c       print *,i,' made a cloud detraining at ',ib
1354            do L = 1,k
1355             temp = TCU(I,L) * DT * rhfrac(i)
1356    c        write(6,122)L,thbef(i,L),poi(i,L),temp
1357            enddo
1358           endif
1359          enddo
1360    
1361    100 CONTINUE    100 CONTINUE
1362    
1363     122  format(' ',i3,' TH B ',e10.3,' TH A ',e10.3,' DTH ',e10.3)
1364    
1365  c Fill Convective Cloud Fractions based on 3-D Rain Amounts  c Fill Convective Cloud Fractions based on 3-D Rain Amounts
1366  c ---------------------------------------------------------  c ---------------------------------------------------------
# Line 1332  c -------------------------------------- Line 1373  c --------------------------------------
1373    
1374        RETURN        RETURN
1375        END        END
   
1376        subroutine rndcloud (iras,nrnd,rnd,myid)        subroutine rndcloud (iras,nrnd,rnd,myid)
1377        implicit none        implicit none
1378        integer n,iras,nrnd,myid        integer n,iras,nrnd,myid
1379        real random_numbx        _RL random_numbx
1380        real rnd(nrnd)  c     _RL rnd(nrnd)
1381          _RL rnd(*)
1382        integer irm        integer irm
1383        parameter (irm = 1000)        parameter (irm = 1000)
1384        real random(irm)        _RL random(irm)
1385        integer i,mcheck,numrand,iseed,index        integer i,mcheck,iseed,indx
1386        logical first        logical first
1387        data    first /.true./        data    first /.true./
1388        integer iras0        integer iras0
1389        data    iras0 /0/        data    iras0 /0/
1390        save random, iras0        save random, iras0
1391    
1392        if(nrnd.eq.0.)then        if(nrnd.eq.0)then
1393         do i = 1,nrnd         do i = 1,nrnd
1394          rnd(i) = 0          rnd(i) = 0
1395         enddo         enddo
1396         if(first .and. myid.eq.0) print *,' NO RANDOM CLOUDS IN RAS '         if(first .and. myid.eq.1) print *,' NO RANDOM CLOUDS IN RAS '
1397         go to 100         go to 100
1398        endif        endif
1399    
1400        mcheck = mod(iras-1,irm/nrnd)        mcheck = mod(iras-1,irm/nrnd)
1401    
1402    c     print *,' RNDCLOUD: first ',first,' iras ',iras,' iras0 ',iras0
1403    c     print *,' RNDCLOUD: irm,nrnd,mcheck=',irm,nrnd,mcheck
1404    
1405          if ( iras.eq.iras0 ) then
1406    C-    Not the 1rst tile: we are all set (already done for the 1rst tile):
1407    c -----------------------------------------------------------------------
1408              indx = (iras-1)*nrnd
1409    
1410  c First Time In From a Continuing RESTART (IRAS.GT.1) or Reading a New RESTART  c First Time In From a Continuing RESTART (IRAS.GT.1) or Reading a New RESTART
1411    c   -- or --
1412    c Multiple Time In But have Used Up all 1000 numbers (MCHECK.EQ.0)
1413  c ----------------------------------------------------------------------------  c ----------------------------------------------------------------------------
1414        if( first.and.(iras.gt.1) .or. iras.ne.iras0+1 )then        elseif ( first.and.(iras.gt.1) .or. mcheck.eq.0 ) then
1415         if( myid.eq.0 ) print *, 'Recreating Rand Numb Array in RNDCLOUD'         iseed = (iras-1-mcheck)*nrnd
        if( myid.eq.0 ) print *, 'IRAS: ',iras,'  IRAS0: ',iras0  
        numrand = mod(iras,irm/nrnd) * nrnd  
        iseed   = iras * nrnd - numrand  
1416         call random_seedx(iseed)         call random_seedx(iseed)
1417         do i = 1,irm         do i = 1,irm
1418          random(i) = random_numbx()          random(i) = random_numbx(iseed)
1419         enddo         enddo
1420         index = (iras-1)*nrnd         indx = (iras-1)*nrnd
1421    
1422  c Multiple Time In But have Used Up all 1000 numbers (MCHECK.EQ.0)         if( myid.eq.1 ) print *, 'Creating Rand Numb Array in RNDCLOUD'
1423  c ----------------------------------------------------------------       &                        ,', iseed=', iseed
1424        else if (mcheck.eq.0) then         if( myid.eq.1 ) print *, 'IRAS: ',iras,'  IRAS0: ',iras0,
1425            iseed = (iras-1)*nrnd       &    ' indx: ', mod(indx,irm)
           call random_seedx(iseed)  
           do i = 1,irm  
            random(i) = random_numbx()  
           enddo  
           index = iseed  
1426    
1427  c Multiple Time In But have NOT Used Up all 1000 numbers (MCHECK.NE.0)  c Multiple Time In But have NOT Used Up all 1000 numbers (MCHECK.NE.0)
1428  c --------------------------------------------------------------------  c --------------------------------------------------------------------
1429        else        else
1430            index = (iras-1)*nrnd            indx = (iras-1)*nrnd
1431          endif
1432    
1433              indx = mod(indx,irm)
1434          if( indx+nrnd.gt.irm ) then
1435    c       if( myid.eq.1 .AND. iras.ne.iras0 ) print *,
1436    c    &   'reach end of Rand Numb Array in RNDCLOUD',indx,irm-nrnd
1437            indx=irm-nrnd
1438        endif        endif
1439    
           index = mod(index,irm)  
       if( index+nrnd.gt.1000 ) index=1000-nrnd  
   
1440        do n = 1,nrnd        do n = 1,nrnd
1441         rnd(n) = random(index+n)         rnd(n) = random(indx+n)
1442        enddo        enddo
1443    
1444   100  continue   100  continue
1445        first = .false.        first = .false.
1446        iras0 = iras        iras0 = iras
1447    
1448        return        return
1449        end        end
1450          function random_numbx(iseed)
       real function random_numbx()  
1451        implicit none        implicit none
1452  #if CRAY        integer iseed
1453        real ranf        real *8 seed,port_rand
1454          _RL random_numbx
1455    #ifdef CRAY
1456          _RL ranf
1457        random_numbx = ranf()        random_numbx = ranf()
1458  #endif  #else
1459  #if SGI  #ifdef SGI
1460        real rand        _RL rand
1461        random_numbx = rand()        random_numbx = rand()
1462    #else
1463          seed = -1.d0
1464          random_numbx = port_rand(seed)
1465    #endif
1466  #endif  #endif
1467        return        return
1468        end        end
1469        subroutine random_seedx (iseed)        subroutine random_seedx (iseed)
1470        implicit none        implicit none
1471        integer  iseed        integer  iseed
1472  #if CRAY        real *8 port_rand
1473    #ifdef CRAY
1474        call ranset (iseed)        call ranset (iseed)
1475  #endif  #else
1476  #if SGI  #ifdef SGI
1477        integer*4   seed        integer*4   seed
1478                    seed = iseed                    seed = iseed
1479        call srand (seed)        call srand (seed)
1480    #else
1481          real*8 tmpRdN
1482          real*8 seed
1483          seed = iseed
1484          tmpRdN = port_rand(seed)
1485    #endif
1486  #endif  #endif
1487        return        return
1488        end        end
1489          SUBROUTINE CLOUD(nn,lng, LENC, K, NLTOP, nlayr, IC, RASALF
       SUBROUTINE CLOUD(nn,LEN, LENC, K, NLTOP, nlayr, IC, RASALF,  
1490       *,                 SETRAS, FRAC       *,                 SETRAS, FRAC
1491       *,                 CP,  ALHL, RKAP, GRAV, P00, CRTMSF       *,                 CP,  ALHL, RKAP, GRAV, P00, CRTMSF
1492       *,                 POI, QOI, UOI, Ntracer, PRS,  PRJ       *,                 POI, QOI, UOI, ntracedim, Ntracer, PRS,  PRJ
1493       *,                 PCU, CLN, TCU, QCU, UCU, CMASS       *,                 PCU, CLN, TCU, QCU, UCU, CMASS
1494       *,                 ALF, BET, GAM, PRH, PRI, HOL, ETA       *,                 ALF, BET, GAM, PRH, PRI, HOL, ETA
1495       *,                 HST, QOL, GMH       *,                 HST, QOL, GMH
# Line 1468  C Line 1528  C
1528  C  Input:  C  Input:
1529  C  ------  C  ------
1530  C  C
1531  C     LEN     : The inner dimension of update and input arrays.  C     lng     : The inner dimension of update and input arrays.
1532  C  C
1533  C     LENC    : The run: the number of soundings processes in a single call.  C     LENC    : The run: the number of soundings processes in a single call.
1534  C               RAS works on the first LENC of the LEN soundings  C               RAS works on the first LENC of the lng soundings
1535  C               passed. This allows working on pieces of the world  C               passed. This allows working on pieces of the world
1536  C               say for multitasking, without declaring temporary arrays  C               say for multitasking, without declaring temporary arrays
1537  C               and copying the data to and from them.  This is an f77  C               and copying the data to and from them.  This is an f77
1538  C               version. An F90 version would have to allow more  C               version. An F90 version would have to allow more
1539  C               flexibility in the argument declarations.  Obviously  C               flexibility in the argument declarations.  Obviously
1540  C               (LENC<=LEN).    C               (LENC<=lng).  
1541  C  C
1542  C     K       : Number of vertical layers (increasing downwards).  C     K       : Number of vertical layers (increasing downwards).
1543  C               Need not be the same as the number of layers in the  C               Need not be the same as the number of layers in the
# Line 1508  C     CRTMSF  : Critical value of mass f Line 1568  C     CRTMSF  : Critical value of mass f
1568  C               the detrainment layer of that cloud-type is assumed.  C               the detrainment layer of that cloud-type is assumed.
1569  C               Affects only cloudiness calculation.  C               Affects only cloudiness calculation.
1570  C  C
1571  C     POI     : 2D array of dimension (LEN,K) containing potential  C     POI     : 2D array of dimension (lng,K) containing potential
1572  C               temperature. Updated but not initialized by RAS.  C               temperature. Updated but not initialized by RAS.
1573  C  C
1574  C     QOI     : 2D array of dimension (LEN,K) containing specific  C     QOI     : 2D array of dimension (lng,K) containing specific
1575  C               humidity. Updated but not initialized by RAS.  C               humidity. Updated but not initialized by RAS.
1576  C  C
1577  C     UOI     : 3D array of dimension (LEN,K,NTRACER) containing tracers  C     UOI     : 3D array of dimension (lng,K,NTRACER) containing tracers
1578  C               Updated but not initialized by RAS.  C               Updated but not initialized by RAS.
1579  C  C
1580  C     PRS     : 2D array of dimension (LEN,K+1) containing pressure  C     PRS     : 2D array of dimension (lng,K+1) containing pressure
1581  C               in hPa at the interfaces of K-layers from top of the  C               in hPa at the interfaces of K-layers from top of the
1582  C               atmosphere to the bottom. Not modified.  C               atmosphere to the bottom. Not modified.
1583  C  C
1584  C     PRJ     : 2D array of dimension (LEN,K+1) containing (PRS/P00) **  C     PRJ     : 2D array of dimension (lng,K+1) containing (PRS/P00) **
1585  C               RKAP.  i.e. Exner function at layer edges. Not modified.  C               RKAP.  i.e. Exner function at layer edges. Not modified.
1586  C  C
1587  C     rhfrac  : 1D array of dimension (LEN) containing a rel.hum. scaling  C     rhfrac  : 1D array of dimension (lng) containing a rel.hum. scaling
1588  C               fraction. Not modified.  C               fraction. Not modified.
1589  C  C
1590  C  Output:  C  Output:
1591  C  -------  C  -------
1592  C  C
1593  C     PCU     : 1D array of length LEN containing accumulated  C     PCU     : 1D array of length lng containing accumulated
1594  C               precipitation in mm/sec.  C               precipitation in mm/sec.
1595  C  C
1596  C     CLN     : 2D array of dimension (LEN,K) containing cloudiness  C     CLN     : 2D array of dimension (lng,K) containing cloudiness
1597  C               Note:  CLN is bumped but NOT initialized  C               Note:  CLN is bumped but NOT initialized
1598  C  C
1599  C     TCU     : 2D array of dimension (LEN,K) containing accumulated  C     TCU     : 2D array of dimension (lng,K) containing accumulated
1600  C               convective heating (K/sec).  C               convective heating (K/sec).
1601  C  C
1602  C     QCU     : 2D array of dimension (LEN,K) containing accumulated  C     QCU     : 2D array of dimension (lng,K) containing accumulated
1603  C               convective drying (kg/kg/sec).  C               convective drying (kg/kg/sec).
1604  C  C
1605  C     CMASS   : 2D array of dimension (LEN,K) containing the  C     CMASS   : 2D array of dimension (lng,K) containing the
1606  C               cloud mass flux (kg/sec). Filled from cloud top  C               cloud mass flux (kg/sec). Filled from cloud top
1607  C               to base.  C               to base.
1608  C  C
# Line 1560  C    IA, I1, and I2 are temporary intege Line 1620  C    IA, I1, and I2 are temporary intege
1620  C  C
1621  C  C
1622  C************************************************************************  C************************************************************************
1623  C        implicit none
1624  C  C Argument List declarations
1625          integer nn,lng,LENC,K,NLTOP,nlayr,ic,ntracedim, ntracer
1626          _RL rasalf
1627          LOGICAL SETRAS
1628          _RL frac, cp,  alhl, rkap, grav, p00, crtmsf
1629          _RL POI(lng,K),QOI(lng,K),PRS(lng,K+1),PRJ(lng,K+1)
1630          _RL uoi(lng,nlayr,ntracedim)
1631          _RL PCU(LENC), CLN(lng)
1632          _RL TCU(lng,K),QCU(lng,K),ucu(lng,k,ntracedim),CMASS(lng,K)
1633          _RL ALF(lng,K), BET(lng,K),  GAM(lng,K), PRH(lng,K), PRI(lng,K)
1634          _RL HOL(LENC,K), ETA(LENC,K), HST(LENC,K), QOL(LENC,K)
1635          _RL GMH(LENC,K)
1636          _RL TX1(LENC), TX2(LENC), TX3(LENC), TX4(LENC)
1637          _RL TX5(LENC), TX6(LENC), TX7(LENC), TX8(LENC)
1638          _RL ALM(LENC), WFN(LENC), AKM(LENC), QS1(LENC)
1639          _RL WLQ(LENC), CLF(LENC)
1640          _RL uht(lng,ntracedim)
1641          integer IA(LENC), I1(LENC),I2(LENC)
1642          _RL      rhfrac(lng)
1643    
1644    C Local Variables
1645          _RL daylen,half,one,zero,cmb2pa,rhmax
1646        PARAMETER (DAYLEN=86400.0,  HALF=0.5,  ONE=1.0, ZERO=0.0)        PARAMETER (DAYLEN=86400.0,  HALF=0.5,  ONE=1.0, ZERO=0.0)
1647        PARAMETER (CMB2PA=100.0)        PARAMETER (CMB2PA=100.0)
1648        PARAMETER (RHMAX=0.9999)        PARAMETER (RHMAX=0.9999)
1649          _RL rkapp1,onebcp,albcp,onebg,cpbg,twobal
1650  C  C
1651        integer nltop,ntracer,nlayr        integer nt,km1,ic1,i,L,len1,len2,isav,len11,ii
1652        DIMENSION POI(LEN,K),  QOI(LEN,K),  PRS(LEN,K+1)        integer lena,lena1,lenb
1653       *,         PRJ(LEN,K+1)        _RL tem,tem1
      *,         TCU(LEN,K),  QCU(LEN,K),  CMASS(LEN,K), CLN(LEN)  
       real uoi(len,nlayr,ntracer)  
       DIMENSION ALF(LEN,K), BET(LEN,K),  GAM(LEN,K)  
      *,         PRH(LEN,K), PRI(LEN,K)  
       DIMENSION AKM(LENC),   WFN(LENC)  
       DIMENSION HOL(LENC,K), QOL(LENC,K),  ETA(LENC,K), HST(LENC,K)  
      *,         GMH(LENC,K), ALM(LENC),    WLQ(LENC),   QS1(LENC)  
      *,         TX1(LENC),   TX2(LENC), TX3(LENC),   TX4(LENC)  
      *,         TX5(LENC),   TX6(LENC), TX7(LENC),   TX8(LENC)  
      *,         CLF(LENC),   PCU(LENC)  
       DIMENSION IA(LENC),    I1(LENC),  I2(LENC)  
       real      rhfrac(len)  
       real ucu(len,k,ntracer),uht(len,ntracer)  
       LOGICAL SETRAS  
   
       integer nt  
1654    
1655  c Explicit Inline Directives  c Explicit Inline Directives
1656  c --------------------------  c --------------------------
1657  #if CRAY  #ifdef CRAY
1658  #if f77  #ifdef f77
1659  cfpp$ expand (qsat)  cfpp$ expand (qsat)
1660  #endif  #endif
1661  #endif  #endif
# Line 1601  cfpp$ expand (qsat) Line 1666  cfpp$ expand (qsat)
1666        ONEBG  = 1.0  / GRAV        ONEBG  = 1.0  / GRAV
1667        CPBG   = CP   * ONEBG        CPBG   = CP   * ONEBG
1668        TWOBAL = 2.0 / ALHL        TWOBAL = 2.0 / ALHL
1669    
1670  C  C
1671        KM1 = K  - 1        KM1 = K  - 1
1672        IC1 = IC + 1        IC1 = IC + 1
1673  C  C
1674  C      SETTIING ALF, BET, GAM, PRH, AND PRI : DONE ONLY WHEN SETRAS=.T.  C      SETTING ALF, BET, GAM, PRH, AND PRI : DONE ONLY WHEN SETRAS=.T.
1675  C  C
1676    
1677        IF (SETRAS) THEN        IF (SETRAS) THEN
# Line 1634  C Line 1700  C
1700  C  C
1701  C  C
1702        DO 10 L=1,K        DO 10 L=1,K
1703        DO 10 I=1,LEN        DO 10 I=1,lng
1704        TCU(I,L) = 0.0        TCU(I,L) = 0.0
1705        QCU(I,L) = 0.0        QCU(I,L) = 0.0
1706        CMASS(I,L) = 0.0        CMASS(I,L) = 0.0
# Line 1902  C Line 1968  C
1968        DO I=1,LENB        DO I=1,LENB
1969        II = I1(I)        II = I1(I)
1970        TEM    = ETA(I,L) - ETA(I,L+1)        TEM    = ETA(I,L) - ETA(I,L+1)
1971        UHT(I,NT) = UHT(I,NT) + TEM * UOI(II,L+nltop-1,NT)        UHT(I,NT) = UHT(I,NT) + TEM *  UOI(II,L+nltop-1,NT)
1972        ENDDO        ENDDO
1973        ENDDO        ENDDO
1974        ENDDO        ENDDO
# Line 2122  C Line 2188  C
2188  c Compute Tracer Tendencies  c Compute Tracer Tendencies
2189  c -------------------------  c -------------------------
2190        do nt = 1,ntracer        do nt = 1,ntracer
2191    c
2192  c Tracer Tendency at the Bottom Layer  c Tracer Tendency at the Bottom Layer
2193  c -----------------------------------  c -----------------------------------
2194        DO 995 I=1,LENB        DO 995 I=1,LENB
2195        II = I1(I)        II = I1(I)
2196        TEM    = half*TX5(I) * PRI(II,K)        TEM    = half*TX5(I) * PRI(II,K)
2197        TX1(I) = (UOI(II,KM1+nltop-1,nt) - UOI(II,K+nltop-1,nt))        TX1(I) = ( UOI(II,KM1+nltop-1,nt) - UOI(II,K+nltop-1,nt))
2198        ucu(II,K,nt) = TEM * TX1(I)        ucu(II,K,nt) = TEM * TX1(I)
2199    995 CONTINUE    995 CONTINUE
2200    c
2201  c Tracer Tendency at all other Levels  c Tracer Tendency at all other Levels
2202  c -----------------------------------  c -----------------------------------
2203        DO 1020 L=KM1,IC1,-1        DO 1020 L=KM1,IC1,-1
# Line 2160  c ----------------------------------- Line 2226  c -----------------------------------
2226        II = I1(I)        II = I1(I)
2227        ucu(II,IC,nt) = TX1(I)        ucu(II,IC,nt) = TX1(I)
2228   1040 CONTINUE   1040 CONTINUE
2229    
2230        enddo        enddo
2231  C  C
2232  C     PENETRATIVE CONVECTION CALCULATION OVER  C     PENETRATIVE CONVECTION CALCULATION OVER
# Line 2168  C Line 2234  C
2234    
2235        RETURN        RETURN
2236        END        END
2237        SUBROUTINE RNCL(LEN, PL, RNO, CLF)        SUBROUTINE RNCL(lng, PL, RNO, CLF)
 C  
2238  C  C
2239  C*********************************************************************  C*********************************************************************
2240  C********************** Relaxed Arakawa-Schubert *********************  C********************** Relaxed Arakawa-Schubert *********************
2241  C************************   SUBROUTINE  RNCL  ************************  C************************   SUBROUTINE  RNCL  ************************
2242  C**************************** 23 July 1992 ***************************  C**************************** 23 July 1992 ***************************
2243  C*********************************************************************  C*********************************************************************
2244          implicit none
2245    C Argument List declarations
2246          integer lng
2247          _RL PL(lng),  RNO(lng), CLF(lng)
2248    
2249    C Local Variables
2250          _RL p5,p8,pt8,pt2,pfac,p4,p6,p7,p9,cucld,cfac
2251        PARAMETER (P5=500.0,  P8=800.0, PT8=0.8, PT2=0.2)        PARAMETER (P5=500.0,  P8=800.0, PT8=0.8, PT2=0.2)
2252        PARAMETER (PFAC=PT2/(P8-P5))        PARAMETER (PFAC=PT2/(P8-P5))
 C  
2253        PARAMETER (P4=400.0,    P6=401.0)        PARAMETER (P4=400.0,    P6=401.0)
2254        PARAMETER (P7=700.0,    P9=900.0)        PARAMETER (P7=700.0,    P9=900.0)
2255        PARAMETER (CUCLD=0.5,CFAC=CUCLD/(P6-P4))        PARAMETER (CUCLD=0.5,CFAC=CUCLD/(P6-P4))
2256    
2257          integer i
2258  C  C
2259        DIMENSION PL(LEN),  RNO(LEN), CLF(LEN)        DO 10 I=1,lng
   
       DO 10 I=1,LEN  
2260                             rno(i) = 1.0                             rno(i) = 1.0
2261  ccc   if( pl(i).le.400.0 ) rno(i) = max( 0.75, 1.0-0.0025*(400.0-pl(i)) )  ccc   if( pl(i).le.400.0 ) rno(i) = max( 0.75, 1.0-0.0025*(400.0-pl(i)) )
2262    
# Line 2213  CARIES Line 2283  CARIES
2283  C  C
2284        RETURN        RETURN
2285        END        END
2286        SUBROUTINE ACRITN ( LEN,PL,PLB,ACR )        SUBROUTINE ACRITN ( lng,PL,PLB,ACR )
2287    
2288  C*********************************************************************  C*********************************************************************
2289  C********************** Relaxed Arakawa-Schubert *********************  C********************** Relaxed Arakawa-Schubert *********************
# Line 2224  C****  Note:  Data obtained from January Line 2294  C****  Note:  Data obtained from January
2294  C****         from 4x5 46-layer GEOS Assimilation                *****  C****         from 4x5 46-layer GEOS Assimilation                *****
2295  C****                                                            *****  C****                                                            *****
2296  C*********************************************************************  C*********************************************************************
2297          implicit none
2298        real PL(LEN), PLB(LEN), ACR(LEN)  C Argument List declarations
2299          integer lng
2300          _RL PL(lng), PLB(lng), ACR(lng)
2301    
2302    C Local variables
2303          integer lma
2304        parameter  (lma=18)        parameter  (lma=18)
2305        real      p(lma)        _RL p(lma)
2306        real      a(lma)        _RL a(lma)
2307          integer i,L
2308          _RL temp
2309    
2310        data p  / 93.81, 111.65, 133.46, 157.80, 186.51,        data p  / 93.81, 111.65, 133.46, 157.80, 186.51,
2311       .         219.88, 257.40, 301.21, 352.49, 409.76,       .         219.88, 257.40, 301.21, 352.49, 409.76,
# Line 2243  C*************************************** Line 2319  C***************************************
2319    
2320    
2321        do L=1,lma-1        do L=1,lma-1
2322        do i=1,len        do i=1,lng
2323           if( pl(i).ge.p(L)   .and.           if( pl(i).ge.p(L)   .and.
2324       .       pl(i).le.p(L+1)) then       .       pl(i).le.p(L+1)) then
2325           temp = ( pl(i)-p(L) )/( p(L+1)-p(L) )           temp = ( pl(i)-p(L) )/( p(L+1)-p(L) )
# Line 2252  C*************************************** Line 2328  C***************************************
2328        enddo        enddo
2329        enddo        enddo
2330    
2331        do i=1,len        do i=1,lng
2332        if( pl(i).lt.p(1)   ) acr(i) = a(1)        if( pl(i).lt.p(1)   ) acr(i) = a(1)
2333        if( pl(i).gt.p(lma) ) acr(i) = a(lma)        if( pl(i).gt.p(lma) ) acr(i) = a(lma)
2334        enddo        enddo
2335    
2336        do i=1,len        do i=1,lng
2337        acr(i) = acr(i) * (plb(i)-pl(i))        acr(i) = acr(i) * (plb(i)-pl(i))
2338        enddo        enddo
2339    
2340        RETURN        RETURN
2341        END        END
2342         SUBROUTINE RNEVP(NN,IRUN,NLAY,TL,QL,RAIN,PL,CLFRAC,SP,DSIG,PLKE,         SUBROUTINE RNEVP(NN,IRUN,NLAY,TL,QL,RAIN,PL,CLFRAC,SP,DP,PLKE,
2343       1   PLK,TH,TEMP1,TEMP2,TEMP3,ITMP1,ITMP2,RCON,RLAR,CLSBTH,tmscl,       1   PLK,TH,TEMP1,TEMP2,TEMP3,ITMP1,ITMP2,RCON,RLAR,CLSBTH,tmscl,
2344       2   tmfrc,cp,gravity,alhl,gamfac,cldlz,RHCRIT,offset,alpha)       2   tmfrc,cp,gravity,alhl,gamfac,cldlz,RHCRIT,offset,alpha)
2345    
2346          implicit none
2347    C Argument List declarations
2348          integer nn,irun,nlay
2349          _RL TL(IRUN,NLAY),QL(IRUN,NLAY),RAIN(IRUN,NLAY),
2350         . PL(IRUN,NLAY),CLFRAC(IRUN,NLAY),SP(IRUN),TEMP1(IRUN,NLAY),
2351         . TEMP2(IRUN,NLAY),PLKE(IRUN,NLAY+1),
2352         . RCON(IRUN),RLAR(IRUN),DP(IRUN,NLAY),PLK(IRUN,NLAY),TH(IRUN,NLAY),
2353         . TEMP3(IRUN,NLAY)
2354          integer ITMP1(IRUN,NLAY),ITMP2(IRUN,NLAY)
2355          _RL CLSBTH(IRUN,NLAY)
2356          _RL tmscl,tmfrc,cp,gravity,alhl,gamfac,offset,alpha
2357          _RL cldlz(irun,nlay)
2358          _RL rhcrit(irun,nlay)
2359    C
2360    C Local Variables
2361          _RL zm1p04,zero,two89,zp44,zp01,half,zp578,one,thousand,z3600
2362          _RL zp1,zp001
2363        PARAMETER (ZM1P04 = -1.04E-4 )        PARAMETER (ZM1P04 = -1.04E-4 )
2364        PARAMETER (ZERO = 0.)        PARAMETER (ZERO = 0.)
2365        PARAMETER (TWO89= 2.89E-5)        PARAMETER (TWO89= 2.89E-5)
# Line 2280  C*************************************** Line 2373  C***************************************
2373        PARAMETER ( THOUSAND = 1000.)        PARAMETER ( THOUSAND = 1000.)
2374        PARAMETER ( Z3600 = 3600.)        PARAMETER ( Z3600 = 3600.)
2375  C  C
2376         DIMENSION TL(IRUN,NLAY),QL(IRUN,NLAY),RAIN(IRUN,NLAY),        _RL EVP9(IRUN,NLAY)
2377       $ PL(IRUN,NLAY),CLFRAC(IRUN,NLAY),SP(IRUN),TEMP1(IRUN,NLAY),        _RL water(irun),crystal(irun)
2378       $ TEMP2(IRUN,NLAY),PLKE(IRUN,NLAY),        _RL watevap(irun),iceevap(irun)
2379       $ RCON(IRUN),RLAR(IRUN),DSIG(NLAY),PLK(IRUN,NLAY),TH(IRUN,NLAY),        _RL fracwat,fracice, tice,rh,fact,dum
2380       $ TEMP3(IRUN,NLAY),ITMP1(IRUN,NLAY),        _RL rainmax(irun)
2381       $ ITMP2(IRUN,NLAY),CLSBTH(IRUN,NLAY)        _RL getcon,rphf,elocp,cpog,relax
2382  C        _RL exparg,arearat,rpow
2383         DIMENSION EVP9(IRUN,NLAY)  
2384         real water(irun),crystal(irun)        integer i,L,n,nlaym1,irnlay,irnlm1
        real watevap(irun),iceevap(irun)  
        real fracwat,fracice, tice,rh,fact,dum  
   
        real cldlz(irun,nlay)  
        real rhcrit(irun,nlay), rainmax(irun)  
        real offset, alpha  
2385    
2386  c Explicit Inline Directives  c Explicit Inline Directives
2387  c --------------------------  c --------------------------
2388  #if CRAY  #ifdef CRAY
2389  #if f77  #ifdef f77
2390  cfpp$ expand (qsat)  cfpp$ expand (qsat)
2391  #endif  #endif
2392  #endif  #endif
# Line 2348  C INVERSE OF MASS IN EACH LAYER Line 2435  C INVERSE OF MASS IN EACH LAYER
2435  c -----------------------------  c -----------------------------
2436        DO L = 1,NLAY        DO L = 1,NLAY
2437        DO I = 1,IRUN        DO I = 1,IRUN
2438        TEMP3(I,L) = SP(I) * DSIG(L)        TEMP3(I,L) = GRAVITY*ZP01 / DP(I,L)
       TEMP3(I,L) = GRAVITY*ZP01 / TEMP3(I,L)  
2439        ENDDO        ENDDO
2440        ENDDO        ENDDO
2441    
# Line 2497  C  ======= Line 2583  C  =======
2583  C    cloud ...... Cloud Fraction        (irun,irise)  C    cloud ...... Cloud Fraction        (irun,irise)
2584  C  C
2585  C***********************************************************************  C***********************************************************************
 C*                  GODDARD LABORATORY FOR ATMOSPHERES                 *  
 C***********************************************************************  
2586    
2587        implicit none        implicit none
2588        integer  irun,irise        integer  irun,irise
2589    
2590        real   th(irun,irise)        _RL   th(irun,irise)
2591        real    q(irun,irise)        _RL    q(irun,irise)
2592        real  plk(irun,irise)        _RL  plk(irun,irise)
2593        real   pl(irun,irise)        _RL   pl(irun,irise)
2594        real plke(irun,irise+1)        _RL plke(irun,irise+1)
2595    
2596        real tempth(irun)        _RL  cloud(irun,irise)
2597        real tempqs(irun)        _RL cldwat(irun,irise)
2598        real dhstar(irun)        _RL     qs(irun,irise)
2599        real  cloud(irun,irise)  
2600        real cldwat(irun,irise)        _RL cp, alhl, getcon, akap
2601        real     qs(irun,irise)        _RL ratio, temp, elocp
2602          _RL rhcrit,rh,dum
2603        real cp, alhl, getcon, akap, pcheck        integer i,L
2604        real ratio, temp, pke, elocp  
2605        real rhcrit,rh,dum,pbar,tbar        _RL rhc(irun,irise)
2606        integer i,L,ntradesu,ntradesl        _RL offset,alpha
   
       real factor  
       real rhc(irun,irise)  
       real offset,alpha  
2607    
2608  c Explicit Inline Directives  c Explicit Inline Directives
2609  c --------------------------  c --------------------------
2610  #if CRAY  #ifdef CRAY
2611  #if f77  #ifdef f77
2612  cfpp$ expand (qsat)  cfpp$ expand (qsat)
2613  #endif  #endif
2614  #endif  #endif
# Line 2569  c -------------------------------------- Line 2649  c --------------------------------------
2649        subroutine ctei ( th,q,cldfrc,cldwat,pl,plk,plke,im,lm )        subroutine ctei ( th,q,cldfrc,cldwat,pl,plk,plke,im,lm )
2650        implicit none        implicit none
2651        integer im,lm        integer im,lm
2652        real  th(im,lm),q(im,lm),plke(im,lm+1),cldwat(im,lm)        _RL  th(im,lm),q(im,lm),plke(im,lm+1),cldwat(im,lm)
2653        real plk(im,lm),pl(im,lm),cldfrc(im,lm)        _RL plk(im,lm),pl(im,lm),cldfrc(im,lm)
2654        integer i,L        integer i,L
2655        real    getcon,cp,alhl,elocp,cpoel,t,p,s,qs,dqsdt,dq        _RL    getcon,cp,alhl,elocp,cpoel,t,p,s,qs,dqsdt,dq
2656        real    k,krd,kmm,f        _RL    k,krd,kmm,f
2657    
2658        cp     = getcon('CP')        cp     = getcon('CP')
2659        alhl   = getcon('LATENT HEAT COND')        alhl   = getcon('LATENT HEAT COND')
# Line 2610  c -------------------------------------- Line 2690  c --------------------------------------
2690        subroutine back2grd(gathered,indeces,scattered,irun)        subroutine back2grd(gathered,indeces,scattered,irun)
2691        implicit none        implicit none
2692        integer i,irun,indeces(irun)        integer i,irun,indeces(irun)
2693        real gathered(irun),scattered(irun)        _RL gathered(irun),scattered(irun)
2694        real temp(irun)        _RL temp(irun)
2695        do i = 1,irun        do i = 1,irun
2696         temp(indeces(i)) = gathered(i)         temp(indeces(i)) = gathered(i)
2697        enddo        enddo
Legend:
Removed from v.1.3  
changed lines
  Added in v.1.29
  ViewVC Help
Powered by ViewVC 1.1.22