! ! $Id: cv3_routines.F 1907 2013-11-26 13:10:46Z musat $ ! c c SUBROUTINE cv3_param(nd,delt) implicit none c------------------------------------------------------------ c Set parameters for convectL for iflag_con = 3 c------------------------------------------------------------ C C *** PBCRIT IS THE CRITICAL CLOUD DEPTH (MB) BENEATH WHICH THE *** C *** PRECIPITATION EFFICIENCY IS ASSUMED TO BE ZERO *** C *** PTCRIT IS THE CLOUD DEPTH (MB) ABOVE WHICH THE PRECIP. *** C *** EFFICIENCY IS ASSUMED TO BE UNITY *** C *** SIGD IS THE FRACTIONAL AREA COVERED BY UNSATURATED DNDRAFT *** C *** SPFAC IS THE FRACTION OF PRECIPITATION FALLING OUTSIDE *** C *** OF CLOUD *** C C [TAU: CHARACTERISTIC TIMESCALE USED TO COMPUTE ALPHA & BETA] C *** ALPHA AND BETA ARE PARAMETERS THAT CONTROL THE RATE OF *** C *** APPROACH TO QUASI-EQUILIBRIUM *** C *** (THEIR STANDARD VALUES ARE 1.0 AND 0.96, RESPECTIVELY) *** C *** (BETA MUST BE LESS THAN OR EQUAL TO 1) *** C C *** DTCRIT IS THE CRITICAL BUOYANCY (K) USED TO ADJUST THE *** C *** APPROACH TO QUASI-EQUILIBRIUM *** C *** IT MUST BE LESS THAN 0 *** include "cv3param.h" include "conema3.h" integer nd real delt ! timestep (seconds) CHARACTER (LEN=20) :: modname='cv3_param' CHARACTER (LEN=80) :: abort_message LOGICAL,SAVE :: first=.true. c$OMP THREADPRIVATE(first) c noff: integer limit for convection (nd-noff) c minorig: First level of convection c -- limit levels for convection: noff = 1 minorig = 1 nl=nd-noff nlp=nl+1 nlm=nl-1 IF (first) THEN c -- "microphysical" parameters: sigdz=0.01 spfac = 0.15 pbcrit = 150.0 ptcrit = 500.0 cIM beg: ajout fis. reglage ep flag_epKEorig=1 elcrit=0.0003 tlcrit=-55.0 cIM lu dans physiq.def via conf_phys.F90 epmax = 0.993 omtrain = 45.0 ! used also for snow (no disctinction rain/snow) c -- misc: dtovsh = -0.2 ! dT for overshoot dpbase = -40. ! definition cloud base (400m above LCL) ccc dttrig = 5. ! (loose) condition for triggering dttrig = 10. ! (loose) condition for triggering flag_wb=1 wbmax = 6. ! (m/s) adiab updraught speed at LFC (used in cv3p1_closure) c -- rate of approach to quasi-equilibrium: dtcrit = -2.0 tau = 8000. c -- interface cloud parameterization: delta=0.01 ! cld c -- interface with boundary-layer (gust factor): (sb) betad=10.0 ! original value (from convect 4.3) OPEN(99,file='conv_param.data',status='old', $ form='formatted',err=9999) READ(99,*,end=9998) dpbase READ(99,*,end=9998) pbcrit READ(99,*,end=9998) ptcrit READ(99,*,end=9998) sigdz READ(99,*,end=9998) spfac READ(99,*,end=9998) tau READ(99,*,end=9998) flag_wb READ(99,*,end=9998) wbmax 9998 Continue CLOSE(99) 9999 Continue WRITE(*,*)'dpbase=',dpbase WRITE(*,*)'pbcrit=',pbcrit WRITE(*,*)'ptcrit=',ptcrit WRITE(*,*)'sigdz=',sigdz WRITE(*,*)'spfac=',spfac WRITE(*,*)'tau=',tau WRITE(*,*)'flag_wb =',flag_wb WRITE(*,*)'wbmax =',wbmax cIM Lecture du fichier ep_param.data OPEN(79,file='ep_param.data',status='old', $ form='formatted',err=7999) READ(79,*,end=7998) flag_epKEorig READ(79,*,end=7998) elcrit READ(79,*,end=7998) tlcrit 7998 Continue CLOSE(79) 7999 Continue WRITE(*,*)'flag_epKEorig',flag_epKEorig WRITE(*,*)'elcrit=',elcrit WRITE(*,*)'tlcrit=',tlcrit cIM end: ajout fis. reglage ep first = .false. ENDIF beta = 1.0 - delt/tau alpha1 = 1.5e-3 cjyg Correction bug alpha alpha1 = alpha1*1.5 alpha = alpha1 * delt/tau cjyg Bug ccc increase alpha to compensate W decrease: cc alpha = alpha*1.5 return end SUBROUTINE cv3_prelim(len,nd,ndp1,t,q,p,ph : ,lv,lf,cpn,tv,gz,h,hm,th) implicit none !===================================================================== ! --- CALCULATE ARRAYS OF GEOPOTENTIAL, HEAT CAPACITY & STATIC ENERGY ! "ori": from convect4.3 (vectorized) ! "convect3": to be exactly consistent with convect3 !===================================================================== c inputs: integer len, nd, ndp1 real t(len,nd), q(len,nd), p(len,nd), ph(len,ndp1) c outputs: real lv(len,nd), lf(len,nd), cpn(len,nd), tv(len,nd) real gz(len,nd), h(len,nd), hm(len,nd) real th(len,nd) c local variables: integer k, i real rdcp real tvx,tvy ! convect3 real cpx(len,nd) include "cvthermo.h" include "cv3param.h" c ori do 110 k=1,nlp ! abderr do 110 k=1,nl ! convect3 do 110 k=1,nlp do 100 i=1,len cdebug lv(i,k)= lv0-clmcpv*(t(i,k)-t0) lv(i,k)= lv0-clmcpv*(t(i,k)-273.15) lf(i,k)= lf0-clmci*(t(i,k)-273.15) cpn(i,k)=cpd*(1.0-q(i,k))+cpv*q(i,k) cpx(i,k)=cpd*(1.0-q(i,k))+cl*q(i,k) c ori tv(i,k)=t(i,k)*(1.0+q(i,k)*epsim1) tv(i,k)=t(i,k)*(1.0+q(i,k)/eps-q(i,k)) rdcp=(rrd*(1.-q(i,k))+q(i,k)*rrv)/cpn(i,k) th(i,k)=t(i,k)*(1000.0/p(i,k))**rdcp 100 continue 110 continue c c gz = phi at the full levels (same as p). c do 120 i=1,len gz(i,1)=0.0 120 continue c ori do 140 k=2,nlp do 140 k=2,nl ! convect3 do 130 i=1,len tvx=t(i,k)*(1.+q(i,k)/eps-q(i,k)) !convect3 tvy=t(i,k-1)*(1.+q(i,k-1)/eps-q(i,k-1)) !convect3 gz(i,k)=gz(i,k-1)+0.5*rrd*(tvx+tvy) !convect3 & *(p(i,k-1)-p(i,k))/ph(i,k) !convect3 c cc print *,' gz(',k,')',gz(i,k),' tvx',tvx,' tvy ',tvy c c ori gz(i,k)=gz(i,k-1)+hrd*(tv(i,k-1)+tv(i,k)) c ori & *(p(i,k-1)-p(i,k))/ph(i,k) 130 continue 140 continue c c h = phi + cpT (dry static energy). c hm = phi + cp(T-Tbase)+Lq c c ori do 170 k=1,nlp do 170 k=1,nl ! convect3 do 160 i=1,len h(i,k)=gz(i,k)+cpn(i,k)*t(i,k) hm(i,k)=gz(i,k)+cpx(i,k)*(t(i,k)-t(i,1))+lv(i,k)*q(i,k) 160 continue 170 continue return end SUBROUTINE cv3_feed(len,nd,t,q,u,v,p,ph,hm,gz : ,p1feed,p2feed,wght : ,wghti,tnk,thnk,qnk,qsnk,unk,vnk : ,cpnk,hnk,nk,icb,icbmax,iflag,gznk,plcl) implicit none C================================================================ C Purpose: CONVECTIVE FEED C C Main differences with cv_feed: C - ph added in input C - here, nk(i)=minorig C - icb defined differently (plcl compared with ph instead of p) C C Main differences with convect3: C - we do not compute dplcldt and dplcldr of CLIFT anymore C - values iflag different (but tests identical) C - A,B explicitely defined (!...) C================================================================ include "cv3param.h" include "cvthermo.h" c inputs: integer len, nd real t(len,nd), q(len,nd), p(len,nd) real u(len,nd), v(len,nd) real hm(len,nd), gz(len,nd) real ph(len,nd+1) real p1feed(len) c, wght(len) real wght(nd) c input-output real p2feed(len) c outputs: integer iflag(len), nk(len), icb(len), icbmax c real wghti(len) real wghti(len,nd) real tnk(len), thnk(len), qnk(len), qsnk(len) real unk(len), vnk(len) real cpnk(len), hnk(len), gznk(len) real plcl(len) c local variables: integer i, k, iter, niter integer ihmin(len) real work(len) real pup(len),plo(len),pfeed(len) real plclup(len),plcllo(len),plclfeed(len) real posit(len) logical nocond(len) ! !------------------------------------------------------------------- ! --- Origin level of ascending parcels for convect3: !------------------------------------------------------------------- do 220 i=1,len nk(i)=minorig gznk(i)=gz(i,nk(i)) 220 continue ! !------------------------------------------------------------------- ! --- Adjust feeding layer thickness so that lifting up to the top of ! --- the feeding layer does not induce condensation (i.e. so that ! --- plcl < p2feed). ! --- Method : iterative secant method. !------------------------------------------------------------------- ! c 1- First bracketing of the solution : ph(nk+1), p2feed c c 1.a- LCL associated to p2feed do i = 1,len pup(i) = p2feed(i) enddo call cv3_vertmix(len,nd,iflag,p1feed,pup,p,ph i ,t,q,u,v,wght o ,wghti,nk,tnk,thnk,qnk,qsnk,unk,vnk,plclup) c 1.b- LCL associated to ph(nk+1) do i = 1,len plo(i) = ph(i,nk(i)+1) enddo call cv3_vertmix(len,nd,iflag,p1feed,plo,p,ph i ,t,q,u,v,wght o ,wghti,nk,tnk,thnk,qnk,qsnk,unk,vnk,plcllo) c 2- Iterations niter = 5 do iter = 1,niter do i = 1,len plcllo(i) = min(plo(i),plcllo(i)) plclup(i) = max(pup(i),plclup(i)) nocond(i) = plclup(i).le.pup(i) enddo do i = 1,len if(nocond(i)) then pfeed(i)=pup(i) else pfeed(i) = (pup(i)*(plo(i)-plcllo(i))+ : plo(i)*(plclup(i)-pup(i)))/ : (plo(i)-plcllo(i)+plclup(i)-pup(i)) endif enddo call cv3_vertmix(len,nd,iflag,p1feed,pfeed,p,ph i ,t,q,u,v,wght o ,wghti,nk,tnk,thnk,qnk,qsnk,unk,vnk,plclfeed) do i = 1,len posit(i) = (sign(1.,plclfeed(i)-pfeed(i))+1.)*0.5 if (plclfeed(i) .eq. pfeed(i)) posit(i) = 1. c- posit = 1 when lcl is below top of feeding layer (plclfeed>pfeed) c- => pup=pfeed c- posit = 0 when lcl is above top of feeding layer (plclfeed plo=pfeed pup(i) = posit(i)*pfeed(i) + (1.-posit(i))*pup(i) plo(i) = (1.-posit(i))*pfeed(i) + posit(i)*plo(i) plclup(i) = posit(i)*plclfeed(i) + (1.-posit(i))*plclup(i) plcllo(i) = (1.-posit(i))*plclfeed(i) + posit(i)*plcllo(i) enddo enddo ! iter do i = 1,len p2feed(i) = pfeed(i) plcl(i) = plclfeed(i) enddo ! do 175 i=1,len cpnk(i)=cpd*(1.0-qnk(i))+cpv*qnk(i) hnk(i)=gz(i,1)+cpnk(i)*tnk(i) 175 continue ! !------------------------------------------------------------------- ! --- Check whether parcel level temperature and specific humidity ! --- are reasonable !------------------------------------------------------------------- do 250 i=1,len if( ( ( tnk(i).lt.250.0 ) & .or.( qnk(i).le.0.0 ) ) & .and. & ( iflag(i).eq.0) ) iflag(i)=7 250 continue c !------------------------------------------------------------------- ! --- Calculate first level above lcl (=icb) !------------------------------------------------------------------- c@ do 270 i=1,len c@ icb(i)=nlm c@ 270 continue c@c c@ do 290 k=minorig,nl c@ do 280 i=1,len c@ if((k.ge.(nk(i)+1)).and.(p(i,k).lt.plcl(i))) c@ & icb(i)=min(icb(i),k) c@ 280 continue c@ 290 continue c@c c@ do 300 i=1,len c@ if((icb(i).ge.nlm).and.(iflag(i).eq.0))iflag(i)=9 c@ 300 continue do 270 i=1,len icb(i)=nlm 270 continue c c la modification consiste a comparer plcl a ph et non a p: c icb est defini par : ph(icb)p(icb), then icbs=icb c c * the routine above computes tvp from minorig to icbs (included). c c * to compute buoybase (in cv3_trigger.F), both tvp(icb) and tvp(icb+1) c must be known. This is the case if icbs=icb+1, but not if icbs=icb. c c * therefore, in the case icbs=icb, we compute tvp at level icb+1 c (tvp at other levels will be computed in cv3_undilute2.F) c do i=1,len ticb(i)=t(i,icb(i)+1) gzicb(i)=gz(i,icb(i)+1) qsicb(i)=qs(i,icb(i)+1) enddo do 460 i=1,len tg=ticb(i) qg=qsicb(i) ! convect3 cdebug alv=lv0-clmcpv*(ticb(i)-t0) alv=lv0-clmcpv*(ticb(i)-273.15) c c First iteration. c c ori s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i)) s=cpd*(1.-qnk(i))+cl*qnk(i) ! convect3 : +alv*alv*qg/(rrv*ticb(i)*ticb(i)) ! convect3 s=1./s c ori ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i) ahg=cpd*tg+(cl-cpd)*qnk(i)*tg+alv*qg+gzicb(i) ! convect3 tg=tg+s*(ah0(i)-ahg) c ori tg=max(tg,35.0) cdebug tc=tg-t0 tc=tg-273.15 denom=243.5+tc denom=MAX(denom,1.0) ! convect3 c ori if(tc.ge.0.0)then es=6.112*exp(17.67*tc/denom) c ori else c ori es=exp(23.33086-6111.72784/tg+0.15215*log(tg)) c ori endif c ori qg=eps*es/(p(i,icb(i))-es*(1.-eps)) qg=eps*es/(p(i,icb(i)+1)-es*(1.-eps)) c c Second iteration. c c ori s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i)) c ori s=1./s c ori ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i) ahg=cpd*tg+(cl-cpd)*qnk(i)*tg+alv*qg+gzicb(i) ! convect3 tg=tg+s*(ah0(i)-ahg) c ori tg=max(tg,35.0) cdebug tc=tg-t0 tc=tg-273.15 denom=243.5+tc denom=MAX(denom,1.0) ! convect3 c ori if(tc.ge.0.0)then es=6.112*exp(17.67*tc/denom) c ori else c ori es=exp(23.33086-6111.72784/tg+0.15215*log(tg)) c ori end if c ori qg=eps*es/(p(i,icb(i))-es*(1.-eps)) qg=eps*es/(p(i,icb(i)+1)-es*(1.-eps)) alv=lv0-clmcpv*(ticb(i)-273.15) c ori c approximation here: c ori tp(i,icb(i))=(ah0(i)-(cl-cpd)*qnk(i)*ticb(i) c ori & -gz(i,icb(i))-alv*qg)/cpd c convect3: no approximation: tp(i,icb(i)+1)=(ah0(i)-gz(i,icb(i)+1)-alv*qg) : /(cpd+(cl-cpd)*qnk(i)) c ori clw(i,icb(i))=qnk(i)-qg c ori clw(i,icb(i))=max(0.0,clw(i,icb(i))) clw(i,icb(i)+1)=qnk(i)-qg clw(i,icb(i)+1)=max(0.0,clw(i,icb(i)+1)) rg=qg/(1.-qnk(i)) c ori tvp(i,icb(i))=tp(i,icb(i))*(1.+rg*epsi) c convect3: (qg utilise au lieu du vrai mixing ratio rg) tvp(i,icb(i)+1)=tp(i,icb(i)+1)*(1.+qg/eps-qnk(i)) !whole thing 460 continue return end SUBROUTINE cv3_trigger(len,nd,icb,plcl,p,th,tv,tvp,thnk, o pbase,buoybase,iflag,sig,w0) implicit none !------------------------------------------------------------------- ! --- TRIGGERING ! ! - computes the cloud base ! - triggering (crude in this version) ! - relaxation of sig and w0 when no convection ! ! Caution1: if no convection, we set iflag=4 ! (it used to be 0 in convect3) ! ! Caution2: at this stage, tvp (and thus buoy) are know up ! through icb only! ! -> the buoyancy below cloud base not (yet) set to the cloud base buoyancy !------------------------------------------------------------------- include "cv3param.h" c input: integer len, nd integer icb(len) real plcl(len), p(len,nd) real th(len,nd), tv(len,nd), tvp(len,nd) real thnk(len) c output: real pbase(len), buoybase(len) c input AND output: integer iflag(len) real sig(len,nd), w0(len,nd) c local variables: integer i,k real tvpbase, tvbase, tdif, ath, ath1 c c *** set cloud base buoyancy at (plcl+dpbase) level buoyancy c do 100 i=1,len pbase(i) = plcl(i) + dpbase tvpbase = tvp(i,icb(i))*(pbase(i)-p(i,icb(i)+1)) : /(p(i,icb(i))-p(i,icb(i)+1)) : + tvp(i,icb(i)+1)*(p(i,icb(i))-pbase(i)) : /(p(i,icb(i))-p(i,icb(i)+1)) tvbase = tv(i,icb(i))*(pbase(i)-p(i,icb(i)+1)) : /(p(i,icb(i))-p(i,icb(i)+1)) : + tv(i,icb(i)+1)*(p(i,icb(i))-pbase(i)) : /(p(i,icb(i))-p(i,icb(i)+1)) buoybase(i) = tvpbase - tvbase 100 continue c c *** make sure that column is dry adiabatic between the surface *** c *** and cloud base, and that lifted air is positively buoyant *** c *** at cloud base *** c *** if not, return to calling program after resetting *** c *** sig(i) and w0(i) *** c c oct3 do 200 i=1,len c oct3 c oct3 tdif = buoybase(i) c oct3 ath1 = th(i,1) c oct3 ath = th(i,icb(i)-1) - dttrig c oct3 c oct3 if (tdif.lt.dtcrit .or. ath.gt.ath1) then c oct3 do 60 k=1,nl c oct3 sig(i,k) = beta*sig(i,k) - 2.*alpha*tdif*tdif c oct3 sig(i,k) = AMAX1(sig(i,k),0.0) c oct3 w0(i,k) = beta*w0(i,k) c oct3 60 continue c oct3 iflag(i)=4 ! pour version vectorisee c oct3c convect3 iflag(i)=0 c oct3cccc return c oct3 endif c oct3 c oct3200 continue c -- oct3: on reecrit la boucle 200 (pour la vectorisation) do 60 k=1,nl do 200 i=1,len tdif = buoybase(i) ath1 = thnk(i) ath = th(i,icb(i)-1) - dttrig if (tdif.lt.dtcrit .or. ath.gt.ath1) then sig(i,k) = beta*sig(i,k) - 2.*alpha*tdif*tdif sig(i,k) = AMAX1(sig(i,k),0.0) w0(i,k) = beta*w0(i,k) iflag(i)=4 ! pour version vectorisee c convect3 iflag(i)=0 endif 200 continue 60 continue c fin oct3 -- return end SUBROUTINE cv3_compress( len,nloc,ncum,nd,ntra : ,iflag1,nk1,icb1,icbs1 : ,plcl1,tnk1,qnk1,gznk1,pbase1,buoybase1 : ,t1,q1,qs1,u1,v1,gz1,th1 : ,tra1 : ,h1,lv1,cpn1,p1,ph1,tv1,tp1,tvp1,clw1 : ,sig1,w01 o ,iflag,nk,icb,icbs o ,plcl,tnk,qnk,gznk,pbase,buoybase o ,t,q,qs,u,v,gz,th o ,tra o ,h,lv,cpn,p,ph,tv,tp,tvp,clw o ,sig,w0 ) implicit none include "cv3param.h" include 'iniprint.h' c inputs: integer len,ncum,nd,ntra,nloc integer iflag1(len),nk1(len),icb1(len),icbs1(len) real plcl1(len),tnk1(len),qnk1(len),gznk1(len) real pbase1(len),buoybase1(len) real t1(len,nd),q1(len,nd),qs1(len,nd),u1(len,nd),v1(len,nd) real gz1(len,nd),h1(len,nd),lv1(len,nd),cpn1(len,nd) real p1(len,nd),ph1(len,nd+1),tv1(len,nd),tp1(len,nd) real tvp1(len,nd),clw1(len,nd) real th1(len,nd) real sig1(len,nd), w01(len,nd) real tra1(len,nd,ntra) c outputs: c en fait, on a nloc=len pour l'instant (cf cv_driver) integer iflag(nloc),nk(nloc),icb(nloc),icbs(nloc) real plcl(nloc),tnk(nloc),qnk(nloc),gznk(nloc) real pbase(nloc),buoybase(nloc) real t(nloc,nd),q(nloc,nd),qs(nloc,nd),u(nloc,nd),v(nloc,nd) real gz(nloc,nd),h(nloc,nd),lv(nloc,nd),cpn(nloc,nd) real p(nloc,nd),ph(nloc,nd+1),tv(nloc,nd),tp(nloc,nd) real tvp(nloc,nd),clw(nloc,nd) real th(nloc,nd) real sig(nloc,nd), w0(nloc,nd) real tra(nloc,nd,ntra) c local variables: integer i,k,nn,j CHARACTER (LEN=20) :: modname='cv3_compress' CHARACTER (LEN=80) :: abort_message do 110 k=1,nl+1 nn=0 do 100 i=1,len if(iflag1(i).eq.0)then nn=nn+1 sig(nn,k)=sig1(i,k) w0(nn,k)=w01(i,k) t(nn,k)=t1(i,k) q(nn,k)=q1(i,k) qs(nn,k)=qs1(i,k) u(nn,k)=u1(i,k) v(nn,k)=v1(i,k) gz(nn,k)=gz1(i,k) h(nn,k)=h1(i,k) lv(nn,k)=lv1(i,k) cpn(nn,k)=cpn1(i,k) p(nn,k)=p1(i,k) ph(nn,k)=ph1(i,k) tv(nn,k)=tv1(i,k) tp(nn,k)=tp1(i,k) tvp(nn,k)=tvp1(i,k) clw(nn,k)=clw1(i,k) th(nn,k)=th1(i,k) endif 100 continue 110 continue !AC! do 121 j=1,ntra !AC!ccccc do 111 k=1,nl+1 !AC! do 111 k=1,nd !AC! nn=0 !AC! do 101 i=1,len !AC! if(iflag1(i).eq.0)then !AC! nn=nn+1 !AC! tra(nn,k,j)=tra1(i,k,j) !AC! endif !AC! 101 continue !AC! 111 continue !AC! 121 continue if (nn.ne.ncum) then write(lunout,*)'strange! nn not equal to ncum: ',nn,ncum abort_message = '' CALL abort_gcm (modname,abort_message,1) endif nn=0 do 150 i=1,len if(iflag1(i).eq.0)then nn=nn+1 pbase(nn)=pbase1(i) buoybase(nn)=buoybase1(i) plcl(nn)=plcl1(i) tnk(nn)=tnk1(i) qnk(nn)=qnk1(i) gznk(nn)=gznk1(i) nk(nn)=nk1(i) icb(nn)=icb1(i) icbs(nn)=icbs1(i) iflag(nn)=iflag1(i) endif 150 continue return end SUBROUTINE Icefrac(t,clw,qi,nl,len) implicit none cJAM-------------------------------------------------------------------- C Calcul de la quantité d'eau sous forme de glace C-------------------------------------------------------------------- Real qi(len,nl) Real t(len,nl), clw(len,nl) Real fracg Integer nl, len, k, i do k=3, nl do i = 1, len if (t(i,k).gt.263.15) then qi(i,k)=0. else if (t(i,k).lt.243.15) then qi(i,k)=clw(i,k) else fracg=(263.15-t(i,k))/20 qi(i,k)=clw(i,k)*fracg endif endif C print*,t(i,k),qi(i,k),'temp,testglace' enddo enddo return end SUBROUTINE cv3_undilute2(nloc,ncum,nd,icb,icbs,nk : ,tnk,qnk,gznk,hnk,t,q,qs,gz : ,p,h,tv,lv,lf,pbase,buoybase,plcl o ,inb,tp,tvp,clw,hp,ep,sigp,buoy,frac) implicit none C--------------------------------------------------------------------- C Purpose: C FIND THE REST OF THE LIFTED PARCEL TEMPERATURES C & C COMPUTE THE PRECIPITATION EFFICIENCIES AND THE C FRACTION OF PRECIPITATION FALLING OUTSIDE OF CLOUD C & C FIND THE LEVEL OF NEUTRAL BUOYANCY C C Main differences convect3/convect4: C - icbs (input) is the first level above LCL (may differ from icb) C - many minor differences in the iterations C - condensed water not removed from tvp in convect3 C - vertical profile of buoyancy computed here (use of buoybase) C - the determination of inb is different C - no inb1, only inb in output C--------------------------------------------------------------------- include "cvthermo.h" include "cv3param.h" include "conema3.h" include "cvflag.h" c inputs: integer ncum, nd, nloc, j integer icb(nloc), icbs(nloc), nk(nloc) real t(nloc,nd), q(nloc,nd), qs(nloc,nd), gz(nloc,nd) real p(nloc,nd) real tnk(nloc), qnk(nloc), gznk(nloc) real hnk(nloc) real lv(nloc,nd), lf(nloc,nd), tv(nloc,nd), h(nloc,nd) real pbase(nloc), buoybase(nloc), plcl(nloc) c outputs: integer inb(nloc) real tp(nloc,nd), tvp(nloc,nd), clw(nloc,nd) real ep(nloc,nd), sigp(nloc,nd), hp(nloc,nd) real buoy(nloc,nd) c local variables: integer i, k real tg,qg,ahg,alv,alf,s,tc,es,esi,denom,rg,tca,elacrit real als real qsat_new,snew, qi(nloc,nd) real by, defrac, pden, tbis real ah0(nloc), cape(nloc), capem(nloc), byp(nloc) real frac(nloc,nd) logical lcape(nloc) integer iposit(nloc) Real fracg !===================================================================== ! --- SOME INITIALIZATIONS !===================================================================== do 170 k=1,nl do 160 i=1,ncum ep(i,k)=0.0 sigp(i,k)=spfac qi(i,k)=0. 160 continue 170 continue !===================================================================== ! --- FIND THE REST OF THE LIFTED PARCEL TEMPERATURES !===================================================================== c c --- The procedure is to solve the equation. c cp*tp+L*qp+phi=cp*tnk+L*qnk+gznk. c c *** Calculate certain parcel quantities, including static energy *** c c do 240 i=1,ncum ah0(i)=(cpd*(1.-qnk(i))+cl*qnk(i))*tnk(i) cdebug & +qnk(i)*(lv0-clmcpv*(tnk(i)-t0))+gznk(i) & +qnk(i)*(lv0-clmcpv*(tnk(i)-273.15))+gznk(i) 240 continue c c c *** Find lifted parcel quantities above cloud base *** c c do 300 k=minorig+1,nl do 290 i=1,ncum c ori if(k.ge.(icb(i)+1))then if(k.ge.(icbs(i)+1))then ! convect3 tg=t(i,k) qg=qs(i,k) cdebug alv=lv0-clmcpv*(t(i,k)-t0) alv=lv0-clmcpv*(t(i,k)-273.15) c c First iteration. c c ori s=cpd+alv*alv*qg/(rrv*t(i,k)*t(i,k)) s=cpd*(1.-qnk(i))+cl*qnk(i) ! convect3 : +alv*alv*qg/(rrv*t(i,k)*t(i,k)) ! convect3 s=1./s c ori ahg=cpd*tg+(cl-cpd)*qnk(i)*t(i,k)+alv*qg+gz(i,k) ahg=cpd*tg+(cl-cpd)*qnk(i)*tg+alv*qg+gz(i,k) ! convect3 tg=tg+s*(ah0(i)-ahg) c ori tg=max(tg,35.0) cdebug tc=tg-t0 tc=tg-273.15 denom=243.5+tc denom=MAX(denom,1.0) ! convect3 c ori if(tc.ge.0.0)then es=6.112*exp(17.67*tc/denom) c ori else c ori es=exp(23.33086-6111.72784/tg+0.15215*log(tg)) c ori endif qg=eps*es/(p(i,k)-es*(1.-eps)) c c Second iteration. c c ori s=cpd+alv*alv*qg/(rrv*t(i,k)*t(i,k)) c ori s=1./s c ori ahg=cpd*tg+(cl-cpd)*qnk(i)*t(i,k)+alv*qg+gz(i,k) ahg=cpd*tg+(cl-cpd)*qnk(i)*tg+alv*qg+gz(i,k) ! convect3 tg=tg+s*(ah0(i)-ahg) c ori tg=max(tg,35.0) cdebug tc=tg-t0 tc=tg-273.15 denom=243.5+tc denom=MAX(denom,1.0) ! convect3 c ori if(tc.ge.0.0)then es=6.112*exp(17.67*tc/denom) c ori else c ori es=exp(23.33086-6111.72784/tg+0.15215*log(tg)) c ori endif qg=eps*es/(p(i,k)-es*(1.-eps)) c cdebug alv=lv0-clmcpv*(t(i,k)-t0) alv=lv0-clmcpv*(t(i,k)-273.15) c print*,'cpd dans convect2 ',cpd c print*,'tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd' c print*,tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd c ori c approximation here: c ori tp(i,k)=(ah0(i)-(cl-cpd)*qnk(i)*t(i,k)-gz(i,k)-alv*qg)/cpd c convect3: no approximation: if (cvflag_ice) then tp(i,k)=Max(0.,(ah0(i)-gz(i,k)-alv*qg) & /(cpd+(cl-cpd)*qnk(i))) else tp(i,k)=(ah0(i)-gz(i,k)-alv*qg)/(cpd+(cl-cpd)*qnk(i)) endif c clw(i,k)=qnk(i)-qg clw(i,k)=max(0.0,clw(i,k)) rg=qg/(1.-qnk(i)) c ori tvp(i,k)=tp(i,k)*(1.+rg*epsi) c convect3: (qg utilise au lieu du vrai mixing ratio rg): tvp(i,k)=tp(i,k)*(1.+qg/eps-qnk(i)) ! whole thing if (cvflag_ice) then if(clw(i,k).lt.1.e-11) then tp(i,k)=tv(i,k) tvp(i,k)=tv(i,k) endif endif endif if (cvflag_ice) then cCR:attention boucle en klon dans Icefrac c Call Icefrac(t,clw,qi,nl,nloc) if (t(i,k).gt.263.15) then qi(i,k)=0. else if (t(i,k).lt.243.15) then qi(i,k)=clw(i,k) else fracg=(263.15-t(i,k))/20 qi(i,k)=clw(i,k)*fracg endif endif cCR: fin test if(t(i,k).lt.263.15) then cCR: on commente les calculs d'Arnaud car division par zero cnouveau calcul propose par JYG c alv=lv0-clmcpv*(t(i,k)-273.15) c alf=lf0-clmci*(t(i,k)-273.15) c tg=tp(i,k) c tc=tp(i,k)-273.15 c denom=243.5+tc c do j=1,3 ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c il faudra que esi vienne en argument de la convection ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c tbis=t(i,k)+(tp(i,k)-tg) c esi=exp(23.33086-(6111.72784/tbis) c : +0.15215*log(tbis)) c qsat_new=eps*esi/(p(i,k)-esi*(1.-eps)) c snew=cpd*(1.-qnk(i))+cl*qnk(i)+alv*alv*qsat_new/ c : (rrv*tbis*tbis) c snew=1./snew c print*,esi,qsat_new,snew,'esi,qsat,snew' c tp(i,k)=tg+(alf*qi(i,k)+alv*qg*(1.-(esi/es)))*snew c print*,k,tp(i,k),qnk(i),'avec glace' c print*,'tpNAN',tg,alf,qi(i,k),alv,qg,esi,es,snew c enddo alv=lv0-clmcpv*(t(i,k)-273.15) alf=lf0+clmci*(t(i,k)-273.15) als=alf+alv tg=tp(i,k) tp(i,k) = t(i,k) do j=1,3 esi=exp(23.33086-(6111.72784/tp(i,k)) : +0.15215*log(tp(i,k))) qsat_new=eps*esi/(p(i,k)-esi*(1.-eps)) snew=cpd*(1.-qnk(i))+cl*qnk(i)+alv*als*qsat_new/ : (rrv*tp(i,k)*tp(i,k)) snew=1./snew cc print*,esi,qsat_new,snew,'esi,qsat,snew' tp(i,k)=tp(i,k)+ : ( (cpd*(1.-qnk(i))+cl*qnk(i))*(tg-tp(i,k)) + : alv*(qg-qsat_new) + alf*qi(i,k) )*snew c print*,k,tp(i,k),qsat_new,qnk(i),qi(i,k), c : 'k,tp,q,qt,qi avec glace' enddo cCR:reprise du code AJ clw(i,k)=qnk(i)-qsat_new clw(i,k)=max(0.0,clw(i,k)) tvp(i,k)=Max(0.,tp(i,k)*(1.+qsat_new/eps-qnk(i))) c print*,tvp(i,k),'tvp' endif if(clw(i,k).lt.1.e-11) then tp(i,k)=tv(i,k) tvp(i,k)=tv(i,k) endif endif ! (cvflag_ice) 290 continue 300 continue c !===================================================================== ! --- SET THE PRECIPITATION EFFICIENCIES AND THE FRACTION OF ! --- PRECIPITATION FALLING OUTSIDE OF CLOUD ! --- THESE MAY BE FUNCTIONS OF TP(I), P(I) AND CLW(I) !===================================================================== if(flag_epKEorig.ne.1) THEN do 320 k=1,nl ! convect3 do 310 i=1,ncum pden=ptcrit-pbcrit ep(i,k)=(plcl(i)-p(i,k)-pbcrit)/pden*epmax ep(i,k)=max(ep(i,k),0.0) ep(i,k)=min(ep(i,k),epmax) sigp(i,k)=spfac 310 continue 320 continue else do 325 k=1,nl do 315 i=1,ncum if(k.ge.(nk(i)+1))then tca=tp(i,k)-t0 if(tca.ge.0.0)then elacrit=elcrit else elacrit=elcrit*(1.0-tca/tlcrit) endif elacrit=max(elacrit,0.0) ep(i,k)=1.0-elacrit/max(clw(i,k),1.0e-8) ep(i,k)=max(ep(i,k),0.0 ) ep(i,k)=min(ep(i,k),epmax ) sigp(i,k)=spfac endif 315 continue 325 continue endif !===================================================================== ! --- CALCULATE VIRTUAL TEMPERATURE AND LIFTED PARCEL ! --- VIRTUAL TEMPERATURE !===================================================================== c c dans convect3, tvp est calcule en une seule fois, et sans retirer c l'eau condensee (~> reversible CAPE) c c ori do 340 k=minorig+1,nl c ori do 330 i=1,ncum c ori if(k.ge.(icb(i)+1))then c ori tvp(i,k)=tvp(i,k)*(1.0-qnk(i)+ep(i,k)*clw(i,k)) c oric print*,'i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)' c oric print*, i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k) c ori endif c ori 330 continue c ori 340 continue c ori do 350 i=1,ncum c ori tvp(i,nlp)=tvp(i,nl)-(gz(i,nlp)-gz(i,nl))/cpd c ori 350 continue do 350 i=1,ncum ! convect3 tp(i,nlp)=tp(i,nl) ! convect3 350 continue ! convect3 c c===================================================================== c --- EFFECTIVE VERTICAL PROFILE OF BUOYANCY (convect3 only): c===================================================================== c-- this is for convect3 only: c first estimate of buoyancy: do 500 i=1,ncum do 501 k=1,nl buoy(i,k)=tvp(i,k)-tv(i,k) 501 continue 500 continue c set buoyancy=buoybase for all levels below base c for safety, set buoy(icb)=buoybase do 505 i=1,ncum do 506 k=1,nl if((k.ge.icb(i)).and.(k.le.nl).and.(p(i,k).ge.pbase(i)))then buoy(i,k)=buoybase(i) endif 506 continue c buoy(icb(i),k)=buoybase(i) buoy(i,icb(i))=buoybase(i) 505 continue c-- end convect3 c===================================================================== c --- FIND THE FIRST MODEL LEVEL (INB) ABOVE THE PARCEL'S c --- LEVEL OF NEUTRAL BUOYANCY c===================================================================== c c-- this is for convect3 only: do 510 i=1,ncum inb(i)=nl-1 iposit(i) = nl 510 continue c c-- iposit(i) = first level, above icb, with positive buoyancy do k = 1,nl-1 do i = 1,ncum if (k .ge. icb(i) .and. buoy(i,k) .gt. 0.) then iposit(i) = min(iposit(i),k) endif enddo enddo do i = 1,ncum if (iposit(i) .eq. nl) then iposit(i) = icb(i) endif enddo do 535 k=1,nl-1 do 530 i=1,ncum if ((k.ge.iposit(i)).and.(buoy(i,k).lt.dtovsh)) then inb(i)=MIN(inb(i),k) endif 530 continue 535 continue c c-- end convect3 c ori do 510 i=1,ncum c ori cape(i)=0.0 c ori capem(i)=0.0 c ori inb(i)=icb(i)+1 c ori inb1(i)=inb(i) c ori 510 continue c c Originial Code c c do 530 k=minorig+1,nl-1 c do 520 i=1,ncum c if(k.ge.(icb(i)+1))then c by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k) c byp=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1) c cape(i)=cape(i)+by c if(by.ge.0.0)inb1(i)=k+1 c if(cape(i).gt.0.0)then c inb(i)=k+1 c capem(i)=cape(i) c endif c endif c520 continue c530 continue c do 540 i=1,ncum c byp=(tvp(i,nl)-tv(i,nl))*dph(i,nl)/p(i,nl) c cape(i)=capem(i)+byp c defrac=capem(i)-cape(i) c defrac=max(defrac,0.001) c frac(i)=-cape(i)/defrac c frac(i)=min(frac(i),1.0) c frac(i)=max(frac(i),0.0) c540 continue c c K Emanuel fix c c call zilch(byp,ncum) c do 530 k=minorig+1,nl-1 c do 520 i=1,ncum c if(k.ge.(icb(i)+1))then c by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k) c cape(i)=cape(i)+by c if(by.ge.0.0)inb1(i)=k+1 c if(cape(i).gt.0.0)then c inb(i)=k+1 c capem(i)=cape(i) c byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1) c endif c endif c520 continue c530 continue c do 540 i=1,ncum c inb(i)=max(inb(i),inb1(i)) c cape(i)=capem(i)+byp(i) c defrac=capem(i)-cape(i) c defrac=max(defrac,0.001) c frac(i)=-cape(i)/defrac c frac(i)=min(frac(i),1.0) c frac(i)=max(frac(i),0.0) c540 continue c c J Teixeira fix c c ori call zilch(byp,ncum) c ori do 515 i=1,ncum c ori lcape(i)=.true. c ori 515 continue c ori do 530 k=minorig+1,nl-1 c ori do 520 i=1,ncum c ori if(cape(i).lt.0.0)lcape(i)=.false. c ori if((k.ge.(icb(i)+1)).and.lcape(i))then c ori by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k) c ori byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1) c ori cape(i)=cape(i)+by c ori if(by.ge.0.0)inb1(i)=k+1 c ori if(cape(i).gt.0.0)then c ori inb(i)=k+1 c ori capem(i)=cape(i) c ori endif c ori endif c ori 520 continue c ori 530 continue c ori do 540 i=1,ncum c ori cape(i)=capem(i)+byp(i) c ori defrac=capem(i)-cape(i) c ori defrac=max(defrac,0.001) c ori frac(i)=-cape(i)/defrac c ori frac(i)=min(frac(i),1.0) c ori frac(i)=max(frac(i),0.0) c ori 540 continue c c===================================================================== c --- CALCULATE LIQUID WATER STATIC ENERGY OF LIFTED PARCEL c===================================================================== c do k = 1,nd do i=1,ncum hp(i,k)=h(i,k) enddo enddo do 600 k=minorig+1,nl do 590 i=1,ncum if((k.ge.icb(i)).and.(k.le.inb(i)))then if (cvflag_ice) then frac(i,k)=1.-(t(i,k)-243.15)/(263.15-243.15) frac(i,k)=min(max(frac(i,k),0.0),1.0) hp(i,k)=hnk(i)+(lv(i,k)+(cpd-cpv)*t(i,k)+frac(i,k)*lf(i,k)) : *ep(i,k)*clw(i,k) else hp(i,k)=hnk(i)+(lv(i,k)+(cpd-cpv)*t(i,k))*ep(i,k)*clw(i,k) endif endif 590 continue 600 continue return end SUBROUTINE cv3_closure(nloc,ncum,nd,icb,inb : ,pbase,p,ph,tv,buoy o ,sig,w0,cape,m,iflag) implicit none !=================================================================== ! --- CLOSURE OF CONVECT3 ! ! vectorization: S. Bony !=================================================================== include "cvthermo.h" include "cv3param.h" c input: integer ncum, nd, nloc integer icb(nloc), inb(nloc) real pbase(nloc) real p(nloc,nd), ph(nloc,nd+1) real tv(nloc,nd), buoy(nloc,nd) c input/output: real sig(nloc,nd), w0(nloc,nd) integer iflag(nloc) c output: real cape(nloc) real m(nloc,nd) c local variables: integer i, j, k, icbmax real deltap, fac, w, amu real dtmin(nloc,nd), sigold(nloc,nd) real cbmflast(nloc) c ------------------------------------------------------- c -- Initialization c ------------------------------------------------------- do k=1,nl do i=1,ncum m(i,k)=0.0 enddo enddo c ------------------------------------------------------- c -- Reset sig(i) and w0(i) for i>inb and i>> do i=1,nd do il=1,ncum wdtrainA(il,i)=0.0 wdtrainM(il,i)=0.0 enddo enddo !! RomP <<< c c *** check whether ep(inb)=0, if so, skip precipitating *** c *** downdraft calculation *** c do il=1,ncum !! lwork(il)=.TRUE. !! if(ep(il,inb(il)).lt.0.0001)lwork(il)=.FALSE. lwork(il)= ep(il,inb(il)) .ge. 0.0001 enddo c *** Set the fractionnal area sigd of precipitating downdraughts do il = 1,ncum sigd(il) = sigdz*coef_clos(il) enddo c++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c c *** begin downdraft loop *** c c++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c DO 400 i=nl+1,1,-1 num1=0 do il=1,ncum if ( i.le.inb(il) .and. lwork(il) ) num1=num1+1 enddo if (num1.le.0) goto 400 call zilch(wdtrain,ncum) c c *** integrate liquid water equation to find condensed water *** c *** and condensed water flux *** c c c *** calculate detrained precipitation *** c do il=1,ncum if (i.le.inb(il) .and. lwork(il)) then if (cvflag_grav) then wdtrain(il)=grav*ep(il,i)*m(il,i)*clw(il,i) wdtrainA(il,i) = wdtrain(il)/grav ! Pa RomP else wdtrain(il)=10.0*ep(il,i)*m(il,i)*clw(il,i) wdtrainA(il,i) = wdtrain(il)/10. ! Pa RomP endif endif enddo if(i.gt.1)then do 320 j=1,i-1 do il=1,ncum if (i.le.inb(il) .and. lwork(il)) then awat=elij(il,j,i)-(1.-ep(il,i))*clw(il,i) awat=max(awat,0.0) if (cvflag_grav) then wdtrain(il)=wdtrain(il)+grav*awat*ment(il,j,i) wdtrainM(il,i) = wdtrain(il)/grav-wdtrainA(il,i) ! Pm RomP else wdtrain(il)=wdtrain(il)+10.0*awat*ment(il,j,i) wdtrainM(il,i) = wdtrain(il)/10.-wdtrainA(il,i) ! Pm RomP endif endif enddo 320 continue endif c c *** find rain water and evaporation using provisional *** c *** estimates of rp(i)and rp(i-1) *** c do 995 il=1,ncum if (i.le.inb(il) .and. lwork(il)) then wt(il,i)=45.0 if (cvflag_ice) then frac(il,inb(il)) = 1. -(t(il,inb(il))-243.15)/(263.15-243.15) frac(il,inb(il)) = min(max(frac(il,inb(il)),0.),1.) fraci(il,inb(il)) = frac(il,inb(il)) else continue endif if(i.lt.inb(il))then if (cvflag_ice) then thaw = (t(il,i)-273.15)/(275.15-273.15) thaw = min(max(thaw,0.0),1.0) frac(il,i)=frac(il,i)*(1.-thaw) else continue endif rp(il,i)=rp(il,i+1) : +(cpd*(t(il,i+1)-t(il,i))+gz(il,i+1)-gz(il,i))/lv(il,i) rp(il,i)=0.5*(rp(il,i)+rr(il,i)) endif fraci(il,i)=1.-(t(il,i)-243.15)/(263.15-243.15) fraci(il,i)=min(max(fraci(il,i),0.0),1.0) rp(il,i)=max(rp(il,i),0.0) rp(il,i)=amin1(rp(il,i),rs(il,i)) rp(il,inb(il))=rr(il,inb(il)) if(i.eq.1)then afac=p(il,1)*(rs(il,1)-rp(il,1))/(1.0e4+2000.0*p(il,1)*rs(il,1)) if (cvflag_ice) then afac1=p(il,i)*(rs(il,1)-rp(il,1))/(1.0e4+2000.0*p(il,1)*rs(il,1)) endif else rp(il,i-1)=rp(il,i) : +(cpd*(t(il,i)-t(il,i-1))+gz(il,i)-gz(il,i-1))/lv(il,i) rp(il,i-1)=0.5*(rp(il,i-1)+rr(il,i-1)) rp(il,i-1)=amin1(rp(il,i-1),rs(il,i-1)) rp(il,i-1)=max(rp(il,i-1),0.0) afac1=p(il,i)*(rs(il,i)-rp(il,i))/(1.0e4+2000.0*p(il,i)*rs(il,i)) afac2=p(il,i-1)*(rs(il,i-1)-rp(il,i-1)) : /(1.0e4+2000.0*p(il,i-1)*rs(il,i-1)) afac=0.5*(afac1+afac2) endif if(i.eq.inb(il))afac=0.0 afac=max(afac,0.0) bfac=1./(sigd(il)*wt(il,i)) c cjyg1 ccc sigt=1.0 ccc if(i.ge.icb)sigt=sigp(i) c prise en compte de la variation progressive de sigt dans c les couches icb et icb-1: c pour plclph(i), pr1=1 & pr2=0 c pour ph(i+1)>> SUBROUTINE cv3_tracer(nloc,len,ncum,nd,na, & ment,sigij,da,phi,phi2,d1a,dam, & ep,Vprecip,elij,clw,epmlmMm,eplaMm, & icb,inb) implicit none include "cv3param.h" c inputs: integer ncum, nd, na, nloc,len real ment(nloc,na,na),sigij(nloc,na,na) real clw(nloc,nd),elij(nloc,na,na) real ep(nloc,na) integer icb(nloc),inb(nloc) real VPrecip(nloc,nd+1) c ouputs: real da(nloc,na),phi(nloc,na,na) real phi2(nloc,na,na) real d1a(nloc,na),dam(nloc,na) real epmlmMm(nloc,na,na),eplaMm(nloc,na) ! variables pour tracer dans precip de l'AA et des mel c local variables: integer i,j,k real epm(nloc,na,na) c ! variables d'Emanuel : du second indice au troisieme ! ---> tab(i,k,j) -> de l origine k a l arrivee j ! ment, sigij, elij ! variables personnelles : du troisieme au second indice ! ---> tab(i,j,k) -> de k a j ! phi, phi2 ! ! initialisations c da(:,:)=0. d1a(:,:)=0. dam(:,:)=0. epm(:,:,:)=0. eplaMm(:,:)=0. epmlmMm(:,:,:)=0. phi(:,:,:)=0. phi2(:,:,:)=0. c ! fraction deau condensee dans les melanges convertie en precip : epm ! et eau condensée précipitée dans masse d'air saturé : l_m*dM_m/dzdz.dzdz do j=1,na do k=1,na do i=1,ncum if(k.ge.icb(i).and.k.le.inb(i).and. !!jyg & j.ge.k.and.j.le.inb(i)) then !!jyg epm(i,j,k)=1.-(1.-ep(i,j))*clw(i,j)/elij(i,k,j) & j.gt.k.and.j.le.inb(i)) then epm(i,j,k)=1.-(1.-ep(i,j))*clw(i,j)/ & max(elij(i,k,j),1.e-16) !! epm(i,j,k)=max(epm(i,j,k),0.0) endif end do end do end do ! do j=1,na do k=1,na do i=1,ncum if(k.ge.icb(i).and.k.le.inb(i)) then eplaMm(i,j)=eplaMm(i,j) + ep(i,j)*clw(i,j) & *ment(i,j,k)*(1.-sigij(i,j,k)) endif end do end do end do ! do j=1,na do k=1,j-1 do i=1,ncum if(k.ge.icb(i).and.k.le.inb(i).and. & j.le.inb(i)) then epmlmMm(i,j,k)=epm(i,j,k)*elij(i,k,j)*ment(i,k,j) endif end do end do end do ! matrices pour calculer la tendance des concentrations dans cvltr.F90 do j=1,na do k=1,na do i=1,ncum da(i,j)=da(i,j)+(1.-sigij(i,k,j))*ment(i,k,j) phi(i,j,k)=sigij(i,k,j)*ment(i,k,j) d1a(i,j)=d1a(i,j)+ment(i,k,j)*ep(i,k) & *(1.-sigij(i,k,j)) if(k.le.j) then dam(i,j)=dam(i,j)+ment(i,k,j) & *epm(i,k,j)*(1.-ep(i,k))*(1.-sigij(i,k,j)) phi2(i,j,k)=phi(i,j,k)*epm(i,j,k) endif end do end do end do return end !AC! et !RomP <<< SUBROUTINE cv3_uncompress(nloc,len,ncum,nd,ntra,idcum : ,iflag : ,precip,sig,w0 : ,ft,fq,fu,fv,ftra : ,Ma,upwd,dnwd,dnwd0,qcondc,wd,cape : ,iflag1 : ,precip1,sig1,w01 : ,ft1,fq1,fu1,fv1,ftra1 : ,Ma1,upwd1,dnwd1,dnwd01,qcondc1,wd1,cape1 : ) implicit none include "cv3param.h" c inputs: integer len, ncum, nd, ntra, nloc integer idcum(nloc) integer iflag(nloc) real precip(nloc) real sig(nloc,nd), w0(nloc,nd) real ft(nloc,nd), fq(nloc,nd), fu(nloc,nd), fv(nloc,nd) real ftra(nloc,nd,ntra) real Ma(nloc,nd) real upwd(nloc,nd),dnwd(nloc,nd),dnwd0(nloc,nd) real qcondc(nloc,nd) real wd(nloc),cape(nloc) c outputs: integer iflag1(len) real precip1(len) real sig1(len,nd), w01(len,nd) real ft1(len,nd), fq1(len,nd), fu1(len,nd), fv1(len,nd) real ftra1(len,nd,ntra) real Ma1(len,nd) real upwd1(len,nd),dnwd1(len,nd),dnwd01(len,nd) real qcondc1(nloc,nd) real wd1(nloc),cape1(nloc) c local variables: integer i,k,j do 2000 i=1,ncum precip1(idcum(i))=precip(i) iflag1(idcum(i))=iflag(i) wd1(idcum(i))=wd(i) cape1(idcum(i))=cape(i) 2000 continue do 2020 k=1,nl do 2010 i=1,ncum sig1(idcum(i),k)=sig(i,k) w01(idcum(i),k)=w0(i,k) ft1(idcum(i),k)=ft(i,k) fq1(idcum(i),k)=fq(i,k) fu1(idcum(i),k)=fu(i,k) fv1(idcum(i),k)=fv(i,k) Ma1(idcum(i),k)=Ma(i,k) upwd1(idcum(i),k)=upwd(i,k) dnwd1(idcum(i),k)=dnwd(i,k) dnwd01(idcum(i),k)=dnwd0(i,k) qcondc1(idcum(i),k)=qcondc(i,k) 2010 continue 2020 continue do 2200 i=1,ncum sig1(idcum(i),nd)=sig(i,nd) 2200 continue !AC! do 2100 j=1,ntra !AC!c oct3 do 2110 k=1,nl !AC! do 2110 k=1,nd ! oct3 !AC! do 2120 i=1,ncum !AC! ftra1(idcum(i),k,j)=ftra(i,k,j) !AC! 2120 continue !AC! 2110 continue !AC! 2100 continue return end