/[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.4 by molod, Wed Jul 7 19:33:48 2004 UTC revision 1.18 by molod, Wed Sep 1 22:42:18 2004 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,
      .   ntracer,ptracer,  
6       .   lowlevel,midlevel,nltop,nsubmin,nsubmax,Lup,       .   lowlevel,midlevel,nltop,nsubmin,nsubmax,Lup,
7       .   pkht,qqz,dumoist,dvmoist,dtmoist,dqmoist,       .   pz,plz,plze,dpres,pkht,pkl,tz,qz,bi,bj,ntracer,ptracer,
8         .   qqz,dumoist,dvmoist,dtmoist,dqmoist,
9       .   im,jm,lm,ptop,       .   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 "SIZE.h"
19    #include "diagnostics_SIZE.h"
20  #include "diagnostics.h"  #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 bi,bj,ntracer,ptracer        
28        integer lowlevel,midlevel,nltop,nsubmin,nsubmax,Lup        integer lowlevel,midlevel,nltop,nsubmin,nsubmax,Lup
29          _RL pz(im,jm),plz(im,jm,lm),plze(im,jm,lm+1),dpres(im,jm,lm)
30        integer im,jm,lm                        _RL pkht(im,jm,lm+1),pkl(im,jm,lm)
31        real  ptop                              _RL tz(im,jm,lm),qz(im,jm,lm,ntracer)      
32          _RL qqz(im,jm,lm)
33        integer ntracer,ptracer                _RL dumoist(im,jm,lm),dvmoist(im,jm,lm)
34          _RL dtmoist(im,jm,lm),dqmoist(im,jm,lm,ntracer)
35        real pz(im,jm)                          _RL ptop
36        real tz(im,jm,lm)                      integer iras
37        real qz(im,jm,lm,ntracer)              _RL rainlsp(im,jm),rainconv(im,jm),snowfall(im,jm)
38          integer nswcld,nswlz
39        real  pkht(im,jm,lm)                    _RL cldlsp_sw(im,jm,lm),cldras_sw(im,jm,lm)
40          _RL cldtot_sw(im,jm,lm),swlz(im,jm,lm)
41        real   qqz(im,jm,lm)                    integer nlwcld,nlwlz
42          _RL  cldlsp_lw(im,jm,lm),cldras_lw(im,jm,lm)
43        real dumoist(im,jm,lm)                  _RL  cldtot_lw(im,jm,lm),lwlz(im,jm,lm)
44        real dvmoist(im,jm,lm)                  logical lpnt
45        real dtmoist(im,jm,lm)                  integer myid
       real dqmoist(im,jm,lm,ntracer)    
   
       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                      
46    
47  c Local Variables  c Local Variables
48  c ---------------  c ---------------
49        integer    ncrnd,nsecf        integer    ncrnd,nsecf
50    
51        real       fracqq, rh,temp1,temp2,dum        _RL       fracqq, dum
52        integer    snowcrit        integer    snowcrit
53        parameter (fracqq = 0.1)        parameter (fracqq = 0.1)
54          _RL one
55          parameter (one=1.)
56    
57        real   cldsr(im,jm,lm)        _RL   cldsr(im,jm,lm)
58        real   srcld(istrip,lm)        _RL   srcld(istrip,lm)
59    
60        real plev        _RL plev
61        real cldnow,cldlsp_mem,cldras_mem,cldras,watnow,watmin,cldmin        _RL cldnow,cldlsp_mem,cldlsp,cldras_mem,cldras
62        real cldprs(im,jm),cldtmp(im,jm)        _RL watnow,watmin,cldmin
63        real cldhi (im,jm),cldlow(im,jm)        _RL cldprs(im,jm),cldtmp(im,jm)
64        real cldmid(im,jm),totcld(im,jm)        _RL cldhi (im,jm),cldlow(im,jm)
65          _RL cldmid(im,jm),totcld(im,jm)
66        real   CLDLS(im,jm,lm)  , CPEN(im,jm,lm)  
67        real    tmpimjm(im,jm)        _RL   CLDLS(im,jm,lm)  , CPEN(im,jm,lm)
68        real    lsp_new(im,jm)        _RL    tmpimjm(im,jm)
69        real   conv_new(im,jm)        _RL    lsp_new(im,jm)
70        real   snow_new(im,jm)        _RL   conv_new(im,jm)
71          _RL   snow_new(im,jm)
72    
73        real  qqcolmin(im,jm)        _RL  qqcolmin(im,jm)
74        real  qqcolmax(im,jm)        _RL  qqcolmax(im,jm)
75        integer levpbl(im,jm)        integer levpbl(im,jm)
76    
77  c Gathered Arrays for Variable Cloud Base  c Gathered Arrays for Variable Cloud Base
78  c ---------------------------------------  c ---------------------------------------
79        real    raincgath(im*jm)        _RL    raincgath(im*jm)
80        real     pigather(im*jm)        _RL     pigather(im*jm)
81        real     thgather(im*jm,lm)        _RL     thgather(im*jm,lm)
82        real     shgather(im*jm,lm)        _RL     shgather(im*jm,lm)
83        real    pkzgather(im*jm,lm)        _RL    pkzgather(im*jm,lm)
84        real    pkegather(im*jm,lm)        _RL    pkegather(im*jm,lm+1)
85        real    tmpgather(im*jm,lm)        _RL    plzgather(im*jm,lm)
86        real   deltgather(im*jm,lm)        _RL    plegather(im*jm,lm+1)
87        real   delqgather(im*jm,lm)        _RL     dpgather(im*jm,lm)
88        real      ugather(im*jm,lm,ntracer)        _RL    tmpgather(im*jm,lm)
89        real   delugather(im*jm,lm,ntracer)        _RL   deltgather(im*jm,lm)
90        real     deltrnev(im*jm,lm)        _RL   delqgather(im*jm,lm)
91        real     delqrnev(im*jm,lm)        _RL      ugather(im*jm,lm,ntracer)
92          _RL   delugather(im*jm,lm,ntracer)
93          _RL     deltrnev(im*jm,lm)
94          _RL     delqrnev(im*jm,lm)
95    
96        integer  nindeces(lm)        integer  nindeces(lm)
97        integer  pblindex(im*jm)        integer  pblindex(im*jm)
# Line 107  c -------------------------------------- Line 99  c --------------------------------------
99    
100  c Stripped Arrays  c Stripped Arrays
101  c ---------------  c ---------------
102        real saveth (istrip,lm)        _RL saveth (istrip,lm)
103        real saveq  (istrip,lm)        _RL saveq  (istrip,lm)
104        real saveu  (istrip,lm,ntracer)        _RL saveu  (istrip,lm,ntracer)
105        real usubcl (istrip,   ntracer)        _RL usubcl (istrip,   ntracer)
106    
107        real     ple(istrip,lm+1), gam(istrip,lm)        _RL     ple(istrip,lm+1)
108        real      TL(ISTRIP,lm)  , SHL(ISTRIP,lm)        _RL      dp(istrip,lm)
109        real      PL(ISTRIP,lm)  , PLK(ISTRIP,lm)        _RL      TL(ISTRIP,lm)  , SHL(ISTRIP,lm)
110        real    PLKE(ISTRIP,lm+1)        _RL      PL(ISTRIP,lm)  , PLK(ISTRIP,lm)
111        real      TH(ISTRIP,lm)  ,CVTH(ISTRIP,lm)        _RL    PLKE(ISTRIP,lm+1)
112        real   SHSAT(ISTRIP,lm)  , CVQ(ISTRIP,lm)        _RL      TH(ISTRIP,lm)  ,CVTH(ISTRIP,lm)
113        real      UL(ISTRIP,lm,ntracer)        _RL   CVQ(ISTRIP,lm)
114        real     cvu(istrip,lm,ntracer)        _RL      UL(ISTRIP,lm,ntracer)
115        real  CLMAXO(ISTRIP,lm),CLBOTH(ISTRIP,lm)        _RL     cvu(istrip,lm,ntracer)
116        real  CLSBTH(ISTRIP,lm)        _RL  CLMAXO(ISTRIP,lm),CLBOTH(ISTRIP,lm)
117        real    TMP1(ISTRIP,lm),  TMP2(ISTRIP,lm)        _RL  CLSBTH(ISTRIP,lm)
118        real    TMP3(ISTRIP,lm),  TMP4(ISTRIP,lm+1)        _RL    TMP1(ISTRIP,lm),  TMP2(ISTRIP,lm)
119        real    TMP5(ISTRIP,lm+1)        _RL    TMP3(ISTRIP,lm),  TMP4(ISTRIP,lm+1)
120          _RL    TMP5(ISTRIP,lm+1)
121        integer   ITMP1(ISTRIP,lm), ITMP2(ISTRIP,lm)        integer   ITMP1(ISTRIP,lm), ITMP2(ISTRIP,lm)
       integer   ITMP3(ISTRIP,lm)  
122    
123        real   PRECIP(ISTRIP), PCMID(ISTRIP), PCNET(ISTRIP)        _RL   PRECIP(ISTRIP), PCNET(ISTRIP)
124        real   PCLOW (ISTRIP),    SP(ISTRIP),  PREP(ISTRIP)        _RL   SP(ISTRIP),  PREP(ISTRIP)
125        real   PCPEN (ISTRIP,lm)        _RL   PCPEN (ISTRIP,lm)
126        integer pbl(istrip),depths(lm)        integer pbl(istrip),depths(lm)
127    
128        real   cldlz(istrip,lm), cldwater(im,jm,lm)        _RL   cldlz(istrip,lm), cldwater(im,jm,lm)
129        real   rhfrac(istrip), rhmin, pup, ppbl, rhcrit(istrip,lm)        _RL   rhfrac(istrip), rhmin, pup, ppbl, rhcrit(istrip,lm)
130        real   offset, alpha, rasmax        _RL   offset, alpha, rasmax
131    
132        logical first        logical first
133        logical lras        logical lras
134        real    clfrac (istrip,lm)        _RL    clfrac (istrip,lm)
135        real    cldmas (istrip,lm)        _RL    cldmas (istrip,lm)
136        real    detrain(istrip,lm)        _RL    detrain(istrip,lm)
137        real    psubcld    (istrip), psubcldg (im,jm)        _RL    psubcld    (istrip), psubcldg (im,jm)
138        real    psubcld_cnt(istrip), psubcldgc(im,jm)        _RL    psubcld_cnt(istrip), psubcldgc(im,jm)
139        real rnd(lm/2)        _RL rnd(lm/2)
140        DATA      FIRST /.TRUE./        DATA      FIRST /.TRUE./
141    
142        integer imstp,nsubcl,nlras        integer imstp,nsubcl,nlras
143        integer i,j,iloop,index,l,nn,num,numdeps,nt        integer i,j,iloop,indx,indgath,l,nn,num,numdeps,nt
144        real tmstp,tminv,sday,grav,alhl,cp,elocp,gamfac        _RL tmstp,tminv,sday,grav,alhl,cp,elocp,gamfac
145        real rkappa,p0kappa,p0kinv,ptopkap,pcheck        _RL rkappa,p0kappa,p0kinv,ptopkap,pcheck
146        real tice,getcon,pi        _RL tice,getcon,pi
147          integer ntracedim
148    
149  C **********************************************************************  C **********************************************************************
150  C ****                     INITIALIZATION                           ****  C ****                     INITIALIZATION                           ****
151  C **********************************************************************  C **********************************************************************
152    
153          ntracedim= max(ntracer-ptracer,1)
154        IMSTP  = nsecf(NDMOIST)        IMSTP  = nsecf(NDMOIST)
155        TMSTP  = FLOAT(IMSTP)        TMSTP  = FLOAT(IMSTP)
156        TMINV  = 1. /  TMSTP        TMINV  = 1. /  TMSTP
# Line 194  c Determine Total number of Random Cloud Line 188  c Determine Total number of Random Cloud
188  c ---------------------------------------------  c ---------------------------------------------
189        ncrnd = (lm-nltop+1)/2        ncrnd = (lm-nltop+1)/2
190    
191        if(first .and. myid.eq.0) then        if(first .and. myid.eq.1) then
192         print *         print *
193         print *,'Top Level Allowed for Convection : ',nltop         print *,'Top Level Allowed for Convection : ',nltop
194         print *,'          Highest Sub-Cloud Level: ',nsubmax         print *,'          Highest Sub-Cloud Level: ',nsubmax
# Line 238  c -------------------------------------- Line 232  c --------------------------------------
232    
233  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
234  c ----------------------------------------------------------------  c ----------------------------------------------------------------
235        index = 0        indx = 0
236        do L = nsubmin,nltop,-1        do L = nsubmin,nltop,-1
237         do j = 1,jm         do j = 1,jm
238         do i = 1,im         do i = 1,im
239          if(levpbl(i,j).eq.L) then          if(levpbl(i,j).eq.L) then
240           index = index + 1           indx = indx + 1
241           pblindex(index) = (j-1)*im + i           pblindex(indx) = (j-1)*im + i
242          endif          endif
243         enddo         enddo
244         enddo         enddo
245        enddo        enddo
246    
247        do index = 1,im*jm        do indx = 1,im*jm
248         levgather(index) = levpbl(pblindex(index),1)         levgather(indx) = levpbl(pblindex(indx),1)
249          pigather(index) =     pz(pblindex(index),1)          pigather(indx) =     pz(pblindex(indx),1)
250            pkegather(indx,lm+1) = pkht(pblindex(indx),1,lm+1)
251            plegather(indx,lm+1) = plze(pblindex(indx),1,lm+1)
252        enddo        enddo
253    
254        do L = 1,lm        do L = 1,lm
255         do index = 1,im*jm         do indx = 1,im*jm
256           thgather(index,L) =   tz(pblindex(index),1,L)           thgather(indx,L) = tz(pblindex(indx),1,L)
257           shgather(index,L) =   qz(pblindex(index),1,L,1)           shgather(indx,L) = qz(pblindex(indx),1,L,1)
258          pkegather(index,L) = pkht(pblindex(index),1,L)          pkegather(indx,L) = pkht(pblindex(indx),1,L)
259          pkzgather(index,L) = pkl (pblindex(index),1,L)          pkzgather(indx,L) = pkl(pblindex(indx),1,L)
260            plegather(indx,L) = plze(pblindex(indx),1,L)
261            plzgather(indx,L) = plz(pblindex(indx),1,L)
262             dpgather(indx,L) = dpres(pblindex(indx),1,L)
263         enddo         enddo
264        enddo        enddo
265        do nt = 1,ntracer-ptracer  c     do nt = 1,ntracer-ptracer
266        do L = 1,lm  c     do L = 1,lm
267         do index = 1,im*jm  c      do indx = 1,im*jm
268          ugather(index,L,nt) = qz(pblindex(index),1,L,nt+ptracer)  c       ugather(indx,L,nt) = qz(pblindex(indx),1,L,nt+ptracer)
269         enddo  c      enddo
270        enddo  c     enddo
271        enddo  c     enddo
272    
273  c bump the counter for number of calls to convection  c bump the counter for number of calls to convection
274  c --------------------------------------------------  c --------------------------------------------------
# Line 303  C ************************************** Line 302  C **************************************
302    
303         CALL STRIP (  pigather, SP      ,im*jm,ISTRIP,1 ,NN )         CALL STRIP (  pigather, SP      ,im*jm,ISTRIP,1 ,NN )
304         CALL STRIP ( pkzgather, PLK     ,im*jm,ISTRIP,lm,NN )         CALL STRIP ( pkzgather, PLK     ,im*jm,ISTRIP,lm,NN )
305         CALL STRIP ( pkegather, PLKE    ,im*jm,ISTRIP,lm,NN )         CALL STRIP ( pkegather, PLKE    ,im*jm,ISTRIP,lm+1,NN )
306           CALL STRIP ( plzgather, PL      ,im*jm,ISTRIP,lm,NN )
307           CALL STRIP ( plegather, PLE     ,im*jm,ISTRIP,lm+1,NN )
308           CALL STRIP (  dpgather, dp      ,im*jm,ISTRIP,lm,NN )
309         CALL STRIP (  thgather, TH      ,im*jm,ISTRIP,lm,NN )         CALL STRIP (  thgather, TH      ,im*jm,ISTRIP,lm,NN )
310         CALL STRIP (  shgather, SHL     ,im*jm,ISTRIP,lm,NN )         CALL STRIP (  shgather, SHL     ,im*jm,ISTRIP,lm,NN )
311         CALL STRINT( levgather, pbl     ,im*jm,ISTRIP,1 ,NN )         CALL STRINT( levgather, pbl     ,im*jm,ISTRIP,1 ,NN )
312    
313         do nt = 1,ntracer-ptracer  c      do nt = 1,ntracer-ptracer
314         call strip ( ugather(1,1,nt), ul(1,1,nt),im*jm,istrip,lm,nn )  c      call strip ( ugather(1,1,nt), ul(1,1,nt),im*jm,istrip,lm,nn )
315         enddo  c      enddo
   
       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  
316    
317  C **********************************************************************  C **********************************************************************
318  C ****        SETUP FOR RAS CUMULUS PARAMETERIZATION                ****  C ****        SETUP FOR RAS CUMULUS PARAMETERIZATION                ****
# Line 386  c -------------------------------------- Line 377  c --------------------------------------
377    
378  c Save initial value of tracers and compute sub-cloud value  c Save initial value of tracers and compute sub-cloud value
379  c ---------------------------------------------------------  c ---------------------------------------------------------
380         DO NT = 1,ntracer-ptracer  c      DO NT = 1,ntracer-ptracer
381            do  L = 1,lm  c         do  L = 1,lm
382            do  i = num,num+nindeces(nsubcl)-1  c         do  i = num,num+nindeces(nsubcl)-1
383            saveu(i,L,nt) = ul(i,L,nt)  c         saveu(i,L,nt) = ul(i,L,nt)
384            enddo  c         enddo
385            enddo  c         enddo
386            DO I=num,num+nindeces(nsubcl)-1  c         DO I=num,num+nindeces(nsubcl)-1
387            TMP1(I,2) = 0.  c         TMP1(I,2) = 0.
388            ENDDO  c         ENDDO
389            DO L=NSUBCL,lm  c         DO L=NSUBCL,lm
390            DO I=num,num+nindeces(nsubcl)-1  c         DO I=num,num+nindeces(nsubcl)-1
391             TMP1(I,2) = TMP1(I,2)+(PLE(I,L+1)-PLE(I,L))*UL(I,L,NT)/sp(i)  c          TMP1(I,2) = TMP1(I,2)+(PLE(I,L+1)-PLE(I,L))*UL(I,L,NT)/sp(i)
392            ENDDO  c         ENDDO
393            ENDDO  c         ENDDO
394            DO I=num,num+nindeces(nsubcl)-1  c         DO I=num,num+nindeces(nsubcl)-1
395            UL(I,NSUBCL,NT) = TMP1(I,2)*TMP1(I,4)  c         UL(I,NSUBCL,NT) = TMP1(I,2)*TMP1(I,4)
396               usubcl(i,nt) = ul(i,nsubcl,nt)  c            usubcl(i,nt) = ul(i,nsubcl,nt)
397            ENDDO  c         ENDDO
398         ENDDO  c      ENDDO
399    
400  c Compute Pressure Arrays for RAS  c Compute Pressure Arrays for RAS
401  c -------------------------------  c -------------------------------
# Line 418  c ------------------------------- Line 409  c -------------------------------
409         ENDDO         ENDDO
410         DO L=2,lm         DO L=2,lm
411         DO I=num,num+nindeces(nsubcl)-1         DO I=num,num+nindeces(nsubcl)-1
412          TMP5(I,L) = PLKE(I,L-1)*P0KINV          TMP5(I,L) = PLKE(I,L)*P0KINV
413         ENDDO         ENDDO
414         ENDDO         ENDDO
415         DO  I=num,num+nindeces(nsubcl)-1         DO  I=num,num+nindeces(nsubcl)-1
416          TMP4(I,lm+1) = PLE (I,lm+1)          TMP4(I,lm+1) = PLE (I,lm+1)
417          TMP5(I,lm+1) = PLKE(I,lm)*P0KINV          TMP5(I,lm+1) = PLKE(I,lm+1)*P0KINV
418         ENDDO         ENDDO
419         DO 113 I=num,num+nindeces(nsubcl)-1         DO 113 I=num,num+nindeces(nsubcl)-1
420          TMP4(I,NSUBCL+1) = PLE (I,lm+1)          TMP4(I,NSUBCL+1) = PLE (I,lm+1)
421          TMP5(I,NSUBCL+1) = PLKE(I,lm)*P0KINV          TMP5(I,NSUBCL+1) = PLKE(I,lm+1)*P0KINV
422   113   CONTINUE   113   CONTINUE
423    
424        do i=num,num+nindeces(nsubcl)-1        do i=num,num+nindeces(nsubcl)-1
# Line 464  C Top level of atan func above this rh_t Line 455  C Top level of atan func above this rh_t
455           rhcrit(i,L) = 1.           rhcrit(i,L) = 1.
456         enddo         enddo
457         do L = 1, nsubcl-1         do L = 1, nsubcl-1
458          pcheck = (1000.-ptop)*sig(L) + ptop          pcheck = pl(i,L)
459          if (pcheck .le. pup) then          if (pcheck .le. pup) then
460           rhcrit(i,L) = rhmin           rhcrit(i,L) = rhmin
461          else          else
462           ppbl = (1000.-ptop)*sig(nsubcl) + ptop           ppbl = pl(i,nsubcl)
463           rhcrit(i,L) = rhmin + (1.-rhmin)/(19.) *           rhcrit(i,L) = rhmin + (1.-rhmin)/(19.) *
464       .      ((atan( (2.*(pcheck-pup)/(ppbl-pup)-1.) *       .      ((atan( (2.*(pcheck-pup)/(ppbl-pup)-1.) *
465       .       tan(20.*pi/21.-0.5*pi) )       .       tan(20.*pi/21.-0.5*pi) )
# Line 489  c -------------------------------------- Line 480  c --------------------------------------
480        enddo        enddo
481    
482        CALL RAS ( NN,istrip,nindeces(nsubcl),NLRAS,NLTOP,lm,TMSTP        CALL RAS ( NN,istrip,nindeces(nsubcl),NLRAS,NLTOP,lm,TMSTP
483       1, UL(num,1,1),ntracer-ptracer,TH(num,NLTOP),SHL(num,NLTOP)       1, UL(num,1,1),ntracedim,TH(num,NLTOP),SHL(num,NLTOP)
484       2, TMP4(num,NLTOP), TMP5(num,NLTOP),rnd, ncrnd, PCPEN(num,NLTOP)       2, TMP4(num,NLTOP), TMP5(num,NLTOP),rnd, ncrnd, PCPEN(num,NLTOP)
485       3, CLBOTH(num,NLTOP), CLFRAC(num,NLTOP)       3, CLBOTH(num,NLTOP), CLFRAC(num,NLTOP)
486       4, cldmas(num,nltop), detrain(num,nltop)       4, cldmas(num,nltop), detrain(num,nltop)
# Line 498  c -------------------------------------- Line 489  c --------------------------------------
489  c Compute Diagnostic CLDMAS in RAS Subcloud Layers  c Compute Diagnostic CLDMAS in RAS Subcloud Layers
490  c ------------------------------------------------  c ------------------------------------------------
491         do L=nsubcl,lm         do L=nsubcl,lm
         dum = dsig(L)/(1.0-sige(nsubcl))  
492         do I=num,num+nindeces(nsubcl)-1         do I=num,num+nindeces(nsubcl)-1
493            dum = dp(i,L)/(ple(i,lm+1)-ple(i,nsubcl))
494          cldmas(i,L) = cldmas(i,L-1) - dum*cldmas(i,nsubcl-1)          cldmas(i,L) = cldmas(i,L-1) - dum*cldmas(i,nsubcl-1)
495         enddo         enddo
496         enddo         enddo
# Line 534  c ------------------------------------ Line 525  c ------------------------------------
525    
526  c Compute Tracer Tendency due to RAS  c Compute Tracer Tendency due to RAS
527  c ----------------------------------  c ----------------------------------
528         do nt = 1,ntracer-ptracer  c      do nt = 1,ntracer-ptracer
529          DO L=1,nsubcl-1  c       DO L=1,nsubcl-1
530          DO I=num,num+nindeces(nsubcl)-1  c       DO I=num,num+nindeces(nsubcl)-1
531           CVU(I,L,nt) = ( UL(I,L,nt)-saveu(i,l,nt) )*sp(i)*tminv  c        CVU(I,L,nt) = ( UL(I,L,nt)-saveu(i,l,nt) )*sp(i)*tminv
532          ENDDO  c       ENDDO
533          ENDDO  c       ENDDO
534          DO L=nsubcl,lm  c       DO L=nsubcl,lm
535          DO I=num,num+nindeces(nsubcl)-1  c       DO I=num,num+nindeces(nsubcl)-1
536           if( usubcl(i,nt).ne.0.0 ) then  c        if( usubcl(i,nt).ne.0.0 ) then
537            cvu(i,L,nt) = ( ul(i,nsubcl,nt)-usubcl(i,nt) ) *  c         cvu(i,L,nt) = ( ul(i,nsubcl,nt)-usubcl(i,nt) ) *
538       .                     ( saveu(i,L,nt)/usubcl(i,nt) )*sp(i)*tminv  c    .                     ( saveu(i,L,nt)/usubcl(i,nt) )*sp(i)*tminv
539           else  c        else
540            cvu(i,L,nt) = 0.0  c         cvu(i,L,nt) = 0.0
541           endif  c        endif
542          ENDDO  c       ENDDO
543          ENDDO  c       ENDDO
544         enddo  c      enddo
545    
546  c Compute Diagnostic PSUBCLD (Subcloud Layer Pressure)  c Compute Diagnostic PSUBCLD (Subcloud Layer Pressure)
547  c ----------------------------------------------------  c ----------------------------------------------------
# Line 581  C ************************************** Line 572  C **************************************
572    
573        call paste( CVTH,deltgather,istrip,im*jm,lm,NN )        call paste( CVTH,deltgather,istrip,im*jm,lm,NN )
574        call paste(  CVQ,delqgather,istrip,im*jm,lm,NN )        call paste(  CVQ,delqgather,istrip,im*jm,lm,NN )
575        do nt = 1,ntracer-ptracer  c     do nt = 1,ntracer-ptracer
576        call paste( CVU(1,1,nt),delugather(1,1,nt),istrip,im*jm,lm,NN )  c     call paste( CVU(1,1,nt),delugather(1,1,nt),istrip,im*jm,lm,NN )
577        enddo  c     enddo
578    
579  C **********************************************************************  C **********************************************************************
580  C     And now paste some arrays for filling diagnostics  C     And now paste some arrays for filling diagnostics
# Line 613  C ************************************** Line 604  C **************************************
604        ENDDO        ENDDO
605        ENDDO        ENDDO
606    
607         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,
608       .  PLK,TH,TMP1,TMP2,TMP3,ITMP1,ITMP2,PCNET,PRECIP,       .  PLK,TH,TMP1,TMP2,TMP3,ITMP1,ITMP2,PCNET,PRECIP,
609       .  CLSBTH,TMSTP,1.,cp,grav,alhl,gamfac,cldlz,rhcrit,offset,alpha)       .  CLSBTH,TMSTP,one,cp,grav,alhl,gamfac,cldlz,rhcrit,offset,alpha)
610    
611  C **********************************************************************  C **********************************************************************
612  C ****                     TENDENCY UPDATES                         ****  C ****                     TENDENCY UPDATES                         ****
# Line 775  c ------------ Line 766  c ------------
766    
767  c Tracers  c Tracers
768  c -------  c -------
769        do nt = 1,ntracer-ptracer  c     do nt = 1,ntracer-ptracer
770         do L = 1,lm  c      do L = 1,lm
771         call back2grd (delugather(1,L,nt),pblindex,  c      call back2grd (delugather(1,L,nt),pblindex,
772       .                                 dqmoist(1,1,L,ptracer+nt),im*jm)  c    .                                 dqmoist(1,1,L,ptracer+nt),im*jm)
773         enddo  c      enddo
774        enddo  c     enddo
775    
776    
777  C **********************************************************************  C **********************************************************************
778  C                          BUMP DIAGNOSTICS  C                          BUMP DIAGNOSTICS
779  C **********************************************************************  C **********************************************************************
780    
 c Clear-Sky (Above 400mb) Temperature  
 c -----------------------------------  
       if( itmpuclr.ne.0 .or. isphuclr.ne.0 ) then  
       do j = 1,jm  
       do i = 1,im  
       totcld(i,j) = 0.0  
       enddo  
       enddo  
       do L = 1,midlevel  
       do j = 1,jm  
       do i = 1,im  
        if(cldls(i,j,L).ne.0.0.or.cpen(i,j,L).ne.0.0)totcld(i,j) = 1.0  
       enddo  
       enddo  
       enddo  
       do L = 1,lm  
        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  
       endif  
781    
782  c Sub-Cloud Layer  c Sub-Cloud Layer
783  c -------------------------  c -------------------------
# Line 858  c Moist Processes Heating Rate Line 810  c Moist Processes Heating Rate
810  c ----------------------------  c ----------------------------
811        if(imoistt.gt.0) then        if(imoistt.gt.0) then
812        do L = 1,lm        do L = 1,lm
813        do i = 1,im*jm        do j = 1,jm
814        qdiag(i,1,imoistt+L-1,bi,bj) = qdiag(i,1,imoistt+L-1,bi,bj) +        do i = 1,im
815       .                      (dtmoist(i,1,L)*sday*pkzgather(i,L)/pz(i,1))         indgath = (j-1)*im + i
816          qdiag(i,j,imoistt+L-1,bi,bj) = qdiag(i,j,imoistt+L-1,bi,bj) +
817         .    (dtmoist(i,j,L)*sday*pkzgather(indgath,L)/pz(i,j))
818          enddo
819        enddo        enddo
820        enddo        enddo
821        endif        endif
# Line 882  c Cloud Mass Flux Line 837  c Cloud Mass Flux
837  c ---------------  c ---------------
838        if(icldmas.gt.0) then        if(icldmas.gt.0) then
839        do L = 1,lm        do L = 1,lm
840        do i = 1,im*jm        do j = 1,jm
841        qdiag(i,1,icldmas+L-1,bi,bj) = qdiag(i,1,icldmas+L-1,bi,bj) +        do i = 1,im
842       .                                                  tmpgather(i,L)         indgath = (j-1)*im + i
843          qdiag(i,j,icldmas+L-1,bi,bj) = qdiag(i,j,icldmas+L-1,bi,bj) +
844         .                               tmpgather(indgath,L)
845          enddo
846        enddo        enddo
847        enddo        enddo
848        endif        endif
# Line 893  c Detrained Cloud Mass Flux Line 851  c Detrained Cloud Mass Flux
851  c -------------------------  c -------------------------
852        if(idtrain.gt.0) then        if(idtrain.gt.0) then
853        do L = 1,lm        do L = 1,lm
854        do i = 1,im*jm        do j = 1,jm
855        qdiag(i,1,idtrain+L-1,bi,bj) = qdiag(i,1,idtrain+L-1,bi,bj) +        do i = 1,im
856       .                                                  pkegather(i,L)         indgath = (j-1)*im + i
857          qdiag(i,j,idtrain+L-1,bi,bj) = qdiag(i,j,idtrain+L-1,bi,bj) +
858         .                                pkegather(indgath,L)
859          enddo
860        enddo        enddo
861        enddo        enddo
862        endif        endif
# Line 904  c Grid-Scale Condensational Heating Rate Line 865  c Grid-Scale Condensational Heating Rate
865  c --------------------------------------  c --------------------------------------
866        if(idtls.gt.0) then        if(idtls.gt.0) then
867        do L = 1,lm        do L = 1,lm
868        do i = 1,im*jm        do j = 1,jm
869        qdiag(i,1,idtls+L-1,bi,bj) = qdiag(i,1,idtls+L-1,bi,bj) +        do i = 1,im
870       .                                                  deltrnev(i,L)         indgath = (j-1)*im + i
871          qdiag(i,j,idtls+L-1,bi,bj) = qdiag(i,j,idtls+L-1,bi,bj) +
872         .                               deltrnev(indgath,L)
873          enddo
874        enddo        enddo
875        enddo        enddo
876        endif        endif
# Line 915  c Grid-Scale Condensational Moistening R Line 879  c Grid-Scale Condensational Moistening R
879  c -----------------------------------------  c -----------------------------------------
880        if(idqls.gt.0) then        if(idqls.gt.0) then
881        do L = 1,lm        do L = 1,lm
882        do i = 1,im*jm        do j = 1,jm
883        qdiag(i,1,idqls+L-1,bi,bj) = qdiag(i,1,idqls+L-1,bi,bj) +        do i = 1,im
884       .                                                  delqrnev(i,L)         indgath = (j-1)*im + i
885          qdiag(i,j,idqls+L-1,bi,bj) = qdiag(i,j,idqls+L-1,bi,bj) +
886         .                                delqrnev(indgath,L)
887          enddo
888        enddo        enddo
889        enddo        enddo
890        endif        endif
# Line 938  c ------------------- Line 905  c -------------------
905  c Convective Precipitation  c Convective Precipitation
906  c ------------------------  c ------------------------
907        if(iprecon.gt.0) then        if(iprecon.gt.0) then
908        do i = 1,im*jm        do j = 1,jm
909        qdiag(i,1,iprecon,bi,bj) = qdiag(i,1,iprecon,bi,bj) +        do i = 1,im
910       .                                         raincgath(i)*sday*tminv         indgath = (j-1)*im + i
911          qdiag(i,j,iprecon,bi,bj) = qdiag(i,j,iprecon,bi,bj) +
912         .                      raincgath(indgath)*sday*tminv
913          enddo
914        enddo        enddo
915        endif        endif
916    
# Line 981  c ------------------------------------ Line 951  c ------------------------------------
951    
952        do L = 1,lm        do L = 1,lm
953        do i = 1,im*jm        do i = 1,im*jm
954         plev = sig(L)*pz(i,1)+ptop         plev = pl(i,L)
955    
956  c Compute Time-averaged Cloud and Water Amounts for Longwave Radiation  c Compute Time-averaged Cloud and Water Amounts for Longwave Radiation
957  c --------------------------------------------------------------------  c --------------------------------------------------------------------
# Line 1094  C ************************************** Line 1064  C **************************************
1064         nlwcld   = nlwcld   + 1         nlwcld   = nlwcld   + 1
1065         nswcld   = nswcld   + 1         nswcld   = nswcld   + 1
1066    
1067    #ifdef ALLOW_DIAGNOSTICS
1068           if( (bi.eq.1) .and. (bj.eq.1) ) then
1069         nmoistt  = nmoistt  + 1         nmoistt  = nmoistt  + 1
1070         nmoistq  = nmoistq  + 1         nmoistq  = nmoistq  + 1
1071         npreacc  = npreacc  + 1         npreacc  = npreacc  + 1
# Line 1104  C ************************************** Line 1076  C **************************************
1076    
1077         ndtls  = ndtls  + 1         ndtls  = ndtls  + 1
1078         ndqls  = ndqls  + 1         ndqls  = ndqls  + 1
1079           endif
1080    #endif
1081    
1082        RETURN        RETURN
1083        END        END
1084        SUBROUTINE RAS( NN, LEN, LENC, K, NLTOP, nlayr, DT        SUBROUTINE RAS( NN, LNG, LENC, K, NLTOP, nlayr, DT
1085       *,               UOI, ntracer, POI, QOI, PRS, PRJ, rnd, ncrnd       *,               UOI, ntracer, POI, QOI, PRS, PRJ, rnd, ncrnd
1086       *,               RAINS, CLN, CLF, cldmas, detrain       *,               RAINS, CLN, CLF, cldmas, detrain
1087       *,               cp,grav,rkappa,alhl,rhfrac,rasmax )       *,               cp,grav,rkappa,alhl,rhfrac,rasmax )
1088  C  C
1089  C*********************************************************************  C*********************************************************************
 C*********************** ARIES   MODEL *******************************  
1090  C********************* SUBROUTINE  RAS   *****************************  C********************* SUBROUTINE  RAS   *****************************
1091  C********************** 16 MARCH   1988 ******************************  C********************** 16 MARCH   1988 ******************************
1092  C*********************************************************************  C*********************************************************************
1093  C  C
1094          implicit none
1095    
1096    C Argument List
1097          integer nn,lng,lenc,k,nltop,nlayr
1098          integer ntracer
1099          integer ncrnd
1100          _RL dt
1101          _RL UOI(lng,nlayr,ntracer),   POI(lng,K)
1102          _RL QOI(lng,K), PRS(lng,K+1), PRJ(lng,K+1)
1103          _RL rnd(ncrnd)
1104          _RL RAINS(lng,K), CLN(lng,K), CLF(lng,K)
1105          _RL cldmas(lng,K), detrain(lng,K)
1106          _RL cp,grav,rkappa,alhl,rhfrac(lng),rasmax
1107    
1108    C Local Variables
1109          _RL TCU(lng,K), QCU(lng,K)
1110          _RL ucu(lng,K,ntracer)
1111          _RL ALF(lng,K), BET(lng,K), GAM(lng,K)
1112         *,         ETA(lng,K), HOI(lng,K)
1113         *,         PRH(lng,K), PRI(lng,K)
1114          _RL HST(lng,K), QOL(lng,K), GMH(lng,K)
1115    
1116          _RL TX1(lng), TX2(lng), TX3(lng), TX4(lng), TX5(lng)
1117         *,         TX6(lng), TX7(lng), TX8(lng), TX9(lng)
1118         *,         TX11(lng), TX12(lng), TX13(lng), TX14(lng,ntracer)
1119         *,         TX15(lng)
1120         *,         WFN(lng)
1121          integer IA1(lng), IA2(lng), IA3(lng)
1122          _RL cloudn(lng), pcu(lng)
1123    
1124          integer krmin,icm
1125          _RL rknob, cmb2pa
1126        PARAMETER (KRMIN=01)        PARAMETER (KRMIN=01)
1127        PARAMETER (ICM=1000)        PARAMETER (ICM=1000)
1128        PARAMETER (CMB2PA=100.0)        PARAMETER (CMB2PA=100.0)
1129        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)  
1130    
1131        real rhfrac(len),rasmax        integer IC(ICM),   IRND(icm)
1132          _RL cmass(lng,K)
       DIMENSION IC(ICM),   IRND(icm)  
       dimension cmass(len,K)  
1133        LOGICAL SETRAS        LOGICAL SETRAS
1134    
1135           do L = 1,k        integer i,L,nc,ib,nt
1136           do I = 1,LENC        integer km1,kp1,kprv,kcr,kfx,ncmx
1137           rains(i,l) = 0.        _RL p00, crtmsf, frac, rasblf
1138           enddo  
1139           enddo        do L = 1,k
1140          do I = 1,LENC
1141           rains(i,l) = 0.
1142          enddo
1143          enddo
1144    
1145        p00 = 1000.        p00 = 1000.
1146        crtmsf = 0.        crtmsf = 0.
# Line 1209  c ------------------------------- Line 1194  c -------------------------------
1194        cloudn(i) = 0.0        cloudn(i) = 0.0
1195        enddo        enddo
1196    
1197         CALL CLOUD(nn,LEN, LENC, K, NLTOP, nlayr, IB, RASBLF,SETRAS,FRAC         CALL CLOUD(nn,lng, LENC, K, NLTOP, nlayr, IB, RASBLF,SETRAS,FRAC
1198       *,           CP,  ALHL, RKAPPA, GRAV, P00, CRTMSF       *,           CP,  ALHL, RKAPPA, GRAV, P00, CRTMSF
1199       *,           POI, QOI, UOI, Ntracer, PRS, PRJ       *,           POI, QOI, UOI, Ntracer, PRS, PRJ
1200       *,           PCU, CLOUDN, TCU, QCU, UCU, CMASS       *,           PCU, CLOUDN, TCU, QCU, UCU, CMASS
# Line 1258  c ***************************** Line 1243  c *****************************
1243          QOI(I,L) = QOI(I,L) + QCU(I,L) * DT * rhfrac(i)          QOI(I,L) = QOI(I,L) + QCU(I,L) * DT * rhfrac(i)
1244         ENDDO         ENDDO
1245        ENDDO        ENDDO
1246        DO NT=1,Ntracer  c     DO NT=1,Ntracer
1247        DO L=IB,K  c     DO L=IB,K
1248         DO I=1,LENC  c      DO I=1,LENC
1249          UOI(I,L+nltop-1,NT)=UOI(I,L+nltop-1,NT)+UCU(I,L,NT)*DT*rhfrac(i)  c       UOI(I,L+nltop-1,NT)=UOI(I,L+nltop-1,NT)+UCU(I,L,NT)*DT*rhfrac(i)
1250         ENDDO  c      ENDDO
1251        ENDDO  c     ENDDO
1252        ENDDO  c     ENDDO
1253        DO I=1,LENC        DO I=1,LENC
1254         rains(I,ib) = rains(I,ib) + PCU(I)*dt * rhfrac(i)         rains(I,ib) = rains(I,ib) + PCU(I)*dt * rhfrac(i)
1255        ENDDO        ENDDO
# Line 1282  c -------------------------------------- Line 1267  c --------------------------------------
1267    
1268        RETURN        RETURN
1269        END        END
   
1270        subroutine rndcloud (iras,nrnd,rnd,myid)        subroutine rndcloud (iras,nrnd,rnd,myid)
1271        implicit none        implicit none
1272        integer n,iras,nrnd,myid        integer n,iras,nrnd,myid
1273        real random_numbx        _RL random_numbx
1274        real rnd(nrnd)        _RL rnd(nrnd)
1275        integer irm        integer irm
1276        parameter (irm = 1000)        parameter (irm = 1000)
1277        real random(irm)        _RL random(irm)
1278        integer i,mcheck,numrand,iseed,index        integer i,mcheck,numrand,iseed,indx
1279        logical first        logical first
1280        data    first /.true./        data    first /.true./
1281        integer iras0        integer iras0
# Line 1302  c -------------------------------------- Line 1286  c --------------------------------------
1286         do i = 1,nrnd         do i = 1,nrnd
1287          rnd(i) = 0          rnd(i) = 0
1288         enddo         enddo
1289         if(first .and. myid.eq.0) print *,' NO RANDOM CLOUDS IN RAS '         if(first .and. myid.eq.1) print *,' NO RANDOM CLOUDS IN RAS '
1290         go to 100         go to 100
1291        endif        endif
1292    
# Line 1311  c -------------------------------------- Line 1295  c --------------------------------------
1295  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
1296  c ----------------------------------------------------------------------------  c ----------------------------------------------------------------------------
1297        if( first.and.(iras.gt.1) .or. iras.ne.iras0+1 )then        if( first.and.(iras.gt.1) .or. iras.ne.iras0+1 )then
1298         if( myid.eq.0 ) print *, 'Recreating Rand Numb Array in RNDCLOUD'         print *,' first ',first,' iras ',iras,' iras0 ',iras0
1299         if( myid.eq.0 ) print *, 'IRAS: ',iras,'  IRAS0: ',iras0         if( myid.eq.1 ) print *, 'Recreating Rand Numb Array in RNDCLOUD'
1300           if( myid.eq.1 ) print *, 'IRAS: ',iras,'  IRAS0: ',iras0
1301         numrand = mod(iras,irm/nrnd) * nrnd         numrand = mod(iras,irm/nrnd) * nrnd
1302         iseed   = iras * nrnd - numrand         iseed   = iras * nrnd - numrand
1303         call random_seedx(iseed)         call random_seedx(iseed)
1304         do i = 1,irm         do i = 1,irm
1305          random(i) = random_numbx()          random(i) = random_numbx(iseed)
1306         enddo         enddo
1307         index = (iras-1)*nrnd         indx = (iras-1)*nrnd
1308    
1309  c Multiple Time In But have Used Up all 1000 numbers (MCHECK.EQ.0)  c Multiple Time In But have Used Up all 1000 numbers (MCHECK.EQ.0)
1310  c ----------------------------------------------------------------  c ----------------------------------------------------------------
# Line 1327  c -------------------------------------- Line 1312  c --------------------------------------
1312            iseed = (iras-1)*nrnd            iseed = (iras-1)*nrnd
1313            call random_seedx(iseed)            call random_seedx(iseed)
1314            do i = 1,irm            do i = 1,irm
1315             random(i) = random_numbx()             random(i) = random_numbx(iseed)
1316            enddo            enddo
1317            index = iseed            indx = iseed
1318    
1319  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)
1320  c --------------------------------------------------------------------  c --------------------------------------------------------------------
1321        else        else
1322            index = (iras-1)*nrnd            indx = (iras-1)*nrnd
1323        endif        endif
1324    
1325            index = mod(index,irm)            indx = mod(indx,irm)
1326        if( index+nrnd.gt.1000 ) index=1000-nrnd        if( indx+nrnd.gt.1000 ) indx=1000-nrnd
1327    
1328        do n = 1,nrnd        do n = 1,nrnd
1329         rnd(n) = random(index+n)         rnd(n) = random(indx+n)
1330        enddo        enddo
1331    
1332   100  continue   100  continue
# Line 1349  c -------------------------------------- Line 1334  c --------------------------------------
1334        iras0 = iras        iras0 = iras
1335        return        return
1336        end        end
1337          function random_numbx(iseed)
       real function random_numbx()  
1338        implicit none        implicit none
1339  #if CRAY        integer iseed
1340        real ranf        real *8 seed,port_rand
1341          _RL random_numbx
1342          random_numbx = 0
1343    #ifdef CRAY
1344          _RL ranf
1345        random_numbx = ranf()        random_numbx = ranf()
1346  #endif  #else
1347  #if SGI  #ifdef SGI
1348        real rand        _RL rand
1349        random_numbx = rand()        random_numbx = rand()
1350  #endif  #endif
1351          random_numbx = port_rand(seed)
1352    #endif
1353        return        return
1354        end        end
1355        subroutine random_seedx (iseed)        subroutine random_seedx (iseed)
1356        implicit none        implicit none
1357        integer  iseed        integer  iseed
1358  #if CRAY  #ifdef CRAY
1359        call ranset (iseed)        call ranset (iseed)
1360  #endif  #endif
1361  #if SGI  #ifdef SGI
1362        integer*4   seed        integer*4   seed
1363                    seed = iseed                    seed = iseed
1364        call srand (seed)        call srand (seed)
1365  #endif  #endif
1366        return        return
1367        end        end
1368          SUBROUTINE CLOUD(nn,lng, LENC, K, NLTOP, nlayr, IC, RASALF
       SUBROUTINE CLOUD(nn,LEN, LENC, K, NLTOP, nlayr, IC, RASALF,  
1369       *,                 SETRAS, FRAC       *,                 SETRAS, FRAC
1370       *,                 CP,  ALHL, RKAP, GRAV, P00, CRTMSF       *,                 CP,  ALHL, RKAP, GRAV, P00, CRTMSF
1371       *,                 POI, QOI, UOI, Ntracer, PRS,  PRJ       *,                 POI, QOI, UOI, Ntracer, PRS,  PRJ
# Line 1418  C Line 1407  C
1407  C  Input:  C  Input:
1408  C  ------  C  ------
1409  C  C
1410  C     LEN     : The inner dimension of update and input arrays.  C     lng     : The inner dimension of update and input arrays.
1411  C  C
1412  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.
1413  C               RAS works on the first LENC of the LEN soundings  C               RAS works on the first LENC of the lng soundings
1414  C               passed. This allows working on pieces of the world  C               passed. This allows working on pieces of the world
1415  C               say for multitasking, without declaring temporary arrays  C               say for multitasking, without declaring temporary arrays
1416  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
1417  C               version. An F90 version would have to allow more  C               version. An F90 version would have to allow more
1418  C               flexibility in the argument declarations.  Obviously  C               flexibility in the argument declarations.  Obviously
1419  C               (LENC<=LEN).    C               (LENC<=lng).  
1420  C  C
1421  C     K       : Number of vertical layers (increasing downwards).  C     K       : Number of vertical layers (increasing downwards).
1422  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 1458  C     CRTMSF  : Critical value of mass f Line 1447  C     CRTMSF  : Critical value of mass f
1447  C               the detrainment layer of that cloud-type is assumed.  C               the detrainment layer of that cloud-type is assumed.
1448  C               Affects only cloudiness calculation.  C               Affects only cloudiness calculation.
1449  C  C
1450  C     POI     : 2D array of dimension (LEN,K) containing potential  C     POI     : 2D array of dimension (lng,K) containing potential
1451  C               temperature. Updated but not initialized by RAS.  C               temperature. Updated but not initialized by RAS.
1452  C  C
1453  C     QOI     : 2D array of dimension (LEN,K) containing specific  C     QOI     : 2D array of dimension (lng,K) containing specific
1454  C               humidity. Updated but not initialized by RAS.  C               humidity. Updated but not initialized by RAS.
1455  C  C
1456  C     UOI     : 3D array of dimension (LEN,K,NTRACER) containing tracers  C     UOI     : 3D array of dimension (lng,K,NTRACER) containing tracers
1457  C               Updated but not initialized by RAS.  C               Updated but not initialized by RAS.
1458  C  C
1459  C     PRS     : 2D array of dimension (LEN,K+1) containing pressure  C     PRS     : 2D array of dimension (lng,K+1) containing pressure
1460  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
1461  C               atmosphere to the bottom. Not modified.  C               atmosphere to the bottom. Not modified.
1462  C  C
1463  C     PRJ     : 2D array of dimension (LEN,K+1) containing (PRS/P00) **  C     PRJ     : 2D array of dimension (lng,K+1) containing (PRS/P00) **
1464  C               RKAP.  i.e. Exner function at layer edges. Not modified.  C               RKAP.  i.e. Exner function at layer edges. Not modified.
1465  C  C
1466  C     rhfrac  : 1D array of dimension (LEN) containing a rel.hum. scaling  C     rhfrac  : 1D array of dimension (lng) containing a rel.hum. scaling
1467  C               fraction. Not modified.  C               fraction. Not modified.
1468  C  C
1469  C  Output:  C  Output:
1470  C  -------  C  -------
1471  C  C
1472  C     PCU     : 1D array of length LEN containing accumulated  C     PCU     : 1D array of length lng containing accumulated
1473  C               precipitation in mm/sec.  C               precipitation in mm/sec.
1474  C  C
1475  C     CLN     : 2D array of dimension (LEN,K) containing cloudiness  C     CLN     : 2D array of dimension (lng,K) containing cloudiness
1476  C               Note:  CLN is bumped but NOT initialized  C               Note:  CLN is bumped but NOT initialized
1477  C  C
1478  C     TCU     : 2D array of dimension (LEN,K) containing accumulated  C     TCU     : 2D array of dimension (lng,K) containing accumulated
1479  C               convective heating (K/sec).  C               convective heating (K/sec).
1480  C  C
1481  C     QCU     : 2D array of dimension (LEN,K) containing accumulated  C     QCU     : 2D array of dimension (lng,K) containing accumulated
1482  C               convective drying (kg/kg/sec).  C               convective drying (kg/kg/sec).
1483  C  C
1484  C     CMASS   : 2D array of dimension (LEN,K) containing the  C     CMASS   : 2D array of dimension (lng,K) containing the
1485  C               cloud mass flux (kg/sec). Filled from cloud top  C               cloud mass flux (kg/sec). Filled from cloud top
1486  C               to base.  C               to base.
1487  C  C
# Line 1510  C    IA, I1, and I2 are temporary intege Line 1499  C    IA, I1, and I2 are temporary intege
1499  C  C
1500  C  C
1501  C************************************************************************  C************************************************************************
1502  C        implicit none
1503  C  C Argument List declarations
1504          integer nn,lng,LENC,K,NLTOP,nlayr,ic,ntracer
1505          _RL rasalf
1506          LOGICAL SETRAS
1507          _RL frac, cp,  alhl, rkap, grav, p00, crtmsf
1508          _RL POI(lng,K),QOI(lng,K),PRS(lng,K+1),PRJ(lng,K+1)
1509          _RL uoi(lng,nlayr,ntracer)
1510          _RL PCU(LENC), CLN(lng)
1511          _RL TCU(lng,K),  QCU(lng,K),  ucu(lng,k,ntracer), CMASS(lng,K)
1512          _RL ALF(lng,K), BET(lng,K),  GAM(lng,K), PRH(lng,K), PRI(lng,K)
1513          _RL HOL(LENC,K), ETA(LENC,K), HST(LENC,K), QOL(LENC,K)
1514          _RL GMH(LENC,K)
1515          _RL TX1(LENC), TX2(LENC), TX3(LENC), TX4(LENC)
1516          _RL TX5(LENC), TX6(LENC), TX7(LENC), TX8(LENC)
1517          _RL ALM(LENC), WFN(LENC), AKM(LENC), QS1(LENC)
1518          _RL WLQ(LENC), CLF(LENC)
1519          _RL uht(lng,ntracer)
1520          integer IA(LENC), I1(LENC),I2(LENC)
1521          _RL      rhfrac(lng)
1522    
1523    C Local Variables
1524          _RL daylen,half,one,zero,cmb2pa,rhmax
1525        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)
1526        PARAMETER (CMB2PA=100.0)        PARAMETER (CMB2PA=100.0)
1527        PARAMETER (RHMAX=0.9999)        PARAMETER (RHMAX=0.9999)
1528          _RL rkapp1,onebcp,albcp,onebg,cpbg,twobal
1529  C  C
1530        integer nltop,ntracer,nlayr        integer nt,km1,ic1,i,L,len1,len2,isav,len11,ii
1531        DIMENSION POI(LEN,K),  QOI(LEN,K),  PRS(LEN,K+1)        integer lena,lena1,lenb
1532       *,         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  
1533    
1534  c Explicit Inline Directives  c Explicit Inline Directives
1535  c --------------------------  c --------------------------
1536  #if CRAY  #ifdef CRAY
1537  #if f77  #ifdef f77
1538  cfpp$ expand (qsat)  cfpp$ expand (qsat)
1539  #endif  #endif
1540  #endif  #endif
# Line 1555  C Line 1549  C
1549        KM1 = K  - 1        KM1 = K  - 1
1550        IC1 = IC + 1        IC1 = IC + 1
1551  C  C
1552  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.
1553  C  C
1554    
1555        IF (SETRAS) THEN        IF (SETRAS) THEN
# Line 1584  C Line 1578  C
1578  C  C
1579  C  C
1580        DO 10 L=1,K        DO 10 L=1,K
1581        DO 10 I=1,LEN        DO 10 I=1,lng
1582        TCU(I,L) = 0.0        TCU(I,L) = 0.0
1583        QCU(I,L) = 0.0        QCU(I,L) = 0.0
1584        CMASS(I,L) = 0.0        CMASS(I,L) = 0.0
1585     10 CONTINUE     10 CONTINUE
1586    
1587        do nt = 1,ntracer  c     do nt = 1,ntracer
1588        do L=1,K  c     do L=1,K
1589        do I=1,LENC  c     do I=1,LENC
1590        ucu(I,L,nt) = 0.0  c     ucu(I,L,nt) = 0.0
1591        enddo  c     enddo
1592        enddo  c     enddo
1593        enddo  c     enddo
1594  C  C
1595        DO 30 I=1,LENC        DO 30 I=1,LENC
1596        TX1(I)   = PRJ(I,K+1) * POI(I,K)        TX1(I)   = PRJ(I,K+1) * POI(I,K)
# Line 1833  C Line 1827  C
1827        WLQ(I) = QOL(II,K) - QS1(I)     * ETA(I,IC)        WLQ(I) = QOL(II,K) - QS1(I)     * ETA(I,IC)
1828        TX7(I) = HOL(II,K)        TX7(I) = HOL(II,K)
1829    620 CONTINUE    620 CONTINUE
1830        DO NT=1,Ntracer  c     DO NT=1,Ntracer
1831        DO 621 I=1,LENB  c     DO 621 I=1,LENB
1832        II = I1(I)  c     II = I1(I)
1833        UHT(I,NT) = UOI(II,K+nltop-1,NT)-UOI(II,IC+nltop-1,NT) * ETA(I,IC)  c     UHT(I,NT) = UOI(II,K+nltop-1,NT)-UOI(II,IC+nltop-1,NT) * ETA(I,IC)
1834    621 CONTINUE  c 621 CONTINUE
1835        ENDDO  c     ENDDO
1836  C  C
1837        DO 635 L=KM1,IC,-1        DO 635 L=KM1,IC,-1
1838        DO 630 I=1,LENB        DO 630 I=1,LENB
# Line 1847  C Line 1841  C
1841        WLQ(I) = WLQ(I) + TEM * QOL(II,L)        WLQ(I) = WLQ(I) + TEM * QOL(II,L)
1842    630 CONTINUE    630 CONTINUE
1843    635 CONTINUE    635 CONTINUE
1844        DO NT=1,Ntracer  c     DO NT=1,Ntracer
1845        DO L=KM1,IC,-1  c     DO L=KM1,IC,-1
1846        DO I=1,LENB  c     DO I=1,LENB
1847        II = I1(I)  c     II = I1(I)
1848        TEM    = ETA(I,L) - ETA(I,L+1)  c     TEM    = ETA(I,L) - ETA(I,L+1)
1849        UHT(I,NT) = UHT(I,NT) + TEM * UOI(II,L+nltop-1,NT)  c     UHT(I,NT) = UHT(I,NT) + TEM * UOI(II,L+nltop-1,NT)
1850        ENDDO  c     ENDDO
1851        ENDDO  c     ENDDO
1852        ENDDO  c     ENDDO
1853  C  C
1854  C     CALCULATE GS AND PART OF AKM (THAT REQUIRES ETA)  C     CALCULATE GS AND PART OF AKM (THAT REQUIRES ETA)
1855  C  C
# Line 2071  C Line 2065  C
2065  C  C
2066  c Compute Tracer Tendencies  c Compute Tracer Tendencies
2067  c -------------------------  c -------------------------
2068        do nt = 1,ntracer  c     do nt = 1,ntracer
2069    c
2070  c Tracer Tendency at the Bottom Layer  c Tracer Tendency at the Bottom Layer
2071  c -----------------------------------  c -----------------------------------
2072        DO 995 I=1,LENB  c     DO 995 I=1,LENB
2073        II = I1(I)  c     II = I1(I)
2074        TEM    = half*TX5(I) * PRI(II,K)  c     TEM    = half*TX5(I) * PRI(II,K)
2075        TX1(I) = (UOI(II,KM1+nltop-1,nt) - UOI(II,K+nltop-1,nt))  c     TX1(I) = (UOI(II,KM1+nltop-1,nt) - UOI(II,K+nltop-1,nt))
2076        ucu(II,K,nt) = TEM * TX1(I)  c     ucu(II,K,nt) = TEM * TX1(I)
2077    995 CONTINUE  c 995 CONTINUE
2078    c
2079  c Tracer Tendency at all other Levels  c Tracer Tendency at all other Levels
2080  c -----------------------------------  c -----------------------------------
2081        DO 1020 L=KM1,IC1,-1  c     DO 1020 L=KM1,IC1,-1
2082        DO 1010 I=1,LENB  c     DO 1010 I=1,LENB
2083        II = I1(I)  c     II = I1(I)
2084        TEM = half*TX5(I) * PRI(II,L)  c     TEM = half*TX5(I) * PRI(II,L)
2085        TEM1   = TX1(I)  c     TEM1   = TX1(I)
2086        TX1(I) = (UOI(II,L-1+nltop-1,nt)-UOI(II,L+nltop-1,nt)) * ETA(I,L)  c     TX1(I) = (UOI(II,L-1+nltop-1,nt)-UOI(II,L+nltop-1,nt)) * ETA(I,L)
2087        TX3(I) = (TX1(I) + TEM1) * TEM  c     TX3(I) = (TX1(I) + TEM1) * TEM
2088   1010 CONTINUE  c1010 CONTINUE
2089        DO 1020 I=1,LENB  c     DO 1020 I=1,LENB
2090        II = I1(I)  c     II = I1(I)
2091        ucu(II,L,nt) = TX3(I)  c     ucu(II,L,nt) = TX3(I)
2092   1020 CONTINUE  c1020 CONTINUE
2093    c
2094        DO 1030 I=1,LENB  c     DO 1030 I=1,LENB
2095        II = I1(I)  c     II = I1(I)
2096        IF (TX6(I) .GE. 1.0) THEN  c     IF (TX6(I) .GE. 1.0) THEN
2097           TEM    = half*TX5(I) * PRI(II,IC)  c        TEM    = half*TX5(I) * PRI(II,IC)
2098        ELSE  c     ELSE
2099           TEM = 0.0  c        TEM = 0.0
2100        ENDIF  c     ENDIF
2101        TX1(I) = (TX1(I) + UHT(I,nt) + UHT(I,nt)) * TEM  c     TX1(I) = (TX1(I) + UHT(I,nt) + UHT(I,nt)) * TEM
2102   1030 CONTINUE  c1030 CONTINUE
2103        DO 1040 I=1,LENB  c     DO 1040 I=1,LENB
2104        II = I1(I)  c     II = I1(I)
2105        ucu(II,IC,nt) = TX1(I)  c     ucu(II,IC,nt) = TX1(I)
2106   1040 CONTINUE  c1040 CONTINUE
2107    c
2108        enddo  c     enddo
2109  C  C
2110  C     PENETRATIVE CONVECTION CALCULATION OVER  C     PENETRATIVE CONVECTION CALCULATION OVER
2111  C  C
2112    
2113        RETURN        RETURN
2114        END        END
2115        SUBROUTINE RNCL(LEN, PL, RNO, CLF)        SUBROUTINE RNCL(lng, PL, RNO, CLF)
 C  
2116  C  C
2117  C*********************************************************************  C*********************************************************************
2118  C********************** Relaxed Arakawa-Schubert *********************  C********************** Relaxed Arakawa-Schubert *********************
2119  C************************   SUBROUTINE  RNCL  ************************  C************************   SUBROUTINE  RNCL  ************************
2120  C**************************** 23 July 1992 ***************************  C**************************** 23 July 1992 ***************************
2121  C*********************************************************************  C*********************************************************************
2122          implicit none
2123    C Argument List declarations
2124          integer lng
2125          _RL PL(lng),  RNO(lng), CLF(lng)
2126    
2127    C Local Variables
2128          _RL p5,p8,pt8,pt2,pfac,p4,p6,p7,p9,cucld,cfac
2129        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)
2130        PARAMETER (PFAC=PT2/(P8-P5))        PARAMETER (PFAC=PT2/(P8-P5))
 C  
2131        PARAMETER (P4=400.0,    P6=401.0)        PARAMETER (P4=400.0,    P6=401.0)
2132        PARAMETER (P7=700.0,    P9=900.0)        PARAMETER (P7=700.0,    P9=900.0)
2133        PARAMETER (CUCLD=0.5,CFAC=CUCLD/(P6-P4))        PARAMETER (CUCLD=0.5,CFAC=CUCLD/(P6-P4))
2134    
2135          integer i
2136  C  C
2137        DIMENSION PL(LEN),  RNO(LEN), CLF(LEN)        DO 10 I=1,lng
   
       DO 10 I=1,LEN  
2138                             rno(i) = 1.0                             rno(i) = 1.0
2139  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)) )
2140    
# Line 2163  CARIES Line 2161  CARIES
2161  C  C
2162        RETURN        RETURN
2163        END        END
2164        SUBROUTINE ACRITN ( LEN,PL,PLB,ACR )        SUBROUTINE ACRITN ( lng,PL,PLB,ACR )
2165    
2166  C*********************************************************************  C*********************************************************************
2167  C********************** Relaxed Arakawa-Schubert *********************  C********************** Relaxed Arakawa-Schubert *********************
# Line 2174  C****  Note:  Data obtained from January Line 2172  C****  Note:  Data obtained from January
2172  C****         from 4x5 46-layer GEOS Assimilation                *****  C****         from 4x5 46-layer GEOS Assimilation                *****
2173  C****                                                            *****  C****                                                            *****
2174  C*********************************************************************  C*********************************************************************
2175          implicit none
2176        real PL(LEN), PLB(LEN), ACR(LEN)  C Argument List declarations
2177          integer lng
2178          _RL PL(lng), PLB(lng), ACR(lng)
2179    
2180    C Local variables
2181          integer lma
2182        parameter  (lma=18)        parameter  (lma=18)
2183        real      p(lma)        _RL p(lma)
2184        real      a(lma)        _RL a(lma)
2185          integer i,L
2186          _RL temp
2187    
2188        data p  / 93.81, 111.65, 133.46, 157.80, 186.51,        data p  / 93.81, 111.65, 133.46, 157.80, 186.51,
2189       .         219.88, 257.40, 301.21, 352.49, 409.76,       .         219.88, 257.40, 301.21, 352.49, 409.76,
# Line 2193  C*************************************** Line 2197  C***************************************
2197    
2198    
2199        do L=1,lma-1        do L=1,lma-1
2200        do i=1,len        do i=1,lng
2201           if( pl(i).ge.p(L)   .and.           if( pl(i).ge.p(L)   .and.
2202       .       pl(i).le.p(L+1)) then       .       pl(i).le.p(L+1)) then
2203           temp = ( pl(i)-p(L) )/( p(L+1)-p(L) )           temp = ( pl(i)-p(L) )/( p(L+1)-p(L) )
# Line 2202  C*************************************** Line 2206  C***************************************
2206        enddo        enddo
2207        enddo        enddo
2208    
2209        do i=1,len        do i=1,lng
2210        if( pl(i).lt.p(1)   ) acr(i) = a(1)        if( pl(i).lt.p(1)   ) acr(i) = a(1)
2211        if( pl(i).gt.p(lma) ) acr(i) = a(lma)        if( pl(i).gt.p(lma) ) acr(i) = a(lma)
2212        enddo        enddo
2213    
2214        do i=1,len        do i=1,lng
2215        acr(i) = acr(i) * (plb(i)-pl(i))        acr(i) = acr(i) * (plb(i)-pl(i))
2216        enddo        enddo
2217    
2218        RETURN        RETURN
2219        END        END
2220         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,
2221       1   PLK,TH,TEMP1,TEMP2,TEMP3,ITMP1,ITMP2,RCON,RLAR,CLSBTH,tmscl,       1   PLK,TH,TEMP1,TEMP2,TEMP3,ITMP1,ITMP2,RCON,RLAR,CLSBTH,tmscl,
2222       2   tmfrc,cp,gravity,alhl,gamfac,cldlz,RHCRIT,offset,alpha)       2   tmfrc,cp,gravity,alhl,gamfac,cldlz,RHCRIT,offset,alpha)
2223    
2224          implicit none
2225    C Argument List declarations
2226          integer nn,irun,nlay
2227          _RL TL(IRUN,NLAY),QL(IRUN,NLAY),RAIN(IRUN,NLAY),
2228         . PL(IRUN,NLAY),CLFRAC(IRUN,NLAY),SP(IRUN),TEMP1(IRUN,NLAY),
2229         . TEMP2(IRUN,NLAY),PLKE(IRUN,NLAY+1),
2230         . RCON(IRUN),RLAR(IRUN),DP(IRUN,NLAY),PLK(IRUN,NLAY),TH(IRUN,NLAY),
2231         . TEMP3(IRUN,NLAY)
2232          integer ITMP1(IRUN,NLAY),ITMP2(IRUN,NLAY)
2233          _RL CLSBTH(IRUN,NLAY)
2234          _RL tmscl,tmfrc,cp,gravity,alhl,gamfac,offset,alpha
2235          _RL cldlz(irun,nlay)
2236          _RL rhcrit(irun,nlay)
2237    C
2238    C Local Variables
2239          _RL zm1p04,zero,two89,zp44,zp01,half,zp578,one,thousand,z3600
2240          _RL zp1,zp001
2241        PARAMETER (ZM1P04 = -1.04E-4 )        PARAMETER (ZM1P04 = -1.04E-4 )
2242        PARAMETER (ZERO = 0.)        PARAMETER (ZERO = 0.)
2243        PARAMETER (TWO89= 2.89E-5)        PARAMETER (TWO89= 2.89E-5)
# Line 2230  C*************************************** Line 2251  C***************************************
2251        PARAMETER ( THOUSAND = 1000.)        PARAMETER ( THOUSAND = 1000.)
2252        PARAMETER ( Z3600 = 3600.)        PARAMETER ( Z3600 = 3600.)
2253  C  C
2254         DIMENSION TL(IRUN,NLAY),QL(IRUN,NLAY),RAIN(IRUN,NLAY),        _RL EVP9(IRUN,NLAY)
2255       $ PL(IRUN,NLAY),CLFRAC(IRUN,NLAY),SP(IRUN),TEMP1(IRUN,NLAY),        _RL water(irun),crystal(irun)
2256       $ TEMP2(IRUN,NLAY),PLKE(IRUN,NLAY),        _RL watevap(irun),iceevap(irun)
2257       $ RCON(IRUN),RLAR(IRUN),DSIG(NLAY),PLK(IRUN,NLAY),TH(IRUN,NLAY),        _RL fracwat,fracice, tice,rh,fact,dum
2258       $ TEMP3(IRUN,NLAY),ITMP1(IRUN,NLAY),        _RL rainmax(irun)
2259       $ ITMP2(IRUN,NLAY),CLSBTH(IRUN,NLAY)        _RL getcon,rphf,elocp,cpog,relax
2260  C        _RL exparg,arearat,rpow
2261         DIMENSION EVP9(IRUN,NLAY)  
2262         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  
2263    
2264  c Explicit Inline Directives  c Explicit Inline Directives
2265  c --------------------------  c --------------------------
2266  #if CRAY  #ifdef CRAY
2267  #if f77  #ifdef f77
2268  cfpp$ expand (qsat)  cfpp$ expand (qsat)
2269  #endif  #endif
2270  #endif  #endif
# Line 2298  C INVERSE OF MASS IN EACH LAYER Line 2313  C INVERSE OF MASS IN EACH LAYER
2313  c -----------------------------  c -----------------------------
2314        DO L = 1,NLAY        DO L = 1,NLAY
2315        DO I = 1,IRUN        DO I = 1,IRUN
2316        TEMP3(I,L) = SP(I) * DSIG(L)        TEMP3(I,L) = GRAVITY*ZP01 / DP(I,L)
       TEMP3(I,L) = GRAVITY*ZP01 / TEMP3(I,L)  
