/[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.1 by molod, Tue Jun 15 14:47:23 2004 UTC revision 1.13 by molod, Mon Jul 26 18:45:17 2004 UTC
# Line 1  Line 1 
1  C $Header$  C $Header$
2  C $Name$  C $Name$
3                                                                                        
4        subroutine moistio (ndmoist,istrip,npcs,pz,tz,qz,ntracer,ptracer,  #include "FIZHI_OPTIONS.h"
5       .   pkht,qqz,dumoist,dvmoist,dtmoist,dqmoist,        subroutine moistio (ndmoist,istrip,npcs,
6       .   im,jm,lm,sige,sig,dsig,ptop,       .   lowlevel,midlevel,nltop,nsubmin,nsubmax,Lup,
7         .   pz,plz,plze,dpres,pkht,pkl,tz,qz,bi,bj,ntracer,ptracer,
8         .   qqz,dumoist,dvmoist,dtmoist,dqmoist,
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,qdiag,nd,myid)       .   lpnt,myid)
14    
15           implicit none
16    
17    #ifdef ALLOW_DIAGNOSTICS
18    #include "SIZE.h"
19    #include "diagnostics_SIZE.h"
20  #include "diagnostics.h"  #include "diagnostics.h"
21    #endif
22    
23  c Input Variables  c Input Variables
24  c ---------------  c ---------------
25        integer ndmoist,istrip,npcs,nd,myid        integer im,jm,lm
26          integer ndmoist,istrip,npcs
27        integer im,jm,lm                        integer bi,bj,ntracer,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,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)        
   
       real  qdiag(im,jm,nd)            
       logical lpnt                      
46    
47  c Local Variables  c Local Variables
48  c ---------------  c ---------------
49        integer    ncrnd,nsecf,nsubmax        integer    ncrnd,nsecf
50    
51        real       fracqq, rh,temp1,temp2,dum        _RL       fracqq, dum
52        integer    snowcrit, lup        integer    snowcrit
53        parameter (fracqq = 0.1)        parameter (fracqq = 0.1)
54    
55        real   cldsr(im,jm,lm)        _RL   cldsr(im,jm,lm)
56        real   srcld(istrip,lm)        _RL   srcld(istrip,lm)
57    
58        real plev        _RL plev
59        real cldnow,cldlsp_mem,cldras_mem,cldras,watnow,watmin,cldmin        _RL cldnow,cldlsp_mem,cldlsp,cldras_mem,cldras
60        real cldprs(im,jm),cldtmp(im,jm)        _RL watnow,watmin,cldmin
61        real cldhi (im,jm),cldlow(im,jm)        _RL cldprs(im,jm),cldtmp(im,jm)
62        real cldmid(im,jm),totcld(im,jm)        _RL cldhi (im,jm),cldlow(im,jm)
63        integer midlevel,lowlevel        _RL cldmid(im,jm),totcld(im,jm)
64    
65        real   CLDLS(im,jm,lm)  , CPEN(im,jm,lm)        _RL   CLDLS(im,jm,lm)  , CPEN(im,jm,lm)
66        real    tmpimjm(im,jm)        _RL    tmpimjm(im,jm)
67        real    lsp_new(im,jm)        _RL    lsp_new(im,jm)
68        real   conv_new(im,jm)        _RL   conv_new(im,jm)
69        real   snow_new(im,jm)        _RL   snow_new(im,jm)
70    
71        real  qqcolmin(im,jm)        _RL  qqcolmin(im,jm)
72        real  qqcolmax(im,jm)        _RL  qqcolmax(im,jm)
73        integer levpbl(im,jm)        integer levpbl(im,jm)
74    
75  c Gathered Arrays for Variable Cloud Base  c Gathered Arrays for Variable Cloud Base
76  c ---------------------------------------  c ---------------------------------------
77        real    raincgath(im*jm)        _RL    raincgath(im*jm)
78        real     pigather(im*jm)        _RL     pigather(im*jm)
79        real     thgather(im*jm,lm)        _RL     thgather(im*jm,lm)
80        real     shgather(im*jm,lm)        _RL     shgather(im*jm,lm)
81        real    pkzgather(im*jm,lm)        _RL    pkzgather(im*jm,lm)
82        real    pkegather(im*jm,lm)        _RL    pkegather(im*jm,lm+1)
83        real    tmpgather(im*jm,lm)        _RL    plzgather(im*jm,lm)
84        real   deltgather(im*jm,lm)        _RL    plegather(im*jm,lm+1)
85        real   delqgather(im*jm,lm)        _RL     dpgather(im*jm,lm)
86        real      ugather(im*jm,lm,ntracer)        _RL    tmpgather(im*jm,lm)
87        real   delugather(im*jm,lm,ntracer)        _RL   deltgather(im*jm,lm)
88        real     deltrnev(im*jm,lm)        _RL   delqgather(im*jm,lm)
89        real     delqrnev(im*jm,lm)        _RL      ugather(im*jm,lm,ntracer)
90          _RL   delugather(im*jm,lm,ntracer)
91          _RL     deltrnev(im*jm,lm)
92          _RL     delqrnev(im*jm,lm)
93    
94        integer  nindeces(lm)        integer  nindeces(lm)
95        integer  pblindex(im*jm)        integer  pblindex(im*jm)
# Line 106  c -------------------------------------- Line 97  c --------------------------------------
97    
98  c Stripped Arrays  c Stripped Arrays
99  c ---------------  c ---------------
100        real saveth (istrip,lm)        _RL saveth (istrip,lm)
101        real saveq  (istrip,lm)        _RL saveq  (istrip,lm)
102        real saveu  (istrip,lm,ntracer)        _RL saveu  (istrip,lm,ntracer)
103        real usubcl (istrip,   ntracer)        _RL usubcl (istrip,   ntracer)
104    
105        real     ple(istrip,lm+1), gam(istrip,lm)        _RL     ple(istrip,lm+1)
106        real      TL(ISTRIP,lm)  , SHL(ISTRIP,lm)        _RL      dp(istrip,lm)
107        real      PL(ISTRIP,lm)  , PLK(ISTRIP,lm)        _RL      TL(ISTRIP,lm)  , SHL(ISTRIP,lm)
108        real    PLKE(ISTRIP,lm+1)        _RL      PL(ISTRIP,lm)  , PLK(ISTRIP,lm)
109        real      TH(ISTRIP,lm)  ,CVTH(ISTRIP,lm)        _RL    PLKE(ISTRIP,lm+1)
110        real   SHSAT(ISTRIP,lm)  , CVQ(ISTRIP,lm)        _RL      TH(ISTRIP,lm)  ,CVTH(ISTRIP,lm)
111        real      UL(ISTRIP,lm,ntracer)        _RL   CVQ(ISTRIP,lm)
112        real     cvu(istrip,lm,ntracer)        _RL      UL(ISTRIP,lm,ntracer)
113        real  CLMAXO(ISTRIP,lm),CLBOTH(ISTRIP,lm)        _RL     cvu(istrip,lm,ntracer)
114        real  CLSBTH(ISTRIP,lm)        _RL  CLMAXO(ISTRIP,lm),CLBOTH(ISTRIP,lm)
115        real    TMP1(ISTRIP,lm),  TMP2(ISTRIP,lm)        _RL  CLSBTH(ISTRIP,lm)
116        real    TMP3(ISTRIP,lm),  TMP4(ISTRIP,lm+1)        _RL    TMP1(ISTRIP,lm),  TMP2(ISTRIP,lm)
117        real    TMP5(ISTRIP,lm+1)        _RL    TMP3(ISTRIP,lm),  TMP4(ISTRIP,lm+1)
118          _RL    TMP5(ISTRIP,lm+1)
119        integer   ITMP1(ISTRIP,lm), ITMP2(ISTRIP,lm)        integer   ITMP1(ISTRIP,lm), ITMP2(ISTRIP,lm)
       integer   ITMP3(ISTRIP,lm)  
