Ignore:
Timestamp:
Apr 13, 2015, 10:21:09 AM (10 years ago)
Author:
Laurent Fairhead
Message:

Merged trunk changes 2216:2237 into testing branch

Location:
LMDZ5/branches/testing
Files:
31 edited
4 copied

Legend:

Unmodified
Added
Removed

  • LMDZ5/branches/testing

  • LMDZ5/branches/testing/libf/phylmd/add_pbl_tend.F90

    r2160 r2258  
    1 SUBROUTINE add_pbl_tend(zdu, zdv, zdt, zdq, zdql, zdqi, paprs, text)
     1SUBROUTINE add_pbl_tend(zdu, zdv, zdt, zdq, zdql, zdqi, paprs, text,abortphy)
    22  ! ======================================================================
    33  ! Ajoute les tendances de couche limite, soit determinees par la
    … …  
    2020  REAL hqturb_gcssold(llm)
    2121  REAL dtime_frcg
     22  INTEGER abortphy
    2223  LOGICAL turb_fcg_gcssold
    2324  COMMON /turb_forcing/dtime_frcg, hthturb_gcssold, hqturb_gcssold, &
    … …  
    4647    PRINT *, ' add_pbl_tend, zzdt ', zzdt
    4748    PRINT *, ' add_pbl_tend, zzdq ', zzdq
    48     CALL add_phys_tend(zdu, zdv, zzdt, zzdq, zdql, zdqi, paprs, text)
     49    CALL add_phys_tend(zdu, zdv, zzdt, zzdq, zdql, zdqi, paprs, text,abortphy)
    4950  ELSE
    50     CALL add_phys_tend(zdu, zdv, zdt, zdq, zdql, zdqi, paprs, text)
     51    CALL add_phys_tend(zdu, zdv, zdt, zdq, zdql, zdqi, paprs, text,abortphy)
    5152  END IF
    5253

  • LMDZ5/branches/testing/libf/phylmd/add_phys_tend.F90

    r2160 r2258  
    22! $Id$
    33!
    4 SUBROUTINE add_phys_tend (zdu,zdv,zdt,zdq,zdql,zdqi,paprs,text)
     4SUBROUTINE add_phys_tend (zdu,zdv,zdt,zdq,zdql,zdqi,paprs,text,abortphy)
    55!======================================================================
    66! Ajoute les tendances des variables physiques aux variables
    … …  
    2828REAL paprs(klon,klev+1)
    2929CHARACTER*(*) text
     30INTEGER abortphy
    3031
    3132! Local :
    … …  
    5253! Initialisations
    5354
    54 debug_level=10
     55      IF (abortphy==1) RETURN ! on n ajoute pas les tendance si le modele
     56                              ! a deja plante.
     57
     58     debug_level=10
    5559     if (first) then
    5660        itap=0
    … …  
    230234ENDIF
    231235
    232       CALL hgardfou(t_seri,ftsol,text)
     236
     237!======================================================================
     238! Contrôle des min/max pour arrêt du modèle
     239! Si le modele est en mode abortphy, on retire les tendances qu'on
     240! vient d'ajouter. Pas exactement parce qu'on ne tient pas compte des
     241! seuils.
     242!======================================================================
     243
     244      CALL hgardfou(t_seri,ftsol,text,abortphy)
     245      IF (abortphy==1) THEN
     246        Print*,'ERROR ABORT hgardfou dans ',text
     247        u_seri(:,:)=u_seri(:,:)-zdu(:,:)
     248        v_seri(:,:)=v_seri(:,:)-zdv(:,:)
     249        ql_seri(:,:)=ql_seri(:,:)-zdql(:,:)
     250        qs_seri(:,:)=qs_seri(:,:)-zdqi(:,:)
     251      ENDIF
     252
     253
     254
    233255      RETURN
    234256      END

  • LMDZ5/branches/testing/libf/phylmd/calcratqs.F90

    r2220 r2258  
    11SUBROUTINE calcratqs(klon,klev,prt_level,lunout,       &
    2            iflag_ratqs,iflag_con,iflag_cldth,pdtphys, &
     2           iflag_ratqs,iflag_con,iflag_cld_th,pdtphys, &
    33           ratqsbas,ratqshaut,tau_ratqs,fact_cldcon,   &
    44           ptconv,ptconvth,clwcon0th, rnebcon0th,      &
    … …  
    1919! Input
    2020integer,intent(in) :: klon,klev,prt_level,lunout
    21 integer,intent(in) :: iflag_con,iflag_cldth,iflag_ratqs
     21integer,intent(in) :: iflag_con,iflag_cld_th,iflag_ratqs
    2222real,intent(in) :: pdtphys,ratqsbas,ratqshaut,fact_cldcon,tau_ratqs
    2323real, dimension(klon,klev+1),intent(in) :: paprs
    … …  
    4343!   ----------------
    4444!   on ecrase le tableau ratqsc calcule par clouds_gno
    45       if (iflag_cldth.eq.1) then
     45      if (iflag_cld_th.eq.1) then
    4646         do k=1,klev
    4747         do i=1,klon
    … …  
    5858!  par nversion de la fonction log normale
    5959!-----------------------------------------------------------------------
    60       else if (iflag_cldth.eq.4) then
     60      else if (iflag_cld_th.eq.4) then
    6161         ptconvth(:,:)=.false.
    6262         ratqsc(:,:)=0.
    … …  
    136136!  -----------
    137137
    138       if (iflag_cldth.eq.1 .or.iflag_cldth.eq.2.or.iflag_cldth.eq.4) then
     138      if (iflag_cld_th.eq.1 .or.iflag_cld_th.eq.2.or.iflag_cld_th.eq.4) then
    139139
    140140! On ajoute une constante au ratqsc*2 pour tenir compte de
    … …  
    165165!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    166166         ratqs(:,:)=max(ratqs(:,:),ratqss(:,:))
    167       else if (iflag_cldth<=6) then
     167      else if (iflag_cld_th<=6) then
    168168!   on ne prend que le ratqs stable pour fisrtilp
    169169         ratqs(:,:)=ratqss(:,:)
    … …  
    174174             do i=1,klon
    175175                if (ratqsc(i,k).gt.1.e-10) then
    176                    ratqs(i,k)=ratqs(i,k)*zfratqs2+(iflag_cldth/100.)*ratqsc(i,k)*(1.-zfratqs2)
     176                   ratqs(i,k)=ratqs(i,k)*zfratqs2+(iflag_cld_th/100.)*ratqsc(i,k)*(1.-zfratqs2)
    177177                endif
    178178                ratqs(i,k)=min(ratqs(i,k)*zfratqs1+ratqss(i,k)*(1.-zfratqs1),0.5)

  • LMDZ5/branches/testing/libf/phylmd/change_srf_frac_mod.F90

    r2220 r2258  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44MODULE change_srf_frac_mod
    … …  
    1212
    1313  SUBROUTINE change_srf_frac(itime, dtime, jour, &
    14        pctsrf, alb1, alb2, tsurf, ustar, u10m, v10m, pbl_tke)
     14!albedo SB >>>
     15!       pctsrf, alb1, alb2, tsurf, ustar, u10m, v10m, pbl_tke)
     16        pctsrf, alb_dir, alb_dif, tsurf, ustar, u10m, v10m, pbl_tke)
     17!albedo SB <<<
     18   
     19
     20
    1521!
    1622! This subroutine is called from physiq.F at each timestep.
    … …  
    3238    INCLUDE "iniprint.h"
    3339    INCLUDE "YOMCST.h"
     40!albedo SB >>>
     41    include "clesphys.h"
     42!albedo SB <<<
     43
     44
    3445
    3546! Input arguments
    … …  
    4354   
    4455    REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: pctsrf ! sub-surface fraction
    45     REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: alb1   ! albedo first interval in SW spektrum
    46     REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: alb2   ! albedo second interval in SW spektrum
     56!albedo SB >>>
     57!   REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: alb1   ! albedo first interval in SW spektrum
     58!   REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: alb2   ! albedo second interval in SW spektrum
     59    REAL, DIMENSION(klon,nsw,nbsrf), INTENT(INOUT) :: alb_dir,alb_dif
     60!albedo SB <<<
     61
    4762    REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: tsurf
    4863    REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: ustar
    … …  
    160175!
    161176!****************************************************************************************
    162        CALL pbl_surface_newfrac(itime, pctsrf, pctsrf_old, tsurf, alb1, alb2, ustar, u10m, v10m, pbl_tke)
     177
     178!albedo SB >>>
     179! CALL pbl_surface_newfrac(itime, pctsrf, pctsrf_old, tsurf, alb1, alb2, ustar,
     180! u10m, v10m, pbl_tke)
     181       CALL pbl_surface_newfrac(itime, pctsrf, pctsrf_old, tsurf, alb_dir,alb_dif, ustar, u10m, v10m, pbl_tke)
     182!albedo SB <<<
     183
     184
    163185
    164186    ELSE

  • LMDZ5/branches/testing/libf/phylmd/clcdrag.F90

    r2160 r2258  
    6161  REAL, DIMENSION(klon) :: zgeop1       ! geopotentiel au 1er niveau du modele
    6262  LOGICAL, PARAMETER    :: zxli=.FALSE. ! calcul des cdrags selon Laurent Li
     63
     64  CHARACTER (LEN=80) :: abort_message
     65  CHARACTER (LEN=20) :: modname = 'clcdrag'
     66
     67
    6368!
    6469! Fonctions thermodynamiques et fonctions d'instabilite
    … …  
    6671  fsta(x) = 1.0 / (1.0+10.0*x*(1+8.0*x))
    6772  fins(x) = SQRT(1.0-18.0*x)
     73
     74  abort_message='obsolete, remplace par cdrag, use at you own risk'
     75  CALL abort_gcm(modname,abort_message,1)
     76
     77
    6878
    6979! ================================================================= c

  • LMDZ5/branches/testing/libf/phylmd/clesphys.h

    r2160 r2258  
    7474       REAL freq_COSP
    7575       LOGICAL :: ok_cosp,ok_mensuelCOSP,ok_journeCOSP,ok_hfCOSP
    76        INTEGER :: ip_ebil_phy, iflag_rrtm, iflag_ice_thermo,NSW
     76       INTEGER :: ip_ebil_phy, iflag_rrtm, iflag_ice_thermo, NSW, iflag_albedo
     77       LOGICAL :: ok_chlorophyll
    7778       LOGICAL :: ok_strato
    7879       LOGICAL :: ok_hines, ok_gwd_rando
    … …  
    116117     &     , ok_lic_melt,           aer_type                            &
    117118     &     , iflag_rrtm, ok_strato,ok_hines, ok_qch4                    &
    118      &     , iflag_ice_thermo, ok_gwd_rando, NSW                        &
    119      &     , ok_conserv_q, ok_all_xml
     119     &     , iflag_ice_thermo, ok_gwd_rando, NSW, iflag_albedo          &
     120     &     , ok_chlorophyll,ok_conserv_q, ok_all_xml
    120121     
    121122       save /clesphys/

  • LMDZ5/branches/testing/libf/phylmd/coefcdrag.F90

    r2160 r2258  
    6464      REAL, dimension(klon) :: trm0, trm1
    6565
     66  CHARACTER (LEN=80) :: abort_message
     67  CHARACTER (LEN=20) :: modname = 'coefcdra'
     68
     69
     70!
     71
     72
    6673!-------------------------------------------------------------------------
    6774      REAL :: fsta, fins, x
    … …  
    6976      fins(x) = SQRT(1.0-18.0*x)
    7077!-------------------------------------------------------------------------
     78
     79  abort_message='obsolete, remplace par cdrag, use at you own risk'
     80  CALL abort_gcm(modname,abort_message,1)
     81
    7182!
    7283      DO i = 1, knon

  • LMDZ5/branches/testing/libf/phylmd/conf_phys_m.F90

    r2220 r2258  
    1515       solarlong0,seuil_inversion, &
    1616       fact_cldcon, facttemps,ok_newmicro,iflag_radia,&
    17        iflag_cldth, &
     17       iflag_cld_th, &
    1818       iflag_ratqs,ratqsbas,ratqshaut,tau_ratqs, &
    1919       ok_ade, ok_aie, ok_cdnc, aerosol_couple, &
    … …  
    8181    REAL                 :: bl95_b0, bl95_b1
    8282    real                 :: fact_cldcon, facttemps,ratqsbas,ratqshaut,tau_ratqs
    83     integer              :: iflag_cldth
     83    integer              :: iflag_cld_th
    8484    integer              :: iflag_ratqs
    8585
    … …  
    110110    integer,SAVE        :: iflag_radia_omp
    111111    integer,SAVE        :: iflag_rrtm_omp
     112    integer,SAVE        :: iflag_albedo_omp !albedo SB
     113    logical,save        :: ok_chlorophyll_omp ! albedo SB 
    112114    integer,SAVE        :: NSW_omp
    113     integer,SAVE        :: iflag_cldth_omp, ip_ebil_phy_omp
     115    integer,SAVE        :: iflag_cld_th_omp, ip_ebil_phy_omp
    114116    integer,SAVE        :: iflag_ratqs_omp
    115117
    … …  
    889891    NSW_omp = 6
    890892    call getin('NSW',NSW_omp)
    891 
    892     !
    893     !Config Key  = iflag_cldth
     893!albedo SB >>>
     894    iflag_albedo_omp = 0
     895    call getin('iflag_albedo',iflag_albedo_omp)
     896
     897    ok_chlorophyll_omp=.false.
     898    call getin('ok_chlorophyll',ok_chlorophyll_omp)
     899!albedo SB <<<
     900
     901    !
     902    !Config Key  = iflag_cld_th
    894903    !Config Desc = 
    895904    !Config Def  = 1
    896905    !Config Help =
    897906    !
    898     iflag_cldth_omp = 1
     907    iflag_cld_th_omp = 1
    899908! On lit deux fois avec l'ancien et le nouveau nom
    900909! pour assurer une retrocompatiblite.
    901910! A abandonner un jour
    902     call getin('iflag_cldcon',iflag_cldth_omp)
    903     call getin('iflag_cldth',iflag_cldth_omp)
    904 
    905     !
    906     !Config Key  = iflag_cld_cv
    907     !Config Desc =
    908     !Config Def  = 1
    909     !Config Help =
    910     !
    911     iflag_cld_cv_omp = 1
     911    call getin('iflag_cldcon',iflag_cld_th_omp)
     912    call getin('iflag_cld_th',iflag_cld_th_omp)
     913    iflag_cld_cv_omp = 0
    912914    call getin('iflag_cld_cv',iflag_cld_cv_omp)
    913915
    … …  
    19731975    iflag_rrtm = iflag_rrtm_omp
    19741976    NSW = NSW_omp
    1975     iflag_cldth = iflag_cldth_omp
     1977    iflag_cld_th = iflag_cld_th_omp
    19761978    iflag_cld_cv = iflag_cld_cv_omp
    19771979    tau_cld_cv = tau_cld_cv_omp
    … …  
    21282130    write(lunout,*)' reevap_ice = ', reevap_ice
    21292131    write(lunout,*)' iflag_pdf = ', iflag_pdf
    2130     write(lunout,*)' iflag_cldth = ', iflag_cldth
     2132    write(lunout,*)' iflag_cld_th = ', iflag_cld_th
    21312133    write(lunout,*)' iflag_cld_cv = ', iflag_cld_cv
    21322134    write(lunout,*)' tau_cld_cv = ', tau_cld_cv
    … …  
    21352137    write(lunout,*)' iflag_rrtm = ', iflag_rrtm
    21362138    write(lunout,*)' NSW = ', NSW
     2139    write(lunout,*)' iflag_albedo = ', iflag_albedo !albedo SB
     2140    write(lunout,*)' ok_chlorophyll =',ok_chlorophyll ! albedo SB
    21372141    write(lunout,*)' iflag_ratqs = ', iflag_ratqs
    21382142    write(lunout,*)' seuil_inversion = ', seuil_inversion

  • LMDZ5/branches/testing/libf/phylmd/cv3p1_closure.F90

    r2220 r2258  
    5353
    5454  ! local variables:
    55   INTEGER il, i, j, k, icbmax, i0(nloc), klfc
     55  INTEGER il, i, j, k, icbmax, i0(nloc), klfc(nloc)
    5656  REAL deltap, fac, w, amu
    5757  REAL rhodp
    … …  
    525525
    526526!CR:Compute k at plfc
     527  DO il=1,ncum
     528           klfc(il)=nl
     529  ENDDO
    527530  DO k=1,nl
    528531     DO il=1,ncum
    529532        if ((plfc(il).lt.ph(il,k)).and.(plfc(il).ge.ph(il,k+1))) then
    530            klfc=k
     533           klfc(il)=k
    531534        endif
    532535     ENDDO
    … …  
    540543!CR: Add large-scale component to the mass-flux
    541544!encore connu sous le nom "Experience du tube de dentifrice"
    542     if (coef_clos_ls.gt.0.) then
    543        cbmf1(il) = cbmf1(il) - coef_clos_ls*min(0.,1./RG*omega(il,klfc))
     545    if ((coef_clos_ls.gt.0.).and.(plfc(il).gt.0.)) then
     546       cbmf1(il) = cbmf1(il) - coef_clos_ls*min(0.,1./RG*omega(il,klfc(il)))
    544547    endif
    545548!RC

  • LMDZ5/branches/testing/libf/phylmd/cv3p_mixing.F90

    r2056 r2258  
    5858  REAL, DIMENSION (nloc)             :: Smid, Sjmin, Sjmax
    5959  REAL, DIMENSION (nloc)             :: Sbef, sup, smin
    60   REAL, DIMENSION (nloc)             :: ASij, smax, Scrit
     60!jyg  REAL, DIMENSION (nloc)             :: ASij, smax, Scrit
     61  REAL, DIMENSION (nloc)             :: ASij, ASij_inv, smax, Scrit
    6162  REAL, DIMENSION (nloc, nd, nd)     :: Sij
    6263  REAL, DIMENSION (nloc, nd)         :: csum
    … …  
    524525      IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il)) THEN
    525526        ASij(il) = amax1(1.0E-16, ASij(il))
    526         ASij(il) = 1.0/ASij(il)
     527!jyg+lluis<
     528!!        ASij(il) = 1.0/ASij(il)
     529        ASij_inv(il) = 1.0/ASij(il)
     530!   IF the F-interval spanned by possible mixtures is less than 0.01, no mixing occurs
     531        IF (ASij_inv(il) > 100.)  ASij_inv(il) = 0.
     532!>jyg+lluis
    527533        csum(il, i) = 0.0
    528534      END IF
    … …  
    533539        IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il) .AND. &
    534540            j>=(icb(il)-1) .AND. j<=inb(il)) THEN
    535           Ment(il, i, j) = Ment(il, i, j)*ASij(il)
     541!jyg          Ment(il, i, j) = Ment(il, i, j)*ASij(il)
     542          Ment(il, i, j) = Ment(il, i, j)*ASij_inv(il)
    536543        END IF
    537544      END DO

  • LMDZ5/branches/testing/libf/phylmd/etat0_netcdf.F90

    r2160 r2258  
    482482  falb1(:,is_oce) = 0.5;  falb1(:,is_sic) = 0.6
    483483  falb2 = falb1
     484!albedo SB >>>
     485  falb_dir(:,is_ter,:)=0.08; falb_dir(:,is_lic,:)=0.6
     486  falb_dir(:,is_oce,:)=0.5;  falb_dir(:,is_sic,:)=0.6
     487!albedo SB <<<
    484488  evap(:,:) = 0.
    485489  DO i=1,nbsrf; qsolsrf(:,i)=150.; END DO

  • LMDZ5/branches/testing/libf/phylmd/fisrtilp.F90

    r2220 r2258  
    88     frac_impa, frac_nucl, beta,                        &
    99     prfl, psfl, rhcl, zqta, fraca,                     &
    10      ztv, zpspsk, ztla, zthl, iflag_cldth,             &
     10     ztv, zpspsk, ztla, zthl, iflag_cld_th,             &
    1111     iflag_ice_thermo)
    1212
    … …  
    8282  INTEGER ninter ! sous-intervals pour la precipitation
    8383  INTEGER ncoreczq 
    84   INTEGER iflag_cldth
     84  INTEGER iflag_cld_th
    8585  INTEGER iflag_ice_thermo
    8686  PARAMETER (ninter=5)
    … …  
    545545           enddo
    546546
    547            if (iflag_cldth>=5) then
     547           if (iflag_cld_th>=5) then
    548548
    549549              call cloudth(klon,klev,k,ztv, &
    … …  
    559559           endif
    560560
    561            if (iflag_cldth <= 4) then
     561           if (iflag_cld_th <= 4) then
    562562              lognormale = .true.
    563            elseif (iflag_cldth >= 6) then
     563           elseif (iflag_cld_th >= 6) then
    564564              ! lognormale en l'absence des thermiques
    565565              lognormale = fraca(:,k) < 1e-10
    566566           else
    567               ! Dans le cas iflag_cldth=5, on prend systématiquement la
     567              ! Dans le cas iflag_cld_th=5, on prend systématiquement la
    568568              ! bi-gaussienne
    569569              lognormale = .false.
    … …  
    783783        else if (iflag_fisrtilp_qsat.gt.0) then
    784784           DO i= 1, klon
    785              if (lognormale(i)) then
    786              zt(i)=Tbef(i)
    787              else
    788785             zt(i) = zt(i) + zcond(i) * RLVTT/RCPD/(1.0+RVTMP2*(zq(i)+zcond(i)))
    789              endif
    790786           ENDDO
    791787        endif
    … …  
    800796!                                     t_glace_max, exposant_glace)
    801797              if (iflag_t_glace.eq.0) then
    802                     zfice(i) = 1.0 - (Tbef(i)-t_glace_min_old) / (RTT-t_glace_min_old)
     798                    zfice(i) = 1.0 - (zt(i)-t_glace_min_old) / (RTT-t_glace_min_old)
    803799                    zfice(i) = MIN(MAX(zfice(i),0.0),1.0)
    804800                    zfice(i) = zfice(i)**exposant_glace_old
    … …  
    809805         else
    810806           DO i=1, klon
    811               if (lognormale(i)) then
    812                  zt(i)=Tbef(i)
    813               else
    814807! JBM: icefrac_lsc is now a function contained in icefrac_lsc_mod
    815808!              zfice(i) = icefrac_lsc(zt(i), t_glace_min, &
    816809!                                     t_glace_max, exposant_glace)
    817810              if (iflag_t_glace.eq.0) then
    818                     zfice(i) = 1.0 - (Tbef(i)-t_glace_min_old) / (RTT-t_glace_min_old)
     811                    zfice(i) = 1.0 - (zt(i)-t_glace_min_old) / (RTT-t_glace_min_old)
    819812                    zfice(i) = MIN(MAX(zfice(i),0.0),1.0)
    820813                    zfice(i) = zfice(i)**exposant_glace_old
    … …  
    822815              zt(i) = zt(i) + (1.-zfice(i))*zcond(i) * RLVTT/RCPD/(1.0+RVTMP2*(zq(i)+zcond(i))) &
    823816                       +zfice(i)*zcond(i) * RLSTT/RCPD/(1.0+RVTMP2*(zq(i)+zcond(i)))
    824               endif
    825817           ENDDO
    826818         endif

  • LMDZ5/branches/testing/libf/phylmd/hgardfou.F90

    r2160 r2258  
    11
    22! $Id$
    3 SUBROUTINE hgardfou(t, tsol, text)
     3SUBROUTINE hgardfou(t, tsol, text,abortphy)
    44  USE dimphy
    55  USE phys_state_var_mod
    … …  
    1515  CHARACTER(len=*), intent(in):: text
    1616  CHARACTER (LEN=20) :: modname = 'hgardfou'
     17  INTEGER abortphy
    1718
    1819  INTEGER i, k, nsrf
    … …  
    128129  END DO
    129130
    130   IF (.NOT. ok) CALL abort_gcm(modname, text, 1)
     131!  IF (.NOT. ok) CALL abort_gcm(modname, text, 1)
     132  IF (.NOT. ok) abortphy=1
    131133
    132134END SUBROUTINE hgardfou

  • LMDZ5/branches/testing/libf/phylmd/iniphysiq.F90

    r1999 r2258  
    33
    44
    5 
    6 SUBROUTINE iniphysiq(ngrid, nlayer, punjours, pdayref, ptimestep, plat, plon, &
    7     parea, pcu, pcv, prad, pg, pr, pcpp, iflag_phys)
    8   USE dimphy, ONLY: klev
    9   USE mod_grid_phy_lmdz, ONLY: klon_glo
    10   USE mod_phys_lmdz_para, ONLY: klon_omp, klon_omp_begin, klon_omp_end, &
    11     klon_mpi_begin
    12   USE comgeomphy, ONLY: airephy, cuphy, cvphy, rlond, rlatd
     5SUBROUTINE iniphysiq(iim,jjm,nlayer,punjours, pdayref,ptimestep,         &
     6                     rlatu,rlonv,aire,cu,cv,                             &
     7                     prad,pg,pr,pcpp,iflag_phys)
     8  USE dimphy, ONLY: klev ! number of atmospheric levels
     9  USE mod_grid_phy_lmdz, ONLY: klon_glo ! number of atmospheric columns
     10                                        ! (on full grid)
     11  USE mod_phys_lmdz_para, ONLY: klon_omp, & ! number of columns (on local omp grid)
     12                                klon_omp_begin, & ! start index of local omp subgrid
     13                                klon_omp_end, & ! end index of local omp subgrid
     14                                klon_mpi_begin ! start indes of columns (on local mpi grid)
     15  USE comgeomphy, ONLY: initcomgeomphy, &
     16                        airephy, & ! physics grid area (m2)
     17                        cuphy, & ! cu coeff. (u_covariant = cu * u)
     18                        cvphy, & ! cv coeff. (v_covariant = cv * v)
     19                        rlond, & ! longitudes
     20                        rlatd ! latitudes
    1321  USE phyaqua_mod, ONLY: iniaqua
    1422  IMPLICIT NONE
    1523
    1624  ! =======================================================================
    17 
    1825  ! Initialisation of the physical constants and some positional and
    1926  ! geometrical arrays for the physics
    20 
    21 
    22   ! ngrid                 Size of the horizontal grid.
    23   ! All internal loops are performed on that grid.
    24   ! nlayer                Number of vertical layers.
    25   ! pdayref               Day of reference for the simulation
    26 
    2727  ! =======================================================================
    2828
    29   ! ym#include "dimensions.h"
    30   ! ym#include "dimphy.h"
    31   ! ym#include "comgeomphy.h"
    3229  include "YOMCST.h"
    3330  include "iniprint.h"
    … …  
    3835  REAL, INTENT (IN) :: pcpp ! specific heat Cp
    3936  REAL, INTENT (IN) :: punjours ! length (in s) of a standard day
    40   INTEGER, INTENT (IN) :: ngrid ! number of horizontal grid points in the physics
    4137  INTEGER, INTENT (IN) :: nlayer ! number of atmospheric layers
    42   REAL, INTENT (IN) :: plat(ngrid) ! latitudes of the physics grid
    43   REAL, INTENT (IN) :: plon(ngrid) ! longitudes of the physics grid
    44   REAL, INTENT (IN) :: parea(klon_glo) ! area (m2)
    45   REAL, INTENT (IN) :: pcu(klon_glo) ! cu coeff. (u_covariant = cu * u)
    46   REAL, INTENT (IN) :: pcv(klon_glo) ! cv coeff. (v_covariant = cv * v)
     38  INTEGER, INTENT (IN) :: iim ! number of atmospheric columns along longitudes
     39  INTEGER, INTENT (IN) :: jjm ! number of atompsheric columns along latitudes
     40  REAL, INTENT (IN) :: rlatu(jjm+1) ! latitudes of the physics grid
     41  REAL, INTENT (IN) :: rlonv(iim+1) ! longitudes of the physics grid
     42  REAL, INTENT (IN) :: aire(iim+1,jjm+1) ! area of the dynamics grid (m2)
     43  REAL, INTENT (IN) :: cu((iim+1)*(jjm+1)) ! cu coeff. (u_covariant = cu * u)
     44  REAL, INTENT (IN) :: cv((iim+1)*jjm) ! cv coeff. (v_covariant = cv * v)
    4745  INTEGER, INTENT (IN) :: pdayref ! reference day of for the simulation
    4846  REAL, INTENT (IN) :: ptimestep !physics time step (s)
    … …  
    5048
    5149  INTEGER :: ibegin, iend, offset
     50  INTEGER :: i,j
    5251  CHARACTER (LEN=20) :: modname = 'iniphysiq'
    5352  CHARACTER (LEN=80) :: abort_message
     53  REAL :: total_area_phy, total_area_dyn
     54
     55
     56  ! global array, on full physics grid:
     57  REAL,ALLOCATABLE :: latfi(:)
     58  REAL,ALLOCATABLE :: lonfi(:)
     59  REAL,ALLOCATABLE :: cufi(:)
     60  REAL,ALLOCATABLE :: cvfi(:)
     61  REAL,ALLOCATABLE :: airefi(:)
    5462
    5563  IF (nlayer/=klev) THEN
    … …  
    6270  END IF
    6371
    64   IF (ngrid/=klon_glo) THEN
    65     WRITE (lunout, *) 'STOP in ', trim(modname)
    66     WRITE (lunout, *) 'Problem with dimensions :'
    67     WRITE (lunout, *) 'ngrid     = ', ngrid
    68     WRITE (lunout, *) 'klon   = ', klon_glo
    69     abort_message = ''
    70     CALL abort_gcm(modname, abort_message, 1)
    71   END IF
    72 
    73   !$OMP PARALLEL PRIVATE(ibegin,iend) &
    74   !$OMP          SHARED(parea,pcu,pcv,plon,plat)
     72  !call init_phys_lmdz(iim,jjm+1,llm,1,(/(jjm-1)*iim+2/))
     73 
     74  ! Generate global arrays on full physics grid
     75  ALLOCATE(latfi(klon_glo),lonfi(klon_glo),cufi(klon_glo),cvfi(klon_glo))
     76  ALLOCATE(airefi(klon_glo))
     77
     78  IF (klon_glo>1) THEN ! general case
     79    ! North pole
     80    latfi(1)=rlatu(1)
     81    lonfi(1)=0.
     82    cufi(1) = cu(1)
     83    cvfi(1) = cv(1)
     84    DO j=2,jjm
     85      DO i=1,iim
     86        latfi((j-2)*iim+1+i)= rlatu(j)
     87        lonfi((j-2)*iim+1+i)= rlonv(i)
     88        cufi((j-2)*iim+1+i) = cu((j-1)*iim+1+i)
     89        cvfi((j-2)*iim+1+i) = cv((j-1)*iim+1+i)
     90      ENDDO
     91    ENDDO
     92    ! South pole
     93    latfi(klon_glo)= rlatu(jjm+1)
     94    lonfi(klon_glo)= 0.
     95    cufi(klon_glo) = cu((iim+1)*jjm+1)
     96    cvfi(klon_glo) = cv((iim+1)*jjm-iim)
     97
     98    ! build airefi(), mesh area on physics grid
     99    CALL gr_dyn_fi(1,iim+1,jjm+1,klon_glo,aire,airefi)
     100    ! Poles are single points on physics grid
     101    airefi(1)=sum(aire(1:iim,1))
     102    airefi(klon_glo)=sum(aire(1:iim,jjm+1))
     103
     104    ! Sanity check: do total planet area match between physics and dynamics?
     105    total_area_dyn=sum(aire(1:iim,1:jjm+1))
     106    total_area_phy=sum(airefi(1:klon_glo))
     107    IF (total_area_dyn/=total_area_phy) THEN
     108      WRITE (lunout, *) 'iniphysiq: planet total surface discrepancy !!!'
     109      WRITE (lunout, *) '     in the dynamics total_area_dyn=', total_area_dyn
     110      WRITE (lunout, *) '  but in the physics total_area_phy=', total_area_phy
     111      IF (abs(total_area_dyn-total_area_phy)>0.00001*total_area_dyn) THEN
     112        ! stop here if the relative difference is more than 0.001%
     113        abort_message = 'planet total surface discrepancy'
     114        CALL abort_gcm(modname, abort_message, 1)
     115      ENDIF
     116    ENDIF
     117  ELSE ! klon_glo==1, running the 1D model
     118    ! just copy over input values
     119    latfi(1)=rlatu(1)
     120    lonfi(1)=rlonv(1)
     121    cufi(1)=cu(1)
     122    cvfi(1)=cv(1)
     123    airefi(1)=aire(1,1)
     124  ENDIF ! of IF (klon_glo>1)
     125
     126!$OMP PARALLEL
     127  ! Now generate local lon/lat/cu/cv/area arrays
     128  CALL initcomgeomphy
    75129
    76130  offset = klon_mpi_begin - 1
    77   airephy(1:klon_omp) = parea(offset+klon_omp_begin:offset+klon_omp_end)
    78   cuphy(1:klon_omp) = pcu(offset+klon_omp_begin:offset+klon_omp_end)
    79   cvphy(1:klon_omp) = pcv(offset+klon_omp_begin:offset+klon_omp_end)
    80   rlond(1:klon_omp) = plon(offset+klon_omp_begin:offset+klon_omp_end)
    81   rlatd(1:klon_omp) = plat(offset+klon_omp_begin:offset+klon_omp_end)
     131  airephy(1:klon_omp) = airefi(offset+klon_omp_begin:offset+klon_omp_end)
     132  cuphy(1:klon_omp) = cufi(offset+klon_omp_begin:offset+klon_omp_end)
     133  cvphy(1:klon_omp) = cvfi(offset+klon_omp_begin:offset+klon_omp_end)
     134  rlond(1:klon_omp) = lonfi(offset+klon_omp_begin:offset+klon_omp_end)
     135  rlatd(1:klon_omp) = latfi(offset+klon_omp_begin:offset+klon_omp_end)
    82136
    83137    ! suphel => initialize some physical constants (orbital parameters,
    … …  
    86140  CALL suphel
    87141
    88   !$OMP END PARALLEL
    89 
    90     ! check that physical constants set in 'suphel' are coherent
    91     ! with values set in the dynamics:
     142!$OMP END PARALLEL
     143
     144  ! check that physical constants set in 'suphel' are coherent
     145  ! with values set in the dynamics:
    92146  IF (rday/=punjours) THEN
    93147    WRITE (lunout, *) 'iniphysiq: length of day discrepancy!!!'
    … …  
    142196
    143197  ! Additional initializations for aquaplanets
    144   !$OMP PARALLEL
     198!$OMP PARALLEL
    145199  IF (iflag_phys>=100) THEN
    146200    CALL iniaqua(klon_omp, rlatd, rlond, iflag_phys)
    147201  END IF
    148   !$OMP END PARALLEL
    149 
    150   ! RETURN
    151   ! 9999  CONTINUE
    152   ! abort_message ='Cette version demande les fichier rnatur.dat
    153   ! & et surf.def'
    154   ! CALL abort_gcm (modname,abort_message,1)
     202!$OMP END PARALLEL
    155203
    156204END SUBROUTINE iniphysiq

  • LMDZ5/branches/testing/libf/phylmd/lmdz1d.F90

    r2220 r2258  
    1010      USE ioipsl, only: ju2ymds, ymds2ju, ioconf_calendar
    1111      use phys_state_var_mod
    12       use comgeomphy
    1312      use dimphy
    1413      use surface_data, only : type_ocean,ok_veget
    … …  
    203202!  Call to physiq
    204203!---------------------------------------------------------------------
    205       integer, parameter :: longcles=20
    206204      logical :: firstcall=.true.
    207205      logical :: lastcall=.false.
    208206      real :: phis    = 0.0
    209       real :: clesphy0(longcles) = 0.0
    210207      real :: dpsrf
    211208
    … …  
    365362!---------------------------------------------------------------------
    366363
    367       call conf_gcm( 99, .TRUE. , clesphy0 )
     364      call conf_gcm( 99, .TRUE. )
    368365!-----------------------------------------------------------------------
    369366!   Choix du calendrier
    … …  
    473470      call init_phys_lmdz(1,1,llm,1,(/1/))
    474471      call suphel
    475       call initcomgeomphy
    476472      call infotrac_init
    477473
    … …  
    608604      rlon_rad(:)=rlon(:)*rpi/180.
    609605
    610       call iniphysiq(ngrid,llm,rday,day_ini,timestep,                        &
     606      call iniphysiq(iim,jjm,llm,rday,day_ini,timestep,                        &
    611607     &     rlat_rad,rlon_rad,airefi,zcufi,zcvfi,ra,rg,rd,rcpd,(/1/))
    612608      print*,'apres iniphysiq'
    … …  
    618614! Ecriture du startphy avant le premier appel a la physique.
    619615! On le met juste avant pour avoir acces a tous les champs
    620 ! NB: les clesphy0 seront remplies dans phyredem d'apres les flags lus dans gcm.def
    621616
    622617      if (ok_writedem) then
    … …  
    673668        zpic = zpicinp
    674669        ftsol=tsurf
     670        nsw=6 ! on met le nb de bandes SW=6, pour initialiser
     671              ! 6 albedo, mais on peut quand meme tourner avec
     672              ! moins. Seules les 2 ou 4 premiers seront lus
    675673        falb1 = albedo                           
    676674        falb2 = albedo                           
     675        falb_dir=albedo
     676        falb_dif=albedo
    677677        rugoro=rugos
    678678        t_ancien(1,:)=temp(:)
    … …  
    859859     &              firstcall,lastcall,                                     &
    860860     &              day,time,timestep,                                      &
    861      &              plev,play,phi,phis,presnivs,clesphy0,                   &
     861     &              plev,play,phi,phis,presnivs,                            &
    862862     &              u,v,temp,q,omega2,                                      &
    863863     &              du_phys,dv_phys,dt_phys,dq,dpsrf,                        &

  • LMDZ5/branches/testing/libf/phylmd/pbl_surface_mod.F90

    r2220 r2258  
    181181!!!
    182182       pplay,     paprs,     pctsrf,                  &
    183        ts,        alb1, alb2,ustar, u10m, v10m,wstar, &
     183!albedo SB >>>
     184!       ts,        alb1, alb2,ustar, u10m, v10m,wstar, &
     185       ts,SFRWL,   alb_dir, alb_dif,ustar, u10m, v10m,wstar, &
     186!albedo SB <<<
    184187       cdragh,    cdragm,   zu1,    zv1,              &
    185        alb1_m,    alb2_m,    zxsens,   zxevap,        &
     188!albedo SB >>>
     189!       alb1_m,    alb2_m,    zxsens,   zxevap,        &
     190       alb_dir_m,    alb_dif_m,  zxsens,   zxevap,    &
     191!albedo SB <<<
    186192       alb3_lic,  runoff,    snowhgt,   qsnow,     to_ice,    sissnow,  &
    187193       zxtsol,    zxfluxlat, zt2m,     qsat2m,        &
    … …  
    349355    REAL, DIMENSION(klon, nbsrf), INTENT(INOUT)     :: delta_tsurf !surface temperature difference between
    350356                                                                   !wake and off-wake regions
    351     REAL, DIMENSION(klon, nbsrf), INTENT(INOUT)     :: alb1    ! albedo in visible SW interval
    352     REAL, DIMENSION(klon, nbsrf), INTENT(INOUT)     :: alb2    ! albedo in near infra-red SW interval
     357!albedo SB >>>
     358!    REAL, DIMENSION(klon, nbsrf), INTENT(INOUT)     :: alb1    ! albedo in visible SW interval
     359!    REAL, DIMENSION(klon, nbsrf), INTENT(INOUT)     :: alb2    ! albedo in near infra-red SW interval
     360    REAL, DIMENSIOn(6),intent(in) :: SFRWL
     361    REAL, DIMENSION(klon, nsw, nbsrf), INTENT(INOUT)     :: alb_dir,alb_dif
     362!albedo SB <<<
    353363!jyg Pourquoi ustar et wstar sont-elles INOUT ?
    354364    REAL, DIMENSION(klon, nbsrf), INTENT(INOUT)     :: ustar   ! u* (m/s)
    … …  
    371381    REAL, DIMENSION(klon),        INTENT(OUT)       :: zu1        ! u wind speed in first layer
    372382    REAL, DIMENSION(klon),        INTENT(OUT)       :: zv1        ! v wind speed in first layer
    373     REAL, DIMENSION(klon),        INTENT(OUT)       :: alb1_m     ! mean albedo in visible SW interval
    374     REAL, DIMENSION(klon),        INTENT(OUT)       :: alb2_m     ! mean albedo in near IR SW interval
     383!albedo SB >>>
     384!    REAL, DIMENSION(klon),        INTENT(OUT)       :: alb1_m     ! mean albedo
     385!    in visible SW interval
     386!    REAL, DIMENSION(klon),        INTENT(OUT)       :: alb2_m     ! mean albedo
     387!    in near IR SW interval
     388    REAL, DIMENSION(klon, nsw),        INTENT(OUT)       :: alb_dir_m,alb_dif_m
     389!albedo SB <<<
    375390    ! Martin
    376391    REAL, DIMENSION(klon),        INTENT(OUT)       :: alb3_lic
    … …  
    505520    REAL, DIMENSION(klon)              :: r_co2_ppm     ! taux CO2 atmosphere
    506521    REAL, DIMENSION(klon)              :: yts, yrugos, ypct, yz0_new
    507     REAL, DIMENSION(klon)              :: yalb, yalb1, yalb2
     522!albedo SB >>>
     523!   REAL, DIMENSION(klon)              :: yalb, yalb1, yalb2
     524    REAL, DIMENSION(klon)              :: yalb,yalb_vis
     525!albedo SB <<<
    508526    REAL, DIMENSION(klon)              :: yu1, yv1
    509527    REAL, DIMENSION(klon)              :: ysnow, yqsurf, yagesno, yqsol
    … …  
    535553    REAL, DIMENSION(klon)              :: tair1, qair1, tairsol
    536554    REAL, DIMENSION(klon)              :: psfce, patm
    537     REAL, DIMENSION(klon)              :: qairsol, zgeo1
     555    REAL, DIMENSION(klon)              :: qairsol, zgeo1, speed, zri1, pref !speed, zri1, pref, added by Fuxing WANG, 04/03/2015
    538556    REAL, DIMENSION(klon)              :: rugo1
    539557    REAL, DIMENSION(klon)              :: yfluxsens
    … …  
    542560    REAL, DIMENSION(klon)              :: ypsref
    543561    REAL, DIMENSION(klon)              :: yevap, ytsurf_new, yalb1_new, yalb2_new, yalb3_new
     562!albedo SB >>>
     563    REAL, DIMENSION(klon,nsw)          :: yalb_dir_new, yalb_dif_new
     564!albedo SB <<<
    544565    REAL, DIMENSION(klon)              :: ztsol
    545566    REAL, DIMENSION(klon)              :: alb_m  ! mean albedo for whole SW interval
    … …  
    693714    REAL, DIMENSION(klon)       :: ytrmb3_w
    694715!
    695     REAL, DIMENSION(klon)              :: uzon_x, vmer_x
     716    REAL, DIMENSION(klon)              :: uzon_x, vmer_x, speed_x, zri1_x, pref_x !speed_x, zri1_x, pref_x, added by Fuxing WANG, 04/03/2015
    696717    REAL, DIMENSION(klon)              :: zgeo1_x, tair1_x, qair1_x, tairsol_x
    697718!
    698     REAL, DIMENSION(klon)              :: uzon_w, vmer_w
     719    REAL, DIMENSION(klon)              :: uzon_w, vmer_w, speed_w, zri1_w, pref_w !speed_w, zri1_w, pref_w, added by Fuxing WANG, 04/03/2015
    699720    REAL, DIMENSION(klon)              :: zgeo1_w, tair1_w, qair1_w, tairsol_w
    700721
    … …  
    855876 cdragh(:)=0. ; cdragm(:)=0.
    856877 zu1(:)=0. ; zv1(:)=0.
    857  alb1_m(:)=0. ; alb2_m(:)=0. ; alb3_lic(:)=0.
     878!albedo SB >>>
     879! alb1_m(:)=0. ; alb2_m(:)=0. ; alb3_lic(:)=0.
     880  alb_dir_m=0. ; alb_dif_m=0. ; alb3_lic(:)=0.
     881!albedo SB <<<
    858882 zxsens(:)=0. ; zxevap(:)=0. ; zxtsol(:)=0.
    859883 d_t_w(:,:)=0. ; d_q_w(:,:)=0. ; d_t_x(:,:)=0. ; d_q_x(:,:)=0.
    … …  
    920944    ypct = 0.0    ; yts = 0.0        ; ysnow = 0.0
    921945!!    zv1 = 0.0     ; yqsurf = 0.0     ; yalb1 = 0.0     ; yalb2 = 0.0   
    922     yqsurf = 0.0  ; yalb1 = 0.0      ; yalb2 = 0.0   
     946!albedo SB >>>
     947!    yqsurf = 0.0  ; yalb1 = 0.0      ; yalb2 = 0.0   
     948    yqsurf = 0.0  ; yalb = 0.0 ; yalb_vis = 0.0
     949!albedo SB <<<
    923950    yrain_f = 0.0 ; ysnow_f = 0.0    ; yfder = 0.0     ; ysolsw = 0.0   
    924951    ysollw = 0.0  ; yrugos = 0.0     ; yu1 = 0.0   
    … …  
    10701097! * alb_m  : mean albedo at whole SW interval
    10711098
    1072     alb1_m(:) = 0.0
    1073     alb2_m(:) = 0.0
    1074     DO nsrf = 1, nbsrf
     1099!albedo SB >>>
     1100!    alb1_m(:) = 0.0
     1101!    alb2_m(:) = 0.0
     1102!    DO nsrf = 1, nbsrf
     1103!       DO i = 1, klon
     1104!          alb1_m(i) = alb1_m(i) + alb1(i,nsrf) * pctsrf(i,nsrf)
     1105!          alb2_m(i) = alb2_m(i) + alb2(i,nsrf) * pctsrf(i,nsrf)
     1106!       ENDDO
     1107!    ENDDO
     1108
     1109    alb_dir_m(:,:) = 0.0
     1110    alb_dif_m(:,:) = 0.0
     1111    DO k = 1, nsw
     1112     DO nsrf = 1, nbsrf
    10751113       DO i = 1, klon
    1076           alb1_m(i) = alb1_m(i) + alb1(i,nsrf) * pctsrf(i,nsrf)
    1077           alb2_m(i) = alb2_m(i) + alb2(i,nsrf) * pctsrf(i,nsrf)
     1114          alb_dir_m(i,k) = alb_dir_m(i,k) + alb_dir(i,k,nsrf) * pctsrf(i,nsrf)
     1115          alb_dif_m(i,k) = alb_dif_m(i,k) + alb_dif(i,k,nsrf) * pctsrf(i,nsrf)
    10781116       ENDDO
     1117     ENDDO
    10791118    ENDDO
    10801119
    10811120! We here suppose the fraction f1 of incoming radiance of visible radiance
    10821121! as a fraction of all shortwave radiance
    1083     f1 = 0.5 
     1122    f1 = 0.5
    10841123!    f1 = 1    ! put f1=1 to recreate old calculations
    10851124
    1086     DO nsrf = 1, nbsrf
    1087        DO i = 1, klon
    1088           alb(i,nsrf) = f1*alb1(i,nsrf) + (1-f1)*alb2(i,nsrf)
    1089        ENDDO
     1125!    DO nsrf = 1, nbsrf
     1126!       DO i = 1, klon
     1127!          alb(i,nsrf) = f1*alb1(i,nsrf) + (1-f1)*alb2(i,nsrf)
     1128!       ENDDO
     1129!    ENDDO
     1130!
     1131!    DO i = 1, klon
     1132!       alb_m(i) = f1*alb1_m(i) + (1-f1)*alb2_m(i)
     1133!    END DO
     1134
     1135
     1136!f1 is already included with SFRWL values in each surf files
     1137    alb=0.0
     1138    DO k=1,nsw
     1139      DO nsrf = 1, nbsrf
     1140        DO i = 1, klon
     1141            alb(i,nsrf) = alb(i,nsrf) + alb_dir(i,k,nsrf)*SFRWL(k)
     1142        ENDDO
     1143      ENDDO
    10901144    ENDDO
    10911145
    1092     DO i = 1, klon
    1093        alb_m(i) = f1*alb1_m(i) + (1-f1)*alb2_m(i)
    1094     END DO
     1146    alb_m=0.0
     1147    DO k = 1,nsw
     1148      DO i = 1, klon
     1149        alb_m(i) = alb_m(i) + alb_dir_m(i,k)*SFRWL(k)
     1150      END DO
     1151    ENDDO
     1152!albedo SB <<<
     1153
     1154
    10951155
    10961156! Calculation of mean temperature at surface grid points
    … …  
    11701230          yqsurf(j)  = qsurf(i,nsrf)
    11711231          yalb(j)    = alb(i,nsrf)
    1172           yalb1(j)   = alb1(i,nsrf)
    1173           yalb2(j)   = alb2(i,nsrf)
     1232!albedo SB >>>
     1233!         yalb1(j)   = alb1(i,nsrf)
     1234!         yalb2(j)   = alb2(i,nsrf)
     1235          yalb_vis(j) = alb_dir(i,1,nsrf)
     1236          if(nsw==6)then
     1237            yalb_vis(j)=(alb_dir(i,1,nsrf)*SFRWL(1)+alb_dir(i,2,nsrf)*SFRWL(2) &
     1238              +alb_dir(i,3,nsrf)*SFRWL(3))/(SFRWL(1)+SFRWL(2)+SFRWL(3))
     1239          endif
     1240!albedo SB <<<
    11741241          yrain_f(j) = rain_f(i)
    11751242          ysnow_f(j) = snow_f(i)
    … …  
    12951362!!!
    12961363!!! nrlmd & jyg les 02/05/2011, 13/06/2011, 05/02/2012
    1297         CALL clcdrag( knon, nsrf, ypaprs, ypplay, &
    1298             yu(:,1), yv(:,1), yt(:,1), yq(:,1), &
     1364! Faire disparaitre les lignes commentees fin 2015 (le temps des tests)
     1365!       CALL clcdrag( knon, nsrf, ypaprs, ypplay, &
     1366!           yu(:,1), yv(:,1), yt(:,1), yq(:,1), &
     1367!           yts, yqsurf, yrugos, &
     1368!           ycdragm, ycdragh )
     1369! Fuxing WANG, 04/03/2015, replace the clcdrag by the merged version: cdrag
     1370        DO i = 1, knon
     1371!          print*,'PBL ',i,RD
     1372!          print*,'PBL ',yt(i,1),ypaprs(i,1),ypplay(i,1)
     1373           zgeo1(i) = RD * yt(i,1) / (0.5*(ypaprs(i,1)+ypplay(i,1))) &
     1374                * (ypaprs(i,1)-ypplay(i,1))
     1375           speed(i) = SQRT(yu(i,1)**2+yv(i,1)**2)
     1376        END DO
     1377        CALL cdrag(knon, nsrf, &
     1378            speed, yt(:,1), yq(:,1), zgeo1, ypaprs(:,1),&
    12991379            yts, yqsurf, yrugos, &
    1300             ycdragm, ycdragh )
     1380            ycdragm, ycdragh, zri1, pref )
     1381
    13011382! --- special Dice: on force cdragm ( a defaut de forcer ustar) MPL 05082013
    13021383     IF (ok_prescr_ust) then
    … …  
    13131394        IF (prt_level >=10) print *,'clcdrag -> ycdragh ', ycdragh
    13141395       ELSE  !(iflag_split .eq.0)
    1315         CALL clcdrag( knon, nsrf, ypaprs, ypplay, &
    1316             yu_x(:,1), yv_x(:,1), yt_x(:,1), yq_x(:,1), &
     1396
     1397! Faire disparaitre les lignes commentees fin 2015 (le temps des tests)
     1398!       CALL clcdrag( knon, nsrf, ypaprs, ypplay, &
     1399!           yu_x(:,1), yv_x(:,1), yt_x(:,1), yq_x(:,1), &
     1400!           yts_x, yqsurf, yrugos, &
     1401!           ycdragm_x, ycdragh_x )
     1402! Fuxing WANG, 04/03/2015, replace the clcdrag by the merged version: cdrag
     1403        DO i = 1, knon
     1404           zgeo1_x(i) = RD * yt_x(i,1) / (0.5*(ypaprs(i,1)+ypplay(i,1))) &
     1405                * (ypaprs(i,1)-ypplay(i,1))
     1406           speed_x(i) = SQRT(yu_x(i,1)**2+yv_x(i,1)**2)
     1407        END DO
     1408        CALL cdrag(knon, nsrf, &
     1409            speed_x, yt_x(:,1), yq_x(:,1), zgeo1_x, ypaprs(:,1),&
    13171410            yts_x, yqsurf, yrugos, &
    1318             ycdragm_x, ycdragh_x )
     1411            ycdragm_x, ycdragh_x, zri1_x, pref_x )
     1412
    13191413! --- special Dice. JYG+MPL 25112013
    13201414        IF (ok_prescr_ust) then
    … …  
    17101804               ylwdown, yq2m, yt2m, &
    17111805               ysnow, yqsol, yagesno, ytsoil, &
    1712                yz0_new, yalb1_new, yalb2_new, yevap, yfluxsens, yfluxlat, &
     1806!albedo SB >>>
     1807!              yz0_new, yalb1_new, yalb2_new, yevap, yfluxsens, yfluxlat, &
     1808               yz0_new, SFRWL, yalb_dir_new, yalb_dif_new, yevap, yfluxsens,yfluxlat,&
     1809!albedo SB <<<
    17131810               yqsurf, ytsurf_new, y_dflux_t, y_dflux_q, &
    17141811               y_flux_u1, y_flux_v1 )
    … …  
    17461843               ypsref, yu1, yv1, yrugoro, pctsrf, &
    17471844               ysnow, yqsurf, yqsol, yagesno, &
    1748                ytsoil, yz0_new, yalb1_new, yalb2_new, yevap, yfluxsens, yfluxlat, &
     1845!albedo SB >>>
     1846!              ytsoil, yz0_new, yalb1_new, yalb2_new, yevap, yfluxsens, yfluxlat, &
     1847               ytsoil, yz0_new, SFRWL, yalb_dir_new, yalb_dif_new, yevap,yfluxsens,yfluxlat, &
     1848!albedo SB <<<
    17491849               ytsurf_new, y_dflux_t, y_dflux_q, &
    17501850               yzsig, ycldt, &
    … …  
    17781878         
    17791879       CASE(is_oce)
    1780           CALL surf_ocean(rlon, rlat, ysolsw, ysollw, yalb1, &
     1880!albedo SB >>>
     1881!          CALL surf_ocean(rlon, rlat, ysolsw, ysollw, yalb1, &
     1882           CALL surf_ocean(rlon, rlat, ysolsw, ysollw, yalb_vis, &
     1883!albedo SB <<<
    17811884               yrugos, ywindsp, rmu0, yfder, yts, &
    17821885               itap, dtime, jour, knon, ni, &
    … …  
    17861889               ypsref, yu1, yv1, yrugoro, pctsrf, &
    17871890               ysnow, yqsurf, yagesno, &
    1788                yz0_new, yalb1_new, yalb2_new, yevap, yfluxsens, yfluxlat, &
     1891!albedo SB >>>
     1892!              yz0_new, yalb1_new, yalb2_new, yevap, yfluxsens, yfluxlat, &
     1893               yz0_new, SFRWL,yalb_dir_new, yalb_dif_new, yevap, yfluxsens,yfluxlat,&
     1894!albedo SB <<<
    17891895               ytsurf_new, y_dflux_t, y_dflux_q, slab_wfbils, &
    17901896               y_flux_u1, y_flux_v1)
    … …  
    18071913       CASE(is_sic)
    18081914          CALL surf_seaice( &
    1809                rlon, rlat, ysolsw, ysollw, yalb1, yfder, &
     1915!albedo SB >>>
     1916!               rlon, rlat, ysolsw, ysollw, yalb1, yfder, &
     1917               rlon, rlat, ysolsw, ysollw, yalb_vis, yfder, &
     1918!albedo SB <<<
    18101919               itap, dtime, jour, knon, ni, &
    18111920               lafin, &
    … …  
    18151924               ypsref, yu1, yv1, yrugoro, pctsrf, &
    18161925               ysnow, yqsurf, yqsol, yagesno, ytsoil, &
    1817                yz0_new, yalb1_new, yalb2_new, yevap, yfluxsens, yfluxlat, &
     1926!albedo SB >>>
     1927!               yz0_new, yalb1_new, yalb2_new, yevap, yfluxsens, yfluxlat, &
     1928               yz0_new, SFRWL, yalb_dir_new, yalb_dif_new, yevap, yfluxsens,yfluxlat,&
     1929!albedo SB <<<
    18181930               ytsurf_new, y_dflux_t, y_dflux_q, &
    18191931               y_flux_u1, y_flux_v1)
    … …  
    21852297          evap(i,nsrf) = - flux_q(i,1,nsrf)                  !jyg
    21862298          d_ts(i,nsrf) = y_d_ts(j)
    2187           alb1(i,nsrf) = yalb1_new(j) 
    2188           alb2(i,nsrf) = yalb2_new(j)
     2299!albedo SB >>>
     2300!          alb1(i,nsrf) = yalb1_new(j) 
     2301!          alb2(i,nsrf) = yalb2_new(j)
     2302          do k=1,nsw
     2303          alb_dir(i,k,nsrf) = yalb_dir_new(j,k)
     2304          alb_dif(i,k,nsrf) = yalb_dif_new(j,k)
     2305          enddo
     2306!albedo SB <<<
    21892307          snow(i,nsrf) = ysnow(j) 
    21902308          qsurf(i,nsrf) = yqsurf(j)
    … …  
    29303048!****************************************************************************************
    29313049!
    2932   SUBROUTINE pbl_surface_newfrac(itime, pctsrf_new, pctsrf_old, tsurf, alb1, alb2, ustar, u10m, v10m, tke)
    2933 
     3050
     3051!albedo SB >>>
     3052!  SUBROUTINE pbl_surface_newfrac(itime, pctsrf_new, pctsrf_old, tsurf, alb1, alb2, ustar, u10m, v10m, tke)
     3053SUBROUTINE pbl_surface_newfrac(itime, pctsrf_new, pctsrf_old, tsurf,alb_dir,alb_dif, ustar, u10m, v10m, tke) 
     3054!albedo SB <<<
    29343055    ! Give default values where new fraction has appread
    29353056
    … …  
    29483069!****************************************************************************************
    29493070    REAL, DIMENSION(klon,nbsrf), INTENT(INOUT)        :: tsurf
    2950     REAL, DIMENSION(klon,nbsrf), INTENT(INOUT)        :: alb1, alb2
     3071!albedo SB >>>
     3072!   REAL, DIMENSION(klon,nbsrf), INTENT(INOUT)        :: alb1, alb2
     3073    REAL, DIMENSION(klon,nsw,nbsrf), INTENT(INOUT)       :: alb_dir, alb_dif
     3074    INTEGER :: k
     3075!albedo SB <<<
    29513076    REAL, DIMENSION(klon,nbsrf), INTENT(INOUT)        :: ustar,u10m, v10m
    29523077    REAL, DIMENSION(klon,klev+1,nbsrf+1), INTENT(INOUT) :: tke
    … …  
    29933118                rugos(i,nsrf) = rugos(i,nsrf_comp1)
    29943119                tsurf(i,nsrf) = tsurf(i,nsrf_comp1)
    2995                 alb1(i,nsrf)  = alb1(i,nsrf_comp1)
    2996                 alb2(i,nsrf)  = alb2(i,nsrf_comp1)
     3120!albedo SB >>>
     3121!                alb1(i,nsrf)  = alb1(i,nsrf_comp1)
     3122!                alb2(i,nsrf)  = alb2(i,nsrf_comp1)
     3123                DO k=1,nsw
     3124                 alb_dir(i,k,nsrf)=alb_dir(i,k,nsrf_comp1)
     3125                 alb_dif(i,k,nsrf)=alb_dif(i,k,nsrf_comp1)
     3126                ENDDO
     3127!albedo SB <<<
    29973128                ustar(i,nsrf)  = ustar(i,nsrf_comp1)
    29983129                u10m(i,nsrf)  = u10m(i,nsrf_comp1)
    … …  
    30083139                rugos(i,nsrf) = rugos(i,nsrf_comp2)*pctsrf_old(i,nsrf_comp2) + rugos(i,nsrf_comp3)*pctsrf_old(i,nsrf_comp3)
    30093140                tsurf(i,nsrf) = tsurf(i,nsrf_comp2)*pctsrf_old(i,nsrf_comp2) + tsurf(i,nsrf_comp3)*pctsrf_old(i,nsrf_comp3)
    3010                 alb1(i,nsrf)  = alb1(i,nsrf_comp2) *pctsrf_old(i,nsrf_comp2) + alb1(i,nsrf_comp3) *pctsrf_old(i,nsrf_comp3)
    3011                 alb2(i,nsrf)  = alb2(i,nsrf_comp2) *pctsrf_old(i,nsrf_comp2) + alb2(i,nsrf_comp3) *pctsrf_old(i,nsrf_comp3)
     3141!albedo SB >>>
     3142!                alb1(i,nsrf)  = alb1(i,nsrf_comp2) *pctsrf_old(i,nsrf_comp2) + alb1(i,nsrf_comp3) *pctsrf_old(i,nsrf_comp3)
     3143!                alb2(i,nsrf)  = alb2(i,nsrf_comp2) *pctsrf_old(i,nsrf_comp2) + alb2(i,nsrf_comp3) *pctsrf_old(i,nsrf_comp3)
     3144                DO k=1,nsw
     3145                 alb_dir(i,k,nsrf)=alb_dir(i,k,nsrf_comp2)*pctsrf_old(i,nsrf_comp2)+&
     3146                                        alb_dir(i,k,nsrf_comp3)*pctsrf_old(i,nsrf_comp3)
     3147                 alb_dif(i,k,nsrf)=alb_dif(i,k,nsrf_comp2)*pctsrf_old(i,nsrf_comp2)+&
     3148                                        alb_dif(i,k,nsrf_comp3)*pctsrf_old(i,nsrf_comp3)
     3149                ENDDO
     3150!albedo SB <<<
    30123151                ustar(i,nsrf)  = ustar(i,nsrf_comp2) *pctsrf_old(i,nsrf_comp2) + ustar(i,nsrf_comp3) *pctsrf_old(i,nsrf_comp3)
    30133152                u10m(i,nsrf)  = u10m(i,nsrf_comp2) *pctsrf_old(i,nsrf_comp2) + u10m(i,nsrf_comp3) *pctsrf_old(i,nsrf_comp3)

  • LMDZ5/branches/testing/libf/phylmd/phyetat0.F90

    r2220 r2258  
    1111  USE phys_state_var_mod, ONLY : ancien_ok, clwcon, detr_therm, dtime, &
    1212       du_gwd_rando, dv_gwd_rando, entr_therm, f0, falb1, falb2, fm_therm, &
     13       falb_dir, falb_dif, &
    1314       ftsol, pbl_tke, pctsrf, q_ancien, radpas, radsol, rain_fall, ratqs, &
    1415       rlat, rlon, rnebcon, rugoro, sig1, snow_fall, solaire_etat0, sollw, sollwdown, &
    … …  
    6970  INTEGER length
    7071  PARAMETER (length=100)
    71   INTEGER it, iiq
     72  INTEGER it, iiq, isw
    7273  REAL tab_cntrl(length), tabcntr0(length)
    7374  CHARACTER*7 str7
    … …  
    243244  ENDIF
    244245
     246!===================================================================
     247  ! Lecture des albedo difus et direct
     248
     249  DO nsrf = 1, nbsrf
     250     DO isw=1, nsw
     251        IF (isw.GT.99 .AND. nsrf.GT.99) THEN
     252           PRINT*, "Trop de bandes SW ou sous-mailles"
     253           call abort_gcm("phyetat0", "", 1)
     254        ENDIF
     255        WRITE(str7, '(i2.2, "srf", i2.2)') isw, nsrf
     256
     257        CALL get_field('A_dir_SW'//str7, falb_dir(:, isw, nsrf), found)
     258        IF (.NOT. found) THEN
     259           PRINT*, "phyetat0: Le champ <A_dir_SW"//str7//"> est absent"
     260           PRINT*, "          Il prend donc la valeur de surface"
     261           DO i=1, klon
     262              falb_dir(i, isw, nsrf)=0.2
     263           ENDDO
     264        ENDIF
     265        CALL get_field('A_dif_SW'//str7, falb_dif(:, isw, nsrf), found)
     266        IF (.NOT. found) THEN
     267           PRINT*, "phyetat0: Le champ <A_dif_SW"//str7//"> est absent"
     268           PRINT*, "          Il prend donc la valeur de surface"
     269           DO i=1, klon
     270              falb_dif(i, isw, nsrf)=0.2
     271           ENDDO
     272        ENDIF
     273     ENDDO
     274  ENDDO
     275
     276!===================================================================
    245277  ! Lecture des temperatures du sol profond:
    246278
    … …  
    264296  ENDDO
    265297
     298!===================================================================
    266299  ! Lecture de l'humidite de l'air juste au dessus du sol:
    267300

  • LMDZ5/branches/testing/libf/phylmd/phyredem.F90

    r2220 r2258  
    5151  REAL tab_cntrl(length)
    5252
    53   INTEGER isoil, nsrf
     53  INTEGER isoil, nsrf,isw
    5454  CHARACTER (len=7) :: str7
    5555  CHARACTER (len=2) :: str2
    … …  
    142142  ENDDO
    143143
     144! ================== Albedo =======================================
     145  print*,'PHYREDEM NOUVEAU'
     146  DO nsrf = 1, nbsrf
     147     DO isw=1, nsw
     148        IF (isw.LE.99 .AND. nsrf.LE.99) THEN
     149           WRITE(str7, '(i2.2, "srf", i2.2)') isw, nsrf
     150  print*,'PHYREDEM ',"A_dir_SW"//str7
     151           CALL put_field("A_dir_SW"//str7, "Albedo direct du sol bande "//str7, &
     152                falb_dir(:, isw, nsrf))
     153           CALL put_field("A_dif_SW"//str7, "Albedo difus du sol bande "//str7, &
     154                falb_dif(:, isw, nsrf))
     155        ELSE
     156           PRINT*, "Trop de couches"
     157           call abort_gcm("phyredem", "", 1)
     158        ENDIF
     159     ENDDO
     160  ENDDO
     161
     162! ================== Tsoil =======================================
    144163  DO nsrf = 1, nbsrf
    145164     DO isoil=1, nsoilmx

  • LMDZ5/branches/testing/libf/phylmd/phys_state_var_mod.F90

    r2220 r2258  
    3030      REAL, ALLOCATABLE, SAVE :: falb1(:,:), falb2(:,:)
    3131!$OMP THREADPRIVATE(falb1, falb2)
     32
     33!albedo SB >>>
     34      REAL, ALLOCATABLE, SAVE :: falb_dif(:,:,:), falb_dir(:,:,:)
     35      real, allocatable, save :: chl_con(:)
     36!$OMP THREADPRIVATE(falb_dir,falb_dif,chl_con)
     37!albedo SB <<<
     38
     39
    3240      REAL, ALLOCATABLE, SAVE :: rain_fall(:), snow_fall(:)
    3341!$OMP THREADPRIVATE( rain_fall, snow_fall)
    … …  
    261269!$OMP THREADPRIVATE(albsol1,albsol2)
    262270
     271!albedo SB >>>
     272      REAL,ALLOCATABLE,SAVE :: albsol_dif(:,:),albsol_dir(:,:)
     273!$OMP THREADPRIVATE(albsol_dif,albsol_dir)
     274!albedo SB <<<
     275
     276
    263277      REAL, ALLOCATABLE, SAVE:: wo(:, :, :)
    264278      ! column-density of ozone in a layer, in kilo-Dobsons
    … …  
    404418      ALLOCATE(falb1(klon,nbsrf))
    405419      ALLOCATE(falb2(klon,nbsrf))
     420!albedo SB >>>
     421      ALLOCATE(falb_dir(klon,nsw,nbsrf),falb_dif(klon,nsw,nbsrf))
     422      ALLOCATE(chl_con(klon))
     423!albedo SB <<<
    406424      ALLOCATE(rain_fall(klon))
    407425      ALLOCATE(snow_fall(klon))
    … …  
    501519      ALLOCATE(paire_ter(klon))
    502520      ALLOCATE(albsol1(klon), albsol2(klon))
     521!albedo SB >>>
     522      ALLOCATE(albsol_dir(klon,nsw),albsol_dif(klon,nsw))
     523!albedo SB <<<
    503524
    504525      if (read_climoz <= 1) then
    … …  
    634655      deallocate(paire_ter)
    635656      deallocate(albsol1, albsol2)
     657!albedo SB >>>
     658      deallocate(albsol_dir,albsol_dif,falb_dir,falb_dif,chl_con)
     659!albedo SB <<<
    636660      deallocate(wo)
    637661      deallocate(clwcon0,rnebcon0)

  • LMDZ5/branches/testing/libf/phylmd/physiq.F90

    r2220 r2258  
    44SUBROUTINE physiq (nlon,nlev, &
    55     debut,lafin,jD_cur, jH_cur,pdtphys, &
    6      paprs,pplay,pphi,pphis,presnivs,clesphy0, &
     6     paprs,pplay,pphi,pphis,presnivs, &
    77     u,v,t,qx, &
    88     flxmass_w, &
    … …  
    283283  !$OMP THREADPRIVATE(ok_hf)
    284284
    285   INTEGER        longcles
    286   PARAMETER    ( longcles = 20 )
    287   REAL clesphy0( longcles      )
     285  INTEGER,PARAMETER :: longcles=20
     286  REAL,SAVE :: clesphy0(longcles)
     287  !$OMP THREADPRIVATE(clesphy0)
    288288  !
    289289  ! Variables propres a la physique
    … …  
    291291  SAVE itap                   ! compteur pour la physique
    292292  !$OMP THREADPRIVATE(itap)
     293
     294  INTEGER, SAVE :: abortphy=0   ! Reprere si on doit arreter en fin de phys
     295  !$OMP THREADPRIVATE(abortphy)
    293296  !
    294297  REAL,save ::  solarlong0
    … …  
    636639  !$OMP THREADPRIVATE(fact_cldcon,facttemps)
    637640
    638   integer iflag_cldth
    639   save iflag_cldth
    640   !$OMP THREADPRIVATE(iflag_cldth)
     641  integer iflag_cld_th
     642  save iflag_cld_th
     643  !$OMP THREADPRIVATE(iflag_cld_th)
    641644  logical ptconv(klon,klev)
    642645  !IM cf. AM 081204 BEG
    … …  
    865868
    866869  REAL zzz
     870!albedo SB >>>
     871  real,dimension(6),save :: SFRWL
     872!albedo SB <<<
    867873
    868874  !======================================================================
    … …  
    913919          solarlong0,seuil_inversion, &
    914920          fact_cldcon, facttemps,ok_newmicro,iflag_radia, &
    915           iflag_cldth,iflag_ratqs,ratqsbas,ratqshaut,tau_ratqs, &
     921          iflag_cld_th,iflag_ratqs,ratqsbas,ratqshaut,tau_ratqs, &
    916922          ok_ade, ok_aie, ok_cdnc, aerosol_couple,  &
    917923          flag_aerosol, flag_aerosol_strat, new_aod, &
    … …  
    924930     print*, '================================================='
    925931     !
     932!CR: check sur le nb de traceurs de l eau
     933     if ((iflag_ice_thermo.gt.0).and.(nqo==2)) then
     934          WRITE (lunout, *) ' iflag_ice_thermo==1 requires 3 H2O tracers (H2Ov, H2Ol, H2Oi)', ' but nqo=', nqo, &
     935          '. Might as well stop here.'
     936          STOP
     937     endif
     938
    926939     dnwd0=0.0
    927940     ftd=0.0
    … …  
    10141027     print*,'CYCLE_DIURNE', cycle_diurne
    10151028     !
    1016      IF (iflag_con.EQ.2.AND.iflag_cldth.GT.-1) THEN
    1017         abort_message = 'Tiedtke needs iflag_cldth=-2 or -1'
     1029     IF (iflag_con.EQ.2.AND.iflag_cld_th.GT.-1) THEN
     1030        abort_message = 'Tiedtke needs iflag_cld_th=-2 or -1'
    10181031        CALL abort_gcm (modname,abort_message,1)
    10191032     ENDIF
    … …  
    11301143                ,alp_bl_prescr, ale_bl_prescr)
    11311144           ! 11/09/06 rajout initialisation ALE et ALP du wake et PBL(YU)
    1132            !        print*,'apres ini_wake iflag_cldth=', iflag_cldth
     1145           !        print*,'apres ini_wake iflag_cld_th=', iflag_cld_th
    11331146        endif
    11341147
    … …  
    13421355     mskocean_beta=.FALSE.
    13431356
     1357!albedo SB >>>
     1358     select case(nsw)
     1359     case(2)
     1360     SFRWL(1)=0.45538747
     1361     SFRWL(2)=0.54461211
     1362     case(4)
     1363     SFRWL(1)=0.45538747
     1364     SFRWL(2)=0.32870591
     1365     SFRWL(3)=0.18568763
     1366     SFRWL(4)=3.02191470E-02
     1367     case(6)
     1368     SFRWL(1)=1.28432794E-03
     1369     SFRWL(2)=0.12304168
     1370     SFRWL(3)=0.33106142
     1371     SFRWL(4)=0.32870591
     1372     SFRWL(5)=0.18568763
     1373     SFRWL(6)=3.02191470E-02
     1374     end select
     1375
     1376
     1377!albedo SB <<<
     1378
    13441379     OPEN(99,file='beta_crf.data',status='old', &
    13451380          form='formatted',err=9999)
    … …  
    13781413  !
    13791414  CALL change_srf_frac(itap, dtime, days_elapsed+1,  &
    1380        pctsrf, falb1, falb2, ftsol, ustar, u10m, v10m, pbl_tke)
    1381 
     1415!albedo SB >>>
     1416!       pctsrf, falb1, falb2, ftsol, ustar, u10m, v10m, pbl_tke)
     1417       pctsrf, falb_dir, falb_dif, ftsol, ustar, u10m, v10m, pbl_tke)
     1418!albedo SB <<<
    13821419
    13831420  ! Update time and other variables in Reprobus
    … …  
    15691606  !IM END
    15701607  !
    1571   CALL hgardfou(t_seri,ftsol,'debutphy')
     1608  CALL hgardfou(t_seri,ftsol,'debutphy',abortphy)
     1609  IF (abortphy==1) Print*,'ERROR ABORT hgardfou debutphy'
     1610
    15721611  !
    15731612  !IM BEG
    … …  
    18131852!>nrlmd+jyg
    18141853          pplay,     paprs,     pctsrf,             &
    1815           ftsol,falb1,falb2,ustar,u10m,v10m,wstar,  &
     1854!albedo SB >>>
     1855!          ftsol,falb1,falb2,ustar,u10m,v10m,wstar,  &
     1856          ftsol,SFRWL,falb_dir,falb_dif,ustar,u10m,v10m,wstar, &
     1857!albedo SB <<<
    18161858          cdragh,    cdragm,  u1,    v1,            &
    1817           albsol1,   albsol2,   sens,    evap,      &
     1859!albedo SB >>>
     1860!          albsol1,   albsol2,   sens,    evap,      &
     1861          albsol_dir,   albsol_dif,   sens,    evap,   & 
     1862!albedo SB <<<
    18181863          albsol3_lic,runoff,   snowhgt,   qsnow, to_ice, sissnow, &
    18191864          zxtsol,    zxfluxlat, zt2m,    qsat2m,  &
    … …  
    18681913     IF (klon_glo==1) THEN
    18691914        CALL add_pbl_tend &
    1870              (d_u_vdf,d_v_vdf,d_t_vdf+d_t_diss,d_q_vdf,dql0,dqi0,paprs,'vdf')
     1915        (d_u_vdf,d_v_vdf,d_t_vdf+d_t_diss,d_q_vdf,dql0,dqi0,paprs,'vdf',abortphy)
    18711916     ELSE
    18721917        CALL add_phys_tend &
    1873              (d_u_vdf,d_v_vdf,d_t_vdf+d_t_diss,d_q_vdf,dql0,dqi0,paprs,'vdf')
     1918        (d_u_vdf,d_v_vdf,d_t_vdf+d_t_diss,d_q_vdf,dql0,dqi0,paprs,'vdf',abortphy)
    18741919     ENDIF
    18751920     !--------------------------------------------------------------------
    … …  
    18811926        call writefield_phy('q_seri',q_seri,llm)
    18821927     endif
     1928
     1929
     1930!albedo SB >>>
     1931 albsol1=0.
     1932 albsol2=0.
     1933 falb1=0.
     1934 falb2=0.
     1935select case(nsw)
     1936case(2)
     1937 albsol1=albsol_dir(:,1)
     1938 albsol2=albsol_dir(:,2)
     1939 falb1=falb_dir(:,1,:)
     1940 falb2=falb_dir(:,2,:)
     1941case(4)
     1942 albsol1=albsol_dir(:,1)
     1943 albsol2=albsol_dir(:,2)*SFRWL(2)+albsol_dir(:,3)*SFRWL(3)+albsol_dir(:,4)*SFRWL(4)
     1944 albsol2=albsol2/(SFRWL(2)+SFRWL(3)+SFRWL(4))
     1945 falb1=falb_dir(:,1,:)
     1946 falb2=falb_dir(:,2,:)*SFRWL(2)+falb_dir(:,3,:)*SFRWL(3)+falb_dir(:,4,:)*SFRWL(4)
     1947 falb2=falb2/(SFRWL(2)+SFRWL(3)+SFRWL(4))
     1948case(6)
     1949 albsol1=albsol_dir(:,1)*SFRWL(1)+albsol_dir(:,2)*SFRWL(2)+albsol_dir(:,3)*SFRWL(3)
     1950 albsol1=albsol1/(SFRWL(1)+SFRWL(2)+SFRWL(3))
     1951 albsol2=albsol_dir(:,4)*SFRWL(4)+albsol_dir(:,5)*SFRWL(5)+albsol_dir(:,6)*SFRWL(6)
     1952 albsol2=albsol2/(SFRWL(4)+SFRWL(5)+SFRWL(6))
     1953 falb1=falb_dir(:,1,:)*SFRWL(1)+falb_dir(:,2,:)*SFRWL(2)+falb_dir(:,3,:)*SFRWL(3)
     1954 falb1=falb1/(SFRWL(1)+SFRWL(2)+SFRWL(3))
     1955 falb2=falb_dir(:,4,:)*SFRWL(4)+falb_dir(:,5,:)*SFRWL(5)+falb_dir(:,6,:)*SFRWL(6)
     1956 falb2=falb2/(SFRWL(4)+SFRWL(5)+SFRWL(6))
     1957end select
     1958!albedo SB <<<
     1959
    18831960
    18841961     CALL evappot(klon,nbsrf,ftsol,pplay(:,1),cdragh, &
    … …  
    22212298     !   calcul des proprietes des nuages convectifs
    22222299     clwcon0(:,:)=fact_cldcon*clwcon0(:,:)
    2223      IF (iflag_cld_cv <= 1) THEN
     2300     IF (iflag_cld_cv == 0) THEN
    22242301     call clouds_gno &
    22252302          (klon,klev,q_seri,zqsat,clwcon0,ptconv,ratqsc,rnebcon0)
    … …  
    22732350
    22742351  CALL add_phys_tend(d_u_con, d_v_con, d_t_con, d_q_con, dql0, dqi0, paprs, &
    2275        'convection')
     2352       'convection',abortphy)
     2353
    22762354  !----------------------------------------------------------------------------
    22772355
    … …  
    24422520     d_t_wake(:,:)=dt_wake(:,:)*dtime
    24432521     d_q_wake(:,:)=dq_wake(:,:)*dtime
    2444      CALL add_phys_tend(du0,dv0,d_t_wake,d_q_wake,dql0,dqi0,paprs,'wake')
     2522     CALL add_phys_tend(du0,dv0,d_t_wake,d_q_wake,dql0,dqi0,paprs,'wake',abortphy)
    24452523     !------------------------------------------------------------------------
    24462524
    … …  
    24612539  END IF
    24622540
    2463   !      print*,'apres callwake iflag_cldth=', iflag_cldth
     2541  !      print*,'apres callwake iflag_cld_th=', iflag_cld_th
    24642542  !
    24652543  !===================================================================
    … …  
    27532831        !-----------------------------------------------------------------------
    27542832        ! ajout des tendances de l'ajustement sec ou des thermiques
    2755         CALL add_phys_tend(du0,dv0,d_t_ajsb,d_q_ajsb,dql0,dqi0,paprs,'ajsb')
     2833        CALL add_phys_tend(du0,dv0,d_t_ajsb,d_q_ajsb,dql0,dqi0,paprs,'ajsb',abortphy)
    27562834        d_t_ajs(:,:)=d_t_ajs(:,:)+d_t_ajsb(:,:)
    27572835        d_q_ajs(:,:)=d_q_ajs(:,:)+d_q_ajsb(:,:)
    … …  
    27822860  ! water distribution
    27832861  CALL  calcratqs(klon,klev,prt_level,lunout,        &
    2784        iflag_ratqs,iflag_con,iflag_cldth,pdtphys,  &
     2862       iflag_ratqs,iflag_con,iflag_cld_th,pdtphys,  &
    27852863       ratqsbas,ratqshaut,tau_ratqs,fact_cldcon,   &
    27862864       ptconv,ptconvth,clwcon0th, rnebcon0th,     &
    … …  
    28042882       frac_impa, frac_nucl, beta_prec_fisrt, &
    28052883       prfl, psfl, rhcl,  &
    2806        zqasc, fraca,ztv,zpspsk,ztla,zthl,iflag_cldth, &
     2884       zqasc, fraca,ztv,zpspsk,ztla,zthl,iflag_cld_th, &
    28072885       iflag_ice_thermo)
    28082886  !
    … …  
    28102888  WHERE (snow_lsc < 0) snow_lsc = 0.
    28112889
    2812   CALL add_phys_tend(du0,dv0,d_t_lsc,d_q_lsc,d_ql_lsc,d_qi_lsc,paprs,'lsc')
     2890  CALL add_phys_tend(du0,dv0,d_t_lsc,d_q_lsc,d_ql_lsc,d_qi_lsc,paprs,'lsc',abortphy)
    28132891  !---------------------------------------------------------------------------
    28142892  DO k = 1, klev
    … …  
    28602938  !
    28612939  !IM cf FH
    2862   !     IF (iflag_cldth.eq.-1) THEN ! seulement pour Tiedtke
    2863   IF (iflag_cldth.le.-1) THEN ! seulement pour Tiedtke
     2940  !     IF (iflag_cld_th.eq.-1) THEN ! seulement pour Tiedtke
     2941  IF (iflag_cld_th.le.-1) THEN ! seulement pour Tiedtke
    28642942     snow_tiedtke=0.
    28652943     !     print*,'avant calcul de la pseudo precip '
    2866      !     print*,'iflag_cldth',iflag_cldth
    2867      if (iflag_cldth.eq.-1) then
     2944     !     print*,'iflag_cld_th',iflag_cld_th
     2945     if (iflag_cld_th.eq.-1) then
    28682946        rain_tiedtke=rain_con
    28692947     else
    … …  
    28982976     ENDDO
    28992977
    2900   ELSE IF (iflag_cldth.ge.3) THEN
     2978  ELSE IF (iflag_cld_th.ge.3) THEN
    29012979     !  On prend pour les nuages convectifs le max du calcul de la
    29022980     !  convection et du calcul du pas de temps precedent diminue d'un facteur
    … …  
    29543032        tausum_aero(:,:,:) = 0.
    29553033        IF (iflag_rrtm .EQ. 0) THEN !--old radiation
    2956            tau_aero(:,:,:,:) = 0.
    2957            piz_aero(:,:,:,:) = 0.
     3034           tau_aero(:,:,:,:) = 1.e-15
     3035           piz_aero(:,:,:,:) = 1.
    29583036           cg_aero(:,:,:,:)  = 0.
    29593037        ELSE
    2960            tau_aero_sw_rrtm(:,:,:,:)=0.0
    2961            piz_aero_sw_rrtm(:,:,:,:)=0.0
    2962            cg_aero_sw_rrtm(:,:,:,:)=0.0
     3038           tau_aero_sw_rrtm(:,:,:,:) = 1.e-15
     3039           tau_aero_lw_rrtm(:,:,:,:) = 1.e-15
     3040           piz_aero_sw_rrtm(:,:,:,:) = 1.0
     3041           cg_aero_sw_rrtm(:,:,:,:)  = 0.0
    29633042        ENDIF
    29643043     ENDIF
    … …  
    29873066     !   On prend la somme des fractions nuageuses et des contenus en eau
    29883067
    2989      if (iflag_cldth>=5) then
     3068     if (iflag_cld_th>=5) then
    29903069
    29913070        do k=1,klev
    … …  
    32933372  IF (MOD(itaprad,radpas).EQ.0) THEN
    32943373
    3295      DO i = 1, klon
    3296         albsol1(i) = falb1(i,is_oce) * pctsrf(i,is_oce) &
    3297              + falb1(i,is_lic) * pctsrf(i,is_lic) &
    3298              + falb1(i,is_ter) * pctsrf(i,is_ter) &
    3299              + falb1(i,is_sic) * pctsrf(i,is_sic)
    3300         albsol2(i) = falb2(i,is_oce) * pctsrf(i,is_oce) &
    3301              + falb2(i,is_lic) * pctsrf(i,is_lic) &
    3302              + falb2(i,is_ter) * pctsrf(i,is_ter) &
    3303              + falb2(i,is_sic) * pctsrf(i,is_sic)
    3304      ENDDO
     3374!albedo SB >>> 
     3375  if(ok_chlorophyll)then
     3376  print*,"-- reading chlorophyll"
     3377  call readchlorophyll(debut)
     3378  endif
     3379  !do i=1,klon
     3380  !if(chl_con(i)>1.) print*,i,chl_con(i),pctsrf(i,is_ter)
     3381  !enddo
     3382!albedo SB <<<
     3383
     3384!albedo SB >>>
     3385!     DO i = 1, klon
     3386!        albsol1(i) = falb1(i,is_oce) * pctsrf(i,is_oce) &
     3387!             + falb1(i,is_lic) * pctsrf(i,is_lic) &
     3388!             + falb1(i,is_ter) * pctsrf(i,is_ter) &
     3389!             + falb1(i,is_sic) * pctsrf(i,is_sic)
     3390!        albsol2(i) = falb2(i,is_oce) * pctsrf(i,is_oce) &
     3391!             + falb2(i,is_lic) * pctsrf(i,is_lic) &
     3392!             + falb2(i,is_ter) * pctsrf(i,is_ter) &
     3393!             + falb2(i,is_sic) * pctsrf(i,is_sic)
     3394!     ENDDO
     3395!albedo SB <<<
    33053396
    33063397     if (mydebug) then
    … …  
    33503441        CALL radlwsw &
    33513442             (dist, rmu0, fract,  &
    3352              paprs, pplay,zxtsol,albsol1, albsol2,  &
     3443!albedo SB >>>
     3444!             paprs, pplay,zxtsol,albsol1, albsol2,  &
     3445             paprs, pplay,zxtsol,SFRWL,albsol_dir, albsol_dif,  &
     3446!albedo SB <<<
    33533447             t_seri,q_seri,wo, &
    33543448             cldfrarad, cldemirad, cldtaurad, &
    … …  
    34033497              CALL radlwsw &
    34043498                   (dist, rmu0, fract,  &
    3405                    paprs, pplay,zxtsol,albsol1, albsol2,  &
     3499!albedo SB >>>
     3500!                   paprs, pplay,zxtsol,albsol1, albsol2,  &
     3501                   paprs, pplay,zxtsol,SFRWL,albsol_dir, albsol_dif, &
     3502!albedo SB <<<
    34063503                   t_seri,q_seri,wo, &
    34073504                   cldfra, cldemi, cldtau, &
    … …  
    34703567  d_t_sw0(:,:)=heat0(:,:)*dtime/RDAY
    34713568  d_t_lw0(:,:)=-cool0(:,:)*dtime/RDAY
    3472   CALL add_phys_tend(du0,dv0,d_t_swr,dq0,dql0,dqi0,paprs,'SW')
    3473   CALL add_phys_tend(du0,dv0,d_t_lwr,dq0,dql0,dqi0,paprs,'LW')
     3569  CALL add_phys_tend(du0,dv0,d_t_swr,dq0,dql0,dqi0,paprs,'SW',abortphy)
     3570  CALL add_phys_tend(du0,dv0,d_t_lwr,dq0,dql0,dqi0,paprs,'LW',abortphy)
    34743571
    34753572  !
    … …  
    35543651     !-----------------------------------------------------------------------------------------
    35553652     ! ajout des tendances de la trainee de l'orographie
    3556      CALL add_phys_tend(d_u_oro,d_v_oro,d_t_oro,dq0,dql0,dqi0,paprs,'oro')
     3653     CALL add_phys_tend(d_u_oro,d_v_oro,d_t_oro,dq0,dql0,dqi0,paprs,'oro',abortphy)
    35573654     !-----------------------------------------------------------------------------------------
    35583655     !
    … …  
    36003697     !-----------------------------------------------------------------------------------------
    36013698     ! ajout des tendances de la portance de l'orographie
    3602      CALL add_phys_tend(d_u_lif,d_v_lif,d_t_lif,dq0,dql0,dqi0,paprs,'lif')
     3699     CALL add_phys_tend(d_u_lif,d_v_lif,d_t_lif,dq0,dql0,dqi0,paprs,'lif',abortphy)
    36033700     !-----------------------------------------------------------------------------------------
    36043701     !
    … …  
    36143711     !
    36153712     !  ajout des tendances
    3616      CALL add_phys_tend(d_u_hin,d_v_hin,d_t_hin,dq0,dql0,dqi0,paprs,'hin')
     3713     CALL add_phys_tend(d_u_hin,d_v_hin,d_t_hin,dq0,dql0,dqi0,paprs,'hin',abortphy)
    36173714
    36183715  ENDIF
    … …  
    36233720          du_gwd_rando, dv_gwd_rando)
    36243721     CALL add_phys_tend(du_gwd_rando, dv_gwd_rando, dt0, dq0, dql0,dqi0,paprs, &
    3625           'flott_gwd_rando')
     3722          'flott_gwd_rando',abortphy)
    36263723  end if
    36273724
    … …  
    36773774     CALL METHOX(1,klon,klon,klev,q_seri,d_q_ch4,pplay)
    36783775  ! ajout de la tendance d'humidite due au methane
    3679      CALL add_phys_tend(du0,dv0,dt0,d_q_ch4*dtime,dql0,'q_ch4')
     3776     CALL add_phys_tend(du0,dv0,dt0,d_q_ch4*dtime,dql0,'q_ch4',abortphy)
    36803777  END IF
    36813778  !
    … …  
    40584155  !On effectue les sorties:
    40594156
    4060   CALL phys_output_write(itap, pdtphys, paprs, pphis,               &
     4157  CALL phys_output_write(itap, pdtphys, paprs, pphis,  &
    40614158       pplay, lmax_th, aerosol_couple,                 &
    40624159       ok_ade, ok_aie, ivap, new_aod, ok_sync,         &
    … …  
    40674164
    40684165
    4069 
    40704166  include "write_histday_seri.h"
    40714167
    … …  
    40734169
    40744170#endif
     4171
     4172
     4173!====================================================================
     4174! Arret du modele apres hgardfou en cas de detection d'un
     4175! plantage par hgardfou
     4176!====================================================================
     4177
     4178    IF (abortphy==1) THEN
     4179       abort_message ='Plantage hgardfou'
     4180       CALL abort_gcm (modname,abort_message,1)
     4181    ENDIF
     4182
    40754183
    40764184  ! 22.03.04 END

  • LMDZ5/branches/testing/libf/phylmd/radlwsw_m.F90

    r2220 r2258  
    1010SUBROUTINE radlwsw( &
    1111   dist, rmu0, fract, &
    12    paprs, pplay,tsol,alb1, alb2, &
     12!albedo SB >>>
     13!  paprs, pplay,tsol,alb1, alb2, &
     14   paprs, pplay,tsol,SFRWL,alb_dir, alb_dif, &
     15!albedo SB <<<
    1316   t,q,wo,&
    1417   cldfra, cldemi, cldtaupd,&
    … …  
    174177  REAL,    INTENT(in)  :: rmu0(KLON), fract(KLON)
    175178  REAL,    INTENT(in)  :: paprs(KLON,KLEV+1), pplay(KLON,KLEV)
    176   REAL,    INTENT(in)  :: alb1(KLON), alb2(KLON), tsol(KLON)
     179!albedo SB >>>
     180! REAL,    INTENT(in)  :: alb1(KLON), alb2(KLON), tsol(KLON)
     181  REAL,    INTENT(in)  :: tsol(KLON)
     182  REAL,    INTENT(in) :: alb_dir(KLON,NSW),alb_dif(KLON,NSW)
     183  real, intent(in) :: SFRWL(6)
     184!albedo SB <<<
    177185  REAL,    INTENT(in)  :: t(KLON,KLEV), q(KLON,KLEV)
    178186
    … …  
    418426!     zfract(i) = 1.     !!!!!!  essai MPL 19052010
    419427      zrmu0(i) = rmu0(iof+i)
    420       PALBD(i,1) = alb1(iof+i)
    421       PALBD(i,2) = alb2(iof+i)
    422 !
    423          PALBD_NEW(i,1) = alb1(iof+i)   !!!!! A REVOIR (MPL) PALBD_NEW en fonction bdes SW
    424          do kk=2,NSW
    425            PALBD_NEW(i,kk) = alb2(iof+i)
    426          enddo
    427       PALBP(i,1) = alb1(iof+i)
    428       PALBP(i,2) = alb2(iof+i)
    429 !
    430          PALBP_NEW(i,1) = alb1(iof+i)     !!!!! A REVOIR (MPL) PALBP_NEW en fonction bdes SW
    431          do kk=2,NSW
    432            PALBP_NEW(i,kk) = alb2(iof+i)
    433          enddo
     428
     429
     430!albedo SB >>>
     431!      PALBD(i,1) = alb1(iof+i)
     432!      PALBD(i,2) = alb2(iof+i)
     433!         PALBD_NEW(i,1) = alb1(iof+i)   !!!!! A REVOIR (MPL) PALBD_NEW en
     434!         fonction bdes SW
     435!         do kk=2,NSW
     436!           PALBD_NEW(i,kk) = alb2(iof+i)
     437!         enddo
     438!      PALBP(i,1) = alb1(iof+i)
     439!      PALBP(i,2) = alb2(iof+i)
     440!
     441!         PALBP_NEW(i,1) = alb1(iof+i)     !!!!! A REVOIR (MPL) PALBP_NEW en
     442!         fonction bdes SW
     443!         do kk=2,NSW
     444!           PALBP_NEW(i,kk) = alb2(iof+i)
     445!         enddo
     446
     447      if(iflag_rrtm==0)then
     448        select case(nsw)
     449        case(2)
     450          PALBD(i,1)=alb_dif(iof+i,1)
     451          PALBD(i,2)=alb_dif(iof+i,2)
     452          PALBP(i,1)=alb_dir(iof+i,1)
     453          PALBP(i,2)=alb_dir(iof+i,2)
     454        case(4)
     455          PALBD(i,1)=alb_dif(iof+i,1)
     456          PALBD(i,2)=(alb_dif(iof+i,2)*SFRWL(2)+alb_dif(iof+i,3)*SFRWL(3) &
     457                 +alb_dif(iof+i,4)*SFRWL(4))/(SFRWL(2)+SFRWL(3)+SFRWL(4))
     458          PALBP(i,1)=alb_dir(iof+i,1)
     459          PALBP(i,2)=(alb_dir(iof+i,2)*SFRWL(2)+alb_dir(iof+i,3)*SFRWL(3) &
     460                 +alb_dir(iof+i,4)*SFRWL(4))/(SFRWL(2)+SFRWL(3)+SFRWL(4))
     461        case(6)
     462          PALBD(i,1)=(alb_dif(iof+i,1)*SFRWL(1)+alb_dif(iof+i,2)*SFRWL(2) &
     463                 +alb_dif(iof+i,3)*SFRWL(3))/(SFRWL(1)+SFRWL(2)+SFRWL(3))
     464          PALBD(i,2)=(alb_dif(iof+i,4)*SFRWL(4)+alb_dif(iof+i,5)*SFRWL(5) &
     465                 +alb_dif(iof+i,6)*SFRWL(6))/(SFRWL(4)+SFRWL(5)+SFRWL(6))
     466          PALBP(i,1)=(alb_dir(iof+i,1)*SFRWL(1)+alb_dir(iof+i,2)*SFRWL(2)  &
     467                 +alb_dir(iof+i,3)*SFRWL(3))/(SFRWL(1)+SFRWL(2)+SFRWL(3))
     468          PALBP(i,2)=(alb_dir(iof+i,4)*SFRWL(4)+alb_dir(iof+i,5)*SFRWL(5)  &
     469                 +alb_dir(iof+i,6)*SFRWL(6))/(SFRWL(4)+SFRWL(5)+SFRWL(6))
     470        end select
     471      elseif(iflag_rrtm==1)then
     472        DO kk=1,NSW
     473         PALBD_NEW(i,kk)=alb_dif(iof+i,kk)
     474         PALBP_NEW(i,kk)=alb_dir(iof+i,kk)
     475        ENDDO
     476      endif
     477!albedo SB <<<
     478
     479
     480
     481
    434482      PEMIS(i) = 1.0    !!!!! A REVOIR (MPL)
    435483      PVIEW(i) = 1.66

  • LMDZ5/branches/testing/libf/phylmd/rrtm/aeropt_6bands_rrtm.F90

    r2211 r2258  
    473473                               tau_ae(i,k,id_ASSSM_phy,inu)+tau_ae(i,k,id_CSSSM_phy,inu)+   &
    474474                               tau_ae(i,k,id_SSSSM_phy,inu)+ tau_ae(i,k,id_CIDUSTM_phy,inu)
    475          tau_allaer(i,k,2,inu)=MAX(tau_allaer(i,k,2,inu),1e-5)
     475         tau_allaer(i,k,2,inu)=MAX(tau_allaer(i,k,2,inu),1e-15)
    476476
    477477         piz_allaer(i,k,2,inu)=(tau_ae(i,k,id_ASSO4M_phy,inu)*piz_ae(i,k,id_ASSO4M_phy,inu)+ &
    … …  
    486486                                tau_ae(i,k,id_CIDUSTM_phy,inu)*piz_ae(i,k,id_CIDUSTM_phy,inu)) &
    487487                                /tau_allaer(i,k,2,inu)
    488          piz_allaer(i,k,2,inu)=MAX(piz_allaer(i,k,2,inu),0.1)
     488         piz_allaer(i,k,2,inu)=MAX(piz_allaer(i,k,2,inu),0.01)
    489489
    490490         cg_allaer(i,k,2,inu)=(tau_ae(i,k,id_ASSO4M_phy,inu)*piz_ae(i,k,id_ASSO4M_phy,inu)*cg_ae(i,k,id_ASSO4M_phy,inu)+ &
    … …  
    506506                               tau_ae_pi(i,k,id_ASSSM_phy,inu)+tau_ae_pi(i,k,id_CSSSM_phy,inu)+   &
    507507                               tau_ae_pi(i,k,id_SSSSM_phy,inu)+ tau_ae_pi(i,k,id_CIDUSTM_phy,inu)
    508          tau_allaer(i,k,1,inu)=MAX(tau_allaer(i,k,1,inu),1e-5)
     508         tau_allaer(i,k,1,inu)=MAX(tau_allaer(i,k,1,inu),1e-15)
    509509
    510510         piz_allaer(i,k,1,inu)=(tau_ae_pi(i,k,id_ASSO4M_phy,inu)*piz_ae(i,k,id_ASSO4M_phy,inu)+ &
    … …  
    519519                                tau_ae_pi(i,k,id_CIDUSTM_phy,inu)*piz_ae(i,k,id_CIDUSTM_phy,inu)) &
    520520                                /tau_allaer(i,k,1,inu)
    521          piz_allaer(i,k,1,inu)=MAX(piz_allaer(i,k,1,inu),0.1)
     521         piz_allaer(i,k,1,inu)=MAX(piz_allaer(i,k,1,inu),0.01)
    522522
    523523         cg_allaer(i,k,1,inu)=(tau_ae_pi(i,k,id_ASSO4M_phy,inu)*piz_ae(i,k,id_ASSO4M_phy,inu)*cg_ae(i,k,id_ASSO4M_phy,inu)+ &

  • LMDZ5/branches/testing/libf/phylmd/rrtm/aeropt_lw_rrtm.F90

    r2220 r2258  
    99  IMPLICIT NONE
    1010
    11   tau_aero_lw_rrtm(:,:,:,:)=0.0
     11  tau_aero_lw_rrtm(:,:,:,:) = 1.e-15
    1212
    1313END SUBROUTINE AEROPT_LW_RRTM

  • LMDZ5/branches/testing/libf/phylmd/rrtm/readaerosolstrato_rrtm.F90

    r2187 r2258  
    211211    ENDDO
    212212
     213!--default SSA value if there is no aerosol
     214!--to avoid 0 values that seems to cause some problem to RRTM
     215    WHERE (tau_aero_sw_rrtm.LT.1.e-14)
     216      piz_aero_sw_rrtm = 1.0
     217    ENDWHERE
     218
     219!--in principle this should not be necessary
     220!--as these variables have min values already but just in case
     221!--put 1e-15 min value to both SW and LW AOD
     222    tau_aero_sw_rrtm = MAX(tau_aero_sw_rrtm,1.e-15)
     223    tau_aero_lw_rrtm = MAX(tau_aero_lw_rrtm,1.e-15)
     224
    213225end subroutine readaerosolstrato_rrtm

  • LMDZ5/branches/testing/libf/phylmd/screenc.F90

    r1910 r2258  
    6666! Richardson at reference level
    6767!
    68       CALL coefcdrag (klon, knon, nsrf, zxli, &
     68!      CALL coefcdrag (klon, knon, nsrf, zxli, &
     69!                    speed, temp, q_zref, gref, &
     70!                    psol, ts, qsurf, rugos, &
     71!                    okri, ri1, &
     72!                    cdram, cdrah, cdran, zri1, &
     73!                    pref)
     74! Fuxing WANG, 04/03/2015, replace the coefcdrag by the merged version: cdrag
     75      CALL cdrag (knon, nsrf, &
    6976                    speed, temp, q_zref, gref, &
    7077                    psol, ts, qsurf, rugos, &
    71                     okri, ri1, &
    72                     cdram, cdrah, cdran, zri1, &
    73                     pref)
    74 !
     78                    cdram, cdrah, zri1, pref)
    7579      DO i = 1, knon
    7680        delu(i) = ustar(i)/sqrt(cdram(i))

  • LMDZ5/branches/testing/libf/phylmd/stdlevvar.F90

    r2160 r2258  
    9898!
    9999      okri=.FALSE.
    100       CALL coefcdrag(klon, knon, nsrf, zxli, &
    101  &                   speed, t1, q1, z1, psol, &
    102  &                   ts1, qsurf, rugos, okri, ri1,  &         
    103  &                   cdram, cdrah, cdran, zri1, pref)           
     100!      CALL coefcdrag(klon, knon, nsrf, zxli, &
     101! &                   speed, t1, q1, z1, psol, &
     102! &                   ts1, qsurf, rugos, okri, ri1,  &         
     103! &                   cdram, cdrah, cdran, zri1, pref)           
     104! Fuxing WANG, 04/03/2015, replace the coefcdrag by the merged version: cdrag
     105      CALL cdrag(knon, nsrf, &
     106 &                   speed, t1, q1, z1, &
     107 &                   psol, ts1, qsurf, rugos, &
     108 &                   cdram, cdrah, zri1, pref)
     109
    104110! --- special Dice: on force cdragm ( a defaut de forcer ustar) MPL 05082013
    105111     IF (ok_prescr_ust) then

  • LMDZ5/branches/testing/libf/phylmd/surf_land_mod.F90

    r2220 r2258  
    1717       lwdown_m, q2m, t2m, &
    1818       snow, qsol, agesno, tsoil, &
    19        z0_new, alb1_new, alb2_new, evap, fluxsens, fluxlat, &
     19!albedo SB >>>
     20!      z0_new, alb1_new, alb2_new, evap, fluxsens, fluxlat, &
     21       z0_new, SFRWL, alb_dir_new, alb_dif_new, evap, fluxsens, fluxlat, &   
     22!albedo SB <<<
    2023       qsurf, tsurf_new, dflux_s, dflux_l, &
    2124       flux_u1, flux_v1 )
    … …  
    3538    INCLUDE "dimsoil.h"
    3639    INCLUDE "YOMCST.h"
     40!albedo SB >>>
     41    INCLUDE "clesphys.h"
     42!albedo SB <<<
    3743
    3844! Input variables 
    … …  
    7177!****************************************************************************************
    7278    REAL, DIMENSION(klon), INTENT(OUT)       :: z0_new
    73     REAL, DIMENSION(klon), INTENT(OUT)       :: alb1_new ! albdeo for shortwave interval 1(visible)
    74     REAL, DIMENSION(klon), INTENT(OUT)       :: alb2_new ! albedo for shortwave interval 2(near infrared)
     79!albedo SB >>>
     80!    REAL, DIMENSION(klon), INTENT(OUT)       :: alb1_new ! albdeo for shortwave interval 1(visible)
     81!    REAL, DIMENSION(klon), INTENT(OUT)       :: alb2_new ! albedo for shortwave interval 2(near infrared)
     82    REAL, DIMENSION(6), INTENT(IN) :: SFRWL
     83    REAL, DIMENSION(klon,nsw), INTENT(OUT)       :: alb_dir_new,alb_dif_new
     84!albedo SB <<<
    7585    REAL, DIMENSION(klon), INTENT(OUT)       :: evap
    7686    REAL, DIMENSION(klon), INTENT(OUT)       :: fluxsens, fluxlat
    … …  
    8999    REAL, DIMENSION(klon) :: u0, v0     ! surface speed
    90100    INTEGER               :: i
     101
     102!albedo SB >>>
     103    REAL, DIMENSION(klon)      :: alb1_new,alb2_new
     104!albedo SB <<<
    91105
    92106
    … …  
    165179         p1lay, temp_air, &
    166180         flux_u1, flux_v1)
     181
     182!albedo SB >>>
     183
     184
     185     select case(NSW)
     186     case(2)
     187       alb_dir_new(1:knon,1)=alb1_new(1:knon)
     188       alb_dir_new(1:knon,2)=alb2_new(1:knon)
     189     case(4)
     190       alb_dir_new(1:knon,1)=alb1_new(1:knon)
     191       alb_dir_new(1:knon,2)=alb2_new(1:knon)
     192       alb_dir_new(1:knon,3)=alb2_new(1:knon)
     193       alb_dir_new(1:knon,4)=alb2_new(1:knon)
     194     case(6)
     195       alb_dir_new(1:knon,1)=alb1_new(1:knon)
     196       alb_dir_new(1:knon,2)=alb1_new(1:knon)
     197       alb_dir_new(1:knon,3)=alb1_new(1:knon)
     198       alb_dir_new(1:knon,4)=alb2_new(1:knon)
     199       alb_dir_new(1:knon,5)=alb2_new(1:knon)
     200       alb_dir_new(1:knon,6)=alb2_new(1:knon)
     201     end select
     202alb_dif_new=alb_dir_new
     203!albedo SB <<<
     204
     205
    167206   
    168207  END SUBROUTINE surf_land

  • LMDZ5/branches/testing/libf/phylmd/surf_landice_mod.F90

    r1910 r2258  
    1717       ps, u1, v1, rugoro, pctsrf, &
    1818       snow, qsurf, qsol, agesno, &
    19        tsoil, z0_new, alb1, alb2, evap, fluxsens, fluxlat, &
     19!albedo SB >>>
     20!      tsoil, z0_new, alb1, alb2, evap, fluxsens, fluxlat, &
     21       tsoil, z0_new, SFRWL, alb_dir, alb_dif, evap, fluxsens, fluxlat, &
     22!albedo SB <<<
    2023       tsurf_new, dflux_s, dflux_l, &
    2124       slope, cloudf, &
    … …  
    8083    REAL, DIMENSION(klon), INTENT(OUT)            :: qsurf
    8184    REAL, DIMENSION(klon), INTENT(OUT)            :: z0_new
    82     REAL, DIMENSION(klon), INTENT(OUT)            :: alb1  ! new albedo in visible SW interval
    83     REAL, DIMENSION(klon), INTENT(OUT)            :: alb2  ! new albedo in near IR interval
     85!albedo SB >>>
     86!    REAL, DIMENSION(klon), INTENT(OUT)            :: alb1  ! new albedo in visible SW interval
     87!    REAL, DIMENSION(klon), INTENT(OUT)            :: alb2  ! new albedo in near IR interval
     88    REAL, DIMENSION(6), INTENT(IN)              ::SFRWL
     89    REAL, DIMENSION(klon,nsw), INTENT(OUT)        ::alb_dir,alb_dif
     90!albedo SB <<<
    8491    REAL, DIMENSION(klon), INTENT(OUT)            :: evap, fluxsens, fluxlat
    8592    REAL, DIMENSION(klon), INTENT(OUT)            :: tsurf_new
    … …  
    116123    CHARACTER (len = 20)                      :: modname = 'surf_landice'
    117124    CHARACTER (len = 80)                      :: abort_message
     125
     126!albedo SB >>>
     127    real,dimension(klon) :: alb1,alb2
     128!albedo SB <<<
    118129
    119130! End definition
    … …  
    315326
    316327
     328!albedo SB >>>
     329     select case(NSW)
     330     case(2)
     331       alb_dir(1:knon,1)=alb1(1:knon)
     332       alb_dir(1:knon,2)=alb2(1:knon)
     333     case(4)
     334       alb_dir(1:knon,1)=alb1(1:knon)
     335       alb_dir(1:knon,2)=alb2(1:knon)
     336       alb_dir(1:knon,3)=alb2(1:knon)
     337       alb_dir(1:knon,4)=alb2(1:knon)
     338     case(6)
     339       alb_dir(1:knon,1)=alb1(1:knon)
     340       alb_dir(1:knon,2)=alb1(1:knon)
     341       alb_dir(1:knon,3)=alb1(1:knon)
     342       alb_dir(1:knon,4)=alb2(1:knon)
     343       alb_dir(1:knon,5)=alb2(1:knon)
     344       alb_dir(1:knon,6)=alb2(1:knon)
     345     end select
     346alb_dif=alb_dir
     347!albedo SB <<<
     348
     349
     350
     351
    317352  END SUBROUTINE surf_landice
    318353!

  • LMDZ5/branches/testing/libf/phylmd/surf_ocean_mod.F90

    r2220 r2258  
    1616       ps, u1, v1, rugoro, pctsrf, &
    1717       snow, qsurf, agesno, &
    18        z0_new, alb1_new, alb2_new, evap, fluxsens, fluxlat, &
     18!albedo SB >>>
     19!      z0_new, alb1_new, alb2_new, evap, fluxsens, fluxlat, &
     20       z0_new, SFRWL, alb_dir_new, alb_dif_new, evap, fluxsens, fluxlat, &
     21!albedo SB <<<
    1922       tsurf_new, dflux_s, dflux_l, lmt_bils, &
    2023       flux_u1, flux_v1)
    … …  
    7275!****************************************************************************************
    7376    REAL, DIMENSION(klon), INTENT(OUT)       :: z0_new
    74     REAL, DIMENSION(klon), INTENT(OUT)       :: alb1_new  ! new albedo in visible SW interval
    75     REAL, DIMENSION(klon), INTENT(OUT)       :: alb2_new  ! new albedo in near IR interval
     77!albedo SB >>>
     78!    REAL, DIMENSION(klon), INTENT(OUT)       :: alb1_new  ! new albedo in visible SW interval
     79!    REAL, DIMENSION(klon), INTENT(OUT)       :: alb2_new  ! new albedo in near IR interval
     80    REAL, DIMENSION(6), INTENT(IN)          :: SFRWL
     81    REAL, DIMENSION(klon,nsw), INTENT(OUT)       :: alb_dir_new,alb_dif_new
     82!albedo SB <<<     
    7683    REAL, DIMENSION(klon), INTENT(OUT)       :: evap, fluxsens, fluxlat
    7784    REAL, DIMENSION(klon), INTENT(OUT)       :: tsurf_new
    … …  
    8289! Local variables
    8390!****************************************************************************************
    84     INTEGER               :: i
     91    INTEGER               :: i, k
    8592    REAL                  :: tmp
    8693    REAL, PARAMETER       :: cepdu2=(0.1)**2
    … …  
    155162!
    156163!****************************************************************************************
     164!albedo SB >>>
     165
     166
     167  if(iflag_albedo==1)then
     168    call ocean_albedo(knon,rmu0,knindex,windsp,SFRWL,alb_dir_new,alb_dif_new)
     169  else
    157170    IF (cycle_diurne) THEN
    158171       CALL alboc_cd(rmu0,alb_eau)
    … …  
    162175
    163176    DO i =1, knon
    164        alb1_new(i) = alb_eau(knindex(i))
     177      do  k=1,nsw
     178       alb_dir_new(i,k) = alb_eau(knindex(i))
     179      enddo
    165180    ENDDO
    166     alb2_new(1:knon) = alb1_new(1:knon)
     181     alb_dif_new=0.05 !alb_dir_new
     182endif
     183
     184!albedo SB <<<
    167185
    168186!****************************************************************************************

  • LMDZ5/branches/testing/libf/phylmd/surf_seaice_mod.F90

    r2220 r2258  
     1!
     2! $Id$
    13!
    24MODULE surf_seaice_mod
    … …  
    1719       ps, u1, v1, rugoro, pctsrf, &
    1820       snow, qsurf, qsol, agesno, tsoil, &
    19        z0_new, alb1_new, alb2_new, evap, fluxsens, fluxlat, &
     21!albedo SB >>>
     22!      z0_new, alb1_new, alb2_new, evap, fluxsens, fluxlat, &
     23       z0_new, SFRWL, alb_dir_new, alb_dif_new, evap, fluxsens, fluxlat, & 
     24!albedo SB <<<
    2025       tsurf_new, dflux_s, dflux_l, &
    2126       flux_u1, flux_v1)
    … …  
    3439!
    3540    INCLUDE "dimsoil.h"
     41    INCLUDE "clesphys.h"
    3642
    3743! Input arguments
    … …  
    6773!****************************************************************************************
    6874    REAL, DIMENSION(klon), INTENT(OUT)       :: z0_new
    69     REAL, DIMENSION(klon), INTENT(OUT)       :: alb1_new  ! new albedo in visible SW interval
    70     REAL, DIMENSION(klon), INTENT(OUT)       :: alb2_new  ! new albedo in near IR interval
     75!albedo SB >>>
     76!    REAL, DIMENSION(klon), INTENT(OUT)       :: alb1_new  ! new albedo in visible SW interval
     77!    REAL, DIMENSION(klon), INTENT(OUT)       :: alb2_new  ! new albedo in near IR interval
     78    REAL, DIMENSION(6), INTENT(IN)    :: SFRWL
     79    REAL, DIMENSION(klon,nsw), INTENT(OUT)   :: alb_dir_new,alb_dif_new
     80!albedo SB <<<
    7181    REAL, DIMENSION(klon), INTENT(OUT)       :: evap, fluxsens, fluxlat
    7282    REAL, DIMENSION(klon), INTENT(OUT)       :: tsurf_new
    … …  
    7888    REAL, DIMENSION(klon)  :: radsol
    7989
     90!albedo SB >>>
     91    REAL, DIMENSION(klon) :: alb1_new,alb2_new
     92!albedo SB <<<
    8093!
    8194! End definitions
    … …  
    140153    z0_new = SQRT(z0_new**2+rugoro**2)
    141154
     155
     156!albedo SB >>>
     157     select case(NSW)
     158     case(2)
     159       alb_dir_new(1:knon,1)=alb1_new(1:knon)
     160       alb_dir_new(1:knon,2)=alb2_new(1:knon)
     161     case(4)
     162       alb_dir_new(1:knon,1)=alb1_new(1:knon)
     163       alb_dir_new(1:knon,2)=alb2_new(1:knon)
     164       alb_dir_new(1:knon,3)=alb2_new(1:knon)
     165       alb_dir_new(1:knon,4)=alb2_new(1:knon)
     166     case(6)
     167       alb_dir_new(1:knon,1)=alb1_new(1:knon)
     168       alb_dir_new(1:knon,2)=alb1_new(1:knon)
     169       alb_dir_new(1:knon,3)=alb1_new(1:knon)
     170       alb_dir_new(1:knon,4)=alb2_new(1:knon)
     171       alb_dir_new(1:knon,5)=alb2_new(1:knon)
     172       alb_dir_new(1:knon,6)=alb2_new(1:knon)
     173     end select
     174alb_dif_new=alb_dir_new
     175!albedo SB <<<
     176
     177
     178
     179
    142180  END SUBROUTINE surf_seaice
    143181!
Note: See TracChangeset for help on using the changeset viewer.