Index: /LMDZ.3.3/branches/rel-LF/libf/dyn3d/bilan_dyn.F =================================================================== --- /LMDZ.3.3/branches/rel-LF/libf/dyn3d/bilan_dyn.F (revision 418) +++ /LMDZ.3.3/branches/rel-LF/libf/dyn3d/bilan_dyn.F (revision 418) @@ -0,0 +1,570 @@ + SUBROUTINE bilan_dyn (ntrac,dt_app,dt_cum, + s ps,masse,pk,flux_u,flux_v,teta,phi,ucov,vcov,trac) + +c AFAIRE +c Prevoir en champ nq+1 le diagnostique de l'energie +c en faisant Qzon=Cv T + L * ... +c vQ..A=Cp T + L * ... + + USE IOIPSL + + IMPLICIT NONE + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom2.h" + +c==================================================================== +c +c Sous-programme consacre à des diagnostics dynamiques de base +c +c +c De facon generale, les moyennes des scalaires Q sont ponderees par +c la masse. +c +c Les flux de masse sont eux simplement moyennes. +c +c==================================================================== + +c Arguments : +c =========== + + integer ntrac + real dt_app,dt_cum + real ps(iip1,jjp1) + real masse(iip1,jjp1,llm),pk(iip1,jjp1,llm) + real flux_u(iip1,jjp1,llm) + real flux_v(iip1,jjm,llm) + real teta(iip1,jjp1,llm) + real phi(iip1,jjp1,llm) + real ucov(iip1,jjp1,llm) + real vcov(iip1,jjp1,llm) + real trac(iip1,jjp1,llm,ntrac) + +c Local : +c ======= + + integer icum,ncum + logical first + real zz,zqy,zfactv(jjm,llm) + + integer nQ + parameter (nQ=7) + + + character*6 nom(nQ) + character*6 unites(nQ) + character*10 file + integer ifile + parameter (ifile=4) + + integer itemp,igeop,iecin,iang,iu,iovap,iun + integer i_sortie + + save first,icum,ncum + save itemp,igeop,iecin,iang,iu,iovap,iun + save i_sortie + + real time + integer itau + save time,itau + data time,itau/0.,0/ + + data first/.true./ + data itemp,igeop,iecin,iang,iu,iovap,iun/1,2,3,4,5,6,7/ + data i_sortie/1/ + + real ww + +c variables dynamiques intermédiaires + REAL vcont(iip1,jjm,llm),ucont(iip1,jjp1,llm) + REAL ang(iip1,jjp1,llm),unat(iip1,jjp1,llm) + REAL massebx(iip1,jjp1,llm),masseby(iip1,jjm,llm) + REAL vorpot(iip1,jjm,llm) + REAL w(iip1,jjp1,llm),ecin(iip1,jjp1,llm),convm(iip1,jjp1,llm) + REAL bern(iip1,jjp1,llm) + +c champ contenant les scalaires advectés. + real Q(iip1,jjp1,llm,nQ) + +c champs cumulés + real ps_cum(iip1,jjp1) + real masse_cum(iip1,jjp1,llm) + real flux_u_cum(iip1,jjp1,llm) + real flux_v_cum(iip1,jjm,llm) + real Q_cum(iip1,jjp1,llm,nQ) + real flux_uQ_cum(iip1,jjp1,llm,nQ) + real flux_vQ_cum(iip1,jjm,llm,nQ) + real flux_wQ_cum(iip1,jjp1,llm,nQ) + real dQ(iip1,jjp1,llm,nQ) + + save ps_cum,masse_cum,flux_u_cum,flux_v_cum + save Q_cum,flux_uQ_cum,flux_vQ_cum + +c champs de tansport en moyenne zonale + integer ntr,itr + parameter (ntr=5) + + character*10 znom(ntr,nQ) + character*20 znoml(ntr,nQ) + character*10 zunites(ntr,nQ) + integer iave,itot,immc,itrs,istn + data iave,itot,immc,itrs,istn/1,2,3,4,5/ + character*3 ctrs(ntr) + data ctrs/' ','TOT','MMC','TRS','STN'/ + + real zvQ(jjm,llm,ntr,nQ),zvQtmp(jjm,llm) + real zavQ(jjm,ntr,nQ),psiQ(jjm,llm+1,nQ) + real zmasse(jjm,llm),zamasse(jjm) + + real zv(jjm,llm),psi(jjm,llm+1) + + integer i,j,l,iQ + + +c Initialisation du fichier contenant les moyennes zonales. +c --------------------------------------------------------- + + character*10 infile + + integer*4 day0, anne0 + integer fileid + integer thoriid, zvertiid + save fileid + + integer ndex3d(jjm*llm) + +C Variables locales +C + integer tau0 + real zjulian + character*3 str + character*10 ctrac + integer ii,jj + integer zan +C + real rlong(jjm),rlatg(jjm) + + + +c===================================================================== +c Initialisation +c===================================================================== + + time=time+dt_app + itau=itau+1 + + if (first) then + + + icum=0 +c initialisation des fichiers + first=.false. +c ncum est la frequence de stokage en pas de temps + ncum=dt_cum/dt_app + if (abs(ncum*dt_app-dt_cum).gt.1.e-5*dt_app) then + print*,'Pb : le pas de cumule doit etre multiple du pas' + print*,'dt_app=',dt_app + print*,'dt_cum=',dt_cum + stop + endif + + if (i_sortie.eq.1) then + file='dynzon' + call inigrads(ifile,1 + s ,0.,180./pi,0.,0.,jjm,rlatv,-90.,90.,180./pi + s ,llm,presnivs,1. + s ,dt_cum,file,'dyn_zon ') + endif + + nom(itemp)='T' + nom(igeop)='gz' + nom(iecin)='K' + nom(iang)='ang' + nom(iu)='u' + nom(iovap)='ovap' + nom(iun)='un' + + unites(itemp)='K' + unites(igeop)='m2/s2' + unites(iecin)='m2/s2' + unites(iang)='ang' + unites(iu)='m/s' + unites(iovap)='kg/kg' + unites(iun)='un' + + +c Initialisation du fichier contenant les moyennes zonales. +c --------------------------------------------------------- + + infile='dynzon' + + day0=0 + zan = 0. + + CALL ymds2ju(zan, 1, 1, 0.0, zjulian) + zjulian = zjulian + day0 + tau0 = 0 + + rlong=0. + rlatg=rlatv*180./pi + + call histbeg(infile, 1, rlong, jjm, rlatg, + . 1, 1, 1, jjm, + . tau0, zjulian, dt_cum, thoriid, fileid) + +C +C Appel a histvert pour la grille verticale +C + call histvert(fileid, 'presnivs', 'Niveaux sigma','mb', + . llm, presnivs, zvertiid) +C +C Appels a histdef pour la definition des variables a sauvegarder + do iQ=1,nQ + do itr=1,ntr + if(itr.eq.1) then + znom(itr,iQ)=nom(iQ) + znoml(itr,iQ)=nom(iQ) + zunites(itr,iQ)=unites(iQ) + else + znom(itr,iQ)=ctrs(itr)//'v'//nom(iQ) + znoml(itr,iQ)='transport : v * '//nom(iQ)//' '//ctrs(itr) + zunites(itr,iQ)='m/s * '//unites(iQ) + endif + enddo + enddo + +c Declarations des champs avec dimension verticale + print*,'1HISTDEF' + do iQ=1,nQ + do itr=1,ntr + print*,'var ',itr,iQ + . ,znom(itr,iQ),znoml(itr,iQ),zunites(itr,iQ) + call histdef(fileid,znom(itr,iQ),znoml(itr,iQ), + . zunites(itr,iQ),1,jjm,thoriid,llm,1,llm,zvertiid, + . 32,'ave(X)',dt_cum,dt_cum) + enddo +c Declarations pour les fonctions de courant + print*,'2HISTDEF' + call histdef(fileid,'psi'//nom(iQ) + . ,'stream fn. '//znoml(itot,iQ), + . zunites(itot,iQ),1,jjm,thoriid,llm,1,llm,zvertiid, + . 32,'ave(X)',dt_cum,dt_cum) + enddo + + +c Declarations pour les champs de transport d'air + print*,'3HISTDEF' + call histdef(fileid, 'masse', 'masse', + . 'kg', 1, jjm, thoriid, llm, 1, llm, zvertiid, + . 32, 'ave(X)', dt_cum, dt_cum) + call histdef(fileid, 'v', 'v', + . 'm/s', 1, jjm, thoriid, llm, 1, llm, zvertiid, + . 32, 'ave(X)', dt_cum, dt_cum) +c Declarations pour les fonctions de courant + print*,'4HISTDEF' + call histdef(fileid,'psi','stream fn. MMC ','mega t/s', + . 1,jjm,thoriid,llm,1,llm,zvertiid, + . 32,'ave(X)',dt_cum,dt_cum) + + +c Declaration des champs 1D de transport en latitude + print*,'5HISTDEF' + do iQ=1,nQ + do itr=2,ntr + call histdef(fileid,'a'//znom(itr,iQ),znoml(itr,iQ), + . zunites(itr,iQ),1,jjm,thoriid,1,1,1,-99, + . 32,'ave(X)',dt_cum,dt_cum) + enddo + enddo + + + print*,'8HISTDEF' + CALL histend(fileid) + + + endif + + +c===================================================================== +c Calcul des champs dynamiques +c ---------------------------- + +c énergie cinétique + CALL covcont(llm,ucov,vcov,ucont,vcont) + CALL enercin(vcov,ucov,vcont,ucont,ecin) + +c moment cinétique + do l=1,llm + ang(:,:,l)=ucov(:,:,l)+constang(:,:) + unat(:,:,l)=ucont(:,:,l)*cu(:,:) + enddo + + Q(:,:,:,itemp)=teta(:,:,:)*pk(:,:,:)/cpp + Q(:,:,:,igeop)=phi(:,:,:) + Q(:,:,:,iecin)=ecin(:,:,:) + Q(:,:,:,iang)=ang(:,:,:) + Q(:,:,:,iu)=unat(:,:,:) + Q(:,:,:,iovap)=q(:,:,:,1) + Q(:,:,:,iun)=1. + + +c===================================================================== +c Cumul +c===================================================================== +c + if(icum.EQ.0) then + ps_cum=0. + masse_cum=0. + flux_u_cum=0. + flux_v_cum=0. + Q_cum=0. + flux_vQ_cum=0. + flux_uQ_cum=0. + endif + + print*,'dans bilan_dyn ',icum,'->',icum+1 + icum=icum+1 + +c accumulation des flux de masse horizontaux + ps_cum=ps_cum+ps + masse_cum=masse_cum+masse + flux_u_cum=flux_u_cum+flux_u + flux_v_cum=flux_v_cum+flux_v + do iQ=1,nQ + Q_cum(:,:,:,iQ)=Q_cum(:,:,:,iQ)+Q(:,:,:,iQ)*masse(:,:,:) + enddo + +c===================================================================== +c FLUX ET TENDANCES +c===================================================================== + +c Flux longitudinal +c ----------------- + do iQ=1,nQ + do l=1,llm + do j=1,jjp1 + do i=1,iim + flux_uQ_cum(i,j,l,iQ)=flux_uQ_cum(i,j,l,iQ) + s +flux_u(i,j,l)*0.5*(Q(i,j,l,iQ)+Q(i+1,j,l,iQ)) + enddo + flux_uQ_cum(iip1,j,l,iQ)=flux_uQ_cum(1,j,l,iQ) + enddo + enddo + enddo + +c flux méridien +c ------------- + do iQ=1,nQ + do l=1,llm + do j=1,jjm + do i=1,iip1 + flux_vQ_cum(i,j,l,iQ)=flux_vQ_cum(i,j,l,iQ) + s +flux_v(i,j,l)*0.5*(Q(i,j,l,iQ)+Q(i,j+1,l,iQ)) + enddo + enddo + enddo + enddo + + +c tendances +c --------- + +c convergence horizontale + call convflu(flux_uQ_cum,flux_vQ_cum,llm*nQ,dQ) + +c calcul de la vitesse verticale + call convmas(flux_u_cum,flux_v_cum,convm) + CALL vitvert(convm,w) + + do iQ=1,nQ + do l=1,llm-1 + do j=1,jjp1 + do i=1,iip1 + ww=-0.5*w(i,j,l+1)*(Q(i,j,l,iQ)+Q(i,j,l+1,iQ)) + dQ(i,j,l ,iQ)=dQ(i,j,l ,iQ)-ww + dQ(i,j,l+1,iQ)=dQ(i,j,l+1,iQ)+ww + enddo + enddo + enddo + enddo + + print*,'Apres les calculs fait a chaque pas' +c===================================================================== +c PAS DE TEMPS D'ECRITURE +c===================================================================== + if (icum.eq.ncum) then +c===================================================================== + + print*,'Pas d ecriture' + +c Normalisation + do iQ=1,nQ + Q_cum(:,:,:,iQ)=Q_cum(:,:,:,iQ)/masse_cum(:,:,:) + enddo + zz=1./float(ncum) + ps_cum=ps_cum*zz + masse_cum=masse_cum*zz + flux_u_cum=flux_u_cum*zz + flux_v_cum=flux_v_cum*zz + flux_uQ_cum=flux_uQ_cum*zz + flux_vQ_cum=flux_vQ_cum*zz + dQ=dQ*zz + +c print*,'1OK' + +c A retravailler eventuellement +c division de dQ par la masse pour revenir aux bonnes grandeurs + do iQ=1,nQ + dQ(:,:,:,iQ)=dQ(:,:,:,iQ)/masse_cum(:,:,:) + enddo + +c print*,'2OK' +c===================================================================== +c Transport méridien +c===================================================================== + +c cumul zonal des masses des mailles +c ---------------------------------- + zv=0. + zmasse=0. + call massbar(masse_cum,massebx,masseby) + do l=1,llm + do j=1,jjm + do i=1,iim + zmasse(j,l)=zmasse(j,l)+masseby(i,j,l) + zv(j,l)=zv(j,l)+flux_v_cum(i,j,l) + enddo + zfactv(j,l)=cv(1,j)/zmasse(j,l) + enddo + enddo + +c print*,'3OK' +c -------------------------------------------------------------- +c calcul de la moyenne zonale du transport : +c ------------------------------------------ +c +c -- +c TOT : la circulation totale [ vq ] +c +c - - +c MMC : mean meridional circulation [ v ] [ q ] +c +c ---- -- - - +c TRS : transitoires [ v'q'] = [ vq ] - [ v q ] +c +c - * - * - - - - +c STT : stationaires [ v q ] = [ v q ] - [ v ] [ q ] +c +c - - +c on utilise aussi l'intermediaire TMP : [ v q ] +c +c la variable zfactv transforme un transport meridien cumule +c en kg/s * unte-du-champ-transporte en m/s * unite-du-champ-transporte +c +c -------------------------------------------------------------- + + +c ---------------------------------------- +c Transport dans le plan latitude-altitude +c ---------------------------------------- + + zvQ=0. + psiQ=0. + do iQ=1,nQ + zvQtmp=0. + do l=1,llm + do j=1,jjm +c print*,'j,l,iQ=',j,l,iQ +c Calcul des moyennes zonales du transort total et de zvQtmp + do i=1,iim + zvQ(j,l,itot,iQ)=zvQ(j,l,itot,iQ) + s +flux_vQ_cum(i,j,l,iQ) + zqy= 0.5*(Q_cum(i,j,l,iQ)*masse_cum(i,j,l)+ + s Q_cum(i,j+1,l,iQ)*masse_cum(i,j+1,l)) + zvQtmp(j,l)=zvQtmp(j,l)+flux_v_cum(i,j,l)*zqy + s /(0.5*(masse_cum(i,j,l)+masse_cum(i,j+1,l))) + zvQ(j,l,iave,iQ)=zvQ(j,l,iave,iQ)+zqy + enddo +c print*,'aOK' +c Decomposition + zvQ(j,l,iave,iQ)=zvQ(j,l,iave,iQ)/zmasse(j,l) + zvQ(j,l,itot,iQ)=zvQ(j,l,itot,iQ)*zfactv(j,l) + zvQtmp(j,l)=zvQtmp(j,l)*zfactv(j,l) + zvQ(j,l,immc,iQ)=zv(j,l)*zvQ(j,l,iave,iQ)*zfactv(j,l) + zvQ(j,l,itrs,iQ)=zvQ(j,l,itot,iQ)-zvQtmp(j,l) + zvQ(j,l,istn,iQ)=zvQtmp(j,l)-zvQ(j,l,immc,iQ) + enddo + enddo +c fonction de courant meridienne pour la quantite Q + do l=llm,1,-1 + do j=1,jjm + psiQ(j,l,iQ)=psiQ(j,l+1,iQ)+zvQ(j,l,itot,iQ) + enddo + enddo + enddo + +c fonction de courant pour la circulation meridienne moyenne + psi=0. + do l=llm,1,-1 + do j=1,jjm + psi(j,l)=psi(j,l+1)+zv(j,l) + zv(j,l)=zv(j,l)*zfactv(j,l) + enddo + enddo + +c print*,'4OK' +c sorties proprement dites + if (i_sortie.eq.1) then + do iQ=1,nQ + do itr=1,ntr + call histwrite(fileid,znom(itr,iQ),itau,zvQ(:,:,itr,iQ) + s ,jjm*llm,ndex3d) + enddo + call histwrite(fileid,'psi'//nom(iQ),itau,psiQ(:,1:llm,iQ) + s ,jjm*llm,ndex3d) + enddo + + call histwrite(fileid,'masse',itau,zmasse + s ,jjm*llm,ndex3d) + call histwrite(fileid,'v',itau,zv + s ,jjm*llm,ndex3d) + psi=psi*1.e-9 + call histwrite(fileid,'psi',itau,psi(:,1:llm),jjm*llm,ndex3d) + + endif + + +c ----------------- +c Moyenne verticale +c ----------------- + + zamasse=0. + do l=1,llm + zamasse(:)=zamasse(:)+zmasse(:,l) + enddo + zavQ=0. + do iQ=1,nQ + do itr=2,ntr + do l=1,llm + zavQ(:,itr,iQ)=zavQ(:,itr,iQ)+zvQ(:,l,itr,iQ)*zmasse(:,l) + enddo + zavQ(:,itr,iQ)=zavQ(:,itr,iQ)/zamasse(:) + call histwrite(fileid,'a'//znom(itr,iQ),itau,zavQ(:,itr,iQ) + s ,jjm*llm,ndex3d) + enddo + enddo + +c on doit pouvoir tracer systematiquement la fonction de courant. + +c===================================================================== +c///////////////////////////////////////////////////////////////////// + icum=0 !/////////////////////////////////////// + endif ! icum.eq.ncum !/////////////////////////////////////// +c///////////////////////////////////////////////////////////////////// +c===================================================================== + + return + end Index: /LMDZ.3.3/branches/rel-LF/libf/dyn3d/diagedyn.F =================================================================== --- /LMDZ.3.3/branches/rel-LF/libf/dyn3d/diagedyn.F (revision 418) +++ /LMDZ.3.3/branches/rel-LF/libf/dyn3d/diagedyn.F (revision 418) @@ -0,0 +1,308 @@ + +C====================================================================== + SUBROUTINE diagedyn(tit,iprt,idiag,idiag2,dtime + e , ucov , vcov , ps, p ,pk , teta , q, ql,aire + s , d_h_vcol , d_qt, d_qw, d_ql, d_ec) +C====================================================================== +C +C Purpose: +C Calcul la difference d'enthalpie et de masse d'eau entre 2 appels, +C et calcul le flux de chaleur et le flux d'eau necessaire a ces +C changements. Ces valeurs sont moyennees sur la surface de tout +C le globe et sont exprime en W/2 et kg/s/m2 +C Outil pour diagnostiquer la conservation de l'energie +C et de la masse dans la dynamique. +C +C +c====================================================================== +C Arguments: +C tit-----imput-A15- Comment added in PRINT (CHARACTER*15) +C iprt----input-I- PRINT level ( <=1 : no PRINT) +C idiag---input-I- indice dans lequel sera range les nouveaux +C bilans d' entalpie et de masse +C idiag2--input-I-les nouveaux bilans d'entalpie et de masse +C sont compare au bilan de d'enthalpie de masse de +C l'indice numero idiag2 +C Cas parriculier : si idiag2=0, pas de comparaison, on +c sort directement les bilans d'enthalpie et de masse +C dtime----input-R- time step (s) +C uconv, vconv-input-R- vents covariants (m/s) +C ps-------input-R- Surface pressure (Pa) +C p--------input-R- pressure at the interfaces +C pk-------input-R- pk= (p/Pref)**kappa +c teta-----input-R- potential temperature (K) +c q--------input-R- vapeur d'eau (kg/kg) +c ql-------input-R- liquid watter (kg/kg) +c aire-----input-R- mesh surafce (m2) +c +C the following total value are computed by UNIT of earth surface +C +C d_h_vcol--output-R- Heat flux (W/m2) define as the Enthalpy +c change (J/m2) during one time step (dtime) for the whole +C atmosphere (air, watter vapour, liquid and solid) +C d_qt------output-R- total water mass flux (kg/m2/s) defined as the +C total watter (kg/m2) change during one time step (dtime), +C d_qw------output-R- same, for the watter vapour only (kg/m2/s) +C d_ql------output-R- same, for the liquid watter only (kg/m2/s) +C d_ec------output-R- Cinetic Energy Budget (W/m2) for vertical air column +C +C +C J.L. Dufresne, July 2002 +c====================================================================== + + IMPLICIT NONE +C +#include "dimensions.h" +#include "paramet.h" +#include "../phylmd/YOMCST.h" +#include "../phylmd/YOETHF.h" +C + INTEGER imjmp1 + PARAMETER( imjmp1=iim*jjp1) +c Input variables + CHARACTER*15 tit + INTEGER iprt,idiag, idiag2 + REAL dtime + REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) ! vents covariants + REAL ps(ip1jmp1) ! pression au sol + REAL p (ip1jmp1,llmp1 ) ! pression aux interfac.des couches + REAL pk (ip1jmp1,llmp1 ) ! = (p/Pref)**kappa + REAL teta(ip1jmp1,llm) ! temperature potentielle + REAL q(ip1jmp1,llm) ! champs eau vapeur + REAL ql(ip1jmp1,llm) ! champs eau liquide + REAL aire(ip1jmp1) ! aire des mailles + + +c Output variables + REAL d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec +C +C Local variables +c + REAL h_vcol_tot, h_dair_tot, h_qw_tot, h_ql_tot + . , h_qs_tot, qw_tot, ql_tot, qs_tot , ec_tot +c h_vcol_tot-- total enthalpy of vertical air column +C (air with watter vapour, liquid and solid) (J/m2) +c h_dair_tot-- total enthalpy of dry air (J/m2) +c h_qw_tot---- total enthalpy of watter vapour (J/m2) +c h_ql_tot---- total enthalpy of liquid watter (J/m2) +c h_qs_tot---- total enthalpy of solid watter (J/m2) +c qw_tot------ total mass of watter vapour (kg/m2) +c ql_tot------ total mass of liquid watter (kg/m2) +c qs_tot------ total mass of solid watter (kg/m2) +c ec_tot------ total cinetic energy (kg/m2) +C + REAL masse(ip1jmp1,llm) ! masse d'air + REAL vcont(ip1jm,llm),ucont(ip1jmp1,llm) + REAL ecin(ip1jmp1,llm) + + REAL zaire(imjmp1) + REAL zps(imjmp1) + REAL zairm(imjmp1,llm) + REAL zecin(imjmp1,llm) + REAL zpaprs(imjmp1,llm) + REAL zpk(imjmp1,llm) + REAL zt(imjmp1,llm) + REAL zh(imjmp1,llm) + REAL zqw(imjmp1,llm) + REAL zql(imjmp1,llm) + REAL zqs(imjmp1,llm) + + REAL zqw_col(imjmp1) + REAL zql_col(imjmp1) + REAL zqs_col(imjmp1) + REAL zec_col(imjmp1) + REAL zh_dair_col(imjmp1) + REAL zh_qw_col(imjmp1), zh_ql_col(imjmp1), zh_qs_col(imjmp1) +C + REAL d_h_dair, d_h_qw, d_h_ql, d_h_qs +C + REAL airetot, zcpvap, zcwat, zcice +C + INTEGER i, k, jj, ij , l ,ip1jjm1 +C + INTEGER ndiag ! max number of diagnostic in parallel + PARAMETER (ndiag=10) + integer pas(ndiag) + save pas + data pas/ndiag*0/ +C + REAL h_vcol_pre(ndiag), h_dair_pre(ndiag), h_qw_pre(ndiag) + $ , h_ql_pre(ndiag), h_qs_pre(ndiag), qw_pre(ndiag) + $ , ql_pre(ndiag), qs_pre(ndiag) , ec_pre(ndiag) + SAVE h_vcol_pre, h_dair_pre, h_qw_pre, h_ql_pre + $ , h_qs_pre, qw_pre, ql_pre, qs_pre , ec_pre + + +c====================================================================== +C Compute Kinetic enrgy + CALL covcont ( llm , ucov , vcov , ucont, vcont ) + CALL enercin ( vcov , ucov , vcont , ucont , ecin ) + CALL massdair( p, masse ) +c====================================================================== +C +C +C On ne garde les donnees que dans les colonnes i=1,iim + DO jj = 1,jjp1 + ip1jjm1=iip1*(jj-1) + DO ij = 1,iim + i=iim*(jj-1)+ij + zaire(i)=aire(ij+ip1jjm1) + zps(i)=ps(ij+ip1jjm1) + ENDDO + ENDDO +C 3D arrays + DO l = 1, llm + DO jj = 1,jjp1 + ip1jjm1=iip1*(jj-1) + DO ij = 1,iim + i=iim*(jj-1)+ij + zairm(i,l) = masse(ij+ip1jjm1,l) + zecin(i,l) = ecin(ij+ip1jjm1,l) + zpaprs(i,l) = p(ij+ip1jjm1,l) + zpk(i,l) = pk(ij+ip1jjm1,l) + zh(i,l) = teta(ij+ip1jjm1,l) + zqw(i,l) = q(ij+ip1jjm1,l) + zql(i,l) = ql(ij+ip1jjm1,l) + zqs(i,l) = 0. + ENDDO + ENDDO + ENDDO +C +C Reset variables + DO i = 1, imjmp1 + zqw_col(i)=0. + zql_col(i)=0. + zqs_col(i)=0. + zec_col(i) = 0. + zh_dair_col(i) = 0. + zh_qw_col(i) = 0. + zh_ql_col(i) = 0. + zh_qs_col(i) = 0. + ENDDO +C + zcpvap=RCPV + zcwat=RCW + zcice=RCS +C +C Compute vertical sum for each atmospheric column +C ================================================ + DO k = 1, llm + DO i = 1, imjmp1 +C Watter mass + zqw_col(i) = zqw_col(i) + zqw(i,k)*zairm(i,k) + zql_col(i) = zql_col(i) + zql(i,k)*zairm(i,k) + zqs_col(i) = zqs_col(i) + zqs(i,k)*zairm(i,k) +C Cinetic Energy + zec_col(i) = zec_col(i) + $ +zecin(i,k)*zairm(i,k) +C Air enthalpy + zt(i,k)= zh(i,k) * zpk(i,k) / RCPD + zh_dair_col(i) = zh_dair_col(i) + $ + RCPD*(1.-zqw(i,k)-zql(i,k)-zqs(i,k))*zairm(i,k)*zt(i,k) + zh_qw_col(i) = zh_qw_col(i) + $ + zcpvap*zqw(i,k)*zairm(i,k)*zt(i,k) + zh_ql_col(i) = zh_ql_col(i) + $ + zcwat*zql(i,k)*zairm(i,k)*zt(i,k) + $ - RLVTT*zql(i,k)*zairm(i,k) + zh_qs_col(i) = zh_qs_col(i) + $ + zcice*zqs(i,k)*zairm(i,k)*zt(i,k) + $ - RLSTT*zqs(i,k)*zairm(i,k) + + END DO + ENDDO +C +C Mean over the planete surface +C ============================= + qw_tot = 0. + ql_tot = 0. + qs_tot = 0. + ec_tot = 0. + h_vcol_tot = 0. + h_dair_tot = 0. + h_qw_tot = 0. + h_ql_tot = 0. + h_qs_tot = 0. + airetot=0. +C + do i=1,imjmp1 + qw_tot = qw_tot + zqw_col(i) + ql_tot = ql_tot + zql_col(i) + qs_tot = qs_tot + zqs_col(i) + ec_tot = ec_tot + zec_col(i) + h_dair_tot = h_dair_tot + zh_dair_col(i) + h_qw_tot = h_qw_tot + zh_qw_col(i) + h_ql_tot = h_ql_tot + zh_ql_col(i) + h_qs_tot = h_qs_tot + zh_qs_col(i) + airetot=airetot+zaire(i) + END DO +C + qw_tot = qw_tot/airetot + ql_tot = ql_tot/airetot + qs_tot = qs_tot/airetot + ec_tot = ec_tot/airetot + h_dair_tot = h_dair_tot/airetot + h_qw_tot = h_qw_tot/airetot + h_ql_tot = h_ql_tot/airetot + h_qs_tot = h_qs_tot/airetot +C + h_vcol_tot = h_dair_tot+h_qw_tot+h_ql_tot+h_qs_tot +C +C Compute the change of the atmospheric state compare to the one +C stored in "idiag2", and convert it in flux. THis computation +C is performed IF idiag2 /= 0 and IF it is not the first CALL +c for "idiag" +C =================================== +C + IF ( (idiag2.gt.0) .and. (pas(idiag2) .ne. 0) ) THEN + d_h_vcol = (h_vcol_tot - h_vcol_pre(idiag2) )/dtime + d_h_dair = (h_dair_tot- h_dair_pre(idiag2))/dtime + d_h_qw = (h_qw_tot - h_qw_pre(idiag2) )/dtime + d_h_ql = (h_ql_tot - h_ql_pre(idiag2) )/dtime + d_h_qs = (h_qs_tot - h_qs_pre(idiag2) )/dtime + d_qw = (qw_tot - qw_pre(idiag2) )/dtime + d_ql = (ql_tot - ql_pre(idiag2) )/dtime + d_qs = (qs_tot - qs_pre(idiag2) )/dtime + d_ec = (ec_tot - ec_pre(idiag2) )/dtime + d_qt = d_qw + d_ql + d_qs + ELSE + d_h_vcol = 0. + d_h_dair = 0. + d_h_qw = 0. + d_h_ql = 0. + d_h_qs = 0. + d_qw = 0. + d_ql = 0. + d_qs = 0. + d_ec = 0. + d_qt = 0. + ENDIF +C + IF (iprt.ge.2) THEN + WRITE(6,9000) tit,pas(idiag),d_qt,d_qw,d_ql,d_qs + 9000 format('Dyn3d. Watter Mass Budget (kg/m2/s)',A15 + $ ,1i6,10(1pE14.6)) + WRITE(6,9001) tit,pas(idiag), d_h_vcol + 9001 format('Dyn3d. Enthalpy Budget (W/m2) ',A15,1i6,10(F8.2)) + WRITE(6,9002) tit,pas(idiag), d_ec + 9002 format('Dyn3d. Cinetic Energy Budget (W/m2) ',A15,1i6,10(F8.2)) +C WRITE(6,9003) tit,pas(idiag), ec_tot + 9003 format('Dyn3d. Cinetic Energy (W/m2) ',A15,1i6,10(E15.6)) + WRITE(6,9004) tit,pas(idiag), d_h_vcol+d_ec + 9004 format('Dyn3d. Total Energy Budget (W/m2) ',A15,1i6,10(F8.2)) + END IF +C +C Store the new atmospheric state in "idiag" +C + pas(idiag)=pas(idiag)+1 + h_vcol_pre(idiag) = h_vcol_tot + h_dair_pre(idiag) = h_dair_tot + h_qw_pre(idiag) = h_qw_tot + h_ql_pre(idiag) = h_ql_tot + h_qs_pre(idiag) = h_qs_tot + qw_pre(idiag) = qw_tot + ql_pre(idiag) = ql_tot + qs_pre(idiag) = qs_tot + ec_pre (idiag) = ec_tot +C + RETURN + END Index: /LMDZ.3.3/branches/rel-LF/libf/phylmd/clcdrag.F90 =================================================================== --- /LMDZ.3.3/branches/rel-LF/libf/phylmd/clcdrag.F90 (revision 418) +++ /LMDZ.3.3/branches/rel-LF/libf/phylmd/clcdrag.F90 (revision 418) @@ -0,0 +1,101 @@ + SUBROUTINE clcdrag(klon, knon, nsrf, zxli, & + u, v, t, q, zgeop, & + ts, qsurf, rugos, & + pcfm, pcfh) + IMPLICIT NONE +! ================================================================= c +! +! Objet : calcul des cdrags pour le moment (pcfm) et +! les flux de chaleur sensible et latente (pcfh). +! +! ================================================================= c +! +! klon----input-I- dimension de la grille physique (= nb_pts_latitude X nb_pts_longitude) +! knon----input-I- nombre de points pour un type de surface +! nsrf----input-I- indice pour le type de surface; voir indicesol.inc +! zxli----input-L- calcul des cdrags selon Laurent Li +! u-------input-R- vent zonal au 1er niveau du modele +! v-------input-R- vent meridien au 1er niveau du modele +! t-------input-R- temperature de l'air au 1er niveau du modele +! q-------input-R- humidite de l'air au 1er niveau du modele +! zgeop---input-R- geopotentiel au 1er niveau du modele +! ts------input-R- temperature de l'air a la surface +! qsurf---input-R- humidite de l'air a la surface +! rugos---input-R- rugosite +! +! pcfm---output-R- cdrag pour le moment +! pcfh---output-R- cdrag pour les flux de chaleur latente et sensible +! + INTEGER, intent(in) :: klon, knon, nsrf + LOGICAL, intent(in) :: zxli + REAL, intent(in), dimension(klon) :: u, v, t, q, zgeop + REAL, intent(in), dimension(klon) :: ts, qsurf + REAL, intent(in), dimension(klon) :: rugos + REAL, intent(out), dimension(klon) :: pcfm, pcfh +! ================================================================= c +! +#include "YOMCST.inc" +#include "YOETHF.inc" +#include "indicesol.inc" +! +! Quelques constantes et options: + REAL, PARAMETER :: ckap=0.35, cb=5.0, cc=5.0, cd=5.0, cepdu2=(0.1)**2 +! +! Variables locales : + INTEGER :: i + REAL :: zdu2, ztsolv, ztvd, zscf + REAL :: zucf, zcr + REAL :: friv, frih + REAL, dimension(klon) :: zcfm1, zcfm2 + REAL, dimension(klon) :: zcfh1, zcfh2 + REAL, dimension(klon) :: zcdn + REAL, dimension(klon) :: zri +! +! Fonctions thermodynamiques et fonctions d'instabilite + REAL :: fsta, fins, x + fsta(x) = 1.0 / (1.0+10.0*x*(1+8.0*x)) + fins(x) = SQRT(1.0-18.0*x) +! ================================================================= c +! +! Calculer le frottement au sol (Cdrag) +! + DO i = 1, knon + zdu2 = max(cepdu2,u(i)**2+v(i)**2) + ztsolv = ts(i) * (1.0+RETV*qsurf(i)) + ztvd = (t(i)+zgeop(i)/RCPD/(1.+RVTMP2*q(i))) & + *(1.+RETV*q(i)) + zri(i) = zgeop(i)*(ztvd-ztsolv)/(zdu2*ztvd) + zcdn(i) = (ckap/log(1.+zgeop(i)/(RG*rugos(i))))**2 +! + IF (zri(i) .ge. 0.) THEN ! situation stable + zri(i) = min(20.,zri(i)) + IF (.NOT.zxli) THEN + zscf = SQRT(1.+cd*ABS(zri(i))) + FRIV = AMAX1(1. / (1.+2.*CB*zri(i)/ZSCF), 0.1) + zcfm1(i) = zcdn(i) * FRIV + FRIH = AMAX1(1./ (1.+3.*CB*zri(i)*ZSCF), 0.1 ) + zcfh1(i) = zcdn(i) * FRIH + pcfm(i) = zcfm1(i) + pcfh(i) = zcfh1(i) + ELSE + pcfm(i) = zcdn(i)* fsta(zri(i)) + pcfh(i) = zcdn(i)* fsta(zri(i)) + ENDIF + ELSE ! situation instable + IF (.NOT.zxli) THEN + zucf = 1./(1.+3.0*cb*cc*zcdn(i)*SQRT(ABS(zri(i)) & + *(1.0+zgeop(i)/(RG*rugos(i))))) + zcfm2(i) = zcdn(i)*amax1((1.-2.0*cb*zri(i)*zucf),0.1) + zcfh2(i) = zcdn(i)*amax1((1.-3.0*cb*zri(i)*zucf),0.1) + pcfm(i) = zcfm2(i) + pcfh(i) = zcfh2(i) + ELSE + pcfm(i) = zcdn(i)* fins(zri(i)) + pcfh(i) = zcdn(i)* fins(zri(i)) + ENDIF + zcr = (0.0016/(zcdn(i)*SQRT(zdu2)))*ABS(ztvd-ztsolv)**(1./3.) + IF(nsrf.EQ.is_oce) pcfh(i) = zcdn(i)*(1.0+zcr**1.25)**(1./1.25) + ENDIF + END DO + RETURN + END SUBROUTINE clcdrag Index: /LMDZ.3.3/branches/rel-LF/libf/phylmd/clouds_gno.F =================================================================== --- /LMDZ.3.3/branches/rel-LF/libf/phylmd/clouds_gno.F (revision 418) +++ /LMDZ.3.3/branches/rel-LF/libf/phylmd/clouds_gno.F (revision 418) @@ -0,0 +1,250 @@ +C +C================================================================================ +C + SUBROUTINE CLOUDS_GNO(klon,ND,R,RS,QSUB,PTCONV,RATQSC,CLDF) + IMPLICIT NONE +C +C-------------------------------------------------------------------------------- +C +C Inputs: +C +C ND----------: Number of vertical levels +C R--------ND-: Domain-averaged mixing ratio of total water +C RS-------ND-: Mean saturation humidity mixing ratio within the gridbox +C QSUB-----ND-: Mixing ratio of condensed water within clouds associated +C with SUBGRID-SCALE condensation processes (here, it is +C predicted by the convection scheme) +C Outputs: +C +C PTCONV-----ND-: Point convectif = TRUE +C RATQSC-----ND-: Largeur normalisee de la distribution +C CLDF-----ND-: Fraction nuageuse +C +C-------------------------------------------------------------------------------- + + + INTEGER klon,ND + REAL R(klon,ND), RS(klon,ND), QSUB(klon,ND) + LOGICAL PTCONV(klon,ND) + REAL RATQSC(klon,ND) + REAL CLDF(klon,ND) + +c -- parameters controlling the iteration: +c -- nmax : maximum nb of iterations (hopefully never reached) +c -- epsilon : accuracy of the numerical resolution +c -- vmax : v-value above which we use an asymptotic expression for ERF(v) + + INTEGER nmax + PARAMETER ( nmax = 10) + REAL epsilon, vmax0, vmax(klon) + PARAMETER ( epsilon = 0.02, vmax0 = 2.0 ) + + REAL min_mu, min_Q + PARAMETER ( min_mu = 1.e-12, min_Q=1.e-12 ) + + INTEGER i,K, n, m + REAL mu(klon), qsat(klon), delta(klon), beta(klon) + real zu2(klon),zv2(klon) + REAL xx(klon), aux(klon), coeff(klon), block(klon) + REAL dist(klon), fprime(klon), det(klon) + REAL pi, u(klon), v(klon), erfu(klon), erfv(klon) + REAL xx1(klon), xx2(klon) + real erf,kkk +c lconv = true si le calcul a converge (entre autre si qsub < min_q) + LOGICAL lconv(klon) + + + pi = ACOS(-1.) + + ptconv=.false. + ratqsc=0. + + + DO 500 K = 1, ND + + do i=1,klon ! vector + mu(i) = R(i,K) + mu(i) = MAX(mu(i),min_mu) + qsat(i) = RS(i,K) + qsat(i) = MAX(qsat(i),min_mu) + delta(i) = log(mu(i)/qsat(i)) + enddo ! vector + +C +C *** There is no subgrid-scale condensation; *** +C *** the scheme becomes equivalent to an "all-or-nothing" *** +C *** large-scale condensation scheme. *** +C + +C +C *** Some condensation is produced at the subgrid-scale *** +C *** *** +C *** PDF = generalized log-normal distribution (GNO) *** +C *** (k<0 because a lower bound is considered for the PDF) *** +C *** *** +C *** -> Determine x (the parameter k of the GNO PDF) such *** +C *** that the contribution of subgrid-scale processes to *** +C *** the in-cloud water content is equal to QSUB(K) *** +C *** (equations (13), (14), (15) + Appendix B of the paper) *** +C *** *** +C *** Here, an iterative method is used for this purpose *** +C *** (other numerical methods might be more efficient) *** +C *** *** +C *** NB: the "error function" is called ERF *** +C *** (ERF in double precision) *** +C + +c On commence par eliminer les cas pour lesquels on n'a pas +c suffisamment d'eau nuageuse. + + do i=1,klon ! vector + + IF ( QSUB(i,K) .lt. min_Q ) THEN + ptconv(i,k)=.false. + ratqsc(i,k)=0. + lconv(i) = .true. + +c Rien on a deja initialise + + ELSE + + lconv(i) = .FALSE. + vmax(i) = vmax0 + + beta(i) = QSUB(i,K)/mu(i) + EXP( -MIN(0.0,delta(i)) ) + +c -- roots of equation v > vmax: + + det(i) = delta(i) + vmax(i)**2. + if (det(i).LE.0.0) vmax(i) = vmax0 + 1.0 + det(i) = delta(i) + vmax(i)**2. + + if (det(i).LE.0.) then + xx(i) = -0.0001 + else + xx1(i)=-SQRT(2.)*vmax(i)*(1.0-SQRT(1.0+delta(i)/(vmax(i)**2.))) + xx2(i)=-SQRT(2.)*vmax(i)*(1.0+SQRT(1.0+delta(i)/(vmax(i)**2.))) + xx(i) = 1.01 * xx1(i) + if ( xx1(i) .GE. 0.0 ) xx(i) = 0.5*xx2(i) + endif + if (delta(i).LT.0.) xx(i) = -0.5*SQRT(log(2.)) + + ENDIF + + enddo ! vector + +c---------------------------------------------------------------------- +c Debut des nmax iterations pour trouver la solution. +c---------------------------------------------------------------------- + + DO n = 1, nmax + + do i=1,klon ! vector + if (.not.lconv(i)) then + + u(i) = delta(i)/(xx(i)*sqrt(2.)) + xx(i)/(2.*sqrt(2.)) + v(i) = delta(i)/(xx(i)*sqrt(2.)) - xx(i)/(2.*sqrt(2.)) + + IF ( v(i) .GT. vmax(i) ) THEN + + IF ( ABS(u(i)) .GT. vmax(i) + : .AND. delta(i) .LT. 0. ) THEN + +c -- use asymptotic expression of erf for u and v large: +c ( -> analytic solution for xx ) + + aux(i) = 2.0*delta(i)*(1.-beta(i)*EXP(delta(i))) + : /(1.+beta(i)*EXP(delta(i))) + if (aux(i).lt.0.) then + print*,'AUX(',i,',',k,')<0',aux(i),delta(i),beta(i) + aux(i)=0. + endif + xx(i) = -SQRT(aux(i)) + block(i) = EXP(-v(i)*v(i)) / v(i) / SQRT(pi) + dist(i) = 0.0 + fprime(i) = 1.0 + + ELSE + +c -- erfv -> 1.0, use an asymptotic expression of erfv for v large: + + erfu(i) = ERF(u(i)) +c !!! ATTENTION : rajout d'un seuil pour l'exponentiel + aux(i) = SQRT(pi)*(1.0-erfu(i))*EXP(min(v(i)*v(i),100.)) + coeff(i) = 1.0 - 1./2./(v(i)**2.) + 3./4./(v(i)**4.) + block(i) = coeff(i) * EXP(-v(i)*v(i)) / v(i) / SQRT(pi) + dist(i) = v(i) * aux(i) / coeff(i) - beta(i) + fprime(i) = 2.0 / xx(i) * (v(i)**2.) + : * ( coeff(i)*EXP(-delta(i)) - u(i) * aux(i) ) + : / coeff(i) / coeff(i) + + ENDIF ! ABS(u) + + ELSE + +c -- general case: + + erfu(i) = ERF(u(i)) + erfv(i) = ERF(v(i)) + block(i) = 1.0-erfv(i) + dist(i) = (1.0 - erfu(i)) / (1.0 - erfv(i)) - beta(i) + zu2(i)=u(i)*u(i) + zv2(i)=v(i)*v(i) + if(zu2(i).gt.20..or. zv2(i).gt.20.) then + print*,'ATTENTION !!! xx(',i,') =', xx(i) + print*,'ATTENTION !!! klon,ND,R,RS,QSUB,PTCONV,RATQSC,CLDF', + .klon,ND,R(i,k),RS(i,k),QSUB(i,k),PTCONV(i,k),RATQSC(i,k), + .CLDF(i,k) + print*,'ATTENTION !!! zu2 zv2 =',zu2(i),zv2(i) + zu2(i)=20. + zv2(i)=20. + fprime(i) = 0. + else + fprime(i) = 2. /SQRT(pi) /xx(i) /(1.0-erfv(i))**2. + : * ( (1.0-erfv(i))*v(i)*EXP(-zu2(i)) + : - (1.0-erfu(i))*u(i)*EXP(-zv2(i)) ) + endif + ENDIF ! x + +c -- test numerical convergence: + +c print*,'avant test ',i,k,lconv(i),u(i),v(i) + if ( ABS(dist(i)/beta(i)) .LT. epsilon ) then +c print*,'v-u **2',(v(i)-u(i))**2 +c print*,'exp v-u **2',exp((v(i)-u(i))**2) + ptconv(i,K) = .TRUE. + lconv(i)=.true. +c borne pour l'exponentielle + ratqsc(i,k)=min(2.*(v(i)-u(i))**2,20.) + ratqsc(i,k)=sqrt(exp(ratqsc(i,k))-1.) + CLDF(i,K) = 0.5 * block(i) +cccccccccccccccccccccccc +c kkk=-sqrt(log(1.+ratqsc(i,k)**2)) +c u(i)=delta(i)/(kkk*sqrt(2.))-kkk/(2.*sqrt(2.)) +c v(i)=delta(i)/(kkk*sqrt(2.))+kkk/(2.*sqrt(2.)) +c erfu(i)=erf(u(i)) +c erfv(i)=erf(v(i)) +c print*,'SIG ',k,qsub(i,k) +c s ,mu(i)*((1.-erfv(i))/(1.-erfu(i))-qsat(i)/mu(i)) +c s ,0.5*erfu(i) +cccccccccccccccccccccccc + else + xx(i) = xx(i) - dist(i)/fprime(i) + endif +c print*,'apres test ',i,k,lconv(i) + + endif ! lconv + enddo ! vector + +c---------------------------------------------------------------------- +c Fin des nmax iterations pour trouver la solution. + ENDDO ! n +c---------------------------------------------------------------------- + +500 CONTINUE ! K + + RETURN + END + + + Index: /LMDZ.3.3/branches/rel-LF/libf/phylmd/coefcdrag.F90 =================================================================== --- /LMDZ.3.3/branches/rel-LF/libf/phylmd/coefcdrag.F90 (revision 418) +++ /LMDZ.3.3/branches/rel-LF/libf/phylmd/coefcdrag.F90 (revision 418) @@ -0,0 +1,137 @@ + SUBROUTINE coefcdrag (klon, knon, nsrf, zxli, & + speed, t, q, zgeop, psol, & + ts, qsurf, rugos, okri, ri1, & + cdram, cdrah, cdran, zri1, pref) + IMPLICIT none +!------------------------------------------------------------------------- +! Objet : calcul des cdrags pour le moment (cdram) et les flux de chaleur +! sensible et latente (cdrah), du cdrag neutre (cdran), +! du nombre de Richardson entre la surface et le niveau de reference +! (zri1) et de la pression au niveau de reference (pref). +! +! I. Musat, 01.07.2002 +!------------------------------------------------------------------------- +! +! klon----input-I- dimension de la grille physique (= nb_pts_latitude X nb_pts_longitude) +! knon----input-I- nombre de points pour un type de surface +! nsrf----input-I- indice pour le type de surface; voir indicesol.inc +! zxli----input-L- TRUE si calcul des cdrags selon Laurent Li +! speed---input-R- module du vent au 1er niveau du modele +! t-------input-R- temperature de l'air au 1er niveau du modele +! q-------input-R- humidite de l'air au 1er niveau du modele +! zgeop---input-R- geopotentiel au 1er niveau du modele +! psol----input-R- pression au sol +! ts------input-R- temperature de l'air a la surface +! qsurf---input-R- humidite de l'air a la surface +! rugos---input-R- rugosite +! okri----input-L- TRUE si on veut tester le nb. Richardson entre la sfce +! et zref par rapport au Ri entre la sfce et la 1ere couche +! ri1-----input-R- nb. Richardson entre la surface et la 1ere couche +! +! cdram--output-R- cdrag pour le moment +! cdrah--output-R- cdrag pour les flux de chaleur latente et sensible +! cdran--output-R- cdrag neutre +! zri1---output-R- nb. Richardson entre la surface et la couche zgeop/RG +! pref---output-R- pression au niveau zgeop/RG +! + INTEGER, intent(in) :: klon, knon, nsrf + LOGICAL, intent(in) :: zxli + REAL, dimension(klon), intent(in) :: speed, t, q, zgeop, psol + REAL, dimension(klon), intent(in) :: ts, qsurf, rugos, ri1 + LOGICAL, intent(in) :: okri +! + REAL, dimension(klon), intent(out) :: cdram, cdrah, cdran, zri1, pref +!------------------------------------------------------------------------- +! +#include "YOMCST.inc" +#include "YOETHF.inc" +#include "indicesol.inc" +! Quelques constantes : + REAL, parameter :: RKAR=0.40, CB=5.0, CC=5.0, CD=5.0 +! +! Variables locales : + INTEGER :: i + REAL, dimension(klon) :: zdu2, zdphi, ztsolv, ztvd + REAL, dimension(klon) :: zscf, friv, frih, zucf, zcr + REAL, dimension(klon) :: zcfm1, zcfh1 + REAL, dimension(klon) :: zcfm2, zcfh2 + REAL, dimension(klon) :: trm0, trm1 +!------------------------------------------------------------------------- + REAL :: fsta, fins, x + fsta(x) = 1.0 / (1.0+10.0*x*(1+8.0*x)) + fins(x) = SQRT(1.0-18.0*x) +!------------------------------------------------------------------------- +! + DO i = 1, knon +! + zdphi(i) = zgeop(i) + zdu2(i) = speed(i)**2 + pref(i) = exp(log(psol(i)) - zdphi(i)/(RD*t(i)* & + (1.+ RETV * max(q(i),0.0)))) + ztsolv(i) = ts(i) + ztvd(i) = t(i) * (psol(i)/pref(i))**RKAPPA + trm0(i) = 1. + RETV * max(qsurf(i),0.0) + trm1(i) = 1. + RETV * max(q(i),0.0) + ztsolv(i) = ztsolv(i) * trm0(i) + ztvd(i) = ztvd(i) * trm1(i) + zri1(i) = zdphi(i)*(ztvd(i)-ztsolv(i))/(zdu2(i)*ztvd(i)) +! +! on teste zri1 par rapport au Richardson de la 1ere couche ri1 +! + IF (okri) THEN + IF (ri1(i).GE.0.0.AND.zri1(i).LT.0.0) THEN + zri1(i) = ri1(i) + ELSE IF(ri1(i).LT.0.0.AND.zri1(i).GE.0.0) THEN + zri1(i) = ri1(i) + ENDIF + ENDIF +! + cdran(i) = (RKAR/log(1.+zdphi(i)/(RG*rugos(i))))**2 + + IF (zri1(i) .ge. 0.) THEN +! +! situation stable : pour eviter les inconsistances dans les cas +! tres stables on limite zri1 a 20. cf Hess et al. (1995) +! + zri1(i) = min(20.,zri1(i)) +! + IF (.NOT.zxli) THEN + zscf(i) = SQRT(1.+CD*ABS(zri1(i))) + friv(i) = max(1. / (1.+2.*CB*zri1(i)/ zscf(i)), 0.1) + zcfm1(i) = cdran(i) * friv(i) + frih(i) = max(1./ (1.+3.*CB*zri1(i)*zscf(i)), 0.1 ) + zcfh1(i) = cdran(i) * frih(i) + cdram(i) = zcfm1(i) + cdrah(i) = zcfh1(i) + ELSE + cdram(i) = cdran(i)* fsta(zri1(i)) + cdrah(i) = cdran(i)* fsta(zri1(i)) + ENDIF +! + ELSE +! +! situation instable +! + IF (.NOT.zxli) THEN + zucf(i) = 1./(1.+3.0*CB*CC*cdran(i)*SQRT(ABS(zri1(i)) & + *(1.0+zdphi(i)/(RG*rugos(i))))) + zcfm2(i) = cdran(i)*max((1.-2.0*CB*zri1(i)*zucf(i)),0.1) + zcfh2(i) = cdran(i)*max((1.-3.0*CB*zri1(i)*zucf(i)),0.1) + cdram(i) = zcfm2(i) + cdrah(i) = zcfh2(i) + ELSE + cdram(i) = cdran(i)* fins(zri1(i)) + cdrah(i) = cdran(i)* fins(zri1(i)) + ENDIF +! +! cdrah sur l'ocean cf. Miller et al. (1992) +! + zcr(i) = (0.0016/(cdran(i)*SQRT(zdu2(i))))*ABS(ztvd(i)-ztsolv(i)) & + **(1./3.) + IF (nsrf.EQ.is_oce) cdrah(i) = cdran(i)*(1.0+zcr(i)**1.25) & + **(1./1.25) + ENDIF +! + END DO + RETURN + END SUBROUTINE coefcdrag Index: /LMDZ.3.3/branches/rel-LF/libf/phylmd/coefcdrag_int.F90 =================================================================== --- /LMDZ.3.3/branches/rel-LF/libf/phylmd/coefcdrag_int.F90 (revision 418) +++ /LMDZ.3.3/branches/rel-LF/libf/phylmd/coefcdrag_int.F90 (revision 418) @@ -0,0 +1,22 @@ +MODULE coefcdrag_int + + IMPLICIT NONE + + INTERFACE + + SUBROUTINE coefcdrag (klon, knon, nsrf, zxli, & + speed, t, q, zgeop, psol, & + ts, qsurf, rugos, okri, ri1, & + cdram, cdrah, cdran, zri1, pref) + INTEGER, intent(in) :: klon, knon, nsrf + LOGICAL, intent(in) :: zxli + REAL, dimension(klon), intent(in) :: speed, t, q, zgeop, psol + REAL, dimension(klon), intent(in) :: ts, qsurf, rugos, ri1 + LOGICAL, intent(in) :: okri + REAL, dimension(klon), intent(out) :: cdram, cdrah, cdran, zri1, pref + + END SUBROUTINE coefcdrag + + END INTERFACE + +END MODULE coefcdrag_int Index: /LMDZ.3.3/branches/rel-LF/libf/phylmd/concvl.F =================================================================== --- /LMDZ.3.3/branches/rel-LF/libf/phylmd/concvl.F (revision 418) +++ /LMDZ.3.3/branches/rel-LF/libf/phylmd/concvl.F (revision 418) @@ -0,0 +1,173 @@ + SUBROUTINE concvl (iflag_con,dtime,paprs,pplay,t,q,u,v,tra,ntra, + . work1,work2,d_t,d_q,d_u,d_v,d_tra, + . rain, snow, kbas, ktop, + . upwd,dnwd,dnwdbis,Ma,cape,tvp,iflag, + . pbase,bbase,dtvpdt1,dtvpdq1,dplcldt,dplcldr, + . qcondc,wd) + +c + IMPLICIT none +c====================================================================== +c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818 +c Objet: schema de convection de Emanuel (1991) interface +c====================================================================== +c Arguments: +c dtime--input-R-pas d'integration (s) +c s-------input-R-la valeur "s" pour chaque couche +c sigs----input-R-la valeur "sigma" de chaque couche +c sig-----input-R-la valeur de "sigma" pour chaque niveau +c psolpa--input-R-la pression au sol (en Pa) +C pskapa--input-R-exponentiel kappa de psolpa +c h-------input-R-enthalpie potentielle (Cp*T/P**kappa) +c q-------input-R-vapeur d'eau (en kg/kg) +c +c work*: input et output: deux variables de travail, +c on peut les mettre a 0 au debut +c ALE-----input-R-energie disponible pour soulevement +c +C d_h-----output-R-increment de l'enthalpie potentielle (h) +c d_q-----output-R-increment de la vapeur d'eau +c rain----output-R-la pluie (mm/s) +c snow----output-R-la neige (mm/s) +c upwd----output-R-saturated updraft mass flux (kg/m**2/s) +c dnwd----output-R-saturated downdraft mass flux (kg/m**2/s) +c dnwd0---output-R-unsaturated downdraft mass flux (kg/m**2/s) +c Cape----output-R-CAPE (J/kg) +c Tvp-----output-R-Temperature virtuelle d'une parcelle soulevee +c adiabatiquement a partir du niveau 1 (K) +c deltapb-output-R-distance entre LCL et base de la colonne (<0 ; Pa) +c Ice_flag-input-L-TRUE->prise en compte de la thermodynamique de la glace +c====================================================================== +c +#include "dimensions.h" +#include "dimphy.h" +c + integer NTRAC + PARAMETER (NTRAC=nqmx-2) +c + INTEGER iflag_con +c + REAL dtime, paprs(klon,klev+1),pplay(klon,klev) + REAL t(klon,klev),q(klon,klev),u(klon,klev),v(klon,klev) + REAL tra(klon,klev,ntrac) + INTEGER ntra + REAL work1(klon,klev),work2(klon,klev) +c + REAL d_t(klon,klev),d_q(klon,klev),d_u(klon,klev),d_v(klon,klev) + REAL d_tra(klon,klev,ntrac) + REAL rain(klon),snow(klon) +c + INTEGER kbas(klon),ktop(klon) + REAL em_ph(klon,klev+1),em_p(klon,klev) + REAL upwd(klon,klev),dnwd(klon,klev),dnwdbis(klon,klev) + REAL Ma(klon,klev),cape(klon),tvp(klon,klev) + INTEGER iflag(klon) + REAL rflag(klon) + REAL pbase(klon),bbase(klon) + REAL dtvpdt1(klon,klev),dtvpdq1(klon,klev) + REAL dplcldt(klon),dplcldr(klon) + REAL qcondc(klon,klev) + REAL wd(klon) +c + REAL zx_t,zdelta,zx_qs,zcor +c + INTEGER noff, minorig + INTEGER i,k,itra + REAL qs(klon,klev) + REAL cbmf(klon) + SAVE cbmf + INTEGER ifrst + SAVE ifrst + DATA ifrst /0/ +#include "YOMCST.h" +#include "YOETHF.h" +#include "FCTTRE.h" +c +c + IF (ifrst .EQ. 0) THEN + ifrst = 1 + DO i = 1, klon + cbmf(i) = 0. + ENDDO + ENDIF + + DO k = 1, klev+1 + DO i=1,klon + em_ph(i,k) = paprs(i,k) / 100.0 + ENDDO + ENDDO +c + DO k = 1, klev + DO i=1,klon + em_p(i,k) = pplay(i,k) / 100.0 + ENDDO + ENDDO + +c + if (iflag_con .eq. 4) then + DO k = 1, klev + DO i = 1, klon + zx_t = t(i,k) + zdelta=MAX(0.,SIGN(1.,rtt-zx_t)) + zx_qs= MIN(0.5 , r2es * FOEEW(zx_t,zdelta)/em_p(i,k)/100.0) + zcor=1./(1.-retv*zx_qs) + qs(i,k)=zx_qs*zcor + ENDDO + ENDDO + else ! iflag_con=3 (modif de puristes qui fait la diffce pour la convergence numerique) + DO k = 1, klev + DO i = 1, klon + zx_t = t(i,k) + zdelta=MAX(0.,SIGN(1.,rtt-zx_t)) + zx_qs= r2es * FOEEW(zx_t,zdelta)/em_p(i,k)/100.0 + zx_qs= MIN(0.5,zx_qs) + zcor=1./(1.-retv*zx_qs) + zx_qs=zx_qs*zcor + qs(i,k)=zx_qs + ENDDO + ENDDO + endif ! iflag_con +c +C------------------------------------------------------------------ + +C Main driver for convection: +C iflag_con = 3 -> equivalent to convect3 +C iflag_con = 4 -> equivalent to convect1/2 + + CALL cv_driver(klon,klev,klev+1,ntra,iflag_con, + : t,q,qs,u,v,tra, + $ em_p,em_ph,iflag, + $ d_t,d_q,d_u,d_v,d_tra,rain, + $ cbmf,work1,work2, + $ dtime,Ma,upwd,dnwd,dnwdbis,qcondc,wd,cape) + +C------------------------------------------------------------------ + + DO i = 1,klon + rain(i) = rain(i)/86400. + rflag(i)=iflag(i) + ENDDO + + DO k = 1, klev + DO i = 1, klon + d_t(i,k) = dtime*d_t(i,k) + d_q(i,k) = dtime*d_q(i,k) + d_u(i,k) = dtime*d_u(i,k) + d_v(i,k) = dtime*d_v(i,k) + ENDDO + ENDDO + +c les traceurs ne sont pas mis dans cette version de convect4: + if (iflag_con.eq.4) then + DO itra = 1,ntra + DO k = 1, klev + DO i = 1, klon + d_tra(i,k,itra) = 0. + ENDDO + ENDDO + ENDDO + endif + + RETURN + END + Index: /LMDZ.3.3/branches/rel-LF/libf/phylmd/cv3_routines.F =================================================================== --- /LMDZ.3.3/branches/rel-LF/libf/phylmd/cv3_routines.F (revision 418) +++ /LMDZ.3.3/branches/rel-LF/libf/phylmd/cv3_routines.F (revision 418) @@ -0,0 +1,3027 @@ + 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 "cvparam3.h" + + integer nd + real delt ! timestep (seconds) + +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 + +c -- "microphysical" parameters: + + sigd = 0.01 + spfac = 0.15 + pbcrit = 150.0 + ptcrit = 500.0 + 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) + dttrig = 5. ! (loose) condition for triggering + +c -- rate of approach to quasi-equilibrium: + + dtcrit = -2.0 + tau = 8000. + beta = 1.0 - delt/tau + alpha = 1.5E-3 * delt/tau +c increase alpha to compensate W decrease: + alpha = alpha*1.5 + +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) + + return + end + + SUBROUTINE cv3_prelim(len,nd,ndp1,t,q,p,ph + : ,lv,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), 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 "cvparam3.h" + + +c ori do 110 k=1,nlp + do 110 k=1,nl ! convect3 + 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) + 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 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,qs,p,ph,hm,gz + : ,nk,icb,icbmax,iflag,tnk,qnk,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 "cvparam3.h" + +c inputs: + integer len, nd + real t(len,nd), q(len,nd), qs(len,nd), p(len,nd) + real hm(len,nd), gz(len,nd) + real ph(len,nd+1) + +c outputs: + integer iflag(len), nk(len), icb(len), icbmax + real tnk(len), qnk(len), gznk(len), plcl(len) + +c local variables: + integer i, k + integer ihmin(len) + real work(len) + real pnk(len), qsnk(len), rh(len), chi(len) + real A, B ! convect3 + +c@ !------------------------------------------------------------------- +c@ ! --- Find level of minimum moist static energy +c@ ! --- If level of minimum moist static energy coincides with +c@ ! --- or is lower than minimum allowable parcel origin level, +c@ ! --- set iflag to 6. +c@ !------------------------------------------------------------------- +c@ +c@ do 180 i=1,len +c@ work(i)=1.0e12 +c@ ihmin(i)=nl +c@ 180 continue +c@ do 200 k=2,nlp +c@ do 190 i=1,len +c@ if((hm(i,k).lt.work(i)).and. +c@ & (hm(i,k).lt.hm(i,k-1)))then +c@ work(i)=hm(i,k) +c@ ihmin(i)=k +c@ endif +c@ 190 continue +c@ 200 continue +c@ do 210 i=1,len +c@ ihmin(i)=min(ihmin(i),nlm) +c@ if(ihmin(i).le.minorig)then +c@ iflag(i)=6 +c@ endif +c@ 210 continue +c@ c +c@ !------------------------------------------------------------------- +c@ ! --- Find that model level below the level of minimum moist static +c@ ! --- energy that has the maximum value of moist static energy +c@ !------------------------------------------------------------------- +c@ +c@ do 220 i=1,len +c@ work(i)=hm(i,minorig) +c@ nk(i)=minorig +c@ 220 continue +c@ do 240 k=minorig+1,nl +c@ do 230 i=1,len +c@ if((hm(i,k).gt.work(i)).and.(k.le.ihmin(i)))then +c@ work(i)=hm(i,k) +c@ nk(i)=k +c@ endif +c@ 230 continue +c@ 240 continue + +!------------------------------------------------------------------- +! --- Origin level of ascending parcels for convect3: +!------------------------------------------------------------------- + + do 220 i=1,len + nk(i)=minorig + 220 continue + +!------------------------------------------------------------------- +! --- Check whether parcel level temperature and specific humidity +! --- are reasonable +!------------------------------------------------------------------- + do 250 i=1,len + if( ( ( t(i,nk(i)).lt.250.0 ) + & .or.( q(i,nk(i)).le.0.0 ) ) +c@ & .or.( p(i,ihmin(i)).lt.400.0 ) ) + & .and. + & ( iflag(i).eq.0) ) iflag(i)=7 + 250 continue +!------------------------------------------------------------------- +! --- 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 + + do 260 i=1,len + + if (iflag(i).ne.7) then ! modif sb Jun7th 2002 + + tnk(i)=t(i,nk(i)) + qnk(i)=q(i,nk(i)) + gznk(i)=gz(i,nk(i)) + pnk(i)=p(i,nk(i)) + qsnk(i)=qs(i,nk(i)) +c + rh(i)=qnk(i)/qsnk(i) +c ori rh(i)=min(1.0,rh(i)) ! removed for convect3 +c ori chi(i)=tnk(i)/(1669.0-122.0*rh(i)-tnk(i)) + chi(i)=tnk(i)/(A-B*rh(i)-tnk(i)) ! convect3 + 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 + + endif ! iflag=7 + + 260 continue + +!------------------------------------------------------------------- +! --- 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 + 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 "cvparam3.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) + +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 = th(i,1) + 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 "cvparam3.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 + + + 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 + + do 121 j=1,ntra +ccccc do 111 k=1,nl+1 + do 111 k=1,nd + nn=0 + do 101 i=1,len + if(iflag1(i).eq.0)then + nn=nn+1 + tra(nn,k,j)=tra1(i,k,j) + endif + 101 continue + 111 continue + 121 continue + + if (nn.ne.ncum) then + print*,'strange! nn not equal to ncum: ',nn,ncum + stop + 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 cv3_undilute2(nloc,ncum,nd,icb,icbs,nk + : ,tnk,qnk,gznk,t,q,qs,gz + : ,p,h,tv,lv,pbase,buoybase,plcl + o ,inb,tp,tvp,clw,hp,ep,sigp,buoy) + 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 "cvparam3.h" + +c inputs: + integer ncum, nd, nloc + 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 lv(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,s,tc,es,denom,rg,tca,elacrit + real by, defrac, pden + real ah0(nloc), cape(nloc), capem(nloc), byp(nloc) + logical lcape(nloc) + +!===================================================================== +! --- SOME INITIALIZATIONS +!===================================================================== + + do 170 k=1,nl + do 160 i=1,ncum + ep(i,k)=0.0 + sigp(i,k)=spfac + 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: + tp(i,k)=(ah0(i)-gz(i,k)-alv*qg)/(cpd+(cl-cpd)*qnk(i)) + + 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 + endif + 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) +!===================================================================== +c +c ori do 320 k=minorig+1,nl + 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)=amax1(ep(i,k),0.0) + ep(i,k)=amin1(ep(i,k),epmax) + sigp(i,k)=spfac +c ori if(k.ge.(nk(i)+1))then +c ori tca=tp(i,k)-t0 +c ori if(tca.ge.0.0)then +c ori elacrit=elcrit +c ori else +c ori elacrit=elcrit*(1.0-tca/tlcrit) +c ori endif +c ori elacrit=max(elacrit,0.0) +c ori ep(i,k)=1.0-elacrit/max(clw(i,k),1.0e-8) +c ori ep(i,k)=max(ep(i,k),0.0 ) +c ori ep(i,k)=min(ep(i,k),1.0 ) +c ori sigp(i,k)=sigs +c ori endif + 310 continue + 320 continue +c +!===================================================================== +! --- 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 + buoy(icb(i),k)=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 + 510 continue + + do 530 i=1,ncum + do 535 k=1,nl-1 + if ((k.ge.icb(i)).and.(buoy(i,k).lt.dtovsh)) then + inb(i)=MIN(inb(i),k) + endif + 535 continue + 530 continue + +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 i=1,ncum*nlp + hp(i,1)=h(i,1) + enddo + + do 600 k=minorig+1,nl + do 590 i=1,ncum + if((k.ge.icb(i)).and.(k.le.inb(i)))then + hp(i,k)=h(i,nk(i))+(lv(i,k)+(cpd-cpv)*t(i,k))*ep(i,k)*clw(i,k) + 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) + implicit none + +!=================================================================== +! --- CLOSURE OF CONVECT3 +! +! vectorization: S. Bony +!=================================================================== + +#include "cvthermo.h" +#include "cvparam3.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) + +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) + + +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 qnk(il) +! - vectorisation de la partie normalisation des flux (do 789...) +!--------------------------------------------------------------------- + +#include "cvthermo.h" +#include "cvparam3.h" + +c inputs: + integer ncum, nd, na, ntra, nloc + integer icb(nloc), inb(nloc), nk(nloc) + real sig(nloc,nd) + real qnk(nloc) + real ph(nloc,nd+1) + real t(nloc,nd), rr(nloc,nd), rs(nloc,nd) + real u(nloc,nd), v(nloc,nd) + real tra(nloc,nd,ntra) ! input of convect3 + real lv(nloc,na), h(nloc,na), hp(nloc,na) + real tv(nloc,na), tvp(nloc,na), ep(nloc,na), clw(nloc,na) + real m(nloc,na) ! input of convect3 + +c outputs: + real ment(nloc,na,na), qent(nloc,na,na) + real uent(nloc,na,na), vent(nloc,na,na) + real sij(nloc,na,na), elij(nloc,na,na) + real traent(nloc,nd,nd,ntra) + real ments(nloc,nd,nd), qents(nloc,nd,nd) + real sigij(nloc,nd,nd) + +c local variables: + integer i, j, k, il, im, jm + integer num1, num2 + integer nent(nloc,na) + real rti, bf2, anum, denom, dei, altem, cwat, stemp, qp + real alt, smid, sjmin, sjmax, delp, delm + real asij(nloc), smax(nloc), scrit(nloc) + real asum(nloc,nd),bsum(nloc,nd),csum(nloc,nd) + real wgh + logical lwork(nloc) + +c===================================================================== +c --- INITIALIZE VARIOUS ARRAYS USED IN THE COMPUTATIONS +c===================================================================== + +c ori do 360 i=1,ncum*nlp + do 361 j=1,nl + do 360 i=1,ncum + nent(i,j)=0 +c in convect3, m is computed in cv3_closure +c ori m(i,1)=0.0 + 360 continue + 361 continue + +c ori do 400 k=1,nlp +c ori do 390 j=1,nlp + do 400 j=1,nl + do 390 k=1,nl + do 385 i=1,ncum + qent(i,k,j)=rr(i,j) + uent(i,k,j)=u(i,j) + vent(i,k,j)=v(i,j) + elij(i,k,j)=0.0 + ment(i,k,j)=0.0 + sij(i,k,j)=0.0 + 385 continue + 390 continue + 400 continue + + do k=1,ntra + do j=1,nd ! instead nlp + do i=1,nd ! instead nlp + do il=1,ncum + traent(il,i,j,k)=tra(il,j,k) + enddo + enddo + enddo + enddo + +c===================================================================== +c --- CALCULATE ENTRAINED AIR MASS FLUX (ment), TOTAL WATER MIXING +c --- RATIO (QENT), TOTAL CONDENSED WATER (elij), AND MIXING +c --- FRACTION (sij) +c===================================================================== + + do 750 i=minorig+1, nl + + do 710 j=minorig,nl + do 700 il=1,ncum + if( (i.ge.icb(il)).and.(i.le.inb(il)).and. + : (j.ge.(icb(il)-1)).and.(j.le.inb(il)))then + + rti=rr(il,1)-ep(il,i)*clw(il,i) + bf2=1.+lv(il,j)*lv(il,j)*rs(il,j)/(rrv*t(il,j)*t(il,j)*cpd) + anum=h(il,j)-hp(il,i)+(cpv-cpd)*t(il,j)*(rti-rr(il,j)) + denom=h(il,i)-hp(il,i)+(cpd-cpv)*(rr(il,i)-rti)*t(il,j) + dei=denom + if(abs(dei).lt.0.01)dei=0.01 + sij(il,i,j)=anum/dei + sij(il,i,i)=1.0 + altem=sij(il,i,j)*rr(il,i)+(1.-sij(il,i,j))*rti-rs(il,j) + altem=altem/bf2 + cwat=clw(il,j)*(1.-ep(il,j)) + stemp=sij(il,i,j) + if((stemp.lt.0.0.or.stemp.gt.1.0.or.altem.gt.cwat) + : .and.j.gt.i)then + anum=anum-lv(il,j)*(rti-rs(il,j)-cwat*bf2) + denom=denom+lv(il,j)*(rr(il,i)-rti) + if(abs(denom).lt.0.01)denom=0.01 + sij(il,i,j)=anum/denom + altem=sij(il,i,j)*rr(il,i)+(1.-sij(il,i,j))*rti-rs(il,j) + altem=altem-(bf2-1.)*cwat + end if + if(sij(il,i,j).gt.0.0.and.sij(il,i,j).lt.0.95)then + qent(il,i,j)=sij(il,i,j)*rr(il,i)+(1.-sij(il,i,j))*rti + uent(il,i,j)=sij(il,i,j)*u(il,i)+(1.-sij(il,i,j))*u(il,nk(il)) + vent(il,i,j)=sij(il,i,j)*v(il,i)+(1.-sij(il,i,j))*v(il,nk(il)) +c!!! do k=1,ntra +c!!! traent(il,i,j,k)=sij(il,i,j)*tra(il,i,k) +c!!! : +(1.-sij(il,i,j))*tra(il,nk(il),k) +c!!! end do + elij(il,i,j)=altem + elij(il,i,j)=amax1(0.0,elij(il,i,j)) + ment(il,i,j)=m(il,i)/(1.-sij(il,i,j)) + nent(il,i)=nent(il,i)+1 + end if + sij(il,i,j)=amax1(0.0,sij(il,i,j)) + sij(il,i,j)=amin1(1.0,sij(il,i,j)) + endif ! new + 700 continue + 710 continue + + do k=1,ntra + do j=minorig,nl + do il=1,ncum + if( (i.ge.icb(il)).and.(i.le.inb(il)).and. + : (j.ge.(icb(il)-1)).and.(j.le.inb(il)))then + traent(il,i,j,k)=sij(il,i,j)*tra(il,i,k) + : +(1.-sij(il,i,j))*tra(il,nk(il),k) + endif + enddo + enddo + enddo + +c +c *** if no air can entrain at level i assume that updraft detrains *** +c *** at that level and calculate detrained air flux and properties *** +c + +c@ do 170 i=icb(il),inb(il) + + do 740 il=1,ncum + if ((i.ge.icb(il)).and.(i.le.inb(il)).and.(nent(il,i).eq.0)) then +c@ if(nent(il,i).eq.0)then + ment(il,i,i)=m(il,i) + qent(il,i,i)=rr(il,nk(il))-ep(il,i)*clw(il,i) + uent(il,i,i)=u(il,nk(il)) + vent(il,i,i)=v(il,nk(il)) + elij(il,i,i)=clw(il,i) + sij(il,i,i)=1.0 + end if + 740 continue + 750 continue + + do j=1,ntra + do i=minorig+1,nl + do il=1,ncum + if (i.ge.icb(il) .and. i.le.inb(il) .and. nent(il,i).eq.0) then + traent(il,i,i,j)=tra(il,nk(il),j) + endif + enddo + enddo + enddo + + do 100 j=minorig,nl + do 101 i=minorig,nl + do 102 il=1,ncum + if ((j.ge.(icb(il)-1)).and.(j.le.inb(il)) + : .and.(i.ge.icb(il)).and.(i.le.inb(il)))then + sigij(il,i,j)=sij(il,i,j) + endif + 102 continue + 101 continue + 100 continue +c@ enddo + +c@170 continue + +c===================================================================== +c --- NORMALIZE ENTRAINED AIR MASS FLUXES +c --- TO REPRESENT EQUAL PROBABILITIES OF MIXING +c===================================================================== + + call zilch(asum,ncum*nd) + call zilch(bsum,ncum*nd) + call zilch(csum,ncum*nd) + + do il=1,ncum + lwork(il) = .FALSE. + enddo + + DO 789 i=minorig+1,nl + + num1=0 + do il=1,ncum + if ( i.ge.icb(il) .and. i.le.inb(il) ) num1=num1+1 + enddo + if (num1.le.0) goto 789 + + + do 781 il=1,ncum + if ( i.ge.icb(il) .and. i.le.inb(il) ) then + lwork(il)=(nent(il,i).ne.0) + qp=rr(il,1)-ep(il,i)*clw(il,i) + anum=h(il,i)-hp(il,i)-lv(il,i)*(qp-rs(il,i)) + : +(cpv-cpd)*t(il,i)*(qp-rr(il,i)) + denom=h(il,i)-hp(il,i)+lv(il,i)*(rr(il,i)-qp) + : +(cpd-cpv)*t(il,i)*(rr(il,i)-qp) + if(abs(denom).lt.0.01)denom=0.01 + scrit(il)=anum/denom + alt=qp-rs(il,i)+scrit(il)*(rr(il,i)-qp) + if(scrit(il).le.0.0.or.alt.le.0.0)scrit(il)=1.0 + smax(il)=0.0 + asij(il)=0.0 + endif +781 continue + + do 175 j=nl,minorig,-1 + + num2=0 + do il=1,ncum + if ( i.ge.icb(il) .and. i.le.inb(il) .and. + : j.ge.(icb(il)-1) .and. j.le.inb(il) + : .and. lwork(il) ) num2=num2+1 + enddo + if (num2.le.0) goto 175 + + do 782 il=1,ncum + if ( i.ge.icb(il) .and. i.le.inb(il) .and. + : j.ge.(icb(il)-1) .and. j.le.inb(il) + : .and. lwork(il) ) then + + if(sij(il,i,j).gt.1.0e-16.and.sij(il,i,j).lt.0.95)then + wgh=1.0 + if(j.gt.i)then + sjmax=amax1(sij(il,i,j+1),smax(il)) + sjmax=amin1(sjmax,scrit(il)) + smax(il)=amax1(sij(il,i,j),smax(il)) + sjmin=amax1(sij(il,i,j-1),smax(il)) + sjmin=amin1(sjmin,scrit(il)) + if(sij(il,i,j).lt.(smax(il)-1.0e-16))wgh=0.0 + smid=amin1(sij(il,i,j),scrit(il)) + else + sjmax=amax1(sij(il,i,j+1),scrit(il)) + smid=amax1(sij(il,i,j),scrit(il)) + sjmin=0.0 + if(j.gt.1)sjmin=sij(il,i,j-1) + sjmin=amax1(sjmin,scrit(il)) + endif + delp=abs(sjmax-smid) + delm=abs(sjmin-smid) + asij(il)=asij(il)+wgh*(delp+delm) + ment(il,i,j)=ment(il,i,j)*(delp+delm)*wgh + endif + endif +782 continue + +175 continue + + do il=1,ncum + if (i.ge.icb(il).and.i.le.inb(il).and.lwork(il)) then + asij(il)=amax1(1.0e-16,asij(il)) + asij(il)=1.0/asij(il) + asum(il,i)=0.0 + bsum(il,i)=0.0 + csum(il,i)=0.0 + endif + enddo + + do 180 j=minorig,nl + do il=1,ncum + if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il) + : .and. j.ge.(icb(il)-1) .and. j.le.inb(il) ) then + ment(il,i,j)=ment(il,i,j)*asij(il) + endif + enddo +180 continue + + do 190 j=minorig,nl + do il=1,ncum + if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il) + : .and. j.ge.(icb(il)-1) .and. j.le.inb(il) ) then + asum(il,i)=asum(il,i)+ment(il,i,j) + ment(il,i,j)=ment(il,i,j)*sig(il,j) + bsum(il,i)=bsum(il,i)+ment(il,i,j) + endif + enddo +190 continue + + do il=1,ncum + if (i.ge.icb(il).and.i.le.inb(il).and.lwork(il)) then + bsum(il,i)=amax1(bsum(il,i),1.0e-16) + bsum(il,i)=1.0/bsum(il,i) + endif + enddo + + do 195 j=minorig,nl + do il=1,ncum + if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il) + : .and. j.ge.(icb(il)-1) .and. j.le.inb(il) ) then + ment(il,i,j)=ment(il,i,j)*asum(il,i)*bsum(il,i) + endif + enddo +195 continue + + do 197 j=minorig,nl + do il=1,ncum + if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il) + : .and. j.ge.(icb(il)-1) .and. j.le.inb(il) ) then + csum(il,i)=csum(il,i)+ment(il,i,j) + endif + enddo +197 continue + + do il=1,ncum + if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il) + : .and. csum(il,i).lt.m(il,i) ) then + nent(il,i)=0 + ment(il,i,i)=m(il,i) + qent(il,i,i)=rr(il,1)-ep(il,i)*clw(il,i) + uent(il,i,i)=u(il,nk(il)) + vent(il,i,i)=v(il,nk(il)) + elij(il,i,i)=clw(il,i) + sij(il,i,i)=1.0 + endif + enddo ! il + + do j=1,ntra + do il=1,ncum + if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il) + : .and. csum(il,i).lt.m(il,i) ) then + traent(il,i,i,j)=tra(il,nk(il),j) + endif + enddo + enddo + +789 continue + + do jm=1,nd + do im=1,nd + do 999 il=1,ncum + qents(il,im,jm)=qent(il,im,jm) + ments(il,im,jm)=ment(il,im,jm) +999 continue + enddo + enddo + + return + end + + + SUBROUTINE cv3_unsat(nloc,ncum,nd,na,ntra,icb,inb + : ,t,rr,rs,gz,u,v,tra,p,ph + : ,th,tv,lv,cpn,ep,sigp,clw + : ,m,ment,elij,delt,plcl + : ,mp,rp,up,vp,trap,wt,water,evap,b) + implicit none + + +#include "cvthermo.h" +#include "cvparam3.h" +#include "cvflag.h" + +c inputs: + integer ncum, nd, na, ntra, nloc + integer icb(nloc), inb(nloc) + real delt, plcl(nloc) + real t(nloc,nd), rr(nloc,nd), rs(nloc,nd) + real u(nloc,nd), v(nloc,nd) + real tra(nloc,nd,ntra) + real p(nloc,nd), ph(nloc,nd+1) + real th(nloc,na), gz(nloc,na) + real lv(nloc,na), ep(nloc,na), sigp(nloc,na), clw(nloc,na) + real cpn(nloc,na), tv(nloc,na) + real m(nloc,na), ment(nloc,na,na), elij(nloc,na,na) + +c outputs: + real mp(nloc,na), rp(nloc,na), up(nloc,na), vp(nloc,na) + real water(nloc,na), evap(nloc,na), wt(nloc,na) + real trap(nloc,na,ntra) + real b(nloc,na) + +c local variables + integer i,j,k,il,num1 + real tinv, delti + real awat, afac, afac1, afac2, bfac + real pr1, pr2, sigt, b6, c6, revap, tevap, delth + real amfac, amp2, xf, tf, fac2, ur, sru, fac, d, af, bf + real ampmax + real lvcp(nloc,na) + real wdtrain(nloc) + logical lwork(nloc) + + +c------------------------------------------------------ + + delti = 1./delt + tinv=1./3. + + do i=1,nl + do il=1,ncum + mp(il,i)=0.0 + rp(il,i)=rr(il,i) + up(il,i)=u(il,i) + vp(il,i)=v(il,i) + wt(il,i)=0.001 + water(il,i)=0.0 + evap(il,i)=0.0 + b(il,i)=0.0 + lvcp(il,i)=lv(il,i)/cpn(il,i) + enddo + enddo + + do k=1,ntra + do i=1,nd + do il=1,ncum + trap(il,i,k)=tra(il,i,k) + enddo + enddo + enddo + +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. + enddo + + call zilch(wdtrain,ncum) + + 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 + +c +c *** integrate liquid water equation to find condensed water *** +c *** and condensed water flux *** +c + +c +c *** begin downdraft loop *** +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) + else + wdtrain(il)=10.0*ep(il,i)*m(il,i)*clw(il,i) + 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=amax1(awat,0.0) + if (cvflag_grav) then + wdtrain(il)=wdtrain(il)+grav*awat*ment(il,j,i) + else + wdtrain(il)=wdtrain(il)+10.0*awat*ment(il,j,i) + 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 999 il=1,ncum + + if (i.le.inb(il) .and. lwork(il)) then + + wt(il,i)=45.0 + + if(i.lt.inb(il))then + 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 + rp(il,i)=amax1(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)) + 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)=amax1(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=amax1(afac,0.0) + bfac=1./(sigd*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)na + o ,lv1,cpn1,tv1,gz1,h1,hm1,th1) + endif + + if (iflag_con.eq.4) then + CALL cv_prelim(len,nd,ndp1,t1,q1,p1,ph1 + o ,lv1,cpn1,tv1,gz1,h1,hm1) + endif + +!-------------------------------------------------------------------- +! --- CONVECTIVE FEED +!-------------------------------------------------------------------- + + if (iflag_con.eq.3) then + CALL cv3_feed(len,nd,t1,q1,qs1,p1,ph1,hm1,gz1 ! nd->na + o ,nk1,icb1,icbmax,iflag1,tnk1,qnk1,gznk1,plcl1) + endif + + if (iflag_con.eq.4) then + CALL cv_feed(len,nd,t1,q1,qs1,p1,hm1,gz1 + o ,nk1,icb1,icbmax,iflag1,tnk1,qnk1,gznk1,plcl1) + endif + +!-------------------------------------------------------------------- +! --- UNDILUTE (ADIABATIC) UPDRAFT / 1st part +! (up through ICB for convect4, up through ICB+1 for convect3) +! Calculates the lifted parcel virtual temperature at nk, the +! actual temperature, and the adiabatic liquid water content. +!-------------------------------------------------------------------- + + if (iflag_con.eq.3) then + CALL cv3_undilute1(len,nd,t1,q1,qs1,gz1,plcl1,p1,nk1,icb1 ! nd->na + o ,tp1,tvp1,clw1,icbs1) + endif + + if (iflag_con.eq.4) then + CALL cv_undilute1(len,nd,t1,q1,qs1,gz1,p1,nk1,icb1,icbmax + : ,tp1,tvp1,clw1) + endif + +!------------------------------------------------------------------- +! --- TRIGGERING +!------------------------------------------------------------------- + + if (iflag_con.eq.3) then + CALL cv3_trigger(len,nd,icb1,plcl1,p1,th1,tv1,tvp1 ! nd->na + o ,pbase1,buoybase1,iflag1,sig1,w01) + endif + + if (iflag_con.eq.4) then + CALL cv_trigger(len,nd,icb1,cbmf1,tv1,tvp1,iflag1) + endif + +!===================================================================== +! --- IF THIS POINT IS REACHED, MOIST CONVECTIVE ADJUSTMENT IS NECESSARY +!===================================================================== + + ncum=0 + do 400 i=1,len + if(iflag1(i).eq.0)then + ncum=ncum+1 + idcum(ncum)=i + endif + 400 continue + +c print*,'klon, ncum = ',len,ncum + + IF (ncum.gt.0) THEN + +!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +! --- COMPRESS THE FIELDS +! (-> vectorization over convective gridpoints) +!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + + if (iflag_con.eq.3) then + CALL 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 ) + endif + + if (iflag_con.eq.4) then + CALL cv_compress( len,nloc,ncum,nd + : ,iflag1,nk1,icb1 + : ,cbmf1,plcl1,tnk1,qnk1,gznk1 + : ,t1,q1,qs1,u1,v1,gz1 + : ,h1,lv1,cpn1,p1,ph1,tv1,tp1,tvp1,clw1 + o ,iflag,nk,icb + o ,cbmf,plcl,tnk,qnk,gznk + o ,t,q,qs,u,v,gz,h,lv,cpn,p,ph,tv,tp,tvp,clw + o ,dph ) + endif + +!------------------------------------------------------------------- +! --- UNDILUTE (ADIABATIC) UPDRAFT / second part : +! --- FIND THE REST OF THE LIFTED PARCEL TEMPERATURES +! --- & +! --- COMPUTE THE PRECIPITATION EFFICIENCIES AND THE +! --- FRACTION OF PRECIPITATION FALLING OUTSIDE OF CLOUD +! --- & +! --- FIND THE LEVEL OF NEUTRAL BUOYANCY +!------------------------------------------------------------------- + + if (iflag_con.eq.3) then + CALL cv3_undilute2(nloc,ncum,nd,icb,icbs,nk !na->nd + : ,tnk,qnk,gznk,t,q,qs,gz + : ,p,h,tv,lv,pbase,buoybase,plcl + o ,inb,tp,tvp,clw,hp,ep,sigp,buoy) + endif + + if (iflag_con.eq.4) then + CALL cv_undilute2(nloc,ncum,nd,icb,nk + : ,tnk,qnk,gznk,t,q,qs,gz + : ,p,dph,h,tv,lv + o ,inb,inbis,tp,tvp,clw,hp,ep,sigp,frac) + endif + +!------------------------------------------------------------------- +! --- CLOSURE +!------------------------------------------------------------------- + + if (iflag_con.eq.3) then + CALL cv3_closure(nloc,ncum,nd,icb,inb ! na->nd + : ,pbase,p,ph,tv,buoy + o ,sig,w0,cape,m) + endif + + if (iflag_con.eq.4) then + CALL cv_closure(nloc,ncum,nd,nk,icb + : ,tv,tvp,p,ph,dph,plcl,cpn + o ,iflag,cbmf) + endif + +!------------------------------------------------------------------- +! --- MIXING +!------------------------------------------------------------------- + + if (iflag_con.eq.3) then + CALL cv3_mixing(nloc,ncum,nd,nd,ntra,icb,nk,inb ! na->nd + : ,ph,t,q,qs,u,v,tra,h,lv,qnk + : ,hp,tv,tvp,ep,clw,m,sig + o ,ment,qent,uent,vent,sij,elij,ments,qents,traent) + endif + + if (iflag_con.eq.4) then + CALL cv_mixing(nloc,ncum,nd,icb,nk,inb,inbis + : ,ph,t,q,qs,u,v,h,lv,qnk + : ,hp,tv,tvp,ep,clw,cbmf + o ,m,ment,qent,uent,vent,nent,sij,elij) + endif + +!------------------------------------------------------------------- +! --- UNSATURATED (PRECIPITATING) DOWNDRAFTS +!------------------------------------------------------------------- + + if (iflag_con.eq.3) then + CALL cv3_unsat(nloc,ncum,nd,nd,ntra,icb,inb ! na->nd + : ,t,q,qs,gz,u,v,tra,p,ph + : ,th,tv,lv,cpn,ep,sigp,clw + : ,m,ment,elij,delt,plcl + o ,mp,qp,up,vp,trap,wt,water,evap,b) + endif + + if (iflag_con.eq.4) then + CALL cv_unsat(nloc,ncum,nd,inb,t,q,qs,gz,u,v,p,ph + : ,h,lv,ep,sigp,clw,m,ment,elij + o ,iflag,mp,qp,up,vp,wt,water,evap) + endif + +!------------------------------------------------------------------- +! --- YIELD +! (tendencies, precipitation, variables of interface with other +! processes, etc) +!------------------------------------------------------------------- + + if (iflag_con.eq.3) then + CALL cv3_yield(nloc,ncum,nd,nd,ntra ! na->nd + : ,icb,inb,delt + : ,t,q,u,v,tra,gz,p,ph,h,hp,lv,cpn,th + : ,ep,clw,m,tp,mp,qp,up,vp,trap + : ,wt,water,evap,b + : ,ment,qent,uent,vent,nent,elij,traent,sig + : ,tv,tvp + o ,iflag,precip,ft,fq,fu,fv,ftra + o ,upwd,dnwd,dnwd0,ma,mike,tls,tps,qcondc,wd) + endif + + if (iflag_con.eq.4) then + CALL cv_yield(nloc,ncum,nd,nk,icb,inb,delt + : ,t,q,u,v,gz,p,ph,h,hp,lv,cpn + : ,ep,clw,frac,m,mp,qp,up,vp + : ,wt,water,evap + : ,ment,qent,uent,vent,nent,elij + : ,tv,tvp + o ,iflag,wd,qprime,tprime + o ,precip,cbmf,ft,fq,fu,fv,Ma,qcondc) + endif + +!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +! --- UNCOMPRESS THE FIELDS +!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + + + if (iflag_con.eq.3) then + CALL cv3_uncompress(nloc,len,ncum,nd,ntra,idcum + : ,iflag + : ,precip,sig,w0 + : ,ft,fq,fu,fv,ftra + : ,Ma,upwd,dnwd,dnwd0,qcondc,wd,cape + o ,iflag1 + o ,precip1,sig1,w01 + o ,ft1,fq1,fu1,fv1,ftra1 + o ,Ma1,upwd1,dnwd1,dnwd01,qcondc1,wd1,cape1 ) + endif + + if (iflag_con.eq.4) then + CALL cv_uncompress(nloc,len,ncum,nd,idcum + : ,iflag + : ,precip,cbmf + : ,ft,fq,fu,fv + : ,Ma,qcondc + o ,iflag1 + o ,precip1,cbmf1 + o ,ft1,fq1,fu1,fv1 + o ,Ma1,qcondc1 ) + endif + + ENDIF ! ncum>0 + +9999 continue + + return + end + +!================================================================== + SUBROUTINE cv_flag + implicit none + +#include "cvflag.h" + +c -- si .TRUE., on rend la gravite plus explicite et eventuellement +c differente de 10.0 dans convect3: + cvflag_grav = .FALSE. + + return + end + +!================================================================== + SUBROUTINE cv_thermo(iflag_con) + implicit none + +c------------------------------------------------------------- +c Set thermodynamical constants for convectL +c------------------------------------------------------------- + +#include "YOMCST.h" +#include "cvthermo.h" + + integer iflag_con + + +c original set from convect: + if (iflag_con.eq.4) then + cpd=1005.7 + cpv=1870.0 + cl=4190.0 + rrv=461.5 + rrd=287.04 + lv0=2.501E6 + g=9.8 + t0=273.15 + grav=g + endif + +c constants consistent with LMDZ: + if (iflag_con.eq.3) then + cpd = RCPD + cpv = RCPV + cl = RCW + rrv = RV + rrd = RD + lv0 = RLVTT + g = RG ! not used in convect3 +c ori t0 = RTT + t0 = 273.15 ! convect3 (RTT=273.16) + grav= 10. ! implicitely or explicitely used in convect3 + endif + + rowl=1000.0 !(a quelle variable de YOMCST cela correspond-il?) + + clmcpv=cl-cpv + clmcpd=cl-cpd + cpdmcp=cpd-cpv + cpvmcpd=cpv-cpd + cpvmcl=cl-cpv ! for convect3 + eps=rrd/rrv + epsi=1.0/eps + epsim1=epsi-1.0 +c ginv=1.0/g + ginv=1.0/grav + hrd=0.5*rrd + + return + end + Index: /LMDZ.3.3/branches/rel-LF/libf/phylmd/cv_routines.F =================================================================== --- /LMDZ.3.3/branches/rel-LF/libf/phylmd/cv_routines.F (revision 418) +++ /LMDZ.3.3/branches/rel-LF/libf/phylmd/cv_routines.F (revision 418) @@ -0,0 +1,1752 @@ + SUBROUTINE cv_param(nd) + implicit none + +c------------------------------------------------------------ +c Set parameters for convectL +c (includes microphysical parameters and parameters that +c control the rate of approach to quasi-equilibrium) +c------------------------------------------------------------ + +C *** ELCRIT IS THE AUTOCONVERSION THERSHOLD WATER CONTENT (gm/gm) *** +C *** TLCRIT IS CRITICAL TEMPERATURE BELOW WHICH THE AUTO- *** +C *** CONVERSION THRESHOLD IS ASSUMED TO BE ZERO *** +C *** (THE AUTOCONVERSION THRESHOLD VARIES LINEARLY *** +C *** BETWEEN 0 C AND TLCRIT) *** +C *** ENTP IS THE COEFFICIENT OF MIXING IN THE ENTRAINMENT *** +C *** FORMULATION *** +C *** SIGD IS THE FRACTIONAL AREA COVERED BY UNSATURATED DNDRAFT *** +C *** SIGS IS THE FRACTION OF PRECIPITATION FALLING OUTSIDE *** +C *** OF CLOUD *** +C *** OMTRAIN IS THE ASSUMED FALL SPEED (P/s) OF RAIN *** +C *** OMTSNOW IS THE ASSUMED FALL SPEED (P/s) OF SNOW *** +C *** COEFFR IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION *** +C *** OF RAIN *** +C *** COEFFS IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION *** +C *** OF SNOW *** +C *** CU IS THE COEFFICIENT GOVERNING CONVECTIVE MOMENTUM *** +C *** TRANSPORT *** +C *** DTMAX IS THE MAXIMUM NEGATIVE TEMPERATURE PERTURBATION *** +C *** A LIFTED PARCEL IS ALLOWED TO HAVE BELOW ITS LFC *** +C *** ALPHA AND DAMP ARE PARAMETERS THAT CONTROL THE RATE OF *** +C *** APPROACH TO QUASI-EQUILIBRIUM *** +C *** (THEIR STANDARD VALUES ARE 0.20 AND 0.1, RESPECTIVELY) *** +C *** (DAMP MUST BE LESS THAN 1) *** + +#include "cvparam.h" + integer nd + +c noff: integer limit for convection (nd-noff) +c minorig: First level of convection + + noff = 2 + minorig = 2 + + nl=nd-noff + nlp=nl+1 + nlm=nl-1 + + elcrit=0.0011 + tlcrit=-55.0 + entp=1.5 + sigs=0.12 + sigd=0.05 + omtrain=50.0 + omtsnow=5.5 + coeffr=1.0 + coeffs=0.8 + dtmax=0.9 +c + cu=0.70 +c + betad=10.0 +c + damp=0.1 + alpha=0.2 +c + delta=0.01 ! cld +c + return + end + + SUBROUTINE cv_prelim(len,nd,ndp1,t,q,p,ph + : ,lv,cpn,tv,gz,h,hm) + implicit none + +!===================================================================== +! --- CALCULATE ARRAYS OF GEOPOTENTIAL, HEAT CAPACITY & STATIC ENERGY +!===================================================================== + +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), cpn(len,nd), tv(len,nd) + real gz(len,nd), h(len,nd), hm(len,nd) + +c local variables: + integer k, i + real cpx(len,nd) + +#include "cvthermo.h" +#include "cvparam.h" + + + do 110 k=1,nlp + do 100 i=1,len + lv(i,k)= lv0-clmcpv*(t(i,k)-t0) + 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) + tv(i,k)=t(i,k)*(1.0+q(i,k)*epsim1) + 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 + do 140 k=2,nlp + do 130 i=1,len + gz(i,k)=gz(i,k-1)+hrd*(tv(i,k-1)+tv(i,k)) + & *(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 + do 170 k=1,nlp + 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 cv_feed(len,nd,t,q,qs,p,hm,gz + : ,nk,icb,icbmax,iflag,tnk,qnk,gznk,plcl) + implicit none + +C================================================================ +C Purpose: CONVECTIVE FEED +C================================================================ + +#include "cvparam.h" + +c inputs: + integer len, nd + real t(len,nd), q(len,nd), qs(len,nd), p(len,nd) + real hm(len,nd), gz(len,nd) + +c outputs: + integer iflag(len), nk(len), icb(len), icbmax + real tnk(len), qnk(len), gznk(len), plcl(len) + +c local variables: + integer i, k + integer ihmin(len) + real work(len) + real pnk(len), qsnk(len), rh(len), chi(len) + +!------------------------------------------------------------------- +! --- Find level of minimum moist static energy +! --- If level of minimum moist static energy coincides with +! --- or is lower than minimum allowable parcel origin level, +! --- set iflag to 6. +!------------------------------------------------------------------- + + do 180 i=1,len + work(i)=1.0e12 + ihmin(i)=nl + 180 continue + do 200 k=2,nlp + do 190 i=1,len + if((hm(i,k).lt.work(i)).and. + & (hm(i,k).lt.hm(i,k-1)))then + work(i)=hm(i,k) + ihmin(i)=k + endif + 190 continue + 200 continue + do 210 i=1,len + ihmin(i)=min(ihmin(i),nlm) + if(ihmin(i).le.minorig)then + iflag(i)=6 + endif + 210 continue +c +!------------------------------------------------------------------- +! --- Find that model level below the level of minimum moist static +! --- energy that has the maximum value of moist static energy +!------------------------------------------------------------------- + + do 220 i=1,len + work(i)=hm(i,minorig) + nk(i)=minorig + 220 continue + do 240 k=minorig+1,nl + do 230 i=1,len + if((hm(i,k).gt.work(i)).and.(k.le.ihmin(i)))then + work(i)=hm(i,k) + nk(i)=k + endif + 230 continue + 240 continue +!------------------------------------------------------------------- +! --- Check whether parcel level temperature and specific humidity +! --- are reasonable +!------------------------------------------------------------------- + do 250 i=1,len + if(((t(i,nk(i)).lt.250.0).or. + & (q(i,nk(i)).le.0.0).or. + & (p(i,ihmin(i)).lt.400.0)).and. + & (iflag(i).eq.0))iflag(i)=7 + 250 continue +!------------------------------------------------------------------- +! --- Calculate lifted condensation level of air at parcel origin level +! --- (Within 0.2% of formula of Bolton, MON. WEA. REV.,1980) +!------------------------------------------------------------------- + do 260 i=1,len + tnk(i)=t(i,nk(i)) + qnk(i)=q(i,nk(i)) + gznk(i)=gz(i,nk(i)) + pnk(i)=p(i,nk(i)) + qsnk(i)=qs(i,nk(i)) +c + rh(i)=qnk(i)/qsnk(i) + rh(i)=min(1.0,rh(i)) + chi(i)=tnk(i)/(1669.0-122.0*rh(i)-tnk(i)) + 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 + 260 continue +!------------------------------------------------------------------- +! --- Calculate first level above lcl (=icb) +!------------------------------------------------------------------- + do 270 i=1,len + icb(i)=nlm + 270 continue +c + do 290 k=minorig,nl + do 280 i=1,len + if((k.ge.(nk(i)+1)).and.(p(i,k).lt.plcl(i))) + & icb(i)=min(icb(i),k) + 280 continue + 290 continue +c + do 300 i=1,len + if((icb(i).ge.nlm).and.(iflag(i).eq.0))iflag(i)=9 + 300 continue +c +c Compute icbmax. +c + icbmax=2 + do 310 i=1,len + icbmax=max(icbmax,icb(i)) + 310 continue + + return + end + + SUBROUTINE cv_undilute1(len,nd,t,q,qs,gz,p,nk,icb,icbmax + : ,tp,tvp,clw) + implicit none + +#include "cvthermo.h" +#include "cvparam.h" + +c inputs: + integer len, nd + integer nk(len), icb(len), icbmax + real t(len,nd), q(len,nd), qs(len,nd), gz(len,nd) + real p(len,nd) + +c outputs: + real tp(len,nd), tvp(len,nd), clw(len,nd) + +c local variables: + integer i, k + real tg, qg, alv, s, ahg, tc, denom, es, rg + real ah0(len), cpp(len) + real tnk(len), qnk(len), gznk(len), ticb(len), gzicb(len) + +!------------------------------------------------------------------- +! --- Calculates the lifted parcel virtual temperature at nk, +! --- the actual temperature, and the adiabatic +! --- liquid water content. The procedure is to solve the equation. +! cp*tp+L*qp+phi=cp*tnk+L*qnk+gznk. +!------------------------------------------------------------------- + + do 320 i=1,len + tnk(i)=t(i,nk(i)) + qnk(i)=q(i,nk(i)) + gznk(i)=gz(i,nk(i)) + ticb(i)=t(i,icb(i)) + gzicb(i)=gz(i,icb(i)) + 320 continue +c +c *** Calculate certain parcel quantities, including static energy *** +c + do 330 i=1,len + ah0(i)=(cpd*(1.-qnk(i))+cl*qnk(i))*tnk(i) + & +qnk(i)*(lv0-clmcpv*(tnk(i)-273.15))+gznk(i) + cpp(i)=cpd*(1.-qnk(i))+qnk(i)*cpv + 330 continue +c +c *** Calculate lifted parcel quantities below cloud base *** +c + do 350 k=minorig,icbmax-1 + do 340 i=1,len + tp(i,k)=tnk(i)-(gz(i,k)-gznk(i))/cpp(i) + tvp(i,k)=tp(i,k)*(1.+qnk(i)*epsi) + 340 continue + 350 continue +c +c *** Find lifted parcel quantities above cloud base *** +c + do 360 i=1,len + tg=ticb(i) + qg=qs(i,icb(i)) + alv=lv0-clmcpv*(ticb(i)-t0) +c +c First iteration. +c + s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i)) + s=1./s + ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i) + tg=tg+s*(ah0(i)-ahg) + tg=max(tg,35.0) + tc=tg-t0 + denom=243.5+tc + if(tc.ge.0.0)then + es=6.112*exp(17.67*tc/denom) + else + es=exp(23.33086-6111.72784/tg+0.15215*log(tg)) + endif + qg=eps*es/(p(i,icb(i))-es*(1.-eps)) +c +c Second iteration. +c + s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i)) + s=1./s + ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i) + tg=tg+s*(ah0(i)-ahg) + tg=max(tg,35.0) + tc=tg-t0 + denom=243.5+tc + if(tc.ge.0.0)then + es=6.112*exp(17.67*tc/denom) + else + es=exp(23.33086-6111.72784/tg+0.15215*log(tg)) + end if + qg=eps*es/(p(i,icb(i))-es*(1.-eps)) +c + alv=lv0-clmcpv*(ticb(i)-273.15) + tp(i,icb(i))=(ah0(i)-(cl-cpd)*qnk(i)*ticb(i) + & -gz(i,icb(i))-alv*qg)/cpd + clw(i,icb(i))=qnk(i)-qg + clw(i,icb(i))=max(0.0,clw(i,icb(i))) + rg=qg/(1.-qnk(i)) + tvp(i,icb(i))=tp(i,icb(i))*(1.+rg*epsi) + 360 continue +c + do 380 k=minorig,icbmax + do 370 i=1,len + tvp(i,k)=tvp(i,k)-tp(i,k)*qnk(i) + 370 continue + 380 continue +c + return + end + + SUBROUTINE cv_trigger(len,nd,icb,cbmf,tv,tvp,iflag) + implicit none + +!------------------------------------------------------------------- +! --- Test for instability. +! --- If there was no convection at last time step and parcel +! --- is stable at icb, then set iflag to 4. +!------------------------------------------------------------------- + +#include "cvparam.h" + +c inputs: + integer len, nd, icb(len) + real cbmf(len), tv(len,nd), tvp(len,nd) + +c outputs: + integer iflag(len) ! also an input + +c local variables: + integer i + + + do 390 i=1,len + if((cbmf(i).eq.0.0) .and.(iflag(i).eq.0).and. + & (tvp(i,icb(i)).le.(tv(i,icb(i))-dtmax)))iflag(i)=4 + 390 continue + + return + end + + SUBROUTINE cv_compress( len,nloc,ncum,nd + : ,iflag1,nk1,icb1 + : ,cbmf1,plcl1,tnk1,qnk1,gznk1 + : ,t1,q1,qs1,u1,v1,gz1 + : ,h1,lv1,cpn1,p1,ph1,tv1,tp1,tvp1,clw1 + o ,iflag,nk,icb + o ,cbmf,plcl,tnk,qnk,gznk + o ,t,q,qs,u,v,gz,h,lv,cpn,p,ph,tv,tp,tvp,clw + o ,dph ) + implicit none + +#include "cvparam.h" + +c inputs: + integer len,ncum,nd,nloc + integer iflag1(len),nk1(len),icb1(len) + real cbmf1(len),plcl1(len),tnk1(len),qnk1(len),gznk1(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) + +c outputs: + integer iflag(nloc),nk(nloc),icb(nloc) + real cbmf(nloc),plcl(nloc),tnk(nloc),qnk(nloc),gznk(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 dph(nloc,nd) + +c local variables: + integer i,k,nn + + + do 110 k=1,nl+1 + nn=0 + do 100 i=1,len + if(iflag1(i).eq.0)then + nn=nn+1 + 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) + endif + 100 continue + 110 continue + + if (nn.ne.ncum) then + print*,'strange! nn not equal to ncum: ',nn,ncum + stop + endif + + nn=0 + do 150 i=1,len + if(iflag1(i).eq.0)then + nn=nn+1 + cbmf(nn)=cbmf1(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) + iflag(nn)=iflag1(i) + endif + 150 continue + + do 170 k=1,nl + do 160 i=1,ncum + dph(i,k)=ph(i,k)-ph(i,k+1) + 160 continue + 170 continue + + return + end + + SUBROUTINE cv_undilute2(nloc,ncum,nd,icb,nk + : ,tnk,qnk,gznk,t,q,qs,gz + : ,p,dph,h,tv,lv + o ,inb,inb1,tp,tvp,clw,hp,ep,sigp,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--------------------------------------------------------------------- + +#include "cvthermo.h" +#include "cvparam.h" + +c inputs: + integer ncum, nd, nloc + integer icb(nloc), nk(nloc) + real t(nloc,nd), q(nloc,nd), qs(nloc,nd), gz(nloc,nd) + real p(nloc,nd), dph(nloc,nd) + real tnk(nloc), qnk(nloc), gznk(nloc) + real lv(nloc,nd), tv(nloc,nd), h(nloc,nd) + +c outputs: + integer inb(nloc), inb1(nloc) + real tp(nloc,nd), tvp(nloc,nd), clw(nloc,nd) + real ep(nloc,nd), sigp(nloc,nd), hp(nloc,nd) + real frac(nloc) + +c local variables: + integer i, k + real tg,qg,ahg,alv,s,tc,es,denom,rg,tca,elacrit + real by, defrac + real ah0(nloc), cape(nloc), capem(nloc), byp(nloc) + logical lcape(nloc) + +!===================================================================== +! --- SOME INITIALIZATIONS +!===================================================================== + + do 170 k=1,nl + do 160 i=1,ncum + ep(i,k)=0.0 + sigp(i,k)=sigs + 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) + & +qnk(i)*(lv0-clmcpv*(tnk(i)-t0))+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 + if(k.ge.(icb(i)+1))then + tg=t(i,k) + qg=qs(i,k) + alv=lv0-clmcpv*(t(i,k)-t0) +c +c First iteration. +c + s=cpd+alv*alv*qg/(rrv*t(i,k)*t(i,k)) + s=1./s + ahg=cpd*tg+(cl-cpd)*qnk(i)*t(i,k)+alv*qg+gz(i,k) + tg=tg+s*(ah0(i)-ahg) + tg=max(tg,35.0) + tc=tg-t0 + denom=243.5+tc + if(tc.ge.0.0)then + es=6.112*exp(17.67*tc/denom) + else + es=exp(23.33086-6111.72784/tg+0.15215*log(tg)) + endif + qg=eps*es/(p(i,k)-es*(1.-eps)) +c +c Second iteration. +c + s=cpd+alv*alv*qg/(rrv*t(i,k)*t(i,k)) + s=1./s + ahg=cpd*tg+(cl-cpd)*qnk(i)*t(i,k)+alv*qg+gz(i,k) + tg=tg+s*(ah0(i)-ahg) + tg=max(tg,35.0) + tc=tg-t0 + denom=243.5+tc + if(tc.ge.0.0)then + es=6.112*exp(17.67*tc/denom) + else + es=exp(23.33086-6111.72784/tg+0.15215*log(tg)) + endif + qg=eps*es/(p(i,k)-es*(1.-eps)) +c + alv=lv0-clmcpv*(t(i,k)-t0) +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 + tp(i,k)=(ah0(i)-(cl-cpd)*qnk(i)*t(i,k)-gz(i,k)-alv*qg)/cpd +c if (.not.cpd.gt.1000.) then +c print*,'CPD=',cpd +c stop +c endif + clw(i,k)=qnk(i)-qg + clw(i,k)=max(0.0,clw(i,k)) + rg=qg/(1.-qnk(i)) + tvp(i,k)=tp(i,k)*(1.+rg*epsi) + endif + 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) +!===================================================================== +c + do 320 k=minorig+1,nl + do 310 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),1.0 ) + sigp(i,k)=sigs + endif + 310 continue + 320 continue +c +!===================================================================== +! --- CALCULATE VIRTUAL TEMPERATURE AND LIFTED PARCEL +! --- VIRTUAL TEMPERATURE +!===================================================================== +c + do 340 k=minorig+1,nl + do 330 i=1,ncum + if(k.ge.(icb(i)+1))then + tvp(i,k)=tvp(i,k)*(1.0-qnk(i)+ep(i,k)*clw(i,k)) +c print*,'i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)' +c print*, i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k) + endif + 330 continue + 340 continue + do 350 i=1,ncum + tvp(i,nlp)=tvp(i,nl)-(gz(i,nlp)-gz(i,nl))/cpd + 350 continue +c +c===================================================================== +c --- FIND THE FIRST MODEL LEVEL (INB1) ABOVE THE PARCEL'S +c --- HIGHEST LEVEL OF NEUTRAL BUOYANCY +c --- AND THE HIGHEST LEVEL OF POSITIVE CAPE (INB) +c===================================================================== +c + do 510 i=1,ncum + cape(i)=0.0 + capem(i)=0.0 + inb(i)=icb(i)+1 + inb1(i)=inb(i) + 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 + call zilch(byp,ncum) + do 515 i=1,ncum + lcape(i)=.true. + 515 continue + do 530 k=minorig+1,nl-1 + do 520 i=1,ncum + if(cape(i).lt.0.0)lcape(i)=.false. + if((k.ge.(icb(i)+1)).and.lcape(i))then + by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k) + byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1) + cape(i)=cape(i)+by + if(by.ge.0.0)inb1(i)=k+1 + if(cape(i).gt.0.0)then + inb(i)=k+1 + capem(i)=cape(i) + endif + endif + 520 continue + 530 continue + do 540 i=1,ncum + cape(i)=capem(i)+byp(i) + defrac=capem(i)-cape(i) + defrac=max(defrac,0.001) + frac(i)=-cape(i)/defrac + frac(i)=min(frac(i),1.0) + frac(i)=max(frac(i),0.0) + 540 continue +c +c===================================================================== +c --- CALCULATE LIQUID WATER STATIC ENERGY OF LIFTED PARCEL +c===================================================================== +c +c initialization: + do i=1,ncum*nlp + hp(i,1)=h(i,1) + enddo + + do 600 k=minorig+1,nl + do 590 i=1,ncum + if((k.ge.icb(i)).and.(k.le.inb(i)))then + hp(i,k)=h(i,nk(i))+(lv(i,k)+(cpd-cpv)*t(i,k))*ep(i,k)*clw(i,k) + endif + 590 continue + 600 continue +c + return + end +c + SUBROUTINE cv_closure(nloc,ncum,nd,nk,icb + : ,tv,tvp,p,ph,dph,plcl,cpn + : ,iflag,cbmf) + implicit none + +c inputs: + integer ncum, nd, nloc + integer nk(nloc), icb(nloc) + real tv(nloc,nd), tvp(nloc,nd), p(nloc,nd), dph(nloc,nd) + real ph(nloc,nd+1) ! caution nd instead ndp1 to be consistent... + real plcl(nloc), cpn(nloc,nd) + +c outputs: + integer iflag(nloc) + real cbmf(nloc) ! also an input + +c local variables: + integer i, k, icbmax + real dtpbl(nloc), dtmin(nloc), tvpplcl(nloc), tvaplcl(nloc) + real work(nloc) + +#include "cvthermo.h" +#include "cvparam.h" + +c------------------------------------------------------------------- +c Compute icbmax. +c------------------------------------------------------------------- + + icbmax=2 + do 230 i=1,ncum + icbmax=max(icbmax,icb(i)) + 230 continue + +c===================================================================== +c --- CALCULATE CLOUD BASE MASS FLUX +c===================================================================== +c +c tvpplcl = parcel temperature lifted adiabatically from level +c icb-1 to the LCL. +c tvaplcl = virtual temperature at the LCL. +c + do 610 i=1,ncum + dtpbl(i)=0.0 + tvpplcl(i)=tvp(i,icb(i)-1) + & -rrd*tvp(i,icb(i)-1)*(p(i,icb(i)-1)-plcl(i)) + & /(cpn(i,icb(i)-1)*p(i,icb(i)-1)) + tvaplcl(i)=tv(i,icb(i)) + & +(tvp(i,icb(i))-tvp(i,icb(i)+1))*(plcl(i)-p(i,icb(i))) + & /(p(i,icb(i))-p(i,icb(i)+1)) + 610 continue + +c------------------------------------------------------------------- +c --- Interpolate difference between lifted parcel and +c --- environmental temperatures to lifted condensation level +c------------------------------------------------------------------- +c +c dtpbl = average of tvp-tv in the PBL (k=nk to icb-1). +c + do 630 k=minorig,icbmax + do 620 i=1,ncum + if((k.ge.nk(i)).and.(k.le.(icb(i)-1)))then + dtpbl(i)=dtpbl(i)+(tvp(i,k)-tv(i,k))*dph(i,k) + endif + 620 continue + 630 continue + do 640 i=1,ncum + dtpbl(i)=dtpbl(i)/(ph(i,nk(i))-ph(i,icb(i))) + dtmin(i)=tvpplcl(i)-tvaplcl(i)+dtmax+dtpbl(i) + 640 continue +c +c------------------------------------------------------------------- +c --- Adjust cloud base mass flux +c------------------------------------------------------------------- +c + do 650 i=1,ncum + work(i)=cbmf(i) + cbmf(i)=max(0.0,(1.0-damp)*cbmf(i)+0.1*alpha*dtmin(i)) + if((work(i).eq.0.0).and.(cbmf(i).eq.0.0))then + iflag(i)=3 + endif + 650 continue + + return + end + + SUBROUTINE cv_mixing(nloc,ncum,nd,icb,nk,inb,inb1 + : ,ph,t,q,qs,u,v,h,lv,qnk + : ,hp,tv,tvp,ep,clw,cbmf + : ,m,ment,qent,uent,vent,nent,sij,elij) + implicit none + +#include "cvthermo.h" +#include "cvparam.h" + +c inputs: + integer ncum, nd, nloc + integer icb(nloc), inb(nloc), inb1(nloc), nk(nloc) + real cbmf(nloc), qnk(nloc) + real ph(nloc,nd+1) + real t(nloc,nd), q(nloc,nd), qs(nloc,nd), lv(nloc,nd) + real u(nloc,nd), v(nloc,nd), h(nloc,nd), hp(nloc,nd) + real tv(nloc,nd), tvp(nloc,nd), ep(nloc,nd), clw(nloc,nd) + +c outputs: + integer nent(nloc,nd) + real m(nloc,nd), ment(nloc,nd,nd), qent(nloc,nd,nd) + real uent(nloc,nd,nd), vent(nloc,nd,nd) + real sij(nloc,nd,nd), elij(nloc,nd,nd) + +c local variables: + integer i, j, k, ij + integer num1, num2 + real dbo, qti, bf2, anum, denom, dei, altem, cwat, stemp + real alt, qp1, smid, sjmin, sjmax, delp, delm + real work(nloc), asij(nloc), smin(nloc), scrit(nloc) + real bsum(nloc,nd) + logical lwork(nloc) + +c===================================================================== +c --- INITIALIZE VARIOUS ARRAYS USED IN THE COMPUTATIONS +c===================================================================== +c + do 360 i=1,ncum*nlp + nent(i,1)=0 + m(i,1)=0.0 + 360 continue +c + do 400 k=1,nlp + do 390 j=1,nlp + do 385 i=1,ncum + qent(i,k,j)=q(i,j) + uent(i,k,j)=u(i,j) + vent(i,k,j)=v(i,j) + elij(i,k,j)=0.0 + ment(i,k,j)=0.0 + sij(i,k,j)=0.0 + 385 continue + 390 continue + 400 continue +c +c------------------------------------------------------------------- +c --- Calculate rates of mixing, m(i) +c------------------------------------------------------------------- +c + call zilch(work,ncum) +c + do 670 j=minorig+1,nl + do 660 i=1,ncum + if((j.ge.(icb(i)+1)).and.(j.le.inb(i)))then + k=min(j,inb1(i)) + dbo=abs(tv(i,k+1)-tvp(i,k+1)-tv(i,k-1)+tvp(i,k-1)) + & +entp*0.04*(ph(i,k)-ph(i,k+1)) + work(i)=work(i)+dbo + m(i,j)=cbmf(i)*dbo + endif + 660 continue + 670 continue + do 690 k=minorig+1,nl + do 680 i=1,ncum + if((k.ge.(icb(i)+1)).and.(k.le.inb(i)))then + m(i,k)=m(i,k)/work(i) + endif + 680 continue + 690 continue +c +c +c===================================================================== +c --- CALCULATE ENTRAINED AIR MASS FLUX (ment), TOTAL WATER MIXING +c --- RATIO (QENT), TOTAL CONDENSED WATER (elij), AND MIXING +c --- FRACTION (sij) +c===================================================================== +c +c + do 750 i=minorig+1,nl + do 710 j=minorig+1,nl + do 700 ij=1,ncum + if((i.ge.(icb(ij)+1)).and.(j.ge.icb(ij)) + & .and.(i.le.inb(ij)).and.(j.le.inb(ij)))then + qti=qnk(ij)-ep(ij,i)*clw(ij,i) + bf2=1.+lv(ij,j)*lv(ij,j)*qs(ij,j) + & /(rrv*t(ij,j)*t(ij,j)*cpd) + anum=h(ij,j)-hp(ij,i)+(cpv-cpd)*t(ij,j)*(qti-q(ij,j)) + denom=h(ij,i)-hp(ij,i)+(cpd-cpv)*(q(ij,i)-qti)*t(ij,j) + dei=denom + if(abs(dei).lt.0.01)dei=0.01 + sij(ij,i,j)=anum/dei + sij(ij,i,i)=1.0 + altem=sij(ij,i,j)*q(ij,i)+(1.-sij(ij,i,j))*qti-qs(ij,j) + altem=altem/bf2 + cwat=clw(ij,j)*(1.-ep(ij,j)) + stemp=sij(ij,i,j) + if((stemp.lt.0.0.or.stemp.gt.1.0.or. + 1 altem.gt.cwat).and.j.gt.i)then + anum=anum-lv(ij,j)*(qti-qs(ij,j)-cwat*bf2) + denom=denom+lv(ij,j)*(q(ij,i)-qti) + if(abs(denom).lt.0.01)denom=0.01 + sij(ij,i,j)=anum/denom + altem=sij(ij,i,j)*q(ij,i)+(1.-sij(ij,i,j))*qti-qs(ij,j) + altem=altem-(bf2-1.)*cwat + endif + if(sij(ij,i,j).gt.0.0.and.sij(ij,i,j).lt.0.9)then + qent(ij,i,j)=sij(ij,i,j)*q(ij,i) + & +(1.-sij(ij,i,j))*qti + uent(ij,i,j)=sij(ij,i,j)*u(ij,i) + & +(1.-sij(ij,i,j))*u(ij,nk(ij)) + vent(ij,i,j)=sij(ij,i,j)*v(ij,i) + & +(1.-sij(ij,i,j))*v(ij,nk(ij)) + elij(ij,i,j)=altem + elij(ij,i,j)=max(0.0,elij(ij,i,j)) + ment(ij,i,j)=m(ij,i)/(1.-sij(ij,i,j)) + nent(ij,i)=nent(ij,i)+1 + endif + sij(ij,i,j)=max(0.0,sij(ij,i,j)) + sij(ij,i,j)=min(1.0,sij(ij,i,j)) + endif + 700 continue + 710 continue +c +c *** If no air can entrain at level i assume that updraft detrains *** +c *** at that level and calculate detrained air flux and properties *** +c + do 740 ij=1,ncum + if((i.ge.(icb(ij)+1)).and.(i.le.inb(ij)) + & .and.(nent(ij,i).eq.0))then + ment(ij,i,i)=m(ij,i) + qent(ij,i,i)=q(ij,nk(ij))-ep(ij,i)*clw(ij,i) + uent(ij,i,i)=u(ij,nk(ij)) + vent(ij,i,i)=v(ij,nk(ij)) + elij(ij,i,i)=clw(ij,i) + sij(ij,i,i)=1.0 + endif + 740 continue + 750 continue +c + do 770 i=1,ncum + sij(i,inb(i),inb(i))=1.0 + 770 continue +c +c===================================================================== +c --- NORMALIZE ENTRAINED AIR MASS FLUXES +c --- TO REPRESENT EQUAL PROBABILITIES OF MIXING +c===================================================================== +c + call zilch(bsum,ncum*nlp) + do 780 ij=1,ncum + lwork(ij)=.false. + 780 continue + do 789 i=minorig+1,nl +c + num1=0 + do 779 ij=1,ncum + if((i.ge.icb(ij)+1).and.(i.le.inb(ij)))num1=num1+1 + 779 continue + if(num1.le.0)go to 789 +c + do 781 ij=1,ncum + if((i.ge.icb(ij)+1).and.(i.le.inb(ij)))then + lwork(ij)=(nent(ij,i).ne.0) + qp1=q(ij,nk(ij))-ep(ij,i)*clw(ij,i) + anum=h(ij,i)-hp(ij,i)-lv(ij,i)*(qp1-qs(ij,i)) + denom=h(ij,i)-hp(ij,i)+lv(ij,i)*(q(ij,i)-qp1) + if(abs(denom).lt.0.01)denom=0.01 + scrit(ij)=anum/denom + alt=qp1-qs(ij,i)+scrit(ij)*(q(ij,i)-qp1) + if(scrit(ij).lt.0.0.or.alt.lt.0.0)scrit(ij)=1.0 + asij(ij)=0.0 + smin(ij)=1.0 + endif + 781 continue + do 783 j=minorig,nl +c + num2=0 + do 778 ij=1,ncum + if((i.ge.icb(ij)+1).and.(i.le.inb(ij)) + & .and.(j.ge.icb(ij)).and.(j.le.inb(ij)) + & .and.lwork(ij))num2=num2+1 + 778 continue + if(num2.le.0)go to 783 +c + do 782 ij=1,ncum + if((i.ge.icb(ij)+1).and.(i.le.inb(ij)) + & .and.(j.ge.icb(ij)).and.(j.le.inb(ij)).and.lwork(ij))then + if(sij(ij,i,j).gt.0.0.and.sij(ij,i,j).lt.0.9)then + if(j.gt.i)then + smid=min(sij(ij,i,j),scrit(ij)) + sjmax=smid + sjmin=smid + if(smid.lt.smin(ij) + & .and.sij(ij,i,j+1).lt.smid)then + smin(ij)=smid + sjmax=min(sij(ij,i,j+1),sij(ij,i,j),scrit(ij)) + sjmin=max(sij(ij,i,j-1),sij(ij,i,j)) + sjmin=min(sjmin,scrit(ij)) + endif + else + sjmax=max(sij(ij,i,j+1),scrit(ij)) + smid=max(sij(ij,i,j),scrit(ij)) + sjmin=0.0 + if(j.gt.1)sjmin=sij(ij,i,j-1) + sjmin=max(sjmin,scrit(ij)) + endif + delp=abs(sjmax-smid) + delm=abs(sjmin-smid) + asij(ij)=asij(ij)+(delp+delm) + & *(ph(ij,j)-ph(ij,j+1)) + ment(ij,i,j)=ment(ij,i,j)*(delp+delm) + & *(ph(ij,j)-ph(ij,j+1)) + endif + endif + 782 continue + 783 continue + do 784 ij=1,ncum + if((i.ge.icb(ij)+1).and.(i.le.inb(ij)).and.lwork(ij))then + asij(ij)=max(1.0e-21,asij(ij)) + asij(ij)=1.0/asij(ij) + bsum(ij,i)=0.0 + endif + 784 continue + do 786 j=minorig,nl+1 + do 785 ij=1,ncum + if((i.ge.icb(ij)+1).and.(i.le.inb(ij)) + & .and.(j.ge.icb(ij)).and.(j.le.inb(ij)) + & .and.lwork(ij))then + ment(ij,i,j)=ment(ij,i,j)*asij(ij) + bsum(ij,i)=bsum(ij,i)+ment(ij,i,j) + endif + 785 continue + 786 continue + do 787 ij=1,ncum + if((i.ge.icb(ij)+1).and.(i.le.inb(ij)) + & .and.(bsum(ij,i).lt.1.0e-18).and.lwork(ij))then + nent(ij,i)=0 + ment(ij,i,i)=m(ij,i) + qent(ij,i,i)=q(ij,nk(ij))-ep(ij,i)*clw(ij,i) + uent(ij,i,i)=u(ij,nk(ij)) + vent(ij,i,i)=v(ij,nk(ij)) + elij(ij,i,i)=clw(ij,i) + sij(ij,i,i)=1.0 + endif + 787 continue + 789 continue +c + return + end + + SUBROUTINE cv_unsat(nloc,ncum,nd,inb,t,q,qs,gz,u,v,p,ph + : ,h,lv,ep,sigp,clw,m,ment,elij + : ,iflag,mp,qp,up,vp,wt,water,evap) + implicit none + + +#include "cvthermo.h" +#include "cvparam.h" + +c inputs: + integer ncum, nd, nloc + integer inb(nloc) + real t(nloc,nd), q(nloc,nd), qs(nloc,nd) + real gz(nloc,nd), u(nloc,nd), v(nloc,nd) + real p(nloc,nd), ph(nloc,nd+1), h(nloc,nd) + real lv(nloc,nd), ep(nloc,nd), sigp(nloc,nd), clw(nloc,nd) + real m(nloc,nd), ment(nloc,nd,nd), elij(nloc,nd,nd) + +c outputs: + integer iflag(nloc) ! also an input + real mp(nloc,nd), qp(nloc,nd), up(nloc,nd), vp(nloc,nd) + real water(nloc,nd), evap(nloc,nd), wt(nloc,nd) + +c local variables: + integer i,j,k,ij,num1 + integer jtt(nloc) + real awat, coeff, qsm, afac, sigt, b6, c6, revap + real dhdp, fac, qstm, rat + real wdtrain(nloc) + logical lwork(nloc) + +c===================================================================== +c --- PRECIPITATING DOWNDRAFT CALCULATION +c===================================================================== +c +c Initializations: +c + do i = 1, ncum + do k = 1, nl+1 + wt(i,k) = omtsnow + mp(i,k) = 0.0 + evap(i,k) = 0.0 + water(i,k) = 0.0 + enddo + enddo + + do 420 i=1,ncum + qp(i,1)=q(i,1) + up(i,1)=u(i,1) + vp(i,1)=v(i,1) + 420 continue + + do 440 k=2,nl+1 + do 430 i=1,ncum + qp(i,k)=q(i,k-1) + up(i,k)=u(i,k-1) + vp(i,k)=v(i,k-1) + 430 continue + 440 continue + + +c *** Check whether ep(inb)=0, if so, skip precipitating *** +c *** downdraft calculation *** +c +c +c *** Integrate liquid water equation to find condensed water *** +c *** and condensed water flux *** +c +c + do 890 i=1,ncum + jtt(i)=2 + if(ep(i,inb(i)).le.0.0001)iflag(i)=2 + if(iflag(i).eq.0)then + lwork(i)=.true. + else + lwork(i)=.false. + endif + 890 continue +c +c *** Begin downdraft loop *** +c +c + call zilch(wdtrain,ncum) + do 899 i=nl+1,1,-1 +c + num1=0 + do 879 ij=1,ncum + if((i.le.inb(ij)).and.lwork(ij))num1=num1+1 + 879 continue + if(num1.le.0)go to 899 +c +c +c *** Calculate detrained precipitation *** +c + do 891 ij=1,ncum + if((i.le.inb(ij)).and.(lwork(ij)))then + wdtrain(ij)=g*ep(ij,i)*m(ij,i)*clw(ij,i) + endif + 891 continue +c + if(i.gt.1)then + do 893 j=1,i-1 + do 892 ij=1,ncum + if((i.le.inb(ij)).and.(lwork(ij)))then + awat=elij(ij,j,i)-(1.-ep(ij,i))*clw(ij,i) + awat=max(0.0,awat) + wdtrain(ij)=wdtrain(ij)+g*awat*ment(ij,j,i) + endif + 892 continue + 893 continue + endif +c +c *** Find rain water and evaporation using provisional *** +c *** estimates of qp(i)and qp(i-1) *** +c +c +c *** Value of terminal velocity and coeffecient of evaporation for snow *** +c + do 894 ij=1,ncum + if((i.le.inb(ij)).and.(lwork(ij)))then + coeff=coeffs + wt(ij,i)=omtsnow +c +c *** Value of terminal velocity and coeffecient of evaporation for rain *** +c + if(t(ij,i).gt.273.0)then + coeff=coeffr + wt(ij,i)=omtrain + endif + qsm=0.5*(q(ij,i)+qp(ij,i+1)) + afac=coeff*ph(ij,i)*(qs(ij,i)-qsm) + & /(1.0e4+2.0e3*ph(ij,i)*qs(ij,i)) + afac=max(afac,0.0) + sigt=sigp(ij,i) + sigt=max(0.0,sigt) + sigt=min(1.0,sigt) + b6=100.*(ph(ij,i)-ph(ij,i+1))*sigt*afac/wt(ij,i) + c6=(water(ij,i+1)*wt(ij,i+1)+wdtrain(ij)/sigd)/wt(ij,i) + revap=0.5*(-b6+sqrt(b6*b6+4.*c6)) + evap(ij,i)=sigt*afac*revap + water(ij,i)=revap*revap +c +c *** Calculate precipitating downdraft mass flux under *** +c *** hydrostatic approximation *** +c + if(i.gt.1)then + dhdp=(h(ij,i)-h(ij,i-1))/(p(ij,i-1)-p(ij,i)) + dhdp=max(dhdp,10.0) + mp(ij,i)=100.*ginv*lv(ij,i)*sigd*evap(ij,i)/dhdp + mp(ij,i)=max(mp(ij,i),0.0) +c +c *** Add small amount of inertia to downdraft *** +c + fac=20.0/(ph(ij,i-1)-ph(ij,i)) + mp(ij,i)=(fac*mp(ij,i+1)+mp(ij,i))/(1.+fac) +c +c *** Force mp to decrease linearly to zero *** +c *** between about 950 mb and the surface *** +c + if(p(ij,i).gt.(0.949*p(ij,1)))then + jtt(ij)=max(jtt(ij),i) + mp(ij,i)=mp(ij,jtt(ij))*(p(ij,1)-p(ij,i)) + & /(p(ij,1)-p(ij,jtt(ij))) + endif + endif +c +c *** Find mixing ratio of precipitating downdraft *** +c + if(i.ne.inb(ij))then + if(i.eq.1)then + qstm=qs(ij,1) + else + qstm=qs(ij,i-1) + endif + if(mp(ij,i).gt.mp(ij,i+1))then + rat=mp(ij,i+1)/mp(ij,i) + qp(ij,i)=qp(ij,i+1)*rat+q(ij,i)*(1.0-rat)+100.*ginv* + & sigd*(ph(ij,i)-ph(ij,i+1))*(evap(ij,i)/mp(ij,i)) + up(ij,i)=up(ij,i+1)*rat+u(ij,i)*(1.-rat) + vp(ij,i)=vp(ij,i+1)*rat+v(ij,i)*(1.-rat) + else + if(mp(ij,i+1).gt.0.0)then + qp(ij,i)=(gz(ij,i+1)-gz(ij,i) + & +qp(ij,i+1)*(lv(ij,i+1)+t(ij,i+1) + & *(cl-cpd))+cpd*(t(ij,i+1)-t(ij,i))) + & /(lv(ij,i)+t(ij,i)*(cl-cpd)) + up(ij,i)=up(ij,i+1) + vp(ij,i)=vp(ij,i+1) + endif + endif + qp(ij,i)=min(qp(ij,i),qstm) + qp(ij,i)=max(qp(ij,i),0.0) + endif + endif + 894 continue + 899 continue +c + return + end + + SUBROUTINE cv_yield(nloc,ncum,nd,nk,icb,inb,delt + : ,t,q,u,v,gz,p,ph,h,hp,lv,cpn + : ,ep,clw,frac,m,mp,qp,up,vp + : ,wt,water,evap + : ,ment,qent,uent,vent,nent,elij + : ,tv,tvp + o ,iflag,wd,qprime,tprime + o ,precip,cbmf,ft,fq,fu,fv,Ma,qcondc) + implicit none + +#include "cvthermo.h" +#include "cvparam.h" + +c inputs + integer ncum, nd, nloc + integer nk(nloc), icb(nloc), inb(nloc) + integer nent(nloc,nd) + real delt + real t(nloc,nd), q(nloc,nd), u(nloc,nd), v(nloc,nd) + real gz(nloc,nd) + real p(nloc,nd), ph(nloc,nd+1), h(nloc,nd) + real hp(nloc,nd), lv(nloc,nd) + real cpn(nloc,nd), ep(nloc,nd), clw(nloc,nd), frac(nloc) + real m(nloc,nd), mp(nloc,nd), qp(nloc,nd) + real up(nloc,nd), vp(nloc,nd) + real wt(nloc,nd), water(nloc,nd), evap(nloc,nd) + real ment(nloc,nd,nd), qent(nloc,nd,nd), elij(nloc,nd,nd) + real uent(nloc,nd,nd), vent(nloc,nd,nd) + real tv(nloc,nd), tvp(nloc,nd) + +c outputs + integer iflag(nloc) ! also an input + real cbmf(nloc) ! also an input + real wd(nloc), tprime(nloc), qprime(nloc) + real precip(nloc) + real ft(nloc,nd), fq(nloc,nd), fu(nloc,nd), fv(nloc,nd) + real Ma(nloc,nd) + real qcondc(nloc,nd) + +c local variables + integer i,j,ij,k,num1 + real dpinv,cpinv,awat,fqold,ftold,fuold,fvold,delti + real work(nloc), am(nloc),amp1(nloc),ad(nloc) + real ents(nloc), uav(nloc),vav(nloc),lvcp(nloc,nd) + real qcond(nloc,nd), nqcond(nloc,nd), wa(nloc,nd) ! cld + real siga(nloc,nd), ax(nloc,nd), mac(nloc,nd) ! cld + + +c -- initializations: + + delti = 1.0/delt + + do 160 i=1,ncum + precip(i)=0.0 + wd(i)=0.0 + tprime(i)=0.0 + qprime(i)=0.0 + do 170 k=1,nl+1 + ft(i,k)=0.0 + fu(i,k)=0.0 + fv(i,k)=0.0 + fq(i,k)=0.0 + lvcp(i,k)=lv(i,k)/cpn(i,k) + qcondc(i,k)=0.0 ! cld + qcond(i,k)=0.0 ! cld + nqcond(i,k)=0.0 ! cld + 170 continue + 160 continue + +c +c *** Calculate surface precipitation in mm/day *** +c + do 1190 i=1,ncum + if(iflag(i).le.1)then +cc precip(i)=precip(i)+wt(i,1)*sigd*water(i,1)*3600.*24000. +cc & /(rowl*g) +cc precip(i)=precip(i)*delt/86400. + precip(i) = wt(i,1)*sigd*water(i,1)*86400/g + endif + 1190 continue +c +c +c *** Calculate downdraft velocity scale and surface temperature and *** +c *** water vapor fluctuations *** +c + do i=1,ncum + wd(i)=betad*abs(mp(i,icb(i)))*0.01*rrd*t(i,icb(i)) + : /(sigd*p(i,icb(i))) + qprime(i)=0.5*(qp(i,1)-q(i,1)) + tprime(i)=lv0*qprime(i)/cpd + enddo +c +c *** Calculate tendencies of lowest level potential temperature *** +c *** and mixing ratio *** +c + do 1200 i=1,ncum + work(i)=0.01/(ph(i,1)-ph(i,2)) + am(i)=0.0 + 1200 continue + do 1220 k=2,nl + do 1210 i=1,ncum + if((nk(i).eq.1).and.(k.le.inb(i)).and.(nk(i).eq.1))then + am(i)=am(i)+m(i,k) + endif + 1210 continue + 1220 continue + do 1240 i=1,ncum + if((g*work(i)*am(i)).ge.delti)iflag(i)=1 + ft(i,1)=ft(i,1)+g*work(i)*am(i)*(t(i,2)-t(i,1) + & +(gz(i,2)-gz(i,1))/cpn(i,1)) + ft(i,1)=ft(i,1)-lvcp(i,1)*sigd*evap(i,1) + ft(i,1)=ft(i,1)+sigd*wt(i,2)*(cl-cpd)*water(i,2)*(t(i,2) + & -t(i,1))*work(i)/cpn(i,1) + fq(i,1)=fq(i,1)+g*mp(i,2)*(qp(i,2)-q(i,1))* + & work(i)+sigd*evap(i,1) + fq(i,1)=fq(i,1)+g*am(i)*(q(i,2)-q(i,1))*work(i) + fu(i,1)=fu(i,1)+g*work(i)*(mp(i,2)*(up(i,2)-u(i,1)) + & +am(i)*(u(i,2)-u(i,1))) + fv(i,1)=fv(i,1)+g*work(i)*(mp(i,2)*(vp(i,2)-v(i,1)) + & +am(i)*(v(i,2)-v(i,1))) + 1240 continue + do 1260 j=2,nl + do 1250 i=1,ncum + if(j.le.inb(i))then + fq(i,1)=fq(i,1) + & +g*work(i)*ment(i,j,1)*(qent(i,j,1)-q(i,1)) + fu(i,1)=fu(i,1) + & +g*work(i)*ment(i,j,1)*(uent(i,j,1)-u(i,1)) + fv(i,1)=fv(i,1) + & +g*work(i)*ment(i,j,1)*(vent(i,j,1)-v(i,1)) + endif + 1250 continue + 1260 continue +c +c *** Calculate tendencies of potential temperature and mixing ratio *** +c *** at levels above the lowest level *** +c +c *** First find the net saturated updraft and downdraft mass fluxes *** +c *** through each level *** +c + do 1500 i=2,nl+1 +c + num1=0 + do 1265 ij=1,ncum + if(i.le.inb(ij))num1=num1+1 + 1265 continue + if(num1.le.0)go to 1500 +c + call zilch(amp1,ncum) + call zilch(ad,ncum) +c + do 1280 k=i+1,nl+1 + do 1270 ij=1,ncum + if((i.ge.nk(ij)).and.(i.le.inb(ij)) + & .and.(k.le.(inb(ij)+1)))then + amp1(ij)=amp1(ij)+m(ij,k) + endif + 1270 continue + 1280 continue +c + do 1310 k=1,i + do 1300 j=i+1,nl+1 + do 1290 ij=1,ncum + if((j.le.(inb(ij)+1)).and.(i.le.inb(ij)))then + amp1(ij)=amp1(ij)+ment(ij,k,j) + endif + 1290 continue + 1300 continue + 1310 continue + do 1340 k=1,i-1 + do 1330 j=i,nl+1 + do 1320 ij=1,ncum + if((i.le.inb(ij)).and.(j.le.inb(ij)))then + ad(ij)=ad(ij)+ment(ij,j,k) + endif + 1320 continue + 1330 continue + 1340 continue +c + do 1350 ij=1,ncum + if(i.le.inb(ij))then + dpinv=0.01/(ph(ij,i)-ph(ij,i+1)) + cpinv=1.0/cpn(ij,i) +c + ft(ij,i)=ft(ij,i) + & +g*dpinv*(amp1(ij)*(t(ij,i+1)-t(ij,i) + & +(gz(ij,i+1)-gz(ij,i))*cpinv) + & -ad(ij)*(t(ij,i)-t(ij,i-1)+(gz(ij,i)-gz(ij,i-1))*cpinv)) + & -sigd*lvcp(ij,i)*evap(ij,i) + ft(ij,i)=ft(ij,i)+g*dpinv*ment(ij,i,i)*(hp(ij,i)-h(ij,i)+ + & t(ij,i)*(cpv-cpd)*(q(ij,i)-qent(ij,i,i)))*cpinv + ft(ij,i)=ft(ij,i)+sigd*wt(ij,i+1)*(cl-cpd)*water(ij,i+1)* + & (t(ij,i+1)-t(ij,i))*dpinv*cpinv + fq(ij,i)=fq(ij,i)+g*dpinv*(amp1(ij)*(q(ij,i+1)-q(ij,i))- + & ad(ij)*(q(ij,i)-q(ij,i-1))) + fu(ij,i)=fu(ij,i)+g*dpinv*(amp1(ij)*(u(ij,i+1)-u(ij,i))- + & ad(ij)*(u(ij,i)-u(ij,i-1))) + fv(ij,i)=fv(ij,i)+g*dpinv*(amp1(ij)*(v(ij,i+1)-v(ij,i))- + & ad(ij)*(v(ij,i)-v(ij,i-1))) + endif + 1350 continue + do 1370 k=1,i-1 + do 1360 ij=1,ncum + if(i.le.inb(ij))then + awat=elij(ij,k,i)-(1.-ep(ij,i))*clw(ij,i) + awat=max(awat,0.0) + fq(ij,i)=fq(ij,i) + & +g*dpinv*ment(ij,k,i)*(qent(ij,k,i)-awat-q(ij,i)) + fu(ij,i)=fu(ij,i) + & +g*dpinv*ment(ij,k,i)*(uent(ij,k,i)-u(ij,i)) + fv(ij,i)=fv(ij,i) + & +g*dpinv*ment(ij,k,i)*(vent(ij,k,i)-v(ij,i)) +c (saturated updrafts resulting from mixing) ! cld + qcond(ij,i)=qcond(ij,i)+(elij(ij,k,i)-awat) ! cld + nqcond(ij,i)=nqcond(ij,i)+1. ! cld + endif + 1360 continue + 1370 continue + do 1390 k=i,nl+1 + do 1380 ij=1,ncum + if((i.le.inb(ij)).and.(k.le.inb(ij)))then + fq(ij,i)=fq(ij,i) + & +g*dpinv*ment(ij,k,i)*(qent(ij,k,i)-q(ij,i)) + fu(ij,i)=fu(ij,i) + & +g*dpinv*ment(ij,k,i)*(uent(ij,k,i)-u(ij,i)) + fv(ij,i)=fv(ij,i) + & +g*dpinv*ment(ij,k,i)*(vent(ij,k,i)-v(ij,i)) + endif + 1380 continue + 1390 continue + do 1400 ij=1,ncum + if(i.le.inb(ij))then + fq(ij,i)=fq(ij,i) + & +sigd*evap(ij,i)+g*(mp(ij,i+1)* + & (qp(ij,i+1)-q(ij,i)) + & -mp(ij,i)*(qp(ij,i)-q(ij,i-1)))*dpinv + fu(ij,i)=fu(ij,i) + & +g*(mp(ij,i+1)*(up(ij,i+1)-u(ij,i))-mp(ij,i)* + & (up(ij,i)-u(ij,i-1)))*dpinv + fv(ij,i)=fv(ij,i) + & +g*(mp(ij,i+1)*(vp(ij,i+1)-v(ij,i))-mp(ij,i)* + & (vp(ij,i)-v(ij,i-1)))*dpinv +C (saturated downdrafts resulting from mixing) ! cld + do k=i+1,inb(ij) ! cld + qcond(ij,i)=qcond(ij,i)+elij(ij,k,i) ! cld + nqcond(ij,i)=nqcond(ij,i)+1. ! cld + enddo ! cld +C (particular case: no detraining level is found) ! cld + if (nent(ij,i).eq.0) then ! cld + qcond(ij,i)=qcond(ij,i)+(1.-ep(ij,i))*clw(ij,i) ! cld + nqcond(ij,i)=nqcond(ij,i)+1. ! cld + endif ! cld + if (nqcond(ij,i).ne.0.) then ! cld + qcond(ij,i)=qcond(ij,i)/nqcond(ij,i) ! cld + endif ! cld + endif + 1400 continue + 1500 continue +c +c *** Adjust tendencies at top of convection layer to reflect *** +c *** actual position of the level zero cape *** +c + do 503 ij=1,ncum + fqold=fq(ij,inb(ij)) + fq(ij,inb(ij))=fq(ij,inb(ij))*(1.-frac(ij)) + fq(ij,inb(ij)-1)=fq(ij,inb(ij)-1) + & +frac(ij)*fqold*((ph(ij,inb(ij))-ph(ij,inb(ij)+1))/ + 1 (ph(ij,inb(ij)-1)-ph(ij,inb(ij))))*lv(ij,inb(ij)) + & /lv(ij,inb(ij)-1) + ftold=ft(ij,inb(ij)) + ft(ij,inb(ij))=ft(ij,inb(ij))*(1.-frac(ij)) + ft(ij,inb(ij)-1)=ft(ij,inb(ij)-1) + & +frac(ij)*ftold*((ph(ij,inb(ij))-ph(ij,inb(ij)+1))/ + 1 (ph(ij,inb(ij)-1)-ph(ij,inb(ij))))*cpn(ij,inb(ij)) + & /cpn(ij,inb(ij)-1) + fuold=fu(ij,inb(ij)) + fu(ij,inb(ij))=fu(ij,inb(ij))*(1.-frac(ij)) + fu(ij,inb(ij)-1)=fu(ij,inb(ij)-1) + & +frac(ij)*fuold*((ph(ij,inb(ij))-ph(ij,inb(ij)+1))/ + 1 (ph(ij,inb(ij)-1)-ph(ij,inb(ij)))) + fvold=fv(ij,inb(ij)) + fv(ij,inb(ij))=fv(ij,inb(ij))*(1.-frac(ij)) + fv(ij,inb(ij)-1)=fv(ij,inb(ij)-1) + & +frac(ij)*fvold*((ph(ij,inb(ij))-ph(ij,inb(ij)+1))/ + 1 (ph(ij,inb(ij)-1)-ph(ij,inb(ij)))) + 503 continue +c +c *** Very slightly adjust tendencies to force exact *** +c *** enthalpy, momentum and tracer conservation *** +c + do 682 ij=1,ncum + ents(ij)=0.0 + uav(ij)=0.0 + vav(ij)=0.0 + do 681 i=1,inb(ij) + ents(ij)=ents(ij) + & +(cpn(ij,i)*ft(ij,i)+lv(ij,i)*fq(ij,i))*(ph(ij,i)-ph(ij,i+1)) + uav(ij)=uav(ij)+fu(ij,i)*(ph(ij,i)-ph(ij,i+1)) + vav(ij)=vav(ij)+fv(ij,i)*(ph(ij,i)-ph(ij,i+1)) + 681 continue + 682 continue + do 683 ij=1,ncum + ents(ij)=ents(ij)/(ph(ij,1)-ph(ij,inb(ij)+1)) + uav(ij)=uav(ij)/(ph(ij,1)-ph(ij,inb(ij)+1)) + vav(ij)=vav(ij)/(ph(ij,1)-ph(ij,inb(ij)+1)) + 683 continue + do 642 ij=1,ncum + do 641 i=1,inb(ij) + ft(ij,i)=ft(ij,i)-ents(ij)/cpn(ij,i) + fu(ij,i)=(1.-cu)*(fu(ij,i)-uav(ij)) + fv(ij,i)=(1.-cu)*(fv(ij,i)-vav(ij)) + 641 continue + 642 continue +c + do 1810 k=1,nl+1 + do 1800 i=1,ncum + if((q(i,k)+delt*fq(i,k)).lt.0.0)iflag(i)=10 + 1800 continue + 1810 continue +c +c + do 1900 i=1,ncum + if(iflag(i).gt.2)then + precip(i)=0.0 + cbmf(i)=0.0 + endif + 1900 continue + do 1920 k=1,nl + do 1910 i=1,ncum + if(iflag(i).gt.2)then + ft(i,k)=0.0 + fq(i,k)=0.0 + fu(i,k)=0.0 + fv(i,k)=0.0 + qcondc(i,k)=0.0 ! cld + endif + 1910 continue + 1920 continue + + do k=1,nl+1 + do i=1,ncum + Ma(i,k) = 0. + enddo + enddo + do k=nl,1,-1 + do i=1,ncum + Ma(i,k) = Ma(i,k+1)+m(i,k) + enddo + enddo + +c +c *** diagnose the in-cloud mixing ratio *** ! cld +c *** of condensed water *** ! cld +c ! cld + DO ij=1,ncum ! cld + do i=1,nd ! cld + mac(ij,i)=0.0 ! cld + wa(ij,i)=0.0 ! cld + siga(ij,i)=0.0 ! cld + enddo ! cld + do i=nk(ij),inb(ij) ! cld + do k=i+1,inb(ij)+1 ! cld + mac(ij,i)=mac(ij,i)+m(ij,k) ! cld + enddo ! cld + enddo ! cld + do i=icb(ij),inb(ij)-1 ! cld + ax(ij,i)=0. ! cld + do j=icb(ij),i ! cld + ax(ij,i)=ax(ij,i)+rrd*(tvp(ij,j)-tv(ij,j)) ! cld + : *(ph(ij,j)-ph(ij,j+1))/p(ij,j) ! cld + enddo ! cld + if (ax(ij,i).gt.0.0) then ! cld + wa(ij,i)=sqrt(2.*ax(ij,i)) ! cld + endif ! cld + enddo ! cld + do i=1,nl ! cld + if (wa(ij,i).gt.0.0) ! cld + : siga(ij,i)=mac(ij,i)/wa(ij,i) ! cld + : *rrd*tvp(ij,i)/p(ij,i)/100./delta ! cld + siga(ij,i) = min(siga(ij,i),1.0) ! cld + qcondc(ij,i)=siga(ij,i)*clw(ij,i)*(1.-ep(ij,i)) ! cld + : + (1.-siga(ij,i))*qcond(ij,i) ! cld + enddo ! cld + ENDDO ! cld + + return + end + + SUBROUTINE cv_uncompress(nloc,len,ncum,nd,idcum + : ,iflag + : ,precip,cbmf + : ,ft,fq,fu,fv + : ,Ma,qcondc + : ,iflag1 + : ,precip1,cbmf1 + : ,ft1,fq1,fu1,fv1 + : ,Ma1,qcondc1 + : ) + implicit none + +#include "cvparam.h" + +c inputs: + integer len, ncum, nd, nloc + integer idcum(nloc) + integer iflag(nloc) + real precip(nloc), cbmf(nloc) + real ft(nloc,nd), fq(nloc,nd), fu(nloc,nd), fv(nloc,nd) + real Ma(nloc,nd) + real qcondc(nloc,nd) !cld + +c outputs: + integer iflag1(len) + real precip1(len), cbmf1(len) + real ft1(len,nd), fq1(len,nd), fu1(len,nd), fv1(len,nd) + real Ma1(len,nd) + real qcondc1(len,nd) !cld + +c local variables: + integer i,k + + do 2000 i=1,ncum + precip1(idcum(i))=precip(i) + cbmf1(idcum(i))=cbmf(i) + iflag1(idcum(i))=iflag(i) + 2000 continue + + do 2020 k=1,nl + do 2010 i=1,ncum + 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) + qcondc1(idcum(i),k)=qcondc(i,k) + 2010 continue + 2020 continue + + return + end + Index: /LMDZ.3.3/branches/rel-LF/libf/phylmd/cvflag.h =================================================================== --- /LMDZ.3.3/branches/rel-LF/libf/phylmd/cvflag.h (revision 418) +++ /LMDZ.3.3/branches/rel-LF/libf/phylmd/cvflag.h (revision 418) @@ -0,0 +1,3 @@ + logical cvflag_grav + + COMMON /cvflag/ cvflag_grav Index: /LMDZ.3.3/branches/rel-LF/libf/phylmd/cvparam.h =================================================================== --- /LMDZ.3.3/branches/rel-LF/libf/phylmd/cvparam.h (revision 418) +++ /LMDZ.3.3/branches/rel-LF/libf/phylmd/cvparam.h (revision 418) @@ -0,0 +1,25 @@ +c------------------------------------------------------------ +c Parameters for convectL: +c (includes - microphysical parameters, +c - parameters that control the rate of approach +c to quasi-equilibrium) +c - noff & minorig (previously in input of convect1) +c------------------------------------------------------------ + + integer noff, minorig, nl, nlp, nlm + real elcrit, tlcrit + real entp + real sigs, sigd + real omtrain, omtsnow, coeffr, coeffs + real dtmax + real cu + real betad + real alpha, damp + real delta + + COMMON /cvparam/ noff, minorig, nl, nlp, nlm + : ,elcrit, tlcrit + : ,entp, sigs, sigd + : ,omtrain, omtsnow, coeffr, coeffs + : ,dtmax, cu, betad, alpha, damp, delta + Index: /LMDZ.3.3/branches/rel-LF/libf/phylmd/cvparam3.h =================================================================== --- /LMDZ.3.3/branches/rel-LF/libf/phylmd/cvparam3.h (revision 418) +++ /LMDZ.3.3/branches/rel-LF/libf/phylmd/cvparam3.h (revision 418) @@ -0,0 +1,24 @@ +c------------------------------------------------------------ +c Parameters for convectL, iflag_con=3: +c (includes - microphysical parameters, +c - parameters that control the rate of approach +c to quasi-equilibrium) +c - noff & minorig (previously in input of convect1) +c------------------------------------------------------------ + + integer noff, minorig, nl, nlp, nlm + real sigd, spfac + real pbcrit, ptcrit, epmax + real omtrain + real dtovsh, dpbase, dttrig + real dtcrit, tau, beta, alpha + real delta + real betad + + COMMON /cvparam3/ noff, minorig, nl, nlp, nlm + : , sigd, spfac + : ,pbcrit, ptcrit, epmax + : ,omtrain + : ,dtovsh, dpbase, dttrig + : ,dtcrit, tau, beta, alpha, delta, betad + Index: /LMDZ.3.3/branches/rel-LF/libf/phylmd/cvthermo.h =================================================================== --- /LMDZ.3.3/branches/rel-LF/libf/phylmd/cvthermo.h (revision 418) +++ /LMDZ.3.3/branches/rel-LF/libf/phylmd/cvthermo.h (revision 418) @@ -0,0 +1,12 @@ +c Thermodynamical constants for convectL: + + real cpd, cpv, cl, rrv, rrd, lv0, g, rowl, t0 + real clmcpv, clmcpd, cpdmcp, cpvmcpd, cpvmcl + real eps, epsi, epsim1 + real ginv, hrd + real grav + + COMMON /cvthermo/ cpd, cpv, cl, rrv, rrd, lv0, g, rowl, t0 + : ,clmcpv, clmcpd, cpdmcp, cpvmcpd, cpvmcl + : ,eps, epsi, epsim1, ginv, hrd, grav + Index: /LMDZ.3.3/branches/rel-LF/libf/phylmd/fisrtilp.h =================================================================== --- /LMDZ.3.3/branches/rel-LF/libf/phylmd/fisrtilp.h (revision 418) +++ /LMDZ.3.3/branches/rel-LF/libf/phylmd/fisrtilp.h (revision 418) @@ -0,0 +1,18 @@ + REAL cld_lc_lsc,cld_lc_con + REAL cld_tau_lsc,cld_tau_con + REAL ffallv_lsc,ffallv_con + REAL coef_eva + LOGICAL reevap_ice + INTEGER iflag_pdf + + common/comfisrtilp/ + s cld_lc_lsc ! 2.6e-4 + s ,cld_lc_con ! 2.6e-4 + s ,cld_tau_lsc ! 3600. + s ,cld_tau_con ! 3600. + s ,ffallv_lsc ! 1. + s ,ffallv_con ! 1. + s ,coef_eva ! 2.e-5 + s ,reevap_ice ! F + s ,iflag_pdf ! 0 + Index: /LMDZ.3.3/branches/rel-LF/libf/phylmd/ini_histday.h =================================================================== --- /LMDZ.3.3/branches/rel-LF/libf/phylmd/ini_histday.h (revision 418) +++ /LMDZ.3.3/branches/rel-LF/libf/phylmd/ini_histday.h (revision 418) @@ -0,0 +1,342 @@ + IF (ok_journe) THEN +c + idayref = day_ref + CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian) +c + CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlon,zx_lon) + DO i = 1, iim + zx_lon(i,1) = rlon(i+1) + zx_lon(i,jjmp1) = rlon(i+1) + ENDDO + DO ll=1,klev + znivsig(ll)=float(ll) + ENDDO + CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlat,zx_lat) + write(*,*)'zx_lon = ',zx_lon(:,1) + write(*,*)'zx_lat = ',zx_lat(1,:) + CALL histbeg("histday", iim,zx_lon(:,1), jjmp1,zx_lat(1,:), + . 1,iim,1,jjmp1, itau_phy, zjulian, dtime, + . nhori, nid_day) + write(*,*)'Journee ', itau_phy, zjulian + CALL histvert(nid_day, "presnivs", "Vertical levels", "mb", + . klev, presnivs, nvert) +c call histvert(nid_day, 'sig_s', 'Niveaux sigma','-', +c . klev, znivsig, nvert) +c + zsto = dtime + zout = dtime * FLOAT(ecrit_day) +C Essai writephys +c nom_fichier = 'histday1' +c call writephy_ini(fid_day,nom_fichier,klon,iim,jjmp1,klev, +c . rlon,rlat, presnivs, +c . zjulian, dtime) +c call writephy_def(prof2d_on, fid_day, "once", zsto, zout, 0) +c call writephy_def(prof3d_on, fid_day, "once", zsto, zout, +c . klev) +c call writephy_def(prof2d_av, fid_day, "ave(X)", zsto, zout, 0) +c call writephy_def(prof3d_av, fid_day, "ave(X)", zsto, zout, +c . klev) + +c + CALL histdef(nid_day, "phis", "Surface geop. height", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "once", zsto,zout) +c + CALL histdef(nid_day, "aire", "Grid area", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "once", zsto,zout) +c +c Champs 2D: +c + CALL histdef(nid_day, "tsol", "Surface Temperature", "K", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "tter", "Surface Temperature", "K", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "tlic", "Surface Temperature", "K", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "toce", "Surface Temperature", "K", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "tsic", "Surface Temperature", "K", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c +cccIM +c + CALL histdef(nid_day, "t2m", "Temperature 2m", "K", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "t2mter", "Temp.terre 2m", "K", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "t2mlic", "Temp.lic 2m", "K", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "t2moce", "Temp.oce 2m", "K", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "t2msic", "Temp.sic 2m", "K", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "t2m_min", "Temp. 2m min.", + . "K", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . t2mincels, zsto,zout) +c + CALL histdef(nid_day, "t2m_max", "Temp. 2m max.", + . "K", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . t2maxcels, zsto,zout) +c + CALL histdef(nid_day, "t2mter_min", "Temp.terre 2m min.", + . "K", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . t2mincels, zsto,zout) +c + CALL histdef(nid_day, "t2mter_max", "Temp.terre 2m max.", + . "K", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . t2maxcels, zsto,zout) +c + CALL histdef(nid_day, "q2m", "Specific humidity", "Kg/Kg", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "u10m", "Vent zonal 10m", "m/s", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "u10mter", "Vent zonal ter 10m", "m/s", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "u10mlic", "Vent zonal lic 10m", "m/s", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "u10moce", "Vent zonal oce 10m", "m/s", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "u10msic", "Vent zonal sic 10m", + . "m/s",iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "v10m", "Vent meridien 10m", "m/s", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "v10mter", "Vent meridien ter 10m", + . "m/s", iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "v10mlic", "Vent meridien lic 10m", + . "m/s",iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "v10moce", "Vent meridien oce 10m", + . "m/s",iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "v10msic", "Vent meridien sic 10m", + . "m/s",iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "psol", "Surface Pressure", "Pa", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "precip","Precipitation Totale liq+sol" + . , "kg/s", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "snow", "Snow fall", "kg/s", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "snow_mass", "Snow Mass", "kg/m2", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "evap", "Evaporation", "kg/s", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "tops", "Solar rad. at TOA", "W/m2", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "topl", "IR rad. at TOA", "W/m2", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "sols", "Net Solar rad. at surf.", + . "W/m2", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "soll", "Net IR rad. at surface", "W/m2", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "solldown", "Down. IR rad. at surface", + . "W/m2", iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "bils", "Surf. total heat flux", "W/m2", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "sens", "Sensible heat flux", "W/m2", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "fder", "Heat flux derivation", "W/m2", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "frtu", "Zonal wind stress", "Pa", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "frtv", "Meridional wind stress", "Pa", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c +CXXX PB flux pour chaque sous surface +C + DO nsrf = 1, nbsrf +C + call histdef(nid_day, "pourc_"//clnsurf(nsrf), + $ "Fraction"//clnsurf(nsrf), "W/m2", + $ iim,jjmp1,nhori, 1,1,1, -99, 32, + $ "ave(X)", zsto,zout) +C + call histdef(nid_day, "tsol_"//clnsurf(nsrf), + $ "Fraction"//clnsurf(nsrf), "W/m2", + $ iim,jjmp1,nhori, 1,1,1, -99, 32, + $ "ave(X)", zsto,zout) +C + call histdef(nid_day, "sens_"//clnsurf(nsrf), + $ "Sensible heat flux "//clnsurf(nsrf), "W/m2", + $ iim,jjmp1,nhori, 1,1,1, -99, 32, + $ "ave(X)", zsto,zout) +c + call histdef(nid_day, "lat_"//clnsurf(nsrf), + $ "Latent heat flux "//clnsurf(nsrf), "W/m2", + $ iim,jjmp1,nhori, 1,1,1, -99, 32, + $ "ave(X)", zsto,zout) +C + call histdef(nid_day, "taux_"//clnsurf(nsrf), + $ "Zonal wind stress"//clnsurf(nsrf),"Pa", + $ iim,jjmp1,nhori, 1,1,1, -99, 32, + $ "ave(X)", zsto,zout) + + call histdef(nid_day, "tauy_"//clnsurf(nsrf), + $ "Meridional xind stress "//clnsurf(nsrf), "Pa", + $ iim,jjmp1,nhori, 1,1,1, -99, 32, + $ "ave(X)", zsto,zout) +C + call histdef(nid_day, "albe_"//clnsurf(nsrf), + $ "Albedo surf. "//clnsurf(nsrf), "W/m2", + $ iim,jjmp1,nhori, 1,1,1, -99, 32, + $ "ave(X)", zsto,zout) +C + call histdef(nid_day, "rugs_"//clnsurf(nsrf), + $ "Latent heat flux "//clnsurf(nsrf), "W/m2", + $ iim,jjmp1,nhori, 1,1,1, -99, 32, + $ "ave(X)", zsto,zout) + +CXXX + END DO + + CALL histdef(nid_day, "sicf", "Sea-ice fraction", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "cldl", "Low-level cloudiness", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "cldm", "Mid-level cloudiness", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "cldh", "High-level cloudiness", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "cldt", "Total cloudiness", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "cldq", "Cloud liquid water path", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c +c Champs 3D: +c + CALL histdef(nid_day, "temp", "Air temperature", "K", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "ovap", "Specific humidity", "Kg/Kg", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "geop", "Geopotential height", "m", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "vitu", "Zonal wind", "m/s", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "vitv", "Meridional wind", "m/s", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "vitw", "Vertical wind", "m/s", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "pres", "Air pressure", "Pa", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c +cccIM + CALL histdef(nid_day, "SWupTOA", "SWup at TOA","W/m2", + . iim,jjmp1,nhori, 1,1,1,-99, + . 32, "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "SWupSFC", "SWup at surface","W/m2", + . iim,jjmp1,nhori, 1,1,1,-99, + . 32, "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "SWdnTOA", "SWdn at TOA","W/m2", + . iim,jjmp1,nhori, 1,1,1,-99, + . 32, "ave(X)", zsto,zout) +c + CALL histdef(nid_day, "SWdnSFC", "SWdn at surface","W/m2", + . iim,jjmp1,nhori, 1,1,1,-99, + . 32, "ave(X)", zsto,zout) +c + CALL histend(nid_day) +c + ndex2d = 0 + ndex3d = 0 +c + ENDIF ! fin de test sur ok_journe Index: /LMDZ.3.3/branches/rel-LF/libf/phylmd/ini_histhf.h =================================================================== --- /LMDZ.3.3/branches/rel-LF/libf/phylmd/ini_histhf.h (revision 418) +++ /LMDZ.3.3/branches/rel-LF/libf/phylmd/ini_histhf.h (revision 418) @@ -0,0 +1,91 @@ + + IF (ok_hf) THEN +c + PRINT*, 'La frequence de sortie instant. est de ', ecrit_hf + +cccIM CALL ymds2ju(anne_ini, 1, 1, 0.0, zjulian) + CALL ymds2ju(annee_ref, 1, 1, 0.0, zjulian) + zjulian = zjulian + day_ini +c + CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlon,zx_lon) + DO i = 1, iim + zx_lon(i,1) = rlon(i+1) + zx_lon(i,jjmp1) = rlon(i+1) + ENDDO + + CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlat,zx_lat) + +cccIM CALL histbeg("histhf", iim,zx_lon, jjmp1,zx_lat, + CALL histbeg("histhf", iim,zx_lon(:,1), jjmp1,zx_lat(1,:), + . 1,iim,1,jjmp1, 0, zjulian, dtime, + . nhori, nid_hf) + + CALL histvert(nid_hf, "presnivs", "Vertical levels", "mb", + . klev, presnivs, nvert) + zsto = dtime + +c pour les champs instantannes, il faut mettre la meme valeur pour +c zout et tsto. +c dtime est passe par ailleurs a histbeg + + zout = dtime * FLOAT(NINT(86400./dtime*ecrit_hf)) + zsto = zout + print*,'zout,zsto=',zout,zsto + +c +c CALL histdef(nid_hf, "phis", "Surface geop. height", "-", +c . iim,jjmp1,nhori, 1,1,1, -99, 32, +c . "once", zsto,zout) +c +c CALL histdef(nid_hf, "aire", "Grid area", "-", +c . iim,jjmp1,nhori, 1,1,1, -99, 32, +c . "once", zsto,zout) +c +c Champs 2D: +c + CALL histdef(nid_hf, "tsol", "Surface Temperature", "K", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) +c + CALL histdef(nid_hf, "psol", "Surface Pressure", "Pa", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) +c + print*,'ATTENTION METTRE AVE(X) POUR LES PRECIPS' + + CALL histdef(nid_hf, "rain", "Precipitation", "mm/d", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) +c + CALL histdef(nid_hf, "u850", "Zonal wind 850mb", "m/s", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) + + CALL histdef(nid_hf, "v850", "Meridional wind 850mb", "m/s", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) +c + CALL histdef(nid_hf, "u500", "Zonal wind 500mb", "m/s", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) + + CALL histdef(nid_hf, "v500", "Meridional wind 500mb", "m/s", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) + + CALL histdef(nid_hf, "u200", "Zonal wind 200mb", "m/s", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) + + CALL histdef(nid_hf, "v200", "Meridional wind 200mb", "m/s", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) + + CALL histdef(nid_hf, "phi500", "Geopotentiel à 500mb", "m2/s2", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) + +c + CALL histend(nid_hf) + + endif ! ok_hf Index: /LMDZ.3.3/branches/rel-LF/libf/phylmd/ini_histins.h =================================================================== --- /LMDZ.3.3/branches/rel-LF/libf/phylmd/ini_histins.h (revision 418) +++ /LMDZ.3.3/branches/rel-LF/libf/phylmd/ini_histins.h (revision 418) @@ -0,0 +1,235 @@ + IF (ok_instan) THEN +c + idayref = day_ref + CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian) +c + CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlon,zx_lon) + DO i = 1, iim + zx_lon(i,1) = rlon(i+1) + zx_lon(i,jjmp1) = rlon(i+1) + ENDDO + DO ll=1,klev + znivsig(ll)=float(ll) + ENDDO + CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlat,zx_lat) + CALL histbeg("histins", iim,zx_lon(:,1), jjmp1,zx_lat(1,:), + . 1,iim,1,jjmp1, itau_phy, zjulian, dtime, + . nhori, nid_ins) + write(*,*)'Inst ', itau_phy, zjulian + CALL histvert(nid_ins, "presnivs", "Vertical levels", "mb", + . klev, presnivs, nvert) +c call histvert(nid_ins, 'sig_s', 'Niveaux sigma','-', +c . klev, znivsig, nvert) +c +c + zsto = dtime * ecrit_ins + zout = dtime * ecrit_ins +C + CALL histdef(nid_ins, "phis", "Surface geop. height", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "once", zsto,zout) +c + CALL histdef(nid_ins, "aire", "Grid area", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "once", zsto,zout) +c +c Champs 2D: +c + CALL histdef(nid_ins, "tsol", "Surface Temperature", "K", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) +c + CALL histdef(nid_ins, "t2m", "Temperature 2m", "K", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) +c + CALL histdef(nid_ins, "q2m", "Specific humidity 2m", "Kg/Kg", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) +c + CALL histdef(nid_ins, "u10m", "Vent zonal 10m", "m/s", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) +c + CALL histdef(nid_ins, "v10m", "Vent meridien 10m", "m/s", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) +c + CALL histdef(nid_ins, "psol", "Surface Pressure", "Pa", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) +c + CALL histdef(nid_ins, "plul", "Large-scale Precip.", "mm/day", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) +c + CALL histdef(nid_ins, "pluc", "Convective Precip.", "mm/day", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) + + CALL histdef(nid_ins, "qsol", "Surface humidity", "mm", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) +c + CALL histdef(nid_ins, "cdrm", "Momentum drag coef.", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) +c + CALL histdef(nid_ins, "cdrh", "Heat drag coef.", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) +c + CALL histdef(nid_ins, "precip", "Precipitation Totale liq+sol", + . "kg/s", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) +c + CALL histdef(nid_ins, "snow", "Snow fall", "kg/s", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) +c + CALL histdef(nid_ins, "snow_mass", "Snow Mass", "kg/m2", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) +c + CALL histdef(nid_ins, "topl", "OLR", "W/m2", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) +c + CALL histdef(nid_ins, "evap", "Evaporation", "kg/s", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) +c + CALL histdef(nid_ins, "sols", "Solar rad. at surf.", "W/m2", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) +c + CALL histdef(nid_ins, "soll", "IR rad. at surface", "W/m2", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) +c + CALL histdef(nid_ins, "solldown", "Down. IR rad. at surface", + . "W/m2", iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) +c + CALL histdef(nid_ins, "bils", "Surf. total heat flux", "W/m2", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) +c + CALL histdef(nid_ins, "sens", "Sensible heat flux", "W/m2", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) +c + CALL histdef(nid_ins, "fder", "Heat flux derivation", "W/m2", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) +c + CALL histdef(nid_ins, "dtsvdfo", "Boundary-layer dTs(o)", "K/s", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) +c + CALL histdef(nid_ins, "dtsvdft", "Boundary-layer dTs(t)", "K/s", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) +c + CALL histdef(nid_ins, "dtsvdfg", "Boundary-layer dTs(g)", "K/s", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) +c + CALL histdef(nid_ins, "dtsvdfi", "Boundary-layer dTs(g)", "K/s", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) + + DO nsrf = 1, nbsrf +C + call histdef(nid_ins, "pourc_"//clnsurf(nsrf), + $ "Fraction"//clnsurf(nsrf), "W/m2", + $ iim,jjmp1,nhori, 1,1,1, -99, 32, + $ "inst(X)", zsto,zout) + + call histdef(nid_ins, "sens_"//clnsurf(nsrf), + $ "Sensible heat flux "//clnsurf(nsrf), "W/m2", + $ iim,jjmp1,nhori, 1,1,1, -99, 32, + $ "inst(X)", zsto,zout) +c + call histdef(nid_ins, "tsol_"//clnsurf(nsrf), + $ "Surface Temperature"//clnsurf(nsrf), "W/m2", + $ iim,jjmp1,nhori, 1,1,1, -99, 32, + $ "inst(X)", zsto,zout) +c + call histdef(nid_ins, "lat_"//clnsurf(nsrf), + $ "Latent heat flux "//clnsurf(nsrf), "W/m2", + $ iim,jjmp1,nhori, 1,1,1, -99, 32, + $ "inst(X)", zsto,zout) +C + call histdef(nid_ins, "taux_"//clnsurf(nsrf), + $ "Zonal wind stress"//clnsurf(nsrf),"Pa", + $ iim,jjmp1,nhori, 1,1,1, -99, 32, + $ "inst(X)", zsto,zout) + + call histdef(nid_ins, "tauy_"//clnsurf(nsrf), + $ "Meridional xind stress "//clnsurf(nsrf), "Pa", + $ iim,jjmp1,nhori, 1,1,1, -99, 32, + $ "inst(X)", zsto,zout) +c + call histdef(nid_ins, "albe_"//clnsurf(nsrf), + $ "Albedo "//clnsurf(nsrf), "-", + $ iim,jjmp1,nhori, 1,1,1, -99, 32, + $ "inst(X)", zsto,zout) +c + call histdef(nid_ins, "rugs_"//clnsurf(nsrf), + $ "rugosite "//clnsurf(nsrf), "-", + $ iim,jjmp1,nhori, 1,1,1, -99, 32, + $ "inst(X)", zsto,zout) +CXXX + END DO + CALL histdef(nid_ins, "rugs", "rugosity", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) + +c + CALL histdef(nid_ins, "albs", "Surface albedo", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) + CALL histdef(nid_ins, "albslw", "Surface albedo LW", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "inst(X)", zsto,zout) +c +c +c Champs 3D: +c + CALL histdef(nid_ins, "temp", "Temperature", "K", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "inst(X)", zsto,zout) +c + CALL histdef(nid_ins, "vitu", "Zonal wind", "m/s", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "inst(X)", zsto,zout) +c + CALL histdef(nid_ins, "vitv", "Merid wind", "m/s", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "inst(X)", zsto,zout) +c + CALL histdef(nid_ins, "geop", "Geopotential height", "m", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "inst(X)", zsto,zout) +c + CALL histdef(nid_ins, "pres", "Air pressure", "Pa", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "inst(X)", zsto,zout) +c + CALL histdef(nid_ins, "dtvdf", "Boundary-layer dT", "K/s", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "inst(X)", zsto,zout) +c + CALL histdef(nid_ins, "dqvdf", "Boundary-layer dQ", "Kg/Kg/s", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "inst(X)", zsto,zout) +c + + CALL histend(nid_ins) +c + ndex2d = 0 + ndex3d = 0 +c + ENDIF Index: /LMDZ.3.3/branches/rel-LF/libf/phylmd/ini_histmth.h =================================================================== --- /LMDZ.3.3/branches/rel-LF/libf/phylmd/ini_histmth.h (revision 418) +++ /LMDZ.3.3/branches/rel-LF/libf/phylmd/ini_histmth.h (revision 418) @@ -0,0 +1,489 @@ + IF (ok_mensuel) THEN +c + idayref = day_ref + CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian) +c + CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlon,zx_lon) + DO i = 1, iim + zx_lon(i,1) = rlon(i+1) + zx_lon(i,jjmp1) = rlon(i+1) + ENDDO + DO ll=1,klev + znivsig(ll)=float(ll) + ENDDO + CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlat,zx_lat) + CALL histbeg("histmth.nc", iim,zx_lon(:,1), jjmp1,zx_lat(1,:), + . 1,iim,1,jjmp1, itau_phy, zjulian, dtime, + . nhori, nid_mth) + write(*,*)'Mensuel ', itau_phy, zjulian + CALL histvert(nid_mth, "presnivs", "Vertical levels", "mb", + . klev, presnivs, nvert) +c call histvert(nid_mth, 'sig_s', 'Niveaux sigma','-', +c . klev, znivsig, nvert) +c + zsto = dtime + zout = dtime * ecrit_mth +c + CALL histdef(nid_mth, "phis", "Surface geop. height", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "once", zsto,zout) +c + CALL histdef(nid_mth, "aire", "Grid area", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "once", zsto,zout) +c +c Champs 2D: +c + CALL histdef(nid_mth, "tsol", "Surface Temperature", "K", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "t2m", "Temperature 2m", "K", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "q2m", "Specific humidity 2m", "Kg/Kg", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "u10m", "Vent zonal 10m", "m/s", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "v10m", "Vent meridien 10m", "m/s", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c +c + CALL histdef(nid_mth, "psol", "Surface Pressure", "Pa", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "qsol", "Surface humidity", "mm", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "precip", "Precipitation Totale liq+sol", + . "kg/s", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "plul", "Large-scale Precip.", "kg/s", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "pluc", "Convective Precip.", "kg/s", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "snow", "Snow fall", "kg/s", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "snow_mass", "Snow Mass", "kg/m2", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "evap", "Evaporation", "kg/s", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "tops", "Solar rad. at TOA", "W/m2", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "topl", "IR rad. at TOA", "W/m2", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "sols", "Solar rad. at surf.", "W/m2", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "soll", "IR rad. at surface", "W/m2", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "solldown", "Down. IR rad. at surface", + . "W/m2", iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "tops0", "Solar rad. at TOA", "W/m2", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "topl0", "IR rad. at TOA", "W/m2", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "sols0", "Solar rad. at surf.", "W/m2", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "soll0", "IR rad. at surface", "W/m2", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "bils", "Surf. total heat flux", "W/m2", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "sens", "Sensible heat flux", "W/m2", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "fder", "Heat flux derivation", "W/m2", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "frtu", "Zonal wind stress", "Pa", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "frtv", "Meridional wind stress", "Pa", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + DO nsrf = 1, nbsrf +C + call histdef(nid_mth, "pourc_"//clnsurf(nsrf), + $ "Fraction "//clnsurf(nsrf), "W/m2", + $ iim,jjmp1,nhori, 1,1,1, -99, 32, + $ "ave(X)", zsto,zout) +C + call histdef(nid_mth, "tsol_"//clnsurf(nsrf), + $ "Fraction "//clnsurf(nsrf), "W/m2", + $ iim,jjmp1,nhori, 1,1,1, -99, 32, + $ "ave(X)", zsto,zout) +C + call histdef(nid_mth, "sens_"//clnsurf(nsrf), + $ "Sensible heat flux "//clnsurf(nsrf), "W/m2", + $ iim,jjmp1,nhori, 1,1,1, -99, 32, + $ "ave(X)", zsto,zout) +c + call histdef(nid_mth, "lat_"//clnsurf(nsrf), + $ "Latent heat flux "//clnsurf(nsrf), "W/m2", + $ iim,jjmp1,nhori, 1,1,1, -99, 32, + $ "ave(X)", zsto,zout) +C + call histdef(nid_mth, "taux_"//clnsurf(nsrf), + $ "Zonal wind stress"//clnsurf(nsrf), "Pa", + $ iim,jjmp1,nhori, 1,1,1, -99, 32, + $ "ave(X)", zsto,zout) + + call histdef(nid_mth, "tauy_"//clnsurf(nsrf), + $ "Meridional xind stress "//clnsurf(nsrf), "Pa", + $ iim,jjmp1,nhori, 1,1,1, -99, 32, + $ "ave(X)", zsto,zout) +c + call histdef(nid_mth, "albe_"//clnsurf(nsrf), + $ "Albedo surf. "//clnsurf(nsrf), "W/m2", + $ iim,jjmp1,nhori, 1,1,1, -99, 32, + $ "ave(X)", zsto,zout) +c + call histdef(nid_mth, "rugs_"//clnsurf(nsrf), + $ "Latent heat flux "//clnsurf(nsrf), "W/m2", + $ iim,jjmp1,nhori, 1,1,1, -99, 32, + $ "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "ages_"//clnsurf(nsrf), "Snow age","day", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) + + END DO +C + CALL histdef(nid_mth, "sicf", "Sea-ice fraction", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "albs", "Surface albedo", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) + CALL histdef(nid_mth, "albslw", "Surface albedo LW", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "cdrm", "Momentum drag coef.", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "cdrh", "Heat drag coef.", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "cldl", "Low-level cloudiness", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "cldm", "Mid-level cloudiness", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "cldh", "High-level cloudiness", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "cldt", "Total cloudiness", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "cldq", "Cloud liquid water path", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "ue", "Zonal energy transport", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "ve", "Merid energy transport", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "uq", "Zonal humidity transport", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "vq", "Merid humidity transport", "-", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +cKE43 + IF (iflag_con .GE. 3) THEN ! sb +c + CALL histdef(nid_mth, "cape", "Conv avlbl pot ener", "J/Kg", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "pbase", "Cld base pressure", "hPa", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "ptop", "Cld top pressure", "hPa", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "fbase", "Cld base mass flux", "Kg/m2/s", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zsto,zout) +c +c + ENDIF +c34EK +c +c Champs 3D: +c + CALL histdef(nid_mth, "temp", "Air temperature", "K", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "ovap", "Specific humidity", "Kg/Kg", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "geop", "Geopotential height", "m", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "vitu", "Zonal wind", "m/s", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "vitv", "Meridional wind", "m/s", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "vitw", "Vertical wind", "m/s", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "pres", "Air pressure", "Pa", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "rneb", "Cloud fraction", "-", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "rhum", "Relative humidity", "-", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "clwcon", "Cloud Liquid water content" + . , "kg/kg", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "oliq", "Liquid water content", "kg/kg", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "dtdyn", "Dynamics dT", "K/s", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "dqdyn", "Dynamics dQ", "Kg/Kg/s", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "dtcon", "Convection dT", "K/s", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "ducon", "Convection du", "m/s2", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "dqcon", "Convection dQ", "Kg/Kg/s", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "dtlsc", "Condensation dT", "K/s", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "dqlsc", "Condensation dQ", "Kg/Kg/s", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "dtvdf", "Boundary-layer dT", "K/s", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "dqvdf", "Boundary-layer dQ", "Kg/Kg/s", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "dteva", "Reevaporation dT", "K/s", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "dqeva", "Reevaporation dQ", "Kg/Kg/s", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + + CALL histdef(nid_mth, "ptconv", "POINTS CONVECTIFS"," ", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + + CALL histdef(nid_mth, "ratqs", "RATQS"," ", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + +c + CALL histdef(nid_mth, "dtajs", "Dry adjust. dT", "K/s", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + + CALL histdef(nid_mth, "dqajs", "Dry adjust. dQ", "Kg/Kg/s", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "dtswr", "SW radiation dT", "K/s", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "dtsw0", "SW radiation dT", "K/s", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "dtlwr", "LW radiation dT", "K/s", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "dtlw0", "LW radiation dT", "K/s", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "dtec", "Cinetic dissip dT", "K/s", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "duvdf", "Boundary-layer dU", "m/s2", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "dvvdf", "Boundary-layer dV", "m/s2", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + IF (ok_orodr) THEN + CALL histdef(nid_mth, "duoro", "Orography dU", "m/s2", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "dvoro", "Orography dV", "m/s2", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + ENDIF +C + IF (ok_orolf) THEN + CALL histdef(nid_mth, "dulif", "Orography dU", "m/s2", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "dvlif", "Orography dV", "m/s2", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + ENDIF +C + CALL histdef(nid_mth, "ozone", "Ozone concentration", "-", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + if (nqmax.GE.3) THEN + DO iq=1,nqmax-2 + IF (iq.LE.99) THEN + WRITE(str2,'(i2.2)') iq + CALL histdef(nid_mth, "trac"//str2, "Tracer No."//str2, "-", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) + ELSE + PRINT*, "Trop de traceurs" + CALL abort + ENDIF + ENDDO + ENDIF +c +cKE43 + IF (iflag_con.GE.3) THEN ! (sb) +c + CALL histdef(nid_mth, "upwd", "saturated updraft", "Kg/m2/s", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "dnwd", "saturated downdraft","Kg/m2/s", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "dnwd0", "unsat. downdraft", "Kg/m2/s", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +c + CALL histdef(nid_mth,"Ma","undilute adiab updraft","Kg/m2/s", + . iim,jjmp1,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zsto,zout) +cccIM + CALL histdef(nid_mth, "SWupTOA", "SWup at TOA","W/m2", + . iim,jjmp1,nhori, 1,1,1,-99, + . 32, "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "SWupSFC", "SWup at surface","W/m2", + . iim,jjmp1,nhori, 1,1,1,-99, + . 32, "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "SWdnTOA", "SWdn at TOA","W/m2", + . iim,jjmp1,nhori, 1,1,1,-99, + . 32, "ave(X)", zsto,zout) +c + CALL histdef(nid_mth, "SWdnSFC", "SWdn at surface","W/m2", + . iim,jjmp1,nhori, 1,1,1,-99, + . 32, "ave(X)", zsto,zout) +c + ENDIF +c34EK + CALL histend(nid_mth) +c + ndex2d = 0 + ndex3d = 0 +c + ENDIF ! fin de test sur ok_mensuel Index: /LMDZ.3.3/branches/rel-LF/libf/phylmd/newmicro.F =================================================================== --- /LMDZ.3.3/branches/rel-LF/libf/phylmd/newmicro.F (revision 418) +++ /LMDZ.3.3/branches/rel-LF/libf/phylmd/newmicro.F (revision 418) @@ -0,0 +1,192 @@ + SUBROUTINE newmicro (paprs, pplay,ok_newmicro, + . t, pqlwp, pclc, pcltau, pclemi, + . pch, pcl, pcm, pct, pctlwp) + IMPLICIT none +c====================================================================== +c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930910 +c Objet: Calculer epaisseur optique et emmissivite des nuages +c====================================================================== +c Arguments: +c t-------input-R-temperature +c pqlwp---input-R-eau liquide nuageuse dans l'atmosphere (kg/kg) +c pclc----input-R-couverture nuageuse pour le rayonnement (0 a 1) +c +c pcltau--output-R-epaisseur optique des nuages +c pclemi--output-R-emissivite des nuages (0 a 1) +c====================================================================== +C +#include "YOMCST.h" +c +#include "dimensions.h" +#include "dimphy.h" +#include "nuage.h" + REAL paprs(klon,klev+1), pplay(klon,klev) + REAL t(klon,klev) +c + REAL pclc(klon,klev) + REAL pqlwp(klon,klev) + REAL pcltau(klon,klev), pclemi(klon,klev) +c + REAL pct(klon), pctlwp(klon), pch(klon), pcl(klon), pcm(klon) +c + LOGICAL lo +c + REAL cetahb, cetamb + PARAMETER (cetahb = 0.45, cetamb = 0.80) +C + INTEGER i, k + REAL zflwp, zradef, zfice, zmsac +c + REAL radius, rad_chaud +cc PARAMETER (rad_chau1=13.0, rad_chau2=9.0, rad_froid=35.0) +ccc PARAMETER (rad_chaud=15.0, rad_froid=35.0) +c sintex initial PARAMETER (rad_chaud=10.0, rad_froid=30.0) + REAL coef, coef_froi, coef_chau + PARAMETER (coef_chau=0.13, coef_froi=0.09) + REAL seuil_neb, t_glace + PARAMETER (seuil_neb=0.001, t_glace=273.0-15.0) + INTEGER nexpo ! exponentiel pour glace/eau + PARAMETER (nexpo=6) +ccc PARAMETER (nexpo=1) + +c -- sb: + logical ok_newmicro +c parameter (ok_newmicro=.FALSE.) + real rel, tc, rei, zfiwp + real k_liq, k_ice0, k_ice, DF + parameter (k_liq=0.0903, k_ice0=0.005) ! units=m2/g + parameter (DF=1.66) ! diffusivity factor +c sb -- + +c +c Calculer l'epaisseur optique et l'emmissivite des nuages +c + DO k = 1, klev + DO i = 1, klon + rad_chaud = rad_chau1 + IF (k.LE.3) rad_chaud = rad_chau2 + pclc(i,k) = MAX(pclc(i,k), seuil_neb) + zflwp = 1000.*pqlwp(i,k)/RG/pclc(i,k) + . *(paprs(i,k)-paprs(i,k+1)) + zfice = 1.0 - (t(i,k)-t_glace) / (273.13-t_glace) + zfice = MIN(MAX(zfice,0.0),1.0) + zfice = zfice**nexpo + radius = rad_chaud * (1.-zfice) + rad_froid * zfice + coef = coef_chau * (1.-zfice) + coef_froi * zfice + pcltau(i,k) = 3.0/2.0 * zflwp / radius + pclemi(i,k) = 1.0 - EXP( - coef * zflwp) + + if (ok_newmicro) then + +c -- liquid/ice cloud water paths: + + zfice = 1.0 - (t(i,k)-t_glace) / (273.13-t_glace) + zfice = MIN(MAX(zfice,0.0),1.0) + + zflwp = 1000.*(1.-zfice)*pqlwp(i,k)/pclc(i,k) + : *(paprs(i,k)-paprs(i,k+1))/RG + zfiwp = 1000.*zfice*pqlwp(i,k)/pclc(i,k) + : *(paprs(i,k)-paprs(i,k+1))/RG + +c -- effective cloud droplet radius (microns): + +c for liquid water clouds: + rel = rad_chaud + +c for ice clouds: as a function of the ambiant temperature +c [formula used by Iacobellis and Somerville (2000), with an +c asymptotical value of 3.5 microns at T<-81.4 C added to be +c consistent with observations of Heymsfield et al. 1986]: + tc = t(i,k)-273.15 + rei = 0.71*tc + 61.29 + if (tc.le.-81.4) rei = 3.5 + +c -- cloud optical thickness : + +c [for liquid clouds, traditional formula, +c for ice clouds, Ebert & Curry (1992)] + + if (zflwp.eq.0.) rel = 1. + if (zfiwp.eq.0. .or. rei.le.0.) rei = 1. + pcltau(i,k) = 3.0/2.0 * ( zflwp/rel ) + . + zfiwp * (3.448e-03 + 2.431/rei) + +c -- cloud infrared emissivity: + +c [the broadband infrared absorption coefficient is parameterized +c as a function of the effective cld droplet radius] + +c Ebert and Curry (1992) formula as used by Kiehl & Zender (1995): + k_ice = k_ice0 + 1.0/rei + + pclemi(i,k) = 1.0 + . - EXP( - coef_chau*zflwp - DF*k_ice*zfiwp ) + + endif ! ok_newmicro + + lo = (pclc(i,k) .LE. seuil_neb) + IF (lo) pclc(i,k) = 0.0 + IF (lo) pcltau(i,k) = 0.0 + IF (lo) pclemi(i,k) = 0.0 + ENDDO + ENDDO +ccc DO k = 1, klev +ccc DO i = 1, klon +ccc t(i,k) = t(i,k) +ccc pclc(i,k) = MAX( 1.e-5 , pclc(i,k) ) +ccc lo = pclc(i,k) .GT. (2.*1.e-5) +ccc zflwp = pqlwp(i,k)*1000.*(paprs(i,k)-paprs(i,k+1)) +ccc . /(rg*pclc(i,k)) +ccc zradef = 10.0 + (1.-sigs(k))*45.0 +ccc pcltau(i,k) = 1.5 * zflwp / zradef +ccc zfice=1.0-MIN(MAX((t(i,k)-263.)/(273.-263.),0.0),1.0) +ccc zmsac = 0.13*(1.0-zfice) + 0.08*zfice +ccc pclemi(i,k) = 1.-EXP(-zmsac*zflwp) +ccc if (.NOT.lo) pclc(i,k) = 0.0 +ccc if (.NOT.lo) pcltau(i,k) = 0.0 +ccc if (.NOT.lo) pclemi(i,k) = 0.0 +ccc ENDDO +ccc ENDDO +cccccc print*, 'pas de nuage dans le rayonnement' +cccccc DO k = 1, klev +cccccc DO i = 1, klon +cccccc pclc(i,k) = 0.0 +cccccc pcltau(i,k) = 0.0 +cccccc pclemi(i,k) = 0.0 +cccccc ENDDO +cccccc ENDDO +C +C COMPUTE CLOUD LIQUID PATH AND TOTAL CLOUDINESS +C + DO i = 1, klon + pct(i)=1.0 + pch(i)=1.0 + pcm(i) = 1.0 + pcl(i) = 1.0 + pctlwp(i) = 0.0 + ENDDO +C + DO k = klev, 1, -1 + DO i = 1, klon + pctlwp(i) = pctlwp(i) + . + pqlwp(i,k)*(paprs(i,k)-paprs(i,k+1))/RG + pct(i) = pct(i)*(1.0-pclc(i,k)) + if (pplay(i,k).LE.cetahb*paprs(i,1)) + . pch(i) = pch(i)*(1.0-pclc(i,k)) + if (pplay(i,k).GT.cetahb*paprs(i,1) .AND. + . pplay(i,k).LE.cetamb*paprs(i,1)) + . pcm(i) = pcm(i)*(1.0-pclc(i,k)) + if (pplay(i,k).GT.cetamb*paprs(i,1)) + . pcl(i) = pcl(i)*(1.0-pclc(i,k)) + ENDDO + ENDDO +C + DO i = 1, klon + pct(i)=1.-pct(i) + pch(i)=1.-pch(i) + pcm(i)=1.-pcm(i) + pcl(i)=1.-pcl(i) + ENDDO +C + RETURN + END Index: /LMDZ.3.3/branches/rel-LF/libf/phylmd/plevel.F =================================================================== --- /LMDZ.3.3/branches/rel-LF/libf/phylmd/plevel.F (revision 418) +++ /LMDZ.3.3/branches/rel-LF/libf/phylmd/plevel.F (revision 418) @@ -0,0 +1,114 @@ +c================================================================ +c================================================================ + SUBROUTINE plevel(ilon,ilev,lnew,pgcm,pres,Qgcm,Qpres) +c================================================================ +c================================================================ + + IMPLICIT none + +#include "dimensions.h" +#include "dimphy.h" + +c================================================================ +c +c Interpoler des champs 3-D u, v et g du modele a un niveau de +c pression donnee (pres) +c +c INPUT: ilon ----- nombre de points +c ilev ----- nombre de couches +c lnew ----- true si on doit reinitialiser les poids +c pgcm ----- pressions modeles +c pres ----- pression vers laquelle on interpolle +c Qgcm ----- champ GCM +c Qpres ---- champ interpolle au niveau pres +c +c================================================================ +c +c arguments : +c ----------- + + INTEGER ilon, ilev + logical lnew + + REAL pgcm(ilon,ilev) + REAL Qgcm(ilon,ilev) + real pres + REAL Qpres(ilon) + +c local : +c ------- + + INTEGER lt(klon), lb(klon) + REAL ptop, pbot, aist(klon), aisb(klon) + + save lt,lb,ptop,pbot,aist,aisb + + INTEGER i, k +c + +c===================================================================== + if (lnew) then +c on réinitialise les réindicages et les poids +c===================================================================== + + +c Chercher les 2 couches les plus proches du niveau a obtenir +c +c Eventuellement, faire l'extrapolation a partir des deux couches +c les plus basses ou les deux couches les plus hautes: + DO 130 i = 1, klon + IF ( ABS(pres-pgcm(i,ilev) ) .LT. + . ABS(pres-pgcm(i,1)) ) THEN + lt(i) = ilev ! 2 + lb(i) = ilev-1 ! 1 + ELSE + lt(i) = 2 + lb(i) = 1 + ENDIF + 130 CONTINUE + DO 150 k = 1, ilev-1 + DO 140 i = 1, klon + pbot = pgcm(i,k) + ptop = pgcm(i,k+1) + IF (ptop.LE.pres .AND. pbot.GE.pres) THEN + lt(i) = k+1 + lb(i) = k + ENDIF + 140 CONTINUE + 150 CONTINUE +c +c Interpolation lineaire: +c + DO i = 1, klon +c interpolation en logarithme de pression: +c +c ... Modif . P. Le Van ( 20/01/98) .... +c Modif Frédéric Hourdin (3/01/02) + + aist(i) = LOG( pgcm(i,lb(i))/ pres ) + . / LOG( pgcm(i,lb(i))/ pgcm(i,lt(i)) ) + aisb(i) = LOG( pres / pgcm(i,lt(i)) ) + . / LOG( pgcm(i,lb(i))/ pgcm(i,lt(i))) + enddo + + + endif ! lnew + +c====================================================================== +c inteprollation +c====================================================================== + + do i=1,klon + Qpres(i)= Qgcm(i,lb(i))*aisb(i)+Qgcm(i,lt(i))*aist(i) + enddo +c +c Je mets les vents a zero quand je rencontre une montagne + do i = 1, klon + if (pgcm(i,1).LT.pres) THEN + Qpres(i)=1e33 + endif + enddo + +c + RETURN + END Index: /LMDZ.3.3/branches/rel-LF/libf/phylmd/screenc.F90 =================================================================== --- /LMDZ.3.3/branches/rel-LF/libf/phylmd/screenc.F90 (revision 418) +++ /LMDZ.3.3/branches/rel-LF/libf/phylmd/screenc.F90 (revision 418) @@ -0,0 +1,82 @@ + SUBROUTINE screenc(klon, knon, nsrf, zxli, & + speed, temp, q_zref, zref, & + ts, qsurf, rugos, psol, & + ustar, testar, qstar, okri, ri1, & + pref, delu, delte, delq) + USE coefcdrag_int + IMPLICIT NONE +!----------------------------------------------------------------------- +! +! Objet : calcul "correcteur" des anomalies du vent, de la temperature +! potentielle et de l'humidite relative au niveau de reference zref et +! par rapport au 1er niveau (pour u) ou a la surface (pour theta et q) +! a partir des equations de Louis. +! +! Reference : Hess, Colman et McAvaney (1995) +! +! I. Musat, 01.07.2002 +!----------------------------------------------------------------------- +! +! klon----input-I- dimension de la grille physique (= nb_pts_latitude X nb_pts_longitude) +! knon----input-I- nombre de points pour un type de surface +! nsrf----input-I- indice pour le type de surface; voir indicesol.inc +! zxli----input-L- TRUE si calcul des cdrags selon Laurent Li +! speed---input-R- module du vent au 1er niveau du modele +! temp----input-R- temperature de l'air au 1er niveau du modele +! q_zref--input-R- humidite relative au 1er niveau du modele +! zref----input-R- altitude de reference +! ts------input-R- temperature de l'air a la surface +! qsurf---input-R- humidite relative a la surface +! rugos---input-R- rugosite +! psol----input-R- pression au sol +! ustar---input-R- facteur d'echelle pour le vent +! testar--input-R- facteur d'echelle pour la temperature potentielle +! qstar---input-R- facteur d'echelle pour l'humidite relative +! okri----input-L- TRUE si on veut tester le nb. Richardson entre la sfce +! et zref par rapport au Ri entre la sfce et la 1ere couche +! ri1-----input-R- nb. Richardson entre la surface et la 1ere couche +! +! pref----input-R- pression au niveau de reference +! delu----input-R- anomalie du vent par rapport au 1er niveau +! delte---input-R- anomalie de la temperature potentielle par rapport a la surface +! delq----input-R- anomalie de l'humidite relative par rapport a la surface +! + INTEGER, intent(in) :: klon, knon, nsrf + LOGICAL, intent(in) :: zxli, okri + REAL, dimension(klon), intent(in) :: speed, temp, q_zref + REAL, intent(in) :: zref + REAL, dimension(klon), intent(in) :: ts, qsurf, rugos, psol + REAL, dimension(klon), intent(in) :: ustar, testar, qstar, ri1 +! + REAL, dimension(klon), intent(out) :: pref, delu, delte, delq +!----------------------------------------------------------------------- +#include "YOMCST.inc" +! +! Variables locales + INTEGER :: i + REAL, dimension(klon) :: cdram, cdrah, cdran, zri1, gref +! +!------------------------------------------------------------------------- + DO i=1, knon + gref(i) = zref*RG + ENDDO +! +! Richardson at reference level +! + CALL coefcdrag (klon, knon, nsrf, zxli, & + speed, temp, q_zref, gref, & + psol, ts, qsurf, rugos, & + okri, ri1, & + cdram, cdrah, cdran, zri1, & + pref) +! + DO i = 1, knon + delu(i) = ustar(i)/sqrt(cdram(i)) + delte(i)= (testar(i)* sqrt(cdram(i)))/ & + cdrah(i) + delq(i)= (qstar(i)* sqrt(cdram(i)))/ & + cdrah(i) + ENDDO +! + RETURN + END SUBROUTINE screenc Index: /LMDZ.3.3/branches/rel-LF/libf/phylmd/screenp.F90 =================================================================== --- /LMDZ.3.3/branches/rel-LF/libf/phylmd/screenp.F90 (revision 418) +++ /LMDZ.3.3/branches/rel-LF/libf/phylmd/screenp.F90 (revision 418) @@ -0,0 +1,105 @@ + SUBROUTINE screenp(klon, knon, nsrf, & + & speed, tair, qair, & + & ts, qsurf, rugos, lmon, & + & ustar, testar, qstar, zref, & + & delu, delte, delq) + IMPLICIT none +!------------------------------------------------------------------------- +! +! Objet : calcul "predicteur" des anomalies du vent, de la temperature +! potentielle et de l'humidite relative au niveau de reference zref et +! par rapport au 1er niveau (pour u) ou a la surface (pour theta et q) +! a partir des relations de Dyer-Businger. +! +! Reference : Hess, Colman et McAvaney (1995) +! +! I. Musat, 01.07.2002 +!------------------------------------------------------------------------- +! +! klon----input-I- dimension de la grille physique (= nb_pts_latitude X nb_pts_longitude) +! knon----input-I- nombre de points pour un type de surface +! nsrf----input-I- indice pour le type de surface; voir indicesol.inc +! speed---input-R- module du vent au 1er niveau du modele +! tair----input-R- temperature de l'air au 1er niveau du modele +! qair----input-R- humidite relative au 1er niveau du modele +! ts------input-R- temperature de l'air a la surface +! qsurf---input-R- humidite relative a la surface +! rugos---input-R- rugosite +! lmon----input-R- longueur de Monin-Obukov +! ustar---input-R- facteur d'echelle pour le vent +! testar--input-R- facteur d'echelle pour la temperature potentielle +! qstar---input-R- facteur d'echelle pour l'humidite relative +! zref----input-R- altitude de reference +! +! delu----input-R- anomalie du vent par rapport au 1er niveau +! delte---input-R- anomalie de la temperature potentielle par rapport a la surface +! delq----input-R- anomalie de l'humidite relative par rapport a la surface +! + INTEGER, intent(in) :: klon, knon, nsrf + REAL, dimension(klon), intent(in) :: speed, tair, qair + REAL, dimension(klon), intent(in) :: ts, qsurf, rugos + DOUBLE PRECISION, dimension(klon), intent(in) :: lmon + REAL, dimension(klon), intent(in) :: ustar, testar, qstar + REAL, intent(in) :: zref +! + REAL, dimension(klon), intent(out) :: delu, delte, delq +! +!------------------------------------------------------------------------- +! Variables locales et constantes : + REAL, PARAMETER :: RKAR=0.40 + INTEGER :: i + REAL :: xtmp, xtmp0 +!------------------------------------------------------------------------- + DO i = 1, knon +! + IF (lmon(i).GE.0.) THEN +! +! STABLE CASE +! + IF (speed(i).GT.1.5.AND.lmon(i).LE.1.0) THEN + delu(i) = (ustar(i)/RKAR)* & + (log(zref/(rugos(i))+1.) + & + min(5.0, 5.0 *(zref - rugos(i))/lmon(i))) + delte(i) = (testar(i)/RKAR)* & + (log(zref/(rugos(i))+1.) + & + min(5.0, 5.0 * (zref - rugos(i))/lmon(i))) + delq(i) = (qstar(i)/RKAR)* & + (log(zref/(rugos(i))+1.) + & + min(5.0, 5.0 * (zref - rugos(i))/lmon(i))) + ELSE + delu(i) = 0.1 * speed(i) + delte(i) = 0.1 * (tair(i) - ts(i) ) + delq(i) = 0.1 * (max(qair(i),0.0) - max(qsurf(i),0.0)) + ENDIF + ELSE +! +! UNSTABLE CASE +! + IF (speed(i).GT.5.0.AND.abs(lmon(i)).LE.50.0) THEN + xtmp = (1. - 16. * (zref/lmon(i)))**(1./4.) + xtmp0 = (1. - 16. * (rugos(i)/lmon(i)))**(1./4.) + delu(i) = (ustar(i)/RKAR)* & + (log(zref/(rugos(i))+1.) & + - 2.*log(0.5*(1. + xtmp)) & + + 2.*log(0.5*(1. + xtmp0)) & + - log(0.5*(1. + xtmp*xtmp)) & + + log(0.5*(1. + xtmp0*xtmp0)) & + + 2.*atan(xtmp) - 2.*atan(xtmp0)) + delte(i) = (testar(i)/RKAR)* & + (log(zref/(rugos(i))+1.) & + - 2.0 * log(0.5*(1. + xtmp*xtmp)) & + + 2.0 * log(0.5*(1. + xtmp0*xtmp0))) + delq(i) = (qstar(i)/RKAR)* & + (log(zref/(rugos(i))+1.) & + - 2.0 * log(0.5*(1. + xtmp*xtmp)) & + + 2.0 * log(0.5*(1. + xtmp0*xtmp0))) + ELSE + delu(i) = 0.5 * speed(i) + delte(i) = 0.5 * (tair(i) - ts(i) ) + delq(i) = 0.5 * (max(qair(i),0.0) - max(qsurf(i),0.0)) + ENDIF + ENDIF +! + ENDDO + RETURN + END SUBROUTINE screenp Index: /LMDZ.3.3/branches/rel-LF/libf/phylmd/screenpc_int.F90 =================================================================== --- /LMDZ.3.3/branches/rel-LF/libf/phylmd/screenpc_int.F90 (revision 418) +++ /LMDZ.3.3/branches/rel-LF/libf/phylmd/screenpc_int.F90 (revision 418) @@ -0,0 +1,38 @@ +MODULE screenpc_int + + IMPLICIT NONE + + INTERFACE + + SUBROUTINE screenp(klon, knon, nsrf, & + & speed, tair, qair, & + & ts, qsurf, rugos, lmon, & + & ustar, testar, qstar, zref, & + & delu, delte, delq) + INTEGER, intent(in) :: klon, knon, nsrf + REAL, dimension(klon), intent(in) :: speed, tair, qair + REAL, dimension(klon), intent(in) :: ts, qsurf, rugos + DOUBLE PRECISION, dimension(klon), intent(in) :: lmon + REAL, dimension(klon), intent(in) :: ustar, testar, qstar + REAL, intent(in) :: zref + REAL, dimension(klon), intent(out) :: delu, delte, delq + END SUBROUTINE screenp + + SUBROUTINE screenc(klon, knon, nsrf, zxli, & + & speed, temp, q_zref, zref, & + & ts, qsurf, rugos, psol, & + & ustar, testar, qstar, okri, ri1, & + & pref, delu, delte, delq) + INTEGER, intent(in) :: klon, knon, nsrf + LOGICAL, intent(in) :: zxli, okri + REAL, dimension(klon), intent(in) :: speed, temp, q_zref + REAL, intent(in) :: zref + REAL, dimension(klon), intent(in) :: ts, qsurf, rugos, psol + REAL, dimension(klon), intent(in) :: ustar, testar, qstar, ri1 + REAL, dimension(klon), intent(out) :: pref, delu, delte, delq + + END SUBROUTINE screenc + + END INTERFACE + +END MODULE screenpc_int Index: /LMDZ.3.3/branches/rel-LF/libf/phylmd/stdlevvar.F90 =================================================================== --- /LMDZ.3.3/branches/rel-LF/libf/phylmd/stdlevvar.F90 (revision 418) +++ /LMDZ.3.3/branches/rel-LF/libf/phylmd/stdlevvar.F90 (revision 418) @@ -0,0 +1,239 @@ + SUBROUTINE stdlevvar(klon, knon, nsrf, zxli, & + u1, v1, t1, q1, z1, & + ts1, qsurf, rugos, psol, pat1, & + t_2m, q_2m, u_10m) + USE coefcdrag_int + USE screenpc_int + IMPLICIT NONE +!------------------------------------------------------------------------- +! +! Objet : calcul de la temperature et l'humidite relative a 2m et du +! module du vent a 10m a partir des relations de Dyer-Businger et +! des equations de Louis. +! +! Reference : Hess, Colman et McAvaney (1995) +! +! I. Musat, 01.07.2002 +!------------------------------------------------------------------------- +! +! klon----input-I- dimension de la grille physique (= nb_pts_latitude X nb_pts_longitude) +! knon----input-I- nombre de points pour un type de surface +! nsrf----input-I- indice pour le type de surface; voir indicesol.inc +! zxli----input-L- TRUE si calcul des cdrags selon Laurent Li +! u1------input-R- vent zonal au 1er niveau du modele +! v1------input-R- vent meridien au 1er niveau du modele +! t1------input-R- temperature de l'air au 1er niveau du modele +! q1------input-R- humidite relative au 1er niveau du modele +! z1------input-R- geopotentiel au 1er niveau du modele +! ts1-----input-R- temperature de l'air a la surface +! qsurf---input-R- humidite relative a la surface +! rugos---input-R- rugosite +! psol----input-R- pression au sol +! pat1----input-R- pression au 1er niveau du modele +! +! t_2m---output-R- temperature de l'air a 2m +! q_2m---output-R- humidite relative a 2m +! u_10m--output-R- vitesse du vent a 10m +! + INTEGER, intent(in) :: klon, knon, nsrf + LOGICAL, intent(in) :: zxli + REAL, dimension(klon), intent(in) :: u1, v1, t1, q1, z1, ts1 + REAL, dimension(klon), intent(in) :: qsurf, rugos + REAL, dimension(klon), intent(in) :: psol, pat1 +! + REAL, dimension(klon), intent(out) :: t_2m, q_2m, u_10m +!------------------------------------------------------------------------- +#include "YOMCST.inc" +!IM PLUS +#include "YOETHF.inc" +! +! Quelques constantes et options: +! +! RKAR : constante de von Karman + REAL, PARAMETER :: RKAR=0.40 +! niter : nombre iterations calcul "corrector" + INTEGER, parameter :: niter=6, ncon=niter-1 +! +! Variables locales + INTEGER :: i, n + REAL :: zref + REAL, dimension(klon) :: speed +! tpot : temperature potentielle + REAL, dimension(klon) :: tpot + REAL, dimension(klon) :: zri1, cdran + REAL, dimension(klon) :: cdram, cdrah +! ri1 : nb. de Richardson entre la surface --> la 1ere couche + REAL, dimension(klon) :: ri1 + REAL, dimension(klon) :: ustar, testar, qstar + REAL, dimension(klon) :: zdte, zdq +! lmon : longueur de Monin-Obukhov selon Hess, Colman and McAvaney + DOUBLE PRECISION, dimension(klon) :: lmon + DOUBLE PRECISION, parameter :: eps=1.0D-20 + REAL, dimension(klon) :: delu, delte, delq + REAL, dimension(klon) :: u_zref, te_zref, q_zref + REAL, dimension(klon) :: temp, pref + LOGICAL :: okri + REAL, dimension(klon) :: u_zref_p, te_zref_p, temp_p, q_zref_p + REAL, dimension(klon) :: u_zref_c, te_zref_c, temp_c, q_zref_c + REAL, dimension(klon) :: ok_pred, ok_corr + REAL, dimension(klon) :: conv_te, conv_q +!------------------------------------------------------------------------- + DO i=1, knon + speed(i)=SQRT(u1(i)**2+v1(i)**2) + ri1(i) = 0.0 + ENDDO +! + okri=.FALSE. + CALL coefcdrag(klon, knon, nsrf, zxli, & + speed, t1, q1, z1, psol, & + ts1, qsurf, rugos, okri, ri1, & + cdram, cdrah, cdran, zri1, pref) +! +!---------Star variables---------------------------------------------------- +! + DO i = 1, knon + ri1(i) = zri1(i) + tpot(i) = t1(i)* (psol(i)/pat1(i))**RKAPPA + ustar(i) = sqrt(cdram(i) * speed(i) * speed(i)) + zdte(i) = tpot(i) - ts1(i) + zdq(i) = max(q1(i),0.0) - max(qsurf(i),0.0) +! + testar(i) = (cdrah(i) * zdte(i) * speed(i))/ustar(i) + qstar(i) = (cdrah(i) * zdq(i) * speed(i))/ustar(i) + lmon(i) = (ustar(i) * ustar(i) * tpot(i))/ & + (RKAR * RG * testar(i)) + ENDDO +! +!----------First aproximation of variables at zref -------------------------- + zref = 2.0 + CALL screenp(klon, knon, nsrf, speed, tpot, q1, & + ts1, qsurf, rugos, lmon, & + ustar, testar, qstar, zref, & + delu, delte, delq) +! + DO i = 1, knon + u_zref(i) = delu(i) + q_zref(i) = max(qsurf(i),0.0) + delq(i) + te_zref(i) = ts1(i) + delte(i) + temp(i) = te_zref(i) * (psol(i)/pat1(i))**(-RKAPPA) +! q_zref_p(i) = q_zref(i) +! te_zref_p(i) = te_zref(i) + temp_p(i) = temp(i) + ENDDO +! +! Iteration of the variables at the reference level zref : corrector calculation ; see Hess & McAvaney, 1995 +! + DO n = 1, niter +! + okri=.TRUE. + CALL screenc(klon, knon, nsrf, zxli, & + u_zref, temp, q_zref, zref, & + ts1, qsurf, rugos, psol, & + ustar, testar, qstar, okri, ri1, & + pref, delu, delte, delq) +! + DO i = 1, knon + u_zref(i) = delu(i) + q_zref(i) = delq(i) + max(qsurf(i),0.0) + te_zref(i) = delte(i) + ts1(i) +! +! return to normal temperature +! + temp(i) = te_zref(i) * (psol(i)/pref(i))**(-RKAPPA) +! temp(i) = te_zref(i) - (zref* RG)/RCPD/ & +! (1 + RVTMP2 * max(q_zref(i),0.0)) +! + IF(temp(i).GT.350.) THEN + WRITE(*,*) 'temp(i) GT 350 K !!',i,nsrf,temp(i) + ENDIF +! + IF(n.EQ.ncon) THEN + te_zref_p(i) = te_zref(i) + q_zref_p(i) = q_zref(i) + ENDIF +! + ENDDO +! + ENDDO +! +! verifier le critere de convergence : 0.25% pour te_zref et 5% pour qe_zref +! + DO i = 1, knon + conv_te(i) = (te_zref(i) - te_zref_p(i))/te_zref_p(i) + conv_q(i) = (q_zref(i) - q_zref_p(i))/q_zref_p(i) + IF(abs(conv_te(i)).GE.0.0025.AND.abs(conv_q(i)).GE.0.05) THEN + PRINT*,'DIV','i=',i,te_zref_p(i),te_zref(i),conv_te(i), & + q_zref_p(i),q_zref(i),conv_q(i) + ENDIF + ENDDO +! + DO i = 1, knon + q_zref_c(i) = q_zref(i) + temp_c(i) = temp(i) +! + IF(zri1(i).LT.0.) THEN + IF(nsrf.EQ.1) THEN + ok_pred(i)=1. + ok_corr(i)=0. + ELSE + ok_pred(i)=0. + ok_corr(i)=1. + ENDIF + ELSE + ok_pred(i)=0. + ok_corr(i)=1. + ENDIF +! + t_2m(i) = temp_p(i) * ok_pred(i) + temp_c(i) * ok_corr(i) + q_2m(i) = q_zref_p(i) * ok_pred(i) + q_zref_c(i) * ok_corr(i) + ENDDO +! +! +!----------First aproximation of variables at zref -------------------------- +! + zref = 10.0 + CALL screenp(klon, knon, nsrf, speed, tpot, q1, & + ts1, qsurf, rugos, lmon, & + ustar, testar, qstar, zref, & + delu, delte, delq) +! + DO i = 1, knon + u_zref(i) = delu(i) + q_zref(i) = max(qsurf(i),0.0) + delq(i) + te_zref(i) = ts1(i) + delte(i) + temp(i) = te_zref(i) * (psol(i)/pat1(i))**(-RKAPPA) +! temp(i) = te_zref(i) - (zref* RG)/RCPD/ & +! (1 + RVTMP2 * max(q_zref(i),0.0)) + u_zref_p(i) = u_zref(i) + ENDDO +! +! Iteration of the variables at the reference level zref : corrector ; see Hess & McAvaney, 1995 +! + DO n = 1, niter +! + okri=.TRUE. + CALL screenc(klon, knon, nsrf, zxli, & + u_zref, temp, q_zref, zref, & + ts1, qsurf, rugos, psol, & + ustar, testar, qstar, okri, ri1, & + pref, delu, delte, delq) +! + DO i = 1, knon + u_zref(i) = delu(i) + q_zref(i) = delq(i) + max(qsurf(i),0.0) + te_zref(i) = delte(i) + ts1(i) + temp(i) = te_zref(i) * (psol(i)/pref(i))**(-RKAPPA) +! temp(i) = te_zref(i) - (zref* RG)/RCPD/ & +! (1 + RVTMP2 * max(q_zref(i),0.0)) + ENDDO +! + ENDDO +! + DO i = 1, knon + u_zref_c(i) = u_zref(i) +! + u_10m(i) = u_zref_p(i) * ok_pred(i) + u_zref_c(i) * ok_corr(i) + ENDDO +! + RETURN + END subroutine stdlevvar Index: /LMDZ.3.3/branches/rel-LF/libf/phylmd/stdlevvar_int.F90 =================================================================== --- /LMDZ.3.3/branches/rel-LF/libf/phylmd/stdlevvar_int.F90 (revision 418) +++ /LMDZ.3.3/branches/rel-LF/libf/phylmd/stdlevvar_int.F90 (revision 418) @@ -0,0 +1,21 @@ +MODULE stdlevvar_int + + IMPLICIT NONE + + INTERFACE + + SUBROUTINE stdlevvar(klon, knon, nsrf, zxli, & + u1, v1, t1, q1, z1, & + ts1, qsurf, rugos, psol, pat1, & + t_2m, q_2m, u_10m) + INTEGER, intent(in) :: klon, knon, nsrf + LOGICAL, intent(in) :: zxli + REAL, dimension(klon), intent(in) :: u1, v1, t1, q1, z1, ts1 + REAL, dimension(klon), intent(in) :: qsurf, rugos + REAL, dimension(klon), intent(in) :: psol, pat1 + REAL, dimension(klon), intent(out) :: t_2m, q_2m, u_10m + END SUBROUTINE stdlevvar + + END INTERFACE + +END MODULE stdlevvar_int Index: /LMDZ.3.3/branches/rel-LF/libf/phylmd/write_histday.h =================================================================== --- /LMDZ.3.3/branches/rel-LF/libf/phylmd/write_histday.h (revision 418) +++ /LMDZ.3.3/branches/rel-LF/libf/phylmd/write_histday.h (revision 418) @@ -0,0 +1,406 @@ + IF (ok_journe) THEN +c + ndex2d = 0 + ndex3d = 0 +c +c Champs 2D: +c + zsto = dtime + zout = dtime * FLOAT(ecrit_day) + itau_w = itau_phy + itap + + i = NINT(zout/zsto) + CALL gr_fi_ecrit(1,klon,iim,jjmp1,pphis,zx_tmp_2d) + CALL histwrite(nid_day,"phis",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) + varname = 'phis' + vartitle= 'Surface geop. height' + varunits= '-' +c call writephy(fid_day,prof2d_on,varname,pphis,vartitle, +c . varunits) +c + i = NINT(zout/zsto) + CALL gr_fi_ecrit(1,klon,iim,jjmp1,paire,zx_tmp_2d) + CALL histwrite(nid_day,"aire",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) + varname = 'aire' + vartitle= 'Grid area' + varunits= '-' +c call writephy(fid_day,prof2d_on,varname,paire,vartitle, +c . varunits) +C + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxtsol,zx_tmp_2d) + CALL histwrite(nid_day,"tsol",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c call writephy(fid_day,prof2d_av,'tsol',zxtsol, +c . 'Surface Temperature','K') +c +C + zx_tmp_fi2d(1 : klon) = ftsol(1 : klon, is_ter) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d ,zx_tmp_2d) + CALL histwrite(nid_day,"tter",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c call writephy(fid_day,prof2d_av,'tter',ftsol(1 : klon, is_ter), +c . 'Surface Temperature','K') +C + zx_tmp_fi2d(1 : klon) = ftsol(1 : klon, is_lic) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_day,"tlic",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c call writephy(fid_day,prof2d_av,'tlic',ftsol(1 : klon, is_lic), +c . 'Surface Temperature','K') +C + zx_tmp_fi2d(1 : klon) = ftsol(1 : klon, is_oce) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_day,"toce",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c call writephy(fid_day,prof2d_av,'toce',ftsol(1 : klon, is_oce), +c . 'Surface Temperature','K') +C + zx_tmp_fi2d(1 : klon) = ftsol(1 : klon, is_sic) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_day,"tsic",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c call writephy(fid_day,prof2d_av,'tsic',ftsol(1 : klon, is_sic), +c . 'Surface Temperature','K') +C +cccIM + CALL gr_fi_ecrit(1,klon,iim,jjmp1,zt2m,zx_tmp_2d) + CALL histwrite(nid_day,"t2m",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1,klon,iim,jjmp1,zt2m,zx_tmp_2d) + CALL histwrite(nid_day,"t2m_min",itau_w,zx_tmp_2d, + . iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1,klon,iim,jjmp1,zt2m,zx_tmp_2d) + CALL histwrite(nid_day,"t2m_max",itau_w,zx_tmp_2d, + . iim*jjmp1,ndex2d) +c + zx_tmp_fi2d(1 : klon) = t2m(1 : klon, is_ter) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d) + CALL histwrite(nid_day,"t2mter",itau_w,zx_tmp_2d,iim*jjmp1, + . ndex2d) +c + zx_tmp_fi2d(1 : klon) = t2m(1 : klon, is_ter) + CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_day,"t2mter_min",itau_w,zx_tmp_2d, + . iim*jjmp1,ndex2d) +c + zx_tmp_fi2d(1 : klon) = t2m(1 : klon, is_ter) + CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_day,"t2mter_max",itau_w,zx_tmp_2d, + . iim*jjmp1,ndex2d) +c + zx_tmp_fi2d(1 : klon) = t2m(1 : klon, is_lic) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d) + CALL histwrite(nid_day,"t2mlic",itau_w,zx_tmp_2d,iim*jjmp1, + . ndex2d) +c + zx_tmp_fi2d(1 : klon) = t2m(1 : klon, is_oce) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d) + CALL histwrite(nid_day,"t2moce",itau_w,zx_tmp_2d,iim*jjmp1, + . ndex2d) +c + zx_tmp_fi2d(1 : klon) = t2m(1 : klon, is_sic) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d) + CALL histwrite(nid_day,"t2msic",itau_w,zx_tmp_2d,iim*jjmp1, + . ndex2d) +c + CALL gr_fi_ecrit(1,klon,iim,jjmp1,zq2m,zx_tmp_2d) + CALL histwrite(nid_day,"q2m",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1,klon,iim,jjmp1,zu10m,zx_tmp_2d) + CALL histwrite(nid_day,"u10m",itau_w,zx_tmp_2d,iim*jjmp1, + . ndex2d) +c + CALL gr_fi_ecrit(1,klon,iim,jjmp1,zv10m,zx_tmp_2d) + CALL histwrite(nid_day,"v10m",itau_w,zx_tmp_2d,iim*jjmp1, + . ndex2d) +c + zx_tmp_fi2d(1 : klon) = u10m(1 : klon, is_ter) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d) + CALL histwrite(nid_day,"u10mter",itau_w,zx_tmp_2d,iim*jjmp1, + . ndex2d) +c + zx_tmp_fi2d(1 : klon) = v10m(1 : klon, is_ter) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d) + CALL histwrite(nid_day,"v10mter",itau_w,zx_tmp_2d,iim*jjmp1, + . ndex2d) +c + zx_tmp_fi2d(1 : klon) = u10m(1 : klon, is_lic) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d) + CALL histwrite(nid_day,"u10mlic",itau_w,zx_tmp_2d,iim*jjmp1, + . ndex2d) +c + zx_tmp_fi2d(1 : klon) = v10m(1 : klon, is_lic) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d) + CALL histwrite(nid_day,"v10mlic",itau_w,zx_tmp_2d,iim*jjmp1, + . ndex2d) +c + zx_tmp_fi2d(1 : klon) = u10m(1 : klon, is_oce) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d) + CALL histwrite(nid_day,"u10moce",itau_w,zx_tmp_2d,iim*jjmp1, + . ndex2d) +c + zx_tmp_fi2d(1 : klon) = v10m(1 : klon, is_oce) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d) + CALL histwrite(nid_day,"v10moce",itau_w,zx_tmp_2d,iim*jjmp1, + . ndex2d) +c + zx_tmp_fi2d(1 : klon) = u10m(1 : klon, is_sic) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d) + CALL histwrite(nid_day,"u10msic",itau_w,zx_tmp_2d,iim*jjmp1, + . ndex2d) +C + zx_tmp_fi2d(1 : klon) = v10m(1 : klon, is_sic) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d) + CALL histwrite(nid_day,"v10msic",itau_w,zx_tmp_2d,iim*jjmp1, + . ndex2d) +C + DO i = 1, klon + zx_tmp_fi2d(i) = paprs(i,1) + ENDDO + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_day,"psol",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c Essai writephys + varname = 'psol' + vartitle= 'pression au sol' + varunits= 'hPa' +c call writephy(fid_day,prof2d_av,varname,zx_tmp_fi2d,vartitle, +c . varunits) +c + DO i = 1, klon + zx_tmp_fi2d(i) = (rain_fall(i) + snow_fall(i)) + ENDDO + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_day,"precip",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c call writephy(fid_day,prof2d_av,'rain',zx_tmp_fi2d, +c . 'Precipitation','mm/day') + + +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, snow_fall,zx_tmp_2d) + CALL histwrite(nid_day,"snow",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c call writephy(fid_day,prof2d_av,'snow',snow_fall, +c . 'Snow','mm/day') +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxsnow,zx_tmp_2d) + CALL histwrite(nid_day,"snow_mass",itau_w,zx_tmp_2d,iim*jjmp1, + . ndex2d) +c call writephy(fid_day,prof2d_av,'snow_mass',zxsnow, +c . 'Snow cover','mm') +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, evap,zx_tmp_2d) + CALL histwrite(nid_day,"evap",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c call writephy(fid_day,prof2d_av,'evap',evap, +c . 'Evaporation','mm/day') +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, topsw,zx_tmp_2d) + CALL histwrite(nid_day,"tops",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c call writephy(fid_day,prof2d_av,'tops',topsw, +c . 'Solar rad. at TOA','W/m2') +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, toplw,zx_tmp_2d) + CALL histwrite(nid_day,"topl",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c call writephy(fid_day,prof2d_av,'topl',toplw, +c . 'IR rad. at TOA','W/m2') +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, solsw,zx_tmp_2d) + CALL histwrite(nid_day,"sols",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c call writephy(fid_day,prof2d_av,'sols',solsw, +c . 'Solar rad. at surf.','W/m2') +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, sollw,zx_tmp_2d) + CALL histwrite(nid_day,"soll",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c call writephy(fid_day,prof2d_av,'soll',sollw, +c . 'IR rad. at surface','W/m2') +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, sollwdown,zx_tmp_2d) + CALL histwrite(nid_day,"solldown",itau_w,zx_tmp_2d,iim*jjmp1, + . ndex2d) +c call writephy(fid_day,prof2d_av,'solldown',sollwdown, +c . 'Down. IR rad. at surface','W/m2') +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, bils,zx_tmp_2d) + CALL histwrite(nid_day,"bils",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c call writephy(fid_day,prof2d_av,'bils',bils, +c . 'Surf. total heat flux','W/m2') +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, sens,zx_tmp_2d) + CALL histwrite(nid_day,"sens",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c call writephy(fid_day,prof2d_av,'sens',sens, +c . 'Sensible heat flux','W/m2') +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, fder,zx_tmp_2d) + CALL histwrite(nid_day,"fder",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c call writephy(fid_day,prof2d_av,'fder',fder, +c . 'Heat flux derivation','W/m2') +c +c + DO nsrf = 1, nbsrf +CXXX + zx_tmp_fi2d(1 : klon) = pctsrf( 1 : klon, nsrf) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d) + CALL histwrite(nid_day,"pourc_"//clnsurf(nsrf),itau_w, + $ zx_tmp_2d,iim*jjmp1,ndex2d) +c call writephy(fid_day,prof2d_av,'pourc_'//clnsurf(nsrf), +c . pctsrf( 1 : klon, nsrf), +c . 'Fraction'//clnsurf(nsrf),'-') +C + zx_tmp_fi2d(1 : klon) = ftsol( 1 : klon, nsrf) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d) + CALL histwrite(nid_day,"tsol_"//clnsurf(nsrf),itau_w, + $ zx_tmp_2d,iim*jjmp1,ndex2d) +c call writephy(fid_day,prof2d_av,'tsol_'//clnsurf(nsrf), +c . ftsol( 1 : klon, nsrf), +c . 'Surf. Temp'//clnsurf(nsrf),'K') +C + zx_tmp_fi2d(1 : klon) = fluxt( 1 : klon, 1, nsrf) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d) + CALL histwrite(nid_day,"sens_"//clnsurf(nsrf),itau_w, + $ zx_tmp_2d,iim*jjmp1,ndex2d) +c call writephy(fid_day,prof2d_av,'sens_'//clnsurf(nsrf), +c . fluxt( 1 : klon, 1, nsrf), +c . 'Sensible heat flux '//clnsurf(nsrf),'W/m2') +C + zx_tmp_fi2d(1 : klon) = fluxlat( 1 : klon, nsrf) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d) + CALL histwrite(nid_day,"lat_"//clnsurf(nsrf),itau_w, + $ zx_tmp_2d,iim*jjmp1,ndex2d) +c call writephy(fid_day,prof2d_av,'lat_'//clnsurf(nsrf), +c . fluxlat( 1 : klon, nsrf), +c . 'Latent heat flux '//clnsurf(nsrf),'W/m2') +C + zx_tmp_fi2d(1 : klon) = fluxu( 1 : klon, 1, nsrf) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d) + CALL histwrite(nid_day,"taux_"//clnsurf(nsrf),itau_w, + $ zx_tmp_2d,iim*jjmp1,ndex2d) +c call writephy(fid_day,prof2d_av,'taux_'//clnsurf(nsrf), +c . fluxu( 1 : klon, 1, nsrf), +c . 'Zonal wind stress '//clnsurf(nsrf),'Pa') +C + zx_tmp_fi2d(1 : klon) = fluxv( 1 : klon, 1, nsrf) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d) + CALL histwrite(nid_day,"tauy_"//clnsurf(nsrf),itau_w, + $ zx_tmp_2d,iim*jjmp1,ndex2d) +c call writephy(fid_day,prof2d_av,'tauy_'//clnsurf(nsrf), +c . fluxv( 1 : klon, 1, nsrf), +c . 'Meridional wind stress '//clnsurf(nsrf),'Pa') +C + zx_tmp_fi2d(1 : klon) = falbe( 1 : klon, nsrf) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d) + CALL histwrite(nid_day,"albe_"//clnsurf(nsrf),itau_w, + $ zx_tmp_2d,iim*jjmp1,ndex2d) +c call writephy(fid_day,prof2d_av,'albe_'//clnsurf(nsrf), +c . falbe( 1 : klon, nsrf), +c . 'Albedo surf. SW'//clnsurf(nsrf),'-') +c call writephy(fid_day,prof2d_av,'alblw_'//clnsurf(nsrf), +c . falblw( 1 : klon, nsrf), +c . 'Albedo surf. LW'//clnsurf(nsrf),'-') +C + zx_tmp_fi2d(1 : klon) = frugs( 1 : klon, nsrf) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d) + CALL histwrite(nid_day,"rugs_"//clnsurf(nsrf),itau_w, + $ zx_tmp_2d,iim*jjmp1,ndex2d) +c call writephy(fid_day,prof2d_av,'rugs_'//clnsurf(nsrf), +c . frugs( 1 : klon, nsrf), +c . 'Rugosity '//clnsurf(nsrf),' - ') +C + END DO +C +cXXX DO i = 1, klon +cXXX zx_tmp_fi2d(i) = pctsrf(i,is_sic) +cXXX ENDDO +cXXX CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d) +cXXX CALL histwrite(nid_day,"sicf",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldl,zx_tmp_2d) + CALL histwrite(nid_day,"cldl",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c call writephy(fid_day,prof2d_av,'cldl',cldl, +c . 'Low-level cloudiness','-') +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldm,zx_tmp_2d) + CALL histwrite(nid_day,"cldm",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c call writephy(fid_day,prof2d_av,'cldm',cldm, +c . 'Mid-level cloudiness','-') +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldh,zx_tmp_2d) + CALL histwrite(nid_day,"cldh",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c call writephy(fid_day,prof2d_av,'cldh',cldh, +c . 'High-level cloudiness','-') +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldt,zx_tmp_2d) + CALL histwrite(nid_day,"cldt",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c call writephy(fid_day,prof2d_av,'cldt',cldt, +c . 'Total cloudiness','-') +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldq,zx_tmp_2d) + CALL histwrite(nid_day,"cldq",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c call writephy(fid_day,prof2d_av,'cldq',cldq, +c . 'Cloud liquid water path','-') +c +c Champs 3D: +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, t_seri, zx_tmp_3d) + CALL histwrite(nid_day,"temp",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c Essai writephys + varname = 'temp' + vartitle= 'temperature 3D' + varunits= 'K' +c call writephy(fid_day,prof3d_av,varname,t_seri,vartitle,varunits) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, qx(1,1,ivap), zx_tmp_3d) + CALL histwrite(nid_day,"ovap",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c call writephy(fid_day,prof3d_av,'ovap',qx(1,1,ivap), +c . 'Specific humidity','Kg/Kg') +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, zphi, zx_tmp_3d) + CALL histwrite(nid_day,"geop",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c call writephy(fid_day,prof3d_av,'geop',zphi, +c . 'Geopotential height','m') +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, u_seri, zx_tmp_3d) + CALL histwrite(nid_day,"vitu",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c call writephy(fid_day,prof3d_av,'vitu',u_seri, +c . 'Zonal wind','m/s') +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, v_seri, zx_tmp_3d) + CALL histwrite(nid_day,"vitv",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c call writephy(fid_day,prof3d_av,'vitv',v_seri, +c . 'Meridional wind','m/s') +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, omega, zx_tmp_3d) + CALL histwrite(nid_day,"vitw",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c call writephy(fid_day,prof3d_av,'vitw',omega, +c . 'Vertical wind','m/s') +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, pplay, zx_tmp_3d) + CALL histwrite(nid_day,"pres",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c call writephy(fid_day,prof3d_av,'pres',pplay, +c . 'Air pressure','Pa') +cccIM + zx_tmp_fi2d(1 : klon) = ZFSUP( 1 : klon, klevp1) + CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_day, "SWupTOA",itau_w,zx_tmp_2d, + . iim*jjmp1,ndex2d) +c + zx_tmp_fi2d(1 : klon) = ZFSUP( 1 : klon, 1) + CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_day, "SWupSFC",itau_w,zx_tmp_2d, + . iim*jjmp1,ndex2d) +c + zx_tmp_fi2d(1 : klon) = ZFSDN( 1 : klon, klevp1) + CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_day, "SWdnTOA",itau_w,zx_tmp_2d, + . iim*jjmp1,ndex2d) +c + zx_tmp_fi2d(1 : klon) = ZFSDN( 1 : klon, 1) + CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_day, "SWdnSFC",itau_w,zx_tmp_2d, + . iim*jjmp1,ndex2d) +c + if (ok_sync) then +c call writephy_sync(fid_day) + call histsync(nid_day) + endif + ENDIF Index: /LMDZ.3.3/branches/rel-LF/libf/phylmd/write_histhf.h =================================================================== --- /LMDZ.3.3/branches/rel-LF/libf/phylmd/write_histhf.h (revision 418) +++ /LMDZ.3.3/branches/rel-LF/libf/phylmd/write_histhf.h (revision 418) @@ -0,0 +1,58 @@ + if (ok_hf) then + +c Comprendre comment marche el i=nint(zout/zsto) +c + print*,'ACRITURE HF !!! ACRITURE HF !!! ACRITURE HF !!! ' + ndex2d = 0 + ndex3d = 0 +c +c +c i = NINT(zout/zsto) +c CALL gr_fi_ecrit(1,klon,iim,jjmp1,pphis,zx_tmp_2d) +c CALL histwrite(nid_hf,"phis",i,zx_tmp_2d,iim*jjmp1,ndex2d) +c +c i = NINT(zout/zsto) +c CALL gr_fi_ecrit(1,klon,iim,jjmp1,paire,zx_tmp_2d) +c CALL histwrite(nid_hf,"aire",i,zx_tmp_2d,iim*jjmp1,ndex2d) +C + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxtsol,zx_tmp_2d) + CALL histwrite(nid_hf,"tsol",itap,zx_tmp_2d,iim*jjmp1,ndex2d) +c + DO i = 1, klon + zx_tmp_fi2d(i) = paprs(i,1) + ENDDO + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_hf,"psol",itap,zx_tmp_2d,iim*jjmp1,ndex2d) +c + DO i = 1, klon + zx_tmp_fi2d(i) = rain_fall(i) + snow_fall(i) + ENDDO + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_hf,"rain",itap,zx_tmp_2d,iim*jjmp1,ndex2d) + + CALL gr_fi_ecrit(1, klon,iim,jjmp1, u850,zx_tmp_2d) + CALL histwrite(nid_hf,"u850",itap,zx_tmp_2d,iim*jjmp1,ndex2d) + + CALL gr_fi_ecrit(1, klon,iim,jjmp1, v850,zx_tmp_2d) + CALL histwrite(nid_hf,"v850",itap,zx_tmp_2d,iim*jjmp1,ndex2d) + + CALL gr_fi_ecrit(1, klon,iim,jjmp1, u500,zx_tmp_2d) + CALL histwrite(nid_hf,"u500",itap,zx_tmp_2d,iim*jjmp1,ndex2d) + + CALL gr_fi_ecrit(1, klon,iim,jjmp1, v500,zx_tmp_2d) + CALL histwrite(nid_hf,"v500",itap,zx_tmp_2d,iim*jjmp1,ndex2d) + + CALL gr_fi_ecrit(1, klon,iim,jjmp1, u200,zx_tmp_2d) + CALL histwrite(nid_hf,"u200",itap,zx_tmp_2d,iim*jjmp1,ndex2d) + + CALL gr_fi_ecrit(1, klon,iim,jjmp1, v200,zx_tmp_2d) + CALL histwrite(nid_hf,"v200",itap,zx_tmp_2d,iim*jjmp1,ndex2d) + + CALL gr_fi_ecrit(1, klon,iim,jjmp1, phi500,zx_tmp_2d) + CALL histwrite(nid_hf,"phi500",itap,zx_tmp_2d,iim*jjmp1,ndex2d) + + if (ok_sync) then + call histsync(nid_hf) + endif + + endif Index: /LMDZ.3.3/branches/rel-LF/libf/phylmd/write_histins.h =================================================================== --- /LMDZ.3.3/branches/rel-LF/libf/phylmd/write_histins.h (revision 418) +++ /LMDZ.3.3/branches/rel-LF/libf/phylmd/write_histins.h (revision 418) @@ -0,0 +1,198 @@ + IF (ok_instan) THEN +c + ndex2d = 0 + ndex3d = 0 +c +c Champs 2D: +c + zsto = dtime * ecrit_ins + zout = dtime * ecrit_ins + itau_w = itau_phy + itap + + i = NINT(zout/zsto) + CALL gr_fi_ecrit(1,klon,iim,jjmp1,pphis,zx_tmp_2d) + CALL histwrite(nid_ins,"phis",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + i = NINT(zout/zsto) + CALL gr_fi_ecrit(1,klon,iim,jjmp1,paire,zx_tmp_2d) + CALL histwrite(nid_ins,"aire",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) + + DO i = 1, klon + zx_tmp_fi2d(i) = paprs(i,1) + ENDDO + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_ins,"psol",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + DO i = 1, klon + zx_tmp_fi2d(i) = rain_fall(i) + snow_fall(i) + ENDDO + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_ins,"precip",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + DO i = 1, klon + zx_tmp_fi2d(i) = rain_lsc(i) + snow_lsc(i) + ENDDO + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_ins,"plul",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + DO i = 1, klon + zx_tmp_fi2d(i) = rain_con(i) + snow_con(i) + ENDDO + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_ins,"pluc",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) + + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxtsol,zx_tmp_2d) + CALL histwrite(nid_ins,"tsol",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +cccIM + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zt2m, zx_tmp_2d) + CALL histwrite(nid_ins,"t2m",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zq2m, zx_tmp_2d) + CALL histwrite(nid_ins,"q2m",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zu10m, zx_tmp_2d) + CALL histwrite(nid_ins,"u10m",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +C + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zv10m, zx_tmp_2d) + CALL histwrite(nid_ins,"v10m",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, snow_fall,zx_tmp_2d) + CALL histwrite(nid_ins,"snow",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) + + CALL gr_fi_ecrit(1, klon,iim,jjmp1, cdragm,zx_tmp_2d) + CALL histwrite(nid_ins,"cdrm",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, cdragh,zx_tmp_2d) + CALL histwrite(nid_ins,"cdrh",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, toplw,zx_tmp_2d) + CALL histwrite(nid_ins,"topl",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, evap,zx_tmp_2d) + CALL histwrite(nid_ins,"evap",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, solsw,zx_tmp_2d) + CALL histwrite(nid_ins,"sols",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, sollw,zx_tmp_2d) + CALL histwrite(nid_ins,"soll",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, sollwdown,zx_tmp_2d) + CALL histwrite(nid_ins,"solldown",itau_w,zx_tmp_2d,iim*jjmp1, + . ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, bils,zx_tmp_2d) + CALL histwrite(nid_ins,"bils",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, sens,zx_tmp_2d) + CALL histwrite(nid_ins,"sens",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, fder,zx_tmp_2d) + CALL histwrite(nid_ins,"fder",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, d_ts(1,is_oce),zx_tmp_2d) + CALL histwrite(nid_ins,"dtsvdfo",itau_w,zx_tmp_2d,iim*jjmp1, + . ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, d_ts(1,is_ter),zx_tmp_2d) + CALL histwrite(nid_ins,"dtsvdft",itau_w,zx_tmp_2d,iim*jjmp1, + . ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, d_ts(1,is_lic),zx_tmp_2d) + CALL histwrite(nid_ins,"dtsvdfg",itau_w,zx_tmp_2d,iim*jjmp1, + . ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, d_ts(1,is_sic),zx_tmp_2d) + CALL histwrite(nid_ins,"dtsvdfi",itau_w,zx_tmp_2d,iim*jjmp1, + . ndex2d) + + DO nsrf = 1, nbsrf +CXXX + zx_tmp_fi2d(1 : klon) = pctsrf( 1 : klon, nsrf) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d) + CALL histwrite(nid_ins,"pourc_"//clnsurf(nsrf),itau_w, + $ zx_tmp_2d,iim*jjmp1,ndex2d) +C + zx_tmp_fi2d(1 : klon) = fluxt( 1 : klon, 1, nsrf) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d) + CALL histwrite(nid_ins,"sens_"//clnsurf(nsrf),itau_w, + $ zx_tmp_2d,iim*jjmp1,ndex2d) +C + zx_tmp_fi2d(1 : klon) = fluxlat( 1 : klon, nsrf) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d) + CALL histwrite(nid_ins,"lat_"//clnsurf(nsrf),itau_w, + $ zx_tmp_2d,iim*jjmp1,ndex2d) +C + zx_tmp_fi2d(1 : klon) = ftsol( 1 : klon, nsrf) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d) + CALL histwrite(nid_ins,"tsol_"//clnsurf(nsrf),itau_w, + $ zx_tmp_2d,iim*jjmp1,ndex2d) +C + zx_tmp_fi2d(1 : klon) = fluxu( 1 : klon, 1, nsrf) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d) + CALL histwrite(nid_ins,"taux_"//clnsurf(nsrf),itau_w, + $ zx_tmp_2d,iim*jjmp1,ndex2d) +C + zx_tmp_fi2d(1 : klon) = fluxv( 1 : klon, 1, nsrf) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d) + CALL histwrite(nid_ins,"tauy_"//clnsurf(nsrf),itau_w, + $ zx_tmp_2d,iim*jjmp1,ndex2d) +C + zx_tmp_fi2d(1 : klon) = frugs( 1 : klon, nsrf) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d) + CALL histwrite(nid_ins,"rugs_"//clnsurf(nsrf),itau_w, + $ zx_tmp_2d,iim*jjmp1,ndex2d) +C + zx_tmp_fi2d(1 : klon) = falbe( 1 : klon, nsrf) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d) + CALL histwrite(nid_ins,"albe_"//clnsurf(nsrf),itau_w, + $ zx_tmp_2d,iim*jjmp1,ndex2d) +C + END DO + CALL gr_fi_ecrit(1, klon,iim,jjmp1, albsol,zx_tmp_2d) + CALL histwrite(nid_ins,"albs",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, albsollw,zx_tmp_2d) + CALL histwrite(nid_ins,"albslw",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxsnow,zx_tmp_2d) + CALL histwrite(nid_ins,"snow_mass",itau_w,zx_tmp_2d,iim*jjmp1, + . ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxrugs,zx_tmp_2d) + CALL histwrite(nid_ins,"rugs",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c +c Champs 3D: +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, t_seri, zx_tmp_3d) + CALL histwrite(nid_ins,"temp",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, u_seri, zx_tmp_3d) + CALL histwrite(nid_ins,"vitu",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, v_seri, zx_tmp_3d) + CALL histwrite(nid_ins,"vitv",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, zphi, zx_tmp_3d) + CALL histwrite(nid_ins,"geop",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, pplay, zx_tmp_3d) + CALL histwrite(nid_ins,"pres",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_vdf, zx_tmp_3d) + CALL histwrite(nid_ins,"dtvdf",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_vdf, zx_tmp_3d) + CALL histwrite(nid_ins,"dqvdf",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) + +c + if (ok_sync) then + call histsync(nid_ins) + endif + ENDIF Index: /LMDZ.3.3/branches/rel-LF/libf/phylmd/write_histmth.h =================================================================== --- /LMDZ.3.3/branches/rel-LF/libf/phylmd/write_histmth.h (revision 418) +++ /LMDZ.3.3/branches/rel-LF/libf/phylmd/write_histmth.h (revision 418) @@ -0,0 +1,450 @@ + IF (ok_mensuel) THEN +c + ndex2d = 0 + ndex3d = 0 +c +c Champs 2D: +c + zsto = dtime + zout = dtime * ecrit_mth + itau_w = itau_phy + itap + + i = NINT(zout/zsto) + CALL gr_fi_ecrit(1,klon,iim,jjmp1,pphis,zx_tmp_2d) + CALL histwrite(nid_mth,"phis",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +C + i = NINT(zout/zsto) + CALL gr_fi_ecrit(1,klon,iim,jjmp1,paire,zx_tmp_2d) + CALL histwrite(nid_mth,"aire",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) + + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxtsol,zx_tmp_2d) + CALL histwrite(nid_mth,"tsol",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c +cccIM + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zt2m,zx_tmp_2d) + CALL histwrite(nid_mth,"t2m",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zq2m,zx_tmp_2d) + CALL histwrite(nid_mth,"q2m",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zu10m,zx_tmp_2d) + CALL histwrite(nid_mth,"u10m",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +C + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zv10m,zx_tmp_2d) + CALL histwrite(nid_mth,"v10m",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +C + DO i = 1, klon + zx_tmp_fi2d(i) = paprs(i,1) + ENDDO + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_mth,"psol",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxqsol,zx_tmp_2d) + CALL histwrite(nid_mth,"qsol",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + DO i = 1, klon + zx_tmp_fi2d(i) = rain_fall(i) + snow_fall(i) + ENDDO + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_mth,"precip",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + DO i = 1, klon + zx_tmp_fi2d(i) = rain_lsc(i) + snow_lsc(i) + ENDDO + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_mth,"plul",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + DO i = 1, klon + zx_tmp_fi2d(i) = rain_con(i) + snow_con(i) + ENDDO + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_mth,"pluc",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, snow_fall,zx_tmp_2d) + CALL histwrite(nid_mth,"snow",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxsnow,zx_tmp_2d) + CALL histwrite(nid_mth,"snow_mass",itau_w,zx_tmp_2d,iim*jjmp1, + . ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, evap,zx_tmp_2d) + CALL histwrite(nid_mth,"evap",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, topsw,zx_tmp_2d) + CALL histwrite(nid_mth,"tops",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, toplw,zx_tmp_2d) + CALL histwrite(nid_mth,"topl",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, solsw,zx_tmp_2d) + CALL histwrite(nid_mth,"sols",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, sollw,zx_tmp_2d) + CALL histwrite(nid_mth,"soll",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, sollwdown,zx_tmp_2d) + CALL histwrite(nid_mth,"solldown",itau_w,zx_tmp_2d,iim*jjmp1, + . ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, topsw0,zx_tmp_2d) + CALL histwrite(nid_mth,"tops0",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, toplw0,zx_tmp_2d) + CALL histwrite(nid_mth,"topl0",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, solsw0,zx_tmp_2d) + CALL histwrite(nid_mth,"sols0",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, sollw0,zx_tmp_2d) + CALL histwrite(nid_mth,"soll0",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, bils,zx_tmp_2d) + CALL histwrite(nid_mth,"bils",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, sens,zx_tmp_2d) + CALL histwrite(nid_mth,"sens",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, fder,zx_tmp_2d) + CALL histwrite(nid_mth,"fder",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c +c +c DO i = 1, klon +c zx_tmp_fi2d(i) = fluxu(i,1) +c ENDDO +c CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d) +c CALL histwrite(nid_mth,"frtu",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c +c DO i = 1, klon +c zx_tmp_fi2d(i) = fluxv(i,1) +c ENDDO +c CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d) +c CALL histwrite(nid_mth,"frtv",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + DO nsrf = 1, nbsrf +CYYY + zx_tmp_fi2d(1 : klon) = pctsrf( 1 : klon, nsrf) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d) + CALL histwrite(nid_mth,"pourc_"//clnsurf(nsrf),itau_w, + $ zx_tmp_2d,iim*jjmp1,ndex2d) +C + zx_tmp_fi2d(1 : klon) = ftsol( 1 : klon, nsrf) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d) + CALL histwrite(nid_mth,"tsol_"//clnsurf(nsrf),itau_w, + $ zx_tmp_2d,iim*jjmp1,ndex2d) +C + zx_tmp_fi2d(1 : klon) = fluxt( 1 : klon, 1, nsrf) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d) + CALL histwrite(nid_mth,"sens_"//clnsurf(nsrf),itau_w, + $ zx_tmp_2d,iim*jjmp1,ndex2d) +C + zx_tmp_fi2d(1 : klon) = fluxlat( 1 : klon, nsrf) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d) + CALL histwrite(nid_mth,"lat_"//clnsurf(nsrf),itau_w, + $ zx_tmp_2d,iim*jjmp1,ndex2d) +C + zx_tmp_fi2d(1 : klon) = fluxu( 1 : klon, 1, nsrf) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d) + CALL histwrite(nid_mth,"taux_"//clnsurf(nsrf),itau_w, + $ zx_tmp_2d,iim*jjmp1,ndex2d) +C + zx_tmp_fi2d(1 : klon) = fluxv( 1 : klon, 1, nsrf) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d) + CALL histwrite(nid_mth,"tauy_"//clnsurf(nsrf),itau_w, + $ zx_tmp_2d,iim*jjmp1,ndex2d) +C + zx_tmp_fi2d(1 : klon) = falbe( 1 : klon, nsrf) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d) + CALL histwrite(nid_mth,"albe_"//clnsurf(nsrf),itau_w, + $ zx_tmp_2d,iim*jjmp1,ndex2d) +C + zx_tmp_fi2d(1 : klon) = frugs( 1 : klon, nsrf) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d) + CALL histwrite(nid_mth,"rugs_"//clnsurf(nsrf),itau_w, + $ zx_tmp_2d,iim*jjmp1,ndex2d) +c + zx_tmp_fi2d(1 : klon) = agesno( 1 : klon, nsrf) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, agesno,zx_tmp_2d) + CALL histwrite(nid_mth,"ages_"//clnsurf(nsrf),itau_w + $ ,zx_tmp_2d,iim*jjmp1,ndex2d) + + END DO +cXXX DO i = 1, klon +cXXX zx_tmp_fi2d(i) = pctsrf(i,is_sic) +cXXX ENDDO +cXXX CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d) +cXXX CALL histwrite(nid_mth,"sicf",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, albsol,zx_tmp_2d) + CALL histwrite(nid_mth,"albs",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) + CALL gr_fi_ecrit(1, klon,iim,jjmp1, albsollw,zx_tmp_2d) + CALL histwrite(nid_mth,"albslw",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, cdragm,zx_tmp_2d) + CALL histwrite(nid_mth,"cdrm",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, cdragh,zx_tmp_2d) + CALL histwrite(nid_mth,"cdrh",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldl,zx_tmp_2d) + CALL histwrite(nid_mth,"cldl",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldm,zx_tmp_2d) + CALL histwrite(nid_mth,"cldm",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldh,zx_tmp_2d) + CALL histwrite(nid_mth,"cldh",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldt,zx_tmp_2d) + CALL histwrite(nid_mth,"cldt",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldq,zx_tmp_2d) + CALL histwrite(nid_mth,"cldq",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, ue,zx_tmp_2d) + CALL histwrite(nid_mth,"ue",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, ve,zx_tmp_2d) + CALL histwrite(nid_mth,"ve",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, uq,zx_tmp_2d) + CALL histwrite(nid_mth,"uq",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, vq,zx_tmp_2d) + CALL histwrite(nid_mth,"vq",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +cKE43 + IF (iflag_con .GE. 3) THEN ! sb +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, cape,zx_tmp_2d) + CALL histwrite(nid_mth,"cape",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1,pbase,zx_tmp_2d) + CALL histwrite(nid_mth,"pbase",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1,ema_pct,zx_tmp_2d) + CALL histwrite(nid_mth,"ptop",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1,ema_cbmf,zx_tmp_2d) + CALL histwrite(nid_mth,"fbase",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c +c + ENDIF +c34EK +c +c Champs 3D: +C + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, t_seri, zx_tmp_3d) + CALL histwrite(nid_mth,"temp",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, qx(1,1,ivap), zx_tmp_3d) + CALL histwrite(nid_mth,"ovap",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, zphi, zx_tmp_3d) + CALL histwrite(nid_mth,"geop",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, u_seri, zx_tmp_3d) + CALL histwrite(nid_mth,"vitu",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, v_seri, zx_tmp_3d) + CALL histwrite(nid_mth,"vitv",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, omega, zx_tmp_3d) + CALL histwrite(nid_mth,"vitw",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, pplay, zx_tmp_3d) + CALL histwrite(nid_mth,"pres",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, cldfra, zx_tmp_3d) + CALL histwrite(nid_mth,"rneb",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, zx_rh, zx_tmp_3d) + CALL histwrite(nid_mth,"rhum",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, cldliq, zx_tmp_3d) + CALL histwrite(nid_mth,"oliq",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, clwcon0, zx_tmp_3d) + CALL histwrite(nid_mth,"clwcon",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_dyn, zx_tmp_3d) + CALL histwrite(nid_mth,"dtdyn",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_dyn, zx_tmp_3d) + CALL histwrite(nid_mth,"dqdyn",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_con, zx_tmp_3d) + CALL histwrite(nid_mth,"dtcon",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_con, zx_tmp_3d) + CALL histwrite(nid_mth,"dqcon",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_lsc, zx_tmp_3d) + CALL histwrite(nid_mth,"dtlsc",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_lsc, zx_tmp_3d) + CALL histwrite(nid_mth,"dqlsc",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_vdf, zx_tmp_3d) + CALL histwrite(nid_mth,"dtvdf",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_vdf, zx_tmp_3d) + CALL histwrite(nid_mth,"dqvdf",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_eva, zx_tmp_3d) + CALL histwrite(nid_mth,"dteva",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_eva, zx_tmp_3d) + CALL histwrite(nid_mth,"dqeva",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + zpt_conv = 0. + where (ptconv) zpt_conv = 1. + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, zpt_conv, zx_tmp_3d) + CALL histwrite(nid_mth,"ptconv",itau_w,zx_tmp_3d, + . iim*(jjmp1)*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, ratqs, zx_tmp_3d) + CALL histwrite(nid_mth,"ratqs",itau_w,zx_tmp_3d, + . iim*(jjmp1)*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_ajs, zx_tmp_3d) + CALL histwrite(nid_mth,"dtajs",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_ajs, zx_tmp_3d) + CALL histwrite(nid_mth,"dqajs",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, heat, zx_tmp_3d) + CALL histwrite(nid_mth,"dtswr",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, heat0, zx_tmp_3d) + CALL histwrite(nid_mth,"dtsw0",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, cool, zx_tmp_3d) + CALL histwrite(nid_mth,"dtlwr",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, cool0, zx_tmp_3d) + CALL histwrite(nid_mth,"dtlw0",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_ec, zx_tmp_3d) + CALL histwrite(nid_mth,"dtec",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_u_vdf, zx_tmp_3d) + CALL histwrite(nid_mth,"duvdf",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_v_vdf, zx_tmp_3d) + CALL histwrite(nid_mth,"dvvdf",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + IF (ok_orodr) THEN + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_u_oro, zx_tmp_3d) + CALL histwrite(nid_mth,"duoro",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_v_oro, zx_tmp_3d) + CALL histwrite(nid_mth,"dvoro",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + ENDIF +C + IF (ok_orolf) THEN + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_u_lif, zx_tmp_3d) + CALL histwrite(nid_mth,"dulif",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_v_lif, zx_tmp_3d) + CALL histwrite(nid_mth,"dvlif",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) + ENDIF +C + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, wo, zx_tmp_3d) + CALL histwrite(nid_mth,"ozone",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + IF (nqmax.GE.3) THEN + DO iq=1,nqmax-2 + IF (iq.LE.99) THEN + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, qx(1,1,iq+2), zx_tmp_3d) + WRITE(str2,'(i2.2)') iq + CALL histwrite(nid_mth,"trac"//str2,itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) + ELSE + PRINT*, "Trop de traceurs" + CALL abort + ENDIF + ENDDO + ENDIF +cKE43 + IF (iflag_con.GE.3) THEN ! (sb) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, upwd, zx_tmp_3d) + CALL histwrite(nid_mth,"upwd",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, dnwd, zx_tmp_3d) + CALL histwrite(nid_mth,"dnwd",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, dnwd0, zx_tmp_3d) + CALL histwrite(nid_mth,"dnwd0",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c + CALL gr_fi_ecrit(klev,klon,iim,jjmp1, Ma, zx_tmp_3d) + CALL histwrite(nid_mth,"Ma",itau_w,zx_tmp_3d, + . iim*jjmp1*klev,ndex3d) +c +cccIM + zx_tmp_fi2d(1 : klon) = ZFSUP( 1 : klon, klevp1) + CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_mth, "SWupTOA",itau_w,zx_tmp_2d, + . iim*jjmp1,ndex2d) +c + zx_tmp_fi2d(1 : klon) = ZFSUP( 1 : klon, 1) + CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_mth, "SWupSFC",itau_w,zx_tmp_2d, + . iim*jjmp1,ndex2d) +c + zx_tmp_fi2d(1 : klon) = ZFSDN( 1 : klon, klevp1) + CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_mth, "SWdnTOA",itau_w,zx_tmp_2d, + . iim*jjmp1,ndex2d) +c + zx_tmp_fi2d(1 : klon) = ZFSDN( 1 : klon, 1) + CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_mth, "SWdnSFC",itau_w,zx_tmp_2d, + . iim*jjmp1,ndex2d) +c + + ENDIF + + if (ok_sync) then + call histsync(nid_mth) + endif + ENDIF +