120    
121        real   PRECIP(ISTRIP), PCMID(ISTRIP), PCNET(ISTRIP)        _RL   PRECIP(ISTRIP), PCNET(ISTRIP)
122        real   PCLOW (ISTRIP),    SP(ISTRIP),  PREP(ISTRIP)        _RL   SP(ISTRIP),  PREP(ISTRIP)
123        real   PCPEN (ISTRIP,lm)        _RL   PCPEN (ISTRIP,lm)
124        integer pbl(istrip),depths(lm)        integer pbl(istrip),depths(lm)
125    
126        real   cldlz(istrip,lm), cldwater(im,jm,lm)        _RL   cldlz(istrip,lm), cldwater(im,jm,lm)
127        real   rhfrac(istrip), rhmin, pup, ppbl, rhcrit(istrip,lm)        _RL   rhfrac(istrip), rhmin, pup, ppbl, rhcrit(istrip,lm)
128        real   offset, alpha, rasmax        _RL   offset, alpha, rasmax
129    
130        logical first        logical first
131        logical lras        logical lras
132        real    clfrac (istrip,lm)        _RL    clfrac (istrip,lm)
133        real    cldmas (istrip,lm)        _RL    cldmas (istrip,lm)
134        real    detrain(istrip,lm)        _RL    detrain(istrip,lm)
135        real    psubcld    (istrip), psubcldg (im,jm)        _RL    psubcld    (istrip), psubcldg (im,jm)
136        real    psubcld_cnt(istrip), psubcldgc(im,jm)        _RL    psubcld_cnt(istrip), psubcldgc(im,jm)
137        real rnd(lm/2)        _RL rnd(lm/2)
138        DATA      FIRST /.TRUE./        DATA      FIRST /.TRUE./
139    
140        integer imstp,nltop,nsubcl,nlras,nsubmin        integer imstp,nsubcl,nlras
141        integer i,j,iloop,index,l,nn,num,numdeps,nt        integer i,j,iloop,index,l,nn,num,numdeps,nt
142        real tmstp,tminv,sday,grav,alhl,cp,elocp,gamfac        _RL tmstp,tminv,sday,grav,alhl,cp,elocp,gamfac
143        real rkappa,p0kappa,p0kinv,ptopkap,pcheck        _RL rkappa,p0kappa,p0kinv,ptopkap,pcheck
144        real tice,getcon,pi        _RL tice,getcon,pi
145    
146  C **********************************************************************  C **********************************************************************
147  C ****                     INITIALIZATION                           ****  C ****                     INITIALIZATION                           ****
# Line 162  C ************************************** Line 153  C **************************************
153    
154  C Minimum Large-Scale Cloud Fraction at rhcrit  C Minimum Large-Scale Cloud Fraction at rhcrit
155        alpha  = 0.80                alpha  = 0.80        
156  C Difference in fraction between SR and LS Thresshold  C Difference in fraction between SR and LS Threshold
157        offset = 0.10                offset = 0.10        
158  C Large-Scale Relative Humidity Threshold in PLB  C Large-Scale Relative Humidity Threshold in PBL
159        rhmin  = 0.90                rhmin  = 0.90        
160  C Maximum Cloud Fraction associated with RAS  C Maximum Cloud Fraction associated with RAS
161        rasmax = 1.00                rasmax = 1.00        
# Line 189  C Threshold for Cloud Liquid Water Memor Line 180  C Threshold for Cloud Liquid Water Memor
180        tice     = getcon('FREEZING-POINT')        tice     = getcon('FREEZING-POINT')
181        PI       = 4.*atan(1.)        PI       = 4.*atan(1.)
182    
183  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  
184  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  
185        ncrnd = (lm-nltop+1)/2        ncrnd = (lm-nltop+1)/2
186    
 c Determine Minimum Number of Levels in Sub-Cloud (50 mb) Layer  
 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  
   
187        if(first .and. myid.eq.0) then        if(first .and. myid.eq.0) then
188         print *         print *
189         print *,'Top Level Allowed for Convection : ',nltop,         print *,'Top Level Allowed for Convection : ',nltop
190       .                    ' (',(1000.-ptop)*SIG(nltop) + PTOP,' mb)'         print *,'          Highest Sub-Cloud Level: ',nsubmax
191         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)'  
192         print *,'    Total Number of Random Clouds: ',ncrnd         print *,'    Total Number of Random Clouds: ',ncrnd
193         print *         print *
194         first = .false.         first = .false.
# Line 276  c -------------------------------------- Line 243  c --------------------------------------
243        do index = 1,im*jm        do index = 1,im*jm
244         levgather(index) = levpbl(pblindex(index),1)         levgather(index) = levpbl(pblindex(index),1)
245          pigather(index) =     pz(pblindex(index),1)          pigather(index) =     pz(pblindex(index),1)
246            pkegather(index,lm+1) = pkht(pblindex(index),1,lm+1)
247            plegather(index,lm+1) = plze(pblindex(index),1,lm+1)
248        enddo        enddo
249    
250        do L = 1,lm        do L = 1,lm
251         do index = 1,im*jm         do index = 1,im*jm
252           thgather(index,L) =   tz(pblindex(index),1,L)           thgather(index,L) = tz(pblindex(index),1,L)
253           shgather(index,L) =   qz(pblindex(index),1,L,1)           shgather(index,L) = qz(pblindex(index),1,L,1)
254          pkegather(index,L) = pkht(pblindex(index),1,L)          pkegather(index,L) = pkht(pblindex(index),1,L)
255            pkzgather(index,L) = pkl(pblindex(index),1,L)
256            plegather(index,L) = plze(pblindex(index),1,L)
257            plzgather(index,L) = plz(pblindex(index),1,L)
258             dpgather(index,L) = dpres(pblindex(index),1,L)
259         enddo         enddo
260        enddo        enddo
261        do nt = 1,ntracer-ptracer        do nt = 1,ntracer-ptracer
# Line 293  c -------------------------------------- Line 266  c --------------------------------------
266        enddo        enddo
267        enddo        enddo
268    
       call pkappa(pigather,pkegather,pkzgather,ptop,sige,dsig,im,jm,lm)  
   
