/[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.26 by jmc, Tue Mar 1 15:25:11 2005 UTC revision 1.35 by ce107, Fri Jun 17 16:51:24 2005 UTC
# 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
# Line 147  c --------------- Line 141  c ---------------
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        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                           ****
# Line 606  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 651  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 737  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 753  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 777  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    
# Line 831  C ************************************** Line 817  C **************************************
817  C                          BUMP DIAGNOSTICS  C                          BUMP DIAGNOSTICS
818  C **********************************************************************  C **********************************************************************
819    
820    #ifdef ALLOW_DIAGNOSTICS
821    
822  c Sub-Cloud Layer  c Sub-Cloud Layer
823  c -------------------------  c -------------------------
824        if( ipsubcld.ne.0 ) then        if(diagnostics_is_on('PSUBCLD ',myid) .and.
825        do j = 1,jm       .                 diagnostics_is_on('PSUBCLDC',myid) ) then
826        do i = 1,im         call diagnostics_fill(psubcldg,'PSUBCLD ',0,1,3,bi,bj,myid)
827        qdiag(i,j,ipsubcld,bi,bj) = qdiag(i,j,ipsubcld,bi,bj) +         call diagnostics_fill(psubcldgc,'PSUBCLDC',0,1,3,bi,bj,myid)
      .                                           psubcldg (i,j)  
       qdiag(i,j,ipsubcldc,bi,bj) = qdiag(i,j,ipsubcldc,bi,bj) +  
      .                                           psubcldgc(i,j)  
       enddo  
       enddo  
828        endif        endif
829    
830  c Non-Precipitating Cloud Fraction  c Non-Precipitating Cloud Fraction
831  c --------------------------------  c --------------------------------
832        if( icldnp.ne.0 ) then        if(diagnostics_is_on('CLDNP   ',myid) ) then
833        do L = 1,lm         do L=1,lm
834        do j = 1,jm         do j=1,jm
835        do i = 1,im         do i=1,im
836        qdiag(i,j,icldnp+L-1,bi,bj) = qdiag(i,j,icldnp+L-1,bi,bj) +          tmpdiag(i,j) = cldsr(i,j,L)
837       .                                                  cldsr(i,j,L)         enddo
838        enddo         enddo
839        enddo         call diagnostics_fill(tmpdiag,'CLDNP   ',L,1,3,bi,bj,myid)
840        enddo        enddo
       ncldnp = ncldnp + 1  
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 j = 1,jm         do j=1,jm
848        do i = 1,im         do i=1,im
849         indgath = (j-1)*im + i          indgath = (j-1)*im + i
850        qdiag(i,j,imoistt+L-1,bi,bj) = qdiag(i,j,imoistt+L-1,bi,bj) +          tmpdiag(i,j)=(dtmoist(i,j,L)*sday*pkzgather(indgath,L)/pz(i,j))
851       .    (dtmoist(i,j,L)*sday*pkzgather(indgath,L)/pz(i,j))         enddo
852        enddo         enddo
853        enddo         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)
       enddo  
       endif  
   
 c Moist Processes Change in U-Momentum (Cumulus Friction)  
 c ------------------------------------------------------  
       if(iudiag1.gt.0) then  
       do L = 1,lm  
       do j = 1,jm  
       do i = 1,im  
        indgath = (j-1)*im + i  
       qdiag(i,j,iudiag1+L-1,bi,bj) = qdiag(i,j,iudiag1+L-1,bi,bj) +  
      .    dumoist(i,j,L)*sday  
       enddo  
       enddo  
       enddo  
       endif  
   
 c Moist Processes Change in V-Momentum (Cumulus Friction)  
 c ------------------------------------------------------  
       if(iudiag2.gt.0) then  
       do L = 1,lm  
       do j = 1,jm  
       do i = 1,im  
        indgath = (j-1)*im + i  
       qdiag(i,j,iudiag2+L-1,bi,bj) = qdiag(i,j,iudiag2+L-1,bi,bj) +  
      .    dvmoist(i,j,L)*sday  
       enddo  
       enddo  
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 j = 1,jm         do j=1,jm
875        do i = 1,im         do i=1,im
876         indgath = (j-1)*im + i          indgath = (j-1)*im + i
877        qdiag(i,j,icldmas+L-1,bi,bj) = qdiag(i,j,icldmas+L-1,bi,bj) +          tmpdiag(i,j)=tmpgather(indgath,L)
878       .                               tmpgather(indgath,L)         enddo
879        enddo         enddo
880        enddo         call diagnostics_fill(tmpdiag,'CLDMAS  ',L,1,3,bi,bj,myid)
881        enddo         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 j = 1,jm         do j=1,jm
889        do i = 1,im         do i=1,im
890         indgath = (j-1)*im + i          indgath = (j-1)*im + i
891        qdiag(i,j,idtrain+L-1,bi,bj) = qdiag(i,j,idtrain+L-1,bi,bj) +          tmpdiag(i,j)=pkegather(indgath,L)
892       .                                pkegather(indgath,L)         enddo
893        enddo         enddo
894        enddo         call diagnostics_fill(tmpdiag,'DTRAIN  ',L,1,3,bi,bj,myid)
895        enddo         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 j = 1,jm         do j=1,jm
903        do i = 1,im         do i=1,im
904         indgath = (j-1)*im + i          indgath = (j-1)*im + i
905        qdiag(i,j,idtls+L-1,bi,bj) = qdiag(i,j,idtls+L-1,bi,bj) +          tmpdiag(i,j)=deltrnev(indgath,L)
906       .                               deltrnev(indgath,L)         enddo
907        enddo         enddo
908        enddo         call diagnostics_fill(tmpdiag,'DTLS    ',L,1,3,bi,bj,myid)
909        enddo         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 j = 1,jm         do j=1,jm
917        do i = 1,im         do i=1,im
918         indgath = (j-1)*im + i          indgath = (j-1)*im + i
919        qdiag(i,j,idqls+L-1,bi,bj) = qdiag(i,j,idqls+L-1,bi,bj) +          tmpdiag(i,j)=delqrnev(indgath,L)
920       .                                delqrnev(indgath,L)         enddo
921        enddo         enddo
922        enddo         call diagnostics_fill(tmpdiag,'DQLS    ',L,1,3,bi,bj,myid)
923        enddo         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 j = 1,jm         do j=1,jm
942        do i = 1,im         do i=1,im
943         indgath = (j-1)*im + i          indgath = (j-1)*im + i
944        qdiag(i,j,iprecon,bi,bj) = qdiag(i,j,iprecon,bi,bj) +          tmpdiag(i,j) = raincgath(indgath)*sday*tminv
945       .                      raincgath(indgath)*sday*tminv         enddo
946        enddo         enddo
947        enddo         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 1038  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 1059  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 1109  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 1145  C ************************************** Line 1114  C **************************************
1114         nlwcld   = nlwcld   + 1         nlwcld   = nlwcld   + 1
1115         nswcld   = nswcld   + 1         nswcld   = nswcld   + 1
1116    
 #ifdef ALLOW_DIAGNOSTICS  
        if( (bi.eq.1) .and. (bj.eq.1) ) then  
        nmoistt  = nmoistt  + 1  
        nmoistq  = nmoistq  + 1  
        npreacc  = npreacc  + 1  
        nprecon  = nprecon  + 1  
   
        ncldmas  = ncldmas  + 1  
        ndtrain  = ndtrain  + 1  
   
        ndtls  = ndtls  + 1  
        ndqls  = ndqls  + 1  
   
        nudiag1  = nudiag1  + 1  
        nudiag2  = nudiag2  + 1  
   
        endif  
 #endif  
   
