SUBROUTINE cv3_vertmix(len,nd,iflag,plim1,plim2,p,ph,t,q,u,v : ,w,wi,nk,tmix,thmix,qmix,qsmix : ,umix,vmix,plcl) *************************************************************** * * * CV3_VERTMIX Brassage adiabatique d'une couche d'epaisseur * * arbitraire. * * * * written by : Grandpeix Jean-Yves, 28/12/2001, 13.14.24 * * modified by : Filiberti M-A 06/2005 vectorisation * *************************************************************** * implicit none C============================================================== C C vertmix : determine theta et r du melange obtenu en brassant C adiabatiquement entre plim1 et plim2, avec une ponderation w. C C=============================================================== include "cvthermo.h" include "YOETHF.h" include "YOMCST.h" include "FCTTRE.h" c input : integer nd,len integer nk(len),iflag(len) real t(len,nd),q(len,nd),w(nd) real u(len,nd),v(len,nd) real p(len,nd),ph(len,nd+1) real plim1(len),plim2(len) c output : real tmix(len),thmix(len),qmix(len),wi(len,nd) real umix(len),vmix(len) real qsmix(len) real plcl(len) c internal variables : integer j1(len),j2(len),niflag7 real A,B real ahm(len),dpw(len),coef(len) real p1(len,nd),p2(len,nd) real rdcp(len),a2(len),b2(len),pnk(len) real rh(len),chi(len) real cpn real x,y,p0,p0m1,zdelta,zcor integer i,j do j = 1,nd do i=1,len if (plim1(i).le.ph(i,j)) j1(i) = j if (plim2(i).ge.ph(i,j+1).and.plim2(i).lt.ph(i,j)) j2(i) = j enddo enddo c do j=1,nd do i = 1,len wi(i,j) = 0. enddo enddo do i = 1,len ahm(i)=0. qmix(i)=0. umix(i)=0. vmix(i)=0. dpw(i) =0. a2(i)=0.0 b2(i) = 0. pnk(i) = p(i,nk(i)) enddo c p0 = 1000. p0m1 = 1./p0 c do i=1,len coef(i) = 1./(plim1(i)-plim2(i)) end do c do j=1,nd do i=1,len if (j.ge.j1(i).and.j.le.j2(i)) then p1(i,j) = min(ph(i,j),plim1(i)) p2(i,j) = max(ph(i,j+1),plim2(i)) cCRtest:couplage thermiques: deja normalise c wi(i,j) = w(j) c print*,'wi',wi(i,j) wi(i,j) = w(j)*(p1(i,j)-p2(i,j))*coef(i) dpw(i) = dpw(i)+wi(i,j) endif end do end do cCR:print c do i=1,len c print*,'plim',plim1(i),plim2(i) c enddo do j=1,nd do i=1,len if (j.ge.j1(i).and.j.le.j2(i)) then wi(i,j)=wi(i,j)/dpw(i) ahm(i)=ahm(i)+(cpd*(1.-q(i,j))+q(i,j)*cpv)*t(i,j)*wi(i,j) qmix(i)=qmix(i)+q(i,j)*wi(i,j) umix(i)=umix(i)+u(i,j)*wi(i,j) vmix(i)=vmix(i)+v(i,j)*wi(i,j) endif end do end do c do i=1,len rdcp(i)=(rrd*(1.-qmix(i))+qmix(i)*rrv)/ : (cpd*(1.-qmix(i))+qmix(i)*cpv) end do c c do 20 j=1,nd do 18 i=1,len if (j.ge.j1(i).and.j.le.j2(i)) then cc x=(.5*(p1(i,j)+p2(i,j))*p0m1)**rdcp(i) y=(.5*(p1(i,j)+p2(i,j))/pnk(i))**rdcp(i) cc a2(i)=a2(i)+(cpd*(1.-qmix(i))+qmix(i)*cpv)*x*wi(i,j) b2(i)=b2(i)+(cpd*(1.-qmix(i))+qmix(i)*cpv)*y*wi(i,j) endif 18 continue 20 continue c do i=1,len tmix(i) = ahm(i)/b2(i) thmix(i) =tmix(i)*(p0/pnk(i))**rdcp(i) c print*,'thmix ahm',ahm(i),b2(i) c print*,'thmix t',tmix(i),p0 c print*,'thmix p',pnk(i),rdcp(i) c print*,'thmix',thmix(i) cc thmix(i) = ahm(i)/a2(i) cc tmix(i)= thmix(i)*(pnk(i)*p0m1)**rdcp(i) zdelta=max(0.,sign(1.,rtt-tmix(i))) qsmix(i)= r2es*FOEEW(tmix(i),zdelta)/(pnk(i)*100.) qsmix(i)=min(0.5,qsmix(i)) zcor=1./(1.-retv*qsmix(i)) qsmix(i)=qsmix(i)*zcor end do c !------------------------------------------------------------------- ! --- Calculate lifted condensation level of air at parcel origin level ! --- (Within 0.2% of formula of Bolton, MON. WEA. REV.,1980) !------------------------------------------------------------------- A = 1669.0 ! convect3 B = 122.0 ! convect3 niflag7=0 do 260 i=1,len if (iflag(i).ne.7) then ! modif sb Jun7th 2002 c rh(i)=qmix(i)/qsmix(i) chi(i)=tmix(i)/(A-B*rh(i)-tmix(i)) ! convect3 c ATTENTION, la LIGNE DESSOUS A ETE RAJOUTEE ARBITRAIREMENT ET c MASQUE UN PB POTENTIEL chi(i)=max(chi(i),0.) rh(i)=max(rh(i),0.) plcl(i)=pnk(i)*(rh(i)**chi(i)) if(((plcl(i).lt.200.0).or.(plcl(i).ge.2000.0)) & .and.(iflag(i).eq.0))iflag(i)=8 else niflag7=niflag7+1 plcl(i)=plim2(i) c endif ! iflag=7 c print*,'NIFLAG7 =',niflag7 260 continue return end