269  c bump the counter for number of calls to convection  c bump the counter for number of calls to convection
270  c --------------------------------------------------  c --------------------------------------------------
271                          iras = iras + 1                          iras = iras + 1
# Line 327  C ************************************** Line 298  C **************************************
298    
299         CALL STRIP (  pigather, SP      ,im*jm,ISTRIP,1 ,NN )         CALL STRIP (  pigather, SP      ,im*jm,ISTRIP,1 ,NN )
300         CALL STRIP ( pkzgather, PLK     ,im*jm,ISTRIP,lm,NN )         CALL STRIP ( pkzgather, PLK     ,im*jm,ISTRIP,lm,NN )
301         CALL STRIP ( pkegather, PLKE    ,im*jm,ISTRIP,lm,NN )         CALL STRIP ( pkegather, PLKE    ,im*jm,ISTRIP,lm+1,NN )
302           CALL STRIP ( plzgather, PL      ,im*jm,ISTRIP,lm,NN )
303           CALL STRIP ( plegather, PLE     ,im*jm,ISTRIP,lm+1,NN )
304           CALL STRIP (  dpgather, dp      ,im*jm,ISTRIP,lm,NN )
305         CALL STRIP (  thgather, TH      ,im*jm,ISTRIP,lm,NN )         CALL STRIP (  thgather, TH      ,im*jm,ISTRIP,lm,NN )
306         CALL STRIP (  shgather, SHL     ,im*jm,ISTRIP,lm,NN )         CALL STRIP (  shgather, SHL     ,im*jm,ISTRIP,lm,NN )
307         CALL STRINT( levgather, pbl     ,im*jm,ISTRIP,1 ,NN )         CALL STRINT( levgather, pbl     ,im*jm,ISTRIP,1 ,NN )
# Line 336  C ************************************** Line 310  C **************************************
310         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 )
311         enddo         enddo
312    
       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  
   
313  C **********************************************************************  C **********************************************************************
314  C ****        SETUP FOR RAS CUMULUS PARAMETERIZATION                ****  C ****        SETUP FOR RAS CUMULUS PARAMETERIZATION                ****
315  C **********************************************************************  C **********************************************************************
# Line 442  c ------------------------------- Line 405  c -------------------------------
405         ENDDO         ENDDO
406         DO L=2,lm         DO L=2,lm
407         DO I=num,num+nindeces(nsubcl)-1         DO I=num,num+nindeces(nsubcl)-1
408          TMP5(I,L) = PLKE(I,L-1)*P0KINV          TMP5(I,L) = PLKE(I,L)*P0KINV
409         ENDDO         ENDDO
410         ENDDO         ENDDO
411         DO  I=num,num+nindeces(nsubcl)-1         DO  I=num,num+nindeces(nsubcl)-1
412          TMP4(I,lm+1) = PLE (I,lm+1)          TMP4(I,lm+1) = PLE (I,lm+1)
413          TMP5(I,lm+1) = PLKE(I,lm)*P0KINV          TMP5(I,lm+1) = PLKE(I,lm+1)*P0KINV
414         ENDDO         ENDDO
415         DO 113 I=num,num+nindeces(nsubcl)-1         DO 113 I=num,num+nindeces(nsubcl)-1
416          TMP4(I,NSUBCL+1) = PLE (I,lm+1)          TMP4(I,NSUBCL+1) = PLE (I,lm+1)
417          TMP5(I,NSUBCL+1) = PLKE(I,lm)*P0KINV          TMP5(I,NSUBCL+1) = PLKE(I,lm+1)*P0KINV
418   113   CONTINUE   113   CONTINUE
419    
420        do i=num,num+nindeces(nsubcl)-1        do i=num,num+nindeces(nsubcl)-1
# Line 484  C  Used in Slingo-Ritter clouds as well Line 447  C  Used in Slingo-Ritter clouds as well
447  C Top level of atan func above this rh_threshold = rhmin  C Top level of atan func above this rh_threshold = rhmin
448        pup = 600.                        pup = 600.                
449        do i=num,num+nindeces(nsubcl)-1        do i=num,num+nindeces(nsubcl)-1
450          do L = nsubcl, lm         do L = nsubcl, lm
451            rhcrit(i,L) = 1.           rhcrit(i,L) = 1.
452          enddo         enddo
453          do L = 1, nsubcl-1         do L = 1, nsubcl-1
454            pcheck = (1000.-ptop)*sig(L) + ptop          pcheck = pl(i,L)
455            if (pcheck .le. pup) then          if (pcheck .le. pup) then
456              rhcrit(i,L) = rhmin           rhcrit(i,L) = rhmin
457            else          else
458              ppbl = (1000.-ptop)*sig(nsubcl) + ptop           ppbl = pl(i,nsubcl)
459              rhcrit(i,L) = rhmin + (1.-rhmin)/(19.) * ((           rhcrit(i,L) = rhmin + (1.-rhmin)/(19.) *
460       .        atan( (2.*(pcheck-pup)/(ppbl-pup)-1.) *       .      ((atan( (2.*(pcheck-pup)/(ppbl-pup)-1.) *
461       .       tan(20.*pi/21.-0.5*pi) )       .       tan(20.*pi/21.-0.5*pi) )
462       .        + 0.5*pi) * 21./pi - 1.)       .        + 0.5*pi) * 21./pi - 1.)
463            endif          endif
464          enddo         enddo
465        enddo        enddo
466    
467  c Save Initial Values of Temperature and Specific Humidity  c Save Initial Values of Temperature and Specific Humidity
# Line 522  c -------------------------------------- Line 485  c --------------------------------------
485  c Compute Diagnostic CLDMAS in RAS Subcloud Layers  c Compute Diagnostic CLDMAS in RAS Subcloud Layers
486  c ------------------------------------------------  c ------------------------------------------------
487         do L=nsubcl,lm         do L=nsubcl,lm
         dum = dsig(L)/(1.0-sige(nsubcl))  
