--- MITgcm/pkg/fizhi/fizhi_moist.F 2004/07/07 19:33:48 1.4 +++ MITgcm/pkg/fizhi/fizhi_moist.F 2004/07/26 18:45:17 1.13 @@ -1,105 +1,95 @@ -C $Header: /home/ubuntu/mnt/e9_copy/MITgcm/pkg/fizhi/fizhi_moist.F,v 1.4 2004/07/07 19:33:48 molod Exp $ +C $Header: /home/ubuntu/mnt/e9_copy/MITgcm/pkg/fizhi/fizhi_moist.F,v 1.13 2004/07/26 18:45:17 molod Exp $ C $Name: $ -#include "CPP_OPTIONS.h" - subroutine moistio (ndmoist,istrip,npcs,pz,tz,qz,bi,bj, - . ntracer,ptracer, +#include "FIZHI_OPTIONS.h" + subroutine moistio (ndmoist,istrip,npcs, . lowlevel,midlevel,nltop,nsubmin,nsubmax,Lup, - . pkht,qqz,dumoist,dvmoist,dtmoist,dqmoist, + . pz,plz,plze,dpres,pkht,pkl,tz,qz,bi,bj,ntracer,ptracer, + . qqz,dumoist,dvmoist,dtmoist,dqmoist, . im,jm,lm,ptop, . iras,rainlsp,rainconv,snowfall, . nswcld,cldtot_sw,cldras_sw,cldlsp_sw,nswlz,swlz, . nlwcld,cldtot_lw,cldras_lw,cldlsp_lw,nlwlz,lwlz, . lpnt,myid) + implicit none + #ifdef ALLOW_DIAGNOSTICS +#include "SIZE.h" +#include "diagnostics_SIZE.h" #include "diagnostics.h" #endif c Input Variables c --------------- - integer ndmoist,istrip,npcs,myid,bi,bj + integer im,jm,lm + integer ndmoist,istrip,npcs + integer bi,bj,ntracer,ptracer integer lowlevel,midlevel,nltop,nsubmin,nsubmax,Lup - - integer im,jm,lm - real ptop - - integer ntracer,ptracer - - real pz(im,jm) - real tz(im,jm,lm) - real qz(im,jm,lm,ntracer) - - real pkht(im,jm,lm) - - real qqz(im,jm,lm) - - real dumoist(im,jm,lm) - real dvmoist(im,jm,lm) - real dtmoist(im,jm,lm) - real dqmoist(im,jm,lm,ntracer) - - integer iras - real rainlsp(im,jm) - real rainconv(im,jm) - real snowfall(im,jm) - - integer nswcld,nswlz - real cldlsp_sw(im,jm,lm) - real cldras_sw(im,jm,lm) - real cldtot_sw(im,jm,lm) - real swlz(im,jm,lm) - - integer nlwcld,nlwlz - real cldlsp_lw(im,jm,lm) - real cldras_lw(im,jm,lm) - real cldtot_lw(im,jm,lm) - real lwlz(im,jm,lm) - - logical lpnt + _RL pz(im,jm),plz(im,jm,lm),plze(im,jm,lm+1),dpres(im,jm,lm) + _RL pkht(im,jm,lm+1),pkl(im,jm,lm) + _RL tz(im,jm,lm),qz(im,jm,lm,ntracer) + _RL qqz(im,jm,lm) + _RL dumoist(im,jm,lm),dvmoist(im,jm,lm) + _RL dtmoist(im,jm,lm),dqmoist(im,jm,lm,ntracer) + _RL ptop + integer iras + _RL rainlsp(im,jm),rainconv(im,jm),snowfall(im,jm) + integer nswcld,nswlz + _RL cldlsp_sw(im,jm,lm),cldras_sw(im,jm,lm) + _RL cldtot_sw(im,jm,lm),swlz(im,jm,lm) + integer nlwcld,nlwlz + _RL cldlsp_lw(im,jm,lm),cldras_lw(im,jm,lm) + _RL cldtot_lw(im,jm,lm),lwlz(im,jm,lm) + logical lpnt + integer myid c Local Variables c --------------- integer ncrnd,nsecf - real fracqq, rh,temp1,temp2,dum + _RL fracqq, dum integer snowcrit parameter (fracqq = 0.1) - real cldsr(im,jm,lm) - real srcld(istrip,lm) + _RL cldsr(im,jm,lm) + _RL srcld(istrip,lm) - real plev - real cldnow,cldlsp_mem,cldras_mem,cldras,watnow,watmin,cldmin - real cldprs(im,jm),cldtmp(im,jm) - real cldhi (im,jm),cldlow(im,jm) - real cldmid(im,jm),totcld(im,jm) - - real CLDLS(im,jm,lm) , CPEN(im,jm,lm) - real tmpimjm(im,jm) - real lsp_new(im,jm) - real conv_new(im,jm) - real snow_new(im,jm) + _RL plev + _RL cldnow,cldlsp_mem,cldlsp,cldras_mem,cldras + _RL watnow,watmin,cldmin + _RL cldprs(im,jm),cldtmp(im,jm) + _RL cldhi (im,jm),cldlow(im,jm) + _RL cldmid(im,jm),totcld(im,jm) + + _RL CLDLS(im,jm,lm) , CPEN(im,jm,lm) + _RL tmpimjm(im,jm) + _RL lsp_new(im,jm) + _RL conv_new(im,jm) + _RL snow_new(im,jm) - real qqcolmin(im,jm) - real qqcolmax(im,jm) + _RL qqcolmin(im,jm) + _RL qqcolmax(im,jm) integer levpbl(im,jm) c Gathered Arrays for Variable Cloud Base c --------------------------------------- - real raincgath(im*jm) - real pigather(im*jm) - real thgather(im*jm,lm) - real shgather(im*jm,lm) - real pkzgather(im*jm,lm) - real pkegather(im*jm,lm) - real tmpgather(im*jm,lm) - real deltgather(im*jm,lm) - real delqgather(im*jm,lm) - real ugather(im*jm,lm,ntracer) - real delugather(im*jm,lm,ntracer) - real deltrnev(im*jm,lm) - real delqrnev(im*jm,lm) + _RL raincgath(im*jm) + _RL pigather(im*jm) + _RL thgather(im*jm,lm) + _RL shgather(im*jm,lm) + _RL pkzgather(im*jm,lm) + _RL pkegather(im*jm,lm+1) + _RL plzgather(im*jm,lm) + _RL plegather(im*jm,lm+1) + _RL dpgather(im*jm,lm) + _RL tmpgather(im*jm,lm) + _RL deltgather(im*jm,lm) + _RL delqgather(im*jm,lm) + _RL ugather(im*jm,lm,ntracer) + _RL delugather(im*jm,lm,ntracer) + _RL deltrnev(im*jm,lm) + _RL delqrnev(im*jm,lm) integer nindeces(lm) integer pblindex(im*jm) @@ -107,51 +97,51 @@ c Stripped Arrays c --------------- - real saveth (istrip,lm) - real saveq (istrip,lm) - real saveu (istrip,lm,ntracer) - real usubcl (istrip, ntracer) - - real ple(istrip,lm+1), gam(istrip,lm) - real TL(ISTRIP,lm) , SHL(ISTRIP,lm) - real PL(ISTRIP,lm) , PLK(ISTRIP,lm) - real PLKE(ISTRIP,lm+1) - real TH(ISTRIP,lm) ,CVTH(ISTRIP,lm) - real SHSAT(ISTRIP,lm) , CVQ(ISTRIP,lm) - real UL(ISTRIP,lm,ntracer) - real cvu(istrip,lm,ntracer) - real CLMAXO(ISTRIP,lm),CLBOTH(ISTRIP,lm) - real CLSBTH(ISTRIP,lm) - real TMP1(ISTRIP,lm), TMP2(ISTRIP,lm) - real TMP3(ISTRIP,lm), TMP4(ISTRIP,lm+1) - real TMP5(ISTRIP,lm+1) + _RL saveth (istrip,lm) + _RL saveq (istrip,lm) + _RL saveu (istrip,lm,ntracer) + _RL usubcl (istrip, ntracer) + + _RL ple(istrip,lm+1) + _RL dp(istrip,lm) + _RL TL(ISTRIP,lm) , SHL(ISTRIP,lm) + _RL PL(ISTRIP,lm) , PLK(ISTRIP,lm) + _RL PLKE(ISTRIP,lm+1) + _RL TH(ISTRIP,lm) ,CVTH(ISTRIP,lm) + _RL CVQ(ISTRIP,lm) + _RL UL(ISTRIP,lm,ntracer) + _RL cvu(istrip,lm,ntracer) + _RL CLMAXO(ISTRIP,lm),CLBOTH(ISTRIP,lm) + _RL CLSBTH(ISTRIP,lm) + _RL TMP1(ISTRIP,lm), TMP2(ISTRIP,lm) + _RL TMP3(ISTRIP,lm), TMP4(ISTRIP,lm+1) + _RL TMP5(ISTRIP,lm+1) integer ITMP1(ISTRIP,lm), ITMP2(ISTRIP,lm) - integer ITMP3(ISTRIP,lm) - real PRECIP(ISTRIP), PCMID(ISTRIP), PCNET(ISTRIP) - real PCLOW (ISTRIP), SP(ISTRIP), PREP(ISTRIP) - real PCPEN (ISTRIP,lm) + _RL PRECIP(ISTRIP), PCNET(ISTRIP) + _RL SP(ISTRIP), PREP(ISTRIP) + _RL PCPEN (ISTRIP,lm) integer pbl(istrip),depths(lm) - real cldlz(istrip,lm), cldwater(im,jm,lm) - real rhfrac(istrip), rhmin, pup, ppbl, rhcrit(istrip,lm) - real offset, alpha, rasmax + _RL cldlz(istrip,lm), cldwater(im,jm,lm) + _RL rhfrac(istrip), rhmin, pup, ppbl, rhcrit(istrip,lm) + _RL offset, alpha, rasmax logical first logical lras - real clfrac (istrip,lm) - real cldmas (istrip,lm) - real detrain(istrip,lm) - real psubcld (istrip), psubcldg (im,jm) - real psubcld_cnt(istrip), psubcldgc(im,jm) - real rnd(lm/2) + _RL clfrac (istrip,lm) + _RL cldmas (istrip,lm) + _RL detrain(istrip,lm) + _RL psubcld (istrip), psubcldg (im,jm) + _RL psubcld_cnt(istrip), psubcldgc(im,jm) + _RL rnd(lm/2) DATA FIRST /.TRUE./ integer imstp,nsubcl,nlras integer i,j,iloop,index,l,nn,num,numdeps,nt - real tmstp,tminv,sday,grav,alhl,cp,elocp,gamfac - real rkappa,p0kappa,p0kinv,ptopkap,pcheck - real tice,getcon,pi + _RL tmstp,tminv,sday,grav,alhl,cp,elocp,gamfac + _RL rkappa,p0kappa,p0kinv,ptopkap,pcheck + _RL tice,getcon,pi C ********************************************************************** C **** INITIALIZATION **** @@ -253,14 +243,19 @@ do index = 1,im*jm levgather(index) = levpbl(pblindex(index),1) pigather(index) = pz(pblindex(index),1) + pkegather(index,lm+1) = pkht(pblindex(index),1,lm+1) + plegather(index,lm+1) = plze(pblindex(index),1,lm+1) enddo do L = 1,lm do index = 1,im*jm - thgather(index,L) = tz(pblindex(index),1,L) - shgather(index,L) = qz(pblindex(index),1,L,1) + thgather(index,L) = tz(pblindex(index),1,L) + shgather(index,L) = qz(pblindex(index),1,L,1) pkegather(index,L) = pkht(pblindex(index),1,L) - pkzgather(index,L) = pkl (pblindex(index),1,L) + pkzgather(index,L) = pkl(pblindex(index),1,L) + plegather(index,L) = plze(pblindex(index),1,L) + plzgather(index,L) = plz(pblindex(index),1,L) + dpgather(index,L) = dpres(pblindex(index),1,L) enddo enddo do nt = 1,ntracer-ptracer @@ -303,7 +298,10 @@ CALL STRIP ( pigather, SP ,im*jm,ISTRIP,1 ,NN ) CALL STRIP ( pkzgather, PLK ,im*jm,ISTRIP,lm,NN ) - CALL STRIP ( pkegather, PLKE ,im*jm,ISTRIP,lm,NN ) + CALL STRIP ( pkegather, PLKE ,im*jm,ISTRIP,lm+1,NN ) + CALL STRIP ( plzgather, PL ,im*jm,ISTRIP,lm,NN ) + CALL STRIP ( plegather, PLE ,im*jm,ISTRIP,lm+1,NN ) + CALL STRIP ( dpgather, dp ,im*jm,ISTRIP,lm,NN ) CALL STRIP ( thgather, TH ,im*jm,ISTRIP,lm,NN ) CALL STRIP ( shgather, SHL ,im*jm,ISTRIP,lm,NN ) CALL STRINT( levgather, pbl ,im*jm,ISTRIP,1 ,NN ) @@ -312,17 +310,6 @@ call strip ( ugather(1,1,nt), ul(1,1,nt),im*jm,istrip,lm,nn ) enddo - do l = 1,lm - do i = 1,istrip - PL(I,L) = SIG(L)*SP(I) + PTOP - PLE(I,L) = SIGE(L)*SP(I) + PTOP - enddo - enddo - - do i = 1,istrip - PLE(I,lm+1) = SP(I) + PTOP - enddo - C ********************************************************************** C **** SETUP FOR RAS CUMULUS PARAMETERIZATION **** C ********************************************************************** @@ -418,16 +405,16 @@ ENDDO DO L=2,lm DO I=num,num+nindeces(nsubcl)-1 - TMP5(I,L) = PLKE(I,L-1)*P0KINV + TMP5(I,L) = PLKE(I,L)*P0KINV ENDDO ENDDO DO I=num,num+nindeces(nsubcl)-1 TMP4(I,lm+1) = PLE (I,lm+1) - TMP5(I,lm+1) = PLKE(I,lm)*P0KINV + TMP5(I,lm+1) = PLKE(I,lm+1)*P0KINV ENDDO DO 113 I=num,num+nindeces(nsubcl)-1 TMP4(I,NSUBCL+1) = PLE (I,lm+1) - TMP5(I,NSUBCL+1) = PLKE(I,lm)*P0KINV + TMP5(I,NSUBCL+1) = PLKE(I,lm+1)*P0KINV 113 CONTINUE do i=num,num+nindeces(nsubcl)-1 @@ -464,11 +451,11 @@ rhcrit(i,L) = 1. enddo do L = 1, nsubcl-1 - pcheck = (1000.-ptop)*sig(L) + ptop + pcheck = pl(i,L) if (pcheck .le. pup) then rhcrit(i,L) = rhmin else - ppbl = (1000.-ptop)*sig(nsubcl) + ptop + ppbl = pl(i,nsubcl) rhcrit(i,L) = rhmin + (1.-rhmin)/(19.) * . ((atan( (2.*(pcheck-pup)/(ppbl-pup)-1.) * . tan(20.*pi/21.-0.5*pi) ) @@ -498,8 +485,8 @@ c Compute Diagnostic CLDMAS in RAS Subcloud Layers c ------------------------------------------------ do L=nsubcl,lm - dum = dsig(L)/(1.0-sige(nsubcl)) do I=num,num+nindeces(nsubcl)-1 + dum = dp(i,L)/(ple(i,lm+1)-ple(i,nsubcl)) cldmas(i,L) = cldmas(i,L-1) - dum*cldmas(i,nsubcl-1) enddo enddo @@ -613,7 +600,7 @@ ENDDO ENDDO - CALL RNEVP (NN,ISTRIP,lm,TL,SHL,PCPEN,PL,CLFRAC,SP,DSIG,PLKE, + CALL RNEVP (NN,ISTRIP,lm,TL,SHL,PCPEN,PL,CLFRAC,SP,DP,PLKE, . PLK,TH,TMP1,TMP2,TMP3,ITMP1,ITMP2,PCNET,PRECIP, . CLSBTH,TMSTP,1.,cp,grav,alhl,gamfac,cldlz,rhcrit,offset,alpha) @@ -787,46 +774,6 @@ C BUMP DIAGNOSTICS C ********************************************************************** -c Clear-Sky (Above 400mb) Temperature -c ----------------------------------- - if( itmpuclr.ne.0 .or. isphuclr.ne.0 ) then - do j = 1,jm - do i = 1,im - totcld(i,j) = 0.0 - enddo - enddo - do L = 1,midlevel - do j = 1,jm - do i = 1,im - if(cldls(i,j,L).ne.0.0.or.cpen(i,j,L).ne.0.0)totcld(i,j) = 1.0 - enddo - enddo - enddo - do L = 1,lm - if( itmpuclr.ne.0 ) then - do i = 1,im*jm - if( totcld(i,1).eq.0.0 ) then - qdiag(i,1,itmpuclr +L-1,bi,bj) = - . qdiag(i,1,itmpuclr +L-1,bi,bj) + tz(i,1,L)*pkzgather(i,L) - qdiag(i,1,itmpuclrc+L-1,bi,bj) = - . qdiag(i,1,itmpuclrc+L-1,bi,bj)+1.0 - endif - enddo - endif - - if( isphuclr.ne.0 ) then - do i = 1,im*jm - if( totcld(i,1).eq.0.0 ) then - qdiag(i,1,isphuclr +L-1,bi,bj) = - . qdiag(i,1,isphuclr +L-1,bi,bj) + qz(i,1,L,1)*1000.0 - qdiag(i,1,isphuclrc+L-1,bi,bj) = - . qdiag(i,1,isphuclrc+L-1,bi,bj) + 1.0 - endif - enddo - endif - enddo - endif - c Sub-Cloud Layer c ------------------------- if( ipsubcld.ne.0 ) then @@ -981,7 +928,7 @@ do L = 1,lm do i = 1,im*jm - plev = sig(L)*pz(i,1)+ptop + plev = pl(i,L) c Compute Time-averaged Cloud and Water Amounts for Longwave Radiation c -------------------------------------------------------------------- @@ -1113,49 +1060,60 @@ *, cp,grav,rkappa,alhl,rhfrac,rasmax ) C C********************************************************************* -C*********************** ARIES MODEL ******************************* C********************* SUBROUTINE RAS ***************************** C********************** 16 MARCH 1988 ****************************** C********************************************************************* C - PARAMETER (KRMIN=01) - PARAMETER (ICM=1000) - PARAMETER (CMB2PA=100.0) - PARAMETER (rknob = 10.) -C + implicit none + +C Argument List + integer nn,len,lenc,k,nltop,nlayr integer ntracer - integer nltop,nlayr - DIMENSION UOI(len,nlayr,ntracer), POI(len,K) - DIMENSION QOI(len,K), PRS(len,K+1), PRJ(len,K+1) - dimension rnd(ncrnd) -C - DIMENSION RAINS(len,K), CLN(len,K), CLF(len,K) - DIMENSION cldmas(len,K), detrain(len,K) - DIMENSION TCU(len,K), QCU(len,K) - real ucu(len,K,ntracer) - DIMENSION ALF(len,K), BET(len,K), GAM(len,K) + integer ncrnd + _RL dt + _RL UOI(len,nlayr,ntracer), POI(len,K) + _RL QOI(len,K), PRS(len,K+1), PRJ(len,K+1) + _RL rnd(ncrnd) + _RL RAINS(len,K), CLN(len,K), CLF(len,K) + _RL cldmas(len,K), detrain(len,K) + _RL cp,grav,rkappa,alhl,rhfrac(len),rasmax + +C Local Variables + _RL TCU(len,K), QCU(len,K) + _RL ucu(len,K,ntracer) + _RL ALF(len,K), BET(len,K), GAM(len,K) *, ETA(len,K), HOI(len,K) *, PRH(len,K), PRI(len,K) - DIMENSION HST(len,K), QOL(len,K), GMH(len,K) + _RL HST(len,K), QOL(len,K), GMH(len,K) - DIMENSION TX1(len), TX2(len), TX3(len), TX4(len), TX5(len) + _RL TX1(len), TX2(len), TX3(len), TX4(len), TX5(len) *, TX6(len), TX7(len), TX8(len), TX9(len) *, TX11(len), TX12(len), TX13(len), TX14(len,ntracer) - *, TX15(len), TX16(len) - *, WFN(len), IA1(len), IA2(len), IA3(len) - DIMENSION cloudn(len), pcu(len) + *, TX15(len) + *, WFN(len) + integer IA1(len), IA2(len), IA3(len) + _RL cloudn(len), pcu(len) - real rhfrac(len),rasmax - - DIMENSION IC(ICM), IRND(icm) - dimension cmass(len,K) + integer krmin,icm + _RL rknob, cmb2pa + PARAMETER (KRMIN=01) + PARAMETER (ICM=1000) + PARAMETER (CMB2PA=100.0) + PARAMETER (rknob = 10.) + + integer IC(ICM), IRND(icm) + _RL cmass(len,K) LOGICAL SETRAS - - do L = 1,k - do I = 1,LENC - rains(i,l) = 0. - enddo - enddo + + integer i,L,nc,ib,nt + integer km1,kp1,kprv,kcr,kfx,ncmx + _RL p00, crtmsf, frac, rasblf + + do L = 1,k + do I = 1,LENC + rains(i,l) = 0. + enddo + enddo p00 = 1000. crtmsf = 0. @@ -1282,15 +1240,14 @@ RETURN END - subroutine rndcloud (iras,nrnd,rnd,myid) implicit none integer n,iras,nrnd,myid - real random_numbx - real rnd(nrnd) + _RL random_numbx + _RL rnd(nrnd) integer irm parameter (irm = 1000) - real random(irm) + _RL random(irm) integer i,mcheck,numrand,iseed,index logical first data first /.true./ @@ -1317,7 +1274,7 @@ iseed = iras * nrnd - numrand call random_seedx(iseed) do i = 1,irm - random(i) = random_numbx() + random(i) = random_numbx(iseed) enddo index = (iras-1)*nrnd @@ -1327,7 +1284,7 @@ iseed = (iras-1)*nrnd call random_seedx(iseed) do i = 1,irm - random(i) = random_numbx() + random(i) = random_numbx(iseed) enddo index = iseed @@ -1349,34 +1306,38 @@ iras0 = iras return end - - real function random_numbx() + function random_numbx(iseed) implicit none -#if CRAY - real ranf + integer iseed + real *8 seed,port_rand + _RL random_numbx + random_numbx = 0 +#ifdef CRAY + _RL ranf random_numbx = ranf() -#endif -#if SGI - real rand +#else +#ifdef SGI + _RL rand random_numbx = rand() #endif + random_numbx = port_rand(seed) +#endif return end subroutine random_seedx (iseed) implicit none integer iseed -#if CRAY +#ifdef CRAY call ranset (iseed) #endif -#if SGI +#ifdef SGI integer*4 seed seed = iseed call srand (seed) #endif return end - - SUBROUTINE CLOUD(nn,LEN, LENC, K, NLTOP, nlayr, IC, RASALF, + SUBROUTINE CLOUD(nn,LEN, LENC, K, NLTOP, nlayr, IC, RASALF *, SETRAS, FRAC *, CP, ALHL, RKAP, GRAV, P00, CRTMSF *, POI, QOI, UOI, Ntracer, PRS, PRJ @@ -1510,37 +1471,41 @@ C C C************************************************************************ -C -C + implicit none +C Argument List declarations + integer nn,LEN,LENC,K,NLTOP,nlayr,ic,ntracer + _RL rasalf + LOGICAL SETRAS + _RL frac, cp, alhl, rkap, grav, p00, crtmsf + _RL POI(LEN,K),QOI(LEN,K),PRS(LEN,K+1),PRJ(LEN,K+1) + _RL uoi(len,nlayr,ntracer) + _RL PCU(LENC), CLN(LEN) + _RL TCU(LEN,K), QCU(LEN,K), ucu(len,k,ntracer), CMASS(LEN,K) + _RL ALF(LEN,K), BET(LEN,K), GAM(LEN,K), PRH(LEN,K), PRI(LEN,K) + _RL HOL(LENC,K), ETA(LENC,K), HST(LENC,K), QOL(LENC,K) + _RL GMH(LENC,K) + _RL TX1(LENC), TX2(LENC), TX3(LENC), TX4(LENC) + _RL TX5(LENC), TX6(LENC), TX7(LENC), TX8(LENC) + _RL ALM(LENC), WFN(LENC), AKM(LENC), QS1(LENC) + _RL WLQ(LENC), CLF(LENC) + _RL uht(len,ntracer) + integer IA(LENC), I1(LENC),I2(LENC) + _RL rhfrac(len) +C Local Variables + _RL daylen,half,one,zero,cmb2pa,rhmax PARAMETER (DAYLEN=86400.0, HALF=0.5, ONE=1.0, ZERO=0.0) PARAMETER (CMB2PA=100.0) PARAMETER (RHMAX=0.9999) + _RL rkapp1,onebcp,albcp,onebg,cpbg,twobal C - integer nltop,ntracer,nlayr - DIMENSION POI(LEN,K), QOI(LEN,K), PRS(LEN,K+1) - *, PRJ(LEN,K+1) - *, TCU(LEN,K), QCU(LEN,K), CMASS(LEN,K), CLN(LEN) - real uoi(len,nlayr,ntracer) - DIMENSION ALF(LEN,K), BET(LEN,K), GAM(LEN,K) - *, PRH(LEN,K), PRI(LEN,K) - DIMENSION AKM(LENC), WFN(LENC) - DIMENSION HOL(LENC,K), QOL(LENC,K), ETA(LENC,K), HST(LENC,K) - *, GMH(LENC,K), ALM(LENC), WLQ(LENC), QS1(LENC) - *, TX1(LENC), TX2(LENC), TX3(LENC), TX4(LENC) - *, TX5(LENC), TX6(LENC), TX7(LENC), TX8(LENC) - *, CLF(LENC), PCU(LENC) - DIMENSION IA(LENC), I1(LENC), I2(LENC) - real rhfrac(len) - real ucu(len,k,ntracer),uht(len,ntracer) - LOGICAL SETRAS - - integer nt + integer nt,km1,ic1,i,L,len1,len2,isav,len11,ii + integer lena,lena1,lenb,tem,tem1 c Explicit Inline Directives c -------------------------- -#if CRAY -#if f77 +#ifdef CRAY +#ifdef f77 cfpp$ expand (qsat) #endif #endif @@ -1555,7 +1520,7 @@ KM1 = K - 1 IC1 = IC + 1 C -C SETTIING ALF, BET, GAM, PRH, AND PRI : DONE ONLY WHEN SETRAS=.T. +C SETTING ALF, BET, GAM, PRH, AND PRI : DONE ONLY WHEN SETRAS=.T. C IF (SETRAS) THEN @@ -2120,22 +2085,26 @@ END SUBROUTINE RNCL(LEN, PL, RNO, CLF) C -C C********************************************************************* C********************** Relaxed Arakawa-Schubert ********************* C************************ SUBROUTINE RNCL ************************ C**************************** 23 July 1992 *************************** C********************************************************************* + implicit none +C Argument List declarations + integer len + _RL PL(LEN), RNO(LEN), CLF(LEN) +C Local Variables + _RL p5,p8,pt8,pt2,pfac,p4,p6,p7,p9,cucld,cfac PARAMETER (P5=500.0, P8=800.0, PT8=0.8, PT2=0.2) PARAMETER (PFAC=PT2/(P8-P5)) -C PARAMETER (P4=400.0, P6=401.0) PARAMETER (P7=700.0, P9=900.0) PARAMETER (CUCLD=0.5,CFAC=CUCLD/(P6-P4)) + + integer i C - DIMENSION PL(LEN), RNO(LEN), CLF(LEN) - DO 10 I=1,LEN rno(i) = 1.0 ccc if( pl(i).le.400.0 ) rno(i) = max( 0.75, 1.0-0.0025*(400.0-pl(i)) ) @@ -2174,12 +2143,18 @@ C**** from 4x5 46-layer GEOS Assimilation ***** C**** ***** C********************************************************************* - - real PL(LEN), PLB(LEN), ACR(LEN) + implicit none +C Argument List declarations + integer len + _RL PL(LEN), PLB(LEN), ACR(LEN) +C Local variables + integer lma parameter (lma=18) - real p(lma) - real a(lma) + _RL p(lma) + _RL a(lma) + integer i,L + _RL temp data p / 93.81, 111.65, 133.46, 157.80, 186.51, . 219.88, 257.40, 301.21, 352.49, 409.76, @@ -2213,10 +2188,27 @@ RETURN END - SUBROUTINE RNEVP(NN,IRUN,NLAY,TL,QL,RAIN,PL,CLFRAC,SP,DSIG,PLKE, + SUBROUTINE RNEVP(NN,IRUN,NLAY,TL,QL,RAIN,PL,CLFRAC,SP,DP,PLKE, 1 PLK,TH,TEMP1,TEMP2,TEMP3,ITMP1,ITMP2,RCON,RLAR,CLSBTH,tmscl, 2 tmfrc,cp,gravity,alhl,gamfac,cldlz,RHCRIT,offset,alpha) + implicit none +C Argument List declarations + integer nn,irun,nlay + _RL TL(IRUN,NLAY),QL(IRUN,NLAY),RAIN(IRUN,NLAY), + . PL(IRUN,NLAY),CLFRAC(IRUN,NLAY),SP(IRUN),TEMP1(IRUN,NLAY), + . TEMP2(IRUN,NLAY),PLKE(IRUN,NLAY+1), + . RCON(IRUN),RLAR(IRUN),DP(IRUN,NLAY),PLK(IRUN,NLAY),TH(IRUN,NLAY), + . TEMP3(IRUN,NLAY) + integer ITMP1(IRUN,NLAY),ITMP2(IRUN,NLAY) + _RL CLSBTH(IRUN,NLAY) + _RL tmscl,tmfrc,cp,gravity,alhl,gamfac,offset,alpha + _RL cldlz(irun,nlay) + _RL rhcrit(irun,nlay) +C +C Local Variables + _RL zm1p04,zero,two89,zp44,zp01,half,zp578,one,thousand,z3600 + _RL zp1,zp001 PARAMETER (ZM1P04 = -1.04E-4 ) PARAMETER (ZERO = 0.) PARAMETER (TWO89= 2.89E-5) @@ -2230,26 +2222,20 @@ PARAMETER ( THOUSAND = 1000.) PARAMETER ( Z3600 = 3600.) C - DIMENSION TL(IRUN,NLAY),QL(IRUN,NLAY),RAIN(IRUN,NLAY), - $ PL(IRUN,NLAY),CLFRAC(IRUN,NLAY),SP(IRUN),TEMP1(IRUN,NLAY), - $ TEMP2(IRUN,NLAY),PLKE(IRUN,NLAY), - $ RCON(IRUN),RLAR(IRUN),DSIG(NLAY),PLK(IRUN,NLAY),TH(IRUN,NLAY), - $ TEMP3(IRUN,NLAY),ITMP1(IRUN,NLAY), - $ ITMP2(IRUN,NLAY),CLSBTH(IRUN,NLAY) -C - DIMENSION EVP9(IRUN,NLAY) - real water(irun),crystal(irun) - real watevap(irun),iceevap(irun) - real fracwat,fracice, tice,rh,fact,dum - - real cldlz(irun,nlay) - real rhcrit(irun,nlay), rainmax(irun) - real offset, alpha + _RL EVP9(IRUN,NLAY) + _RL water(irun),crystal(irun) + _RL watevap(irun),iceevap(irun) + _RL fracwat,fracice, tice,rh,fact,dum + _RL rainmax(irun) + _RL getcon,rphf,elocp,cpog,relax + _RL exparg,arearat,rpow + + integer i,L,n,nlaym1,irnlay,irnlm1 c Explicit Inline Directives c -------------------------- -#if CRAY -#if f77 +#ifdef CRAY +#ifdef f77 cfpp$ expand (qsat) #endif #endif @@ -2298,8 +2284,7 @@ c ----------------------------- DO L = 1,NLAY DO I = 1,IRUN - TEMP3(I,L) = SP(I) * DSIG(L) - TEMP3(I,L) = GRAVITY*ZP01 / TEMP3(I,L) + TEMP3(I,L) = GRAVITY*ZP01 / DP(I,L) ENDDO ENDDO @@ -2447,38 +2432,32 @@ C cloud ...... Cloud Fraction (irun,irise) C C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** implicit none integer irun,irise - real th(irun,irise) - real q(irun,irise) - real plk(irun,irise) - real pl(irun,irise) - real plke(irun,irise+1) - - real tempth(irun) - real tempqs(irun) - real dhstar(irun) - real cloud(irun,irise) - real cldwat(irun,irise) - real qs(irun,irise) - - real cp, alhl, getcon, akap, pcheck - real ratio, temp, pke, elocp - real rhcrit,rh,dum,pbar,tbar - integer i,L,ntradesu,ntradesl - - real factor - real rhc(irun,irise) - real offset,alpha + _RL th(irun,irise) + _RL q(irun,irise) + _RL plk(irun,irise) + _RL pl(irun,irise) + _RL plke(irun,irise+1) + + _RL cloud(irun,irise) + _RL cldwat(irun,irise) + _RL qs(irun,irise) + + _RL cp, alhl, getcon, akap + _RL ratio, temp, elocp + _RL rhcrit,rh,dum + integer i,L + + _RL rhc(irun,irise) + _RL offset,alpha c Explicit Inline Directives c -------------------------- -#if CRAY -#if f77 +#ifdef CRAY +#ifdef f77 cfpp$ expand (qsat) #endif #endif @@ -2519,11 +2498,11 @@ subroutine ctei ( th,q,cldfrc,cldwat,pl,plk,plke,im,lm ) implicit none integer im,lm - real th(im,lm),q(im,lm),plke(im,lm+1),cldwat(im,lm) - real plk(im,lm),pl(im,lm),cldfrc(im,lm) + _RL th(im,lm),q(im,lm),plke(im,lm+1),cldwat(im,lm) + _RL plk(im,lm),pl(im,lm),cldfrc(im,lm) integer i,L - real getcon,cp,alhl,elocp,cpoel,t,p,s,qs,dqsdt,dq - real k,krd,kmm,f + _RL getcon,cp,alhl,elocp,cpoel,t,p,s,qs,dqsdt,dq + _RL k,krd,kmm,f cp = getcon('CP') alhl = getcon('LATENT HEAT COND') @@ -2560,8 +2539,8 @@ subroutine back2grd(gathered,indeces,scattered,irun) implicit none integer i,irun,indeces(irun) - real gathered(irun),scattered(irun) - real temp(irun) + _RL gathered(irun),scattered(irun) + _RL temp(irun) do i = 1,irun temp(indeces(i)) = gathered(i) enddo