/[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.21 by molod, Thu Dec 2 19:06:17 2004 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 24  c Input Variables Line 24  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 51  c --------------- Line 53  c ---------------
53        _RL       fracqq, dum        _RL       fracqq, dum
54        integer    snowcrit        integer    snowcrit
55        parameter (fracqq = 0.1)        parameter (fracqq = 0.1)
56          _RL one
57          parameter (one=1.)
58    
59        _RL   cldsr(im,jm,lm)        _RL   cldsr(im,jm,lm)
60        _RL   srcld(istrip,lm)        _RL   srcld(istrip,lm)
# Line 86  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 99  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 109  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 138  c --------------- Line 142  c ---------------
142        DATA      FIRST /.TRUE./        DATA      FIRST /.TRUE./
143    
144        integer imstp,nsubcl,nlras        integer imstp,nsubcl,nlras
145        integer i,j,iloop,index,l,nn,num,numdeps,nt        integer i,j,iloop,indx,indgath,l,nn,num,numdeps,nt
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 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)
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 182  C Threshold for Cloud Liquid Water Memor Line 196  C Threshold for Cloud Liquid Water Memor
196    
197  c Determine Total number of Random Clouds to Check  c Determine Total number of Random Clouds to Check
198  c ---------------------------------------------  c ---------------------------------------------
199        ncrnd = (lm-nltop+1)/2  C     ncrnd = (lm-nltop+1)/2
200          ncrnd = 0
201    
202        if(first .and. myid.eq.0) then        if(first .and. myid.eq.1 .and. bi.eq.1 ) then
203         print *         print *
204         print *,'Top Level Allowed for Convection : ',nltop         print *,'Top Level Allowed for Convection : ',nltop
205         print *,'          Highest Sub-Cloud Level: ',nsubmax         print *,'          Highest Sub-Cloud Level: ',nsubmax
# Line 228  c -------------------------------------- Line 243  c --------------------------------------
243    
244  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
245  c ----------------------------------------------------------------  c ----------------------------------------------------------------
246        index = 0        indx = 0
247        do L = nsubmin,nltop,-1        do L = nsubmin,nltop,-1
248         do j = 1,jm         do j = 1,jm
249         do i = 1,im         do i = 1,im
250          if(levpbl(i,j).eq.L) then          if(levpbl(i,j).eq.L) then
251           index = index + 1           indx = indx + 1
252           pblindex(index) = (j-1)*im + i           pblindex(indx) = (j-1)*im + i
253          endif          endif
254         enddo         enddo
255         enddo         enddo
256        enddo        enddo
257    
258        do index = 1,im*jm        do indx = 1,im*jm
259         levgather(index) = levpbl(pblindex(index),1)         levgather(indx) = levpbl(pblindex(indx),1)
260          pigather(index) =     pz(pblindex(index),1)          pigather(indx) =     pz(pblindex(indx),1)
261          pkegather(index,lm+1) = pkht(pblindex(index),1,lm+1)          pkegather(indx,lm+1) = pkht(pblindex(indx),1,lm+1)
262          plegather(index,lm+1) = plze(pblindex(index),1,lm+1)          plegather(indx,lm+1) = plze(pblindex(indx),1,lm+1)
263        enddo        enddo
264    
265        do L = 1,lm        do L = 1,lm
266         do index = 1,im*jm         do indx = 1,im*jm
267           thgather(index,L) = tz(pblindex(index),1,L)           thgather(indx,L) = tz(pblindex(indx),1,L)
268           shgather(index,L) = qz(pblindex(index),1,L,1)           shgather(indx,L) = qz(pblindex(indx),1,L,1)
269          pkegather(index,L) = pkht(pblindex(index),1,L)          pkegather(indx,L) = pkht(pblindex(indx),1,L)
270          pkzgather(index,L) = pkl(pblindex(index),1,L)          pkzgather(indx,L) = pkl(pblindex(indx),1,L)
271          plegather(index,L) = plze(pblindex(index),1,L)          plegather(indx,L) = plze(pblindex(indx),1,L)
272          plzgather(index,L) = plz(pblindex(index),1,L)          plzgather(indx,L) = plz(pblindex(indx),1,L)
273           dpgather(index,L) = dpres(pblindex(index),1,L)           dpgather(indx,L) = dpres(pblindex(indx),1,L)
274         enddo         enddo
275        enddo        enddo
276        do nt = 1,ntracer-ptracer  C General Tracers
277    C----------------
278          do nt = 1,ntracerin-ptracer
279        do L = 1,lm        do L = 1,lm
280         do index = 1,im*jm         do indx = 1,im*jm
281          ugather(index,L,nt) = qz(pblindex(index),1,L,nt+ptracer)          ugather(indx,L,nt) = qz(pblindex(indx),1,L,nt+ptracer)
282         enddo         enddo
283        enddo        enddo
284        enddo        enddo
285    
286          if(cumfric) then
287    C Cumulus Friction - load u and v wind components into tracer array
288    C------------------------------------------------------------------
289          do L = 1,lm
290           do indx = 1,im*jm
291            ugather(indx,L,ntracerin-ptracer+1) = uz(pblindex(indx),1,L)
292            ugather(indx,L,ntracerin-ptracer+2) = vz(pblindex(indx),1,L)
293           enddo
294          enddo
295    
296          endif
297    
298  c bump the counter for number of calls to convection  c bump the counter for number of calls to convection
299  c --------------------------------------------------  c --------------------------------------------------
300                          iras = iras + 1                          iras = iras + 1
# Line 278  c -------------------------------------- Line 307  c --------------------------------------
307        do l=1,lm        do l=1,lm
308        do j=1,jm        do j=1,jm
309        do i=1,im        do i=1,im
310          dumoist(i,j,l) = 0.
311          dvmoist(i,j,l) = 0.
312        dtmoist(i,j,l) = 0.        dtmoist(i,j,l) = 0.
313          do nt = 1,ntracer          do nt = 1,ntracerin
314          dqmoist(i,j,l,nt) = 0.          dqmoist(i,j,l,nt) = 0.
315          enddo          enddo
316        enddo        enddo
# Line 307  C ************************************** Line 338  C **************************************
338         CALL STRINT( levgather, pbl     ,im*jm,ISTRIP,1 ,NN )         CALL STRINT( levgather, pbl     ,im*jm,ISTRIP,1 ,NN )
339    
340         do nt = 1,ntracer-ptracer         do nt = 1,ntracer-ptracer
341         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 )
342         enddo         enddo
343    
344  C **********************************************************************  C **********************************************************************
# Line 476  c -------------------------------------- Line 507  c --------------------------------------
507        enddo        enddo
508    
509        CALL RAS ( NN,istrip,nindeces(nsubcl),NLRAS,NLTOP,lm,TMSTP        CALL RAS ( NN,istrip,nindeces(nsubcl),NLRAS,NLTOP,lm,TMSTP
510       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)
511       2, TMP4(num,NLTOP), TMP5(num,NLTOP),rnd, ncrnd, PCPEN(num,NLTOP)       2, TMP4(num,NLTOP), TMP5(num,NLTOP),rnd, ncrnd, PCPEN(num,NLTOP)
512       3, CLBOTH(num,NLTOP), CLFRAC(num,NLTOP)       3, CLBOTH(num,NLTOP), CLFRAC(num,NLTOP)
513       4, cldmas(num,nltop), detrain(num,nltop)       4, cldmas(num,nltop), detrain(num,nltop)
# Line 602  C ************************************** Line 633  C **************************************
633    
634         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,
635       .  PLK,TH,TMP1,TMP2,TMP3,ITMP1,ITMP2,PCNET,PRECIP,       .  PLK,TH,TMP1,TMP2,TMP3,ITMP1,ITMP2,PCNET,PRECIP,
636       .  CLSBTH,TMSTP,1.,cp,grav,alhl,gamfac,cldlz,rhcrit,offset,alpha)       .  CLSBTH,TMSTP,one,cp,grav,alhl,gamfac,cldlz,rhcrit,offset,alpha)
637    
638  C **********************************************************************  C **********************************************************************
639  C ****                     TENDENCY UPDATES                         ****  C ****                     TENDENCY UPDATES                         ****
# Line 760  c ------------ Line 791  c ------------
791       .                                              cldsr(1,1,L),im*jm)       .                                              cldsr(1,1,L),im*jm)
792        enddo        enddo
793    
794  c Tracers  c General Tracers
795  c -------  c ---------------
796        do nt = 1,ntracer-ptracer        do nt = 1,ntracerin-ptracer
797         do L = 1,lm         do L = 1,lm
798         call back2grd (delugather(1,L,nt),pblindex,         call back2grd (delugather(1,L,nt),pblindex,
799       .                                 dqmoist(1,1,L,ptracer+nt),im*jm)       .                                 dqmoist(1,1,L,ptracer+nt),im*jm)
800         enddo         enddo
801        enddo        enddo
802    
803          if(cumfric) then
804    
805    c U and V for cumulus friction
806    c ----------------------------
807          do L = 1,lm
808           call back2grd (delugather(1,L,ntracerin-ptracer+1),pblindex,
809         .                                 dumoist(1,1,L),im*jm)
810           call back2grd (delugather(1,L,ntracerin-ptracer+2),pblindex,
811         .                                 dvmoist(1,1,L),im*jm)
812          enddo
813    
814    C Remove pi-weighting for u and v tendencies
815          do j = 1,jm
816          do i = 1,im
817           tmpimjm(i,j) = 1./pz(i,j)
818          enddo
819          enddo
820          do L = 1,lm
821          do j = 1,jm
822          do i = 1,im
823           dumoist(i,j,L) = dumoist(i,j,L) * tmpimjm(i,j)
824           dumoist(i,j,L) = dumoist(i,j,L) * tmpimjm(i,j)
825          enddo
826          enddo
827          enddo
828    
829          endif
830    
831  C **********************************************************************  C **********************************************************************
832  C                          BUMP DIAGNOSTICS  C                          BUMP DIAGNOSTICS
833  C **********************************************************************  C **********************************************************************
834    
835    
836  c Sub-Cloud Layer  c Sub-Cloud Layer
837  c -------------------------  c -------------------------
838        if( ipsubcld.ne.0 ) then        if( ipsubcld.ne.0 ) then
# Line 805  c Moist Processes Heating Rate Line 864  c Moist Processes Heating Rate
864  c ----------------------------  c ----------------------------
865        if(imoistt.gt.0) then        if(imoistt.gt.0) then
866        do L = 1,lm        do L = 1,lm
867        do i = 1,im*jm        do j = 1,jm
868        qdiag(i,1,imoistt+L-1,bi,bj) = qdiag(i,1,imoistt+L-1,bi,bj) +        do i = 1,im
869       .                      (dtmoist(i,1,L)*sday*pkzgather(i,L)/pz(i,1))         indgath = (j-1)*im + i
870          qdiag(i,j,imoistt+L-1,bi,bj) = qdiag(i,j,imoistt+L-1,bi,bj) +
871         .    (dtmoist(i,j,L)*sday*pkzgather(indgath,L)/pz(i,j))
872          enddo
873        enddo        enddo
874        enddo        enddo
875        endif        endif
# Line 825  c ------------------------------- Line 887  c -------------------------------
887        enddo        enddo
888        endif        endif
889    
890    c Moist Processes Change in U-Momentum (Cumulus Friction)
891    c ------------------------------------------------------
892          if(iudiag1.gt.0) then
893          do L = 1,lm
894          do j = 1,jm
895          do i = 1,im
896           indgath = (j-1)*im + i
897          qdiag(i,j,iudiag1+L-1,bi,bj) = qdiag(i,j,iudiag1+L-1,bi,bj) +
898         .    dumoist(i,j,L)*sday
899          enddo
900          enddo
901          enddo
902          endif
903    
904    c Moist Processes Change in V-Momentum (Cumulus Friction)
905    c ------------------------------------------------------
906          if(iudiag2.gt.0) then
907          do L = 1,lm
908          do j = 1,jm
909          do i = 1,im
910           indgath = (j-1)*im + i
911          qdiag(i,j,iudiag2+L-1,bi,bj) = qdiag(i,j,iudiag2+L-1,bi,bj) +
912         .    dvmoist(i,j,L)*sday
913          enddo
914          enddo
915          enddo
916          endif
917    
918  c Cloud Mass Flux  c Cloud Mass Flux
919  c ---------------  c ---------------
920        if(icldmas.gt.0) then        if(icldmas.gt.0) then
921        do L = 1,lm        do L = 1,lm
922        do i = 1,im*jm        do j = 1,jm
923        qdiag(i,1,icldmas+L-1,bi,bj) = qdiag(i,1,icldmas+L-1,bi,bj) +        do i = 1,im
924       .                                                  tmpgather(i,L)         indgath = (j-1)*im + i
925          qdiag(i,j,icldmas+L-1,bi,bj) = qdiag(i,j,icldmas+L-1,bi,bj) +
926         .                               tmpgather(indgath,L)
927          enddo
928        enddo        enddo
929        enddo        enddo
930        endif        endif
# Line 840  c Detrained Cloud Mass Flux Line 933  c Detrained Cloud Mass Flux
933  c -------------------------  c -------------------------
934        if(idtrain.gt.0) then        if(idtrain.gt.0) then
935        do L = 1,lm        do L = 1,lm
936        do i = 1,im*jm        do j = 1,jm
937        qdiag(i,1,idtrain+L-1,bi,bj) = qdiag(i,1,idtrain+L-1,bi,bj) +        do i = 1,im
938       .                                                  pkegather(i,L)         indgath = (j-1)*im + i
939          qdiag(i,j,idtrain+L-1,bi,bj) = qdiag(i,j,idtrain+L-1,bi,bj) +
940         .                                pkegather(indgath,L)
941          enddo
942        enddo        enddo
943        enddo        enddo
944        endif        endif
# Line 851  c Grid-Scale Condensational Heating Rate Line 947  c Grid-Scale Condensational Heating Rate
947  c --------------------------------------  c --------------------------------------
948        if(idtls.gt.0) then        if(idtls.gt.0) then
949        do L = 1,lm        do L = 1,lm
950        do i = 1,im*jm        do j = 1,jm
951        qdiag(i,1,idtls+L-1,bi,bj) = qdiag(i,1,idtls+L-1,bi,bj) +        do i = 1,im
952       .                                                  deltrnev(i,L)         indgath = (j-1)*im + i
953          qdiag(i,j,idtls+L-1,bi,bj) = qdiag(i,j,idtls+L-1,bi,bj) +
954         .                               deltrnev(indgath,L)
955          enddo
956        enddo        enddo
957        enddo        enddo
958        endif        endif
# Line 862  c Grid-Scale Condensational Moistening R Line 961  c Grid-Scale Condensational Moistening R
961  c -----------------------------------------  c -----------------------------------------
962        if(idqls.gt.0) then        if(idqls.gt.0) then
963        do L = 1,lm        do L = 1,lm
964        do i = 1,im*jm        do j = 1,jm
965        qdiag(i,1,idqls+L-1,bi,bj) = qdiag(i,1,idqls+L-1,bi,bj) +        do i = 1,im
966       .                                                  delqrnev(i,L)         indgath = (j-1)*im + i
967          qdiag(i,j,idqls+L-1,bi,bj) = qdiag(i,j,idqls+L-1,bi,bj) +
968         .                                delqrnev(indgath,L)
969          enddo
970        enddo        enddo
971        enddo        enddo
972        endif        endif
# Line 885  c ------------------- Line 987  c -------------------
987  c Convective Precipitation  c Convective Precipitation
988  c ------------------------  c ------------------------
989        if(iprecon.gt.0) then        if(iprecon.gt.0) then
990        do i = 1,im*jm        do j = 1,jm
991        qdiag(i,1,iprecon,bi,bj) = qdiag(i,1,iprecon,bi,bj) +        do i = 1,im
992       .                                         raincgath(i)*sday*tminv         indgath = (j-1)*im + i
993          qdiag(i,j,iprecon,bi,bj) = qdiag(i,j,iprecon,bi,bj) +
994         .                      raincgath(indgath)*sday*tminv
995          enddo
996        enddo        enddo
997        endif        endif
998    
# Line 990  c -------------------------------------- Line 1095  c --------------------------------------
1095        enddo        enddo
1096        enddo        enddo
1097    
1098  c Compute Instantanious Total 2-D Cloud Fraction  c Compute Instantaneous Total 2-D Cloud Fraction
1099  c ----------------------------------------------  c ----------------------------------------------
1100        do j = 1,jm        do j = 1,jm
1101        do i = 1,im        do i = 1,im
# Line 1041  C ************************************** Line 1146  C **************************************
1146         nlwcld   = nlwcld   + 1         nlwcld   = nlwcld   + 1
1147         nswcld   = nswcld   + 1         nswcld   = nswcld   + 1
1148    
1149    #ifdef ALLOW_DIAGNOSTICS
1150           if( (bi.eq.1) .and. (bj.eq.1) ) then
1151         nmoistt  = nmoistt  + 1         nmoistt  = nmoistt  + 1
1152         nmoistq  = nmoistq  + 1         nmoistq  = nmoistq  + 1
1153         npreacc  = npreacc  + 1         npreacc  = npreacc  + 1
# Line 1051  C ************************************** Line 1158  C **************************************
1158    
1159         ndtls  = ndtls  + 1         ndtls  = ndtls  + 1
1160         ndqls  = ndqls  + 1         ndqls  = ndqls  + 1
1161           endif
1162    #endif
1163    
1164        RETURN        RETURN
1165        END        END
1166        SUBROUTINE RAS( NN, LEN, LENC, K, NLTOP, nlayr, DT        SUBROUTINE RAS( NN, LNG, LENC, K, NLTOP, nlayr, DT
1167       *,               UOI, ntracer, POI, QOI, PRS, PRJ, rnd, ncrnd       *,      UOI, ntracedim, ntracer, POI, QOI, PRS, PRJ, rnd, ncrnd
1168       *,               RAINS, CLN, CLF, cldmas, detrain       *,      RAINS, CLN, CLF, cldmas, detrain
1169       *,               cp,grav,rkappa,alhl,rhfrac,rasmax )       *,      cp,grav,rkappa,alhl,rhfrac,rasmax )
1170  C  C
1171  C*********************************************************************  C*********************************************************************
1172  C********************* SUBROUTINE  RAS   *****************************  C********************* SUBROUTINE  RAS   *****************************
# Line 1067  C Line 1176  C
1176        implicit none        implicit none
1177    
1178  C Argument List  C Argument List
1179        integer nn,len,lenc,k,nltop,nlayr        integer nn,lng,lenc,k,nltop,nlayr
1180        integer ntracer        integer ntracedim, ntracer
1181        integer ncrnd        integer ncrnd
1182        _RL dt        _RL dt
1183        _RL UOI(len,nlayr,ntracer),   POI(len,K)        _RL UOI(lng,nlayr,ntracedim),   POI(lng,K)
1184        _RL QOI(len,K), PRS(len,K+1), PRJ(len,K+1)        _RL QOI(lng,K), PRS(lng,K+1), PRJ(lng,K+1)
1185        _RL rnd(ncrnd)        _RL rnd(ncrnd)
1186        _RL RAINS(len,K), CLN(len,K), CLF(len,K)        _RL RAINS(lng,K), CLN(lng,K), CLF(lng,K)
1187        _RL cldmas(len,K), detrain(len,K)        _RL cldmas(lng,K), detrain(lng,K)
1188        _RL cp,grav,rkappa,alhl,rhfrac(len),rasmax        _RL cp,grav,rkappa,alhl,rhfrac(lng),rasmax
1189    
1190  C Local Variables  C Local Variables
1191        _RL TCU(len,K), QCU(len,K)        _RL TCU(lng,K), QCU(lng,K)
1192        _RL ucu(len,K,ntracer)        _RL ucu(lng,K,ntracedim)
1193        _RL ALF(len,K), BET(len,K), GAM(len,K)        _RL ALF(lng,K), BET(lng,K), GAM(lng,K)
1194       *,         ETA(len,K), HOI(len,K)       *,         ETA(lng,K), HOI(lng,K)
1195       *,         PRH(len,K), PRI(len,K)       *,         PRH(lng,K), PRI(lng,K)
1196        _RL HST(len,K), QOL(len,K), GMH(len,K)        _RL HST(lng,K), QOL(lng,K), GMH(lng,K)
1197    
1198        _RL TX1(len), TX2(len), TX3(len), TX4(len), TX5(len)        _RL TX1(lng), TX2(lng), TX3(lng), TX4(lng), TX5(lng)
1199       *,         TX6(len), TX7(len), TX8(len), TX9(len)       *,         TX6(lng), TX7(lng), TX8(lng), TX9(lng)
1200       *,         TX11(len), TX12(len), TX13(len), TX14(len,ntracer)       *,         TX11(lng), TX12(lng), TX13(lng), TX14(lng,ntracedim)
1201       *,         TX15(len)       *,         TX15(lng)
1202       *,         WFN(len)       *,         WFN(lng)
1203        integer IA1(len), IA2(len), IA3(len)        integer IA1(lng), IA2(lng), IA3(lng)
1204        _RL cloudn(len), pcu(len)        _RL cloudn(lng), pcu(lng)
1205    
1206        integer krmin,icm        integer krmin,icm
1207        _RL rknob, cmb2pa        _RL rknob, cmb2pa
# Line 1102  C Local Variables Line 1211  C Local Variables
1211        PARAMETER (rknob = 10.)        PARAMETER (rknob = 10.)
1212    
1213        integer IC(ICM),   IRND(icm)        integer IC(ICM),   IRND(icm)
1214        _RL cmass(len,K)        _RL cmass(lng,K)
1215        LOGICAL SETRAS        LOGICAL SETRAS
1216    
1217        integer i,L,nc,ib,nt        integer i,L,nc,ib,nt
# Line 1132  C Line 1241  C
1241         KPRV  = KM1         KPRV  = KM1
1242  C Removed KRMAX parameter  C Removed KRMAX parameter
1243         KCR   = MIN(KM1,nlayr-2)             KCR   = MIN(KM1,nlayr-2)    
1244         KFX   = KM1 - KCR  CCC    KFX   = KM1 - KCR
1245           KFX   = KM1
1246         NCMX  = KFX + NCRND         NCMX  = KFX + NCRND
1247  C  C
1248         IF (KFX .GT. 0) THEN         IF (KFX .GT. 0) THEN
# Line 1167  c ------------------------------- Line 1277  c -------------------------------
1277        cloudn(i) = 0.0        cloudn(i) = 0.0
1278        enddo        enddo
1279    
1280         CALL CLOUD(nn,LEN, LENC, K, NLTOP, nlayr, IB, RASBLF,SETRAS,FRAC         CALL CLOUD(nn,lng, LENC, K, NLTOP, nlayr, IB, RASBLF,SETRAS,FRAC
1281       *,           CP,  ALHL, RKAPPA, GRAV, P00, CRTMSF       *,           CP,  ALHL, RKAPPA, GRAV, P00, CRTMSF
1282       *,           POI, QOI, UOI, Ntracer, PRS, PRJ       *,           POI, QOI, UOI, ntracedim, Ntracer, PRS, PRJ
1283       *,           PCU, CLOUDN, TCU, QCU, UCU, CMASS       *,           PCU, CLOUDN, TCU, QCU, UCU, CMASS
1284       *,           ALF, BET, GAM, PRH, PRI, HOI, ETA       *,           ALF, BET, GAM, PRH, PRI, HOI, ETA
1285       *,           HST, QOL, GMH       *,           HST, QOL, GMH
# Line 1248  c -------------------------------------- Line 1358  c --------------------------------------
1358        integer irm        integer irm
1359        parameter (irm = 1000)        parameter (irm = 1000)
1360        _RL random(irm)        _RL random(irm)
1361        integer i,mcheck,numrand,iseed,index        integer i,mcheck,numrand,iseed,indx
1362        logical first        logical first
1363        data    first /.true./        data    first /.true./
1364        integer iras0        integer iras0
# Line 1259  c -------------------------------------- Line 1369  c --------------------------------------
1369         do i = 1,nrnd         do i = 1,nrnd
1370          rnd(i) = 0          rnd(i) = 0
1371         enddo         enddo
1372         if(first .and. myid.eq.0) print *,' NO RANDOM CLOUDS IN RAS '         if(first .and. myid.eq.1) print *,' NO RANDOM CLOUDS IN RAS '
1373         go to 100         go to 100
1374        endif        endif
1375    
# Line 1268  c -------------------------------------- Line 1378  c --------------------------------------
1378  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
1379  c ----------------------------------------------------------------------------  c ----------------------------------------------------------------------------
1380        if( first.and.(iras.gt.1) .or. iras.ne.iras0+1 )then        if( first.and.(iras.gt.1) .or. iras.ne.iras0+1 )then
1381         if( myid.eq.0 ) print *, 'Recreating Rand Numb Array in RNDCLOUD'         print *,' first ',first,' iras ',iras,' iras0 ',iras0
1382         if( myid.eq.0 ) print *, 'IRAS: ',iras,'  IRAS0: ',iras0         if( myid.eq.1 ) print *, 'Recreating Rand Numb Array in RNDCLOUD'
1383           if( myid.eq.1 ) print *, 'IRAS: ',iras,'  IRAS0: ',iras0
1384         numrand = mod(iras,irm/nrnd) * nrnd         numrand = mod(iras,irm/nrnd) * nrnd
1385         iseed   = iras * nrnd - numrand         iseed   = iras * nrnd - numrand
1386         call random_seedx(iseed)         call random_seedx(iseed)
1387         do i = 1,irm         do i = 1,irm
1388          random(i) = random_numbx(iseed)          random(i) = random_numbx(iseed)
1389         enddo         enddo
1390         index = (iras-1)*nrnd         indx = (iras-1)*nrnd
1391    
1392  c Multiple Time In But have Used Up all 1000 numbers (MCHECK.EQ.0)  c Multiple Time In But have Used Up all 1000 numbers (MCHECK.EQ.0)
1393  c ----------------------------------------------------------------  c ----------------------------------------------------------------
# Line 1286  c -------------------------------------- Line 1397  c --------------------------------------
1397            do i = 1,irm            do i = 1,irm
1398             random(i) = random_numbx(iseed)             random(i) = random_numbx(iseed)
1399            enddo            enddo
1400            index = iseed            indx = iseed
1401    
1402  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)
1403  c --------------------------------------------------------------------  c --------------------------------------------------------------------
1404        else        else
1405            index = (iras-1)*nrnd            indx = (iras-1)*nrnd
1406        endif        endif
1407    
1408            index = mod(index,irm)            indx = mod(indx,irm)
1409        if( index+nrnd.gt.1000 ) index=1000-nrnd        if( indx+nrnd.gt.1000 ) indx=1000-nrnd
1410    
1411        do n = 1,nrnd        do n = 1,nrnd
1412         rnd(n) = random(index+n)         rnd(n) = random(indx+n)
1413        enddo        enddo
1414    
1415   100  continue   100  continue
# Line 1337  c -------------------------------------- Line 1448  c --------------------------------------
1448  #endif  #endif
1449        return        return
1450        end        end
1451        SUBROUTINE CLOUD(nn,LEN, LENC, K, NLTOP, nlayr, IC, RASALF        SUBROUTINE CLOUD(nn,lng, LENC, K, NLTOP, nlayr, IC, RASALF
1452       *,                 SETRAS, FRAC       *,                 SETRAS, FRAC
1453       *,                 CP,  ALHL, RKAP, GRAV, P00, CRTMSF       *,                 CP,  ALHL, RKAP, GRAV, P00, CRTMSF
1454       *,                 POI, QOI, UOI, Ntracer, PRS,  PRJ       *,                 POI, QOI, UOI, ntracedim, Ntracer, PRS,  PRJ
1455       *,                 PCU, CLN, TCU, QCU, UCU, CMASS       *,                 PCU, CLN, TCU, QCU, UCU, CMASS
1456       *,                 ALF, BET, GAM, PRH, PRI, HOL, ETA       *,                 ALF, BET, GAM, PRH, PRI, HOL, ETA
1457       *,                 HST, QOL, GMH       *,                 HST, QOL, GMH
# Line 1379  C Line 1490  C
1490  C  Input:  C  Input:
1491  C  ------  C  ------
1492  C  C
1493  C     LEN     : The inner dimension of update and input arrays.  C     lng     : The inner dimension of update and input arrays.
1494  C  C
1495  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.
1496  C               RAS works on the first LENC of the LEN soundings  C               RAS works on the first LENC of the lng soundings
1497  C               passed. This allows working on pieces of the world  C               passed. This allows working on pieces of the world
1498  C               say for multitasking, without declaring temporary arrays  C               say for multitasking, without declaring temporary arrays
1499  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
1500  C               version. An F90 version would have to allow more  C               version. An F90 version would have to allow more
1501  C               flexibility in the argument declarations.  Obviously  C               flexibility in the argument declarations.  Obviously
1502  C               (LENC<=LEN).    C               (LENC<=lng).  
1503  C  C
1504  C     K       : Number of vertical layers (increasing downwards).  C     K       : Number of vertical layers (increasing downwards).
1505  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 1530  C     CRTMSF  : Critical value of mass f
1530  C               the detrainment layer of that cloud-type is assumed.  C               the detrainment layer of that cloud-type is assumed.
1531  C               Affects only cloudiness calculation.  C               Affects only cloudiness calculation.
1532  C  C
1533  C     POI     : 2D array of dimension (LEN,K) containing potential  C     POI     : 2D array of dimension (lng,K) containing potential
1534  C               temperature. Updated but not initialized by RAS.  C               temperature. Updated but not initialized by RAS.
1535  C  C
1536  C     QOI     : 2D array of dimension (LEN,K) containing specific  C     QOI     : 2D array of dimension (lng,K) containing specific
1537  C               humidity. Updated but not initialized by RAS.  C               humidity. Updated but not initialized by RAS.
1538  C  C
1539  C     UOI     : 3D array of dimension (LEN,K,NTRACER) containing tracers  C     UOI     : 3D array of dimension (lng,K,NTRACER) containing tracers
1540  C               Updated but not initialized by RAS.  C               Updated but not initialized by RAS.
1541  C  C
1542  C     PRS     : 2D array of dimension (LEN,K+1) containing pressure  C     PRS     : 2D array of dimension (lng,K+1) containing pressure
1543  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
1544  C               atmosphere to the bottom. Not modified.  C               atmosphere to the bottom. Not modified.
1545  C  C
1546  C     PRJ     : 2D array of dimension (LEN,K+1) containing (PRS/P00) **  C     PRJ     : 2D array of dimension (lng,K+1) containing (PRS/P00) **
1547  C               RKAP.  i.e. Exner function at layer edges. Not modified.  C               RKAP.  i.e. Exner function at layer edges. Not modified.
1548  C  C
1549  C     rhfrac  : 1D array of dimension (LEN) containing a rel.hum. scaling  C     rhfrac  : 1D array of dimension (lng) containing a rel.hum. scaling
1550  C               fraction. Not modified.  C               fraction. Not modified.
1551  C  C
1552  C  Output:  C  Output:
1553  C  -------  C  -------
1554  C  C
1555  C     PCU     : 1D array of length LEN containing accumulated  C     PCU     : 1D array of length lng containing accumulated
1556  C               precipitation in mm/sec.  C               precipitation in mm/sec.
1557  C  C
1558  C     CLN     : 2D array of dimension (LEN,K) containing cloudiness  C     CLN     : 2D array of dimension (lng,K) containing cloudiness
1559  C               Note:  CLN is bumped but NOT initialized  C               Note:  CLN is bumped but NOT initialized
1560  C  C
1561  C     TCU     : 2D array of dimension (LEN,K) containing accumulated  C     TCU     : 2D array of dimension (lng,K) containing accumulated
1562  C               convective heating (K/sec).  C               convective heating (K/sec).
1563  C  C
1564  C     QCU     : 2D array of dimension (LEN,K) containing accumulated  C     QCU     : 2D array of dimension (lng,K) containing accumulated
1565  C               convective drying (kg/kg/sec).  C               convective drying (kg/kg/sec).
1566  C  C
1567  C     CMASS   : 2D array of dimension (LEN,K) containing the  C     CMASS   : 2D array of dimension (lng,K) containing the
1568  C               cloud mass flux (kg/sec). Filled from cloud top  C               cloud mass flux (kg/sec). Filled from cloud top
1569  C               to base.  C               to base.
1570  C  C
# Line 1473  C Line 1584  C
1584  C************************************************************************  C************************************************************************
1585        implicit none        implicit none
1586  C Argument List declarations  C Argument List declarations
1587        integer nn,LEN,LENC,K,NLTOP,nlayr,ic,ntracer        integer nn,lng,LENC,K,NLTOP,nlayr,ic,ntracedim, ntracer
1588        _RL rasalf        _RL rasalf
1589        LOGICAL SETRAS        LOGICAL SETRAS
1590        _RL frac, cp,  alhl, rkap, grav, p00, crtmsf        _RL frac, cp,  alhl, rkap, grav, p00, crtmsf
1591        _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)
1592        _RL uoi(len,nlayr,ntracer)        _RL uoi(lng,nlayr,ntracedim)
1593        _RL PCU(LENC), CLN(LEN)        _RL PCU(LENC), CLN(lng)
1594        _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)
1595        _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)
1596        _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)
1597        _RL GMH(LENC,K)        _RL GMH(LENC,K)
1598        _RL TX1(LENC), TX2(LENC), TX3(LENC), TX4(LENC)        _RL TX1(LENC), TX2(LENC), TX3(LENC), TX4(LENC)
1599        _RL TX5(LENC), TX6(LENC), TX7(LENC), TX8(LENC)        _RL TX5(LENC), TX6(LENC), TX7(LENC), TX8(LENC)
1600        _RL ALM(LENC), WFN(LENC), AKM(LENC), QS1(LENC)        _RL ALM(LENC), WFN(LENC), AKM(LENC), QS1(LENC)
1601        _RL WLQ(LENC), CLF(LENC)        _RL WLQ(LENC), CLF(LENC)
1602        _RL uht(len,ntracer)        _RL uht(lng,ntracedim)
1603        integer IA(LENC), I1(LENC),I2(LENC)        integer IA(LENC), I1(LENC),I2(LENC)
1604        _RL      rhfrac(len)        _RL      rhfrac(lng)
1605    
1606  C Local Variables  C Local Variables
1607        _RL daylen,half,one,zero,cmb2pa,rhmax        _RL daylen,half,one,zero,cmb2pa,rhmax
# Line 1500  C Local Variables Line 1611  C Local Variables
1611        _RL rkapp1,onebcp,albcp,onebg,cpbg,twobal        _RL rkapp1,onebcp,albcp,onebg,cpbg,twobal
1612  C  C
1613        integer nt,km1,ic1,i,L,len1,len2,isav,len11,ii        integer nt,km1,ic1,i,L,len1,len2,isav,len11,ii
1614        integer lena,lena1,lenb,tem,tem1        integer lena,lena1,lenb
1615          _RL tem,tem1
1616    
1617  c Explicit Inline Directives  c Explicit Inline Directives
1618  c --------------------------  c --------------------------
# Line 1516  cfpp$ expand (qsat) Line 1628  cfpp$ expand (qsat)
1628        ONEBG  = 1.0  / GRAV        ONEBG  = 1.0  / GRAV
1629        CPBG   = CP   * ONEBG        CPBG   = CP   * ONEBG
1630        TWOBAL = 2.0 / ALHL        TWOBAL = 2.0 / ALHL
1631    
1632  C  C
1633        KM1 = K  - 1        KM1 = K  - 1
1634        IC1 = IC + 1        IC1 = IC + 1
# Line 1549  C Line 1662  C
1662  C  C
1663  C  C
1664        DO 10 L=1,K        DO 10 L=1,K
1665        DO 10 I=1,LEN        DO 10 I=1,lng
1666        TCU(I,L) = 0.0        TCU(I,L) = 0.0
1667        QCU(I,L) = 0.0        QCU(I,L) = 0.0
1668        CMASS(I,L) = 0.0        CMASS(I,L) = 0.0
# Line 1817  C Line 1930  C
1930        DO I=1,LENB        DO I=1,LENB
1931        II = I1(I)        II = I1(I)
1932        TEM    = ETA(I,L) - ETA(I,L+1)        TEM    = ETA(I,L) - ETA(I,L+1)
1933        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)
1934        ENDDO        ENDDO
1935        ENDDO        ENDDO
1936        ENDDO        ENDDO
# Line 2037  C Line 2150  C
2150  c Compute Tracer Tendencies  c Compute Tracer Tendencies
2151  c -------------------------  c -------------------------
2152        do nt = 1,ntracer        do nt = 1,ntracer
2153    c
2154  c Tracer Tendency at the Bottom Layer  c Tracer Tendency at the Bottom Layer
2155  c -----------------------------------  c -----------------------------------
2156        DO 995 I=1,LENB        DO 995 I=1,LENB
2157        II = I1(I)        II = I1(I)
2158        TEM    = half*TX5(I) * PRI(II,K)        TEM    = half*TX5(I) * PRI(II,K)
2159        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))
2160        ucu(II,K,nt) = TEM * TX1(I)        ucu(II,K,nt) = TEM * TX1(I)
2161    995 CONTINUE    995 CONTINUE
2162    c
2163  c Tracer Tendency at all other Levels  c Tracer Tendency at all other Levels
2164  c -----------------------------------  c -----------------------------------
2165        DO 1020 L=KM1,IC1,-1        DO 1020 L=KM1,IC1,-1
# Line 2061  c ----------------------------------- Line 2174  c -----------------------------------
2174        II = I1(I)        II = I1(I)
2175        ucu(II,L,nt) = TX3(I)        ucu(II,L,nt) = TX3(I)
2176   1020 CONTINUE   1020 CONTINUE
2177    
2178        DO 1030 I=1,LENB        DO 1030 I=1,LENB
2179        II = I1(I)        II = I1(I)
2180        IF (TX6(I) .GE. 1.0) THEN        IF (TX6(I) .GE. 1.0) THEN
# Line 2075  c ----------------------------------- Line 2188  c -----------------------------------
2188        II = I1(I)        II = I1(I)
2189        ucu(II,IC,nt) = TX1(I)        ucu(II,IC,nt) = TX1(I)
2190   1040 CONTINUE   1040 CONTINUE
2191    
2192        enddo        enddo
2193  C  C
2194  C     PENETRATIVE CONVECTION CALCULATION OVER  C     PENETRATIVE CONVECTION CALCULATION OVER
# Line 2083  C Line 2196  C
2196    
2197        RETURN        RETURN
2198        END        END
2199        SUBROUTINE RNCL(LEN, PL, RNO, CLF)        SUBROUTINE RNCL(lng, PL, RNO, CLF)
2200  C  C
2201  C*********************************************************************  C*********************************************************************
2202  C********************** Relaxed Arakawa-Schubert *********************  C********************** Relaxed Arakawa-Schubert *********************
# Line 2092  C**************************** 23 July 19 Line 2205  C**************************** 23 July 19
2205  C*********************************************************************  C*********************************************************************
2206        implicit none        implicit none
2207  C Argument List declarations  C Argument List declarations
2208        integer len        integer lng
2209        _RL PL(LEN),  RNO(LEN), CLF(LEN)        _RL PL(lng),  RNO(lng), CLF(lng)
2210    
2211  C Local Variables  C Local Variables
2212        _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 2218  C Local Variables
2218    
2219        integer i        integer i
2220  C  C
2221        DO 10 I=1,LEN        DO 10 I=1,lng
2222                             rno(i) = 1.0                             rno(i) = 1.0
2223  ccc   if( pl(i).le.400.0 ) rno(i) = max( 0.75, 1.0-0.0025*(400.0-pl(i)) )  ccc   if( pl(i).le.400.0 ) rno(i) = max( 0.75, 1.0-0.0025*(400.0-pl(i)) )
2224    
# Line 2132  CARIES Line 2245  CARIES
2245  C  C
2246        RETURN        RETURN
2247        END        END
2248        SUBROUTINE ACRITN ( LEN,PL,PLB,ACR )        SUBROUTINE ACRITN ( lng,PL,PLB,ACR )
2249    
2250  C*********************************************************************  C*********************************************************************
2251  C********************** Relaxed Arakawa-Schubert *********************  C********************** Relaxed Arakawa-Schubert *********************
# Line 2145  C**** Line 2258  C****
2258  C*********************************************************************  C*********************************************************************
2259        implicit none        implicit none
2260  C Argument List declarations  C Argument List declarations
2261        integer len        integer lng
2262        _RL PL(LEN), PLB(LEN), ACR(LEN)        _RL PL(lng), PLB(lng), ACR(lng)
2263    
2264  C Local variables  C Local variables
2265        integer lma        integer lma
# Line 2168  C Local variables Line 2281  C Local variables
2281    
2282    
2283        do L=1,lma-1        do L=1,lma-1
2284        do i=1,len        do i=1,lng
2285           if( pl(i).ge.p(L)   .and.           if( pl(i).ge.p(L)   .and.
2286       .       pl(i).le.p(L+1)) then       .       pl(i).le.p(L+1)) then
2287           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 2290  C Local variables
2290        enddo        enddo
2291        enddo        enddo
2292    
2293        do i=1,len        do i=1,lng
2294        if( pl(i).lt.p(1)   ) acr(i) = a(1)        if( pl(i).lt.p(1)   ) acr(i) = a(1)
2295        if( pl(i).gt.p(lma) ) acr(i) = a(lma)        if( pl(i).gt.p(lma) ) acr(i) = a(lma)
2296        enddo        enddo
2297    
2298        do i=1,len        do i=1,lng
2299        acr(i) = acr(i) * (plb(i)-pl(i))        acr(i) = acr(i) * (plb(i)-pl(i))
2300        enddo        enddo
2301    
Legend:
Removed from v.1.13  
changed lines
  Added in v.1.21
  ViewVC Help
Powered by ViewVC 1.1.22