488         do I=num,num+nindeces(nsubcl)-1         do I=num,num+nindeces(nsubcl)-1
489            dum = dp(i,L)/(ple(i,lm+1)-ple(i,nsubcl))
490          cldmas(i,L) = cldmas(i,L-1) - dum*cldmas(i,nsubcl-1)          cldmas(i,L) = cldmas(i,L-1) - dum*cldmas(i,nsubcl-1)
491         enddo         enddo
492         enddo         enddo
# Line 637  C ************************************** Line 600  C **************************************
600        ENDDO        ENDDO
601        ENDDO        ENDDO
602    
603         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,
604       .  PLK,TH,TMP1,TMP2,TMP3,ITMP1,ITMP2,PCNET,PRECIP,       .  PLK,TH,TMP1,TMP2,TMP3,ITMP1,ITMP2,PCNET,PRECIP,
605       .  CLSBTH,TMSTP,1.,cp,grav,alhl,gamfac,cldlz,rhcrit,offset,alpha)       .  CLSBTH,TMSTP,1.,cp,grav,alhl,gamfac,cldlz,rhcrit,offset,alpha)
606    
# Line 726  c  snow algorthm: Line 689  c  snow algorthm:
689  c  if temperature profile from the surface level to 700 mb  c  if temperature profile from the surface level to 700 mb
690  c  uniformaly c  below zero, then precipitation (total) is  c  uniformaly c  below zero, then precipitation (total) is
691  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  
692  c-------------------------------------------------------  c-------------------------------------------------------
693    
         pup = 700.  
         do L = lm, 1, -1  
           pcheck = (1000.-ptop)*sig(L) + ptop  
           if (pcheck .ge. pup) then  
             lup = L  
           endif  
         enddo  
694          do i = 1,istrip          do i = 1,istrip
695            snowcrit=0            snowcrit=0
696            do l=lup,lm            do l=lup,lm
# Line 823  C ************************************** Line 774  C **************************************
774  C                          BUMP DIAGNOSTICS  C                          BUMP DIAGNOSTICS
775  C **********************************************************************  C **********************************************************************
776    
 c Determine Level Indices for Low-Mid-High Cloud Regions  
 c ------------------------------------------------------  
       lowlevel = lm  
       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  
       enddo  
   
   
 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) = qdiag(i,1,itmpuclr +L-1) +  
      .                                          tz(i,1,L)*pkzgather(i,L)  
          qdiag(i,1,itmpuclrc+L-1) = qdiag(i,1,itmpuclrc+L-1) + 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) = qdiag(i,1,isphuclr +L-1) +  
      .                                                qz(i,1,L,1)*1000.0  
          qdiag(i,1,isphuclrc+L-1) = qdiag(i,1,isphuclrc+L-1) + 1.0  
         endif  
         enddo  
        endif  
       enddo  
       endif  
   
