/[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.13 by molod, Mon Jul 26 18:45:17 2004 UTC revision 1.35 by ce107, Fri Jun 17 16:51:24 2005 UTC
# Line 4  C $Name$ Line 4  C $Name$
4  #include "FIZHI_OPTIONS.h"  #include "FIZHI_OPTIONS.h"
5        subroutine moistio (ndmoist,istrip,npcs,        subroutine moistio (ndmoist,istrip,npcs,
6       .   lowlevel,midlevel,nltop,nsubmin,nsubmax,Lup,       .   lowlevel,midlevel,nltop,nsubmin,nsubmax,Lup,
7       .   pz,plz,plze,dpres,pkht,pkl,tz,qz,bi,bj,ntracer,ptracer,       .   pz,plz,plze,dpres,pkht,pkl,uz,vz,tz,qz,bi,bj,ntracerin,ptracer,
8       .   qqz,dumoist,dvmoist,dtmoist,dqmoist,       .   qqz,dumoist,dvmoist,dtmoist,dqmoist,cumfric,
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,
# Line 14  C $Name$ Line 14  C $Name$
14    
15         implicit none         implicit none
16    
 #ifdef ALLOW_DIAGNOSTICS  
 #include "SIZE.h"  
 #include "diagnostics_SIZE.h"  
 #include "diagnostics.h"  
 #endif  
   
17  c Input Variables  c Input Variables
18  c ---------------  c ---------------
19        integer im,jm,lm        integer im,jm,lm
20        integer ndmoist,istrip,npcs        integer ndmoist,istrip,npcs
21        integer bi,bj,ntracer,ptracer                integer bi,bj,ntracerin,ptracer        
22        integer lowlevel,midlevel,nltop,nsubmin,nsubmax,Lup        integer lowlevel,midlevel,nltop,nsubmin,nsubmax,Lup
23        _RL pz(im,jm),plz(im,jm,lm),plze(im,jm,lm+1),dpres(im,jm,lm)        _RL pz(im,jm),plz(im,jm,lm),plze(im,jm,lm+1),dpres(im,jm,lm)
24        _RL pkht(im,jm,lm+1),pkl(im,jm,lm)        _RL pkht(im,jm,lm+1),pkl(im,jm,lm)
25        _RL tz(im,jm,lm),qz(im,jm,lm,ntracer)              _RL tz(im,jm,lm),qz(im,jm,lm,ntracerin)      
26          _RL uz(im,jm,lm),vz(im,jm,lm)      
27        _RL qqz(im,jm,lm)        _RL qqz(im,jm,lm)
28        _RL dumoist(im,jm,lm),dvmoist(im,jm,lm)        _RL dumoist(im,jm,lm),dvmoist(im,jm,lm)
29        _RL dtmoist(im,jm,lm),dqmoist(im,jm,lm,ntracer)        _RL dtmoist(im,jm,lm),dqmoist(im,jm,lm,ntracerin)
30          logical cumfric
31        _RL ptop        _RL ptop
32        integer iras        integer iras
33        _RL rainlsp(im,jm),rainconv(im,jm),snowfall(im,jm)        _RL rainlsp(im,jm),rainconv(im,jm),snowfall(im,jm)
# Line 51  c --------------- Line 47  c ---------------
47        _RL       fracqq, dum        _RL       fracqq, dum
48        integer    snowcrit        integer    snowcrit
49        parameter (fracqq = 0.1)        parameter (fracqq = 0.1)
50          _RL one
51          parameter (one=1.)
52    
53        _RL   cldsr(im,jm,lm)        _RL   cldsr(im,jm,lm)
54        _RL   srcld(istrip,lm)        _RL   srcld(istrip,lm)
# Line 86  c -------------------------------------- Line 84  c --------------------------------------
84        _RL    tmpgather(im*jm,lm)        _RL    tmpgather(im*jm,lm)
85        _RL   deltgather(im*jm,lm)        _RL   deltgather(im*jm,lm)
86        _RL   delqgather(im*jm,lm)        _RL   delqgather(im*jm,lm)
87        _RL      ugather(im*jm,lm,ntracer)        _RL      ugather(im*jm,lm,ntracerin+2-ptracer)
88        _RL   delugather(im*jm,lm,ntracer)        _RL   delugather(im*jm,lm,ntracerin+2-ptracer)
89        _RL     deltrnev(im*jm,lm)        _RL     deltrnev(im*jm,lm)
90        _RL     delqrnev(im*jm,lm)        _RL     delqrnev(im*jm,lm)
91    
# Line 99  c Stripped Arrays Line 97  c Stripped Arrays
97  c ---------------  c ---------------
98        _RL saveth (istrip,lm)        _RL saveth (istrip,lm)
99        _RL saveq  (istrip,lm)        _RL saveq  (istrip,lm)
100        _RL saveu  (istrip,lm,ntracer)        _RL saveu  (istrip,lm,ntracerin+2-ptracer)
101        _RL usubcl (istrip,   ntracer)        _RL usubcl (istrip,   ntracerin+2-ptracer)
102    
103        _RL     ple(istrip,lm+1)        _RL     ple(istrip,lm+1)
104        _RL      dp(istrip,lm)        _RL      dp(istrip,lm)
# Line 109  c --------------- Line 107  c ---------------
107        _RL    PLKE(ISTRIP,lm+1)        _RL    PLKE(ISTRIP,lm+1)
108        _RL      TH(ISTRIP,lm)  ,CVTH(ISTRIP,lm)        _RL      TH(ISTRIP,lm)  ,CVTH(ISTRIP,lm)
109        _RL   CVQ(ISTRIP,lm)        _RL   CVQ(ISTRIP,lm)
110        _RL      UL(ISTRIP,lm,ntracer)        _RL      UL(ISTRIP,lm,ntracerin+2-ptracer)
111        _RL     cvu(istrip,lm,ntracer)        _RL     cvu(istrip,lm,ntracerin+2-ptracer)
112        _RL  CLMAXO(ISTRIP,lm),CLBOTH(ISTRIP,lm)        _RL  CLMAXO(ISTRIP,lm),CLBOTH(ISTRIP,lm)
113        _RL  CLSBTH(ISTRIP,lm)        _RL  CLSBTH(ISTRIP,lm)
114        _RL    TMP1(ISTRIP,lm),  TMP2(ISTRIP,lm)        _RL    TMP1(ISTRIP,lm),  TMP2(ISTRIP,lm)
# Line 138  c --------------- Line 136  c ---------------
136        DATA      FIRST /.TRUE./        DATA      FIRST /.TRUE./
137    
138        integer imstp,nsubcl,nlras        integer imstp,nsubcl,nlras
139        integer i,j,iloop,index,l,nn,num,numdeps,nt        integer i,j,iloop,indx,indgath,l,nn,num,numdeps,nt
140        _RL tmstp,tminv,sday,grav,alhl,cp,elocp,gamfac        _RL tmstp,tminv,sday,grav,alhl,cp,elocp,gamfac
141        _RL rkappa,p0kappa,p0kinv,ptopkap,pcheck        _RL rkappa,p0kappa,p0kinv,ptopkap,pcheck
142        _RL tice,getcon,pi        _RL tice,getcon,pi
143          integer ntracer,ntracedim, ntracex
144    
145    #ifdef ALLOW_DIAGNOSTICS
146          logical  diagnostics_is_on
147          external diagnostics_is_on
148          _RL tmpdiag(im,jm),tmpdiag2(im,jm)
149    #endif
150    
151  C **********************************************************************  C **********************************************************************
152  C ****                     INITIALIZATION                           ****  C ****                     INITIALIZATION                           ****
153  C **********************************************************************  C **********************************************************************
154    
155    C Add U and V components to tracer array for cumulus friction
156    
157          if(cumfric) then
158           ntracer = ntracerin + 2
159          else
160           ntracer = ntracerin
161          endif
162          ntracedim= max(ntracer-ptracer,1)
163          ntracex= ntracer-ptracer
164        IMSTP  = nsecf(NDMOIST)        IMSTP  = nsecf(NDMOIST)
165        TMSTP  = FLOAT(IMSTP)        TMSTP  = FLOAT(IMSTP)
166        TMINV  = 1. /  TMSTP        TMINV  = 1. /  TMSTP
# Line 184  c Determine Total number of Random Cloud Line 198  c Determine Total number of Random Cloud
198  c ---------------------------------------------  c ---------------------------------------------
199        ncrnd = (lm-nltop+1)/2        ncrnd = (lm-nltop+1)/2
200    
201        if(first .and. myid.eq.0) then        if(first .and. myid.eq.1 .and. bi.eq.1 ) then
202         print *         print *
203         print *,'Top Level Allowed for Convection : ',nltop         print *,'Top Level Allowed for Convection : ',nltop
204         print *,'          Highest Sub-Cloud Level: ',nsubmax         print *,'          Highest Sub-Cloud Level: ',nsubmax
# Line 228  c -------------------------------------- Line 242  c --------------------------------------
242    
243  c Set up the array of indeces of subcloud levels for the gathering  c Set up the array of indeces of subcloud levels for the gathering
244  c ----------------------------------------------------------------  c ----------------------------------------------------------------
245        index = 0        indx = 0
246        do L = nsubmin,nltop,-1        do L = nsubmin,nltop,-1
247         do j = 1,jm         do j = 1,jm
248         do i = 1,im         do i = 1,im
249          if(levpbl(i,j).eq.L) then          if(levpbl(i,j).eq.L) then
250           index = index + 1           indx = indx + 1
251           pblindex(index) = (j-1)*im + i           pblindex(indx) = (j-1)*im + i
252          endif          endif
253         enddo         enddo
254         enddo         enddo
255        enddo        enddo
256    
257        do index = 1,im*jm        do indx = 1,im*jm
258         levgather(index) = levpbl(pblindex(index),1)         levgather(indx) = levpbl(pblindex(indx),1)
259          pigather(index) =     pz(pblindex(index),1)          pigather(indx) =     pz(pblindex(indx),1)
260          pkegather(index,lm+1) = pkht(pblindex(index),1,lm+1)          pkegather(indx,lm+1) = pkht(pblindex(indx),1,lm+1)
261          plegather(index,lm+1) = plze(pblindex(index),1,lm+1)          plegather(indx,lm+1) = plze(pblindex(indx),1,lm+1)
262        enddo        enddo
263    
264        do L = 1,lm        do L = 1,lm
265         do index = 1,im*jm         do indx = 1,im*jm
266           thgather(index,L) = tz(pblindex(index),1,L)           thgather(indx,L) = tz(pblindex(indx),1,L)
267           shgather(index,L) = qz(pblindex(index),1,L,1)           shgather(indx,L) = qz(pblindex(indx),1,L,1)
268          pkegather(index,L) = pkht(pblindex(index),1,L)          pkegather(indx,L) = pkht(pblindex(indx),1,L)
269          pkzgather(index,L) = pkl(pblindex(index),1,L)          pkzgather(indx,L) = pkl(pblindex(indx),1,L)
270          plegather(index,L) = plze(pblindex(index),1,L)          plegather(indx,L) = plze(pblindex(indx),1,L)
271          plzgather(index,L) = plz(pblindex(index),1,L)          plzgather(indx,L) = plz(pblindex(indx),1,L)
272           dpgather(index,L) = dpres(pblindex(index),1,L)           dpgather(indx,L) = dpres(pblindex(indx),1,L)
273         enddo         enddo
274        enddo        enddo
275        do nt = 1,ntracer-ptracer  C General Tracers
276    C----------------
277          do nt = 1,ntracerin-ptracer
278        do L = 1,lm        do L = 1,lm
279         do index = 1,im*jm         do indx = 1,im*jm
280          ugather(index,L,nt) = qz(pblindex(index),1,L,nt+ptracer)          ugather(indx,L,nt) = qz(pblindex(indx),1,L,nt+ptracer)
281         enddo         enddo
282        enddo        enddo
283        enddo        enddo
284    
285          if(cumfric) then
286    C Cumulus Friction - load u and v wind components into tracer array
287    C------------------------------------------------------------------
288          do L = 1,lm
289           do indx = 1,im*jm
290            ugather(indx,L,ntracerin-ptracer+1) = uz(pblindex(indx),1,L)
291            ugather(indx,L,ntracerin-ptracer+2) = vz(pblindex(indx),1,L)
292           enddo
293          enddo
294    
295          endif
296    
297  c bump the counter for number of calls to convection  c bump the counter for number of calls to convection
298  c --------------------------------------------------  c --------------------------------------------------
299                          iras = iras + 1                          iras = iras + 1
# Line 278  c -------------------------------------- Line 306  c --------------------------------------
306        do l=1,lm        do l=1,lm
307        do j=1,jm        do j=1,jm
308        do i=1,im        do i=1,im
309          dumoist(i,j,l) = 0.
310          dvmoist(i,j,l) = 0.
311        dtmoist(i,j,l) = 0.        dtmoist(i,j,l) = 0.
312          do nt = 1,ntracer          do nt = 1,ntracerin
313          dqmoist(i,j,l,nt) = 0.          dqmoist(i,j,l,nt) = 0.
314          enddo          enddo
315        enddo        enddo
# Line 307  C ************************************** Line 337  C **************************************
337         CALL STRINT( levgather, pbl     ,im*jm,ISTRIP,1 ,NN )         CALL STRINT( levgather, pbl     ,im*jm,ISTRIP,1 ,NN )
338    
339         do nt = 1,ntracer-ptracer         do nt = 1,ntracer-ptracer
340         call strip ( ugather(1,1,nt), ul(1,1,nt),im*jm,istrip,lm,nn )          call strip ( ugather(1,1,nt), ul(1,1,nt),im*jm,istrip,lm,nn )
341         enddo         enddo
342    
343  C **********************************************************************  C **********************************************************************
# Line 340  C ************************************** Line 370  C **************************************
370         endif         endif
371        enddo        enddo
372    
   
373  C Initiate a do-loop around RAS for the number of different  C Initiate a do-loop around RAS for the number of different
374  C    sub-cloud layer depths in this strip  C    sub-cloud layer depths in this strip
375  C --If all subcloud depths are the same, execute loop once  C --If all subcloud depths are the same, execute loop once
# Line 476  c -------------------------------------- Line 505  c --------------------------------------
505        enddo        enddo
506    
507        CALL RAS ( NN,istrip,nindeces(nsubcl),NLRAS,NLTOP,lm,TMSTP        CALL RAS ( NN,istrip,nindeces(nsubcl),NLRAS,NLTOP,lm,TMSTP
508       1, UL(num,1,1),ntracer-ptracer,TH(num,NLTOP),SHL(num,NLTOP)       1, UL(num,1,1),ntracedim,ntracex,TH(num,NLTOP),SHL(num,NLTOP)
509       2, TMP4(num,NLTOP), TMP5(num,NLTOP),rnd, ncrnd, PCPEN(num,NLTOP)       2, TMP4(num,NLTOP), TMP5(num,NLTOP),rnd, ncrnd, PCPEN(num,NLTOP)
510       3, CLBOTH(num,NLTOP), CLFRAC(num,NLTOP)       3, CLBOTH(num,NLTOP), CLFRAC(num,NLTOP)
511       4, cldmas(num,nltop), detrain(num,nltop)       4, cldmas(num,nltop), detrain(num,nltop)
# Line 577  C     And now paste some arrays for fill Line 606  C     And now paste some arrays for fill
606  C (use pkegather to hold detrainment and tmpgather for cloud mass flux)  C (use pkegather to hold detrainment and tmpgather for cloud mass flux)
607  C **********************************************************************  C **********************************************************************
608    
609        if(icldmas .gt.0) call paste( cldmas,tmpgather,istrip,im*jm,lm,NN)        call paste( cldmas,tmpgather,istrip,im*jm,lm,NN)
610        if(idtrain .gt.0) call paste(detrain,pkegather,istrip,im*jm,lm,NN)        call paste(detrain,pkegather,istrip,im*jm,lm,NN)
       if(ipsubcld.gt.0) then  
611        call paste(psubcld    ,psubcldg ,istrip,im*jm,1,NN)        call paste(psubcld    ,psubcldg ,istrip,im*jm,1,NN)
612        call paste(psubcld_cnt,psubcldgc,istrip,im*jm,1,NN)        call paste(psubcld_cnt,psubcldgc,istrip,im*jm,1,NN)
       endif  
613    
614  C *********************************************************************  C *********************************************************************
615  C ****         RE-EVAPORATION OF PENETRATING CONVECTIVE RAIN       ****  C ****         RE-EVAPORATION OF PENETRATING CONVECTIVE RAIN       ****
# Line 602  C ************************************** Line 629  C **************************************
629    
630         CALL RNEVP (NN,ISTRIP,lm,TL,SHL,PCPEN,PL,CLFRAC,SP,DP,PLKE,         CALL RNEVP (NN,ISTRIP,lm,TL,SHL,PCPEN,PL,CLFRAC,SP,DP,PLKE,
631       .  PLK,TH,TMP1,TMP2,TMP3,ITMP1,ITMP2,PCNET,PRECIP,       .  PLK,TH,TMP1,TMP2,TMP3,ITMP1,ITMP2,PCNET,PRECIP,
632       .  CLSBTH,TMSTP,1.,cp,grav,alhl,gamfac,cldlz,rhcrit,offset,alpha)       .  CLSBTH,TMSTP,one,cp,grav,alhl,gamfac,cldlz,rhcrit,offset,alpha)
633    
634  C **********************************************************************  C **********************************************************************
635  C ****                     TENDENCY UPDATES                         ****  C ****                     TENDENCY UPDATES                         ****
# Line 622  C ************************************** Line 649  C **************************************
649    
650  C Paste rain evap tendencies into arrays for diagnostic output  C Paste rain evap tendencies into arrays for diagnostic output
651  c ------------------------------------------------------------  c ------------------------------------------------------------
        if(idtls.gt.0)then  
652         DO I =1,ISTRIP         DO I =1,ISTRIP
653          TMP1(I,L) = ((TL(I,L)/PLK(I,L))-saveth(i,l))*plk(i,l)*sday*tminv          TMP1(I,L) = ((TL(I,L)/PLK(I,L))-saveth(i,l))*plk(i,l)*sday*tminv
654         ENDDO         ENDDO
655         call paste(tmp1(1,L),deltrnev(1,L),istrip,im*jm,1,NN)         call paste(tmp1(1,L),deltrnev(1,L),istrip,im*jm,1,NN)
        endif  
656    
        if(idqls.gt.0)then  
657         DO I =1,ISTRIP         DO I =1,ISTRIP
658          TMP1(I,L) = (SHL(I,L)-saveq(I,L)) * 1000. * sday * tminv          TMP1(I,L) = (SHL(I,L)-saveq(I,L)) * 1000. * sday * tminv
659         ENDDO         ENDDO
660         call paste(tmp1(1,L),delqrnev(1,L),istrip,im*jm,1,NN)         call paste(tmp1(1,L),delqrnev(1,L),istrip,im*jm,1,NN)
        endif  
661    
662        ENDDO        ENDDO
663    
# Line 708  c--------------------------------------- Line 731  c---------------------------------------
731        CALL paste (tmp1(1,1), lsp_new,ISTRIP,im*jm,1,NN)        CALL paste (tmp1(1,1), lsp_new,ISTRIP,im*jm,1,NN)
732        CALL paste (tmp1(1,2),conv_new,ISTRIP,im*jm,1,NN)        CALL paste (tmp1(1,2),conv_new,ISTRIP,im*jm,1,NN)
733        CALL paste (tmp1(1,3),snow_new,ISTRIP,im*jm,1,NN)        CALL paste (tmp1(1,3),snow_new,ISTRIP,im*jm,1,NN)
   
       if(iprecon.gt.0) then  
734        CALL paste (pcnet,raincgath,ISTRIP,im*jm,1,NN)        CALL paste (pcnet,raincgath,ISTRIP,im*jm,1,NN)
       endif  
735    
736  C *********************************************************************  C *********************************************************************
737  C ****               End Major Stripped Region                     ****  C ****               End Major Stripped Region                     ****
# Line 724  c -------------------------------------- Line 744  c --------------------------------------
744        call back2grd ( lsp_new,pblindex, lsp_new,im*jm)        call back2grd ( lsp_new,pblindex, lsp_new,im*jm)
745        call back2grd (conv_new,pblindex,conv_new,im*jm)        call back2grd (conv_new,pblindex,conv_new,im*jm)
746        call back2grd (snow_new,pblindex,snow_new,im*jm)        call back2grd (snow_new,pblindex,snow_new,im*jm)
   
       if(iprecon.gt.0) then  
747        call back2grd (raincgath,pblindex,raincgath,im*jm)        call back2grd (raincgath,pblindex,raincgath,im*jm)
       endif  
748    
749  c Subcloud Layer Pressure  c Subcloud Layer Pressure
750  c -----------------------  c -----------------------
       if(ipsubcld.gt.0) then  
751        call back2grd (psubcldg ,pblindex,psubcldg ,im*jm)        call back2grd (psubcldg ,pblindex,psubcldg ,im*jm)
752        call back2grd (psubcldgc,pblindex,psubcldgc,im*jm)        call back2grd (psubcldgc,pblindex,psubcldgc,im*jm)
       endif  
753    
754        do L = 1,lm        do L = 1,lm
755  C Delta theta,q, convective, max and ls clouds  C Delta theta,q, convective, max and ls clouds
# Line 748  c -------------------------------------- Line 763  c --------------------------------------
763    
764  C Diagnostics:  C Diagnostics:
765  c ------------  c ------------
766         if(icldmas.gt.0)call back2grd(tmpgather(1,L),pblindex,         call back2grd(tmpgather(1,L),pblindex,
767       .                                            tmpgather(1,L),im*jm)       .                                            tmpgather(1,L),im*jm)
768         if(idtrain.gt.0)call back2grd(pkegather(1,L),pblindex,         call back2grd(pkegather(1,L),pblindex,
769       .                                            pkegather(1,L),im*jm)       .                                            pkegather(1,L),im*jm)
770         if(idtls.gt.0)call back2grd(deltrnev(1,L),pblindex,         call back2grd(deltrnev(1,L),pblindex,
771       .                                             deltrnev(1,L),im*jm)       .                                             deltrnev(1,L),im*jm)
772         if(idqls.gt.0)call back2grd(delqrnev(1,L),pblindex,         call back2grd(delqrnev(1,L),pblindex,
773       .                                             delqrnev(1,L),im*jm)       .                                             delqrnev(1,L),im*jm)
774         if(icldnp.gt.0)call back2grd(cldsr(1,1,L),pblindex,         call back2grd(cldsr(1,1,L),pblindex,
775       .                                              cldsr(1,1,L),im*jm)       .                                              cldsr(1,1,L),im*jm)
776        enddo        enddo
777    
778  c Tracers  c General Tracers
779  c -------  c ---------------
780        do nt = 1,ntracer-ptracer        do nt = 1,ntracerin-ptracer
781         do L = 1,lm         do L = 1,lm
782         call back2grd (delugather(1,L,nt),pblindex,         call back2grd (delugather(1,L,nt),pblindex,
783       .                                 dqmoist(1,1,L,ptracer+nt),im*jm)       .                                 dqmoist(1,1,L,ptracer+nt),im*jm)
784         enddo         enddo
785        enddo        enddo
786    
787          if(cumfric) then
788    
789  C **********************************************************************  c U and V for cumulus friction
790  C                          BUMP DIAGNOSTICS  c ----------------------------
791  C **********************************************************************        do L = 1,lm
792           call back2grd (delugather(1,L,ntracerin-ptracer+1),pblindex,
793         .                                 dumoist(1,1,L),im*jm)
794           call back2grd (delugather(1,L,ntracerin-ptracer+2),pblindex,
795         .                                 dvmoist(1,1,L),im*jm)
796          enddo
797    
798  c Sub-Cloud Layer  C Remove pi-weighting for u and v tendencies
 c -------------------------  
       if( ipsubcld.ne.0 ) then  
799        do j = 1,jm        do j = 1,jm
800        do i = 1,im        do i = 1,im
801        qdiag(i,j,ipsubcld,bi,bj) = qdiag(i,j,ipsubcld,bi,bj) +         tmpimjm(i,j) = 1./pz(i,j)
      .                                           psubcldg (i,j)  
       qdiag(i,j,ipsubcldc,bi,bj) = qdiag(i,j,ipsubcldc,bi,bj) +  
      .                                           psubcldgc(i,j)  
802        enddo        enddo
803        enddo        enddo
       endif  
   
 c Non-Precipitating Cloud Fraction  
 c --------------------------------  
       if( icldnp.ne.0 ) then  
804        do L = 1,lm        do L = 1,lm
805        do j = 1,jm        do j = 1,jm
806        do i = 1,im        do i = 1,im
807        qdiag(i,j,icldnp+L-1,bi,bj) = qdiag(i,j,icldnp+L-1,bi,bj) +         dumoist(i,j,L) = dumoist(i,j,L) * tmpimjm(i,j)
808       .                                                  cldsr(i,j,L)         dvmoist(i,j,L) = dvmoist(i,j,L) * tmpimjm(i,j)
809        enddo        enddo
810        enddo        enddo
811        enddo        enddo
812        ncldnp = ncldnp + 1  
813    
814          endif
815    
816    C **********************************************************************
817    C                          BUMP DIAGNOSTICS
818    C **********************************************************************
819    
820    #ifdef ALLOW_DIAGNOSTICS
821    
822    c Sub-Cloud Layer
823    c -------------------------
824          if(diagnostics_is_on('PSUBCLD ',myid) .and.
825         .                 diagnostics_is_on('PSUBCLDC',myid) ) then
826           call diagnostics_fill(psubcldg,'PSUBCLD ',0,1,3,bi,bj,myid)
827           call diagnostics_fill(psubcldgc,'PSUBCLDC',0,1,3,bi,bj,myid)
828          endif
829    
830    c Non-Precipitating Cloud Fraction
831    c --------------------------------
832          if(diagnostics_is_on('CLDNP   ',myid) ) then
833           do L=1,lm
834           do j=1,jm
835           do i=1,im
836            tmpdiag(i,j) = cldsr(i,j,L)
837           enddo
838           enddo
839           call diagnostics_fill(tmpdiag,'CLDNP   ',L,1,3,bi,bj,myid)
840          enddo
841        endif        endif
842    
843  c Moist Processes Heating Rate  c Moist Processes Heating Rate
844  c ----------------------------  c ----------------------------
845        if(imoistt.gt.0) then        if(diagnostics_is_on('MOISTT  ',myid) ) then
846        do L = 1,lm         do L=1,lm
847        do i = 1,im*jm         do j=1,jm
848        qdiag(i,1,imoistt+L-1,bi,bj) = qdiag(i,1,imoistt+L-1,bi,bj) +         do i=1,im
849       .                      (dtmoist(i,1,L)*sday*pkzgather(i,L)/pz(i,1))          indgath = (j-1)*im + i
850        enddo          tmpdiag(i,j)=(dtmoist(i,j,L)*sday*pkzgather(indgath,L)/pz(i,j))
851           enddo
852           enddo
853           call diagnostics_fill(tmpdiag,'MOISTT  ',L,1,3,bi,bj,myid)
854        enddo        enddo
855        endif        endif
856    
857  c Moist Processes Moistening Rate  c Moist Processes Moistening Rate
858  c -------------------------------  c -------------------------------
859        if(imoistq.gt.0) then        if(diagnostics_is_on('MOISTQ  ',myid) ) then
860        do L = 1,lm         do L=1,lm
861        do j = 1,jm         do j=1,jm
862        do i = 1,im         do i=1,im
863        qdiag(i,j,imoistq+L-1,bi,bj) = qdiag(i,j,imoistq+L-1,bi,bj) +          tmpdiag(i,j)=(dqmoist(i,j,L,1)*sday*1000./pz(i,j))
864       .                           (dqmoist(i,j,L,1)*sday*1000.0/pz(i,j))         enddo
865        enddo         enddo
866        enddo         call diagnostics_fill(tmpdiag,'MOISTQ  ',L,1,3,bi,bj,myid)
867        enddo        enddo
868        endif        endif
869    
870  c Cloud Mass Flux  c Cloud Mass Flux
871  c ---------------  c ---------------
872        if(icldmas.gt.0) then        if(diagnostics_is_on('CLDMAS  ',myid) ) then
873        do L = 1,lm         do L=1,lm
874        do i = 1,im*jm         do j=1,jm
875        qdiag(i,1,icldmas+L-1,bi,bj) = qdiag(i,1,icldmas+L-1,bi,bj) +         do i=1,im
876       .                                                  tmpgather(i,L)          indgath = (j-1)*im + i
877        enddo          tmpdiag(i,j)=tmpgather(indgath,L)
878        enddo         enddo
879           enddo
880           call diagnostics_fill(tmpdiag,'CLDMAS  ',L,1,3,bi,bj,myid)
881           enddo
882        endif        endif
883    
884  c Detrained Cloud Mass Flux  c Detrained Cloud Mass Flux
885  c -------------------------  c -------------------------
886        if(idtrain.gt.0) then        if(diagnostics_is_on('DTRAIN  ',myid) ) then
887        do L = 1,lm         do L=1,lm
888        do i = 1,im*jm         do j=1,jm
889        qdiag(i,1,idtrain+L-1,bi,bj) = qdiag(i,1,idtrain+L-1,bi,bj) +         do i=1,im
890       .                                                  pkegather(i,L)          indgath = (j-1)*im + i
891        enddo          tmpdiag(i,j)=pkegather(indgath,L)
892        enddo         enddo
893           enddo
894           call diagnostics_fill(tmpdiag,'DTRAIN  ',L,1,3,bi,bj,myid)
895           enddo
896        endif        endif
897    
898  c Grid-Scale Condensational Heating Rate  c Grid-Scale Condensational Heating Rate
899  c --------------------------------------  c --------------------------------------
900        if(idtls.gt.0) then        if(diagnostics_is_on('DTLS    ',myid) ) then
901        do L = 1,lm         do L=1,lm
902        do i = 1,im*jm         do j=1,jm
903        qdiag(i,1,idtls+L-1,bi,bj) = qdiag(i,1,idtls+L-1,bi,bj) +         do i=1,im
904       .                                                  deltrnev(i,L)          indgath = (j-1)*im + i
905        enddo          tmpdiag(i,j)=deltrnev(indgath,L)
906        enddo         enddo
907           enddo
908           call diagnostics_fill(tmpdiag,'DTLS    ',L,1,3,bi,bj,myid)
909           enddo
910        endif        endif
911    
912  c Grid-Scale Condensational Moistening Rate  c Grid-Scale Condensational Moistening Rate
913  c -----------------------------------------  c -----------------------------------------
914        if(idqls.gt.0) then        if(diagnostics_is_on('DQLS    ',myid) ) then
915        do L = 1,lm         do L=1,lm
916        do i = 1,im*jm         do j=1,jm
917        qdiag(i,1,idqls+L-1,bi,bj) = qdiag(i,1,idqls+L-1,bi,bj) +         do i=1,im
918       .                                                  delqrnev(i,L)          indgath = (j-1)*im + i
919        enddo          tmpdiag(i,j)=delqrnev(indgath,L)
920        enddo         enddo
921           enddo
922           call diagnostics_fill(tmpdiag,'DQLS    ',L,1,3,bi,bj,myid)
923           enddo
924        endif        endif
925    
926  c Total Precipitation  c Total Precipitation
927  c -------------------  c -------------------
928        if(ipreacc.gt.0) then        if(diagnostics_is_on('PREACC  ',myid) ) then
929        do j = 1,jm         do j=1,jm
930        do i = 1,im         do i=1,im
931        qdiag(i,j,ipreacc,bi,bj) = qdiag(i,j,ipreacc,bi,bj)          tmpdiag(i,j) = (lsp_new(I,j) + snow_new(I,j) + conv_new(i,j))
932       .                   +  (  lsp_new(I,j)       .                                                    *sday*tminv
933       .                      + snow_new(I,j)         enddo
934       .                      + conv_new(i,j) ) *sday*tminv         enddo
935        enddo         call diagnostics_fill(tmpdiag,'PREACC  ',0,1,3,bi,bj,myid)
       enddo  
936        endif        endif
937    
938  c Convective Precipitation  c Convective Precipitation
939  c ------------------------  c ------------------------
940        if(iprecon.gt.0) then        if(diagnostics_is_on('PRECON  ',myid) ) then
941        do i = 1,im*jm         do j=1,jm
942        qdiag(i,1,iprecon,bi,bj) = qdiag(i,1,iprecon,bi,bj) +         do i=1,im
943       .                                         raincgath(i)*sday*tminv          indgath = (j-1)*im + i
944        enddo          tmpdiag(i,j) = raincgath(indgath)*sday*tminv
945           enddo
946           enddo
947           call diagnostics_fill(tmpdiag,'PRECON  ',0,1,3,bi,bj,myid)
948        endif        endif
949    
950    #endif
951    
952  C **********************************************************************  C **********************************************************************
953  C ****   Fill Rainfall and Snowfall Arrays for Land Surface Model   ****  C ****   Fill Rainfall and Snowfall Arrays for Land Surface Model   ****
954  C ****        Note:  Precip Rates work when DT(turb)<DT(moist)      ****  C ****        Note:  Precip Rates work when DT(turb)<DT(moist)      ****
# Line 934  c Compute Time-averaged Cloud and Water Line 992  c Compute Time-averaged Cloud and Water
992  c --------------------------------------------------------------------  c --------------------------------------------------------------------
993         watnow = cldwater(i,1,L)         watnow = cldwater(i,1,L)
994         if( plev.le.500.0 ) then         if( plev.le.500.0 ) then
995          cldras = min( max( cldras_lw(i,1,L)*cldras_mem,cpen(i,1,L)),1.0)            cldras = min( max( cldras_lw(i,1,L)*cldras_mem,cpen(i,1,L)),
996         $         1.0 _d 0)
997         else         else
998          cldras = 0.0          cldras = 0.0
999         endif         endif
1000         cldlsp = min( max( cldlsp_lw(i,1,L)*cldlsp_mem,cldls(i,1,L)),1.0)         cldlsp = min( max( cldlsp_lw(i,1,L)*cldlsp_mem,cldls(i,1,L)),
1001         $      1.0 _d 0)
1002    
1003         if( cldras.lt.cldmin ) cldras = 0.0         if( cldras.lt.cldmin ) cldras = 0.0
1004         if( cldlsp.lt.cldmin ) cldlsp = 0.0         if( cldlsp.lt.cldmin ) cldlsp = 0.0
# Line 955  c Compute Time-averaged Cloud and Water Line 1015  c Compute Time-averaged Cloud and Water
1015  c ---------------------------------------------------------------------  c ---------------------------------------------------------------------
1016         watnow = cldwater(i,1,L)         watnow = cldwater(i,1,L)
1017         if( plev.le.500.0 ) then         if( plev.le.500.0 ) then
1018          cldras = min( max(cldras_sw(i,1,L)*cldras_mem, cpen(i,1,L)),1.0)            cldras = min( max(cldras_sw(i,1,L)*cldras_mem, cpen(i,1,L)),
1019         $         1.0 _d 0)
1020         else         else
1021          cldras = 0.0          cldras = 0.0
1022         endif         endif
1023         cldlsp = min( max(cldlsp_sw(i,1,L)*cldlsp_mem,cldls(i,1,L)),1.0)         cldlsp = min( max(cldlsp_sw(i,1,L)*cldlsp_mem,cldls(i,1,L)),
1024         $      1.0 _d 0)
1025    
1026         if( cldras.lt.cldmin ) cldras = 0.0         if( cldras.lt.cldmin ) cldras = 0.0
1027         if( cldlsp.lt.cldmin ) cldlsp = 0.0         if( cldlsp.lt.cldmin ) cldlsp = 0.0
# Line 990  c -------------------------------------- Line 1052  c --------------------------------------
1052        enddo        enddo
1053        enddo        enddo
1054    
1055  c Compute Instantanious Total 2-D Cloud Fraction  c Compute Instantaneous Total 2-D Cloud Fraction
1056  c ----------------------------------------------  c ----------------------------------------------
1057        do j = 1,jm        do j = 1,jm
1058        do i = 1,im        do i = 1,im
# Line 1005  C ************************************** Line 1067  C **************************************
1067  C ***       Fill Cloud Top Pressure and Temperature Diagnostic       ***  C ***       Fill Cloud Top Pressure and Temperature Diagnostic       ***
1068  C **********************************************************************  C **********************************************************************
1069    
1070        if(icldtmp.gt.0) then  #ifdef ALLOW_DIAGNOSTICS
1071        do j = 1,jm        if(diagnostics_is_on('CLDTMP  ',myid) .and.
1072        do i = 1,im       .                 diagnostics_is_on('CTTCNT  ',myid) ) then
1073           if( cldtmp(i,j).gt.0.0 ) then         do j=1,jm
1074           qdiag(i,j,icldtmp,bi,bj) = qdiag(i,j,icldtmp,bi,bj) +         do i=1,im
1075       .                       cldtmp(i,j)*totcld(i,j)/tmpimjm(i,j)          if( cldtmp(i,j).gt.0. ) then              
1076           qdiag(i,j,icttcnt,bi,bj) = qdiag(i,j,icttcnt,bi,bj) +           tmpdiag(i,j) = cldtmp(i,j)*totcld(i,j)/tmpimjm(i,j)
1077       .                                                totcld(i,j)           tmpdiag2(i,j) = totcld(i,j)
1078           endif          else
1079        enddo           tmpdiag(i,j) = 0.
1080        enddo           tmpdiag2(i,j) = 0.
1081            endif
1082           enddo
1083           enddo
1084           call diagnostics_fill(tmpdiag,'CLDTMP  ',0,1,3,bi,bj,myid)
1085           call diagnostics_fill(tmpdiag2,'CTTCNT  ',0,1,3,bi,bj,myid)
1086        endif        endif
1087    
1088        if(icldprs.gt.0) then        if(diagnostics_is_on('CLDPRS  ',myid) .and.
1089        do j = 1,jm       .                 diagnostics_is_on('CTPCNTC ',myid) ) then
1090        do i = 1,im         do j=1,jm
1091           if( cldprs(i,j).gt.0.0 ) then         do i=1,im
1092           qdiag(i,j,icldprs,bi,bj) = qdiag(i,j,icldprs,bi,bj) +          if( cldprs(i,j).gt.0. ) then              
1093       .                       cldprs(i,j)*totcld(i,j)/tmpimjm(i,j)           tmpdiag(i,j) = cldprs(i,j)*totcld(i,j)/tmpimjm(i,j)
1094           qdiag(i,j,ictpcnt,bi,bj) = qdiag(i,j,ictpcnt,bi,bj) +           tmpdiag2(i,j) = totcld(i,j)
1095       .                                                totcld(i,j)          else
1096           endif           tmpdiag(i,j) = 0.
1097        enddo           tmpdiag2(i,j) = 0.
1098        enddo          endif
1099           enddo
1100           enddo
1101           call diagnostics_fill(tmpdiag,'CLDPRS  ',0,1,3,bi,bj,myid)
1102           call diagnostics_fill(tmpdiag2,'CTPCNT  ',0,1,3,bi,bj,myid)
1103        endif        endif
1104    
1105    #endif
1106        
1107  C **********************************************************************  C **********************************************************************
1108  C ****                      INCREMENT COUNTERS                      ****  C ****                      INCREMENT COUNTERS                      ****
# Line 1041  C ************************************** Line 1114  C **************************************
1114         nlwcld   = nlwcld   + 1         nlwcld   = nlwcld   + 1
1115         nswcld   = nswcld   + 1         nswcld   = nswcld   + 1
1116    
        nmoistt  = nmoistt  + 1  
        nmoistq  = nmoistq  + 1  
        npreacc  = npreacc  + 1  
        nprecon  = nprecon  + 1  
   
        ncldmas  = ncldmas  + 1  
        ndtrain  = ndtrain  + 1  
   
        ndtls  = ndtls  + 1  
        ndqls  = ndqls  + 1  
   
1117        RETURN        RETURN
1118        END        END
1119        SUBROUTINE RAS( NN, LEN, LENC, K, NLTOP, nlayr, DT        SUBROUTINE RAS( NN, LNG, LENC, K, NLTOP, nlayr, DT
1120       *,               UOI, ntracer, POI, QOI, PRS, PRJ, rnd, ncrnd       *,      UOI, ntracedim, ntracer, POI, QOI, PRS, PRJ, rnd, ncrnd
1121       *,               RAINS, CLN, CLF, cldmas, detrain       *,      RAINS, CLN, CLF, cldmas, detrain
1122       *,               cp,grav,rkappa,alhl,rhfrac,rasmax )       *,      cp,grav,rkappa,alhl,rhfrac,rasmax )
1123  C  C
1124  C*********************************************************************  C*********************************************************************
1125  C********************* SUBROUTINE  RAS   *****************************  C********************* SUBROUTINE  RAS   *****************************
# Line 1067  C Line 1129  C
1129        implicit none        implicit none
1130    
1131  C Argument List  C Argument List
1132        integer nn,len,lenc,k,nltop,nlayr        integer nn,lng,lenc,k,nltop,nlayr
1133        integer ntracer        integer ntracedim, ntracer
1134        integer ncrnd        integer ncrnd
1135        _RL dt        _RL dt
1136        _RL UOI(len,nlayr,ntracer),   POI(len,K)        _RL UOI(lng,nlayr,ntracedim),   POI(lng,K)
1137        _RL QOI(len,K), PRS(len,K+1), PRJ(len,K+1)        _RL QOI(lng,K), PRS(lng,K+1), PRJ(lng,K+1)
1138        _RL rnd(ncrnd)        _RL rnd(ncrnd)
1139        _RL RAINS(len,K), CLN(len,K), CLF(len,K)        _RL RAINS(lng,K), CLN(lng,K), CLF(lng,K)
1140        _RL cldmas(len,K), detrain(len,K)        _RL cldmas(lng,K), detrain(lng,K)
1141        _RL cp,grav,rkappa,alhl,rhfrac(len),rasmax        _RL cp,grav,rkappa,alhl,rhfrac(lng),rasmax
1142    
1143  C Local Variables  C Local Variables
1144        _RL TCU(len,K), QCU(len,K)        _RL TCU(lng,K), QCU(lng,K)
1145        _RL ucu(len,K,ntracer)        _RL ucu(lng,K,ntracedim)
1146        _RL ALF(len,K), BET(len,K), GAM(len,K)        _RL ALF(lng,K), BET(lng,K), GAM(lng,K)
1147       *,         ETA(len,K), HOI(len,K)       *,         ETA(lng,K), HOI(lng,K)
1148       *,         PRH(len,K), PRI(len,K)       *,         PRH(lng,K), PRI(lng,K)
1149        _RL HST(len,K), QOL(len,K), GMH(len,K)        _RL HST(lng,K), QOL(lng,K), GMH(lng,K)
1150    
1151        _RL TX1(len), TX2(len), TX3(len), TX4(len), TX5(len)        _RL TX1(lng), TX2(lng), TX3(lng), TX4(lng), TX5(lng)
1152       *,         TX6(len), TX7(len), TX8(len), TX9(len)       *,         TX6(lng), TX7(lng), TX8(lng), TX9(lng)
1153       *,         TX11(len), TX12(len), TX13(len), TX14(len,ntracer)       *,         TX11(lng), TX12(lng), TX13(lng), TX14(lng,ntracedim)
1154       *,         TX15(len)       *,         TX15(lng)
1155       *,         WFN(len)       *,         WFN(lng)
1156        integer IA1(len), IA2(len), IA3(len)        integer IA1(lng), IA2(lng), IA3(lng)
1157        _RL cloudn(len), pcu(len)        _RL cloudn(lng), pcu(lng)
1158    
1159        integer krmin,icm        integer krmin,icm
1160        _RL rknob, cmb2pa        _RL rknob, cmb2pa
# Line 1102  C Local Variables Line 1164  C Local Variables
1164        PARAMETER (rknob = 10.)        PARAMETER (rknob = 10.)
1165    
1166        integer IC(ICM),   IRND(icm)        integer IC(ICM),   IRND(icm)
1167        _RL cmass(len,K)        _RL cmass(lng,K)
1168        LOGICAL SETRAS        LOGICAL SETRAS
1169          integer ifound
1170          _RL temp
1171          _RL thbef(lng,K)
1172    
1173        integer i,L,nc,ib,nt        integer i,L,nc,ib,nt
1174        integer km1,kp1,kprv,kcr,kfx,ncmx        integer km1,kp1,kprv,kcr,kfx,ncmx
# Line 1122  C The numerator here is the fraction of Line 1187  C The numerator here is the fraction of
1187  C      allowed to entrain into the cloud  C      allowed to entrain into the cloud
1188    
1189  CCC   FRAC = 1./dt  CCC   FRAC = 1./dt
1190    CCC   FRAC = 0.5/dt
1191        FRAC = 0.5/dt        FRAC = 0.5/dt
1192    
1193        KM1    = K  - 1        KM1    = K  - 1
# Line 1167  c ------------------------------- Line 1233  c -------------------------------
1233        cloudn(i) = 0.0        cloudn(i) = 0.0
1234        enddo        enddo
1235    
1236         CALL CLOUD(nn,LEN, LENC, K, NLTOP, nlayr, IB, RASBLF,SETRAS,FRAC         CALL CLOUD(nn,lng, LENC, K, NLTOP, nlayr, IB, RASBLF,SETRAS,FRAC
1237       *,           CP,  ALHL, RKAPPA, GRAV, P00, CRTMSF       *,           CP,  ALHL, RKAPPA, GRAV, P00, CRTMSF
1238       *,           POI, QOI, UOI, Ntracer, PRS, PRJ       *,           POI, QOI, UOI, ntracedim, Ntracer, PRS, PRJ
1239       *,           PCU, CLOUDN, TCU, QCU, UCU, CMASS       *,           PCU, CLOUDN, TCU, QCU, UCU, CMASS
1240       *,           ALF, BET, GAM, PRH, PRI, HOI, ETA       *,           ALF, BET, GAM, PRH, PRI, HOI, ETA
1241       *,           HST, QOL, GMH       *,           HST, QOL, GMH
# Line 1212  c ***************************** Line 1278  c *****************************
1278    
1279        DO L=IB,K        DO L=IB,K
1280         DO I=1,LENC         DO I=1,LENC
1281            thbef(I,L) = POI(I,L)
1282          POI(I,L) = POI(I,L) + TCU(I,L) * DT * rhfrac(i)          POI(I,L) = POI(I,L) + TCU(I,L) * DT * rhfrac(i)
1283          QOI(I,L) = QOI(I,L) + QCU(I,L) * DT * rhfrac(i)          QOI(I,L) = QOI(I,L) + QCU(I,L) * DT * rhfrac(i)
1284         ENDDO         ENDDO
# Line 1227  c ***************************** Line 1294  c *****************************
1294         rains(I,ib) = rains(I,ib) + PCU(I)*dt * rhfrac(i)         rains(I,ib) = rains(I,ib) + PCU(I)*dt * rhfrac(i)
1295        ENDDO        ENDDO
1296    
1297          do i = 1,lenc
1298           ifound = 0
1299           do L = 1,k
1300            if(tcu(i,L).ne.0.)ifound = ifound + 1
1301           enddo
1302           if(ifound.ne.0) then
1303    c       print *,i,' made a cloud detraining at ',ib
1304            do L = 1,k
1305             temp = TCU(I,L) * DT * rhfrac(i)
1306    c        write(6,122)L,thbef(i,L),poi(i,L),temp
1307            enddo
1308           endif
1309          enddo
1310    
1311    100 CONTINUE    100 CONTINUE
1312    
1313     122  format(' ',i3,' TH B ',e10.3,' TH A ',e10.3,' DTH ',e10.3)
1314    
1315  c Fill Convective Cloud Fractions based on 3-D Rain Amounts  c Fill Convective Cloud Fractions based on 3-D Rain Amounts
1316  c ---------------------------------------------------------  c ---------------------------------------------------------
# Line 1244  c -------------------------------------- Line 1327  c --------------------------------------
1327        implicit none        implicit none
1328        integer n,iras,nrnd,myid        integer n,iras,nrnd,myid
1329        _RL random_numbx        _RL random_numbx
1330        _RL rnd(nrnd)  c     _RL rnd(nrnd)
1331          _RL rnd(*)
1332        integer irm        integer irm
1333        parameter (irm = 1000)        parameter (irm = 1000)
1334        _RL random(irm)        _RL random(irm)
1335        integer i,mcheck,numrand,iseed,index        integer i,mcheck,iseed,indx
1336        logical first        logical first
1337        data    first /.true./        data    first /.true./
1338        integer iras0        integer iras0
1339        data    iras0 /0/        data    iras0 /0/
1340        save random, iras0        save random, iras0
1341    
1342        if(nrnd.eq.0.)then        if(nrnd.eq.0)then
1343         do i = 1,nrnd         do i = 1,nrnd
1344          rnd(i) = 0          rnd(i) = 0
1345         enddo         enddo
1346         if(first .and. myid.eq.0) print *,' NO RANDOM CLOUDS IN RAS '         if(first .and. myid.eq.1) print *,' NO RANDOM CLOUDS IN RAS '
1347         go to 100         go to 100
1348        endif        endif
1349    
1350        mcheck = mod(iras-1,irm/nrnd)        mcheck = mod(iras-1,irm/nrnd)
1351    
1352    c     print *,' RNDCLOUD: first ',first,' iras ',iras,' iras0 ',iras0
1353    c     print *,' RNDCLOUD: irm,nrnd,mcheck=',irm,nrnd,mcheck
1354    
1355          if ( iras.eq.iras0 ) then
1356    C-    Not the 1rst tile: we are all set (already done for the 1rst tile):
1357    c -----------------------------------------------------------------------
1358              indx = (iras-1)*nrnd
1359    
1360  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
1361    c   -- or --
1362    c Multiple Time In But have Used Up all 1000 numbers (MCHECK.EQ.0)
1363  c ----------------------------------------------------------------------------  c ----------------------------------------------------------------------------
1364        if( first.and.(iras.gt.1) .or. iras.ne.iras0+1 )then        elseif ( first.and.(iras.gt.1) .or. mcheck.eq.0 ) then
1365         if( myid.eq.0 ) print *, 'Recreating Rand Numb Array in RNDCLOUD'         iseed = (iras-1-mcheck)*nrnd
        if( myid.eq.0 ) print *, 'IRAS: ',iras,'  IRAS0: ',iras0  
        numrand = mod(iras,irm/nrnd) * nrnd  
        iseed   = iras * nrnd - numrand  
1366         call random_seedx(iseed)         call random_seedx(iseed)
1367         do i = 1,irm         do i = 1,irm
1368          random(i) = random_numbx(iseed)          random(i) = random_numbx(iseed)
1369         enddo         enddo
1370         index = (iras-1)*nrnd         indx = (iras-1)*nrnd
1371    
1372  c Multiple Time In But have Used Up all 1000 numbers (MCHECK.EQ.0)         if( myid.eq.1 ) print *, 'Creating Rand Numb Array in RNDCLOUD'
1373  c ----------------------------------------------------------------       &                        ,', iseed=', iseed
1374        else if (mcheck.eq.0) then         if( myid.eq.1 ) print *, 'IRAS: ',iras,'  IRAS0: ',iras0,
1375            iseed = (iras-1)*nrnd       &    ' indx: ', mod(indx,irm)
           call random_seedx(iseed)  
           do i = 1,irm  
            random(i) = random_numbx(iseed)  
           enddo  
           index = iseed  
1376    
1377  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)
1378  c --------------------------------------------------------------------  c --------------------------------------------------------------------
1379        else        else
1380            index = (iras-1)*nrnd            indx = (iras-1)*nrnd
1381          endif
1382    
1383              indx = mod(indx,irm)
1384          if( indx+nrnd.gt.irm ) then
1385    c       if( myid.eq.1 .AND. iras.ne.iras0 ) print *,
1386    c    &   'reach end of Rand Numb Array in RNDCLOUD',indx,irm-nrnd
1387            indx=irm-nrnd
1388        endif        endif
1389    
           index = mod(index,irm)  
       if( index+nrnd.gt.1000 ) index=1000-nrnd  
   
1390        do n = 1,nrnd        do n = 1,nrnd
1391         rnd(n) = random(index+n)         rnd(n) = random(indx+n)
1392        enddo        enddo
1393    
1394   100  continue   100  continue
1395        first = .false.        first = .false.
1396        iras0 = iras        iras0 = iras
1397    
1398        return        return
1399        end        end
1400        function random_numbx(iseed)        function random_numbx(iseed)
# Line 1311  c -------------------------------------- Line 1402  c --------------------------------------
1402        integer iseed        integer iseed
1403        real *8 seed,port_rand        real *8 seed,port_rand
1404        _RL random_numbx        _RL random_numbx
       random_numbx = 0  
1405  #ifdef CRAY  #ifdef CRAY
1406        _RL ranf        _RL ranf
1407        random_numbx = ranf()        random_numbx = ranf()
# Line 1319  c -------------------------------------- Line 1409  c --------------------------------------
1409  #ifdef SGI  #ifdef SGI
1410        _RL rand        _RL rand
1411        random_numbx = rand()        random_numbx = rand()
1412  #endif  #else
1413          seed = -1.d0
1414        random_numbx = port_rand(seed)        random_numbx = port_rand(seed)
1415  #endif  #endif
1416    #endif
1417        return        return
1418        end        end
1419        subroutine random_seedx (iseed)        subroutine random_seedx (iseed)
1420        implicit none        implicit none
1421        integer  iseed        integer  iseed
1422          real *8 port_rand
1423  #ifdef CRAY  #ifdef CRAY
1424        call ranset (iseed)        call ranset (iseed)
1425  #endif  #else
1426  #ifdef SGI  #ifdef SGI
1427        integer*4   seed        integer*4   seed
1428                    seed = iseed                    seed = iseed
1429        call srand (seed)        call srand (seed)
1430    #else
1431          real*8 tmpRdN
1432          real*8 seed
1433          seed = iseed
1434          tmpRdN = port_rand(seed)
1435    #endif
1436  #endif  #endif
1437        return        return
1438        end        end
1439        SUBROUTINE CLOUD(nn,LEN, LENC, K, NLTOP, nlayr, IC, RASALF        SUBROUTINE CLOUD(nn,lng, LENC, K, NLTOP, nlayr, IC, RASALF
1440       *,                 SETRAS, FRAC       *,                 SETRAS, FRAC
1441       *,                 CP,  ALHL, RKAP, GRAV, P00, CRTMSF       *,                 CP,  ALHL, RKAP, GRAV, P00, CRTMSF
1442       *,                 POI, QOI, UOI, Ntracer, PRS,  PRJ       *,                 POI, QOI, UOI, ntracedim, Ntracer, PRS,  PRJ
1443       *,                 PCU, CLN, TCU, QCU, UCU, CMASS       *,                 PCU, CLN, TCU, QCU, UCU, CMASS
1444       *,                 ALF, BET, GAM, PRH, PRI, HOL, ETA       *,                 ALF, BET, GAM, PRH, PRI, HOL, ETA
1445       *,                 HST, QOL, GMH       *,                 HST, QOL, GMH
# Line 1379  C Line 1478  C
1478  C  Input:  C  Input:
1479  C  ------  C  ------
1480  C  C
1481  C     LEN     : The inner dimension of update and input arrays.  C     lng     : The inner dimension of update and input arrays.
1482  C  C
1483  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.
1484  C               RAS works on the first LENC of the LEN soundings  C               RAS works on the first LENC of the lng soundings
1485  C               passed. This allows working on pieces of the world  C               passed. This allows working on pieces of the world
1486  C               say for multitasking, without declaring temporary arrays  C               say for multitasking, without declaring temporary arrays
1487  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
1488  C               version. An F90 version would have to allow more  C               version. An F90 version would have to allow more
1489  C               flexibility in the argument declarations.  Obviously  C               flexibility in the argument declarations.  Obviously
1490  C               (LENC<=LEN).    C               (LENC<=lng).  
1491  C  C
1492  C     K       : Number of vertical layers (increasing downwards).  C     K       : Number of vertical layers (increasing downwards).
1493  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 1419  C     CRTMSF  : Critical value of mass f Line 1518  C     CRTMSF  : Critical value of mass f
1518  C               the detrainment layer of that cloud-type is assumed.  C               the detrainment layer of that cloud-type is assumed.
1519  C               Affects only cloudiness calculation.  C               Affects only cloudiness calculation.
1520  C  C
1521  C     POI     : 2D array of dimension (LEN,K) containing potential  C     POI     : 2D array of dimension (lng,K) containing potential
1522  C               temperature. Updated but not initialized by RAS.  C               temperature. Updated but not initialized by RAS.
1523  C  C
1524  C     QOI     : 2D array of dimension (LEN,K) containing specific  C     QOI     : 2D array of dimension (lng,K) containing specific
1525  C               humidity. Updated but not initialized by RAS.  C               humidity. Updated but not initialized by RAS.
1526  C  C
1527  C     UOI     : 3D array of dimension (LEN,K,NTRACER) containing tracers  C     UOI     : 3D array of dimension (lng,K,NTRACER) containing tracers
1528  C               Updated but not initialized by RAS.  C               Updated but not initialized by RAS.
1529  C  C
1530  C     PRS     : 2D array of dimension (LEN,K+1) containing pressure  C     PRS     : 2D array of dimension (lng,K+1) containing pressure
1531  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
1532  C               atmosphere to the bottom. Not modified.  C               atmosphere to the bottom. Not modified.
1533  C  C
1534  C     PRJ     : 2D array of dimension (LEN,K+1) containing (PRS/P00) **  C     PRJ     : 2D array of dimension (lng,K+1) containing (PRS/P00) **
1535  C               RKAP.  i.e. Exner function at layer edges. Not modified.  C               RKAP.  i.e. Exner function at layer edges. Not modified.
1536  C  C
1537  C     rhfrac  : 1D array of dimension (LEN) containing a rel.hum. scaling  C     rhfrac  : 1D array of dimension (lng) containing a rel.hum. scaling
1538  C               fraction. Not modified.  C               fraction. Not modified.
1539  C  C
1540  C  Output:  C  Output:
1541  C  -------  C  -------
1542  C  C
1543  C     PCU     : 1D array of length LEN containing accumulated  C     PCU     : 1D array of length lng containing accumulated
1544  C               precipitation in mm/sec.  C               precipitation in mm/sec.
1545  C  C
1546  C     CLN     : 2D array of dimension (LEN,K) containing cloudiness  C     CLN     : 2D array of dimension (lng,K) containing cloudiness
1547  C               Note:  CLN is bumped but NOT initialized  C               Note:  CLN is bumped but NOT initialized
1548  C  C
1549  C     TCU     : 2D array of dimension (LEN,K) containing accumulated  C     TCU     : 2D array of dimension (lng,K) containing accumulated
1550  C               convective heating (K/sec).  C               convective heating (K/sec).
1551  C  C
1552  C     QCU     : 2D array of dimension (LEN,K) containing accumulated  C     QCU     : 2D array of dimension (lng,K) containing accumulated
1553  C               convective drying (kg/kg/sec).  C               convective drying (kg/kg/sec).
1554  C  C
1555  C     CMASS   : 2D array of dimension (LEN,K) containing the  C     CMASS   : 2D array of dimension (lng,K) containing the
1556  C               cloud mass flux (kg/sec). Filled from cloud top  C               cloud mass flux (kg/sec). Filled from cloud top
1557  C               to base.  C               to base.
1558  C  C
# Line 1473  C Line 1572  C
1572  C************************************************************************  C************************************************************************
1573        implicit none        implicit none
1574  C Argument List declarations  C Argument List declarations
1575        integer nn,LEN,LENC,K,NLTOP,nlayr,ic,ntracer        integer nn,lng,LENC,K,NLTOP,nlayr,ic,ntracedim, ntracer
1576        _RL rasalf        _RL rasalf
1577        LOGICAL SETRAS        LOGICAL SETRAS
1578        _RL frac, cp,  alhl, rkap, grav, p00, crtmsf        _RL frac, cp,  alhl, rkap, grav, p00, crtmsf
1579        _RL POI(LEN,K),QOI(LEN,K),PRS(LEN,K+1),PRJ(LEN,K+1)        _RL POI(lng,K),QOI(lng,K),PRS(lng,K+1),PRJ(lng,K+1)
1580        _RL uoi(len,nlayr,ntracer)        _RL uoi(lng,nlayr,ntracedim)
1581        _RL PCU(LENC), CLN(LEN)        _RL PCU(LENC), CLN(lng)
1582        _RL TCU(LEN,K),  QCU(LEN,K),  ucu(len,k,ntracer), CMASS(LEN,K)        _RL TCU(lng,K),QCU(lng,K),ucu(lng,k,ntracedim),CMASS(lng,K)
1583        _RL ALF(LEN,K), BET(LEN,K),  GAM(LEN,K), PRH(LEN,K), PRI(LEN,K)        _RL ALF(lng,K), BET(lng,K),  GAM(lng,K), PRH(lng,K), PRI(lng,K)
1584        _RL HOL(LENC,K), ETA(LENC,K), HST(LENC,K), QOL(LENC,K)        _RL HOL(LENC,K), ETA(LENC,K), HST(LENC,K), QOL(LENC,K)
1585        _RL GMH(LENC,K)        _RL GMH(LENC,K)
1586        _RL TX1(LENC), TX2(LENC), TX3(LENC), TX4(LENC)        _RL TX1(LENC), TX2(LENC), TX3(LENC), TX4(LENC)
1587        _RL TX5(LENC), TX6(LENC), TX7(LENC), TX8(LENC)        _RL TX5(LENC), TX6(LENC), TX7(LENC), TX8(LENC)
1588        _RL ALM(LENC), WFN(LENC), AKM(LENC), QS1(LENC)        _RL ALM(LENC), WFN(LENC), AKM(LENC), QS1(LENC)
1589        _RL WLQ(LENC), CLF(LENC)        _RL WLQ(LENC), CLF(LENC)
1590        _RL uht(len,ntracer)        _RL uht(lng,ntracedim)
1591        integer IA(LENC), I1(LENC),I2(LENC)        integer IA(LENC), I1(LENC),I2(LENC)
1592        _RL      rhfrac(len)        _RL      rhfrac(lng)
1593    
1594  C Local Variables  C Local Variables
1595        _RL daylen,half,one,zero,cmb2pa,rhmax        _RL daylen,half,one,zero,cmb2pa,rhmax
# Line 1500  C Local Variables Line 1599  C Local Variables
1599        _RL rkapp1,onebcp,albcp,onebg,cpbg,twobal        _RL rkapp1,onebcp,albcp,onebg,cpbg,twobal
1600  C  C
1601        integer nt,km1,ic1,i,L,len1,len2,isav,len11,ii        integer nt,km1,ic1,i,L,len1,len2,isav,len11,ii
1602        integer lena,lena1,lenb,tem,tem1        integer lena,lena1,lenb
1603          _RL tem,tem1
1604    
1605  c Explicit Inline Directives  c Explicit Inline Directives
1606  c --------------------------  c --------------------------
# Line 1516  cfpp$ expand (qsat) Line 1616  cfpp$ expand (qsat)
1616        ONEBG  = 1.0  / GRAV        ONEBG  = 1.0  / GRAV
1617        CPBG   = CP   * ONEBG        CPBG   = CP   * ONEBG
1618        TWOBAL = 2.0 / ALHL        TWOBAL = 2.0 / ALHL
1619    
1620  C  C
1621        KM1 = K  - 1        KM1 = K  - 1
1622        IC1 = IC + 1        IC1 = IC + 1
# Line 1549  C Line 1650  C
1650  C  C
1651  C  C
1652        DO 10 L=1,K        DO 10 L=1,K
1653        DO 10 I=1,LEN        DO 10 I=1,lng
1654        TCU(I,L) = 0.0        TCU(I,L) = 0.0
1655        QCU(I,L) = 0.0        QCU(I,L) = 0.0
1656        CMASS(I,L) = 0.0        CMASS(I,L) = 0.0
# Line 1817  C Line 1918  C
1918        DO I=1,LENB        DO I=1,LENB
1919        II = I1(I)        II = I1(I)
1920        TEM    = ETA(I,L) - ETA(I,L+1)        TEM    = ETA(I,L) - ETA(I,L+1)
1921        UHT(I,NT) = UHT(I,NT) + TEM * UOI(II,L+nltop-1,NT)        UHT(I,NT) = UHT(I,NT) + TEM *  UOI(II,L+nltop-1,NT)
1922        ENDDO        ENDDO
1923        ENDDO        ENDDO
1924        ENDDO        ENDDO
# Line 2037  C Line 2138  C
2138  c Compute Tracer Tendencies  c Compute Tracer Tendencies
2139  c -------------------------  c -------------------------
2140        do nt = 1,ntracer        do nt = 1,ntracer
2141    c
2142  c Tracer Tendency at the Bottom Layer  c Tracer Tendency at the Bottom Layer
2143  c -----------------------------------  c -----------------------------------
2144        DO 995 I=1,LENB        DO 995 I=1,LENB
2145        II = I1(I)        II = I1(I)
2146        TEM    = half*TX5(I) * PRI(II,K)        TEM    = half*TX5(I) * PRI(II,K)
2147        TX1(I) = (UOI(II,KM1+nltop-1,nt) - UOI(II,K+nltop-1,nt))        TX1(I) = ( UOI(II,KM1+nltop-1,nt) - UOI(II,K+nltop-1,nt))
2148        ucu(II,K,nt) = TEM * TX1(I)        ucu(II,K,nt) = TEM * TX1(I)
2149    995 CONTINUE    995 CONTINUE
2150    c
2151  c Tracer Tendency at all other Levels  c Tracer Tendency at all other Levels
2152  c -----------------------------------  c -----------------------------------
2153        DO 1020 L=KM1,IC1,-1        DO 1020 L=KM1,IC1,-1
# Line 2075  c ----------------------------------- Line 2176  c -----------------------------------
2176        II = I1(I)        II = I1(I)
2177        ucu(II,IC,nt) = TX1(I)        ucu(II,IC,nt) = TX1(I)
2178   1040 CONTINUE   1040 CONTINUE
2179    
2180        enddo        enddo
2181  C  C
2182  C     PENETRATIVE CONVECTION CALCULATION OVER  C     PENETRATIVE CONVECTION CALCULATION OVER
# Line 2083  C Line 2184  C
2184    
2185        RETURN        RETURN
2186        END        END
2187        SUBROUTINE RNCL(LEN, PL, RNO, CLF)        SUBROUTINE RNCL(lng, PL, RNO, CLF)
2188  C  C
2189  C*********************************************************************  C*********************************************************************
2190  C********************** Relaxed Arakawa-Schubert *********************  C********************** Relaxed Arakawa-Schubert *********************
# Line 2092  C**************************** 23 July 19 Line 2193  C**************************** 23 July 19
2193  C*********************************************************************  C*********************************************************************
2194        implicit none        implicit none
2195  C Argument List declarations  C Argument List declarations
2196        integer len        integer lng
2197        _RL PL(LEN),  RNO(LEN), CLF(LEN)        _RL PL(lng),  RNO(lng), CLF(lng)
2198    
2199  C Local Variables  C Local Variables
2200        _RL p5,p8,pt8,pt2,pfac,p4,p6,p7,p9,cucld,cfac        _RL p5,p8,pt8,pt2,pfac,p4,p6,p7,p9,cucld,cfac
# Line 2105  C Local Variables Line 2206  C Local Variables
2206    
2207        integer i        integer i
2208  C  C
2209        DO 10 I=1,LEN        DO 10 I=1,lng
2210                             rno(i) = 1.0                             rno(i) = 1.0
2211  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 _d 0, 1.0-0.0025*
2212    ccc  &                                 (400.0-pl(i)) )
2213    
2214  ccc   IF ( PL(I).GE.P7 .AND. PL(I).LE.P9 ) THEN  ccc   IF ( PL(I).GE.P7 .AND. PL(I).LE.P9 ) THEN
2215  ccc     RNO(I) = ((P9-PL(I))/(P9-P7)) **2  ccc     RNO(I) = ((P9-PL(I))/(P9-P7)) **2
# Line 2132  CARIES Line 2234  CARIES
2234  C  C
2235        RETURN        RETURN
2236        END        END
2237        SUBROUTINE ACRITN ( LEN,PL,PLB,ACR )        SUBROUTINE ACRITN ( lng,PL,PLB,ACR )
2238    
2239  C*********************************************************************  C*********************************************************************
2240  C********************** Relaxed Arakawa-Schubert *********************  C********************** Relaxed Arakawa-Schubert *********************
# Line 2145  C**** Line 2247  C****
2247  C*********************************************************************  C*********************************************************************
2248        implicit none        implicit none
2249  C Argument List declarations  C Argument List declarations
2250        integer len        integer lng
2251        _RL PL(LEN), PLB(LEN), ACR(LEN)        _RL PL(lng), PLB(lng), ACR(lng)
2252    
2253  C Local variables  C Local variables
2254        integer lma        integer lma
# Line 2168  C Local variables Line 2270  C Local variables
2270    
2271    
2272        do L=1,lma-1        do L=1,lma-1
2273        do i=1,len        do i=1,lng
2274           if( pl(i).ge.p(L)   .and.           if( pl(i).ge.p(L)   .and.
2275       .       pl(i).le.p(L+1)) then       .       pl(i).le.p(L+1)) then
2276           temp = ( pl(i)-p(L) )/( p(L+1)-p(L) )           temp = ( pl(i)-p(L) )/( p(L+1)-p(L) )
# Line 2177  C Local variables Line 2279  C Local variables
2279        enddo        enddo
2280        enddo        enddo
2281    
2282        do i=1,len        do i=1,lng
2283        if( pl(i).lt.p(1)   ) acr(i) = a(1)        if( pl(i).lt.p(1)   ) acr(i) = a(1)
2284        if( pl(i).gt.p(lma) ) acr(i) = a(lma)        if( pl(i).gt.p(lma) ) acr(i) = a(lma)
2285        enddo        enddo
2286    
2287        do i=1,len        do i=1,lng
2288        acr(i) = acr(i) * (plb(i)-pl(i))        acr(i) = acr(i) * (plb(i)-pl(i))
2289        enddo        enddo
2290    
# Line 2376  C*************************************** Line 2478  C***************************************
2478             if( rhcrit(i,L).eq.1.0 ) then             if( rhcrit(i,L).eq.1.0 ) then
2479             fact = 1.0             fact = 1.0
2480             else             else
2481             fact = min( 1.0, alpha + (1.0-alpha)*( rh-rhcrit(i,L)) /             fact = min( 1.0 _d 0, alpha + (1.0-alpha)*( rh-rhcrit(i,L)) /
2482       1                                          (1.0-rhcrit(i,L)) )       1                                          (1.0-rhcrit(i,L)) )
2483             endif             endif
2484    
# Line 2482  cfpp$ expand (qsat) Line 2584  cfpp$ expand (qsat)
2584        ratio  = alpha*(rh-rhcrit)/offset        ratio  = alpha*(rh-rhcrit)/offset
2585    
2586        if(cloud(i,L).eq.  0.0 .and. ratio.gt.0.0 ) then        if(cloud(i,L).eq.  0.0 .and. ratio.gt.0.0 ) then
2587           cloud(i,L) = min( ratio,1.0 )           cloud(i,L) = min( ratio,1.0 _d 0)
2588        endif        endif
2589    
2590        enddo        enddo
# Line 2525  c -------------------------------------- Line 2627  c --------------------------------------
2627       .    / ( 2+(1+1.608*cpoel*t)*elocp*dqsdt )       .    / ( 2+(1+1.608*cpoel*t)*elocp*dqsdt )
2628    
2629        s = ( (k-krd)/(kmm-krd) )        s = ( (k-krd)/(kmm-krd) )
2630        f = 1.0 - min( 1.0, max(0.0,1.0-exp(-s)) )        f = 1.0 - min( 1.0 _d 0, max(0.0 _d 0,1.0-exp(-s)) )
2631    
2632        cldfrc(i,L) = cldfrc(i,L)*f        cldfrc(i,L) = cldfrc(i,L)*f
2633        cldwat(i,L) = cldwat(i,L)*f        cldwat(i,L) = cldwat(i,L)*f
Legend:
Removed from v.1.13  
changed lines
  Added in v.1.35
  ViewVC Help
Powered by ViewVC 1.1.22