Index: LMDZ6/trunk/libf/phylmd/FLOTT_GWD_rando_m.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/FLOTT_GWD_rando_m.f90 (revision 6048) +++ LMDZ6/trunk/libf/phylmd/FLOTT_GWD_rando_m.f90 (revision 6048) @@ -0,0 +1,469 @@ +! +! $Id$ +! +!$gpum horizontal klon +module FLOTT_GWD_rando_m + + USE clesphys_mod_h + implicit none + INTEGER, PARAMETER:: NK = 2, NP = 2, NO = 2, NW = NK * NP * NO + INTEGER, PARAMETER:: NA = 5 !number of realizations to get the phase speed + LOGICAL, SAVE :: gwd_reproductibilite_mpiomp=.true. + LOGICAL, SAVE :: firstcall = .TRUE. + !$OMP THREADPRIVATE(firstcall,gwd_reproductibilite_mpiomp) + +contains + + SUBROUTINE FLOTT_GWD_rando_first + use dimphy, only: klev + USE ioipsl_getin_p_mod, ONLY : getin_p + IMPLICIT NONE + CHARACTER (LEN=20),PARAMETER :: modname='acama_gwd_rando_m' + CHARACTER (LEN=80) :: abort_message + + IF (firstcall) THEN + ! Cle introduite pour resoudre un probleme de non reproductibilite + ! Le but est de pouvoir tester de revenir a la version precedenete + ! A eliminer rapidement + CALL getin_p('gwd_reproductibilite_mpiomp',gwd_reproductibilite_mpiomp) + IF (NW+3*NA>=KLEV) THEN + abort_message = 'NW+3*NA>=KLEV Probleme pour generation des ondes' + CALL abort_physic (modname,abort_message,1) + ENDIF + firstcall=.false. + ENDIF + END SUBROUTINE FLOTT_GWD_rando_first + + + SUBROUTINE FLOTT_GWD_rando(DTIME, PP, tt, uu, vv, prec, zustr, zvstr, d_u, & + d_v,east_gwstress,west_gwstress) + + ! Parametrization of the momentum flux deposition due to a discrete + ! number of gravity waves. + ! Author: F. Lott + ! July, 12th, 2012 + ! Gaussian distribution of the source, source is precipitation + ! Reference: Lott (JGR, vol 118, page 8897, 2013) + + !ONLINE: + USE yomcst_mod_h +use dimphy, only: klon, klev + use assert_m, only: assert + USE ioipsl_getin_p_mod, ONLY : getin_p + USE vertical_layers_mod, ONLY : presnivs + USE yoegwd_mod_h + + CHARACTER (LEN=20),PARAMETER :: modname='flott_gwd_rando' + CHARACTER (LEN=80) :: abort_message + + ! OFFLINE: + ! include "dimensions_mod.f90" + ! include "dimphy.h" + ! END OF DIFFERENCE ONLINE-OFFLINE + + ! 0. DECLARATIONS: + + ! 0.1 INPUTS + REAL, intent(in)::DTIME ! Time step of the Physics + REAL, intent(in):: pp(KLON, KLEV) ! (KLON, KLEV) Pressure at full levels + REAL, intent(in):: prec(KLON) ! (klon) Precipitation (kg/m^2/s) + REAL, intent(in):: TT(KLON, KLEV) ! (KLON, KLEV) Temp at full levels + REAL, intent(in):: UU(KLON, KLEV) ! (KLON, KLEV) Zonal wind at full levels + REAL, intent(in):: VV(KLON, KLEV) ! (KLON, KLEV) Merid wind at full levels + + ! 0.2 OUTPUTS + REAL, intent(out):: zustr(KLON), zvstr(KLON) ! (KLON) Surface Stresses + + REAL, intent(inout):: d_u(KLON, KLEV), d_v(KLON, KLEV) + REAL, intent(inout):: east_gwstress(KLON, KLEV) ! Profile of eastward stress + REAL, intent(inout):: west_gwstress(KLON, KLEV) ! Profile of westward stress + + ! (KLON, KLEV) tendencies on winds + + ! O.3 INTERNAL ARRAYS + REAL BVLOW(klon) + REAL DZ ! Characteristic depth of the Source + + INTEGER II, JJ, LL + + ! 0.3.0 TIME SCALE OF THE LIFE CYCLE OF THE WAVES PARAMETERIZED + + REAL DELTAT + + ! 0.3.1 GRAVITY-WAVES SPECIFICATIONS + + INTEGER JK, JP, JO, JW + REAL KMIN, KMAX ! Min and Max horizontal wavenumbers + REAL CMAX ! standard deviation of the phase speed distribution + REAL RUWMAX,SAT ! ONLINE SPECIFIED IN run.def + REAL CPHA ! absolute PHASE VELOCITY frequency + REAL ZK(KLON, NW) ! Horizontal wavenumber amplitude + REAL ZP(KLON, NW) ! Horizontal wavenumber angle + REAL ZO(KLON, NW) ! Absolute frequency ! + + ! Waves Intr. freq. at the 1/2 lev surrounding the full level + REAL ZOM(KLON, NW), ZOP(KLON, NW) + + ! Wave EP-fluxes at the 2 semi levels surrounding the full level + REAL WWM(KLON, NW), WWP(KLON, NW) + + REAL RUW0(KLON, NW) ! Fluxes at launching level + + REAL RUWP(KLON, NW), RVWP(KLON, NW) + ! Fluxes X and Y for each waves at 1/2 Levels + + INTEGER LAUNCH, LTROP ! Launching altitude and tropo altitude + + REAL XLAUNCH ! Controle the launching altitude + REAL XTROP ! SORT of Tropopause altitude + REAL RUW(KLON, KLEV + 1) ! Flux x at semi levels + REAL RVW(KLON, KLEV + 1) ! Flux y at semi levels + + REAL PRMAX ! Maximum value of PREC, and for which our linear formula + ! for GWs parameterisation apply + + ! 0.3.2 PARAMETERS OF WAVES DISSIPATIONS + + REAL RDISS, ZOISEC ! COEFF DE DISSIPATION, SECURITY FOR INTRINSIC FREQ + + ! 0.3.3 BACKGROUND FLOW AT 1/2 LEVELS AND VERTICAL COORDINATE + + REAL H0 ! Characteristic Height of the atmosphere + REAL PR, TR ! Reference Pressure and Temperature + + REAL ZH(KLON, KLEV + 1) ! Log-pressure altitude + + REAL UH(KLON, KLEV + 1), VH(KLON, KLEV + 1) ! Winds at 1/2 levels + REAL PH(KLON, KLEV + 1) ! Pressure at 1/2 levels + REAL PSEC ! Security to avoid division by 0 pressure + REAL BV(KLON, KLEV + 1) ! Brunt Vaisala freq. (BVF) at 1/2 levels + REAL BVSEC ! Security to avoid negative BVF + REAL RAN_NUM_1,RAN_NUM_2,RAN_NUM_3 + + REAL, DIMENSION(klev+1) ::HREF + + + !----------------------------------------------------------------- + + ! 1. INITIALISATIONS + + ! 1.1 Basic parameter + + ! Are provided from elsewhere (latent heat of vaporization, dry + ! gaz constant for air, gravity constant, heat capacity of dry air + ! at constant pressure, earth rotation rate, pi). + + ! 1.2 Tuning parameters of V14 + + + RDISS = 0.5 ! Diffusion parameter + ! ONLINE + RUWMAX=GWD_RANDO_RUWMAX + SAT=gwd_rando_sat + !END ONLINE + ! OFFLINE + ! RUWMAX= 1.75 ! Launched flux + ! SAT=0.25 ! Saturation parameter + ! END OFFLINE + + PRMAX = 20. / 24. /3600. + ! maximum of rain for which our theory applies (in kg/m^2/s) + + ! Characteristic depth of the source + DZ = 1000. + XLAUNCH=0.5 ! Parameter that control launching altitude + XTROP=0.2 ! Parameter that control tropopause altitude + DELTAT=24.*3600. ! Time scale of the waves (first introduced in 9b) + ! OFFLINE + ! DELTAT=DTIME + ! END OFFLINE + + KMIN = 2.E-5 + ! minimum horizontal wavenumber (inverse of the subgrid scale resolution) + + KMAX = 1.E-3 ! Max horizontal wavenumber + CMAX = 30. ! Max phase speed velocity + + TR = 240. ! Reference Temperature + PR = 101300. ! Reference pressure + H0 = RD * TR / RG ! Characteristic vertical scale height + + BVSEC = 5.E-3 ! Security to avoid negative BVF + PSEC = 1.E-6 ! Security to avoid division by 0 pressure + ZOISEC = 1.E-6 ! Security FOR 0 INTRINSIC FREQ + +IF (1==0) THEN + !ONLINE + call assert(klon == (/size(pp, 1), size(tt, 1), size(uu, 1), & + size(vv, 1), size(zustr), size(zvstr), size(d_u, 1), & + size(d_v, 1), & + size(east_gwstress, 1), size(west_gwstress, 1) /), & + "FLOTT_GWD_RANDO klon") + call assert(klev == (/size(pp, 2), size(tt, 2), size(uu, 2), & + size(vv, 2), size(d_u, 2), size(d_v, 2), & + size(east_gwstress,2), size(west_gwstress,2) /), & + "FLOTT_GWD_RANDO klev") + !END ONLINE +ENDIF + + IF(DELTAT < DTIME)THEN + abort_message='flott_gwd_rando: deltat < dtime!' + CALL abort_physic(modname,abort_message,1) + ENDIF + + IF (KLEV < NW) THEN + abort_message='flott_gwd_rando: you will have problem with random numbers' + CALL abort_physic(modname,abort_message,1) + ENDIF + + ! 2. EVALUATION OF THE BACKGROUND FLOW AT SEMI-LEVELS + + ! Pressure and Inv of pressure + DO LL = 2, KLEV + PH(:, LL) = EXP((LOG(PP(:, LL)) + LOG(PP(:, LL - 1))) / 2.) + end DO + PH(:, KLEV + 1) = 0. + PH(:, 1) = 2. * PP(:, 1) - PH(:, 2) + + ! Launching altitude + + !Pour revenir a la version non reproductible en changeant le nombre de process + IF (gwd_reproductibilite_mpiomp) THEN + ! Reprend la formule qui calcule PH en fonction de PP=play + DO LL = 2, KLEV + HREF(LL) = EXP((LOG(presnivs(LL)) + LOG(presnivs(LL - 1))) / 2.) + end DO + HREF(KLEV + 1) = 0. + HREF(1) = 2. * presnivs(1) - HREF(2) + ELSE + HREF(1:KLEV)=PH(KLON/2,1:KLEV) + ENDIF + + LAUNCH=0 + LTROP =0 + DO LL = 1, KLEV + IF (HREF(LL) / HREF(1) > XLAUNCH) LAUNCH = LL + ENDDO + DO LL = 1, KLEV + IF (HREF(LL) / HREF(1) > XTROP) LTROP = LL + ENDDO + !LAUNCH=22 ; LTROP=33 +! print*,'LAUNCH=',LAUNCH,'LTROP=',LTROP + + ! Log pressure vert. coordinate + DO LL = 1, KLEV + 1 + ZH(:, LL) = H0 * LOG(PR / (PH(:, LL) + PSEC)) + end DO + + ! BV frequency + DO LL = 2, KLEV + ! BVSEC: BV Frequency (UH USED IS AS A TEMPORARY ARRAY DOWN TO WINDS) + UH(:, LL) = 0.5 * (TT(:, LL) + TT(:, LL - 1)) & + * RD**2 / RCPD / H0**2 + (TT(:, LL) & + - TT(:, LL - 1)) / (ZH(:, LL) - ZH(:, LL - 1)) * RD / H0 + end DO + BVLOW(:) = 0.5 * (TT(:, LTROP )+ TT(:, LAUNCH)) & + * RD**2 / RCPD / H0**2 + (TT(:, LTROP ) & + - TT(:, LAUNCH))/(ZH(:, LTROP )- ZH(:, LAUNCH)) * RD / H0 + + UH(:, 1) = UH(:, 2) + UH(:, KLEV + 1) = UH(:, KLEV) + BV(:, 1) = UH(:, 2) + BV(:, KLEV + 1) = UH(:, KLEV) + ! SMOOTHING THE BV HELPS + DO LL = 2, KLEV + BV(:, LL)=(UH(:, LL+1)+2.*UH(:, LL)+UH(:, LL-1))/4. + end DO + + BV=MAX(SQRT(MAX(BV, 0.)), BVSEC) + BVLOW=MAX(SQRT(MAX(BVLOW, 0.)), BVSEC) + + + ! WINDS + DO LL = 2, KLEV + UH(:, LL) = 0.5 * (UU(:, LL) + UU(:, LL - 1)) ! Zonal wind + VH(:, LL) = 0.5 * (VV(:, LL) + VV(:, LL - 1)) ! Meridional wind + end DO + UH(:, 1) = 0. + VH(:, 1) = 0. + UH(:, KLEV + 1) = UU(:, KLEV) + VH(:, KLEV + 1) = VV(:, KLEV) + + ! 3 WAVES CHARACTERISTICS CHOSEN RANDOMLY AT THE LAUNCH ALTITUDE + + ! The mod functions of weird arguments are used to produce the + ! waves characteristics in an almost stochastic way + + DO JW = 1, NW + ! Angle + DO II = 1, KLON + ! Angle (0 or PI so far) + RAN_NUM_1=MOD(TT(II, JW) * 10., 1.) + RAN_NUM_2= MOD(TT(II, JW) * 100., 1.) + ZP(II, JW) = (SIGN(1., 0.5 - RAN_NUM_1) + 1.) & + * RPI / 2. + ! Horizontal wavenumber amplitude + ZK(II, JW) = KMIN + (KMAX - KMIN) *RAN_NUM_2 + ! Horizontal phase speed + CPHA = 0. + DO JJ = 1, NA + RAN_NUM_3=MOD(TT(II, JW+3*JJ)**2, 1.) + CPHA = CPHA + & + CMAX*2.*(RAN_NUM_3 -0.5)*SQRT(3.)/SQRT(NA*1.) + END DO + IF (CPHA.LT.0.) THEN + CPHA = -1.*CPHA + ZP(II, JW) = ZP(II, JW) + RPI + ENDIF + ! Absolute frequency is imposed + ZO(II, JW) = CPHA * ZK(II, JW) + ! Intrinsic frequency is imposed + ZO(II, JW) = ZO(II, JW) & + + ZK(II, JW) * COS(ZP(II, JW)) * UH(II, LAUNCH) & + + ZK(II, JW) * SIN(ZP(II, JW)) * VH(II, LAUNCH) + ! Momentum flux at launch lev + RUW0(II, JW) = RUWMAX + ENDDO + ENDDO + + ! 4. COMPUTE THE FLUXES + + ! 4.1 Vertical velocity at launching altitude to ensure + ! the correct value to the imposed fluxes. + + DO JW = 1, NW + + ! Evaluate intrinsic frequency at launching altitude: + ZOP(:,JW) = ZO(:, JW) & + - ZK(:, JW) * COS(ZP(:, JW)) * UH(:, LAUNCH) & + - ZK(:, JW) * SIN(ZP(:, JW)) * VH(:, LAUNCH) + + ! VERSION WITH CONVECTIVE SOURCE + + ! Vertical velocity at launch level, value to ensure the + ! imposed factor related to the convective forcing: + ! precipitations. + + ! tanh limitation to values above prmax: + WWP(:, JW) = RUW0(:, JW) & + * (RD / RCPD / H0 * RLVTT * PRMAX * TANH(PREC(:) / PRMAX))**2 + + ! Factor related to the characteristics of the waves: + WWP(:, JW) = WWP(:, JW) * ZK(:, JW)**3 / KMIN / BVLOW(:) & + / MAX(ABS(ZOP(:, JW)), ZOISEC)**3 + + ! Moderation by the depth of the source (dz here): + WWP(:, JW) = WWP(:, JW) & + * EXP(- BVLOW(:)**2 / MAX(ABS(ZOP(:, JW)), ZOISEC)**2 * ZK(:, JW)**2 & + * DZ**2) + + ! Put the stress in the right direction: + RUWP(:, JW) = ZOP(:, JW) / MAX(ABS(ZOP(:, JW)), ZOISEC)**2 & + * BV(:, LAUNCH) * COS(ZP(:, JW)) * WWP(:, JW)**2 + RVWP(:, JW) = ZOP(:, JW) / MAX(ABS(ZOP(:, JW)), ZOISEC)**2 & + * BV(:, LAUNCH) * SIN(ZP(:, JW)) * WWP(:, JW)**2 + end DO + + + ! 4.2 Uniform values below the launching altitude + + DO LL = 1, LAUNCH + RUW(:, LL) = 0 + RVW(:, LL) = 0 + DO JW = 1, NW + RUW(:, LL) = RUW(:, LL) + RUWP(:, JW) + RVW(:, LL) = RVW(:, LL) + RVWP(:, JW) + end DO + end DO + + ! 4.3 Loop over altitudes, with passage from one level to the next + ! done by i) conserving the EP flux, ii) dissipating a little, + ! iii) testing critical levels, and vi) testing the breaking. + + DO LL = LAUNCH, KLEV - 1 + ! Warning: all the physics is here (passage from one level + ! to the next) + DO JW = 1, NW + ZOM(:, JW) = ZOP(:,JW) + WWM(:, JW) = WWP(:, JW) + ! Intrinsic Frequency + ZOP(:, JW) = ZO(:, JW) - ZK(:, JW) * COS(ZP(:, JW)) * UH(:, LL + 1) & + - ZK(:, JW) * SIN(ZP(:, JW)) * VH(:, LL + 1) + + ! No breaking (Eq.6) + ! Dissipation (Eq. 8) + WWP(:, JW) = WWM(:, JW) * EXP(- 4. * RDISS * PR / (PH(:, LL + 1) & + + PH(:, LL)) * ((BV(:, LL + 1) + BV(:, LL)) / 2.)**3 & + / MAX(ABS(ZOP(:, JW) + ZOM(:, JW)) / 2., ZOISEC)**4 & + * ZK(:, JW)**3 * (ZH(:, LL + 1) - ZH(:, LL))) + + ! Critical levels (forced to zero if intrinsic frequency changes sign) + ! Saturation (Eq. 12) + WWP(:, JW) = min(WWP(:, JW), MAX(0., & + SIGN(1., ZOP(:, JW) * ZOM(:, JW))) * ABS(ZOP(:, JW))**3 & + / BV(:, LL + 1) * EXP(- ZH(:, LL + 1) / H0) * KMIN**2 & + * SAT**2 / ZK(:, JW)**4) + end DO + + ! Evaluate EP-flux from Eq. 7 and give the right orientation to + ! the stress + + DO JW = 1, NW + RUWP(:, JW) = SIGN(1., ZOP(:, JW))*COS(ZP(:, JW)) * WWP(:, JW) + RVWP(:, JW) = SIGN(1., ZOP(:, JW))*SIN(ZP(:, JW)) * WWP(:, JW) + end DO + + RUW(:, LL + 1) = 0. + RVW(:, LL + 1) = 0. + + DO JW = 1, NW + RUW(:, LL + 1) = RUW(:, LL + 1) + RUWP(:, JW) + RVW(:, LL + 1) = RVW(:, LL + 1) + RVWP(:, JW) + EAST_GWSTRESS(:, LL)=EAST_GWSTRESS(:, LL)+MAX(0.,RUWP(:, JW))/REAL(NW) + WEST_GWSTRESS(:, LL)=WEST_GWSTRESS(:, LL)+MIN(0.,RUWP(:, JW))/REAL(NW) + end DO + end DO +! OFFLINE ONLY +! PRINT *,'SAT PROFILE:' +! DO LL=1,KLEV +! PRINT *,ZH(KLON/2,LL)/1000.,SAT*(2.+TANH(ZH(KLON/2,LL)/H0-8.)) +! ENDDO + + ! 5 CALCUL DES TENDANCES: + + ! 5.1 Rectification des flux au sommet et dans les basses couches + + RUW(:, KLEV + 1) = 0. + RVW(:, KLEV + 1) = 0. + RUW(:, 1) = RUW(:, LAUNCH) + RVW(:, 1) = RVW(:, LAUNCH) + DO LL = 1, LAUNCH + RUW(:, LL) = RUW(:, LAUNCH+1) + RVW(:, LL) = RVW(:, LAUNCH+1) + EAST_GWSTRESS(:, LL) = EAST_GWSTRESS(:, LAUNCH) + WEST_GWSTRESS(:, LL) = WEST_GWSTRESS(:, LAUNCH) + end DO + + ! AR-1 RECURSIVE FORMULA (13) IN VERSION 4 + DO LL = 1, KLEV + D_U(:, LL) = (1.-DTIME/DELTAT) * D_U(:, LL) + DTIME/DELTAT/REAL(NW) * & + RG * (RUW(:, LL + 1) - RUW(:, LL)) & + / (PH(:, LL + 1) - PH(:, LL)) * DTIME + ! NO AR-1 FOR MERIDIONAL TENDENCIES + D_V(:, LL) = 1./REAL(NW) * & + RG * (RVW(:, LL + 1) - RVW(:, LL)) & + / (PH(:, LL + 1) - PH(:, LL)) * DTIME + ENDDO + + ! Cosmetic: evaluation of the cumulated stress + ZUSTR = 0. + ZVSTR = 0. + DO LL = 1, KLEV + ZUSTR = ZUSTR + D_U(:, LL) / RG * (PH(:, LL + 1) - PH(:, LL))/DTIME + ZVSTR = ZVSTR + D_V(:, LL) / RG * (PH(:, LL + 1) - PH(:, LL))/DTIME + ENDDO + + + END SUBROUTINE FLOTT_GWD_RANDO + +end module FLOTT_GWD_rando_m Index: LMDZ6/trunk/libf/phylmd/acama_gwd_rando_m.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/acama_gwd_rando_m.f90 (revision 6047) +++ LMDZ6/trunk/libf/phylmd/acama_gwd_rando_m.f90 (revision 6048) @@ -3,5 +3,5 @@ ! !$gpum horizontal klon -module ACAMA_GWD_rando_m +module acama_gwd_rando_m USE clesphys_mod_h @@ -543,3 +543,3 @@ END SUBROUTINE ACAMA_GWD_RANDO -end module ACAMA_GWD_rando_m +end module acama_gwd_rando_m Index: LMDZ6/trunk/libf/phylmd/add_wake_tend.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/add_wake_tend.f90 (revision 6047) +++ (revision ) @@ -1,79 +1,0 @@ -!$gpum horizontal klon -MODULE add_wake_tend_mod - PRIVATE - - PUBLIC add_wake_tend - - CONTAINS - -SUBROUTINE add_wake_tend(zddeltat, zddeltaq, zds, zdas, zddensw, zddensaw, zoccur, text, abortphy) -!=================================================================== -! Ajoute les tendances liees aux diverses parametrisations physiques aux -! variables d'etat des poches froides. -!=================================================================== -!====================================================================== -! Declarations -!====================================================================== - -USE dimphy, ONLY: klon, klev -USE phys_state_var_mod, ONLY: wake_deltat, wake_deltaq, wake_s, awake_s, & - wake_dens, awake_dens - -USE print_control_mod, ONLY: prt_level -IMPLICIT none - -! Arguments : -!------------ - REAL, DIMENSION(klon, klev), INTENT (IN) :: zddeltat, zddeltaq - REAL, DIMENSION(klon), INTENT (IN) :: zds, zdas, zddensw, zddensaw - INTEGER, DIMENSION(klon), INTENT (IN) :: zoccur - CHARACTER(LEN=*), INTENT (IN) :: text - INTEGER, INTENT (IN) :: abortphy - -! Local : -!-------- - -INTEGER :: i, l - - - - IF (prt_level >= 5) then - write (*,*) "In add_wake_tend, after ",text - call flush - end if - - IF (abortphy==1) RETURN ! on n ajoute pas les tendance si le modele - ! a deja plante. - -!====================================================================== -! Add tendencies to wake state variables -!====================================================================== - DO l = 1, klev - DO i = 1, klon - IF (zoccur(i) .GE. 1) THEN - wake_deltat(i, l) = wake_deltat(i, l) + zddeltat(i,l) - wake_deltaq(i, l) = wake_deltaq(i, l) + zddeltaq(i,l) - ELSE - wake_deltat(i, l) = 0. - wake_deltaq(i, l) = 0. - ENDIF ! (zoccur(i) .GE. 1) - END DO - END DO - DO i = 1, klon - IF (zoccur(i) .GE. 1) THEN - wake_s(i) = wake_s(i) + zds(i) - awake_s(i) = awake_s(i) + zdas(i) - wake_dens(i) = wake_dens(i) + zddensw(i) - awake_dens(i) = awake_dens(i) + zddensaw(i) - ELSE - wake_s(i) = 0. - awake_s(i) = 0. - wake_dens(i) = 0. - awake_dens(i) = 0. - ENDIF ! (zoccur(i) .GE. 1) - END DO - -RETURN -END SUBROUTINE add_wake_tend - -END MODULE add_wake_tend_mod Index: LMDZ6/trunk/libf/phylmd/add_wake_tend_mod.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/add_wake_tend_mod.f90 (revision 6048) +++ LMDZ6/trunk/libf/phylmd/add_wake_tend_mod.f90 (revision 6048) @@ -0,0 +1,79 @@ +!$gpum horizontal klon +MODULE add_wake_tend_mod + PRIVATE + + PUBLIC add_wake_tend + + CONTAINS + +SUBROUTINE add_wake_tend(zddeltat, zddeltaq, zds, zdas, zddensw, zddensaw, zoccur, text, abortphy) +!=================================================================== +! Ajoute les tendances liees aux diverses parametrisations physiques aux +! variables d'etat des poches froides. +!=================================================================== +!====================================================================== +! Declarations +!====================================================================== + +USE dimphy, ONLY: klon, klev +USE phys_state_var_mod, ONLY: wake_deltat, wake_deltaq, wake_s, awake_s, & + wake_dens, awake_dens + +USE print_control_mod, ONLY: prt_level +IMPLICIT none + +! Arguments : +!------------ + REAL, DIMENSION(klon, klev), INTENT (IN) :: zddeltat, zddeltaq + REAL, DIMENSION(klon), INTENT (IN) :: zds, zdas, zddensw, zddensaw + INTEGER, DIMENSION(klon), INTENT (IN) :: zoccur + CHARACTER(LEN=*), INTENT (IN) :: text + INTEGER, INTENT (IN) :: abortphy + +! Local : +!-------- + +INTEGER :: i, l + + + + IF (prt_level >= 5) then + write (*,*) "In add_wake_tend, after ",text + call flush + end if + + IF (abortphy==1) RETURN ! on n ajoute pas les tendance si le modele + ! a deja plante. + +!====================================================================== +! Add tendencies to wake state variables +!====================================================================== + DO l = 1, klev + DO i = 1, klon + IF (zoccur(i) .GE. 1) THEN + wake_deltat(i, l) = wake_deltat(i, l) + zddeltat(i,l) + wake_deltaq(i, l) = wake_deltaq(i, l) + zddeltaq(i,l) + ELSE + wake_deltat(i, l) = 0. + wake_deltaq(i, l) = 0. + ENDIF ! (zoccur(i) .GE. 1) + END DO + END DO + DO i = 1, klon + IF (zoccur(i) .GE. 1) THEN + wake_s(i) = wake_s(i) + zds(i) + awake_s(i) = awake_s(i) + zdas(i) + wake_dens(i) = wake_dens(i) + zddensw(i) + awake_dens(i) = awake_dens(i) + zddensaw(i) + ELSE + wake_s(i) = 0. + awake_s(i) = 0. + wake_dens(i) = 0. + awake_dens(i) = 0. + ENDIF ! (zoccur(i) .GE. 1) + END DO + +RETURN +END SUBROUTINE add_wake_tend + +END MODULE add_wake_tend_mod Index: LMDZ6/trunk/libf/phylmd/ajsec.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ajsec.f90 (revision 6047) +++ (revision ) @@ -1,409 +1,0 @@ - -! $Header$ -!$gpum horizontal klon -MODULE ajsec_mod - PRIVATE - - PUBLIC ajsec, ajsec_convv2, ajsec_old - - CONTAINS - -SUBROUTINE ajsec(paprs, pplay, t, q, limbas, d_t, d_q) - USE dimphy - USE yomcst_mod_h -IMPLICIT NONE - ! ====================================================================== - ! Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818 - ! Objet: ajustement sec (adaptation du GCM du LMD) - ! ====================================================================== - ! Arguments: - ! t-------input-R- Temperature - - ! d_t-----output-R-Incrementation de la temperature - ! ====================================================================== - - REAL paprs(klon, klev+1), pplay(klon, klev) - REAL t(klon, klev), q(klon, klev) - REAL d_t(klon, klev), d_q(klon, klev) - - INTEGER limbas(klon), limhau ! les couches a ajuster - - LOGICAL mixq - ! cc PARAMETER (mixq=.TRUE.) - PARAMETER (mixq=.FALSE.) - - REAL zh(klon, klev) - REAL zho(klon, klev) - REAL zq(klon, klev) - REAL zpk(klon, klev) - REAL zpkdp(klon, klev) - REAL hm, sm, qm - LOGICAL modif(klon), down - INTEGER i, k, k1, k2 - - ! Initialisation: - - ! ym - limhau = klev - - DO k = 1, klev - DO i = 1, klon - d_t(i, k) = 0.0 - d_q(i, k) = 0.0 - END DO - END DO - ! ------------------------------------- detection des profils a modifier - DO k = 1, limhau - DO i = 1, klon - zpk(i, k) = pplay(i, k)**rkappa - zh(i, k) = rcpd*t(i, k)/zpk(i, k) - zho(i, k) = zh(i, k) - zq(i, k) = q(i, k) - END DO - END DO - - DO k = 1, limhau - DO i = 1, klon - zpkdp(i, k) = zpk(i, k)*(paprs(i,k)-paprs(i,k+1)) - END DO - END DO - - DO i = 1, klon - modif(i) = .FALSE. - END DO - DO k = 2, limhau - DO i = 1, klon - IF (.NOT. modif(i) .AND. k-1>limbas(i)) THEN - IF (zh(i,k)limhau) GO TO 8001 - IF (zh(i,k2)=hm)) GO TO 8021 - k2 = k2 + 1 - k = k2 - END IF - GO TO 8020 -8021 CONTINUE - ! ------------ nouveau profil : constant (valeur moyenne) - DO k = k1, k2 - zh(i, k) = hm - zq(i, k) = qm - END DO - k2 = k2 + 1 - END IF - GO TO 8000 -8001 CONTINUE - END IF - END DO - - DO k = 1, limhau - DO i = 1, klon - d_t(i, k) = (zh(i,k)-zho(i,k))*zpk(i, k)/rcpd - d_q(i, k) = zq(i, k) - q(i, k) - END DO - END DO - - ! FH : les d_q et d_t sont maintenant calcules de facon a valoir - ! effectivement 0. si on ne fait rien. - - ! IF (limbas.GT.1) THEN - ! DO k = 1, limbas-1 - ! DO i = 1, klon - ! d_t(i,k) = 0.0 - ! d_q(i,k) = 0.0 - ! ENDDO - ! ENDDO - ! ENDIF - - ! IF (limhau.LT.klev) THEN - ! DO k = limhau+1, klev - ! DO i = 1, klon - ! d_t(i,k) = 0.0 - ! d_q(i,k) = 0.0 - ! ENDDO - ! ENDDO - ! ENDIF - - IF (.NOT. mixq) THEN - DO k = 1, klev - DO i = 1, klon - d_q(i, k) = 0.0 - END DO - END DO - END IF - - RETURN -END SUBROUTINE ajsec - -SUBROUTINE ajsec_convv2(paprs, pplay, t, q, d_t, d_q) - USE dimphy - USE yomcst_mod_h -IMPLICIT NONE - ! ====================================================================== - ! Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818 - ! Objet: ajustement sec (adaptation du GCM du LMD) - ! ====================================================================== - ! Arguments: - ! t-------input-R- Temperature - - ! d_t-----output-R-Incrementation de la temperature - ! ====================================================================== - - REAL paprs(klon, klev+1), pplay(klon, klev) - REAL t(klon, klev), q(klon, klev) - REAL d_t(klon, klev), d_q(klon, klev) - - INTEGER limbas, limhau ! les couches a ajuster - ! cc PARAMETER (limbas=klev-3, limhau=klev) - ! ym PARAMETER (limbas=1, limhau=klev) - - LOGICAL mixq - ! cc PARAMETER (mixq=.TRUE.) - PARAMETER (mixq=.FALSE.) - - REAL zh(klon, klev) - REAL zq(klon, klev) - REAL zpk(klon, klev) - REAL zpkdp(klon, klev) - REAL hm, sm, qm - LOGICAL modif(klon), down - INTEGER i, k, k1, k2 - - ! Initialisation: - - ! ym - limbas = 1 - limhau = klev - - DO k = 1, klev - DO i = 1, klon - d_t(i, k) = 0.0 - d_q(i, k) = 0.0 - END DO - END DO - ! ------------------------------------- detection des profils a modifier - DO k = limbas, limhau - DO i = 1, klon - zpk(i, k) = pplay(i, k)**rkappa - zh(i, k) = rcpd*t(i, k)/zpk(i, k) - zq(i, k) = q(i, k) - END DO - END DO - - DO k = limbas, limhau - DO i = 1, klon - zpkdp(i, k) = zpk(i, k)*(paprs(i,k)-paprs(i,k+1)) - END DO - END DO - - DO i = 1, klon - modif(i) = .FALSE. - END DO - DO k = limbas + 1, limhau - DO i = 1, klon - IF (.NOT. modif(i)) THEN - IF (zh(i,k)limhau) GO TO 8001 - IF (zh(i,k2)=hm)) GO TO 8021 - k2 = k2 + 1 - k = k2 - END IF - GO TO 8020 -8021 CONTINUE - ! ------------ nouveau profil : constant (valeur moyenne) - DO k = k1, k2 - zh(i, k) = hm - zq(i, k) = qm - END DO - k2 = k2 + 1 - END IF - GO TO 8000 -8001 CONTINUE - END IF - END DO - - DO k = limbas, limhau - DO i = 1, klon - d_t(i, k) = zh(i, k)*zpk(i, k)/rcpd - t(i, k) - d_q(i, k) = zq(i, k) - q(i, k) - END DO - END DO - - IF (limbas>1) THEN - DO k = 1, limbas - 1 - DO i = 1, klon - d_t(i, k) = 0.0 - d_q(i, k) = 0.0 - END DO - END DO - END IF - - IF (limhauklev) GO TO 8001 - IF (local_h(i,l2)=hm)) GO TO 8021 - l2 = l2 + 1 - l = l2 - END IF - GO TO 8020 -8021 CONTINUE - ! ------------ nouveau profil : constant (valeur moyenne) - DO l = l1, l2 - local_h(i, l) = hm - END DO - l2 = l2 + 1 - END IF - GO TO 8000 -8001 CONTINUE - END IF - END DO - - DO l = 1, klev - DO i = 1, klon - d_t(i, l) = local_h(i, l)*(pplay(i,l)**rkappa)/rcpd - t(i, l) - END DO - END DO - - RETURN -END SUBROUTINE ajsec_old - -END MODULE ajsec_mod Index: LMDZ6/trunk/libf/phylmd/ajsec_mod.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ajsec_mod.f90 (revision 6048) +++ LMDZ6/trunk/libf/phylmd/ajsec_mod.f90 (revision 6048) @@ -0,0 +1,409 @@ + +! $Header$ +!$gpum horizontal klon +MODULE ajsec_mod + PRIVATE + + PUBLIC ajsec, ajsec_convv2, ajsec_old + + CONTAINS + +SUBROUTINE ajsec(paprs, pplay, t, q, limbas, d_t, d_q) + USE dimphy + USE yomcst_mod_h +IMPLICIT NONE + ! ====================================================================== + ! Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818 + ! Objet: ajustement sec (adaptation du GCM du LMD) + ! ====================================================================== + ! Arguments: + ! t-------input-R- Temperature + + ! d_t-----output-R-Incrementation de la temperature + ! ====================================================================== + + REAL paprs(klon, klev+1), pplay(klon, klev) + REAL t(klon, klev), q(klon, klev) + REAL d_t(klon, klev), d_q(klon, klev) + + INTEGER limbas(klon), limhau ! les couches a ajuster + + LOGICAL mixq + ! cc PARAMETER (mixq=.TRUE.) + PARAMETER (mixq=.FALSE.) + + REAL zh(klon, klev) + REAL zho(klon, klev) + REAL zq(klon, klev) + REAL zpk(klon, klev) + REAL zpkdp(klon, klev) + REAL hm, sm, qm + LOGICAL modif(klon), down + INTEGER i, k, k1, k2 + + ! Initialisation: + + ! ym + limhau = klev + + DO k = 1, klev + DO i = 1, klon + d_t(i, k) = 0.0 + d_q(i, k) = 0.0 + END DO + END DO + ! ------------------------------------- detection des profils a modifier + DO k = 1, limhau + DO i = 1, klon + zpk(i, k) = pplay(i, k)**rkappa + zh(i, k) = rcpd*t(i, k)/zpk(i, k) + zho(i, k) = zh(i, k) + zq(i, k) = q(i, k) + END DO + END DO + + DO k = 1, limhau + DO i = 1, klon + zpkdp(i, k) = zpk(i, k)*(paprs(i,k)-paprs(i,k+1)) + END DO + END DO + + DO i = 1, klon + modif(i) = .FALSE. + END DO + DO k = 2, limhau + DO i = 1, klon + IF (.NOT. modif(i) .AND. k-1>limbas(i)) THEN + IF (zh(i,k)limhau) GO TO 8001 + IF (zh(i,k2)=hm)) GO TO 8021 + k2 = k2 + 1 + k = k2 + END IF + GO TO 8020 +8021 CONTINUE + ! ------------ nouveau profil : constant (valeur moyenne) + DO k = k1, k2 + zh(i, k) = hm + zq(i, k) = qm + END DO + k2 = k2 + 1 + END IF + GO TO 8000 +8001 CONTINUE + END IF + END DO + + DO k = 1, limhau + DO i = 1, klon + d_t(i, k) = (zh(i,k)-zho(i,k))*zpk(i, k)/rcpd + d_q(i, k) = zq(i, k) - q(i, k) + END DO + END DO + + ! FH : les d_q et d_t sont maintenant calcules de facon a valoir + ! effectivement 0. si on ne fait rien. + + ! IF (limbas.GT.1) THEN + ! DO k = 1, limbas-1 + ! DO i = 1, klon + ! d_t(i,k) = 0.0 + ! d_q(i,k) = 0.0 + ! ENDDO + ! ENDDO + ! ENDIF + + ! IF (limhau.LT.klev) THEN + ! DO k = limhau+1, klev + ! DO i = 1, klon + ! d_t(i,k) = 0.0 + ! d_q(i,k) = 0.0 + ! ENDDO + ! ENDDO + ! ENDIF + + IF (.NOT. mixq) THEN + DO k = 1, klev + DO i = 1, klon + d_q(i, k) = 0.0 + END DO + END DO + END IF + + RETURN +END SUBROUTINE ajsec + +SUBROUTINE ajsec_convv2(paprs, pplay, t, q, d_t, d_q) + USE dimphy + USE yomcst_mod_h +IMPLICIT NONE + ! ====================================================================== + ! Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818 + ! Objet: ajustement sec (adaptation du GCM du LMD) + ! ====================================================================== + ! Arguments: + ! t-------input-R- Temperature + + ! d_t-----output-R-Incrementation de la temperature + ! ====================================================================== + + REAL paprs(klon, klev+1), pplay(klon, klev) + REAL t(klon, klev), q(klon, klev) + REAL d_t(klon, klev), d_q(klon, klev) + + INTEGER limbas, limhau ! les couches a ajuster + ! cc PARAMETER (limbas=klev-3, limhau=klev) + ! ym PARAMETER (limbas=1, limhau=klev) + + LOGICAL mixq + ! cc PARAMETER (mixq=.TRUE.) + PARAMETER (mixq=.FALSE.) + + REAL zh(klon, klev) + REAL zq(klon, klev) + REAL zpk(klon, klev) + REAL zpkdp(klon, klev) + REAL hm, sm, qm + LOGICAL modif(klon), down + INTEGER i, k, k1, k2 + + ! Initialisation: + + ! ym + limbas = 1 + limhau = klev + + DO k = 1, klev + DO i = 1, klon + d_t(i, k) = 0.0 + d_q(i, k) = 0.0 + END DO + END DO + ! ------------------------------------- detection des profils a modifier + DO k = limbas, limhau + DO i = 1, klon + zpk(i, k) = pplay(i, k)**rkappa + zh(i, k) = rcpd*t(i, k)/zpk(i, k) + zq(i, k) = q(i, k) + END DO + END DO + + DO k = limbas, limhau + DO i = 1, klon + zpkdp(i, k) = zpk(i, k)*(paprs(i,k)-paprs(i,k+1)) + END DO + END DO + + DO i = 1, klon + modif(i) = .FALSE. + END DO + DO k = limbas + 1, limhau + DO i = 1, klon + IF (.NOT. modif(i)) THEN + IF (zh(i,k)limhau) GO TO 8001 + IF (zh(i,k2)=hm)) GO TO 8021 + k2 = k2 + 1 + k = k2 + END IF + GO TO 8020 +8021 CONTINUE + ! ------------ nouveau profil : constant (valeur moyenne) + DO k = k1, k2 + zh(i, k) = hm + zq(i, k) = qm + END DO + k2 = k2 + 1 + END IF + GO TO 8000 +8001 CONTINUE + END IF + END DO + + DO k = limbas, limhau + DO i = 1, klon + d_t(i, k) = zh(i, k)*zpk(i, k)/rcpd - t(i, k) + d_q(i, k) = zq(i, k) - q(i, k) + END DO + END DO + + IF (limbas>1) THEN + DO k = 1, limbas - 1 + DO i = 1, klon + d_t(i, k) = 0.0 + d_q(i, k) = 0.0 + END DO + END DO + END IF + + IF (limhauklev) GO TO 8001 + IF (local_h(i,l2)=hm)) GO TO 8021 + l2 = l2 + 1 + l = l2 + END IF + GO TO 8020 +8021 CONTINUE + ! ------------ nouveau profil : constant (valeur moyenne) + DO l = l1, l2 + local_h(i, l) = hm + END DO + l2 = l2 + 1 + END IF + GO TO 8000 +8001 CONTINUE + END IF + END DO + + DO l = 1, klev + DO i = 1, klon + d_t(i, l) = local_h(i, l)*(pplay(i,l)**rkappa)/rcpd - t(i, l) + END DO + END DO + + RETURN +END SUBROUTINE ajsec_old + +END MODULE ajsec_mod Index: LMDZ6/trunk/libf/phylmd/albedo.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/albedo.f90 (revision 6047) +++ (revision ) @@ -1,164 +1,0 @@ -! $Id$ -MODULE albedo_mod - -IMPLICIT NONE - -contains - - SUBROUTINE alboc(ngrid, rjour, rlat, albedo) -!$gpum horizontal ngrid -! USE clesphys_mod_h - USE yomcst_mod_h, ONLY : r_incl - USE orbite_mod, ONLY : orbite - IMPLICIT NONE - ! ====================================================================== - ! Auteur(s): Z.X. Li (LMD/CNRS) (adaptation du GCM du LMD) - ! Date: le 16 mars 1995 - ! Objet: Calculer l'albedo sur l'ocean - ! Methode: Integrer numeriquement l'albedo pendant une journee - - ! Arguments; - ! rjour (in,R) : jour dans l'annee (a compter du 1 janvier) - ! rlat (in,R) : latitude en degre - ! albedo (out,R): albedo obtenu (de 0 a 1) - ! ====================================================================== - INTEGER, INTENT(IN) :: ngrid - INTEGER npts ! il controle la precision de l'integration - PARAMETER (npts=120) ! 120 correspond a l'interval 6 minutes - - REAL rlat(ngrid), rjour, albedo(ngrid) - REAL zdist, zlonsun, zpi, zdeclin - REAL rmu, alb, srmu, salb, fauxo, aa, bb - INTEGER i, k - ! ccIM - LOGICAL ancien_albedo - PARAMETER (ancien_albedo=.FALSE.) - ! SAVE albedo - - IF (ancien_albedo) THEN - - zpi = 4.*atan(1.) - - ! Calculer la longitude vraie de l'orbite terrestre: - CALL orbite(rjour, zlonsun, zdist) - - ! Calculer la declinaison du soleil (qui varie entre + et - R_incl): - zdeclin = asin(sin(zlonsun*zpi/180.0)*sin(r_incl*zpi/180.0)) - - DO i = 1, ngrid - aa = sin(rlat(i)*zpi/180.0)*sin(zdeclin) - bb = cos(rlat(i)*zpi/180.0)*cos(zdeclin) - - ! Midi local (angle du temps = 0.0): - rmu = aa + bb*cos(0.0) - rmu = max(0.0, rmu) - fauxo = (1.47-acos(rmu))/.15 - alb = 0.03 + 0.630/(1.+fauxo*fauxo) - srmu = rmu - salb = alb*rmu - - ! Faire l'integration numerique de midi a minuit (le facteur 2 - ! prend en compte l'autre moitie de la journee): - DO k = 1, npts - rmu = aa + bb*cos(real(k)/real(npts)*zpi) - rmu = max(0.0, rmu) - fauxo = (1.47-acos(rmu))/.15 - alb = 0.03 + 0.630/(1.+fauxo*fauxo) - srmu = srmu + rmu*2.0 - salb = salb + alb*rmu*2.0 - END DO - IF (srmu/=0.0) THEN - albedo(i) = salb/srmu - ELSE ! nuit polaire (on peut prendre une valeur quelconque) - albedo(i) = 1.0 - END IF - END DO - - ! nouvel albedo - - ELSE - - zpi = 4.*atan(1.) - - ! Calculer la longitude vraie de l'orbite terrestre: - CALL orbite(rjour, zlonsun, zdist) - - ! Calculer la declinaison du soleil (qui varie entre + et - R_incl): - zdeclin = asin(sin(zlonsun*zpi/180.0)*sin(r_incl*zpi/180.0)) - - DO i = 1, ngrid - aa = sin(rlat(i)*zpi/180.0)*sin(zdeclin) - bb = cos(rlat(i)*zpi/180.0)*cos(zdeclin) - - ! Midi local (angle du temps = 0.0): - rmu = aa + bb*cos(0.0) - rmu = max(0.0, rmu) - ! IM cf. PB alb = 0.058/(rmu + 0.30) - ! alb = 0.058/(rmu + 0.30) * 1.5 - alb = 0.058/(rmu+0.30)*1.2 - ! alb = 0.058/(rmu + 0.30) * 1.3 - srmu = rmu - salb = alb*rmu - - ! Faire l'integration numerique de midi a minuit (le facteur 2 - ! prend en compte l'autre moitie de la journee): - DO k = 1, npts - rmu = aa + bb*cos(real(k)/real(npts)*zpi) - rmu = max(0.0, rmu) - ! IM cf. PB alb = 0.058/(rmu + 0.30) - ! alb = 0.058/(rmu + 0.30) * 1.5 - alb = 0.058/(rmu+0.30)*1.2 - ! alb = 0.058/(rmu + 0.30) * 1.3 - srmu = srmu + rmu*2.0 - salb = salb + alb*rmu*2.0 - END DO - IF (srmu/=0.0) THEN - albedo(i) = salb/srmu - ELSE ! nuit polaire (on peut prendre une valeur quelconque) - albedo(i) = 1.0 - END IF - END DO - END IF - RETURN - END SUBROUTINE alboc - ! ===================================================================== - SUBROUTINE alboc_cd(ngrid, rmu0, albedo) -!$gpum horizontal ngrid - IMPLICIT NONE - - ! Auteur(s): Z.X. Li (LMD/CNRS) - ! date: 19940624 - ! Calculer l'albedo sur l'ocean en fonction de l'angle zenithal moyen - ! Formule due a Larson and Barkstrom (1977) Proc. of the symposium - ! on radiation in the atmosphere, 19-28 August 1976, science Press, - ! 1977 pp 451-453, ou These de 3eme cycle de Sylvie Joussaume. - - ! Arguments - ! rmu0 (in): cosinus de l'angle solaire zenithal - ! albedo (out): albedo de surface de l'ocean - ! ====================================================================== - INTEGER, INTENT(IN) :: ngrid - REAL, intent(in):: rmu0(ngrid) - real, intent(out):: albedo(ngrid) - - REAL fauxo - INTEGER i - LOGICAL ancien_albedo - PARAMETER (ancien_albedo=.FALSE.) - - IF (ancien_albedo) THEN - DO i = 1, ngrid - fauxo = (1.47-acos(max(rmu0(i), 0.0)))/0.15 - albedo(i) = 0.03+.630/(1.+fauxo*fauxo) - albedo(i) = max(min(albedo(i),0.60), 0.04) - END DO - ELSE - DO i = 1, ngrid - albedo(i) = 0.058/(max(rmu0(i), 0.0)+0.30) - albedo(i) = max(min(albedo(i),0.60), 0.04) - END DO - END IF - - END SUBROUTINE alboc_cd - -end module albedo_mod Index: LMDZ6/trunk/libf/phylmd/albedo_mod.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/albedo_mod.f90 (revision 6048) +++ LMDZ6/trunk/libf/phylmd/albedo_mod.f90 (revision 6048) @@ -0,0 +1,164 @@ +! $Id$ +MODULE albedo_mod + +IMPLICIT NONE + +contains + + SUBROUTINE alboc(ngrid, rjour, rlat, albedo) +!$gpum horizontal ngrid +! USE clesphys_mod_h + USE yomcst_mod_h, ONLY : r_incl + USE orbite_mod, ONLY : orbite + IMPLICIT NONE + ! ====================================================================== + ! Auteur(s): Z.X. Li (LMD/CNRS) (adaptation du GCM du LMD) + ! Date: le 16 mars 1995 + ! Objet: Calculer l'albedo sur l'ocean + ! Methode: Integrer numeriquement l'albedo pendant une journee + + ! Arguments; + ! rjour (in,R) : jour dans l'annee (a compter du 1 janvier) + ! rlat (in,R) : latitude en degre + ! albedo (out,R): albedo obtenu (de 0 a 1) + ! ====================================================================== + INTEGER, INTENT(IN) :: ngrid + INTEGER npts ! il controle la precision de l'integration + PARAMETER (npts=120) ! 120 correspond a l'interval 6 minutes + + REAL rlat(ngrid), rjour, albedo(ngrid) + REAL zdist, zlonsun, zpi, zdeclin + REAL rmu, alb, srmu, salb, fauxo, aa, bb + INTEGER i, k + ! ccIM + LOGICAL ancien_albedo + PARAMETER (ancien_albedo=.FALSE.) + ! SAVE albedo + + IF (ancien_albedo) THEN + + zpi = 4.*atan(1.) + + ! Calculer la longitude vraie de l'orbite terrestre: + CALL orbite(rjour, zlonsun, zdist) + + ! Calculer la declinaison du soleil (qui varie entre + et - R_incl): + zdeclin = asin(sin(zlonsun*zpi/180.0)*sin(r_incl*zpi/180.0)) + + DO i = 1, ngrid + aa = sin(rlat(i)*zpi/180.0)*sin(zdeclin) + bb = cos(rlat(i)*zpi/180.0)*cos(zdeclin) + + ! Midi local (angle du temps = 0.0): + rmu = aa + bb*cos(0.0) + rmu = max(0.0, rmu) + fauxo = (1.47-acos(rmu))/.15 + alb = 0.03 + 0.630/(1.+fauxo*fauxo) + srmu = rmu + salb = alb*rmu + + ! Faire l'integration numerique de midi a minuit (le facteur 2 + ! prend en compte l'autre moitie de la journee): + DO k = 1, npts + rmu = aa + bb*cos(real(k)/real(npts)*zpi) + rmu = max(0.0, rmu) + fauxo = (1.47-acos(rmu))/.15 + alb = 0.03 + 0.630/(1.+fauxo*fauxo) + srmu = srmu + rmu*2.0 + salb = salb + alb*rmu*2.0 + END DO + IF (srmu/=0.0) THEN + albedo(i) = salb/srmu + ELSE ! nuit polaire (on peut prendre une valeur quelconque) + albedo(i) = 1.0 + END IF + END DO + + ! nouvel albedo + + ELSE + + zpi = 4.*atan(1.) + + ! Calculer la longitude vraie de l'orbite terrestre: + CALL orbite(rjour, zlonsun, zdist) + + ! Calculer la declinaison du soleil (qui varie entre + et - R_incl): + zdeclin = asin(sin(zlonsun*zpi/180.0)*sin(r_incl*zpi/180.0)) + + DO i = 1, ngrid + aa = sin(rlat(i)*zpi/180.0)*sin(zdeclin) + bb = cos(rlat(i)*zpi/180.0)*cos(zdeclin) + + ! Midi local (angle du temps = 0.0): + rmu = aa + bb*cos(0.0) + rmu = max(0.0, rmu) + ! IM cf. PB alb = 0.058/(rmu + 0.30) + ! alb = 0.058/(rmu + 0.30) * 1.5 + alb = 0.058/(rmu+0.30)*1.2 + ! alb = 0.058/(rmu + 0.30) * 1.3 + srmu = rmu + salb = alb*rmu + + ! Faire l'integration numerique de midi a minuit (le facteur 2 + ! prend en compte l'autre moitie de la journee): + DO k = 1, npts + rmu = aa + bb*cos(real(k)/real(npts)*zpi) + rmu = max(0.0, rmu) + ! IM cf. PB alb = 0.058/(rmu + 0.30) + ! alb = 0.058/(rmu + 0.30) * 1.5 + alb = 0.058/(rmu+0.30)*1.2 + ! alb = 0.058/(rmu + 0.30) * 1.3 + srmu = srmu + rmu*2.0 + salb = salb + alb*rmu*2.0 + END DO + IF (srmu/=0.0) THEN + albedo(i) = salb/srmu + ELSE ! nuit polaire (on peut prendre une valeur quelconque) + albedo(i) = 1.0 + END IF + END DO + END IF + RETURN + END SUBROUTINE alboc + ! ===================================================================== + SUBROUTINE alboc_cd(ngrid, rmu0, albedo) +!$gpum horizontal ngrid + IMPLICIT NONE + + ! Auteur(s): Z.X. Li (LMD/CNRS) + ! date: 19940624 + ! Calculer l'albedo sur l'ocean en fonction de l'angle zenithal moyen + ! Formule due a Larson and Barkstrom (1977) Proc. of the symposium + ! on radiation in the atmosphere, 19-28 August 1976, science Press, + ! 1977 pp 451-453, ou These de 3eme cycle de Sylvie Joussaume. + + ! Arguments + ! rmu0 (in): cosinus de l'angle solaire zenithal + ! albedo (out): albedo de surface de l'ocean + ! ====================================================================== + INTEGER, INTENT(IN) :: ngrid + REAL, intent(in):: rmu0(ngrid) + real, intent(out):: albedo(ngrid) + + REAL fauxo + INTEGER i + LOGICAL ancien_albedo + PARAMETER (ancien_albedo=.FALSE.) + + IF (ancien_albedo) THEN + DO i = 1, ngrid + fauxo = (1.47-acos(max(rmu0(i), 0.0)))/0.15 + albedo(i) = 0.03+.630/(1.+fauxo*fauxo) + albedo(i) = max(min(albedo(i),0.60), 0.04) + END DO + ELSE + DO i = 1, ngrid + albedo(i) = 0.058/(max(rmu0(i), 0.0)+0.30) + albedo(i) = max(min(albedo(i),0.60), 0.04) + END DO + END IF + + END SUBROUTINE alboc_cd + +end module albedo_mod Index: LMDZ6/trunk/libf/phylmd/albsno.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/albsno.f90 (revision 6047) +++ (revision ) @@ -1,68 +1,0 @@ -! -! $Header$ -! -MODULE albsno_mod - -CONTAINS - -SUBROUTINE albsno(klon, knon, dtime, agesno, alb_neig_grid, precip_snow) -!$gpum horizontal knon klon - USE clesphys_mod_h - IMPLICIT NONE - - -! Input arguments -!**************************************************************************************** - INTEGER, INTENT(IN) :: klon, knon - REAL, INTENT(IN) :: dtime - REAL, DIMENSION(klon), INTENT(IN) :: precip_snow - -! In/Output arguments -!**************************************************************************************** - REAL, DIMENSION(klon), INTENT(INOUT) :: agesno - -! Output arguments -!**************************************************************************************** - REAL, DIMENSION(klon), INTENT(OUT) :: alb_neig_grid - -! Local variables -!**************************************************************************************** - INTEGER :: i, nv - INTEGER, PARAMETER :: nvm = 8 - REAL :: as - REAL, DIMENSION(klon,nvm) :: veget - REAL, DIMENSION(nvm) :: init - REAL, DIMENSION(nvm) :: decay - -!**************************************************************************************** - init = (/0.55, 0.14, 0.18, 0.29, 0.15, 0.15, 0.14, 0./) - decay = (/0.30, 0.67, 0.63, 0.45, 0.40, 0.14, 0.06, 1./) - - if (albsno0>=0.) then - init(:)=albsno0 - decay(:)=0. - endif - - veget = 0. - veget(:,1) = 1. ! desert partout - DO i = 1, knon - alb_neig_grid(i) = 0.0 - ENDDO - DO nv = 1, nvm - DO i = 1, knon - as = init(nv)+decay(nv)*EXP(-agesno(i)/5.) - alb_neig_grid(i) = alb_neig_grid(i) + veget(i,nv)*as - ENDDO - ENDDO - - -! modilation en fonction de l'age de la neige - DO i = 1, knon - agesno(i) = (agesno(i) + (1.-agesno(i)/50.)*dtime/86400.)& - & * EXP(-1.*MAX(0.0,precip_snow(i))*dtime/0.3) - agesno(i) = MAX(agesno(i),0.0) - ENDDO - -END SUBROUTINE albsno - -END MODULE albsno_mod Index: LMDZ6/trunk/libf/phylmd/albsno_mod.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/albsno_mod.f90 (revision 6048) +++ LMDZ6/trunk/libf/phylmd/albsno_mod.f90 (revision 6048) @@ -0,0 +1,68 @@ +! +! $Header$ +! +MODULE albsno_mod + +CONTAINS + +SUBROUTINE albsno(klon, knon, dtime, agesno, alb_neig_grid, precip_snow) +!$gpum horizontal knon klon + USE clesphys_mod_h + IMPLICIT NONE + + +! Input arguments +!**************************************************************************************** + INTEGER, INTENT(IN) :: klon, knon + REAL, INTENT(IN) :: dtime + REAL, DIMENSION(klon), INTENT(IN) :: precip_snow + +! In/Output arguments +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(INOUT) :: agesno + +! Output arguments +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(OUT) :: alb_neig_grid + +! Local variables +!**************************************************************************************** + INTEGER :: i, nv + INTEGER, PARAMETER :: nvm = 8 + REAL :: as + REAL, DIMENSION(klon,nvm) :: veget + REAL, DIMENSION(nvm) :: init + REAL, DIMENSION(nvm) :: decay + +!**************************************************************************************** + init = (/0.55, 0.14, 0.18, 0.29, 0.15, 0.15, 0.14, 0./) + decay = (/0.30, 0.67, 0.63, 0.45, 0.40, 0.14, 0.06, 1./) + + if (albsno0>=0.) then + init(:)=albsno0 + decay(:)=0. + endif + + veget = 0. + veget(:,1) = 1. ! desert partout + DO i = 1, knon + alb_neig_grid(i) = 0.0 + ENDDO + DO nv = 1, nvm + DO i = 1, knon + as = init(nv)+decay(nv)*EXP(-agesno(i)/5.) + alb_neig_grid(i) = alb_neig_grid(i) + veget(i,nv)*as + ENDDO + ENDDO + + +! modilation en fonction de l'age de la neige + DO i = 1, knon + agesno(i) = (agesno(i) + (1.-agesno(i)/50.)*dtime/86400.)& + & * EXP(-1.*MAX(0.0,precip_snow(i))*dtime/0.3) + agesno(i) = MAX(agesno(i),0.0) + ENDDO + +END SUBROUTINE albsno + +END MODULE albsno_mod Index: LMDZ6/trunk/libf/phylmd/alpale_th.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/alpale_th.f90 (revision 6047) +++ (revision ) @@ -1,362 +1,0 @@ -! -! $Id$ -! -!$gpum horizontal klon -MODULE alpale_th_mod - PRIVATE - - LOGICAL, SAVE :: first = .TRUE. - !$OMP THREADPRIVATE(first) - LOGICAL, SAVE :: multiply_proba_notrig = .FALSE. - !$OMP THREADPRIVATE(multiply_proba_notrig) - REAL, SAVE :: random_notrig_max=1. - !$OMP THREADPRIVATE(random_notrig_max) - REAL, SAVE :: cv_feed_area - !$OMP THREADPRIVATE(cv_feed_area) - - PUBLIC alpale_th, alpale_th_first - - CONTAINS - -SUBROUTINE alpale_th_first() - - USE alpale_mod, ONLY: iflag_clos_bl - USE ioipsl_getin_p_mod, ONLY : getin_p - - IMPLICIT NONE - - IF (first) THEN - CALL getin_p('multiply_proba_notrig',multiply_proba_notrig) - IF (iflag_clos_bl .LT. 3) THEN - random_notrig_max=1. - CALL getin_p('random_notrig_max',random_notrig_max) - ELSEIF (iflag_clos_bl .EQ. 3) THEN ! (iflag_clos_bl .LT. 3) - cv_feed_area = 1.e10 ! m2 - CALL getin_p('cv_feed_area', cv_feed_area) - ENDIF !! (iflag_clos_bl .LT. 3) - first = .FALSE. - ENDIF - -END SUBROUTINE alpale_th_first - -SUBROUTINE alpale_th ( dtime, lmax_th, t_seri, cell_area, & - cin, s2, n2, strig, & - ale_bl_trig, ale_bl_stat, ale_bl, & - alp_bl, alp_bl_stat, & - proba_notrig, random_notrig, birth_rate) - -! ************************************************************** -! * -! ALPALE_TH * -! * -! * -! written by : Jean-Yves Grandpeix, 11/05/2016 * -! modified by : * -! ************************************************************** - - USE dimphy - USE print_control_mod, ONLY: mydebug=>debug , lunout, prt_level - USE alpale_mod, ONLY: iflag_clos_bl, iflag_coupl, iflag_trig_bl, s_trig, tau_trig_deep, tau_trig_shallow - IMPLICIT NONE - -!================================================================ -! Auteur(s) : Jean-Yves Grandpeix, 11/05/2016 -! Objet : Contribution of the thermal scheme to Ale and Alp -!================================================================ - -! Input arguments -!---------------- - REAL, INTENT(IN) :: dtime - REAL, DIMENSION(klon), INTENT(IN) :: cell_area - INTEGER, DIMENSION(klon), INTENT(IN) :: lmax_th - REAL, DIMENSION(klon,klev), INTENT(IN) :: t_seri - REAL, DIMENSION(klon), INTENT(IN) :: ale_bl_stat - REAL, DIMENSION(klon), INTENT(IN) :: cin - REAL, DIMENSION(klon), INTENT(IN) :: s2, n2, strig - - REAL, DIMENSION(klon), INTENT(INOUT) :: ale_bl_trig, ale_bl - REAL, DIMENSION(klon), INTENT(INOUT) :: alp_bl - REAL, DIMENSION(klon), INTENT(INOUT) :: alp_bl_stat - REAL, DIMENSION(klon), INTENT(INOUT) :: proba_notrig - - REAL, DIMENSION(klon), INTENT(OUT) :: random_notrig - - REAL, DIMENSION(klon), INTENT(OUT) :: birth_rate - -! Local variables -!---------------- - INTEGER :: i - REAL :: birth_number - REAL, DIMENSION(klon) :: ale_bl_ref - REAL, DIMENSION(klon) :: tau_trig - - REAL umexp ! expression of (1.-exp(-x))/x valid for all x, especially when x->0 - REAL x -! - CHARACTER (LEN=20), PARAMETER :: modname='alpale_th' - CHARACTER (LEN=80) :: abort_message - - umexp(x) = max(sign(1.,x-1.e-3),0.)*(1.-exp(-x))/max(x,1.e-3) + & - (1.-max(sign(1.,x-1.e-3),0.))*(1.-0.5*x*(1.-x/3.*(1.-0.25*x))) !!! correct formula (jyg) -!!! (1.-max(sign(1.,x-1.e-3),0.))*(-0.5*x*(1.-x/3.*(1.-0.25*x))) !!! bug introduced by mistake (jyg) -!!! (1.-max(sign(1.,x-1.e-3),0.))*(1.-0.5*x*(1.-x/3.*(1.-0.25*x))) !!! initial correct formula (jyg) -! -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -! JYG, 20160513 : Introduction of the Effective Lifting Power (ELP), which -! takes into account the area (cv_feed_area) covered by thermals contributing -! to each cumulonimbus. -! The use of ELP prevents singularities when the trigger probability tends to -! zero. It is activated by iflag_clos_bl = 3. -! The ELP values are stored in the ALP_bl variable. -! -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -! - -!! -!! Control of the multiplication of no-trigger probabilities between calls -!! to the convection scheme. If multiply_proba_notrig is .false., then -!! proba_notrig is set to 1 at each call to alpale_th, so that only the last call -!! plays a role in the triggering of convection. If it is .true., then propa_notrig -!! is saved between calls to convection and is reset to 1 only after calling the -!! convection scheme. -!! For instance, if the probability of no_trigger is 0.9 at each call, and if -!! there are 3 calls to alpale_th between calls to the convection scheme, then the -!! probability of triggering convection will be 0.1 (= 1.-0.9) if -!! multiply_proba_notrig is .false. and 0.271 (= 1.-0.9^3) if multiply_proba_notrig -!! is .true. -!! - IF (.NOT.multiply_proba_notrig) THEN - DO i=1,klon - proba_notrig(i)=1. - ENDDO - ENDIF !! (.NOT.multiply_proba_notrig) -!! -!! -!--------------------------------------- - IF (iflag_clos_bl .LT. 3) THEN -!--------------------------------------- -! -! Original code (Nicolas Rochetin) -! -------------------------------- - !cc nrlmd le 10/04/2012 - !-----------Stochastic triggering----------- - if (iflag_trig_bl.ge.1) then - ! - IF (prt_level .GE. 10) THEN - WRITE(lunout,*)'cin, ale_bl_stat, alp_bl, alp_bl_stat ', & - cin, ale_bl_stat, alp_bl, alp_bl_stat - ENDIF - - - !----Initialisations - do i=1,klon -!!jyg proba_notrig(i)=1. - random_notrig(i)=1e6*ale_bl_stat(i)-int(1e6*ale_bl_stat(i)) - if ( random_notrig(i) > random_notrig_max ) random_notrig(i)=0. - if ( ale_bl_trig(i) .lt. abs(cin(i))+1.e-10 ) then - tau_trig(i)=tau_trig_shallow - else - tau_trig(i)=tau_trig_deep - endif - enddo - ! - IF (prt_level .GE. 10) THEN - WRITE(lunout,*)'random_notrig, tau_trig ', & - random_notrig, tau_trig - WRITE(lunout,*)'s_trig,s2,n2 ', & - s_trig,s2,n2 - ENDIF - - !Option pour re-activer l'ancien calcul de Ale_bl (iflag_trig_bl=2) - IF (iflag_trig_bl.eq.1) then - - !----Tirage al\'eatoire et calcul de ale_bl_trig - do i=1,klon - if ( (ale_bl_stat(i) .gt. abs(cin(i))+1.e-10) ) then - proba_notrig(i)=proba_notrig(i)* & - (1.-exp(-strig(i)/s2(i)))**(n2(i)*dtime/tau_trig(i)) - ! print *, 'proba_notrig(i) ',proba_notrig(i) - if (random_notrig(i) .ge. proba_notrig(i)) then - ale_bl_trig(i)=ale_bl_stat(i) - else - ale_bl_trig(i)=0. - endif - birth_rate(i) = n2(i)*exp(-strig(i)/s2(i))/(tau_trig(i)*cell_area(i)) -!!! birth_rate(i) = max(birth_rate(i),1.e-18) - else -!!jyg proba_notrig(i)=1. - birth_rate(i) = 0. - random_notrig(i)=0. - ale_bl_trig(i)=0. - endif - enddo - - ELSE IF (iflag_trig_bl.ge.2) then - - do i=1,klon - if ( (Ale_bl(i) .gt. abs(cin(i))+1.e-10) ) then - proba_notrig(i)=proba_notrig(i)* & - (1.-exp(-strig(i)/s2(i)))**(n2(i)*dtime/tau_trig(i)) - ! print *, 'proba_notrig(i) ',proba_notrig(i) - if (random_notrig(i) .ge. proba_notrig(i)) then - ale_bl_trig(i)=Ale_bl(i) - else - ale_bl_trig(i)=0. - endif - birth_rate(i) = n2(i)*exp(-strig(i)/s2(i))/(tau_trig(i)*cell_area(i)) -!!! birth_rate(i) = max(birth_rate(i),1.e-18) - else -!!jyg proba_notrig(i)=1. - birth_rate(i) = 0. - random_notrig(i)=0. - ale_bl_trig(i)=0. - endif - enddo - - ENDIF - - ! - IF (prt_level .GE. 10) THEN - WRITE(lunout,*)'proba_notrig, ale_bl_trig ', & - proba_notrig, ale_bl_trig - ENDIF - - endif !(iflag_trig_bl) - - !-----------Statistical closure----------- - if (iflag_clos_bl.eq.1) then - - do i=1,klon - !CR: alp probabiliste - if (ale_bl_trig(i).gt.0.) then - alp_bl(i)=alp_bl(i)/(1.-min(proba_notrig(i),0.999)) - endif - enddo - - else if (iflag_clos_bl.eq.2) then - - !CR: alp calculee dans thermcell_main - do i=1,klon - alp_bl(i)=alp_bl_stat(i) - enddo - - else - - alp_bl_stat(:)=0. - - endif !(iflag_clos_bl) - -! -!--------------------------------------- - ELSEIF (iflag_clos_bl .EQ. 3) THEN ! (iflag_clos_bl .LT. 3) -!--------------------------------------- -! -! New code with Effective Lifting Power -! ------------------------------------- - - !-----------Stochastic triggering----------- - if (iflag_trig_bl.ge.1) then - ! - IF (prt_level .GE. 10) THEN - WRITE(lunout,*)'cin, ale_bl_stat, alp_bl_stat ', & - cin, ale_bl_stat, alp_bl_stat - ENDIF - - ! Use ale_bl_stat (Rochetin's code) or ale_bl (old code) according to - ! iflag_trig_bl value. - IF (iflag_trig_bl.eq.1) then ! use ale_bl_stat (Rochetin computation) - do i=1,klon - ale_bl_ref(i)=ale_bl_stat(i) - enddo - ELSE IF (iflag_trig_bl.ge.2) then ! use ale_bl (old computation) - do i=1,klon - ale_bl_ref(i)=Ale_bl(i) - enddo - ENDIF ! (iflag_trig_bl.eq.1) - - - !----Initializations and random number generation - do i=1,klon -!!jyg proba_notrig(i)=1. - random_notrig(i)=1e6*ale_bl_stat(i)-int(1e6*ale_bl_stat(i)) - if ( ale_bl_trig(i) .lt. abs(cin(i))+1.e-10 ) then - tau_trig(i)=tau_trig_shallow - else - tau_trig(i)=tau_trig_deep - endif - enddo - ! - IF (prt_level .GE. 10) THEN - WRITE(lunout,*)'random_notrig, tau_trig ', & - random_notrig, tau_trig - WRITE(lunout,*)'s_trig,s2,n2 ', & - s_trig,s2,n2 - ENDIF - - !----alp_bl computation - do i=1,klon - if ( (ale_bl_ref(i) .gt. abs(cin(i))+1.e-10) ) then - birth_number = n2(i)*exp(-strig(i)/s2(i)) - birth_rate(i) = birth_number/(tau_trig(i)*cell_area(i)) -!!! birth_rate(i) = max(birth_rate(i),1.e-18) - proba_notrig(i)=proba_notrig(i)*exp(-birth_number*dtime/tau_trig(i)) - Alp_bl(i) = Alp_bl(i)* & - umexp(-birth_number*cv_feed_area/cell_area(i))/ & - umexp(-birth_number*dtime/tau_trig(i))* & - tau_trig(i)*cv_feed_area/(dtime*cell_area(i)) - else -!!jyg proba_notrig(i)=1. - birth_rate(i)=0. - random_notrig(i)=0. - alp_bl(i)=0. - endif - enddo - - !----ale_bl_trig computation - do i=1,klon - if (random_notrig(i) .ge. proba_notrig(i)) then - ale_bl_trig(i)=ale_bl_ref(i) - else - ale_bl_trig(i)=0. - endif - enddo - - ! - IF (prt_level .GE. 10) THEN - WRITE(lunout,*)'proba_notrig, ale_bl_trig ', & - proba_notrig, ale_bl_trig - ENDIF - - endif !(iflag_trig_bl .ge. 1) - -!--------------------------------------- - ENDIF ! (iflag_clos_bl .LT. 3) -!--------------------------------------- - - IF (prt_level .GE. 10) THEN - WRITE(lunout,*)'alpale_th: ale_bl_trig, alp_bl_stat, birth_rate ', & - ale_bl_trig(1), alp_bl_stat(1), birth_rate(1) - ENDIF - - !cc fin nrlmd le 10/04/2012 -! - !IM/FH: 2011/02/23 - ! Couplage Thermiques/Emanuel seulement si T<0 - if (iflag_coupl==2) then - IF (prt_level .GE. 10) THEN - WRITE(lunout,*)'Couplage Thermiques/Emanuel seulement si T<0' - ENDIF - do i=1,klon - if (t_seri(i,lmax_th(i))>273.) then - Ale_bl(i)=0. - endif - enddo -! print *,'In order to run with iflag_coupl=2, you have to comment out the following stop' -! STOP - abort_message='In order to run with iflag_coupl=2, you have to comment out the following abort' - CALL abort_physic(modname,abort_message,1) - endif - RETURN - END SUBROUTINE alpale_th - -END MODULE alpale_th_mod Index: LMDZ6/trunk/libf/phylmd/alpale_th_mod.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/alpale_th_mod.f90 (revision 6048) +++ LMDZ6/trunk/libf/phylmd/alpale_th_mod.f90 (revision 6048) @@ -0,0 +1,362 @@ +! +! $Id$ +! +!$gpum horizontal klon +MODULE alpale_th_mod + PRIVATE + + LOGICAL, SAVE :: first = .TRUE. + !$OMP THREADPRIVATE(first) + LOGICAL, SAVE :: multiply_proba_notrig = .FALSE. + !$OMP THREADPRIVATE(multiply_proba_notrig) + REAL, SAVE :: random_notrig_max=1. + !$OMP THREADPRIVATE(random_notrig_max) + REAL, SAVE :: cv_feed_area + !$OMP THREADPRIVATE(cv_feed_area) + + PUBLIC alpale_th, alpale_th_first + + CONTAINS + +SUBROUTINE alpale_th_first() + + USE alpale_mod, ONLY: iflag_clos_bl + USE ioipsl_getin_p_mod, ONLY : getin_p + + IMPLICIT NONE + + IF (first) THEN + CALL getin_p('multiply_proba_notrig',multiply_proba_notrig) + IF (iflag_clos_bl .LT. 3) THEN + random_notrig_max=1. + CALL getin_p('random_notrig_max',random_notrig_max) + ELSEIF (iflag_clos_bl .EQ. 3) THEN ! (iflag_clos_bl .LT. 3) + cv_feed_area = 1.e10 ! m2 + CALL getin_p('cv_feed_area', cv_feed_area) + ENDIF !! (iflag_clos_bl .LT. 3) + first = .FALSE. + ENDIF + +END SUBROUTINE alpale_th_first + +SUBROUTINE alpale_th ( dtime, lmax_th, t_seri, cell_area, & + cin, s2, n2, strig, & + ale_bl_trig, ale_bl_stat, ale_bl, & + alp_bl, alp_bl_stat, & + proba_notrig, random_notrig, birth_rate) + +! ************************************************************** +! * +! ALPALE_TH * +! * +! * +! written by : Jean-Yves Grandpeix, 11/05/2016 * +! modified by : * +! ************************************************************** + + USE dimphy + USE print_control_mod, ONLY: mydebug=>debug , lunout, prt_level + USE alpale_mod, ONLY: iflag_clos_bl, iflag_coupl, iflag_trig_bl, s_trig, tau_trig_deep, tau_trig_shallow + IMPLICIT NONE + +!================================================================ +! Auteur(s) : Jean-Yves Grandpeix, 11/05/2016 +! Objet : Contribution of the thermal scheme to Ale and Alp +!================================================================ + +! Input arguments +!---------------- + REAL, INTENT(IN) :: dtime + REAL, DIMENSION(klon), INTENT(IN) :: cell_area + INTEGER, DIMENSION(klon), INTENT(IN) :: lmax_th + REAL, DIMENSION(klon,klev), INTENT(IN) :: t_seri + REAL, DIMENSION(klon), INTENT(IN) :: ale_bl_stat + REAL, DIMENSION(klon), INTENT(IN) :: cin + REAL, DIMENSION(klon), INTENT(IN) :: s2, n2, strig + + REAL, DIMENSION(klon), INTENT(INOUT) :: ale_bl_trig, ale_bl + REAL, DIMENSION(klon), INTENT(INOUT) :: alp_bl + REAL, DIMENSION(klon), INTENT(INOUT) :: alp_bl_stat + REAL, DIMENSION(klon), INTENT(INOUT) :: proba_notrig + + REAL, DIMENSION(klon), INTENT(OUT) :: random_notrig + + REAL, DIMENSION(klon), INTENT(OUT) :: birth_rate + +! Local variables +!---------------- + INTEGER :: i + REAL :: birth_number + REAL, DIMENSION(klon) :: ale_bl_ref + REAL, DIMENSION(klon) :: tau_trig + + REAL umexp ! expression of (1.-exp(-x))/x valid for all x, especially when x->0 + REAL x +! + CHARACTER (LEN=20), PARAMETER :: modname='alpale_th' + CHARACTER (LEN=80) :: abort_message + + umexp(x) = max(sign(1.,x-1.e-3),0.)*(1.-exp(-x))/max(x,1.e-3) + & + (1.-max(sign(1.,x-1.e-3),0.))*(1.-0.5*x*(1.-x/3.*(1.-0.25*x))) !!! correct formula (jyg) +!!! (1.-max(sign(1.,x-1.e-3),0.))*(-0.5*x*(1.-x/3.*(1.-0.25*x))) !!! bug introduced by mistake (jyg) +!!! (1.-max(sign(1.,x-1.e-3),0.))*(1.-0.5*x*(1.-x/3.*(1.-0.25*x))) !!! initial correct formula (jyg) +! +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +! JYG, 20160513 : Introduction of the Effective Lifting Power (ELP), which +! takes into account the area (cv_feed_area) covered by thermals contributing +! to each cumulonimbus. +! The use of ELP prevents singularities when the trigger probability tends to +! zero. It is activated by iflag_clos_bl = 3. +! The ELP values are stored in the ALP_bl variable. +! +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +! + +!! +!! Control of the multiplication of no-trigger probabilities between calls +!! to the convection scheme. If multiply_proba_notrig is .false., then +!! proba_notrig is set to 1 at each call to alpale_th, so that only the last call +!! plays a role in the triggering of convection. If it is .true., then propa_notrig +!! is saved between calls to convection and is reset to 1 only after calling the +!! convection scheme. +!! For instance, if the probability of no_trigger is 0.9 at each call, and if +!! there are 3 calls to alpale_th between calls to the convection scheme, then the +!! probability of triggering convection will be 0.1 (= 1.-0.9) if +!! multiply_proba_notrig is .false. and 0.271 (= 1.-0.9^3) if multiply_proba_notrig +!! is .true. +!! + IF (.NOT.multiply_proba_notrig) THEN + DO i=1,klon + proba_notrig(i)=1. + ENDDO + ENDIF !! (.NOT.multiply_proba_notrig) +!! +!! +!--------------------------------------- + IF (iflag_clos_bl .LT. 3) THEN +!--------------------------------------- +! +! Original code (Nicolas Rochetin) +! -------------------------------- + !cc nrlmd le 10/04/2012 + !-----------Stochastic triggering----------- + if (iflag_trig_bl.ge.1) then + ! + IF (prt_level .GE. 10) THEN + WRITE(lunout,*)'cin, ale_bl_stat, alp_bl, alp_bl_stat ', & + cin, ale_bl_stat, alp_bl, alp_bl_stat + ENDIF + + + !----Initialisations + do i=1,klon +!!jyg proba_notrig(i)=1. + random_notrig(i)=1e6*ale_bl_stat(i)-int(1e6*ale_bl_stat(i)) + if ( random_notrig(i) > random_notrig_max ) random_notrig(i)=0. + if ( ale_bl_trig(i) .lt. abs(cin(i))+1.e-10 ) then + tau_trig(i)=tau_trig_shallow + else + tau_trig(i)=tau_trig_deep + endif + enddo + ! + IF (prt_level .GE. 10) THEN + WRITE(lunout,*)'random_notrig, tau_trig ', & + random_notrig, tau_trig + WRITE(lunout,*)'s_trig,s2,n2 ', & + s_trig,s2,n2 + ENDIF + + !Option pour re-activer l'ancien calcul de Ale_bl (iflag_trig_bl=2) + IF (iflag_trig_bl.eq.1) then + + !----Tirage al\'eatoire et calcul de ale_bl_trig + do i=1,klon + if ( (ale_bl_stat(i) .gt. abs(cin(i))+1.e-10) ) then + proba_notrig(i)=proba_notrig(i)* & + (1.-exp(-strig(i)/s2(i)))**(n2(i)*dtime/tau_trig(i)) + ! print *, 'proba_notrig(i) ',proba_notrig(i) + if (random_notrig(i) .ge. proba_notrig(i)) then + ale_bl_trig(i)=ale_bl_stat(i) + else + ale_bl_trig(i)=0. + endif + birth_rate(i) = n2(i)*exp(-strig(i)/s2(i))/(tau_trig(i)*cell_area(i)) +!!! birth_rate(i) = max(birth_rate(i),1.e-18) + else +!!jyg proba_notrig(i)=1. + birth_rate(i) = 0. + random_notrig(i)=0. + ale_bl_trig(i)=0. + endif + enddo + + ELSE IF (iflag_trig_bl.ge.2) then + + do i=1,klon + if ( (Ale_bl(i) .gt. abs(cin(i))+1.e-10) ) then + proba_notrig(i)=proba_notrig(i)* & + (1.-exp(-strig(i)/s2(i)))**(n2(i)*dtime/tau_trig(i)) + ! print *, 'proba_notrig(i) ',proba_notrig(i) + if (random_notrig(i) .ge. proba_notrig(i)) then + ale_bl_trig(i)=Ale_bl(i) + else + ale_bl_trig(i)=0. + endif + birth_rate(i) = n2(i)*exp(-strig(i)/s2(i))/(tau_trig(i)*cell_area(i)) +!!! birth_rate(i) = max(birth_rate(i),1.e-18) + else +!!jyg proba_notrig(i)=1. + birth_rate(i) = 0. + random_notrig(i)=0. + ale_bl_trig(i)=0. + endif + enddo + + ENDIF + + ! + IF (prt_level .GE. 10) THEN + WRITE(lunout,*)'proba_notrig, ale_bl_trig ', & + proba_notrig, ale_bl_trig + ENDIF + + endif !(iflag_trig_bl) + + !-----------Statistical closure----------- + if (iflag_clos_bl.eq.1) then + + do i=1,klon + !CR: alp probabiliste + if (ale_bl_trig(i).gt.0.) then + alp_bl(i)=alp_bl(i)/(1.-min(proba_notrig(i),0.999)) + endif + enddo + + else if (iflag_clos_bl.eq.2) then + + !CR: alp calculee dans thermcell_main + do i=1,klon + alp_bl(i)=alp_bl_stat(i) + enddo + + else + + alp_bl_stat(:)=0. + + endif !(iflag_clos_bl) + +! +!--------------------------------------- + ELSEIF (iflag_clos_bl .EQ. 3) THEN ! (iflag_clos_bl .LT. 3) +!--------------------------------------- +! +! New code with Effective Lifting Power +! ------------------------------------- + + !-----------Stochastic triggering----------- + if (iflag_trig_bl.ge.1) then + ! + IF (prt_level .GE. 10) THEN + WRITE(lunout,*)'cin, ale_bl_stat, alp_bl_stat ', & + cin, ale_bl_stat, alp_bl_stat + ENDIF + + ! Use ale_bl_stat (Rochetin's code) or ale_bl (old code) according to + ! iflag_trig_bl value. + IF (iflag_trig_bl.eq.1) then ! use ale_bl_stat (Rochetin computation) + do i=1,klon + ale_bl_ref(i)=ale_bl_stat(i) + enddo + ELSE IF (iflag_trig_bl.ge.2) then ! use ale_bl (old computation) + do i=1,klon + ale_bl_ref(i)=Ale_bl(i) + enddo + ENDIF ! (iflag_trig_bl.eq.1) + + + !----Initializations and random number generation + do i=1,klon +!!jyg proba_notrig(i)=1. + random_notrig(i)=1e6*ale_bl_stat(i)-int(1e6*ale_bl_stat(i)) + if ( ale_bl_trig(i) .lt. abs(cin(i))+1.e-10 ) then + tau_trig(i)=tau_trig_shallow + else + tau_trig(i)=tau_trig_deep + endif + enddo + ! + IF (prt_level .GE. 10) THEN + WRITE(lunout,*)'random_notrig, tau_trig ', & + random_notrig, tau_trig + WRITE(lunout,*)'s_trig,s2,n2 ', & + s_trig,s2,n2 + ENDIF + + !----alp_bl computation + do i=1,klon + if ( (ale_bl_ref(i) .gt. abs(cin(i))+1.e-10) ) then + birth_number = n2(i)*exp(-strig(i)/s2(i)) + birth_rate(i) = birth_number/(tau_trig(i)*cell_area(i)) +!!! birth_rate(i) = max(birth_rate(i),1.e-18) + proba_notrig(i)=proba_notrig(i)*exp(-birth_number*dtime/tau_trig(i)) + Alp_bl(i) = Alp_bl(i)* & + umexp(-birth_number*cv_feed_area/cell_area(i))/ & + umexp(-birth_number*dtime/tau_trig(i))* & + tau_trig(i)*cv_feed_area/(dtime*cell_area(i)) + else +!!jyg proba_notrig(i)=1. + birth_rate(i)=0. + random_notrig(i)=0. + alp_bl(i)=0. + endif + enddo + + !----ale_bl_trig computation + do i=1,klon + if (random_notrig(i) .ge. proba_notrig(i)) then + ale_bl_trig(i)=ale_bl_ref(i) + else + ale_bl_trig(i)=0. + endif + enddo + + ! + IF (prt_level .GE. 10) THEN + WRITE(lunout,*)'proba_notrig, ale_bl_trig ', & + proba_notrig, ale_bl_trig + ENDIF + + endif !(iflag_trig_bl .ge. 1) + +!--------------------------------------- + ENDIF ! (iflag_clos_bl .LT. 3) +!--------------------------------------- + + IF (prt_level .GE. 10) THEN + WRITE(lunout,*)'alpale_th: ale_bl_trig, alp_bl_stat, birth_rate ', & + ale_bl_trig(1), alp_bl_stat(1), birth_rate(1) + ENDIF + + !cc fin nrlmd le 10/04/2012 +! + !IM/FH: 2011/02/23 + ! Couplage Thermiques/Emanuel seulement si T<0 + if (iflag_coupl==2) then + IF (prt_level .GE. 10) THEN + WRITE(lunout,*)'Couplage Thermiques/Emanuel seulement si T<0' + ENDIF + do i=1,klon + if (t_seri(i,lmax_th(i))>273.) then + Ale_bl(i)=0. + endif + enddo +! print *,'In order to run with iflag_coupl=2, you have to comment out the following stop' +! STOP + abort_message='In order to run with iflag_coupl=2, you have to comment out the following abort' + CALL abort_physic(modname,abort_message,1) + endif + RETURN + END SUBROUTINE alpale_th + +END MODULE alpale_th_mod Index: LMDZ6/trunk/libf/phylmd/alpale_wk.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/alpale_wk.f90 (revision 6047) +++ (revision ) @@ -1,103 +1,0 @@ -!$gpum horizontal klon -MODULE alpale_wk_mod - PRIVATE - - LOGICAL, SAVE :: first = .TRUE. - !$OMP THREADPRIVATE(first) - REAL, ALLOCATABLE, SAVE, DIMENSION(:) :: cellrad - !$OMP THREADPRIVATE(cellrad) - - PUBLIC alpale_wk, alpale_wk_first - - CONTAINS - -SUBROUTINE alpale_wk_first(cell_area) - - USE dimphy, ONLY: klon - USE yomcst_mod_h, ONLY: rpi - - IMPLICIT NONE - REAL, DIMENSION(klon), INTENT(IN) :: cell_area - - IF (first) THEN - ALLOCATE (cellrad(klon)) - ! Compute pseudo grid-cell radius cellrad, such that pi*cellrad^2=cell_area - print *,'alpale_wk: cell_area(1) ',cell_area(1) - cellrad(:)=sqrt(cell_area(:)/rpi) - first = .FALSE. - ENDIF - -END SUBROUTINE alpale_wk_first - -SUBROUTINE alpale_wk ( dtime, cell_area, zoccur, sigmaw, wdens, fip , & - fip_cond) - -! ************************************************************** -! * -! ALPALE_WK * -! * -! * -! written by : Jean-Yves Grandpeix, 07/08/2017 * -! modified by : * -! ************************************************************** - - USE dimphy, ONLY: klon - USE ioipsl_getin_p_mod, ONLY : getin_p - USE print_control_mod, ONLY: mydebug=>debug , lunout, prt_level - USE yomcst_mod_h, ONLY: rpi - - IMPLICIT NONE - -!================================================================ -! Auteur(s) : Jean-Yves Grandpeix, 07/08/2017 -! Objet : Contribution of the wake scheme to Ale and Alp -!================================================================ - -! Input arguments -!---------------- - REAL, INTENT(IN) :: dtime - REAL, DIMENSION(klon), INTENT(IN) :: cell_area - INTEGER, DIMENSION(klon), INTENT (IN) :: zoccur - REAL, DIMENSION(klon), INTENT(IN) :: sigmaw - REAL, DIMENSION(klon), INTENT(IN) :: wdens - REAL, DIMENSION(klon), INTENT(IN) :: fip -! Output arguments -!----------------- - REAL, DIMENSION(klon), INTENT(OUT) :: fip_cond - - -! Local variables -!---------------- - INTEGER :: i - REAL, DIMENSION(klon) :: wkrad - REAL, DIMENSION(klon) :: proba_gf - -! Compute wake radius -!! print *,'alpale_wk: sigmaw(1), wdens(1) ', sigmaw(1), wdens(1) - DO i = 1,klon - IF (zoccur(i) .GE. 1) THEN - wkrad(i) = sqrt(sigmaw(i)/(rpi*wdens(i))) - ELSE - wkrad(i) = 0. - ENDIF ! (zoccur(i) .GE. 1) - ENDDO - -! Compute probability that the grid-cell is intersected by a gust front -!! print *,'alpale_wk: wkrad(1), cellrad(1) ', wkrad(1), cellrad(1) -!! proba_gf(:) = exp(-wdens(:)*rpi*max(wkrad(:)-cellrad(:),0.)**2) - & ! Formules -!! exp(-wdens(:)*rpi*(wkrad(:)+cellrad(:))**2) ! fausses ! - proba_gf(:) = 1. - exp(-wdens(:)*rpi*((wkrad(:)+cellrad(:))**2 - & - max(wkrad(:)-cellrad(:),0.)**2) ) -! - proba_gf(:) = max(proba_gf(:),1.e-3) -! Compute Fip conditionned on the presence of some gust front within the -! grid-cell -!! print *,'alpale_wk: proba_gf(1), fip(1), ', proba_gf(1), fip(1) - fip_cond(:) = fip(:)/proba_gf(:) -!! print *,'alpale_wk: wkrad(1), cellrad(1), proba_gf(1), fip(1), fip_cond(1) ', & -!! wkrad(1), cellrad(1), proba_gf(1), fip(1), fip_cond(1) - - RETURN - END SUBROUTINE alpale_wk - -END MODULE alpale_wk_mod Index: LMDZ6/trunk/libf/phylmd/alpale_wk_mod.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/alpale_wk_mod.f90 (revision 6048) +++ LMDZ6/trunk/libf/phylmd/alpale_wk_mod.f90 (revision 6048) @@ -0,0 +1,103 @@ +!$gpum horizontal klon +MODULE alpale_wk_mod + PRIVATE + + LOGICAL, SAVE :: first = .TRUE. + !$OMP THREADPRIVATE(first) + REAL, ALLOCATABLE, SAVE, DIMENSION(:) :: cellrad + !$OMP THREADPRIVATE(cellrad) + + PUBLIC alpale_wk, alpale_wk_first + + CONTAINS + +SUBROUTINE alpale_wk_first(cell_area) + + USE dimphy, ONLY: klon + USE yomcst_mod_h, ONLY: rpi + + IMPLICIT NONE + REAL, DIMENSION(klon), INTENT(IN) :: cell_area + + IF (first) THEN + ALLOCATE (cellrad(klon)) + ! Compute pseudo grid-cell radius cellrad, such that pi*cellrad^2=cell_area + print *,'alpale_wk: cell_area(1) ',cell_area(1) + cellrad(:)=sqrt(cell_area(:)/rpi) + first = .FALSE. + ENDIF + +END SUBROUTINE alpale_wk_first + +SUBROUTINE alpale_wk ( dtime, cell_area, zoccur, sigmaw, wdens, fip , & + fip_cond) + +! ************************************************************** +! * +! ALPALE_WK * +! * +! * +! written by : Jean-Yves Grandpeix, 07/08/2017 * +! modified by : * +! ************************************************************** + + USE dimphy, ONLY: klon + USE ioipsl_getin_p_mod, ONLY : getin_p + USE print_control_mod, ONLY: mydebug=>debug , lunout, prt_level + USE yomcst_mod_h, ONLY: rpi + + IMPLICIT NONE + +!================================================================ +! Auteur(s) : Jean-Yves Grandpeix, 07/08/2017 +! Objet : Contribution of the wake scheme to Ale and Alp +!================================================================ + +! Input arguments +!---------------- + REAL, INTENT(IN) :: dtime + REAL, DIMENSION(klon), INTENT(IN) :: cell_area + INTEGER, DIMENSION(klon), INTENT (IN) :: zoccur + REAL, DIMENSION(klon), INTENT(IN) :: sigmaw + REAL, DIMENSION(klon), INTENT(IN) :: wdens + REAL, DIMENSION(klon), INTENT(IN) :: fip +! Output arguments +!----------------- + REAL, DIMENSION(klon), INTENT(OUT) :: fip_cond + + +! Local variables +!---------------- + INTEGER :: i + REAL, DIMENSION(klon) :: wkrad + REAL, DIMENSION(klon) :: proba_gf + +! Compute wake radius +!! print *,'alpale_wk: sigmaw(1), wdens(1) ', sigmaw(1), wdens(1) + DO i = 1,klon + IF (zoccur(i) .GE. 1) THEN + wkrad(i) = sqrt(sigmaw(i)/(rpi*wdens(i))) + ELSE + wkrad(i) = 0. + ENDIF ! (zoccur(i) .GE. 1) + ENDDO + +! Compute probability that the grid-cell is intersected by a gust front +!! print *,'alpale_wk: wkrad(1), cellrad(1) ', wkrad(1), cellrad(1) +!! proba_gf(:) = exp(-wdens(:)*rpi*max(wkrad(:)-cellrad(:),0.)**2) - & ! Formules +!! exp(-wdens(:)*rpi*(wkrad(:)+cellrad(:))**2) ! fausses ! + proba_gf(:) = 1. - exp(-wdens(:)*rpi*((wkrad(:)+cellrad(:))**2 - & + max(wkrad(:)-cellrad(:),0.)**2) ) +! + proba_gf(:) = max(proba_gf(:),1.e-3) +! Compute Fip conditionned on the presence of some gust front within the +! grid-cell +!! print *,'alpale_wk: proba_gf(1), fip(1), ', proba_gf(1), fip(1) + fip_cond(:) = fip(:)/proba_gf(:) +!! print *,'alpale_wk: wkrad(1), cellrad(1), proba_gf(1), fip(1), fip_cond(1) ', & +!! wkrad(1), cellrad(1), proba_gf(1), fip(1), fip_cond(1) + + RETURN + END SUBROUTINE alpale_wk + +END MODULE alpale_wk_mod Index: LMDZ6/trunk/libf/phylmd/calbeta.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/calbeta.f90 (revision 6047) +++ (revision ) @@ -1,117 +1,0 @@ -! -! $Header$ -! -MODULE calbeta_mod - -CONTAINS - -SUBROUTINE calbeta(dtime,indice,knon,snow,qsol, & - vbeta,vcal,vdif) -!$gpum horizontal knon -USE flux_arp_mod_h - USE dimphy - USE indice_sol_mod - - IMPLICIT none - - -!====================================================================== -! Auteur(s): Z.X. Li (LMD/CNRS) (adaptation du GCM au LMD) -! date: 19940414 -!====================================================================== -! -! Calculer quelques parametres pour appliquer la couche limite -! ------------------------------------------------------------ -! Variables d'entrees -!**************************************************************************************** - REAL, INTENT(IN) :: dtime - INTEGER, INTENT(IN) :: indice - INTEGER, INTENT(IN) :: knon - REAL, DIMENSION(knon), INTENT(IN) :: snow - REAL, DIMENSION(knon), INTENT(IN) :: qsol - - -! Variables de sorties -!**************************************************************************************** - REAL, DIMENSION(knon), INTENT(OUT) :: vbeta - REAL, DIMENSION(knon), INTENT(OUT) :: vcal - REAL, DIMENSION(knon), INTENT(OUT) :: vdif - -! Variables locales -!**************************************************************************************** - REAL, PARAMETER :: tau_gl=86400.0*5.0 ! temps de relaxation pour la glace de mer -!cc PARAMETER (tau_gl=86400.0*30.0) - REAL, PARAMETER :: mx_eau_sol=150.0 - REAL, PARAMETER :: calsol=1.0/(2.5578E+06*0.15) - REAL, PARAMETER :: calsno=1.0/(2.3867E+06*0.15) - REAL, PARAMETER :: calice=1.0/(5.1444E+06*0.15) - - INTEGER :: i - -!**************************************************************************************** - - vbeta(:) = 0.0 - vcal(:) = 0.0 - vdif(:) = 0.0 - - IF (indice.EQ.is_oce) THEN - DO i = 1, knon - vcal(i) = 0.0 - vbeta(i) = 1.0 - vdif(i) = 0.0 - ENDDO - ENDIF - - IF (indice.EQ.is_sic) THEN - DO i = 1, knon - vcal(i) = calice - IF (snow(i) .GT. 0.0) vcal(i) = calsno - vbeta(i) = 1.0 - vdif(i) = 1.0/tau_gl -! vdif(i) = calice/tau_gl ! c'etait une erreur - ENDDO - ENDIF - - IF (indice.EQ.is_ter) THEN - DO i = 1, knon - vcal(i) = calsol - IF (snow(i) .GT. 0.0) vcal(i) = calsno - vbeta(i) = MIN(2.0*qsol(i)/mx_eau_sol, 1.0) - vdif(i) = 0.0 - ENDDO - ENDIF - - IF (indice.EQ.is_lic) THEN - DO i = 1, knon - vcal(i) = calice - IF (snow(i) .GT. 0.0) vcal(i) = calsno - vbeta(i) = 1.0 - vdif(i) = 0.0 - ENDDO - ENDIF - - ! EV: when beta is prescribed for 1D cases: - IF (knon.EQ.1 .AND. ok_prescr_beta) THEN - DO i = 1, knon - vbeta(i)=betaevap - ENDDO - ENDIF - -END SUBROUTINE calbeta - -END MODULE calbeta_mod - - - - - - - - - - - - - - - Index: LMDZ6/trunk/libf/phylmd/calbeta_clim.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/calbeta_clim.f90 (revision 6047) +++ (revision ) @@ -1,79 +1,0 @@ -! -! $Header: /home/cvsroot/LMDZ4/libf/phylmd/calbeta.F90,v 1.2 2007/06/22 12:49:51 -! fairhead Exp $ -! -MODULE calbeta_clim_mod - - -CONTAINS - -SUBROUTINE calbeta_clim(klon,time,lat_radian,beta) -!$gpum horizontal klon - - !====================================================================== - ! Auteur(s): A.K. TRAORE - !====================================================================== - - !USE phys_local_var_mod, ONLY : ideal_beta !pour faire la variable dans le - ! physiq.f pour des sorties directes de beta - - USE phys_cal_mod, only: year_len - USE print_control_mod, ONLY: prt_level - - implicit none - integer klon,nt,j,it - real logbeta(klon),pi - real lat(klon),lat_radian(klon) - integer time - real time_radian - real lat_sahel,beta(klon) - real lat_nord,lat_sud - - !============================================== - - pi=2.*asin(1.) - beta=0. - - !calcul des cordonnees - - ! print*,'LATITUDES BETA ',lat_radian - time_radian=(time+15.)*2.*pi / year_len - - if (prt_level >= 1) print *, 'time_radian time', time_radian, time - - lat(:)=180.*lat_radian(:)/pi !lat(:)=lat_radian(:) - - lat_sahel=-5*sin(time_radian)+13 - lat_nord=lat_sahel+25. - lat_sud=lat_sahel-25. - do j=1,klon - !=========== - if (lat(j) < 5. ) then - - logbeta(j)=0.2*(lat(j)-lat_sud)-1.6 - beta(j)=10**(logbeta(j)) - beta(j)=max(beta(j),0.03) - beta(j)=min(beta(j),0.22) - ! print*,'j,lat,lat_radian,beta',j,lat(j),lat_radian(j),beta(j) - !=========== - elseif (lat(j) < 22.) then !lat(j)<22. - - logbeta(j)=-0.25*(lat(j)-lat_sahel)-1.6 - beta(j)=10**(logbeta(j)) - beta(j)=max(beta(j),1.e-2) - beta(j)=min(beta(j),0.22) - ! print*,'j,lat,lat_radian,beta',j,lat(j),lat_radian(j),beta(j) - !=========== - else - logbeta(j)=0.25*(lat(j)-lat_nord)-1. - beta(j)=10**(logbeta(j)) - beta(j)=max(beta(j),1.e-2) - beta(j)=min(beta(j),0.25) - ! print*,'j,lat,lat_radian,beta',j,lat(j),lat_radian(j),beta(j) - endif - !=========== - enddo - -end SUBROUTINE calbeta_clim - -END MODULE calbeta_clim_mod Index: LMDZ6/trunk/libf/phylmd/calbeta_clim_mod.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/calbeta_clim_mod.f90 (revision 6048) +++ LMDZ6/trunk/libf/phylmd/calbeta_clim_mod.f90 (revision 6048) @@ -0,0 +1,79 @@ +! +! $Header: /home/cvsroot/LMDZ4/libf/phylmd/calbeta.F90,v 1.2 2007/06/22 12:49:51 +! fairhead Exp $ +! +MODULE calbeta_clim_mod + + +CONTAINS + +SUBROUTINE calbeta_clim(klon,time,lat_radian,beta) +!$gpum horizontal klon + + !====================================================================== + ! Auteur(s): A.K. TRAORE + !====================================================================== + + !USE phys_local_var_mod, ONLY : ideal_beta !pour faire la variable dans le + ! physiq.f pour des sorties directes de beta + + USE phys_cal_mod, only: year_len + USE print_control_mod, ONLY: prt_level + + implicit none + integer klon,nt,j,it + real logbeta(klon),pi + real lat(klon),lat_radian(klon) + integer time + real time_radian + real lat_sahel,beta(klon) + real lat_nord,lat_sud + + !============================================== + + pi=2.*asin(1.) + beta=0. + + !calcul des cordonnees + + ! print*,'LATITUDES BETA ',lat_radian + time_radian=(time+15.)*2.*pi / year_len + + if (prt_level >= 1) print *, 'time_radian time', time_radian, time + + lat(:)=180.*lat_radian(:)/pi !lat(:)=lat_radian(:) + + lat_sahel=-5*sin(time_radian)+13 + lat_nord=lat_sahel+25. + lat_sud=lat_sahel-25. + do j=1,klon + !=========== + if (lat(j) < 5. ) then + + logbeta(j)=0.2*(lat(j)-lat_sud)-1.6 + beta(j)=10**(logbeta(j)) + beta(j)=max(beta(j),0.03) + beta(j)=min(beta(j),0.22) + ! print*,'j,lat,lat_radian,beta',j,lat(j),lat_radian(j),beta(j) + !=========== + elseif (lat(j) < 22.) then !lat(j)<22. + + logbeta(j)=-0.25*(lat(j)-lat_sahel)-1.6 + beta(j)=10**(logbeta(j)) + beta(j)=max(beta(j),1.e-2) + beta(j)=min(beta(j),0.22) + ! print*,'j,lat,lat_radian,beta',j,lat(j),lat_radian(j),beta(j) + !=========== + else + logbeta(j)=0.25*(lat(j)-lat_nord)-1. + beta(j)=10**(logbeta(j)) + beta(j)=max(beta(j),1.e-2) + beta(j)=min(beta(j),0.25) + ! print*,'j,lat,lat_radian,beta',j,lat(j),lat_radian(j),beta(j) + endif + !=========== + enddo + +end SUBROUTINE calbeta_clim + +END MODULE calbeta_clim_mod Index: LMDZ6/trunk/libf/phylmd/calbeta_mod.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/calbeta_mod.f90 (revision 6048) +++ LMDZ6/trunk/libf/phylmd/calbeta_mod.f90 (revision 6048) @@ -0,0 +1,117 @@ +! +! $Header$ +! +MODULE calbeta_mod + +CONTAINS + +SUBROUTINE calbeta(dtime,indice,knon,snow,qsol, & + vbeta,vcal,vdif) +!$gpum horizontal knon +USE flux_arp_mod_h + USE dimphy + USE indice_sol_mod + + IMPLICIT none + + +!====================================================================== +! Auteur(s): Z.X. Li (LMD/CNRS) (adaptation du GCM au LMD) +! date: 19940414 +!====================================================================== +! +! Calculer quelques parametres pour appliquer la couche limite +! ------------------------------------------------------------ +! Variables d'entrees +!**************************************************************************************** + REAL, INTENT(IN) :: dtime + INTEGER, INTENT(IN) :: indice + INTEGER, INTENT(IN) :: knon + REAL, DIMENSION(knon), INTENT(IN) :: snow + REAL, DIMENSION(knon), INTENT(IN) :: qsol + + +! Variables de sorties +!**************************************************************************************** + REAL, DIMENSION(knon), INTENT(OUT) :: vbeta + REAL, DIMENSION(knon), INTENT(OUT) :: vcal + REAL, DIMENSION(knon), INTENT(OUT) :: vdif + +! Variables locales +!**************************************************************************************** + REAL, PARAMETER :: tau_gl=86400.0*5.0 ! temps de relaxation pour la glace de mer +!cc PARAMETER (tau_gl=86400.0*30.0) + REAL, PARAMETER :: mx_eau_sol=150.0 + REAL, PARAMETER :: calsol=1.0/(2.5578E+06*0.15) + REAL, PARAMETER :: calsno=1.0/(2.3867E+06*0.15) + REAL, PARAMETER :: calice=1.0/(5.1444E+06*0.15) + + INTEGER :: i + +!**************************************************************************************** + + vbeta(:) = 0.0 + vcal(:) = 0.0 + vdif(:) = 0.0 + + IF (indice.EQ.is_oce) THEN + DO i = 1, knon + vcal(i) = 0.0 + vbeta(i) = 1.0 + vdif(i) = 0.0 + ENDDO + ENDIF + + IF (indice.EQ.is_sic) THEN + DO i = 1, knon + vcal(i) = calice + IF (snow(i) .GT. 0.0) vcal(i) = calsno + vbeta(i) = 1.0 + vdif(i) = 1.0/tau_gl +! vdif(i) = calice/tau_gl ! c'etait une erreur + ENDDO + ENDIF + + IF (indice.EQ.is_ter) THEN + DO i = 1, knon + vcal(i) = calsol + IF (snow(i) .GT. 0.0) vcal(i) = calsno + vbeta(i) = MIN(2.0*qsol(i)/mx_eau_sol, 1.0) + vdif(i) = 0.0 + ENDDO + ENDIF + + IF (indice.EQ.is_lic) THEN + DO i = 1, knon + vcal(i) = calice + IF (snow(i) .GT. 0.0) vcal(i) = calsno + vbeta(i) = 1.0 + vdif(i) = 0.0 + ENDDO + ENDIF + + ! EV: when beta is prescribed for 1D cases: + IF (knon.EQ.1 .AND. ok_prescr_beta) THEN + DO i = 1, knon + vbeta(i)=betaevap + ENDDO + ENDIF + +END SUBROUTINE calbeta + +END MODULE calbeta_mod + + + + + + + + + + + + + + + Index: LMDZ6/trunk/libf/phylmd/calwake.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/calwake.f90 (revision 6047) +++ (revision ) @@ -1,394 +1,0 @@ -! $Id$ -MODULE calwake_mod - PRIVATE - - LOGICAL, SAVE, ALLOCATABLE :: first(:) ! first(klon) : first calwake computation on columns - !$OMP THREADPRIVATE(first) - - LOGICAL, SAVE :: first_first=.TRUE. ! fisrt call to calwake - !$OMP THREADPRIVATE(first_first) - - PUBLIC calwake_first, calwake - -CONTAINS - -SUBROUTINE calwake_first(dtime) -USE dimphy, ONLY : klon,klev -USE lmdz_wake_first, ONLY : wake_first - REAL, INTENT(IN) :: dtime - - IF (first_first) THEN - ALLOCATE(first(klon)) - first(:)=.TRUE. - - CALL wake_first(klev, dtime) - - first_first=.FALSE. - ENDIF - -END SUBROUTINE calwake_first - - -SUBROUTINE calwake(iflag_wake_tend, paprs, pplay, dtime, & - t, q, omgb, & - dt_dwn, dq_dwn, m_dwn, m_up, dt_a, dq_a, wgen, & - sigd, Cin, & - wake_deltat, wake_deltaq, wake_s, awake_s, wake_dens, awake_dens, & - wake_dth, wake_h, & - wake_pe, wake_fip, wake_gfl, & - dt_wake, dq_wake, wake_k, t_x, q_x, wake_omgbdth, & - wake_dp_omgb, & - wake_dtke, wake_dqke, & - wake_omg, wake_dp_deltomg, & - wake_spread, wake_cstar, wake_d_deltat_gw, & - wake_ddeltat, wake_ddeltaq, wake_ds, awake_ds, wake_ddens, awake_ddens) - ! ************************************************************** - ! * - ! 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 - USE phys_state_var_mod, ONLY: pctsrf - USE indice_sol_mod, ONLY: is_oce - USE print_control_mod, ONLY: lunout, prt_level - USE lmdz_wake, ONLY : wake - USE lmdz_wake2, ONLY : wake2 - USE lmdz_wake3, ONLY : wake3 - USE alpale_mod, ONLY: iflag_wake - USE yomcst_mod_h -IMPLICIT NONE - ! ====================================================================== - - - ! Arguments - ! ---------- - ! Input - ! ---- - INTEGER, INTENT (IN) :: iflag_wake_tend - REAL, INTENT (IN) :: dtime - REAL, DIMENSION(klon, klev), INTENT (IN) :: pplay - REAL, DIMENSION(klon, klev+1), INTENT (IN) :: paprs - REAL, DIMENSION(klon, klev), INTENT (IN) :: t, q, omgb - REAL, DIMENSION(klon, klev), INTENT (IN) :: dt_dwn, dq_dwn - REAL, DIMENSION(klon, klev), INTENT (IN) :: m_up, m_dwn - REAL, DIMENSION(klon, klev), INTENT (IN) :: dt_a, dq_a - REAL, DIMENSION(klon), INTENT (IN) :: wgen - REAL, DIMENSION(klon), INTENT (IN) :: sigd - REAL, DIMENSION(klon), INTENT (IN) :: Cin - ! Input/Output - ! ------------ - REAL, DIMENSION(klon, klev), INTENT (INOUT) :: wake_deltat, wake_deltaq - REAL, DIMENSION(klon), INTENT (INOUT) :: wake_s, awake_s - REAL, DIMENSION(klon), INTENT (INOUT) :: wake_dens, awake_dens - ! Output - ! ------ - REAL, DIMENSION(klon, klev), INTENT (OUT) :: dt_wake, dq_wake -!!jyg REAL, DIMENSION(klon), INTENT (OUT) :: wake_k - INTEGER, DIMENSION(klon), INTENT (OUT) :: wake_k - REAL, DIMENSION(klon, klev), INTENT (OUT) :: wake_d_deltat_gw - REAL, DIMENSION(klon), INTENT (OUT) :: wake_h - REAL, DIMENSION(klon, klev), INTENT (OUT) :: wake_dth - REAL, DIMENSION(klon), INTENT (OUT) :: wake_pe, wake_fip, wake_gfl - REAL, DIMENSION(klon, klev), INTENT (OUT) :: t_x, q_x - REAL, DIMENSION(klon, klev), INTENT (OUT) :: wake_omgbdth, wake_dp_omgb - REAL, DIMENSION(klon, klev), INTENT (OUT) :: wake_dtke, wake_dqke - REAL, DIMENSION(klon, klev), INTENT (OUT) :: wake_omg, wake_dp_deltomg - REAL, DIMENSION(klon, klev), INTENT (OUT) :: wake_spread - REAL, DIMENSION(klon), INTENT (OUT) :: wake_cstar - REAL, DIMENSION(klon, klev), INTENT (OUT) :: wake_ddeltat, wake_ddeltaq - REAL, DIMENSION(klon), INTENT (OUT) :: wake_ds, awake_ds, wake_ddens, awake_ddens - - - ! Variable internes - ! ----------------- - INTEGER :: i, l - INTEGER, DIMENSION(klon) :: znatsurf ! 0 if pctsrf(is_oce)>0.1; 1 else. - REAL :: aire - REAL, DIMENSION(klon, klev) :: p, pi - REAL, DIMENSION(klon, klev+1) :: ph - REAL, DIMENSION(klon, klev) :: omgbe - REAL, DIMENSION(klon, klev) :: te, qe - REAL, DIMENSION(klon, klev) :: dtdwn, dqdwn - REAL, DIMENSION(klon, klev) :: dta, dqa - REAL, DIMENSION(klon, klev) :: amdwn, amup - REAL, DIMENSION(klon, klev) :: dtw, dqw, dth - REAL, DIMENSION(klon, klev) :: dtls, dqls - REAL, DIMENSION(klon, klev) :: tx, qx - REAL, DIMENSION(klon) :: hw, wape, fip, gfl - REAL, DIMENSION(klon) :: sigmaw, asigmaw, wdens, awdens - REAL, DIMENSION(klon, klev) :: omgbdth - REAL, DIMENSION(klon, klev) :: dp_omgb - REAL, DIMENSION(klon, klev) :: dtke, dqke - REAL, DIMENSION(klon, klev) :: omg - REAL, DIMENSION(klon, klev) :: dp_deltomg, spread - REAL, DIMENSION(klon) :: cstar - REAL, DIMENSION(klon) :: sigd0 - INTEGER, DIMENSION(klon) :: ktopw - REAL, DIMENSION(klon, klev) :: d_deltat_gw - REAL, DIMENSION(klon, klev) :: d_deltatw, d_deltaqw - REAL, DIMENSION(klon) :: d_sigmaw, d_asigmaw, d_wdens, d_awdens - - REAL :: rdcp - - - IF (prt_level >= 10) THEN - print *, '-> calwake, wake_s, awake_s, wgen input ', wake_s(1), awake_s(1), wgen(1) - ENDIF - - rdcp = 1./3.5 - - znatsurf(:) = 0 - DO i = 1,klon - IF (pctsrf(i,is_oce) < 0.1) znatsurf(i) = 1 - ENDDO - - - ! ----------------------------------------------------------- - ! IM 290108 DO 999 i=1,klon ! a vectoriser - ! ---------------------------------------------------------- - - - DO l = 1, klev - DO i = 1, klon - p(i, l) = pplay(i, l) - ph(i, l) = paprs(i, l) - pi(i, l) = (pplay(i,l)/100000.)**rdcp - - te(i, l) = t(i, l) - qe(i, l) = q(i, l) - omgbe(i, l) = omgb(i, l) - - dtdwn(i, l) = dt_dwn(i, l) - dqdwn(i, l) = dq_dwn(i, l) - dta(i, l) = dt_a(i, l) - dqa(i, l) = dq_a(i, l) - END DO - END DO - -!---------------------------------------------------------------- -! Initialize tendencies to zero -!---------------------------------------------------------------- -dtls(:,:) = 0. -dqls(:,:) = 0. -d_deltat_gw(:,:) = 0. -d_deltatw(:,:) = 0. -d_deltaqw(:,:) = 0. -d_sigmaw(:) = 0. -d_asigmaw(:) = 0. -d_wdens(:) = 0. -d_awdens(:) = 0. -! - - DO i = 1, klon - sigd0(i) = sigd(i) - END DO - ! print*, 'sigd0,sigd', sigd0, sigd(i) - DO i = 1, klon - ph(i, klev+1) = 0. - END DO - -!!jyg! DO i = 1, klon -!!jyg! ktopw(i) = NINT(wake_k(i)) -!!jyg! END DO - - DO i = 1, klon - hw(i) = wake_h(i) - END DO -! -! Make a copy of state variables - DO l = 1, klev - DO i = 1, klon - dtw(i, l) = wake_deltat(i, l) - dqw(i, l) = wake_deltaq(i, l) - END DO - END DO - - DO i = 1, klon - sigmaw(i) = wake_s(i) - asigmaw(i) = awake_s(i) - END DO - - DO i = 1, klon - wdens(i) = max(0., wake_dens(i)) - awdens(i) = max(0., awake_dens(i)) - END DO - - ! fkc les flux de masses sont evalues aux niveaux et valent 0 a la surface - ! fkc on veut le flux de masse au milieu des couches - - DO l = 1, klev - 1 - DO i = 1, klon - amdwn(i, l) = 0.5*(m_dwn(i,l)+m_dwn(i,l+1)) - amdwn(i, l) = (m_dwn(i,l+1)) - END DO - END DO - - ! au sommet le flux de masse est nul - - DO i = 1, klon - amdwn(i, klev) = 0.5*m_dwn(i, klev) - END DO - - DO l = 1, klev - DO i = 1, klon - amup(i, l) = m_up(i, l) - END DO - END DO - - - - IF (iflag_wake/10 == 0) THEN - CALL wake(klon,klev,znatsurf, p, ph, pi, dtime, & - te, qe, omgbe, & - dtdwn, dqdwn, amdwn, amup, dta, dqa, wgen, & - sigd0, Cin, & - dtw, dqw, sigmaw, asigmaw, wdens, awdens, & ! state variables - dth, hw, wape, fip, gfl, & - dtls, dqls, ktopw, omgbdth, dp_omgb, tx, qx, & - dtke, dqke, omg, dp_deltomg, spread, cstar, & - d_deltat_gw, & - d_deltatw, d_deltaqw, d_sigmaw, d_asigmaw, d_wdens, d_awdens) ! tendencies - - ELSE IF (iflag_wake/10 == 2) THEN - CALL wake2(klon,klev,znatsurf, p, ph, pi, dtime, & - te, qe, omgbe, & - dtdwn, dqdwn, amdwn, amup, dta, dqa, wgen, & - sigd0, Cin, & - dtw, dqw, sigmaw, asigmaw, wdens, awdens, & ! state variables - dth, hw, wape, fip, gfl, & - dtls, dqls, ktopw, omgbdth, dp_omgb, tx, qx, & - dtke, dqke, omg, dp_deltomg, spread, cstar, & - d_deltat_gw, & - d_deltatw, d_deltaqw, d_sigmaw, d_asigmaw, d_wdens, d_awdens) ! tendencies - - ELSE IF (iflag_wake/10 == 3) THEN - CALL wake3(klon,klev,znatsurf, p, ph, pi, dtime, & - te, qe, omgbe, & - dtdwn, dqdwn, amdwn, amup, dta, dqa, wgen, & - sigd0, Cin, & - dtw, dqw, sigmaw, asigmaw, wdens, awdens, & ! state variables - dth, hw, wape, fip, gfl, & - dtls, dqls, ktopw, omgbdth, dp_omgb, tx, qx, & - dtke, dqke, omg, dp_deltomg, spread, cstar, & - d_deltat_gw, & - d_deltatw, d_deltaqw, d_sigmaw, d_asigmaw, d_wdens, d_awdens) ! tendencies - - END IF !(iflag_wake/10 == 0) - - -! - DO l = 1, klev - DO i = 1, klon - IF (ktopw(i)>0) THEN - wake_d_deltat_gw(i, l) = d_deltat_gw(i, l) - wake_omgbdth(i, l) = omgbdth(i, l) - wake_dp_omgb(i, l) = dp_omgb(i, l) - wake_dtke(i, l) = dtke(i, l) - wake_dqke(i, l) = dqke(i, l) - wake_omg(i, l) = omg(i, l) - wake_dp_deltomg(i, l) = dp_deltomg(i, l) - wake_spread(i, l) = spread(i, l) - wake_dth(i, l) = dth(i, l) - dt_wake(i, l) = dtls(i, l)*dtime ! derivative -> tendency - dq_wake(i, l) = dqls(i, l)*dtime ! derivative -> tendency - t_x(i, l) = tx(i, l) - q_x(i, l) = qx(i, l) - ELSE - 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. - t_x(i, l) = te(i, l) - q_x(i, l) = qe(i, l) - END IF - END DO - END DO - - DO i = 1, klon - wake_h(i) = hw(i) - wake_pe(i) = wape(i) - wake_fip(i) = fip(i) - wake_gfl(i) = gfl(i) - wake_k(i) = ktopw(i) - wake_cstar(i) = cstar(i) - END DO - -! Tendencies of state variables - DO l = 1, klev - DO i = 1, klon - IF (ktopw(i)>0) THEN - wake_ddeltat(i, l) = d_deltatw(i, l)*dtime - wake_ddeltaq(i, l) = d_deltaqw(i, l)*dtime - ELSE - wake_ddeltat(i, l) = -wake_deltat(i, l) - wake_ddeltaq(i, l) = -wake_deltaq(i, l) - END IF - END DO - END DO - DO i = 1, klon - IF (ktopw(i)>0) THEN - wake_ds(i) = d_sigmaw(i)*dtime - awake_ds(i) = d_asigmaw(i)*dtime - awake_ddens(i) = d_awdens(i)*dtime - wake_ddens(i) = d_wdens(i)*dtime - ELSE - wake_ds(i) = -wake_s(i) - awake_ds(i) = -awake_s(i) - wake_ddens(i) = -wake_dens(i) - awake_ddens(i)= -awake_dens(i) - END IF - END DO -! - -!jyg< - IF (iflag_wake_tend .EQ. 0) THEN -! Update State variables - DO l = 1, klev - DO i = 1, klon - IF (ktopw(i)>0) THEN - wake_deltat(i, l) = dtw(i, l) - wake_deltaq(i, l) = dqw(i, l) - ELSE - wake_deltat(i, l) = 0. - wake_deltaq(i, l) = 0. - END IF - END DO - END DO - DO i = 1, klon - wake_s(i) = sigmaw(i) - awake_s(i) = asigmaw(i) - awake_dens(i) = awdens(i) - wake_dens(i) = wdens(i) - END DO - ENDIF ! (iflag_wake_tend .EQ. 0) -! - DO i = 1,klon - IF (first(i)) THEN - IF (wake_dens(i) < -1.) THEN - wake_dens(i) = wdens(i) - ENDIF - first(i)=.FALSE. - ENDIF - ENDDO - -!>jyg - IF (prt_level >= 10) THEN - print *, 'calwake ->, wake_s, awake_s ', wake_s(1), awake_s(1) - ENDIF - - RETURN -END SUBROUTINE calwake - -END MODULE calwake_mod Index: LMDZ6/trunk/libf/phylmd/calwake_mod.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/calwake_mod.f90 (revision 6048) +++ LMDZ6/trunk/libf/phylmd/calwake_mod.f90 (revision 6048) @@ -0,0 +1,394 @@ +! $Id$ +MODULE calwake_mod + PRIVATE + + LOGICAL, SAVE, ALLOCATABLE :: first(:) ! first(klon) : first calwake computation on columns + !$OMP THREADPRIVATE(first) + + LOGICAL, SAVE :: first_first=.TRUE. ! fisrt call to calwake + !$OMP THREADPRIVATE(first_first) + + PUBLIC calwake_first, calwake + +CONTAINS + +SUBROUTINE calwake_first(dtime) +USE dimphy, ONLY : klon,klev +USE lmdz_wake_first, ONLY : wake_first + REAL, INTENT(IN) :: dtime + + IF (first_first) THEN + ALLOCATE(first(klon)) + first(:)=.TRUE. + + CALL wake_first(klev, dtime) + + first_first=.FALSE. + ENDIF + +END SUBROUTINE calwake_first + + +SUBROUTINE calwake(iflag_wake_tend, paprs, pplay, dtime, & + t, q, omgb, & + dt_dwn, dq_dwn, m_dwn, m_up, dt_a, dq_a, wgen, & + sigd, Cin, & + wake_deltat, wake_deltaq, wake_s, awake_s, wake_dens, awake_dens, & + wake_dth, wake_h, & + wake_pe, wake_fip, wake_gfl, & + dt_wake, dq_wake, wake_k, t_x, q_x, wake_omgbdth, & + wake_dp_omgb, & + wake_dtke, wake_dqke, & + wake_omg, wake_dp_deltomg, & + wake_spread, wake_cstar, wake_d_deltat_gw, & + wake_ddeltat, wake_ddeltaq, wake_ds, awake_ds, wake_ddens, awake_ddens) + ! ************************************************************** + ! * + ! 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 + USE phys_state_var_mod, ONLY: pctsrf + USE indice_sol_mod, ONLY: is_oce + USE print_control_mod, ONLY: lunout, prt_level + USE lmdz_wake, ONLY : wake + USE lmdz_wake2, ONLY : wake2 + USE lmdz_wake3, ONLY : wake3 + USE alpale_mod, ONLY: iflag_wake + USE yomcst_mod_h +IMPLICIT NONE + ! ====================================================================== + + + ! Arguments + ! ---------- + ! Input + ! ---- + INTEGER, INTENT (IN) :: iflag_wake_tend + REAL, INTENT (IN) :: dtime + REAL, DIMENSION(klon, klev), INTENT (IN) :: pplay + REAL, DIMENSION(klon, klev+1), INTENT (IN) :: paprs + REAL, DIMENSION(klon, klev), INTENT (IN) :: t, q, omgb + REAL, DIMENSION(klon, klev), INTENT (IN) :: dt_dwn, dq_dwn + REAL, DIMENSION(klon, klev), INTENT (IN) :: m_up, m_dwn + REAL, DIMENSION(klon, klev), INTENT (IN) :: dt_a, dq_a + REAL, DIMENSION(klon), INTENT (IN) :: wgen + REAL, DIMENSION(klon), INTENT (IN) :: sigd + REAL, DIMENSION(klon), INTENT (IN) :: Cin + ! Input/Output + ! ------------ + REAL, DIMENSION(klon, klev), INTENT (INOUT) :: wake_deltat, wake_deltaq + REAL, DIMENSION(klon), INTENT (INOUT) :: wake_s, awake_s + REAL, DIMENSION(klon), INTENT (INOUT) :: wake_dens, awake_dens + ! Output + ! ------ + REAL, DIMENSION(klon, klev), INTENT (OUT) :: dt_wake, dq_wake +!!jyg REAL, DIMENSION(klon), INTENT (OUT) :: wake_k + INTEGER, DIMENSION(klon), INTENT (OUT) :: wake_k + REAL, DIMENSION(klon, klev), INTENT (OUT) :: wake_d_deltat_gw + REAL, DIMENSION(klon), INTENT (OUT) :: wake_h + REAL, DIMENSION(klon, klev), INTENT (OUT) :: wake_dth + REAL, DIMENSION(klon), INTENT (OUT) :: wake_pe, wake_fip, wake_gfl + REAL, DIMENSION(klon, klev), INTENT (OUT) :: t_x, q_x + REAL, DIMENSION(klon, klev), INTENT (OUT) :: wake_omgbdth, wake_dp_omgb + REAL, DIMENSION(klon, klev), INTENT (OUT) :: wake_dtke, wake_dqke + REAL, DIMENSION(klon, klev), INTENT (OUT) :: wake_omg, wake_dp_deltomg + REAL, DIMENSION(klon, klev), INTENT (OUT) :: wake_spread + REAL, DIMENSION(klon), INTENT (OUT) :: wake_cstar + REAL, DIMENSION(klon, klev), INTENT (OUT) :: wake_ddeltat, wake_ddeltaq + REAL, DIMENSION(klon), INTENT (OUT) :: wake_ds, awake_ds, wake_ddens, awake_ddens + + + ! Variable internes + ! ----------------- + INTEGER :: i, l + INTEGER, DIMENSION(klon) :: znatsurf ! 0 if pctsrf(is_oce)>0.1; 1 else. + REAL :: aire + REAL, DIMENSION(klon, klev) :: p, pi + REAL, DIMENSION(klon, klev+1) :: ph + REAL, DIMENSION(klon, klev) :: omgbe + REAL, DIMENSION(klon, klev) :: te, qe + REAL, DIMENSION(klon, klev) :: dtdwn, dqdwn + REAL, DIMENSION(klon, klev) :: dta, dqa + REAL, DIMENSION(klon, klev) :: amdwn, amup + REAL, DIMENSION(klon, klev) :: dtw, dqw, dth + REAL, DIMENSION(klon, klev) :: dtls, dqls + REAL, DIMENSION(klon, klev) :: tx, qx + REAL, DIMENSION(klon) :: hw, wape, fip, gfl + REAL, DIMENSION(klon) :: sigmaw, asigmaw, wdens, awdens + REAL, DIMENSION(klon, klev) :: omgbdth + REAL, DIMENSION(klon, klev) :: dp_omgb + REAL, DIMENSION(klon, klev) :: dtke, dqke + REAL, DIMENSION(klon, klev) :: omg + REAL, DIMENSION(klon, klev) :: dp_deltomg, spread + REAL, DIMENSION(klon) :: cstar + REAL, DIMENSION(klon) :: sigd0 + INTEGER, DIMENSION(klon) :: ktopw + REAL, DIMENSION(klon, klev) :: d_deltat_gw + REAL, DIMENSION(klon, klev) :: d_deltatw, d_deltaqw + REAL, DIMENSION(klon) :: d_sigmaw, d_asigmaw, d_wdens, d_awdens + + REAL :: rdcp + + + IF (prt_level >= 10) THEN + print *, '-> calwake, wake_s, awake_s, wgen input ', wake_s(1), awake_s(1), wgen(1) + ENDIF + + rdcp = 1./3.5 + + znatsurf(:) = 0 + DO i = 1,klon + IF (pctsrf(i,is_oce) < 0.1) znatsurf(i) = 1 + ENDDO + + + ! ----------------------------------------------------------- + ! IM 290108 DO 999 i=1,klon ! a vectoriser + ! ---------------------------------------------------------- + + + DO l = 1, klev + DO i = 1, klon + p(i, l) = pplay(i, l) + ph(i, l) = paprs(i, l) + pi(i, l) = (pplay(i,l)/100000.)**rdcp + + te(i, l) = t(i, l) + qe(i, l) = q(i, l) + omgbe(i, l) = omgb(i, l) + + dtdwn(i, l) = dt_dwn(i, l) + dqdwn(i, l) = dq_dwn(i, l) + dta(i, l) = dt_a(i, l) + dqa(i, l) = dq_a(i, l) + END DO + END DO + +!---------------------------------------------------------------- +! Initialize tendencies to zero +!---------------------------------------------------------------- +dtls(:,:) = 0. +dqls(:,:) = 0. +d_deltat_gw(:,:) = 0. +d_deltatw(:,:) = 0. +d_deltaqw(:,:) = 0. +d_sigmaw(:) = 0. +d_asigmaw(:) = 0. +d_wdens(:) = 0. +d_awdens(:) = 0. +! + + DO i = 1, klon + sigd0(i) = sigd(i) + END DO + ! print*, 'sigd0,sigd', sigd0, sigd(i) + DO i = 1, klon + ph(i, klev+1) = 0. + END DO + +!!jyg! DO i = 1, klon +!!jyg! ktopw(i) = NINT(wake_k(i)) +!!jyg! END DO + + DO i = 1, klon + hw(i) = wake_h(i) + END DO +! +! Make a copy of state variables + DO l = 1, klev + DO i = 1, klon + dtw(i, l) = wake_deltat(i, l) + dqw(i, l) = wake_deltaq(i, l) + END DO + END DO + + DO i = 1, klon + sigmaw(i) = wake_s(i) + asigmaw(i) = awake_s(i) + END DO + + DO i = 1, klon + wdens(i) = max(0., wake_dens(i)) + awdens(i) = max(0., awake_dens(i)) + END DO + + ! fkc les flux de masses sont evalues aux niveaux et valent 0 a la surface + ! fkc on veut le flux de masse au milieu des couches + + DO l = 1, klev - 1 + DO i = 1, klon + amdwn(i, l) = 0.5*(m_dwn(i,l)+m_dwn(i,l+1)) + amdwn(i, l) = (m_dwn(i,l+1)) + END DO + END DO + + ! au sommet le flux de masse est nul + + DO i = 1, klon + amdwn(i, klev) = 0.5*m_dwn(i, klev) + END DO + + DO l = 1, klev + DO i = 1, klon + amup(i, l) = m_up(i, l) + END DO + END DO + + + + IF (iflag_wake/10 == 0) THEN + CALL wake(klon,klev,znatsurf, p, ph, pi, dtime, & + te, qe, omgbe, & + dtdwn, dqdwn, amdwn, amup, dta, dqa, wgen, & + sigd0, Cin, & + dtw, dqw, sigmaw, asigmaw, wdens, awdens, & ! state variables + dth, hw, wape, fip, gfl, & + dtls, dqls, ktopw, omgbdth, dp_omgb, tx, qx, & + dtke, dqke, omg, dp_deltomg, spread, cstar, & + d_deltat_gw, & + d_deltatw, d_deltaqw, d_sigmaw, d_asigmaw, d_wdens, d_awdens) ! tendencies + + ELSE IF (iflag_wake/10 == 2) THEN + CALL wake2(klon,klev,znatsurf, p, ph, pi, dtime, & + te, qe, omgbe, & + dtdwn, dqdwn, amdwn, amup, dta, dqa, wgen, & + sigd0, Cin, & + dtw, dqw, sigmaw, asigmaw, wdens, awdens, & ! state variables + dth, hw, wape, fip, gfl, & + dtls, dqls, ktopw, omgbdth, dp_omgb, tx, qx, & + dtke, dqke, omg, dp_deltomg, spread, cstar, & + d_deltat_gw, & + d_deltatw, d_deltaqw, d_sigmaw, d_asigmaw, d_wdens, d_awdens) ! tendencies + + ELSE IF (iflag_wake/10 == 3) THEN + CALL wake3(klon,klev,znatsurf, p, ph, pi, dtime, & + te, qe, omgbe, & + dtdwn, dqdwn, amdwn, amup, dta, dqa, wgen, & + sigd0, Cin, & + dtw, dqw, sigmaw, asigmaw, wdens, awdens, & ! state variables + dth, hw, wape, fip, gfl, & + dtls, dqls, ktopw, omgbdth, dp_omgb, tx, qx, & + dtke, dqke, omg, dp_deltomg, spread, cstar, & + d_deltat_gw, & + d_deltatw, d_deltaqw, d_sigmaw, d_asigmaw, d_wdens, d_awdens) ! tendencies + + END IF !(iflag_wake/10 == 0) + + +! + DO l = 1, klev + DO i = 1, klon + IF (ktopw(i)>0) THEN + wake_d_deltat_gw(i, l) = d_deltat_gw(i, l) + wake_omgbdth(i, l) = omgbdth(i, l) + wake_dp_omgb(i, l) = dp_omgb(i, l) + wake_dtke(i, l) = dtke(i, l) + wake_dqke(i, l) = dqke(i, l) + wake_omg(i, l) = omg(i, l) + wake_dp_deltomg(i, l) = dp_deltomg(i, l) + wake_spread(i, l) = spread(i, l) + wake_dth(i, l) = dth(i, l) + dt_wake(i, l) = dtls(i, l)*dtime ! derivative -> tendency + dq_wake(i, l) = dqls(i, l)*dtime ! derivative -> tendency + t_x(i, l) = tx(i, l) + q_x(i, l) = qx(i, l) + ELSE + 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. + t_x(i, l) = te(i, l) + q_x(i, l) = qe(i, l) + END IF + END DO + END DO + + DO i = 1, klon + wake_h(i) = hw(i) + wake_pe(i) = wape(i) + wake_fip(i) = fip(i) + wake_gfl(i) = gfl(i) + wake_k(i) = ktopw(i) + wake_cstar(i) = cstar(i) + END DO + +! Tendencies of state variables + DO l = 1, klev + DO i = 1, klon + IF (ktopw(i)>0) THEN + wake_ddeltat(i, l) = d_deltatw(i, l)*dtime + wake_ddeltaq(i, l) = d_deltaqw(i, l)*dtime + ELSE + wake_ddeltat(i, l) = -wake_deltat(i, l) + wake_ddeltaq(i, l) = -wake_deltaq(i, l) + END IF + END DO + END DO + DO i = 1, klon + IF (ktopw(i)>0) THEN + wake_ds(i) = d_sigmaw(i)*dtime + awake_ds(i) = d_asigmaw(i)*dtime + awake_ddens(i) = d_awdens(i)*dtime + wake_ddens(i) = d_wdens(i)*dtime + ELSE + wake_ds(i) = -wake_s(i) + awake_ds(i) = -awake_s(i) + wake_ddens(i) = -wake_dens(i) + awake_ddens(i)= -awake_dens(i) + END IF + END DO +! + +!jyg< + IF (iflag_wake_tend .EQ. 0) THEN +! Update State variables + DO l = 1, klev + DO i = 1, klon + IF (ktopw(i)>0) THEN + wake_deltat(i, l) = dtw(i, l) + wake_deltaq(i, l) = dqw(i, l) + ELSE + wake_deltat(i, l) = 0. + wake_deltaq(i, l) = 0. + END IF + END DO + END DO + DO i = 1, klon + wake_s(i) = sigmaw(i) + awake_s(i) = asigmaw(i) + awake_dens(i) = awdens(i) + wake_dens(i) = wdens(i) + END DO + ENDIF ! (iflag_wake_tend .EQ. 0) +! + DO i = 1,klon + IF (first(i)) THEN + IF (wake_dens(i) < -1.) THEN + wake_dens(i) = wdens(i) + ENDIF + first(i)=.FALSE. + ENDIF + ENDDO + +!>jyg + IF (prt_level >= 10) THEN + print *, 'calwake ->, wake_s, awake_s ', wake_s(1), awake_s(1) + ENDIF + + RETURN +END SUBROUTINE calwake + +END MODULE calwake_mod Index: LMDZ6/trunk/libf/phylmd/clc_core_cp.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/clc_core_cp.f90 (revision 6047) +++ (revision ) @@ -1,238 +1,0 @@ -MODULE clc_core_cp_mod -! -! $Id$ -! -CONTAINS - - SUBROUTINE clc_core_cp(du, dt, dq, t1, q1, & - zu, zt, zq, & - P,& - n_it, mixte, & - coeffs, rugosm, rugosh) - - IMPLICIT NONE - - - ! INTEGER :: i,j,k - REAL, INTENT(IN) :: du,dt,dq,t1,q1 - REAL, INTENT(IN) :: zu,zt,zq, P - INTEGER, INTENT(IN):: n_it - LOGICAL, INTENT(IN) :: mixte - REAL, DIMENSION(3), INTENT(OUT) :: coeffs - real, intent(out) :: rugosm - real, intent(out) :: rugosh - - -! REAL :: du,dt,t1,dq,q1 - REAL :: dt_u, dq_u - - - - REAL :: cd, ch, cd_rt, cd_n10, ce_n10, ce,& - u_N, X,& - rho,cpa,le - - REAL :: usr,tsr,qsr - REAL, DIMENSION(3) :: zeta ! dans l'ordre: it courant, it precedente, var - REAL, DIMENSION(2,3) :: psi - REAL, PARAMETER :: g = 9.81, k=.41, sqrt_k = .640312 !avec g= gravité, k = cste von karman, sqrt_k = racine(k) - REAL :: logzu_10,logzt_10,logzq_10,logzt_zu,logzq_zu,& - u,cd_n10_rt,ch_n10_rt,ch_n10,chi,z_0m,z_0h,tv - INTEGER :: i,j,m1,m2,m3,m4,m5 - - - REAL :: phih,phid,phie - - - REAL, parameter :: alpha=2.7e-3,& !alpha = a1 ds formulation smith - beta = 1.42e-4,& !beta = a2 ds la formulation smith - gamma = 7.64e-5,& !Large and yaeger 2006 !gamma = a3 ds formulation smith -! gamma = 13.09e-3,& !Large and yaeger 2004 - q0 = 1.64474 ! q0 dzfinis mais pas reutilisée ds la suite ?? - - REAL, dimension(3) :: z - integer, dimension(2) :: tmp_shape - z = [zu, zt, zq] - - - - logzu_10 = LOG(zu/10.) - logzt_10 = LOG(zt/10.) - logzq_10 = LOG(zq/10.) - logzt_zu = logzt_10 - logzu_10 - logzq_zu = logzq_10 - logzu_10 - - cpa = 1004.67 !!! pas reutilise ds nvelle formulation... - - tv = t1 * (1+.608*q1) !!!!! tv pas reutiliser ds nvelle formulation... - rho = p / (287.1 * t1 * (1.+.61*q1)) !!!! rho pas reutiliser ds nvelle formulation.... - - - le = (2.501-.00237*(t1-273.15-dt))*1.e6 !!!!!! le pas reutiliser ds nvelle formulation.... - - u = max(du,.5) !!!! u = vitesse du vent 1 er niveau - u_N = u !!!!!!! u_N utilisée pour le calcul des premier calcul... - - - !!!!! initialisation des parametres et premier calcul de z_0 cd et ch - - - if (mixte) then - z_0m = 1.e-4 !!!!! pour l'initialisation on fixe z_0 a 10-4 - cd_n10 = k**2 / (log(10/z_0m))**2 !!!!! on calcul ensuite cd a 10 m d'après smith - cd_n10_rt = sqrt(cd_n10) - else -! Large and yaeger 2006 - cd_n10 = alpha / u_n + beta + gamma * u_n !!!!! calcul de cd pour core pur -! Large and yaeger 2004 -! cd_n10 = 1E-3 * (2.7/U_n + 0.142 + U_n/13.09) - cd_n10_rt = sqrt(cd_n10) !!!!!! - z_0m = 10. * exp(-k/cd_n10_rt) !!!!!!! on calcul le premier z_0 - endif - - - if ( dt .gt. 0. ) then - ch_n10 = 0.018 * cd_n10_rt !!!!!!! si regime stable calcul du ch -! z_0h = 10. * exp(-k/ch_n10) - else - ch_n10 = 0.0327 * cd_n10_rt !!!!!!! si regime instable calcul du ch -! z_0h = 10. * exp(-k/ch_n10) - endif - - ce_n10 = 3.46e-2 *cd_n10_rt !!!!!! calcul ensuite de ce - - - dt_u = dt !!! def - dq_u = dq !!! def - - cd = cd_n10 !!! def - ch = ch_n10 !!! def - ce = ce_n10 !!! def - - cd_rt = sqrt(cd) !!! def - - ! open(7,file="err_rel.dat",position="append") - - -!!!!!!!!! début des itérations.... - - do i = 1,n_it - - usr = cd_rt * u - tsr = ch / cd_rt * dt_u - qsr = ce / cd_rt * dq_u - - - zeta = k*g / (usr**2) * tsr / t1& - * z - - zeta = sign( min(abs(zeta),10.0), zeta ) - - -!!!! calcul du zeta pour connaitre le signe et donc en deduire le regime... - - - - - IF ( zeta(1) .GT. 0 ) THEN !!! si regime stable alors valeurs pr chi et psi - - chi = 0.018 - - - psi(1,1) = -5.*zeta(1) - psi(2,1) = psi(1,1) - - ELSE !!!!! si regime instable alors valeurs pr psi et chi !!! - - chi = 0.0327 - - X = sqrt( sqrt( 1-16.*zeta(1) )) - psi(1,1) = 3.1415695 / 2 + 2 * LOG( ( 1 + X ) / 2 ) + LOG( (1 + X**2) / 2 ) - 2*ATAN(X) - psi(2,1) = 2.*LOG( (1 + X**2) / 2 ) - - END IF - - do j =2,3 - IF ( zeta(j) .GT. 0 ) THEN - psi(1,j) = -5.*zeta(j) - psi(2,j) = psi(1,1) - - ELSE - X = sqrt( sqrt( 1-16.*zeta(j) )) - psi(1,j) = 3.1415695 / 2 + 2 * LOG( ( 1 + X ) / 2 ) + LOG( (1 + X**2) / 2 ) - 2*ATAN(X) - psi(2,j) = 2.*LOG( (1 + X**2) / 2 ) - - END IF - enddo - - - dt_u = dt - tsr / k * & - ( logzt_zu + psi(2,1) - psi(2,2) ) - - dq_u = dq - qsr / k * & - ( logzq_zu + psi(2,1) - psi(2,3) ) - - - - u_N = u / ( 1 + cd_n10_rt / k * ( logzu_10 - psi(1,1)) ) - - if (mixte) then - z_0m=0.018*usr**2/9.81 + 0.11*14e-6 / (usr) -! z_0h=(0.11*14e-6 / (usr)) + 1.4e-5 - cd_n10 = k**2 / (log(10/z_0m))**2 - cd_n10_rt = sqrt(cd_n10) -! ch_n10 = k**2 / ((log(10/z_0m))*(log(10/z_0h))) -! ch_n10_rt = sqrt(ch_n10) - ch_n10 = 1.e-3 - else -! Large and yaeger 2006 - cd_n10 = alpha / u_n + beta + gamma * u_n !!!!! calcul de cd pour core pur -! Large and yaeger 2004 -! cd_n10 = 1E-3 * (2.7/U_n + 0.142 + U_n/13.09) - ! cd_n10_dun = -alpha / u_n**2 + gamma - cd_n10_rt = sqrt(cd_n10) - z_0m = 10. * exp(-k/cd_n10_rt) !!!!! c'est sur cette ligne la qu'il y a un bug... ou sur la ligne du u_N -! ch_n10 = chi * cd_n10_rt -! z_0h = 10. * exp(-k/ch_n10) -! ch_n10_rt = sqrt(ch_n10) - ch_n10 = chi * cd_n10_rt - endif - - - ce_n10 = 3.46e-2*cd_n10_rt - - - - phid = 1+cd_n10_rt/k * (logzu_10 - psi(1,1)) - phih = 1+chi/k * (logzu_10 - psi(2,1)) - phie = 1+3.46e-2/k * (logzu_10 - psi(2,1)) - - - cd_rt = cd_n10_rt / abs( phid ) - ch = ch_n10 / ( phih * phid ) - ce = ce_n10 / ( phie * phid ) - - cd=cd_rt**2 - - END DO - - usr = cd_rt * u - tsr = ch / cd_rt * dt_u - qsr = ce / cd_rt * dq_u - - - ! coeffs(:,m) = [ & - ! rho * usr**2,& - ! rho * cpa * usr *tsr,& - ! rho * le * usr *qsr] - - coeffs = [ cd_rt**2, ch , ce ] - - rugosm = z_0m - rugosh = z_0h - - RETURN - END subroutine clc_core_cp - -END MODULE clc_core_cp_mod - Index: LMDZ6/trunk/libf/phylmd/clc_core_cp_mod.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/clc_core_cp_mod.f90 (revision 6048) +++ LMDZ6/trunk/libf/phylmd/clc_core_cp_mod.f90 (revision 6048) @@ -0,0 +1,238 @@ +MODULE clc_core_cp_mod +! +! $Id$ +! +CONTAINS + + SUBROUTINE clc_core_cp(du, dt, dq, t1, q1, & + zu, zt, zq, & + P,& + n_it, mixte, & + coeffs, rugosm, rugosh) + + IMPLICIT NONE + + + ! INTEGER :: i,j,k + REAL, INTENT(IN) :: du,dt,dq,t1,q1 + REAL, INTENT(IN) :: zu,zt,zq, P + INTEGER, INTENT(IN):: n_it + LOGICAL, INTENT(IN) :: mixte + REAL, DIMENSION(3), INTENT(OUT) :: coeffs + real, intent(out) :: rugosm + real, intent(out) :: rugosh + + +! REAL :: du,dt,t1,dq,q1 + REAL :: dt_u, dq_u + + + + REAL :: cd, ch, cd_rt, cd_n10, ce_n10, ce,& + u_N, X,& + rho,cpa,le + + REAL :: usr,tsr,qsr + REAL, DIMENSION(3) :: zeta ! dans l'ordre: it courant, it precedente, var + REAL, DIMENSION(2,3) :: psi + REAL, PARAMETER :: g = 9.81, k=.41, sqrt_k = .640312 !avec g= gravité, k = cste von karman, sqrt_k = racine(k) + REAL :: logzu_10,logzt_10,logzq_10,logzt_zu,logzq_zu,& + u,cd_n10_rt,ch_n10_rt,ch_n10,chi,z_0m,z_0h,tv + INTEGER :: i,j,m1,m2,m3,m4,m5 + + + REAL :: phih,phid,phie + + + REAL, parameter :: alpha=2.7e-3,& !alpha = a1 ds formulation smith + beta = 1.42e-4,& !beta = a2 ds la formulation smith + gamma = 7.64e-5,& !Large and yaeger 2006 !gamma = a3 ds formulation smith +! gamma = 13.09e-3,& !Large and yaeger 2004 + q0 = 1.64474 ! q0 dzfinis mais pas reutilisée ds la suite ?? + + REAL, dimension(3) :: z + integer, dimension(2) :: tmp_shape + z = [zu, zt, zq] + + + + logzu_10 = LOG(zu/10.) + logzt_10 = LOG(zt/10.) + logzq_10 = LOG(zq/10.) + logzt_zu = logzt_10 - logzu_10 + logzq_zu = logzq_10 - logzu_10 + + cpa = 1004.67 !!! pas reutilise ds nvelle formulation... + + tv = t1 * (1+.608*q1) !!!!! tv pas reutiliser ds nvelle formulation... + rho = p / (287.1 * t1 * (1.+.61*q1)) !!!! rho pas reutiliser ds nvelle formulation.... + + + le = (2.501-.00237*(t1-273.15-dt))*1.e6 !!!!!! le pas reutiliser ds nvelle formulation.... + + u = max(du,.5) !!!! u = vitesse du vent 1 er niveau + u_N = u !!!!!!! u_N utilisée pour le calcul des premier calcul... + + + !!!!! initialisation des parametres et premier calcul de z_0 cd et ch + + + if (mixte) then + z_0m = 1.e-4 !!!!! pour l'initialisation on fixe z_0 a 10-4 + cd_n10 = k**2 / (log(10/z_0m))**2 !!!!! on calcul ensuite cd a 10 m d'après smith + cd_n10_rt = sqrt(cd_n10) + else +! Large and yaeger 2006 + cd_n10 = alpha / u_n + beta + gamma * u_n !!!!! calcul de cd pour core pur +! Large and yaeger 2004 +! cd_n10 = 1E-3 * (2.7/U_n + 0.142 + U_n/13.09) + cd_n10_rt = sqrt(cd_n10) !!!!!! + z_0m = 10. * exp(-k/cd_n10_rt) !!!!!!! on calcul le premier z_0 + endif + + + if ( dt .gt. 0. ) then + ch_n10 = 0.018 * cd_n10_rt !!!!!!! si regime stable calcul du ch +! z_0h = 10. * exp(-k/ch_n10) + else + ch_n10 = 0.0327 * cd_n10_rt !!!!!!! si regime instable calcul du ch +! z_0h = 10. * exp(-k/ch_n10) + endif + + ce_n10 = 3.46e-2 *cd_n10_rt !!!!!! calcul ensuite de ce + + + dt_u = dt !!! def + dq_u = dq !!! def + + cd = cd_n10 !!! def + ch = ch_n10 !!! def + ce = ce_n10 !!! def + + cd_rt = sqrt(cd) !!! def + + ! open(7,file="err_rel.dat",position="append") + + +!!!!!!!!! début des itérations.... + + do i = 1,n_it + + usr = cd_rt * u + tsr = ch / cd_rt * dt_u + qsr = ce / cd_rt * dq_u + + + zeta = k*g / (usr**2) * tsr / t1& + * z + + zeta = sign( min(abs(zeta),10.0), zeta ) + + +!!!! calcul du zeta pour connaitre le signe et donc en deduire le regime... + + + + + IF ( zeta(1) .GT. 0 ) THEN !!! si regime stable alors valeurs pr chi et psi + + chi = 0.018 + + + psi(1,1) = -5.*zeta(1) + psi(2,1) = psi(1,1) + + ELSE !!!!! si regime instable alors valeurs pr psi et chi !!! + + chi = 0.0327 + + X = sqrt( sqrt( 1-16.*zeta(1) )) + psi(1,1) = 3.1415695 / 2 + 2 * LOG( ( 1 + X ) / 2 ) + LOG( (1 + X**2) / 2 ) - 2*ATAN(X) + psi(2,1) = 2.*LOG( (1 + X**2) / 2 ) + + END IF + + do j =2,3 + IF ( zeta(j) .GT. 0 ) THEN + psi(1,j) = -5.*zeta(j) + psi(2,j) = psi(1,1) + + ELSE + X = sqrt( sqrt( 1-16.*zeta(j) )) + psi(1,j) = 3.1415695 / 2 + 2 * LOG( ( 1 + X ) / 2 ) + LOG( (1 + X**2) / 2 ) - 2*ATAN(X) + psi(2,j) = 2.*LOG( (1 + X**2) / 2 ) + + END IF + enddo + + + dt_u = dt - tsr / k * & + ( logzt_zu + psi(2,1) - psi(2,2) ) + + dq_u = dq - qsr / k * & + ( logzq_zu + psi(2,1) - psi(2,3) ) + + + + u_N = u / ( 1 + cd_n10_rt / k * ( logzu_10 - psi(1,1)) ) + + if (mixte) then + z_0m=0.018*usr**2/9.81 + 0.11*14e-6 / (usr) +! z_0h=(0.11*14e-6 / (usr)) + 1.4e-5 + cd_n10 = k**2 / (log(10/z_0m))**2 + cd_n10_rt = sqrt(cd_n10) +! ch_n10 = k**2 / ((log(10/z_0m))*(log(10/z_0h))) +! ch_n10_rt = sqrt(ch_n10) + ch_n10 = 1.e-3 + else +! Large and yaeger 2006 + cd_n10 = alpha / u_n + beta + gamma * u_n !!!!! calcul de cd pour core pur +! Large and yaeger 2004 +! cd_n10 = 1E-3 * (2.7/U_n + 0.142 + U_n/13.09) + ! cd_n10_dun = -alpha / u_n**2 + gamma + cd_n10_rt = sqrt(cd_n10) + z_0m = 10. * exp(-k/cd_n10_rt) !!!!! c'est sur cette ligne la qu'il y a un bug... ou sur la ligne du u_N +! ch_n10 = chi * cd_n10_rt +! z_0h = 10. * exp(-k/ch_n10) +! ch_n10_rt = sqrt(ch_n10) + ch_n10 = chi * cd_n10_rt + endif + + + ce_n10 = 3.46e-2*cd_n10_rt + + + + phid = 1+cd_n10_rt/k * (logzu_10 - psi(1,1)) + phih = 1+chi/k * (logzu_10 - psi(2,1)) + phie = 1+3.46e-2/k * (logzu_10 - psi(2,1)) + + + cd_rt = cd_n10_rt / abs( phid ) + ch = ch_n10 / ( phih * phid ) + ce = ce_n10 / ( phie * phid ) + + cd=cd_rt**2 + + END DO + + usr = cd_rt * u + tsr = ch / cd_rt * dt_u + qsr = ce / cd_rt * dq_u + + + ! coeffs(:,m) = [ & + ! rho * usr**2,& + ! rho * cpa * usr *tsr,& + ! rho * le * usr *qsr] + + coeffs = [ cd_rt**2, ch , ce ] + + rugosm = z_0m + rugosh = z_0h + + RETURN + END subroutine clc_core_cp + +END MODULE clc_core_cp_mod + Index: LMDZ6/trunk/libf/phylmd/clouds_bigauss.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/clouds_bigauss.f90 (revision 6047) +++ (revision ) @@ -1,125 +1,0 @@ - -! $Header$ - - -! ================================================================================ -!$gpum horizontal klon -MODULE clouds_bigauss_mod - - PRIVATE - - PUBLIC clouds_bigauss - - CONTAINS - -SUBROUTINE clouds_bigauss(klon, nd, r, rs, qtc, sigt, ptconv, ratqsc, cldf) - IMPLICIT NONE - - ! -------------------------------------------------------------------------------- - - ! Inputs: - - ! ND----------: Number of vertical levels - ! R--------ND-: Domain-averaged mixing ratio of total water - ! RS-------ND-: Mean saturation humidity mixing ratio within the gridbox - ! QSUB-----ND-: Mixing ratio of condensed water within clouds associated - ! with SUBGRID-SCALE condensation processes (here, it is - ! predicted by the convection scheme) - ! Outputs: - - ! PTCONV-----ND-: Point convectif = TRUE - ! RATQSC-----ND-: Largeur normalisee de la distribution - ! CLDF-----ND-: Fraction nuageuse - - ! -------------------------------------------------------------------------------- - - - INTEGER klon, nd - REAL r(klon, nd), rs(klon, nd), qtc(klon, nd), sigt(klon, nd) - LOGICAL ptconv(klon, nd) - REAL ratqsc(klon, nd) - REAL cldf(klon, nd) - - ! -- parameters controlling the iteration: - ! -- nmax : maximum nb of iterations (hopefully never reached) - ! -- epsilon : accuracy of the numerical resolution - ! -- 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, qsat, delta - REAL sigma1, sigma2, alpha, qconv - REAL xconv, xenv - REAL cconv, cenv - REAL pi, u, v - REAL sqrtpi, sqrt2 - ! lconv = true si le calcul a converge (entre autre si qsub < min_q) - LOGICAL lconv(klon) - - - cldf(1:klon, 1:nd) = 0.0 ! cym - ratqsc(1:klon, 1:nd) = 0.0 - ptconv(1:klon, 1:nd) = .FALSE. - ! cdir end arraycomb - - pi = acos(-1.) - sqrtpi = sqrt(pi) - sqrt2 = sqrt(2.) - - - DO k = 1, nd - - DO i = 1, klon ! vector - - mu = r(i, k) - mu = max(mu, min_mu) - qsat = rs(i, k) - qsat = max(qsat, min_mu) - delta = log(mu/qsat) - qconv=qtc(i,k) - alpha=sigt(i,k) - - IF (qconv Determine x (the parameter k of the GNO PDF) such *** - ! *** that the contribution of subgrid-scale processes to *** - ! *** the in-cloud water content is equal to QSUB(K) *** - ! *** (equations (13), (14), (15) + Appendix B of the paper) *** - ! *** *** - ! *** Here, an iterative method is used for this purpose *** - ! *** (other numerical methods might be more efficient) *** - ! *** *** - ! *** NB: the "error function" is called ERF *** - ! *** (ERF in double precision) *** - - - ! On commence par eliminer les cas pour lesquels on n'a pas - ! suffisamment d'eau nuageuse. - - ! do i=1,klon ! vector - - IF (qsub(i,k) vmax: - - det = delta(i) + vmax(i)*vmax(i) - IF (det<=0.0) vmax(i) = vmax0 + 1.0 - det = delta(i) + vmax(i)*vmax(i) - - IF (det<=0.) THEN - xx(i) = -0.0001 - ELSE - zx1 = -sqrt2*vmax(i) - zx2 = sqrt(1.0+delta(i)/(vmax(i)*vmax(i))) - xx1 = zx1*(1.0-zx2) - xx2 = zx1*(1.0+zx2) - xx(i) = 1.01*xx1 - IF (xx1>=0.0) xx(i) = 0.5*xx2 - END IF - IF (delta(i)<0.) xx(i) = -hsqrtlog_2 - - END IF - - END DO ! vector - - ! ---------------------------------------------------------------------- - ! Debut des nmax iterations pour trouver la solution. - ! ---------------------------------------------------------------------- - - DO n = 1, nmax - - DO i = 1, klon ! vector - IF (.NOT. lconv(i)) THEN - - u = delta(i)/(xx(i)*sqrt2) + xx(i)/(2.*sqrt2) - v = delta(i)/(xx(i)*sqrt2) - xx(i)/(2.*sqrt2) - v2 = v*v - - IF (v>vmax(i)) THEN - - IF (abs(u)>vmax(i) .AND. delta(i)<0.) THEN - - ! -- use asymptotic expression of erf for u and v large: - ! ( -> analytic solution for xx ) - exdel = beta(i)*exp(delta(i)) - aux(i) = 2.0*delta(i)*(1.-exdel)/(1.+exdel) - IF (aux(i)<0.) THEN - ! print*,'AUX(',i,',',k,')<0',aux(i),delta(i),beta(i) - aux(i) = 0. - END IF - xx(i) = -sqrt(aux(i)) - block = exp(-v*v)/v/sqrtpi - dist = 0.0 - fprime = 1.0 - - ELSE - - ! -- erfv -> 1.0, use an asymptotic expression of erfv for v - ! large: - - erfcu = 1.0 - erf(u) - ! !!! ATTENTION : rajout d'un seuil pour l'exponentiel - aux(i) = sqrtpi*erfcu*exp(min(v2,100.)) - coeff = 1.0 - 0.5/(v2) + 0.75/(v2*v2) - block = coeff*exp(-v2)/v/sqrtpi - dist = v*aux(i)/coeff - beta(i) - fprime = 2.0/xx(i)*(v2)*(exp(-delta(i))-u*aux(i)/coeff)/coeff - - END IF ! ABS(u) - - ELSE - - ! -- general case: - - erfcu = 1.0 - erf(u) - erfcv = 1.0 - erf(v) - block = erfcv - dist = erfcu/erfcv - beta(i) - zu2 = u*u - zv2 = v2 - IF (zu2>20. .OR. zv2>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 = 20. - zv2 = 20. - fprime = 0. - ELSE - fprime = 2./sqrtpi/xx(i)/(erfcv*erfcv)* & - (erfcv*v*exp(-zu2)-erfcu*u*exp(-zv2)) - END IF - END IF ! x - - ! -- test numerical convergence: - - ! if (beta(i).lt.1.e-10) then - ! print*,'avant test ',i,k,lconv(i),u(i),v(i),beta(i) - ! stop - ! endif - IF (abs(fprime)<1.E-11) THEN - ! print*,'avant test fprime<.e-11 ' - ! s ,i,k,lconv(i),u(i),v(i),beta(i),fprime(i) - ! print*,'klon,ND,R,RS,QSUB', - ! s klon,ND,R(i,k),rs(i,k),qsub(i,k) - fprime = sign(1.E-11, fprime) - END IF - - - IF (abs(dist/beta(i)) Determine x (the parameter k of the GNO PDF) such *** + ! *** that the contribution of subgrid-scale processes to *** + ! *** the in-cloud water content is equal to QSUB(K) *** + ! *** (equations (13), (14), (15) + Appendix B of the paper) *** + ! *** *** + ! *** Here, an iterative method is used for this purpose *** + ! *** (other numerical methods might be more efficient) *** + ! *** *** + ! *** NB: the "error function" is called ERF *** + ! *** (ERF in double precision) *** + + + ! On commence par eliminer les cas pour lesquels on n'a pas + ! suffisamment d'eau nuageuse. + + ! do i=1,klon ! vector + + IF (qsub(i,k) vmax: + + det = delta(i) + vmax(i)*vmax(i) + IF (det<=0.0) vmax(i) = vmax0 + 1.0 + det = delta(i) + vmax(i)*vmax(i) + + IF (det<=0.) THEN + xx(i) = -0.0001 + ELSE + zx1 = -sqrt2*vmax(i) + zx2 = sqrt(1.0+delta(i)/(vmax(i)*vmax(i))) + xx1 = zx1*(1.0-zx2) + xx2 = zx1*(1.0+zx2) + xx(i) = 1.01*xx1 + IF (xx1>=0.0) xx(i) = 0.5*xx2 + END IF + IF (delta(i)<0.) xx(i) = -hsqrtlog_2 + + END IF + + END DO ! vector + + ! ---------------------------------------------------------------------- + ! Debut des nmax iterations pour trouver la solution. + ! ---------------------------------------------------------------------- + + DO n = 1, nmax + + DO i = 1, klon ! vector + IF (.NOT. lconv(i)) THEN + + u = delta(i)/(xx(i)*sqrt2) + xx(i)/(2.*sqrt2) + v = delta(i)/(xx(i)*sqrt2) - xx(i)/(2.*sqrt2) + v2 = v*v + + IF (v>vmax(i)) THEN + + IF (abs(u)>vmax(i) .AND. delta(i)<0.) THEN + + ! -- use asymptotic expression of erf for u and v large: + ! ( -> analytic solution for xx ) + exdel = beta(i)*exp(delta(i)) + aux(i) = 2.0*delta(i)*(1.-exdel)/(1.+exdel) + IF (aux(i)<0.) THEN + ! print*,'AUX(',i,',',k,')<0',aux(i),delta(i),beta(i) + aux(i) = 0. + END IF + xx(i) = -sqrt(aux(i)) + block = exp(-v*v)/v/sqrtpi + dist = 0.0 + fprime = 1.0 + + ELSE + + ! -- erfv -> 1.0, use an asymptotic expression of erfv for v + ! large: + + erfcu = 1.0 - erf(u) + ! !!! ATTENTION : rajout d'un seuil pour l'exponentiel + aux(i) = sqrtpi*erfcu*exp(min(v2,100.)) + coeff = 1.0 - 0.5/(v2) + 0.75/(v2*v2) + block = coeff*exp(-v2)/v/sqrtpi + dist = v*aux(i)/coeff - beta(i) + fprime = 2.0/xx(i)*(v2)*(exp(-delta(i))-u*aux(i)/coeff)/coeff + + END IF ! ABS(u) + + ELSE + + ! -- general case: + + erfcu = 1.0 - erf(u) + erfcv = 1.0 - erf(v) + block = erfcv + dist = erfcu/erfcv - beta(i) + zu2 = u*u + zv2 = v2 + IF (zu2>20. .OR. zv2>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 = 20. + zv2 = 20. + fprime = 0. + ELSE + fprime = 2./sqrtpi/xx(i)/(erfcv*erfcv)* & + (erfcv*v*exp(-zu2)-erfcu*u*exp(-zv2)) + END IF + END IF ! x + + ! -- test numerical convergence: + + ! if (beta(i).lt.1.e-10) then + ! print*,'avant test ',i,k,lconv(i),u(i),v(i),beta(i) + ! stop + ! endif + IF (abs(fprime)<1.E-11) THEN + ! print*,'avant test fprime<.e-11 ' + ! s ,i,k,lconv(i),u(i),v(i),beta(i),fprime(i) + ! print*,'klon,ND,R,RS,QSUB', + ! s klon,ND,R(i,k),rs(i,k),qsub(i,k) + fprime = sign(1.E-11, fprime) + END IF + + + IF (abs(dist/beta(i))teta(ig,1)) THEN - qmin = ustar(ig)*(max(1.-zlev(ig,k)/pblhmin(ig),0.))**2 - kmin = kap*zlev(ig, k)*qmin - ELSE - kmin = 0. ! kmin n'est utilise que pour les SL stables. - END IF - kn(ig, k) = kmin - km(ig, k) = kmin - END DO - END DO - - - RETURN -END SUBROUTINE coefkzmin - -END MODULE coefkzmin_mod Index: LMDZ6/trunk/libf/phylmd/coefkzmin_mod.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/coefkzmin_mod.f90 (revision 6048) +++ LMDZ6/trunk/libf/phylmd/coefkzmin_mod.f90 (revision 6048) @@ -0,0 +1,137 @@ +MODULE coefkzmin_mod + +CONTAINS + +SUBROUTINE coefkzmin(knon, ypaprs, ypplay, yu, yv, yt, yq, ycdragm, km, kn) +!$gpum horizontal knon + USE dimphy, ONLY: klev + USE yomcst_mod_h +IMPLICIT NONE + + + + ! ....................................................................... + ! Entrees modifies en attendant une version ou les zlev, et zlay soient + ! disponibles. + INTEGER knon + REAL ycdragm(knon) + + REAL yu(knon, klev), yv(knon, klev) + REAL yt(knon, klev), yq(knon, klev) + REAL ypaprs(knon, klev+1), ypplay(knon, klev) + REAL yustar(knon) + REAL yzlay(knon, klev), yzlev(knon, klev+1), yteta(knon, klev) + + INTEGER i + + ! ....................................................................... + + ! En entree : + ! ----------- + + ! zlev : altitude a chaque niveau (interface inferieure de la couche + ! de meme indice) + ! ustar : u* + + ! teta : temperature potentielle au centre de chaque couche + ! (en entree : la valeur au debut du pas de temps) + + ! en sortier : + ! ------------ + + ! km : diffusivite turbulente de quantite de mouvement (au bas de chaque + ! couche) + ! (en sortie : la valeur a la fin du pas de temps) + ! kn : diffusivite turbulente des scalaires (au bas de chaque couche) + ! (en sortie : la valeur a la fin du pas de temps) + + ! ....................................................................... + + REAL ustar(knon) + REAL kmin, qmin, pblhmin(knon), coriol(knon) + REAL zlev(knon, klev+1) + REAL teta(knon, klev) + + REAL km(knon, klev) + REAL kn(knon, klev) + + + INTEGER nlay, nlev + INTEGER ig, k + + REAL, PARAMETER :: kap = 0.4 + + nlay = klev + nlev = klev + 1 + ! ....................................................................... + ! en attendant une version ou les zlev, et zlay soient + ! disponibles. + ! Debut de la partie qui doit etre unclue a terme dans clmain. + + DO i = 1, knon + yzlay(i, 1) = rd*yt(i, 1)/(0.5*(ypaprs(i,1)+ypplay(i, & + 1)))*(ypaprs(i,1)-ypplay(i,1))/rg + END DO + DO k = 2, klev + DO i = 1, knon + yzlay(i, k) = yzlay(i, k-1) + rd*0.5*(yt(i,k-1)+yt(i,k))/ypaprs(i, k)*( & + ypplay(i,k-1)-ypplay(i,k))/rg + END DO + END DO + DO k = 1, klev + DO i = 1, knon + ! ATTENTION:on passe la temperature potentielle virt. pour le calcul de + ! K + yteta(i, k) = yt(i, k)*(ypaprs(i,1)/ypplay(i,k))**rkappa* & + (1.+0.61*yq(i,k)) + END DO + END DO + DO i = 1, knon + yzlev(i, 1) = 0. + yzlev(i, klev+1) = 2.*yzlay(i, klev) - yzlay(i, klev-1) + END DO + DO k = 2, klev + DO i = 1, knon + yzlev(i, k) = 0.5*(yzlay(i,k)+yzlay(i,k-1)) + END DO + END DO + + yustar(1:knon) = sqrt(ycdragm(1:knon)*(yu(1:knon,1)*yu(1:knon,1)+yv(1:knon, & + 1)*yv(1:knon,1))) + + ! Fin de la partie qui doit etre unclue a terme dans clmain. + + ! ette routine est ecrite pour avoir en entree ustar, teta et zlev + ! Ici, on a inclut le calcul de ces trois variables dans la routine + ! coefkzmin en attendant une nouvelle version de la couche limite + ! ou ces variables seront disponibles. + + ! Debut de la routine coefkzmin proprement dite. + + ustar = yustar + teta = yteta + zlev = yzlev + + DO ig = 1, knon + coriol(ig) = 1.E-4 + pblhmin(ig) = 0.07*ustar(ig)/max(abs(coriol(ig)), 2.546E-5) + END DO + + DO k = 2, klev + DO ig = 1, knon + IF (teta(ig,2)>teta(ig,1)) THEN + qmin = ustar(ig)*(max(1.-zlev(ig,k)/pblhmin(ig),0.))**2 + kmin = kap*zlev(ig, k)*qmin + ELSE + kmin = 0. ! kmin n'est utilise que pour les SL stables. + END IF + kn(ig, k) = kmin + km(ig, k) = kmin + END DO + END DO + + + RETURN +END SUBROUTINE coefkzmin + +END MODULE coefkzmin_mod Index: LMDZ6/trunk/libf/phylmd/create_etat0_limit_unstruct_mod.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/create_etat0_limit_unstruct_mod.f90 (revision 6047) +++ (revision ) @@ -1,113 +1,0 @@ -MODULE etat0_limit_unstruct_mod - - LOGICAL, SAVE :: create_etat0_limit -!$OMP THREADPRIVATE(create_etat0_limit) - - - - -CONTAINS - - SUBROUTINE init_etat0_limit_unstruct - USE lmdz_xios, ONLY: xios_set_axis_attr, xios_set_fieldgroup_attr, & - xios_set_filegroup_attr, xios_set_file_attr - USE mod_phys_lmdz_para, ONLY: is_omp_master - USE mod_grid_phy_lmdz, ONLY: grid_type, unstructured - USE ioipsl, ONLY : ioget_year_len - USE ioipsl_getin_p_mod, ONLY: getin_p - USE time_phylmdz_mod, ONLY : annee_ref - USE create_etat0_unstruct_mod, ONLY: init_create_etat0_unstruct - IMPLICIT NONE - - INTEGER :: iflag_phys,i - INTEGER :: ndays - REAL,ALLOCATABLE :: value(:) - - IF (grid_type==unstructured) THEN - CALL getin_p("iflag_phys",iflag_phys) - - CALL getin_p('create_etat0_limit',create_etat0_limit) - - ndays=ioget_year_len(annee_ref) - ALLOCATE(value(ndays)) - DO i=1,ndays - value(i)=i-1 - ENDDO - - IF (is_omp_master) CALL xios_set_axis_attr("time_year",n_glo=ndays,value=value) - - IF (create_etat0_limit) THEN - IF (iflag_phys<100) THEN - IF (is_omp_master) CALL xios_set_fieldgroup_attr("etat0_limit_read",read_access=.TRUE.,enabled=.TRUE.) - IF (is_omp_master) CALL xios_set_filegroup_attr("etat0_limit_read",enabled=.TRUE.) - ENDIF - IF (is_omp_master) CALL xios_set_file_attr("limit_write",enabled=.TRUE.) - CALL init_create_etat0_unstruct - ENDIF - - ENDIF - - END SUBROUTINE init_etat0_limit_unstruct - - SUBROUTINE create_etat0_limit_unstruct - USE mod_grid_phy_lmdz, ONLY: grid_type, unstructured - USE create_etat0_unstruct_mod, ONLY: create_etat0_unstruct - USE create_limit_unstruct_mod, ONLY: create_limit_unstruct - USE phyaqua_mod, ONLY: iniaqua - USE phys_cal_mod, only: year_len - USE mod_phys_lmdz_para, ONLY: is_omp_master - USE ioipsl_getin_p_mod, ONLY: getin_p - USE dimphy, ONLY: klon - USE lmdz_xios, ONLY: xios_context_finalize, xios_set_current_context, & - xios_finalize - USE print_control_mod, ONLY: lunout - IMPLICIT NONE - INTEGER :: iflag_phys - INTEGER :: ierr - CHARACTER (LEN=20) :: modname='create_etat0_limit_unstruct' - CHARACTER (LEN=80) :: abort_message - - IF (grid_type==unstructured) THEN - - CALL getin_p("iflag_phys",iflag_phys) - - IF (iflag_phys<100) THEN - IF ( create_etat0_limit) THEN - CALL create_etat0_unstruct - CALL create_limit_unstruct - IF (is_omp_master) THEN - CALL xios_context_finalize() - CALL xios_set_current_context("icosagcm") ! very bad, need to find an other solution - CALL xios_context_finalize() - CALL xios_finalize() -! CALL MPI_Finalize(ierr) - abort_message='create_etat0_limit_unstruct, Initial state file are created, all is fine' - write(lunout,*) abort_message - STOP 0 -! CALL abort_physic(modname,abort_message,0) - ENDIF -!$OMP BARRIER - abort_message='create_etat0_limit_unstruct, Initial state file are created, all is fine' - CALL abort_physic(modname,abort_message,0) - ENDIF - ELSE - IF (create_etat0_limit) THEN - CALL iniaqua(klon,year_len,iflag_phys) - IF (is_omp_master) THEN - CALL xios_context_finalize() - CALL xios_set_current_context("icosagcm") ! very bad, need to find an other solution - CALL xios_context_finalize() - CALL xios_finalize() -! CALL MPI_Finalize(ierr) - ENDIF -!$OMP BARRIER - abort_message='create_etat0_limit_unstruct, Initial state file are created, all is fine' - CALL abort_physic(modname,abort_message,0) - ENDIF - ENDIF - ENDIF - - END SUBROUTINE create_etat0_limit_unstruct - -END MODULE etat0_limit_unstruct_mod - Index: LMDZ6/trunk/libf/phylmd/ctstar.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ctstar.f90 (revision 6047) +++ (revision ) @@ -1,139 +1,0 @@ -!$gpum horizontal kproma kprof -MODULE ctstart_mod - PRIVATE - - PUBLIC ctstar - - CONTAINS - -SUBROUTINE CTSTAR(KPROMA,KSTART,KPROF,PTB,PRESBH,PRESBF,POROG,PTSTAR,PT0) - -!**** *CTSTAR* - COMPUTES STANDARD SURFACE TEMPERATURE -! AND SURFACE TEMPERATURE. - -! PURPOSE. -! -------- - -! COMPUTES THE STANDARD SURFACE TEMPERATURE AND THE SURFACE -! TEMPERATURE TO BE USED FOR EXTRAPOLATIONS OF TEMPERATURE -! AND GEOPOTENTIEL. - -!** INTERFACE. -! ---------- -! *CALL* *CTSTAR(..)* - -! EXPLICIT ARGUMENTS -! -------------------- - -! KPROMA - HORIZONTAL DIMENSIONS. (INPUT) -! KSTART - START OF WORK (INPUT) -! KPROF - DEPTH OF WORK (INPUT) - -! PTB(KPROMA) - TEMPERATURE AT NFLEVG-1 (INPUT) -! PRESBH(KPROMA) - LOWEST MODEL HALF LEVEL PRESSURES (INPUT) - -! PRESBF(KPROMA) - PRESSURE AT NFLEVG-1 (INPUT) -! POROG(KPROMA) - MODEL ORGRAPHY (INPUT) - - -! PTSTAR(KPROMA) - SURFACE TEMPERATURE (OUTPUT) - -! PT0(KPROMA) - STANDARD SURFACE TEMPERATURE (OUTPUT) - -! IMPLICIT ARGUMENTS : CONSTANTS FROM YOMSTA,YOMCST. -! -------------------- - -! METHOD. -! ------- -! SEE DOCUMENTATION - -! EXTERNALS. NONE. -! ---------- - -! REFERENCE. -! ---------- -! ECMWF Research Department documentation of the IFS - -! AUTHOR. -! ------- -! MATS HAMRUD AND PHILIPPE COURTIER *ECMWF* - -! MODIFICATIONS. -! -------------- -! ORIGINAL : 89-05-02 - -! Modification : 93-06-01 M.Hamrud (Comment only, now T from NFLEVG-1) -! M.Hamrud 01-Oct-2003 CY28 Cleaning - -! ------------------------------------------------------------------ - -!USE PARKIND1 -! ,ONLY : JPIM ,JPRB -!USE YOMHOOK -! ,ONLY : LHOOK, DR_HOOK - -!USE YOMCST, ONLY : RG, RD -! , ONLY : RG - -! ,RD -!USE YOMSTA -! , ONLY : RDTDZ1 - -USE yomcst_mod_h -IMPLICIT NONE - - -!IM INTEGER(KIND=JPIM),INTENT(IN) :: KPROMA -!IM INTEGER(KIND=JPIM),INTENT(IN) :: KSTART -!IM INTEGER(KIND=JPIM),INTENT(IN) :: KPROF -INTEGER,INTENT(IN) :: KPROMA -INTEGER,INTENT(IN) :: KSTART -INTEGER,INTENT(IN) :: KPROF -!IM REAL(KIND=JPRB) ,INTENT(IN) :: PTB(KPROMA) -REAL ,INTENT(IN) :: PTB(KPROMA) -!IM REAL(KIND=JPRB) ,INTENT(IN) :: PRESBH(KPROMA) -REAL ,INTENT(IN) :: PRESBH(KPROMA) -!IM REAL(KIND=JPRB) ,INTENT(IN) :: PRESBF(KPROMA) -REAL ,INTENT(IN) :: PRESBF(KPROMA) -!IM REAL(KIND=JPRB) ,INTENT(IN) :: POROG(KPROMA) -REAL ,INTENT(IN) :: POROG(KPROMA) -!IM REAL(KIND=JPRB) ,INTENT(OUT) :: PTSTAR(KPROMA) -REAL ,INTENT(OUT) :: PTSTAR(KPROMA) -!IM REAL(KIND=JPRB) ,INTENT(OUT) :: PT0(KPROMA) -REAL ,INTENT(OUT) :: PT0(KPROMA) -!IM INTEGER(KIND=JPIM) :: JL -INTEGER :: JL - -!IM REAL(KIND=JPRB) :: ZALPHA, ZDTDZSG -REAL :: ZALPHA, ZDTDZSG -!IM REAL(KIND=JPRB) :: ZHOOK_HANDLE -REAL :: ZHOOK_HANDLE -!IM beg -REAL, PARAMETER :: RDTDZ1=-0.0065 !or USE YOMSTA -!IM end - -! ------------------------------------------------------------------ - -!* 1. COMPUTES SURFACE TEMPERATURE -!* THEN STANDARD SURFACE TEMPERATURE. - -!IF (LHOOK) CALL DR_HOOK('CTSTAR',0,ZHOOK_HANDLE) -ZDTDZSG=-RDTDZ1/RG -! -ZALPHA=ZDTDZSG*RD -DO JL=KSTART,KPROF - - !IM PTSTAR(JL)=PTB(JL)*(1.0_JPRB+ZALPHA*(PRESBH(JL)/PRESBF(JL)-1.0_JPRB)) - PTSTAR(JL)=PTB(JL)*(1.0+ZALPHA*(PRESBH(JL)/PRESBF(JL)-1.0)) - PT0(JL)=PTSTAR(JL)+ZDTDZSG*POROG(JL) -! print*,'cstar JL ptb zalpha PRESBH PRESBF ptstar' & -! ,JL,PTB(JL),ZALPHA,PRESBH(JL),PRESBF(JL),PTSTAR(JL) -ENDDO - - -! ------------------------------------------------------------------ - -!IF (LHOOK) CALL DR_HOOK('CTSTAR',1,ZHOOK_HANDLE) -END SUBROUTINE CTSTAR - -END MODULE ctstart_mod Index: LMDZ6/trunk/libf/phylmd/ctstart_mod.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ctstart_mod.f90 (revision 6048) +++ LMDZ6/trunk/libf/phylmd/ctstart_mod.f90 (revision 6048) @@ -0,0 +1,139 @@ +!$gpum horizontal kproma kprof +MODULE ctstart_mod + PRIVATE + + PUBLIC ctstar + + CONTAINS + +SUBROUTINE CTSTAR(KPROMA,KSTART,KPROF,PTB,PRESBH,PRESBF,POROG,PTSTAR,PT0) + +!**** *CTSTAR* - COMPUTES STANDARD SURFACE TEMPERATURE +! AND SURFACE TEMPERATURE. + +! PURPOSE. +! -------- + +! COMPUTES THE STANDARD SURFACE TEMPERATURE AND THE SURFACE +! TEMPERATURE TO BE USED FOR EXTRAPOLATIONS OF TEMPERATURE +! AND GEOPOTENTIEL. + +!** INTERFACE. +! ---------- +! *CALL* *CTSTAR(..)* + +! EXPLICIT ARGUMENTS +! -------------------- + +! KPROMA - HORIZONTAL DIMENSIONS. (INPUT) +! KSTART - START OF WORK (INPUT) +! KPROF - DEPTH OF WORK (INPUT) + +! PTB(KPROMA) - TEMPERATURE AT NFLEVG-1 (INPUT) +! PRESBH(KPROMA) - LOWEST MODEL HALF LEVEL PRESSURES (INPUT) + +! PRESBF(KPROMA) - PRESSURE AT NFLEVG-1 (INPUT) +! POROG(KPROMA) - MODEL ORGRAPHY (INPUT) + + +! PTSTAR(KPROMA) - SURFACE TEMPERATURE (OUTPUT) + +! PT0(KPROMA) - STANDARD SURFACE TEMPERATURE (OUTPUT) + +! IMPLICIT ARGUMENTS : CONSTANTS FROM YOMSTA,YOMCST. +! -------------------- + +! METHOD. +! ------- +! SEE DOCUMENTATION + +! EXTERNALS. NONE. +! ---------- + +! REFERENCE. +! ---------- +! ECMWF Research Department documentation of the IFS + +! AUTHOR. +! ------- +! MATS HAMRUD AND PHILIPPE COURTIER *ECMWF* + +! MODIFICATIONS. +! -------------- +! ORIGINAL : 89-05-02 + +! Modification : 93-06-01 M.Hamrud (Comment only, now T from NFLEVG-1) +! M.Hamrud 01-Oct-2003 CY28 Cleaning + +! ------------------------------------------------------------------ + +!USE PARKIND1 +! ,ONLY : JPIM ,JPRB +!USE YOMHOOK +! ,ONLY : LHOOK, DR_HOOK + +!USE YOMCST, ONLY : RG, RD +! , ONLY : RG + +! ,RD +!USE YOMSTA +! , ONLY : RDTDZ1 + +USE yomcst_mod_h +IMPLICIT NONE + + +!IM INTEGER(KIND=JPIM),INTENT(IN) :: KPROMA +!IM INTEGER(KIND=JPIM),INTENT(IN) :: KSTART +!IM INTEGER(KIND=JPIM),INTENT(IN) :: KPROF +INTEGER,INTENT(IN) :: KPROMA +INTEGER,INTENT(IN) :: KSTART +INTEGER,INTENT(IN) :: KPROF +!IM REAL(KIND=JPRB) ,INTENT(IN) :: PTB(KPROMA) +REAL ,INTENT(IN) :: PTB(KPROMA) +!IM REAL(KIND=JPRB) ,INTENT(IN) :: PRESBH(KPROMA) +REAL ,INTENT(IN) :: PRESBH(KPROMA) +!IM REAL(KIND=JPRB) ,INTENT(IN) :: PRESBF(KPROMA) +REAL ,INTENT(IN) :: PRESBF(KPROMA) +!IM REAL(KIND=JPRB) ,INTENT(IN) :: POROG(KPROMA) +REAL ,INTENT(IN) :: POROG(KPROMA) +!IM REAL(KIND=JPRB) ,INTENT(OUT) :: PTSTAR(KPROMA) +REAL ,INTENT(OUT) :: PTSTAR(KPROMA) +!IM REAL(KIND=JPRB) ,INTENT(OUT) :: PT0(KPROMA) +REAL ,INTENT(OUT) :: PT0(KPROMA) +!IM INTEGER(KIND=JPIM) :: JL +INTEGER :: JL + +!IM REAL(KIND=JPRB) :: ZALPHA, ZDTDZSG +REAL :: ZALPHA, ZDTDZSG +!IM REAL(KIND=JPRB) :: ZHOOK_HANDLE +REAL :: ZHOOK_HANDLE +!IM beg +REAL, PARAMETER :: RDTDZ1=-0.0065 !or USE YOMSTA +!IM end + +! ------------------------------------------------------------------ + +!* 1. COMPUTES SURFACE TEMPERATURE +!* THEN STANDARD SURFACE TEMPERATURE. + +!IF (LHOOK) CALL DR_HOOK('CTSTAR',0,ZHOOK_HANDLE) +ZDTDZSG=-RDTDZ1/RG +! +ZALPHA=ZDTDZSG*RD +DO JL=KSTART,KPROF + + !IM PTSTAR(JL)=PTB(JL)*(1.0_JPRB+ZALPHA*(PRESBH(JL)/PRESBF(JL)-1.0_JPRB)) + PTSTAR(JL)=PTB(JL)*(1.0+ZALPHA*(PRESBH(JL)/PRESBF(JL)-1.0)) + PT0(JL)=PTSTAR(JL)+ZDTDZSG*POROG(JL) +! print*,'cstar JL ptb zalpha PRESBH PRESBF ptstar' & +! ,JL,PTB(JL),ZALPHA,PRESBH(JL),PRESBF(JL),PTSTAR(JL) +ENDDO + + +! ------------------------------------------------------------------ + +!IF (LHOOK) CALL DR_HOOK('CTSTAR',1,ZHOOK_HANDLE) +END SUBROUTINE CTSTAR + +END MODULE ctstart_mod Index: LMDZ6/trunk/libf/phylmd/cv3_buoy.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cv3_buoy.f90 (revision 6047) +++ (revision ) @@ -1,159 +1,0 @@ -MODULE cv3_buoy_mod - PRIVATE - - PUBLIC cv3_buoy - -CONTAINS - -SUBROUTINE cv3_buoy(nloc, ncum, nd, icb, inb, pbase, plcl, p, ph, ale, cin, & - tv, tvp, buoy) - ! ************************************************************** - ! * - ! CV3_BUOY * - ! Buoyancy corrections to account for ALE * - ! * - ! written by : MOREAU Cecile, 07/08/2003, 15.55.48 * - ! modified by : * - ! ************************************************************** - -USE yomcst2_mod_h - USE lmdz_cv_ini, ONLY : grav,nl - IMPLICIT NONE - - - ! input: - INTEGER ncum, nd, nloc - INTEGER icb(nloc), inb(nloc) - REAL pbase(nloc), plcl(nloc) - REAL p(nloc, nd), ph(nloc, nd+1) - REAL ale(nloc), cin(nloc) - REAL tv(nloc, nd), tvp(nloc, nd) - - ! output: - REAL buoy(nloc, nd) - - ! local variables: - INTEGER il, k - INTEGER kmx(nloc) - REAL bll(nloc), bmx(nloc) - REAL gamma(nloc) - LOGICAL ok(nloc) - - REAL dgamma - REAL buoymin - PARAMETER (dgamma=2.E-03) !dgamma gamma - PARAMETER (buoymin=2.) - - LOGICAL, PARAMETER :: fixed_bll = .TRUE. - - ! print *,' Ale+cin ',ale(1)+cin(1) - ! -------------------------------------------------------------- - ! Recompute buoyancies - ! -------------------------------------------------------------- - DO k = 1, nl - DO il = 1, ncum - buoy(il, k) = tvp(il, k) - tv(il, k) - END DO - END DO - - ! ------------------------------------------------------------- - ! -- Compute low level buoyancy ( function of Ale+Cin ) - ! ------------------------------------------------------------- - IF (fixed_bll) THEN - - DO il = 1, ncum - bll(il) = 0.5 - END DO - ELSE - - DO il = 1, ncum - IF (ale(il)+cin(il)>0.) THEN - gamma(il) = 4.*buoy(il, icb(il))**2 + 8.*dgamma*(ale(il)+cin(il))*tv( & - il, icb(il))/grav - gamma(il) = max(gamma(il), 1.E-10) - END IF - END DO - - DO il = 1, ncum - IF (ale(il)+cin(il)>0.) THEN - bll(il) = 4.*dgamma*(ale(il)+cin(il))*tv(il, icb(il))/ & - (grav*(abs(buoy(il,icb(il))+0.5*sqrt(gamma(il))))) - END IF - END DO - - DO il = 1, ncum - IF (ale(il)+cin(il)>0.) THEN - bll(il) = min(bll(il), buoymin) - END IF - END DO - - END IF !(fixed_bll) - - - ! ------------------------------------------------------------- - ! --Get highest buoyancy among levels below LCL-200hPa - ! ------------------------------------------------------------- - - DO il = 1, ncum - bmx(il) = -1000. - kmx(il) = icb(il) - ok(il) = .TRUE. - END DO - - DO k = 1, nl - DO il = 1, ncum - IF (ale(il)+cin(il)>0. .AND. ok(il)) THEN - IF (k>icb(il) .AND. k<=inb(il)) THEN - ! c print *,'k,p(il,k),plcl(il)-200. ', - ! k,p(il,k),plcl(il)-200. - IF (p(il,k)>plcl(il)-200.) THEN - IF (buoy(il,k)>bmx(il)) THEN - bmx(il) = buoy(il, k) - kmx(il) = k - IF (bmx(il)>=bll(il)) ok(il) = .FALSE. - END IF - END IF - END IF - END IF - END DO - END DO - - ! print *,' ==cv3_buoy== bll(1),bmx(1),icb(1),kmx(1) ' - ! $ ,bll(1),bmx(1),icb(1),kmx(1) - - ! ------------------------------------------------------------- - ! --Calculate modified buoyancies - ! ------------------------------------------------------------- - - DO il = 1, ncum - IF (ale(il)+cin(il)>0.) THEN - bll(il) = min(bll(il), bmx(il)) - END IF - END DO - - DO k = 1, nl - DO il = 1, ncum - IF (ale(il)+cin(il)>0.) THEN - IF (k>=icb(il) .AND. k<=kmx(il)-1) THEN - buoy(il, k) = bll(il) - END IF - END IF - END DO - END DO - -!CR:Correction of buoy for what comes next -!keep flag or to modify in all cases? - IF (iflag_mix_adiab.eq.1) THEN - DO k = 1, nl - DO il = 1, ncum - IF ((k>=kmx(il)) .AND. (k<=inb(il)) .AND. (buoy(il,k).lt.0.)) THEN - buoy(il,k)=buoy(il,k-1) - END IF - ENDDO - ENDDO - ENDIF - - RETURN -END SUBROUTINE cv3_buoy - -END MODULE cv3_buoy_mod Index: LMDZ6/trunk/libf/phylmd/cv3_buoy_mod.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cv3_buoy_mod.f90 (revision 6048) +++ LMDZ6/trunk/libf/phylmd/cv3_buoy_mod.f90 (revision 6048) @@ -0,0 +1,159 @@ +MODULE cv3_buoy_mod + PRIVATE + + PUBLIC cv3_buoy + +CONTAINS + +SUBROUTINE cv3_buoy(nloc, ncum, nd, icb, inb, pbase, plcl, p, ph, ale, cin, & + tv, tvp, buoy) + ! ************************************************************** + ! * + ! CV3_BUOY * + ! Buoyancy corrections to account for ALE * + ! * + ! written by : MOREAU Cecile, 07/08/2003, 15.55.48 * + ! modified by : * + ! ************************************************************** + +USE yomcst2_mod_h + USE lmdz_cv_ini, ONLY : grav,nl + IMPLICIT NONE + + + ! input: + INTEGER ncum, nd, nloc + INTEGER icb(nloc), inb(nloc) + REAL pbase(nloc), plcl(nloc) + REAL p(nloc, nd), ph(nloc, nd+1) + REAL ale(nloc), cin(nloc) + REAL tv(nloc, nd), tvp(nloc, nd) + + ! output: + REAL buoy(nloc, nd) + + ! local variables: + INTEGER il, k + INTEGER kmx(nloc) + REAL bll(nloc), bmx(nloc) + REAL gamma(nloc) + LOGICAL ok(nloc) + + REAL dgamma + REAL buoymin + PARAMETER (dgamma=2.E-03) !dgamma gamma + PARAMETER (buoymin=2.) + + LOGICAL, PARAMETER :: fixed_bll = .TRUE. + + ! print *,' Ale+cin ',ale(1)+cin(1) + ! -------------------------------------------------------------- + ! Recompute buoyancies + ! -------------------------------------------------------------- + DO k = 1, nl + DO il = 1, ncum + buoy(il, k) = tvp(il, k) - tv(il, k) + END DO + END DO + + ! ------------------------------------------------------------- + ! -- Compute low level buoyancy ( function of Ale+Cin ) + ! ------------------------------------------------------------- + IF (fixed_bll) THEN + + DO il = 1, ncum + bll(il) = 0.5 + END DO + ELSE + + DO il = 1, ncum + IF (ale(il)+cin(il)>0.) THEN + gamma(il) = 4.*buoy(il, icb(il))**2 + 8.*dgamma*(ale(il)+cin(il))*tv( & + il, icb(il))/grav + gamma(il) = max(gamma(il), 1.E-10) + END IF + END DO + + DO il = 1, ncum + IF (ale(il)+cin(il)>0.) THEN + bll(il) = 4.*dgamma*(ale(il)+cin(il))*tv(il, icb(il))/ & + (grav*(abs(buoy(il,icb(il))+0.5*sqrt(gamma(il))))) + END IF + END DO + + DO il = 1, ncum + IF (ale(il)+cin(il)>0.) THEN + bll(il) = min(bll(il), buoymin) + END IF + END DO + + END IF !(fixed_bll) + + + ! ------------------------------------------------------------- + ! --Get highest buoyancy among levels below LCL-200hPa + ! ------------------------------------------------------------- + + DO il = 1, ncum + bmx(il) = -1000. + kmx(il) = icb(il) + ok(il) = .TRUE. + END DO + + DO k = 1, nl + DO il = 1, ncum + IF (ale(il)+cin(il)>0. .AND. ok(il)) THEN + IF (k>icb(il) .AND. k<=inb(il)) THEN + ! c print *,'k,p(il,k),plcl(il)-200. ', + ! k,p(il,k),plcl(il)-200. + IF (p(il,k)>plcl(il)-200.) THEN + IF (buoy(il,k)>bmx(il)) THEN + bmx(il) = buoy(il, k) + kmx(il) = k + IF (bmx(il)>=bll(il)) ok(il) = .FALSE. + END IF + END IF + END IF + END IF + END DO + END DO + + ! print *,' ==cv3_buoy== bll(1),bmx(1),icb(1),kmx(1) ' + ! $ ,bll(1),bmx(1),icb(1),kmx(1) + + ! ------------------------------------------------------------- + ! --Calculate modified buoyancies + ! ------------------------------------------------------------- + + DO il = 1, ncum + IF (ale(il)+cin(il)>0.) THEN + bll(il) = min(bll(il), bmx(il)) + END IF + END DO + + DO k = 1, nl + DO il = 1, ncum + IF (ale(il)+cin(il)>0.) THEN + IF (k>=icb(il) .AND. k<=kmx(il)-1) THEN + buoy(il, k) = bll(il) + END IF + END IF + END DO + END DO + +!CR:Correction of buoy for what comes next +!keep flag or to modify in all cases? + IF (iflag_mix_adiab.eq.1) THEN + DO k = 1, nl + DO il = 1, ncum + IF ((k>=kmx(il)) .AND. (k<=inb(il)) .AND. (buoy(il,k).lt.0.)) THEN + buoy(il,k)=buoy(il,k-1) + END IF + ENDDO + ENDDO + ENDIF + + RETURN +END SUBROUTINE cv3_buoy + +END MODULE cv3_buoy_mod Index: LMDZ6/trunk/libf/phylmd/cv3_cine.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cv3_cine.f90 (revision 6047) +++ (revision ) @@ -1,470 +1,0 @@ - -! $Id$ -MODULE cv3_cine_mod - PRIVATE - - PUBLIC cv3_cine - -CONTAINS - -SUBROUTINE cv3_cine(nloc, ncum, nd, icb, inb, pbase, plcl, p, ph, tv, tvp, & - cina, cinb, plfc) - - ! ************************************************************** - ! * - ! CV3_CINE * - ! * - ! * - ! written by : Frederique Cheruy * - ! vectorization: Jean-Yves Grandpeix, 19/06/2003, 11.54.43 * - ! modified by : * - ! ************************************************************** - - USE lmdz_cv_ini, ONLY : nl - - USE yomcst_mod_h -IMPLICIT NONE - - - ! input: - INTEGER ncum, nd, nloc - INTEGER icb(nloc), inb(nloc) - REAL pbase(nloc), plcl(nloc) - REAL p(nloc, nd), ph(nloc, nd+1) - REAL tv(nloc, nd), tvp(nloc, nd) - - ! output - REAL cina(nloc), cinb(nloc), plfc(nloc) - - ! local variables - INTEGER il, i, j, k - INTEGER itop(nloc), ineg(nloc), ilow(nloc) - INTEGER ifst(nloc), isublcl(nloc) - LOGICAL lswitch(nloc), lswitch1(nloc), lswitch2(nloc), lswitch3(nloc) - LOGICAL exist_lfc(nloc) - REAL dpmax - REAL deltap, dcin - REAL buoylcl(nloc), tvplcl(nloc), tvlcl(nloc) - REAL p0(nloc) - REAL buoyz(nloc), buoy(nloc, nd) - - ! ------------------------------------------------------------- - ! Initialization - ! ------------------------------------------------------------- - DO il = 1, ncum - cina(il) = 0. - cinb(il) = 0. - END DO - - ! -------------------------------------------------------------- - ! Recompute buoyancies - ! -------------------------------------------------------------- - DO k = 1, nd - DO il = 1, ncum - ! print*,'tvp tv=',tvp(il,k),tv(il,k) - buoy(il, k) = tvp(il, k) - tv(il, k) - END DO - END DO - ! --------------------------------------------------------------- - - ! calcul de la flottabilite a LCL (Buoylcl) - ! ifst = first P-level above lcl - ! isublcl = highest P-level below lcl. - ! --------------------------------------------------------------- - - DO il = 1, ncum - tvplcl(il) = tvp(il, 1)*(plcl(il)/p(il,1))**(2./7.) !For dry air, R/Cp=2/7 - END DO - - DO il = 1, ncum - IF (plcl(il)>p(il,icb(il))) THEN - ifst(il) = icb(il) - isublcl(il) = icb(il) - 1 - ELSE - ifst(il) = icb(il) + 1 - isublcl(il) = icb(il) - END IF - END DO - - DO il = 1, ncum - tvlcl(il) = tv(il, ifst(il)-1) + (tv(il,ifst(il))-tv(il,ifst(il)-1))*( & - plcl(il)-p(il,ifst(il)-1))/(p(il,ifst(il))-p(il,ifst(il)-1)) - END DO - - DO il = 1, ncum - buoylcl(il) = tvplcl(il) - tvlcl(il) - END DO - - ! --------------------------------------------------------------- - ! premiere couche contenant un niveau de flotabilite positive - ! et premiere couche contenant un niveau de flotabilite negative - ! au dessus du niveau de condensation - ! --------------------------------------------------------------- - DO il = 1, ncum - itop(il) = nl - 1 - ineg(il) = nl - 1 - exist_lfc(il) = .FALSE. - END DO - DO k = nl - 1, 1, -1 - DO il = 1, ncum - IF (k>=ifst(il)) THEN - IF (buoy(il,k)>0.) THEN - itop(il) = k - exist_lfc(il) = .TRUE. - ELSE - ineg(il) = k - END IF - END IF - END DO - END DO - - ! --------------------------------------------------------------- - ! When there is no positive buoyancy level, set Plfc, Cina and Cinb - ! to arbitrary extreme values. - ! --------------------------------------------------------------- - DO il = 1, ncum - IF (.NOT. exist_lfc(il)) THEN - plfc(il) = 1.111 - cinb(il) = -1111. - cina(il) = -1112. - END IF - END DO - - - ! --------------------------------------------------------------- - ! -- Two cases : BUOYlcl >= 0 and BUOYlcl < 0. - ! --------------------------------------------------------------- - - ! -------------------- - ! -- 1.0 BUOYlcl >=0. - ! -------------------- - - dpmax = 50. - DO il = 1, ncum - lswitch1(il) = buoylcl(il) >= 0. .AND. exist_lfc(il) - lswitch(il) = lswitch1(il) - END DO - - ! 1.1 No inhibition case - ! ---------------------- - ! If buoyancy is positive at LCL and stays positive over a large enough - ! pressure interval (=DPMAX), inhibition is set to zero, - - DO il = 1, ncum - IF (lswitch(il)) THEN - IF (p(il,ineg(il))= p(il, icb(il)) - dpmax - lswitch(il) = lswitch1(il) .AND. lswitch2(il) - END DO - - ! 1.2.1 Recompute itop (=1st layer with positive buoyancy above ineg) - ! ------------------------------------------------------------------- - - DO il = 1, ncum - IF (lswitch(il)) THEN - itop(il) = nl - 1 - END IF - END DO - - DO k = nl, 1, -1 - DO il = 1, ncum - IF (lswitch(il)) THEN - IF (k>=ineg(il) .AND. buoy(il,k)>0) THEN - itop(il) = k - END IF - END IF - END DO - END DO - - ! If there is no layer with positive buoyancy above ineg, set Plfc, - ! Cina and Cinb to arbitrary extreme values. - DO il = 1, ncum - IF (lswitch(il) .AND. itop(il) == nl - 1) THEN - plfc(il) = 1.121 - cinb(il) = -1121. - cina(il) = -1122. - END IF - END DO - - DO il = 1, ncum - lswitch3(il) = itop(il) < nl -1 - lswitch(il) = lswitch1(il) .AND. lswitch2(il) .AND. lswitch3(il) - END DO - - DO il = 1, ncum - IF (lswitch(il)) THEN - cinb(il) = 0. - - ! 1.2.2 Calcul de la pression du niveau de flot. nulle juste au-dessus - ! de LCL - ! --------------------------------------------------------------------------- - IF (ineg(il)>isublcl(il)+1) THEN - ! In order to get P0, one may interpolate linearly buoyancies - ! between P(ineg) and P(ineg-1). - p0(il) = (buoy(il,ineg(il))*p(il,ineg(il)-1)-buoy(il,ineg(il)-1)*p(il,ineg(il)))/ & - (buoy(il,ineg(il))-buoy(il,ineg(il)-1)) - ELSE - ! In order to get P0, one has to interpolate between P(ineg) and - ! Plcl. - p0(il) = (buoy(il,ineg(il))*plcl(il)-buoylcl(il)*p(il,ineg(il)))/ & - (buoy(il,ineg(il))-buoylcl(il)) - END IF - END IF - END DO - - ! 1.2.3 Computation of PLFC - ! ------------------------- - DO il = 1, ncum - IF (lswitch(il)) THEN - plfc(il) = (buoy(il,itop(il))*p(il,itop(il)-1)-buoy(il,itop( & - il)-1)*p(il,itop(il)))/(buoy(il,itop(il))-buoy(il,itop(il)-1)) - END IF - END DO - - ! 1.2.4 Computation of CINA - ! ------------------------- - - ! Upper part of CINA : integral from P(itop-1) to Plfc - DO il = 1, ncum - IF (lswitch(il)) THEN - deltap = p(il, itop(il)-1) - plfc(il) - dcin = rd*buoy(il, itop(il)-1)*deltap/(p(il,itop(il)-1)+plfc(il)) - cina(il) = min(0., dcin) - END IF - END DO - - ! Middle part of CINA : integral from P(ineg) to P(itop-1) - DO k = 1, nl - DO il = 1, ncum - IF (lswitch(il)) THEN - IF (k>=ineg(il) .AND. k<=itop(il)-2) THEN - deltap = p(il, k) - p(il, k+1) - dcin = 0.5*rd*(buoy(il,k)+buoy(il,k+1))*deltap/ph(il, k+1) - cina(il) = cina(il) + min(0., dcin) - END IF - END IF - END DO - END DO - - ! Lower part of CINA : integral from P0 to P(ineg) - DO il = 1, ncum - IF (lswitch(il)) THEN - deltap = p0(il) - p(il, ineg(il)) - dcin = rd*buoy(il, ineg(il))*deltap/(p(il,ineg(il))+p0(il)) - cina(il) = cina(il) + min(0., dcin) - END IF - END DO - - - ! ------------------ - ! -- 2.0 BUOYlcl <0. - ! ------------------ - - DO il = 1, ncum - lswitch1(il) = buoylcl(il) < 0. .AND. exist_lfc(il) - lswitch(il) = lswitch1(il) - END DO - - ! 2.0.1 Premiere couche ou la flotabilite est negative au dessus du sol - ! ---------------------------------------------------- - ! au cas ou elle existe sinon ilow=1 (nk apres) - ! on suppose que la parcelle part de la premiere couche - - DO il = 1, ncum - IF (lswitch(il)) THEN - ilow(il) = 1 - END IF - END DO - - DO k = nl, 1, -1 - DO il = 1, ncum - IF (lswitch(il) .AND. k<=icb(il)-1) THEN - IF (buoy(il,k)<0.) THEN - ilow(il) = k - END IF - END IF - END DO - END DO - - ! 2.0.2 Calcul de la pression du niveau de flot. nulle sous le nuage - ! ---------------------------------------------------- - DO il = 1, ncum - IF (lswitch(il)) THEN - IF (ilow(il)>1) THEN - p0(il) = (buoy(il,ilow(il))*p(il,ilow(il)-1)-buoy(il,ilow( & - il)-1)*p(il,ilow(il)))/(buoy(il,ilow(il))-buoy(il,ilow(il)-1)) - buoyz(il) = 0. - ELSE - p0(il) = p(il, 1) - buoyz(il) = buoy(il, 1) - END IF - END IF - END DO - - ! 2.1. Computation of CINB - ! ----------------------- - - DO il = 1, ncum - lswitch2(il) = (isublcl(il)==1 .AND. ilow(il)==1) .OR. & - (isublcl(il)==ilow(il)-1) - lswitch(il) = lswitch1(il) .AND. lswitch2(il) - END DO - ! c IF ( (isublcl .EQ. 1 .AND. ilow .EQ. 1) - ! c $ .OR.(isublcl .EQ. ilow-1)) THEN - - ! 2.1.1 First case : Plcl just above P0 - ! ------------------------------------- - DO il = 1, ncum - IF (lswitch(il)) THEN - deltap = p0(il) - plcl(il) - dcin = rd*(buoyz(il)+buoylcl(il))*deltap/(p0(il)+plcl(il)) - cinb(il) = min(0., dcin) - END IF - END DO - - DO il = 1, ncum - lswitch(il) = lswitch1(il) .AND. .NOT. lswitch2(il) - END DO - ! c ELSE - - ! 2.1.2 Second case : there is at least one P-level between P0 and Plcl - ! --------------------------------------------------------------------- - - ! Lower part of CINB : integral from P0 to P(ilow) - DO il = 1, ncum - IF (lswitch(il)) THEN - deltap = p0(il) - p(il, ilow(il)) - dcin = rd*(buoyz(il)+buoy(il,ilow(il)))*deltap/(p0(il)+p(il,ilow(il))) - cinb(il) = min(0., dcin) - END IF - END DO - - - ! Middle part of CINB : integral from P(ilow) to P(isublcl) - ! c DO k = ilow,isublcl-1 - DO k = 1, nl - DO il = 1, ncum - IF (lswitch(il) .AND. k>=ilow(il) .AND. k<=isublcl(il)-1) THEN - deltap = p(il, k) - p(il, k+1) - dcin = 0.5*rd*(buoy(il,k)+buoy(il,k+1))*deltap/ph(il, k+1) - cinb(il) = cinb(il) + min(0., dcin) - END IF - END DO - END DO - - ! Upper part of CINB : integral from P(isublcl) to Plcl - DO il = 1, ncum - IF (lswitch(il)) THEN - deltap = p(il, isublcl(il)) - plcl(il) - dcin = rd*(buoy(il,isublcl(il))+buoylcl(il))*deltap/ & - (p(il,isublcl(il))+plcl(il)) - cinb(il) = cinb(il) + min(0., dcin) - END IF - END DO - - - ! c ENDIF - - ! 2.2 Computation of CINA - ! --------------------- - - DO il = 1, ncum - lswitch2(il) = plcl(il) > p(il, itop(il)-1) - lswitch(il) = lswitch1(il) .AND. lswitch2(il) - END DO - - ! 2.2.1 FIrst case : Plcl > P(itop-1) - ! --------------------------------- - ! In order to get Plfc, one may interpolate linearly buoyancies - ! between P(itop) and P(itop-1). - DO il = 1, ncum - IF (lswitch(il)) THEN - plfc(il) = (buoy(il,itop(il))*p(il,itop(il)-1)-buoy(il,itop( & - il)-1)*p(il,itop(il)))/(buoy(il,itop(il))-buoy(il,itop(il)-1)) - END IF - END DO - - ! Upper part of CINA : integral from P(itop-1) to Plfc - DO il = 1, ncum - IF (lswitch(il)) THEN - deltap = p(il, itop(il)-1) - plfc(il) - dcin = rd*buoy(il, itop(il)-1)*deltap/(p(il,itop(il)-1)+plfc(il)) - cina(il) = min(0., dcin) - END IF - END DO - - ! Middle part of CINA : integral from P(icb+1) to P(itop-1) - DO k = 1, nl - DO il = 1, ncum - IF (lswitch(il) .AND. k>=icb(il)+1 .AND. k<=itop(il)-2) THEN - deltap = p(il, k) - p(il, k+1) - dcin = 0.5*rd*(buoy(il,k)+buoy(il,k+1))*deltap/ph(il, k+1) - cina(il) = cina(il) + min(0., dcin) - END IF - END DO - END DO - - ! Lower part of CINA : integral from Plcl to P(icb+1) - DO il = 1, ncum - IF (lswitch(il)) THEN - IF (plcl(il)>p(il,icb(il))) THEN - IF (icb(il)cv3_vertmix, plim1,plim2 ', plim1,plim2 !jyg - plim2p(:) = min(plim2(:),plim1(:)-dpmin) - j1(:)=nd - j2(:) = 0 - DO j = 1, nd - DO i = 1, len - IF (plim1(i)<=ph(i,j)) j1(i) = j -!!! IF (plim2p(i)>=ph(i,j+1) .AND. plim2p(i)=j1(i) .AND. j<=j2(i)) THEN - p1(i, j) = min(ph(i,j), plim1(i)) - p2(i, j) = max(ph(i,j+1), plim2p(i)) - ! CRtest:couplage thermiques: deja normalise - ! wi(i,j) = w(j) - ! print*,'wi',wi(i,j) - wi(i, j) = w(j)*(p1(i,j)-p2(i,j))*coef(i)+eqwght(i) - dpw(i) = dpw(i) + wi(i, j) - -!! print *,'cv3_vertmix, j, wi(1,j),dpw ', j, wi(1,j),dpw !jyg - - END IF - END DO - END DO - - ! CR:print - ! do i=1,len - ! print*,'plim',plim1(i),plim2p(i) - ! enddo - DO j = 1, nd - DO i = 1, len - IF (j>=j1(i) .AND. j<=j2(i)) THEN - wi(i, j) = wi(i, j)/dpw(i) - akm(i) = akm(i) + (cpd*(1.-q(i,j))+q(i,j)*cpv)*t(i, j)*wi(i, j) - qmix(i) = qmix(i) + q(i, j)*wi(i, j) - umix(i) = umix(i) + u(i, j)*wi(i, j) - vmix(i) = vmix(i) + v(i, j)*wi(i, j) - END IF - END DO - END DO - - DO i = 1, len - rdcp(i) = (rrd*(1.-qmix(i))+qmix(i)*rrv)/(cpd*(1.-qmix(i))+qmix(i)*cpv) - END DO - - -!! print *,'cv3_vertmix, rdcp ', rdcp !jyg - - - - DO j = 1, nd - DO i = 1, len - IF (j>=j1(i) .AND. j<=j2(i)) THEN - ! c x=(.5*(p1(i,j)+p2(i,j))*p0m1)**rdcp(i) - y = (.5*(p1(i,j)+p2(i,j))/pnk(i))**rdcp(i) - ! c a2(i)=a2(i)+(cpd*(1.-qmix(i))+qmix(i)*cpv)*x*wi(i,j) - b2(i) = b2(i) + (cpd*(1.-qmix(i))+qmix(i)*cpv)*y*wi(i, j) - END IF - END DO - END DO - - DO i = 1, len - tmix(i) = akm(i)/b2(i) - thmix(i) = tmix(i)*(p0/pnk(i))**rdcp(i) - ! print*,'thmix akm',akm(i),b2(i) - ! print*,'thmix t',tmix(i),p0 - ! print*,'thmix p',pnk(i),rdcp(i) - ! print*,'thmix',thmix(i) - ! c thmix(i) = akm(i)/a2(i) - ! c tmix(i)= thmix(i)*(pnk(i)*p0m1)**rdcp(i) - zdelta = max(0., sign(1.,rtt-tmix(i))) - qsmix(i) = r2es*foeew(tmix(i), zdelta)/(pnk(i)*100.) - qsmix(i) = min(0.5, qsmix(i)) - zcor = 1./(1.-retv*qsmix(i)) - qsmix(i) = qsmix(i)*zcor - END DO - - ! ------------------------------------------------------------------- - ! --- Calculate lifted condensation level of air at parcel origin level - ! --- (Within 0.2% of formula of Bolton, MON. WEA. REV.,1980) - ! ------------------------------------------------------------------- - - a = 1669.0 ! convect3 - b = 122.0 ! convect3 - - - niflag7 = 0 - DO i = 1, len - - IF (iflag(i)/=7) THEN ! modif sb Jun7th 2002 - - rh(i) = qmix(i)/qsmix(i) - chi(i) = tmix(i)/(a-b*rh(i)-tmix(i)) ! convect3 - ! ATTENTION, la LIGNE DESSOUS A ETE RAJOUTEE ARBITRAIREMENT ET - ! MASQUE UN PB POTENTIEL - chi(i) = max(chi(i), 0.) - rh(i) = max(rh(i), 0.) - plcl(i) = pnk(i)*(rh(i)**chi(i)) - IF (((plcl(i)<200.0) .OR. (plcl(i)>=2000.0)) .AND. (iflag(i)==0)) & - iflag(i) = 8 - - ELSE - - niflag7 = niflag7 + 1 - plcl(i) = plim2p(i) - - END IF ! iflag=7 - - ! print*,'NIFLAG7 =',niflag7 - - END DO - -!! print *,' cv3_vertmix->' !jyg - - - RETURN -END SUBROUTINE cv3_enthalpmix - -END MODULE cv3_enthalpmix_mod Index: LMDZ6/trunk/libf/phylmd/cv3_enthalpmix_mod.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cv3_enthalpmix_mod.f90 (revision 6048) +++ LMDZ6/trunk/libf/phylmd/cv3_enthalpmix_mod.f90 (revision 6048) @@ -0,0 +1,222 @@ +MODULE cv3_enthalpmix_mod + PRIVATE + + PUBLIC cv3_enthalpmix + +CONTAINS + +SUBROUTINE cv3_enthalpmix(len, nd, iflag, plim1, plim2, p, ph, & + t, q, u, v, w, & + wi, nk, tmix, thmix, qmix, qsmix, umix, vmix, plcl) + ! ************************************************************** + ! * + ! CV3_ENTHALPMIX Brassage adiabatique d'une couche d'epaisseur * + ! arbitraire. * + ! * + ! written by : Grandpeix Jean-Yves, 28/12/2001, 13.14.24 * + ! modified by : Filiberti M-A 06/2005 vectorisation * + ! ************************************************************** + + USE lmdz_cv_ini, ONLY : cpd,cpv,rrd,rrv + USE yomcst_mod_h + USE yoethf_mod_h +IMPLICIT NONE + ! ============================================================== + + ! vertmix : determines theta, t, q, qs, u and v of the mixture generated by + ! adiabatic mixing of air between plim1 and plim2 with weighting w. + ! If plim1 and plim2 fall within the same model layer, then theta, ... v + ! are those of that layer. + ! A minimum value (dpmin) is imposed upon plim1-plim2 + + ! =============================================================== + + include "FCTTRE.h" +!inputs: + INTEGER, INTENT (IN) :: nd, len + INTEGER, DIMENSION (len), INTENT (IN) :: nk + REAL, DIMENSION (len), INTENT (IN) :: plim1, plim2 + REAL, DIMENSION (len,nd), INTENT (IN) :: t, q + REAL, DIMENSION (len,nd), INTENT (IN) :: u, v + REAL, DIMENSION (nd), INTENT (IN) :: w + REAL, DIMENSION (len,nd), INTENT (IN) :: p + REAL, DIMENSION (len,nd+1), INTENT (IN) :: ph +!input/output: + INTEGER, DIMENSION (len), INTENT (INOUT) :: iflag +!outputs: + REAL, DIMENSION (len), INTENT (OUT) :: tmix, thmix, qmix + REAL, DIMENSION (len), INTENT (OUT) :: umix, vmix + REAL, DIMENSION (len), INTENT (OUT) :: qsmix + REAL, DIMENSION (len), INTENT (OUT) :: plcl + REAL, DIMENSION (len,nd), INTENT (OUT) :: wi +!internal variables : + INTEGER i, j + INTEGER niflag7 + INTEGER, DIMENSION(len) :: j1, j2 + REAL :: a, b + REAL :: cpn + REAL :: x, y, p0, p0m1, zdelta, zcor + REAL, PARAMETER :: dpmin=1. + REAL, DIMENSION(len) :: plim2p ! = min(plim2(:),plim1(:)-dpmin) + REAL, DIMENSION(len) :: akm ! mixture enthalpy + REAL, DIMENSION(len) :: dpw, coef + REAL, DIMENSION(len) :: rdcp, a2, b2, pnk + REAL, DIMENSION(len) :: rh, chi + REAL, DIMENSION(len) :: eqwght + REAL, DIMENSION(len,nd) :: p1, p2 + + +!! print *,' ->cv3_vertmix, plim1,plim2 ', plim1,plim2 !jyg + plim2p(:) = min(plim2(:),plim1(:)-dpmin) + j1(:)=nd + j2(:) = 0 + DO j = 1, nd + DO i = 1, len + IF (plim1(i)<=ph(i,j)) j1(i) = j +!!! IF (plim2p(i)>=ph(i,j+1) .AND. plim2p(i)=j1(i) .AND. j<=j2(i)) THEN + p1(i, j) = min(ph(i,j), plim1(i)) + p2(i, j) = max(ph(i,j+1), plim2p(i)) + ! CRtest:couplage thermiques: deja normalise + ! wi(i,j) = w(j) + ! print*,'wi',wi(i,j) + wi(i, j) = w(j)*(p1(i,j)-p2(i,j))*coef(i)+eqwght(i) + dpw(i) = dpw(i) + wi(i, j) + +!! print *,'cv3_vertmix, j, wi(1,j),dpw ', j, wi(1,j),dpw !jyg + + END IF + END DO + END DO + + ! CR:print + ! do i=1,len + ! print*,'plim',plim1(i),plim2p(i) + ! enddo + DO j = 1, nd + DO i = 1, len + IF (j>=j1(i) .AND. j<=j2(i)) THEN + wi(i, j) = wi(i, j)/dpw(i) + akm(i) = akm(i) + (cpd*(1.-q(i,j))+q(i,j)*cpv)*t(i, j)*wi(i, j) + qmix(i) = qmix(i) + q(i, j)*wi(i, j) + umix(i) = umix(i) + u(i, j)*wi(i, j) + vmix(i) = vmix(i) + v(i, j)*wi(i, j) + END IF + END DO + END DO + + DO i = 1, len + rdcp(i) = (rrd*(1.-qmix(i))+qmix(i)*rrv)/(cpd*(1.-qmix(i))+qmix(i)*cpv) + END DO + + +!! print *,'cv3_vertmix, rdcp ', rdcp !jyg + + + + DO j = 1, nd + DO i = 1, len + IF (j>=j1(i) .AND. j<=j2(i)) THEN + ! c x=(.5*(p1(i,j)+p2(i,j))*p0m1)**rdcp(i) + y = (.5*(p1(i,j)+p2(i,j))/pnk(i))**rdcp(i) + ! c a2(i)=a2(i)+(cpd*(1.-qmix(i))+qmix(i)*cpv)*x*wi(i,j) + b2(i) = b2(i) + (cpd*(1.-qmix(i))+qmix(i)*cpv)*y*wi(i, j) + END IF + END DO + END DO + + DO i = 1, len + tmix(i) = akm(i)/b2(i) + thmix(i) = tmix(i)*(p0/pnk(i))**rdcp(i) + ! print*,'thmix akm',akm(i),b2(i) + ! print*,'thmix t',tmix(i),p0 + ! print*,'thmix p',pnk(i),rdcp(i) + ! print*,'thmix',thmix(i) + ! c thmix(i) = akm(i)/a2(i) + ! c tmix(i)= thmix(i)*(pnk(i)*p0m1)**rdcp(i) + zdelta = max(0., sign(1.,rtt-tmix(i))) + qsmix(i) = r2es*foeew(tmix(i), zdelta)/(pnk(i)*100.) + qsmix(i) = min(0.5, qsmix(i)) + zcor = 1./(1.-retv*qsmix(i)) + qsmix(i) = qsmix(i)*zcor + END DO + + ! ------------------------------------------------------------------- + ! --- Calculate lifted condensation level of air at parcel origin level + ! --- (Within 0.2% of formula of Bolton, MON. WEA. REV.,1980) + ! ------------------------------------------------------------------- + + a = 1669.0 ! convect3 + b = 122.0 ! convect3 + + + niflag7 = 0 + DO i = 1, len + + IF (iflag(i)/=7) THEN ! modif sb Jun7th 2002 + + rh(i) = qmix(i)/qsmix(i) + chi(i) = tmix(i)/(a-b*rh(i)-tmix(i)) ! convect3 + ! ATTENTION, la LIGNE DESSOUS A ETE RAJOUTEE ARBITRAIREMENT ET + ! MASQUE UN PB POTENTIEL + chi(i) = max(chi(i), 0.) + rh(i) = max(rh(i), 0.) + plcl(i) = pnk(i)*(rh(i)**chi(i)) + IF (((plcl(i)<200.0) .OR. (plcl(i)>=2000.0)) .AND. (iflag(i)==0)) & + iflag(i) = 8 + + ELSE + + niflag7 = niflag7 + 1 + plcl(i) = plim2p(i) + + END IF ! iflag=7 + + ! print*,'NIFLAG7 =',niflag7 + + END DO + +!! print *,' cv3_vertmix->' !jyg + + + RETURN +END SUBROUTINE cv3_enthalpmix + +END MODULE cv3_enthalpmix_mod Index: LMDZ6/trunk/libf/phylmd/cv3_estatmix.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cv3_estatmix.f90 (revision 6047) +++ (revision ) @@ -1,205 +1,0 @@ -MODULE cv3_estatmix_mod - PRIVATE - - PUBLIC cv3_estatmix - -CONTAINS - -SUBROUTINE cv3_estatmix(len, nd, iflag, plim1, plim2, p, ph, & - t, q, u, v, h, gz, w, & - wi, nk, tmix, thmix, qmix, qsmix, umix, vmix, plcl) - ! ************************************************************** - ! * - ! CV3_ESTATMIX Determine the properties of an adiabatic updraft * - ! made of air coming from several layers by * - ! mixing static energy * - ! * - ! written by : Grandpeix Jean-Yves, 28/12/2001, 13.14.24 * - ! modified by : Filiberti M-A 06/2005 vectorisation * - ! **************************************************************** - - USE lmdz_cv_ini, ONLY : cpd,cpv,rrd,rrv - USE yomcst_mod_h - USE yoethf_mod_h -IMPLICIT NONE - ! ============================================================== - - ! estatmix : determines theta, t, q, qs, u and v of the lifted mixture - ! made of air between plim1 and plim2 with weighting w. - ! If plim1 and plim2 fall within the same model layer, then theta, ... v - ! are those of that layer. - ! A minimum value (dpmin) is imposed upon plim1-plim2 - - ! =============================================================== - - include "FCTTRE.h" -!inputs: - INTEGER, INTENT (IN) :: nd, len - INTEGER, DIMENSION (len), INTENT (IN) :: nk - REAL, DIMENSION (len), INTENT (IN) :: plim1, plim2 - REAL, DIMENSION (len,nd), INTENT (IN) :: t, q - REAL, DIMENSION (len,nd), INTENT (IN) :: u, v - REAL, DIMENSION (len,nd), INTENT (IN) :: h ! static energy of the layers - REAL, DIMENSION (len,nd), INTENT (IN) :: gz - REAL, DIMENSION (nd), INTENT (IN) :: w - REAL, DIMENSION (len,nd), INTENT (IN) :: p - REAL, DIMENSION (len,nd+1), INTENT (IN) :: ph -!input/output: - INTEGER, DIMENSION (len), INTENT (INOUT) :: iflag -!outputs: - REAL, DIMENSION (len), INTENT (OUT) :: tmix, thmix, qmix - REAL, DIMENSION (len), INTENT (OUT) :: umix, vmix - REAL, DIMENSION (len), INTENT (OUT) :: qsmix - REAL, DIMENSION (len), INTENT (OUT) :: plcl - REAL, DIMENSION (len,nd), INTENT (OUT) :: wi -!internal variables : - INTEGER i, j - INTEGER niflag7 - INTEGER, DIMENSION(len) :: j1, j2 - REAL :: a, b - REAL :: cpn - REAL :: x, y, p0, zdelta, zcor - REAL, PARAMETER :: dpmin=1. - REAL, DIMENSION(len) :: plim2p ! = min(plim2(:),plim1(:)-dpmin) - REAL, DIMENSION(len) :: dpw, coef - REAL, DIMENSION(len) :: hmix ! static energy of the updraft - REAL, DIMENSION(len) :: rdcp, pnk - REAL, DIMENSION(len) :: rh, chi - REAL, DIMENSION(len) :: eqwght - REAL, DIMENSION(len,nd) :: p1, p2 - - -!! print *,' ->cv3_vertmix, plim1,plim2 ', plim1,plim2 !jyg - plim2p(:) = min(plim2(:),plim1(:)-dpmin) - j1(:)=nd - j2(:) = 0 - DO j = 1, nd - DO i = 1, len - IF (plim1(i)<=ph(i,j)) j1(i) = j -!!! IF (plim2p(i)>=ph(i,j+1) .AND. plim2p(i)=j1(i) .AND. j<=j2(i)) THEN - p1(i, j) = min(ph(i,j), plim1(i)) - p2(i, j) = max(ph(i,j+1), plim2p(i)) - ! CRtest:couplage thermiques: deja normalise - ! wi(i,j) = w(j) - ! print*,'wi',wi(i,j) - wi(i, j) = w(j)*(p1(i,j)-p2(i,j))*coef(i)+eqwght(i) - dpw(i) = dpw(i) + wi(i, j) - -!! print *,'cv3_vertmix, j, wi(1,j),dpw ', j, wi(1,j),dpw !jyg - - END IF - END DO - END DO - - ! CR:print - ! do i=1,len - ! print*,'plim',plim1(i),plim2p(i) - ! enddo - DO j = 1, nd - DO i = 1, len - IF (j>=j1(i) .AND. j<=j2(i)) THEN - wi(i, j) = wi(i, j)/dpw(i) - hmix(i) = hmix(i) + h(i, j)*wi(i, j) - qmix(i) = qmix(i) + q(i, j)*wi(i, j) - umix(i) = umix(i) + u(i, j)*wi(i, j) - vmix(i) = vmix(i) + v(i, j)*wi(i, j) - END IF - END DO - END DO - - DO i = 1, len - rdcp(i) = (rrd*(1.-qmix(i))+qmix(i)*rrv)/(cpd*(1.-qmix(i))+qmix(i)*cpv) - END DO - - -!! print *,'cv3_vertmix, rdcp ', rdcp !jyg - - DO i = 1, len - tmix(i) = (hmix(i) - gz(i,1))/(cpd*(1.-qmix(i)) + qmix(i)*cpv) - ! (Use of Cpv since we are dealing with dry static energy) - thmix(i) = tmix(i)*(p0/pnk(i))**rdcp(i) - ! print*,'tmix thmix hmix ',tmix(i),thmix(i),hmix(i) - zdelta = max(0., sign(1.,rtt-tmix(i))) - qsmix(i) = r2es*foeew(tmix(i), zdelta)/(pnk(i)*100.) - qsmix(i) = min(0.5, qsmix(i)) - zcor = 1./(1.-retv*qsmix(i)) - qsmix(i) = qsmix(i)*zcor - END DO - - ! ------------------------------------------------------------------- - ! --- Calculate lifted condensation level of air at parcel origin level - ! --- (Within 0.2% of formula of Bolton, MON. WEA. REV.,1980) - ! ------------------------------------------------------------------- - - a = 1669.0 ! convect3 - b = 122.0 ! convect3 - - - niflag7 = 0 - DO i = 1, len - - IF (iflag(i)/=7) THEN ! modif sb Jun7th 2002 - - rh(i) = qmix(i)/qsmix(i) - chi(i) = tmix(i)/(a-b*rh(i)-tmix(i)) ! convect3 - ! ATTENTION, la LIGNE DESSOUS A ETE RAJOUTEE ARBITRAIREMENT ET - ! MASQUE UN PB POTENTIEL - chi(i) = max(chi(i), 0.) - rh(i) = max(rh(i), 0.) - plcl(i) = pnk(i)*(rh(i)**chi(i)) - IF (((plcl(i)<200.0) .OR. (plcl(i)>=2000.0)) .AND. (iflag(i)==0)) & - iflag(i) = 8 - - ELSE - - niflag7 = niflag7 + 1 - plcl(i) = plim2p(i) - - END IF ! iflag=7 - - ! print*,'NIFLAG7 =',niflag7 - - END DO - -!! print *,' cv3_vertmix->' !jyg - - - RETURN -END SUBROUTINE cv3_estatmix - -END MODULE cv3_estatmix_mod Index: LMDZ6/trunk/libf/phylmd/cv3_estatmix_mod.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cv3_estatmix_mod.f90 (revision 6048) +++ LMDZ6/trunk/libf/phylmd/cv3_estatmix_mod.f90 (revision 6048) @@ -0,0 +1,205 @@ +MODULE cv3_estatmix_mod + PRIVATE + + PUBLIC cv3_estatmix + +CONTAINS + +SUBROUTINE cv3_estatmix(len, nd, iflag, plim1, plim2, p, ph, & + t, q, u, v, h, gz, w, & + wi, nk, tmix, thmix, qmix, qsmix, umix, vmix, plcl) + ! ************************************************************** + ! * + ! CV3_ESTATMIX Determine the properties of an adiabatic updraft * + ! made of air coming from several layers by * + ! mixing static energy * + ! * + ! written by : Grandpeix Jean-Yves, 28/12/2001, 13.14.24 * + ! modified by : Filiberti M-A 06/2005 vectorisation * + ! **************************************************************** + + USE lmdz_cv_ini, ONLY : cpd,cpv,rrd,rrv + USE yomcst_mod_h + USE yoethf_mod_h +IMPLICIT NONE + ! ============================================================== + + ! estatmix : determines theta, t, q, qs, u and v of the lifted mixture + ! made of air between plim1 and plim2 with weighting w. + ! If plim1 and plim2 fall within the same model layer, then theta, ... v + ! are those of that layer. + ! A minimum value (dpmin) is imposed upon plim1-plim2 + + ! =============================================================== + + include "FCTTRE.h" +!inputs: + INTEGER, INTENT (IN) :: nd, len + INTEGER, DIMENSION (len), INTENT (IN) :: nk + REAL, DIMENSION (len), INTENT (IN) :: plim1, plim2 + REAL, DIMENSION (len,nd), INTENT (IN) :: t, q + REAL, DIMENSION (len,nd), INTENT (IN) :: u, v + REAL, DIMENSION (len,nd), INTENT (IN) :: h ! static energy of the layers + REAL, DIMENSION (len,nd), INTENT (IN) :: gz + REAL, DIMENSION (nd), INTENT (IN) :: w + REAL, DIMENSION (len,nd), INTENT (IN) :: p + REAL, DIMENSION (len,nd+1), INTENT (IN) :: ph +!input/output: + INTEGER, DIMENSION (len), INTENT (INOUT) :: iflag +!outputs: + REAL, DIMENSION (len), INTENT (OUT) :: tmix, thmix, qmix + REAL, DIMENSION (len), INTENT (OUT) :: umix, vmix + REAL, DIMENSION (len), INTENT (OUT) :: qsmix + REAL, DIMENSION (len), INTENT (OUT) :: plcl + REAL, DIMENSION (len,nd), INTENT (OUT) :: wi +!internal variables : + INTEGER i, j + INTEGER niflag7 + INTEGER, DIMENSION(len) :: j1, j2 + REAL :: a, b + REAL :: cpn + REAL :: x, y, p0, zdelta, zcor + REAL, PARAMETER :: dpmin=1. + REAL, DIMENSION(len) :: plim2p ! = min(plim2(:),plim1(:)-dpmin) + REAL, DIMENSION(len) :: dpw, coef + REAL, DIMENSION(len) :: hmix ! static energy of the updraft + REAL, DIMENSION(len) :: rdcp, pnk + REAL, DIMENSION(len) :: rh, chi + REAL, DIMENSION(len) :: eqwght + REAL, DIMENSION(len,nd) :: p1, p2 + + +!! print *,' ->cv3_vertmix, plim1,plim2 ', plim1,plim2 !jyg + plim2p(:) = min(plim2(:),plim1(:)-dpmin) + j1(:)=nd + j2(:) = 0 + DO j = 1, nd + DO i = 1, len + IF (plim1(i)<=ph(i,j)) j1(i) = j +!!! IF (plim2p(i)>=ph(i,j+1) .AND. plim2p(i)=j1(i) .AND. j<=j2(i)) THEN + p1(i, j) = min(ph(i,j), plim1(i)) + p2(i, j) = max(ph(i,j+1), plim2p(i)) + ! CRtest:couplage thermiques: deja normalise + ! wi(i,j) = w(j) + ! print*,'wi',wi(i,j) + wi(i, j) = w(j)*(p1(i,j)-p2(i,j))*coef(i)+eqwght(i) + dpw(i) = dpw(i) + wi(i, j) + +!! print *,'cv3_vertmix, j, wi(1,j),dpw ', j, wi(1,j),dpw !jyg + + END IF + END DO + END DO + + ! CR:print + ! do i=1,len + ! print*,'plim',plim1(i),plim2p(i) + ! enddo + DO j = 1, nd + DO i = 1, len + IF (j>=j1(i) .AND. j<=j2(i)) THEN + wi(i, j) = wi(i, j)/dpw(i) + hmix(i) = hmix(i) + h(i, j)*wi(i, j) + qmix(i) = qmix(i) + q(i, j)*wi(i, j) + umix(i) = umix(i) + u(i, j)*wi(i, j) + vmix(i) = vmix(i) + v(i, j)*wi(i, j) + END IF + END DO + END DO + + DO i = 1, len + rdcp(i) = (rrd*(1.-qmix(i))+qmix(i)*rrv)/(cpd*(1.-qmix(i))+qmix(i)*cpv) + END DO + + +!! print *,'cv3_vertmix, rdcp ', rdcp !jyg + + DO i = 1, len + tmix(i) = (hmix(i) - gz(i,1))/(cpd*(1.-qmix(i)) + qmix(i)*cpv) + ! (Use of Cpv since we are dealing with dry static energy) + thmix(i) = tmix(i)*(p0/pnk(i))**rdcp(i) + ! print*,'tmix thmix hmix ',tmix(i),thmix(i),hmix(i) + zdelta = max(0., sign(1.,rtt-tmix(i))) + qsmix(i) = r2es*foeew(tmix(i), zdelta)/(pnk(i)*100.) + qsmix(i) = min(0.5, qsmix(i)) + zcor = 1./(1.-retv*qsmix(i)) + qsmix(i) = qsmix(i)*zcor + END DO + + ! ------------------------------------------------------------------- + ! --- Calculate lifted condensation level of air at parcel origin level + ! --- (Within 0.2% of formula of Bolton, MON. WEA. REV.,1980) + ! ------------------------------------------------------------------- + + a = 1669.0 ! convect3 + b = 122.0 ! convect3 + + + niflag7 = 0 + DO i = 1, len + + IF (iflag(i)/=7) THEN ! modif sb Jun7th 2002 + + rh(i) = qmix(i)/qsmix(i) + chi(i) = tmix(i)/(a-b*rh(i)-tmix(i)) ! convect3 + ! ATTENTION, la LIGNE DESSOUS A ETE RAJOUTEE ARBITRAIREMENT ET + ! MASQUE UN PB POTENTIEL + chi(i) = max(chi(i), 0.) + rh(i) = max(rh(i), 0.) + plcl(i) = pnk(i)*(rh(i)**chi(i)) + IF (((plcl(i)<200.0) .OR. (plcl(i)>=2000.0)) .AND. (iflag(i)==0)) & + iflag(i) = 8 + + ELSE + + niflag7 = niflag7 + 1 + plcl(i) = plim2p(i) + + END IF ! iflag=7 + + ! print*,'NIFLAG7 =',niflag7 + + END DO + +!! print *,' cv3_vertmix->' !jyg + + + RETURN +END SUBROUTINE cv3_estatmix + +END MODULE cv3_estatmix_mod Index: LMDZ6/trunk/libf/phylmd/cv3_mixscale.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cv3_mixscale.f90 (revision 6047) +++ (revision ) @@ -1,43 +1,0 @@ -MODULE cv3_mixscale_mod - PRIVATE - - PUBLIC cv3_mixscale - -CONTAINS - -SUBROUTINE cv3_mixscale(nloc, ncum, na, ment, m) - ! ************************************************************** - ! * - ! CV3_MIXSCALE * - ! * - ! * - ! written by : Jean-Yves Grandpeix, 30/05/2003, 16.34.37 * - ! modified by : * - ! ************************************************************** - - USE lmdz_cv_ini, ONLY : nl - IMPLICIT NONE - - -!inputs: - INTEGER, INTENT (IN) :: ncum, na, nloc - REAL, DIMENSION (nloc, na), INTENT (IN) :: m -!input/outputs: - REAL, DIMENSION (nloc, na, na), INTENT (INOUT) :: ment - -!local variables: - INTEGER i, j, il - - DO j = 1, nl - DO i = 1, nl - DO il = 1, ncum - ment(il, i, j) = m(il, i)*ment(il, i, j) - END DO - END DO - END DO - - - RETURN -END SUBROUTINE cv3_mixscale - -END MODULE cv3_mixscale_mod Index: LMDZ6/trunk/libf/phylmd/cv3_mixscale_mod.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cv3_mixscale_mod.f90 (revision 6048) +++ LMDZ6/trunk/libf/phylmd/cv3_mixscale_mod.f90 (revision 6048) @@ -0,0 +1,43 @@ +MODULE cv3_mixscale_mod + PRIVATE + + PUBLIC cv3_mixscale + +CONTAINS + +SUBROUTINE cv3_mixscale(nloc, ncum, na, ment, m) + ! ************************************************************** + ! * + ! CV3_MIXSCALE * + ! * + ! * + ! written by : Jean-Yves Grandpeix, 30/05/2003, 16.34.37 * + ! modified by : * + ! ************************************************************** + + USE lmdz_cv_ini, ONLY : nl + IMPLICIT NONE + + +!inputs: + INTEGER, INTENT (IN) :: ncum, na, nloc + REAL, DIMENSION (nloc, na), INTENT (IN) :: m +!input/outputs: + REAL, DIMENSION (nloc, na, na), INTENT (INOUT) :: ment + +!local variables: + INTEGER i, j, il + + DO j = 1, nl + DO i = 1, nl + DO il = 1, ncum + ment(il, i, j) = m(il, i)*ment(il, i, j) + END DO + END DO + END DO + + + RETURN +END SUBROUTINE cv3_mixscale + +END MODULE cv3_mixscale_mod Index: LMDZ6/trunk/libf/phylmd/cv3_routines.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cv3_routines.f90 (revision 6047) +++ (revision ) @@ -1,5145 +1,0 @@ - -! $Id$ -MODULE cv3_routines_mod - PRIVATE -! for cv3_feed - LOGICAL, SAVE :: cv3_feed_first =.TRUE. - LOGICAL, SAVE :: ok_new_feed -!$OMP THREADPRIVATE (cv3_feed_first,ok_new_feed) - PUBLIC cv3_param, cv3_incrcount, cv3_prelim, cv3_feed, cv3_undilute1, cv3_trigger, cv3_compress, & - icefrac, cv3_undilute2, cv3_closure, cv3_mixing, cv3_unsat, cv3_yield, cv3_tracer, cv3_uncompress,& - cv3_epmax_fn_cape, cv3_routine_pre -CONTAINS - -SUBROUTINE cv3_routine_pre(ok_conserv_q) - LOGICAL, INTENT (IN) :: ok_conserv_q - - CALL cv3_feed_pre(ok_conserv_q) - -END SUBROUTINE cv3_routine_pre - -SUBROUTINE cv3_param(nd, k_upper, delt) - - USE cvflag_mod_h - USE ioipsl_getin_p_mod, ONLY : getin_p - use mod_phys_lmdz_para - USE conema3_mod_h - USE lmdz_cv_ini, ONLY : alpha,alpha1,beta,betad,coef_peel,cv_flag_feed,delta,dpbase,dtcrit,dtovsh,dttrig,ejectice,ejectliq,elcrit,flag_epkeorig,flag_wb,minorig,nl,nlm,nlp,noconv_stop,noff,omtrain,pbcrit,ptcrit,sigdz,spfac,t_top_max,tau,tau_stop,tlcrit,wbmax - USE lmdz_cv_ini, ONLY : keep_bug_indices_cv3_tracer,restore_bug_cvdn - - - IMPLICIT NONE - -!------------------------------------------------------------ -!Set parameters for convectL for iflag_con = 3 -!------------------------------------------------------------ - - -!*** PBCRIT IS THE CRITICAL CLOUD DEPTH (MB) BENEATH WHICH THE *** -!*** PRECIPITATION EFFICIENCY IS ASSUMED TO BE ZERO *** -!*** PTCRIT IS THE CLOUD DEPTH (MB) ABOVE WHICH THE PRECIP. *** -!*** EFFICIENCY IS ASSUMED TO BE UNITY *** -!*** SIGD IS THE FRACTIONAL AREA COVERED BY UNSATURATED DNDRAFT *** -!*** SPFAC IS THE FRACTION OF PRECIPITATION FALLING OUTSIDE *** -!*** OF CLOUD *** - -![TAU: CHARACTERISTIC TIMESCALE USED TO COMPUTE ALPHA & BETA] -!*** ALPHA AND BETA ARE PARAMETERS THAT CONTROL THE RATE OF *** -!*** APPROACH TO QUASI-EQUILIBRIUM *** -!*** (THEIR STANDARD VALUES ARE 1.0 AND 0.96, RESPECTIVELY) *** -!*** (BETA MUST BE LESS THAN OR EQUAL TO 1) *** - -!*** DTCRIT IS THE CRITICAL BUOYANCY (K) USED TO ADJUST THE *** -!*** APPROACH TO QUASI-EQUILIBRIUM *** -!*** IT MUST BE LESS THAN 0 *** - - INTEGER, INTENT(IN) :: nd - INTEGER, INTENT(IN) :: k_upper - REAL, INTENT(IN) :: delt ! timestep (seconds) - -! Local variables - CHARACTER (LEN=20),PARAMETER :: modname = 'cv3_param' - CHARACTER (LEN=80) :: abort_message - - LOGICAL, SAVE :: first = .TRUE. -!$OMP THREADPRIVATE(first) - -!glb noff: integer limit for convection (nd-noff) -! minorig: First level of convection - -! -- limit levels for convection: - -!jyg< -! noff is chosen such that nl = k_upper so that upmost loops end at about 22 km -! - noff = min(max(nd-k_upper, 1), (nd+1)/2) -!! noff = 1 -!>jyg - minorig = 1 - nl = nd - noff - nlp = nl + 1 - nlm = nl - 1 - - IF (first) THEN -! -- "microphysical" parameters: -! IM beg: ajout fis. reglage ep -! CR+JYG: shedding coefficient (used when iflag_mix_adiab=1) -! IM lu dans physiq.def via conf_phys.F90 epmax = 0.993 - - omtrain = 45.0 ! used also for snow (no disctinction rain/snow) -! -- misc: - dtovsh = -0.2 ! dT for overshoot -! cc dttrig = 5. ! (loose) condition for triggering - dttrig = 10. ! (loose) condition for triggering - dtcrit = -2.0 -! -- end of convection -! -- interface cloud parameterization: - delta = 0.01 ! cld -! -- interface with boundary-layer (gust factor): (sb) - betad = 10.0 ! original value (from convect 4.3) - -! Var interm pour le getin - cv_flag_feed=1 - CALL getin_p('cv_flag_feed',cv_flag_feed) - T_top_max = 1000. - CALL getin_p('t_top_max',T_top_max) - dpbase=-40. - CALL getin_p('dpbase',dpbase) - pbcrit=150.0 - CALL getin_p('pbcrit',pbcrit) - ptcrit=500.0 - CALL getin_p('ptcrit',ptcrit) - sigdz=0.01 - CALL getin_p('sigdz',sigdz) - spfac=0.15 - CALL getin_p('spfac',spfac) - tau=8000. - CALL getin_p('tau',tau) - flag_wb=1 - CALL getin_p('flag_wb',flag_wb) - wbmax=6. - CALL getin_p('wbmax',wbmax) - ok_convstop=.False. - CALL getin_p('ok_convstop',ok_convstop) - tau_stop=15000. - CALL getin_p('tau_stop',tau_stop) - ok_intermittent=.False. - CALL getin_p('ok_intermittent',ok_intermittent) - ok_optim_yield=.False. - CALL getin_p('ok_optim_yield',ok_optim_yield) - ok_homo_tend=.TRUE. - CALL getin_p('ok_homo_tend',ok_homo_tend) - ok_entrain=.TRUE. - CALL getin_p('ok_entrain',ok_entrain) - - coef_peel=0.25 - CALL getin_p('coef_peel',coef_peel) - - flag_epKEorig=1 - CALL getin_p('flag_epKEorig',flag_epKEorig) - elcrit=0.0003 - CALL getin_p('elcrit',elcrit) - tlcrit=-55.0 - CALL getin_p('tlcrit',tlcrit) - ejectliq=0. - CALL getin_p('ejectliq',ejectliq) - ejectice=0. - CALL getin_p('ejectice',ejectice) - cvflag_prec_eject = .FALSE. - CALL getin_p('cvflag_prec_eject',cvflag_prec_eject) - qsat_depends_on_qt = .FALSE. - CALL getin_p('qsat_depends_on_qt',qsat_depends_on_qt) - adiab_ascent_mass_flux_depends_on_ejectliq = .FALSE. - CALL getin_p('adiab_ascent_mass_flux_depends_on_ejectliq',adiab_ascent_mass_flux_depends_on_ejectliq) - keepbug_ice_frac = .TRUE. - CALL getin_p('keepbug_ice_frac', keepbug_ice_frac) - keep_bug_indices_cv3_tracer = .FALSE. - CALL getin_p('keep_bug_indices_cv3_tracer', keep_bug_indices_cv3_tracer) - restore_bug_cvdn=.false. - CALL getin_p('restore_bug_cvdn',restore_bug_cvdn) - - - WRITE (*, *) 't_top_max=', t_top_max - WRITE (*, *) 'dpbase=', dpbase - WRITE (*, *) 'pbcrit=', pbcrit - WRITE (*, *) 'ptcrit=', ptcrit - WRITE (*, *) 'sigdz=', sigdz - WRITE (*, *) 'spfac=', spfac - WRITE (*, *) 'tau=', tau - WRITE (*, *) 'flag_wb=', flag_wb - WRITE (*, *) 'wbmax=', wbmax - WRITE (*, *) 'ok_convstop=', ok_convstop - WRITE (*, *) 'tau_stop=', tau_stop - WRITE (*, *) 'ok_intermittent=', ok_intermittent - WRITE (*, *) 'ok_optim_yield =', ok_optim_yield - WRITE (*, *) 'coef_peel=', coef_peel - - WRITE (*, *) 'flag_epKEorig=', flag_epKEorig - WRITE (*, *) 'elcrit=', elcrit - WRITE (*, *) 'tlcrit=', tlcrit - WRITE (*, *) 'ejectliq=', ejectliq - WRITE (*, *) 'ejectice=', ejectice - WRITE (*, *) 'cvflag_prec_eject =', cvflag_prec_eject - WRITE (*, *) 'qsat_depends_on_qt =', qsat_depends_on_qt - WRITE (*, *) 'adiab_ascent_mass_flux_depends_on_ejectliq =', adiab_ascent_mass_flux_depends_on_ejectliq - WRITE (*, *) 'keepbug_ice_frac =', keepbug_ice_frac - WRITE (*, *) 'keep_bug_indices_cv3_tracer =', keep_bug_indices_cv3_tracer - WRITE (*, *) 'restore_bug_cvdn=',restore_bug_cvdn - - first = .FALSE. - END IF ! (first) - - beta = 1.0 - delt/tau - alpha1 = 1.5E-3 -!JYG Correction bug alpha - alpha1 = alpha1*1.5 - alpha = alpha1*delt/tau -!JYG Bug -! cc increase alpha to compensate W decrease: -! c alpha = alpha*1.5 - - noconv_stop = max(2.,tau_stop/delt) - - RETURN -END SUBROUTINE cv3_param - -SUBROUTINE cv3_incrcount(len, nd, delt, sig) - - USE lmdz_cv_ini, ONLY : noconv_stop - USE cvflag_mod_h - IMPLICIT NONE - -! ===================================================================== -! Increment the counter sig(nd) -! ===================================================================== - -!inputs: - INTEGER, INTENT(IN) :: len - INTEGER, INTENT(IN) :: nd - REAL, INTENT(IN) :: delt ! timestep (seconds) - -!input/output - REAL, DIMENSION(len,nd), INTENT(INOUT) :: sig - -!local variables - INTEGER il - -! print *,'cv3_incrcount : noconv_stop ',noconv_stop -! print *,'cv3_incrcount in, sig(1,nd) ',sig(1,nd) - IF(ok_convstop) THEN - DO il = 1, len - sig(il, nd) = sig(il, nd) + 1. - sig(il, nd) = min(sig(il,nd), noconv_stop+0.1) - END DO - ELSE - DO il = 1, len - sig(il, nd) = sig(il, nd) + 1. - sig(il, nd) = min(sig(il,nd), 12.1) - END DO - ENDIF ! (ok_convstop) -! print *,'cv3_incrcount out, sig(1,nd) ',sig(1,nd) - - RETURN -END SUBROUTINE cv3_incrcount - -SUBROUTINE cv3_prelim(len, nd, ndp1, t, q, p, ph, & - lv, lf, cpn, tv, gz, h, hm, th) - USE lmdz_cv_ini, ONLY : cl,clmci,clmcpv,cpd,cpv,eps,lf0,lv0,nl,nlp,rrd,rrv - IMPLICIT NONE - -! ===================================================================== -! --- CALCULATE ARRAYS OF GEOPOTENTIAL, HEAT CAPACITY & STATIC ENERGY -! "ori": from convect4.3 (vectorized) -! "convect3": to be exactly consistent with convect3 -! ===================================================================== - -! inputs: - INTEGER len, nd, ndp1 - REAL t(len, nd), q(len, nd), p(len, nd), ph(len, ndp1) - -! outputs: - REAL lv(len, nd), lf(len, nd), cpn(len, nd), tv(len, nd) - REAL gz(len, nd), h(len, nd), hm(len, nd) - REAL th(len, nd) - -! local variables: - INTEGER k, i - REAL rdcp - REAL tvx, tvy ! convect3 - REAL cpx(len, nd) -! ori do 110 k=1,nlp -! abderr do 110 k=1,nl ! convect3 - DO k = 1, nlp - - DO i = 1, len -! debug lv(i,k)= lv0-clmcpv*(t(i,k)-t0) - lv(i, k) = lv0 - clmcpv*(t(i,k)-273.15) -!! lf(i, k) = lf0 - clmci*(t(i,k)-273.15) ! erreur de signe !! - lf(i, k) = lf0 + clmci*(t(i,k)-273.15) - cpn(i, k) = cpd*(1.0-q(i,k)) + cpv*q(i, k) - cpx(i, k) = cpd*(1.0-q(i,k)) + cl*q(i, k) -! 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 - END DO - END DO - -! gz = phi at the full levels (same as p). - -!! DO i = 1, len !jyg -!! gz(i, 1) = 0.0 !jyg -!! END DO !jyg - gz(:,:) = 0. !jyg: initialization of the whole array -! ori do 140 k=2,nlp - DO k = 2, nl ! convect3 - DO 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 print *,' gz(',k,')',gz(i,k),' tvx',tvx,' tvy ',tvy - -! ori gz(i,k)=gz(i,k-1)+hrd*(tv(i,k-1)+tv(i,k)) -! ori & *(p(i,k-1)-p(i,k))/ph(i,k) - END DO - END DO - -! h = phi + cpT (dry static energy). -! hm = phi + cp(T-Tbase)+Lq - -! ori do 170 k=1,nlp - DO k = 1, nl ! convect3 - DO 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) - END DO - END DO - - RETURN -END SUBROUTINE cv3_prelim - - -SUBROUTINE cv3_feed_pre(ok_conserv_q) -USE mod_phys_lmdz_transfert_para, ONLY : bcast -IMPLICIT NONE - LOGICAL, INTENT (IN) :: ok_conserv_q - INTEGER :: iostat - - IF (cv3_feed_first) THEN - -!$OMP MASTER - ok_new_feed = ok_conserv_q - OPEN (98, FILE='cv3feed_param.data', STATUS='old', FORM='formatted', IOSTAT=iostat) - IF (iostat==0) THEN - READ (98, *, END=998) ok_new_feed -998 CONTINUE - CLOSE (98) - END IF - PRINT *, ' ok_new_feed: ', ok_new_feed -!$OMP END MASTER - call bcast(ok_new_feed) - cv3_feed_first = .FALSE. - END IF - -END SUBROUTINE cv3_feed_pre - - -SUBROUTINE cv3_feed(len, nd, ok_conserv_q, & - t, q, u, v, p, ph, h, gz, & - p1feed, p2feed, wght, & - wghti, tnk, thnk, qnk, qsnk, unk, vnk, & - cpnk, hnk, nk, icb, icbmax, iflag, gznk, plcl) - - USE add_phys_tend_mod, ONLY: fl_cor_ebil - USE print_control_mod, ONLY: prt_level - USE lmdz_cv_ini, ONLY : cpd,cpv,cv_flag_feed,minorig,nl,nlm,cl - USE cv3_estatmix_mod, ONLY : cv3_estatmix - USE cv3_enthalpmix_mod, ONLY : cv3_enthalpmix - IMPLICIT NONE - -! ================================================================ -! Purpose: CONVECTIVE FEED - -! Main differences with cv_feed: -! - ph added in input -! - here, nk(i)=minorig -! - icb defined differently (plcl compared with ph instead of p) -! - dry static energy as argument instead of moist static energy - -! Main differences with convect3: -! - we do not compute dplcldt and dplcldr of CLIFT anymore -! - values iflag different (but tests identical) -! - A,B explicitely defined (!...) -! ================================================================ - -!inputs: - INTEGER, INTENT (IN) :: len, nd - LOGICAL, INTENT (IN) :: ok_conserv_q - REAL, DIMENSION (len, nd), INTENT (IN) :: t, q, p - REAL, DIMENSION (len, nd), INTENT (IN) :: u, v - REAL, DIMENSION (len, nd), INTENT (IN) :: h, gz - REAL, DIMENSION (len, nd+1), INTENT (IN) :: ph - REAL, DIMENSION (len), INTENT (IN) :: p1feed - REAL, DIMENSION (nd), INTENT (IN) :: wght -!input-output - REAL, DIMENSION (len), INTENT (INOUT) :: p2feed -!outputs: - INTEGER, INTENT (OUT) :: icbmax - INTEGER, DIMENSION (len), INTENT (OUT) :: iflag, nk, icb - REAL, DIMENSION (len, nd), INTENT (OUT) :: wghti - REAL, DIMENSION (len), INTENT (OUT) :: tnk, thnk, qnk, qsnk - REAL, DIMENSION (len), INTENT (OUT) :: unk, vnk - REAL, DIMENSION (len), INTENT (OUT) :: cpnk, hnk, gznk - REAL, DIMENSION (len), INTENT (OUT) :: plcl - -!local variables: - INTEGER i, k, iter, niter - INTEGER ihmin(len) - REAL work(len) - REAL pup(len), plo(len), pfeed(len) - REAL plclup(len), plcllo(len), plclfeed(len) - REAL pfeedmin(len) - REAL posit(len) - LOGICAL nocond(len) - -!jyg20140217< - REAL, PARAMETER :: dp_lcl_feed = 2. - -!jyg> -! ------------------------------------------------------------------- -! --- Origin level of ascending parcels for convect3: -! ------------------------------------------------------------------- - - DO i = 1, len - nk(i) = minorig - gznk(i) = gz(i, nk(i)) - END DO - -! ------------------------------------------------------------------- -! --- Adjust feeding layer thickness so that lifting up to the top of -! --- the feeding layer does not induce condensation (i.e. so that -! --- plcl < p2feed). -! --- Method : iterative secant method. -! ------------------------------------------------------------------- - -! 1- First bracketing of the solution : ph(nk+1), p2feed - -! 1.a- LCL associated with p2feed - DO i = 1, len - pup(i) = p2feed(i) - END DO - IF (fl_cor_ebil >=2 ) THEN - CALL cv3_estatmix(len, nd, iflag, p1feed, pup, p, ph, & - t, q, u, v, h, gz, wght, & - wghti, nk, tnk, thnk, qnk, qsnk, unk, vnk, plclup) - ELSE - CALL cv3_enthalpmix(len, nd, iflag, p1feed, pup, p, ph, & - t, q, u, v, wght, & - wghti, nk, tnk, thnk, qnk, qsnk, unk, vnk, plclup) - ENDIF ! (fl_cor_ebil >=2 ) -! 1.b- LCL associated with ph(nk+1) - DO i = 1, len - plo(i) = ph(i, nk(i)+1) - END DO - IF (fl_cor_ebil >=2 ) THEN - CALL cv3_estatmix(len, nd, iflag, p1feed, plo, p, ph, & - t, q, u, v, h, gz, wght, & - wghti, nk, tnk, thnk, qnk, qsnk, unk, vnk, plcllo) - ELSE - CALL cv3_enthalpmix(len, nd, iflag, p1feed, plo, p, ph, & - t, q, u, v, wght, & - wghti, nk, tnk, thnk, qnk, qsnk, unk, vnk, plcllo) - ENDIF ! (fl_cor_ebil >=2 ) -! 2- Iterations - niter = 5 - DO iter = 1, niter - DO i = 1, len - plcllo(i) = min(plo(i), plcllo(i)) - plclup(i) = max(pup(i), plclup(i)) - nocond(i) = plclup(i) <= pup(i) - END DO - DO i = 1, len - IF (nocond(i)) THEN - pfeed(i) = pup(i) - ELSE -!JYG20140217< - IF (ok_new_feed) THEN - pfeed(i) = (pup(i)*(plo(i)-plcllo(i)-dp_lcl_feed)+ & - plo(i)*(plclup(i)-pup(i)+dp_lcl_feed))/ & - (plo(i)-plcllo(i)+plclup(i)-pup(i)) - ELSE - pfeed(i) = (pup(i)*(plo(i)-plcllo(i))+ & - plo(i)*(plclup(i)-pup(i)))/ & - (plo(i)-plcllo(i)+plclup(i)-pup(i)) - END IF -!JYG> - END IF - END DO -!jyg20140217< -! For the last iteration, make sure that the top of the feeding layer -! and LCL are not in the same layer: - IF (ok_new_feed) THEN - IF (iter==niter) THEN - DO i = 1,len !jyg - pfeedmin(i) = ph(i,minorig+1) !jyg - ENDDO !jyg - DO k = minorig+1, nl !jyg -!! DO k = minorig, nl !jyg - DO i = 1, len - IF (ph(i,k)>=plclfeed(i)) pfeedmin(i) = ph(i, k) - END DO - END DO - DO i = 1, len - pfeed(i) = max(pfeedmin(i), pfeed(i)) - END DO - END IF - END IF -!jyg> - - IF (fl_cor_ebil >=2 ) THEN - CALL cv3_estatmix(len, nd, iflag, p1feed, pfeed, p, ph, & - t, q, u, v, h, gz, wght, & - wghti, nk, tnk, thnk, qnk, qsnk, unk, vnk, plclfeed) - ELSE - CALL cv3_enthalpmix(len, nd, iflag, p1feed, pfeed, p, ph, & - t, q, u, v, wght, & - wghti, nk, tnk, thnk, qnk, qsnk, unk, vnk, plclfeed) - ENDIF ! (fl_cor_ebil >=2 ) -!jyg20140217< - IF (ok_new_feed) THEN - DO i = 1, len - posit(i) = (sign(1.,plclfeed(i)-pfeed(i)+dp_lcl_feed)+1.)*0.5 - IF (plclfeed(i)-pfeed(i)+dp_lcl_feed==0.) posit(i) = 1. - END DO - ELSE - DO i = 1, len - posit(i) = (sign(1.,plclfeed(i)-pfeed(i))+1.)*0.5 - IF (plclfeed(i)==pfeed(i)) posit(i) = 1. - END DO - END IF -!jyg> - DO i = 1, len -! - posit = 1 when lcl is below top of feeding layer (plclfeed>pfeed) -! - => pup=pfeed -! - posit = 0 when lcl is above top of feeding layer (plclfeed plo=pfeed - pup(i) = posit(i)*pfeed(i) + (1.-posit(i))*pup(i) - plo(i) = (1.-posit(i))*pfeed(i) + posit(i)*plo(i) - plclup(i) = posit(i)*plclfeed(i) + (1.-posit(i))*plclup(i) - plcllo(i) = (1.-posit(i))*plclfeed(i) + posit(i)*plcllo(i) - END DO - END DO ! iter - - DO i = 1, len - p2feed(i) = pfeed(i) - plcl(i) = plclfeed(i) - END DO - - DO i = 1, len - cpnk(i) = cpd*(1.0-qnk(i)) + cpv*qnk(i) - hnk(i) = gz(i, 1) + cpnk(i)*tnk(i) - END DO - -! ------------------------------------------------------------------- -! --- Check whether parcel level temperature and specific humidity -! --- are reasonable -! ------------------------------------------------------------------- - IF (cv_flag_feed == 1) THEN - DO i = 1, len - IF (((tnk(i)<250.0) .OR. & - (qnk(i)<=0.0)) .AND. & - (iflag(i)==0)) iflag(i) = 7 - END DO - ELSEIF (cv_flag_feed >= 2) THEN -! --- and demand that LCL be high enough - DO i = 1, len - IF (((tnk(i)<250.0) .OR. & - (qnk(i)<=0.0) .OR. & - (plcl(i)>min(0.99*ph(i,1),ph(i,3)))) .AND. & - (iflag(i)==0)) iflag(i) = 7 - END DO - ENDIF - IF (prt_level .GE. 10) THEN - print *,'cv3_feed : iflag(1), pfeed(1), plcl(1), wghti(1,k) ', & - iflag(1), pfeed(1), plcl(1), (wghti(1,k),k=1,10) - ENDIF - -! ------------------------------------------------------------------- -! --- 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 - - DO i = 1, len - icb(i) = nlm - END DO - -! la modification consiste a comparer plcl a ph et non a p: -! icb est defini par : ph(icb)p(icb), then icbs=icb - -! * the routine above computes tvp from minorig to icbs (included). - -! * to compute buoybase (in cv3_trigger.F), both tvp(icb) and tvp(icb+1) -! must be known. This is the case if icbs=icb+1, but not if icbs=icb. - -! * therefore, in the case icbs=icb, we compute tvp at level icb+1 -! (tvp at other levels will be computed in cv3_undilute2.F) - - - 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) - END DO - - DO i = 1, len - tg = ticb(i) - qg = qsicb(i) ! convect3 -! debug alv=lv0-clmcpv*(ticb(i)-t0) - alv = lv0 - clmcpv*(ticb(i)-273.15) - -! First iteration. - -! 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 -! 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) -! ori tg=max(tg,35.0) -! debug tc=tg-t0 - tc = tg - 273.15 - denom = 243.5 + tc - denom = max(denom, 1.0) ! convect3 -! ori if(tc.ge.0.0)then - es = 6.112*exp(17.67*tc/denom) -! ori else -! ori es=exp(23.33086-6111.72784/tg+0.15215*log(tg)) -! ori endif -! ori qg=eps*es/(p(i,icb(i))-es*(1.-eps)) - qg = eps*es/(p(i,icb(i)+1)-es*(1.-eps)) - -! Second iteration. - - -! ori s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i)) -! ori s=1./s -! 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) -! ori tg=max(tg,35.0) -! debug tc=tg-t0 - tc = tg - 273.15 - denom = 243.5 + tc - denom = max(denom, 1.0) ! convect3 -! ori if(tc.ge.0.0)then - es = 6.112*exp(17.67*tc/denom) -! ori else -! ori es=exp(23.33086-6111.72784/tg+0.15215*log(tg)) -! ori end if -! 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) - -! ori c approximation here: -! ori tp(i,icb(i))=(ah0(i)-(cl-cpd)*qnk(i)*ticb(i) -! ori & -gz(i,icb(i))-alv*qg)/cpd - -! convect3: no approximation: - tp(i, icb(i)+1) = (ah0(i)-gz(i,icb(i)+1)-alv*qg)/(cpd+(cl-cpd)*qnk(i)) - -! ori clw(i,icb(i))=qnk(i)-qg -! 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)) -! ori tvp(i,icb(i))=tp(i,icb(i))*(1.+rg*epsi) -! 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 - - END DO - - RETURN -END SUBROUTINE cv3_undilute1 - -SUBROUTINE cv3_trigger(len, nd, icb, plcl, p, th, tv, tvp, thnk, & - pbase, buoybase, iflag, sig, w0) - USE lmdz_cv_ini, ONLY : alpha,beta,dpbase,dtcrit,dttrig,nl - 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=14 -! (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 -! ------------------------------------------------------------------- - -! input: - INTEGER len, nd - INTEGER icb(len) - REAL plcl(len), p(len, nd) - REAL th(len, nd), tv(len, nd), tvp(len, nd) - REAL thnk(len) - -! output: - REAL pbase(len), buoybase(len) - -! input AND output: - INTEGER iflag(len) - REAL sig(len, nd), w0(len, nd) - -! local variables: - INTEGER i, k - REAL tvpbase, tvbase, tdif, ath, ath1 - - -! *** set cloud base buoyancy at (plcl+dpbase) level buoyancy - - DO 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 - END DO - - -! *** make sure that column is dry adiabatic between the surface *** -! *** and cloud base, and that lifted air is positively buoyant *** -! *** at cloud base *** -! *** if not, return to calling program after resetting *** -! *** sig(i) and w0(i) *** - - -! oct3 do 200 i=1,len -! oct3 -! oct3 tdif = buoybase(i) -! oct3 ath1 = th(i,1) -! oct3 ath = th(i,icb(i)-1) - dttrig -! oct3 -! oct3 if (tdif.lt.dtcrit .or. ath.gt.ath1) then -! oct3 do 60 k=1,nl -! oct3 sig(i,k) = beta*sig(i,k) - 2.*alpha*tdif*tdif -! oct3 sig(i,k) = AMAX1(sig(i,k),0.0) -! oct3 w0(i,k) = beta*w0(i,k) -! oct3 60 continue -! oct3 iflag(i)=4 ! pour version vectorisee -! oct3c convect3 iflag(i)=0 -! oct3cccc return -! oct3 endif -! oct3 -! oct3200 continue - -! -- oct3: on reecrit la boucle 200 (pour la vectorisation) - - DO k = 1, nl - DO i = 1, len - - tdif = buoybase(i) - ath1 = thnk(i) - ath = th(i, icb(i)-1) - dttrig - - IF (tdifath1) 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) = 14 ! pour version vectorisee -! convect3 iflag(i)=0 - END IF - - END DO - END DO - -! fin oct3 -- - - RETURN -END SUBROUTINE cv3_trigger - -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, & - iflag, nk, icb, icbs, & - plcl, tnk, qnk, gznk, pbase, buoybase, & - t, q, qs, u, v, gz, th, & - tra, & - h, lv, cpn, p, ph, tv, tp, tvp, clw, & - sig, w0) - USE lmdz_cv_ini, ONLY : nl - USE print_control_mod, ONLY: lunout - IMPLICIT NONE - - -!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) - -!outputs: -! 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) - -!local variables: - INTEGER i, k, nn, j - - CHARACTER (LEN=20) :: modname = 'cv3_compress' - CHARACTER (LEN=80) :: abort_message - - DO k = 1, nl + 1 - nn = 0 - DO i = 1, len - IF (iflag1(i)==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) - END IF - END DO - END DO - -!AC! do 121 j=1,ntra -!AC!ccccc do 111 k=1,nl+1 -!AC! do 111 k=1,nd -!AC! nn=0 -!AC! do 101 i=1,len -!AC! if(iflag1(i).eq.0)then -!AC! nn=nn+1 -!AC! tra(nn,k,j)=tra1(i,k,j) -!AC! endif -!AC! 101 continue -!AC! 111 continue -!AC! 121 continue - - IF (nn/=ncum) THEN - WRITE (lunout, *) 'strange! nn not equal to ncum: ', nn, ncum - abort_message = '' - CALL abort_physic(modname, abort_message, 1) - END IF - - nn = 0 - DO i = 1, len - IF (iflag1(i)==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) - END IF - END DO - - RETURN -END SUBROUTINE cv3_compress - -SUBROUTINE icefrac(t, clw, qi, nl, len) - IMPLICIT NONE - - -!JAM-------------------------------------------------------------------- -! Calcul de la quantit� d'eau sous forme de glace -! -------------------------------------------------------------------- - INTEGER nl, len - REAL qi(len, nl) - REAL t(len, nl), clw(len, nl) - REAL fracg - INTEGER k, i - - DO k = 3, nl - DO i = 1, len - IF (t(i,k)>263.15) THEN - qi(i, k) = 0. - ELSE - IF (t(i,k)<243.15) THEN - qi(i, k) = clw(i, k) - ELSE - fracg = (263.15-t(i,k))/20 - qi(i, k) = clw(i, k)*fracg - END IF - END IF -! print*,t(i,k),qi(i,k),'temp,testglace' - END DO - END DO - - RETURN - -END SUBROUTINE icefrac - -SUBROUTINE cv3_undilute2(nloc, ncum, nd, iflag, icb, icbs, nk, & - tnk, qnk, gznk, hnk, t, q, qs, gz, & - p, ph, h, tv, lv, lf, pbase, buoybase, plcl, & - inb, tp, tvp, clw, hp, ep, sigp, buoy, & - frac_a, frac_s, qpreca, qta) - USE print_control_mod, ONLY: prt_level - USE cvflag_mod_h - USE conema3_mod_h - USE lmdz_cv_ini, ONLY : cl,clmci,clmcpv,cpd,cpv,dtovsh,ejectice,ejectliq,elcrit - USE lmdz_cv_ini, ONLY : eps,flag_epkeorig,lf0,lv0,minorig,nl,nlp,pbcrit,ptcrit,rrd,rrv,spfac,t0,t_top_max,tlcrit - USE yomcst2_mod_h - IMPLICIT NONE - -! --------------------------------------------------------------------- -! Purpose: -! 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 - -! Main differences convect3/convect4: -! - icbs (input) is the first level above LCL (may differ from icb) -! - many minor differences in the iterations -! - condensed water not removed from tvp in convect3 -! - vertical profile of buoyancy computed here (use of buoybase) -! - the determination of inb is different -! - no inb1, only inb in output -! --------------------------------------------------------------------- - -!inputs: - INTEGER, INTENT (IN) :: ncum, nd, nloc - INTEGER, DIMENSION (nloc), INTENT (IN) :: icb, icbs, nk - REAL, DIMENSION (nloc, nd), INTENT (IN) :: t, q, qs, gz - REAL, DIMENSION (nloc, nd), INTENT (IN) :: p - REAL, DIMENSION (nloc, nd+1), INTENT (IN) :: ph - REAL, DIMENSION (nloc), INTENT (IN) :: tnk, qnk, gznk - REAL, DIMENSION (nloc), INTENT (IN) :: hnk - REAL, DIMENSION (nloc, nd), INTENT (IN) :: lv, lf, tv, h - REAL, DIMENSION (nloc), INTENT (IN) :: pbase, buoybase, plcl - -!input/outputs: - REAL, DIMENSION (nloc, nd), INTENT (INOUT) :: tp, tvp, clw ! Input for k = 1, icb+1 (computed in cv3_undilute1) - ! Output above - INTEGER, DIMENSION (nloc), INTENT (INOUT) :: iflag - -!outputs: - INTEGER, DIMENSION (nloc), INTENT (OUT) :: inb - REAL, DIMENSION (nloc, nd), INTENT (OUT) :: ep, sigp, hp - REAL, DIMENSION (nloc, nd), INTENT (OUT) :: buoy - REAL, DIMENSION (nloc, nd), INTENT (OUT) :: frac_a, frac_s - REAL, DIMENSION (nloc, nd), INTENT (OUT) :: qpreca - REAL, DIMENSION (nloc, nd), INTENT (OUT) :: qta - -!local variables: - INTEGER i, j, k - REAL smallestreal - REAL tg, qg, dqgdT, ahg, alv, alf, s, tc, es, esi, denom, rg, tca, elacrit - REAL :: phinu2p - REAL :: qhthreshold - REAL :: als - REAL :: qsat_new, snew - REAL, DIMENSION (nloc,nd) :: qi - REAL, DIMENSION (nloc,nd) :: ha ! moist static energy of adiabatic ascents - ! taking into account precip ejection - REAL, DIMENSION (nloc,nd) :: hla ! liquid water static energy of adiabatic ascents - ! taking into account precip ejection - REAL, DIMENSION (nloc,nd) :: qcld ! specific cloud water - REAL, DIMENSION (nloc,nd) :: qhsat ! specific humidity at saturation - REAL, DIMENSION (nloc,nd) :: dqhsatdT ! dqhsat/dT - REAL, DIMENSION (nloc,nd) :: frac ! ice fraction function of envt temperature - REAL, DIMENSION (nloc,nd) :: qps ! specific solid precipitation - REAL, DIMENSION (nloc,nd) :: qpl ! specific liquid precipitation - REAL, DIMENSION (nloc) :: ah0, cape, capem, byp - LOGICAL, DIMENSION (nloc) :: lcape - INTEGER, DIMENSION (nloc) :: iposit - REAL :: denomm1 - REAL :: by, defrac, pden, tbis - REAL :: fracg - REAL :: deltap - REAL, PARAMETER :: Tx=263.15 - REAL, PARAMETER :: Tm=243.15 - REAL :: aa, bb, dd, ddelta, discr - REAL :: ff, fp - REAL :: coefx, coefm, Zx, Zm, Ux, U, Um - - IF (prt_level >= 10) THEN - print *,'cv3_undilute2.0. icvflag_Tpa, t(1,k), q(1,k), qs(1,k) ', & - icvflag_Tpa, (k, t(1,k), q(1,k), qs(1,k), k = 1,nl) - ENDIF - smallestreal=tiny(smallestreal) - -! ===================================================================== -! --- SOME INITIALIZATIONS -! ===================================================================== - - DO k = 1, nl - DO i = 1, ncum - qi(i, k) = 0. - END DO - END DO - - -! ===================================================================== -! --- FIND THE REST OF THE LIFTED PARCEL TEMPERATURES -! ===================================================================== - -! --- The procedure is to solve the equation. -! cp*tp+L*qp+phi=cp*tnk+L*qnk+gznk. - -! *** Calculate certain parcel quantities, including static energy *** - - - DO i = 1, ncum - ah0(i) = (cpd*(1.-qnk(i))+cl*qnk(i))*tnk(i)+ & -! debug qnk(i)*(lv0-clmcpv*(tnk(i)-t0))+gznk(i) - qnk(i)*(lv0-clmcpv*(tnk(i)-273.15)) + gznk(i) - END DO -! -! Ice fraction -! - IF (cvflag_ice) THEN - DO k = minorig, nl - DO i = 1, ncum - frac(i, k) = (Tx - t(i,k))/(Tx - Tm) - frac(i, k) = min(max(frac(i,k),0.0), 1.0) - END DO - END DO -! Below cloud base, set ice fraction to cloud base value - DO k = 1, nl - DO i = 1, ncum - IF (kjyg -! - -! *** Find lifted parcel quantities above cloud base *** - -!---------------------------------------------------------------------------- -! - IF (icvflag_Tpa == 2) THEN -! -!---------------------------------------------------------------------------- -! - DO k = minorig + 1, nl - DO i = 1,ncum - tp(i,k) = t(i,k) - ENDDO -!! alv = lv0 - clmcpv*(t(i,k)-273.15) -!! alf = lf0 + clmci*(t(i,k)-273.15) -!! als = alf + alv - DO j = 1,4 - DO i = 1, ncum -! ori if(k.ge.(icb(i)+1))then - IF (k>=(icbs(i)+1)) THEN ! convect3 - tg = tp(i, k) - IF (tg .gt. Tx) THEN - es = 6.112*exp(17.67*(tg - 273.15)/(tg + 243.5 - 273.15)) - qg = eps*es/(p(i,k)-es*(1.-eps)) - ELSE - esi = exp(23.33086-(6111.72784/tg)+0.15215*log(tg)) - qg = eps*esi/(p(i,k)-esi*(1.-eps)) - ENDIF -! Ice fraction - ff = 0. - fp = 1./(Tx - Tm) - IF (tg < Tx) THEN - IF (tg > Tm) THEN - ff = (Tx - tg)*fp - ELSE - ff = 1. - ENDIF ! (tg > Tm) - ENDIF ! (tg < Tx) -! Intermediate variables - aa = cpd + (cl-cpd)*qnk(i) + lv(i,k)*lv(i,k)*qg/(rrv*tg*tg) - ahg = (cpd + (cl-cpd)*qnk(i))*tg + lv(i,k)*qg - & - lf(i,k)*ff*(qnk(i) - qg) + gz(i,k) - dd = lf(i,k)*lv(i,k)*qg/(rrv*tg*tg) - ddelta = lf(i,k)*(qnk(i) - qg) - bb = aa + ddelta*fp + dd*fp*(Tx-tg) -! Compute Zx and Zm - coefx = aa - coefm = aa + dd - IF (tg .gt. Tx) THEN - Zx = ahg + coefx*(Tx - tg) - Zm = ahg - ddelta + coefm*(Tm - tg) - ELSE - IF (tg .gt. Tm) THEN - Zx = ahg + (coefx +fp*ddelta)*(Tx - Tg) - Zm = ahg + (coefm +fp*ddelta)*(Tm - Tg) - ELSE - Zx = ahg + ddelta + coefx*(Tx - tg) - Zm = ahg + coefm*(Tm - tg) - ENDIF ! (tg .gt. Tm) - ENDIF ! (tg .gt. Tx) -! Compute the masks Um, U, Ux - Um = (sign(1., Zm-ah0(i))+1.)/2. - Ux = (sign(1., ah0(i)-Zx)+1.)/2. - U = (1. - Um)*(1. - Ux) -! Compute the updated parcell temperature Tp : 3 cases depending on tg value - IF (tg .gt. Tx) THEN - discr = bb*bb - 4*dd*fp*(ah0(i) - ahg + ddelta*fp*(Tx-tg)) - Tp(i,k) = tg + & - Um* (ah0(i) - ahg + ddelta) /(aa + dd) + & - U *2*(ah0(i) - ahg + ddelta*fp*(Tx-tg))/(bb + sqrt(discr)) + & - Ux* (ah0(i) - ahg) /aa - ELSEIF (tg .gt. Tm) THEN - discr = bb*bb - 4*dd*fp*(ah0(i) - ahg) - Tp(i,k) = tg + & - Um* (ah0(i) - ahg + ddelta*fp*(tg-Tm))/(aa + dd) + & - U *2*(ah0(i) - ahg) /(bb + sqrt(discr)) + & - Ux* (ah0(i) - ahg + ddelta*fp*(tg-Tx))/aa - ELSE - discr = bb*bb - 4*dd*fp*(ah0(i) - ahg + ddelta*fp*(Tm-tg)) - Tp(i,k) = tg + & - Um* (ah0(i) - ahg) /(aa + dd) + & - U *2*(ah0(i) - ahg + ddelta*fp*(Tm-tg))/(bb + sqrt(discr)) + & - Ux* (ah0(i) - ahg - ddelta) /aa - ENDIF ! (tg .gt. Tx) -! -!! print *,' j, k, Um, U, Ux, aa, bb, discr, dd, ddelta ', j, k, Um, U, Ux, aa, bb, discr, dd, ddelta -!! print *,' j, k, ah0(i), ahg, tg, qg, tp(i,k), ff ', j, k, ah0(i), ahg, tg, qg, tp(i,k), ff - END IF ! (k>=(icbs(i)+1)) - END DO ! i = 1, ncum - END DO ! j = 1,4 - DO i = 1, ncum - IF (k>=(icbs(i)+1)) THEN ! convect3 - tg = tp(i, k) - IF (tg .gt. Tx) THEN - es = 6.112*exp(17.67*(tg - 273.15)/(tg + 243.5 - 273.15)) - qg = eps*es/(p(i,k)-es*(1.-eps)) - ELSE - esi = exp(23.33086-(6111.72784/tg)+0.15215*log(tg)) - qg = eps*esi/(p(i,k)-esi*(1.-eps)) - ENDIF - clw(i, k) = qnk(i) - qg - clw(i, k) = max(0.0, clw(i,k)) - tvp(i, k) = max(0., tp(i,k)*(1.+qg/eps-qnk(i))) -! print*,tvp(i,k),'tvp' - IF (clw(i,k)<1.E-11) THEN - tp(i, k) = tv(i, k) - tvp(i, k) = tv(i, k) - END IF ! (clw(i,k)<1.E-11) - END IF ! (k>=(icbs(i)+1)) - END DO ! i = 1, ncum - END DO ! k = minorig + 1, nl -!---------------------------------------------------------------------------- -! - ELSE IF (icvflag_Tpa == 1) THEN ! (icvflag_Tpa == 2) -! -!---------------------------------------------------------------------------- -! - DO k = minorig + 1, nl - DO i = 1,ncum - tp(i,k) = t(i,k) - ENDDO -!! alv = lv0 - clmcpv*(t(i,k)-273.15) -!! alf = lf0 + clmci*(t(i,k)-273.15) -!! als = alf + alv - DO j = 1,4 - DO i = 1, ncum -! ori if(k.ge.(icb(i)+1))then - IF (k>=(icbs(i)+1)) THEN ! convect3 - tg = tp(i, k) - IF (tg .gt. Tx .OR. .NOT.cvflag_ice) THEN - es = 6.112*exp(17.67*(tg - 273.15)/(tg + 243.5 - 273.15)) - qg = eps*es/(p(i,k)-es*(1.-eps)) - dqgdT = lv(i,k)*qg/(rrv*tg*tg) - ELSE - esi = exp(23.33086-(6111.72784/tg)+0.15215*log(tg)) - qg = eps*esi/(p(i,k)-esi*(1.-eps)) - dqgdT = (lv(i,k)+lf(i,k))*qg/(rrv*tg*tg) - ENDIF - IF (qsat_depends_on_qt) THEN - dqgdT = dqgdT*(1.-qta(i,k-1))/(1.-qg)**2 - qg = qg*(1.-qta(i,k-1))/(1.-qg) - ENDIF - ahg = (cpd + (cl-cpd)*qta(i,k-1))*tg + lv(i,k)*qg - & - lf(i,k)*frac(i,k)*(qta(i,k-1) - qg) + gz(i,k) - Tp(i,k) = tg + (ah0(i) - ahg)/ & - (cpd + (cl-cpd)*qta(i,k-1) + (lv(i,k)+frac(i,k)*lf(i,k))*dqgdT) -!! print *,'undilute2 iterations k, Tp(i,k), ah0(i), ahg ', & -!! k, Tp(i,k), ah0(i), ahg - END IF ! (k>=(icbs(i)+1)) - END DO ! i = 1, ncum - END DO ! j = 1,4 - DO i = 1, ncum - IF (k>=(icbs(i)+1)) THEN ! convect3 - tg = tp(i, k) - IF (tg .gt. Tx .OR. .NOT.cvflag_ice) THEN - es = 6.112*exp(17.67*(tg - 273.15)/(tg + 243.5 - 273.15)) - qg = eps*es/(p(i,k)-es*(1.-eps)) - ELSE - esi = exp(23.33086-(6111.72784/tg)+0.15215*log(tg)) - qg = eps*esi/(p(i,k)-esi*(1.-eps)) - ENDIF - IF (qsat_depends_on_qt) THEN - qg = qg*(1.-qta(i,k-1))/(1.-qg) - ENDIF - qhsat(i,k) = qg - END IF ! (k>=(icbs(i)+1)) - END DO ! i = 1, ncum - DO i = 1, ncum - IF (k>=(icbs(i)+1)) THEN ! convect3 - clw(i, k) = qta(i,k-1) - qhsat(i,k) - clw(i, k) = max(0.0, clw(i,k)) - tvp(i, k) = max(0., tp(i,k)*(1.+qhsat(i,k)/eps-qta(i,k-1))) -! print*,tvp(i,k),'tvp' - IF (clw(i,k)<1.E-11) THEN - tp(i, k) = tv(i, k) - tvp(i, k) = tv(i, k) - END IF ! (clw(i,k)<1.E-11) - END IF ! (k>=(icbs(i)+1)) - END DO ! i = 1, ncum -! - IF (cvflag_prec_eject) THEN - DO i = 1, ncum - IF (k>=(icbs(i)+1)) THEN ! convect3 -! Specific precipitation (liquid and solid) and ice content -! before ejection of precipitation !!jygprl - elacrit = elcrit*min(max(1.-(tp(i,k)-T0)/Tlcrit, 0.), 1.) !!jygprl -!!!! qcld(i,k) = min(clw(i,k), elacrit) !!jygprl - qhthreshold = elacrit*(1.-qta(i,k-1))/(1.-elacrit) - qcld(i,k) = min(clw(i,k), qhthreshold) !!jygprl -!!!! phinu2p = max(qhsat(i,k-1) + qcld(i,k-1) - (qhsat(i,k) + qcld(i,k)),0.) !!jygprl - phinu2p = max(clw(i,k) - max(qta(i,k-1) - qhsat(i,k-1), qhthreshold), 0.) - qpl(i,k) = qpl(i,k-1) + (1.-frac(i,k))*phinu2p !!jygprl - qps(i,k) = qps(i,k-1) + frac(i,k) *phinu2p !!jygprl - qi(i,k) = (1.-ejectliq)*clw(i,k)*frac(i,k) + & !!jygprl - ejectliq*(qps(i,k-1) + frac(i,k)*(phinu2p+qcld(i,k))) !!jygprl -!! -! ===================================================================================== -! Ejection of precipitation from adiabatic ascents if requested (cvflag_prec_eject=True): -! Compute the steps of total water (qta), of moist static energy (ha), of specific -! precipitation (qpl and qps) and of specific cloud water (qcld) associated with precipitation -! ejection. -! ===================================================================================== -! -! Verif - qpreca(i,k) = ejectliq*qpl(i,k) + ejectice*qps(i,k) !!jygprl - frac_a(i,k) = ejectice*qps(i,k)/max(qpreca(i,k),smallestreal) !!jygprl - frac_s(i,k) = (1.-ejectliq)*frac(i,k) + & !!jygprl - ejectliq*(1. - (qpl(i,k)+(1.-frac(i,k))*qcld(i,k))/max(clw(i,k),smallestreal)) !!jygprl -! - denomm1 = 1./(1. - qpreca(i,k)) -! - qta(i,k) = qta(i,k-1) - & - qpreca(i,k)*(1.-qta(i,k-1))*denomm1 - ha(i,k) = ha(i,k-1) + & - ( qpreca(i,k)*(-(1.-qta(i,k-1))*(cl-cpd)*tp(i,k) + & - lv(i,k)*qhsat(i,k) - lf(i,k)*(frac_s(i,k)*qcld(i,k)+qps(i,k))) + & - lf(i,k)*ejectice*qps(i,k))*denomm1 - hla(i,k) = hla(i,k-1) + & - ( qpreca(i,k)*(-(1.-qta(i,k-1))*(cpv-cpd)*tp(i,k) - & - lv(i,k)*((1.-frac_s(i,k))*qcld(i,k)+qpl(i,k)) - & - (lv(i,k)+lf(i,k))*(frac_s(i,k)*qcld(i,k)+qps(i,k))) + & - lv(i,k)*ejectliq*qpl(i,k) + (lv(i,k)+lf(i,k))*ejectice*qps(i,k))*denomm1 - qpl(i,k) = qpl(i,k)*(1.-ejectliq)*denomm1 - qps(i,k) = qps(i,k)*(1.-ejectice)*denomm1 - qcld(i,k) = qcld(i,k)*denomm1 - qhsat(i,k) = qhsat(i,k)*(1.-qta(i,k))/(1.-qta(i,k-1)) - END IF ! (k>=(icbs(i)+1)) - END DO ! i = 1, ncum - ENDIF ! (cvflag_prec_eject) -! - END DO ! k = minorig + 1, nl -! -!---------------------------------------------------------------------------- -! - ELSE IF (icvflag_Tpa == 0) THEN! (icvflag_Tpa == 2) ELSE IF(icvflag_Tpa == 1) -! -!---------------------------------------------------------------------------- -! - DO k = minorig + 1, nl - DO i = 1, ncum -! ori if(k.ge.(icb(i)+1))then - IF (k>=(icbs(i)+1)) THEN ! convect3 - tg = t(i, k) - qg = qs(i, k) -! debug alv=lv0-clmcpv*(t(i,k)-t0) - alv = lv0 - clmcpv*(t(i,k)-273.15) - -! First iteration. - -! 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 -! 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) -! ori tg=max(tg,35.0) -! debug tc=tg-t0 - tc = tg - 273.15 - denom = 243.5 + tc - denom = max(denom, 1.0) ! convect3 -! ori if(tc.ge.0.0)then - es = 6.112*exp(17.67*tc/denom) -! ori else -! ori es=exp(23.33086-6111.72784/tg+0.15215*log(tg)) -! ori endif - qg = eps*es/(p(i,k)-es*(1.-eps)) - -! Second iteration. - -! ori s=cpd+alv*alv*qg/(rrv*t(i,k)*t(i,k)) -! ori s=1./s -! 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) -! ori tg=max(tg,35.0) -! debug tc=tg-t0 - tc = tg - 273.15 - denom = 243.5 + tc - denom = max(denom, 1.0) ! convect3 -! ori if(tc.ge.0.0)then - es = 6.112*exp(17.67*tc/denom) -! ori else -! ori es=exp(23.33086-6111.72784/tg+0.15215*log(tg)) -! ori endif - qg = eps*es/(p(i,k)-es*(1.-eps)) - -! debug alv=lv0-clmcpv*(t(i,k)-t0) - alv = lv0 - clmcpv*(t(i,k)-273.15) -! print*,'cpd dans convect2 ',cpd -! print*,'tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd' -! print*,tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd - -! ori c approximation here: -! ori tp(i,k)=(ah0(i)-(cl-cpd)*qnk(i)*t(i,k)-gz(i,k)-alv*qg)/cpd - -! convect3: no approximation: - IF (cvflag_ice) THEN - tp(i, k) = max(0., (ah0(i)-gz(i,k)-alv*qg)/(cpd+(cl-cpd)*qnk(i))) - ELSE - tp(i, k) = (ah0(i)-gz(i,k)-alv*qg)/(cpd+(cl-cpd)*qnk(i)) - END IF - - clw(i, k) = qnk(i) - qg - clw(i, k) = max(0.0, clw(i,k)) - rg = qg/(1.-qnk(i)) -! ori tvp(i,k)=tp(i,k)*(1.+rg*epsi) -! convect3: (qg utilise au lieu du vrai mixing ratio rg): - tvp(i, k) = tp(i, k)*(1.+qg/eps-qnk(i)) ! whole thing - IF (cvflag_ice) THEN - IF (clw(i,k)<1.E-11) THEN - tp(i, k) = tv(i, k) - tvp(i, k) = tv(i, k) - END IF - END IF -!jyg< -!! END IF ! Endif moved to the end of the loop -!>jyg - - IF (cvflag_ice) THEN -!CR:attention boucle en klon dans Icefrac -! Call Icefrac(t,clw,qi,nl,nloc) - IF (t(i,k)>263.15) THEN - qi(i, k) = 0. - ELSE - IF (t(i,k)<243.15) THEN - qi(i, k) = clw(i, k) - ELSE - fracg = (263.15-t(i,k))/20 - qi(i, k) = clw(i, k)*fracg - END IF - END IF -!CR: fin test - IF (t(i,k)<263.15) THEN -!CR: on commente les calculs d'Arnaud car division par zero -! nouveau calcul propose par JYG -! alv=lv0-clmcpv*(t(i,k)-273.15) -! alf=lf0-clmci*(t(i,k)-273.15) -! tg=tp(i,k) -! tc=tp(i,k)-273.15 -! denom=243.5+tc -! do j=1,3 -! cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -! il faudra que esi vienne en argument de la convection -! cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -! tbis=t(i,k)+(tp(i,k)-tg) -! esi=exp(23.33086-(6111.72784/tbis) + & -! 0.15215*log(tbis)) -! qsat_new=eps*esi/(p(i,k)-esi*(1.-eps)) -! snew=cpd*(1.-qnk(i))+cl*qnk(i)+alv*alv*qsat_new/ & -! (rrv*tbis*tbis) -! snew=1./snew -! print*,esi,qsat_new,snew,'esi,qsat,snew' -! tp(i,k)=tg+(alf*qi(i,k)+alv*qg*(1.-(esi/es)))*snew -! print*,k,tp(i,k),qnk(i),'avec glace' -! print*,'tpNAN',tg,alf,qi(i,k),alv,qg,esi,es,snew -! enddo - - alv = lv0 - clmcpv*(t(i,k)-273.15) - alf = lf0 + clmci*(t(i,k)-273.15) - als = alf + alv - tg = tp(i, k) - tp(i, k) = t(i, k) - DO j = 1, 3 - esi = exp(23.33086-(6111.72784/tp(i,k))+0.15215*log(tp(i,k))) - qsat_new = eps*esi/(p(i,k)-esi*(1.-eps)) - snew = cpd*(1.-qnk(i)) + cl*qnk(i) + alv*als*qsat_new/ & - (rrv*tp(i,k)*tp(i,k)) - snew = 1./snew -! c print*,esi,qsat_new,snew,'esi,qsat,snew' - tp(i, k) = tp(i, k) + & - ((cpd*(1.-qnk(i))+cl*qnk(i))*(tg-tp(i,k)) + & - alv*(qg-qsat_new)+alf*qi(i,k))*snew -! print*,k,tp(i,k),qsat_new,qnk(i),qi(i,k), & -! 'k,tp,q,qt,qi avec glace' - END DO - -!CR:reprise du code AJ - clw(i, k) = qnk(i) - qsat_new - clw(i, k) = max(0.0, clw(i,k)) - tvp(i, k) = max(0., tp(i,k)*(1.+qsat_new/eps-qnk(i))) -! print*,tvp(i,k),'tvp' - END IF - IF (clw(i,k)<1.E-11) THEN - tp(i, k) = tv(i, k) - tvp(i, k) = tv(i, k) - END IF - END IF ! (cvflag_ice) -!jyg< - END IF ! (k>=(icbs(i)+1)) -!>jyg - END DO - END DO - -!---------------------------------------------------------------------------- -! - ENDIF ! (icvflag_Tpa == 2) ELSEIF (icvflag_Tpa == 1) ELSE (icvflag_Tpa == 0) -! -!---------------------------------------------------------------------------- -! -! ===================================================================== -! --- SET THE PRECIPITATION EFFICIENCIES -! --- THESE MAY BE FUNCTIONS OF TP(I), P(I) AND CLW(I) -! ===================================================================== -! - IF (flag_epkeorig/=1) THEN - DO k = 1, nl ! convect3 - DO i = 1, ncum -!jyg< - IF(k>=icb(i)) THEN -!>jyg - pden = ptcrit - pbcrit - ep(i, k) = (plcl(i)-p(i,k)-pbcrit)/pden*epmax - ep(i, k) = max(ep(i,k), 0.0) - ep(i, k) = min(ep(i,k), epmax) -!! sigp(i, k) = spfac ! jyg - ENDIF ! (k>=icb(i)) - END DO - END DO - ELSE - DO k = 1, nl - DO i = 1, ncum - IF(k>=icb(i)) THEN -!! IF (k>=(nk(i)+1)) THEN -!>jyg - tca = tp(i, k) - t0 - IF (tca>=0.0) THEN - elacrit = elcrit - ELSE - elacrit = elcrit*(1.0-tca/tlcrit) - END IF - elacrit = max(elacrit, 0.0) - ep(i, k) = 1.0 - elacrit/max(clw(i,k), 1.0E-8) - ep(i, k) = max(ep(i,k), 0.0) - ep(i, k) = min(ep(i,k), epmax) -!! sigp(i, k) = spfac ! jyg - END IF ! (k>=icb(i)) - END DO - END DO - END IF -! -! ========================================================================= - IF (prt_level >= 10) THEN - print *,'cv3_undilute2.1. tp(1,k), tvp(1,k) ', & - (k, tp(1,k), tvp(1,k), k = 1,nl) - ENDIF -! -! ===================================================================== -! --- CALCULATE VIRTUAL TEMPERATURE AND LIFTED PARCEL -! --- VIRTUAL TEMPERATURE -! ===================================================================== - -! dans convect3, tvp est calcule en une seule fois, et sans retirer -! l'eau condensee (~> reversible CAPE) - -! ori do 340 k=minorig+1,nl -! ori do 330 i=1,ncum -! ori if(k.ge.(icb(i)+1))then -! ori tvp(i,k)=tvp(i,k)*(1.0-qnk(i)+ep(i,k)*clw(i,k)) -! oric print*,'i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)' -! oric print*, i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k) -! ori endif -! ori 330 continue -! ori 340 continue - -! ori do 350 i=1,ncum -! ori tvp(i,nlp)=tvp(i,nl)-(gz(i,nlp)-gz(i,nl))/cpd -! ori 350 continue - - DO i = 1, ncum ! convect3 - tp(i, nlp) = tp(i, nl) ! convect3 - END DO ! convect3 - -! ===================================================================== -! --- EFFECTIVE VERTICAL PROFILE OF BUOYANCY (convect3 only): -! ===================================================================== - -! -- this is for convect3 only: - -! first estimate of buoyancy: - -!jyg : k-loop outside i-loop (07042015) - DO k = 1, nl - DO i = 1, ncum - buoy(i, k) = tvp(i, k) - tv(i, k) - END DO - END DO - -! set buoyancy=buoybase for all levels below base -! for safety, set buoy(icb)=buoybase - -!jyg : k-loop outside i-loop (07042015) - DO k = 1, nl - DO i = 1, ncum - IF ((k>=icb(i)) .AND. (k<=nl) .AND. (p(i,k)>=pbase(i))) THEN - buoy(i, k) = buoybase(i) - END IF - END DO - END DO - DO i = 1, ncum -! buoy(icb(i),k)=buoybase(i) - buoy(i, icb(i)) = buoybase(i) - END DO - -! -- end convect3 - -! ===================================================================== -! --- FIND THE FIRST MODEL LEVEL (INB) ABOVE THE PARCEL'S -! --- LEVEL OF NEUTRAL BUOYANCY -! ===================================================================== - -! -- this is for convect3 only: - - DO i = 1, ncum - inb(i) = nl - 1 - iposit(i) = nl - END DO - - -! -- iposit(i) = first level, above icb, with positive buoyancy - DO k = 1, nl - 1 - DO i = 1, ncum - IF (k>=icb(i) .AND. buoy(i,k)>0.) THEN - iposit(i) = min(iposit(i), k) - END IF - END DO - END DO - - DO i = 1, ncum - IF (iposit(i)==nl) THEN - iposit(i) = icb(i) - END IF - END DO - - DO k = 1, nl - 1 - DO i = 1, ncum - IF ((k>=iposit(i)) .AND. (buoy(i,k)=iposit(i))) THEN - deltap = min(plcl(i), ph(i,k-1)) - min(plcl(i), ph(i,k)) - cape(i) = cape(i) + rrd*buoy(i, k-1)*deltap/p(i, k-1) - IF (cape(i).gt.0.) THEN - inb(i) = max(inb(i), k) - END IF - ENDIF - ENDDO - ENDDO - -! DO i = 1, ncum -! print*,"inb",inb(i) -! ENDDO - - endif - -! -- end convect3 - -! ori do 510 i=1,ncum -! ori cape(i)=0.0 -! ori capem(i)=0.0 -! ori inb(i)=icb(i)+1 -! ori inb1(i)=inb(i) -! ori 510 continue - -! Originial Code - -! do 530 k=minorig+1,nl-1 -! do 520 i=1,ncum -! if(k.ge.(icb(i)+1))then -! by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k) -! byp=(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 -! byp=(tvp(i,nl)-tv(i,nl))*dph(i,nl)/p(i,nl) -! cape(i)=capem(i)+byp -! 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 - -! K Emanuel fix - -! call zilch(byp,ncum) -! do 530 k=minorig+1,nl-1 -! do 520 i=1,ncum -! if(k.ge.(icb(i)+1))then -! by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k) -! 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) -! byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1) -! endif -! endif -!520 continue -!530 continue -! do 540 i=1,ncum -! inb(i)=max(inb(i),inb1(i)) -! 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 - -! J Teixeira fix - -! ori call zilch(byp,ncum) -! ori do 515 i=1,ncum -! ori lcape(i)=.true. -! ori 515 continue -! ori do 530 k=minorig+1,nl-1 -! ori do 520 i=1,ncum -! ori if(cape(i).lt.0.0)lcape(i)=.false. -! ori if((k.ge.(icb(i)+1)).and.lcape(i))then -! ori by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k) -! ori byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1) -! ori cape(i)=cape(i)+by -! ori if(by.ge.0.0)inb1(i)=k+1 -! ori if(cape(i).gt.0.0)then -! ori inb(i)=k+1 -! ori capem(i)=cape(i) -! ori endif -! ori endif -! ori 520 continue -! ori 530 continue -! ori do 540 i=1,ncum -! ori cape(i)=capem(i)+byp(i) -! ori defrac=capem(i)-cape(i) -! ori defrac=max(defrac,0.001) -! ori frac(i)=-cape(i)/defrac -! ori frac(i)=min(frac(i),1.0) -! ori frac(i)=max(frac(i),0.0) -! ori 540 continue - -! -------------------------------------------------------------------- -! Prevent convection when top is too hot -! -------------------------------------------------------------------- - DO i = 1,ncum - IF (t(i,inb(i)) > T_top_max) iflag(i) = 10 - ENDDO - -! ===================================================================== -! --- CALCULATE LIQUID WATER STATIC ENERGY OF LIFTED PARCEL -! ===================================================================== - - DO k = 1, nl - DO i = 1, ncum - hp(i, k) = h(i, k) - END DO - END DO - -!jyg : cvflag_ice test outside the loops (07042015) -! - IF (cvflag_ice) THEN -! - IF (cvflag_prec_eject) THEN -!! DO k = minorig + 1, nl -!! DO i = 1, ncum -!! IF ((k>=icb(i)) .AND. (k<=inb(i))) THEN -!! frac_s(i,k) = qi(i,k)/max(clw(i,k),smallestreal) -!! frac_s(i,k) = 1. - (qpl(i,k)+(1.-frac_s(i,k))*qcld(i,k))/max(clw(i,k),smallestreal) -!! END IF -!! END DO -!! END DO - ELSE ! (cvflag_prec_eject) - DO k = minorig + 1, nl - DO i = 1, ncum - IF ((k>=icb(i)) .AND. (k<=inb(i))) THEN -!jyg< frac computation moved to beginning of cv3_undilute2. -! kept here for compatibility test with CMip6 version - frac_s(i, k) = 1. - (t(i,k)-243.15)/(263.15-243.15) - frac_s(i, k) = min(max(frac_s(i,k),0.0), 1.0) - END IF - END DO - END DO - ENDIF ! (cvflag_prec_eject) ELSE - DO k = minorig + 1, nl - DO i = 1, ncum - IF ((k>=icb(i)) .AND. (k<=inb(i))) THEN -!! hp(i, k) = hnk(i) + (lv(i,k)+(cpd-cpv)*t(i,k)+frac_s(i,k)*lf(i,k))* & !!jygprl -!! ep(i, k)*clw(i, k) !!jygprl - hp(i, k) = hla(i,k-1) + (lv(i,k)+(cpd-cpv)*t(i,k)+frac_s(i,k)*lf(i,k))* & !!jygprl - ep(i, k)*clw(i, k) !!jygprl - END IF - END DO - END DO -! - ELSE ! (cvflag_ice) -! - DO k = minorig + 1, nl - DO i = 1, ncum - IF ((k>=icb(i)) .AND. (k<=inb(i))) THEN -!jyg< (energy conservation tests) -!! hp(i, k) = hnk(i) + (lv(i,k)+(cpd-cpv)*tp(i,k))*ep(i, k)*clw(i, k) -!! hp(i, k) = ( hnk(i) + (lv(i,k)+(cpd-cpv)*t(i,k))*ep(i, k)*clw(i, k) ) / & -!! (1. - ep(i,k)*clw(i,k)) -!! hp(i, k) = ( hnk(i) + (lv(i,k)+(cpd-cl)*t(i,k))*ep(i, k)*clw(i, k) ) / & -!! (1. - ep(i,k)*clw(i,k)) - hp(i, k) = hnk(i) + (lv(i,k)+(cpd-cpv)*t(i,k))*ep(i, k)*clw(i, k) - END IF - END DO - END DO -! - END IF ! (cvflag_ice) - - RETURN -END SUBROUTINE cv3_undilute2 - -SUBROUTINE cv3_closure(nloc, ncum, nd, icb, inb, & - pbase, p, ph, tv, buoy, & - sig, w0, cape, m, iflag) - USE lmdz_cv_ini, ONLY : alpha,beta,dtcrit,minorig,nl,rrd - USE cvflag_mod_h - IMPLICIT NONE - -! =================================================================== -! --- CLOSURE OF CONVECT3 -! -! vectorization: S. Bony -! =================================================================== - - -!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) - -!input/output: - REAL sig(nloc, nd), w0(nloc, nd) - INTEGER iflag(nloc) - -!output: - REAL cape(nloc) - REAL m(nloc, nd) - -!local variables: - INTEGER i, j, k, icbmax - REAL deltap, fac, w, amu - REAL dtmin(nloc, nd), sigold(nloc, nd) - REAL cbmflast(nloc) - - -! ------------------------------------------------------- -! -- Initialization -! ------------------------------------------------------- - - DO k = 1, nl - DO i = 1, ncum - m(i, k) = 0.0 - END DO - END DO - -! ------------------------------------------------------- -! -- Reset sig(i) and w0(i) for i>inb and i=(inb(i)+1))) THEN - sig(i, k) = beta*sig(i, k) + & - 2.*alpha*buoy(i, inb(i))*abs(buoy(i,inb(i))) - sig(i, k) = amax1(sig(i,k), 0.0) - w0(i, k) = beta*w0(i, k) - END IF - END DO - END DO - -! compute icbmax: - -!ym icbmax = 2 -!ym DO i = 1, ncum -!ym icbmax = max(icbmax, icb(i)) -!ym END DO - -! update sig and w0 below cloud base: - -!ym DO k = 1, icbmax - DO k = 1, nd - DO i = 1, ncum - IF (k<=MAX(2,icb(i))) THEN - IF (k<=icb(i)) THEN - sig(i, k) = beta*sig(i, k) - & - 2.*alpha*buoy(i, icb(i))*buoy(i, icb(i)) - sig(i, k) = max(sig(i,k), 0.0) - w0(i, k) = beta*w0(i, k) - END IF - ENDIF - END DO - END DO - -!! if(inb.lt.(nl-1))then -!! do 85 i=inb+1,nl-1 -!! sig(i)=beta*sig(i)+2.*alpha*buoy(inb)* -!! 1 abs(buoy(inb)) -!! sig(i)=max(sig(i),0.0) -!! w0(i)=beta*w0(i) -!! 85 continue -!! end if - -!! do 87 i=1,icb -!! sig(i)=beta*sig(i)-2.*alpha*buoy(icb)*buoy(icb) -!! sig(i)=max(sig(i),0.0) -!! w0(i)=beta*w0(i) -!! 87 continue - -! ------------------------------------------------------------- -! -- Reset fractional areas of updrafts and w0 at initial time -! -- and after 10 time steps of no convection -! ------------------------------------------------------------- - - DO k = 1, nl - 1 - DO i = 1, ncum - IF (sig(i,nd)<1.5 .OR. sig(i,nd)>12.0) THEN - sig(i, k) = 0.0 - w0(i, k) = 0.0 - END IF - END DO - END DO - -! ------------------------------------------------------------- -! -- Calculate convective available potential energy (cape), -! -- vertical velocity (w), fractional area covered by -! -- undilute updraft (sig), and updraft mass flux (m) -! ------------------------------------------------------------- - - DO i = 1, ncum - cape(i) = 0.0 - END DO - -! compute dtmin (minimum buoyancy between ICB and given level k): - - DO i = 1, ncum - DO k = 1, nl - dtmin(i, k) = 100.0 - END DO - END DO - - DO i = 1, ncum - DO k = 1, nl - DO j = minorig, nl - IF ((k>=(icb(i)+1)) .AND. (k<=inb(i)) .AND. (j>=icb(i)) .AND. (j<=(k-1))) THEN - dtmin(i, k) = amin1(dtmin(i,k), buoy(i,j)) - END IF - END DO - END DO - END DO - -! the interval on which cape is computed starts at pbase : - - DO k = 1, nl - DO i = 1, ncum - - IF ((k>=(icb(i)+1)) .AND. (k<=inb(i))) THEN - - deltap = min(pbase(i), ph(i,k-1)) - min(pbase(i), ph(i,k)) - cape(i) = cape(i) + rrd*buoy(i, k-1)*deltap/p(i, k-1) - cape(i) = amax1(0.0, cape(i)) - sigold(i, k) = sig(i, k) - -! dtmin(i,k)=100.0 -! do 97 j=icb(i),k-1 ! mauvaise vectorisation -! dtmin(i,k)=AMIN1(dtmin(i,k),buoy(i,j)) -! 97 continue - - sig(i, k) = beta*sig(i, k) + alpha*dtmin(i, k)*abs(dtmin(i,k)) - sig(i, k) = max(sig(i,k), 0.0) - sig(i, k) = amin1(sig(i,k), 0.01) - fac = amin1(((dtcrit-dtmin(i,k))/dtcrit), 1.0) - w = (1.-beta)*fac*sqrt(cape(i)) + beta*w0(i, k) - amu = 0.5*(sig(i,k)+sigold(i,k))*w - m(i, k) = amu*0.007*p(i, k)*(ph(i,k)-ph(i,k+1))/tv(i, k) - w0(i, k) = w - END IF - - END DO - END DO - - DO i = 1, ncum - w0(i, icb(i)) = 0.5*w0(i, icb(i)+1) - m(i, icb(i)) = 0.5*m(i, icb(i)+1)*(ph(i,icb(i))-ph(i,icb(i)+1))/(ph(i,icb(i)+1)-ph(i,icb(i)+2)) - sig(i, icb(i)) = sig(i, icb(i)+1) - sig(i, icb(i)-1) = sig(i, icb(i)) - END DO - -! ccc 3. Compute final cloud base mass flux and set iflag to 3 if -! ccc cloud base mass flux is exceedingly small and is decreasing (i.e. if -! ccc the final mass flux (cbmflast) is greater than the target mass flux -! ccc (cbmf) ??). -! cc -! c do i = 1,ncum -! c cbmflast(i) = 0. -! c enddo -! cc -! c do k= 1,nl -! c do i = 1,ncum -! c IF (k .ge. icb(i) .and. k .le. inb(i)) THEN -! c cbmflast(i) = cbmflast(i)+M(i,k) -! c ENDIF -! c enddo -! c enddo -! cc -! c do i = 1,ncum -! c IF (cbmflast(i) .lt. 1.e-6) THEN -! c iflag(i) = 3 -! c ENDIF -! c enddo -! cc -! c do k= 1,nl -! c do i = 1,ncum -! c IF (iflag(i) .ge. 3) THEN -! c M(i,k) = 0. -! c sig(i,k) = 0. -! c w0(i,k) = 0. -! c ENDIF -! c enddo -! c enddo -! cc -!! cape=0.0 -!! do 98 i=icb+1,inb -!! deltap = min(pbase,ph(i-1))-min(pbase,ph(i)) -!! cape=cape+rrd*buoy(i-1)*deltap/p(i-1) -!! dcape=rrd*buoy(i-1)*deltap/p(i-1) -!! dlnp=deltap/p(i-1) -!! cape=max(0.0,cape) -!! sigold=sig(i) - -!! dtmin=100.0 -!! do 97 j=icb,i-1 -!! dtmin=amin1(dtmin,buoy(j)) -!! 97 continue - -!! sig(i)=beta*sig(i)+alpha*dtmin*abs(dtmin) -!! sig(i)=max(sig(i),0.0) -!! sig(i)=amin1(sig(i),0.01) -!! fac=amin1(((dtcrit-dtmin)/dtcrit),1.0) -!! w=(1.-beta)*fac*sqrt(cape)+beta*w0(i) -!! amu=0.5*(sig(i)+sigold)*w -!! m(i)=amu*0.007*p(i)*(ph(i)-ph(i+1))/tv(i) -!! w0(i)=w -!! 98 continue -!! w0(icb)=0.5*w0(icb+1) -!! m(icb)=0.5*m(icb+1)*(ph(icb)-ph(icb+1))/(ph(icb+1)-ph(icb+2)) -!! sig(icb)=sig(icb+1) -!! sig(icb-1)=sig(icb) - - RETURN -END SUBROUTINE cv3_closure - -!!SUBROUTINE cv3_mixing(nloc, ncum, nd, na, ntra, icb, nk, inb, & !jyg: get rid of ntra -SUBROUTINE cv3_mixing(nloc, ncum, nd, na, icb, nk, inb, & -!! ph, t, rr, rs, u, v, tra, h, lv, lf, frac, qnk, & !jyg: get rid of ntra - ph, t, rr, rs, u, v, h, lv, lf, frac, qnk, & - unk, vnk, hp, tv, tvp, ep, clw, m, sig, & -!! ment, qent, uent, vent, nent, sij, elij, ments, qents, traent) !jyg: get rid of ntra -!! ment, qent, uent, vent, nent, sij, elij, ments, qents) !jyg: get rid of ments - ment, qent, uent, vent, nent, sij, elij) - USE cvflag_mod_h - USE lmdz_cv_ini, ONLY : cpd,cpv,minorig,nl,rrv,cpd,ginv,grav - IMPLICIT NONE - -! --------------------------------------------------------------------- -! a faire: -! - vectorisation de la partie normalisation des flux (do 789...) -! --------------------------------------------------------------------- - -!inputs: -!! INTEGER, INTENT (IN) :: ncum, nd, na, ntra, nloc !jyg: get rid of ntra - INTEGER, INTENT (IN) :: ncum, nd, na, nloc - INTEGER, DIMENSION (nloc), INTENT (IN) :: icb, inb, nk - REAL, DIMENSION (nloc, nd), INTENT (IN) :: sig - REAL, DIMENSION (nloc), INTENT (IN) :: qnk, unk, vnk - REAL, DIMENSION (nloc, nd+1), INTENT (IN) :: ph - REAL, DIMENSION (nloc, nd), INTENT (IN) :: t, rr, rs - REAL, DIMENSION (nloc, nd), INTENT (IN) :: u, v -!! REAL, DIMENSION (nloc, nd, ntra), INTENT (IN) :: tra ! input of convect3 !jyg: get rid of ntra - REAL, DIMENSION (nloc, na), INTENT (IN) :: lv, h, hp - REAL, DIMENSION (nloc, na), INTENT (IN) :: lf, frac - REAL, DIMENSION (nloc, na), INTENT (IN) :: tv, tvp, ep, clw - REAL, DIMENSION (nloc, na), INTENT (IN) :: m ! input of convect3 - -!outputs: - REAL, DIMENSION (nloc, na, na), INTENT (OUT) :: ment, qent - REAL, DIMENSION (nloc, na, na), INTENT (OUT) :: uent, vent - REAL, DIMENSION (nloc, na, na), INTENT (OUT) :: sij, elij -!! REAL, DIMENSION (nloc, nd, nd, ntra), INTENT (OUT) :: traent !jyg: get rid of ntra -!! REAL, DIMENSION (nloc, nd, nd), INTENT (OUT) :: ments, qents !jyg: get rid of ments - INTEGER, DIMENSION (nloc, nd), INTENT (OUT) :: nent - -!local variables: - INTEGER i, j, k, il, im, jm - INTEGER num1, num2 - 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 sigij(nloc, nd, nd) - REAL wgh - REAL zm(nloc, na) - LOGICAL lwork(nloc) - -! ===================================================================== -! --- INITIALIZE VARIOUS ARRAYS USED IN THE COMPUTATIONS -! ===================================================================== - -! ori do 360 i=1,ncum*nlp - DO j = 1, nl - DO il = 1, ncum - nent(il, j) = 0 -! in convect3, m is computed in cv3_closure -! ori m(i,1)=0.0 - END DO - END DO - -! ori do 400 k=1,nlp -! ori do 390 j=1,nlp - DO j = 1, nl - DO k = 1, nl - DO il = 1, ncum - qent(il, k, j) = rr(il, j) - uent(il, k, j) = u(il, j) - vent(il, k, j) = v(il, j) - elij(il, k, j) = 0.0 -!ym ment(i,k,j)=0.0 -!ym sij(i,k,j)=0.0 - END DO - END DO - END DO - -!ym - ment(1:ncum, 1:nd, 1:nd) = 0.0 - sij(1:ncum, 1:nd, 1:nd) = 0.0 - zm(:, :) = 0. - -! ===================================================================== -! --- CALCULATE ENTRAINED AIR MASS FLUX (ment), TOTAL WATER MIXING -! --- RATIO (QENT), TOTAL CONDENSED WATER (elij), AND MIXING -! --- FRACTION (sij) -! ===================================================================== - - DO i = minorig + 1, nl - - DO j = minorig, nl - DO il = 1, ncum - IF ((i>=icb(il)) .AND. (i<=inb(il)) .AND. (j>=(icb(il)-1)) .AND. (j<=inb(il))) THEN - - rti = qnk(il) - 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) - - - IF (cvflag_ice) THEN -! print*,cvflag_ice,'cvflag_ice dans do 700' - IF (t(il,j)<=263.15) THEN - bf2 = 1. + (lf(il,j)+lv(il,j))*(lv(il,j)+frac(il,j)* & - lf(il,j))*rs(il, j)/(rrv*t(il,j)*t(il,j)*cpd) - END IF - END IF - - 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)<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<0.0 .OR. stemp>1.0 .OR. altem>cwat) .AND. j>i) THEN - - IF (cvflag_ice) THEN - anum = anum - (lv(il,j)+frac(il,j)*lf(il,j))*(rti-rs(il,j)-cwat*bf2) - denom = denom + (lv(il,j)+frac(il,j)*lf(il,j))*(rr(il,i)-rti) - ELSE - anum = anum - lv(il, j)*(rti-rs(il,j)-cwat*bf2) - denom = denom + lv(il, j)*(rr(il,i)-rti) - END IF - - IF (abs(denom)<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)>0.0 .AND. sij(il,i,j)<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))*unk(il) - vent(il, i, j) = sij(il, i, j)*v(il, i) + (1.-sij(il,i,j))*vnk(il) - elij(il, i, j) = altem - elij(il, i, j) = max(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) = max(0.0, sij(il,i,j)) - sij(il, i, j) = amin1(1.0, sij(il,i,j)) - END IF ! new - END DO - END DO - - -! *** if no air can entrain at level i assume that updraft detrains *** -! *** at that level and calculate detrained air flux and properties *** - - -! @ do 170 i=icb(il),inb(il) - - DO il = 1, ncum - IF ((i>=icb(il)) .AND. (i<=inb(il)) .AND. (nent(il,i)==0)) THEN -! @ if(nent(il,i).eq.0)then - ment(il, i, i) = m(il, i) - qent(il, i, i) = qnk(il) - ep(il, i)*clw(il, i) - uent(il, i, i) = unk(il) - vent(il, i, i) = vnk(il) - elij(il, i, i) = clw(il, i) -! MAF sij(il,i,i)=1.0 - sij(il, i, i) = 0.0 - END IF - END DO - END DO - - DO j = minorig, nl - DO i = minorig, nl - DO il = 1, ncum - IF ((j>=(icb(il)-1)) .AND. (j<=inb(il)) .AND. (i>=icb(il)) .AND. (i<=inb(il))) THEN - sigij(il, i, j) = sij(il, i, j) - END IF - END DO - END DO - END DO -! @ enddo - -! @170 continue - -! ===================================================================== -! --- NORMALIZE ENTRAINED AIR MASS FLUXES -! --- TO REPRESENT EQUAL PROBABILITIES OF MIXING -! ===================================================================== - asum(1:nloc,1:nd) = 0. - csum(1:nloc,1:nd) = 0. - - DO il = 1, ncum - lwork(il) = .FALSE. - END DO - - DO i = minorig + 1, nl - - num1 = 0 - DO il = 1, ncum - IF (i>=icb(il) .AND. i<=inb(il)) num1 = num1 + 1 - END DO -!ym IF (num1<=0) GO TO 789 - IF (num1<=0) CYCLE - - DO il = 1, ncum - IF (i>=icb(il) .AND. i<=inb(il)) THEN - lwork(il) = (nent(il,i)/=0) - qp = qnk(il) - ep(il, i)*clw(il, i) - - IF (cvflag_ice) THEN - - anum = h(il, i) - hp(il, i) - (lv(il,i)+frac(il,i)*lf(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)+frac(il,i)*lf(il,i))* & - (rr(il,i)-qp) + (cpd-cpv)*t(il, i)*(rr(il,i)-qp) - ELSE - - 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) - END IF - - IF (abs(denom)<0.01) denom = 0.01 - scrit(il) = anum/denom - alt = qp - rs(il, i) + scrit(il)*(rr(il,i)-qp) - IF (scrit(il)<=0.0 .OR. alt<=0.0) scrit(il) = 1.0 - smax(il) = 0.0 - asij(il) = 0.0 - END IF - END DO - - DO j = nl, minorig, -1 - - num2 = 0 - DO il = 1, ncum - IF (i>=icb(il) .AND. i<=inb(il) .AND. & - j>=(icb(il)-1) .AND. j<=inb(il) .AND. & - lwork(il)) num2 = num2 + 1 - END DO -!ym IF (num2<=0) GO TO 175 - IF (num2<=0) CYCLE - - DO il = 1, ncum - IF (i>=icb(il) .AND. i<=inb(il) .AND. & - j>=(icb(il)-1) .AND. j<=inb(il) .AND. & - lwork(il)) THEN - - IF (sij(il,i,j)>1.0E-16 .AND. sij(il,i,j)<0.95) THEN - wgh = 1.0 - IF (j>i) THEN - sjmax = max(sij(il,i,j+1), smax(il)) - sjmax = amin1(sjmax, scrit(il)) - smax(il) = max(sij(il,i,j), smax(il)) - sjmin = max(sij(il,i,j-1), smax(il)) - sjmin = amin1(sjmin, scrit(il)) - IF (sij(il,i,j)<(smax(il)-1.0E-16)) wgh = 0.0 - smid = amin1(sij(il,i,j), scrit(il)) - ELSE - sjmax = max(sij(il,i,j+1), scrit(il)) - smid = max(sij(il,i,j), scrit(il)) - sjmin = 0.0 - IF (j>1) sjmin = sij(il, i, j-1) - sjmin = max(sjmin, scrit(il)) - END IF - 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 - END IF - END IF - END DO - -175 END DO - - DO il = 1, ncum - IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il)) THEN - asij(il) = max(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 - END IF - END DO - - DO j = minorig, nl - DO il = 1, ncum - IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il) .AND. & - j>=(icb(il)-1) .AND. j<=inb(il)) THEN - ment(il, i, j) = ment(il, i, j)*asij(il) - END IF - END DO - END DO - - DO j = minorig, nl - DO il = 1, ncum - IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il) .AND. & - j>=(icb(il)-1) .AND. j<=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) - END IF - END DO - END DO - - DO il = 1, ncum - IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il)) THEN - bsum(il, i) = max(bsum(il,i), 1.0E-16) - bsum(il, i) = 1.0/bsum(il, i) - END IF - END DO - - DO j = minorig, nl - DO il = 1, ncum - IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il) .AND. & - j>=(icb(il)-1) .AND. j<=inb(il)) THEN - ment(il, i, j) = ment(il, i, j)*asum(il, i)*bsum(il, i) - END IF - END DO - END DO - - DO j = minorig, nl - DO il = 1, ncum - IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il) .AND. & - j>=(icb(il)-1) .AND. j<=inb(il)) THEN - csum(il, i) = csum(il, i) + ment(il, i, j) - END IF - END DO - END DO - - DO il = 1, ncum - IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il) .AND. & - csum(il,i)cv3_unsat, iflag(1) ', iflag(1) - -smallestreal=tiny(smallestreal) - -! ============================= -! --- INITIALIZE OUTPUT ARRAYS -! ============================= -! (loops up to nl+1) -mp(:,:) = 0. -rp(:,:) = 0. -up(:,:) = 0. -vp(:,:) = 0. -water(:,:) = 0. -evap(:,:) = 0. -wt(:,:) = 0. -ice(:,:) = 0. -fondue(:,:) = 0. -faci(:,:) = 0. -b(:,:) = 0. -sigd(:) = 0. -!! RomP >>> -wdtrainA(:,:) = 0. -wdtrainS(:,:) = 0. -wdtrainM(:,:) = 0. -!! RomP <<< - - DO i = 1, nlp - DO il = 1, ncum - rp(il, i) = rr(il, i) - up(il, i) = u(il, i) - vp(il, i) = v(il, i) - wt(il, i) = 0.001 - END DO - END DO - -! *** Set the fractionnal area sigd of precipitating downdraughts - DO il = 1, ncum - sigd(il) = sigdz*coef_clos(il) - END DO - -! ===================================================================== -! --- INITIALIZE VARIOUS ARRAYS AND PARAMETERS USED IN THE COMPUTATIONS -! ===================================================================== -! (loops up to nl+1) - - delti = 1./delt - tinv = 1./3. - - DO i = 1, nlp - DO il = 1, ncum - frac(il, i) = 0.0 - fraci(il, i) = 0.0 - prec(il, i) = 0.0 - lvcp(il, i) = lv(il, i)/cpn(il, i) - lfcp(il, i) = lf(il, i)/cpn(il, i) - END DO - END DO - -! *** check whether ep(inb)=0, if so, skip precipitating *** -! *** downdraft calculation *** - - - DO il = 1, ncum -!! lwork(il)=.TRUE. -!! if(ep(il,inb(il)).lt.0.0001)lwork(il)=.FALSE. -!jyg< -!! lwork(il) = ep(il, inb(il)) >= 0.0001 - lwork(il) = ep(il, inb(il)) >= 0.0001 .AND. iflag(il) <= 2 - END DO - -! -! Get adiabatic ascent mass flux -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - IF (adiab_ascent_mass_flux_depends_on_ejectliq) THEN -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!! Warning : this option leads to water conservation violation -!!! Expert only -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - DO il = 1, ncum - ma(il, nlp) = 0. - ma(il, 1) = 0. - END DO - - DO i = nl, 2, -1 - DO il = 1, ncum - ma(il, i) = ma(il, i+1)*(1.-qta(il,i))/(1.-qta(il,i-1)) + m(il, i) - END DO - END DO -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ELSE ! (adiab_ascent_mass_flux_depends_on_ejectliq) -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - DO il = 1, ncum - ma(il, nlp) = 0. - ma(il, 1) = 0. - END DO - - DO i = nl, 2, -1 - DO il = 1, ncum - ma(il, i) = ma(il, i+1) + m(il, i) - END DO - END DO - - ENDIF ! (adiab_ascent_mass_flux_depends_on_ejectliq) ELSE -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -! -! *** begin downdraft loop *** -! -! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - DO i = nl + 1, 1, -1 - - num1 = 0 - DO il = 1, ncum - IF (i<=inb(il) .AND. lwork(il)) num1 = num1 + 1 - END DO -!ym IF (num1<=0) GO TO 400 - IF (num1<=0) CYCLE - - wdtrain(1:ncum) = 0.0 - - -! *** integrate liquid water equation to find condensed water *** -! *** and condensed water flux *** -! -! -! *** calculate detrained precipitation *** - - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - DO il = 1, ncum - IF (i<=inb(il) .AND. lwork(il)) THEN - wdtrainS(il, i) = ep(il, i)*m(il, i)*clw(il, i) ! jyg - END IF - END DO - - IF (i>1) THEN - DO j = 1, i - 1 - DO il = 1, ncum - IF (i<=inb(il) .AND. lwork(il)) THEN - awat = elij(il, j, i) - (1.-ep(il,i))*clw(il, i) - awat = max(awat, 0.0) - wdtrainM(il, i) = wdtrainM(il, i) + awat*ment(il, j, i) ! jyg - END IF - END DO - END DO - END IF - - IF (cvflag_prec_eject) THEN - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - IF (adiab_ascent_mass_flux_depends_on_ejectliq) THEN - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !!! Warning : this option leads to water conservation violation - !!! Expert only - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - IF ( i > 1) THEN - DO il = 1, ncum - IF (i<=inb(il) .AND. lwork(il)) THEN - wdtrainA(il,i) = ma(il, i+1)*(qta(il, i-1)-qta(il,i))/(1. - qta(il, i-1)) ! Pa jygprl - END IF - END DO - ENDIF ! ( i > 1) - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ELSE ! (adiab_ascent_mass_flux_depends_on_ejectliq) - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - IF ( i > 1) THEN - DO il = 1, ncum - IF (i<=inb(il) .AND. lwork(il)) THEN - wdtrainA(il,i) = ma(il, i+1)*(qta(il, i-1)-qta(il,i)) ! Pa jygprl - END IF - END DO - ENDIF ! ( i > 1) - - ENDIF ! (adiab_ascent_mass_flux_depends_on_ejectliq) ELSE - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ENDIF ! (cvflag_prec_eject) - - IF ( i > 1) THEN - DO il = 1, ncum - IF (i<=inb(il) .AND. lwork(il)) THEN - wdtrain(il) = grav*(wdtrainS(il,i) + wdtrainM(il,i) + wdtrainA(il,i)) - END IF - END DO - ENDIF ! ( i > 1) - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -! *** find rain water and evaporation using provisional *** -! *** estimates of rp(i)and rp(i-1) *** - - - IF (cvflag_ice) THEN !!jygprl - IF (cvflag_prec_eject) THEN - DO il = 1, ncum !!jygprl - IF (i<=inb(il) .AND. lwork(il)) THEN !!jygprl - frac(il, i) = (frac_a(il,i)*wdtrainA(il,i)+frac_s(il,i)*(wdtrainS(il,i)+wdtrainM(il,i))) / & !!jygprl - max(wdtrainA(il,i)+wdtrainS(il,i)+wdtrainM(il,i),smallestreal) !!jygprl - fraci(il, i) = frac(il, i) !!jygprl - END IF !!jygprl - END DO !!jygprl - ELSE ! (cvflag_prec_eject) - DO il = 1, ncum !!jygprl - IF (i<=inb(il) .AND. lwork(il)) THEN !!jygprl -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - IF (keepbug_ice_frac) THEN - frac(il, i) = frac_s(il, i) -! Ice fraction computed again here as a function of the temperature seen by unsaturated downdraughts -! (i.e. the cold pool temperature) for compatibility with earlier versions. - fraci(il, i) = 1. - (t(il,i)-243.15)/(263.15-243.15) - fraci(il, i) = min(max(fraci(il,i),0.0), 1.0) -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ELSE ! (keepbug_ice_frac) -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - frac(il, i) = frac_s(il, i) - fraci(il, i) = frac(il, i) !!jygprl - ENDIF ! (keepbug_ice_frac) -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - END IF !!jygprl - END DO !!jygprl - ENDIF ! (cvflag_prec_eject) - END IF !!jygprl - - - DO il = 1, ncum - IF (i<=inb(il) .AND. lwork(il)) THEN - - wt(il, i) = 45.0 - - IF (i= 20) THEN - Print*, 'cv3_unsat after provisional rp estimate: rp, afac, bfac ', & - i, rp(1, i), afac,bfac - ENDIF -! -!JYG1 -! cc sigt=1.0 -! cc if(i.ge.icb)sigt=sigp(i) -! prise en compte de la variation progressive de sigt dans -! les couches icb et icb-1: -! pour plclph(i), pr1=1 & pr2=0 -! pour ph(i+1)b6*b6+1.E-20) THEN - revap = 2.*c6/(b6+sqrt(b6*b6+4.*c6)) - ELSE - revap = (-b6+sqrt(b6*b6+4.*c6))/2. - END IF - prec(il, i) = max(0., 2.*revap*revap-prec(il,i+1)) -! print*,prec(il,i),'neige' - -!JYG Dans sa formulation originale, Emanuel calcule l'evaporation par: -! c evap(il,i)=sigt*afac*revap -! ce qui n'est pas correct. Dans cv_routines, la formulation a �t� modifiee. -! Ici,l'evaporation evap est simplement calculee par l'equation de -! conservation. -! prec(il,i)=revap*revap -! else -!JYG---- Correction : si c6 <= 0, water(il,i)=0. -! prec(il,i)=0. -! endif - -!JYG--- Dans tous les cas, evaporation = [tt ce qui entre dans la couche i] -! moins [tt ce qui sort de la couche i] -! print *, 'evap avec ice' - evap(il, i) = (wdtrain(il)+sigd(il)*wt(il,i)*(prec(il,i+1)-prec(il,i))) / & - (sigd(il)*(ph(il,i)-ph(il,i+1))*100.) -! - IF (prt_level >= 20) THEN - Print*, 'cv3_unsat after evap computation: wdtrain, sigd, wt, prec(i+1),prec(i) ', & - i, wdtrain(1), sigd(1), wt(1,i), prec(1,i+1),prec(1,i) - ENDIF -! - -!jyg< - d6 = prec(il,i)-prec(il,i+1) - -!! d6 = bfac*wdtrain(il) - 100.*sigd(il)*bfac*(ph(il,i)-ph(il,i+1))*evap(il, i) -!! e6 = bfac*wdtrain(il) -!! f6 = -100.*sigd(il)*bfac*(ph(il,i)-ph(il,i+1))*evap(il, i) -!>jyg -!CR:tmax_fonte_cv: T for which ice is totally melted (used to be 275.15) - thaw = (t(il,i)-273.15)/(tmax_fonte_cv-273.15) - thaw = min(max(thaw,0.0), 1.0) -!jyg< - water(il, i) = water(il, i+1) + (1-fraci(il,i))*d6 - ice(il, i) = ice(il, i+1) + fraci(il, i)*d6 - water(il, i) = min(prec(il,i), max(water(il,i), 0.)) - ice(il, i) = min(prec(il,i), max(ice(il,i), 0.)) - -!! water(il, i) = water(il, i+1) + (1-fraci(il,i))*d6 -!! water(il, i) = max(water(il,i), 0.) -!! ice(il, i) = ice(il, i+1) + fraci(il, i)*d6 -!! ice(il, i) = max(ice(il,i), 0.) -!>jyg - fondue(il, i) = ice(il, i)*thaw - water(il, i) = water(il, i) + fondue(il, i) - ice(il, i) = ice(il, i) - fondue(il, i) - -!! IF (water(il,i)+ice(il,i)<1.E-30) THEN -!! faci(il, i) = 0. -!! ELSE -!! faci(il, i) = ice(il, i)/(water(il,i)+ice(il,i)) -!! END IF - - faci(il,i) = ice(il, i)/max((water(il,i)+ice(il,i)), smallestreal) - -! water(il,i)=water(il,i+1)+(1.-fraci(il,i))*e6+(1.-faci(il,i))*f6 -! water(il,i)=max(water(il,i),0.) -! ice(il,i)=ice(il,i+1)+fraci(il,i)*e6+faci(il,i)*f6 -! ice(il,i)=max(ice(il,i),0.) -! fondue(il,i)=ice(il,i)*thaw -! water(il,i)=water(il,i)+fondue(il,i) -! ice(il,i)=ice(il,i)-fondue(il,i) - -! if((water(il,i)+ice(il,i)).lt.1.e-30)then -! faci(il,i)=0. -! else -! faci(il,i)=ice(il,i)/(water(il,i)+ice(il,i)) -! endif - - ELSE - b6 = bfac*50.*sigd(il)*(ph(il,i)-ph(il,i+1))*sigt*afac - c6 = water(il, i+1) + bfac*wdtrain(il) - & - 50.*sigd(il)*bfac*(ph(il,i)-ph(il,i+1))*evap(il, i+1) - IF (c6>0.0) THEN - revap = 0.5*(-b6+sqrt(b6*b6+4.*c6)) - water(il, i) = revap*revap - ELSE - water(il, i) = 0. - END IF -! print *, 'evap sans ice' - evap(il, i) = (wdtrain(il)+sigd(il)*wt(il,i)*(water(il,i+1)-water(il,i)))/ & - (sigd(il)*(ph(il,i)-ph(il,i+1))*100.) - - END IF - END IF !(i.le.inb(il) .and. lwork(il)) - END DO -! ---------------------------------------------------------------- - -! cc -! *** calculate precipitating downdraft mass flux under *** -! *** hydrostatic approximation *** - - DO il = 1, ncum - IF (i<=inb(il) .AND. lwork(il) .AND. i/=1) THEN - - tevap(il) = max(0.0, evap(il,i)) - delth = max(0.001, (th(il,i)-th(il,i-1))) - IF (cvflag_ice) THEN - IF (cvflag_grav) THEN - mp(il, i) = 100.*ginv*(lvcp(il,i)*sigd(il)*tevap(il)* & - (p(il,i-1)-p(il,i))/delth + & - lfcp(il,i)*sigd(il)*faci(il,i)*tevap(il)* & - (p(il,i-1)-p(il,i))/delth + & - lfcp(il,i)*sigd(il)*wt(il,i)/100.*fondue(il,i)* & - (p(il,i-1)-p(il,i))/delth/(ph(il,i)-ph(il,i+1))) - ELSE - mp(il, i) = 10.*(lvcp(il,i)*sigd(il)*tevap(il)* & - (p(il,i-1)-p(il,i))/delth + & - lfcp(il,i)*sigd(il)*faci(il,i)*tevap(il)* & - (p(il,i-1)-p(il,i))/delth + & - lfcp(il,i)*sigd(il)*wt(il,i)/100.*fondue(il,i)* & - (p(il,i-1)-p(il,i))/delth/(ph(il,i)-ph(il,i+1))) - - END IF - ELSE - IF (cvflag_grav) THEN - mp(il, i) = 100.*ginv*lvcp(il, i)*sigd(il)*tevap(il)* & - (p(il,i-1)-p(il,i))/delth - ELSE - mp(il, i) = 10.*lvcp(il, i)*sigd(il)*tevap(il)* & - (p(il,i-1)-p(il,i))/delth - END IF - - END IF - - END IF !(i.le.inb(il) .and. lwork(il) .and. i.ne.1) - IF (prt_level .GE. 20) THEN - PRINT *,'cv3_unsat, mp hydrostatic ', i, mp(il,i) - ENDIF - END DO -! ---------------------------------------------------------------- - -! *** if hydrostatic assumption fails, *** -! *** solve cubic difference equation for downdraft theta *** -! *** and mass flux from two simultaneous differential eqns *** - - DO il = 1, ncum - IF (i<=inb(il) .AND. lwork(il) .AND. i/=1) THEN - - amfac = sigd(il)*sigd(il)*70.0*ph(il, i)*(p(il,i-1)-p(il,i))* & - (th(il,i)-th(il,i-1))/(tv(il,i)*th(il,i)) - amp2 = abs(mp(il,i+1)*mp(il,i+1)-mp(il,i)*mp(il,i)) - - IF (amp2>(0.1*amfac)) THEN - xf = 100.0*sigd(il)*sigd(il)*sigd(il)*(ph(il,i)-ph(il,i+1)) - tf = b(il, i) - 5.0*(th(il,i)-th(il,i-1))*t(il, i) / & - (lvcp(il,i)*sigd(il)*th(il,i)) - af = xf*tf + mp(il, i+1)*mp(il, i+1)*tinv - - IF (cvflag_ice) THEN - bf = 2.*(tinv*mp(il,i+1))**3 + tinv*mp(il, i+1)*xf*tf + & - 50.*(p(il,i-1)-p(il,i))*xf*(tevap(il)*(1.+(lf(il,i)/lv(il,i))*faci(il,i)) + & - (lf(il,i)/lv(il,i))*wt(il,i)/100.*fondue(il,i)/(ph(il,i)-ph(il,i+1))) - ELSE - - bf = 2.*(tinv*mp(il,i+1))**3 + tinv*mp(il, i+1)*xf*tf + & - 50.*(p(il,i-1)-p(il,i))*xf*tevap(il) - END IF - - fac2 = 1.0 - IF (bf<0.0) fac2 = -1.0 - bf = abs(bf) - ur = 0.25*bf*bf - af*af*af*tinv*tinv*tinv - IF (ur>=0.0) THEN - sru = sqrt(ur) - fac = 1.0 - IF ((0.5*bf-sru)<0.0) fac = -1.0 - mp(il, i) = mp(il, i+1)*tinv + (0.5*bf+sru)**tinv + & - fac*(abs(0.5*bf-sru))**tinv - ELSE - d = atan(2.*sqrt(-ur)/(bf+1.0E-28)) - IF (fac2<0.0) d = 3.14159 - d - mp(il, i) = mp(il, i+1)*tinv + 2.*sqrt(af*tinv)*cos(d*tinv) - END IF - mp(il, i) = max(0.0, mp(il,i)) - IF (prt_level .GE. 20) THEN - PRINT *,'cv3_unsat, mp cubic ', i, mp(il,i) - ENDIF - - IF (cvflag_ice) THEN - IF (cvflag_grav) THEN -!JYG : il y a vraisemblablement une erreur dans la ligne 2 suivante: -! il faut diviser par (mp(il,i)*sigd(il)*grav) et non par (mp(il,i)+sigd(il)*0.1). -! Et il faut bien revoir les facteurs 100. - b(il, i-1) = b(il, i) + 100.0*(p(il,i-1)-p(il,i))* & - (tevap(il)*(1.+(lf(il,i)/lv(il,i))*faci(il,i)) + & - (lf(il,i)/lv(il,i))*wt(il,i)/100.*fondue(il,i) / & - (ph(il,i)-ph(il,i+1))) / & - (mp(il,i)+sigd(il)*0.1) - & - 10.0*(th(il,i)-th(il,i-1))*t(il, i) / & - (lvcp(il,i)*sigd(il)*th(il,i)) - ELSE - b(il, i-1) = b(il, i) + 100.0*(p(il,i-1)-p(il,i))*& - (tevap(il)*(1.+(lf(il,i)/lv(il,i))*faci(il,i)) + & - (lf(il,i)/lv(il,i))*wt(il,i)/100.*fondue(il,i) / & - (ph(il,i)-ph(il,i+1))) / & - (mp(il,i)+sigd(il)*0.1) - & - 10.0*(th(il,i)-th(il,i-1))*t(il, i) / & - (lvcp(il,i)*sigd(il)*th(il,i)) - END IF - ELSE - IF (cvflag_grav) THEN - b(il, i-1) = b(il, i) + 100.0*(p(il,i-1)-p(il,i))*tevap(il) / & - (mp(il,i)+sigd(il)*0.1) - & - 10.0*(th(il,i)-th(il,i-1))*t(il, i) / & - (lvcp(il,i)*sigd(il)*th(il,i)) - ELSE - b(il, i-1) = b(il, i) + 100.0*(p(il,i-1)-p(il,i))*tevap(il) / & - (mp(il,i)+sigd(il)*0.1) - & - 10.0*(th(il,i)-th(il,i-1))*t(il, i) / & - (lvcp(il,i)*sigd(il)*th(il,i)) - END IF - END IF - b(il, i-1) = max(b(il,i-1), 0.0) - - END IF !(amp2.gt.(0.1*amfac)) - -!jyg< This part shifted 10 lines farther -!!! *** limit magnitude of mp(i) to meet cfl condition *** -!! -!! ampmax = 2.0*(ph(il,i)-ph(il,i+1))*delti -!! amp2 = 2.0*(ph(il,i-1)-ph(il,i))*delti -!! ampmax = min(ampmax, amp2) -!! mp(il, i) = min(mp(il,i), ampmax) -!>jyg - -! *** force mp to decrease linearly to zero *** -! *** between cloud base and the surface *** - - -! c if(p(il,i).gt.p(il,icb(il)))then -! c mp(il,i)=mp(il,icb(il))*(p(il,1)-p(il,i))/(p(il,1)-p(il,icb(il))) -! c endif - IF (ph(il,i)>0.9*plcl(il)) THEN - mp(il, i) = mp(il, i)*(ph(il,1)-ph(il,i))/(ph(il,1)-0.9*plcl(il)) - END IF - -!jyg< Shifted part -! *** limit magnitude of mp(i) to meet cfl condition *** - - ampmax = 2.0*(ph(il,i)-ph(il,i+1))*delti - amp2 = 2.0*(ph(il,i-1)-ph(il,i))*delti - ampmax = min(ampmax, amp2) - mp(il, i) = min(mp(il,i), ampmax) -!>jyg - - END IF ! (i.le.inb(il) .and. lwork(il) .and. i.ne.1) - END DO -! ---------------------------------------------------------------- -! - IF (prt_level >= 20) THEN - Print*, 'cv3_unsat after mp computation: mp, b(i), b(i-1) ', & - i, mp(1, i), b(1,i), b(1,max(i-1,1)) - ENDIF -! - -! *** find mixing ratio of precipitating downdraft *** - - DO il = 1, ncum - IF (i mp(il, i+1) - END IF ! (i.lt.inb(il) .and. lwork(il)) - END DO - - DO il = 1, ncum - IF (i1.0E-16) THEN - IF (cvflag_grav) THEN - rp(il, i) = rp(il,i+1) + 100.*ginv*0.5*sigd(il)*(ph(il,i)-ph(il,i+1)) * & - (evap(il,i+1)+evap(il,i))/mp(il,i+1) - ELSE - rp(il, i) = rp(il,i+1) + 5.*sigd(il)*(ph(il,i)-ph(il,i+1)) * & - (evap(il,i+1)+evap(il,i))/mp(il, i+1) - END IF - up(il, i) = up(il, i+1) - vp(il, i) = vp(il, i+1) - END IF ! (mp(il,i+1).gt.1.0e-16) - END IF ! (mplus(il)) else if (.not.mplus(il)) - - rp(il, i) = amin1(rp(il,i), rs(il,i)) - rp(il, i) = max(rp(il,i), 0.0) - - END IF ! (i.lt.inb(il) .and. lwork(il)) - END DO -! ---------------------------------------------------------------- - -! *** find tracer concentrations in precipitating downdraft *** - -400 END DO -! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - -! *** end of downdraft loop *** - -! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - RETURN - -END SUBROUTINE cv3_unsat - -!!SUBROUTINE cv3_yield(nloc, ncum, nd, na, ntra, ok_conserv_q, & !jyg: get rid of ntra -SUBROUTINE cv3_yield(nloc, ncum, nd, na, ok_conserv_q, & - icb, inb, delt, & -!! t, rr, t_wake, rr_wake, s_wake, u, v, tra, & !jyg: get rid of ntra - t, rr, t_wake, rr_wake, s_wake, u, v, & - gz, p, ph, h, hp, lv, lf, cpn, th, th_wake, & -!! ep, clw, qpreca, m, tp, mp, rp, up, vp, trap, & !jyg: get rid of ntra - ep, clw, qpreca, m, tp, mp, rp, up, vp, & - wt, water, ice, evap, fondue, faci, b, sigd, & - ment, qent, hent, iflag_mix, uent, vent, & -!! nent, elij, traent, sig, & !jyg: get rid of ntra - nent, elij, sig, & - tv, tvp, wghti, & - iflag, precip, Vprecip, Vprecipi, & ! jyg: Vprecipi -!! ft, fr, fr_comp, fu, fv, ftra, & ! jyg !jyg: get rid of ntra - ft, fr, fr_comp, fu, fv, & ! jyg - cbmf, upwd, dnwd, dnwd0, ma, mip, & -!! tls, tps, ! useless . jyg - qcondc, wd, & - ftd, fqd, qta, qtc, sigt, detrain, tau_cld_cv, coefw_cld_cv) - - USE conema3_mod_h - USE print_control_mod, ONLY: lunout, prt_level - USE add_phys_tend_mod, only : fl_cor_ebil - USE cvflag_mod_h - USE lmdz_cv_ini, ONLY : grav,minorig,nl,nlp,rowl,rrd,nl,ci,cl,cpd,cpv - USE lmdz_cv_ini, ONLY : restore_bug_cvdn - - IMPLICIT NONE - - -!inputs: - INTEGER, INTENT (IN) :: iflag_mix -!! INTEGER, INTENT (IN) :: ncum, nd, na, ntra, nloc !jyg: get rid of ntra - INTEGER, INTENT (IN) :: ncum, nd, na, nloc - LOGICAL, INTENT (IN) :: ok_conserv_q - INTEGER, DIMENSION (nloc), INTENT (IN) :: icb, inb - REAL, INTENT (IN) :: delt - REAL, DIMENSION (nloc, nd), INTENT (IN) :: t, rr, u, v - REAL, DIMENSION (nloc, nd), INTENT (IN) :: t_wake, rr_wake - REAL, DIMENSION (nloc), INTENT (IN) :: s_wake -!! REAL, DIMENSION (nloc, nd, ntra), INTENT (IN) :: tra !jyg: get rid of ntra - REAL, DIMENSION (nloc, nd), INTENT (IN) :: p - REAL, DIMENSION (nloc, nd+1), INTENT (IN) :: ph - REAL, DIMENSION (nloc, na), INTENT (IN) :: gz, h, hp - REAL, DIMENSION (nloc, na), INTENT (IN) :: th, tp - REAL, DIMENSION (nloc, na), INTENT (IN) :: lv, cpn, ep, clw - REAL, DIMENSION (nloc, na), INTENT (IN) :: lf - REAL, DIMENSION (nloc, na), INTENT (IN) :: rp, up - REAL, DIMENSION (nloc, na), INTENT (IN) :: vp - REAL, DIMENSION (nloc, nd), INTENT (IN) :: wt -!! REAL, DIMENSION (nloc, nd, ntra), INTENT (IN) :: trap !jyg: get rid of ntra - REAL, DIMENSION (nloc, na), INTENT (IN) :: water, evap, b - REAL, DIMENSION (nloc, na), INTENT (IN) :: fondue, faci, ice - REAL, DIMENSION (nloc, na, na), INTENT (IN) :: qent, uent - REAL, DIMENSION (nloc, na, na), INTENT (IN) :: hent - REAL, DIMENSION (nloc, na, na), INTENT (IN) :: vent, elij - INTEGER, DIMENSION (nloc, nd), INTENT (IN) :: nent -!! REAL, DIMENSION (nloc, na, na, ntra), INTENT (IN) :: traent !jyg: get rid of ntra - REAL, DIMENSION (nloc, nd), INTENT (IN) :: tv, tvp, wghti - REAL, DIMENSION (nloc, nd), INTENT (IN) :: qta - REAL, DIMENSION (nloc, na),INTENT(IN) :: qpreca - REAL, INTENT(IN) :: tau_cld_cv, coefw_cld_cv -! -!input/output: - REAL, DIMENSION (nloc, na), INTENT (INOUT) :: m, mp - REAL, DIMENSION (nloc, na, na), INTENT (INOUT) :: ment - INTEGER, DIMENSION (nloc), INTENT (INOUT) :: iflag - REAL, DIMENSION (nloc, nd), INTENT (INOUT) :: sig - REAL, DIMENSION (nloc), INTENT (INOUT) :: sigd -! -!outputs: - REAL, DIMENSION (nloc), INTENT (OUT) :: precip - REAL, DIMENSION (nloc, nd), INTENT (OUT) :: ft, fr, fu, fv , fr_comp - REAL, DIMENSION (nloc, nd), INTENT (OUT) :: ftd, fqd -!! REAL, DIMENSION (nloc, nd, ntra), INTENT (OUT) :: ftra !jyg: get rid of ntra - REAL, DIMENSION (nloc, nd), INTENT (OUT) :: upwd, dnwd, ma - REAL, DIMENSION (nloc, nd), INTENT (OUT) :: dnwd0, mip - REAL, DIMENSION (nloc, nd+1), INTENT (OUT) :: Vprecip - REAL, DIMENSION (nloc, nd+1), INTENT (OUT) :: Vprecipi -!! REAL tls(nloc, nd), tps(nloc, nd) ! useless . jyg - REAL, DIMENSION (nloc, nd), INTENT (OUT) :: qcondc ! cld - REAL, DIMENSION (nloc, nd), INTENT (OUT) :: qtc, sigt ! cld - REAL, DIMENSION (nloc, nd), INTENT (OUT) :: detrain ! Louis : pour le calcul de Klein du terme de variance qui detraine dans lenvironnement - REAL, DIMENSION (nloc), INTENT (OUT) :: wd ! gust - REAL, DIMENSION (nloc), INTENT (OUT) :: cbmf -! -!local variables: - INTEGER :: i, k, il, n, j, num1 - REAL :: rat, delti - REAL :: ax, bx, cx, dx, ex - REAL :: cpinv, rdcp, dpinv - REAL :: sigaq - REAL, DIMENSION (nloc) :: awat - REAL, DIMENSION (nloc, nd) :: lvcp, lfcp ! , mke ! unused . jyg - REAL, DIMENSION (nloc) :: am, work, ad, amp1 -!! real up1(nloc), dn1(nloc) - REAL, DIMENSION (nloc, nd, nd) :: up1, dn1 -!jyg< - REAL, DIMENSION (nloc, nd) :: up_to, up_from - REAL, DIMENSION (nloc, nd) :: dn_to, dn_from -!>jyg - REAL, DIMENSION (nloc) :: asum, bsum, csum, dsum - REAL, DIMENSION (nloc) :: esum, fsum, gsum, hsum - REAL, DIMENSION (nloc, nd) :: th_wake - REAL, DIMENSION (nloc) :: alpha_qpos, alpha_qpos1 - REAL, DIMENSION (nloc, nd) :: qcond, nqcond, wa ! cld - REAL, DIMENSION (nloc, nd) :: siga, sax, mac ! cld - REAL, DIMENSION (nloc) :: sument - REAL, DIMENSION (nloc, nd) :: sigment, qtment ! cld - REAL, DIMENSION (nloc, nd, nd) :: qdet -!! REAL sumdq !jyg -! -! ------------------------------------------------------------- - - -! initialization: - - delti = 1.0/delt -! print*,'cv3_yield initialisation delt', delt - - DO il = 1, ncum - precip(il) = 0.0 - wd(il) = 0.0 ! gust - END DO - -! Fluxes are on a staggered grid : loops extend up to nl+1 - DO i = 1, nlp - DO il = 1, ncum - Vprecip(il, i) = 0.0 - Vprecipi(il, i) = 0.0 ! jyg - upwd(il, i) = 0.0 - dnwd(il, i) = 0.0 - dnwd0(il, i) = 0.0 - mip(il, i) = 0.0 - END DO - END DO - DO i = 1, nl - DO il = 1, ncum - ft(il, i) = 0.0 - fr(il, i) = 0.0 - fr_comp(il,i) = 0.0 - fu(il, i) = 0.0 - fv(il, i) = 0.0 - ftd(il, i) = 0.0 - fqd(il, i) = 0.0 - qcondc(il, i) = 0.0 ! cld - qcond(il, i) = 0.0 ! cld - qtc(il, i) = 0.0 ! cld - qtment(il, i) = 0.0 ! cld - sigment(il, i) = 0.0 ! cld - sigt(il, i) = 0.0 ! cld - qdet(il,i,:) = 0.0 ! cld - detrain(il, i) = 0.0 ! cld - nqcond(il, i) = 0.0 ! cld - END DO - END DO -! print*,'cv3_yield initialisation 2' -! print*,'cv3_yield initialisation 3' - DO i = 1, nl - DO il = 1, ncum - lvcp(il, i) = lv(il, i)/cpn(il, i) - lfcp(il, i) = lf(il, i)/cpn(il, i) - END DO - END DO - - - -! *** calculate surface precipitation in mm/day *** - - DO il = 1, ncum - IF (ep(il,inb(il))>=0.0001 .AND. iflag(il)<=1) THEN - IF (cvflag_ice) THEN - precip(il) = wt(il, 1)*sigd(il)*(water(il,1)+ice(il,1)) & - *86400.*1000./(rowl*grav) - ELSE - precip(il) = wt(il, 1)*sigd(il)*water(il, 1) & - *86400.*1000./(rowl*grav) - END IF - END IF - END DO -! print*,'cv3_yield apres calcul precip' - - -! === calculate vertical profile of precipitation in kg/m2/s === - - DO i = 1, nl - DO il = 1, ncum - IF (ep(il,inb(il))>=0.0001 .AND. i<=inb(il) .AND. iflag(il)<=1) THEN - IF (cvflag_ice) THEN - Vprecip(il, i) = wt(il, i)*sigd(il)*(water(il,i)+ice(il,i))/grav - Vprecipi(il, i) = wt(il, i)*sigd(il)*ice(il,i)/grav ! jyg - ELSE - Vprecip(il, i) = wt(il, i)*sigd(il)*water(il, i)/grav - Vprecipi(il, i) = 0. ! jyg - END IF - END IF - END DO - END DO - - -! *** Calculate downdraft velocity scale *** -! *** NE PAS UTILISER POUR L'INSTANT *** - -!! do il=1,ncum -!! wd(il)=betad*abs(mp(il,icb(il)))*0.01*rrd*t(il,icb(il)) & -!! /(sigd(il)*p(il,icb(il))) -!! enddo - - -! *** calculate tendencies of lowest level potential temperature *** -! *** and mixing ratio *** - - DO il = 1, ncum - work(il) = 1.0/(ph(il,1)-ph(il,2)) - cbmf(il) = 0.0 - END DO - -! - Adiabatic ascent mass flux "ma" and cloud base mass flux "cbmf" -!----------------------------------------------------------------- -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - IF (adiab_ascent_mass_flux_depends_on_ejectliq) THEN -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!! Warning : this option leads to water conservation violation -!!! Expert only -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - DO il = 1, ncum - ma(il, nlp) = 0. - ma(il, 1) = 0. - END DO - DO k = nl, 2, -1 - DO il = 1, ncum - ma(il, k) = ma(il, k+1)*(1.-qta(il, k))/(1.-qta(il, k-1)) + m(il, k) - cbmf(il) = max(cbmf(il), ma(il,k)) - END DO - END DO - DO k = 2,nl - DO il = 1, ncum - IF (k =icb(il)) THEN - cbmf(il) = cbmf(il) + m(il, k) - END IF - END DO - END DO - - DO il = 1, ncum - ma(il, nlp) = 0. - ma(il, 1) = 0. - END DO - DO k = nl, 2, -1 - DO il = 1, ncum - ma(il, k) = ma(il, k+1) + m(il, k) - END DO - END DO - DO k = 2,nl - DO il = 1, ncum - IF (k =delti) iflag(il) = 1 !consist vect -!jyg< - IF (fl_cor_ebil >= 2) THEN - ft(il, 1) = ft(il, 1) + 0.01*grav*work(il)*am(il) * & - ((t(il,2)-t(il,1))*cpn(il,2)+gz(il,2)-gz(il,1))/cpn(il,1) - ELSE - ft(il, 1) = ft(il, 1) + 0.01*grav*work(il)*am(il) * & - (t(il,2)-t(il,1)+(gz(il,2)-gz(il,1))/cpn(il,1)) - ENDIF -!>jyg - END IF ! iflag - END DO - - - DO j = 2, nl - IF (iflag_mix>0) THEN - DO il = 1, ncum -! FH WARNING a modifier : - cpinv = 0. -! cpinv=1.0/cpn(il,1) - IF (j<=inb(il) .AND. iflag(il)<=1) THEN - ft(il, 1) = ft(il, 1) + 0.01*grav*work(il)*ment(il, j, 1) * & - (hent(il,j,1)-h(il,1)+t(il,1)*(cpv-cpd)*(rr(il,1)-qent(il,j,1)))*cpinv - END IF ! j - END DO - END IF - END DO -! fin sature - - - DO il = 1, ncum - IF (iflag(il)<=1) THEN -!JYG1 Correction pour mieux conserver l'eau (conformite avec CONVECT4.3) - fr(il, 1) = 0.01*grav*mp(il, 2)*(rp(il,2)-rr_wake(il,1))*work(il) + & - sigd(il)*evap(il, 1) -!!! sigd(il)*0.5*(evap(il,1)+evap(il,2)) - - fqd(il, 1) = fr(il, 1) !precip - - fr(il, 1) = fr(il, 1) + 0.01*grav*am(il)*(rr(il,2)-rr(il,1))*work(il) !sature - - fu(il, 1) = fu(il, 1) + 0.01*grav*work(il)*(mp(il,2)*(up(il,2)-u(il,1)) + & - am(il)*(u(il,2)-u(il,1))) - fv(il, 1) = fv(il, 1) + 0.01*grav*work(il)*(mp(il,2)*(vp(il,2)-v(il,1)) + & - am(il)*(v(il,2)-v(il,1))) - END IF ! iflag - END DO ! il - - - DO j = 2, nl - DO il = 1, ncum - IF (j<=inb(il) .AND. iflag(il)<=1) THEN - fr(il, 1) = fr(il, 1) + 0.01*grav*work(il)*ment(il, j, 1)*(qent(il,j,1)-rr(il,1)) - fr_comp(il,1) = fr_comp(il,1) + 0.01*grav*work(il)*ment(il, j, 1)*(qent(il,j,1)-rr(il,1)) - fu(il, 1) = fu(il, 1) + 0.01*grav*work(il)*ment(il, j, 1)*(uent(il,j,1)-u(il,1)) - fv(il, 1) = fv(il, 1) + 0.01*grav*work(il)*ment(il, j, 1)*(vent(il,j,1)-v(il,1)) - END IF ! j - END DO - END DO - -! print*,'cv3_yield apres ft' - -!jyg< -!----------------------------------------------------------- - IF (ok_optim_yield) THEN !| -!----------------------------------------------------------- -! -!*** *** -!*** Compute convective mass fluxes upwd and dnwd *** - -! -! ================================================= -! upward fluxes | -! ------------------------------------------------ -! -upwd(:,:) = 0. -up_to(:,:) = 0. -up_from(:,:) = 0. -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - IF (adiab_ascent_mass_flux_depends_on_ejectliq) THEN -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!! The decrease of the adiabatic ascent mass flux due to ejection of precipitation -!! is taken into account. -!! WARNING : in the present version, taking into account the mass-flux decrease due to -!! precipitation ejection leads to water conservation violation. -! -! - Upward mass flux of mixed draughts -!--------------------------------------- -DO i = 2, nl - DO j = 1, i-1 - DO il = 1, ncum - IF (i<=inb(il)) THEN - up_to(il,i) = up_to(il,i) + ment(il,j,i) - ENDIF - ENDDO - ENDDO -ENDDO -! -DO j = 3, nl - DO i = 2, j-1 - DO il = 1, ncum - IF (j<=inb(il)) THEN - up_from(il,i) = up_from(il,i) + ment(il,i,j) - ENDIF - ENDDO - ENDDO -ENDDO -! -! The difference between upwd(il,i) and upwd(il,i-1) is due to updrafts ending in layer -!(i-1) (theses drafts cross interface (i-1) but not interface(i)) and to updrafts starting -!from layer (i-1) (theses drafts cross interface (i) but not interface(i-1)): -! -DO i = 2, nlp - DO il = 1, ncum - IF (i<=inb(il)+1) THEN - upwd(il,i) = max(0., upwd(il,i-1) - up_to(il,i-1) + up_from(il,i-1)) - ENDIF - ENDDO -ENDDO -! -! - Total upward mass flux -!--------------------------- -DO i = 2, nlp - DO il = 1, ncum - IF (i<=inb(il)+1) THEN - upwd(il,i) = upwd(il,i) + ma(il,i) - ENDIF - ENDDO -ENDDO -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ELSE ! (adiab_ascent_mass_flux_depends_on_ejectliq) -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!! The decrease of the adiabatic ascent mass flux due to ejection of precipitation -!! is not taken into account. -! -! - Upward mass flux -!------------------- -DO i = 2, nl - DO il = 1, ncum - IF (i<=inb(il)) THEN - up_to(il,i) = m(il,i) - ENDIF - ENDDO - DO j = 1, i-1 - DO il = 1, ncum - IF (i<=inb(il)) THEN - up_to(il,i) = up_to(il,i) + ment(il,j,i) - ENDIF - ENDDO - ENDDO -ENDDO -! -DO i = 1, nl - DO il = 1, ncum - IF (i<=inb(il)) THEN - up_from(il,i) = cbmf(il)*wghti(il,i) - ENDIF - ENDDO -ENDDO -! -DO j = 3, nl - DO i = 2, j-1 - DO il = 1, ncum - IF (j<=inb(il)) THEN - up_from(il,i) = up_from(il,i) + ment(il,i,j) - ENDIF - ENDDO - ENDDO -ENDDO -! -! The difference between upwd(il,i) and upwd(il,i-1) is due to updrafts ending in layer -!(i-1) (theses drafts cross interface (i-1) but not interface(i)) and to updrafts starting -!from layer (i-1) (theses drafts cross interface (i) but not interface(i-1)): -! -DO i = 2, nlp - DO il = 1, ncum - IF (i<=inb(il)+1) THEN - upwd(il,i) = max(0., upwd(il,i-1) - up_to(il,i-1) + up_from(il,i-1)) - ENDIF - ENDDO -ENDDO - - - ENDIF ! (adiab_ascent_mass_flux_depends_on_ejectliq) ELSE -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -! -! ================================================= -! downward fluxes | -! ------------------------------------------------ -dnwd(:,:) = 0. -dn_to(:,:) = 0. -dn_from(:,:) = 0. -DO i = 1, nl - DO j = i+1, nl - DO il = 1, ncum - IF (j<=inb(il)) THEN -!! dn_to(il,i) = dn_to(il,i) + ment(il,j,i) !jyg,20220202 - dn_to(il,i) = dn_to(il,i) - ment(il,j,i) - ENDIF - ENDDO - ENDDO -ENDDO -! -DO j = 1, nl - DO i = j+1, nl - DO il = 1, ncum - IF (i<=inb(il)) THEN -!! dn_from(il,i) = dn_from(il,i) + ment(il,i,j) !jyg,20220202 - dn_from(il,i) = dn_from(il,i) - ment(il,i,j) - ENDIF - ENDDO - ENDDO -ENDDO -! -! The difference between dnwd(il,i) and dnwd(il,i+1) is due to downdrafts ending in layer -!(i) (theses drafts cross interface (i+1) but not interface(i)) and to downdrafts -!starting from layer (i) (theses drafts cross interface (i) but not interface(i+1)): -! -DO i = nl-1, 1, -1 - DO il = 1, ncum -!! dnwd(il,i) = max(0., dnwd(il,i+1) - dn_to(il,i) + dn_from(il,i)) !jyg,20220202 - dnwd(il,i) = min(0., dnwd(il,i+1) - dn_to(il,i) + dn_from(il,i)) - ENDDO -ENDDO -! ================================================= -! -!----------------------------------------------------------- - ENDIF !(ok_optim_yield) !| -!----------------------------------------------------------- -!>jyg - -! *** calculate tendencies of potential temperature and mixing ratio *** -! *** at levels above the lowest level *** - -! *** first find the net saturated updraft and downdraft mass fluxes *** -! *** through each level *** - -!jyg< -!! DO i = 2, nl + 1 ! newvecto: mettre nl au lieu nl+1? - DO i = 2, nl -!>jyg - - num1 = 0 - DO il = 1, ncum - IF (i<=inb(il) .AND. iflag(il)<=1) num1 = num1 + 1 - END DO -!ym IF (num1<=0) GO TO 500 - IF (num1<=0) CYCLE - -! -!jyg< -!----------------------------------------------------------- - IF (ok_optim_yield) THEN !| -!----------------------------------------------------------- - - ! Restoring a bug that was found and corrected in svn release - ! 5544; which appears to have a much stronger impact than initially - ! thought - - if ( restore_bug_cvdn ) then - DO il = 1, ncum - amp1(il) = upwd(il,i+1) - ad(il) = dnwd(il,i) - ENDDO - else - DO il = 1, ncum - amp1(il) = upwd(il,i+1) - ad(il) = - dnwd(il,i) - ENDDO - endif -!----------------------------------------------------------- - ELSE !(ok_optim_yield) !| -!----------------------------------------------------------- -!>jyg - DO il = 1,ncum - amp1(il) = 0. - ad(il) = 0. - ENDDO - - DO k = 1, nl + 1 - DO il = 1, ncum - IF (i>=icb(il)) THEN - IF (k>=i+1 .AND. k<=(inb(il)+1)) THEN - amp1(il) = amp1(il) + m(il, k) - END IF - ELSE -! AMP1 is the part of cbmf taken from layers I and lower - IF (k<=i) THEN - amp1(il) = amp1(il) + cbmf(il)*wghti(il, k) - END IF - END IF - END DO - END DO - - DO j = i + 1, nl + 1 - DO k = 1, i - !yor! reverted j and k loops - DO il = 1, ncum -!yor! IF (i<=inb(il) .AND. j<=(inb(il)+1)) THEN ! the second condition implies the first ! - IF (j<=(inb(il)+1)) THEN - amp1(il) = amp1(il) + ment(il, k, j) - END IF - END DO - END DO - END DO - - DO k = 1, i - 1 -!jyg< -!! DO j = i, nl + 1 ! newvecto: nl au lieu nl+1? - DO j = i, nl -!>jyg - DO il = 1, ncum -!yor! IF (i<=inb(il) .AND. j<=inb(il)) THEN ! the second condition implies the 1st ! - IF (j<=inb(il)) THEN - ad(il) = ad(il) + ment(il, j, k) - END IF - END DO - END DO - END DO -! -!----------------------------------------------------------- - ENDIF !(ok_optim_yield) !| -!----------------------------------------------------------- -! -!! print *,'yield, i, amp1, ad', i, amp1(1), ad(1) - - DO il = 1, ncum - IF (i<=inb(il) .AND. iflag(il)<=1) THEN - dpinv = 1.0/(ph(il,i)-ph(il,i+1)) - cpinv = 1.0/cpn(il, i) - -! convect3 if((0.1*dpinv*amp1).ge.delti)iflag(il)=4 - IF ((0.01*grav*dpinv*amp1(il))>=delti) iflag(il) = 1 ! vecto - -! precip -! cc ft(il,i)= -0.5*sigd(il)*lvcp(il,i)*(evap(il,i)+evap(il,i+1)) - IF (cvflag_ice) THEN - ft(il, i) = -sigd(il)*lvcp(il, i)*evap(il, i) - & - sigd(il)*lfcp(il, i)*evap(il, i)*faci(il, i) - & - sigd(il)*lfcp(il, i)*fondue(il, i)*wt(il, i)/(100.*(p(il,i-1)-p(il,i))) - ELSE - ft(il, i) = -sigd(il)*lvcp(il, i)*evap(il, i) - END IF - - rat = cpn(il, i-1)*cpinv - - ft(il, i) = ft(il, i) - 0.009*grav*sigd(il) * & - (mp(il,i+1)*t_wake(il,i)*b(il,i)-mp(il,i)*t_wake(il,i-1)*rat*b(il,i-1))*dpinv - IF (cvflag_ice) THEN - ft(il, i) = ft(il, i) + 0.01*sigd(il)*wt(il, i)*(cl-cpd)*water(il, i+1) * & - (t_wake(il,i+1)-t_wake(il,i))*dpinv*cpinv + & - 0.01*sigd(il)*wt(il, i)*(ci-cpd)*ice(il, i+1) * & - (t_wake(il,i+1)-t_wake(il,i))*dpinv*cpinv - ELSE - ft(il, i) = ft(il, i) + 0.01*sigd(il)*wt(il, i)*(cl-cpd)*water(il, i+1) * & - (t_wake(il,i+1)-t_wake(il,i))*dpinv* & - cpinv - END IF - - ftd(il, i) = ft(il, i) -! fin precip - -! sature -!jyg< - IF (fl_cor_ebil >= 2) THEN - ft(il, i) = ft(il, i) + 0.01*grav*dpinv * & - ( amp1(il)*( (t(il,i+1)-t(il,i))*cpn(il,i+1) + gz(il,i+1)-gz(il,i))*cpinv - & - ad(il)*( (t(il,i)-t(il,i-1))*cpn(il,i-1) + gz(il,i)-gz(il,i-1))*cpinv) - ELSE - ft(il, i) = ft(il, i) + 0.01*grav*dpinv * & - (amp1(il)*(t(il,i+1)-t(il,i) + (gz(il,i+1)-gz(il,i))*cpinv) - & - ad(il)*(t(il,i)-t(il,i-1)+(gz(il,i)-gz(il,i-1))*cpinv)) - ENDIF -!>jyg - - - IF (iflag_mix==0) THEN - ft(il, i) = ft(il, i) + 0.01*grav*dpinv*ment(il, i, i)*(hp(il,i)-h(il,i) + & - t(il,i)*(cpv-cpd)*(rr(il,i)-qent(il,i,i)))*cpinv - END IF -! -! sb: on ne fait pas encore la correction permettant de mieux -! conserver l'eau: -!JYG: correction permettant de mieux conserver l'eau: -! cc fr(il,i)=0.5*sigd(il)*(evap(il,i)+evap(il,i+1)) - fr(il, i) = sigd(il)*evap(il, i) + 0.01*grav*(mp(il,i+1)*(rp(il,i+1)-rr_wake(il,i)) - & - mp(il,i)*(rp(il,i)-rr_wake(il,i-1)))*dpinv - fqd(il, i) = fr(il, i) ! precip - - fu(il, i) = 0.01*grav*(mp(il,i+1)*(up(il,i+1)-u(il,i)) - & - mp(il,i)*(up(il,i)-u(il,i-1)))*dpinv - fv(il, i) = 0.01*grav*(mp(il,i+1)*(vp(il,i+1)-v(il,i)) - & - mp(il,i)*(vp(il,i)-v(il,i-1)))*dpinv - - - fr(il, i) = fr(il, i) + 0.01*grav*dpinv*(amp1(il)*(rr(il,i+1)-rr(il,i)) - & - ad(il)*(rr(il,i)-rr(il,i-1))) - fu(il, i) = fu(il, i) + 0.01*grav*dpinv*(amp1(il)*(u(il,i+1)-u(il,i)) - & - ad(il)*(u(il,i)-u(il,i-1))) - fv(il, i) = fv(il, i) + 0.01*grav*dpinv*(amp1(il)*(v(il,i+1)-v(il,i)) - & - ad(il)*(v(il,i)-v(il,i-1))) - - END IF ! i - END DO - - DO k = 1, i - 1 - - DO il = 1, ncum - awat(il) = elij(il, k, i) - (1.-ep(il,i))*clw(il, i) - awat(il) = max(awat(il), 0.0) - END DO - - IF (iflag_mix/=0) THEN - DO il = 1, ncum - IF (i<=inb(il) .AND. iflag(il)<=1) THEN - dpinv = 1.0/(ph(il,i)-ph(il,i+1)) - cpinv = 1.0/cpn(il, i) - ft(il, i) = ft(il, i) + 0.01*grav*dpinv*ment(il, k, i) * & - (hent(il,k,i)-h(il,i)+t(il,i)*(cpv-cpd)*(rr(il,i)+awat(il)-qent(il,k,i)))*cpinv -! -! - END IF ! i - END DO - END IF - - DO il = 1, ncum - IF (i<=inb(il) .AND. iflag(il)<=1) THEN - dpinv = 1.0/(ph(il,i)-ph(il,i+1)) - cpinv = 1.0/cpn(il, i) - fr(il, i) = fr(il, i) + 0.01*grav*dpinv*ment(il, k, i) * & - (qent(il,k,i)-awat(il)-rr(il,i)) - fr_comp(il,i) = fr_comp(il,i) + 0.01*grav*dpinv*ment(il, k, i)*(qent(il,k,i)-awat(il)-rr(il,i)) - fu(il, i) = fu(il, i) + 0.01*grav*dpinv*ment(il, k, i)*(uent(il,k,i)-u(il,i)) - fv(il, i) = fv(il, i) + 0.01*grav*dpinv*ment(il, k, i)*(vent(il,k,i)-v(il,i)) - -! (saturated updrafts resulting from mixing) ! cld - qcond(il, i) = qcond(il, i) + (elij(il,k,i)-awat(il)) ! cld - qdet(il,k,i) = (qent(il,k,i)-awat(il)) ! cld Louis : specific humidity in detraining water - qtment(il, i) = qtment(il, i) + qent(il,k,i) ! cld - nqcond(il, i) = nqcond(il, i) + 1. ! cld - END IF ! i - END DO - END DO - -!jyg< -!! DO k = i, nl + 1 - DO k = i, nl -!>jyg - - IF (iflag_mix/=0) THEN - DO il = 1, ncum - IF (i<=inb(il) .AND. k<=inb(il) .AND. iflag(il)<=1) THEN - dpinv = 1.0/(ph(il,i)-ph(il,i+1)) - cpinv = 1.0/cpn(il, i) - ft(il, i) = ft(il, i) + 0.01*grav*dpinv*ment(il, k, i) * & - (hent(il,k,i)-h(il,i)+t(il,i)*(cpv-cpd)*(rr(il,i)-qent(il,k,i)))*cpinv - - - END IF ! i - END DO - END IF - - DO il = 1, ncum - IF (i<=inb(il) .AND. k<=inb(il) .AND. iflag(il)<=1) THEN - dpinv = 1.0/(ph(il,i)-ph(il,i+1)) - cpinv = 1.0/cpn(il, i) - - fr(il, i) = fr(il, i) + 0.01*grav*dpinv*ment(il, k, i)*(qent(il,k,i)-rr(il,i)) - fu(il, i) = fu(il, i) + 0.01*grav*dpinv*ment(il, k, i)*(uent(il,k,i)-u(il,i)) - fv(il, i) = fv(il, i) + 0.01*grav*dpinv*ment(il, k, i)*(vent(il,k,i)-v(il,i)) - END IF ! i and k - END DO - END DO - -! sb: interface with the cloud parameterization: ! cld - - DO k = i + 1, nl - DO il = 1, ncum - IF (k<=inb(il) .AND. i<=inb(il) .AND. iflag(il)<=1) THEN ! cld -! (saturated downdrafts resulting from mixing) ! cld - qcond(il, i) = qcond(il, i) + elij(il, k, i) ! cld - qdet(il,k,i) = qent(il,k,i) ! cld Louis : specific humidity in detraining water - qtment(il, i) = qent(il,k,i) + qtment(il,i) ! cld - nqcond(il, i) = nqcond(il, i) + 1. ! cld - END IF ! cld - END DO ! cld - END DO ! cld - -!ym BIG Warning : it seems that the k loop is missing !!! -!ym Strong advice to check this -!ym add a k loop temporary - -! (particular case: no detraining level is found) ! cld -! Verif merge Dynamico<<<<<<< .working - DO il = 1, ncum ! cld - IF (i<=inb(il) .AND. nent(il,i)==0 .AND. iflag(il)<=1) THEN ! cld - qcond(il, i) = qcond(il, i) + (1.-ep(il,i))*clw(il, i) ! cld -!jyg< Bug correction 20180620 -! PROBLEM: Should not qent(il,i,i) be taken into account even if nent(il,i)/=0? -!! qtment(il, i) = qent(il,k,i) + qtment(il,i) ! cld - qdet(il,i,i) = qent(il,i,i) ! cld Louis : specific humidity in detraining water - qtment(il, i) = qent(il,i,i) + qtment(il,i) ! cld -!>jyg - nqcond(il, i) = nqcond(il, i) + 1. ! cld - END IF ! cld - END DO ! cld -! Verif merge Dynamico ======= -! Verif merge Dynamico DO k = i + 1, nl -! Verif merge Dynamico DO il = 1, ncum !ym k loop added ! cld -! Verif merge Dynamico IF (i<=inb(il) .AND. nent(il,i)==0 .AND. iflag(il)<=1) THEN ! cld -! Verif merge Dynamico qcond(il, i) = qcond(il, i) + (1.-ep(il,i))*clw(il, i) ! cld -! Verif merge Dynamico qtment(il, i) = qent(il,k,i) + qtment(il,i) ! cld -! Verif merge Dynamico nqcond(il, i) = nqcond(il, i) + 1. ! cld -! Verif merge Dynamico END IF ! cld -! Verif merge Dynamico END DO -! Verif merge Dynamico ENDDO ! cld -! Verif merge Dynamico >>>>>>> .merge-right.r3413 - - DO il = 1, ncum ! cld - IF (i<=inb(il) .AND. nqcond(il,i)/=0 .AND. iflag(il)<=1) THEN ! cld - qcond(il, i) = qcond(il, i)/nqcond(il, i) ! cld - qtment(il, i) = qtment(il,i)/nqcond(il, i) ! cld - END IF ! cld - END DO - - -500 END DO - -!!!JYG< -!!!Conservation de l'eau -!! sumdq = 0. -!! DO k = 1, nl -!! sumdq = sumdq + fr(1, k)*100.*(ph(1,k)-ph(1,k+1))/grav -!! END DO -!! PRINT *, 'cv3_yield, apres 500, sum(dq), precip, somme ', sumdq, Vprecip(1, 1), sumdq + vprecip(1, 1) -!!!JYG> -! *** move the detrainment at level inb down to level inb-1 *** -! *** in such a way as to preserve the vertically *** -! *** integrated enthalpy and water tendencies *** - -! Correction bug le 18-03-09 - DO il = 1, ncum - IF (iflag(il)<=1) THEN - ax = 0.01*grav*ment(il, inb(il), inb(il))* & - (hp(il,inb(il))-h(il,inb(il))+t(il,inb(il))*(cpv-cpd)*(rr(il,inb(il))-qent(il,inb(il),inb(il))))/ & - (cpn(il,inb(il))*(ph(il,inb(il))-ph(il,inb(il)+1))) - ft(il, inb(il)) = ft(il, inb(il)) - ax - ft(il, inb(il)-1) = ft(il, inb(il)-1) + ax*cpn(il, inb(il))*(ph(il,inb(il))-ph(il,inb(il)+1))/ & - (cpn(il,inb(il)-1)*(ph(il,inb(il)-1)-ph(il,inb(il)))) - - bx = 0.01*grav*ment(il, inb(il), inb(il))*(qent(il,inb(il),inb(il))-rr(il,inb(il)))/ & - (ph(il,inb(il))-ph(il,inb(il)+1)) - fr(il, inb(il)) = fr(il, inb(il)) - bx - fr(il, inb(il)-1) = fr(il, inb(il)-1) + bx*(ph(il,inb(il))-ph(il,inb(il)+1))/ & - (ph(il,inb(il)-1)-ph(il,inb(il))) - - cx = 0.01*grav*ment(il, inb(il), inb(il))*(uent(il,inb(il),inb(il))-u(il,inb(il)))/ & - (ph(il,inb(il))-ph(il,inb(il)+1)) - fu(il, inb(il)) = fu(il, inb(il)) - cx - fu(il, inb(il)-1) = fu(il, inb(il)-1) + cx*(ph(il,inb(il))-ph(il,inb(il)+1))/ & - (ph(il,inb(il)-1)-ph(il,inb(il))) - - dx = 0.01*grav*ment(il, inb(il), inb(il))*(vent(il,inb(il),inb(il))-v(il,inb(il)))/ & - (ph(il,inb(il))-ph(il,inb(il)+1)) - fv(il, inb(il)) = fv(il, inb(il)) - dx - fv(il, inb(il)-1) = fv(il, inb(il)-1) + dx*(ph(il,inb(il))-ph(il,inb(il)+1))/ & - (ph(il,inb(il)-1)-ph(il,inb(il))) - END IF !iflag - END DO - -!!!JYG< -!!!Conservation de l'eau -!! sumdq = 0. -!! DO k = 1, nl -!! sumdq = sumdq + fr(1, k)*100.*(ph(1,k)-ph(1,k+1))/grav -!! END DO -!! PRINT *, 'cv3_yield, apres 503, sum(dq), precip, somme ', sumdq, Vprecip(1, 1), sumdq + vprecip(1, 1) -!!!JYG> - - -! *** homogenize tendencies below cloud base *** - - - DO il = 1, ncum - asum(il) = 0.0 - bsum(il) = 0.0 - csum(il) = 0.0 - dsum(il) = 0.0 - esum(il) = 0.0 - fsum(il) = 0.0 - gsum(il) = 0.0 - hsum(il) = 0.0 - END DO - -!do i=1,nl -!do il=1,ncum -!th_wake(il,i)=t_wake(il,i)*(1000.0/p(il,i))**rdcp -!enddo -!enddo - - DO i = 1, nl - DO il = 1, ncum - IF (i<=(icb(il)-1) .AND. iflag(il)<=1) THEN -!jyg Saturated part : use T profile - asum(il) = asum(il) + (ft(il,i)-ftd(il,i))*(ph(il,i)-ph(il,i+1)) -!jyg<20140311 -!Correction pour conserver l eau - IF (ok_conserv_q) THEN - bsum(il) = bsum(il) + (fr(il,i)-fqd(il,i))*(ph(il,i)-ph(il,i+1)) - csum(il) = csum(il) + (ph(il,i)-ph(il,i+1)) - - ELSE - bsum(il)=bsum(il)+(fr(il,i)-fqd(il,i))*(lv(il,i)+(cl-cpd)*(t(il,i)-t(il,1)))* & - (ph(il,i)-ph(il,i+1)) - csum(il)=csum(il)+(lv(il,i)+(cl-cpd)*(t(il,i)-t(il,1)))* & - (ph(il,i)-ph(il,i+1)) - ENDIF ! (ok_conserv_q) -!jyg> - dsum(il) = dsum(il) + t(il, i)*(ph(il,i)-ph(il,i+1))/th(il, i) -!jyg Unsaturated part : use T_wake profile - esum(il) = esum(il) + ftd(il, i)*(ph(il,i)-ph(il,i+1)) -!jyg<20140311 -!Correction pour conserver l eau - IF (ok_conserv_q) THEN - fsum(il) = fsum(il) + fqd(il, i)*(ph(il,i)-ph(il,i+1)) - gsum(il) = gsum(il) + (ph(il,i)-ph(il,i+1)) - ELSE - fsum(il)=fsum(il)+fqd(il,i)*(lv(il,i)+(cl-cpd)*(t_wake(il,i)-t_wake(il,1)))* & - (ph(il,i)-ph(il,i+1)) - gsum(il)=gsum(il)+(lv(il,i)+(cl-cpd)*(t_wake(il,i)-t_wake(il,1)))* & - (ph(il,i)-ph(il,i+1)) - ENDIF ! (ok_conserv_q) -!jyg> - hsum(il) = hsum(il) + t_wake(il, i)*(ph(il,i)-ph(il,i+1))/th_wake(il, i) - END IF - END DO - END DO - -!!!! do 700 i=1,icb(il)-1 - IF (ok_homo_tend) THEN - DO i = 1, nl - DO il = 1, ncum - IF (i<=(icb(il)-1) .AND. iflag(il)<=1) THEN - ftd(il, i) = esum(il)*t_wake(il, i)/(th_wake(il,i)*hsum(il)) - fqd(il, i) = fsum(il)/gsum(il) - ft(il, i) = ftd(il, i) + asum(il)*t(il, i)/(th(il,i)*dsum(il)) - fr(il, i) = fqd(il, i) + bsum(il)/csum(il) - END IF - END DO - END DO - ENDIF - -!jyg< -!Conservation de l'eau -!! sumdq = 0. -!! DO k = 1, nl -!! sumdq = sumdq + fr(1, k)*100.*(ph(1,k)-ph(1,k+1))/grav -!! END DO -!! PRINT *, 'cv3_yield, apres hom, sum(dq), precip, somme ', sumdq, Vprecip(1, 1), sumdq + vprecip(1, 1) -!jyg> - - -! *** Check that moisture stays positive. If not, scale tendencies -! in order to ensure moisture positivity - DO il = 1, ncum - alpha_qpos(il) = 1. - IF (iflag(il)<=1) THEN - IF (fr(il,1)<=0.) THEN - alpha_qpos(il) = max(alpha_qpos(il), (-delt*fr(il,1))/(s_wake(il)*rr_wake(il,1)+(1.-s_wake(il))*rr(il,1))) - END IF - END IF - END DO - DO i = 2, nl - DO il = 1, ncum - IF (iflag(il)<=1) THEN - IF (fr(il,i)<=0.) THEN - alpha_qpos1(il) = max(1., (-delt*fr(il,i))/(s_wake(il)*rr_wake(il,i)+(1.-s_wake(il))*rr(il,i))) - IF (alpha_qpos1(il)>=alpha_qpos(il)) alpha_qpos(il) = alpha_qpos1(il) - END IF - END IF - END DO - END DO - DO il = 1, ncum - IF (iflag(il)<=1 .AND. alpha_qpos(il)>1.001) THEN - alpha_qpos(il) = alpha_qpos(il)*1.1 - END IF - END DO -! - IF (prt_level .GE. 5) THEN - print *,' CV3_YIELD : alpha_qpos ',alpha_qpos(1) - ENDIF -! - DO il = 1, ncum - IF (iflag(il)<=1) THEN - sigd(il) = sigd(il)/alpha_qpos(il) - precip(il) = precip(il)/alpha_qpos(il) - cbmf(il) = cbmf(il)/alpha_qpos(il) - END IF - END DO - DO i = 1, nl - DO il = 1, ncum - IF (iflag(il)<=1) THEN - fr(il, i) = fr(il, i)/alpha_qpos(il) - ft(il, i) = ft(il, i)/alpha_qpos(il) - fqd(il, i) = fqd(il, i)/alpha_qpos(il) - ftd(il, i) = ftd(il, i)/alpha_qpos(il) - fu(il, i) = fu(il, i)/alpha_qpos(il) - fv(il, i) = fv(il, i)/alpha_qpos(il) - m(il, i) = m(il, i)/alpha_qpos(il) - mp(il, i) = mp(il, i)/alpha_qpos(il) - Vprecip(il, i) = Vprecip(il, i)/alpha_qpos(il) - Vprecipi(il, i) = Vprecipi(il, i)/alpha_qpos(il) ! jyg - END IF - END DO - END DO -!jyg< -!----------------------------------------------------------- - IF (ok_optim_yield) THEN !| -!----------------------------------------------------------- - DO i = 1, nl - DO il = 1, ncum - IF (iflag(il)<=1) THEN - upwd(il, i) = upwd(il, i)/alpha_qpos(il) - dnwd(il, i) = dnwd(il, i)/alpha_qpos(il) - END IF - END DO - END DO -!----------------------------------------------------------- - ENDIF !(ok_optim_yield) !| -!----------------------------------------------------------- -!>jyg - DO j = 1, nl !yor! inverted i and j loops - DO i = 1, nl - DO il = 1, ncum - IF (iflag(il)<=1) THEN - ment(il, i, j) = ment(il, i, j)/alpha_qpos(il) - END IF - END DO - END DO - END DO - - -! *** reset counter and return *** - -! Reset counter only for points actually convective (jyg) -! In order take into account the possibility of changing the compression, -! reset m, sig and w0 to zero for non-convecting points. - DO il = 1, ncum - IF (iflag(il) < 3) THEN - sig(il, nd) = 2.0 - ENDIF - END DO - - - DO i = 1, nl - DO il = 1, ncum - dnwd0(il, i) = -mp(il, i) - END DO - END DO -!jyg< (loops stop at nl) -!! DO i = nl + 1, nd -!! DO il = 1, ncum -!! dnwd0(il, i) = 0. -!! END DO -!! END DO -!>jyg - - -!jyg< -!----------------------------------------------------------- - IF (.NOT.ok_optim_yield) THEN !| -!----------------------------------------------------------- - DO i = 1, nl - DO il = 1, ncum - upwd(il, i) = 0.0 - dnwd(il, i) = 0.0 - END DO - END DO - -!! DO i = 1, nl ! useless; jyg -!! DO il = 1, ncum ! useless; jyg -!! IF (i>=icb(il) .AND. i<=inb(il)) THEN ! useless; jyg -!! upwd(il, i) = 0.0 ! useless; jyg -!! dnwd(il, i) = 0.0 ! useless; jyg -!! END IF ! useless; jyg -!! END DO ! useless; jyg -!! END DO ! useless; jyg - - DO i = 1, nl - DO k = 1, nl - DO il = 1, ncum - up1(il, k, i) = 0.0 - dn1(il, k, i) = 0.0 - END DO - END DO - END DO - -!yor! commented original -! DO i = 1, nl -! DO k = i, nl -! DO n = 1, i - 1 -! DO il = 1, ncum -! IF (i>=icb(il) .AND. i<=inb(il) .AND. k<=inb(il)) THEN -! up1(il, k, i) = up1(il, k, i) + ment(il, n, k) -! dn1(il, k, i) = dn1(il, k, i) - ment(il, k, n) -! END IF -! END DO -! END DO -! END DO -! END DO -!yor! replaced with - DO i = 1, nl - DO k = i, nl - DO n = 1, i - 1 - DO il = 1, ncum - IF (i>=icb(il) .AND. k<=inb(il)) THEN ! yor ! as i always <= k - up1(il, k, i) = up1(il, k, i) + ment(il, n, k) - END IF - END DO - END DO - END DO - END DO - DO i = 1, nl - DO n = 1, i - 1 - DO k = i, nl - DO il = 1, ncum - IF (i>=icb(il) .AND. k<=inb(il)) THEN ! yor ! i always <= k - dn1(il, k, i) = dn1(il, k, i) - ment(il, k, n) - END IF - END DO - END DO - END DO - END DO -!yor! end replace - - DO i = 1, nl - DO k = 1, nl - DO il = 1, ncum - IF (i>=icb(il)) THEN - IF (k>=i .AND. k<=(inb(il))) THEN - upwd(il, i) = upwd(il, i) + m(il, k) - END IF - ELSE - IF (kjyg - -!! DO i = 1, nl -!! DO il = 1, ncum -!! IF (i<=(icb(il)-1)) THEN -!! ma(il, i) = 0 -!! END IF -!! END DO -!! END DO - -!----------------------------------------------------------- - ENDIF !(.NOT.ok_optim_yield) !| -!----------------------------------------------------------- -!>jyg - -! ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -! determination de la variation de flux ascendant entre -! deux niveau non dilue mip -! ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - - DO i = 1, nl - DO il = 1, ncum - mip(il, i) = m(il, i) - END DO - END DO - -!jyg< (loops stop at nl) -!! DO i = nl + 1, nd -!! DO il = 1, ncum -!! mip(il, i) = 0. -!! END DO -!! END DO -!>jyg - - -! cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -! icb represente de niveau ou se trouve la -! base du nuage , et inb le top du nuage -! ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - -!! DO i = 1, nd ! unused . jyg -!! DO il = 1, ncum ! unused . jyg -!! mke(il, i) = upwd(il, i) + dnwd(il, i) ! unused . jyg -!! END DO ! unused . jyg -!! END DO ! unused . jyg - -!! DO i = 1, nd ! unused . jyg -!! DO il = 1, ncum ! unused . jyg -!! rdcp = (rrd*(1.-rr(il,i))-rr(il,i)*rrv)/(cpd*(1.-rr(il,i))+rr(il,i)*cpv) ! unused . jyg -!! tls(il, i) = t(il, i)*(1000.0/p(il,i))**rdcp ! unused . jyg -!! tps(il, i) = tp(il, i) ! unused . jyg -!! END DO ! unused . jyg -!! END DO ! unused . jyg - - -! *** diagnose the in-cloud mixing ratio *** ! cld -! *** of condensed water *** ! cld -!! cld - - DO i = 1, nl+1 ! cld - DO il = 1, ncum ! cld - mac(il, i) = 0.0 ! cld - wa(il, i) = 0.0 ! cld - siga(il, i) = 0.0 ! cld - sax(il, i) = 0.0 ! cld - END DO ! cld - END DO ! cld - - DO i = minorig, nl ! cld - DO k = i + 1, nl + 1 ! cld - DO il = 1, ncum ! cld - IF (i<=inb(il) .AND. k<=(inb(il)+1) .AND. iflag(il)<=1) THEN ! cld - mac(il, i) = mac(il, i) + m(il, k) ! cld - END IF ! cld - END DO ! cld - END DO ! cld - END DO ! cld - - DO i = 1, nl ! cld - DO j = 1, i ! cld - DO il = 1, ncum ! cld - IF (i>=icb(il) .AND. i<=(inb(il)-1) & ! cld - .AND. j>=icb(il) .AND. iflag(il)<=1) THEN ! cld - sax(il, i) = sax(il, i) + rrd*(tvp(il,j)-tv(il,j)) & ! cld - *(ph(il,j)-ph(il,j+1))/p(il, j) ! cld - END IF ! cld - END DO ! cld - END DO ! cld - END DO ! cld - - DO i = 1, nl ! cld - DO il = 1, ncum ! cld - IF (i>=icb(il) .AND. i<=(inb(il)-1) & ! cld - .AND. sax(il,i)>0.0 .AND. iflag(il)<=1) THEN ! cld - wa(il, i) = sqrt(2.*sax(il,i)) ! cld - END IF ! cld - END DO ! cld - END DO - ! cld - DO i = 1, nl - -! 14/01/15 AJ je remets les parties manquantes cf JYG -! Initialize sument to 0 - - DO il = 1,ncum - sument(il) = 0. - ENDDO - -! Sum mixed mass fluxes in sument - - DO k = 1,nl - DO il = 1,ncum - IF (k<=inb(il) .AND. i<=inb(il) .AND. iflag(il)<=1) THEN ! cld - sument(il) =sument(il) + abs(ment(il,k,i)) - detrain(il,i) = detrain(il,i) + abs(ment(il,k,i))*(qdet(il,k,i) - rr(il,i))*(qdet(il,k,i) - rr(il,i)) ! Louis terme de detrainement dans le bilan de variance - ENDIF - ENDDO ! il - ENDDO ! k - -! 14/01/15 AJ delta n'a rien a faire la... - DO il = 1, ncum ! cld -!! IF (wa(il,i)>0.0 .AND. iflag(il)<=1) & ! cld -!! siga(il, i) = mac(il, i)/(coefw_cld_cv*wa(il, i)) & ! cld -!! *rrd*tvp(il, i)/p(il, i)/100. ! cld -!! -!! siga(il, i) = min(siga(il,i), 1.0) ! cld - sigaq = 0. - IF (wa(il,i)>0.0 .AND. iflag(il)<=1) THEN ! cld - siga(il, i) = mac(il, i)/(coefw_cld_cv*wa(il, i)) & ! cld - *rrd*tvp(il, i)/p(il, i)/100. ! cld - siga(il, i) = min(siga(il,i), 1.0) ! cld - sigaq = siga(il,i)*qta(il,i-1) ! cld - ENDIF - -! IM cf. FH -! 14/01/15 AJ ne correspond pas � ce qui a �t� cod� par JYG et SB - - IF (iflag_clw==0) THEN ! cld - qcondc(il, i) = siga(il, i)*clw(il, i)*(1.-ep(il,i)) & ! cld - +(1.-siga(il,i))*qcond(il, i) ! cld - - - sigment(il,i)=sument(il)*tau_cld_cv/(ph(il,i)-ph(il,i+1)) ! cld - sigment(il, i) = min(1.e-4+sigment(il,i), 1.0 - siga(il,i)) ! cld -!! qtc(il, i) = (siga(il,i)*qta(il,i-1)+sigment(il,i)*qtment(il,i)) & ! cld - qtc(il, i) = (sigaq+sigment(il,i)*qtment(il,i)) & ! cld - /(siga(il,i)+sigment(il,i)) ! cld - sigt(il,i) = sigment(il, i) + siga(il, i) - -! qtc(il, i) = siga(il,i)*qta(il,i-1)+(1.-siga(il,i))*qtment(il,i) ! cld -! print*,'BIGAUSSIAN CONV',siga(il,i),sigment(il,i),qtc(il,i) - - ELSE IF (iflag_clw==1) THEN ! cld - qcondc(il, i) = qcond(il, i) ! cld - qtc(il,i) = qtment(il,i) ! cld - END IF ! cld - - END DO ! cld - END DO -! print*,'cv3_yield fin' - - RETURN -END SUBROUTINE cv3_yield - -!AC! et !RomP >>> -SUBROUTINE cv3_tracer(nloc, len, ncum, nd, na, & - ment, sigij, da, phi, phi2, d1a, dam, & - ep, Vprecip, elij, clw, epmlmMm, eplaMm, & - icb, inb) - USE lmdz_cv_ini, ONLY : nl,keep_bug_indices_cv3_tracer - USE cvflag_mod_h - USE ioipsl_getin_p_mod, ONLY : getin_p - IMPLICIT NONE - - -!inputs: -!------ - INTEGER, INTENT (IN) :: ncum, nd, na, nloc, len - INTEGER, DIMENSION (len), INTENT (IN) :: icb, inb - REAL, DIMENSION (len, na, na), INTENT (IN) :: ment, sigij, elij - REAL, DIMENSION (len, nd), INTENT (IN) :: clw - REAL, DIMENSION (len, na), INTENT (IN) :: ep - REAL, DIMENSION (len, nd+1), INTENT (IN) :: Vprecip -!ouputs: -!------ - REAL, DIMENSION (len, na, na), INTENT (OUT) :: phi, phi2, epmlmMm - REAL, DIMENSION (len, na), INTENT (OUT) :: da, d1a, dam, eplaMm -! -!local variables: -!--------------- -! variables pour tracer dans precip de l'AA et des mel - INTEGER i, j, k - REAL epm(nloc, na, na) -! -! variables d'Emanuel : du second indice au troisieme -! ---> tab(i,k,j) -> de l origine k a l arrivee j -! ment, sigij, elij -! variables personnelles : du troisieme au second indice -! ---> tab(i,j,k) -> de k a j -! phi, phi2, epm, epmlmMm - - - da(:, :) = 0. - d1a(:, :) = 0. - dam(:, :) = 0. - epm(:, :, :) = 0. - eplaMm(:, :) = 0. - epmlmMm(:, :, :) = 0. - phi(:, :, :) = 0. - phi2(:, :, :) = 0. - -! fraction deau condensee dans les melanges convertie en precip : epm -! et eau condens�e pr�cipit�e dans masse d'air satur� : l_m*dM_m/dzdz.dzdz - DO j = 1, nl - DO k = 1, nl - DO i = 1, ncum - IF (k>=icb(i) .AND. k<=inb(i) .AND. & -!!jyg j.ge.k.and.j.le.inb(i)) then -!!jyg epm(i,j,k)=1.-(1.-ep(i,j))*clw(i,j)/elij(i,k,j) - j>k .AND. j<=inb(i)) THEN - epm(i, j, k) = 1. - (1.-ep(i,j))*clw(i, j)/max(elij(i,k,j), 1.E-16) -!! - epm(i, j, k) = max(epm(i,j,k), 0.0) - END IF - END DO - END DO - END DO - - - DO j = 1, nl - DO k = 1, nl - DO i = 1, ncum - IF (k>=icb(i) .AND. k<=inb(i)) THEN - eplaMm(i, j) = eplamm(i, j) + & - ep(i, j)*clw(i, j)*ment(i, j, k)*(1.-sigij(i,j,k)) - END IF - END DO - END DO - END DO - - DO j = 1, nl - DO k = 1, j - 1 - DO i = 1, ncum - IF (k>=icb(i) .AND. k<=inb(i) .AND. j<=inb(i)) THEN - epmlmMm(i, j, k) = epm(i, j, k)*elij(i, k, j)*ment(i, k, j) - END IF - END DO - END DO - END DO - -! matrices pour calculer la tendance des concentrations dans cvltr.F90 - DO j = 1, nl - DO k = 1, nl - DO i = 1, ncum - da(i, j) = da(i, j) + (1.-sigij(i,k,j))*ment(i, k, j) - phi(i, j, k) = sigij(i, k, j)*ment(i, k, j) - d1a(i, j) = d1a(i, j) + ment(i, k, j)*ep(i, k)*(1.-sigij(i,k,j)) - IF (k<=j) THEN - phi2(i, j, k) = phi(i, j, k)*epm(i, j, k) - END IF - END DO - END DO - END DO - - IF (keep_bug_indices_cv3_tracer) THEN - DO j = 1, nl - DO k = 1, nl - DO i = 1, ncum - IF (k<=j) THEN - dam(i, j) = dam(i, j) + ment(i, k, j)*epm(i, k, j)*(1.-ep(i,k))*(1.-sigij(i,k,j)) - END IF ! (k<=j) - END DO - END DO - END DO - ELSE ! (keep_bug_indices_cv3_tracer) - DO j = 1, nl - DO k = 1, nl - DO i = 1, ncum - IF (k<=j) THEN - dam(i, j) = dam(i, j) + ment(i, k, j)*epm(i, j, k)*(1.-ep(i,k))*(1.-sigij(i,k,j)) - END IF ! (k<=j) - END DO - END DO - END DO - ENDIF ! (keep_bug_indices_cv3_tracer) - - RETURN -END SUBROUTINE cv3_tracer -!AC! et !RomP <<< - -SUBROUTINE cv3_uncompress(nloc, len, ncum, nd, ntra, idcum, & - iflag, & - precip, sig, w0, & - ft, fq, fu, fv, ftra, & - Ma, upwd, dnwd, dnwd0, qcondc, wd, cape, & - epmax_diag, & ! epmax_cape - iflag1, & - precip1, sig1, w01, & - ft1, fq1, fu1, fv1, ftra1, & - Ma1, upwd1, dnwd1, dnwd01, qcondc1, wd1, cape1, & - epmax_diag1) ! epmax_cape - USE lmdz_cv_ini, ONLY : nl - IMPLICIT NONE - - -!inputs: - INTEGER len, ncum, nd, ntra, nloc - INTEGER idcum(nloc) - INTEGER iflag(nloc) - REAL precip(nloc) - REAL sig(nloc, nd), w0(nloc, nd) - REAL ft(nloc, nd), fq(nloc, nd), fu(nloc, nd), fv(nloc, nd) - REAL ftra(nloc, nd, ntra) - REAL ma(nloc, nd) - REAL upwd(nloc, nd), dnwd(nloc, nd), dnwd0(nloc, nd) - REAL qcondc(nloc, nd) - REAL wd(nloc), cape(nloc) - REAL epmax_diag(nloc) - -!outputs: - INTEGER iflag1(len) - REAL precip1(len) - REAL sig1(len, nd), w01(len, nd) - REAL ft1(len, nd), fq1(len, nd), fu1(len, nd), fv1(len, nd) - REAL ftra1(len, nd, ntra) - REAL ma1(len, nd) - REAL upwd1(len, nd), dnwd1(len, nd), dnwd01(len, nd) - REAL qcondc1(nloc, nd) - REAL wd1(nloc), cape1(nloc) - REAL epmax_diag1(len) ! epmax_cape - -!local variables: - INTEGER i, k, j - - DO i = 1, ncum - precip1(idcum(i)) = precip(i) - iflag1(idcum(i)) = iflag(i) - wd1(idcum(i)) = wd(i) - cape1(idcum(i)) = cape(i) - epmax_diag1(idcum(i))=epmax_diag(i) ! epmax_cape - END DO - - DO k = 1, nl - DO i = 1, ncum - sig1(idcum(i), k) = sig(i, k) - w01(idcum(i), k) = w0(i, k) - ft1(idcum(i), k) = ft(i, k) - fq1(idcum(i), k) = fq(i, k) - fu1(idcum(i), k) = fu(i, k) - fv1(idcum(i), k) = fv(i, k) - ma1(idcum(i), k) = ma(i, k) - upwd1(idcum(i), k) = upwd(i, k) - dnwd1(idcum(i), k) = dnwd(i, k) - dnwd01(idcum(i), k) = dnwd0(i, k) - qcondc1(idcum(i), k) = qcondc(i, k) - END DO - END DO - - DO i = 1, ncum - sig1(idcum(i), nd) = sig(i, nd) - END DO - - -!AC! do 2100 j=1,ntra -!AC!c oct3 do 2110 k=1,nl -!AC! do 2110 k=1,nd ! oct3 -!AC! do 2120 i=1,ncum -!AC! ftra1(idcum(i),k,j)=ftra(i,k,j) -!AC! 2120 continue -!AC! 2110 continue -!AC! 2100 continue -! - RETURN -END SUBROUTINE cv3_uncompress - - - subroutine cv3_epmax_fn_cape(nloc,ncum,nd & - , ep,hp,icb,inb,clw,nk,t,h,hnk,lv,lf,frac & - , pbase, p, ph, tv, buoy, sig, w0,iflag & - , epmax_diag) - USE conema3_mod_h - USE cvflag_mod_h - USE lmdz_cv_ini, ONLY : nl,minorig,cpd,cpv - implicit none - - ! On fait varier epmax en fn de la cape - ! Il faut donc recalculer ep, et hp qui a d�j� �t� calcul� et - ! qui en d�pend - ! Toutes les autres variables fn de ep sont calcul�es plus bas. - - -! inputs: - INTEGER, INTENT (IN) :: ncum, nd, nloc - INTEGER, DIMENSION (nloc), INTENT (IN) :: icb, inb, nk - REAL, DIMENSION (nloc), INTENT (IN) :: hnk,pbase - REAL, DIMENSION (nloc, nd), INTENT (IN) :: t, lv, lf, tv, h - REAL, DIMENSION (nloc, nd), INTENT (IN) :: clw, buoy,frac - REAL, DIMENSION (nloc, nd), INTENT (IN) :: sig,w0 - INTEGER, DIMENSION (nloc), INTENT (IN) :: iflag(nloc) - REAL, DIMENSION (nloc, nd), INTENT (IN) :: p - REAL, DIMENSION (nloc, nd+1), INTENT (IN) :: ph -! inouts: - REAL, DIMENSION (nloc, nd), INTENT (INOUT) :: ep,hp -! outputs - REAL, DIMENSION (nloc), INTENT (OUT) :: epmax_diag - -! local - integer i,k -! real hp_bak(nloc,nd) -! real ep_bak(nloc,nd) - real m_loc(nloc,nd) - real sig_loc(nloc,nd) - real w0_loc(nloc,nd) - integer iflag_loc(nloc) - real cape(nloc) - - if (coef_epmax_cape.gt.1e-12) then - - ! il faut calculer la cape: on fait un calcule simple car tant qu'on ne - ! connait pas ep, on ne connait pas les m�langes, ddfts etc... qui sont - ! necessaires au calcul de la cape dans la nouvelle physique - -! write(*,*) 'cv3_routines check 4303' - do i=1,ncum - do k=1,nd - sig_loc(i,k)=sig(i,k) - w0_loc(i,k)=w0(i,k) - iflag_loc(i)=iflag(i) -! ep_bak(i,k)=ep(i,k) - enddo ! do k=1,nd - enddo !do i=1,ncum - -! write(*,*) 'cv3_routines check 4311' -! write(*,*) 'nl=',nl - CALL cv3_closure(nloc, ncum, nd, icb, inb, & ! na->nd - pbase, p, ph, tv, buoy, & - sig_loc, w0_loc, cape, m_loc,iflag_loc) - -! write(*,*) 'cv3_routines check 4316' -! write(*,*) 'ep(1,:)=',ep(1,:) - do i=1,ncum - epmax_diag(i)=epmax-coef_epmax_cape*sqrt(cape(i)) - epmax_diag(i)=amax1(epmax_diag(i),0.0) -! write(*,*) 'i,icb,inb,cape,epmax_diag=', & -! i,icb(i),inb(i),cape(i),epmax_diag(i) - do k=1,nl - ep(i,k)=ep(i,k)/epmax*epmax_diag(i) - ep(i,k)=amax1(ep(i,k),0.0) - ep(i,k)=amin1(ep(i,k),epmax_diag(i)) - enddo - enddo - ! write(*,*) 'ep(1,:)=',ep(1,:) - - !write(*,*) 'cv3_routines check 4326' -! On recalcule hp: -! do k=1,nl -! do i=1,ncum -! hp_bak(i,k)=hp(i,k) -! enddo -! enddo - do k=1,nl - do i=1,ncum - hp(i,k)=h(i,k) - enddo - enddo - - IF (cvflag_ice) THEN - - do k=minorig+1,nl - do i=1,ncum - if((k.ge.icb(i)).and.(k.le.inb(i)))then - hp(i, k) = hnk(i) + (lv(i,k)+(cpd-cpv)*t(i,k)+frac(i,k)*lf(i,k))* & - ep(i, k)*clw(i, k) - endif - enddo - enddo !do k=minorig+1,n - ELSE !IF (cvflag_ice) THEN - - DO k = minorig + 1, nl - DO i = 1, ncum - IF ((k>=icb(i)) .AND. (k<=inb(i))) THEN - hp(i,k)=hnk(i)+(lv(i,k)+(cpd-cpv)*t(i,k))*ep(i,k)*clw(i,k) - endif - enddo - enddo !do k=minorig+1,n - - ENDIF !IF (cvflag_ice) THEN - !write(*,*) 'cv3_routines check 4345' -! do i=1,ncum -! do k=1,nl -! if ((abs(hp_bak(i,k)-hp(i,k))/hp_bak(i,k).gt.1e-1).or. & -! ((abs(hp_bak(i,k)-hp(i,k))/hp_bak(i,k).gt.1e-4).and. & -! (ep(i,k)-ep_bak(i,k).lt.1e-4))) then -! write(*,*) 'i,k=',i,k -! write(*,*) 'coef_epmax_cape=',coef_epmax_cape -! write(*,*) 'epmax_diag(i)=',epmax_diag(i) -! write(*,*) 'ep(i,k)=',ep(i,k) -! write(*,*) 'ep_bak(i,k)=',ep_bak(i,k) -! write(*,*) 'hp(i,k)=',hp(i,k) -! write(*,*) 'hp_bak(i,k)=',hp_bak(i,k) -! write(*,*) 'h(i,k)=',h(i,k) -! write(*,*) 'nk(i)=',nk(i) -! write(*,*) 'h(i,nk(i))=',h(i,nk(i)) -! write(*,*) 'lv(i,k)=',lv(i,k) -! write(*,*) 't(i,k)=',t(i,k) -! write(*,*) 'clw(i,k)=',clw(i,k) -! write(*,*) 'cpd,cpv=',cpd,cpv -! stop -! endif -! enddo !do k=1,nl -! enddo !do i=1,ncum - endif !if (coef_epmax_cape.gt.1e-12) then - !write(*,*) 'cv3_routines check 4367' - - return - end subroutine cv3_epmax_fn_cape - -END MODULE cv3_routines_mod - Index: LMDZ6/trunk/libf/phylmd/cv3_routines_mod.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cv3_routines_mod.f90 (revision 6048) +++ LMDZ6/trunk/libf/phylmd/cv3_routines_mod.f90 (revision 6048) @@ -0,0 +1,5145 @@ + +! $Id$ +MODULE cv3_routines_mod + PRIVATE +! for cv3_feed + LOGICAL, SAVE :: cv3_feed_first =.TRUE. + LOGICAL, SAVE :: ok_new_feed +!$OMP THREADPRIVATE (cv3_feed_first,ok_new_feed) + PUBLIC cv3_param, cv3_incrcount, cv3_prelim, cv3_feed, cv3_undilute1, cv3_trigger, cv3_compress, & + icefrac, cv3_undilute2, cv3_closure, cv3_mixing, cv3_unsat, cv3_yield, cv3_tracer, cv3_uncompress,& + cv3_epmax_fn_cape, cv3_routine_pre +CONTAINS + +SUBROUTINE cv3_routine_pre(ok_conserv_q) + LOGICAL, INTENT (IN) :: ok_conserv_q + + CALL cv3_feed_pre(ok_conserv_q) + +END SUBROUTINE cv3_routine_pre + +SUBROUTINE cv3_param(nd, k_upper, delt) + + USE cvflag_mod_h + USE ioipsl_getin_p_mod, ONLY : getin_p + use mod_phys_lmdz_para + USE conema3_mod_h + USE lmdz_cv_ini, ONLY : alpha,alpha1,beta,betad,coef_peel,cv_flag_feed,delta,dpbase,dtcrit,dtovsh,dttrig,ejectice,ejectliq,elcrit,flag_epkeorig,flag_wb,minorig,nl,nlm,nlp,noconv_stop,noff,omtrain,pbcrit,ptcrit,sigdz,spfac,t_top_max,tau,tau_stop,tlcrit,wbmax + USE lmdz_cv_ini, ONLY : keep_bug_indices_cv3_tracer,restore_bug_cvdn + + + IMPLICIT NONE + +!------------------------------------------------------------ +!Set parameters for convectL for iflag_con = 3 +!------------------------------------------------------------ + + +!*** PBCRIT IS THE CRITICAL CLOUD DEPTH (MB) BENEATH WHICH THE *** +!*** PRECIPITATION EFFICIENCY IS ASSUMED TO BE ZERO *** +!*** PTCRIT IS THE CLOUD DEPTH (MB) ABOVE WHICH THE PRECIP. *** +!*** EFFICIENCY IS ASSUMED TO BE UNITY *** +!*** SIGD IS THE FRACTIONAL AREA COVERED BY UNSATURATED DNDRAFT *** +!*** SPFAC IS THE FRACTION OF PRECIPITATION FALLING OUTSIDE *** +!*** OF CLOUD *** + +![TAU: CHARACTERISTIC TIMESCALE USED TO COMPUTE ALPHA & BETA] +!*** ALPHA AND BETA ARE PARAMETERS THAT CONTROL THE RATE OF *** +!*** APPROACH TO QUASI-EQUILIBRIUM *** +!*** (THEIR STANDARD VALUES ARE 1.0 AND 0.96, RESPECTIVELY) *** +!*** (BETA MUST BE LESS THAN OR EQUAL TO 1) *** + +!*** DTCRIT IS THE CRITICAL BUOYANCY (K) USED TO ADJUST THE *** +!*** APPROACH TO QUASI-EQUILIBRIUM *** +!*** IT MUST BE LESS THAN 0 *** + + INTEGER, INTENT(IN) :: nd + INTEGER, INTENT(IN) :: k_upper + REAL, INTENT(IN) :: delt ! timestep (seconds) + +! Local variables + CHARACTER (LEN=20),PARAMETER :: modname = 'cv3_param' + CHARACTER (LEN=80) :: abort_message + + LOGICAL, SAVE :: first = .TRUE. +!$OMP THREADPRIVATE(first) + +!glb noff: integer limit for convection (nd-noff) +! minorig: First level of convection + +! -- limit levels for convection: + +!jyg< +! noff is chosen such that nl = k_upper so that upmost loops end at about 22 km +! + noff = min(max(nd-k_upper, 1), (nd+1)/2) +!! noff = 1 +!>jyg + minorig = 1 + nl = nd - noff + nlp = nl + 1 + nlm = nl - 1 + + IF (first) THEN +! -- "microphysical" parameters: +! IM beg: ajout fis. reglage ep +! CR+JYG: shedding coefficient (used when iflag_mix_adiab=1) +! IM lu dans physiq.def via conf_phys.F90 epmax = 0.993 + + omtrain = 45.0 ! used also for snow (no disctinction rain/snow) +! -- misc: + dtovsh = -0.2 ! dT for overshoot +! cc dttrig = 5. ! (loose) condition for triggering + dttrig = 10. ! (loose) condition for triggering + dtcrit = -2.0 +! -- end of convection +! -- interface cloud parameterization: + delta = 0.01 ! cld +! -- interface with boundary-layer (gust factor): (sb) + betad = 10.0 ! original value (from convect 4.3) + +! Var interm pour le getin + cv_flag_feed=1 + CALL getin_p('cv_flag_feed',cv_flag_feed) + T_top_max = 1000. + CALL getin_p('t_top_max',T_top_max) + dpbase=-40. + CALL getin_p('dpbase',dpbase) + pbcrit=150.0 + CALL getin_p('pbcrit',pbcrit) + ptcrit=500.0 + CALL getin_p('ptcrit',ptcrit) + sigdz=0.01 + CALL getin_p('sigdz',sigdz) + spfac=0.15 + CALL getin_p('spfac',spfac) + tau=8000. + CALL getin_p('tau',tau) + flag_wb=1 + CALL getin_p('flag_wb',flag_wb) + wbmax=6. + CALL getin_p('wbmax',wbmax) + ok_convstop=.False. + CALL getin_p('ok_convstop',ok_convstop) + tau_stop=15000. + CALL getin_p('tau_stop',tau_stop) + ok_intermittent=.False. + CALL getin_p('ok_intermittent',ok_intermittent) + ok_optim_yield=.False. + CALL getin_p('ok_optim_yield',ok_optim_yield) + ok_homo_tend=.TRUE. + CALL getin_p('ok_homo_tend',ok_homo_tend) + ok_entrain=.TRUE. + CALL getin_p('ok_entrain',ok_entrain) + + coef_peel=0.25 + CALL getin_p('coef_peel',coef_peel) + + flag_epKEorig=1 + CALL getin_p('flag_epKEorig',flag_epKEorig) + elcrit=0.0003 + CALL getin_p('elcrit',elcrit) + tlcrit=-55.0 + CALL getin_p('tlcrit',tlcrit) + ejectliq=0. + CALL getin_p('ejectliq',ejectliq) + ejectice=0. + CALL getin_p('ejectice',ejectice) + cvflag_prec_eject = .FALSE. + CALL getin_p('cvflag_prec_eject',cvflag_prec_eject) + qsat_depends_on_qt = .FALSE. + CALL getin_p('qsat_depends_on_qt',qsat_depends_on_qt) + adiab_ascent_mass_flux_depends_on_ejectliq = .FALSE. + CALL getin_p('adiab_ascent_mass_flux_depends_on_ejectliq',adiab_ascent_mass_flux_depends_on_ejectliq) + keepbug_ice_frac = .TRUE. + CALL getin_p('keepbug_ice_frac', keepbug_ice_frac) + keep_bug_indices_cv3_tracer = .FALSE. + CALL getin_p('keep_bug_indices_cv3_tracer', keep_bug_indices_cv3_tracer) + restore_bug_cvdn=.false. + CALL getin_p('restore_bug_cvdn',restore_bug_cvdn) + + + WRITE (*, *) 't_top_max=', t_top_max + WRITE (*, *) 'dpbase=', dpbase + WRITE (*, *) 'pbcrit=', pbcrit + WRITE (*, *) 'ptcrit=', ptcrit + WRITE (*, *) 'sigdz=', sigdz + WRITE (*, *) 'spfac=', spfac + WRITE (*, *) 'tau=', tau + WRITE (*, *) 'flag_wb=', flag_wb + WRITE (*, *) 'wbmax=', wbmax + WRITE (*, *) 'ok_convstop=', ok_convstop + WRITE (*, *) 'tau_stop=', tau_stop + WRITE (*, *) 'ok_intermittent=', ok_intermittent + WRITE (*, *) 'ok_optim_yield =', ok_optim_yield + WRITE (*, *) 'coef_peel=', coef_peel + + WRITE (*, *) 'flag_epKEorig=', flag_epKEorig + WRITE (*, *) 'elcrit=', elcrit + WRITE (*, *) 'tlcrit=', tlcrit + WRITE (*, *) 'ejectliq=', ejectliq + WRITE (*, *) 'ejectice=', ejectice + WRITE (*, *) 'cvflag_prec_eject =', cvflag_prec_eject + WRITE (*, *) 'qsat_depends_on_qt =', qsat_depends_on_qt + WRITE (*, *) 'adiab_ascent_mass_flux_depends_on_ejectliq =', adiab_ascent_mass_flux_depends_on_ejectliq + WRITE (*, *) 'keepbug_ice_frac =', keepbug_ice_frac + WRITE (*, *) 'keep_bug_indices_cv3_tracer =', keep_bug_indices_cv3_tracer + WRITE (*, *) 'restore_bug_cvdn=',restore_bug_cvdn + + first = .FALSE. + END IF ! (first) + + beta = 1.0 - delt/tau + alpha1 = 1.5E-3 +!JYG Correction bug alpha + alpha1 = alpha1*1.5 + alpha = alpha1*delt/tau +!JYG Bug +! cc increase alpha to compensate W decrease: +! c alpha = alpha*1.5 + + noconv_stop = max(2.,tau_stop/delt) + + RETURN +END SUBROUTINE cv3_param + +SUBROUTINE cv3_incrcount(len, nd, delt, sig) + + USE lmdz_cv_ini, ONLY : noconv_stop + USE cvflag_mod_h + IMPLICIT NONE + +! ===================================================================== +! Increment the counter sig(nd) +! ===================================================================== + +!inputs: + INTEGER, INTENT(IN) :: len + INTEGER, INTENT(IN) :: nd + REAL, INTENT(IN) :: delt ! timestep (seconds) + +!input/output + REAL, DIMENSION(len,nd), INTENT(INOUT) :: sig + +!local variables + INTEGER il + +! print *,'cv3_incrcount : noconv_stop ',noconv_stop +! print *,'cv3_incrcount in, sig(1,nd) ',sig(1,nd) + IF(ok_convstop) THEN + DO il = 1, len + sig(il, nd) = sig(il, nd) + 1. + sig(il, nd) = min(sig(il,nd), noconv_stop+0.1) + END DO + ELSE + DO il = 1, len + sig(il, nd) = sig(il, nd) + 1. + sig(il, nd) = min(sig(il,nd), 12.1) + END DO + ENDIF ! (ok_convstop) +! print *,'cv3_incrcount out, sig(1,nd) ',sig(1,nd) + + RETURN +END SUBROUTINE cv3_incrcount + +SUBROUTINE cv3_prelim(len, nd, ndp1, t, q, p, ph, & + lv, lf, cpn, tv, gz, h, hm, th) + USE lmdz_cv_ini, ONLY : cl,clmci,clmcpv,cpd,cpv,eps,lf0,lv0,nl,nlp,rrd,rrv + IMPLICIT NONE + +! ===================================================================== +! --- CALCULATE ARRAYS OF GEOPOTENTIAL, HEAT CAPACITY & STATIC ENERGY +! "ori": from convect4.3 (vectorized) +! "convect3": to be exactly consistent with convect3 +! ===================================================================== + +! inputs: + INTEGER len, nd, ndp1 + REAL t(len, nd), q(len, nd), p(len, nd), ph(len, ndp1) + +! outputs: + REAL lv(len, nd), lf(len, nd), cpn(len, nd), tv(len, nd) + REAL gz(len, nd), h(len, nd), hm(len, nd) + REAL th(len, nd) + +! local variables: + INTEGER k, i + REAL rdcp + REAL tvx, tvy ! convect3 + REAL cpx(len, nd) +! ori do 110 k=1,nlp +! abderr do 110 k=1,nl ! convect3 + DO k = 1, nlp + + DO i = 1, len +! debug lv(i,k)= lv0-clmcpv*(t(i,k)-t0) + lv(i, k) = lv0 - clmcpv*(t(i,k)-273.15) +!! lf(i, k) = lf0 - clmci*(t(i,k)-273.15) ! erreur de signe !! + lf(i, k) = lf0 + clmci*(t(i,k)-273.15) + cpn(i, k) = cpd*(1.0-q(i,k)) + cpv*q(i, k) + cpx(i, k) = cpd*(1.0-q(i,k)) + cl*q(i, k) +! 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 + END DO + END DO + +! gz = phi at the full levels (same as p). + +!! DO i = 1, len !jyg +!! gz(i, 1) = 0.0 !jyg +!! END DO !jyg + gz(:,:) = 0. !jyg: initialization of the whole array +! ori do 140 k=2,nlp + DO k = 2, nl ! convect3 + DO 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 print *,' gz(',k,')',gz(i,k),' tvx',tvx,' tvy ',tvy + +! ori gz(i,k)=gz(i,k-1)+hrd*(tv(i,k-1)+tv(i,k)) +! ori & *(p(i,k-1)-p(i,k))/ph(i,k) + END DO + END DO + +! h = phi + cpT (dry static energy). +! hm = phi + cp(T-Tbase)+Lq + +! ori do 170 k=1,nlp + DO k = 1, nl ! convect3 + DO 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) + END DO + END DO + + RETURN +END SUBROUTINE cv3_prelim + + +SUBROUTINE cv3_feed_pre(ok_conserv_q) +USE mod_phys_lmdz_transfert_para, ONLY : bcast +IMPLICIT NONE + LOGICAL, INTENT (IN) :: ok_conserv_q + INTEGER :: iostat + + IF (cv3_feed_first) THEN + +!$OMP MASTER + ok_new_feed = ok_conserv_q + OPEN (98, FILE='cv3feed_param.data', STATUS='old', FORM='formatted', IOSTAT=iostat) + IF (iostat==0) THEN + READ (98, *, END=998) ok_new_feed +998 CONTINUE + CLOSE (98) + END IF + PRINT *, ' ok_new_feed: ', ok_new_feed +!$OMP END MASTER + call bcast(ok_new_feed) + cv3_feed_first = .FALSE. + END IF + +END SUBROUTINE cv3_feed_pre + + +SUBROUTINE cv3_feed(len, nd, ok_conserv_q, & + t, q, u, v, p, ph, h, gz, & + p1feed, p2feed, wght, & + wghti, tnk, thnk, qnk, qsnk, unk, vnk, & + cpnk, hnk, nk, icb, icbmax, iflag, gznk, plcl) + + USE add_phys_tend_mod, ONLY: fl_cor_ebil + USE print_control_mod, ONLY: prt_level + USE lmdz_cv_ini, ONLY : cpd,cpv,cv_flag_feed,minorig,nl,nlm,cl + USE cv3_estatmix_mod, ONLY : cv3_estatmix + USE cv3_enthalpmix_mod, ONLY : cv3_enthalpmix + IMPLICIT NONE + +! ================================================================ +! Purpose: CONVECTIVE FEED + +! Main differences with cv_feed: +! - ph added in input +! - here, nk(i)=minorig +! - icb defined differently (plcl compared with ph instead of p) +! - dry static energy as argument instead of moist static energy + +! Main differences with convect3: +! - we do not compute dplcldt and dplcldr of CLIFT anymore +! - values iflag different (but tests identical) +! - A,B explicitely defined (!...) +! ================================================================ + +!inputs: + INTEGER, INTENT (IN) :: len, nd + LOGICAL, INTENT (IN) :: ok_conserv_q + REAL, DIMENSION (len, nd), INTENT (IN) :: t, q, p + REAL, DIMENSION (len, nd), INTENT (IN) :: u, v + REAL, DIMENSION (len, nd), INTENT (IN) :: h, gz + REAL, DIMENSION (len, nd+1), INTENT (IN) :: ph + REAL, DIMENSION (len), INTENT (IN) :: p1feed + REAL, DIMENSION (nd), INTENT (IN) :: wght +!input-output + REAL, DIMENSION (len), INTENT (INOUT) :: p2feed +!outputs: + INTEGER, INTENT (OUT) :: icbmax + INTEGER, DIMENSION (len), INTENT (OUT) :: iflag, nk, icb + REAL, DIMENSION (len, nd), INTENT (OUT) :: wghti + REAL, DIMENSION (len), INTENT (OUT) :: tnk, thnk, qnk, qsnk + REAL, DIMENSION (len), INTENT (OUT) :: unk, vnk + REAL, DIMENSION (len), INTENT (OUT) :: cpnk, hnk, gznk + REAL, DIMENSION (len), INTENT (OUT) :: plcl + +!local variables: + INTEGER i, k, iter, niter + INTEGER ihmin(len) + REAL work(len) + REAL pup(len), plo(len), pfeed(len) + REAL plclup(len), plcllo(len), plclfeed(len) + REAL pfeedmin(len) + REAL posit(len) + LOGICAL nocond(len) + +!jyg20140217< + REAL, PARAMETER :: dp_lcl_feed = 2. + +!jyg> +! ------------------------------------------------------------------- +! --- Origin level of ascending parcels for convect3: +! ------------------------------------------------------------------- + + DO i = 1, len + nk(i) = minorig + gznk(i) = gz(i, nk(i)) + END DO + +! ------------------------------------------------------------------- +! --- Adjust feeding layer thickness so that lifting up to the top of +! --- the feeding layer does not induce condensation (i.e. so that +! --- plcl < p2feed). +! --- Method : iterative secant method. +! ------------------------------------------------------------------- + +! 1- First bracketing of the solution : ph(nk+1), p2feed + +! 1.a- LCL associated with p2feed + DO i = 1, len + pup(i) = p2feed(i) + END DO + IF (fl_cor_ebil >=2 ) THEN + CALL cv3_estatmix(len, nd, iflag, p1feed, pup, p, ph, & + t, q, u, v, h, gz, wght, & + wghti, nk, tnk, thnk, qnk, qsnk, unk, vnk, plclup) + ELSE + CALL cv3_enthalpmix(len, nd, iflag, p1feed, pup, p, ph, & + t, q, u, v, wght, & + wghti, nk, tnk, thnk, qnk, qsnk, unk, vnk, plclup) + ENDIF ! (fl_cor_ebil >=2 ) +! 1.b- LCL associated with ph(nk+1) + DO i = 1, len + plo(i) = ph(i, nk(i)+1) + END DO + IF (fl_cor_ebil >=2 ) THEN + CALL cv3_estatmix(len, nd, iflag, p1feed, plo, p, ph, & + t, q, u, v, h, gz, wght, & + wghti, nk, tnk, thnk, qnk, qsnk, unk, vnk, plcllo) + ELSE + CALL cv3_enthalpmix(len, nd, iflag, p1feed, plo, p, ph, & + t, q, u, v, wght, & + wghti, nk, tnk, thnk, qnk, qsnk, unk, vnk, plcllo) + ENDIF ! (fl_cor_ebil >=2 ) +! 2- Iterations + niter = 5 + DO iter = 1, niter + DO i = 1, len + plcllo(i) = min(plo(i), plcllo(i)) + plclup(i) = max(pup(i), plclup(i)) + nocond(i) = plclup(i) <= pup(i) + END DO + DO i = 1, len + IF (nocond(i)) THEN + pfeed(i) = pup(i) + ELSE +!JYG20140217< + IF (ok_new_feed) THEN + pfeed(i) = (pup(i)*(plo(i)-plcllo(i)-dp_lcl_feed)+ & + plo(i)*(plclup(i)-pup(i)+dp_lcl_feed))/ & + (plo(i)-plcllo(i)+plclup(i)-pup(i)) + ELSE + pfeed(i) = (pup(i)*(plo(i)-plcllo(i))+ & + plo(i)*(plclup(i)-pup(i)))/ & + (plo(i)-plcllo(i)+plclup(i)-pup(i)) + END IF +!JYG> + END IF + END DO +!jyg20140217< +! For the last iteration, make sure that the top of the feeding layer +! and LCL are not in the same layer: + IF (ok_new_feed) THEN + IF (iter==niter) THEN + DO i = 1,len !jyg + pfeedmin(i) = ph(i,minorig+1) !jyg + ENDDO !jyg + DO k = minorig+1, nl !jyg +!! DO k = minorig, nl !jyg + DO i = 1, len + IF (ph(i,k)>=plclfeed(i)) pfeedmin(i) = ph(i, k) + END DO + END DO + DO i = 1, len + pfeed(i) = max(pfeedmin(i), pfeed(i)) + END DO + END IF + END IF +!jyg> + + IF (fl_cor_ebil >=2 ) THEN + CALL cv3_estatmix(len, nd, iflag, p1feed, pfeed, p, ph, & + t, q, u, v, h, gz, wght, & + wghti, nk, tnk, thnk, qnk, qsnk, unk, vnk, plclfeed) + ELSE + CALL cv3_enthalpmix(len, nd, iflag, p1feed, pfeed, p, ph, & + t, q, u, v, wght, & + wghti, nk, tnk, thnk, qnk, qsnk, unk, vnk, plclfeed) + ENDIF ! (fl_cor_ebil >=2 ) +!jyg20140217< + IF (ok_new_feed) THEN + DO i = 1, len + posit(i) = (sign(1.,plclfeed(i)-pfeed(i)+dp_lcl_feed)+1.)*0.5 + IF (plclfeed(i)-pfeed(i)+dp_lcl_feed==0.) posit(i) = 1. + END DO + ELSE + DO i = 1, len + posit(i) = (sign(1.,plclfeed(i)-pfeed(i))+1.)*0.5 + IF (plclfeed(i)==pfeed(i)) posit(i) = 1. + END DO + END IF +!jyg> + DO i = 1, len +! - posit = 1 when lcl is below top of feeding layer (plclfeed>pfeed) +! - => pup=pfeed +! - posit = 0 when lcl is above top of feeding layer (plclfeed plo=pfeed + pup(i) = posit(i)*pfeed(i) + (1.-posit(i))*pup(i) + plo(i) = (1.-posit(i))*pfeed(i) + posit(i)*plo(i) + plclup(i) = posit(i)*plclfeed(i) + (1.-posit(i))*plclup(i) + plcllo(i) = (1.-posit(i))*plclfeed(i) + posit(i)*plcllo(i) + END DO + END DO ! iter + + DO i = 1, len + p2feed(i) = pfeed(i) + plcl(i) = plclfeed(i) + END DO + + DO i = 1, len + cpnk(i) = cpd*(1.0-qnk(i)) + cpv*qnk(i) + hnk(i) = gz(i, 1) + cpnk(i)*tnk(i) + END DO + +! ------------------------------------------------------------------- +! --- Check whether parcel level temperature and specific humidity +! --- are reasonable +! ------------------------------------------------------------------- + IF (cv_flag_feed == 1) THEN + DO i = 1, len + IF (((tnk(i)<250.0) .OR. & + (qnk(i)<=0.0)) .AND. & + (iflag(i)==0)) iflag(i) = 7 + END DO + ELSEIF (cv_flag_feed >= 2) THEN +! --- and demand that LCL be high enough + DO i = 1, len + IF (((tnk(i)<250.0) .OR. & + (qnk(i)<=0.0) .OR. & + (plcl(i)>min(0.99*ph(i,1),ph(i,3)))) .AND. & + (iflag(i)==0)) iflag(i) = 7 + END DO + ENDIF + IF (prt_level .GE. 10) THEN + print *,'cv3_feed : iflag(1), pfeed(1), plcl(1), wghti(1,k) ', & + iflag(1), pfeed(1), plcl(1), (wghti(1,k),k=1,10) + ENDIF + +! ------------------------------------------------------------------- +! --- 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 + + DO i = 1, len + icb(i) = nlm + END DO + +! la modification consiste a comparer plcl a ph et non a p: +! icb est defini par : ph(icb)p(icb), then icbs=icb + +! * the routine above computes tvp from minorig to icbs (included). + +! * to compute buoybase (in cv3_trigger.F), both tvp(icb) and tvp(icb+1) +! must be known. This is the case if icbs=icb+1, but not if icbs=icb. + +! * therefore, in the case icbs=icb, we compute tvp at level icb+1 +! (tvp at other levels will be computed in cv3_undilute2.F) + + + 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) + END DO + + DO i = 1, len + tg = ticb(i) + qg = qsicb(i) ! convect3 +! debug alv=lv0-clmcpv*(ticb(i)-t0) + alv = lv0 - clmcpv*(ticb(i)-273.15) + +! First iteration. + +! 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 +! 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) +! ori tg=max(tg,35.0) +! debug tc=tg-t0 + tc = tg - 273.15 + denom = 243.5 + tc + denom = max(denom, 1.0) ! convect3 +! ori if(tc.ge.0.0)then + es = 6.112*exp(17.67*tc/denom) +! ori else +! ori es=exp(23.33086-6111.72784/tg+0.15215*log(tg)) +! ori endif +! ori qg=eps*es/(p(i,icb(i))-es*(1.-eps)) + qg = eps*es/(p(i,icb(i)+1)-es*(1.-eps)) + +! Second iteration. + + +! ori s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i)) +! ori s=1./s +! 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) +! ori tg=max(tg,35.0) +! debug tc=tg-t0 + tc = tg - 273.15 + denom = 243.5 + tc + denom = max(denom, 1.0) ! convect3 +! ori if(tc.ge.0.0)then + es = 6.112*exp(17.67*tc/denom) +! ori else +! ori es=exp(23.33086-6111.72784/tg+0.15215*log(tg)) +! ori end if +! 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) + +! ori c approximation here: +! ori tp(i,icb(i))=(ah0(i)-(cl-cpd)*qnk(i)*ticb(i) +! ori & -gz(i,icb(i))-alv*qg)/cpd + +! convect3: no approximation: + tp(i, icb(i)+1) = (ah0(i)-gz(i,icb(i)+1)-alv*qg)/(cpd+(cl-cpd)*qnk(i)) + +! ori clw(i,icb(i))=qnk(i)-qg +! 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)) +! ori tvp(i,icb(i))=tp(i,icb(i))*(1.+rg*epsi) +! 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 + + END DO + + RETURN +END SUBROUTINE cv3_undilute1 + +SUBROUTINE cv3_trigger(len, nd, icb, plcl, p, th, tv, tvp, thnk, & + pbase, buoybase, iflag, sig, w0) + USE lmdz_cv_ini, ONLY : alpha,beta,dpbase,dtcrit,dttrig,nl + 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=14 +! (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 +! ------------------------------------------------------------------- + +! input: + INTEGER len, nd + INTEGER icb(len) + REAL plcl(len), p(len, nd) + REAL th(len, nd), tv(len, nd), tvp(len, nd) + REAL thnk(len) + +! output: + REAL pbase(len), buoybase(len) + +! input AND output: + INTEGER iflag(len) + REAL sig(len, nd), w0(len, nd) + +! local variables: + INTEGER i, k + REAL tvpbase, tvbase, tdif, ath, ath1 + + +! *** set cloud base buoyancy at (plcl+dpbase) level buoyancy + + DO 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 + END DO + + +! *** make sure that column is dry adiabatic between the surface *** +! *** and cloud base, and that lifted air is positively buoyant *** +! *** at cloud base *** +! *** if not, return to calling program after resetting *** +! *** sig(i) and w0(i) *** + + +! oct3 do 200 i=1,len +! oct3 +! oct3 tdif = buoybase(i) +! oct3 ath1 = th(i,1) +! oct3 ath = th(i,icb(i)-1) - dttrig +! oct3 +! oct3 if (tdif.lt.dtcrit .or. ath.gt.ath1) then +! oct3 do 60 k=1,nl +! oct3 sig(i,k) = beta*sig(i,k) - 2.*alpha*tdif*tdif +! oct3 sig(i,k) = AMAX1(sig(i,k),0.0) +! oct3 w0(i,k) = beta*w0(i,k) +! oct3 60 continue +! oct3 iflag(i)=4 ! pour version vectorisee +! oct3c convect3 iflag(i)=0 +! oct3cccc return +! oct3 endif +! oct3 +! oct3200 continue + +! -- oct3: on reecrit la boucle 200 (pour la vectorisation) + + DO k = 1, nl + DO i = 1, len + + tdif = buoybase(i) + ath1 = thnk(i) + ath = th(i, icb(i)-1) - dttrig + + IF (tdifath1) 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) = 14 ! pour version vectorisee +! convect3 iflag(i)=0 + END IF + + END DO + END DO + +! fin oct3 -- + + RETURN +END SUBROUTINE cv3_trigger + +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, & + iflag, nk, icb, icbs, & + plcl, tnk, qnk, gznk, pbase, buoybase, & + t, q, qs, u, v, gz, th, & + tra, & + h, lv, cpn, p, ph, tv, tp, tvp, clw, & + sig, w0) + USE lmdz_cv_ini, ONLY : nl + USE print_control_mod, ONLY: lunout + IMPLICIT NONE + + +!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) + +!outputs: +! 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) + +!local variables: + INTEGER i, k, nn, j + + CHARACTER (LEN=20) :: modname = 'cv3_compress' + CHARACTER (LEN=80) :: abort_message + + DO k = 1, nl + 1 + nn = 0 + DO i = 1, len + IF (iflag1(i)==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) + END IF + END DO + END DO + +!AC! do 121 j=1,ntra +!AC!ccccc do 111 k=1,nl+1 +!AC! do 111 k=1,nd +!AC! nn=0 +!AC! do 101 i=1,len +!AC! if(iflag1(i).eq.0)then +!AC! nn=nn+1 +!AC! tra(nn,k,j)=tra1(i,k,j) +!AC! endif +!AC! 101 continue +!AC! 111 continue +!AC! 121 continue + + IF (nn/=ncum) THEN + WRITE (lunout, *) 'strange! nn not equal to ncum: ', nn, ncum + abort_message = '' + CALL abort_physic(modname, abort_message, 1) + END IF + + nn = 0 + DO i = 1, len + IF (iflag1(i)==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) + END IF + END DO + + RETURN +END SUBROUTINE cv3_compress + +SUBROUTINE icefrac(t, clw, qi, nl, len) + IMPLICIT NONE + + +!JAM-------------------------------------------------------------------- +! Calcul de la quantit� d'eau sous forme de glace +! -------------------------------------------------------------------- + INTEGER nl, len + REAL qi(len, nl) + REAL t(len, nl), clw(len, nl) + REAL fracg + INTEGER k, i + + DO k = 3, nl + DO i = 1, len + IF (t(i,k)>263.15) THEN + qi(i, k) = 0. + ELSE + IF (t(i,k)<243.15) THEN + qi(i, k) = clw(i, k) + ELSE + fracg = (263.15-t(i,k))/20 + qi(i, k) = clw(i, k)*fracg + END IF + END IF +! print*,t(i,k),qi(i,k),'temp,testglace' + END DO + END DO + + RETURN + +END SUBROUTINE icefrac + +SUBROUTINE cv3_undilute2(nloc, ncum, nd, iflag, icb, icbs, nk, & + tnk, qnk, gznk, hnk, t, q, qs, gz, & + p, ph, h, tv, lv, lf, pbase, buoybase, plcl, & + inb, tp, tvp, clw, hp, ep, sigp, buoy, & + frac_a, frac_s, qpreca, qta) + USE print_control_mod, ONLY: prt_level + USE cvflag_mod_h + USE conema3_mod_h + USE lmdz_cv_ini, ONLY : cl,clmci,clmcpv,cpd,cpv,dtovsh,ejectice,ejectliq,elcrit + USE lmdz_cv_ini, ONLY : eps,flag_epkeorig,lf0,lv0,minorig,nl,nlp,pbcrit,ptcrit,rrd,rrv,spfac,t0,t_top_max,tlcrit + USE yomcst2_mod_h + IMPLICIT NONE + +! --------------------------------------------------------------------- +! Purpose: +! 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 + +! Main differences convect3/convect4: +! - icbs (input) is the first level above LCL (may differ from icb) +! - many minor differences in the iterations +! - condensed water not removed from tvp in convect3 +! - vertical profile of buoyancy computed here (use of buoybase) +! - the determination of inb is different +! - no inb1, only inb in output +! --------------------------------------------------------------------- + +!inputs: + INTEGER, INTENT (IN) :: ncum, nd, nloc + INTEGER, DIMENSION (nloc), INTENT (IN) :: icb, icbs, nk + REAL, DIMENSION (nloc, nd), INTENT (IN) :: t, q, qs, gz + REAL, DIMENSION (nloc, nd), INTENT (IN) :: p + REAL, DIMENSION (nloc, nd+1), INTENT (IN) :: ph + REAL, DIMENSION (nloc), INTENT (IN) :: tnk, qnk, gznk + REAL, DIMENSION (nloc), INTENT (IN) :: hnk + REAL, DIMENSION (nloc, nd), INTENT (IN) :: lv, lf, tv, h + REAL, DIMENSION (nloc), INTENT (IN) :: pbase, buoybase, plcl + +!input/outputs: + REAL, DIMENSION (nloc, nd), INTENT (INOUT) :: tp, tvp, clw ! Input for k = 1, icb+1 (computed in cv3_undilute1) + ! Output above + INTEGER, DIMENSION (nloc), INTENT (INOUT) :: iflag + +!outputs: + INTEGER, DIMENSION (nloc), INTENT (OUT) :: inb + REAL, DIMENSION (nloc, nd), INTENT (OUT) :: ep, sigp, hp + REAL, DIMENSION (nloc, nd), INTENT (OUT) :: buoy + REAL, DIMENSION (nloc, nd), INTENT (OUT) :: frac_a, frac_s + REAL, DIMENSION (nloc, nd), INTENT (OUT) :: qpreca + REAL, DIMENSION (nloc, nd), INTENT (OUT) :: qta + +!local variables: + INTEGER i, j, k + REAL smallestreal + REAL tg, qg, dqgdT, ahg, alv, alf, s, tc, es, esi, denom, rg, tca, elacrit + REAL :: phinu2p + REAL :: qhthreshold + REAL :: als + REAL :: qsat_new, snew + REAL, DIMENSION (nloc,nd) :: qi + REAL, DIMENSION (nloc,nd) :: ha ! moist static energy of adiabatic ascents + ! taking into account precip ejection + REAL, DIMENSION (nloc,nd) :: hla ! liquid water static energy of adiabatic ascents + ! taking into account precip ejection + REAL, DIMENSION (nloc,nd) :: qcld ! specific cloud water + REAL, DIMENSION (nloc,nd) :: qhsat ! specific humidity at saturation + REAL, DIMENSION (nloc,nd) :: dqhsatdT ! dqhsat/dT + REAL, DIMENSION (nloc,nd) :: frac ! ice fraction function of envt temperature + REAL, DIMENSION (nloc,nd) :: qps ! specific solid precipitation + REAL, DIMENSION (nloc,nd) :: qpl ! specific liquid precipitation + REAL, DIMENSION (nloc) :: ah0, cape, capem, byp + LOGICAL, DIMENSION (nloc) :: lcape + INTEGER, DIMENSION (nloc) :: iposit + REAL :: denomm1 + REAL :: by, defrac, pden, tbis + REAL :: fracg + REAL :: deltap + REAL, PARAMETER :: Tx=263.15 + REAL, PARAMETER :: Tm=243.15 + REAL :: aa, bb, dd, ddelta, discr + REAL :: ff, fp + REAL :: coefx, coefm, Zx, Zm, Ux, U, Um + + IF (prt_level >= 10) THEN + print *,'cv3_undilute2.0. icvflag_Tpa, t(1,k), q(1,k), qs(1,k) ', & + icvflag_Tpa, (k, t(1,k), q(1,k), qs(1,k), k = 1,nl) + ENDIF + smallestreal=tiny(smallestreal) + +! ===================================================================== +! --- SOME INITIALIZATIONS +! ===================================================================== + + DO k = 1, nl + DO i = 1, ncum + qi(i, k) = 0. + END DO + END DO + + +! ===================================================================== +! --- FIND THE REST OF THE LIFTED PARCEL TEMPERATURES +! ===================================================================== + +! --- The procedure is to solve the equation. +! cp*tp+L*qp+phi=cp*tnk+L*qnk+gznk. + +! *** Calculate certain parcel quantities, including static energy *** + + + DO i = 1, ncum + ah0(i) = (cpd*(1.-qnk(i))+cl*qnk(i))*tnk(i)+ & +! debug qnk(i)*(lv0-clmcpv*(tnk(i)-t0))+gznk(i) + qnk(i)*(lv0-clmcpv*(tnk(i)-273.15)) + gznk(i) + END DO +! +! Ice fraction +! + IF (cvflag_ice) THEN + DO k = minorig, nl + DO i = 1, ncum + frac(i, k) = (Tx - t(i,k))/(Tx - Tm) + frac(i, k) = min(max(frac(i,k),0.0), 1.0) + END DO + END DO +! Below cloud base, set ice fraction to cloud base value + DO k = 1, nl + DO i = 1, ncum + IF (kjyg +! + +! *** Find lifted parcel quantities above cloud base *** + +!---------------------------------------------------------------------------- +! + IF (icvflag_Tpa == 2) THEN +! +!---------------------------------------------------------------------------- +! + DO k = minorig + 1, nl + DO i = 1,ncum + tp(i,k) = t(i,k) + ENDDO +!! alv = lv0 - clmcpv*(t(i,k)-273.15) +!! alf = lf0 + clmci*(t(i,k)-273.15) +!! als = alf + alv + DO j = 1,4 + DO i = 1, ncum +! ori if(k.ge.(icb(i)+1))then + IF (k>=(icbs(i)+1)) THEN ! convect3 + tg = tp(i, k) + IF (tg .gt. Tx) THEN + es = 6.112*exp(17.67*(tg - 273.15)/(tg + 243.5 - 273.15)) + qg = eps*es/(p(i,k)-es*(1.-eps)) + ELSE + esi = exp(23.33086-(6111.72784/tg)+0.15215*log(tg)) + qg = eps*esi/(p(i,k)-esi*(1.-eps)) + ENDIF +! Ice fraction + ff = 0. + fp = 1./(Tx - Tm) + IF (tg < Tx) THEN + IF (tg > Tm) THEN + ff = (Tx - tg)*fp + ELSE + ff = 1. + ENDIF ! (tg > Tm) + ENDIF ! (tg < Tx) +! Intermediate variables + aa = cpd + (cl-cpd)*qnk(i) + lv(i,k)*lv(i,k)*qg/(rrv*tg*tg) + ahg = (cpd + (cl-cpd)*qnk(i))*tg + lv(i,k)*qg - & + lf(i,k)*ff*(qnk(i) - qg) + gz(i,k) + dd = lf(i,k)*lv(i,k)*qg/(rrv*tg*tg) + ddelta = lf(i,k)*(qnk(i) - qg) + bb = aa + ddelta*fp + dd*fp*(Tx-tg) +! Compute Zx and Zm + coefx = aa + coefm = aa + dd + IF (tg .gt. Tx) THEN + Zx = ahg + coefx*(Tx - tg) + Zm = ahg - ddelta + coefm*(Tm - tg) + ELSE + IF (tg .gt. Tm) THEN + Zx = ahg + (coefx +fp*ddelta)*(Tx - Tg) + Zm = ahg + (coefm +fp*ddelta)*(Tm - Tg) + ELSE + Zx = ahg + ddelta + coefx*(Tx - tg) + Zm = ahg + coefm*(Tm - tg) + ENDIF ! (tg .gt. Tm) + ENDIF ! (tg .gt. Tx) +! Compute the masks Um, U, Ux + Um = (sign(1., Zm-ah0(i))+1.)/2. + Ux = (sign(1., ah0(i)-Zx)+1.)/2. + U = (1. - Um)*(1. - Ux) +! Compute the updated parcell temperature Tp : 3 cases depending on tg value + IF (tg .gt. Tx) THEN + discr = bb*bb - 4*dd*fp*(ah0(i) - ahg + ddelta*fp*(Tx-tg)) + Tp(i,k) = tg + & + Um* (ah0(i) - ahg + ddelta) /(aa + dd) + & + U *2*(ah0(i) - ahg + ddelta*fp*(Tx-tg))/(bb + sqrt(discr)) + & + Ux* (ah0(i) - ahg) /aa + ELSEIF (tg .gt. Tm) THEN + discr = bb*bb - 4*dd*fp*(ah0(i) - ahg) + Tp(i,k) = tg + & + Um* (ah0(i) - ahg + ddelta*fp*(tg-Tm))/(aa + dd) + & + U *2*(ah0(i) - ahg) /(bb + sqrt(discr)) + & + Ux* (ah0(i) - ahg + ddelta*fp*(tg-Tx))/aa + ELSE + discr = bb*bb - 4*dd*fp*(ah0(i) - ahg + ddelta*fp*(Tm-tg)) + Tp(i,k) = tg + & + Um* (ah0(i) - ahg) /(aa + dd) + & + U *2*(ah0(i) - ahg + ddelta*fp*(Tm-tg))/(bb + sqrt(discr)) + & + Ux* (ah0(i) - ahg - ddelta) /aa + ENDIF ! (tg .gt. Tx) +! +!! print *,' j, k, Um, U, Ux, aa, bb, discr, dd, ddelta ', j, k, Um, U, Ux, aa, bb, discr, dd, ddelta +!! print *,' j, k, ah0(i), ahg, tg, qg, tp(i,k), ff ', j, k, ah0(i), ahg, tg, qg, tp(i,k), ff + END IF ! (k>=(icbs(i)+1)) + END DO ! i = 1, ncum + END DO ! j = 1,4 + DO i = 1, ncum + IF (k>=(icbs(i)+1)) THEN ! convect3 + tg = tp(i, k) + IF (tg .gt. Tx) THEN + es = 6.112*exp(17.67*(tg - 273.15)/(tg + 243.5 - 273.15)) + qg = eps*es/(p(i,k)-es*(1.-eps)) + ELSE + esi = exp(23.33086-(6111.72784/tg)+0.15215*log(tg)) + qg = eps*esi/(p(i,k)-esi*(1.-eps)) + ENDIF + clw(i, k) = qnk(i) - qg + clw(i, k) = max(0.0, clw(i,k)) + tvp(i, k) = max(0., tp(i,k)*(1.+qg/eps-qnk(i))) +! print*,tvp(i,k),'tvp' + IF (clw(i,k)<1.E-11) THEN + tp(i, k) = tv(i, k) + tvp(i, k) = tv(i, k) + END IF ! (clw(i,k)<1.E-11) + END IF ! (k>=(icbs(i)+1)) + END DO ! i = 1, ncum + END DO ! k = minorig + 1, nl +!---------------------------------------------------------------------------- +! + ELSE IF (icvflag_Tpa == 1) THEN ! (icvflag_Tpa == 2) +! +!---------------------------------------------------------------------------- +! + DO k = minorig + 1, nl + DO i = 1,ncum + tp(i,k) = t(i,k) + ENDDO +!! alv = lv0 - clmcpv*(t(i,k)-273.15) +!! alf = lf0 + clmci*(t(i,k)-273.15) +!! als = alf + alv + DO j = 1,4 + DO i = 1, ncum +! ori if(k.ge.(icb(i)+1))then + IF (k>=(icbs(i)+1)) THEN ! convect3 + tg = tp(i, k) + IF (tg .gt. Tx .OR. .NOT.cvflag_ice) THEN + es = 6.112*exp(17.67*(tg - 273.15)/(tg + 243.5 - 273.15)) + qg = eps*es/(p(i,k)-es*(1.-eps)) + dqgdT = lv(i,k)*qg/(rrv*tg*tg) + ELSE + esi = exp(23.33086-(6111.72784/tg)+0.15215*log(tg)) + qg = eps*esi/(p(i,k)-esi*(1.-eps)) + dqgdT = (lv(i,k)+lf(i,k))*qg/(rrv*tg*tg) + ENDIF + IF (qsat_depends_on_qt) THEN + dqgdT = dqgdT*(1.-qta(i,k-1))/(1.-qg)**2 + qg = qg*(1.-qta(i,k-1))/(1.-qg) + ENDIF + ahg = (cpd + (cl-cpd)*qta(i,k-1))*tg + lv(i,k)*qg - & + lf(i,k)*frac(i,k)*(qta(i,k-1) - qg) + gz(i,k) + Tp(i,k) = tg + (ah0(i) - ahg)/ & + (cpd + (cl-cpd)*qta(i,k-1) + (lv(i,k)+frac(i,k)*lf(i,k))*dqgdT) +!! print *,'undilute2 iterations k, Tp(i,k), ah0(i), ahg ', & +!! k, Tp(i,k), ah0(i), ahg + END IF ! (k>=(icbs(i)+1)) + END DO ! i = 1, ncum + END DO ! j = 1,4 + DO i = 1, ncum + IF (k>=(icbs(i)+1)) THEN ! convect3 + tg = tp(i, k) + IF (tg .gt. Tx .OR. .NOT.cvflag_ice) THEN + es = 6.112*exp(17.67*(tg - 273.15)/(tg + 243.5 - 273.15)) + qg = eps*es/(p(i,k)-es*(1.-eps)) + ELSE + esi = exp(23.33086-(6111.72784/tg)+0.15215*log(tg)) + qg = eps*esi/(p(i,k)-esi*(1.-eps)) + ENDIF + IF (qsat_depends_on_qt) THEN + qg = qg*(1.-qta(i,k-1))/(1.-qg) + ENDIF + qhsat(i,k) = qg + END IF ! (k>=(icbs(i)+1)) + END DO ! i = 1, ncum + DO i = 1, ncum + IF (k>=(icbs(i)+1)) THEN ! convect3 + clw(i, k) = qta(i,k-1) - qhsat(i,k) + clw(i, k) = max(0.0, clw(i,k)) + tvp(i, k) = max(0., tp(i,k)*(1.+qhsat(i,k)/eps-qta(i,k-1))) +! print*,tvp(i,k),'tvp' + IF (clw(i,k)<1.E-11) THEN + tp(i, k) = tv(i, k) + tvp(i, k) = tv(i, k) + END IF ! (clw(i,k)<1.E-11) + END IF ! (k>=(icbs(i)+1)) + END DO ! i = 1, ncum +! + IF (cvflag_prec_eject) THEN + DO i = 1, ncum + IF (k>=(icbs(i)+1)) THEN ! convect3 +! Specific precipitation (liquid and solid) and ice content +! before ejection of precipitation !!jygprl + elacrit = elcrit*min(max(1.-(tp(i,k)-T0)/Tlcrit, 0.), 1.) !!jygprl +!!!! qcld(i,k) = min(clw(i,k), elacrit) !!jygprl + qhthreshold = elacrit*(1.-qta(i,k-1))/(1.-elacrit) + qcld(i,k) = min(clw(i,k), qhthreshold) !!jygprl +!!!! phinu2p = max(qhsat(i,k-1) + qcld(i,k-1) - (qhsat(i,k) + qcld(i,k)),0.) !!jygprl + phinu2p = max(clw(i,k) - max(qta(i,k-1) - qhsat(i,k-1), qhthreshold), 0.) + qpl(i,k) = qpl(i,k-1) + (1.-frac(i,k))*phinu2p !!jygprl + qps(i,k) = qps(i,k-1) + frac(i,k) *phinu2p !!jygprl + qi(i,k) = (1.-ejectliq)*clw(i,k)*frac(i,k) + & !!jygprl + ejectliq*(qps(i,k-1) + frac(i,k)*(phinu2p+qcld(i,k))) !!jygprl +!! +! ===================================================================================== +! Ejection of precipitation from adiabatic ascents if requested (cvflag_prec_eject=True): +! Compute the steps of total water (qta), of moist static energy (ha), of specific +! precipitation (qpl and qps) and of specific cloud water (qcld) associated with precipitation +! ejection. +! ===================================================================================== +! +! Verif + qpreca(i,k) = ejectliq*qpl(i,k) + ejectice*qps(i,k) !!jygprl + frac_a(i,k) = ejectice*qps(i,k)/max(qpreca(i,k),smallestreal) !!jygprl + frac_s(i,k) = (1.-ejectliq)*frac(i,k) + & !!jygprl + ejectliq*(1. - (qpl(i,k)+(1.-frac(i,k))*qcld(i,k))/max(clw(i,k),smallestreal)) !!jygprl +! + denomm1 = 1./(1. - qpreca(i,k)) +! + qta(i,k) = qta(i,k-1) - & + qpreca(i,k)*(1.-qta(i,k-1))*denomm1 + ha(i,k) = ha(i,k-1) + & + ( qpreca(i,k)*(-(1.-qta(i,k-1))*(cl-cpd)*tp(i,k) + & + lv(i,k)*qhsat(i,k) - lf(i,k)*(frac_s(i,k)*qcld(i,k)+qps(i,k))) + & + lf(i,k)*ejectice*qps(i,k))*denomm1 + hla(i,k) = hla(i,k-1) + & + ( qpreca(i,k)*(-(1.-qta(i,k-1))*(cpv-cpd)*tp(i,k) - & + lv(i,k)*((1.-frac_s(i,k))*qcld(i,k)+qpl(i,k)) - & + (lv(i,k)+lf(i,k))*(frac_s(i,k)*qcld(i,k)+qps(i,k))) + & + lv(i,k)*ejectliq*qpl(i,k) + (lv(i,k)+lf(i,k))*ejectice*qps(i,k))*denomm1 + qpl(i,k) = qpl(i,k)*(1.-ejectliq)*denomm1 + qps(i,k) = qps(i,k)*(1.-ejectice)*denomm1 + qcld(i,k) = qcld(i,k)*denomm1 + qhsat(i,k) = qhsat(i,k)*(1.-qta(i,k))/(1.-qta(i,k-1)) + END IF ! (k>=(icbs(i)+1)) + END DO ! i = 1, ncum + ENDIF ! (cvflag_prec_eject) +! + END DO ! k = minorig + 1, nl +! +!---------------------------------------------------------------------------- +! + ELSE IF (icvflag_Tpa == 0) THEN! (icvflag_Tpa == 2) ELSE IF(icvflag_Tpa == 1) +! +!---------------------------------------------------------------------------- +! + DO k = minorig + 1, nl + DO i = 1, ncum +! ori if(k.ge.(icb(i)+1))then + IF (k>=(icbs(i)+1)) THEN ! convect3 + tg = t(i, k) + qg = qs(i, k) +! debug alv=lv0-clmcpv*(t(i,k)-t0) + alv = lv0 - clmcpv*(t(i,k)-273.15) + +! First iteration. + +! 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 +! 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) +! ori tg=max(tg,35.0) +! debug tc=tg-t0 + tc = tg - 273.15 + denom = 243.5 + tc + denom = max(denom, 1.0) ! convect3 +! ori if(tc.ge.0.0)then + es = 6.112*exp(17.67*tc/denom) +! ori else +! ori es=exp(23.33086-6111.72784/tg+0.15215*log(tg)) +! ori endif + qg = eps*es/(p(i,k)-es*(1.-eps)) + +! Second iteration. + +! ori s=cpd+alv*alv*qg/(rrv*t(i,k)*t(i,k)) +! ori s=1./s +! 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) +! ori tg=max(tg,35.0) +! debug tc=tg-t0 + tc = tg - 273.15 + denom = 243.5 + tc + denom = max(denom, 1.0) ! convect3 +! ori if(tc.ge.0.0)then + es = 6.112*exp(17.67*tc/denom) +! ori else +! ori es=exp(23.33086-6111.72784/tg+0.15215*log(tg)) +! ori endif + qg = eps*es/(p(i,k)-es*(1.-eps)) + +! debug alv=lv0-clmcpv*(t(i,k)-t0) + alv = lv0 - clmcpv*(t(i,k)-273.15) +! print*,'cpd dans convect2 ',cpd +! print*,'tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd' +! print*,tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd + +! ori c approximation here: +! ori tp(i,k)=(ah0(i)-(cl-cpd)*qnk(i)*t(i,k)-gz(i,k)-alv*qg)/cpd + +! convect3: no approximation: + IF (cvflag_ice) THEN + tp(i, k) = max(0., (ah0(i)-gz(i,k)-alv*qg)/(cpd+(cl-cpd)*qnk(i))) + ELSE + tp(i, k) = (ah0(i)-gz(i,k)-alv*qg)/(cpd+(cl-cpd)*qnk(i)) + END IF + + clw(i, k) = qnk(i) - qg + clw(i, k) = max(0.0, clw(i,k)) + rg = qg/(1.-qnk(i)) +! ori tvp(i,k)=tp(i,k)*(1.+rg*epsi) +! convect3: (qg utilise au lieu du vrai mixing ratio rg): + tvp(i, k) = tp(i, k)*(1.+qg/eps-qnk(i)) ! whole thing + IF (cvflag_ice) THEN + IF (clw(i,k)<1.E-11) THEN + tp(i, k) = tv(i, k) + tvp(i, k) = tv(i, k) + END IF + END IF +!jyg< +!! END IF ! Endif moved to the end of the loop +!>jyg + + IF (cvflag_ice) THEN +!CR:attention boucle en klon dans Icefrac +! Call Icefrac(t,clw,qi,nl,nloc) + IF (t(i,k)>263.15) THEN + qi(i, k) = 0. + ELSE + IF (t(i,k)<243.15) THEN + qi(i, k) = clw(i, k) + ELSE + fracg = (263.15-t(i,k))/20 + qi(i, k) = clw(i, k)*fracg + END IF + END IF +!CR: fin test + IF (t(i,k)<263.15) THEN +!CR: on commente les calculs d'Arnaud car division par zero +! nouveau calcul propose par JYG +! alv=lv0-clmcpv*(t(i,k)-273.15) +! alf=lf0-clmci*(t(i,k)-273.15) +! tg=tp(i,k) +! tc=tp(i,k)-273.15 +! denom=243.5+tc +! do j=1,3 +! cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +! il faudra que esi vienne en argument de la convection +! cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +! tbis=t(i,k)+(tp(i,k)-tg) +! esi=exp(23.33086-(6111.72784/tbis) + & +! 0.15215*log(tbis)) +! qsat_new=eps*esi/(p(i,k)-esi*(1.-eps)) +! snew=cpd*(1.-qnk(i))+cl*qnk(i)+alv*alv*qsat_new/ & +! (rrv*tbis*tbis) +! snew=1./snew +! print*,esi,qsat_new,snew,'esi,qsat,snew' +! tp(i,k)=tg+(alf*qi(i,k)+alv*qg*(1.-(esi/es)))*snew +! print*,k,tp(i,k),qnk(i),'avec glace' +! print*,'tpNAN',tg,alf,qi(i,k),alv,qg,esi,es,snew +! enddo + + alv = lv0 - clmcpv*(t(i,k)-273.15) + alf = lf0 + clmci*(t(i,k)-273.15) + als = alf + alv + tg = tp(i, k) + tp(i, k) = t(i, k) + DO j = 1, 3 + esi = exp(23.33086-(6111.72784/tp(i,k))+0.15215*log(tp(i,k))) + qsat_new = eps*esi/(p(i,k)-esi*(1.-eps)) + snew = cpd*(1.-qnk(i)) + cl*qnk(i) + alv*als*qsat_new/ & + (rrv*tp(i,k)*tp(i,k)) + snew = 1./snew +! c print*,esi,qsat_new,snew,'esi,qsat,snew' + tp(i, k) = tp(i, k) + & + ((cpd*(1.-qnk(i))+cl*qnk(i))*(tg-tp(i,k)) + & + alv*(qg-qsat_new)+alf*qi(i,k))*snew +! print*,k,tp(i,k),qsat_new,qnk(i),qi(i,k), & +! 'k,tp,q,qt,qi avec glace' + END DO + +!CR:reprise du code AJ + clw(i, k) = qnk(i) - qsat_new + clw(i, k) = max(0.0, clw(i,k)) + tvp(i, k) = max(0., tp(i,k)*(1.+qsat_new/eps-qnk(i))) +! print*,tvp(i,k),'tvp' + END IF + IF (clw(i,k)<1.E-11) THEN + tp(i, k) = tv(i, k) + tvp(i, k) = tv(i, k) + END IF + END IF ! (cvflag_ice) +!jyg< + END IF ! (k>=(icbs(i)+1)) +!>jyg + END DO + END DO + +!---------------------------------------------------------------------------- +! + ENDIF ! (icvflag_Tpa == 2) ELSEIF (icvflag_Tpa == 1) ELSE (icvflag_Tpa == 0) +! +!---------------------------------------------------------------------------- +! +! ===================================================================== +! --- SET THE PRECIPITATION EFFICIENCIES +! --- THESE MAY BE FUNCTIONS OF TP(I), P(I) AND CLW(I) +! ===================================================================== +! + IF (flag_epkeorig/=1) THEN + DO k = 1, nl ! convect3 + DO i = 1, ncum +!jyg< + IF(k>=icb(i)) THEN +!>jyg + pden = ptcrit - pbcrit + ep(i, k) = (plcl(i)-p(i,k)-pbcrit)/pden*epmax + ep(i, k) = max(ep(i,k), 0.0) + ep(i, k) = min(ep(i,k), epmax) +!! sigp(i, k) = spfac ! jyg + ENDIF ! (k>=icb(i)) + END DO + END DO + ELSE + DO k = 1, nl + DO i = 1, ncum + IF(k>=icb(i)) THEN +!! IF (k>=(nk(i)+1)) THEN +!>jyg + tca = tp(i, k) - t0 + IF (tca>=0.0) THEN + elacrit = elcrit + ELSE + elacrit = elcrit*(1.0-tca/tlcrit) + END IF + elacrit = max(elacrit, 0.0) + ep(i, k) = 1.0 - elacrit/max(clw(i,k), 1.0E-8) + ep(i, k) = max(ep(i,k), 0.0) + ep(i, k) = min(ep(i,k), epmax) +!! sigp(i, k) = spfac ! jyg + END IF ! (k>=icb(i)) + END DO + END DO + END IF +! +! ========================================================================= + IF (prt_level >= 10) THEN + print *,'cv3_undilute2.1. tp(1,k), tvp(1,k) ', & + (k, tp(1,k), tvp(1,k), k = 1,nl) + ENDIF +! +! ===================================================================== +! --- CALCULATE VIRTUAL TEMPERATURE AND LIFTED PARCEL +! --- VIRTUAL TEMPERATURE +! ===================================================================== + +! dans convect3, tvp est calcule en une seule fois, et sans retirer +! l'eau condensee (~> reversible CAPE) + +! ori do 340 k=minorig+1,nl +! ori do 330 i=1,ncum +! ori if(k.ge.(icb(i)+1))then +! ori tvp(i,k)=tvp(i,k)*(1.0-qnk(i)+ep(i,k)*clw(i,k)) +! oric print*,'i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)' +! oric print*, i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k) +! ori endif +! ori 330 continue +! ori 340 continue + +! ori do 350 i=1,ncum +! ori tvp(i,nlp)=tvp(i,nl)-(gz(i,nlp)-gz(i,nl))/cpd +! ori 350 continue + + DO i = 1, ncum ! convect3 + tp(i, nlp) = tp(i, nl) ! convect3 + END DO ! convect3 + +! ===================================================================== +! --- EFFECTIVE VERTICAL PROFILE OF BUOYANCY (convect3 only): +! ===================================================================== + +! -- this is for convect3 only: + +! first estimate of buoyancy: + +!jyg : k-loop outside i-loop (07042015) + DO k = 1, nl + DO i = 1, ncum + buoy(i, k) = tvp(i, k) - tv(i, k) + END DO + END DO + +! set buoyancy=buoybase for all levels below base +! for safety, set buoy(icb)=buoybase + +!jyg : k-loop outside i-loop (07042015) + DO k = 1, nl + DO i = 1, ncum + IF ((k>=icb(i)) .AND. (k<=nl) .AND. (p(i,k)>=pbase(i))) THEN + buoy(i, k) = buoybase(i) + END IF + END DO + END DO + DO i = 1, ncum +! buoy(icb(i),k)=buoybase(i) + buoy(i, icb(i)) = buoybase(i) + END DO + +! -- end convect3 + +! ===================================================================== +! --- FIND THE FIRST MODEL LEVEL (INB) ABOVE THE PARCEL'S +! --- LEVEL OF NEUTRAL BUOYANCY +! ===================================================================== + +! -- this is for convect3 only: + + DO i = 1, ncum + inb(i) = nl - 1 + iposit(i) = nl + END DO + + +! -- iposit(i) = first level, above icb, with positive buoyancy + DO k = 1, nl - 1 + DO i = 1, ncum + IF (k>=icb(i) .AND. buoy(i,k)>0.) THEN + iposit(i) = min(iposit(i), k) + END IF + END DO + END DO + + DO i = 1, ncum + IF (iposit(i)==nl) THEN + iposit(i) = icb(i) + END IF + END DO + + DO k = 1, nl - 1 + DO i = 1, ncum + IF ((k>=iposit(i)) .AND. (buoy(i,k)=iposit(i))) THEN + deltap = min(plcl(i), ph(i,k-1)) - min(plcl(i), ph(i,k)) + cape(i) = cape(i) + rrd*buoy(i, k-1)*deltap/p(i, k-1) + IF (cape(i).gt.0.) THEN + inb(i) = max(inb(i), k) + END IF + ENDIF + ENDDO + ENDDO + +! DO i = 1, ncum +! print*,"inb",inb(i) +! ENDDO + + endif + +! -- end convect3 + +! ori do 510 i=1,ncum +! ori cape(i)=0.0 +! ori capem(i)=0.0 +! ori inb(i)=icb(i)+1 +! ori inb1(i)=inb(i) +! ori 510 continue + +! Originial Code + +! do 530 k=minorig+1,nl-1 +! do 520 i=1,ncum +! if(k.ge.(icb(i)+1))then +! by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k) +! byp=(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 +! byp=(tvp(i,nl)-tv(i,nl))*dph(i,nl)/p(i,nl) +! cape(i)=capem(i)+byp +! 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 + +! K Emanuel fix + +! call zilch(byp,ncum) +! do 530 k=minorig+1,nl-1 +! do 520 i=1,ncum +! if(k.ge.(icb(i)+1))then +! by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k) +! 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) +! byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1) +! endif +! endif +!520 continue +!530 continue +! do 540 i=1,ncum +! inb(i)=max(inb(i),inb1(i)) +! 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 + +! J Teixeira fix + +! ori call zilch(byp,ncum) +! ori do 515 i=1,ncum +! ori lcape(i)=.true. +! ori 515 continue +! ori do 530 k=minorig+1,nl-1 +! ori do 520 i=1,ncum +! ori if(cape(i).lt.0.0)lcape(i)=.false. +! ori if((k.ge.(icb(i)+1)).and.lcape(i))then +! ori by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k) +! ori byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1) +! ori cape(i)=cape(i)+by +! ori if(by.ge.0.0)inb1(i)=k+1 +! ori if(cape(i).gt.0.0)then +! ori inb(i)=k+1 +! ori capem(i)=cape(i) +! ori endif +! ori endif +! ori 520 continue +! ori 530 continue +! ori do 540 i=1,ncum +! ori cape(i)=capem(i)+byp(i) +! ori defrac=capem(i)-cape(i) +! ori defrac=max(defrac,0.001) +! ori frac(i)=-cape(i)/defrac +! ori frac(i)=min(frac(i),1.0) +! ori frac(i)=max(frac(i),0.0) +! ori 540 continue + +! -------------------------------------------------------------------- +! Prevent convection when top is too hot +! -------------------------------------------------------------------- + DO i = 1,ncum + IF (t(i,inb(i)) > T_top_max) iflag(i) = 10 + ENDDO + +! ===================================================================== +! --- CALCULATE LIQUID WATER STATIC ENERGY OF LIFTED PARCEL +! ===================================================================== + + DO k = 1, nl + DO i = 1, ncum + hp(i, k) = h(i, k) + END DO + END DO + +!jyg : cvflag_ice test outside the loops (07042015) +! + IF (cvflag_ice) THEN +! + IF (cvflag_prec_eject) THEN +!! DO k = minorig + 1, nl +!! DO i = 1, ncum +!! IF ((k>=icb(i)) .AND. (k<=inb(i))) THEN +!! frac_s(i,k) = qi(i,k)/max(clw(i,k),smallestreal) +!! frac_s(i,k) = 1. - (qpl(i,k)+(1.-frac_s(i,k))*qcld(i,k))/max(clw(i,k),smallestreal) +!! END IF +!! END DO +!! END DO + ELSE ! (cvflag_prec_eject) + DO k = minorig + 1, nl + DO i = 1, ncum + IF ((k>=icb(i)) .AND. (k<=inb(i))) THEN +!jyg< frac computation moved to beginning of cv3_undilute2. +! kept here for compatibility test with CMip6 version + frac_s(i, k) = 1. - (t(i,k)-243.15)/(263.15-243.15) + frac_s(i, k) = min(max(frac_s(i,k),0.0), 1.0) + END IF + END DO + END DO + ENDIF ! (cvflag_prec_eject) ELSE + DO k = minorig + 1, nl + DO i = 1, ncum + IF ((k>=icb(i)) .AND. (k<=inb(i))) THEN +!! hp(i, k) = hnk(i) + (lv(i,k)+(cpd-cpv)*t(i,k)+frac_s(i,k)*lf(i,k))* & !!jygprl +!! ep(i, k)*clw(i, k) !!jygprl + hp(i, k) = hla(i,k-1) + (lv(i,k)+(cpd-cpv)*t(i,k)+frac_s(i,k)*lf(i,k))* & !!jygprl + ep(i, k)*clw(i, k) !!jygprl + END IF + END DO + END DO +! + ELSE ! (cvflag_ice) +! + DO k = minorig + 1, nl + DO i = 1, ncum + IF ((k>=icb(i)) .AND. (k<=inb(i))) THEN +!jyg< (energy conservation tests) +!! hp(i, k) = hnk(i) + (lv(i,k)+(cpd-cpv)*tp(i,k))*ep(i, k)*clw(i, k) +!! hp(i, k) = ( hnk(i) + (lv(i,k)+(cpd-cpv)*t(i,k))*ep(i, k)*clw(i, k) ) / & +!! (1. - ep(i,k)*clw(i,k)) +!! hp(i, k) = ( hnk(i) + (lv(i,k)+(cpd-cl)*t(i,k))*ep(i, k)*clw(i, k) ) / & +!! (1. - ep(i,k)*clw(i,k)) + hp(i, k) = hnk(i) + (lv(i,k)+(cpd-cpv)*t(i,k))*ep(i, k)*clw(i, k) + END IF + END DO + END DO +! + END IF ! (cvflag_ice) + + RETURN +END SUBROUTINE cv3_undilute2 + +SUBROUTINE cv3_closure(nloc, ncum, nd, icb, inb, & + pbase, p, ph, tv, buoy, & + sig, w0, cape, m, iflag) + USE lmdz_cv_ini, ONLY : alpha,beta,dtcrit,minorig,nl,rrd + USE cvflag_mod_h + IMPLICIT NONE + +! =================================================================== +! --- CLOSURE OF CONVECT3 +! +! vectorization: S. Bony +! =================================================================== + + +!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) + +!input/output: + REAL sig(nloc, nd), w0(nloc, nd) + INTEGER iflag(nloc) + +!output: + REAL cape(nloc) + REAL m(nloc, nd) + +!local variables: + INTEGER i, j, k, icbmax + REAL deltap, fac, w, amu + REAL dtmin(nloc, nd), sigold(nloc, nd) + REAL cbmflast(nloc) + + +! ------------------------------------------------------- +! -- Initialization +! ------------------------------------------------------- + + DO k = 1, nl + DO i = 1, ncum + m(i, k) = 0.0 + END DO + END DO + +! ------------------------------------------------------- +! -- Reset sig(i) and w0(i) for i>inb and i=(inb(i)+1))) THEN + sig(i, k) = beta*sig(i, k) + & + 2.*alpha*buoy(i, inb(i))*abs(buoy(i,inb(i))) + sig(i, k) = amax1(sig(i,k), 0.0) + w0(i, k) = beta*w0(i, k) + END IF + END DO + END DO + +! compute icbmax: + +!ym icbmax = 2 +!ym DO i = 1, ncum +!ym icbmax = max(icbmax, icb(i)) +!ym END DO + +! update sig and w0 below cloud base: + +!ym DO k = 1, icbmax + DO k = 1, nd + DO i = 1, ncum + IF (k<=MAX(2,icb(i))) THEN + IF (k<=icb(i)) THEN + sig(i, k) = beta*sig(i, k) - & + 2.*alpha*buoy(i, icb(i))*buoy(i, icb(i)) + sig(i, k) = max(sig(i,k), 0.0) + w0(i, k) = beta*w0(i, k) + END IF + ENDIF + END DO + END DO + +!! if(inb.lt.(nl-1))then +!! do 85 i=inb+1,nl-1 +!! sig(i)=beta*sig(i)+2.*alpha*buoy(inb)* +!! 1 abs(buoy(inb)) +!! sig(i)=max(sig(i),0.0) +!! w0(i)=beta*w0(i) +!! 85 continue +!! end if + +!! do 87 i=1,icb +!! sig(i)=beta*sig(i)-2.*alpha*buoy(icb)*buoy(icb) +!! sig(i)=max(sig(i),0.0) +!! w0(i)=beta*w0(i) +!! 87 continue + +! ------------------------------------------------------------- +! -- Reset fractional areas of updrafts and w0 at initial time +! -- and after 10 time steps of no convection +! ------------------------------------------------------------- + + DO k = 1, nl - 1 + DO i = 1, ncum + IF (sig(i,nd)<1.5 .OR. sig(i,nd)>12.0) THEN + sig(i, k) = 0.0 + w0(i, k) = 0.0 + END IF + END DO + END DO + +! ------------------------------------------------------------- +! -- Calculate convective available potential energy (cape), +! -- vertical velocity (w), fractional area covered by +! -- undilute updraft (sig), and updraft mass flux (m) +! ------------------------------------------------------------- + + DO i = 1, ncum + cape(i) = 0.0 + END DO + +! compute dtmin (minimum buoyancy between ICB and given level k): + + DO i = 1, ncum + DO k = 1, nl + dtmin(i, k) = 100.0 + END DO + END DO + + DO i = 1, ncum + DO k = 1, nl + DO j = minorig, nl + IF ((k>=(icb(i)+1)) .AND. (k<=inb(i)) .AND. (j>=icb(i)) .AND. (j<=(k-1))) THEN + dtmin(i, k) = amin1(dtmin(i,k), buoy(i,j)) + END IF + END DO + END DO + END DO + +! the interval on which cape is computed starts at pbase : + + DO k = 1, nl + DO i = 1, ncum + + IF ((k>=(icb(i)+1)) .AND. (k<=inb(i))) THEN + + deltap = min(pbase(i), ph(i,k-1)) - min(pbase(i), ph(i,k)) + cape(i) = cape(i) + rrd*buoy(i, k-1)*deltap/p(i, k-1) + cape(i) = amax1(0.0, cape(i)) + sigold(i, k) = sig(i, k) + +! dtmin(i,k)=100.0 +! do 97 j=icb(i),k-1 ! mauvaise vectorisation +! dtmin(i,k)=AMIN1(dtmin(i,k),buoy(i,j)) +! 97 continue + + sig(i, k) = beta*sig(i, k) + alpha*dtmin(i, k)*abs(dtmin(i,k)) + sig(i, k) = max(sig(i,k), 0.0) + sig(i, k) = amin1(sig(i,k), 0.01) + fac = amin1(((dtcrit-dtmin(i,k))/dtcrit), 1.0) + w = (1.-beta)*fac*sqrt(cape(i)) + beta*w0(i, k) + amu = 0.5*(sig(i,k)+sigold(i,k))*w + m(i, k) = amu*0.007*p(i, k)*(ph(i,k)-ph(i,k+1))/tv(i, k) + w0(i, k) = w + END IF + + END DO + END DO + + DO i = 1, ncum + w0(i, icb(i)) = 0.5*w0(i, icb(i)+1) + m(i, icb(i)) = 0.5*m(i, icb(i)+1)*(ph(i,icb(i))-ph(i,icb(i)+1))/(ph(i,icb(i)+1)-ph(i,icb(i)+2)) + sig(i, icb(i)) = sig(i, icb(i)+1) + sig(i, icb(i)-1) = sig(i, icb(i)) + END DO + +! ccc 3. Compute final cloud base mass flux and set iflag to 3 if +! ccc cloud base mass flux is exceedingly small and is decreasing (i.e. if +! ccc the final mass flux (cbmflast) is greater than the target mass flux +! ccc (cbmf) ??). +! cc +! c do i = 1,ncum +! c cbmflast(i) = 0. +! c enddo +! cc +! c do k= 1,nl +! c do i = 1,ncum +! c IF (k .ge. icb(i) .and. k .le. inb(i)) THEN +! c cbmflast(i) = cbmflast(i)+M(i,k) +! c ENDIF +! c enddo +! c enddo +! cc +! c do i = 1,ncum +! c IF (cbmflast(i) .lt. 1.e-6) THEN +! c iflag(i) = 3 +! c ENDIF +! c enddo +! cc +! c do k= 1,nl +! c do i = 1,ncum +! c IF (iflag(i) .ge. 3) THEN +! c M(i,k) = 0. +! c sig(i,k) = 0. +! c w0(i,k) = 0. +! c ENDIF +! c enddo +! c enddo +! cc +!! cape=0.0 +!! do 98 i=icb+1,inb +!! deltap = min(pbase,ph(i-1))-min(pbase,ph(i)) +!! cape=cape+rrd*buoy(i-1)*deltap/p(i-1) +!! dcape=rrd*buoy(i-1)*deltap/p(i-1) +!! dlnp=deltap/p(i-1) +!! cape=max(0.0,cape) +!! sigold=sig(i) + +!! dtmin=100.0 +!! do 97 j=icb,i-1 +!! dtmin=amin1(dtmin,buoy(j)) +!! 97 continue + +!! sig(i)=beta*sig(i)+alpha*dtmin*abs(dtmin) +!! sig(i)=max(sig(i),0.0) +!! sig(i)=amin1(sig(i),0.01) +!! fac=amin1(((dtcrit-dtmin)/dtcrit),1.0) +!! w=(1.-beta)*fac*sqrt(cape)+beta*w0(i) +!! amu=0.5*(sig(i)+sigold)*w +!! m(i)=amu*0.007*p(i)*(ph(i)-ph(i+1))/tv(i) +!! w0(i)=w +!! 98 continue +!! w0(icb)=0.5*w0(icb+1) +!! m(icb)=0.5*m(icb+1)*(ph(icb)-ph(icb+1))/(ph(icb+1)-ph(icb+2)) +!! sig(icb)=sig(icb+1) +!! sig(icb-1)=sig(icb) + + RETURN +END SUBROUTINE cv3_closure + +!!SUBROUTINE cv3_mixing(nloc, ncum, nd, na, ntra, icb, nk, inb, & !jyg: get rid of ntra +SUBROUTINE cv3_mixing(nloc, ncum, nd, na, icb, nk, inb, & +!! ph, t, rr, rs, u, v, tra, h, lv, lf, frac, qnk, & !jyg: get rid of ntra + ph, t, rr, rs, u, v, h, lv, lf, frac, qnk, & + unk, vnk, hp, tv, tvp, ep, clw, m, sig, & +!! ment, qent, uent, vent, nent, sij, elij, ments, qents, traent) !jyg: get rid of ntra +!! ment, qent, uent, vent, nent, sij, elij, ments, qents) !jyg: get rid of ments + ment, qent, uent, vent, nent, sij, elij) + USE cvflag_mod_h + USE lmdz_cv_ini, ONLY : cpd,cpv,minorig,nl,rrv,cpd,ginv,grav + IMPLICIT NONE + +! --------------------------------------------------------------------- +! a faire: +! - vectorisation de la partie normalisation des flux (do 789...) +! --------------------------------------------------------------------- + +!inputs: +!! INTEGER, INTENT (IN) :: ncum, nd, na, ntra, nloc !jyg: get rid of ntra + INTEGER, INTENT (IN) :: ncum, nd, na, nloc + INTEGER, DIMENSION (nloc), INTENT (IN) :: icb, inb, nk + REAL, DIMENSION (nloc, nd), INTENT (IN) :: sig + REAL, DIMENSION (nloc), INTENT (IN) :: qnk, unk, vnk + REAL, DIMENSION (nloc, nd+1), INTENT (IN) :: ph + REAL, DIMENSION (nloc, nd), INTENT (IN) :: t, rr, rs + REAL, DIMENSION (nloc, nd), INTENT (IN) :: u, v +!! REAL, DIMENSION (nloc, nd, ntra), INTENT (IN) :: tra ! input of convect3 !jyg: get rid of ntra + REAL, DIMENSION (nloc, na), INTENT (IN) :: lv, h, hp + REAL, DIMENSION (nloc, na), INTENT (IN) :: lf, frac + REAL, DIMENSION (nloc, na), INTENT (IN) :: tv, tvp, ep, clw + REAL, DIMENSION (nloc, na), INTENT (IN) :: m ! input of convect3 + +!outputs: + REAL, DIMENSION (nloc, na, na), INTENT (OUT) :: ment, qent + REAL, DIMENSION (nloc, na, na), INTENT (OUT) :: uent, vent + REAL, DIMENSION (nloc, na, na), INTENT (OUT) :: sij, elij +!! REAL, DIMENSION (nloc, nd, nd, ntra), INTENT (OUT) :: traent !jyg: get rid of ntra +!! REAL, DIMENSION (nloc, nd, nd), INTENT (OUT) :: ments, qents !jyg: get rid of ments + INTEGER, DIMENSION (nloc, nd), INTENT (OUT) :: nent + +!local variables: + INTEGER i, j, k, il, im, jm + INTEGER num1, num2 + 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 sigij(nloc, nd, nd) + REAL wgh + REAL zm(nloc, na) + LOGICAL lwork(nloc) + +! ===================================================================== +! --- INITIALIZE VARIOUS ARRAYS USED IN THE COMPUTATIONS +! ===================================================================== + +! ori do 360 i=1,ncum*nlp + DO j = 1, nl + DO il = 1, ncum + nent(il, j) = 0 +! in convect3, m is computed in cv3_closure +! ori m(i,1)=0.0 + END DO + END DO + +! ori do 400 k=1,nlp +! ori do 390 j=1,nlp + DO j = 1, nl + DO k = 1, nl + DO il = 1, ncum + qent(il, k, j) = rr(il, j) + uent(il, k, j) = u(il, j) + vent(il, k, j) = v(il, j) + elij(il, k, j) = 0.0 +!ym ment(i,k,j)=0.0 +!ym sij(i,k,j)=0.0 + END DO + END DO + END DO + +!ym + ment(1:ncum, 1:nd, 1:nd) = 0.0 + sij(1:ncum, 1:nd, 1:nd) = 0.0 + zm(:, :) = 0. + +! ===================================================================== +! --- CALCULATE ENTRAINED AIR MASS FLUX (ment), TOTAL WATER MIXING +! --- RATIO (QENT), TOTAL CONDENSED WATER (elij), AND MIXING +! --- FRACTION (sij) +! ===================================================================== + + DO i = minorig + 1, nl + + DO j = minorig, nl + DO il = 1, ncum + IF ((i>=icb(il)) .AND. (i<=inb(il)) .AND. (j>=(icb(il)-1)) .AND. (j<=inb(il))) THEN + + rti = qnk(il) - 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) + + + IF (cvflag_ice) THEN +! print*,cvflag_ice,'cvflag_ice dans do 700' + IF (t(il,j)<=263.15) THEN + bf2 = 1. + (lf(il,j)+lv(il,j))*(lv(il,j)+frac(il,j)* & + lf(il,j))*rs(il, j)/(rrv*t(il,j)*t(il,j)*cpd) + END IF + END IF + + 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)<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<0.0 .OR. stemp>1.0 .OR. altem>cwat) .AND. j>i) THEN + + IF (cvflag_ice) THEN + anum = anum - (lv(il,j)+frac(il,j)*lf(il,j))*(rti-rs(il,j)-cwat*bf2) + denom = denom + (lv(il,j)+frac(il,j)*lf(il,j))*(rr(il,i)-rti) + ELSE + anum = anum - lv(il, j)*(rti-rs(il,j)-cwat*bf2) + denom = denom + lv(il, j)*(rr(il,i)-rti) + END IF + + IF (abs(denom)<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)>0.0 .AND. sij(il,i,j)<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))*unk(il) + vent(il, i, j) = sij(il, i, j)*v(il, i) + (1.-sij(il,i,j))*vnk(il) + elij(il, i, j) = altem + elij(il, i, j) = max(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) = max(0.0, sij(il,i,j)) + sij(il, i, j) = amin1(1.0, sij(il,i,j)) + END IF ! new + END DO + END DO + + +! *** if no air can entrain at level i assume that updraft detrains *** +! *** at that level and calculate detrained air flux and properties *** + + +! @ do 170 i=icb(il),inb(il) + + DO il = 1, ncum + IF ((i>=icb(il)) .AND. (i<=inb(il)) .AND. (nent(il,i)==0)) THEN +! @ if(nent(il,i).eq.0)then + ment(il, i, i) = m(il, i) + qent(il, i, i) = qnk(il) - ep(il, i)*clw(il, i) + uent(il, i, i) = unk(il) + vent(il, i, i) = vnk(il) + elij(il, i, i) = clw(il, i) +! MAF sij(il,i,i)=1.0 + sij(il, i, i) = 0.0 + END IF + END DO + END DO + + DO j = minorig, nl + DO i = minorig, nl + DO il = 1, ncum + IF ((j>=(icb(il)-1)) .AND. (j<=inb(il)) .AND. (i>=icb(il)) .AND. (i<=inb(il))) THEN + sigij(il, i, j) = sij(il, i, j) + END IF + END DO + END DO + END DO +! @ enddo + +! @170 continue + +! ===================================================================== +! --- NORMALIZE ENTRAINED AIR MASS FLUXES +! --- TO REPRESENT EQUAL PROBABILITIES OF MIXING +! ===================================================================== + asum(1:nloc,1:nd) = 0. + csum(1:nloc,1:nd) = 0. + + DO il = 1, ncum + lwork(il) = .FALSE. + END DO + + DO i = minorig + 1, nl + + num1 = 0 + DO il = 1, ncum + IF (i>=icb(il) .AND. i<=inb(il)) num1 = num1 + 1 + END DO +!ym IF (num1<=0) GO TO 789 + IF (num1<=0) CYCLE + + DO il = 1, ncum + IF (i>=icb(il) .AND. i<=inb(il)) THEN + lwork(il) = (nent(il,i)/=0) + qp = qnk(il) - ep(il, i)*clw(il, i) + + IF (cvflag_ice) THEN + + anum = h(il, i) - hp(il, i) - (lv(il,i)+frac(il,i)*lf(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)+frac(il,i)*lf(il,i))* & + (rr(il,i)-qp) + (cpd-cpv)*t(il, i)*(rr(il,i)-qp) + ELSE + + 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) + END IF + + IF (abs(denom)<0.01) denom = 0.01 + scrit(il) = anum/denom + alt = qp - rs(il, i) + scrit(il)*(rr(il,i)-qp) + IF (scrit(il)<=0.0 .OR. alt<=0.0) scrit(il) = 1.0 + smax(il) = 0.0 + asij(il) = 0.0 + END IF + END DO + + DO j = nl, minorig, -1 + + num2 = 0 + DO il = 1, ncum + IF (i>=icb(il) .AND. i<=inb(il) .AND. & + j>=(icb(il)-1) .AND. j<=inb(il) .AND. & + lwork(il)) num2 = num2 + 1 + END DO +!ym IF (num2<=0) GO TO 175 + IF (num2<=0) CYCLE + + DO il = 1, ncum + IF (i>=icb(il) .AND. i<=inb(il) .AND. & + j>=(icb(il)-1) .AND. j<=inb(il) .AND. & + lwork(il)) THEN + + IF (sij(il,i,j)>1.0E-16 .AND. sij(il,i,j)<0.95) THEN + wgh = 1.0 + IF (j>i) THEN + sjmax = max(sij(il,i,j+1), smax(il)) + sjmax = amin1(sjmax, scrit(il)) + smax(il) = max(sij(il,i,j), smax(il)) + sjmin = max(sij(il,i,j-1), smax(il)) + sjmin = amin1(sjmin, scrit(il)) + IF (sij(il,i,j)<(smax(il)-1.0E-16)) wgh = 0.0 + smid = amin1(sij(il,i,j), scrit(il)) + ELSE + sjmax = max(sij(il,i,j+1), scrit(il)) + smid = max(sij(il,i,j), scrit(il)) + sjmin = 0.0 + IF (j>1) sjmin = sij(il, i, j-1) + sjmin = max(sjmin, scrit(il)) + END IF + 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 + END IF + END IF + END DO + +175 END DO + + DO il = 1, ncum + IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il)) THEN + asij(il) = max(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 + END IF + END DO + + DO j = minorig, nl + DO il = 1, ncum + IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il) .AND. & + j>=(icb(il)-1) .AND. j<=inb(il)) THEN + ment(il, i, j) = ment(il, i, j)*asij(il) + END IF + END DO + END DO + + DO j = minorig, nl + DO il = 1, ncum + IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il) .AND. & + j>=(icb(il)-1) .AND. j<=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) + END IF + END DO + END DO + + DO il = 1, ncum + IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il)) THEN + bsum(il, i) = max(bsum(il,i), 1.0E-16) + bsum(il, i) = 1.0/bsum(il, i) + END IF + END DO + + DO j = minorig, nl + DO il = 1, ncum + IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il) .AND. & + j>=(icb(il)-1) .AND. j<=inb(il)) THEN + ment(il, i, j) = ment(il, i, j)*asum(il, i)*bsum(il, i) + END IF + END DO + END DO + + DO j = minorig, nl + DO il = 1, ncum + IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il) .AND. & + j>=(icb(il)-1) .AND. j<=inb(il)) THEN + csum(il, i) = csum(il, i) + ment(il, i, j) + END IF + END DO + END DO + + DO il = 1, ncum + IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il) .AND. & + csum(il,i)cv3_unsat, iflag(1) ', iflag(1) + +smallestreal=tiny(smallestreal) + +! ============================= +! --- INITIALIZE OUTPUT ARRAYS +! ============================= +! (loops up to nl+1) +mp(:,:) = 0. +rp(:,:) = 0. +up(:,:) = 0. +vp(:,:) = 0. +water(:,:) = 0. +evap(:,:) = 0. +wt(:,:) = 0. +ice(:,:) = 0. +fondue(:,:) = 0. +faci(:,:) = 0. +b(:,:) = 0. +sigd(:) = 0. +!! RomP >>> +wdtrainA(:,:) = 0. +wdtrainS(:,:) = 0. +wdtrainM(:,:) = 0. +!! RomP <<< + + DO i = 1, nlp + DO il = 1, ncum + rp(il, i) = rr(il, i) + up(il, i) = u(il, i) + vp(il, i) = v(il, i) + wt(il, i) = 0.001 + END DO + END DO + +! *** Set the fractionnal area sigd of precipitating downdraughts + DO il = 1, ncum + sigd(il) = sigdz*coef_clos(il) + END DO + +! ===================================================================== +! --- INITIALIZE VARIOUS ARRAYS AND PARAMETERS USED IN THE COMPUTATIONS +! ===================================================================== +! (loops up to nl+1) + + delti = 1./delt + tinv = 1./3. + + DO i = 1, nlp + DO il = 1, ncum + frac(il, i) = 0.0 + fraci(il, i) = 0.0 + prec(il, i) = 0.0 + lvcp(il, i) = lv(il, i)/cpn(il, i) + lfcp(il, i) = lf(il, i)/cpn(il, i) + END DO + END DO + +! *** check whether ep(inb)=0, if so, skip precipitating *** +! *** downdraft calculation *** + + + DO il = 1, ncum +!! lwork(il)=.TRUE. +!! if(ep(il,inb(il)).lt.0.0001)lwork(il)=.FALSE. +!jyg< +!! lwork(il) = ep(il, inb(il)) >= 0.0001 + lwork(il) = ep(il, inb(il)) >= 0.0001 .AND. iflag(il) <= 2 + END DO + +! +! Get adiabatic ascent mass flux +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + IF (adiab_ascent_mass_flux_depends_on_ejectliq) THEN +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!! Warning : this option leads to water conservation violation +!!! Expert only +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + DO il = 1, ncum + ma(il, nlp) = 0. + ma(il, 1) = 0. + END DO + + DO i = nl, 2, -1 + DO il = 1, ncum + ma(il, i) = ma(il, i+1)*(1.-qta(il,i))/(1.-qta(il,i-1)) + m(il, i) + END DO + END DO +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ELSE ! (adiab_ascent_mass_flux_depends_on_ejectliq) +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + DO il = 1, ncum + ma(il, nlp) = 0. + ma(il, 1) = 0. + END DO + + DO i = nl, 2, -1 + DO il = 1, ncum + ma(il, i) = ma(il, i+1) + m(il, i) + END DO + END DO + + ENDIF ! (adiab_ascent_mass_flux_depends_on_ejectliq) ELSE +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +! +! *** begin downdraft loop *** +! +! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + + DO i = nl + 1, 1, -1 + + num1 = 0 + DO il = 1, ncum + IF (i<=inb(il) .AND. lwork(il)) num1 = num1 + 1 + END DO +!ym IF (num1<=0) GO TO 400 + IF (num1<=0) CYCLE + + wdtrain(1:ncum) = 0.0 + + +! *** integrate liquid water equation to find condensed water *** +! *** and condensed water flux *** +! +! +! *** calculate detrained precipitation *** + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + DO il = 1, ncum + IF (i<=inb(il) .AND. lwork(il)) THEN + wdtrainS(il, i) = ep(il, i)*m(il, i)*clw(il, i) ! jyg + END IF + END DO + + IF (i>1) THEN + DO j = 1, i - 1 + DO il = 1, ncum + IF (i<=inb(il) .AND. lwork(il)) THEN + awat = elij(il, j, i) - (1.-ep(il,i))*clw(il, i) + awat = max(awat, 0.0) + wdtrainM(il, i) = wdtrainM(il, i) + awat*ment(il, j, i) ! jyg + END IF + END DO + END DO + END IF + + IF (cvflag_prec_eject) THEN + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + IF (adiab_ascent_mass_flux_depends_on_ejectliq) THEN + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !!! Warning : this option leads to water conservation violation + !!! Expert only + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + IF ( i > 1) THEN + DO il = 1, ncum + IF (i<=inb(il) .AND. lwork(il)) THEN + wdtrainA(il,i) = ma(il, i+1)*(qta(il, i-1)-qta(il,i))/(1. - qta(il, i-1)) ! Pa jygprl + END IF + END DO + ENDIF ! ( i > 1) + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ELSE ! (adiab_ascent_mass_flux_depends_on_ejectliq) + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + IF ( i > 1) THEN + DO il = 1, ncum + IF (i<=inb(il) .AND. lwork(il)) THEN + wdtrainA(il,i) = ma(il, i+1)*(qta(il, i-1)-qta(il,i)) ! Pa jygprl + END IF + END DO + ENDIF ! ( i > 1) + + ENDIF ! (adiab_ascent_mass_flux_depends_on_ejectliq) ELSE + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ENDIF ! (cvflag_prec_eject) + + IF ( i > 1) THEN + DO il = 1, ncum + IF (i<=inb(il) .AND. lwork(il)) THEN + wdtrain(il) = grav*(wdtrainS(il,i) + wdtrainM(il,i) + wdtrainA(il,i)) + END IF + END DO + ENDIF ! ( i > 1) + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +! *** find rain water and evaporation using provisional *** +! *** estimates of rp(i)and rp(i-1) *** + + + IF (cvflag_ice) THEN !!jygprl + IF (cvflag_prec_eject) THEN + DO il = 1, ncum !!jygprl + IF (i<=inb(il) .AND. lwork(il)) THEN !!jygprl + frac(il, i) = (frac_a(il,i)*wdtrainA(il,i)+frac_s(il,i)*(wdtrainS(il,i)+wdtrainM(il,i))) / & !!jygprl + max(wdtrainA(il,i)+wdtrainS(il,i)+wdtrainM(il,i),smallestreal) !!jygprl + fraci(il, i) = frac(il, i) !!jygprl + END IF !!jygprl + END DO !!jygprl + ELSE ! (cvflag_prec_eject) + DO il = 1, ncum !!jygprl + IF (i<=inb(il) .AND. lwork(il)) THEN !!jygprl +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + IF (keepbug_ice_frac) THEN + frac(il, i) = frac_s(il, i) +! Ice fraction computed again here as a function of the temperature seen by unsaturated downdraughts +! (i.e. the cold pool temperature) for compatibility with earlier versions. + fraci(il, i) = 1. - (t(il,i)-243.15)/(263.15-243.15) + fraci(il, i) = min(max(fraci(il,i),0.0), 1.0) +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ELSE ! (keepbug_ice_frac) +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + frac(il, i) = frac_s(il, i) + fraci(il, i) = frac(il, i) !!jygprl + ENDIF ! (keepbug_ice_frac) +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + END IF !!jygprl + END DO !!jygprl + ENDIF ! (cvflag_prec_eject) + END IF !!jygprl + + + DO il = 1, ncum + IF (i<=inb(il) .AND. lwork(il)) THEN + + wt(il, i) = 45.0 + + IF (i= 20) THEN + Print*, 'cv3_unsat after provisional rp estimate: rp, afac, bfac ', & + i, rp(1, i), afac,bfac + ENDIF +! +!JYG1 +! cc sigt=1.0 +! cc if(i.ge.icb)sigt=sigp(i) +! prise en compte de la variation progressive de sigt dans +! les couches icb et icb-1: +! pour plclph(i), pr1=1 & pr2=0 +! pour ph(i+1)b6*b6+1.E-20) THEN + revap = 2.*c6/(b6+sqrt(b6*b6+4.*c6)) + ELSE + revap = (-b6+sqrt(b6*b6+4.*c6))/2. + END IF + prec(il, i) = max(0., 2.*revap*revap-prec(il,i+1)) +! print*,prec(il,i),'neige' + +!JYG Dans sa formulation originale, Emanuel calcule l'evaporation par: +! c evap(il,i)=sigt*afac*revap +! ce qui n'est pas correct. Dans cv_routines, la formulation a �t� modifiee. +! Ici,l'evaporation evap est simplement calculee par l'equation de +! conservation. +! prec(il,i)=revap*revap +! else +!JYG---- Correction : si c6 <= 0, water(il,i)=0. +! prec(il,i)=0. +! endif + +!JYG--- Dans tous les cas, evaporation = [tt ce qui entre dans la couche i] +! moins [tt ce qui sort de la couche i] +! print *, 'evap avec ice' + evap(il, i) = (wdtrain(il)+sigd(il)*wt(il,i)*(prec(il,i+1)-prec(il,i))) / & + (sigd(il)*(ph(il,i)-ph(il,i+1))*100.) +! + IF (prt_level >= 20) THEN + Print*, 'cv3_unsat after evap computation: wdtrain, sigd, wt, prec(i+1),prec(i) ', & + i, wdtrain(1), sigd(1), wt(1,i), prec(1,i+1),prec(1,i) + ENDIF +! + +!jyg< + d6 = prec(il,i)-prec(il,i+1) + +!! d6 = bfac*wdtrain(il) - 100.*sigd(il)*bfac*(ph(il,i)-ph(il,i+1))*evap(il, i) +!! e6 = bfac*wdtrain(il) +!! f6 = -100.*sigd(il)*bfac*(ph(il,i)-ph(il,i+1))*evap(il, i) +!>jyg +!CR:tmax_fonte_cv: T for which ice is totally melted (used to be 275.15) + thaw = (t(il,i)-273.15)/(tmax_fonte_cv-273.15) + thaw = min(max(thaw,0.0), 1.0) +!jyg< + water(il, i) = water(il, i+1) + (1-fraci(il,i))*d6 + ice(il, i) = ice(il, i+1) + fraci(il, i)*d6 + water(il, i) = min(prec(il,i), max(water(il,i), 0.)) + ice(il, i) = min(prec(il,i), max(ice(il,i), 0.)) + +!! water(il, i) = water(il, i+1) + (1-fraci(il,i))*d6 +!! water(il, i) = max(water(il,i), 0.) +!! ice(il, i) = ice(il, i+1) + fraci(il, i)*d6 +!! ice(il, i) = max(ice(il,i), 0.) +!>jyg + fondue(il, i) = ice(il, i)*thaw + water(il, i) = water(il, i) + fondue(il, i) + ice(il, i) = ice(il, i) - fondue(il, i) + +!! IF (water(il,i)+ice(il,i)<1.E-30) THEN +!! faci(il, i) = 0. +!! ELSE +!! faci(il, i) = ice(il, i)/(water(il,i)+ice(il,i)) +!! END IF + + faci(il,i) = ice(il, i)/max((water(il,i)+ice(il,i)), smallestreal) + +! water(il,i)=water(il,i+1)+(1.-fraci(il,i))*e6+(1.-faci(il,i))*f6 +! water(il,i)=max(water(il,i),0.) +! ice(il,i)=ice(il,i+1)+fraci(il,i)*e6+faci(il,i)*f6 +! ice(il,i)=max(ice(il,i),0.) +! fondue(il,i)=ice(il,i)*thaw +! water(il,i)=water(il,i)+fondue(il,i) +! ice(il,i)=ice(il,i)-fondue(il,i) + +! if((water(il,i)+ice(il,i)).lt.1.e-30)then +! faci(il,i)=0. +! else +! faci(il,i)=ice(il,i)/(water(il,i)+ice(il,i)) +! endif + + ELSE + b6 = bfac*50.*sigd(il)*(ph(il,i)-ph(il,i+1))*sigt*afac + c6 = water(il, i+1) + bfac*wdtrain(il) - & + 50.*sigd(il)*bfac*(ph(il,i)-ph(il,i+1))*evap(il, i+1) + IF (c6>0.0) THEN + revap = 0.5*(-b6+sqrt(b6*b6+4.*c6)) + water(il, i) = revap*revap + ELSE + water(il, i) = 0. + END IF +! print *, 'evap sans ice' + evap(il, i) = (wdtrain(il)+sigd(il)*wt(il,i)*(water(il,i+1)-water(il,i)))/ & + (sigd(il)*(ph(il,i)-ph(il,i+1))*100.) + + END IF + END IF !(i.le.inb(il) .and. lwork(il)) + END DO +! ---------------------------------------------------------------- + +! cc +! *** calculate precipitating downdraft mass flux under *** +! *** hydrostatic approximation *** + + DO il = 1, ncum + IF (i<=inb(il) .AND. lwork(il) .AND. i/=1) THEN + + tevap(il) = max(0.0, evap(il,i)) + delth = max(0.001, (th(il,i)-th(il,i-1))) + IF (cvflag_ice) THEN + IF (cvflag_grav) THEN + mp(il, i) = 100.*ginv*(lvcp(il,i)*sigd(il)*tevap(il)* & + (p(il,i-1)-p(il,i))/delth + & + lfcp(il,i)*sigd(il)*faci(il,i)*tevap(il)* & + (p(il,i-1)-p(il,i))/delth + & + lfcp(il,i)*sigd(il)*wt(il,i)/100.*fondue(il,i)* & + (p(il,i-1)-p(il,i))/delth/(ph(il,i)-ph(il,i+1))) + ELSE + mp(il, i) = 10.*(lvcp(il,i)*sigd(il)*tevap(il)* & + (p(il,i-1)-p(il,i))/delth + & + lfcp(il,i)*sigd(il)*faci(il,i)*tevap(il)* & + (p(il,i-1)-p(il,i))/delth + & + lfcp(il,i)*sigd(il)*wt(il,i)/100.*fondue(il,i)* & + (p(il,i-1)-p(il,i))/delth/(ph(il,i)-ph(il,i+1))) + + END IF + ELSE + IF (cvflag_grav) THEN + mp(il, i) = 100.*ginv*lvcp(il, i)*sigd(il)*tevap(il)* & + (p(il,i-1)-p(il,i))/delth + ELSE + mp(il, i) = 10.*lvcp(il, i)*sigd(il)*tevap(il)* & + (p(il,i-1)-p(il,i))/delth + END IF + + END IF + + END IF !(i.le.inb(il) .and. lwork(il) .and. i.ne.1) + IF (prt_level .GE. 20) THEN + PRINT *,'cv3_unsat, mp hydrostatic ', i, mp(il,i) + ENDIF + END DO +! ---------------------------------------------------------------- + +! *** if hydrostatic assumption fails, *** +! *** solve cubic difference equation for downdraft theta *** +! *** and mass flux from two simultaneous differential eqns *** + + DO il = 1, ncum + IF (i<=inb(il) .AND. lwork(il) .AND. i/=1) THEN + + amfac = sigd(il)*sigd(il)*70.0*ph(il, i)*(p(il,i-1)-p(il,i))* & + (th(il,i)-th(il,i-1))/(tv(il,i)*th(il,i)) + amp2 = abs(mp(il,i+1)*mp(il,i+1)-mp(il,i)*mp(il,i)) + + IF (amp2>(0.1*amfac)) THEN + xf = 100.0*sigd(il)*sigd(il)*sigd(il)*(ph(il,i)-ph(il,i+1)) + tf = b(il, i) - 5.0*(th(il,i)-th(il,i-1))*t(il, i) / & + (lvcp(il,i)*sigd(il)*th(il,i)) + af = xf*tf + mp(il, i+1)*mp(il, i+1)*tinv + + IF (cvflag_ice) THEN + bf = 2.*(tinv*mp(il,i+1))**3 + tinv*mp(il, i+1)*xf*tf + & + 50.*(p(il,i-1)-p(il,i))*xf*(tevap(il)*(1.+(lf(il,i)/lv(il,i))*faci(il,i)) + & + (lf(il,i)/lv(il,i))*wt(il,i)/100.*fondue(il,i)/(ph(il,i)-ph(il,i+1))) + ELSE + + bf = 2.*(tinv*mp(il,i+1))**3 + tinv*mp(il, i+1)*xf*tf + & + 50.*(p(il,i-1)-p(il,i))*xf*tevap(il) + END IF + + fac2 = 1.0 + IF (bf<0.0) fac2 = -1.0 + bf = abs(bf) + ur = 0.25*bf*bf - af*af*af*tinv*tinv*tinv + IF (ur>=0.0) THEN + sru = sqrt(ur) + fac = 1.0 + IF ((0.5*bf-sru)<0.0) fac = -1.0 + mp(il, i) = mp(il, i+1)*tinv + (0.5*bf+sru)**tinv + & + fac*(abs(0.5*bf-sru))**tinv + ELSE + d = atan(2.*sqrt(-ur)/(bf+1.0E-28)) + IF (fac2<0.0) d = 3.14159 - d + mp(il, i) = mp(il, i+1)*tinv + 2.*sqrt(af*tinv)*cos(d*tinv) + END IF + mp(il, i) = max(0.0, mp(il,i)) + IF (prt_level .GE. 20) THEN + PRINT *,'cv3_unsat, mp cubic ', i, mp(il,i) + ENDIF + + IF (cvflag_ice) THEN + IF (cvflag_grav) THEN +!JYG : il y a vraisemblablement une erreur dans la ligne 2 suivante: +! il faut diviser par (mp(il,i)*sigd(il)*grav) et non par (mp(il,i)+sigd(il)*0.1). +! Et il faut bien revoir les facteurs 100. + b(il, i-1) = b(il, i) + 100.0*(p(il,i-1)-p(il,i))* & + (tevap(il)*(1.+(lf(il,i)/lv(il,i))*faci(il,i)) + & + (lf(il,i)/lv(il,i))*wt(il,i)/100.*fondue(il,i) / & + (ph(il,i)-ph(il,i+1))) / & + (mp(il,i)+sigd(il)*0.1) - & + 10.0*(th(il,i)-th(il,i-1))*t(il, i) / & + (lvcp(il,i)*sigd(il)*th(il,i)) + ELSE + b(il, i-1) = b(il, i) + 100.0*(p(il,i-1)-p(il,i))*& + (tevap(il)*(1.+(lf(il,i)/lv(il,i))*faci(il,i)) + & + (lf(il,i)/lv(il,i))*wt(il,i)/100.*fondue(il,i) / & + (ph(il,i)-ph(il,i+1))) / & + (mp(il,i)+sigd(il)*0.1) - & + 10.0*(th(il,i)-th(il,i-1))*t(il, i) / & + (lvcp(il,i)*sigd(il)*th(il,i)) + END IF + ELSE + IF (cvflag_grav) THEN + b(il, i-1) = b(il, i) + 100.0*(p(il,i-1)-p(il,i))*tevap(il) / & + (mp(il,i)+sigd(il)*0.1) - & + 10.0*(th(il,i)-th(il,i-1))*t(il, i) / & + (lvcp(il,i)*sigd(il)*th(il,i)) + ELSE + b(il, i-1) = b(il, i) + 100.0*(p(il,i-1)-p(il,i))*tevap(il) / & + (mp(il,i)+sigd(il)*0.1) - & + 10.0*(th(il,i)-th(il,i-1))*t(il, i) / & + (lvcp(il,i)*sigd(il)*th(il,i)) + END IF + END IF + b(il, i-1) = max(b(il,i-1), 0.0) + + END IF !(amp2.gt.(0.1*amfac)) + +!jyg< This part shifted 10 lines farther +!!! *** limit magnitude of mp(i) to meet cfl condition *** +!! +!! ampmax = 2.0*(ph(il,i)-ph(il,i+1))*delti +!! amp2 = 2.0*(ph(il,i-1)-ph(il,i))*delti +!! ampmax = min(ampmax, amp2) +!! mp(il, i) = min(mp(il,i), ampmax) +!>jyg + +! *** force mp to decrease linearly to zero *** +! *** between cloud base and the surface *** + + +! c if(p(il,i).gt.p(il,icb(il)))then +! c mp(il,i)=mp(il,icb(il))*(p(il,1)-p(il,i))/(p(il,1)-p(il,icb(il))) +! c endif + IF (ph(il,i)>0.9*plcl(il)) THEN + mp(il, i) = mp(il, i)*(ph(il,1)-ph(il,i))/(ph(il,1)-0.9*plcl(il)) + END IF + +!jyg< Shifted part +! *** limit magnitude of mp(i) to meet cfl condition *** + + ampmax = 2.0*(ph(il,i)-ph(il,i+1))*delti + amp2 = 2.0*(ph(il,i-1)-ph(il,i))*delti + ampmax = min(ampmax, amp2) + mp(il, i) = min(mp(il,i), ampmax) +!>jyg + + END IF ! (i.le.inb(il) .and. lwork(il) .and. i.ne.1) + END DO +! ---------------------------------------------------------------- +! + IF (prt_level >= 20) THEN + Print*, 'cv3_unsat after mp computation: mp, b(i), b(i-1) ', & + i, mp(1, i), b(1,i), b(1,max(i-1,1)) + ENDIF +! + +! *** find mixing ratio of precipitating downdraft *** + + DO il = 1, ncum + IF (i mp(il, i+1) + END IF ! (i.lt.inb(il) .and. lwork(il)) + END DO + + DO il = 1, ncum + IF (i1.0E-16) THEN + IF (cvflag_grav) THEN + rp(il, i) = rp(il,i+1) + 100.*ginv*0.5*sigd(il)*(ph(il,i)-ph(il,i+1)) * & + (evap(il,i+1)+evap(il,i))/mp(il,i+1) + ELSE + rp(il, i) = rp(il,i+1) + 5.*sigd(il)*(ph(il,i)-ph(il,i+1)) * & + (evap(il,i+1)+evap(il,i))/mp(il, i+1) + END IF + up(il, i) = up(il, i+1) + vp(il, i) = vp(il, i+1) + END IF ! (mp(il,i+1).gt.1.0e-16) + END IF ! (mplus(il)) else if (.not.mplus(il)) + + rp(il, i) = amin1(rp(il,i), rs(il,i)) + rp(il, i) = max(rp(il,i), 0.0) + + END IF ! (i.lt.inb(il) .and. lwork(il)) + END DO +! ---------------------------------------------------------------- + +! *** find tracer concentrations in precipitating downdraft *** + +400 END DO +! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + +! *** end of downdraft loop *** + +! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + + RETURN + +END SUBROUTINE cv3_unsat + +!!SUBROUTINE cv3_yield(nloc, ncum, nd, na, ntra, ok_conserv_q, & !jyg: get rid of ntra +SUBROUTINE cv3_yield(nloc, ncum, nd, na, ok_conserv_q, & + icb, inb, delt, & +!! t, rr, t_wake, rr_wake, s_wake, u, v, tra, & !jyg: get rid of ntra + t, rr, t_wake, rr_wake, s_wake, u, v, & + gz, p, ph, h, hp, lv, lf, cpn, th, th_wake, & +!! ep, clw, qpreca, m, tp, mp, rp, up, vp, trap, & !jyg: get rid of ntra + ep, clw, qpreca, m, tp, mp, rp, up, vp, & + wt, water, ice, evap, fondue, faci, b, sigd, & + ment, qent, hent, iflag_mix, uent, vent, & +!! nent, elij, traent, sig, & !jyg: get rid of ntra + nent, elij, sig, & + tv, tvp, wghti, & + iflag, precip, Vprecip, Vprecipi, & ! jyg: Vprecipi +!! ft, fr, fr_comp, fu, fv, ftra, & ! jyg !jyg: get rid of ntra + ft, fr, fr_comp, fu, fv, & ! jyg + cbmf, upwd, dnwd, dnwd0, ma, mip, & +!! tls, tps, ! useless . jyg + qcondc, wd, & + ftd, fqd, qta, qtc, sigt, detrain, tau_cld_cv, coefw_cld_cv) + + USE conema3_mod_h + USE print_control_mod, ONLY: lunout, prt_level + USE add_phys_tend_mod, only : fl_cor_ebil + USE cvflag_mod_h + USE lmdz_cv_ini, ONLY : grav,minorig,nl,nlp,rowl,rrd,nl,ci,cl,cpd,cpv + USE lmdz_cv_ini, ONLY : restore_bug_cvdn + + IMPLICIT NONE + + +!inputs: + INTEGER, INTENT (IN) :: iflag_mix +!! INTEGER, INTENT (IN) :: ncum, nd, na, ntra, nloc !jyg: get rid of ntra + INTEGER, INTENT (IN) :: ncum, nd, na, nloc + LOGICAL, INTENT (IN) :: ok_conserv_q + INTEGER, DIMENSION (nloc), INTENT (IN) :: icb, inb + REAL, INTENT (IN) :: delt + REAL, DIMENSION (nloc, nd), INTENT (IN) :: t, rr, u, v + REAL, DIMENSION (nloc, nd), INTENT (IN) :: t_wake, rr_wake + REAL, DIMENSION (nloc), INTENT (IN) :: s_wake +!! REAL, DIMENSION (nloc, nd, ntra), INTENT (IN) :: tra !jyg: get rid of ntra + REAL, DIMENSION (nloc, nd), INTENT (IN) :: p + REAL, DIMENSION (nloc, nd+1), INTENT (IN) :: ph + REAL, DIMENSION (nloc, na), INTENT (IN) :: gz, h, hp + REAL, DIMENSION (nloc, na), INTENT (IN) :: th, tp + REAL, DIMENSION (nloc, na), INTENT (IN) :: lv, cpn, ep, clw + REAL, DIMENSION (nloc, na), INTENT (IN) :: lf + REAL, DIMENSION (nloc, na), INTENT (IN) :: rp, up + REAL, DIMENSION (nloc, na), INTENT (IN) :: vp + REAL, DIMENSION (nloc, nd), INTENT (IN) :: wt +!! REAL, DIMENSION (nloc, nd, ntra), INTENT (IN) :: trap !jyg: get rid of ntra + REAL, DIMENSION (nloc, na), INTENT (IN) :: water, evap, b + REAL, DIMENSION (nloc, na), INTENT (IN) :: fondue, faci, ice + REAL, DIMENSION (nloc, na, na), INTENT (IN) :: qent, uent + REAL, DIMENSION (nloc, na, na), INTENT (IN) :: hent + REAL, DIMENSION (nloc, na, na), INTENT (IN) :: vent, elij + INTEGER, DIMENSION (nloc, nd), INTENT (IN) :: nent +!! REAL, DIMENSION (nloc, na, na, ntra), INTENT (IN) :: traent !jyg: get rid of ntra + REAL, DIMENSION (nloc, nd), INTENT (IN) :: tv, tvp, wghti + REAL, DIMENSION (nloc, nd), INTENT (IN) :: qta + REAL, DIMENSION (nloc, na),INTENT(IN) :: qpreca + REAL, INTENT(IN) :: tau_cld_cv, coefw_cld_cv +! +!input/output: + REAL, DIMENSION (nloc, na), INTENT (INOUT) :: m, mp + REAL, DIMENSION (nloc, na, na), INTENT (INOUT) :: ment + INTEGER, DIMENSION (nloc), INTENT (INOUT) :: iflag + REAL, DIMENSION (nloc, nd), INTENT (INOUT) :: sig + REAL, DIMENSION (nloc), INTENT (INOUT) :: sigd +! +!outputs: + REAL, DIMENSION (nloc), INTENT (OUT) :: precip + REAL, DIMENSION (nloc, nd), INTENT (OUT) :: ft, fr, fu, fv , fr_comp + REAL, DIMENSION (nloc, nd), INTENT (OUT) :: ftd, fqd +!! REAL, DIMENSION (nloc, nd, ntra), INTENT (OUT) :: ftra !jyg: get rid of ntra + REAL, DIMENSION (nloc, nd), INTENT (OUT) :: upwd, dnwd, ma + REAL, DIMENSION (nloc, nd), INTENT (OUT) :: dnwd0, mip + REAL, DIMENSION (nloc, nd+1), INTENT (OUT) :: Vprecip + REAL, DIMENSION (nloc, nd+1), INTENT (OUT) :: Vprecipi +!! REAL tls(nloc, nd), tps(nloc, nd) ! useless . jyg + REAL, DIMENSION (nloc, nd), INTENT (OUT) :: qcondc ! cld + REAL, DIMENSION (nloc, nd), INTENT (OUT) :: qtc, sigt ! cld + REAL, DIMENSION (nloc, nd), INTENT (OUT) :: detrain ! Louis : pour le calcul de Klein du terme de variance qui detraine dans lenvironnement + REAL, DIMENSION (nloc), INTENT (OUT) :: wd ! gust + REAL, DIMENSION (nloc), INTENT (OUT) :: cbmf +! +!local variables: + INTEGER :: i, k, il, n, j, num1 + REAL :: rat, delti + REAL :: ax, bx, cx, dx, ex + REAL :: cpinv, rdcp, dpinv + REAL :: sigaq + REAL, DIMENSION (nloc) :: awat + REAL, DIMENSION (nloc, nd) :: lvcp, lfcp ! , mke ! unused . jyg + REAL, DIMENSION (nloc) :: am, work, ad, amp1 +!! real up1(nloc), dn1(nloc) + REAL, DIMENSION (nloc, nd, nd) :: up1, dn1 +!jyg< + REAL, DIMENSION (nloc, nd) :: up_to, up_from + REAL, DIMENSION (nloc, nd) :: dn_to, dn_from +!>jyg + REAL, DIMENSION (nloc) :: asum, bsum, csum, dsum + REAL, DIMENSION (nloc) :: esum, fsum, gsum, hsum + REAL, DIMENSION (nloc, nd) :: th_wake + REAL, DIMENSION (nloc) :: alpha_qpos, alpha_qpos1 + REAL, DIMENSION (nloc, nd) :: qcond, nqcond, wa ! cld + REAL, DIMENSION (nloc, nd) :: siga, sax, mac ! cld + REAL, DIMENSION (nloc) :: sument + REAL, DIMENSION (nloc, nd) :: sigment, qtment ! cld + REAL, DIMENSION (nloc, nd, nd) :: qdet +!! REAL sumdq !jyg +! +! ------------------------------------------------------------- + + +! initialization: + + delti = 1.0/delt +! print*,'cv3_yield initialisation delt', delt + + DO il = 1, ncum + precip(il) = 0.0 + wd(il) = 0.0 ! gust + END DO + +! Fluxes are on a staggered grid : loops extend up to nl+1 + DO i = 1, nlp + DO il = 1, ncum + Vprecip(il, i) = 0.0 + Vprecipi(il, i) = 0.0 ! jyg + upwd(il, i) = 0.0 + dnwd(il, i) = 0.0 + dnwd0(il, i) = 0.0 + mip(il, i) = 0.0 + END DO + END DO + DO i = 1, nl + DO il = 1, ncum + ft(il, i) = 0.0 + fr(il, i) = 0.0 + fr_comp(il,i) = 0.0 + fu(il, i) = 0.0 + fv(il, i) = 0.0 + ftd(il, i) = 0.0 + fqd(il, i) = 0.0 + qcondc(il, i) = 0.0 ! cld + qcond(il, i) = 0.0 ! cld + qtc(il, i) = 0.0 ! cld + qtment(il, i) = 0.0 ! cld + sigment(il, i) = 0.0 ! cld + sigt(il, i) = 0.0 ! cld + qdet(il,i,:) = 0.0 ! cld + detrain(il, i) = 0.0 ! cld + nqcond(il, i) = 0.0 ! cld + END DO + END DO +! print*,'cv3_yield initialisation 2' +! print*,'cv3_yield initialisation 3' + DO i = 1, nl + DO il = 1, ncum + lvcp(il, i) = lv(il, i)/cpn(il, i) + lfcp(il, i) = lf(il, i)/cpn(il, i) + END DO + END DO + + + +! *** calculate surface precipitation in mm/day *** + + DO il = 1, ncum + IF (ep(il,inb(il))>=0.0001 .AND. iflag(il)<=1) THEN + IF (cvflag_ice) THEN + precip(il) = wt(il, 1)*sigd(il)*(water(il,1)+ice(il,1)) & + *86400.*1000./(rowl*grav) + ELSE + precip(il) = wt(il, 1)*sigd(il)*water(il, 1) & + *86400.*1000./(rowl*grav) + END IF + END IF + END DO +! print*,'cv3_yield apres calcul precip' + + +! === calculate vertical profile of precipitation in kg/m2/s === + + DO i = 1, nl + DO il = 1, ncum + IF (ep(il,inb(il))>=0.0001 .AND. i<=inb(il) .AND. iflag(il)<=1) THEN + IF (cvflag_ice) THEN + Vprecip(il, i) = wt(il, i)*sigd(il)*(water(il,i)+ice(il,i))/grav + Vprecipi(il, i) = wt(il, i)*sigd(il)*ice(il,i)/grav ! jyg + ELSE + Vprecip(il, i) = wt(il, i)*sigd(il)*water(il, i)/grav + Vprecipi(il, i) = 0. ! jyg + END IF + END IF + END DO + END DO + + +! *** Calculate downdraft velocity scale *** +! *** NE PAS UTILISER POUR L'INSTANT *** + +!! do il=1,ncum +!! wd(il)=betad*abs(mp(il,icb(il)))*0.01*rrd*t(il,icb(il)) & +!! /(sigd(il)*p(il,icb(il))) +!! enddo + + +! *** calculate tendencies of lowest level potential temperature *** +! *** and mixing ratio *** + + DO il = 1, ncum + work(il) = 1.0/(ph(il,1)-ph(il,2)) + cbmf(il) = 0.0 + END DO + +! - Adiabatic ascent mass flux "ma" and cloud base mass flux "cbmf" +!----------------------------------------------------------------- +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + IF (adiab_ascent_mass_flux_depends_on_ejectliq) THEN +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!! Warning : this option leads to water conservation violation +!!! Expert only +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + DO il = 1, ncum + ma(il, nlp) = 0. + ma(il, 1) = 0. + END DO + DO k = nl, 2, -1 + DO il = 1, ncum + ma(il, k) = ma(il, k+1)*(1.-qta(il, k))/(1.-qta(il, k-1)) + m(il, k) + cbmf(il) = max(cbmf(il), ma(il,k)) + END DO + END DO + DO k = 2,nl + DO il = 1, ncum + IF (k =icb(il)) THEN + cbmf(il) = cbmf(il) + m(il, k) + END IF + END DO + END DO + + DO il = 1, ncum + ma(il, nlp) = 0. + ma(il, 1) = 0. + END DO + DO k = nl, 2, -1 + DO il = 1, ncum + ma(il, k) = ma(il, k+1) + m(il, k) + END DO + END DO + DO k = 2,nl + DO il = 1, ncum + IF (k =delti) iflag(il) = 1 !consist vect +!jyg< + IF (fl_cor_ebil >= 2) THEN + ft(il, 1) = ft(il, 1) + 0.01*grav*work(il)*am(il) * & + ((t(il,2)-t(il,1))*cpn(il,2)+gz(il,2)-gz(il,1))/cpn(il,1) + ELSE + ft(il, 1) = ft(il, 1) + 0.01*grav*work(il)*am(il) * & + (t(il,2)-t(il,1)+(gz(il,2)-gz(il,1))/cpn(il,1)) + ENDIF +!>jyg + END IF ! iflag + END DO + + + DO j = 2, nl + IF (iflag_mix>0) THEN + DO il = 1, ncum +! FH WARNING a modifier : + cpinv = 0. +! cpinv=1.0/cpn(il,1) + IF (j<=inb(il) .AND. iflag(il)<=1) THEN + ft(il, 1) = ft(il, 1) + 0.01*grav*work(il)*ment(il, j, 1) * & + (hent(il,j,1)-h(il,1)+t(il,1)*(cpv-cpd)*(rr(il,1)-qent(il,j,1)))*cpinv + END IF ! j + END DO + END IF + END DO +! fin sature + + + DO il = 1, ncum + IF (iflag(il)<=1) THEN +!JYG1 Correction pour mieux conserver l'eau (conformite avec CONVECT4.3) + fr(il, 1) = 0.01*grav*mp(il, 2)*(rp(il,2)-rr_wake(il,1))*work(il) + & + sigd(il)*evap(il, 1) +!!! sigd(il)*0.5*(evap(il,1)+evap(il,2)) + + fqd(il, 1) = fr(il, 1) !precip + + fr(il, 1) = fr(il, 1) + 0.01*grav*am(il)*(rr(il,2)-rr(il,1))*work(il) !sature + + fu(il, 1) = fu(il, 1) + 0.01*grav*work(il)*(mp(il,2)*(up(il,2)-u(il,1)) + & + am(il)*(u(il,2)-u(il,1))) + fv(il, 1) = fv(il, 1) + 0.01*grav*work(il)*(mp(il,2)*(vp(il,2)-v(il,1)) + & + am(il)*(v(il,2)-v(il,1))) + END IF ! iflag + END DO ! il + + + DO j = 2, nl + DO il = 1, ncum + IF (j<=inb(il) .AND. iflag(il)<=1) THEN + fr(il, 1) = fr(il, 1) + 0.01*grav*work(il)*ment(il, j, 1)*(qent(il,j,1)-rr(il,1)) + fr_comp(il,1) = fr_comp(il,1) + 0.01*grav*work(il)*ment(il, j, 1)*(qent(il,j,1)-rr(il,1)) + fu(il, 1) = fu(il, 1) + 0.01*grav*work(il)*ment(il, j, 1)*(uent(il,j,1)-u(il,1)) + fv(il, 1) = fv(il, 1) + 0.01*grav*work(il)*ment(il, j, 1)*(vent(il,j,1)-v(il,1)) + END IF ! j + END DO + END DO + +! print*,'cv3_yield apres ft' + +!jyg< +!----------------------------------------------------------- + IF (ok_optim_yield) THEN !| +!----------------------------------------------------------- +! +!*** *** +!*** Compute convective mass fluxes upwd and dnwd *** + +! +! ================================================= +! upward fluxes | +! ------------------------------------------------ +! +upwd(:,:) = 0. +up_to(:,:) = 0. +up_from(:,:) = 0. +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + IF (adiab_ascent_mass_flux_depends_on_ejectliq) THEN +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! The decrease of the adiabatic ascent mass flux due to ejection of precipitation +!! is taken into account. +!! WARNING : in the present version, taking into account the mass-flux decrease due to +!! precipitation ejection leads to water conservation violation. +! +! - Upward mass flux of mixed draughts +!--------------------------------------- +DO i = 2, nl + DO j = 1, i-1 + DO il = 1, ncum + IF (i<=inb(il)) THEN + up_to(il,i) = up_to(il,i) + ment(il,j,i) + ENDIF + ENDDO + ENDDO +ENDDO +! +DO j = 3, nl + DO i = 2, j-1 + DO il = 1, ncum + IF (j<=inb(il)) THEN + up_from(il,i) = up_from(il,i) + ment(il,i,j) + ENDIF + ENDDO + ENDDO +ENDDO +! +! The difference between upwd(il,i) and upwd(il,i-1) is due to updrafts ending in layer +!(i-1) (theses drafts cross interface (i-1) but not interface(i)) and to updrafts starting +!from layer (i-1) (theses drafts cross interface (i) but not interface(i-1)): +! +DO i = 2, nlp + DO il = 1, ncum + IF (i<=inb(il)+1) THEN + upwd(il,i) = max(0., upwd(il,i-1) - up_to(il,i-1) + up_from(il,i-1)) + ENDIF + ENDDO +ENDDO +! +! - Total upward mass flux +!--------------------------- +DO i = 2, nlp + DO il = 1, ncum + IF (i<=inb(il)+1) THEN + upwd(il,i) = upwd(il,i) + ma(il,i) + ENDIF + ENDDO +ENDDO +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ELSE ! (adiab_ascent_mass_flux_depends_on_ejectliq) +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! The decrease of the adiabatic ascent mass flux due to ejection of precipitation +!! is not taken into account. +! +! - Upward mass flux +!------------------- +DO i = 2, nl + DO il = 1, ncum + IF (i<=inb(il)) THEN + up_to(il,i) = m(il,i) + ENDIF + ENDDO + DO j = 1, i-1 + DO il = 1, ncum + IF (i<=inb(il)) THEN + up_to(il,i) = up_to(il,i) + ment(il,j,i) + ENDIF + ENDDO + ENDDO +ENDDO +! +DO i = 1, nl + DO il = 1, ncum + IF (i<=inb(il)) THEN + up_from(il,i) = cbmf(il)*wghti(il,i) + ENDIF + ENDDO +ENDDO +! +DO j = 3, nl + DO i = 2, j-1 + DO il = 1, ncum + IF (j<=inb(il)) THEN + up_from(il,i) = up_from(il,i) + ment(il,i,j) + ENDIF + ENDDO + ENDDO +ENDDO +! +! The difference between upwd(il,i) and upwd(il,i-1) is due to updrafts ending in layer +!(i-1) (theses drafts cross interface (i-1) but not interface(i)) and to updrafts starting +!from layer (i-1) (theses drafts cross interface (i) but not interface(i-1)): +! +DO i = 2, nlp + DO il = 1, ncum + IF (i<=inb(il)+1) THEN + upwd(il,i) = max(0., upwd(il,i-1) - up_to(il,i-1) + up_from(il,i-1)) + ENDIF + ENDDO +ENDDO + + + ENDIF ! (adiab_ascent_mass_flux_depends_on_ejectliq) ELSE +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +! +! ================================================= +! downward fluxes | +! ------------------------------------------------ +dnwd(:,:) = 0. +dn_to(:,:) = 0. +dn_from(:,:) = 0. +DO i = 1, nl + DO j = i+1, nl + DO il = 1, ncum + IF (j<=inb(il)) THEN +!! dn_to(il,i) = dn_to(il,i) + ment(il,j,i) !jyg,20220202 + dn_to(il,i) = dn_to(il,i) - ment(il,j,i) + ENDIF + ENDDO + ENDDO +ENDDO +! +DO j = 1, nl + DO i = j+1, nl + DO il = 1, ncum + IF (i<=inb(il)) THEN +!! dn_from(il,i) = dn_from(il,i) + ment(il,i,j) !jyg,20220202 + dn_from(il,i) = dn_from(il,i) - ment(il,i,j) + ENDIF + ENDDO + ENDDO +ENDDO +! +! The difference between dnwd(il,i) and dnwd(il,i+1) is due to downdrafts ending in layer +!(i) (theses drafts cross interface (i+1) but not interface(i)) and to downdrafts +!starting from layer (i) (theses drafts cross interface (i) but not interface(i+1)): +! +DO i = nl-1, 1, -1 + DO il = 1, ncum +!! dnwd(il,i) = max(0., dnwd(il,i+1) - dn_to(il,i) + dn_from(il,i)) !jyg,20220202 + dnwd(il,i) = min(0., dnwd(il,i+1) - dn_to(il,i) + dn_from(il,i)) + ENDDO +ENDDO +! ================================================= +! +!----------------------------------------------------------- + ENDIF !(ok_optim_yield) !| +!----------------------------------------------------------- +!>jyg + +! *** calculate tendencies of potential temperature and mixing ratio *** +! *** at levels above the lowest level *** + +! *** first find the net saturated updraft and downdraft mass fluxes *** +! *** through each level *** + +!jyg< +!! DO i = 2, nl + 1 ! newvecto: mettre nl au lieu nl+1? + DO i = 2, nl +!>jyg + + num1 = 0 + DO il = 1, ncum + IF (i<=inb(il) .AND. iflag(il)<=1) num1 = num1 + 1 + END DO +!ym IF (num1<=0) GO TO 500 + IF (num1<=0) CYCLE + +! +!jyg< +!----------------------------------------------------------- + IF (ok_optim_yield) THEN !| +!----------------------------------------------------------- + + ! Restoring a bug that was found and corrected in svn release + ! 5544; which appears to have a much stronger impact than initially + ! thought + + if ( restore_bug_cvdn ) then + DO il = 1, ncum + amp1(il) = upwd(il,i+1) + ad(il) = dnwd(il,i) + ENDDO + else + DO il = 1, ncum + amp1(il) = upwd(il,i+1) + ad(il) = - dnwd(il,i) + ENDDO + endif +!----------------------------------------------------------- + ELSE !(ok_optim_yield) !| +!----------------------------------------------------------- +!>jyg + DO il = 1,ncum + amp1(il) = 0. + ad(il) = 0. + ENDDO + + DO k = 1, nl + 1 + DO il = 1, ncum + IF (i>=icb(il)) THEN + IF (k>=i+1 .AND. k<=(inb(il)+1)) THEN + amp1(il) = amp1(il) + m(il, k) + END IF + ELSE +! AMP1 is the part of cbmf taken from layers I and lower + IF (k<=i) THEN + amp1(il) = amp1(il) + cbmf(il)*wghti(il, k) + END IF + END IF + END DO + END DO + + DO j = i + 1, nl + 1 + DO k = 1, i + !yor! reverted j and k loops + DO il = 1, ncum +!yor! IF (i<=inb(il) .AND. j<=(inb(il)+1)) THEN ! the second condition implies the first ! + IF (j<=(inb(il)+1)) THEN + amp1(il) = amp1(il) + ment(il, k, j) + END IF + END DO + END DO + END DO + + DO k = 1, i - 1 +!jyg< +!! DO j = i, nl + 1 ! newvecto: nl au lieu nl+1? + DO j = i, nl +!>jyg + DO il = 1, ncum +!yor! IF (i<=inb(il) .AND. j<=inb(il)) THEN ! the second condition implies the 1st ! + IF (j<=inb(il)) THEN + ad(il) = ad(il) + ment(il, j, k) + END IF + END DO + END DO + END DO +! +!----------------------------------------------------------- + ENDIF !(ok_optim_yield) !| +!----------------------------------------------------------- +! +!! print *,'yield, i, amp1, ad', i, amp1(1), ad(1) + + DO il = 1, ncum + IF (i<=inb(il) .AND. iflag(il)<=1) THEN + dpinv = 1.0/(ph(il,i)-ph(il,i+1)) + cpinv = 1.0/cpn(il, i) + +! convect3 if((0.1*dpinv*amp1).ge.delti)iflag(il)=4 + IF ((0.01*grav*dpinv*amp1(il))>=delti) iflag(il) = 1 ! vecto + +! precip +! cc ft(il,i)= -0.5*sigd(il)*lvcp(il,i)*(evap(il,i)+evap(il,i+1)) + IF (cvflag_ice) THEN + ft(il, i) = -sigd(il)*lvcp(il, i)*evap(il, i) - & + sigd(il)*lfcp(il, i)*evap(il, i)*faci(il, i) - & + sigd(il)*lfcp(il, i)*fondue(il, i)*wt(il, i)/(100.*(p(il,i-1)-p(il,i))) + ELSE + ft(il, i) = -sigd(il)*lvcp(il, i)*evap(il, i) + END IF + + rat = cpn(il, i-1)*cpinv + + ft(il, i) = ft(il, i) - 0.009*grav*sigd(il) * & + (mp(il,i+1)*t_wake(il,i)*b(il,i)-mp(il,i)*t_wake(il,i-1)*rat*b(il,i-1))*dpinv + IF (cvflag_ice) THEN + ft(il, i) = ft(il, i) + 0.01*sigd(il)*wt(il, i)*(cl-cpd)*water(il, i+1) * & + (t_wake(il,i+1)-t_wake(il,i))*dpinv*cpinv + & + 0.01*sigd(il)*wt(il, i)*(ci-cpd)*ice(il, i+1) * & + (t_wake(il,i+1)-t_wake(il,i))*dpinv*cpinv + ELSE + ft(il, i) = ft(il, i) + 0.01*sigd(il)*wt(il, i)*(cl-cpd)*water(il, i+1) * & + (t_wake(il,i+1)-t_wake(il,i))*dpinv* & + cpinv + END IF + + ftd(il, i) = ft(il, i) +! fin precip + +! sature +!jyg< + IF (fl_cor_ebil >= 2) THEN + ft(il, i) = ft(il, i) + 0.01*grav*dpinv * & + ( amp1(il)*( (t(il,i+1)-t(il,i))*cpn(il,i+1) + gz(il,i+1)-gz(il,i))*cpinv - & + ad(il)*( (t(il,i)-t(il,i-1))*cpn(il,i-1) + gz(il,i)-gz(il,i-1))*cpinv) + ELSE + ft(il, i) = ft(il, i) + 0.01*grav*dpinv * & + (amp1(il)*(t(il,i+1)-t(il,i) + (gz(il,i+1)-gz(il,i))*cpinv) - & + ad(il)*(t(il,i)-t(il,i-1)+(gz(il,i)-gz(il,i-1))*cpinv)) + ENDIF +!>jyg + + + IF (iflag_mix==0) THEN + ft(il, i) = ft(il, i) + 0.01*grav*dpinv*ment(il, i, i)*(hp(il,i)-h(il,i) + & + t(il,i)*(cpv-cpd)*(rr(il,i)-qent(il,i,i)))*cpinv + END IF +! +! sb: on ne fait pas encore la correction permettant de mieux +! conserver l'eau: +!JYG: correction permettant de mieux conserver l'eau: +! cc fr(il,i)=0.5*sigd(il)*(evap(il,i)+evap(il,i+1)) + fr(il, i) = sigd(il)*evap(il, i) + 0.01*grav*(mp(il,i+1)*(rp(il,i+1)-rr_wake(il,i)) - & + mp(il,i)*(rp(il,i)-rr_wake(il,i-1)))*dpinv + fqd(il, i) = fr(il, i) ! precip + + fu(il, i) = 0.01*grav*(mp(il,i+1)*(up(il,i+1)-u(il,i)) - & + mp(il,i)*(up(il,i)-u(il,i-1)))*dpinv + fv(il, i) = 0.01*grav*(mp(il,i+1)*(vp(il,i+1)-v(il,i)) - & + mp(il,i)*(vp(il,i)-v(il,i-1)))*dpinv + + + fr(il, i) = fr(il, i) + 0.01*grav*dpinv*(amp1(il)*(rr(il,i+1)-rr(il,i)) - & + ad(il)*(rr(il,i)-rr(il,i-1))) + fu(il, i) = fu(il, i) + 0.01*grav*dpinv*(amp1(il)*(u(il,i+1)-u(il,i)) - & + ad(il)*(u(il,i)-u(il,i-1))) + fv(il, i) = fv(il, i) + 0.01*grav*dpinv*(amp1(il)*(v(il,i+1)-v(il,i)) - & + ad(il)*(v(il,i)-v(il,i-1))) + + END IF ! i + END DO + + DO k = 1, i - 1 + + DO il = 1, ncum + awat(il) = elij(il, k, i) - (1.-ep(il,i))*clw(il, i) + awat(il) = max(awat(il), 0.0) + END DO + + IF (iflag_mix/=0) THEN + DO il = 1, ncum + IF (i<=inb(il) .AND. iflag(il)<=1) THEN + dpinv = 1.0/(ph(il,i)-ph(il,i+1)) + cpinv = 1.0/cpn(il, i) + ft(il, i) = ft(il, i) + 0.01*grav*dpinv*ment(il, k, i) * & + (hent(il,k,i)-h(il,i)+t(il,i)*(cpv-cpd)*(rr(il,i)+awat(il)-qent(il,k,i)))*cpinv +! +! + END IF ! i + END DO + END IF + + DO il = 1, ncum + IF (i<=inb(il) .AND. iflag(il)<=1) THEN + dpinv = 1.0/(ph(il,i)-ph(il,i+1)) + cpinv = 1.0/cpn(il, i) + fr(il, i) = fr(il, i) + 0.01*grav*dpinv*ment(il, k, i) * & + (qent(il,k,i)-awat(il)-rr(il,i)) + fr_comp(il,i) = fr_comp(il,i) + 0.01*grav*dpinv*ment(il, k, i)*(qent(il,k,i)-awat(il)-rr(il,i)) + fu(il, i) = fu(il, i) + 0.01*grav*dpinv*ment(il, k, i)*(uent(il,k,i)-u(il,i)) + fv(il, i) = fv(il, i) + 0.01*grav*dpinv*ment(il, k, i)*(vent(il,k,i)-v(il,i)) + +! (saturated updrafts resulting from mixing) ! cld + qcond(il, i) = qcond(il, i) + (elij(il,k,i)-awat(il)) ! cld + qdet(il,k,i) = (qent(il,k,i)-awat(il)) ! cld Louis : specific humidity in detraining water + qtment(il, i) = qtment(il, i) + qent(il,k,i) ! cld + nqcond(il, i) = nqcond(il, i) + 1. ! cld + END IF ! i + END DO + END DO + +!jyg< +!! DO k = i, nl + 1 + DO k = i, nl +!>jyg + + IF (iflag_mix/=0) THEN + DO il = 1, ncum + IF (i<=inb(il) .AND. k<=inb(il) .AND. iflag(il)<=1) THEN + dpinv = 1.0/(ph(il,i)-ph(il,i+1)) + cpinv = 1.0/cpn(il, i) + ft(il, i) = ft(il, i) + 0.01*grav*dpinv*ment(il, k, i) * & + (hent(il,k,i)-h(il,i)+t(il,i)*(cpv-cpd)*(rr(il,i)-qent(il,k,i)))*cpinv + + + END IF ! i + END DO + END IF + + DO il = 1, ncum + IF (i<=inb(il) .AND. k<=inb(il) .AND. iflag(il)<=1) THEN + dpinv = 1.0/(ph(il,i)-ph(il,i+1)) + cpinv = 1.0/cpn(il, i) + + fr(il, i) = fr(il, i) + 0.01*grav*dpinv*ment(il, k, i)*(qent(il,k,i)-rr(il,i)) + fu(il, i) = fu(il, i) + 0.01*grav*dpinv*ment(il, k, i)*(uent(il,k,i)-u(il,i)) + fv(il, i) = fv(il, i) + 0.01*grav*dpinv*ment(il, k, i)*(vent(il,k,i)-v(il,i)) + END IF ! i and k + END DO + END DO + +! sb: interface with the cloud parameterization: ! cld + + DO k = i + 1, nl + DO il = 1, ncum + IF (k<=inb(il) .AND. i<=inb(il) .AND. iflag(il)<=1) THEN ! cld +! (saturated downdrafts resulting from mixing) ! cld + qcond(il, i) = qcond(il, i) + elij(il, k, i) ! cld + qdet(il,k,i) = qent(il,k,i) ! cld Louis : specific humidity in detraining water + qtment(il, i) = qent(il,k,i) + qtment(il,i) ! cld + nqcond(il, i) = nqcond(il, i) + 1. ! cld + END IF ! cld + END DO ! cld + END DO ! cld + +!ym BIG Warning : it seems that the k loop is missing !!! +!ym Strong advice to check this +!ym add a k loop temporary + +! (particular case: no detraining level is found) ! cld +! Verif merge Dynamico<<<<<<< .working + DO il = 1, ncum ! cld + IF (i<=inb(il) .AND. nent(il,i)==0 .AND. iflag(il)<=1) THEN ! cld + qcond(il, i) = qcond(il, i) + (1.-ep(il,i))*clw(il, i) ! cld +!jyg< Bug correction 20180620 +! PROBLEM: Should not qent(il,i,i) be taken into account even if nent(il,i)/=0? +!! qtment(il, i) = qent(il,k,i) + qtment(il,i) ! cld + qdet(il,i,i) = qent(il,i,i) ! cld Louis : specific humidity in detraining water + qtment(il, i) = qent(il,i,i) + qtment(il,i) ! cld +!>jyg + nqcond(il, i) = nqcond(il, i) + 1. ! cld + END IF ! cld + END DO ! cld +! Verif merge Dynamico ======= +! Verif merge Dynamico DO k = i + 1, nl +! Verif merge Dynamico DO il = 1, ncum !ym k loop added ! cld +! Verif merge Dynamico IF (i<=inb(il) .AND. nent(il,i)==0 .AND. iflag(il)<=1) THEN ! cld +! Verif merge Dynamico qcond(il, i) = qcond(il, i) + (1.-ep(il,i))*clw(il, i) ! cld +! Verif merge Dynamico qtment(il, i) = qent(il,k,i) + qtment(il,i) ! cld +! Verif merge Dynamico nqcond(il, i) = nqcond(il, i) + 1. ! cld +! Verif merge Dynamico END IF ! cld +! Verif merge Dynamico END DO +! Verif merge Dynamico ENDDO ! cld +! Verif merge Dynamico >>>>>>> .merge-right.r3413 + + DO il = 1, ncum ! cld + IF (i<=inb(il) .AND. nqcond(il,i)/=0 .AND. iflag(il)<=1) THEN ! cld + qcond(il, i) = qcond(il, i)/nqcond(il, i) ! cld + qtment(il, i) = qtment(il,i)/nqcond(il, i) ! cld + END IF ! cld + END DO + + +500 END DO + +!!!JYG< +!!!Conservation de l'eau +!! sumdq = 0. +!! DO k = 1, nl +!! sumdq = sumdq + fr(1, k)*100.*(ph(1,k)-ph(1,k+1))/grav +!! END DO +!! PRINT *, 'cv3_yield, apres 500, sum(dq), precip, somme ', sumdq, Vprecip(1, 1), sumdq + vprecip(1, 1) +!!!JYG> +! *** move the detrainment at level inb down to level inb-1 *** +! *** in such a way as to preserve the vertically *** +! *** integrated enthalpy and water tendencies *** + +! Correction bug le 18-03-09 + DO il = 1, ncum + IF (iflag(il)<=1) THEN + ax = 0.01*grav*ment(il, inb(il), inb(il))* & + (hp(il,inb(il))-h(il,inb(il))+t(il,inb(il))*(cpv-cpd)*(rr(il,inb(il))-qent(il,inb(il),inb(il))))/ & + (cpn(il,inb(il))*(ph(il,inb(il))-ph(il,inb(il)+1))) + ft(il, inb(il)) = ft(il, inb(il)) - ax + ft(il, inb(il)-1) = ft(il, inb(il)-1) + ax*cpn(il, inb(il))*(ph(il,inb(il))-ph(il,inb(il)+1))/ & + (cpn(il,inb(il)-1)*(ph(il,inb(il)-1)-ph(il,inb(il)))) + + bx = 0.01*grav*ment(il, inb(il), inb(il))*(qent(il,inb(il),inb(il))-rr(il,inb(il)))/ & + (ph(il,inb(il))-ph(il,inb(il)+1)) + fr(il, inb(il)) = fr(il, inb(il)) - bx + fr(il, inb(il)-1) = fr(il, inb(il)-1) + bx*(ph(il,inb(il))-ph(il,inb(il)+1))/ & + (ph(il,inb(il)-1)-ph(il,inb(il))) + + cx = 0.01*grav*ment(il, inb(il), inb(il))*(uent(il,inb(il),inb(il))-u(il,inb(il)))/ & + (ph(il,inb(il))-ph(il,inb(il)+1)) + fu(il, inb(il)) = fu(il, inb(il)) - cx + fu(il, inb(il)-1) = fu(il, inb(il)-1) + cx*(ph(il,inb(il))-ph(il,inb(il)+1))/ & + (ph(il,inb(il)-1)-ph(il,inb(il))) + + dx = 0.01*grav*ment(il, inb(il), inb(il))*(vent(il,inb(il),inb(il))-v(il,inb(il)))/ & + (ph(il,inb(il))-ph(il,inb(il)+1)) + fv(il, inb(il)) = fv(il, inb(il)) - dx + fv(il, inb(il)-1) = fv(il, inb(il)-1) + dx*(ph(il,inb(il))-ph(il,inb(il)+1))/ & + (ph(il,inb(il)-1)-ph(il,inb(il))) + END IF !iflag + END DO + +!!!JYG< +!!!Conservation de l'eau +!! sumdq = 0. +!! DO k = 1, nl +!! sumdq = sumdq + fr(1, k)*100.*(ph(1,k)-ph(1,k+1))/grav +!! END DO +!! PRINT *, 'cv3_yield, apres 503, sum(dq), precip, somme ', sumdq, Vprecip(1, 1), sumdq + vprecip(1, 1) +!!!JYG> + + +! *** homogenize tendencies below cloud base *** + + + DO il = 1, ncum + asum(il) = 0.0 + bsum(il) = 0.0 + csum(il) = 0.0 + dsum(il) = 0.0 + esum(il) = 0.0 + fsum(il) = 0.0 + gsum(il) = 0.0 + hsum(il) = 0.0 + END DO + +!do i=1,nl +!do il=1,ncum +!th_wake(il,i)=t_wake(il,i)*(1000.0/p(il,i))**rdcp +!enddo +!enddo + + DO i = 1, nl + DO il = 1, ncum + IF (i<=(icb(il)-1) .AND. iflag(il)<=1) THEN +!jyg Saturated part : use T profile + asum(il) = asum(il) + (ft(il,i)-ftd(il,i))*(ph(il,i)-ph(il,i+1)) +!jyg<20140311 +!Correction pour conserver l eau + IF (ok_conserv_q) THEN + bsum(il) = bsum(il) + (fr(il,i)-fqd(il,i))*(ph(il,i)-ph(il,i+1)) + csum(il) = csum(il) + (ph(il,i)-ph(il,i+1)) + + ELSE + bsum(il)=bsum(il)+(fr(il,i)-fqd(il,i))*(lv(il,i)+(cl-cpd)*(t(il,i)-t(il,1)))* & + (ph(il,i)-ph(il,i+1)) + csum(il)=csum(il)+(lv(il,i)+(cl-cpd)*(t(il,i)-t(il,1)))* & + (ph(il,i)-ph(il,i+1)) + ENDIF ! (ok_conserv_q) +!jyg> + dsum(il) = dsum(il) + t(il, i)*(ph(il,i)-ph(il,i+1))/th(il, i) +!jyg Unsaturated part : use T_wake profile + esum(il) = esum(il) + ftd(il, i)*(ph(il,i)-ph(il,i+1)) +!jyg<20140311 +!Correction pour conserver l eau + IF (ok_conserv_q) THEN + fsum(il) = fsum(il) + fqd(il, i)*(ph(il,i)-ph(il,i+1)) + gsum(il) = gsum(il) + (ph(il,i)-ph(il,i+1)) + ELSE + fsum(il)=fsum(il)+fqd(il,i)*(lv(il,i)+(cl-cpd)*(t_wake(il,i)-t_wake(il,1)))* & + (ph(il,i)-ph(il,i+1)) + gsum(il)=gsum(il)+(lv(il,i)+(cl-cpd)*(t_wake(il,i)-t_wake(il,1)))* & + (ph(il,i)-ph(il,i+1)) + ENDIF ! (ok_conserv_q) +!jyg> + hsum(il) = hsum(il) + t_wake(il, i)*(ph(il,i)-ph(il,i+1))/th_wake(il, i) + END IF + END DO + END DO + +!!!! do 700 i=1,icb(il)-1 + IF (ok_homo_tend) THEN + DO i = 1, nl + DO il = 1, ncum + IF (i<=(icb(il)-1) .AND. iflag(il)<=1) THEN + ftd(il, i) = esum(il)*t_wake(il, i)/(th_wake(il,i)*hsum(il)) + fqd(il, i) = fsum(il)/gsum(il) + ft(il, i) = ftd(il, i) + asum(il)*t(il, i)/(th(il,i)*dsum(il)) + fr(il, i) = fqd(il, i) + bsum(il)/csum(il) + END IF + END DO + END DO + ENDIF + +!jyg< +!Conservation de l'eau +!! sumdq = 0. +!! DO k = 1, nl +!! sumdq = sumdq + fr(1, k)*100.*(ph(1,k)-ph(1,k+1))/grav +!! END DO +!! PRINT *, 'cv3_yield, apres hom, sum(dq), precip, somme ', sumdq, Vprecip(1, 1), sumdq + vprecip(1, 1) +!jyg> + + +! *** Check that moisture stays positive. If not, scale tendencies +! in order to ensure moisture positivity + DO il = 1, ncum + alpha_qpos(il) = 1. + IF (iflag(il)<=1) THEN + IF (fr(il,1)<=0.) THEN + alpha_qpos(il) = max(alpha_qpos(il), (-delt*fr(il,1))/(s_wake(il)*rr_wake(il,1)+(1.-s_wake(il))*rr(il,1))) + END IF + END IF + END DO + DO i = 2, nl + DO il = 1, ncum + IF (iflag(il)<=1) THEN + IF (fr(il,i)<=0.) THEN + alpha_qpos1(il) = max(1., (-delt*fr(il,i))/(s_wake(il)*rr_wake(il,i)+(1.-s_wake(il))*rr(il,i))) + IF (alpha_qpos1(il)>=alpha_qpos(il)) alpha_qpos(il) = alpha_qpos1(il) + END IF + END IF + END DO + END DO + DO il = 1, ncum + IF (iflag(il)<=1 .AND. alpha_qpos(il)>1.001) THEN + alpha_qpos(il) = alpha_qpos(il)*1.1 + END IF + END DO +! + IF (prt_level .GE. 5) THEN + print *,' CV3_YIELD : alpha_qpos ',alpha_qpos(1) + ENDIF +! + DO il = 1, ncum + IF (iflag(il)<=1) THEN + sigd(il) = sigd(il)/alpha_qpos(il) + precip(il) = precip(il)/alpha_qpos(il) + cbmf(il) = cbmf(il)/alpha_qpos(il) + END IF + END DO + DO i = 1, nl + DO il = 1, ncum + IF (iflag(il)<=1) THEN + fr(il, i) = fr(il, i)/alpha_qpos(il) + ft(il, i) = ft(il, i)/alpha_qpos(il) + fqd(il, i) = fqd(il, i)/alpha_qpos(il) + ftd(il, i) = ftd(il, i)/alpha_qpos(il) + fu(il, i) = fu(il, i)/alpha_qpos(il) + fv(il, i) = fv(il, i)/alpha_qpos(il) + m(il, i) = m(il, i)/alpha_qpos(il) + mp(il, i) = mp(il, i)/alpha_qpos(il) + Vprecip(il, i) = Vprecip(il, i)/alpha_qpos(il) + Vprecipi(il, i) = Vprecipi(il, i)/alpha_qpos(il) ! jyg + END IF + END DO + END DO +!jyg< +!----------------------------------------------------------- + IF (ok_optim_yield) THEN !| +!----------------------------------------------------------- + DO i = 1, nl + DO il = 1, ncum + IF (iflag(il)<=1) THEN + upwd(il, i) = upwd(il, i)/alpha_qpos(il) + dnwd(il, i) = dnwd(il, i)/alpha_qpos(il) + END IF + END DO + END DO +!----------------------------------------------------------- + ENDIF !(ok_optim_yield) !| +!----------------------------------------------------------- +!>jyg + DO j = 1, nl !yor! inverted i and j loops + DO i = 1, nl + DO il = 1, ncum + IF (iflag(il)<=1) THEN + ment(il, i, j) = ment(il, i, j)/alpha_qpos(il) + END IF + END DO + END DO + END DO + + +! *** reset counter and return *** + +! Reset counter only for points actually convective (jyg) +! In order take into account the possibility of changing the compression, +! reset m, sig and w0 to zero for non-convecting points. + DO il = 1, ncum + IF (iflag(il) < 3) THEN + sig(il, nd) = 2.0 + ENDIF + END DO + + + DO i = 1, nl + DO il = 1, ncum + dnwd0(il, i) = -mp(il, i) + END DO + END DO +!jyg< (loops stop at nl) +!! DO i = nl + 1, nd +!! DO il = 1, ncum +!! dnwd0(il, i) = 0. +!! END DO +!! END DO +!>jyg + + +!jyg< +!----------------------------------------------------------- + IF (.NOT.ok_optim_yield) THEN !| +!----------------------------------------------------------- + DO i = 1, nl + DO il = 1, ncum + upwd(il, i) = 0.0 + dnwd(il, i) = 0.0 + END DO + END DO + +!! DO i = 1, nl ! useless; jyg +!! DO il = 1, ncum ! useless; jyg +!! IF (i>=icb(il) .AND. i<=inb(il)) THEN ! useless; jyg +!! upwd(il, i) = 0.0 ! useless; jyg +!! dnwd(il, i) = 0.0 ! useless; jyg +!! END IF ! useless; jyg +!! END DO ! useless; jyg +!! END DO ! useless; jyg + + DO i = 1, nl + DO k = 1, nl + DO il = 1, ncum + up1(il, k, i) = 0.0 + dn1(il, k, i) = 0.0 + END DO + END DO + END DO + +!yor! commented original +! DO i = 1, nl +! DO k = i, nl +! DO n = 1, i - 1 +! DO il = 1, ncum +! IF (i>=icb(il) .AND. i<=inb(il) .AND. k<=inb(il)) THEN +! up1(il, k, i) = up1(il, k, i) + ment(il, n, k) +! dn1(il, k, i) = dn1(il, k, i) - ment(il, k, n) +! END IF +! END DO +! END DO +! END DO +! END DO +!yor! replaced with + DO i = 1, nl + DO k = i, nl + DO n = 1, i - 1 + DO il = 1, ncum + IF (i>=icb(il) .AND. k<=inb(il)) THEN ! yor ! as i always <= k + up1(il, k, i) = up1(il, k, i) + ment(il, n, k) + END IF + END DO + END DO + END DO + END DO + DO i = 1, nl + DO n = 1, i - 1 + DO k = i, nl + DO il = 1, ncum + IF (i>=icb(il) .AND. k<=inb(il)) THEN ! yor ! i always <= k + dn1(il, k, i) = dn1(il, k, i) - ment(il, k, n) + END IF + END DO + END DO + END DO + END DO +!yor! end replace + + DO i = 1, nl + DO k = 1, nl + DO il = 1, ncum + IF (i>=icb(il)) THEN + IF (k>=i .AND. k<=(inb(il))) THEN + upwd(il, i) = upwd(il, i) + m(il, k) + END IF + ELSE + IF (kjyg + +!! DO i = 1, nl +!! DO il = 1, ncum +!! IF (i<=(icb(il)-1)) THEN +!! ma(il, i) = 0 +!! END IF +!! END DO +!! END DO + +!----------------------------------------------------------- + ENDIF !(.NOT.ok_optim_yield) !| +!----------------------------------------------------------- +!>jyg + +! ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +! determination de la variation de flux ascendant entre +! deux niveau non dilue mip +! ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + + DO i = 1, nl + DO il = 1, ncum + mip(il, i) = m(il, i) + END DO + END DO + +!jyg< (loops stop at nl) +!! DO i = nl + 1, nd +!! DO il = 1, ncum +!! mip(il, i) = 0. +!! END DO +!! END DO +!>jyg + + +! cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +! icb represente de niveau ou se trouve la +! base du nuage , et inb le top du nuage +! ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + +!! DO i = 1, nd ! unused . jyg +!! DO il = 1, ncum ! unused . jyg +!! mke(il, i) = upwd(il, i) + dnwd(il, i) ! unused . jyg +!! END DO ! unused . jyg +!! END DO ! unused . jyg + +!! DO i = 1, nd ! unused . jyg +!! DO il = 1, ncum ! unused . jyg +!! rdcp = (rrd*(1.-rr(il,i))-rr(il,i)*rrv)/(cpd*(1.-rr(il,i))+rr(il,i)*cpv) ! unused . jyg +!! tls(il, i) = t(il, i)*(1000.0/p(il,i))**rdcp ! unused . jyg +!! tps(il, i) = tp(il, i) ! unused . jyg +!! END DO ! unused . jyg +!! END DO ! unused . jyg + + +! *** diagnose the in-cloud mixing ratio *** ! cld +! *** of condensed water *** ! cld +!! cld + + DO i = 1, nl+1 ! cld + DO il = 1, ncum ! cld + mac(il, i) = 0.0 ! cld + wa(il, i) = 0.0 ! cld + siga(il, i) = 0.0 ! cld + sax(il, i) = 0.0 ! cld + END DO ! cld + END DO ! cld + + DO i = minorig, nl ! cld + DO k = i + 1, nl + 1 ! cld + DO il = 1, ncum ! cld + IF (i<=inb(il) .AND. k<=(inb(il)+1) .AND. iflag(il)<=1) THEN ! cld + mac(il, i) = mac(il, i) + m(il, k) ! cld + END IF ! cld + END DO ! cld + END DO ! cld + END DO ! cld + + DO i = 1, nl ! cld + DO j = 1, i ! cld + DO il = 1, ncum ! cld + IF (i>=icb(il) .AND. i<=(inb(il)-1) & ! cld + .AND. j>=icb(il) .AND. iflag(il)<=1) THEN ! cld + sax(il, i) = sax(il, i) + rrd*(tvp(il,j)-tv(il,j)) & ! cld + *(ph(il,j)-ph(il,j+1))/p(il, j) ! cld + END IF ! cld + END DO ! cld + END DO ! cld + END DO ! cld + + DO i = 1, nl ! cld + DO il = 1, ncum ! cld + IF (i>=icb(il) .AND. i<=(inb(il)-1) & ! cld + .AND. sax(il,i)>0.0 .AND. iflag(il)<=1) THEN ! cld + wa(il, i) = sqrt(2.*sax(il,i)) ! cld + END IF ! cld + END DO ! cld + END DO + ! cld + DO i = 1, nl + +! 14/01/15 AJ je remets les parties manquantes cf JYG +! Initialize sument to 0 + + DO il = 1,ncum + sument(il) = 0. + ENDDO + +! Sum mixed mass fluxes in sument + + DO k = 1,nl + DO il = 1,ncum + IF (k<=inb(il) .AND. i<=inb(il) .AND. iflag(il)<=1) THEN ! cld + sument(il) =sument(il) + abs(ment(il,k,i)) + detrain(il,i) = detrain(il,i) + abs(ment(il,k,i))*(qdet(il,k,i) - rr(il,i))*(qdet(il,k,i) - rr(il,i)) ! Louis terme de detrainement dans le bilan de variance + ENDIF + ENDDO ! il + ENDDO ! k + +! 14/01/15 AJ delta n'a rien a faire la... + DO il = 1, ncum ! cld +!! IF (wa(il,i)>0.0 .AND. iflag(il)<=1) & ! cld +!! siga(il, i) = mac(il, i)/(coefw_cld_cv*wa(il, i)) & ! cld +!! *rrd*tvp(il, i)/p(il, i)/100. ! cld +!! +!! siga(il, i) = min(siga(il,i), 1.0) ! cld + sigaq = 0. + IF (wa(il,i)>0.0 .AND. iflag(il)<=1) THEN ! cld + siga(il, i) = mac(il, i)/(coefw_cld_cv*wa(il, i)) & ! cld + *rrd*tvp(il, i)/p(il, i)/100. ! cld + siga(il, i) = min(siga(il,i), 1.0) ! cld + sigaq = siga(il,i)*qta(il,i-1) ! cld + ENDIF + +! IM cf. FH +! 14/01/15 AJ ne correspond pas � ce qui a �t� cod� par JYG et SB + + IF (iflag_clw==0) THEN ! cld + qcondc(il, i) = siga(il, i)*clw(il, i)*(1.-ep(il,i)) & ! cld + +(1.-siga(il,i))*qcond(il, i) ! cld + + + sigment(il,i)=sument(il)*tau_cld_cv/(ph(il,i)-ph(il,i+1)) ! cld + sigment(il, i) = min(1.e-4+sigment(il,i), 1.0 - siga(il,i)) ! cld +!! qtc(il, i) = (siga(il,i)*qta(il,i-1)+sigment(il,i)*qtment(il,i)) & ! cld + qtc(il, i) = (sigaq+sigment(il,i)*qtment(il,i)) & ! cld + /(siga(il,i)+sigment(il,i)) ! cld + sigt(il,i) = sigment(il, i) + siga(il, i) + +! qtc(il, i) = siga(il,i)*qta(il,i-1)+(1.-siga(il,i))*qtment(il,i) ! cld +! print*,'BIGAUSSIAN CONV',siga(il,i),sigment(il,i),qtc(il,i) + + ELSE IF (iflag_clw==1) THEN ! cld + qcondc(il, i) = qcond(il, i) ! cld + qtc(il,i) = qtment(il,i) ! cld + END IF ! cld + + END DO ! cld + END DO +! print*,'cv3_yield fin' + + RETURN +END SUBROUTINE cv3_yield + +!AC! et !RomP >>> +SUBROUTINE cv3_tracer(nloc, len, ncum, nd, na, & + ment, sigij, da, phi, phi2, d1a, dam, & + ep, Vprecip, elij, clw, epmlmMm, eplaMm, & + icb, inb) + USE lmdz_cv_ini, ONLY : nl,keep_bug_indices_cv3_tracer + USE cvflag_mod_h + USE ioipsl_getin_p_mod, ONLY : getin_p + IMPLICIT NONE + + +!inputs: +!------ + INTEGER, INTENT (IN) :: ncum, nd, na, nloc, len + INTEGER, DIMENSION (len), INTENT (IN) :: icb, inb + REAL, DIMENSION (len, na, na), INTENT (IN) :: ment, sigij, elij + REAL, DIMENSION (len, nd), INTENT (IN) :: clw + REAL, DIMENSION (len, na), INTENT (IN) :: ep + REAL, DIMENSION (len, nd+1), INTENT (IN) :: Vprecip +!ouputs: +!------ + REAL, DIMENSION (len, na, na), INTENT (OUT) :: phi, phi2, epmlmMm + REAL, DIMENSION (len, na), INTENT (OUT) :: da, d1a, dam, eplaMm +! +!local variables: +!--------------- +! variables pour tracer dans precip de l'AA et des mel + INTEGER i, j, k + REAL epm(nloc, na, na) +! +! variables d'Emanuel : du second indice au troisieme +! ---> tab(i,k,j) -> de l origine k a l arrivee j +! ment, sigij, elij +! variables personnelles : du troisieme au second indice +! ---> tab(i,j,k) -> de k a j +! phi, phi2, epm, epmlmMm + + + da(:, :) = 0. + d1a(:, :) = 0. + dam(:, :) = 0. + epm(:, :, :) = 0. + eplaMm(:, :) = 0. + epmlmMm(:, :, :) = 0. + phi(:, :, :) = 0. + phi2(:, :, :) = 0. + +! fraction deau condensee dans les melanges convertie en precip : epm +! et eau condens�e pr�cipit�e dans masse d'air satur� : l_m*dM_m/dzdz.dzdz + DO j = 1, nl + DO k = 1, nl + DO i = 1, ncum + IF (k>=icb(i) .AND. k<=inb(i) .AND. & +!!jyg j.ge.k.and.j.le.inb(i)) then +!!jyg epm(i,j,k)=1.-(1.-ep(i,j))*clw(i,j)/elij(i,k,j) + j>k .AND. j<=inb(i)) THEN + epm(i, j, k) = 1. - (1.-ep(i,j))*clw(i, j)/max(elij(i,k,j), 1.E-16) +!! + epm(i, j, k) = max(epm(i,j,k), 0.0) + END IF + END DO + END DO + END DO + + + DO j = 1, nl + DO k = 1, nl + DO i = 1, ncum + IF (k>=icb(i) .AND. k<=inb(i)) THEN + eplaMm(i, j) = eplamm(i, j) + & + ep(i, j)*clw(i, j)*ment(i, j, k)*(1.-sigij(i,j,k)) + END IF + END DO + END DO + END DO + + DO j = 1, nl + DO k = 1, j - 1 + DO i = 1, ncum + IF (k>=icb(i) .AND. k<=inb(i) .AND. j<=inb(i)) THEN + epmlmMm(i, j, k) = epm(i, j, k)*elij(i, k, j)*ment(i, k, j) + END IF + END DO + END DO + END DO + +! matrices pour calculer la tendance des concentrations dans cvltr.F90 + DO j = 1, nl + DO k = 1, nl + DO i = 1, ncum + da(i, j) = da(i, j) + (1.-sigij(i,k,j))*ment(i, k, j) + phi(i, j, k) = sigij(i, k, j)*ment(i, k, j) + d1a(i, j) = d1a(i, j) + ment(i, k, j)*ep(i, k)*(1.-sigij(i,k,j)) + IF (k<=j) THEN + phi2(i, j, k) = phi(i, j, k)*epm(i, j, k) + END IF + END DO + END DO + END DO + + IF (keep_bug_indices_cv3_tracer) THEN + DO j = 1, nl + DO k = 1, nl + DO i = 1, ncum + IF (k<=j) THEN + dam(i, j) = dam(i, j) + ment(i, k, j)*epm(i, k, j)*(1.-ep(i,k))*(1.-sigij(i,k,j)) + END IF ! (k<=j) + END DO + END DO + END DO + ELSE ! (keep_bug_indices_cv3_tracer) + DO j = 1, nl + DO k = 1, nl + DO i = 1, ncum + IF (k<=j) THEN + dam(i, j) = dam(i, j) + ment(i, k, j)*epm(i, j, k)*(1.-ep(i,k))*(1.-sigij(i,k,j)) + END IF ! (k<=j) + END DO + END DO + END DO + ENDIF ! (keep_bug_indices_cv3_tracer) + + RETURN +END SUBROUTINE cv3_tracer +!AC! et !RomP <<< + +SUBROUTINE cv3_uncompress(nloc, len, ncum, nd, ntra, idcum, & + iflag, & + precip, sig, w0, & + ft, fq, fu, fv, ftra, & + Ma, upwd, dnwd, dnwd0, qcondc, wd, cape, & + epmax_diag, & ! epmax_cape + iflag1, & + precip1, sig1, w01, & + ft1, fq1, fu1, fv1, ftra1, & + Ma1, upwd1, dnwd1, dnwd01, qcondc1, wd1, cape1, & + epmax_diag1) ! epmax_cape + USE lmdz_cv_ini, ONLY : nl + IMPLICIT NONE + + +!inputs: + INTEGER len, ncum, nd, ntra, nloc + INTEGER idcum(nloc) + INTEGER iflag(nloc) + REAL precip(nloc) + REAL sig(nloc, nd), w0(nloc, nd) + REAL ft(nloc, nd), fq(nloc, nd), fu(nloc, nd), fv(nloc, nd) + REAL ftra(nloc, nd, ntra) + REAL ma(nloc, nd) + REAL upwd(nloc, nd), dnwd(nloc, nd), dnwd0(nloc, nd) + REAL qcondc(nloc, nd) + REAL wd(nloc), cape(nloc) + REAL epmax_diag(nloc) + +!outputs: + INTEGER iflag1(len) + REAL precip1(len) + REAL sig1(len, nd), w01(len, nd) + REAL ft1(len, nd), fq1(len, nd), fu1(len, nd), fv1(len, nd) + REAL ftra1(len, nd, ntra) + REAL ma1(len, nd) + REAL upwd1(len, nd), dnwd1(len, nd), dnwd01(len, nd) + REAL qcondc1(nloc, nd) + REAL wd1(nloc), cape1(nloc) + REAL epmax_diag1(len) ! epmax_cape + +!local variables: + INTEGER i, k, j + + DO i = 1, ncum + precip1(idcum(i)) = precip(i) + iflag1(idcum(i)) = iflag(i) + wd1(idcum(i)) = wd(i) + cape1(idcum(i)) = cape(i) + epmax_diag1(idcum(i))=epmax_diag(i) ! epmax_cape + END DO + + DO k = 1, nl + DO i = 1, ncum + sig1(idcum(i), k) = sig(i, k) + w01(idcum(i), k) = w0(i, k) + ft1(idcum(i), k) = ft(i, k) + fq1(idcum(i), k) = fq(i, k) + fu1(idcum(i), k) = fu(i, k) + fv1(idcum(i), k) = fv(i, k) + ma1(idcum(i), k) = ma(i, k) + upwd1(idcum(i), k) = upwd(i, k) + dnwd1(idcum(i), k) = dnwd(i, k) + dnwd01(idcum(i), k) = dnwd0(i, k) + qcondc1(idcum(i), k) = qcondc(i, k) + END DO + END DO + + DO i = 1, ncum + sig1(idcum(i), nd) = sig(i, nd) + END DO + + +!AC! do 2100 j=1,ntra +!AC!c oct3 do 2110 k=1,nl +!AC! do 2110 k=1,nd ! oct3 +!AC! do 2120 i=1,ncum +!AC! ftra1(idcum(i),k,j)=ftra(i,k,j) +!AC! 2120 continue +!AC! 2110 continue +!AC! 2100 continue +! + RETURN +END SUBROUTINE cv3_uncompress + + + subroutine cv3_epmax_fn_cape(nloc,ncum,nd & + , ep,hp,icb,inb,clw,nk,t,h,hnk,lv,lf,frac & + , pbase, p, ph, tv, buoy, sig, w0,iflag & + , epmax_diag) + USE conema3_mod_h + USE cvflag_mod_h + USE lmdz_cv_ini, ONLY : nl,minorig,cpd,cpv + implicit none + + ! On fait varier epmax en fn de la cape + ! Il faut donc recalculer ep, et hp qui a d�j� �t� calcul� et + ! qui en d�pend + ! Toutes les autres variables fn de ep sont calcul�es plus bas. + + +! inputs: + INTEGER, INTENT (IN) :: ncum, nd, nloc + INTEGER, DIMENSION (nloc), INTENT (IN) :: icb, inb, nk + REAL, DIMENSION (nloc), INTENT (IN) :: hnk,pbase + REAL, DIMENSION (nloc, nd), INTENT (IN) :: t, lv, lf, tv, h + REAL, DIMENSION (nloc, nd), INTENT (IN) :: clw, buoy,frac + REAL, DIMENSION (nloc, nd), INTENT (IN) :: sig,w0 + INTEGER, DIMENSION (nloc), INTENT (IN) :: iflag(nloc) + REAL, DIMENSION (nloc, nd), INTENT (IN) :: p + REAL, DIMENSION (nloc, nd+1), INTENT (IN) :: ph +! inouts: + REAL, DIMENSION (nloc, nd), INTENT (INOUT) :: ep,hp +! outputs + REAL, DIMENSION (nloc), INTENT (OUT) :: epmax_diag + +! local + integer i,k +! real hp_bak(nloc,nd) +! real ep_bak(nloc,nd) + real m_loc(nloc,nd) + real sig_loc(nloc,nd) + real w0_loc(nloc,nd) + integer iflag_loc(nloc) + real cape(nloc) + + if (coef_epmax_cape.gt.1e-12) then + + ! il faut calculer la cape: on fait un calcule simple car tant qu'on ne + ! connait pas ep, on ne connait pas les m�langes, ddfts etc... qui sont + ! necessaires au calcul de la cape dans la nouvelle physique + +! write(*,*) 'cv3_routines check 4303' + do i=1,ncum + do k=1,nd + sig_loc(i,k)=sig(i,k) + w0_loc(i,k)=w0(i,k) + iflag_loc(i)=iflag(i) +! ep_bak(i,k)=ep(i,k) + enddo ! do k=1,nd + enddo !do i=1,ncum + +! write(*,*) 'cv3_routines check 4311' +! write(*,*) 'nl=',nl + CALL cv3_closure(nloc, ncum, nd, icb, inb, & ! na->nd + pbase, p, ph, tv, buoy, & + sig_loc, w0_loc, cape, m_loc,iflag_loc) + +! write(*,*) 'cv3_routines check 4316' +! write(*,*) 'ep(1,:)=',ep(1,:) + do i=1,ncum + epmax_diag(i)=epmax-coef_epmax_cape*sqrt(cape(i)) + epmax_diag(i)=amax1(epmax_diag(i),0.0) +! write(*,*) 'i,icb,inb,cape,epmax_diag=', & +! i,icb(i),inb(i),cape(i),epmax_diag(i) + do k=1,nl + ep(i,k)=ep(i,k)/epmax*epmax_diag(i) + ep(i,k)=amax1(ep(i,k),0.0) + ep(i,k)=amin1(ep(i,k),epmax_diag(i)) + enddo + enddo + ! write(*,*) 'ep(1,:)=',ep(1,:) + + !write(*,*) 'cv3_routines check 4326' +! On recalcule hp: +! do k=1,nl +! do i=1,ncum +! hp_bak(i,k)=hp(i,k) +! enddo +! enddo + do k=1,nl + do i=1,ncum + hp(i,k)=h(i,k) + enddo + enddo + + IF (cvflag_ice) THEN + + do k=minorig+1,nl + do i=1,ncum + if((k.ge.icb(i)).and.(k.le.inb(i)))then + hp(i, k) = hnk(i) + (lv(i,k)+(cpd-cpv)*t(i,k)+frac(i,k)*lf(i,k))* & + ep(i, k)*clw(i, k) + endif + enddo + enddo !do k=minorig+1,n + ELSE !IF (cvflag_ice) THEN + + DO k = minorig + 1, nl + DO i = 1, ncum + IF ((k>=icb(i)) .AND. (k<=inb(i))) THEN + hp(i,k)=hnk(i)+(lv(i,k)+(cpd-cpv)*t(i,k))*ep(i,k)*clw(i,k) + endif + enddo + enddo !do k=minorig+1,n + + ENDIF !IF (cvflag_ice) THEN + !write(*,*) 'cv3_routines check 4345' +! do i=1,ncum +! do k=1,nl +! if ((abs(hp_bak(i,k)-hp(i,k))/hp_bak(i,k).gt.1e-1).or. & +! ((abs(hp_bak(i,k)-hp(i,k))/hp_bak(i,k).gt.1e-4).and. & +! (ep(i,k)-ep_bak(i,k).lt.1e-4))) then +! write(*,*) 'i,k=',i,k +! write(*,*) 'coef_epmax_cape=',coef_epmax_cape +! write(*,*) 'epmax_diag(i)=',epmax_diag(i) +! write(*,*) 'ep(i,k)=',ep(i,k) +! write(*,*) 'ep_bak(i,k)=',ep_bak(i,k) +! write(*,*) 'hp(i,k)=',hp(i,k) +! write(*,*) 'hp_bak(i,k)=',hp_bak(i,k) +! write(*,*) 'h(i,k)=',h(i,k) +! write(*,*) 'nk(i)=',nk(i) +! write(*,*) 'h(i,nk(i))=',h(i,nk(i)) +! write(*,*) 'lv(i,k)=',lv(i,k) +! write(*,*) 't(i,k)=',t(i,k) +! write(*,*) 'clw(i,k)=',clw(i,k) +! write(*,*) 'cpd,cpv=',cpd,cpv +! stop +! endif +! enddo !do k=1,nl +! enddo !do i=1,ncum + endif !if (coef_epmax_cape.gt.1e-12) then + !write(*,*) 'cv3_routines check 4367' + + return + end subroutine cv3_epmax_fn_cape + +END MODULE cv3_routines_mod + Index: LMDZ6/trunk/libf/phylmd/cv3a_compress.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cv3a_compress.f90 (revision 6047) +++ (revision ) @@ -1,243 +1,0 @@ -MODULE cv3a_compress_mod - -CONTAINS - -!!SUBROUTINE cv3a_compress(len, nloc, ncum, nd, ntra, compress, & !jyg: get rid of ntra -SUBROUTINE cv3a_compress(len, nloc, ncum, nd, compress, & - iflag1, nk1, icb1, icbs1, & - plcl1, tnk1, qnk1, gznk1, hnk1, unk1, vnk1, & - wghti1, pbase1, buoybase1, & - t1, q1, qs1, t1_wake, q1_wake, qs1_wake, s1_wake, & - u1, v1, gz1, th1, th1_wake, & -!! tra1, & !jyg: get rid of ntra - h1, lv1, lf1, cpn1, p1, ph1, tv1, tp1, tvp1, clw1, & - h1_wake, lv1_wake, lf1_wake, cpn1_wake, tv1_wake, & - sig1, w01, ptop21, & - Ale1, Alp1, omega1, & - iflag, nk, icb, icbs, & - plcl, tnk, qnk, gznk, hnk, unk, vnk, & - wghti, pbase, buoybase, & - t, q, qs, t_wake, q_wake, qs_wake, s_wake, & - u, v, gz, th, th_wake, & -!! tra, & !jyg: get rid of ntra - h, lv, lf, cpn, p, ph, tv, tp, tvp, clw, & - h_wake, lv_wake, lf_wake, cpn_wake, tv_wake, & - sig, w0, ptop2, & - Ale, Alp, omega) - ! ************************************************************** - ! * - ! CV3A_COMPRESS * - ! * - ! * - ! written by : Sandrine Bony-Lena , 17/05/2003, 11.22.15 * - ! modified by : Jean-Yves Grandpeix, 23/06/2003, 10.28.09 * - ! ************************************************************** - - USE lmdz_cv_ini, ONLY : nl - IMPLICIT NONE - - - ! inputs: -!! INTEGER, INTENT (IN) :: len, nloc, nd, ntra !jyg: get rid of ntra - INTEGER, INTENT (IN) :: len, nloc, nd -!jyg< - LOGICAL, INTENT (IN) :: compress ! compression is performed if compress is true -!>jyg - INTEGER, DIMENSION (len), INTENT (IN) :: iflag1, nk1, icb1, icbs1 - REAL, DIMENSION (len), INTENT (IN) :: plcl1, tnk1, qnk1, gznk1 - REAL, DIMENSION (len), INTENT (IN) :: hnk1, unk1, vnk1 - REAL, DIMENSION (len, nd), INTENT (IN) :: wghti1(len, nd) - REAL, DIMENSION (len), INTENT (IN) :: pbase1, buoybase1 - REAL, DIMENSION (len, nd), INTENT (IN) :: t1, q1, qs1 - REAL, DIMENSION (len, nd), INTENT (IN) :: t1_wake, q1_wake, qs1_wake - REAL, DIMENSION (len), INTENT (IN) :: s1_wake - REAL, DIMENSION (len, nd), INTENT (IN) :: u1, v1 - REAL, DIMENSION (len, nd), INTENT (IN) :: gz1, th1, th1_wake -!! REAL, DIMENSION (len, nd,ntra), INTENT (IN) :: tra1 !jyg: get rid of ntra - REAL, DIMENSION (len, nd), INTENT (IN) :: h1, lv1, lf1, cpn1 - REAL, DIMENSION (len, nd), INTENT (IN) :: p1 - REAL, DIMENSION (len, nd+1), INTENT (IN) :: ph1(len, nd+1) - REAL, DIMENSION (len, nd), INTENT (IN) :: tv1, tp1 - REAL, DIMENSION (len, nd), INTENT (IN) :: tvp1, clw1 - REAL, DIMENSION (len, nd), INTENT (IN) :: h1_wake, lv1_wake, cpn1_wake - REAL, DIMENSION (len, nd), INTENT (IN) :: tv1_wake, lf1_wake - REAL, DIMENSION (len, nd), INTENT (IN) :: sig1, w01 - REAL, DIMENSION (len), INTENT (IN) :: ptop21 - REAL, DIMENSION (len), INTENT (IN) :: Ale1, Alp1 - REAL, DIMENSION (len, nd), INTENT (IN) :: omega1 -! - ! in/out - INTEGER, INTENT (INOUT) :: ncum -! - ! outputs: - ! en fait, on a nloc=len pour l'instant (cf cv_driver) - INTEGER, DIMENSION (nloc), INTENT (OUT) :: iflag, nk, icb, icbs - REAL, DIMENSION (nloc), INTENT (OUT) :: plcl, tnk, qnk, gznk - REAL, DIMENSION (nloc), INTENT (OUT) :: hnk, unk, vnk - REAL, DIMENSION (nloc, nd), INTENT (OUT) :: wghti - REAL, DIMENSION (nloc), INTENT (OUT) :: pbase, buoybase - REAL, DIMENSION (nloc, nd), INTENT (OUT) :: t, q, qs - REAL, DIMENSION (nloc, nd), INTENT (OUT) :: t_wake, q_wake, qs_wake - REAL, DIMENSION (nloc), INTENT (OUT) :: s_wake - REAL, DIMENSION (nloc, nd), INTENT (OUT) :: u, v - REAL, DIMENSION (nloc, nd), INTENT (OUT) :: gz, th, th_wake -!! REAL, DIMENSION (nloc, nd,ntra), INTENT (OUT) :: tra !jyg: get rid of ntra - REAL, DIMENSION (nloc, nd), INTENT (OUT) :: h, lv, lf, cpn - REAL, DIMENSION (nloc, nd), INTENT (OUT) :: p - REAL, DIMENSION (nloc, nd+1), INTENT (OUT) :: ph - REAL, DIMENSION (nloc, nd), INTENT (OUT) :: tv, tp - REAL, DIMENSION (nloc, nd), INTENT (OUT) :: tvp, clw - REAL, DIMENSION (nloc, nd), INTENT (OUT) :: h_wake, lv_wake, cpn_wake - REAL, DIMENSION (nloc, nd), INTENT (OUT) :: tv_wake, lf_wake - REAL, DIMENSION (nloc, nd), INTENT (OUT) :: sig, w0 - REAL, DIMENSION (nloc), INTENT (OUT) :: ptop2 - REAL, DIMENSION (nloc), INTENT (OUT) :: Ale, Alp - REAL, DIMENSION (nloc, nd), INTENT (OUT) :: omega - - ! local variables: - INTEGER i, k, nn, j - - CHARACTER (LEN=20),PARAMETER :: modname = 'cv3a_compress' - CHARACTER (LEN=80) :: abort_message - -!jyg< - IF (compress) THEN -!>jyg - - DO k = 1, nl + 1 - nn = 0 - DO i = 1, len - IF (iflag1(i)==0) THEN - nn = nn + 1 - wghti(nn, k) = wghti1(i, k) - t(nn, k) = t1(i, k) - q(nn, k) = q1(i, k) - qs(nn, k) = qs1(i, k) - t_wake(nn, k) = t1_wake(i, k) - q_wake(nn, k) = q1_wake(i, k) - qs_wake(nn, k) = qs1_wake(i, k) - u(nn, k) = u1(i, k) - v(nn, k) = v1(i, k) - gz(nn, k) = gz1(i, k) - th(nn, k) = th1(i, k) - th_wake(nn, k) = th1_wake(i, k) - h(nn, k) = h1(i, k) - lv(nn, k) = lv1(i, k) - lf(nn, k) = lf1(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) - h_wake(nn, k) = h1_wake(i, k) - lv_wake(nn, k) = lv1_wake(i, k) - lf_wake(nn, k) = lf1_wake(i, k) - cpn_wake(nn, k) = cpn1_wake(i, k) - tv_wake(nn, k) = tv1_wake(i, k) - sig(nn, k) = sig1(i, k) - w0(nn, k) = w01(i, k) - omega(nn, k) = omega1(i, k) - END IF - END DO - END DO -! - - IF (nn/=ncum) THEN - PRINT *, 'WARNING nn not equal to ncum: ', nn, ncum - abort_message = '' - CALL abort_physic(modname, abort_message, 1) - END IF - - nn = 0 - DO i = 1, len - IF (iflag1(i)==0) THEN - nn = nn + 1 - s_wake(nn) = s1_wake(i) - iflag(nn) = iflag1(i) - nk(nn) = nk1(i) - icb(nn) = icb1(i) - icbs(nn) = icbs1(i) - plcl(nn) = plcl1(i) - tnk(nn) = tnk1(i) - qnk(nn) = qnk1(i) - gznk(nn) = gznk1(i) - hnk(nn) = hnk1(i) - unk(nn) = unk1(i) - vnk(nn) = vnk1(i) - pbase(nn) = pbase1(i) - buoybase(nn) = buoybase1(i) - sig(nn, nd) = sig1(i, nd) - ptop2(nn) = ptop2(i) - Ale(nn) = Ale1(i) - Alp(nn) = Alp1(i) - END IF - END DO - - IF (nn/=ncum) THEN - PRINT *, 'WARNING nn not equal to ncum: ', nn, ncum - abort_message = '' - CALL abort_physic(modname, abort_message, 1) - END IF -! -!jyg< - ELSE !(compress) -! - wghti(:,1:nl+1) = wghti1(:,1:nl+1) - t(:,1:nl+1) = t1(:,1:nl+1) - q(:,1:nl+1) = q1(:,1:nl+1) - qs(:,1:nl+1) = qs1(:,1:nl+1) - t_wake(:,1:nl+1) = t1_wake(:,1:nl+1) - q_wake(:,1:nl+1) = q1_wake(:,1:nl+1) - qs_wake(:,1:nl+1) = qs1_wake(:,1:nl+1) - u(:,1:nl+1) = u1(:,1:nl+1) - v(:,1:nl+1) = v1(:,1:nl+1) - gz(:,1:nl+1) = gz1(:,1:nl+1) - th(:,1:nl+1) = th1(:,1:nl+1) - th_wake(:,1:nl+1) = th1_wake(:,1:nl+1) - h(:,1:nl+1) = h1(:,1:nl+1) - lv(:,1:nl+1) = lv1(:,1:nl+1) - lf(:,1:nl+1) = lf1(:,1:nl+1) - cpn(:,1:nl+1) = cpn1(:,1:nl+1) - p(:,1:nl+1) = p1(:,1:nl+1) - ph(:,1:nl+1) = ph1(:,1:nl+1) - tv(:,1:nl+1) = tv1(:,1:nl+1) - tp(:,1:nl+1) = tp1(:,1:nl+1) - tvp(:,1:nl+1) = tvp1(:,1:nl+1) - clw(:,1:nl+1) = clw1(:,1:nl+1) - h_wake(:,1:nl+1) = h1_wake(:,1:nl+1) - lv_wake(:,1:nl+1) = lv1_wake(:,1:nl+1) - lf_wake(:,1:nl+1) = lf1_wake(:,1:nl+1) - cpn_wake(:,1:nl+1) = cpn1_wake(:,1:nl+1) - tv_wake(:,1:nl+1) = tv1_wake(:,1:nl+1) - sig(:,1:nl+1) = sig1(:,1:nl+1) - w0(:,1:nl+1) = w01(:,1:nl+1) - omega(:,1:nl+1) = omega1(:,1:nl+1) - - s_wake(:) = s1_wake(:) - iflag(:) = iflag1(:) - nk(:) = nk1(:) - icb(:) = icb1(:) - icbs(:) = icbs1(:) - plcl(:) = plcl1(:) - tnk(:) = tnk1(:) - qnk(:) = qnk1(:) - gznk(:) = gznk1(:) - hnk(:) = hnk1(:) - unk(:) = unk1(:) - vnk(:) = vnk1(:) - pbase(:) = pbase1(:) - buoybase(:) = buoybase1(:) - sig(:, nd) = sig1(:, nd) - ptop2(:) = ptop2(:) - Ale(:) = Ale1(:) - Alp(:) = Alp1(:) -! - ENDIF !(compress) -!>jyg - - RETURN -END SUBROUTINE cv3a_compress - -END MODULE cv3a_compress_mod Index: LMDZ6/trunk/libf/phylmd/cv3a_compress_mod.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cv3a_compress_mod.f90 (revision 6048) +++ LMDZ6/trunk/libf/phylmd/cv3a_compress_mod.f90 (revision 6048) @@ -0,0 +1,243 @@ +MODULE cv3a_compress_mod + +CONTAINS + +!!SUBROUTINE cv3a_compress(len, nloc, ncum, nd, ntra, compress, & !jyg: get rid of ntra +SUBROUTINE cv3a_compress(len, nloc, ncum, nd, compress, & + iflag1, nk1, icb1, icbs1, & + plcl1, tnk1, qnk1, gznk1, hnk1, unk1, vnk1, & + wghti1, pbase1, buoybase1, & + t1, q1, qs1, t1_wake, q1_wake, qs1_wake, s1_wake, & + u1, v1, gz1, th1, th1_wake, & +!! tra1, & !jyg: get rid of ntra + h1, lv1, lf1, cpn1, p1, ph1, tv1, tp1, tvp1, clw1, & + h1_wake, lv1_wake, lf1_wake, cpn1_wake, tv1_wake, & + sig1, w01, ptop21, & + Ale1, Alp1, omega1, & + iflag, nk, icb, icbs, & + plcl, tnk, qnk, gznk, hnk, unk, vnk, & + wghti, pbase, buoybase, & + t, q, qs, t_wake, q_wake, qs_wake, s_wake, & + u, v, gz, th, th_wake, & +!! tra, & !jyg: get rid of ntra + h, lv, lf, cpn, p, ph, tv, tp, tvp, clw, & + h_wake, lv_wake, lf_wake, cpn_wake, tv_wake, & + sig, w0, ptop2, & + Ale, Alp, omega) + ! ************************************************************** + ! * + ! CV3A_COMPRESS * + ! * + ! * + ! written by : Sandrine Bony-Lena , 17/05/2003, 11.22.15 * + ! modified by : Jean-Yves Grandpeix, 23/06/2003, 10.28.09 * + ! ************************************************************** + + USE lmdz_cv_ini, ONLY : nl + IMPLICIT NONE + + + ! inputs: +!! INTEGER, INTENT (IN) :: len, nloc, nd, ntra !jyg: get rid of ntra + INTEGER, INTENT (IN) :: len, nloc, nd +!jyg< + LOGICAL, INTENT (IN) :: compress ! compression is performed if compress is true +!>jyg + INTEGER, DIMENSION (len), INTENT (IN) :: iflag1, nk1, icb1, icbs1 + REAL, DIMENSION (len), INTENT (IN) :: plcl1, tnk1, qnk1, gznk1 + REAL, DIMENSION (len), INTENT (IN) :: hnk1, unk1, vnk1 + REAL, DIMENSION (len, nd), INTENT (IN) :: wghti1(len, nd) + REAL, DIMENSION (len), INTENT (IN) :: pbase1, buoybase1 + REAL, DIMENSION (len, nd), INTENT (IN) :: t1, q1, qs1 + REAL, DIMENSION (len, nd), INTENT (IN) :: t1_wake, q1_wake, qs1_wake + REAL, DIMENSION (len), INTENT (IN) :: s1_wake + REAL, DIMENSION (len, nd), INTENT (IN) :: u1, v1 + REAL, DIMENSION (len, nd), INTENT (IN) :: gz1, th1, th1_wake +!! REAL, DIMENSION (len, nd,ntra), INTENT (IN) :: tra1 !jyg: get rid of ntra + REAL, DIMENSION (len, nd), INTENT (IN) :: h1, lv1, lf1, cpn1 + REAL, DIMENSION (len, nd), INTENT (IN) :: p1 + REAL, DIMENSION (len, nd+1), INTENT (IN) :: ph1(len, nd+1) + REAL, DIMENSION (len, nd), INTENT (IN) :: tv1, tp1 + REAL, DIMENSION (len, nd), INTENT (IN) :: tvp1, clw1 + REAL, DIMENSION (len, nd), INTENT (IN) :: h1_wake, lv1_wake, cpn1_wake + REAL, DIMENSION (len, nd), INTENT (IN) :: tv1_wake, lf1_wake + REAL, DIMENSION (len, nd), INTENT (IN) :: sig1, w01 + REAL, DIMENSION (len), INTENT (IN) :: ptop21 + REAL, DIMENSION (len), INTENT (IN) :: Ale1, Alp1 + REAL, DIMENSION (len, nd), INTENT (IN) :: omega1 +! + ! in/out + INTEGER, INTENT (INOUT) :: ncum +! + ! outputs: + ! en fait, on a nloc=len pour l'instant (cf cv_driver) + INTEGER, DIMENSION (nloc), INTENT (OUT) :: iflag, nk, icb, icbs + REAL, DIMENSION (nloc), INTENT (OUT) :: plcl, tnk, qnk, gznk + REAL, DIMENSION (nloc), INTENT (OUT) :: hnk, unk, vnk + REAL, DIMENSION (nloc, nd), INTENT (OUT) :: wghti + REAL, DIMENSION (nloc), INTENT (OUT) :: pbase, buoybase + REAL, DIMENSION (nloc, nd), INTENT (OUT) :: t, q, qs + REAL, DIMENSION (nloc, nd), INTENT (OUT) :: t_wake, q_wake, qs_wake + REAL, DIMENSION (nloc), INTENT (OUT) :: s_wake + REAL, DIMENSION (nloc, nd), INTENT (OUT) :: u, v + REAL, DIMENSION (nloc, nd), INTENT (OUT) :: gz, th, th_wake +!! REAL, DIMENSION (nloc, nd,ntra), INTENT (OUT) :: tra !jyg: get rid of ntra + REAL, DIMENSION (nloc, nd), INTENT (OUT) :: h, lv, lf, cpn + REAL, DIMENSION (nloc, nd), INTENT (OUT) :: p + REAL, DIMENSION (nloc, nd+1), INTENT (OUT) :: ph + REAL, DIMENSION (nloc, nd), INTENT (OUT) :: tv, tp + REAL, DIMENSION (nloc, nd), INTENT (OUT) :: tvp, clw + REAL, DIMENSION (nloc, nd), INTENT (OUT) :: h_wake, lv_wake, cpn_wake + REAL, DIMENSION (nloc, nd), INTENT (OUT) :: tv_wake, lf_wake + REAL, DIMENSION (nloc, nd), INTENT (OUT) :: sig, w0 + REAL, DIMENSION (nloc), INTENT (OUT) :: ptop2 + REAL, DIMENSION (nloc), INTENT (OUT) :: Ale, Alp + REAL, DIMENSION (nloc, nd), INTENT (OUT) :: omega + + ! local variables: + INTEGER i, k, nn, j + + CHARACTER (LEN=20),PARAMETER :: modname = 'cv3a_compress' + CHARACTER (LEN=80) :: abort_message + +!jyg< + IF (compress) THEN +!>jyg + + DO k = 1, nl + 1 + nn = 0 + DO i = 1, len + IF (iflag1(i)==0) THEN + nn = nn + 1 + wghti(nn, k) = wghti1(i, k) + t(nn, k) = t1(i, k) + q(nn, k) = q1(i, k) + qs(nn, k) = qs1(i, k) + t_wake(nn, k) = t1_wake(i, k) + q_wake(nn, k) = q1_wake(i, k) + qs_wake(nn, k) = qs1_wake(i, k) + u(nn, k) = u1(i, k) + v(nn, k) = v1(i, k) + gz(nn, k) = gz1(i, k) + th(nn, k) = th1(i, k) + th_wake(nn, k) = th1_wake(i, k) + h(nn, k) = h1(i, k) + lv(nn, k) = lv1(i, k) + lf(nn, k) = lf1(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) + h_wake(nn, k) = h1_wake(i, k) + lv_wake(nn, k) = lv1_wake(i, k) + lf_wake(nn, k) = lf1_wake(i, k) + cpn_wake(nn, k) = cpn1_wake(i, k) + tv_wake(nn, k) = tv1_wake(i, k) + sig(nn, k) = sig1(i, k) + w0(nn, k) = w01(i, k) + omega(nn, k) = omega1(i, k) + END IF + END DO + END DO +! + + IF (nn/=ncum) THEN + PRINT *, 'WARNING nn not equal to ncum: ', nn, ncum + abort_message = '' + CALL abort_physic(modname, abort_message, 1) + END IF + + nn = 0 + DO i = 1, len + IF (iflag1(i)==0) THEN + nn = nn + 1 + s_wake(nn) = s1_wake(i) + iflag(nn) = iflag1(i) + nk(nn) = nk1(i) + icb(nn) = icb1(i) + icbs(nn) = icbs1(i) + plcl(nn) = plcl1(i) + tnk(nn) = tnk1(i) + qnk(nn) = qnk1(i) + gznk(nn) = gznk1(i) + hnk(nn) = hnk1(i) + unk(nn) = unk1(i) + vnk(nn) = vnk1(i) + pbase(nn) = pbase1(i) + buoybase(nn) = buoybase1(i) + sig(nn, nd) = sig1(i, nd) + ptop2(nn) = ptop2(i) + Ale(nn) = Ale1(i) + Alp(nn) = Alp1(i) + END IF + END DO + + IF (nn/=ncum) THEN + PRINT *, 'WARNING nn not equal to ncum: ', nn, ncum + abort_message = '' + CALL abort_physic(modname, abort_message, 1) + END IF +! +!jyg< + ELSE !(compress) +! + wghti(:,1:nl+1) = wghti1(:,1:nl+1) + t(:,1:nl+1) = t1(:,1:nl+1) + q(:,1:nl+1) = q1(:,1:nl+1) + qs(:,1:nl+1) = qs1(:,1:nl+1) + t_wake(:,1:nl+1) = t1_wake(:,1:nl+1) + q_wake(:,1:nl+1) = q1_wake(:,1:nl+1) + qs_wake(:,1:nl+1) = qs1_wake(:,1:nl+1) + u(:,1:nl+1) = u1(:,1:nl+1) + v(:,1:nl+1) = v1(:,1:nl+1) + gz(:,1:nl+1) = gz1(:,1:nl+1) + th(:,1:nl+1) = th1(:,1:nl+1) + th_wake(:,1:nl+1) = th1_wake(:,1:nl+1) + h(:,1:nl+1) = h1(:,1:nl+1) + lv(:,1:nl+1) = lv1(:,1:nl+1) + lf(:,1:nl+1) = lf1(:,1:nl+1) + cpn(:,1:nl+1) = cpn1(:,1:nl+1) + p(:,1:nl+1) = p1(:,1:nl+1) + ph(:,1:nl+1) = ph1(:,1:nl+1) + tv(:,1:nl+1) = tv1(:,1:nl+1) + tp(:,1:nl+1) = tp1(:,1:nl+1) + tvp(:,1:nl+1) = tvp1(:,1:nl+1) + clw(:,1:nl+1) = clw1(:,1:nl+1) + h_wake(:,1:nl+1) = h1_wake(:,1:nl+1) + lv_wake(:,1:nl+1) = lv1_wake(:,1:nl+1) + lf_wake(:,1:nl+1) = lf1_wake(:,1:nl+1) + cpn_wake(:,1:nl+1) = cpn1_wake(:,1:nl+1) + tv_wake(:,1:nl+1) = tv1_wake(:,1:nl+1) + sig(:,1:nl+1) = sig1(:,1:nl+1) + w0(:,1:nl+1) = w01(:,1:nl+1) + omega(:,1:nl+1) = omega1(:,1:nl+1) + + s_wake(:) = s1_wake(:) + iflag(:) = iflag1(:) + nk(:) = nk1(:) + icb(:) = icb1(:) + icbs(:) = icbs1(:) + plcl(:) = plcl1(:) + tnk(:) = tnk1(:) + qnk(:) = qnk1(:) + gznk(:) = gznk1(:) + hnk(:) = hnk1(:) + unk(:) = unk1(:) + vnk(:) = vnk1(:) + pbase(:) = pbase1(:) + buoybase(:) = buoybase1(:) + sig(:, nd) = sig1(:, nd) + ptop2(:) = ptop2(:) + Ale(:) = Ale1(:) + Alp(:) = Alp1(:) +! + ENDIF !(compress) +!>jyg + + RETURN +END SUBROUTINE cv3a_compress + +END MODULE cv3a_compress_mod Index: LMDZ6/trunk/libf/phylmd/cv3a_uncompress.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cv3a_uncompress.f90 (revision 6047) +++ (revision ) @@ -1,372 +1,0 @@ -! $Id$ -MODULE cv3a_uncompress_mod - PRIVATE - - PUBLIC cv3a_uncompress - -CONTAINS - -!!SUBROUTINE cv3a_uncompress(nloc, len, ncum, nd, ntra, idcum, is_convect, compress, & !jyg: get rid of ntra -SUBROUTINE cv3a_uncompress(nloc, len, ncum, nd, idcum, is_convect, compress, & - iflag, kbas, ktop, & - precip, cbmf, plcl, plfc, wbeff, sig, w0, ptop2, & -!! ft, fq, fqcomp, fu, fv, ftra, & !jyg: get rid of ntra - ft, fq, fqcomp, fu, fv, & - sigd, ma, mip, vprecip, vprecipi, upwd, dnwd, dnwd0, & - qcondc, wd, cape, cin, & - tvp, & - ftd, fqd, & - plim1, plim2, asupmax, supmax0, & - asupmaxmin, & - coef_clos, coef_clos_eff, & - da, phi, mp, phi2, d1a, dam, sigij, & ! RomP+AC+jyg - qta, clw, elij, evap, ep, epmlmMm, eplaMm, & ! RomP+jyg - wdtrainA, wdtrainS, wdtrainM, & ! RomP - qtc, sigt, detrain, & - epmax_diag, & ! epmax_cape - iflag1, kbas1, ktop1, & - precip1, cbmf1, plcl1, plfc1, wbeff1, sig1, w01, ptop21, & -!! ft1, fq1, fqcomp1, fu1, fv1, ftra1, & !jyg: get rid of ntra - ft1, fq1, fqcomp1, fu1, fv1, & - sigd1, ma1, mip1, vprecip1, vprecipi1, upwd1, dnwd1, dnwd01, & - qcondc1, wd1, cape1, cin1, & - tvp1, & - ftd1, fqd1, & - plim11, plim21, asupmax1, supmax01, & - asupmaxmin1, & - coef_clos1, coef_clos_eff1, & - da1, phi1, mp1, phi21, d1a1, dam1, sigij1, & ! RomP+AC+jyg - qta1, clw1, elij1, evap1, ep1, epmlmMm1, eplaMm1, & ! RomP+jyg - wdtrainA1, wdtrainS1, wdtrainM1, & ! RomP - qtc1, sigt1, detrain1, & - epmax_diag1) ! epmax_cape - - ! ************************************************************** - ! * - ! CV3A_UNCOMPRESS * - ! * - ! * - ! written by : Sandrine Bony-Lena , 17/05/2003, 11.22.15 * - ! modified by : Jean-Yves Grandpeix, 23/06/2003, 10.36.17 * - ! ************************************************************** - - USE lmdz_cv_ini, ONLY : nl,nlp - IMPLICIT NONE - - - ! inputs: -!! INTEGER, INTENT (IN) :: nloc, len, ncum, nd, ntra !jyg: get rid of ntra - INTEGER, INTENT (IN) :: nloc, len, ncum, nd - INTEGER, DIMENSION (nloc), INTENT (IN) :: idcum(nloc) - LOGICAL, DIMENSION (nloc), INTENT (IN) :: is_convect(nloc) -!jyg< - LOGICAL, INTENT (IN) :: compress -!>jyg - INTEGER, DIMENSION (nloc), INTENT (IN) ::iflag, kbas, ktop - REAL, DIMENSION (nloc), INTENT (IN) :: precip, cbmf, plcl, plfc - REAL, DIMENSION (nloc), INTENT (IN) :: wbeff - REAL, DIMENSION (nloc, nd), INTENT (IN) :: sig, w0 - REAL, DIMENSION (nloc), INTENT (IN) :: ptop2 - REAL, DIMENSION (nloc), INTENT (IN) :: epmax_diag - REAL, DIMENSION (nloc, nd), INTENT (IN) :: ft, fq, fqcomp, fu, fv -!! REAL, DIMENSION (nloc, nd, ntra), INTENT (IN) :: ftra !jyg: get rid of ntra - REAL, DIMENSION (nloc), INTENT (IN) :: sigd - REAL, DIMENSION (nloc, nd), INTENT (IN) :: ma, mip - REAL, DIMENSION (nloc, nd+1), INTENT (IN) :: vprecip - REAL, DIMENSION (nloc, nd+1), INTENT (IN) :: vprecipi - REAL, DIMENSION (nloc, nd), INTENT (IN) :: upwd, dnwd, dnwd0 - REAL, DIMENSION (nloc, nd), INTENT (IN) :: qcondc - REAL, DIMENSION (nloc), INTENT (IN) :: wd, cape, cin - REAL, DIMENSION (nloc, nd), INTENT (IN) :: tvp - REAL, DIMENSION (nloc, nd), INTENT (IN) :: ftd, fqd - REAL, DIMENSION (nloc), INTENT (IN) :: plim1, plim2 - REAL, DIMENSION (nloc, nd), INTENT (IN) :: asupmax - REAL, DIMENSION (nloc), INTENT (IN) :: supmax0, asupmaxmin - REAL, DIMENSION (nloc), INTENT (IN) :: coef_clos, coef_clos_eff - - REAL, DIMENSION (nloc, nd), INTENT (IN) :: da - REAL, DIMENSION (nloc, nd, nd), INTENT (IN) :: phi !AC! - REAL, DIMENSION (nloc, nd), INTENT (IN) :: mp !RomP - REAL, DIMENSION (nloc, nd, nd), INTENT (IN) :: phi2 !RomP - REAL, DIMENSION (nloc, nd), INTENT (IN) :: d1a, dam !RomP - REAL, DIMENSION (nloc, nd, nd), INTENT (IN) :: sigij !RomP - REAL, DIMENSION (nloc, nd), INTENT (IN) :: qta !jyg - REAL, DIMENSION (nloc, nd), INTENT (IN) :: clw !RomP - REAL, DIMENSION (nloc, nd, nd), INTENT (IN) :: elij !RomP - REAL, DIMENSION (nloc, nd), INTENT (IN) :: evap, ep !RomP - REAL, DIMENSION (nloc, nd, nd), INTENT (IN) :: epmlmMm !RomP+jyg - REAL, DIMENSION (nloc, nd), INTENT (IN) :: eplamM !RomP+jyg - REAL, DIMENSION (nloc, nd), INTENT (IN) :: qtc, sigt, detrain !RomP - REAL, DIMENSION (nloc, nd), INTENT (IN) :: wdtrainA, wdtrainS, wdtrainM !RomP - - ! outputs: - INTEGER, DIMENSION (len), INTENT (OUT) :: iflag1, kbas1, ktop1 - REAL, DIMENSION (len), INTENT (OUT) :: precip1, cbmf1, plcl1, plfc1 - REAL, DIMENSION (len), INTENT (OUT) :: wbeff1 - REAL, DIMENSION (len, nd), INTENT (OUT) :: sig1, w01 - REAL, DIMENSION (len), INTENT (OUT) :: epmax_diag1 ! epmax_cape - REAL, DIMENSION (len), INTENT (OUT) :: ptop21 - REAL, DIMENSION (len, nd), INTENT (OUT) :: ft1, fq1, fqcomp1, fu1, fv1 -!! REAL, DIMENSION (len, nd, ntra), INTENT (OUT) :: ftra1 !jyg: get rid of ntra - REAL, DIMENSION (len), INTENT (OUT) :: sigd1 - REAL, DIMENSION (len, nd), INTENT (OUT) :: ma1, mip1 - REAL, DIMENSION (len, nd+1), INTENT (OUT) :: vprecip1 - REAL, DIMENSION (len, nd+1), INTENT (OUT) :: vprecipi1 - REAL, DIMENSION (len, nd), INTENT (OUT) :: upwd1, dnwd1, dnwd01 - REAL, DIMENSION (len, nd), INTENT (OUT) :: qcondc1 - REAL, DIMENSION (len), INTENT (OUT) :: wd1, cape1, cin1 - REAL, DIMENSION (len, nd), INTENT (OUT) :: tvp1 - REAL, DIMENSION (len, nd), INTENT (OUT) :: ftd1, fqd1 - REAL, DIMENSION (len), INTENT (OUT) :: plim11, plim21 - REAL, DIMENSION (len, nd), INTENT (OUT) :: asupmax1 - REAL, DIMENSION (len), INTENT (OUT) :: supmax01, asupmaxmin1 - REAL, DIMENSION (len), INTENT (OUT) :: coef_clos1, coef_clos_eff1 - - REAL, DIMENSION (len, nd), INTENT (OUT) :: da1 - REAL, DIMENSION (len, nd, nd), INTENT (OUT) :: phi1 !AC! - REAL, DIMENSION (len, nd), INTENT (OUT) :: mp1 !RomP - REAL, DIMENSION (len, nd, nd), INTENT (OUT) :: phi21 !RomP - REAL, DIMENSION (len, nd), INTENT (OUT) :: d1a1, dam1 !RomP !RomP - REAL, DIMENSION (len, nd, nd), INTENT (OUT) :: sigij1 !RomP - REAL, DIMENSION (len, nd), INTENT (OUT) :: qta1 !jyg - REAL, DIMENSION (len, nd), INTENT (OUT) :: clw1 !RomP - REAL, DIMENSION (len, nd, nd), INTENT (OUT) :: elij1 !RomP - REAL, DIMENSION (len, nd), INTENT (OUT) :: evap1, ep1 !RomP - REAL, DIMENSION (len, nd, nd), INTENT (OUT) :: epmlmMm1 !RomP+jyg - REAL, DIMENSION (len, nd), INTENT (OUT) :: eplamM1 !RomP+jyg - REAL, DIMENSION (len, nd), INTENT (OUT) :: qtc1, sigt1, detrain1 !RomP - REAL, DIMENSION (len, nd), INTENT (OUT) :: wdtrainA1, wdtrainS1, wdtrainM1 !RomP - - - ! local variables: - INTEGER i, k, j - INTEGER jdcum - ! c integer k1,k2 - -!jyg< - IF (compress) THEN -!>jyg - DO i = 1, ncum - sig1(idcum(i), nd) = sig(i, nd) - ptop21(idcum(i)) = ptop2(i) - sigd1(idcum(i)) = sigd(i) - precip1(idcum(i)) = precip(i) - cbmf1(idcum(i)) = cbmf(i) - plcl1(idcum(i)) = plcl(i) - plfc1(idcum(i)) = plfc(i) - wbeff1(idcum(i)) = wbeff(i) - iflag1(idcum(i)) = iflag(i) - kbas1(idcum(i)) = kbas(i) - ktop1(idcum(i)) = ktop(i) - wd1(idcum(i)) = wd(i) - cape1(idcum(i)) = cape(i) - cin1(idcum(i)) = cin(i) - plim11(idcum(i)) = plim1(i) - plim21(idcum(i)) = plim2(i) - supmax01(idcum(i)) = supmax0(i) - asupmaxmin1(idcum(i)) = asupmaxmin(i) - coef_clos1(idcum(i)) = coef_clos(i) - coef_clos_eff1(idcum(i)) = coef_clos_eff(i) - epmax_diag1(idcum(i)) = epmax_diag(i) - END DO - - DO k = 1, nl - DO i = 1, ncum - sig1(idcum(i), k) = sig(i, k) - w01(idcum(i), k) = w0(i, k) - ft1(idcum(i), k) = ft(i, k) - fq1(idcum(i), k) = fq(i, k) - fqcomp1(idcum(i), k) = fqcomp(i, k) - fu1(idcum(i), k) = fu(i, k) - fv1(idcum(i), k) = fv(i, k) - ma1(idcum(i), k) = ma(i, k) - mip1(idcum(i), k) = mip(i, k) - vprecip1(idcum(i), k) = vprecip(i, k) - vprecipi1(idcum(i), k) = vprecipi(i, k) - upwd1(idcum(i), k) = upwd(i, k) - dnwd1(idcum(i), k) = dnwd(i, k) - dnwd01(idcum(i), k) = dnwd0(i, k) - qcondc1(idcum(i), k) = qcondc(i, k) - tvp1(idcum(i), k) = tvp(i, k) - ftd1(idcum(i), k) = ftd(i, k) - fqd1(idcum(i), k) = fqd(i, k) - asupmax1(idcum(i), k) = asupmax(i, k) - - da1(idcum(i), k) = da(i, k) !AC! - mp1(idcum(i), k) = mp(i, k) !RomP - d1a1(idcum(i), k) = d1a(i, k) !RomP - dam1(idcum(i), k) = dam(i, k) !RomP - qta1(idcum(i), k) = qta(i, k) !jyg - clw1(idcum(i), k) = clw(i, k) !RomP - evap1(idcum(i), k) = evap(i, k) !RomP - ep1(idcum(i), k) = ep(i, k) !RomP - eplamM1(idcum(i), k) = eplamM(i, k) !RomP+jyg - wdtrainA1(idcum(i), k) = wdtrainA(i, k) !RomP - wdtrainS1(idcum(i), k) = wdtrainS(i, k) !RomP - wdtrainM1(idcum(i), k) = wdtrainM(i, k) !RomP - qtc1(idcum(i), k) = qtc(i, k) - sigt1(idcum(i), k) = sigt(i, k) - detrain1(idcum(i), k) = detrain(i, k) - - END DO - END DO - -! Fluxes are defined on a staggered grid and extend up to nl+1 - DO i = 1, ncum - ma1(idcum(i), nlp) = 0. - vprecip1(idcum(i), nlp) = 0. - vprecipi1(idcum(i), nlp) = 0. - upwd1(idcum(i), nlp) = 0. - dnwd1(idcum(i), nlp) = 0. - dnwd01(idcum(i), nlp) = 0. - END DO - -!jyg< -! Essais pour gagner du temps en diminuant l'adressage indirect -!! DO j = 1, nd -!! DO k = 1, nd -!! DO i = 1, ncum -!! phi1(idcum(i), k, j) = phi(i, k, j) !AC! -!! phi21(idcum(i), k, j) = phi2(i, k, j) !RomP -!! sigij1(idcum(i), k, j) = sigij(i, k, j) !RomP -!! elij1(idcum(i), k, j) = elij(i, k, j) !RomP -!! epmlmMm(idcum(i), k, j) = epmlmMm(i, k, j) !RomP+jyg -!! END DO -!! END DO -!! END DO - -!! DO i = 1, ncum -!! jdcum=idcum(i) -!! phi1 (jdcum, 1:nl+1, 1:nl+1) = phi (i, 1:nl+1, 1:nl+1) !AC! -!! phi21 (jdcum, 1:nl+1, 1:nl+1) = phi2 (i, 1:nl+1, 1:nl+1) !RomP -!! sigij1 (jdcum, 1:nl+1, 1:nl+1) = sigij (i, 1:nl+1, 1:nl+1) !RomP -!! elij1 (jdcum, 1:nl+1, 1:nl+1) = elij (i, 1:nl+1, 1:nl+1) !RomP -!! epmlmMm1(jdcum, 1:nl+1, 1:nl+1) = epmlmMm(i, 1:nl+1, 1:nl+1) !RomP+jyg -!! END DO -! These tracer associated arrays are defined up to nl, not nl+1 - DO i = 1, ncum - jdcum=idcum(i) - DO k = 1,nl - DO j = 1,nl - phi1 (jdcum, j, k) = phi (i, j, k) !AC! - phi21 (jdcum, j, k) = phi2 (i, j, k) !RomP - sigij1 (jdcum, j, k) = sigij (i, j, k) !RomP - elij1 (jdcum, j, k) = elij (i, j, k) !RomP - epmlmMm1(jdcum, j, k) = epmlmMm(i, j, k) !RomP+jyg - END DO - ENDDO - ENDDO -!>jyg - ! AC! - - - ! do 2220 k2=1,nd - ! do 2210 k1=1,nd - ! do 2200 i=1,ncum - ! ment1(idcum(i),k1,k2) = ment(i,k1,k2) - ! sigij1(idcum(i),k1,k2) = sigij(i,k1,k2) - ! 2200 enddo - ! 2210 enddo - ! 2220 enddo -! -!jyg< - ELSE !(compress) -! - DO i = 1, len - IF (is_convect(i)) THEN - sig1(i,nd) = sig(i,nd) - ptop21(i) = ptop2(i) - sigd1(i) = sigd(i) - precip1(i) = precip(i) - cbmf1(i) = cbmf(i) - plcl1(i) = plcl(i) - plfc1(i) = plfc(i) - wbeff1(i) = wbeff(i) - iflag1(i) = iflag(i) - kbas1(i) = kbas(i) - ktop1(i) = ktop(i) - wd1(i) = wd(i) - cape1(i) = cape(i) - cin1(i) = cin(i) - plim11(i) = plim1(i) - plim21(i) = plim2(i) - supmax01(i) = supmax0(i) - asupmaxmin1(i) = asupmaxmin(i) - coef_clos1(i) = coef_clos(i) - coef_clos_eff1(i) = coef_clos_eff(i) - ENDIF - ENDDO - - DO k = 1, nl - DO i = 1, len - IF (is_convect(i)) THEN - sig1(i,k) = sig(i,k) - w01(i,k) = w0(i,k) - ft1(i,k) = ft(i,k) - fq1(i,k) = fq(i,k) - fqcomp1(i,k) = fqcomp(i,k) - fu1(i,k) = fu(i,k) - fv1(i,k) = fv(i,k) - ma1(i,k) = ma(i,k) - mip1(i,k) = mip(i,k) - vprecip1(i,k) = vprecip(i,k) - vprecipi1(i,k) = vprecipi(i,k) - upwd1(i,k) = upwd(i,k) - dnwd1(i,k) = dnwd(i,k) - dnwd01(i,k) = dnwd0(i,k) - qcondc1(i,k) = qcondc(i,k) - tvp1(i,k) = tvp(i,k) - ftd1(i,k) = ftd(i,k) - fqd1(i,k) = fqd(i,k) - asupmax1(i,k) = asupmax(i,k) - - da1(i,k) = da(i,k) !AC! - mp1(i,k) = mp(i,k) !RomP - d1a1(i,k) = d1a(i,k) !RomP - dam1(i,k) = dam(i,k) !RomP - qta1(i,k) = qta(i,k) !jyg - clw1(i,k) = clw(i,k) !RomP - evap1(i,k) = evap(i,k) !RomP - ep1(i,k) = ep(i,k) !RomP - eplamM1(i,k) = eplamM(i,k) !RomP+jyg - wdtrainA1(i,k) = wdtrainA(i,k) !RomP - wdtrainS1(i,k) = wdtrainS(i,k) !RomP - wdtrainM1(i,k) = wdtrainM(i,k) !RomP - qtc1(i,k) = qtc(i,k) - sigt1(i,k) = sigt(i,k) - detrain1(i,k) = detrain(i,k) - ENDIF - ENDDO - ENDDO - - DO i = 1, len - IF (is_convect(i)) THEN - ma1(i, nlp) = 0. - vprecip1(i, nlp) = 0. - vprecipi1(i, nlp) = 0. - upwd1(i, nlp) = 0. - dnwd1(i, nlp) = 0. - dnwd01(i, nlp) = 0. - ENDIF - ENDDO -! - DO k = 1,nl - DO j = 1,nl - DO i = 1, len - IF (is_convect(i)) THEN - phi1 (i,j,k) = phi (i,j,k) !AC! - phi21 (i,j,k) = phi2 (i,j,k) !RomP - sigij1 (i,j,k) = sigij (i,j,k) !RomP - elij1 (i,j,k) = elij (i,j,k) !RomP - epmlmMm1(i,j,k) = epmlmMm(i,j,k) !RomP+jyg - ENDIF - ENDDO - ENDDO - ENDDO - ENDIF !(compress) -!>jyg - - RETURN -END SUBROUTINE cv3a_uncompress - -END MODULE cv3a_uncompress_mod Index: LMDZ6/trunk/libf/phylmd/cv3a_uncompress_mod.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cv3a_uncompress_mod.f90 (revision 6048) +++ LMDZ6/trunk/libf/phylmd/cv3a_uncompress_mod.f90 (revision 6048) @@ -0,0 +1,372 @@ +! $Id$ +MODULE cv3a_uncompress_mod + PRIVATE + + PUBLIC cv3a_uncompress + +CONTAINS + +!!SUBROUTINE cv3a_uncompress(nloc, len, ncum, nd, ntra, idcum, is_convect, compress, & !jyg: get rid of ntra +SUBROUTINE cv3a_uncompress(nloc, len, ncum, nd, idcum, is_convect, compress, & + iflag, kbas, ktop, & + precip, cbmf, plcl, plfc, wbeff, sig, w0, ptop2, & +!! ft, fq, fqcomp, fu, fv, ftra, & !jyg: get rid of ntra + ft, fq, fqcomp, fu, fv, & + sigd, ma, mip, vprecip, vprecipi, upwd, dnwd, dnwd0, & + qcondc, wd, cape, cin, & + tvp, & + ftd, fqd, & + plim1, plim2, asupmax, supmax0, & + asupmaxmin, & + coef_clos, coef_clos_eff, & + da, phi, mp, phi2, d1a, dam, sigij, & ! RomP+AC+jyg + qta, clw, elij, evap, ep, epmlmMm, eplaMm, & ! RomP+jyg + wdtrainA, wdtrainS, wdtrainM, & ! RomP + qtc, sigt, detrain, & + epmax_diag, & ! epmax_cape + iflag1, kbas1, ktop1, & + precip1, cbmf1, plcl1, plfc1, wbeff1, sig1, w01, ptop21, & +!! ft1, fq1, fqcomp1, fu1, fv1, ftra1, & !jyg: get rid of ntra + ft1, fq1, fqcomp1, fu1, fv1, & + sigd1, ma1, mip1, vprecip1, vprecipi1, upwd1, dnwd1, dnwd01, & + qcondc1, wd1, cape1, cin1, & + tvp1, & + ftd1, fqd1, & + plim11, plim21, asupmax1, supmax01, & + asupmaxmin1, & + coef_clos1, coef_clos_eff1, & + da1, phi1, mp1, phi21, d1a1, dam1, sigij1, & ! RomP+AC+jyg + qta1, clw1, elij1, evap1, ep1, epmlmMm1, eplaMm1, & ! RomP+jyg + wdtrainA1, wdtrainS1, wdtrainM1, & ! RomP + qtc1, sigt1, detrain1, & + epmax_diag1) ! epmax_cape + + ! ************************************************************** + ! * + ! CV3A_UNCOMPRESS * + ! * + ! * + ! written by : Sandrine Bony-Lena , 17/05/2003, 11.22.15 * + ! modified by : Jean-Yves Grandpeix, 23/06/2003, 10.36.17 * + ! ************************************************************** + + USE lmdz_cv_ini, ONLY : nl,nlp + IMPLICIT NONE + + + ! inputs: +!! INTEGER, INTENT (IN) :: nloc, len, ncum, nd, ntra !jyg: get rid of ntra + INTEGER, INTENT (IN) :: nloc, len, ncum, nd + INTEGER, DIMENSION (nloc), INTENT (IN) :: idcum(nloc) + LOGICAL, DIMENSION (nloc), INTENT (IN) :: is_convect(nloc) +!jyg< + LOGICAL, INTENT (IN) :: compress +!>jyg + INTEGER, DIMENSION (nloc), INTENT (IN) ::iflag, kbas, ktop + REAL, DIMENSION (nloc), INTENT (IN) :: precip, cbmf, plcl, plfc + REAL, DIMENSION (nloc), INTENT (IN) :: wbeff + REAL, DIMENSION (nloc, nd), INTENT (IN) :: sig, w0 + REAL, DIMENSION (nloc), INTENT (IN) :: ptop2 + REAL, DIMENSION (nloc), INTENT (IN) :: epmax_diag + REAL, DIMENSION (nloc, nd), INTENT (IN) :: ft, fq, fqcomp, fu, fv +!! REAL, DIMENSION (nloc, nd, ntra), INTENT (IN) :: ftra !jyg: get rid of ntra + REAL, DIMENSION (nloc), INTENT (IN) :: sigd + REAL, DIMENSION (nloc, nd), INTENT (IN) :: ma, mip + REAL, DIMENSION (nloc, nd+1), INTENT (IN) :: vprecip + REAL, DIMENSION (nloc, nd+1), INTENT (IN) :: vprecipi + REAL, DIMENSION (nloc, nd), INTENT (IN) :: upwd, dnwd, dnwd0 + REAL, DIMENSION (nloc, nd), INTENT (IN) :: qcondc + REAL, DIMENSION (nloc), INTENT (IN) :: wd, cape, cin + REAL, DIMENSION (nloc, nd), INTENT (IN) :: tvp + REAL, DIMENSION (nloc, nd), INTENT (IN) :: ftd, fqd + REAL, DIMENSION (nloc), INTENT (IN) :: plim1, plim2 + REAL, DIMENSION (nloc, nd), INTENT (IN) :: asupmax + REAL, DIMENSION (nloc), INTENT (IN) :: supmax0, asupmaxmin + REAL, DIMENSION (nloc), INTENT (IN) :: coef_clos, coef_clos_eff + + REAL, DIMENSION (nloc, nd), INTENT (IN) :: da + REAL, DIMENSION (nloc, nd, nd), INTENT (IN) :: phi !AC! + REAL, DIMENSION (nloc, nd), INTENT (IN) :: mp !RomP + REAL, DIMENSION (nloc, nd, nd), INTENT (IN) :: phi2 !RomP + REAL, DIMENSION (nloc, nd), INTENT (IN) :: d1a, dam !RomP + REAL, DIMENSION (nloc, nd, nd), INTENT (IN) :: sigij !RomP + REAL, DIMENSION (nloc, nd), INTENT (IN) :: qta !jyg + REAL, DIMENSION (nloc, nd), INTENT (IN) :: clw !RomP + REAL, DIMENSION (nloc, nd, nd), INTENT (IN) :: elij !RomP + REAL, DIMENSION (nloc, nd), INTENT (IN) :: evap, ep !RomP + REAL, DIMENSION (nloc, nd, nd), INTENT (IN) :: epmlmMm !RomP+jyg + REAL, DIMENSION (nloc, nd), INTENT (IN) :: eplamM !RomP+jyg + REAL, DIMENSION (nloc, nd), INTENT (IN) :: qtc, sigt, detrain !RomP + REAL, DIMENSION (nloc, nd), INTENT (IN) :: wdtrainA, wdtrainS, wdtrainM !RomP + + ! outputs: + INTEGER, DIMENSION (len), INTENT (OUT) :: iflag1, kbas1, ktop1 + REAL, DIMENSION (len), INTENT (OUT) :: precip1, cbmf1, plcl1, plfc1 + REAL, DIMENSION (len), INTENT (OUT) :: wbeff1 + REAL, DIMENSION (len, nd), INTENT (OUT) :: sig1, w01 + REAL, DIMENSION (len), INTENT (OUT) :: epmax_diag1 ! epmax_cape + REAL, DIMENSION (len), INTENT (OUT) :: ptop21 + REAL, DIMENSION (len, nd), INTENT (OUT) :: ft1, fq1, fqcomp1, fu1, fv1 +!! REAL, DIMENSION (len, nd, ntra), INTENT (OUT) :: ftra1 !jyg: get rid of ntra + REAL, DIMENSION (len), INTENT (OUT) :: sigd1 + REAL, DIMENSION (len, nd), INTENT (OUT) :: ma1, mip1 + REAL, DIMENSION (len, nd+1), INTENT (OUT) :: vprecip1 + REAL, DIMENSION (len, nd+1), INTENT (OUT) :: vprecipi1 + REAL, DIMENSION (len, nd), INTENT (OUT) :: upwd1, dnwd1, dnwd01 + REAL, DIMENSION (len, nd), INTENT (OUT) :: qcondc1 + REAL, DIMENSION (len), INTENT (OUT) :: wd1, cape1, cin1 + REAL, DIMENSION (len, nd), INTENT (OUT) :: tvp1 + REAL, DIMENSION (len, nd), INTENT (OUT) :: ftd1, fqd1 + REAL, DIMENSION (len), INTENT (OUT) :: plim11, plim21 + REAL, DIMENSION (len, nd), INTENT (OUT) :: asupmax1 + REAL, DIMENSION (len), INTENT (OUT) :: supmax01, asupmaxmin1 + REAL, DIMENSION (len), INTENT (OUT) :: coef_clos1, coef_clos_eff1 + + REAL, DIMENSION (len, nd), INTENT (OUT) :: da1 + REAL, DIMENSION (len, nd, nd), INTENT (OUT) :: phi1 !AC! + REAL, DIMENSION (len, nd), INTENT (OUT) :: mp1 !RomP + REAL, DIMENSION (len, nd, nd), INTENT (OUT) :: phi21 !RomP + REAL, DIMENSION (len, nd), INTENT (OUT) :: d1a1, dam1 !RomP !RomP + REAL, DIMENSION (len, nd, nd), INTENT (OUT) :: sigij1 !RomP + REAL, DIMENSION (len, nd), INTENT (OUT) :: qta1 !jyg + REAL, DIMENSION (len, nd), INTENT (OUT) :: clw1 !RomP + REAL, DIMENSION (len, nd, nd), INTENT (OUT) :: elij1 !RomP + REAL, DIMENSION (len, nd), INTENT (OUT) :: evap1, ep1 !RomP + REAL, DIMENSION (len, nd, nd), INTENT (OUT) :: epmlmMm1 !RomP+jyg + REAL, DIMENSION (len, nd), INTENT (OUT) :: eplamM1 !RomP+jyg + REAL, DIMENSION (len, nd), INTENT (OUT) :: qtc1, sigt1, detrain1 !RomP + REAL, DIMENSION (len, nd), INTENT (OUT) :: wdtrainA1, wdtrainS1, wdtrainM1 !RomP + + + ! local variables: + INTEGER i, k, j + INTEGER jdcum + ! c integer k1,k2 + +!jyg< + IF (compress) THEN +!>jyg + DO i = 1, ncum + sig1(idcum(i), nd) = sig(i, nd) + ptop21(idcum(i)) = ptop2(i) + sigd1(idcum(i)) = sigd(i) + precip1(idcum(i)) = precip(i) + cbmf1(idcum(i)) = cbmf(i) + plcl1(idcum(i)) = plcl(i) + plfc1(idcum(i)) = plfc(i) + wbeff1(idcum(i)) = wbeff(i) + iflag1(idcum(i)) = iflag(i) + kbas1(idcum(i)) = kbas(i) + ktop1(idcum(i)) = ktop(i) + wd1(idcum(i)) = wd(i) + cape1(idcum(i)) = cape(i) + cin1(idcum(i)) = cin(i) + plim11(idcum(i)) = plim1(i) + plim21(idcum(i)) = plim2(i) + supmax01(idcum(i)) = supmax0(i) + asupmaxmin1(idcum(i)) = asupmaxmin(i) + coef_clos1(idcum(i)) = coef_clos(i) + coef_clos_eff1(idcum(i)) = coef_clos_eff(i) + epmax_diag1(idcum(i)) = epmax_diag(i) + END DO + + DO k = 1, nl + DO i = 1, ncum + sig1(idcum(i), k) = sig(i, k) + w01(idcum(i), k) = w0(i, k) + ft1(idcum(i), k) = ft(i, k) + fq1(idcum(i), k) = fq(i, k) + fqcomp1(idcum(i), k) = fqcomp(i, k) + fu1(idcum(i), k) = fu(i, k) + fv1(idcum(i), k) = fv(i, k) + ma1(idcum(i), k) = ma(i, k) + mip1(idcum(i), k) = mip(i, k) + vprecip1(idcum(i), k) = vprecip(i, k) + vprecipi1(idcum(i), k) = vprecipi(i, k) + upwd1(idcum(i), k) = upwd(i, k) + dnwd1(idcum(i), k) = dnwd(i, k) + dnwd01(idcum(i), k) = dnwd0(i, k) + qcondc1(idcum(i), k) = qcondc(i, k) + tvp1(idcum(i), k) = tvp(i, k) + ftd1(idcum(i), k) = ftd(i, k) + fqd1(idcum(i), k) = fqd(i, k) + asupmax1(idcum(i), k) = asupmax(i, k) + + da1(idcum(i), k) = da(i, k) !AC! + mp1(idcum(i), k) = mp(i, k) !RomP + d1a1(idcum(i), k) = d1a(i, k) !RomP + dam1(idcum(i), k) = dam(i, k) !RomP + qta1(idcum(i), k) = qta(i, k) !jyg + clw1(idcum(i), k) = clw(i, k) !RomP + evap1(idcum(i), k) = evap(i, k) !RomP + ep1(idcum(i), k) = ep(i, k) !RomP + eplamM1(idcum(i), k) = eplamM(i, k) !RomP+jyg + wdtrainA1(idcum(i), k) = wdtrainA(i, k) !RomP + wdtrainS1(idcum(i), k) = wdtrainS(i, k) !RomP + wdtrainM1(idcum(i), k) = wdtrainM(i, k) !RomP + qtc1(idcum(i), k) = qtc(i, k) + sigt1(idcum(i), k) = sigt(i, k) + detrain1(idcum(i), k) = detrain(i, k) + + END DO + END DO + +! Fluxes are defined on a staggered grid and extend up to nl+1 + DO i = 1, ncum + ma1(idcum(i), nlp) = 0. + vprecip1(idcum(i), nlp) = 0. + vprecipi1(idcum(i), nlp) = 0. + upwd1(idcum(i), nlp) = 0. + dnwd1(idcum(i), nlp) = 0. + dnwd01(idcum(i), nlp) = 0. + END DO + +!jyg< +! Essais pour gagner du temps en diminuant l'adressage indirect +!! DO j = 1, nd +!! DO k = 1, nd +!! DO i = 1, ncum +!! phi1(idcum(i), k, j) = phi(i, k, j) !AC! +!! phi21(idcum(i), k, j) = phi2(i, k, j) !RomP +!! sigij1(idcum(i), k, j) = sigij(i, k, j) !RomP +!! elij1(idcum(i), k, j) = elij(i, k, j) !RomP +!! epmlmMm(idcum(i), k, j) = epmlmMm(i, k, j) !RomP+jyg +!! END DO +!! END DO +!! END DO + +!! DO i = 1, ncum +!! jdcum=idcum(i) +!! phi1 (jdcum, 1:nl+1, 1:nl+1) = phi (i, 1:nl+1, 1:nl+1) !AC! +!! phi21 (jdcum, 1:nl+1, 1:nl+1) = phi2 (i, 1:nl+1, 1:nl+1) !RomP +!! sigij1 (jdcum, 1:nl+1, 1:nl+1) = sigij (i, 1:nl+1, 1:nl+1) !RomP +!! elij1 (jdcum, 1:nl+1, 1:nl+1) = elij (i, 1:nl+1, 1:nl+1) !RomP +!! epmlmMm1(jdcum, 1:nl+1, 1:nl+1) = epmlmMm(i, 1:nl+1, 1:nl+1) !RomP+jyg +!! END DO +! These tracer associated arrays are defined up to nl, not nl+1 + DO i = 1, ncum + jdcum=idcum(i) + DO k = 1,nl + DO j = 1,nl + phi1 (jdcum, j, k) = phi (i, j, k) !AC! + phi21 (jdcum, j, k) = phi2 (i, j, k) !RomP + sigij1 (jdcum, j, k) = sigij (i, j, k) !RomP + elij1 (jdcum, j, k) = elij (i, j, k) !RomP + epmlmMm1(jdcum, j, k) = epmlmMm(i, j, k) !RomP+jyg + END DO + ENDDO + ENDDO +!>jyg + ! AC! + + + ! do 2220 k2=1,nd + ! do 2210 k1=1,nd + ! do 2200 i=1,ncum + ! ment1(idcum(i),k1,k2) = ment(i,k1,k2) + ! sigij1(idcum(i),k1,k2) = sigij(i,k1,k2) + ! 2200 enddo + ! 2210 enddo + ! 2220 enddo +! +!jyg< + ELSE !(compress) +! + DO i = 1, len + IF (is_convect(i)) THEN + sig1(i,nd) = sig(i,nd) + ptop21(i) = ptop2(i) + sigd1(i) = sigd(i) + precip1(i) = precip(i) + cbmf1(i) = cbmf(i) + plcl1(i) = plcl(i) + plfc1(i) = plfc(i) + wbeff1(i) = wbeff(i) + iflag1(i) = iflag(i) + kbas1(i) = kbas(i) + ktop1(i) = ktop(i) + wd1(i) = wd(i) + cape1(i) = cape(i) + cin1(i) = cin(i) + plim11(i) = plim1(i) + plim21(i) = plim2(i) + supmax01(i) = supmax0(i) + asupmaxmin1(i) = asupmaxmin(i) + coef_clos1(i) = coef_clos(i) + coef_clos_eff1(i) = coef_clos_eff(i) + ENDIF + ENDDO + + DO k = 1, nl + DO i = 1, len + IF (is_convect(i)) THEN + sig1(i,k) = sig(i,k) + w01(i,k) = w0(i,k) + ft1(i,k) = ft(i,k) + fq1(i,k) = fq(i,k) + fqcomp1(i,k) = fqcomp(i,k) + fu1(i,k) = fu(i,k) + fv1(i,k) = fv(i,k) + ma1(i,k) = ma(i,k) + mip1(i,k) = mip(i,k) + vprecip1(i,k) = vprecip(i,k) + vprecipi1(i,k) = vprecipi(i,k) + upwd1(i,k) = upwd(i,k) + dnwd1(i,k) = dnwd(i,k) + dnwd01(i,k) = dnwd0(i,k) + qcondc1(i,k) = qcondc(i,k) + tvp1(i,k) = tvp(i,k) + ftd1(i,k) = ftd(i,k) + fqd1(i,k) = fqd(i,k) + asupmax1(i,k) = asupmax(i,k) + + da1(i,k) = da(i,k) !AC! + mp1(i,k) = mp(i,k) !RomP + d1a1(i,k) = d1a(i,k) !RomP + dam1(i,k) = dam(i,k) !RomP + qta1(i,k) = qta(i,k) !jyg + clw1(i,k) = clw(i,k) !RomP + evap1(i,k) = evap(i,k) !RomP + ep1(i,k) = ep(i,k) !RomP + eplamM1(i,k) = eplamM(i,k) !RomP+jyg + wdtrainA1(i,k) = wdtrainA(i,k) !RomP + wdtrainS1(i,k) = wdtrainS(i,k) !RomP + wdtrainM1(i,k) = wdtrainM(i,k) !RomP + qtc1(i,k) = qtc(i,k) + sigt1(i,k) = sigt(i,k) + detrain1(i,k) = detrain(i,k) + ENDIF + ENDDO + ENDDO + + DO i = 1, len + IF (is_convect(i)) THEN + ma1(i, nlp) = 0. + vprecip1(i, nlp) = 0. + vprecipi1(i, nlp) = 0. + upwd1(i, nlp) = 0. + dnwd1(i, nlp) = 0. + dnwd01(i, nlp) = 0. + ENDIF + ENDDO +! + DO k = 1,nl + DO j = 1,nl + DO i = 1, len + IF (is_convect(i)) THEN + phi1 (i,j,k) = phi (i,j,k) !AC! + phi21 (i,j,k) = phi2 (i,j,k) !RomP + sigij1 (i,j,k) = sigij (i,j,k) !RomP + elij1 (i,j,k) = elij (i,j,k) !RomP + epmlmMm1(i,j,k) = epmlmMm(i,j,k) !RomP+jyg + ENDIF + ENDDO + ENDDO + ENDDO + ENDIF !(compress) +!>jyg + + RETURN +END SUBROUTINE cv3a_uncompress + +END MODULE cv3a_uncompress_mod Index: LMDZ6/trunk/libf/phylmd/cv3p1_closure.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cv3p1_closure.f90 (revision 6047) +++ (revision ) @@ -1,845 +1,0 @@ - -! $Id$ -MODULE cv3p1_closure_mod -PRIVATE -PUBLIC cv3p1_closure -CONTAINS - -SUBROUTINE cv3p1_closure(nloc, ncum, nd, icb, inb, pbase, plcl, p, ph, tv, & - tvp, buoy, supmax, ok_inhib, ale, alp, omega,sig, w0, ptop2, cape, cin, m, & - iflag, coef, coeftrue, plim1, plim2, asupmax, supmax0, asupmaxmin, & - cbmf, plfc, wbeff) - - - ! ************************************************************** - ! * - ! CV3P1_CLOSURE * - ! Ale & Alp Closure of Convect3 * - ! * - ! written by : Kerry Emanuel * - ! vectorization: S. Bony * - ! modified by : Jean-Yves Grandpeix, 18/06/2003, 19.32.10 * - ! Julie Frohwirth, 14/10/2005 17.44.22 * - ! ************************************************************** - -USE yomcst2_mod_h - USE lmdz_cv_ini, ONLY : pbcrit,wbmax,rrd,minorig,flag_wb,alpha,alpha1,beta,coef_peel,nl - USE conema3_mod_h - USE print_control_mod, ONLY: prt_level, lunout - USE yomcst_mod_h - USE cv3_cine_mod, ONLY : cv3_cine - USE cv3_buoy_mod, ONLY : cv3_buoy -IMPLICIT NONE - - - - ! input: - INTEGER, INTENT (IN) :: ncum, nd, nloc - INTEGER, DIMENSION (nloc), INTENT (IN) :: icb, inb - REAL, DIMENSION (nloc), INTENT (IN) :: pbase, plcl - REAL, DIMENSION (nloc, nd), INTENT (IN) :: p - REAL, DIMENSION (nloc, nd+1), INTENT (IN) :: ph - REAL, DIMENSION (nloc, nd), INTENT (IN) :: tv, tvp, buoy - REAL, DIMENSION (nloc, nd), INTENT (IN) :: supmax - LOGICAL, INTENT (IN) :: ok_inhib ! enable convection inhibition by dryness - REAL, DIMENSION (nloc), INTENT (IN) :: ale, alp - REAL, DIMENSION (nloc, nd), INTENT (IN) :: omega - - ! input/output: - INTEGER, DIMENSION (nloc), INTENT (INOUT) :: iflag - REAL, DIMENSION (nloc, nd), INTENT (INOUT) :: sig, w0 - REAL, DIMENSION (nloc), INTENT (INOUT) :: ptop2 - - ! output: - REAL, DIMENSION (nloc), INTENT (OUT) :: cape, cin - REAL, DIMENSION (nloc, nd), INTENT (OUT) :: m - REAL, DIMENSION (nloc), INTENT (OUT) :: coef, coeftrue - REAL, DIMENSION (nloc), INTENT (OUT) :: plim1, plim2 - REAL, DIMENSION (nloc, nd), INTENT (OUT) :: asupmax - REAL, DIMENSION (nloc), INTENT (OUT) :: supmax0 - REAL, DIMENSION (nloc), INTENT (OUT) :: asupmaxmin - REAL, DIMENSION (nloc), INTENT (OUT) :: cbmf, plfc - REAL, DIMENSION (nloc), INTENT (OUT) :: wbeff - - ! local variables: - INTEGER il, i, j, k, icbmax, i0(nloc), klfc(nloc) - REAL deltap, fac, w, amu - REAL rhodp, dz - REAL pbmxup - REAL dtmin(nloc, nd), sigold(nloc, nd) - REAL coefmix(nloc, nd) - REAL pzero(nloc), ptop2old(nloc) - REAL cina(nloc), cinb(nloc) - INTEGER ibeg(nloc) - INTEGER nsupmax(nloc) - REAL supcrit, temp(nloc, nd) - REAL p1(nloc), pmin(nloc) - REAL asupmax0(nloc) - LOGICAL ok(nloc) - REAL siglim(nloc, nd), wlim(nloc, nd), mlim(nloc, nd) - REAL wb2(nloc) - REAL cbmflim(nloc), cbmf1(nloc), cbmfmax(nloc) - REAL cbmflast(nloc) - REAL xp(nloc), xq(nloc), xr(nloc), discr(nloc), b3(nloc), b4(nloc) - REAL theta(nloc), bb(nloc) - REAL term1, term2, term3 - REAL alp2(nloc) ! Alp with offset - !CR: variables for new erosion of adiabiatic ascent - REAL mad(nloc, nd), me(nloc, nd), betalim(nloc, nd), beta_coef(nloc, nd) - REAL med(nloc, nd), md(nloc,nd) -!jyg< -! coef_peel is now in the common cv3_param -!! REAL coef_peel -!! PARAMETER (coef_peel=0.25) -!>jyg - - REAL,PARAMETER :: sigmax = 0.1 - - CHARACTER (LEN=20), PARAMETER :: modname = 'cv3p1_closure' - CHARACTER (LEN=80) :: abort_message - - ! print *,' -> cv3p1_closure, Ale ',ale(1) - - - ! ------------------------------------------------------- - ! -- Initialization - ! ------------------------------------------------------- - - - DO il = 1, ncum - alp2(il) = max(alp(il), 1.E-5) - ! IM - alp2(il) = max(alp(il), 1.E-12) - END DO - - pbmxup = 50. ! PBMXUP+PBCRIT = cloud depth above which mixed updraughts - ! exist (if any) - - IF (prt_level>=20) PRINT *, 'cv3p1_param nloc ncum nd icb inb nl', nloc, & - ncum, nd, icb(nloc), inb(nloc), nl - DO k = 1, nd !jyg: initialization up to nd - DO il = 1, ncum - m(il, k) = 0.0 - END DO - END DO - -!CR: initializations for erosion of adiabatic ascent - DO k = 1,nd !jyg: initialization up to nd - DO il = 1, ncum - mad(il,k)=0. - me(il,k)=0. - betalim(il,k)=1. - wlim(il,k)=0. - ENDDO - ENDDO - - ! ------------------------------------------------------- - ! -- Reset sig(i) and w0(i) for i>inb and i=(inb(il)+1))) THEN - sig(il, k) = beta*sig(il, k) + 2.*alpha*buoy(il, inb(il))*abs(buoy(il & - ,inb(il))) - sig(il, k) = amax1(sig(il,k), 0.0) - w0(il, k) = beta*w0(il, k) - END IF - END DO - END DO - - ! if(prt.level.GE.20) print*,'cv3p1_param apres 100' - ! compute icbmax: - -!ym break the column independance -!ym icbmax = 2 -!ym DO il = 1, ncum -!ym icbmax = max(icbmax, icb(il)) -!ym END DO - - ! if(prt.level.GE.20) print*,'cv3p1_param apres 200' - - ! update sig and w0 below cloud base: -!ym column independance -!ym DO k = 1, icbmax - -! JYCF2026/01/20 m(k)=rho(k)*sig(k)*w(k) -! sig(k) est la fraction surfacique de l'ascendance arrivant au niveau k (en m^2/m^2) - - DO k = 1, nd - DO il = 1, ncum - IF (k<=MAX(2,icb(il))) THEN - IF (k<=icb(il)) THEN - sig(il, k) = beta*sig(il, k) - 2.*alpha*buoy(il, icb(il))*buoy(il, & - icb(il)) - sig(il, k) = amax1(sig(il,k), 0.0) - w0(il, k) = beta*w0(il, k) - END IF - ENDIF - END DO - END DO - IF (prt_level>=20) PRINT *, 'cv3p1_param apres 300' - ! ------------------------------------------------------------- - ! -- Reset fractional areas of updrafts and w0 at initial time - ! -- and after 10 time steps of no convection - ! ------------------------------------------------------------- - - DO k = 1, nl - 1 - DO il = 1, ncum - IF (sig(il,nd)<1.5 .OR. sig(il,nd)>12.0) THEN - sig(il, k) = 0.0 - w0(il, k) = 0.0 - END IF - END DO - END DO - IF (prt_level>=20) PRINT *, 'cv3p1_param apres 400' - - ! ------------------------------------------------------------- - ! jyg1 - ! -- Calculate adiabatic ascent top pressure (ptop) - ! ------------------------------------------------------------- - - - ! c 1. Start at first level where precipitations form - DO il = 1, ncum - pzero(il) = plcl(il) - pbcrit - END DO - - ! c 2. Add offset - DO il = 1, ncum - pzero(il) = pzero(il) - pbmxup - END DO - DO il = 1, ncum - ptop2old(il) = ptop2(il) - END DO - - DO il = 1, ncum - ! CR:c est quoi ce 300?? - p1(il) = pzero(il) - 300. - END DO - - ! compute asupmax=abs(supmax) up to lnm+1 - - DO il = 1, ncum - ok(il) = .TRUE. - nsupmax(il) = inb(il) - END DO - - DO i = 1, nl - DO il = 1, ncum - IF (i>icb(il) .AND. i<=inb(il)) THEN - IF (p(il,i)<=pzero(il) .AND. supmax(il,i)<0 .AND. ok(il)) THEN - nsupmax(il) = i - ok(il) = .FALSE. - END IF ! end IF (P(i) ... ) - END IF ! end IF (icb+1 le i le inb) - END DO - END DO - - IF (prt_level>=20) PRINT *, 'cv3p1_param apres 2.' - DO i = 1, nl - DO il = 1, ncum - asupmax(il, i) = abs(supmax(il,i)) - END DO - END DO - - - DO il = 1, ncum - asupmaxmin(il) = 10. - pmin(il) = 100. - ! IM ?? - asupmax0(il) = 0. - END DO - - ! c 3. Compute in which level is Pzero - - ! IM bug i0 = 18 - DO il = 1, ncum - i0(il) = nl - END DO - - DO i = 1, nl - DO il = 1, ncum - IF (i>icb(il) .AND. i<=inb(il)) THEN - IF (p(il,i)<=pzero(il) .AND. p(il,i)>=p1(il)) THEN - IF (pzero(il)>p(il,i) .AND. pzero(il)=20) PRINT *, 'cv3p1_param apres 3.' - - ! c 4. Compute asupmax at Pzero - - DO i = 1, nl - DO il = 1, ncum - IF (i>icb(il) .AND. i<=inb(il)) THEN - IF (p(il,i)<=pzero(il) .AND. p(il,i)>=p1(il)) THEN - asupmax0(il) = ((pzero(il)-p(il,i0(il)-1))*asupmax(il,i0(il))-( & - pzero(il)-p(il,i0(il)))*asupmax(il,i0(il)-1))/(p(il,i0(il))-p(il, & - i0(il)-1)) - END IF - END IF - END DO - END DO - - - DO i = 1, nl - DO il = 1, ncum - IF (p(il,i)==pzero(il)) THEN - asupmax(i, il) = asupmax0(il) - END IF - END DO - END DO - IF (prt_level>=20) PRINT *, 'cv3p1_param apres 4.' - - ! c 5. Compute asupmaxmin, minimum of asupmax - - DO i = 1, nl - DO il = 1, ncum - IF (i>icb(il) .AND. i<=inb(il)) THEN - IF (p(il,i)<=pzero(il) .AND. p(il,i)>=p1(il)) THEN - IF (asupmax(il,i)=20) THEN - PRINT *, 'cv3p1_closure il asupmax0 asupmaxmin', il, asupmax0(il), & - asupmaxmin(il), pzero(il), pmin(il) - END IF - IF (asupmax0(il)=20) PRINT *, 'cv3p1_param apres 5.' - - - ! Compute Supmax at Pzero - - DO i = 1, nl - DO il = 1, ncum - IF (i>icb(il) .AND. i<=inb(il)) THEN - IF (p(il,i)<=pzero(il)) THEN - supmax0(il) = ((p(il,i)-pzero(il))*asupmax(il,i-1)-(p(il, & - i-1)-pzero(il))*asupmax(il,i))/(p(il,i)-p(il,i-1)) -!ym WARNING : probably bad GOTO branching ===> to check ! -!ym GO TO 425 - END IF ! end IF (P(i) ... ) - END IF ! end IF (icb+1 le i le inb) - END DO - END DO -!ym bad branching -!ym 425 CONTINUE - IF (prt_level>=20) PRINT *, 'cv3p1_param apres 425.' - - ! c 6. Calculate ptop2 - - DO il = 1, ncum - IF (asupmaxmin(il)supcrit1 .AND. asupmaxmin(il)supcrit2) THEN - ptop2(il) = ph(il, inb(il)) - END IF - END DO - - IF (prt_level>=20) PRINT *, 'cv3p1_param apres 6.' - - ! c 7. Compute multiplying factor for adiabatic updraught mass flux - - - IF (ok_inhib) THEN - -! JYCF2026/01/20 m(k)=rho(k)*sig(k)*w(k) -! Possible que toutes les lignes au dessus ne servent que pour ok_inhib=T -! Ce n'est pas le cas. -! ok_inhib est mis à iflag_mix==2 dans cva_driver. -! Il est donc faux par défaut, pour iflag_mix=1 - - DO i = 1, nl - DO il = 1, ncum - IF (i<=nl) THEN - coefmix(il, i) = (min(ptop2(il),ph(il,i))-ph(il,i))/(ph(il,i+1)-ph( & - il,i)) - coefmix(il, i) = min(coefmix(il,i), 1.) - END IF - END DO - END DO - - - ELSE ! when inhibition is not taken into account, coefmix=1 - - - - DO i = 1, nl - DO il = 1, ncum - IF (i<=nl) THEN - coefmix(il, i) = 1. - END IF - END DO - END DO - - END IF ! ok_inhib - IF (prt_level>=20) PRINT *, 'cv3p1_param apres 7.' - ! ------------------------------------------------------------------- - ! ------------------------------------------------------------------- - - - ! jyg2 - - ! ========================================================================== - - - ! ------------------------------------------------------------- - ! -- Calculate convective inhibition (CIN) - ! ------------------------------------------------------------- - - ! do i=1,nloc - ! print*,'avant cine p',pbase(i),plcl(i) - ! enddo - ! do j=1,nd - ! do i=1,nloc - ! print*,'avant cine t',tv(i),tvp(i) - ! enddo - ! enddo - CALL cv3_cine(nloc, ncum, nd, icb, inb, pbase, plcl, p, ph, tv, tvp, cina, & - cinb, plfc) - -! JYCF2026/01/20 somme de la partie en dessous et au dessus du LCL - - DO il = 1, ncum - cin(il) = cina(il) + cinb(il) - END DO - IF (prt_level>=20) PRINT *, 'cv3p1_param apres cv3_cine' - - ! ------------------------------------------------------------- - ! --Update buoyancies to account for Ale - ! ------------------------------------------------------------- - -! JYCF2026/01/20 Ajout de Ale dans le caclul de ALE pour le déclenchement -! Est-ce que le calcul du déclenchement est fait dedans. -! A verifier et documenter. -! Notamment mettre les inten(in/out) dans cv3_buoy.f90 -! On ne sort buoy que si ALE+CIN>0 ? -! Le "buoy" qui sort est un delta de température ? - - CALL cv3_buoy(nloc, ncum, nd, icb, inb, pbase, plcl, p, ph, ale, cin, tv, & - tvp, buoy) - IF (prt_level>=20) PRINT *, 'cv3p1_param apres cv3_buoy' - - ! ------------------------------------------------------------- - ! -- Calculate convective available potential energy (cape), - ! -- vertical velocity (w), fractional area covered by - ! -- undilute updraft (sig), and updraft mass flux (m) - ! ------------------------------------------------------------- - - DO il = 1, ncum - cape(il) = 0.0 - END DO - - ! compute dtmin (minimum buoyancy between ICB and given level k): - ! in fact a delta of temperature - DO k = 1, nl - DO il = 1, ncum - dtmin(il, k) = 100.0 - END DO - END DO - - DO k = 1, nl - DO j = minorig, nl - DO il = 1, ncum - IF ((k>=(icb(il)+1)) .AND. (k<=inb(il)) .AND. (j>=icb(il)) .AND. (j<= & - (k-1))) THEN - dtmin(il, k) = amin1(dtmin(il,k), buoy(il,j)) - END IF - END DO - END DO - END DO - - ! the vertical interval on which cape is computed starts at pbase : - -! JYCF2026/01/20 computing siglim(k), the target value for sig(k) -! for the time relaxation -! mlim=rho*dp*siglim*wlim avec wlim=sqrt(cape) - - - DO k = 1, nl - DO il = 1, ncum - - IF ((k>=(icb(il)+1)) .AND. (k<=inb(il))) THEN - IF (iflag_mix_adiab.eq.1) THEN -!CR:computation of cape from LCL: keep flag or to modify in all cases? - deltap = min(plcl(il), ph(il,k-1)) - min(plcl(il), ph(il,k)) - ELSE - deltap = min(pbase(il), ph(il,k-1)) - min(pbase(il), ph(il,k)) - ENDIF - cape(il) = cape(il) + rrd*buoy(il, k-1)*deltap/p(il, k-1) - cape(il) = amax1(0.0, cape(il)) - sigold(il, k) = sig(il, k) - - - ! jyg Coefficient coefmix limits convection to levels where a - ! sufficient - ! fraction of mixed draughts are ascending. - siglim(il, k) = coefmix(il, k)*alpha1*dtmin(il, k)*abs(dtmin(il,k)) - siglim(il, k) = amax1(siglim(il,k), 0.0) - siglim(il, k) = amin1(siglim(il,k), 0.01) - ! c fac=AMIN1(((dtcrit-dtmin(il,k))/dtcrit),1.0) - fac = 1. - wlim(il, k) = fac*sqrt(cape(il)) - amu = siglim(il, k)*wlim(il, k) - rhodp = 0.007*p(il, k)*(ph(il,k)-ph(il,k+1))/tv(il, k) - mlim(il, k) = amu*rhodp - ! print*, 'siglim ', k,siglim(1,k) - END IF - - END DO - END DO - IF (prt_level>=20) PRINT *, 'cv3p1_param apres 600' - - DO il = 1, ncum - ! IM beg - IF (prt_level>=20) THEN - PRINT *, 'cv3p1_closure il icb mlim ph ph+1 ph+2', il, icb(il), & - mlim(il, icb(il)+1), ph(il, icb(il)), ph(il, icb(il)+1), & - ph(il, icb(il)+2) - END IF - -! JYCF2026/01/20 computing mlim at CB -! Boucle à vérifier -! inb est le sommet - - IF (icb(il)+1<=inb(il)) THEN - ! IM end - mlim(il, icb(il)) = 0.5*mlim(il, icb(il)+1)*(ph(il,icb(il))-ph(il,icb( & - il)+1))/(ph(il,icb(il)+1)-ph(il,icb(il)+2)) - ! IM beg - END IF !(icb(il.le.inb(il))) then - ! IM end - END DO - IF (prt_level>=20) PRINT *, 'cv3p1_param apres 700' - - ! jyg1 - ! ------------------------------------------------------------------------ - ! c Correct mass fluxes so that power used to overcome CIN does not - ! c exceed Power Available for Lifting (PAL). - ! ------------------------------------------------------------------------ - - -! JYCF2026/01/20 cbmflim=sum(mlim) - DO il = 1, ncum - cbmflim(il) = 0. - cbmf(il) = 0. - END DO - - ! c 1. Compute cloud base mass flux of elementary system (Cbmf0=Cbmflim) - - DO k = 1, nl - DO il = 1, ncum - ! old IF (k .ge. icb(il) .and. k .le. inb(il)) THEN - ! IM IF (k .ge. icb(il)+1 .and. k .le. inb(il)) THEN - IF (k>=icb(il) .AND. k<=inb(il) & !cor jyg - .AND. icb(il)+1<=inb(il)) THEN !cor jyg - cbmflim(il) = cbmflim(il) + mlim(il, k) - END IF - END DO - END DO - IF (prt_level>=20) PRINT *, 'cv3p1_param apres cbmflim' - - ! 1.5 Compute cloud base mass flux given by Alp closure (Cbmf1), maximum - ! allowed mass flux (Cbmfmax) and final target mass flux (Cbmf) - ! Cbmf is set to zero if Cbmflim (the mass flux of elementary cloud) - ! is exceedingly small. - - DO il = 1, ncum - wb2(il) = sqrt(2.*max(ale(il)+cin(il),0.)) - END DO - -! JYCF2026/01/20 Various options to compute the vertical velocity -! in the adiabatic ascent at cloud base - - DO il = 1, ncum - IF (plfc(il)<100.) THEN - ! This is an irealistic value for plfc => no calculation of wbeff - wbeff(il) = 100.1 - ELSE - ! Calculate wbeff - IF (NINT(flag_wb)==0) THEN - wbeff(il) = wbmax - ELSE IF (NINT(flag_wb)==1) THEN - wbeff(il) = wbmax/(1.+500./(ph(il,1)-plfc(il))) - ELSE IF (NINT(flag_wb)==2) THEN - wbeff(il) = wbmax*(0.01*(ph(il,1)-plfc(il)))**2 - ELSE ! Option provisoire ou le iflag_wb/10 est considere comme une vitesse - wbeff(il) = flag_wb*0.01+wbmax/(1.+500./(ph(il,1)-plfc(il))) - END IF - END IF - END DO - -!CR:Compute k at plfc - DO il=1,ncum - klfc(il)=nl - ENDDO - DO k=1,nl - DO il=1,ncum - if ((plfc(il).lt.ph(il,k)).and.(plfc(il).ge.ph(il,k+1))) then - klfc(il)=k - endif - ENDDO - ENDDO -!RC - -! JYCF2026/01/20 computing cbmf1, mass flux at cloud base coming -! from the ALP closure - - DO il = 1, ncum - ! jyg Modification du coef de wb*wb pour conformite avec papier Wake - ! c cbmf1(il) = alp2(il)/(0.5*wb*wb-Cin(il)) - cbmf1(il) = alp2(il)/(2.*wbeff(il)*wbeff(il)-cin(il)) -!CR: Add large-scale component to the mass-flux -!encore connu sous le nom "Experience du tube de dentifrice" - if ((coef_clos_ls.gt.0.).and.(plfc(il).gt.0.)) then - cbmf1(il) = cbmf1(il) - coef_clos_ls*min(0.,1./RG*omega(il,klfc(il))) - endif -!RC - IF (cbmf1(il)==0 .AND. alp2(il)/=0.) THEN - WRITE (lunout, *) 'cv3p1_closure cbmf1=0 and alp NE 0 il alp2 alp cin ' & - , il, alp2(il), alp(il), cin(il) - abort_message = '' - CALL abort_physic(modname, abort_message, 1) - END IF - cbmfmax(il) = sigmax*wb2(il)*100.*p(il, icb(il))/(rrd*tv(il,icb(il))) - END DO - -! JYCF2026/01/20 cbmf=cbmf1, coming from ALP closure - DO il = 1, ncum - IF (cbmflim(il)>1.E-6) THEN - ! ATTENTION TEST CR - ! if (cbmfmax(il).lt.1.e-12) then - cbmf(il) = min(cbmf1(il), cbmfmax(il)) - ! else - ! cbmf(il) = cbmf1(il) - ! endif - ! print*,'cbmf',cbmf1(il),cbmfmax(il) - END IF - END DO - IF (prt_level>=20) PRINT *, 'cv3p1_param apres cbmflim_testCR' - - ! c 2. Compute coefficient and apply correction - -! JYCF2026/01/20 coef : ratio of the ALP to the CAPE closure -! keeping the original ratio in coeftrue - - DO il = 1, ncum - coef(il) = (cbmf(il)+1.E-10)/(cbmflim(il)+1.E-10) - coeftrue(il) = coef(il) - END DO - IF (prt_level>=20) PRINT *, 'cv3p1_param apres coef_plantePLUS' - -! JYCF2026/01/20 : resumé -! computing siglim(k), the target value for sig(k) -! for the time relaxation -! mlim=rho*dp*siglim*wlim avec wlim=sqrt(cape) -! cbmflim=sum(mlim) -! computing cbmf, mass flux at cloud base from the ALP closure -! time relaxation on sig*w (in fact on "m") -! w is kept unchanged and sig is computed as sig*w/w -! -! coef=cbmf(ALP)/cbmflim(CAPE) sans relaxation -! - - -! JYCF2026/01/20 time relaxation on sig*w (in fact on "m") -! beta = 1.0 - delt / tau, in cv3_param -! w is kept unchanged and sig is computed as sig*w/w - - DO k = 1, nl - DO il = 1, ncum - IF (k>=icb(il)+1 .AND. k<=inb(il)) THEN - amu = beta*sig(il, k)*w0(il, k) + (1.-beta)*coef(il)*siglim(il, k)* & - wlim(il, k) - w0(il, k) = wlim(il, k) - w0(il, k) = max(w0(il,k), 1.E-10) - sig(il, k) = amu/w0(il, k) - sig(il, k) = min(sig(il,k), 1.) - ! c amu = 0.5*(SIG(il,k)+sigold(il,k))*W0(il,k) -! JYCF2026/01/20 0.007=2/R ? -! m=sig w rho delta(p) - m(il, k) = amu*0.007*p(il, k)*(ph(il,k)-ph(il,k+1))/tv(il, k) - END IF - END DO - END DO - ! jyg2 - DO il = 1, ncum - w0(il, icb(il)) = 0.5*w0(il, icb(il)+1) - m(il, icb(il)) = 0.5*m(il, icb(il)+1)*(ph(il,icb(il))-ph(il,icb(il)+1))/ & - (ph(il,icb(il)+1)-ph(il,icb(il)+2)) - sig(il, icb(il)) = sig(il, icb(il)+1) - sig(il, icb(il)-1) = sig(il, icb(il)) - END DO - IF (prt_level>=20) PRINT *, 'cv3p1_param apres w0_sig_M' - -!CR: new erosion of adiabatic ascent: modification of m -!computation of the sum of ascending fluxes - IF (iflag_mix_adiab.eq.1) THEN - ! - !Verification sum(me)=sum(m) - DO k = 1,nd !jyg: initialization up to nd - DO il = 1, ncum - md(il,k)=0. - med(il,k)=0. - ENDDO - ENDDO - ! - DO k = nl,1,-1 - DO il = 1, ncum - md(il,k)=md(il,k+1)+m(il,k+1) - ENDDO - ENDDO - ! - DO k = nl,1,-1 - DO il = 1, ncum - IF ((k>=(icb(il))) .AND. (k<=inb(il))) THEN - mad(il,k)=mad(il,k+1)+m(il,k+1) - ENDIF - ! print*,"mad",il,k,mad(il,k) - ENDDO - ENDDO - ! - !CR: erosion of each adiabatic ascent during its ascent - ! - !Computation of erosion coefficient beta_coef - DO k = 1, nl - DO il = 1, ncum - IF ((k>=(icb(il)+1)) .AND. (k<=inb(il)) .AND. (mlim(il,k).gt.0.)) THEN - ! print*,"beta_coef",il,k,icb(il),inb(il),buoy(il,k),tv(il,k),wlim(il,k),wlim(il,k+1) - beta_coef(il,k)=RG*coef_peel*buoy(il,k)/tv(il,k)/((wlim(il,k)+wlim(il,k+1))/2.)**2 - ELSE - beta_coef(il,k)=0. - ENDIF - ENDDO - ENDDO - ! - ! print*,"apres beta_coef" - ! - DO k = 1, nl - DO il = 1, ncum - ! - IF ((k>=(icb(il)+1)) .AND. (k<=inb(il))) THEN - ! - ! print*,"dz",il,k,tv(il, k-1) - dz = (ph(il,k-1)-ph(il,k))/(p(il, k-1)/(rrd*tv(il, k-1))*RG) - betalim(il,k)=betalim(il,k-1)*exp(-1.*beta_coef(il,k-1)*dz) - ! betalim(il,k)=betalim(il,k-1)*exp(-RG*coef_peel*buoy(il,k-1)/tv(il,k-1)/5.**2*dz) - ! print*,"me",il,k,mlim(il,k),buoy(il,k),wlim(il,k),mad(il,k) - dz = (ph(il,k)-ph(il,k+1))/(p(il, k)/(rrd*tv(il, k))*RG) - ! me(il,k)=betalim(il,k)*(m(il,k)+RG*coef_peel*buoy(il,k)/tv(il,k)/((wlim(il,k)+wlim(il,k+1))/2.)**2*dz*mad(il,k)) - me(il,k)=betalim(il,k)*(m(il,k)+beta_coef(il,k)*dz*mad(il,k)) - ! print*,"B/w2",il,k,RG*coef_peel*buoy(il,k)/tv(il,k)/((wlim(il,k)+wlim(il,k+1))/2.)**2*dz - ! - END IF - ! - !Modification of m - m(il,k)=me(il,k) - END DO - END DO - ! - ! DO il = 1, ncum - ! dz = (ph(il,icb(il))-ph(il,icb(il)+1))/(p(il, icb(il))/(rrd*tv(il, icb(il)))*RG) - ! m(il,icb(il))=m(il,icb(il))+RG*coef_peel*buoy(il,icb(il))/tv(il,icb(il)) & - ! /((wlim(il,icb(il))+wlim(il,icb(il)+1))/2.)**2*dz*mad(il,icb(il)) - ! print*,"wlim(icb)",icb(il),wlim(il,icb(il)),m(il,icb(il)) - ! ENDDO - ! - !Verification sum(me)=sum(m) - DO k = nl,1,-1 - DO il = 1, ncum - med(il,k)=med(il,k+1)+m(il,k+1) - ! print*,"somme(me),somme(m)",il,k,icb(il),med(il,k),md(il,k),me(il,k),m(il,k),wlim(il,k) - ENDDO - ENDDO - ! - ! - ENDIF !(iflag_mix_adiab) -!RC - - - - ! c 3. Compute final cloud base mass flux and set iflag to 3 if - ! c cloud base mass flux is exceedingly small and is decreasing (i.e. if - ! c the final mass flux (cbmflast) is greater than the target mass flux - ! c (cbmf)). - - DO il = 1, ncum - cbmflast(il) = 0. - END DO - - DO k = 1, nl - DO il = 1, ncum - IF (k>=icb(il) .AND. k<=inb(il)) THEN - !IMpropo?? IF ((k.ge.(icb(il)+1)).and.(k.le.inb(il))) THEN - cbmflast(il) = cbmflast(il) + m(il, k) - END IF - END DO - END DO - - DO il = 1, ncum - IF (cbmflast(il)<1.E-6 .AND. cbmflast(il)>=cbmf(il)) THEN - iflag(il) = 3 - END IF - END DO - - DO k = 1, nl - DO il = 1, ncum - IF (iflag(il)>=3) THEN - m(il, k) = 0. - sig(il, k) = 0. - w0(il, k) = 0. - END IF - END DO - END DO - IF (prt_level>=20) PRINT *, 'cv3p1_param apres iflag' - - ! c 4. Introduce a correcting factor for coef, in order to obtain an - ! effective sigdz larger in the present case (using cv3p1_closure) - ! than in the old - ! c closure (using cv3_closure). - IF (1==0) THEN - DO il = 1, ncum - ! c coef(il) = 2.*coef(il) - coef(il) = 5.*coef(il) - END DO - ! version CVS du ..2008 - ELSE - IF (iflag_cvl_sigd==0) THEN - ! test pour verifier qu on fait la meme chose qu avant: sid constant - coef(1:ncum) = 1. - ELSE - coef(1:ncum) = min(2.*coef(1:ncum), 5.) - coef(1:ncum) = max(2.*coef(1:ncum), 0.2) - END IF - END IF - - IF (prt_level>=20) PRINT *, 'cv3p1_param FIN' - RETURN -END SUBROUTINE cv3p1_closure - -END MODULE cv3p1_closure_mod - Index: LMDZ6/trunk/libf/phylmd/cv3p1_closure_mod.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cv3p1_closure_mod.f90 (revision 6048) +++ LMDZ6/trunk/libf/phylmd/cv3p1_closure_mod.f90 (revision 6048) @@ -0,0 +1,845 @@ + +! $Id$ +MODULE cv3p1_closure_mod +PRIVATE +PUBLIC cv3p1_closure +CONTAINS + +SUBROUTINE cv3p1_closure(nloc, ncum, nd, icb, inb, pbase, plcl, p, ph, tv, & + tvp, buoy, supmax, ok_inhib, ale, alp, omega,sig, w0, ptop2, cape, cin, m, & + iflag, coef, coeftrue, plim1, plim2, asupmax, supmax0, asupmaxmin, & + cbmf, plfc, wbeff) + + + ! ************************************************************** + ! * + ! CV3P1_CLOSURE * + ! Ale & Alp Closure of Convect3 * + ! * + ! written by : Kerry Emanuel * + ! vectorization: S. Bony * + ! modified by : Jean-Yves Grandpeix, 18/06/2003, 19.32.10 * + ! Julie Frohwirth, 14/10/2005 17.44.22 * + ! ************************************************************** + +USE yomcst2_mod_h + USE lmdz_cv_ini, ONLY : pbcrit,wbmax,rrd,minorig,flag_wb,alpha,alpha1,beta,coef_peel,nl + USE conema3_mod_h + USE print_control_mod, ONLY: prt_level, lunout + USE yomcst_mod_h + USE cv3_cine_mod, ONLY : cv3_cine + USE cv3_buoy_mod, ONLY : cv3_buoy +IMPLICIT NONE + + + + ! input: + INTEGER, INTENT (IN) :: ncum, nd, nloc + INTEGER, DIMENSION (nloc), INTENT (IN) :: icb, inb + REAL, DIMENSION (nloc), INTENT (IN) :: pbase, plcl + REAL, DIMENSION (nloc, nd), INTENT (IN) :: p + REAL, DIMENSION (nloc, nd+1), INTENT (IN) :: ph + REAL, DIMENSION (nloc, nd), INTENT (IN) :: tv, tvp, buoy + REAL, DIMENSION (nloc, nd), INTENT (IN) :: supmax + LOGICAL, INTENT (IN) :: ok_inhib ! enable convection inhibition by dryness + REAL, DIMENSION (nloc), INTENT (IN) :: ale, alp + REAL, DIMENSION (nloc, nd), INTENT (IN) :: omega + + ! input/output: + INTEGER, DIMENSION (nloc), INTENT (INOUT) :: iflag + REAL, DIMENSION (nloc, nd), INTENT (INOUT) :: sig, w0 + REAL, DIMENSION (nloc), INTENT (INOUT) :: ptop2 + + ! output: + REAL, DIMENSION (nloc), INTENT (OUT) :: cape, cin + REAL, DIMENSION (nloc, nd), INTENT (OUT) :: m + REAL, DIMENSION (nloc), INTENT (OUT) :: coef, coeftrue + REAL, DIMENSION (nloc), INTENT (OUT) :: plim1, plim2 + REAL, DIMENSION (nloc, nd), INTENT (OUT) :: asupmax + REAL, DIMENSION (nloc), INTENT (OUT) :: supmax0 + REAL, DIMENSION (nloc), INTENT (OUT) :: asupmaxmin + REAL, DIMENSION (nloc), INTENT (OUT) :: cbmf, plfc + REAL, DIMENSION (nloc), INTENT (OUT) :: wbeff + + ! local variables: + INTEGER il, i, j, k, icbmax, i0(nloc), klfc(nloc) + REAL deltap, fac, w, amu + REAL rhodp, dz + REAL pbmxup + REAL dtmin(nloc, nd), sigold(nloc, nd) + REAL coefmix(nloc, nd) + REAL pzero(nloc), ptop2old(nloc) + REAL cina(nloc), cinb(nloc) + INTEGER ibeg(nloc) + INTEGER nsupmax(nloc) + REAL supcrit, temp(nloc, nd) + REAL p1(nloc), pmin(nloc) + REAL asupmax0(nloc) + LOGICAL ok(nloc) + REAL siglim(nloc, nd), wlim(nloc, nd), mlim(nloc, nd) + REAL wb2(nloc) + REAL cbmflim(nloc), cbmf1(nloc), cbmfmax(nloc) + REAL cbmflast(nloc) + REAL xp(nloc), xq(nloc), xr(nloc), discr(nloc), b3(nloc), b4(nloc) + REAL theta(nloc), bb(nloc) + REAL term1, term2, term3 + REAL alp2(nloc) ! Alp with offset + !CR: variables for new erosion of adiabiatic ascent + REAL mad(nloc, nd), me(nloc, nd), betalim(nloc, nd), beta_coef(nloc, nd) + REAL med(nloc, nd), md(nloc,nd) +!jyg< +! coef_peel is now in the common cv3_param +!! REAL coef_peel +!! PARAMETER (coef_peel=0.25) +!>jyg + + REAL,PARAMETER :: sigmax = 0.1 + + CHARACTER (LEN=20), PARAMETER :: modname = 'cv3p1_closure' + CHARACTER (LEN=80) :: abort_message + + ! print *,' -> cv3p1_closure, Ale ',ale(1) + + + ! ------------------------------------------------------- + ! -- Initialization + ! ------------------------------------------------------- + + + DO il = 1, ncum + alp2(il) = max(alp(il), 1.E-5) + ! IM + alp2(il) = max(alp(il), 1.E-12) + END DO + + pbmxup = 50. ! PBMXUP+PBCRIT = cloud depth above which mixed updraughts + ! exist (if any) + + IF (prt_level>=20) PRINT *, 'cv3p1_param nloc ncum nd icb inb nl', nloc, & + ncum, nd, icb(nloc), inb(nloc), nl + DO k = 1, nd !jyg: initialization up to nd + DO il = 1, ncum + m(il, k) = 0.0 + END DO + END DO + +!CR: initializations for erosion of adiabatic ascent + DO k = 1,nd !jyg: initialization up to nd + DO il = 1, ncum + mad(il,k)=0. + me(il,k)=0. + betalim(il,k)=1. + wlim(il,k)=0. + ENDDO + ENDDO + + ! ------------------------------------------------------- + ! -- Reset sig(i) and w0(i) for i>inb and i=(inb(il)+1))) THEN + sig(il, k) = beta*sig(il, k) + 2.*alpha*buoy(il, inb(il))*abs(buoy(il & + ,inb(il))) + sig(il, k) = amax1(sig(il,k), 0.0) + w0(il, k) = beta*w0(il, k) + END IF + END DO + END DO + + ! if(prt.level.GE.20) print*,'cv3p1_param apres 100' + ! compute icbmax: + +!ym break the column independance +!ym icbmax = 2 +!ym DO il = 1, ncum +!ym icbmax = max(icbmax, icb(il)) +!ym END DO + + ! if(prt.level.GE.20) print*,'cv3p1_param apres 200' + + ! update sig and w0 below cloud base: +!ym column independance +!ym DO k = 1, icbmax + +! JYCF2026/01/20 m(k)=rho(k)*sig(k)*w(k) +! sig(k) est la fraction surfacique de l'ascendance arrivant au niveau k (en m^2/m^2) + + DO k = 1, nd + DO il = 1, ncum + IF (k<=MAX(2,icb(il))) THEN + IF (k<=icb(il)) THEN + sig(il, k) = beta*sig(il, k) - 2.*alpha*buoy(il, icb(il))*buoy(il, & + icb(il)) + sig(il, k) = amax1(sig(il,k), 0.0) + w0(il, k) = beta*w0(il, k) + END IF + ENDIF + END DO + END DO + IF (prt_level>=20) PRINT *, 'cv3p1_param apres 300' + ! ------------------------------------------------------------- + ! -- Reset fractional areas of updrafts and w0 at initial time + ! -- and after 10 time steps of no convection + ! ------------------------------------------------------------- + + DO k = 1, nl - 1 + DO il = 1, ncum + IF (sig(il,nd)<1.5 .OR. sig(il,nd)>12.0) THEN + sig(il, k) = 0.0 + w0(il, k) = 0.0 + END IF + END DO + END DO + IF (prt_level>=20) PRINT *, 'cv3p1_param apres 400' + + ! ------------------------------------------------------------- + ! jyg1 + ! -- Calculate adiabatic ascent top pressure (ptop) + ! ------------------------------------------------------------- + + + ! c 1. Start at first level where precipitations form + DO il = 1, ncum + pzero(il) = plcl(il) - pbcrit + END DO + + ! c 2. Add offset + DO il = 1, ncum + pzero(il) = pzero(il) - pbmxup + END DO + DO il = 1, ncum + ptop2old(il) = ptop2(il) + END DO + + DO il = 1, ncum + ! CR:c est quoi ce 300?? + p1(il) = pzero(il) - 300. + END DO + + ! compute asupmax=abs(supmax) up to lnm+1 + + DO il = 1, ncum + ok(il) = .TRUE. + nsupmax(il) = inb(il) + END DO + + DO i = 1, nl + DO il = 1, ncum + IF (i>icb(il) .AND. i<=inb(il)) THEN + IF (p(il,i)<=pzero(il) .AND. supmax(il,i)<0 .AND. ok(il)) THEN + nsupmax(il) = i + ok(il) = .FALSE. + END IF ! end IF (P(i) ... ) + END IF ! end IF (icb+1 le i le inb) + END DO + END DO + + IF (prt_level>=20) PRINT *, 'cv3p1_param apres 2.' + DO i = 1, nl + DO il = 1, ncum + asupmax(il, i) = abs(supmax(il,i)) + END DO + END DO + + + DO il = 1, ncum + asupmaxmin(il) = 10. + pmin(il) = 100. + ! IM ?? + asupmax0(il) = 0. + END DO + + ! c 3. Compute in which level is Pzero + + ! IM bug i0 = 18 + DO il = 1, ncum + i0(il) = nl + END DO + + DO i = 1, nl + DO il = 1, ncum + IF (i>icb(il) .AND. i<=inb(il)) THEN + IF (p(il,i)<=pzero(il) .AND. p(il,i)>=p1(il)) THEN + IF (pzero(il)>p(il,i) .AND. pzero(il)=20) PRINT *, 'cv3p1_param apres 3.' + + ! c 4. Compute asupmax at Pzero + + DO i = 1, nl + DO il = 1, ncum + IF (i>icb(il) .AND. i<=inb(il)) THEN + IF (p(il,i)<=pzero(il) .AND. p(il,i)>=p1(il)) THEN + asupmax0(il) = ((pzero(il)-p(il,i0(il)-1))*asupmax(il,i0(il))-( & + pzero(il)-p(il,i0(il)))*asupmax(il,i0(il)-1))/(p(il,i0(il))-p(il, & + i0(il)-1)) + END IF + END IF + END DO + END DO + + + DO i = 1, nl + DO il = 1, ncum + IF (p(il,i)==pzero(il)) THEN + asupmax(i, il) = asupmax0(il) + END IF + END DO + END DO + IF (prt_level>=20) PRINT *, 'cv3p1_param apres 4.' + + ! c 5. Compute asupmaxmin, minimum of asupmax + + DO i = 1, nl + DO il = 1, ncum + IF (i>icb(il) .AND. i<=inb(il)) THEN + IF (p(il,i)<=pzero(il) .AND. p(il,i)>=p1(il)) THEN + IF (asupmax(il,i)=20) THEN + PRINT *, 'cv3p1_closure il asupmax0 asupmaxmin', il, asupmax0(il), & + asupmaxmin(il), pzero(il), pmin(il) + END IF + IF (asupmax0(il)=20) PRINT *, 'cv3p1_param apres 5.' + + + ! Compute Supmax at Pzero + + DO i = 1, nl + DO il = 1, ncum + IF (i>icb(il) .AND. i<=inb(il)) THEN + IF (p(il,i)<=pzero(il)) THEN + supmax0(il) = ((p(il,i)-pzero(il))*asupmax(il,i-1)-(p(il, & + i-1)-pzero(il))*asupmax(il,i))/(p(il,i)-p(il,i-1)) +!ym WARNING : probably bad GOTO branching ===> to check ! +!ym GO TO 425 + END IF ! end IF (P(i) ... ) + END IF ! end IF (icb+1 le i le inb) + END DO + END DO +!ym bad branching +!ym 425 CONTINUE + IF (prt_level>=20) PRINT *, 'cv3p1_param apres 425.' + + ! c 6. Calculate ptop2 + + DO il = 1, ncum + IF (asupmaxmin(il)supcrit1 .AND. asupmaxmin(il)supcrit2) THEN + ptop2(il) = ph(il, inb(il)) + END IF + END DO + + IF (prt_level>=20) PRINT *, 'cv3p1_param apres 6.' + + ! c 7. Compute multiplying factor for adiabatic updraught mass flux + + + IF (ok_inhib) THEN + +! JYCF2026/01/20 m(k)=rho(k)*sig(k)*w(k) +! Possible que toutes les lignes au dessus ne servent que pour ok_inhib=T +! Ce n'est pas le cas. +! ok_inhib est mis à iflag_mix==2 dans cva_driver. +! Il est donc faux par défaut, pour iflag_mix=1 + + DO i = 1, nl + DO il = 1, ncum + IF (i<=nl) THEN + coefmix(il, i) = (min(ptop2(il),ph(il,i))-ph(il,i))/(ph(il,i+1)-ph( & + il,i)) + coefmix(il, i) = min(coefmix(il,i), 1.) + END IF + END DO + END DO + + + ELSE ! when inhibition is not taken into account, coefmix=1 + + + + DO i = 1, nl + DO il = 1, ncum + IF (i<=nl) THEN + coefmix(il, i) = 1. + END IF + END DO + END DO + + END IF ! ok_inhib + IF (prt_level>=20) PRINT *, 'cv3p1_param apres 7.' + ! ------------------------------------------------------------------- + ! ------------------------------------------------------------------- + + + ! jyg2 + + ! ========================================================================== + + + ! ------------------------------------------------------------- + ! -- Calculate convective inhibition (CIN) + ! ------------------------------------------------------------- + + ! do i=1,nloc + ! print*,'avant cine p',pbase(i),plcl(i) + ! enddo + ! do j=1,nd + ! do i=1,nloc + ! print*,'avant cine t',tv(i),tvp(i) + ! enddo + ! enddo + CALL cv3_cine(nloc, ncum, nd, icb, inb, pbase, plcl, p, ph, tv, tvp, cina, & + cinb, plfc) + +! JYCF2026/01/20 somme de la partie en dessous et au dessus du LCL + + DO il = 1, ncum + cin(il) = cina(il) + cinb(il) + END DO + IF (prt_level>=20) PRINT *, 'cv3p1_param apres cv3_cine' + + ! ------------------------------------------------------------- + ! --Update buoyancies to account for Ale + ! ------------------------------------------------------------- + +! JYCF2026/01/20 Ajout de Ale dans le caclul de ALE pour le déclenchement +! Est-ce que le calcul du déclenchement est fait dedans. +! A verifier et documenter. +! Notamment mettre les inten(in/out) dans cv3_buoy.f90 +! On ne sort buoy que si ALE+CIN>0 ? +! Le "buoy" qui sort est un delta de température ? + + CALL cv3_buoy(nloc, ncum, nd, icb, inb, pbase, plcl, p, ph, ale, cin, tv, & + tvp, buoy) + IF (prt_level>=20) PRINT *, 'cv3p1_param apres cv3_buoy' + + ! ------------------------------------------------------------- + ! -- Calculate convective available potential energy (cape), + ! -- vertical velocity (w), fractional area covered by + ! -- undilute updraft (sig), and updraft mass flux (m) + ! ------------------------------------------------------------- + + DO il = 1, ncum + cape(il) = 0.0 + END DO + + ! compute dtmin (minimum buoyancy between ICB and given level k): + ! in fact a delta of temperature + DO k = 1, nl + DO il = 1, ncum + dtmin(il, k) = 100.0 + END DO + END DO + + DO k = 1, nl + DO j = minorig, nl + DO il = 1, ncum + IF ((k>=(icb(il)+1)) .AND. (k<=inb(il)) .AND. (j>=icb(il)) .AND. (j<= & + (k-1))) THEN + dtmin(il, k) = amin1(dtmin(il,k), buoy(il,j)) + END IF + END DO + END DO + END DO + + ! the vertical interval on which cape is computed starts at pbase : + +! JYCF2026/01/20 computing siglim(k), the target value for sig(k) +! for the time relaxation +! mlim=rho*dp*siglim*wlim avec wlim=sqrt(cape) + + + DO k = 1, nl + DO il = 1, ncum + + IF ((k>=(icb(il)+1)) .AND. (k<=inb(il))) THEN + IF (iflag_mix_adiab.eq.1) THEN +!CR:computation of cape from LCL: keep flag or to modify in all cases? + deltap = min(plcl(il), ph(il,k-1)) - min(plcl(il), ph(il,k)) + ELSE + deltap = min(pbase(il), ph(il,k-1)) - min(pbase(il), ph(il,k)) + ENDIF + cape(il) = cape(il) + rrd*buoy(il, k-1)*deltap/p(il, k-1) + cape(il) = amax1(0.0, cape(il)) + sigold(il, k) = sig(il, k) + + + ! jyg Coefficient coefmix limits convection to levels where a + ! sufficient + ! fraction of mixed draughts are ascending. + siglim(il, k) = coefmix(il, k)*alpha1*dtmin(il, k)*abs(dtmin(il,k)) + siglim(il, k) = amax1(siglim(il,k), 0.0) + siglim(il, k) = amin1(siglim(il,k), 0.01) + ! c fac=AMIN1(((dtcrit-dtmin(il,k))/dtcrit),1.0) + fac = 1. + wlim(il, k) = fac*sqrt(cape(il)) + amu = siglim(il, k)*wlim(il, k) + rhodp = 0.007*p(il, k)*(ph(il,k)-ph(il,k+1))/tv(il, k) + mlim(il, k) = amu*rhodp + ! print*, 'siglim ', k,siglim(1,k) + END IF + + END DO + END DO + IF (prt_level>=20) PRINT *, 'cv3p1_param apres 600' + + DO il = 1, ncum + ! IM beg + IF (prt_level>=20) THEN + PRINT *, 'cv3p1_closure il icb mlim ph ph+1 ph+2', il, icb(il), & + mlim(il, icb(il)+1), ph(il, icb(il)), ph(il, icb(il)+1), & + ph(il, icb(il)+2) + END IF + +! JYCF2026/01/20 computing mlim at CB +! Boucle à vérifier +! inb est le sommet + + IF (icb(il)+1<=inb(il)) THEN + ! IM end + mlim(il, icb(il)) = 0.5*mlim(il, icb(il)+1)*(ph(il,icb(il))-ph(il,icb( & + il)+1))/(ph(il,icb(il)+1)-ph(il,icb(il)+2)) + ! IM beg + END IF !(icb(il.le.inb(il))) then + ! IM end + END DO + IF (prt_level>=20) PRINT *, 'cv3p1_param apres 700' + + ! jyg1 + ! ------------------------------------------------------------------------ + ! c Correct mass fluxes so that power used to overcome CIN does not + ! c exceed Power Available for Lifting (PAL). + ! ------------------------------------------------------------------------ + + +! JYCF2026/01/20 cbmflim=sum(mlim) + DO il = 1, ncum + cbmflim(il) = 0. + cbmf(il) = 0. + END DO + + ! c 1. Compute cloud base mass flux of elementary system (Cbmf0=Cbmflim) + + DO k = 1, nl + DO il = 1, ncum + ! old IF (k .ge. icb(il) .and. k .le. inb(il)) THEN + ! IM IF (k .ge. icb(il)+1 .and. k .le. inb(il)) THEN + IF (k>=icb(il) .AND. k<=inb(il) & !cor jyg + .AND. icb(il)+1<=inb(il)) THEN !cor jyg + cbmflim(il) = cbmflim(il) + mlim(il, k) + END IF + END DO + END DO + IF (prt_level>=20) PRINT *, 'cv3p1_param apres cbmflim' + + ! 1.5 Compute cloud base mass flux given by Alp closure (Cbmf1), maximum + ! allowed mass flux (Cbmfmax) and final target mass flux (Cbmf) + ! Cbmf is set to zero if Cbmflim (the mass flux of elementary cloud) + ! is exceedingly small. + + DO il = 1, ncum + wb2(il) = sqrt(2.*max(ale(il)+cin(il),0.)) + END DO + +! JYCF2026/01/20 Various options to compute the vertical velocity +! in the adiabatic ascent at cloud base + + DO il = 1, ncum + IF (plfc(il)<100.) THEN + ! This is an irealistic value for plfc => no calculation of wbeff + wbeff(il) = 100.1 + ELSE + ! Calculate wbeff + IF (NINT(flag_wb)==0) THEN + wbeff(il) = wbmax + ELSE IF (NINT(flag_wb)==1) THEN + wbeff(il) = wbmax/(1.+500./(ph(il,1)-plfc(il))) + ELSE IF (NINT(flag_wb)==2) THEN + wbeff(il) = wbmax*(0.01*(ph(il,1)-plfc(il)))**2 + ELSE ! Option provisoire ou le iflag_wb/10 est considere comme une vitesse + wbeff(il) = flag_wb*0.01+wbmax/(1.+500./(ph(il,1)-plfc(il))) + END IF + END IF + END DO + +!CR:Compute k at plfc + DO il=1,ncum + klfc(il)=nl + ENDDO + DO k=1,nl + DO il=1,ncum + if ((plfc(il).lt.ph(il,k)).and.(plfc(il).ge.ph(il,k+1))) then + klfc(il)=k + endif + ENDDO + ENDDO +!RC + +! JYCF2026/01/20 computing cbmf1, mass flux at cloud base coming +! from the ALP closure + + DO il = 1, ncum + ! jyg Modification du coef de wb*wb pour conformite avec papier Wake + ! c cbmf1(il) = alp2(il)/(0.5*wb*wb-Cin(il)) + cbmf1(il) = alp2(il)/(2.*wbeff(il)*wbeff(il)-cin(il)) +!CR: Add large-scale component to the mass-flux +!encore connu sous le nom "Experience du tube de dentifrice" + if ((coef_clos_ls.gt.0.).and.(plfc(il).gt.0.)) then + cbmf1(il) = cbmf1(il) - coef_clos_ls*min(0.,1./RG*omega(il,klfc(il))) + endif +!RC + IF (cbmf1(il)==0 .AND. alp2(il)/=0.) THEN + WRITE (lunout, *) 'cv3p1_closure cbmf1=0 and alp NE 0 il alp2 alp cin ' & + , il, alp2(il), alp(il), cin(il) + abort_message = '' + CALL abort_physic(modname, abort_message, 1) + END IF + cbmfmax(il) = sigmax*wb2(il)*100.*p(il, icb(il))/(rrd*tv(il,icb(il))) + END DO + +! JYCF2026/01/20 cbmf=cbmf1, coming from ALP closure + DO il = 1, ncum + IF (cbmflim(il)>1.E-6) THEN + ! ATTENTION TEST CR + ! if (cbmfmax(il).lt.1.e-12) then + cbmf(il) = min(cbmf1(il), cbmfmax(il)) + ! else + ! cbmf(il) = cbmf1(il) + ! endif + ! print*,'cbmf',cbmf1(il),cbmfmax(il) + END IF + END DO + IF (prt_level>=20) PRINT *, 'cv3p1_param apres cbmflim_testCR' + + ! c 2. Compute coefficient and apply correction + +! JYCF2026/01/20 coef : ratio of the ALP to the CAPE closure +! keeping the original ratio in coeftrue + + DO il = 1, ncum + coef(il) = (cbmf(il)+1.E-10)/(cbmflim(il)+1.E-10) + coeftrue(il) = coef(il) + END DO + IF (prt_level>=20) PRINT *, 'cv3p1_param apres coef_plantePLUS' + +! JYCF2026/01/20 : resumé +! computing siglim(k), the target value for sig(k) +! for the time relaxation +! mlim=rho*dp*siglim*wlim avec wlim=sqrt(cape) +! cbmflim=sum(mlim) +! computing cbmf, mass flux at cloud base from the ALP closure +! time relaxation on sig*w (in fact on "m") +! w is kept unchanged and sig is computed as sig*w/w +! +! coef=cbmf(ALP)/cbmflim(CAPE) sans relaxation +! + + +! JYCF2026/01/20 time relaxation on sig*w (in fact on "m") +! beta = 1.0 - delt / tau, in cv3_param +! w is kept unchanged and sig is computed as sig*w/w + + DO k = 1, nl + DO il = 1, ncum + IF (k>=icb(il)+1 .AND. k<=inb(il)) THEN + amu = beta*sig(il, k)*w0(il, k) + (1.-beta)*coef(il)*siglim(il, k)* & + wlim(il, k) + w0(il, k) = wlim(il, k) + w0(il, k) = max(w0(il,k), 1.E-10) + sig(il, k) = amu/w0(il, k) + sig(il, k) = min(sig(il,k), 1.) + ! c amu = 0.5*(SIG(il,k)+sigold(il,k))*W0(il,k) +! JYCF2026/01/20 0.007=2/R ? +! m=sig w rho delta(p) + m(il, k) = amu*0.007*p(il, k)*(ph(il,k)-ph(il,k+1))/tv(il, k) + END IF + END DO + END DO + ! jyg2 + DO il = 1, ncum + w0(il, icb(il)) = 0.5*w0(il, icb(il)+1) + m(il, icb(il)) = 0.5*m(il, icb(il)+1)*(ph(il,icb(il))-ph(il,icb(il)+1))/ & + (ph(il,icb(il)+1)-ph(il,icb(il)+2)) + sig(il, icb(il)) = sig(il, icb(il)+1) + sig(il, icb(il)-1) = sig(il, icb(il)) + END DO + IF (prt_level>=20) PRINT *, 'cv3p1_param apres w0_sig_M' + +!CR: new erosion of adiabatic ascent: modification of m +!computation of the sum of ascending fluxes + IF (iflag_mix_adiab.eq.1) THEN + ! + !Verification sum(me)=sum(m) + DO k = 1,nd !jyg: initialization up to nd + DO il = 1, ncum + md(il,k)=0. + med(il,k)=0. + ENDDO + ENDDO + ! + DO k = nl,1,-1 + DO il = 1, ncum + md(il,k)=md(il,k+1)+m(il,k+1) + ENDDO + ENDDO + ! + DO k = nl,1,-1 + DO il = 1, ncum + IF ((k>=(icb(il))) .AND. (k<=inb(il))) THEN + mad(il,k)=mad(il,k+1)+m(il,k+1) + ENDIF + ! print*,"mad",il,k,mad(il,k) + ENDDO + ENDDO + ! + !CR: erosion of each adiabatic ascent during its ascent + ! + !Computation of erosion coefficient beta_coef + DO k = 1, nl + DO il = 1, ncum + IF ((k>=(icb(il)+1)) .AND. (k<=inb(il)) .AND. (mlim(il,k).gt.0.)) THEN + ! print*,"beta_coef",il,k,icb(il),inb(il),buoy(il,k),tv(il,k),wlim(il,k),wlim(il,k+1) + beta_coef(il,k)=RG*coef_peel*buoy(il,k)/tv(il,k)/((wlim(il,k)+wlim(il,k+1))/2.)**2 + ELSE + beta_coef(il,k)=0. + ENDIF + ENDDO + ENDDO + ! + ! print*,"apres beta_coef" + ! + DO k = 1, nl + DO il = 1, ncum + ! + IF ((k>=(icb(il)+1)) .AND. (k<=inb(il))) THEN + ! + ! print*,"dz",il,k,tv(il, k-1) + dz = (ph(il,k-1)-ph(il,k))/(p(il, k-1)/(rrd*tv(il, k-1))*RG) + betalim(il,k)=betalim(il,k-1)*exp(-1.*beta_coef(il,k-1)*dz) + ! betalim(il,k)=betalim(il,k-1)*exp(-RG*coef_peel*buoy(il,k-1)/tv(il,k-1)/5.**2*dz) + ! print*,"me",il,k,mlim(il,k),buoy(il,k),wlim(il,k),mad(il,k) + dz = (ph(il,k)-ph(il,k+1))/(p(il, k)/(rrd*tv(il, k))*RG) + ! me(il,k)=betalim(il,k)*(m(il,k)+RG*coef_peel*buoy(il,k)/tv(il,k)/((wlim(il,k)+wlim(il,k+1))/2.)**2*dz*mad(il,k)) + me(il,k)=betalim(il,k)*(m(il,k)+beta_coef(il,k)*dz*mad(il,k)) + ! print*,"B/w2",il,k,RG*coef_peel*buoy(il,k)/tv(il,k)/((wlim(il,k)+wlim(il,k+1))/2.)**2*dz + ! + END IF + ! + !Modification of m + m(il,k)=me(il,k) + END DO + END DO + ! + ! DO il = 1, ncum + ! dz = (ph(il,icb(il))-ph(il,icb(il)+1))/(p(il, icb(il))/(rrd*tv(il, icb(il)))*RG) + ! m(il,icb(il))=m(il,icb(il))+RG*coef_peel*buoy(il,icb(il))/tv(il,icb(il)) & + ! /((wlim(il,icb(il))+wlim(il,icb(il)+1))/2.)**2*dz*mad(il,icb(il)) + ! print*,"wlim(icb)",icb(il),wlim(il,icb(il)),m(il,icb(il)) + ! ENDDO + ! + !Verification sum(me)=sum(m) + DO k = nl,1,-1 + DO il = 1, ncum + med(il,k)=med(il,k+1)+m(il,k+1) + ! print*,"somme(me),somme(m)",il,k,icb(il),med(il,k),md(il,k),me(il,k),m(il,k),wlim(il,k) + ENDDO + ENDDO + ! + ! + ENDIF !(iflag_mix_adiab) +!RC + + + + ! c 3. Compute final cloud base mass flux and set iflag to 3 if + ! c cloud base mass flux is exceedingly small and is decreasing (i.e. if + ! c the final mass flux (cbmflast) is greater than the target mass flux + ! c (cbmf)). + + DO il = 1, ncum + cbmflast(il) = 0. + END DO + + DO k = 1, nl + DO il = 1, ncum + IF (k>=icb(il) .AND. k<=inb(il)) THEN + !IMpropo?? IF ((k.ge.(icb(il)+1)).and.(k.le.inb(il))) THEN + cbmflast(il) = cbmflast(il) + m(il, k) + END IF + END DO + END DO + + DO il = 1, ncum + IF (cbmflast(il)<1.E-6 .AND. cbmflast(il)>=cbmf(il)) THEN + iflag(il) = 3 + END IF + END DO + + DO k = 1, nl + DO il = 1, ncum + IF (iflag(il)>=3) THEN + m(il, k) = 0. + sig(il, k) = 0. + w0(il, k) = 0. + END IF + END DO + END DO + IF (prt_level>=20) PRINT *, 'cv3p1_param apres iflag' + + ! c 4. Introduce a correcting factor for coef, in order to obtain an + ! effective sigdz larger in the present case (using cv3p1_closure) + ! than in the old + ! c closure (using cv3_closure). + IF (1==0) THEN + DO il = 1, ncum + ! c coef(il) = 2.*coef(il) + coef(il) = 5.*coef(il) + END DO + ! version CVS du ..2008 + ELSE + IF (iflag_cvl_sigd==0) THEN + ! test pour verifier qu on fait la meme chose qu avant: sid constant + coef(1:ncum) = 1. + ELSE + coef(1:ncum) = min(2.*coef(1:ncum), 5.) + coef(1:ncum) = max(2.*coef(1:ncum), 0.2) + END IF + END IF + + IF (prt_level>=20) PRINT *, 'cv3p1_param FIN' + RETURN +END SUBROUTINE cv3p1_closure + +END MODULE cv3p1_closure_mod + Index: LMDZ6/trunk/libf/phylmd/cv3p2_closure.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cv3p2_closure.f90 (revision 6047) +++ (revision ) @@ -1,884 +1,0 @@ -MODULE cv3p2_closure_mod - PRIVATE - - PUBLIC cv3p2_closure - -CONTAINS - -SUBROUTINE cv3p2_closure(nloc, ncum, nd, icb, inb, pbase, plcl, p, ph, tv, & - tvp, buoy, supmax, ok_inhib, ale, alp, omega,sig, w0, ptop2, cape, cin, m, & - iflag, coef, plim1, plim2, asupmax, supmax0, asupmaxmin, cbmflast, plfc, & - wbeff) - - - ! ************************************************************** - ! * - ! CV3P2_CLOSURE * - ! Ale & Alp Closure of Convect3 * - ! * - ! written by : Kerry Emanuel * - ! vectorization: S. Bony * - ! modified by : Jean-Yves Grandpeix, 18/06/2003, 19.32.10 * - ! Julie Frohwirth, 14/10/2005 17.44.22 * - ! ************************************************************** - - USE yomcst2_mod_h - USE lmdz_cv_ini, ONLY : alpha,alpha1,beta,flag_wb,minorig,nl,noconv_stop,pbcrit,rrd,wbmax,coef_peel - USE conema3_mod_h - USE cvflag_mod_h - USE print_control_mod, ONLY: prt_level, lunout - USE yomcst_mod_h - USE cv3_cine_mod, ONLY : cv3_cine - USE cv3_buoy_mod, ONLY : cv3_buoy -IMPLICIT NONE - - - - ! input: - INTEGER, INTENT (IN) :: ncum, nd, nloc - INTEGER, DIMENSION (nloc), INTENT (IN) :: icb, inb - REAL, DIMENSION (nloc), INTENT (IN) :: pbase, plcl - REAL, DIMENSION (nloc, nd), INTENT (IN) :: p - REAL, DIMENSION (nloc, nd+1), INTENT (IN) :: ph - REAL, DIMENSION (nloc, nd), INTENT (IN) :: tv, tvp, buoy - REAL, DIMENSION (nloc, nd), INTENT (IN) :: supmax - LOGICAL, INTENT (IN) :: ok_inhib ! enable convection inhibition by dryness - REAL, DIMENSION (nloc), INTENT (IN) :: ale, alp - REAL, DIMENSION (nloc, nd), INTENT (IN) :: omega - - ! input/output: - INTEGER, DIMENSION (nloc), INTENT (INOUT) :: iflag - REAL, DIMENSION (nloc, nd), INTENT (INOUT) :: sig, w0 - REAL, DIMENSION (nloc), INTENT (INOUT) :: ptop2 - - ! output: - REAL, DIMENSION (nloc), INTENT (OUT) :: cape, cin - REAL, DIMENSION (nloc, nd), INTENT (OUT) :: m - REAL, DIMENSION (nloc), INTENT (OUT) :: plim1, plim2 - REAL, DIMENSION (nloc, nd), INTENT (OUT) :: asupmax - REAL, DIMENSION (nloc), INTENT (OUT) :: supmax0 - REAL, DIMENSION (nloc), INTENT (OUT) :: asupmaxmin - REAL, DIMENSION (nloc), INTENT (OUT) :: cbmflast, plfc - REAL, DIMENSION (nloc), INTENT (OUT) :: wbeff - - ! local variables: - INTEGER :: il, i, j, k, icbmax - INTEGER, DIMENSION (nloc) :: i0, klfc - REAL :: deltap, fac, w, amu - REAL, DIMENSION (nloc, nd) :: rhodp ! Factor such that m=rhodp*sig*w - REAL :: dz - REAL :: pbmxup - REAL, DIMENSION (nloc, nd) :: dtmin, sigold - REAL, DIMENSION (nloc, nd) :: coefmix - REAL, DIMENSION (nloc) :: dtminmax - REAL, DIMENSION (nloc) :: pzero, ptop2old - REAL, DIMENSION (nloc) :: cina, cinb - INTEGER, DIMENSION (nloc) :: ibeg - INTEGER, DIMENSION (nloc) :: nsupmax - REAL :: supcrit - REAL, DIMENSION (nloc, nd) :: temp - REAL, DIMENSION (nloc) :: p1, pmin - REAL, DIMENSION (nloc) :: asupmax0 - LOGICAL, DIMENSION (nloc) :: ok - REAL, DIMENSION (nloc, nd) :: siglim, wlim, mlim - REAL, DIMENSION (nloc) :: wb2 - REAL, DIMENSION (nloc) :: cbmf0 ! initial cloud base mass flux - REAL, DIMENSION (nloc) :: cbmflim ! cbmf given by Cape closure - REAL, DIMENSION (nloc) :: cbmfalp ! cbmf given by Alp closure - REAL, DIMENSION (nloc) :: cbmfalpb ! bounded cbmf given by Alp closure - REAL, DIMENSION (nloc) :: cbmfmax ! upper bound on cbmf - REAL, DIMENSION (nloc) :: coef - REAL, DIMENSION (nloc) :: xp, xq, xr, discr, b3, b4 - REAL, DIMENSION (nloc) :: theta, bb - REAL :: term1, term2, term3 - REAL, DIMENSION (nloc) :: alp2 ! Alp with offset - -!CR: variables for new erosion of adiabiatic ascent - REAL, DIMENSION (nloc, nd) :: mad, me, betalim, beta_coef - REAL, DIMENSION (nloc, nd) :: med, md -!jyg< -! coef_peel is now in the common cv3_param -!! REAL :: coef_peel -!! PARAMETER (coef_peel=0.25) -!>jyg - - REAL :: sigmax - PARAMETER (sigmax=0.1) -!! PARAMETER (sigmax=10.) - - CHARACTER (LEN=20),PARAMETER :: modname = 'cv3p2_closure' - CHARACTER (LEN=80) :: abort_message - - INTEGER,PARAMETER :: igout=1 - - IF (prt_level>=20) print *,' -> cv3p2_closure, Ale ',ale(igout) - - - ! ------------------------------------------------------- - ! -- Initialization - ! ------------------------------------------------------- - - - DO il = 1, ncum - alp2(il) = max(alp(il), 1.E-5) - ! IM - alp2(il) = max(alp(il), 1.E-12) - END DO - - pbmxup = 50. ! PBMXUP+PBCRIT = cloud depth above which mixed updraughts - ! exist (if any) - - IF (prt_level>=20) PRINT *, 'cv3p2_closure nloc ncum nd icb inb nl', nloc, & - ncum, nd, icb(nloc), inb(nloc), nl - DO k = 1, nl - DO il = 1, ncum - rhodp(il,k) = 0.007*p(il, k)*(ph(il,k)-ph(il,k+1))/tv(il, k) - END DO - END DO - -!CR+jyg: initializations (up to nd) for erosion of adiabatic ascent and of m and wlim - DO k = 1,nd - DO il = 1, ncum - mad(il,k)=0. - me(il,k)=0. - betalim(il,k)=1. - wlim(il,k)=0. - m(il, k) = 0.0 - ENDDO - ENDDO - - ! ------------------------------------------------------- - ! -- Reset sig(i) and w0(i) for i>inb and i=(inb(il)+1))) THEN - sig(il, k) = beta*sig(il, k) + 2.*alpha*buoy(il, inb(il))*abs(buoy(il,inb(il))) - sig(il, k) = amax1(sig(il,k), 0.0) - w0(il, k) = beta*w0(il, k) - END IF - END DO - END DO - - ! if(prt.level.GE.20) print*,'cv3p2_closure apres 100' - ! compute icbmax: - -!ym break the column independance -!ym icbmax = 2 -!ym DO il = 1, ncum -!ym icbmax = max(icbmax, icb(il)) -!ym END DO - - ! if(prt.level.GE.20) print*,'cv3p2_closure apres 200' - - ! update sig and w0 below cloud base: - -!ym column independance -!ym DO k = 1, icbmax - DO k = 1, nd - DO il = 1, ncum - IF (k<=MAX(2,icb(il))) THEN - IF (k<=icb(il)) THEN - sig(il, k) = beta*sig(il, k) - 2.*alpha*buoy(il, icb(il))*buoy(il,icb(il)) - sig(il, k) = amax1(sig(il,k), 0.0) - w0(il, k) = beta*w0(il, k) - END IF - ENDIF - END DO - END DO - IF (prt_level>=20) PRINT *, 'cv3p2_closure apres 300' - - ! ------------------------------------------------------------- - ! -- Reset fractional areas of updrafts and w0 at initial time - ! -- and after 10 time steps of no convection - ! ------------------------------------------------------------- - -!jyg< - IF (ok_convstop) THEN - DO k = 1, nl - 1 - DO il = 1, ncum - IF (sig(il,nd)<1.5 .OR. sig(il,nd)>noconv_stop) THEN - sig(il, k) = 0.0 - w0(il, k) = 0.0 - END IF - END DO - END DO - ELSE - DO k = 1, nl - 1 - DO il = 1, ncum - IF (sig(il,nd)<1.5 .OR. sig(il,nd)>12.0) THEN - sig(il, k) = 0.0 - w0(il, k) = 0.0 - END IF - END DO - END DO - ENDIF ! (ok_convstop) -!>jyg - IF (prt_level>=20) PRINT *, 'cv3p2_closure apres 400' - - ! ------------------------------------------------------- - ! -- Compute initial cloud base mass flux (Cbmf0) - ! ------------------------------------------------------- - DO il = 1, ncum - cbmf0(il) = 0.0 - END DO - - DO k = 1, nl - DO il = 1, ncum - IF (k>=icb(il) .AND. k<=inb(il) & - .AND. icb(il)+1<=inb(il)) THEN - cbmf0(il) = cbmf0(il) + sig(il, k)*w0(il,k)*rhodp(il,k) - END IF - END DO - END DO - - ! ------------------------------------------------------------- - ! jyg1 - ! -- Calculate adiabatic ascent top pressure (ptop) - ! ------------------------------------------------------------- - - - ! c 1. Start at first level where precipitations form - DO il = 1, ncum - pzero(il) = plcl(il) - pbcrit - END DO - - ! c 2. Add offset - DO il = 1, ncum - pzero(il) = pzero(il) - pbmxup - END DO - DO il = 1, ncum - ptop2old(il) = ptop2(il) - END DO - - DO il = 1, ncum - ! CR:c est quoi ce 300?? - p1(il) = pzero(il) - 300. - END DO - - ! compute asupmax=abs(supmax) up to lnm+1 - - DO il = 1, ncum - ok(il) = .TRUE. - nsupmax(il) = inb(il) - END DO - - DO i = 1, nl - DO il = 1, ncum - IF (i>icb(il) .AND. i<=inb(il)) THEN - IF (p(il,i)<=pzero(il) .AND. supmax(il,i)<0 .AND. ok(il)) THEN - nsupmax(il) = i - ok(il) = .FALSE. - END IF ! end IF (P(i) ... ) - END IF ! end IF (icb+1 le i le inb) - END DO - END DO - - IF (prt_level>=20) PRINT *, 'cv3p2_closure apres 2.' - DO i = 1, nl - DO il = 1, ncum - asupmax(il, i) = abs(supmax(il,i)) - END DO - END DO - - - DO il = 1, ncum - asupmaxmin(il) = 10. - pmin(il) = 100. - ! IM ?? - asupmax0(il) = 0. - END DO - - ! c 3. Compute in which level is Pzero - - ! IM bug i0 = 18 - DO il = 1, ncum - i0(il) = nl - END DO - - DO i = 1, nl - DO il = 1, ncum - IF (i>icb(il) .AND. i<=inb(il)) THEN - IF (p(il,i)<=pzero(il) .AND. p(il,i)>=p1(il)) THEN - IF (pzero(il)>p(il,i) .AND. pzero(il)=20) PRINT *, 'cv3p2_closure apres 3.' - - ! c 4. Compute asupmax at Pzero - - DO i = 1, nl - DO il = 1, ncum - IF (i>icb(il) .AND. i<=inb(il)) THEN - IF (p(il,i)<=pzero(il) .AND. p(il,i)>=p1(il)) THEN - asupmax0(il) = ((pzero(il)-p(il,i0(il)-1))*asupmax(il,i0(il))- & - (pzero(il)-p(il,i0(il)))*asupmax(il,i0(il)-1))/(p(il,i0(il))-p(il,i0(il)-1)) - END IF - END IF - END DO - END DO - - - DO i = 1, nl - DO il = 1, ncum - IF (p(il,i)==pzero(il)) THEN - asupmax(i, il) = asupmax0(il) - END IF - END DO - END DO - IF (prt_level>=20) PRINT *, 'cv3p2_closure apres 4.' - - ! c 5. Compute asupmaxmin, minimum of asupmax - - DO i = 1, nl - DO il = 1, ncum - IF (i>icb(il) .AND. i<=inb(il)) THEN - IF (p(il,i)<=pzero(il) .AND. p(il,i)>=p1(il)) THEN - IF (asupmax(il,i)=20) THEN - PRINT *, 'cv3p2_closure il asupmax0 asupmaxmin', il, asupmax0(il), & - asupmaxmin(il), pzero(il), pmin(il) - END IF - IF (asupmax0(il)=20) PRINT *, 'cv3p2_closure apres 5.' - - - ! Compute Supmax at Pzero - - DO i = 1, nl - DO il = 1, ncum - IF (i>icb(il) .AND. i<=inb(il)) THEN - IF (p(il,i)<=pzero(il)) THEN - supmax0(il) = ((p(il,i)-pzero(il))*asupmax(il,i-1)- & - (p(il,i-1)-pzero(il))*asupmax(il,i))/(p(il,i)-p(il,i-1)) -!ym WARNING : probably bad GOTO branching ===> to check ! -!ym GO TO 425 - END IF ! end IF (P(i) ... ) - END IF ! end IF (icb+1 le i le inb) - END DO - END DO - -!ym bad branching -!ym 425 CONTINUE - IF (prt_level>=20) PRINT *, 'cv3p2_closure apres 425.' - - ! c 6. Calculate ptop2 - - DO il = 1, ncum - IF (asupmaxmin(il)supcrit1 .AND. asupmaxmin(il)supcrit2) THEN - ptop2(il) = ph(il, inb(il)) - END IF - END DO - - IF (prt_level>=20) PRINT *, 'cv3p2_closure apres 6.' - - ! c 7. Compute multiplying factor for adiabatic updraught mass flux - - - IF (ok_inhib) THEN - - DO i = 1, nl - DO il = 1, ncum - IF (i<=nl) THEN - coefmix(il, i) = (min(ptop2(il),ph(il,i))-ph(il,i))/(ph(il,i+1)-ph(il,i)) - coefmix(il, i) = min(coefmix(il,i), 1.) - END IF - END DO - END DO - - - ELSE ! when inhibition is not taken into account, coefmix=1 - - - - DO i = 1, nl - DO il = 1, ncum - IF (i<=nl) THEN - coefmix(il, i) = 1. - END IF - END DO - END DO - - END IF ! ok_inhib - IF (prt_level>=20) PRINT *, 'cv3p2_closure apres 7.' - ! ------------------------------------------------------------------- - ! ------------------------------------------------------------------- - - - ! jyg2 - - ! ========================================================================== - - - ! ------------------------------------------------------------- - ! -- Calculate convective inhibition (CIN) - ! ------------------------------------------------------------- - - ! do i=1,nloc - ! print*,'avant cine p',pbase(i),plcl(i) - ! enddo - ! do j=1,nd - ! do i=1,nloc - ! print*,'avant cine t',tv(i),tvp(i) - ! enddo - ! enddo - CALL cv3_cine(nloc, ncum, nd, icb, inb, pbase, plcl, p, ph, tv, tvp, cina, & - cinb, plfc) - - DO il = 1, ncum - cin(il) = cina(il) + cinb(il) - END DO - IF (prt_level>=20) PRINT *, 'cv3p2_closure after cv3_cine: cina, cinb, cin ', & - cina(igout), cinb(igout), cin(igout) - ! ------------------------------------------------------------- - ! --Update buoyancies to account for Ale - ! ------------------------------------------------------------- - - CALL cv3_buoy(nloc, ncum, nd, icb, inb, pbase, plcl, p, ph, ale, cin, tv, & - tvp, buoy) - IF (prt_level>=20) PRINT *, 'cv3p2_closure after cv3_buoy' - - ! ------------------------------------------------------------- - ! -- Calculate convective available potential energy (cape), - ! -- vertical velocity (w), fractional area covered by - ! -- undilute updraft (sig), and updraft mass flux (m) - ! ------------------------------------------------------------- - - DO il = 1, ncum - cape(il) = 0.0 - dtminmax(il) = -100. - END DO - - ! compute dtmin (minimum buoyancy between ICB and given level k): - - DO k = 1, nl - DO il = 1, ncum - dtmin(il, k) = 100.0 - END DO - END DO - - DO k = 1, nl - DO j = minorig, nl - DO il = 1, ncum - IF ((k>=(icb(il)+1)) .AND. (k<=inb(il)) .AND. (j>=icb(il)) & - .AND. (j<=(k-1))) THEN - dtmin(il, k) = amin1(dtmin(il,k), buoy(il,j)) - END IF - END DO - END DO - END DO -!jyg< -! Store maximum of dtmin -! C est pas terrible d avoir ce test sur Ale+Cin encore une fois ici. -! A REVOIR ! - DO k = 1, nl - DO il = 1, ncum - IF (k>=(icb(il)+1) .AND. k<=inb(il) .AND. ale(il)+cin(il)>0.) THEN - dtminmax(il) = max(dtmin(il,k), dtminmax(il)) - ENDIF - END DO - END DO -! -! prevent convection when ale+cin <= 0 - DO k = 1, nl - DO il = 1, ncum - IF (k>=(icb(il)+1) .AND. k<=inb(il)) THEN - dtmin(il,k) = min(dtmin(il,k), dtminmax(il)) - ENDIF - END DO - END DO -!>jyg -! - IF (prt_level >= 20) THEN - print *,'cv3p2_closure: dtmin ', (k, dtmin(igout,k), k=1,nl) - print *,'cv3p2_closure: dtminmax ', dtminmax(igout) - ENDIF -! - ! the interval on which cape is computed starts at pbase : - - DO k = 1, nl - DO il = 1, ncum - - IF ((k>=(icb(il)+1)) .AND. (k<=inb(il))) THEN - - IF (iflag_mix_adiab.eq.1) THEN -!CR:computation of cape from LCL: keep flag or to modify in all cases? - deltap = min(plcl(il), ph(il,k-1)) - min(plcl(il), ph(il,k)) - ELSE - deltap = min(pbase(il), ph(il,k-1)) - min(pbase(il), ph(il,k)) - ENDIF - cape(il) = cape(il) + rrd*buoy(il, k-1)*deltap/p(il, k-1) - cape(il) = amax1(0.0, cape(il)) - sigold(il, k) = sig(il, k) - - - ! jyg Coefficient coefmix limits convection to levels where a - ! sufficient - ! fraction of mixed draughts are ascending. - siglim(il, k) = coefmix(il, k)*alpha1*dtmin(il, k)*abs(dtmin(il,k)) - siglim(il, k) = amax1(siglim(il,k), 0.0) - siglim(il, k) = amin1(siglim(il,k), 0.01) - ! c fac=AMIN1(((dtcrit-dtmin(il,k))/dtcrit),1.0) - fac = 1. - wlim(il, k) = fac*sqrt(cape(il)) - amu = siglim(il, k)*wlim(il, k) -!! rhodp(il,k) = 0.007*p(il, k)*(ph(il,k)-ph(il,k+1))/tv(il, k) !cor jyg : computed earlier - mlim(il, k) = amu*rhodp(il,k) - ! print*, 'siglim ', k,siglim(1,k) - END IF - - END DO - END DO - IF (prt_level>=20) PRINT *, 'cv3p2_closure apres 600' - - DO il = 1, ncum - ! IM beg - IF (prt_level>=20) THEN - PRINT *, 'cv3p2_closure il icb mlim ph ph+1 ph+2', il, icb(il), & - mlim(il, icb(il)+1), ph(il, icb(il)), ph(il, icb(il)+1), & - ph(il, icb(il)+2) - END IF - - IF (icb(il)+1<=inb(il)) THEN - ! IM end - mlim(il, icb(il)) = 0.5*mlim(il,icb(il)+1)*(ph(il,icb(il))-ph(il,icb(il)+1))/ & - (ph(il,icb(il)+1)-ph(il,icb(il)+2)) - ! IM beg - END IF !(icb(il.le.inb(il))) then - ! IM end - END DO - IF (prt_level>=20) PRINT *, 'cv3p2_closure apres 700' - - ! - ! ------------------------------------------------------------------------ - ! c Compute Cloud base mass flux given by Cape closure (cbmflim = cbmf of - ! c elementary systems), cbmf given by Alp closure (cbmfalp), cbmf given by Alp - ! c closure with an upper bound imposed (cbmfalpb) and cbmf resulting from - ! c time integration (cbmflast). - ! ------------------------------------------------------------------------ - - DO il = 1, ncum - cbmflim(il) = 0. - cbmfalp(il) = 0. - cbmfalpb(il) = 0. - cbmflast(il) = 0. - END DO - - ! c 1. Compute cloud base mass flux of elementary system (Cbmflim) - - DO k = 1, nl - DO il = 1, ncum - ! old IF (k .ge. icb(il) .and. k .le. inb(il)) THEN - ! IM IF (k .ge. icb(il)+1 .and. k .le. inb(il)) THEN - IF (k>=icb(il) .AND. k<=inb(il) & !cor jyg - .AND. icb(il)+1<=inb(il)) THEN !cor jyg - cbmflim(il) = cbmflim(il) + mlim(il, k) - END IF - END DO - END DO - IF (prt_level>=20) PRINT *, 'cv3p2_closure after cbmflim: cbmflim ', cbmflim(igout) - - ! 1.5 Compute cloud base mass flux given by Alp closure (Cbmfalp), maximum - ! allowed mass flux (Cbmfmax) and bounded mass flux (Cbmfalpb) - ! Cbmfalpb is set to zero if Cbmflim (the mass flux of elementary cloud) - ! is exceedingly small. - - DO il = 1, ncum - wb2(il) = sqrt(2.*max(ale(il)+cin(il),0.)) - END DO - - DO il = 1, ncum - IF (plfc(il)<100.) THEN - ! This is an irealistic value for plfc => no calculation of wbeff - wbeff(il) = 100.1 - ELSE - ! Calculate wbeff - IF (NINT(flag_wb)==0) THEN - wbeff(il) = wbmax - ELSE IF (NINT(flag_wb)==1) THEN - wbeff(il) = wbmax/(1.+500./(ph(il,1)-plfc(il))) - ELSE IF (NINT(flag_wb)==2) THEN - wbeff(il) = wbmax*(0.01*(ph(il,1)-plfc(il)))**2 - END IF - END IF - END DO - -!CR:Compute k at plfc - DO il=1,ncum - klfc(il)=nl - ENDDO - DO k=1,nl - DO il=1,ncum - if ((plfc(il).lt.ph(il,k)).and.(plfc(il).ge.ph(il,k+1))) then - klfc(il)=k - endif - ENDDO - ENDDO -!RC - - DO il = 1, ncum - ! jyg Modification du coef de wb*wb pour conformite avec papier Wake - ! c cbmfalp(il) = alp2(il)/(0.5*wb*wb-Cin(il)) - cbmfalp(il) = alp2(il)/(2.*wbeff(il)*wbeff(il)-cin(il)) -!CR: Add large-scale component to the mass-flux -!encore connu sous le nom "Experience du tube de dentifrice" - if ((coef_clos_ls.gt.0.).and.(plfc(il).gt.0.)) then - cbmfalp(il) = cbmfalp(il) - coef_clos_ls*min(0.,1./RG*omega(il,klfc(il))) - endif -!RC - IF (cbmfalp(il)==0 .AND. alp2(il)/=0.) THEN - WRITE (lunout, *) 'cv3p2_closure cbmfalp=0 and alp NE 0 il alp2 alp cin ' , & - il, alp2(il), alp(il), cin(il) - abort_message = '' - CALL abort_physic(modname, abort_message, 1) - END IF - cbmfmax(il) = sigmax*wb2(il)*100.*p(il, icb(il))/(rrd*tv(il,icb(il))) - END DO - -!jyg< - IF (OK_intermittent) THEN - DO il = 1, ncum - IF (cbmflim(il)>1.E-6) THEN - cbmfalpb(il) = min(cbmfalp(il), (cbmfmax(il)-beta*cbmf0(il))/(1.-beta)) - ! print*,'cbmfalpb',cbmfalpb(il),cbmfmax(il) - END IF - END DO - ELSE -!>jyg - DO il = 1, ncum - IF (cbmflim(il)>1.E-6) THEN - ! ATTENTION TEST CR - ! if (cbmfmax(il).lt.1.e-12) then - cbmfalpb(il) = min(cbmfalp(il), cbmfmax(il)) - ! else - ! cbmfalpb(il) = cbmfalp(il) - ! endif - ! print*,'cbmfalpb',cbmfalp(il),cbmfmax(il) - END IF - END DO - ENDIF !(OK_intermittent) - IF (prt_level>=20) PRINT *, 'cv3p2_closure apres cbmfalpb: cbmfalpb ',cbmfalpb(igout) - - ! c 2. Compute coefficient and apply correction - - DO il = 1, ncum - coef(il) = (cbmfalpb(il)+1.E-10)/(cbmflim(il)+1.E-10) - END DO - IF (prt_level>=20) PRINT *, 'cv3p2_closure apres coef_plantePLUS' - - DO k = 1, nl - DO il = 1, ncum - IF (k>=icb(il)+1 .AND. k<=inb(il)) THEN - amu = beta*sig(il, k)*w0(il, k) + (1.-beta)*coef(il)*siglim(il, k)*wlim(il, k) - w0(il, k) = wlim(il, k) - w0(il, k) = max(w0(il,k), 1.E-10) - sig(il, k) = amu/w0(il, k) - sig(il, k) = min(sig(il,k), 1.) - ! c amu = 0.5*(SIG(il,k)+sigold(il,k))*W0(il,k) - !jyg m(il, k) = amu*0.007*p(il, k)*(ph(il,k)-ph(il,k+1))/tv(il, k) - m(il, k) = amu*rhodp(il,k) - END IF - END DO - END DO - ! jyg2 - DO il = 1, ncum - w0(il, icb(il)) = 0.5*w0(il, icb(il)+1) - m(il, icb(il)) = 0.5*m(il, icb(il)+1)*(ph(il,icb(il))-ph(il,icb(il)+1))/ & - (ph(il,icb(il)+1)-ph(il,icb(il)+2)) - sig(il, icb(il)) = sig(il, icb(il)+1) - sig(il, icb(il)-1) = sig(il, icb(il)) - END DO - IF (prt_level>=20) PRINT *, 'cv3p2_closure apres w0_sig_M: w0, sig ', & - (k,w0(igout,k),sig(igout,k), k=icb(igout),inb(igout)) - -!CR: new erosion of adiabatic ascent: modification of m -!computation of the sum of ascending fluxes - IF (iflag_mix_adiab.eq.1) THEN - -!Verification sum(me)=sum(m) - DO k = 1,nd - DO il = 1, ncum - md(il,k)=0. - med(il,k)=0. - ENDDO - ENDDO - - DO k = nl,1,-1 - DO il = 1, ncum - md(il,k)=md(il,k+1)+m(il,k+1) - ENDDO - ENDDO - - DO k = nl,1,-1 - DO il = 1, ncum - IF ((k>=(icb(il))) .AND. (k<=inb(il))) THEN - mad(il,k)=mad(il,k+1)+m(il,k+1) - ENDIF -! print*,"mad",il,k,mad(il,k) - ENDDO - ENDDO - -!CR: erosion of each adiabatic ascent during its ascent - -!Computation of erosion coefficient beta_coef - DO k = 1, nl - DO il = 1, ncum - IF ((k>=(icb(il)+1)) .AND. (k<=inb(il)) .AND. (mlim(il,k).gt.0.)) THEN -! print*,"beta_coef",il,k,icb(il),inb(il),buoy(il,k),tv(il,k),wlim(il,k),wlim(il,k+1) - beta_coef(il,k)=RG*coef_peel*buoy(il,k)/tv(il,k)/((wlim(il,k)+wlim(il,k+1))/2.)**2 - ELSE - beta_coef(il,k)=0. - ENDIF - ENDDO - ENDDO - -! print*,"apres beta_coef" - - DO k = 1, nl - DO il = 1, ncum - - IF ((k>=(icb(il)+1)) .AND. (k<=inb(il))) THEN - -! print*,"dz",il,k,tv(il, k-1) - dz = (ph(il,k-1)-ph(il,k))/(p(il, k-1)/(rrd*tv(il, k-1))*RG) - betalim(il,k)=betalim(il,k-1)*exp(-1.*beta_coef(il,k-1)*dz) -! betalim(il,k)=betalim(il,k-1)*exp(-RG*coef_peel*buoy(il,k-1)/tv(il,k-1)/5.**2*dz) -! print*,"me",il,k,mlim(il,k),buoy(il,k),wlim(il,k),mad(il,k) - dz = (ph(il,k)-ph(il,k+1))/(p(il, k)/(rrd*tv(il, k))*RG) -! me(il,k)=betalim(il,k)*(m(il,k)+RG*coef_peel*buoy(il,k)/tv(il,k)/((wlim(il,k)+wlim(il,k+1))/2.)**2*dz*mad(il,k)) - me(il,k)=betalim(il,k)*(m(il,k)+beta_coef(il,k)*dz*mad(il,k)) -! print*,"B/w2",il,k,RG*coef_peel*buoy(il,k)/tv(il,k)/((wlim(il,k)+wlim(il,k+1))/2.)**2*dz - - END IF - -!Modification of m - m(il,k)=me(il,k) - END DO - END DO - -! DO il = 1, ncum -! dz = (ph(il,icb(il))-ph(il,icb(il)+1))/(p(il, icb(il))/(rrd*tv(il, icb(il)))*RG) -! m(il,icb(il))=m(il,icb(il))+RG*coef_peel*buoy(il,icb(il))/tv(il,icb(il)) & -! /((wlim(il,icb(il))+wlim(il,icb(il)+1))/2.)**2*dz*mad(il,icb(il)) -! print*,"wlim(icb)",icb(il),wlim(il,icb(il)),m(il,icb(il)) -! ENDDO - -!Verification sum(me)=sum(m) - DO k = nl,1,-1 - DO il = 1, ncum - med(il,k)=med(il,k+1)+m(il,k+1) -! print*,"somme(me),somme(m)",il,k,icb(il),med(il,k),md(il,k),me(il,k),m(il,k),wlim(il,k) - ENDDO - ENDDO - - - ENDIF !(iflag_mix_adiab) -!RC - - ! c 3. Compute final cloud base mass flux; - ! c set iflag to 3 if cloud base mass flux is exceedingly small and is - ! c decreasing (i.e. if the final mass flux (cbmflast) is greater than - ! c the target mass flux (cbmfalpb)). - ! c If(ok_convstop): set iflag to 4 if no positive buoyancy has been met - -!jyg DO il = 1, ncum -!jyg cbmflast(il) = 0. -!jyg END DO - - DO k = 1, nl - DO il = 1, ncum - IF (k>=icb(il) .AND. k<=inb(il)) THEN - !IMpropo?? IF ((k.ge.(icb(il)+1)).and.(k.le.inb(il))) THEN - cbmflast(il) = cbmflast(il) + m(il, k) - END IF - END DO - END DO - IF (prt_level>=20) PRINT *, 'cv3p2_closure apres cbmflast: cbmflast ',cbmflast(igout) - - DO il = 1, ncum - IF (cbmflast(il)<1.E-6 .AND. cbmflast(il)>=cbmfalpb(il)) THEN - iflag(il) = 3 - END IF - END DO - -!jyg< - IF (ok_convstop) THEN - DO il = 1, ncum - IF (dtminmax(il) .LE. 0.) THEN - iflag(il) = 4 - END IF - END DO - ELSE -!>jyg - DO k = 1, nl - DO il = 1, ncum - IF (iflag(il)>=3) THEN - m(il, k) = 0. - sig(il, k) = 0. - w0(il, k) = 0. - END IF - END DO - END DO - ENDIF ! (ok_convstop) -! - IF (prt_level >= 10) THEN - print *,'cv3p2_closure: iflag ',iflag(igout) - ENDIF -! - - ! c 4. Introduce a correcting factor for coef, in order to obtain an - ! effective - ! c sigdz larger in the present case (using cv3p2_closure) than in the - ! old - ! c closure (using cv3_closure). - IF (1==0) THEN - DO il = 1, ncum - ! c coef(il) = 2.*coef(il) - coef(il) = 5.*coef(il) - END DO - ! version CVS du ..2008 - ELSE - IF (iflag_cvl_sigd==0) THEN - ! test pour verifier qu on fait la meme chose qu avant: sid constant - coef(1:ncum) = 1. - ELSE - coef(1:ncum) = min(2.*coef(1:ncum), 5.) - coef(1:ncum) = max(2.*coef(1:ncum), 0.2) - END IF - END IF - - IF (prt_level>=20) PRINT *, 'cv3p2_closure FIN' - RETURN -END SUBROUTINE cv3p2_closure - -END MODULE cv3p2_closure_mod - Index: LMDZ6/trunk/libf/phylmd/cv3p2_closure_mod.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cv3p2_closure_mod.f90 (revision 6048) +++ LMDZ6/trunk/libf/phylmd/cv3p2_closure_mod.f90 (revision 6048) @@ -0,0 +1,884 @@ +MODULE cv3p2_closure_mod + PRIVATE + + PUBLIC cv3p2_closure + +CONTAINS + +SUBROUTINE cv3p2_closure(nloc, ncum, nd, icb, inb, pbase, plcl, p, ph, tv, & + tvp, buoy, supmax, ok_inhib, ale, alp, omega,sig, w0, ptop2, cape, cin, m, & + iflag, coef, plim1, plim2, asupmax, supmax0, asupmaxmin, cbmflast, plfc, & + wbeff) + + + ! ************************************************************** + ! * + ! CV3P2_CLOSURE * + ! Ale & Alp Closure of Convect3 * + ! * + ! written by : Kerry Emanuel * + ! vectorization: S. Bony * + ! modified by : Jean-Yves Grandpeix, 18/06/2003, 19.32.10 * + ! Julie Frohwirth, 14/10/2005 17.44.22 * + ! ************************************************************** + + USE yomcst2_mod_h + USE lmdz_cv_ini, ONLY : alpha,alpha1,beta,flag_wb,minorig,nl,noconv_stop,pbcrit,rrd,wbmax,coef_peel + USE conema3_mod_h + USE cvflag_mod_h + USE print_control_mod, ONLY: prt_level, lunout + USE yomcst_mod_h + USE cv3_cine_mod, ONLY : cv3_cine + USE cv3_buoy_mod, ONLY : cv3_buoy +IMPLICIT NONE + + + + ! input: + INTEGER, INTENT (IN) :: ncum, nd, nloc + INTEGER, DIMENSION (nloc), INTENT (IN) :: icb, inb + REAL, DIMENSION (nloc), INTENT (IN) :: pbase, plcl + REAL, DIMENSION (nloc, nd), INTENT (IN) :: p + REAL, DIMENSION (nloc, nd+1), INTENT (IN) :: ph + REAL, DIMENSION (nloc, nd), INTENT (IN) :: tv, tvp, buoy + REAL, DIMENSION (nloc, nd), INTENT (IN) :: supmax + LOGICAL, INTENT (IN) :: ok_inhib ! enable convection inhibition by dryness + REAL, DIMENSION (nloc), INTENT (IN) :: ale, alp + REAL, DIMENSION (nloc, nd), INTENT (IN) :: omega + + ! input/output: + INTEGER, DIMENSION (nloc), INTENT (INOUT) :: iflag + REAL, DIMENSION (nloc, nd), INTENT (INOUT) :: sig, w0 + REAL, DIMENSION (nloc), INTENT (INOUT) :: ptop2 + + ! output: + REAL, DIMENSION (nloc), INTENT (OUT) :: cape, cin + REAL, DIMENSION (nloc, nd), INTENT (OUT) :: m + REAL, DIMENSION (nloc), INTENT (OUT) :: plim1, plim2 + REAL, DIMENSION (nloc, nd), INTENT (OUT) :: asupmax + REAL, DIMENSION (nloc), INTENT (OUT) :: supmax0 + REAL, DIMENSION (nloc), INTENT (OUT) :: asupmaxmin + REAL, DIMENSION (nloc), INTENT (OUT) :: cbmflast, plfc + REAL, DIMENSION (nloc), INTENT (OUT) :: wbeff + + ! local variables: + INTEGER :: il, i, j, k, icbmax + INTEGER, DIMENSION (nloc) :: i0, klfc + REAL :: deltap, fac, w, amu + REAL, DIMENSION (nloc, nd) :: rhodp ! Factor such that m=rhodp*sig*w + REAL :: dz + REAL :: pbmxup + REAL, DIMENSION (nloc, nd) :: dtmin, sigold + REAL, DIMENSION (nloc, nd) :: coefmix + REAL, DIMENSION (nloc) :: dtminmax + REAL, DIMENSION (nloc) :: pzero, ptop2old + REAL, DIMENSION (nloc) :: cina, cinb + INTEGER, DIMENSION (nloc) :: ibeg + INTEGER, DIMENSION (nloc) :: nsupmax + REAL :: supcrit + REAL, DIMENSION (nloc, nd) :: temp + REAL, DIMENSION (nloc) :: p1, pmin + REAL, DIMENSION (nloc) :: asupmax0 + LOGICAL, DIMENSION (nloc) :: ok + REAL, DIMENSION (nloc, nd) :: siglim, wlim, mlim + REAL, DIMENSION (nloc) :: wb2 + REAL, DIMENSION (nloc) :: cbmf0 ! initial cloud base mass flux + REAL, DIMENSION (nloc) :: cbmflim ! cbmf given by Cape closure + REAL, DIMENSION (nloc) :: cbmfalp ! cbmf given by Alp closure + REAL, DIMENSION (nloc) :: cbmfalpb ! bounded cbmf given by Alp closure + REAL, DIMENSION (nloc) :: cbmfmax ! upper bound on cbmf + REAL, DIMENSION (nloc) :: coef + REAL, DIMENSION (nloc) :: xp, xq, xr, discr, b3, b4 + REAL, DIMENSION (nloc) :: theta, bb + REAL :: term1, term2, term3 + REAL, DIMENSION (nloc) :: alp2 ! Alp with offset + +!CR: variables for new erosion of adiabiatic ascent + REAL, DIMENSION (nloc, nd) :: mad, me, betalim, beta_coef + REAL, DIMENSION (nloc, nd) :: med, md +!jyg< +! coef_peel is now in the common cv3_param +!! REAL :: coef_peel +!! PARAMETER (coef_peel=0.25) +!>jyg + + REAL :: sigmax + PARAMETER (sigmax=0.1) +!! PARAMETER (sigmax=10.) + + CHARACTER (LEN=20),PARAMETER :: modname = 'cv3p2_closure' + CHARACTER (LEN=80) :: abort_message + + INTEGER,PARAMETER :: igout=1 + + IF (prt_level>=20) print *,' -> cv3p2_closure, Ale ',ale(igout) + + + ! ------------------------------------------------------- + ! -- Initialization + ! ------------------------------------------------------- + + + DO il = 1, ncum + alp2(il) = max(alp(il), 1.E-5) + ! IM + alp2(il) = max(alp(il), 1.E-12) + END DO + + pbmxup = 50. ! PBMXUP+PBCRIT = cloud depth above which mixed updraughts + ! exist (if any) + + IF (prt_level>=20) PRINT *, 'cv3p2_closure nloc ncum nd icb inb nl', nloc, & + ncum, nd, icb(nloc), inb(nloc), nl + DO k = 1, nl + DO il = 1, ncum + rhodp(il,k) = 0.007*p(il, k)*(ph(il,k)-ph(il,k+1))/tv(il, k) + END DO + END DO + +!CR+jyg: initializations (up to nd) for erosion of adiabatic ascent and of m and wlim + DO k = 1,nd + DO il = 1, ncum + mad(il,k)=0. + me(il,k)=0. + betalim(il,k)=1. + wlim(il,k)=0. + m(il, k) = 0.0 + ENDDO + ENDDO + + ! ------------------------------------------------------- + ! -- Reset sig(i) and w0(i) for i>inb and i=(inb(il)+1))) THEN + sig(il, k) = beta*sig(il, k) + 2.*alpha*buoy(il, inb(il))*abs(buoy(il,inb(il))) + sig(il, k) = amax1(sig(il,k), 0.0) + w0(il, k) = beta*w0(il, k) + END IF + END DO + END DO + + ! if(prt.level.GE.20) print*,'cv3p2_closure apres 100' + ! compute icbmax: + +!ym break the column independance +!ym icbmax = 2 +!ym DO il = 1, ncum +!ym icbmax = max(icbmax, icb(il)) +!ym END DO + + ! if(prt.level.GE.20) print*,'cv3p2_closure apres 200' + + ! update sig and w0 below cloud base: + +!ym column independance +!ym DO k = 1, icbmax + DO k = 1, nd + DO il = 1, ncum + IF (k<=MAX(2,icb(il))) THEN + IF (k<=icb(il)) THEN + sig(il, k) = beta*sig(il, k) - 2.*alpha*buoy(il, icb(il))*buoy(il,icb(il)) + sig(il, k) = amax1(sig(il,k), 0.0) + w0(il, k) = beta*w0(il, k) + END IF + ENDIF + END DO + END DO + IF (prt_level>=20) PRINT *, 'cv3p2_closure apres 300' + + ! ------------------------------------------------------------- + ! -- Reset fractional areas of updrafts and w0 at initial time + ! -- and after 10 time steps of no convection + ! ------------------------------------------------------------- + +!jyg< + IF (ok_convstop) THEN + DO k = 1, nl - 1 + DO il = 1, ncum + IF (sig(il,nd)<1.5 .OR. sig(il,nd)>noconv_stop) THEN + sig(il, k) = 0.0 + w0(il, k) = 0.0 + END IF + END DO + END DO + ELSE + DO k = 1, nl - 1 + DO il = 1, ncum + IF (sig(il,nd)<1.5 .OR. sig(il,nd)>12.0) THEN + sig(il, k) = 0.0 + w0(il, k) = 0.0 + END IF + END DO + END DO + ENDIF ! (ok_convstop) +!>jyg + IF (prt_level>=20) PRINT *, 'cv3p2_closure apres 400' + + ! ------------------------------------------------------- + ! -- Compute initial cloud base mass flux (Cbmf0) + ! ------------------------------------------------------- + DO il = 1, ncum + cbmf0(il) = 0.0 + END DO + + DO k = 1, nl + DO il = 1, ncum + IF (k>=icb(il) .AND. k<=inb(il) & + .AND. icb(il)+1<=inb(il)) THEN + cbmf0(il) = cbmf0(il) + sig(il, k)*w0(il,k)*rhodp(il,k) + END IF + END DO + END DO + + ! ------------------------------------------------------------- + ! jyg1 + ! -- Calculate adiabatic ascent top pressure (ptop) + ! ------------------------------------------------------------- + + + ! c 1. Start at first level where precipitations form + DO il = 1, ncum + pzero(il) = plcl(il) - pbcrit + END DO + + ! c 2. Add offset + DO il = 1, ncum + pzero(il) = pzero(il) - pbmxup + END DO + DO il = 1, ncum + ptop2old(il) = ptop2(il) + END DO + + DO il = 1, ncum + ! CR:c est quoi ce 300?? + p1(il) = pzero(il) - 300. + END DO + + ! compute asupmax=abs(supmax) up to lnm+1 + + DO il = 1, ncum + ok(il) = .TRUE. + nsupmax(il) = inb(il) + END DO + + DO i = 1, nl + DO il = 1, ncum + IF (i>icb(il) .AND. i<=inb(il)) THEN + IF (p(il,i)<=pzero(il) .AND. supmax(il,i)<0 .AND. ok(il)) THEN + nsupmax(il) = i + ok(il) = .FALSE. + END IF ! end IF (P(i) ... ) + END IF ! end IF (icb+1 le i le inb) + END DO + END DO + + IF (prt_level>=20) PRINT *, 'cv3p2_closure apres 2.' + DO i = 1, nl + DO il = 1, ncum + asupmax(il, i) = abs(supmax(il,i)) + END DO + END DO + + + DO il = 1, ncum + asupmaxmin(il) = 10. + pmin(il) = 100. + ! IM ?? + asupmax0(il) = 0. + END DO + + ! c 3. Compute in which level is Pzero + + ! IM bug i0 = 18 + DO il = 1, ncum + i0(il) = nl + END DO + + DO i = 1, nl + DO il = 1, ncum + IF (i>icb(il) .AND. i<=inb(il)) THEN + IF (p(il,i)<=pzero(il) .AND. p(il,i)>=p1(il)) THEN + IF (pzero(il)>p(il,i) .AND. pzero(il)=20) PRINT *, 'cv3p2_closure apres 3.' + + ! c 4. Compute asupmax at Pzero + + DO i = 1, nl + DO il = 1, ncum + IF (i>icb(il) .AND. i<=inb(il)) THEN + IF (p(il,i)<=pzero(il) .AND. p(il,i)>=p1(il)) THEN + asupmax0(il) = ((pzero(il)-p(il,i0(il)-1))*asupmax(il,i0(il))- & + (pzero(il)-p(il,i0(il)))*asupmax(il,i0(il)-1))/(p(il,i0(il))-p(il,i0(il)-1)) + END IF + END IF + END DO + END DO + + + DO i = 1, nl + DO il = 1, ncum + IF (p(il,i)==pzero(il)) THEN + asupmax(i, il) = asupmax0(il) + END IF + END DO + END DO + IF (prt_level>=20) PRINT *, 'cv3p2_closure apres 4.' + + ! c 5. Compute asupmaxmin, minimum of asupmax + + DO i = 1, nl + DO il = 1, ncum + IF (i>icb(il) .AND. i<=inb(il)) THEN + IF (p(il,i)<=pzero(il) .AND. p(il,i)>=p1(il)) THEN + IF (asupmax(il,i)=20) THEN + PRINT *, 'cv3p2_closure il asupmax0 asupmaxmin', il, asupmax0(il), & + asupmaxmin(il), pzero(il), pmin(il) + END IF + IF (asupmax0(il)=20) PRINT *, 'cv3p2_closure apres 5.' + + + ! Compute Supmax at Pzero + + DO i = 1, nl + DO il = 1, ncum + IF (i>icb(il) .AND. i<=inb(il)) THEN + IF (p(il,i)<=pzero(il)) THEN + supmax0(il) = ((p(il,i)-pzero(il))*asupmax(il,i-1)- & + (p(il,i-1)-pzero(il))*asupmax(il,i))/(p(il,i)-p(il,i-1)) +!ym WARNING : probably bad GOTO branching ===> to check ! +!ym GO TO 425 + END IF ! end IF (P(i) ... ) + END IF ! end IF (icb+1 le i le inb) + END DO + END DO + +!ym bad branching +!ym 425 CONTINUE + IF (prt_level>=20) PRINT *, 'cv3p2_closure apres 425.' + + ! c 6. Calculate ptop2 + + DO il = 1, ncum + IF (asupmaxmin(il)supcrit1 .AND. asupmaxmin(il)supcrit2) THEN + ptop2(il) = ph(il, inb(il)) + END IF + END DO + + IF (prt_level>=20) PRINT *, 'cv3p2_closure apres 6.' + + ! c 7. Compute multiplying factor for adiabatic updraught mass flux + + + IF (ok_inhib) THEN + + DO i = 1, nl + DO il = 1, ncum + IF (i<=nl) THEN + coefmix(il, i) = (min(ptop2(il),ph(il,i))-ph(il,i))/(ph(il,i+1)-ph(il,i)) + coefmix(il, i) = min(coefmix(il,i), 1.) + END IF + END DO + END DO + + + ELSE ! when inhibition is not taken into account, coefmix=1 + + + + DO i = 1, nl + DO il = 1, ncum + IF (i<=nl) THEN + coefmix(il, i) = 1. + END IF + END DO + END DO + + END IF ! ok_inhib + IF (prt_level>=20) PRINT *, 'cv3p2_closure apres 7.' + ! ------------------------------------------------------------------- + ! ------------------------------------------------------------------- + + + ! jyg2 + + ! ========================================================================== + + + ! ------------------------------------------------------------- + ! -- Calculate convective inhibition (CIN) + ! ------------------------------------------------------------- + + ! do i=1,nloc + ! print*,'avant cine p',pbase(i),plcl(i) + ! enddo + ! do j=1,nd + ! do i=1,nloc + ! print*,'avant cine t',tv(i),tvp(i) + ! enddo + ! enddo + CALL cv3_cine(nloc, ncum, nd, icb, inb, pbase, plcl, p, ph, tv, tvp, cina, & + cinb, plfc) + + DO il = 1, ncum + cin(il) = cina(il) + cinb(il) + END DO + IF (prt_level>=20) PRINT *, 'cv3p2_closure after cv3_cine: cina, cinb, cin ', & + cina(igout), cinb(igout), cin(igout) + ! ------------------------------------------------------------- + ! --Update buoyancies to account for Ale + ! ------------------------------------------------------------- + + CALL cv3_buoy(nloc, ncum, nd, icb, inb, pbase, plcl, p, ph, ale, cin, tv, & + tvp, buoy) + IF (prt_level>=20) PRINT *, 'cv3p2_closure after cv3_buoy' + + ! ------------------------------------------------------------- + ! -- Calculate convective available potential energy (cape), + ! -- vertical velocity (w), fractional area covered by + ! -- undilute updraft (sig), and updraft mass flux (m) + ! ------------------------------------------------------------- + + DO il = 1, ncum + cape(il) = 0.0 + dtminmax(il) = -100. + END DO + + ! compute dtmin (minimum buoyancy between ICB and given level k): + + DO k = 1, nl + DO il = 1, ncum + dtmin(il, k) = 100.0 + END DO + END DO + + DO k = 1, nl + DO j = minorig, nl + DO il = 1, ncum + IF ((k>=(icb(il)+1)) .AND. (k<=inb(il)) .AND. (j>=icb(il)) & + .AND. (j<=(k-1))) THEN + dtmin(il, k) = amin1(dtmin(il,k), buoy(il,j)) + END IF + END DO + END DO + END DO +!jyg< +! Store maximum of dtmin +! C est pas terrible d avoir ce test sur Ale+Cin encore une fois ici. +! A REVOIR ! + DO k = 1, nl + DO il = 1, ncum + IF (k>=(icb(il)+1) .AND. k<=inb(il) .AND. ale(il)+cin(il)>0.) THEN + dtminmax(il) = max(dtmin(il,k), dtminmax(il)) + ENDIF + END DO + END DO +! +! prevent convection when ale+cin <= 0 + DO k = 1, nl + DO il = 1, ncum + IF (k>=(icb(il)+1) .AND. k<=inb(il)) THEN + dtmin(il,k) = min(dtmin(il,k), dtminmax(il)) + ENDIF + END DO + END DO +!>jyg +! + IF (prt_level >= 20) THEN + print *,'cv3p2_closure: dtmin ', (k, dtmin(igout,k), k=1,nl) + print *,'cv3p2_closure: dtminmax ', dtminmax(igout) + ENDIF +! + ! the interval on which cape is computed starts at pbase : + + DO k = 1, nl + DO il = 1, ncum + + IF ((k>=(icb(il)+1)) .AND. (k<=inb(il))) THEN + + IF (iflag_mix_adiab.eq.1) THEN +!CR:computation of cape from LCL: keep flag or to modify in all cases? + deltap = min(plcl(il), ph(il,k-1)) - min(plcl(il), ph(il,k)) + ELSE + deltap = min(pbase(il), ph(il,k-1)) - min(pbase(il), ph(il,k)) + ENDIF + cape(il) = cape(il) + rrd*buoy(il, k-1)*deltap/p(il, k-1) + cape(il) = amax1(0.0, cape(il)) + sigold(il, k) = sig(il, k) + + + ! jyg Coefficient coefmix limits convection to levels where a + ! sufficient + ! fraction of mixed draughts are ascending. + siglim(il, k) = coefmix(il, k)*alpha1*dtmin(il, k)*abs(dtmin(il,k)) + siglim(il, k) = amax1(siglim(il,k), 0.0) + siglim(il, k) = amin1(siglim(il,k), 0.01) + ! c fac=AMIN1(((dtcrit-dtmin(il,k))/dtcrit),1.0) + fac = 1. + wlim(il, k) = fac*sqrt(cape(il)) + amu = siglim(il, k)*wlim(il, k) +!! rhodp(il,k) = 0.007*p(il, k)*(ph(il,k)-ph(il,k+1))/tv(il, k) !cor jyg : computed earlier + mlim(il, k) = amu*rhodp(il,k) + ! print*, 'siglim ', k,siglim(1,k) + END IF + + END DO + END DO + IF (prt_level>=20) PRINT *, 'cv3p2_closure apres 600' + + DO il = 1, ncum + ! IM beg + IF (prt_level>=20) THEN + PRINT *, 'cv3p2_closure il icb mlim ph ph+1 ph+2', il, icb(il), & + mlim(il, icb(il)+1), ph(il, icb(il)), ph(il, icb(il)+1), & + ph(il, icb(il)+2) + END IF + + IF (icb(il)+1<=inb(il)) THEN + ! IM end + mlim(il, icb(il)) = 0.5*mlim(il,icb(il)+1)*(ph(il,icb(il))-ph(il,icb(il)+1))/ & + (ph(il,icb(il)+1)-ph(il,icb(il)+2)) + ! IM beg + END IF !(icb(il.le.inb(il))) then + ! IM end + END DO + IF (prt_level>=20) PRINT *, 'cv3p2_closure apres 700' + + ! + ! ------------------------------------------------------------------------ + ! c Compute Cloud base mass flux given by Cape closure (cbmflim = cbmf of + ! c elementary systems), cbmf given by Alp closure (cbmfalp), cbmf given by Alp + ! c closure with an upper bound imposed (cbmfalpb) and cbmf resulting from + ! c time integration (cbmflast). + ! ------------------------------------------------------------------------ + + DO il = 1, ncum + cbmflim(il) = 0. + cbmfalp(il) = 0. + cbmfalpb(il) = 0. + cbmflast(il) = 0. + END DO + + ! c 1. Compute cloud base mass flux of elementary system (Cbmflim) + + DO k = 1, nl + DO il = 1, ncum + ! old IF (k .ge. icb(il) .and. k .le. inb(il)) THEN + ! IM IF (k .ge. icb(il)+1 .and. k .le. inb(il)) THEN + IF (k>=icb(il) .AND. k<=inb(il) & !cor jyg + .AND. icb(il)+1<=inb(il)) THEN !cor jyg + cbmflim(il) = cbmflim(il) + mlim(il, k) + END IF + END DO + END DO + IF (prt_level>=20) PRINT *, 'cv3p2_closure after cbmflim: cbmflim ', cbmflim(igout) + + ! 1.5 Compute cloud base mass flux given by Alp closure (Cbmfalp), maximum + ! allowed mass flux (Cbmfmax) and bounded mass flux (Cbmfalpb) + ! Cbmfalpb is set to zero if Cbmflim (the mass flux of elementary cloud) + ! is exceedingly small. + + DO il = 1, ncum + wb2(il) = sqrt(2.*max(ale(il)+cin(il),0.)) + END DO + + DO il = 1, ncum + IF (plfc(il)<100.) THEN + ! This is an irealistic value for plfc => no calculation of wbeff + wbeff(il) = 100.1 + ELSE + ! Calculate wbeff + IF (NINT(flag_wb)==0) THEN + wbeff(il) = wbmax + ELSE IF (NINT(flag_wb)==1) THEN + wbeff(il) = wbmax/(1.+500./(ph(il,1)-plfc(il))) + ELSE IF (NINT(flag_wb)==2) THEN + wbeff(il) = wbmax*(0.01*(ph(il,1)-plfc(il)))**2 + END IF + END IF + END DO + +!CR:Compute k at plfc + DO il=1,ncum + klfc(il)=nl + ENDDO + DO k=1,nl + DO il=1,ncum + if ((plfc(il).lt.ph(il,k)).and.(plfc(il).ge.ph(il,k+1))) then + klfc(il)=k + endif + ENDDO + ENDDO +!RC + + DO il = 1, ncum + ! jyg Modification du coef de wb*wb pour conformite avec papier Wake + ! c cbmfalp(il) = alp2(il)/(0.5*wb*wb-Cin(il)) + cbmfalp(il) = alp2(il)/(2.*wbeff(il)*wbeff(il)-cin(il)) +!CR: Add large-scale component to the mass-flux +!encore connu sous le nom "Experience du tube de dentifrice" + if ((coef_clos_ls.gt.0.).and.(plfc(il).gt.0.)) then + cbmfalp(il) = cbmfalp(il) - coef_clos_ls*min(0.,1./RG*omega(il,klfc(il))) + endif +!RC + IF (cbmfalp(il)==0 .AND. alp2(il)/=0.) THEN + WRITE (lunout, *) 'cv3p2_closure cbmfalp=0 and alp NE 0 il alp2 alp cin ' , & + il, alp2(il), alp(il), cin(il) + abort_message = '' + CALL abort_physic(modname, abort_message, 1) + END IF + cbmfmax(il) = sigmax*wb2(il)*100.*p(il, icb(il))/(rrd*tv(il,icb(il))) + END DO + +!jyg< + IF (OK_intermittent) THEN + DO il = 1, ncum + IF (cbmflim(il)>1.E-6) THEN + cbmfalpb(il) = min(cbmfalp(il), (cbmfmax(il)-beta*cbmf0(il))/(1.-beta)) + ! print*,'cbmfalpb',cbmfalpb(il),cbmfmax(il) + END IF + END DO + ELSE +!>jyg + DO il = 1, ncum + IF (cbmflim(il)>1.E-6) THEN + ! ATTENTION TEST CR + ! if (cbmfmax(il).lt.1.e-12) then + cbmfalpb(il) = min(cbmfalp(il), cbmfmax(il)) + ! else + ! cbmfalpb(il) = cbmfalp(il) + ! endif + ! print*,'cbmfalpb',cbmfalp(il),cbmfmax(il) + END IF + END DO + ENDIF !(OK_intermittent) + IF (prt_level>=20) PRINT *, 'cv3p2_closure apres cbmfalpb: cbmfalpb ',cbmfalpb(igout) + + ! c 2. Compute coefficient and apply correction + + DO il = 1, ncum + coef(il) = (cbmfalpb(il)+1.E-10)/(cbmflim(il)+1.E-10) + END DO + IF (prt_level>=20) PRINT *, 'cv3p2_closure apres coef_plantePLUS' + + DO k = 1, nl + DO il = 1, ncum + IF (k>=icb(il)+1 .AND. k<=inb(il)) THEN + amu = beta*sig(il, k)*w0(il, k) + (1.-beta)*coef(il)*siglim(il, k)*wlim(il, k) + w0(il, k) = wlim(il, k) + w0(il, k) = max(w0(il,k), 1.E-10) + sig(il, k) = amu/w0(il, k) + sig(il, k) = min(sig(il,k), 1.) + ! c amu = 0.5*(SIG(il,k)+sigold(il,k))*W0(il,k) + !jyg m(il, k) = amu*0.007*p(il, k)*(ph(il,k)-ph(il,k+1))/tv(il, k) + m(il, k) = amu*rhodp(il,k) + END IF + END DO + END DO + ! jyg2 + DO il = 1, ncum + w0(il, icb(il)) = 0.5*w0(il, icb(il)+1) + m(il, icb(il)) = 0.5*m(il, icb(il)+1)*(ph(il,icb(il))-ph(il,icb(il)+1))/ & + (ph(il,icb(il)+1)-ph(il,icb(il)+2)) + sig(il, icb(il)) = sig(il, icb(il)+1) + sig(il, icb(il)-1) = sig(il, icb(il)) + END DO + IF (prt_level>=20) PRINT *, 'cv3p2_closure apres w0_sig_M: w0, sig ', & + (k,w0(igout,k),sig(igout,k), k=icb(igout),inb(igout)) + +!CR: new erosion of adiabatic ascent: modification of m +!computation of the sum of ascending fluxes + IF (iflag_mix_adiab.eq.1) THEN + +!Verification sum(me)=sum(m) + DO k = 1,nd + DO il = 1, ncum + md(il,k)=0. + med(il,k)=0. + ENDDO + ENDDO + + DO k = nl,1,-1 + DO il = 1, ncum + md(il,k)=md(il,k+1)+m(il,k+1) + ENDDO + ENDDO + + DO k = nl,1,-1 + DO il = 1, ncum + IF ((k>=(icb(il))) .AND. (k<=inb(il))) THEN + mad(il,k)=mad(il,k+1)+m(il,k+1) + ENDIF +! print*,"mad",il,k,mad(il,k) + ENDDO + ENDDO + +!CR: erosion of each adiabatic ascent during its ascent + +!Computation of erosion coefficient beta_coef + DO k = 1, nl + DO il = 1, ncum + IF ((k>=(icb(il)+1)) .AND. (k<=inb(il)) .AND. (mlim(il,k).gt.0.)) THEN +! print*,"beta_coef",il,k,icb(il),inb(il),buoy(il,k),tv(il,k),wlim(il,k),wlim(il,k+1) + beta_coef(il,k)=RG*coef_peel*buoy(il,k)/tv(il,k)/((wlim(il,k)+wlim(il,k+1))/2.)**2 + ELSE + beta_coef(il,k)=0. + ENDIF + ENDDO + ENDDO + +! print*,"apres beta_coef" + + DO k = 1, nl + DO il = 1, ncum + + IF ((k>=(icb(il)+1)) .AND. (k<=inb(il))) THEN + +! print*,"dz",il,k,tv(il, k-1) + dz = (ph(il,k-1)-ph(il,k))/(p(il, k-1)/(rrd*tv(il, k-1))*RG) + betalim(il,k)=betalim(il,k-1)*exp(-1.*beta_coef(il,k-1)*dz) +! betalim(il,k)=betalim(il,k-1)*exp(-RG*coef_peel*buoy(il,k-1)/tv(il,k-1)/5.**2*dz) +! print*,"me",il,k,mlim(il,k),buoy(il,k),wlim(il,k),mad(il,k) + dz = (ph(il,k)-ph(il,k+1))/(p(il, k)/(rrd*tv(il, k))*RG) +! me(il,k)=betalim(il,k)*(m(il,k)+RG*coef_peel*buoy(il,k)/tv(il,k)/((wlim(il,k)+wlim(il,k+1))/2.)**2*dz*mad(il,k)) + me(il,k)=betalim(il,k)*(m(il,k)+beta_coef(il,k)*dz*mad(il,k)) +! print*,"B/w2",il,k,RG*coef_peel*buoy(il,k)/tv(il,k)/((wlim(il,k)+wlim(il,k+1))/2.)**2*dz + + END IF + +!Modification of m + m(il,k)=me(il,k) + END DO + END DO + +! DO il = 1, ncum +! dz = (ph(il,icb(il))-ph(il,icb(il)+1))/(p(il, icb(il))/(rrd*tv(il, icb(il)))*RG) +! m(il,icb(il))=m(il,icb(il))+RG*coef_peel*buoy(il,icb(il))/tv(il,icb(il)) & +! /((wlim(il,icb(il))+wlim(il,icb(il)+1))/2.)**2*dz*mad(il,icb(il)) +! print*,"wlim(icb)",icb(il),wlim(il,icb(il)),m(il,icb(il)) +! ENDDO + +!Verification sum(me)=sum(m) + DO k = nl,1,-1 + DO il = 1, ncum + med(il,k)=med(il,k+1)+m(il,k+1) +! print*,"somme(me),somme(m)",il,k,icb(il),med(il,k),md(il,k),me(il,k),m(il,k),wlim(il,k) + ENDDO + ENDDO + + + ENDIF !(iflag_mix_adiab) +!RC + + ! c 3. Compute final cloud base mass flux; + ! c set iflag to 3 if cloud base mass flux is exceedingly small and is + ! c decreasing (i.e. if the final mass flux (cbmflast) is greater than + ! c the target mass flux (cbmfalpb)). + ! c If(ok_convstop): set iflag to 4 if no positive buoyancy has been met + +!jyg DO il = 1, ncum +!jyg cbmflast(il) = 0. +!jyg END DO + + DO k = 1, nl + DO il = 1, ncum + IF (k>=icb(il) .AND. k<=inb(il)) THEN + !IMpropo?? IF ((k.ge.(icb(il)+1)).and.(k.le.inb(il))) THEN + cbmflast(il) = cbmflast(il) + m(il, k) + END IF + END DO + END DO + IF (prt_level>=20) PRINT *, 'cv3p2_closure apres cbmflast: cbmflast ',cbmflast(igout) + + DO il = 1, ncum + IF (cbmflast(il)<1.E-6 .AND. cbmflast(il)>=cbmfalpb(il)) THEN + iflag(il) = 3 + END IF + END DO + +!jyg< + IF (ok_convstop) THEN + DO il = 1, ncum + IF (dtminmax(il) .LE. 0.) THEN + iflag(il) = 4 + END IF + END DO + ELSE +!>jyg + DO k = 1, nl + DO il = 1, ncum + IF (iflag(il)>=3) THEN + m(il, k) = 0. + sig(il, k) = 0. + w0(il, k) = 0. + END IF + END DO + END DO + ENDIF ! (ok_convstop) +! + IF (prt_level >= 10) THEN + print *,'cv3p2_closure: iflag ',iflag(igout) + ENDIF +! + + ! c 4. Introduce a correcting factor for coef, in order to obtain an + ! effective + ! c sigdz larger in the present case (using cv3p2_closure) than in the + ! old + ! c closure (using cv3_closure). + IF (1==0) THEN + DO il = 1, ncum + ! c coef(il) = 2.*coef(il) + coef(il) = 5.*coef(il) + END DO + ! version CVS du ..2008 + ELSE + IF (iflag_cvl_sigd==0) THEN + ! test pour verifier qu on fait la meme chose qu avant: sid constant + coef(1:ncum) = 1. + ELSE + coef(1:ncum) = min(2.*coef(1:ncum), 5.) + coef(1:ncum) = max(2.*coef(1:ncum), 0.2) + END IF + END IF + + IF (prt_level>=20) PRINT *, 'cv3p2_closure FIN' + RETURN +END SUBROUTINE cv3p2_closure + +END MODULE cv3p2_closure_mod + Index: LMDZ6/trunk/libf/phylmd/cv3p_mixing.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cv3p_mixing.f90 (revision 6047) +++ (revision ) @@ -1,654 +1,0 @@ -MODULE cv3p_mixing_mod - PRIVATE - PUBLIC cv3p_mixing -CONTAINS - -SUBROUTINE cv3p_mixing_pre - -END SUBROUTINE cv3p_mixing_pre - -!!SUBROUTINE cv3p_mixing(nloc, ncum, nd, na, ntra, icb, nk, inb, & !jyg: get rid of ntra -SUBROUTINE cv3p_mixing(nloc, ncum, nd, na, icb, nk, inb, & -!! ph, t, rr, rs, u, v, tra, h, lv, lf, frac, qta, & !jyg: get rid of ntra - ph, t, rr, rs, u, v, h, lv, lf, frac, qta, & - unk, vnk, hp, tv, tvp, ep, clw, sig, & - Ment, Qent, hent, uent, vent, nent, & -!! Sigij, elij, supmax, Ments, Qents, traent) !jyg: get rid of ntra -!! Sigij, elij, supmax, Ments, Qents) !jyg: get rid of ments - Sigij, elij, supmax) -! ************************************************************** -! * -! CV3P_MIXING : compute mixed draught properties and, * -! within a scaling factor, mixed draught * -! mass fluxes. * -! written by : VTJ Philips,JY Grandpeix, 21/05/2003, 09.14.15* -! modified by : * -! ************************************************************** - -USE yomcst2_mod_h, ONLY : Fmax, gammas, scut, qqa1, qqa2 - USE lmdz_cv_ini, ONLY : cpd,cpv,minorig,nl,rrv - USE cvflag_mod_h - USE print_control_mod, ONLY: mydebug=>debug , lunout, prt_level - USE ioipsl_getin_p_mod, ONLY: getin_p - USE add_phys_tend_mod, ONLY: fl_cor_ebil - - IMPLICIT NONE - - -!inputs: - INTEGER, INTENT (IN) :: ncum, nd, na -!! INTEGER, INTENT (IN) :: ntra, nloc !jyg: get rid of ntra - INTEGER, INTENT (IN) :: nloc - INTEGER, DIMENSION (nloc), INTENT (IN) :: icb, inb, nk - REAL, DIMENSION (nloc, nd), INTENT (IN) :: sig - REAL, DIMENSION (nloc), INTENT (IN) :: unk, vnk - REAL, DIMENSION (nloc, nd), INTENT (IN) :: qta - REAL, DIMENSION (nloc, nd+1), INTENT (IN) :: ph - REAL, DIMENSION (nloc, nd), INTENT (IN) :: t, rr, rs - REAL, DIMENSION (nloc, nd), INTENT (IN) :: u, v -!! REAL, DIMENSION (nloc, nd, ntra), INTENT (IN) :: tra ! input of convect3 !jyg: get rid of ntra - REAL, DIMENSION (nloc, na), INTENT (IN) :: lv - REAL, DIMENSION (nloc, na), INTENT (IN) :: lf - REAL, DIMENSION (nloc, na), INTENT (IN) :: frac !ice fraction in condensate - REAL, DIMENSION (nloc, na), INTENT (IN) :: h !liquid water static energy of environment - REAL, DIMENSION (nloc, na), INTENT (IN) :: hp !liquid water static energy of air shed from adiab. asc. - REAL, DIMENSION (nloc, na), INTENT (IN) :: tv, tvp - REAL, DIMENSION (nloc, na), INTENT (IN) :: ep, clw - -!outputs: - REAL, DIMENSION (nloc, na, na), INTENT (OUT) :: Ment, Qent - REAL, DIMENSION (nloc, na, na), INTENT (OUT) :: uent, vent - REAL, DIMENSION (nloc, na, na), INTENT (OUT) :: Sigij, elij - REAL, DIMENSION (nloc, na), INTENT (OUT) :: supmax ! Highest mixing fraction of mixed - ! updraughts with the sign of (h-hp) -!! REAL, DIMENSION (nloc, nd, nd, ntra), INTENT (OUT) :: traent !jyg: get rid of ntra -!! REAL, DIMENSION (nloc, nd, nd), INTENT (OUT) :: Ments, Qents !jyg: get rid of ments - REAL, DIMENSION (nloc, nd, nd), INTENT (OUT) :: hent - INTEGER, DIMENSION (nloc, nd), INTENT (OUT) :: nent - -!local variables: - INTEGER i, j, k, il, im, jm - INTEGER num1, num2 - REAL :: rti, bf2, anum, denom, dei, altem, cwat, stemp - REAL :: alt, delp, delm - REAL, DIMENSION (nloc) :: Qmixmax, Rmixmax, sqmrmax - REAL, DIMENSION (nloc) :: Qmixmin, Rmixmin, sqmrmin - REAL, DIMENSION (nloc) :: signhpmh - REAL, DIMENSION (nloc) :: Sx - REAL :: Scrit2 - REAL, DIMENSION (nloc) :: Smid, Sjmin, Sjmax - REAL, DIMENSION (nloc) :: Sbef, sup, smin - REAL, DIMENSION (nloc) :: ASij, ASij_inv, smax, Scrit - REAL, DIMENSION (nloc, nd, nd) :: Sij - REAL, DIMENSION (nloc, nd) :: csum - REAL :: awat - REAL :: cpm !Mixed draught heat capacity - REAL :: Tm !Mixed draught temperature - LOGICAL, DIMENSION (nloc) :: lwork - - REAL amxupcrit, df, ff - INTEGER nstep - - INTEGER,PARAMETER :: igout=1 - -! -- Mixing probability distribution functions - - REAL Qcoef1, Qcoef2, QFF, QFFF, Qmix, Rmix, Qmix1, Rmix1, Qmix2, Rmix2, F - REAL :: Qcoef1max,Qcoef2max !ym WARNING - !ym redefine local variable instead use module variable - !ym to check when refactoring deep convection - !ym => eliminate "first" SAVE variable - !ym probably all these folowing lines will be removed - Qcoef1(F) = tanh(F/gammas) - Qcoef2(F) = (tanh(F/gammas)+gammas*log(cosh((1.-F)/gammas)/cosh(F/gammas))) - QFF(F) = max(min(F,1.), 0.) - QFFf(F) = min(QFF(F), scut) - Qmix1(F) = (tanh((QFF(F)-Fmax)/gammas)+Qcoef1max)/Qcoef2max - Rmix1(F) = (gammas*log(cosh((QFF(F)-Fmax)/gammas))+QFF(F)*Qcoef1max)/Qcoef2max - Qmix2(F) = -log(1.-QFFf(F))/scut - Rmix2(F) = (QFFf(F)+(1.-QFF(F))*log(1.-QFFf(F)))/scut - Qmix(F) = qqa1*Qmix1(F) + qqa2*Qmix2(F) - Rmix(F) = qqa1*Rmix1(F) + qqa2*Rmix2(F) - - - -! ===================================================================== -! --- INITIALIZE VARIOUS ARRAYS USED IN THE COMPUTATIONS -! ===================================================================== - - Qcoef1max = Qcoef1(Fmax) - Qcoef2max = Qcoef2(Fmax) - -! ori do 360 i=1,ncum*nlp - DO j = 1, nl - DO il = 1, ncum - nent(il, j) = 0 -! in convect3, m is computed in cv3_closure -! ori m(i,1)=0.0 - END DO - END DO - -! ori do 400 k=1,nlp -! ori do 390 j=1,nlp - DO j = 1, nl - DO k = 1, nl - DO il = 1, ncum - Qent(il, k, j) = rr(il, j) - uent(il, k, j) = u(il, j) - vent(il, k, j) = v(il, j) - elij(il, k, j) = 0.0 - hent(il, k, j) = 0.0 -!AC! Ment(i,k,j)=0.0 -!AC! Sij(i,k,j)=0.0 - END DO - END DO - END DO - -!AC! - Ment(1:ncum, 1:nd, 1:nd) = 0.0 - Sij(1:ncum, 1:nd, 1:nd) = 0.0 -!AC! -!ym - Sigij(1:ncum, 1:nd, 1:nd) = 0.0 -!ym - -! ===================================================================== -! --- CALCULATE ENTRAINED AIR MASS FLUX (Ment), TOTAL WATER MIXING -! --- RATIO (QENT), TOTAL CONDENSED WATER (elij), AND MIXING -! --- FRACTION (Sij) -! ===================================================================== - - DO i = minorig + 1, nl - - IF (ok_entrain) THEN - DO j = minorig, nl - DO il = 1, ncum - IF ((i>=icb(il)) .AND. (i<=inb(il)) .AND. (j>=(icb(il)-1)) & - .AND. (j<=inb(il))) THEN - -!! rti = qnk(il) - ep(il, i)*clw(il, i) - rti = qta(il,i-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) -!jyg(from aj)< - IF (cvflag_ice) THEN -! print*,cvflag_ice,'cvflag_ice dans do 700' - IF (t(il,j)<=263.15) THEN - bf2 = 1. + (lf(il,j)+lv(il,j))*(lv(il,j)+frac(il,j)* & - lf(il,j))*rs(il, j)/(rrv*t(il,j)*t(il,j)*cpd) - END IF - END IF -!>jyg - 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)<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<0.0 .OR. stemp>1.0 .OR. altem>cwat) .AND. j>i) THEN -!jyg(from aj)< - IF (cvflag_ice) THEN - anum = anum - (lv(il,j)+frac(il,j)*lf(il,j))*(rti-rs(il,j)-cwat*bf2) - denom = denom + (lv(il,j)+frac(il,j)*lf(il,j))*(rr(il,i)-rti) - ELSE - anum = anum - lv(il, j)*(rti-rs(il,j)-cwat*bf2) - denom = denom + lv(il, j)*(rr(il,i)-rti) - END IF -!>jyg - IF (abs(denom)<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)>0.0) THEN -!!! Ment(il,i,j)=m(il,i) - Ment(il, i, j) = 1. - elij(il, i, j) = altem - elij(il, i, j) = amax1(0.0, elij(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)) - ELSE IF (j > i) THEN - IF (prt_level >= 10) THEN - print *,'cv3p_mixing i, j, Sij given by the no-precip eq. ', i, j, Sij(il,i,j) - ENDIF - END IF ! new - END DO - END DO - ELSE ! (ok_entrain) - DO il = 1,ncum - nent(il,i) = 0 - ENDDO - ENDIF ! (ok_entrain) - -!jygdebug< - IF (prt_level >= 10) THEN - print *,'cv3p_mixing i, nent(i), icb, inb ',i, nent(igout,i), icb(igout), inb(igout) - IF (nent(igout,i) .gt. 0) THEN - print *,'i,(j,Sij(i,j),j=icb-1,inb) ',i,(j,Sij(igout,i,j),j=icb(igout)-1,inb(igout)) - ENDIF - ENDIF -!>jygdebug - -! *** if no air can entrain at level i assume that updraft detrains *** -! *** at that level and calculate detrained air flux and properties *** - - -! @ do 170 i=icb(il),inb(il) - - DO il = 1, ncum - IF ((i>=icb(il)) .AND. (i<=inb(il)) .AND. (nent(il,i)==0)) THEN -! @ if(nent(il,i).eq.0)then -!!! Ment(il,i,i)=m(il,i) - Ment(il, i, i) = 1. -!! Qent(il, i, i) = qnk(il) - ep(il, i)*clw(il, i) - Qent(il, i, i) = qta(il,i-1) - ep(il, i)*clw(il, i) - uent(il, i, i) = unk(il) - vent(il, i, i) = vnk(il) - IF (fl_cor_ebil .GE. 2) THEN - hent(il, i, i) = hp(il,i) - ENDIF - elij(il, i, i) = clw(il, i)*(1.-ep(il,i)) - Sij(il, i, i) = 0.0 - END IF - END DO - END DO ! i = minorig + 1, nl - - DO j = minorig, nl - DO i = minorig, nl - DO il = 1, ncum - IF ((j>=(icb(il)-1)) .AND. (j<=inb(il)) .AND. & - (i>=icb(il)) .AND. (i<=inb(il))) THEN - Sigij(il, i, j) = Sij(il, i, j) - END IF - END DO - END DO - END DO -! @ enddo - -! @170 continue - -! ===================================================================== -! --- NORMALIZE ENTRAINED AIR MASS FLUXES -! --- TO REPRESENT EQUAL PROBABILITIES OF MIXING -! ===================================================================== - - csum(:,:) = 0. - - DO il = 1, ncum - lwork(il) = .FALSE. - END DO - -! --------------------------------------------------------------- - DO i = minorig + 1, nl !Loop on origin level "i" -! --------------------------------------------------------------- - - num1 = 0 - DO il = 1, ncum - IF (i>=icb(il) .AND. i<=inb(il)) num1 = num1 + 1 - END DO -!ym IF (num1<=0) GO TO 789 - IF (num1<=0) CYCLE - - -!JYG1 Find maximum of SIJ for J>I, if any. - - Sx(:) = 0. - - DO il = 1, ncum - IF (i>=icb(il) .AND. i<=inb(il)) THEN - signhpmh(il) = sign(1., hp(il,i)-h(il,i)) - Sbef(il) = max(0., signhpmh(il)) - END IF - END DO - - DO j = i + 1, nl - DO il = 1, ncum - IF (i>=icb(il) .AND. i<=inb(il) .AND. j<=inb(il)) THEN - IF (Sbef(il)=icb(il) .AND. i<=inb(il)) THEN - lwork(il) = (nent(il,i)/=0) -!! rti = qnk(il) - ep(il, i)*clw(il, i) - rti = qta(il,i-1) - ep(il, i)*clw(il, i) -!jyg< - IF (cvflag_ice) THEN - - anum = h(il, i) - hp(il, i) - (lv(il,i)+frac(il,i)*lf(il,i))* & - (rti-rs(il,i)) + (cpv-cpd)*t(il, i)*(rti-rr(il,i)) - denom = h(il, i) - hp(il, i) + (lv(il,i)+frac(il,i)*lf(il,i))* & - (rr(il,i)-rti) + (cpd-cpv)*t(il, i)*(rr(il,i)-rti) - ELSE - - anum = h(il, i) - hp(il, i) - lv(il, i)*(rti-rs(il,i)) + & - (cpv-cpd)*t(il, i)*(rti-rr(il,i)) - denom = h(il, i) - hp(il, i) + lv(il, i)*(rr(il,i)-rti) + & - (cpd-cpv)*t(il, i)*(rr(il,i)-rti) - END IF -!>jyg - IF (abs(denom)<0.01) denom = 0.01 - Scrit(il) = min(anum/denom, 1.) - alt = rti - rs(il, i) + Scrit(il)*(rr(il,i)-rti) - -!JYG1 Find new critical value Scrit2 -! such that : Sij > Scrit2 => mixed draught will detrain at J mixed draught will detrain at J>I - - Scrit2 = min(Scrit(il), Sx(il))*max(0., -signhpmh(il)) + & - Scrit(il)*max(0., signhpmh(il)) - - Scrit(il) = Scrit2 - -!JYG Correction pour la nouvelle logique; la correction pour ALT -! est un peu au hazard - IF (Scrit(il)<=0.0) Scrit(il) = 0.0 - IF (alt<=0.0) Scrit(il) = 1.0 - - smax(il) = 0.0 - ASij(il) = 0.0 - sup(il) = 0. ! upper S-value reached by descending draughts - END IF - END DO - -! --------------------------------------------------------------- - DO j = minorig, nl !Loop on destination level "j" -! --------------------------------------------------------------- - - num2 = 0 - DO il = 1, ncum - IF (i>=icb(il) .AND. i<=inb(il) .AND. & - j>=(icb(il)-1) .AND. j<=inb(il) .AND. & - lwork(il)) num2 = num2 + 1 - END DO -!ym IF (num2<=0) GO TO 175 - IF (num2<=0) CYCLE -! ----------------------------------------------- - IF (j>i) THEN -! ----------------------------------------------- - DO il = 1, ncum - IF (i>=icb(il) .AND. i<=inb(il) .AND. & - j>=(icb(il)-1) .AND. j<=inb(il) .AND. & - lwork(il)) THEN - IF (Sij(il,i,j)>0.0) THEN - Smid(il) = min(Sij(il,i,j), Scrit(il)) - Sjmax(il) = Smid(il) - Sjmin(il) = Smid(il) - IF (Smid(il)=icb(il) .AND. i<=inb(il) .AND. & - j>=(icb(il)-1) .AND. j<=inb(il) .AND. & - lwork(il)) THEN - IF (Sij(il,i,j)>0.0) THEN - Smid(il) = 1. - Sjmin(il) = max((Sij(il,i,j-1)+Smid(il))/2., Scrit(il))*max(0., -signhpmh(il)) + & - min((Sij(il,i,j+1)+Smid(il))/2., Scrit(il))*max(0., signhpmh(il)) - Sjmin(il) = max(Sjmin(il), sup(il)) - Sjmax(il) = 1. - -! - preparation des variables Scrit, Smin et Sbef pour la partie j>i - Scrit(il) = min(Sjmin(il), Sjmax(il), Scrit(il)) - - smin(il) = 1. - Sbef(il) = max(0., signhpmh(il)) - supmax(il, i) = sign(Scrit(il), -signhpmh(il)) - END IF - END IF - END DO -! ----------------------------------------------- - ELSE IF (j=icb(il) .AND. i<=inb(il) .AND. & - j>=(icb(il)-1) .AND. j<=inb(il) .AND. & - lwork(il)) THEN - IF (Sij(il,i,j)>0.0) THEN - Smid(il) = max(Sij(il,i,j), Scrit(il)) - Sjmax(il) = Smid(il) - Sjmin(il) = Smid(il) - IF (Smid(il)>smax(il) .AND. Sij(il,i,j+1)>Smid(il)) THEN - smax(il) = Smid(il) - Sjmax(il) = max((Sij(il,i,j+1)+Sij(il,i,j))/2., Sij(il,i,j)) - Sjmax(il) = max(Sjmax(il), Scrit(il)) - Sjmin(il) = min((Sbef(il)+Sij(il,i,j))/2., Sij(il,i,j)) - Sjmin(il) = max(Sjmin(il), Scrit(il)) - Sbef(il) = Sij(il, i, j) - END IF - IF (abs(Sjmin(il)-Sjmax(il))>1.E-10) & - sup(il) = max(Sjmin(il), Sjmax(il), sup(il)) - END IF - END IF - END DO -! ----------------------------------------------- - END IF -! ----------------------------------------------- - - - DO il = 1, ncum - IF (i>=icb(il) .AND. i<=inb(il) .AND. & - j>=(icb(il)-1) .AND. j<=inb(il) .AND. & - lwork(il)) THEN - IF (Sij(il,i,j)>0.0) THEN -!! rti = qnk(il) - ep(il, i)*clw(il, i) - rti = qta(il,i-1) - ep(il, i)*clw(il, i) - Qmixmax(il) = Qmix(Sjmax(il)) - Qmixmin(il) = Qmix(Sjmin(il)) - Rmixmax(il) = Rmix(Sjmax(il)) - Rmixmin(il) = Rmix(Sjmin(il)) - sqmrmax(il) = Sjmax(il)*Qmix(Sjmax(il)) - Rmix(Sjmax(il)) - sqmrmin(il) = Sjmin(il)*Qmix(Sjmin(il)) - Rmix(Sjmin(il)) - - Ment(il, i, j) = abs(Qmixmax(il)-Qmixmin(il))*Ment(il, i, j) - -! Sigij(i,j) is the 'true' mixing fraction of mixture Ment(i,j) - IF (abs(Qmixmax(il)-Qmixmin(il))>1.E-10) THEN - Sigij(il, i, j) = (sqmrmax(il)-sqmrmin(il))/(Qmixmax(il)-Qmixmin(il)) - ELSE - Sigij(il, i, j) = 0. - END IF - -! -- Compute Qent, uent, vent according to the true mixing fraction - Qent(il, i, j) = (1.-Sigij(il,i,j))*rti + Sigij(il, i, j)*rr(il, i) - uent(il, i, j) = (1.-Sigij(il,i,j))*unk(il) + Sigij(il, i, j)*u(il, i) - vent(il, i, j) = (1.-Sigij(il,i,j))*vnk(il) + Sigij(il, i, j)*v(il, i) - -! -- Compute liquid water static energy of mixed draughts -! IF (j .GT. i) THEN -! awat=elij(il,i,j)-(1.-ep(il,j))*clw(il,j) -! awat=amax1(awat,0.0) -! ELSE -! awat = 0. -! ENDIF -! Hent(il,i,j) = (1.-Sigij(il,i,j))*HP(il,i) -! : + Sigij(il,i,j)*H(il,i) -! : + (LV(il,j)+(cpd-cpv)*t(il,j))*awat -!IM 301008 beg - hent(il, i, j) = (1.-Sigij(il,i,j))*hp(il, i) + Sigij(il, i, j)*h(il, i) - -!jyg< -! elij(il, i, j) = Qent(il, i, j) - rs(il, j) -! elij(il, i, j) = elij(il, i, j) + & -! ((h(il,j)-hent(il,i,j))*rs(il,j)*lv(il,j) / & -! ((cpd*(1.-Qent(il,i,j))+Qent(il,i,j)*cpv)*rrv*t(il,j)*t(il,j))) -! elij(il, i, j) = elij(il, i, j) / & -! (1.+lv(il,j)*lv(il,j)*rs(il,j) / & -! ((cpd*(1.-Qent(il,i,j))+Qent(il,i,j)*cpv)*rrv*t(il,j)*t(il,j))) -! -! Computation of condensate amount Elij, taking into account the ice fraction frac -! Warning : the same saturation humidity rs is used over both liquid water and ice; this -! should be corrected. -! -! Heat capacity of mixed draught - cpm = cpd+Qent(il,i,j)*(cpv-cpd) -! - IF (cvflag_ice .and. frac(il,j) .gt. 0.) THEN - elij(il, i, j) = Qent(il, i, j) - rs(il, j) - elij(il, i, j) = elij(il, i, j) + & - (h(il,j)-hent(il,i,j)+(cpv-cpd)*(Qent(il,i,j)-rr(il,j))*t(il,j))* & - rs(il,j)*lv(il,j) / (cpm*rrv*t(il,j)*t(il,j)) - elij(il, i, j) = elij(il, i, j) / & - (1.+(lv(il,j)+frac(il,j)*lf(il,j))*lv(il,j)*rs(il,j) / & - (cpm*rrv*t(il,j)*t(il,j))) - ELSE - elij(il, i, j) = Qent(il, i, j) - rs(il, j) - elij(il, i, j) = elij(il, i, j) + & - (h(il,j)-hent(il,i,j)+(cpv-cpd)*(Qent(il,i,j)-rr(il,j))*t(il,j))* & - rs(il,j)*lv(il,j) / (cpm*rrv*t(il,j)*t(il,j)) - elij(il, i, j) = elij(il, i, j) / & - (1.+lv(il,j)*lv(il,j)*rs(il,j) / & - (cpm*rrv*t(il,j)*t(il,j))) - ENDIF -!>jyg - elij(il, i, j) = max(elij(il,i,j), 0.) - - elij(il, i, j) = min(elij(il,i,j), Qent(il,i,j)) - - IF (j>i) THEN - awat = elij(il, i, j) - (1.-ep(il,j))*clw(il, j) - awat = amax1(awat, 0.0) - ELSE - awat = 0. - END IF - -! print *,h(il,j)-hent(il,i,j),LV(il,j)*rs(il,j)/(cpd*rrv*t(il,j)* -! : t(il,j)) - -!jyg< -! hent(il, i, j) = hent(il, i, j) + (lv(il,j)+(cpd-cpv)*t(il,j))*awat -! Mixed draught temperature at level j - IF (cvflag_ice .and. frac(il,j) .gt. 0.) THEN - Tm = t(il,j) + (Qent(il,i,j)-elij(il,i,j)-rs(il,j))*rrv*t(il,j)*t(il,j)/(lv(il,j)*rs(il,j)) - hent(il, i, j) = hent(il, i, j) + (lv(il,j)+frac(il,j)*lf(il,j)+(cpd-cpv)*Tm)*awat - ELSE - Tm = t(il,j) + (Qent(il,i,j)-elij(il,i,j)-rs(il,j))*rrv*t(il,j)*t(il,j)/(lv(il,j)*rs(il,j)) - hent(il, i, j) = hent(il, i, j) + (lv(il,j)+(cpd-cpv)*Tm)*awat - ENDIF -!>jyg - -!IM 301008 end - -! print *,'mix : i,j,hent(il,i,j),Sigij(il,i,j) ', -! : i,j,hent(il,i,j),Sigij(il,i,j) - -! -- ASij is the integral of P(F) over the relevant F interval - ASij(il) = ASij(il) + abs(Qmixmax(il)*(1.-Sjmax(il))+Rmixmax(il) - & - Qmixmin(il)*(1.-Sjmin(il))-Rmixmin(il)) - - END IF - END IF - END DO - -! -- If I=J (detrainement and entrainement at the same level), then only the -! -- adiabatic ascent part of the mixture is considered - IF (i==j) THEN - DO il = 1, ncum - IF (i>=icb(il) .AND. i<=inb(il) .AND. & - j>=(icb(il)-1) .AND. j<=inb(il) .AND. & - lwork(il)) THEN - IF (Sij(il,i,j)>0.0) THEN -!! rti = qnk(il) - ep(il, i)*clw(il, i) - rti = qta(il,i-1) - ep(il, i)*clw(il, i) -!!! Ment(il,i,i) = m(il,i)*abs(Qmixmax(il)*(1.-Sjmax(il)) - Ment(il, i, i) = abs(Qmixmax(il)*(1.-Sjmax(il))+Rmixmax(il) - & - Qmixmin(il)*(1.-Sjmin(il))-Rmixmin(il)) - Qent(il, i, i) = rti - uent(il, i, i) = unk(il) - vent(il, i, i) = vnk(il) - hent(il, i, i) = hp(il, i) - elij(il, i, i) = clw(il, i)*(1.-ep(il,i)) - Sigij(il, i, i) = 0. - END IF - END IF - END DO - END IF !(i==j) - -! --------------------------------------------------------------- - END DO !ym label 175 ! End loop on destination level "j" -! --------------------------------------------------------------- - - DO il = 1, ncum - IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il)) THEN - ASij(il) = amax1(1.0E-16, ASij(il)) -!jyg+lluis< -!! ASij(il) = 1.0/ASij(il) - ASij_inv(il) = 1.0/ASij(il) -! IF the F-interval spanned by possible mixtures is less than 0.01, no mixing occurs - IF (ASij_inv(il) > 100.) ASij_inv(il) = 0. -!>jyg+lluis - csum(il, i) = 0.0 - END IF - END DO - - DO j = minorig, nl - DO il = 1, ncum - IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il) .AND. & - j>=(icb(il)-1) .AND. j<=inb(il)) THEN -!jyg Ment(il, i, j) = Ment(il, i, j)*ASij(il) - Ment(il, i, j) = Ment(il, i, j)*ASij_inv(il) - END IF - END DO - END DO - - DO j = minorig, nl - DO il = 1, ncum - IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il) .AND. & - j>=(icb(il)-1) .AND. j<=inb(il)) THEN - csum(il, i) = csum(il, i) + Ment(il, i, j) - END IF - END DO - END DO - - DO il = 1, ncum - IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il) .AND. csum(il,i)<1.) THEN -! cc : .and. csum(il,i).lt.m(il,i) ) then - nent(il, i) = 0 -! cc Ment(il,i,i)=m(il,i) - Ment(il, i, i) = 1. -!! Qent(il, i, i) = qnk(il) - ep(il, i)*clw(il, i) - Qent(il, i, i) = qta(il,i-1) - ep(il, i)*clw(il, i) - uent(il, i, i) = unk(il) - vent(il, i, i) = vnk(il) - elij(il, i, i) = clw(il, i)*(1.-ep(il,i)) - IF (fl_cor_ebil .GE. 2) THEN - hent(il, i, i) = hp(il,i) - Sigij(il, i, i) = 0.0 - ELSE - Sij(il, i, i) = 0.0 - ENDIF - END IF - END DO ! il - -! --------------------------------------------------------------- -END DO !ym label 789 ! End loop on origin level "i" - -! --------------------------------------------------------------- - - - RETURN -END SUBROUTINE cv3p_mixing - -END MODULE cv3p_mixing_mod Index: LMDZ6/trunk/libf/phylmd/cv3p_mixing_mod.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cv3p_mixing_mod.f90 (revision 6048) +++ LMDZ6/trunk/libf/phylmd/cv3p_mixing_mod.f90 (revision 6048) @@ -0,0 +1,654 @@ +MODULE cv3p_mixing_mod + PRIVATE + PUBLIC cv3p_mixing +CONTAINS + +SUBROUTINE cv3p_mixing_pre + +END SUBROUTINE cv3p_mixing_pre + +!!SUBROUTINE cv3p_mixing(nloc, ncum, nd, na, ntra, icb, nk, inb, & !jyg: get rid of ntra +SUBROUTINE cv3p_mixing(nloc, ncum, nd, na, icb, nk, inb, & +!! ph, t, rr, rs, u, v, tra, h, lv, lf, frac, qta, & !jyg: get rid of ntra + ph, t, rr, rs, u, v, h, lv, lf, frac, qta, & + unk, vnk, hp, tv, tvp, ep, clw, sig, & + Ment, Qent, hent, uent, vent, nent, & +!! Sigij, elij, supmax, Ments, Qents, traent) !jyg: get rid of ntra +!! Sigij, elij, supmax, Ments, Qents) !jyg: get rid of ments + Sigij, elij, supmax) +! ************************************************************** +! * +! CV3P_MIXING : compute mixed draught properties and, * +! within a scaling factor, mixed draught * +! mass fluxes. * +! written by : VTJ Philips,JY Grandpeix, 21/05/2003, 09.14.15* +! modified by : * +! ************************************************************** + +USE yomcst2_mod_h, ONLY : Fmax, gammas, scut, qqa1, qqa2 + USE lmdz_cv_ini, ONLY : cpd,cpv,minorig,nl,rrv + USE cvflag_mod_h + USE print_control_mod, ONLY: mydebug=>debug , lunout, prt_level + USE ioipsl_getin_p_mod, ONLY: getin_p + USE add_phys_tend_mod, ONLY: fl_cor_ebil + + IMPLICIT NONE + + +!inputs: + INTEGER, INTENT (IN) :: ncum, nd, na +!! INTEGER, INTENT (IN) :: ntra, nloc !jyg: get rid of ntra + INTEGER, INTENT (IN) :: nloc + INTEGER, DIMENSION (nloc), INTENT (IN) :: icb, inb, nk + REAL, DIMENSION (nloc, nd), INTENT (IN) :: sig + REAL, DIMENSION (nloc), INTENT (IN) :: unk, vnk + REAL, DIMENSION (nloc, nd), INTENT (IN) :: qta + REAL, DIMENSION (nloc, nd+1), INTENT (IN) :: ph + REAL, DIMENSION (nloc, nd), INTENT (IN) :: t, rr, rs + REAL, DIMENSION (nloc, nd), INTENT (IN) :: u, v +!! REAL, DIMENSION (nloc, nd, ntra), INTENT (IN) :: tra ! input of convect3 !jyg: get rid of ntra + REAL, DIMENSION (nloc, na), INTENT (IN) :: lv + REAL, DIMENSION (nloc, na), INTENT (IN) :: lf + REAL, DIMENSION (nloc, na), INTENT (IN) :: frac !ice fraction in condensate + REAL, DIMENSION (nloc, na), INTENT (IN) :: h !liquid water static energy of environment + REAL, DIMENSION (nloc, na), INTENT (IN) :: hp !liquid water static energy of air shed from adiab. asc. + REAL, DIMENSION (nloc, na), INTENT (IN) :: tv, tvp + REAL, DIMENSION (nloc, na), INTENT (IN) :: ep, clw + +!outputs: + REAL, DIMENSION (nloc, na, na), INTENT (OUT) :: Ment, Qent + REAL, DIMENSION (nloc, na, na), INTENT (OUT) :: uent, vent + REAL, DIMENSION (nloc, na, na), INTENT (OUT) :: Sigij, elij + REAL, DIMENSION (nloc, na), INTENT (OUT) :: supmax ! Highest mixing fraction of mixed + ! updraughts with the sign of (h-hp) +!! REAL, DIMENSION (nloc, nd, nd, ntra), INTENT (OUT) :: traent !jyg: get rid of ntra +!! REAL, DIMENSION (nloc, nd, nd), INTENT (OUT) :: Ments, Qents !jyg: get rid of ments + REAL, DIMENSION (nloc, nd, nd), INTENT (OUT) :: hent + INTEGER, DIMENSION (nloc, nd), INTENT (OUT) :: nent + +!local variables: + INTEGER i, j, k, il, im, jm + INTEGER num1, num2 + REAL :: rti, bf2, anum, denom, dei, altem, cwat, stemp + REAL :: alt, delp, delm + REAL, DIMENSION (nloc) :: Qmixmax, Rmixmax, sqmrmax + REAL, DIMENSION (nloc) :: Qmixmin, Rmixmin, sqmrmin + REAL, DIMENSION (nloc) :: signhpmh + REAL, DIMENSION (nloc) :: Sx + REAL :: Scrit2 + REAL, DIMENSION (nloc) :: Smid, Sjmin, Sjmax + REAL, DIMENSION (nloc) :: Sbef, sup, smin + REAL, DIMENSION (nloc) :: ASij, ASij_inv, smax, Scrit + REAL, DIMENSION (nloc, nd, nd) :: Sij + REAL, DIMENSION (nloc, nd) :: csum + REAL :: awat + REAL :: cpm !Mixed draught heat capacity + REAL :: Tm !Mixed draught temperature + LOGICAL, DIMENSION (nloc) :: lwork + + REAL amxupcrit, df, ff + INTEGER nstep + + INTEGER,PARAMETER :: igout=1 + +! -- Mixing probability distribution functions + + REAL Qcoef1, Qcoef2, QFF, QFFF, Qmix, Rmix, Qmix1, Rmix1, Qmix2, Rmix2, F + REAL :: Qcoef1max,Qcoef2max !ym WARNING + !ym redefine local variable instead use module variable + !ym to check when refactoring deep convection + !ym => eliminate "first" SAVE variable + !ym probably all these folowing lines will be removed + Qcoef1(F) = tanh(F/gammas) + Qcoef2(F) = (tanh(F/gammas)+gammas*log(cosh((1.-F)/gammas)/cosh(F/gammas))) + QFF(F) = max(min(F,1.), 0.) + QFFf(F) = min(QFF(F), scut) + Qmix1(F) = (tanh((QFF(F)-Fmax)/gammas)+Qcoef1max)/Qcoef2max + Rmix1(F) = (gammas*log(cosh((QFF(F)-Fmax)/gammas))+QFF(F)*Qcoef1max)/Qcoef2max + Qmix2(F) = -log(1.-QFFf(F))/scut + Rmix2(F) = (QFFf(F)+(1.-QFF(F))*log(1.-QFFf(F)))/scut + Qmix(F) = qqa1*Qmix1(F) + qqa2*Qmix2(F) + Rmix(F) = qqa1*Rmix1(F) + qqa2*Rmix2(F) + + + +! ===================================================================== +! --- INITIALIZE VARIOUS ARRAYS USED IN THE COMPUTATIONS +! ===================================================================== + + Qcoef1max = Qcoef1(Fmax) + Qcoef2max = Qcoef2(Fmax) + +! ori do 360 i=1,ncum*nlp + DO j = 1, nl + DO il = 1, ncum + nent(il, j) = 0 +! in convect3, m is computed in cv3_closure +! ori m(i,1)=0.0 + END DO + END DO + +! ori do 400 k=1,nlp +! ori do 390 j=1,nlp + DO j = 1, nl + DO k = 1, nl + DO il = 1, ncum + Qent(il, k, j) = rr(il, j) + uent(il, k, j) = u(il, j) + vent(il, k, j) = v(il, j) + elij(il, k, j) = 0.0 + hent(il, k, j) = 0.0 +!AC! Ment(i,k,j)=0.0 +!AC! Sij(i,k,j)=0.0 + END DO + END DO + END DO + +!AC! + Ment(1:ncum, 1:nd, 1:nd) = 0.0 + Sij(1:ncum, 1:nd, 1:nd) = 0.0 +!AC! +!ym + Sigij(1:ncum, 1:nd, 1:nd) = 0.0 +!ym + +! ===================================================================== +! --- CALCULATE ENTRAINED AIR MASS FLUX (Ment), TOTAL WATER MIXING +! --- RATIO (QENT), TOTAL CONDENSED WATER (elij), AND MIXING +! --- FRACTION (Sij) +! ===================================================================== + + DO i = minorig + 1, nl + + IF (ok_entrain) THEN + DO j = minorig, nl + DO il = 1, ncum + IF ((i>=icb(il)) .AND. (i<=inb(il)) .AND. (j>=(icb(il)-1)) & + .AND. (j<=inb(il))) THEN + +!! rti = qnk(il) - ep(il, i)*clw(il, i) + rti = qta(il,i-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) +!jyg(from aj)< + IF (cvflag_ice) THEN +! print*,cvflag_ice,'cvflag_ice dans do 700' + IF (t(il,j)<=263.15) THEN + bf2 = 1. + (lf(il,j)+lv(il,j))*(lv(il,j)+frac(il,j)* & + lf(il,j))*rs(il, j)/(rrv*t(il,j)*t(il,j)*cpd) + END IF + END IF +!>jyg + 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)<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<0.0 .OR. stemp>1.0 .OR. altem>cwat) .AND. j>i) THEN +!jyg(from aj)< + IF (cvflag_ice) THEN + anum = anum - (lv(il,j)+frac(il,j)*lf(il,j))*(rti-rs(il,j)-cwat*bf2) + denom = denom + (lv(il,j)+frac(il,j)*lf(il,j))*(rr(il,i)-rti) + ELSE + anum = anum - lv(il, j)*(rti-rs(il,j)-cwat*bf2) + denom = denom + lv(il, j)*(rr(il,i)-rti) + END IF +!>jyg + IF (abs(denom)<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)>0.0) THEN +!!! Ment(il,i,j)=m(il,i) + Ment(il, i, j) = 1. + elij(il, i, j) = altem + elij(il, i, j) = amax1(0.0, elij(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)) + ELSE IF (j > i) THEN + IF (prt_level >= 10) THEN + print *,'cv3p_mixing i, j, Sij given by the no-precip eq. ', i, j, Sij(il,i,j) + ENDIF + END IF ! new + END DO + END DO + ELSE ! (ok_entrain) + DO il = 1,ncum + nent(il,i) = 0 + ENDDO + ENDIF ! (ok_entrain) + +!jygdebug< + IF (prt_level >= 10) THEN + print *,'cv3p_mixing i, nent(i), icb, inb ',i, nent(igout,i), icb(igout), inb(igout) + IF (nent(igout,i) .gt. 0) THEN + print *,'i,(j,Sij(i,j),j=icb-1,inb) ',i,(j,Sij(igout,i,j),j=icb(igout)-1,inb(igout)) + ENDIF + ENDIF +!>jygdebug + +! *** if no air can entrain at level i assume that updraft detrains *** +! *** at that level and calculate detrained air flux and properties *** + + +! @ do 170 i=icb(il),inb(il) + + DO il = 1, ncum + IF ((i>=icb(il)) .AND. (i<=inb(il)) .AND. (nent(il,i)==0)) THEN +! @ if(nent(il,i).eq.0)then +!!! Ment(il,i,i)=m(il,i) + Ment(il, i, i) = 1. +!! Qent(il, i, i) = qnk(il) - ep(il, i)*clw(il, i) + Qent(il, i, i) = qta(il,i-1) - ep(il, i)*clw(il, i) + uent(il, i, i) = unk(il) + vent(il, i, i) = vnk(il) + IF (fl_cor_ebil .GE. 2) THEN + hent(il, i, i) = hp(il,i) + ENDIF + elij(il, i, i) = clw(il, i)*(1.-ep(il,i)) + Sij(il, i, i) = 0.0 + END IF + END DO + END DO ! i = minorig + 1, nl + + DO j = minorig, nl + DO i = minorig, nl + DO il = 1, ncum + IF ((j>=(icb(il)-1)) .AND. (j<=inb(il)) .AND. & + (i>=icb(il)) .AND. (i<=inb(il))) THEN + Sigij(il, i, j) = Sij(il, i, j) + END IF + END DO + END DO + END DO +! @ enddo + +! @170 continue + +! ===================================================================== +! --- NORMALIZE ENTRAINED AIR MASS FLUXES +! --- TO REPRESENT EQUAL PROBABILITIES OF MIXING +! ===================================================================== + + csum(:,:) = 0. + + DO il = 1, ncum + lwork(il) = .FALSE. + END DO + +! --------------------------------------------------------------- + DO i = minorig + 1, nl !Loop on origin level "i" +! --------------------------------------------------------------- + + num1 = 0 + DO il = 1, ncum + IF (i>=icb(il) .AND. i<=inb(il)) num1 = num1 + 1 + END DO +!ym IF (num1<=0) GO TO 789 + IF (num1<=0) CYCLE + + +!JYG1 Find maximum of SIJ for J>I, if any. + + Sx(:) = 0. + + DO il = 1, ncum + IF (i>=icb(il) .AND. i<=inb(il)) THEN + signhpmh(il) = sign(1., hp(il,i)-h(il,i)) + Sbef(il) = max(0., signhpmh(il)) + END IF + END DO + + DO j = i + 1, nl + DO il = 1, ncum + IF (i>=icb(il) .AND. i<=inb(il) .AND. j<=inb(il)) THEN + IF (Sbef(il)=icb(il) .AND. i<=inb(il)) THEN + lwork(il) = (nent(il,i)/=0) +!! rti = qnk(il) - ep(il, i)*clw(il, i) + rti = qta(il,i-1) - ep(il, i)*clw(il, i) +!jyg< + IF (cvflag_ice) THEN + + anum = h(il, i) - hp(il, i) - (lv(il,i)+frac(il,i)*lf(il,i))* & + (rti-rs(il,i)) + (cpv-cpd)*t(il, i)*(rti-rr(il,i)) + denom = h(il, i) - hp(il, i) + (lv(il,i)+frac(il,i)*lf(il,i))* & + (rr(il,i)-rti) + (cpd-cpv)*t(il, i)*(rr(il,i)-rti) + ELSE + + anum = h(il, i) - hp(il, i) - lv(il, i)*(rti-rs(il,i)) + & + (cpv-cpd)*t(il, i)*(rti-rr(il,i)) + denom = h(il, i) - hp(il, i) + lv(il, i)*(rr(il,i)-rti) + & + (cpd-cpv)*t(il, i)*(rr(il,i)-rti) + END IF +!>jyg + IF (abs(denom)<0.01) denom = 0.01 + Scrit(il) = min(anum/denom, 1.) + alt = rti - rs(il, i) + Scrit(il)*(rr(il,i)-rti) + +!JYG1 Find new critical value Scrit2 +! such that : Sij > Scrit2 => mixed draught will detrain at J mixed draught will detrain at J>I + + Scrit2 = min(Scrit(il), Sx(il))*max(0., -signhpmh(il)) + & + Scrit(il)*max(0., signhpmh(il)) + + Scrit(il) = Scrit2 + +!JYG Correction pour la nouvelle logique; la correction pour ALT +! est un peu au hazard + IF (Scrit(il)<=0.0) Scrit(il) = 0.0 + IF (alt<=0.0) Scrit(il) = 1.0 + + smax(il) = 0.0 + ASij(il) = 0.0 + sup(il) = 0. ! upper S-value reached by descending draughts + END IF + END DO + +! --------------------------------------------------------------- + DO j = minorig, nl !Loop on destination level "j" +! --------------------------------------------------------------- + + num2 = 0 + DO il = 1, ncum + IF (i>=icb(il) .AND. i<=inb(il) .AND. & + j>=(icb(il)-1) .AND. j<=inb(il) .AND. & + lwork(il)) num2 = num2 + 1 + END DO +!ym IF (num2<=0) GO TO 175 + IF (num2<=0) CYCLE +! ----------------------------------------------- + IF (j>i) THEN +! ----------------------------------------------- + DO il = 1, ncum + IF (i>=icb(il) .AND. i<=inb(il) .AND. & + j>=(icb(il)-1) .AND. j<=inb(il) .AND. & + lwork(il)) THEN + IF (Sij(il,i,j)>0.0) THEN + Smid(il) = min(Sij(il,i,j), Scrit(il)) + Sjmax(il) = Smid(il) + Sjmin(il) = Smid(il) + IF (Smid(il)=icb(il) .AND. i<=inb(il) .AND. & + j>=(icb(il)-1) .AND. j<=inb(il) .AND. & + lwork(il)) THEN + IF (Sij(il,i,j)>0.0) THEN + Smid(il) = 1. + Sjmin(il) = max((Sij(il,i,j-1)+Smid(il))/2., Scrit(il))*max(0., -signhpmh(il)) + & + min((Sij(il,i,j+1)+Smid(il))/2., Scrit(il))*max(0., signhpmh(il)) + Sjmin(il) = max(Sjmin(il), sup(il)) + Sjmax(il) = 1. + +! - preparation des variables Scrit, Smin et Sbef pour la partie j>i + Scrit(il) = min(Sjmin(il), Sjmax(il), Scrit(il)) + + smin(il) = 1. + Sbef(il) = max(0., signhpmh(il)) + supmax(il, i) = sign(Scrit(il), -signhpmh(il)) + END IF + END IF + END DO +! ----------------------------------------------- + ELSE IF (j=icb(il) .AND. i<=inb(il) .AND. & + j>=(icb(il)-1) .AND. j<=inb(il) .AND. & + lwork(il)) THEN + IF (Sij(il,i,j)>0.0) THEN + Smid(il) = max(Sij(il,i,j), Scrit(il)) + Sjmax(il) = Smid(il) + Sjmin(il) = Smid(il) + IF (Smid(il)>smax(il) .AND. Sij(il,i,j+1)>Smid(il)) THEN + smax(il) = Smid(il) + Sjmax(il) = max((Sij(il,i,j+1)+Sij(il,i,j))/2., Sij(il,i,j)) + Sjmax(il) = max(Sjmax(il), Scrit(il)) + Sjmin(il) = min((Sbef(il)+Sij(il,i,j))/2., Sij(il,i,j)) + Sjmin(il) = max(Sjmin(il), Scrit(il)) + Sbef(il) = Sij(il, i, j) + END IF + IF (abs(Sjmin(il)-Sjmax(il))>1.E-10) & + sup(il) = max(Sjmin(il), Sjmax(il), sup(il)) + END IF + END IF + END DO +! ----------------------------------------------- + END IF +! ----------------------------------------------- + + + DO il = 1, ncum + IF (i>=icb(il) .AND. i<=inb(il) .AND. & + j>=(icb(il)-1) .AND. j<=inb(il) .AND. & + lwork(il)) THEN + IF (Sij(il,i,j)>0.0) THEN +!! rti = qnk(il) - ep(il, i)*clw(il, i) + rti = qta(il,i-1) - ep(il, i)*clw(il, i) + Qmixmax(il) = Qmix(Sjmax(il)) + Qmixmin(il) = Qmix(Sjmin(il)) + Rmixmax(il) = Rmix(Sjmax(il)) + Rmixmin(il) = Rmix(Sjmin(il)) + sqmrmax(il) = Sjmax(il)*Qmix(Sjmax(il)) - Rmix(Sjmax(il)) + sqmrmin(il) = Sjmin(il)*Qmix(Sjmin(il)) - Rmix(Sjmin(il)) + + Ment(il, i, j) = abs(Qmixmax(il)-Qmixmin(il))*Ment(il, i, j) + +! Sigij(i,j) is the 'true' mixing fraction of mixture Ment(i,j) + IF (abs(Qmixmax(il)-Qmixmin(il))>1.E-10) THEN + Sigij(il, i, j) = (sqmrmax(il)-sqmrmin(il))/(Qmixmax(il)-Qmixmin(il)) + ELSE + Sigij(il, i, j) = 0. + END IF + +! -- Compute Qent, uent, vent according to the true mixing fraction + Qent(il, i, j) = (1.-Sigij(il,i,j))*rti + Sigij(il, i, j)*rr(il, i) + uent(il, i, j) = (1.-Sigij(il,i,j))*unk(il) + Sigij(il, i, j)*u(il, i) + vent(il, i, j) = (1.-Sigij(il,i,j))*vnk(il) + Sigij(il, i, j)*v(il, i) + +! -- Compute liquid water static energy of mixed draughts +! IF (j .GT. i) THEN +! awat=elij(il,i,j)-(1.-ep(il,j))*clw(il,j) +! awat=amax1(awat,0.0) +! ELSE +! awat = 0. +! ENDIF +! Hent(il,i,j) = (1.-Sigij(il,i,j))*HP(il,i) +! : + Sigij(il,i,j)*H(il,i) +! : + (LV(il,j)+(cpd-cpv)*t(il,j))*awat +!IM 301008 beg + hent(il, i, j) = (1.-Sigij(il,i,j))*hp(il, i) + Sigij(il, i, j)*h(il, i) + +!jyg< +! elij(il, i, j) = Qent(il, i, j) - rs(il, j) +! elij(il, i, j) = elij(il, i, j) + & +! ((h(il,j)-hent(il,i,j))*rs(il,j)*lv(il,j) / & +! ((cpd*(1.-Qent(il,i,j))+Qent(il,i,j)*cpv)*rrv*t(il,j)*t(il,j))) +! elij(il, i, j) = elij(il, i, j) / & +! (1.+lv(il,j)*lv(il,j)*rs(il,j) / & +! ((cpd*(1.-Qent(il,i,j))+Qent(il,i,j)*cpv)*rrv*t(il,j)*t(il,j))) +! +! Computation of condensate amount Elij, taking into account the ice fraction frac +! Warning : the same saturation humidity rs is used over both liquid water and ice; this +! should be corrected. +! +! Heat capacity of mixed draught + cpm = cpd+Qent(il,i,j)*(cpv-cpd) +! + IF (cvflag_ice .and. frac(il,j) .gt. 0.) THEN + elij(il, i, j) = Qent(il, i, j) - rs(il, j) + elij(il, i, j) = elij(il, i, j) + & + (h(il,j)-hent(il,i,j)+(cpv-cpd)*(Qent(il,i,j)-rr(il,j))*t(il,j))* & + rs(il,j)*lv(il,j) / (cpm*rrv*t(il,j)*t(il,j)) + elij(il, i, j) = elij(il, i, j) / & + (1.+(lv(il,j)+frac(il,j)*lf(il,j))*lv(il,j)*rs(il,j) / & + (cpm*rrv*t(il,j)*t(il,j))) + ELSE + elij(il, i, j) = Qent(il, i, j) - rs(il, j) + elij(il, i, j) = elij(il, i, j) + & + (h(il,j)-hent(il,i,j)+(cpv-cpd)*(Qent(il,i,j)-rr(il,j))*t(il,j))* & + rs(il,j)*lv(il,j) / (cpm*rrv*t(il,j)*t(il,j)) + elij(il, i, j) = elij(il, i, j) / & + (1.+lv(il,j)*lv(il,j)*rs(il,j) / & + (cpm*rrv*t(il,j)*t(il,j))) + ENDIF +!>jyg + elij(il, i, j) = max(elij(il,i,j), 0.) + + elij(il, i, j) = min(elij(il,i,j), Qent(il,i,j)) + + IF (j>i) THEN + awat = elij(il, i, j) - (1.-ep(il,j))*clw(il, j) + awat = amax1(awat, 0.0) + ELSE + awat = 0. + END IF + +! print *,h(il,j)-hent(il,i,j),LV(il,j)*rs(il,j)/(cpd*rrv*t(il,j)* +! : t(il,j)) + +!jyg< +! hent(il, i, j) = hent(il, i, j) + (lv(il,j)+(cpd-cpv)*t(il,j))*awat +! Mixed draught temperature at level j + IF (cvflag_ice .and. frac(il,j) .gt. 0.) THEN + Tm = t(il,j) + (Qent(il,i,j)-elij(il,i,j)-rs(il,j))*rrv*t(il,j)*t(il,j)/(lv(il,j)*rs(il,j)) + hent(il, i, j) = hent(il, i, j) + (lv(il,j)+frac(il,j)*lf(il,j)+(cpd-cpv)*Tm)*awat + ELSE + Tm = t(il,j) + (Qent(il,i,j)-elij(il,i,j)-rs(il,j))*rrv*t(il,j)*t(il,j)/(lv(il,j)*rs(il,j)) + hent(il, i, j) = hent(il, i, j) + (lv(il,j)+(cpd-cpv)*Tm)*awat + ENDIF +!>jyg + +!IM 301008 end + +! print *,'mix : i,j,hent(il,i,j),Sigij(il,i,j) ', +! : i,j,hent(il,i,j),Sigij(il,i,j) + +! -- ASij is the integral of P(F) over the relevant F interval + ASij(il) = ASij(il) + abs(Qmixmax(il)*(1.-Sjmax(il))+Rmixmax(il) - & + Qmixmin(il)*(1.-Sjmin(il))-Rmixmin(il)) + + END IF + END IF + END DO + +! -- If I=J (detrainement and entrainement at the same level), then only the +! -- adiabatic ascent part of the mixture is considered + IF (i==j) THEN + DO il = 1, ncum + IF (i>=icb(il) .AND. i<=inb(il) .AND. & + j>=(icb(il)-1) .AND. j<=inb(il) .AND. & + lwork(il)) THEN + IF (Sij(il,i,j)>0.0) THEN +!! rti = qnk(il) - ep(il, i)*clw(il, i) + rti = qta(il,i-1) - ep(il, i)*clw(il, i) +!!! Ment(il,i,i) = m(il,i)*abs(Qmixmax(il)*(1.-Sjmax(il)) + Ment(il, i, i) = abs(Qmixmax(il)*(1.-Sjmax(il))+Rmixmax(il) - & + Qmixmin(il)*(1.-Sjmin(il))-Rmixmin(il)) + Qent(il, i, i) = rti + uent(il, i, i) = unk(il) + vent(il, i, i) = vnk(il) + hent(il, i, i) = hp(il, i) + elij(il, i, i) = clw(il, i)*(1.-ep(il,i)) + Sigij(il, i, i) = 0. + END IF + END IF + END DO + END IF !(i==j) + +! --------------------------------------------------------------- + END DO !ym label 175 ! End loop on destination level "j" +! --------------------------------------------------------------- + + DO il = 1, ncum + IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il)) THEN + ASij(il) = amax1(1.0E-16, ASij(il)) +!jyg+lluis< +!! ASij(il) = 1.0/ASij(il) + ASij_inv(il) = 1.0/ASij(il) +! IF the F-interval spanned by possible mixtures is less than 0.01, no mixing occurs + IF (ASij_inv(il) > 100.) ASij_inv(il) = 0. +!>jyg+lluis + csum(il, i) = 0.0 + END IF + END DO + + DO j = minorig, nl + DO il = 1, ncum + IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il) .AND. & + j>=(icb(il)-1) .AND. j<=inb(il)) THEN +!jyg Ment(il, i, j) = Ment(il, i, j)*ASij(il) + Ment(il, i, j) = Ment(il, i, j)*ASij_inv(il) + END IF + END DO + END DO + + DO j = minorig, nl + DO il = 1, ncum + IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il) .AND. & + j>=(icb(il)-1) .AND. j<=inb(il)) THEN + csum(il, i) = csum(il, i) + Ment(il, i, j) + END IF + END DO + END DO + + DO il = 1, ncum + IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il) .AND. csum(il,i)<1.) THEN +! cc : .and. csum(il,i).lt.m(il,i) ) then + nent(il, i) = 0 +! cc Ment(il,i,i)=m(il,i) + Ment(il, i, i) = 1. +!! Qent(il, i, i) = qnk(il) - ep(il, i)*clw(il, i) + Qent(il, i, i) = qta(il,i-1) - ep(il, i)*clw(il, i) + uent(il, i, i) = unk(il) + vent(il, i, i) = vnk(il) + elij(il, i, i) = clw(il, i)*(1.-ep(il,i)) + IF (fl_cor_ebil .GE. 2) THEN + hent(il, i, i) = hp(il,i) + Sigij(il, i, i) = 0.0 + ELSE + Sij(il, i, i) = 0.0 + ENDIF + END IF + END DO ! il + +! --------------------------------------------------------------- +END DO !ym label 789 ! End loop on origin level "i" + +! --------------------------------------------------------------- + + + RETURN +END SUBROUTINE cv3p_mixing + +END MODULE cv3p_mixing_mod Index: LMDZ6/trunk/libf/phylmd/cv_routines.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cv_routines.f90 (revision 6047) +++ (revision ) @@ -1,1801 +1,0 @@ - -! $Id$ -MODULE cv_routines_mod -PRIVATE - -PUBLIC cv_param, cv_prelim, cv_feed, cv_undilute1, cv_trigger, cv_compress, cv_undilute2, & - cv_closure, cv_mixing, cv_yield, cv_unsat, cv_uncompress - -CONTAINS - -SUBROUTINE cv_param(nd) - USE lmdz_cv_ini, ONLY : alpha,betad,coeffr,coeffs,cu,damp,delta,dtmax,elcrit,entp,minorig,nl,nlm,nlp,noff,omtrain,omtsnow,sigd,sigs,tlcrit - - IMPLICIT NONE - - ! ------------------------------------------------------------ - ! Set parameters for convectL - ! (includes microphysical parameters and parameters that - ! control the rate of approach to quasi-equilibrium) - ! ------------------------------------------------------------ - - ! *** ELCRIT IS THE AUTOCONVERSION THERSHOLD WATER CONTENT (gm/gm) *** - ! *** TLCRIT IS CRITICAL TEMPERATURE BELOW WHICH THE AUTO- *** - ! *** CONVERSION THRESHOLD IS ASSUMED TO BE ZERO *** - ! *** (THE AUTOCONVERSION THRESHOLD VARIES LINEARLY *** - ! *** BETWEEN 0 C AND TLCRIT) *** - ! *** ENTP IS THE COEFFICIENT OF MIXING IN THE ENTRAINMENT *** - ! *** FORMULATION *** - ! *** SIGD IS THE FRACTIONAL AREA COVERED BY UNSATURATED DNDRAFT *** - ! *** SIGS IS THE FRACTION OF PRECIPITATION FALLING OUTSIDE *** - ! *** OF CLOUD *** - ! *** OMTRAIN IS THE ASSUMED FALL SPEED (P/s) OF RAIN *** - ! *** OMTSNOW IS THE ASSUMED FALL SPEED (P/s) OF SNOW *** - ! *** COEFFR IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION *** - ! *** OF RAIN *** - ! *** COEFFS IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION *** - ! *** OF SNOW *** - ! *** CU IS THE COEFFICIENT GOVERNING CONVECTIVE MOMENTUM *** - ! *** TRANSPORT *** - ! *** DTMAX IS THE MAXIMUM NEGATIVE TEMPERATURE PERTURBATION *** - ! *** A LIFTED PARCEL IS ALLOWED TO HAVE BELOW ITS LFC *** - ! *** ALPHA AND DAMP ARE PARAMETERS THAT CONTROL THE RATE OF *** - ! *** APPROACH TO QUASI-EQUILIBRIUM *** - ! *** (THEIR STANDARD VALUES ARE 0.20 AND 0.1, RESPECTIVELY) *** - ! *** (DAMP MUST BE LESS THAN 1) *** - - INTEGER nd - CHARACTER (LEN=20) :: modname = 'cv_routines' - CHARACTER (LEN=80) :: abort_message - - ! noff: integer limit for convection (nd-noff) - ! 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 - - cu = 0.70 - - betad = 10.0 - - damp = 0.1 - alpha = 0.2 - - delta = 0.01 ! cld - - RETURN -END SUBROUTINE cv_param - -SUBROUTINE cv_prelim(len, nd, ndp1, t, q, p, ph, lv, cpn, tv, gz, h, hm) - USE lmdz_cv_ini, ONLY : cl,clmcpv,cpd,cpv,epsim1,hrd,lv0,nlp,t0 - - IMPLICIT NONE - - ! ===================================================================== - ! --- CALCULATE ARRAYS OF GEOPOTENTIAL, HEAT CAPACITY & STATIC ENERGY - ! ===================================================================== - - ! inputs: - INTEGER len, nd, ndp1 - REAL t(len, nd), q(len, nd), p(len, nd), ph(len, ndp1) - - ! outputs: - REAL lv(len, nd), cpn(len, nd), tv(len, nd) - REAL gz(len, nd), h(len, nd), hm(len, nd) - - ! local variables: - INTEGER k, i - REAL cpx(len, nd) - - DO k = 1, nlp - DO 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) - ENDDO - ENDDO - - ! gz = phi at the full levels (same as p). - - DO i = 1, len - gz(i, 1) = 0.0 - ENDDO - DO k = 2, nlp - DO 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) - ENDDO - ENDDO - - ! h = phi + cpT (dry static energy). - ! hm = phi + cp(T-Tbase)+Lq - - DO k = 1, nlp - DO 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) - ENDDO - ENDDO - - RETURN -END SUBROUTINE cv_prelim - -SUBROUTINE cv_feed(len, nd, t, q, qs, p, hm, gz, nk, icb, icbmax, iflag, tnk, & - qnk, gznk, plcl) - USE lmdz_cv_ini, ONLY : minorig,nl,nlm,nlp - - IMPLICIT NONE - - ! ================================================================ - ! Purpose: CONVECTIVE FEED - ! ================================================================ - - - ! inputs: - INTEGER len, nd - REAL t(len, nd), q(len, nd), qs(len, nd), p(len, nd) - REAL hm(len, nd), gz(len, nd) - - ! outputs: - INTEGER iflag(len), nk(len), icb(len), icbmax - REAL tnk(len), qnk(len), gznk(len), plcl(len) - - ! 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 i = 1, len - work(i) = 1.0E12 - ihmin(i) = nl - ENDDO - DO k = 2, nlp - DO i = 1, len - IF ((hm(i,k)work(i)) .AND. (k<=ihmin(i))) THEN - work(i) = hm(i, k) - nk(i) = k - ENDIF - ENDDO - ENDDO - ! ------------------------------------------------------------------- - ! --- Check whether parcel level temperature and specific humidity - ! --- are reasonable - ! ------------------------------------------------------------------- - DO i = 1, len - IF (((t(i,nk(i))<250.0) .OR. (q(i,nk(i))<=0.0) .OR. (p(i,ihmin(i))< & - 400.0)) .AND. (iflag(i)==0)) iflag(i) = 7 - ENDDO - ! ------------------------------------------------------------------- - ! --- Calculate lifted condensation level of air at parcel origin level - ! --- (Within 0.2% of formula of Bolton, MON. WEA. REV.,1980) - ! ------------------------------------------------------------------- - DO 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)) - - 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)<200.0) .OR. (plcl(i)>=2000.0)) .AND. (iflag(i)==0)) iflag(i & - ) = 8 - ENDDO - ! ------------------------------------------------------------------- - ! --- Calculate first level above lcl (=icb) - ! ------------------------------------------------------------------- - DO i = 1, len - icb(i) = nlm - ENDDO - - DO k = minorig, nl - DO i = 1, len - IF ((k>=(nk(i)+1)) .AND. (p(i,k)=nlm) .AND. (iflag(i)==0)) iflag(i) = 9 - ENDDO - - ! Compute icbmax. - !ym do not do that, independance between column - !ym icbmax = 2 - !ym DO i = 1, len - !ym icbmax = max(icbmax, icb(i)) - !ym END DO - - RETURN -END SUBROUTINE cv_feed - -SUBROUTINE cv_undilute1(len, nd, t, q, qs, gz, p, nk, icb, icbmax, tp, tvp, & - clw) - USE lmdz_cv_ini, ONLY : cl,clmcpv,cpd,cpv,eps,epsi,lv0,minorig,rrv,t0,nl - - IMPLICIT NONE - - ! 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) - - ! outputs: - REAL tp(len, nd), tvp(len, nd), clw(len, nd) - - ! 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 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)) - END DO - - ! *** Calculate certain parcel quantities, including static energy *** - - DO 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 - END DO - - ! *** Calculate lifted parcel quantities below cloud base *** - - !ym bad dependance between column => icbmax computed in cv_feed -!ym DO k = minorig, icbmax - 1 - DO k = minorig, nd - DO i = 1, len - IF (k <= MAX(2,icb(i))-1) THEN - tp(i, k) = tnk(i) - (gz(i,k)-gznk(i))/cpp(i) - tvp(i, k) = tp(i, k)*(1.+qnk(i)*epsi) - ENDIF - ENDDO - ENDDO - - ! *** Find lifted parcel quantities above cloud base *** - - DO i = 1, len - tg = ticb(i) - qg = qs(i, icb(i)) - alv = lv0 - clmcpv*(ticb(i)-t0) - - ! First iteration. - - 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>=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)) - - ! Second iteration. - - 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>=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)) - - 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) - ENDDO - - !ym bad dependance between column => ibmax computed in cv_feed -!ym DO k = minorig, icbmax - DO k = minorig, nd - DO i = 1, len - IF (k <= MAX(2,icb(i))) THEN - tvp(i, k) = tvp(i, k) - tp(i, k)*qnk(i) - ENDIF - ENDDO - ENDDO - - RETURN -END SUBROUTINE cv_undilute1 - -SUBROUTINE cv_trigger(len, nd, icb, cbmf, tv, tvp, iflag) - USE lmdz_cv_ini, ONLY : dtmax - 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. - ! ------------------------------------------------------------------- - - - ! inputs: - INTEGER len, nd, icb(len) - REAL cbmf(len), tv(len, nd), tvp(len, nd) - - ! outputs: - INTEGER iflag(len) ! also an input - - ! local variables: - INTEGER i - - - DO i = 1, len - IF ((cbmf(i)==0.0) .AND. (iflag(i)==0) .AND. (tvp(i, & - icb(i))<=(tv(i,icb(i))-dtmax))) iflag(i) = 4 - END DO - - RETURN -END SUBROUTINE cv_trigger - -SUBROUTINE cv_compress(len, nloc, ncum, nd, iflag1, compress, nk1, icb1, cbmf1, plcl1, & - tnk1, qnk1, gznk1, t1, q1, qs1, u1, v1, gz1, h1, lv1, cpn1, p1, ph1, tv1, & - tp1, tvp1, clw1, iflag, nk, icb, cbmf, plcl, tnk, qnk, gznk, t, q, qs, u, & - v, gz, h, lv, cpn, p, ph, tv, tp, tvp, clw, dph) - USE lmdz_cv_ini, ONLY : nl - USE print_control_mod, ONLY: lunout - IMPLICIT NONE - - - ! inputs: - INTEGER len, ncum, nd, nloc - INTEGER iflag1(len), nk1(len), icb1(len) - LOGICAL compress - 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) - - ! 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) - - ! local variables: - INTEGER i, k, nn - CHARACTER (LEN=20) :: modname = 'cv_compress' - CHARACTER (LEN=80) :: abort_message - - IF (compress) THEN - DO k = 1, nl + 1 - nn = 0 - DO i = 1, len - IF (iflag1(i)==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 - ENDDO - ENDDO - - IF (nn/=ncum) THEN - WRITE (lunout, *) 'strange! nn not equal to ncum: ', nn, ncum - abort_message = '' - CALL abort_physic(modname, abort_message, 1) - ENDIF - - nn = 0 - DO i = 1, len - IF (iflag1(i)==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 - ENDDO - - ELSE !compress - t(:, 1:nl+1) = t1(:, 1:nl+1) - q(:, 1:nl+1) = q1(:, 1:nl+1) - qs(:, 1:nl+1) = qs1(:, 1:nl+1) - u(:, 1:nl+1) = u1(:, 1:nl+1) - v(:, 1:nl+1) = v1(:, 1:nl+1) - gz(:, 1:nl+1) = gz1(:, 1:nl+1) - h(:, 1:nl+1) = h1(:, 1:nl+1) - lv(:, 1:nl+1) = lv1(:, 1:nl+1) - cpn(:, 1:nl+1) = cpn1(:, 1:nl+1) - p(:, 1:nl+1) = p1(:, 1:nl+1) - ph(:, 1:nl+1) = ph1(:, 1:nl+1) - tv(:, 1:nl+1) = tv1(:, 1:nl+1) - tp(:, 1:nl+1) = tp1(:, 1:nl+1) - tvp(:, 1:nl+1) = tvp1(:, 1:nl+1) - clw(:, 1:nl+1) = clw1(:, 1:nl+1) - - cbmf(:) = cbmf1(:) - plcl(:) = plcl1(:) - tnk(:) = tnk1(:) - qnk(:) = qnk1(:) - gznk(:) = gznk1(:) - nk(:) = nk1(:) - icb(:) = icb1(:) - iflag(:) = iflag1(:) - ENDIF - - DO k = 1, nl - DO i = 1, ncum - dph(i, k) = ph(i, k) - ph(i, k+1) - ENDDO - ENDDO - - RETURN -END SUBROUTINE cv_compress - -SUBROUTINE cv_undilute2(nloc, ncum, nd, icb, nk, tnk, qnk, gznk, t, q, qs, & - gz, p, dph, h, tv, lv, inb, inb1, tp, tvp, clw, hp, ep, sigp, frac) - USE lmdz_cv_ini, ONLY : nl,cl,clmcpv,cpd,cpv,elcrit,eps,epsi,lv0,minorig,nlp,rrv,sigs,t0,tlcrit - - IMPLICIT NONE - - ! --------------------------------------------------------------------- - ! Purpose: - ! 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 - ! --------------------------------------------------------------------- - - ! 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) - - ! 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) - - ! 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 k = 1, nl - DO i = 1, ncum - ep(i, k) = 0.0 - sigp(i, k) = sigs - ENDDO - ENDDO - - ! ===================================================================== - ! --- FIND THE REST OF THE LIFTED PARCEL TEMPERATURES - ! ===================================================================== - - ! --- The procedure is to solve the equation. - ! cp*tp+L*qp+phi=cp*tnk+L*qnk+gznk. - - ! *** Calculate certain parcel quantities, including static energy *** - - - DO i = 1, ncum - ah0(i) = (cpd*(1.-qnk(i))+cl*qnk(i))*tnk(i) + qnk(i)*(lv0-clmcpv*(tnk(i)- & - t0)) + gznk(i) - ENDDO - - - ! *** Find lifted parcel quantities above cloud base *** - - - DO k = minorig + 1, nl - DO i = 1, ncum - IF (k>=(icb(i)+1)) THEN - tg = t(i, k) - qg = qs(i, k) - alv = lv0 - clmcpv*(t(i,k)-t0) - - ! First iteration. - - 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>=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)) - - ! Second iteration. - - 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>=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)) - - alv = lv0 - clmcpv*(t(i,k)-t0) - ! print*,'cpd dans convect2 ',cpd - ! print*,'tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd' - ! 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 - ! if (.not.cpd.gt.1000.) then - ! print*,'CPD=',cpd - ! stop - ! 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 - ENDDO - ENDDO - - ! ===================================================================== - ! --- 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) - ! ===================================================================== - - DO k = minorig + 1, nl - DO i = 1, ncum - IF (k>=(nk(i)+1)) THEN - tca = tp(i, k) - t0 - IF (tca>=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 - ENDDO - ENDDO - - ! ===================================================================== - ! --- CALCULATE VIRTUAL TEMPERATURE AND LIFTED PARCEL - ! --- VIRTUAL TEMPERATURE - ! ===================================================================== - - DO k = minorig + 1, nl - DO i = 1, ncum - IF (k>=(icb(i)+1)) THEN - tvp(i, k) = tvp(i, k)*(1.0-qnk(i)+ep(i,k)*clw(i,k)) - ! print*,'i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)' - ! print*, i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k) - ENDIF - ENDDO - ENDDO - DO i = 1, ncum - tvp(i, nlp) = tvp(i, nl) - (gz(i,nlp)-gz(i,nl))/cpd - ENDDO - - ! ===================================================================== - ! --- FIND THE FIRST MODEL LEVEL (INB1) ABOVE THE PARCEL'S - ! --- HIGHEST LEVEL OF NEUTRAL BUOYANCY - ! --- AND THE HIGHEST LEVEL OF POSITIVE CAPE (INB) - ! ===================================================================== - - DO i = 1, ncum - cape(i) = 0.0 - capem(i) = 0.0 - inb(i) = icb(i) + 1 - inb1(i) = inb(i) - ENDDO - - ! Originial Code - - ! do 530 k=minorig+1,nl-1 - ! do 520 i=1,ncum - ! if(k.ge.(icb(i)+1))then - ! by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k) - ! byp=(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 - ! byp=(tvp(i,nl)-tv(i,nl))*dph(i,nl)/p(i,nl) - ! cape(i)=capem(i)+byp - ! 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 - - ! K Emanuel fix - - ! call zilch(byp,ncum) - ! do 530 k=minorig+1,nl-1 - ! do 520 i=1,ncum - ! if(k.ge.(icb(i)+1))then - ! by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k) - ! 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) - ! byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1) - ! endif - ! endif - ! 520 continue - ! 530 continue - ! do 540 i=1,ncum - ! inb(i)=max(inb(i),inb1(i)) - ! 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 - - ! J Teixeira fix - - byp(1:ncum) = 0 - - DO i = 1, ncum - lcape(i) = .TRUE. - ENDDO - DO k = minorig + 1, nl - 1 - DO i = 1, ncum - IF (cape(i)<0.0) lcape(i) = .FALSE. - IF ((k>=(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>=0.0) inb1(i) = k + 1 - IF (cape(i)>0.0) THEN - inb(i) = k + 1 - capem(i) = cape(i) - ENDIF - ENDIF - ENDDO - ENDDO - DO 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) - ENDDO - - ! ===================================================================== - ! --- CALCULATE LIQUID WATER STATIC ENERGY OF LIFTED PARCEL - ! ===================================================================== - - ! initialization: -!ym very bad -!ym DO i = 1, ncum*nlp -!ym hp(i, 1) = h(i, 1) -!ym END DO - DO k=1,nlp - DO i=1,ncum - hp(i, k) = h(i, k) - ENDDO - ENDDO - - DO k = minorig + 1, nl - DO i = 1, ncum - IF ((k>=icb(i)) .AND. (k<=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 - ENDDO - ENDDO - - RETURN -END SUBROUTINE cv_undilute2 - -SUBROUTINE cv_closure(nloc, ncum, nd, nk, icb, tv, tvp, p, ph, dph, plcl, & - cpn, iflag, cbmf) - USE lmdz_cv_ini, ONLY : alpha,damp,dtmax,minorig,rrd - - IMPLICIT NONE - - ! 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) - - ! outputs: - INTEGER iflag(nloc) - REAL cbmf(nloc) ! also an input - - ! local variables: - INTEGER i, k, icbmax - REAL dtpbl(nloc), dtmin(nloc), tvpplcl(nloc), tvaplcl(nloc) - REAL work(nloc) - - ! ------------------------------------------------------------------- - ! Compute icbmax. - ! ------------------------------------------------------------------- - -!ym independance between columns -!ym icbmax = 2 -!ym DO i = 1, ncum -!ym icbmax = max(icbmax, icb(i)) -!ym END DO - - ! ===================================================================== - ! --- CALCULATE CLOUD BASE MASS FLUX - ! ===================================================================== - - ! tvpplcl = parcel temperature lifted adiabatically from level - ! icb-1 to the LCL. - ! tvaplcl = virtual temperature at the LCL. - - DO 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)) - ENDDO - - ! ------------------------------------------------------------------- - ! --- Interpolate difference between lifted parcel and - ! --- environmental temperatures to lifted condensation level - ! ------------------------------------------------------------------- - - ! dtpbl = average of tvp-tv in the PBL (k=nk to icb-1). -!ym independance betwwen column -!ym DO k = minorig, icbmax - DO k = minorig, nd - DO i = 1, ncum - IF (k<=MAX(2,icb(i))) THEN - IF ((k>=nk(i)) .AND. (k<=(icb(i)-1))) THEN - dtpbl(i) = dtpbl(i) + (tvp(i,k)-tv(i,k))*dph(i, k) - ENDIF - ENDIF - ENDDO - ENDDO - DO i = 1, ncum - dtpbl(i) = dtpbl(i)/(ph(i,nk(i))-ph(i,icb(i))) - dtmin(i) = tvpplcl(i) - tvaplcl(i) + dtmax + dtpbl(i) - ENDDO - - ! ------------------------------------------------------------------- - ! --- Adjust cloud base mass flux - ! ------------------------------------------------------------------- - - DO 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)==0.0) .AND. (cbmf(i)==0.0)) THEN - iflag(i) = 3 - ENDIF - ENDDO - - RETURN -END SUBROUTINE cv_closure - -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) - USE lmdz_cv_ini, ONLY : cpd,cpv,entp,minorig,nl,nlp,rrv - - IMPLICIT NONE - - - ! 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) - - ! 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) - - ! 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) - - ! ===================================================================== - ! --- INITIALIZE VARIOUS ARRAYS USED IN THE COMPUTATIONS - ! ===================================================================== - -!ym very bad -!ym DO i = 1, ncum*nlp -!ym nent(i, 1) = 0 -!ym m(i, 1) = 0.0 -!ym END DO - DO k = 1, nlp - DO i = 1, ncum - nent(i, k) = 0 - m(i, k) = 0.0 - ENDDO - ENDDO - - DO k = 1, nlp - DO j = 1, nlp - DO 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 - ENDDO - ENDDO - ENDDO - - ! ------------------------------------------------------------------- - ! --- Calculate rates of mixing, m(i) - ! ------------------------------------------------------------------- - - work(1:ncum) = 0. - - DO j = minorig + 1, nl - DO i = 1, ncum - IF ((j>=(icb(i)+1)) .AND. (j<=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 - ENDDO - ENDDO - DO k = minorig + 1, nl - DO i = 1, ncum - IF ((k>=(icb(i)+1)) .AND. (k<=inb(i))) THEN - m(i, k) = m(i, k)/work(i) - ENDIF - ENDDO - ENDDO - - - ! ===================================================================== - ! --- CALCULATE ENTRAINED AIR MASS FLUX (ment), TOTAL WATER MIXING - ! --- RATIO (QENT), TOTAL CONDENSED WATER (elij), AND MIXING - ! --- FRACTION (sij) - ! ===================================================================== - - - DO i = minorig + 1, nl - DO j = minorig + 1, nl - DO ij = 1, ncum - IF ((i>=(icb(ij)+1)) .AND. (j>=icb(ij)) .AND. (i<=inb(ij)) .AND. (j<= & - 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)<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<0.0 .OR. stemp>1.0 .OR. altem>cwat) .AND. j>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)<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)>0.0 .AND. sij(ij,i,j)<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 - ENDDO - ENDDO - - ! *** If no air can entrain at level i assume that updraft detrains - ! *** - ! *** at that level and calculate detrained air flux and properties - ! *** - - DO ij = 1, ncum - IF ((i>=(icb(ij)+1)) .AND. (i<=inb(ij)) .AND. (nent(ij,i)==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 - ENDDO - ENDDO - - DO i = 1, ncum - sij(i, inb(i), inb(i)) = 1.0 - ENDDO - - ! ===================================================================== - ! --- NORMALIZE ENTRAINED AIR MASS FLUXES - ! --- TO REPRESENT EQUAL PROBABILITIES OF MIXING - ! ===================================================================== - - bsum(1:ncum,1:nlp) = 0. - DO ij = 1, ncum - lwork(ij) = .FALSE. - ENDDO - DO i = minorig + 1, nl !789 ENDDO - - num1 = 0 - DO ij = 1, ncum - IF ((i>=icb(ij)+1) .AND. (i<=inb(ij))) num1 = num1 + 1 - ENDDO -!ym IF (num1<=0) GO TO 789 - IF (num1<=0) CYCLE - - DO ij = 1, ncum - IF ((i>=icb(ij)+1) .AND. (i<=inb(ij))) THEN - lwork(ij) = (nent(ij,i)/=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)<0.01) denom = 0.01 - scrit(ij) = anum/denom - alt = qp1 - qs(ij, i) + scrit(ij)*(q(ij,i)-qp1) - IF (scrit(ij)<0.0 .OR. alt<0.0) scrit(ij) = 1.0 - asij(ij) = 0.0 - smin(ij) = 1.0 - ENDIF - ENDDO - DO j = minorig, nl ! 783 ENDDO - - num2 = 0 - DO ij = 1, ncum - IF ((i>=icb(ij)+1) .AND. (i<=inb(ij)) .AND. (j>=icb( & - ij)) .AND. (j<=inb(ij)) .AND. lwork(ij)) num2 = num2 + 1 - END DO -!ym IF (num2<=0) GO TO 783 - IF (num2<=0) CYCLE - - DO ij = 1, ncum - IF ((i>=icb(ij)+1) .AND. (i<=inb(ij)) .AND. (j>=icb( & - ij)) .AND. (j<=inb(ij)) .AND. lwork(ij)) THEN - IF (sij(ij,i,j)>0.0 .AND. sij(ij,i,j)<0.9) THEN - IF (j>i) THEN - smid = min(sij(ij,i,j), scrit(ij)) - sjmax = smid - sjmin = smid - IF (smid1) 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 - ENDDO -783 ENDDO - DO ij = 1, ncum - IF ((i>=icb(ij)+1) .AND. (i<=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 - ENDDO - DO j = minorig, nl + 1 - DO ij = 1, ncum - IF ((i>=icb(ij)+1) .AND. (i<=inb(ij)) .AND. (j>=icb( & - ij)) .AND. (j<=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 - ENDDO - ENDDO - DO ij = 1, ncum - IF ((i>=icb(ij)+1) .AND. (i<=inb(ij)) .AND. (bsum(ij, & - i)<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 - ENDDO -789 ENDDO - - RETURN -END SUBROUTINE cv_mixing - -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) - USE lmdz_cv_ini, ONLY : cl,coeffr,coeffs,cpd,g,ginv,nl,omtrain,omtsnow,sigd - - IMPLICIT NONE - - ! 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) - - ! 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) - - ! 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) - - ! ===================================================================== - ! --- PRECIPITATING DOWNDRAFT CALCULATION - ! ===================================================================== - - ! Initializations: - - 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 i = 1, ncum - qp(i, 1) = q(i, 1) - up(i, 1) = u(i, 1) - vp(i, 1) = v(i, 1) - ENDDO - - DO k = 2, nl + 1 - DO i = 1, ncum - qp(i, k) = q(i, k-1) - up(i, k) = u(i, k-1) - vp(i, k) = v(i, k-1) - ENDDO - ENDDO - - - ! *** Check whether ep(inb)=0, if so, skip precipitating *** - ! *** downdraft calculation *** - - - ! *** Integrate liquid water equation to find condensed water *** - ! *** and condensed water flux *** - - - DO i = 1, ncum - jtt(i) = 2 - IF (ep(i,inb(i))<=0.0001) iflag(i) = 2 - IF (iflag(i)==0) THEN - lwork(i) = .TRUE. - ELSE - lwork(i) = .FALSE. - ENDIF - ENDDO - - ! *** Begin downdraft loop *** - - - wdtrain(1:ncum) = 0. - DO i = nl + 1, 1, -1 ! 899 ENDDO - - num1 = 0 - DO ij = 1, ncum - IF ((i<=inb(ij)) .AND. lwork(ij)) num1 = num1 + 1 - END DO -!ym IF (num1<=0) GO TO 899 - IF (num1<=0) CYCLE - - - ! *** Calculate detrained precipitation *** - - DO ij = 1, ncum - IF ((i<=inb(ij)) .AND. (lwork(ij))) THEN - wdtrain(ij) = g*ep(ij, i)*m(ij, i)*clw(ij, i) - ENDIF - ENDDO - - IF (i>1) THEN - DO j = 1, i - 1 - DO ij = 1, ncum - IF ((i<=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 - ENDDO - ENDDO - ENDIF - - ! *** Find rain water and evaporation using provisional *** - ! *** estimates of qp(i)and qp(i-1) *** - - - ! *** Value of terminal velocity and coeffecient of evaporation for snow - ! *** - - DO ij = 1, ncum - IF ((i<=inb(ij)) .AND. (lwork(ij))) THEN - coeff = coeffs - wt(ij, i) = omtsnow - - ! *** Value of terminal velocity and coeffecient of evaporation for - ! rain *** - - IF (t(ij,i)>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 - - ! *** Calculate precipitating downdraft mass flux under *** - ! *** hydrostatic approximation *** - - IF (i>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) - - ! *** Add small amount of inertia to downdraft *** - - fac = 20.0/(ph(ij,i-1)-ph(ij,i)) - mp(ij, i) = (fac*mp(ij,i+1)+mp(ij,i))/(1.+fac) - - ! *** Force mp to decrease linearly to zero - ! *** - ! *** between about 950 mb and the surface - ! *** - - IF (p(ij,i)>(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 - - ! *** Find mixing ratio of precipitating downdraft *** - - IF (i/=inb(ij)) THEN - IF (i==1) THEN - qstm = qs(ij, 1) - ELSE - qstm = qs(ij, i-1) - ENDIF - IF (mp(ij,i)>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)>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 - ENDDO -899 ENDDO - - RETURN -END SUBROUTINE cv_unsat - -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, iflag, wd, qprime, tprime, & - precip, cbmf, ft, fq, fu, fv, ma, qcondc) - - USE lmdz_cv_ini, ONLY : g,lv0,nl,rrd,sigd,betad,cl,cpd,cpv,cu,delta - - IMPLICIT NONE - - ! 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) - - ! 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) - - ! 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 - - - ! -- initializations: - - delti = 1.0/delt - - DO i = 1, ncum - precip(i) = 0.0 - wd(i) = 0.0 - tprime(i) = 0.0 - qprime(i) = 0.0 - DO 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 - ENDDO - ENDDO - - - ! *** Calculate surface precipitation in mm/day *** - - DO i = 1, ncum - IF (iflag(i)<=1) THEN - ! c precip(i)=precip(i)+wt(i,1)*sigd*water(i,1)*3600.*24000. - ! c & /(rowl*g) - ! c precip(i)=precip(i)*delt/86400. - precip(i) = wt(i, 1)*sigd*water(i, 1)*86400/g - ENDIF - ENDDO - - - ! *** Calculate downdraft velocity scale and surface temperature and *** - ! *** water vapor fluctuations *** - - 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 - - ! *** Calculate tendencies of lowest level potential temperature *** - ! *** and mixing ratio *** - - DO i = 1, ncum - work(i) = 0.01/(ph(i,1)-ph(i,2)) - am(i) = 0.0 - ENDDO - DO k = 2, nl - DO i = 1, ncum - IF ((nk(i)==1) .AND. (k<=inb(i)) .AND. (nk(i)==1)) THEN - am(i) = am(i) + m(i, k) - ENDIF - ENDDO - ENDDO - DO i = 1, ncum - IF ((g*work(i)*am(i))>=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))) - ENDDO - DO j = 2, nl - DO i = 1, ncum - IF (j<=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 - ENDDO - ENDDO - - ! *** Calculate tendencies of potential temperature and mixing ratio *** - ! *** at levels above the lowest level *** - - ! *** First find the net saturated updraft and downdraft mass fluxes *** - ! *** through each level *** - - DO i = 2, nl + 1 ! 1500 ENDDO - - num1 = 0 - DO ij = 1, ncum - IF (i<=inb(ij)) num1 = num1 + 1 - ENDDO -!ym IF (num1<=0) GO TO 1500 - IF (num1<=0) CYCLE - - amp1(1:ncum)=0. - ad(1:ncum)=0. - - DO k = i + 1, nl + 1 - DO ij = 1, ncum - IF ((i>=nk(ij)) .AND. (i<=inb(ij)) .AND. (k<=(inb(ij)+1))) THEN - amp1(ij) = amp1(ij) + m(ij, k) - ENDIF - ENDDO - ENDDO - - DO k = 1, i - DO j = i + 1, nl + 1 - DO ij = 1, ncum - IF ((j<=(inb(ij)+1)) .AND. (i<=inb(ij))) THEN - amp1(ij) = amp1(ij) + ment(ij, k, j) - ENDIF - ENDDO - ENDDO - ENDDO - DO k = 1, i - 1 - DO j = i, nl + 1 - DO ij = 1, ncum - IF ((i<=inb(ij)) .AND. (j<=inb(ij))) THEN - ad(ij) = ad(ij) + ment(ij, j, k) - ENDIF - ENDDO - ENDDO - ENDDO - - DO ij = 1, ncum - IF (i<=inb(ij)) THEN - dpinv = 0.01/(ph(ij,i)-ph(ij,i+1)) - cpinv = 1.0/cpn(ij, i) - - 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 - ENDDO - DO k = 1, i - 1 - DO ij = 1, ncum - IF (i<=inb(ij)) THEN - dpinv = 0.01/(ph(ij,i)-ph(ij,i+1)) - 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 & - )) - ! (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 - ENDDO - ENDDO - DO k = i, nl + 1 - DO ij = 1, ncum - IF ((i<=inb(ij)) .AND. (k<=inb(ij))) THEN - dpinv = 0.01/(ph(ij,i)-ph(ij,i+1)) - 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 - ENDDO - ENDDO - DO ij = 1, ncum - IF (i<=inb(ij)) THEN - dpinv = 0.01/(ph(ij,i)-ph(ij,i+1)) - 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 - ! (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 - ! (particular case: no detraining level is found) ! cld - IF (nent(ij,i)==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)/=0.) THEN ! cld - qcond(ij, i) = qcond(ij, i)/nqcond(ij, i) ! cld - ENDIF ! cld - ENDIF - ENDDO -1500 ENDDO - - ! *** Adjust tendencies at top of convection layer to reflect *** - ! *** actual position of the level zero cape *** - - DO 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))/(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))/(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))/(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))/(ph(ij,inb(ij)-1)-ph(ij,inb(ij)))) - ENDDO - - ! *** Very slightly adjust tendencies to force exact *** - ! *** enthalpy, momentum and tracer conservation *** - - DO ij = 1, ncum - ents(ij) = 0.0 - uav(ij) = 0.0 - vav(ij) = 0.0 - DO 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)) - ENDDO - ENDDO - DO 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)) - ENDDO - DO ij = 1, ncum - DO 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)) - ENDDO - ENDDO - - DO k = 1, nl + 1 - DO i = 1, ncum - IF ((q(i,k)+delt*fq(i,k))<0.0) iflag(i) = 10 - ENDDO - ENDDO - - - DO i = 1, ncum - IF (iflag(i)>2) THEN - precip(i) = 0.0 - cbmf(i) = 0.0 - ENDIF - ENDDO - DO k = 1, nl - DO i = 1, ncum - IF (iflag(i)>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 - ENDDO - ENDDO - - 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 - - - ! *** diagnose the in-cloud mixing ratio *** ! cld - ! *** of condensed water *** ! cld - ! ! 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)>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)>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_yield - -SUBROUTINE cv_uncompress(nloc, len, ncum, nd, idcum, is_convect, compress, iflag, precip, cbmf, ft, & - fq, fu, fv, ma, qcondc, iflag1, precip1, cbmf1, ft1, fq1, fu1, fv1, ma1, & - qcondc1) - USE lmdz_cv_ini, ONLY : nl - IMPLICIT NONE - - - ! inputs: - INTEGER len, ncum, nd, nloc - INTEGER idcum(nloc) - LOGICAL is_convect(nloc) - LOGICAL compress - 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 - - ! 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 - - ! local variables: - INTEGER i, k - - IF (compress) THEN - DO i = 1, ncum - precip1(idcum(i)) = precip(i) - cbmf1(idcum(i)) = cbmf(i) - iflag1(idcum(i)) = iflag(i) - ENDDO - - DO k = 1, nl - DO 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) - ENDDO - ENDDO - ELSE - DO i = 1, len - IF (is_convect(i)) THEN - precip1(i) = precip(i) - cbmf1(i) = cbmf(i) - iflag1(i) = iflag(i) - ENDIF - ENDDO - - DO k = 1, nl - DO i = 1, ncum - IF (is_convect(i)) THEN - ft1(i, k) = ft(i, k) - fq1(i, k) = fq(i, k) - fu1(i, k) = fu(i, k) - fv1(i, k) = fv(i, k) - ma1(i, k) = ma(i, k) - qcondc1(i, k) = qcondc(i, k) - ENDIF - ENDDO - ENDDO - ENDIF - RETURN -END SUBROUTINE cv_uncompress - -END MODULE cv_routines_mod Index: LMDZ6/trunk/libf/phylmd/cv_routines_mod.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cv_routines_mod.f90 (revision 6048) +++ LMDZ6/trunk/libf/phylmd/cv_routines_mod.f90 (revision 6048) @@ -0,0 +1,1801 @@ + +! $Id$ +MODULE cv_routines_mod +PRIVATE + +PUBLIC cv_param, cv_prelim, cv_feed, cv_undilute1, cv_trigger, cv_compress, cv_undilute2, & + cv_closure, cv_mixing, cv_yield, cv_unsat, cv_uncompress + +CONTAINS + +SUBROUTINE cv_param(nd) + USE lmdz_cv_ini, ONLY : alpha,betad,coeffr,coeffs,cu,damp,delta,dtmax,elcrit,entp,minorig,nl,nlm,nlp,noff,omtrain,omtsnow,sigd,sigs,tlcrit + + IMPLICIT NONE + + ! ------------------------------------------------------------ + ! Set parameters for convectL + ! (includes microphysical parameters and parameters that + ! control the rate of approach to quasi-equilibrium) + ! ------------------------------------------------------------ + + ! *** ELCRIT IS THE AUTOCONVERSION THERSHOLD WATER CONTENT (gm/gm) *** + ! *** TLCRIT IS CRITICAL TEMPERATURE BELOW WHICH THE AUTO- *** + ! *** CONVERSION THRESHOLD IS ASSUMED TO BE ZERO *** + ! *** (THE AUTOCONVERSION THRESHOLD VARIES LINEARLY *** + ! *** BETWEEN 0 C AND TLCRIT) *** + ! *** ENTP IS THE COEFFICIENT OF MIXING IN THE ENTRAINMENT *** + ! *** FORMULATION *** + ! *** SIGD IS THE FRACTIONAL AREA COVERED BY UNSATURATED DNDRAFT *** + ! *** SIGS IS THE FRACTION OF PRECIPITATION FALLING OUTSIDE *** + ! *** OF CLOUD *** + ! *** OMTRAIN IS THE ASSUMED FALL SPEED (P/s) OF RAIN *** + ! *** OMTSNOW IS THE ASSUMED FALL SPEED (P/s) OF SNOW *** + ! *** COEFFR IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION *** + ! *** OF RAIN *** + ! *** COEFFS IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION *** + ! *** OF SNOW *** + ! *** CU IS THE COEFFICIENT GOVERNING CONVECTIVE MOMENTUM *** + ! *** TRANSPORT *** + ! *** DTMAX IS THE MAXIMUM NEGATIVE TEMPERATURE PERTURBATION *** + ! *** A LIFTED PARCEL IS ALLOWED TO HAVE BELOW ITS LFC *** + ! *** ALPHA AND DAMP ARE PARAMETERS THAT CONTROL THE RATE OF *** + ! *** APPROACH TO QUASI-EQUILIBRIUM *** + ! *** (THEIR STANDARD VALUES ARE 0.20 AND 0.1, RESPECTIVELY) *** + ! *** (DAMP MUST BE LESS THAN 1) *** + + INTEGER nd + CHARACTER (LEN=20) :: modname = 'cv_routines' + CHARACTER (LEN=80) :: abort_message + + ! noff: integer limit for convection (nd-noff) + ! 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 + + cu = 0.70 + + betad = 10.0 + + damp = 0.1 + alpha = 0.2 + + delta = 0.01 ! cld + + RETURN +END SUBROUTINE cv_param + +SUBROUTINE cv_prelim(len, nd, ndp1, t, q, p, ph, lv, cpn, tv, gz, h, hm) + USE lmdz_cv_ini, ONLY : cl,clmcpv,cpd,cpv,epsim1,hrd,lv0,nlp,t0 + + IMPLICIT NONE + + ! ===================================================================== + ! --- CALCULATE ARRAYS OF GEOPOTENTIAL, HEAT CAPACITY & STATIC ENERGY + ! ===================================================================== + + ! inputs: + INTEGER len, nd, ndp1 + REAL t(len, nd), q(len, nd), p(len, nd), ph(len, ndp1) + + ! outputs: + REAL lv(len, nd), cpn(len, nd), tv(len, nd) + REAL gz(len, nd), h(len, nd), hm(len, nd) + + ! local variables: + INTEGER k, i + REAL cpx(len, nd) + + DO k = 1, nlp + DO 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) + ENDDO + ENDDO + + ! gz = phi at the full levels (same as p). + + DO i = 1, len + gz(i, 1) = 0.0 + ENDDO + DO k = 2, nlp + DO 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) + ENDDO + ENDDO + + ! h = phi + cpT (dry static energy). + ! hm = phi + cp(T-Tbase)+Lq + + DO k = 1, nlp + DO 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) + ENDDO + ENDDO + + RETURN +END SUBROUTINE cv_prelim + +SUBROUTINE cv_feed(len, nd, t, q, qs, p, hm, gz, nk, icb, icbmax, iflag, tnk, & + qnk, gznk, plcl) + USE lmdz_cv_ini, ONLY : minorig,nl,nlm,nlp + + IMPLICIT NONE + + ! ================================================================ + ! Purpose: CONVECTIVE FEED + ! ================================================================ + + + ! inputs: + INTEGER len, nd + REAL t(len, nd), q(len, nd), qs(len, nd), p(len, nd) + REAL hm(len, nd), gz(len, nd) + + ! outputs: + INTEGER iflag(len), nk(len), icb(len), icbmax + REAL tnk(len), qnk(len), gznk(len), plcl(len) + + ! 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 i = 1, len + work(i) = 1.0E12 + ihmin(i) = nl + ENDDO + DO k = 2, nlp + DO i = 1, len + IF ((hm(i,k)work(i)) .AND. (k<=ihmin(i))) THEN + work(i) = hm(i, k) + nk(i) = k + ENDIF + ENDDO + ENDDO + ! ------------------------------------------------------------------- + ! --- Check whether parcel level temperature and specific humidity + ! --- are reasonable + ! ------------------------------------------------------------------- + DO i = 1, len + IF (((t(i,nk(i))<250.0) .OR. (q(i,nk(i))<=0.0) .OR. (p(i,ihmin(i))< & + 400.0)) .AND. (iflag(i)==0)) iflag(i) = 7 + ENDDO + ! ------------------------------------------------------------------- + ! --- Calculate lifted condensation level of air at parcel origin level + ! --- (Within 0.2% of formula of Bolton, MON. WEA. REV.,1980) + ! ------------------------------------------------------------------- + DO 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)) + + 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)<200.0) .OR. (plcl(i)>=2000.0)) .AND. (iflag(i)==0)) iflag(i & + ) = 8 + ENDDO + ! ------------------------------------------------------------------- + ! --- Calculate first level above lcl (=icb) + ! ------------------------------------------------------------------- + DO i = 1, len + icb(i) = nlm + ENDDO + + DO k = minorig, nl + DO i = 1, len + IF ((k>=(nk(i)+1)) .AND. (p(i,k)=nlm) .AND. (iflag(i)==0)) iflag(i) = 9 + ENDDO + + ! Compute icbmax. + !ym do not do that, independance between column + !ym icbmax = 2 + !ym DO i = 1, len + !ym icbmax = max(icbmax, icb(i)) + !ym END DO + + RETURN +END SUBROUTINE cv_feed + +SUBROUTINE cv_undilute1(len, nd, t, q, qs, gz, p, nk, icb, icbmax, tp, tvp, & + clw) + USE lmdz_cv_ini, ONLY : cl,clmcpv,cpd,cpv,eps,epsi,lv0,minorig,rrv,t0,nl + + IMPLICIT NONE + + ! 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) + + ! outputs: + REAL tp(len, nd), tvp(len, nd), clw(len, nd) + + ! 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 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)) + END DO + + ! *** Calculate certain parcel quantities, including static energy *** + + DO 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 + END DO + + ! *** Calculate lifted parcel quantities below cloud base *** + + !ym bad dependance between column => icbmax computed in cv_feed +!ym DO k = minorig, icbmax - 1 + DO k = minorig, nd + DO i = 1, len + IF (k <= MAX(2,icb(i))-1) THEN + tp(i, k) = tnk(i) - (gz(i,k)-gznk(i))/cpp(i) + tvp(i, k) = tp(i, k)*(1.+qnk(i)*epsi) + ENDIF + ENDDO + ENDDO + + ! *** Find lifted parcel quantities above cloud base *** + + DO i = 1, len + tg = ticb(i) + qg = qs(i, icb(i)) + alv = lv0 - clmcpv*(ticb(i)-t0) + + ! First iteration. + + 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>=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)) + + ! Second iteration. + + 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>=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)) + + 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) + ENDDO + + !ym bad dependance between column => ibmax computed in cv_feed +!ym DO k = minorig, icbmax + DO k = minorig, nd + DO i = 1, len + IF (k <= MAX(2,icb(i))) THEN + tvp(i, k) = tvp(i, k) - tp(i, k)*qnk(i) + ENDIF + ENDDO + ENDDO + + RETURN +END SUBROUTINE cv_undilute1 + +SUBROUTINE cv_trigger(len, nd, icb, cbmf, tv, tvp, iflag) + USE lmdz_cv_ini, ONLY : dtmax + 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. + ! ------------------------------------------------------------------- + + + ! inputs: + INTEGER len, nd, icb(len) + REAL cbmf(len), tv(len, nd), tvp(len, nd) + + ! outputs: + INTEGER iflag(len) ! also an input + + ! local variables: + INTEGER i + + + DO i = 1, len + IF ((cbmf(i)==0.0) .AND. (iflag(i)==0) .AND. (tvp(i, & + icb(i))<=(tv(i,icb(i))-dtmax))) iflag(i) = 4 + END DO + + RETURN +END SUBROUTINE cv_trigger + +SUBROUTINE cv_compress(len, nloc, ncum, nd, iflag1, compress, nk1, icb1, cbmf1, plcl1, & + tnk1, qnk1, gznk1, t1, q1, qs1, u1, v1, gz1, h1, lv1, cpn1, p1, ph1, tv1, & + tp1, tvp1, clw1, iflag, nk, icb, cbmf, plcl, tnk, qnk, gznk, t, q, qs, u, & + v, gz, h, lv, cpn, p, ph, tv, tp, tvp, clw, dph) + USE lmdz_cv_ini, ONLY : nl + USE print_control_mod, ONLY: lunout + IMPLICIT NONE + + + ! inputs: + INTEGER len, ncum, nd, nloc + INTEGER iflag1(len), nk1(len), icb1(len) + LOGICAL compress + 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) + + ! 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) + + ! local variables: + INTEGER i, k, nn + CHARACTER (LEN=20) :: modname = 'cv_compress' + CHARACTER (LEN=80) :: abort_message + + IF (compress) THEN + DO k = 1, nl + 1 + nn = 0 + DO i = 1, len + IF (iflag1(i)==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 + ENDDO + ENDDO + + IF (nn/=ncum) THEN + WRITE (lunout, *) 'strange! nn not equal to ncum: ', nn, ncum + abort_message = '' + CALL abort_physic(modname, abort_message, 1) + ENDIF + + nn = 0 + DO i = 1, len + IF (iflag1(i)==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 + ENDDO + + ELSE !compress + t(:, 1:nl+1) = t1(:, 1:nl+1) + q(:, 1:nl+1) = q1(:, 1:nl+1) + qs(:, 1:nl+1) = qs1(:, 1:nl+1) + u(:, 1:nl+1) = u1(:, 1:nl+1) + v(:, 1:nl+1) = v1(:, 1:nl+1) + gz(:, 1:nl+1) = gz1(:, 1:nl+1) + h(:, 1:nl+1) = h1(:, 1:nl+1) + lv(:, 1:nl+1) = lv1(:, 1:nl+1) + cpn(:, 1:nl+1) = cpn1(:, 1:nl+1) + p(:, 1:nl+1) = p1(:, 1:nl+1) + ph(:, 1:nl+1) = ph1(:, 1:nl+1) + tv(:, 1:nl+1) = tv1(:, 1:nl+1) + tp(:, 1:nl+1) = tp1(:, 1:nl+1) + tvp(:, 1:nl+1) = tvp1(:, 1:nl+1) + clw(:, 1:nl+1) = clw1(:, 1:nl+1) + + cbmf(:) = cbmf1(:) + plcl(:) = plcl1(:) + tnk(:) = tnk1(:) + qnk(:) = qnk1(:) + gznk(:) = gznk1(:) + nk(:) = nk1(:) + icb(:) = icb1(:) + iflag(:) = iflag1(:) + ENDIF + + DO k = 1, nl + DO i = 1, ncum + dph(i, k) = ph(i, k) - ph(i, k+1) + ENDDO + ENDDO + + RETURN +END SUBROUTINE cv_compress + +SUBROUTINE cv_undilute2(nloc, ncum, nd, icb, nk, tnk, qnk, gznk, t, q, qs, & + gz, p, dph, h, tv, lv, inb, inb1, tp, tvp, clw, hp, ep, sigp, frac) + USE lmdz_cv_ini, ONLY : nl,cl,clmcpv,cpd,cpv,elcrit,eps,epsi,lv0,minorig,nlp,rrv,sigs,t0,tlcrit + + IMPLICIT NONE + + ! --------------------------------------------------------------------- + ! Purpose: + ! 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 + ! --------------------------------------------------------------------- + + ! 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) + + ! 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) + + ! 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 k = 1, nl + DO i = 1, ncum + ep(i, k) = 0.0 + sigp(i, k) = sigs + ENDDO + ENDDO + + ! ===================================================================== + ! --- FIND THE REST OF THE LIFTED PARCEL TEMPERATURES + ! ===================================================================== + + ! --- The procedure is to solve the equation. + ! cp*tp+L*qp+phi=cp*tnk+L*qnk+gznk. + + ! *** Calculate certain parcel quantities, including static energy *** + + + DO i = 1, ncum + ah0(i) = (cpd*(1.-qnk(i))+cl*qnk(i))*tnk(i) + qnk(i)*(lv0-clmcpv*(tnk(i)- & + t0)) + gznk(i) + ENDDO + + + ! *** Find lifted parcel quantities above cloud base *** + + + DO k = minorig + 1, nl + DO i = 1, ncum + IF (k>=(icb(i)+1)) THEN + tg = t(i, k) + qg = qs(i, k) + alv = lv0 - clmcpv*(t(i,k)-t0) + + ! First iteration. + + 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>=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)) + + ! Second iteration. + + 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>=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)) + + alv = lv0 - clmcpv*(t(i,k)-t0) + ! print*,'cpd dans convect2 ',cpd + ! print*,'tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd' + ! 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 + ! if (.not.cpd.gt.1000.) then + ! print*,'CPD=',cpd + ! stop + ! 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 + ENDDO + ENDDO + + ! ===================================================================== + ! --- 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) + ! ===================================================================== + + DO k = minorig + 1, nl + DO i = 1, ncum + IF (k>=(nk(i)+1)) THEN + tca = tp(i, k) - t0 + IF (tca>=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 + ENDDO + ENDDO + + ! ===================================================================== + ! --- CALCULATE VIRTUAL TEMPERATURE AND LIFTED PARCEL + ! --- VIRTUAL TEMPERATURE + ! ===================================================================== + + DO k = minorig + 1, nl + DO i = 1, ncum + IF (k>=(icb(i)+1)) THEN + tvp(i, k) = tvp(i, k)*(1.0-qnk(i)+ep(i,k)*clw(i,k)) + ! print*,'i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)' + ! print*, i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k) + ENDIF + ENDDO + ENDDO + DO i = 1, ncum + tvp(i, nlp) = tvp(i, nl) - (gz(i,nlp)-gz(i,nl))/cpd + ENDDO + + ! ===================================================================== + ! --- FIND THE FIRST MODEL LEVEL (INB1) ABOVE THE PARCEL'S + ! --- HIGHEST LEVEL OF NEUTRAL BUOYANCY + ! --- AND THE HIGHEST LEVEL OF POSITIVE CAPE (INB) + ! ===================================================================== + + DO i = 1, ncum + cape(i) = 0.0 + capem(i) = 0.0 + inb(i) = icb(i) + 1 + inb1(i) = inb(i) + ENDDO + + ! Originial Code + + ! do 530 k=minorig+1,nl-1 + ! do 520 i=1,ncum + ! if(k.ge.(icb(i)+1))then + ! by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k) + ! byp=(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 + ! byp=(tvp(i,nl)-tv(i,nl))*dph(i,nl)/p(i,nl) + ! cape(i)=capem(i)+byp + ! 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 + + ! K Emanuel fix + + ! call zilch(byp,ncum) + ! do 530 k=minorig+1,nl-1 + ! do 520 i=1,ncum + ! if(k.ge.(icb(i)+1))then + ! by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k) + ! 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) + ! byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1) + ! endif + ! endif + ! 520 continue + ! 530 continue + ! do 540 i=1,ncum + ! inb(i)=max(inb(i),inb1(i)) + ! 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 + + ! J Teixeira fix + + byp(1:ncum) = 0 + + DO i = 1, ncum + lcape(i) = .TRUE. + ENDDO + DO k = minorig + 1, nl - 1 + DO i = 1, ncum + IF (cape(i)<0.0) lcape(i) = .FALSE. + IF ((k>=(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>=0.0) inb1(i) = k + 1 + IF (cape(i)>0.0) THEN + inb(i) = k + 1 + capem(i) = cape(i) + ENDIF + ENDIF + ENDDO + ENDDO + DO 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) + ENDDO + + ! ===================================================================== + ! --- CALCULATE LIQUID WATER STATIC ENERGY OF LIFTED PARCEL + ! ===================================================================== + + ! initialization: +!ym very bad +!ym DO i = 1, ncum*nlp +!ym hp(i, 1) = h(i, 1) +!ym END DO + DO k=1,nlp + DO i=1,ncum + hp(i, k) = h(i, k) + ENDDO + ENDDO + + DO k = minorig + 1, nl + DO i = 1, ncum + IF ((k>=icb(i)) .AND. (k<=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 + ENDDO + ENDDO + + RETURN +END SUBROUTINE cv_undilute2 + +SUBROUTINE cv_closure(nloc, ncum, nd, nk, icb, tv, tvp, p, ph, dph, plcl, & + cpn, iflag, cbmf) + USE lmdz_cv_ini, ONLY : alpha,damp,dtmax,minorig,rrd + + IMPLICIT NONE + + ! 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) + + ! outputs: + INTEGER iflag(nloc) + REAL cbmf(nloc) ! also an input + + ! local variables: + INTEGER i, k, icbmax + REAL dtpbl(nloc), dtmin(nloc), tvpplcl(nloc), tvaplcl(nloc) + REAL work(nloc) + + ! ------------------------------------------------------------------- + ! Compute icbmax. + ! ------------------------------------------------------------------- + +!ym independance between columns +!ym icbmax = 2 +!ym DO i = 1, ncum +!ym icbmax = max(icbmax, icb(i)) +!ym END DO + + ! ===================================================================== + ! --- CALCULATE CLOUD BASE MASS FLUX + ! ===================================================================== + + ! tvpplcl = parcel temperature lifted adiabatically from level + ! icb-1 to the LCL. + ! tvaplcl = virtual temperature at the LCL. + + DO 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)) + ENDDO + + ! ------------------------------------------------------------------- + ! --- Interpolate difference between lifted parcel and + ! --- environmental temperatures to lifted condensation level + ! ------------------------------------------------------------------- + + ! dtpbl = average of tvp-tv in the PBL (k=nk to icb-1). +!ym independance betwwen column +!ym DO k = minorig, icbmax + DO k = minorig, nd + DO i = 1, ncum + IF (k<=MAX(2,icb(i))) THEN + IF ((k>=nk(i)) .AND. (k<=(icb(i)-1))) THEN + dtpbl(i) = dtpbl(i) + (tvp(i,k)-tv(i,k))*dph(i, k) + ENDIF + ENDIF + ENDDO + ENDDO + DO i = 1, ncum + dtpbl(i) = dtpbl(i)/(ph(i,nk(i))-ph(i,icb(i))) + dtmin(i) = tvpplcl(i) - tvaplcl(i) + dtmax + dtpbl(i) + ENDDO + + ! ------------------------------------------------------------------- + ! --- Adjust cloud base mass flux + ! ------------------------------------------------------------------- + + DO 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)==0.0) .AND. (cbmf(i)==0.0)) THEN + iflag(i) = 3 + ENDIF + ENDDO + + RETURN +END SUBROUTINE cv_closure + +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) + USE lmdz_cv_ini, ONLY : cpd,cpv,entp,minorig,nl,nlp,rrv + + IMPLICIT NONE + + + ! 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) + + ! 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) + + ! 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) + + ! ===================================================================== + ! --- INITIALIZE VARIOUS ARRAYS USED IN THE COMPUTATIONS + ! ===================================================================== + +!ym very bad +!ym DO i = 1, ncum*nlp +!ym nent(i, 1) = 0 +!ym m(i, 1) = 0.0 +!ym END DO + DO k = 1, nlp + DO i = 1, ncum + nent(i, k) = 0 + m(i, k) = 0.0 + ENDDO + ENDDO + + DO k = 1, nlp + DO j = 1, nlp + DO 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 + ENDDO + ENDDO + ENDDO + + ! ------------------------------------------------------------------- + ! --- Calculate rates of mixing, m(i) + ! ------------------------------------------------------------------- + + work(1:ncum) = 0. + + DO j = minorig + 1, nl + DO i = 1, ncum + IF ((j>=(icb(i)+1)) .AND. (j<=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 + ENDDO + ENDDO + DO k = minorig + 1, nl + DO i = 1, ncum + IF ((k>=(icb(i)+1)) .AND. (k<=inb(i))) THEN + m(i, k) = m(i, k)/work(i) + ENDIF + ENDDO + ENDDO + + + ! ===================================================================== + ! --- CALCULATE ENTRAINED AIR MASS FLUX (ment), TOTAL WATER MIXING + ! --- RATIO (QENT), TOTAL CONDENSED WATER (elij), AND MIXING + ! --- FRACTION (sij) + ! ===================================================================== + + + DO i = minorig + 1, nl + DO j = minorig + 1, nl + DO ij = 1, ncum + IF ((i>=(icb(ij)+1)) .AND. (j>=icb(ij)) .AND. (i<=inb(ij)) .AND. (j<= & + 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)<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<0.0 .OR. stemp>1.0 .OR. altem>cwat) .AND. j>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)<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)>0.0 .AND. sij(ij,i,j)<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 + ENDDO + ENDDO + + ! *** If no air can entrain at level i assume that updraft detrains + ! *** + ! *** at that level and calculate detrained air flux and properties + ! *** + + DO ij = 1, ncum + IF ((i>=(icb(ij)+1)) .AND. (i<=inb(ij)) .AND. (nent(ij,i)==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 + ENDDO + ENDDO + + DO i = 1, ncum + sij(i, inb(i), inb(i)) = 1.0 + ENDDO + + ! ===================================================================== + ! --- NORMALIZE ENTRAINED AIR MASS FLUXES + ! --- TO REPRESENT EQUAL PROBABILITIES OF MIXING + ! ===================================================================== + + bsum(1:ncum,1:nlp) = 0. + DO ij = 1, ncum + lwork(ij) = .FALSE. + ENDDO + DO i = minorig + 1, nl !789 ENDDO + + num1 = 0 + DO ij = 1, ncum + IF ((i>=icb(ij)+1) .AND. (i<=inb(ij))) num1 = num1 + 1 + ENDDO +!ym IF (num1<=0) GO TO 789 + IF (num1<=0) CYCLE + + DO ij = 1, ncum + IF ((i>=icb(ij)+1) .AND. (i<=inb(ij))) THEN + lwork(ij) = (nent(ij,i)/=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)<0.01) denom = 0.01 + scrit(ij) = anum/denom + alt = qp1 - qs(ij, i) + scrit(ij)*(q(ij,i)-qp1) + IF (scrit(ij)<0.0 .OR. alt<0.0) scrit(ij) = 1.0 + asij(ij) = 0.0 + smin(ij) = 1.0 + ENDIF + ENDDO + DO j = minorig, nl ! 783 ENDDO + + num2 = 0 + DO ij = 1, ncum + IF ((i>=icb(ij)+1) .AND. (i<=inb(ij)) .AND. (j>=icb( & + ij)) .AND. (j<=inb(ij)) .AND. lwork(ij)) num2 = num2 + 1 + END DO +!ym IF (num2<=0) GO TO 783 + IF (num2<=0) CYCLE + + DO ij = 1, ncum + IF ((i>=icb(ij)+1) .AND. (i<=inb(ij)) .AND. (j>=icb( & + ij)) .AND. (j<=inb(ij)) .AND. lwork(ij)) THEN + IF (sij(ij,i,j)>0.0 .AND. sij(ij,i,j)<0.9) THEN + IF (j>i) THEN + smid = min(sij(ij,i,j), scrit(ij)) + sjmax = smid + sjmin = smid + IF (smid1) 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 + ENDDO +783 ENDDO + DO ij = 1, ncum + IF ((i>=icb(ij)+1) .AND. (i<=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 + ENDDO + DO j = minorig, nl + 1 + DO ij = 1, ncum + IF ((i>=icb(ij)+1) .AND. (i<=inb(ij)) .AND. (j>=icb( & + ij)) .AND. (j<=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 + ENDDO + ENDDO + DO ij = 1, ncum + IF ((i>=icb(ij)+1) .AND. (i<=inb(ij)) .AND. (bsum(ij, & + i)<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 + ENDDO +789 ENDDO + + RETURN +END SUBROUTINE cv_mixing + +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) + USE lmdz_cv_ini, ONLY : cl,coeffr,coeffs,cpd,g,ginv,nl,omtrain,omtsnow,sigd + + IMPLICIT NONE + + ! 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) + + ! 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) + + ! 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) + + ! ===================================================================== + ! --- PRECIPITATING DOWNDRAFT CALCULATION + ! ===================================================================== + + ! Initializations: + + 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 i = 1, ncum + qp(i, 1) = q(i, 1) + up(i, 1) = u(i, 1) + vp(i, 1) = v(i, 1) + ENDDO + + DO k = 2, nl + 1 + DO i = 1, ncum + qp(i, k) = q(i, k-1) + up(i, k) = u(i, k-1) + vp(i, k) = v(i, k-1) + ENDDO + ENDDO + + + ! *** Check whether ep(inb)=0, if so, skip precipitating *** + ! *** downdraft calculation *** + + + ! *** Integrate liquid water equation to find condensed water *** + ! *** and condensed water flux *** + + + DO i = 1, ncum + jtt(i) = 2 + IF (ep(i,inb(i))<=0.0001) iflag(i) = 2 + IF (iflag(i)==0) THEN + lwork(i) = .TRUE. + ELSE + lwork(i) = .FALSE. + ENDIF + ENDDO + + ! *** Begin downdraft loop *** + + + wdtrain(1:ncum) = 0. + DO i = nl + 1, 1, -1 ! 899 ENDDO + + num1 = 0 + DO ij = 1, ncum + IF ((i<=inb(ij)) .AND. lwork(ij)) num1 = num1 + 1 + END DO +!ym IF (num1<=0) GO TO 899 + IF (num1<=0) CYCLE + + + ! *** Calculate detrained precipitation *** + + DO ij = 1, ncum + IF ((i<=inb(ij)) .AND. (lwork(ij))) THEN + wdtrain(ij) = g*ep(ij, i)*m(ij, i)*clw(ij, i) + ENDIF + ENDDO + + IF (i>1) THEN + DO j = 1, i - 1 + DO ij = 1, ncum + IF ((i<=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 + ENDDO + ENDDO + ENDIF + + ! *** Find rain water and evaporation using provisional *** + ! *** estimates of qp(i)and qp(i-1) *** + + + ! *** Value of terminal velocity and coeffecient of evaporation for snow + ! *** + + DO ij = 1, ncum + IF ((i<=inb(ij)) .AND. (lwork(ij))) THEN + coeff = coeffs + wt(ij, i) = omtsnow + + ! *** Value of terminal velocity and coeffecient of evaporation for + ! rain *** + + IF (t(ij,i)>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 + + ! *** Calculate precipitating downdraft mass flux under *** + ! *** hydrostatic approximation *** + + IF (i>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) + + ! *** Add small amount of inertia to downdraft *** + + fac = 20.0/(ph(ij,i-1)-ph(ij,i)) + mp(ij, i) = (fac*mp(ij,i+1)+mp(ij,i))/(1.+fac) + + ! *** Force mp to decrease linearly to zero + ! *** + ! *** between about 950 mb and the surface + ! *** + + IF (p(ij,i)>(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 + + ! *** Find mixing ratio of precipitating downdraft *** + + IF (i/=inb(ij)) THEN + IF (i==1) THEN + qstm = qs(ij, 1) + ELSE + qstm = qs(ij, i-1) + ENDIF + IF (mp(ij,i)>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)>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 + ENDDO +899 ENDDO + + RETURN +END SUBROUTINE cv_unsat + +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, iflag, wd, qprime, tprime, & + precip, cbmf, ft, fq, fu, fv, ma, qcondc) + + USE lmdz_cv_ini, ONLY : g,lv0,nl,rrd,sigd,betad,cl,cpd,cpv,cu,delta + + IMPLICIT NONE + + ! 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) + + ! 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) + + ! 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 + + + ! -- initializations: + + delti = 1.0/delt + + DO i = 1, ncum + precip(i) = 0.0 + wd(i) = 0.0 + tprime(i) = 0.0 + qprime(i) = 0.0 + DO 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 + ENDDO + ENDDO + + + ! *** Calculate surface precipitation in mm/day *** + + DO i = 1, ncum + IF (iflag(i)<=1) THEN + ! c precip(i)=precip(i)+wt(i,1)*sigd*water(i,1)*3600.*24000. + ! c & /(rowl*g) + ! c precip(i)=precip(i)*delt/86400. + precip(i) = wt(i, 1)*sigd*water(i, 1)*86400/g + ENDIF + ENDDO + + + ! *** Calculate downdraft velocity scale and surface temperature and *** + ! *** water vapor fluctuations *** + + 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 + + ! *** Calculate tendencies of lowest level potential temperature *** + ! *** and mixing ratio *** + + DO i = 1, ncum + work(i) = 0.01/(ph(i,1)-ph(i,2)) + am(i) = 0.0 + ENDDO + DO k = 2, nl + DO i = 1, ncum + IF ((nk(i)==1) .AND. (k<=inb(i)) .AND. (nk(i)==1)) THEN + am(i) = am(i) + m(i, k) + ENDIF + ENDDO + ENDDO + DO i = 1, ncum + IF ((g*work(i)*am(i))>=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))) + ENDDO + DO j = 2, nl + DO i = 1, ncum + IF (j<=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 + ENDDO + ENDDO + + ! *** Calculate tendencies of potential temperature and mixing ratio *** + ! *** at levels above the lowest level *** + + ! *** First find the net saturated updraft and downdraft mass fluxes *** + ! *** through each level *** + + DO i = 2, nl + 1 ! 1500 ENDDO + + num1 = 0 + DO ij = 1, ncum + IF (i<=inb(ij)) num1 = num1 + 1 + ENDDO +!ym IF (num1<=0) GO TO 1500 + IF (num1<=0) CYCLE + + amp1(1:ncum)=0. + ad(1:ncum)=0. + + DO k = i + 1, nl + 1 + DO ij = 1, ncum + IF ((i>=nk(ij)) .AND. (i<=inb(ij)) .AND. (k<=(inb(ij)+1))) THEN + amp1(ij) = amp1(ij) + m(ij, k) + ENDIF + ENDDO + ENDDO + + DO k = 1, i + DO j = i + 1, nl + 1 + DO ij = 1, ncum + IF ((j<=(inb(ij)+1)) .AND. (i<=inb(ij))) THEN + amp1(ij) = amp1(ij) + ment(ij, k, j) + ENDIF + ENDDO + ENDDO + ENDDO + DO k = 1, i - 1 + DO j = i, nl + 1 + DO ij = 1, ncum + IF ((i<=inb(ij)) .AND. (j<=inb(ij))) THEN + ad(ij) = ad(ij) + ment(ij, j, k) + ENDIF + ENDDO + ENDDO + ENDDO + + DO ij = 1, ncum + IF (i<=inb(ij)) THEN + dpinv = 0.01/(ph(ij,i)-ph(ij,i+1)) + cpinv = 1.0/cpn(ij, i) + + 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 + ENDDO + DO k = 1, i - 1 + DO ij = 1, ncum + IF (i<=inb(ij)) THEN + dpinv = 0.01/(ph(ij,i)-ph(ij,i+1)) + 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 & + )) + ! (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 + ENDDO + ENDDO + DO k = i, nl + 1 + DO ij = 1, ncum + IF ((i<=inb(ij)) .AND. (k<=inb(ij))) THEN + dpinv = 0.01/(ph(ij,i)-ph(ij,i+1)) + 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 + ENDDO + ENDDO + DO ij = 1, ncum + IF (i<=inb(ij)) THEN + dpinv = 0.01/(ph(ij,i)-ph(ij,i+1)) + 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 + ! (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 + ! (particular case: no detraining level is found) ! cld + IF (nent(ij,i)==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)/=0.) THEN ! cld + qcond(ij, i) = qcond(ij, i)/nqcond(ij, i) ! cld + ENDIF ! cld + ENDIF + ENDDO +1500 ENDDO + + ! *** Adjust tendencies at top of convection layer to reflect *** + ! *** actual position of the level zero cape *** + + DO 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))/(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))/(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))/(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))/(ph(ij,inb(ij)-1)-ph(ij,inb(ij)))) + ENDDO + + ! *** Very slightly adjust tendencies to force exact *** + ! *** enthalpy, momentum and tracer conservation *** + + DO ij = 1, ncum + ents(ij) = 0.0 + uav(ij) = 0.0 + vav(ij) = 0.0 + DO 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)) + ENDDO + ENDDO + DO 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)) + ENDDO + DO ij = 1, ncum + DO 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)) + ENDDO + ENDDO + + DO k = 1, nl + 1 + DO i = 1, ncum + IF ((q(i,k)+delt*fq(i,k))<0.0) iflag(i) = 10 + ENDDO + ENDDO + + + DO i = 1, ncum + IF (iflag(i)>2) THEN + precip(i) = 0.0 + cbmf(i) = 0.0 + ENDIF + ENDDO + DO k = 1, nl + DO i = 1, ncum + IF (iflag(i)>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 + ENDDO + ENDDO + + 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 + + + ! *** diagnose the in-cloud mixing ratio *** ! cld + ! *** of condensed water *** ! cld + ! ! 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)>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)>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_yield + +SUBROUTINE cv_uncompress(nloc, len, ncum, nd, idcum, is_convect, compress, iflag, precip, cbmf, ft, & + fq, fu, fv, ma, qcondc, iflag1, precip1, cbmf1, ft1, fq1, fu1, fv1, ma1, & + qcondc1) + USE lmdz_cv_ini, ONLY : nl + IMPLICIT NONE + + + ! inputs: + INTEGER len, ncum, nd, nloc + INTEGER idcum(nloc) + LOGICAL is_convect(nloc) + LOGICAL compress + 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 + + ! 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 + + ! local variables: + INTEGER i, k + + IF (compress) THEN + DO i = 1, ncum + precip1(idcum(i)) = precip(i) + cbmf1(idcum(i)) = cbmf(i) + iflag1(idcum(i)) = iflag(i) + ENDDO + + DO k = 1, nl + DO 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) + ENDDO + ENDDO + ELSE + DO i = 1, len + IF (is_convect(i)) THEN + precip1(i) = precip(i) + cbmf1(i) = cbmf(i) + iflag1(i) = iflag(i) + ENDIF + ENDDO + + DO k = 1, nl + DO i = 1, ncum + IF (is_convect(i)) THEN + ft1(i, k) = ft(i, k) + fq1(i, k) = fq(i, k) + fu1(i, k) = fu(i, k) + fv1(i, k) = fv(i, k) + ma1(i, k) = ma(i, k) + qcondc1(i, k) = qcondc(i, k) + ENDIF + ENDDO + ENDDO + ENDIF + RETURN +END SUBROUTINE cv_uncompress + +END MODULE cv_routines_mod Index: LMDZ6/trunk/libf/phylmd/cva_driver.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cva_driver.f90 (revision 6047) +++ (revision ) @@ -1,1361 +1,0 @@ - -! $Id$ -!$gpum horizontal len nloc ncum klon -MODULE cva_driver_mod - PRIVATE - LOGICAL, SAVE :: debut = .TRUE. - !$OMP THREADPRIVATE(debut) - LOGICAL, SAVE :: never_compress=.FALSE. ! if true, compression is desactivated in convection - !$OMP THREADPRIVATE(never_compress) - - PUBLIC cva_driver_pre, cva_driver_post, cva_driver - -CONTAINS - -! called before cva_driver -SUBROUTINE cva_driver_pre(nd, k_upper, iflag_con, iflag_ice_thermo, ok_conserv_q, delt) -USE cv3_routines_mod, ONLY : cv3_routine_pre, cv3_param -USE cv_routines_mod, ONLY : cv_param -USE ioipsl_getin_p_mod, ONLY : getin_p -USE s2s -IMPLICIT NONE - INTEGER, INTENT (IN) :: nd - INTEGER, INTENT (IN) :: k_upper - INTEGER, INTENT (IN) :: iflag_con - INTEGER, INTENT (IN) :: iflag_ice_thermo - REAL, INTENT (IN) :: delt - LOGICAL, INTENT (IN) :: ok_conserv_q - - IF (debut) THEN - ! ------------------------------------------------------------------- - ! --- SET CONSTANTS AND PARAMETERS - ! ------------------------------------------------------------------- - - ! -- set simulation flags: - ! (common cvflag) - never_compress = .FALSE. - CALL getin_p("convection_no_compression",never_compress) - IF (s2s_gpu_activated()) never_compress = .TRUE. ! for GPU, compression must be disabled - CALL cv_flag(iflag_ice_thermo) - - ! -- set thermodynamical constants: - ! (common cvthermo) - - CALL cv_thermo(iflag_con) - - ! -- set convect parameters - - ! includes microphysical parameters and parameters that - ! control the rate of approach to quasi-equilibrium) - ! (common cvparam) - - IF (iflag_con==3) THEN - CALL cv3_param(nd, k_upper, delt) - END IF - - IF (iflag_con==4) THEN - CALL cv_param(nd) - END IF - - CALL cv3_routine_pre(ok_conserv_q) - ENDIF - -END SUBROUTINE cva_driver_pre - -!called after cva_driver -SUBROUTINE cva_driver_post -IMPLICIT NONE - IF (debut) THEN - debut=.FALSE. - ENDIF -END SUBROUTINE cva_driver_post - -!!SUBROUTINE cva_driver(len, nd, ndp1, ntra, nloc, k_upper, & !jyg: get rid of ntra -SUBROUTINE cva_driver(len, nd, ndp1, nloc, k_upper, & - iflag_con, iflag_mix, iflag_ice_thermo, iflag_clos, ok_conserv_q, & -!! delt, t1, q1, qs1, t1_wake, q1_wake, qs1_wake, s1_wake, & ! jyg - delt, comp_threshold, & ! jyg - t1, q1, qs1, t1_wake, q1_wake, qs1_wake, s1_wake, & ! jyg -!! u1, v1, tra1, & !jyg: get rid of ntra - u1, v1, & - p1, ph1, & - Ale1, Alp1, omega1, & - sig1feed1, sig2feed1, wght1, & -!! iflag1, ft1, fq1, fqcomp1, fu1, fv1, ftra1, & !jyg: get rid of ntra - iflag1, ft1, fq1, fqcomp1, fu1, fv1, & - precip1, kbas1, ktop1, & - cbmf1, plcl1, plfc1, wbeff1, & - sig1, w01, & !input/output - ptop21, sigd1, & - ma1, mip1, Vprecip1, Vprecipi1, upwd1, dnwd1, dnwd01, & ! jyg - qcondc1, wd1, & - cape1, cin1, tvp1, & - ftd1, fqd1, & - Plim11, Plim21, asupmax1, supmax01, asupmaxmin1, & - coef_clos1, coef_clos_eff1, & - lalim_conv1, & -!! da1,phi1,mp1,phi21,d1a1,dam1,sigij1,clw1, & ! RomP -!! elij1,evap1,ep1,epmlmMm1,eplaMm1, & ! RomP - da1, phi1, mp1, phi21, d1a1, dam1, sigij1, wghti1, & ! RomP, RL - qta1, clw1, elij1, evap1, ep1, epmlmMm1, eplaMm1, & ! RomP, RL - wdtrainA1, wdtrainS1, wdtrainM1, qtc1, sigt1, detrain1, tau_cld_cv, & !!jygprl - coefw_cld_cv, & ! RomP, AJ - epmax_diag1) ! epmax_cape -! ************************************************************** -! * -! CV_DRIVER * -! * -! * -! written by : Sandrine Bony-Lena , 17/05/2003, 11.19.41 * -! modified by : * -! ************************************************************** -! ************************************************************** - - USE print_control_mod, ONLY: prt_level, lunout - USE add_phys_tend_mod, ONLY: fl_cor_ebil - USE cv3_routines_mod - USE cv_routines_mod - USE cv3a_compress_mod, ONLY : cv3a_compress - USE cv3p_mixing_mod, ONLY : cv3p_mixing - USE cv3p1_closure_mod, ONLY : cv3p1_closure - USE cv3p2_closure_mod, ONLY : cv3p2_closure - USE cv3_mixscale_mod, ONLY : cv3_mixscale - USE cv3a_uncompress_mod, ONLY : cv3a_uncompress - USE cv3_enthalpmix_mod, ONLY : cv3_enthalpmix - USE cv3_estatmix_mod, ONLY : cv3_estatmix - IMPLICIT NONE - -! .............................START PROLOGUE............................ - - -! All argument names (except len,nd,nloc,delt and the flags) have a "1" appended. -! The "1" is removed for the corresponding compressed variables. -! PARAMETERS: -! Name Type Usage Description -! ---------- ---------- ------- ---------------------------- - -! len Integer Input first (i) dimension -! nd Integer Input vertical (k) dimension -! ndp1 Integer Input nd + 1 -! nloc Integer Input dimension of arrays for compressed fields -! k_upper Integer Input upmost level for vertical loops -! iflag_con Integer Input version of convect (3/4) -! iflag_mix Integer Input version of mixing (0/1/2) -! iflag_ice_thermo Integer Input accounting for ice thermodynamics (0/1) -! iflag_clos Integer Input version of closure (0/1) -! tau_cld_cv Real Input characteristic time of dissipation of mixing fluxes -! coefw_cld_cv Real Input coefficient for updraft velocity in convection -! ok_conserv_q Logical Input when true corrections for water conservation are swtiched on -! delt Real Input time step -! comp_threshold Real Input threshold on the fraction of convective points below which -! fields are compressed -! t1 Real Input temperature (sat draught envt) -! q1 Real Input specific hum (sat draught envt) -! qs1 Real Input sat specific hum (sat draught envt) -! t1_wake Real Input temperature (unsat draught envt) -! q1_wake Real Input specific hum(unsat draught envt) -! qs1_wake Real Input sat specific hum(unsat draughts envt) -! s1_wake Real Input fractionnal area covered by wakes -! u1 Real Input u-wind -! v1 Real Input v-wind -! p1 Real Input full level pressure -! ph1 Real Input half level pressure -! ALE1 Real Input Available lifting Energy -! ALP1 Real Input Available lifting Power -! sig1feed1 Real Input sigma coord at lower bound of feeding layer -! sig2feed1 Real Input sigma coord at upper bound of feeding layer -! wght1 Real Input weight density determining the feeding mixture -! iflag1 Integer Output flag for Emanuel conditions -! ft1 Real Output temp tend -! fq1 Real Output spec hum tend -! fqcomp1 Real Output spec hum tend (only mixed draughts) -! fu1 Real Output u-wind tend -! fv1 Real Output v-wind tend -! precip1 Real Output precipitation -! kbas1 Integer Output cloud base level -! ktop1 Integer Output cloud top level -! cbmf1 Real Output cloud base mass flux -! sig1 Real In/Out section adiabatic updraft -! w01 Real In/Out vertical velocity within adiab updraft -! ptop21 Real In/Out top of entraining zone -! Ma1 Real Output mass flux adiabatic updraft -! mip1 Real Output mass flux shed by the adiabatic updraft -! Vprecip1 Real Output vertical profile of total precipitation -! Vprecipi1 Real Output vertical profile of ice precipitation -! upwd1 Real Output total upward mass flux (adiab+mixed) -! dnwd1 Real Output saturated downward mass flux (mixed) -! dnwd01 Real Output unsaturated downward mass flux -! qcondc1 Real Output in-cld mixing ratio of condensed water -! wd1 Real Output downdraft velocity scale for sfc fluxes -! cape1 Real Output CAPE -! cin1 Real Output CIN -! tvp1 Real Output adiab lifted parcell virt temp -! ftd1 Real Output precip temp tend -! fqt1 Real Output precip spec hum tend -! Plim11 Real Output -! Plim21 Real Output -! asupmax1 Real Output -! supmax01 Real Output -! asupmaxmin1 Real Output - -! ftd1 Real Output Array of temperature tendency due to precipitations (K/s) of dimension ND, -! defined at same grid levels as T, Q, QS and P. - -! fqd1 Real Output Array of specific humidity tendencies due to precipitations ((gm/gm)/s) -! of dimension ND, defined at same grid levels as T, Q, QS and P. - -! wdtrainA1 Real Output precipitation ejected from adiabatic draught; -! should be used in tracer transport (cvltr) -! wdtrainS1 Real Output precipitation detrained from shedding of adiabatic draught; -! used in tracer transport (cvltr) -! wdtrainM1 Real Output precipitation detrained from mixed draughts; -! used in tracer transport (cvltr) -! da1 Real Output used in tracer transport (cvltr) -! phi1 Real Output used in tracer transport (cvltr) -! mp1 Real Output used in tracer transport (cvltr) -! qtc1 Real Output specific humidity in convection -! sigt1 Real Output surface fraction in adiabatic updrafts -! detrain1 Real Output detrainment terme klein -! phi21 Real Output used in tracer transport (cvltr) - -! d1a1 Real Output used in tracer transport (cvltr) -! dam1 Real Output used in tracer transport (cvltr) - -! epmlmMm1 Real Output used in tracer transport (cvltr) -! eplaMm1 Real Output used in tracer transport (cvltr) - -! evap1 Real Output -! ep1 Real Output -! sigij1 Real Output used in tracer transport (cvltr) -! clw1 Real Output condensed water content of the adiabatic updraught -! elij1 Real Output -! wghti1 Real Output final weight of the feeding layers, -! used in tracer transport (cvltr) - - -! S. Bony, Mar 2002: -! * Several modules corresponding to different physical processes -! * Several versions of convect may be used: -! - iflag_con=3: version lmd (previously named convect3) -! - iflag_con=4: version 4.3b (vect. version, previously convect1/2) -! + tard: - iflag_con=5: version lmd with ice (previously named convectg) -! S. Bony, Oct 2002: -! * Vectorization of convect3 (ie version lmd) - -! ..............................END PROLOGUE............................. - - - -! Input - INTEGER, INTENT (IN) :: len - INTEGER, INTENT (IN) :: nd - INTEGER, INTENT (IN) :: ndp1 -!! INTEGER, INTENT (IN) :: ntra !jyg: get rid of ntra - INTEGER, INTENT(IN) :: nloc ! (nloc=len) pour l'instant - INTEGER, INTENT (IN) :: k_upper - INTEGER, INTENT (IN) :: iflag_con - INTEGER, INTENT (IN) :: iflag_mix - INTEGER, INTENT (IN) :: iflag_ice_thermo - INTEGER, INTENT (IN) :: iflag_clos - LOGICAL, INTENT (IN) :: ok_conserv_q - REAL, INTENT (IN) :: tau_cld_cv - REAL, INTENT (IN) :: coefw_cld_cv - REAL, INTENT (IN) :: delt - REAL, INTENT (IN) :: comp_threshold - REAL, DIMENSION (len, nd), INTENT (IN) :: t1 - REAL, DIMENSION (len, nd), INTENT (IN) :: q1 - REAL, DIMENSION (len, nd), INTENT (IN) :: qs1 - REAL, DIMENSION (len, nd), INTENT (IN) :: t1_wake - REAL, DIMENSION (len, nd), INTENT (IN) :: q1_wake - REAL, DIMENSION (len, nd), INTENT (IN) :: qs1_wake - REAL, DIMENSION (len), INTENT (IN) :: s1_wake - REAL, DIMENSION (len, nd), INTENT (IN) :: u1 - REAL, DIMENSION (len, nd), INTENT (IN) :: v1 -!! REAL, DIMENSION (len, nd, ntra), INTENT (IN) :: tra1 !jyg: get rid of ntra - REAL, DIMENSION (len, nd), INTENT (IN) :: p1 - REAL, DIMENSION (len, ndp1), INTENT (IN) :: ph1 - REAL, DIMENSION (len), INTENT (IN) :: Ale1 - REAL, DIMENSION (len), INTENT (IN) :: Alp1 - REAL, DIMENSION (len, nd), INTENT (IN) :: omega1 - REAL, INTENT (IN) :: sig1feed1 ! pressure at lower bound of feeding layer - REAL, INTENT (IN) :: sig2feed1 ! pressure at upper bound of feeding layer - REAL, DIMENSION (nd), INTENT (IN) :: wght1 ! weight density determining the feeding mixture - INTEGER, DIMENSION (len), INTENT (IN) :: lalim_conv1 - -! Input/Output - REAL, DIMENSION (len, nd), INTENT (INOUT) :: sig1 - REAL, DIMENSION (len, nd), INTENT (INOUT) :: w01 - -! Output - INTEGER, DIMENSION (len), INTENT (OUT) :: iflag1 - REAL, DIMENSION (len, nd), INTENT (OUT) :: ft1 - REAL, DIMENSION (len, nd), INTENT (OUT) :: fq1 - REAL, DIMENSION (len, nd), INTENT (OUT) :: fqcomp1 - REAL, DIMENSION (len, nd), INTENT (OUT) :: fu1 - REAL, DIMENSION (len, nd), INTENT (OUT) :: fv1 -!! REAL, DIMENSION (len, nd, ntra), INTENT (OUT) :: ftra1 !jyg: get rid of ntra - REAL, DIMENSION (len), INTENT (OUT) :: precip1 - INTEGER, DIMENSION (len), INTENT (OUT) :: kbas1 - INTEGER, DIMENSION (len), INTENT (OUT) :: ktop1 - REAL, DIMENSION (len), INTENT (OUT) :: cbmf1 - REAL, DIMENSION (len), INTENT (OUT) :: plcl1 - REAL, DIMENSION (len), INTENT (OUT) :: plfc1 - REAL, DIMENSION (len), INTENT (OUT) :: wbeff1 - REAL, DIMENSION (len), INTENT (OUT) :: ptop21 - REAL, DIMENSION (len), INTENT (OUT) :: sigd1 - REAL, DIMENSION (len, nd), INTENT (OUT) :: ma1 ! adiab. asc. mass flux (staggered grid) - REAL, DIMENSION (len, nd), INTENT (OUT) :: mip1 ! mass flux shed from adiab. ascent (extensive) -! real Vprecip1(len,nd) - REAL, DIMENSION (len, ndp1), INTENT (OUT) :: vprecip1 ! tot precipitation flux (staggered grid) - REAL, DIMENSION (len, ndp1), INTENT (OUT) :: vprecipi1 ! ice precipitation flux (staggered grid) - REAL, DIMENSION (len, nd), INTENT (OUT) :: upwd1 ! upwd sat. mass flux (staggered grid) - REAL, DIMENSION (len, nd), INTENT (OUT) :: dnwd1 ! dnwd sat. mass flux (staggered grid) - REAL, DIMENSION (len, nd), INTENT (OUT) :: dnwd01 ! unsat. mass flux (staggered grid) - REAL, DIMENSION (len, nd), INTENT (OUT) :: qcondc1 ! max cloud condensate (intensive) ! cld - REAL, DIMENSION (len), INTENT (OUT) :: wd1 ! gust - REAL, DIMENSION (len), INTENT (OUT) :: cape1 - REAL, DIMENSION (len), INTENT (OUT) :: cin1 - REAL, DIMENSION (len, nd), INTENT (OUT) :: tvp1 ! Virt. temp. in the adiab. ascent - -!AC! -!! real da1(len,nd),phi1(len,nd,nd) -!! real da(len,nd),phi(len,nd,nd) -!AC! - REAL, DIMENSION (len, nd), INTENT (OUT) :: ftd1 ! Temp. tendency due to the sole unsat. drafts - REAL, DIMENSION (len, nd), INTENT (OUT) :: fqd1 ! Moist. tendency due to the sole unsat. drafts - REAL, DIMENSION (len), INTENT (OUT) :: Plim11 - REAL, DIMENSION (len), INTENT (OUT) :: Plim21 - REAL, DIMENSION (len, nd), INTENT (OUT) :: asupmax1 ! Highest mixing fraction of mixed updraughts - REAL, DIMENSION (len), INTENT (OUT) :: supmax01 - REAL, DIMENSION (len), INTENT (OUT) :: asupmaxmin1 - REAL, DIMENSION (len), INTENT (OUT) :: coef_clos1, coef_clos_eff1 - REAL, DIMENSION (len, nd), INTENT (OUT) :: qtc1 ! in cloud water content (intensive) ! cld - REAL, DIMENSION (len, nd), INTENT (OUT) :: sigt1 ! fract. cloud area (intensive) ! cld - REAL, DIMENSION (len, nd), INTENT (OUT) :: detrain1 ! detrainement term of mixed draughts in environment - -! RomP >>> - REAL, DIMENSION (len, nd), INTENT (OUT) :: wdtrainA1, wdtrainS1, wdtrainM1 ! precipitation sources (extensive) - REAL, DIMENSION (len, nd), INTENT (OUT) :: mp1 ! unsat. mass flux (staggered grid) - REAL, DIMENSION (len, nd), INTENT (OUT) :: da1 ! detrained mass flux of adiab. asc. air (extensive) - REAL, DIMENSION (len, nd, nd), INTENT (OUT) :: phi1 ! mass flux of envt. air in mixed draughts (extensive) - REAL, DIMENSION (len, nd, nd), INTENT (OUT) :: epmlmMm1 ! (extensive) - REAL, DIMENSION (len, nd), INTENT (OUT) :: eplaMm1 ! (extensive) - REAL, DIMENSION (len, nd), INTENT (OUT) :: evap1 ! evaporation rate in precip. downdraft. (intensive) - REAL, DIMENSION (len, nd), INTENT (OUT) :: ep1 - REAL, DIMENSION (len, nd, nd), INTENT (OUT) :: sigij1 ! mass fraction of env. air in mixed draughts (intensive) - REAL, DIMENSION (len, nd, nd), INTENT (OUT) :: elij1! cond. water per unit mass of mixed draughts (intensive) - REAL, DIMENSION (len, nd), INTENT (OUT) :: qta1 ! total water per unit mass of the adiab. asc. (intensive) - REAL, DIMENSION (len, nd), INTENT (OUT) :: clw1 ! cond. water per unit mass of the adiab. asc. (intensive) -!JYG,RL - REAL, DIMENSION (len, nd), INTENT (OUT) :: wghti1 ! final weight of the feeding layers (extensive) -!JYG,RL - REAL, DIMENSION (len, nd, nd), INTENT (OUT) :: phi21 ! (extensive) - REAL, DIMENSION (len, nd), INTENT (OUT) :: d1a1 ! (extensive) - REAL, DIMENSION (len, nd), INTENT (OUT) :: dam1 ! (extensive) -! RomP <<< - REAL, DIMENSION (len ), INTENT (OUT) :: epmax_diag1 - -! ------------------------------------------------------------------- -! Prolog by Kerry Emanuel. -! ------------------------------------------------------------------- -! --- ARGUMENTS -! ------------------------------------------------------------------- -! --- On input: - -! t: Array of absolute temperature (K) of dimension ND, with first -! index corresponding to lowest model level. Note that this array -! will be altered by the subroutine if dry convective adjustment -! occurs and if IPBL is not equal to 0. - -! q: Array of specific humidity (gm/gm) of dimension ND, with first -! index corresponding to lowest model level. Must be defined -! at same grid levels as T. Note that this array will be altered -! if dry convective adjustment occurs and if IPBL is not equal to 0. - -! qs: Array of saturation specific humidity of dimension ND, with first -! index corresponding to lowest model level. Must be defined -! at same grid levels as T. Note that this array will be altered -! if dry convective adjustment occurs and if IPBL is not equal to 0. - -! t_wake: Array of absolute temperature (K), seen by unsaturated draughts, -! of dimension ND, with first index corresponding to lowest model level. - -! q_wake: Array of specific humidity (gm/gm), seen by unsaturated draughts, -! of dimension ND, with first index corresponding to lowest model level. -! Must be defined at same grid levels as T. - -! qs_wake: Array of saturation specific humidity, seen by unsaturated draughts, -! of dimension ND, with first index corresponding to lowest model level. -! Must be defined at same grid levels as T. - -! s_wake: Array of fractionnal area occupied by the wakes. - -! u: Array of zonal wind velocity (m/s) of dimension ND, witth first -! index corresponding with the lowest model level. Defined at -! same levels as T. Note that this array will be altered if -! dry convective adjustment occurs and if IPBL is not equal to 0. - -! v: Same as u but for meridional velocity. - -! p: Array of pressure (mb) of dimension ND, with first -! index corresponding to lowest model level. Must be defined -! at same grid levels as T. - -! ph: Array of pressure (mb) of dimension ND+1, with first index -! corresponding to lowest level. These pressures are defined at -! levels intermediate between those of P, T, Q and QS. The first -! value of PH should be greater than (i.e. at a lower level than) -! the first value of the array P. - -! ALE: Available lifting Energy - -! ALP: Available lifting Power - -! nl: The maximum number of levels to which convection can penetrate, plus 1. -! NL MUST be less than or equal to ND-1. - -! delt: The model time step (sec) between calls to CONVECT - -! ---------------------------------------------------------------------------- -! --- On Output: - -! iflag: An output integer whose value denotes the following: -! VALUE INTERPRETATION -! ----- -------------- -! 0 Moist convection occurs. -! 1 Moist convection occurs, but a CFL condition -! on the subsidence warming is violated. This -! does not cause the scheme to terminate. -! 2 Moist convection, but no precip because ep(inb) lt 0.0001 -! 3 No moist convection because new cbmf is 0 and old cbmf is 0. -! 4 No moist convection; atmosphere is not -! unstable -! 6 No moist convection because ihmin le minorig. -! 7 No moist convection because unreasonable -! parcel level temperature or specific humidity. -! 8 No moist convection: lifted condensation -! level is above the 200 mb level. -! 9 No moist convection: cloud base is higher -! then the level NL-1. -! 10 No moist convection: cloud top is too warm. -! 14 No moist convection; atmosphere is very -! stable (=> no computation) -! - -! ft: Array of temperature tendency (K/s) of dimension ND, defined at same -! grid levels as T, Q, QS and P. - -! fq: Array of specific humidity tendencies ((gm/gm)/s) of dimension ND, -! defined at same grid levels as T, Q, QS and P. - -! fu: Array of forcing of zonal velocity (m/s^2) of dimension ND, -! defined at same grid levels as T. - -! fv: Same as FU, but for forcing of meridional velocity. - -! precip: Scalar convective precipitation rate (mm/day). - -! wd: A convective downdraft velocity scale. For use in surface -! flux parameterizations. See convect.ps file for details. - -! tprime: A convective downdraft temperature perturbation scale (K). -! For use in surface flux parameterizations. See convect.ps -! file for details. - -! qprime: A convective downdraft specific humidity -! perturbation scale (gm/gm). -! For use in surface flux parameterizations. See convect.ps -! file for details. - -! cbmf: The cloud base mass flux ((kg/m**2)/s). THIS SCALAR VALUE MUST -! BE STORED BY THE CALLING PROGRAM AND RETURNED TO CONVECT AT -! ITS NEXT CALL. That is, the value of CBMF must be "remembered" -! by the calling program between calls to CONVECT. - -! det: Array of detrainment mass flux of dimension ND. -! ------------------------------------------------------------------- - -! Local (non compressed) arrays - - - INTEGER i, k, il - INTEGER nword1, nword2, nword3, nword4 - INTEGER icbmax - INTEGER nk1(len) - INTEGER icb1(len) - INTEGER icbs1(len) - - LOGICAL ok_inhib ! True => possible inhibition of convection by dryness - - REAL coef_convective(len) ! = 1 for convective points, = 0 otherwise - REAL tnk1(len) - REAL thnk1(len) - REAL qnk1(len) - REAL gznk1(len) - REAL qsnk1(len) - REAL unk1(len) - REAL vnk1(len) - REAL cpnk1(len) - REAL hnk1(len) - REAL pbase1(len) - REAL buoybase1(len) - - REAL lf1(len, nd), lf1_wake(len, nd) - REAL lv1(len, nd), lv1_wake(len, nd) - REAL cpn1(len, nd), cpn1_wake(len, nd) - REAL tv1(len, nd), tv1_wake(len, nd) - REAL gz1(len, nd), gz1_wake(len, nd) - REAL hm1(len, nd) - REAL h1(len, nd), h1_wake(len, nd) - REAL tp1(len, nd) - REAL th1(len, nd), th1_wake(len, nd) - - REAL bid(len, nd) ! dummy array - - INTEGER ncum - - REAL p1feed1(len) ! pressure at lower bound of feeding layer - REAL p2feed1(len) ! pressure at upper bound of feeding layer -!JYG,RL -!! real wghti1(len,nd) ! weights of the feeding layers -!JYG,RL - -! (local) compressed fields: - - - INTEGER idcum(nloc) -!jyg< - LOGICAL compress ! True if compression occurs -!>jyg - INTEGER iflag(nloc), nk(nloc), icb(nloc) - INTEGER nent(nloc, nd) - INTEGER icbs(nloc) - INTEGER inb(nloc), inbis(nloc) - - REAL cbmf(nloc), plcl(nloc), plfc(nloc), wbeff(nloc) - REAL t(nloc, nd), q(nloc, nd), qs(nloc, nd) - REAL t_wake(nloc, nd), q_wake(nloc, nd), qs_wake(nloc, nd) - REAL s_wake(nloc) - REAL u(nloc, nd), v(nloc, nd) - REAL gz(nloc, nd), h(nloc, nd) - REAL h_wake(nloc, nd) - REAL lv(nloc, nd), lf(nloc, nd), cpn(nloc, nd) - REAL lv_wake(nloc, nd), lf_wake(nloc, nd), cpn_wake(nloc, nd) - REAL p(nloc, nd), ph(nloc, nd+1), tv(nloc, nd), tp(nloc, nd) - REAL tv_wake(nloc, nd) - REAL clw(nloc, nd) - REAL, DIMENSION(nloc, nd) :: qta, qpreca !!jygprl - REAL dph(nloc, nd) - REAL pbase(nloc), buoybase(nloc), th(nloc, nd) - REAL th_wake(nloc, nd) - REAL tvp(nloc, nd) - REAL sig(nloc, nd), w0(nloc, nd), ptop2(nloc) - REAL hp(nloc, nd), ep(nloc, nd), sigp(nloc, nd) - REAL buoy(nloc, nd) - REAL cape(nloc) - REAL cin(nloc) - REAL m(nloc, nd) - REAL mm(nloc, nd) - REAL ment(nloc, nd, nd), sigij(nloc, nd, nd) - REAL qent(nloc, nd, nd) - REAL hent(nloc, nd, nd) - REAL uent(nloc, nd, nd), vent(nloc, nd, nd) -!! REAL ments(nloc, nd, nd), qents(nloc, nd, nd) !jyg: get rid of ments - REAL elij(nloc, nd, nd) - REAL supmax(nloc, nd) - REAL Ale(nloc), Alp(nloc), coef_clos(nloc), coef_clos_eff(nloc) - REAL omega(nloc,nd) - REAL sigd(nloc) -! real mp(nloc,nd), qp(nloc,nd), up(nloc,nd), vp(nloc,nd) -! real wt(nloc,nd), water(nloc,nd), evap(nloc,nd), ice(nloc,nd) -! real b(nloc,nd), sigd(nloc) -! save mp,qp,up,vp,wt,water,evap,b - REAL, DIMENSION(len,nd) :: mp, qp, up, vp - REAL, DIMENSION(len,nd) :: wt, water, evap - REAL, DIMENSION(len,nd) :: ice, fondue, b - REAL, DIMENSION(len,nd) :: frac_a, frac_s, faci !!jygprl - REAL ft(nloc, nd), fq(nloc, nd), fqcomp(nloc, nd) - REAL ftd(nloc, nd), fqd(nloc, nd) - REAL fu(nloc, nd), fv(nloc, nd) - REAL upwd(nloc, nd), dnwd(nloc, nd), dnwd0(nloc, nd) - REAL ma(nloc, nd), mip(nloc, nd) -!! REAL tls(nloc, nd), tps(nloc, nd) ! unused . jyg - REAL qprime(nloc), tprime(nloc) - REAL precip(nloc) -! real Vprecip(nloc,nd) - REAL vprecip(nloc, nd+1) - REAL vprecipi(nloc, nd+1) -!! REAL tra(nloc, nd, ntra), trap(nloc, nd, ntra) !jyg: get rid of ntra -!! REAL ftra(nloc, nd, ntra), traent(nloc, nd, nd, ntra) !jyg: get rid of ntra - REAL qcondc(nloc, nd) ! cld - REAL wd(nloc) ! gust - REAL Plim1(nloc), plim2(nloc) - REAL asupmax(nloc, nd) - REAL supmax0(nloc) - REAL asupmaxmin(nloc) - - REAL tnk(nloc), qnk(nloc), gznk(nloc) - REAL wghti(nloc, nd) - REAL hnk(nloc), unk(nloc), vnk(nloc) - - REAL qtc(nloc, nd) ! cld - REAL sigt(nloc, nd) ! cld - REAL detrain(nloc, nd) ! cld - -! RomP >>> - REAL wdtrainA(nloc, nd), wdtrainS(nloc, nd), wdtrainM(nloc, nd) !!jygprl - REAL da(len, nd), phi(len, nd, nd) - REAL epmlmMm(nloc, nd, nd), eplaMm(nloc, nd) - REAL phi2(len, nd, nd) - REAL d1a(len, nd), dam(len, nd) -! RomP <<< - REAL epmax_diag(nloc) ! epmax_cape - - CHARACTER (LEN=20), PARAMETER :: modname = 'cva_driver' - CHARACTER (LEN=80) :: abort_message - - REAL, PARAMETER :: Cin_noconv = -100000. - REAL, PARAMETER :: Cape_noconv = -1. - - INTEGER, PARAMETER :: igout=1 - LOGICAL :: is_convect(len) ! is convection is active on column - -! print *, 't1, t1_wake ',(k,t1(1,k),t1_wake(1,k),k=1,nd) -! print *, 'q1, q1_wake ',(k,q1(1,k),q1_wake(1,k),k=1,nd) - - - -! --------------------------------------------------------------------- -! --- INITIALIZE OUTPUT ARRAYS AND PARAMETERS -! --------------------------------------------------------------------- - nword1 = len - nword2 = len*nd -!! nword3 = len*nd*ntra !jyg: get rid of ntra - nword4 = len*nd*nd - - iflag1(:) = 0 - ktop1(:) = 0 - kbas1(:) = 0 - ft1(:, :) = 0.0 - fq1(:, :) = 0.0 - fqcomp1(:, :) = 0.0 - fu1(:, :) = 0.0 - fv1(:, :) = 0.0 -!! ftra1(:, :, :) = 0. !jyg: get rid of ntra - precip1(:) = 0. - cbmf1(:) = 0. - plcl1(:) = 0. - plfc1(:) = 0. - wbeff1(:) = 0. - ptop21(:) = 0. - sigd1(:) = 0. - ma1(:, :) = 0. - mip1(:, :) = 0. - vprecip1(:, :) = 0. - vprecipi1(:, :) = 0. - upwd1(:, :) = 0. - dnwd1(:, :) = 0. - dnwd01(:, :) = 0. - qcondc1(:, :) = 0. - wd1(:) = 0. - cape1(:) = 0. - cin1(:) = 0. - tvp1(:, :) = 0. - ftd1(:, :) = 0. - fqd1(:, :) = 0. - Plim11(:) = 0. - Plim21(:) = 0. - asupmax1(:, :) = 0. - supmax01(:) = 0. - asupmaxmin1(:) = 0. - - tvp(:, :) = 0. !ym missing init, need to have a look by developpers - tv(:, :) = 0. !ym missing init, need to have a look by developpers - - DO il = 1, len -!! cin1(il) = -100000. -!! cape1(il) = -1. - cin1(il) = Cin_noconv - cape1(il) = Cape_noconv - END DO - -!! IF (iflag_con==3) THEN -!! DO il = 1, len -!! sig1(il, nd) = sig1(il, nd) + 1. -!! sig1(il, nd) = amin1(sig1(il,nd), 12.1) -!! END DO -!! END IF - - IF (iflag_con==3) THEN - CALL cv3_incrcount(len,nd,delt,sig1) - END IF ! (iflag_con==3) - -! RomP >>> - sigt1(:, :) = 0. - detrain1(:, :) = 0. - qtc1(:, :) = 0. - wdtrainA1(:, :) = 0. - wdtrainS1(:, :) = 0. - wdtrainM1(:, :) = 0. - da1(:, :) = 0. - phi1(:, :, :) = 0. - epmlmMm1(:, :, :) = 0. - eplaMm1(:, :) = 0. - mp1(:, :) = 0. - evap1(:, :) = 0. - ep1(:, :) = 0. - sigij1(:, :, :) = 0. - elij1(:, :, :) = 0. - qta1(:,:) = 0. - clw1(:,:) = 0. - wghti1(:,:) = 0. - phi21(:, :, :) = 0. - d1a1(:, :) = 0. - dam1(:, :) = 0. -! RomP <<< -! --------------------------------------------------------------------- -! --- INITIALIZE LOCAL ARRAYS AND PARAMETERS -! --------------------------------------------------------------------- - - DO il = 1, nloc - coef_clos(il) = 1. - coef_clos_eff(il) = 1. - END DO - -! -------------------------------------------------------------------- -! --- CALCULATE ARRAYS OF GEOPOTENTIAL, HEAT CAPACITY & STATIC ENERGY -! -------------------------------------------------------------------- - - IF (iflag_con==3) THEN - - IF (debut) THEN - PRINT *, 'Emanuel version 3 nouvelle' - END IF -! print*,'t1, q1 ',t1,q1 - if (prt_level >= 9) & - PRINT *, 'cva_driver -> cv3_prelim' - CALL cv3_prelim(len, nd, ndp1, t1, q1, p1, ph1, & ! nd->na - lv1, lf1, cpn1, tv1, gz1, h1, hm1, th1) - - - if (prt_level >= 9) & - PRINT *, 'cva_driver -> cv3_prelim' - CALL cv3_prelim(len, nd, ndp1, t1_wake, q1_wake, p1, ph1, & ! nd->na - lv1_wake, lf1_wake, cpn1_wake, tv1_wake, gz1_wake, & - h1_wake, bid, th1_wake) - - END IF - - IF (iflag_con==4) THEN - PRINT *, 'Emanuel version 4 ' - if (prt_level >= 9) & - PRINT *, 'cva_driver -> cv_prelim' - CALL cv_prelim(len, nd, ndp1, t1, q1, p1, ph1, & - lv1, cpn1, tv1, gz1, h1, hm1) - END IF - -! -------------------------------------------------------------------- -! --- CONVECTIVE FEED -! -------------------------------------------------------------------- - -! compute feeding layer potential temperature and mixing ratio : - -! get bounds of feeding layer - -! test niveaux couche alimentation KE - IF (sig1feed1==sig2feed1) THEN - WRITE (lunout, *) 'impossible de choisir sig1feed=sig2feed' - WRITE (lunout, *) 'changer la valeur de sig2feed dans physiq.def' - abort_message = '' - CALL abort_physic(modname, abort_message, 1) - END IF - - DO i = 1, len - p1feed1(i) = sig1feed1*ph1(i, 1) - p2feed1(i) = sig2feed1*ph1(i, 1) -!test maf -! p1feed1(i)=ph1(i,1) -! p2feed1(i)=ph1(i,2) -! p2feed1(i)=ph1(i,3) -!testCR: on prend la couche alim des thermiques -! p2feed1(i)=ph1(i,lalim_conv1(i)+1) -! print*,'lentr=',lentr(i),ph1(i,lentr(i)+1),ph1(i,2) - END DO - - IF (iflag_con==3) THEN - END IF - DO i = 1, len -! print*,'avant cv3_feed Plim',p1feed1(i),p2feed1(i) - END DO - IF (iflag_con==3) THEN - -! print*, 'IFLAG1 avant cv3_feed' -! print*,'len,nd',len,nd -! write(*,'(64i1)') iflag1(2:len-1) - - if (prt_level >= 9) & - PRINT *, 'cva_driver -> cv3_feed' - CALL cv3_feed(len, nd, ok_conserv_q, & ! nd->na - t1, q1, u1, v1, p1, ph1, h1, gz1, & - p1feed1, p2feed1, wght1, & - wghti1, tnk1, thnk1, qnk1, qsnk1, unk1, vnk1, & - cpnk1, hnk1, nk1, icb1, icbmax, iflag1, gznk1, plcl1) - END IF - -! print*, 'IFLAG1 apres cv3_feed' -! print*,'len,nd',len,nd -! write(*,'(64i1)') iflag1(2:len-1) - - IF (iflag_con==4) THEN - if (prt_level >= 9) & - PRINT *, 'cva_driver -> cv_feed' - CALL cv_feed(len, nd, t1, q1, qs1, p1, hm1, gz1, & - nk1, icb1, icbmax, iflag1, tnk1, qnk1, gznk1, plcl1) - END IF - -! print *, 'cv3_feed-> iflag1, plcl1 ',iflag1(1),plcl1(1) - -! -------------------------------------------------------------------- -! --- 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==3) THEN - - if (prt_level >= 9) & - PRINT *, 'cva_driver -> cv3_undilute1' - CALL cv3_undilute1(len, nd, t1, qs1, gz1, plcl1, p1, icb1, tnk1, qnk1, & ! nd->na - gznk1, tp1, tvp1, clw1, icbs1) - END IF - - - IF (iflag_con==4) THEN - if (prt_level >= 9) & - PRINT *, 'cva_driver -> cv_undilute1' - CALL cv_undilute1(len, nd, t1, q1, qs1, gz1, p1, nk1, icb1, icbmax, & - tp1, tvp1, clw1) - END IF - -! ------------------------------------------------------------------- -! --- TRIGGERING -! ------------------------------------------------------------------- - -! print *,' avant triggering, iflag_con ',iflag_con - - IF (iflag_con==3) THEN - - if (prt_level >= 9) & - PRINT *, 'cva_driver -> cv3_trigger' - CALL cv3_trigger(len, nd, icb1, plcl1, p1, th1, tv1, tvp1, thnk1, & ! nd->na - pbase1, buoybase1, iflag1, sig1, w01) - - -! print*, 'IFLAG1 apres cv3_triger' -! print*,'len,nd',len,nd -! write(*,'(64i1)') iflag1(2:len-1) - -! call dump2d(iim,jjm-1,sig1(2) - END IF - - IF (iflag_con==4) THEN - if (prt_level >= 9) & - PRINT *, 'cva_driver -> cv_trigger' - CALL cv_trigger(len, nd, icb1, cbmf1, tv1, tvp1, iflag1) - END IF - - -! ===================================================================== -! --- IF THIS POINT IS REACHED, MOIST CONVECTIVE ADJUSTMENT IS NECESSARY -! ===================================================================== - -! Determine the number "ncum" of convective gridpoints, the list "idcum" of convective -! gridpoints and the weights "coef_convective" (= 1. for convective gridpoints and = 0. -! elsewhere). - DO i = 1, len - IF (iflag1(i)==0) THEN - coef_convective(i) = 1. - is_convect(i) = .TRUE. - ELSE - coef_convective(i) = 0. - is_convect(i) = .FALSE. - END IF - END DO - - - IF (never_compress) THEN - compress = .FALSE. - DO i = 1,len - idcum(i) = i - ENDDO - ncum=len - ELSE - ncum = 0 - DO i = 1, len - IF (iflag1(i)==0) THEN - ncum = ncum + 1 - idcum(ncum) = i - END IF - END DO - - IF (ncum>0) THEN -! If the fraction of convective points is larger than comp_threshold, then compression -! is assumed useless. - compress = ncum .lt. len*comp_threshold - IF (.not. compress) THEN - DO i = 1,len - idcum(i) = i - ENDDO - ncum=len - ENDIF - ENDIF - - ENDIF - - IF (ncum>0) THEN - -! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -! --- COMPRESS THE FIELDS -! (-> vectorization over convective gridpoints) -! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ - - IF (iflag_con==3) THEN - if (prt_level >= 9) PRINT *, 'cva_driver -> cv3a_compress' -!! CALL cv3a_compress(len, nloc, ncum, nd, ntra, compress, & !jyg: get rid of ntra - CALL cv3a_compress(len, nloc, ncum, nd, compress, & - iflag1, nk1, icb1, icbs1, & - plcl1, tnk1, qnk1, gznk1, hnk1, unk1, vnk1, & - wghti1, pbase1, buoybase1, & - t1, q1, qs1, t1_wake, q1_wake, qs1_wake, s1_wake, & - u1, v1, gz1, th1, th1_wake, & -!! tra1, & !jyg: get rid of ntra - h1, lv1, lf1, cpn1, p1, ph1, tv1, tp1, tvp1, clw1, & - h1_wake, lv1_wake, lf1_wake, cpn1_wake, tv1_wake, & - sig1, w01, ptop21, & - Ale1, Alp1, omega1, & - iflag, nk, icb, icbs, & - plcl, tnk, qnk, gznk, hnk, unk, vnk, & - wghti, pbase, buoybase, & - t, q, qs, t_wake, q_wake, qs_wake, s_wake, & - u, v, gz, th, th_wake, & -!! tra, & !jyg: get rid of ntra - h, lv, lf, cpn, p, ph, tv, tp, tvp, clw, & - h_wake, lv_wake, lf_wake, cpn_wake, tv_wake, & - sig, w0, ptop2, & - Ale, Alp, omega) - - - END IF - - IF (iflag_con==4) THEN - if (prt_level >= 9) PRINT *, 'cva_driver -> cv_compress' - CALL cv_compress(len, nloc, ncum, nd, & - iflag1, compress, nk1, icb1, & - cbmf1, plcl1, tnk1, qnk1, gznk1, & - t1, q1, qs1, u1, v1, gz1, & - h1, lv1, cpn1, p1, ph1, tv1, tp1, tvp1, clw1, & - iflag, nk, icb, & - cbmf, plcl, tnk, qnk, gznk, & - t, q, qs, u, v, gz, h, lv, cpn, p, ph, tv, tp, tvp, clw, & - dph) - END IF - -! ------------------------------------------------------------------- -! --- 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==3) THEN - if (prt_level >= 9) & - PRINT *, 'cva_driver -> cv3_undilute2' - CALL cv3_undilute2(nloc, ncum, nd, iflag, icb, icbs, nk, & !na->nd - tnk, qnk, gznk, hnk, t, q, qs, gz, & - p, ph, h, tv, lv, lf, pbase, buoybase, plcl, & - inb, tp, tvp, clw, hp, ep, sigp, buoy, & - frac_a, frac_s, qpreca, qta) !!jygprl - END IF - - IF (iflag_con==4) THEN - if (prt_level >= 9) & - PRINT *, 'cva_driver -> cv_undilute2' - CALL cv_undilute2(nloc, ncum, nd, icb, nk, & - tnk, qnk, gznk, t, q, qs, gz, & - p, dph, h, tv, lv, & - inb, inbis, tp, tvp, clw, hp, ep, sigp, frac_s) - END IF - - ! epmax_cape - ! on recalcule ep et hp - if (prt_level >= 9) & - PRINT *, 'cva_driver -> cv3_epmax_cape' - call cv3_epmax_fn_cape(nloc,ncum,nd & - , ep,hp,icb,inb,clw,nk,t,h,hnk,lv,lf,frac_s & - , pbase, p, ph, tv, buoy, sig, w0,iflag & - , epmax_diag) - -! ------------------------------------------------------------------- -! --- MIXING(1) (if iflag_mix .ge. 1) -! ------------------------------------------------------------------- - IF (iflag_con==3) THEN -! IF ((iflag_ice_thermo==1) .AND. (iflag_mix/=0)) THEN -! WRITE (*, *) ' iflag_ice_thermo==1 requires iflag_mix==0', ' but iflag_mix=', iflag_mix, & -! '. Might as well stop here.' -! STOP -! END IF - IF (iflag_mix>=1) THEN - supmax(:,:)=0. - if (prt_level >= 9) & - PRINT *, 'cva_driver -> cv3p_mixing' -!! CALL cv3p_mixing(nloc, ncum, nd, nd, ntra, icb, nk, inb, & ! na->nd !jyg: get rid of ntra - CALL cv3p_mixing(nloc, ncum, nd, nd, icb, nk, inb, & ! na->nd -!! ph, t, q, qs, u, v, tra, h, lv, lf, frac, qnk, & -!! ph, t, q, qs, u, v, tra, h, lv, lf, frac_s, qta, & !!jygprl !jyg: get rid of ntra - ph, t, q, qs, u, v, h, lv, lf, frac_s, qta, & !!jygprl - unk, vnk, hp, tv, tvp, ep, clw, sig, & - ment, qent, hent, uent, vent, nent, & -!! sigij, elij, supmax, ments, qents, traent) !jyg: get rid of ntra -!! sigij, elij, supmax, ments, qents) !jyg: get rid of ments - sigij, elij, supmax) -! print*, 'cv3p_mixing-> supmax ', (supmax(1,k), k=1,nd) - - ELSE - supmax(:,:)=0. - END IF - END IF -! ------------------------------------------------------------------- -! --- CLOSURE -! ------------------------------------------------------------------- - - - IF (iflag_con==3) THEN - IF (iflag_clos==0) THEN - if (prt_level >= 9) & - PRINT *, 'cva_driver -> cv3_closure' - CALL cv3_closure(nloc, ncum, nd, icb, inb, & ! na->nd - pbase, p, ph, tv, buoy, & - sig, w0, cape, m, iflag) - END IF ! iflag_clos==0 - - ok_inhib = iflag_mix == 2 - - IF (iflag_clos==1) THEN - PRINT *, ' pas d appel cv3p_closure' -! c CALL cv3p_closure(nloc,ncum,nd,icb,inb ! na->nd -! c : ,pbase,plcl,p,ph,tv,tvp,buoy -! c : ,supmax -! c o ,sig,w0,ptop2,cape,cin,m) - END IF ! iflag_clos==1 - - IF (iflag_clos==2) THEN - if (prt_level >= 9) & - PRINT *, 'cva_driver -> cv3p1_closure' - CALL cv3p1_closure(nloc, ncum, nd, icb, inb, & ! na->nd - pbase, plcl, p, ph, tv, tvp, buoy, & - supmax, ok_inhib, Ale, Alp, omega, & - sig, w0, ptop2, cape, cin, m, iflag, & - coef_clos_eff, coef_clos, & - Plim1, plim2, asupmax, supmax0, & - asupmaxmin, cbmf, plfc, wbeff) - if (prt_level >= 10) & - PRINT *, 'cv3p1_closure-> plfc,wbeff ', plfc(1), wbeff(1) - END IF ! iflag_clos==2 - - IF (iflag_clos==3) THEN - if (prt_level >= 9) & - PRINT *, 'cva_driver -> cv3p2_closure' - CALL cv3p2_closure(nloc, ncum, nd, icb, inb, & ! na->nd - pbase, plcl, p, ph, tv, tvp, buoy, & - supmax, ok_inhib, Ale, Alp, omega, & - sig, w0, ptop2, cape, cin, m, iflag, coef_clos_eff, & - Plim1, plim2, asupmax, supmax0, & - asupmaxmin, cbmf, plfc, wbeff) - if (prt_level >= 10) & - PRINT *, 'cv3p2_closure-> plfc,wbeff ', plfc(1), wbeff(1) - END IF ! iflag_clos==3 - END IF ! iflag_con==3 - - IF (iflag_con==4) THEN - if (prt_level >= 9) & - PRINT *, 'cva_driver -> cv_closure' - CALL cv_closure(nloc, ncum, nd, nk, icb, & - tv, tvp, p, ph, dph, plcl, cpn, & - iflag, cbmf) - END IF - -! print *,'cv_closure-> cape ',cape(1) - -! ------------------------------------------------------------------- -! --- MIXING(2) -! ------------------------------------------------------------------- - - IF (iflag_con==3) THEN - IF (iflag_mix==0) THEN - if (prt_level >= 9) & - PRINT *, 'cva_driver -> cv3_mixing' -!! CALL cv3_mixing(nloc, ncum, nd, nd, ntra, icb, nk, inb, & ! na->nd !jyg: get rid of ntra - CALL cv3_mixing(nloc, ncum, nd, nd, icb, nk, inb, & ! na->nd -!! ph, t, q, qs, u, v, tra, h, lv, lf, frac_s, qnk, & !jyg: get rid of ntra - ph, t, q, qs, u, v, h, lv, lf, frac_s, qnk, & - unk, vnk, hp, tv, tvp, ep, clw, m, sig, & -!! ment, qent, uent, vent, nent, sigij, elij, ments, qents, traent) !jyg: get rid of ntra -!! ment, qent, uent, vent, nent, sigij, elij, ments, qents) !jyg: get rid of ments - ment, qent, uent, vent, nent, sigij, elij) - hent(1:nloc,1:nd,1:nd) = 0. - ELSE -!!jyg: Essais absurde pour voir -!! mm(:,1) = 0. -!! DO i = 2,nd -!! mm(:,i) = m(:,i)*(1.-qta(:,i-1)) -!! ENDDO - mm(:,:) = m(:,:) - CALL cv3_mixscale(nloc, ncum, nd, ment, mm) - IF (debut) THEN - PRINT *, ' cv3_mixscale-> ' - END IF !(debut) THEN - END IF - END IF - - IF (iflag_con==4) THEN - if (prt_level >= 9) & - PRINT *, 'cva_driver -> cv_mixing' - 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, & - m, ment, qent, uent, vent, nent, sigij, elij) - END IF - - IF (debut) THEN - PRINT *, ' cv_mixing ->' - END IF !(debut) THEN -! do i = 1,nd -! print*,'cv_mixing-> i,ment ',i,(ment(1,i,j),j=1,nd) -! enddo - -! ------------------------------------------------------------------- -! --- UNSATURATED (PRECIPITATING) DOWNDRAFTS -! ------------------------------------------------------------------- - IF (iflag_con==3) THEN - IF (debut) THEN - PRINT *, ' cva_driver -> cv3_unsat ' - END IF !(debut) THEN - - if (prt_level >= 9) & - PRINT *, 'cva_driver -> cv3_unsat' -!! CALL cv3_unsat(nloc, ncum, nd, nd, ntra, icb, inb, iflag, & ! na->nd !jyg: get rid of ntra - CALL cv3_unsat(nloc, ncum, nd, nd, icb, inb, iflag, & ! na->nd -!! t_wake, q_wake, qs_wake, gz, u, v, tra, p, ph, & !jyg: get rid of ntra - t_wake, q_wake, qs_wake, gz, u, v, p, ph, & - th_wake, tv_wake, lv_wake, lf_wake, cpn_wake, & - ep, sigp, clw, frac_s, qpreca, frac_a, qta, & !!jygprl - m, ment, elij, delt, plcl, coef_clos_eff, & -!! mp, qp, up, vp, trap, wt, water, evap, fondue, ice, & !jyg: get rid of ntra - mp, qp, up, vp, wt, water, evap, fondue, ice, & - faci, b, sigd, & -!! wdtrainA, wdtrainM) ! RomP - wdtrainA, wdtrainS, wdtrainM) !!jygprl -! - IF (prt_level >= 10) THEN - Print *, 'cva_driver after cv3_unsat:mp , water, ice, evap, fondue ' - DO k = 1,nd - write (6, '(i4,5(1x,e13.6))') & - k, mp(igout,k), water(igout,k), ice(igout,k), & - evap(igout,k), fondue(igout,k) - ENDDO - Print *, 'cva_driver after cv3_unsat: wdtrainA, wdtrainS, wdtrainM ' !!jygprl - DO k = 1,nd - write (6, '(i4,3(1x,e13.6))') & - k, wdtrainA(igout,k), wdtrainS(igout,k), wdtrainM(igout,k) !!jygprl - ENDDO - ENDIF -! - END IF !(iflag_con==3) - - IF (iflag_con==4) THEN - if (prt_level >= 9) & - PRINT *, 'cva_driver -> cv_unsat' - CALL 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) - END IF - - IF (debut) THEN - PRINT *, 'cv_unsat-> ' - END IF !(debut) THEN - -! print *,'cv_unsat-> mp ',mp -! print *,'cv_unsat-> water ',water -! ------------------------------------------------------------------- -! --- YIELD -! (tendencies, precipitation, variables of interface with other -! processes, etc) -! ------------------------------------------------------------------- - - IF (iflag_con==3) THEN - - if (prt_level >= 9) & - PRINT *, 'cva_driver -> cv3_yield' -!! CALL cv3_yield(nloc, ncum, nd, nd, ntra, ok_conserv_q, & ! na->nd !jyg: get rid of ntra - CALL cv3_yield(nloc, ncum, nd, nd, ok_conserv_q, & ! na->nd - icb, inb, delt, & -!! t, q, t_wake, q_wake, s_wake, u, v, tra, & !jyg: get rid of ntra - t, q, t_wake, q_wake, s_wake, u, v, & - gz, p, ph, h, hp, lv, lf, cpn, th, th_wake, & -!! ep, clw, qpreca, m, tp, mp, qp, up, vp, trap, & !jyg: get rid of ntra - ep, clw, qpreca, m, tp, mp, qp, up, vp, & - wt, water, ice, evap, fondue, faci, b, sigd, & - ment, qent, hent, iflag_mix, uent, vent, & -!! nent, elij, traent, sig, & !jyg: get rid of ntra - nent, elij, sig, & - tv, tvp, wghti, & -!! iflag, precip, Vprecip, Vprecipi, ft, fq, fqcomp, fu, fv, ftra, & !jyg: get rid of ntra - iflag, precip, Vprecip, Vprecipi, ft, fq, fqcomp, fu, fv, & - cbmf, upwd, dnwd, dnwd0, ma, mip, & -!! tls, tps, & ! useless . jyg - qcondc, wd, & -!! ftd, fqd, qnk, qtc, sigt, tau_cld_cv, coefw_cld_cv) - ftd, fqd, qta, qtc, sigt, detrain, tau_cld_cv, coefw_cld_cv) !!jygprl -! -! Test conseravtion de l'eau -! - IF (debut) THEN - PRINT *, ' cv3_yield -> fqd(1) = ', fqd(igout, 1) - END IF !(debut) THEN -! - IF (prt_level >= 10) THEN - Print *, 'cva_driver after cv3_yield:ft(1) , ftd(1) ', & - ft(igout,1), ftd(igout,1) - Print *, 'cva_driver after cv3_yield:fq(1) , fqd(1) ', & - fq(igout,1), fqd(igout,1) - ENDIF -! - END IF - - IF (iflag_con==4) THEN - if (prt_level >= 9) & - PRINT *, 'cva_driver -> cv_yield' - CALL cv_yield(nloc, ncum, nd, nk, icb, inb, delt, & - t, q, u, v, & - gz, p, ph, h, hp, lv, cpn, & - ep, clw, frac_s, m, mp, qp, up, vp, & - wt, water, evap, & - ment, qent, uent, vent, nent, elij, & - tv, tvp, & - iflag, wd, qprime, tprime, & - precip, cbmf, ft, fq, fu, fv, ma, qcondc) - END IF - -!AC! -!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -!--- passive tracers -!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ - - IF (iflag_con==3) THEN -!RomP >>> - if (prt_level >= 9) & - PRINT *, 'cva_driver -> cv3_tracer' - CALL cv3_tracer(nloc, len, ncum, nd, nd, & - ment, sigij, da, phi, phi2, d1a, dam, & - ep, vprecip, elij, clw, epmlmMm, eplaMm, & - icb, inb) -!RomP <<< - END IF - -!AC! - -! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -! --- UNCOMPRESS THE FIELDS -! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ - - - IF (iflag_con==3) THEN - if (prt_level >= 9) & - PRINT *, 'cva_driver -> cv3a_uncompress' -!! CALL cv3a_uncompress(nloc, len, ncum, nd, ntra, idcum, is_convect, compress, & !jyg: get rid of ntra - CALL cv3a_uncompress(nloc, len, ncum, nd, idcum, is_convect, compress, & - iflag, icb, inb, & - precip, cbmf, plcl, plfc, wbeff, sig, w0, ptop2, & -!! ft, fq, fqcomp, fu, fv, ftra, & !jyg: get rid of ntra - ft, fq, fqcomp, fu, fv, & - sigd, ma, mip, vprecip, vprecipi, upwd, dnwd, dnwd0, & - qcondc, wd, cape, cin, & - tvp, & - ftd, fqd, & - Plim1, plim2, asupmax, supmax0, & - asupmaxmin, & - coef_clos, coef_clos_eff, & - da, phi, mp, phi2, d1a, dam, sigij, & ! RomP - qta, clw, elij, evap, ep, epmlmMm, eplaMm, & ! RomP - wdtrainA, wdtrainS, wdtrainM, & ! RomP - qtc, sigt, detrain, epmax_diag, & ! epmax_cape - iflag1, kbas1, ktop1, & - precip1, cbmf1, plcl1, plfc1, wbeff1, sig1, w01, ptop21, & -!! ft1, fq1, fqcomp1, fu1, fv1, ftra1, & !jyg: get rid of ntra - ft1, fq1, fqcomp1, fu1, fv1, & - sigd1, ma1, mip1, vprecip1, vprecipi1, upwd1, dnwd1, dnwd01, & - qcondc1, wd1, cape1, cin1, & - tvp1, & - ftd1, fqd1, & - Plim11, plim21, asupmax1, supmax01, & - asupmaxmin1, & - coef_clos1, coef_clos_eff1, & - da1, phi1, mp1, phi21, d1a1, dam1, sigij1, & ! RomP - qta1, clw1, elij1, evap1, ep1, epmlmMm1, eplaMm1, & ! RomP - wdtrainA1, wdtrainS1, wdtrainM1, & ! RomP - qtc1, sigt1, detrain1, epmax_diag1) ! epmax_cape -! - IF (prt_level >= 10) THEN - Print *, 'cva_driver after cv3_uncompress:ft1(1) , ftd1(1) ', & - ft1(igout,1), ftd1(igout,1) - Print *, 'cva_driver after cv3_uncompress:fq1(1) , fqd1(1) ', & - fq1(igout,1), fqd1(igout,1) - ENDIF -! - END IF - - IF (iflag_con==4) THEN - if (prt_level >= 9) & - PRINT *, 'cva_driver -> cv_uncompress' - CALL cv_uncompress(nloc, len, ncum, nd, idcum, is_convect, compress, & - iflag, & - precip, cbmf, & - ft, fq, fu, fv, & - ma, qcondc, & - iflag1, & - precip1,cbmf1, & - ft1, fq1, fu1, fv1, & - ma1, qcondc1) - END IF - - END IF ! ncum>0 -! -! - DO i = 1,len - IF (iflag1(i) == 14) THEN - Cin1(i) = Cin_noconv - Cape1(i) = Cape_noconv - ENDIF - ENDDO - -! -! In order take into account the possibility of changing the compression, -! reset m, sig and w0 to zero for non-convective points. - DO k = 1,nd-1 - sig1(:, k) = sig1(:, k)*coef_convective(:) - w01(:, k) = w01(:, k)*coef_convective(:) - ENDDO - - IF (debut) THEN - PRINT *, ' cv_uncompress -> ' - END IF !(debut) THEN - - - RETURN -END SUBROUTINE cva_driver - -END MODULE cva_driver_mod Index: LMDZ6/trunk/libf/phylmd/cva_driver_mod.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cva_driver_mod.f90 (revision 6048) +++ LMDZ6/trunk/libf/phylmd/cva_driver_mod.f90 (revision 6048) @@ -0,0 +1,1361 @@ + +! $Id$ +!$gpum horizontal len nloc ncum klon +MODULE cva_driver_mod + PRIVATE + LOGICAL, SAVE :: debut = .TRUE. + !$OMP THREADPRIVATE(debut) + LOGICAL, SAVE :: never_compress=.FALSE. ! if true, compression is desactivated in convection + !$OMP THREADPRIVATE(never_compress) + + PUBLIC cva_driver_pre, cva_driver_post, cva_driver + +CONTAINS + +! called before cva_driver +SUBROUTINE cva_driver_pre(nd, k_upper, iflag_con, iflag_ice_thermo, ok_conserv_q, delt) +USE cv3_routines_mod, ONLY : cv3_routine_pre, cv3_param +USE cv_routines_mod, ONLY : cv_param +USE ioipsl_getin_p_mod, ONLY : getin_p +USE s2s +IMPLICIT NONE + INTEGER, INTENT (IN) :: nd + INTEGER, INTENT (IN) :: k_upper + INTEGER, INTENT (IN) :: iflag_con + INTEGER, INTENT (IN) :: iflag_ice_thermo + REAL, INTENT (IN) :: delt + LOGICAL, INTENT (IN) :: ok_conserv_q + + IF (debut) THEN + ! ------------------------------------------------------------------- + ! --- SET CONSTANTS AND PARAMETERS + ! ------------------------------------------------------------------- + + ! -- set simulation flags: + ! (common cvflag) + never_compress = .FALSE. + CALL getin_p("convection_no_compression",never_compress) + IF (s2s_gpu_activated()) never_compress = .TRUE. ! for GPU, compression must be disabled + CALL cv_flag(iflag_ice_thermo) + + ! -- set thermodynamical constants: + ! (common cvthermo) + + CALL cv_thermo(iflag_con) + + ! -- set convect parameters + + ! includes microphysical parameters and parameters that + ! control the rate of approach to quasi-equilibrium) + ! (common cvparam) + + IF (iflag_con==3) THEN + CALL cv3_param(nd, k_upper, delt) + END IF + + IF (iflag_con==4) THEN + CALL cv_param(nd) + END IF + + CALL cv3_routine_pre(ok_conserv_q) + ENDIF + +END SUBROUTINE cva_driver_pre + +!called after cva_driver +SUBROUTINE cva_driver_post +IMPLICIT NONE + IF (debut) THEN + debut=.FALSE. + ENDIF +END SUBROUTINE cva_driver_post + +!!SUBROUTINE cva_driver(len, nd, ndp1, ntra, nloc, k_upper, & !jyg: get rid of ntra +SUBROUTINE cva_driver(len, nd, ndp1, nloc, k_upper, & + iflag_con, iflag_mix, iflag_ice_thermo, iflag_clos, ok_conserv_q, & +!! delt, t1, q1, qs1, t1_wake, q1_wake, qs1_wake, s1_wake, & ! jyg + delt, comp_threshold, & ! jyg + t1, q1, qs1, t1_wake, q1_wake, qs1_wake, s1_wake, & ! jyg +!! u1, v1, tra1, & !jyg: get rid of ntra + u1, v1, & + p1, ph1, & + Ale1, Alp1, omega1, & + sig1feed1, sig2feed1, wght1, & +!! iflag1, ft1, fq1, fqcomp1, fu1, fv1, ftra1, & !jyg: get rid of ntra + iflag1, ft1, fq1, fqcomp1, fu1, fv1, & + precip1, kbas1, ktop1, & + cbmf1, plcl1, plfc1, wbeff1, & + sig1, w01, & !input/output + ptop21, sigd1, & + ma1, mip1, Vprecip1, Vprecipi1, upwd1, dnwd1, dnwd01, & ! jyg + qcondc1, wd1, & + cape1, cin1, tvp1, & + ftd1, fqd1, & + Plim11, Plim21, asupmax1, supmax01, asupmaxmin1, & + coef_clos1, coef_clos_eff1, & + lalim_conv1, & +!! da1,phi1,mp1,phi21,d1a1,dam1,sigij1,clw1, & ! RomP +!! elij1,evap1,ep1,epmlmMm1,eplaMm1, & ! RomP + da1, phi1, mp1, phi21, d1a1, dam1, sigij1, wghti1, & ! RomP, RL + qta1, clw1, elij1, evap1, ep1, epmlmMm1, eplaMm1, & ! RomP, RL + wdtrainA1, wdtrainS1, wdtrainM1, qtc1, sigt1, detrain1, tau_cld_cv, & !!jygprl + coefw_cld_cv, & ! RomP, AJ + epmax_diag1) ! epmax_cape +! ************************************************************** +! * +! CV_DRIVER * +! * +! * +! written by : Sandrine Bony-Lena , 17/05/2003, 11.19.41 * +! modified by : * +! ************************************************************** +! ************************************************************** + + USE print_control_mod, ONLY: prt_level, lunout + USE add_phys_tend_mod, ONLY: fl_cor_ebil + USE cv3_routines_mod + USE cv_routines_mod + USE cv3a_compress_mod, ONLY : cv3a_compress + USE cv3p_mixing_mod, ONLY : cv3p_mixing + USE cv3p1_closure_mod, ONLY : cv3p1_closure + USE cv3p2_closure_mod, ONLY : cv3p2_closure + USE cv3_mixscale_mod, ONLY : cv3_mixscale + USE cv3a_uncompress_mod, ONLY : cv3a_uncompress + USE cv3_enthalpmix_mod, ONLY : cv3_enthalpmix + USE cv3_estatmix_mod, ONLY : cv3_estatmix + IMPLICIT NONE + +! .............................START PROLOGUE............................ + + +! All argument names (except len,nd,nloc,delt and the flags) have a "1" appended. +! The "1" is removed for the corresponding compressed variables. +! PARAMETERS: +! Name Type Usage Description +! ---------- ---------- ------- ---------------------------- + +! len Integer Input first (i) dimension +! nd Integer Input vertical (k) dimension +! ndp1 Integer Input nd + 1 +! nloc Integer Input dimension of arrays for compressed fields +! k_upper Integer Input upmost level for vertical loops +! iflag_con Integer Input version of convect (3/4) +! iflag_mix Integer Input version of mixing (0/1/2) +! iflag_ice_thermo Integer Input accounting for ice thermodynamics (0/1) +! iflag_clos Integer Input version of closure (0/1) +! tau_cld_cv Real Input characteristic time of dissipation of mixing fluxes +! coefw_cld_cv Real Input coefficient for updraft velocity in convection +! ok_conserv_q Logical Input when true corrections for water conservation are swtiched on +! delt Real Input time step +! comp_threshold Real Input threshold on the fraction of convective points below which +! fields are compressed +! t1 Real Input temperature (sat draught envt) +! q1 Real Input specific hum (sat draught envt) +! qs1 Real Input sat specific hum (sat draught envt) +! t1_wake Real Input temperature (unsat draught envt) +! q1_wake Real Input specific hum(unsat draught envt) +! qs1_wake Real Input sat specific hum(unsat draughts envt) +! s1_wake Real Input fractionnal area covered by wakes +! u1 Real Input u-wind +! v1 Real Input v-wind +! p1 Real Input full level pressure +! ph1 Real Input half level pressure +! ALE1 Real Input Available lifting Energy +! ALP1 Real Input Available lifting Power +! sig1feed1 Real Input sigma coord at lower bound of feeding layer +! sig2feed1 Real Input sigma coord at upper bound of feeding layer +! wght1 Real Input weight density determining the feeding mixture +! iflag1 Integer Output flag for Emanuel conditions +! ft1 Real Output temp tend +! fq1 Real Output spec hum tend +! fqcomp1 Real Output spec hum tend (only mixed draughts) +! fu1 Real Output u-wind tend +! fv1 Real Output v-wind tend +! precip1 Real Output precipitation +! kbas1 Integer Output cloud base level +! ktop1 Integer Output cloud top level +! cbmf1 Real Output cloud base mass flux +! sig1 Real In/Out section adiabatic updraft +! w01 Real In/Out vertical velocity within adiab updraft +! ptop21 Real In/Out top of entraining zone +! Ma1 Real Output mass flux adiabatic updraft +! mip1 Real Output mass flux shed by the adiabatic updraft +! Vprecip1 Real Output vertical profile of total precipitation +! Vprecipi1 Real Output vertical profile of ice precipitation +! upwd1 Real Output total upward mass flux (adiab+mixed) +! dnwd1 Real Output saturated downward mass flux (mixed) +! dnwd01 Real Output unsaturated downward mass flux +! qcondc1 Real Output in-cld mixing ratio of condensed water +! wd1 Real Output downdraft velocity scale for sfc fluxes +! cape1 Real Output CAPE +! cin1 Real Output CIN +! tvp1 Real Output adiab lifted parcell virt temp +! ftd1 Real Output precip temp tend +! fqt1 Real Output precip spec hum tend +! Plim11 Real Output +! Plim21 Real Output +! asupmax1 Real Output +! supmax01 Real Output +! asupmaxmin1 Real Output + +! ftd1 Real Output Array of temperature tendency due to precipitations (K/s) of dimension ND, +! defined at same grid levels as T, Q, QS and P. + +! fqd1 Real Output Array of specific humidity tendencies due to precipitations ((gm/gm)/s) +! of dimension ND, defined at same grid levels as T, Q, QS and P. + +! wdtrainA1 Real Output precipitation ejected from adiabatic draught; +! should be used in tracer transport (cvltr) +! wdtrainS1 Real Output precipitation detrained from shedding of adiabatic draught; +! used in tracer transport (cvltr) +! wdtrainM1 Real Output precipitation detrained from mixed draughts; +! used in tracer transport (cvltr) +! da1 Real Output used in tracer transport (cvltr) +! phi1 Real Output used in tracer transport (cvltr) +! mp1 Real Output used in tracer transport (cvltr) +! qtc1 Real Output specific humidity in convection +! sigt1 Real Output surface fraction in adiabatic updrafts +! detrain1 Real Output detrainment terme klein +! phi21 Real Output used in tracer transport (cvltr) + +! d1a1 Real Output used in tracer transport (cvltr) +! dam1 Real Output used in tracer transport (cvltr) + +! epmlmMm1 Real Output used in tracer transport (cvltr) +! eplaMm1 Real Output used in tracer transport (cvltr) + +! evap1 Real Output +! ep1 Real Output +! sigij1 Real Output used in tracer transport (cvltr) +! clw1 Real Output condensed water content of the adiabatic updraught +! elij1 Real Output +! wghti1 Real Output final weight of the feeding layers, +! used in tracer transport (cvltr) + + +! S. Bony, Mar 2002: +! * Several modules corresponding to different physical processes +! * Several versions of convect may be used: +! - iflag_con=3: version lmd (previously named convect3) +! - iflag_con=4: version 4.3b (vect. version, previously convect1/2) +! + tard: - iflag_con=5: version lmd with ice (previously named convectg) +! S. Bony, Oct 2002: +! * Vectorization of convect3 (ie version lmd) + +! ..............................END PROLOGUE............................. + + + +! Input + INTEGER, INTENT (IN) :: len + INTEGER, INTENT (IN) :: nd + INTEGER, INTENT (IN) :: ndp1 +!! INTEGER, INTENT (IN) :: ntra !jyg: get rid of ntra + INTEGER, INTENT(IN) :: nloc ! (nloc=len) pour l'instant + INTEGER, INTENT (IN) :: k_upper + INTEGER, INTENT (IN) :: iflag_con + INTEGER, INTENT (IN) :: iflag_mix + INTEGER, INTENT (IN) :: iflag_ice_thermo + INTEGER, INTENT (IN) :: iflag_clos + LOGICAL, INTENT (IN) :: ok_conserv_q + REAL, INTENT (IN) :: tau_cld_cv + REAL, INTENT (IN) :: coefw_cld_cv + REAL, INTENT (IN) :: delt + REAL, INTENT (IN) :: comp_threshold + REAL, DIMENSION (len, nd), INTENT (IN) :: t1 + REAL, DIMENSION (len, nd), INTENT (IN) :: q1 + REAL, DIMENSION (len, nd), INTENT (IN) :: qs1 + REAL, DIMENSION (len, nd), INTENT (IN) :: t1_wake + REAL, DIMENSION (len, nd), INTENT (IN) :: q1_wake + REAL, DIMENSION (len, nd), INTENT (IN) :: qs1_wake + REAL, DIMENSION (len), INTENT (IN) :: s1_wake + REAL, DIMENSION (len, nd), INTENT (IN) :: u1 + REAL, DIMENSION (len, nd), INTENT (IN) :: v1 +!! REAL, DIMENSION (len, nd, ntra), INTENT (IN) :: tra1 !jyg: get rid of ntra + REAL, DIMENSION (len, nd), INTENT (IN) :: p1 + REAL, DIMENSION (len, ndp1), INTENT (IN) :: ph1 + REAL, DIMENSION (len), INTENT (IN) :: Ale1 + REAL, DIMENSION (len), INTENT (IN) :: Alp1 + REAL, DIMENSION (len, nd), INTENT (IN) :: omega1 + REAL, INTENT (IN) :: sig1feed1 ! pressure at lower bound of feeding layer + REAL, INTENT (IN) :: sig2feed1 ! pressure at upper bound of feeding layer + REAL, DIMENSION (nd), INTENT (IN) :: wght1 ! weight density determining the feeding mixture + INTEGER, DIMENSION (len), INTENT (IN) :: lalim_conv1 + +! Input/Output + REAL, DIMENSION (len, nd), INTENT (INOUT) :: sig1 + REAL, DIMENSION (len, nd), INTENT (INOUT) :: w01 + +! Output + INTEGER, DIMENSION (len), INTENT (OUT) :: iflag1 + REAL, DIMENSION (len, nd), INTENT (OUT) :: ft1 + REAL, DIMENSION (len, nd), INTENT (OUT) :: fq1 + REAL, DIMENSION (len, nd), INTENT (OUT) :: fqcomp1 + REAL, DIMENSION (len, nd), INTENT (OUT) :: fu1 + REAL, DIMENSION (len, nd), INTENT (OUT) :: fv1 +!! REAL, DIMENSION (len, nd, ntra), INTENT (OUT) :: ftra1 !jyg: get rid of ntra + REAL, DIMENSION (len), INTENT (OUT) :: precip1 + INTEGER, DIMENSION (len), INTENT (OUT) :: kbas1 + INTEGER, DIMENSION (len), INTENT (OUT) :: ktop1 + REAL, DIMENSION (len), INTENT (OUT) :: cbmf1 + REAL, DIMENSION (len), INTENT (OUT) :: plcl1 + REAL, DIMENSION (len), INTENT (OUT) :: plfc1 + REAL, DIMENSION (len), INTENT (OUT) :: wbeff1 + REAL, DIMENSION (len), INTENT (OUT) :: ptop21 + REAL, DIMENSION (len), INTENT (OUT) :: sigd1 + REAL, DIMENSION (len, nd), INTENT (OUT) :: ma1 ! adiab. asc. mass flux (staggered grid) + REAL, DIMENSION (len, nd), INTENT (OUT) :: mip1 ! mass flux shed from adiab. ascent (extensive) +! real Vprecip1(len,nd) + REAL, DIMENSION (len, ndp1), INTENT (OUT) :: vprecip1 ! tot precipitation flux (staggered grid) + REAL, DIMENSION (len, ndp1), INTENT (OUT) :: vprecipi1 ! ice precipitation flux (staggered grid) + REAL, DIMENSION (len, nd), INTENT (OUT) :: upwd1 ! upwd sat. mass flux (staggered grid) + REAL, DIMENSION (len, nd), INTENT (OUT) :: dnwd1 ! dnwd sat. mass flux (staggered grid) + REAL, DIMENSION (len, nd), INTENT (OUT) :: dnwd01 ! unsat. mass flux (staggered grid) + REAL, DIMENSION (len, nd), INTENT (OUT) :: qcondc1 ! max cloud condensate (intensive) ! cld + REAL, DIMENSION (len), INTENT (OUT) :: wd1 ! gust + REAL, DIMENSION (len), INTENT (OUT) :: cape1 + REAL, DIMENSION (len), INTENT (OUT) :: cin1 + REAL, DIMENSION (len, nd), INTENT (OUT) :: tvp1 ! Virt. temp. in the adiab. ascent + +!AC! +!! real da1(len,nd),phi1(len,nd,nd) +!! real da(len,nd),phi(len,nd,nd) +!AC! + REAL, DIMENSION (len, nd), INTENT (OUT) :: ftd1 ! Temp. tendency due to the sole unsat. drafts + REAL, DIMENSION (len, nd), INTENT (OUT) :: fqd1 ! Moist. tendency due to the sole unsat. drafts + REAL, DIMENSION (len), INTENT (OUT) :: Plim11 + REAL, DIMENSION (len), INTENT (OUT) :: Plim21 + REAL, DIMENSION (len, nd), INTENT (OUT) :: asupmax1 ! Highest mixing fraction of mixed updraughts + REAL, DIMENSION (len), INTENT (OUT) :: supmax01 + REAL, DIMENSION (len), INTENT (OUT) :: asupmaxmin1 + REAL, DIMENSION (len), INTENT (OUT) :: coef_clos1, coef_clos_eff1 + REAL, DIMENSION (len, nd), INTENT (OUT) :: qtc1 ! in cloud water content (intensive) ! cld + REAL, DIMENSION (len, nd), INTENT (OUT) :: sigt1 ! fract. cloud area (intensive) ! cld + REAL, DIMENSION (len, nd), INTENT (OUT) :: detrain1 ! detrainement term of mixed draughts in environment + +! RomP >>> + REAL, DIMENSION (len, nd), INTENT (OUT) :: wdtrainA1, wdtrainS1, wdtrainM1 ! precipitation sources (extensive) + REAL, DIMENSION (len, nd), INTENT (OUT) :: mp1 ! unsat. mass flux (staggered grid) + REAL, DIMENSION (len, nd), INTENT (OUT) :: da1 ! detrained mass flux of adiab. asc. air (extensive) + REAL, DIMENSION (len, nd, nd), INTENT (OUT) :: phi1 ! mass flux of envt. air in mixed draughts (extensive) + REAL, DIMENSION (len, nd, nd), INTENT (OUT) :: epmlmMm1 ! (extensive) + REAL, DIMENSION (len, nd), INTENT (OUT) :: eplaMm1 ! (extensive) + REAL, DIMENSION (len, nd), INTENT (OUT) :: evap1 ! evaporation rate in precip. downdraft. (intensive) + REAL, DIMENSION (len, nd), INTENT (OUT) :: ep1 + REAL, DIMENSION (len, nd, nd), INTENT (OUT) :: sigij1 ! mass fraction of env. air in mixed draughts (intensive) + REAL, DIMENSION (len, nd, nd), INTENT (OUT) :: elij1! cond. water per unit mass of mixed draughts (intensive) + REAL, DIMENSION (len, nd), INTENT (OUT) :: qta1 ! total water per unit mass of the adiab. asc. (intensive) + REAL, DIMENSION (len, nd), INTENT (OUT) :: clw1 ! cond. water per unit mass of the adiab. asc. (intensive) +!JYG,RL + REAL, DIMENSION (len, nd), INTENT (OUT) :: wghti1 ! final weight of the feeding layers (extensive) +!JYG,RL + REAL, DIMENSION (len, nd, nd), INTENT (OUT) :: phi21 ! (extensive) + REAL, DIMENSION (len, nd), INTENT (OUT) :: d1a1 ! (extensive) + REAL, DIMENSION (len, nd), INTENT (OUT) :: dam1 ! (extensive) +! RomP <<< + REAL, DIMENSION (len ), INTENT (OUT) :: epmax_diag1 + +! ------------------------------------------------------------------- +! Prolog by Kerry Emanuel. +! ------------------------------------------------------------------- +! --- ARGUMENTS +! ------------------------------------------------------------------- +! --- On input: + +! t: Array of absolute temperature (K) of dimension ND, with first +! index corresponding to lowest model level. Note that this array +! will be altered by the subroutine if dry convective adjustment +! occurs and if IPBL is not equal to 0. + +! q: Array of specific humidity (gm/gm) of dimension ND, with first +! index corresponding to lowest model level. Must be defined +! at same grid levels as T. Note that this array will be altered +! if dry convective adjustment occurs and if IPBL is not equal to 0. + +! qs: Array of saturation specific humidity of dimension ND, with first +! index corresponding to lowest model level. Must be defined +! at same grid levels as T. Note that this array will be altered +! if dry convective adjustment occurs and if IPBL is not equal to 0. + +! t_wake: Array of absolute temperature (K), seen by unsaturated draughts, +! of dimension ND, with first index corresponding to lowest model level. + +! q_wake: Array of specific humidity (gm/gm), seen by unsaturated draughts, +! of dimension ND, with first index corresponding to lowest model level. +! Must be defined at same grid levels as T. + +! qs_wake: Array of saturation specific humidity, seen by unsaturated draughts, +! of dimension ND, with first index corresponding to lowest model level. +! Must be defined at same grid levels as T. + +! s_wake: Array of fractionnal area occupied by the wakes. + +! u: Array of zonal wind velocity (m/s) of dimension ND, witth first +! index corresponding with the lowest model level. Defined at +! same levels as T. Note that this array will be altered if +! dry convective adjustment occurs and if IPBL is not equal to 0. + +! v: Same as u but for meridional velocity. + +! p: Array of pressure (mb) of dimension ND, with first +! index corresponding to lowest model level. Must be defined +! at same grid levels as T. + +! ph: Array of pressure (mb) of dimension ND+1, with first index +! corresponding to lowest level. These pressures are defined at +! levels intermediate between those of P, T, Q and QS. The first +! value of PH should be greater than (i.e. at a lower level than) +! the first value of the array P. + +! ALE: Available lifting Energy + +! ALP: Available lifting Power + +! nl: The maximum number of levels to which convection can penetrate, plus 1. +! NL MUST be less than or equal to ND-1. + +! delt: The model time step (sec) between calls to CONVECT + +! ---------------------------------------------------------------------------- +! --- On Output: + +! iflag: An output integer whose value denotes the following: +! VALUE INTERPRETATION +! ----- -------------- +! 0 Moist convection occurs. +! 1 Moist convection occurs, but a CFL condition +! on the subsidence warming is violated. This +! does not cause the scheme to terminate. +! 2 Moist convection, but no precip because ep(inb) lt 0.0001 +! 3 No moist convection because new cbmf is 0 and old cbmf is 0. +! 4 No moist convection; atmosphere is not +! unstable +! 6 No moist convection because ihmin le minorig. +! 7 No moist convection because unreasonable +! parcel level temperature or specific humidity. +! 8 No moist convection: lifted condensation +! level is above the 200 mb level. +! 9 No moist convection: cloud base is higher +! then the level NL-1. +! 10 No moist convection: cloud top is too warm. +! 14 No moist convection; atmosphere is very +! stable (=> no computation) +! + +! ft: Array of temperature tendency (K/s) of dimension ND, defined at same +! grid levels as T, Q, QS and P. + +! fq: Array of specific humidity tendencies ((gm/gm)/s) of dimension ND, +! defined at same grid levels as T, Q, QS and P. + +! fu: Array of forcing of zonal velocity (m/s^2) of dimension ND, +! defined at same grid levels as T. + +! fv: Same as FU, but for forcing of meridional velocity. + +! precip: Scalar convective precipitation rate (mm/day). + +! wd: A convective downdraft velocity scale. For use in surface +! flux parameterizations. See convect.ps file for details. + +! tprime: A convective downdraft temperature perturbation scale (K). +! For use in surface flux parameterizations. See convect.ps +! file for details. + +! qprime: A convective downdraft specific humidity +! perturbation scale (gm/gm). +! For use in surface flux parameterizations. See convect.ps +! file for details. + +! cbmf: The cloud base mass flux ((kg/m**2)/s). THIS SCALAR VALUE MUST +! BE STORED BY THE CALLING PROGRAM AND RETURNED TO CONVECT AT +! ITS NEXT CALL. That is, the value of CBMF must be "remembered" +! by the calling program between calls to CONVECT. + +! det: Array of detrainment mass flux of dimension ND. +! ------------------------------------------------------------------- + +! Local (non compressed) arrays + + + INTEGER i, k, il + INTEGER nword1, nword2, nword3, nword4 + INTEGER icbmax + INTEGER nk1(len) + INTEGER icb1(len) + INTEGER icbs1(len) + + LOGICAL ok_inhib ! True => possible inhibition of convection by dryness + + REAL coef_convective(len) ! = 1 for convective points, = 0 otherwise + REAL tnk1(len) + REAL thnk1(len) + REAL qnk1(len) + REAL gznk1(len) + REAL qsnk1(len) + REAL unk1(len) + REAL vnk1(len) + REAL cpnk1(len) + REAL hnk1(len) + REAL pbase1(len) + REAL buoybase1(len) + + REAL lf1(len, nd), lf1_wake(len, nd) + REAL lv1(len, nd), lv1_wake(len, nd) + REAL cpn1(len, nd), cpn1_wake(len, nd) + REAL tv1(len, nd), tv1_wake(len, nd) + REAL gz1(len, nd), gz1_wake(len, nd) + REAL hm1(len, nd) + REAL h1(len, nd), h1_wake(len, nd) + REAL tp1(len, nd) + REAL th1(len, nd), th1_wake(len, nd) + + REAL bid(len, nd) ! dummy array + + INTEGER ncum + + REAL p1feed1(len) ! pressure at lower bound of feeding layer + REAL p2feed1(len) ! pressure at upper bound of feeding layer +!JYG,RL +!! real wghti1(len,nd) ! weights of the feeding layers +!JYG,RL + +! (local) compressed fields: + + + INTEGER idcum(nloc) +!jyg< + LOGICAL compress ! True if compression occurs +!>jyg + INTEGER iflag(nloc), nk(nloc), icb(nloc) + INTEGER nent(nloc, nd) + INTEGER icbs(nloc) + INTEGER inb(nloc), inbis(nloc) + + REAL cbmf(nloc), plcl(nloc), plfc(nloc), wbeff(nloc) + REAL t(nloc, nd), q(nloc, nd), qs(nloc, nd) + REAL t_wake(nloc, nd), q_wake(nloc, nd), qs_wake(nloc, nd) + REAL s_wake(nloc) + REAL u(nloc, nd), v(nloc, nd) + REAL gz(nloc, nd), h(nloc, nd) + REAL h_wake(nloc, nd) + REAL lv(nloc, nd), lf(nloc, nd), cpn(nloc, nd) + REAL lv_wake(nloc, nd), lf_wake(nloc, nd), cpn_wake(nloc, nd) + REAL p(nloc, nd), ph(nloc, nd+1), tv(nloc, nd), tp(nloc, nd) + REAL tv_wake(nloc, nd) + REAL clw(nloc, nd) + REAL, DIMENSION(nloc, nd) :: qta, qpreca !!jygprl + REAL dph(nloc, nd) + REAL pbase(nloc), buoybase(nloc), th(nloc, nd) + REAL th_wake(nloc, nd) + REAL tvp(nloc, nd) + REAL sig(nloc, nd), w0(nloc, nd), ptop2(nloc) + REAL hp(nloc, nd), ep(nloc, nd), sigp(nloc, nd) + REAL buoy(nloc, nd) + REAL cape(nloc) + REAL cin(nloc) + REAL m(nloc, nd) + REAL mm(nloc, nd) + REAL ment(nloc, nd, nd), sigij(nloc, nd, nd) + REAL qent(nloc, nd, nd) + REAL hent(nloc, nd, nd) + REAL uent(nloc, nd, nd), vent(nloc, nd, nd) +!! REAL ments(nloc, nd, nd), qents(nloc, nd, nd) !jyg: get rid of ments + REAL elij(nloc, nd, nd) + REAL supmax(nloc, nd) + REAL Ale(nloc), Alp(nloc), coef_clos(nloc), coef_clos_eff(nloc) + REAL omega(nloc,nd) + REAL sigd(nloc) +! real mp(nloc,nd), qp(nloc,nd), up(nloc,nd), vp(nloc,nd) +! real wt(nloc,nd), water(nloc,nd), evap(nloc,nd), ice(nloc,nd) +! real b(nloc,nd), sigd(nloc) +! save mp,qp,up,vp,wt,water,evap,b + REAL, DIMENSION(len,nd) :: mp, qp, up, vp + REAL, DIMENSION(len,nd) :: wt, water, evap + REAL, DIMENSION(len,nd) :: ice, fondue, b + REAL, DIMENSION(len,nd) :: frac_a, frac_s, faci !!jygprl + REAL ft(nloc, nd), fq(nloc, nd), fqcomp(nloc, nd) + REAL ftd(nloc, nd), fqd(nloc, nd) + REAL fu(nloc, nd), fv(nloc, nd) + REAL upwd(nloc, nd), dnwd(nloc, nd), dnwd0(nloc, nd) + REAL ma(nloc, nd), mip(nloc, nd) +!! REAL tls(nloc, nd), tps(nloc, nd) ! unused . jyg + REAL qprime(nloc), tprime(nloc) + REAL precip(nloc) +! real Vprecip(nloc,nd) + REAL vprecip(nloc, nd+1) + REAL vprecipi(nloc, nd+1) +!! REAL tra(nloc, nd, ntra), trap(nloc, nd, ntra) !jyg: get rid of ntra +!! REAL ftra(nloc, nd, ntra), traent(nloc, nd, nd, ntra) !jyg: get rid of ntra + REAL qcondc(nloc, nd) ! cld + REAL wd(nloc) ! gust + REAL Plim1(nloc), plim2(nloc) + REAL asupmax(nloc, nd) + REAL supmax0(nloc) + REAL asupmaxmin(nloc) + + REAL tnk(nloc), qnk(nloc), gznk(nloc) + REAL wghti(nloc, nd) + REAL hnk(nloc), unk(nloc), vnk(nloc) + + REAL qtc(nloc, nd) ! cld + REAL sigt(nloc, nd) ! cld + REAL detrain(nloc, nd) ! cld + +! RomP >>> + REAL wdtrainA(nloc, nd), wdtrainS(nloc, nd), wdtrainM(nloc, nd) !!jygprl + REAL da(len, nd), phi(len, nd, nd) + REAL epmlmMm(nloc, nd, nd), eplaMm(nloc, nd) + REAL phi2(len, nd, nd) + REAL d1a(len, nd), dam(len, nd) +! RomP <<< + REAL epmax_diag(nloc) ! epmax_cape + + CHARACTER (LEN=20), PARAMETER :: modname = 'cva_driver' + CHARACTER (LEN=80) :: abort_message + + REAL, PARAMETER :: Cin_noconv = -100000. + REAL, PARAMETER :: Cape_noconv = -1. + + INTEGER, PARAMETER :: igout=1 + LOGICAL :: is_convect(len) ! is convection is active on column + +! print *, 't1, t1_wake ',(k,t1(1,k),t1_wake(1,k),k=1,nd) +! print *, 'q1, q1_wake ',(k,q1(1,k),q1_wake(1,k),k=1,nd) + + + +! --------------------------------------------------------------------- +! --- INITIALIZE OUTPUT ARRAYS AND PARAMETERS +! --------------------------------------------------------------------- + nword1 = len + nword2 = len*nd +!! nword3 = len*nd*ntra !jyg: get rid of ntra + nword4 = len*nd*nd + + iflag1(:) = 0 + ktop1(:) = 0 + kbas1(:) = 0 + ft1(:, :) = 0.0 + fq1(:, :) = 0.0 + fqcomp1(:, :) = 0.0 + fu1(:, :) = 0.0 + fv1(:, :) = 0.0 +!! ftra1(:, :, :) = 0. !jyg: get rid of ntra + precip1(:) = 0. + cbmf1(:) = 0. + plcl1(:) = 0. + plfc1(:) = 0. + wbeff1(:) = 0. + ptop21(:) = 0. + sigd1(:) = 0. + ma1(:, :) = 0. + mip1(:, :) = 0. + vprecip1(:, :) = 0. + vprecipi1(:, :) = 0. + upwd1(:, :) = 0. + dnwd1(:, :) = 0. + dnwd01(:, :) = 0. + qcondc1(:, :) = 0. + wd1(:) = 0. + cape1(:) = 0. + cin1(:) = 0. + tvp1(:, :) = 0. + ftd1(:, :) = 0. + fqd1(:, :) = 0. + Plim11(:) = 0. + Plim21(:) = 0. + asupmax1(:, :) = 0. + supmax01(:) = 0. + asupmaxmin1(:) = 0. + + tvp(:, :) = 0. !ym missing init, need to have a look by developpers + tv(:, :) = 0. !ym missing init, need to have a look by developpers + + DO il = 1, len +!! cin1(il) = -100000. +!! cape1(il) = -1. + cin1(il) = Cin_noconv + cape1(il) = Cape_noconv + END DO + +!! IF (iflag_con==3) THEN +!! DO il = 1, len +!! sig1(il, nd) = sig1(il, nd) + 1. +!! sig1(il, nd) = amin1(sig1(il,nd), 12.1) +!! END DO +!! END IF + + IF (iflag_con==3) THEN + CALL cv3_incrcount(len,nd,delt,sig1) + END IF ! (iflag_con==3) + +! RomP >>> + sigt1(:, :) = 0. + detrain1(:, :) = 0. + qtc1(:, :) = 0. + wdtrainA1(:, :) = 0. + wdtrainS1(:, :) = 0. + wdtrainM1(:, :) = 0. + da1(:, :) = 0. + phi1(:, :, :) = 0. + epmlmMm1(:, :, :) = 0. + eplaMm1(:, :) = 0. + mp1(:, :) = 0. + evap1(:, :) = 0. + ep1(:, :) = 0. + sigij1(:, :, :) = 0. + elij1(:, :, :) = 0. + qta1(:,:) = 0. + clw1(:,:) = 0. + wghti1(:,:) = 0. + phi21(:, :, :) = 0. + d1a1(:, :) = 0. + dam1(:, :) = 0. +! RomP <<< +! --------------------------------------------------------------------- +! --- INITIALIZE LOCAL ARRAYS AND PARAMETERS +! --------------------------------------------------------------------- + + DO il = 1, nloc + coef_clos(il) = 1. + coef_clos_eff(il) = 1. + END DO + +! -------------------------------------------------------------------- +! --- CALCULATE ARRAYS OF GEOPOTENTIAL, HEAT CAPACITY & STATIC ENERGY +! -------------------------------------------------------------------- + + IF (iflag_con==3) THEN + + IF (debut) THEN + PRINT *, 'Emanuel version 3 nouvelle' + END IF +! print*,'t1, q1 ',t1,q1 + if (prt_level >= 9) & + PRINT *, 'cva_driver -> cv3_prelim' + CALL cv3_prelim(len, nd, ndp1, t1, q1, p1, ph1, & ! nd->na + lv1, lf1, cpn1, tv1, gz1, h1, hm1, th1) + + + if (prt_level >= 9) & + PRINT *, 'cva_driver -> cv3_prelim' + CALL cv3_prelim(len, nd, ndp1, t1_wake, q1_wake, p1, ph1, & ! nd->na + lv1_wake, lf1_wake, cpn1_wake, tv1_wake, gz1_wake, & + h1_wake, bid, th1_wake) + + END IF + + IF (iflag_con==4) THEN + PRINT *, 'Emanuel version 4 ' + if (prt_level >= 9) & + PRINT *, 'cva_driver -> cv_prelim' + CALL cv_prelim(len, nd, ndp1, t1, q1, p1, ph1, & + lv1, cpn1, tv1, gz1, h1, hm1) + END IF + +! -------------------------------------------------------------------- +! --- CONVECTIVE FEED +! -------------------------------------------------------------------- + +! compute feeding layer potential temperature and mixing ratio : + +! get bounds of feeding layer + +! test niveaux couche alimentation KE + IF (sig1feed1==sig2feed1) THEN + WRITE (lunout, *) 'impossible de choisir sig1feed=sig2feed' + WRITE (lunout, *) 'changer la valeur de sig2feed dans physiq.def' + abort_message = '' + CALL abort_physic(modname, abort_message, 1) + END IF + + DO i = 1, len + p1feed1(i) = sig1feed1*ph1(i, 1) + p2feed1(i) = sig2feed1*ph1(i, 1) +!test maf +! p1feed1(i)=ph1(i,1) +! p2feed1(i)=ph1(i,2) +! p2feed1(i)=ph1(i,3) +!testCR: on prend la couche alim des thermiques +! p2feed1(i)=ph1(i,lalim_conv1(i)+1) +! print*,'lentr=',lentr(i),ph1(i,lentr(i)+1),ph1(i,2) + END DO + + IF (iflag_con==3) THEN + END IF + DO i = 1, len +! print*,'avant cv3_feed Plim',p1feed1(i),p2feed1(i) + END DO + IF (iflag_con==3) THEN + +! print*, 'IFLAG1 avant cv3_feed' +! print*,'len,nd',len,nd +! write(*,'(64i1)') iflag1(2:len-1) + + if (prt_level >= 9) & + PRINT *, 'cva_driver -> cv3_feed' + CALL cv3_feed(len, nd, ok_conserv_q, & ! nd->na + t1, q1, u1, v1, p1, ph1, h1, gz1, & + p1feed1, p2feed1, wght1, & + wghti1, tnk1, thnk1, qnk1, qsnk1, unk1, vnk1, & + cpnk1, hnk1, nk1, icb1, icbmax, iflag1, gznk1, plcl1) + END IF + +! print*, 'IFLAG1 apres cv3_feed' +! print*,'len,nd',len,nd +! write(*,'(64i1)') iflag1(2:len-1) + + IF (iflag_con==4) THEN + if (prt_level >= 9) & + PRINT *, 'cva_driver -> cv_feed' + CALL cv_feed(len, nd, t1, q1, qs1, p1, hm1, gz1, & + nk1, icb1, icbmax, iflag1, tnk1, qnk1, gznk1, plcl1) + END IF + +! print *, 'cv3_feed-> iflag1, plcl1 ',iflag1(1),plcl1(1) + +! -------------------------------------------------------------------- +! --- 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==3) THEN + + if (prt_level >= 9) & + PRINT *, 'cva_driver -> cv3_undilute1' + CALL cv3_undilute1(len, nd, t1, qs1, gz1, plcl1, p1, icb1, tnk1, qnk1, & ! nd->na + gznk1, tp1, tvp1, clw1, icbs1) + END IF + + + IF (iflag_con==4) THEN + if (prt_level >= 9) & + PRINT *, 'cva_driver -> cv_undilute1' + CALL cv_undilute1(len, nd, t1, q1, qs1, gz1, p1, nk1, icb1, icbmax, & + tp1, tvp1, clw1) + END IF + +! ------------------------------------------------------------------- +! --- TRIGGERING +! ------------------------------------------------------------------- + +! print *,' avant triggering, iflag_con ',iflag_con + + IF (iflag_con==3) THEN + + if (prt_level >= 9) & + PRINT *, 'cva_driver -> cv3_trigger' + CALL cv3_trigger(len, nd, icb1, plcl1, p1, th1, tv1, tvp1, thnk1, & ! nd->na + pbase1, buoybase1, iflag1, sig1, w01) + + +! print*, 'IFLAG1 apres cv3_triger' +! print*,'len,nd',len,nd +! write(*,'(64i1)') iflag1(2:len-1) + +! call dump2d(iim,jjm-1,sig1(2) + END IF + + IF (iflag_con==4) THEN + if (prt_level >= 9) & + PRINT *, 'cva_driver -> cv_trigger' + CALL cv_trigger(len, nd, icb1, cbmf1, tv1, tvp1, iflag1) + END IF + + +! ===================================================================== +! --- IF THIS POINT IS REACHED, MOIST CONVECTIVE ADJUSTMENT IS NECESSARY +! ===================================================================== + +! Determine the number "ncum" of convective gridpoints, the list "idcum" of convective +! gridpoints and the weights "coef_convective" (= 1. for convective gridpoints and = 0. +! elsewhere). + DO i = 1, len + IF (iflag1(i)==0) THEN + coef_convective(i) = 1. + is_convect(i) = .TRUE. + ELSE + coef_convective(i) = 0. + is_convect(i) = .FALSE. + END IF + END DO + + + IF (never_compress) THEN + compress = .FALSE. + DO i = 1,len + idcum(i) = i + ENDDO + ncum=len + ELSE + ncum = 0 + DO i = 1, len + IF (iflag1(i)==0) THEN + ncum = ncum + 1 + idcum(ncum) = i + END IF + END DO + + IF (ncum>0) THEN +! If the fraction of convective points is larger than comp_threshold, then compression +! is assumed useless. + compress = ncum .lt. len*comp_threshold + IF (.not. compress) THEN + DO i = 1,len + idcum(i) = i + ENDDO + ncum=len + ENDIF + ENDIF + + ENDIF + + IF (ncum>0) THEN + +! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +! --- COMPRESS THE FIELDS +! (-> vectorization over convective gridpoints) +! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + + IF (iflag_con==3) THEN + if (prt_level >= 9) PRINT *, 'cva_driver -> cv3a_compress' +!! CALL cv3a_compress(len, nloc, ncum, nd, ntra, compress, & !jyg: get rid of ntra + CALL cv3a_compress(len, nloc, ncum, nd, compress, & + iflag1, nk1, icb1, icbs1, & + plcl1, tnk1, qnk1, gznk1, hnk1, unk1, vnk1, & + wghti1, pbase1, buoybase1, & + t1, q1, qs1, t1_wake, q1_wake, qs1_wake, s1_wake, & + u1, v1, gz1, th1, th1_wake, & +!! tra1, & !jyg: get rid of ntra + h1, lv1, lf1, cpn1, p1, ph1, tv1, tp1, tvp1, clw1, & + h1_wake, lv1_wake, lf1_wake, cpn1_wake, tv1_wake, & + sig1, w01, ptop21, & + Ale1, Alp1, omega1, & + iflag, nk, icb, icbs, & + plcl, tnk, qnk, gznk, hnk, unk, vnk, & + wghti, pbase, buoybase, & + t, q, qs, t_wake, q_wake, qs_wake, s_wake, & + u, v, gz, th, th_wake, & +!! tra, & !jyg: get rid of ntra + h, lv, lf, cpn, p, ph, tv, tp, tvp, clw, & + h_wake, lv_wake, lf_wake, cpn_wake, tv_wake, & + sig, w0, ptop2, & + Ale, Alp, omega) + + + END IF + + IF (iflag_con==4) THEN + if (prt_level >= 9) PRINT *, 'cva_driver -> cv_compress' + CALL cv_compress(len, nloc, ncum, nd, & + iflag1, compress, nk1, icb1, & + cbmf1, plcl1, tnk1, qnk1, gznk1, & + t1, q1, qs1, u1, v1, gz1, & + h1, lv1, cpn1, p1, ph1, tv1, tp1, tvp1, clw1, & + iflag, nk, icb, & + cbmf, plcl, tnk, qnk, gznk, & + t, q, qs, u, v, gz, h, lv, cpn, p, ph, tv, tp, tvp, clw, & + dph) + END IF + +! ------------------------------------------------------------------- +! --- 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==3) THEN + if (prt_level >= 9) & + PRINT *, 'cva_driver -> cv3_undilute2' + CALL cv3_undilute2(nloc, ncum, nd, iflag, icb, icbs, nk, & !na->nd + tnk, qnk, gznk, hnk, t, q, qs, gz, & + p, ph, h, tv, lv, lf, pbase, buoybase, plcl, & + inb, tp, tvp, clw, hp, ep, sigp, buoy, & + frac_a, frac_s, qpreca, qta) !!jygprl + END IF + + IF (iflag_con==4) THEN + if (prt_level >= 9) & + PRINT *, 'cva_driver -> cv_undilute2' + CALL cv_undilute2(nloc, ncum, nd, icb, nk, & + tnk, qnk, gznk, t, q, qs, gz, & + p, dph, h, tv, lv, & + inb, inbis, tp, tvp, clw, hp, ep, sigp, frac_s) + END IF + + ! epmax_cape + ! on recalcule ep et hp + if (prt_level >= 9) & + PRINT *, 'cva_driver -> cv3_epmax_cape' + call cv3_epmax_fn_cape(nloc,ncum,nd & + , ep,hp,icb,inb,clw,nk,t,h,hnk,lv,lf,frac_s & + , pbase, p, ph, tv, buoy, sig, w0,iflag & + , epmax_diag) + +! ------------------------------------------------------------------- +! --- MIXING(1) (if iflag_mix .ge. 1) +! ------------------------------------------------------------------- + IF (iflag_con==3) THEN +! IF ((iflag_ice_thermo==1) .AND. (iflag_mix/=0)) THEN +! WRITE (*, *) ' iflag_ice_thermo==1 requires iflag_mix==0', ' but iflag_mix=', iflag_mix, & +! '. Might as well stop here.' +! STOP +! END IF + IF (iflag_mix>=1) THEN + supmax(:,:)=0. + if (prt_level >= 9) & + PRINT *, 'cva_driver -> cv3p_mixing' +!! CALL cv3p_mixing(nloc, ncum, nd, nd, ntra, icb, nk, inb, & ! na->nd !jyg: get rid of ntra + CALL cv3p_mixing(nloc, ncum, nd, nd, icb, nk, inb, & ! na->nd +!! ph, t, q, qs, u, v, tra, h, lv, lf, frac, qnk, & +!! ph, t, q, qs, u, v, tra, h, lv, lf, frac_s, qta, & !!jygprl !jyg: get rid of ntra + ph, t, q, qs, u, v, h, lv, lf, frac_s, qta, & !!jygprl + unk, vnk, hp, tv, tvp, ep, clw, sig, & + ment, qent, hent, uent, vent, nent, & +!! sigij, elij, supmax, ments, qents, traent) !jyg: get rid of ntra +!! sigij, elij, supmax, ments, qents) !jyg: get rid of ments + sigij, elij, supmax) +! print*, 'cv3p_mixing-> supmax ', (supmax(1,k), k=1,nd) + + ELSE + supmax(:,:)=0. + END IF + END IF +! ------------------------------------------------------------------- +! --- CLOSURE +! ------------------------------------------------------------------- + + + IF (iflag_con==3) THEN + IF (iflag_clos==0) THEN + if (prt_level >= 9) & + PRINT *, 'cva_driver -> cv3_closure' + CALL cv3_closure(nloc, ncum, nd, icb, inb, & ! na->nd + pbase, p, ph, tv, buoy, & + sig, w0, cape, m, iflag) + END IF ! iflag_clos==0 + + ok_inhib = iflag_mix == 2 + + IF (iflag_clos==1) THEN + PRINT *, ' pas d appel cv3p_closure' +! c CALL cv3p_closure(nloc,ncum,nd,icb,inb ! na->nd +! c : ,pbase,plcl,p,ph,tv,tvp,buoy +! c : ,supmax +! c o ,sig,w0,ptop2,cape,cin,m) + END IF ! iflag_clos==1 + + IF (iflag_clos==2) THEN + if (prt_level >= 9) & + PRINT *, 'cva_driver -> cv3p1_closure' + CALL cv3p1_closure(nloc, ncum, nd, icb, inb, & ! na->nd + pbase, plcl, p, ph, tv, tvp, buoy, & + supmax, ok_inhib, Ale, Alp, omega, & + sig, w0, ptop2, cape, cin, m, iflag, & + coef_clos_eff, coef_clos, & + Plim1, plim2, asupmax, supmax0, & + asupmaxmin, cbmf, plfc, wbeff) + if (prt_level >= 10) & + PRINT *, 'cv3p1_closure-> plfc,wbeff ', plfc(1), wbeff(1) + END IF ! iflag_clos==2 + + IF (iflag_clos==3) THEN + if (prt_level >= 9) & + PRINT *, 'cva_driver -> cv3p2_closure' + CALL cv3p2_closure(nloc, ncum, nd, icb, inb, & ! na->nd + pbase, plcl, p, ph, tv, tvp, buoy, & + supmax, ok_inhib, Ale, Alp, omega, & + sig, w0, ptop2, cape, cin, m, iflag, coef_clos_eff, & + Plim1, plim2, asupmax, supmax0, & + asupmaxmin, cbmf, plfc, wbeff) + if (prt_level >= 10) & + PRINT *, 'cv3p2_closure-> plfc,wbeff ', plfc(1), wbeff(1) + END IF ! iflag_clos==3 + END IF ! iflag_con==3 + + IF (iflag_con==4) THEN + if (prt_level >= 9) & + PRINT *, 'cva_driver -> cv_closure' + CALL cv_closure(nloc, ncum, nd, nk, icb, & + tv, tvp, p, ph, dph, plcl, cpn, & + iflag, cbmf) + END IF + +! print *,'cv_closure-> cape ',cape(1) + +! ------------------------------------------------------------------- +! --- MIXING(2) +! ------------------------------------------------------------------- + + IF (iflag_con==3) THEN + IF (iflag_mix==0) THEN + if (prt_level >= 9) & + PRINT *, 'cva_driver -> cv3_mixing' +!! CALL cv3_mixing(nloc, ncum, nd, nd, ntra, icb, nk, inb, & ! na->nd !jyg: get rid of ntra + CALL cv3_mixing(nloc, ncum, nd, nd, icb, nk, inb, & ! na->nd +!! ph, t, q, qs, u, v, tra, h, lv, lf, frac_s, qnk, & !jyg: get rid of ntra + ph, t, q, qs, u, v, h, lv, lf, frac_s, qnk, & + unk, vnk, hp, tv, tvp, ep, clw, m, sig, & +!! ment, qent, uent, vent, nent, sigij, elij, ments, qents, traent) !jyg: get rid of ntra +!! ment, qent, uent, vent, nent, sigij, elij, ments, qents) !jyg: get rid of ments + ment, qent, uent, vent, nent, sigij, elij) + hent(1:nloc,1:nd,1:nd) = 0. + ELSE +!!jyg: Essais absurde pour voir +!! mm(:,1) = 0. +!! DO i = 2,nd +!! mm(:,i) = m(:,i)*(1.-qta(:,i-1)) +!! ENDDO + mm(:,:) = m(:,:) + CALL cv3_mixscale(nloc, ncum, nd, ment, mm) + IF (debut) THEN + PRINT *, ' cv3_mixscale-> ' + END IF !(debut) THEN + END IF + END IF + + IF (iflag_con==4) THEN + if (prt_level >= 9) & + PRINT *, 'cva_driver -> cv_mixing' + 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, & + m, ment, qent, uent, vent, nent, sigij, elij) + END IF + + IF (debut) THEN + PRINT *, ' cv_mixing ->' + END IF !(debut) THEN +! do i = 1,nd +! print*,'cv_mixing-> i,ment ',i,(ment(1,i,j),j=1,nd) +! enddo + +! ------------------------------------------------------------------- +! --- UNSATURATED (PRECIPITATING) DOWNDRAFTS +! ------------------------------------------------------------------- + IF (iflag_con==3) THEN + IF (debut) THEN + PRINT *, ' cva_driver -> cv3_unsat ' + END IF !(debut) THEN + + if (prt_level >= 9) & + PRINT *, 'cva_driver -> cv3_unsat' +!! CALL cv3_unsat(nloc, ncum, nd, nd, ntra, icb, inb, iflag, & ! na->nd !jyg: get rid of ntra + CALL cv3_unsat(nloc, ncum, nd, nd, icb, inb, iflag, & ! na->nd +!! t_wake, q_wake, qs_wake, gz, u, v, tra, p, ph, & !jyg: get rid of ntra + t_wake, q_wake, qs_wake, gz, u, v, p, ph, & + th_wake, tv_wake, lv_wake, lf_wake, cpn_wake, & + ep, sigp, clw, frac_s, qpreca, frac_a, qta, & !!jygprl + m, ment, elij, delt, plcl, coef_clos_eff, & +!! mp, qp, up, vp, trap, wt, water, evap, fondue, ice, & !jyg: get rid of ntra + mp, qp, up, vp, wt, water, evap, fondue, ice, & + faci, b, sigd, & +!! wdtrainA, wdtrainM) ! RomP + wdtrainA, wdtrainS, wdtrainM) !!jygprl +! + IF (prt_level >= 10) THEN + Print *, 'cva_driver after cv3_unsat:mp , water, ice, evap, fondue ' + DO k = 1,nd + write (6, '(i4,5(1x,e13.6))') & + k, mp(igout,k), water(igout,k), ice(igout,k), & + evap(igout,k), fondue(igout,k) + ENDDO + Print *, 'cva_driver after cv3_unsat: wdtrainA, wdtrainS, wdtrainM ' !!jygprl + DO k = 1,nd + write (6, '(i4,3(1x,e13.6))') & + k, wdtrainA(igout,k), wdtrainS(igout,k), wdtrainM(igout,k) !!jygprl + ENDDO + ENDIF +! + END IF !(iflag_con==3) + + IF (iflag_con==4) THEN + if (prt_level >= 9) & + PRINT *, 'cva_driver -> cv_unsat' + CALL 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) + END IF + + IF (debut) THEN + PRINT *, 'cv_unsat-> ' + END IF !(debut) THEN + +! print *,'cv_unsat-> mp ',mp +! print *,'cv_unsat-> water ',water +! ------------------------------------------------------------------- +! --- YIELD +! (tendencies, precipitation, variables of interface with other +! processes, etc) +! ------------------------------------------------------------------- + + IF (iflag_con==3) THEN + + if (prt_level >= 9) & + PRINT *, 'cva_driver -> cv3_yield' +!! CALL cv3_yield(nloc, ncum, nd, nd, ntra, ok_conserv_q, & ! na->nd !jyg: get rid of ntra + CALL cv3_yield(nloc, ncum, nd, nd, ok_conserv_q, & ! na->nd + icb, inb, delt, & +!! t, q, t_wake, q_wake, s_wake, u, v, tra, & !jyg: get rid of ntra + t, q, t_wake, q_wake, s_wake, u, v, & + gz, p, ph, h, hp, lv, lf, cpn, th, th_wake, & +!! ep, clw, qpreca, m, tp, mp, qp, up, vp, trap, & !jyg: get rid of ntra + ep, clw, qpreca, m, tp, mp, qp, up, vp, & + wt, water, ice, evap, fondue, faci, b, sigd, & + ment, qent, hent, iflag_mix, uent, vent, & +!! nent, elij, traent, sig, & !jyg: get rid of ntra + nent, elij, sig, & + tv, tvp, wghti, & +!! iflag, precip, Vprecip, Vprecipi, ft, fq, fqcomp, fu, fv, ftra, & !jyg: get rid of ntra + iflag, precip, Vprecip, Vprecipi, ft, fq, fqcomp, fu, fv, & + cbmf, upwd, dnwd, dnwd0, ma, mip, & +!! tls, tps, & ! useless . jyg + qcondc, wd, & +!! ftd, fqd, qnk, qtc, sigt, tau_cld_cv, coefw_cld_cv) + ftd, fqd, qta, qtc, sigt, detrain, tau_cld_cv, coefw_cld_cv) !!jygprl +! +! Test conseravtion de l'eau +! + IF (debut) THEN + PRINT *, ' cv3_yield -> fqd(1) = ', fqd(igout, 1) + END IF !(debut) THEN +! + IF (prt_level >= 10) THEN + Print *, 'cva_driver after cv3_yield:ft(1) , ftd(1) ', & + ft(igout,1), ftd(igout,1) + Print *, 'cva_driver after cv3_yield:fq(1) , fqd(1) ', & + fq(igout,1), fqd(igout,1) + ENDIF +! + END IF + + IF (iflag_con==4) THEN + if (prt_level >= 9) & + PRINT *, 'cva_driver -> cv_yield' + CALL cv_yield(nloc, ncum, nd, nk, icb, inb, delt, & + t, q, u, v, & + gz, p, ph, h, hp, lv, cpn, & + ep, clw, frac_s, m, mp, qp, up, vp, & + wt, water, evap, & + ment, qent, uent, vent, nent, elij, & + tv, tvp, & + iflag, wd, qprime, tprime, & + precip, cbmf, ft, fq, fu, fv, ma, qcondc) + END IF + +!AC! +!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +!--- passive tracers +!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + + IF (iflag_con==3) THEN +!RomP >>> + if (prt_level >= 9) & + PRINT *, 'cva_driver -> cv3_tracer' + CALL cv3_tracer(nloc, len, ncum, nd, nd, & + ment, sigij, da, phi, phi2, d1a, dam, & + ep, vprecip, elij, clw, epmlmMm, eplaMm, & + icb, inb) +!RomP <<< + END IF + +!AC! + +! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +! --- UNCOMPRESS THE FIELDS +! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + + + IF (iflag_con==3) THEN + if (prt_level >= 9) & + PRINT *, 'cva_driver -> cv3a_uncompress' +!! CALL cv3a_uncompress(nloc, len, ncum, nd, ntra, idcum, is_convect, compress, & !jyg: get rid of ntra + CALL cv3a_uncompress(nloc, len, ncum, nd, idcum, is_convect, compress, & + iflag, icb, inb, & + precip, cbmf, plcl, plfc, wbeff, sig, w0, ptop2, & +!! ft, fq, fqcomp, fu, fv, ftra, & !jyg: get rid of ntra + ft, fq, fqcomp, fu, fv, & + sigd, ma, mip, vprecip, vprecipi, upwd, dnwd, dnwd0, & + qcondc, wd, cape, cin, & + tvp, & + ftd, fqd, & + Plim1, plim2, asupmax, supmax0, & + asupmaxmin, & + coef_clos, coef_clos_eff, & + da, phi, mp, phi2, d1a, dam, sigij, & ! RomP + qta, clw, elij, evap, ep, epmlmMm, eplaMm, & ! RomP + wdtrainA, wdtrainS, wdtrainM, & ! RomP + qtc, sigt, detrain, epmax_diag, & ! epmax_cape + iflag1, kbas1, ktop1, & + precip1, cbmf1, plcl1, plfc1, wbeff1, sig1, w01, ptop21, & +!! ft1, fq1, fqcomp1, fu1, fv1, ftra1, & !jyg: get rid of ntra + ft1, fq1, fqcomp1, fu1, fv1, & + sigd1, ma1, mip1, vprecip1, vprecipi1, upwd1, dnwd1, dnwd01, & + qcondc1, wd1, cape1, cin1, & + tvp1, & + ftd1, fqd1, & + Plim11, plim21, asupmax1, supmax01, & + asupmaxmin1, & + coef_clos1, coef_clos_eff1, & + da1, phi1, mp1, phi21, d1a1, dam1, sigij1, & ! RomP + qta1, clw1, elij1, evap1, ep1, epmlmMm1, eplaMm1, & ! RomP + wdtrainA1, wdtrainS1, wdtrainM1, & ! RomP + qtc1, sigt1, detrain1, epmax_diag1) ! epmax_cape +! + IF (prt_level >= 10) THEN + Print *, 'cva_driver after cv3_uncompress:ft1(1) , ftd1(1) ', & + ft1(igout,1), ftd1(igout,1) + Print *, 'cva_driver after cv3_uncompress:fq1(1) , fqd1(1) ', & + fq1(igout,1), fqd1(igout,1) + ENDIF +! + END IF + + IF (iflag_con==4) THEN + if (prt_level >= 9) & + PRINT *, 'cva_driver -> cv_uncompress' + CALL cv_uncompress(nloc, len, ncum, nd, idcum, is_convect, compress, & + iflag, & + precip, cbmf, & + ft, fq, fu, fv, & + ma, qcondc, & + iflag1, & + precip1,cbmf1, & + ft1, fq1, fu1, fv1, & + ma1, qcondc1) + END IF + + END IF ! ncum>0 +! +! + DO i = 1,len + IF (iflag1(i) == 14) THEN + Cin1(i) = Cin_noconv + Cape1(i) = Cape_noconv + ENDIF + ENDDO + +! +! In order take into account the possibility of changing the compression, +! reset m, sig and w0 to zero for non-convective points. + DO k = 1,nd-1 + sig1(:, k) = sig1(:, k)*coef_convective(:) + w01(:, k) = w01(:, k)*coef_convective(:) + ENDDO + + IF (debut) THEN + PRINT *, ' cv_uncompress -> ' + END IF !(debut) THEN + + + RETURN +END SUBROUTINE cva_driver + +END MODULE cva_driver_mod Index: LMDZ6/trunk/libf/phylmd/diag_slp.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/diag_slp.f90 (revision 6047) +++ (revision ) @@ -1,58 +1,0 @@ -!$gpum horizontal nlon klon -MODULE diag_slp_mod - PRIVATE - - PUBLIC diag_slp - - CONTAINS - -SUBROUTINE diag_slp(nlon,t,pab,pal,pphis,tasfc,tastd,pmer) - USE dimphy - USE phys_output_write_mod - USE phys_output_ctrlout_mod - USE phys_local_var_mod - USE ctstart_mod, ONLY: ctstar - USE pppmer_mod, ONLY: pppmer - - IMPLICIT NONE - !>====================================================================== - !! - !! Auteur(s) I.Musat (LMD/CNRS) date: 20151106 - !! - !! Objet: Calcul pression au niveau de la mer cf. Arpege-IFS - !! ctstar: calcule la temperature de l'air a la surface (tasfc) et - !! la temperature de l'air standard a la surface (tastd) - !! pppmer: calcule la slp a partir de tasfc, tastd, de la pression a la surface (pab1) - !! et du geopotentiel de la surface - !!====================================================================== - !! nlon--input-R-temperature au milieu de chaque couche (en K) - !! t--input-R-temperature au milieu de chaque couche (en K) - !! pab--input-R-pression pour chaque inter-couche (en Pa) - !! pal---input-R-pression pour le mileu de chaque couche (en Pa) - !! pphis---input-R-geopotentiel du sol (en m2/s2) - !! tasfc---output-R-temperature air au sol (en K) - !! tastd---output-R-temperature air 'standard' au sol (en K) - !! pmer---output-R-pression au niveau de la mer (en Pa) - !!====================================================================== - INTEGER, INTENT(IN) :: nlon - REAL t(nlon,klev) - REAL pab(nlon,klev+1) - REAL pal(nlon,klev) - REAL pphis(nlon) - REAL tasfc(nlon), tastd(nlon) - REAL pmer(nlon) -!!! -!!! calcul tasfc et tastd - tal1(:)=t(:,1) - pab2(:)=pab(:,2) - pal1(:)=pal(:,1) - CALL ctstar(nlon,1,nlon,tal1,pab2,pal1,pphis,tasfc,tastd) -!!! -!!! calcul slp - pab1(:)=pab(:,1) - CALL pppmer(nlon,1,nlon,pab1,pphis,tasfc,tastd,pmer) -! - RETURN - END SUBROUTINE diag_slp - -END MODULE diag_slp_mod Index: LMDZ6/trunk/libf/phylmd/diag_slp_mod.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/diag_slp_mod.f90 (revision 6048) +++ LMDZ6/trunk/libf/phylmd/diag_slp_mod.f90 (revision 6048) @@ -0,0 +1,58 @@ +!$gpum horizontal nlon klon +MODULE diag_slp_mod + PRIVATE + + PUBLIC diag_slp + + CONTAINS + +SUBROUTINE diag_slp(nlon,t,pab,pal,pphis,tasfc,tastd,pmer) + USE dimphy + USE phys_output_write_mod + USE phys_output_ctrlout_mod + USE phys_local_var_mod + USE ctstart_mod, ONLY: ctstar + USE pppmer_mod, ONLY: pppmer + + IMPLICIT NONE + !>====================================================================== + !! + !! Auteur(s) I.Musat (LMD/CNRS) date: 20151106 + !! + !! Objet: Calcul pression au niveau de la mer cf. Arpege-IFS + !! ctstar: calcule la temperature de l'air a la surface (tasfc) et + !! la temperature de l'air standard a la surface (tastd) + !! pppmer: calcule la slp a partir de tasfc, tastd, de la pression a la surface (pab1) + !! et du geopotentiel de la surface + !!====================================================================== + !! nlon--input-R-temperature au milieu de chaque couche (en K) + !! t--input-R-temperature au milieu de chaque couche (en K) + !! pab--input-R-pression pour chaque inter-couche (en Pa) + !! pal---input-R-pression pour le mileu de chaque couche (en Pa) + !! pphis---input-R-geopotentiel du sol (en m2/s2) + !! tasfc---output-R-temperature air au sol (en K) + !! tastd---output-R-temperature air 'standard' au sol (en K) + !! pmer---output-R-pression au niveau de la mer (en Pa) + !!====================================================================== + INTEGER, INTENT(IN) :: nlon + REAL t(nlon,klev) + REAL pab(nlon,klev+1) + REAL pal(nlon,klev) + REAL pphis(nlon) + REAL tasfc(nlon), tastd(nlon) + REAL pmer(nlon) +!!! +!!! calcul tasfc et tastd + tal1(:)=t(:,1) + pab2(:)=pab(:,2) + pal1(:)=pal(:,1) + CALL ctstar(nlon,1,nlon,tal1,pab2,pal1,pphis,tasfc,tastd) +!!! +!!! calcul slp + pab1(:)=pab(:,1) + CALL pppmer(nlon,1,nlon,pab1,pphis,tasfc,tastd,pmer) +! + RETURN + END SUBROUTINE diag_slp + +END MODULE diag_slp_mod Index: LMDZ6/trunk/libf/phylmd/ecumev6_flux.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecumev6_flux.f90 (revision 6047) +++ (revision ) @@ -1,782 +1,0 @@ -MODULE ecumev6_flux_mod - -CONTAINS -!SFX_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier -!SFX_LIC This is part of the SURFEX software governed by the CeCILL-C licence -!SFX_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt -!SFX_LIC for details. version 1. -! ######### - SUBROUTINE ecumev6_flux(knon, klon, PZ0SEA,PTA,PSST,PQA,PQSAT,PVMOD, & - PZREF,PSSS,PUREF,PPS,PPA,OPRECIP,OPWEBB, & - PSFTH,PSFTQ,PUSTAR,PCD,PCDN,PCH,PCE, & - PRI,PRESA,PRAIN,PZ0HSEA,OPERTFLUX,coeffs ) -!$gpum horizontal knon -!############################################################################### -!! -!!**** *ECUMEV6_FLUX* -!! -!! PURPOSE -!! ------- -! Calculate the surface turbulent fluxes of heat, moisture, and momentum -! over sea surface + corrections due to rainfall & Webb effect. -!! -!!** METHOD -!! ------ -! The estimation of the transfer coefficients relies on the iterative -! computation of the scaling parameters U*/Teta*/q*. The convergence is -! supposed to be reached in NITERFL iterations maximum. -! Neutral transfer coefficients for momentum/temperature/humidity -! are computed as a function of the 10m-height neutral wind speed using -! the ECUME_V6 formulation based on the multi-campaign (POMME,FETCH,CATCH, -! SEMAPHORE,EQUALANT) ALBATROS dataset. -!! -!! EXTERNAL -!! -------- -!! -!! IMPLICIT ARGUMENTS -!! ------------------ -!! -!! REFERENCE -!! --------- -!! Fairall et al (1996), JGR, 3747-3764 -!! Gosnell et al (1995), JGR, 437-442 -!! Fairall et al (1996), JGR, 1295-1308 -!! -!! AUTHOR -!! ------ -!! C. Lebeaupin *Météo-France* (adapted from S. Belamari's code) -!! -!! MODIFICATIONS -!! ------------- -!! Original 15/03/2005 -!! Modified 01/2006 C. Lebeaupin (adapted from A. Pirani's code) -!! Modified 08/2009 B. Decharme: limitation of Ri -!! Modified 09/2012 B. Decharme: CD correction -!! Modified 09/2012 B. Decharme: limitation of Ri in surface_ri.F90 -!! Modified 10/2012 P. Le Moigne: extra inputs for FLake use -!! Modified 06/2013 B. Decharme: bug in z0 (output) computation -!! Modified 12/2013 S. Belamari: ZRF computation updated: -!! 1. ZP00/PPA in ZDWAT, ZLVA in ZDQSDT/ZBULB/ZRF -!! 2. ZDWAT/ZDTMP in ZBULB/ZRF (Gosnell et al 95) -!! 3. cool skin correction included -!! Modified 01/2014 S. Belamari: salinity impact on latent heat of -!! vaporization of seawater included -!! Modified 01/2014 S. Belamari: new formulation for pure water -!! specific heat (ZCPWA) -!! Modified 01/2014 S. Belamari: 4 choices for PZ0SEA computation -!! Modified 12/2015 S. Belamari: ECUME now provides parameterisations -!! for: U10n*sqrt(CDN) instead of CDN -!! U10n*CHN/sqrt(CDN) " CHN -!! U10n*CEN/sqrt(CDN) " CEN -!! Modified 01/2016 S. Belamari: New ECUME formulation -!! -!! To be done: -!! include gustiness computation following Mondon & Redelsperger (1998) -!!! -!------------------------------------------------------------------------------- -!! -!! MODIFICATIONS RELATED TO SST CORRECTION COMPUTATION -!! --------------------------------------------------- -!! Modified 09/2013 S. Belamari: use 0.98 for the ocean emissivity -!! following up to date satellite measurements in -!! the 8-14 μm range (obtained values range from -!! 0.98 to 0.99). -!!! -!------------------------------------------------------------------------------- -! -! 0. DECLARATIONS -! ------------ -! -USE indice_sol_mod -USE MODD_CSTS, ONLY : XPI, XDAY, XKARMAN, XG, XP00, XSTEFAN, XRD, XRV, & - XCPD, XCPV, XCL, XTT, XLVTT - - -!USE MODD_SURF_PAR, ONLY : XUNDEF -!USE MODD_SURF_ATM, ONLY : XVCHRNK, XVZ0CM -!USE MODD_REPROD_OPER, ONLY : CCHARNOCK -! -!USE MODE_THERMOS -!USE MODI_WIND_THRESHOLD -!USE MODI_SURFACE_RI -! -!USE YOMHOOK, ONLY : LHOOK, DR_HOOK -!USE PARKIND1, ONLY : JPRB -! -!USE MODI_ABOR1_SFX -USE yomcst_mod_h -USE clesphys_mod_h -USE qsat_seawater_mod, ONLY : qsat_seawater -USE qsat_seawater2_mod, ONLY : qsat_seawater2 -IMPLICIT NONE -! -! 0.1. Declarations of arguments -! -INTEGER, INTENT(IN) :: knon ! horizontal indice (compressed ? ) -INTEGER, INTENT(IN) :: klon ! horizontal indice (fake == 1?) -REAL, DIMENSION(klon), INTENT(IN) :: PVMOD ! module of wind at atm level (m/s) -REAL, DIMENSION(klon), INTENT(IN) :: PTA ! air temperature at atm level (K) -REAL, DIMENSION(klon), INTENT(IN) :: PQA ! air spec. hum. at atm level (kg/kg) -REAL, DIMENSION(klon), INTENT(IN) :: PQSAT ! sea surface spec. hum. (kg/kg) -REAL, DIMENSION(klon), INTENT(IN) :: PPA ! air pressure at atm level (Pa) -!REAL, DIMENSION(:), INTENT(IN) :: PRHOA ! air density at atm level (kg/m3) -!REAL, DIMENSION(:), INTENT(IN) :: PEXNA ! Exner function at atm level -REAL, DIMENSION(klon), INTENT(IN) :: PUREF ! atm level for wind (m) -REAL, DIMENSION(klon), INTENT(IN) :: PZREF ! atm level for temp./hum. (m) -REAL, DIMENSION(klon), INTENT(IN) :: PSSS ! Sea Surface Salinity (g/kg) -REAL, DIMENSION(klon), INTENT(IN) :: PPS ! air pressure at sea surface (Pa) -!REAL, DIMENSION(:), INTENT(IN) :: PEXNS ! Exner function at sea surface -!REAL, DIMENSION(:), INTENT(IN) :: PPERTFLUX ! stochastic flux perturbation pattern -! for correction -!REAL, INTENT(IN) :: PICHCE ! -LOGICAL, INTENT(IN) :: OPRECIP ! -LOGICAL, INTENT(IN) :: OPWEBB ! -LOGICAL, INTENT(IN) :: OPERTFLUX -REAL, DIMENSION(klon), INTENT(IN) :: PRAIN ! precipitation rate (kg/s/m2) -! -!INTEGER, INTENT(IN) :: KZ0 -! -REAL, DIMENSION(klon), INTENT(INOUT) :: PSST ! Sea Surface Temperature (K) -REAL, DIMENSION(klon), INTENT(INOUT) :: PZ0SEA ! roughness length over sea -REAL, DIMENSION(klon), INTENT(OUT) :: PZ0HSEA ! heat roughness length over sea - -! surface fluxes : latent heat, sensible heat, friction fluxes -REAL, DIMENSION(klon), INTENT(OUT) :: PUSTAR ! friction velocity (m/s) -REAL, DIMENSION(klon), INTENT(OUT) :: PSFTH ! heat flux (W/m2) -REAL, DIMENSION(klon), INTENT(OUT) :: PSFTQ ! water flux (kg/m2/s) - -! diagnostics -REAL, DIMENSION(klon), INTENT(OUT) :: PCD ! transfer coef. for momentum -REAL, DIMENSION(klon), INTENT(OUT) :: PCH ! transfer coef. for temperature -REAL, DIMENSION(klon), INTENT(OUT) :: PCE ! transfer coef. for humidity -REAL, DIMENSION(klon), INTENT(OUT) :: PCDN ! neutral coef. for momentum -REAL, DIMENSION(klon), INTENT(OUT) :: PRI ! Richardson number -REAL, DIMENSION(klon), INTENT(OUT) :: PRESA ! aerodynamical resistance -real, dimension(3), intent(out) :: coeffs - -! 0.2. Declarations of local variables -! -! specif SB -INTEGER, DIMENSION(klon) :: JCV ! convergence index -INTEGER, DIMENSION(klon) :: JITER ! nb of iterations to converge -!rajout -REAL, DIMENSION(klon) :: PEXNA ! Exner function at atm level -REAL, DIMENSION(klon) :: PEXNS ! Exner function at atm level -! -REAL, DIMENSION(klon) :: ZTAU ! momentum flux (N/m2) -REAL, DIMENSION(klon) :: ZHF ! sensible heat flux (W/m2) -REAL, DIMENSION(klon) :: ZEF ! latent heat flux (W/m2) -REAL, DIMENSION(klon) :: ZTAUR ! momentum flx due to rain (N/m2) -REAL, DIMENSION(klon) :: ZRF ! sensible flx due to rain (W/m2) -REAL, DIMENSION(klon) :: ZEFWEBB ! Webb corr. on latent flx (W/m2) - -REAL, DIMENSION(klon) :: ZVMOD ! wind intensity at atm level (m/s) -REAL, DIMENSION(klon) :: ZQSATA ! sat.spec.hum. at atm level (kg/kg) -REAL, DIMENSION(klon) :: ZLVA ! vap.heat of pure water at atm level (J/kg) -REAL, DIMENSION(klon) :: ZLVS ! vap.heat of seawater at sea surface (J/kg) -REAL, DIMENSION(klon) :: ZCPA ! specif.heat moist air (J/kg/K) -REAL, DIMENSION(klon) :: ZVISA ! kinemat.visc. of dry air (m2/s) -REAL, DIMENSION(klon) :: ZDU ! U vert.grad. (real atm) -REAL, DIMENSION(klon) :: ZDT,ZDQ ! T,Q vert.grad. (real atm) -REAL, DIMENSION(klon) :: ZDDU ! U vert.grad. (real atm + gust) -REAL, DIMENSION(klon) :: ZDDT,ZDDQ ! T,Q vert.grad. (real atm + WL/CS) -REAL, DIMENSION(klon) :: ZUSR ! velocity scaling param. (m/s) - ! =friction velocity -REAL, DIMENSION(klon) :: ZTSR ! temperature scaling param. (K) -REAL, DIMENSION(klon) :: ZQSR ! humidity scaling param. (kg/kg) -REAL, DIMENSION(klon) :: ZDELTAU10N,ZDELTAT10N,ZDELTAQ10N - ! U,T,Q vert.grad. (10m, neutral atm) -REAL, DIMENSION(klon) :: ZUSR0,ZTSR0,ZQSR0 ! ITERATIVE PROCESS -REAL, DIMENSION(klon) :: ZDUSTO,ZDTSTO,ZDQSTO ! ITERATIVE PROCESS -REAL, DIMENSION(klon) :: ZPSIU,ZPSIT! PSI funct for U, T/Q (Z0 comp) -REAL, DIMENSION(klon) :: ZCHARN ! Charnock parameter (Z0 comp) - -REAL, DIMENSION(klon) :: ZUSTAR2 ! square of friction velocity -REAL, DIMENSION(klon) :: ZAC ! aerodynamical conductance -REAL, DIMENSION(klon) :: ZDIRCOSZW ! orography slope cosine - ! (=1 on water!) -REAL, DIMENSION(klon) :: ZPARUN,ZPARTN,ZPARQN ! neutral parameter for U,T,Q - -!-- rajout pour la pression saturante -REAL, DIMENSION(klon) :: ZFOES ! [OPWEBB] -REAL, DIMENSION(klon) :: ZWORK1 -REAL, DIMENSION(klon) :: ZWORK2 -REAL, DIMENSION(klon) :: ZWORK1A -REAL, DIMENSION(klon) :: ZWORK2A -!##################### - -REAL, DIMENSION(0:5) :: ZCOEFU,ZCOEFT,ZCOEFQ - -!--------- Modif Olive ----------------- -REAL, DIMENSION(klon) :: PRHOA -REAL, PARAMETER :: XUNDEF = 1.E+20 - - -REAL :: XVCHRNK = 0.021 -REAL :: XVZ0CM = 1.0E-5 -!REAL :: XRIMAX - -CHARACTER :: CCHARNOCK = 'NEW' - - -!-------------------------------------- - - -! local constants -LOGICAL :: OPCVFLX ! to force convergence -INTEGER :: NITERMAX ! nb of iterations to get free convergence -INTEGER :: NITERSUP ! nb of additional iterations if OPCVFLX=.TRUE. -INTEGER :: NITERFL ! maximum number of iterations -REAL :: ZETV,ZRDSRV ! thermodynamic constants -REAL :: ZSQR3 -REAL :: ZLMOMIN,ZLMOMAX ! min/max value of Obukhovs stability param. z/l -REAL :: ZBTA,ZGMA ! parameters of the stability functions -REAL :: ZDUSR0,ZDTSR0,ZDQSR0 ! maximum gap for USR/TSR/QSR between 2 steps -REAL :: ZP00 ! [OPRECIP] - water vap. diffusiv.ref.press.(Pa) -REAL :: ZUTU,ZUTT,ZUTQ ! U10n threshold in ECUME parameterisation -REAL :: ZCDIRU,ZCDIRT,ZCDIRQ ! coef directeur pour fonction affine U,T,Q -REAL :: ZORDOU,ZORDOT,ZORDOQ ! ordonnee a l'origine pour fonction affine U,T,Q - -INTEGER :: JJ ! for ITERATIVE PROCESS -INTEGER :: JLON,JK -REAL :: ZLMOU,ZLMOT ! Obukhovs param. z/l for U, T/Q -REAL :: ZPSI_U,ZPSI_T ! PSI funct. for U, T/Q -REAL :: Z0TSEA,Z0QSEA ! roughness length for T, Q -REAL :: ZCHIC,ZCHIK,ZPSIC,ZPSIK,ZLOGUS10,ZLOGTS10 -REAL :: ZTAC,ZCPWA,ZDQSDT,ZDWAT,ZDTMP,ZBULB ! [OPRECIP] -REAL :: ZWW ! [OPWEBB] - - -INTEGER :: PREF ! reference pressure for exner function -REAL, DIMENSION(klon) :: PQSATA ! sea surface spec. hum. (kg/kg) - -!REAL(KIND=JPRB) :: ZHOOK_HANDLE -! -!------------------------------------------------------------------------------- -!----------------------- Modif Olive calcul de PRHOA --------------------------- - -!write(*,*) "PZ0SEA ",PZ0SEA -!write(*,*) "PTA ",PTA -!write(*,*) "PSST ",PSST -!write(*,*) "PQA ",PQA -!write(*,*) "PVMOD ",PVMOD -!write(*,*) "PZREF ",PZREF -!write(*,*) "PUREF ",PUREF -!write(*,*) "PPS ",PPS -!write(*,*) "PPA ",PPA -!write(*,*) "OPRECIP ",OPRECIP -!write(*,*) "PZ0HSEA ",PZ0HSEA -!write(*,*) "PRAIN ",PRAIN - - -PRHOA(:) = PPS(:) / (287.1 * PTA(:) * (1.+.61*PQA(:))) -!write(*,*) "klon klon ",klon,PTA -!write(*,*) "PRHOA ",SIZE(PRHOA),PRHOA - -PREF = 100900. ! = 1000 hPa - -!PEXNA = (PPA/PPS)**RKAPPA -!PEXNS = (PPS/PPS)**RKAPPA - -PEXNA = (PPA/PREF)**(RD/RCPD) -PEXNS = (PPS/PREF)**(RD/RCPD) - -!IF (LHOOK) CALL DR_HOOK('ECUMEV6_FLUX',0,ZHOOK_HANDLE) -! -ZDUSR0 = 1.E-06 -ZDTSR0 = 1.E-06 -ZDQSR0 = 1.E-09 -! -NITERMAX = 5 -NITERSUP = 5 -OPCVFLX = .TRUE. -! -NITERFL = NITERMAX -IF (OPCVFLX) NITERFL = NITERMAX+NITERSUP -! -ZCOEFU = (/ 1.00E-03, 3.66E-02, -1.92E-03, 2.32E-04, -7.02E-06, 6.40E-08 /) -ZCOEFT = (/ 5.36E-03, 2.90E-02, -1.24E-03, 4.50E-04, -2.06E-05, 0.0 /) -ZCOEFQ = (/ 1.00E-03, 3.59E-02, -2.87E-04, 0.0, 0.0, 0.0 /) -! -ZUTU = 40.0 -ZUTT = 14.4 -ZUTQ = 10.0 -! -ZCDIRU = ZCOEFU(1) + 2.0*ZCOEFU(2)*ZUTU + 3.0*ZCOEFU(3)*ZUTU**2 & - + 4.0*ZCOEFU(4)*ZUTU**3 + 5.0*ZCOEFU(5)*ZUTU**4 -ZCDIRT = ZCOEFT(1) + 2.0*ZCOEFT(2)*ZUTT + 3.0*ZCOEFT(3)*ZUTT**2 & - + 4.0*ZCOEFT(4)*ZUTT**3 -ZCDIRQ = ZCOEFQ(1) + 2.0*ZCOEFQ(2)*ZUTQ -! -ZORDOU = ZCOEFU(0) + ZCOEFU(1)*ZUTU + ZCOEFU(2)*ZUTU**2 + ZCOEFU(3)*ZUTU**3 & - + ZCOEFU(4)*ZUTU**4 + ZCOEFU(5)*ZUTU**5 -ZORDOT = ZCOEFT(0) + ZCOEFT(1)*ZUTT + ZCOEFT(2)*ZUTT**2 + ZCOEFT(3)*ZUTT**3 & - + ZCOEFT(4)*ZUTT**4 -ZORDOQ = ZCOEFQ(0) + ZCOEFQ(1)*ZUTQ + ZCOEFQ(2)*ZUTQ**2 -! -!------------------------------------------------------------------------------- -! -! 1. AUXILIARY CONSTANTS & ARRAY INITIALISATION BY UNDEFINED VALUES. -! -------------------------------------------------------------------- -! -ZDIRCOSZW(:) = 1.0 -! -ZETV = XRV/XRD-1.0 !~0.61 (cf Liu et al. 1979) -ZRDSRV = XRD/XRV !~0.622 -ZSQR3 = SQRT(3.0) -ZLMOMIN = -200.0 -ZLMOMAX = 0.25 -ZBTA = 16.0 -ZGMA = 7.0 !initially =4.7, modified to 7.0 following G. Caniaux -! -ZP00 = 1013.25E+02 -! -PCD = XUNDEF -PCH = XUNDEF -PCE = XUNDEF -PCDN = XUNDEF -ZUSR = XUNDEF -ZTSR = XUNDEF -ZQSR = XUNDEF -ZTAU = XUNDEF -ZHF = XUNDEF -ZEF = XUNDEF -! -PSFTH = XUNDEF -PSFTQ = XUNDEF -PUSTAR = XUNDEF -PRESA = XUNDEF -PRI = XUNDEF -! -ZTAUR = 0.0 -ZRF = 0.0 -ZEFWEBB = 0.0 -! -!------------------------------------------------------------------------------- -! -! 2. INITIALISATIONS BEFORE ITERATIVE LOOP. -! ------------------------------------------- -! -!ZVMOD(:) = WIND_THRESHOLD(PVMOD(:),PUREF(:)) !set a minimum value to wind -ZVMOD = MAX(PVMOD , 0.1 * MIN(10.,PUREF) ) !set a minimum value to wind - -write(*,*) "ZVMOD ",SIZE(ZVMOD) - -! -! 2.0. Radiative fluxes - For warm layer & cool skin -! -! 2.0b. Warm Layer correction -! -! 2.1. Specific humidity at saturation -! -WHERE(PSSS(:)>0.0.AND.PSSS(:)/=XUNDEF) - PQSATA = QSAT_SEAWATER2 (knon, klon, PSST(:),PPS(:),PSSS(:)) !at sea surface -ELSEWHERE - PQSATA (:) = QSAT_SEAWATER (knon, klon, PSST(:),PPS(:)) !at sea surface -ENDWHERE - -!ZQSATA(:) = QSAT(PTA(:),PPA(:)) !at atm level - -!### OLIVIER POUR PRESSION SATURANTE ##### -!------------------------------------------------------------------------------- -! -ZFOES = 1 !PSAT(PT(:)) -ZFOES = 0.98*ZFOES -! -ZWORK1 = ZFOES/PPS -ZWORK2 = XRD/XRV - -ZWORK1A = ZFOES/PPA -ZWORK2A = XRD/XRV - -!write(*,*) "ZFOES ",ZFOES -!write(*,*) "PPS ",PPS -!write(*,*) "ZWORK1 ",ZWORK1 -!write(*,*) "XRD ",XRD -!write(*,*) "XRV ",XRV -!write(*,*) "PPA ",PPA -!write(*,*) "ZWORK1A ",ZWORK1A - -write(*,*) "PQSAT : ",PQSAT -write(*,*) "PQSATA : ",PQSATA - - -! -!* 2. COMPUTE SATURATION HUMIDITY -! --------------------------- -! -!PQSAT = ZWORK2*ZWORK1 / (1.+(ZWORK2-1.)*ZWORK1) -!ZQSATA = ZWORK2A*ZWORK1A / (1.+(ZWORK2A-1.)*ZWORK1A) -ZQSATA = QSAT_SEAWATER (knon, klon, PTA(:),PPA(:)) !at sea surface - - -! -! 2.2. Gradients at the air-sea interface -! -ZDU(:) = ZVMOD(:) !one assumes u is measured / sea surface current -ZDT(:) = PTA(:)/PEXNA(:)-PSST(:)/PEXNS(:) -ZDQ(:) = PQA(:)-PQSATA(:) - -write(*,*) "PQA ",PQA(:) -write(*,*) "PQSAT",PQSAT(:) -write(*,*) "ZDQ",ZDQ(:) -! -! 2.3. Latent heat of vaporisation -! -ZLVA(:) = XLVTT+(XCPV-XCL)*(PTA (:)-XTT) !of pure water at atm level -ZLVS(:) = XLVTT+(XCPV-XCL)*(PSST(:)-XTT) !of pure water at sea surface - - - -write(*,*) "ZLVA ",ZLVA -write(*,*) "ZLVS ",ZLVS - - -WHERE(PSSS(:)>0.0.AND.PSSS(:)/=XUNDEF) - ZLVS(:) = ZLVS(:)*(1.0-1.00472E-3*PSSS(:)) !of seawater at sea surface -ENDWHERE -! -! 2.4. Specific heat of moist air (Businger 1982) -! -!ZCPA(:) = XCPD*(1.0+(XCPV/XCPD-1.0)*PQA(:)) -ZCPA(:) = XCPD -! -! 2.4b Kinematic viscosity of dry air (Andreas 1989, CRREL Rep. 89-11) -! -ZVISA(:) = 1.326E-05*(1.0+6.542E-03*(PTA(:)-XTT)+8.301E-06*(PTA(:)-XTT)**2 & - -4.84E-09*(PTA(:)-XTT)**3) -! -! 2.4c Coefficients for warm layer and/or cool skin correction -! -! 2.5. Initial guess -! -ZDDU(:) = ZDU(:) -ZDDT(:) = ZDT(:) -ZDDQ(:) = ZDQ(:) -ZDDU(:) = SIGN(MAX(ABS(ZDDU(:)),10.0*ZDUSR0),ZDDU(:)) -ZDDT(:) = SIGN(MAX(ABS(ZDDT(:)),10.0*ZDTSR0),ZDDT(:)) -ZDDQ(:) = SIGN(MAX(ABS(ZDDQ(:)),10.0*ZDQSR0),ZDDQ(:)) - -write(*,*) "ZDDU ",ZDDU -write(*,*) "ZDDQ ",ZDDQ -write(*,*) "ZDDT ",ZDDT - -! -JCV (:) = -1 -ZUSR(:) = 0.04*ZDDU(:) -ZTSR(:) = 0.04*ZDDT(:) -ZQSR(:) = 0.04*ZDDQ(:) -ZDELTAU10N(:) = ZDDU(:) -ZDELTAT10N(:) = ZDDT(:) -ZDELTAQ10N(:) = ZDDQ(:) -JITER(:) = 99 -! -! In the following, we suppose that Richardson number PRI < XRIMAX -! If not true, Monin-Obukhov theory can't (and therefore shouldn't) be applied ! -!------------------------------------------------------------------------------- -! -! 3. ITERATIVE LOOP TO COMPUTE U*, T*, Q*. -! ------------------------------------------ -! -DO JJ=1,NITERFL - DO JLON=1,SIZE(PTA) -! - IF (JCV(JLON) == -1) THEN - ZUSR0(JLON)=ZUSR(JLON) - ZTSR0(JLON)=ZTSR(JLON) - ZQSR0(JLON)=ZQSR(JLON) - IF (JJ == NITERMAX+1 .OR. JJ == NITERMAX+NITERSUP) THEN - ZDELTAU10N(JLON) = 0.5*(ZDUSTO(JLON)+ZDELTAU10N(JLON)) !forced convergence - ZDELTAT10N(JLON) = 0.5*(ZDTSTO(JLON)+ZDELTAT10N(JLON)) - ZDELTAQ10N(JLON) = 0.5*(ZDQSTO(JLON)+ZDELTAQ10N(JLON)) - IF (JJ == NITERMAX+NITERSUP) JCV(JLON)=3 - ENDIF - ZDUSTO(JLON) = ZDELTAU10N(JLON) - ZDTSTO(JLON) = ZDELTAT10N(JLON) - ZDQSTO(JLON) = ZDELTAQ10N(JLON) -! -! 3.1. Neutral parameter for wind speed (ECUME_V6 formulation) -! - IF (ZDELTAU10N(JLON) <= ZUTU) THEN - ZPARUN(JLON) = ZCOEFU(0) + ZCOEFU(1)*ZDELTAU10N(JLON) & - + ZCOEFU(2)*ZDELTAU10N(JLON)**2 & - + ZCOEFU(3)*ZDELTAU10N(JLON)**3 & - + ZCOEFU(4)*ZDELTAU10N(JLON)**4 & - + ZCOEFU(5)*ZDELTAU10N(JLON)**5 - ELSE - ZPARUN(JLON) = ZCDIRU*(ZDELTAU10N(JLON)-ZUTU) + ZORDOU - ENDIF - PCDN(JLON) = (ZPARUN(JLON)/ZDELTAU10N(JLON))**2 -! -! 3.2. Neutral parameter for temperature (ECUME_V6 formulation) -! - IF (ZDELTAU10N(JLON) <= ZUTT) THEN - ZPARTN(JLON) = ZCOEFT(0) + ZCOEFT(1)*ZDELTAU10N(JLON) & - + ZCOEFT(2)*ZDELTAU10N(JLON)**2 & - + ZCOEFT(3)*ZDELTAU10N(JLON)**3 & - + ZCOEFT(4)*ZDELTAU10N(JLON)**4 - ELSE - ZPARTN(JLON) = ZCDIRT*(ZDELTAU10N(JLON)-ZUTT) + ZORDOT - ENDIF -! -! 3.3. Neutral parameter for humidity (ECUME_V6 formulation) -! - IF (ZDELTAU10N(JLON) <= ZUTQ) THEN - ZPARQN(JLON) = ZCOEFQ(0) + ZCOEFQ(1)*ZDELTAU10N(JLON) & - + ZCOEFQ(2)*ZDELTAU10N(JLON)**2 - ELSE - ZPARQN(JLON) = ZCDIRQ*(ZDELTAU10N(JLON)-ZUTQ) + ZORDOQ - ENDIF -! -! 3.4. Scaling parameters U*, T*, Q* -! - ZUSR(JLON) = ZPARUN(JLON) - ZTSR(JLON) = ZPARTN(JLON)*ZDELTAT10N(JLON)/ZDELTAU10N(JLON) - ZQSR(JLON) = ZPARQN(JLON)*ZDELTAQ10N(JLON)/ZDELTAU10N(JLON) -! -! 3.4b Gustiness factor (Deardorff 1970) -! -! 3.4c Cool skin correction -! -! 3.5. Obukhovs stability param. z/l following Liu et al. (JAS, 1979) -! -! For U - ZLMOU = PUREF(JLON)*XG*XKARMAN*(ZTSR(JLON)/PTA(JLON) & - +ZETV*ZQSR(JLON)/(1.0+ZETV*PQA(JLON)))/ZUSR(JLON)**2 -! For T/Q - ZLMOT = ZLMOU*(PZREF(JLON)/PUREF(JLON)) - ZLMOU = MAX(MIN(ZLMOU,ZLMOMAX),ZLMOMIN) - ZLMOT = MAX(MIN(ZLMOT,ZLMOMAX),ZLMOMIN) -! -! 3.6. Stability function psi (see Liu et al, 1979 ; Dyer and Hicks, 1970) -! Modified to include convective form following Fairall (unpublished) -! -! For U - IF (ZLMOU == 0.0) THEN - ZPSI_U = 0.0 - ELSEIF (ZLMOU > 0.0) THEN - ZPSI_U = -ZGMA*ZLMOU - ELSE - ZCHIK = (1.0-ZBTA*ZLMOU)**0.25 - ZPSIK = 2.0*LOG((1.0+ZCHIK)/2.0) & - +LOG((1.0+ZCHIK**2)/2.0) & - -2.0*ATAN(ZCHIK)+0.5*XPI - ZCHIC = (1.0-12.87*ZLMOU)**(1.0/3.0) !for very unstable conditions - ZPSIC = 1.5*LOG((ZCHIC**2+ZCHIC+1.0)/3.0) & - -ZSQR3*ATAN((2.0*ZCHIC+1.0)/ZSQR3) & - +XPI/ZSQR3 - ZPSI_U = ZPSIC+(ZPSIK-ZPSIC)/(1.0+ZLMOU**2) !match Kansas & free-conv. forms - ENDIF - ZPSIU(JLON) = ZPSI_U -! For T/Q - IF (ZLMOT == 0.0) THEN - ZPSI_T = 0.0 - ELSEIF (ZLMOT > 0.0) THEN - ZPSI_T = -ZGMA*ZLMOT - ELSE - ZCHIK = (1.0-ZBTA*ZLMOT)**0.25 - ZPSIK = 2.0*LOG((1.0+ZCHIK**2)/2.0) - ZCHIC = (1.0-12.87*ZLMOT)**(1.0/3.0) !for very unstable conditions - ZPSIC = 1.5*LOG((ZCHIC**2+ZCHIC+1.0)/3.0) & - -ZSQR3*ATAN((2.0*ZCHIC+1.0)/ZSQR3) & - +XPI/ZSQR3 - ZPSI_T = ZPSIC+(ZPSIK-ZPSIC)/(1.0+ZLMOT**2) !match Kansas & free-conv. forms - ENDIF - ZPSIT(JLON) = ZPSI_T -! -! 3.7. Update air-sea gradients -! - ZDDU(JLON) = ZDU(JLON) - ZDDT(JLON) = ZDT(JLON) - ZDDQ(JLON) = ZDQ(JLON) - ZDDU(JLON) = SIGN(MAX(ABS(ZDDU(JLON)),10.0*ZDUSR0),ZDDU(JLON)) - ZDDT(JLON) = SIGN(MAX(ABS(ZDDT(JLON)),10.0*ZDTSR0),ZDDT(JLON)) - ZDDQ(JLON) = SIGN(MAX(ABS(ZDDQ(JLON)),10.0*ZDQSR0),ZDDQ(JLON)) - ZLOGUS10 = LOG(PUREF(JLON)/10.0) - ZLOGTS10 = LOG(PZREF(JLON)/10.0) - ZDELTAU10N(JLON) = ZDDU(JLON)-ZUSR(JLON)*(ZLOGUS10-ZPSI_U)/XKARMAN - ZDELTAT10N(JLON) = ZDDT(JLON)-ZTSR(JLON)*(ZLOGTS10-ZPSI_T)/XKARMAN - ZDELTAQ10N(JLON) = ZDDQ(JLON)-ZQSR(JLON)*(ZLOGTS10-ZPSI_T)/XKARMAN - ZDELTAU10N(JLON) = SIGN(MAX(ABS(ZDELTAU10N(JLON)),10.0*ZDUSR0), & - ZDELTAU10N(JLON)) - ZDELTAT10N(JLON) = SIGN(MAX(ABS(ZDELTAT10N(JLON)),10.0*ZDTSR0), & - ZDELTAT10N(JLON)) - ZDELTAQ10N(JLON) = SIGN(MAX(ABS(ZDELTAQ10N(JLON)),10.0*ZDQSR0), & - ZDELTAQ10N(JLON)) -! -! 3.8. Test convergence for U*, T*, Q* -! - IF (ABS(ZUSR(JLON)-ZUSR0(JLON)) < ZDUSR0 .AND. & - ABS(ZTSR(JLON)-ZTSR0(JLON)) < ZDTSR0 .AND. & - ABS(ZQSR(JLON)-ZQSR0(JLON)) < ZDQSR0) THEN - JCV(JLON) = 1 !free convergence - IF (JJ >= NITERMAX+1) JCV(JLON) = 2 !leaded convergence - ENDIF - JITER(JLON) = JJ - ENDIF -! - ENDDO -ENDDO -! -!------------------------------------------------------------------------------- -! -! 4. COMPUTATION OF TURBULENT FLUXES AND EXCHANGE COEFFICIENTS. -! --------------------------------------------------------------- -! -DO JLON=1,SIZE(PTA) -! -! 4.1. Surface turbulent fluxes -! (ATM CONV.: ZTAU<<0 ; ZHF,ZEF<0 if atm looses heat) -! - ZTAU(JLON) = -PRHOA(JLON)*ZUSR(JLON)**2 - ZHF(JLON) = -PRHOA(JLON)*ZCPA(JLON)*ZUSR(JLON)*ZTSR(JLON) - ZEF(JLON) = -PRHOA(JLON)*ZLVS(JLON)*ZUSR(JLON)*ZQSR(JLON) - - write(*,*) "ZTAU = ",ZTAU(JLON) - write(*,*) "SENS = ",ZHF(JLON) - write(*,*) "LAT = ",ZEF(JLON) - -! -! 4.2. Exchange coefficients PCD, PCH, PCE -! - PCD(JLON) = (ZUSR(JLON)/ZDDU(JLON))**2 - PCH(JLON) = (ZUSR(JLON)*ZTSR(JLON))/(ZDDU(JLON)*ZDDT(JLON)) - PCE(JLON) = (ZUSR(JLON)*ZQSR(JLON))/(ZDDU(JLON)*ZDDQ(JLON)) - - write(*,*) "ZUSR = ",ZUSR(JLON) - write(*,*) "ZTSR = ",ZTSR(JLON) - write(*,*) "ZQSR = ",ZQSR(JLON) - -! -! 4.3. Stochastic perturbation of turbulent fluxes -! -! IF( OPERTFLUX )THEN -! ZTAU(JLON) = ZTAU(JLON)* ( 1. + PPERTFLUX(JLON) / 2. ) -! ZHF (JLON) = ZHF(JLON)* ( 1. + PPERTFLUX(JLON) / 2. ) -! ZEF (JLON) = ZEF(JLON)* ( 1. + PPERTFLUX(JLON) / 2. ) -! ENDIF -! -ENDDO -! -!------------------------------------------------------------------------------- -! -! 5. COMPUTATION OF FLUX CORRECTIONS DUE TO RAINFALL. -! (ATM conv: ZRF<0 if atm. looses heat, ZTAUR<<0) -! ----------------------------------------------------- -! -IF (OPRECIP) THEN - DO JLON=1,SIZE(PTA) -! -! 5.1. Momentum flux due to rainfall (ZTAUR, N/m2) -! -! See pp3752 in FBR96. - ZTAUR(JLON) = -0.85*PRAIN(JLON)*PVMOD(JLON) -! -! 5.2. Sensible heat flux due to rainfall (ZRF, W/m2) -! -! See Eq.12 in GoF95 with ZCPWA as specific heat of water at atm level (J/kg/K), -! ZDQSDT from Clausius-Clapeyron relation, ZDWAT as water vapor diffusivity -! (Eq.13-3 of Pruppacher and Klett, 1978), ZDTMP as heat diffusivity, and ZBULB -! as wet-bulb factor (Eq.11 in GoF95). -! - ZTAC = PTA(JLON)-XTT - ZCPWA = 4217.51 -3.65566*ZTAC +0.1381*ZTAC**2 & - -2.8309E-03*ZTAC**3 +3.42061E-05*ZTAC**4 & - -2.18107E-07*ZTAC**5 +5.74535E-10*ZTAC**6 - ZDQSDT = (ZLVA(JLON)*ZQSATA(JLON))/(XRV*PTA(JLON)**2) - ZDWAT = 2.11E-05*(ZP00/PPA(JLON))*(PTA(JLON)/XTT)**1.94 - ZDTMP = (1.0+3.309E-03*ZTAC-1.44E-06*ZTAC**2) & - *0.02411/(PRHOA(JLON)*ZCPA(JLON)) - ZBULB = 1.0/(1.0+ZDQSDT*(ZLVA(JLON)*ZDWAT)/(ZCPA(JLON)*ZDTMP)) - ZRF(JLON) = PRAIN(JLON)*ZCPWA*ZBULB*((PSST(JLON)-PTA(JLON)) & - +(PQSATA(JLON)-PQA(JLON))*(ZLVA(JLON)*ZDWAT)/(ZCPA(JLON)*ZDTMP)) -! - ENDDO -ENDIF -! -!------------------------------------------------------------------------------- -! -! 6. COMPUTATION OF WEBB CORRECTION TO LATENT HEAT FLUX (ZEFWEBB, W/m2). -! ------------------------------------------------------------------------ -! -! See Eq.21 and Eq.22 in FBR96. -IF (OPWEBB) THEN - DO JLON=1,SIZE(PTA) - ZWW = (1.0+ZETV)*(ZUSR(JLON)*ZQSR(JLON)) & - +(1.0+(1.0+ZETV)*PQA(JLON))*(ZUSR(JLON)*ZTSR(JLON))/PTA(JLON) - ZEFWEBB(JLON) = -PRHOA(JLON)*ZLVS(JLON)*ZWW*PQA(JLON) - ENDDO -ENDIF -! -!------------------------------------------------------------------------------- -! -! 7. FINAL STEP : TOTAL SURFACE FLUXES AND DERIVED DIAGNOSTICS. -! --------------------------------------------------------------- -! -! 7.1. Richardson number -! -! CALL SURFACE_RI(PSST,PQSAT,PEXNS,PEXNA,PTA,PQA, & -! PZREF,PUREF,ZDIRCOSZW,PVMOD,PRI) -! -! 7.2. Friction velocity which contains correction due to rain -! -ZUSTAR2(:) = -(ZTAU(:)+ZTAUR(:))/PRHOA(:) !>>0 as ZTAU<<0 & ZTAUR<=0 -! -IF (OPRECIP) THEN - PCD(:) = ZUSTAR2(:)/ZDDU(:)**2 -ENDIF -! -PUSTAR(:) = SQRT(ZUSTAR2(:)) !>>0 -! -! 7.3. Aerodynamical conductance and resistance -! -ZAC (:) = PCH(:)*ZDDU(:) -PRESA(:) = 1.0/ZAC(:) -! -! 7.4. Total surface fluxes -! -PSFTH(:) = ZHF(:)+ZRF(:) -PSFTQ(:) = (ZEF(:)+ZEFWEBB(:))/ZLVS(:) -! -! 7.5. Charnock number -! -IF (CCHARNOCK == 'OLD') THEN - ZCHARN(:) = XVCHRNK -ELSE !modified for moderate wind speed as in COARE3.0 - ZCHARN(:) = MIN(0.018,MAX(0.011,0.011+(0.007/8.0)*(ZDDU(:)-10.0))) -ENDIF -! -! 7.6. Roughness lengths Z0 and Z0H over sea -! -!IF (KZ0 == 0) THEN ! ARPEGE formulation -! PZ0SEA (:) = (ZCHARN(:)/XG)*ZUSTAR2(:) + XVZ0CM*PCD(:)/PCDN(:) -! PZ0HSEA(:) = PZ0SEA (:) -!ELSEIF (KZ0 == 1) THEN ! Smith (1988) formulation -! PZ0SEA (:) = (ZCHARN(:)/XG)*ZUSTAR2(:) + 0.11*ZVISA(:)/PUSTAR(:) -! PZ0HSEA(:) = PZ0SEA (:) -!ELSEIF (KZ0 == 2) THEN ! Direct computation using the stability functions -! DO JLON=1,SIZE(PTA) -! PZ0SEA (JLON) = PUREF(JLON)/EXP(XKARMAN*ZDDU(JLON)/PUSTAR(JLON)+ZPSIU(JLON)) -! Z0TSEA = PZREF(JLON)/EXP(XKARMAN*ZDDT(JLON)/ZTSR (JLON)+ZPSIT(JLON)) -! Z0QSEA = PZREF(JLON)/EXP(XKARMAN*ZDDQ(JLON)/ZQSR (JLON)+ZPSIT(JLON)) -! PZ0HSEA(JLON) = 0.5*(Z0TSEA+Z0QSEA) -! ENDDO -!ENDIF - -write(*,*) "JLON ",JLON -write(*,*) "PTA ",klon,PTA -write(*,*) "PCD ",SIZE(PCD),PCD -write(*,*) "PCQ ",SIZE(PCE),PCE -write(*,*) "PCH ",SIZE(PCH),PCH - -coeffs = [PCD,& - PCE,& - PCH] -! -! -!IF (LHOOK) CALL DR_HOOK('ECUMEV6_FLUX',1,ZHOOK_HANDLE) -! -!------------------------------------------------------------------------------- - END SUBROUTINE ecumev6_flux - -END MODULE ecumev6_flux_mod Index: LMDZ6/trunk/libf/phylmd/ecumev6_flux_mod.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ecumev6_flux_mod.f90 (revision 6048) +++ LMDZ6/trunk/libf/phylmd/ecumev6_flux_mod.f90 (revision 6048) @@ -0,0 +1,782 @@ +MODULE ecumev6_flux_mod + +CONTAINS +!SFX_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier +!SFX_LIC This is part of the SURFEX software governed by the CeCILL-C licence +!SFX_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt +!SFX_LIC for details. version 1. +! ######### + SUBROUTINE ecumev6_flux(knon, klon, PZ0SEA,PTA,PSST,PQA,PQSAT,PVMOD, & + PZREF,PSSS,PUREF,PPS,PPA,OPRECIP,OPWEBB, & + PSFTH,PSFTQ,PUSTAR,PCD,PCDN,PCH,PCE, & + PRI,PRESA,PRAIN,PZ0HSEA,OPERTFLUX,coeffs ) +!$gpum horizontal knon +!############################################################################### +!! +!!**** *ECUMEV6_FLUX* +!! +!! PURPOSE +!! ------- +! Calculate the surface turbulent fluxes of heat, moisture, and momentum +! over sea surface + corrections due to rainfall & Webb effect. +!! +!!** METHOD +!! ------ +! The estimation of the transfer coefficients relies on the iterative +! computation of the scaling parameters U*/Teta*/q*. The convergence is +! supposed to be reached in NITERFL iterations maximum. +! Neutral transfer coefficients for momentum/temperature/humidity +! are computed as a function of the 10m-height neutral wind speed using +! the ECUME_V6 formulation based on the multi-campaign (POMME,FETCH,CATCH, +! SEMAPHORE,EQUALANT) ALBATROS dataset. +!! +!! EXTERNAL +!! -------- +!! +!! IMPLICIT ARGUMENTS +!! ------------------ +!! +!! REFERENCE +!! --------- +!! Fairall et al (1996), JGR, 3747-3764 +!! Gosnell et al (1995), JGR, 437-442 +!! Fairall et al (1996), JGR, 1295-1308 +!! +!! AUTHOR +!! ------ +!! C. Lebeaupin *Météo-France* (adapted from S. Belamari's code) +!! +!! MODIFICATIONS +!! ------------- +!! Original 15/03/2005 +!! Modified 01/2006 C. Lebeaupin (adapted from A. Pirani's code) +!! Modified 08/2009 B. Decharme: limitation of Ri +!! Modified 09/2012 B. Decharme: CD correction +!! Modified 09/2012 B. Decharme: limitation of Ri in surface_ri.F90 +!! Modified 10/2012 P. Le Moigne: extra inputs for FLake use +!! Modified 06/2013 B. Decharme: bug in z0 (output) computation +!! Modified 12/2013 S. Belamari: ZRF computation updated: +!! 1. ZP00/PPA in ZDWAT, ZLVA in ZDQSDT/ZBULB/ZRF +!! 2. ZDWAT/ZDTMP in ZBULB/ZRF (Gosnell et al 95) +!! 3. cool skin correction included +!! Modified 01/2014 S. Belamari: salinity impact on latent heat of +!! vaporization of seawater included +!! Modified 01/2014 S. Belamari: new formulation for pure water +!! specific heat (ZCPWA) +!! Modified 01/2014 S. Belamari: 4 choices for PZ0SEA computation +!! Modified 12/2015 S. Belamari: ECUME now provides parameterisations +!! for: U10n*sqrt(CDN) instead of CDN +!! U10n*CHN/sqrt(CDN) " CHN +!! U10n*CEN/sqrt(CDN) " CEN +!! Modified 01/2016 S. Belamari: New ECUME formulation +!! +!! To be done: +!! include gustiness computation following Mondon & Redelsperger (1998) +!!! +!------------------------------------------------------------------------------- +!! +!! MODIFICATIONS RELATED TO SST CORRECTION COMPUTATION +!! --------------------------------------------------- +!! Modified 09/2013 S. Belamari: use 0.98 for the ocean emissivity +!! following up to date satellite measurements in +!! the 8-14 μm range (obtained values range from +!! 0.98 to 0.99). +!!! +!------------------------------------------------------------------------------- +! +! 0. DECLARATIONS +! ------------ +! +USE indice_sol_mod +USE MODD_CSTS, ONLY : XPI, XDAY, XKARMAN, XG, XP00, XSTEFAN, XRD, XRV, & + XCPD, XCPV, XCL, XTT, XLVTT + + +!USE MODD_SURF_PAR, ONLY : XUNDEF +!USE MODD_SURF_ATM, ONLY : XVCHRNK, XVZ0CM +!USE MODD_REPROD_OPER, ONLY : CCHARNOCK +! +!USE MODE_THERMOS +!USE MODI_WIND_THRESHOLD +!USE MODI_SURFACE_RI +! +!USE YOMHOOK, ONLY : LHOOK, DR_HOOK +!USE PARKIND1, ONLY : JPRB +! +!USE MODI_ABOR1_SFX +USE yomcst_mod_h +USE clesphys_mod_h +USE qsat_seawater_mod, ONLY : qsat_seawater +USE qsat_seawater2_mod, ONLY : qsat_seawater2 +IMPLICIT NONE +! +! 0.1. Declarations of arguments +! +INTEGER, INTENT(IN) :: knon ! horizontal indice (compressed ? ) +INTEGER, INTENT(IN) :: klon ! horizontal indice (fake == 1?) +REAL, DIMENSION(klon), INTENT(IN) :: PVMOD ! module of wind at atm level (m/s) +REAL, DIMENSION(klon), INTENT(IN) :: PTA ! air temperature at atm level (K) +REAL, DIMENSION(klon), INTENT(IN) :: PQA ! air spec. hum. at atm level (kg/kg) +REAL, DIMENSION(klon), INTENT(IN) :: PQSAT ! sea surface spec. hum. (kg/kg) +REAL, DIMENSION(klon), INTENT(IN) :: PPA ! air pressure at atm level (Pa) +!REAL, DIMENSION(:), INTENT(IN) :: PRHOA ! air density at atm level (kg/m3) +!REAL, DIMENSION(:), INTENT(IN) :: PEXNA ! Exner function at atm level +REAL, DIMENSION(klon), INTENT(IN) :: PUREF ! atm level for wind (m) +REAL, DIMENSION(klon), INTENT(IN) :: PZREF ! atm level for temp./hum. (m) +REAL, DIMENSION(klon), INTENT(IN) :: PSSS ! Sea Surface Salinity (g/kg) +REAL, DIMENSION(klon), INTENT(IN) :: PPS ! air pressure at sea surface (Pa) +!REAL, DIMENSION(:), INTENT(IN) :: PEXNS ! Exner function at sea surface +!REAL, DIMENSION(:), INTENT(IN) :: PPERTFLUX ! stochastic flux perturbation pattern +! for correction +!REAL, INTENT(IN) :: PICHCE ! +LOGICAL, INTENT(IN) :: OPRECIP ! +LOGICAL, INTENT(IN) :: OPWEBB ! +LOGICAL, INTENT(IN) :: OPERTFLUX +REAL, DIMENSION(klon), INTENT(IN) :: PRAIN ! precipitation rate (kg/s/m2) +! +!INTEGER, INTENT(IN) :: KZ0 +! +REAL, DIMENSION(klon), INTENT(INOUT) :: PSST ! Sea Surface Temperature (K) +REAL, DIMENSION(klon), INTENT(INOUT) :: PZ0SEA ! roughness length over sea +REAL, DIMENSION(klon), INTENT(OUT) :: PZ0HSEA ! heat roughness length over sea + +! surface fluxes : latent heat, sensible heat, friction fluxes +REAL, DIMENSION(klon), INTENT(OUT) :: PUSTAR ! friction velocity (m/s) +REAL, DIMENSION(klon), INTENT(OUT) :: PSFTH ! heat flux (W/m2) +REAL, DIMENSION(klon), INTENT(OUT) :: PSFTQ ! water flux (kg/m2/s) + +! diagnostics +REAL, DIMENSION(klon), INTENT(OUT) :: PCD ! transfer coef. for momentum +REAL, DIMENSION(klon), INTENT(OUT) :: PCH ! transfer coef. for temperature +REAL, DIMENSION(klon), INTENT(OUT) :: PCE ! transfer coef. for humidity +REAL, DIMENSION(klon), INTENT(OUT) :: PCDN ! neutral coef. for momentum +REAL, DIMENSION(klon), INTENT(OUT) :: PRI ! Richardson number +REAL, DIMENSION(klon), INTENT(OUT) :: PRESA ! aerodynamical resistance +real, dimension(3), intent(out) :: coeffs + +! 0.2. Declarations of local variables +! +! specif SB +INTEGER, DIMENSION(klon) :: JCV ! convergence index +INTEGER, DIMENSION(klon) :: JITER ! nb of iterations to converge +!rajout +REAL, DIMENSION(klon) :: PEXNA ! Exner function at atm level +REAL, DIMENSION(klon) :: PEXNS ! Exner function at atm level +! +REAL, DIMENSION(klon) :: ZTAU ! momentum flux (N/m2) +REAL, DIMENSION(klon) :: ZHF ! sensible heat flux (W/m2) +REAL, DIMENSION(klon) :: ZEF ! latent heat flux (W/m2) +REAL, DIMENSION(klon) :: ZTAUR ! momentum flx due to rain (N/m2) +REAL, DIMENSION(klon) :: ZRF ! sensible flx due to rain (W/m2) +REAL, DIMENSION(klon) :: ZEFWEBB ! Webb corr. on latent flx (W/m2) + +REAL, DIMENSION(klon) :: ZVMOD ! wind intensity at atm level (m/s) +REAL, DIMENSION(klon) :: ZQSATA ! sat.spec.hum. at atm level (kg/kg) +REAL, DIMENSION(klon) :: ZLVA ! vap.heat of pure water at atm level (J/kg) +REAL, DIMENSION(klon) :: ZLVS ! vap.heat of seawater at sea surface (J/kg) +REAL, DIMENSION(klon) :: ZCPA ! specif.heat moist air (J/kg/K) +REAL, DIMENSION(klon) :: ZVISA ! kinemat.visc. of dry air (m2/s) +REAL, DIMENSION(klon) :: ZDU ! U vert.grad. (real atm) +REAL, DIMENSION(klon) :: ZDT,ZDQ ! T,Q vert.grad. (real atm) +REAL, DIMENSION(klon) :: ZDDU ! U vert.grad. (real atm + gust) +REAL, DIMENSION(klon) :: ZDDT,ZDDQ ! T,Q vert.grad. (real atm + WL/CS) +REAL, DIMENSION(klon) :: ZUSR ! velocity scaling param. (m/s) + ! =friction velocity +REAL, DIMENSION(klon) :: ZTSR ! temperature scaling param. (K) +REAL, DIMENSION(klon) :: ZQSR ! humidity scaling param. (kg/kg) +REAL, DIMENSION(klon) :: ZDELTAU10N,ZDELTAT10N,ZDELTAQ10N + ! U,T,Q vert.grad. (10m, neutral atm) +REAL, DIMENSION(klon) :: ZUSR0,ZTSR0,ZQSR0 ! ITERATIVE PROCESS +REAL, DIMENSION(klon) :: ZDUSTO,ZDTSTO,ZDQSTO ! ITERATIVE PROCESS +REAL, DIMENSION(klon) :: ZPSIU,ZPSIT! PSI funct for U, T/Q (Z0 comp) +REAL, DIMENSION(klon) :: ZCHARN ! Charnock parameter (Z0 comp) + +REAL, DIMENSION(klon) :: ZUSTAR2 ! square of friction velocity +REAL, DIMENSION(klon) :: ZAC ! aerodynamical conductance +REAL, DIMENSION(klon) :: ZDIRCOSZW ! orography slope cosine + ! (=1 on water!) +REAL, DIMENSION(klon) :: ZPARUN,ZPARTN,ZPARQN ! neutral parameter for U,T,Q + +!-- rajout pour la pression saturante +REAL, DIMENSION(klon) :: ZFOES ! [OPWEBB] +REAL, DIMENSION(klon) :: ZWORK1 +REAL, DIMENSION(klon) :: ZWORK2 +REAL, DIMENSION(klon) :: ZWORK1A +REAL, DIMENSION(klon) :: ZWORK2A +!##################### + +REAL, DIMENSION(0:5) :: ZCOEFU,ZCOEFT,ZCOEFQ + +!--------- Modif Olive ----------------- +REAL, DIMENSION(klon) :: PRHOA +REAL, PARAMETER :: XUNDEF = 1.E+20 + + +REAL :: XVCHRNK = 0.021 +REAL :: XVZ0CM = 1.0E-5 +!REAL :: XRIMAX + +CHARACTER :: CCHARNOCK = 'NEW' + + +!-------------------------------------- + + +! local constants +LOGICAL :: OPCVFLX ! to force convergence +INTEGER :: NITERMAX ! nb of iterations to get free convergence +INTEGER :: NITERSUP ! nb of additional iterations if OPCVFLX=.TRUE. +INTEGER :: NITERFL ! maximum number of iterations +REAL :: ZETV,ZRDSRV ! thermodynamic constants +REAL :: ZSQR3 +REAL :: ZLMOMIN,ZLMOMAX ! min/max value of Obukhovs stability param. z/l +REAL :: ZBTA,ZGMA ! parameters of the stability functions +REAL :: ZDUSR0,ZDTSR0,ZDQSR0 ! maximum gap for USR/TSR/QSR between 2 steps +REAL :: ZP00 ! [OPRECIP] - water vap. diffusiv.ref.press.(Pa) +REAL :: ZUTU,ZUTT,ZUTQ ! U10n threshold in ECUME parameterisation +REAL :: ZCDIRU,ZCDIRT,ZCDIRQ ! coef directeur pour fonction affine U,T,Q +REAL :: ZORDOU,ZORDOT,ZORDOQ ! ordonnee a l'origine pour fonction affine U,T,Q + +INTEGER :: JJ ! for ITERATIVE PROCESS +INTEGER :: JLON,JK +REAL :: ZLMOU,ZLMOT ! Obukhovs param. z/l for U, T/Q +REAL :: ZPSI_U,ZPSI_T ! PSI funct. for U, T/Q +REAL :: Z0TSEA,Z0QSEA ! roughness length for T, Q +REAL :: ZCHIC,ZCHIK,ZPSIC,ZPSIK,ZLOGUS10,ZLOGTS10 +REAL :: ZTAC,ZCPWA,ZDQSDT,ZDWAT,ZDTMP,ZBULB ! [OPRECIP] +REAL :: ZWW ! [OPWEBB] + + +INTEGER :: PREF ! reference pressure for exner function +REAL, DIMENSION(klon) :: PQSATA ! sea surface spec. hum. (kg/kg) + +!REAL(KIND=JPRB) :: ZHOOK_HANDLE +! +!------------------------------------------------------------------------------- +!----------------------- Modif Olive calcul de PRHOA --------------------------- + +!write(*,*) "PZ0SEA ",PZ0SEA +!write(*,*) "PTA ",PTA +!write(*,*) "PSST ",PSST +!write(*,*) "PQA ",PQA +!write(*,*) "PVMOD ",PVMOD +!write(*,*) "PZREF ",PZREF +!write(*,*) "PUREF ",PUREF +!write(*,*) "PPS ",PPS +!write(*,*) "PPA ",PPA +!write(*,*) "OPRECIP ",OPRECIP +!write(*,*) "PZ0HSEA ",PZ0HSEA +!write(*,*) "PRAIN ",PRAIN + + +PRHOA(:) = PPS(:) / (287.1 * PTA(:) * (1.+.61*PQA(:))) +!write(*,*) "klon klon ",klon,PTA +!write(*,*) "PRHOA ",SIZE(PRHOA),PRHOA + +PREF = 100900. ! = 1000 hPa + +!PEXNA = (PPA/PPS)**RKAPPA +!PEXNS = (PPS/PPS)**RKAPPA + +PEXNA = (PPA/PREF)**(RD/RCPD) +PEXNS = (PPS/PREF)**(RD/RCPD) + +!IF (LHOOK) CALL DR_HOOK('ECUMEV6_FLUX',0,ZHOOK_HANDLE) +! +ZDUSR0 = 1.E-06 +ZDTSR0 = 1.E-06 +ZDQSR0 = 1.E-09 +! +NITERMAX = 5 +NITERSUP = 5 +OPCVFLX = .TRUE. +! +NITERFL = NITERMAX +IF (OPCVFLX) NITERFL = NITERMAX+NITERSUP +! +ZCOEFU = (/ 1.00E-03, 3.66E-02, -1.92E-03, 2.32E-04, -7.02E-06, 6.40E-08 /) +ZCOEFT = (/ 5.36E-03, 2.90E-02, -1.24E-03, 4.50E-04, -2.06E-05, 0.0 /) +ZCOEFQ = (/ 1.00E-03, 3.59E-02, -2.87E-04, 0.0, 0.0, 0.0 /) +! +ZUTU = 40.0 +ZUTT = 14.4 +ZUTQ = 10.0 +! +ZCDIRU = ZCOEFU(1) + 2.0*ZCOEFU(2)*ZUTU + 3.0*ZCOEFU(3)*ZUTU**2 & + + 4.0*ZCOEFU(4)*ZUTU**3 + 5.0*ZCOEFU(5)*ZUTU**4 +ZCDIRT = ZCOEFT(1) + 2.0*ZCOEFT(2)*ZUTT + 3.0*ZCOEFT(3)*ZUTT**2 & + + 4.0*ZCOEFT(4)*ZUTT**3 +ZCDIRQ = ZCOEFQ(1) + 2.0*ZCOEFQ(2)*ZUTQ +! +ZORDOU = ZCOEFU(0) + ZCOEFU(1)*ZUTU + ZCOEFU(2)*ZUTU**2 + ZCOEFU(3)*ZUTU**3 & + + ZCOEFU(4)*ZUTU**4 + ZCOEFU(5)*ZUTU**5 +ZORDOT = ZCOEFT(0) + ZCOEFT(1)*ZUTT + ZCOEFT(2)*ZUTT**2 + ZCOEFT(3)*ZUTT**3 & + + ZCOEFT(4)*ZUTT**4 +ZORDOQ = ZCOEFQ(0) + ZCOEFQ(1)*ZUTQ + ZCOEFQ(2)*ZUTQ**2 +! +!------------------------------------------------------------------------------- +! +! 1. AUXILIARY CONSTANTS & ARRAY INITIALISATION BY UNDEFINED VALUES. +! -------------------------------------------------------------------- +! +ZDIRCOSZW(:) = 1.0 +! +ZETV = XRV/XRD-1.0 !~0.61 (cf Liu et al. 1979) +ZRDSRV = XRD/XRV !~0.622 +ZSQR3 = SQRT(3.0) +ZLMOMIN = -200.0 +ZLMOMAX = 0.25 +ZBTA = 16.0 +ZGMA = 7.0 !initially =4.7, modified to 7.0 following G. Caniaux +! +ZP00 = 1013.25E+02 +! +PCD = XUNDEF +PCH = XUNDEF +PCE = XUNDEF +PCDN = XUNDEF +ZUSR = XUNDEF +ZTSR = XUNDEF +ZQSR = XUNDEF +ZTAU = XUNDEF +ZHF = XUNDEF +ZEF = XUNDEF +! +PSFTH = XUNDEF +PSFTQ = XUNDEF +PUSTAR = XUNDEF +PRESA = XUNDEF +PRI = XUNDEF +! +ZTAUR = 0.0 +ZRF = 0.0 +ZEFWEBB = 0.0 +! +!------------------------------------------------------------------------------- +! +! 2. INITIALISATIONS BEFORE ITERATIVE LOOP. +! ------------------------------------------- +! +!ZVMOD(:) = WIND_THRESHOLD(PVMOD(:),PUREF(:)) !set a minimum value to wind +ZVMOD = MAX(PVMOD , 0.1 * MIN(10.,PUREF) ) !set a minimum value to wind + +write(*,*) "ZVMOD ",SIZE(ZVMOD) + +! +! 2.0. Radiative fluxes - For warm layer & cool skin +! +! 2.0b. Warm Layer correction +! +! 2.1. Specific humidity at saturation +! +WHERE(PSSS(:)>0.0.AND.PSSS(:)/=XUNDEF) + PQSATA = QSAT_SEAWATER2 (knon, klon, PSST(:),PPS(:),PSSS(:)) !at sea surface +ELSEWHERE + PQSATA (:) = QSAT_SEAWATER (knon, klon, PSST(:),PPS(:)) !at sea surface +ENDWHERE + +!ZQSATA(:) = QSAT(PTA(:),PPA(:)) !at atm level + +!### OLIVIER POUR PRESSION SATURANTE ##### +!------------------------------------------------------------------------------- +! +ZFOES = 1 !PSAT(PT(:)) +ZFOES = 0.98*ZFOES +! +ZWORK1 = ZFOES/PPS +ZWORK2 = XRD/XRV + +ZWORK1A = ZFOES/PPA +ZWORK2A = XRD/XRV + +!write(*,*) "ZFOES ",ZFOES +!write(*,*) "PPS ",PPS +!write(*,*) "ZWORK1 ",ZWORK1 +!write(*,*) "XRD ",XRD +!write(*,*) "XRV ",XRV +!write(*,*) "PPA ",PPA +!write(*,*) "ZWORK1A ",ZWORK1A + +write(*,*) "PQSAT : ",PQSAT +write(*,*) "PQSATA : ",PQSATA + + +! +!* 2. COMPUTE SATURATION HUMIDITY +! --------------------------- +! +!PQSAT = ZWORK2*ZWORK1 / (1.+(ZWORK2-1.)*ZWORK1) +!ZQSATA = ZWORK2A*ZWORK1A / (1.+(ZWORK2A-1.)*ZWORK1A) +ZQSATA = QSAT_SEAWATER (knon, klon, PTA(:),PPA(:)) !at sea surface + + +! +! 2.2. Gradients at the air-sea interface +! +ZDU(:) = ZVMOD(:) !one assumes u is measured / sea surface current +ZDT(:) = PTA(:)/PEXNA(:)-PSST(:)/PEXNS(:) +ZDQ(:) = PQA(:)-PQSATA(:) + +write(*,*) "PQA ",PQA(:) +write(*,*) "PQSAT",PQSAT(:) +write(*,*) "ZDQ",ZDQ(:) +! +! 2.3. Latent heat of vaporisation +! +ZLVA(:) = XLVTT+(XCPV-XCL)*(PTA (:)-XTT) !of pure water at atm level +ZLVS(:) = XLVTT+(XCPV-XCL)*(PSST(:)-XTT) !of pure water at sea surface + + + +write(*,*) "ZLVA ",ZLVA +write(*,*) "ZLVS ",ZLVS + + +WHERE(PSSS(:)>0.0.AND.PSSS(:)/=XUNDEF) + ZLVS(:) = ZLVS(:)*(1.0-1.00472E-3*PSSS(:)) !of seawater at sea surface +ENDWHERE +! +! 2.4. Specific heat of moist air (Businger 1982) +! +!ZCPA(:) = XCPD*(1.0+(XCPV/XCPD-1.0)*PQA(:)) +ZCPA(:) = XCPD +! +! 2.4b Kinematic viscosity of dry air (Andreas 1989, CRREL Rep. 89-11) +! +ZVISA(:) = 1.326E-05*(1.0+6.542E-03*(PTA(:)-XTT)+8.301E-06*(PTA(:)-XTT)**2 & + -4.84E-09*(PTA(:)-XTT)**3) +! +! 2.4c Coefficients for warm layer and/or cool skin correction +! +! 2.5. Initial guess +! +ZDDU(:) = ZDU(:) +ZDDT(:) = ZDT(:) +ZDDQ(:) = ZDQ(:) +ZDDU(:) = SIGN(MAX(ABS(ZDDU(:)),10.0*ZDUSR0),ZDDU(:)) +ZDDT(:) = SIGN(MAX(ABS(ZDDT(:)),10.0*ZDTSR0),ZDDT(:)) +ZDDQ(:) = SIGN(MAX(ABS(ZDDQ(:)),10.0*ZDQSR0),ZDDQ(:)) + +write(*,*) "ZDDU ",ZDDU +write(*,*) "ZDDQ ",ZDDQ +write(*,*) "ZDDT ",ZDDT + +! +JCV (:) = -1 +ZUSR(:) = 0.04*ZDDU(:) +ZTSR(:) = 0.04*ZDDT(:) +ZQSR(:) = 0.04*ZDDQ(:) +ZDELTAU10N(:) = ZDDU(:) +ZDELTAT10N(:) = ZDDT(:) +ZDELTAQ10N(:) = ZDDQ(:) +JITER(:) = 99 +! +! In the following, we suppose that Richardson number PRI < XRIMAX +! If not true, Monin-Obukhov theory can't (and therefore shouldn't) be applied ! +!------------------------------------------------------------------------------- +! +! 3. ITERATIVE LOOP TO COMPUTE U*, T*, Q*. +! ------------------------------------------ +! +DO JJ=1,NITERFL + DO JLON=1,SIZE(PTA) +! + IF (JCV(JLON) == -1) THEN + ZUSR0(JLON)=ZUSR(JLON) + ZTSR0(JLON)=ZTSR(JLON) + ZQSR0(JLON)=ZQSR(JLON) + IF (JJ == NITERMAX+1 .OR. JJ == NITERMAX+NITERSUP) THEN + ZDELTAU10N(JLON) = 0.5*(ZDUSTO(JLON)+ZDELTAU10N(JLON)) !forced convergence + ZDELTAT10N(JLON) = 0.5*(ZDTSTO(JLON)+ZDELTAT10N(JLON)) + ZDELTAQ10N(JLON) = 0.5*(ZDQSTO(JLON)+ZDELTAQ10N(JLON)) + IF (JJ == NITERMAX+NITERSUP) JCV(JLON)=3 + ENDIF + ZDUSTO(JLON) = ZDELTAU10N(JLON) + ZDTSTO(JLON) = ZDELTAT10N(JLON) + ZDQSTO(JLON) = ZDELTAQ10N(JLON) +! +! 3.1. Neutral parameter for wind speed (ECUME_V6 formulation) +! + IF (ZDELTAU10N(JLON) <= ZUTU) THEN + ZPARUN(JLON) = ZCOEFU(0) + ZCOEFU(1)*ZDELTAU10N(JLON) & + + ZCOEFU(2)*ZDELTAU10N(JLON)**2 & + + ZCOEFU(3)*ZDELTAU10N(JLON)**3 & + + ZCOEFU(4)*ZDELTAU10N(JLON)**4 & + + ZCOEFU(5)*ZDELTAU10N(JLON)**5 + ELSE + ZPARUN(JLON) = ZCDIRU*(ZDELTAU10N(JLON)-ZUTU) + ZORDOU + ENDIF + PCDN(JLON) = (ZPARUN(JLON)/ZDELTAU10N(JLON))**2 +! +! 3.2. Neutral parameter for temperature (ECUME_V6 formulation) +! + IF (ZDELTAU10N(JLON) <= ZUTT) THEN + ZPARTN(JLON) = ZCOEFT(0) + ZCOEFT(1)*ZDELTAU10N(JLON) & + + ZCOEFT(2)*ZDELTAU10N(JLON)**2 & + + ZCOEFT(3)*ZDELTAU10N(JLON)**3 & + + ZCOEFT(4)*ZDELTAU10N(JLON)**4 + ELSE + ZPARTN(JLON) = ZCDIRT*(ZDELTAU10N(JLON)-ZUTT) + ZORDOT + ENDIF +! +! 3.3. Neutral parameter for humidity (ECUME_V6 formulation) +! + IF (ZDELTAU10N(JLON) <= ZUTQ) THEN + ZPARQN(JLON) = ZCOEFQ(0) + ZCOEFQ(1)*ZDELTAU10N(JLON) & + + ZCOEFQ(2)*ZDELTAU10N(JLON)**2 + ELSE + ZPARQN(JLON) = ZCDIRQ*(ZDELTAU10N(JLON)-ZUTQ) + ZORDOQ + ENDIF +! +! 3.4. Scaling parameters U*, T*, Q* +! + ZUSR(JLON) = ZPARUN(JLON) + ZTSR(JLON) = ZPARTN(JLON)*ZDELTAT10N(JLON)/ZDELTAU10N(JLON) + ZQSR(JLON) = ZPARQN(JLON)*ZDELTAQ10N(JLON)/ZDELTAU10N(JLON) +! +! 3.4b Gustiness factor (Deardorff 1970) +! +! 3.4c Cool skin correction +! +! 3.5. Obukhovs stability param. z/l following Liu et al. (JAS, 1979) +! +! For U + ZLMOU = PUREF(JLON)*XG*XKARMAN*(ZTSR(JLON)/PTA(JLON) & + +ZETV*ZQSR(JLON)/(1.0+ZETV*PQA(JLON)))/ZUSR(JLON)**2 +! For T/Q + ZLMOT = ZLMOU*(PZREF(JLON)/PUREF(JLON)) + ZLMOU = MAX(MIN(ZLMOU,ZLMOMAX),ZLMOMIN) + ZLMOT = MAX(MIN(ZLMOT,ZLMOMAX),ZLMOMIN) +! +! 3.6. Stability function psi (see Liu et al, 1979 ; Dyer and Hicks, 1970) +! Modified to include convective form following Fairall (unpublished) +! +! For U + IF (ZLMOU == 0.0) THEN + ZPSI_U = 0.0 + ELSEIF (ZLMOU > 0.0) THEN + ZPSI_U = -ZGMA*ZLMOU + ELSE + ZCHIK = (1.0-ZBTA*ZLMOU)**0.25 + ZPSIK = 2.0*LOG((1.0+ZCHIK)/2.0) & + +LOG((1.0+ZCHIK**2)/2.0) & + -2.0*ATAN(ZCHIK)+0.5*XPI + ZCHIC = (1.0-12.87*ZLMOU)**(1.0/3.0) !for very unstable conditions + ZPSIC = 1.5*LOG((ZCHIC**2+ZCHIC+1.0)/3.0) & + -ZSQR3*ATAN((2.0*ZCHIC+1.0)/ZSQR3) & + +XPI/ZSQR3 + ZPSI_U = ZPSIC+(ZPSIK-ZPSIC)/(1.0+ZLMOU**2) !match Kansas & free-conv. forms + ENDIF + ZPSIU(JLON) = ZPSI_U +! For T/Q + IF (ZLMOT == 0.0) THEN + ZPSI_T = 0.0 + ELSEIF (ZLMOT > 0.0) THEN + ZPSI_T = -ZGMA*ZLMOT + ELSE + ZCHIK = (1.0-ZBTA*ZLMOT)**0.25 + ZPSIK = 2.0*LOG((1.0+ZCHIK**2)/2.0) + ZCHIC = (1.0-12.87*ZLMOT)**(1.0/3.0) !for very unstable conditions + ZPSIC = 1.5*LOG((ZCHIC**2+ZCHIC+1.0)/3.0) & + -ZSQR3*ATAN((2.0*ZCHIC+1.0)/ZSQR3) & + +XPI/ZSQR3 + ZPSI_T = ZPSIC+(ZPSIK-ZPSIC)/(1.0+ZLMOT**2) !match Kansas & free-conv. forms + ENDIF + ZPSIT(JLON) = ZPSI_T +! +! 3.7. Update air-sea gradients +! + ZDDU(JLON) = ZDU(JLON) + ZDDT(JLON) = ZDT(JLON) + ZDDQ(JLON) = ZDQ(JLON) + ZDDU(JLON) = SIGN(MAX(ABS(ZDDU(JLON)),10.0*ZDUSR0),ZDDU(JLON)) + ZDDT(JLON) = SIGN(MAX(ABS(ZDDT(JLON)),10.0*ZDTSR0),ZDDT(JLON)) + ZDDQ(JLON) = SIGN(MAX(ABS(ZDDQ(JLON)),10.0*ZDQSR0),ZDDQ(JLON)) + ZLOGUS10 = LOG(PUREF(JLON)/10.0) + ZLOGTS10 = LOG(PZREF(JLON)/10.0) + ZDELTAU10N(JLON) = ZDDU(JLON)-ZUSR(JLON)*(ZLOGUS10-ZPSI_U)/XKARMAN + ZDELTAT10N(JLON) = ZDDT(JLON)-ZTSR(JLON)*(ZLOGTS10-ZPSI_T)/XKARMAN + ZDELTAQ10N(JLON) = ZDDQ(JLON)-ZQSR(JLON)*(ZLOGTS10-ZPSI_T)/XKARMAN + ZDELTAU10N(JLON) = SIGN(MAX(ABS(ZDELTAU10N(JLON)),10.0*ZDUSR0), & + ZDELTAU10N(JLON)) + ZDELTAT10N(JLON) = SIGN(MAX(ABS(ZDELTAT10N(JLON)),10.0*ZDTSR0), & + ZDELTAT10N(JLON)) + ZDELTAQ10N(JLON) = SIGN(MAX(ABS(ZDELTAQ10N(JLON)),10.0*ZDQSR0), & + ZDELTAQ10N(JLON)) +! +! 3.8. Test convergence for U*, T*, Q* +! + IF (ABS(ZUSR(JLON)-ZUSR0(JLON)) < ZDUSR0 .AND. & + ABS(ZTSR(JLON)-ZTSR0(JLON)) < ZDTSR0 .AND. & + ABS(ZQSR(JLON)-ZQSR0(JLON)) < ZDQSR0) THEN + JCV(JLON) = 1 !free convergence + IF (JJ >= NITERMAX+1) JCV(JLON) = 2 !leaded convergence + ENDIF + JITER(JLON) = JJ + ENDIF +! + ENDDO +ENDDO +! +!------------------------------------------------------------------------------- +! +! 4. COMPUTATION OF TURBULENT FLUXES AND EXCHANGE COEFFICIENTS. +! --------------------------------------------------------------- +! +DO JLON=1,SIZE(PTA) +! +! 4.1. Surface turbulent fluxes +! (ATM CONV.: ZTAU<<0 ; ZHF,ZEF<0 if atm looses heat) +! + ZTAU(JLON) = -PRHOA(JLON)*ZUSR(JLON)**2 + ZHF(JLON) = -PRHOA(JLON)*ZCPA(JLON)*ZUSR(JLON)*ZTSR(JLON) + ZEF(JLON) = -PRHOA(JLON)*ZLVS(JLON)*ZUSR(JLON)*ZQSR(JLON) + + write(*,*) "ZTAU = ",ZTAU(JLON) + write(*,*) "SENS = ",ZHF(JLON) + write(*,*) "LAT = ",ZEF(JLON) + +! +! 4.2. Exchange coefficients PCD, PCH, PCE +! + PCD(JLON) = (ZUSR(JLON)/ZDDU(JLON))**2 + PCH(JLON) = (ZUSR(JLON)*ZTSR(JLON))/(ZDDU(JLON)*ZDDT(JLON)) + PCE(JLON) = (ZUSR(JLON)*ZQSR(JLON))/(ZDDU(JLON)*ZDDQ(JLON)) + + write(*,*) "ZUSR = ",ZUSR(JLON) + write(*,*) "ZTSR = ",ZTSR(JLON) + write(*,*) "ZQSR = ",ZQSR(JLON) + +! +! 4.3. Stochastic perturbation of turbulent fluxes +! +! IF( OPERTFLUX )THEN +! ZTAU(JLON) = ZTAU(JLON)* ( 1. + PPERTFLUX(JLON) / 2. ) +! ZHF (JLON) = ZHF(JLON)* ( 1. + PPERTFLUX(JLON) / 2. ) +! ZEF (JLON) = ZEF(JLON)* ( 1. + PPERTFLUX(JLON) / 2. ) +! ENDIF +! +ENDDO +! +!------------------------------------------------------------------------------- +! +! 5. COMPUTATION OF FLUX CORRECTIONS DUE TO RAINFALL. +! (ATM conv: ZRF<0 if atm. looses heat, ZTAUR<<0) +! ----------------------------------------------------- +! +IF (OPRECIP) THEN + DO JLON=1,SIZE(PTA) +! +! 5.1. Momentum flux due to rainfall (ZTAUR, N/m2) +! +! See pp3752 in FBR96. + ZTAUR(JLON) = -0.85*PRAIN(JLON)*PVMOD(JLON) +! +! 5.2. Sensible heat flux due to rainfall (ZRF, W/m2) +! +! See Eq.12 in GoF95 with ZCPWA as specific heat of water at atm level (J/kg/K), +! ZDQSDT from Clausius-Clapeyron relation, ZDWAT as water vapor diffusivity +! (Eq.13-3 of Pruppacher and Klett, 1978), ZDTMP as heat diffusivity, and ZBULB +! as wet-bulb factor (Eq.11 in GoF95). +! + ZTAC = PTA(JLON)-XTT + ZCPWA = 4217.51 -3.65566*ZTAC +0.1381*ZTAC**2 & + -2.8309E-03*ZTAC**3 +3.42061E-05*ZTAC**4 & + -2.18107E-07*ZTAC**5 +5.74535E-10*ZTAC**6 + ZDQSDT = (ZLVA(JLON)*ZQSATA(JLON))/(XRV*PTA(JLON)**2) + ZDWAT = 2.11E-05*(ZP00/PPA(JLON))*(PTA(JLON)/XTT)**1.94 + ZDTMP = (1.0+3.309E-03*ZTAC-1.44E-06*ZTAC**2) & + *0.02411/(PRHOA(JLON)*ZCPA(JLON)) + ZBULB = 1.0/(1.0+ZDQSDT*(ZLVA(JLON)*ZDWAT)/(ZCPA(JLON)*ZDTMP)) + ZRF(JLON) = PRAIN(JLON)*ZCPWA*ZBULB*((PSST(JLON)-PTA(JLON)) & + +(PQSATA(JLON)-PQA(JLON))*(ZLVA(JLON)*ZDWAT)/(ZCPA(JLON)*ZDTMP)) +! + ENDDO +ENDIF +! +!------------------------------------------------------------------------------- +! +! 6. COMPUTATION OF WEBB CORRECTION TO LATENT HEAT FLUX (ZEFWEBB, W/m2). +! ------------------------------------------------------------------------ +! +! See Eq.21 and Eq.22 in FBR96. +IF (OPWEBB) THEN + DO JLON=1,SIZE(PTA) + ZWW = (1.0+ZETV)*(ZUSR(JLON)*ZQSR(JLON)) & + +(1.0+(1.0+ZETV)*PQA(JLON))*(ZUSR(JLON)*ZTSR(JLON))/PTA(JLON) + ZEFWEBB(JLON) = -PRHOA(JLON)*ZLVS(JLON)*ZWW*PQA(JLON) + ENDDO +ENDIF +! +!------------------------------------------------------------------------------- +! +! 7. FINAL STEP : TOTAL SURFACE FLUXES AND DERIVED DIAGNOSTICS. +! --------------------------------------------------------------- +! +! 7.1. Richardson number +! +! CALL SURFACE_RI(PSST,PQSAT,PEXNS,PEXNA,PTA,PQA, & +! PZREF,PUREF,ZDIRCOSZW,PVMOD,PRI) +! +! 7.2. Friction velocity which contains correction due to rain +! +ZUSTAR2(:) = -(ZTAU(:)+ZTAUR(:))/PRHOA(:) !>>0 as ZTAU<<0 & ZTAUR<=0 +! +IF (OPRECIP) THEN + PCD(:) = ZUSTAR2(:)/ZDDU(:)**2 +ENDIF +! +PUSTAR(:) = SQRT(ZUSTAR2(:)) !>>0 +! +! 7.3. Aerodynamical conductance and resistance +! +ZAC (:) = PCH(:)*ZDDU(:) +PRESA(:) = 1.0/ZAC(:) +! +! 7.4. Total surface fluxes +! +PSFTH(:) = ZHF(:)+ZRF(:) +PSFTQ(:) = (ZEF(:)+ZEFWEBB(:))/ZLVS(:) +! +! 7.5. Charnock number +! +IF (CCHARNOCK == 'OLD') THEN + ZCHARN(:) = XVCHRNK +ELSE !modified for moderate wind speed as in COARE3.0 + ZCHARN(:) = MIN(0.018,MAX(0.011,0.011+(0.007/8.0)*(ZDDU(:)-10.0))) +ENDIF +! +! 7.6. Roughness lengths Z0 and Z0H over sea +! +!IF (KZ0 == 0) THEN ! ARPEGE formulation +! PZ0SEA (:) = (ZCHARN(:)/XG)*ZUSTAR2(:) + XVZ0CM*PCD(:)/PCDN(:) +! PZ0HSEA(:) = PZ0SEA (:) +!ELSEIF (KZ0 == 1) THEN ! Smith (1988) formulation +! PZ0SEA (:) = (ZCHARN(:)/XG)*ZUSTAR2(:) + 0.11*ZVISA(:)/PUSTAR(:) +! PZ0HSEA(:) = PZ0SEA (:) +!ELSEIF (KZ0 == 2) THEN ! Direct computation using the stability functions +! DO JLON=1,SIZE(PTA) +! PZ0SEA (JLON) = PUREF(JLON)/EXP(XKARMAN*ZDDU(JLON)/PUSTAR(JLON)+ZPSIU(JLON)) +! Z0TSEA = PZREF(JLON)/EXP(XKARMAN*ZDDT(JLON)/ZTSR (JLON)+ZPSIT(JLON)) +! Z0QSEA = PZREF(JLON)/EXP(XKARMAN*ZDDQ(JLON)/ZQSR (JLON)+ZPSIT(JLON)) +! PZ0HSEA(JLON) = 0.5*(Z0TSEA+Z0QSEA) +! ENDDO +!ENDIF + +write(*,*) "JLON ",JLON +write(*,*) "PTA ",klon,PTA +write(*,*) "PCD ",SIZE(PCD),PCD +write(*,*) "PCQ ",SIZE(PCE),PCE +write(*,*) "PCH ",SIZE(PCH),PCH + +coeffs = [PCD,& + PCE,& + PCH] +! +! +!IF (LHOOK) CALL DR_HOOK('ECUMEV6_FLUX',1,ZHOOK_HANDLE) +! +!------------------------------------------------------------------------------- + END SUBROUTINE ecumev6_flux + +END MODULE ecumev6_flux_mod Index: LMDZ6/trunk/libf/phylmd/ener_conserv.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ener_conserv.f90 (revision 6047) +++ (revision ) @@ -1,278 +1,0 @@ -!$gpum horizontal klon -MODULE ener_conserv_mod - - PRIVATE - - PUBLIC ener_conserv - - CONTAINS - -subroutine ener_conserv(klon,klev,pdtphys, & - & puo,pvo,pto,qx,ivap,iliq,isol, & - & pun,pvn,ptn,pqn,pqln,pqsn,dtke,masse,exner,d_t_ec) - -!============================================================= -! Energy conservation -! Based on the TKE equation -! The M2 and N2 terms at the origin of TKE production are -! concerted into heating in the d_t_ec term -! Option 1 is the standard -! 101 is for M2 term only -! 101 for N2 term only -! -1 is a previours treatment for kinetic energy only -! FH (hourdin@lmd.jussieu.fr), 2013/04/25 -!============================================================= - -!============================================================= -! Declarations -!============================================================= - -! From module -USE compbl_mod_h -USE yoethf_mod_h -USE clesphys_mod_h -USE phys_local_var_mod, ONLY : d_u_vdf,d_v_vdf,d_t_vdf,d_u_ajs,d_v_ajs,d_t_ajs, & - & d_u_con,d_v_con,d_t_con,d_t_diss -USE phys_local_var_mod, ONLY : d_t_eva,d_t_lsc,d_q_eva,d_q_lsc -USE phys_local_var_mod, ONLY : d_u_oro,d_v_oro,d_u_lif,d_v_lif -USE phys_local_var_mod, ONLY : du_gwd_hines,dv_gwd_hines,dv_gwd_front,dv_gwd_rando -USE phys_state_var_mod, ONLY : du_gwd_front,du_gwd_rando -USE phys_output_var_mod, ONLY : bils_ec,bils_ech,bils_tke,bils_kinetic,bils_enthalp,bils_latent,bils_diss -USE add_phys_tend_mod, ONLY : fl_cor_ebil -USE infotrac_phy, ONLY: nqtot - - -USE yomcst_mod_h -IMPLICIT none - - -! Arguments -INTEGER, INTENT(IN) :: klon,klev -REAL, INTENT(IN) :: pdtphys -REAL, DIMENSION(klon,klev), INTENT(IN) :: puo,pvo,pto -REAL, DIMENSION(klon,klev,nqtot), INTENT(IN):: qx -INTEGER, INTENT(IN) :: ivap, iliq, isol -REAL, DIMENSION(klon,klev), INTENT(IN) :: pun,pvn,ptn,pqn,pqln,pqsn -REAL, DIMENSION(klon,klev), INTENT(IN) :: masse,exner -REAL, DIMENSION(klon,klev+1), INTENT(IN) :: dtke -! -REAL, DIMENSION(klon,klev), INTENT(OUT) :: d_t_ec - -! Local - integer k,i -REAL, DIMENSION(klon,klev+1) :: fluxu,fluxv,fluxt -REAL, DIMENSION(klon,klev+1) :: dddu,dddv,dddt -REAL, DIMENSION(klon,klev) :: d_u,d_v,d_t,zv,zu,d_t_ech, pqo, pql0, pqs0 -REAL ZRCPD - -CHARACTER (LEN=80) :: abort_message -CHARACTER (LEN=20), PARAMETER :: modname = 'ener_conser' - -d_t_ec(:,:)=0. - -IF(ivap == 0) CALL abort_physic (modname,'can''t run without water vapour',1) -IF(iliq == 0) CALL abort_physic (modname,'can''t run without liquid water',1) -pqo = qx(:,:,ivap) -pql0 = qx(:,:,iliq) -IF(isol /= 0) pqs0 = qx(:,:,isol) - -IF (iflag_ener_conserv==-1) THEN -!+jld ec_conser - DO k = 1, klev - DO i = 1, klon - IF (fl_cor_ebil .GT. 0) then - ZRCPD = RCPD*(1.0+RVTMP2*(pqn(i,k)+pqln(i,k)+pqsn(i,k))) - ELSE - ZRCPD = RCPD*(1.0+RVTMP2*pqn(i,k)) - ENDIF - d_t_ec(i,k)=0.5/ZRCPD & - & *(puo(i,k)**2+pvo(i,k)**2-pun(i,k)**2-pvn(i,k)**2) - ENDDO - ENDDO -!-jld ec_conser - - - -ELSEIF (iflag_ener_conserv>=1) THEN - - IF (iflag_ener_conserv<=2) THEN -! print*,'ener_conserv pbl=',iflag_pbl - IF (iflag_pbl>=20 .AND. iflag_pbl<=27) THEN !d_t_diss accounts for conserv - d_t(:,:)=d_t_ajs(:,:) ! d_t_ajs = adjust + thermals - d_u(:,:)=d_u_ajs(:,:)+d_u_con(:,:) - d_v(:,:)=d_v_ajs(:,:)+d_v_con(:,:) - ELSE - d_t(:,:)=d_t_vdf(:,:)+d_t_ajs(:,:) ! d_t_ajs = adjust + thermals - d_u(:,:)=d_u_vdf(:,:)+d_u_ajs(:,:)+d_u_con(:,:) - d_v(:,:)=d_v_vdf(:,:)+d_v_ajs(:,:)+d_v_con(:,:) - ENDIF - ELSEIF (iflag_ener_conserv==101) THEN - d_t(:,:)=0. - d_u(:,:)=d_u_vdf(:,:)+d_u_ajs(:,:)+d_u_con(:,:) - d_v(:,:)=d_v_vdf(:,:)+d_v_ajs(:,:)+d_v_con(:,:) - ELSEIF (iflag_ener_conserv==110) THEN - d_t(:,:)=d_t_vdf(:,:)+d_t_ajs(:,:) - d_u(:,:)=0. - d_v(:,:)=0. - - ELSEIF (iflag_ener_conserv==3) THEN - d_t(:,:)=0. - d_u(:,:)=0. - d_v(:,:)=0. - ELSEIF (iflag_ener_conserv==4) THEN - d_t(:,:)=0. - d_u(:,:)=d_u_vdf(:,:) - d_v(:,:)=d_v_vdf(:,:) - ELSEIF (iflag_ener_conserv==5) THEN - d_t(:,:)=d_t_vdf(:,:) - d_u(:,:)=d_u_vdf(:,:) - d_v(:,:)=d_v_vdf(:,:) - ELSEIF (iflag_ener_conserv==6) THEN - d_t(:,:)=d_t_vdf(:,:) - d_u(:,:)=d_u_vdf(:,:)+d_u_ajs(:,:) - d_v(:,:)=d_v_vdf(:,:)+d_v_ajs(:,:) - ELSEIF (iflag_ener_conserv==7) THEN - d_t(:,:)=d_t_vdf(:,:)+d_t_ajs(:,:) - d_u(:,:)=d_u_vdf(:,:)+d_u_ajs(:,:) - d_v(:,:)=d_v_vdf(:,:)+d_v_ajs(:,:) - ELSEIF (iflag_ener_conserv==8) THEN - d_t(:,:)=d_t_vdf(:,:) - d_u(:,:)=d_u_vdf(:,:)+d_u_ajs(:,:)+d_u_con(:,:) - d_v(:,:)=d_v_vdf(:,:)+d_v_ajs(:,:)+d_v_con(:,:) - ELSEIF (iflag_ener_conserv==9) THEN - d_t(:,:)=d_t_vdf(:,:) - d_u(:,:)=d_u_vdf(:,:)+d_u_ajs(:,:)+d_u_con(:,:)+d_u_oro(:,:) - d_v(:,:)=d_v_vdf(:,:)+d_v_ajs(:,:)+d_v_con(:,:)+d_v_oro(:,:) - ELSEIF (iflag_ener_conserv==10) THEN - d_t(:,:)=d_t_vdf(:,:) - d_u(:,:)=d_u_vdf(:,:)+d_u_ajs(:,:)+d_u_con(:,:)+d_u_oro(:,:)+d_u_lif(:,:) - d_v(:,:)=d_v_vdf(:,:)+d_v_ajs(:,:)+d_v_con(:,:)+d_v_oro(:,:)+d_v_lif(:,:) - ELSEIF (iflag_ener_conserv==11) THEN - d_t(:,:)=d_t_vdf(:,:) - d_u(:,:)=d_u_vdf(:,:)+d_u_ajs(:,:)+d_u_con(:,:)+d_u_oro(:,:)+d_u_lif(:,:) - d_v(:,:)=d_v_vdf(:,:)+d_v_ajs(:,:)+d_v_con(:,:)+d_v_oro(:,:)+d_v_lif(:,:) - IF (ok_hines) THEN - d_u_vdf(:,:)=d_u_vdf(:,:)+du_gwd_hines(:,:) - d_v_vdf(:,:)=d_v_vdf(:,:)+dv_gwd_hines(:,:) - ENDIF - IF (.not. ok_hines .and. ok_gwd_rando) THEN - d_u_vdf(:,:)=d_u_vdf(:,:)+du_gwd_front(:,:) - d_v_vdf(:,:)=d_v_vdf(:,:)+dv_gwd_front(:,:) - ENDIF - IF (ok_gwd_rando) THEN - d_u_vdf(:,:)=d_u_vdf(:,:)+du_gwd_rando(:,:) - d_v_vdf(:,:)=d_v_vdf(:,:)+dv_gwd_rando(:,:) - ENDIF - ELSE - abort_message = 'iflag_ener_conserv non prevu' - CALL abort_physic (modname,abort_message,1) - ENDIF - -!---------------------------------------------------------------------------- -! Two options wether we consider time integration in the energy conservation -!---------------------------------------------------------------------------- - - if (iflag_ener_conserv==2) then - zu(:,:)=puo(:,:) - zv(:,:)=pvo(:,:) - else - IF (iflag_pbl>=20 .AND. iflag_pbl<=27) THEN - zu(:,:)=puo(:,:)+d_u_vdf(:,:)+0.5*d_u(:,:) - zv(:,:)=pvo(:,:)+d_v_vdf(:,:)+0.5*d_v(:,:) - ELSE - zu(:,:)=puo(:,:)+0.5*d_u(:,:) - zv(:,:)=pvo(:,:)+0.5*d_v(:,:) - ENDIF - endif - - fluxu(:,klev+1)=0. - fluxv(:,klev+1)=0. - fluxt(:,klev+1)=0. - - do k=klev,1,-1 - fluxu(:,k)=fluxu(:,k+1)+masse(:,k)*d_u(:,k) - fluxv(:,k)=fluxv(:,k+1)+masse(:,k)*d_v(:,k) - fluxt(:,k)=fluxt(:,k+1)+masse(:,k)*d_t(:,k)/exner(:,k) - enddo - - dddu(:,1)=2*zu(:,1)*fluxu(:,1) - dddv(:,1)=2*zv(:,1)*fluxv(:,1) - dddt(:,1)=(exner(:,1)-1.)*fluxt(:,1) - - do k=2,klev - dddu(:,k)=(zu(:,k)-zu(:,k-1))*fluxu(:,k) - dddv(:,k)=(zv(:,k)-zv(:,k-1))*fluxv(:,k) - dddt(:,k)=(exner(:,k)-exner(:,k-1))*fluxt(:,k) - enddo - dddu(:,klev+1)=0. - dddv(:,klev+1)=0. - dddt(:,klev+1)=0. - - do k=1,klev - d_t_ech(:,k)=-(rcpd*(dddt(:,k)+dddt(:,k+1)))/(2.*rcpd*masse(:,k)) - d_t_ec(:,k)=-(dddu(:,k)+dddu(:,k+1)+dddv(:,k)+dddv(:,k+1))/(2.*rcpd*masse(:,k))+d_t_ech(:,k) - enddo - -ENDIF - -!================================================================ -! Computation of integrated enthalpie and kinetic energy variation -! FH (hourdin@lmd.jussieu.fr), 2013/04/25 -! bils_ec : energie conservation term -! bils_ech : part of this term linked to temperature -! bils_tke : change of TKE -! bils_diss : dissipation of TKE (when activated) -! bils_kinetic : change of kinetic energie of the column -! bils_enthalp : change of enthalpie -! bils_latent : change of latent heat. Computed between -! after reevaporation (at the beginning of the physics) -! and before large scale condensation (fisrtilp) -!================================================================ - - bils_ec(:)=0. - bils_ech(:)=0. - bils_tke(:)=0. - bils_diss(:)=0. - bils_kinetic(:)=0. - bils_enthalp(:)=0. - bils_latent(:)=0. - DO k=1,klev - bils_ec(:)=bils_ec(:)-d_t_ec(:,k)*masse(:,k) - bils_diss(:)=bils_diss(:)-d_t_diss(:,k)*masse(:,k) - bils_kinetic(:)=bils_kinetic(:)+masse(:,k)* & - & (pun(:,k)*pun(:,k)+pvn(:,k)*pvn(:,k) & - & -puo(:,k)*puo(:,k)-pvo(:,k)*pvo(:,k)) - bils_enthalp(:)= & - & bils_enthalp(:)+masse(:,k)*(ptn(:,k)-pto(:,k)+d_t_ec(:,k)-d_t_eva(:,k)-d_t_lsc(:,k)) -! & bils_enthalp(:)+masse(:,k)*(ptn(:,k)-pto(:,k)+d_t_ec(:,k)) - bils_latent(:)=bils_latent(:)+masse(:,k)* & -! & (pqn(:,k)-pqo(:,k)) - & (pqn(:,k)-pqo(:,k)-d_q_eva(:,k)-d_q_lsc(:,k)) - ENDDO - bils_ec(:)=rcpd*bils_ec(:)/pdtphys - bils_diss(:)=rcpd*bils_diss(:)/pdtphys - bils_kinetic(:)= 0.5*bils_kinetic(:)/pdtphys - bils_enthalp(:)=rcpd*bils_enthalp(:)/pdtphys - bils_latent(:)=rlvtt*bils_latent(:)/pdtphys -!jyg< - IF (iflag_pbl > 1) THEN - DO k=1,klev - bils_tke(:)=bils_tke(:)+0.5*(dtke(:,k)+dtke(:,k+1))*masse(:,k) - ENDDO - bils_tke(:)=bils_tke(:)/pdtphys - ENDIF ! (iflag_pbl > 1) -!>jyg - -IF (iflag_ener_conserv>=1) THEN - bils_ech(:)=0. - DO k=1,klev - bils_ech(:)=bils_ech(:)-d_t_ech(:,k)*masse(:,k) - ENDDO - bils_ech(:)=rcpd*bils_ech(:)/pdtphys -ENDIF - -RETURN - -END SUBROUTINE ener_conserv - -END MODULE ener_conserv_mod Index: LMDZ6/trunk/libf/phylmd/ener_conserv_mod.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ener_conserv_mod.f90 (revision 6048) +++ LMDZ6/trunk/libf/phylmd/ener_conserv_mod.f90 (revision 6048) @@ -0,0 +1,278 @@ +!$gpum horizontal klon +MODULE ener_conserv_mod + + PRIVATE + + PUBLIC ener_conserv + + CONTAINS + +subroutine ener_conserv(klon,klev,pdtphys, & + & puo,pvo,pto,qx,ivap,iliq,isol, & + & pun,pvn,ptn,pqn,pqln,pqsn,dtke,masse,exner,d_t_ec) + +!============================================================= +! Energy conservation +! Based on the TKE equation +! The M2 and N2 terms at the origin of TKE production are +! concerted into heating in the d_t_ec term +! Option 1 is the standard +! 101 is for M2 term only +! 101 for N2 term only +! -1 is a previours treatment for kinetic energy only +! FH (hourdin@lmd.jussieu.fr), 2013/04/25 +!============================================================= + +!============================================================= +! Declarations +!============================================================= + +! From module +USE compbl_mod_h +USE yoethf_mod_h +USE clesphys_mod_h +USE phys_local_var_mod, ONLY : d_u_vdf,d_v_vdf,d_t_vdf,d_u_ajs,d_v_ajs,d_t_ajs, & + & d_u_con,d_v_con,d_t_con,d_t_diss +USE phys_local_var_mod, ONLY : d_t_eva,d_t_lsc,d_q_eva,d_q_lsc +USE phys_local_var_mod, ONLY : d_u_oro,d_v_oro,d_u_lif,d_v_lif +USE phys_local_var_mod, ONLY : du_gwd_hines,dv_gwd_hines,dv_gwd_front,dv_gwd_rando +USE phys_state_var_mod, ONLY : du_gwd_front,du_gwd_rando +USE phys_output_var_mod, ONLY : bils_ec,bils_ech,bils_tke,bils_kinetic,bils_enthalp,bils_latent,bils_diss +USE add_phys_tend_mod, ONLY : fl_cor_ebil +USE infotrac_phy, ONLY: nqtot + + +USE yomcst_mod_h +IMPLICIT none + + +! Arguments +INTEGER, INTENT(IN) :: klon,klev +REAL, INTENT(IN) :: pdtphys +REAL, DIMENSION(klon,klev), INTENT(IN) :: puo,pvo,pto +REAL, DIMENSION(klon,klev,nqtot), INTENT(IN):: qx +INTEGER, INTENT(IN) :: ivap, iliq, isol +REAL, DIMENSION(klon,klev), INTENT(IN) :: pun,pvn,ptn,pqn,pqln,pqsn +REAL, DIMENSION(klon,klev), INTENT(IN) :: masse,exner +REAL, DIMENSION(klon,klev+1), INTENT(IN) :: dtke +! +REAL, DIMENSION(klon,klev), INTENT(OUT) :: d_t_ec + +! Local + integer k,i +REAL, DIMENSION(klon,klev+1) :: fluxu,fluxv,fluxt +REAL, DIMENSION(klon,klev+1) :: dddu,dddv,dddt +REAL, DIMENSION(klon,klev) :: d_u,d_v,d_t,zv,zu,d_t_ech, pqo, pql0, pqs0 +REAL ZRCPD + +CHARACTER (LEN=80) :: abort_message +CHARACTER (LEN=20), PARAMETER :: modname = 'ener_conser' + +d_t_ec(:,:)=0. + +IF(ivap == 0) CALL abort_physic (modname,'can''t run without water vapour',1) +IF(iliq == 0) CALL abort_physic (modname,'can''t run without liquid water',1) +pqo = qx(:,:,ivap) +pql0 = qx(:,:,iliq) +IF(isol /= 0) pqs0 = qx(:,:,isol) + +IF (iflag_ener_conserv==-1) THEN +!+jld ec_conser + DO k = 1, klev + DO i = 1, klon + IF (fl_cor_ebil .GT. 0) then + ZRCPD = RCPD*(1.0+RVTMP2*(pqn(i,k)+pqln(i,k)+pqsn(i,k))) + ELSE + ZRCPD = RCPD*(1.0+RVTMP2*pqn(i,k)) + ENDIF + d_t_ec(i,k)=0.5/ZRCPD & + & *(puo(i,k)**2+pvo(i,k)**2-pun(i,k)**2-pvn(i,k)**2) + ENDDO + ENDDO +!-jld ec_conser + + + +ELSEIF (iflag_ener_conserv>=1) THEN + + IF (iflag_ener_conserv<=2) THEN +! print*,'ener_conserv pbl=',iflag_pbl + IF (iflag_pbl>=20 .AND. iflag_pbl<=27) THEN !d_t_diss accounts for conserv + d_t(:,:)=d_t_ajs(:,:) ! d_t_ajs = adjust + thermals + d_u(:,:)=d_u_ajs(:,:)+d_u_con(:,:) + d_v(:,:)=d_v_ajs(:,:)+d_v_con(:,:) + ELSE + d_t(:,:)=d_t_vdf(:,:)+d_t_ajs(:,:) ! d_t_ajs = adjust + thermals + d_u(:,:)=d_u_vdf(:,:)+d_u_ajs(:,:)+d_u_con(:,:) + d_v(:,:)=d_v_vdf(:,:)+d_v_ajs(:,:)+d_v_con(:,:) + ENDIF + ELSEIF (iflag_ener_conserv==101) THEN + d_t(:,:)=0. + d_u(:,:)=d_u_vdf(:,:)+d_u_ajs(:,:)+d_u_con(:,:) + d_v(:,:)=d_v_vdf(:,:)+d_v_ajs(:,:)+d_v_con(:,:) + ELSEIF (iflag_ener_conserv==110) THEN + d_t(:,:)=d_t_vdf(:,:)+d_t_ajs(:,:) + d_u(:,:)=0. + d_v(:,:)=0. + + ELSEIF (iflag_ener_conserv==3) THEN + d_t(:,:)=0. + d_u(:,:)=0. + d_v(:,:)=0. + ELSEIF (iflag_ener_conserv==4) THEN + d_t(:,:)=0. + d_u(:,:)=d_u_vdf(:,:) + d_v(:,:)=d_v_vdf(:,:) + ELSEIF (iflag_ener_conserv==5) THEN + d_t(:,:)=d_t_vdf(:,:) + d_u(:,:)=d_u_vdf(:,:) + d_v(:,:)=d_v_vdf(:,:) + ELSEIF (iflag_ener_conserv==6) THEN + d_t(:,:)=d_t_vdf(:,:) + d_u(:,:)=d_u_vdf(:,:)+d_u_ajs(:,:) + d_v(:,:)=d_v_vdf(:,:)+d_v_ajs(:,:) + ELSEIF (iflag_ener_conserv==7) THEN + d_t(:,:)=d_t_vdf(:,:)+d_t_ajs(:,:) + d_u(:,:)=d_u_vdf(:,:)+d_u_ajs(:,:) + d_v(:,:)=d_v_vdf(:,:)+d_v_ajs(:,:) + ELSEIF (iflag_ener_conserv==8) THEN + d_t(:,:)=d_t_vdf(:,:) + d_u(:,:)=d_u_vdf(:,:)+d_u_ajs(:,:)+d_u_con(:,:) + d_v(:,:)=d_v_vdf(:,:)+d_v_ajs(:,:)+d_v_con(:,:) + ELSEIF (iflag_ener_conserv==9) THEN + d_t(:,:)=d_t_vdf(:,:) + d_u(:,:)=d_u_vdf(:,:)+d_u_ajs(:,:)+d_u_con(:,:)+d_u_oro(:,:) + d_v(:,:)=d_v_vdf(:,:)+d_v_ajs(:,:)+d_v_con(:,:)+d_v_oro(:,:) + ELSEIF (iflag_ener_conserv==10) THEN + d_t(:,:)=d_t_vdf(:,:) + d_u(:,:)=d_u_vdf(:,:)+d_u_ajs(:,:)+d_u_con(:,:)+d_u_oro(:,:)+d_u_lif(:,:) + d_v(:,:)=d_v_vdf(:,:)+d_v_ajs(:,:)+d_v_con(:,:)+d_v_oro(:,:)+d_v_lif(:,:) + ELSEIF (iflag_ener_conserv==11) THEN + d_t(:,:)=d_t_vdf(:,:) + d_u(:,:)=d_u_vdf(:,:)+d_u_ajs(:,:)+d_u_con(:,:)+d_u_oro(:,:)+d_u_lif(:,:) + d_v(:,:)=d_v_vdf(:,:)+d_v_ajs(:,:)+d_v_con(:,:)+d_v_oro(:,:)+d_v_lif(:,:) + IF (ok_hines) THEN + d_u_vdf(:,:)=d_u_vdf(:,:)+du_gwd_hines(:,:) + d_v_vdf(:,:)=d_v_vdf(:,:)+dv_gwd_hines(:,:) + ENDIF + IF (.not. ok_hines .and. ok_gwd_rando) THEN + d_u_vdf(:,:)=d_u_vdf(:,:)+du_gwd_front(:,:) + d_v_vdf(:,:)=d_v_vdf(:,:)+dv_gwd_front(:,:) + ENDIF + IF (ok_gwd_rando) THEN + d_u_vdf(:,:)=d_u_vdf(:,:)+du_gwd_rando(:,:) + d_v_vdf(:,:)=d_v_vdf(:,:)+dv_gwd_rando(:,:) + ENDIF + ELSE + abort_message = 'iflag_ener_conserv non prevu' + CALL abort_physic (modname,abort_message,1) + ENDIF + +!---------------------------------------------------------------------------- +! Two options wether we consider time integration in the energy conservation +!---------------------------------------------------------------------------- + + if (iflag_ener_conserv==2) then + zu(:,:)=puo(:,:) + zv(:,:)=pvo(:,:) + else + IF (iflag_pbl>=20 .AND. iflag_pbl<=27) THEN + zu(:,:)=puo(:,:)+d_u_vdf(:,:)+0.5*d_u(:,:) + zv(:,:)=pvo(:,:)+d_v_vdf(:,:)+0.5*d_v(:,:) + ELSE + zu(:,:)=puo(:,:)+0.5*d_u(:,:) + zv(:,:)=pvo(:,:)+0.5*d_v(:,:) + ENDIF + endif + + fluxu(:,klev+1)=0. + fluxv(:,klev+1)=0. + fluxt(:,klev+1)=0. + + do k=klev,1,-1 + fluxu(:,k)=fluxu(:,k+1)+masse(:,k)*d_u(:,k) + fluxv(:,k)=fluxv(:,k+1)+masse(:,k)*d_v(:,k) + fluxt(:,k)=fluxt(:,k+1)+masse(:,k)*d_t(:,k)/exner(:,k) + enddo + + dddu(:,1)=2*zu(:,1)*fluxu(:,1) + dddv(:,1)=2*zv(:,1)*fluxv(:,1) + dddt(:,1)=(exner(:,1)-1.)*fluxt(:,1) + + do k=2,klev + dddu(:,k)=(zu(:,k)-zu(:,k-1))*fluxu(:,k) + dddv(:,k)=(zv(:,k)-zv(:,k-1))*fluxv(:,k) + dddt(:,k)=(exner(:,k)-exner(:,k-1))*fluxt(:,k) + enddo + dddu(:,klev+1)=0. + dddv(:,klev+1)=0. + dddt(:,klev+1)=0. + + do k=1,klev + d_t_ech(:,k)=-(rcpd*(dddt(:,k)+dddt(:,k+1)))/(2.*rcpd*masse(:,k)) + d_t_ec(:,k)=-(dddu(:,k)+dddu(:,k+1)+dddv(:,k)+dddv(:,k+1))/(2.*rcpd*masse(:,k))+d_t_ech(:,k) + enddo + +ENDIF + +!================================================================ +! Computation of integrated enthalpie and kinetic energy variation +! FH (hourdin@lmd.jussieu.fr), 2013/04/25 +! bils_ec : energie conservation term +! bils_ech : part of this term linked to temperature +! bils_tke : change of TKE +! bils_diss : dissipation of TKE (when activated) +! bils_kinetic : change of kinetic energie of the column +! bils_enthalp : change of enthalpie +! bils_latent : change of latent heat. Computed between +! after reevaporation (at the beginning of the physics) +! and before large scale condensation (fisrtilp) +!================================================================ + + bils_ec(:)=0. + bils_ech(:)=0. + bils_tke(:)=0. + bils_diss(:)=0. + bils_kinetic(:)=0. + bils_enthalp(:)=0. + bils_latent(:)=0. + DO k=1,klev + bils_ec(:)=bils_ec(:)-d_t_ec(:,k)*masse(:,k) + bils_diss(:)=bils_diss(:)-d_t_diss(:,k)*masse(:,k) + bils_kinetic(:)=bils_kinetic(:)+masse(:,k)* & + & (pun(:,k)*pun(:,k)+pvn(:,k)*pvn(:,k) & + & -puo(:,k)*puo(:,k)-pvo(:,k)*pvo(:,k)) + bils_enthalp(:)= & + & bils_enthalp(:)+masse(:,k)*(ptn(:,k)-pto(:,k)+d_t_ec(:,k)-d_t_eva(:,k)-d_t_lsc(:,k)) +! & bils_enthalp(:)+masse(:,k)*(ptn(:,k)-pto(:,k)+d_t_ec(:,k)) + bils_latent(:)=bils_latent(:)+masse(:,k)* & +! & (pqn(:,k)-pqo(:,k)) + & (pqn(:,k)-pqo(:,k)-d_q_eva(:,k)-d_q_lsc(:,k)) + ENDDO + bils_ec(:)=rcpd*bils_ec(:)/pdtphys + bils_diss(:)=rcpd*bils_diss(:)/pdtphys + bils_kinetic(:)= 0.5*bils_kinetic(:)/pdtphys + bils_enthalp(:)=rcpd*bils_enthalp(:)/pdtphys + bils_latent(:)=rlvtt*bils_latent(:)/pdtphys +!jyg< + IF (iflag_pbl > 1) THEN + DO k=1,klev + bils_tke(:)=bils_tke(:)+0.5*(dtke(:,k)+dtke(:,k+1))*masse(:,k) + ENDDO + bils_tke(:)=bils_tke(:)/pdtphys + ENDIF ! (iflag_pbl > 1) +!>jyg + +IF (iflag_ener_conserv>=1) THEN + bils_ech(:)=0. + DO k=1,klev + bils_ech(:)=bils_ech(:)-d_t_ech(:,k)*masse(:,k) + ENDDO + bils_ech(:)=rcpd*bils_ech(:)/pdtphys +ENDIF + +RETURN + +END SUBROUTINE ener_conserv + +END MODULE ener_conserv_mod Index: LMDZ6/trunk/libf/phylmd/etat0_limit_unstruct_mod.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/etat0_limit_unstruct_mod.f90 (revision 6048) +++ LMDZ6/trunk/libf/phylmd/etat0_limit_unstruct_mod.f90 (revision 6048) @@ -0,0 +1,113 @@ +MODULE etat0_limit_unstruct_mod + + LOGICAL, SAVE :: create_etat0_limit +!$OMP THREADPRIVATE(create_etat0_limit) + + + + +CONTAINS + + SUBROUTINE init_etat0_limit_unstruct + USE lmdz_xios, ONLY: xios_set_axis_attr, xios_set_fieldgroup_attr, & + xios_set_filegroup_attr, xios_set_file_attr + USE mod_phys_lmdz_para, ONLY: is_omp_master + USE mod_grid_phy_lmdz, ONLY: grid_type, unstructured + USE ioipsl, ONLY : ioget_year_len + USE ioipsl_getin_p_mod, ONLY: getin_p + USE time_phylmdz_mod, ONLY : annee_ref + USE create_etat0_unstruct_mod, ONLY: init_create_etat0_unstruct + IMPLICIT NONE + + INTEGER :: iflag_phys,i + INTEGER :: ndays + REAL,ALLOCATABLE :: value(:) + + IF (grid_type==unstructured) THEN + CALL getin_p("iflag_phys",iflag_phys) + + CALL getin_p('create_etat0_limit',create_etat0_limit) + + ndays=ioget_year_len(annee_ref) + ALLOCATE(value(ndays)) + DO i=1,ndays + value(i)=i-1 + ENDDO + + IF (is_omp_master) CALL xios_set_axis_attr("time_year",n_glo=ndays,value=value) + + IF (create_etat0_limit) THEN + IF (iflag_phys<100) THEN + IF (is_omp_master) CALL xios_set_fieldgroup_attr("etat0_limit_read",read_access=.TRUE.,enabled=.TRUE.) + IF (is_omp_master) CALL xios_set_filegroup_attr("etat0_limit_read",enabled=.TRUE.) + ENDIF + IF (is_omp_master) CALL xios_set_file_attr("limit_write",enabled=.TRUE.) + CALL init_create_etat0_unstruct + ENDIF + + ENDIF + + END SUBROUTINE init_etat0_limit_unstruct + + SUBROUTINE create_etat0_limit_unstruct + USE mod_grid_phy_lmdz, ONLY: grid_type, unstructured + USE create_etat0_unstruct_mod, ONLY: create_etat0_unstruct + USE create_limit_unstruct_mod, ONLY: create_limit_unstruct + USE phyaqua_mod, ONLY: iniaqua + USE phys_cal_mod, only: year_len + USE mod_phys_lmdz_para, ONLY: is_omp_master + USE ioipsl_getin_p_mod, ONLY: getin_p + USE dimphy, ONLY: klon + USE lmdz_xios, ONLY: xios_context_finalize, xios_set_current_context, & + xios_finalize + USE print_control_mod, ONLY: lunout + IMPLICIT NONE + INTEGER :: iflag_phys + INTEGER :: ierr + CHARACTER (LEN=20) :: modname='create_etat0_limit_unstruct' + CHARACTER (LEN=80) :: abort_message + + IF (grid_type==unstructured) THEN + + CALL getin_p("iflag_phys",iflag_phys) + + IF (iflag_phys<100) THEN + IF ( create_etat0_limit) THEN + CALL create_etat0_unstruct + CALL create_limit_unstruct + IF (is_omp_master) THEN + CALL xios_context_finalize() + CALL xios_set_current_context("icosagcm") ! very bad, need to find an other solution + CALL xios_context_finalize() + CALL xios_finalize() +! CALL MPI_Finalize(ierr) + abort_message='create_etat0_limit_unstruct, Initial state file are created, all is fine' + write(lunout,*) abort_message + STOP 0 +! CALL abort_physic(modname,abort_message,0) + ENDIF +!$OMP BARRIER + abort_message='create_etat0_limit_unstruct, Initial state file are created, all is fine' + CALL abort_physic(modname,abort_message,0) + ENDIF + ELSE + IF (create_etat0_limit) THEN + CALL iniaqua(klon,year_len,iflag_phys) + IF (is_omp_master) THEN + CALL xios_context_finalize() + CALL xios_set_current_context("icosagcm") ! very bad, need to find an other solution + CALL xios_context_finalize() + CALL xios_finalize() +! CALL MPI_Finalize(ierr) + ENDIF +!$OMP BARRIER + abort_message='create_etat0_limit_unstruct, Initial state file are created, all is fine' + CALL abort_physic(modname,abort_message,0) + ENDIF + ENDIF + ENDIF + + END SUBROUTINE create_etat0_limit_unstruct + +END MODULE etat0_limit_unstruct_mod + Index: LMDZ6/trunk/libf/phylmd/evappot.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/evappot.f90 (revision 6047) +++ (revision ) @@ -1,53 +1,0 @@ -!$gpum horizontal klon -MODULE evappot_mod - PRIVATE - - PUBLIC evappot - - CONTAINS - -SUBROUTINE evappot(klon,nbsrf,ftsol,pplay,cdragh, & - & t_seri,q_seri,u_seri,v_seri,evap_pot) - -USE yoethf_mod_h -USE yomcst_mod_h -IMPLICIT NONE - - -INCLUDE "FCTTRE.h" - - -INTEGER :: klon, nbsrf -REAL, DIMENSION(klon,nbsrf) :: ftsol,evap_pot -REAL, DIMENSION(klon) :: pplay,t_seri,wind,q_seri,u_seri,v_seri,cdragh - -INTEGER :: nsrf,i -REAL, DIMENSION(klon,nbsrf) :: qsat_ftsol -REAL, DIMENSION(klon) :: rhos, norme_u -REAL :: t_coup - - t_coup=234. ! Quelle horreur !!!!! - -DO nsrf = 1, nbsrf - DO i = 1, klon - IF (ftsol(i,nsrf).LT.t_coup) THEN - qsat_ftsol(i,nsrf) = qsats(ftsol(i,nsrf))/pplay(i) - ELSE - qsat_ftsol(i,nsrf) = qsatl(ftsol(i,nsrf))/pplay(i) - ENDIF - ENDDO -ENDDO -! ========================================================== c -! Calcul de l'evaporation Potentielle - - -rhos(:) = pplay(:)/(RD*t_seri(:)) -norme_u(:)=1.+sqrt(u_seri(:)*u_seri(:)+v_seri(:)*v_seri(:)) -DO nsrf = 1, nbsrf - evap_pot(:,nsrf)=rhos(:)*cdragh(:)*norme_u(:)*(qsat_ftsol(:,nsrf)-q_seri(:)) -ENDDO -RETURN - -END SUBROUTINE evappot - -END MODULE evappot_mod Index: LMDZ6/trunk/libf/phylmd/evappot_mod.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/evappot_mod.f90 (revision 6048) +++ LMDZ6/trunk/libf/phylmd/evappot_mod.f90 (revision 6048) @@ -0,0 +1,53 @@ +!$gpum horizontal klon +MODULE evappot_mod + PRIVATE + + PUBLIC evappot + + CONTAINS + +SUBROUTINE evappot(klon,nbsrf,ftsol,pplay,cdragh, & + & t_seri,q_seri,u_seri,v_seri,evap_pot) + +USE yoethf_mod_h +USE yomcst_mod_h +IMPLICIT NONE + + +INCLUDE "FCTTRE.h" + + +INTEGER :: klon, nbsrf +REAL, DIMENSION(klon,nbsrf) :: ftsol,evap_pot +REAL, DIMENSION(klon) :: pplay,t_seri,wind,q_seri,u_seri,v_seri,cdragh + +INTEGER :: nsrf,i +REAL, DIMENSION(klon,nbsrf) :: qsat_ftsol +REAL, DIMENSION(klon) :: rhos, norme_u +REAL :: t_coup + + t_coup=234. ! Quelle horreur !!!!! + +DO nsrf = 1, nbsrf + DO i = 1, klon + IF (ftsol(i,nsrf).LT.t_coup) THEN + qsat_ftsol(i,nsrf) = qsats(ftsol(i,nsrf))/pplay(i) + ELSE + qsat_ftsol(i,nsrf) = qsatl(ftsol(i,nsrf))/pplay(i) + ENDIF + ENDDO +ENDDO +! ========================================================== c +! Calcul de l'evaporation Potentielle + + +rhos(:) = pplay(:)/(RD*t_seri(:)) +norme_u(:)=1.+sqrt(u_seri(:)*u_seri(:)+v_seri(:)*v_seri(:)) +DO nsrf = 1, nbsrf + evap_pot(:,nsrf)=rhos(:)*cdragh(:)*norme_u(:)*(qsat_ftsol(:,nsrf)-q_seri(:)) +ENDDO +RETURN + +END SUBROUTINE evappot + +END MODULE evappot_mod Index: LMDZ6/trunk/libf/phylmd/flott_gwd_rando_m.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/flott_gwd_rando_m.f90 (revision 6047) +++ (revision ) @@ -1,469 +1,0 @@ -! -! $Id$ -! -!$gpum horizontal klon -module FLOTT_GWD_rando_m - - USE clesphys_mod_h - implicit none - INTEGER, PARAMETER:: NK = 2, NP = 2, NO = 2, NW = NK * NP * NO - INTEGER, PARAMETER:: NA = 5 !number of realizations to get the phase speed - LOGICAL, SAVE :: gwd_reproductibilite_mpiomp=.true. - LOGICAL, SAVE :: firstcall = .TRUE. - !$OMP THREADPRIVATE(firstcall,gwd_reproductibilite_mpiomp) - -contains - - SUBROUTINE FLOTT_GWD_rando_first - use dimphy, only: klev - USE ioipsl_getin_p_mod, ONLY : getin_p - IMPLICIT NONE - CHARACTER (LEN=20),PARAMETER :: modname='acama_gwd_rando_m' - CHARACTER (LEN=80) :: abort_message - - IF (firstcall) THEN - ! Cle introduite pour resoudre un probleme de non reproductibilite - ! Le but est de pouvoir tester de revenir a la version precedenete - ! A eliminer rapidement - CALL getin_p('gwd_reproductibilite_mpiomp',gwd_reproductibilite_mpiomp) - IF (NW+3*NA>=KLEV) THEN - abort_message = 'NW+3*NA>=KLEV Probleme pour generation des ondes' - CALL abort_physic (modname,abort_message,1) - ENDIF - firstcall=.false. - ENDIF - END SUBROUTINE FLOTT_GWD_rando_first - - - SUBROUTINE FLOTT_GWD_rando(DTIME, PP, tt, uu, vv, prec, zustr, zvstr, d_u, & - d_v,east_gwstress,west_gwstress) - - ! Parametrization of the momentum flux deposition due to a discrete - ! number of gravity waves. - ! Author: F. Lott - ! July, 12th, 2012 - ! Gaussian distribution of the source, source is precipitation - ! Reference: Lott (JGR, vol 118, page 8897, 2013) - - !ONLINE: - USE yomcst_mod_h -use dimphy, only: klon, klev - use assert_m, only: assert - USE ioipsl_getin_p_mod, ONLY : getin_p - USE vertical_layers_mod, ONLY : presnivs - USE yoegwd_mod_h - - CHARACTER (LEN=20),PARAMETER :: modname='flott_gwd_rando' - CHARACTER (LEN=80) :: abort_message - - ! OFFLINE: - ! include "dimensions_mod.f90" - ! include "dimphy.h" - ! END OF DIFFERENCE ONLINE-OFFLINE - - ! 0. DECLARATIONS: - - ! 0.1 INPUTS - REAL, intent(in)::DTIME ! Time step of the Physics - REAL, intent(in):: pp(KLON, KLEV) ! (KLON, KLEV) Pressure at full levels - REAL, intent(in):: prec(KLON) ! (klon) Precipitation (kg/m^2/s) - REAL, intent(in):: TT(KLON, KLEV) ! (KLON, KLEV) Temp at full levels - REAL, intent(in):: UU(KLON, KLEV) ! (KLON, KLEV) Zonal wind at full levels - REAL, intent(in):: VV(KLON, KLEV) ! (KLON, KLEV) Merid wind at full levels - - ! 0.2 OUTPUTS - REAL, intent(out):: zustr(KLON), zvstr(KLON) ! (KLON) Surface Stresses - - REAL, intent(inout):: d_u(KLON, KLEV), d_v(KLON, KLEV) - REAL, intent(inout):: east_gwstress(KLON, KLEV) ! Profile of eastward stress - REAL, intent(inout):: west_gwstress(KLON, KLEV) ! Profile of westward stress - - ! (KLON, KLEV) tendencies on winds - - ! O.3 INTERNAL ARRAYS - REAL BVLOW(klon) - REAL DZ ! Characteristic depth of the Source - - INTEGER II, JJ, LL - - ! 0.3.0 TIME SCALE OF THE LIFE CYCLE OF THE WAVES PARAMETERIZED - - REAL DELTAT - - ! 0.3.1 GRAVITY-WAVES SPECIFICATIONS - - INTEGER JK, JP, JO, JW - REAL KMIN, KMAX ! Min and Max horizontal wavenumbers - REAL CMAX ! standard deviation of the phase speed distribution - REAL RUWMAX,SAT ! ONLINE SPECIFIED IN run.def - REAL CPHA ! absolute PHASE VELOCITY frequency - REAL ZK(KLON, NW) ! Horizontal wavenumber amplitude - REAL ZP(KLON, NW) ! Horizontal wavenumber angle - REAL ZO(KLON, NW) ! Absolute frequency ! - - ! Waves Intr. freq. at the 1/2 lev surrounding the full level - REAL ZOM(KLON, NW), ZOP(KLON, NW) - - ! Wave EP-fluxes at the 2 semi levels surrounding the full level - REAL WWM(KLON, NW), WWP(KLON, NW) - - REAL RUW0(KLON, NW) ! Fluxes at launching level - - REAL RUWP(KLON, NW), RVWP(KLON, NW) - ! Fluxes X and Y for each waves at 1/2 Levels - - INTEGER LAUNCH, LTROP ! Launching altitude and tropo altitude - - REAL XLAUNCH ! Controle the launching altitude - REAL XTROP ! SORT of Tropopause altitude - REAL RUW(KLON, KLEV + 1) ! Flux x at semi levels - REAL RVW(KLON, KLEV + 1) ! Flux y at semi levels - - REAL PRMAX ! Maximum value of PREC, and for which our linear formula - ! for GWs parameterisation apply - - ! 0.3.2 PARAMETERS OF WAVES DISSIPATIONS - - REAL RDISS, ZOISEC ! COEFF DE DISSIPATION, SECURITY FOR INTRINSIC FREQ - - ! 0.3.3 BACKGROUND FLOW AT 1/2 LEVELS AND VERTICAL COORDINATE - - REAL H0 ! Characteristic Height of the atmosphere - REAL PR, TR ! Reference Pressure and Temperature - - REAL ZH(KLON, KLEV + 1) ! Log-pressure altitude - - REAL UH(KLON, KLEV + 1), VH(KLON, KLEV + 1) ! Winds at 1/2 levels - REAL PH(KLON, KLEV + 1) ! Pressure at 1/2 levels - REAL PSEC ! Security to avoid division by 0 pressure - REAL BV(KLON, KLEV + 1) ! Brunt Vaisala freq. (BVF) at 1/2 levels - REAL BVSEC ! Security to avoid negative BVF - REAL RAN_NUM_1,RAN_NUM_2,RAN_NUM_3 - - REAL, DIMENSION(klev+1) ::HREF - - - !----------------------------------------------------------------- - - ! 1. INITIALISATIONS - - ! 1.1 Basic parameter - - ! Are provided from elsewhere (latent heat of vaporization, dry - ! gaz constant for air, gravity constant, heat capacity of dry air - ! at constant pressure, earth rotation rate, pi). - - ! 1.2 Tuning parameters of V14 - - - RDISS = 0.5 ! Diffusion parameter - ! ONLINE - RUWMAX=GWD_RANDO_RUWMAX - SAT=gwd_rando_sat - !END ONLINE - ! OFFLINE - ! RUWMAX= 1.75 ! Launched flux - ! SAT=0.25 ! Saturation parameter - ! END OFFLINE - - PRMAX = 20. / 24. /3600. - ! maximum of rain for which our theory applies (in kg/m^2/s) - - ! Characteristic depth of the source - DZ = 1000. - XLAUNCH=0.5 ! Parameter that control launching altitude - XTROP=0.2 ! Parameter that control tropopause altitude - DELTAT=24.*3600. ! Time scale of the waves (first introduced in 9b) - ! OFFLINE - ! DELTAT=DTIME - ! END OFFLINE - - KMIN = 2.E-5 - ! minimum horizontal wavenumber (inverse of the subgrid scale resolution) - - KMAX = 1.E-3 ! Max horizontal wavenumber - CMAX = 30. ! Max phase speed velocity - - TR = 240. ! Reference Temperature - PR = 101300. ! Reference pressure - H0 = RD * TR / RG ! Characteristic vertical scale height - - BVSEC = 5.E-3 ! Security to avoid negative BVF - PSEC = 1.E-6 ! Security to avoid division by 0 pressure - ZOISEC = 1.E-6 ! Security FOR 0 INTRINSIC FREQ - -IF (1==0) THEN - !ONLINE - call assert(klon == (/size(pp, 1), size(tt, 1), size(uu, 1), & - size(vv, 1), size(zustr), size(zvstr), size(d_u, 1), & - size(d_v, 1), & - size(east_gwstress, 1), size(west_gwstress, 1) /), & - "FLOTT_GWD_RANDO klon") - call assert(klev == (/size(pp, 2), size(tt, 2), size(uu, 2), & - size(vv, 2), size(d_u, 2), size(d_v, 2), & - size(east_gwstress,2), size(west_gwstress,2) /), & - "FLOTT_GWD_RANDO klev") - !END ONLINE -ENDIF - - IF(DELTAT < DTIME)THEN - abort_message='flott_gwd_rando: deltat < dtime!' - CALL abort_physic(modname,abort_message,1) - ENDIF - - IF (KLEV < NW) THEN - abort_message='flott_gwd_rando: you will have problem with random numbers' - CALL abort_physic(modname,abort_message,1) - ENDIF - - ! 2. EVALUATION OF THE BACKGROUND FLOW AT SEMI-LEVELS - - ! Pressure and Inv of pressure - DO LL = 2, KLEV - PH(:, LL) = EXP((LOG(PP(:, LL)) + LOG(PP(:, LL - 1))) / 2.) - end DO - PH(:, KLEV + 1) = 0. - PH(:, 1) = 2. * PP(:, 1) - PH(:, 2) - - ! Launching altitude - - !Pour revenir a la version non reproductible en changeant le nombre de process - IF (gwd_reproductibilite_mpiomp) THEN - ! Reprend la formule qui calcule PH en fonction de PP=play - DO LL = 2, KLEV - HREF(LL) = EXP((LOG(presnivs(LL)) + LOG(presnivs(LL - 1))) / 2.) - end DO - HREF(KLEV + 1) = 0. - HREF(1) = 2. * presnivs(1) - HREF(2) - ELSE - HREF(1:KLEV)=PH(KLON/2,1:KLEV) - ENDIF - - LAUNCH=0 - LTROP =0 - DO LL = 1, KLEV - IF (HREF(LL) / HREF(1) > XLAUNCH) LAUNCH = LL - ENDDO - DO LL = 1, KLEV - IF (HREF(LL) / HREF(1) > XTROP) LTROP = LL - ENDDO - !LAUNCH=22 ; LTROP=33 -! print*,'LAUNCH=',LAUNCH,'LTROP=',LTROP - - ! Log pressure vert. coordinate - DO LL = 1, KLEV + 1 - ZH(:, LL) = H0 * LOG(PR / (PH(:, LL) + PSEC)) - end DO - - ! BV frequency - DO LL = 2, KLEV - ! BVSEC: BV Frequency (UH USED IS AS A TEMPORARY ARRAY DOWN TO WINDS) - UH(:, LL) = 0.5 * (TT(:, LL) + TT(:, LL - 1)) & - * RD**2 / RCPD / H0**2 + (TT(:, LL) & - - TT(:, LL - 1)) / (ZH(:, LL) - ZH(:, LL - 1)) * RD / H0 - end DO - BVLOW(:) = 0.5 * (TT(:, LTROP )+ TT(:, LAUNCH)) & - * RD**2 / RCPD / H0**2 + (TT(:, LTROP ) & - - TT(:, LAUNCH))/(ZH(:, LTROP )- ZH(:, LAUNCH)) * RD / H0 - - UH(:, 1) = UH(:, 2) - UH(:, KLEV + 1) = UH(:, KLEV) - BV(:, 1) = UH(:, 2) - BV(:, KLEV + 1) = UH(:, KLEV) - ! SMOOTHING THE BV HELPS - DO LL = 2, KLEV - BV(:, LL)=(UH(:, LL+1)+2.*UH(:, LL)+UH(:, LL-1))/4. - end DO - - BV=MAX(SQRT(MAX(BV, 0.)), BVSEC) - BVLOW=MAX(SQRT(MAX(BVLOW, 0.)), BVSEC) - - - ! WINDS - DO LL = 2, KLEV - UH(:, LL) = 0.5 * (UU(:, LL) + UU(:, LL - 1)) ! Zonal wind - VH(:, LL) = 0.5 * (VV(:, LL) + VV(:, LL - 1)) ! Meridional wind - end DO - UH(:, 1) = 0. - VH(:, 1) = 0. - UH(:, KLEV + 1) = UU(:, KLEV) - VH(:, KLEV + 1) = VV(:, KLEV) - - ! 3 WAVES CHARACTERISTICS CHOSEN RANDOMLY AT THE LAUNCH ALTITUDE - - ! The mod functions of weird arguments are used to produce the - ! waves characteristics in an almost stochastic way - - DO JW = 1, NW - ! Angle - DO II = 1, KLON - ! Angle (0 or PI so far) - RAN_NUM_1=MOD(TT(II, JW) * 10., 1.) - RAN_NUM_2= MOD(TT(II, JW) * 100., 1.) - ZP(II, JW) = (SIGN(1., 0.5 - RAN_NUM_1) + 1.) & - * RPI / 2. - ! Horizontal wavenumber amplitude - ZK(II, JW) = KMIN + (KMAX - KMIN) *RAN_NUM_2 - ! Horizontal phase speed - CPHA = 0. - DO JJ = 1, NA - RAN_NUM_3=MOD(TT(II, JW+3*JJ)**2, 1.) - CPHA = CPHA + & - CMAX*2.*(RAN_NUM_3 -0.5)*SQRT(3.)/SQRT(NA*1.) - END DO - IF (CPHA.LT.0.) THEN - CPHA = -1.*CPHA - ZP(II, JW) = ZP(II, JW) + RPI - ENDIF - ! Absolute frequency is imposed - ZO(II, JW) = CPHA * ZK(II, JW) - ! Intrinsic frequency is imposed - ZO(II, JW) = ZO(II, JW) & - + ZK(II, JW) * COS(ZP(II, JW)) * UH(II, LAUNCH) & - + ZK(II, JW) * SIN(ZP(II, JW)) * VH(II, LAUNCH) - ! Momentum flux at launch lev - RUW0(II, JW) = RUWMAX - ENDDO - ENDDO - - ! 4. COMPUTE THE FLUXES - - ! 4.1 Vertical velocity at launching altitude to ensure - ! the correct value to the imposed fluxes. - - DO JW = 1, NW - - ! Evaluate intrinsic frequency at launching altitude: - ZOP(:,JW) = ZO(:, JW) & - - ZK(:, JW) * COS(ZP(:, JW)) * UH(:, LAUNCH) & - - ZK(:, JW) * SIN(ZP(:, JW)) * VH(:, LAUNCH) - - ! VERSION WITH CONVECTIVE SOURCE - - ! Vertical velocity at launch level, value to ensure the - ! imposed factor related to the convective forcing: - ! precipitations. - - ! tanh limitation to values above prmax: - WWP(:, JW) = RUW0(:, JW) & - * (RD / RCPD / H0 * RLVTT * PRMAX * TANH(PREC(:) / PRMAX))**2 - - ! Factor related to the characteristics of the waves: - WWP(:, JW) = WWP(:, JW) * ZK(:, JW)**3 / KMIN / BVLOW(:) & - / MAX(ABS(ZOP(:, JW)), ZOISEC)**3 - - ! Moderation by the depth of the source (dz here): - WWP(:, JW) = WWP(:, JW) & - * EXP(- BVLOW(:)**2 / MAX(ABS(ZOP(:, JW)), ZOISEC)**2 * ZK(:, JW)**2 & - * DZ**2) - - ! Put the stress in the right direction: - RUWP(:, JW) = ZOP(:, JW) / MAX(ABS(ZOP(:, JW)), ZOISEC)**2 & - * BV(:, LAUNCH) * COS(ZP(:, JW)) * WWP(:, JW)**2 - RVWP(:, JW) = ZOP(:, JW) / MAX(ABS(ZOP(:, JW)), ZOISEC)**2 & - * BV(:, LAUNCH) * SIN(ZP(:, JW)) * WWP(:, JW)**2 - end DO - - - ! 4.2 Uniform values below the launching altitude - - DO LL = 1, LAUNCH - RUW(:, LL) = 0 - RVW(:, LL) = 0 - DO JW = 1, NW - RUW(:, LL) = RUW(:, LL) + RUWP(:, JW) - RVW(:, LL) = RVW(:, LL) + RVWP(:, JW) - end DO - end DO - - ! 4.3 Loop over altitudes, with passage from one level to the next - ! done by i) conserving the EP flux, ii) dissipating a little, - ! iii) testing critical levels, and vi) testing the breaking. - - DO LL = LAUNCH, KLEV - 1 - ! Warning: all the physics is here (passage from one level - ! to the next) - DO JW = 1, NW - ZOM(:, JW) = ZOP(:,JW) - WWM(:, JW) = WWP(:, JW) - ! Intrinsic Frequency - ZOP(:, JW) = ZO(:, JW) - ZK(:, JW) * COS(ZP(:, JW)) * UH(:, LL + 1) & - - ZK(:, JW) * SIN(ZP(:, JW)) * VH(:, LL + 1) - - ! No breaking (Eq.6) - ! Dissipation (Eq. 8) - WWP(:, JW) = WWM(:, JW) * EXP(- 4. * RDISS * PR / (PH(:, LL + 1) & - + PH(:, LL)) * ((BV(:, LL + 1) + BV(:, LL)) / 2.)**3 & - / MAX(ABS(ZOP(:, JW) + ZOM(:, JW)) / 2., ZOISEC)**4 & - * ZK(:, JW)**3 * (ZH(:, LL + 1) - ZH(:, LL))) - - ! Critical levels (forced to zero if intrinsic frequency changes sign) - ! Saturation (Eq. 12) - WWP(:, JW) = min(WWP(:, JW), MAX(0., & - SIGN(1., ZOP(:, JW) * ZOM(:, JW))) * ABS(ZOP(:, JW))**3 & - / BV(:, LL + 1) * EXP(- ZH(:, LL + 1) / H0) * KMIN**2 & - * SAT**2 / ZK(:, JW)**4) - end DO - - ! Evaluate EP-flux from Eq. 7 and give the right orientation to - ! the stress - - DO JW = 1, NW - RUWP(:, JW) = SIGN(1., ZOP(:, JW))*COS(ZP(:, JW)) * WWP(:, JW) - RVWP(:, JW) = SIGN(1., ZOP(:, JW))*SIN(ZP(:, JW)) * WWP(:, JW) - end DO - - RUW(:, LL + 1) = 0. - RVW(:, LL + 1) = 0. - - DO JW = 1, NW - RUW(:, LL + 1) = RUW(:, LL + 1) + RUWP(:, JW) - RVW(:, LL + 1) = RVW(:, LL + 1) + RVWP(:, JW) - EAST_GWSTRESS(:, LL)=EAST_GWSTRESS(:, LL)+MAX(0.,RUWP(:, JW))/REAL(NW) - WEST_GWSTRESS(:, LL)=WEST_GWSTRESS(:, LL)+MIN(0.,RUWP(:, JW))/REAL(NW) - end DO - end DO -! OFFLINE ONLY -! PRINT *,'SAT PROFILE:' -! DO LL=1,KLEV -! PRINT *,ZH(KLON/2,LL)/1000.,SAT*(2.+TANH(ZH(KLON/2,LL)/H0-8.)) -! ENDDO - - ! 5 CALCUL DES TENDANCES: - - ! 5.1 Rectification des flux au sommet et dans les basses couches - - RUW(:, KLEV + 1) = 0. - RVW(:, KLEV + 1) = 0. - RUW(:, 1) = RUW(:, LAUNCH) - RVW(:, 1) = RVW(:, LAUNCH) - DO LL = 1, LAUNCH - RUW(:, LL) = RUW(:, LAUNCH+1) - RVW(:, LL) = RVW(:, LAUNCH+1) - EAST_GWSTRESS(:, LL) = EAST_GWSTRESS(:, LAUNCH) - WEST_GWSTRESS(:, LL) = WEST_GWSTRESS(:, LAUNCH) - end DO - - ! AR-1 RECURSIVE FORMULA (13) IN VERSION 4 - DO LL = 1, KLEV - D_U(:, LL) = (1.-DTIME/DELTAT) * D_U(:, LL) + DTIME/DELTAT/REAL(NW) * & - RG * (RUW(:, LL + 1) - RUW(:, LL)) & - / (PH(:, LL + 1) - PH(:, LL)) * DTIME - ! NO AR-1 FOR MERIDIONAL TENDENCIES - D_V(:, LL) = 1./REAL(NW) * & - RG * (RVW(:, LL + 1) - RVW(:, LL)) & - / (PH(:, LL + 1) - PH(:, LL)) * DTIME - ENDDO - - ! Cosmetic: evaluation of the cumulated stress - ZUSTR = 0. - ZVSTR = 0. - DO LL = 1, KLEV - ZUSTR = ZUSTR + D_U(:, LL) / RG * (PH(:, LL + 1) - PH(:, LL))/DTIME - ZVSTR = ZVSTR + D_V(:, LL) / RG * (PH(:, LL + 1) - PH(:, LL))/DTIME - ENDDO - - - END SUBROUTINE FLOTT_GWD_RANDO - -end module FLOTT_GWD_rando_m Index: LMDZ6/trunk/libf/phylmd/freinage.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/freinage.f90 (revision 6047) +++ (revision ) @@ -1,153 +1,0 @@ -MODULE freinage_mod -! -! $Id$ -! - -CONTAINS - - SUBROUTINE freinage(klon, knon, uu, vv, & - tt,veget,lai, height,ypaprs,ypplay,drag_pro,d_u,d_v) -!$gpum horizontal knon klon - - !ONLINE: -USE yoegwd_mod_h - USE dimpft_mod_h - USE compbl_mod_h - USE clesphys_mod_h - use dimphy, only: klev -! USE control, ONLY: nvm -! USE indice_sol_mod, only : nvm_orch - - USE yomcst_mod_h -IMPLICIT NONE - - - -!FC - - ! 0. DECLARATIONS: - - ! 0.1 INPUTS - - REAL, DIMENSION(klon,klev), INTENT(IN) :: ypplay - REAL, DIMENSION(klon,klev+1), INTENT(IN) :: ypaprs - - - REAL, DIMENSION(klon, klev), INTENT(IN) :: uu - REAL, DIMENSION(klon, klev), INTENT(IN) :: vv - REAL, DIMENSION(klon, klev), INTENT(IN) :: tt - REAL, DIMENSION(klon,nvm_lmdz), INTENT(IN) :: veget,lai - REAL, DIMENSION(klon,nvm_lmdz), INTENT(IN) :: height - - REAL, DIMENSION(klon,klev) :: wind - REAL, DIMENSION(klon, klev) :: yzlay - INTEGER klon, knon - - ! 0.2 OUTPUTS - - REAL, DIMENSION(klon, klev), INTENT(OUT) :: d_v ! change in v - REAL, DIMENSION(klon, klev), INTENT(OUT) :: d_u ! change in v - !knon nombre de points concernes - REAL, DIMENSION(klon,klev) :: sumveg ! change in v - - REAL, DIMENSION(klon,klev), INTENT(OUT) :: drag_pro - ! (KLON, KLEV) tendencies on winds - - - INTEGER k,jv,i - - -!FCCCC REAL Cd_frein - - ! 0.3.1 LOCAL VARIABLE - - - !----------------------------------------------------------------- - - ! 1. INITIALISATIONS - - -! Cd_frein = 7.5E-2 ! (0.075) ! Drag from MASSON 2009 -!FC ESSAI -! Cd_frein = 1.5E-2 ! (0.075) ! Drag from MASSON 2009 -! Cd_frein = 0.005 ! (0.075) ! Drag from MASSON 2009 - -! initialisation - d_u(:,:) =0. - d_v(:,:) =0. - drag_pro(:,:) =0. - sumveg(:,:) =0. -!! print*, "Cd_frein" , Cd_frein - - wind(:,:)= sqrt(uu(:,:)*uu(:,:)+vv(:,:)*vv(:,:)) - - yzlay(1:knon,1)= & - RD*tt(1:knon,1)/(0.5*(ypaprs(1:knon,1)+ypplay(1:knon,1))) & - *(ypaprs(1:knon,1)-ypplay(1:knon,1))/RG - DO k=2,klev - yzlay(1:knon,k)= & - yzlay(1:knon,k-1)+RD*0.5*(tt(1:knon,k-1)+tt(1:knon,k)) & - /ypaprs(1:knon,k)*(ypplay(1:knon,k-1)-ypplay(1:knon,k))/RG - END DO - -! verifier les indexes ..... -!! print*, " calcul de drag_pro FC " - - do k= 1,klev - - do jv=2,nvm_lmdz ! (on peut faire 9 ?) - - do i=1,knon - - sumveg(i,k)= sumveg(i,k)+ veget(i,jv) - -! if ( (height(i,jv) .gt. yzlay(i,k)) .AND. (height(i,jv) .gt. 0.1) .and. LAI(i,jv).gt.0. ) then - if ( (height(i,jv) .gt. yzlay(i,k)) .AND. (height(i,jv) .gt. 0.1) ) then -!FC attention veut on le test sur le LAI ? - if (ifl_pbltree.eq.1) then - drag_pro(i,k)= drag_pro(i,k)+ & - veget(i,jv) - elseif (ifl_pbltree.eq.2) then - drag_pro(i,k)= drag_pro(i,k)+ & - 6*LAI(i,jv)*veget(i,jv)*( yzlay(i,k)*(height(i,jv)-yzlay(i,k))/(height(i,jv)*height(i,jv)+ 0.01)) - elseif (ifl_pbltree.eq.3) then - drag_pro(i,k)= drag_pro(i,k)+ & - veget(i,jv)*( yzlay(i,k)*(height(i,jv)-yzlay(i,k))/(height(i,jv)*height(i,jv)+ 0.01)) - elseif (ifl_pbltree.eq.0) then - drag_pro(i,k)=0.0 - endif - else - drag_pro(i,k)= drag_pro(i,k) - endif - - - enddo - enddo - enddo - - do k=1,klev - -!ym where are not correctly supported by gpumorphosis switch to LOOP, IF/ENDIF -!ym where (sumveg(1:knon,k) > 0.05 ) -!ym ! drag_pro(1:knon,k)=Cd_frein*drag_pro(1:knon,k)/sumveg(1:knon,k) -!ym drag_pro(1:knon,k)=Cd_frein*drag_pro(1:knon,k) -!ym elsewhere -!ym drag_pro(1:knon,k)=0.0 -!ym endwhere - - DO i=1,knon - IF (sumveg(i,k) > 0.05) THEN - drag_pro(i,k)=Cd_frein*drag_pro(i,k) - ELSE - drag_pro(i,k)=0.0 - ENDIF - ENDDO - d_u(1:knon,k) =(-1)*drag_pro(1:knon,k)*uu(1:knon,k)*wind(1:knon,k) - d_v(1:knon,k) =(-1)*drag_pro(1:knon,k)*vv(1:knon,k)*wind(1:knon,k) - enddo - return - - END SUBROUTINE freinage - -END MODULE freinage_mod - Index: LMDZ6/trunk/libf/phylmd/freinage_mod.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/freinage_mod.f90 (revision 6048) +++ LMDZ6/trunk/libf/phylmd/freinage_mod.f90 (revision 6048) @@ -0,0 +1,153 @@ +MODULE freinage_mod +! +! $Id$ +! + +CONTAINS + + SUBROUTINE freinage(klon, knon, uu, vv, & + tt,veget,lai, height,ypaprs,ypplay,drag_pro,d_u,d_v) +!$gpum horizontal knon klon + + !ONLINE: +USE yoegwd_mod_h + USE dimpft_mod_h + USE compbl_mod_h + USE clesphys_mod_h + use dimphy, only: klev +! USE control, ONLY: nvm +! USE indice_sol_mod, only : nvm_orch + + USE yomcst_mod_h +IMPLICIT NONE + + + +!FC + + ! 0. DECLARATIONS: + + ! 0.1 INPUTS + + REAL, DIMENSION(klon,klev), INTENT(IN) :: ypplay + REAL, DIMENSION(klon,klev+1), INTENT(IN) :: ypaprs + + + REAL, DIMENSION(klon, klev), INTENT(IN) :: uu + REAL, DIMENSION(klon, klev), INTENT(IN) :: vv + REAL, DIMENSION(klon, klev), INTENT(IN) :: tt + REAL, DIMENSION(klon,nvm_lmdz), INTENT(IN) :: veget,lai + REAL, DIMENSION(klon,nvm_lmdz), INTENT(IN) :: height + + REAL, DIMENSION(klon,klev) :: wind + REAL, DIMENSION(klon, klev) :: yzlay + INTEGER klon, knon + + ! 0.2 OUTPUTS + + REAL, DIMENSION(klon, klev), INTENT(OUT) :: d_v ! change in v + REAL, DIMENSION(klon, klev), INTENT(OUT) :: d_u ! change in v + !knon nombre de points concernes + REAL, DIMENSION(klon,klev) :: sumveg ! change in v + + REAL, DIMENSION(klon,klev), INTENT(OUT) :: drag_pro + ! (KLON, KLEV) tendencies on winds + + + INTEGER k,jv,i + + +!FCCCC REAL Cd_frein + + ! 0.3.1 LOCAL VARIABLE + + + !----------------------------------------------------------------- + + ! 1. INITIALISATIONS + + +! Cd_frein = 7.5E-2 ! (0.075) ! Drag from MASSON 2009 +!FC ESSAI +! Cd_frein = 1.5E-2 ! (0.075) ! Drag from MASSON 2009 +! Cd_frein = 0.005 ! (0.075) ! Drag from MASSON 2009 + +! initialisation + d_u(:,:) =0. + d_v(:,:) =0. + drag_pro(:,:) =0. + sumveg(:,:) =0. +!! print*, "Cd_frein" , Cd_frein + + wind(:,:)= sqrt(uu(:,:)*uu(:,:)+vv(:,:)*vv(:,:)) + + yzlay(1:knon,1)= & + RD*tt(1:knon,1)/(0.5*(ypaprs(1:knon,1)+ypplay(1:knon,1))) & + *(ypaprs(1:knon,1)-ypplay(1:knon,1))/RG + DO k=2,klev + yzlay(1:knon,k)= & + yzlay(1:knon,k-1)+RD*0.5*(tt(1:knon,k-1)+tt(1:knon,k)) & + /ypaprs(1:knon,k)*(ypplay(1:knon,k-1)-ypplay(1:knon,k))/RG + END DO + +! verifier les indexes ..... +!! print*, " calcul de drag_pro FC " + + do k= 1,klev + + do jv=2,nvm_lmdz ! (on peut faire 9 ?) + + do i=1,knon + + sumveg(i,k)= sumveg(i,k)+ veget(i,jv) + +! if ( (height(i,jv) .gt. yzlay(i,k)) .AND. (height(i,jv) .gt. 0.1) .and. LAI(i,jv).gt.0. ) then + if ( (height(i,jv) .gt. yzlay(i,k)) .AND. (height(i,jv) .gt. 0.1) ) then +!FC attention veut on le test sur le LAI ? + if (ifl_pbltree.eq.1) then + drag_pro(i,k)= drag_pro(i,k)+ & + veget(i,jv) + elseif (ifl_pbltree.eq.2) then + drag_pro(i,k)= drag_pro(i,k)+ & + 6*LAI(i,jv)*veget(i,jv)*( yzlay(i,k)*(height(i,jv)-yzlay(i,k))/(height(i,jv)*height(i,jv)+ 0.01)) + elseif (ifl_pbltree.eq.3) then + drag_pro(i,k)= drag_pro(i,k)+ & + veget(i,jv)*( yzlay(i,k)*(height(i,jv)-yzlay(i,k))/(height(i,jv)*height(i,jv)+ 0.01)) + elseif (ifl_pbltree.eq.0) then + drag_pro(i,k)=0.0 + endif + else + drag_pro(i,k)= drag_pro(i,k) + endif + + + enddo + enddo + enddo + + do k=1,klev + +!ym where are not correctly supported by gpumorphosis switch to LOOP, IF/ENDIF +!ym where (sumveg(1:knon,k) > 0.05 ) +!ym ! drag_pro(1:knon,k)=Cd_frein*drag_pro(1:knon,k)/sumveg(1:knon,k) +!ym drag_pro(1:knon,k)=Cd_frein*drag_pro(1:knon,k) +!ym elsewhere +!ym drag_pro(1:knon,k)=0.0 +!ym endwhere + + DO i=1,knon + IF (sumveg(i,k) > 0.05) THEN + drag_pro(i,k)=Cd_frein*drag_pro(i,k) + ELSE + drag_pro(i,k)=0.0 + ENDIF + ENDDO + d_u(1:knon,k) =(-1)*drag_pro(1:knon,k)*uu(1:knon,k)*wind(1:knon,k) + d_v(1:knon,k) =(-1)*drag_pro(1:knon,k)*vv(1:knon,k)*wind(1:knon,k) + enddo + return + + END SUBROUTINE freinage + +END MODULE freinage_mod + Index: LMDZ6/trunk/libf/phylmd/frequences_LW_data.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/frequences_LW_data.F90 (revision 6047) +++ LMDZ6/trunk/libf/phylmd/frequences_LW_data.F90 (revision 6048) @@ -1,4 +1,4 @@ -MODULE FREQUENCES_LW_DATA +MODULE frequences_LW_data USE AERO_MOD, ONLY : nbands_lw_rrtm !FC @@ -18,4 +18,4 @@ ! print*, ILW,deltanu(ilw) ! enddo -END MODULE FREQUENCES_LW_DATA +END MODULE frequences_LW_data Index: LMDZ6/trunk/libf/phylmd/m_simu_airs.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/m_simu_airs.f90 (revision 6048) +++ LMDZ6/trunk/libf/phylmd/m_simu_airs.f90 (revision 6048) @@ -0,0 +1,1307 @@ + + module m_simu_airs + + USE print_control_mod, ONLY: prt_level,lunout + + implicit none + + REAL, PARAMETER :: tau_thresh = 0.05 ! seuil nuages detectables + REAL, PARAMETER :: p_thresh = 445. ! seuil nuages hauts + REAL, PARAMETER :: em_min = 0.2 ! seuils nuages semi-transp + REAL, PARAMETER :: em_max = 0.85 + REAL, PARAMETER :: undef = 999. + + contains + + REAL function search_tropopause(P,T,alt,N) result(P_tropo) +! this function searches for the tropopause pressure in [hPa]. +! The search is based on ideology described in +! Reichler et al., Determining the tropopause height from gridded data, +! GRL, 30(20) 2042, doi:10.1029/2003GL018240, 2003 + + INTEGER N,i,i_lev,first_point,exit_flag,i_dir + REAL P(N),T(N),alt(N),slope(N) + REAL P_min, P_max, slope_limit,slope_2km, & + & delta_alt_limit,tmp,delta_alt + PARAMETER(P_min=75.0, P_max=470.0) ! hPa + PARAMETER(slope_limit=0.002) ! 2 K/km converted to K/m + PARAMETER(delta_alt_limit=2000.0) ! 2000 meters + + do i=1,N-1 + slope(i)=-(T(i+1)-T(i))/(alt(i+1)-alt(i)) + end do + slope(N)=slope(N-1) + + if (P(1).gt.P(N)) then + i_dir= 1 + i=1 + else + i_dir=-1 + i=N + end if + + first_point=0 + exit_flag=0 + do while(exit_flag.eq.0) + if (P(i).ge.P_min.and.P(i).le.P_max) then + if (first_point.gt.0) then + delta_alt=alt(i)-alt(first_point) + if (delta_alt.ge.delta_alt_limit) then + slope_2km=(T(first_point)-T(i))/delta_alt + if (slope_2km.lt.slope_limit) then + exit_flag=1 + else + first_point=0 + end if + end if + end if + if (first_point.eq.0.and.slope(i).lt.slope_limit) first_point=i + end if + i=i+i_dir + if (i.le.1.or.i.ge.N) exit_flag=1 + end do + + if (first_point.le.0) P_tropo=65.4321 + if (first_point.eq.1) P_tropo=64.5432 + if (first_point.gt.1) then + tmp=(slope_limit-slope(first_point))/(slope(first_point+1)- & + & slope(first_point))*(P(first_point+1)-P(first_point)) + P_tropo=P(first_point)+tmp + ! print*, 'P_tropo= ', tmp, P(first_point), P_tropo + end if + +! Ajout Marine + if (P_tropo .lt. 60. .or. P_tropo .gt. 470.) then + P_tropo = 999. + endif + + return + end function search_tropopause + + + + subroutine cloud_structure(len_cs, rneb_cs, temp_cs, & + & emis_cs, iwco_cs, & + & pres_cs, dz_cs, rhodz_cs, rad_cs, & + & cc_tot_cs, cc_hc_cs, cc_hist_cs, & + & cc_Cb_cs, cc_ThCi_cs, cc_Anv_cs, & + & pcld_hc_cs, tcld_hc_cs, & + & em_hc_cs, iwp_hc_cs, deltaz_hc_cs, & + & pcld_Cb_cs, tcld_Cb_cs, em_Cb_cs, & + & pcld_ThCi_cs, tcld_ThCi_cs, em_ThCi_cs, & + & pcld_Anv_cs, tcld_Anv_cs, em_Anv_cs, & + & em_hist_cs, iwp_hist_cs, deltaz_hist_cs, rad_hist_cs) + + + + INTEGER :: i, n, nss + + INTEGER, intent(in) :: len_cs + REAL, DIMENSION(:), intent(in) :: rneb_cs, temp_cs + REAL, DIMENSION(:), intent(in) :: emis_cs, iwco_cs, rad_cs + REAL, DIMENSION(:), intent(in) :: pres_cs, dz_cs, rhodz_cs + + REAL, intent(out) :: cc_tot_cs, cc_hc_cs, cc_hist_cs, & + & cc_Cb_cs, cc_ThCi_cs, cc_Anv_cs, & + & pcld_hc_cs, tcld_hc_cs, em_hc_cs, iwp_hc_cs, & + & pcld_Cb_cs, tcld_Cb_cs, em_Cb_cs, & + & pcld_ThCi_cs, tcld_ThCi_cs, em_ThCi_cs, & + & pcld_Anv_cs, tcld_Anv_cs, em_Anv_cs, & + & em_hist_cs, iwp_hist_cs, & + & deltaz_hc_cs, deltaz_hist_cs, rad_hist_cs + + REAL, DIMENSION(len_cs) :: rneb_ord + REAL :: rneb_min + + REAL, DIMENSION(:), allocatable :: s, s_hc, s_hist, rneb_max + REAL, DIMENSION(:), allocatable :: sCb, sThCi, sAnv + REAL, DIMENSION(:), allocatable :: iwp_ss, pcld_ss, tcld_ss,& + & emis_ss + REAL, DIMENSION(:), allocatable :: deltaz_ss, rad_ss + + CHARACTER (len = 50) :: modname = 'simu_airs.cloud_structure' + CHARACTER (len = 160) :: abort_message + + + write(lunout,*) 'dans cloud_structure' + + call ordonne(len_cs, rneb_cs, rneb_ord) + + +! Definition des sous_sections + + rneb_min = rneb_ord(1) + nss = 1 + + do i = 2, size(rneb_cs) + if (rneb_ord(i) .gt. rneb_min) then + nss = nss+1 + rneb_min = rneb_ord(i) + endif + enddo + + allocate (s(nss)) + allocate (s_hc(nss)) + allocate (s_hist(nss)) + allocate (rneb_max(nss)) + allocate (emis_ss(nss)) + allocate (pcld_ss(nss)) + allocate (tcld_ss(nss)) + allocate (iwp_ss(nss)) + allocate (deltaz_ss(nss)) + allocate (rad_ss(nss)) + allocate (sCb(nss)) + allocate (sThCi(nss)) + allocate (sAnv(nss)) + + rneb_min = rneb_ord(1) + n = 1 + s(1) = rneb_ord(1) + s_hc(1) = rneb_ord(1) + s_hist(1) = rneb_ord(1) + sCb(1) = rneb_ord(1) + sThCi(1) = rneb_ord(1) + sAnv(1) = rneb_ord(1) + + rneb_max(1) = rneb_ord(1) + + do i = 2, size(rneb_cs) + if (rneb_ord(i) .gt. rneb_min) then + n = n+1 + s(n) = rneb_ord(i)-rneb_min + s_hc(n) = rneb_ord(i)-rneb_min + s_hist(n) = rneb_ord(i)-rneb_min + sCb(n) = rneb_ord(i)-rneb_min + sThCi(n) = rneb_ord(i)-rneb_min + sAnv(n) = rneb_ord(i)-rneb_min + + rneb_max(n) = rneb_ord(i) + rneb_min = rneb_ord(i) + endif + enddo + +! Appel de sous_section + + do i = 1, nss + call sous_section(len_cs, rneb_cs, temp_cs, & + & emis_cs, iwco_cs, & + & pres_cs, dz_cs, rhodz_cs, rad_cs, rneb_ord, & + & rneb_max(i),s(i),s_hc(i),s_hist(i), & + & sCb(i), sThCi(i), sAnv(i), & + & emis_ss(i), & + & pcld_ss(i), tcld_ss(i), iwp_ss(i), deltaz_ss(i), rad_ss(i)) + enddo + +! Caracteristiques de la structure nuageuse + + cc_tot_cs = 0. + cc_hc_cs = 0. + cc_hist_cs = 0. + + cc_Cb_cs = 0. + cc_ThCi_cs = 0. + cc_Anv_cs = 0. + + em_hc_cs = 0. + iwp_hc_cs = 0. + deltaz_hc_cs = 0. + + em_hist_cs = 0. + iwp_hist_cs = 0. + deltaz_hist_cs = 0. + rad_hist_cs = 0. + + pcld_hc_cs = 0. + tcld_hc_cs = 0. + + pcld_Cb_cs = 0. + tcld_Cb_cs = 0. + em_Cb_cs = 0. + + pcld_ThCi_cs = 0. + tcld_ThCi_cs = 0. + em_ThCi_cs = 0. + + pcld_Anv_cs = 0. + tcld_Anv_cs = 0. + em_Anv_cs = 0. + + do i = 1, nss + + cc_tot_cs = cc_tot_cs + s(i) + cc_hc_cs = cc_hc_cs + s_hc(i) + cc_hist_cs = cc_hist_cs + s_hist(i) + + cc_Cb_cs = cc_Cb_cs + sCb(i) + cc_ThCi_cs = cc_ThCi_cs + sThCi(i) + cc_Anv_cs = cc_Anv_cs + sAnv(i) + + iwp_hc_cs = iwp_hc_cs + s_hc(i)*iwp_ss(i) + em_hc_cs = em_hc_cs + s_hc(i)*emis_ss(i) + deltaz_hc_cs = deltaz_hc_cs + s_hc(i)*deltaz_ss(i) + + iwp_hist_cs = iwp_hist_cs + s_hist(i)*iwp_ss(i) + em_hist_cs = em_hist_cs + s_hist(i)*emis_ss(i) + deltaz_hist_cs = deltaz_hist_cs + s_hist(i)*deltaz_ss(i) + rad_hist_cs = rad_hist_cs + s_hist(i)*rad_ss(i) + + pcld_hc_cs = pcld_hc_cs + s_hc(i)*pcld_ss(i) + tcld_hc_cs = tcld_hc_cs + s_hc(i)*tcld_ss(i) + + pcld_Cb_cs = pcld_Cb_cs + sCb(i)*pcld_ss(i) + tcld_Cb_cs = tcld_Cb_cs + sCb(i)*tcld_ss(i) + em_Cb_cs = em_Cb_cs + sCb(i)*emis_ss(i) + + pcld_ThCi_cs = pcld_ThCi_cs + sThCi(i)*pcld_ss(i) + tcld_ThCi_cs = tcld_ThCi_cs + sThCi(i)*tcld_ss(i) + em_ThCi_cs = em_ThCi_cs + sThCi(i)*emis_ss(i) + + pcld_Anv_cs = pcld_Anv_cs + sAnv(i)*pcld_ss(i) + tcld_Anv_cs = tcld_Anv_cs + sAnv(i)*tcld_ss(i) + em_Anv_cs = em_Anv_cs + sAnv(i)*emis_ss(i) + + enddo + + deallocate(s) + deallocate (s_hc) + deallocate (s_hist) + deallocate (rneb_max) + deallocate (emis_ss) + deallocate (pcld_ss) + deallocate (tcld_ss) + deallocate (iwp_ss) + deallocate (deltaz_ss) + deallocate (rad_ss) + deallocate (sCb) + deallocate (sThCi) + deallocate (sAnv) + + call normal_undef(pcld_hc_cs,cc_hc_cs) + call normal_undef(tcld_hc_cs,cc_hc_cs) + call normal_undef(iwp_hc_cs,cc_hc_cs) + call normal_undef(em_hc_cs,cc_hc_cs) + call normal_undef(deltaz_hc_cs,cc_hc_cs) + + call normal_undef(iwp_hist_cs,cc_hist_cs) + call normal_undef(em_hist_cs,cc_hist_cs) + call normal_undef(deltaz_hist_cs,cc_hist_cs) + call normal_undef(rad_hist_cs,cc_hist_cs) + + call normal_undef(pcld_Cb_cs,cc_Cb_cs) + call normal_undef(tcld_Cb_cs,cc_Cb_cs) + call normal_undef(em_Cb_cs,cc_Cb_cs) + + call normal_undef(pcld_ThCi_cs,cc_ThCi_cs) + call normal_undef(tcld_ThCi_cs,cc_ThCi_cs) + call normal_undef(em_ThCi_cs,cc_ThCi_cs) + + call normal_undef(pcld_Anv_cs,cc_Anv_cs) + call normal_undef(tcld_Anv_cs,cc_Anv_cs) + call normal_undef(em_Anv_cs,cc_Anv_cs) + + +! Tests + + if (cc_tot_cs .gt. maxval(rneb_cs) .and. & + & abs(cc_tot_cs-maxval(rneb_cs)) .gt. 1.e-4 ) then + WRITE(abort_message,*) 'cc_tot_cs > max rneb_cs', cc_tot_cs, maxval(rneb_cs) + CALL abort_physic(modname,abort_message,1) + endif + + if (iwp_hc_cs .lt. 0.) then + abort_message= 'cloud_structure: iwp_hc_cs < 0' + CALL abort_physic(modname,abort_message,1) + endif + + end subroutine cloud_structure + + + subroutine normal_undef(num, den) + + REAL, intent(in) :: den + REAL, intent(inout) :: num + + if (den .ne. 0) then + num = num/den + else + num = undef + endif + + end subroutine normal_undef + + + subroutine normal2_undef(res,num,den) + + REAL, intent(in) :: den + REAL, intent(in) :: num + REAL, intent(out) :: res + + if (den .ne. 0.) then + res = num/den + else + res = undef + endif + + end subroutine normal2_undef + + + subroutine sous_section(len_cs, rneb_cs, temp_cs, & + & emis_cs, iwco_cs, & + & pres_cs, dz_cs, rhodz_cs, rad_cs, rneb_ord, & + & rnebmax, stot, shc, shist, & + & sCb, sThCi, sAnv, & + & emis, pcld, tcld, iwp, deltaz, rad) + + INTEGER, intent(in) :: len_cs + REAL, DIMENSION(len_cs), intent(in) :: rneb_cs, temp_cs + REAL, DIMENSION(len_cs), intent(in) :: emis_cs, iwco_cs, & + & rneb_ord + REAL, DIMENSION(len_cs), intent(in) :: pres_cs, dz_cs, rad_cs + REAL, DIMENSION(len_cs), intent(in) :: rhodz_cs + REAL, DIMENSION(len_cs) :: tau_cs, w + REAL, intent(in) :: rnebmax + REAL, intent(inout) :: stot, shc, shist + REAL, intent(inout) :: sCb, sThCi, sAnv + REAL, intent(out) :: emis, pcld, tcld, iwp, deltaz, rad + + INTEGER :: i, ideb, ibeg, iend, nuage, visible + REAL :: som, som_tau, som_iwc, som_dz, som_rad, tau + + CHARACTER (len = 50) :: modname = 'simu_airs.sous_section' + CHARACTER (len = 160) :: abort_message + + +! Ponderation: 1 pour les nuages, 0 pour les trous + + do i = 1, len_cs + if (rneb_cs(i) .ge. rnebmax) then + w(i) = 1. + else + w(i) = 0. + endif + enddo + +! Calcul des epaisseurs optiques a partir des emissivites + + som = 0. + do i = 1, len_cs + if (emis_cs(i) .eq. 1.) then + tau_cs(i) = 10. + else + tau_cs(i) = -log(1.-emis_cs(i)) + endif + som = som+tau_cs(i) + enddo + + + ideb = 1 + nuage = 0 + visible = 0 + + +! Boucle sur les nuages + do while (ideb .ne. 0 .and. ideb .le. len_cs) + + +! Definition d'un nuage de la sous-section + + call topbot(ideb, w, ibeg, iend) + ideb = iend+1 + + if (ibeg .gt. 0) then + + nuage = nuage + 1 + +! On determine les caracteristiques du nuage +! (ep. optique, ice water path, pression, temperature) + + call caract(ibeg, iend, temp_cs, tau_cs, iwco_cs, & + & pres_cs, dz_cs, rhodz_cs, rad_cs, pcld, tcld, & + & som_tau, som_iwc, som_dz, som_rad) + +! On masque le nuage s'il n'est pas detectable + + call masque(ibeg, iend, som_tau, visible, w) + + endif + +! Fin boucle nuages + enddo + + +! Analyse du nuage detecte + + call topbot(1, w, ibeg, iend) + + if (ibeg .gt. 0) then + + call caract(ibeg, iend, temp_cs, tau_cs, iwco_cs, & + & pres_cs, dz_cs, rhodz_cs, rad_cs, pcld, tcld, & + & som_tau, som_iwc, som_dz, som_rad) + + tau = som_tau + emis = 1. - exp(-tau) + iwp = som_iwc + deltaz = som_dz + rad = som_rad + + if (pcld .gt. p_thresh) then + + shc = 0. + shist = 0. + sCb = 0. + sThCi = 0. + sAnv = 0. + + else + + if (emis .lt. em_min .or. emis .gt. em_max & + & .or. tcld .gt. 230.) then + shist = 0. + endif + + if (emis .lt. 0.98) then + sCb = 0. + endif + + if (emis .gt. 0.5 .or. emis .lt. 0.1) then + sThCi = 0. + endif + + if (emis .le. 0.5 .or. emis .ge. 0.98) then + sAnv = 0. + endif + + endif + + else + + tau = 0. + emis = 0. + iwp = 0. + deltaz = 0. + pcld = 0. + tcld = 0. + stot = 0. + shc = 0. + shist = 0. + rad = 0. + sCb = 0. + sThCi = 0. + sAnv = 0. + + endif + + +! Tests + + if (iwp .lt. 0.) then + WRITE(abort_message,*) 'ideb iwp =', ideb, iwp + CALL abort_physic(modname,abort_message,1) + endif + + if (deltaz .lt. 0.) then + WRITE(abort_message,*)'ideb deltaz =', ideb, deltaz + CALL abort_physic(modname,abort_message,1) + endif + + if (emis .lt. 0.048 .and. emis .ne. 0.) then + WRITE(abort_message,*) 'ideb emis =', ideb, emis + CALL abort_physic(modname,abort_message,1) + endif + + end subroutine sous_section + + + subroutine masque (ibeg, iend, som_tau, & + & visible, w) + + INTEGER, intent(in) :: ibeg, iend + REAL, intent(in) :: som_tau + + INTEGER, intent(inout) :: visible + REAL, DIMENSION(:), intent(inout) :: w + + INTEGER :: i + + + +! Masque + +! Cas ou il n'y a pas de nuage visible au-dessus + + if (visible .eq. 0) then + + if (som_tau .lt. tau_thresh) then + do i = ibeg, iend + w(i) = 0. + enddo + else + visible = 1 + endif + +! Cas ou il y a un nuage visible au-dessus + + else + + do i = ibeg, iend + w(i) = 0. + enddo + + endif + + + end subroutine masque + + + subroutine caract (ibeg, iend, temp_cs, tau_cs, iwco_cs, & + & pres_cs, dz_cs, rhodz_cs, rad_cs, pcld, tcld, & + & som_tau, som_iwc, som_dz, som_rad) + + INTEGER, intent(in) :: ibeg, iend + REAL, DIMENSION(:), intent(in) :: tau_cs, iwco_cs, temp_cs + REAL, DIMENSION(:), intent(in) :: pres_cs, dz_cs, rad_cs + REAL, DIMENSION(:), intent(in) :: rhodz_cs + REAL, intent(out) :: som_tau, som_iwc, som_dz, som_rad + REAL , intent(out) :: pcld, tcld + + INTEGER :: i, ibase, imid + + CHARACTER (len = 50) :: modname = 'simu_airs.caract' + CHARACTER (len = 160) :: abort_message + +! Somme des epaisseurs optiques et des contenus en glace sur le nuage + + som_tau = 0. + som_iwc = 0. + som_dz = 0. + som_rad = 0. + ibase = -100 + + do i = ibeg, iend + + som_tau = som_tau + tau_cs(i) + + som_dz = som_dz + dz_cs(i) + som_iwc = som_iwc + iwco_cs(i)*1000*rhodz_cs(i) ! en g/m2 + som_rad = som_rad + rad_cs(i)*dz_cs(i) + + if (som_tau .gt. 3. .and. ibase .eq. -100) then + ibase = i-1 + endif + + enddo + + if (som_dz .ne. 0.) then + som_rad = som_rad/som_dz + else + write(*,*) 'som_dez = 0 STOP' + write(*,*) 'ibeg, iend =', ibeg, iend + do i = ibeg, iend + write(*,*) dz_cs(i), rhodz_cs(i) + enddo + abort_message='see above' + CALL abort_physic(modname,abort_message,1) + endif + +! Determination de Pcld et Tcld + + if (ibase .lt. ibeg) then + ibase = ibeg + endif + + imid = (ibeg+ibase)/2 + + pcld = pres_cs(imid)/100. ! pcld en hPa + tcld = temp_cs(imid) + + + end subroutine caract + + subroutine topbot(ideb,w,ibeg,iend) + + INTEGER, intent(in) :: ideb + REAL, DIMENSION(:), intent(in) :: w + INTEGER, intent(out) :: ibeg, iend + + INTEGER :: i, itest + + itest = 0 + ibeg = 0 + iend = 0 + + do i = ideb, size(w) + + if (w(i) .eq. 1. .and. itest .eq. 0) then + ibeg = i + itest = 1 + endif + + enddo + + + i = ibeg + do while (w(i) .eq. 1. .and. i .le. size(w)) + i = i+1 + enddo + iend = i-1 + + + end subroutine topbot + + subroutine ordonne(len_cs, rneb_cs, rneb_ord) + + INTEGER, intent(in) :: len_cs + REAL, DIMENSION(:), intent(in) :: rneb_cs + REAL, DIMENSION(:), intent(out) :: rneb_ord + + INTEGER :: i, j, ind_min + + REAL, DIMENSION(len_cs) :: rneb + REAL :: rneb_max + + + do i = 1, size(rneb_cs) + rneb(i) = rneb_cs(i) + enddo + + do j = 1, size(rneb_cs) + + rneb_max = 100. + + do i = 1, size(rneb_cs) + if (rneb(i) .lt. rneb_max) then + rneb_max = rneb(i) + ind_min = i + endif + enddo + + rneb_ord(j) = rneb_max + rneb(ind_min) = 100. + + enddo + + end subroutine ordonne + + + subroutine sim_mesh(rneb_1D, temp_1D, emis_1D, & + & iwcon_1D, rad_1D, & + & pres, dz, & + & rhodz_1D, cc_tot_mesh, cc_hc_mesh, cc_hist_mesh, pcld_hc_mesh,& + & tcld_hc_mesh, & + & em_hc_mesh, iwp_hc_mesh, deltaz_hc_mesh, & + & cc_Cb_mesh, cc_ThCi_mesh, cc_Anv_mesh, & + & pcld_Cb_mesh, tcld_Cb_mesh, em_Cb_mesh, & + & pcld_ThCi_mesh, tcld_ThCi_mesh, em_ThCi_mesh, & + & pcld_Anv_mesh, tcld_Anv_mesh, em_Anv_mesh, & + & em_hist_mesh, iwp_hist_mesh, deltaz_hist_mesh, rad_hist_mesh) + + USE dimphy + + REAL, DIMENSION(klev), intent(in) :: rneb_1D, temp_1D, emis_1D, & + & iwcon_1D, rad_1D + REAL, DIMENSION(klev), intent(in) :: pres, dz, rhodz_1D + REAL, intent(out) :: cc_tot_mesh, cc_hc_mesh, cc_hist_mesh + REAL, intent(out) :: cc_Cb_mesh, cc_ThCi_mesh, cc_Anv_mesh + REAL, intent(out) :: em_hc_mesh, pcld_hc_mesh, tcld_hc_mesh, & + & iwp_hc_mesh + + REAL, intent(out) :: pcld_Cb_mesh, tcld_Cb_mesh, em_Cb_mesh + REAL, intent(out) :: pcld_ThCi_mesh, tcld_ThCi_mesh, & + & em_ThCi_mesh + REAL, intent(out) :: pcld_Anv_mesh, tcld_Anv_mesh, em_Anv_mesh + + REAL, intent(out) :: em_hist_mesh, iwp_hist_mesh, rad_hist_mesh + REAL, intent(out) :: deltaz_hc_mesh, deltaz_hist_mesh + + REAL, DIMENSION(:), allocatable :: rneb_cs, temp_cs, emis_cs, & + & iwco_cs + REAL, DIMENSION(:), allocatable :: pres_cs, dz_cs, rad_cs, & + & rhodz_cs + + INTEGER :: i,j,l + INTEGER :: ltop, itop, ibot, num_cs, N_cs, len_cs, ics + + REAL :: som_emi_hc,som_pcl_hc,som_tcl_hc,som_iwp_hc,som_hc,& + & som_hist + REAL :: som_emi_hist, som_iwp_hist, som_deltaz_hc, & + & som_deltaz_hist + REAL :: som_rad_hist + REAL :: som_Cb, som_ThCi, som_Anv + REAL :: som_emi_Cb, som_tcld_Cb, som_pcld_Cb + REAL :: som_emi_Anv, som_tcld_Anv, som_pcld_Anv + REAL :: som_emi_ThCi, som_tcld_ThCi, som_pcld_ThCi + REAL :: tsom_tot, tsom_hc, tsom_hist + REAL :: prod, prod_hh + + REAL :: cc_tot_cs, cc_hc_cs, cc_hist_cs + REAL :: cc_Cb_cs, cc_ThCi_cs, cc_Anv_cs + REAL :: pcld_hc_cs, tcld_hc_cs + REAL :: em_hc_cs, iwp_hc_cs, deltaz_hc_cs + REAL :: pcld_Cb_cs, tcld_Cb_cs, em_Cb_cs + REAL :: pcld_ThCi_cs, tcld_ThCi_cs, em_ThCi_cs + REAL :: pcld_Anv_cs, tcld_Anv_cs, em_Anv_cs + REAL :: em_hist_cs, iwp_hist_cs, deltaz_hist_cs, rad_hist_cs + + REAL, DIMENSION(klev) :: test_tot, test_hc, test_hist + REAL, DIMENSION(klev) :: test_pcld, test_tcld, test_em, test_iwp + + CHARACTER (len = 50) :: modname = 'simu_airs.sim_mesh' + CHARACTER (len = 160) :: abort_message + + + do j = 1, klev + WRITE(lunout,*) 'simu_airs, j, rneb_1D =', rneb_1D(j) + enddo + +! Definition des structures nuageuses, de la plus haute a la plus basse + + num_cs = 0 + ltop = klev-1 + + prod = 1. + + som_emi_hc = 0. + som_emi_hist = 0. + som_pcl_hc = 0. + som_tcl_hc = 0. + som_iwp_hc = 0. + som_iwp_hist = 0. + som_deltaz_hc = 0. + som_deltaz_hist = 0. + som_rad_hist = 0. + som_hc = 0. + som_hist = 0. + + som_Cb = 0. + som_ThCi = 0. + som_Anv = 0. + + som_emi_Cb = 0. + som_pcld_Cb = 0. + som_tcld_Cb = 0. + + som_emi_ThCi = 0. + som_pcld_ThCi = 0. + som_tcld_ThCi = 0. + + som_emi_Anv = 0. + som_pcld_Anv = 0. + som_tcld_Anv = 0. + + tsom_tot = 0. + tsom_hc = 0. + tsom_hist = 0. + + do while (ltop .ge. 1) ! Boucle sur toute la colonne + + itop = 0 + + do l = ltop,1,-1 + + if (itop .eq. 0 .and. rneb_1D(l) .gt. 0.001 ) then + itop = l + endif + + enddo + + ibot = itop + + do while (rneb_1D(ibot) .gt. 0.001 .and. ibot .ge. 1) + ibot = ibot -1 + enddo + + + ibot = ibot+1 + + if (itop .gt. 0) then ! itop > 0 + + num_cs = num_cs +1 + len_cs = itop-ibot+1 + +! Allocation et definition des variables de la structure nuageuse +! le premier indice denote ce qui est le plus haut + + allocate (rneb_cs(len_cs)) + allocate (temp_cs(len_cs)) + allocate (emis_cs(len_cs)) + allocate (iwco_cs(len_cs)) + allocate (pres_cs(len_cs)) + allocate (dz_cs(len_cs)) + allocate (rad_cs(len_cs)) + allocate (rhodz_cs(len_cs)) + + ics = 0 + + do i = itop, ibot, -1 + ics = ics + 1 + rneb_cs(ics) = rneb_1D(i) + temp_cs(ics) = temp_1D(i) + emis_cs(ics) = emis_1D(i) + iwco_cs(ics) = iwcon_1D(i) + rad_cs(ics) = rad_1D(i) + pres_cs(ics) = pres(i) + dz_cs(ics) = dz(i) + rhodz_cs(ics) = rhodz_1D(i) + enddo + +! Appel du sous_programme cloud_structure + + call cloud_structure(len_cs,rneb_cs,temp_cs,emis_cs,iwco_cs,& + & pres_cs, dz_cs, rhodz_cs, rad_cs, & + & cc_tot_cs, cc_hc_cs, cc_hist_cs, & + & cc_Cb_cs, cc_ThCi_cs, cc_Anv_cs, & + & pcld_hc_cs, tcld_hc_cs, & + & em_hc_cs, iwp_hc_cs, deltaz_hc_cs, & + & pcld_Cb_cs, tcld_Cb_cs, em_Cb_cs, & + & pcld_ThCi_cs, tcld_ThCi_cs, em_ThCi_cs, & + & pcld_Anv_cs, tcld_Anv_cs, em_Anv_cs, & + & em_hist_cs, iwp_hist_cs, deltaz_hist_cs, rad_hist_cs) + + + deallocate (rneb_cs) + deallocate (temp_cs) + deallocate (emis_cs) + deallocate (iwco_cs) + deallocate (pres_cs) + deallocate (dz_cs) + deallocate (rad_cs) + deallocate (rhodz_cs) + + +! Pour la couverture nuageuse sur la maille + + prod_hh = prod + + prod = prod*(1.-cc_tot_cs) + +! Pour les autres variables definies sur la maille + + som_emi_hc = som_emi_hc + em_hc_cs*cc_hc_cs*prod_hh + som_iwp_hc = som_iwp_hc + iwp_hc_cs*cc_hc_cs*prod_hh + som_deltaz_hc = som_deltaz_hc + deltaz_hc_cs*cc_hc_cs*prod_hh + + som_emi_Cb = som_emi_Cb + em_Cb_cs*cc_Cb_cs*prod_hh + som_tcld_Cb = som_tcld_Cb + tcld_Cb_cs*cc_Cb_cs*prod_hh + som_pcld_Cb = som_pcld_Cb + pcld_Cb_cs*cc_Cb_cs*prod_hh + + som_emi_ThCi = som_emi_ThCi + em_ThCi_cs*cc_ThCi_cs*prod_hh + som_tcld_ThCi = som_tcld_ThCi + tcld_ThCi_cs*cc_ThCi_cs*prod_hh + som_pcld_ThCi = som_pcld_ThCi + pcld_ThCi_cs*cc_ThCi_cs*prod_hh + + som_emi_Anv = som_emi_Anv + em_Anv_cs*cc_Anv_cs*prod_hh + som_tcld_Anv = som_tcld_Anv + tcld_Anv_cs*cc_Anv_cs*prod_hh + som_pcld_Anv = som_pcld_Anv + pcld_Anv_cs*cc_Anv_cs*prod_hh + + som_emi_hist = som_emi_hist + em_hist_cs*cc_hist_cs*prod_hh + som_iwp_hist = som_iwp_hist + iwp_hist_cs*cc_hist_cs*prod_hh + som_deltaz_hist = som_deltaz_hist + & + & deltaz_hist_cs*cc_hist_cs*prod_hh + som_rad_hist = som_rad_hist + rad_hist_cs*cc_hist_cs*prod_hh + + som_pcl_hc = som_pcl_hc + pcld_hc_cs*cc_hc_cs*prod_hh + som_tcl_hc = som_tcl_hc + tcld_hc_cs*cc_hc_cs*prod_hh + + som_hc = som_hc + cc_hc_cs*prod_hh + som_hist = som_hist + cc_hist_cs*prod_hh + + som_Cb = som_Cb + cc_Cb_cs*prod_hh + som_ThCi = som_ThCi + cc_ThCi_cs*prod_hh + som_Anv = som_Anv + cc_Anv_cs*prod_hh + + +! Pour test + + call test_bornes('cc_tot_cs ',cc_tot_cs,1.,0.) + call test_bornes('cc_hc_cs ',cc_hc_cs,1.,0.) + call test_bornes('cc_hist_cs ',cc_hist_cs,1.,0.) + call test_bornes('pcld_hc_cs ',pcld_hc_cs,1200.,0.) + call test_bornes('tcld_hc_cs ',tcld_hc_cs,1000.,100.) + call test_bornes('em_hc_cs ',em_hc_cs,1000.,0.048) + + test_tot(num_cs) = cc_tot_cs + test_hc(num_cs) = cc_hc_cs + test_hist(num_cs) = cc_hist_cs + test_pcld(num_cs) = pcld_hc_cs + test_tcld(num_cs) = tcld_hc_cs + test_em(num_cs) = em_hc_cs + test_iwp(num_cs) = iwp_hc_cs + + tsom_tot = tsom_tot + cc_tot_cs + tsom_hc = tsom_hc + cc_hc_cs + tsom_hist = tsom_hist + cc_hist_cs + + + endif ! itop > 0 + + ltop = ibot -1 + + enddo ! fin de la boucle sur la colonne + + N_CS = num_cs + + +! Determination des variables de sortie + + if (N_CS .gt. 0) then ! if N_CS>0 + + cc_tot_mesh = 1. - prod + + cc_hc_mesh = som_hc + cc_hist_mesh = som_hist + + cc_Cb_mesh = som_Cb + cc_ThCi_mesh = som_ThCi + cc_Anv_mesh = som_Anv + + call normal2_undef(pcld_hc_mesh,som_pcl_hc, & + & cc_hc_mesh) + call normal2_undef(tcld_hc_mesh,som_tcl_hc, & + & cc_hc_mesh) + call normal2_undef(em_hc_mesh,som_emi_hc, & + & cc_hc_mesh) + call normal2_undef(iwp_hc_mesh,som_iwp_hc, & + & cc_hc_mesh) + call normal2_undef(deltaz_hc_mesh,som_deltaz_hc, & + & cc_hc_mesh) + + call normal2_undef(em_Cb_mesh,som_emi_Cb, & + & cc_Cb_mesh) + call normal2_undef(tcld_Cb_mesh,som_tcld_Cb, & + & cc_Cb_mesh) + call normal2_undef(pcld_Cb_mesh,som_pcld_Cb, & + & cc_Cb_mesh) + + call normal2_undef(em_ThCi_mesh,som_emi_ThCi, & + & cc_ThCi_mesh) + call normal2_undef(tcld_ThCi_mesh,som_tcld_ThCi, & + & cc_ThCi_mesh) + call normal2_undef(pcld_ThCi_mesh,som_pcld_ThCi, & + & cc_ThCi_mesh) + + call normal2_undef(em_Anv_mesh,som_emi_Anv, & + & cc_Anv_mesh) + call normal2_undef(tcld_Anv_mesh,som_tcld_Anv, & + & cc_Anv_mesh) + call normal2_undef(pcld_Anv_mesh,som_pcld_Anv, & + & cc_Anv_mesh) + + + call normal2_undef(em_hist_mesh,som_emi_hist, & + & cc_hist_mesh) + call normal2_undef(iwp_hist_mesh,som_iwp_hist, & + & cc_hist_mesh) + call normal2_undef(deltaz_hist_mesh,som_deltaz_hist, & + & cc_hist_mesh) + call normal2_undef(rad_hist_mesh,som_rad_hist, & + & cc_hist_mesh) + + +! Tests + + ! Tests + + if (cc_tot_mesh .gt. tsom_tot .and. & + & abs(cc_tot_mesh-tsom_tot) .gt. 1.e-4) then + WRITE(abort_message,*)'cc_tot_mesh > tsom_tot', cc_tot_mesh, tsom_tot + CALL abort_physic(modname,abort_message,1) + endif + + if (cc_tot_mesh .lt. maxval(test_tot(1:N_CS)) .and. & + & abs(cc_tot_mesh-maxval(test_tot(1:N_CS))) .gt. 1.e-4) then + WRITE(abort_message,*) 'cc_tot_mesh < max', cc_tot_mesh, maxval(test_tot(1:N_CS)) + CALL abort_physic(modname,abort_message,1) + endif + + if (cc_hc_mesh .gt. tsom_hc .and. & + & abs(cc_hc_mesh-tsom_hc) .gt. 1.e-4) then + WRITE(abort_message,*) 'cc_hc_mesh > tsom_hc', cc_hc_mesh, tsom_hc + CALL abort_physic(modname,abort_message,1) + endif + + if (cc_hc_mesh .lt. maxval(test_hc(1:N_CS)) .and. & + & abs(cc_hc_mesh-maxval(test_hc(1:N_CS))) .gt. 1.e-4) then + WRITE(abort_message,*) 'cc_hc_mesh < max', cc_hc_mesh, maxval(test_hc(1:N_CS)) + CALL abort_physic(modname,abort_message,1) + endif + + if (cc_hist_mesh .gt. tsom_hist .and. & + & abs(cc_hist_mesh-tsom_hist) .gt. 1.e-4) then + WRITE(abort_message,*) 'cc_hist_mesh > tsom_hist', cc_hist_mesh, tsom_hist + CALL abort_physic(modname,abort_message,1) + endif + + if (cc_hist_mesh .lt. 0.) then + WRITE(abort_message,*) 'cc_hist_mesh < 0', cc_hist_mesh + CALL abort_physic(modname,abort_message,1) + endif + + if ((pcld_hc_mesh .gt. maxval(test_pcld(1:N_CS)) .or. & + & pcld_hc_mesh .lt. minval(test_pcld(1:N_CS))) .and. & + & abs(pcld_hc_mesh-maxval(test_pcld(1:N_CS))) .gt. 1. .and. & + & maxval(test_pcld(1:N_CS)) .ne. 999. & + & .and. minval(test_pcld(1:N_CS)) .ne. 999.) then + WRITE(abort_message,*) 'pcld_hc_mesh est faux', pcld_hc_mesh, maxval(test_pcld(1:N_CS)), & + & minval(test_pcld(1:N_CS)) + CALL abort_physic(modname,abort_message,1) + endif + + if ((tcld_hc_mesh .gt. maxval(test_tcld(1:N_CS)) .or. & + & tcld_hc_mesh .lt. minval(test_tcld(1:N_CS))) .and. & + & abs(tcld_hc_mesh-maxval(test_tcld(1:N_CS))) .gt. 0.1 .and. & + & maxval(test_tcld(1:N_CS)) .ne. 999. & + & .and. minval(test_tcld(1:N_CS)) .ne. 999.) then + WRITE(abort_message,*) 'tcld_hc_mesh est faux', tcld_hc_mesh, maxval(test_tcld(1:N_CS)), & + & minval(test_tcld(1:N_CS)) + CALL abort_physic(modname,abort_message,1) + endif + + if ((em_hc_mesh .gt. maxval(test_em(1:N_CS)) .or. & + & em_hc_mesh .lt. minval(test_em(1:N_CS))) .and. & + & abs(em_hc_mesh-maxval(test_em(1:N_CS))) .gt. 1.e-4 .and. & + & minval(test_em(1:N_CS)) .ne. 999. .and. & + & maxval(test_em(1:N_CS)) .ne. 999. ) then + WRITE(abort_message,*) 'em_hc_mesh est faux', em_hc_mesh, maxval(test_em(1:N_CS)), & + & minval(test_em(1:N_CS)) + CALL abort_physic(modname,abort_message,1) + endif + + else ! if N_CS>0 + + cc_tot_mesh = 0. + cc_hc_mesh = 0. + cc_hist_mesh = 0. + + cc_Cb_mesh = 0. + cc_ThCi_mesh = 0. + cc_Anv_mesh = 0. + + iwp_hc_mesh = undef + deltaz_hc_mesh = undef + em_hc_mesh = undef + iwp_hist_mesh = undef + deltaz_hist_mesh = undef + rad_hist_mesh = undef + em_hist_mesh = undef + pcld_hc_mesh = undef + tcld_hc_mesh = undef + + pcld_Cb_mesh = undef + tcld_Cb_mesh = undef + em_Cb_mesh = undef + + pcld_ThCi_mesh = undef + tcld_ThCi_mesh = undef + em_ThCi_mesh = undef + + pcld_Anv_mesh = undef + tcld_Anv_mesh = undef + em_Anv_mesh = undef + + + endif ! if N_CS>0 + + end subroutine sim_mesh + + subroutine test_bornes(sx,x,bsup,binf) + + REAL, intent(in) :: x, bsup, binf + character*14, intent(in) :: sx + CHARACTER (len = 50) :: modname = 'simu_airs.test_bornes' + CHARACTER (len = 160) :: abort_message + + if (x .gt. bsup .or. x .lt. binf) then + WRITE(abort_message,*) sx, 'est faux', sx, x + CALL abort_physic(modname,abort_message,1) + endif + + end subroutine test_bornes + + end module m_simu_airs + + + subroutine simu_airs & + & (itap, rneb_airs, temp_airs, cldemi_airs, iwcon0_airs, rad_airs, & + & geop_airs, pplay_airs, paprs_airs, & + & map_prop_hc,map_prop_hist,& + & map_emis_hc,map_iwp_hc,map_deltaz_hc,map_pcld_hc,map_tcld_hc,& + & map_emis_Cb,map_pcld_Cb,map_tcld_Cb,& + & map_emis_ThCi,map_pcld_ThCi,map_tcld_ThCi,& + & map_emis_Anv,map_pcld_Anv,map_tcld_Anv,& + & map_emis_hist,map_iwp_hist,map_deltaz_hist,map_rad_hist,& + & map_ntot,map_hc,map_hist,& + & map_Cb,map_ThCi,map_Anv,alt_tropo ) + + USE dimphy + USE m_simu_airs + + USE yomcst_mod_h +IMPLICIT NONE + + + + INTEGER,intent(in) :: itap + + REAL, DIMENSION(klon,klev), intent(in) :: & + & rneb_airs, temp_airs, cldemi_airs, iwcon0_airs, & + & rad_airs, geop_airs, pplay_airs, paprs_airs + + REAL, DIMENSION(klon,klev) :: & + & rhodz_airs, rho_airs, iwcon_airs + + REAL, DIMENSION(klon),intent(out) :: alt_tropo + + REAL, DIMENSION(klev) :: rneb_1D, temp_1D, & + & emis_1D, rad_1D, pres_1D, alt_1D, & + & rhodz_1D, dz_1D, iwcon_1D + + INTEGER :: i, j + + REAL :: cc_tot_mesh, cc_hc_mesh, cc_hist_mesh + REAL :: cc_Cb_mesh, cc_ThCi_mesh, cc_Anv_mesh + REAL :: pcld_hc_mesh, tcld_hc_mesh, em_hc_mesh, iwp_hc_mesh + REAL :: em_hist_mesh, iwp_hist_mesh + REAL :: deltaz_hc_mesh, deltaz_hist_mesh, rad_hist_mesh + REAL :: pcld_Cb_mesh, tcld_Cb_mesh, em_Cb_mesh + REAL :: pcld_ThCi_mesh, tcld_ThCi_mesh, em_ThCi_mesh + REAL :: pcld_Anv_mesh, tcld_Anv_mesh, em_Anv_mesh + + REAL, DIMENSION(klon),intent(out) :: map_prop_hc, map_prop_hist + REAL, DIMENSION(klon),intent(out) :: map_emis_hc, map_iwp_hc + REAL, DIMENSION(klon),intent(out) :: map_deltaz_hc, map_pcld_hc + REAL, DIMENSION(klon),intent(out) :: map_tcld_hc + REAL, DIMENSION(klon),intent(out) :: map_emis_Cb,map_pcld_Cb,map_tcld_Cb + REAL, DIMENSION(klon),intent(out) :: & + & map_emis_ThCi,map_pcld_ThCi,map_tcld_ThCi + REAL, DIMENSION(klon),intent(out) :: & + & map_emis_Anv,map_pcld_Anv,map_tcld_Anv + REAL, DIMENSION(klon),intent(out) :: & + & map_emis_hist,map_iwp_hist,map_deltaz_hist,& + & map_rad_hist + REAL, DIMENSION(klon),intent(out) :: map_ntot,map_hc,map_hist + REAL, DIMENSION(klon),intent(out) :: map_Cb,map_ThCi,map_Anv + + + write(*,*) 'simu_airs' + write(*,*) 'itap, klon, klev', itap, klon, klev + write(*,*) 'RG, RD =', RG, RD + + +! Definition des variables 1D + + do i = 1, klon + do j = 1, klev-1 + rhodz_airs(i,j) = & + & (paprs_airs(i,j)-paprs_airs(i,j+1))/RG + enddo + rhodz_airs(i,klev) = 0. + enddo + + do i = 1, klon + do j = 1,klev + rho_airs(i,j) = & + & pplay_airs(i,j)/(temp_airs(i,j)*RD) + + if (rneb_airs(i,j) .gt. 0.001) then + iwcon_airs(i,j) = iwcon0_airs(i,j)/rneb_airs(i,j) + else + iwcon_airs(i,j) = 0. + endif + + enddo + enddo + +!============================================================================= + + do i = 1, klon ! boucle sur les points de grille + +!============================================================================= + + do j = 1,klev + + rneb_1D(j) = rneb_airs(i,j) + temp_1D(j) = temp_airs(i,j) + emis_1D(j) = cldemi_airs(i,j) + iwcon_1D(j) = iwcon_airs(i,j) + rad_1D(j) = rad_airs(i,j) + pres_1D(j) = pplay_airs(i,j) + alt_1D(j) = geop_airs(i,j)/RG + rhodz_1D(j) = rhodz_airs(i,j) + dz_1D(j) = rhodz_airs(i,j)/rho_airs(i,j) + + enddo + + alt_tropo(i) = & + & search_tropopause(pres_1D/100.,temp_1D,alt_1D,klev) + + +! Appel du ss-programme sim_mesh + +! if (itap .eq. 1 ) then + + call sim_mesh(rneb_1D, temp_1D, emis_1D, iwcon_1D, rad_1D, & + & pres_1D, dz_1D, rhodz_1D, & + & cc_tot_mesh, cc_hc_mesh, cc_hist_mesh, & + & pcld_hc_mesh, tcld_hc_mesh, em_hc_mesh, iwp_hc_mesh, & + & deltaz_hc_mesh,& + & cc_Cb_mesh, cc_ThCi_mesh, cc_Anv_mesh, & + & pcld_Cb_mesh, tcld_Cb_mesh, em_Cb_mesh, & + & pcld_ThCi_mesh, tcld_ThCi_mesh, em_ThCi_mesh, & + & pcld_Anv_mesh, tcld_Anv_mesh, em_Anv_mesh, & + & em_hist_mesh, iwp_hist_mesh, deltaz_hist_mesh, rad_hist_mesh) + + write(*,*) '====================================' + write(*,*) 'itap, i:', itap, i + write(*,*) 'cc_tot, cc_hc, cc_hist, pcld_hc, tcld_hc, em_hc, & + & iwp_hc, em_hist, iwp_hist =' + write(*,*) cc_tot_mesh, cc_hc_mesh, cc_hist_mesh + write(*,*) pcld_hc_mesh, tcld_hc_mesh, em_hc_mesh, iwp_hc_mesh + write(*,*) em_hist_mesh, iwp_hist_mesh + +! endif + +! Definition des variables a ecrire dans le fichier de sortie + + call normal2_undef(map_prop_hc(i),cc_hc_mesh, & + & cc_tot_mesh) + call normal2_undef(map_prop_hist(i),cc_hist_mesh, & + & cc_tot_mesh) + + map_emis_hc(i) = em_hc_mesh + map_iwp_hc(i) = iwp_hc_mesh + map_deltaz_hc(i) = deltaz_hc_mesh + map_pcld_hc(i) = pcld_hc_mesh + map_tcld_hc(i) = tcld_hc_mesh + + map_emis_Cb(i) = em_Cb_mesh + map_pcld_Cb(i) = pcld_Cb_mesh + map_tcld_Cb(i) = tcld_Cb_mesh + + map_emis_ThCi(i) = em_ThCi_mesh + map_pcld_ThCi(i) = pcld_ThCi_mesh + map_tcld_ThCi(i) = tcld_ThCi_mesh + + map_emis_Anv(i) = em_Anv_mesh + map_pcld_Anv(i) = pcld_Anv_mesh + map_tcld_Anv(i) = tcld_Anv_mesh + + map_emis_hist(i) = em_hist_mesh + map_iwp_hist(i) = iwp_hist_mesh + map_deltaz_hist(i) = deltaz_hist_mesh + map_rad_hist(i) = rad_hist_mesh + + map_ntot(i) = cc_tot_mesh + map_hc(i) = cc_hc_mesh + map_hist(i) = cc_hist_mesh + + map_Cb(i) = cc_Cb_mesh + map_ThCi(i) = cc_ThCi_mesh + map_Anv(i) = cc_Anv_mesh + + + enddo ! fin boucle sur les points de grille + + + + end subroutine simu_airs + Index: LMDZ6/trunk/libf/phylmd/mo_simple_plumes.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/mo_simple_plumes.f90 (revision 6047) +++ LMDZ6/trunk/libf/phylmd/mo_simple_plumes.f90 (revision 6048) @@ -1,5 +1,5 @@ !> !! -!! @brief Module MO_SIMPLE_PLUMES: provides anthropogenic aerosol optical properties as a function of lat, lon +!! @brief Module mo_simple_plumes: provides anthropogenic aerosol optical properties as a function of lat, lon !! height, time, and wavelength !! @@ -22,5 +22,5 @@ !! ! -MODULE MO_SIMPLE_PLUMES +MODULE mo_simple_plumes USE netcdf @@ -494,3 +494,3 @@ END SUBROUTINE sp_aop_profile -END MODULE MO_SIMPLE_PLUMES +END MODULE mo_simple_plumes Index: LMDZ6/trunk/libf/phylmd/nuage.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/nuage.f90 (revision 6047) +++ (revision ) @@ -1,444 +1,0 @@ -! $Id$ -MODULE nuage_mod - PRIVATE - - PUBLIC nuage, diagcld1, diagcld2 - - CONTAINS - -SUBROUTINE nuage(paprs, pplay, t, pqlwp,picefra, pclc, pcltau, pclemi, pch, pcl, pcm, & - pct, pctlwp, ok_aie, mass_solu_aero, mass_solu_aero_pi, bl95_b0, bl95_b1, distcltop, & - temp_cltop, cldtaupi, re, fl) - USE clesphys_mod_h - USE yomcst_mod_h - USE dimphy - USE lmdz_lscp_phase, only: icefrac_lscp - USE icefrac_lsc_mod ! computes ice fraction (JBM 3/14) - USE lmdz_lscp_ini, only : iflag_t_glace - USE phys_local_var_mod, ONLY: ptconv - USE nuage_params_mod_h - IMPLICIT NONE - ! ====================================================================== - ! Auteur(s): Z.X. Li (LMD/CNRS) date: 19930910 - ! Objet: Calculer epaisseur optique et emmissivite des nuages - ! ====================================================================== - ! Arguments: - ! t-------input-R-temperature - ! pqlwp---input-R-eau liquide nuageuse dans l'atmosphere (kg/kg) - ! picefra--inout-R-fraction de glace dans les nuages (-) - ! pclc----input-R-couverture nuageuse pour le rayonnement (0 a 1) - ! ok_aie--input-L-apply aerosol indirect effect or not - ! mass_solu_aero-----input-R-total mass concentration for all soluble - ! aerosols[ug/m^3] - ! mass_solu_aero_pi--input-R-dito, pre-industrial value - ! bl95_b0-input-R-a parameter, may be varied for tests (s-sea, l-land) - ! bl95_b1-input-R-a parameter, may be varied for tests ( -"- ) - - ! cldtaupi-output-R-pre-industrial value of cloud optical thickness, - ! needed for the diagnostics of the aerosol indirect - ! radiative forcing (see radlwsw) - ! re------output-R-Cloud droplet effective radius multiplied by fl [um] - ! fl------output-R-Denominator to re, introduced to avoid problems in - ! the averaging of the output. fl is the fraction of liquid - ! water clouds within a grid cell - - ! pcltau--output-R-epaisseur optique des nuages - ! pclemi--output-R-emissivite des nuages (0 a 1) - ! ====================================================================== - - REAL paprs(klon, klev+1), pplay(klon, klev) - REAL t(klon, klev) - - REAL pclc(klon, klev) - REAL pqlwp(klon, klev), picefra(klon,klev) - REAL pcltau(klon, klev), pclemi(klon, klev) - - REAL pct(klon), pctlwp(klon), pch(klon), pcl(klon), pcm(klon) - REAL distcltop(klon,klev) - REAL temp_cltop(klon,klev) - LOGICAL lo - - REAL cetahb, cetamb - PARAMETER (cetahb=0.45, cetamb=0.80) - - INTEGER i, k - REAL zflwp, zradef, zfice(klon), zmsac - - REAL radius, rad_chaud -! JBM (3/14) parameters already defined in nuage.h: -! REAL rad_froid, rad_chau1, rad_chau2 -! PARAMETER (rad_chau1=13.0, rad_chau2=9.0, rad_froid=35.0) - ! cc PARAMETER (rad_chaud=15.0, rad_froid=35.0) - ! 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 - PARAMETER (seuil_neb=0.001) -! JBM (3/14) nexpo is replaced by exposant_glace -! REAL nexpo ! exponentiel pour glace/eau -! PARAMETER (nexpo=6.) - REAL, PARAMETER :: t_glace_min_old = 258. - INTEGER, PARAMETER :: exposant_glace_old = 6 - - - ! jq for the aerosol indirect effect - ! jq introduced by Johannes Quaas (quaas@lmd.jussieu.fr), 27/11/2003 - ! jq - LOGICAL ok_aie ! Apply AIE or not? - - REAL mass_solu_aero(klon, klev) ! total mass concentration for all soluble aerosols[ug m-3] - REAL mass_solu_aero_pi(klon, klev) ! - " - pre-industrial value - REAL cdnc(klon, klev) ! cloud droplet number concentration [m-3] - REAL re(klon, klev) ! cloud droplet effective radius [um] - REAL cdnc_pi(klon, klev) ! cloud droplet number concentration [m-3] (pi value) - REAL re_pi(klon, klev) ! cloud droplet effective radius [um] (pi value) - - REAL fl(klon, klev) ! xliq * rneb (denominator to re; fraction of liquid water clouds - ! within the grid cell) - - REAL bl95_b0, bl95_b1 ! Parameter in B&L 95-Formula - - REAL cldtaupi(klon, klev) ! pre-industrial cloud opt thickness for diag - REAl dzfice(klon) - REAL :: pp_ratio(klon) - ! jq-end - - ! cc PARAMETER (nexpo=1) - - ! Calculer l'epaisseur optique et l'emmissivite des nuages - - DO k = 1, klev - IF (iflag_t_glace.EQ.0) THEN - DO i = 1, klon - zfice(i) = 1.0 - (t(i,k)-t_glace_min_old)/(273.13-t_glace_min_old) - zfice(i) = min(max(zfice(i),0.0), 1.0) - zfice(i) = zfice(i)**exposant_glace_old - ENDDO - ELSE ! of IF (iflag_t_glace.EQ.0) -! JBM: icefrac_lsc is now a function contained in icefrac_lsc_mod -! zfice(i) = icefrac_lsc(t(i,k), t_glace_min, & -! t_glace_max, exposant_glace) - IF (ok_new_lscp) THEN - CALL icefrac_lscp(klon,t(:,k),iflag_ice_thermo,distcltop(:,k),temp_cltop(:,k),zfice(:),dzfice(:)) - ELSE - pp_ratio(1:klon) = pplay(1:klon,k)/paprs(1:klon,1) - CALL icefrac_lsc(klon,t(:,k),pp_ratio(:),zfice(:)) - - ENDIF - - IF (ok_new_lscp .AND. ok_icefra_lscp) THEN - ! EV: take the ice fraction directly from the lscp code - ! consistent only for non convective grid points - ! critical for mixed phase clouds - DO i=1,klon - IF (.NOT. ptconv(i,k)) THEN - zfice(i)=picefra(i,k) - ENDIF - ENDDO - ENDIF - - - ENDIF - - DO i = 1, klon - rad_chaud = rad_chau1 - IF (k<=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)) - - IF (ok_aie) THEN - ! Formula "D" of Boucher and Lohmann, Tellus, 1995 - ! - cdnc(i, k) = 10.**(bl95_b0+bl95_b1*log(max(mass_solu_aero(i,k), & - 1.E-4))/log(10.))*1.E6 !-m-3 - ! Cloud droplet number concentration (CDNC) is restricted - ! to be within [20, 1000 cm^3] - ! - cdnc(i, k) = min(1000.E6, max(20.E6,cdnc(i,k))) - cdnc_pi(i, k) = 10.**(bl95_b0+bl95_b1*log(max(mass_solu_aero_pi(i,k), & - 1.E-4))/log(10.))*1.E6 !-m-3 - cdnc_pi(i, k) = min(1000.E6, max(20.E6,cdnc_pi(i,k))) - ! - ! - ! air density: pplay(i,k) / (RD * zT(i,k)) - ! factor 1.1: derive effective radius from volume-mean radius - ! factor 1000 is the water density - ! _chaud means that this is the CDR for liquid water clouds - ! - rad_chaud = 1.1*((pqlwp(i,k)*pplay(i,k)/(rd*t(i,k)))/(4./3.*rpi*1000. & - *cdnc(i,k)))**(1./3.) - ! - ! Convert to um. CDR shall be at least 3 um. - ! - rad_chaud = max(rad_chaud*1.E6, 3.) - - ! For output diagnostics - ! - ! Cloud droplet effective radius [um] - ! - ! we multiply here with f * xl (fraction of liquid water - ! clouds in the grid cell) to avoid problems in the - ! averaging of the output. - ! In the output of IOIPSL, derive the real cloud droplet - ! effective radius as re/fl - ! - fl(i, k) = pclc(i, k)*(1.-zfice(i)) - re(i, k) = rad_chaud*fl(i, k) - - ! Pre-industrial cloud opt thickness - ! - ! "radius" is calculated as rad_chaud above (plus the - ! ice cloud contribution) but using cdnc_pi instead of - ! cdnc. - radius = max(1.1E6*((pqlwp(i,k)*pplay(i,k)/(rd*t(i,k)))/(4./3.*rpi* & - 1000.*cdnc_pi(i,k)))**(1./3.), 3.)*(1.-zfice(i)) + rad_froid*zfice(i) - cldtaupi(i, k) = 3.0/2.0*zflwp/radius - END IF ! ok_aie - - radius = rad_chaud*(1.-zfice(i)) + rad_froid*zfice(i) - coef = coef_chau*(1.-zfice(i)) + coef_froi*zfice(i) - pcltau(i, k) = 3.0/2.0*zflwp/radius - pclemi(i, k) = 1.0 - exp(-coef*zflwp) - lo = (pclc(i,k)<=seuil_neb) - IF (lo) pclc(i, k) = 0.0 - IF (lo) pcltau(i, k) = 0.0 - IF (lo) pclemi(i, k) = 0.0 - - IF (.NOT. ok_aie) cldtaupi(i, k) = pcltau(i, k) - END DO - END DO - ! cc DO k = 1, klev - ! cc DO i = 1, klon - ! cc t(i,k) = t(i,k) - ! cc pclc(i,k) = MAX( 1.e-5 , pclc(i,k) ) - ! cc lo = pclc(i,k) .GT. (2.*1.e-5) - ! cc zflwp = pqlwp(i,k)*1000.*(paprs(i,k)-paprs(i,k+1)) - ! cc . /(rg*pclc(i,k)) - ! cc zradef = 10.0 + (1.-sigs(k))*45.0 - ! cc pcltau(i,k) = 1.5 * zflwp / zradef - ! cc zfice=1.0-MIN(MAX((t(i,k)-263.)/(273.-263.),0.0),1.0) - ! cc zmsac = 0.13*(1.0-zfice) + 0.08*zfice - ! cc pclemi(i,k) = 1.-EXP(-zmsac*zflwp) - ! cc if (.NOT.lo) pclc(i,k) = 0.0 - ! cc if (.NOT.lo) pcltau(i,k) = 0.0 - ! cc if (.NOT.lo) pclemi(i,k) = 0.0 - ! cc ENDDO - ! cc ENDDO - ! ccccc print*, 'pas de nuage dans le rayonnement' - ! ccccc DO k = 1, klev - ! ccccc DO i = 1, klon - ! ccccc pclc(i,k) = 0.0 - ! ccccc pcltau(i,k) = 0.0 - ! ccccc pclemi(i,k) = 0.0 - ! ccccc ENDDO - ! ccccc ENDDO - - ! COMPUTE CLOUD LIQUID PATH AND TOTAL CLOUDINESS - - DO i = 1, klon - pct(i) = 1.0 - pch(i) = 1.0 - pcm(i) = 1.0 - pcl(i) = 1.0 - pctlwp(i) = 0.0 - END DO - - 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)<=cetahb*paprs(i,1)) pch(i) = pch(i)*(1.0-pclc(i,k)) - IF (pplay(i,k)>cetahb*paprs(i,1) .AND. pplay(i,k)<=cetamb*paprs(i,1)) & - pcm(i) = pcm(i)*(1.0-pclc(i,k)) - IF (pplay(i,k)>cetamb*paprs(i,1)) pcl(i) = pcl(i)*(1.0-pclc(i,k)) - END DO - END DO - - DO i = 1, klon - pct(i) = 1. - pct(i) - pch(i) = 1. - pch(i) - pcm(i) = 1. - pcm(i) - pcl(i) = 1. - pcl(i) - END DO - - RETURN -END SUBROUTINE nuage - -SUBROUTINE diagcld1(paprs, pplay, rain, snow, kbot, ktop, diafra, dialiq) - USE dimphy - USE yomcst_mod_h -IMPLICIT NONE - - ! Laurent Li (LMD/CNRS), le 12 octobre 1998 - ! (adaptation du code ECMWF) - - ! Dans certains cas, le schema pronostique des nuages n'est - ! pas suffisament performant. On a donc besoin de diagnostiquer - ! ces nuages. Je dois avouer que c'est une frustration. - - - - ! Arguments d'entree: - REAL paprs(klon, klev+1) ! pression (Pa) a inter-couche - REAL pplay(klon, klev) ! pression (Pa) au milieu de couche - REAL t(klon, klev) ! temperature (K) - REAL q(klon, klev) ! humidite specifique (Kg/Kg) - REAL rain(klon) ! pluie convective (kg/m2/s) - REAL snow(klon) ! neige convective (kg/m2/s) - INTEGER ktop(klon) ! sommet de la convection - INTEGER kbot(klon) ! bas de la convection - - ! Arguments de sortie: - REAL diafra(klon, klev) ! fraction nuageuse diagnostiquee - REAL dialiq(klon, klev) ! eau liquide nuageuse - - ! Constantes ajustables: - REAL canva, canvb, canvh - PARAMETER (canva=2.0, canvb=0.3, canvh=0.4) - REAL cca, ccb, ccc - PARAMETER (cca=0.125, ccb=1.5, ccc=0.8) - REAL ccfct, ccscal - PARAMETER (ccfct=0.400) - PARAMETER (ccscal=1.0E+11) - REAL cetahb, cetamb - PARAMETER (cetahb=0.45, cetamb=0.80) - REAL cclwmr - PARAMETER (cclwmr=1.E-04) - REAL zepscr - PARAMETER (zepscr=1.0E-10) - - ! Variables locales: - INTEGER i, k - REAL zcc(klon) - - ! Initialisation: - - DO k = 1, klev - DO i = 1, klon - diafra(i, k) = 0.0 - dialiq(i, k) = 0.0 - END DO - END DO - - DO i = 1, klon ! Calculer la fraction nuageuse - zcc(i) = 0.0 - IF ((rain(i)+snow(i))>0.) THEN - zcc(i) = cca*log(max(zepscr,(rain(i)+snow(i))*ccscal)) - ccb - zcc(i) = min(ccc, max(0.0,zcc(i))) - END IF - END DO - - DO i = 1, klon ! pour traiter les enclumes - diafra(i, ktop(i)) = max(diafra(i,ktop(i)), zcc(i)*ccfct) - IF ((zcc(i)>=canvh) .AND. (pplay(i,ktop(i))<=cetahb*paprs(i, & - 1))) diafra(i, ktop(i)) = max(diafra(i,ktop(i)), max(zcc( & - i)*ccfct,canva*(zcc(i)-canvb))) - dialiq(i, ktop(i)) = cclwmr*diafra(i, ktop(i)) - END DO - - DO k = 1, klev ! nuages convectifs (sauf enclumes) - DO i = 1, klon - IF (k=kbot(i)) THEN - diafra(i, k) = max(diafra(i,k), zcc(i)*ccfct) - dialiq(i, k) = cclwmr*diafra(i, k) - END IF - END DO - END DO - - RETURN -END SUBROUTINE diagcld1 - -SUBROUTINE diagcld2(paprs, pplay, t, q, diafra, dialiq) - USE dimphy - USE yomcst_mod_h - USE yoethf_mod_h -IMPLICIT NONE - - - - ! Arguments d'entree: - REAL paprs(klon, klev+1) ! pression (Pa) a inter-couche - REAL pplay(klon, klev) ! pression (Pa) au milieu de couche - REAL t(klon, klev) ! temperature (K) - REAL q(klon, klev) ! humidite specifique (Kg/Kg) - - ! Arguments de sortie: - REAL diafra(klon, klev) ! fraction nuageuse diagnostiquee - REAL dialiq(klon, klev) ! eau liquide nuageuse - - REAL cetamb - PARAMETER (cetamb=0.80) - REAL cloia, cloib, cloic, cloid - PARAMETER (cloia=1.0E+02, cloib=-10.00, cloic=-0.6, cloid=5.0) - ! cc PARAMETER (CLOIA=1.0E+02, CLOIB=-10.00, CLOIC=-0.9, CLOID=5.0) - REAL rgammas - PARAMETER (rgammas=0.05) - REAL crhl - PARAMETER (crhl=0.15) - ! cc PARAMETER (CRHL=0.70) - REAL t_coup - PARAMETER (t_coup=234.0) - - ! Variables locales: - INTEGER i, k, kb, invb(klon) - REAL zqs, zrhb, zcll, zdthmin(klon), zdthdp - REAL zdelta, zcor - - ! Fonctions thermodynamiques: - include "FCTTRE.h" - - ! Initialisation: - - DO k = 1, klev - DO i = 1, klon - diafra(i, k) = 0.0 - dialiq(i, k) = 0.0 - END DO - END DO - - DO i = 1, klon - invb(i) = klev - zdthmin(i) = 0.0 - END DO - - DO k = 2, klev/2 - 1 - DO i = 1, klon - zdthdp = (t(i,k)-t(i,k+1))/(pplay(i,k)-pplay(i,k+1)) - & - rd*0.5*(t(i,k)+t(i,k+1))/rcpd/paprs(i, k+1) - zdthdp = zdthdp*cloia - IF (pplay(i,k)>cetamb*paprs(i,1) .AND. zdthdp0.0 .AND. zrhbcetahb*paprs(i,1) .AND. pplay(i,k)<=cetamb*paprs(i,1)) & + pcm(i) = pcm(i)*(1.0-pclc(i,k)) + IF (pplay(i,k)>cetamb*paprs(i,1)) pcl(i) = pcl(i)*(1.0-pclc(i,k)) + END DO + END DO + + DO i = 1, klon + pct(i) = 1. - pct(i) + pch(i) = 1. - pch(i) + pcm(i) = 1. - pcm(i) + pcl(i) = 1. - pcl(i) + END DO + + RETURN +END SUBROUTINE nuage + +SUBROUTINE diagcld1(paprs, pplay, rain, snow, kbot, ktop, diafra, dialiq) + USE dimphy + USE yomcst_mod_h +IMPLICIT NONE + + ! Laurent Li (LMD/CNRS), le 12 octobre 1998 + ! (adaptation du code ECMWF) + + ! Dans certains cas, le schema pronostique des nuages n'est + ! pas suffisament performant. On a donc besoin de diagnostiquer + ! ces nuages. Je dois avouer que c'est une frustration. + + + + ! Arguments d'entree: + REAL paprs(klon, klev+1) ! pression (Pa) a inter-couche + REAL pplay(klon, klev) ! pression (Pa) au milieu de couche + REAL t(klon, klev) ! temperature (K) + REAL q(klon, klev) ! humidite specifique (Kg/Kg) + REAL rain(klon) ! pluie convective (kg/m2/s) + REAL snow(klon) ! neige convective (kg/m2/s) + INTEGER ktop(klon) ! sommet de la convection + INTEGER kbot(klon) ! bas de la convection + + ! Arguments de sortie: + REAL diafra(klon, klev) ! fraction nuageuse diagnostiquee + REAL dialiq(klon, klev) ! eau liquide nuageuse + + ! Constantes ajustables: + REAL canva, canvb, canvh + PARAMETER (canva=2.0, canvb=0.3, canvh=0.4) + REAL cca, ccb, ccc + PARAMETER (cca=0.125, ccb=1.5, ccc=0.8) + REAL ccfct, ccscal + PARAMETER (ccfct=0.400) + PARAMETER (ccscal=1.0E+11) + REAL cetahb, cetamb + PARAMETER (cetahb=0.45, cetamb=0.80) + REAL cclwmr + PARAMETER (cclwmr=1.E-04) + REAL zepscr + PARAMETER (zepscr=1.0E-10) + + ! Variables locales: + INTEGER i, k + REAL zcc(klon) + + ! Initialisation: + + DO k = 1, klev + DO i = 1, klon + diafra(i, k) = 0.0 + dialiq(i, k) = 0.0 + END DO + END DO + + DO i = 1, klon ! Calculer la fraction nuageuse + zcc(i) = 0.0 + IF ((rain(i)+snow(i))>0.) THEN + zcc(i) = cca*log(max(zepscr,(rain(i)+snow(i))*ccscal)) - ccb + zcc(i) = min(ccc, max(0.0,zcc(i))) + END IF + END DO + + DO i = 1, klon ! pour traiter les enclumes + diafra(i, ktop(i)) = max(diafra(i,ktop(i)), zcc(i)*ccfct) + IF ((zcc(i)>=canvh) .AND. (pplay(i,ktop(i))<=cetahb*paprs(i, & + 1))) diafra(i, ktop(i)) = max(diafra(i,ktop(i)), max(zcc( & + i)*ccfct,canva*(zcc(i)-canvb))) + dialiq(i, ktop(i)) = cclwmr*diafra(i, ktop(i)) + END DO + + DO k = 1, klev ! nuages convectifs (sauf enclumes) + DO i = 1, klon + IF (k=kbot(i)) THEN + diafra(i, k) = max(diafra(i,k), zcc(i)*ccfct) + dialiq(i, k) = cclwmr*diafra(i, k) + END IF + END DO + END DO + + RETURN +END SUBROUTINE diagcld1 + +SUBROUTINE diagcld2(paprs, pplay, t, q, diafra, dialiq) + USE dimphy + USE yomcst_mod_h + USE yoethf_mod_h +IMPLICIT NONE + + + + ! Arguments d'entree: + REAL paprs(klon, klev+1) ! pression (Pa) a inter-couche + REAL pplay(klon, klev) ! pression (Pa) au milieu de couche + REAL t(klon, klev) ! temperature (K) + REAL q(klon, klev) ! humidite specifique (Kg/Kg) + + ! Arguments de sortie: + REAL diafra(klon, klev) ! fraction nuageuse diagnostiquee + REAL dialiq(klon, klev) ! eau liquide nuageuse + + REAL cetamb + PARAMETER (cetamb=0.80) + REAL cloia, cloib, cloic, cloid + PARAMETER (cloia=1.0E+02, cloib=-10.00, cloic=-0.6, cloid=5.0) + ! cc PARAMETER (CLOIA=1.0E+02, CLOIB=-10.00, CLOIC=-0.9, CLOID=5.0) + REAL rgammas + PARAMETER (rgammas=0.05) + REAL crhl + PARAMETER (crhl=0.15) + ! cc PARAMETER (CRHL=0.70) + REAL t_coup + PARAMETER (t_coup=234.0) + + ! Variables locales: + INTEGER i, k, kb, invb(klon) + REAL zqs, zrhb, zcll, zdthmin(klon), zdthdp + REAL zdelta, zcor + + ! Fonctions thermodynamiques: + include "FCTTRE.h" + + ! Initialisation: + + DO k = 1, klev + DO i = 1, klon + diafra(i, k) = 0.0 + dialiq(i, k) = 0.0 + END DO + END DO + + DO i = 1, klon + invb(i) = klev + zdthmin(i) = 0.0 + END DO + + DO k = 2, klev/2 - 1 + DO i = 1, klon + zdthdp = (t(i,k)-t(i,k+1))/(pplay(i,k)-pplay(i,k+1)) - & + rd*0.5*(t(i,k)+t(i,k+1))/rcpd/paprs(i, k+1) + zdthdp = zdthdp*cloia + IF (pplay(i,k)>cetamb*paprs(i,1) .AND. zdthdp0.0 .AND. zrhb 0.02 ) -!! ZNU(:)=MIN(0.0,0.5*(ZWORK3(:)-0.3)) -!! ZBBP(:)=(0.002+0.01*(0.5-0.25*ZWORK3(:))*(ZWL/550.)**ZNU(:))*ZWORK2(:) -!! ELSEWHERE -!! ZBBP(:)=0.019*(550./ZWL)*ZWORK2(:) !ZBBPf=0.0113 at chl<=0.02 -!! ENDWHERE - - do JI = 1, knon - IF (ZCHL(JI) > 0.02) THEN - ZNU(JI)=MIN(0.0,0.5*(ZWORK3(JI)-0.3)) - ZBBP(JI)=(0.002+0.01*(0.5-0.25*ZWORK3(JI))*(ZWL/550.)**ZNU(JI)) & - *ZWORK2(JI) - ELSE - ZBBP(JI)=0.019*(550./ZWL)*ZWORK2(JI) !ZBBPf=0.0113 at chl<=0.02 - ENDIF - ENDDO - - ! Morel-Gentili(1991), Eq (12) - ! ZHB=h/(h+2*ZBBPf*(1.-h)) - ZHB(1:knon)=0.5*ZBW/(0.5*ZBW+ZBBP(1:knon)) - - !--------------------------------------------------------------------------------- - ! 3- Compute direct water-leaving albedo (ZRW) - !--------------------------------------------------------------------------------- - ! Based on Morel & Gentilli 1991 parametrization - ZR22(1:knon)=0.48168549-0.014894708*ZSIG(1:knon)-0.20703885*ZSIG(1:knon)**2 - - ! Use Morel 91 formula to compute the direct reflectance - ! below the surface - ZR00(1:knon)=(0.5*ZBW+ZBBP(1:knon))/(ZAW+ZAP(1:knon)) * & - (0.6279-0.2227*ZHB(1:knon)-0.0513*ZHB(1:knon)**2 + & - (-0.3119+0.2465*ZHB(1:knon))*ZCOSZEN(1:knon)) - ZRW(1:knon)=ZR00(1:knon)*(1.-ZR22(1:knon))/(1.-ZR00(1:knon)*ZR22(1:knon)) - - !--------------------------------------------------------------------------------- - ! 4- Compute diffuse water-leaving albedo (ZRWDF) - !--------------------------------------------------------------------------------- - ! as previous water-leaving computation but assumes a uniform incidence of - ! shortwave at surface (ue) - ZUE=0.676 ! equivalent u_unif for diffuse incidence - ZUE2=SQRT(1.0-(1.0-ZUE**2)/ZREFM**2) - ZRR0(1:knon)=0.50*(((ZUE2-ZREFM*ZUE)/(ZUE2+ZREFM*ZUE))**2 +((ZUE-ZREFM*ZUE2)/(ZUE+ZREFM*ZUE2))**2) - ZRRR(1:knon)=0.50*(((ZUE2-1.34*ZUE)/(ZUE2+1.34*ZUE))**2 +((ZUE-1.34*ZUE2)/(ZUE+1.34*ZUE2))**2) - ZR11DF(1:knon)=ZRR0(1:knon)-(0.0152-1.7873*ZUE+6.8972*ZUE**2-8.5778*ZUE**3+4.071*ZSIG(1:knon)-7.6446*ZUE*ZSIG(1:knon)) * & - EXP(0.1643-7.8409*ZUE-3.5639*ZUE**2-2.3588*ZSIG(1:knon)+10.0538*ZUE*ZSIG(1:knon))*ZRR0(1:knon)/ZRRR(1:knon) - - ! Use Morel 91 formula to compute the diffuse - ! reflectance below the surface - ZR00(1:knon) = (0.5*ZBW+ZBBP(1:knon)) / (ZAW+ZAP(1:knon)) & - * (0.6279-0.2227*ZHB(1:knon)-0.0513*ZHB(1:knon)**2 & - + (-0.3119+0.2465*ZHB(1:knon))*ZUE) - ZRWDF(1:knon)=ZR00(1:knon)*(1.-ZR22(1:knon))*(1.-ZR11DF(1:knon))/(1.-ZR00(1:knon)*ZR22(1:knon)) - - ! get waveband index inu for each nsw band - SELECT CASE(nsw) - CASE(2) - IF (JWL.LE.49) THEN ! from 200 to 680 nm - inu=1 - ELSE ! from 690 to 4000 nm - inu=2 - ENDIF - CASE(4) - IF (JWL.LE.49) THEN ! from 200 to 680 nm - inu=1 - ELSE IF (JWL.LE.99) THEN ! from 690 to 1180 nm - inu=2 - ELSE IF (JWL.LE.218) THEN ! from 1190 to 2370 nm - inu=3 - ELSE ! from 2380 to 4000 nm - inu=4 - ENDIF - CASE(6) - IF (JWL.LE.5) THEN ! from 200 to 240 nm - inu=1 - ELSE IF (JWL.LE.24) THEN ! from 250 to 430 nm - inu=2 - ELSE IF (JWL.LE.49) THEN ! from 440 to 680 nm - inu=3 - ELSE IF (JWL.LE.99) THEN ! from 690 to 1180 nm - inu=4 - ELSE IF (JWL.LE.218) THEN ! from 1190 to 2370 nm - inu=5 - ELSE ! from 2380 to 4000 nm - inu=6 - ENDIF - END SELECT - - ! partitionning direct and diffuse albedo - ! excluding diffuse albedo ZRW on ZDIR_ALB - - !--direct - alb_dir_new(1:knon,inu)=alb_dir_new(1:knon,inu) + & - ( XFRWL(JWL) * ((1.-ZFWC(1:knon)) * (ZR11(1:knon)+ZRW(1:knon)) + ZFWC(1:knon)*XRWC(JWL)) )/SFRWL(inu) - !--diffuse - alb_dif_new(1:knon,inu)=alb_dif_new(1:knon,inu) + & - ( XFRWL(JWL) * ((1.-ZFWC(1:knon)) * (ZRDF(1:knon)+ZRWDF(1:knon)) + ZFWC(1:knon)*XRWC(JWL)) )/SFRWL(inu) - -ENDDO ! ending loop over wavelengths - -END SUBROUTINE ocean_albedo - -END MODULE ocean_albedo_mod Index: LMDZ6/trunk/libf/phylmd/ocean_albedo_mod.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ocean_albedo_mod.f90 (revision 6048) +++ LMDZ6/trunk/libf/phylmd/ocean_albedo_mod.f90 (revision 6048) @@ -0,0 +1,262 @@ +! +! $Id$ +! +MODULE ocean_albedo_mod + +CONTAINS + +SUBROUTINE ocean_albedo(knon,zrmu0,knindex,pwind,SFRWL,alb_dir_new,alb_dif_new) +!$gpum horizontal knon klon + +!! +!!**** *ALBEDO_RS14* +!! +!! PURPOSE +!! ------- +!! computes the direct & diffuse albedo over open water +!! +!!** METHOD +!! ------ +!! +!! EXTERNAL +!! -------- +!! +!! IMPLICIT ARGUMENTS +!! ------------------ +!! +!! REFERENCE +!! --------- +!! +!! AUTHOR +!! ------ +!! R. Séférian * Meteo-France * +!! +!! MODIFICATIONS +!! ------------- +!! Original 03/2014 +!! 05/2014 R. Séférian & B. Decharme :: Adaptation to spectral +!! computation for diffuse and direct albedo +!! 08/2014 S. Baek :: for wider wavelength range 200-4000nm and +!! adaptation to LMDZ + whitecap effect by Koepke + chrolophyll +!! map from climatology file +!! 10/2016 O. Boucher :: some optimisation following R. +!! Seferian's work in the CNRM Model +!! +!------------------------------------------------------------------------------- +! +!* DECLARATIONS +! ------------ +! +USE ocean_albedo_para, ONLY : nnwl, xakwl, xakrefm, xakachl, xakaw3, xakbw, xaw440, xfrwl, xrwc +USE phys_state_var_mod, ONLY : chl_con +USE clesphys_mod_h, ONLY: nsw, ok_chlorophyll +! +! +IMPLICIT NONE +! +!* 0.1 declarations of arguments +! ------------------------- +! +! +INTEGER, INTENT(IN) :: knon +INTEGER, DIMENSION(knon), INTENT(IN) :: knindex +REAL, DIMENSION(knon), INTENT(IN) :: zrmu0 !--cos(SZA) on full vector +REAL, DIMENSION(knon), INTENT(IN) :: pwind !--wind speed on compressed vector +REAL, DIMENSION(6),INTENT(IN) :: SFRWL +REAL, DIMENSION(knon,nsw), INTENT(OUT) :: alb_dir_new, alb_dif_new +! +!* 0.2 declarations of local variables +! ------------------------- +! +REAL, DIMENSION(knon) :: ZCHL ! surface chlorophyll +REAL, DIMENSION(knon) :: ZCOSZEN ! Cosine of the zenith solar angle +! +INTEGER :: JWL, INU ! indexes +INTEGER :: JI +REAL :: ZWL ! input parameter: wavelength and diffuse/direct fraction of light +REAL:: ZCHLABS, ZAW, ZBW, ZREFM, ZYLMD, ZUE, ZUE2 ! scalar computation variables +! +REAL, DIMENSION(knon) :: ZAP, ZXX2, ZR00, ZRR0, ZRRR ! computation variables +REAL, DIMENSION(knon) :: ZR22, ZR11DF ! computation variables +REAL, DIMENSION(knon) :: ZBBP, ZNU, ZHB ! computation variables +REAL, DIMENSION(knon) :: ZR11, ZRW, ZRWDF, ZRDF ! 4 components of the OSA +REAL, DIMENSION(knon) :: ZSIG, ZFWC, ZWORK1, ZWORK2, ZWORK3 +! +!--initialisations------------- +! + +IF (knon==0) RETURN ! A verifier pourquoi on en a besoin... + +alb_dir_new(:,:) = 0. +alb_dif_new(:,:) = 0. +! +! Initialisation of chlorophyll content +! ZCHL(:) = CHL_CON!0.05 ! averaged global values for surface chlorophyll +IF (ok_chlorophyll) THEN + ZCHL(1:knon)=CHL_CON(knindex(1:knon)) +ELSE + ZCHL(1:knon) = 0.05 +ENDIF + +! variables that do not depend on wavelengths +! loop over the grid points +! functions of chlorophyll content +ZWORK1(1:knon)= EXP(LOG(ZCHL(1:knon))*0.65) +ZWORK2(1:knon)= 0.416 * EXP(LOG(ZCHL(1:knon))*0.766) +ZWORK3(1:knon)= LOG10(ZCHL(1:knon)) +! store the cosine of the solar zenith angle +ZCOSZEN(1:knon) = zrmu0(1:knon) +! Compute sigma derived from wind speed (Cox & Munk reflectance model) +ZSIG(1:knon)=SQRT(0.003+0.00512*PWIND(1:knon)) +! original : correction for foam (Eq 16-17) +! has to be update once we have information from wave model (discussion with G. Madec) +ZFWC(1:knon)=3.97e-4*PWIND(1:knon)**1.59 ! Salisbury 2014 eq(2) at 37GHz, value in fraction +! +DO JWL=1,NNWL ! loop over the wavelengths + ! + !--------------------------------------------------------------------------------- + ! 0- Compute baseline values + !--------------------------------------------------------------------------------- + + ! Get refractive index for the correspoding wavelength + ZWL=XAKWL(JWL) !!!--------- wavelength value + ZREFM= XAKREFM(JWL) !!!--------- refraction index value + + !--------------------------------------------------------------------------------- + ! 1- Compute direct surface albedo (ZR11) + !--------------------------------------------------------------------------------- + ! + ZXX2(1:knon)=SQRT(1.0-(1.0-ZCOSZEN(1:knon)**2)/ZREFM**2) + ZRR0(1:knon)=0.50*(((ZXX2(1:knon)-ZREFM*ZCOSZEN(1:knon))/(ZXX2(1:knon)+ZREFM*ZCOSZEN(1:knon)))**2 + & + ((ZCOSZEN(1:knon)-ZREFM*ZXX2(1:knon))/(ZCOSZEN(1:knon)+ZREFM*ZXX2(1:knon)))**2) + ZRRR(1:knon)=0.50*(((ZXX2(1:knon)-1.34*ZCOSZEN(1:knon))/(ZXX2(1:knon)+1.34*ZCOSZEN(1:knon)))**2 + & + ((ZCOSZEN(1:knon)-1.34*ZXX2(1:knon))/(ZCOSZEN(1:knon)+1.34*ZXX2(1:knon)))**2) + ZR11(1:knon)=ZRR0(1:knon)-(0.0152-1.7873*ZCOSZEN(1:knon)+6.8972*ZCOSZEN(1:knon)**2-8.5778*ZCOSZEN(1:knon)**3+ & + 4.071*ZSIG(1:knon)-7.6446*ZCOSZEN(1:knon)*ZSIG(1:knon)) * & + EXP(0.1643-7.8409*ZCOSZEN(1:knon)-3.5639*ZCOSZEN(1:knon)**2-2.3588*ZSIG(1:knon)+ & + 10.0538*ZCOSZEN(1:knon)*ZSIG(1:knon))*ZRR0(1:knon)/ZRRR(1:knon) + ! + !--------------------------------------------------------------------------------- + ! 2- Compute surface diffuse albedo (ZRDF) + !--------------------------------------------------------------------------------- + ! Diffuse albedo from Jin et al., 2006 + estimation from diffuse fraction of + ! light (relying later on AOD). CNRM model has opted for Eq 5b + ZRDF(1:knon)=-0.1482-0.012*ZSIG(1:knon)+0.1609*ZREFM-0.0244*ZSIG(1:knon)*ZREFM ! surface diffuse (Eq 5a) + !!ZRDF(1:knon)=-0.1479+0.1502*ZREFM-0.0176*ZSIG(1:knon)*ZREFM ! surface diffuse (Eq 5b) + + !--------------------------------------------------------------------------------- + ! *- Determine absorption and backscattering + ! coefficients to determine reflectance below the surface (Ro) once for all + ! + ! *.1- Absorption by chlorophyll + ZCHLABS= XAKACHL(JWL) + ! *.2- Absorption by seawater + ZAW= XAKAW3(JWL) + ! *.3- Backscattering by seawater + ZBW= XAKBW(JWL) + ! *.4- Backscattering by chlorophyll + ZYLMD = EXP(0.014*(440.0-ZWL)) + ZAP(1:knon) = 0.06*ZCHLABS*ZWORK1(1:knon) +0.2*(XAW440+0.06*ZWORK1(1:knon))*ZYLMD + +!! WHERE ( ZCHL(1:knon) > 0.02 ) +!! ZNU(:)=MIN(0.0,0.5*(ZWORK3(:)-0.3)) +!! ZBBP(:)=(0.002+0.01*(0.5-0.25*ZWORK3(:))*(ZWL/550.)**ZNU(:))*ZWORK2(:) +!! ELSEWHERE +!! ZBBP(:)=0.019*(550./ZWL)*ZWORK2(:) !ZBBPf=0.0113 at chl<=0.02 +!! ENDWHERE + + do JI = 1, knon + IF (ZCHL(JI) > 0.02) THEN + ZNU(JI)=MIN(0.0,0.5*(ZWORK3(JI)-0.3)) + ZBBP(JI)=(0.002+0.01*(0.5-0.25*ZWORK3(JI))*(ZWL/550.)**ZNU(JI)) & + *ZWORK2(JI) + ELSE + ZBBP(JI)=0.019*(550./ZWL)*ZWORK2(JI) !ZBBPf=0.0113 at chl<=0.02 + ENDIF + ENDDO + + ! Morel-Gentili(1991), Eq (12) + ! ZHB=h/(h+2*ZBBPf*(1.-h)) + ZHB(1:knon)=0.5*ZBW/(0.5*ZBW+ZBBP(1:knon)) + + !--------------------------------------------------------------------------------- + ! 3- Compute direct water-leaving albedo (ZRW) + !--------------------------------------------------------------------------------- + ! Based on Morel & Gentilli 1991 parametrization + ZR22(1:knon)=0.48168549-0.014894708*ZSIG(1:knon)-0.20703885*ZSIG(1:knon)**2 + + ! Use Morel 91 formula to compute the direct reflectance + ! below the surface + ZR00(1:knon)=(0.5*ZBW+ZBBP(1:knon))/(ZAW+ZAP(1:knon)) * & + (0.6279-0.2227*ZHB(1:knon)-0.0513*ZHB(1:knon)**2 + & + (-0.3119+0.2465*ZHB(1:knon))*ZCOSZEN(1:knon)) + ZRW(1:knon)=ZR00(1:knon)*(1.-ZR22(1:knon))/(1.-ZR00(1:knon)*ZR22(1:knon)) + + !--------------------------------------------------------------------------------- + ! 4- Compute diffuse water-leaving albedo (ZRWDF) + !--------------------------------------------------------------------------------- + ! as previous water-leaving computation but assumes a uniform incidence of + ! shortwave at surface (ue) + ZUE=0.676 ! equivalent u_unif for diffuse incidence + ZUE2=SQRT(1.0-(1.0-ZUE**2)/ZREFM**2) + ZRR0(1:knon)=0.50*(((ZUE2-ZREFM*ZUE)/(ZUE2+ZREFM*ZUE))**2 +((ZUE-ZREFM*ZUE2)/(ZUE+ZREFM*ZUE2))**2) + ZRRR(1:knon)=0.50*(((ZUE2-1.34*ZUE)/(ZUE2+1.34*ZUE))**2 +((ZUE-1.34*ZUE2)/(ZUE+1.34*ZUE2))**2) + ZR11DF(1:knon)=ZRR0(1:knon)-(0.0152-1.7873*ZUE+6.8972*ZUE**2-8.5778*ZUE**3+4.071*ZSIG(1:knon)-7.6446*ZUE*ZSIG(1:knon)) * & + EXP(0.1643-7.8409*ZUE-3.5639*ZUE**2-2.3588*ZSIG(1:knon)+10.0538*ZUE*ZSIG(1:knon))*ZRR0(1:knon)/ZRRR(1:knon) + + ! Use Morel 91 formula to compute the diffuse + ! reflectance below the surface + ZR00(1:knon) = (0.5*ZBW+ZBBP(1:knon)) / (ZAW+ZAP(1:knon)) & + * (0.6279-0.2227*ZHB(1:knon)-0.0513*ZHB(1:knon)**2 & + + (-0.3119+0.2465*ZHB(1:knon))*ZUE) + ZRWDF(1:knon)=ZR00(1:knon)*(1.-ZR22(1:knon))*(1.-ZR11DF(1:knon))/(1.-ZR00(1:knon)*ZR22(1:knon)) + + ! get waveband index inu for each nsw band + SELECT CASE(nsw) + CASE(2) + IF (JWL.LE.49) THEN ! from 200 to 680 nm + inu=1 + ELSE ! from 690 to 4000 nm + inu=2 + ENDIF + CASE(4) + IF (JWL.LE.49) THEN ! from 200 to 680 nm + inu=1 + ELSE IF (JWL.LE.99) THEN ! from 690 to 1180 nm + inu=2 + ELSE IF (JWL.LE.218) THEN ! from 1190 to 2370 nm + inu=3 + ELSE ! from 2380 to 4000 nm + inu=4 + ENDIF + CASE(6) + IF (JWL.LE.5) THEN ! from 200 to 240 nm + inu=1 + ELSE IF (JWL.LE.24) THEN ! from 250 to 430 nm + inu=2 + ELSE IF (JWL.LE.49) THEN ! from 440 to 680 nm + inu=3 + ELSE IF (JWL.LE.99) THEN ! from 690 to 1180 nm + inu=4 + ELSE IF (JWL.LE.218) THEN ! from 1190 to 2370 nm + inu=5 + ELSE ! from 2380 to 4000 nm + inu=6 + ENDIF + END SELECT + + ! partitionning direct and diffuse albedo + ! excluding diffuse albedo ZRW on ZDIR_ALB + + !--direct + alb_dir_new(1:knon,inu)=alb_dir_new(1:knon,inu) + & + ( XFRWL(JWL) * ((1.-ZFWC(1:knon)) * (ZR11(1:knon)+ZRW(1:knon)) + ZFWC(1:knon)*XRWC(JWL)) )/SFRWL(inu) + !--diffuse + alb_dif_new(1:knon,inu)=alb_dif_new(1:knon,inu) + & + ( XFRWL(JWL) * ((1.-ZFWC(1:knon)) * (ZRDF(1:knon)+ZRWDF(1:knon)) + ZFWC(1:knon)*XRWC(JWL)) )/SFRWL(inu) + +ENDDO ! ending loop over wavelengths + +END SUBROUTINE ocean_albedo + +END MODULE ocean_albedo_mod Index: LMDZ6/trunk/libf/phylmd/orbite.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/orbite.f90 (revision 6047) +++ (revision ) @@ -1,307 +1,0 @@ - -! $Header$ -!$gpum horizontal klon -MODULE orbite_mod - PRIVATE - - PUBLIC orbite, angle, zenang, zenith - - CONTAINS - -! ====================================================================== -SUBROUTINE orbite(xjour, longi, dist) - USE yomcst_mod_h, ONLY: r_peri, r_ecc -IMPLICIT NONE - ! ====================================================================== - ! Auteur(s): Z.X. Li (LMD/CNRS) (adapte du GCM du LMD) date: 19930818 - ! Objet: pour un jour donne, calculer la longitude vraie de la terre - ! (par rapport au point vernal-21 mars) dans son orbite solaire - ! calculer aussi la distance terre-soleil (unite astronomique) - ! ====================================================================== - ! Arguments: - ! xjour--INPUT--R- jour de l'annee a compter du 1er janvier - ! longi--OUTPUT-R- longitude vraie en degres par rapport au point - ! vernal (21 mars) en degres - ! dist---OUTPUT-R- distance terre-soleil (par rapport a la moyenne) - REAL xjour, longi, dist - ! ====================================================================== - - - ! -- Variables dynamiques locales - REAL pir, xl, xllp, xee, xse, xlam, dlamm, anm, ranm, anv, ranv - - pir = 4.0*atan(1.0)/180.0 - xl = r_peri + 180.0 - xllp = xl*pir - xee = r_ecc*r_ecc - xse = sqrt(1.0-xee) - xlam = (r_ecc/2.0+r_ecc*xee/8.0)*(1.0+xse)*sin(xllp) - & - xee/4.0*(0.5+xse)*sin(2.0*xllp) + r_ecc*xee/8.0*(1.0/3.0+xse)*sin(3.0* & - xllp) - xlam = 2.0*xlam/pir - dlamm = xlam + (xjour-81.0) - anm = dlamm - xl - ranm = anm*pir - xee = xee*r_ecc - ranv = ranm + (2.0*r_ecc-xee/4.0)*sin(ranm) + 5.0/4.0*r_ecc*r_ecc*sin(2.0* & - ranm) + 13.0/12.0*xee*sin(3.0*ranm) - - anv = ranv/pir - longi = anv + xl - - dist = (1-r_ecc*r_ecc)/(1+r_ecc*cos(pir*(longi-(r_peri+180.0)))) - RETURN -END SUBROUTINE orbite -! ====================================================================== -SUBROUTINE angle(longi, lati, frac, muzero) - USE dimphy - USE yomcst_mod_h -IMPLICIT NONE - ! ====================================================================== - ! Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818 - ! Objet: Calculer la duree d'ensoleillement pour un jour et la hauteur - ! du soleil (cosinus de l'angle zinithal) moyenne sur la journee - ! ====================================================================== - ! Arguments: - ! longi----INPUT-R- la longitude vraie de la terre dans son plan - ! solaire a partir de l'equinoxe de printemps (degre) - ! lati-----INPUT-R- la latitude d'un point sur la terre (degre) - ! frac-----OUTPUT-R la duree d'ensoleillement dans la journee divisee - ! par 24 heures (unite en fraction de 0 a 1) - ! muzero---OUTPUT-R la moyenne du cosinus de l'angle zinithal sur - ! la journee (0 a 1) - ! ====================================================================== - REAL longi - REAL lati(klon), frac(klon), muzero(klon) - - REAL lat, omega, lon_sun, lat_sun - REAL pi_local, incl - INTEGER i - - pi_local = 4.0*atan(1.0) - incl = r_incl*pi_local/180. - - lon_sun = longi*pi_local/180.0 - lat_sun = asin(sin(lon_sun)*sin(incl)) - - DO i = 1, klon - lat = lati(i)*pi_local/180.0 - - IF (lat>=(pi_local/2.+lat_sun) .OR. lat<=(-pi_local/2.+lat_sun)) THEN - omega = 0.0 ! nuit polaire - ELSE IF (lat>=(pi_local/2.-lat_sun) .OR. lat<=(-pi_local/2.-lat_sun)) & - THEN - omega = pi_local ! journee polaire - ELSE - omega = -tan(lat)*tan(lat_sun) - omega = acos(omega) - END IF - - frac(i) = omega/pi_local - - IF (omega>0.0) THEN - muzero(i) = sin(lat)*sin(lat_sun) + cos(lat)*cos(lat_sun)*sin(omega)/ & - omega - ELSE - muzero(i) = 0.0 - END IF - END DO - - RETURN -END SUBROUTINE angle -! ==================================================================== -SUBROUTINE zenang(longi, gmtime, pdtrad1, pdtrad2, lat, long, pmu0, frac) - USE dimphy - USE yomcst_mod_h -IMPLICIT NONE - ! ============================================================= - ! Auteur : O. Boucher (LMD/CNRS) - ! d'apres les routines zenith et angle de Z.X. Li - ! Objet : calculer les valeurs moyennes du cos de l'angle zenithal - ! et l'ensoleillement moyen entre gmtime1 et gmtime2 - ! connaissant la declinaison, la latitude et la longitude. - ! Rque : Different de la routine angle en ce sens que zenang - ! fournit des moyennes de pmu0 et non des valeurs - ! instantanees, du coup frac prend toutes les valeurs - ! entre 0 et 1. La routine integre entre gmtime+pdtrad1 et - ! gmtime+pdtrad2 avec pdtrad1 et pdtrad2 exprimes en secondes. - ! Date : premiere version le 13 decembre 1994 - ! revu pour GCM le 30 septembre 1996 - ! revu le 3 septembre 2015 pour les bornes de l'integrale - ! =============================================================== - ! longi : la longitude vraie de la terre dans son plan - ! solaire a partir de l'equinoxe de printemps (degre) - ! gmtime : temps universel en fraction de jour - ! pdtrad1 : borne inferieure du pas de temps du rayonnement (secondes) - ! pdtrad2 : borne inferieure du pas de temps du rayonnement (secondes) - ! pdtrad2-pdtrad1 correspond a pdtrad, le pas de temps du rayonnement (secondes) - ! lat------INPUT : latitude en degres - ! long-----INPUT : longitude en degres - ! pmu0-----OUTPUT: angle zenithal moyen entre gmtime+pdtrad1 et gmtime+pdtrad2 - ! frac-----OUTPUT: ensoleillement moyen entre gmtime+pdtrad1 et gmtime+pdtrad2 - ! ================================================================ - - ! ================================================================ - REAL, INTENT (IN) :: longi, gmtime, pdtrad1, pdtrad2 - REAL lat(klon), long(klon), pmu0(klon), frac(klon) - ! ================================================================ - INTEGER i - REAL gmtime1, gmtime2 - REAL pi_local, deux_pi_local, incl - REAL omega1, omega2, omega - ! omega1, omega2 : temps 1 et 2 exprime en radian avec 0 a midi. - ! omega : heure en radian du coucher de soleil - ! -omega est donc l'heure en radian de lever du soleil - REAL omegadeb, omegafin - REAL zfrac1, zfrac2, z1_mu, z2_mu - REAL lat_sun ! declinaison en radian - REAL lon_sun ! longitude solaire en radian - REAL latr ! latitude du pt de grille en radian - ! ================================================================ - - pi_local = 4.0*atan(1.0) - deux_pi_local = 2.0*pi_local - incl = r_incl*pi_local/180. - - lon_sun = longi*pi_local/180.0 - lat_sun = asin(sin(lon_sun)*sin(incl)) - - gmtime1 = gmtime*86400. + pdtrad1 - gmtime2 = gmtime*86400. + pdtrad2 - - DO i = 1, klon - - latr = lat(i)*pi_local/180. - - omega = 0.0 !--nuit polaire - - IF (latr>=(pi_local/2.-lat_sun) .OR. latr<=(-pi_local/2.-lat_sun)) THEN - omega = pi_local ! journee polaire - END IF - - IF (latr<(pi_local/2.+lat_sun) .AND. latr>(-pi_local/2.+lat_sun) .AND. & - latr<(pi_local/2.-lat_sun) .AND. latr>(-pi_local/2.-lat_sun)) THEN - omega = -tan(latr)*tan(lat_sun) - omega = acos(omega) - END IF - - omega1 = gmtime1 + long(i)*86400.0/360.0 - omega1 = omega1/86400.0*deux_pi_local - omega1 = mod(omega1+deux_pi_local, deux_pi_local) - omega1 = omega1 - pi_local - - omega2 = gmtime2 + long(i)*86400.0/360.0 - omega2 = omega2/86400.0*deux_pi_local - omega2 = mod(omega2+deux_pi_local, deux_pi_local) - omega2 = omega2 - pi_local - - IF (omega1<=omega2) THEN !--on est dans la meme journee locale - - IF (omega2<=-omega .OR. omega1>=omega .OR. omega<1E-5) THEN !--nuit - frac(i) = 0.0 - pmu0(i) = 0.0 - ELSE !--jour+nuit/jour - omegadeb = max(-omega, omega1) - omegafin = min(omega, omega2) - frac(i) = (omegafin-omegadeb)/(omega2-omega1) - pmu0(i) = sin(latr)*sin(lat_sun) + cos(latr)*cos(lat_sun)*(sin( & - omegafin)-sin(omegadeb))/(omegafin-omegadeb) - END IF - - ELSE !---omega1 GT omega2 -- a cheval sur deux journees - - ! -------------------entre omega1 et pi - IF (omega1>=omega) THEN !--nuit - zfrac1 = 0.0 - z1_mu = 0.0 - ELSE !--jour+nuit - omegadeb = max(-omega, omega1) - omegafin = omega - zfrac1 = omegafin - omegadeb - z1_mu = sin(latr)*sin(lat_sun) + cos(latr)*cos(lat_sun)*(sin(omegafin & - )-sin(omegadeb))/(omegafin-omegadeb) - END IF - ! ---------------------entre -pi et omega2 - IF (omega2<=-omega) THEN !--nuit - zfrac2 = 0.0 - z2_mu = 0.0 - ELSE !--jour+nuit - omegadeb = -omega - omegafin = min(omega, omega2) - zfrac2 = omegafin - omegadeb - z2_mu = sin(latr)*sin(lat_sun) + cos(latr)*cos(lat_sun)*(sin(omegafin & - )-sin(omegadeb))/(omegafin-omegadeb) - - END IF - ! -----------------------moyenne - frac(i) = (zfrac1+zfrac2)/(omega2+deux_pi_local-omega1) - pmu0(i) = (zfrac1*z1_mu+zfrac2*z2_mu)/max(zfrac1+zfrac2, 1.E-10) - - END IF !---comparaison omega1 et omega2 - - END DO - -END SUBROUTINE zenang -! =================================================================== -SUBROUTINE zenith(longi, gmtime, lat, long, pmu0, fract) - USE dimphy - USE yomcst_mod_h -IMPLICIT NONE - - ! Auteur(s): Z.X. Li (LMD/ENS) - - ! Objet: calculer le cosinus de l'angle zenithal du soleil en - ! connaissant la declinaison du soleil, la latitude et la - ! longitude du point sur la terre, et le temps universel - - ! Arguments d'entree: - ! longi : declinaison du soleil (en degres) - ! gmtime : temps universel en second qui varie entre 0 et 86400 - ! lat : latitude en degres - ! long : longitude en degres - ! Arguments de sortie: - ! pmu0 : cosinus de l'angle zenithal - - ! ==================================================================== - - ! ==================================================================== - REAL longi, gmtime - REAL lat(klon), long(klon), pmu0(klon), fract(klon) - ! ===================================================================== - INTEGER n - REAL zpi, zpir, omega, zgmtime - REAL incl, lat_sun, lon_sun - ! ---------------------------------------------------------------------- - zpi = 4.0*atan(1.0) - zpir = zpi/180.0 - zgmtime = gmtime*86400. - - incl = r_incl*zpir - - lon_sun = longi*zpir - lat_sun = asin(sin(lon_sun)*sin(incl)) - - ! --initialisation a la nuit - - DO n = 1, klon - pmu0(n) = 0. - fract(n) = 0.0 - END DO - - ! 1 degre en longitude = 240 secondes en temps - - DO n = 1, klon - omega = zgmtime + long(n)*86400.0/360.0 - omega = omega/86400.0*2.0*zpi - omega = mod(omega+2.0*zpi, 2.0*zpi) - omega = omega - zpi - pmu0(n) = sin(lat(n)*zpir)*sin(lat_sun) + cos(lat(n)*zpir)*cos(lat_sun)* & - cos(omega) - pmu0(n) = max(pmu0(n), 0.0) - IF (pmu0(n)>1.E-6) fract(n) = 1.0 - END DO - - RETURN -END SUBROUTINE zenith - -END MODULE orbite_mod Index: LMDZ6/trunk/libf/phylmd/orbite_mod.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/orbite_mod.f90 (revision 6048) +++ LMDZ6/trunk/libf/phylmd/orbite_mod.f90 (revision 6048) @@ -0,0 +1,307 @@ + +! $Header$ +!$gpum horizontal klon +MODULE orbite_mod + PRIVATE + + PUBLIC orbite, angle, zenang, zenith + + CONTAINS + +! ====================================================================== +SUBROUTINE orbite(xjour, longi, dist) + USE yomcst_mod_h, ONLY: r_peri, r_ecc +IMPLICIT NONE + ! ====================================================================== + ! Auteur(s): Z.X. Li (LMD/CNRS) (adapte du GCM du LMD) date: 19930818 + ! Objet: pour un jour donne, calculer la longitude vraie de la terre + ! (par rapport au point vernal-21 mars) dans son orbite solaire + ! calculer aussi la distance terre-soleil (unite astronomique) + ! ====================================================================== + ! Arguments: + ! xjour--INPUT--R- jour de l'annee a compter du 1er janvier + ! longi--OUTPUT-R- longitude vraie en degres par rapport au point + ! vernal (21 mars) en degres + ! dist---OUTPUT-R- distance terre-soleil (par rapport a la moyenne) + REAL xjour, longi, dist + ! ====================================================================== + + + ! -- Variables dynamiques locales + REAL pir, xl, xllp, xee, xse, xlam, dlamm, anm, ranm, anv, ranv + + pir = 4.0*atan(1.0)/180.0 + xl = r_peri + 180.0 + xllp = xl*pir + xee = r_ecc*r_ecc + xse = sqrt(1.0-xee) + xlam = (r_ecc/2.0+r_ecc*xee/8.0)*(1.0+xse)*sin(xllp) - & + xee/4.0*(0.5+xse)*sin(2.0*xllp) + r_ecc*xee/8.0*(1.0/3.0+xse)*sin(3.0* & + xllp) + xlam = 2.0*xlam/pir + dlamm = xlam + (xjour-81.0) + anm = dlamm - xl + ranm = anm*pir + xee = xee*r_ecc + ranv = ranm + (2.0*r_ecc-xee/4.0)*sin(ranm) + 5.0/4.0*r_ecc*r_ecc*sin(2.0* & + ranm) + 13.0/12.0*xee*sin(3.0*ranm) + + anv = ranv/pir + longi = anv + xl + + dist = (1-r_ecc*r_ecc)/(1+r_ecc*cos(pir*(longi-(r_peri+180.0)))) + RETURN +END SUBROUTINE orbite +! ====================================================================== +SUBROUTINE angle(longi, lati, frac, muzero) + USE dimphy + USE yomcst_mod_h +IMPLICIT NONE + ! ====================================================================== + ! Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818 + ! Objet: Calculer la duree d'ensoleillement pour un jour et la hauteur + ! du soleil (cosinus de l'angle zinithal) moyenne sur la journee + ! ====================================================================== + ! Arguments: + ! longi----INPUT-R- la longitude vraie de la terre dans son plan + ! solaire a partir de l'equinoxe de printemps (degre) + ! lati-----INPUT-R- la latitude d'un point sur la terre (degre) + ! frac-----OUTPUT-R la duree d'ensoleillement dans la journee divisee + ! par 24 heures (unite en fraction de 0 a 1) + ! muzero---OUTPUT-R la moyenne du cosinus de l'angle zinithal sur + ! la journee (0 a 1) + ! ====================================================================== + REAL longi + REAL lati(klon), frac(klon), muzero(klon) + + REAL lat, omega, lon_sun, lat_sun + REAL pi_local, incl + INTEGER i + + pi_local = 4.0*atan(1.0) + incl = r_incl*pi_local/180. + + lon_sun = longi*pi_local/180.0 + lat_sun = asin(sin(lon_sun)*sin(incl)) + + DO i = 1, klon + lat = lati(i)*pi_local/180.0 + + IF (lat>=(pi_local/2.+lat_sun) .OR. lat<=(-pi_local/2.+lat_sun)) THEN + omega = 0.0 ! nuit polaire + ELSE IF (lat>=(pi_local/2.-lat_sun) .OR. lat<=(-pi_local/2.-lat_sun)) & + THEN + omega = pi_local ! journee polaire + ELSE + omega = -tan(lat)*tan(lat_sun) + omega = acos(omega) + END IF + + frac(i) = omega/pi_local + + IF (omega>0.0) THEN + muzero(i) = sin(lat)*sin(lat_sun) + cos(lat)*cos(lat_sun)*sin(omega)/ & + omega + ELSE + muzero(i) = 0.0 + END IF + END DO + + RETURN +END SUBROUTINE angle +! ==================================================================== +SUBROUTINE zenang(longi, gmtime, pdtrad1, pdtrad2, lat, long, pmu0, frac) + USE dimphy + USE yomcst_mod_h +IMPLICIT NONE + ! ============================================================= + ! Auteur : O. Boucher (LMD/CNRS) + ! d'apres les routines zenith et angle de Z.X. Li + ! Objet : calculer les valeurs moyennes du cos de l'angle zenithal + ! et l'ensoleillement moyen entre gmtime1 et gmtime2 + ! connaissant la declinaison, la latitude et la longitude. + ! Rque : Different de la routine angle en ce sens que zenang + ! fournit des moyennes de pmu0 et non des valeurs + ! instantanees, du coup frac prend toutes les valeurs + ! entre 0 et 1. La routine integre entre gmtime+pdtrad1 et + ! gmtime+pdtrad2 avec pdtrad1 et pdtrad2 exprimes en secondes. + ! Date : premiere version le 13 decembre 1994 + ! revu pour GCM le 30 septembre 1996 + ! revu le 3 septembre 2015 pour les bornes de l'integrale + ! =============================================================== + ! longi : la longitude vraie de la terre dans son plan + ! solaire a partir de l'equinoxe de printemps (degre) + ! gmtime : temps universel en fraction de jour + ! pdtrad1 : borne inferieure du pas de temps du rayonnement (secondes) + ! pdtrad2 : borne inferieure du pas de temps du rayonnement (secondes) + ! pdtrad2-pdtrad1 correspond a pdtrad, le pas de temps du rayonnement (secondes) + ! lat------INPUT : latitude en degres + ! long-----INPUT : longitude en degres + ! pmu0-----OUTPUT: angle zenithal moyen entre gmtime+pdtrad1 et gmtime+pdtrad2 + ! frac-----OUTPUT: ensoleillement moyen entre gmtime+pdtrad1 et gmtime+pdtrad2 + ! ================================================================ + + ! ================================================================ + REAL, INTENT (IN) :: longi, gmtime, pdtrad1, pdtrad2 + REAL lat(klon), long(klon), pmu0(klon), frac(klon) + ! ================================================================ + INTEGER i + REAL gmtime1, gmtime2 + REAL pi_local, deux_pi_local, incl + REAL omega1, omega2, omega + ! omega1, omega2 : temps 1 et 2 exprime en radian avec 0 a midi. + ! omega : heure en radian du coucher de soleil + ! -omega est donc l'heure en radian de lever du soleil + REAL omegadeb, omegafin + REAL zfrac1, zfrac2, z1_mu, z2_mu + REAL lat_sun ! declinaison en radian + REAL lon_sun ! longitude solaire en radian + REAL latr ! latitude du pt de grille en radian + ! ================================================================ + + pi_local = 4.0*atan(1.0) + deux_pi_local = 2.0*pi_local + incl = r_incl*pi_local/180. + + lon_sun = longi*pi_local/180.0 + lat_sun = asin(sin(lon_sun)*sin(incl)) + + gmtime1 = gmtime*86400. + pdtrad1 + gmtime2 = gmtime*86400. + pdtrad2 + + DO i = 1, klon + + latr = lat(i)*pi_local/180. + + omega = 0.0 !--nuit polaire + + IF (latr>=(pi_local/2.-lat_sun) .OR. latr<=(-pi_local/2.-lat_sun)) THEN + omega = pi_local ! journee polaire + END IF + + IF (latr<(pi_local/2.+lat_sun) .AND. latr>(-pi_local/2.+lat_sun) .AND. & + latr<(pi_local/2.-lat_sun) .AND. latr>(-pi_local/2.-lat_sun)) THEN + omega = -tan(latr)*tan(lat_sun) + omega = acos(omega) + END IF + + omega1 = gmtime1 + long(i)*86400.0/360.0 + omega1 = omega1/86400.0*deux_pi_local + omega1 = mod(omega1+deux_pi_local, deux_pi_local) + omega1 = omega1 - pi_local + + omega2 = gmtime2 + long(i)*86400.0/360.0 + omega2 = omega2/86400.0*deux_pi_local + omega2 = mod(omega2+deux_pi_local, deux_pi_local) + omega2 = omega2 - pi_local + + IF (omega1<=omega2) THEN !--on est dans la meme journee locale + + IF (omega2<=-omega .OR. omega1>=omega .OR. omega<1E-5) THEN !--nuit + frac(i) = 0.0 + pmu0(i) = 0.0 + ELSE !--jour+nuit/jour + omegadeb = max(-omega, omega1) + omegafin = min(omega, omega2) + frac(i) = (omegafin-omegadeb)/(omega2-omega1) + pmu0(i) = sin(latr)*sin(lat_sun) + cos(latr)*cos(lat_sun)*(sin( & + omegafin)-sin(omegadeb))/(omegafin-omegadeb) + END IF + + ELSE !---omega1 GT omega2 -- a cheval sur deux journees + + ! -------------------entre omega1 et pi + IF (omega1>=omega) THEN !--nuit + zfrac1 = 0.0 + z1_mu = 0.0 + ELSE !--jour+nuit + omegadeb = max(-omega, omega1) + omegafin = omega + zfrac1 = omegafin - omegadeb + z1_mu = sin(latr)*sin(lat_sun) + cos(latr)*cos(lat_sun)*(sin(omegafin & + )-sin(omegadeb))/(omegafin-omegadeb) + END IF + ! ---------------------entre -pi et omega2 + IF (omega2<=-omega) THEN !--nuit + zfrac2 = 0.0 + z2_mu = 0.0 + ELSE !--jour+nuit + omegadeb = -omega + omegafin = min(omega, omega2) + zfrac2 = omegafin - omegadeb + z2_mu = sin(latr)*sin(lat_sun) + cos(latr)*cos(lat_sun)*(sin(omegafin & + )-sin(omegadeb))/(omegafin-omegadeb) + + END IF + ! -----------------------moyenne + frac(i) = (zfrac1+zfrac2)/(omega2+deux_pi_local-omega1) + pmu0(i) = (zfrac1*z1_mu+zfrac2*z2_mu)/max(zfrac1+zfrac2, 1.E-10) + + END IF !---comparaison omega1 et omega2 + + END DO + +END SUBROUTINE zenang +! =================================================================== +SUBROUTINE zenith(longi, gmtime, lat, long, pmu0, fract) + USE dimphy + USE yomcst_mod_h +IMPLICIT NONE + + ! Auteur(s): Z.X. Li (LMD/ENS) + + ! Objet: calculer le cosinus de l'angle zenithal du soleil en + ! connaissant la declinaison du soleil, la latitude et la + ! longitude du point sur la terre, et le temps universel + + ! Arguments d'entree: + ! longi : declinaison du soleil (en degres) + ! gmtime : temps universel en second qui varie entre 0 et 86400 + ! lat : latitude en degres + ! long : longitude en degres + ! Arguments de sortie: + ! pmu0 : cosinus de l'angle zenithal + + ! ==================================================================== + + ! ==================================================================== + REAL longi, gmtime + REAL lat(klon), long(klon), pmu0(klon), fract(klon) + ! ===================================================================== + INTEGER n + REAL zpi, zpir, omega, zgmtime + REAL incl, lat_sun, lon_sun + ! ---------------------------------------------------------------------- + zpi = 4.0*atan(1.0) + zpir = zpi/180.0 + zgmtime = gmtime*86400. + + incl = r_incl*zpir + + lon_sun = longi*zpir + lat_sun = asin(sin(lon_sun)*sin(incl)) + + ! --initialisation a la nuit + + DO n = 1, klon + pmu0(n) = 0. + fract(n) = 0.0 + END DO + + ! 1 degre en longitude = 240 secondes en temps + + DO n = 1, klon + omega = zgmtime + long(n)*86400.0/360.0 + omega = omega/86400.0*2.0*zpi + omega = mod(omega+2.0*zpi, 2.0*zpi) + omega = omega - zpi + pmu0(n) = sin(lat(n)*zpir)*sin(lat_sun) + cos(lat(n)*zpir)*cos(lat_sun)* & + cos(omega) + pmu0(n) = max(pmu0(n), 0.0) + IF (pmu0(n)>1.E-6) fract(n) = 1.0 + END DO + + RETURN +END SUBROUTINE zenith + +END MODULE orbite_mod Index: LMDZ6/trunk/libf/phylmd/orografi.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/orografi.f90 (revision 6047) +++ (revision ) @@ -1,1693 +1,0 @@ - -! $Id$ -!$gpum horizontal klon nlon kfdia -MODULE orografi_mod - PRIVATE - - PUBLIC drag_noro, orodrag, orosetup, gwstress, gwprofil, lift_noro, orolift, sugwd - -CONTAINS - -SUBROUTINE drag_noro(nlon, nlev, dtime, paprs, pplay, pmea, pstd, psig, pgam, & - pthe, ppic, pval, kgwd, kdx, ktest, t, u, v, pulow, pvlow, pustr, pvstr, & - d_t, d_u, d_v) - - USE dimphy - USE yomcst_mod_h -IMPLICIT NONE - ! ====================================================================== - ! Auteur(s): F.Lott (LMD/CNRS) date: 19950201 - ! Objet: Frottement de la montagne Interface - ! ====================================================================== - ! Arguments: - ! dtime---input-R- pas d'integration (s) - ! paprs---input-R-pression pour chaque inter-couche (en Pa) - ! pplay---input-R-pression pour le mileu de chaque couche (en Pa) - ! t-------input-R-temperature (K) - ! u-------input-R-vitesse horizontale (m/s) - ! v-------input-R-vitesse horizontale (m/s) - - ! d_t-----output-R-increment de la temperature - ! d_u-----output-R-increment de la vitesse u - ! d_v-----output-R-increment de la vitesse v - ! ====================================================================== - - - ! ARGUMENTS - - INTEGER nlon, nlev - REAL dtime - REAL paprs(klon, klev+1) - REAL pplay(klon, klev) - REAL pmea(nlon), pstd(nlon), psig(nlon), pgam(nlon), pthe(nlon) - REAL ppic(nlon), pval(nlon) - REAL pulow(nlon), pvlow(nlon), pustr(nlon), pvstr(nlon) - REAL t(nlon, nlev), u(nlon, nlev), v(nlon, nlev) - REAL d_t(nlon, nlev), d_u(nlon, nlev), d_v(nlon, nlev) - - INTEGER i, k, kgwd, kdx(nlon), ktest(nlon) - - ! Variables locales: - - REAL zgeom(klon, klev) - REAL pdtdt(klon, klev), pdudt(klon, klev), pdvdt(klon, klev) - REAL pt(klon, klev), pu(klon, klev), pv(klon, klev) - REAL papmf(klon, klev), papmh(klon, klev+1) - - ! initialiser les variables de sortie (pour securite) - - DO i = 1, klon - pulow(i) = 0.0 - pvlow(i) = 0.0 - pustr(i) = 0.0 - pvstr(i) = 0.0 - END DO - DO k = 1, klev - DO i = 1, klon - d_t(i, k) = 0.0 - d_u(i, k) = 0.0 - d_v(i, k) = 0.0 - pdudt(i, k) = 0.0 - pdvdt(i, k) = 0.0 - pdtdt(i, k) = 0.0 - END DO - END DO - - ! preparer les variables d'entree (attention: l'ordre des niveaux - ! verticaux augmente du haut vers le bas) - - DO k = 1, klev - DO i = 1, klon - pt(i, k) = t(i, klev-k+1) - pu(i, k) = u(i, klev-k+1) - pv(i, k) = v(i, klev-k+1) - papmf(i, k) = pplay(i, klev-k+1) - END DO - END DO - DO k = 1, klev + 1 - DO i = 1, klon - papmh(i, k) = paprs(i, klev-k+2) - END DO - END DO - DO i = 1, klon - zgeom(i, klev) = rd*pt(i, klev)*log(papmh(i,klev+1)/papmf(i,klev)) - END DO - DO k = klev - 1, 1, -1 - DO i = 1, klon - zgeom(i, k) = zgeom(i, k+1) + rd*(pt(i,k)+pt(i,k+1))/2.0*log(papmf(i,k+ & - 1)/papmf(i,k)) - END DO - END DO - - ! appeler la routine principale - - CALL orodrag(klon, klev, kgwd, kdx, ktest, dtime, papmh, papmf, zgeom, pt, & - pu, pv, pmea, pstd, psig, pgam, pthe, ppic, pval, pulow, pvlow, pdudt, & - pdvdt, pdtdt) - - DO k = 1, klev - DO i = 1, klon - d_u(i, klev+1-k) = dtime*pdudt(i, k) - d_v(i, klev+1-k) = dtime*pdvdt(i, k) - d_t(i, klev+1-k) = dtime*pdtdt(i, k) - pustr(i) = pustr(i) & ! IM BUG . - ! +rg*pdudt(i,k)*(papmh(i,k+1)-papmh(i,k)) - +pdudt(i, k)*(papmh(i,k+1)-papmh(i,k))/rg - pvstr(i) = pvstr(i) & ! IM BUG . - ! +rg*pdvdt(i,k)*(papmh(i,k+1)-papmh(i,k)) - +pdvdt(i, k)*(papmh(i,k+1)-papmh(i,k))/rg - END DO - END DO - - RETURN -END SUBROUTINE drag_noro -SUBROUTINE orodrag(nlon, nlev, kgwd, kdx, ktest, ptsphy, paphm1, papm1, & - pgeom1, ptm1, pum1, pvm1, pmea, pstd, psig, pgamma, ptheta, ppic, pval & - ! outputs - , pulow, pvlow, pvom, pvol, pte) - - USE yomcst_mod_h - USE dimphy - USE yoegwd_mod_h - IMPLICIT NONE - - - - ! **** *gwdrag* - does the gravity wave parametrization. - - ! purpose. - ! -------- - - ! this routine computes the physical tendencies of the - ! prognostic variables u,v and t due to vertical transports by - ! subgridscale orographically excited gravity waves - - ! ** interface. - ! ---------- - ! called from *callpar*. - - ! the routine takes its input from the long-term storage: - ! u,v,t and p at t-1. - - ! explicit arguments : - ! -------------------- - ! ==== inputs === - ! ==== outputs === - - ! implicit arguments : none - ! -------------------- - - ! implicit logical (l) - - ! method. - ! ------- - - ! externals. - ! ---------- - INTEGER ismin, ismax - EXTERNAL ismin, ismax - - ! reference. - ! ---------- - - ! author. - ! ------- - ! m.miller + b.ritter e.c.m.w.f. 15/06/86. - - ! f.lott + m. miller e.c.m.w.f. 22/11/94 - ! ----------------------------------------------------------------------- - - ! * 0.1 arguments - ! --------- - - - ! ym integer nlon, nlev, klevm1 - INTEGER nlon, nlev - INTEGER kgwd, jl, ilevp1, jk, ji - REAL zdelp, ztemp, zforc, ztend - REAL rover, zb, zc, zconb, zabsv - REAL zzd1, ratio, zbet, zust, zvst, zdis - REAL pte(nlon, nlev), pvol(nlon, nlev), pvom(nlon, nlev), pulow(klon), & - pvlow(klon) - REAL pum1(nlon, nlev), pvm1(nlon, nlev), ptm1(nlon, nlev), pmea(nlon), & - pstd(nlon), psig(nlon), pgamma(nlon), ptheta(nlon), ppic(nlon), & - pval(nlon), pgeom1(nlon, nlev), papm1(nlon, nlev), paphm1(nlon, nlev+1) - - INTEGER kdx(nlon), ktest(nlon) - ! ----------------------------------------------------------------------- - - ! * 0.2 local arrays - ! ------------ - INTEGER isect(klon), icrit(klon), ikcrith(klon), ikenvh(klon), iknu(klon), & - iknu2(klon), ikcrit(klon), ikhlim(klon) - - REAL ztau(klon, klev+1), ztauf(klon, klev+1), zstab(klon, klev+1), & - zvph(klon, klev+1), zrho(klon, klev+1), zri(klon, klev+1), & - zpsi(klon, klev+1), zzdep(klon, klev) - REAL zdudt(klon), zdvdt(klon), zdtdt(klon), zdedt(klon), zvidis(klon), & - znu(klon), zd1(klon), zd2(klon), zdmod(klon) - REAL ztmst, ptsphy, zrtmst - - ! ------------------------------------------------------------------ - - ! * 1. initialization - ! -------------- - - - ! ------------------------------------------------------------------ - - ! * 1.1 computational constants - ! ----------------------- - - - ! ztmst=twodt - ! if(nstep.eq.nstart) ztmst=0.5*twodt - ! ym klevm1=klev-1 - ztmst = ptsphy - zrtmst = 1./ztmst - - ! ------------------------------------------------------------------ - - ! * 1.3 check whether row contains point for printing - ! --------------------------------------------- - - - ! ------------------------------------------------------------------ - - ! * 2. precompute basic state variables. - ! * ---------- ----- ----- ---------- - ! * define low level wind, project winds in plane of - ! * low level wind, determine sector in which to take - ! * the variance and set indicator for critical levels. - - - - - CALL orosetup(nlon, ktest, ikcrit, ikcrith, icrit, ikenvh, iknu, iknu2, & - paphm1, papm1, pum1, pvm1, ptm1, pgeom1, pstd, zrho, zri, zstab, ztau, & - zvph, zpsi, zzdep, pulow, pvlow, ptheta, pgamma, pmea, ppic, pval, znu, & - zd1, zd2, zdmod) - - ! *********************************************************** - - - ! * 3. compute low level stresses using subcritical and - ! * supercritical forms.computes anisotropy coefficient - ! * as measure of orographic twodimensionality. - - - CALL gwstress(nlon, nlev, ktest, icrit, ikenvh, iknu, zrho, zstab, zvph, & - pstd, psig, pmea, ppic, ztau, pgeom1, zdmod) - - ! * 4. compute stress profile. - ! * ------- ------ -------- - - - - CALL gwprofil(nlon, nlev, kgwd, kdx, ktest, ikcrith, icrit, paphm1, zrho, & - zstab, zvph, zri, ztau, zdmod, psig, pstd) - - ! * 5. compute tendencies. - ! * ------------------- - - - ! explicit solution at all levels for the gravity wave - ! implicit solution for the blocked levels - - DO jl = kidia, kfdia - zvidis(jl) = 0.0 - zdudt(jl) = 0.0 - zdvdt(jl) = 0.0 - zdtdt(jl) = 0.0 - END DO - - ilevp1 = klev + 1 - - - DO jk = 1, klev - - - ! do 523 jl=1,kgwd - ! ji=kdx(jl) - ! Modif vectorisation 02/04/2004 - DO ji = kidia, kfdia - IF (ktest(ji)==1) THEN - - zdelp = paphm1(ji, jk+1) - paphm1(ji, jk) - ztemp = -rg*(ztau(ji,jk+1)-ztau(ji,jk))/(zvph(ji,ilevp1)*zdelp) - zdudt(ji) = (pulow(ji)*zd1(ji)-pvlow(ji)*zd2(ji))*ztemp/zdmod(ji) - zdvdt(ji) = (pvlow(ji)*zd1(ji)+pulow(ji)*zd2(ji))*ztemp/zdmod(ji) - - ! controle des overshoots: - - zforc = sqrt(zdudt(ji)**2+zdvdt(ji)**2) + 1.E-12 - ztend = sqrt(pum1(ji,jk)**2+pvm1(ji,jk)**2)/ztmst + 1.E-12 - rover = 0.25 - IF (zforc>=rover*ztend) THEN - zdudt(ji) = rover*ztend/zforc*zdudt(ji) - zdvdt(ji) = rover*ztend/zforc*zdvdt(ji) - END IF - - ! fin du controle des overshoots - - IF (jk>=ikenvh(ji)) THEN - zb = 1.0 - 0.18*pgamma(ji) - 0.04*pgamma(ji)**2 - zc = 0.48*pgamma(ji) + 0.3*pgamma(ji)**2 - zconb = 2.*ztmst*gkwake*psig(ji)/(4.*pstd(ji)) - zabsv = sqrt(pum1(ji,jk)**2+pvm1(ji,jk)**2)/2. - zzd1 = zb*cos(zpsi(ji,jk))**2 + zc*sin(zpsi(ji,jk))**2 - ratio = (cos(zpsi(ji,jk))**2+pgamma(ji)*sin(zpsi(ji, & - jk))**2)/(pgamma(ji)*cos(zpsi(ji,jk))**2+sin(zpsi(ji,jk))**2) - zbet = max(0., 2.-1./ratio)*zconb*zzdep(ji, jk)*zzd1*zabsv - - ! simplement oppose au vent - - zdudt(ji) = -pum1(ji, jk)/ztmst - zdvdt(ji) = -pvm1(ji, jk)/ztmst - - ! projection dans la direction de l'axe principal de l'orographie - ! mod zdudt(ji)=-(pum1(ji,jk)*cos(ptheta(ji)*rpi/180.) - ! mod * +pvm1(ji,jk)*sin(ptheta(ji)*rpi/180.)) - ! mod * *cos(ptheta(ji)*rpi/180.)/ztmst - ! mod zdvdt(ji)=-(pum1(ji,jk)*cos(ptheta(ji)*rpi/180.) - ! mod * +pvm1(ji,jk)*sin(ptheta(ji)*rpi/180.)) - ! mod * *sin(ptheta(ji)*rpi/180.)/ztmst - zdudt(ji) = zdudt(ji)*(zbet/(1.+zbet)) - zdvdt(ji) = zdvdt(ji)*(zbet/(1.+zbet)) - END IF - pvom(ji, jk) = zdudt(ji) - pvol(ji, jk) = zdvdt(ji) - zust = pum1(ji, jk) + ztmst*zdudt(ji) - zvst = pvm1(ji, jk) + ztmst*zdvdt(ji) - zdis = 0.5*(pum1(ji,jk)**2+pvm1(ji,jk)**2-zust**2-zvst**2) - zdedt(ji) = zdis/ztmst - zvidis(ji) = zvidis(ji) + zdis*zdelp - zdtdt(ji) = zdedt(ji)/rcpd - ! pte(ji,jk)=zdtdt(ji) - - ! ENCORE UN TRUC POUR EVITER LES EXPLOSIONS - - pte(ji, jk) = 0.0 - - END IF - END DO - - END DO - - - RETURN -END SUBROUTINE orodrag -SUBROUTINE orosetup(nlon, ktest, kkcrit, kkcrith, kcrit, kkenvh, kknu, kknu2, & - paphm1, papm1, pum1, pvm1, ptm1, pgeom1, pstd, prho, pri, pstab, ptau, & - pvph, ppsi, pzdep, pulow, pvlow, ptheta, pgamma, pmea, ppic, pval, pnu, & - pd1, pd2, pdmod) - - ! **** *gwsetup* - - ! purpose. - ! -------- - - ! ** interface. - ! ---------- - ! from *orodrag* - - ! explicit arguments : - ! -------------------- - ! ==== inputs === - ! ==== outputs === - - ! implicit arguments : none - ! -------------------- - - ! method. - ! ------- - - - ! externals. - ! ---------- - - - ! reference. - ! ---------- - - ! see ecmwf research department documentation of the "i.f.s." - - ! author. - ! ------- - - ! modifications. - ! -------------- - ! f.lott for the new-gwdrag scheme november 1993 - - ! ----------------------------------------------------------------------- -USE yoegwd_mod_h - USE dimphy - USE yomcst_mod_h -IMPLICIT NONE - - - - - ! ----------------------------------------------------------------------- - - ! * 0.1 arguments - ! --------- - - INTEGER nlon - INTEGER jl, jk - REAL zdelp - - INTEGER kkcrit(nlon), kkcrith(nlon), kcrit(nlon), ktest(nlon), kkenvh(nlon) - - - REAL paphm1(nlon, klev+1), papm1(nlon, klev), pum1(nlon, klev), & - pvm1(nlon, klev), ptm1(nlon, klev), pgeom1(nlon, klev), & - prho(nlon, klev+1), pri(nlon, klev+1), pstab(nlon, klev+1), & - ptau(nlon, klev+1), pvph(nlon, klev+1), ppsi(nlon, klev+1), & - pzdep(nlon, klev) - REAL pulow(nlon), pvlow(nlon), ptheta(nlon), pgamma(nlon), pnu(nlon), & - pd1(nlon), pd2(nlon), pdmod(nlon) - REAL pstd(nlon), pmea(nlon), ppic(nlon), pval(nlon) - - ! ----------------------------------------------------------------------- - - ! * 0.2 local arrays - ! ------------ - - - INTEGER ilevm1, ilevm2, ilevh - REAL zcons1, zcons2, zcons3, zhgeo - REAL zu, zphi, zvt1, zvt2, zst, zvar, zdwind, zwind - REAL zstabm, zstabp, zrhom, zrhop, alpha - REAL zggeenv, zggeom1, zgvar - LOGICAL lo - LOGICAL ll1(klon, klev+1) - INTEGER kknu(klon), kknu2(klon), kknub(klon), kknul(klon), kentp(klon), & - ncount(klon) - - REAL zhcrit(klon, klev), zvpf(klon, klev), zdp(klon, klev) - REAL znorm(klon), zb(klon), zc(klon), zulow(klon), zvlow(klon), znup(klon), & - znum(klon) - - ! ------------------------------------------------------------------ - - ! * 1. initialization - ! -------------- - - ! print *,' entree gwsetup' - - ! ------------------------------------------------------------------ - - ! * 1.1 computational constants - ! ----------------------- - - - ilevm1 = klev - 1 - ilevm2 = klev - 2 - ilevh = klev/3 - - zcons1 = 1./rd - ! old zcons2=g**2/cpd - zcons2 = rg**2/rcpd - ! old zcons3=1.5*api - zcons3 = 1.5*rpi - - ! ------------------------------------------------------------------ - - ! * 2. - ! -------------- - - - ! ------------------------------------------------------------------ - - ! * 2.1 define low level wind, project winds in plane of - ! * low level wind, determine sector in which to take - ! * the variance and set indicator for critical levels. - - - - DO jl = kidia, kfdia - kknu(jl) = klev - kknu2(jl) = klev - kknub(jl) = klev - kknul(jl) = klev - pgamma(jl) = max(pgamma(jl), gtsec) - ll1(jl, klev+1) = .FALSE. - END DO - - ! Ajouter une initialisation (L. Li, le 23fev99): - - DO jk = klev, ilevh, -1 - DO jl = kidia, kfdia - ll1(jl, jk) = .FALSE. - END DO - END DO - - ! * define top of low level flow - ! ---------------------------- - DO jk = klev, ilevh, -1 - DO jl = kidia, kfdia - lo = (paphm1(jl,jk)/paphm1(jl,klev+1)) >= gsigcr - IF (lo) THEN - kkcrit(jl) = jk - END IF - zhcrit(jl, jk) = ppic(jl) - zhgeo = pgeom1(jl, jk)/rg - ll1(jl, jk) = (zhgeo>zhcrit(jl,jk)) - IF (ll1(jl,jk) .NEQV. ll1(jl,jk+1)) THEN - kknu(jl) = jk - END IF - IF (.NOT. ll1(jl,ilevh)) kknu(jl) = ilevh - END DO - END DO - DO jk = klev, ilevh, -1 - DO jl = kidia, kfdia - zhcrit(jl, jk) = ppic(jl) - pval(jl) - zhgeo = pgeom1(jl, jk)/rg - ll1(jl, jk) = (zhgeo>zhcrit(jl,jk)) - IF (ll1(jl,jk) .NEQV. ll1(jl,jk+1)) THEN - kknu2(jl) = jk - END IF - IF (.NOT. ll1(jl,ilevh)) kknu2(jl) = ilevh - END DO - END DO - DO jk = klev, ilevh, -1 - DO jl = kidia, kfdia - zhcrit(jl, jk) = amax1(ppic(jl)-pmea(jl), pmea(jl)-pval(jl)) - zhgeo = pgeom1(jl, jk)/rg - ll1(jl, jk) = (zhgeo>zhcrit(jl,jk)) - IF (ll1(jl,jk) .NEQV. ll1(jl,jk+1)) THEN - kknub(jl) = jk - END IF - IF (.NOT. ll1(jl,ilevh)) kknub(jl) = ilevh - END DO - END DO - - DO jl = kidia, kfdia - kknu(jl) = min(kknu(jl), nktopg) - kknu2(jl) = min(kknu2(jl), nktopg) - kknub(jl) = min(kknub(jl), nktopg) - kknul(jl) = klev - END DO - - ! c* initialize various arrays - - DO jl = kidia, kfdia - prho(jl, klev+1) = 0.0 - pstab(jl, klev+1) = 0.0 - pstab(jl, 1) = 0.0 - pri(jl, klev+1) = 9999.0 - ppsi(jl, klev+1) = 0.0 - pri(jl, 1) = 0.0 - pvph(jl, 1) = 0.0 - pulow(jl) = 0.0 - pvlow(jl) = 0.0 - zulow(jl) = 0.0 - zvlow(jl) = 0.0 - kkcrith(jl) = klev - kkenvh(jl) = klev - kentp(jl) = klev - kcrit(jl) = 1 - ncount(jl) = 0 - ll1(jl, klev+1) = .FALSE. - END DO - - ! * define low-level flow - ! --------------------- - - DO jk = klev, 2, -1 - DO jl = kidia, kfdia - IF (ktest(jl)==1) THEN - zdp(jl, jk) = papm1(jl, jk) - papm1(jl, jk-1) - prho(jl, jk) = 2.*paphm1(jl, jk)*zcons1/(ptm1(jl,jk)+ptm1(jl,jk-1)) - pstab(jl, jk) = 2.*zcons2/(ptm1(jl,jk)+ptm1(jl,jk-1))* & - (1.-rcpd*prho(jl,jk)*(ptm1(jl,jk)-ptm1(jl,jk-1))/zdp(jl,jk)) - pstab(jl, jk) = max(pstab(jl,jk), gssec) - END IF - END DO - END DO - - ! ******************************************************************** - - ! * define blocked flow - ! ------------------- - DO jk = klev, ilevh, -1 - DO jl = kidia, kfdia - IF (jk>=kknub(jl) .AND. jk<=kknul(jl)) THEN - pulow(jl) = pulow(jl) + pum1(jl, jk)*(paphm1(jl,jk+1)-paphm1(jl,jk)) - pvlow(jl) = pvlow(jl) + pvm1(jl, jk)*(paphm1(jl,jk+1)-paphm1(jl,jk)) - END IF - END DO - END DO - DO jl = kidia, kfdia - pulow(jl) = pulow(jl)/(paphm1(jl,kknul(jl)+1)-paphm1(jl,kknub(jl))) - pvlow(jl) = pvlow(jl)/(paphm1(jl,kknul(jl)+1)-paphm1(jl,kknub(jl))) - znorm(jl) = max(sqrt(pulow(jl)**2+pvlow(jl)**2), gvsec) - pvph(jl, klev+1) = znorm(jl) - END DO - - ! ******* setup orography axes and define plane of profiles ******* - - DO jl = kidia, kfdia - lo = (pulow(jl)=-gvsec) - IF (lo) THEN - zu = pulow(jl) + 2.*gvsec - ELSE - zu = pulow(jl) - END IF - zphi = atan(pvlow(jl)/zu) - ppsi(jl, klev+1) = ptheta(jl)*rpi/180. - zphi - zb(jl) = 1. - 0.18*pgamma(jl) - 0.04*pgamma(jl)**2 - zc(jl) = 0.48*pgamma(jl) + 0.3*pgamma(jl)**2 - pd1(jl) = zb(jl) - (zb(jl)-zc(jl))*(sin(ppsi(jl,klev+1))**2) - pd2(jl) = (zb(jl)-zc(jl))*sin(ppsi(jl,klev+1))*cos(ppsi(jl,klev+1)) - pdmod(jl) = sqrt(pd1(jl)**2+pd2(jl)**2) - END DO - - ! ************ define flow in plane of lowlevel stress ************* - - DO jk = 1, klev - DO jl = kidia, kfdia - IF (ktest(jl)==1) THEN - zvt1 = pulow(jl)*pum1(jl, jk) + pvlow(jl)*pvm1(jl, jk) - zvt2 = -pvlow(jl)*pum1(jl, jk) + pulow(jl)*pvm1(jl, jk) - zvpf(jl, jk) = (zvt1*pd1(jl)+zvt2*pd2(jl))/(znorm(jl)*pdmod(jl)) - END IF - ptau(jl, jk) = 0.0 - pzdep(jl, jk) = 0.0 - ppsi(jl, jk) = 0.0 - ll1(jl, jk) = .FALSE. - END DO - END DO - DO jk = 2, klev - DO jl = kidia, kfdia - IF (ktest(jl)==1) THEN - zdp(jl, jk) = papm1(jl, jk) - papm1(jl, jk-1) - pvph(jl, jk) = ((paphm1(jl,jk)-papm1(jl,jk-1))*zvpf(jl,jk)+(papm1(jl, & - jk)-paphm1(jl,jk))*zvpf(jl,jk-1))/zdp(jl, jk) - IF (pvph(jl,jk)=(kknub(jl)+1) .AND. jk<=kknul(jl)) THEN - zst = zcons2/ptm1(jl, jk)*(1.-rcpd*prho(jl,jk)*(ptm1(jl, & - jk)-ptm1(jl,jk-1))/zdp(jl,jk)) - pstab(jl, klev+1) = pstab(jl, klev+1) + zst*zdp(jl, jk) - pstab(jl, klev+1) = max(pstab(jl,klev+1), gssec) - prho(jl, klev+1) = prho(jl, klev+1) + paphm1(jl, jk)*2.*zdp(jl, jk) & - *zcons1/(ptm1(jl,jk)+ptm1(jl,jk-1)) - END IF - END IF - END DO - END DO - - DO jl = kidia, kfdia - pstab(jl, klev+1) = pstab(jl, klev+1)/(papm1(jl,kknul(jl))-papm1(jl,kknub & - (jl))) - prho(jl, klev+1) = prho(jl, klev+1)/(papm1(jl,kknul(jl))-papm1(jl,kknub( & - jl))) - zvar = pstd(jl) - END DO - - ! * 2.3 mean flow richardson number. - ! * and critical height for froude layer - - - DO jk = 2, klev - DO jl = kidia, kfdia - IF (ktest(jl)==1) THEN - zdwind = max(abs(zvpf(jl,jk)-zvpf(jl,jk-1)), gvsec) - pri(jl, jk) = pstab(jl, jk)*(zdp(jl,jk)/(rg*prho(jl,jk)*zdwind))**2 - pri(jl, jk) = max(pri(jl,jk), grcrit) - END IF - END DO - END DO - - - - ! * define top of 'envelope' layer - ! ---------------------------- - - DO jl = kidia, kfdia - pnu(jl) = 0.0 - znum(jl) = 0.0 - END DO - - DO jk = 2, klev - 1 - DO jl = kidia, kfdia - - IF (ktest(jl)==1) THEN - - IF (jk>=kknub(jl)) THEN - - znum(jl) = pnu(jl) - zwind = (pulow(jl)*pum1(jl,jk)+pvlow(jl)*pvm1(jl,jk))/ & - max(sqrt(pulow(jl)**2+pvlow(jl)**2), gvsec) - zwind = max(sqrt(zwind**2), gvsec) - zdelp = paphm1(jl, jk+1) - paphm1(jl, jk) - zstabm = sqrt(max(pstab(jl,jk),gssec)) - zstabp = sqrt(max(pstab(jl,jk+1),gssec)) - zrhom = prho(jl, jk) - zrhop = prho(jl, jk+1) - pnu(jl) = pnu(jl) + (zdelp/rg)*((zstabp/zrhop+zstabm/zrhom)/2.)/ & - zwind - IF ((znum(jl)<=gfrcrit) .AND. (pnu(jl)>gfrcrit) .AND. (kkenvh( & - jl)==klev)) kkenvh(jl) = jk - - END IF - - END IF - - END DO - END DO - - ! calculation of a dynamical mixing height for the breaking - ! of gravity waves: - - - DO jl = kidia, kfdia - znup(jl) = 0.0 - znum(jl) = 0.0 - END DO - - DO jk = klev - 1, 2, -1 - DO jl = kidia, kfdia - - IF (ktest(jl)==1) THEN - - znum(jl) = znup(jl) - zwind = (pulow(jl)*pum1(jl,jk)+pvlow(jl)*pvm1(jl,jk))/ & - max(sqrt(pulow(jl)**2+pvlow(jl)**2), gvsec) - zwind = max(sqrt(zwind**2), gvsec) - zdelp = paphm1(jl, jk+1) - paphm1(jl, jk) - zstabm = sqrt(max(pstab(jl,jk),gssec)) - zstabp = sqrt(max(pstab(jl,jk+1),gssec)) - zrhom = prho(jl, jk) - zrhop = prho(jl, jk+1) - znup(jl) = znup(jl) + (zdelp/rg)*((zstabp/zrhop+zstabm/zrhom)/2.)/ & - zwind - IF ((znum(jl)<=rpi/2.) .AND. (znup(jl)>rpi/2.) .AND. (kkcrith( & - jl)==klev)) kkcrith(jl) = jk - - END IF - - END DO - END DO - - DO jl = kidia, kfdia - kkcrith(jl) = min0(kkcrith(jl), kknu2(jl)) - kkcrith(jl) = max0(kkcrith(jl), ilevh*2) - END DO - - ! directional info for flow blocking ************************* - - DO jk = ilevh, klev - DO jl = kidia, kfdia - IF (jk>=kkenvh(jl)) THEN - lo = (pum1(jl,jk)=-gvsec) - IF (lo) THEN - zu = pum1(jl, jk) + 2.*gvsec - ELSE - zu = pum1(jl, jk) - END IF - zphi = atan(pvm1(jl,jk)/zu) - ppsi(jl, jk) = ptheta(jl)*rpi/180. - zphi - END IF - END DO - END DO - ! forms the vertical 'leakiness' ************************** - - alpha = 3. - - DO jk = ilevh, klev - DO jl = kidia, kfdia - IF (jk>=kkenvh(jl)) THEN - zggeenv = amax1(1., (pgeom1(jl,kkenvh(jl))+pgeom1(jl, & - kkenvh(jl)-1))/2.) - zggeom1 = amax1(pgeom1(jl,jk), 1.) - zgvar = amax1(pstd(jl)*rg, 1.) - ! mod pzdep(jl,jk)=sqrt((zggeenv-zggeom1)/(zggeom1+zgvar)) - pzdep(jl, jk) = (pgeom1(jl,kkenvh(jl)-1)-pgeom1(jl,jk))/ & - (pgeom1(jl,kkenvh(jl)-1)-pgeom1(jl,klev)) - END IF - END DO - END DO - - RETURN -END SUBROUTINE orosetup -SUBROUTINE gwstress(nlon, nlev, ktest, kcrit, kkenvh, kknu, prho, pstab, & - pvph, pstd, psig, pmea, ppic, ptau, pgeom1, pdmod) - - ! **** *gwstress* - - ! purpose. - ! -------- - - ! ** interface. - ! ---------- - ! call *gwstress* from *gwdrag* - - ! explicit arguments : - ! -------------------- - ! ==== inputs === - ! ==== outputs === - - ! implicit arguments : none - ! -------------------- - - ! method. - ! ------- - - - ! externals. - ! ---------- - - - ! reference. - ! ---------- - - ! see ecmwf research department documentation of the "i.f.s." - - ! author. - ! ------- - - ! modifications. - ! -------------- - ! f. lott put the new gwd on ifs 22/11/93 - - ! ----------------------------------------------------------------------- -USE yoegwd_mod_h - USE dimphy - USE yomcst_mod_h -IMPLICIT NONE - - - ! ----------------------------------------------------------------------- - - ! * 0.1 arguments - ! --------- - - INTEGER nlon, nlev - INTEGER kcrit(nlon), ktest(nlon), kkenvh(nlon), kknu(nlon) - - REAL prho(nlon, nlev+1), pstab(nlon, nlev+1), ptau(nlon, nlev+1), & - pvph(nlon, nlev+1), pgeom1(nlon, nlev), pstd(nlon) - - REAL psig(nlon) - REAL pmea(nlon), ppic(nlon) - REAL pdmod(nlon) - - ! ----------------------------------------------------------------------- - - ! * 0.2 local arrays - ! ------------ - INTEGER jl - REAL zblock, zvar, zeff - LOGICAL lo - - ! ----------------------------------------------------------------------- - - ! * 0.3 functions - ! --------- - ! ------------------------------------------------------------------ - - ! * 1. initialization - ! -------------- - - - ! * 3.1 gravity wave stress. - - - - DO jl = kidia, kfdia - IF (ktest(jl)==1) THEN - - ! effective mountain height above the blocked flow - - IF (kkenvh(jl)==klev) THEN - zblock = 0.0 - ELSE - zblock = (pgeom1(jl,kkenvh(jl))+pgeom1(jl,kkenvh(jl)+1))/2./rg - END IF - - zvar = ppic(jl) - pmea(jl) - zeff = amax1(0., zvar-zblock) - - ptau(jl, klev+1) = prho(jl, klev+1)*gkdrag*psig(jl)*zeff**2/4./ & - pstd(jl)*pvph(jl, klev+1)*pdmod(jl)*sqrt(pstab(jl,klev+1)) - - ! too small value of stress or low level flow include critical level - ! or low level flow: gravity wave stress nul. - - lo = (ptau(jl,klev+1)=kknu(jl)) .OR. & - (pvph(jl,klev+1)kkcrith(jl)) THEN - ptau(jl, jk) = ztau(jl, klev+1) - ! ENDIF - ! IF(JK.EQ.KKCRITH(JL)) THEN - ELSE - ptau(jl, jk) = grahilo*ztau(jl, klev+1) - END IF - END IF - END DO - - ! * 4.15 CONSTANT SHEAR STRESS UNTIL THE TOP OF THE - ! LOW LEVEL FLOW LAYER. - - - ! * 4.2 WAVE DISPLACEMENT AT NEXT LEVEL. - - - ! DO 421 ji=1,kgwd - ! jl=kdx(ji) - ! Modif vectorisation 02/04/2004 - DO jl = kidia, kfdia - IF (ktest(jl)==1) THEN - IF (jkkkcrith(jl)) THEN - - zdelp = paphm1(jl, jk) - paphm1(jl, klev+1) - zdelpt = paphm1(jl, kkcrith(jl)) - paphm1(jl, klev+1) - ptau(jl, jk) = ztau(jl, klev+1) + (ztau(jl,kkcrith(jl))-ztau(jl, & - klev+1))*zdelp/zdelpt - - END IF - - END IF - END DO - - ! REORGANISATION IN THE STRATOSPHERE - - ! DO 533 ji=1,kgwd - ! jl=kdx(ji) - ! Modif vectorisation 02/04/2004 - DO jl = kidia, kfdia - IF (ktest(jl)==1) THEN - - - IF (jknstra) THEN - - zdelp = paphm1(jl, jk) - paphm1(jl, kkcrith(jl)) - zdelpt = paphm1(jl, nstra) - paphm1(jl, kkcrith(jl)) - ptau(jl, jk) = ztau(jl, kkcrith(jl)) + (ztau(jl,nstra)-ztau(jl, & - kkcrith(jl)))*zdelp/zdelpt - - END IF - END IF - END DO - - - END DO - - - RETURN -END SUBROUTINE gwprofil -SUBROUTINE lift_noro(nlon, nlev, dtime, paprs, pplay, plat, pmea, pstd, ppic, & - ktest, t, u, v, pulow, pvlow, pustr, pvstr, d_t, d_u, d_v) - - USE dimphy - USE yomcst_mod_h -IMPLICIT NONE - ! ====================================================================== - ! Auteur(s): F.Lott (LMD/CNRS) date: 19950201 - ! Objet: Frottement de la montagne Interface - ! ====================================================================== - ! Arguments: - ! dtime---input-R- pas d'integration (s) - ! paprs---input-R-pression pour chaque inter-couche (en Pa) - ! pplay---input-R-pression pour le mileu de chaque couche (en Pa) - ! t-------input-R-temperature (K) - ! u-------input-R-vitesse horizontale (m/s) - ! v-------input-R-vitesse horizontale (m/s) - - ! d_t-----output-R-increment de la temperature - ! d_u-----output-R-increment de la vitesse u - ! d_v-----output-R-increment de la vitesse v - ! ====================================================================== - - - ! ARGUMENTS - - INTEGER nlon, nlev - REAL dtime - REAL paprs(klon, klev+1) - REAL pplay(klon, klev) - REAL plat(nlon), pmea(nlon) - REAL pstd(nlon) - REAL ppic(nlon) - REAL pulow(nlon), pvlow(nlon), pustr(nlon), pvstr(nlon) - REAL t(nlon, nlev), u(nlon, nlev), v(nlon, nlev) - REAL d_t(nlon, nlev), d_u(nlon, nlev), d_v(nlon, nlev) - - INTEGER i, k, ktest(nlon) - - ! Variables locales: - - REAL zgeom(klon, klev) - REAL pdtdt(klon, klev), pdudt(klon, klev), pdvdt(klon, klev) - REAL pt(klon, klev), pu(klon, klev), pv(klon, klev) - REAL papmf(klon, klev), papmh(klon, klev+1) - - ! initialiser les variables de sortie (pour securite) - - DO i = 1, klon - pulow(i) = 0.0 - pvlow(i) = 0.0 - pustr(i) = 0.0 - pvstr(i) = 0.0 - END DO - DO k = 1, klev - DO i = 1, klon - d_t(i, k) = 0.0 - d_u(i, k) = 0.0 - d_v(i, k) = 0.0 - pdudt(i, k) = 0.0 - pdvdt(i, k) = 0.0 - pdtdt(i, k) = 0.0 - END DO - END DO - - ! preparer les variables d'entree (attention: l'ordre des niveaux - ! verticaux augmente du haut vers le bas) - - DO k = 1, klev - DO i = 1, klon - pt(i, k) = t(i, klev-k+1) - pu(i, k) = u(i, klev-k+1) - pv(i, k) = v(i, klev-k+1) - papmf(i, k) = pplay(i, klev-k+1) - END DO - END DO - DO k = 1, klev + 1 - DO i = 1, klon - papmh(i, k) = paprs(i, klev-k+2) - END DO - END DO - DO i = 1, klon - zgeom(i, klev) = rd*pt(i, klev)*log(papmh(i,klev+1)/papmf(i,klev)) - END DO - DO k = klev - 1, 1, -1 - DO i = 1, klon - zgeom(i, k) = zgeom(i, k+1) + rd*(pt(i,k)+pt(i,k+1))/2.0*log(papmf(i,k+ & - 1)/papmf(i,k)) - END DO - END DO - - ! appeler la routine principale - - CALL orolift(klon, klev, ktest, dtime, papmh, zgeom, pt, pu, pv, plat, & - pmea, pstd, ppic, pulow, pvlow, pdudt, pdvdt, pdtdt) - - DO k = 1, klev - DO i = 1, klon - d_u(i, klev+1-k) = dtime*pdudt(i, k) - d_v(i, klev+1-k) = dtime*pdvdt(i, k) - d_t(i, klev+1-k) = dtime*pdtdt(i, k) - pustr(i) = pustr(i) & ! IM BUG . - ! +RG*pdudt(i,k)*(papmh(i,k+1)-papmh(i,k)) - +pdudt(i, k)*(papmh(i,k+1)-papmh(i,k))/rg - pvstr(i) = pvstr(i) & ! IM BUG . - ! +RG*pdvdt(i,k)*(papmh(i,k+1)-papmh(i,k)) - +pdvdt(i, k)*(papmh(i,k+1)-papmh(i,k))/rg - END DO - END DO - - RETURN -END SUBROUTINE lift_noro -SUBROUTINE orolift(nlon, nlev, ktest, ptsphy, paphm1, pgeom1, ptm1, pum1, & - pvm1, plat, pmea, pvaror, ppic & ! OUTPUTS - , pulow, pvlow, pvom, pvol, pte) - - - ! **** *OROLIFT: SIMULATE THE GEOSTROPHIC LIFT. - - ! PURPOSE. - ! -------- - - ! ** INTERFACE. - ! ---------- - ! CALLED FROM *lift_noro - ! ---------- - - ! AUTHOR. - ! ------- - ! F.LOTT LMD 22/11/95 - -USE yoegwd_mod_h - USE dimphy - USE yomcst_mod_h -IMPLICIT NONE - - - - ! ----------------------------------------------------------------------- - - ! * 0.1 ARGUMENTS - ! --------- - - - INTEGER nlon, nlev - REAL pte(nlon, nlev), pvol(nlon, nlev), pvom(nlon, nlev), pulow(nlon), & - pvlow(nlon) - REAL pum1(nlon, nlev), pvm1(nlon, nlev), ptm1(nlon, nlev), plat(nlon), & - pmea(nlon), pvaror(nlon), ppic(nlon), pgeom1(nlon, nlev), & - paphm1(nlon, nlev+1) - - INTEGER ktest(nlon) - REAL ptsphy - ! ----------------------------------------------------------------------- - - ! * 0.2 LOCAL ARRAYS - ! ------------ - LOGICAL lifthigh - ! ym integer klevm1, jl, ilevh, jk - INTEGER jl, ilevh, jk - REAL zcons1, ztmst, zrtmst, zpi, zhgeo - REAL zdelp, zslow, zsqua, zscav, zbet - INTEGER iknub(klon), iknul(klon) - LOGICAL ll1(klon, klev+1) - - REAL ztau(klon, klev+1), ztav(klon, klev+1), zrho(klon, klev+1) - REAL zdudt(klon), zdvdt(klon) - REAL zhcrit(klon, klev) - CHARACTER (LEN=20) :: modname = 'orografi' - CHARACTER (LEN=80) :: abort_message - ! ----------------------------------------------------------------------- - - ! * 1.1 INITIALIZATIONS - ! --------------- - - lifthigh = .FALSE. - - IF (nlon/=klon .OR. nlev/=klev) THEN - abort_message = 'pb dimension' - CALL abort_physic(modname, abort_message, 1) - END IF - zcons1 = 1./rd - ! ym KLEVM1=KLEV-1 - ztmst = ptsphy - zrtmst = 1./ztmst - zpi = acos(-1.) - - DO jl = kidia, kfdia - zrho(jl, klev+1) = 0.0 - pulow(jl) = 0.0 - pvlow(jl) = 0.0 - iknub(jl) = klev - iknul(jl) = klev - ilevh = klev/3 - ll1(jl, klev+1) = .FALSE. - DO jk = 1, klev - pvom(jl, jk) = 0.0 - pvol(jl, jk) = 0.0 - pte(jl, jk) = 0.0 - END DO - END DO - - - ! * 2.1 DEFINE LOW LEVEL WIND, PROJECT WINDS IN PLANE OF - ! * LOW LEVEL WIND, DETERMINE SECTOR IN WHICH TO TAKE - ! * THE VARIANCE AND SET INDICATOR FOR CRITICAL LEVELS. - - - - DO jk = klev, 1, -1 - DO jl = kidia, kfdia - IF (ktest(jl)==1) THEN - zhcrit(jl, jk) = amax1(ppic(jl)-pmea(jl), 100.) - zhgeo = pgeom1(jl, jk)/rg - ll1(jl, jk) = (zhgeo>zhcrit(jl,jk)) - IF (ll1(jl,jk) .NEQV. ll1(jl,jk+1)) THEN - iknub(jl) = jk - END IF - END IF - END DO - END DO - - DO jl = kidia, kfdia - IF (ktest(jl)==1) THEN - iknub(jl) = max(iknub(jl), klev/2) - iknul(jl) = max(iknul(jl), 2*klev/3) - IF (iknub(jl)>nktopg) iknub(jl) = nktopg - IF (iknub(jl)==nktopg) iknul(jl) = klev - IF (iknub(jl)==iknul(jl)) iknub(jl) = iknul(jl) - 1 - END IF - END DO - - ! do 2011 jl=kidia,kfdia - ! IF(KTEST(JL).EQ.1) THEN - ! print *,' iknul= ',iknul(jl),' iknub=',iknub(jl) - ! ENDIF - ! 2011 continue - - ! PRINT *,' DANS OROLIFT: 2010' - - DO jk = klev, 2, -1 - DO jl = kidia, kfdia - zrho(jl, jk) = 2.*paphm1(jl, jk)*zcons1/(ptm1(jl,jk)+ptm1(jl,jk-1)) - END DO - END DO - ! PRINT *,' DANS OROLIFT: 223' - - ! ******************************************************************** - - ! * DEFINE LOW LEVEL FLOW - ! ------------------- - DO jk = klev, 1, -1 - DO jl = kidia, kfdia - IF (ktest(jl)==1) THEN - IF (jk>=iknub(jl) .AND. jk<=iknul(jl)) THEN - pulow(jl) = pulow(jl) + pum1(jl, jk)*(paphm1(jl,jk+1)-paphm1(jl,jk) & - ) - pvlow(jl) = pvlow(jl) + pvm1(jl, jk)*(paphm1(jl,jk+1)-paphm1(jl,jk) & - ) - zrho(jl, klev+1) = zrho(jl, klev+1) + zrho(jl, jk)*(paphm1(jl,jk+1) & - -paphm1(jl,jk)) - END IF - END IF - END DO - END DO - DO jl = kidia, kfdia - IF (ktest(jl)==1) THEN - pulow(jl) = pulow(jl)/(paphm1(jl,iknul(jl)+1)-paphm1(jl,iknub(jl))) - pvlow(jl) = pvlow(jl)/(paphm1(jl,iknul(jl)+1)-paphm1(jl,iknub(jl))) - zrho(jl, klev+1) = zrho(jl, klev+1)/(paphm1(jl,iknul(jl)+1)-paphm1(jl, & - iknub(jl))) - END IF - END DO - - ! *********************************************************** - - ! * 3. COMPUTE MOUNTAIN LIFT - - - DO jl = kidia, kfdia - IF (ktest(jl)==1) THEN - ztau(jl, klev+1) = -gklift*zrho(jl, klev+1)*2.*romega* & ! * - ! (2*PVAROR(JL)+PMEA(JL))* - 2*pvaror(jl)*sin(zpi/180.*plat(jl))*pvlow(jl) - ztav(jl, klev+1) = gklift*zrho(jl, klev+1)*2.*romega* & ! * - ! (2*PVAROR(JL)+PMEA(JL))* - 2*pvaror(jl)*sin(zpi/180.*plat(jl))*pulow(jl) - ELSE - ztau(jl, klev+1) = 0.0 - ztav(jl, klev+1) = 0.0 - END IF - END DO - - ! * 4. COMPUTE LIFT PROFILE - ! * -------------------- - - - - DO jk = 1, klev - DO jl = kidia, kfdia - IF (ktest(jl)==1) THEN - ztau(jl, jk) = ztau(jl, klev+1)*paphm1(jl, jk)/paphm1(jl, klev+1) - ztav(jl, jk) = ztav(jl, klev+1)*paphm1(jl, jk)/paphm1(jl, klev+1) - ELSE - ztau(jl, jk) = 0.0 - ztav(jl, jk) = 0.0 - END IF - END DO - END DO - - - ! * 5. COMPUTE TENDENCIES. - ! * ------------------- - IF (lifthigh) THEN - ! PRINT *,' DANS OROLIFT: 500' - - ! EXPLICIT SOLUTION AT ALL LEVELS - - DO jk = 1, klev - DO jl = kidia, kfdia - IF (ktest(jl)==1) THEN - zdelp = paphm1(jl, jk+1) - paphm1(jl, jk) - zdudt(jl) = -rg*(ztau(jl,jk+1)-ztau(jl,jk))/zdelp - zdvdt(jl) = -rg*(ztav(jl,jk+1)-ztav(jl,jk))/zdelp - END IF - END DO - END DO - - ! PROJECT PERPENDICULARLY TO U NOT TO DESTROY ENERGY - - DO jk = 1, klev - DO jl = kidia, kfdia - IF (ktest(jl)==1) THEN - - zslow = sqrt(pulow(jl)**2+pvlow(jl)**2) - zsqua = amax1(sqrt(pum1(jl,jk)**2+pvm1(jl,jk)**2), gvsec) - zscav = -zdudt(jl)*pvm1(jl, jk) + zdvdt(jl)*pum1(jl, jk) - IF (zsqua>gvsec) THEN - pvom(jl, jk) = -zscav*pvm1(jl, jk)/zsqua**2 - pvol(jl, jk) = zscav*pum1(jl, jk)/zsqua**2 - ELSE - pvom(jl, jk) = 0.0 - pvol(jl, jk) = 0.0 - END IF - zsqua = sqrt(pum1(jl,jk)**2+pum1(jl,jk)**2) - IF (zsqua=rover*ztend) THEN + zdudt(ji) = rover*ztend/zforc*zdudt(ji) + zdvdt(ji) = rover*ztend/zforc*zdvdt(ji) + END IF + + ! fin du controle des overshoots + + IF (jk>=ikenvh(ji)) THEN + zb = 1.0 - 0.18*pgamma(ji) - 0.04*pgamma(ji)**2 + zc = 0.48*pgamma(ji) + 0.3*pgamma(ji)**2 + zconb = 2.*ztmst*gkwake*psig(ji)/(4.*pstd(ji)) + zabsv = sqrt(pum1(ji,jk)**2+pvm1(ji,jk)**2)/2. + zzd1 = zb*cos(zpsi(ji,jk))**2 + zc*sin(zpsi(ji,jk))**2 + ratio = (cos(zpsi(ji,jk))**2+pgamma(ji)*sin(zpsi(ji, & + jk))**2)/(pgamma(ji)*cos(zpsi(ji,jk))**2+sin(zpsi(ji,jk))**2) + zbet = max(0., 2.-1./ratio)*zconb*zzdep(ji, jk)*zzd1*zabsv + + ! simplement oppose au vent + + zdudt(ji) = -pum1(ji, jk)/ztmst + zdvdt(ji) = -pvm1(ji, jk)/ztmst + + ! projection dans la direction de l'axe principal de l'orographie + ! mod zdudt(ji)=-(pum1(ji,jk)*cos(ptheta(ji)*rpi/180.) + ! mod * +pvm1(ji,jk)*sin(ptheta(ji)*rpi/180.)) + ! mod * *cos(ptheta(ji)*rpi/180.)/ztmst + ! mod zdvdt(ji)=-(pum1(ji,jk)*cos(ptheta(ji)*rpi/180.) + ! mod * +pvm1(ji,jk)*sin(ptheta(ji)*rpi/180.)) + ! mod * *sin(ptheta(ji)*rpi/180.)/ztmst + zdudt(ji) = zdudt(ji)*(zbet/(1.+zbet)) + zdvdt(ji) = zdvdt(ji)*(zbet/(1.+zbet)) + END IF + pvom(ji, jk) = zdudt(ji) + pvol(ji, jk) = zdvdt(ji) + zust = pum1(ji, jk) + ztmst*zdudt(ji) + zvst = pvm1(ji, jk) + ztmst*zdvdt(ji) + zdis = 0.5*(pum1(ji,jk)**2+pvm1(ji,jk)**2-zust**2-zvst**2) + zdedt(ji) = zdis/ztmst + zvidis(ji) = zvidis(ji) + zdis*zdelp + zdtdt(ji) = zdedt(ji)/rcpd + ! pte(ji,jk)=zdtdt(ji) + + ! ENCORE UN TRUC POUR EVITER LES EXPLOSIONS + + pte(ji, jk) = 0.0 + + END IF + END DO + + END DO + + + RETURN +END SUBROUTINE orodrag +SUBROUTINE orosetup(nlon, ktest, kkcrit, kkcrith, kcrit, kkenvh, kknu, kknu2, & + paphm1, papm1, pum1, pvm1, ptm1, pgeom1, pstd, prho, pri, pstab, ptau, & + pvph, ppsi, pzdep, pulow, pvlow, ptheta, pgamma, pmea, ppic, pval, pnu, & + pd1, pd2, pdmod) + + ! **** *gwsetup* + + ! purpose. + ! -------- + + ! ** interface. + ! ---------- + ! from *orodrag* + + ! explicit arguments : + ! -------------------- + ! ==== inputs === + ! ==== outputs === + + ! implicit arguments : none + ! -------------------- + + ! method. + ! ------- + + + ! externals. + ! ---------- + + + ! reference. + ! ---------- + + ! see ecmwf research department documentation of the "i.f.s." + + ! author. + ! ------- + + ! modifications. + ! -------------- + ! f.lott for the new-gwdrag scheme november 1993 + + ! ----------------------------------------------------------------------- +USE yoegwd_mod_h + USE dimphy + USE yomcst_mod_h +IMPLICIT NONE + + + + + ! ----------------------------------------------------------------------- + + ! * 0.1 arguments + ! --------- + + INTEGER nlon + INTEGER jl, jk + REAL zdelp + + INTEGER kkcrit(nlon), kkcrith(nlon), kcrit(nlon), ktest(nlon), kkenvh(nlon) + + + REAL paphm1(nlon, klev+1), papm1(nlon, klev), pum1(nlon, klev), & + pvm1(nlon, klev), ptm1(nlon, klev), pgeom1(nlon, klev), & + prho(nlon, klev+1), pri(nlon, klev+1), pstab(nlon, klev+1), & + ptau(nlon, klev+1), pvph(nlon, klev+1), ppsi(nlon, klev+1), & + pzdep(nlon, klev) + REAL pulow(nlon), pvlow(nlon), ptheta(nlon), pgamma(nlon), pnu(nlon), & + pd1(nlon), pd2(nlon), pdmod(nlon) + REAL pstd(nlon), pmea(nlon), ppic(nlon), pval(nlon) + + ! ----------------------------------------------------------------------- + + ! * 0.2 local arrays + ! ------------ + + + INTEGER ilevm1, ilevm2, ilevh + REAL zcons1, zcons2, zcons3, zhgeo + REAL zu, zphi, zvt1, zvt2, zst, zvar, zdwind, zwind + REAL zstabm, zstabp, zrhom, zrhop, alpha + REAL zggeenv, zggeom1, zgvar + LOGICAL lo + LOGICAL ll1(klon, klev+1) + INTEGER kknu(klon), kknu2(klon), kknub(klon), kknul(klon), kentp(klon), & + ncount(klon) + + REAL zhcrit(klon, klev), zvpf(klon, klev), zdp(klon, klev) + REAL znorm(klon), zb(klon), zc(klon), zulow(klon), zvlow(klon), znup(klon), & + znum(klon) + + ! ------------------------------------------------------------------ + + ! * 1. initialization + ! -------------- + + ! print *,' entree gwsetup' + + ! ------------------------------------------------------------------ + + ! * 1.1 computational constants + ! ----------------------- + + + ilevm1 = klev - 1 + ilevm2 = klev - 2 + ilevh = klev/3 + + zcons1 = 1./rd + ! old zcons2=g**2/cpd + zcons2 = rg**2/rcpd + ! old zcons3=1.5*api + zcons3 = 1.5*rpi + + ! ------------------------------------------------------------------ + + ! * 2. + ! -------------- + + + ! ------------------------------------------------------------------ + + ! * 2.1 define low level wind, project winds in plane of + ! * low level wind, determine sector in which to take + ! * the variance and set indicator for critical levels. + + + + DO jl = kidia, kfdia + kknu(jl) = klev + kknu2(jl) = klev + kknub(jl) = klev + kknul(jl) = klev + pgamma(jl) = max(pgamma(jl), gtsec) + ll1(jl, klev+1) = .FALSE. + END DO + + ! Ajouter une initialisation (L. Li, le 23fev99): + + DO jk = klev, ilevh, -1 + DO jl = kidia, kfdia + ll1(jl, jk) = .FALSE. + END DO + END DO + + ! * define top of low level flow + ! ---------------------------- + DO jk = klev, ilevh, -1 + DO jl = kidia, kfdia + lo = (paphm1(jl,jk)/paphm1(jl,klev+1)) >= gsigcr + IF (lo) THEN + kkcrit(jl) = jk + END IF + zhcrit(jl, jk) = ppic(jl) + zhgeo = pgeom1(jl, jk)/rg + ll1(jl, jk) = (zhgeo>zhcrit(jl,jk)) + IF (ll1(jl,jk) .NEQV. ll1(jl,jk+1)) THEN + kknu(jl) = jk + END IF + IF (.NOT. ll1(jl,ilevh)) kknu(jl) = ilevh + END DO + END DO + DO jk = klev, ilevh, -1 + DO jl = kidia, kfdia + zhcrit(jl, jk) = ppic(jl) - pval(jl) + zhgeo = pgeom1(jl, jk)/rg + ll1(jl, jk) = (zhgeo>zhcrit(jl,jk)) + IF (ll1(jl,jk) .NEQV. ll1(jl,jk+1)) THEN + kknu2(jl) = jk + END IF + IF (.NOT. ll1(jl,ilevh)) kknu2(jl) = ilevh + END DO + END DO + DO jk = klev, ilevh, -1 + DO jl = kidia, kfdia + zhcrit(jl, jk) = amax1(ppic(jl)-pmea(jl), pmea(jl)-pval(jl)) + zhgeo = pgeom1(jl, jk)/rg + ll1(jl, jk) = (zhgeo>zhcrit(jl,jk)) + IF (ll1(jl,jk) .NEQV. ll1(jl,jk+1)) THEN + kknub(jl) = jk + END IF + IF (.NOT. ll1(jl,ilevh)) kknub(jl) = ilevh + END DO + END DO + + DO jl = kidia, kfdia + kknu(jl) = min(kknu(jl), nktopg) + kknu2(jl) = min(kknu2(jl), nktopg) + kknub(jl) = min(kknub(jl), nktopg) + kknul(jl) = klev + END DO + + ! c* initialize various arrays + + DO jl = kidia, kfdia + prho(jl, klev+1) = 0.0 + pstab(jl, klev+1) = 0.0 + pstab(jl, 1) = 0.0 + pri(jl, klev+1) = 9999.0 + ppsi(jl, klev+1) = 0.0 + pri(jl, 1) = 0.0 + pvph(jl, 1) = 0.0 + pulow(jl) = 0.0 + pvlow(jl) = 0.0 + zulow(jl) = 0.0 + zvlow(jl) = 0.0 + kkcrith(jl) = klev + kkenvh(jl) = klev + kentp(jl) = klev + kcrit(jl) = 1 + ncount(jl) = 0 + ll1(jl, klev+1) = .FALSE. + END DO + + ! * define low-level flow + ! --------------------- + + DO jk = klev, 2, -1 + DO jl = kidia, kfdia + IF (ktest(jl)==1) THEN + zdp(jl, jk) = papm1(jl, jk) - papm1(jl, jk-1) + prho(jl, jk) = 2.*paphm1(jl, jk)*zcons1/(ptm1(jl,jk)+ptm1(jl,jk-1)) + pstab(jl, jk) = 2.*zcons2/(ptm1(jl,jk)+ptm1(jl,jk-1))* & + (1.-rcpd*prho(jl,jk)*(ptm1(jl,jk)-ptm1(jl,jk-1))/zdp(jl,jk)) + pstab(jl, jk) = max(pstab(jl,jk), gssec) + END IF + END DO + END DO + + ! ******************************************************************** + + ! * define blocked flow + ! ------------------- + DO jk = klev, ilevh, -1 + DO jl = kidia, kfdia + IF (jk>=kknub(jl) .AND. jk<=kknul(jl)) THEN + pulow(jl) = pulow(jl) + pum1(jl, jk)*(paphm1(jl,jk+1)-paphm1(jl,jk)) + pvlow(jl) = pvlow(jl) + pvm1(jl, jk)*(paphm1(jl,jk+1)-paphm1(jl,jk)) + END IF + END DO + END DO + DO jl = kidia, kfdia + pulow(jl) = pulow(jl)/(paphm1(jl,kknul(jl)+1)-paphm1(jl,kknub(jl))) + pvlow(jl) = pvlow(jl)/(paphm1(jl,kknul(jl)+1)-paphm1(jl,kknub(jl))) + znorm(jl) = max(sqrt(pulow(jl)**2+pvlow(jl)**2), gvsec) + pvph(jl, klev+1) = znorm(jl) + END DO + + ! ******* setup orography axes and define plane of profiles ******* + + DO jl = kidia, kfdia + lo = (pulow(jl)=-gvsec) + IF (lo) THEN + zu = pulow(jl) + 2.*gvsec + ELSE + zu = pulow(jl) + END IF + zphi = atan(pvlow(jl)/zu) + ppsi(jl, klev+1) = ptheta(jl)*rpi/180. - zphi + zb(jl) = 1. - 0.18*pgamma(jl) - 0.04*pgamma(jl)**2 + zc(jl) = 0.48*pgamma(jl) + 0.3*pgamma(jl)**2 + pd1(jl) = zb(jl) - (zb(jl)-zc(jl))*(sin(ppsi(jl,klev+1))**2) + pd2(jl) = (zb(jl)-zc(jl))*sin(ppsi(jl,klev+1))*cos(ppsi(jl,klev+1)) + pdmod(jl) = sqrt(pd1(jl)**2+pd2(jl)**2) + END DO + + ! ************ define flow in plane of lowlevel stress ************* + + DO jk = 1, klev + DO jl = kidia, kfdia + IF (ktest(jl)==1) THEN + zvt1 = pulow(jl)*pum1(jl, jk) + pvlow(jl)*pvm1(jl, jk) + zvt2 = -pvlow(jl)*pum1(jl, jk) + pulow(jl)*pvm1(jl, jk) + zvpf(jl, jk) = (zvt1*pd1(jl)+zvt2*pd2(jl))/(znorm(jl)*pdmod(jl)) + END IF + ptau(jl, jk) = 0.0 + pzdep(jl, jk) = 0.0 + ppsi(jl, jk) = 0.0 + ll1(jl, jk) = .FALSE. + END DO + END DO + DO jk = 2, klev + DO jl = kidia, kfdia + IF (ktest(jl)==1) THEN + zdp(jl, jk) = papm1(jl, jk) - papm1(jl, jk-1) + pvph(jl, jk) = ((paphm1(jl,jk)-papm1(jl,jk-1))*zvpf(jl,jk)+(papm1(jl, & + jk)-paphm1(jl,jk))*zvpf(jl,jk-1))/zdp(jl, jk) + IF (pvph(jl,jk)=(kknub(jl)+1) .AND. jk<=kknul(jl)) THEN + zst = zcons2/ptm1(jl, jk)*(1.-rcpd*prho(jl,jk)*(ptm1(jl, & + jk)-ptm1(jl,jk-1))/zdp(jl,jk)) + pstab(jl, klev+1) = pstab(jl, klev+1) + zst*zdp(jl, jk) + pstab(jl, klev+1) = max(pstab(jl,klev+1), gssec) + prho(jl, klev+1) = prho(jl, klev+1) + paphm1(jl, jk)*2.*zdp(jl, jk) & + *zcons1/(ptm1(jl,jk)+ptm1(jl,jk-1)) + END IF + END IF + END DO + END DO + + DO jl = kidia, kfdia + pstab(jl, klev+1) = pstab(jl, klev+1)/(papm1(jl,kknul(jl))-papm1(jl,kknub & + (jl))) + prho(jl, klev+1) = prho(jl, klev+1)/(papm1(jl,kknul(jl))-papm1(jl,kknub( & + jl))) + zvar = pstd(jl) + END DO + + ! * 2.3 mean flow richardson number. + ! * and critical height for froude layer + + + DO jk = 2, klev + DO jl = kidia, kfdia + IF (ktest(jl)==1) THEN + zdwind = max(abs(zvpf(jl,jk)-zvpf(jl,jk-1)), gvsec) + pri(jl, jk) = pstab(jl, jk)*(zdp(jl,jk)/(rg*prho(jl,jk)*zdwind))**2 + pri(jl, jk) = max(pri(jl,jk), grcrit) + END IF + END DO + END DO + + + + ! * define top of 'envelope' layer + ! ---------------------------- + + DO jl = kidia, kfdia + pnu(jl) = 0.0 + znum(jl) = 0.0 + END DO + + DO jk = 2, klev - 1 + DO jl = kidia, kfdia + + IF (ktest(jl)==1) THEN + + IF (jk>=kknub(jl)) THEN + + znum(jl) = pnu(jl) + zwind = (pulow(jl)*pum1(jl,jk)+pvlow(jl)*pvm1(jl,jk))/ & + max(sqrt(pulow(jl)**2+pvlow(jl)**2), gvsec) + zwind = max(sqrt(zwind**2), gvsec) + zdelp = paphm1(jl, jk+1) - paphm1(jl, jk) + zstabm = sqrt(max(pstab(jl,jk),gssec)) + zstabp = sqrt(max(pstab(jl,jk+1),gssec)) + zrhom = prho(jl, jk) + zrhop = prho(jl, jk+1) + pnu(jl) = pnu(jl) + (zdelp/rg)*((zstabp/zrhop+zstabm/zrhom)/2.)/ & + zwind + IF ((znum(jl)<=gfrcrit) .AND. (pnu(jl)>gfrcrit) .AND. (kkenvh( & + jl)==klev)) kkenvh(jl) = jk + + END IF + + END IF + + END DO + END DO + + ! calculation of a dynamical mixing height for the breaking + ! of gravity waves: + + + DO jl = kidia, kfdia + znup(jl) = 0.0 + znum(jl) = 0.0 + END DO + + DO jk = klev - 1, 2, -1 + DO jl = kidia, kfdia + + IF (ktest(jl)==1) THEN + + znum(jl) = znup(jl) + zwind = (pulow(jl)*pum1(jl,jk)+pvlow(jl)*pvm1(jl,jk))/ & + max(sqrt(pulow(jl)**2+pvlow(jl)**2), gvsec) + zwind = max(sqrt(zwind**2), gvsec) + zdelp = paphm1(jl, jk+1) - paphm1(jl, jk) + zstabm = sqrt(max(pstab(jl,jk),gssec)) + zstabp = sqrt(max(pstab(jl,jk+1),gssec)) + zrhom = prho(jl, jk) + zrhop = prho(jl, jk+1) + znup(jl) = znup(jl) + (zdelp/rg)*((zstabp/zrhop+zstabm/zrhom)/2.)/ & + zwind + IF ((znum(jl)<=rpi/2.) .AND. (znup(jl)>rpi/2.) .AND. (kkcrith( & + jl)==klev)) kkcrith(jl) = jk + + END IF + + END DO + END DO + + DO jl = kidia, kfdia + kkcrith(jl) = min0(kkcrith(jl), kknu2(jl)) + kkcrith(jl) = max0(kkcrith(jl), ilevh*2) + END DO + + ! directional info for flow blocking ************************* + + DO jk = ilevh, klev + DO jl = kidia, kfdia + IF (jk>=kkenvh(jl)) THEN + lo = (pum1(jl,jk)=-gvsec) + IF (lo) THEN + zu = pum1(jl, jk) + 2.*gvsec + ELSE + zu = pum1(jl, jk) + END IF + zphi = atan(pvm1(jl,jk)/zu) + ppsi(jl, jk) = ptheta(jl)*rpi/180. - zphi + END IF + END DO + END DO + ! forms the vertical 'leakiness' ************************** + + alpha = 3. + + DO jk = ilevh, klev + DO jl = kidia, kfdia + IF (jk>=kkenvh(jl)) THEN + zggeenv = amax1(1., (pgeom1(jl,kkenvh(jl))+pgeom1(jl, & + kkenvh(jl)-1))/2.) + zggeom1 = amax1(pgeom1(jl,jk), 1.) + zgvar = amax1(pstd(jl)*rg, 1.) + ! mod pzdep(jl,jk)=sqrt((zggeenv-zggeom1)/(zggeom1+zgvar)) + pzdep(jl, jk) = (pgeom1(jl,kkenvh(jl)-1)-pgeom1(jl,jk))/ & + (pgeom1(jl,kkenvh(jl)-1)-pgeom1(jl,klev)) + END IF + END DO + END DO + + RETURN +END SUBROUTINE orosetup +SUBROUTINE gwstress(nlon, nlev, ktest, kcrit, kkenvh, kknu, prho, pstab, & + pvph, pstd, psig, pmea, ppic, ptau, pgeom1, pdmod) + + ! **** *gwstress* + + ! purpose. + ! -------- + + ! ** interface. + ! ---------- + ! call *gwstress* from *gwdrag* + + ! explicit arguments : + ! -------------------- + ! ==== inputs === + ! ==== outputs === + + ! implicit arguments : none + ! -------------------- + + ! method. + ! ------- + + + ! externals. + ! ---------- + + + ! reference. + ! ---------- + + ! see ecmwf research department documentation of the "i.f.s." + + ! author. + ! ------- + + ! modifications. + ! -------------- + ! f. lott put the new gwd on ifs 22/11/93 + + ! ----------------------------------------------------------------------- +USE yoegwd_mod_h + USE dimphy + USE yomcst_mod_h +IMPLICIT NONE + + + ! ----------------------------------------------------------------------- + + ! * 0.1 arguments + ! --------- + + INTEGER nlon, nlev + INTEGER kcrit(nlon), ktest(nlon), kkenvh(nlon), kknu(nlon) + + REAL prho(nlon, nlev+1), pstab(nlon, nlev+1), ptau(nlon, nlev+1), & + pvph(nlon, nlev+1), pgeom1(nlon, nlev), pstd(nlon) + + REAL psig(nlon) + REAL pmea(nlon), ppic(nlon) + REAL pdmod(nlon) + + ! ----------------------------------------------------------------------- + + ! * 0.2 local arrays + ! ------------ + INTEGER jl + REAL zblock, zvar, zeff + LOGICAL lo + + ! ----------------------------------------------------------------------- + + ! * 0.3 functions + ! --------- + ! ------------------------------------------------------------------ + + ! * 1. initialization + ! -------------- + + + ! * 3.1 gravity wave stress. + + + + DO jl = kidia, kfdia + IF (ktest(jl)==1) THEN + + ! effective mountain height above the blocked flow + + IF (kkenvh(jl)==klev) THEN + zblock = 0.0 + ELSE + zblock = (pgeom1(jl,kkenvh(jl))+pgeom1(jl,kkenvh(jl)+1))/2./rg + END IF + + zvar = ppic(jl) - pmea(jl) + zeff = amax1(0., zvar-zblock) + + ptau(jl, klev+1) = prho(jl, klev+1)*gkdrag*psig(jl)*zeff**2/4./ & + pstd(jl)*pvph(jl, klev+1)*pdmod(jl)*sqrt(pstab(jl,klev+1)) + + ! too small value of stress or low level flow include critical level + ! or low level flow: gravity wave stress nul. + + lo = (ptau(jl,klev+1)=kknu(jl)) .OR. & + (pvph(jl,klev+1)kkcrith(jl)) THEN + ptau(jl, jk) = ztau(jl, klev+1) + ! ENDIF + ! IF(JK.EQ.KKCRITH(JL)) THEN + ELSE + ptau(jl, jk) = grahilo*ztau(jl, klev+1) + END IF + END IF + END DO + + ! * 4.15 CONSTANT SHEAR STRESS UNTIL THE TOP OF THE + ! LOW LEVEL FLOW LAYER. + + + ! * 4.2 WAVE DISPLACEMENT AT NEXT LEVEL. + + + ! DO 421 ji=1,kgwd + ! jl=kdx(ji) + ! Modif vectorisation 02/04/2004 + DO jl = kidia, kfdia + IF (ktest(jl)==1) THEN + IF (jkkkcrith(jl)) THEN + + zdelp = paphm1(jl, jk) - paphm1(jl, klev+1) + zdelpt = paphm1(jl, kkcrith(jl)) - paphm1(jl, klev+1) + ptau(jl, jk) = ztau(jl, klev+1) + (ztau(jl,kkcrith(jl))-ztau(jl, & + klev+1))*zdelp/zdelpt + + END IF + + END IF + END DO + + ! REORGANISATION IN THE STRATOSPHERE + + ! DO 533 ji=1,kgwd + ! jl=kdx(ji) + ! Modif vectorisation 02/04/2004 + DO jl = kidia, kfdia + IF (ktest(jl)==1) THEN + + + IF (jknstra) THEN + + zdelp = paphm1(jl, jk) - paphm1(jl, kkcrith(jl)) + zdelpt = paphm1(jl, nstra) - paphm1(jl, kkcrith(jl)) + ptau(jl, jk) = ztau(jl, kkcrith(jl)) + (ztau(jl,nstra)-ztau(jl, & + kkcrith(jl)))*zdelp/zdelpt + + END IF + END IF + END DO + + + END DO + + + RETURN +END SUBROUTINE gwprofil +SUBROUTINE lift_noro(nlon, nlev, dtime, paprs, pplay, plat, pmea, pstd, ppic, & + ktest, t, u, v, pulow, pvlow, pustr, pvstr, d_t, d_u, d_v) + + USE dimphy + USE yomcst_mod_h +IMPLICIT NONE + ! ====================================================================== + ! Auteur(s): F.Lott (LMD/CNRS) date: 19950201 + ! Objet: Frottement de la montagne Interface + ! ====================================================================== + ! Arguments: + ! dtime---input-R- pas d'integration (s) + ! paprs---input-R-pression pour chaque inter-couche (en Pa) + ! pplay---input-R-pression pour le mileu de chaque couche (en Pa) + ! t-------input-R-temperature (K) + ! u-------input-R-vitesse horizontale (m/s) + ! v-------input-R-vitesse horizontale (m/s) + + ! d_t-----output-R-increment de la temperature + ! d_u-----output-R-increment de la vitesse u + ! d_v-----output-R-increment de la vitesse v + ! ====================================================================== + + + ! ARGUMENTS + + INTEGER nlon, nlev + REAL dtime + REAL paprs(klon, klev+1) + REAL pplay(klon, klev) + REAL plat(nlon), pmea(nlon) + REAL pstd(nlon) + REAL ppic(nlon) + REAL pulow(nlon), pvlow(nlon), pustr(nlon), pvstr(nlon) + REAL t(nlon, nlev), u(nlon, nlev), v(nlon, nlev) + REAL d_t(nlon, nlev), d_u(nlon, nlev), d_v(nlon, nlev) + + INTEGER i, k, ktest(nlon) + + ! Variables locales: + + REAL zgeom(klon, klev) + REAL pdtdt(klon, klev), pdudt(klon, klev), pdvdt(klon, klev) + REAL pt(klon, klev), pu(klon, klev), pv(klon, klev) + REAL papmf(klon, klev), papmh(klon, klev+1) + + ! initialiser les variables de sortie (pour securite) + + DO i = 1, klon + pulow(i) = 0.0 + pvlow(i) = 0.0 + pustr(i) = 0.0 + pvstr(i) = 0.0 + END DO + DO k = 1, klev + DO i = 1, klon + d_t(i, k) = 0.0 + d_u(i, k) = 0.0 + d_v(i, k) = 0.0 + pdudt(i, k) = 0.0 + pdvdt(i, k) = 0.0 + pdtdt(i, k) = 0.0 + END DO + END DO + + ! preparer les variables d'entree (attention: l'ordre des niveaux + ! verticaux augmente du haut vers le bas) + + DO k = 1, klev + DO i = 1, klon + pt(i, k) = t(i, klev-k+1) + pu(i, k) = u(i, klev-k+1) + pv(i, k) = v(i, klev-k+1) + papmf(i, k) = pplay(i, klev-k+1) + END DO + END DO + DO k = 1, klev + 1 + DO i = 1, klon + papmh(i, k) = paprs(i, klev-k+2) + END DO + END DO + DO i = 1, klon + zgeom(i, klev) = rd*pt(i, klev)*log(papmh(i,klev+1)/papmf(i,klev)) + END DO + DO k = klev - 1, 1, -1 + DO i = 1, klon + zgeom(i, k) = zgeom(i, k+1) + rd*(pt(i,k)+pt(i,k+1))/2.0*log(papmf(i,k+ & + 1)/papmf(i,k)) + END DO + END DO + + ! appeler la routine principale + + CALL orolift(klon, klev, ktest, dtime, papmh, zgeom, pt, pu, pv, plat, & + pmea, pstd, ppic, pulow, pvlow, pdudt, pdvdt, pdtdt) + + DO k = 1, klev + DO i = 1, klon + d_u(i, klev+1-k) = dtime*pdudt(i, k) + d_v(i, klev+1-k) = dtime*pdvdt(i, k) + d_t(i, klev+1-k) = dtime*pdtdt(i, k) + pustr(i) = pustr(i) & ! IM BUG . + ! +RG*pdudt(i,k)*(papmh(i,k+1)-papmh(i,k)) + +pdudt(i, k)*(papmh(i,k+1)-papmh(i,k))/rg + pvstr(i) = pvstr(i) & ! IM BUG . + ! +RG*pdvdt(i,k)*(papmh(i,k+1)-papmh(i,k)) + +pdvdt(i, k)*(papmh(i,k+1)-papmh(i,k))/rg + END DO + END DO + + RETURN +END SUBROUTINE lift_noro +SUBROUTINE orolift(nlon, nlev, ktest, ptsphy, paphm1, pgeom1, ptm1, pum1, & + pvm1, plat, pmea, pvaror, ppic & ! OUTPUTS + , pulow, pvlow, pvom, pvol, pte) + + + ! **** *OROLIFT: SIMULATE THE GEOSTROPHIC LIFT. + + ! PURPOSE. + ! -------- + + ! ** INTERFACE. + ! ---------- + ! CALLED FROM *lift_noro + ! ---------- + + ! AUTHOR. + ! ------- + ! F.LOTT LMD 22/11/95 + +USE yoegwd_mod_h + USE dimphy + USE yomcst_mod_h +IMPLICIT NONE + + + + ! ----------------------------------------------------------------------- + + ! * 0.1 ARGUMENTS + ! --------- + + + INTEGER nlon, nlev + REAL pte(nlon, nlev), pvol(nlon, nlev), pvom(nlon, nlev), pulow(nlon), & + pvlow(nlon) + REAL pum1(nlon, nlev), pvm1(nlon, nlev), ptm1(nlon, nlev), plat(nlon), & + pmea(nlon), pvaror(nlon), ppic(nlon), pgeom1(nlon, nlev), & + paphm1(nlon, nlev+1) + + INTEGER ktest(nlon) + REAL ptsphy + ! ----------------------------------------------------------------------- + + ! * 0.2 LOCAL ARRAYS + ! ------------ + LOGICAL lifthigh + ! ym integer klevm1, jl, ilevh, jk + INTEGER jl, ilevh, jk + REAL zcons1, ztmst, zrtmst, zpi, zhgeo + REAL zdelp, zslow, zsqua, zscav, zbet + INTEGER iknub(klon), iknul(klon) + LOGICAL ll1(klon, klev+1) + + REAL ztau(klon, klev+1), ztav(klon, klev+1), zrho(klon, klev+1) + REAL zdudt(klon), zdvdt(klon) + REAL zhcrit(klon, klev) + CHARACTER (LEN=20) :: modname = 'orografi' + CHARACTER (LEN=80) :: abort_message + ! ----------------------------------------------------------------------- + + ! * 1.1 INITIALIZATIONS + ! --------------- + + lifthigh = .FALSE. + + IF (nlon/=klon .OR. nlev/=klev) THEN + abort_message = 'pb dimension' + CALL abort_physic(modname, abort_message, 1) + END IF + zcons1 = 1./rd + ! ym KLEVM1=KLEV-1 + ztmst = ptsphy + zrtmst = 1./ztmst + zpi = acos(-1.) + + DO jl = kidia, kfdia + zrho(jl, klev+1) = 0.0 + pulow(jl) = 0.0 + pvlow(jl) = 0.0 + iknub(jl) = klev + iknul(jl) = klev + ilevh = klev/3 + ll1(jl, klev+1) = .FALSE. + DO jk = 1, klev + pvom(jl, jk) = 0.0 + pvol(jl, jk) = 0.0 + pte(jl, jk) = 0.0 + END DO + END DO + + + ! * 2.1 DEFINE LOW LEVEL WIND, PROJECT WINDS IN PLANE OF + ! * LOW LEVEL WIND, DETERMINE SECTOR IN WHICH TO TAKE + ! * THE VARIANCE AND SET INDICATOR FOR CRITICAL LEVELS. + + + + DO jk = klev, 1, -1 + DO jl = kidia, kfdia + IF (ktest(jl)==1) THEN + zhcrit(jl, jk) = amax1(ppic(jl)-pmea(jl), 100.) + zhgeo = pgeom1(jl, jk)/rg + ll1(jl, jk) = (zhgeo>zhcrit(jl,jk)) + IF (ll1(jl,jk) .NEQV. ll1(jl,jk+1)) THEN + iknub(jl) = jk + END IF + END IF + END DO + END DO + + DO jl = kidia, kfdia + IF (ktest(jl)==1) THEN + iknub(jl) = max(iknub(jl), klev/2) + iknul(jl) = max(iknul(jl), 2*klev/3) + IF (iknub(jl)>nktopg) iknub(jl) = nktopg + IF (iknub(jl)==nktopg) iknul(jl) = klev + IF (iknub(jl)==iknul(jl)) iknub(jl) = iknul(jl) - 1 + END IF + END DO + + ! do 2011 jl=kidia,kfdia + ! IF(KTEST(JL).EQ.1) THEN + ! print *,' iknul= ',iknul(jl),' iknub=',iknub(jl) + ! ENDIF + ! 2011 continue + + ! PRINT *,' DANS OROLIFT: 2010' + + DO jk = klev, 2, -1 + DO jl = kidia, kfdia + zrho(jl, jk) = 2.*paphm1(jl, jk)*zcons1/(ptm1(jl,jk)+ptm1(jl,jk-1)) + END DO + END DO + ! PRINT *,' DANS OROLIFT: 223' + + ! ******************************************************************** + + ! * DEFINE LOW LEVEL FLOW + ! ------------------- + DO jk = klev, 1, -1 + DO jl = kidia, kfdia + IF (ktest(jl)==1) THEN + IF (jk>=iknub(jl) .AND. jk<=iknul(jl)) THEN + pulow(jl) = pulow(jl) + pum1(jl, jk)*(paphm1(jl,jk+1)-paphm1(jl,jk) & + ) + pvlow(jl) = pvlow(jl) + pvm1(jl, jk)*(paphm1(jl,jk+1)-paphm1(jl,jk) & + ) + zrho(jl, klev+1) = zrho(jl, klev+1) + zrho(jl, jk)*(paphm1(jl,jk+1) & + -paphm1(jl,jk)) + END IF + END IF + END DO + END DO + DO jl = kidia, kfdia + IF (ktest(jl)==1) THEN + pulow(jl) = pulow(jl)/(paphm1(jl,iknul(jl)+1)-paphm1(jl,iknub(jl))) + pvlow(jl) = pvlow(jl)/(paphm1(jl,iknul(jl)+1)-paphm1(jl,iknub(jl))) + zrho(jl, klev+1) = zrho(jl, klev+1)/(paphm1(jl,iknul(jl)+1)-paphm1(jl, & + iknub(jl))) + END IF + END DO + + ! *********************************************************** + + ! * 3. COMPUTE MOUNTAIN LIFT + + + DO jl = kidia, kfdia + IF (ktest(jl)==1) THEN + ztau(jl, klev+1) = -gklift*zrho(jl, klev+1)*2.*romega* & ! * + ! (2*PVAROR(JL)+PMEA(JL))* + 2*pvaror(jl)*sin(zpi/180.*plat(jl))*pvlow(jl) + ztav(jl, klev+1) = gklift*zrho(jl, klev+1)*2.*romega* & ! * + ! (2*PVAROR(JL)+PMEA(JL))* + 2*pvaror(jl)*sin(zpi/180.*plat(jl))*pulow(jl) + ELSE + ztau(jl, klev+1) = 0.0 + ztav(jl, klev+1) = 0.0 + END IF + END DO + + ! * 4. COMPUTE LIFT PROFILE + ! * -------------------- + + + + DO jk = 1, klev + DO jl = kidia, kfdia + IF (ktest(jl)==1) THEN + ztau(jl, jk) = ztau(jl, klev+1)*paphm1(jl, jk)/paphm1(jl, klev+1) + ztav(jl, jk) = ztav(jl, klev+1)*paphm1(jl, jk)/paphm1(jl, klev+1) + ELSE + ztau(jl, jk) = 0.0 + ztav(jl, jk) = 0.0 + END IF + END DO + END DO + + + ! * 5. COMPUTE TENDENCIES. + ! * ------------------- + IF (lifthigh) THEN + ! PRINT *,' DANS OROLIFT: 500' + + ! EXPLICIT SOLUTION AT ALL LEVELS + + DO jk = 1, klev + DO jl = kidia, kfdia + IF (ktest(jl)==1) THEN + zdelp = paphm1(jl, jk+1) - paphm1(jl, jk) + zdudt(jl) = -rg*(ztau(jl,jk+1)-ztau(jl,jk))/zdelp + zdvdt(jl) = -rg*(ztav(jl,jk+1)-ztav(jl,jk))/zdelp + END IF + END DO + END DO + + ! PROJECT PERPENDICULARLY TO U NOT TO DESTROY ENERGY + + DO jk = 1, klev + DO jl = kidia, kfdia + IF (ktest(jl)==1) THEN + + zslow = sqrt(pulow(jl)**2+pvlow(jl)**2) + zsqua = amax1(sqrt(pum1(jl,jk)**2+pvm1(jl,jk)**2), gvsec) + zscav = -zdudt(jl)*pvm1(jl, jk) + zdvdt(jl)*pum1(jl, jk) + IF (zsqua>gvsec) THEN + pvom(jl, jk) = -zscav*pvm1(jl, jk)/zsqua**2 + pvol(jl, jk) = zscav*pum1(jl, jk)/zsqua**2 + ELSE + pvom(jl, jk) = 0.0 + pvol(jl, jk) = 0.0 + END IF + zsqua = sqrt(pum1(jl,jk)**2+pum1(jl,jk)**2) + IF (zsqua=nstra) THEN - rover = 0.10 - IF (abs(zdudt(ji))>rover*abs(pum1(ji,jk))/ztmst) zdudt(ji) = rover* & - abs(pum1(ji,jk))/ztmst*zdudt(ji)/(abs(zdudt(ji))+1.E-10) - IF (abs(zdvdt(ji))>rover*abs(pvm1(ji,jk))/ztmst) zdvdt(ji) = rover* & - abs(pvm1(ji,jk))/ztmst*zdvdt(ji)/(abs(zdvdt(ji))+1.E-10) - END IF - - rover = 0.25 - zforc = sqrt(zdudt(ji)**2+zdvdt(ji)**2) - ztend = sqrt(pum1(ji,jk)**2+pvm1(ji,jk)**2)/ztmst - - IF (zforc>=rover*ztend) THEN - zdudt(ji) = rover*ztend/zforc*zdudt(ji) - zdvdt(ji) = rover*ztend/zforc*zdvdt(ji) - END IF - - ! BLOCKED FLOW DRAG: - ! ----------------- - - IF (partdrag .GE. 2) THEN - facpart=0. - ELSE - facpart=gkwake - ENDIF - - - IF (jk>ikenvh(ji)) THEN - zb = 1.0 - 0.18*pgam(ji) - 0.04*pgam(ji)**2 - zc = 0.48*pgam(ji) + 0.3*pgam(ji)**2 - zconb = 2.*ztmst*facpart*psig(ji)/(4.*pstd(ji)) - zabsv = sqrt(pum1(ji,jk)**2+pvm1(ji,jk)**2)/2. - zzd1 = zb*cos(zpsi(ji,jk))**2 + zc*sin(zpsi(ji,jk))**2 - ratio = (cos(zpsi(ji,jk))**2+pgam(ji)*sin(zpsi(ji, & - jk))**2)/(pgam(ji)*cos(zpsi(ji,jk))**2+sin(zpsi(ji,jk))**2) - zbet = max(0., 2.-1./ratio)*zconb*zzdep(ji, jk)*zzd1*zabsv - - ! OPPOSED TO THE WIND - - zdudt(ji) = -pum1(ji, jk)/ztmst - zdvdt(ji) = -pvm1(ji, jk)/ztmst - - ! PERPENDICULAR TO THE SSO MAIN AXIS: - - ! mod zdudt(ji)=-(pum1(ji,jk)*cos(pthe(ji)*rpi/180.) - ! mod * +pvm1(ji,jk)*sin(pthe(ji)*rpi/180.)) - ! mod * *cos(pthe(ji)*rpi/180.)/ztmst - ! mod zdvdt(ji)=-(pum1(ji,jk)*cos(pthe(ji)*rpi/180.) - ! mod * +pvm1(ji,jk)*sin(pthe(ji)*rpi/180.)) - ! mod * *sin(pthe(ji)*rpi/180.)/ztmst - - zdudt(ji) = zdudt(ji)*(zbet/(1.+zbet)) - zdvdt(ji) = zdvdt(ji)*(zbet/(1.+zbet)) - END IF - pvom(ji, jk) = zdudt(ji) - pvol(ji, jk) = zdvdt(ji) - zust = pum1(ji, jk) + ztmst*zdudt(ji) - zvst = pvm1(ji, jk) + ztmst*zdvdt(ji) - zdis = 0.5*(pum1(ji,jk)**2+pvm1(ji,jk)**2-zust**2-zvst**2) - zdedt(ji) = zdis/ztmst - zvidis(ji) = zvidis(ji) + zdis*zdelp - zdtdt(ji) = zdedt(ji)/rcpd - - ! NO TENDENCIES ON TEMPERATURE ..... - - ! Instead of, pte(ji,jk)=zdtdt(ji), due to mechanical dissipation - - pte(ji, jk) = 0.0 - - END IF - - END DO - END DO - - RETURN -END SUBROUTINE orodrag_strato -SUBROUTINE orosetup_strato(nlon, nlev, ktest, kkcrit, kkcrith, kcrit, ksect, & - kkhlim, kkenvh, kknu, kknu2, paphm1, papm1, pum1, pvm1, ptm1, pgeom1, & - pstd, prho, pri, pstab, ptau, pvph, ppsi, pzdep, pulow, pvlow, ptheta, & - pgam, pmea, ppic, pval, pnu, pd1, pd2, pdmod) - - ! **** *gwsetup* - - ! purpose. - ! -------- - ! SET-UP THE ESSENTIAL PARAMETERS OF THE SSO DRAG SCHEME: - ! DEPTH OF LOW WBLOCKED LAYER, LOW-LEVEL FLOW, BACKGROUND - ! STRATIFICATION..... - - ! ** interface. - ! ---------- - ! from *orodrag* - - ! explicit arguments : - ! -------------------- - ! ==== inputs === - - ! nlon----input-I-Total number of horizontal points that get into physics - ! nlev----input-I-Number of vertical levels - ! ktest--input-I: Flags to indicate active points - - ! ptsphy--input-R-Time-step (s) - ! paphm1--input-R: pressure at model 1/2 layer - ! papm1---input-R: pressure at model layer - ! pgeom1--input-R: Altitude of layer above ground - ! ptm1, pum1, pvm1--R-: t, u and v - ! pmea----input-R-Mean Orography (m) - ! pstd----input-R-SSO standard deviation (m) - ! psig----input-R-SSO slope - ! pgam----input-R-SSO Anisotropy - ! pthe----input-R-SSO Angle - ! ppic----input-R-SSO Peacks elevation (m) - ! pval----input-R-SSO Valleys elevation (m) - - ! ==== outputs === - ! pulow, pvlow -output-R: Low-level wind - ! kkcrit----I-: Security value for top of low level flow - ! kcrit-----I-: Critical level - ! ksect-----I-: Not used - ! kkhlim----I-: Not used - ! kkenvh----I-: Top of blocked flow layer - ! kknu------I-: Layer that sees mountain peacks - ! kknu2-----I-: Layer that sees mountain peacks above mountain mean - ! kknub-----I-: Layer that sees mountain mean above valleys - ! prho------R-: Density at 1/2 layers - ! pri-------R-: Background Richardson Number, Wind shear measured along GW - ! stress - ! pstab-----R-: Brunt-Vaisala freq. at 1/2 layers - ! pvph------R-: Wind in plan of GW stress, Half levels. - ! ppsi------R-: Angle between low level wind and SS0 main axis. - ! pd1-------R-| Compared the ratio of the stress - ! pd2-------R-| that is along the wind to that Normal to it. - ! pdi define the plane of low level stress - ! compared to the low level wind. - ! see p. 108 Lott & Miller (1997). - ! pdmod-----R-: Norme of pdi - - ! === local arrays === - - ! zvpf------R-: Wind projected in the plan of the low-level stress. - - ! ==== outputs === - - ! implicit arguments : none - ! -------------------- - - ! method. - ! ------- - - - ! externals. - ! ---------- - - - ! reference. - ! ---------- - - ! see ecmwf research department documentation of the "i.f.s." - - ! author. - ! ------- - - ! modifications. - ! -------------- - ! f.lott for the new-gwdrag scheme november 1993 - - ! ----------------------------------------------------------------------- -USE yoegwd_mod_h - USE dimphy - USE yomcst_mod_h -IMPLICIT NONE - - - - - ! ----------------------------------------------------------------------- - - ! * 0.1 arguments - ! --------- - - INTEGER nlon, nlev - INTEGER kkcrit(nlon), kkcrith(nlon), kcrit(nlon), ksect(nlon), & - kkhlim(nlon), ktest(nlon), kkenvh(nlon) - - - REAL paphm1(nlon, klev+1), papm1(nlon, klev), pum1(nlon, klev), & - pvm1(nlon, klev), ptm1(nlon, klev), pgeom1(nlon, klev), & - prho(nlon, klev+1), pri(nlon, klev+1), pstab(nlon, klev+1), & - ptau(nlon, klev+1), pvph(nlon, klev+1), ppsi(nlon, klev+1), & - pzdep(nlon, klev) - REAL pulow(nlon), pvlow(nlon), ptheta(nlon), pgam(nlon), pnu(nlon), & - pd1(nlon), pd2(nlon), pdmod(nlon) - REAL pstd(nlon), pmea(nlon), ppic(nlon), pval(nlon) - - ! ----------------------------------------------------------------------- - - ! * 0.2 local arrays - ! ------------ - - - INTEGER ilevh, jl, jk - REAL zcons1, zcons2, zhgeo, zu, zphi - REAL zvt1, zvt2, zdwind, zwind, zdelp - REAL zstabm, zstabp, zrhom, zrhop - LOGICAL lo - LOGICAL ll1(klon, klev+1) - INTEGER kknu(klon), kknu2(klon), kknub(klon), kknul(klon), kentp(klon), & - ncount(klon) - - REAL zhcrit(klon, klev), zvpf(klon, klev), zdp(klon, klev) - REAL znorm(klon), zb(klon), zc(klon), zulow(klon), zvlow(klon), znup(klon), & - znum(klon) - - ! ------------------------------------------------------------------ - - ! * 1. initialization - ! -------------- - - ! PRINT *,' in orosetup' - - ! ------------------------------------------------------------------ - - ! * 1.1 computational constants - ! ----------------------- - - - ilevh = klev/3 - - zcons1 = 1./rd - zcons2 = rg**2/rcpd - - ! ------------------------------------------------------------------ - - ! * 2. - ! -------------- - - - ! ------------------------------------------------------------------ - - ! * 2.1 define low level wind, project winds in plane of - ! * low level wind, determine sector in which to take - ! * the variance and set indicator for critical levels. - - - - DO jl = kidia, kfdia - kknu(jl) = klev - kknu2(jl) = klev - kknub(jl) = klev - kknul(jl) = klev - pgam(jl) = max(pgam(jl), gtsec) - ll1(jl, klev+1) = .FALSE. - END DO - - ! Ajouter une initialisation (L. Li, le 23fev99): - - DO jk = klev, ilevh, -1 - DO jl = kidia, kfdia - ll1(jl, jk) = .FALSE. - END DO - END DO - - ! * define top of low level flow - ! ---------------------------- - DO jk = klev, ilevh, -1 - DO jl = kidia, kfdia - IF (ktest(jl)==1) THEN - lo = (paphm1(jl,jk)/paphm1(jl,klev+1)) >= gsigcr - IF (lo) THEN - kkcrit(jl) = jk - END IF - zhcrit(jl, jk) = ppic(jl) - pval(jl) - zhgeo = pgeom1(jl, jk)/rg - ll1(jl, jk) = (zhgeo>zhcrit(jl,jk)) - IF (ll1(jl,jk) .NEQV. ll1(jl,jk+1)) THEN - kknu(jl) = jk - END IF - IF (.NOT. ll1(jl,ilevh)) kknu(jl) = ilevh - END IF - END DO - END DO - DO jk = klev, ilevh, -1 - DO jl = kidia, kfdia - IF (ktest(jl)==1) THEN - zhcrit(jl, jk) = ppic(jl) - pmea(jl) - zhgeo = pgeom1(jl, jk)/rg - ll1(jl, jk) = (zhgeo>zhcrit(jl,jk)) - IF (ll1(jl,jk) .NEQV. ll1(jl,jk+1)) THEN - kknu2(jl) = jk - END IF - IF (.NOT. ll1(jl,ilevh)) kknu2(jl) = ilevh - END IF - END DO - END DO - DO jk = klev, ilevh, -1 - DO jl = kidia, kfdia - IF (ktest(jl)==1) THEN - zhcrit(jl, jk) = amin1(ppic(jl)-pmea(jl), pmea(jl)-pval(jl)) - zhgeo = pgeom1(jl, jk)/rg - ll1(jl, jk) = (zhgeo>zhcrit(jl,jk)) - IF (ll1(jl,jk) .NEQV. ll1(jl,jk+1)) THEN - kknub(jl) = jk - END IF - IF (.NOT. ll1(jl,ilevh)) kknub(jl) = ilevh - END IF - END DO - END DO - - DO jl = kidia, kfdia - IF (ktest(jl)==1) THEN - kknu(jl) = min(kknu(jl), nktopg) - kknu2(jl) = min(kknu2(jl), nktopg) - kknub(jl) = min(kknub(jl), nktopg) - kknul(jl) = klev - END IF - END DO - - ! c* initialize various arrays - - DO jl = kidia, kfdia - prho(jl, klev+1) = 0.0 - ! ym correction en attendant mieux - prho(jl, 1) = 0.0 - pstab(jl, klev+1) = 0.0 - pstab(jl, 1) = 0.0 - pri(jl, klev+1) = 9999.0 - ppsi(jl, klev+1) = 0.0 - pri(jl, 1) = 0.0 - pvph(jl, 1) = 0.0 - pvph(jl, klev+1) = 0.0 - ! ym correction en attendant mieux - ! ym pvph(jl,klev) =0.0 - pulow(jl) = 0.0 - pvlow(jl) = 0.0 - zulow(jl) = 0.0 - zvlow(jl) = 0.0 - kkcrith(jl) = klev - kkenvh(jl) = klev - kentp(jl) = klev - kcrit(jl) = 1 - ncount(jl) = 0 - ll1(jl, klev+1) = .FALSE. - END DO - - ! * define flow density and stratification (rho and N2) - ! at semi layers. - ! ------------------------------------------------------- - - DO jk = klev, 2, -1 - DO jl = kidia, kfdia - IF (ktest(jl)==1) THEN - zdp(jl, jk) = papm1(jl, jk) - papm1(jl, jk-1) - prho(jl, jk) = 2.*paphm1(jl, jk)*zcons1/(ptm1(jl,jk)+ptm1(jl,jk-1)) - pstab(jl, jk) = 2.*zcons2/(ptm1(jl,jk)+ptm1(jl,jk-1))* & - (1.-rcpd*prho(jl,jk)*(ptm1(jl,jk)-ptm1(jl,jk-1))/zdp(jl,jk)) - pstab(jl, jk) = max(pstab(jl,jk), gssec) - END IF - END DO - END DO - - ! ******************************************************************** - - ! * define Low level flow (between ground and peacks-valleys) - ! --------------------------------------------------------- - DO jk = klev, ilevh, -1 - DO jl = kidia, kfdia - IF (ktest(jl)==1) THEN - IF (jk>=kknu2(jl) .AND. jk<=kknul(jl)) THEN - pulow(jl) = pulow(jl) + pum1(jl, jk)*(paphm1(jl,jk+1)-paphm1(jl,jk) & - ) - pvlow(jl) = pvlow(jl) + pvm1(jl, jk)*(paphm1(jl,jk+1)-paphm1(jl,jk) & - ) - pstab(jl, klev+1) = pstab(jl, klev+1) + pstab(jl, jk)*(paphm1(jl,jk & - +1)-paphm1(jl,jk)) - prho(jl, klev+1) = prho(jl, klev+1) + prho(jl, jk)*(paphm1(jl,jk+1) & - -paphm1(jl,jk)) - END IF - END IF - END DO - END DO - DO jl = kidia, kfdia - IF (ktest(jl)==1) THEN - pulow(jl) = pulow(jl)/(paphm1(jl,kknul(jl)+1)-paphm1(jl,kknu2(jl))) - pvlow(jl) = pvlow(jl)/(paphm1(jl,kknul(jl)+1)-paphm1(jl,kknu2(jl))) - znorm(jl) = max(sqrt(pulow(jl)**2+pvlow(jl)**2), gvsec) - pvph(jl, klev+1) = znorm(jl) - pstab(jl, klev+1) = pstab(jl, klev+1)/(paphm1(jl,kknul(jl)+1)-paphm1(jl & - ,kknu2(jl))) - prho(jl, klev+1) = prho(jl, klev+1)/(paphm1(jl,kknul(jl)+1)-paphm1(jl, & - kknu2(jl))) - END IF - END DO - - - ! ******* setup orography orientation relative to the low level - ! wind and define parameters of the Anisotropic wave stress. - - DO jl = kidia, kfdia - IF (ktest(jl)==1) THEN - lo = (pulow(jl)=-gvsec) - IF (lo) THEN - zu = pulow(jl) + 2.*gvsec - ELSE - zu = pulow(jl) - END IF - zphi = atan(pvlow(jl)/zu) - ppsi(jl, klev+1) = ptheta(jl)*rpi/180. - zphi - zb(jl) = 1. - 0.18*pgam(jl) - 0.04*pgam(jl)**2 - zc(jl) = 0.48*pgam(jl) + 0.3*pgam(jl)**2 - pd1(jl) = zb(jl) - (zb(jl)-zc(jl))*(sin(ppsi(jl,klev+1))**2) - pd2(jl) = (zb(jl)-zc(jl))*sin(ppsi(jl,klev+1))*cos(ppsi(jl,klev+1)) - pdmod(jl) = sqrt(pd1(jl)**2+pd2(jl)**2) - END IF - END DO - - ! ************ projet flow in plane of lowlevel stress ************* - ! ************ Find critical levels... ************* - - DO jk = 1, klev - DO jl = kidia, kfdia - IF (ktest(jl)==1) THEN - zvt1 = pulow(jl)*pum1(jl, jk) + pvlow(jl)*pvm1(jl, jk) - zvt2 = -pvlow(jl)*pum1(jl, jk) + pulow(jl)*pvm1(jl, jk) - zvpf(jl, jk) = (zvt1*pd1(jl)+zvt2*pd2(jl))/(znorm(jl)*pdmod(jl)) - END IF - ptau(jl, jk) = 0.0 - pzdep(jl, jk) = 0.0 - ppsi(jl, jk) = 0.0 - ll1(jl, jk) = .FALSE. - END DO - END DO - DO jk = 2, klev - DO jl = kidia, kfdia - IF (ktest(jl)==1) THEN - zdp(jl, jk) = papm1(jl, jk) - papm1(jl, jk-1) - pvph(jl, jk) = ((paphm1(jl,jk)-papm1(jl,jk-1))*zvpf(jl,jk)+(papm1(jl, & - jk)-paphm1(jl,jk))*zvpf(jl,jk-1))/zdp(jl, jk) - IF (pvph(jl,jk)=kknu2(jl)) THEN - - znum(jl) = pnu(jl) - zwind = (pulow(jl)*pum1(jl,jk)+pvlow(jl)*pvm1(jl,jk))/ & - max(sqrt(pulow(jl)**2+pvlow(jl)**2), gvsec) - zwind = max(sqrt(zwind**2), gvsec) - zdelp = paphm1(jl, jk+1) - paphm1(jl, jk) - zstabm = sqrt(max(pstab(jl,jk),gssec)) - zstabp = sqrt(max(pstab(jl,jk+1),gssec)) - zrhom = prho(jl, jk) - zrhop = prho(jl, jk+1) - pnu(jl) = pnu(jl) + (zdelp/rg)*((zstabp/zrhop+zstabm/zrhom)/2.)/ & - zwind - IF ((znum(jl)<=gfrcrit) .AND. (pnu(jl)>gfrcrit) .AND. (kkenvh( & - jl)==klev)) kkenvh(jl) = jk - - END IF - - END IF - - END DO - END DO - - ! calculation of a dynamical mixing height for when the waves - ! BREAK AT LOW LEVEL: The drag will be repartited over - ! a depths that depends on waves vertical wavelength, - ! not just between two adjacent model layers. - ! of gravity waves: - - DO jl = kidia, kfdia - znup(jl) = 0.0 - znum(jl) = 0.0 - END DO - - DO jk = klev - 1, 2, -1 - DO jl = kidia, kfdia - - IF (ktest(jl)==1) THEN - - znum(jl) = znup(jl) - zwind = (pulow(jl)*pum1(jl,jk)+pvlow(jl)*pvm1(jl,jk))/ & - max(sqrt(pulow(jl)**2+pvlow(jl)**2), gvsec) - zwind = max(sqrt(zwind**2), gvsec) - zdelp = paphm1(jl, jk+1) - paphm1(jl, jk) - zstabm = sqrt(max(pstab(jl,jk),gssec)) - zstabp = sqrt(max(pstab(jl,jk+1),gssec)) - zrhom = prho(jl, jk) - zrhop = prho(jl, jk+1) - znup(jl) = znup(jl) + (zdelp/rg)*((zstabp/zrhop+zstabm/zrhom)/2.)/ & - zwind - IF ((znum(jl)<=rpi/4.) .AND. (znup(jl)>rpi/4.) .AND. (kkcrith( & - jl)==klev)) kkcrith(jl) = jk - - END IF - - END DO - END DO - - DO jl = kidia, kfdia - IF (ktest(jl)==1) THEN - kkcrith(jl) = max0(kkcrith(jl), ilevh*2) - kkcrith(jl) = max0(kkcrith(jl), kknu(jl)) - IF (kcrit(jl)>=kkcrith(jl)) kcrit(jl) = 1 - END IF - END DO - - ! directional info for flow blocking ************************* - - DO jk = 1, klev - DO jl = kidia, kfdia - IF (ktest(jl)==1) THEN - lo = (pum1(jl,jk)=-gvsec) - IF (lo) THEN - zu = pum1(jl, jk) + 2.*gvsec - ELSE - zu = pum1(jl, jk) - END IF - zphi = atan(pvm1(jl,jk)/zu) - ppsi(jl, jk) = ptheta(jl)*rpi/180. - zphi - END IF - END DO - END DO - - ! forms the vertical 'leakiness' ************************** - - DO jk = ilevh, klev - DO jl = kidia, kfdia - IF (ktest(jl)==1) THEN - pzdep(jl, jk) = 0 - IF (jk>=kkenvh(jl) .AND. kkenvh(jl)/=klev) THEN - pzdep(jl, jk) = (pgeom1(jl,kkenvh(jl))-pgeom1(jl,jk))/ & - (pgeom1(jl,kkenvh(jl))-pgeom1(jl,klev)) - END IF - END IF - END DO - END DO - - RETURN -END SUBROUTINE orosetup_strato -SUBROUTINE gwstress_strato(nlon, nlev, kkcrit, ksect, kkhlim, ktest, kkcrith, & - kcrit, kkenvh, kknu, prho, pstab, pvph, pstd, psig, pmea, ppic, pval, & - ptfr, ptau, pgeom1, pgamma, pd1, pd2, pdmod, pnu) - - ! **** *gwstress* - - ! purpose. - ! -------- - ! Compute the surface stress due to Gravity Waves, according - ! to the Phillips (1979) theory of 3-D flow above - ! anisotropic elliptic ridges. - - ! The stress is reduced two account for cut-off flow over - ! hill. The flow only see that part of the ridge located - ! above the blocked layer (see zeff). - - ! ** interface. - ! ---------- - ! call *gwstress* from *gwdrag* - - ! explicit arguments : - ! -------------------- - ! ==== inputs === - ! ==== outputs === - - ! implicit arguments : none - ! -------------------- - - ! method. - ! ------- - - - ! externals. - ! ---------- - - - ! reference. - ! ---------- - - ! LOTT and MILLER (1997) & LOTT (1999) - - ! author. - ! ------- - - ! modifications. - ! -------------- - ! f. lott put the new gwd on ifs 22/11/93 - - ! ----------------------------------------------------------------------- -USE yoegwd_mod_h - USE dimphy - USE yomcst_mod_h -IMPLICIT NONE - - - - ! ----------------------------------------------------------------------- - - ! * 0.1 arguments - ! --------- - - INTEGER nlon, nlev - INTEGER kkcrit(nlon), kkcrith(nlon), kcrit(nlon), ksect(nlon), & - kkhlim(nlon), ktest(nlon), kkenvh(nlon), kknu(nlon) - - REAL prho(nlon, nlev+1), pstab(nlon, nlev+1), ptau(nlon, nlev+1), & - pvph(nlon, nlev+1), ptfr(nlon), pgeom1(nlon, nlev), pstd(nlon) - - REAL pd1(nlon), pd2(nlon), pnu(nlon), psig(nlon), pgamma(nlon) - REAL pmea(nlon), ppic(nlon), pval(nlon) - REAL pdmod(nlon) - - ! ----------------------------------------------------------------------- - - ! * 0.2 local arrays - ! ------------ - ! zeff--real: effective height seen by the flow when there is blocking - - INTEGER jl - REAL zeff - - ! ----------------------------------------------------------------------- - - ! * 0.3 functions - ! --------- - ! ------------------------------------------------------------------ - - ! * 1. initialization - ! -------------- - - ! PRINT *,' in gwstress' - - ! * 3.1 gravity wave stress. - - - - DO jl = kidia, kfdia - IF (ktest(jl)==1) THEN - - ! effective mountain height above the blocked flow - - zeff = ppic(jl) - pval(jl) - IF (kkenvh(jl)kkcrith(jl)) THEN - zdelp = paphm1(jl, jk) - paphm1(jl, klev+1) - zdelpt = paphm1(jl, kkcrith(jl)) - paphm1(jl, klev+1) - ptau(jl, jk) = ztau(jl, klev+1) + zdelp/zdelpt*(ztau(jl,kkcrith(jl) & - )-ztau(jl,klev+1)) - ELSE - ptau(jl, jk) = ztau(jl, kkcrith(jl)) - END IF - END IF - END DO - - ! * 4.15 constant shear stress until the top of the - ! low level flow layer. - - - ! * 4.2 wave displacement at next level. - - - END DO - - - ! * 4.4 wave richardson number, new wave displacement - ! * and stress: breaking evaluation and critical - ! level - - - DO jk = klev, 1, -1 - - DO jl = kidia, kfdia - IF (ktest(jl)==1) THEN - znorm(jl) = prho(jl, jk)*sqrt(pstab(jl,jk))*pvph(jl, jk) - zdz2(jl, jk) = ptau(jl, jk)/amax1(znorm(jl), gssec)/zoro(jl) - END IF - END DO - - DO jl = kidia, kfdia - IF (ktest(jl)==1) THEN - IF (jkkkcrith(jl)-1) THEN - - zdelp = paphm1(jl, jk) - paphm1(jl, klev+1) - zdelpt = paphm1(jl, kkcrith(jl)-1) - paphm1(jl, klev+1) - ptau(jl, jk) = ztau(jl, klev+1) + (ztau(jl,kkcrith(jl)-1)-ztau(jl, & - klev+1))*zdelp/zdelpt - - END IF - END IF - - END DO - - ! REORGANISATION AT THE MODEL TOP.... - - DO jl = kidia, kfdia - IF (ktest(jl)==1) THEN - - IF (jkzhcrit(jl,jk)) - IF (ll1(jl,jk) .NEQV. ll1(jl,jk+1)) THEN - iknub(jl) = jk - END IF - END IF - END DO - END DO - - - DO jl = kidia, kfdia - IF (ktest(jl)==1) THEN - iknub(jl) = max(iknub(jl), klev/2) - iknul(jl) = max(iknul(jl), 2*klev/3) - IF (iknub(jl)>nktopg) iknub(jl) = nktopg - IF (iknub(jl)==nktopg) iknul(jl) = klev - IF (iknub(jl)==iknul(jl)) iknub(jl) = iknul(jl) - 1 - END IF - END DO - - DO jk = klev, 2, -1 - DO jl = kidia, kfdia - zrho(jl, jk) = 2.*paphm1(jl, jk)*zcons1/(ptm1(jl,jk)+ptm1(jl,jk-1)) - END DO - END DO - ! print *,' dans orolift: 223' - - ! ******************************************************************** - - ! * define low level flow - ! ------------------- - DO jk = klev, 1, -1 - DO jl = kidia, kfdia - IF (ktest(jl)==1) THEN - IF (jk>=iknub(jl) .AND. jk<=iknul(jl)) THEN - pulow(jl) = pulow(jl) + pum1(jl, jk)*(paphm1(jl,jk+1)-paphm1(jl,jk) & - ) - pvlow(jl) = pvlow(jl) + pvm1(jl, jk)*(paphm1(jl,jk+1)-paphm1(jl,jk) & - ) - zrho(jl, klev+1) = zrho(jl, klev+1) + zrho(jl, jk)*(paphm1(jl,jk+1) & - -paphm1(jl,jk)) - END IF - END IF - END DO - END DO - DO jl = kidia, kfdia - IF (ktest(jl)==1) THEN - pulow(jl) = pulow(jl)/(paphm1(jl,iknul(jl)+1)-paphm1(jl,iknub(jl))) - pvlow(jl) = pvlow(jl)/(paphm1(jl,iknul(jl)+1)-paphm1(jl,iknub(jl))) - zrho(jl, klev+1) = zrho(jl, klev+1)/(paphm1(jl,iknul(jl)+1)-paphm1(jl, & - iknub(jl))) - END IF - END DO - - ! *********************************************************** - - ! * 3. COMPUTE MOUNTAIN LIFT - - - DO jl = kidia, kfdia - IF (ktest(jl)==1) THEN - ztau(jl, klev+1) = -gklift*zrho(jl, klev+1)*2.*romega* & ! * - ! (2*pstd(jl)+pmea(jl))* - 2*pstd(jl)*sin(rpi/180.*plat(jl))*pvlow(jl) - ztav(jl, klev+1) = gklift*zrho(jl, klev+1)*2.*romega* & ! * - ! (2*pstd(jl)+pmea(jl))* - 2*pstd(jl)*sin(rpi/180.*plat(jl))*pulow(jl) - ELSE - ztau(jl, klev+1) = 0.0 - ztav(jl, klev+1) = 0.0 - END IF - END DO - - ! * 4. COMPUTE LIFT PROFILE - ! * -------------------- - - - - DO jk = 1, klev - DO jl = kidia, kfdia - IF (ktest(jl)==1) THEN - ztau(jl, jk) = ztau(jl, klev+1)*paphm1(jl, jk)/paphm1(jl, klev+1) - ztav(jl, jk) = ztav(jl, klev+1)*paphm1(jl, jk)/paphm1(jl, klev+1) - ELSE - ztau(jl, jk) = 0.0 - ztav(jl, jk) = 0.0 - END IF - END DO - END DO - - - ! * 5. COMPUTE TENDENCIES. - ! * ------------------- - IF (lifthigh) THEN - ! EXPLICIT SOLUTION AT ALL LEVELS - - DO jk = 1, klev - DO jl = kidia, kfdia - IF (ktest(jl)==1) THEN - zdelp = paphm1(jl, jk+1) - paphm1(jl, jk) - zdudt(jl) = -rg*(ztau(jl,jk+1)-ztau(jl,jk))/zdelp - zdvdt(jl) = -rg*(ztav(jl,jk+1)-ztav(jl,jk))/zdelp - END IF - END DO - END DO - - ! PROJECT PERPENDICULARLY TO U NOT TO DESTROY ENERGY - - DO jk = 1, klev - DO jl = kidia, kfdia - IF (ktest(jl)==1) THEN - - zslow = sqrt(pulow(jl)**2+pvlow(jl)**2) - zsqua = amax1(sqrt(pum1(jl,jk)**2+pvm1(jl,jk)**2), gvsec) - zscav = -zdudt(jl)*pvm1(jl, jk) + zdvdt(jl)*pum1(jl, jk) - IF (zsqua>gvsec) THEN - pvom(jl, jk) = -zscav*pvm1(jl, jk)/zsqua**2 - pvol(jl, jk) = zscav*pum1(jl, jk)/zsqua**2 - ELSE - pvom(jl, jk) = 0.0 - pvol(jl, jk) = 0.0 - END IF - zsqua = sqrt(pum1(jl,jk)**2+pum1(jl,jk)**2) - IF (zsqua=zsigt) THEN - nktopg_tmp = jk - END IF - IF (zpm1r>=ztop) THEN - nstra_tmp = jk - END IF - END DO - ELSE - nktopg_tmp=0 - nstra_tmp=0 - ENDIF - - CALL reduce_sum(nktopg_tmp,nktopg) - CALL bcast(nktopg) - CALL reduce_sum(nstra_tmp,nstra) - CALL bcast(nstra) - - ! inversion car dans orodrag on compte les niveaux a l'envers - nktopg = nlev - nktopg + 1 - nstra = nlev - nstra - PRINT *, ' DANS SUGWD nktopg=', nktopg - PRINT *, ' DANS SUGWD nstra=', nstra - if (nstra == 0) call abort_physic("sugwd_strato", "no level in stratosphere", 1) - -! Valeurs lues dans les .def, ou attribues dans conf_phys - !gkdrag = 0.2 - !grahilo = 0.1 - !grcrit = 1.00 - !gfrcrit = 0.70 - !gkwake = 0.40 - !gklift = 0.25 - - gsigcr = 0.80 ! Top of low level flow - gvcrit = 0.1 - - WRITE (UNIT=6, FMT='('' *** SSO essential constants ***'')') - WRITE (UNIT=6, FMT='('' *** SPECIFIED IN SUGWD ***'')') - WRITE (UNIT=6, FMT='('' Gravity wave ct '',E13.7,'' '')') gkdrag - WRITE (UNIT=6, FMT='('' Trapped/total wave dag '',E13.7,'' '')') grahilo - WRITE (UNIT=6, FMT='('' Critical Richardson = '',E13.7,'' '')') grcrit - WRITE (UNIT=6, FMT='('' Critical Froude'',e13.7)') gfrcrit - WRITE (UNIT=6, FMT='('' Low level Wake bluff cte'',e13.7)') gkwake - WRITE (UNIT=6, FMT='('' Low level lift cte'',e13.7)') gklift - - ! ---------------------------------------------------------------- - - ! * 2. SET VALUES OF SECURITY PARAMETERS - ! --------------------------------- - - - gvsec = 0.10 - gssec = 0.0001 - - gtsec = 0.00001 - - RETURN -END SUBROUTINE sugwd_strato - -END MODULE orografi_strato_mod Index: LMDZ6/trunk/libf/phylmd/orografi_strato_mod.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/orografi_strato_mod.f90 (revision 6048) +++ LMDZ6/trunk/libf/phylmd/orografi_strato_mod.f90 (revision 6048) @@ -0,0 +1,1948 @@ +!$gpum horizontal klon nlon kfdia +MODULE orografi_strato_mod + PRIVATE + + PUBLIC drag_noro_strato, orodrag_strato, orosetup_strato, gwstress_strato, & + & lift_noro_strato, orolift_strato, sugwd_strato + +CONTAINS + +SUBROUTINE drag_noro_strato(partdrag, nlon, nlev, dtime, paprs, pplay, pmea, pstd, & + psig, pgam, pthe, ppic, pval, kgwd, kdx, ktest, t, u, v, pulow, pvlow, & + pustr, pvstr, d_t, d_u, d_v) + + USE yomcst_mod_h + USE dimphy + USE yoegwd_mod_h + IMPLICIT NONE + ! ====================================================================== + ! Auteur(s): F.Lott (LMD/CNRS) date: 19950201 + ! Object: Mountain drag interface. Made necessary because: + ! 1. in the LMD-GCM Layers are from bottom to top, + ! contrary to most European GCM. + ! 2. the altitude above ground of each model layers + ! needs to be known (variable zgeom) + ! ====================================================================== + ! Explicit Arguments: + ! ================== + ! partdrag-input-I-control which part of the drag we consider (total part or GW part) + ! nlon----input-I-Total number of horizontal points that get into physics + ! nlev----input-I-Number of vertical levels + ! dtime---input-R-Time-step (s) + ! paprs---input-R-Pressure in semi layers (Pa) + ! pplay---input-R-Pressure model-layers (Pa) + ! t-------input-R-temperature (K) + ! u-------input-R-Horizontal wind (m/s) + ! v-------input-R-Meridional wind (m/s) + ! pmea----input-R-Mean Orography (m) + ! pstd----input-R-SSO standard deviation (m) + ! psig----input-R-SSO slope + ! pgam----input-R-SSO Anisotropy + ! pthe----input-R-SSO Angle + ! ppic----input-R-SSO Peacks elevation (m) + ! pval----input-R-SSO Valleys elevation (m) + + ! kgwd- -input-I: Total nb of points where the orography schemes are active + ! ktest--input-I: Flags to indicate active points + ! kdx----input-I: Locate the physical location of an active point. + + ! pulow, pvlow -output-R: Low-level wind + ! pustr, pvstr -output-R: Surface stress due to SSO drag (Pa) + + ! d_t-----output-R: T increment + ! d_u-----output-R: U increment + ! d_v-----output-R: V increment + + ! Implicit Arguments: + ! =================== + + ! iim--common-I: Number of longitude intervals + ! jjm--common-I: Number of latitude intervals + ! klon-common-I: Number of points seen by the physics + ! (iim+1)*(jjm+1) for instance + ! klev-common-I: Number of vertical layers + ! ====================================================================== + ! Local Variables: + ! ================ + + ! zgeom-----R: Altitude of layer above ground + ! pt, pu, pv --R: t u v from top to bottom + ! pdtdt, pdudt, pdvdt --R: t u v tendencies (from top to bottom) + ! papmf: pressure at model layer (from top to bottom) + ! papmh: pressure at model 1/2 layer (from top to bottom) + + ! ====================================================================== + + ! ARGUMENTS + + INTEGER partdrag,nlon, nlev + REAL dtime + REAL paprs(nlon, nlev+1) + REAL pplay(nlon, nlev) + REAL pmea(nlon), pstd(nlon), psig(nlon), pgam(nlon), pthe(nlon) + REAL ppic(nlon), pval(nlon) + REAL pulow(nlon), pvlow(nlon), pustr(nlon), pvstr(nlon) + REAL t(nlon, nlev), u(nlon, nlev), v(nlon, nlev) + REAL d_t(nlon, nlev), d_u(nlon, nlev), d_v(nlon, nlev) + + INTEGER i, k, kgwd, kdx(nlon), ktest(nlon) + + ! LOCAL VARIABLES: + + REAL zgeom(klon, klev) + REAL pdtdt(klon, klev), pdudt(klon, klev), pdvdt(klon, klev) + REAL pt(klon, klev), pu(klon, klev), pv(klon, klev) + REAL papmf(klon, klev), papmh(klon, klev+1) + CHARACTER (LEN=20) :: modname = 'orografi_strato' + CHARACTER (LEN=80) :: abort_message + + ! INITIALIZE OUTPUT VARIABLES + + DO i = 1, klon + pulow(i) = 0.0 + pvlow(i) = 0.0 + pustr(i) = 0.0 + pvstr(i) = 0.0 + END DO + DO k = 1, klev + DO i = 1, klon + d_t(i, k) = 0.0 + d_u(i, k) = 0.0 + d_v(i, k) = 0.0 + pdudt(i, k) = 0.0 + pdvdt(i, k) = 0.0 + pdtdt(i, k) = 0.0 + END DO + END DO + + ! PREPARE INPUT VARIABLES FOR ORODRAG (i.e., ORDERED FROM TOP TO BOTTOM) + ! CALCULATE LAYERS HEIGHT ABOVE GROUND) + + DO k = 1, klev + DO i = 1, klon + pt(i, k) = t(i, klev-k+1) + pu(i, k) = u(i, klev-k+1) + pv(i, k) = v(i, klev-k+1) + papmf(i, k) = pplay(i, klev-k+1) + END DO + END DO + DO k = 1, klev + 1 + DO i = 1, klon + papmh(i, k) = paprs(i, klev-k+2) + END DO + END DO + DO i = 1, klon + zgeom(i, klev) = rd*pt(i, klev)*log(papmh(i,klev+1)/papmf(i,klev)) + END DO + DO k = klev - 1, 1, -1 + DO i = 1, klon + zgeom(i, k) = zgeom(i, k+1) + rd*(pt(i,k)+pt(i,k+1))/2.0*log(papmf(i,k+ & + 1)/papmf(i,k)) + END DO + END DO + + ! CALL SSO DRAG ROUTINES + + CALL orodrag_strato(partdrag,klon, klev, kgwd, kdx, ktest, dtime, papmh, papmf, & + zgeom, pt, pu, pv, pmea, pstd, psig, pgam, pthe, ppic, pval, pulow, & + pvlow, pdudt, pdvdt, pdtdt) + + ! COMPUTE INCREMENTS AND STRESS FROM TENDENCIES + + DO k = 1, klev + DO i = 1, klon + d_u(i, klev+1-k) = dtime*pdudt(i, k) + d_v(i, klev+1-k) = dtime*pdvdt(i, k) + d_t(i, klev+1-k) = dtime*pdtdt(i, k) + pustr(i) = pustr(i) + pdudt(i, k)*(papmh(i,k+1)-papmh(i,k))/rg + pvstr(i) = pvstr(i) + pdvdt(i, k)*(papmh(i,k+1)-papmh(i,k))/rg + END DO + END DO + + RETURN +END SUBROUTINE drag_noro_strato + +SUBROUTINE orodrag_strato(partdrag,nlon, nlev, kgwd, kdx, ktest, ptsphy, paphm1, & + papm1, pgeom1, ptm1, pum1, pvm1, pmea, pstd, psig, pgam, pthe, ppic, pval & + ! outputs + , pulow, pvlow, pvom, pvol, pte) + + USE yomcst_mod_h + USE dimphy + USE yoegwd_mod_h + IMPLICIT NONE + + + ! **** *orodrag* - does the SSO drag parametrization. + + ! purpose. + ! -------- + + ! this routine computes the physical tendencies of the + ! prognostic variables u,v and t due to vertical transports by + ! subgridscale orographically excited gravity waves, and to + ! low level blocked flow drag. + + ! ** interface. + ! ---------- + ! called from *drag_noro*. + + ! the routine takes its input from the long-term storage: + ! u,v,t and p at t-1. + + ! explicit arguments : + ! -------------------- + ! ==== inputs === + ! partdrag-input-I-control which part of the drag we consider (total part or GW part) + ! nlon----input-I-Total number of horizontal points that get into physics + ! nlev----input-I-Number of vertical levels + + ! kgwd- -input-I: Total nb of points where the orography schemes are active + ! ktest--input-I: Flags to indicate active points + ! kdx----input-I: Locate the physical location of an active point. + ! ptsphy--input-R-Time-step (s) + ! paphm1--input-R: pressure at model 1/2 layer + ! papm1---input-R: pressure at model layer + ! pgeom1--input-R: Altitude of layer above ground + ! ptm1, pum1, pvm1--R-: t, u and v + ! pmea----input-R-Mean Orography (m) + ! pstd----input-R-SSO standard deviation (m) + ! psig----input-R-SSO slope + ! pgam----input-R-SSO Anisotropy + ! pthe----input-R-SSO Angle + ! ppic----input-R-SSO Peacks elevation (m) + ! pval----input-R-SSO Valleys elevation (m) + + INTEGER nlon, nlev, kgwd + REAL ptsphy + + ! ==== outputs === + ! pulow, pvlow -output-R: Low-level wind + + ! pte -----output-R: T tendency + ! pvom-----output-R: U tendency + ! pvol-----output-R: V tendency + + + ! Implicit Arguments: + ! =================== + + ! klon-common-I: Number of points seen by the physics + ! klev-common-I: Number of vertical layers + + ! method. + ! ------- + + ! externals. + ! ---------- + INTEGER ismin, ismax + EXTERNAL ismin, ismax + + ! reference. + ! ---------- + + ! author. + ! ------- + ! m.miller + b.ritter e.c.m.w.f. 15/06/86. + + ! f.lott + m. miller e.c.m.w.f. 22/11/94 + ! ----------------------------------------------------------------------- + + ! * 0.1 arguments + ! --------- + + INTEGER partdrag + REAL pte(nlon, nlev), pvol(nlon, nlev), pvom(nlon, nlev), pulow(nlon), & + pvlow(nlon) + REAL pum1(nlon, nlev), pvm1(nlon, nlev), ptm1(nlon, nlev), pmea(nlon), & + pstd(nlon), psig(nlon), pgam(nlon), pthe(nlon), ppic(nlon), pval(nlon), & + pgeom1(nlon, nlev), papm1(nlon, nlev), paphm1(nlon, nlev+1) + + INTEGER kdx(nlon), ktest(nlon) + ! ----------------------------------------------------------------------- + + ! * 0.2 local arrays + ! ------------ + INTEGER isect(klon), icrit(klon), ikcrith(klon), ikenvh(klon), iknu(klon), & + iknu2(klon), ikcrit(klon), ikhlim(klon) + + REAL ztau(klon, klev+1), zstab(klon, klev+1), zvph(klon, klev+1), & + zrho(klon, klev+1), zri(klon, klev+1), zpsi(klon, klev+1), & + zzdep(klon, klev) + REAL zdudt(klon), zdvdt(klon), zdtdt(klon), zdedt(klon), zvidis(klon), & + ztfr(klon), znu(klon), zd1(klon), zd2(klon), zdmod(klon) + + + ! local quantities: + + INTEGER jl, jk, ji + REAL ztmst, zdelp, ztemp, zforc, ztend, rover, facpart + REAL zb, zc, zconb, zabsv, zzd1, ratio, zbet, zust, zvst, zdis + + ! ------------------------------------------------------------------ + + ! * 1. initialization + ! -------------- + + ! print *,' in orodrag' + + ! ------------------------------------------------------------------ + + ! * 1.1 computational constants + ! ----------------------- + + + ! ztmst=twodt + ! if(nstep.eq.nstart) ztmst=0.5*twodt + ztmst = ptsphy + + ! ------------------------------------------------------------------ + + ! * 1.3 check whether row contains point for printing + ! --------------------------------------------- + + + ! ------------------------------------------------------------------ + + ! * 2. precompute basic state variables. + ! * ---------- ----- ----- ---------- + ! * define low level wind, project winds in plane of + ! * low level wind, determine sector in which to take + ! * the variance and set indicator for critical levels. + + + + + + CALL orosetup_strato(nlon, nlev, ktest, ikcrit, ikcrith, icrit, isect, & + ikhlim, ikenvh, iknu, iknu2, paphm1, papm1, pum1, pvm1, ptm1, pgeom1, & + pstd, zrho, zri, zstab, ztau, zvph, zpsi, zzdep, pulow, pvlow, pthe, & + pgam, pmea, ppic, pval, znu, zd1, zd2, zdmod) + + ! *********************************************************** + + + ! * 3. compute low level stresses using subcritical and + ! * supercritical forms.computes anisotropy coefficient + ! * as measure of orographic twodimensionality. + + + CALL gwstress_strato(nlon, nlev, ikcrit, isect, ikhlim, ktest, ikcrith, & + icrit, ikenvh, iknu, zrho, zstab, zvph, pstd, psig, pmea, ppic, pval, & + ztfr, ztau, pgeom1, pgam, zd1, zd2, zdmod, znu) + + ! * 4. compute stress profile including + ! trapped waves, wave breaking, + ! linear decay in stratosphere. + + + + + CALL gwprofil_strato(nlon, nlev, kgwd, kdx, ktest, ikcrit, ikcrith, icrit, & + ikenvh, iknu, iknu2, paphm1, zrho, zstab, ztfr, zvph, zri, ztau & + , zdmod, znu, psig, pgam, pstd, ppic, pval) + + ! * 5. Compute tendencies from waves stress profile. + ! Compute low level blocked flow drag. + ! * -------------------------------------------- + + + + + ! explicit solution at all levels for the gravity wave + ! implicit solution for the blocked levels + + DO jl = kidia, kfdia + zvidis(jl) = 0.0 + zdudt(jl) = 0.0 + zdvdt(jl) = 0.0 + zdtdt(jl) = 0.0 + END DO + + + DO jk = 1, klev + + + ! WAVE STRESS + ! ------------- + + + DO ji = kidia, kfdia + + IF (ktest(ji)==1) THEN + + zdelp = paphm1(ji, jk+1) - paphm1(ji, jk) + ztemp = -rg*(ztau(ji,jk+1)-ztau(ji,jk))/(zvph(ji,klev+1)*zdelp) + + zdudt(ji) = (pulow(ji)*zd1(ji)-pvlow(ji)*zd2(ji))*ztemp/zdmod(ji) + zdvdt(ji) = (pvlow(ji)*zd1(ji)+pulow(ji)*zd2(ji))*ztemp/zdmod(ji) + + ! Control Overshoots + + + IF (jk>=nstra) THEN + rover = 0.10 + IF (abs(zdudt(ji))>rover*abs(pum1(ji,jk))/ztmst) zdudt(ji) = rover* & + abs(pum1(ji,jk))/ztmst*zdudt(ji)/(abs(zdudt(ji))+1.E-10) + IF (abs(zdvdt(ji))>rover*abs(pvm1(ji,jk))/ztmst) zdvdt(ji) = rover* & + abs(pvm1(ji,jk))/ztmst*zdvdt(ji)/(abs(zdvdt(ji))+1.E-10) + END IF + + rover = 0.25 + zforc = sqrt(zdudt(ji)**2+zdvdt(ji)**2) + ztend = sqrt(pum1(ji,jk)**2+pvm1(ji,jk)**2)/ztmst + + IF (zforc>=rover*ztend) THEN + zdudt(ji) = rover*ztend/zforc*zdudt(ji) + zdvdt(ji) = rover*ztend/zforc*zdvdt(ji) + END IF + + ! BLOCKED FLOW DRAG: + ! ----------------- + + IF (partdrag .GE. 2) THEN + facpart=0. + ELSE + facpart=gkwake + ENDIF + + + IF (jk>ikenvh(ji)) THEN + zb = 1.0 - 0.18*pgam(ji) - 0.04*pgam(ji)**2 + zc = 0.48*pgam(ji) + 0.3*pgam(ji)**2 + zconb = 2.*ztmst*facpart*psig(ji)/(4.*pstd(ji)) + zabsv = sqrt(pum1(ji,jk)**2+pvm1(ji,jk)**2)/2. + zzd1 = zb*cos(zpsi(ji,jk))**2 + zc*sin(zpsi(ji,jk))**2 + ratio = (cos(zpsi(ji,jk))**2+pgam(ji)*sin(zpsi(ji, & + jk))**2)/(pgam(ji)*cos(zpsi(ji,jk))**2+sin(zpsi(ji,jk))**2) + zbet = max(0., 2.-1./ratio)*zconb*zzdep(ji, jk)*zzd1*zabsv + + ! OPPOSED TO THE WIND + + zdudt(ji) = -pum1(ji, jk)/ztmst + zdvdt(ji) = -pvm1(ji, jk)/ztmst + + ! PERPENDICULAR TO THE SSO MAIN AXIS: + + ! mod zdudt(ji)=-(pum1(ji,jk)*cos(pthe(ji)*rpi/180.) + ! mod * +pvm1(ji,jk)*sin(pthe(ji)*rpi/180.)) + ! mod * *cos(pthe(ji)*rpi/180.)/ztmst + ! mod zdvdt(ji)=-(pum1(ji,jk)*cos(pthe(ji)*rpi/180.) + ! mod * +pvm1(ji,jk)*sin(pthe(ji)*rpi/180.)) + ! mod * *sin(pthe(ji)*rpi/180.)/ztmst + + zdudt(ji) = zdudt(ji)*(zbet/(1.+zbet)) + zdvdt(ji) = zdvdt(ji)*(zbet/(1.+zbet)) + END IF + pvom(ji, jk) = zdudt(ji) + pvol(ji, jk) = zdvdt(ji) + zust = pum1(ji, jk) + ztmst*zdudt(ji) + zvst = pvm1(ji, jk) + ztmst*zdvdt(ji) + zdis = 0.5*(pum1(ji,jk)**2+pvm1(ji,jk)**2-zust**2-zvst**2) + zdedt(ji) = zdis/ztmst + zvidis(ji) = zvidis(ji) + zdis*zdelp + zdtdt(ji) = zdedt(ji)/rcpd + + ! NO TENDENCIES ON TEMPERATURE ..... + + ! Instead of, pte(ji,jk)=zdtdt(ji), due to mechanical dissipation + + pte(ji, jk) = 0.0 + + END IF + + END DO + END DO + + RETURN +END SUBROUTINE orodrag_strato +SUBROUTINE orosetup_strato(nlon, nlev, ktest, kkcrit, kkcrith, kcrit, ksect, & + kkhlim, kkenvh, kknu, kknu2, paphm1, papm1, pum1, pvm1, ptm1, pgeom1, & + pstd, prho, pri, pstab, ptau, pvph, ppsi, pzdep, pulow, pvlow, ptheta, & + pgam, pmea, ppic, pval, pnu, pd1, pd2, pdmod) + + ! **** *gwsetup* + + ! purpose. + ! -------- + ! SET-UP THE ESSENTIAL PARAMETERS OF THE SSO DRAG SCHEME: + ! DEPTH OF LOW WBLOCKED LAYER, LOW-LEVEL FLOW, BACKGROUND + ! STRATIFICATION..... + + ! ** interface. + ! ---------- + ! from *orodrag* + + ! explicit arguments : + ! -------------------- + ! ==== inputs === + + ! nlon----input-I-Total number of horizontal points that get into physics + ! nlev----input-I-Number of vertical levels + ! ktest--input-I: Flags to indicate active points + + ! ptsphy--input-R-Time-step (s) + ! paphm1--input-R: pressure at model 1/2 layer + ! papm1---input-R: pressure at model layer + ! pgeom1--input-R: Altitude of layer above ground + ! ptm1, pum1, pvm1--R-: t, u and v + ! pmea----input-R-Mean Orography (m) + ! pstd----input-R-SSO standard deviation (m) + ! psig----input-R-SSO slope + ! pgam----input-R-SSO Anisotropy + ! pthe----input-R-SSO Angle + ! ppic----input-R-SSO Peacks elevation (m) + ! pval----input-R-SSO Valleys elevation (m) + + ! ==== outputs === + ! pulow, pvlow -output-R: Low-level wind + ! kkcrit----I-: Security value for top of low level flow + ! kcrit-----I-: Critical level + ! ksect-----I-: Not used + ! kkhlim----I-: Not used + ! kkenvh----I-: Top of blocked flow layer + ! kknu------I-: Layer that sees mountain peacks + ! kknu2-----I-: Layer that sees mountain peacks above mountain mean + ! kknub-----I-: Layer that sees mountain mean above valleys + ! prho------R-: Density at 1/2 layers + ! pri-------R-: Background Richardson Number, Wind shear measured along GW + ! stress + ! pstab-----R-: Brunt-Vaisala freq. at 1/2 layers + ! pvph------R-: Wind in plan of GW stress, Half levels. + ! ppsi------R-: Angle between low level wind and SS0 main axis. + ! pd1-------R-| Compared the ratio of the stress + ! pd2-------R-| that is along the wind to that Normal to it. + ! pdi define the plane of low level stress + ! compared to the low level wind. + ! see p. 108 Lott & Miller (1997). + ! pdmod-----R-: Norme of pdi + + ! === local arrays === + + ! zvpf------R-: Wind projected in the plan of the low-level stress. + + ! ==== outputs === + + ! implicit arguments : none + ! -------------------- + + ! method. + ! ------- + + + ! externals. + ! ---------- + + + ! reference. + ! ---------- + + ! see ecmwf research department documentation of the "i.f.s." + + ! author. + ! ------- + + ! modifications. + ! -------------- + ! f.lott for the new-gwdrag scheme november 1993 + + ! ----------------------------------------------------------------------- +USE yoegwd_mod_h + USE dimphy + USE yomcst_mod_h +IMPLICIT NONE + + + + + ! ----------------------------------------------------------------------- + + ! * 0.1 arguments + ! --------- + + INTEGER nlon, nlev + INTEGER kkcrit(nlon), kkcrith(nlon), kcrit(nlon), ksect(nlon), & + kkhlim(nlon), ktest(nlon), kkenvh(nlon) + + + REAL paphm1(nlon, klev+1), papm1(nlon, klev), pum1(nlon, klev), & + pvm1(nlon, klev), ptm1(nlon, klev), pgeom1(nlon, klev), & + prho(nlon, klev+1), pri(nlon, klev+1), pstab(nlon, klev+1), & + ptau(nlon, klev+1), pvph(nlon, klev+1), ppsi(nlon, klev+1), & + pzdep(nlon, klev) + REAL pulow(nlon), pvlow(nlon), ptheta(nlon), pgam(nlon), pnu(nlon), & + pd1(nlon), pd2(nlon), pdmod(nlon) + REAL pstd(nlon), pmea(nlon), ppic(nlon), pval(nlon) + + ! ----------------------------------------------------------------------- + + ! * 0.2 local arrays + ! ------------ + + + INTEGER ilevh, jl, jk + REAL zcons1, zcons2, zhgeo, zu, zphi + REAL zvt1, zvt2, zdwind, zwind, zdelp + REAL zstabm, zstabp, zrhom, zrhop + LOGICAL lo + LOGICAL ll1(klon, klev+1) + INTEGER kknu(klon), kknu2(klon), kknub(klon), kknul(klon), kentp(klon), & + ncount(klon) + + REAL zhcrit(klon, klev), zvpf(klon, klev), zdp(klon, klev) + REAL znorm(klon), zb(klon), zc(klon), zulow(klon), zvlow(klon), znup(klon), & + znum(klon) + + ! ------------------------------------------------------------------ + + ! * 1. initialization + ! -------------- + + ! PRINT *,' in orosetup' + + ! ------------------------------------------------------------------ + + ! * 1.1 computational constants + ! ----------------------- + + + ilevh = klev/3 + + zcons1 = 1./rd + zcons2 = rg**2/rcpd + + ! ------------------------------------------------------------------ + + ! * 2. + ! -------------- + + + ! ------------------------------------------------------------------ + + ! * 2.1 define low level wind, project winds in plane of + ! * low level wind, determine sector in which to take + ! * the variance and set indicator for critical levels. + + + + DO jl = kidia, kfdia + kknu(jl) = klev + kknu2(jl) = klev + kknub(jl) = klev + kknul(jl) = klev + pgam(jl) = max(pgam(jl), gtsec) + ll1(jl, klev+1) = .FALSE. + END DO + + ! Ajouter une initialisation (L. Li, le 23fev99): + + DO jk = klev, ilevh, -1 + DO jl = kidia, kfdia + ll1(jl, jk) = .FALSE. + END DO + END DO + + ! * define top of low level flow + ! ---------------------------- + DO jk = klev, ilevh, -1 + DO jl = kidia, kfdia + IF (ktest(jl)==1) THEN + lo = (paphm1(jl,jk)/paphm1(jl,klev+1)) >= gsigcr + IF (lo) THEN + kkcrit(jl) = jk + END IF + zhcrit(jl, jk) = ppic(jl) - pval(jl) + zhgeo = pgeom1(jl, jk)/rg + ll1(jl, jk) = (zhgeo>zhcrit(jl,jk)) + IF (ll1(jl,jk) .NEQV. ll1(jl,jk+1)) THEN + kknu(jl) = jk + END IF + IF (.NOT. ll1(jl,ilevh)) kknu(jl) = ilevh + END IF + END DO + END DO + DO jk = klev, ilevh, -1 + DO jl = kidia, kfdia + IF (ktest(jl)==1) THEN + zhcrit(jl, jk) = ppic(jl) - pmea(jl) + zhgeo = pgeom1(jl, jk)/rg + ll1(jl, jk) = (zhgeo>zhcrit(jl,jk)) + IF (ll1(jl,jk) .NEQV. ll1(jl,jk+1)) THEN + kknu2(jl) = jk + END IF + IF (.NOT. ll1(jl,ilevh)) kknu2(jl) = ilevh + END IF + END DO + END DO + DO jk = klev, ilevh, -1 + DO jl = kidia, kfdia + IF (ktest(jl)==1) THEN + zhcrit(jl, jk) = amin1(ppic(jl)-pmea(jl), pmea(jl)-pval(jl)) + zhgeo = pgeom1(jl, jk)/rg + ll1(jl, jk) = (zhgeo>zhcrit(jl,jk)) + IF (ll1(jl,jk) .NEQV. ll1(jl,jk+1)) THEN + kknub(jl) = jk + END IF + IF (.NOT. ll1(jl,ilevh)) kknub(jl) = ilevh + END IF + END DO + END DO + + DO jl = kidia, kfdia + IF (ktest(jl)==1) THEN + kknu(jl) = min(kknu(jl), nktopg) + kknu2(jl) = min(kknu2(jl), nktopg) + kknub(jl) = min(kknub(jl), nktopg) + kknul(jl) = klev + END IF + END DO + + ! c* initialize various arrays + + DO jl = kidia, kfdia + prho(jl, klev+1) = 0.0 + ! ym correction en attendant mieux + prho(jl, 1) = 0.0 + pstab(jl, klev+1) = 0.0 + pstab(jl, 1) = 0.0 + pri(jl, klev+1) = 9999.0 + ppsi(jl, klev+1) = 0.0 + pri(jl, 1) = 0.0 + pvph(jl, 1) = 0.0 + pvph(jl, klev+1) = 0.0 + ! ym correction en attendant mieux + ! ym pvph(jl,klev) =0.0 + pulow(jl) = 0.0 + pvlow(jl) = 0.0 + zulow(jl) = 0.0 + zvlow(jl) = 0.0 + kkcrith(jl) = klev + kkenvh(jl) = klev + kentp(jl) = klev + kcrit(jl) = 1 + ncount(jl) = 0 + ll1(jl, klev+1) = .FALSE. + END DO + + ! * define flow density and stratification (rho and N2) + ! at semi layers. + ! ------------------------------------------------------- + + DO jk = klev, 2, -1 + DO jl = kidia, kfdia + IF (ktest(jl)==1) THEN + zdp(jl, jk) = papm1(jl, jk) - papm1(jl, jk-1) + prho(jl, jk) = 2.*paphm1(jl, jk)*zcons1/(ptm1(jl,jk)+ptm1(jl,jk-1)) + pstab(jl, jk) = 2.*zcons2/(ptm1(jl,jk)+ptm1(jl,jk-1))* & + (1.-rcpd*prho(jl,jk)*(ptm1(jl,jk)-ptm1(jl,jk-1))/zdp(jl,jk)) + pstab(jl, jk) = max(pstab(jl,jk), gssec) + END IF + END DO + END DO + + ! ******************************************************************** + + ! * define Low level flow (between ground and peacks-valleys) + ! --------------------------------------------------------- + DO jk = klev, ilevh, -1 + DO jl = kidia, kfdia + IF (ktest(jl)==1) THEN + IF (jk>=kknu2(jl) .AND. jk<=kknul(jl)) THEN + pulow(jl) = pulow(jl) + pum1(jl, jk)*(paphm1(jl,jk+1)-paphm1(jl,jk) & + ) + pvlow(jl) = pvlow(jl) + pvm1(jl, jk)*(paphm1(jl,jk+1)-paphm1(jl,jk) & + ) + pstab(jl, klev+1) = pstab(jl, klev+1) + pstab(jl, jk)*(paphm1(jl,jk & + +1)-paphm1(jl,jk)) + prho(jl, klev+1) = prho(jl, klev+1) + prho(jl, jk)*(paphm1(jl,jk+1) & + -paphm1(jl,jk)) + END IF + END IF + END DO + END DO + DO jl = kidia, kfdia + IF (ktest(jl)==1) THEN + pulow(jl) = pulow(jl)/(paphm1(jl,kknul(jl)+1)-paphm1(jl,kknu2(jl))) + pvlow(jl) = pvlow(jl)/(paphm1(jl,kknul(jl)+1)-paphm1(jl,kknu2(jl))) + znorm(jl) = max(sqrt(pulow(jl)**2+pvlow(jl)**2), gvsec) + pvph(jl, klev+1) = znorm(jl) + pstab(jl, klev+1) = pstab(jl, klev+1)/(paphm1(jl,kknul(jl)+1)-paphm1(jl & + ,kknu2(jl))) + prho(jl, klev+1) = prho(jl, klev+1)/(paphm1(jl,kknul(jl)+1)-paphm1(jl, & + kknu2(jl))) + END IF + END DO + + + ! ******* setup orography orientation relative to the low level + ! wind and define parameters of the Anisotropic wave stress. + + DO jl = kidia, kfdia + IF (ktest(jl)==1) THEN + lo = (pulow(jl)=-gvsec) + IF (lo) THEN + zu = pulow(jl) + 2.*gvsec + ELSE + zu = pulow(jl) + END IF + zphi = atan(pvlow(jl)/zu) + ppsi(jl, klev+1) = ptheta(jl)*rpi/180. - zphi + zb(jl) = 1. - 0.18*pgam(jl) - 0.04*pgam(jl)**2 + zc(jl) = 0.48*pgam(jl) + 0.3*pgam(jl)**2 + pd1(jl) = zb(jl) - (zb(jl)-zc(jl))*(sin(ppsi(jl,klev+1))**2) + pd2(jl) = (zb(jl)-zc(jl))*sin(ppsi(jl,klev+1))*cos(ppsi(jl,klev+1)) + pdmod(jl) = sqrt(pd1(jl)**2+pd2(jl)**2) + END IF + END DO + + ! ************ projet flow in plane of lowlevel stress ************* + ! ************ Find critical levels... ************* + + DO jk = 1, klev + DO jl = kidia, kfdia + IF (ktest(jl)==1) THEN + zvt1 = pulow(jl)*pum1(jl, jk) + pvlow(jl)*pvm1(jl, jk) + zvt2 = -pvlow(jl)*pum1(jl, jk) + pulow(jl)*pvm1(jl, jk) + zvpf(jl, jk) = (zvt1*pd1(jl)+zvt2*pd2(jl))/(znorm(jl)*pdmod(jl)) + END IF + ptau(jl, jk) = 0.0 + pzdep(jl, jk) = 0.0 + ppsi(jl, jk) = 0.0 + ll1(jl, jk) = .FALSE. + END DO + END DO + DO jk = 2, klev + DO jl = kidia, kfdia + IF (ktest(jl)==1) THEN + zdp(jl, jk) = papm1(jl, jk) - papm1(jl, jk-1) + pvph(jl, jk) = ((paphm1(jl,jk)-papm1(jl,jk-1))*zvpf(jl,jk)+(papm1(jl, & + jk)-paphm1(jl,jk))*zvpf(jl,jk-1))/zdp(jl, jk) + IF (pvph(jl,jk)=kknu2(jl)) THEN + + znum(jl) = pnu(jl) + zwind = (pulow(jl)*pum1(jl,jk)+pvlow(jl)*pvm1(jl,jk))/ & + max(sqrt(pulow(jl)**2+pvlow(jl)**2), gvsec) + zwind = max(sqrt(zwind**2), gvsec) + zdelp = paphm1(jl, jk+1) - paphm1(jl, jk) + zstabm = sqrt(max(pstab(jl,jk),gssec)) + zstabp = sqrt(max(pstab(jl,jk+1),gssec)) + zrhom = prho(jl, jk) + zrhop = prho(jl, jk+1) + pnu(jl) = pnu(jl) + (zdelp/rg)*((zstabp/zrhop+zstabm/zrhom)/2.)/ & + zwind + IF ((znum(jl)<=gfrcrit) .AND. (pnu(jl)>gfrcrit) .AND. (kkenvh( & + jl)==klev)) kkenvh(jl) = jk + + END IF + + END IF + + END DO + END DO + + ! calculation of a dynamical mixing height for when the waves + ! BREAK AT LOW LEVEL: The drag will be repartited over + ! a depths that depends on waves vertical wavelength, + ! not just between two adjacent model layers. + ! of gravity waves: + + DO jl = kidia, kfdia + znup(jl) = 0.0 + znum(jl) = 0.0 + END DO + + DO jk = klev - 1, 2, -1 + DO jl = kidia, kfdia + + IF (ktest(jl)==1) THEN + + znum(jl) = znup(jl) + zwind = (pulow(jl)*pum1(jl,jk)+pvlow(jl)*pvm1(jl,jk))/ & + max(sqrt(pulow(jl)**2+pvlow(jl)**2), gvsec) + zwind = max(sqrt(zwind**2), gvsec) + zdelp = paphm1(jl, jk+1) - paphm1(jl, jk) + zstabm = sqrt(max(pstab(jl,jk),gssec)) + zstabp = sqrt(max(pstab(jl,jk+1),gssec)) + zrhom = prho(jl, jk) + zrhop = prho(jl, jk+1) + znup(jl) = znup(jl) + (zdelp/rg)*((zstabp/zrhop+zstabm/zrhom)/2.)/ & + zwind + IF ((znum(jl)<=rpi/4.) .AND. (znup(jl)>rpi/4.) .AND. (kkcrith( & + jl)==klev)) kkcrith(jl) = jk + + END IF + + END DO + END DO + + DO jl = kidia, kfdia + IF (ktest(jl)==1) THEN + kkcrith(jl) = max0(kkcrith(jl), ilevh*2) + kkcrith(jl) = max0(kkcrith(jl), kknu(jl)) + IF (kcrit(jl)>=kkcrith(jl)) kcrit(jl) = 1 + END IF + END DO + + ! directional info for flow blocking ************************* + + DO jk = 1, klev + DO jl = kidia, kfdia + IF (ktest(jl)==1) THEN + lo = (pum1(jl,jk)=-gvsec) + IF (lo) THEN + zu = pum1(jl, jk) + 2.*gvsec + ELSE + zu = pum1(jl, jk) + END IF + zphi = atan(pvm1(jl,jk)/zu) + ppsi(jl, jk) = ptheta(jl)*rpi/180. - zphi + END IF + END DO + END DO + + ! forms the vertical 'leakiness' ************************** + + DO jk = ilevh, klev + DO jl = kidia, kfdia + IF (ktest(jl)==1) THEN + pzdep(jl, jk) = 0 + IF (jk>=kkenvh(jl) .AND. kkenvh(jl)/=klev) THEN + pzdep(jl, jk) = (pgeom1(jl,kkenvh(jl))-pgeom1(jl,jk))/ & + (pgeom1(jl,kkenvh(jl))-pgeom1(jl,klev)) + END IF + END IF + END DO + END DO + + RETURN +END SUBROUTINE orosetup_strato +SUBROUTINE gwstress_strato(nlon, nlev, kkcrit, ksect, kkhlim, ktest, kkcrith, & + kcrit, kkenvh, kknu, prho, pstab, pvph, pstd, psig, pmea, ppic, pval, & + ptfr, ptau, pgeom1, pgamma, pd1, pd2, pdmod, pnu) + + ! **** *gwstress* + + ! purpose. + ! -------- + ! Compute the surface stress due to Gravity Waves, according + ! to the Phillips (1979) theory of 3-D flow above + ! anisotropic elliptic ridges. + + ! The stress is reduced two account for cut-off flow over + ! hill. The flow only see that part of the ridge located + ! above the blocked layer (see zeff). + + ! ** interface. + ! ---------- + ! call *gwstress* from *gwdrag* + + ! explicit arguments : + ! -------------------- + ! ==== inputs === + ! ==== outputs === + + ! implicit arguments : none + ! -------------------- + + ! method. + ! ------- + + + ! externals. + ! ---------- + + + ! reference. + ! ---------- + + ! LOTT and MILLER (1997) & LOTT (1999) + + ! author. + ! ------- + + ! modifications. + ! -------------- + ! f. lott put the new gwd on ifs 22/11/93 + + ! ----------------------------------------------------------------------- +USE yoegwd_mod_h + USE dimphy + USE yomcst_mod_h +IMPLICIT NONE + + + + ! ----------------------------------------------------------------------- + + ! * 0.1 arguments + ! --------- + + INTEGER nlon, nlev + INTEGER kkcrit(nlon), kkcrith(nlon), kcrit(nlon), ksect(nlon), & + kkhlim(nlon), ktest(nlon), kkenvh(nlon), kknu(nlon) + + REAL prho(nlon, nlev+1), pstab(nlon, nlev+1), ptau(nlon, nlev+1), & + pvph(nlon, nlev+1), ptfr(nlon), pgeom1(nlon, nlev), pstd(nlon) + + REAL pd1(nlon), pd2(nlon), pnu(nlon), psig(nlon), pgamma(nlon) + REAL pmea(nlon), ppic(nlon), pval(nlon) + REAL pdmod(nlon) + + ! ----------------------------------------------------------------------- + + ! * 0.2 local arrays + ! ------------ + ! zeff--real: effective height seen by the flow when there is blocking + + INTEGER jl + REAL zeff + + ! ----------------------------------------------------------------------- + + ! * 0.3 functions + ! --------- + ! ------------------------------------------------------------------ + + ! * 1. initialization + ! -------------- + + ! PRINT *,' in gwstress' + + ! * 3.1 gravity wave stress. + + + + DO jl = kidia, kfdia + IF (ktest(jl)==1) THEN + + ! effective mountain height above the blocked flow + + zeff = ppic(jl) - pval(jl) + IF (kkenvh(jl)kkcrith(jl)) THEN + zdelp = paphm1(jl, jk) - paphm1(jl, klev+1) + zdelpt = paphm1(jl, kkcrith(jl)) - paphm1(jl, klev+1) + ptau(jl, jk) = ztau(jl, klev+1) + zdelp/zdelpt*(ztau(jl,kkcrith(jl) & + )-ztau(jl,klev+1)) + ELSE + ptau(jl, jk) = ztau(jl, kkcrith(jl)) + END IF + END IF + END DO + + ! * 4.15 constant shear stress until the top of the + ! low level flow layer. + + + ! * 4.2 wave displacement at next level. + + + END DO + + + ! * 4.4 wave richardson number, new wave displacement + ! * and stress: breaking evaluation and critical + ! level + + + DO jk = klev, 1, -1 + + DO jl = kidia, kfdia + IF (ktest(jl)==1) THEN + znorm(jl) = prho(jl, jk)*sqrt(pstab(jl,jk))*pvph(jl, jk) + zdz2(jl, jk) = ptau(jl, jk)/amax1(znorm(jl), gssec)/zoro(jl) + END IF + END DO + + DO jl = kidia, kfdia + IF (ktest(jl)==1) THEN + IF (jkkkcrith(jl)-1) THEN + + zdelp = paphm1(jl, jk) - paphm1(jl, klev+1) + zdelpt = paphm1(jl, kkcrith(jl)-1) - paphm1(jl, klev+1) + ptau(jl, jk) = ztau(jl, klev+1) + (ztau(jl,kkcrith(jl)-1)-ztau(jl, & + klev+1))*zdelp/zdelpt + + END IF + END IF + + END DO + + ! REORGANISATION AT THE MODEL TOP.... + + DO jl = kidia, kfdia + IF (ktest(jl)==1) THEN + + IF (jkzhcrit(jl,jk)) + IF (ll1(jl,jk) .NEQV. ll1(jl,jk+1)) THEN + iknub(jl) = jk + END IF + END IF + END DO + END DO + + + DO jl = kidia, kfdia + IF (ktest(jl)==1) THEN + iknub(jl) = max(iknub(jl), klev/2) + iknul(jl) = max(iknul(jl), 2*klev/3) + IF (iknub(jl)>nktopg) iknub(jl) = nktopg + IF (iknub(jl)==nktopg) iknul(jl) = klev + IF (iknub(jl)==iknul(jl)) iknub(jl) = iknul(jl) - 1 + END IF + END DO + + DO jk = klev, 2, -1 + DO jl = kidia, kfdia + zrho(jl, jk) = 2.*paphm1(jl, jk)*zcons1/(ptm1(jl,jk)+ptm1(jl,jk-1)) + END DO + END DO + ! print *,' dans orolift: 223' + + ! ******************************************************************** + + ! * define low level flow + ! ------------------- + DO jk = klev, 1, -1 + DO jl = kidia, kfdia + IF (ktest(jl)==1) THEN + IF (jk>=iknub(jl) .AND. jk<=iknul(jl)) THEN + pulow(jl) = pulow(jl) + pum1(jl, jk)*(paphm1(jl,jk+1)-paphm1(jl,jk) & + ) + pvlow(jl) = pvlow(jl) + pvm1(jl, jk)*(paphm1(jl,jk+1)-paphm1(jl,jk) & + ) + zrho(jl, klev+1) = zrho(jl, klev+1) + zrho(jl, jk)*(paphm1(jl,jk+1) & + -paphm1(jl,jk)) + END IF + END IF + END DO + END DO + DO jl = kidia, kfdia + IF (ktest(jl)==1) THEN + pulow(jl) = pulow(jl)/(paphm1(jl,iknul(jl)+1)-paphm1(jl,iknub(jl))) + pvlow(jl) = pvlow(jl)/(paphm1(jl,iknul(jl)+1)-paphm1(jl,iknub(jl))) + zrho(jl, klev+1) = zrho(jl, klev+1)/(paphm1(jl,iknul(jl)+1)-paphm1(jl, & + iknub(jl))) + END IF + END DO + + ! *********************************************************** + + ! * 3. COMPUTE MOUNTAIN LIFT + + + DO jl = kidia, kfdia + IF (ktest(jl)==1) THEN + ztau(jl, klev+1) = -gklift*zrho(jl, klev+1)*2.*romega* & ! * + ! (2*pstd(jl)+pmea(jl))* + 2*pstd(jl)*sin(rpi/180.*plat(jl))*pvlow(jl) + ztav(jl, klev+1) = gklift*zrho(jl, klev+1)*2.*romega* & ! * + ! (2*pstd(jl)+pmea(jl))* + 2*pstd(jl)*sin(rpi/180.*plat(jl))*pulow(jl) + ELSE + ztau(jl, klev+1) = 0.0 + ztav(jl, klev+1) = 0.0 + END IF + END DO + + ! * 4. COMPUTE LIFT PROFILE + ! * -------------------- + + + + DO jk = 1, klev + DO jl = kidia, kfdia + IF (ktest(jl)==1) THEN + ztau(jl, jk) = ztau(jl, klev+1)*paphm1(jl, jk)/paphm1(jl, klev+1) + ztav(jl, jk) = ztav(jl, klev+1)*paphm1(jl, jk)/paphm1(jl, klev+1) + ELSE + ztau(jl, jk) = 0.0 + ztav(jl, jk) = 0.0 + END IF + END DO + END DO + + + ! * 5. COMPUTE TENDENCIES. + ! * ------------------- + IF (lifthigh) THEN + ! EXPLICIT SOLUTION AT ALL LEVELS + + DO jk = 1, klev + DO jl = kidia, kfdia + IF (ktest(jl)==1) THEN + zdelp = paphm1(jl, jk+1) - paphm1(jl, jk) + zdudt(jl) = -rg*(ztau(jl,jk+1)-ztau(jl,jk))/zdelp + zdvdt(jl) = -rg*(ztav(jl,jk+1)-ztav(jl,jk))/zdelp + END IF + END DO + END DO + + ! PROJECT PERPENDICULARLY TO U NOT TO DESTROY ENERGY + + DO jk = 1, klev + DO jl = kidia, kfdia + IF (ktest(jl)==1) THEN + + zslow = sqrt(pulow(jl)**2+pvlow(jl)**2) + zsqua = amax1(sqrt(pum1(jl,jk)**2+pvm1(jl,jk)**2), gvsec) + zscav = -zdudt(jl)*pvm1(jl, jk) + zdvdt(jl)*pum1(jl, jk) + IF (zsqua>gvsec) THEN + pvom(jl, jk) = -zscav*pvm1(jl, jk)/zsqua**2 + pvol(jl, jk) = zscav*pum1(jl, jk)/zsqua**2 + ELSE + pvom(jl, jk) = 0.0 + pvol(jl, jk) = 0.0 + END IF + zsqua = sqrt(pum1(jl,jk)**2+pum1(jl,jk)**2) + IF (zsqua=zsigt) THEN + nktopg_tmp = jk + END IF + IF (zpm1r>=ztop) THEN + nstra_tmp = jk + END IF + END DO + ELSE + nktopg_tmp=0 + nstra_tmp=0 + ENDIF + + CALL reduce_sum(nktopg_tmp,nktopg) + CALL bcast(nktopg) + CALL reduce_sum(nstra_tmp,nstra) + CALL bcast(nstra) + + ! inversion car dans orodrag on compte les niveaux a l'envers + nktopg = nlev - nktopg + 1 + nstra = nlev - nstra + PRINT *, ' DANS SUGWD nktopg=', nktopg + PRINT *, ' DANS SUGWD nstra=', nstra + if (nstra == 0) call abort_physic("sugwd_strato", "no level in stratosphere", 1) + +! Valeurs lues dans les .def, ou attribues dans conf_phys + !gkdrag = 0.2 + !grahilo = 0.1 + !grcrit = 1.00 + !gfrcrit = 0.70 + !gkwake = 0.40 + !gklift = 0.25 + + gsigcr = 0.80 ! Top of low level flow + gvcrit = 0.1 + + WRITE (UNIT=6, FMT='('' *** SSO essential constants ***'')') + WRITE (UNIT=6, FMT='('' *** SPECIFIED IN SUGWD ***'')') + WRITE (UNIT=6, FMT='('' Gravity wave ct '',E13.7,'' '')') gkdrag + WRITE (UNIT=6, FMT='('' Trapped/total wave dag '',E13.7,'' '')') grahilo + WRITE (UNIT=6, FMT='('' Critical Richardson = '',E13.7,'' '')') grcrit + WRITE (UNIT=6, FMT='('' Critical Froude'',e13.7)') gfrcrit + WRITE (UNIT=6, FMT='('' Low level Wake bluff cte'',e13.7)') gkwake + WRITE (UNIT=6, FMT='('' Low level lift cte'',e13.7)') gklift + + ! ---------------------------------------------------------------- + + ! * 2. SET VALUES OF SECURITY PARAMETERS + ! --------------------------------- + + + gvsec = 0.10 + gssec = 0.0001 + + gtsec = 0.00001 + + RETURN +END SUBROUTINE sugwd_strato + +END MODULE orografi_strato_mod Index: LMDZ6/trunk/libf/phylmd/paramlmdz_phy_mod.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/paramlmdz_phy_mod.F90 (revision 6047) +++ LMDZ6/trunk/libf/phylmd/paramlmdz_phy_mod.F90 (revision 6048) @@ -1,3 +1,3 @@ -MODULE paramLMDZ_phy_mod +MODULE paramlmdz_phy_mod ! Olivier 13/07/2016 @@ -262,3 +262,3 @@ END SUBROUTINE write_paramLMDZ_phy -END MODULE paramLMDZ_phy_mod +END MODULE paramlmdz_phy_mod Index: LMDZ6/trunk/libf/phylmd/phys_output_write_mod.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/phys_output_write_mod.F90 (revision 6047) +++ LMDZ6/trunk/libf/phylmd/phys_output_write_mod.F90 (revision 6048) @@ -527,5 +527,5 @@ USE YOERAD, ONLY: NLW #ifdef CPP_RRTM - USE FREQUENCES_LW_DATA, ONLY: deltanu ,wl1_lw, wl2_lw!FC + USE frequences_LW_data, ONLY: deltanu ,wl1_lw, wl2_lw!FC USE YOESW, ONLY : RSUN #endif Index: LMDZ6/trunk/libf/phylmd/physiq_mod.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/physiq_mod.F90 (revision 6047) +++ LMDZ6/trunk/libf/phylmd/physiq_mod.F90 (revision 6048) @@ -20,5 +20,5 @@ ! PLEASE try to follow this rule - USE ACAMA_GWD_rando_m, only: ACAMA_GWD_rando, ACAMA_GWD_rando_first + USE acama_gwd_rando_m, only: ACAMA_GWD_rando, ACAMA_GWD_rando_first USE add_wake_tend_mod, ONLY: add_wake_tend USE aero_mod @@ -160,5 +160,5 @@ #ifndef CPP_XIOS - USE paramLMDZ_phy_mod + USE paramlmdz_phy_mod #endif ! Index: LMDZ6/trunk/libf/phylmd/pppmer.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/pppmer.f90 (revision 6047) +++ (revision ) @@ -1,172 +1,0 @@ -!$gpum horizontal kproma kprof -MODULE pppmer_mod - PRIVATE - - PUBLIC pppmer - - CONTAINS - -SUBROUTINE PPPMER(KPROMA,KSTART,KPROF,PRPRESS,POROG,PTSTAR,PT0,PMSLPPP) - -!**** *PPPMER* - POST-PROCESS MSL PRESSURE. - -! PURPOSE. -! -------- -! COMPUTES MSL PRESSURE. - -!** INTERFACE. -! ---------- - -! *CALL* *PPPMER(KPROMA,KSTART,KPROF,PRPRESS,POROG,PTSTAR,PT0, -! S PMSLPPP) - -! EXPLICIT ARGUMENTS -! -------------------- - - -! KPROMA - HORIZONTAL DIMENSION. (INPUT) -! KSTART - START OF WORK. (INPUT) -! KPROF - DEPTH OF WORK. (INPUT) -! PRPRESS(KPROMA) - SURFACE PRESSURE (INPUT) -! POROG(KPROMA) - MODEL OROGRAPHY. (INPUT) -! PTSTAR(KPROMA) - SURFACE TEMPERATURE (INPUT) -! PT0(KPROMA) - STANDARD SURFACE TEMPERATURE (INPUT) -! PMSLPPP(KPROMA) - POST-PROCESSED MSL PRESSURE (OUTPUT) -! IMPLICIT ARGUMENTS : CONSTANTS FROM YOMCST,YOMGEM,YOMSTA. -! -------------------- - -! METHOD. -! ------- -! SEE DOCUMENTATION - -! EXTERNALS. NONE -! ---------- - -! REFERENCE. -! ---------- -! ECMWF Research Department documentation of the IFS - -! AUTHOR. -! ------- -! MATS HAMRUD AND PHILIPPE COURTIER *ECMWF* - -! MODIFICATIONS. -! -------------- -! ORIGINAL : 89-01-26 - -! E. A-son, J-F Geleyn 920409 Mod. T*, T0 and alpha below surface. -! M.Hamrud 01-Oct-2003 CY28 Cleaning - -! ------------------------------------------------------------------ - -! USE PARKIND1 -! ,ONLY : JPIM ,JPRB -! USE YOMHOOK -! ,ONLY : LHOOK, DR_HOOK - -!USE YOMCST, ONLY : RG, RD -! , ONLY : RG - -! ,RD -! USE YOMSTA -! , ONLY : RDTDZ1 - - USE yomcst_mod_h -IMPLICIT NONE - - -!IM INTEGER(KIND=JPIM),INTENT(IN) :: KPROMA -!IM INTEGER(KIND=JPIM),INTENT(IN) :: KSTART -!IM INTEGER(KIND=JPIM),INTENT(IN) :: KPROF - INTEGER,INTENT(IN) :: KPROMA - INTEGER,INTENT(IN) :: KSTART - INTEGER,INTENT(IN) :: KPROF -!IM REAL(KIND=JPRB) ,INTENT(IN) :: PRPRESS(KPROMA) -!IM REAL(KIND=JPRB) ,INTENT(IN) :: POROG(KPROMA) -!IM REAL(KIND=JPRB) ,INTENT(IN) :: PTSTAR(KPROMA) -!IM REAL(KIND=JPRB) ,INTENT(IN) :: PT0(KPROMA) -!IM REAL(KIND=JPRB) ,INTENT(OUT) :: PMSLPPP(KPROMA) -!IM REAL(KIND=JPRB) :: ZTSTAR(KPROMA) -!IM REAL(KIND=JPRB) :: ZALPHA(KPROMA) - REAL,INTENT(IN) :: PRPRESS(KPROMA) - REAL,INTENT(IN) :: POROG(KPROMA) - REAL,INTENT(IN) :: PTSTAR(KPROMA) - REAL,INTENT(IN) :: PT0(KPROMA) - REAL,INTENT(OUT) :: PMSLPPP(KPROMA) - REAL :: ZTSTAR(KPROMA) - REAL :: ZALPHA(KPROMA) - -!IM INTEGER(KIND=JPIM) :: JL - INTEGER :: JL - -!IM REAL(KIND=JPRB) :: ZDTDZSG, ZOROG, ZT0, ZTX, ZTY, ZX, ZY, ZY2 -!IM REAL(KIND=JPRB) :: ZHOOK_HANDLE - REAL :: ZDTDZSG, ZOROG, ZT0, ZTX, ZTY, ZX, ZY, ZY2 - REAL :: ZHOOK_HANDLE -!IM beg -REAL, PARAMETER :: RDTDZ1=-0.0065 !or USE YOMSTA -!IM end - -! ------------------------------------------------------------------ - -!* 1. POST-PROCESS MSL PRESSURE. -! -------------------------- - -!* 1.1 COMPUTATION OF MODIFIED ALPHA AND TSTAR. - -!IM IF (LHOOK) CALL DR_HOOK('PPPMER',0,ZHOOK_HANDLE) -!IM ZTX=290.5_JPRB -!IM ZTY=255.0_JPRB - ZTX=290.5 - ZTY=255.0 - ZDTDZSG=-RDTDZ1/RG -! - DO JL=KSTART,KPROF - - IF(PTSTAR(JL) < ZTY) THEN -!IM ZTSTAR(JL)=0.5_JPRB*(ZTY+PTSTAR(JL)) - ZTSTAR(JL)=0.5*(ZTY+PTSTAR(JL)) - ELSEIF(PTSTAR(JL) < ZTX) THEN - ZTSTAR(JL)=PTSTAR(JL) - ELSE -!IM ZTSTAR(JL)=0.5_JPRB*(ZTX+PTSTAR(JL)) - ZTSTAR(JL)=0.5*(ZTX+PTSTAR(JL)) - ENDIF - - ZT0=ZTSTAR(JL)+ZDTDZSG*POROG(JL) - IF(ZTX > ZTSTAR(JL) .AND. ZT0 > ZTX) THEN - ZT0=ZTX - ELSEIF(ZTX <= ZTSTAR(JL) .AND. ZT0 > ZTSTAR(JL)) THEN - ZT0=ZTSTAR(JL) - ELSE - ZT0=PT0(JL) - ENDIF - -!IM ZOROG=SIGN(MAX(1.0_JPRB,ABS(POROG(JL))),POROG(JL)) - ZOROG=SIGN(MAX(1.0,ABS(POROG(JL))),POROG(JL)) - ZALPHA(JL)=RD*(ZT0-ZTSTAR(JL))/ZOROG - ENDDO - -!* 1.2 COMPUTATION OF MSL PRESSURE. - - DO JL=KSTART,KPROF -!IM IF (ABS(POROG(JL)) >= 0.001_JPRB) THEN - IF (ABS(POROG(JL)) >= 0.001) THEN - ZX=POROG(JL)/(RD*ZTSTAR(JL)) - ZY=ZALPHA(JL)*ZX - ZY2=ZY*ZY - -!IM PMSLPPP(JL)=PRPRESS(JL)*EXP(ZX*(1.0_JPRB-0.5_JPRB*ZY+1.0_JPRB/3._JPRB*ZY2)) - PMSLPPP(JL)=PRPRESS(JL)*EXP(ZX*(1.0-0.5*ZY+1.0/3.*ZY2)) - ELSE - PMSLPPP(JL)=PRPRESS(JL) - ENDIF - ENDDO - - -! ------------------------------------------------------------------ - -!IM IF (LHOOK) CALL DR_HOOK('PPPMER',1,ZHOOK_HANDLE) - END SUBROUTINE PPPMER - -END MODULE pppmer_mod Index: LMDZ6/trunk/libf/phylmd/pppmer_mod.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/pppmer_mod.f90 (revision 6048) +++ LMDZ6/trunk/libf/phylmd/pppmer_mod.f90 (revision 6048) @@ -0,0 +1,172 @@ +!$gpum horizontal kproma kprof +MODULE pppmer_mod + PRIVATE + + PUBLIC pppmer + + CONTAINS + +SUBROUTINE PPPMER(KPROMA,KSTART,KPROF,PRPRESS,POROG,PTSTAR,PT0,PMSLPPP) + +!**** *PPPMER* - POST-PROCESS MSL PRESSURE. + +! PURPOSE. +! -------- +! COMPUTES MSL PRESSURE. + +!** INTERFACE. +! ---------- + +! *CALL* *PPPMER(KPROMA,KSTART,KPROF,PRPRESS,POROG,PTSTAR,PT0, +! S PMSLPPP) + +! EXPLICIT ARGUMENTS +! -------------------- + + +! KPROMA - HORIZONTAL DIMENSION. (INPUT) +! KSTART - START OF WORK. (INPUT) +! KPROF - DEPTH OF WORK. (INPUT) +! PRPRESS(KPROMA) - SURFACE PRESSURE (INPUT) +! POROG(KPROMA) - MODEL OROGRAPHY. (INPUT) +! PTSTAR(KPROMA) - SURFACE TEMPERATURE (INPUT) +! PT0(KPROMA) - STANDARD SURFACE TEMPERATURE (INPUT) +! PMSLPPP(KPROMA) - POST-PROCESSED MSL PRESSURE (OUTPUT) +! IMPLICIT ARGUMENTS : CONSTANTS FROM YOMCST,YOMGEM,YOMSTA. +! -------------------- + +! METHOD. +! ------- +! SEE DOCUMENTATION + +! EXTERNALS. NONE +! ---------- + +! REFERENCE. +! ---------- +! ECMWF Research Department documentation of the IFS + +! AUTHOR. +! ------- +! MATS HAMRUD AND PHILIPPE COURTIER *ECMWF* + +! MODIFICATIONS. +! -------------- +! ORIGINAL : 89-01-26 + +! E. A-son, J-F Geleyn 920409 Mod. T*, T0 and alpha below surface. +! M.Hamrud 01-Oct-2003 CY28 Cleaning + +! ------------------------------------------------------------------ + +! USE PARKIND1 +! ,ONLY : JPIM ,JPRB +! USE YOMHOOK +! ,ONLY : LHOOK, DR_HOOK + +!USE YOMCST, ONLY : RG, RD +! , ONLY : RG + +! ,RD +! USE YOMSTA +! , ONLY : RDTDZ1 + + USE yomcst_mod_h +IMPLICIT NONE + + +!IM INTEGER(KIND=JPIM),INTENT(IN) :: KPROMA +!IM INTEGER(KIND=JPIM),INTENT(IN) :: KSTART +!IM INTEGER(KIND=JPIM),INTENT(IN) :: KPROF + INTEGER,INTENT(IN) :: KPROMA + INTEGER,INTENT(IN) :: KSTART + INTEGER,INTENT(IN) :: KPROF +!IM REAL(KIND=JPRB) ,INTENT(IN) :: PRPRESS(KPROMA) +!IM REAL(KIND=JPRB) ,INTENT(IN) :: POROG(KPROMA) +!IM REAL(KIND=JPRB) ,INTENT(IN) :: PTSTAR(KPROMA) +!IM REAL(KIND=JPRB) ,INTENT(IN) :: PT0(KPROMA) +!IM REAL(KIND=JPRB) ,INTENT(OUT) :: PMSLPPP(KPROMA) +!IM REAL(KIND=JPRB) :: ZTSTAR(KPROMA) +!IM REAL(KIND=JPRB) :: ZALPHA(KPROMA) + REAL,INTENT(IN) :: PRPRESS(KPROMA) + REAL,INTENT(IN) :: POROG(KPROMA) + REAL,INTENT(IN) :: PTSTAR(KPROMA) + REAL,INTENT(IN) :: PT0(KPROMA) + REAL,INTENT(OUT) :: PMSLPPP(KPROMA) + REAL :: ZTSTAR(KPROMA) + REAL :: ZALPHA(KPROMA) + +!IM INTEGER(KIND=JPIM) :: JL + INTEGER :: JL + +!IM REAL(KIND=JPRB) :: ZDTDZSG, ZOROG, ZT0, ZTX, ZTY, ZX, ZY, ZY2 +!IM REAL(KIND=JPRB) :: ZHOOK_HANDLE + REAL :: ZDTDZSG, ZOROG, ZT0, ZTX, ZTY, ZX, ZY, ZY2 + REAL :: ZHOOK_HANDLE +!IM beg +REAL, PARAMETER :: RDTDZ1=-0.0065 !or USE YOMSTA +!IM end + +! ------------------------------------------------------------------ + +!* 1. POST-PROCESS MSL PRESSURE. +! -------------------------- + +!* 1.1 COMPUTATION OF MODIFIED ALPHA AND TSTAR. + +!IM IF (LHOOK) CALL DR_HOOK('PPPMER',0,ZHOOK_HANDLE) +!IM ZTX=290.5_JPRB +!IM ZTY=255.0_JPRB + ZTX=290.5 + ZTY=255.0 + ZDTDZSG=-RDTDZ1/RG +! + DO JL=KSTART,KPROF + + IF(PTSTAR(JL) < ZTY) THEN +!IM ZTSTAR(JL)=0.5_JPRB*(ZTY+PTSTAR(JL)) + ZTSTAR(JL)=0.5*(ZTY+PTSTAR(JL)) + ELSEIF(PTSTAR(JL) < ZTX) THEN + ZTSTAR(JL)=PTSTAR(JL) + ELSE +!IM ZTSTAR(JL)=0.5_JPRB*(ZTX+PTSTAR(JL)) + ZTSTAR(JL)=0.5*(ZTX+PTSTAR(JL)) + ENDIF + + ZT0=ZTSTAR(JL)+ZDTDZSG*POROG(JL) + IF(ZTX > ZTSTAR(JL) .AND. ZT0 > ZTX) THEN + ZT0=ZTX + ELSEIF(ZTX <= ZTSTAR(JL) .AND. ZT0 > ZTSTAR(JL)) THEN + ZT0=ZTSTAR(JL) + ELSE + ZT0=PT0(JL) + ENDIF + +!IM ZOROG=SIGN(MAX(1.0_JPRB,ABS(POROG(JL))),POROG(JL)) + ZOROG=SIGN(MAX(1.0,ABS(POROG(JL))),POROG(JL)) + ZALPHA(JL)=RD*(ZT0-ZTSTAR(JL))/ZOROG + ENDDO + +!* 1.2 COMPUTATION OF MSL PRESSURE. + + DO JL=KSTART,KPROF +!IM IF (ABS(POROG(JL)) >= 0.001_JPRB) THEN + IF (ABS(POROG(JL)) >= 0.001) THEN + ZX=POROG(JL)/(RD*ZTSTAR(JL)) + ZY=ZALPHA(JL)*ZX + ZY2=ZY*ZY + +!IM PMSLPPP(JL)=PRPRESS(JL)*EXP(ZX*(1.0_JPRB-0.5_JPRB*ZY+1.0_JPRB/3._JPRB*ZY2)) + PMSLPPP(JL)=PRPRESS(JL)*EXP(ZX*(1.0-0.5*ZY+1.0/3.*ZY2)) + ELSE + PMSLPPP(JL)=PRPRESS(JL) + ENDIF + ENDDO + + +! ------------------------------------------------------------------ + +!IM IF (LHOOK) CALL DR_HOOK('PPPMER',1,ZHOOK_HANDLE) + END SUBROUTINE PPPMER + +END MODULE pppmer_mod Index: LMDZ6/trunk/libf/phylmd/qsat_seawater.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/qsat_seawater.f90 (revision 6047) +++ (revision ) @@ -1,128 +1,0 @@ -MODULE qsat_seawater_mod - -CONTAINS - -!------------------------------------------------------------------------------- -! -! ###################################### - FUNCTION QSAT_SEAWATER(knon, klon, PT,PP) -!$gpum horizontal knon - -! ###################################### -! -!!**** *QSATW * - function to compute saturation vapor humidity from -!! temperature -!! -!! PURPOSE -!! ------- -! The purpose of this function is to compute the saturation vapor -! pressure from temperature over saline seawater -! -! -!!** METHOD -!! ------ -!! Given temperature T (PT), the saturation vapor pressure es(T) -!! (FOES(PT)) is computed by integration of the Clapeyron equation -!! from the triple point temperature Tt (XTT) and the saturation vapor -!! pressure of the triple point es(Tt) (XESTT), i.e -!! The reduction due to salinity is compute with the factor 0.98 (reduction of 2%) -!! -!! es(T)= 0.98*EXP( alphaw - betaw /T - gammaw Log(T) ) -!! -!! with : -!! alphaw (XALPW) = LOG(es(Tt))+ betaw/Tt + gammaw Log(Tt) -!! betaw (XBETAW) = Lv(Tt)/Rv + gammaw Tt -!! gammaw (XGAMW) = (Cl -Cpv) /Rv -!! -!! Then, the specific humidity at saturation is deduced. -!! -!! -!! EXTERNAL -!! -------- -!! NONE -!! -!! IMPLICIT ARGUMENTS -!! ------------------ -!! Module MODD_CST : comtains physical constants -!! XALPW : Constant for saturation vapor pressure function -!! XBETAW : Constant for saturation vapor pressure function -!! XGAMW : Constant for saturation vapor pressure function -!! -!! REFERENCE -!! --------- -!! Book2 of documentation of Meso-NH -!! Zeng, X., Zhao, M., and Dickinson, R. E., 1998 : Intercomparaison of bulk -!! aerodynamic algorithm for the computation of sea surface fluxes using -!! TOGA COARE and TAO data. Journal of Climate, vol 11, nb 10, pp 2628--2644 -!! -!! -!! AUTHOR -!! ------ -!! C. Lebeaupin * Meteo France * -!! -!! MODIFICATIONS -!! ------------- -!! Original 6/04/2005 -!------------------------------------------------------------------------------- -! -!* 0. DECLARATIONS -! ------------ -! -USE MODD_CSTS -USE indice_sol_mod -! -IMPLICIT NONE -! -!* 0.1 Declarations of arguments and results -! -! -INTEGER, INTENT(IN) :: knon ! horizontal indice compressed -INTEGER, INTENT(IN) :: klon ! horizontal indice (fake can be 1) - -REAL, DIMENSION(klon), INTENT(IN) :: PT ! Temperature - ! (Kelvin) -REAL, DIMENSION(klon), INTENT(IN) :: PP ! Pressure - ! (Pa) -REAL, DIMENSION(SIZE(PT)) :: PQSAT ! saturation vapor - ! specific humidity - ! with respect to - ! water (kg/kg) - -! -!* 0.2 Declarations of local variables -! -REAL, DIMENSION(SIZE(PT)) :: ZFOES ! saturation vapor - ! pressure - ! (Pascal) -REAL :: QSAT_SEAWATER -! -REAL, DIMENSION(SIZE(PT)) :: ZWORK1 -REAL :: ZWORK2 -!REAL(KIND=JPRB) :: ZHOOK_HANDLE -!------------------------------------------------------------------------------- -! -!IF (LHOOK) CALL DR_HOOK('MODE_THERMOS:QSATSEAW_1D',0,ZHOOK_HANDLE) -! -!ZFOES = 1 !PSAT(PT(:)) -!ZFOES = 0.98*ZFOES -!ZFOES(:) = ZFOES(:)*1013.25E+02 !convert from atm to Pa -ZFOES = 0.98*EXP( XALPW - XBETAW/PT - XGAMW*LOG(PT) ) -! vapor pressure reduction of 2% over saline seawater could have a significant -! impact on the computation of surface latent heat flux under strong wind -! conditions (Zeng et al, 1998). -! -ZWORK1 = ZFOES/PP -ZWORK2 = XRD/XRV -! -!* 2. COMPUTE SATURATION HUMIDITY -! --------------------------- -! -PQSAT = ZWORK2*ZWORK1 / (1.+(ZWORK2-1.)*ZWORK1) -! -!IF (LHOOK) CALL DR_HOOK('MODE_THERMOS:QSATSEAW_1D',1,ZHOOK_HANDLE) -!------------------------------------------------------------------------------- -! -END FUNCTION QSAT_SEAWATER -! -!------------------------------------------------------------------------------- -END MODULE qsat_seawater_mod Index: LMDZ6/trunk/libf/phylmd/qsat_seawater2.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/qsat_seawater2.f90 (revision 6047) +++ (revision ) @@ -1,112 +1,0 @@ -MODULE qsat_seawater2_mod - - -CONTAINS - -REAL FUNCTION QSAT_SEAWATER2(knon, klon, PT,PP,PSSS) -!$gpum horizontal knon - -! ###################################### -! -!!**** *QSATW * - function to compute saturation vapor humidity from -!! temperature -!! -!! PURPOSE -!! ------- -! The purpose of this function is to compute the saturation vapor -! pressure from temperature over saline seawater -! -! -!!** METHOD -!! ------ -!! Given temperature T (PT) and salinity S (PSSS), the saturation vapor -!! pressure es(T,S) (FOES(PT,PSSS)) is computed following Weiss and Price -!! (1980). -!! -!! Then, the specific humidity at saturation is deduced. -!! -!! -!! EXTERNAL -!! -------- -!! NONE -!! -!! IMPLICIT ARGUMENTS -!! ------------------ -!! Module MODD_CST : contains physical constants -!! -!! REFERENCE -!! --------- -!! Weiss, R.F., and Price, B.A., 1980 : Nitrous oxide solubility in water -!! and seawater. Marine Chemistry, nb 8, pp 347-359. -!! -!! -!! AUTHOR -!! ------ -!! S. Belamari * Meteo France * -!! -!! MODIFICATIONS -!! ------------- -!! Original 19/03/2014 -!------------------------------------------------------------------------------- -! -!* 0. DECLARATIONS -! ------------ -! -USE MODD_CSTS, ONLY : XRD, XRV -USE indice_sol_mod -! -IMPLICIT NONE -! -!* 0.1 Declarations of arguments and results -! -! -INTEGER, INTENT(IN) :: knon ! horizontal indice compressed -INTEGER, INTENT(IN) :: klon ! horizontal indice (fake can be 1) - -REAL, DIMENSION(klon), INTENT(IN) :: PT ! Temperature - ! (Kelvin) -REAL, DIMENSION(klon), INTENT(IN) :: PP ! Pressure - ! (Pascal) -REAL, DIMENSION(klon), INTENT(IN) :: PSSS ! Salinity - ! (g/kg) -REAL, DIMENSION(SIZE(PT)) :: PQSATA ! saturation vapor - ! specific humidity - ! with respect to - ! water (kg/kg) -! -!* 0.2 Declarations of local variables -! -REAL, DIMENSION(SIZE(PT)) :: ZFOES ! saturation vapor - ! pressure - ! (Pascal) -! -REAL, DIMENSION(SIZE(PT)) :: ZWORK1 -REAL :: ZWORK2 -!REAL(KIND=JPRB) :: ZHOOK_HANDLE -!------------------------------------------------------------------------------- -! -!IF (LHOOK) CALL DR_HOOK('MODE_THERMOS:QSATSEAW2_1D',0,ZHOOK_HANDLE) -! -!* 1. COMPUTE SATURATION VAPOR PRESSURE -! --------------------------------- -! -ZFOES(:) = EXP( 24.4543 -67.4509*(100.0/PT(:)) -4.8489*LOG(PT(:)/100.0) & - -5.44E-04*(PSSS(:)/1.00472) ) !see Sharqawy et al (2010) Eq32 p368 -ZFOES(:) = ZFOES(:)*1013.25E+02 !convert from atm to Pa -! -ZWORK1(:) = ZFOES(:)/PP(:) -ZWORK2 = XRD/XRV -! -!* 2. COMPUTE SATURATION SPECIFIC HUMIDITY -! ------------------------------------ -! -PQSATA(:) = ZWORK2*ZWORK1(:) / (1.0+(ZWORK2-1.0)*ZWORK1(:)) -! -!IF (LHOOK) CALL DR_HOOK('MODE_THERMOS:QSATSEAW2_1D',1,ZHOOK_HANDLE) -!------------------------------------------------------------------------------- -! -END FUNCTION QSAT_SEAWATER2 -! -!------------------------------------------------------------------------------- - -END MODULE qsat_seawater2_mod Index: LMDZ6/trunk/libf/phylmd/qsat_seawater2_mod.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/qsat_seawater2_mod.f90 (revision 6048) +++ LMDZ6/trunk/libf/phylmd/qsat_seawater2_mod.f90 (revision 6048) @@ -0,0 +1,112 @@ +MODULE qsat_seawater2_mod + + +CONTAINS + +REAL FUNCTION QSAT_SEAWATER2(knon, klon, PT,PP,PSSS) +!$gpum horizontal knon + +! ###################################### +! +!!**** *QSATW * - function to compute saturation vapor humidity from +!! temperature +!! +!! PURPOSE +!! ------- +! The purpose of this function is to compute the saturation vapor +! pressure from temperature over saline seawater +! +! +!!** METHOD +!! ------ +!! Given temperature T (PT) and salinity S (PSSS), the saturation vapor +!! pressure es(T,S) (FOES(PT,PSSS)) is computed following Weiss and Price +!! (1980). +!! +!! Then, the specific humidity at saturation is deduced. +!! +!! +!! EXTERNAL +!! -------- +!! NONE +!! +!! IMPLICIT ARGUMENTS +!! ------------------ +!! Module MODD_CST : contains physical constants +!! +!! REFERENCE +!! --------- +!! Weiss, R.F., and Price, B.A., 1980 : Nitrous oxide solubility in water +!! and seawater. Marine Chemistry, nb 8, pp 347-359. +!! +!! +!! AUTHOR +!! ------ +!! S. Belamari * Meteo France * +!! +!! MODIFICATIONS +!! ------------- +!! Original 19/03/2014 +!------------------------------------------------------------------------------- +! +!* 0. DECLARATIONS +! ------------ +! +USE MODD_CSTS, ONLY : XRD, XRV +USE indice_sol_mod +! +IMPLICIT NONE +! +!* 0.1 Declarations of arguments and results +! +! +INTEGER, INTENT(IN) :: knon ! horizontal indice compressed +INTEGER, INTENT(IN) :: klon ! horizontal indice (fake can be 1) + +REAL, DIMENSION(klon), INTENT(IN) :: PT ! Temperature + ! (Kelvin) +REAL, DIMENSION(klon), INTENT(IN) :: PP ! Pressure + ! (Pascal) +REAL, DIMENSION(klon), INTENT(IN) :: PSSS ! Salinity + ! (g/kg) +REAL, DIMENSION(SIZE(PT)) :: PQSATA ! saturation vapor + ! specific humidity + ! with respect to + ! water (kg/kg) +! +!* 0.2 Declarations of local variables +! +REAL, DIMENSION(SIZE(PT)) :: ZFOES ! saturation vapor + ! pressure + ! (Pascal) +! +REAL, DIMENSION(SIZE(PT)) :: ZWORK1 +REAL :: ZWORK2 +!REAL(KIND=JPRB) :: ZHOOK_HANDLE +!------------------------------------------------------------------------------- +! +!IF (LHOOK) CALL DR_HOOK('MODE_THERMOS:QSATSEAW2_1D',0,ZHOOK_HANDLE) +! +!* 1. COMPUTE SATURATION VAPOR PRESSURE +! --------------------------------- +! +ZFOES(:) = EXP( 24.4543 -67.4509*(100.0/PT(:)) -4.8489*LOG(PT(:)/100.0) & + -5.44E-04*(PSSS(:)/1.00472) ) !see Sharqawy et al (2010) Eq32 p368 +ZFOES(:) = ZFOES(:)*1013.25E+02 !convert from atm to Pa +! +ZWORK1(:) = ZFOES(:)/PP(:) +ZWORK2 = XRD/XRV +! +!* 2. COMPUTE SATURATION SPECIFIC HUMIDITY +! ------------------------------------ +! +PQSATA(:) = ZWORK2*ZWORK1(:) / (1.0+(ZWORK2-1.0)*ZWORK1(:)) +! +!IF (LHOOK) CALL DR_HOOK('MODE_THERMOS:QSATSEAW2_1D',1,ZHOOK_HANDLE) +!------------------------------------------------------------------------------- +! +END FUNCTION QSAT_SEAWATER2 +! +!------------------------------------------------------------------------------- + +END MODULE qsat_seawater2_mod Index: LMDZ6/trunk/libf/phylmd/qsat_seawater_mod.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/qsat_seawater_mod.f90 (revision 6048) +++ LMDZ6/trunk/libf/phylmd/qsat_seawater_mod.f90 (revision 6048) @@ -0,0 +1,128 @@ +MODULE qsat_seawater_mod + +CONTAINS + +!------------------------------------------------------------------------------- +! +! ###################################### + FUNCTION QSAT_SEAWATER(knon, klon, PT,PP) +!$gpum horizontal knon + +! ###################################### +! +!!**** *QSATW * - function to compute saturation vapor humidity from +!! temperature +!! +!! PURPOSE +!! ------- +! The purpose of this function is to compute the saturation vapor +! pressure from temperature over saline seawater +! +! +!!** METHOD +!! ------ +!! Given temperature T (PT), the saturation vapor pressure es(T) +!! (FOES(PT)) is computed by integration of the Clapeyron equation +!! from the triple point temperature Tt (XTT) and the saturation vapor +!! pressure of the triple point es(Tt) (XESTT), i.e +!! The reduction due to salinity is compute with the factor 0.98 (reduction of 2%) +!! +!! es(T)= 0.98*EXP( alphaw - betaw /T - gammaw Log(T) ) +!! +!! with : +!! alphaw (XALPW) = LOG(es(Tt))+ betaw/Tt + gammaw Log(Tt) +!! betaw (XBETAW) = Lv(Tt)/Rv + gammaw Tt +!! gammaw (XGAMW) = (Cl -Cpv) /Rv +!! +!! Then, the specific humidity at saturation is deduced. +!! +!! +!! EXTERNAL +!! -------- +!! NONE +!! +!! IMPLICIT ARGUMENTS +!! ------------------ +!! Module MODD_CST : comtains physical constants +!! XALPW : Constant for saturation vapor pressure function +!! XBETAW : Constant for saturation vapor pressure function +!! XGAMW : Constant for saturation vapor pressure function +!! +!! REFERENCE +!! --------- +!! Book2 of documentation of Meso-NH +!! Zeng, X., Zhao, M., and Dickinson, R. E., 1998 : Intercomparaison of bulk +!! aerodynamic algorithm for the computation of sea surface fluxes using +!! TOGA COARE and TAO data. Journal of Climate, vol 11, nb 10, pp 2628--2644 +!! +!! +!! AUTHOR +!! ------ +!! C. Lebeaupin * Meteo France * +!! +!! MODIFICATIONS +!! ------------- +!! Original 6/04/2005 +!------------------------------------------------------------------------------- +! +!* 0. DECLARATIONS +! ------------ +! +USE MODD_CSTS +USE indice_sol_mod +! +IMPLICIT NONE +! +!* 0.1 Declarations of arguments and results +! +! +INTEGER, INTENT(IN) :: knon ! horizontal indice compressed +INTEGER, INTENT(IN) :: klon ! horizontal indice (fake can be 1) + +REAL, DIMENSION(klon), INTENT(IN) :: PT ! Temperature + ! (Kelvin) +REAL, DIMENSION(klon), INTENT(IN) :: PP ! Pressure + ! (Pa) +REAL, DIMENSION(SIZE(PT)) :: PQSAT ! saturation vapor + ! specific humidity + ! with respect to + ! water (kg/kg) + +! +!* 0.2 Declarations of local variables +! +REAL, DIMENSION(SIZE(PT)) :: ZFOES ! saturation vapor + ! pressure + ! (Pascal) +REAL :: QSAT_SEAWATER +! +REAL, DIMENSION(SIZE(PT)) :: ZWORK1 +REAL :: ZWORK2 +!REAL(KIND=JPRB) :: ZHOOK_HANDLE +!------------------------------------------------------------------------------- +! +!IF (LHOOK) CALL DR_HOOK('MODE_THERMOS:QSATSEAW_1D',0,ZHOOK_HANDLE) +! +!ZFOES = 1 !PSAT(PT(:)) +!ZFOES = 0.98*ZFOES +!ZFOES(:) = ZFOES(:)*1013.25E+02 !convert from atm to Pa +ZFOES = 0.98*EXP( XALPW - XBETAW/PT - XGAMW*LOG(PT) ) +! vapor pressure reduction of 2% over saline seawater could have a significant +! impact on the computation of surface latent heat flux under strong wind +! conditions (Zeng et al, 1998). +! +ZWORK1 = ZFOES/PP +ZWORK2 = XRD/XRV +! +!* 2. COMPUTE SATURATION HUMIDITY +! --------------------------- +! +PQSAT = ZWORK2*ZWORK1 / (1.+(ZWORK2-1.)*ZWORK1) +! +!IF (LHOOK) CALL DR_HOOK('MODE_THERMOS:QSATSEAW_1D',1,ZHOOK_HANDLE) +!------------------------------------------------------------------------------- +! +END FUNCTION QSAT_SEAWATER +! +!------------------------------------------------------------------------------- +END MODULE qsat_seawater_mod Index: LMDZ6/trunk/libf/phylmd/simu_airs.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/simu_airs.f90 (revision 6047) +++ (revision ) @@ -1,1307 +1,0 @@ - - module m_simu_airs - - USE print_control_mod, ONLY: prt_level,lunout - - implicit none - - REAL, PARAMETER :: tau_thresh = 0.05 ! seuil nuages detectables - REAL, PARAMETER :: p_thresh = 445. ! seuil nuages hauts - REAL, PARAMETER :: em_min = 0.2 ! seuils nuages semi-transp - REAL, PARAMETER :: em_max = 0.85 - REAL, PARAMETER :: undef = 999. - - contains - - REAL function search_tropopause(P,T,alt,N) result(P_tropo) -! this function searches for the tropopause pressure in [hPa]. -! The search is based on ideology described in -! Reichler et al., Determining the tropopause height from gridded data, -! GRL, 30(20) 2042, doi:10.1029/2003GL018240, 2003 - - INTEGER N,i,i_lev,first_point,exit_flag,i_dir - REAL P(N),T(N),alt(N),slope(N) - REAL P_min, P_max, slope_limit,slope_2km, & - & delta_alt_limit,tmp,delta_alt - PARAMETER(P_min=75.0, P_max=470.0) ! hPa - PARAMETER(slope_limit=0.002) ! 2 K/km converted to K/m - PARAMETER(delta_alt_limit=2000.0) ! 2000 meters - - do i=1,N-1 - slope(i)=-(T(i+1)-T(i))/(alt(i+1)-alt(i)) - end do - slope(N)=slope(N-1) - - if (P(1).gt.P(N)) then - i_dir= 1 - i=1 - else - i_dir=-1 - i=N - end if - - first_point=0 - exit_flag=0 - do while(exit_flag.eq.0) - if (P(i).ge.P_min.and.P(i).le.P_max) then - if (first_point.gt.0) then - delta_alt=alt(i)-alt(first_point) - if (delta_alt.ge.delta_alt_limit) then - slope_2km=(T(first_point)-T(i))/delta_alt - if (slope_2km.lt.slope_limit) then - exit_flag=1 - else - first_point=0 - end if - end if - end if - if (first_point.eq.0.and.slope(i).lt.slope_limit) first_point=i - end if - i=i+i_dir - if (i.le.1.or.i.ge.N) exit_flag=1 - end do - - if (first_point.le.0) P_tropo=65.4321 - if (first_point.eq.1) P_tropo=64.5432 - if (first_point.gt.1) then - tmp=(slope_limit-slope(first_point))/(slope(first_point+1)- & - & slope(first_point))*(P(first_point+1)-P(first_point)) - P_tropo=P(first_point)+tmp - ! print*, 'P_tropo= ', tmp, P(first_point), P_tropo - end if - -! Ajout Marine - if (P_tropo .lt. 60. .or. P_tropo .gt. 470.) then - P_tropo = 999. - endif - - return - end function search_tropopause - - - - subroutine cloud_structure(len_cs, rneb_cs, temp_cs, & - & emis_cs, iwco_cs, & - & pres_cs, dz_cs, rhodz_cs, rad_cs, & - & cc_tot_cs, cc_hc_cs, cc_hist_cs, & - & cc_Cb_cs, cc_ThCi_cs, cc_Anv_cs, & - & pcld_hc_cs, tcld_hc_cs, & - & em_hc_cs, iwp_hc_cs, deltaz_hc_cs, & - & pcld_Cb_cs, tcld_Cb_cs, em_Cb_cs, & - & pcld_ThCi_cs, tcld_ThCi_cs, em_ThCi_cs, & - & pcld_Anv_cs, tcld_Anv_cs, em_Anv_cs, & - & em_hist_cs, iwp_hist_cs, deltaz_hist_cs, rad_hist_cs) - - - - INTEGER :: i, n, nss - - INTEGER, intent(in) :: len_cs - REAL, DIMENSION(:), intent(in) :: rneb_cs, temp_cs - REAL, DIMENSION(:), intent(in) :: emis_cs, iwco_cs, rad_cs - REAL, DIMENSION(:), intent(in) :: pres_cs, dz_cs, rhodz_cs - - REAL, intent(out) :: cc_tot_cs, cc_hc_cs, cc_hist_cs, & - & cc_Cb_cs, cc_ThCi_cs, cc_Anv_cs, & - & pcld_hc_cs, tcld_hc_cs, em_hc_cs, iwp_hc_cs, & - & pcld_Cb_cs, tcld_Cb_cs, em_Cb_cs, & - & pcld_ThCi_cs, tcld_ThCi_cs, em_ThCi_cs, & - & pcld_Anv_cs, tcld_Anv_cs, em_Anv_cs, & - & em_hist_cs, iwp_hist_cs, & - & deltaz_hc_cs, deltaz_hist_cs, rad_hist_cs - - REAL, DIMENSION(len_cs) :: rneb_ord - REAL :: rneb_min - - REAL, DIMENSION(:), allocatable :: s, s_hc, s_hist, rneb_max - REAL, DIMENSION(:), allocatable :: sCb, sThCi, sAnv - REAL, DIMENSION(:), allocatable :: iwp_ss, pcld_ss, tcld_ss,& - & emis_ss - REAL, DIMENSION(:), allocatable :: deltaz_ss, rad_ss - - CHARACTER (len = 50) :: modname = 'simu_airs.cloud_structure' - CHARACTER (len = 160) :: abort_message - - - write(lunout,*) 'dans cloud_structure' - - call ordonne(len_cs, rneb_cs, rneb_ord) - - -! Definition des sous_sections - - rneb_min = rneb_ord(1) - nss = 1 - - do i = 2, size(rneb_cs) - if (rneb_ord(i) .gt. rneb_min) then - nss = nss+1 - rneb_min = rneb_ord(i) - endif - enddo - - allocate (s(nss)) - allocate (s_hc(nss)) - allocate (s_hist(nss)) - allocate (rneb_max(nss)) - allocate (emis_ss(nss)) - allocate (pcld_ss(nss)) - allocate (tcld_ss(nss)) - allocate (iwp_ss(nss)) - allocate (deltaz_ss(nss)) - allocate (rad_ss(nss)) - allocate (sCb(nss)) - allocate (sThCi(nss)) - allocate (sAnv(nss)) - - rneb_min = rneb_ord(1) - n = 1 - s(1) = rneb_ord(1) - s_hc(1) = rneb_ord(1) - s_hist(1) = rneb_ord(1) - sCb(1) = rneb_ord(1) - sThCi(1) = rneb_ord(1) - sAnv(1) = rneb_ord(1) - - rneb_max(1) = rneb_ord(1) - - do i = 2, size(rneb_cs) - if (rneb_ord(i) .gt. rneb_min) then - n = n+1 - s(n) = rneb_ord(i)-rneb_min - s_hc(n) = rneb_ord(i)-rneb_min - s_hist(n) = rneb_ord(i)-rneb_min - sCb(n) = rneb_ord(i)-rneb_min - sThCi(n) = rneb_ord(i)-rneb_min - sAnv(n) = rneb_ord(i)-rneb_min - - rneb_max(n) = rneb_ord(i) - rneb_min = rneb_ord(i) - endif - enddo - -! Appel de sous_section - - do i = 1, nss - call sous_section(len_cs, rneb_cs, temp_cs, & - & emis_cs, iwco_cs, & - & pres_cs, dz_cs, rhodz_cs, rad_cs, rneb_ord, & - & rneb_max(i),s(i),s_hc(i),s_hist(i), & - & sCb(i), sThCi(i), sAnv(i), & - & emis_ss(i), & - & pcld_ss(i), tcld_ss(i), iwp_ss(i), deltaz_ss(i), rad_ss(i)) - enddo - -! Caracteristiques de la structure nuageuse - - cc_tot_cs = 0. - cc_hc_cs = 0. - cc_hist_cs = 0. - - cc_Cb_cs = 0. - cc_ThCi_cs = 0. - cc_Anv_cs = 0. - - em_hc_cs = 0. - iwp_hc_cs = 0. - deltaz_hc_cs = 0. - - em_hist_cs = 0. - iwp_hist_cs = 0. - deltaz_hist_cs = 0. - rad_hist_cs = 0. - - pcld_hc_cs = 0. - tcld_hc_cs = 0. - - pcld_Cb_cs = 0. - tcld_Cb_cs = 0. - em_Cb_cs = 0. - - pcld_ThCi_cs = 0. - tcld_ThCi_cs = 0. - em_ThCi_cs = 0. - - pcld_Anv_cs = 0. - tcld_Anv_cs = 0. - em_Anv_cs = 0. - - do i = 1, nss - - cc_tot_cs = cc_tot_cs + s(i) - cc_hc_cs = cc_hc_cs + s_hc(i) - cc_hist_cs = cc_hist_cs + s_hist(i) - - cc_Cb_cs = cc_Cb_cs + sCb(i) - cc_ThCi_cs = cc_ThCi_cs + sThCi(i) - cc_Anv_cs = cc_Anv_cs + sAnv(i) - - iwp_hc_cs = iwp_hc_cs + s_hc(i)*iwp_ss(i) - em_hc_cs = em_hc_cs + s_hc(i)*emis_ss(i) - deltaz_hc_cs = deltaz_hc_cs + s_hc(i)*deltaz_ss(i) - - iwp_hist_cs = iwp_hist_cs + s_hist(i)*iwp_ss(i) - em_hist_cs = em_hist_cs + s_hist(i)*emis_ss(i) - deltaz_hist_cs = deltaz_hist_cs + s_hist(i)*deltaz_ss(i) - rad_hist_cs = rad_hist_cs + s_hist(i)*rad_ss(i) - - pcld_hc_cs = pcld_hc_cs + s_hc(i)*pcld_ss(i) - tcld_hc_cs = tcld_hc_cs + s_hc(i)*tcld_ss(i) - - pcld_Cb_cs = pcld_Cb_cs + sCb(i)*pcld_ss(i) - tcld_Cb_cs = tcld_Cb_cs + sCb(i)*tcld_ss(i) - em_Cb_cs = em_Cb_cs + sCb(i)*emis_ss(i) - - pcld_ThCi_cs = pcld_ThCi_cs + sThCi(i)*pcld_ss(i) - tcld_ThCi_cs = tcld_ThCi_cs + sThCi(i)*tcld_ss(i) - em_ThCi_cs = em_ThCi_cs + sThCi(i)*emis_ss(i) - - pcld_Anv_cs = pcld_Anv_cs + sAnv(i)*pcld_ss(i) - tcld_Anv_cs = tcld_Anv_cs + sAnv(i)*tcld_ss(i) - em_Anv_cs = em_Anv_cs + sAnv(i)*emis_ss(i) - - enddo - - deallocate(s) - deallocate (s_hc) - deallocate (s_hist) - deallocate (rneb_max) - deallocate (emis_ss) - deallocate (pcld_ss) - deallocate (tcld_ss) - deallocate (iwp_ss) - deallocate (deltaz_ss) - deallocate (rad_ss) - deallocate (sCb) - deallocate (sThCi) - deallocate (sAnv) - - call normal_undef(pcld_hc_cs,cc_hc_cs) - call normal_undef(tcld_hc_cs,cc_hc_cs) - call normal_undef(iwp_hc_cs,cc_hc_cs) - call normal_undef(em_hc_cs,cc_hc_cs) - call normal_undef(deltaz_hc_cs,cc_hc_cs) - - call normal_undef(iwp_hist_cs,cc_hist_cs) - call normal_undef(em_hist_cs,cc_hist_cs) - call normal_undef(deltaz_hist_cs,cc_hist_cs) - call normal_undef(rad_hist_cs,cc_hist_cs) - - call normal_undef(pcld_Cb_cs,cc_Cb_cs) - call normal_undef(tcld_Cb_cs,cc_Cb_cs) - call normal_undef(em_Cb_cs,cc_Cb_cs) - - call normal_undef(pcld_ThCi_cs,cc_ThCi_cs) - call normal_undef(tcld_ThCi_cs,cc_ThCi_cs) - call normal_undef(em_ThCi_cs,cc_ThCi_cs) - - call normal_undef(pcld_Anv_cs,cc_Anv_cs) - call normal_undef(tcld_Anv_cs,cc_Anv_cs) - call normal_undef(em_Anv_cs,cc_Anv_cs) - - -! Tests - - if (cc_tot_cs .gt. maxval(rneb_cs) .and. & - & abs(cc_tot_cs-maxval(rneb_cs)) .gt. 1.e-4 ) then - WRITE(abort_message,*) 'cc_tot_cs > max rneb_cs', cc_tot_cs, maxval(rneb_cs) - CALL abort_physic(modname,abort_message,1) - endif - - if (iwp_hc_cs .lt. 0.) then - abort_message= 'cloud_structure: iwp_hc_cs < 0' - CALL abort_physic(modname,abort_message,1) - endif - - end subroutine cloud_structure - - - subroutine normal_undef(num, den) - - REAL, intent(in) :: den - REAL, intent(inout) :: num - - if (den .ne. 0) then - num = num/den - else - num = undef - endif - - end subroutine normal_undef - - - subroutine normal2_undef(res,num,den) - - REAL, intent(in) :: den - REAL, intent(in) :: num - REAL, intent(out) :: res - - if (den .ne. 0.) then - res = num/den - else - res = undef - endif - - end subroutine normal2_undef - - - subroutine sous_section(len_cs, rneb_cs, temp_cs, & - & emis_cs, iwco_cs, & - & pres_cs, dz_cs, rhodz_cs, rad_cs, rneb_ord, & - & rnebmax, stot, shc, shist, & - & sCb, sThCi, sAnv, & - & emis, pcld, tcld, iwp, deltaz, rad) - - INTEGER, intent(in) :: len_cs - REAL, DIMENSION(len_cs), intent(in) :: rneb_cs, temp_cs - REAL, DIMENSION(len_cs), intent(in) :: emis_cs, iwco_cs, & - & rneb_ord - REAL, DIMENSION(len_cs), intent(in) :: pres_cs, dz_cs, rad_cs - REAL, DIMENSION(len_cs), intent(in) :: rhodz_cs - REAL, DIMENSION(len_cs) :: tau_cs, w - REAL, intent(in) :: rnebmax - REAL, intent(inout) :: stot, shc, shist - REAL, intent(inout) :: sCb, sThCi, sAnv - REAL, intent(out) :: emis, pcld, tcld, iwp, deltaz, rad - - INTEGER :: i, ideb, ibeg, iend, nuage, visible - REAL :: som, som_tau, som_iwc, som_dz, som_rad, tau - - CHARACTER (len = 50) :: modname = 'simu_airs.sous_section' - CHARACTER (len = 160) :: abort_message - - -! Ponderation: 1 pour les nuages, 0 pour les trous - - do i = 1, len_cs - if (rneb_cs(i) .ge. rnebmax) then - w(i) = 1. - else - w(i) = 0. - endif - enddo - -! Calcul des epaisseurs optiques a partir des emissivites - - som = 0. - do i = 1, len_cs - if (emis_cs(i) .eq. 1.) then - tau_cs(i) = 10. - else - tau_cs(i) = -log(1.-emis_cs(i)) - endif - som = som+tau_cs(i) - enddo - - - ideb = 1 - nuage = 0 - visible = 0 - - -! Boucle sur les nuages - do while (ideb .ne. 0 .and. ideb .le. len_cs) - - -! Definition d'un nuage de la sous-section - - call topbot(ideb, w, ibeg, iend) - ideb = iend+1 - - if (ibeg .gt. 0) then - - nuage = nuage + 1 - -! On determine les caracteristiques du nuage -! (ep. optique, ice water path, pression, temperature) - - call caract(ibeg, iend, temp_cs, tau_cs, iwco_cs, & - & pres_cs, dz_cs, rhodz_cs, rad_cs, pcld, tcld, & - & som_tau, som_iwc, som_dz, som_rad) - -! On masque le nuage s'il n'est pas detectable - - call masque(ibeg, iend, som_tau, visible, w) - - endif - -! Fin boucle nuages - enddo - - -! Analyse du nuage detecte - - call topbot(1, w, ibeg, iend) - - if (ibeg .gt. 0) then - - call caract(ibeg, iend, temp_cs, tau_cs, iwco_cs, & - & pres_cs, dz_cs, rhodz_cs, rad_cs, pcld, tcld, & - & som_tau, som_iwc, som_dz, som_rad) - - tau = som_tau - emis = 1. - exp(-tau) - iwp = som_iwc - deltaz = som_dz - rad = som_rad - - if (pcld .gt. p_thresh) then - - shc = 0. - shist = 0. - sCb = 0. - sThCi = 0. - sAnv = 0. - - else - - if (emis .lt. em_min .or. emis .gt. em_max & - & .or. tcld .gt. 230.) then - shist = 0. - endif - - if (emis .lt. 0.98) then - sCb = 0. - endif - - if (emis .gt. 0.5 .or. emis .lt. 0.1) then - sThCi = 0. - endif - - if (emis .le. 0.5 .or. emis .ge. 0.98) then - sAnv = 0. - endif - - endif - - else - - tau = 0. - emis = 0. - iwp = 0. - deltaz = 0. - pcld = 0. - tcld = 0. - stot = 0. - shc = 0. - shist = 0. - rad = 0. - sCb = 0. - sThCi = 0. - sAnv = 0. - - endif - - -! Tests - - if (iwp .lt. 0.) then - WRITE(abort_message,*) 'ideb iwp =', ideb, iwp - CALL abort_physic(modname,abort_message,1) - endif - - if (deltaz .lt. 0.) then - WRITE(abort_message,*)'ideb deltaz =', ideb, deltaz - CALL abort_physic(modname,abort_message,1) - endif - - if (emis .lt. 0.048 .and. emis .ne. 0.) then - WRITE(abort_message,*) 'ideb emis =', ideb, emis - CALL abort_physic(modname,abort_message,1) - endif - - end subroutine sous_section - - - subroutine masque (ibeg, iend, som_tau, & - & visible, w) - - INTEGER, intent(in) :: ibeg, iend - REAL, intent(in) :: som_tau - - INTEGER, intent(inout) :: visible - REAL, DIMENSION(:), intent(inout) :: w - - INTEGER :: i - - - -! Masque - -! Cas ou il n'y a pas de nuage visible au-dessus - - if (visible .eq. 0) then - - if (som_tau .lt. tau_thresh) then - do i = ibeg, iend - w(i) = 0. - enddo - else - visible = 1 - endif - -! Cas ou il y a un nuage visible au-dessus - - else - - do i = ibeg, iend - w(i) = 0. - enddo - - endif - - - end subroutine masque - - - subroutine caract (ibeg, iend, temp_cs, tau_cs, iwco_cs, & - & pres_cs, dz_cs, rhodz_cs, rad_cs, pcld, tcld, & - & som_tau, som_iwc, som_dz, som_rad) - - INTEGER, intent(in) :: ibeg, iend - REAL, DIMENSION(:), intent(in) :: tau_cs, iwco_cs, temp_cs - REAL, DIMENSION(:), intent(in) :: pres_cs, dz_cs, rad_cs - REAL, DIMENSION(:), intent(in) :: rhodz_cs - REAL, intent(out) :: som_tau, som_iwc, som_dz, som_rad - REAL , intent(out) :: pcld, tcld - - INTEGER :: i, ibase, imid - - CHARACTER (len = 50) :: modname = 'simu_airs.caract' - CHARACTER (len = 160) :: abort_message - -! Somme des epaisseurs optiques et des contenus en glace sur le nuage - - som_tau = 0. - som_iwc = 0. - som_dz = 0. - som_rad = 0. - ibase = -100 - - do i = ibeg, iend - - som_tau = som_tau + tau_cs(i) - - som_dz = som_dz + dz_cs(i) - som_iwc = som_iwc + iwco_cs(i)*1000*rhodz_cs(i) ! en g/m2 - som_rad = som_rad + rad_cs(i)*dz_cs(i) - - if (som_tau .gt. 3. .and. ibase .eq. -100) then - ibase = i-1 - endif - - enddo - - if (som_dz .ne. 0.) then - som_rad = som_rad/som_dz - else - write(*,*) 'som_dez = 0 STOP' - write(*,*) 'ibeg, iend =', ibeg, iend - do i = ibeg, iend - write(*,*) dz_cs(i), rhodz_cs(i) - enddo - abort_message='see above' - CALL abort_physic(modname,abort_message,1) - endif - -! Determination de Pcld et Tcld - - if (ibase .lt. ibeg) then - ibase = ibeg - endif - - imid = (ibeg+ibase)/2 - - pcld = pres_cs(imid)/100. ! pcld en hPa - tcld = temp_cs(imid) - - - end subroutine caract - - subroutine topbot(ideb,w,ibeg,iend) - - INTEGER, intent(in) :: ideb - REAL, DIMENSION(:), intent(in) :: w - INTEGER, intent(out) :: ibeg, iend - - INTEGER :: i, itest - - itest = 0 - ibeg = 0 - iend = 0 - - do i = ideb, size(w) - - if (w(i) .eq. 1. .and. itest .eq. 0) then - ibeg = i - itest = 1 - endif - - enddo - - - i = ibeg - do while (w(i) .eq. 1. .and. i .le. size(w)) - i = i+1 - enddo - iend = i-1 - - - end subroutine topbot - - subroutine ordonne(len_cs, rneb_cs, rneb_ord) - - INTEGER, intent(in) :: len_cs - REAL, DIMENSION(:), intent(in) :: rneb_cs - REAL, DIMENSION(:), intent(out) :: rneb_ord - - INTEGER :: i, j, ind_min - - REAL, DIMENSION(len_cs) :: rneb - REAL :: rneb_max - - - do i = 1, size(rneb_cs) - rneb(i) = rneb_cs(i) - enddo - - do j = 1, size(rneb_cs) - - rneb_max = 100. - - do i = 1, size(rneb_cs) - if (rneb(i) .lt. rneb_max) then - rneb_max = rneb(i) - ind_min = i - endif - enddo - - rneb_ord(j) = rneb_max - rneb(ind_min) = 100. - - enddo - - end subroutine ordonne - - - subroutine sim_mesh(rneb_1D, temp_1D, emis_1D, & - & iwcon_1D, rad_1D, & - & pres, dz, & - & rhodz_1D, cc_tot_mesh, cc_hc_mesh, cc_hist_mesh, pcld_hc_mesh,& - & tcld_hc_mesh, & - & em_hc_mesh, iwp_hc_mesh, deltaz_hc_mesh, & - & cc_Cb_mesh, cc_ThCi_mesh, cc_Anv_mesh, & - & pcld_Cb_mesh, tcld_Cb_mesh, em_Cb_mesh, & - & pcld_ThCi_mesh, tcld_ThCi_mesh, em_ThCi_mesh, & - & pcld_Anv_mesh, tcld_Anv_mesh, em_Anv_mesh, & - & em_hist_mesh, iwp_hist_mesh, deltaz_hist_mesh, rad_hist_mesh) - - USE dimphy - - REAL, DIMENSION(klev), intent(in) :: rneb_1D, temp_1D, emis_1D, & - & iwcon_1D, rad_1D - REAL, DIMENSION(klev), intent(in) :: pres, dz, rhodz_1D - REAL, intent(out) :: cc_tot_mesh, cc_hc_mesh, cc_hist_mesh - REAL, intent(out) :: cc_Cb_mesh, cc_ThCi_mesh, cc_Anv_mesh - REAL, intent(out) :: em_hc_mesh, pcld_hc_mesh, tcld_hc_mesh, & - & iwp_hc_mesh - - REAL, intent(out) :: pcld_Cb_mesh, tcld_Cb_mesh, em_Cb_mesh - REAL, intent(out) :: pcld_ThCi_mesh, tcld_ThCi_mesh, & - & em_ThCi_mesh - REAL, intent(out) :: pcld_Anv_mesh, tcld_Anv_mesh, em_Anv_mesh - - REAL, intent(out) :: em_hist_mesh, iwp_hist_mesh, rad_hist_mesh - REAL, intent(out) :: deltaz_hc_mesh, deltaz_hist_mesh - - REAL, DIMENSION(:), allocatable :: rneb_cs, temp_cs, emis_cs, & - & iwco_cs - REAL, DIMENSION(:), allocatable :: pres_cs, dz_cs, rad_cs, & - & rhodz_cs - - INTEGER :: i,j,l - INTEGER :: ltop, itop, ibot, num_cs, N_cs, len_cs, ics - - REAL :: som_emi_hc,som_pcl_hc,som_tcl_hc,som_iwp_hc,som_hc,& - & som_hist - REAL :: som_emi_hist, som_iwp_hist, som_deltaz_hc, & - & som_deltaz_hist - REAL :: som_rad_hist - REAL :: som_Cb, som_ThCi, som_Anv - REAL :: som_emi_Cb, som_tcld_Cb, som_pcld_Cb - REAL :: som_emi_Anv, som_tcld_Anv, som_pcld_Anv - REAL :: som_emi_ThCi, som_tcld_ThCi, som_pcld_ThCi - REAL :: tsom_tot, tsom_hc, tsom_hist - REAL :: prod, prod_hh - - REAL :: cc_tot_cs, cc_hc_cs, cc_hist_cs - REAL :: cc_Cb_cs, cc_ThCi_cs, cc_Anv_cs - REAL :: pcld_hc_cs, tcld_hc_cs - REAL :: em_hc_cs, iwp_hc_cs, deltaz_hc_cs - REAL :: pcld_Cb_cs, tcld_Cb_cs, em_Cb_cs - REAL :: pcld_ThCi_cs, tcld_ThCi_cs, em_ThCi_cs - REAL :: pcld_Anv_cs, tcld_Anv_cs, em_Anv_cs - REAL :: em_hist_cs, iwp_hist_cs, deltaz_hist_cs, rad_hist_cs - - REAL, DIMENSION(klev) :: test_tot, test_hc, test_hist - REAL, DIMENSION(klev) :: test_pcld, test_tcld, test_em, test_iwp - - CHARACTER (len = 50) :: modname = 'simu_airs.sim_mesh' - CHARACTER (len = 160) :: abort_message - - - do j = 1, klev - WRITE(lunout,*) 'simu_airs, j, rneb_1D =', rneb_1D(j) - enddo - -! Definition des structures nuageuses, de la plus haute a la plus basse - - num_cs = 0 - ltop = klev-1 - - prod = 1. - - som_emi_hc = 0. - som_emi_hist = 0. - som_pcl_hc = 0. - som_tcl_hc = 0. - som_iwp_hc = 0. - som_iwp_hist = 0. - som_deltaz_hc = 0. - som_deltaz_hist = 0. - som_rad_hist = 0. - som_hc = 0. - som_hist = 0. - - som_Cb = 0. - som_ThCi = 0. - som_Anv = 0. - - som_emi_Cb = 0. - som_pcld_Cb = 0. - som_tcld_Cb = 0. - - som_emi_ThCi = 0. - som_pcld_ThCi = 0. - som_tcld_ThCi = 0. - - som_emi_Anv = 0. - som_pcld_Anv = 0. - som_tcld_Anv = 0. - - tsom_tot = 0. - tsom_hc = 0. - tsom_hist = 0. - - do while (ltop .ge. 1) ! Boucle sur toute la colonne - - itop = 0 - - do l = ltop,1,-1 - - if (itop .eq. 0 .and. rneb_1D(l) .gt. 0.001 ) then - itop = l - endif - - enddo - - ibot = itop - - do while (rneb_1D(ibot) .gt. 0.001 .and. ibot .ge. 1) - ibot = ibot -1 - enddo - - - ibot = ibot+1 - - if (itop .gt. 0) then ! itop > 0 - - num_cs = num_cs +1 - len_cs = itop-ibot+1 - -! Allocation et definition des variables de la structure nuageuse -! le premier indice denote ce qui est le plus haut - - allocate (rneb_cs(len_cs)) - allocate (temp_cs(len_cs)) - allocate (emis_cs(len_cs)) - allocate (iwco_cs(len_cs)) - allocate (pres_cs(len_cs)) - allocate (dz_cs(len_cs)) - allocate (rad_cs(len_cs)) - allocate (rhodz_cs(len_cs)) - - ics = 0 - - do i = itop, ibot, -1 - ics = ics + 1 - rneb_cs(ics) = rneb_1D(i) - temp_cs(ics) = temp_1D(i) - emis_cs(ics) = emis_1D(i) - iwco_cs(ics) = iwcon_1D(i) - rad_cs(ics) = rad_1D(i) - pres_cs(ics) = pres(i) - dz_cs(ics) = dz(i) - rhodz_cs(ics) = rhodz_1D(i) - enddo - -! Appel du sous_programme cloud_structure - - call cloud_structure(len_cs,rneb_cs,temp_cs,emis_cs,iwco_cs,& - & pres_cs, dz_cs, rhodz_cs, rad_cs, & - & cc_tot_cs, cc_hc_cs, cc_hist_cs, & - & cc_Cb_cs, cc_ThCi_cs, cc_Anv_cs, & - & pcld_hc_cs, tcld_hc_cs, & - & em_hc_cs, iwp_hc_cs, deltaz_hc_cs, & - & pcld_Cb_cs, tcld_Cb_cs, em_Cb_cs, & - & pcld_ThCi_cs, tcld_ThCi_cs, em_ThCi_cs, & - & pcld_Anv_cs, tcld_Anv_cs, em_Anv_cs, & - & em_hist_cs, iwp_hist_cs, deltaz_hist_cs, rad_hist_cs) - - - deallocate (rneb_cs) - deallocate (temp_cs) - deallocate (emis_cs) - deallocate (iwco_cs) - deallocate (pres_cs) - deallocate (dz_cs) - deallocate (rad_cs) - deallocate (rhodz_cs) - - -! Pour la couverture nuageuse sur la maille - - prod_hh = prod - - prod = prod*(1.-cc_tot_cs) - -! Pour les autres variables definies sur la maille - - som_emi_hc = som_emi_hc + em_hc_cs*cc_hc_cs*prod_hh - som_iwp_hc = som_iwp_hc + iwp_hc_cs*cc_hc_cs*prod_hh - som_deltaz_hc = som_deltaz_hc + deltaz_hc_cs*cc_hc_cs*prod_hh - - som_emi_Cb = som_emi_Cb + em_Cb_cs*cc_Cb_cs*prod_hh - som_tcld_Cb = som_tcld_Cb + tcld_Cb_cs*cc_Cb_cs*prod_hh - som_pcld_Cb = som_pcld_Cb + pcld_Cb_cs*cc_Cb_cs*prod_hh - - som_emi_ThCi = som_emi_ThCi + em_ThCi_cs*cc_ThCi_cs*prod_hh - som_tcld_ThCi = som_tcld_ThCi + tcld_ThCi_cs*cc_ThCi_cs*prod_hh - som_pcld_ThCi = som_pcld_ThCi + pcld_ThCi_cs*cc_ThCi_cs*prod_hh - - som_emi_Anv = som_emi_Anv + em_Anv_cs*cc_Anv_cs*prod_hh - som_tcld_Anv = som_tcld_Anv + tcld_Anv_cs*cc_Anv_cs*prod_hh - som_pcld_Anv = som_pcld_Anv + pcld_Anv_cs*cc_Anv_cs*prod_hh - - som_emi_hist = som_emi_hist + em_hist_cs*cc_hist_cs*prod_hh - som_iwp_hist = som_iwp_hist + iwp_hist_cs*cc_hist_cs*prod_hh - som_deltaz_hist = som_deltaz_hist + & - & deltaz_hist_cs*cc_hist_cs*prod_hh - som_rad_hist = som_rad_hist + rad_hist_cs*cc_hist_cs*prod_hh - - som_pcl_hc = som_pcl_hc + pcld_hc_cs*cc_hc_cs*prod_hh - som_tcl_hc = som_tcl_hc + tcld_hc_cs*cc_hc_cs*prod_hh - - som_hc = som_hc + cc_hc_cs*prod_hh - som_hist = som_hist + cc_hist_cs*prod_hh - - som_Cb = som_Cb + cc_Cb_cs*prod_hh - som_ThCi = som_ThCi + cc_ThCi_cs*prod_hh - som_Anv = som_Anv + cc_Anv_cs*prod_hh - - -! Pour test - - call test_bornes('cc_tot_cs ',cc_tot_cs,1.,0.) - call test_bornes('cc_hc_cs ',cc_hc_cs,1.,0.) - call test_bornes('cc_hist_cs ',cc_hist_cs,1.,0.) - call test_bornes('pcld_hc_cs ',pcld_hc_cs,1200.,0.) - call test_bornes('tcld_hc_cs ',tcld_hc_cs,1000.,100.) - call test_bornes('em_hc_cs ',em_hc_cs,1000.,0.048) - - test_tot(num_cs) = cc_tot_cs - test_hc(num_cs) = cc_hc_cs - test_hist(num_cs) = cc_hist_cs - test_pcld(num_cs) = pcld_hc_cs - test_tcld(num_cs) = tcld_hc_cs - test_em(num_cs) = em_hc_cs - test_iwp(num_cs) = iwp_hc_cs - - tsom_tot = tsom_tot + cc_tot_cs - tsom_hc = tsom_hc + cc_hc_cs - tsom_hist = tsom_hist + cc_hist_cs - - - endif ! itop > 0 - - ltop = ibot -1 - - enddo ! fin de la boucle sur la colonne - - N_CS = num_cs - - -! Determination des variables de sortie - - if (N_CS .gt. 0) then ! if N_CS>0 - - cc_tot_mesh = 1. - prod - - cc_hc_mesh = som_hc - cc_hist_mesh = som_hist - - cc_Cb_mesh = som_Cb - cc_ThCi_mesh = som_ThCi - cc_Anv_mesh = som_Anv - - call normal2_undef(pcld_hc_mesh,som_pcl_hc, & - & cc_hc_mesh) - call normal2_undef(tcld_hc_mesh,som_tcl_hc, & - & cc_hc_mesh) - call normal2_undef(em_hc_mesh,som_emi_hc, & - & cc_hc_mesh) - call normal2_undef(iwp_hc_mesh,som_iwp_hc, & - & cc_hc_mesh) - call normal2_undef(deltaz_hc_mesh,som_deltaz_hc, & - & cc_hc_mesh) - - call normal2_undef(em_Cb_mesh,som_emi_Cb, & - & cc_Cb_mesh) - call normal2_undef(tcld_Cb_mesh,som_tcld_Cb, & - & cc_Cb_mesh) - call normal2_undef(pcld_Cb_mesh,som_pcld_Cb, & - & cc_Cb_mesh) - - call normal2_undef(em_ThCi_mesh,som_emi_ThCi, & - & cc_ThCi_mesh) - call normal2_undef(tcld_ThCi_mesh,som_tcld_ThCi, & - & cc_ThCi_mesh) - call normal2_undef(pcld_ThCi_mesh,som_pcld_ThCi, & - & cc_ThCi_mesh) - - call normal2_undef(em_Anv_mesh,som_emi_Anv, & - & cc_Anv_mesh) - call normal2_undef(tcld_Anv_mesh,som_tcld_Anv, & - & cc_Anv_mesh) - call normal2_undef(pcld_Anv_mesh,som_pcld_Anv, & - & cc_Anv_mesh) - - - call normal2_undef(em_hist_mesh,som_emi_hist, & - & cc_hist_mesh) - call normal2_undef(iwp_hist_mesh,som_iwp_hist, & - & cc_hist_mesh) - call normal2_undef(deltaz_hist_mesh,som_deltaz_hist, & - & cc_hist_mesh) - call normal2_undef(rad_hist_mesh,som_rad_hist, & - & cc_hist_mesh) - - -! Tests - - ! Tests - - if (cc_tot_mesh .gt. tsom_tot .and. & - & abs(cc_tot_mesh-tsom_tot) .gt. 1.e-4) then - WRITE(abort_message,*)'cc_tot_mesh > tsom_tot', cc_tot_mesh, tsom_tot - CALL abort_physic(modname,abort_message,1) - endif - - if (cc_tot_mesh .lt. maxval(test_tot(1:N_CS)) .and. & - & abs(cc_tot_mesh-maxval(test_tot(1:N_CS))) .gt. 1.e-4) then - WRITE(abort_message,*) 'cc_tot_mesh < max', cc_tot_mesh, maxval(test_tot(1:N_CS)) - CALL abort_physic(modname,abort_message,1) - endif - - if (cc_hc_mesh .gt. tsom_hc .and. & - & abs(cc_hc_mesh-tsom_hc) .gt. 1.e-4) then - WRITE(abort_message,*) 'cc_hc_mesh > tsom_hc', cc_hc_mesh, tsom_hc - CALL abort_physic(modname,abort_message,1) - endif - - if (cc_hc_mesh .lt. maxval(test_hc(1:N_CS)) .and. & - & abs(cc_hc_mesh-maxval(test_hc(1:N_CS))) .gt. 1.e-4) then - WRITE(abort_message,*) 'cc_hc_mesh < max', cc_hc_mesh, maxval(test_hc(1:N_CS)) - CALL abort_physic(modname,abort_message,1) - endif - - if (cc_hist_mesh .gt. tsom_hist .and. & - & abs(cc_hist_mesh-tsom_hist) .gt. 1.e-4) then - WRITE(abort_message,*) 'cc_hist_mesh > tsom_hist', cc_hist_mesh, tsom_hist - CALL abort_physic(modname,abort_message,1) - endif - - if (cc_hist_mesh .lt. 0.) then - WRITE(abort_message,*) 'cc_hist_mesh < 0', cc_hist_mesh - CALL abort_physic(modname,abort_message,1) - endif - - if ((pcld_hc_mesh .gt. maxval(test_pcld(1:N_CS)) .or. & - & pcld_hc_mesh .lt. minval(test_pcld(1:N_CS))) .and. & - & abs(pcld_hc_mesh-maxval(test_pcld(1:N_CS))) .gt. 1. .and. & - & maxval(test_pcld(1:N_CS)) .ne. 999. & - & .and. minval(test_pcld(1:N_CS)) .ne. 999.) then - WRITE(abort_message,*) 'pcld_hc_mesh est faux', pcld_hc_mesh, maxval(test_pcld(1:N_CS)), & - & minval(test_pcld(1:N_CS)) - CALL abort_physic(modname,abort_message,1) - endif - - if ((tcld_hc_mesh .gt. maxval(test_tcld(1:N_CS)) .or. & - & tcld_hc_mesh .lt. minval(test_tcld(1:N_CS))) .and. & - & abs(tcld_hc_mesh-maxval(test_tcld(1:N_CS))) .gt. 0.1 .and. & - & maxval(test_tcld(1:N_CS)) .ne. 999. & - & .and. minval(test_tcld(1:N_CS)) .ne. 999.) then - WRITE(abort_message,*) 'tcld_hc_mesh est faux', tcld_hc_mesh, maxval(test_tcld(1:N_CS)), & - & minval(test_tcld(1:N_CS)) - CALL abort_physic(modname,abort_message,1) - endif - - if ((em_hc_mesh .gt. maxval(test_em(1:N_CS)) .or. & - & em_hc_mesh .lt. minval(test_em(1:N_CS))) .and. & - & abs(em_hc_mesh-maxval(test_em(1:N_CS))) .gt. 1.e-4 .and. & - & minval(test_em(1:N_CS)) .ne. 999. .and. & - & maxval(test_em(1:N_CS)) .ne. 999. ) then - WRITE(abort_message,*) 'em_hc_mesh est faux', em_hc_mesh, maxval(test_em(1:N_CS)), & - & minval(test_em(1:N_CS)) - CALL abort_physic(modname,abort_message,1) - endif - - else ! if N_CS>0 - - cc_tot_mesh = 0. - cc_hc_mesh = 0. - cc_hist_mesh = 0. - - cc_Cb_mesh = 0. - cc_ThCi_mesh = 0. - cc_Anv_mesh = 0. - - iwp_hc_mesh = undef - deltaz_hc_mesh = undef - em_hc_mesh = undef - iwp_hist_mesh = undef - deltaz_hist_mesh = undef - rad_hist_mesh = undef - em_hist_mesh = undef - pcld_hc_mesh = undef - tcld_hc_mesh = undef - - pcld_Cb_mesh = undef - tcld_Cb_mesh = undef - em_Cb_mesh = undef - - pcld_ThCi_mesh = undef - tcld_ThCi_mesh = undef - em_ThCi_mesh = undef - - pcld_Anv_mesh = undef - tcld_Anv_mesh = undef - em_Anv_mesh = undef - - - endif ! if N_CS>0 - - end subroutine sim_mesh - - subroutine test_bornes(sx,x,bsup,binf) - - REAL, intent(in) :: x, bsup, binf - character*14, intent(in) :: sx - CHARACTER (len = 50) :: modname = 'simu_airs.test_bornes' - CHARACTER (len = 160) :: abort_message - - if (x .gt. bsup .or. x .lt. binf) then - WRITE(abort_message,*) sx, 'est faux', sx, x - CALL abort_physic(modname,abort_message,1) - endif - - end subroutine test_bornes - - end module m_simu_airs - - - subroutine simu_airs & - & (itap, rneb_airs, temp_airs, cldemi_airs, iwcon0_airs, rad_airs, & - & geop_airs, pplay_airs, paprs_airs, & - & map_prop_hc,map_prop_hist,& - & map_emis_hc,map_iwp_hc,map_deltaz_hc,map_pcld_hc,map_tcld_hc,& - & map_emis_Cb,map_pcld_Cb,map_tcld_Cb,& - & map_emis_ThCi,map_pcld_ThCi,map_tcld_ThCi,& - & map_emis_Anv,map_pcld_Anv,map_tcld_Anv,& - & map_emis_hist,map_iwp_hist,map_deltaz_hist,map_rad_hist,& - & map_ntot,map_hc,map_hist,& - & map_Cb,map_ThCi,map_Anv,alt_tropo ) - - USE dimphy - USE m_simu_airs - - USE yomcst_mod_h -IMPLICIT NONE - - - - INTEGER,intent(in) :: itap - - REAL, DIMENSION(klon,klev), intent(in) :: & - & rneb_airs, temp_airs, cldemi_airs, iwcon0_airs, & - & rad_airs, geop_airs, pplay_airs, paprs_airs - - REAL, DIMENSION(klon,klev) :: & - & rhodz_airs, rho_airs, iwcon_airs - - REAL, DIMENSION(klon),intent(out) :: alt_tropo - - REAL, DIMENSION(klev) :: rneb_1D, temp_1D, & - & emis_1D, rad_1D, pres_1D, alt_1D, & - & rhodz_1D, dz_1D, iwcon_1D - - INTEGER :: i, j - - REAL :: cc_tot_mesh, cc_hc_mesh, cc_hist_mesh - REAL :: cc_Cb_mesh, cc_ThCi_mesh, cc_Anv_mesh - REAL :: pcld_hc_mesh, tcld_hc_mesh, em_hc_mesh, iwp_hc_mesh - REAL :: em_hist_mesh, iwp_hist_mesh - REAL :: deltaz_hc_mesh, deltaz_hist_mesh, rad_hist_mesh - REAL :: pcld_Cb_mesh, tcld_Cb_mesh, em_Cb_mesh - REAL :: pcld_ThCi_mesh, tcld_ThCi_mesh, em_ThCi_mesh - REAL :: pcld_Anv_mesh, tcld_Anv_mesh, em_Anv_mesh - - REAL, DIMENSION(klon),intent(out) :: map_prop_hc, map_prop_hist - REAL, DIMENSION(klon),intent(out) :: map_emis_hc, map_iwp_hc - REAL, DIMENSION(klon),intent(out) :: map_deltaz_hc, map_pcld_hc - REAL, DIMENSION(klon),intent(out) :: map_tcld_hc - REAL, DIMENSION(klon),intent(out) :: map_emis_Cb,map_pcld_Cb,map_tcld_Cb - REAL, DIMENSION(klon),intent(out) :: & - & map_emis_ThCi,map_pcld_ThCi,map_tcld_ThCi - REAL, DIMENSION(klon),intent(out) :: & - & map_emis_Anv,map_pcld_Anv,map_tcld_Anv - REAL, DIMENSION(klon),intent(out) :: & - & map_emis_hist,map_iwp_hist,map_deltaz_hist,& - & map_rad_hist - REAL, DIMENSION(klon),intent(out) :: map_ntot,map_hc,map_hist - REAL, DIMENSION(klon),intent(out) :: map_Cb,map_ThCi,map_Anv - - - write(*,*) 'simu_airs' - write(*,*) 'itap, klon, klev', itap, klon, klev - write(*,*) 'RG, RD =', RG, RD - - -! Definition des variables 1D - - do i = 1, klon - do j = 1, klev-1 - rhodz_airs(i,j) = & - & (paprs_airs(i,j)-paprs_airs(i,j+1))/RG - enddo - rhodz_airs(i,klev) = 0. - enddo - - do i = 1, klon - do j = 1,klev - rho_airs(i,j) = & - & pplay_airs(i,j)/(temp_airs(i,j)*RD) - - if (rneb_airs(i,j) .gt. 0.001) then - iwcon_airs(i,j) = iwcon0_airs(i,j)/rneb_airs(i,j) - else - iwcon_airs(i,j) = 0. - endif - - enddo - enddo - -!============================================================================= - - do i = 1, klon ! boucle sur les points de grille - -!============================================================================= - - do j = 1,klev - - rneb_1D(j) = rneb_airs(i,j) - temp_1D(j) = temp_airs(i,j) - emis_1D(j) = cldemi_airs(i,j) - iwcon_1D(j) = iwcon_airs(i,j) - rad_1D(j) = rad_airs(i,j) - pres_1D(j) = pplay_airs(i,j) - alt_1D(j) = geop_airs(i,j)/RG - rhodz_1D(j) = rhodz_airs(i,j) - dz_1D(j) = rhodz_airs(i,j)/rho_airs(i,j) - - enddo - - alt_tropo(i) = & - & search_tropopause(pres_1D/100.,temp_1D,alt_1D,klev) - - -! Appel du ss-programme sim_mesh - -! if (itap .eq. 1 ) then - - call sim_mesh(rneb_1D, temp_1D, emis_1D, iwcon_1D, rad_1D, & - & pres_1D, dz_1D, rhodz_1D, & - & cc_tot_mesh, cc_hc_mesh, cc_hist_mesh, & - & pcld_hc_mesh, tcld_hc_mesh, em_hc_mesh, iwp_hc_mesh, & - & deltaz_hc_mesh,& - & cc_Cb_mesh, cc_ThCi_mesh, cc_Anv_mesh, & - & pcld_Cb_mesh, tcld_Cb_mesh, em_Cb_mesh, & - & pcld_ThCi_mesh, tcld_ThCi_mesh, em_ThCi_mesh, & - & pcld_Anv_mesh, tcld_Anv_mesh, em_Anv_mesh, & - & em_hist_mesh, iwp_hist_mesh, deltaz_hist_mesh, rad_hist_mesh) - - write(*,*) '====================================' - write(*,*) 'itap, i:', itap, i - write(*,*) 'cc_tot, cc_hc, cc_hist, pcld_hc, tcld_hc, em_hc, & - & iwp_hc, em_hist, iwp_hist =' - write(*,*) cc_tot_mesh, cc_hc_mesh, cc_hist_mesh - write(*,*) pcld_hc_mesh, tcld_hc_mesh, em_hc_mesh, iwp_hc_mesh - write(*,*) em_hist_mesh, iwp_hist_mesh - -! endif - -! Definition des variables a ecrire dans le fichier de sortie - - call normal2_undef(map_prop_hc(i),cc_hc_mesh, & - & cc_tot_mesh) - call normal2_undef(map_prop_hist(i),cc_hist_mesh, & - & cc_tot_mesh) - - map_emis_hc(i) = em_hc_mesh - map_iwp_hc(i) = iwp_hc_mesh - map_deltaz_hc(i) = deltaz_hc_mesh - map_pcld_hc(i) = pcld_hc_mesh - map_tcld_hc(i) = tcld_hc_mesh - - map_emis_Cb(i) = em_Cb_mesh - map_pcld_Cb(i) = pcld_Cb_mesh - map_tcld_Cb(i) = tcld_Cb_mesh - - map_emis_ThCi(i) = em_ThCi_mesh - map_pcld_ThCi(i) = pcld_ThCi_mesh - map_tcld_ThCi(i) = tcld_ThCi_mesh - - map_emis_Anv(i) = em_Anv_mesh - map_pcld_Anv(i) = pcld_Anv_mesh - map_tcld_Anv(i) = tcld_Anv_mesh - - map_emis_hist(i) = em_hist_mesh - map_iwp_hist(i) = iwp_hist_mesh - map_deltaz_hist(i) = deltaz_hist_mesh - map_rad_hist(i) = rad_hist_mesh - - map_ntot(i) = cc_tot_mesh - map_hc(i) = cc_hc_mesh - map_hist(i) = cc_hist_mesh - - map_Cb(i) = cc_Cb_mesh - map_ThCi(i) = cc_ThCi_mesh - map_Anv(i) = cc_Anv_mesh - - - enddo ! fin boucle sur les points de grille - - - - end subroutine simu_airs - Index: LMDZ6/trunk/libf/phylmd/soil.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/soil.f90 (revision 6047) +++ (revision ) @@ -1,369 +1,0 @@ -! -! $Header$ -! -MODULE soil_mod - USE dimsoil_mod_h, ONLY: nsoilmx - PRIVATE - - REAL, SAVE :: lambda -!$OMP THREADPRIVATE(lambda) - REAL, DIMENSION(nsoilmx), SAVE :: dz1, dz2 -!$OMP THREADPRIVATE(dz1,dz2) - LOGICAL, SAVE :: is_initialized=.FALSE. -!$OMP THREADPRIVATE(is_initialized) - - PUBLIC :: soil_init, soil - -CONTAINS - -SUBROUTINE soil_init -USE dimsoil_mod_h, ONLY: nsoilmx -USE print_control_mod, ONLY: lunout -USE mod_phys_lmdz_para -IMPLICIT NONE - REAL :: min_period,dalph_soil - INTEGER :: ig, jk, ierr -!----------------------------------------------------------------------- -! Depthts: -! -------- - REAL fz,rk,fz1,rk1,rk2 - fz(rk)=fz1*(dalph_soil**rk-1.)/(dalph_soil-1.) - - -!----------------------------------------------------------------------- -! Calculation of some constants -! NB! These constants do not depend on the sub-surfaces -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -! ground levels -! grnd=z/l where l is the skin depth of the diurnal cycle: -!----------------------------------------------------------------------- - IF (.NOT. is_initialized) THEN - - min_period=1800. ! en secondes - dalph_soil=2. ! rapport entre les epaisseurs de 2 couches succ. -!$OMP MASTER - IF (is_mpi_root) THEN - OPEN(99,file='soil.def',status='old',form='formatted',iostat=ierr) - IF (ierr == 0) THEN ! Read file only if it exists - READ(99,*) min_period - READ(99,*) dalph_soil - WRITE(lunout,*)'Discretization for the soil model' - WRITE(lunout,*)'First level e-folding depth',min_period, & - ' dalph',dalph_soil - CLOSE(99) - END IF - ENDIF -!$OMP END MASTER - CALL bcast(min_period) - CALL bcast(dalph_soil) - -! la premiere couche represente un dixieme de cycle diurne - fz1=SQRT(min_period/3.14) - - DO jk=1,nsoilmx - rk1=jk - rk2=jk-1 - dz2(jk)=fz(rk1)-fz(rk2) - ENDDO - DO jk=1,nsoilmx-1 - rk1=jk+.5 - rk2=jk-.5 - dz1(jk)=1./(fz(rk1)-fz(rk2)) - ENDDO - lambda=fz(.5)*dz1(1) - WRITE(lunout,*)'full layers, intermediate layers (seconds)' - DO jk=1,nsoilmx - rk=jk - rk1=jk+.5 - rk2=jk-.5 - WRITE(lunout,*)'fz=', & - fz(rk1)*fz(rk2)*3.14,fz(rk)*fz(rk)*3.14 - ENDDO - - is_initialized=.TRUE. - END IF - -END SUBROUTINE soil_init - -SUBROUTINE soil(ptimestep, indice, knon, snow, ptsrf, qsol, & - lon, lat, ptsoil, pcapcal, pfluxgrd) -!$gpum horizontal knon klon - USE yomcst_mod_h - USE dimphy - USE mod_phys_lmdz_para - USE indice_sol_mod - USE print_control_mod, ONLY: lunout - USE dimsoil_mod_h, ONLY: nsoilmx - USE comsoil_mod_h - IMPLICIT NONE - -!======================================================================= -! -! Auteur: Frederic Hourdin 30/01/92 -! ------- -! -! Object: Computation of : the soil temperature evolution -! ------- the surfacic heat capacity "Capcal" -! the surface conduction flux pcapcal -! -! Update: 2021/07 : soil thermal inertia, formerly a constant value, -! ------ can also be now a function of soil moisture (F Cheruy's idea) -! depending on iflag_inertie, read from physiq.def via conf_phys_m.F90 -! ("Stage L3" Eve Rebouillat, with E Vignon, A Sima, F Cheruy) -! -! Method: Implicit time integration -! ------- -! Consecutive ground temperatures are related by: -! T(k+1) = C(k) + D(k)*T(k) (*) -! The coefficients C and D are computed at the t-dt time-step. -! Routine structure: -! 1) C and D coefficients are computed from the old temperature -! 2) new temperatures are computed using (*) -! 3) C and D coefficients are computed from the new temperature -! profile for the t+dt time-step -! 4) the coefficients A and B are computed where the diffusive -! fluxes at the t+dt time-step is given by -! Fdiff = A + B Ts(t+dt) -! or Fdiff = F0 + Capcal (Ts(t+dt)-Ts(t))/dt -! with F0 = A + B (Ts(t)) -! Capcal = B*dt -! -! Interface: -! ---------- -! -! Arguments: -! ---------- -! ptimestep physical timestep (s) -! indice sub-surface index -! snow(klon) snow -! ptsrf(klon) surface temperature at time-step t (K) -! qsol(klon) soil moisture (kg/m2 or mm) -! lon(klon) longitude in radian -! lat(klon) latitude in radian -! ptsoil(klon,nsoilmx) temperature inside the ground (K) -! pcapcal(klon) surfacic specific heat (W*m-2*s*K-1) -! pfluxgrd(klon) surface diffusive flux from ground (Wm-2) -! -!======================================================================= -! Arguments -! --------- - REAL, INTENT(IN) :: ptimestep - INTEGER, INTENT(IN) :: indice, knon !, knindex - REAL, DIMENSION(knon), INTENT(IN) :: snow - REAL, DIMENSION(knon), INTENT(IN) :: ptsrf - REAL, DIMENSION(knon), INTENT(IN) :: qsol - REAL, DIMENSION(knon), INTENT(IN) :: lon - REAL, DIMENSION(knon), INTENT(IN) :: lat - - REAL, DIMENSION(knon,nsoilmx), INTENT(INOUT) :: ptsoil - REAL, DIMENSION(knon), INTENT(OUT) :: pcapcal - REAL, DIMENSION(knon), INTENT(OUT) :: pfluxgrd - -!----------------------------------------------------------------------- -! Local variables -! --------------- - INTEGER :: ig, jk, ierr - REAL, DIMENSION(nsoilmx) :: zdz2 - REAL :: z1s - REAL, DIMENSION(knon) :: ztherm_i - REAL, DIMENSION(knon,nsoilmx,nbsrf) :: C_coef, D_coef - - - -!----------------------------------------------------------------------- -! Calcul de l'inertie thermique a partir de la variable rnat. -! on initialise a inertie_sic meme au-dessus d'un point de mer au cas -! ou le point de mer devienne point de glace au pas suivant -! on corrige si on a un point de terre avec ou sans glace -! -! iophys can be used to write the ztherm_i variable in a phys.nc file -! and check the results; to do so, add "CALL iophys_ini" in physiq_mod -! and add knindex to the list of inputs in all the calls to soil.F90 -! (and to soil.F90 itself !) -!----------------------------------------------------------------------- - - IF (indice == is_sic) THEN - DO ig = 1, knon - ztherm_i(ig) = inertie_sic - ENDDO - IF (iflag_sic == 0) THEN - DO ig = 1, knon - IF (snow(ig) > 0.0) ztherm_i(ig) = inertie_sno - ENDDO -! Otherwise sea-ice keeps the same inertia, even when covered by snow - ENDIF -! CALL iophys_ecrit_index('ztherm_sic', 1, 'ztherm_sic', 'USI', & -! knon, knindex, ztherm_i) - ELSE IF (indice == is_lic) THEN - DO ig = 1, knon - ztherm_i(ig) = inertie_lic - IF (snow(ig) > 0.0) ztherm_i(ig) = inertie_sno - ENDDO -! CALL iophys_ecrit_index('ztherm_lic', 1, 'ztherm_lic', 'USI', & -! knon, knindex, ztherm_i) - ELSE IF (indice == is_ter) THEN - ! - ! La relation entre l'inertie thermique du sol et qsol change d'apres - ! iflag_inertie, defini dans physiq.def, et appele via comsoil.h - ! - DO ig = 1, knon - ! iflag_inertie=0 correspond au cas inertie=constant, comme avant - IF (iflag_inertie==0) THEN - ztherm_i(ig) = inertie_sol - ELSE IF (iflag_inertie == 1) THEN - ! I = a_qsol * qsol + b modele lineaire deduit d'une - ! regression lineaire I = a_mrsos * mrsos + b obtenue sur - ! sorties MO d'une simulation LMDZOR(CMIP6) sur l'annee 2000 - ! sur tous les points avec frac_snow=0 - ! Difference entre qsol et mrsos prise en compte par un - ! facteur d'echelle sur le coefficient directeur de regression: - ! fact = 35./150. = mrsos_max/qsol_max - ! et a_qsol = a_mrsos * fact (car a = dI/dHumidite) - ztherm_i(ig) = 30.0 *35.0/150.0 *qsol(ig) +770.0 - ! AS : pour qsol entre 0 - 150, on a I entre 770 - 1820 - ELSE IF (iflag_inertie == 2) THEN - ! deux regressions lineaires, sur les memes sorties, - ! distinguant le type de sol : sable ou autre (limons/argile) - ! Implementation simple : regression type "sable" seulement pour - ! Sahara, defini par une "boite" lat/lon (NB : en radians !! ) - IF (lon(ig)>-0.35 .AND. lon(ig)<0.70 .AND. lat(ig)>0.17 .AND. lat(ig)<0.52) THEN - ! Valeurs theoriquement entre 728 et 2373 ; qsol valeurs basses - ztherm_i(ig) = 47. *35.0/150.0 *qsol(ig) +728. ! boite type "sable" pour Sahara - ELSE - ! Valeurs theoriquement entre 550 et 1940 ; qsol valeurs moyennes et hautes - ztherm_i(ig) = 41. *35.0/150.0 *qsol(ig) +505. - ENDIF - ELSE IF (iflag_inertie == 3) THEN - ! AS : idee a tester : - ! si la relation doit etre une droite, - ! definissons-la en fonction des valeurs min et max de qsol (0:150), - ! et de l'inertie (900 : 2000 ou 2400 ; choix ici: 2000) - ! I = I_min + qsol * (I_max - I_min)/(qsol_max - qsol_min) - ztherm_i(ig) = 900. + qsol(ig) * (2000. - 900.)/150. - ELSE - WRITE (lunout,*) "Le choix iflag_inertie = ",iflag_inertie," n'est pas defini. Veuillez choisir un entier entre 0 et 3" - ENDIF - ! - ! Fin de l'introduction de la relation entre l'inertie thermique du sol et qsol - !------------------------------------------- - !AS : donc le moindre flocon de neige sur un point de grid - ! fait que l'inertie du point passe a la valeur pour neige ! - IF (snow(ig) > 0.0) ztherm_i(ig) = inertie_sno - - ENDDO -! CALL iophys_ecrit_index('ztherm_ter', 1, 'ztherm_ter', 'USI', & -! knon, knindex, ztherm_i) - ELSE IF (indice == is_oce) THEN - DO ig = 1, knon -! This is just in case, but SST should be used by the model anyway - ztherm_i(ig) = inertie_sic - ENDDO -! CALL iophys_ecrit_index('ztherm_oce', 1, 'ztherm_oce', 'USI', & -! knon, knindex, ztherm_i) - ELSE - WRITE(lunout,*) "valeur d indice non prevue", indice - call abort_physic("soil", "", 1) - ENDIF - - -!----------------------------------------------------------------------- -! 1) -! Calculation of Cgrf and Dgrd coefficients using soil temperature from -! previous time step. -! -! These variables are recalculated on the local compressed grid instead -! of saved in restart file. -!----------------------------------------------------------------------- - DO jk=1,nsoilmx - zdz2(jk)=dz2(jk)/ptimestep - ENDDO - - DO ig=1,knon - z1s = zdz2(nsoilmx)+dz1(nsoilmx-1) - C_coef(ig,nsoilmx-1,indice)= & - zdz2(nsoilmx)*ptsoil(ig,nsoilmx)/z1s - D_coef(ig,nsoilmx-1,indice)=dz1(nsoilmx-1)/z1s - ENDDO - - DO jk=nsoilmx-1,2,-1 - DO ig=1,knon - z1s = 1./(zdz2(jk)+dz1(jk-1)+dz1(jk) & - *(1.-D_coef(ig,jk,indice))) - C_coef(ig,jk-1,indice)= & - (ptsoil(ig,jk)*zdz2(jk)+dz1(jk)*C_coef(ig,jk,indice)) * z1s - D_coef(ig,jk-1,indice)=dz1(jk-1)*z1s - ENDDO - ENDDO - -!----------------------------------------------------------------------- -! 2) -! Computation of the soil temperatures using the Cgrd and Dgrd -! coefficient computed above -! -!----------------------------------------------------------------------- - -! Surface temperature - DO ig=1,knon - ptsoil(ig,1)=(lambda*C_coef(ig,1,indice)+ptsrf(ig))/ & - (lambda*(1.-D_coef(ig,1,indice))+1.) - ENDDO - -! Other temperatures - DO jk=1,nsoilmx-1 - DO ig=1,knon - ptsoil(ig,jk+1)=C_coef(ig,jk,indice)+D_coef(ig,jk,indice) & - *ptsoil(ig,jk) - ENDDO - ENDDO - - IF (indice == is_sic) THEN - DO ig = 1 , knon - ptsoil(ig,nsoilmx) = RTT - 1.8 - END DO - ENDIF - -!----------------------------------------------------------------------- -! 3) -! Calculate the Cgrd and Dgrd coefficient corresponding to actual soil -! temperature -!----------------------------------------------------------------------- - DO ig=1,knon - z1s = zdz2(nsoilmx)+dz1(nsoilmx-1) - C_coef(ig,nsoilmx-1,indice) = zdz2(nsoilmx)*ptsoil(ig,nsoilmx)/z1s - D_coef(ig,nsoilmx-1,indice) = dz1(nsoilmx-1)/z1s - ENDDO - - DO jk=nsoilmx-1,2,-1 - DO ig=1,knon - z1s = 1./(zdz2(jk)+dz1(jk-1)+dz1(jk) & - *(1.-D_coef(ig,jk,indice))) - C_coef(ig,jk-1,indice) = & - (ptsoil(ig,jk)*zdz2(jk)+dz1(jk)*C_coef(ig,jk,indice)) * z1s - D_coef(ig,jk-1,indice) = dz1(jk-1)*z1s - ENDDO - ENDDO - -!----------------------------------------------------------------------- -! 4) -! Computation of the surface diffusive flux from ground and -! calorific capacity of the ground -!----------------------------------------------------------------------- - DO ig=1,knon - pfluxgrd(ig) = ztherm_i(ig)*dz1(1)* & - (C_coef(ig,1,indice)+(D_coef(ig,1,indice)-1.)*ptsoil(ig,1)) - pcapcal(ig) = ztherm_i(ig)* & - (dz2(1)+ptimestep*(1.-D_coef(ig,1,indice))*dz1(1)) - z1s = lambda*(1.-D_coef(ig,1,indice))+1. - pcapcal(ig) = pcapcal(ig)/z1s - pfluxgrd(ig) = pfluxgrd(ig) & - + pcapcal(ig) * (ptsoil(ig,1) * z1s & - - lambda * C_coef(ig,1,indice) & - - ptsrf(ig)) & - /ptimestep - ENDDO - -END SUBROUTINE soil - -END MODULE soil_mod Index: LMDZ6/trunk/libf/phylmd/soil_mod.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/soil_mod.f90 (revision 6048) +++ LMDZ6/trunk/libf/phylmd/soil_mod.f90 (revision 6048) @@ -0,0 +1,369 @@ +! +! $Header$ +! +MODULE soil_mod + USE dimsoil_mod_h, ONLY: nsoilmx + PRIVATE + + REAL, SAVE :: lambda +!$OMP THREADPRIVATE(lambda) + REAL, DIMENSION(nsoilmx), SAVE :: dz1, dz2 +!$OMP THREADPRIVATE(dz1,dz2) + LOGICAL, SAVE :: is_initialized=.FALSE. +!$OMP THREADPRIVATE(is_initialized) + + PUBLIC :: soil_init, soil + +CONTAINS + +SUBROUTINE soil_init +USE dimsoil_mod_h, ONLY: nsoilmx +USE print_control_mod, ONLY: lunout +USE mod_phys_lmdz_para +IMPLICIT NONE + REAL :: min_period,dalph_soil + INTEGER :: ig, jk, ierr +!----------------------------------------------------------------------- +! Depthts: +! -------- + REAL fz,rk,fz1,rk1,rk2 + fz(rk)=fz1*(dalph_soil**rk-1.)/(dalph_soil-1.) + + +!----------------------------------------------------------------------- +! Calculation of some constants +! NB! These constants do not depend on the sub-surfaces +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! ground levels +! grnd=z/l where l is the skin depth of the diurnal cycle: +!----------------------------------------------------------------------- + IF (.NOT. is_initialized) THEN + + min_period=1800. ! en secondes + dalph_soil=2. ! rapport entre les epaisseurs de 2 couches succ. +!$OMP MASTER + IF (is_mpi_root) THEN + OPEN(99,file='soil.def',status='old',form='formatted',iostat=ierr) + IF (ierr == 0) THEN ! Read file only if it exists + READ(99,*) min_period + READ(99,*) dalph_soil + WRITE(lunout,*)'Discretization for the soil model' + WRITE(lunout,*)'First level e-folding depth',min_period, & + ' dalph',dalph_soil + CLOSE(99) + END IF + ENDIF +!$OMP END MASTER + CALL bcast(min_period) + CALL bcast(dalph_soil) + +! la premiere couche represente un dixieme de cycle diurne + fz1=SQRT(min_period/3.14) + + DO jk=1,nsoilmx + rk1=jk + rk2=jk-1 + dz2(jk)=fz(rk1)-fz(rk2) + ENDDO + DO jk=1,nsoilmx-1 + rk1=jk+.5 + rk2=jk-.5 + dz1(jk)=1./(fz(rk1)-fz(rk2)) + ENDDO + lambda=fz(.5)*dz1(1) + WRITE(lunout,*)'full layers, intermediate layers (seconds)' + DO jk=1,nsoilmx + rk=jk + rk1=jk+.5 + rk2=jk-.5 + WRITE(lunout,*)'fz=', & + fz(rk1)*fz(rk2)*3.14,fz(rk)*fz(rk)*3.14 + ENDDO + + is_initialized=.TRUE. + END IF + +END SUBROUTINE soil_init + +SUBROUTINE soil(ptimestep, indice, knon, snow, ptsrf, qsol, & + lon, lat, ptsoil, pcapcal, pfluxgrd) +!$gpum horizontal knon klon + USE yomcst_mod_h + USE dimphy + USE mod_phys_lmdz_para + USE indice_sol_mod + USE print_control_mod, ONLY: lunout + USE dimsoil_mod_h, ONLY: nsoilmx + USE comsoil_mod_h + IMPLICIT NONE + +!======================================================================= +! +! Auteur: Frederic Hourdin 30/01/92 +! ------- +! +! Object: Computation of : the soil temperature evolution +! ------- the surfacic heat capacity "Capcal" +! the surface conduction flux pcapcal +! +! Update: 2021/07 : soil thermal inertia, formerly a constant value, +! ------ can also be now a function of soil moisture (F Cheruy's idea) +! depending on iflag_inertie, read from physiq.def via conf_phys_m.F90 +! ("Stage L3" Eve Rebouillat, with E Vignon, A Sima, F Cheruy) +! +! Method: Implicit time integration +! ------- +! Consecutive ground temperatures are related by: +! T(k+1) = C(k) + D(k)*T(k) (*) +! The coefficients C and D are computed at the t-dt time-step. +! Routine structure: +! 1) C and D coefficients are computed from the old temperature +! 2) new temperatures are computed using (*) +! 3) C and D coefficients are computed from the new temperature +! profile for the t+dt time-step +! 4) the coefficients A and B are computed where the diffusive +! fluxes at the t+dt time-step is given by +! Fdiff = A + B Ts(t+dt) +! or Fdiff = F0 + Capcal (Ts(t+dt)-Ts(t))/dt +! with F0 = A + B (Ts(t)) +! Capcal = B*dt +! +! Interface: +! ---------- +! +! Arguments: +! ---------- +! ptimestep physical timestep (s) +! indice sub-surface index +! snow(klon) snow +! ptsrf(klon) surface temperature at time-step t (K) +! qsol(klon) soil moisture (kg/m2 or mm) +! lon(klon) longitude in radian +! lat(klon) latitude in radian +! ptsoil(klon,nsoilmx) temperature inside the ground (K) +! pcapcal(klon) surfacic specific heat (W*m-2*s*K-1) +! pfluxgrd(klon) surface diffusive flux from ground (Wm-2) +! +!======================================================================= +! Arguments +! --------- + REAL, INTENT(IN) :: ptimestep + INTEGER, INTENT(IN) :: indice, knon !, knindex + REAL, DIMENSION(knon), INTENT(IN) :: snow + REAL, DIMENSION(knon), INTENT(IN) :: ptsrf + REAL, DIMENSION(knon), INTENT(IN) :: qsol + REAL, DIMENSION(knon), INTENT(IN) :: lon + REAL, DIMENSION(knon), INTENT(IN) :: lat + + REAL, DIMENSION(knon,nsoilmx), INTENT(INOUT) :: ptsoil + REAL, DIMENSION(knon), INTENT(OUT) :: pcapcal + REAL, DIMENSION(knon), INTENT(OUT) :: pfluxgrd + +!----------------------------------------------------------------------- +! Local variables +! --------------- + INTEGER :: ig, jk, ierr + REAL, DIMENSION(nsoilmx) :: zdz2 + REAL :: z1s + REAL, DIMENSION(knon) :: ztherm_i + REAL, DIMENSION(knon,nsoilmx,nbsrf) :: C_coef, D_coef + + + +!----------------------------------------------------------------------- +! Calcul de l'inertie thermique a partir de la variable rnat. +! on initialise a inertie_sic meme au-dessus d'un point de mer au cas +! ou le point de mer devienne point de glace au pas suivant +! on corrige si on a un point de terre avec ou sans glace +! +! iophys can be used to write the ztherm_i variable in a phys.nc file +! and check the results; to do so, add "CALL iophys_ini" in physiq_mod +! and add knindex to the list of inputs in all the calls to soil.F90 +! (and to soil.F90 itself !) +!----------------------------------------------------------------------- + + IF (indice == is_sic) THEN + DO ig = 1, knon + ztherm_i(ig) = inertie_sic + ENDDO + IF (iflag_sic == 0) THEN + DO ig = 1, knon + IF (snow(ig) > 0.0) ztherm_i(ig) = inertie_sno + ENDDO +! Otherwise sea-ice keeps the same inertia, even when covered by snow + ENDIF +! CALL iophys_ecrit_index('ztherm_sic', 1, 'ztherm_sic', 'USI', & +! knon, knindex, ztherm_i) + ELSE IF (indice == is_lic) THEN + DO ig = 1, knon + ztherm_i(ig) = inertie_lic + IF (snow(ig) > 0.0) ztherm_i(ig) = inertie_sno + ENDDO +! CALL iophys_ecrit_index('ztherm_lic', 1, 'ztherm_lic', 'USI', & +! knon, knindex, ztherm_i) + ELSE IF (indice == is_ter) THEN + ! + ! La relation entre l'inertie thermique du sol et qsol change d'apres + ! iflag_inertie, defini dans physiq.def, et appele via comsoil.h + ! + DO ig = 1, knon + ! iflag_inertie=0 correspond au cas inertie=constant, comme avant + IF (iflag_inertie==0) THEN + ztherm_i(ig) = inertie_sol + ELSE IF (iflag_inertie == 1) THEN + ! I = a_qsol * qsol + b modele lineaire deduit d'une + ! regression lineaire I = a_mrsos * mrsos + b obtenue sur + ! sorties MO d'une simulation LMDZOR(CMIP6) sur l'annee 2000 + ! sur tous les points avec frac_snow=0 + ! Difference entre qsol et mrsos prise en compte par un + ! facteur d'echelle sur le coefficient directeur de regression: + ! fact = 35./150. = mrsos_max/qsol_max + ! et a_qsol = a_mrsos * fact (car a = dI/dHumidite) + ztherm_i(ig) = 30.0 *35.0/150.0 *qsol(ig) +770.0 + ! AS : pour qsol entre 0 - 150, on a I entre 770 - 1820 + ELSE IF (iflag_inertie == 2) THEN + ! deux regressions lineaires, sur les memes sorties, + ! distinguant le type de sol : sable ou autre (limons/argile) + ! Implementation simple : regression type "sable" seulement pour + ! Sahara, defini par une "boite" lat/lon (NB : en radians !! ) + IF (lon(ig)>-0.35 .AND. lon(ig)<0.70 .AND. lat(ig)>0.17 .AND. lat(ig)<0.52) THEN + ! Valeurs theoriquement entre 728 et 2373 ; qsol valeurs basses + ztherm_i(ig) = 47. *35.0/150.0 *qsol(ig) +728. ! boite type "sable" pour Sahara + ELSE + ! Valeurs theoriquement entre 550 et 1940 ; qsol valeurs moyennes et hautes + ztherm_i(ig) = 41. *35.0/150.0 *qsol(ig) +505. + ENDIF + ELSE IF (iflag_inertie == 3) THEN + ! AS : idee a tester : + ! si la relation doit etre une droite, + ! definissons-la en fonction des valeurs min et max de qsol (0:150), + ! et de l'inertie (900 : 2000 ou 2400 ; choix ici: 2000) + ! I = I_min + qsol * (I_max - I_min)/(qsol_max - qsol_min) + ztherm_i(ig) = 900. + qsol(ig) * (2000. - 900.)/150. + ELSE + WRITE (lunout,*) "Le choix iflag_inertie = ",iflag_inertie," n'est pas defini. Veuillez choisir un entier entre 0 et 3" + ENDIF + ! + ! Fin de l'introduction de la relation entre l'inertie thermique du sol et qsol + !------------------------------------------- + !AS : donc le moindre flocon de neige sur un point de grid + ! fait que l'inertie du point passe a la valeur pour neige ! + IF (snow(ig) > 0.0) ztherm_i(ig) = inertie_sno + + ENDDO +! CALL iophys_ecrit_index('ztherm_ter', 1, 'ztherm_ter', 'USI', & +! knon, knindex, ztherm_i) + ELSE IF (indice == is_oce) THEN + DO ig = 1, knon +! This is just in case, but SST should be used by the model anyway + ztherm_i(ig) = inertie_sic + ENDDO +! CALL iophys_ecrit_index('ztherm_oce', 1, 'ztherm_oce', 'USI', & +! knon, knindex, ztherm_i) + ELSE + WRITE(lunout,*) "valeur d indice non prevue", indice + call abort_physic("soil", "", 1) + ENDIF + + +!----------------------------------------------------------------------- +! 1) +! Calculation of Cgrf and Dgrd coefficients using soil temperature from +! previous time step. +! +! These variables are recalculated on the local compressed grid instead +! of saved in restart file. +!----------------------------------------------------------------------- + DO jk=1,nsoilmx + zdz2(jk)=dz2(jk)/ptimestep + ENDDO + + DO ig=1,knon + z1s = zdz2(nsoilmx)+dz1(nsoilmx-1) + C_coef(ig,nsoilmx-1,indice)= & + zdz2(nsoilmx)*ptsoil(ig,nsoilmx)/z1s + D_coef(ig,nsoilmx-1,indice)=dz1(nsoilmx-1)/z1s + ENDDO + + DO jk=nsoilmx-1,2,-1 + DO ig=1,knon + z1s = 1./(zdz2(jk)+dz1(jk-1)+dz1(jk) & + *(1.-D_coef(ig,jk,indice))) + C_coef(ig,jk-1,indice)= & + (ptsoil(ig,jk)*zdz2(jk)+dz1(jk)*C_coef(ig,jk,indice)) * z1s + D_coef(ig,jk-1,indice)=dz1(jk-1)*z1s + ENDDO + ENDDO + +!----------------------------------------------------------------------- +! 2) +! Computation of the soil temperatures using the Cgrd and Dgrd +! coefficient computed above +! +!----------------------------------------------------------------------- + +! Surface temperature + DO ig=1,knon + ptsoil(ig,1)=(lambda*C_coef(ig,1,indice)+ptsrf(ig))/ & + (lambda*(1.-D_coef(ig,1,indice))+1.) + ENDDO + +! Other temperatures + DO jk=1,nsoilmx-1 + DO ig=1,knon + ptsoil(ig,jk+1)=C_coef(ig,jk,indice)+D_coef(ig,jk,indice) & + *ptsoil(ig,jk) + ENDDO + ENDDO + + IF (indice == is_sic) THEN + DO ig = 1 , knon + ptsoil(ig,nsoilmx) = RTT - 1.8 + END DO + ENDIF + +!----------------------------------------------------------------------- +! 3) +! Calculate the Cgrd and Dgrd coefficient corresponding to actual soil +! temperature +!----------------------------------------------------------------------- + DO ig=1,knon + z1s = zdz2(nsoilmx)+dz1(nsoilmx-1) + C_coef(ig,nsoilmx-1,indice) = zdz2(nsoilmx)*ptsoil(ig,nsoilmx)/z1s + D_coef(ig,nsoilmx-1,indice) = dz1(nsoilmx-1)/z1s + ENDDO + + DO jk=nsoilmx-1,2,-1 + DO ig=1,knon + z1s = 1./(zdz2(jk)+dz1(jk-1)+dz1(jk) & + *(1.-D_coef(ig,jk,indice))) + C_coef(ig,jk-1,indice) = & + (ptsoil(ig,jk)*zdz2(jk)+dz1(jk)*C_coef(ig,jk,indice)) * z1s + D_coef(ig,jk-1,indice) = dz1(jk-1)*z1s + ENDDO + ENDDO + +!----------------------------------------------------------------------- +! 4) +! Computation of the surface diffusive flux from ground and +! calorific capacity of the ground +!----------------------------------------------------------------------- + DO ig=1,knon + pfluxgrd(ig) = ztherm_i(ig)*dz1(1)* & + (C_coef(ig,1,indice)+(D_coef(ig,1,indice)-1.)*ptsoil(ig,1)) + pcapcal(ig) = ztherm_i(ig)* & + (dz2(1)+ptimestep*(1.-D_coef(ig,1,indice))*dz1(1)) + z1s = lambda*(1.-D_coef(ig,1,indice))+1. + pcapcal(ig) = pcapcal(ig)/z1s + pfluxgrd(ig) = pfluxgrd(ig) & + + pcapcal(ig) * (ptsoil(ig,1) * z1s & + - lambda * C_coef(ig,1,indice) & + - ptsrf(ig)) & + /ptimestep + ENDDO + +END SUBROUTINE soil + +END MODULE soil_mod Index: LMDZ6/trunk/libf/phylmd/stratocu_if.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/stratocu_if.f90 (revision 6047) +++ (revision ) @@ -1,91 +1,0 @@ -!$gpum horizontal klon -MODULE stratocu_if_mod - PRIVATE - - PUBLIC stratocu_if - - CONTAINS - - SUBROUTINE stratocu_if(klon,klev,pctsrf,paprs, pplay,t & -,seuil_inversion,weak_inversion,dthmin) - - USE indice_sol_mod - -USE yomcst_mod_h -IMPLICIT NONE - -!====================================================================== -! J'introduit un peu de diffusion sauf dans les endroits -! ou une forte inversion est presente -! On peut dire qu'il represente la convection peu profonde -! -! Arguments: -! klon-----input-I- nombre de points a traiter -! paprs----input-R- pression a chaque intercouche (en Pa) -! pplay----input-R- pression au milieu de chaque couche (en Pa) -! t--------input-R- temperature (K) -! -! weak_inversion-----logical -!====================================================================== -! -! Arguments: -! - INTEGER, INTENT(IN) :: klon,klev - REAL, DIMENSION(klon, klev+1), INTENT(IN) :: paprs - REAL, DIMENSION(klon, klev), INTENT(IN) :: pplay - REAL, DIMENSION(klon, 4), INTENT(IN) :: pctsrf - REAL, DIMENSION(klon, klev), INTENT(IN) :: t - - REAL, DIMENSION(klon), INTENT(OUT) :: weak_inversion -! -! Quelques constantes et options: -! - REAL seuil_inversion ! au-dela l'inversion est consideree trop faible -! PARAMETER (seuil=-0.1) - -! -! Variables locales: -! - INTEGER i, k, invb(klon) - REAL zl2(klon) - REAL dthmin(klon), zdthdp - - - -! -! Chercher la zone d'inversion forte -! - - DO i = 1, klon - invb(i) = klev - dthmin(i)=0.0 - ENDDO - DO k = 2, klev/2-1 - DO i = 1, klon - zdthdp = (t(i,k)-t(i,k+1))/(pplay(i,k)-pplay(i,k+1)) & - - RD * 0.5*(t(i,k)+t(i,k+1))/RCPD/paprs(i,k+1) - zdthdp = zdthdp * 100.0 - IF (pplay(i,k).GT.0.8*paprs(i,1) .AND. & - zdthdp.LT.dthmin(i) ) THEN - dthmin(i) = zdthdp - invb(i) = k - ENDIF - ENDDO - ENDDO - - -! -! Introduire une diffusion: -! - DO i = 1, klon - IF ( (pctsrf(i,is_oce) < 0.5) .OR. & - (invb(i) == klev) .OR. (dthmin(i) > seuil_inversion) ) THEN - weak_inversion(i)=1. - ELSE - weak_inversion(i)=0. - ENDIF - ENDDO - - END SUBROUTINE stratocu_if - -END MODULE stratocu_if_mod Index: LMDZ6/trunk/libf/phylmd/stratocu_if_mod.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/stratocu_if_mod.f90 (revision 6048) +++ LMDZ6/trunk/libf/phylmd/stratocu_if_mod.f90 (revision 6048) @@ -0,0 +1,91 @@ +!$gpum horizontal klon +MODULE stratocu_if_mod + PRIVATE + + PUBLIC stratocu_if + + CONTAINS + + SUBROUTINE stratocu_if(klon,klev,pctsrf,paprs, pplay,t & +,seuil_inversion,weak_inversion,dthmin) + + USE indice_sol_mod + +USE yomcst_mod_h +IMPLICIT NONE + +!====================================================================== +! J'introduit un peu de diffusion sauf dans les endroits +! ou une forte inversion est presente +! On peut dire qu'il represente la convection peu profonde +! +! Arguments: +! klon-----input-I- nombre de points a traiter +! paprs----input-R- pression a chaque intercouche (en Pa) +! pplay----input-R- pression au milieu de chaque couche (en Pa) +! t--------input-R- temperature (K) +! +! weak_inversion-----logical +!====================================================================== +! +! Arguments: +! + INTEGER, INTENT(IN) :: klon,klev + REAL, DIMENSION(klon, klev+1), INTENT(IN) :: paprs + REAL, DIMENSION(klon, klev), INTENT(IN) :: pplay + REAL, DIMENSION(klon, 4), INTENT(IN) :: pctsrf + REAL, DIMENSION(klon, klev), INTENT(IN) :: t + + REAL, DIMENSION(klon), INTENT(OUT) :: weak_inversion +! +! Quelques constantes et options: +! + REAL seuil_inversion ! au-dela l'inversion est consideree trop faible +! PARAMETER (seuil=-0.1) + +! +! Variables locales: +! + INTEGER i, k, invb(klon) + REAL zl2(klon) + REAL dthmin(klon), zdthdp + + + +! +! Chercher la zone d'inversion forte +! + + DO i = 1, klon + invb(i) = klev + dthmin(i)=0.0 + ENDDO + DO k = 2, klev/2-1 + DO i = 1, klon + zdthdp = (t(i,k)-t(i,k+1))/(pplay(i,k)-pplay(i,k+1)) & + - RD * 0.5*(t(i,k)+t(i,k+1))/RCPD/paprs(i,k+1) + zdthdp = zdthdp * 100.0 + IF (pplay(i,k).GT.0.8*paprs(i,1) .AND. & + zdthdp.LT.dthmin(i) ) THEN + dthmin(i) = zdthdp + invb(i) = k + ENDIF + ENDDO + ENDDO + + +! +! Introduire une diffusion: +! + DO i = 1, klon + IF ( (pctsrf(i,is_oce) < 0.5) .OR. & + (invb(i) == klev) .OR. (dthmin(i) > seuil_inversion) ) THEN + weak_inversion(i)=1. + ELSE + weak_inversion(i)=0. + ENDIF + ENDDO + + END SUBROUTINE stratocu_if + +END MODULE stratocu_if_mod Index: LMDZ6/trunk/libf/phylmd/tend_to_tke.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/tend_to_tke.f90 (revision 6047) +++ (revision ) @@ -1,160 +1,0 @@ -!*************************************************************************************** -! tend_to_tke.F90 -!************* -! -! Subroutine that adds a tendency on the TKE created by the -! fluxes of momentum retrieved from the wind speed tendencies -! of the physics. -! -! The basic concept is the following: -! the TKE equation writes de/dt = -u'w' du/dz -v'w' dv/dz +g/theta dtheta/dz +...... -! -! -! We expect contributions to the term u'w' and v'w' that do not come from the Yamada -! scheme, for instance: gravity waves, drag from high vegetation..... These contributions -! need to be accounted for. -! we explicitely calculate the fluxes, integrating the wind speed -! tendency from the top of the atmospher -! -! -! -! contacts: Frederic Hourdin, Etienne Vignon -! -! History: -!--------- -! - 1st redaction, Etienne, 15/10/2016 -! Ajout des 4 sous surfaces pour la tke -! on sort l'ajout des tendances du if sur les deux cas, pour ne pas -! dupliuqer les lignes -! on enleve le pas de temps qui disprait dans les calculs -! -! -!************************************************************************************** - -!$gpum horizontal klon -MODULE tend_to_tke_mod - PRIVATE - - PUBLIC tend_to_tke - - CONTAINS - - SUBROUTINE tend_to_tke(dt,plev,exner,temp,windu,windv,dt_a,du_a,dv_a,pctsrf,tke) - - USE dimphy, ONLY: klon, klev - USE indice_sol_mod, ONLY: nbsrf - -USE yomcst_mod_h -IMPLICIT NONE - - -! Declarations -!============== - - -! Inputs -!------- - REAL dt ! Time step [s] - REAL plev(klon,klev+1) ! inter-layer pressure [Pa] - REAL temp(klon,klev) ! temperature [K], grid-cell average or for a one subsurface - REAL windu(klon,klev) ! zonal wind [m/s], grid-cell average or for a one subsurface - REAL windv(klon,klev) ! meridonal wind [m/s], grid-cell average or for a one subsurface - REAL exner(klon,klev) ! Fonction d'Exner = T/theta - REAL dt_a(klon,klev) ! Temperature tendency [K], grid-cell average or for a one subsurface - REAL du_a(klon,klev) ! Zonal wind speed tendency [m/s], grid-cell average or for a one subsurface - REAL dv_a(klon,klev) ! Meridional wind speed tendency [m/s], grid-cell average or for a one subsurface - REAL pctsrf(klon,nbsrf) ! Turbulent Kinetic energy [m2/s2], grid-cell average or for a subsurface - -! Inputs/Outputs -!--------------- - REAL tke(klon,klev+1,nbsrf+1) ! Turbulent Kinetic energy [m2/s2], grid-cell average or for a subsurface - - -! Local -!------- - - - INTEGER i,k,isrf ! indices - REAL masse(klon,klev) ! mass in the layers [kg/m2] - REAL unsmasse(klon,klev+1) ! linear mass in the layers [kg/m2] - REAL flux_rhotw(klon,klev+1) ! flux massique de tempe. pot. rho*u'*theta' - REAL flux_rhouw(klon,klev+1) ! flux massique de quantit?? de mouvement rho*u'*w' [kg/m/s2] - REAL flux_rhovw(klon,klev+1) ! flux massique de quantit?? de mouvement rho*v'*w' [kg/m/s2] - REAL tendt(klon,klev) ! new temperature tke tendency [m2/s2/s] - REAL tendu(klon,klev) ! new zonal tke tendency [m2/s2/s] - REAL tendv(klon,klev) ! new meridonal tke tendency [m2/s2/s] - - - - -! First calculations: -!===================== - - unsmasse(:,:)=0. - DO k=1,klev - masse(:,k)=(plev(:,k)-plev(:,k+1))/RG - unsmasse(:,k)=unsmasse(:,k)+0.5/masse(:,k) - unsmasse(:,k+1)=unsmasse(:,k+1)+0.5/masse(:,k) - END DO - - tendu(:,:)=0.0 - tendv(:,:)=0.0 - -! Method 1: Calculation of fluxes using a downward integration -!============================================================ - - - -! Flux calculation - - flux_rhotw(:,klev+1)=0. - flux_rhouw(:,klev+1)=0. - flux_rhovw(:,klev+1)=0. - - DO k=klev,1,-1 - flux_rhotw(:,k)=flux_rhotw(:,k+1)+masse(:,k)*dt_a(:,k)/exner(:,k) - flux_rhouw(:,k)=flux_rhouw(:,k+1)+masse(:,k)*du_a(:,k) - flux_rhovw(:,k)=flux_rhovw(:,k+1)+masse(:,k)*dv_a(:,k) - ENDDO - - -! TKE update: - - DO k=2,klev - tendt(:,k)=-flux_rhotw(:,k)*(exner(:,k)-exner(:,k-1))*unsmasse(:,k)*RCPD - tendu(:,k)=-flux_rhouw(:,k)*(windu(:,k)-windu(:,k-1))*unsmasse(:,k) - tendv(:,k)=-flux_rhovw(:,k)*(windv(:,k)-windv(:,k-1))*unsmasse(:,k) - ENDDO - tendt(:,1)=-flux_rhotw(:,1)*(exner(:,1)-1.)*unsmasse(:,1)*RCPD - tendu(:,1)=-1.*flux_rhouw(:,1)*windu(:,1)*unsmasse(:,1) - tendv(:,1)=-1.*flux_rhovw(:,1)*windv(:,1)*unsmasse(:,1) - - - DO isrf=1,nbsrf - DO k=1,klev - DO i=1,klon - IF (pctsrf(i,isrf)>0.) THEN - tke(i,k,isrf)= tke(i,k,isrf)+tendu(i,k)+tendv(i,k)+tendt(i,k) - tke(i,k,isrf)= max(tke(i,k,isrf),1.e-10) - ENDIF - ENDDO - ENDDO - ENDDO - - -! IF (klon==1) THEN -! CALL iophys_ecrit('u',klev,'u','',windu) -! CALL iophys_ecrit('v',klev,'v','',windu) -! CALL iophys_ecrit('t',klev,'t','',temp) -! CALL iophys_ecrit('tke1',klev,'tke1','',tke(:,1:klev,1)) -! CALL iophys_ecrit('tke2',klev,'tke2','',tke(:,1:klev,2)) -! CALL iophys_ecrit('tke3',klev,'tke3','',tke(:,1:klev,3)) -! CALL iophys_ecrit('tke4',klev,'tke4','',tke(:,1:klev,4)) -! CALL iophys_ecrit('theta',klev,'theta','',temp/exner) -! CALL iophys_ecrit('Duv',klev,'Duv','',tendu(:,1:klev)+tendv(:,1:klev)) -! CALL iophys_ecrit('Dt',klev,'Dt','',tendt(:,1:klev)) -! ENDIF - - END SUBROUTINE tend_to_tke - -END MODULE tend_to_tke_mod Index: LMDZ6/trunk/libf/phylmd/tend_to_tke_mod.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/tend_to_tke_mod.f90 (revision 6048) +++ LMDZ6/trunk/libf/phylmd/tend_to_tke_mod.f90 (revision 6048) @@ -0,0 +1,160 @@ +!*************************************************************************************** +! tend_to_tke.F90 +!************* +! +! Subroutine that adds a tendency on the TKE created by the +! fluxes of momentum retrieved from the wind speed tendencies +! of the physics. +! +! The basic concept is the following: +! the TKE equation writes de/dt = -u'w' du/dz -v'w' dv/dz +g/theta dtheta/dz +...... +! +! +! We expect contributions to the term u'w' and v'w' that do not come from the Yamada +! scheme, for instance: gravity waves, drag from high vegetation..... These contributions +! need to be accounted for. +! we explicitely calculate the fluxes, integrating the wind speed +! tendency from the top of the atmospher +! +! +! +! contacts: Frederic Hourdin, Etienne Vignon +! +! History: +!--------- +! - 1st redaction, Etienne, 15/10/2016 +! Ajout des 4 sous surfaces pour la tke +! on sort l'ajout des tendances du if sur les deux cas, pour ne pas +! dupliuqer les lignes +! on enleve le pas de temps qui disprait dans les calculs +! +! +!************************************************************************************** + +!$gpum horizontal klon +MODULE tend_to_tke_mod + PRIVATE + + PUBLIC tend_to_tke + + CONTAINS + + SUBROUTINE tend_to_tke(dt,plev,exner,temp,windu,windv,dt_a,du_a,dv_a,pctsrf,tke) + + USE dimphy, ONLY: klon, klev + USE indice_sol_mod, ONLY: nbsrf + +USE yomcst_mod_h +IMPLICIT NONE + + +! Declarations +!============== + + +! Inputs +!------- + REAL dt ! Time step [s] + REAL plev(klon,klev+1) ! inter-layer pressure [Pa] + REAL temp(klon,klev) ! temperature [K], grid-cell average or for a one subsurface + REAL windu(klon,klev) ! zonal wind [m/s], grid-cell average or for a one subsurface + REAL windv(klon,klev) ! meridonal wind [m/s], grid-cell average or for a one subsurface + REAL exner(klon,klev) ! Fonction d'Exner = T/theta + REAL dt_a(klon,klev) ! Temperature tendency [K], grid-cell average or for a one subsurface + REAL du_a(klon,klev) ! Zonal wind speed tendency [m/s], grid-cell average or for a one subsurface + REAL dv_a(klon,klev) ! Meridional wind speed tendency [m/s], grid-cell average or for a one subsurface + REAL pctsrf(klon,nbsrf) ! Turbulent Kinetic energy [m2/s2], grid-cell average or for a subsurface + +! Inputs/Outputs +!--------------- + REAL tke(klon,klev+1,nbsrf+1) ! Turbulent Kinetic energy [m2/s2], grid-cell average or for a subsurface + + +! Local +!------- + + + INTEGER i,k,isrf ! indices + REAL masse(klon,klev) ! mass in the layers [kg/m2] + REAL unsmasse(klon,klev+1) ! linear mass in the layers [kg/m2] + REAL flux_rhotw(klon,klev+1) ! flux massique de tempe. pot. rho*u'*theta' + REAL flux_rhouw(klon,klev+1) ! flux massique de quantit?? de mouvement rho*u'*w' [kg/m/s2] + REAL flux_rhovw(klon,klev+1) ! flux massique de quantit?? de mouvement rho*v'*w' [kg/m/s2] + REAL tendt(klon,klev) ! new temperature tke tendency [m2/s2/s] + REAL tendu(klon,klev) ! new zonal tke tendency [m2/s2/s] + REAL tendv(klon,klev) ! new meridonal tke tendency [m2/s2/s] + + + + +! First calculations: +!===================== + + unsmasse(:,:)=0. + DO k=1,klev + masse(:,k)=(plev(:,k)-plev(:,k+1))/RG + unsmasse(:,k)=unsmasse(:,k)+0.5/masse(:,k) + unsmasse(:,k+1)=unsmasse(:,k+1)+0.5/masse(:,k) + END DO + + tendu(:,:)=0.0 + tendv(:,:)=0.0 + +! Method 1: Calculation of fluxes using a downward integration +!============================================================ + + + +! Flux calculation + + flux_rhotw(:,klev+1)=0. + flux_rhouw(:,klev+1)=0. + flux_rhovw(:,klev+1)=0. + + DO k=klev,1,-1 + flux_rhotw(:,k)=flux_rhotw(:,k+1)+masse(:,k)*dt_a(:,k)/exner(:,k) + flux_rhouw(:,k)=flux_rhouw(:,k+1)+masse(:,k)*du_a(:,k) + flux_rhovw(:,k)=flux_rhovw(:,k+1)+masse(:,k)*dv_a(:,k) + ENDDO + + +! TKE update: + + DO k=2,klev + tendt(:,k)=-flux_rhotw(:,k)*(exner(:,k)-exner(:,k-1))*unsmasse(:,k)*RCPD + tendu(:,k)=-flux_rhouw(:,k)*(windu(:,k)-windu(:,k-1))*unsmasse(:,k) + tendv(:,k)=-flux_rhovw(:,k)*(windv(:,k)-windv(:,k-1))*unsmasse(:,k) + ENDDO + tendt(:,1)=-flux_rhotw(:,1)*(exner(:,1)-1.)*unsmasse(:,1)*RCPD + tendu(:,1)=-1.*flux_rhouw(:,1)*windu(:,1)*unsmasse(:,1) + tendv(:,1)=-1.*flux_rhovw(:,1)*windv(:,1)*unsmasse(:,1) + + + DO isrf=1,nbsrf + DO k=1,klev + DO i=1,klon + IF (pctsrf(i,isrf)>0.) THEN + tke(i,k,isrf)= tke(i,k,isrf)+tendu(i,k)+tendv(i,k)+tendt(i,k) + tke(i,k,isrf)= max(tke(i,k,isrf),1.e-10) + ENDIF + ENDDO + ENDDO + ENDDO + + +! IF (klon==1) THEN +! CALL iophys_ecrit('u',klev,'u','',windu) +! CALL iophys_ecrit('v',klev,'v','',windu) +! CALL iophys_ecrit('t',klev,'t','',temp) +! CALL iophys_ecrit('tke1',klev,'tke1','',tke(:,1:klev,1)) +! CALL iophys_ecrit('tke2',klev,'tke2','',tke(:,1:klev,2)) +! CALL iophys_ecrit('tke3',klev,'tke3','',tke(:,1:klev,3)) +! CALL iophys_ecrit('tke4',klev,'tke4','',tke(:,1:klev,4)) +! CALL iophys_ecrit('theta',klev,'theta','',temp/exner) +! CALL iophys_ecrit('Duv',klev,'Duv','',tendu(:,1:klev)+tendv(:,1:klev)) +! CALL iophys_ecrit('Dt',klev,'Dt','',tendt(:,1:klev)) +! ENDIF + + END SUBROUTINE tend_to_tke + +END MODULE tend_to_tke_mod Index: LMDZ6/trunk/libf/phylmd/transp.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/transp.f90 (revision 6047) +++ (revision ) @@ -1,69 +1,0 @@ - -! $Id$ -!$gpum horizontal klon -MODULE transp_mod - - PRIVATE - - PUBLIC transp - - CONTAINS - -SUBROUTINE transp(paprs, tsol, t, q, ql, qs, u, v, geom, & - utran_e, vtran_e, utran_q, vtran_q, utran_w, vtran_w) - - USE dimphy - USE yomcst_mod_h -IMPLICIT NONE - ! ====================================================================== - ! Auteur(s): Z.X.Li (LMD/CNRS) - ! Date: le 25 avril 1994 - ! Objet: Calculer le transport de l'energie et de la vapeur d'eau - ! ====================================================================== - - - - !--inputs - REAL, INTENT(IN) :: paprs(klon, klev+1), tsol(klon), geom(klon, klev) - REAL, INTENT(IN) :: t(klon, klev), q(klon, klev), ql(klon, klev), qs(klon, klev) - REAL, INTENT(IN) :: u(klon, klev), v(klon, klev) - !--outputs - REAL, INTENT(OUT) :: utran_e(klon), vtran_e(klon) !--lateral flux of dry static energy (J m-1 s-1) - REAL, INTENT(OUT) :: utran_q(klon), vtran_q(klon) !--lateral flux of water vapour (kg m-1 s-1) - REAL, INTENT(OUT) :: utran_w(klon), vtran_w(klon) !--lateral flux of total water (kg m-1 s-1) - !--local variables - INTEGER i, l - REAL e, dm - ! ------------------------------------------------------------------ - - !--initialisations - utran_e(:) = 0.0 - utran_q(:) = 0.0 - vtran_e(:) = 0.0 - vtran_q(:) = 0.0 - utran_w(:) = 0.0 - vtran_w(:) = 0.0 - - !--vertical integration of diagnostics - DO l = 1, klev - DO i = 1, klon - dm= (paprs(i,l)-paprs(i,l+1))/RG !--mass of layer kg m-2 - !--moist static energy -! e = rcpd*t(i, l) + rlvtt*q(i, l) + geom(i, l) - !--dry static energy - e = rcpd*t(i, l) + geom(i, l) - utran_e(i) = utran_e(i) + u(i, l)*e*dm - vtran_e(i) = vtran_e(i) + v(i, l)*e*dm - !--water vapour - utran_q(i) = utran_q(i) + u(i, l)*q(i,l)*dm - vtran_q(i) = vtran_q(i) + v(i, l)*q(i,l)*dm - !--total water - utran_w(i) = utran_w(i) + u(i, l)*(q(i,l)+ql(i,l)+qs(i,l))*dm - vtran_w(i) = vtran_w(i) + v(i, l)*(q(i,l)+ql(i,l)+qs(i,l))*dm - ENDDO - ENDDO - - RETURN -END SUBROUTINE transp - -END MODULE transp_mod Index: LMDZ6/trunk/libf/phylmd/transp_mod.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/transp_mod.f90 (revision 6048) +++ LMDZ6/trunk/libf/phylmd/transp_mod.f90 (revision 6048) @@ -0,0 +1,69 @@ + +! $Id$ +!$gpum horizontal klon +MODULE transp_mod + + PRIVATE + + PUBLIC transp + + CONTAINS + +SUBROUTINE transp(paprs, tsol, t, q, ql, qs, u, v, geom, & + utran_e, vtran_e, utran_q, vtran_q, utran_w, vtran_w) + + USE dimphy + USE yomcst_mod_h +IMPLICIT NONE + ! ====================================================================== + ! Auteur(s): Z.X.Li (LMD/CNRS) + ! Date: le 25 avril 1994 + ! Objet: Calculer le transport de l'energie et de la vapeur d'eau + ! ====================================================================== + + + + !--inputs + REAL, INTENT(IN) :: paprs(klon, klev+1), tsol(klon), geom(klon, klev) + REAL, INTENT(IN) :: t(klon, klev), q(klon, klev), ql(klon, klev), qs(klon, klev) + REAL, INTENT(IN) :: u(klon, klev), v(klon, klev) + !--outputs + REAL, INTENT(OUT) :: utran_e(klon), vtran_e(klon) !--lateral flux of dry static energy (J m-1 s-1) + REAL, INTENT(OUT) :: utran_q(klon), vtran_q(klon) !--lateral flux of water vapour (kg m-1 s-1) + REAL, INTENT(OUT) :: utran_w(klon), vtran_w(klon) !--lateral flux of total water (kg m-1 s-1) + !--local variables + INTEGER i, l + REAL e, dm + ! ------------------------------------------------------------------ + + !--initialisations + utran_e(:) = 0.0 + utran_q(:) = 0.0 + vtran_e(:) = 0.0 + vtran_q(:) = 0.0 + utran_w(:) = 0.0 + vtran_w(:) = 0.0 + + !--vertical integration of diagnostics + DO l = 1, klev + DO i = 1, klon + dm= (paprs(i,l)-paprs(i,l+1))/RG !--mass of layer kg m-2 + !--moist static energy +! e = rcpd*t(i, l) + rlvtt*q(i, l) + geom(i, l) + !--dry static energy + e = rcpd*t(i, l) + geom(i, l) + utran_e(i) = utran_e(i) + u(i, l)*e*dm + vtran_e(i) = vtran_e(i) + v(i, l)*e*dm + !--water vapour + utran_q(i) = utran_q(i) + u(i, l)*q(i,l)*dm + vtran_q(i) = vtran_q(i) + v(i, l)*q(i,l)*dm + !--total water + utran_w(i) = utran_w(i) + u(i, l)*(q(i,l)+ql(i,l)+qs(i,l))*dm + vtran_w(i) = vtran_w(i) + v(i, l)*(q(i,l)+ql(i,l)+qs(i,l))*dm + ENDDO + ENDDO + + RETURN +END SUBROUTINE transp + +END MODULE transp_mod Index: LMDZ6/trunk/libf/phylmd/ustarhb.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ustarhb.f90 (revision 6047) +++ (revision ) @@ -1,49 +1,0 @@ - -! $Header$ -MODULE ustarhb_mod - -CONTAINS - -SUBROUTINE ustarhb(klon, klev, knon, u, v, cd_m, ustar) -!$gpum horizontal knon klon - IMPLICIT NONE - ! ====================================================================== - ! Laurent Li (LMD/CNRS), le 30 septembre 1998 - ! Couche limite non-locale. Adaptation du code du CCM3. - ! Code non teste, donc a ne pas utiliser. - ! ====================================================================== - ! Nonlocal scheme that determines eddy diffusivities based on a - ! diagnosed boundary layer height and a turbulent velocity scale. - ! Also countergradient effects for heat and moisture are included. - - ! For more information, see Holtslag, A.A.M., and B.A. Boville, 1993: - ! Local versus nonlocal boundary-layer diffusion in a global climate - ! model. J. of Climate, vol. 6, 1825-1842. - ! ====================================================================== - - ! Arguments: - - INTEGER, INTENT(IN) :: klon, klev, knon ! nombre de points a calculer - REAL, DIMENSION(klon, klev), INTENT(IN) :: u,v ! vent horizontal (m/s) - REAL, DIMENSION(klon), INTENT(IN) :: cd_m ! coefficient de friction au sol pour vitesse - REAL, DIMENSION(klon), INTENT(OUT) :: ustar - - INTEGER :: i, k - REAL :: zxt, zxq, zxu, zxv, zxmod, taux, tauy - REAL :: zx_alf1, zx_alf2 ! parametres pour extrapolation - - DO i = 1, knon - zx_alf1 = 1.0 - zx_alf2 = 1.0 - zx_alf1 - zxu = u(i, 1)*zx_alf1 + u(i, 2)*zx_alf2 - zxv = v(i, 1)*zx_alf1 + v(i, 2)*zx_alf2 - zxmod = 1.0 + sqrt(zxu**2+zxv**2) - taux = zxu*zxmod*cd_m(i) - tauy = zxv*zxmod*cd_m(i) - ustar(i) = sqrt(taux**2+tauy**2) - END DO - - RETURN -END SUBROUTINE ustarhb - -END MODULE ustarhb_mod Index: LMDZ6/trunk/libf/phylmd/ustarhb_mod.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/ustarhb_mod.f90 (revision 6048) +++ LMDZ6/trunk/libf/phylmd/ustarhb_mod.f90 (revision 6048) @@ -0,0 +1,49 @@ + +! $Header$ +MODULE ustarhb_mod + +CONTAINS + +SUBROUTINE ustarhb(klon, klev, knon, u, v, cd_m, ustar) +!$gpum horizontal knon klon + IMPLICIT NONE + ! ====================================================================== + ! Laurent Li (LMD/CNRS), le 30 septembre 1998 + ! Couche limite non-locale. Adaptation du code du CCM3. + ! Code non teste, donc a ne pas utiliser. + ! ====================================================================== + ! Nonlocal scheme that determines eddy diffusivities based on a + ! diagnosed boundary layer height and a turbulent velocity scale. + ! Also countergradient effects for heat and moisture are included. + + ! For more information, see Holtslag, A.A.M., and B.A. Boville, 1993: + ! Local versus nonlocal boundary-layer diffusion in a global climate + ! model. J. of Climate, vol. 6, 1825-1842. + ! ====================================================================== + + ! Arguments: + + INTEGER, INTENT(IN) :: klon, klev, knon ! nombre de points a calculer + REAL, DIMENSION(klon, klev), INTENT(IN) :: u,v ! vent horizontal (m/s) + REAL, DIMENSION(klon), INTENT(IN) :: cd_m ! coefficient de friction au sol pour vitesse + REAL, DIMENSION(klon), INTENT(OUT) :: ustar + + INTEGER :: i, k + REAL :: zxt, zxq, zxu, zxv, zxmod, taux, tauy + REAL :: zx_alf1, zx_alf2 ! parametres pour extrapolation + + DO i = 1, knon + zx_alf1 = 1.0 + zx_alf2 = 1.0 - zx_alf1 + zxu = u(i, 1)*zx_alf1 + u(i, 2)*zx_alf2 + zxv = v(i, 1)*zx_alf1 + v(i, 2)*zx_alf2 + zxmod = 1.0 + sqrt(zxu**2+zxv**2) + taux = zxu*zxmod*cd_m(i) + tauy = zxv*zxmod*cd_m(i) + ustar(i) = sqrt(taux**2+tauy**2) + END DO + + RETURN +END SUBROUTINE ustarhb + +END MODULE ustarhb_mod Index: LMDZ6/trunk/libf/phylmd/vdif_kcay.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/vdif_kcay.f90 (revision 6047) +++ (revision ) @@ -1,680 +1,0 @@ -! $Header$ -MODULE vdif_kcay_mod - -CONTAINS - -SUBROUTINE vdif_kcay(klon,klev,ngrid,dt, g, rconst, plev, temp, zlev, zlay, u, v, & - teta, cd, q2, q2diag, km, kn, ustar, l_mix) - -!$gpum horizontal ngrid klon - - IMPLICIT NONE - - ! dt : pas de temps - ! g : g - ! zlev : altitude a chaque niveau (interface inferieure de la couche - ! de meme indice) - ! zlay : altitude au centre de chaque couche - ! u,v : vitesse au centre de chaque couche - ! (en entree : la valeur au debut du pas de temps) - ! teta : temperature potentielle au centre de chaque couche - ! (en entree : la valeur au debut du pas de temps) - ! cd : cdrag - ! (en entree : la valeur au debut du pas de temps) - ! q2 : $q^2$ au bas de chaque couche - ! (en entree : la valeur au debut du pas de temps) - ! (en sortie : la valeur a la fin du pas de temps) - ! km : diffusivite turbulente de quantite de mouvement (au bas de chaque - ! couche) - ! (en sortie : la valeur a la fin du pas de temps) - ! kn : diffusivite turbulente des scalaires (au bas de chaque couche) - ! (en sortie : la valeur a la fin du pas de temps) - - ! ....................................................................... - INTEGER, INTENT(IN) :: klon,klev,ngrid - REAL,INTENT(IN) :: dt, g, rconst - REAL,DIMENSION(klon,klev+1),INTENT(IN) :: plev - REAL,DIMENSION(klon,klev),INTENT(IN) :: temp - REAL,DIMENSION(klon),INTENT(IN) :: ustar - REAL,DIMENSION(klon,klev+1),INTENT(INOUT) :: zlev - REAL,DIMENSION(klon,klev),INTENT(IN) :: zlay - REAL,DIMENSION(klon,klev),INTENT(IN) :: u - REAL,DIMENSION(klon,klev),INTENT(IN) :: v - REAL,DIMENSION(klon,klev),INTENT(IN) :: teta - REAL,DIMENSION(klon),INTENT(IN) :: cd - REAL,DIMENSION(klon,klev+1),INTENT(INOUT) :: q2 - REAL,DIMENSION(klon,klev+1),INTENT(OUT) :: q2diag - REAL,DIMENSION(klon,klev+1),INTENT(OUT) :: km - REAL,DIMENSION(klon,klev+1),INTENT(OUT) :: kn - INTEGER, INTENT(OUT) :: l_mix - - REAL,DIMENSION(klon) :: sq, sqz, long0 - REAL,DIMENSION(klon,klev+1) :: q2s,zz - REAL :: snstable,zq - - INTEGER :: iii - ! ....................................................................... - - ! nlay : nombre de couches - ! nlev : nombre de niveaux - ! ngrid : nombre de points de grille - ! unsdz : 1 sur l'epaisseur de couche - ! unsdzdec : 1 sur la distance entre le centre de la couche et le - ! centre de la couche inferieure - ! q : echelle de vitesse au bas de chaque couche - ! (valeur a la fin du pas de temps) - - ! ....................................................................... - INTEGER :: nlay, nlev - REAL, DIMENSION(klon,klev) :: unsdz - REAL, DIMENSION(klon, klev+1) :: unsdzdec,q - - ! ....................................................................... - - ! kmpre : km au debut du pas de temps - ! qcstat : q : solution stationnaire du probleme couple - ! (valeur a la fin du pas de temps) - ! q2cstat : q2 : solution stationnaire du probleme couple - ! (valeur a la fin du pas de temps) - - ! ....................................................................... - REAL, DIMENSION(klon, klev+1) :: kmpre - REAL :: qcstat - REAL :: q2cstat - REAL :: sss, sssq - ! ....................................................................... - - ! long : longueur de melange calculee selon Blackadar - - ! ....................................................................... - REAL, DIMENSION(klon, klev+1) :: long - ! ....................................................................... - - ! kmq3 : terme en q^3 dans le developpement de km - ! (valeur au debut du pas de temps) - ! kmcstat : valeur de km solution stationnaire du systeme {q2 ; du/dz} - ! (valeur a la fin du pas de temps) - ! knq3 : terme en q^3 dans le developpement de kn - ! mcstat : valeur de m solution stationnaire du systeme {q2 ; du/dz} - ! (valeur a la fin du pas de temps) - ! m2cstat : valeur de m2 solution stationnaire du systeme {q2 ; du/dz} - ! (valeur a la fin du pas de temps) - ! m : valeur a la fin du pas de temps - ! mpre : valeur au debut du pas de temps - ! m2 : valeur a la fin du pas de temps - ! n2 : valeur a la fin du pas de temps - - ! ....................................................................... - REAL :: kmq3 - REAL :: kmcstat - REAL :: knq3 - REAL :: mcstat - REAL :: m2cstat - REAL, DIMENSION(klon, klev+1) :: m,mpre,m2,n2 - ! ....................................................................... - - ! gn : intermediaire pour les coefficients de stabilite - ! gnmin : borne inferieure de gn (-0.23 ou -0.28) - ! gnmax : borne superieure de gn (0.0233) - ! gninf : vrai si gn est en dessous de sa borne inferieure - ! gnsup : vrai si gn est en dessus de sa borne superieure - ! gm : drole d'objet bien utile - ! ri : nombre de Richardson - ! sn : coefficient de stabilite pour n - ! snq2 : premier terme du developement limite de sn en q2 - ! sm : coefficient de stabilite pour m - ! smq2 : premier terme du developement limite de sm en q2 - - ! ....................................................................... - REAL :: gn,gm - REAL :: gnmin - REAL :: gnmax - LOGICAL :: gninf - LOGICAL :: gnsup - REAL, DIMENSION(klon, klev+1) :: sn, snq2, sm, smq2 - ! ....................................................................... - - ! kappa : consatnte de Von Karman (0.4) - ! long00 : longueur de reference pour le calcul de long (160) - ! a1,a2,b1,b2,c1 : constantes d'origine pour les coefficients - ! de stabilite (0.92/0.74/16.6/10.1/0.08) - ! cn1,cn2 : constantes pour sn - ! cm1,cm2,cm3,cm4 : constantes pour sm - - ! ....................................................................... - REAL :: kappa - REAL :: long00 - REAL :: a1, a2, b1, b2, c1 - REAL :: cn1, cn2 - REAL :: cm1, cm2, cm3, cm4 - ! ....................................................................... - - ! termq : termes en $q$ dans l'equation de q2 - ! termq3 : termes en $q^3$ dans l'equation de q2 - ! termqm2 : termes en $q*m^2$ dans l'equation de q2 - ! termq3m2 : termes en $q^3*m^2$ dans l'equation de q2 - - ! ....................................................................... - REAL :: termq - REAL :: termq3 - REAL :: termqm2 - REAL :: termq3m2 - ! ....................................................................... - - ! q2min : borne inferieure de q2 - ! q2max : borne superieure de q2 - - ! ....................................................................... - REAL :: q2min - REAL :: q2max - ! ....................................................................... - ! knmin : borne inferieure de kn - ! kmmin : borne inferieure de km - ! ....................................................................... - REAL :: knmin - REAL :: kmmin - ! ....................................................................... - INTEGER :: ilay, ilev, igrid - REAL :: tmp1, tmp2 - ! ....................................................................... - PARAMETER (kappa=0.4E+0) - PARAMETER (long00=160.E+0) - ! PARAMETER (gnmin=-10.E+0) - PARAMETER (gnmin=-0.28) - PARAMETER (gnmax=0.0233E+0) - PARAMETER (a1=0.92E+0) - PARAMETER (a2=0.74E+0) - PARAMETER (b1=16.6E+0) - PARAMETER (b2=10.1E+0) - PARAMETER (c1=0.08E+0) - PARAMETER (knmin=1.E-5) - PARAMETER (kmmin=1.E-5) - PARAMETER (q2min=1.E-5) - PARAMETER (q2max=1.E+2) - ! ym PARAMETER (nlay=klev) - ! ym PARAMETER (nlev=klev+1) - - PARAMETER (cn1=a2*(1.E+0-6.E+0*a1/b1)) - PARAMETER (cn2=-3.E+0*a2*(6.E+0*a1+b2)) - PARAMETER (cm1=a1*(1.E+0-3.E+0*c1-6.E+0*a1/b1)) - PARAMETER (cm2=a1*(-3.E+0*a2*((b2-3.E+0*a2)*(1.E+0-6.E+0*a1/b1)- & - 3.E+0*c1*(b2+6.E+0*a1)))) - PARAMETER (cm3=-3.E+0*a2*(6.E+0*a1+b2)) - PARAMETER (cm4=-9.E+0*a1*a2) - - LOGICAL :: first -! SAVE first -! DATA first/.TRUE./ -! !$OMP THREADPRIVATE(first) - ! ....................................................................... - ! traitment des valeur de q2 en entree - ! ....................................................................... - - ! Initialisation de q2 - nlay = klev - nlev = klev + 1 - -! Initialisation avec un schema d'equilibre -! CALL yamada(ngrid, dt, g, rconst, plev, temp, zlev, zlay, u, v, teta, cd, & -! q2diag, km, kn, ustar, l_mix) -! IF (first .AND. 1==1) THEN -! first = .FALSE. -! q2 = q2diag -! END IF -q2diag=0. - - DO ilev = 2, nlay - DO igrid = 1, ngrid - q2(igrid, ilev) = amax1(q2(igrid,ilev), q2min) - q(igrid, ilev) = sqrt(q2(igrid,ilev)) - END DO - END DO - - DO igrid = 1, ngrid - tmp1 = cd(igrid)*(u(igrid,1)**2+v(igrid,1)**2) - q2(igrid, 1) = b1**(2.E+0/3.E+0)*tmp1 - q2(igrid, 1) = amax1(q2(igrid,1), q2min) - q(igrid, 1) = sqrt(q2(igrid,1)) - END DO - - ! ....................................................................... - ! les increments verticaux - ! ....................................................................... - - ! !!!!! allerte !!!!!c - ! !!!!! zlev n'est pas declare a nlev !!!!!c - ! !!!!! ----> - DO igrid = 1, ngrid - zlev(igrid, nlev) = zlay(igrid, nlay) + (zlay(igrid,nlay)-zlev(igrid,nlev & - -1)) - END DO - ! !!!!! <---- - ! !!!!! allerte !!!!!c - - DO ilay = 1, nlay - DO igrid = 1, ngrid - unsdz(igrid, ilay) = 1.E+0/(zlev(igrid,ilay+1)-zlev(igrid,ilay)) - END DO - END DO - DO igrid = 1, ngrid - unsdzdec(igrid, 1) = 1.E+0/(zlay(igrid,1)-zlev(igrid,1)) - END DO - DO ilay = 2, nlay - DO igrid = 1, ngrid - unsdzdec(igrid, ilay) = 1.E+0/(zlay(igrid,ilay)-zlay(igrid,ilay-1)) - END DO - END DO - DO igrid = 1, ngrid - unsdzdec(igrid, nlay+1) = 1.E+0/(zlev(igrid,nlay+1)-zlay(igrid,nlay)) - END DO - - ! ....................................................................... - ! le cisaillement et le gradient de temperature - ! ....................................................................... - - DO igrid = 1, ngrid - m2(igrid, 1) = (unsdzdec(igrid,1)*u(igrid,1))**2 + & - (unsdzdec(igrid,1)*v(igrid,1))**2 - m(igrid, 1) = sqrt(m2(igrid,1)) - mpre(igrid, 1) = m(igrid, 1) - END DO - - ! ----------------------------------------------------------------------- - DO ilev = 2, nlev - 1 - DO igrid = 1, ngrid - ! ----------------------------------------------------------------------- - - n2(igrid, ilev) = g*unsdzdec(igrid, ilev)*(teta(igrid,ilev)-teta(igrid, & - ilev-1))/(teta(igrid,ilev)+teta(igrid,ilev-1))*2.E+0 - ! n2(igrid,ilev)=0. - - ! ---> - ! on ne sais traiter que les cas stratifies. et l'ajustement - ! convectif est cense faire en sorte que seul des configurations - ! stratifiees soient rencontrees en entree de cette routine. - ! mais, bon ... on sait jamais (meme on sait que n2 prends - ! quelques valeurs negatives ... parfois) alors : - ! <--- - - IF (n2(igrid,ilev)<0.E+0) THEN - n2(igrid, ilev) = 0.E+0 - END IF - - m2(igrid, ilev) = (unsdzdec(igrid,ilev)*(u(igrid,ilev)-u(igrid, & - ilev-1)))**2 + (unsdzdec(igrid,ilev)*(v(igrid,ilev)-v(igrid, & - ilev-1)))**2 - m(igrid, ilev) = sqrt(m2(igrid,ilev)) - mpre(igrid, ilev) = m(igrid, ilev) - - ! ----------------------------------------------------------------------- - END DO - END DO - ! ----------------------------------------------------------------------- - - DO igrid = 1, ngrid - m2(igrid, nlev) = m2(igrid, nlev-1) - m(igrid, nlev) = m(igrid, nlev-1) - mpre(igrid, nlev) = m(igrid, nlev) - END DO - - ! ....................................................................... - ! calcul des fonctions de stabilite - ! ....................................................................... - - IF (l_mix==4) THEN - DO igrid = 1, ngrid - sqz(igrid) = 1.E-10 - sq(igrid) = 1.E-10 - END DO - DO ilev = 2, nlev - 1 - DO igrid = 1, ngrid - zq = sqrt(q2(igrid,ilev)) - sqz(igrid) = sqz(igrid) + zq*zlev(igrid, ilev)*(zlay(igrid,ilev)-zlay & - (igrid,ilev-1)) - sq(igrid) = sq(igrid) + zq*(zlay(igrid,ilev)-zlay(igrid,ilev-1)) - END DO - END DO - DO igrid = 1, ngrid - long0(igrid) = 0.2*sqz(igrid)/sq(igrid) - END DO - ELSE IF (l_mix==3) THEN - long0(igrid) = long00 - END IF - - ! (abd 5 2) print*,'LONG0=',long0 - - ! ----------------------------------------------------------------------- - DO ilev = 2, nlev - 1 - DO igrid = 1, ngrid - ! ----------------------------------------------------------------------- - - tmp1 = kappa*(zlev(igrid,ilev)-zlev(igrid,1)) - IF (l_mix>=10) THEN - long(igrid, ilev) = l_mix - ELSE - long(igrid, ilev) = tmp1/(1.E+0+tmp1/long0(igrid)) - END IF - long(igrid, ilev) = max(min(long(igrid,ilev),0.5*sqrt(q2(igrid,ilev))/ & - sqrt(max(n2(igrid,ilev),1.E-10))), 5.) - - gn = -long(igrid, ilev)**2/q2(igrid, ilev)*n2(igrid, ilev) - gm = long(igrid, ilev)**2/q2(igrid, ilev)*m2(igrid, ilev) - - gninf = .FALSE. - gnsup = .FALSE. - - IF (gngnmax) THEN - gnsup = .TRUE. - gn = gnmax - END IF - - sn(igrid, ilev) = cn1/(1.E+0+cn2*gn) - sm(igrid, ilev) = (cm1+cm2*gn)/((1.E+0+cm3*gn)*(1.E+0+cm4*gn)) - - IF ((gninf) .OR. (gnsup)) THEN - snq2(igrid, ilev) = 0.E+0 - smq2(igrid, ilev) = 0.E+0 - ELSE - snq2(igrid, ilev) = -gn*(-cn1*cn2/(1.E+0+cn2*gn)**2) - smq2(igrid, ilev) = -gn*(cm2*(1.E+0+cm3*gn)*(1.E+0+cm4*gn)-(cm3*( & - 1.E+0+cm4*gn)+cm4*(1.E+0+cm3*gn))*(cm1+cm2*gn))/((1.E+0+cm3*gn)*( & - 1.E+0+cm4*gn))**2 - END IF - - ! abd - ! if(ilev.le.57.and.ilev.ge.37) then - ! print*,'L=',ilev,' GN=',gn,' SM=',sm(igrid,ilev) - ! endif - ! ---> - ! la decomposition de Taylor en q2 n'a de sens que - ! dans les cas stratifies ou sn et sm sont quasi - ! proportionnels a q2. ailleurs on laisse le meme - ! algorithme car l'ajustement convectif fait le travail. - ! mais c'est delirant quand sn et snq2 n'ont pas le meme - ! signe : dans ces cas, on ne fait pas la decomposition. - ! <--- - - IF (snq2(igrid,ilev)*sn(igrid,ilev)<=0.E+0) snq2(igrid, ilev) = 0.E+0 - IF (smq2(igrid,ilev)*sm(igrid,ilev)<=0.E+0) smq2(igrid, ilev) = 0.E+0 - - ! Correction pour les couches stables. - ! Schema repris de JHoltzlag Boville, lui meme venant de... - - IF (1==1) THEN - snstable = 1. - zlev(igrid, ilev)/(700.*max(ustar(igrid),0.0001)) - snstable = 1. - zlev(igrid, ilev)/400. - snstable = max(snstable, 0.) - snstable = snstable*snstable - - ! abde print*,'SN ',ilev,sn(1,ilev),snstable - IF (sn(igrid,ilev) - DO ilev = 2, nlev - 1 - ! ----> - DO igrid = 1, ngrid - - ! ....................................................................... - - ! calcul des termes sources et puits de l'equation de q2 - ! ------------------------------------------------------ - - knq3 = kn(igrid, ilev)*snq2(igrid, ilev)/sn(igrid, ilev) - kmq3 = km(igrid, ilev)*smq2(igrid, ilev)/sm(igrid, ilev) - - termq = 0.E+0 - termq3 = 0.E+0 - termqm2 = 0.E+0 - termq3m2 = 0.E+0 - - tmp1 = dt*2.E+0*km(igrid, ilev)*m2(igrid, ilev) - tmp2 = dt*2.E+0*kmq3*m2(igrid, ilev) - termqm2 = termqm2 + dt*2.E+0*km(igrid, ilev)*m2(igrid, ilev) - & - dt*2.E+0*kmq3*m2(igrid, ilev) - termq3m2 = termq3m2 + dt*2.E+0*kmq3*m2(igrid, ilev) - - termq = termq - dt*2.E+0*kn(igrid, ilev)*n2(igrid, ilev) + & - dt*2.E+0*knq3*n2(igrid, ilev) - termq3 = termq3 - dt*2.E+0*knq3*n2(igrid, ilev) - - termq3 = termq3 - dt*2.E+0*q(igrid, ilev)**3/(b1*long(igrid,ilev)) - - ! ....................................................................... - - ! resolution stationnaire couplee avec le gradient de vitesse local - ! ----------------------------------------------------------------- - - ! -----{on cherche le cisaillement qui annule l'equation de q^2 - ! supposee en q3} - - tmp1 = termq + termq3 - tmp2 = termqm2 + termq3m2 - m2cstat = m2(igrid, ilev) - (tmp1+tmp2)/(dt*2.E+0*km(igrid,ilev)) - mcstat = sqrt(m2cstat) - - ! abde print*,'M2 L=',ilev,mpre(igrid,ilev),mcstat - - ! -----{puis on ecrit la valeur de q qui annule l'equation de m - ! supposee en q3} - - IF (ilev==2) THEN - kmcstat = 1.E+0/mcstat*(unsdz(igrid,ilev)*kmpre(igrid,ilev+1)*mpre( & - igrid,ilev+1)+unsdz(igrid,ilev-1)*cd(igrid)*(sqrt(u(igrid,3)**2+ & - v(igrid,3)**2)-mcstat/unsdzdec(igrid,ilev)-mpre(igrid, & - ilev+1)/unsdzdec(igrid,ilev+1))**2)/(unsdz(igrid,ilev)+unsdz(igrid, & - ilev-1)) - ELSE - kmcstat = 1.E+0/mcstat*(unsdz(igrid,ilev)*kmpre(igrid,ilev+1)*mpre( & - igrid,ilev+1)+unsdz(igrid,ilev-1)*kmpre(igrid,ilev-1)*mpre(igrid, & - ilev-1))/(unsdz(igrid,ilev)+unsdz(igrid,ilev-1)) - END IF - tmp2 = kmcstat/(sm(igrid,ilev)/q2(igrid,ilev))/long(igrid, ilev) - qcstat = tmp2**(1.E+0/3.E+0) - q2cstat = qcstat**2 - - ! ....................................................................... - - ! choix de la solution finale - ! --------------------------- - - q(igrid, ilev) = qcstat - q2(igrid, ilev) = q2cstat - m(igrid, ilev) = mcstat - ! abd if(ilev.le.57.and.ilev.ge.37) then - ! print*,'L=',ilev,' M2=',m2(igrid,ilev),m2cstat, - ! s 'N2=',n2(igrid,ilev) - ! abd endif - m2(igrid, ilev) = m2cstat - - ! ---> - ! pour des raisons simples q2 est minore - ! <--- - - IF (q2(igrid,ilev)gnmax) gn = gnmax - sn(igrid, ilev) = cn1/(1.E+0+cn2*gn) - sm(igrid, ilev) = (cm1+cm2*gn)/((1.E+0+cm3*gn)*(1.E+0+cm4*gn)) - kn(igrid, ilev) = long(igrid, ilev)*q(igrid, ilev)*sn(igrid, ilev) - km(igrid, ilev) = long(igrid, ilev)*q(igrid, ilev)*sm(igrid, ilev) - ! abd - ! if(ilev.le.57.and.ilev.ge.37) then - ! print*,'L=',ilev,' GN=',gn,' SM=',sm(igrid,ilev) - ! endif - - ! ....................................................................... - - END DO - - END DO - - ! ....................................................................... - - - DO igrid = 1, ngrid - kn(igrid, 1) = knmin - km(igrid, 1) = kmmin - ! kn(igrid,1)=cd(igrid) - ! km(igrid,1)=cd(igrid) - q2(igrid, nlev) = q2(igrid, nlev-1) - q(igrid, nlev) = q(igrid, nlev-1) - kn(igrid, nlev) = kn(igrid, nlev-1) - km(igrid, nlev) = km(igrid, nlev-1) - END DO - - ! CALCUL DE LA DIFFUSION VERTICALE DE Q2 - IF (1==1) THEN - - sss=0. - sssq=0. - ! WARNING : travail sur le point ig=1 ???? - DO ilev = 2, klev - 1 - sss = sss + plev(1, ilev-1) - plev(1, ilev+1) - sssq = sssq + (plev(1,ilev-1)-plev(1,ilev+1))*q2(1, ilev) - END DO - ! print*,'Q2moy avant',sssq/sss - ! print*,'Q2q20 ',(q2(1,ilev),ilev=1,10) - ! print*,'Q2km0 ',(km(1,ilev),ilev=1,10) - ! ! C'est quoi ca qu'etait dans l'original??? - ! do igrid=1,ngrid - ! q2(igrid,1)=10. - ! enddo - ! q2s=q2 - ! do iii=1,10 - ! call vdif_q2(dt,g,rconst,plev,temp,km,q2) - ! do ilev=1,klev+1 - ! write(iii+49,*) q2(1,ilev),zlev(1,ilev) - ! enddo - ! enddo - ! stop - ! do ilev=1,klev - ! print*,zlev(1,ilev),q2s(1,ilev),q2(1,ilev) - ! enddo - ! q2s=q2-q2s - ! do ilev=1,klev - ! print*,q2s(1,ilev),zlev(1,ilev) - ! enddo - DO ilev = 2, klev - 1 - sss = sss + plev(1, ilev-1) - plev(1, ilev+1) - sssq = sssq + (plev(1,ilev-1)-plev(1,ilev+1))*q2(1, ilev) - END DO - PRINT *, 'Q2moy apres', sssq/sss - - - DO ilev = 2, klev-1 - DO igrid = 1, ngrid - q2(igrid, ilev) = max(q2(igrid,ilev), q2min) - q(igrid, ilev) = sqrt(q2(igrid,ilev)) - - ! ....................................................................... - - ! calcul final de kn et km - ! ------------------------ - - gn = -long(igrid, ilev)**2/q2(igrid, ilev)*n2(igrid, ilev) - IF (gngnmax) gn = gnmax - sn(igrid, ilev) = cn1/(1.E+0+cn2*gn) - sm(igrid, ilev) = (cm1+cm2*gn)/((1.E+0+cm3*gn)*(1.E+0+cm4*gn)) - ! Correction pour les couches stables. - ! Schema repris de JHoltzlag Boville, lui meme venant de... - - IF (1==1) THEN - snstable = 1. - zlev(igrid, ilev)/(700.*max(ustar(igrid),0.0001)) - snstable = 1. - zlev(igrid, ilev)/400. - snstable = max(snstable, 0.) - snstable = snstable*snstable - - ! abde print*,'SN ',ilev,sn(1,ilev),snstable - IF (sn(igrid,ilev) + DO igrid = 1, ngrid + zlev(igrid, nlev) = zlay(igrid, nlay) + (zlay(igrid,nlay)-zlev(igrid,nlev & + -1)) + END DO + ! !!!!! <---- + ! !!!!! allerte !!!!!c + + DO ilay = 1, nlay + DO igrid = 1, ngrid + unsdz(igrid, ilay) = 1.E+0/(zlev(igrid,ilay+1)-zlev(igrid,ilay)) + END DO + END DO + DO igrid = 1, ngrid + unsdzdec(igrid, 1) = 1.E+0/(zlay(igrid,1)-zlev(igrid,1)) + END DO + DO ilay = 2, nlay + DO igrid = 1, ngrid + unsdzdec(igrid, ilay) = 1.E+0/(zlay(igrid,ilay)-zlay(igrid,ilay-1)) + END DO + END DO + DO igrid = 1, ngrid + unsdzdec(igrid, nlay+1) = 1.E+0/(zlev(igrid,nlay+1)-zlay(igrid,nlay)) + END DO + + ! ....................................................................... + ! le cisaillement et le gradient de temperature + ! ....................................................................... + + DO igrid = 1, ngrid + m2(igrid, 1) = (unsdzdec(igrid,1)*u(igrid,1))**2 + & + (unsdzdec(igrid,1)*v(igrid,1))**2 + m(igrid, 1) = sqrt(m2(igrid,1)) + mpre(igrid, 1) = m(igrid, 1) + END DO + + ! ----------------------------------------------------------------------- + DO ilev = 2, nlev - 1 + DO igrid = 1, ngrid + ! ----------------------------------------------------------------------- + + n2(igrid, ilev) = g*unsdzdec(igrid, ilev)*(teta(igrid,ilev)-teta(igrid, & + ilev-1))/(teta(igrid,ilev)+teta(igrid,ilev-1))*2.E+0 + ! n2(igrid,ilev)=0. + + ! ---> + ! on ne sais traiter que les cas stratifies. et l'ajustement + ! convectif est cense faire en sorte que seul des configurations + ! stratifiees soient rencontrees en entree de cette routine. + ! mais, bon ... on sait jamais (meme on sait que n2 prends + ! quelques valeurs negatives ... parfois) alors : + ! <--- + + IF (n2(igrid,ilev)<0.E+0) THEN + n2(igrid, ilev) = 0.E+0 + END IF + + m2(igrid, ilev) = (unsdzdec(igrid,ilev)*(u(igrid,ilev)-u(igrid, & + ilev-1)))**2 + (unsdzdec(igrid,ilev)*(v(igrid,ilev)-v(igrid, & + ilev-1)))**2 + m(igrid, ilev) = sqrt(m2(igrid,ilev)) + mpre(igrid, ilev) = m(igrid, ilev) + + ! ----------------------------------------------------------------------- + END DO + END DO + ! ----------------------------------------------------------------------- + + DO igrid = 1, ngrid + m2(igrid, nlev) = m2(igrid, nlev-1) + m(igrid, nlev) = m(igrid, nlev-1) + mpre(igrid, nlev) = m(igrid, nlev) + END DO + + ! ....................................................................... + ! calcul des fonctions de stabilite + ! ....................................................................... + + IF (l_mix==4) THEN + DO igrid = 1, ngrid + sqz(igrid) = 1.E-10 + sq(igrid) = 1.E-10 + END DO + DO ilev = 2, nlev - 1 + DO igrid = 1, ngrid + zq = sqrt(q2(igrid,ilev)) + sqz(igrid) = sqz(igrid) + zq*zlev(igrid, ilev)*(zlay(igrid,ilev)-zlay & + (igrid,ilev-1)) + sq(igrid) = sq(igrid) + zq*(zlay(igrid,ilev)-zlay(igrid,ilev-1)) + END DO + END DO + DO igrid = 1, ngrid + long0(igrid) = 0.2*sqz(igrid)/sq(igrid) + END DO + ELSE IF (l_mix==3) THEN + long0(igrid) = long00 + END IF + + ! (abd 5 2) print*,'LONG0=',long0 + + ! ----------------------------------------------------------------------- + DO ilev = 2, nlev - 1 + DO igrid = 1, ngrid + ! ----------------------------------------------------------------------- + + tmp1 = kappa*(zlev(igrid,ilev)-zlev(igrid,1)) + IF (l_mix>=10) THEN + long(igrid, ilev) = l_mix + ELSE + long(igrid, ilev) = tmp1/(1.E+0+tmp1/long0(igrid)) + END IF + long(igrid, ilev) = max(min(long(igrid,ilev),0.5*sqrt(q2(igrid,ilev))/ & + sqrt(max(n2(igrid,ilev),1.E-10))), 5.) + + gn = -long(igrid, ilev)**2/q2(igrid, ilev)*n2(igrid, ilev) + gm = long(igrid, ilev)**2/q2(igrid, ilev)*m2(igrid, ilev) + + gninf = .FALSE. + gnsup = .FALSE. + + IF (gngnmax) THEN + gnsup = .TRUE. + gn = gnmax + END IF + + sn(igrid, ilev) = cn1/(1.E+0+cn2*gn) + sm(igrid, ilev) = (cm1+cm2*gn)/((1.E+0+cm3*gn)*(1.E+0+cm4*gn)) + + IF ((gninf) .OR. (gnsup)) THEN + snq2(igrid, ilev) = 0.E+0 + smq2(igrid, ilev) = 0.E+0 + ELSE + snq2(igrid, ilev) = -gn*(-cn1*cn2/(1.E+0+cn2*gn)**2) + smq2(igrid, ilev) = -gn*(cm2*(1.E+0+cm3*gn)*(1.E+0+cm4*gn)-(cm3*( & + 1.E+0+cm4*gn)+cm4*(1.E+0+cm3*gn))*(cm1+cm2*gn))/((1.E+0+cm3*gn)*( & + 1.E+0+cm4*gn))**2 + END IF + + ! abd + ! if(ilev.le.57.and.ilev.ge.37) then + ! print*,'L=',ilev,' GN=',gn,' SM=',sm(igrid,ilev) + ! endif + ! ---> + ! la decomposition de Taylor en q2 n'a de sens que + ! dans les cas stratifies ou sn et sm sont quasi + ! proportionnels a q2. ailleurs on laisse le meme + ! algorithme car l'ajustement convectif fait le travail. + ! mais c'est delirant quand sn et snq2 n'ont pas le meme + ! signe : dans ces cas, on ne fait pas la decomposition. + ! <--- + + IF (snq2(igrid,ilev)*sn(igrid,ilev)<=0.E+0) snq2(igrid, ilev) = 0.E+0 + IF (smq2(igrid,ilev)*sm(igrid,ilev)<=0.E+0) smq2(igrid, ilev) = 0.E+0 + + ! Correction pour les couches stables. + ! Schema repris de JHoltzlag Boville, lui meme venant de... + + IF (1==1) THEN + snstable = 1. - zlev(igrid, ilev)/(700.*max(ustar(igrid),0.0001)) + snstable = 1. - zlev(igrid, ilev)/400. + snstable = max(snstable, 0.) + snstable = snstable*snstable + + ! abde print*,'SN ',ilev,sn(1,ilev),snstable + IF (sn(igrid,ilev) + DO ilev = 2, nlev - 1 + ! ----> + DO igrid = 1, ngrid + + ! ....................................................................... + + ! calcul des termes sources et puits de l'equation de q2 + ! ------------------------------------------------------ + + knq3 = kn(igrid, ilev)*snq2(igrid, ilev)/sn(igrid, ilev) + kmq3 = km(igrid, ilev)*smq2(igrid, ilev)/sm(igrid, ilev) + + termq = 0.E+0 + termq3 = 0.E+0 + termqm2 = 0.E+0 + termq3m2 = 0.E+0 + + tmp1 = dt*2.E+0*km(igrid, ilev)*m2(igrid, ilev) + tmp2 = dt*2.E+0*kmq3*m2(igrid, ilev) + termqm2 = termqm2 + dt*2.E+0*km(igrid, ilev)*m2(igrid, ilev) - & + dt*2.E+0*kmq3*m2(igrid, ilev) + termq3m2 = termq3m2 + dt*2.E+0*kmq3*m2(igrid, ilev) + + termq = termq - dt*2.E+0*kn(igrid, ilev)*n2(igrid, ilev) + & + dt*2.E+0*knq3*n2(igrid, ilev) + termq3 = termq3 - dt*2.E+0*knq3*n2(igrid, ilev) + + termq3 = termq3 - dt*2.E+0*q(igrid, ilev)**3/(b1*long(igrid,ilev)) + + ! ....................................................................... + + ! resolution stationnaire couplee avec le gradient de vitesse local + ! ----------------------------------------------------------------- + + ! -----{on cherche le cisaillement qui annule l'equation de q^2 + ! supposee en q3} + + tmp1 = termq + termq3 + tmp2 = termqm2 + termq3m2 + m2cstat = m2(igrid, ilev) - (tmp1+tmp2)/(dt*2.E+0*km(igrid,ilev)) + mcstat = sqrt(m2cstat) + + ! abde print*,'M2 L=',ilev,mpre(igrid,ilev),mcstat + + ! -----{puis on ecrit la valeur de q qui annule l'equation de m + ! supposee en q3} + + IF (ilev==2) THEN + kmcstat = 1.E+0/mcstat*(unsdz(igrid,ilev)*kmpre(igrid,ilev+1)*mpre( & + igrid,ilev+1)+unsdz(igrid,ilev-1)*cd(igrid)*(sqrt(u(igrid,3)**2+ & + v(igrid,3)**2)-mcstat/unsdzdec(igrid,ilev)-mpre(igrid, & + ilev+1)/unsdzdec(igrid,ilev+1))**2)/(unsdz(igrid,ilev)+unsdz(igrid, & + ilev-1)) + ELSE + kmcstat = 1.E+0/mcstat*(unsdz(igrid,ilev)*kmpre(igrid,ilev+1)*mpre( & + igrid,ilev+1)+unsdz(igrid,ilev-1)*kmpre(igrid,ilev-1)*mpre(igrid, & + ilev-1))/(unsdz(igrid,ilev)+unsdz(igrid,ilev-1)) + END IF + tmp2 = kmcstat/(sm(igrid,ilev)/q2(igrid,ilev))/long(igrid, ilev) + qcstat = tmp2**(1.E+0/3.E+0) + q2cstat = qcstat**2 + + ! ....................................................................... + + ! choix de la solution finale + ! --------------------------- + + q(igrid, ilev) = qcstat + q2(igrid, ilev) = q2cstat + m(igrid, ilev) = mcstat + ! abd if(ilev.le.57.and.ilev.ge.37) then + ! print*,'L=',ilev,' M2=',m2(igrid,ilev),m2cstat, + ! s 'N2=',n2(igrid,ilev) + ! abd endif + m2(igrid, ilev) = m2cstat + + ! ---> + ! pour des raisons simples q2 est minore + ! <--- + + IF (q2(igrid,ilev)gnmax) gn = gnmax + sn(igrid, ilev) = cn1/(1.E+0+cn2*gn) + sm(igrid, ilev) = (cm1+cm2*gn)/((1.E+0+cm3*gn)*(1.E+0+cm4*gn)) + kn(igrid, ilev) = long(igrid, ilev)*q(igrid, ilev)*sn(igrid, ilev) + km(igrid, ilev) = long(igrid, ilev)*q(igrid, ilev)*sm(igrid, ilev) + ! abd + ! if(ilev.le.57.and.ilev.ge.37) then + ! print*,'L=',ilev,' GN=',gn,' SM=',sm(igrid,ilev) + ! endif + + ! ....................................................................... + + END DO + + END DO + + ! ....................................................................... + + + DO igrid = 1, ngrid + kn(igrid, 1) = knmin + km(igrid, 1) = kmmin + ! kn(igrid,1)=cd(igrid) + ! km(igrid,1)=cd(igrid) + q2(igrid, nlev) = q2(igrid, nlev-1) + q(igrid, nlev) = q(igrid, nlev-1) + kn(igrid, nlev) = kn(igrid, nlev-1) + km(igrid, nlev) = km(igrid, nlev-1) + END DO + + ! CALCUL DE LA DIFFUSION VERTICALE DE Q2 + IF (1==1) THEN + + sss=0. + sssq=0. + ! WARNING : travail sur le point ig=1 ???? + DO ilev = 2, klev - 1 + sss = sss + plev(1, ilev-1) - plev(1, ilev+1) + sssq = sssq + (plev(1,ilev-1)-plev(1,ilev+1))*q2(1, ilev) + END DO + ! print*,'Q2moy avant',sssq/sss + ! print*,'Q2q20 ',(q2(1,ilev),ilev=1,10) + ! print*,'Q2km0 ',(km(1,ilev),ilev=1,10) + ! ! C'est quoi ca qu'etait dans l'original??? + ! do igrid=1,ngrid + ! q2(igrid,1)=10. + ! enddo + ! q2s=q2 + ! do iii=1,10 + ! call vdif_q2(dt,g,rconst,plev,temp,km,q2) + ! do ilev=1,klev+1 + ! write(iii+49,*) q2(1,ilev),zlev(1,ilev) + ! enddo + ! enddo + ! stop + ! do ilev=1,klev + ! print*,zlev(1,ilev),q2s(1,ilev),q2(1,ilev) + ! enddo + ! q2s=q2-q2s + ! do ilev=1,klev + ! print*,q2s(1,ilev),zlev(1,ilev) + ! enddo + DO ilev = 2, klev - 1 + sss = sss + plev(1, ilev-1) - plev(1, ilev+1) + sssq = sssq + (plev(1,ilev-1)-plev(1,ilev+1))*q2(1, ilev) + END DO + PRINT *, 'Q2moy apres', sssq/sss + + + DO ilev = 2, klev-1 + DO igrid = 1, ngrid + q2(igrid, ilev) = max(q2(igrid,ilev), q2min) + q(igrid, ilev) = sqrt(q2(igrid,ilev)) + + ! ....................................................................... + + ! calcul final de kn et km + ! ------------------------ + + gn = -long(igrid, ilev)**2/q2(igrid, ilev)*n2(igrid, ilev) + IF (gngnmax) gn = gnmax + sn(igrid, ilev) = cn1/(1.E+0+cn2*gn) + sm(igrid, ilev) = (cm1+cm2*gn)/((1.E+0+cm3*gn)*(1.E+0+cm4*gn)) + ! Correction pour les couches stables. + ! Schema repris de JHoltzlag Boville, lui meme venant de... + + IF (1==1) THEN + snstable = 1. - zlev(igrid, ilev)/(700.*max(ustar(igrid),0.0001)) + snstable = 1. - zlev(igrid, ilev)/400. + snstable = max(snstable, 0.) + snstable = snstable*snstable + + ! abde print*,'SN ',ilev,sn(1,ilev),snstable + IF (sn(igrid,ilev) the model starts with NP from start files created by ce0l - ! -> the model can run with longer time-steps. - ! 2016/11/30 (EV etienne.vignon@lmd.ipsl.fr) - ! On met tke (=q2/2) en entr??e plut??t que q2 - ! On corrige l'update de la tke - ! 2020/10/01 (EV) - ! On ajoute la dissipation de la TKE en diagnostique de sortie - ! - ! Inpout/Output : - !============== - ! tke : tke au bas de chaque couche - ! (en entree : la valeur au debut du pas de temps) - ! (en sortie : la valeur a la fin du pas de temps) - - ! Outputs: - !========== - ! eps: tke dissipation rate - ! km : diffusivite turbulente de quantite de mouvement (au bas de chaque - ! couche) - ! (en sortie : la valeur a la fin du pas de temps) - ! kn : diffusivite turbulente des scalaires (au bas de chaque couche) - ! (en sortie : la valeur a la fin du pas de temps) - ! - !....................................................................... - - !======================================================================= - ! Declarations: - !======================================================================= - - - ! Inputs/Outputs - !---------------- - REAL dt, g, rconst - REAL plev(ngrid, klev+1), temp(ngrid, klev) - REAL ustar(ngrid) - REAL kmin, qmin, pblhmin(ngrid), coriol(ngrid) - REAL zlev(ngrid, klev+1) - REAL zlay(ngrid, klev) - REAL u(ngrid, klev) - REAL v(ngrid, klev) - REAL teta(ngrid, klev) - REAL cd(ngrid) - REAL tke(ngrid, klev+1) - REAL eps(ngrid,klev+1) - REAL unsdz(ngrid, klev) - REAL unsdzdec(ngrid, klev+1) - REAL kn(ngrid, klev+1) - REAL km(ngrid, klev+1) - INTEGER iflag_pbl, ngrid, nsrf - INTEGER ni(ngrid) - -!FC - REAL drgpro(ngrid,klev) - REAL winds(ngrid,klev) - - ! Local - !------- - - REAL q2(ngrid, klev+1) - REAL kmpre(ngrid, klev+1), tmp2, qpre - REAL mpre(ngrid, klev+1) - REAL kq(ngrid, klev+1) - REAL ff(ngrid, klev+1), delta(ngrid, klev+1) - REAL aa(ngrid, klev+1), aa0, aa1 - INTEGER nlay, nlev - - INTEGER ig, jg, k - REAL ri, zrif, zalpha, zsm, zsn - REAL rif(ngrid, klev+1), sm(ngrid, klev+1), alpha(ngrid, klev) - REAL m2(ngrid, klev+1), dz(ngrid, klev+1), zq, n2(ngrid, klev+1) - REAL dtetadz(ngrid, klev+1) - REAL m2cstat, mcstat, kmcstat - REAL l(ngrid, klev+1) - REAL zz(ngrid, klev+1) - INTEGER iter - REAL dissip(ngrid,klev), tkeprov,tkeexp, shear(ngrid,klev), buoy(ngrid,klev) - REAL :: disseff - - REAL :: rifc - REAL :: seuilsm, seuilalpha - - REAL frif, falpha, fsm - REAL rino(ngrid, klev+1), smyam(ngrid, klev), styam(ngrid, klev), & - lyam(ngrid, klev), knyam(ngrid, klev), w2yam(ngrid, klev), t2yam(ngrid, klev) - - CHARACTER (len = 20) :: modname = 'yamada4' - CHARACTER (len = 80) :: abort_message - - - - ! Fonctions utilis??es - !-------------------- - - frif(ri) = 0.6588*(ri+0.1776-sqrt(ri*ri-0.3221*ri+0.03156)) - falpha(ri) = 1.318*(0.2231-ri)/(0.2341-ri) - fsm(ri) = 1.96*(0.1912-ri)*(0.2341-ri)/((1.-ri)*(0.2231-ri)) - - - - IF (new_yamada4) THEN -! Corrections et reglages issus du travail de these d'Etienne Vignon. - rifc=frif(ric) - seuilsm=fsm(frif(ric)) - seuilalpha=falpha(frif(ric)) - ELSE - rifc=0.191 - seuilalpha=1.12 - seuilsm=0.085 - ENDIF - -!=============================================================================== -! Flags, tests et ??valuations de constantes -!=============================================================================== - -! On utilise ou non la routine de Holstalg Boville pour les cas tres stables - - - IF (.NOT. (iflag_pbl>=6 .AND. iflag_pbl<=12)) THEN - abort_message='probleme de coherence dans appel a MY' - CALL abort_physic(modname,abort_message,1) - END IF - - - nlay = klev - nlev = klev + 1 - - -!======================================================================== -! Calcul des increments verticaux -!========================================================================= - - -! Attention: zlev n'est pas declare a nlev - DO ig = 1, ngrid - zlev(ig, nlev) = zlay(ig, nlay) + (zlay(ig,nlay)-zlev(ig,nlev-1)) - END DO - - - DO k = 1, nlay - DO ig = 1, ngrid - unsdz(ig, k) = 1.E+0/(zlev(ig,k+1)-zlev(ig,k)) - END DO - END DO - DO ig = 1, ngrid - unsdzdec(ig, 1) = 1.E+0/(zlay(ig,1)-zlev(ig,1)) - END DO - DO k = 2, nlay - DO ig = 1, ngrid - unsdzdec(ig, k) = 1.E+0/(zlay(ig,k)-zlay(ig,k-1)) - END DO - END DO - DO ig = 1, ngrid - unsdzdec(ig, nlay+1) = 1.E+0/(zlev(ig,nlay+1)-zlay(ig,nlay)) - END DO - -!========================================================================= -! Richardson number and stability functions -!========================================================================= - -! initialize arrays: - - m2(1:ngrid, :) = 0.0 - sm(1:ngrid, :) = 0.0 - rif(1:ngrid, :) = 0.0 - -!------------------------------------------------------------ - DO k = 2, klev - - DO ig = 1, ngrid - dz(ig, k) = zlay(ig, k) - zlay(ig, k-1) - m2(ig, k) = ((u(ig,k)-u(ig,k-1))**2+(v(ig,k)-v(ig, & - k-1))**2)/(dz(ig,k)*dz(ig,k)) - dtetadz(ig, k) = (teta(ig,k)-teta(ig,k-1))/dz(ig, k) - n2(ig, k) = g*2.*dtetadz(ig, k)/(teta(ig,k-1)+teta(ig,k)) - ri = n2(ig, k)/max(m2(ig,k), 1.E-10) - IF (ri0.) THEN - q2(ig, k) = (qpre+aa(ig,k)*qpre*qpre)**2 - ELSE - q2(ig, k) = (qpre/(1.-aa(ig,k)*qpre))**2 - END IF - ! else ! iflag_pbl=9 - ! if (aa(ig,k)*qpre.gt.0.9) then - ! q2(ig,k)=(qpre*10.)**2 - ! else - ! q2(ig,k)=(qpre/(1.-aa(ig,k)*qpre))**2 - ! endif - ! endif - q2(ig, k) = min(max(q2(ig,k),1.E-10), 1.E4) - END DO - END DO - - ELSE IF (iflag_pbl>=10) THEN - - shear(:,:)=0. - buoy(:,:)=0. - dissip(:,:)=0. - km(:,:)=0. - - IF (yamada4_num>=1) THEN - - DO k = 2, klev - 1 - DO ig=1,ngrid - q2(ig, k) = min(max(q2(ig,k),1.E-10), 1.E4) - km(ig, k) = l(ig, k)*sqrt(q2(ig,k))*sm(ig, k) - shear(ig,k)=km(ig, k)*m2(ig, k) - buoy(ig,k)=km(ig, k)*m2(ig, k)*(-1.*rif(ig,k)) -! dissip(ig,k)=min(max(((sqrt(q2(ig,k)))**3)/(b1*l(ig,k)),1.E-12),1.E4) - dissip(ig,k)=((sqrt(q2(ig,k)))**3)/(b1*l(ig,k)) - ENDDO - ENDDO - - IF (yamada4_num==1) THEN ! Schema du MAR tel quel - DO k = 2, klev - 1 - DO ig=1,ngrid - tkeprov=q2(ig,k)/ydeux - tkeprov= tkeprov* & - & (tkeprov+dt*(shear(ig,k)+max(0.,buoy(ig,k))))/ & - & (tkeprov+dt*((-1.)*min(0.,buoy(ig,k))+dissip(ig,k)+drgpro(ig,k)*tkeprov)) - q2(ig,k)=tkeprov*ydeux - ENDDO - ENDDO - ELSE IF (yamada4_num==2) THEN ! version modifiee avec integration exacte pour la dissipation - DO k = 2, klev - 1 - DO ig=1,ngrid - tkeprov=q2(ig,k)/ydeux - disseff=dissip(ig,k)-min(0.,buoy(ig,k)) - tkeprov = tkeprov/(1.+dt*disseff/(2.*tkeprov))**2 - tkeprov= tkeprov+dt*(shear(ig,k)+max(0.,buoy(ig,k))) - q2(ig,k)=tkeprov*ydeux - ! En cas stable, on traite la flotabilite comme la - ! dissipation, en supposant que buoy/q2^3 est constant. - ! Puis on prend la solution exacte - ENDDO - ENDDO - ELSE IF (yamada4_num==3) THEN ! version modifiee avec integration exacte pour la dissipation - DO k = 2, klev - 1 - DO ig=1,ngrid - tkeprov=q2(ig,k)/ydeux - disseff=dissip(ig,k)-min(0.,buoy(ig,k)) - tkeprov=tkeprov*exp(-dt*disseff/tkeprov) - tkeprov= tkeprov+dt*(shear(ig,k)+max(0.,buoy(ig,k))) - q2(ig,k)=tkeprov*ydeux - ! En cas stable, on traite la flotabilite comme la - ! dissipation, en supposant que buoy/q2^3 est constant. - ! Puis on prend la solution exacte - ENDDO - ENDDO - ELSE IF (yamada4_num==4) THEN ! version modifiee avec integration exacte pour la dissipation - DO k = 2, klev - 1 - DO ig=1,ngrid - tkeprov=q2(ig,k)/ydeux - tkeprov= tkeprov+dt*(shear(ig,k)+max(0.,buoy(ig,k))) - tkeprov= tkeprov* & - & tkeprov/ & - & (tkeprov+dt*((-1.)*min(0.,buoy(ig,k))+dissip(ig,k))) - q2(ig,k)=tkeprov*ydeux - ! En cas stable, on traite la flotabilite comme la - ! dissipation, en supposant que buoy/q2^3 est constant. - ! Puis on prend la solution exacte - ENDDO - ENDDO - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !! Attention, yamada4_num=5 est inexacte car néglige les termes de flottabilité - !! en conditions instables - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ELSE IF (yamada4_num==5) THEN ! version modifiee avec integration exacte pour la dissipation - DO k = 2, klev - 1 - DO ig=1,ngrid - tkeprov=q2(ig,k)/ydeux -!FC on ajoute la dissipation due aux arbres - disseff=dissip(ig,k)-min(0.,buoy(ig,k)) + drgpro(ig,k)*tkeprov - tkeexp=exp(-dt*disseff/tkeprov) -! on prend en compte la tke cree par les arbres - winds(ig,k)=sqrt(u(ig,k)**2+v(ig,k)**2) - tkeprov= (shear(ig,k)+ & - & drgpro(ig,k)*(winds(ig,k))**3)*tkeprov/disseff*(1.-tkeexp)+tkeprov*tkeexp - q2(ig,k)=tkeprov*ydeux - ! En cas stable, on traite la flotabilite comme la - ! dissipation, en supposant que buoy/q2^3 est constant. - ! Puis on prend la solution exacte - ENDDO - ENDDO - ELSE IF (yamada4_num==6) THEN ! version modifiee avec integration exacte pour la dissipation - DO k = 2, klev - 1 - DO ig=1,ngrid - ! En cas stable, on traite la flotabilite comme la - ! dissipation, en supposant que dissipeff/TKE est constant. - ! Puis on prend la solution exacte - ! With drag and dissipation from high vegetation (EV & FC, 05/10/2020) - winds(ig,k)=sqrt(u(ig,k)**2+v(ig,k)**2) - tkeprov=q2(ig,k)/ydeux - tkeprov=tkeprov+max(buoy(ig,k)+shear(ig,k)+drgpro(ig,k)*(winds(ig,k))**3,0.)*dt - disseff=dissip(ig,k)-min(0.,buoy(ig,k)+shear(ig,k)+drgpro(ig,k)*(winds(ig,k))**3) + drgpro(ig,k)*tkeprov - tkeexp=exp(-dt*disseff/tkeprov) - tkeprov= tkeprov*tkeexp - q2(ig,k)=tkeprov*ydeux - - ENDDO - ENDDO - ENDIF - - DO k = 2, klev - 1 - DO ig=1,ngrid - q2(ig, k) = min(max(q2(ig,k),1.E-10), 1.E4) - ENDDO - ENDDO - - ELSE - - DO k = 2, klev - 1 - km(1:ngrid, k) = l(1:ngrid, k)*sqrt(q2(1:ngrid,k))*sm(1:ngrid, k) - q2(1:ngrid, k) = q2(1:ngrid, k) + ydeux*dt*km(1:ngrid, k)*m2(1:ngrid, k)*(1.-rif(1:ngrid,k)) -! q2(1:ngrid, k) = q2(1:ngrid, k) + dt*km(1:ngrid, k)*m2(1:ngrid, k)*(1.-rif(1:ngrid,k)) - q2(1:ngrid, k) = min(max(q2(1:ngrid,k),1.E-10), 1.E4) - q2(1:ngrid, k) = 1./(1./sqrt(q2(1:ngrid,k))+dt/(yun*l(1:ngrid,k)*b1)) -! q2(1:ngrid, k) = 1./(1./sqrt(q2(1:ngrid,k))+dt/(2*l(1:ngrid,k)*b1)) - q2(1:ngrid, k) = q2(1:ngrid, k)*q2(1:ngrid, k) - END DO - - ENDIF - - ELSE - abort_message='Cas nom prevu dans yamada4' - CALL abort_physic(modname,abort_message,1) - - END IF ! Fin du cas 8 - - - ! ==================================================================== - ! Calcul des coefficients de melange - ! ==================================================================== - - DO k = 2, klev - DO ig = 1, ngrid - zq = sqrt(q2(ig,k)) - km(ig, k) = l(ig, k)*zq*sm(ig, k) ! For momentum - kn(ig, k) = km(ig, k)*alpha(ig, k) ! For scalars - kq(ig, k) = l(ig, k)*zq*0.2 ! For TKE - END DO - END DO - - - !==================================================================== - ! Transport diffusif vertical de la TKE par la TKE - !==================================================================== - - - ! initialize near-surface and top-layer mixing coefficients - !........................................................... - - kq(1:ngrid, 1) = kq(1:ngrid, 2) ! constant (ie no gradient) near the surface - kq(1:ngrid, klev+1) = 0 ! zero at the top - - ! Transport diffusif vertical de la TKE. - !....................................... - - IF (iflag_vdif_q2==1) THEN - q2(1:ngrid, 1) = q2(1:ngrid, 2) - CALL vdif_q2(dt, g, rconst, ngrid, plev, temp, kq, q2) - END IF - - - !==================================================================== - ! Traitement particulier pour les cas tres stables, introduction d'une - ! longueur de m??lange minimale - !==================================================================== - ! - ! Reference: Local versus Nonlocal boundary-layer diffusion in a global climate model - ! Holtslag A.A.M. and Boville B.A. - ! J. Clim., 6, 1825-1842, 1993 - - - IF (hboville) THEN - - - IF (prt_level>1) THEN - WRITE(lunout,*) 'YAMADA4 0' - END IF - - DO ig = 1, ngrid - coriol(ig) = 1.E-4 - pblhmin(ig) = 0.07*ustar(ig)/max(abs(coriol(ig)), 2.546E-5) - END DO - - IF (1==1) THEN - IF (iflag_pbl==8 .OR. iflag_pbl==10) THEN - - DO k = 2, klev - DO ig = 1, ngrid - IF (teta(ig,2)>teta(ig,1)) THEN - qmin = ustar(ig)*(max(1.-zlev(ig,k)/pblhmin(ig),0.))**2 - kmin = kap*zlev(ig, k)*qmin - ELSE - kmin = -1. ! kmin n'est utilise que pour les SL stables. - END IF - IF (kn(ig,k)teta(ig,1)) THEN - qmin = ustar(ig)*(max(1.-zlev(ig,k)/pblhmin(ig),0.))**2 - kmin = kap*zlev(ig, k)*qmin - ELSE - kmin = -1. ! kmin n'est utilise que pour les SL stables. - END IF - IF (kn(ig,k)1) THEN - WRITE(lunout,*)'YAMADA4 1' - END IF !(prt_level>1) THEN - - - !====================================================== - ! Estimations de w'2 et T'2 d'apres Abdela et McFarlane - !====================================================== - ! - ! Reference: A New Second-Order Turbulence Closure Scheme for the Planetary Boundary Layer - ! Abdella K and McFarlane N - ! J. Atmos. Sci., 54, 1850-1867, 1997 - - ! Diagnostique pour stokage - !.......................... - - IF (1==0) THEN - rino = rif - smyam(1:ngrid, 1) = 0. - styam(1:ngrid, 1) = 0. - lyam(1:ngrid, 1) = 0. - knyam(1:ngrid, 1) = 0. - w2yam(1:ngrid, 1) = 0. - t2yam(1:ngrid, 1) = 0. - - smyam(1:ngrid, 2:klev) = sm(1:ngrid, 2:klev) - styam(1:ngrid, 2:klev) = sm(1:ngrid, 2:klev)*alpha(1:ngrid, 2:klev) - lyam(1:ngrid, 2:klev) = l(1:ngrid, 2:klev) - knyam(1:ngrid, 2:klev) = kn(1:ngrid, 2:klev) - - - ! Calcul de w'2 et T'2 - !....................... - - w2yam(1:ngrid, 2:klev) = q2(1:ngrid, 2:klev)*0.24 + & - lyam(1:ngrid, 2:klev)*5.17*kn(1:ngrid, 2:klev)*n2(1:ngrid, 2:klev)/ & - sqrt(q2(1:ngrid,2:klev)) - - t2yam(1:ngrid, 2:klev) = 9.1*kn(1:ngrid, 2:klev)* & - dtetadz(1:ngrid, 2:klev)**2/sqrt(q2(1:ngrid,2:klev))* & - lyam(1:ngrid, 2:klev) - END IF - - - -!============================================================================ -! Mise a jour de la tke -!============================================================================ - - IF (new_yamada4) THEN - DO k=1,klev+1 - tke(1:ngrid,k)=q2(1:ngrid,k)/ydeux - ENDDO - ELSE - DO k=1,klev+1 - tke(1:ngrid,k)=q2(1:ngrid,k) - ENDDO - ENDIF - - -!============================================================================ -! Diagnostique de la dissipation et vitesse verticale -!============================================================================ - -! Diagnostics - - eps(:,:)=0. -!ym wprime(1:ngrid,:,nsrf)=0. - DO k=2,klev - DO ig=1,ngrid - eps(ig,k)=dissip(ig,k) - jg=ni(ig) - wprime(jg,k,nsrf)=sqrt(MAX(1./3*q2(ig,k),0.)) - ENDDO - ENDDO - - -!============================================================================= - - RETURN - - -END SUBROUTINE yamada4 - -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -SUBROUTINE vdif_q2(timestep, gravity, rconst, ngrid, plev, temp, kmy, q2) -!$gpum horizontal ngrid - USE dimphy, only : klev - IMPLICIT NONE - -! vdif_q2: subroutine qui calcule la diffusion de la TKE par la TKE -! avec un schema implicite en temps avec -! inversion d'un syst??me tridiagonal -! -! Reference: Description of the interface with the surface and -! the computation of the turbulet diffusion in LMDZ -! Technical note on LMDZ -! Dufresne, J-L, Ghattas, J. and Grandpeix, J-Y -! -!============================================================================ -! Declarations -!============================================================================ - - REAL plev(ngrid, klev+1) - REAL temp(ngrid, klev) - REAL timestep - REAL gravity, rconst - REAL kstar(ngrid, klev+1), zz - REAL kmy(ngrid, klev+1) - REAL q2(ngrid, klev+1) - REAL deltap(ngrid, klev+1) - REAL denom(ngrid, klev+1), alpha(ngrid, klev+1), beta(ngrid, klev+1) - INTEGER ngrid - - INTEGER i, k - - -!========================================================================= -! Calcul -!========================================================================= - - DO k = 1, klev - DO i = 1, ngrid - zz = (plev(i,k)+plev(i,k+1))*gravity/(rconst*temp(i,k)) - kstar(i, k) = 0.125*(kmy(i,k+1)+kmy(i,k))*zz*zz/ & - (plev(i,k)-plev(i,k+1))*timestep - END DO - END DO - - DO k = 2, klev - DO i = 1, ngrid - deltap(i, k) = 0.5*(plev(i,k-1)-plev(i,k+1)) - END DO - END DO - DO i = 1, ngrid - deltap(i, 1) = 0.5*(plev(i,1)-plev(i,2)) - deltap(i, klev+1) = 0.5*(plev(i,klev)-plev(i,klev+1)) - denom(i, klev+1) = deltap(i, klev+1) + kstar(i, klev) - alpha(i, klev+1) = deltap(i, klev+1)*q2(i, klev+1)/denom(i, klev+1) - beta(i, klev+1) = kstar(i, klev)/denom(i, klev+1) - END DO - - DO k = klev, 2, -1 - DO i = 1, ngrid - denom(i, k) = deltap(i, k) + (1.-beta(i,k+1))*kstar(i, k) + & - kstar(i, k-1) - alpha(i, k) = (q2(i,k)*deltap(i,k)+kstar(i,k)*alpha(i,k+1))/denom(i, k) - beta(i, k) = kstar(i, k-1)/denom(i, k) - END DO - END DO - - ! Si on recalcule q2(1) - !....................... - IF (1==0) THEN - DO i = 1, ngrid - denom(i, 1) = deltap(i, 1) + (1-beta(i,2))*kstar(i, 1) - q2(i, 1) = (q2(i,1)*deltap(i,1)+kstar(i,1)*alpha(i,2))/denom(i, 1) - END DO - END IF - - - DO k = 2, klev + 1 - DO i = 1, ngrid - q2(i, k) = alpha(i, k) + beta(i, k)*q2(i, k-1) - END DO - END DO - - RETURN -END SUBROUTINE vdif_q2 -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - - -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - SUBROUTINE vdif_q2e(timestep, gravity, rconst, ngrid, plev, temp, kmy, q2) -!$gpum horizontal ngrid - USE dimphy, only : klev - IMPLICIT NONE - -! vdif_q2e: subroutine qui calcule la diffusion de TKE par la TKE -! avec un schema explicite en temps - - -!==================================================== -! Declarations -!==================================================== - - REAL plev(ngrid, klev+1) - REAL temp(ngrid, klev) - REAL timestep - REAL gravity, rconst - REAL kstar(ngrid, klev+1), zz - REAL kmy(ngrid, klev+1) - REAL q2(ngrid, klev+1) - REAL deltap(ngrid, klev+1) - REAL denom(ngrid, klev+1), alpha(ngrid, klev+1), beta(ngrid, klev+1) - INTEGER ngrid - INTEGER i, k - - -!================================================== -! Calcul -!================================================== - - DO k = 1, klev - DO i = 1, ngrid - zz = (plev(i,k)+plev(i,k+1))*gravity/(rconst*temp(i,k)) - kstar(i, k) = 0.125*(kmy(i,k+1)+kmy(i,k))*zz*zz/ & - (plev(i,k)-plev(i,k+1))*timestep - END DO - END DO - - DO k = 2, klev - DO i = 1, ngrid - deltap(i, k) = 0.5*(plev(i,k-1)-plev(i,k+1)) - END DO - END DO - DO i = 1, ngrid - deltap(i, 1) = 0.5*(plev(i,1)-plev(i,2)) - deltap(i, klev+1) = 0.5*(plev(i,klev)-plev(i,klev+1)) - END DO - - DO k = klev, 2, -1 - DO i = 1, ngrid - q2(i, k) = q2(i, k) + (kstar(i,k)*(q2(i,k+1)-q2(i, & - k))-kstar(i,k-1)*(q2(i,k)-q2(i,k-1)))/deltap(i, k) - END DO - END DO - - DO i = 1, ngrid - q2(i, 1) = q2(i, 1) + (kstar(i,1)*(q2(i,2)-q2(i,1)))/deltap(i, 1) - q2(i, klev+1) = q2(i, klev+1) + (-kstar(i,klev)*(q2(i,klev+1)-q2(i, & - klev)))/deltap(i, klev+1) - END DO - - RETURN -END SUBROUTINE vdif_q2e - -!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - -SUBROUTINE mixinglength(ni, nsrf, ngrid,iflag_pbl,pbl_lmixmin_alpha,lmixmin,zlay,zlev,u,v,q2,n2, lmix) -!$gpum horizontal ngrid - - - USE dimphy, only : klev - USE yamada_ini_mod, only : l0 - USE phys_state_var_mod, only: zstd, zsig, zmea - USE phys_local_var_mod, only: l_mixmin, l_mix - USE yamada_ini_mod, only : kap, kapb - - ! zstd: ecart type de la'altitud e sous-maille - ! zmea: altitude moyenne sous maille - ! zsig: pente moyenne de le maille - - !USE geometry_mod, only: cell_area - ! aire_cell: aire de la maille - - IMPLICIT NONE -!************************************************************************* -! Subrourine qui calcule la longueur de m??lange dans le sch??ma de turbulence -! avec la formule de Blackadar -! Calcul d'un minimum en fonction de l'orographie sous-maille: -! L'id??e est la suivante: plus il y a de relief, plus il y a du m??lange -! induit par les circulations meso et submeso ??chelles. -! -! References: * The vertical distribution of wind and turbulent exchange in a neutral atmosphere -! Blackadar A.K. -! J. Geophys. Res., 64, No 8, 1962 -! -! * An evaluation of neutral and convective planetary boundary-layer parametrisations relative -! to large eddy simulations -! Ayotte K et al -! Boundary Layer Meteorology, 79, 131-175, 1996 -! -! -! * Local Similarity in the Stable Boundary Layer and Mixing length Approaches: consistency of concepts -! Van de Wiel B.J.H et al -! Boundary-Lay Meteorol, 128, 103-166, 2008 -! -! -! Histoire: -!---------- -! * premi??re r??daction, Etienne et Frederic, 09/06/2016 -! -! *********************************************************************** - -!================================================================== -! Declarations -!================================================================== - -! Inputs -!------- - INTEGER ni(ngrid) ! indice sur la grille original (non restreinte) - INTEGER nsrf ! Type de surface - INTEGER ngrid ! Nombre de points concern??s sur l'horizontal - INTEGER iflag_pbl ! Choix du sch??ma de turbulence - REAL pbl_lmixmin_alpha ! on active ou non le calcul de la longueur de melange minimum en fonction du relief - REAL lmixmin ! Minimum absolu de la longueur de m??lange - REAL zlay(ngrid, klev) ! altitude du centre de la couche - REAL zlev(ngrid, klev+1) ! atitude de l'interface inf??rieure de la couche - REAL u(ngrid, klev) ! vitesse du vent zonal - REAL v(ngrid, klev) ! vitesse du vent meridional - REAL q2(ngrid, klev+1) ! energie cin??tique turbulente - REAL n2(ngrid, klev+1) ! frequence de Brunt-Vaisala - -!In/out -!------- - -! Outputs -!--------- - - REAL lmix(ngrid, klev+1) ! Longueur de melange - - -! Local -!------- - - INTEGER ig,jg, k - REAL h_oro(ngrid) - REAL hlim(ngrid) - REAL zq - REAL sq(ngrid), sqz(ngrid) - REAL fl, zzz, zl0, zq2, zn2 - REAL famorti, zzzz, zh_oro, zhlim - REAL l1(ngrid, klev+1), l2(ngrid,klev+1) - REAL winds(ngrid, klev) - REAL xcell - REAL zstdslope(ngrid) - REAL lmax - REAL l2strat, l2neutre, extent - REAL l2limit(ngrid) -!=============================================================== -! Fonctions utiles -!=============================================================== - -! Calcul de l suivant la formule de Blackadar 1962 adapt??e par Ayotte 1996 -!.......................................................................... - -!ym il ya a des gens qui font du code avec leur pieds => n'importe quoi ! -!ym fl(zzz, zl0, zq2, zn2) = max(min(l0(ig)*kap*zlev(ig, & -!ym k)/(kap*zlev(ig,k)+l0(ig)),0.5*sqrt(q2(ig,k))/sqrt( & -!ym max(n2(ig,k),1.E-10))), 1.E-5) - - fl(zzz, zl0, zq2, zn2) = max(min(zl0*kap*zzz/(kap*zzz+zl0),0.5*sqrt(zq2)/sqrt(max(zn2,1.E-10))), 1.E-5) - - - -! Fonction d'amortissement de la turbulence au dessus de la montagne -! On augmente l'amortissement en diminuant la valeur de hlim (extent) dans le code -!..................................................................... - - famorti(zzzz, zh_oro, zhlim)=(-1.)*ATAN((zzzz-zh_oro)/(zhlim-zh_oro))*2./3.1416+1. - - IF (ngrid==0) RETURN - - -!===================================================================== -! CALCUL de la LONGUEUR de m??lange suivant BLACKADAR: l1 -!===================================================================== - - l1(1:ngrid,:)=0. - IF (iflag_pbl==8 .OR. iflag_pbl==10) THEN - - - ! Iterative computation of l0 - ! This version is kept for iflag_pbl only for convergence - ! with NPv3.1 Cmip5 simulations - !................................................................... - - DO ig = 1, ngrid - sq(ig) = 1.E-10 - sqz(ig) = 1.E-10 - END DO - DO k = 2, klev - 1 - DO ig = 1, ngrid - zq = sqrt(q2(ig,k)) - sqz(ig) = sqz(ig) + zq*zlev(ig, k)*(zlay(ig,k)-zlay(ig,k-1)) - sq(ig) = sq(ig) + zq*(zlay(ig,k)-zlay(ig,k-1)) - END DO - END DO - DO ig = 1, ngrid - l0(ig) = 0.2*sqz(ig)/sq(ig) - END DO - DO k = 2, klev - DO ig = 1, ngrid - l1(ig, k) = fl(zlev(ig,k), l0(ig), q2(ig,k), n2(ig,k)) - END DO - END DO - - ELSE - - - ! In all other case, the assymptotic mixing length l0 is imposed (150m) - !...................................................................... - - l0(1:ngrid) = 150. - DO k = 2, klev - DO ig = 1, ngrid - l1(ig, k) = fl(zlev(ig,k), l0(ig), q2(ig,k), n2(ig,k)) - END DO - END DO - - END IF - -!=========================================================================================== -! CALCUL d'une longueur de melange minimum en fonctions de la topographie sous maille: l2 -! si pbl_lmixmin_alpha=TRUE et si on se trouve sur de la terre ( pas actif sur les -! glacier, la glace de mer et les oc??ans) -!=========================================================================================== - - l2(1:ngrid,:)=0.0 -!YM uncompressed variable, setting to 0 in pre_pbl_sutf -!YM l_mixmin(1:ngrid,:,nsrf)=0. -!YM l_mix(1:ngrid,:,nsrf)=0. - hlim(1:ngrid)=0. - - IF (nsrf .EQ. 1) THEN - -! coefficients -!-------------- - - extent=2. ! On ??tend l'impact du relief jusqu'?? extent*h, extent >1. - lmax=150. ! Longueur de m??lange max dans l'absolu - -! calculs -!--------- - - DO ig=1,ngrid - - ! On calcule la hauteur du relief - !................................. - ! On ne peut pas prendre zstd seulement pour caracteriser le relief sous maille - ! car sur un terrain pentu mais sans relief, zstd est non nul (comme en Antarctique, C. Genthon) - ! On corrige donc zstd avec l'ecart type de l'altitude dans la maille sans relief - ! (en gros, une maille de taille xcell avec une pente constante zstdslope) - jg=ni(ig) -! IF (zsig(jg) .EQ. 0.) THEN -! zstdslope(ig)=0. -! ELSE -! xcell=sqrt(cell_area(jg)) -! zstdslope(ig)=max((xcell*zsig(jg)-zmea(jg))**3 /(3.*zsig(jg)),0.) -! zstdslope(ig)=sqrt(zstdslope(ig)) -! END IF - -! h_oro(ig)=max(zstd(jg)-zstdslope(ig),0.) ! Hauteur du relief - h_oro(ig)=zstd(jg) - hlim(ig)=extent*h_oro(ig) - ENDDO - - l2limit(1:ngrid)=0. - - DO k=2,klev - DO ig=1,ngrid - winds(ig,k)=sqrt(u(ig,k)**2+v(ig,k)**2) - IF (zlev(ig,k) .LE. h_oro(ig)) THEN ! sous l'orographie - l2strat= kapb*pbl_lmixmin_alpha*winds(ig,k)/sqrt(max(n2(ig,k),1.E-10)) ! si stratifi??, amplitude d'oscillation * kappab (voir Van de Wiel et al 2008) - l2neutre=kap*zlev(ig,k)*h_oro(ig)/(kap*zlev(ig,k)+h_oro(ig)) ! Dans le cas neutre, formule de blackadar. tend asymptotiquement vers h - l2neutre=MIN(l2neutre,lmax) ! On majore par lmax - l2limit(ig)=MIN(l2neutre,l2strat) ! Calcule de l2 (minimum de la longueur en cas neutre et celle en situation stratifi??e) - l2(ig,k)=l2limit(ig) - - ELSE IF (zlev(ig,k) .LE. hlim(ig)) THEN ! Si on est au dessus des montagnes, mais affect?? encore par elles - - ! Au dessus des montagnes, on prend la l2limit au sommet des montagnes - ! (la derni??re calcul??e dans la boucle k, vu que k est un indice croissant avec z) - ! et on multiplie l2limit par une fonction qui d??croit entre h et hlim - l2(ig,k)=l2limit(ig)*famorti(zlev(ig,k),h_oro(ig), hlim(ig)) - ELSE ! Au dessus de extent*h, on prend l2=l0 - l2(ig,k)=0. - END IF - ENDDO - ENDDO - ENDIF ! pbl_lmixmin_alpha - -!================================================================================== -! On prend le max entre la longueur de melange de blackadar et celle calcul??e -! en fonction de la topographie -!=================================================================================== - - - DO k=1,klev+1 - DO ig=1,ngrid - lmix(ig,k)=MAX(MAX(l1(ig,k), l2(ig,k)),lmixmin) - ENDDO - ENDDO - -! Diagnostics - - DO k=1,klev+1 - DO ig=1,ngrid - jg=ni(ig) - l_mix(jg,k,nsrf)=lmix(ig,k) - l_mixmin(jg,k,nsrf)=MAX(l2(ig,k),lmixmin) - ENDDO - ENDDO - - - -END SUBROUTINE mixinglength - -END MODULE yamada4_mod Index: LMDZ6/trunk/libf/phylmd/yamada4_mod.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/yamada4_mod.f90 (revision 6048) +++ LMDZ6/trunk/libf/phylmd/yamada4_mod.f90 (revision 6048) @@ -0,0 +1,1131 @@ +MODULE yamada4_mod + +CONTAINS +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + +SUBROUTINE yamada4(ni, nsrf, ngrid, dt, g, rconst, plev, temp, zlev, zlay, u, v, teta, & + cd, tke, eps, km, kn, kq, ustar, iflag_pbl, drgpro) +!$gpum horizontal ngrid + USE dimphy, only : klev + USE phys_local_var_mod, only: wprime + USE yamada_ini_mod, only : new_yamada4,yamada4_num,hboville + USE yamada_ini_mod, only : prt_level, lunout,pbl_lmixmin_alpha,b1,kap,viscom,viscoh + USE yamada_ini_mod, only : ric, yun,ydeux,lmixmin,iflag_vdif_q2 + + IMPLICIT NONE + ! ************************************************************************************************ + ! + ! yamada4: subroutine qui calcule le transfert turbulent avec une fermeture d'ordre 2 ou 2.5 + ! + ! Reference: Simulation of nocturnal drainage flows by a q2l Turbulence Closure Model + ! Yamada T. + ! J. Atmos. Sci, 40, 91-106, 1983 + ! + !************************************************************************************************ + ! Input : + !'====== + ! ni: indice horizontal sur la grille de base, non restreinte + ! nsrf: type de surface + ! ngrid: nombre de mailles concern??es sur l'horizontal + ! dt : pas de temps + ! g : g + ! rconst: constante de l'air sec + ! zlev : altitude a chaque niveau (interface inferieure de la couche + ! de meme indice) + ! zlay : altitude au centre de chaque couche + ! u,v : vitesse au centre de chaque couche + ! (en entree : la valeur au debut du pas de temps) + ! teta : temperature potentielle virtuelle au centre de chaque couche + ! (en entree : la valeur au debut du pas de temps) + ! cd : cdrag pour la quantit?? de mouvement + ! (en entree : la valeur au debut du pas de temps) + ! ustar: vitesse de friction calcul??e par une formule diagnostique + ! iflag_pbl: flag pour choisir des options du sch??ma de turbulence + ! + ! iflag_pbl doit valoir entre 6 et 9 + ! l=6, on prend systematiquement une longueur d'equilibre + ! iflag_pbl=6 : MY 2.0 + ! iflag_pbl=7 : MY 2.0.Fournier + ! iflag_pbl=8/9 : MY 2.5 + ! iflag_pbl=8 with special obsolete treatments for convergence + ! with Cmpi5 NPv3.1 simulations + ! iflag_pbl=10/11 : New scheme M2 and N2 explicit and dissiptation exact + ! iflag_pbl=12 = 11 with vertical diffusion off q2 + ! + ! 2013/04/01 (FH hourdin@lmd.jussieu.fr) + ! Correction for very stable PBLs (iflag_pbl=10 and 11) + ! iflag_pbl=8 converges numerically with NPv3.1 + ! iflag_pbl=11 -> the model starts with NP from start files created by ce0l + ! -> the model can run with longer time-steps. + ! 2016/11/30 (EV etienne.vignon@lmd.ipsl.fr) + ! On met tke (=q2/2) en entr??e plut??t que q2 + ! On corrige l'update de la tke + ! 2020/10/01 (EV) + ! On ajoute la dissipation de la TKE en diagnostique de sortie + ! + ! Inpout/Output : + !============== + ! tke : tke au bas de chaque couche + ! (en entree : la valeur au debut du pas de temps) + ! (en sortie : la valeur a la fin du pas de temps) + + ! Outputs: + !========== + ! eps: tke dissipation rate + ! km : diffusivite turbulente de quantite de mouvement (au bas de chaque + ! couche) + ! (en sortie : la valeur a la fin du pas de temps) + ! kn : diffusivite turbulente des scalaires (au bas de chaque couche) + ! (en sortie : la valeur a la fin du pas de temps) + ! + !....................................................................... + + !======================================================================= + ! Declarations: + !======================================================================= + + + ! Inputs/Outputs + !---------------- + REAL dt, g, rconst + REAL plev(ngrid, klev+1), temp(ngrid, klev) + REAL ustar(ngrid) + REAL kmin, qmin, pblhmin(ngrid), coriol(ngrid) + REAL zlev(ngrid, klev+1) + REAL zlay(ngrid, klev) + REAL u(ngrid, klev) + REAL v(ngrid, klev) + REAL teta(ngrid, klev) + REAL cd(ngrid) + REAL tke(ngrid, klev+1) + REAL eps(ngrid,klev+1) + REAL unsdz(ngrid, klev) + REAL unsdzdec(ngrid, klev+1) + REAL kn(ngrid, klev+1) + REAL km(ngrid, klev+1) + INTEGER iflag_pbl, ngrid, nsrf + INTEGER ni(ngrid) + +!FC + REAL drgpro(ngrid,klev) + REAL winds(ngrid,klev) + + ! Local + !------- + + REAL q2(ngrid, klev+1) + REAL kmpre(ngrid, klev+1), tmp2, qpre + REAL mpre(ngrid, klev+1) + REAL kq(ngrid, klev+1) + REAL ff(ngrid, klev+1), delta(ngrid, klev+1) + REAL aa(ngrid, klev+1), aa0, aa1 + INTEGER nlay, nlev + + INTEGER ig, jg, k + REAL ri, zrif, zalpha, zsm, zsn + REAL rif(ngrid, klev+1), sm(ngrid, klev+1), alpha(ngrid, klev) + REAL m2(ngrid, klev+1), dz(ngrid, klev+1), zq, n2(ngrid, klev+1) + REAL dtetadz(ngrid, klev+1) + REAL m2cstat, mcstat, kmcstat + REAL l(ngrid, klev+1) + REAL zz(ngrid, klev+1) + INTEGER iter + REAL dissip(ngrid,klev), tkeprov,tkeexp, shear(ngrid,klev), buoy(ngrid,klev) + REAL :: disseff + + REAL :: rifc + REAL :: seuilsm, seuilalpha + + REAL frif, falpha, fsm + REAL rino(ngrid, klev+1), smyam(ngrid, klev), styam(ngrid, klev), & + lyam(ngrid, klev), knyam(ngrid, klev), w2yam(ngrid, klev), t2yam(ngrid, klev) + + CHARACTER (len = 20) :: modname = 'yamada4' + CHARACTER (len = 80) :: abort_message + + + + ! Fonctions utilis??es + !-------------------- + + frif(ri) = 0.6588*(ri+0.1776-sqrt(ri*ri-0.3221*ri+0.03156)) + falpha(ri) = 1.318*(0.2231-ri)/(0.2341-ri) + fsm(ri) = 1.96*(0.1912-ri)*(0.2341-ri)/((1.-ri)*(0.2231-ri)) + + + + IF (new_yamada4) THEN +! Corrections et reglages issus du travail de these d'Etienne Vignon. + rifc=frif(ric) + seuilsm=fsm(frif(ric)) + seuilalpha=falpha(frif(ric)) + ELSE + rifc=0.191 + seuilalpha=1.12 + seuilsm=0.085 + ENDIF + +!=============================================================================== +! Flags, tests et ??valuations de constantes +!=============================================================================== + +! On utilise ou non la routine de Holstalg Boville pour les cas tres stables + + + IF (.NOT. (iflag_pbl>=6 .AND. iflag_pbl<=12)) THEN + abort_message='probleme de coherence dans appel a MY' + CALL abort_physic(modname,abort_message,1) + END IF + + + nlay = klev + nlev = klev + 1 + + +!======================================================================== +! Calcul des increments verticaux +!========================================================================= + + +! Attention: zlev n'est pas declare a nlev + DO ig = 1, ngrid + zlev(ig, nlev) = zlay(ig, nlay) + (zlay(ig,nlay)-zlev(ig,nlev-1)) + END DO + + + DO k = 1, nlay + DO ig = 1, ngrid + unsdz(ig, k) = 1.E+0/(zlev(ig,k+1)-zlev(ig,k)) + END DO + END DO + DO ig = 1, ngrid + unsdzdec(ig, 1) = 1.E+0/(zlay(ig,1)-zlev(ig,1)) + END DO + DO k = 2, nlay + DO ig = 1, ngrid + unsdzdec(ig, k) = 1.E+0/(zlay(ig,k)-zlay(ig,k-1)) + END DO + END DO + DO ig = 1, ngrid + unsdzdec(ig, nlay+1) = 1.E+0/(zlev(ig,nlay+1)-zlay(ig,nlay)) + END DO + +!========================================================================= +! Richardson number and stability functions +!========================================================================= + +! initialize arrays: + + m2(1:ngrid, :) = 0.0 + sm(1:ngrid, :) = 0.0 + rif(1:ngrid, :) = 0.0 + +!------------------------------------------------------------ + DO k = 2, klev + + DO ig = 1, ngrid + dz(ig, k) = zlay(ig, k) - zlay(ig, k-1) + m2(ig, k) = ((u(ig,k)-u(ig,k-1))**2+(v(ig,k)-v(ig, & + k-1))**2)/(dz(ig,k)*dz(ig,k)) + dtetadz(ig, k) = (teta(ig,k)-teta(ig,k-1))/dz(ig, k) + n2(ig, k) = g*2.*dtetadz(ig, k)/(teta(ig,k-1)+teta(ig,k)) + ri = n2(ig, k)/max(m2(ig,k), 1.E-10) + IF (ri0.) THEN + q2(ig, k) = (qpre+aa(ig,k)*qpre*qpre)**2 + ELSE + q2(ig, k) = (qpre/(1.-aa(ig,k)*qpre))**2 + END IF + ! else ! iflag_pbl=9 + ! if (aa(ig,k)*qpre.gt.0.9) then + ! q2(ig,k)=(qpre*10.)**2 + ! else + ! q2(ig,k)=(qpre/(1.-aa(ig,k)*qpre))**2 + ! endif + ! endif + q2(ig, k) = min(max(q2(ig,k),1.E-10), 1.E4) + END DO + END DO + + ELSE IF (iflag_pbl>=10) THEN + + shear(:,:)=0. + buoy(:,:)=0. + dissip(:,:)=0. + km(:,:)=0. + + IF (yamada4_num>=1) THEN + + DO k = 2, klev - 1 + DO ig=1,ngrid + q2(ig, k) = min(max(q2(ig,k),1.E-10), 1.E4) + km(ig, k) = l(ig, k)*sqrt(q2(ig,k))*sm(ig, k) + shear(ig,k)=km(ig, k)*m2(ig, k) + buoy(ig,k)=km(ig, k)*m2(ig, k)*(-1.*rif(ig,k)) +! dissip(ig,k)=min(max(((sqrt(q2(ig,k)))**3)/(b1*l(ig,k)),1.E-12),1.E4) + dissip(ig,k)=((sqrt(q2(ig,k)))**3)/(b1*l(ig,k)) + ENDDO + ENDDO + + IF (yamada4_num==1) THEN ! Schema du MAR tel quel + DO k = 2, klev - 1 + DO ig=1,ngrid + tkeprov=q2(ig,k)/ydeux + tkeprov= tkeprov* & + & (tkeprov+dt*(shear(ig,k)+max(0.,buoy(ig,k))))/ & + & (tkeprov+dt*((-1.)*min(0.,buoy(ig,k))+dissip(ig,k)+drgpro(ig,k)*tkeprov)) + q2(ig,k)=tkeprov*ydeux + ENDDO + ENDDO + ELSE IF (yamada4_num==2) THEN ! version modifiee avec integration exacte pour la dissipation + DO k = 2, klev - 1 + DO ig=1,ngrid + tkeprov=q2(ig,k)/ydeux + disseff=dissip(ig,k)-min(0.,buoy(ig,k)) + tkeprov = tkeprov/(1.+dt*disseff/(2.*tkeprov))**2 + tkeprov= tkeprov+dt*(shear(ig,k)+max(0.,buoy(ig,k))) + q2(ig,k)=tkeprov*ydeux + ! En cas stable, on traite la flotabilite comme la + ! dissipation, en supposant que buoy/q2^3 est constant. + ! Puis on prend la solution exacte + ENDDO + ENDDO + ELSE IF (yamada4_num==3) THEN ! version modifiee avec integration exacte pour la dissipation + DO k = 2, klev - 1 + DO ig=1,ngrid + tkeprov=q2(ig,k)/ydeux + disseff=dissip(ig,k)-min(0.,buoy(ig,k)) + tkeprov=tkeprov*exp(-dt*disseff/tkeprov) + tkeprov= tkeprov+dt*(shear(ig,k)+max(0.,buoy(ig,k))) + q2(ig,k)=tkeprov*ydeux + ! En cas stable, on traite la flotabilite comme la + ! dissipation, en supposant que buoy/q2^3 est constant. + ! Puis on prend la solution exacte + ENDDO + ENDDO + ELSE IF (yamada4_num==4) THEN ! version modifiee avec integration exacte pour la dissipation + DO k = 2, klev - 1 + DO ig=1,ngrid + tkeprov=q2(ig,k)/ydeux + tkeprov= tkeprov+dt*(shear(ig,k)+max(0.,buoy(ig,k))) + tkeprov= tkeprov* & + & tkeprov/ & + & (tkeprov+dt*((-1.)*min(0.,buoy(ig,k))+dissip(ig,k))) + q2(ig,k)=tkeprov*ydeux + ! En cas stable, on traite la flotabilite comme la + ! dissipation, en supposant que buoy/q2^3 est constant. + ! Puis on prend la solution exacte + ENDDO + ENDDO + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !! Attention, yamada4_num=5 est inexacte car néglige les termes de flottabilité + !! en conditions instables + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ELSE IF (yamada4_num==5) THEN ! version modifiee avec integration exacte pour la dissipation + DO k = 2, klev - 1 + DO ig=1,ngrid + tkeprov=q2(ig,k)/ydeux +!FC on ajoute la dissipation due aux arbres + disseff=dissip(ig,k)-min(0.,buoy(ig,k)) + drgpro(ig,k)*tkeprov + tkeexp=exp(-dt*disseff/tkeprov) +! on prend en compte la tke cree par les arbres + winds(ig,k)=sqrt(u(ig,k)**2+v(ig,k)**2) + tkeprov= (shear(ig,k)+ & + & drgpro(ig,k)*(winds(ig,k))**3)*tkeprov/disseff*(1.-tkeexp)+tkeprov*tkeexp + q2(ig,k)=tkeprov*ydeux + ! En cas stable, on traite la flotabilite comme la + ! dissipation, en supposant que buoy/q2^3 est constant. + ! Puis on prend la solution exacte + ENDDO + ENDDO + ELSE IF (yamada4_num==6) THEN ! version modifiee avec integration exacte pour la dissipation + DO k = 2, klev - 1 + DO ig=1,ngrid + ! En cas stable, on traite la flotabilite comme la + ! dissipation, en supposant que dissipeff/TKE est constant. + ! Puis on prend la solution exacte + ! With drag and dissipation from high vegetation (EV & FC, 05/10/2020) + winds(ig,k)=sqrt(u(ig,k)**2+v(ig,k)**2) + tkeprov=q2(ig,k)/ydeux + tkeprov=tkeprov+max(buoy(ig,k)+shear(ig,k)+drgpro(ig,k)*(winds(ig,k))**3,0.)*dt + disseff=dissip(ig,k)-min(0.,buoy(ig,k)+shear(ig,k)+drgpro(ig,k)*(winds(ig,k))**3) + drgpro(ig,k)*tkeprov + tkeexp=exp(-dt*disseff/tkeprov) + tkeprov= tkeprov*tkeexp + q2(ig,k)=tkeprov*ydeux + + ENDDO + ENDDO + ENDIF + + DO k = 2, klev - 1 + DO ig=1,ngrid + q2(ig, k) = min(max(q2(ig,k),1.E-10), 1.E4) + ENDDO + ENDDO + + ELSE + + DO k = 2, klev - 1 + km(1:ngrid, k) = l(1:ngrid, k)*sqrt(q2(1:ngrid,k))*sm(1:ngrid, k) + q2(1:ngrid, k) = q2(1:ngrid, k) + ydeux*dt*km(1:ngrid, k)*m2(1:ngrid, k)*(1.-rif(1:ngrid,k)) +! q2(1:ngrid, k) = q2(1:ngrid, k) + dt*km(1:ngrid, k)*m2(1:ngrid, k)*(1.-rif(1:ngrid,k)) + q2(1:ngrid, k) = min(max(q2(1:ngrid,k),1.E-10), 1.E4) + q2(1:ngrid, k) = 1./(1./sqrt(q2(1:ngrid,k))+dt/(yun*l(1:ngrid,k)*b1)) +! q2(1:ngrid, k) = 1./(1./sqrt(q2(1:ngrid,k))+dt/(2*l(1:ngrid,k)*b1)) + q2(1:ngrid, k) = q2(1:ngrid, k)*q2(1:ngrid, k) + END DO + + ENDIF + + ELSE + abort_message='Cas nom prevu dans yamada4' + CALL abort_physic(modname,abort_message,1) + + END IF ! Fin du cas 8 + + + ! ==================================================================== + ! Calcul des coefficients de melange + ! ==================================================================== + + DO k = 2, klev + DO ig = 1, ngrid + zq = sqrt(q2(ig,k)) + km(ig, k) = l(ig, k)*zq*sm(ig, k) ! For momentum + kn(ig, k) = km(ig, k)*alpha(ig, k) ! For scalars + kq(ig, k) = l(ig, k)*zq*0.2 ! For TKE + END DO + END DO + + + !==================================================================== + ! Transport diffusif vertical de la TKE par la TKE + !==================================================================== + + + ! initialize near-surface and top-layer mixing coefficients + !........................................................... + + kq(1:ngrid, 1) = kq(1:ngrid, 2) ! constant (ie no gradient) near the surface + kq(1:ngrid, klev+1) = 0 ! zero at the top + + ! Transport diffusif vertical de la TKE. + !....................................... + + IF (iflag_vdif_q2==1) THEN + q2(1:ngrid, 1) = q2(1:ngrid, 2) + CALL vdif_q2(dt, g, rconst, ngrid, plev, temp, kq, q2) + END IF + + + !==================================================================== + ! Traitement particulier pour les cas tres stables, introduction d'une + ! longueur de m??lange minimale + !==================================================================== + ! + ! Reference: Local versus Nonlocal boundary-layer diffusion in a global climate model + ! Holtslag A.A.M. and Boville B.A. + ! J. Clim., 6, 1825-1842, 1993 + + + IF (hboville) THEN + + + IF (prt_level>1) THEN + WRITE(lunout,*) 'YAMADA4 0' + END IF + + DO ig = 1, ngrid + coriol(ig) = 1.E-4 + pblhmin(ig) = 0.07*ustar(ig)/max(abs(coriol(ig)), 2.546E-5) + END DO + + IF (1==1) THEN + IF (iflag_pbl==8 .OR. iflag_pbl==10) THEN + + DO k = 2, klev + DO ig = 1, ngrid + IF (teta(ig,2)>teta(ig,1)) THEN + qmin = ustar(ig)*(max(1.-zlev(ig,k)/pblhmin(ig),0.))**2 + kmin = kap*zlev(ig, k)*qmin + ELSE + kmin = -1. ! kmin n'est utilise que pour les SL stables. + END IF + IF (kn(ig,k)teta(ig,1)) THEN + qmin = ustar(ig)*(max(1.-zlev(ig,k)/pblhmin(ig),0.))**2 + kmin = kap*zlev(ig, k)*qmin + ELSE + kmin = -1. ! kmin n'est utilise que pour les SL stables. + END IF + IF (kn(ig,k)1) THEN + WRITE(lunout,*)'YAMADA4 1' + END IF !(prt_level>1) THEN + + + !====================================================== + ! Estimations de w'2 et T'2 d'apres Abdela et McFarlane + !====================================================== + ! + ! Reference: A New Second-Order Turbulence Closure Scheme for the Planetary Boundary Layer + ! Abdella K and McFarlane N + ! J. Atmos. Sci., 54, 1850-1867, 1997 + + ! Diagnostique pour stokage + !.......................... + + IF (1==0) THEN + rino = rif + smyam(1:ngrid, 1) = 0. + styam(1:ngrid, 1) = 0. + lyam(1:ngrid, 1) = 0. + knyam(1:ngrid, 1) = 0. + w2yam(1:ngrid, 1) = 0. + t2yam(1:ngrid, 1) = 0. + + smyam(1:ngrid, 2:klev) = sm(1:ngrid, 2:klev) + styam(1:ngrid, 2:klev) = sm(1:ngrid, 2:klev)*alpha(1:ngrid, 2:klev) + lyam(1:ngrid, 2:klev) = l(1:ngrid, 2:klev) + knyam(1:ngrid, 2:klev) = kn(1:ngrid, 2:klev) + + + ! Calcul de w'2 et T'2 + !....................... + + w2yam(1:ngrid, 2:klev) = q2(1:ngrid, 2:klev)*0.24 + & + lyam(1:ngrid, 2:klev)*5.17*kn(1:ngrid, 2:klev)*n2(1:ngrid, 2:klev)/ & + sqrt(q2(1:ngrid,2:klev)) + + t2yam(1:ngrid, 2:klev) = 9.1*kn(1:ngrid, 2:klev)* & + dtetadz(1:ngrid, 2:klev)**2/sqrt(q2(1:ngrid,2:klev))* & + lyam(1:ngrid, 2:klev) + END IF + + + +!============================================================================ +! Mise a jour de la tke +!============================================================================ + + IF (new_yamada4) THEN + DO k=1,klev+1 + tke(1:ngrid,k)=q2(1:ngrid,k)/ydeux + ENDDO + ELSE + DO k=1,klev+1 + tke(1:ngrid,k)=q2(1:ngrid,k) + ENDDO + ENDIF + + +!============================================================================ +! Diagnostique de la dissipation et vitesse verticale +!============================================================================ + +! Diagnostics + + eps(:,:)=0. +!ym wprime(1:ngrid,:,nsrf)=0. + DO k=2,klev + DO ig=1,ngrid + eps(ig,k)=dissip(ig,k) + jg=ni(ig) + wprime(jg,k,nsrf)=sqrt(MAX(1./3*q2(ig,k),0.)) + ENDDO + ENDDO + + +!============================================================================= + + RETURN + + +END SUBROUTINE yamada4 + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +SUBROUTINE vdif_q2(timestep, gravity, rconst, ngrid, plev, temp, kmy, q2) +!$gpum horizontal ngrid + USE dimphy, only : klev + IMPLICIT NONE + +! vdif_q2: subroutine qui calcule la diffusion de la TKE par la TKE +! avec un schema implicite en temps avec +! inversion d'un syst??me tridiagonal +! +! Reference: Description of the interface with the surface and +! the computation of the turbulet diffusion in LMDZ +! Technical note on LMDZ +! Dufresne, J-L, Ghattas, J. and Grandpeix, J-Y +! +!============================================================================ +! Declarations +!============================================================================ + + REAL plev(ngrid, klev+1) + REAL temp(ngrid, klev) + REAL timestep + REAL gravity, rconst + REAL kstar(ngrid, klev+1), zz + REAL kmy(ngrid, klev+1) + REAL q2(ngrid, klev+1) + REAL deltap(ngrid, klev+1) + REAL denom(ngrid, klev+1), alpha(ngrid, klev+1), beta(ngrid, klev+1) + INTEGER ngrid + + INTEGER i, k + + +!========================================================================= +! Calcul +!========================================================================= + + DO k = 1, klev + DO i = 1, ngrid + zz = (plev(i,k)+plev(i,k+1))*gravity/(rconst*temp(i,k)) + kstar(i, k) = 0.125*(kmy(i,k+1)+kmy(i,k))*zz*zz/ & + (plev(i,k)-plev(i,k+1))*timestep + END DO + END DO + + DO k = 2, klev + DO i = 1, ngrid + deltap(i, k) = 0.5*(plev(i,k-1)-plev(i,k+1)) + END DO + END DO + DO i = 1, ngrid + deltap(i, 1) = 0.5*(plev(i,1)-plev(i,2)) + deltap(i, klev+1) = 0.5*(plev(i,klev)-plev(i,klev+1)) + denom(i, klev+1) = deltap(i, klev+1) + kstar(i, klev) + alpha(i, klev+1) = deltap(i, klev+1)*q2(i, klev+1)/denom(i, klev+1) + beta(i, klev+1) = kstar(i, klev)/denom(i, klev+1) + END DO + + DO k = klev, 2, -1 + DO i = 1, ngrid + denom(i, k) = deltap(i, k) + (1.-beta(i,k+1))*kstar(i, k) + & + kstar(i, k-1) + alpha(i, k) = (q2(i,k)*deltap(i,k)+kstar(i,k)*alpha(i,k+1))/denom(i, k) + beta(i, k) = kstar(i, k-1)/denom(i, k) + END DO + END DO + + ! Si on recalcule q2(1) + !....................... + IF (1==0) THEN + DO i = 1, ngrid + denom(i, 1) = deltap(i, 1) + (1-beta(i,2))*kstar(i, 1) + q2(i, 1) = (q2(i,1)*deltap(i,1)+kstar(i,1)*alpha(i,2))/denom(i, 1) + END DO + END IF + + + DO k = 2, klev + 1 + DO i = 1, ngrid + q2(i, k) = alpha(i, k) + beta(i, k)*q2(i, k-1) + END DO + END DO + + RETURN +END SUBROUTINE vdif_q2 +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + + + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + SUBROUTINE vdif_q2e(timestep, gravity, rconst, ngrid, plev, temp, kmy, q2) +!$gpum horizontal ngrid + USE dimphy, only : klev + IMPLICIT NONE + +! vdif_q2e: subroutine qui calcule la diffusion de TKE par la TKE +! avec un schema explicite en temps + + +!==================================================== +! Declarations +!==================================================== + + REAL plev(ngrid, klev+1) + REAL temp(ngrid, klev) + REAL timestep + REAL gravity, rconst + REAL kstar(ngrid, klev+1), zz + REAL kmy(ngrid, klev+1) + REAL q2(ngrid, klev+1) + REAL deltap(ngrid, klev+1) + REAL denom(ngrid, klev+1), alpha(ngrid, klev+1), beta(ngrid, klev+1) + INTEGER ngrid + INTEGER i, k + + +!================================================== +! Calcul +!================================================== + + DO k = 1, klev + DO i = 1, ngrid + zz = (plev(i,k)+plev(i,k+1))*gravity/(rconst*temp(i,k)) + kstar(i, k) = 0.125*(kmy(i,k+1)+kmy(i,k))*zz*zz/ & + (plev(i,k)-plev(i,k+1))*timestep + END DO + END DO + + DO k = 2, klev + DO i = 1, ngrid + deltap(i, k) = 0.5*(plev(i,k-1)-plev(i,k+1)) + END DO + END DO + DO i = 1, ngrid + deltap(i, 1) = 0.5*(plev(i,1)-plev(i,2)) + deltap(i, klev+1) = 0.5*(plev(i,klev)-plev(i,klev+1)) + END DO + + DO k = klev, 2, -1 + DO i = 1, ngrid + q2(i, k) = q2(i, k) + (kstar(i,k)*(q2(i,k+1)-q2(i, & + k))-kstar(i,k-1)*(q2(i,k)-q2(i,k-1)))/deltap(i, k) + END DO + END DO + + DO i = 1, ngrid + q2(i, 1) = q2(i, 1) + (kstar(i,1)*(q2(i,2)-q2(i,1)))/deltap(i, 1) + q2(i, klev+1) = q2(i, klev+1) + (-kstar(i,klev)*(q2(i,klev+1)-q2(i, & + klev)))/deltap(i, klev+1) + END DO + + RETURN +END SUBROUTINE vdif_q2e + +!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + +SUBROUTINE mixinglength(ni, nsrf, ngrid,iflag_pbl,pbl_lmixmin_alpha,lmixmin,zlay,zlev,u,v,q2,n2, lmix) +!$gpum horizontal ngrid + + + USE dimphy, only : klev + USE yamada_ini_mod, only : l0 + USE phys_state_var_mod, only: zstd, zsig, zmea + USE phys_local_var_mod, only: l_mixmin, l_mix + USE yamada_ini_mod, only : kap, kapb + + ! zstd: ecart type de la'altitud e sous-maille + ! zmea: altitude moyenne sous maille + ! zsig: pente moyenne de le maille + + !USE geometry_mod, only: cell_area + ! aire_cell: aire de la maille + + IMPLICIT NONE +!************************************************************************* +! Subrourine qui calcule la longueur de m??lange dans le sch??ma de turbulence +! avec la formule de Blackadar +! Calcul d'un minimum en fonction de l'orographie sous-maille: +! L'id??e est la suivante: plus il y a de relief, plus il y a du m??lange +! induit par les circulations meso et submeso ??chelles. +! +! References: * The vertical distribution of wind and turbulent exchange in a neutral atmosphere +! Blackadar A.K. +! J. Geophys. Res., 64, No 8, 1962 +! +! * An evaluation of neutral and convective planetary boundary-layer parametrisations relative +! to large eddy simulations +! Ayotte K et al +! Boundary Layer Meteorology, 79, 131-175, 1996 +! +! +! * Local Similarity in the Stable Boundary Layer and Mixing length Approaches: consistency of concepts +! Van de Wiel B.J.H et al +! Boundary-Lay Meteorol, 128, 103-166, 2008 +! +! +! Histoire: +!---------- +! * premi??re r??daction, Etienne et Frederic, 09/06/2016 +! +! *********************************************************************** + +!================================================================== +! Declarations +!================================================================== + +! Inputs +!------- + INTEGER ni(ngrid) ! indice sur la grille original (non restreinte) + INTEGER nsrf ! Type de surface + INTEGER ngrid ! Nombre de points concern??s sur l'horizontal + INTEGER iflag_pbl ! Choix du sch??ma de turbulence + REAL pbl_lmixmin_alpha ! on active ou non le calcul de la longueur de melange minimum en fonction du relief + REAL lmixmin ! Minimum absolu de la longueur de m??lange + REAL zlay(ngrid, klev) ! altitude du centre de la couche + REAL zlev(ngrid, klev+1) ! atitude de l'interface inf??rieure de la couche + REAL u(ngrid, klev) ! vitesse du vent zonal + REAL v(ngrid, klev) ! vitesse du vent meridional + REAL q2(ngrid, klev+1) ! energie cin??tique turbulente + REAL n2(ngrid, klev+1) ! frequence de Brunt-Vaisala + +!In/out +!------- + +! Outputs +!--------- + + REAL lmix(ngrid, klev+1) ! Longueur de melange + + +! Local +!------- + + INTEGER ig,jg, k + REAL h_oro(ngrid) + REAL hlim(ngrid) + REAL zq + REAL sq(ngrid), sqz(ngrid) + REAL fl, zzz, zl0, zq2, zn2 + REAL famorti, zzzz, zh_oro, zhlim + REAL l1(ngrid, klev+1), l2(ngrid,klev+1) + REAL winds(ngrid, klev) + REAL xcell + REAL zstdslope(ngrid) + REAL lmax + REAL l2strat, l2neutre, extent + REAL l2limit(ngrid) +!=============================================================== +! Fonctions utiles +!=============================================================== + +! Calcul de l suivant la formule de Blackadar 1962 adapt??e par Ayotte 1996 +!.......................................................................... + +!ym il ya a des gens qui font du code avec leur pieds => n'importe quoi ! +!ym fl(zzz, zl0, zq2, zn2) = max(min(l0(ig)*kap*zlev(ig, & +!ym k)/(kap*zlev(ig,k)+l0(ig)),0.5*sqrt(q2(ig,k))/sqrt( & +!ym max(n2(ig,k),1.E-10))), 1.E-5) + + fl(zzz, zl0, zq2, zn2) = max(min(zl0*kap*zzz/(kap*zzz+zl0),0.5*sqrt(zq2)/sqrt(max(zn2,1.E-10))), 1.E-5) + + + +! Fonction d'amortissement de la turbulence au dessus de la montagne +! On augmente l'amortissement en diminuant la valeur de hlim (extent) dans le code +!..................................................................... + + famorti(zzzz, zh_oro, zhlim)=(-1.)*ATAN((zzzz-zh_oro)/(zhlim-zh_oro))*2./3.1416+1. + + IF (ngrid==0) RETURN + + +!===================================================================== +! CALCUL de la LONGUEUR de m??lange suivant BLACKADAR: l1 +!===================================================================== + + l1(1:ngrid,:)=0. + IF (iflag_pbl==8 .OR. iflag_pbl==10) THEN + + + ! Iterative computation of l0 + ! This version is kept for iflag_pbl only for convergence + ! with NPv3.1 Cmip5 simulations + !................................................................... + + DO ig = 1, ngrid + sq(ig) = 1.E-10 + sqz(ig) = 1.E-10 + END DO + DO k = 2, klev - 1 + DO ig = 1, ngrid + zq = sqrt(q2(ig,k)) + sqz(ig) = sqz(ig) + zq*zlev(ig, k)*(zlay(ig,k)-zlay(ig,k-1)) + sq(ig) = sq(ig) + zq*(zlay(ig,k)-zlay(ig,k-1)) + END DO + END DO + DO ig = 1, ngrid + l0(ig) = 0.2*sqz(ig)/sq(ig) + END DO + DO k = 2, klev + DO ig = 1, ngrid + l1(ig, k) = fl(zlev(ig,k), l0(ig), q2(ig,k), n2(ig,k)) + END DO + END DO + + ELSE + + + ! In all other case, the assymptotic mixing length l0 is imposed (150m) + !...................................................................... + + l0(1:ngrid) = 150. + DO k = 2, klev + DO ig = 1, ngrid + l1(ig, k) = fl(zlev(ig,k), l0(ig), q2(ig,k), n2(ig,k)) + END DO + END DO + + END IF + +!=========================================================================================== +! CALCUL d'une longueur de melange minimum en fonctions de la topographie sous maille: l2 +! si pbl_lmixmin_alpha=TRUE et si on se trouve sur de la terre ( pas actif sur les +! glacier, la glace de mer et les oc??ans) +!=========================================================================================== + + l2(1:ngrid,:)=0.0 +!YM uncompressed variable, setting to 0 in pre_pbl_sutf +!YM l_mixmin(1:ngrid,:,nsrf)=0. +!YM l_mix(1:ngrid,:,nsrf)=0. + hlim(1:ngrid)=0. + + IF (nsrf .EQ. 1) THEN + +! coefficients +!-------------- + + extent=2. ! On ??tend l'impact du relief jusqu'?? extent*h, extent >1. + lmax=150. ! Longueur de m??lange max dans l'absolu + +! calculs +!--------- + + DO ig=1,ngrid + + ! On calcule la hauteur du relief + !................................. + ! On ne peut pas prendre zstd seulement pour caracteriser le relief sous maille + ! car sur un terrain pentu mais sans relief, zstd est non nul (comme en Antarctique, C. Genthon) + ! On corrige donc zstd avec l'ecart type de l'altitude dans la maille sans relief + ! (en gros, une maille de taille xcell avec une pente constante zstdslope) + jg=ni(ig) +! IF (zsig(jg) .EQ. 0.) THEN +! zstdslope(ig)=0. +! ELSE +! xcell=sqrt(cell_area(jg)) +! zstdslope(ig)=max((xcell*zsig(jg)-zmea(jg))**3 /(3.*zsig(jg)),0.) +! zstdslope(ig)=sqrt(zstdslope(ig)) +! END IF + +! h_oro(ig)=max(zstd(jg)-zstdslope(ig),0.) ! Hauteur du relief + h_oro(ig)=zstd(jg) + hlim(ig)=extent*h_oro(ig) + ENDDO + + l2limit(1:ngrid)=0. + + DO k=2,klev + DO ig=1,ngrid + winds(ig,k)=sqrt(u(ig,k)**2+v(ig,k)**2) + IF (zlev(ig,k) .LE. h_oro(ig)) THEN ! sous l'orographie + l2strat= kapb*pbl_lmixmin_alpha*winds(ig,k)/sqrt(max(n2(ig,k),1.E-10)) ! si stratifi??, amplitude d'oscillation * kappab (voir Van de Wiel et al 2008) + l2neutre=kap*zlev(ig,k)*h_oro(ig)/(kap*zlev(ig,k)+h_oro(ig)) ! Dans le cas neutre, formule de blackadar. tend asymptotiquement vers h + l2neutre=MIN(l2neutre,lmax) ! On majore par lmax + l2limit(ig)=MIN(l2neutre,l2strat) ! Calcule de l2 (minimum de la longueur en cas neutre et celle en situation stratifi??e) + l2(ig,k)=l2limit(ig) + + ELSE IF (zlev(ig,k) .LE. hlim(ig)) THEN ! Si on est au dessus des montagnes, mais affect?? encore par elles + + ! Au dessus des montagnes, on prend la l2limit au sommet des montagnes + ! (la derni??re calcul??e dans la boucle k, vu que k est un indice croissant avec z) + ! et on multiplie l2limit par une fonction qui d??croit entre h et hlim + l2(ig,k)=l2limit(ig)*famorti(zlev(ig,k),h_oro(ig), hlim(ig)) + ELSE ! Au dessus de extent*h, on prend l2=l0 + l2(ig,k)=0. + END IF + ENDDO + ENDDO + ENDIF ! pbl_lmixmin_alpha + +!================================================================================== +! On prend le max entre la longueur de melange de blackadar et celle calcul??e +! en fonction de la topographie +!=================================================================================== + + + DO k=1,klev+1 + DO ig=1,ngrid + lmix(ig,k)=MAX(MAX(l1(ig,k), l2(ig,k)),lmixmin) + ENDDO + ENDDO + +! Diagnostics + + DO k=1,klev+1 + DO ig=1,ngrid + jg=ni(ig) + l_mix(jg,k,nsrf)=lmix(ig,k) + l_mixmin(jg,k,nsrf)=MAX(l2(ig,k),lmixmin) + ENDDO + ENDDO + + + +END SUBROUTINE mixinglength + +END MODULE yamada4_mod Index: LMDZ6/trunk/libf/phylmd/yamada_c.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/yamada_c.F90 (revision 6047) +++ (revision ) @@ -1,490 +1,0 @@ -! -! $Header$ -! -MODULE yamada_c_mod - PRIVATE - - INTEGER, SAVE :: iflag_tke_diff=0 - !$OMP THREADPRIVATE(iflag_tke_diff) - - PUBLIC :: yamada_c_init, yamada_c - -CONTAINS - - SUBROUTINE yamada_c_init - USE ioipsl_getin_p_mod, ONLY : getin_p - IMPLICIT NONE - - CALL getin_p('iflag_tke_diff',iflag_tke_diff) - - END SUBROUTINE yamada_c_init - - - SUBROUTINE yamada_c(klon, ngrid,timestep,plev,play & - & ,pu,pv,pt,d_u,d_v,d_t,cd,q2,km,kn,kq,d_t_diss,ustar & - & ,iflag_pbl) -!$gpum horizontal klon ngrid - USE dimphy, ONLY: klev - USE print_control_mod, ONLY: prt_level - USE yamada4_mod, ONLY : vdif_q2 - USE yomcst_mod_h -IMPLICIT NONE - -! -! timestep : pas de temps -! g : g -! zlev : altitude a chaque niveau (interface inferieure de la couche -! de meme indice) -! zlay : altitude au centre de chaque couche -! u,v : vitesse au centre de chaque couche -! (en entree : la valeur au debut du pas de temps) -! teta : temperature potentielle au centre de chaque couche -! (en entree : la valeur au debut du pas de temps) -! cd : cdrag -! (en entree : la valeur au debut du pas de temps) -! q2 : $q^2$ au bas de chaque couche -! (en entree : la valeur au debut du pas de temps) -! (en sortie : la valeur a la fin du pas de temps) -! km : diffusivite turbulente de quantite de mouvement (au bas de chaque -! couche) -! (en sortie : la valeur a la fin du pas de temps) -! kn : diffusivite turbulente des scalaires (au bas de chaque couche) -! (en sortie : la valeur a la fin du pas de temps) -! -! iflag_pbl doit valoir entre 6 et 9 -! l=6, on prend systematiquement une longueur d'equilibre -! iflag_pbl=6 : MY 2.0 -! iflag_pbl=7 : MY 2.0.Fournier -! iflag_pbl=8/9 : MY 2.5 -! iflag_pbl=8 with special obsolete treatments for convergence -! with Cmpi5 NPv3.1 simulations -! iflag_pbl=10/11 : New scheme M2 and N2 explicit and dissiptation exact -! iflag_pbl=12 = 11 with vertical diffusion off q2 -! -! 2013/04/01 (FH hourdin@lmd.jussieu.fr) -! Correction for very stable PBLs (iflag_pbl=10 and 11) -! iflag_pbl=8 converges numerically with NPv3.1 -! iflag_pbl=11 -> the model starts with NP from start files created by ce0l -! -> the model can run with longer time-steps. -!....................................................................... - INTEGER, INTENT(IN) :: klon - REAL, DIMENSION(klon,klev) :: d_u,d_v,d_t - REAL, DIMENSION(klon,klev) :: pu,pv,pt - REAL, DIMENSION(klon,klev) :: d_t_diss - - REAL timestep - real plev(klon,klev+1) - real play(klon,klev) - real ustar(klon) - real kmin,qmin,pblhmin(klon),coriol(klon) - REAL zlev(klon,klev+1) - REAL zlay(klon,klev) - REAL zu(klon,klev) - REAL zv(klon,klev) - REAL zt(klon,klev) - REAL teta(klon,klev) - REAL cd(klon) - REAL q2(klon,klev+1),qpre - REAL unsdz(klon,klev) - REAL unsdzdec(klon,klev+1) - - REAL km(klon,klev) - REAL kmpre(klon,klev+1),tmp2 - REAL mpre(klon,klev+1) - REAL kn(klon,klev) - REAL kq(klon,klev) - real ff(klon,klev+1),delta(klon,klev+1) - real aa(klon,klev+1),aa0,aa1 - integer iflag_pbl,ngrid - integer nlay,nlev - - integer ig,k - - - real ri,zrif,zalpha,zsm,zsn - real rif(klon,klev+1),sm(klon,klev+1),alpha(klon,klev) - - real m2(klon,klev+1),dz(klon,klev+1),zq,n2(klon,klev+1) - REAL, DIMENSION(klon,klev+1) :: km2,kn2,sqrtq - real dtetadz(klon,klev+1) - real m2cstat,mcstat,kmcstat - real l(klon,klev+1) - real leff(klon,klev+1) - real l0(klon) - real sq(klon),sqz(klon),zz(klon,klev+1) - integer iter - - real, parameter :: ric=0.195,rifc=0.191,b1=16.6,kap=0.4 - real frif,falpha,fsm - real fl,zzz,zl0,zq2,zn2 - - real rino(klon,klev+1),smyam(klon,klev),styam(klon,klev) - real lyam(klon,klev),knyam(klon,klev) - real w2yam(klon,klev),t2yam(klon,klev) - - CHARACTER(len=20),PARAMETER :: modname="yamada_c" -REAL, DIMENSION(klon,klev+1) :: fluxu,fluxv,fluxt -REAL, DIMENSION(klon,klev+1) :: dddu,dddv,dddt -REAL, DIMENSION(klon,klev) :: exner,masse -REAL, DIMENSION(klon,klev+1) :: masseb,q2old,q2neg - LOGICAL okiophys - - frif(ri)=0.6588*(ri+0.1776-sqrt(ri*ri-0.3221*ri+0.03156)) - falpha(ri)=1.318*(0.2231-ri)/(0.2341-ri) - fsm(ri)=1.96*(0.1912-ri)*(0.2341-ri)/((1.-ri)*(0.2231-ri)) -!ym pas glop! pas glop! -!ym fl(zzz,zl0,zq2,zn2)= & -!ym & max(min(zl0(ig)*kap*zlev(ig,k)/(kap*zlev(ig,k)+l0(ig)) & -!ym & ,0.5*sqrt(q2(ig,k))/sqrt(max(n2(ig,k),1.e-10))) ,1.) - fl(zzz,zl0,zq2,zn2)= & - & max(min(zl0*kap*zzz/(kap*zzz+zl0) & - & ,0.5*sqrt(zq2)/sqrt(max(zn2,1.e-10))) ,1.) - - - okiophys=klon==1 - - IF (ngrid<=0) RETURN ! Bizarre : on n a pas ce probeleme pour coef_diff_turb - - nlay=klev - nlev=klev+1 - - -!------------------------------------------------------------------------- -! Computation of conservative source terms from the turbulent tendencies -!------------------------------------------------------------------------- - - - zalpha=0.5 ! Anciennement 0.5. Essayer de voir pourquoi ? - zu(:,:)=pu(:,:)+zalpha*d_u(:,:) - zv(:,:)=pv(:,:)+zalpha*d_v(:,:) - zt(:,:)=pt(:,:)+zalpha*d_t(:,:) - - do k=1,klev - exner(:,k)=(play(:,k)/plev(:,1))**RKAPPA - masse(:,k)=(plev(:,k)-plev(:,k+1))/RG - teta(:,k)=zt(:,k)/exner(:,k) - enddo - -! Atmospheric mass at layer interfaces, where the TKE is computed - masseb(:,:)=0. - do k=1,klev - masseb(:,k)=masseb(:,k)+masse(:,k) - masseb(:,k+1)=masseb(:,k+1)+masse(:,k) - enddo - masseb(:,:)=0.5*masseb(:,:) - - zlev(:,1)=0. - zlay(:,1)=RCPD*teta(:,1)*(1.-exner(:,1)) - do k=1,klev-1 - zlay(:,k+1)=zlay(:,k)+0.5*RCPD*(teta(:,k)+teta(:,k+1))*(exner(:,k)-exner(:,k+1))/RG - zlev(:,k+1)=0.5*(zlay(:,k)+zlay(:,k+1)) ! PASBO - ! ym bugfix : zlev(:,k) => zlev(:,k+1) - enddo - - fluxu(:,klev+1)=0. - fluxv(:,klev+1)=0. - fluxt(:,klev+1)=0. - - do k=klev,1,-1 - fluxu(:,k)=fluxu(:,k+1)+masse(:,k)*d_u(:,k) - fluxv(:,k)=fluxv(:,k+1)+masse(:,k)*d_v(:,k) - fluxt(:,k)=fluxt(:,k+1)+masse(:,k)*d_t(:,k)/exner(:,k) ! Flux de theta - enddo - - dddu(:,1)=2*zu(:,1)*fluxu(:,1) - dddv(:,1)=2*zv(:,1)*fluxv(:,1) - dddt(:,1)=(exner(:,1)-1.)*fluxt(:,1) - - do k=2,klev - dddu(:,k)=(zu(:,k)-zu(:,k-1))*fluxu(:,k) - dddv(:,k)=(zv(:,k)-zv(:,k-1))*fluxv(:,k) - dddt(:,k)=(exner(:,k)-exner(:,k-1))*fluxt(:,k) - enddo - dddu(:,klev+1)=0. - dddv(:,klev+1)=0. - dddt(:,klev+1)=0. - -#ifdef IOPHYS -if (okiophys) then - call iophys_ecrit('zlay',klev,'Geop','m',zlay) - call iophys_ecrit('teta',klev,'teta','K',teta) - call iophys_ecrit('temp',klev,'temp','K',zt) - call iophys_ecrit('pt',klev,'temp','K',pt) - call iophys_ecrit('pu',klev,'u','m/s',pu) - call iophys_ecrit('pv',klev,'v','m/s',pv) - call iophys_ecrit('d_u',klev,'d_u','m/s2',d_u) - call iophys_ecrit('d_v',klev,'d_v','m/s2',d_v) - call iophys_ecrit('d_t',klev,'d_t','K/s',d_t) - call iophys_ecrit('exner',klev,'exner','',exner) - call iophys_ecrit('masse',klev,'masse','',masse) - call iophys_ecrit('masseb',klev,'masseb','',masseb) -endif -#endif - - - - - -!....................................................................... -! les increments verticaux -!....................................................................... -! -!!!!!! allerte !!!!!c -!!!!!! zlev n'est pas declare a nlev !!!!!c -!!!!!! ----> - DO ig=1,ngrid - zlev(ig,nlev)=zlay(ig,nlay) & - & +( zlay(ig,nlay) - zlev(ig,nlev-1) ) - ENDDO -!!!!!! <---- -!!!!!! allerte !!!!!c -! - DO k=1,nlay - DO ig=1,ngrid - unsdz(ig,k)=1.E+0/(zlev(ig,k+1)-zlev(ig,k)) - ENDDO - ENDDO - DO ig=1,ngrid - unsdzdec(ig,1)=1.E+0/(zlay(ig,1)-zlev(ig,1)) - ENDDO - DO k=2,nlay - DO ig=1,ngrid - unsdzdec(ig,k)=1.E+0/(zlay(ig,k)-zlay(ig,k-1)) - ENDDO - ENDDO - DO ig=1,ngrid - unsdzdec(ig,nlay+1)=1.E+0/(zlev(ig,nlay+1)-zlay(ig,nlay)) - ENDDO -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! Computing M^2, N^2, Richardson numbers, stability functions -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - - do k=2,klev - do ig=1,ngrid - dz(ig,k)=zlay(ig,k)-zlay(ig,k-1) - m2(ig,k)=((zu(ig,k)-zu(ig,k-1))**2+(zv(ig,k)-zv(ig,k-1))**2)/(dz(ig,k)*dz(ig,k)) - dtetadz(ig,k)=(teta(ig,k)-teta(ig,k-1))/dz(ig,k) - n2(ig,k)=RG*2.*dtetadz(ig,k)/(teta(ig,k-1)+teta(ig,k)) -! n2(ig,k)=0. - ri=n2(ig,k)/max(m2(ig,k),1.e-10) - if (ri.lt.ric) then - rif(ig,k)=frif(ri) - else - rif(ig,k)=rifc - endif - if(rif(ig,k)<0.16) then - alpha(ig,k)=falpha(rif(ig,k)) - sm(ig,k)=fsm(rif(ig,k)) - else - alpha(ig,k)=1.12 - sm(ig,k)=0.085 - endif - zz(ig,k)=b1*m2(ig,k)*(1.-rif(ig,k))*sm(ig,k) - enddo - enddo - - - -!==================================================================== -! Computing the mixing length -!==================================================================== - -! Mise a jour de l0 - if (iflag_pbl==8.or.iflag_pbl==10) then - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! Iterative computation of l0 -! This version is kept for iflag_pbl only for convergence -! with NPv3.1 Cmip5 simulations -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - do ig=1,ngrid - sq(ig)=1.e-10 - sqz(ig)=1.e-10 - enddo - do k=2,klev-1 - do ig=1,ngrid - zq=sqrt(q2(ig,k)) - sqz(ig)=sqz(ig)+zq*zlev(ig,k)*(zlay(ig,k)-zlay(ig,k-1)) - sq(ig)=sq(ig)+zq*(zlay(ig,k)-zlay(ig,k-1)) - enddo - enddo - do ig=1,ngrid - l0(ig)=0.2*sqz(ig)/sq(ig) - enddo - l(:,1) = 0. !ym <- fix unitialized level - l(:,klev+1) = 0. !ym <- fix unitialized level - do k=2,klev - do ig=1,ngrid - l(ig,k)=fl(zlev(ig,k),l0(ig),q2(ig,k),n2(ig,k)) - enddo - enddo -! print*,'L0 cas 8 ou 10 ',l0 - - else - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! In all other case, the assymptotic mixing length l0 is imposed (100m) -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - l0(:)=150. - l(:,1) = 0. !ym <- fix unitialized level - l(:,klev+1) = 0. !ym <- fix unitialized level - do k=2,klev - do ig=1,ngrid - l(ig,k)=fl(zlev(ig,k),l0(ig),q2(ig,k),n2(ig,k)) - enddo - enddo -! print*,'L0 cas autres ',l0 - - endif - - -#ifdef IOPHYS -if (okiophys) then -call iophys_ecrit('rif',klev,'Flux Richardson','m',rif(:,1:klev)) -call iophys_ecrit('m2',klev,'m2 ','m/s',m2(:,1:klev)) -call iophys_ecrit('Km2app',klev,'m2 conserv','m/s',km(:,1:klev)*m2(:,1:klev)) -call iophys_ecrit('Km',klev,'Km','m2/s',km(:,1:klev)) -endif -#endif - - -IF (iflag_pbl<20) then - ! For diagnostics only - RETURN - -ELSE - -! print*,'OK1' - -! Evolution of TKE under source terms K M2 and K N2 - leff(:,:)=max(l(:,:),1.) - -!################################################################## -!# IF (iflag_pbl==29) THEN -!# STOP'Ne pas utiliser iflag_pbl=29' -!# km2(:,:)=km(:,:)*m2(:,:) -!# kn2(:,:)=kn2(:,:)*rif(:,:) -!# ELSEIF (iflag_pbl==25) THEN -! VERSION AVEC LA TKE EN MILIEU DE COUCHE -!# STOP'Ne pas utiliser iflag_pbl=25' -!# DO k=1,klev -!# km2(:,k)=-0.5*(dddu(:,k)+dddv(:,k)+dddu(:,k+1)+dddv(:,k+1)) & -!# & /(masse(:,k)*timestep) -!# kn2(:,k)=rcpd*0.5*(dddt(:,k)+dddt(:,k+1))/(masse(:,k)*timestep) -!# leff(:,k)=0.5*(leff(:,k)+leff(:,k+1)) -!# ENDDO -!# km2(:,klev+1)=0. ; kn2(:,klev+1)=0. -!# ELSE -!################################################################# - - km2(:,:)=-(dddu(:,:)+dddv(:,:))/(masseb(:,:)*timestep) - kn2(:,:)=rcpd*dddt(:,:)/(masseb(:,:)*timestep) -! ENDIF - q2neg(:,:)=q2(:,:)+timestep*(km2(:,:)-kn2(:,:)) - q2(:,:)=min(max(q2neg(:,:),1.e-10),1.e4) - - -#ifdef IOPHYS -if (okiophys) then - call iophys_ecrit('km2',klev,'m2 conserv','m/s',km2(:,1:klev)) - call iophys_ecrit('kn2',klev,'n2 conserv','m/s',kn2(:,1:klev)) -endif -#endif - -! Dissipation of TKE - q2old(:,:)=q2(:,:) - q2(:,:)=1./(1./sqrt(q2(:,:))+timestep/(2*leff(:,:)*b1)) - q2(:,:)=q2(:,:)*q2(:,:) -! IF (iflag_pbl<=24) THEN - DO k=1,klev - d_t_diss(:,k)=(masseb(:,k)*(q2neg(:,k)-q2(:,k))+masseb(:,k+1)*(q2neg(:,k+1)-q2(:,k+1)))/(2.*rcpd*masse(:,k)) - ENDDO - -!################################################################### -! ELSE IF (iflag_pbl<=27) THEN -! DO k=1,klev -! d_t_diss(:,k)=(q2neg(:,k)-q2(:,k))/rcpd -! ENDDO -! ENDIF -! print*,'iflag_pbl ',d_t_diss -!################################################################### - - -! Compuation of stability functions -! IF (iflag_pbl/=29) THEN - DO k=1,klev - DO ig=1,ngrid - IF (ABS(km2(ig,k))<=1.e-20) THEN - rif(ig,k)=0. - ELSE - rif(ig,k)=min(kn2(ig,k)/km2(ig,k),rifc) - ENDIF - IF (rif(ig,k).lt.0.16) THEN - alpha(ig,k)=falpha(rif(ig,k)) - sm(ig,k)=fsm(rif(ig,k)) - else - alpha(ig,k)=1.12 - sm(ig,k)=0.085 - endif - ENDDO - ENDDO -! ENDIF - -! Computation of turbulent diffusivities -! IF (25<=iflag_pbl.and.iflag_pbl<=28) THEN -! DO k=2,klev -! sqrtq(:,k)=sqrt(0.5*(q2(:,k)+q2(:,k-1))) -! ENDDO -! ELSE - kq(:,:)=0. - DO k=1,klev - ! Coefficient au milieu des couches pour diffuser la TKE - kq(:,k)=0.5*leff(:,k)*sqrt(q2(:,k))*0.2 - ENDDO - -#ifdef IOPHYS -if (okiophys) then -call iophys_ecrit('q2b',klev,'KTE inter','m2/s',q2(:,1:klev)) -endif -#endif - - IF (iflag_tke_diff==1) THEN - CALL vdif_q2(timestep, RG, RD, ngrid, plev, pt, kq, q2) - ENDIF - - km(:,:)=0. - kn(:,:)=0. - DO k=1,klev - km(:,k)=leff(:,k)*sqrt(q2(:,k))*sm(:,k) - kn(:,k)=km(:,k)*alpha(:,k) - ENDDO - - -#ifdef IOPHYS -if (okiophys) then -call iophys_ecrit('mixingl',klev,'Mixing length','m',leff(:,1:klev)) -call iophys_ecrit('rife',klev,'Flux Richardson','m',rif(:,1:klev)) -call iophys_ecrit('q2f',klev,'KTE finale','m2/s',q2(:,1:klev)) -call iophys_ecrit('q2neg',klev,'KTE non bornee','m2/s',q2neg(:,1:klev)) -call iophys_ecrit('alpha',klev,'alpha','',alpha(:,1:klev)) -call iophys_ecrit('sm',klev,'sm','',sm(:,1:klev)) -call iophys_ecrit('q2f',klev,'KTE finale','m2/s',q2(:,1:klev)) -call iophys_ecrit('kmf',klev,'Kz final','m2/s',km(:,1:klev)) -call iophys_ecrit('knf',klev,'Kz final','m2/s',kn(:,1:klev)) -call iophys_ecrit('kqf',klev,'Kz final','m2/s',kq(:,1:klev)) -endif -#endif - - -ENDIF - - -! print*,'OK2' - RETURN - END SUBROUTINE yamada_c - -END MODULE yamada_c_mod Index: LMDZ6/trunk/libf/phylmd/yamada_c_mod.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/yamada_c_mod.F90 (revision 6048) +++ LMDZ6/trunk/libf/phylmd/yamada_c_mod.F90 (revision 6048) @@ -0,0 +1,490 @@ +! +! $Header$ +! +MODULE yamada_c_mod + PRIVATE + + INTEGER, SAVE :: iflag_tke_diff=0 + !$OMP THREADPRIVATE(iflag_tke_diff) + + PUBLIC :: yamada_c_init, yamada_c + +CONTAINS + + SUBROUTINE yamada_c_init + USE ioipsl_getin_p_mod, ONLY : getin_p + IMPLICIT NONE + + CALL getin_p('iflag_tke_diff',iflag_tke_diff) + + END SUBROUTINE yamada_c_init + + + SUBROUTINE yamada_c(klon, ngrid,timestep,plev,play & + & ,pu,pv,pt,d_u,d_v,d_t,cd,q2,km,kn,kq,d_t_diss,ustar & + & ,iflag_pbl) +!$gpum horizontal klon ngrid + USE dimphy, ONLY: klev + USE print_control_mod, ONLY: prt_level + USE yamada4_mod, ONLY : vdif_q2 + USE yomcst_mod_h +IMPLICIT NONE + +! +! timestep : pas de temps +! g : g +! zlev : altitude a chaque niveau (interface inferieure de la couche +! de meme indice) +! zlay : altitude au centre de chaque couche +! u,v : vitesse au centre de chaque couche +! (en entree : la valeur au debut du pas de temps) +! teta : temperature potentielle au centre de chaque couche +! (en entree : la valeur au debut du pas de temps) +! cd : cdrag +! (en entree : la valeur au debut du pas de temps) +! q2 : $q^2$ au bas de chaque couche +! (en entree : la valeur au debut du pas de temps) +! (en sortie : la valeur a la fin du pas de temps) +! km : diffusivite turbulente de quantite de mouvement (au bas de chaque +! couche) +! (en sortie : la valeur a la fin du pas de temps) +! kn : diffusivite turbulente des scalaires (au bas de chaque couche) +! (en sortie : la valeur a la fin du pas de temps) +! +! iflag_pbl doit valoir entre 6 et 9 +! l=6, on prend systematiquement une longueur d'equilibre +! iflag_pbl=6 : MY 2.0 +! iflag_pbl=7 : MY 2.0.Fournier +! iflag_pbl=8/9 : MY 2.5 +! iflag_pbl=8 with special obsolete treatments for convergence +! with Cmpi5 NPv3.1 simulations +! iflag_pbl=10/11 : New scheme M2 and N2 explicit and dissiptation exact +! iflag_pbl=12 = 11 with vertical diffusion off q2 +! +! 2013/04/01 (FH hourdin@lmd.jussieu.fr) +! Correction for very stable PBLs (iflag_pbl=10 and 11) +! iflag_pbl=8 converges numerically with NPv3.1 +! iflag_pbl=11 -> the model starts with NP from start files created by ce0l +! -> the model can run with longer time-steps. +!....................................................................... + INTEGER, INTENT(IN) :: klon + REAL, DIMENSION(klon,klev) :: d_u,d_v,d_t + REAL, DIMENSION(klon,klev) :: pu,pv,pt + REAL, DIMENSION(klon,klev) :: d_t_diss + + REAL timestep + real plev(klon,klev+1) + real play(klon,klev) + real ustar(klon) + real kmin,qmin,pblhmin(klon),coriol(klon) + REAL zlev(klon,klev+1) + REAL zlay(klon,klev) + REAL zu(klon,klev) + REAL zv(klon,klev) + REAL zt(klon,klev) + REAL teta(klon,klev) + REAL cd(klon) + REAL q2(klon,klev+1),qpre + REAL unsdz(klon,klev) + REAL unsdzdec(klon,klev+1) + + REAL km(klon,klev) + REAL kmpre(klon,klev+1),tmp2 + REAL mpre(klon,klev+1) + REAL kn(klon,klev) + REAL kq(klon,klev) + real ff(klon,klev+1),delta(klon,klev+1) + real aa(klon,klev+1),aa0,aa1 + integer iflag_pbl,ngrid + integer nlay,nlev + + integer ig,k + + + real ri,zrif,zalpha,zsm,zsn + real rif(klon,klev+1),sm(klon,klev+1),alpha(klon,klev) + + real m2(klon,klev+1),dz(klon,klev+1),zq,n2(klon,klev+1) + REAL, DIMENSION(klon,klev+1) :: km2,kn2,sqrtq + real dtetadz(klon,klev+1) + real m2cstat,mcstat,kmcstat + real l(klon,klev+1) + real leff(klon,klev+1) + real l0(klon) + real sq(klon),sqz(klon),zz(klon,klev+1) + integer iter + + real, parameter :: ric=0.195,rifc=0.191,b1=16.6,kap=0.4 + real frif,falpha,fsm + real fl,zzz,zl0,zq2,zn2 + + real rino(klon,klev+1),smyam(klon,klev),styam(klon,klev) + real lyam(klon,klev),knyam(klon,klev) + real w2yam(klon,klev),t2yam(klon,klev) + + CHARACTER(len=20),PARAMETER :: modname="yamada_c" +REAL, DIMENSION(klon,klev+1) :: fluxu,fluxv,fluxt +REAL, DIMENSION(klon,klev+1) :: dddu,dddv,dddt +REAL, DIMENSION(klon,klev) :: exner,masse +REAL, DIMENSION(klon,klev+1) :: masseb,q2old,q2neg + LOGICAL okiophys + + frif(ri)=0.6588*(ri+0.1776-sqrt(ri*ri-0.3221*ri+0.03156)) + falpha(ri)=1.318*(0.2231-ri)/(0.2341-ri) + fsm(ri)=1.96*(0.1912-ri)*(0.2341-ri)/((1.-ri)*(0.2231-ri)) +!ym pas glop! pas glop! +!ym fl(zzz,zl0,zq2,zn2)= & +!ym & max(min(zl0(ig)*kap*zlev(ig,k)/(kap*zlev(ig,k)+l0(ig)) & +!ym & ,0.5*sqrt(q2(ig,k))/sqrt(max(n2(ig,k),1.e-10))) ,1.) + fl(zzz,zl0,zq2,zn2)= & + & max(min(zl0*kap*zzz/(kap*zzz+zl0) & + & ,0.5*sqrt(zq2)/sqrt(max(zn2,1.e-10))) ,1.) + + + okiophys=klon==1 + + IF (ngrid<=0) RETURN ! Bizarre : on n a pas ce probeleme pour coef_diff_turb + + nlay=klev + nlev=klev+1 + + +!------------------------------------------------------------------------- +! Computation of conservative source terms from the turbulent tendencies +!------------------------------------------------------------------------- + + + zalpha=0.5 ! Anciennement 0.5. Essayer de voir pourquoi ? + zu(:,:)=pu(:,:)+zalpha*d_u(:,:) + zv(:,:)=pv(:,:)+zalpha*d_v(:,:) + zt(:,:)=pt(:,:)+zalpha*d_t(:,:) + + do k=1,klev + exner(:,k)=(play(:,k)/plev(:,1))**RKAPPA + masse(:,k)=(plev(:,k)-plev(:,k+1))/RG + teta(:,k)=zt(:,k)/exner(:,k) + enddo + +! Atmospheric mass at layer interfaces, where the TKE is computed + masseb(:,:)=0. + do k=1,klev + masseb(:,k)=masseb(:,k)+masse(:,k) + masseb(:,k+1)=masseb(:,k+1)+masse(:,k) + enddo + masseb(:,:)=0.5*masseb(:,:) + + zlev(:,1)=0. + zlay(:,1)=RCPD*teta(:,1)*(1.-exner(:,1)) + do k=1,klev-1 + zlay(:,k+1)=zlay(:,k)+0.5*RCPD*(teta(:,k)+teta(:,k+1))*(exner(:,k)-exner(:,k+1))/RG + zlev(:,k+1)=0.5*(zlay(:,k)+zlay(:,k+1)) ! PASBO + ! ym bugfix : zlev(:,k) => zlev(:,k+1) + enddo + + fluxu(:,klev+1)=0. + fluxv(:,klev+1)=0. + fluxt(:,klev+1)=0. + + do k=klev,1,-1 + fluxu(:,k)=fluxu(:,k+1)+masse(:,k)*d_u(:,k) + fluxv(:,k)=fluxv(:,k+1)+masse(:,k)*d_v(:,k) + fluxt(:,k)=fluxt(:,k+1)+masse(:,k)*d_t(:,k)/exner(:,k) ! Flux de theta + enddo + + dddu(:,1)=2*zu(:,1)*fluxu(:,1) + dddv(:,1)=2*zv(:,1)*fluxv(:,1) + dddt(:,1)=(exner(:,1)-1.)*fluxt(:,1) + + do k=2,klev + dddu(:,k)=(zu(:,k)-zu(:,k-1))*fluxu(:,k) + dddv(:,k)=(zv(:,k)-zv(:,k-1))*fluxv(:,k) + dddt(:,k)=(exner(:,k)-exner(:,k-1))*fluxt(:,k) + enddo + dddu(:,klev+1)=0. + dddv(:,klev+1)=0. + dddt(:,klev+1)=0. + +#ifdef IOPHYS +if (okiophys) then + call iophys_ecrit('zlay',klev,'Geop','m',zlay) + call iophys_ecrit('teta',klev,'teta','K',teta) + call iophys_ecrit('temp',klev,'temp','K',zt) + call iophys_ecrit('pt',klev,'temp','K',pt) + call iophys_ecrit('pu',klev,'u','m/s',pu) + call iophys_ecrit('pv',klev,'v','m/s',pv) + call iophys_ecrit('d_u',klev,'d_u','m/s2',d_u) + call iophys_ecrit('d_v',klev,'d_v','m/s2',d_v) + call iophys_ecrit('d_t',klev,'d_t','K/s',d_t) + call iophys_ecrit('exner',klev,'exner','',exner) + call iophys_ecrit('masse',klev,'masse','',masse) + call iophys_ecrit('masseb',klev,'masseb','',masseb) +endif +#endif + + + + + +!....................................................................... +! les increments verticaux +!....................................................................... +! +!!!!!! allerte !!!!!c +!!!!!! zlev n'est pas declare a nlev !!!!!c +!!!!!! ----> + DO ig=1,ngrid + zlev(ig,nlev)=zlay(ig,nlay) & + & +( zlay(ig,nlay) - zlev(ig,nlev-1) ) + ENDDO +!!!!!! <---- +!!!!!! allerte !!!!!c +! + DO k=1,nlay + DO ig=1,ngrid + unsdz(ig,k)=1.E+0/(zlev(ig,k+1)-zlev(ig,k)) + ENDDO + ENDDO + DO ig=1,ngrid + unsdzdec(ig,1)=1.E+0/(zlay(ig,1)-zlev(ig,1)) + ENDDO + DO k=2,nlay + DO ig=1,ngrid + unsdzdec(ig,k)=1.E+0/(zlay(ig,k)-zlay(ig,k-1)) + ENDDO + ENDDO + DO ig=1,ngrid + unsdzdec(ig,nlay+1)=1.E+0/(zlev(ig,nlay+1)-zlay(ig,nlay)) + ENDDO +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Computing M^2, N^2, Richardson numbers, stability functions +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + + do k=2,klev + do ig=1,ngrid + dz(ig,k)=zlay(ig,k)-zlay(ig,k-1) + m2(ig,k)=((zu(ig,k)-zu(ig,k-1))**2+(zv(ig,k)-zv(ig,k-1))**2)/(dz(ig,k)*dz(ig,k)) + dtetadz(ig,k)=(teta(ig,k)-teta(ig,k-1))/dz(ig,k) + n2(ig,k)=RG*2.*dtetadz(ig,k)/(teta(ig,k-1)+teta(ig,k)) +! n2(ig,k)=0. + ri=n2(ig,k)/max(m2(ig,k),1.e-10) + if (ri.lt.ric) then + rif(ig,k)=frif(ri) + else + rif(ig,k)=rifc + endif + if(rif(ig,k)<0.16) then + alpha(ig,k)=falpha(rif(ig,k)) + sm(ig,k)=fsm(rif(ig,k)) + else + alpha(ig,k)=1.12 + sm(ig,k)=0.085 + endif + zz(ig,k)=b1*m2(ig,k)*(1.-rif(ig,k))*sm(ig,k) + enddo + enddo + + + +!==================================================================== +! Computing the mixing length +!==================================================================== + +! Mise a jour de l0 + if (iflag_pbl==8.or.iflag_pbl==10) then + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Iterative computation of l0 +! This version is kept for iflag_pbl only for convergence +! with NPv3.1 Cmip5 simulations +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + do ig=1,ngrid + sq(ig)=1.e-10 + sqz(ig)=1.e-10 + enddo + do k=2,klev-1 + do ig=1,ngrid + zq=sqrt(q2(ig,k)) + sqz(ig)=sqz(ig)+zq*zlev(ig,k)*(zlay(ig,k)-zlay(ig,k-1)) + sq(ig)=sq(ig)+zq*(zlay(ig,k)-zlay(ig,k-1)) + enddo + enddo + do ig=1,ngrid + l0(ig)=0.2*sqz(ig)/sq(ig) + enddo + l(:,1) = 0. !ym <- fix unitialized level + l(:,klev+1) = 0. !ym <- fix unitialized level + do k=2,klev + do ig=1,ngrid + l(ig,k)=fl(zlev(ig,k),l0(ig),q2(ig,k),n2(ig,k)) + enddo + enddo +! print*,'L0 cas 8 ou 10 ',l0 + + else + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! In all other case, the assymptotic mixing length l0 is imposed (100m) +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + l0(:)=150. + l(:,1) = 0. !ym <- fix unitialized level + l(:,klev+1) = 0. !ym <- fix unitialized level + do k=2,klev + do ig=1,ngrid + l(ig,k)=fl(zlev(ig,k),l0(ig),q2(ig,k),n2(ig,k)) + enddo + enddo +! print*,'L0 cas autres ',l0 + + endif + + +#ifdef IOPHYS +if (okiophys) then +call iophys_ecrit('rif',klev,'Flux Richardson','m',rif(:,1:klev)) +call iophys_ecrit('m2',klev,'m2 ','m/s',m2(:,1:klev)) +call iophys_ecrit('Km2app',klev,'m2 conserv','m/s',km(:,1:klev)*m2(:,1:klev)) +call iophys_ecrit('Km',klev,'Km','m2/s',km(:,1:klev)) +endif +#endif + + +IF (iflag_pbl<20) then + ! For diagnostics only + RETURN + +ELSE + +! print*,'OK1' + +! Evolution of TKE under source terms K M2 and K N2 + leff(:,:)=max(l(:,:),1.) + +!################################################################## +!# IF (iflag_pbl==29) THEN +!# STOP'Ne pas utiliser iflag_pbl=29' +!# km2(:,:)=km(:,:)*m2(:,:) +!# kn2(:,:)=kn2(:,:)*rif(:,:) +!# ELSEIF (iflag_pbl==25) THEN +! VERSION AVEC LA TKE EN MILIEU DE COUCHE +!# STOP'Ne pas utiliser iflag_pbl=25' +!# DO k=1,klev +!# km2(:,k)=-0.5*(dddu(:,k)+dddv(:,k)+dddu(:,k+1)+dddv(:,k+1)) & +!# & /(masse(:,k)*timestep) +!# kn2(:,k)=rcpd*0.5*(dddt(:,k)+dddt(:,k+1))/(masse(:,k)*timestep) +!# leff(:,k)=0.5*(leff(:,k)+leff(:,k+1)) +!# ENDDO +!# km2(:,klev+1)=0. ; kn2(:,klev+1)=0. +!# ELSE +!################################################################# + + km2(:,:)=-(dddu(:,:)+dddv(:,:))/(masseb(:,:)*timestep) + kn2(:,:)=rcpd*dddt(:,:)/(masseb(:,:)*timestep) +! ENDIF + q2neg(:,:)=q2(:,:)+timestep*(km2(:,:)-kn2(:,:)) + q2(:,:)=min(max(q2neg(:,:),1.e-10),1.e4) + + +#ifdef IOPHYS +if (okiophys) then + call iophys_ecrit('km2',klev,'m2 conserv','m/s',km2(:,1:klev)) + call iophys_ecrit('kn2',klev,'n2 conserv','m/s',kn2(:,1:klev)) +endif +#endif + +! Dissipation of TKE + q2old(:,:)=q2(:,:) + q2(:,:)=1./(1./sqrt(q2(:,:))+timestep/(2*leff(:,:)*b1)) + q2(:,:)=q2(:,:)*q2(:,:) +! IF (iflag_pbl<=24) THEN + DO k=1,klev + d_t_diss(:,k)=(masseb(:,k)*(q2neg(:,k)-q2(:,k))+masseb(:,k+1)*(q2neg(:,k+1)-q2(:,k+1)))/(2.*rcpd*masse(:,k)) + ENDDO + +!################################################################### +! ELSE IF (iflag_pbl<=27) THEN +! DO k=1,klev +! d_t_diss(:,k)=(q2neg(:,k)-q2(:,k))/rcpd +! ENDDO +! ENDIF +! print*,'iflag_pbl ',d_t_diss +!################################################################### + + +! Compuation of stability functions +! IF (iflag_pbl/=29) THEN + DO k=1,klev + DO ig=1,ngrid + IF (ABS(km2(ig,k))<=1.e-20) THEN + rif(ig,k)=0. + ELSE + rif(ig,k)=min(kn2(ig,k)/km2(ig,k),rifc) + ENDIF + IF (rif(ig,k).lt.0.16) THEN + alpha(ig,k)=falpha(rif(ig,k)) + sm(ig,k)=fsm(rif(ig,k)) + else + alpha(ig,k)=1.12 + sm(ig,k)=0.085 + endif + ENDDO + ENDDO +! ENDIF + +! Computation of turbulent diffusivities +! IF (25<=iflag_pbl.and.iflag_pbl<=28) THEN +! DO k=2,klev +! sqrtq(:,k)=sqrt(0.5*(q2(:,k)+q2(:,k-1))) +! ENDDO +! ELSE + kq(:,:)=0. + DO k=1,klev + ! Coefficient au milieu des couches pour diffuser la TKE + kq(:,k)=0.5*leff(:,k)*sqrt(q2(:,k))*0.2 + ENDDO + +#ifdef IOPHYS +if (okiophys) then +call iophys_ecrit('q2b',klev,'KTE inter','m2/s',q2(:,1:klev)) +endif +#endif + + IF (iflag_tke_diff==1) THEN + CALL vdif_q2(timestep, RG, RD, ngrid, plev, pt, kq, q2) + ENDIF + + km(:,:)=0. + kn(:,:)=0. + DO k=1,klev + km(:,k)=leff(:,k)*sqrt(q2(:,k))*sm(:,k) + kn(:,k)=km(:,k)*alpha(:,k) + ENDDO + + +#ifdef IOPHYS +if (okiophys) then +call iophys_ecrit('mixingl',klev,'Mixing length','m',leff(:,1:klev)) +call iophys_ecrit('rife',klev,'Flux Richardson','m',rif(:,1:klev)) +call iophys_ecrit('q2f',klev,'KTE finale','m2/s',q2(:,1:klev)) +call iophys_ecrit('q2neg',klev,'KTE non bornee','m2/s',q2neg(:,1:klev)) +call iophys_ecrit('alpha',klev,'alpha','',alpha(:,1:klev)) +call iophys_ecrit('sm',klev,'sm','',sm(:,1:klev)) +call iophys_ecrit('q2f',klev,'KTE finale','m2/s',q2(:,1:klev)) +call iophys_ecrit('kmf',klev,'Kz final','m2/s',km(:,1:klev)) +call iophys_ecrit('knf',klev,'Kz final','m2/s',kn(:,1:klev)) +call iophys_ecrit('kqf',klev,'Kz final','m2/s',kq(:,1:klev)) +endif +#endif + + +ENDIF + + +! print*,'OK2' + RETURN + END SUBROUTINE yamada_c + +END MODULE yamada_c_mod Index: LMDZ6/trunk/libf/phylmd/yoerad.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/yoerad.f90 (revision 6048) +++ LMDZ6/trunk/libf/phylmd/yoerad.f90 (revision 6048) @@ -0,0 +1,181 @@ +! Sourced from rrtm/yoerad.F90 to allow compilation of StratAer blocks + +MODULE yoerad + + IMPLICIT NONE + + SAVE + + ! ------------------------------------------------------------------ + !* ** *YOERAD* - CONTROL OPTIONS FOR RADIATION CONFIGURATION + ! ------------------------------------------------------------------ + + INTEGER :: NAER + INTEGER :: NMODE + INTEGER :: NOZOCL + INTEGER :: NRADFR + INTEGER :: NRADPFR + INTEGER :: NRADPLA + INTEGER :: NRINT + INTEGER :: NRADINT + INTEGER :: NRADRES + INTEGER :: NRADNFR + INTEGER :: NRADSFR + INTEGER :: NOVLP + INTEGER :: NRPROMA + INTEGER :: NLW + !INTEGER :: NSW mis dans .def MPL 20140211 + INTEGER :: NSWNL + INTEGER :: NSWTL + INTEGER :: NTSW + INTEGER :: NUV + INTEGER :: NCSRADF + INTEGER :: NICEOPT + INTEGER :: NLIQOPT + INTEGER :: NRADIP + INTEGER :: NRADLP + INTEGER :: NINHOM + INTEGER :: NLAYINH + INTEGER :: NLNGR1H + INTEGER :: NPERTAER + INTEGER :: NPERTOZ + INTEGER :: NSCEN + INTEGER :: NHINCSOL + INTEGER :: NMCICA + + LOGICAL :: LERAD1H + LOGICAL :: LERADHS + LOGICAL :: LEPO3RA + LOGICAL :: LRADLB + LOGICAL :: LONEWSW + LOGICAL :: LECSRAD + LOGICAL :: LRRTM + LOGICAL :: LSRTM + LOGICAL :: LDIFFC + LOGICAL :: LHVOLCA + LOGICAL :: LNEWAER + LOGICAL :: LNOTROAER + LOGICAL :: LRAYL + LOGICAL :: LOPTRPROMA + LOGICAL :: LECO2VAR + LOGICAL :: LHGHG + + CHARACTER (LEN = 256) :: CRTABLEDIR + CHARACTER (LEN = 32) :: CRTABLEFIL + LOGICAL :: LCCNL + LOGICAL :: LCCNO + + REAL :: RAOVLP, RBOVLP + REAL :: RCCNLND, RCCNSEA + LOGICAL :: LEDBUG + REAL :: RPERTOZ, RRe2De + REAL :: RLWINHF, RSWINHF + + ! * E.C.M.W.F. PHYSICS PACKAGE * + + ! J.-J. MORCRETTE E.C.M.W.F. 89/07/14 + + ! NAME TYPE PURPOSE + ! ---- : ---- : --------------------------------------------------- + ! LERAD1H: LOGICAL : .T. TO ALLOW MORE FREQUENT RADIATION CALCULATIONS + ! : DURING FIRST N HOURS OF FORECAST + ! NLNGR1H: INTEGER : NUMBER FORECAST HOURS DURING WHICH MORE FREQUENT + ! RADIATION CALCULATIONS ARE REQUIRED + ! LERADHS: LOGICAL : .T. IF RAD.COMPUTED ON A COARSER SAMPLED GRID + ! LEPO3RA: LOGICAL : .T. IF PROGNOSTIC OZONE (EC) IS PASSED TO RADIATION + ! NAER : INTEGER : CONFIGURATION INDEX FOR AEROSOLS + ! NMODE : INTEGER : CONFIGURATION FOR RADIATION CODE: FLUX VS. RADIANCE + ! NOZOCL : INTEGER : CHOICE OF OZONE CLIMATOLOGY (0 old, 1 new) + ! NRADFR : INTEGER : FREQUENCY OF FULL RADIATION COMPUTATIONS + ! IF(NRADFR.GT.0): RAD EVERY 'NRADFR' TIME-STEPS + ! IF(NRADFR.LT.0): RAD EVERY '-NRADFR' HOURS + ! NRADPFR: INTEGER : PRINT FREQUENCY FOR RAD.STATISTICS (in RAD.T.STEPS) + ! NRADPLA: INTEGER : PRINT RAD.STATISTICS EVERY 'NRADPLA' ROWS + ! NRINT : INTEGER : INTERPOLATION DISTANCE (in points) + ! NRADINT: INTEGER : RADIATION INTERPOLATION METHOD + ! : 0 = CURRENT RADIATION INTERPOLATION (CONTROLLED BY NRINT) + ! : 1 = SPECTRAL TRANSFORM INTERPOLATION + ! : 2 = 4 POINT HORIZONTAL INTERPOLATION + ! : 3 = 12 POINT HORIZONTAL INTERPOLATION + ! NRADRES: INTEGER : RADIATION GRID SPECTRAL RESOLUTION + ! NRADNFR: INTEGER : NORMAL FREQUENCY OF RADIATION STEPS + ! NRADSFR: INTEGER : START-UP FREQUENCY OF RADIATION STEPS + ! NOVLP : INTEGER : CLOUD OVERLAP CONFIGURATION + ! NRPROMA: INTEGER : VECTOR LENGTH FOR RADIATION CALCULATIONS + ! NLW : INTEGER : NUMBER OF LONGWAVE SPECTRAL INTERVALS + ! NSW : INTEGER : NUMBER OF SHORTWAVE SPECTRAL INTERVALS + ! NSWNL : INTEGER : NUMBER OF SHORTWAVE SPECTRAL INTERVALS IN NL MODEL + ! NSWTL : INTEGER : NUMBER OF SHORTWAVE SPECTRAL INTERVALS IN TL MODEL + ! NTSW : INTEGER : MAXIMUM POSSIBLE NUMBER OF SW SPECTRAL INTERVALS + ! NUV : INTEGER : NUMBER OF UV SPECTRAL INTERVALS FOR THE UV PROCESSOR + ! LRADLB : LOGICAL : .T. IF RADIATION COURSER GRID IS TO BE LOAD BALANCED + ! : OVER PROCESSORS (I.E. WHEN NRINT>1) + ! LOPTRPROMA:LOGICAL: .T. NRPROMA will be optimised + ! : .F. NRPROMA will not be optimised (forced + ! : by negative NRPROMA in namelist) + + ! NRADIP : INTEGER : INDEX FOR DIAGNOSIS OF ICE CLOUD EFFECTIVE RADIUS + ! 0=EbCu/SmSh 1=EbCu/EbCu 2=FuLi/FuLi 3=Fu/Fu&al + ! NRADLP : INTEGER : INDEX FOR DIAGNOSIS OF LIQ. CLOUD EFFECTIVE RADIUS + ! 0=YF/SmSh 1=ASl/HSa 2=ASl/LiLi + ! NICEOPT: INTEGER : INDEX FOR ICE CLOUD OPTICAL PROPERTIES + ! 0=40u 1=40-130 2=30-60 3=Sun'01 + ! NLIQOPT: INTEGER : INDEX FOR LIQUID WATER CLOUD OPTICAL PROPERTIES + ! 0=f(P) 1=10/13 2=Martin_et_al + + ! LONEWSW: LOGICAL : .T. IF NEW SW CODE IS ACTIVE + ! LECSRAD: LOGICAL : .T. IF CLEAR-SKY RADIATION IS ARCHIVED AS PEXTR2 + ! NCSRADF: INTEGER : 1 IF ACCUMULATED, 2 IF INSTANTANEOUS + ! LRRTM : LOGICAL : .T. IF RRTM140MR IS USED FOR LW RADIATION TRANSFER + + ! LHVOLCA: LOGICAL : .T. IF GISS HISTORY OF VOLCANIC AEROSOLS IS ON + ! LNEWAER: LOGICAL : .T. IF AEROSOL MONTHLY DISTRIBUTIONS ARE USED + ! LNOTROAER:LOGICAL: .T. IF NO TROPOSPHERIC AEROSOLS + ! CRTABLEDIR: CHAR : IF NRADINT > 0 SPECIFIES DIRECTORY PATH FOR RADIATION + ! : GRID RTABLE NAMELIST + ! CRTABLEFIL: CHAR : IF NRADINT > 0 SPECIFIES FILE NAME OF RADIATION + ! : GRID RTABLE NAMELIST + ! LRAYL : LOGICAL : .T. NEW RAYLEIGH FOR SW-6 VERSION + + ! RAOVLP : REAL : COEFFICIENTS FOR ALPHA1 FACTOR IN HOGAN & + ! RBOVLP : REAL : ILLINGWORTH's PARAMETRIZATION + + ! LCCNL : LOGICAL : .T. IF CCN CONCENTRATION OVER LAND IS DIAGNOSED + ! LCCNO : LOGICAL : .T. IF CCN CONCENTRATION OVER OCEAN IS DIAGNOSED + ! RCCNLND: REAL : NUMBER CONCENTRATION (CM-3) OF CCNs OVER LAND + ! RCCNSEA: REAL : NUMBER CONCENTRATION (CM-3) OF CCNs OVER SEA + + ! LDIFFC : LOGICAL : .T. IF SAVIJARVI'S DIFFUSIVITY CORRECTION IS ON + + ! NINHOM : INTEGER : 0 IF NO INHOMOGENEITY SCALING EFFECT + ! 1 IF SIMPLE 0.7 SCALING + ! 2 IF BARKER, 3 IF CAIRNS ET AL. + ! RLWINHF: REAL : INHOMOG. SCALING FACTOR FOR CLOUD LW OPTICAL THICKNESS + ! RSWINHF: REAL : INHOMOG. SCALING FACTOR FOR CLOUD SW OPTICAL THICKNESS + + ! NPERTAER : INTERGER : PERCENTAGE OF PERTURBATION FOR AEROSOL + ! NPERTOZONE : INTEGER : PERCENTAGE OF PERTURBATION FOR OZONE + ! NHINCSOL:INTEGER : + ! = 0 NO VARIABILITY OF SOLAR CONSTANT IS ACCOUNTED FOR + ! = 1 IF YEAR-TO-YEAR VARIABILITY OF SOLAR CONSTANT IS ACCOUNTED FOR + ! = 2 IF MONTH-TO-MONTH VARIABILITY OF SOLAR CONSTANT IS ACCOUNTED FOR + ! LECO2VAR: LOGICAL: .T. IF ERA-40/AMIP2 VARIABILITY OF GHG IS ON + ! LHGHG : LOGICAL : .T. IF VARIABILITY OF GREENHOUSE GASES (INCLUDING CO2) IS ON + ! N.B.: LHGHG supercedes LECO2VAR and allows using better specification of trace gases + ! NSCEN : INTEGER : 21st CENTURY SCENARIO FOR GHG (1=A1B, 2=A2, 3=B1) + ! RRe2De : REAL : CONVERSION FACTOR BETWWEN EFFECTIVE RADIUS AND PARTICLE SIZE + ! FOR ICE + ! NMCICA : INTEGER : 0: NO McICA + ! 1: McICA w maximum-random in cloud generator + ! 2: McICA w generalized overlap in cloud generator + ! ------------------------------------------------------------------ + + !$OMP THREADPRIVATE(crtabledir,crtablefil,lccnl,lccno,ldiffc,leco2var,lecsrad) + !$OMP THREADPRIVATE(ledbug,lepo3ra,lerad1h,leradhs,lhghg,lhvolca,lnewaer,lnotroaer) + !$OMP THREADPRIVATE(lonewsw,loptrproma,lradlb,lrayl,lrrtm,lsrtm,naer,ncsradf,nhincsol) + !$OMP THREADPRIVATE(niceopt,ninhom,nlayinh,nliqopt,nlngr1h,nlw,nmcica,nmode,novlp,nozocl) + !$OMP THREADPRIVATE(npertaer,npertoz,nradfr,nradint,nradip,nradlp,nradnfr,nradpfr,nradpla) + !$OMP THREADPRIVATE(nradres,nradsfr,nrint,nrproma,nscen,nswnl,nswtl,ntsw,nuv,raovlp) + !$OMP THREADPRIVATE(rbovlp,rccnlnd,rccnsea,rlwinhf,rpertoz,rre2de,rswinhf) + +END MODULE yoerad Index: LMDZ6/trunk/libf/phylmd/yoerad_strataer_rrtm.f90 =================================================================== --- LMDZ6/trunk/libf/phylmd/yoerad_strataer_rrtm.f90 (revision 6047) +++ (revision ) @@ -1,181 +1,0 @@ -! Sourced from rrtm/yoerad.F90 to allow compilation of StratAer blocks - -MODULE yoerad - - IMPLICIT NONE - - SAVE - - ! ------------------------------------------------------------------ - !* ** *YOERAD* - CONTROL OPTIONS FOR RADIATION CONFIGURATION - ! ------------------------------------------------------------------ - - INTEGER :: NAER - INTEGER :: NMODE - INTEGER :: NOZOCL - INTEGER :: NRADFR - INTEGER :: NRADPFR - INTEGER :: NRADPLA - INTEGER :: NRINT - INTEGER :: NRADINT - INTEGER :: NRADRES - INTEGER :: NRADNFR - INTEGER :: NRADSFR - INTEGER :: NOVLP - INTEGER :: NRPROMA - INTEGER :: NLW - !INTEGER :: NSW mis dans .def MPL 20140211 - INTEGER :: NSWNL - INTEGER :: NSWTL - INTEGER :: NTSW - INTEGER :: NUV - INTEGER :: NCSRADF - INTEGER :: NICEOPT - INTEGER :: NLIQOPT - INTEGER :: NRADIP - INTEGER :: NRADLP - INTEGER :: NINHOM - INTEGER :: NLAYINH - INTEGER :: NLNGR1H - INTEGER :: NPERTAER - INTEGER :: NPERTOZ - INTEGER :: NSCEN - INTEGER :: NHINCSOL - INTEGER :: NMCICA - - LOGICAL :: LERAD1H - LOGICAL :: LERADHS - LOGICAL :: LEPO3RA - LOGICAL :: LRADLB - LOGICAL :: LONEWSW - LOGICAL :: LECSRAD - LOGICAL :: LRRTM - LOGICAL :: LSRTM - LOGICAL :: LDIFFC - LOGICAL :: LHVOLCA - LOGICAL :: LNEWAER - LOGICAL :: LNOTROAER - LOGICAL :: LRAYL - LOGICAL :: LOPTRPROMA - LOGICAL :: LECO2VAR - LOGICAL :: LHGHG - - CHARACTER (LEN = 256) :: CRTABLEDIR - CHARACTER (LEN = 32) :: CRTABLEFIL - LOGICAL :: LCCNL - LOGICAL :: LCCNO - - REAL :: RAOVLP, RBOVLP - REAL :: RCCNLND, RCCNSEA - LOGICAL :: LEDBUG - REAL :: RPERTOZ, RRe2De - REAL :: RLWINHF, RSWINHF - - ! * E.C.M.W.F. PHYSICS PACKAGE * - - ! J.-J. MORCRETTE E.C.M.W.F. 89/07/14 - - ! NAME TYPE PURPOSE - ! ---- : ---- : --------------------------------------------------- - ! LERAD1H: LOGICAL : .T. TO ALLOW MORE FREQUENT RADIATION CALCULATIONS - ! : DURING FIRST N HOURS OF FORECAST - ! NLNGR1H: INTEGER : NUMBER FORECAST HOURS DURING WHICH MORE FREQUENT - ! RADIATION CALCULATIONS ARE REQUIRED - ! LERADHS: LOGICAL : .T. IF RAD.COMPUTED ON A COARSER SAMPLED GRID - ! LEPO3RA: LOGICAL : .T. IF PROGNOSTIC OZONE (EC) IS PASSED TO RADIATION - ! NAER : INTEGER : CONFIGURATION INDEX FOR AEROSOLS - ! NMODE : INTEGER : CONFIGURATION FOR RADIATION CODE: FLUX VS. RADIANCE - ! NOZOCL : INTEGER : CHOICE OF OZONE CLIMATOLOGY (0 old, 1 new) - ! NRADFR : INTEGER : FREQUENCY OF FULL RADIATION COMPUTATIONS - ! IF(NRADFR.GT.0): RAD EVERY 'NRADFR' TIME-STEPS - ! IF(NRADFR.LT.0): RAD EVERY '-NRADFR' HOURS - ! NRADPFR: INTEGER : PRINT FREQUENCY FOR RAD.STATISTICS (in RAD.T.STEPS) - ! NRADPLA: INTEGER : PRINT RAD.STATISTICS EVERY 'NRADPLA' ROWS - ! NRINT : INTEGER : INTERPOLATION DISTANCE (in points) - ! NRADINT: INTEGER : RADIATION INTERPOLATION METHOD - ! : 0 = CURRENT RADIATION INTERPOLATION (CONTROLLED BY NRINT) - ! : 1 = SPECTRAL TRANSFORM INTERPOLATION - ! : 2 = 4 POINT HORIZONTAL INTERPOLATION - ! : 3 = 12 POINT HORIZONTAL INTERPOLATION - ! NRADRES: INTEGER : RADIATION GRID SPECTRAL RESOLUTION - ! NRADNFR: INTEGER : NORMAL FREQUENCY OF RADIATION STEPS - ! NRADSFR: INTEGER : START-UP FREQUENCY OF RADIATION STEPS - ! NOVLP : INTEGER : CLOUD OVERLAP CONFIGURATION - ! NRPROMA: INTEGER : VECTOR LENGTH FOR RADIATION CALCULATIONS - ! NLW : INTEGER : NUMBER OF LONGWAVE SPECTRAL INTERVALS - ! NSW : INTEGER : NUMBER OF SHORTWAVE SPECTRAL INTERVALS - ! NSWNL : INTEGER : NUMBER OF SHORTWAVE SPECTRAL INTERVALS IN NL MODEL - ! NSWTL : INTEGER : NUMBER OF SHORTWAVE SPECTRAL INTERVALS IN TL MODEL - ! NTSW : INTEGER : MAXIMUM POSSIBLE NUMBER OF SW SPECTRAL INTERVALS - ! NUV : INTEGER : NUMBER OF UV SPECTRAL INTERVALS FOR THE UV PROCESSOR - ! LRADLB : LOGICAL : .T. IF RADIATION COURSER GRID IS TO BE LOAD BALANCED - ! : OVER PROCESSORS (I.E. WHEN NRINT>1) - ! LOPTRPROMA:LOGICAL: .T. NRPROMA will be optimised - ! : .F. NRPROMA will not be optimised (forced - ! : by negative NRPROMA in namelist) - - ! NRADIP : INTEGER : INDEX FOR DIAGNOSIS OF ICE CLOUD EFFECTIVE RADIUS - ! 0=EbCu/SmSh 1=EbCu/EbCu 2=FuLi/FuLi 3=Fu/Fu&al - ! NRADLP : INTEGER : INDEX FOR DIAGNOSIS OF LIQ. CLOUD EFFECTIVE RADIUS - ! 0=YF/SmSh 1=ASl/HSa 2=ASl/LiLi - ! NICEOPT: INTEGER : INDEX FOR ICE CLOUD OPTICAL PROPERTIES - ! 0=40u 1=40-130 2=30-60 3=Sun'01 - ! NLIQOPT: INTEGER : INDEX FOR LIQUID WATER CLOUD OPTICAL PROPERTIES - ! 0=f(P) 1=10/13 2=Martin_et_al - - ! LONEWSW: LOGICAL : .T. IF NEW SW CODE IS ACTIVE - ! LECSRAD: LOGICAL : .T. IF CLEAR-SKY RADIATION IS ARCHIVED AS PEXTR2 - ! NCSRADF: INTEGER : 1 IF ACCUMULATED, 2 IF INSTANTANEOUS - ! LRRTM : LOGICAL : .T. IF RRTM140MR IS USED FOR LW RADIATION TRANSFER - - ! LHVOLCA: LOGICAL : .T. IF GISS HISTORY OF VOLCANIC AEROSOLS IS ON - ! LNEWAER: LOGICAL : .T. IF AEROSOL MONTHLY DISTRIBUTIONS ARE USED - ! LNOTROAER:LOGICAL: .T. IF NO TROPOSPHERIC AEROSOLS - ! CRTABLEDIR: CHAR : IF NRADINT > 0 SPECIFIES DIRECTORY PATH FOR RADIATION - ! : GRID RTABLE NAMELIST - ! CRTABLEFIL: CHAR : IF NRADINT > 0 SPECIFIES FILE NAME OF RADIATION - ! : GRID RTABLE NAMELIST - ! LRAYL : LOGICAL : .T. NEW RAYLEIGH FOR SW-6 VERSION - - ! RAOVLP : REAL : COEFFICIENTS FOR ALPHA1 FACTOR IN HOGAN & - ! RBOVLP : REAL : ILLINGWORTH's PARAMETRIZATION - - ! LCCNL : LOGICAL : .T. IF CCN CONCENTRATION OVER LAND IS DIAGNOSED - ! LCCNO : LOGICAL : .T. IF CCN CONCENTRATION OVER OCEAN IS DIAGNOSED - ! RCCNLND: REAL : NUMBER CONCENTRATION (CM-3) OF CCNs OVER LAND - ! RCCNSEA: REAL : NUMBER CONCENTRATION (CM-3) OF CCNs OVER SEA - - ! LDIFFC : LOGICAL : .T. IF SAVIJARVI'S DIFFUSIVITY CORRECTION IS ON - - ! NINHOM : INTEGER : 0 IF NO INHOMOGENEITY SCALING EFFECT - ! 1 IF SIMPLE 0.7 SCALING - ! 2 IF BARKER, 3 IF CAIRNS ET AL. - ! RLWINHF: REAL : INHOMOG. SCALING FACTOR FOR CLOUD LW OPTICAL THICKNESS - ! RSWINHF: REAL : INHOMOG. SCALING FACTOR FOR CLOUD SW OPTICAL THICKNESS - - ! NPERTAER : INTERGER : PERCENTAGE OF PERTURBATION FOR AEROSOL - ! NPERTOZONE : INTEGER : PERCENTAGE OF PERTURBATION FOR OZONE - ! NHINCSOL:INTEGER : - ! = 0 NO VARIABILITY OF SOLAR CONSTANT IS ACCOUNTED FOR - ! = 1 IF YEAR-TO-YEAR VARIABILITY OF SOLAR CONSTANT IS ACCOUNTED FOR - ! = 2 IF MONTH-TO-MONTH VARIABILITY OF SOLAR CONSTANT IS ACCOUNTED FOR - ! LECO2VAR: LOGICAL: .T. IF ERA-40/AMIP2 VARIABILITY OF GHG IS ON - ! LHGHG : LOGICAL : .T. IF VARIABILITY OF GREENHOUSE GASES (INCLUDING CO2) IS ON - ! N.B.: LHGHG supercedes LECO2VAR and allows using better specification of trace gases - ! NSCEN : INTEGER : 21st CENTURY SCENARIO FOR GHG (1=A1B, 2=A2, 3=B1) - ! RRe2De : REAL : CONVERSION FACTOR BETWWEN EFFECTIVE RADIUS AND PARTICLE SIZE - ! FOR ICE - ! NMCICA : INTEGER : 0: NO McICA - ! 1: McICA w maximum-random in cloud generator - ! 2: McICA w generalized overlap in cloud generator - ! ------------------------------------------------------------------ - - !$OMP THREADPRIVATE(crtabledir,crtablefil,lccnl,lccno,ldiffc,leco2var,lecsrad) - !$OMP THREADPRIVATE(ledbug,lepo3ra,lerad1h,leradhs,lhghg,lhvolca,lnewaer,lnotroaer) - !$OMP THREADPRIVATE(lonewsw,loptrproma,lradlb,lrayl,lrrtm,lsrtm,naer,ncsradf,nhincsol) - !$OMP THREADPRIVATE(niceopt,ninhom,nlayinh,nliqopt,nlngr1h,nlw,nmcica,nmode,novlp,nozocl) - !$OMP THREADPRIVATE(npertaer,npertoz,nradfr,nradint,nradip,nradlp,nradnfr,nradpfr,nradpla) - !$OMP THREADPRIVATE(nradres,nradsfr,nrint,nrproma,nscen,nswnl,nswtl,ntsw,nuv,raovlp) - !$OMP THREADPRIVATE(rbovlp,rccnlnd,rccnsea,rlwinhf,rpertoz,rre2de,rswinhf) - -END MODULE yoerad Index: LMDZ6/trunk/libf/phylmdiso/FLOTT_GWD_rando_m.f90 =================================================================== --- LMDZ6/trunk/libf/phylmdiso/FLOTT_GWD_rando_m.f90 (revision 6048) +++ LMDZ6/trunk/libf/phylmdiso/FLOTT_GWD_rando_m.f90 (revision 6048) @@ -0,0 +1,1 @@ +link ../phylmd/FLOTT_GWD_rando_m.f90 Index: LMDZ6/trunk/libf/phylmdiso/alpale_th.f90 =================================================================== --- LMDZ6/trunk/libf/phylmdiso/alpale_th.f90 (revision 6047) +++ (revision ) @@ -1,1 +1,0 @@ -link ../phylmd/alpale_th.f90 Index: LMDZ6/trunk/libf/phylmdiso/alpale_th_mod.f90 =================================================================== --- LMDZ6/trunk/libf/phylmdiso/alpale_th_mod.f90 (revision 6048) +++ LMDZ6/trunk/libf/phylmdiso/alpale_th_mod.f90 (revision 6048) @@ -0,0 +1,1 @@ +link ../phylmd/alpale_th_mod.f90 Index: LMDZ6/trunk/libf/phylmdiso/alpale_wk.f90 =================================================================== --- LMDZ6/trunk/libf/phylmdiso/alpale_wk.f90 (revision 6047) +++ (revision ) @@ -1,1 +1,0 @@ -link ../phylmd/alpale_wk.f90 Index: LMDZ6/trunk/libf/phylmdiso/alpale_wk_mod.f90 =================================================================== --- LMDZ6/trunk/libf/phylmdiso/alpale_wk_mod.f90 (revision 6048) +++ LMDZ6/trunk/libf/phylmdiso/alpale_wk_mod.f90 (revision 6048) @@ -0,0 +1,1 @@ +link ../phylmd/alpale_wk_mod.f90 Index: LMDZ6/trunk/libf/phylmdiso/clc_core_cp.f90 =================================================================== --- LMDZ6/trunk/libf/phylmdiso/clc_core_cp.f90 (revision 6047) +++ (revision ) @@ -1,1 +1,0 @@ -link ../phylmd/clc_core_cp.f90 Index: LMDZ6/trunk/libf/phylmdiso/clc_core_cp_mod.f90 =================================================================== --- LMDZ6/trunk/libf/phylmdiso/clc_core_cp_mod.f90 (revision 6048) +++ LMDZ6/trunk/libf/phylmdiso/clc_core_cp_mod.f90 (revision 6048) @@ -0,0 +1,1 @@ +link ../phylmd/clc_core_cp_mod.f90 Index: LMDZ6/trunk/libf/phylmdiso/clouds_bigauss.f90 =================================================================== --- LMDZ6/trunk/libf/phylmdiso/clouds_bigauss.f90 (revision 6047) +++ (revision ) @@ -1,1 +1,0 @@ -link ../phylmd/clouds_bigauss.f90 Index: LMDZ6/trunk/libf/phylmdiso/clouds_bigauss_mod.f90 =================================================================== --- LMDZ6/trunk/libf/phylmdiso/clouds_bigauss_mod.f90 (revision 6048) +++ LMDZ6/trunk/libf/phylmdiso/clouds_bigauss_mod.f90 (revision 6048) @@ -0,0 +1,1 @@ +link ../phylmd/clouds_bigauss_mod.f90 Index: LMDZ6/trunk/libf/phylmdiso/clouds_gno.f90 =================================================================== --- LMDZ6/trunk/libf/phylmdiso/clouds_gno.f90 (revision 6047) +++ (revision ) @@ -1,1 +1,0 @@ -link ../phylmd/clouds_gno.f90 Index: LMDZ6/trunk/libf/phylmdiso/clouds_gno_mod.f90 =================================================================== --- LMDZ6/trunk/libf/phylmdiso/clouds_gno_mod.f90 (revision 6048) +++ LMDZ6/trunk/libf/phylmdiso/clouds_gno_mod.f90 (revision 6048) @@ -0,0 +1,1 @@ +link ../phylmd/clouds_gno_mod.f90 Index: LMDZ6/trunk/libf/phylmdiso/create_etat0_limit_unstruct_mod.f90 =================================================================== --- LMDZ6/trunk/libf/phylmdiso/create_etat0_limit_unstruct_mod.f90 (revision 6047) +++ (revision ) @@ -1,1 +1,0 @@ -link ../phylmd/create_etat0_limit_unstruct_mod.f90 Index: LMDZ6/trunk/libf/phylmdiso/ctstar.f90 =================================================================== --- LMDZ6/trunk/libf/phylmdiso/ctstar.f90 (revision 6047) +++ (revision ) @@ -1,1 +1,0 @@ -link ../phylmd/ctstar.f90 Index: LMDZ6/trunk/libf/phylmdiso/ctstart_mod.f90 =================================================================== --- LMDZ6/trunk/libf/phylmdiso/ctstart_mod.f90 (revision 6048) +++ LMDZ6/trunk/libf/phylmdiso/ctstart_mod.f90 (revision 6048) @@ -0,0 +1,1 @@ +link ../phylmd/ctstart_mod.f90 Index: LMDZ6/trunk/libf/phylmdiso/cv3_buoy.f90 =================================================================== --- LMDZ6/trunk/libf/phylmdiso/cv3_buoy.f90 (revision 6047) +++ (revision ) @@ -1,1 +1,0 @@ -link ../phylmd/cv3_buoy.f90 Index: LMDZ6/trunk/libf/phylmdiso/cv3_buoy_mod.f90 =================================================================== --- LMDZ6/trunk/libf/phylmdiso/cv3_buoy_mod.f90 (revision 6048) +++ LMDZ6/trunk/libf/phylmdiso/cv3_buoy_mod.f90 (revision 6048) @@ -0,0 +1,1 @@ +link ../phylmd/cv3_buoy_mod.f90 Index: LMDZ6/trunk/libf/phylmdiso/cv3_cine.f90 =================================================================== --- LMDZ6/trunk/libf/phylmdiso/cv3_cine.f90 (revision 6047) +++ (revision ) @@ -1,1 +1,0 @@ -link ../phylmd/cv3_cine.f90 Index: LMDZ6/trunk/libf/phylmdiso/cv3_cine_mod.f90 =================================================================== --- LMDZ6/trunk/libf/phylmdiso/cv3_cine_mod.f90 (revision 6048) +++ LMDZ6/trunk/libf/phylmdiso/cv3_cine_mod.f90 (revision 6048) @@ -0,0 +1,1 @@ +link ../phylmd/cv3_cine_mod.f90 Index: LMDZ6/trunk/libf/phylmdiso/cv3_mixscale.f90 =================================================================== --- LMDZ6/trunk/libf/phylmdiso/cv3_mixscale.f90 (revision 6047) +++ (revision ) @@ -1,1 +1,0 @@ -link ../phylmd/cv3_mixscale.f90 Index: LMDZ6/trunk/libf/phylmdiso/cv3_mixscale_mod.f90 =================================================================== --- LMDZ6/trunk/libf/phylmdiso/cv3_mixscale_mod.f90 (revision 6048) +++ LMDZ6/trunk/libf/phylmdiso/cv3_mixscale_mod.f90 (revision 6048) @@ -0,0 +1,1 @@ +link ../phylmd/cv3_mixscale_mod.f90 Index: LMDZ6/trunk/libf/phylmdiso/cv3p1_closure.f90 =================================================================== --- LMDZ6/trunk/libf/phylmdiso/cv3p1_closure.f90 (revision 6047) +++ (revision ) @@ -1,1 +1,0 @@ -link ../phylmd/cv3p1_closure.f90 Index: LMDZ6/trunk/libf/phylmdiso/cv3p1_closure_mod.f90 =================================================================== --- LMDZ6/trunk/libf/phylmdiso/cv3p1_closure_mod.f90 (revision 6048) +++ LMDZ6/trunk/libf/phylmdiso/cv3p1_closure_mod.f90 (revision 6048) @@ -0,0 +1,1 @@ +link ../phylmd/cv3p1_closure_mod.f90 Index: LMDZ6/trunk/libf/phylmdiso/cv3p2_closure.f90 =================================================================== --- LMDZ6/trunk/libf/phylmdiso/cv3p2_closure.f90 (revision 6047) +++ (revision ) @@ -1,1 +1,0 @@ -link ../phylmd/cv3p2_closure.f90 Index: LMDZ6/trunk/libf/phylmdiso/cv3p2_closure_mod.f90 =================================================================== --- LMDZ6/trunk/libf/phylmdiso/cv3p2_closure_mod.f90 (revision 6048) +++ LMDZ6/trunk/libf/phylmdiso/cv3p2_closure_mod.f90 (revision 6048) @@ -0,0 +1,1 @@ +link ../phylmd/cv3p2_closure_mod.f90 Index: LMDZ6/trunk/libf/phylmdiso/cv_routines.f90 =================================================================== --- LMDZ6/trunk/libf/phylmdiso/cv_routines.f90 (revision 6047) +++ (revision ) @@ -1,1 +1,0 @@ -link ../phylmd/cv_routines.f90 Index: LMDZ6/trunk/libf/phylmdiso/cv_routines_mod.f90 =================================================================== --- LMDZ6/trunk/libf/phylmdiso/cv_routines_mod.f90 (revision 6048) +++ LMDZ6/trunk/libf/phylmdiso/cv_routines_mod.f90 (revision 6048) @@ -0,0 +1,1 @@ +link ../phylmd/cv_routines_mod.f90 Index: LMDZ6/trunk/libf/phylmdiso/diag_slp.f90 =================================================================== --- LMDZ6/trunk/libf/phylmdiso/diag_slp.f90 (revision 6047) +++ (revision ) @@ -1,1 +1,0 @@ -link ../phylmd/diag_slp.f90 Index: LMDZ6/trunk/libf/phylmdiso/diag_slp_mod.f90 =================================================================== --- LMDZ6/trunk/libf/phylmdiso/diag_slp_mod.f90 (revision 6048) +++ LMDZ6/trunk/libf/phylmdiso/diag_slp_mod.f90 (revision 6048) @@ -0,0 +1,1 @@ +link ../phylmd/diag_slp_mod.f90 Index: LMDZ6/trunk/libf/phylmdiso/ecumev6_flux.f90 =================================================================== --- LMDZ6/trunk/libf/phylmdiso/ecumev6_flux.f90 (revision 6047) +++ (revision ) @@ -1,1 +1,0 @@ -link ../phylmd/ecumev6_flux.f90 Index: LMDZ6/trunk/libf/phylmdiso/ecumev6_flux_mod.f90 =================================================================== --- LMDZ6/trunk/libf/phylmdiso/ecumev6_flux_mod.f90 (revision 6048) +++ LMDZ6/trunk/libf/phylmdiso/ecumev6_flux_mod.f90 (revision 6048) @@ -0,0 +1,1 @@ +link ../phylmd/ecumev6_flux_mod.f90 Index: LMDZ6/trunk/libf/phylmdiso/ener_conserv.f90 =================================================================== --- LMDZ6/trunk/libf/phylmdiso/ener_conserv.f90 (revision 6047) +++ (revision ) @@ -1,1 +1,0 @@ -link ../phylmd/ener_conserv.f90 Index: LMDZ6/trunk/libf/phylmdiso/ener_conserv_mod.f90 =================================================================== --- LMDZ6/trunk/libf/phylmdiso/ener_conserv_mod.f90 (revision 6048) +++ LMDZ6/trunk/libf/phylmdiso/ener_conserv_mod.f90 (revision 6048) @@ -0,0 +1,1 @@ +link ../phylmd/ener_conserv_mod.f90 Index: LMDZ6/trunk/libf/phylmdiso/etat0_limit_unstruct_mod.f90 =================================================================== --- LMDZ6/trunk/libf/phylmdiso/etat0_limit_unstruct_mod.f90 (revision 6048) +++ LMDZ6/trunk/libf/phylmdiso/etat0_limit_unstruct_mod.f90 (revision 6048) @@ -0,0 +1,1 @@ +link ../phylmd/etat0_limit_unstruct_mod.f90 Index: LMDZ6/trunk/libf/phylmdiso/evappot.f90 =================================================================== --- LMDZ6/trunk/libf/phylmdiso/evappot.f90 (revision 6047) +++ (revision ) @@ -1,1 +1,0 @@ -link ../phylmd/evappot.f90 Index: LMDZ6/trunk/libf/phylmdiso/evappot_mod.f90 =================================================================== --- LMDZ6/trunk/libf/phylmdiso/evappot_mod.f90 (revision 6048) +++ LMDZ6/trunk/libf/phylmdiso/evappot_mod.f90 (revision 6048) @@ -0,0 +1,1 @@ +link ../phylmd/evappot_mod.f90 Index: LMDZ6/trunk/libf/phylmdiso/flott_gwd_rando_m.f90 =================================================================== --- LMDZ6/trunk/libf/phylmdiso/flott_gwd_rando_m.f90 (revision 6047) +++ (revision ) @@ -1,1 +1,0 @@ -link ../phylmd/flott_gwd_rando_m.f90 Index: LMDZ6/trunk/libf/phylmdiso/m_simu_airs.f90 =================================================================== --- LMDZ6/trunk/libf/phylmdiso/m_simu_airs.f90 (revision 6048) +++ LMDZ6/trunk/libf/phylmdiso/m_simu_airs.f90 (revision 6048) @@ -0,0 +1,1 @@ +link ../phylmd/m_simu_airs.f90 Index: LMDZ6/trunk/libf/phylmdiso/nuage.f90 =================================================================== --- LMDZ6/trunk/libf/phylmdiso/nuage.f90 (revision 6047) +++ (revision ) @@ -1,1 +1,0 @@ -link ../phylmd/nuage.f90 Index: LMDZ6/trunk/libf/phylmdiso/nuage_mod.f90 =================================================================== --- LMDZ6/trunk/libf/phylmdiso/nuage_mod.f90 (revision 6048) +++ LMDZ6/trunk/libf/phylmdiso/nuage_mod.f90 (revision 6048) @@ -0,0 +1,1 @@ +link ../phylmd/nuage_mod.f90 Index: LMDZ6/trunk/libf/phylmdiso/orbite.f90 =================================================================== --- LMDZ6/trunk/libf/phylmdiso/orbite.f90 (revision 6047) +++ (revision ) @@ -1,1 +1,0 @@ -link ../phylmd/orbite.f90 Index: LMDZ6/trunk/libf/phylmdiso/orbite_mod.f90 =================================================================== --- LMDZ6/trunk/libf/phylmdiso/orbite_mod.f90 (revision 6048) +++ LMDZ6/trunk/libf/phylmdiso/orbite_mod.f90 (revision 6048) @@ -0,0 +1,1 @@ +link ../phylmd/orbite_mod.f90 Index: LMDZ6/trunk/libf/phylmdiso/orografi.f90 =================================================================== --- LMDZ6/trunk/libf/phylmdiso/orografi.f90 (revision 6047) +++ (revision ) @@ -1,1 +1,0 @@ -link ../phylmd/orografi.f90 Index: LMDZ6/trunk/libf/phylmdiso/orografi_mod.f90 =================================================================== --- LMDZ6/trunk/libf/phylmdiso/orografi_mod.f90 (revision 6048) +++ LMDZ6/trunk/libf/phylmdiso/orografi_mod.f90 (revision 6048) @@ -0,0 +1,1 @@ +link ../phylmd/orografi_mod.f90 Index: LMDZ6/trunk/libf/phylmdiso/orografi_strato.f90 =================================================================== --- LMDZ6/trunk/libf/phylmdiso/orografi_strato.f90 (revision 6047) +++ (revision ) @@ -1,1 +1,0 @@ -link ../phylmd/orografi_strato.f90 Index: LMDZ6/trunk/libf/phylmdiso/orografi_strato_mod.f90 =================================================================== --- LMDZ6/trunk/libf/phylmdiso/orografi_strato_mod.f90 (revision 6048) +++ LMDZ6/trunk/libf/phylmdiso/orografi_strato_mod.f90 (revision 6048) @@ -0,0 +1,1 @@ +link ../phylmd/orografi_strato_mod.f90 Index: LMDZ6/trunk/libf/phylmdiso/pppmer.f90 =================================================================== --- LMDZ6/trunk/libf/phylmdiso/pppmer.f90 (revision 6047) +++ (revision ) @@ -1,1 +1,0 @@ -link ../phylmd/pppmer.f90 Index: LMDZ6/trunk/libf/phylmdiso/pppmer_mod.f90 =================================================================== --- LMDZ6/trunk/libf/phylmdiso/pppmer_mod.f90 (revision 6048) +++ LMDZ6/trunk/libf/phylmdiso/pppmer_mod.f90 (revision 6048) @@ -0,0 +1,1 @@ +link ../phylmd/pppmer_mod.f90 Index: LMDZ6/trunk/libf/phylmdiso/qsat_seawater.f90 =================================================================== --- LMDZ6/trunk/libf/phylmdiso/qsat_seawater.f90 (revision 6047) +++ (revision ) @@ -1,1 +1,0 @@ -link ../phylmd/qsat_seawater.f90 Index: LMDZ6/trunk/libf/phylmdiso/qsat_seawater2.f90 =================================================================== --- LMDZ6/trunk/libf/phylmdiso/qsat_seawater2.f90 (revision 6047) +++ (revision ) @@ -1,1 +1,0 @@ -link ../phylmd/qsat_seawater2.f90 Index: LMDZ6/trunk/libf/phylmdiso/qsat_seawater2_mod.f90 =================================================================== --- LMDZ6/trunk/libf/phylmdiso/qsat_seawater2_mod.f90 (revision 6048) +++ LMDZ6/trunk/libf/phylmdiso/qsat_seawater2_mod.f90 (revision 6048) @@ -0,0 +1,1 @@ +link ../phylmd/qsat_seawater2_mod.f90 Index: LMDZ6/trunk/libf/phylmdiso/qsat_seawater_mod.f90 =================================================================== --- LMDZ6/trunk/libf/phylmdiso/qsat_seawater_mod.f90 (revision 6048) +++ LMDZ6/trunk/libf/phylmdiso/qsat_seawater_mod.f90 (revision 6048) @@ -0,0 +1,1 @@ +link ../phylmd/qsat_seawater_mod.f90 Index: LMDZ6/trunk/libf/phylmdiso/simu_airs.f90 =================================================================== --- LMDZ6/trunk/libf/phylmdiso/simu_airs.f90 (revision 6047) +++ (revision ) @@ -1,1 +1,0 @@ -link ../phylmd/simu_airs.f90 Index: LMDZ6/trunk/libf/phylmdiso/stratocu_if.f90 =================================================================== --- LMDZ6/trunk/libf/phylmdiso/stratocu_if.f90 (revision 6047) +++ (revision ) @@ -1,1 +1,0 @@ -link ../phylmd/stratocu_if.f90 Index: LMDZ6/trunk/libf/phylmdiso/stratocu_if_mod.f90 =================================================================== --- LMDZ6/trunk/libf/phylmdiso/stratocu_if_mod.f90 (revision 6048) +++ LMDZ6/trunk/libf/phylmdiso/stratocu_if_mod.f90 (revision 6048) @@ -0,0 +1,1 @@ +link ../phylmd/stratocu_if_mod.f90 Index: LMDZ6/trunk/libf/phylmdiso/tend_to_tke.f90 =================================================================== --- LMDZ6/trunk/libf/phylmdiso/tend_to_tke.f90 (revision 6047) +++ (revision ) @@ -1,1 +1,0 @@ -link ../phylmd/tend_to_tke.f90 Index: LMDZ6/trunk/libf/phylmdiso/tend_to_tke_mod.f90 =================================================================== --- LMDZ6/trunk/libf/phylmdiso/tend_to_tke_mod.f90 (revision 6048) +++ LMDZ6/trunk/libf/phylmdiso/tend_to_tke_mod.f90 (revision 6048) @@ -0,0 +1,1 @@ +link ../phylmd/tend_to_tke_mod.f90 Index: LMDZ6/trunk/libf/phylmdiso/transp.f90 =================================================================== --- LMDZ6/trunk/libf/phylmdiso/transp.f90 (revision 6047) +++ (revision ) @@ -1,1 +1,0 @@ -link ../phylmd/transp.f90 Index: LMDZ6/trunk/libf/phylmdiso/transp_mod.f90 =================================================================== --- LMDZ6/trunk/libf/phylmdiso/transp_mod.f90 (revision 6048) +++ LMDZ6/trunk/libf/phylmdiso/transp_mod.f90 (revision 6048) @@ -0,0 +1,1 @@ +link ../phylmd/transp_mod.f90 Index: LMDZ6/trunk/libf/phylmdiso/water_int.f90 =================================================================== --- LMDZ6/trunk/libf/phylmdiso/water_int.f90 (revision 6047) +++ (revision ) @@ -1,1 +1,0 @@ -link ../phylmd/water_int.f90 Index: LMDZ6/trunk/libf/phylmdiso/water_int_mod.f90 =================================================================== --- LMDZ6/trunk/libf/phylmdiso/water_int_mod.f90 (revision 6048) +++ LMDZ6/trunk/libf/phylmdiso/water_int_mod.f90 (revision 6048) @@ -0,0 +1,1 @@ +link ../phylmd/water_int_mod.f90 Index: LMDZ6/trunk/libf/phylmdiso/yoerad.f90 =================================================================== --- LMDZ6/trunk/libf/phylmdiso/yoerad.f90 (revision 6048) +++ LMDZ6/trunk/libf/phylmdiso/yoerad.f90 (revision 6048) @@ -0,0 +1,1 @@ +link ../phylmd/yoerad.f90 Index: LMDZ6/trunk/libf/phylmdiso/yoerad_strataer_rrtm.f90 =================================================================== --- LMDZ6/trunk/libf/phylmdiso/yoerad_strataer_rrtm.f90 (revision 6047) +++ (revision ) @@ -1,1 +1,0 @@ -link ../phylmd/yoerad_strataer_rrtm.f90