! ! $Id: cv3p1_closure.F 1664 2012-10-09 13:29:15Z fairhead $ ! SUBROUTINE cv3p1_closure(nloc,ncum,nd,icb,inb & & ,pbase,plcl,p,ph,tv,tvp,buoy & & ,Supmax,ok_inhib,Ale,Alp & & ,sig,w0,ptop2,cape,cin,m,iflag,coef & & ,Plim1,Plim2,asupmax,supmax0 & & ,asupmaxmin,cbmf,plfc,wbeff) !* !*************************************************************** !* * !* CV3P1_CLOSURE * !* Ale & Alp Closure of Convect3 * !* * !* written by : Kerry Emanuel * !* vectorization: S. Bony * !* modified by : Jean-Yves Grandpeix, 18/06/2003, 19.32.10 * !* Julie Frohwirth, 14/10/2005 17.44.22 * !*************************************************************** !* implicit none #include "cvthermo.h" #include "cv3param.h" #include "YOMCST2.h" #include "YOMCST.h" #include "conema3.h" #include "iniprint.h" !c input: integer ncum, nd, nloc integer icb(nloc), inb(nloc) real pbase(nloc),plcl(nloc) real p(nloc,nd), ph(nloc,nd+1) real tv(nloc,nd),tvp(nloc,nd), buoy(nloc,nd) real Supmax(nloc,nd) logical ok_inhib ! enable convection inhibition by dryness real Ale(nloc),Alp(nloc) !c input/output: real sig(nloc,nd), w0(nloc,nd), ptop2(nloc) !c output: real cape(nloc),cin(nloc) real m(nloc,nd) real Plim1(nloc),Plim2(nloc) real asupmax(nloc,nd),supmax0(nloc) real asupmaxmin(nloc) real cbmf(nloc),plfc(nloc) real wbeff(nloc) integer iflag(nloc) !c !c local variables: integer il, i, j, k, icbmax, i0(nloc) real deltap, fac, w, amu real rhodp real Pbmxup real dtmin(nloc,nd), sigold(nloc,nd) real coefmix(nloc,nd) real pzero(nloc),ptop2old(nloc) real cina(nloc),cinb(nloc) integer ibeg(nloc) integer nsupmax(nloc) real supcrit,temp(nloc,nd) real P1(nloc),Pmin(nloc) real asupmax0(nloc) logical ok(nloc) real siglim(nloc,nd),wlim(nloc,nd),mlim(nloc,nd) real wb2(nloc) real cbmflim(nloc),cbmf1(nloc),cbmfmax(nloc) real cbmflast(nloc) real coef(nloc) real xp(nloc),xq(nloc),xr(nloc),discr(nloc),b3(nloc),b4(nloc) real theta(nloc),bb(nloc) real term1,term2,term3 real alp2(nloc) ! Alp with offset !c real sigmax parameter (sigmax = 0.1) CHARACTER (LEN=20) :: modname='cv3p1_closure' CHARACTER (LEN=80) :: abort_message !c !c print *,' -> cv3p1_closure, Ale ',ale(1) !c !c ------------------------------------------------------- !c -- Initialization !c ------------------------------------------------------- !c !c do il = 1,ncum alp2(il) = max(alp(il),1.e-5) !IM alp2(il) = max(alp(il),1.e-12) enddo !c PBMXUP=50. ! PBMXUP+PBCRIT = cloud depth above which mixed updraughts !c exist (if any) if(prt_level.GE.20) & & print*,'cv3p1_param nloc ncum nd icb inb nl',nloc,ncum,nd, & & icb(nloc),inb(nloc),nl do k=1,nl do il=1,ncum m(il,k)=0.0 enddo enddo !c ------------------------------------------------------- !c -- Reset sig(i) and w0(i) for i>inb and i no calculation of wbeff wbeff(il) = 100.1 ELSE !c Calculate wbeff IF (flag_wb==0) THEN wbeff(il) = wbmax ELSE IF (flag_wb==1) THEN wbeff(il) = wbmax/(1.+500./(ph(il,1)-plfc(il))) ELSE IF (flag_wb==2) THEN wbeff(il) = wbmax*(0.01*(ph(il,1)-plfc(il)))**2 ENDIF END IF END DO DO il = 1,ncum !cjyg Modification du coef de wb*wb pour conformite avec papier Wake !cc cbmf1(il) = alp2(il)/(0.5*wb*wb-Cin(il)) cbmf1(il) = alp2(il)/(2.*wbeff(il)*wbeff(il)-Cin(il)) if(cbmf1(il).EQ.0.AND.alp2(il).NE.0.) THEN write(lunout,*) & & 'cv3p1_closure cbmf1=0 and alp NE 0 il alp2 alp cin ',il, & & alp2(il),alp(il),cin(il) abort_message = '' CALL abort_gcm (modname,abort_message,1) endif cbmfmax(il) = sigmax*wb2(il)*100.*p(il,icb(il)) & & /(rrd*tv(il,icb(il))) ENDDO !c DO il = 1,ncum IF (cbmflim(il) .gt. 1.e-6) THEN !cATTENTION TEST CR !c if (cbmfmax(il).lt.1.e-12) then cbmf(il) = min(cbmf1(il),cbmfmax(il)) !c else !c cbmf(il) = cbmf1(il) !c endif !c print*,'cbmf',cbmf1(il),cbmfmax(il) ENDIF ENDDO if(prt_level.GE.20) print*,'cv3p1_param apres cbmflim_testCR' !c !cc 2. Compute coefficient and apply correction !c do il = 1,ncum coef(il) = (cbmf(il)+1.e-10)/(cbmflim(il)+1.e-10) enddo if(prt_level.GE.20) print*,'cv3p1_param apres coef_plantePLUS' !c DO k = 1,nl do il = 1,ncum IF ( k .ge. icb(il)+1 .AND. k .le. inb(il)) THEN amu=beta*sig(il,k)*w0(il,k)+ & & (1.-beta)*coef(il)*siglim(il,k)*wlim(il,k) w0(il,k) = wlim(il,k) w0(il,k) =max(w0(il,k),1.e-10) sig(il,k)=amu/w0(il,k) sig(il,k)=min(sig(il,k),1.) !cc amu = 0.5*(SIG(il,k)+sigold(il,k))*W0(il,k) M(il,k)=AMU*0.007*P(il,k)*(PH(il,k)-PH(il,k+1))/TV(il,k) ENDIF enddo ENDDO !cjyg2 DO il = 1,ncum w0(il,icb(il))=0.5*w0(il,icb(il)+1) m(il,icb(il))=0.5*m(il,icb(il)+1) & & *(ph(il,icb(il))-ph(il,icb(il)+1)) & & /(ph(il,icb(il)+1)-ph(il,icb(il)+2)) sig(il,icb(il))=sig(il,icb(il)+1) sig(il,icb(il)-1)=sig(il,icb(il)) ENDDO if(prt_level.GE.20) print*,'cv3p1_param apres w0_sig_M' !c !cc 3. Compute final cloud base mass flux and set iflag to 3 if !cc cloud base mass flux is exceedingly small and is decreasing (i.e. if !cc the final mass flux (cbmflast) is greater than the target mass flux !cc (cbmf)). !c do il = 1,ncum cbmflast(il) = 0. enddo !c do k= 1,nl do il = 1,ncum IF (k .ge. icb(il) .and. k .le. inb(il)) THEN !IMpropo?? IF ((k.ge.(icb(il)+1)).and.(k.le.inb(il))) THEN cbmflast(il) = cbmflast(il)+M(il,k) ENDIF enddo enddo !c do il = 1,ncum IF (cbmflast(il) .lt. 1.e-6 .and. & & cbmflast(il) .ge. cbmf(il)) THEN iflag(il) = 3 ENDIF enddo !c do k= 1,nl do il = 1,ncum IF (iflag(il) .ge. 3) THEN M(il,k) = 0. sig(il,k) = 0. w0(il,k) = 0. ENDIF enddo enddo if(prt_level.GE.20) print*,'cv3p1_param apres iflag' !c !cc 4. Introduce a correcting factor for coef, in order to obtain an effective !cc sigdz larger in the present case (using cv3p1_closure) than in the old !cc closure (using cv3_closure). if (1.eq.0) then do il = 1,ncum !cc coef(il) = 2.*coef(il) coef(il) = 5.*coef(il) enddo !c version CVS du ..2008 else if (iflag_cvl_sigd.eq.0) then !ctest pour verifier qu on fait la meme chose qu avant: sid constant coef(1:ncum)=1. else coef(1:ncum) = min(2.*coef(1:ncum),5.) coef(1:ncum) = max(2.*coef(1:ncum),0.2) endif endif !c if(prt_level.GE.20) print*,'cv3p1_param FIN' return end