777  c Sub-Cloud Layer  c Sub-Cloud Layer
778  c -------------------------  c -------------------------
779        if( ipsubcld.ne.0 ) then        if( ipsubcld.ne.0 ) then
780        do j = 1,jm        do j = 1,jm
781        do i = 1,im        do i = 1,im
782        qdiag(i,j,ipsubcld ) = qdiag(i,j,ipsubcld ) + psubcldg (i,j)        qdiag(i,j,ipsubcld,bi,bj) = qdiag(i,j,ipsubcld,bi,bj) +
783        qdiag(i,j,ipsubcldc) = qdiag(i,j,ipsubcldc) + psubcldgc(i,j)       .                                           psubcldg (i,j)
784          qdiag(i,j,ipsubcldc,bi,bj) = qdiag(i,j,ipsubcldc,bi,bj) +
785         .                                           psubcldgc(i,j)
786        enddo        enddo
787        enddo        enddo
788        endif        endif
# Line 889  c -------------------------------- Line 793  c --------------------------------
793        do L = 1,lm        do L = 1,lm
794        do j = 1,jm        do j = 1,jm
795        do i = 1,im        do i = 1,im
796        qdiag(i,j,icldnp+L-1) = qdiag(i,j,icldnp+L-1) + cldsr(i,j,L)        qdiag(i,j,icldnp+L-1,bi,bj) = qdiag(i,j,icldnp+L-1,bi,bj) +
797         .                                                  cldsr(i,j,L)
798        enddo        enddo
799        enddo        enddo
800        enddo        enddo
# Line 901  c ---------------------------- Line 806  c ----------------------------
806        if(imoistt.gt.0) then        if(imoistt.gt.0) then
807        do L = 1,lm        do L = 1,lm
808        do i = 1,im*jm        do i = 1,im*jm
809        qdiag(i,1,imoistt+L-1) = qdiag(i,1,imoistt+L-1) +        qdiag(i,1,imoistt+L-1,bi,bj) = qdiag(i,1,imoistt+L-1,bi,bj) +
810       .                      (dtmoist(i,1,L)*sday*pkzgather(i,L)/pz(i,1))       .                      (dtmoist(i,1,L)*sday*pkzgather(i,L)/pz(i,1))
811        enddo        enddo
812        enddo        enddo
# Line 913  c ------------------------------- Line 818  c -------------------------------
818        do L = 1,lm        do L = 1,lm
819        do j = 1,jm        do j = 1,jm
820        do i = 1,im        do i = 1,im
821        qdiag(i,j,imoistq+L-1) = qdiag(i,j,imoistq+L-1) +        qdiag(i,j,imoistq+L-1,bi,bj) = qdiag(i,j,imoistq+L-1,bi,bj) +
822       .                           (dqmoist(i,j,L,1)*sday*1000.0/pz(i,j))       .                           (dqmoist(i,j,L,1)*sday*1000.0/pz(i,j))
823        enddo        enddo
824        enddo        enddo
# Line 925  c --------------- Line 830  c ---------------
830        if(icldmas.gt.0) then        if(icldmas.gt.0) then
831        do L = 1,lm        do L = 1,lm
832        do i = 1,im*jm        do i = 1,im*jm
833        qdiag(i,1,icldmas+L-1) = qdiag(i,1,icldmas+L-1) + tmpgather(i,L)        qdiag(i,1,icldmas+L-1,bi,bj) = qdiag(i,1,icldmas+L-1,bi,bj) +
834         .                                                  tmpgather(i,L)
835        enddo        enddo
836        enddo        enddo
837        endif        endif
# Line 935  c ------------------------- Line 841  c -------------------------
841        if(idtrain.gt.0) then        if(idtrain.gt.0) then
842        do L = 1,lm        do L = 1,lm
843        do i = 1,im*jm        do i = 1,im*jm
844        qdiag(i,1,idtrain+L-1) = qdiag(i,1,idtrain+L-1) + pkegather(i,L)        qdiag(i,1,idtrain+L-1,bi,bj) = qdiag(i,1,idtrain+L-1,bi,bj) +
845         .                                                  pkegather(i,L)
846        enddo        enddo
847        enddo        enddo
848        endif        endif
# Line 945  c -------------------------------------- Line 852  c --------------------------------------
852        if(idtls.gt.0) then        if(idtls.gt.0) then
853        do L = 1,lm        do L = 1,lm
854        do i = 1,im*jm        do i = 1,im*jm
855        qdiag(i,1,idtls+L-1) = qdiag(i,1,idtls+L-1) + deltrnev(i,L)        qdiag(i,1,idtls+L-1,bi,bj) = qdiag(i,1,idtls+L-1,bi,bj) +
856         .                                                  deltrnev(i,L)
857        enddo        enddo
858        enddo        enddo
859        endif        endif
# Line 955  c -------------------------------------- Line 863  c --------------------------------------
863        if(idqls.gt.0) then        if(idqls.gt.0) then
864        do L = 1,lm        do L = 1,lm
865        do i = 1,im*jm        do i = 1,im*jm
866        qdiag(i,1,idqls+L-1) = qdiag(i,1,idqls+L-1) + delqrnev(i,L)        qdiag(i,1,idqls+L-1,bi,bj) = qdiag(i,1,idqls+L-1,bi,bj) +
867         .                                                  delqrnev(i,L)
868        enddo        enddo
869        enddo        enddo
870        endif        endif
# Line 965  c ------------------- Line 874  c -------------------
874        if(ipreacc.gt.0) then        if(ipreacc.gt.0) then
875        do j = 1,jm        do j = 1,jm
876        do i = 1,im        do i = 1,im
877        qdiag(i,j,ipreacc) = qdiag(i,j,ipreacc)        qdiag(i,j,ipreacc,bi,bj) = qdiag(i,j,ipreacc,bi,bj)
878       .                   +  (  lsp_new(I,j)       .                   +  (  lsp_new(I,j)
879       .                      + snow_new(I,j)       .                      + snow_new(I,j)
880       .                      + conv_new(i,j) ) *sday*tminv       .                      + conv_new(i,j) ) *sday*tminv
# Line 977  c Convective Precipitation Line 886  c Convective Precipitation
886  c ------------------------  c ------------------------
887        if(iprecon.gt.0) then        if(iprecon.gt.0) then
888        do i = 1,im*jm        do i = 1,im*jm
889        qdiag(i,1,iprecon) = qdiag(i,1,iprecon) + raincgath(i)*sday*tminv        qdiag(i,1,iprecon,bi,bj) = qdiag(i,1,iprecon,bi,bj) +
890         .                                         raincgath(i)*sday*tminv
891        enddo        enddo
892        endif        endif
893    
# Line 1018  c ------------------------------------ Line 928  c ------------------------------------
928    
929        do L = 1,lm        do L = 1,lm
930        do i = 1,im*jm        do i = 1,im*jm
931         plev = sig(L)*pz(i,1)+ptop         plev = pl(i,L)
932    
933  c Compute Time-averaged Cloud and Water Amounts for Longwave Radiation  c Compute Time-averaged Cloud and Water Amounts for Longwave Radiation
934  c --------------------------------------------------------------------  c --------------------------------------------------------------------
# Line 1099  C ************************************** Line 1009  C **************************************
1009        do j = 1,jm        do j = 1,jm
1010        do i = 1,im        do i = 1,im
1011           if( cldtmp(i,j).gt.0.0 ) then           if( cldtmp(i,j).gt.0.0 ) then
1012           qdiag(i,j,icldtmp) = qdiag(i,j,icldtmp) +           qdiag(i,j,icldtmp,bi,bj) = qdiag(i,j,icldtmp,bi,bj) +
1013       .                       cldtmp(i,j)*totcld(i,j)/tmpimjm(i,j)       .                       cldtmp(i,j)*totcld(i,j)/tmpimjm(i,j)
1014           qdiag(i,j,icttcnt) = qdiag(i,j,icttcnt) + totcld(i,j)           qdiag(i,j,icttcnt,bi,bj) = qdiag(i,j,icttcnt,bi,bj) +
1015         .                                                totcld(i,j)
1016           endif           endif
1017        enddo        enddo
1018        enddo        enddo
# Line 1111  C ************************************** Line 1022  C **************************************
1022        do j = 1,jm        do j = 1,jm
1023        do i = 1,im        do i = 1,im
1024           if( cldprs(i,j).gt.0.0 ) then           if( cldprs(i,j).gt.0.0 ) then
1025           qdiag(i,j,icldprs) = qdiag(i,j,icldprs) +           qdiag(i,j,icldprs,bi,bj) = qdiag(i,j,icldprs,bi,bj) +
1026       .                       cldprs(i,j)*totcld(i,j)/tmpimjm(i,j)       .                       cldprs(i,j)*totcld(i,j)/tmpimjm(i,j)
1027           qdiag(i,j,ictpcnt) = qdiag(i,j,ictpcnt) + totcld(i,j)           qdiag(i,j,ictpcnt,bi,bj) = qdiag(i,j,ictpcnt,bi,bj) +
1028         .                                                totcld(i,j)
1029           endif           endif
1030        enddo        enddo
1031        enddo        enddo
# Line 1148  C ************************************** Line 1060  C **************************************
1060       *,               cp,grav,rkappa,alhl,rhfrac,rasmax )       *,               cp,grav,rkappa,alhl,rhfrac,rasmax )
1061  C  C
1062  C*********************************************************************  C*********************************************************************
 C*********************** ARIES   MODEL *******************************  
1063  C********************* SUBROUTINE  RAS   *****************************  C********************* SUBROUTINE  RAS   *****************************
1064  C********************** 16 MARCH   1988 ******************************  C********************** 16 MARCH   1988 ******************************
1065  C*********************************************************************  C*********************************************************************
1066  C  C
1067        PARAMETER (KRMIN=01)        implicit none
1068        PARAMETER (ICM=1000)  
1069        PARAMETER (CMB2PA=100.0)  C Argument List
1070        PARAMETER (rknob = 10.)        integer nn,len,lenc,k,nltop,nlayr
 C  
