/[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.17 by molod, Thu Aug 12 15:21:22 2004 UTC revision 1.20 by molod, Thu Oct 7 00:06:09 2004 UTC
# Line 144  c --------------- Line 144  c ---------------
144        _RL tmstp,tminv,sday,grav,alhl,cp,elocp,gamfac        _RL tmstp,tminv,sday,grav,alhl,cp,elocp,gamfac
145        _RL rkappa,p0kappa,p0kinv,ptopkap,pcheck        _RL rkappa,p0kappa,p0kinv,ptopkap,pcheck
146        _RL tice,getcon,pi        _RL tice,getcon,pi
147          integer ntracedim
148    
149  C **********************************************************************  C **********************************************************************
150  C ****                     INITIALIZATION                           ****  C ****                     INITIALIZATION                           ****
151  C **********************************************************************  C **********************************************************************
152    
153          ntracedim= max(ntracer-ptracer,1)
154        IMSTP  = nsecf(NDMOIST)        IMSTP  = nsecf(NDMOIST)
155        TMSTP  = FLOAT(IMSTP)        TMSTP  = FLOAT(IMSTP)
156        TMINV  = 1. /  TMSTP        TMINV  = 1. /  TMSTP
# Line 184  C Threshold for Cloud Liquid Water Memor Line 186  C Threshold for Cloud Liquid Water Memor
186    
187  c Determine Total number of Random Clouds to Check  c Determine Total number of Random Clouds to Check
188  c ---------------------------------------------  c ---------------------------------------------
189        ncrnd = (lm-nltop+1)/2  C     ncrnd = (lm-nltop+1)/2
190          ncrnd = 0
191    
192        if(first .and. myid.eq.1) then        if(first .and. myid.eq.1 .and. bi.eq.1 ) then
193         print *         print *
194         print *,'Top Level Allowed for Convection : ',nltop         print *,'Top Level Allowed for Convection : ',nltop
195         print *,'          Highest Sub-Cloud Level: ',nsubmax         print *,'          Highest Sub-Cloud Level: ',nsubmax
# Line 260  c -------------------------------------- Line 263  c --------------------------------------
263           dpgather(indx,L) = dpres(pblindex(indx),1,L)           dpgather(indx,L) = dpres(pblindex(indx),1,L)
264         enddo         enddo
265        enddo        enddo
266        do nt = 1,ntracer-ptracer  c     do nt = 1,ntracer-ptracer
267        do L = 1,lm  c     do L = 1,lm
268         do indx = 1,im*jm  c      do indx = 1,im*jm
269          ugather(indx,L,nt) = qz(pblindex(indx),1,L,nt+ptracer)  c       ugather(indx,L,nt) = qz(pblindex(indx),1,L,nt+ptracer)
270         enddo  c      enddo
271        enddo  c     enddo
272        enddo  c     enddo
273    
274  c bump the counter for number of calls to convection  c bump the counter for number of calls to convection
275  c --------------------------------------------------  c --------------------------------------------------
# Line 308  C ************************************** Line 311  C **************************************
311         CALL STRIP (  shgather, SHL     ,im*jm,ISTRIP,lm,NN )         CALL STRIP (  shgather, SHL     ,im*jm,ISTRIP,lm,NN )
312         CALL STRINT( levgather, pbl     ,im*jm,ISTRIP,1 ,NN )         CALL STRINT( levgather, pbl     ,im*jm,ISTRIP,1 ,NN )
313    
314         do nt = 1,ntracer-ptracer  c      do nt = 1,ntracer-ptracer
315         call strip ( ugather(1,1,nt), ul(1,1,nt),im*jm,istrip,lm,nn )  c      call strip ( ugather(1,1,nt), ul(1,1,nt),im*jm,istrip,lm,nn )
316         enddo  c      enddo
317    
318  C **********************************************************************  C **********************************************************************
319  C ****        SETUP FOR RAS CUMULUS PARAMETERIZATION                ****  C ****        SETUP FOR RAS CUMULUS PARAMETERIZATION                ****
# Line 375  c -------------------------------------- Line 378  c --------------------------------------
378    
379  c Save initial value of tracers and compute sub-cloud value  c Save initial value of tracers and compute sub-cloud value
380  c ---------------------------------------------------------  c ---------------------------------------------------------
381         DO NT = 1,ntracer-ptracer  c      DO NT = 1,ntracer-ptracer
382            do  L = 1,lm  c         do  L = 1,lm
383            do  i = num,num+nindeces(nsubcl)-1  c         do  i = num,num+nindeces(nsubcl)-1
384            saveu(i,L,nt) = ul(i,L,nt)  c         saveu(i,L,nt) = ul(i,L,nt)
385            enddo  c         enddo
386            enddo  c         enddo
387            DO I=num,num+nindeces(nsubcl)-1  c         DO I=num,num+nindeces(nsubcl)-1
388            TMP1(I,2) = 0.  c         TMP1(I,2) = 0.
389            ENDDO  c         ENDDO
390            DO L=NSUBCL,lm  c         DO L=NSUBCL,lm
391            DO I=num,num+nindeces(nsubcl)-1  c         DO I=num,num+nindeces(nsubcl)-1
392             TMP1(I,2) = TMP1(I,2)+(PLE(I,L+1)-PLE(I,L))*UL(I,L,NT)/sp(i)  c          TMP1(I,2) = TMP1(I,2)+(PLE(I,L+1)-PLE(I,L))*UL(I,L,NT)/sp(i)
393            ENDDO  c         ENDDO
394            ENDDO  c         ENDDO
395            DO I=num,num+nindeces(nsubcl)-1  c         DO I=num,num+nindeces(nsubcl)-1
396            UL(I,NSUBCL,NT) = TMP1(I,2)*TMP1(I,4)  c         UL(I,NSUBCL,NT) = TMP1(I,2)*TMP1(I,4)
397               usubcl(i,nt) = ul(i,nsubcl,nt)  c            usubcl(i,nt) = ul(i,nsubcl,nt)
398            ENDDO  c         ENDDO
399         ENDDO  c      ENDDO
400    
401  c Compute Pressure Arrays for RAS  c Compute Pressure Arrays for RAS
402  c -------------------------------  c -------------------------------
# Line 478  c -------------------------------------- Line 481  c --------------------------------------
481        enddo        enddo
482    
483        CALL RAS ( NN,istrip,nindeces(nsubcl),NLRAS,NLTOP,lm,TMSTP        CALL RAS ( NN,istrip,nindeces(nsubcl),NLRAS,NLTOP,lm,TMSTP
484       1, UL(num,1,1),ntracer-ptracer,TH(num,NLTOP),SHL(num,NLTOP)       1, UL(num,1,1),ntracedim,TH(num,NLTOP),SHL(num,NLTOP)
485       2, TMP4(num,NLTOP), TMP5(num,NLTOP),rnd, ncrnd, PCPEN(num,NLTOP)       2, TMP4(num,NLTOP), TMP5(num,NLTOP),rnd, ncrnd, PCPEN(num,NLTOP)
486       3, CLBOTH(num,NLTOP), CLFRAC(num,NLTOP)       3, CLBOTH(num,NLTOP), CLFRAC(num,NLTOP)
487       4, cldmas(num,nltop), detrain(num,nltop)       4, cldmas(num,nltop), detrain(num,nltop)
# Line 523  c ------------------------------------ Line 526  c ------------------------------------
526    
527  c Compute Tracer Tendency due to RAS  c Compute Tracer Tendency due to RAS
528  c ----------------------------------  c ----------------------------------
529         do nt = 1,ntracer-ptracer  c      do nt = 1,ntracer-ptracer
530          DO L=1,nsubcl-1  c       DO L=1,nsubcl-1
531          DO I=num,num+nindeces(nsubcl)-1  c       DO I=num,num+nindeces(nsubcl)-1
532           CVU(I,L,nt) = ( UL(I,L,nt)-saveu(i,l,nt) )*sp(i)*tminv  c        CVU(I,L,nt) = ( UL(I,L,nt)-saveu(i,l,nt) )*sp(i)*tminv
533          ENDDO  c       ENDDO
534          ENDDO  c       ENDDO
535          DO L=nsubcl,lm  c       DO L=nsubcl,lm
536          DO I=num,num+nindeces(nsubcl)-1  c       DO I=num,num+nindeces(nsubcl)-1
537           if( usubcl(i,nt).ne.0.0 ) then  c        if( usubcl(i,nt).ne.0.0 ) then
538            cvu(i,L,nt) = ( ul(i,nsubcl,nt)-usubcl(i,nt) ) *  c         cvu(i,L,nt) = ( ul(i,nsubcl,nt)-usubcl(i,nt) ) *
539       .                     ( saveu(i,L,nt)/usubcl(i,nt) )*sp(i)*tminv  c    .                     ( saveu(i,L,nt)/usubcl(i,nt) )*sp(i)*tminv
540           else  c        else
541            cvu(i,L,nt) = 0.0  c         cvu(i,L,nt) = 0.0
542           endif  c        endif
543          ENDDO  c       ENDDO
544          ENDDO  c       ENDDO
545         enddo  c      enddo
546    
547  c Compute Diagnostic PSUBCLD (Subcloud Layer Pressure)  c Compute Diagnostic PSUBCLD (Subcloud Layer Pressure)
548  c ----------------------------------------------------  c ----------------------------------------------------
# Line 570  C ************************************** Line 573  C **************************************
573    
574        call paste( CVTH,deltgather,istrip,im*jm,lm,NN )        call paste( CVTH,deltgather,istrip,im*jm,lm,NN )
575        call paste(  CVQ,delqgather,istrip,im*jm,lm,NN )        call paste(  CVQ,delqgather,istrip,im*jm,lm,NN )
576        do nt = 1,ntracer-ptracer  c     do nt = 1,ntracer-ptracer
577        call paste( CVU(1,1,nt),delugather(1,1,nt),istrip,im*jm,lm,NN )  c     call paste( CVU(1,1,nt),delugather(1,1,nt),istrip,im*jm,lm,NN )
578        enddo  c     enddo
579    
580  C **********************************************************************  C **********************************************************************
581  C     And now paste some arrays for filling diagnostics  C     And now paste some arrays for filling diagnostics
# Line 764  c ------------ Line 767  c ------------
767    
768  c Tracers  c Tracers
769  c -------  c -------
770        do nt = 1,ntracer-ptracer  c     do nt = 1,ntracer-ptracer
771         do L = 1,lm  c      do L = 1,lm
772         call back2grd (delugather(1,L,nt),pblindex,  c      call back2grd (delugather(1,L,nt),pblindex,
773       .                                 dqmoist(1,1,L,ptracer+nt),im*jm)  c    .                                 dqmoist(1,1,L,ptracer+nt),im*jm)
774         enddo  c      enddo
775        enddo  c     enddo
776    
777    
778  C **********************************************************************  C **********************************************************************
# Line 1241  c ***************************** Line 1244  c *****************************
1244          QOI(I,L) = QOI(I,L) + QCU(I,L) * DT * rhfrac(i)          QOI(I,L) = QOI(I,L) + QCU(I,L) * DT * rhfrac(i)
1245         ENDDO         ENDDO
1246        ENDDO        ENDDO
1247        DO NT=1,Ntracer  c     DO NT=1,Ntracer
1248        DO L=IB,K  c     DO L=IB,K
1249         DO I=1,LENC  c      DO I=1,LENC
1250          UOI(I,L+nltop-1,NT)=UOI(I,L+nltop-1,NT)+UCU(I,L,NT)*DT*rhfrac(i)  c       UOI(I,L+nltop-1,NT)=UOI(I,L+nltop-1,NT)+UCU(I,L,NT)*DT*rhfrac(i)
1251         ENDDO  c      ENDDO
1252        ENDDO  c     ENDDO
1253        ENDDO  c     ENDDO
1254        DO I=1,LENC        DO I=1,LENC
1255         rains(I,ib) = rains(I,ib) + PCU(I)*dt * rhfrac(i)         rains(I,ib) = rains(I,ib) + PCU(I)*dt * rhfrac(i)
1256        ENDDO        ENDDO
# Line 1293  c -------------------------------------- Line 1296  c --------------------------------------
1296  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
1297  c ----------------------------------------------------------------------------  c ----------------------------------------------------------------------------
1298        if( first.and.(iras.gt.1) .or. iras.ne.iras0+1 )then        if( first.and.(iras.gt.1) .or. iras.ne.iras0+1 )then
1299           print *,' first ',first,' iras ',iras,' iras0 ',iras0
1300         if( myid.eq.1 ) print *, 'Recreating Rand Numb Array in RNDCLOUD'         if( myid.eq.1 ) print *, 'Recreating Rand Numb Array in RNDCLOUD'
1301         if( myid.eq.1 ) print *, 'IRAS: ',iras,'  IRAS0: ',iras0         if( myid.eq.1 ) print *, 'IRAS: ',iras,'  IRAS0: ',iras0
1302         numrand = mod(iras,irm/nrnd) * nrnd         numrand = mod(iras,irm/nrnd) * nrnd
# Line 1581  C Line 1585  C
1585        CMASS(I,L) = 0.0        CMASS(I,L) = 0.0
1586     10 CONTINUE     10 CONTINUE
1587    
1588        do nt = 1,ntracer  c     do nt = 1,ntracer
1589        do L=1,K  c     do L=1,K
1590        do I=1,LENC  c     do I=1,LENC
1591        ucu(I,L,nt) = 0.0  c     ucu(I,L,nt) = 0.0
1592        enddo  c     enddo
1593        enddo  c     enddo
1594        enddo  c     enddo
1595  C  C
1596        DO 30 I=1,LENC        DO 30 I=1,LENC
1597        TX1(I)   = PRJ(I,K+1) * POI(I,K)        TX1(I)   = PRJ(I,K+1) * POI(I,K)
# Line 1824  C Line 1828  C
1828        WLQ(I) = QOL(II,K) - QS1(I)     * ETA(I,IC)        WLQ(I) = QOL(II,K) - QS1(I)     * ETA(I,IC)
1829        TX7(I) = HOL(II,K)        TX7(I) = HOL(II,K)
1830    620 CONTINUE    620 CONTINUE
1831        DO NT=1,Ntracer  c     DO NT=1,Ntracer
1832        DO 621 I=1,LENB  c     DO 621 I=1,LENB
1833        II = I1(I)  c     II = I1(I)
1834        UHT(I,NT) = UOI(II,K+nltop-1,NT)-UOI(II,IC+nltop-1,NT) * ETA(I,IC)  c     UHT(I,NT) = UOI(II,K+nltop-1,NT)-UOI(II,IC+nltop-1,NT) * ETA(I,IC)
1835    621 CONTINUE  c 621 CONTINUE
1836        ENDDO  c     ENDDO
1837  C  C
1838        DO 635 L=KM1,IC,-1        DO 635 L=KM1,IC,-1
1839        DO 630 I=1,LENB        DO 630 I=1,LENB
# Line 1838  C Line 1842  C
1842        WLQ(I) = WLQ(I) + TEM * QOL(II,L)        WLQ(I) = WLQ(I) + TEM * QOL(II,L)
1843    630 CONTINUE    630 CONTINUE
1844    635 CONTINUE    635 CONTINUE
1845        DO NT=1,Ntracer  c     DO NT=1,Ntracer
1846        DO L=KM1,IC,-1  c     DO L=KM1,IC,-1
1847        DO I=1,LENB  c     DO I=1,LENB
1848        II = I1(I)  c     II = I1(I)
1849        TEM    = ETA(I,L) - ETA(I,L+1)  c     TEM    = ETA(I,L) - ETA(I,L+1)
1850        UHT(I,NT) = UHT(I,NT) + TEM * UOI(II,L+nltop-1,NT)  c     UHT(I,NT) = UHT(I,NT) + TEM * UOI(II,L+nltop-1,NT)
1851        ENDDO  c     ENDDO
1852        ENDDO  c     ENDDO
1853        ENDDO  c     ENDDO
1854  C  C
1855  C     CALCULATE GS AND PART OF AKM (THAT REQUIRES ETA)  C     CALCULATE GS AND PART OF AKM (THAT REQUIRES ETA)
1856  C  C
# Line 2062  C Line 2066  C
2066  C  C
2067  c Compute Tracer Tendencies  c Compute Tracer Tendencies
2068  c -------------------------  c -------------------------
2069        do nt = 1,ntracer  c     do nt = 1,ntracer
2070    c
2071  c Tracer Tendency at the Bottom Layer  c Tracer Tendency at the Bottom Layer
2072  c -----------------------------------  c -----------------------------------
2073        DO 995 I=1,LENB  c     DO 995 I=1,LENB
2074        II = I1(I)  c     II = I1(I)
2075        TEM    = half*TX5(I) * PRI(II,K)  c     TEM    = half*TX5(I) * PRI(II,K)
2076        TX1(I) = (UOI(II,KM1+nltop-1,nt) - UOI(II,K+nltop-1,nt))  c     TX1(I) = (UOI(II,KM1+nltop-1,nt) - UOI(II,K+nltop-1,nt))
2077        ucu(II,K,nt) = TEM * TX1(I)  c     ucu(II,K,nt) = TEM * TX1(I)
2078    995 CONTINUE  c 995 CONTINUE
2079    c
2080  c Tracer Tendency at all other Levels  c Tracer Tendency at all other Levels
2081  c -----------------------------------  c -----------------------------------
2082        DO 1020 L=KM1,IC1,-1  c     DO 1020 L=KM1,IC1,-1
2083        DO 1010 I=1,LENB  c     DO 1010 I=1,LENB
2084        II = I1(I)  c     II = I1(I)
2085        TEM = half*TX5(I) * PRI(II,L)  c     TEM = half*TX5(I) * PRI(II,L)
2086        TEM1   = TX1(I)  c     TEM1   = TX1(I)
2087        TX1(I) = (UOI(II,L-1+nltop-1,nt)-UOI(II,L+nltop-1,nt)) * ETA(I,L)  c     TX1(I) = (UOI(II,L-1+nltop-1,nt)-UOI(II,L+nltop-1,nt)) * ETA(I,L)
2088        TX3(I) = (TX1(I) + TEM1) * TEM  c     TX3(I) = (TX1(I) + TEM1) * TEM
2089   1010 CONTINUE  c1010 CONTINUE
2090        DO 1020 I=1,LENB  c     DO 1020 I=1,LENB
2091        II = I1(I)  c     II = I1(I)
2092        ucu(II,L,nt) = TX3(I)  c     ucu(II,L,nt) = TX3(I)
2093   1020 CONTINUE  c1020 CONTINUE
2094    c
2095        DO 1030 I=1,LENB  c     DO 1030 I=1,LENB
2096        II = I1(I)  c     II = I1(I)
2097        IF (TX6(I) .GE. 1.0) THEN  c     IF (TX6(I) .GE. 1.0) THEN
2098           TEM    = half*TX5(I) * PRI(II,IC)  c        TEM    = half*TX5(I) * PRI(II,IC)
2099        ELSE  c     ELSE
2100           TEM = 0.0  c        TEM = 0.0
2101        ENDIF  c     ENDIF
2102        TX1(I) = (TX1(I) + UHT(I,nt) + UHT(I,nt)) * TEM  c     TX1(I) = (TX1(I) + UHT(I,nt) + UHT(I,nt)) * TEM
2103   1030 CONTINUE  c1030 CONTINUE
2104        DO 1040 I=1,LENB  c     DO 1040 I=1,LENB
2105        II = I1(I)  c     II = I1(I)
2106        ucu(II,IC,nt) = TX1(I)  c     ucu(II,IC,nt) = TX1(I)
2107   1040 CONTINUE  c1040 CONTINUE
2108    c
2109        enddo  c     enddo
2110  C  C
2111  C     PENETRATIVE CONVECTION CALCULATION OVER  C     PENETRATIVE CONVECTION CALCULATION OVER
2112  C  C
Legend:
Removed from v.1.17  
changed lines
  Added in v.1.20
  ViewVC Help
Powered by ViewVC 1.1.22