2317        ENDDO        ENDDO
2318        ENDDO        ENDDO
2319    
# Line 2447  C  ======= Line 2461  C  =======
2461  C    cloud ...... Cloud Fraction        (irun,irise)  C    cloud ...... Cloud Fraction        (irun,irise)
2462  C  C
2463  C***********************************************************************  C***********************************************************************
 C*                  GODDARD LABORATORY FOR ATMOSPHERES                 *  
 C***********************************************************************  
2464    
2465        implicit none        implicit none
2466        integer  irun,irise        integer  irun,irise
2467    
2468        real   th(irun,irise)        _RL   th(irun,irise)
2469        real    q(irun,irise)        _RL    q(irun,irise)
2470        real  plk(irun,irise)        _RL  plk(irun,irise)
2471        real   pl(irun,irise)        _RL   pl(irun,irise)
2472        real plke(irun,irise+1)        _RL plke(irun,irise+1)
2473    
2474        real tempth(irun)        _RL  cloud(irun,irise)
2475        real tempqs(irun)        _RL cldwat(irun,irise)
2476        real dhstar(irun)        _RL     qs(irun,irise)
2477        real  cloud(irun,irise)  
2478        real cldwat(irun,irise)        _RL cp, alhl, getcon, akap
2479        real     qs(irun,irise)        _RL ratio, temp, elocp
2480          _RL rhcrit,rh,dum
2481        real cp, alhl, getcon, akap, pcheck        integer i,L
2482        real ratio, temp, pke, elocp  
2483        real rhcrit,rh,dum,pbar,tbar        _RL rhc(irun,irise)
2484        integer i,L,ntradesu,ntradesl        _RL offset,alpha
   
       real factor  
       real rhc(irun,irise)  
       real offset,alpha  