1071        integer ntracer        integer ntracer
1072        integer nltop,nlayr        integer ncrnd
1073        DIMENSION UOI(len,nlayr,ntracer),   POI(len,K)        _RL dt
1074        DIMENSION QOI(len,K), PRS(len,K+1), PRJ(len,K+1)        _RL UOI(len,nlayr,ntracer),   POI(len,K)
1075        dimension rnd(ncrnd)        _RL QOI(len,K), PRS(len,K+1), PRJ(len,K+1)
1076  C        _RL rnd(ncrnd)
1077        DIMENSION RAINS(len,K), CLN(len,K), CLF(len,K)        _RL RAINS(len,K), CLN(len,K), CLF(len,K)
1078        DIMENSION cldmas(len,K), detrain(len,K)        _RL cldmas(len,K), detrain(len,K)
1079        DIMENSION TCU(len,K), QCU(len,K)        _RL cp,grav,rkappa,alhl,rhfrac(len),rasmax
1080        real ucu(len,K,ntracer)  
1081        DIMENSION ALF(len,K), BET(len,K), GAM(len,K)  C Local Variables
1082          _RL TCU(len,K), QCU(len,K)
1083          _RL ucu(len,K,ntracer)
1084          _RL ALF(len,K), BET(len,K), GAM(len,K)
1085       *,         ETA(len,K), HOI(len,K)       *,         ETA(len,K), HOI(len,K)
1086       *,         PRH(len,K), PRI(len,K)       *,         PRH(len,K), PRI(len,K)
1087        DIMENSION HST(len,K), QOL(len,K), GMH(len,K)        _RL HST(len,K), QOL(len,K), GMH(len,K)
1088    
1089        DIMENSION TX1(len), TX2(len), TX3(len), TX4(len), TX5(len)        _RL TX1(len), TX2(len), TX3(len), TX4(len), TX5(len)
1090       *,         TX6(len), TX7(len), TX8(len), TX9(len)       *,         TX6(len), TX7(len), TX8(len), TX9(len)
1091       *,         TX11(len), TX12(len), TX13(len), TX14(len,ntracer)       *,         TX11(len), TX12(len), TX13(len), TX14(len,ntracer)
1092       *,         TX15(len), TX16(len)       *,         TX15(len)
1093       *,         WFN(len), IA1(len), IA2(len), IA3(len)       *,         WFN(len)
1094        DIMENSION cloudn(len), pcu(len)        integer IA1(len), IA2(len), IA3(len)
1095          _RL cloudn(len), pcu(len)
1096    
1097        real rhfrac(len),rasmax        integer krmin,icm
1098          _RL rknob, cmb2pa
1099        DIMENSION IC(ICM),   IRND(icm)        PARAMETER (KRMIN=01)
1100        dimension cmass(len,K)        PARAMETER (ICM=1000)
1101          PARAMETER (CMB2PA=100.0)
1102          PARAMETER (rknob = 10.)
1103    
1104          integer IC(ICM),   IRND(icm)
1105          _RL cmass(len,K)
1106        LOGICAL SETRAS        LOGICAL SETRAS
1107    
1108           do L = 1,k        integer i,L,nc,ib,nt
1109           do I = 1,LENC        integer km1,kp1,kprv,kcr,kfx,ncmx
1110           rains(i,l) = 0.        _RL p00, crtmsf, frac, rasblf
1111           enddo  
1112           enddo        do L = 1,k
1113          do I = 1,LENC
1114           rains(i,l) = 0.
1115          enddo
1116          enddo
1117    
1118        p00 = 1000.        p00 = 1000.
1119        crtmsf = 0.        crtmsf = 0.
# Line 1317  c -------------------------------------- Line 1240  c --------------------------------------
1240    
1241        RETURN        RETURN
1242        END        END
   
1243        subroutine rndcloud (iras,nrnd,rnd,myid)        subroutine rndcloud (iras,nrnd,rnd,myid)
1244        implicit none        implicit none
1245        integer n,iras,nrnd,myid        integer n,iras,nrnd,myid
1246        real random_numbx        _RL random_numbx
1247        real rnd(nrnd)        _RL rnd(nrnd)
1248        integer irm        integer irm
1249        parameter (irm = 1000)        parameter (irm = 1000)
1250        real random(irm)        _RL random(irm)
1251        integer i,mcheck,numrand,iseed,index        integer i,mcheck,numrand,iseed,index
1252        logical first        logical first
1253        data    first /.true./        data    first /.true./
# Line 1352  c -------------------------------------- Line 1274  c --------------------------------------
1274         iseed   = iras * nrnd - numrand         iseed   = iras * nrnd - numrand
1275         call random_seedx(iseed)         call random_seedx(iseed)
1276         do i = 1,irm         do i = 1,irm
1277          random(i) = random_numbx()          random(i) = random_numbx(iseed)
1278         enddo         enddo
1279         index = (iras-1)*nrnd         index = (iras-1)*nrnd
1280    
# Line 1362  c -------------------------------------- Line 1284  c --------------------------------------
1284            iseed = (iras-1)*nrnd            iseed = (iras-1)*nrnd
1285            call random_seedx(iseed)            call random_seedx(iseed)
1286            do i = 1,irm            do i = 1,irm
1287             random(i) = random_numbx()             random(i) = random_numbx(iseed)
1288            enddo            enddo
1289            index = iseed            index = iseed
1290    
# Line 1384  c -------------------------------------- Line 1306  c --------------------------------------
1306        iras0 = iras        iras0 = iras
1307        return        return
1308        end        end
1309          function random_numbx(iseed)
       real function random_numbx()  
