SUBROUTINE CALWAKE(paprs,pplay,dtime : ,t,q,omgb : ,dt_dwn,dq_dwn,M_dwn,M_up : ,dt_a,dq_a,sigd : ,wdt_PBL,wdq_PBL : ,udt_PBL,udq_PBL o ,wake_deltat,wake_deltaq,wake_dth o ,wake_h,wake_s,wake_dens o ,wake_pe,wake_fip,wake_gfl o ,dt_wake,dq_wake o ,wake_k o ,undi_t,undi_q o ,wake_omgbdth,wake_dp_omgb o ,wake_dtKE,wake_dqKE o ,wake_dtPBL,wake_dqPBL o ,wake_omg,wake_dp_deltomg o ,wake_spread,wake_Cstar,wake_d_deltat_gw o ,wake_ddeltat,wake_ddeltaq) *************************************************************** * * * CALWAKE * * interface avec le schema de calcul de la poche * * froide * * * * written by : CHERUY Frederique, 13/03/2000, 10.31.05 * * modified by : ROEHRIG Romain, 01/30/2007 * *************************************************************** * USE dimphy IMPLICIT none c====================================================================== #include "dimensions.h" cccc#include "dimphy.h" #include "YOMCST.h" c Arguments c---------- INTEGER i,l,ktopw REAL dtime REAL paprs(klon,klev+1),pplay(klon,klev) REAL t(klon,klev), q(klon,klev), omgb(klon,klev) REAL dt_dwn(klon,klev), dq_dwn(klon,klev),M_dwn(klon,klev) REAL M_up(klon,klev) REAL dt_a(klon,klev), dq_a(klon,klev) REAL wdt_PBL(klon,klev), wdq_PBL(klon,klev) REAL udt_PBL(klon,klev), udq_PBL(klon,klev) REAL wake_deltat(klon,klev),wake_deltaq(klon,klev) REAL dt_wake(klon,klev),dq_wake(klon,klev) REAL wake_d_deltat_gw(klon,klev) REAL wake_h(klon),wake_s(klon) REAL wake_dth(klon,klev) REAL wake_pe(klon),wake_fip(klon),wake_gfl(klon) REAL undi_t(klon,klev),undi_q(klon,klev) REAL wake_omgbdth(klon,klev),wake_dp_omgb(klon,klev) REAL wake_dtKE(klon,klev),wake_dqKE(klon,klev) REAL wake_dtPBL(klon,klev),wake_dqPBL(klon,klev) REAL wake_omg(klon,klev+1),wake_dp_deltomg(klon,klev) REAL wake_spread(klon,klev),wake_Cstar(klon) REAL wake_ddeltat(klon,klev),wake_ddeltaq(klon,klev) REAL d_deltatw(klev), d_deltaqw(klev) INTEGER wake_k(klon) REAL sigd(klon) REAL wake_dens(klon) C Variable internes C ----------------- REAL aire REAL p(klev),ph(klev+1),pi(klev) REAL te(klev),qe(klev),omgbe(klev),dtdwn(klev),dqdwn(klev) REAL dta(klev),dqa(klev) REAL wdtPBL(klev),wdqPBL(klev) REAL udtPBL(klev),udqPBL(klev) REAL amdwn(klev),amup(klev) REAL dtw(klev),dqw(klev),dth(klev),d_deltat_gw(klev) REAL dtls(klev),dqls(klev) REAL tu(klev),qu(klev) REAL hw,sigmaw,wape,fip,gfl REAL omgbdth(klev),dp_omgb(klev) REAL dtKE(klev),dqKE(klev) REAL dtPBL(klev),dqPBL(klev) REAL omg(klev+1),dp_deltomg(klev),spread(klev),Cstar REAL sigd0,wdens REAL RDCP c print *, '-> calwake, wake_s ', wake_s(1) RDCP=1./3.5 c----------------------------------------------------------- DO 999 i=1,klon ! a vectoriser c---------------------------------------------------------- DO l=1,klev p(l)= pplay(i,l) ph(l)= paprs(i,l) pi(l) = (pplay(i,l)/100000.)**RDCP te(l) = t(i,l) qe(l) = q(i,l) omgbe(l) = omgb(i,l) dtdwn(l)= dt_dwn(i,l) dqdwn(l)= dq_dwn(i,l) dta(l)= dt_a(i,l) dqa(l)= dq_a(i,l) wdtPBL(l)= wdt_PBL(i,l) wdqPBL(l)= wdq_PBL(i,l) udtPBL(l)= udt_PBL(i,l) udqPBL(l)= udq_PBL(i,l) ENDDO sigd0=sigd(i) c print*, 'sigd0,sigd', sigd0, sigd(i) ph(klev+1)=0. ktopw = wake_k(i) DO l=1,klev dtw(l) = wake_deltat(i,l) dqw(l) = wake_deltaq(i,l) ENDDO DO l=1,klev dtls(l)=dt_wake(i,l) dqls(l)=dq_wake(i,l) ENDDO hw = wake_h(i) sigmaw = wake_s(i) cfkc les flux de masses sont evalues aux niveaux et valent 0 a la surface cfkc on veut le flux de masse au milieu des couches DO l=1,klev-1 amdwn(l)= 0.5*(M_dwn(i,l)+M_dwn(i,l+1)) amdwn(l)= (M_dwn(i,l+1)) ENDDO c au sommet le flux de masse est nul amdwn(klev)=0.5*M_dwn(i,klev) c DO l = 1,klev amup(l)=M_up(i,l) ENDDO call WAKE(p,ph,pi,dtime,sigd0 $ ,te,qe,omgbe $ ,dtdwn,dqdwn,amdwn,amup,dta,dqa $ ,wdtPBL,wdqPBL,udtPBL,udqPBL $ ,dtw,dqw,dth,hw,sigmaw,wape,fip,gfl $ ,dtls,dqls,ktopw $ ,omgbdth,dp_omgb,wdens $ ,tu,qu $ ,dtKE,dqKE $ ,dtPBL,dqPBL $ ,omg,dp_deltomg,spread $ ,Cstar,d_deltat_gw $ ,d_deltatw,d_deltaqw) IF (ktopw .GT. 0) THEN DO l=1,klev wake_deltat(i,l)= dtw(l) wake_deltaq(i,l)= dqw(l) wake_d_deltat_gw(i,l)= d_deltat_gw(l) wake_omgbdth(i,l) = omgbdth(l) wake_dp_omgb(i,l) = dp_omgb(l) wake_dtKE(i,l) = dtKE(l) wake_dqKE(i,l) = dqKE(l) wake_dtPBL(i,l) = dtPBL(l) wake_dqPBL(i,l) = dqPBL(l) wake_omg(i,l) = omg(l) wake_dp_deltomg(i,l) = dp_deltomg(l) wake_spread(i,l) = spread(l) wake_dth(i,l) = dth(l) dt_wake(i,l) = dtls(l) dq_wake(i,l) = dqls(l) undi_t(i,l) = tu(l) undi_q(i,l) = qu(l) wake_ddeltat(i,l) = d_deltatw(l) wake_ddeltaq(i,l) = d_deltaqw(l) ENDDO ELSE DO l = 1,klev wake_deltat(i,l)= 0. wake_deltaq(i,l)= 0. wake_d_deltat_gw(i,l)= 0. wake_omgbdth(i,l) = 0. wake_dp_omgb(i,l) = 0. wake_dtKE(i,l) = 0. wake_dqKE(i,l) = 0. wake_omg(i,l) = 0. wake_dp_deltomg(i,l) = 0. wake_spread(i,l) = 0. wake_dth(i,l)=0. dt_wake(i,l)=0. dq_wake(i,l)=0. undi_t(i,l)=te(l) undi_q(i,l)=qe(l) ENDDO ENDIF wake_h(i)= hw wake_s(i)= sigmaw wake_pe(i)= wape wake_fip(i)= fip wake_gfl(i) = gfl wake_k(i) =ktopw wake_Cstar(i) = Cstar wake_dens(i) = wdens c 999 CONTINUE c RETURN END