2485    
2486  c Explicit Inline Directives  c Explicit Inline Directives
2487  c --------------------------  c --------------------------
2488  #if CRAY  #ifdef CRAY
2489  #if f77  #ifdef f77
2490  cfpp$ expand (qsat)  cfpp$ expand (qsat)
2491  #endif  #endif
2492  #endif  #endif
# Line 2519  c -------------------------------------- Line 2527  c --------------------------------------
2527        subroutine ctei ( th,q,cldfrc,cldwat,pl,plk,plke,im,lm )        subroutine ctei ( th,q,cldfrc,cldwat,pl,plk,plke,im,lm )
2528        implicit none        implicit none
2529        integer im,lm        integer im,lm
2530        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)
2531        real plk(im,lm),pl(im,lm),cldfrc(im,lm)        _RL plk(im,lm),pl(im,lm),cldfrc(im,lm)
2532        integer i,L        integer i,L
2533        real    getcon,cp,alhl,elocp,cpoel,t,p,s,qs,dqsdt,dq        _RL    getcon,cp,alhl,elocp,cpoel,t,p,s,qs,dqsdt,dq
2534        real    k,krd,kmm,f        _RL    k,krd,kmm,f
2535    
2536        cp     = getcon('CP')        cp     = getcon('CP')
2537        alhl   = getcon('LATENT HEAT COND')        alhl   = getcon('LATENT HEAT COND')
# Line 2560  c -------------------------------------- Line 2568  c --------------------------------------
2568        subroutine back2grd(gathered,indeces,scattered,irun)        subroutine back2grd(gathered,indeces,scattered,irun)
2569        implicit none        implicit none
2570        integer i,irun,indeces(irun)        integer i,irun,indeces(irun)
2571        real gathered(irun),scattered(irun)        _RL gathered(irun),scattered(irun)
2572        real temp(irun)        _RL temp(irun)
2573        do i = 1,irun        do i = 1,irun
2574         temp(indeces(i)) = gathered(i)         temp(indeces(i)) = gathered(i)
2575        enddo        enddo
Legend:
Removed from v.1.4  
changed lines
  Added in v.1.18
  ViewVC Help
Powered by ViewVC 1.1.22