1310        implicit none        implicit none
1311  #if CRAY        integer iseed
1312        real ranf        real *8 seed,port_rand
1313          _RL random_numbx
1314          random_numbx = 0
1315    #ifdef CRAY
1316          _RL ranf
1317        random_numbx = ranf()        random_numbx = ranf()
1318  #endif  #else
1319  #if SGI  #ifdef SGI
1320        real rand        _RL rand
1321        random_numbx = rand()        random_numbx = rand()
1322  #endif  #endif
1323          random_numbx = port_rand(seed)
1324    #endif
1325        return        return
1326        end        end
1327        subroutine random_seedx (iseed)        subroutine random_seedx (iseed)
1328        implicit none        implicit none
1329        integer  iseed        integer  iseed
1330  #if CRAY  #ifdef CRAY
1331        call ranset (iseed)        call ranset (iseed)
1332  #endif  #endif
1333  #if SGI  #ifdef SGI
1334        integer*4   seed        integer*4   seed
1335                    seed = iseed                    seed = iseed
1336        call srand (seed)        call srand (seed)
1337  #endif  #endif
1338        return        return
1339        end        end
1340          SUBROUTINE CLOUD(nn,LEN, LENC, K, NLTOP, nlayr, IC, RASALF
       SUBROUTINE CLOUD(nn,LEN, LENC, K, NLTOP, nlayr, IC, RASALF,  
1341       *,                 SETRAS, FRAC       *,                 SETRAS, FRAC
1342       *,                 CP,  ALHL, RKAP, GRAV, P00, CRTMSF       *,                 CP,  ALHL, RKAP, GRAV, P00, CRTMSF
1343       *,                 POI, QOI, UOI, Ntracer, PRS,  PRJ       *,                 POI, QOI, UOI, Ntracer, PRS,  PRJ
# Line 1545  C    IA, I1, and I2 are temporary intege Line 1471  C    IA, I1, and I2 are temporary intege
1471  C  C
1472  C  C
1473  C************************************************************************  C************************************************************************
1474  C        implicit none
1475  C  C Argument List declarations
1476          integer nn,LEN,LENC,K,NLTOP,nlayr,ic,ntracer
1477          _RL rasalf
1478          LOGICAL SETRAS
1479          _RL frac, cp,  alhl, rkap, grav, p00, crtmsf
1480          _RL POI(LEN,K),QOI(LEN,K),PRS(LEN,K+1),PRJ(LEN,K+1)
1481          _RL uoi(len,nlayr,ntracer)
1482          _RL PCU(LENC), CLN(LEN)
1483          _RL TCU(LEN,K),  QCU(LEN,K),  ucu(len,k,ntracer), CMASS(LEN,K)
1484          _RL ALF(LEN,K), BET(LEN,K),  GAM(LEN,K), PRH(LEN,K), PRI(LEN,K)
1485          _RL HOL(LENC,K), ETA(LENC,K), HST(LENC,K), QOL(LENC,K)
1486          _RL GMH(LENC,K)
1487          _RL TX1(LENC), TX2(LENC), TX3(LENC), TX4(LENC)
1488          _RL TX5(LENC), TX6(LENC), TX7(LENC), TX8(LENC)
1489          _RL ALM(LENC), WFN(LENC), AKM(LENC), QS1(LENC)
1490          _RL WLQ(LENC), CLF(LENC)
1491          _RL uht(len,ntracer)
1492          integer IA(LENC), I1(LENC),I2(LENC)
1493          _RL      rhfrac(len)
1494    
1495    C Local Variables
1496          _RL daylen,half,one,zero,cmb2pa,rhmax
1497        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)
1498        PARAMETER (CMB2PA=100.0)        PARAMETER (CMB2PA=100.0)
1499        PARAMETER (RHMAX=0.9999)        PARAMETER (RHMAX=0.9999)
1500          _RL rkapp1,onebcp,albcp,onebg,cpbg,twobal
1501  C  C
1502        integer nltop,ntracer,nlayr        integer nt,km1,ic1,i,L,len1,len2,isav,len11,ii
1503        DIMENSION POI(LEN,K),  QOI(LEN,K),  PRS(LEN,K+1)        integer lena,lena1,lenb,tem,tem1
      *,         PRJ(LEN,K+1)  
      *,         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  
1504    
1505  c Explicit Inline Directives  c Explicit Inline Directives
1506  c --------------------------  c --------------------------
1507  #if CRAY  #ifdef CRAY
1508  #if f77  #ifdef f77
1509  cfpp$ expand (qsat)  cfpp$ expand (qsat)
1510  #endif  #endif
1511  #endif  #endif
# Line 1590  C Line 1520  C
1520        KM1 = K  - 1        KM1 = K  - 1
1521        IC1 = IC + 1        IC1 = IC + 1
1522  C  C
1523  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.
1524  C  C
1525    
1526        IF (SETRAS) THEN        IF (SETRAS) THEN
# Line 2155  C Line 2085  C
2085        END        END
2086        SUBROUTINE RNCL(LEN, PL, RNO, CLF)        SUBROUTINE RNCL(LEN, PL, RNO, CLF)
2087  C  C
 C  
2088  C*********************************************************************  C*********************************************************************
2089  C********************** Relaxed Arakawa-Schubert *********************  C********************** Relaxed Arakawa-Schubert *********************
2090  C************************   SUBROUTINE  RNCL  ************************  C************************   SUBROUTINE  RNCL  ************************
2091  C**************************** 23 July 1992 ***************************  C**************************** 23 July 1992 ***************************
2092  C*********************************************************************  C*********************************************************************
2093          implicit none
2094    C Argument List declarations
2095          integer len
2096          _RL PL(LEN),  RNO(LEN), CLF(LEN)
2097    
2098    C Local Variables
2099          _RL p5,p8,pt8,pt2,pfac,p4,p6,p7,p9,cucld,cfac
2100        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)
2101        PARAMETER (PFAC=PT2/(P8-P5))        PARAMETER (PFAC=PT2/(P8-P5))
 C  
2102        PARAMETER (P4=400.0,    P6=401.0)        PARAMETER (P4=400.0,    P6=401.0)
2103        PARAMETER (P7=700.0,    P9=900.0)        PARAMETER (P7=700.0,    P9=900.0)
2104        PARAMETER (CUCLD=0.5,CFAC=CUCLD/(P6-P4))        PARAMETER (CUCLD=0.5,CFAC=CUCLD/(P6-P4))
2105    
2106          integer i
2107  C  C
       DIMENSION PL(LEN),  RNO(LEN), CLF(LEN)  
   