1117        RETURN        RETURN
1118        END        END
1119        SUBROUTINE RAS( NN, LNG, LENC, K, NLTOP, nlayr, DT        SUBROUTINE RAS( NN, LNG, LENC, K, NLTOP, nlayr, DT
# Line 1377  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,indx        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
# Line 1398  c -------------------------------------- Line 1349  c --------------------------------------
1349    
1350        mcheck = mod(iras-1,irm/nrnd)        mcheck = mod(iras-1,irm/nrnd)
1351    
 c First Time In From a Continuing RESTART (IRAS.GT.1) or Reading a New RESTART  
 c ----------------------------------------------------------------------------  
1352  c     print *,' RNDCLOUD: first ',first,' iras ',iras,' iras0 ',iras0  c     print *,' RNDCLOUD: first ',first,' iras ',iras,' iras0 ',iras0
1353  c     print *,' RNDCLOUD: irm,nrnd,mcheck=',irm,nrnd,mcheck  c     print *,' RNDCLOUD: irm,nrnd,mcheck=',irm,nrnd,mcheck
1354        if( first.and.(iras.gt.1) .or. iras.ne.iras0+1 )then  
1355         print *,' first ',first,' iras ',iras,' iras0 ',iras0        if ( iras.eq.iras0 ) then
1356         if( myid.eq.1 ) print *, 'Recreating Rand Numb Array in RNDCLOUD'  C-    Not the 1rst tile: we are all set (already done for the 1rst tile):
1357         if( myid.eq.1 ) print *, 'IRAS: ',iras,'  IRAS0: ',iras0  c -----------------------------------------------------------------------
1358         numrand = mod(iras,irm/nrnd) * nrnd            indx = (iras-1)*nrnd
1359         iseed   = iras * nrnd - numrand  
1360    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 ----------------------------------------------------------------------------
1364          elseif ( first.and.(iras.gt.1) .or. mcheck.eq.0 ) then
1365           iseed = (iras-1-mcheck)*nrnd
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         indx = (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  
           indx = 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 --------------------------------------------------------------------
# Line 1431  c -------------------------------------- Line 1381  c --------------------------------------
1381        endif        endif
1382    
1383            indx = mod(indx,irm)            indx = mod(indx,irm)
1384        if( indx+nrnd.gt.1000 ) indx=1000-nrnd        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
1389    
1390        do n = 1,nrnd        do n = 1,nrnd
1391         rnd(n) = random(indx+n)         rnd(n) = random(indx+n)
1392        enddo        enddo
# Line 1440  c -------------------------------------- Line 1394  c --------------------------------------
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 1455  c -------------------------------------- Line 1410  c --------------------------------------
1410        _RL rand        _RL rand
1411        random_numbx = rand()        random_numbx = rand()
1412  #else  #else
1413        seed = iseed        seed = -1.d0
1414        random_numbx = port_rand(seed)        random_numbx = port_rand(seed)
1415  #endif  #endif
1416  #endif  #endif
# Line 1464  c -------------------------------------- Line 1419  c --------------------------------------
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
# Line 2246  C Local Variables Line 2208  C Local Variables
2208  C  C
2209        DO 10 I=1,lng        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 2515  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 2621  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 2664  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.26  
changed lines
  Added in v.1.35
  ViewVC Help
Powered by ViewVC 1.1.22