/[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.18 by molod, Wed Sep 1 22:42:18 2004 UTC revision 1.30 by molod, Wed Mar 9 23:25:18 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 16  C $Name$ Line 16  C $Name$
16    
17  #ifdef ALLOW_DIAGNOSTICS  #ifdef ALLOW_DIAGNOSTICS
18  #include "SIZE.h"  #include "SIZE.h"
19  #include "diagnostics_SIZE.h"  #include "DIAGNOSTICS_SIZE.h"
20  #include "diagnostics.h"  #include "DIAGNOSTICS.h"
21  #endif  #endif
22    
23  c Input Variables  c Input Variables
24  c ---------------  c ---------------
25        integer im,jm,lm        integer im,jm,lm
26        integer ndmoist,istrip,npcs        integer ndmoist,istrip,npcs
27        integer bi,bj,ntracer,ptracer                integer bi,bj,ntracerin,ptracer        
28        integer lowlevel,midlevel,nltop,nsubmin,nsubmax,Lup        integer lowlevel,midlevel,nltop,nsubmin,nsubmax,Lup
29        _RL pz(im,jm),plz(im,jm,lm),plze(im,jm,lm+1),dpres(im,jm,lm)        _RL pz(im,jm),plz(im,jm,lm),plze(im,jm,lm+1),dpres(im,jm,lm)
30        _RL pkht(im,jm,lm+1),pkl(im,jm,lm)        _RL pkht(im,jm,lm+1),pkl(im,jm,lm)
31        _RL tz(im,jm,lm),qz(im,jm,lm,ntracer)              _RL tz(im,jm,lm),qz(im,jm,lm,ntracerin)      
32          _RL uz(im,jm,lm),vz(im,jm,lm)      
33        _RL qqz(im,jm,lm)        _RL qqz(im,jm,lm)
34        _RL dumoist(im,jm,lm),dvmoist(im,jm,lm)        _RL dumoist(im,jm,lm),dvmoist(im,jm,lm)
35        _RL dtmoist(im,jm,lm),dqmoist(im,jm,lm,ntracer)        _RL dtmoist(im,jm,lm),dqmoist(im,jm,lm,ntracerin)
36          logical cumfric
37        _RL ptop        _RL ptop
38        integer iras        integer iras
39        _RL rainlsp(im,jm),rainconv(im,jm),snowfall(im,jm)        _RL rainlsp(im,jm),rainconv(im,jm),snowfall(im,jm)
# Line 88  c -------------------------------------- Line 90  c --------------------------------------
90        _RL    tmpgather(im*jm,lm)        _RL    tmpgather(im*jm,lm)
91        _RL   deltgather(im*jm,lm)        _RL   deltgather(im*jm,lm)
92        _RL   delqgather(im*jm,lm)        _RL   delqgather(im*jm,lm)
93        _RL      ugather(im*jm,lm,ntracer)        _RL      ugather(im*jm,lm,ntracerin+2-ptracer)
94        _RL   delugather(im*jm,lm,ntracer)        _RL   delugather(im*jm,lm,ntracerin+2-ptracer)
95        _RL     deltrnev(im*jm,lm)        _RL     deltrnev(im*jm,lm)
96        _RL     delqrnev(im*jm,lm)        _RL     delqrnev(im*jm,lm)
97    
# Line 101  c Stripped Arrays Line 103  c Stripped Arrays
103  c ---------------  c ---------------
104        _RL saveth (istrip,lm)        _RL saveth (istrip,lm)
105        _RL saveq  (istrip,lm)        _RL saveq  (istrip,lm)
106        _RL saveu  (istrip,lm,ntracer)        _RL saveu  (istrip,lm,ntracerin+2-ptracer)
107        _RL usubcl (istrip,   ntracer)        _RL usubcl (istrip,   ntracerin+2-ptracer)
108    
109        _RL     ple(istrip,lm+1)        _RL     ple(istrip,lm+1)
110        _RL      dp(istrip,lm)        _RL      dp(istrip,lm)
# Line 111  c --------------- Line 113  c ---------------
113        _RL    PLKE(ISTRIP,lm+1)        _RL    PLKE(ISTRIP,lm+1)
114        _RL      TH(ISTRIP,lm)  ,CVTH(ISTRIP,lm)        _RL      TH(ISTRIP,lm)  ,CVTH(ISTRIP,lm)
115        _RL   CVQ(ISTRIP,lm)        _RL   CVQ(ISTRIP,lm)
116        _RL      UL(ISTRIP,lm,ntracer)        _RL      UL(ISTRIP,lm,ntracerin+2-ptracer)
117        _RL     cvu(istrip,lm,ntracer)        _RL     cvu(istrip,lm,ntracerin+2-ptracer)
118        _RL  CLMAXO(ISTRIP,lm),CLBOTH(ISTRIP,lm)        _RL  CLMAXO(ISTRIP,lm),CLBOTH(ISTRIP,lm)
119        _RL  CLSBTH(ISTRIP,lm)        _RL  CLSBTH(ISTRIP,lm)
120        _RL    TMP1(ISTRIP,lm),  TMP2(ISTRIP,lm)        _RL    TMP1(ISTRIP,lm),  TMP2(ISTRIP,lm)
# Line 144  c --------------- Line 146  c ---------------
146        _RL tmstp,tminv,sday,grav,alhl,cp,elocp,gamfac        _RL tmstp,tminv,sday,grav,alhl,cp,elocp,gamfac
147        _RL rkappa,p0kappa,p0kinv,ptopkap,pcheck        _RL rkappa,p0kappa,p0kinv,ptopkap,pcheck
148        _RL tice,getcon,pi        _RL tice,getcon,pi
149        integer ntracedim        integer ntracer,ntracedim, ntracex
150    
151  C **********************************************************************  C **********************************************************************
152  C ****                     INITIALIZATION                           ****  C ****                     INITIALIZATION                           ****
153  C **********************************************************************  C **********************************************************************
154    
155    C Add U and V components to tracer array for cumulus friction
156    
157          if(cumfric) then
158           ntracer = ntracerin + 2
159          else
160           ntracer = ntracerin
161          endif
162        ntracedim= max(ntracer-ptracer,1)        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 188  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.1) 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 262  c -------------------------------------- Line 272  c --------------------------------------
272           dpgather(indx,L) = dpres(pblindex(indx),1,L)           dpgather(indx,L) = dpres(pblindex(indx),1,L)
273         enddo         enddo
274        enddo        enddo
275  c     do nt = 1,ntracer-ptracer  C General Tracers
276  c     do L = 1,lm  C----------------
277  c      do indx = 1,im*jm        do nt = 1,ntracerin-ptracer
278  c       ugather(indx,L,nt) = qz(pblindex(indx),1,L,nt+ptracer)        do L = 1,lm
279  c      enddo         do indx = 1,im*jm
280  c     enddo          ugather(indx,L,nt) = qz(pblindex(indx),1,L,nt+ptracer)
281  c     enddo         enddo
282          enddo
283          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 --------------------------------------------------
# Line 282  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 310  C ************************************** Line 336  C **************************************
336         CALL STRIP (  shgather, SHL     ,im*jm,ISTRIP,lm,NN )         CALL STRIP (  shgather, SHL     ,im*jm,ISTRIP,lm,NN )
337         CALL STRINT( levgather, pbl     ,im*jm,ISTRIP,1 ,NN )         CALL STRINT( levgather, pbl     ,im*jm,ISTRIP,1 ,NN )
338    
339  c      do nt = 1,ntracer-ptracer         do nt = 1,ntracer-ptracer
340  c      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  c      enddo         enddo
342    
343  C **********************************************************************  C **********************************************************************
344  C ****        SETUP FOR RAS CUMULUS PARAMETERIZATION                ****  C ****        SETUP FOR RAS CUMULUS PARAMETERIZATION                ****
# Line 344  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 377  c -------------------------------------- Line 402  c --------------------------------------
402    
403  c Save initial value of tracers and compute sub-cloud value  c Save initial value of tracers and compute sub-cloud value
404  c ---------------------------------------------------------  c ---------------------------------------------------------
405  c      DO NT = 1,ntracer-ptracer         DO NT = 1,ntracer-ptracer
406  c         do  L = 1,lm            do  L = 1,lm
407  c         do  i = num,num+nindeces(nsubcl)-1            do  i = num,num+nindeces(nsubcl)-1
408  c         saveu(i,L,nt) = ul(i,L,nt)            saveu(i,L,nt) = ul(i,L,nt)
409  c         enddo            enddo
410  c         enddo            enddo
411  c         DO I=num,num+nindeces(nsubcl)-1            DO I=num,num+nindeces(nsubcl)-1
412  c         TMP1(I,2) = 0.            TMP1(I,2) = 0.
413  c         ENDDO            ENDDO
414  c         DO L=NSUBCL,lm            DO L=NSUBCL,lm
415  c         DO I=num,num+nindeces(nsubcl)-1            DO I=num,num+nindeces(nsubcl)-1
416  c          TMP1(I,2) = TMP1(I,2)+(PLE(I,L+1)-PLE(I,L))*UL(I,L,NT)/sp(i)             TMP1(I,2) = TMP1(I,2)+(PLE(I,L+1)-PLE(I,L))*UL(I,L,NT)/sp(i)
417  c         ENDDO            ENDDO
418  c         ENDDO            ENDDO
419  c         DO I=num,num+nindeces(nsubcl)-1            DO I=num,num+nindeces(nsubcl)-1
420  c         UL(I,NSUBCL,NT) = TMP1(I,2)*TMP1(I,4)            UL(I,NSUBCL,NT) = TMP1(I,2)*TMP1(I,4)
421  c            usubcl(i,nt) = ul(i,nsubcl,nt)               usubcl(i,nt) = ul(i,nsubcl,nt)
422  c         ENDDO            ENDDO
423  c      ENDDO         ENDDO
424    
425  c Compute Pressure Arrays for RAS  c Compute Pressure Arrays for RAS
426  c -------------------------------  c -------------------------------
# Line 480  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),ntracedim,TH(num,NLTOP),SHL(num,NLTOP)       1, UL(num,1,1),ntracedim,ntracex,TH(num,NLTOP),SHL(num,NLTOP)
509       2, TMP4(num,NLTOP), TMP5(num,NLTOP),rnd, ncrnd, PCPEN(num,NLTOP)       2, TMP4(num,NLTOP), TMP5(num,NLTOP),rnd, ncrnd, PCPEN(num,NLTOP)
510       3, CLBOTH(num,NLTOP), CLFRAC(num,NLTOP)       3, CLBOTH(num,NLTOP), CLFRAC(num,NLTOP)
511       4, cldmas(num,nltop), detrain(num,nltop)       4, cldmas(num,nltop), detrain(num,nltop)
# Line 525  c ------------------------------------ Line 550  c ------------------------------------
550    
551  c Compute Tracer Tendency due to RAS  c Compute Tracer Tendency due to RAS
552  c ----------------------------------  c ----------------------------------
553  c      do nt = 1,ntracer-ptracer         do nt = 1,ntracer-ptracer
554  c       DO L=1,nsubcl-1          DO L=1,nsubcl-1
555  c       DO I=num,num+nindeces(nsubcl)-1          DO I=num,num+nindeces(nsubcl)-1
556  c        CVU(I,L,nt) = ( UL(I,L,nt)-saveu(i,l,nt) )*sp(i)*tminv           CVU(I,L,nt) = ( UL(I,L,nt)-saveu(i,l,nt) )*sp(i)*tminv
557  c       ENDDO          ENDDO
558  c       ENDDO          ENDDO
559  c       DO L=nsubcl,lm          DO L=nsubcl,lm
560  c       DO I=num,num+nindeces(nsubcl)-1          DO I=num,num+nindeces(nsubcl)-1
561  c        if( usubcl(i,nt).ne.0.0 ) then           if( usubcl(i,nt).ne.0.0 ) then
562  c         cvu(i,L,nt) = ( ul(i,nsubcl,nt)-usubcl(i,nt) ) *            cvu(i,L,nt) = ( ul(i,nsubcl,nt)-usubcl(i,nt) ) *
563  c    .                     ( saveu(i,L,nt)/usubcl(i,nt) )*sp(i)*tminv       .                     ( saveu(i,L,nt)/usubcl(i,nt) )*sp(i)*tminv
564  c        else           else
565  c         cvu(i,L,nt) = 0.0            cvu(i,L,nt) = 0.0
566  c        endif           endif
567  c       ENDDO          ENDDO
568  c       ENDDO          ENDDO
569  c      enddo         enddo
570    
571  c Compute Diagnostic PSUBCLD (Subcloud Layer Pressure)  c Compute Diagnostic PSUBCLD (Subcloud Layer Pressure)
572  c ----------------------------------------------------  c ----------------------------------------------------
# Line 572  C ************************************** Line 597  C **************************************
597    
598        call paste( CVTH,deltgather,istrip,im*jm,lm,NN )        call paste( CVTH,deltgather,istrip,im*jm,lm,NN )
599        call paste(  CVQ,delqgather,istrip,im*jm,lm,NN )        call paste(  CVQ,delqgather,istrip,im*jm,lm,NN )
600  c     do nt = 1,ntracer-ptracer        do nt = 1,ntracer-ptracer
601  c     call paste( CVU(1,1,nt),delugather(1,1,nt),istrip,im*jm,lm,NN )        call paste( CVU(1,1,nt),delugather(1,1,nt),istrip,im*jm,lm,NN )
602  c     enddo        enddo
603    
604  C **********************************************************************  C **********************************************************************
605  C     And now paste some arrays for filling diagnostics  C     And now paste some arrays for filling diagnostics
# Line 764  c ------------ Line 789  c ------------
789       .                                              cldsr(1,1,L),im*jm)       .                                              cldsr(1,1,L),im*jm)
790        enddo        enddo
791    
792  c Tracers  c General Tracers
793  c -------  c ---------------
794  c     do nt = 1,ntracer-ptracer        do nt = 1,ntracerin-ptracer
795  c      do L = 1,lm         do L = 1,lm
796  c      call back2grd (delugather(1,L,nt),pblindex,         call back2grd (delugather(1,L,nt),pblindex,
797  c    .                                 dqmoist(1,1,L,ptracer+nt),im*jm)       .                                 dqmoist(1,1,L,ptracer+nt),im*jm)
798  c      enddo         enddo
799  c     enddo        enddo
800    
801          if(cumfric) then
802    
803    c U and V for cumulus friction
804    c ----------------------------
805          do L = 1,lm
806           call back2grd (delugather(1,L,ntracerin-ptracer+1),pblindex,
807         .                                 dumoist(1,1,L),im*jm)
808           call back2grd (delugather(1,L,ntracerin-ptracer+2),pblindex,
809         .                                 dvmoist(1,1,L),im*jm)
810          enddo
811    
812    C Remove pi-weighting for u and v tendencies
813          do j = 1,jm
814          do i = 1,im
815           tmpimjm(i,j) = 1./pz(i,j)
816          enddo
817          enddo
818          do L = 1,lm
819          do j = 1,jm
820          do i = 1,im
821           dumoist(i,j,L) = dumoist(i,j,L) * tmpimjm(i,j)
822           dvmoist(i,j,L) = dvmoist(i,j,L) * tmpimjm(i,j)
823          enddo
824          enddo
825          enddo
826    
827    
828          endif
829    
830  C **********************************************************************  C **********************************************************************
831  C                          BUMP DIAGNOSTICS  C                          BUMP DIAGNOSTICS
# Line 1013  c -------------------------------------- Line 1066  c --------------------------------------
1066        enddo        enddo
1067        enddo        enddo
1068    
1069  c Compute Instantanious Total 2-D Cloud Fraction  c Compute Instantaneous Total 2-D Cloud Fraction
1070  c ----------------------------------------------  c ----------------------------------------------
1071        do j = 1,jm        do j = 1,jm
1072        do i = 1,im        do i = 1,im
# Line 1076  C ************************************** Line 1129  C **************************************
1129    
1130         ndtls  = ndtls  + 1         ndtls  = ndtls  + 1
1131         ndqls  = ndqls  + 1         ndqls  = ndqls  + 1
1132    
1133           nudiag1  = nudiag1  + 1
1134           nudiag2  = nudiag2  + 1
1135    
1136         endif         endif
1137  #endif  #endif
1138    
1139        RETURN        RETURN
1140        END        END
1141        SUBROUTINE RAS( NN, LNG, LENC, K, NLTOP, nlayr, DT        SUBROUTINE RAS( NN, LNG, LENC, K, NLTOP, nlayr, DT
1142       *,               UOI, ntracer, POI, QOI, PRS, PRJ, rnd, ncrnd       *,      UOI, ntracedim, ntracer, POI, QOI, PRS, PRJ, rnd, ncrnd
1143       *,               RAINS, CLN, CLF, cldmas, detrain       *,      RAINS, CLN, CLF, cldmas, detrain
1144       *,               cp,grav,rkappa,alhl,rhfrac,rasmax )       *,      cp,grav,rkappa,alhl,rhfrac,rasmax )
1145  C  C
1146  C*********************************************************************  C*********************************************************************
1147  C********************* SUBROUTINE  RAS   *****************************  C********************* SUBROUTINE  RAS   *****************************
# Line 1095  C Line 1152  C
1152    
1153  C Argument List  C Argument List
1154        integer nn,lng,lenc,k,nltop,nlayr        integer nn,lng,lenc,k,nltop,nlayr
1155        integer ntracer        integer ntracedim, ntracer
1156        integer ncrnd        integer ncrnd
1157        _RL dt        _RL dt
1158        _RL UOI(lng,nlayr,ntracer),   POI(lng,K)        _RL UOI(lng,nlayr,ntracedim),   POI(lng,K)
1159        _RL QOI(lng,K), PRS(lng,K+1), PRJ(lng,K+1)        _RL QOI(lng,K), PRS(lng,K+1), PRJ(lng,K+1)
1160        _RL rnd(ncrnd)        _RL rnd(ncrnd)
1161        _RL RAINS(lng,K), CLN(lng,K), CLF(lng,K)        _RL RAINS(lng,K), CLN(lng,K), CLF(lng,K)
# Line 1107  C Argument List Line 1164  C Argument List
1164    
1165  C Local Variables  C Local Variables
1166        _RL TCU(lng,K), QCU(lng,K)        _RL TCU(lng,K), QCU(lng,K)
1167        _RL ucu(lng,K,ntracer)        _RL ucu(lng,K,ntracedim)
1168        _RL ALF(lng,K), BET(lng,K), GAM(lng,K)        _RL ALF(lng,K), BET(lng,K), GAM(lng,K)
1169       *,         ETA(lng,K), HOI(lng,K)       *,         ETA(lng,K), HOI(lng,K)
1170       *,         PRH(lng,K), PRI(lng,K)       *,         PRH(lng,K), PRI(lng,K)
# Line 1115  C Local Variables Line 1172  C Local Variables
1172    
1173        _RL TX1(lng), TX2(lng), TX3(lng), TX4(lng), TX5(lng)        _RL TX1(lng), TX2(lng), TX3(lng), TX4(lng), TX5(lng)
1174       *,         TX6(lng), TX7(lng), TX8(lng), TX9(lng)       *,         TX6(lng), TX7(lng), TX8(lng), TX9(lng)
1175       *,         TX11(lng), TX12(lng), TX13(lng), TX14(lng,ntracer)       *,         TX11(lng), TX12(lng), TX13(lng), TX14(lng,ntracedim)
1176       *,         TX15(lng)       *,         TX15(lng)
1177       *,         WFN(lng)       *,         WFN(lng)
1178        integer IA1(lng), IA2(lng), IA3(lng)        integer IA1(lng), IA2(lng), IA3(lng)
# Line 1131  C Local Variables Line 1188  C Local Variables
1188        integer IC(ICM),   IRND(icm)        integer IC(ICM),   IRND(icm)
1189        _RL cmass(lng,K)        _RL cmass(lng,K)
1190        LOGICAL SETRAS        LOGICAL SETRAS
1191          integer ifound
1192          _RL temp
1193          _RL thbef(lng,K)
1194    
1195        integer i,L,nc,ib,nt        integer i,L,nc,ib,nt
1196        integer km1,kp1,kprv,kcr,kfx,ncmx        integer km1,kp1,kprv,kcr,kfx,ncmx
# Line 1149  C The numerator here is the fraction of Line 1209  C The numerator here is the fraction of
1209  C      allowed to entrain into the cloud  C      allowed to entrain into the cloud
1210    
1211  CCC   FRAC = 1./dt  CCC   FRAC = 1./dt
1212    CCC   FRAC = 0.5/dt
1213        FRAC = 0.5/dt        FRAC = 0.5/dt
1214    
1215        KM1    = K  - 1        KM1    = K  - 1
# Line 1196  c ------------------------------- Line 1257  c -------------------------------
1257    
1258         CALL CLOUD(nn,lng, LENC, K, NLTOP, nlayr, IB, RASBLF,SETRAS,FRAC         CALL CLOUD(nn,lng, LENC, K, NLTOP, nlayr, IB, RASBLF,SETRAS,FRAC
1259       *,           CP,  ALHL, RKAPPA, GRAV, P00, CRTMSF       *,           CP,  ALHL, RKAPPA, GRAV, P00, CRTMSF
1260       *,           POI, QOI, UOI, Ntracer, PRS, PRJ       *,           POI, QOI, UOI, ntracedim, Ntracer, PRS, PRJ
1261       *,           PCU, CLOUDN, TCU, QCU, UCU, CMASS       *,           PCU, CLOUDN, TCU, QCU, UCU, CMASS
1262       *,           ALF, BET, GAM, PRH, PRI, HOI, ETA       *,           ALF, BET, GAM, PRH, PRI, HOI, ETA
1263       *,           HST, QOL, GMH       *,           HST, QOL, GMH
# Line 1239  c ***************************** Line 1300  c *****************************
1300    
1301        DO L=IB,K        DO L=IB,K
1302         DO I=1,LENC         DO I=1,LENC
1303            thbef(I,L) = POI(I,L)
1304          POI(I,L) = POI(I,L) + TCU(I,L) * DT * rhfrac(i)          POI(I,L) = POI(I,L) + TCU(I,L) * DT * rhfrac(i)
1305          QOI(I,L) = QOI(I,L) + QCU(I,L) * DT * rhfrac(i)          QOI(I,L) = QOI(I,L) + QCU(I,L) * DT * rhfrac(i)
1306         ENDDO         ENDDO
1307        ENDDO        ENDDO
1308  c     DO NT=1,Ntracer        DO NT=1,Ntracer
1309  c     DO L=IB,K        DO L=IB,K
1310  c      DO I=1,LENC         DO I=1,LENC
1311  c       UOI(I,L+nltop-1,NT)=UOI(I,L+nltop-1,NT)+UCU(I,L,NT)*DT*rhfrac(i)          UOI(I,L+nltop-1,NT)=UOI(I,L+nltop-1,NT)+UCU(I,L,NT)*DT*rhfrac(i)
1312  c      ENDDO         ENDDO
1313  c     ENDDO        ENDDO
1314  c     ENDDO        ENDDO
1315        DO I=1,LENC        DO I=1,LENC
1316         rains(I,ib) = rains(I,ib) + PCU(I)*dt * rhfrac(i)         rains(I,ib) = rains(I,ib) + PCU(I)*dt * rhfrac(i)
1317        ENDDO        ENDDO
1318    
1319          do i = 1,lenc
1320           ifound = 0
1321           do L = 1,k
1322            if(tcu(i,L).ne.0.)ifound = ifound + 1
1323           enddo
1324           if(ifound.ne.0) then
1325    c       print *,i,' made a cloud detraining at ',ib
1326            do L = 1,k
1327             temp = TCU(I,L) * DT * rhfrac(i)
1328    c        write(6,122)L,thbef(i,L),poi(i,L),temp
1329            enddo
1330           endif
1331          enddo
1332    
1333    100 CONTINUE    100 CONTINUE
1334    
1335     122  format(' ',i3,' TH B ',e10.3,' TH A ',e10.3,' DTH ',e10.3)
1336    
1337  c Fill Convective Cloud Fractions based on 3-D Rain Amounts  c Fill Convective Cloud Fractions based on 3-D Rain Amounts
1338  c ---------------------------------------------------------  c ---------------------------------------------------------
# Line 1271  c -------------------------------------- Line 1349  c --------------------------------------
1349        implicit none        implicit none
1350        integer n,iras,nrnd,myid        integer n,iras,nrnd,myid
1351        _RL random_numbx        _RL random_numbx
1352        _RL rnd(nrnd)  c     _RL rnd(nrnd)
1353          _RL rnd(*)
1354        integer irm        integer irm
1355        parameter (irm = 1000)        parameter (irm = 1000)
1356        _RL random(irm)        _RL random(irm)
1357        integer i,mcheck,numrand,iseed,indx        integer i,mcheck,iseed,indx
1358        logical first        logical first
1359        data    first /.true./        data    first /.true./
1360        integer iras0        integer iras0
1361        data    iras0 /0/        data    iras0 /0/
1362        save random, iras0        save random, iras0
1363    
1364        if(nrnd.eq.0.)then        if(nrnd.eq.0)then
1365         do i = 1,nrnd         do i = 1,nrnd
1366          rnd(i) = 0          rnd(i) = 0
1367         enddo         enddo
# Line 1292  c -------------------------------------- Line 1371  c --------------------------------------
1371    
1372        mcheck = mod(iras-1,irm/nrnd)        mcheck = mod(iras-1,irm/nrnd)
1373    
1374    c     print *,' RNDCLOUD: first ',first,' iras ',iras,' iras0 ',iras0
1375    c     print *,' RNDCLOUD: irm,nrnd,mcheck=',irm,nrnd,mcheck
1376    
1377          if ( iras.eq.iras0 ) then
1378    C-    Not the 1rst tile: we are all set (already done for the 1rst tile):
1379    c -----------------------------------------------------------------------
1380              indx = (iras-1)*nrnd
1381    
1382  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
1383    c   -- or --
1384    c Multiple Time In But have Used Up all 1000 numbers (MCHECK.EQ.0)
1385  c ----------------------------------------------------------------------------  c ----------------------------------------------------------------------------
1386        if( first.and.(iras.gt.1) .or. iras.ne.iras0+1 )then        elseif ( first.and.(iras.gt.1) .or. mcheck.eq.0 ) then
1387         print *,' first ',first,' iras ',iras,' iras0 ',iras0         iseed = (iras-1-mcheck)*nrnd
        if( myid.eq.1 ) print *, 'Recreating Rand Numb Array in RNDCLOUD'  
        if( myid.eq.1 ) print *, 'IRAS: ',iras,'  IRAS0: ',iras0  
        numrand = mod(iras,irm/nrnd) * nrnd  
        iseed   = iras * nrnd - numrand  
1388         call random_seedx(iseed)         call random_seedx(iseed)
1389         do i = 1,irm         do i = 1,irm
1390          random(i) = random_numbx(iseed)          random(i) = random_numbx(iseed)
1391         enddo         enddo
1392         indx = (iras-1)*nrnd         indx = (iras-1)*nrnd
1393    
1394  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'
1395  c ----------------------------------------------------------------       &                        ,', iseed=', iseed
1396        else if (mcheck.eq.0) then         if( myid.eq.1 ) print *, 'IRAS: ',iras,'  IRAS0: ',iras0,
1397            iseed = (iras-1)*nrnd       &    ' indx: ', mod(indx,irm)
           call random_seedx(iseed)  
           do i = 1,irm  
            random(i) = random_numbx(iseed)  
           enddo  
           indx = iseed  
1398    
1399  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)
1400  c --------------------------------------------------------------------  c --------------------------------------------------------------------
# Line 1323  c -------------------------------------- Line 1403  c --------------------------------------
1403        endif        endif
1404    
1405            indx = mod(indx,irm)            indx = mod(indx,irm)
1406        if( indx+nrnd.gt.1000 ) indx=1000-nrnd        if( indx+nrnd.gt.irm ) then
1407    c       if( myid.eq.1 .AND. iras.ne.iras0 ) print *,
1408    c    &   'reach end of Rand Numb Array in RNDCLOUD',indx,irm-nrnd
1409            indx=irm-nrnd
1410          endif
1411    
1412        do n = 1,nrnd        do n = 1,nrnd
1413         rnd(n) = random(indx+n)         rnd(n) = random(indx+n)
1414        enddo        enddo
# Line 1332  c -------------------------------------- Line 1416  c --------------------------------------
1416   100  continue   100  continue
1417        first = .false.        first = .false.
1418        iras0 = iras        iras0 = iras
1419    
1420        return        return
1421        end        end
1422        function random_numbx(iseed)        function random_numbx(iseed)
# Line 1339  c -------------------------------------- Line 1424  c --------------------------------------
1424        integer iseed        integer iseed
1425        real *8 seed,port_rand        real *8 seed,port_rand
1426        _RL random_numbx        _RL random_numbx
       random_numbx = 0  
1427  #ifdef CRAY  #ifdef CRAY
1428        _RL ranf        _RL ranf
1429        random_numbx = ranf()        random_numbx = ranf()
# Line 1347  c -------------------------------------- Line 1431  c --------------------------------------
1431  #ifdef SGI  #ifdef SGI
1432        _RL rand        _RL rand
1433        random_numbx = rand()        random_numbx = rand()
1434  #endif  #else
1435          seed = -1.d0
1436        random_numbx = port_rand(seed)        random_numbx = port_rand(seed)
1437  #endif  #endif
1438    #endif
1439        return        return
1440        end        end
1441        subroutine random_seedx (iseed)        subroutine random_seedx (iseed)
1442        implicit none        implicit none
1443        integer  iseed        integer  iseed
1444          real *8 port_rand
1445  #ifdef CRAY  #ifdef CRAY
1446        call ranset (iseed)        call ranset (iseed)
1447  #endif  #else
1448  #ifdef SGI  #ifdef SGI
1449        integer*4   seed        integer*4   seed
1450                    seed = iseed                    seed = iseed
1451        call srand (seed)        call srand (seed)
1452    #else
1453          real*8 tmpRdN
1454          real*8 seed
1455          seed = iseed
1456          tmpRdN = port_rand(seed)
1457    #endif
1458  #endif  #endif
1459        return        return
1460        end        end
1461        SUBROUTINE CLOUD(nn,lng, LENC, K, NLTOP, nlayr, IC, RASALF        SUBROUTINE CLOUD(nn,lng, LENC, K, NLTOP, nlayr, IC, RASALF
1462       *,                 SETRAS, FRAC       *,                 SETRAS, FRAC
1463       *,                 CP,  ALHL, RKAP, GRAV, P00, CRTMSF       *,                 CP,  ALHL, RKAP, GRAV, P00, CRTMSF
1464       *,                 POI, QOI, UOI, Ntracer, PRS,  PRJ       *,                 POI, QOI, UOI, ntracedim, Ntracer, PRS,  PRJ
1465       *,                 PCU, CLN, TCU, QCU, UCU, CMASS       *,                 PCU, CLN, TCU, QCU, UCU, CMASS
1466       *,                 ALF, BET, GAM, PRH, PRI, HOL, ETA       *,                 ALF, BET, GAM, PRH, PRI, HOL, ETA
1467       *,                 HST, QOL, GMH       *,                 HST, QOL, GMH
# Line 1501  C Line 1594  C
1594  C************************************************************************  C************************************************************************
1595        implicit none        implicit none
1596  C Argument List declarations  C Argument List declarations
1597        integer nn,lng,LENC,K,NLTOP,nlayr,ic,ntracer        integer nn,lng,LENC,K,NLTOP,nlayr,ic,ntracedim, ntracer
1598        _RL rasalf        _RL rasalf
1599        LOGICAL SETRAS        LOGICAL SETRAS
1600        _RL frac, cp,  alhl, rkap, grav, p00, crtmsf        _RL frac, cp,  alhl, rkap, grav, p00, crtmsf
1601        _RL POI(lng,K),QOI(lng,K),PRS(lng,K+1),PRJ(lng,K+1)        _RL POI(lng,K),QOI(lng,K),PRS(lng,K+1),PRJ(lng,K+1)
1602        _RL uoi(lng,nlayr,ntracer)        _RL uoi(lng,nlayr,ntracedim)
1603        _RL PCU(LENC), CLN(lng)        _RL PCU(LENC), CLN(lng)
1604        _RL TCU(lng,K),  QCU(lng,K),  ucu(lng,k,ntracer), CMASS(lng,K)        _RL TCU(lng,K),QCU(lng,K),ucu(lng,k,ntracedim),CMASS(lng,K)
1605        _RL ALF(lng,K), BET(lng,K),  GAM(lng,K), PRH(lng,K), PRI(lng,K)        _RL ALF(lng,K), BET(lng,K),  GAM(lng,K), PRH(lng,K), PRI(lng,K)
1606        _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)
1607        _RL GMH(LENC,K)        _RL GMH(LENC,K)
# Line 1516  C Argument List declarations Line 1609  C Argument List declarations
1609        _RL TX5(LENC), TX6(LENC), TX7(LENC), TX8(LENC)        _RL TX5(LENC), TX6(LENC), TX7(LENC), TX8(LENC)
1610        _RL ALM(LENC), WFN(LENC), AKM(LENC), QS1(LENC)        _RL ALM(LENC), WFN(LENC), AKM(LENC), QS1(LENC)
1611        _RL WLQ(LENC), CLF(LENC)        _RL WLQ(LENC), CLF(LENC)
1612        _RL uht(lng,ntracer)        _RL uht(lng,ntracedim)
1613        integer IA(LENC), I1(LENC),I2(LENC)        integer IA(LENC), I1(LENC),I2(LENC)
1614        _RL      rhfrac(lng)        _RL      rhfrac(lng)
1615    
# Line 1545  cfpp$ expand (qsat) Line 1638  cfpp$ expand (qsat)
1638        ONEBG  = 1.0  / GRAV        ONEBG  = 1.0  / GRAV
1639        CPBG   = CP   * ONEBG        CPBG   = CP   * ONEBG
1640        TWOBAL = 2.0 / ALHL        TWOBAL = 2.0 / ALHL
1641    
1642  C  C
1643        KM1 = K  - 1        KM1 = K  - 1
1644        IC1 = IC + 1        IC1 = IC + 1
# Line 1584  C Line 1678  C
1678        CMASS(I,L) = 0.0        CMASS(I,L) = 0.0
1679     10 CONTINUE     10 CONTINUE
1680    
1681  c     do nt = 1,ntracer        do nt = 1,ntracer
1682  c     do L=1,K        do L=1,K
1683  c     do I=1,LENC        do I=1,LENC
1684  c     ucu(I,L,nt) = 0.0        ucu(I,L,nt) = 0.0
1685  c     enddo        enddo
1686  c     enddo        enddo
1687  c     enddo        enddo
1688  C  C
1689        DO 30 I=1,LENC        DO 30 I=1,LENC
1690        TX1(I)   = PRJ(I,K+1) * POI(I,K)        TX1(I)   = PRJ(I,K+1) * POI(I,K)
# Line 1827  C Line 1921  C
1921        WLQ(I) = QOL(II,K) - QS1(I)     * ETA(I,IC)        WLQ(I) = QOL(II,K) - QS1(I)     * ETA(I,IC)
1922        TX7(I) = HOL(II,K)        TX7(I) = HOL(II,K)
1923    620 CONTINUE    620 CONTINUE
1924  c     DO NT=1,Ntracer        DO NT=1,Ntracer
1925  c     DO 621 I=1,LENB        DO 621 I=1,LENB
1926  c     II = I1(I)        II = I1(I)
1927  c     UHT(I,NT) = UOI(II,K+nltop-1,NT)-UOI(II,IC+nltop-1,NT) * ETA(I,IC)        UHT(I,NT) = UOI(II,K+nltop-1,NT)-UOI(II,IC+nltop-1,NT) * ETA(I,IC)
1928  c 621 CONTINUE    621 CONTINUE
1929  c     ENDDO        ENDDO
1930  C  C
1931        DO 635 L=KM1,IC,-1        DO 635 L=KM1,IC,-1
1932        DO 630 I=1,LENB        DO 630 I=1,LENB
# Line 1841  C Line 1935  C
1935        WLQ(I) = WLQ(I) + TEM * QOL(II,L)        WLQ(I) = WLQ(I) + TEM * QOL(II,L)
1936    630 CONTINUE    630 CONTINUE
1937    635 CONTINUE    635 CONTINUE
1938  c     DO NT=1,Ntracer        DO NT=1,Ntracer
1939  c     DO L=KM1,IC,-1        DO L=KM1,IC,-1
1940  c     DO I=1,LENB        DO I=1,LENB
1941  c     II = I1(I)        II = I1(I)
1942  c     TEM    = ETA(I,L) - ETA(I,L+1)        TEM    = ETA(I,L) - ETA(I,L+1)
1943  c     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)
1944  c     ENDDO        ENDDO
1945  c     ENDDO        ENDDO
1946  c     ENDDO        ENDDO
1947  C  C
1948  C     CALCULATE GS AND PART OF AKM (THAT REQUIRES ETA)  C     CALCULATE GS AND PART OF AKM (THAT REQUIRES ETA)
1949  C  C
# Line 2065  C Line 2159  C
2159  C  C
2160  c Compute Tracer Tendencies  c Compute Tracer Tendencies
2161  c -------------------------  c -------------------------
2162  c     do nt = 1,ntracer        do nt = 1,ntracer
2163  c  c
2164  c Tracer Tendency at the Bottom Layer  c Tracer Tendency at the Bottom Layer
2165  c -----------------------------------  c -----------------------------------
2166  c     DO 995 I=1,LENB        DO 995 I=1,LENB
2167  c     II = I1(I)        II = I1(I)
2168  c     TEM    = half*TX5(I) * PRI(II,K)        TEM    = half*TX5(I) * PRI(II,K)
2169  c     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))
2170  c     ucu(II,K,nt) = TEM * TX1(I)        ucu(II,K,nt) = TEM * TX1(I)
2171  c 995 CONTINUE    995 CONTINUE
2172  c  c
2173  c Tracer Tendency at all other Levels  c Tracer Tendency at all other Levels
2174  c -----------------------------------  c -----------------------------------
2175  c     DO 1020 L=KM1,IC1,-1        DO 1020 L=KM1,IC1,-1
2176  c     DO 1010 I=1,LENB        DO 1010 I=1,LENB
2177  c     II = I1(I)        II = I1(I)
2178  c     TEM = half*TX5(I) * PRI(II,L)        TEM = half*TX5(I) * PRI(II,L)
2179  c     TEM1   = TX1(I)        TEM1   = TX1(I)
2180  c     TX1(I) = (UOI(II,L-1+nltop-1,nt)-UOI(II,L+nltop-1,nt)) * ETA(I,L)        TX1(I) = (UOI(II,L-1+nltop-1,nt)-UOI(II,L+nltop-1,nt)) * ETA(I,L)
2181  c     TX3(I) = (TX1(I) + TEM1) * TEM        TX3(I) = (TX1(I) + TEM1) * TEM
2182  c1010 CONTINUE   1010 CONTINUE
2183  c     DO 1020 I=1,LENB        DO 1020 I=1,LENB
2184  c     II = I1(I)        II = I1(I)
2185  c     ucu(II,L,nt) = TX3(I)        ucu(II,L,nt) = TX3(I)
2186  c1020 CONTINUE   1020 CONTINUE
2187  c  
2188  c     DO 1030 I=1,LENB        DO 1030 I=1,LENB
2189  c     II = I1(I)        II = I1(I)
2190  c     IF (TX6(I) .GE. 1.0) THEN        IF (TX6(I) .GE. 1.0) THEN
2191  c        TEM    = half*TX5(I) * PRI(II,IC)           TEM    = half*TX5(I) * PRI(II,IC)
2192  c     ELSE        ELSE
2193  c        TEM = 0.0           TEM = 0.0
2194  c     ENDIF        ENDIF
2195  c     TX1(I) = (TX1(I) + UHT(I,nt) + UHT(I,nt)) * TEM        TX1(I) = (TX1(I) + UHT(I,nt) + UHT(I,nt)) * TEM
2196  c1030 CONTINUE   1030 CONTINUE
2197  c     DO 1040 I=1,LENB        DO 1040 I=1,LENB
2198  c     II = I1(I)        II = I1(I)
2199  c     ucu(II,IC,nt) = TX1(I)        ucu(II,IC,nt) = TX1(I)
2200  c1040 CONTINUE   1040 CONTINUE
2201  c  
2202  c     enddo        enddo
2203  C  C
2204  C     PENETRATIVE CONVECTION CALCULATION OVER  C     PENETRATIVE CONVECTION CALCULATION OVER
2205  C  C
Legend:
Removed from v.1.18  
changed lines
  Added in v.1.30
  ViewVC Help
Powered by ViewVC 1.1.22