2108        DO 10 I=1,LEN        DO 10 I=1,LEN
2109                             rno(i) = 1.0                             rno(i) = 1.0
2110  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)) )
# Line 2209  C****  Note:  Data obtained from January Line 2143  C****  Note:  Data obtained from January
2143  C****         from 4x5 46-layer GEOS Assimilation                *****  C****         from 4x5 46-layer GEOS Assimilation                *****
2144  C****                                                            *****  C****                                                            *****
2145  C*********************************************************************  C*********************************************************************
2146          implicit none
2147        real PL(LEN), PLB(LEN), ACR(LEN)  C Argument List declarations
2148          integer len
2149          _RL PL(LEN), PLB(LEN), ACR(LEN)
2150    
2151    C Local variables
2152          integer lma
2153        parameter  (lma=18)        parameter  (lma=18)
2154        real      p(lma)        _RL p(lma)
2155        real      a(lma)        _RL a(lma)
2156          integer i,L
2157          _RL temp
2158    
2159        data p  / 93.81, 111.65, 133.46, 157.80, 186.51,        data p  / 93.81, 111.65, 133.46, 157.80, 186.51,
2160       .         219.88, 257.40, 301.21, 352.49, 409.76,       .         219.88, 257.40, 301.21, 352.49, 409.76,
# Line 2248  C*************************************** Line 2188  C***************************************
2188    
2189        RETURN        RETURN
2190        END        END
2191         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,
2192       1   PLK,TH,TEMP1,TEMP2,TEMP3,ITMP1,ITMP2,RCON,RLAR,CLSBTH,tmscl,       1   PLK,TH,TEMP1,TEMP2,TEMP3,ITMP1,ITMP2,RCON,RLAR,CLSBTH,tmscl,
2193       2   tmfrc,cp,gravity,alhl,gamfac,cldlz,RHCRIT,offset,alpha)       2   tmfrc,cp,gravity,alhl,gamfac,cldlz,RHCRIT,offset,alpha)
2194    
2195          implicit none
2196    C Argument List declarations
2197          integer nn,irun,nlay
2198          _RL TL(IRUN,NLAY),QL(IRUN,NLAY),RAIN(IRUN,NLAY),
2199         . PL(IRUN,NLAY),CLFRAC(IRUN,NLAY),SP(IRUN),TEMP1(IRUN,NLAY),
2200         . TEMP2(IRUN,NLAY),PLKE(IRUN,NLAY+1),
2201         . RCON(IRUN),RLAR(IRUN),DP(IRUN,NLAY),PLK(IRUN,NLAY),TH(IRUN,NLAY),
2202         . TEMP3(IRUN,NLAY)
2203          integer ITMP1(IRUN,NLAY),ITMP2(IRUN,NLAY)
2204          _RL CLSBTH(IRUN,NLAY)
2205          _RL tmscl,tmfrc,cp,gravity,alhl,gamfac,offset,alpha
2206          _RL cldlz(irun,nlay)
2207          _RL rhcrit(irun,nlay)
2208    C
2209    C Local Variables
2210          _RL zm1p04,zero,two89,zp44,zp01,half,zp578,one,thousand,z3600
2211          _RL zp1,zp001
2212        PARAMETER (ZM1P04 = -1.04E-4 )        PARAMETER (ZM1P04 = -1.04E-4 )
2213        PARAMETER (ZERO = 0.)        PARAMETER (ZERO = 0.)
2214        PARAMETER (TWO89= 2.89E-5)        PARAMETER (TWO89= 2.89E-5)
# Line 2265  C*************************************** Line 2222  C***************************************
2222        PARAMETER ( THOUSAND = 1000.)        PARAMETER ( THOUSAND = 1000.)
2223        PARAMETER ( Z3600 = 3600.)        PARAMETER ( Z3600 = 3600.)
2224  C  C
2225         DIMENSION TL(IRUN,NLAY),QL(IRUN,NLAY),RAIN(IRUN,NLAY),        _RL EVP9(IRUN,NLAY)
2226       $ PL(IRUN,NLAY),CLFRAC(IRUN,NLAY),SP(IRUN),TEMP1(IRUN,NLAY),        _RL water(irun),crystal(irun)
2227       $ TEMP2(IRUN,NLAY),PLKE(IRUN,NLAY),        _RL watevap(irun),iceevap(irun)
2228       $ RCON(IRUN),RLAR(IRUN),DSIG(NLAY),PLK(IRUN,NLAY),TH(IRUN,NLAY),        _RL fracwat,fracice, tice,rh,fact,dum
2229       $ TEMP3(IRUN,NLAY),ITMP1(IRUN,NLAY),        _RL rainmax(irun)
2230       $ ITMP2(IRUN,NLAY),CLSBTH(IRUN,NLAY)        _RL getcon,rphf,elocp,cpog,relax
2231  C        _RL exparg,arearat,rpow
2232         DIMENSION EVP9(IRUN,NLAY)  
2233         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  
2234    
2235  c Explicit Inline Directives  c Explicit Inline Directives
2236  c --------------------------  c --------------------------
2237  #if CRAY  #ifdef CRAY
2238  #if f77  #ifdef f77
2239  cfpp$ expand (qsat)  cfpp$ expand (qsat)
2240  #endif  #endif
2241  #endif  #endif
# Line 2333  C INVERSE OF MASS IN EACH LAYER Line 2284  C INVERSE OF MASS IN EACH LAYER
2284  c -----------------------------  c -----------------------------
2285        DO L = 1,NLAY        DO L = 1,NLAY
2286        DO I = 1,IRUN        DO I = 1,IRUN
2287        TEMP3(I,L) = SP(I) * DSIG(L)        TEMP3(I,L) = GRAVITY*ZP01 / DP(I,L)
       TEMP3(I,L) = GRAVITY*ZP01 / TEMP3(I,L)  
2288        ENDDO        ENDDO
2289        ENDDO        ENDDO
2290    
# Line 2482  C  ======= Line 2432  C  =======
2432  C    cloud ...... Cloud Fraction        (irun,irise)  C    cloud ...... Cloud Fraction        (irun,irise)
2433  C  C
2434  C***********************************************************************  C***********************************************************************
 C*                  GODDARD LABORATORY FOR ATMOSPHERES                 *  
 C***********************************************************************  
2435    
2436        implicit none        implicit none
2437        integer  irun,irise        integer  irun,irise
2438    
2439        real   th(irun,irise)        _RL   th(irun,irise)
2440        real    q(irun,irise)        _RL    q(irun,irise)
2441        real  plk(irun,irise)        _RL  plk(irun,irise)
2442        real   pl(irun,irise)        _RL   pl(irun,irise)
2443        real plke(irun,irise+1)        _RL plke(irun,irise+1)
2444    
2445        real tempth(irun)        _RL  cloud(irun,irise)
2446        real tempqs(irun)        _RL cldwat(irun,irise)
2447        real dhstar(irun)        _RL     qs(irun,irise)
2448        real  cloud(irun,irise)  
2449        real cldwat(irun,irise)        _RL cp, alhl, getcon, akap
2450        real     qs(irun,irise)        _RL ratio, temp, elocp
2451          _RL rhcrit,rh,dum
2452        real cp, alhl, getcon, akap, pcheck        integer i,L
2453        real ratio, temp, pke, elocp  
2454        real rhcrit,rh,dum,pbar,tbar        _RL rhc(irun,irise)
2455        integer i,L,ntradesu,ntradesl        _RL offset,alpha
   
       real factor  
       real rhc(irun,irise)  
       real offset,alpha  
2456    
2457  c Explicit Inline Directives  c Explicit Inline Directives
2458  c --------------------------  c --------------------------
2459  #if CRAY  #ifdef CRAY
2460  #if f77  #ifdef f77
2461  cfpp$ expand (qsat)  cfpp$ expand (qsat)
2462  #endif  #endif
2463  #endif  #endif
# Line 2554  c -------------------------------------- Line 2498  c --------------------------------------
2498        subroutine ctei ( th,q,cldfrc,cldwat,pl,plk,plke,im,lm )        subroutine ctei ( th,q,cldfrc,cldwat,pl,plk,plke,im,lm )
2499        implicit none        implicit none
2500        integer im,lm        integer im,lm
2501        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)
2502        real plk(im,lm),pl(im,lm),cldfrc(im,lm)        _RL plk(im,lm),pl(im,lm),cldfrc(im,lm)
2503        integer i,L        integer i,L
2504        real    getcon,cp,alhl,elocp,cpoel,t,p,s,qs,dqsdt,dq        _RL    getcon,cp,alhl,elocp,cpoel,t,p,s,qs,dqsdt,dq
2505        real    k,krd,kmm,f        _RL    k,krd,kmm,f
2506    
2507        cp     = getcon('CP')        cp     = getcon('CP')
2508        alhl   = getcon('LATENT HEAT COND')        alhl   = getcon('LATENT HEAT COND')
# Line 2595  c -------------------------------------- Line 2539  c --------------------------------------
2539        subroutine back2grd(gathered,indeces,scattered,irun)        subroutine back2grd(gathered,indeces,scattered,irun)
2540        implicit none        implicit none
2541        integer i,irun,indeces(irun)        integer i,irun,indeces(irun)
2542        real gathered(irun),scattered(irun)        _RL gathered(irun),scattered(irun)
2543        real temp(irun)        _RL temp(irun)
2544        do i = 1,irun        do i = 1,irun
2545         temp(indeces(i)) = gathered(i)         temp(indeces(i)) = gathered(i)
2546        enddo        enddo
Legend:
Removed from v.1.1  
changed lines
  Added in v.1.13
  ViewVC Help
Powered by ViewVC 1.1.22