Ignore:
Timestamp:
Jul 22, 2024, 9:29:09 PM (4 months ago)
Author:
abarral
Message:

Replace most uses of CPP_DUST by the corresponding logical defined in lmdz_cppkeys_wrapper.F90
Convert several files from .F to .f90 to allow Dust to compile w/o rrtm/ecrad
Create lmdz_yoerad.f90
(lint) Remove "!" on otherwise empty line

File:
1 edited

Legend:

Unmodified
Added
Removed

  • LMDZ6/branches/Amaury_dev/libf/phylmd/pbl_surface_mod.F90

    r5088 r5099  
    1 !
     1
    22! $Id$
    3 !
     3
    44MODULE pbl_surface_mod
    5 !
     5
    66! Planetary Boundary Layer and Surface module
    7 !
     7
    88! This module manages the calculation of turbulent diffusion in the boundary layer
    99! and all interactions towards the differents sub-surfaces.
    10 !
    11 !
     10
     11
    1212  USE dimphy
    1313  USE mod_phys_lmdz_para,  ONLY : mpi_size
    … …  
    7373
    7474CONTAINS
    75 !
    76 !****************************************************************************************
    77 !
     75
     76!****************************************************************************************
     77
    7878  SUBROUTINE pbl_surface_init(fder_rst, snow_rst, qsurf_rst, ftsoil_rst)
    7979
    … …  
    104104!****************************************************************************************
    105105! Allocate and initialize module variables with fields read from restart file.
    106 !
     106
    107107!****************************************************************************************   
    108108    ALLOCATE(fder(klon), stat=ierr)
    … …  
    133133!****************************************************************************************
    134134! Test for sub-surface indices
    135 !
     135
    136136!****************************************************************************************
    137137    IF (is_ter /= 1) THEN
    … …  
    163163!****************************************************************************************
    164164! Validation of ocean mode
    165 !
     165
    166166!****************************************************************************************
    167167
    … …  
    179179!    iflag_frein = 0
    180180!    CALL getin_p('iflag_frein',iflag_frein)
    181 !
     181
    182182!jyg<
    183183!****************************************************************************************
    184184! Allocate variables for pbl splitting
    185 !
     185
    186186!****************************************************************************************
    187187
    … …  
    222222!****************************************************************************************
    223223! Allocate and initialize module variables with fields read from restart file.
    224 !
     224
    225225!****************************************************************************************   
    226226
    … …  
    255255#endif
    256256
    257 ! 
    258 !****************************************************************************************
    259 ! 
     257!****************************************************************************************
    260258
    261259  SUBROUTINE pbl_surface( &
    … …  
    329327! Auteur(s) Z.X. Li (LMD/CNRS) date: 19930818
    330328! Objet: interface de "couche limite" (diffusion verticale)
    331 !
     329
    332330!AA REM:
    333331!AA-----
    … …  
    345343!AA il faudra sortir ces memes champs en leur ajoutant une dimension,
    346344!AA c'est a dire nbsrf (nbre de subsurface).
    347 !
     345
    348346! Arguments:
    349 !
     347
    350348! dtime----input-R- interval du temps (secondes)
    351349! itap-----input-I- numero du pas de temps
    … …  
    367365! cldt-----input-R- total cloud fraction
    368366! Martin
    369 !
     367
    370368! d_t------output-R- le changement pour "t"
    371369! d_q------output-R- le changement pour "q"
    … …  
    392390! pblT-----output-R- T au nveau HCL
    393391! treedrg--output-R- tree drag (m)               
    394 !
     392
    395393    USE carbon_cycle_mod,   ONLY : carbon_cycle_cpl, carbon_cycle_tr, level_coupling_esm
    396394    USE carbon_cycle_mod,   ONLY : co2_send, nbcf_out, fields_out, yfields_out, cfname_out
    … …  
    858856!!!jyg le 08/02/2012
    859857    REAL, DIMENSION(klon, nbsrf)       :: windsp
    860 !
     858
    861859    REAL, DIMENSION(klon, nbsrf)       :: t2m_x
    862860    REAL, DIMENSION(klon, nbsrf)       :: q2m_x
    … …  
    867865    REAL, DIMENSION(klon, nbsrf)       :: ustar_x
    868866    REAL, DIMENSION(klon, nbsrf)       :: wstar_x
    869 !             
     867
    870868    REAL, DIMENSION(klon, nbsrf)       :: pblh_x
    871869    REAL, DIMENSION(klon, nbsrf)       :: plcl_x
    … …  
    878876    REAL, DIMENSION(klon, nbsrf)       :: trmb2_x
    879877    REAL, DIMENSION(klon, nbsrf)       :: trmb3_x
    880 !
     878
    881879    REAL, DIMENSION(klon, nbsrf)       :: t2m_w
    882880    REAL, DIMENSION(klon, nbsrf)       :: q2m_w
    … …  
    887885    REAL, DIMENSION(klon, nbsrf)       :: ustar_w
    888886    REAL, DIMENSION(klon, nbsrf)       :: wstar_w
    889 !                           
     887
    890888    REAL, DIMENSION(klon, nbsrf)       :: pblh_w
    891889    REAL, DIMENSION(klon, nbsrf)       :: plcl_w
    … …  
    898896    REAL, DIMENSION(klon, nbsrf)       :: trmb2_w
    899897    REAL, DIMENSION(klon, nbsrf)       :: trmb3_w
    900 !
     898
    901899    REAL, DIMENSION(klon)       :: yt2m_x
    902900    REAL, DIMENSION(klon)       :: yq2m_x
    … …  
    907905    REAL, DIMENSION(klon)       :: yustar_x
    908906    REAL, DIMENSION(klon)       :: ywstar_x
    909 !             
     907
    910908    REAL, DIMENSION(klon)       :: ypblh_x
    911909    REAL, DIMENSION(klon)       :: ylcl_x
    … …  
    918916    REAL, DIMENSION(klon)       :: ytrmb2_x
    919917    REAL, DIMENSION(klon)       :: ytrmb3_x
    920 !
     918
    921919    REAL, DIMENSION(klon)       :: yt2m_w
    922920    REAL, DIMENSION(klon)       :: yq2m_w
    … …  
    927925    REAL, DIMENSION(klon)       :: yustar_w
    928926    REAL, DIMENSION(klon)       :: ywstar_w
    929 !                       
     927
    930928    REAL, DIMENSION(klon)       :: ypblh_w
    931929    REAL, DIMENSION(klon)       :: ylcl_w
    … …  
    938936    REAL, DIMENSION(klon)       :: ytrmb2_w
    939937    REAL, DIMENSION(klon)       :: ytrmb3_w
    940 !
     938
    941939    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
    942940    REAL, DIMENSION(klon)       :: zgeo1_x, tair1_x, qair1_x, tairsol_x
    943 !
     941
    944942    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
    945943    REAL, DIMENSION(klon)       :: zgeo1_w, tair1_w, qair1_w, tairsol_w
    … …  
    984982    REAL, DIMENSION(klon)              :: yGamma_dTs_phiT, yGamma_dQs_phiQ
    985983    REAL, DIMENSION(klon)              :: ydTs_ins, ydqs_ins
    986 !
     984
    987985    REAL, PARAMETER                    :: facteur=2./sqrt(3.14)
    988986    REAL, PARAMETER                    :: inertia=2000.
    … …  
    10101008
    10111009    REAL                               :: vent
    1012 !
     1010
    10131011! For debugging with IOIPSL
    10141012    INTEGER, DIMENSION(nbp_lon*nbp_lat)    :: ndexbg
    … …  
    10721070
    10731071      IF (prt_level >=10) print *,' -> pbl_surface, itap ',itap
    1074 !
     1072
    10751073!!jyg      iflag_split = mod(iflag_pbl_split,2)
    10761074!!jyg      iflag_split = mod(iflag_pbl_split,10)
    1077 !
     1075
    10781076! Flags controlling the splitting of the turbulent boundary layer:
    10791077!   iflag_split_ref = 0  ==> no splitting
    … …  
    11311129! 1) Initialisation and validation tests
    11321130!    Only done first time entering this subroutine
    1133 !
     1131
    11341132!****************************************************************************************
    11351133
    … …  
    12081206! 2) Initialization to zero
    12091207!****************************************************************************************
    1210 !
     1208
    12111209! 2a) Initialization of all argument variables with INTENT(OUT)
    12121210!****************************************************************************************
    … …  
    13831381    flux_t_x(:,:,:)=0. ;          flux_t_w(:,:,:)=0.
    13841382    flux_q_x(:,:,:)=0. ;          flux_q_w(:,:,:)=0.
    1385 !
     1383
    13861384!jyg<
    13871385    flux_u_x(:,:,:)=0. ;          flux_u_w(:,:,:)=0.
    … …  
    13921390    flux_xt_x(:,:,:,:)=0. ;          flux_xt_w(:,:,:,:)=0.
    13931391#endif
    1394 !
     1392
    13951393!jyg<
    13961394! pblh,plcl,capCL,cteiCL ... are meaningfull only over sub-surfaces
    13971395! actually present in the grid cell  ==> value set to 999999.
    1398 !                           
     1396
    13991397!jyg<
    14001398       ustar(:,:)   = 999999.
    … …  
    14041402       v10m(:,:)    = 999999.
    14051403!>jyg
    1406 !
     1404
    14071405       pblh(:,:)   = 999999.        ! Hauteur de couche limite
    14081406       plcl(:,:)   = 999999.        ! Niveau de condensation de la CLA
    … …  
    14151413       trmb2(:,:)  = 999999.        ! inhibition
    14161414       trmb3(:,:)  = 999999.        ! Point Omega
    1417 !
     1415
    14181416       t2m_x(:,:)    = 999999.
    14191417       q2m_x(:,:)    = 999999.
    … …  
    14221420       u10m_x(:,:)   = 999999.
    14231421       v10m_x(:,:)   = 999999.
    1424 !                           
     1422
    14251423       pblh_x(:,:)   = 999999.      ! Hauteur de couche limite
    14261424       plcl_x(:,:)   = 999999.      ! Niveau de condensation de la CLA
    … …  
    14331431       trmb2_x(:,:)  = 999999.      ! inhibition
    14341432       trmb3_x(:,:)  = 999999.      ! Point Omega
    1435 !
     1433
    14361434       t2m_w(:,:)    = 999999.
    14371435       q2m_w(:,:)    = 999999.
    … …  
    14521450       trmb3_w(:,:)  = 999999.      ! Point Omega
    14531451!!!     
    1454 !
     1452
    14551453!!!
    14561454!****************************************************************************************
    … …  
    14681466!****************************************************************************************
    14691467! Test for rugos........ from physiq.. A la fin plutot???
    1470 !
     1468
    14711469!****************************************************************************************
    14721470
    … …  
    14791477
    14801478! Mean calculations of albedo
    1481 !
     1479
    14821480! * alb  : mean albedo for whole SW interval
    1483 !
     1481
    14841482! Mean albedo for grid point
    14851483! * alb_m  : mean albedo at whole SW interval
    … …  
    15371535       ENDDO
    15381536    ENDDO
    1539 !
     1537
    15401538!<al1: second order corrections
    15411539!- net = dwn -up; up=sig( T4 + 4sum%T3T' + 6sum%T2T'2 +...)
    … …  
    15771575!****************************************************************************************
    15781576! 4) Loop over different surfaces
    1579 !
     1577
    15801578! Only points containing a fraction of the sub surface will be treated.
    1581 !
     1579
    15821580!****************************************************************************************
    15831581                                                                          !<<<<<<<<<<<<<
    … …  
    15851583                                                                          !<<<<<<<<<<<<<
    15861584       IF (prt_level >=10) print *,' Loop nsrf ',nsrf
    1587 !
     1585
    15881586       IF (iflag_split_ref == 3) THEN
    15891587         IF (nsrf == is_oce) THEN
    … …  
    16271625!****************************************************************************************
    16281626! 5) Compress variables
    1629 !
    1630 !****************************************************************************************
    1631 
    1632 !
     1627
     1628!****************************************************************************************
     1629
    16331630!jyg<    (20190926)
    16341631!   Provisional : set ybeta to standard values
    … …  
    16461643       ENDIF !  (nsrf .NE. is_ter)
    16471644!>jyg
    1648 !
     1645
    16491646       DO j = 1, knon
    16501647          i = ni(j)
    … …  
    17401737          ENDDO
    17411738       ENDDO
    1742 !
     1739
    17431740!!! jyg le 07/02/2012 et le 10/04/2013
    17441741        DO k = 1, klev+1
    … …  
    17671764          ENDDO
    17681765        ENDDO
    1769 !
     1766
    17701767       IF (iflag_split>=1) THEN
    17711768!!! nrlmd le 02/05/2011
    … …  
    18051802!!             ywake_dltke(j,k) = wake_dltke(i,k,nsrf)
    18061803!!             ytke(j,k)     = tke(i,k,nsrf)
    1807 !
     1804
    18081805             ytke_x(j,k)      = tke_x(i,k,nsrf)
    18091806             ytke(j,k)        = tke_x(i,k,nsrf)+wake_s(i)*wake_dltke(i,k,nsrf)
    … …  
    18661863!****************************************************************************************
    18671864! 6a) Calculate coefficients for turbulent diffusion at surface, cdragh et cdragm.
    1868 !
     1865
    18691866!****************************************************************************************
    18701867
    … …  
    19361933        ENDIF
    19371934        IF (prt_level >=10) print *,'clcdrag -> ycdragh_x ', ycdragh_x(1:knon)
    1938 !
     1935
    19391936! Faire disparaitre les lignes commentees fin 2015 (le temps des tests)
    19401937!        CALL clcdrag( knon, nsrf, ypaprs, ypplay, &
    … …  
    19521949            yts_w, yqsurf_w, yz0m, yz0h, yri0, 0, &
    19531950            ycdragm_w, ycdragh_w, zri1_w, pref_w, rain_f, zxtsol, ypplay(:,1) )
    1954 !
     1951
    19551952        IF(ok_bug_zg_wk_pbl) THEN
    19561953         zgeo1(1:knon) = wake_s(1:knon)*zgeo1_w(1:knon) + (1.-wake_s(1:knon))*zgeo1_x(1:knon)
    … …  
    19761973!****************************************************************************************
    19771974! 6b) Calculate coefficients for turbulent diffusion in the atmosphere, ycoefh et ycoefm.
    1978 !
     1975
    19791976!****************************************************************************************
    19801977
    … …  
    20662063
    20672064        IF (prt_level >=10) print *,'coef_diff_turb -> ycoefh_x ',ycoefh_x(1:knon,:)
    2068 !
     2065
    20692066      IF (prt_level >=10) THEN
    20702067      print *,' args coef_diff_turb: yu_w ',  yu_w(1:knon,:)
    … …  
    21222119       
    21232120!****************************************************************************************
    2124 !
     2121
    21252122! 8) "La descente" - "The downhill"
    2126 ! 
     2123
    21272124!  climb_hq_down and climb_wind_down calculate the coefficients
    21282125!  Ccoef_X et Dcoef_X for X=[H, Q, U, V].
    21292126!  Only the coefficients at surface for H and Q are returned.
    2130 !
     2127
    21312128!****************************************************************************************
    21322129
    … …  
    21662163         PRINT *,'pbl_surface (climb_hq_down.x->) BcoefQ_x ',BcoefQ_x
    21672164       ENDIF
    2168 !
     2165
    21692166        CALL climb_hq_down(knon, ycoefh_w, ypaprs, ypplay, &
    21702167            ydelp, yt_w, yq_w, dtime, &
    … …  
    22062203!!!
    22072204            AcoefU_x, AcoefV_x, BcoefU_x, BcoefV_x)
    2208 !
     2205
    22092206        CALL climb_wind_down(knon, dtime, ycoefm_w, ypplay, ypaprs, yt_w, ydelp, yu_w, yv_w, &
    22102207!!! nrlmd le 02/05/2011
    … …  
    22362233!****************************************************************************************
    22372234! 9) Small calculations
    2238 !
     2235
    22392236!****************************************************************************************
    22402237
    … …  
    22682265#endif
    22692266
    2270 !
    22712267! Cdragq computation
    22722268! ------------------
    … …  
    22782274    ! pbl_surface of an independant cdragq variable.
    22792275    !******************************************************************************
    2280 !
     2276
    22812277    IF ( f_z0qh_oce /= 1. .and. nsrf ==is_oce) THEN
    22822278       ! Si on suit les formulations par exemple de Tessel, on
    … …  
    22862282!!       ycdragq_w(1:knon)=ycdragh_w(1:knon)*                                      &
    22872283!!            log(z1lay(1:knon)/yz0h(1:knon))/log(z1lay(1:knon)/(f_z0qh_oce*yz0h(1:knon)))
    2288 !
     2284
    22892285       DO j = 1,knon
    22902286         z1lay = zgeo1(j)/RG
    … …  
    22942290!!     Print *,'YYYYpbl0: fact_cdrag ', fact_cdrag
    22952291       ENDDO  ! j = 1,knon
    2296 !
     2292
    22972293!!  Print *,'YYYYpbl0: z1lay, yz0h, f_z0qh_oce, ycdragh_w, ycdragq_w ', &
    22982294!!                z1lay, yz0h(1:knon), f_z0qh_oce, ycdragh_w(1:knon), ycdragq_w(1:knon)
    … …  
    23012297       ycdragq_w(1:knon)=ycdragh_w(1:knon)
    23022298    ENDIF  ! ( f_z0qh_oce .ne. 1. .and. nsrf .eq.is_oce)
    2303 !
     2299
    23042300         CALL wx_pbl_prelim_0(knon, nsrf, dtime, ypplay, ypaprs, ywake_s,  &
    23052301                         yts, y_delta_tsurf, ygustiness, &
    … …  
    23752371!  Save initial value of z0h for use in evappot (z0h wiil be computed again in the surface models)
    23762372          yz0h_old(1:knon) = yz0h(1:knon)
    2377 !
    2378 !****************************************************************************************
    2379 !
     2373
     2374!****************************************************************************************
     2375
    23802376! Calulate t2m and q2m for the case of calculation at land grid points
    23812377! t2m and q2m are needed as input to ORCHIDEE
    2382 !
     2378
    23832379!****************************************************************************************
    23842380       IF (nsrf == is_ter) THEN
    … …  
    24062402
    24072403!****************************************************************************************
    2408 !
     2404
    24092405! 10) Switch according to current surface
    24102406!     It is necessary to start with the continental surfaces because the ocean
    24112407!     needs their run-off.
    2412 !
     2408
    24132409!****************************************************************************************
    24142410       SELECT CASE(nsrf)
    … …  
    26662662!****************************************************************************************
    26672663! 11) - Calcul the increment of surface temperature
    2668 !
     2664
    26692665!****************************************************************************************
    26702666
    … …  
    26772673 
    26782674!****************************************************************************************
    2679 !
     2675
    26802676! 12) "La remontee" - "The uphill"
    2681 !
     2677
    26822678!  The fluxes (y_flux_X) and tendancy (y_d_X) are calculated
    26832679!  for X=H, Q, U and V, for all vertical levels.
    2684 !
     2680
    26852681!****************************************************************************************
    26862682!!
    … …  
    27032699          y_flux_q1(:) =  flat/RLVTT
    27042700          yfluxlat(:) =  flat
    2705 !
     2701
    27062702!!  Test sur iflag_split retire le 2/02/2018, sans vraiment comprendre la raison de ce test. (jyg)
    27072703!!          IF (iflag_split .eq.0) THEN
    … …  
    27372733        ENDDO
    27382734        ENDIF
    2739 !
     2735
    27402736! ------------------------------------------------------------------------------
    27412737! 12a)  Splitting
    … …  
    27462742        call abort_gcm('pbl_surface_mod 2607','isos pas encore dans iflag_split=1',1)
    27472743#endif
    2748 !
    2749 !
     2744
     2745
    27502746         IF (nsrf /= is_oce) THEN
    2751 !
     2747
    27522748!         Compute potential evaporation and aridity factor  (jyg, 20200328)
    27532749          ybeta_prev(:) = ybeta(:)
    … …  
    27552751               yqa(j) = AcoefQ(j) - BcoefQ(j)*yevap(j)*dtime
    27562752             ENDDO
    2757 !
     2753
    27582754          CALL wx_evappot(knon, yqa, yTsurf_new, yevap_pot)
    2759 !
     2755
    27602756          ybeta(1:knon) = min(yevap(1:knon)/yevap_pot(1:knon), 1.)
    27612757         
    … …  
    27682764           ENDDO
    27692765          ENDIF  ! (prt_level >=10)
    2770 !
     2766
    27712767! Second call to wx_pbl0_merge and wx_pbl_dts_merge in order to take into account
    27722768! the update of the aridity coeficient beta.
    2773 !
     2769
    27742770        CALL wx_pbl_prelim_beta(knon, dtime, ywake_s, ybeta,  &
    27752771                        BcoefQ_x, BcoefQ_w  &
    … …  
    28152811            ydqs_ins(:) = 0.
    28162812          ENDIF   ! (iflag_split .eq. 2)
    2817 !
     2813
    28182814        ELSE    ! (nsrf .ne. is_oce)
    28192815          ybeta(1:knon) = 1.
    … …  
    28302826          ydqs_ins(:) = 0.
    28312827        ENDIF   ! (nsrf .ne. is_oce)
    2832 !
     2828
    28332829        CALL wx_pbl_split(knon, nsrf, dtime, ywake_s, ybeta, iflag_split, &
    28342830                       yg_T, yg_Q, &
    … …  
    28462842                       y_delta_tsurf_new, y_delta_qsurf &
    28472843                       )
    2848 !
     2844
    28492845         CALL wx_pbl_check(knon, dtime, ypplay, ypaprs, ywake_s, ybeta, iflag_split, &
    28502846                       yTs, y_delta_tsurf,  &
    … …  
    28582854                       y_flux_t1_x, y_flux_t1_w, &
    28592855                       y_flux_q1_x, y_flux_q1_w)
    2860 !
     2856
    28612857         IF (nsrf /= is_oce) THEN
    28622858           CALL wx_pbl_dts_check(knon, dtime, ypplay, ypaprs, ywake_s, ybeta, iflag_split, &
    … …  
    28772873                         y_flux_q1_x, y_flux_q1_w )
    28782874         ENDIF   ! (nsrf .ne. is_oce)
    2879 !
     2875
    28802876       ELSE  ! (iflag_split .ge. 1)
    28812877         ybeta(1:knon) = 1.
    28822878         yevap_pot(1:knon) = yevap(1:knon)
    28832879       ENDIF  ! (iflag_split .ge. 1)
    2884 !
     2880
    28852881       IF (prt_level >= 10) THEN
    28862882         print *,'pbl_surface, ybeta , yevap, yevap_pot ', &
    28872883                               ybeta(1:knon) , yevap(1:knon), yevap_pot(1:knon)
    28882884       ENDIF  ! (prt_level >= 10)
    2889 !
     2885
    28902886!>jyg
    2891 !
    2892  
     2887
    28932888!!jyg!!   A reprendre apres reflexion   ===============================================
    28942889!!jyg!!
    … …  
    29862981#endif
    29872982      )
    2988 !
     2983
    29892984       CALL climb_hq_up(knon, dtime, yt_w, yq_w, &
    29902985            y_flux_q1_w, y_flux_t1_w, ypaprs, ypplay, &
    … …  
    30323027!!!
    30333028            y_flux_u_x, y_flux_v_x, y_d_u_x, y_d_v_x)
    3034 !
     3029
    30353030     y_d_t_diss_x(:,:)=0.
    30363031     IF (iflag_pbl>=20 .and. iflag_pbl<30) THEN
    … …  
    30583053     ENDIF
    30593054!     print*,'yamada_c OK'
    3060 !
     3055
    30613056        IF (prt_level >=10) THEN
    30623057         print *, 'After climbing up, lfuxlat_x, fluxlat_w ', &
    30633058               yfluxlat_x(1:knon), yfluxlat_w(1:knon)
    30643059        ENDIF
    3065 !
     3060
    30663061       ENDIF  ! (iflag_split .eq.0)
    30673062
    … …  
    30873082!     - Multiply with pourcentage of current surface
    30883083!     - Cumulate in global variable
    3089 !
     3084
    30903085!****************************************************************************************
    30913086
    … …  
    32983293!!jyg20210118          delta_tsurf(i,nsrf)=y_delta_tsurf(j)
    32993294          delta_tsurf(i,nsrf)=y_delta_tsurf_new(j)
    3300 !
     3295
    33013296          delta_qsurf(i) = delta_qsurf(i) + y_delta_qsurf(j)*ypct(j)
    3302 !
     3297
    33033298          cdragh_x(i) = cdragh_x(i) + ycdragh_x(j)*ypct(j)
    33043299          cdragh_w(i) = cdragh_w(i) + ycdragh_w(j)*ypct(j)
    … …  
    34343429           d_u_x(i,k) = d_u_x(i,k) + y_d_u_x(j,k)
    34353430           d_v_x(i,k) = d_v_x(i,k) + y_d_v_x(j,k)
    3436 !
     3431
    34373432           d_t_diss_w(i,k) = d_t_diss_w(i,k) + y_d_t_diss_w(j,k)
    34383433           d_t_w(i,k) = d_t_w(i,k) + y_d_t_w(j,k)
    … …  
    34473442#endif
    34483443
    3449 !
    34503444!!           d_wake_dlt(i,k) = d_wake_dlt(i,k) + y_d_t_w(i,k)-y_d_t_x(i,k)
    34513445!!           d_wake_dlq(i,k) = d_wake_dlq(i,k) + y_d_q_w(i,k)-y_d_q_x(i,k)
    … …  
    35423536! 14) Calculate the temperature and relative humidity at 2m and the wind at 10m
    35433537!     Call HBTM
    3544 !
    3545 !****************************************************************************************
    3546 !!!
    3547 !
     3538
     3539!****************************************************************************************
     3540!!!
     3541
    35483542#undef T2m     
    35493543#define T2m     
    … …  
    36623656          u10m(i,nsrf)=(yu10m(j) * uzon(j))/SQRT(uzon(j)**2+vmer(j)**2)
    36633657          v10m(i,nsrf)=(yu10m(j) * vmer(j))/SQRT(uzon(j)**2+vmer(j)**2)
    3664 !
     3658
    36653659          DO k = 1, 6
    36663660           n2mout(i,nsrf,k) = yn2mout(j,nsrf,k)
    36673661          END DO 
    3668 !
     3662
    36693663        ENDDO
    36703664       ELSE  !(iflag_split .eq.0)
    … …  
    36773671          u10m_x(i,nsrf)=(yu10m_x(j) * uzon_x(j))/SQRT(uzon_x(j)**2+vmer_x(j)**2)
    36783672          v10m_x(i,nsrf)=(yu10m_x(j) * vmer_x(j))/SQRT(uzon_x(j)**2+vmer_x(j)**2)
    3679 !
     3673
    36803674          DO k = 1, 6
    36813675           n2mout_x(i,nsrf,k) = yn2mout_x(j,nsrf,k)
    36823676          END DO 
    3683 !
     3677
    36843678        ENDDO
    36853679        DO j=1, knon
    … …  
    36913685          u10m_w(i,nsrf)=(yu10m_w(j) * uzon_w(j))/SQRT(uzon_w(j)**2+vmer_w(j)**2)
    36923686          v10m_w(i,nsrf)=(yu10m_w(j) * vmer_w(j))/SQRT(uzon_w(j)**2+vmer_w(j)**2)
    3693 !
     3687
    36943688          ustar(i,nsrf) = ustar_x(i,nsrf) + wake_s(i)*(ustar_w(i,nsrf)-ustar_x(i,nsrf))
    36953689          u10m(i,nsrf) = u10m_x(i,nsrf) + wake_s(i)*(u10m_w(i,nsrf)-u10m_x(i,nsrf))
    36963690          v10m(i,nsrf) = v10m_x(i,nsrf) + wake_s(i)*(v10m_w(i,nsrf)-v10m_x(i,nsrf))
    3697 !
     3691
    36983692          DO k = 1, 6
    36993693           n2mout_w(i,nsrf,k) = yn2mout_w(j,nsrf,k)
    37003694          END DO 
    3701 !
     3695
    37023696        ENDDO
    37033697!!!
    … …  
    37493743!!!
    37503744       ENDIF
    3751 !
     3745
    37523746       IF (prt_level >=10) THEN
    37533747         print *, 'T2m, q2m, RH2m ', &
    … …  
    37563750
    37573751!   print*,'OK pbl 5'
    3758 !
     3752
    37593753!!! jyg le 07/02/2012
    37603754       IF (iflag_split ==0) THEN
    … …  
    38793873!****************************************************************************************
    38803874! 15) End of loop over different surfaces
    3881 !
     3875
    38823876!****************************************************************************************
    38833877    ENDDO loop_nbsrf
    3884 !
     3878
    38853879!----------------------------------------------------------------------------------------
    38863880!   Reset iflag_split
    3887 !
     3881
    38883882   iflag_split=iflag_split_ref
    38893883
    … …  
    39013895!****************************************************************************************
    39023896! 16) Calculate the mean value over all sub-surfaces for some variables
    3903 !
     3897
    39043898!****************************************************************************************
    39053899   
    … …  
    39393933              zxfluxu_x(i,k) = zxfluxu_x(i,k) + flux_u_x(i,k,nsrf) * pctsrf(i,nsrf)
    39403934              zxfluxv_x(i,k) = zxfluxv_x(i,k) + flux_v_x(i,k,nsrf) * pctsrf(i,nsrf)
    3941 !
     3935
    39423936              zxfluxt_w(i,k) = zxfluxt_w(i,k) + flux_t_w(i,k,nsrf) * pctsrf(i,nsrf)
    39433937              zxfluxq_w(i,k) = zxfluxq_w(i,k) + flux_q_w(i,k,nsrf) * pctsrf(i,nsrf)
    … …  
    40094003!!!
    40104004
    4011 !
    40124005! Incrementer la temperature du sol
    4013 !
     4006
    40144007    zxtsol(:) = 0.0  ; zxfluxlat(:) = 0.0
    40154008    zt2m(:) = 0.0    ; zq2m(:) = 0.0 ; zn2mout(:,:) = 0
    … …  
    40454038       ENDDO
    40464039    ENDDO
    4047 !
     4040
    40484041!<al1 order 2 correction to zxtsol, for radiation computations (main atm effect of Ts)
    40494042   IF (iflag_order2_sollw == 1) THEN
    … …  
    40644057          zt2m(i)  = zt2m(i)  + t2m(i,nsrf)  * pctsrf(i,nsrf)
    40654058          zq2m(i)  = zq2m(i)  + q2m(i,nsrf)  * pctsrf(i,nsrf)
    4066 !
     4059
    40674060          DO k = 1, 6
    40684061           zn2mout(i,k)  = zn2mout(i,k)  + n2mout(i,nsrf,k)  * pctsrf(i,nsrf)
    40694062          ENDDO 
    4070 !
     4063
    40714064          zustar(i) = zustar(i) + ustar(i,nsrf) * pctsrf(i,nsrf)
    40724065          wstar(i,is_ave)=wstar(i,is_ave)+wstar(i,nsrf)*pctsrf(i,nsrf)
    … …  
    41004093          zt2m(i)  = zt2m(i)  + (t2m_x(i,nsrf)+wake_s(i)*(t2m_w(i,nsrf)-t2m_x(i,nsrf))) * pctsrf(i,nsrf)
    41014094          zq2m(i)  = zq2m(i)  + q2m_x(i,nsrf)  * pctsrf(i,nsrf)
    4102 !
     4095
    41034096          DO k = 1, 6
    41044097           zn2mout(i,k)  = zn2mout(i,k)  + n2mout_x(i,nsrf,k)  * pctsrf(i,nsrf)
    41054098          ENDDO
    4106 !
     4099
    41074100          zustar(i) = zustar(i) + ustar_x(i,nsrf) * pctsrf(i,nsrf)
    41084101          wstar(i,is_ave)=wstar(i,is_ave)+wstar_x(i,nsrf)*pctsrf(i,nsrf)
    41094102          zu10m(i) = zu10m(i) + u10m_x(i,nsrf) * pctsrf(i,nsrf)
    41104103          zv10m(i) = zv10m(i) + v10m_x(i,nsrf) * pctsrf(i,nsrf)
    4111 !
     4104
    41124105          s_pblh(i)     = s_pblh(i)     + pblh_x(i,nsrf)  * pctsrf(i,nsrf)
    41134106          s_pblh_x(i)   = s_pblh_x(i)   + pblh_x(i,nsrf)  * pctsrf(i,nsrf)
    41144107          s_pblh_w(i)   = s_pblh_w(i)   + pblh_w(i,nsrf)  * pctsrf(i,nsrf)
    4115 !
     4108
    41164109          s_plcl(i)     = s_plcl(i)     + plcl_x(i,nsrf)  * pctsrf(i,nsrf)
    41174110          s_plcl_x(i)   = s_plcl_x(i)   + plcl_x(i,nsrf)  * pctsrf(i,nsrf)
    41184111          s_plcl_w(i)   = s_plcl_w(i)   + plcl_w(i,nsrf)  * pctsrf(i,nsrf)
    4119 !
     4112
    41204113          s_capCL(i)  = s_capCL(i)  + capCL_x(i,nsrf) * pctsrf(i,nsrf)
    41214114          s_oliqCL(i) = s_oliqCL(i) + oliqCL_x(i,nsrf)* pctsrf(i,nsrf)
    … …  
    42024195
    42034196  END SUBROUTINE pbl_surface
    4204 !
    4205 !****************************************************************************************
    4206 !
     4197
     4198!****************************************************************************************
     4199
    42074200  SUBROUTINE pbl_surface_final(fder_rst, snow_rst, qsurf_rst, ftsoil_rst &
    42084201#ifdef ISO
    … …  
    42354228!****************************************************************************************
    42364229! Return module variables for writing to restart file
    4237 !
     4230
    42384231!****************************************************************************************   
    42394232    fder_rst(:)       = fder(:)
    … …  
    42484241!****************************************************************************************
    42494242! Deallocate module variables
    4250 !
     4243
    42514244!****************************************************************************************
    42524245!   DEALLOCATE(qsol, fder, snow, qsurf, evap, rugos, agesno, ftsoil)
    … …  
    42664259!****************************************************************************************
    42674260! Deallocate variables for pbl splitting
    4268 !
     4261
    42694262!****************************************************************************************
    42704263
    … …  
    42734266
    42744267  END SUBROUTINE pbl_surface_final
    4275 ! 
    4276 !****************************************************************************************
    4277 !
     4268
     4269!****************************************************************************************
    42784270
    42794271!albedo SB >>>
    … …  
    43264318    INTEGER           :: ixt
    43274319#endif
    4328 !
     4320
    43294321! All at once !!
    43304322!****************************************************************************************
    … …  
    44604452
    44614453  END SUBROUTINE pbl_surface_newfrac
    4462 ! 
    4463 !****************************************************************************************
    4464 ! 
     4454
     4455!****************************************************************************************
     4456
    44654457END MODULE pbl_surface_mod
Note: See TracChangeset for help on using the changeset viewer.