Changeset 2298


Ignore:
Timestamp:
Jun 14, 2015, 9:13:32 PM (10 years ago)
Author:
Laurent Fairhead
Message:

Merged trunk changes -r2237:2291 into testing branch

Location:
LMDZ5/branches/testing
Files:
55 deleted
111 edited
166 copied

Legend:

Unmodified
Added
Removed

  • LMDZ5/branches/testing

  • LMDZ5/branches/testing/DefLists/field_def_lmdz.xml

    r2258 r2298  
    1 <field_definition level="1" prec="4" operation="average" freq_op="1ts" enabled=".true.">
     1<field_definition level="1" prec="4" operation="average" freq_op="1ts" enabled=".true." default_value="9.96921e+36">
    22   
    33<!--    <field_group id="fields_1D" grid_ref="vertical">  -->
    … …  
    212212        <field id="alp_bl_conv"    long_name="ALP_BL_CONV"    unit="W/m2" />
    213213        <field id="alp_bl_stat"    long_name="ALP_BL_STAT"    unit="W/m2" />
    214         <field id="u850"    long_name="Zonal wind 1hPa"    unit="m/s" />
    215         <field id="u700"    long_name="Zonal wind 2hPa"    unit="m/s" />
    216         <field id="u500"    long_name="Zonal wind 3hPa"    unit="m/s" />
    217         <field id="u200"    long_name="Zonal wind 4hPa"    unit="m/s" />
    218         <field id="u100"    long_name="Zonal wind 5hPa"    unit="m/s" />
    219         <field id="u50"     long_name="Zonal wind 6hPa"    unit="m/s" />
    220         <field id="u10"     long_name="Zonal wind 7hPa"    unit="m/s" />
    221         <field id="v850"    long_name="Meridional wind 1hPa"    unit="m/s" />
    222         <field id="v700"    long_name="Meridional wind 2hPa"    unit="m/s" />
    223         <field id="v500"    long_name="Meridional wind 3hPa"    unit="m/s" />
    224         <field id="v200"    long_name="Meridional wind 4hPa"    unit="m/s" />
    225         <field id="v100"    long_name="Meridional wind 5hPa"    unit="m/s" />
    226         <field id="v50"     long_name="Meridional wind 6hPa"    unit="m/s" />
    227         <field id="v10"    long_name="Meridional wind 7hPa"    unit="m/s" />
    228         <field id="w850"    long_name="Vertical wind 1hPa"    unit="Pa/s" />
    229         <field id="w700"    long_name="Vertical wind 2hPa"    unit="Pa/s" />
    230         <field id="w500"    long_name="Vertical wind 3hPa"    unit="Pa/s" />
    231         <field id="w200"    long_name="Vertical wind 4hPa"    unit="Pa/s" />
    232         <field id="w100"    long_name="Vertical wind 5hPa"    unit="Pa/s" />
    233         <field id="w50"    long_name="Vertical wind 6hPa"    unit="Pa/s" />
    234         <field id="w10"    long_name="Vertical wind 7hPa"    unit="Pa/s" />
    235         <field id="t850"    long_name="Temperature 1hPa"    unit="K" />
    236         <field id="t700"    long_name="Temperature 2hPa"    unit="K" />
    237         <field id="t500"    long_name="Temperature 3hPa"    unit="K" />
    238         <field id="t200"    long_name="Temperature 4hPa"    unit="K" />
    239         <field id="t100"    long_name="Temperature 5hPa"    unit="K" />
    240         <field id="t50"    long_name="Temperature 6hPa"    unit="K" />
    241         <field id="t10"    long_name="Temperature 7hPa"    unit="K" />
    242         <field id="q850"    long_name="Specific humidity 1hPa"    unit="kg/kg" />
    243         <field id="q700"    long_name="Specific humidity 2hPa"    unit="kg/kg" />
    244         <field id="q500"    long_name="Specific humidity 3hPa"    unit="kg/kg" />
    245         <field id="q200"    long_name="Specific humidity 4hPa"    unit="kg/kg" />
    246         <field id="q100"    long_name="Specific humidity 5hPa"    unit="kg/kg" />
    247         <field id="q50"    long_name="Specific humidity 6hPa"    unit="kg/kg" />
    248         <field id="q10"    long_name="Specific humidity 7hPa"    unit="kg/kg" />
    249         <field id="z850"    long_name="Geopotential height 1hPa"    unit="m" />
    250         <field id="z700"    long_name="Geopotential height 2hPa"    unit="m" />
    251         <field id="z500"    long_name="Geopotential height 3hPa"    unit="m" />
    252         <field id="z200"    long_name="Geopotential height 4hPa"    unit="m" />
    253         <field id="z100"    long_name="Geopotential height 5hPa"    unit="m" />
    254         <field id="z50"    long_name="Geopotential height 6hPa"    unit="m" />
    255         <field id="z10"    long_name="Geopotential height 7hPa"    unit="m" />
     214        <field id="u850"    long_name="Zonal wind 850hPa"    unit="m/s" />
     215        <field id="u700"    long_name="Zonal wind 700hPa"    unit="m/s" />
     216        <field id="u500"    long_name="Zonal wind 500hPa"    unit="m/s" />
     217        <field id="u200"    long_name="Zonal wind 200hPa"    unit="m/s" />
     218        <field id="u100"    long_name="Zonal wind 100hPa"    unit="m/s" />
     219        <field id="u50"     long_name="Zonal wind 50hPa"    unit="m/s" />
     220        <field id="u10"     long_name="Zonal wind 10hPa"    unit="m/s" />
     221        <field id="v850"    long_name="Meridional wind 850hPa"    unit="m/s" />
     222        <field id="v700"    long_name="Meridional wind 700hPa"    unit="m/s" />
     223        <field id="v500"    long_name="Meridional wind 500hPa"    unit="m/s" />
     224        <field id="v200"    long_name="Meridional wind 200hPa"    unit="m/s" />
     225        <field id="v100"    long_name="Meridional wind 100hPa"    unit="m/s" />
     226        <field id="v50"     long_name="Meridional wind 50hPa"    unit="m/s" />
     227        <field id="v10"    long_name="Meridional wind 10hPa"    unit="m/s" />
     228        <field id="w850"    long_name="Vertical wind 850hPa"    unit="Pa/s" />
     229        <field id="w700"    long_name="Vertical wind 700hPa"    unit="Pa/s" />
     230        <field id="w500"    long_name="Vertical wind 500hPa"    unit="Pa/s" />
     231        <field id="w200"    long_name="Vertical wind 200hPa"    unit="Pa/s" />
     232        <field id="w100"    long_name="Vertical wind 100hPa"    unit="Pa/s" />
     233        <field id="w50"    long_name="Vertical wind 50hPa"    unit="Pa/s" />
     234        <field id="w10"    long_name="Vertical wind 10hPa"    unit="Pa/s" />
     235        <field id="t850"    long_name="Temperature 850hPa"    unit="K" />
     236        <field id="t700"    long_name="Temperature 700hPa"    unit="K" />
     237        <field id="t500"    long_name="Temperature 500hPa"    unit="K" />
     238        <field id="t200"    long_name="Temperature 200hPa"    unit="K" />
     239        <field id="t100"    long_name="Temperature 100hPa"    unit="K" />
     240        <field id="t50"    long_name="Temperature 50hPa"    unit="K" />
     241        <field id="t10"    long_name="Temperature 10hPa"    unit="K" />
     242        <field id="q850"    long_name="Specific humidity 850hPa"    unit="kg/kg" />
     243        <field id="q700"    long_name="Specific humidity 700hPa"    unit="kg/kg" />
     244        <field id="q500"    long_name="Specific humidity 500hPa"    unit="kg/kg" />
     245        <field id="q200"    long_name="Specific humidity 200hPa"    unit="kg/kg" />
     246        <field id="q100"    long_name="Specific humidity 100hPa"    unit="kg/kg" />
     247        <field id="q50"    long_name="Specific humidity 50hPa"    unit="kg/kg" />
     248        <field id="q10"    long_name="Specific humidity 10hPa"    unit="kg/kg" />
     249        <field id="z850"    long_name="Geopotential height 850hPa"    unit="m" />
     250        <field id="z700"    long_name="Geopotential height 700hPa"    unit="m" />
     251        <field id="z500"    long_name="Geopotential height 500hPa"    unit="m" />
     252        <field id="z200"    long_name="Geopotential height 200hPa"    unit="m" />
     253        <field id="z100"    long_name="Geopotential height 100hPa"    unit="m" />
     254        <field id="z50"    long_name="Geopotential height 50hPa"    unit="m" />
     255        <field id="z10"    long_name="Geopotential height 10hPa"    unit="m" />
    256256        <field id="t_oce_sic"    long_name="Temp mixte oce-sic"    unit="K" />
    257257        <field id="weakinv"    long_name="Weak inversion"    unit="-" />
    … …  
    547547   
    548548    <field_group  id="fields_NMC" domain_ref="dom_glo" axis_ref="plev">
    549       <field id="tnondef" long_name="Undefined value of T" unit="K" />
     549<!--  <field id="tnondef" long_name="Undefined value of T" unit="K" /> -->
    550550      <field id="ta" long_name="Air temperature" unit="K" />
    551551      <field id="zg" long_name="Geopotential height" unit="m" />
    … …  
    555555      <field id="va" long_name="Northward wind" unit="m s-1" />
    556556      <field id="wap" long_name="Lagrangian tendency of air pressure" unit="Pa s-1" />
    557       <field id="psbg" long_name="Pressure sfce below ground" unit="%" />
     557<!--  <field id="psbg" long_name="Pressure sfce below ground" unit="%" /> -->
    558558      <field id="tro3" long_name="Ozone mole fraction" unit="1e-9" />
    559559      <field id="tro3_daylight" long_name="Daylight ozone mole fraction" unit="1e-9" />
    … …  
    621621    </field_group>
    622622
    623     <field_group id="fields_COSP_CALIPSO" domain_ref="dom_glo">
     623    <field_group id="fields_COSP_CALIPSO" domain_ref="dom_glo" freq_op="3h">
    624624      <field id="cllcalipso"    long_name="Lidar Low-level Cloud Fraction"   unit="1" />
    625625      <field id="clhcalipso"    long_name="Lidar Hight-level Cloud Fraction"   unit="1" />
    … …  
    629629      <field id="parasol_refl"  long_name="PARASOL-like mono-directional reflectance" unit="1" axis_ref="sza" />
    630630      <field id="parasol_crefl"  long_name="PARASOL-like mono-directional reflectance (integral)" unit="1" axis_ref="sza" />
     631      <field id="Ncrefl"  long_name="Nb for PARASOL-like mono-directional reflectance" unit="1" axis_ref="sza" />
    631632      <field id="c01_cfad_lidarsr532" long_name="Lidar Scattering Ratio CFAD (532 nm)" unit="1" axis_ref="presnivs" />
    632633      <field id="c02_cfad_lidarsr532" long_name="Lidar Scattering Ratio CFAD (532 nm)" unit="1" axis_ref="presnivs" />
    … …  
    672673    </field_group> 
    673674
    674     <field_group id="fields_COSP_ISCCP" domain_ref="dom_glo">
     675    <field_group id="fields_COSP_ISCCP" domain_ref="dom_glo" freq_op="3h">
    675676      <field id="sunlit" long_name="1 for day points, 0 for nightime" unit="1" />
    676677      <field id="c01_clisccp2" long_name="Cloud Fraction as Calculated by the ISCCP Simulator" unit="1" axis_ref="pressure2" />

  • LMDZ5/branches/testing/DefLists/file_def_histLES_lmdz.xml

    r2258 r2298  
    205205                <field field_ref="alp_bl_stat" level="10" />
    206206
    207                 <field_group operation="instant">
     207                <field_group operation="average" freq_op="1ts" detect_missing_value=".true.">
    208208                    <field field_ref="u850" level="10" />
    209209                    <field field_ref="u700" level="10" />

  • LMDZ5/branches/testing/DefLists/file_def_histdayCOSP_lmdz.xml

    r2160 r2298  
    44
    55            <!-- VARS 2D -->
    6             <field_group operation="instant" freq_op="1ts">
     6            <field_group operation="average" freq_op="3h">
    77                <field field_ref="cllcalipso"         level="1" />
    88                <field field_ref="clmcalipso"         level="1" />
    … …  
    1212                <field field_ref="parasol_refl"  level="1" axis_ref="sza" />
    1313                <field field_ref="parasol_crefl"  level="1" axis_ref="sza" />
     14                <field field_ref="Ncrefl"  level="1" axis_ref="sza" />
    1415                <field field_ref="c01_cfad_lidarsr532"  level="10" axis_ref="presnivs" />
    1516                <field field_ref="c02_cfad_lidarsr532"  level="10" axis_ref="presnivs" />

  • LMDZ5/branches/testing/DefLists/file_def_histdayNMC_lmdz.xml

    r2160 r2298  
    44
    55            <!-- VARS 3D -->
    6             <field_group operation="instant" freq_op="1ts" >
    7                 <field field_ref="tnondef" level="5" />
     6            <field_group operation="average" freq_op="1ts" detect_missing_value=".true.">
     7<!--            <field field_ref="tnondef" level="5" /> -->
    88                <field field_ref="ta" level="1" />
    99                <field field_ref="zg" level="5" />
    … …  
    1313                <field field_ref="va" level="5" />
    1414                <field field_ref="wap" level="5" />
    15                 <field field_ref="psbg" level="5" />
     15<!--            <field field_ref="psbg" level="5" /> -->
    1616                <field field_ref="tro3" level="5" />
    1717                <field field_ref="tro3_daylight" level="5" />

  • LMDZ5/branches/testing/DefLists/file_def_histday_lmdz.xml

    r2258 r2298  
    205205                <field field_ref="alp_bl_stat" level="1" />
    206206
    207                 <field_group operation="instant">
     207                <field_group operation="average" freq_op="1ts" detect_missing_value=".true.">
    208208                    <field field_ref="u850" level="7" />
    209209                    <field field_ref="u700" level="7" />

  • LMDZ5/branches/testing/DefLists/file_def_histhfCOSP_lmdz.xml

    r2160 r2298  
    11<file_definition>
    22     <file_group id="defile">
    3         <file id="histhfCOSP" name="XhisthfCOSP" output_freq="6h" output_level="10"  enabled=".FALSE.">
     3        <file id="histhfCOSP" name="XhisthfCOSP" output_freq="3h" output_level="10"  enabled=".FALSE.">
    44
    55            <!-- VARS 2D -->
    6             <field_group operation="instant" freq_op="1ts">
     6            <field_group operation="instant" freq_op="3h">
    77                <field field_ref="cllcalipso"         level="1" />
    88                <field field_ref="clmcalipso"         level="1" />
    … …  
    1212                <field field_ref="parasol_refl"  level="1" axis_ref="sza" />
    1313                <field field_ref="parasol_crefl"  level="1" axis_ref="sza" />
     14                <field field_ref="Ncrefl"  level="1" axis_ref="sza" />
    1415                <field field_ref="c01_cfad_lidarsr532"  level="10" axis_ref="presnivs" />
    1516                <field field_ref="c02_cfad_lidarsr532"  level="10" axis_ref="presnivs" />

  • LMDZ5/branches/testing/DefLists/file_def_histhfNMC_lmdz.xml

    r2160 r2298  
    44
    55            <!-- VARS 3D -->
    6             <field_group operation="instant" freq_op="1ts" >
    7                 <field field_ref="tnondef" level="5" />
     6            <field_group operation="instant" freq_op="1ts" detect_missing_value=".true." >
     7<!--            <field field_ref="tnondef" level="5" />  -->
    88                <field field_ref="ta" level="1" />
    99                <field field_ref="zg" level="5" />
    … …  
    1313                <field field_ref="va" level="5" />
    1414                <field field_ref="wap" level="5" />
    15                 <field field_ref="psbg" level="5" />
     15<!--            <field field_ref="psbg" level="5" /> -->
    1616                <field field_ref="tro3" level="5" />
    1717                <field field_ref="tro3_daylight" level="5" />

  • LMDZ5/branches/testing/DefLists/file_def_histhf_lmdz.xml

    r2258 r2298  
    205205                <field field_ref="alp_bl_stat" level="10" />
    206206
    207                 <field_group operation="instant">
     207                <field_group operation="average" freq_op="1ts" detect_missing_value=".true.">
    208208                    <field field_ref="u850" level="10" />
    209209                    <field field_ref="u700" level="10" />

  • LMDZ5/branches/testing/DefLists/file_def_histins_lmdz.xml

    r2258 r2298  
    11<file_definition>
    22    <file_group id="defile">
    3         <file id="histins" name="Xhistins" output_freq="6h" output_level="4" enabled=".FALSE.">
     3        <file id="histins" name="Xhistins" output_freq="1ts" output_level="4" enabled=".FALSE.">
    44           
    55            <!-- VARS 1D -->
    … …  
    205205                <field field_ref="alp_bl_stat" level="1" />
    206206
    207                 <field_group operation="instant">
     207                <field_group operation="instant" freq_op="1ts" detect_missing_value=".true.">
    208208                    <field field_ref="u850" level="7" />
    209209                    <field field_ref="u700" level="7" />

  • LMDZ5/branches/testing/DefLists/file_def_histmthCOSP_lmdz.xml

    r2160 r2298  
    11<file_definition>
    22     <file_group id="defile">
    3         <file id="histmthCOSP" name="XhistmthCOSP" output_freq="5d" output_level="10"  enabled=".FALSE.">
     3        <file id="histmthCOSP" name="XhistmthCOSP" output_freq="1mo" output_level="10"  enabled=".FALSE.">
    44
    55            <!-- VARS 2D -->
    6             <field_group operation="instant" freq_op="1ts">
     6            <field_group operation="average" freq_op="3h">
    77                <field field_ref="cllcalipso"         level="1" />
    88                <field field_ref="clmcalipso"         level="1" />
    … …  
    1212                <field field_ref="parasol_refl"  level="1" axis_ref="sza" />
    1313                <field field_ref="parasol_crefl"  level="1" axis_ref="sza" />
     14                <field field_ref="Ncrefl"  level="1" axis_ref="sza" />
    1415                <field field_ref="c01_cfad_lidarsr532"  level="10" axis_ref="presnivs" />
    1516                <field field_ref="c02_cfad_lidarsr532"  level="10" axis_ref="presnivs" />

  • LMDZ5/branches/testing/DefLists/file_def_histmthNMC_lmdz.xml

    r2160 r2298  
    44
    55            <!-- VARS 3D -->
    6             <field_group operation="instant" freq_op="1ts" >
    7                 <field field_ref="tnondef" level="5" />
     6            <field_group operation="average" freq_op="1ts" detect_missing_value=".true.">
     7<!--            <field field_ref="tnondef" level="5" />  -->
    88                <field field_ref="ta" level="1" />
    99                <field field_ref="zg" level="5" />
    … …  
    1313                <field field_ref="va" level="5" />
    1414                <field field_ref="wap" level="5" />
    15                 <field field_ref="psbg" level="5" />
     15<!--            <field field_ref="psbg" level="5" />  -->
    1616                <field field_ref="tro3" level="5" />
    1717                <field field_ref="tro3_daylight" level="5" />

  • LMDZ5/branches/testing/DefLists/file_def_histmth_lmdz.xml

    r2258 r2298  
    205205                <field field_ref="alp_bl_stat" level="1" />
    206206
    207                 <field_group operation="instant">
     207                <field_group operation="average" freq_op="1ts" detect_missing_value=".true.">
    208208                    <field field_ref="u850" level="1" />
    209209                    <field field_ref="u700" level="1" />

  • LMDZ5/branches/testing/DefLists/file_def_histstn_lmdz.xml

    r2258 r2298  
    205205                <field field_ref="alp_bl_stat" level="10" />
    206206
    207                 <field_group operation="instant">
     207                <field_group operation="average" freq_op="1ts" detect_missing_value=".true.">
    208208                    <field field_ref="u850" level="10" />
    209209                    <field field_ref="u700" level="10" />

  • LMDZ5/branches/testing/arch/arch-X64_ADA.fcm

    r2258 r2298  
    55%FPP_FLAGS           -P -traditional -I/smplocal/pub/FFTW/3.3.3_dyn/include/
    66%FPP_DEF             NC_DOUBLE FFT_FFTW
    7 %BASE_FFLAGS         -auto -mcmodel=large -integer-size 32 -real-size 64 -align all
     7%BASE_FFLAGS         -auto -recursive -mcmodel=large -integer-size 32 -real-size 64 -align all
    88%PROD_FFLAGS         -O2 -ip -fp-model strict -axAVX,SSE4.2
    99%DEV_FFLAGS          -p -g -O0 -fpe0 -traceback

  • LMDZ5/branches/testing/arch/arch-X64_CURIE.fcm

    r2160 r2298  
    55%FPP_FLAGS           -P -traditional
    66%FPP_DEF             NC_DOUBLE FFT_MKL
    7 #%BASE_FFLAGS        -xHost -i4 -r8 -auto -align all -I$(MKL_INC_DIR) -I$(MKL_INC_DIR)/intel64/lp64
     7#%BASE_FFLAGS        -recursive -xHost -i4 -r8 -auto -align all -I$(MKL_INC_DIR) -I$(MKL_INC_DIR)/intel64/lp64
    88%BASE_FFLAGS         -i4 -r8 -auto -align all -I$(MKL_INC_DIR) -I$(MKL_INC_DIR)/intel64/lp64 -fp-model strict
    99%PROD_FFLAGS         -O2

  • LMDZ5/branches/testing/arch/arch-gfortran.fcm

    r1910 r2298  
    55%FPP_FLAGS           -P -traditional
    66%FPP_DEF             NC_DOUBLE
    7 %BASE_FFLAGS         -c -fdefault-real-8
     7%BASE_FFLAGS         -c -fdefault-real-8 -frecursive
    88%PROD_FFLAGS         -O3
    99%DEV_FFLAGS          -O

  • LMDZ5/branches/testing/arch/arch-gfortran_CICLAD.fcm

    r2160 r2298  
    55%FPP_FLAGS           -P -traditional
    66%FPP_DEF             NC_DOUBLE
    7 %BASE_FFLAGS         -c -fdefault-real-8 -fcray-pointer
     7%BASE_FFLAGS         -c -fdefault-real-8 -fcray-pointer -frecursive
    88%PROD_FFLAGS         -O3
    99%DEV_FFLAGS          -O -Wall -fbounds-check

  • LMDZ5/branches/testing/bld.cfg

    r2160 r2298  
    2424src::dyn     %SRC_PATH/%DYN
    2525src::phys    %SRC_PATH/%PHYS
     26src::dyn_phys %DYN_PHYS
     27src::dyn_phys_sub %DYN_PHYS_SUB
    2628src::sisvat  %SISVAT
    2729src::rrtm    %RRTM
    2830src::grid    %SRC_PATH/grid
    29 src::filtrez %SRC_PATH/filtrez
    30 src::bibio   %SRC_PATH/bibio
    31 src::dyn3d_common   %SRC_PATH/dyn3d_common
     31src::filtrez %FILTRE
     32src::misc    %SRC_PATH/misc
     33src::dyn3d_common   %DYN_COMMON
    3234src::cosp    %COSP
    3335src::ext_src %EXT_SRC

  • LMDZ5/branches/testing/create_make_gcm

    r2160 r2298  
    55#set -xv
    66
     7# arguments given to create_make_gcm are the directories to scan
     8src_dirs=$*
    79
    810machine=`hostname`
    … …  
    4850fi
    4951echo "LOCAL_DIR=`echo $localdir`"
    50 echo 'BIBIO    = $(LIBF)/bibio'
     52echo 'MISC    = $(LIBF)/misc'
    5153echo "FILTRE   = filtre"
    5254echo "PHYS  = "
    5355echo 'LIBPHY = $(LIBO)/libphy$(PHYS).a'
     56echo 'LIBDYN_PHY = $(LIBO)/libdynlmdz_phy$(PHYS).a'
    5457echo 'DIRMAIN=dyn$(DIM)d$(FLAG_PARA)'
    5558echo 'RM=rm'
    … …  
    6063echo 'L_DYN      = -ldyn$(DIM)d$(FLAG_PARA) -ldyn3d_common'
    6164echo 'L_FILTRE   = -l$(FILTRE)'
     65echo 'L_DYN_PHY = -ldynlmdz_phy$(PHYS) '
    6266echo 'L_PHY = -lphy$(PHYS) '
    63 echo 'L_BIBIO    = -lbibio'
     67echo 'L_MISC    = -lmisc'
    6468echo 'L_ADJNT    ='
    6569echo 'L_COSP     = -lcosp'
    … …  
    8791echo 'DYN  = dyn$(DIM)d'
    8892echo
    89 #echo 'main : chimie $(DYN) bibio phys $(OPTION_DEP) '
    90 echo 'main : $(DYN) bibio phys $(OPTION_DEP) '
     93#echo 'main : chimie $(DYN) misc phys $(OPTION_DEP) '
     94echo 'main : $(DYN) misc phys dyn_phy $(OPTION_DEP) '
    9195echo '  cd $(LIBO) ; $(RANLIB) lib*.a ; cd $(GCM) ;\'
    9296echo '  cd $(LOCAL_DIR); \'
    9397echo '  $(COMPILE90) $(LIBF)/$(DIRMAIN)/$(SOURCE) -o $(PROG).o ; \'
    94 echo '  $(LINK) $(PROG).o -L$(LIBO) $(L_DYN) $(L_ADJNT) $(L_COSP) $(L_PHY) $(L_DYN) $(L_DYN3D_COMMON) $(L_BIBIO) $(L_DYN3D_COMMON) $(L_PHY) $(L_DYN) $(L_FILTRE) $(OPLINK) $(OPTION_LINK) -o $(LOCAL_DIR)/$(PROG).e ; $(RM) $(PROG).o '
     98echo '  $(LINK) $(PROG).o -L$(LIBO) $(L_DYN) $(L_DYN_PHY) $(L_ADJNT) $(L_COSP) $(L_PHY) $(L_DYN) $(L_DYN3D_COMMON) $(L_MISC) $(L_DYN3D_COMMON) $(L_PHY) $(L_DYN_PHY) $(L_DYN) $(L_FILTRE) $(OPLINK) $(OPTION_LINK) -o $(LOCAL_DIR)/$(PROG).e ; $(RM) $(PROG).o '
    9599echo
    96100echo 'phys : $(LIBPHY)'
    … …  
    99103echo 'dyn1d :'
    100104echo
     105echo 'dyn_phy: $(LIBDYN_PHYS)'
    101106echo
    102107#echo 'chimie : $(LIBO)/libchimie.a'
    103108echo
    104 echo 'bibio : $(LIBO)/libbibio.a'
     109echo 'misc : $(LIBO)/libmisc.a'
    105110echo
    106111echo 'adjnt : $(LIBO)/libadjnt.a'
    … …  
    121126cd $libf >/dev/null 2>&1
    122127
    123 for diri in ` ls ` ; do
     128for diri in $src_dirs ; do
    124129
    125130   if [ -d $diri ] ; then
    126    if [ "`ls $diri/*.F $diri/*/*.F`" != "" ] || [ "`ls $diri/*.[fF]90 $diri/*/*.[fF]90`" != "" ]  ; then
     131   if [ "`ls $diri/*.F`" != "" ] || [ "`ls $diri/*.[fF]90`" != "" ]  ; then
    127132#      cd $diri >/dev/null 2>&1
    128133      echo
    129134      listlib=""
    130135# Liste des fichiers .F et .F90 n'etant pas des programmes principaux
    131       for fili in `ls $diri/*.[fF] $diri/*/*.[fF]` ; do
    132          test=` (  head $fili | grep '      PROGRAM' ) `
     136      for fili in `ls $diri/*.[fF]` ; do
     137         # Check if file is a routine or main program
     138         # i.e: look for the "program" keword preceeded by leading spaces
     139         test=` (  head $fili | grep -i '^ *program' ) `
     140         # if it is not a main program, add it to the list
    133141         if [ "$test" = "" ] ; then listlib=$listlib" "$fili ; fi
    134142      done
    135       for fili in `ls $diri/*.[fF]90 $diri/*/*.[fF]90` ; do
    136          test=` (  head $fili | grep 'PROGRAM' ) `
     143      for fili in `ls $diri/*.[fF]90` ; do
     144         # Check if file is a routine or main program
     145         # i.e. look for "program" keyword (with possibly some leading spaces)
     146         test=` (  head $fili | grep -i '^ \{0,\}program' ) `
     147         # if it is not a main program, add it to the list
    137148         if [ "$test" = "" ] ; then listlib=$listlib" "$fili ; fi
    138149      done
    … …  
    140151      echo $listlib >> $logfile
    141152      echo
     153      # topdiri contains main dir name (without trailing "/blabla" for subdirs)
     154      topdiri=${diri%/*}
    142155      echo "#=================================================================="
    143156      echo "# Contenu de la bibliotheque correspondant au Directory "$diri
    … …  
    146159      for trufile in $listlib ; do
    147160         fili=`echo $trufile | awk -F/ ' { print $NF } ' | cut -d. -f1`
    148          echo '$(LIBO)/lib'$diri".a : " '$(LIBO)/lib'$diri".a("$fili".o)"
     161         echo '$(LIBO)/lib'$topdiri".a : " '$(LIBO)/lib'$topdiri".a("$fili".o)"
    149162         echo
    150163      done
    151       echo '.PRECIOUS   : $(LIBO)/lib'$diri'.a'
    152       echo
    153       echo
    154       echo "# Compilation des membres de la bibliotheque lib"$diri".a"
     164      echo '.PRECIOUS   : $(LIBO)/lib'$topdiri'.a'
     165      echo
     166      echo
     167      echo "# Compilation of elements in $diri of library lib"$topdiri".a"
    155168      echo
    156169      for trufile in $listlib ; do
    … …  
    159172                 egrep -i '^ *module ' $trufile > /dev/null 2>&1 && F90=1
    160173                 egrep -i '#include*.inc ' $trufile > /dev/null 2>&1 && F90=1
    161          str1='$(LIBO)/lib'$diri'.a('$fili'.o) : $(LIBF)/'$trufile
     174         str1='$(LIBO)/lib'$topdiri'.a('$fili'.o) : $(LIBF)/'$trufile
    162175         [ "$fili" = "$diri/chem.subs" ] && str1=$str1' $(LIBF)/'$diri/chem.mods.F
    163176
    … …  
    175188            strj=`echo $stri | tr [A-Z] [a-z]`
    176189            str2=""
    177             for dirinc in filtrez bibio dyn3d_common grid dyn3d phydev $diri $diri/*/ ; do
     190            for dirinc in $src_dirs ; do
    178191# Recherche dans l'ordre hierarchique inverse car seule la derniere
    179192# ligne est conservee
    180                if [ $dirinc = phydev ] ; then
    181                    dirstr='$(PHYS)'
    182                    libstr='phy$(PHYS)'
    183                else
     193#               if [ $dirinc = phydev ] ; then
     194#                   dirstr='$(PHYS)'
     195#                   libstr='phy$(PHYS)'
     196#               else
    184197                   dirstr=$dirinc
    185198                   libstr=$dirinc
    186                fi
     199#               fi
    187200               echo dirinc $dirinc >> $logfile
    188201               if [ -f $dirinc/$stri ] ; then
    … …  
    214227         # object from library
    215228         echo ' cd $(LIBO); \'
    216          echo ' $(AR) d $(LIBO)/lib'$diri'.a '$fili'.o ; \'
     229         echo ' $(AR) d $(LIBO)/lib'$topdiri'.a '$fili'.o ; \'
    217230         if [ "$F90" -eq '0' ] ; then
    218231         ## Fixed Form Fortran 77
    … …  
    228241         fi
    229242         # Put generated object in library
    230          echo ' $(AR) r $(LIBO)/lib'$diri'.a '$fili'.o ; $(RM) '$fili'.o ; \'
     243         echo ' $(AR) r $(LIBO)/lib'$topdiri'.a '$fili'.o ; $(RM) '$fili'.o ; \'
    231244         echo
    232245      done

  • LMDZ5/branches/testing/libf/dyn3d/advtrac.F90

    r1999 r2298  
    99  !            M.A Filiberti (04/2002)
    1010  !
    11   USE infotrac, ONLY: nqtot, iadv
     11  USE infotrac, ONLY: nqtot, iadv,nqperes,ok_iso_verif
    1212  USE control_mod, ONLY: iapp_tracvl, day_step
    1313
    … …  
    7979
    8080  IF(iadvtr.EQ.0) THEN
    81      CALL initial0(ijp1llm,pbaruc)
    82      CALL initial0(ijmllm,pbarvc)
     81     pbaruc(:,:)=0
     82     pbarvc(:,:)=0
    8383  ENDIF
    8484
    … …  
    223223     !     Appel des sous programmes d'advection
    224224     !-----------------------------------------------------------
    225      do iq=1,nqtot
     225
     226     if (ok_iso_verif) then
     227           write(*,*) 'advtrac 227'
     228           call check_isotopes_seq(q,ip1jmp1,'advtrac 162')
     229     endif !if (ok_iso_verif) then
     230
     231     do iq=1,nqperes
    226232        !        call clock(t_initial)
    227233        if(iadv(iq) == 0) cycle
    … …  
    230236        !   ----------------------------------------------------------------
    231237        if(iadv(iq).eq.10) THEN
    232            call vlsplt(q(1,1,iq),2.,massem,wg,pbarug,pbarvg,dtvr)
    233 
     238           ! CRisi: on fait passer tout q pour avoir acces aux fils
     239           
     240           !write(*,*) 'advtrac 239: iq,q(1721,19,:)=',iq,q(1721,19,:)     
     241           call vlsplt(q,2.,massem,wg,pbarug,pbarvg,dtvr,iq)
     242           
    234243           !   ----------------------------------------------------------------
    235244           !   Schema "pseudo amont" + test sur humidite specifique
    … …  
    238247        else if(iadv(iq).eq.14) then
    239248           !
    240            CALL vlspltqs( q(1,1,1), 2., massem, wg , &
    241                 pbarug,pbarvg,dtvr,p,pk,teta )
     249           !write(*,*) 'advtrac 248: iq,q(1721,19,:)=',iq,q(1721,19,:)
     250           CALL vlspltqs( q, 2., massem, wg , &
     251                pbarug,pbarvg,dtvr,p,pk,teta,iq)
     252           
    242253           !   ----------------------------------------------------------------
    243254           !   Schema de Frederic Hourdin
    … …  
    388399     end DO
    389400
     401     if (ok_iso_verif) then
     402           write(*,*) 'advtrac 402'
     403           call check_isotopes_seq(q,ip1jmp1,'advtrac 397')
     404     endif !if (ok_iso_verif) then
    390405
    391406     !------------------------------------------------------------------

  • LMDZ5/branches/testing/libf/dyn3d/caladvtrac.F

    r1910 r2298  
    5353      if (planet_type.eq."earth") then
    5454C initialisation
    55         dq(:,:,1:2)=q(:,:,1:2)
     55! CRisi: il faut gérer tous les traceurs si on veut pouvoir faire des
     56! isotopes
     57!        dq(:,:,1:2)=q(:,:,1:2)
     58        dq(:,:,1:nqtot)=q(:,:,1:nqtot)
    5659       
    5760c  test des valeurs minmax
    … …  
    8184           ENDDO
    8285          ENDDO
    83          
    84           CALL qminimum( q, 2, finmasse )
     86
     87          !write(*,*) 'caladvtrac 87'
     88          CALL qminimum( q, nqtot, finmasse )
     89          !write(*,*) 'caladvtrac 89'
    8590
    8691          CALL SCOPY   ( ip1jmp1*llm, masse, 1, finmasse,       1 )
    … …  
    9297          dtvrtrac = iapp_tracvl * dtvr
    9398c
    94            DO iq = 1 , 2
     99           DO iq = 1 , nqtot
    95100            DO l = 1 , llm
    96101             DO ij = 1,ip1jmp1
    … …  
    105110        if (planet_type.eq."earth") then
    106111! Earth-specific treatment for the first 2 tracers (water)
    107           dq(:,:,1:2)=0.
     112          dq(:,:,1:nqtot)=0.
    108113        endif ! of if (planet_type.eq."earth")
    109114      ENDIF ! of IF( iapptrac.EQ.iapp_tracvl )

  • LMDZ5/branches/testing/libf/dyn3d/conf_gcm.F90

    r2258 r2298  
    4646  LOGICAL  fxyhypbb, ysinuss
    4747  INTEGER i
    48   LOGICAL use_filtre_fft
    4948
    5049  !  -------------------------------------------------------------------
    … …  
    8988
    9089  !Config  Key  = prt_level
    91   !Config  Desc = niveau d'impressions de débogage
     90  !Config  Desc = niveau d'impressions de d\'ebogage
    9291  !Config  Def  = 0
    93   !Config  Help = Niveau d'impression pour le débogage
     92  !Config  Help = Niveau d'impression pour le d\'ebogage
    9493  !Config         (0 = minimum d'impression)
    9594  prt_level = 0
    … …  
    733732     dzoomy = 0.2
    734733     CALL getin('dzoomy',dzoomy)
    735      call assert(dzoomy< 1, "conf_gcm: dzoomy must be < 1")
     734     call assert(dzoomy < 1, "conf_gcm: dzoomy must be < 1")
    736735
    737736     !Config  Key  = taux
    … …  
    810809     CALL getin('ok_dyn_ave',ok_dyn_ave)
    811810
    812      !Config  Key  = use_filtre_fft
    813      !Config  Desc = flag d'activation des FFT pour le filtre
    814      !Config  Def  = false
    815      !Config  Help = permet d'activer l'utilisation des FFT pour effectuer
    816      !Config         le filtrage aux poles.
    817      ! Le filtre fft n'est pas implemente dans dyn3d
    818      use_filtre_fft=.FALSE.
    819      CALL getin('use_filtre_fft',use_filtre_fft)
    820 
    821      IF (use_filtre_fft) THEN
    822         write(lunout,*)'STOP !!!'
    823         write(lunout,*)'use_filtre_fft n est pas implemente dans dyn3d'
    824         STOP 1
    825      ENDIF
    826 
    827811     !Config key = ok_strato
    828812     !Config  Desc = activation de la version strato
    829813     !Config  Def  = .FALSE.
    830      !Config  Help = active la version stratosphérique de LMDZ de F. Lott
     814     !Config  Help = active la version stratosph\'erique de LMDZ de F. Lott
    831815
    832816     ok_strato=.FALSE.

  • LMDZ5/branches/testing/libf/dyn3d/dynetat0.F

    r1999 r2298  
    297297           write(lunout,*)"          Il est donc initialise a zero"
    298298           q(:,:,:,iq)=0.
     299
     300           ! CRisi: pour les isotopes, on peut faire init théorique
     301           ! distill de Rayleigh très simplifiée
     302           if (ok_isotopes) then
     303              if ((iso_num(iq).gt.0).and.(zone_num(iq).eq.0)) then
     304                q(:,:,:,iq)=q(:,:,:,iqpere(iq))                         
     305     &                   *tnat(iso_num(iq))                             
     306     &                   *(q(:,:,:,iqpere(iq))/30.e-3)                 
     307     &                   **(alpha_ideal(iso_num(iq))-1)
     308              endif
     309              if ((iso_num(iq).gt.0).and.(zone_num(iq).eq.1)) then
     310                  q(:,:,:,iq)=q(:,:,:,iqiso(iso_indnum(iq),
     311     &                   phase_num(iq)))
     312              endif 
     313           endif !if (ok_isotopes) then
    299314        ELSE
    300315           ierr = NF90_GET_VAR(nid, nvarid, q(:,:,:,iq))

  • LMDZ5/branches/testing/libf/dyn3d/fluxstokenc.F

    r1910 r2298  
    8383
    8484      IF(iadvtr.EQ.0) THEN
    85          CALL initial0(ijp1llm,phic)
    86          CALL initial0(ijp1llm,tetac)
    87          CALL initial0(ijp1llm,pbaruc)
    88          CALL initial0(ijmllm,pbarvc)
     85         phic(:,:)=0
     86         tetac(:,:)=0
     87         pbaruc(:,:)=0
     88         pbarvc(:,:)=0
    8989      ENDIF
    9090

  • LMDZ5/branches/testing/libf/dyn3d/guide_mod.F90

    r2160 r2298  
    8181! Lecture des parametres: 
    8282! ---------------------------------------------
     83    call ini_getparam("nudging_parameters_out.txt")
    8384! Variables guidees
    8485    CALL getpar('guide_u',.true.,guide_u,'guidage de u')
    … …  
    109110    CALL getpar('gamma4',.false.,gamma4,'Zone sans rappel elargie')
    110111    CALL getpar('guide_BL',.true.,guide_BL,'guidage dans C.Lim')
    111    
     112
    112113! Sauvegarde du for�age
    113114    CALL getpar('guide_sav',.false.,guide_sav,'sauvegarde guidage')
    … …  
    147148    CALL getpar('guide_2D',.false.,guide_2D,'fichier guidage lat-P')
    148149
     150    call fin_getparam
     151   
    149152! ---------------------------------------------
    150153! Determination du nombre de niveaux verticaux
    … …  
    156159          rcod=nf90_open('apbp.nc',Nf90_NOWRITe, ncidpl)
    157160          if (rcod.NE.NF_NOERR) THEN
    158              print *,'Guide: probleme -> pas de fichier apbp.nc'
    159              CALL abort_gcm(modname,abort_message,1)
     161             CALL abort_gcm(modname, &
     162                  'Guide: probleme -> pas de fichier apbp.nc',1)
    160163          endif
    161164       endif
    … …  
    165168               rcod=nf90_open('u.nc',Nf90_NOWRITe,ncidpl)
    166169               if (rcod.NE.NF_NOERR) THEN
    167                   print *,'Guide: probleme -> pas de fichier u.nc'
    168                   CALL abort_gcm(modname,abort_message,1)
     170                  CALL abort_gcm(modname, &
     171                       'Guide: probleme -> pas de fichier u.nc',1)
    169172               endif
    170173           endif
    … …  
    173176               rcod=nf90_open('v.nc',nf90_nowrite,ncidpl)
    174177               if (rcod.NE.NF_NOERR) THEN
    175                   print *,'Guide: probleme -> pas de fichier v.nc'
    176                   CALL abort_gcm(modname,abort_message,1)
     178                  CALL abort_gcm(modname, &
     179                       'Guide: probleme -> pas de fichier v.nc',1)
    177180               endif
    178181           endif
    … …  
    181184               rcod=nf90_open('T.nc',nf90_nowrite,ncidpl)
    182185               if (rcod.NE.NF_NOERR) THEN
    183                   print *,'Guide: probleme -> pas de fichier T.nc'
    184                   CALL abort_gcm(modname,abort_message,1)
     186                  CALL abort_gcm(modname, &
     187                       'Guide: probleme -> pas de fichier T.nc',1)
    185188               endif
    186189           endif
    … …  
    189192               rcod=nf90_open('hur.nc',nf90_nowrite, ncidpl)
    190193               if (rcod.NE.NF_NOERR) THEN
    191                   print *,'Guide: probleme -> pas de fichier hur.nc'
    192                   CALL abort_gcm(modname,abort_message,1)
     194                  CALL abort_gcm(modname, &
     195                       'Guide: probleme -> pas de fichier hur.nc',1)
    193196               endif
    194197           endif
    … …  
    198201    IF (error.NE.NF_NOERR) error=NF_INQ_DIMID(ncidpl,'PRESSURE',rid)
    199202    IF (error.NE.NF_NOERR) THEN
    200         print *,'Guide: probleme lecture niveaux pression'
    201         CALL abort_gcm(modname,abort_message,1)
     203        CALL abort_gcm(modname,'Guide: probleme lecture niveaux pression',1)
    202204    ENDIF
    203205    error=NF_INQ_DIMLEN(ncidpl,rid,nlevnc)

  • LMDZ5/branches/testing/libf/dyn3d/iniacademic.F90

    r2160 r2298  
    55
    66  USE filtreg_mod, ONLY: inifilr
    7   USE infotrac, ONLY : nqtot
     7  USE infotrac
    88  USE control_mod, ONLY: day_step,planet_type
    99#ifdef CPP_IOIPSL
    … …  
    262262              if (i == 2) q(:,:,i)=1.e-15
    263263              if (i.gt.2) q(:,:,i)=0.
     264
     265              ! CRisi: init des isotopes
     266              ! distill de Rayleigh très simplifiée
     267              if (ok_isotopes) then
     268                if ((iso_num(i).gt.0).and.(zone_num(i).eq.0)) then         
     269                   q(:,:,i)=q(:,:,iqpere(i))             &
     270      &                  *tnat(iso_num(i))               &
     271      &                  *(q(:,:,iqpere(i))/30.e-3)      &
     272      &                  **(alpha_ideal(iso_num(i))-1)
     273                endif               
     274                if ((iso_num(i).gt.0).and.(zone_num(i).eq.1)) then
     275                  q(:,:,i)=q(:,:,iqiso(iso_indnum(i),phase_num(i)))
     276                endif
     277              endif !if (ok_isotopes) then
     278
    264279           enddo
    265280        else
    266281           q(:,:,:)=0
    267282        endif ! of if (planet_type=="earth")
     283
     284        if (ok_iso_verif) then
     285           call check_isotopes_seq(q,1,ip1jmp1,'iniacademic_loc')
     286        endif !if (ok_iso_verif) then
    268287
    269288        ! add random perturbation to temperature

  • LMDZ5/branches/testing/libf/dyn3d/leapfrog.F

    r2258 r2298  
    1111      use IOIPSL
    1212#endif
    13       USE infotrac, ONLY: nqtot
     13      USE infotrac, ONLY: nqtot,ok_iso_verif
    1414      USE guide_mod, ONLY : guide_main
    1515      USE write_field, ONLY: writefield
    … …  
    235235      jH_cur = jH_cur - int(jH_cur)
    236236
     237        if (ok_iso_verif) then
     238           call check_isotopes_seq(q,ip1jmp1,'leapfrog 321')
     239        endif !if (ok_iso_verif) then
    237240
    238241#ifdef CPP_IOIPSL
    … …  
    265268!      CALL SCOPY   ( ijp1llm,   masse, 1, finvmaold,     1 )
    266269!      CALL filtreg ( finvmaold ,jjp1, llm, -2,2, .TRUE., 1 )
     270
     271        if (ok_iso_verif) then
     272           call check_isotopes_seq(q,ip1jmp1,'leapfrog 400')
     273        endif !if (ok_iso_verif) then
    267274
    268275   2  CONTINUE ! Matsuno backward or leapfrog step begins here
    … …  
    305312      endif
    306313
     314
     315        if (ok_iso_verif) then
     316           call check_isotopes_seq(q,ip1jmp1,'leapfrog 589')
     317        endif !if (ok_iso_verif) then
     318
    307319c-----------------------------------------------------------------------
    308320c   calcul des tendances dynamiques:
    … …  
    321333c   calcul des tendances advection des traceurs (dont l'humidite)
    322334c   -------------------------------------------------------------
     335
     336        if (ok_iso_verif) then
     337           call check_isotopes_seq(q,ip1jmp1,
     338     &           'leapfrog 686: avant caladvtrac')
     339        endif !if (ok_iso_verif) then
    323340
    324341      IF( forward. OR . leapf )  THEN
    … …  
    327344     *        p, masse, dq,  teta,
    328345     .        flxw, pk)
     346          !write(*,*) 'caladvtrac 346'
     347
    329348         
    330349         IF (offline) THEN
    … …  
    346365c   ----------------------------------
    347366
    348 
    349        CALL integrd ( 2,vcovm1,ucovm1,tetam1,psm1,massem1 ,
     367        if (ok_iso_verif) then
     368           write(*,*) 'leapfrog 720'
     369           call check_isotopes_seq(q,ip1jmp1,'leapfrog 756')
     370        endif !if (ok_iso_verif) then
     371       
     372       CALL integrd ( nqtot,vcovm1,ucovm1,tetam1,psm1,massem1 ,
    350373     $         dv,du,dteta,dq,dp,vcov,ucov,teta,q,ps,masse,phis )
    351374!     $              finvmaold                                    )
    352375
     376       if (ok_iso_verif) then
     377          write(*,*) 'leapfrog 724'
     378           call check_isotopes_seq(q,ip1jmp1,'leapfrog 762')
     379        endif !if (ok_iso_verif) then
    353380
    354381c .P.Le Van (26/04/94  ajout de  finvpold dans l'appel d'integrd)
    … …  
    437464#endif
    438465! #endif of #ifdef CPP_IOIPSL
     466#ifdef CPP_PHYS
    439467         CALL calfis( lafin , jD_cur, jH_cur,
    440468     $               ucov,vcov,teta,q,masse,ps,p,pk,phis,phi ,
    441469     $               du,dv,dteta,dq,
    442470     $               flxw,dufi,dvfi,dtetafi,dqfi,dpfi  )
    443 
     471#endif
    444472c      ajout des tendances physiques:
    445473c      ------------------------------
    … …  
    515543        CALL massdair(p,masse)
    516544
     545        if (ok_iso_verif) then
     546           call check_isotopes_seq(q,ip1jmp1,'leapfrog 1196')
     547        endif !if (ok_iso_verif) then
    517548
    518549c-----------------------------------------------------------------------
    … …  
    599630c   preparation du pas d'integration suivant  ......
    600631
     632        if (ok_iso_verif) then
     633           call check_isotopes_seq(q,ip1jmp1,'leapfrog 1509')
     634        endif !if (ok_iso_verif) then
     635
    601636      IF ( .NOT.purmats ) THEN
    602637c       ........................................................
    … …  
    656691            ENDIF ! of IF((MOD(itau,iperiod).EQ.0).OR.(itau.EQ.itaufin))
    657692
     693        if (ok_iso_verif) then
     694           call check_isotopes_seq(q,ip1jmp1,'leapfrog 1584')
     695        endif !if (ok_iso_verif) then
     696
    658697c-----------------------------------------------------------------------
    659698c   ecriture de la bande histoire:
    … …  
    734773      ELSE ! of IF (.not.purmats)
    735774
     775        if (ok_iso_verif) then
     776           call check_isotopes_seq(q,ip1jmp1,'leapfrog 1664')
     777        endif !if (ok_iso_verif) then
     778
    736779c       ........................................................
    737780c       ..............       schema  matsuno        ...............
    … …  
    756799
    757800            ELSE ! of IF(forward) i.e. backward step
     801 
     802        if (ok_iso_verif) then
     803           call check_isotopes_seq(q,ip1jmp1,'leapfrog 1698')
     804        endif !if (ok_iso_verif) then 
    758805
    759806              IF(MOD(itau,iperiod).EQ.0 .OR. itau.EQ.itaufin) THEN

  • LMDZ5/branches/testing/libf/dyn3d/qminimum.F

    r1910 r2298  
    22! $Header$
    33!
    4       SUBROUTINE qminimum( q,nq,deltap )
     4      SUBROUTINE qminimum( q,nqtot,deltap )
    55
     6      USE infotrac, ONLY: ok_isotopes,ntraciso,iqiso,ok_iso_verif
    67      IMPLICIT none
    78c
    … …  
    1314#include "comvert.h"
    1415c
    15       INTEGER nq
    16       REAL q(ip1jmp1,llm,nq), deltap(ip1jmp1,llm)
     16      INTEGER nqtot
     17      REAL q(ip1jmp1,llm,nqtot), deltap(ip1jmp1,llm)
    1718c
    1819      INTEGER iq_vap, iq_liq
    … …  
    3031      INTEGER i, k, iq
    3132      REAL zx_defau, zx_abc, zx_pump(ip1jmp1), pompe
     33
     34      real zx_defau_diag(ip1jmp1,llm,2)
     35      real q_follow(ip1jmp1,llm,2)
    3236c
    3337      REAL SSUM
    … …  
    3640      SAVE imprim
    3741      DATA imprim /0/
     42      !INTEGER ijb,ije
     43      !INTEGER Index_pump(ij_end-ij_begin+1)
     44      !INTEGER nb_pump
     45      INTEGER ixt
    3846c
    3947c Quand l'eau liquide est trop petite (ou negative), on prend
    … …  
    4149c (sans changer la temperature !)
    4250c
     51
     52        if (ok_iso_verif) then
     53           call check_isotopes_seq(q,ip1jmp1,'qminimum 52')   
     54        endif !if (ok_iso_verif) then     
     55
     56      zx_defau_diag(:,:,:)=0.0
     57      q_follow(:,:,1:2)=q(:,:,1:2) 
    4358      DO 1000 k = 1, llm
    4459        DO 1040 i = 1, ip1jmp1
    4560          if (seuil_liq - q(i,k,iq_liq) .gt. 0.d0 ) then
     61
     62              if (ok_isotopes) then
     63                 zx_defau_diag(i,k,iq_liq)=AMAX1
     64     :               ( seuil_liq - q(i,k,iq_liq), 0.0 )
     65              endif !if (ok_isotopes) then
     66
    4667             q(i,k,iq_vap) = q(i,k,iq_vap) + q(i,k,iq_liq) - seuil_liq
    4768             q(i,k,iq_liq) = seuil_liq
    … …  
    5980        DO i = 1, ip1jmp1
    6081          if ( seuil_vap - q(i,k,iq) .gt. 0.d0 ) then
     82
     83            if (ok_isotopes) then
     84              zx_defau_diag(i,k,iq)=AMAX1( seuil_vap - q(i,k,iq), 0.0 )
     85            endif !if (ok_isotopes) then
     86
    6187            q(i,k-1,iq) =  q(i,k-1,iq) - ( seuil_vap - q(i,k,iq) ) *
    6288     &                     deltap(i,k) / deltap(i,k-1)
    … …  
    83109         ENDDO
    84110      ENDIF
     111
     112      !write(*,*) 'qminimum 128'
     113      if (ok_isotopes) then
     114      ! CRisi: traiter de même les traceurs d'eau
     115      ! Mais il faut les prendre à l'envers pour essayer de conserver la
     116      ! masse.
     117      ! 1) pompage dans le sol 
     118      ! On suppose que ce pompage se fait sans isotopes -> on ne modifie
     119      ! rien ici et on croise les doigts pour que ça ne soit pas trop
     120      ! génant
     121      DO i = 1,ip1jmp1
     122        if (zx_pump(i).gt.0.0) then
     123          q_follow(i,1,iq_vap)=q_follow(i,1,iq_vap)+zx_pump(i)
     124        endif !if (zx_pump(i).gt.0.0) then
     125      enddo !DO i = 1,ip1jmp1
     126
     127      ! 2) transfert de vap vers les couches plus hautes
     128      !write(*,*) 'qminimum 139'
     129      do k=2,llm
     130        DO i = 1,ip1jmp1
     131          if (zx_defau_diag(i,k,iq_vap).gt.0.0) then             
     132              ! on ajoute la vapeur en k             
     133              do ixt=1,ntraciso
     134               q(i,k,iqiso(ixt,iq_vap))=q(i,k,iqiso(ixt,iq_vap))
     135     :              +zx_defau_diag(i,k,iq_vap)
     136     :              *q(i,k-1,iqiso(ixt,iq_vap))/q_follow(i,k-1,iq_vap)
     137               
     138              ! et on la retranche en k-1
     139               q(i,k-1,iqiso(ixt,iq_vap))=q(i,k-1,iqiso(ixt,iq_vap))
     140     :              -zx_defau_diag(i,k,iq_vap)
     141     :              *deltap(i,k)/deltap(i,k-1)
     142     :              *q(i,k-1,iqiso(ixt,iq_vap))/q_follow(i,k-1,iq_vap)
     143
     144              enddo !do ixt=1,niso
     145              q_follow(i,k,iq_vap)=   q_follow(i,k,iq_vap)
     146     :               +zx_defau_diag(i,k,iq_vap)
     147              q_follow(i,k-1,iq_vap)=   q_follow(i,k-1,iq_vap)
     148     :               -zx_defau_diag(i,k,iq_vap)
     149     :              *deltap(i,k)/deltap(i,k-1)
     150          endif !if (zx_defau_diag(i,k,iq_vap).gt.0.0) then
     151        enddo !DO i = 1, ip1jmp1       
     152       enddo !do k=2,llm
     153
     154        if (ok_iso_verif) then     
     155           call check_isotopes_seq(q,ip1jmp1,'qminimum 168')
     156        endif !if (ok_iso_verif) then
     157       
     158     
     159        ! 3) transfert d'eau de la vapeur au liquide
     160        !write(*,*) 'qminimum 164'
     161        do k=1,llm
     162        DO i = 1,ip1jmp1
     163          if (zx_defau_diag(i,k,iq_liq).gt.0.0) then
     164
     165              ! on ajoute eau liquide en k en k             
     166              do ixt=1,ntraciso
     167               q(i,k,iqiso(ixt,iq_liq))=q(i,k,iqiso(ixt,iq_liq))
     168     :              +zx_defau_diag(i,k,iq_liq)
     169     :              *q(i,k,iqiso(ixt,iq_vap))/q_follow(i,k,iq_vap)
     170              ! et on la retranche à la vapeur en k
     171               q(i,k,iqiso(ixt,iq_vap))=q(i,k,iqiso(ixt,iq_vap))
     172     :              -zx_defau_diag(i,k,iq_liq)
     173     :              *q(i,k,iqiso(ixt,iq_vap))/q_follow(i,k,iq_vap)   
     174              enddo !do ixt=1,niso
     175              q_follow(i,k,iq_liq)=   q_follow(i,k,iq_liq)
     176     :               +zx_defau_diag(i,k,iq_liq)
     177              q_follow(i,k,iq_vap)=   q_follow(i,k,iq_vap)
     178     :               -zx_defau_diag(i,k,iq_liq)
     179          endif !if (zx_defau_diag(i,k,iq_vap).gt.0.0) then
     180        enddo !DO i = 1, ip1jmp1
     181       enddo !do k=2,llm 
     182
     183        if (ok_iso_verif) then
     184           call check_isotopes_seq(q,ip1jmp1,'qminimum 197')
     185        endif !if (ok_iso_verif) then
     186
     187      endif !if (ok_isotopes) then
     188      !write(*,*) 'qminimum 188'
     189     
    85190c
    86191      RETURN

  • LMDZ5/branches/testing/libf/dyn3d/vlsplt.F

    r1910 r2298  
    33c
    44
    5       SUBROUTINE vlsplt(q,pente_max,masse,w,pbaru,pbarv,pdt)
     5      SUBROUTINE vlsplt(q,pente_max,masse,w,pbaru,pbarv,pdt,iq)
     6      USE infotrac, ONLY: nqtot,nqdesc,iqfils
    67c
    78c     Auteurs:   P.Le Van, F.Hourdin, F.Forget
    … …  
    3233c      REAL masse(iip1,jjp1,llm),pente_max
    3334      REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm)
    34       REAL q(ip1jmp1,llm)
     35      REAL q(ip1jmp1,llm,nqtot)
    3536c      REAL q(iip1,jjp1,llm)
    3637      REAL w(ip1jmp1,llm),pdt
     38      INTEGER iq ! CRisi
    3739c
    3840c      Local
    … …  
    4244      INTEGER ijlqmin,iqmin,jqmin,lqmin
    4345c
    44       REAL zm(ip1jmp1,llm),newmasse
     46      REAL zm(ip1jmp1,llm,nqtot),newmasse
    4547      REAL mu(ip1jmp1,llm)
    4648      REAL mv(ip1jm,llm)
    4749      REAL mw(ip1jmp1,llm+1)
    48       REAL zq(ip1jmp1,llm),zz
     50      REAL zq(ip1jmp1,llm,nqtot),zz
    4951      REAL dqx(ip1jmp1,llm),dqy(ip1jmp1,llm),dqz(ip1jmp1,llm)
    5052      REAL second,temps0,temps1,temps2,temps3
    … …  
    5557      SAVE temps1,temps2,temps3
    5658      INTEGER iminn,imaxx
     59      INTEGER ifils,iq2 ! CRisi
    5760
    5861      REAL qmin,qmax
    … …  
    7982         mw(ij,llm+1)=0.
    8083      ENDDO
    81      
    82       CALL SCOPY(ijp1llm,q,1,zq,1)
    83       CALL SCOPY(ijp1llm,masse,1,zm,1)
     84           
     85      CALL SCOPY(ijp1llm,q(1,1,iq),1,zq(1,1,iq),1)
     86      CALL SCOPY(ijp1llm,masse,1,zm(1,1,iq),1)
     87       
     88      if (nqdesc(iq).gt.0) then 
     89        do ifils=1,nqdesc(iq)
     90          iq2=iqfils(ifils,iq)
     91          CALL SCOPY(ijp1llm,q(1,1,iq2),1,zq(1,1,iq2),1)
     92        enddo 
     93      endif !if (nqfils(iq).gt.0) then
    8494
    8595cprint*,'Entree vlx1'
    8696c       call minmaxq(zq,qmin,qmax,'avant vlx     ')
    87       call vlx(zq,pente_max,zm,mu)
     97      call vlx(zq,pente_max,zm,mu,iq)
    8898cprint*,'Sortie vlx1'
    8999c       call minmaxq(zq,qmin,qmax,'apres vlx1    ')
    90100
    91101c print*,'Entree vly1'
    92       call vly(zq,pente_max,zm,mv)
     102
     103      call vly(zq,pente_max,zm,mv,iq)
    93104c       call minmaxq(zq,qmin,qmax,'apres vly1     ')
    94105cprint*,'Sortie vly1'
    95       call vlz(zq,pente_max,zm,mw)
     106      call vlz(zq,pente_max,zm,mw,iq)
    96107c       call minmaxq(zq,qmin,qmax,'apres vlz     ')
    97108
    98109
    99       call vly(zq,pente_max,zm,mv)
     110      call vly(zq,pente_max,zm,mv,iq)
    100111c       call minmaxq(zq,qmin,qmax,'apres vly     ')
    101112
    102113
    103       call vlx(zq,pente_max,zm,mu)
     114      call vlx(zq,pente_max,zm,mu,iq)
    104115c       call minmaxq(zq,qmin,qmax,'apres vlx2    ')
    105116       
    … …  
    107118      DO l=1,llm
    108119         DO ij=1,ip1jmp1
    109            q(ij,l)=zq(ij,l)
     120           q(ij,l,iq)=zq(ij,l,iq)
    110121         ENDDO
    111122         DO ij=1,ip1jm+1,iip1
    112             q(ij+iim,l)=q(ij,l)
    113          ENDDO
    114       ENDDO
     123            q(ij+iim,l,iq)=q(ij,l,iq)
     124         ENDDO
     125      ENDDO
     126      ! CRisi: aussi pour les fils
     127      if (nqdesc(iq).gt.0) then
     128      do ifils=1,nqdesc(iq)
     129        iq2=iqfils(ifils,iq)
     130        DO l=1,llm
     131         DO ij=1,ip1jmp1
     132           q(ij,l,iq2)=zq(ij,l,iq2)
     133         ENDDO
     134         DO ij=1,ip1jm+1,iip1
     135            q(ij+iim,l,iq2)=q(ij,l,iq2)
     136         ENDDO
     137        ENDDO
     138      enddo !do ifils=1,nqdesc(iq)   
     139      endif ! if (nqdesc(iq).gt.0) then   
    115140
    116141      RETURN
    117142      END
    118       SUBROUTINE vlx(q,pente_max,masse,u_m)
     143      RECURSIVE SUBROUTINE vlx(q,pente_max,masse,u_m,iq)
     144      USE infotrac, ONLY : nqtot,nqfils,nqdesc,iqfils ! CRisi
    119145
    120146c     Auteurs:   P.Le Van, F.Hourdin, F.Forget
    … …  
    139165c   Arguments:
    140166c   ----------
    141       REAL masse(ip1jmp1,llm),pente_max
     167      REAL masse(ip1jmp1,llm,nqtot),pente_max
    142168      REAL u_m( ip1jmp1,llm ),pbarv( iip1,jjm,llm)
    143       REAL q(ip1jmp1,llm)
     169      REAL q(ip1jmp1,llm,nqtot)
    144170      REAL w(ip1jmp1,llm)
     171      INTEGER iq ! CRisi
    145172c
    146173c      Local
    … …  
    155182      REAL adxqu(ip1jmp1),dxqmax(ip1jmp1,llm)
    156183      REAL u_mq(ip1jmp1,llm)
     184
     185      ! CRisi
     186      REAL masseq(ip1jmp1,llm,nqtot),Ratio(ip1jmp1,llm,nqtot)
     187      INTEGER ifils,iq2 ! CRisi
    157188
    158189      Logical extremum,first,testcpu
    … …  
    188219         DO l = 1, llm
    189220            DO ij=iip2,ip1jm-1
    190                dxqu(ij)=q(ij+1,l)-q(ij,l)
     221               dxqu(ij)=q(ij+1,l,iq)-q(ij,l,iq)
    191222c              IF(u_m(ij,l).lt.0.) stop'limx n admet pas les U<0'
    192 c              sigu(ij)=u_m(ij,l)/masse(ij,l)
     223c              sigu(ij)=u_m(ij,l)/masse(ij,l,iq)
    193224            ENDDO
    194225            DO ij=iip1+iip1,ip1jm,iip1
    … …  
    243274         DO l = 1, llm
    244275            DO ij=iip2,ip1jm-1
    245                dxqu(ij)=q(ij+1,l)-q(ij,l)
     276               dxqu(ij)=q(ij+1,l,iq)-q(ij,l,iq)
    246277            ENDDO
    247278            DO ij=iip1+iip1,ip1jm,iip1
    … …  
    285316      DO l=1,llm
    286317       DO ij=iip2,ip1jm-1
    287           zdum(ij,l)=cvmgp(1.-u_m(ij,l)/masse(ij,l),
    288      ,                     1.+u_m(ij,l)/masse(ij+1,l),
     318          zdum(ij,l)=cvmgp(1.-u_m(ij,l)/masse(ij,l,iq),
     319     ,                     1.+u_m(ij,l)/masse(ij+1,l,iq),
    289320     ,                     u_m(ij,l))
    290321          zdum(ij,l)=0.5*zdum(ij,l)
    291322          u_mq(ij,l)=cvmgp(
    292      ,                q(ij,l)+zdum(ij,l)*dxq(ij,l),
    293      ,                q(ij+1,l)-zdum(ij,l)*dxq(ij+1,l),
     323     ,                q(ij,l,iq)+zdum(ij,l)*dxq(ij,l),
     324     ,                q(ij+1,l,iq)-zdum(ij,l)*dxq(ij+1,l),
    294325     ,                u_m(ij,l))
    295326          u_mq(ij,l)=u_m(ij,l)*u_mq(ij,l)
    … …  
    303334      DO l=1,llm
    304335       DO ij=iip2,ip1jm-1
    305 c       print*,'masse(',ij,')=',masse(ij,l)
     336c       print*,'masse(',ij,')=',masse(ij,l,iq)
    306337          IF (u_m(ij,l).gt.0.) THEN
    307              zdum(ij,l)=1.-u_m(ij,l)/masse(ij,l)
    308              u_mq(ij,l)=u_m(ij,l)*(q(ij,l)+0.5*zdum(ij,l)*dxq(ij,l))
     338             zdum(ij,l)=1.-u_m(ij,l)/masse(ij,l,iq)
     339             u_mq(ij,l)=u_m(ij,l)*(q(ij,l,iq)+0.5*zdum(ij,l)*dxq(ij,l))
    309340          ELSE
    310              zdum(ij,l)=1.+u_m(ij,l)/masse(ij+1,l)
    311              u_mq(ij,l)=u_m(ij,l)*(q(ij+1,l)-0.5*zdum(ij,l)*dxq(ij+1,l))
     341             zdum(ij,l)=1.+u_m(ij,l)/masse(ij+1,l,iq)
     342             u_mq(ij,l)=u_m(ij,l)*(q(ij+1,l,iq)
     343     &           -0.5*zdum(ij,l)*dxq(ij+1,l))
    312344          ENDIF
    313345       ENDDO
    … …  
    379411                     i=ijq-(j-1)*iip1
    380412c   accumulation pour les mailles completements advectees
    381                      do while(zu_m.gt.masse(ijq,l))
    382                         u_mq(ij,l)=u_mq(ij,l)+q(ijq,l)*masse(ijq,l)
    383                         zu_m=zu_m-masse(ijq,l)
     413                     do while(zu_m.gt.masse(ijq,l,iq))
     414                        u_mq(ij,l)=u_mq(ij,l)+q(ijq,l,iq)
     415     &                          *masse(ijq,l,iq)
     416                        zu_m=zu_m-masse(ijq,l,iq)
    384417                        i=mod(i-2+iim,iim)+1
    385418                        ijq=(j-1)*iip1+i
    … …  
    387420c   ajout de la maille non completement advectee
    388421                     u_mq(ij,l)=u_mq(ij,l)+zu_m*
    389      &               (q(ijq,l)+0.5*(1.-zu_m/masse(ijq,l))*dxq(ijq,l))
     422     &                  (q(ijq,l,iq)+0.5*(1.-zu_m/masse(ijq,l,iq))
     423     &                  *dxq(ijq,l))
    390424                  ELSE
    391425                     ijq=ij+1
    392426                     i=ijq-(j-1)*iip1
    393427c   accumulation pour les mailles completements advectees
    394                      do while(-zu_m.gt.masse(ijq,l))
    395                         u_mq(ij,l)=u_mq(ij,l)-q(ijq,l)*masse(ijq,l)
    396                         zu_m=zu_m+masse(ijq,l)
     428                     do while(-zu_m.gt.masse(ijq,l,iq))
     429                        u_mq(ij,l)=u_mq(ij,l)-q(ijq,l,iq)
     430     &                          *masse(ijq,l,iq)
     431                        zu_m=zu_m+masse(ijq,l,iq)
    397432                        i=mod(i,iim)+1
    398433                        ijq=(j-1)*iip1+i
    399434                     ENDDO
    400435c   ajout de la maille non completement advectee
    401                      u_mq(ij,l)=u_mq(ij,l)+zu_m*(q(ijq,l)-
    402      &               0.5*(1.+zu_m/masse(ijq,l))*dxq(ijq,l))
     436                     u_mq(ij,l)=u_mq(ij,l)+zu_m*(q(ijq,l,iq)-
     437     &               0.5*(1.+zu_m/masse(ijq,l,iq))*dxq(ijq,l))
    403438                  ENDIF
    404439               ENDDO
    … …  
    417452      ENDDO
    418453
     454! CRisi: appel récursif de l'advection sur les fils.
     455! Il faut faire ça avant d'avoir mis à jour q et masse
     456      !write(*,*) 'vlsplt 326: iq,nqfils(iq)=',iq,nqfils(iq)
     457     
     458      if (nqdesc(iq).gt.0) then 
     459       do ifils=1,nqdesc(iq)
     460         iq2=iqfils(ifils,iq)
     461         DO l=1,llm
     462          DO ij=iip2,ip1jm
     463           ! On a besoin de q et masse seulement entre iip2 et ip1jm
     464           masseq(ij,l,iq2)=masse(ij,l,iq)*q(ij,l,iq)
     465           Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq)
     466          enddo   
     467         enddo
     468        enddo !do ifils=1,nqdesc(iq)
     469        do ifils=1,nqfils(iq)
     470         iq2=iqfils(ifils,iq)
     471         call vlx(Ratio,pente_max,masseq,u_mq,iq2)
     472        enddo !do ifils=1,nqfils(iq)
     473      endif !if (nqfils(iq).gt.0) then
     474! end CRisi
     475
    419476
    420477c   calcul des tENDances
    … …  
    422479      DO l=1,llm
    423480         DO ij=iip2+1,ip1jm
    424             new_m=masse(ij,l)+u_m(ij-1,l)-u_m(ij,l)
    425             q(ij,l)=(q(ij,l)*masse(ij,l)+
     481            new_m=masse(ij,l,iq)+u_m(ij-1,l)-u_m(ij,l)
     482            q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+
    426483     &      u_mq(ij-1,l)-u_mq(ij,l))
    427484     &      /new_m
    428             masse(ij,l)=new_m
     485            masse(ij,l,iq)=new_m
    429486         ENDDO
    430487c   ModIF Fred 22 03 96 correction d'un bug (les scopy ci-dessous)
    431488         DO ij=iip1+iip1,ip1jm,iip1
    432             q(ij-iim,l)=q(ij,l)
    433             masse(ij-iim,l)=masse(ij,l)
    434          ENDDO
    435       ENDDO
     489            q(ij-iim,l,iq)=q(ij,l,iq)
     490            masse(ij-iim,l,iq)=masse(ij,l,iq)
     491         ENDDO
     492      ENDDO
     493
     494      ! retablir les fils en rapport de melange par rapport a l'air:
     495      ! On calcule q entre iip2+1,ip1jm -> on fait pareil pour ratio
     496      ! puis on boucle en longitude
     497      if (nqdesc(iq).gt.0) then 
     498       do ifils=1,nqdesc(iq)
     499         iq2=iqfils(ifils,iq) 
     500         DO l=1,llm
     501          DO ij=iip2+1,ip1jm
     502            q(ij,l,iq2)=q(ij,l,iq)*Ratio(ij,l,iq2)           
     503          enddo
     504          DO ij=iip1+iip1,ip1jm,iip1
     505             q(ij-iim,l,iq2)=q(ij,l,iq2)
     506          enddo ! DO ij=ijb+iip1-1,ije,iip1
     507         enddo !DO l=1,llm
     508        enddo !do ifils=1,nqdesc(iq)
     509      endif !if (nqfils(iq).gt.0) then
     510
    436511c     CALL SCOPY((jjm-1)*llm,q(iip1+iip1,1),iip1,q(iip2,1),iip1)
    437512c     CALL SCOPY((jjm-1)*llm,masse(iip1+iip1,1),iip1,masse(iip2,1),iip1)
    … …  
    440515      RETURN
    441516      END
    442       SUBROUTINE vly(q,pente_max,masse,masse_adv_v)
     517      RECURSIVE SUBROUTINE vly(q,pente_max,masse,masse_adv_v,iq)
     518      USE infotrac, ONLY : nqtot,nqfils,nqdesc,iqfils ! CRisi
    443519c
    444520c     Auteurs:   P.Le Van, F.Hourdin, F.Forget
    … …  
    464540c   Arguments:
    465541c   ----------
    466       REAL masse(ip1jmp1,llm),pente_max
     542      REAL masse(ip1jmp1,llm,nqtot),pente_max
    467543      REAL masse_adv_v( ip1jm,llm)
    468       REAL q(ip1jmp1,llm), dq( ip1jmp1,llm)
     544      REAL q(ip1jmp1,llm,nqtot), dq( ip1jmp1,llm)
     545      INTEGER iq ! CRisi
    469546c
    470547c      Local
    … …  
    491568      SAVE sinlon,coslon,sinlondlon,coslondlon
    492569      SAVE airej2,airejjm
     570
     571      REAL masseq(ip1jmp1,llm,nqtot),Ratio(ip1jmp1,llm,nqtot) ! CRisi
     572      INTEGER ifils,iq2 ! CRisi
     573
    493574c
    494575c
    … …  
    497578      DATA first,testcpu/.true.,.false./
    498579      DATA temps0,temps1,temps2,temps3,temps4,temps5/0.,0.,0.,0.,0.,0./
     580
     581      !write(*,*) 'vly 578: entree, iq=',iq
    499582
    500583      IF(first) THEN
    … …  
    529612
    530613      DO i = 1, iim
    531       airescb(i) = aire(i+ iip1) * q(i+ iip1,l)
    532       airesch(i) = aire(i+ ip1jm- iip1) * q(i+ ip1jm- iip1,l)
     614      airescb(i) = aire(i+ iip1) * q(i+ iip1,l,iq)
     615      airesch(i) = aire(i+ ip1jm- iip1) * q(i+ ip1jm- iip1,l,iq)
    533616      ENDDO
    534617      qpns   = SSUM( iim,  airescb ,1 ) / airej2
    … …  
    538621
    539622      DO ij=1,ip1jm
    540          dyqv(ij)=q(ij,l)-q(ij+iip1,l)
     623         dyqv(ij)=q(ij,l,iq)-q(ij+iip1,l,iq)
    541624         adyqv(ij)=abs(dyqv(ij))
    542625      ENDDO
    … …  
    553636
    554637      DO ij=1,iip1
    555          dyq(ij,l)=qpns-q(ij+iip1,l)
    556          dyq(ip1jm+ij,l)=q(ip1jm+ij-iip1,l)-qpsn
     638         dyq(ij,l)=qpns-q(ij+iip1,l,iq)
     639         dyq(ip1jm+ij,l)=q(ip1jm+ij-iip1,l,iq)-qpsn
    557640      ENDDO
    558641
    … …  
    675758      ENDDO
    676759
     760      !write(*,*) 'vly 756'
    677761      DO l=1,llm
    678762       DO ij=1,ip1jm
    679763          IF(masse_adv_v(ij,l).gt.0) THEN
    680               qbyv(ij,l)=q(ij+iip1,l)+dyq(ij+iip1,l)*
    681      ,                   0.5*(1.-masse_adv_v(ij,l)/masse(ij+iip1,l))
     764              qbyv(ij,l)=q(ij+iip1,l,iq)+dyq(ij+iip1,l)*
     765     ,                   0.5*(1.-masse_adv_v(ij,l)
     766     ,                   /masse(ij+iip1,l,iq))
    682767          ELSE
    683               qbyv(ij,l)=q(ij,l)-dyq(ij,l)*
    684      ,                   0.5*(1.+masse_adv_v(ij,l)/masse(ij,l))
     768              qbyv(ij,l)=q(ij,l,iq)-dyq(ij,l)*
     769     ,                   0.5*(1.+masse_adv_v(ij,l)
     770     ,                   /masse(ij,l,iq))
    685771          ENDIF
    686772          qbyv(ij,l)=masse_adv_v(ij,l)*qbyv(ij,l)
    … …  
    688774      ENDDO
    689775
     776! CRisi: appel récursif de l'advection sur les fils.
     777! Il faut faire ça avant d'avoir mis à jour q et masse
     778      !write(*,*) 'vly 689: iq,nqfils(iq)=',iq,nqfils(iq)
     779   
     780      if (nqfils(iq).gt.0) then 
     781       do ifils=1,nqdesc(iq)
     782         iq2=iqfils(ifils,iq)
     783         DO l=1,llm
     784         DO ij=1,ip1jmp1
     785           ! attention, chaque fils doit avoir son masseq, sinon, le 1er
     786           ! fils ecrase le masseq de ses freres.
     787           masseq(ij,l,iq2)=masse(ij,l,iq)*q(ij,l,iq)
     788           Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq)     
     789          enddo   
     790         enddo
     791        enddo !do ifils=1,nqdesc(iq)
     792
     793        do ifils=1,nqfils(iq)
     794         iq2=iqfils(ifils,iq)
     795         call vly(Ratio,pente_max,masseq,qbyv,iq2)
     796        enddo !do ifils=1,nqfils(iq)
     797      endif !if (nqfils(iq).gt.0) then
    690798
    691799      DO l=1,llm
    692800         DO ij=iip2,ip1jm
    693             newmasse=masse(ij,l)
     801            newmasse=masse(ij,l,iq)
    694802     &      +masse_adv_v(ij,l)-masse_adv_v(ij-iip1,l)
    695             q(ij,l)=(q(ij,l)*masse(ij,l)+qbyv(ij,l)-qbyv(ij-iip1,l))
    696      &         /newmasse
    697             masse(ij,l)=newmasse
     803            q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+qbyv(ij,l)
     804     &         -qbyv(ij-iip1,l))/newmasse
     805            masse(ij,l,iq)=newmasse
    698806         ENDDO
    699807c.-. ancienne version
    … …  
    703811         convpn=SSUM(iim,qbyv(1,l),1)
    704812         convmpn=ssum(iim,masse_adv_v(1,l),1)
    705          massepn=ssum(iim,masse(1,l),1)
     813         massepn=ssum(iim,masse(1,l,iq),1)
    706814         qpn=0.
    707815         do ij=1,iim
    708             qpn=qpn+masse(ij,l)*q(ij,l)
     816            qpn=qpn+masse(ij,l,iq)*q(ij,l,iq)
    709817         enddo
    710818         qpn=(qpn+convpn)/(massepn+convmpn)
    711819         do ij=1,iip1
    712             q(ij,l)=qpn
     820            q(ij,l,iq)=qpn
    713821         enddo
    714822
    … …  
    718826         convps=-SSUM(iim,qbyv(ip1jm-iim,l),1)
    719827         convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1)
    720          masseps=ssum(iim, masse(ip1jm+1,l),1)
     828         masseps=ssum(iim, masse(ip1jm+1,l,iq),1)
    721829         qps=0.
    722830         do ij = ip1jm+1,ip1jmp1-1
    723             qps=qps+masse(ij,l)*q(ij,l)
     831            qps=qps+masse(ij,l,iq)*q(ij,l,iq)
    724832         enddo
    725833         qps=(qps+convps)/(masseps+convmps)
    726834         do ij=ip1jm+1,ip1jmp1
    727             q(ij,l)=qps
     835            q(ij,l,iq)=qps
    728836         enddo
    729837
    … …  
    739847c        DO ij = 1,iip1
    740848c           q(ij,l)=newq
    741 c           masse(ij,l)=newmasse*aire(ij)
     849c           masse(ij,l,iq)=newmasse*aire(ij)
    742850c        ENDDO
    743851c        convps=-SSUM(iim,qbyv(ip1jm-iim,l),1)
    … …  
    749857c        DO ij = ip1jm+1,ip1jmp1
    750858c           q(ij,l)=newq
    751 c           masse(ij,l)=newmasse*aire(ij)
     859c           masse(ij,l,iq)=newmasse*aire(ij)
    752860c        ENDDO
    753861c._. fin nouvelle version
    754862      ENDDO
     863 
     864! retablir les fils en rapport de melange par rapport a l'air:
     865      if (nqfils(iq).gt.0) then 
     866       do ifils=1,nqdesc(iq)
     867         iq2=iqfils(ifils,iq) 
     868         DO l=1,llm
     869          DO ij=1,ip1jmp1
     870            q(ij,l,iq2)=q(ij,l,iq)*Ratio(ij,l,iq2)           
     871          enddo
     872         enddo
     873        enddo !do ifils=1,nqdesc(iq)
     874      endif !if (nqfils(iq).gt.0) then
     875
     876      !write(*,*) 'vly 853: sortie'
    755877
    756878      RETURN
    757879      END
    758       SUBROUTINE vlz(q,pente_max,masse,w)
     880      RECURSIVE SUBROUTINE vlz(q,pente_max,masse,w,iq)
     881      USE infotrac, ONLY : nqtot,nqfils,nqdesc,iqfils ! CRisi
    759882c
    760883c     Auteurs:   P.Le Van, F.Hourdin, F.Forget
    … …  
    779902c   Arguments:
    780903c   ----------
    781       REAL masse(ip1jmp1,llm),pente_max
    782       REAL q(ip1jmp1,llm)
     904      REAL masse(ip1jmp1,llm,nqtot),pente_max
     905      REAL q(ip1jmp1,llm,nqtot)
    783906      REAL w(ip1jmp1,llm+1)
     907      INTEGER iq
    784908c
    785909c      Local
    … …  
    792916      REAL dzq(ip1jmp1,llm),dzqw(ip1jmp1,llm),adzqw(ip1jmp1,llm),dzqmax
    793917      REAL sigw
     918
     919      REAL masseq(ip1jmp1,llm,nqtot),Ratio(ip1jmp1,llm,nqtot) ! CRisi
     920      INTEGER ifils,iq2 ! CRisi
    794921
    795922      LOGICAL testcpu
    … …  
    805932c    On oriente tout dans le sens de la pression c'est a dire dans le
    806933c    sens de W
     934
     935      !write(*,*) 'vlz 923: entree'
    807936
    808937#ifdef BIDON
    … …  
    813942      DO l=2,llm
    814943         DO ij=1,ip1jmp1
    815             dzqw(ij,l)=q(ij,l-1)-q(ij,l)
     944            dzqw(ij,l)=q(ij,l-1,iq)-q(ij,l,iq)
    816945            adzqw(ij,l)=abs(dzqw(ij,l))
    817946         ENDDO
    … …  
    835964      ENDDO
    836965
     966      !write(*,*) 'vlz 954'
    837967      DO ij=1,ip1jmp1
    838968         dzq(ij,1)=0.
    … …  
    851981c calcul de  - d( q   * w )/ d(sigma)    qu'on ajoute a  dq pour calculer dq
    852982
     983       !write(*,*) 'vlz 969'
    853984       DO l = 1,llm-1
    854985         do  ij = 1,ip1jmp1
    855986          IF(w(ij,l+1).gt.0.) THEN
    856              sigw=w(ij,l+1)/masse(ij,l+1)
    857              wq(ij,l+1)=w(ij,l+1)*(q(ij,l+1)+0.5*(1.-sigw)*dzq(ij,l+1))
     987             sigw=w(ij,l+1)/masse(ij,l+1,iq)
     988             wq(ij,l+1)=w(ij,l+1)*(q(ij,l+1,iq)
     989     &           +0.5*(1.-sigw)*dzq(ij,l+1))
    858990          ELSE
    859              sigw=w(ij,l+1)/masse(ij,l)
    860              wq(ij,l+1)=w(ij,l+1)*(q(ij,l)-0.5*(1.+sigw)*dzq(ij,l))
     991             sigw=w(ij,l+1)/masse(ij,l,iq)
     992             wq(ij,l+1)=w(ij,l+1)*(q(ij,l,iq)-0.5*(1.+sigw)*dzq(ij,l))
    861993          ENDIF
    862994         ENDDO
    … …  
    8681000       ENDDO
    8691001
     1002! CRisi: appel récursif de l'advection sur les fils.
     1003! Il faut faire ça avant d'avoir mis à jour q et masse
     1004      !write(*,*) 'vlsplt 942: iq,nqfils(iq)=',iq,nqfils(iq)
     1005      if (nqfils(iq).gt.0) then 
     1006       do ifils=1,nqdesc(iq)
     1007         iq2=iqfils(ifils,iq)
     1008         DO l=1,llm
     1009          DO ij=1,ip1jmp1
     1010           masseq(ij,l,iq2)=masse(ij,l,iq)*q(ij,l,iq)
     1011           Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq)       
     1012          enddo   
     1013         enddo
     1014        enddo !do ifils=1,nqdesc(iq)
     1015       
     1016        do ifils=1,nqfils(iq)
     1017         iq2=iqfils(ifils,iq)         
     1018         call vlz(Ratio,pente_max,masseq,wq,iq2)
     1019        enddo !do ifils=1,nqfils(iq)
     1020      endif !if (nqfils(iq).gt.0) then
     1021! end CRisi 
     1022
    8701023      DO l=1,llm
    8711024         DO ij=1,ip1jmp1
    872             newmasse=masse(ij,l)+w(ij,l+1)-w(ij,l)
    873             q(ij,l)=(q(ij,l)*masse(ij,l)+wq(ij,l+1)-wq(ij,l))
     1025            newmasse=masse(ij,l,iq)+w(ij,l+1)-w(ij,l)
     1026            q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+wq(ij,l+1)-wq(ij,l))
    8741027     &         /newmasse
    875             masse(ij,l)=newmasse
    876          ENDDO
    877       ENDDO
    878 
     1028            masse(ij,l,iq)=newmasse
     1029         ENDDO
     1030      ENDDO
     1031
     1032! retablir les fils en rapport de melange par rapport a l'air:
     1033      if (nqfils(iq).gt.0) then 
     1034       do ifils=1,nqdesc(iq)
     1035         iq2=iqfils(ifils,iq) 
     1036         DO l=1,llm
     1037          DO ij=1,ip1jmp1
     1038            q(ij,l,iq2)=q(ij,l,iq)*Ratio(ij,l,iq2)           
     1039          enddo
     1040         enddo
     1041        enddo !do ifils=1,nqdesc(iq)
     1042      endif !if (nqfils(iq).gt.0) then
     1043      !write(*,*) 'vlsplt 1032'
    8791044
    8801045      RETURN

  • LMDZ5/branches/testing/libf/dyn3d/vlspltqs.F

    r1910 r2298  
    33c
    44       SUBROUTINE vlspltqs ( q,pente_max,masse,w,pbaru,pbarv,pdt,
    5      ,                                  p,pk,teta                 )
     5     ,                                  p,pk,teta,iq             )
     6       USE infotrac, ONLY: nqtot,nqdesc,iqfils
    67c
    78c     Auteurs:   P.Le Van, F.Hourdin, F.Forget, F.Codron
    … …  
    3536      REAL masse(ip1jmp1,llm),pente_max
    3637      REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm)
    37       REAL q(ip1jmp1,llm)
     38      REAL q(ip1jmp1,llm,nqtot)
    3839      REAL w(ip1jmp1,llm),pdt
    3940      REAL p(ip1jmp1,llmp1),teta(ip1jmp1,llm),pk(ip1jmp1,llm)
     41      INTEGER iq ! CRisi
    4042c
    4143c      Local
    … …  
    4345c
    4446      INTEGER i,ij,l,j,ii
     47      INTEGER ifils,iq2 ! CRisi
    4548c
    4649      REAL qsat(ip1jmp1,llm)
    47       REAL zm(ip1jmp1,llm)
     50      REAL zm(ip1jmp1,llm,nqtot)
    4851      REAL mu(ip1jmp1,llm)
    4952      REAL mv(ip1jm,llm)
    5053      REAL mw(ip1jmp1,llm+1)
    51       REAL zq(ip1jmp1,llm)
     54      REAL zq(ip1jmp1,llm,nqtot)
    5255      REAL temps1,temps2,temps3
    5356      REAL zzpbar, zzw
    … …  
    116119      ENDDO
    117120
    118       CALL SCOPY(ijp1llm,q,1,zq,1)
    119       CALL SCOPY(ijp1llm,masse,1,zm,1)
     121      CALL SCOPY(ijp1llm,q(1,1,iq),1,zq(1,1,iq),1)
     122      CALL SCOPY(ijp1llm,masse,1,zm(1,1,iq),1)
     123      if (nqdesc(iq).gt.0) then 
     124       do ifils=1,nqdesc(iq)
     125        iq2=iqfils(ifils,iq)
     126        CALL SCOPY(ijp1llm,q(1,1,iq2),1,zq(1,1,iq2),1)
     127       enddo 
     128      endif !if (nqfils(iq).gt.0) then
    120129
    121130c      call minmaxq(zq,qmin,qmax,'avant vlxqs     ')
    122       call vlxqs(zq,pente_max,zm,mu,qsat)
    123 
     131      call vlxqs(zq,pente_max,zm,mu,qsat,iq)
    124132
    125133c     call minmaxq(zq,qmin,qmax,'avant vlyqs     ')
    126134
    127       call vlyqs(zq,pente_max,zm,mv,qsat)
    128 
     135      call vlyqs(zq,pente_max,zm,mv,qsat,iq)
    129136
    130137c      call minmaxq(zq,qmin,qmax,'avant vlz     ')
    131138
    132       call vlz(zq,pente_max,zm,mw)
    133 
     139      call vlz(zq,pente_max,zm,mw,iq)
    134140
    135141c     call minmaxq(zq,qmin,qmax,'avant vlyqs     ')
    136142c     call minmaxq(zm,qmin,qmax,'M avant vlyqs     ')
    137143
    138       call vlyqs(zq,pente_max,zm,mv,qsat)
    139 
     144      call vlyqs(zq,pente_max,zm,mv,qsat,iq)
    140145
    141146c     call minmaxq(zq,qmin,qmax,'avant vlxqs     ')
    142147c     call minmaxq(zm,qmin,qmax,'M avant vlxqs     ')
    143148
    144       call vlxqs(zq,pente_max,zm,mu,qsat)
     149      call vlxqs(zq,pente_max,zm,mu,qsat,iq)
    145150
    146151c     call minmaxq(zq,qmin,qmax,'apres vlxqs     ')
    … …  
    150155      DO l=1,llm
    151156         DO ij=1,ip1jmp1
    152            q(ij,l)=zq(ij,l)
     157           q(ij,l,iq)=zq(ij,l,iq)
    153158         ENDDO
    154159         DO ij=1,ip1jm+1,iip1
    155             q(ij+iim,l)=q(ij,l)
    156          ENDDO
    157       ENDDO
     160            q(ij+iim,l,iq)=q(ij,l,iq)
     161         ENDDO
     162      ENDDO
     163      ! CRisi: aussi pour les fils
     164      if (nqdesc(iq).gt.0) then
     165      do ifils=1,nqdesc(iq)
     166        iq2=iqfils(ifils,iq)
     167        DO l=1,llm
     168         DO ij=1,ip1jmp1
     169           q(ij,l,iq2)=zq(ij,l,iq2)
     170         ENDDO
     171         DO ij=1,ip1jm+1,iip1
     172            q(ij+iim,l,iq2)=q(ij,l,iq2)
     173         ENDDO
     174        ENDDO
     175      enddo !do ifils=1,nqdesc(iq) 
     176      endif ! if (nqfils(iq).gt.0) then
     177      !write(*,*) 'vlspltqs 183: fin de la routine'
    158178
    159179      RETURN
    160180      END
    161       SUBROUTINE vlxqs(q,pente_max,masse,u_m,qsat)
     181      SUBROUTINE vlxqs(q,pente_max,masse,u_m,qsat,iq)
     182      USE infotrac, ONLY : nqtot,nqfils,nqdesc,iqfils ! CRisi
     183
    162184c
    163185c     Auteurs:   P.Le Van, F.Hourdin, F.Forget
    … …  
    179201c   Arguments:
    180202c   ----------
    181       REAL masse(ip1jmp1,llm),pente_max
     203      REAL masse(ip1jmp1,llm,nqtot),pente_max
    182204      REAL u_m( ip1jmp1,llm )
    183       REAL q(ip1jmp1,llm)
     205      REAL q(ip1jmp1,llm,nqtot)
    184206      REAL qsat(ip1jmp1,llm)
     207      INTEGER iq ! CRisi
    185208c
    186209c      Local
    … …  
    195218      REAL adxqu(ip1jmp1),dxqmax(ip1jmp1,llm)
    196219      REAL u_mq(ip1jmp1,llm)
     220
     221      ! CRisi
     222      REAL masseq(ip1jmp1,llm,nqtot),Ratio(ip1jmp1,llm,nqtot)
     223      INTEGER ifils,iq2 ! CRisi
    197224
    198225      Logical first,testcpu
    … …  
    227254         DO l = 1, llm
    228255            DO ij=iip2,ip1jm-1
    229                dxqu(ij)=q(ij+1,l)-q(ij,l)
     256               dxqu(ij)=q(ij+1,l,iq)-q(ij,l,iq)
    230257c              IF(u_m(ij,l).lt.0.) stop'limx n admet pas les U<0'
    231 c              sigu(ij)=u_m(ij,l)/masse(ij,l)
     258c              sigu(ij)=u_m(ij,l)/masse(ij,l,iq)
    232259            ENDDO
    233260            DO ij=iip1+iip1,ip1jm,iip1
    … …  
    281308         DO l = 1, llm
    282309            DO ij=iip2,ip1jm-1
    283                dxqu(ij)=q(ij+1,l)-q(ij,l)
     310               dxqu(ij)=q(ij+1,l,iq)-q(ij,l,iq)
    284311            ENDDO
    285312            DO ij=iip1+iip1,ip1jm,iip1
    … …  
    323350      DO l=1,llm
    324351       DO ij=iip2,ip1jm-1
    325           zdum(ij,l)=cvmgp(1.-u_m(ij,l)/masse(ij,l),
    326      ,                     1.+u_m(ij,l)/masse(ij+1,l),
     352          zdum(ij,l)=cvmgp(1.-u_m(ij,l)/masse(ij,l,iq),
     353     ,                     1.+u_m(ij,l)/masse(ij+1,l,iq),
    327354     ,                     u_m(ij,l))
    328355          zdum(ij,l)=0.5*zdum(ij,l)
    329356          u_mq(ij,l)=cvmgp(
    330      ,                q(ij,l)+zdum(ij,l)*dxq(ij,l),
    331      ,                q(ij+1,l)-zdum(ij,l)*dxq(ij+1,l),
     357     ,                q(ij,l,iq)+zdum(ij,l)*dxq(ij,l),
     358     ,                q(ij+1,l,iq)-zdum(ij,l)*dxq(ij+1,l),
    332359     ,                u_m(ij,l))
    333360          u_mq(ij,l)=u_m(ij,l)*u_mq(ij,l)
    … …  
    341368       DO ij=iip2,ip1jm-1
    342369          IF (u_m(ij,l).gt.0.) THEN
    343              zdum(ij,l)=1.-u_m(ij,l)/masse(ij,l)
     370             zdum(ij,l)=1.-u_m(ij,l)/masse(ij,l,iq)
    344371             u_mq(ij,l)=u_m(ij,l)*
    345      $         min(q(ij,l)+0.5*zdum(ij,l)*dxq(ij,l),qsat(ij+1,l))
     372     $         min(q(ij,l,iq)+0.5*zdum(ij,l)*dxq(ij,l),qsat(ij+1,l))
    346373          ELSE
    347              zdum(ij,l)=1.+u_m(ij,l)/masse(ij+1,l)
     374             zdum(ij,l)=1.+u_m(ij,l)/masse(ij+1,l,iq)
    348375             u_mq(ij,l)=u_m(ij,l)*
    349      $         min(q(ij+1,l)-0.5*zdum(ij,l)*dxq(ij+1,l),qsat(ij,l))
     376     $         min(q(ij+1,l,iq)-0.5*zdum(ij,l)*dxq(ij+1,l),qsat(ij,l))
    350377          ENDIF
    351378       ENDDO
    … …  
    416443                     i=ijq-(j-1)*iip1
    417444c   accumulation pour les mailles completements advectees
    418                      do while(zu_m.gt.masse(ijq,l))
    419                         u_mq(ij,l)=u_mq(ij,l)+q(ijq,l)*masse(ijq,l)
    420                         zu_m=zu_m-masse(ijq,l)
     445                     do while(zu_m.gt.masse(ijq,l,iq))
     446                        u_mq(ij,l)=u_mq(ij,l)+q(ijq,l,iq)
     447     &                          *masse(ijq,l,iq)
     448                        zu_m=zu_m-masse(ijq,l,iq)
    421449                        i=mod(i-2+iim,iim)+1
    422450                        ijq=(j-1)*iip1+i
    … …  
    424452c   ajout de la maille non completement advectee
    425453                     u_mq(ij,l)=u_mq(ij,l)+zu_m*
    426      &               (q(ijq,l)+0.5*(1.-zu_m/masse(ijq,l))*dxq(ijq,l))
     454     &                  (q(ijq,l,iq)+0.5*(1.-zu_m/masse(ijq,l,iq))
     455     &                  *dxq(ijq,l))
    427456                  ELSE
    428457                     ijq=ij+1
    429458                     i=ijq-(j-1)*iip1
    430459c   accumulation pour les mailles completements advectees
    431                      do while(-zu_m.gt.masse(ijq,l))
    432                         u_mq(ij,l)=u_mq(ij,l)-q(ijq,l)*masse(ijq,l)
    433                         zu_m=zu_m+masse(ijq,l)
     460                     do while(-zu_m.gt.masse(ijq,l,iq))
     461                        u_mq(ij,l)=u_mq(ij,l)-q(ijq,l,iq)
     462     &                          *masse(ijq,l,iq)
     463                        zu_m=zu_m+masse(ijq,l,iq)
    434464                        i=mod(i,iim)+1
    435465                        ijq=(j-1)*iip1+i
    436466                     ENDDO
    437467c   ajout de la maille non completement advectee
    438                      u_mq(ij,l)=u_mq(ij,l)+zu_m*(q(ijq,l)-
    439      &               0.5*(1.+zu_m/masse(ijq,l))*dxq(ijq,l))
     468                     u_mq(ij,l)=u_mq(ij,l)+zu_m*(q(ijq,l,iq)-
     469     &               0.5*(1.+zu_m/masse(ijq,l,iq))*dxq(ijq,l))
    440470                  ENDIF
    441471               ENDDO
    … …  
    454484      ENDDO
    455485
     486! CRisi: appel récursif de l'advection sur les fils.
     487! Il faut faire ça avant d'avoir mis à jour q et masse
     488      !write(*,*) 'vlspltqs 326: iq,nqfils(iq)=',iq,nqfils(iq)
     489     
     490      if (nqfils(iq).gt.0) then 
     491       do ifils=1,nqdesc(iq)
     492         iq2=iqfils(ifils,iq)
     493         DO l=1,llm
     494          DO ij=iip2,ip1jm
     495           ! On a besoin de q et masse seulement entre iip2 et ip1jm
     496           masseq(ij,l,iq2)=masse(ij,l,iq)*q(ij,l,iq)
     497           Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq)
     498          enddo   
     499         enddo
     500        enddo !do ifils=1,nqdesc(iq)
     501        do ifils=1,nqfils(iq)
     502         iq2=iqfils(ifils,iq)
     503         call vlx(Ratio,pente_max,masseq,u_mq,iq2)
     504        enddo !do ifils=1,nqfils(iq)
     505      endif !if (nqfils(iq).gt.0) then
     506! end CRisi
    456507
    457508c   calcul des tendances
    … …  
    459510      DO l=1,llm
    460511         DO ij=iip2+1,ip1jm
    461             new_m=masse(ij,l)+u_m(ij-1,l)-u_m(ij,l)
    462             q(ij,l)=(q(ij,l)*masse(ij,l)+
     512            new_m=masse(ij,l,iq)+u_m(ij-1,l)-u_m(ij,l)
     513            q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+
    463514     &      u_mq(ij-1,l)-u_mq(ij,l))
    464515     &      /new_m
    465             masse(ij,l)=new_m
     516            masse(ij,l,iq)=new_m
    466517         ENDDO
    467518c   Modif Fred 22 03 96 correction d'un bug (les scopy ci-dessous)
    468519         DO ij=iip1+iip1,ip1jm,iip1
    469             q(ij-iim,l)=q(ij,l)
    470             masse(ij-iim,l)=masse(ij,l)
    471          ENDDO
    472       ENDDO
     520            q(ij-iim,l,iq)=q(ij,l,iq)
     521            masse(ij-iim,l,iq)=masse(ij,l,iq)
     522         ENDDO
     523      ENDDO
     524
     525      ! retablir les fils en rapport de melange par rapport a l'air:
     526      ! On calcule q entre iip2+1,ip1jm -> on fait pareil pour ratio
     527      ! puis on boucle en longitude
     528      if (nqdesc(iq).gt.0) then 
     529       do ifils=1,nqdesc(iq)
     530         iq2=iqfils(ifils,iq) 
     531         DO l=1,llm
     532          DO ij=iip2+1,ip1jm
     533            q(ij,l,iq2)=q(ij,l,iq)*Ratio(ij,l,iq2)           
     534          enddo
     535          DO ij=iip1+iip1,ip1jm,iip1
     536             q(ij-iim,l,iq2)=q(ij,l,iq2)
     537          enddo ! DO ij=ijb+iip1-1,ije,iip1
     538         enddo !DO l=1,llm
     539        enddo !do ifils=1,nqdesc(iq)
     540      endif !if (nqfils(iq).gt.0) then
    473541
    474542c     CALL SCOPY((jjm-1)*llm,q(iip1+iip1,1),iip1,q(iip2,1),iip1)
    … …  
    478546      RETURN
    479547      END
    480       SUBROUTINE vlyqs(q,pente_max,masse,masse_adv_v,qsat)
     548      SUBROUTINE vlyqs(q,pente_max,masse,masse_adv_v,qsat,iq)
     549      USE infotrac, ONLY : nqtot,nqfils,nqdesc,iqfils ! CRisi
    481550c
    482551c     Auteurs:   P.Le Van, F.Hourdin, F.Forget
    … …  
    502571c   Arguments:
    503572c   ----------
    504       REAL masse(ip1jmp1,llm),pente_max
     573      REAL masse(ip1jmp1,llm,nqtot),pente_max
    505574      REAL masse_adv_v( ip1jm,llm)
    506       REAL q(ip1jmp1,llm)
     575      REAL q(ip1jmp1,llm,nqtot)
    507576      REAL qsat(ip1jmp1,llm)
     577      INTEGER iq ! CRisi
    508578c
    509579c      Local
    … …  
    529599      SAVE sinlon,coslon,sinlondlon,coslondlon
    530600      SAVE airej2,airejjm
     601
     602      REAL masseq(ip1jmp1,llm,nqtot),Ratio(ip1jmp1,llm,nqtot) ! CRisi
     603      INTEGER ifils,iq2 ! CRisi
    531604c
    532605c
    … …  
    567640
    568641      DO i = 1, iim
    569       airescb(i) = aire(i+ iip1) * q(i+ iip1,l)
    570       airesch(i) = aire(i+ ip1jm- iip1) * q(i+ ip1jm- iip1,l)
     642      airescb(i) = aire(i+ iip1) * q(i+ iip1,l,iq)
     643      airesch(i) = aire(i+ ip1jm- iip1) * q(i+ ip1jm- iip1,l,iq)
    571644      ENDDO
    572645      qpns   = SSUM( iim,  airescb ,1 ) / airej2
    … …  
    576649
    577650      DO ij=1,ip1jm
    578          dyqv(ij)=q(ij,l)-q(ij+iip1,l)
     651         dyqv(ij)=q(ij,l,iq)-q(ij+iip1,l,iq)
    579652         adyqv(ij)=abs(dyqv(ij))
    580653      ENDDO
    … …  
    591664
    592665      DO ij=1,iip1
    593          dyq(ij,l)=qpns-q(ij+iip1,l)
    594          dyq(ip1jm+ij,l)=q(ip1jm+ij-iip1,l)-qpsn
     666         dyq(ij,l)=qpns-q(ij+iip1,l,iq)
     667         dyq(ip1jm+ij,l)=q(ip1jm+ij-iip1,l,iq)-qpsn
    595668      ENDDO
    596669
    … …  
    710783       DO ij=1,ip1jm
    711784         IF( masse_adv_v(ij,l).GT.0. ) THEN
    712            qbyv(ij,l)= MIN( qsat(ij+iip1,l), q(ij+iip1,l )  +
    713      ,      dyq(ij+iip1,l)*0.5*(1.-masse_adv_v(ij,l)/masse(ij+iip1,l)))
     785           qbyv(ij,l)= MIN( qsat(ij+iip1,l), q(ij+iip1,l,iq )  +
     786     ,      dyq(ij+iip1,l)*0.5*(1.-masse_adv_v(ij,l)
     787     ,      /masse(ij+iip1,l,iq)))
    714788         ELSE
    715               qbyv(ij,l)= MIN( qsat(ij,l), q(ij,l) - dyq(ij,l) *
    716      ,                   0.5*(1.+masse_adv_v(ij,l)/masse(ij,l)) )
     789              qbyv(ij,l)= MIN( qsat(ij,l), q(ij,l,iq) - dyq(ij,l) *
     790     ,                   0.5*(1.+masse_adv_v(ij,l)/masse(ij,l,iq)) )
    717791         ENDIF
    718792          qbyv(ij,l) = masse_adv_v(ij,l)*qbyv(ij,l)
    … …  
    721795
    722796
     797! CRisi: appel récursif de l'advection sur les fils.
     798! Il faut faire ça avant d'avoir mis à jour q et masse
     799      !write(*,*) 'vlyqs 689: iq,nqfils(iq)=',iq,nqfils(iq)
     800   
     801      if (nqfils(iq).gt.0) then 
     802       do ifils=1,nqdesc(iq)
     803         iq2=iqfils(ifils,iq)
     804         DO l=1,llm
     805         DO ij=1,ip1jmp1
     806           masseq(ij,l,iq2)=masse(ij,l,iq)*q(ij,l,iq)
     807           Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq)     
     808          enddo   
     809         enddo
     810        enddo !do ifils=1,nqdesc(iq)
     811
     812        do ifils=1,nqfils(iq)
     813         iq2=iqfils(ifils,iq)
     814         !write(*,*) 'vlyqs 783: appel rec de vly, iq2=',iq2
     815         call vly(Ratio,pente_max,masseq,qbyv,iq2)
     816        enddo !do ifils=1,nqfils(iq)
     817      endif !if (nqfils(iq).gt.0) then
     818
    723819      DO l=1,llm
    724820         DO ij=iip2,ip1jm
    725             newmasse=masse(ij,l)
     821            newmasse=masse(ij,l,iq)
    726822     &      +masse_adv_v(ij,l)-masse_adv_v(ij-iip1,l)
    727             q(ij,l)=(q(ij,l)*masse(ij,l)+qbyv(ij,l)-qbyv(ij-iip1,l))
    728      &         /newmasse
    729             masse(ij,l)=newmasse
     823            q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+qbyv(ij,l)
     824     &         -qbyv(ij-iip1,l))/newmasse
     825            masse(ij,l,iq)=newmasse
    730826         ENDDO
    731827c.-. ancienne version
    … …  
    733829         convmpn=ssum(iim,masse_adv_v(1,l),1)/apoln
    734830         DO ij = 1,iip1
    735             newmasse=masse(ij,l)+convmpn*aire(ij)
    736             q(ij,l)=(q(ij,l)*masse(ij,l)+convpn*aire(ij))/
     831            newmasse=masse(ij,l,iq)+convmpn*aire(ij)
     832            q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+convpn*aire(ij))/
    737833     &               newmasse
    738             masse(ij,l)=newmasse
     834            masse(ij,l,iq)=newmasse
    739835         ENDDO
    740836         convps  = -SSUM(iim,qbyv(ip1jm-iim,l),1)/apols
    741837         convmps = -SSUM(iim,masse_adv_v(ip1jm-iim,l),1)/apols
    742838         DO ij = ip1jm+1,ip1jmp1
    743             newmasse=masse(ij,l)+convmps*aire(ij)
    744             q(ij,l)=(q(ij,l)*masse(ij,l)+convps*aire(ij))/
     839            newmasse=masse(ij,l,iq)+convmps*aire(ij)
     840            q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+convps*aire(ij))/
    745841     &               newmasse
    746             masse(ij,l)=newmasse
     842            masse(ij,l,iq)=newmasse
    747843         ENDDO
    748844c.-. fin ancienne version
    … …  
    757853c        DO ij = 1,iip1
    758854c           q(ij,l)=newq
    759 c           masse(ij,l)=newmasse*aire(ij)
     855c           masse(ij,l,iq)=newmasse*aire(ij)
    760856c        ENDDO
    761857c        convps=-SSUM(iim,qbyv(ip1jm-iim,l),1)
    … …  
    767863c        DO ij = ip1jm+1,ip1jmp1
    768864c           q(ij,l)=newq
    769 c           masse(ij,l)=newmasse*aire(ij)
     865c           masse(ij,l,iq)=newmasse*aire(ij)
    770866c        ENDDO
    771867c._. fin nouvelle version
    772868      ENDDO
    773869
     870      !write(*,*) 'vly 866'
     871
     872! retablir les fils en rapport de melange par rapport a l'air:
     873      if (nqdesc(iq).gt.0) then 
     874       do ifils=1,nqdesc(iq)
     875         iq2=iqfils(ifils,iq) 
     876         DO l=1,llm
     877          DO ij=1,ip1jmp1
     878            q(ij,l,iq2)=q(ij,l,iq)*Ratio(ij,l,iq2)           
     879          enddo
     880         enddo
     881        enddo !do ifils=1,nqdesc(iq)
     882      endif !if (nqfils(iq).gt.0) then
     883      !write(*,*) 'vly 879'
     884
    774885      RETURN
    775886      END

  • LMDZ5/branches/testing/libf/dyn3d_common/diagedyn.F

    r1999 r2298  
    5353c======================================================================
    5454 
     55      USE control_mod, ONLY : planet_type
     56     
    5557      IMPLICIT NONE
    5658C
    … …  
    6062#include "iniprint.h"
    6163
    62 #ifdef CPP_EARTH
    63 #include "../phylmd/YOMCST.h"
    64 #include "../phylmd/YOETHF.h"
    65 #endif
     64!#ifdef CPP_EARTH
     65!#include "../phylmd/YOMCST.h"
     66!#include "../phylmd/YOETHF.h"
     67!#endif
     68! Ehouarn: for now set these parameters to what is in Earth physics...
     69!          (cf ../phylmd/suphel.h)
     70!          this should be generalized...
     71      REAL,PARAMETER :: RCPD=
     72     &               3.5*(1000.*(6.0221367E+23*1.380658E-23)/28.9644)
     73      REAL,PARAMETER :: RCPV=
     74     &               4.*(1000.*(6.0221367E+23*1.380658E-23)/18.0153)
     75      REAL,PARAMETER :: RCS=RCPV
     76      REAL,PARAMETER :: RCW=RCPV
     77      REAL,PARAMETER :: RLSTT=2.8345E+6
     78      REAL,PARAMETER :: RLVTT=2.5008E+6
     79!
    6680C
    6781      INTEGER imjmp1
    … …  
    140154
    141155
    142 #ifdef CPP_EARTH
     156!#ifdef CPP_EARTH
     157      IF (planet_type=="earth") THEN
     158     
    143159c======================================================================
    144160C     Compute Kinetic enrgy
    … …  
    314330      ec_pre (idiag)    = ec_tot
    315331C
    316 #else
    317       write(lunout,*)'diagedyn: Needs Earth physics to function'
    318 #endif
     332!#else
     333      ELSE
     334        write(lunout,*)'diagedyn: set to function with Earth parameters'
     335      ENDIF ! of if (planet_type=="earth")
     336!#endif
    319337! #endif of #ifdef CPP_EARTH
    320338      RETURN

  • LMDZ5/branches/testing/libf/dyn3d_common/infotrac.F90

    r2187 r2298  
    1212  INTEGER, SAVE :: nbtr
    1313
     14! CRisi: nb traceurs pères= directement advectés par l'air
     15  INTEGER, SAVE :: nqperes
     16
    1417! Name variables
    1518  CHARACTER(len=20), ALLOCATABLE, DIMENSION(:), SAVE :: tname ! tracer short name for restart and diagnostics
    … …  
    2225!         dynamic part of the code and the tracers (nbtr+2) used in the physics part of the code.
    2326  INTEGER, ALLOCATABLE, DIMENSION(:), SAVE    :: niadv ! equivalent dyn / physique
     27
     28! CRisi: tableaux de fils
     29  INTEGER, ALLOCATABLE, DIMENSION(:), SAVE    :: nqfils
     30  INTEGER, ALLOCATABLE, DIMENSION(:), SAVE    :: nqdesc ! nombres de fils + nombre de tous les petits fils sur toutes les générations
     31  INTEGER, SAVE :: nqdesc_tot
     32  INTEGER, ALLOCATABLE, DIMENSION(:,:), SAVE    :: iqfils
     33  INTEGER, ALLOCATABLE, DIMENSION(:), SAVE    :: iqpere
    2434
    2535! conv_flg(it)=0 : convection desactivated for tracer number it
    … …  
    3040  CHARACTER(len=4),SAVE :: type_trac
    3141  CHARACTER(len=8),DIMENSION(:),ALLOCATABLE, SAVE :: solsym
     42   
     43    ! CRisi: cas particulier des isotopes
     44    LOGICAL,SAVE :: ok_isotopes,ok_iso_verif,ok_isotrac,ok_init_iso
     45    INTEGER :: niso_possibles   
     46    PARAMETER ( niso_possibles=5)
     47    real, DIMENSION (niso_possibles),SAVE :: tnat,alpha_ideal
     48    LOGICAL, DIMENSION(niso_possibles),SAVE ::  use_iso
     49    INTEGER, ALLOCATABLE, DIMENSION(:,:), SAVE ::  iqiso ! donne indice iq en fn de (ixt,phase)
     50    INTEGER, ALLOCATABLE, DIMENSION(:), SAVE ::  iso_num ! donne numéro iso entre 1 et niso_possibles en fn de nqtot
     51    INTEGER, ALLOCATABLE, DIMENSION(:), SAVE ::  iso_indnum ! donne numéro iso entre 1 et niso effectif en fn de nqtot
     52    INTEGER, ALLOCATABLE, DIMENSION(:), SAVE ::  zone_num ! donne numéro de la zone de tracage en fn de nqtot
     53    INTEGER, ALLOCATABLE, DIMENSION(:), SAVE ::  phase_num ! donne numéro de la zone de tracage en fn de nqtot
     54    INTEGER, DIMENSION(niso_possibles), SAVE :: indnum_fn_num ! donne indice entre entre 1 et niso en fonction du numéro d isotope entre 1 et niso_possibles
     55    INTEGER, ALLOCATABLE, DIMENSION(:,:), SAVE ::  index_trac ! numéro ixt en fn izone, indnum entre 1 et niso
     56    INTEGER,SAVE :: niso,ntraceurs_zone,ntraciso
    3257 
    3358CONTAINS
    … …  
    6388
    6489    CHARACTER(len=15), ALLOCATABLE, DIMENSION(:) :: tnom_0  ! tracer short name
     90    CHARACTER(len=15), ALLOCATABLE, DIMENSION(:) :: tnom_transp ! transporting fluid short name: CRisi
    6591    CHARACTER(len=3), DIMENSION(30) :: descrq
    6692    CHARACTER(len=1), DIMENSION(3)  :: txts
    … …  
    7096    INTEGER :: nqtrue  ! number of tracers read from tracer.def, without higer order of moment
    7197    INTEGER :: iq, new_iq, iiq, jq, ierr
     98    INTEGER :: ifils,ipere,generation ! CRisi
     99    LOGICAL :: continu,nouveau_traceurdef
     100    INTEGER :: IOstatus ! gestion de la retrocompatibilite de traceur.def
     101    CHARACTER(len=15) :: tchaine   
    72102
    73103    character(len=*),parameter :: modname="infotrac_init"
    … …  
    134164          WRITE(lunout,*) trim(modname),': Open traceur.def : ok'
    135165          READ(90,*) nqtrue
     166          write(lunout,*) 'nqtrue=',nqtrue
    136167       ELSE
    137168          WRITE(lunout,*) trim(modname),': Problem in opening traceur.def'
    … …  
    143174          endif
    144175       END IF
    145        if ( planet_type=='earth') then
    146          ! For Earth, water vapour & liquid tracers are not in the physics
    147          nbtr=nqtrue-2
    148        else
    149          ! Other planets (for now); we have the same number of tracers
    150          ! in the dynamics than in the physics
    151          nbtr=nqtrue
    152        endif
     176!jyg<
     177!!       if ( planet_type=='earth') then
     178!!         ! For Earth, water vapour & liquid tracers are not in the physics
     179!!         nbtr=nqtrue-2
     180!!       else
     181!!         ! Other planets (for now); we have the same number of tracers
     182!!         ! in the dynamics than in the physics
     183!!         nbtr=nqtrue
     184!!       endif
     185!>jyg
    153186    ELSE ! type_trac=inca
     187!jyg<
     188       ! The traceur.def file is used to define the number "nqo" of water phases
     189       ! present in the simulation. Default : nqo = 2.
     190       OPEN(90,file='traceur.def',form='formatted',status='old', iostat=ierr)
     191       IF(ierr.EQ.0) THEN
     192          WRITE(lunout,*) trim(modname),': Open traceur.def : ok'
     193          READ(90,*) nqo
     194       ELSE
     195          WRITE(lunout,*) trim(modname),': Using default value for nqo'
     196          nqo=2
     197       ENDIF
     198       IF (nqo /= 2 .OR. nqo /= 3 ) THEN
     199          WRITE(lunout,*) trim(modname),': nqo=',nqo, ' is not allowded. Only 2 or 3 water phases allowed'
     200          CALL abort_gcm('infotrac_init','Bad number of water phases',1)
     201       END IF
    154202       ! nbtr has been read from INCA by init_const_lmdz() in gcm.F
    155        nqtrue=nbtr+2
    156     END IF
     203       nqtrue=nbtr+nqo
     204!!       nqtrue=nbtr+2
     205    END IF   ! type_trac
     206!>jyg
    157207
    158208    IF ((planet_type=="earth").and.(nqtrue < 2)) THEN
    … …  
    161211    END IF
    162212   
     213!jyg<
    163214! Transfert number of tracers to Reprobus
    164     IF (type_trac == 'repr') THEN
    165 #ifdef REPROBUS
    166        CALL Init_chem_rep_trac(nbtr)
    167 #endif
    168     END IF
     215!!    IF (type_trac == 'repr') THEN
     216!!#ifdef REPROBUS
     217!!       CALL Init_chem_rep_trac(nbtr)
     218!!#endif
     219!!    END IF
     220!>jyg
    169221       
    170222!
    171 ! Allocate variables depending on nqtrue and nbtr
    172 !
    173     ALLOCATE(tnom_0(nqtrue), hadv(nqtrue), vadv(nqtrue))
    174     ALLOCATE(conv_flg(nbtr), pbl_flg(nbtr), solsym(nbtr))
    175     conv_flg(:) = 1 ! convection activated for all tracers
    176     pbl_flg(:)  = 1 ! boundary layer activated for all tracers
     223! Allocate variables depending on nqtrue
     224!
     225    ALLOCATE(tnom_0(nqtrue), hadv(nqtrue), vadv(nqtrue),tnom_transp(nqtrue))
     226!
     227!jyg<
     228!!    ALLOCATE(conv_flg(nbtr), pbl_flg(nbtr), solsym(nbtr))
     229!!    conv_flg(:) = 1 ! convection activated for all tracers
     230!!    pbl_flg(:)  = 1 ! boundary layer activated for all tracers
     231!>jyg
    177232
    178233!-----------------------------------------------------------------------
    … …  
    206261          ! Continue to read tracer.def
    207262          DO iq=1,nqtrue
    208              READ(90,*) hadv(iq),vadv(iq),tnom_0(iq)
    209           END DO
     263
     264             write(*,*) 'infotrac 237: iq=',iq
     265             ! CRisi: ajout du nom du fluide transporteur
     266             ! mais rester retro compatible
     267             READ(90,'(I2,X,I2,X,A)',IOSTAT=IOstatus) hadv(iq),vadv(iq),tchaine
     268             write(lunout,*) 'iq,hadv(iq),vadv(iq)=',iq,hadv(iq),vadv(iq)
     269             write(lunout,*) 'tchaine=',trim(tchaine)
     270             write(*,*) 'infotrac 238: IOstatus=',IOstatus
     271             if (IOstatus.ne.0) then
     272                CALL abort_gcm('infotrac_init','Pb dans la lecture de traceur.def',1)
     273             endif
     274             ! Y-a-t-il 1 ou 2 noms de traceurs? -> On regarde s'il y a un
     275             ! espace ou pas au milieu de la chaine.
     276             continu=1
     277             nouveau_traceurdef=0
     278             iiq=1
     279             do while (continu)
     280                if (tchaine(iiq:iiq).eq.' ') then
     281                  nouveau_traceurdef=1
     282                  continu=0
     283                else if (iiq.lt.LEN_TRIM(tchaine)) then
     284                  iiq=iiq+1
     285                else
     286                  continu=0     
     287                endif
     288             enddo
     289             write(*,*) 'iiq,nouveau_traceurdef=',iiq,nouveau_traceurdef
     290             if (nouveau_traceurdef) then
     291                write(lunout,*) 'C''est la nouvelle version de traceur.def'
     292                tnom_0(iq)=tchaine(1:iiq-1)
     293                tnom_transp(iq)=tchaine(iiq+1:15)
     294             else
     295                write(lunout,*) 'C''est l''ancienne version de traceur.def'
     296                write(lunout,*) 'On suppose que les traceurs sont tous d''air'
     297                tnom_0(iq)=tchaine
     298                tnom_transp(iq) = 'air'
     299             endif
     300             write(lunout,*) 'tnom_0(iq)=<',trim(tnom_0(iq)),'>'
     301             write(lunout,*) 'tnom_transp(iq)=<',trim(tnom_transp(iq)),'>'
     302
     303          END DO !DO iq=1,nqtrue
    210304          CLOSE(90) 
     305
    211306       ELSE ! Without tracer.def, set default values
    212307         if (planet_type=="earth") then
    … …  
    215310          vadv(1) = 14
    216311          tnom_0(1) = 'H2Ov'
     312          tnom_transp(1) = 'air'
    217313          hadv(2) = 10
    218314          vadv(2) = 10
    219315          tnom_0(2) = 'H2Ol'
     316          tnom_transp(2) = 'air'
    220317          hadv(3) = 10
    221318          vadv(3) = 10
    222319          tnom_0(3) = 'RN'
     320          tnom_transp(3) = 'air'
    223321          hadv(4) = 10
    224322          vadv(4) = 10
    225323          tnom_0(4) = 'PB'
     324          tnom_transp(4) = 'air'
    226325         else ! default for other planets
    227326          hadv(1) = 10
    228327          vadv(1) = 10
    229328          tnom_0(1) = 'dummy'
     329          tnom_transp(1) = 'dummy'
    230330         endif ! of if (planet_type=="earth")
    231331       END IF
    232 
    233 !CR: nombre de traceurs de l eau
    234        if (tnom_0(3) == 'H2Oi') then
    235           nqo=3
    236        else
    237           nqo=2
    238        endif
    239332       
    240333       WRITE(lunout,*) trim(modname),': Valeur de traceur.def :'
    241334       WRITE(lunout,*) trim(modname),': nombre de traceurs ',nqtrue
    242335       DO iq=1,nqtrue
    243           WRITE(lunout,*) hadv(iq),vadv(iq),tnom_0(iq)
     336          WRITE(lunout,*) hadv(iq),vadv(iq),tnom_0(iq),tnom_transp(iq)
    244337       END DO
    245338
    246     ELSE  ! type_trac=inca : config_inca='aero' ou 'chem'
     339       if ( planet_type=='earth') then
     340         !CR: nombre de traceurs de l eau
     341         if (tnom_0(3) == 'H2Oi') then
     342            nqo=3
     343         else
     344            nqo=2
     345         endif
     346         ! For Earth, water vapour & liquid tracers are not in the physics
     347         nbtr=nqtrue-nqo
     348       else
     349         ! Other planets (for now); we have the same number of tracers
     350         ! in the dynamics than in the physics
     351         nbtr=nqtrue
     352       endif
     353
     354    ENDIF  ! (type_trac == 'lmdz' .OR. type_trac == 'repr')
     355!jyg<
     356!
     357! Transfert number of tracers to Reprobus
     358    IF (type_trac == 'repr') THEN
     359#ifdef REPROBUS
     360       CALL Init_chem_rep_trac(nbtr)
     361#endif
     362    END IF
     363!
     364! Allocate variables depending on nbtr
     365!
     366    ALLOCATE(conv_flg(nbtr), pbl_flg(nbtr), solsym(nbtr))
     367    conv_flg(:) = 1 ! convection activated for all tracers
     368    pbl_flg(:)  = 1 ! boundary layer activated for all tracers
     369!
     370!!    ELSE  ! type_trac=inca : config_inca='aero' ou 'chem'
     371!
     372    IF (type_trac == 'inca') THEN   ! config_inca='aero' ou 'chem'
     373!>jyg
    247374! le module de chimie fournit les noms des traceurs
    248375! et les schemas d'advection associes.
    … …  
    258385       tnom_0(1)='H2Ov'
    259386       tnom_0(2)='H2Ol'
    260 
    261        DO iq =3,nqtrue
    262           tnom_0(iq)=solsym(iq-2)
     387       IF (nqo == 3) tnom_0(3)='H2Oi'     !! jyg
     388
     389!jyg<
     390       DO iq = nqo+1, nqtrue
     391          tnom_0(iq)=solsym(iq-nqo)
    263392       END DO
    264        nqo = 2
    265 
    266     END IF ! type_trac
     393!!       DO iq =3,nqtrue
     394!!          tnom_0(iq)=solsym(iq-2)
     395!!       END DO
     396!!       nqo = 2
     397!>jyg
     398
     399    END IF ! (type_trac == 'inca')
    267400
    268401!-----------------------------------------------------------------------
    … …  
    390523    END DO
    391524
     525
     526! CRisi: quels sont les traceurs fils et les traceurs pères.
     527! initialiser tous les tableaux d'indices liés aux traceurs familiaux
     528! + vérifier que tous les pères sont écrits en premières positions
     529    ALLOCATE(nqfils(nqtot),nqdesc(nqtot))   
     530    ALLOCATE(iqfils(nqtot,nqtot))   
     531    ALLOCATE(iqpere(nqtot))
     532    nqperes=0
     533    nqfils(:)=0
     534    nqdesc(:)=0
     535    iqfils(:,:)=0
     536    iqpere(:)=0
     537    nqdesc_tot=0   
     538    DO iq=1,nqtot
     539      if (tnom_transp(iq) == 'air') then
     540        ! ceci est un traceur père
     541        WRITE(lunout,*) 'Le traceur',iq,', appele ',trim(tnom_0(iq)),', est un pere'
     542        nqperes=nqperes+1
     543        iqpere(iq)=0
     544      else !if (tnom_transp(iq) == 'air') then
     545        ! ceci est un fils. Qui est son père?
     546        WRITE(lunout,*) 'Le traceur',iq,', appele ',trim(tnom_0(iq)),', est un fils'
     547        continu=.true.
     548        ipere=1
     549        do while (continu)           
     550          if (tnom_transp(iq) == tnom_0(ipere)) then
     551            ! Son père est ipere
     552            WRITE(lunout,*) 'Le traceur',iq,'appele ', &
     553      &          trim(tnom_0(iq)),' est le fils de ',ipere,'appele ',trim(tnom_0(ipere))
     554            nqfils(ipere)=nqfils(ipere)+1 
     555            iqfils(nqfils(ipere),ipere)=iq
     556            iqpere(iq)=ipere         
     557            continu=.false.
     558          else !if (tnom_transp(iq) == tnom_0(ipere)) then
     559            ipere=ipere+1
     560            if (ipere.gt.nqtot) then
     561                WRITE(lunout,*) 'Le traceur',iq,'appele ', &
     562      &          trim(tnom_0(iq)),', est orpelin.'
     563                CALL abort_gcm('infotrac_init','Un traceur est orphelin',1)
     564            endif !if (ipere.gt.nqtot) then
     565          endif !if (tnom_transp(iq) == tnom_0(ipere)) then
     566        enddo !do while (continu)
     567      endif !if (tnom_transp(iq) == 'air') then
     568    enddo !DO iq=1,nqtot
     569    WRITE(lunout,*) 'infotrac: nqperes=',nqperes   
     570    WRITE(lunout,*) 'nqfils=',nqfils
     571    WRITE(lunout,*) 'iqpere=',iqpere
     572    WRITE(lunout,*) 'iqfils=',iqfils
     573
     574! Calculer le nombre de descendants à partir de iqfils et de nbfils
     575    DO iq=1,nqtot   
     576      generation=0
     577      continu=.true.
     578      ifils=iq
     579      do while (continu)
     580        ipere=iqpere(ifils)
     581        if (ipere.gt.0) then
     582         nqdesc(ipere)=nqdesc(ipere)+1   
     583         nqdesc_tot=nqdesc_tot+1     
     584         iqfils(nqdesc(ipere),ipere)=iq
     585         ifils=ipere
     586         generation=generation+1
     587        else !if (ipere.gt.0) then
     588         continu=.false.
     589        endif !if (ipere.gt.0) then
     590      enddo !do while (continu)   
     591      WRITE(lunout,*) 'Le traceur ',iq,', appele ',trim(tnom_0(iq)),' est un traceur de generation: ',generation
     592    enddo !DO iq=1,nqtot
     593    WRITE(lunout,*) 'infotrac: nqdesc=',nqdesc
     594    WRITE(lunout,*) 'iqfils=',iqfils
     595    WRITE(lunout,*) 'nqdesc_tot=',nqdesc_tot
     596
     597! Interdire autres schémas que 10 pour les traceurs fils, et autres schémas
     598! que 10 et 14 si des pères ont des fils
     599    do iq=1,nqtot
     600      if (iqpere(iq).gt.0) then
     601        ! ce traceur a un père qui n'est pas l'air
     602        ! Seul le schéma 10 est autorisé
     603        if (iadv(iq)/=10) then
     604           WRITE(lunout,*)trim(modname),' STOP : The option iadv=',iadv(iq),' is not implemented for sons'
     605          CALL abort_gcm('infotrac_init','Sons should be advected by scheme 10',1)
     606        endif
     607        ! Le traceur père ne peut être advecté que par schéma 10 ou 14:
     608        IF (iadv(iqpere(iq))/=10 .AND. iadv(iqpere(iq))/=14) THEN
     609          WRITE(lunout,*)trim(modname),' STOP : The option iadv=',iadv(iq),' is not implemented for fathers'
     610          CALL abort_gcm('infotrac_init','Fathers should be advected by scheme 10 ou 14',1)
     611        endif !IF (iadv(iqpere(iq))/=10 .AND. iadv(iqpere(iq))/=14) THEN
     612     endif !if (iqpere(iq).gt.0) the
     613    enddo !do iq=1,nqtot
     614
     615
     616! detecter quels sont les traceurs isotopiques parmi des traceurs
     617    call infotrac_isoinit(tnom_0,nqtrue)
     618       
    392619!-----------------------------------------------------------------------
    393620! Finalize :
    394621!
    395     DEALLOCATE(tnom_0, hadv, vadv)
     622    DEALLOCATE(tnom_0, hadv, vadv,tnom_transp)
    396623
    397624
    398625  END SUBROUTINE infotrac_init
    399626
     627  SUBROUTINE infotrac_isoinit(tnom_0,nqtrue)
     628
     629#ifdef CPP_IOIPSL
     630  use IOIPSL
     631#else
     632  ! if not using IOIPSL, we still need to use (a local version of) getin
     633  use ioipsl_getincom
     634#endif
     635  implicit none
     636 
     637    ! inputs
     638    INTEGER nqtrue
     639    CHARACTER(len=15) tnom_0(nqtrue)
     640   
     641    ! locals   
     642    CHARACTER(len=3), DIMENSION(niso_possibles) :: tnom_iso
     643    INTEGER, ALLOCATABLE,DIMENSION(:,:) :: nb_iso,nb_traciso
     644    INTEGER, ALLOCATABLE,DIMENSION(:) :: nb_isoind
     645    INTEGER :: ntraceurs_zone_prec,iq,phase,ixt,iiso,izone
     646    CHARACTER(len=19) :: tnom_trac
     647    INCLUDE "iniprint.h"
     648
     649    tnom_iso=(/'eau','HDO','O18','O17','HTO'/)
     650
     651    ALLOCATE(nb_iso(niso_possibles,nqo))
     652    ALLOCATE(nb_isoind(nqo))
     653    ALLOCATE(nb_traciso(niso_possibles,nqo))
     654    ALLOCATE(iso_num(nqtot))
     655    ALLOCATE(iso_indnum(nqtot))
     656    ALLOCATE(zone_num(nqtot))
     657    ALLOCATE(phase_num(nqtot))
     658     
     659    iso_num(:)=0
     660    iso_indnum(:)=0
     661    zone_num(:)=0
     662    phase_num(:)=0
     663    indnum_fn_num(:)=0
     664    use_iso(:)=.false. 
     665    nb_iso(:,:)=0 
     666    nb_isoind(:)=0     
     667    nb_traciso(:,:)=0
     668    niso=0
     669    ntraceurs_zone=0 
     670    ntraceurs_zone_prec=0
     671    ntraciso=0
     672
     673    do iq=nqo+1,nqtot
     674       write(lunout,*) 'infotrac 569: iq,tnom_0(iq)=',iq,tnom_0(iq)
     675       do phase=1,nqo   
     676        do ixt= 1,niso_possibles   
     677         tnom_trac=trim(tnom_0(phase))//'_'
     678         tnom_trac=trim(tnom_trac)//trim(tnom_iso(ixt))
     679         write(*,*) 'phase,ixt,tnom_trac=',phase,ixt,tnom_trac     
     680         IF (tnom_0(iq) == tnom_trac) then
     681          write(lunout,*) 'Ce traceur est un isotope'
     682          nb_iso(ixt,phase)=nb_iso(ixt,phase)+1   
     683          nb_isoind(phase)=nb_isoind(phase)+1   
     684          iso_num(iq)=ixt
     685          iso_indnum(iq)=nb_isoind(phase)
     686          indnum_fn_num(ixt)=iso_indnum(iq)
     687          phase_num(iq)=phase
     688          write(lunout,*) 'iso_num(iq)=',iso_num(iq)
     689          write(lunout,*) 'iso_indnum(iq)=',iso_indnum(iq)
     690          write(lunout,*) 'indnum_fn_num(ixt)=',indnum_fn_num(ixt)
     691          write(lunout,*) 'phase_num(iq)=',phase_num(iq)
     692          goto 20
     693         else if (iqpere(iq).gt.0) then         
     694          if (tnom_0(iqpere(iq)) == tnom_trac) then
     695           write(lunout,*) 'Ce traceur est le fils d''un isotope'
     696           ! c'est un traceur d'isotope
     697           nb_traciso(ixt,phase)=nb_traciso(ixt,phase)+1
     698           iso_num(iq)=ixt
     699           iso_indnum(iq)=indnum_fn_num(ixt)
     700           zone_num(iq)=nb_traciso(ixt,phase)
     701           phase_num(iq)=phase
     702           write(lunout,*) 'iso_num(iq)=',iso_num(iq)
     703           write(lunout,*) 'phase_num(iq)=',phase_num(iq)
     704           write(lunout,*) 'zone_num(iq)=',zone_num(iq)
     705           goto 20
     706          endif !if (tnom_0(iqpere(iq)) == trim(tnom_0(phase))//trim(tnom_iso(ixt))) then
     707         endif !IF (tnom_0(iq) == trim(tnom_0(phase))//trim(tnom_iso(ixt))) then
     708        enddo !do ixt= niso_possibles
     709       enddo !do phase=1,nqo
     710  20   continue
     711      enddo !do iq=1,nqtot
     712
     713      write(lunout,*) 'iso_num=',iso_num
     714      write(lunout,*) 'iso_indnum=',iso_indnum
     715      write(lunout,*) 'zone_num=',zone_num 
     716      write(lunout,*) 'phase_num=',phase_num
     717      write(lunout,*) 'indnum_fn_num=',indnum_fn_num
     718
     719      do ixt= 1,niso_possibles 
     720
     721        if (nb_iso(ixt,1).eq.1) then
     722          ! on vérifie que toutes les phases ont le même nombre de
     723          ! traceurs
     724          do phase=2,nqo
     725            if (nb_iso(ixt,phase).ne.nb_iso(ixt,1)) then
     726              write(lunout,*) 'ixt,phase,nb_iso=',ixt,phase,nb_iso(ixt,phase)
     727              CALL abort_gcm('infotrac_init','Phases must have same number of isotopes',1)
     728            endif
     729          enddo !do phase=2,nqo
     730
     731          niso=niso+1
     732          use_iso(ixt)=.true.
     733          ntraceurs_zone=nb_traciso(ixt,1)
     734
     735          ! on vérifie que toutes les phases ont le même nombre de
     736          ! traceurs
     737          do phase=2,nqo
     738            if (nb_traciso(ixt,phase).ne.ntraceurs_zone) then
     739              write(lunout,*) 'ixt,phase,nb_traciso=',ixt,phase,nb_traciso(ixt,phase)
     740              write(lunout,*) 'ntraceurs_zone=',ntraceurs_zone
     741              CALL abort_gcm('infotrac_init','Phases must have same number of tracers',1)
     742            endif 
     743          enddo  !do phase=2,nqo
     744          ! on vérifie que tous les isotopes ont le même nombre de
     745          ! traceurs
     746          if (ntraceurs_zone_prec.gt.0) then               
     747            if (ntraceurs_zone.eq.ntraceurs_zone_prec) then
     748              ntraceurs_zone_prec=ntraceurs_zone
     749            else !if (ntraceurs_zone.eq.ntraceurs_zone_prec) then
     750              write(*,*) 'ntraceurs_zone_prec,ntraceurs_zone=',ntraceurs_zone_prec,ntraceurs_zone   
     751              CALL abort_gcm('infotrac_init', &
     752               &'Isotope tracers are not well defined in traceur.def',1)           
     753            endif !if (ntraceurs_zone.eq.ntraceurs_zone_prec) then
     754           endif !if (ntraceurs_zone_prec.gt.0) then
     755
     756        else if (nb_iso(ixt,1).ne.0) then
     757           WRITE(lunout,*) 'nqo,ixt=',nqo,ixt
     758           WRITE(lunout,*) 'nb_iso(ixt,1)=',nb_iso(ixt,1)   
     759           CALL abort_gcm('infotrac_init','Isotopes are not well defined in traceur.def',1)     
     760        endif   !if (nb_iso(ixt,1).eq.1) then       
     761    enddo ! do ixt= niso_possibles
     762
     763    ! dimensions isotopique:
     764    ntraciso=niso*(ntraceurs_zone+1)
     765    WRITE(lunout,*) 'niso=',niso
     766    WRITE(lunout,*) 'ntraceurs_zone,ntraciso=',ntraceurs_zone,ntraciso   
     767 
     768    ! flags isotopiques:
     769    if (niso.gt.0) then
     770        ok_isotopes=.true.
     771    else
     772        ok_isotopes=.false.
     773    endif
     774    WRITE(lunout,*) 'ok_isotopes=',ok_isotopes
     775 
     776    if (ok_isotopes) then
     777        ok_iso_verif=.false.
     778        call getin('ok_iso_verif',ok_iso_verif)
     779        ok_init_iso=.false.
     780        call getin('ok_init_iso',ok_init_iso)
     781        tnat=(/1.0,155.76e-6,2005.2e-6,0.004/100.,0.0/)
     782        alpha_ideal=(/1.0,1.01,1.006,1.003,1.0/)
     783    endif !if (ok_isotopes) then 
     784    WRITE(lunout,*) 'ok_iso_verif=',ok_iso_verif
     785    WRITE(lunout,*) 'ok_init_iso=',ok_init_iso
     786
     787    if (ntraceurs_zone.gt.0) then
     788        ok_isotrac=.true.
     789    else
     790        ok_isotrac=.false.
     791    endif   
     792    WRITE(lunout,*) 'ok_isotrac=',ok_isotrac
     793
     794    ! remplissage du tableau iqiso(ntraciso,phase)
     795    ALLOCATE(iqiso(ntraciso,nqo))   
     796    iqiso(:,:)=0     
     797    do iq=1,nqtot
     798        if (iso_num(iq).gt.0) then
     799          ixt=iso_indnum(iq)+zone_num(iq)*niso
     800          iqiso(ixt,phase_num(iq))=iq
     801        endif
     802    enddo
     803    WRITE(lunout,*) 'iqiso=',iqiso
     804
     805    ! replissage du tableau index_trac(ntraceurs_zone,niso)
     806    ALLOCATE(index_trac(ntraceurs_zone,niso)) 
     807    if (ok_isotrac) then
     808        do iiso=1,niso
     809          do izone=1,ntraceurs_zone
     810             index_trac(izone,iiso)=iiso+izone*niso
     811          enddo
     812        enddo
     813    else !if (ok_isotrac) then     
     814        index_trac(:,:)=0.0
     815    endif !if (ok_isotrac) then
     816    write(lunout,*) 'index_trac=',index_trac   
     817
     818! Finalize :
     819    DEALLOCATE(nb_iso)
     820
     821  END SUBROUTINE infotrac_isoinit
     822
    400823END MODULE infotrac

  • LMDZ5/branches/testing/libf/dyn3dmem/advtrac_loc.F

    r1999 r2298  
    2424      USE Vampir
    2525      USE times
    26       USE infotrac, ONLY: nqtot, iadv
     26      USE infotrac, ONLY: nqtot, iadv, ok_iso_verif
    2727      USE control_mod, ONLY: iapp_tracvl, day_step, planet_type
    2828      USE advtrac_mod, ONLY: finmasse
    … …  
    8282!$OMP THREADPRIVATE(testRequest)
    8383
    84 c  test sur l'eventuelle creation de valeurs negatives de la masse
     84c  test sur l''eventuelle creation de valeurs negatives de la masse
    8585         ijb=ij_begin
    8686         ije=ij_end
    … …  
    155155c$OMP BARRIER
    156156                 
     157          !write(*,*) 'advtrac 157: appel de vlspltgen_loc'
    157158          call vlspltgen_loc( q,iadv, 2., massem, wg ,
    158159     *                        pbarug,pbarvg,dtvr,p,
    159160     *                        pk,teta )
     161
     162          !write(*,*) 'advtrac 162: apres appel vlspltgen_loc'
     163      if (ok_iso_verif) then
     164           call check_isotopes(q,ijb_u,ije_u,'advtrac 162')
     165      endif !if (ok_iso_verif) then
    160166
    161167#ifdef DEBUG_IO     
    … …  
    356362c$OMP END DO
    357363
    358        CALL qminimum_loc( q, 2, finmasse )
     364        ! CRisi: on passe nqtot et non nq
     365       CALL qminimum_loc( q, nqtot, finmasse )
    359366
    360367      endif ! of if (planet_type=="earth")

  • LMDZ5/branches/testing/libf/dyn3dmem/caladvtrac_loc.F

    r1910 r2298  
    5656!$OMP THREADPRIVATE(Request_vanleer)
    5757
    58            
     58      !write(*,*) 'caladvtrac 58: entree'     
    5959      ijbu=ij_begin
    6060      ijeu=ij_end
    … …  
    109109
    110110      IF ( iadvtr.EQ.iapp_tracvl ) THEN
     111      !write(*,*) 'caladvtrac 133'
    111112c$OMP MASTER
    112113        call suspend_timer(timer_caldyn)
    … …  
    183184         CALL WriteField_u('wg1',wg_adv)
    184185#endif       
     186      !write(*,*) 'caladvtrac 185' 
    185187      CALL advtrac_loc( pbarug_adv,pbarvg_adv,wg_adv,
    186188     *             p_adv,  massem_adv,q_adv, teta_adv,
    187      .             pk_adv)
     189     .             pk_adv)     
     190      !write(*,*) 'caladvtrac 189'
    188191
    189192

  • LMDZ5/branches/testing/libf/dyn3dmem/call_calfis_mod.F90

    r2258 r2298  
    227227  !$OMP BARRIER
    228228
     229#ifdef CPP_PHYS
    229230    CALL calfis_loc(lafin ,jD_cur, jH_cur,                       &
    230231                     ucov,vcov,teta,q,masse,ps,p,pk,phis,phi ,   &
    231232                     du,dv,dteta,dq,                             &
    232233                     flxw, dufi,dvfi,dtetafi,dqfi,dpfi  )
    233 
     234#endif
    234235    ijb=ij_begin
    235236    ije=ij_end 

  • LMDZ5/branches/testing/libf/dyn3dmem/dynetat0_loc.F

    r1999 r2298  
    366366           write(lunout,*)"Il est donc initialise a zero"
    367367           q(:,:,iq)=0.
     368
     369           ! CRisi: pour les isotopes, on peut faire init théorique
     370           ! distill de Rayleigh très simplifiée
     371           if (ok_isotopes) then
     372              if ((iso_num(iq).gt.0).and.(zone_num(iq).eq.0)) then
     373                q(:,:,iq)=q(:,:,iqpere(iq))                             &
     374     &                   *tnat(iso_num(iq))                             &
     375     &                   *(q(:,:,iqpere(iq))/30.e-3)                    &
     376     &                   **(alpha_ideal(iso_num(iq))-1)
     377              endif
     378              if ((iso_num(iq).gt.0).and.(zone_num(iq).eq.1)) then
     379                  q(:,:,iq)=q(:,:,iqiso(iso_indnum(iq),phase_num(iq)))
     380              endif 
     381           endif !if (ok_isotopes) then       
     382
    368383        ELSE
    369384#ifdef NC_DOUBLE
    … …  
    380395
    381396        ENDIF
    382       ENDDO
     397      ENDDO !DO iq=1,nqtot
     398
     399      if (ok_iso_verif) then
     400         call check_isotopes(q,ijb_u,ije_u,'dynetat0_loc')
     401      endif !if (ok_iso_verif) then
    383402
    384403      DEALLOCATE(q_glo)

  • LMDZ5/branches/testing/libf/dyn3dmem/guide_loc_mod.F90

    r2160 r2298  
    8787! Lecture des parametres: 
    8888! ---------------------------------------------
     89    call ini_getparam("nudging_parameters_out.txt")
    8990! Variables guidees
    9091    CALL getpar('guide_u',.true.,guide_u,'guidage de u')
    … …  
    159160    CALL getpar('guide_2D',.false.,guide_2D,'fichier guidage lat-P')
    160161
     162    call fin_getparam
     163   
    161164! ---------------------------------------------
    162165! Determination du nombre de niveaux verticaux

  • LMDZ5/branches/testing/libf/dyn3dmem/iniacademic_loc.F90

    r2160 r2298  
    77  use exner_hyb_m, only: exner_hyb
    88  use exner_milieu_m, only: exner_milieu
    9   USE infotrac, ONLY : nqtot
     9  USE infotrac, ONLY: nqtot,niso_possibles,ok_isotopes,iqpere,ok_iso_verif,tnat,alpha_ideal, &
     10        & iqiso,phase_num,iso_indnum,iso_num,zone_num
    1011  USE control_mod, ONLY: day_step,planet_type
    1112  USE parallel_lmdz, ONLY: ijb_u, ije_u, ijb_v, ije_v
    … …  
    110111  ztot0      = 0.
    111112  stot0      = 0.
    112   ang0       = 0.
     113  ang0       = 0.     
    113114
    114115  if (llm == 1) then
    … …  
    269270        if (planet_type=="earth") then
    270271           ! Earth: first two tracers will be water
     272
    271273           do i=1,nqtot
    272274              if (i == 1) q(ijb_u:ije_u,:,i)=1.e-10
    273275              if (i == 2) q(ijb_u:ije_u,:,i)=1.e-15
    274276              if (i.gt.2) q(ijb_u:ije_u,:,i)=0.
     277
     278              ! CRisi: init des isotopes
     279              ! distill de Rayleigh très simplifiée
     280              if (ok_isotopes) then
     281                if ((iso_num(i).gt.0).and.(zone_num(i).eq.0)) then         
     282                   q(ijb_u:ije_u,:,i)=q(ijb_u:ije_u,:,iqpere(i))       &
     283      &                  *tnat(iso_num(i))                             &
     284      &                  *(q(ijb_u:ije_u,:,iqpere(i))/30.e-3)                              &
     285     &                   **(alpha_ideal(iso_num(i))-1)
     286                endif               
     287                if ((iso_num(i).gt.0).and.(zone_num(i).eq.1)) then
     288                  q(ijb_u:ije_u,:,i)=q(ijb_u:ije_u,:,iqiso(iso_indnum(i),phase_num(i)))
     289                endif
     290              endif !if (ok_isotopes) then
     291
    275292           enddo
    276293        else
    277294           q(ijb_u:ije_u,:,:)=0
    278295        endif ! of if (planet_type=="earth")
     296
     297        if (ok_iso_verif) then
     298           call check_isotopes(q,ijb_u,ije_u,'iniacademic_loc')
     299        endif !if (ok_iso_verif) then
    279300
    280301        ! add random perturbation to temperature

  • LMDZ5/branches/testing/libf/dyn3dmem/integrd_loc.F

    r2160 r2298  
    1111      USE write_field
    1212      USE integrd_mod
     13      USE infotrac, ONLY: ok_iso_verif ! ajout CRisi
    1314      IMPLICIT NONE
    1415
    … …  
    8687      INTEGER :: ierr
    8788
     89      !write(*,*) 'integrd 88: entree, nq=',nq
    8890c-----------------------------------------------------------------------
     91
    8992c$OMP BARRIER     
    9093      if (pole_nord) THEN
    … …  
    125128      DO 2 ij = ijb,ije
    126129       pscr (ij)    = ps0(ij)
    127        ps (ij)      = psm1(ij) + dt * dp(ij)
     130       ps (ij)      = psm1(ij) + dt * dp(ij)     
     131
    128132   2  CONTINUE
     133
    129134c$OMP END DO 
    130135c$OMP BARRIER
    … …  
    159164c$OMP END MASTER
    160165c$OMP BARRIER
     166        !write(*,*) 'integrd 170'
    161167      IF (.NOT. Checksum_all) THEN
    162168        call WriteField_v('int_vcov',vcov)
    … …  
    188194       
    189195c
     196        !write(*,*) 'integrd 200'
    190197C$OMP MASTER
    191198      if (pole_nord) THEN
    … …  
    214221c$OMP END MASTER
    215222c$OMP BARRIER
     223      !write(*,*) 'integrd 217' 
    216224c
    217225c  ... Calcul  de la nouvelle masse d'air au dernier temps integre t+1 ...
    … …  
    219227
    220228      CALL pression_loc ( ip1jmp1, ap, bp, ps, p )
     229
    221230c$OMP BARRIER
    222231      CALL massdair_loc (     p  , masse         )
    … …  
    276285c
    277286c
     287        !write(*,*) 'integrd 291'
    278288      IF (pole_nord) THEN
    279289       
    … …  
    334344           ENDDO
    335345          ENDDO
     346         
    336347c$OMP END DO NOWAIT
    337348c$OMP BARRIER
    338349
    339           CALL qminimum_loc( q, nq, deltap )
     350        if (ok_iso_verif) then
     351           call check_isotopes(q,ijb,ije,'integrd 342')
     352        endif !if (ok_iso_verif) then
     353
     354        !write(*,*) 'integrd 341'
     355        CALL qminimum_loc( q, nq, deltap )
     356        !write(*,*) 'integrd 343'
     357
     358        if (ok_iso_verif) then
     359           call check_isotopes(q,ijb,ije,'integrd 346')
     360        endif !if (ok_iso_verif) then
    340361c
    341362c    .....  Calcul de la valeur moyenne, unique  aux poles pour  q .....
    … …  
    387408     
    388409      ENDIF
     410
     411        if (ok_iso_verif) then
     412           call check_isotopes(q,ijb,ije,'integrd 409')
     413        endif !if (ok_iso_verif) then
    389414     
    390415! Ehouarn: forget about finvmaold
    … …  
    404429
    40543015    continue
     431          !write(*,*) 'integrd 410'
    406432
    407433c$OMP DO SCHEDULE(STATIC)

  • LMDZ5/branches/testing/libf/dyn3dmem/leapfrog_loc.F

    r2258 r2298  
    200200      LOGICAL, SAVE :: firstcall=.TRUE.
    201201      TYPE(distrib),SAVE :: new_dist
     202
     203      if (ok_iso_verif) then
     204         call check_isotopes(q0,ijb_u,ije_u,'leapfrog204: debut')
     205      endif !if (ok_iso_verif) then
    202206     
    203207c$OMP MASTER
    … …  
    219223      itaufinp1 = itaufin +1
    220224
     225      if (ok_iso_verif) then
     226        call check_isotopes(q0,ijb_u,ije_u,'leapfrog 226')
     227      endif !if (ok_iso_verif) then
     228
    221229      itau = 0
    222230      physic=.true.
    … …  
    231239      phis=phis0
    232240      q=q0
     241
     242      if (ok_iso_verif) then
     243        call check_isotopes(q,ijb_u,ije_u,'leapfrog 239')
     244      endif !if (ok_iso_verif) then
    233245     
    234246!      iday = day_ini+itau/day_step
    … …  
    296308
    297309   1  CONTINUE ! Matsuno Forward step begins here
    298 
     310      !write(*,*) 'leapfrog 298: itau=',itau
    299311      jD_cur = jD_ref + day_ini - day_ref +                             &
    300312     &          itau/day_step
    … …  
    306318      endif
    307319
     320        if (ok_iso_verif) then
     321           call check_isotopes(q,ijb_u,ije_u,'leapfrog 321')
     322        endif !if (ok_iso_verif) then
    308323
    309324#ifdef CPP_IOIPSL
    … …  
    384399cym      call minmax(ijp1llm,q(:,:,3),zqmin,zqmax)
    385400
     401
     402        if (ok_iso_verif) then
     403           call check_isotopes(q,ijb_u,ije_u,'leapfrog 400')
     404        endif !if (ok_iso_verif) then
     405
    386406   2  CONTINUE ! Matsuno backward or leapfrog step begins here
     407
     408
     409        if (ok_iso_verif) then
     410           call check_isotopes(q,ijb_u,ije_u,'leapfrog 402')
     411        endif !if (ok_iso_verif) then
    387412
    388413c$OMP MASTER
    … …  
    455480c$OMP END MASTER     
    456481
     482
     483        if (ok_iso_verif) then
     484           call check_isotopes(q,ijb_u,ije_u,'leapfrog 471')
     485        endif !if (ok_iso_verif) then
    457486
    458487!ym  PAS D'AJUSTEMENT POUR LE MOMENT     
    … …  
    574603     
    575604     
     605        if (ok_iso_verif) then
     606           call check_isotopes(q,ijb_u,ije_u,'leapfrog 589')
     607        endif !if (ok_iso_verif) then
    576608     
    577609c-----------------------------------------------------------------------
    … …  
    635667      ! compute geopotential phi()
    636668      CALL geopot_loc  ( ip1jmp1, teta  , pk , pks,  phis  , phi   )
    637 
     669       
     670        if (ok_iso_verif) then
     671           call check_isotopes(q,ijb_u,ije_u,'leapfrog 651')
     672        endif !if (ok_iso_verif) then
    638673     
    639674      call VTb(VTcaldyn)
    … …  
    644679!      CALL FTRACE_REGION_BEGIN("caldyn")
    645680      time = jD_cur + jH_cur
     681
    646682      CALL caldyn_loc
    647683     $  ( itau,ucov,vcov,teta,ps,masse,pk,pkf,phis ,
    … …  
    670706c   -------------------------------------------------------------
    671707
     708        if (ok_iso_verif) then
     709           call check_isotopes(q,ijb_u,ije_u,
     710     &           'leapfrog 686: avant caladvtrac')
     711        endif !if (ok_iso_verif) then
    672712     
    673713      IF( forward. OR . leapf )  THEN
    674714! Ehouarn: NB: fields sent to advtrac are those at the beginning of the time step
     715        !write(*,*) 'leapfrog 679: avant CALL caladvtrac_loc'
    675716         CALL caladvtrac_loc(q,pbaru,pbarv,
    676717     *        p, masse, dq,  teta,
    677718     .        flxw,pk, iapptrac)
     719
     720         !write(*,*) 'leapfrog 719'
     721         if (ok_iso_verif) then
     722           call check_isotopes(q,ijb_u,ije_u,
     723     &           'leapfrog 698: apres caladvtrac')
     724         endif !if (ok_iso_verif) then
    678725
    679726!      do j=1,nqtot
    … …  
    708755!       CALL FTRACE_REGION_BEGIN("integrd")
    709756
    710        CALL integrd_loc ( 2,vcovm1,ucovm1,tetam1,psm1,massem1 ,
     757       !write(*,*) 'leapfrog 720'
     758        if (ok_iso_verif) then
     759           call check_isotopes(q,ijb_u,ije_u,'leapfrog 756')
     760        endif !if (ok_iso_verif) then
     761
     762       ! CRisi: pourquoi aller jusqu'à 2 et non pas jusqu'à nqtot??
     763       CALL integrd_loc ( nqtot,vcovm1,ucovm1,tetam1,psm1,massem1 ,
    711764     $         dv,du,dteta,dq,dp,vcov,ucov,teta,q,ps,masse,phis)
    712765!     $              finvmaold                                    )
    713766
     767       !write(*,*) 'leapfrog 724'       
     768        if (ok_iso_verif) then
     769           call check_isotopes(q,ijb_u,ije_u,'leapfrog 762')
     770        endif !if (ok_iso_verif) then
     771 
    714772!       CALL FTRACE_REGION_END("integrd")
    715773c$OMP BARRIER
    … …  
    724782      call WriteField_u('ps_int',ps)
    725783#endif   
     784
     785        if (ok_iso_verif) then
     786           call check_isotopes(q,ijb_u,ije_u,'leapfrog 775')
     787        endif !if (ok_iso_verif) then
     788
    726789c      do j=1,nqtot
    727790c        call WriteField_p('q'//trim(int2str(j)),
    … …  
    10821145       ENDIF ! of IF( apphys )
    10831146
     1147        if (ok_iso_verif) then
     1148           call check_isotopes(q,ijb_u,ije_u,'leapfrog 1132')
     1149        endif !if (ok_iso_verif) then
     1150        !write(*,*) 'leapfrog 1134: iflag_phys=',iflag_phys
     1151
    10841152      IF(iflag_phys.EQ.2) THEN ! "Newtonian" case
    10851153c$OMP MASTER
    … …  
    11461214
    11471215cc$OMP END PARALLEL
     1216        if (ok_iso_verif) then
     1217           call check_isotopes(q,ijb_u,ije_u,'leapfrog 1196')
     1218        endif !if (ok_iso_verif) then
    11481219
    11491220c-----------------------------------------------------------------------
    11501221c   dissipation horizontale et verticale  des petites echelles:
    11511222c   ----------------------------------------------------------
    1152 
     1223      !write(*,*) 'leapfrog 1163: apdiss=',apdiss
    11531224      IF(apdiss) THEN
    11541225     
    … …  
    13791450c                call abort_gcm(modname,abort_message,0)
    13801451c              ENDIF
    1381        
     1452
     1453        if (ok_iso_verif) then
     1454           call check_isotopes(q,ijb_u,ije_u,'leapfrog 1430')
     1455        endif !if (ok_iso_verif) then     
     1456 
    13821457c   ********************************************************************
    13831458c   ********************************************************************
    … …  
    14551530      ENDIF
    14561531     
     1532        if (ok_iso_verif) then
     1533           call check_isotopes(q,ijb_u,ije_u,'leapfrog 1509')
     1534        endif !if (ok_iso_verif) then
     1535
    14571536      IF ( .NOT.purmats ) THEN
    14581537c       ........................................................
    … …  
    15261605            ENDIF
    15271606
     1607        if (ok_iso_verif) then
     1608           call check_isotopes(q,ijb_u,ije_u,'leapfrog 1584')
     1609        endif !if (ok_iso_verif) then
     1610
    15281611c-----------------------------------------------------------------------
    15291612c   ecriture de la bande histoire:
    … …  
    15621645            ENDIF ! of IF (itau.EQ.itaufin)
    15631646
     1647        if (ok_iso_verif) then
     1648           call check_isotopes(q,ijb_u,ije_u,'leapfrog 1624')
     1649        endif !if (ok_iso_verif) then
     1650
    15641651c-----------------------------------------------------------------------
    15651652c   gestion de l'integration temporelle:
    … …  
    15961683
    15971684      ELSE ! of IF (.not.purmats)
     1685
     1686
     1687        if (ok_iso_verif) then
     1688           call check_isotopes(q,ijb_u,ije_u,'leapfrog 1664')
     1689        endif !if (ok_iso_verif) then
    15981690
    15991691c       ........................................................
    … …  
    16311723
    16321724            ELSE ! of IF(forward) i.e. backward step
     1725
     1726             
     1727        if (ok_iso_verif) then
     1728           call check_isotopes(q,ijb_u,ije_u,'leapfrog 1698')
     1729        endif !if (ok_iso_verif) then 
    16331730
    16341731              IF(MOD(itau,iperiod).EQ.0 .OR. itau.EQ.itaufin) THEN
    … …  
    16831780            ENDIF ! of IF (forward)
    16841781
     1782
     1783        if (ok_iso_verif) then
     1784           call check_isotopes(q,ijb_u,ije_u,'leapfrog 1750')
     1785        endif !if (ok_iso_verif) then
     1786
    16851787      END IF ! of IF(.not.purmats)
    16861788c$OMP MASTER

  • LMDZ5/branches/testing/libf/dyn3dmem/qminimum_loc.F

    r1910 r2298  
    1       SUBROUTINE qminimum_loc( q,nq,deltap )
     1      SUBROUTINE qminimum_loc( q,nqtot,deltap )
    22      USE parallel_lmdz
     3      USE infotrac, ONLY: ok_isotopes,ntraciso,iqiso,ok_iso_verif
    34      IMPLICIT none
    45c
    … …  
    1011#include "comvert.h"
    1112c
    12       INTEGER nq
    13       REAL q(ijb_u:ije_u,llm,nq), deltap(ijb_u:ije_u,llm)
     13      INTEGER nqtot ! CRisi: on remplace nq par nqtot
     14      REAL q(ijb_u:ije_u,llm,nqtot), deltap(ijb_u:ije_u,llm)
    1415c
    1516      INTEGER iq_vap, iq_liq
    … …  
    2728      INTEGER i, k, iq
    2829      REAL zx_defau, zx_abc, zx_pump(ijb_u:ije_u), pompe
     30
     31      real zx_defau_diag(ijb_u:ije_u,llm,2)
     32      real q_follow(ijb_u:ije_u,llm,2)
    2933c
    3034      REAL SSUM
    … …  
    3842      INTEGER Index_pump(ij_end-ij_begin+1)
    3943      INTEGER nb_pump
     44      INTEGER ixt
     45      INTEGER iso_verif_noNaN_nostop
    4046c
    4147c Quand l'eau liquide est trop petite (ou negative), on prend
    … …  
    4450c
    4551
     52        !write(*,*) 'qminimum 52: entree'
     53        if (ok_iso_verif) then
     54           call check_isotopes(q,ij_begin,ij_end,'qminimum 52')   
     55        endif !if (ok_iso_verif) then     
     56
    4657      ijb=ij_begin
    4758      ije=ij_end
    4859
     60      zx_defau_diag(ijb:ije,:,:)=0.0
     61      q_follow(ijb:ije,:,1:2)=q(ijb:ije,:,1:2) 
     62
     63      !write(*,*) 'qminimum 57'
    4964c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)       
    5065      DO 1000 k = 1, llm
    5166      DO 1040 i = ijb, ije
    5267            if (seuil_liq - q(i,k,iq_liq) .gt. 0.d0 ) then
     68
     69              if (ok_isotopes) then
     70                 zx_defau_diag(i,k,iq_liq)=AMAX1
     71     :               ( seuil_liq - q(i,k,iq_liq), 0.0 )
     72              endif !if (ok_isotopes) then
     73
    5374               q(i,k,iq_vap) = q(i,k,iq_vap) + q(i,k,iq_liq) - seuil_liq
    5475               q(i,k,iq_liq) = seuil_liq
    … …  
    6081c --->  SYNCHRO OPENMP ICI
    6182
     83
    6284c
    6385c Quand l'eau vapeur est trop faible (ou negative), on complete
    6486c le defaut en prennant de l'eau vapeur de la couche au-dessous.
    6587c
     88      !write(*,*) 'qminimum 81'
    6689      iq = iq_vap
    6790c
    … …  
    7093c$OMP DO SCHEDULE(STATIC)
    7194      DO i = ijb, ije
     95
    7296         if ( seuil_vap - q(i,k,iq) .gt. 0.d0 ) then
     97
     98            if (ok_isotopes) then
     99              zx_defau_diag(i,k,iq)=AMAX1( seuil_vap - q(i,k,iq), 0.0 )
     100            endif !if (ok_isotopes) then
     101
    73102            q(i,k-1,iq) =  q(i,k-1,iq) - ( seuil_vap - q(i,k,iq) ) *
    74103     &           deltap(i,k) / deltap(i,k-1)
    75104            q(i,k,iq)   =  seuil_vap 
     105
    76106         endif
    77107      ENDDO
    … …  
    79109      ENDDO
    80110c$OMP BARRIER
     111
    81112c
    82113c Quand il s'agit de la premiere couche au-dessus du sol, on
    83114c doit imprimer un message d'avertissement (saturation possible).
    84115c
     116      !write(*,*) 'qminimum 106'
    85117      nb_pump=0
    86118c$OMP DO SCHEDULE(STATIC)
    … …  
    103135         ENDDO
    104136      ENDIF
     137
     138      !write(*,*) 'qminimum 128'
     139      if (ok_isotopes) then
     140      ! CRisi: traiter de même les traceurs d'eau
     141      ! Mais il faut les prendre à l'envers pour essayer de conserver la
     142      ! masse.
     143      ! 1) pompage dans le sol 
     144      ! On suppose que ce pompage se fait sans isotopes -> on ne modifie
     145      ! rien ici et on croise les doigts pour que ça ne soit pas trop
     146      ! génant
     147      DO i = ijb, ije
     148        if (zx_pump(i).gt.0.0) then
     149          q_follow(i,1,iq_vap)=q_follow(i,1,iq_vap)+zx_pump(i)
     150        endif !if (zx_pump(i).gt.0.0) then
     151      enddo !DO i = ijb, ije 
     152
     153      ! 2) transfert de vap vers les couches plus hautes
     154      !write(*,*) 'qminimum 139'
     155      do k=2,llm
     156        DO i = ijb, ije
     157          if (zx_defau_diag(i,k,iq_vap).gt.0.0) then             
     158              ! on ajoute la vapeur en k             
     159              do ixt=1,ntraciso
     160               q(i,k,iqiso(ixt,iq_vap))=q(i,k,iqiso(ixt,iq_vap))
     161     :              +zx_defau_diag(i,k,iq_vap)
     162     :              *q(i,k-1,iqiso(ixt,iq_vap))/q_follow(i,k-1,iq_vap)
     163               
     164              if (ok_iso_verif) then
     165                if (iso_verif_noNaN_nostop(q(i,k,iqiso(ixt,iq_vap)),
     166     :                   'qminimum 155').eq.1) then
     167                   write(*,*) 'i,k,ixt=',i,k,ixt
     168                   write(*,*) 'q_follow(i,k-1,iq_vap)=',
     169     :                   q_follow(i,k-1,iq_vap)
     170                   write(*,*) 'q(i,k,iqiso(ixt,iq_vap))=',
     171     :                   q(i,k,iqiso(ixt,iq_vap))
     172                   write(*,*) 'zx_defau_diag(i,k,iq_vap)=',
     173     :                   zx_defau_diag(i,k,iq_vap)
     174                   write(*,*) 'q(i,k-1,iqiso(ixt,iq_vap))=',
     175     :                   q(i,k-1,iqiso(ixt,iq_vap))
     176                   stop
     177                endif
     178              endif
     179
     180              ! et on la retranche en k-1
     181               q(i,k-1,iqiso(ixt,iq_vap))=q(i,k-1,iqiso(ixt,iq_vap))
     182     :              -zx_defau_diag(i,k,iq_vap)
     183     :              *deltap(i,k)/deltap(i,k-1)
     184     :              *q(i,k-1,iqiso(ixt,iq_vap))/q_follow(i,k-1,iq_vap)
     185
     186               if (ok_iso_verif) then
     187                if (iso_verif_noNaN_nostop(q(i,k-1,iqiso(ixt,iq_vap)),
     188     :                   'qminimum 175').eq.1) then
     189                   write(*,*) 'k,i,ixt=',k,i,ixt
     190                   write(*,*) 'q_follow(i,k-1,iq_vap)=',
     191     :                   q_follow(i,k-1,iq_vap)
     192                   write(*,*) 'q(i,k,iqiso(ixt,iq_vap))=',
     193     :                   q(i,k,iqiso(ixt,iq_vap))
     194                   write(*,*) 'zx_defau_diag(i,k,iq_vap)=',
     195     :                   zx_defau_diag(i,k,iq_vap)
     196                   write(*,*) 'q(i,k-1,iqiso(ixt,iq_vap))=',
     197     :                   q(i,k-1,iqiso(ixt,iq_vap))
     198                   stop
     199                endif
     200              endif
     201
     202              enddo !do ixt=1,niso
     203              q_follow(i,k,iq_vap)=   q_follow(i,k,iq_vap)
     204     :               +zx_defau_diag(i,k,iq_vap)
     205              q_follow(i,k-1,iq_vap)=   q_follow(i,k-1,iq_vap)
     206     :               -zx_defau_diag(i,k,iq_vap)
     207     :              *deltap(i,k)/deltap(i,k-1)
     208          endif !if (zx_defau_diag(i,k,iq_vap).gt.0.0) then
     209        enddo !DO i = 1, ip1jmp1       
     210       enddo !do k=2,llm
     211
     212        if (ok_iso_verif) then
     213           call check_isotopes(q,ijb,ije,'qminimum 168')
     214        endif !if (ok_iso_verif) then
     215       
     216     
     217        ! 3) transfert d'eau de la vapeur au liquide
     218        !write(*,*) 'qminimum 164'
     219        do k=1,llm
     220        DO i = ijb, ije
     221          if (zx_defau_diag(i,k,iq_liq).gt.0.0) then
     222
     223              ! on ajoute eau liquide en k en k             
     224              do ixt=1,ntraciso
     225               q(i,k,iqiso(ixt,iq_liq))=q(i,k,iqiso(ixt,iq_liq))
     226     :              +zx_defau_diag(i,k,iq_liq)
     227     :              *q(i,k,iqiso(ixt,iq_vap))/q_follow(i,k,iq_vap)
     228              ! et on la retranche à la vapeur en k
     229               q(i,k,iqiso(ixt,iq_vap))=q(i,k,iqiso(ixt,iq_vap))
     230     :              -zx_defau_diag(i,k,iq_liq)
     231     :              *q(i,k,iqiso(ixt,iq_vap))/q_follow(i,k,iq_vap)   
     232              enddo !do ixt=1,niso
     233              q_follow(i,k,iq_liq)=   q_follow(i,k,iq_liq)
     234     :               +zx_defau_diag(i,k,iq_liq)
     235              q_follow(i,k,iq_vap)=   q_follow(i,k,iq_vap)
     236     :               -zx_defau_diag(i,k,iq_liq)
     237          endif !if (zx_defau_diag(i,k,iq_vap).gt.0.0) then
     238        enddo !DO i = 1, ip1jmp1
     239       enddo !do k=2,llm 
     240
     241        if (ok_iso_verif) then
     242           call check_isotopes(q,ijb,ije,'qminimum 197')
     243        endif !if (ok_iso_verif) then
     244
     245      endif !if (ok_isotopes) then
     246      !write(*,*) 'qminimum 188'
    105247c
    106248      RETURN

  • LMDZ5/branches/testing/libf/dyn3dmem/vlsplt_loc.F

    r1910 r2298  
    22! $Id$
    33!
    4       SUBROUTINE vlx_loc(q,pente_max,masse,u_m,ijb_x,ije_x)
     4      RECURSIVE SUBROUTINE vlx_loc(q,pente_max,masse,u_m,ijb_x,ije_x,iq)
    55
    66c     Auteurs:   P.Le Van, F.Hourdin, F.Forget
    … …  
    1414c   --------------------------------------------------------------------
    1515      USE parallel_lmdz
     16      USE infotrac, ONLY : nqtot,nqfils,nqdesc,iqfils ! CRisi
    1617      IMPLICIT NONE
    1718c
    … …  
    2526c   Arguments:
    2627c   ----------
    27       REAL masse(ijb_u:ije_u,llm),pente_max
    28       REAL u_m( ijb_u:ije_u,llm ),pbarv( iip1,jjb_v:jje_v,llm)
    29       REAL q(ijb_u:ije_u,llm)
    30       REAL w(ijb_u:ije_u,llm)
     28      REAL masse(ijb_u:ije_u,llm,nqtot),pente_max
     29      REAL u_m( ijb_u:ije_u,llm),pbarv( iip1,jjb_v:jje_v,llm)
     30      REAL q(ijb_u:ije_u,llm,nqtot) ! CRisi: ajout dimension nqtot
     31      REAL w(ijb_u:ije_u,llm)
     32      INTEGER iq ! CRisi
    3133c
    3234c      Local
    … …  
    4244      REAL u_mq(ijb_u:ije_u,llm)
    4345
     46      REAL Ratio(ijb_u:ije_u,llm,nqtot) ! CRisi
     47      INTEGER ifils,iq2 ! CRisi
     48
    4449      Logical extremum
    4550
    … …  
    5156      INTEGER ijb,ije,ijb_x,ije_x
    5257     
     58      !write(*,*) 'vlsplt 58: entree dans vlx_loc, iq,ijb_x=',
     59!     &   iq,ijb_x
    5360c   calcul de la pente a droite et a gauche de la maille
    5461
    … …  
    6471c   calcul des pentes avec limitation, Van Leer scheme I:
    6572c   -----------------------------------------------------
    66 
     73      ! on a besoin de q entre ijb et ije
    6774c   calcul de la pente aux points u
    6875c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)         
    … …  
    7077           
    7178            DO ij=ijb,ije-1
    72                dxqu(ij)=q(ij+1,l)-q(ij,l)
     79               dxqu(ij)=q(ij+1,l,iq)-q(ij,l,iq)
    7380c              IF(u_m(ij,l).lt.0.) stop'limx n admet pas les U<0'
    74 c              sigu(ij)=u_m(ij,l)/masse(ij,l)
     81c              sigu(ij)=u_m(ij,l)/masse(ij,l,iq)
    7582            ENDDO
    7683            DO ij=ijb+iip1-1,ije,iip1
    … …  
    126133         DO l = 1, llm
    127134            DO ij=ijb,ije-1
    128                dxqu(ij)=q(ij+1,l)-q(ij,l)
     135               dxqu(ij)=q(ij+1,l,iq)-q(ij,l,iq)
    129136            ENDDO
    130137            DO ij=ijb+iip1-1,ije,iip1
    … …  
    147154      ENDIF ! (pente_max.lt.-1.e-5)
    148155
     156      !write(*,*) 'vlx 156: iq,ijb_x=',iq,ijb_x
     157
    149158c   bouclage de la pente en iip1:
    150159c   -----------------------------
    … …  
    168177      DO l=1,llm
    169178       DO ij=ijb,ije-1
    170           zdum(ij,l)=cvmgp(1.-u_m(ij,l)/masse(ij,l),
    171      ,                     1.+u_m(ij,l)/masse(ij+1,l),
    172      ,                     u_m(ij,l))
     179          zdum(ij,l)=cvmgp(1.-u_m(ij,l)/masse(ij,l,iq),
     180     ,                     1.+u_m(ij,l)/masse(ij+1,l,iq),
     181     ,                     u_m(ij,l,iq))
    173182          zdum(ij,l)=0.5*zdum(ij,l)
    174183          u_mq(ij,l)=cvmgp(
    175      ,                q(ij,l)+zdum(ij,l)*dxq(ij,l),
    176      ,                q(ij+1,l)-zdum(ij,l)*dxq(ij+1,l),
     184     ,                q(ij,l,iq)+zdum(ij,l)*dxq(ij,l),
     185     ,                q(ij+1,l,iq)-zdum(ij,l)*dxq(ij+1,l),
    177186     ,                u_m(ij,l))
    178187          u_mq(ij,l)=u_m(ij,l)*u_mq(ij,l)
    … …  
    185194c       print*,'Cumule ....'
    186195c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     196        ! on a besoin de masse entre ijb et ije
    187197      DO l=1,llm
    188198       DO ij=ijb,ije-1
    189 c       print*,'masse(',ij,')=',masse(ij,l)
     199c       print*,'masse(',ij,')=',masse(ij,l,iq)
    190200          IF (u_m(ij,l).gt.0.) THEN
    191              zdum(ij,l)=1.-u_m(ij,l)/masse(ij,l)
    192              u_mq(ij,l)=u_m(ij,l)*(q(ij,l)+0.5*zdum(ij,l)*dxq(ij,l))
     201             zdum(ij,l)=1.-u_m(ij,l)/masse(ij,l,iq)
     202             u_mq(ij,l)=u_m(ij,l)*(q(ij,l,iq)
     203     :           +0.5*zdum(ij,l)*dxq(ij,l))
    193204          ELSE
    194              zdum(ij,l)=1.+u_m(ij,l)/masse(ij+1,l)
    195              u_mq(ij,l)=u_m(ij,l)*(q(ij+1,l)-0.5*zdum(ij,l)*dxq(ij+1,l))
     205             zdum(ij,l)=1.+u_m(ij,l)/masse(ij+1,l,iq)
     206             u_mq(ij,l)=u_m(ij,l)*(q(ij+1,l,iq)
     207     :           -0.5*zdum(ij,l)*dxq(ij+1,l))
    196208          ENDIF
    197209       ENDDO
    … …  
    215227c$OMP END DO NOWAIT
    216228c       print*,'Ok test 1'
     229
    217230c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    218231      DO l=1,llm
    … …  
    223236c$OMP END DO NOWAIT
    224237c        print*,'Ok test 2'
    225 
     238       
    226239
    227240c   traitement special pour le cas ou on advecte en longitude plus que le
    … …  
    247260c     &       ,'contenu de la maille : ',n0
    248261c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     262
     263
    249264         DO l=1,llm
    250265            IF(nl(l).gt.0) THEN
    … …  
    258273               ENDDO
    259274               niju=iju
    260 c              PRINT*,'niju,nl',niju,nl(l)
     275               !PRINT*,'vlx 278, niju,nl',niju,nl(l)
    261276
    262277c  traitement des mailles
    … …  
    270285                     i=ijq-(j-1)*iip1
    271286c   accumulation pour les mailles completements advectees
    272                      do while(zu_m.gt.masse(ijq,l))
    273                         u_mq(ij,l)=u_mq(ij,l)+q(ijq,l)*masse(ijq,l)
    274                         zu_m=zu_m-masse(ijq,l)
     287                     do while(zu_m.gt.masse(ijq,l,iq))
     288                        u_mq(ij,l)=u_mq(ij,l)
     289     &                          +q(ijq,l,iq)*masse(ijq,l,iq)
     290                        zu_m=zu_m-masse(ijq,l,iq)
    275291                        i=mod(i-2+iim,iim)+1
    276292                        ijq=(j-1)*iip1+i
    … …  
    278294c   ajout de la maille non completement advectee
    279295                     u_mq(ij,l)=u_mq(ij,l)+zu_m*
    280      &               (q(ijq,l)+0.5*(1.-zu_m/masse(ijq,l))*dxq(ijq,l))
     296     &               (q(ijq,l,iq)+0.5*
     297     &               (1.-zu_m/masse(ijq,l,iq))*dxq(ijq,l))
    281298                  ELSE
    282299                     ijq=ij+1
    283300                     i=ijq-(j-1)*iip1
    284301c   accumulation pour les mailles completements advectees
    285                      do while(-zu_m.gt.masse(ijq,l))
    286                         u_mq(ij,l)=u_mq(ij,l)-q(ijq,l)*masse(ijq,l)
    287                         zu_m=zu_m+masse(ijq,l)
     302                     do while(-zu_m.gt.masse(ijq,l,iq))
     303                        u_mq(ij,l)=u_mq(ij,l)-q(ijq,l,iq)
     304     &                           *masse(ijq,l,iq)
     305                        zu_m=zu_m+masse(ijq,l,iq)
    288306                        i=mod(i,iim)+1
    289307                        ijq=(j-1)*iip1+i
    290308                     ENDDO
    291309c   ajout de la maille non completement advectee
    292                      u_mq(ij,l)=u_mq(ij,l)+zu_m*(q(ijq,l)-
    293      &               0.5*(1.+zu_m/masse(ijq,l))*dxq(ijq,l))
     310                     u_mq(ij,l)=u_mq(ij,l)+zu_m*(q(ijq,l,iq)-
     311     &               0.5*(1.+zu_m/masse(ijq,l,iq))*dxq(ijq,l))
    294312                  ENDIF
    295313               ENDDO
    … …  
    299317cym      ENDIF  ! n0.gt.0
    3003189999    continue
    301 
    302319
    303320c   bouclage en latitude
    … …  
    311328c$OMP END DO NOWAIT
    312329
     330! CRisi: appel récursif de l'advection sur les fils.
     331! Il faut faire ça avant d'avoir mis à jour q et masse
     332
     333      !write(*,*) 'vlsplt 326: iq,ijb_x,nqfils(iq)=',iq,ijb_x,nqfils(iq)
     334
     335      if (nqfils(iq).gt.0) then 
     336       do ifils=1,nqdesc(iq)
     337         iq2=iqfils(ifils,iq)
     338c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     339         DO l=1,llm
     340          DO ij=ijb,ije
     341           ! On a besoin de q et masse seulement entre ijb et ije. On ne
     342           ! les calcule donc que de ijb à ije
     343           masse(ij,l,iq2)=masse(ij,l,iq)*q(ij,l,iq)
     344           Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq)
     345          enddo   
     346         enddo
     347c$OMP END DO NOWAIT
     348        enddo !do ifils=1,nqdesc(iq)
     349        do ifils=1,nqfils(iq)
     350         iq2=iqfils(ifils,iq)
     351         call vlx_loc(Ratio,pente_max,masse,u_mq,ijb_x,ije_x,iq2)
     352        enddo !do ifils=1,nqfils(iq)
     353      endif !if (nqfils(iq).gt.0) then
     354! end CRisi
     355
     356      !write(*,*) 'vlsplt 360: iq,ijb_x=',iq,ijb_x
     357
    313358c   calcul des tENDances
    314359c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    315360      DO l=1,llm
    316361         DO ij=ijb+1,ije
    317             new_m=masse(ij,l)+u_m(ij-1,l)-u_m(ij,l)
    318             q(ij,l)=(q(ij,l)*masse(ij,l)+
    319      &      u_mq(ij-1,l)-u_mq(ij,l))
    320      &      /new_m
    321             masse(ij,l)=new_m
     362            new_m=masse(ij,l,iq)+u_m(ij-1,l)-u_m(ij,l)
     363            q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+
     364     &        u_mq(ij-1,l)-u_mq(ij,l))
     365     &        /new_m
     366            masse(ij,l,iq)=new_m
    322367         ENDDO
    323368c   ModIF Fred 22 03 96 correction d'un bug (les scopy ci-dessous)
    324369         DO ij=ijb+iip1-1,ije,iip1
    325             q(ij-iim,l)=q(ij,l)
    326             masse(ij-iim,l)=masse(ij,l)
    327          ENDDO
    328       ENDDO
    329 c$OMP END DO NOWAIT
     370            q(ij-iim,l,iq)=q(ij,l,iq)
     371            masse(ij-iim,l,iq)=masse(ij,l,iq)
     372         ENDDO
     373      ENDDO
     374c$OMP END DO NOWAIT
     375      !write(*,*) 'vlsplt 380: iq,ijb_x=',iq,ijb_x
     376
     377! retablir les fils en rapport de melange par rapport a l'air:
     378      ! On calcule q entre ijb+1 et ije -> on fait pareil pour ratio
     379      ! puis on boucle en longitude
     380      if (nqfils(iq).gt.0) then 
     381       do ifils=1,nqdesc(iq)
     382         iq2=iqfils(ifils,iq) 
     383c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)   
     384         DO l=1,llm
     385          DO ij=ijb+1,ije
     386            q(ij,l,iq2)=q(ij,l,iq)*Ratio(ij,l,iq2)           
     387          enddo
     388          DO ij=ijb+iip1-1,ije,iip1
     389             q(ij-iim,l,iq2)=q(ij,l,iq2)
     390          enddo ! DO ij=ijb+iip1-1,ije,iip1
     391         enddo !DO l=1,llm
     392c$OMP END DO NOWAIT
     393        enddo !do ifils=1,nqdesc(iq)
     394      endif !if (nqfils(iq).gt.0) then
     395
     396      !write(*,*) 'vlsplt 399: iq,ijb_x=',iq,ijb_x
    330397c     CALL SCOPY((jjm-1)*llm,q(iip1+iip1,1),iip1,q(iip2,1),iip1)
    331398c     CALL SCOPY((jjm-1)*llm,masse(iip1+iip1,1),iip1,masse(iip2,1),iip1)
    … …  
    336403
    337404
    338       SUBROUTINE vly_loc(q,pente_max,masse,masse_adv_v)
     405      RECURSIVE SUBROUTINE vly_loc(q,pente_max,masse,masse_adv_v,iq)
    339406c
    340407c     Auteurs:   P.Le Van, F.Hourdin, F.Forget
    … …  
    349416c   --------------------------------------------------------------------
    350417      USE parallel_lmdz
     418      USE infotrac, ONLY : nqtot,nqfils,nqdesc,iqfils ! CRisi
    351419      IMPLICIT NONE
    352420c
    … …  
    361429c   Arguments:
    362430c   ----------
    363       REAL masse(ijb_u:ije_u,llm),pente_max
     431      REAL masse(ijb_u:ije_u,llm,nqtot),pente_max
    364432      REAL masse_adv_v( ijb_v:ije_v,llm)
    365       REAL q(ijb_u:ije_u,llm), dq( ijb_u:ije_u,llm)
     433      REAL q(ijb_u:ije_u,llm,nqtot), dq( ijb_u:ije_u,llm)
     434      INTEGER iq ! CRisi
    366435c
    367436c      Local
    … …  
    392461      SAVE airej2,airejjm
    393462c$OMP THREADPRIVATE(airej2,airejjm)
     463
     464      REAL Ratio(ijb_u:ije_u,llm,nqtot) ! CRisi
     465      INTEGER ifils,iq2 ! CRisi
    394466c
    395467c
    … …  
    401473      INTEGER ijb,ije
    402474
     475      ijb=ij_begin-2*iip1
     476      ije=ij_end+2*iip1 
     477      if (pole_nord) ijb=ij_begin
     478      if (pole_sud)  ije=ij_end
     479
    403480      IF(first) THEN
    404 c         PRINT*,'Shema  Amont nouveau  appele dans  Vanleer   '
     481         PRINT*,'Shema  Amont nouveau  appele dans  Vanleer   '
    405482         first=.false.
    406483         do i=2,iip1
    … …  
    434511      if (pole_nord) then
    435512        DO i = 1, iim
    436           airescb(i) = aire(i+ iip1) * q(i+ iip1,l)
     513          airescb(i) = aire(i+ iip1) * q(i+ iip1,l,iq)
    437514        ENDDO
    438515        qpns   = SSUM( iim,  airescb ,1 ) / airej2
    … …  
    441518      if (pole_sud) then
    442519        DO i = 1, iim
    443           airesch(i) = aire(i+ ip1jm- iip1) * q(i+ ip1jm- iip1,l)
     520          airesch(i) = aire(i+ ip1jm- iip1) * q(i+ ip1jm- iip1,l,iq)
    444521        ENDDO
    445522        qpsn   = SSUM( iim,  airesch ,1 ) / airejjm
    446523      endif
    447524     
    448      
    449 
    450525c   calcul des pentes aux points v
    451526
    … …  
    455530      if (pole_sud)  ije=ij_end-iip1
    456531     
     532      ! on a besoin de q entre ij_begin-2*iip1 et ij_end+2*iip1
     533      ! Si pole sud, entre ij_begin-2*iip1 et ij_end
     534      ! Si pole Nord, entre ij_begin et ij_end+2*iip1
    457535      DO ij=ijb,ije
    458          dyqv(ij)=q(ij,l)-q(ij+iip1,l)
     536         dyqv(ij)=q(ij,l,iq)-q(ij+iip1,l,iq)
    459537         adyqv(ij)=abs(dyqv(ij))
    460538      ENDDO
     539 
    461540
    462541c   calcul des pentes aux points scalaires
    … …  
    475554      IF (pole_nord) THEN
    476555        DO ij=1,iip1
    477            dyq(ij,l)=qpns-q(ij+iip1,l)
     556           dyq(ij,l)=qpns-q(ij+iip1,l,iq)
    478557        ENDDO
    479558       
    … …  
    497576
    498577        DO ij=1,iip1
    499            dyq(ip1jm+ij,l)=q(ip1jm+ij-iip1,l)-qpsn
     578           dyq(ip1jm+ij,l)=q(ip1jm+ij-iip1,l,iq)-qpsn
    500579        ENDDO
    501580
    … …  
    633712       DO ij=ijb,ije
    634713          IF(masse_adv_v(ij,l).gt.0) THEN
    635               qbyv(ij,l)=q(ij+iip1,l)+dyq(ij+iip1,l)*
    636      ,                   0.5*(1.-masse_adv_v(ij,l)/masse(ij+iip1,l))
     714              qbyv(ij,l)=q(ij+iip1,l,iq)+dyq(ij+iip1,l)*
     715     ,                   0.5*(1.-masse_adv_v(ij,l)
     716     ,                   /masse(ij+iip1,l,iq))
    637717          ELSE
    638               qbyv(ij,l)=q(ij,l)-dyq(ij,l)*
    639      ,                   0.5*(1.+masse_adv_v(ij,l)/masse(ij,l))
     718              qbyv(ij,l)=q(ij,l,iq)-dyq(ij,l)*
     719     ,                   0.5*(1.+masse_adv_v(ij,l)/masse(ij,l,iq))
    640720          ENDIF
    641721          qbyv(ij,l)=masse_adv_v(ij,l)*qbyv(ij,l)
    … …  
    643723      ENDDO
    644724c$OMP END DO NOWAIT
     725
     726! CRisi: appel récursif de l'advection sur les fils.
     727! Il faut faire ça avant d'avoir mis à jour q et masse
     728      !write(*,*) 'vly 689: iq,nqfils(iq)=',iq,nqfils(iq)
     729
     730      ijb=ij_begin-2*iip1
     731      ije=ij_end+2*iip1
     732      if (pole_nord) ijb=ij_begin
     733      if (pole_sud)  ije=ij_end
     734   
     735      if (nqfils(iq).gt.0) then 
     736       do ifils=1,nqdesc(iq)
     737         iq2=iqfils(ifils,iq)
     738c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     739         DO l=1,llm
     740         DO ij=ijb,ije
     741           masse(ij,l,iq2)=masse(ij,l,iq)*q(ij,l,iq)
     742           Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq)     
     743          enddo   
     744         enddo
     745c$OMP END DO NOWAIT
     746        enddo !do ifils=1,nqdesc(iq)
     747
     748        do ifils=1,nqfils(iq)
     749         iq2=iqfils(ifils,iq)
     750         call vly_loc(Ratio,pente_max,masse,qbyv,iq2)
     751        enddo !do ifils=1,nqfils(iq)
     752      endif !if (nqfils(iq).gt.0) then
     753! end CRisi
    645754     
    646755      ijb=ij_begin
    … …  
    652761      DO l=1,llm
    653762         DO ij=ijb,ije
    654             newmasse=masse(ij,l)
    655      &      +masse_adv_v(ij,l)-masse_adv_v(ij-iip1,l)
    656      
    657             q(ij,l)=(q(ij,l)*masse(ij,l)+qbyv(ij,l)-qbyv(ij-iip1,l))
    658      &         /newmasse
    659             masse(ij,l)=newmasse
    660          ENDDO
     763            newmasse=masse(ij,l,iq)
     764     &         +masse_adv_v(ij,l)-masse_adv_v(ij-iip1,l)
     765
     766            q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+qbyv(ij,l)
     767     &         -qbyv(ij-iip1,l))/newmasse
     768
     769            masse(ij,l,iq)=newmasse
     770
     771         ENDDO
     772
     773
    661774c.-. ancienne version
    662775c        convpn=SSUM(iim,qbyv(1,l),1)/apoln
    … …  
    665778           convpn=SSUM(iim,qbyv(1,l),1)
    666779           convmpn=ssum(iim,masse_adv_v(1,l),1)
    667            massepn=ssum(iim,masse(1,l),1)
     780           massepn=ssum(iim,masse(1,l,iq),1)
    668781           qpn=0.
    669782           do ij=1,iim
    670               qpn=qpn+masse(ij,l)*q(ij,l)
     783              qpn=qpn+masse(ij,l,iq)*q(ij,l,iq)
    671784           enddo
    672785           qpn=(qpn+convpn)/(massepn+convmpn)
    673786           do ij=1,iip1
    674               q(ij,l)=qpn
     787              q(ij,l,iq)=qpn
    675788           enddo
    676789         endif
    … …  
    683796           convps=-SSUM(iim,qbyv(ip1jm-iim,l),1)
    684797           convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1)
    685            masseps=ssum(iim, masse(ip1jm+1,l),1)
     798           masseps=ssum(iim, masse(ip1jm+1,l,iq),1)
    686799           qps=0.
    687800           do ij = ip1jm+1,ip1jmp1-1
    688               qps=qps+masse(ij,l)*q(ij,l)
     801              qps=qps+masse(ij,l,iq)*q(ij,l,iq)
    689802           enddo
    690803           qps=(qps+convps)/(masseps+convmps)
    691804           do ij=ip1jm+1,ip1jmp1
    692               q(ij,l)=qps
     805              q(ij,l,iq)=qps
    693806           enddo
    694807         endif
    … …  
    704817c        DO ij = 1,iip1
    705818c           q(ij,l)=newq
    706 c           masse(ij,l)=newmasse*aire(ij)
     819c           masse(ij,l,iq)=newmasse*aire(ij)
    707820c        ENDDO
    708821c        convps=-SSUM(iim,qbyv(ip1jm-iim,l),1)
    … …  
    714827c        DO ij = ip1jm+1,ip1jmp1
    715828c           q(ij,l)=newq
    716 c           masse(ij,l)=newmasse*aire(ij)
     829c           masse(ij,l,iq)=newmasse*aire(ij)
    717830c        ENDDO
    718831c._. fin nouvelle version
    … …  
    720833c$OMP END DO NOWAIT
    721834
     835! retablir les fils en rapport de melange par rapport a l'air:
     836      ijb=ij_begin
     837      ije=ij_end
     838!      if (pole_nord) ijb=ij_begin
     839!      if (pole_sud)  ije=ij_end
     840
     841      if (nqfils(iq).gt.0) then 
     842       do ifils=1,nqdesc(iq)
     843         iq2=iqfils(ifils,iq) 
     844c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)   
     845         DO l=1,llm
     846          DO ij=ijb,ije
     847            q(ij,l,iq2)=q(ij,l,iq)*Ratio(ij,l,iq2)           
     848          enddo
     849         enddo
     850c$OMP END DO NOWAIT
     851        enddo !do ifils=1,nqdesc(iq)
     852      endif !if (nqfils(iq).gt.0) then
     853
     854
    722855      RETURN
    723856      END
    … …  
    725858     
    726859     
    727       SUBROUTINE vlz_loc(q,pente_max,masse,w,ijb_x,ije_x)
     860      RECURSIVE SUBROUTINE vlz_loc(q,pente_max,masse,w,ijb_x,ije_x,iq)
    728861c
    729862c     Auteurs:   P.Le Van, F.Hourdin, F.Forget
    … …  
    739872      USE parallel_lmdz
    740873      USE vlz_mod
     874      USE infotrac, ONLY : nqtot,nqfils,nqdesc,iqfils ! CRisi 
    741875      IMPLICIT NONE
    742876c
    … …  
    750884c   Arguments:
    751885c   ----------
    752       REAL masse(ijb_u:ije_u,llm),pente_max
    753       REAL q(ijb_u:ije_u,llm)
    754       REAL w(ijb_u:ije_u,llm+1)
     886      REAL masse(ijb_u:ije_u,llm,nqtot),pente_max
     887      REAL q(ijb_u:ije_u,llm,nqtot)
     888      REAL w(ijb_u:ije_u,llm+1,nqtot)
     889      INTEGER iq
    755890c
    756891c      Local
    … …  
    779914      LOGICAL,SAVE :: first=.TRUE.
    780915!$OMP THREADPRIVATE(first)
    781      
     916
     917      !REAL masseq(ijb_u:ije_u,llm,nqtot),Ratio(ijb_u:ije_u,llm,nqtot) ! CRisi
     918      ! Ces varibles doivent être déclarées en pointer et en save dans
     919      ! vlz_loc si on veut qu'elles soient vues par tous les threads. 
     920      INTEGER ifils,iq2 ! CRisi
    782921
    783922      IF (first) THEN
    … …  
    787926c    sens de W
    788927
     928      !write(*,*) 'vlsplt 926: entree dans vlz_loc, iq=',iq
    789929#ifdef BIDON
    790930      IF(testcpu) THEN
    … …  
    799939      DO l=2,llm
    800940         DO ij=ijb,ije
    801             dzqw(ij,l)=q(ij,l-1)-q(ij,l)
     941            dzqw(ij,l)=q(ij,l-1,iq)-q(ij,l,iq)
    802942            adzqw(ij,l)=abs(dzqw(ij,l))
    803943         ENDDO
    … …  
    842982c calcul de  - d( q   * w )/ d(sigma)    qu'on ajoute a  dq pour calculer dq
    843983
     984       !write(*,*) 'vlz 982,ijb,ije=',ijb,ije
    844985c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    845986       DO l = 1,llm-1
    846987         do  ij = ijb,ije
    847           IF(w(ij,l+1).gt.0.) THEN
    848              sigw=w(ij,l+1)/masse(ij,l+1)
    849              wq(ij,l+1)=w(ij,l+1)*(q(ij,l+1)+0.5*(1.-sigw)*dzq(ij,l+1))
     988          IF(w(ij,l+1,iq).gt.0.) THEN
     989             sigw=w(ij,l+1,iq)/masse(ij,l+1,iq)
     990             wq(ij,l+1,iq)=w(ij,l+1,iq)*(q(ij,l+1,iq)
     991     :           +0.5*(1.-sigw)*dzq(ij,l+1))
    850992          ELSE
    851              sigw=w(ij,l+1)/masse(ij,l)
    852              wq(ij,l+1)=w(ij,l+1)*(q(ij,l)-0.5*(1.+sigw)*dzq(ij,l))
     993             sigw=w(ij,l+1,iq)/masse(ij,l,iq)
     994             wq(ij,l+1,iq)=w(ij,l+1,iq)*(q(ij,l,iq)
     995     :           -0.5*(1.+sigw)*dzq(ij,l))
    853996          ENDIF
    854997         ENDDO
    855998       ENDDO
    856 c$OMP END DO NOWAIT
     999c$OMP END DO NOWAIT   
     1000       !write(*,*) 'vlz 1001'   
    8571001
    8581002c$OMP MASTER
    8591003       DO ij=ijb,ije
    860           wq(ij,llm+1)=0.
    861           wq(ij,1)=0.
     1004          wq(ij,llm+1,iq)=0.
     1005          wq(ij,1,iq)=0.
    8621006       ENDDO
    8631007c$OMP END MASTER
    8641008c$OMP BARRIER
    8651009
     1010! CRisi: appel récursif de l'advection sur les fils.
     1011! Il faut faire ça avant d'avoir mis à jour q et masse
     1012      !write(*,*) 'vlsplt 942: iq,nqfils(iq)=',iq,nqfils(iq)
     1013      if (nqfils(iq).gt.0) then 
     1014       do ifils=1,nqdesc(iq)
     1015         iq2=iqfils(ifils,iq)
     1016c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
     1017         DO l=1,llm
     1018          DO ij=ijb,ije
     1019           masse(ij,l,iq2)=masse(ij,l,iq)*q(ij,l,iq)
     1020           Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq)
     1021           !wq(ij,l,iq2)=wq(ij,l,iq) ! correction bug le 15mai2015
     1022           w(ij,l,iq2)=wq(ij,l,iq)
     1023          enddo   
     1024         enddo
     1025c$OMP END DO NOWAIT
     1026        enddo !do ifils=1,nqdesc(iq)
     1027c$OMP BARRIER
     1028
     1029        do ifils=1,nqfils(iq)
     1030         iq2=iqfils(ifils,iq)
     1031         call vlz_loc(Ratio,pente_max,masse,w,ijb_x,ije_x,iq2)
     1032        enddo !do ifils=1,nqfils(iq)
     1033      endif !if (nqfils(iq).gt.0) then
     1034! end CRisi 
     1035
     1036! CRisi: On rajoute ici une barrière car on veut être sur que tous les
     1037! wq soient synchronisés
     1038
     1039c$OMP BARRIER
    8661040c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    8671041      DO l=1,llm
    8681042         DO ij=ijb,ije
    869             newmasse=masse(ij,l)+w(ij,l+1)-w(ij,l)
    870             q(ij,l)=(q(ij,l)*masse(ij,l)+wq(ij,l+1)-wq(ij,l))
     1043            newmasse=masse(ij,l,iq)+w(ij,l+1,iq)-w(ij,l,iq)
     1044            q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)
     1045     &         +wq(ij,l+1,iq)-wq(ij,l,iq))
    8711046     &         /newmasse
    872             masse(ij,l)=newmasse
    873          ENDDO
    874       ENDDO
    875 c$OMP END DO NOWAIT
    876 
     1047            masse(ij,l,iq)=newmasse
     1048         ENDDO
     1049      ENDDO
     1050c$OMP END DO NOWAIT
     1051
     1052     
     1053! retablir les fils en rapport de melange par rapport a l'air:
     1054      if (nqfils(iq).gt.0) then 
     1055       do ifils=1,nqdesc(iq)
     1056         iq2=iqfils(ifils,iq) 
     1057c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)   
     1058         DO l=1,llm
     1059          DO ij=ijb,ije
     1060            q(ij,l,iq2)=q(ij,l,iq)*Ratio(ij,l,iq2)           
     1061          enddo
     1062         enddo
     1063c$OMP END DO NOWAIT
     1064        enddo !do ifils=1,nqdesc(iq)
     1065      endif !if (nqfils(iq).gt.0) then
    8771066
    8781067      RETURN

  • LMDZ5/branches/testing/libf/dyn3dmem/vlspltgen_loc.F

    r1910 r2298  
    2727      USE Write_Field_loc
    2828      USE VAMPIR
    29       USE infotrac, ONLY : nqtot
     29      ! CRisi: on rajoute variables utiles d'infotrac 
     30      USE infotrac, ONLY : nqtot,nqperes,nqdesc,nqfils,iqfils,
     31     &    ok_iso_verif
    3032      USE vlspltgen_mod
    3133      IMPLICIT NONE
    … …  
    6466      REAL ptarg,pdelarg,foeew,zdelta
    6567      REAL tempe(ijb_u:ije_u)
    66       INTEGER ijb,ije,iq
     68      INTEGER ijb,ije,iq,iq2,ifils
    6769      LOGICAL, SAVE :: firstcall=.TRUE.
    6870!$OMP THREADPRIVATE(firstcall)
    … …  
    150152      ije=ij_end
    151153
     154      DO iq=1,nqtot
    152155c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)     
    153156      DO l=1,llm
    154157         DO ij=ijb,ije
    155             mw(ij,l)=w(ij,l) * zzw
     158            mw(ij,l,iq)=w(ij,l) * zzw
    156159         ENDDO
    157160      ENDDO
    158161c$OMP END DO NOWAIT
    159 
     162      ENDDO
     163
     164      DO iq=1,nqtot 
    160165c$OMP MASTER
    161166      DO ij=ijb,ije
    162          mw(ij,llm+1)=0.
     167         mw(ij,llm+1,iq)=0.
    163168      ENDDO
    164169c$OMP END MASTER
     170      ENDDO
    165171
    166172c      CALL SCOPY(ijp1llm,q,1,zq,1)
    … …  
    170176       ije=ij_end
    171177
    172       DO iq=1,nqtot
     178      DO iq=1,nqtot       
    173179c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    174180        DO l=1,llm
    … …  
    179185      ENDDO
    180186
    181 #ifdef DEBUG_IO   
     187#ifdef DEBUG_IO     
    182188       CALL WriteField_u('mu',mu)
    183189       CALL WriteField_v('mv',mv)
    … …  
    186192#endif
    187193
     194      ! verif temporaire
     195      ijb=ij_begin
     196      ije=ij_end 
     197      if (ok_iso_verif) then
     198        call check_isotopes(zq,ijb,ije,'vlspltgen_loc 191')
     199      endif !if (ok_iso_verif) then   
     200
    188201c$OMP BARRIER           
    189       DO iq=1,nqtot
    190 
     202!      DO iq=1,nqtot
     203      DO iq=1,nqperes ! CRisi: on ne boucle que sur les pères= ceux qui sont transportés directement par l'air
     204       !write(*,*) 'vlspltgen 192: iq,iadv=',iq,iadv(iq)
     205#ifdef DEBUG_IO   
     206       CALL WriteField_u('zq',zq(:,:,iq))
     207       CALL WriteField_u('zm',zm(:,:,iq))
     208#endif
     209        if(iadv(iq) == 0) then
     210       
     211          cycle
     212       
     213        else if (iadv(iq)==10) then
     214
     215#ifdef _ADV_HALO       
     216! CRisi: on ajoute les nombres de fils et tableaux des fils
     217! On suppose qu'on ne peut advecter les fils que par le schéma 10. 
     218          call vlx_loc(zq,pente_max,zm,mu,
     219     &               ij_begin,ij_begin+2*iip1-1,iq)
     220          call vlx_loc(zq,pente_max,zm,mu,
     221     &               ij_end-2*iip1+1,ij_end,iq)
     222#else
     223          call vlx_loc(zq,pente_max,zm,mu,
     224     &               ij_begin,ij_end,iq)
     225#endif
     226
     227c$OMP MASTER
     228          call VTb(VTHallo)
     229c$OMP END MASTER
     230          call Register_Hallo_u(zq(:,:,iq),llm,2,2,2,2,MyRequest1)
     231          call Register_Hallo_u(zm(:,:,iq),llm,1,1,1,1,MyRequest1)
     232! CRisi
     233          do ifils=1,nqdesc(iq)
     234            iq2=iqfils(ifils,iq)
     235            call Register_Hallo_u(zq(:,:,iq2),llm,2,2,2,2,MyRequest1)
     236            call Register_Hallo_u(zm(:,:,iq2),llm,1,1,1,1,MyRequest1)
     237          enddo
     238
     239c$OMP MASTER
     240          call VTe(VTHallo)
     241c$OMP END MASTER
     242        else if (iadv(iq)==14) then
     243
     244#ifdef _ADV_HALO           
     245          call vlxqs_loc(zq,pente_max,zm,mu,
     246     &                   qsat,ij_begin,ij_begin+2*iip1-1,iq)
     247          call vlxqs_loc(zq,pente_max,zm,mu,
     248     &                   qsat,ij_end-2*iip1+1,ij_end,iq)
     249#else
     250          call vlxqs_loc(zq,pente_max,zm,mu,
     251     &                   qsat,ij_begin,ij_end,iq)
     252#endif
     253
     254c$OMP MASTER
     255          call VTb(VTHallo)
     256c$OMP END MASTER
     257
     258          call Register_Hallo_u(zq(:,:,iq),llm,2,2,2,2,MyRequest1)
     259          call Register_Hallo_u(zm(:,:,iq),llm,1,1,1,1,MyRequest1)
     260          do ifils=1,nqdesc(iq)
     261            iq2=iqfils(ifils,iq)
     262            call Register_Hallo_u(zq(:,:,iq2),llm,2,2,2,2,MyRequest1)
     263            call Register_Hallo_u(zm(:,:,iq2),llm,1,1,1,1,MyRequest1)
     264          enddo
     265
     266c$OMP MASTER
     267          call VTe(VTHallo)
     268c$OMP END MASTER
     269        else
     270       
     271          stop 'vlspltgen_p : schema non parallelise'
     272     
     273        endif
     274     
     275      enddo !DO iq=1,nqperes
     276     
     277     
     278c$OMP BARRIER     
     279c$OMP MASTER     
     280      call VTb(VTHallo)
     281c$OMP END MASTER
     282
     283      call SendRequest(MyRequest1)
     284
     285c$OMP MASTER
     286      call VTe(VTHallo)
     287c$OMP END MASTER       
     288c$OMP BARRIER
     289
     290      ! verif temporaire
     291      ijb=ij_begin-2*iip1
     292      ije=ij_end+2*iip1 
     293      if (pole_nord) ijb=ij_begin
     294      if (pole_sud)  ije=ij_end 
     295      if (ok_iso_verif) then
     296           call check_isotopes(zq,ij_begin,ij_end,'vlspltgen_loc 280')
     297      endif !if (ok_iso_verif) then
     298
     299      do iq=1,nqperes
     300        !write(*,*) 'vlspltgen 279: iq=',iq
     301
     302        if(iadv(iq) == 0) then
     303       
     304          cycle
     305       
     306        else if (iadv(iq)==10) then
     307
     308#ifdef _ADV_HALLO
     309          call vlx_loc(zq,pente_max,zm,mu,
     310     &                 ij_begin+2*iip1,ij_end-2*iip1,iq)
     311#endif       
     312        else if (iadv(iq)==14) then
     313#ifdef _ADV_HALLO
     314          call vlxqs_loc(zq,pente_max,zm,mu,
     315     &                    qsat,ij_begin+2*iip1,ij_end-2*iip1,iq)
     316#endif   
     317        else
     318       
     319          stop 'vlspltgen_p : schema non parallelise'
     320     
     321        endif
     322     
     323      enddo
     324c$OMP BARRIER     
     325c$OMP MASTER
     326      call VTb(VTHallo)
     327c$OMP END MASTER
     328
     329!      call WaitRecvRequest(MyRequest1)
     330!      call WaitSendRequest(MyRequest1)
     331c$OMP BARRIER
     332       call WaitRequest(MyRequest1)
     333
     334
     335c$OMP MASTER
     336      call VTe(VTHallo)
     337c$OMP END MASTER
     338c$OMP BARRIER
     339
     340     
     341      if (ok_iso_verif) then
     342           call check_isotopes(zq,ij_begin,ij_end,'vlspltgen_loc 326')
     343      endif !if (ok_iso_verif) then       
     344      if (ok_iso_verif) then
     345           ijb=ij_begin-2*iip1
     346           ije=ij_end+2*iip1
     347           if (pole_nord) ijb=ij_begin
     348           if (pole_sud)  ije=ij_end
     349           call check_isotopes(zq,ijb,ije,'vlspltgen_loc 336')
     350      endif !if (ok_iso_verif) then 
     351
     352      do iq=1,nqperes
     353       !write(*,*) 'vlspltgen 321: iq=',iq
    191354#ifdef DEBUG_IO   
    192355       CALL WriteField_u('zq',zq(:,:,iq))
    193356       CALL WriteField_u('zm',zm(:,:,iq))
    194357#endif
     358
    195359        if(iadv(iq) == 0) then
    196360       
    … …  
    198362       
    199363        else if (iadv(iq)==10) then
    200 
    201 #ifdef _ADV_HALO       
    202           call vlx_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mu,
    203      &               ij_begin,ij_begin+2*iip1-1)
    204           call vlx_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mu,
    205      &               ij_end-2*iip1+1,ij_end)
    206 #else
    207           call vlx_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mu,
    208      &               ij_begin,ij_end)
    209 #endif
    210 
    211 c$OMP MASTER
    212           call VTb(VTHallo)
    213 c$OMP END MASTER
    214           call Register_Hallo_u(zq(:,:,iq),llm,2,2,2,2,MyRequest1)
    215           call Register_Hallo_u(zm(:,:,iq),llm,1,1,1,1,MyRequest1)
    216 
    217 c$OMP MASTER
    218           call VTe(VTHallo)
    219 c$OMP END MASTER
     364       
     365          call vly_loc(zq,pente_max,zm,mv,iq)
     366 
    220367        else if (iadv(iq)==14) then
    221 
    222 #ifdef _ADV_HALO           
    223           call vlxqs_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mu,
    224      &                   qsat,ij_begin,ij_begin+2*iip1-1)
    225           call vlxqs_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mu,
    226      &                   qsat,ij_end-2*iip1+1,ij_end)
    227 #else
    228 
    229           call vlxqs_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mu,
    230      &                   qsat,ij_begin,ij_end)
    231 #endif
    232 
    233 c$OMP MASTER
    234           call VTb(VTHallo)
    235 c$OMP END MASTER
    236 
    237           call Register_Hallo_u(zq(:,:,iq),llm,2,2,2,2,MyRequest1)
    238           call Register_Hallo_u(zm(:,:,iq),llm,1,1,1,1,MyRequest1)
    239 
    240 c$OMP MASTER
    241           call VTe(VTHallo)
    242 c$OMP END MASTER
     368     
     369          call vlyqs_loc(zq,pente_max,zm,mv,
     370     &                   qsat,iq)
     371 
    243372        else
    244373       
    … …  
    246375     
    247376        endif
    248      
    249       enddo
    250      
    251      
    252 c$OMP BARRIER     
    253 c$OMP MASTER     
    254       call VTb(VTHallo)
    255 c$OMP END MASTER
    256 
    257       call SendRequest(MyRequest1)
    258 
    259 c$OMP MASTER
    260       call VTe(VTHallo)
    261 c$OMP END MASTER       
    262 c$OMP BARRIER
    263       do iq=1,nqtot
    264 
    265         if(iadv(iq) == 0) then
    266        
    267           cycle
    268        
    269         else if (iadv(iq)==10) then
    270 
    271 #ifdef _ADV_HALLO
    272           call vlx_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mu,
    273      &                 ij_begin+2*iip1,ij_end-2*iip1)
    274 #endif       
    275         else if (iadv(iq)==14) then
    276 #ifdef _ADV_HALLO
    277           call vlxqs_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mu,
    278      &                    qsat,ij_begin+2*iip1,ij_end-2*iip1)
    279 #endif   
    280         else
    281        
    282           stop 'vlspltgen_p : schema non parallelise'
    283      
    284         endif
    285      
    286       enddo
    287 c$OMP BARRIER     
    288 c$OMP MASTER
    289       call VTb(VTHallo)
    290 c$OMP END MASTER
    291 
    292 !      call WaitRecvRequest(MyRequest1)
    293 !      call WaitSendRequest(MyRequest1)
    294 c$OMP BARRIER
    295        call WaitRequest(MyRequest1)
    296 
    297 
    298 c$OMP MASTER
    299       call VTe(VTHallo)
    300 c$OMP END MASTER
    301 c$OMP BARRIER
    302 
    303 
    304       do iq=1,nqtot
     377       
     378       enddo
     379
     380      if (ok_iso_verif) then
     381           call check_isotopes(zq,ij_begin,ij_end,'vlspltgen_loc 357')
     382      endif !if (ok_iso_verif) then
     383
     384      do iq=1,nqperes
     385      !write(*,*) 'vlspltgen 349: iq=',iq
    305386#ifdef DEBUG_IO   
    306387       CALL WriteField_u('zq',zq(:,:,iq))
    307388       CALL WriteField_u('zm',zm(:,:,iq))
    308389#endif
     390        if(iadv(iq) == 0) then
     391         
     392          cycle
     393       
     394        else if (iadv(iq)==10 .or. iadv(iq)==14 ) then
     395
     396c$OMP BARRIER       
     397#ifdef _ADV_HALLO
     398          call vlz_loc(zq,pente_max,zm,mw,
     399     &               ij_begin,ij_begin+2*iip1-1,iq)
     400          call vlz_loc(zq,pente_max,zm,mw,
     401     &               ij_end-2*iip1+1,ij_end,iq)
     402#else
     403          call vlz_loc(zq,pente_max,zm,mw,
     404     &               ij_begin,ij_end,iq)
     405#endif
     406c$OMP BARRIER
     407
     408c$OMP MASTER
     409          call VTb(VTHallo)
     410c$OMP END MASTER
     411
     412          call Register_Hallo_u(zq(:,:,iq),llm,2,2,2,2,MyRequest2)
     413          call Register_Hallo_u(zm(:,:,iq),llm,1,1,1,1,MyRequest2)
     414          ! CRisi
     415          do ifils=1,nqdesc(iq)
     416            iq2=iqfils(ifils,iq)
     417            call Register_Hallo_u(zq(:,:,iq2),llm,2,2,2,2,MyRequest2)
     418            call Register_Hallo_u(zm(:,:,iq2),llm,1,1,1,1,MyRequest2)
     419          enddo     
     420c$OMP MASTER
     421          call VTe(VTHallo)
     422c$OMP END MASTER       
     423c$OMP BARRIER
     424        else
     425       
     426          stop 'vlspltgen_p : schema non parallelise'
     427     
     428        endif
     429     
     430      enddo
     431c$OMP BARRIER     
     432
     433c$OMP MASTER       
     434      call VTb(VTHallo)
     435c$OMP END MASTER
     436
     437      call SendRequest(MyRequest2)
     438
     439c$OMP MASTER
     440      call VTe(VTHallo)
     441c$OMP END MASTER       
     442
     443
     444      if (ok_iso_verif) then
     445           call check_isotopes(zq,ij_begin,ij_end,'vlspltgen_loc 429')
     446      endif !if (ok_iso_verif) then
     447
     448c$OMP BARRIER
     449      do iq=1,nqperes
     450      !write(*,*) 'vlspltgen 409: iq=',iq
     451
    309452        if(iadv(iq) == 0) then
    310        
     453         
    311454          cycle
    312455       
    313         else if (iadv(iq)==10) then
    314        
    315           call vly_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mv)
    316  
    317         else if (iadv(iq)==14) then
    318       
    319           call vlyqs_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mv,
    320      &                   qsat)
    321 
     456        else if (iadv(iq)==10 .or. iadv(iq)==14 ) then
     457c$OMP BARRIER       
     458
     459#ifdef _ADV_HALLO
     460          call vlz_loc(zq,pente_max,zm,mw,
     461     &               ij_begin+2*iip1,ij_end-2*iip1,iq)
     462#endif
     463
     464c$OMP BARRIER       
    322465        else
    323466       
    … …  
    325468     
    326469        endif
    327        
    328        enddo
    329 
    330 
    331       do iq=1,nqtot
     470     
     471      enddo
     472      !write(*,*) 'vlspltgen_loc 476'
     473
     474c$OMP BARRIER
     475      !write(*,*) 'vlspltgen_loc 477'
     476c$OMP MASTER
     477      call VTb(VTHallo)
     478c$OMP END MASTER
     479
     480!      call WaitRecvRequest(MyRequest2)
     481!      call WaitSendRequest(MyRequest2)
     482c$OMP BARRIER
     483       CALL WaitRequest(MyRequest2)
     484
     485c$OMP MASTER
     486      call VTe(VTHallo)
     487c$OMP END MASTER
     488c$OMP BARRIER
     489
     490
     491      !write(*,*) 'vlspltgen_loc 494'
     492      if (ok_iso_verif) then
     493           call check_isotopes(zq,ij_begin,ij_end,'vlspltgen_loc 461')
     494      endif !if (ok_iso_verif) then
     495
     496      do iq=1,nqperes
     497      !write(*,*) 'vlspltgen 449: iq=',iq
    332498#ifdef DEBUG_IO   
    333499       CALL WriteField_u('zq',zq(:,:,iq))
    334500       CALL WriteField_u('zm',zm(:,:,iq))
    335501#endif
     502        if(iadv(iq) == 0) then
     503       
     504          cycle
     505       
     506        else if (iadv(iq)==10) then
     507       
     508          call vly_loc(zq,pente_max,zm,mv,iq)
     509 
     510        else if (iadv(iq)==14) then
     511     
     512          call vlyqs_loc(zq,pente_max,zm,mv,
     513     &                   qsat,iq)
     514 
     515        else
     516       
     517          stop 'vlspltgen_p : schema non parallelise'
     518     
     519        endif
     520       
     521       enddo !do iq=1,nqperes
     522
     523      if (ok_iso_verif) then
     524           call check_isotopes(zq,ij_begin,ij_end,'vlspltgen_loc 493')
     525      endif !if (ok_iso_verif) then
     526
     527      do iq=1,nqperes
     528      !write(*,*) 'vlspltgen 477: iq=',iq
     529#ifdef DEBUG_IO   
     530       CALL WriteField_u('zq',zq(:,:,iq))
     531       CALL WriteField_u('zm',zm(:,:,iq))
     532#endif
    336533        if(iadv(iq) == 0) then
    337534         
    338535          cycle
    339536       
    340         else if (iadv(iq)==10 .or. iadv(iq)==14 ) then
    341 
    342 c$OMP BARRIER       
    343 #ifdef _ADV_HALLO
    344           call vlz_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mw,
    345      &               ij_begin,ij_begin+2*iip1-1)
    346           call vlz_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mw,
    347      &               ij_end-2*iip1+1,ij_end)
    348 #else
    349           call vlz_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mw,
    350      &               ij_begin,ij_end)
    351 #endif
    352 c$OMP BARRIER
    353 
    354 c$OMP MASTER
    355           call VTb(VTHallo)
    356 c$OMP END MASTER
    357 
    358           call Register_Hallo_u(zq(:,:,iq),llm,2,2,2,2,MyRequest2)
    359           call Register_Hallo_u(zm(:,:,iq),llm,1,1,1,1,MyRequest2)
    360 
    361 c$OMP MASTER
    362           call VTe(VTHallo)
    363 c$OMP END MASTER       
    364 c$OMP BARRIER
    365         else
    366        
    367           stop 'vlspltgen_p : schema non parallelise'
    368      
    369         endif
    370      
    371       enddo
    372 c$OMP BARRIER     
    373 
    374 c$OMP MASTER       
    375       call VTb(VTHallo)
    376 c$OMP END MASTER
    377 
    378       call SendRequest(MyRequest2)
    379 
    380 c$OMP MASTER
    381       call VTe(VTHallo)
    382 c$OMP END MASTER       
    383 
    384 c$OMP BARRIER
    385       do iq=1,nqtot
    386 
    387         if(iadv(iq) == 0) then
    388          
    389           cycle
    390        
    391         else if (iadv(iq)==10 .or. iadv(iq)==14 ) then
    392 c$OMP BARRIER       
    393 
    394 #ifdef _ADV_HALLO
    395           call vlz_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mw,
    396      &               ij_begin+2*iip1,ij_end-2*iip1)
    397 #endif
    398 
    399 c$OMP BARRIER       
    400         else
    401        
    402           stop 'vlspltgen_p : schema non parallelise'
    403      
    404         endif
    405      
    406       enddo
    407 
    408 c$OMP BARRIER
    409 c$OMP MASTER
    410       call VTb(VTHallo)
    411 c$OMP END MASTER
    412 
    413 !      call WaitRecvRequest(MyRequest2)
    414 !      call WaitSendRequest(MyRequest2)
    415 c$OMP BARRIER
    416        CALL WaitRequest(MyRequest2)
    417 
    418 c$OMP MASTER
    419       call VTe(VTHallo)
    420 c$OMP END MASTER
    421 c$OMP BARRIER
    422 
    423 
    424       do iq=1,nqtot
    425 #ifdef DEBUG_IO   
    426        CALL WriteField_u('zq',zq(:,:,iq))
    427        CALL WriteField_u('zm',zm(:,:,iq))
    428 #endif
    429         if(iadv(iq) == 0) then
    430        
    431           cycle
    432        
    433537        else if (iadv(iq)==10) then
    434538       
    435           call vly_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mv)
     539          call vlx_loc(zq,pente_max,zm,mu,
     540     &               ij_begin,ij_end,iq)
    436541 
    437542        else if (iadv(iq)==14) then
    438543     
    439           call vlyqs_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mv,
    440      &                   qsat)
     544          call vlxqs_loc(zq,pente_max,zm,mu,
     545     &                 qsat, ij_begin,ij_end,iq)
    441546 
    442547        else
    443548       
    444           stop 'vlspltgen_p : schema non parallelise'
     549          stop 'vlspltgen_p : schema non parallelise'
    445550     
    446551        endif
    447552       
    448        enddo
    449 
    450 
    451       do iq=1,nqtot
    452 #ifdef DEBUG_IO   
    453        CALL WriteField_u('zq',zq(:,:,iq))
    454        CALL WriteField_u('zm',zm(:,:,iq))
    455 #endif
    456         if(iadv(iq) == 0) then
    457          
    458           cycle
    459        
    460         else if (iadv(iq)==10) then
    461        
    462           call vlx_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mu,
    463      &               ij_begin,ij_end)
    464  
    465         else if (iadv(iq)==14) then
    466      
    467           call vlxqs_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mu,
    468      &                 qsat, ij_begin,ij_end)
    469  
    470         else
    471        
    472           stop 'vlspltgen_p : schema non parallelise'
    473      
    474         endif
    475        
    476        enddo
    477 
     553       enddo !do iq=1,nqperes
     554
     555      !write(*,*) 'vlspltgen 550: apres derniere serie de call vlx'
     556      if (ok_iso_verif) then
     557           call check_isotopes(zq,ij_begin,ij_end,'vlspltgen_loc 521')
     558      endif !if (ok_iso_verif) then
    478559     
    479560      ijb=ij_begin
    480561      ije=ij_end
     562      !write(*,*) 'vlspltgen_loc 557'
    481563c$OMP BARRIER     
    482564
    483 
     565      !write(*,*) 'vlspltgen_loc 559' 
    484566      DO iq=1,nqtot
     567       !write(*,*) 'vlspltgen_loc 561, iq=',iq 
    485568#ifdef DEBUG_IO   
    486569       CALL WriteField_u('zq',zq(:,:,iq))
    … …  
    495578           ENDDO
    496579        ENDDO
    497 c$OMP END DO NOWAIT         
     580c$OMP END DO NOWAIT   
     581      !write(*,*) 'vlspltgen_loc 575'     
    498582
    499583c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    … …  
    504588        ENDDO
    505589c$OMP END DO NOWAIT 
    506 
    507       ENDDO
     590      !write(*,*) 'vlspltgen_loc 583' 
     591      ENDDO !DO iq=1,nqtot
    508592       
    509      
     593      if (ok_iso_verif) then
     594           call check_isotopes(q,ij_begin,ij_end,'vlspltgen_loc 557')
     595      endif !if (ok_iso_verif) then
     596
    510597c$OMP BARRIER
    511598
    … …  
    516603cc$OMP BARRIER
    517604
     605      !write(*,*) 'vlspltgen 597: sortie' 
    518606      RETURN
    519607      END

  • LMDZ5/branches/testing/libf/dyn3dmem/vlspltgen_mod.F90

    r1910 r2298  
    22
    33  REAL,POINTER,SAVE :: qsat(:,:)
    4   REAL,POINTER,SAVE :: mu(:,:)
     4  REAL,POINTER,SAVE :: mu(:,:) ! CRisi: on ajoute une dimension
    55  REAL,POINTER,SAVE :: mv(:,:)
    6   REAL,POINTER,SAVE :: mw(:,:)
     6  REAL,POINTER,SAVE :: mw(:,:,:)
    77  REAL,POINTER,SAVE :: zm(:,:,:)
    88  REAL,POINTER,SAVE :: zq(:,:,:)
    … …  
    2525    CALL allocate_u(mu,llm,d)
    2626    CALL allocate_v(mv,llm,d)
    27     CALL allocate_u(mw,llm+1,d)
     27    CALL allocate_u(mw,llm+1,nqtot,d)
    2828    CALL allocate_u(zm,llm,nqtot,d)
    2929    CALL allocate_u(zq,llm,nqtot,d)

  • LMDZ5/branches/testing/libf/dyn3dmem/vlspltqs_loc.F

    r1910 r2298  
    1       SUBROUTINE vlxqs_loc(q,pente_max,masse,u_m,qsat,ijb_x,ije_x)
     1      SUBROUTINE vlxqs_loc(q,pente_max,masse,u_m,qsat,ijb_x,ije_x,iq)
    22c
    33c     Auteurs:   P.Le Van, F.Hourdin, F.Forget
    44c
    55c    ********************************************************************
    6 c     Shema  d'advection " pseudo amont " .
     6c     Shema  d''advection " pseudo amont " .
    77c    ********************************************************************
    88c
    99c   --------------------------------------------------------------------
    1010      USE parallel_lmdz
     11      USE infotrac, ONLY : nqtot,nqfils,nqdesc,iqfils ! CRisi 
    1112      IMPLICIT NONE
    1213c
    … …  
    2021c   Arguments:
    2122c   ----------
    22       REAL masse(ijb_u:ije_u,llm),pente_max
     23      REAL masse(ijb_u:ije_u,llm,nqtot),pente_max
    2324      REAL u_m( ijb_u:ije_u,llm )
    24       REAL q(ijb_u:ije_u,llm)
     25      REAL q(ijb_u:ije_u,llm,nqtot)
    2526      REAL qsat(ijb_u:ije_u,llm)
     27      INTEGER iq ! CRisi
    2628c
    2729c      Local
    … …  
    3638      REAL adxqu(ijb_u:ije_u),dxqmax(ijb_u:ije_u,llm)
    3739      REAL u_mq(ijb_u:ije_u,llm)
     40      REAL Ratio(ijb_u:ije_u,llm,nqtot) ! CRisi
     41      INTEGER ifils,iq2 ! CRisi
     42
    3843
    3944      REAL      SSUM
    … …  
    4247      INTEGER ijb,ije,ijb_x,ije_x
    4348     
     49      !write(*,*) 'vlspltqs 58: entree vlxqs_loc, iq,ijb_x=',
     50!     &   iq,ijb_x
    4451
    4552c   calcul de la pente a droite et a gauche de la maille
    … …  
    6572         DO l = 1, llm
    6673            DO ij=ijb,ije-1
    67                dxqu(ij)=q(ij+1,l)-q(ij,l)
     74               dxqu(ij)=q(ij+1,l,iq)-q(ij,l,iq)
    6875c              IF(u_m(ij,l).lt.0.) stop'limx n admet pas les U<0'
    69 c              sigu(ij)=u_m(ij,l)/masse(ij,l)
     76c              sigu(ij)=u_m(ij,l)/masse(ij,l,iq)
    7077            ENDDO
    7178            DO ij=ijb+iip1-1,ije,iip1
    … …  
    120127         DO l = 1, llm
    121128            DO ij=ijb,ije-1
    122                dxqu(ij)=q(ij+1,l)-q(ij,l)
     129               dxqu(ij)=q(ij+1,l,iq)-q(ij,l,iq)
    123130            ENDDO
    124131            DO ij=ijb+iip1-1,ije,iip1
    … …  
    179186      DO l=1,llm
    180187       DO ij=ijb,ije-1
    181           zdum(ij,l)=cvmgp(1.-u_m(ij,l)/masse(ij,l),
    182      ,                     1.+u_m(ij,l)/masse(ij+1,l),
     188          zdum(ij,l)=cvmgp(1.-u_m(ij,l)/masse(ij,l,iq),
     189     ,                     1.+u_m(ij,l)/masse(ij+1,l,iq),
    183190     ,                     u_m(ij,l))
    184191          zdum(ij,l)=0.5*zdum(ij,l)
    185192          u_mq(ij,l)=cvmgp(
    186      ,                q(ij,l)+zdum(ij,l)*dxq(ij,l),
    187      ,                q(ij+1,l)-zdum(ij,l)*dxq(ij+1,l),
     193     ,                q(ij,l,iq)+zdum(ij,l)*dxq(ij,l),
     194     ,                q(ij+1,l,iq)-zdum(ij,l)*dxq(ij+1,l),
    188195     ,                u_m(ij,l))
    189196          u_mq(ij,l)=u_m(ij,l)*u_mq(ij,l)
    … …  
    195202c   on cumule le flux correspondant a toutes les mailles dont la masse
    196203c   au travers de la paroi pENDant le pas de temps.
    197 c   le rapport de melange de l'air advecte est min(q_vanleer, Qsat_downwind)
     204c   le rapport de melange de l''air advecte est min(q_vanleer, Qsat_downwind)
    198205c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    199206      DO l=1,llm
    200207       DO ij=ijb,ije-1
    201208          IF (u_m(ij,l).gt.0.) THEN
    202              zdum(ij,l)=1.-u_m(ij,l)/masse(ij,l)
     209             zdum(ij,l)=1.-u_m(ij,l)/masse(ij,l,iq)
    203210             u_mq(ij,l)=u_m(ij,l)*
    204      $         min(q(ij,l)+0.5*zdum(ij,l)*dxq(ij,l),qsat(ij+1,l))
     211     $         min(q(ij,l,iq)+0.5*zdum(ij,l)*dxq(ij,l),qsat(ij+1,l))
    205212          ELSE
    206              zdum(ij,l)=1.+u_m(ij,l)/masse(ij+1,l)
     213             zdum(ij,l)=1.+u_m(ij,l)/masse(ij+1,l,iq)
    207214             u_mq(ij,l)=u_m(ij,l)*
    208      $         min(q(ij+1,l)-0.5*zdum(ij,l)*dxq(ij+1,l),qsat(ij,l))
     215     $         min(q(ij+1,l,iq)-0.5*zdum(ij,l)*dxq(ij+1,l),qsat(ij,l))
    209216          ENDIF
    210217       ENDDO
    … …  
    273280               ENDDO
    274281               niju=iju
    275 c              PRINT*,'niju,nl',niju,nl(l)
     282               !PRINT*,'vlxqs 280: niju,nl',niju,nl(l)
    276283
    277284c  traitement des mailles
    … …  
    285292                     i=ijq-(j-1)*iip1
    286293c   accumulation pour les mailles completements advectees
    287                      do while(zu_m.gt.masse(ijq,l))
    288                         u_mq(ij,l)=u_mq(ij,l)+q(ijq,l)*masse(ijq,l)
    289                         zu_m=zu_m-masse(ijq,l)
     294                     do while(zu_m.gt.masse(ijq,l,iq))
     295                        u_mq(ij,l)=u_mq(ij,l)+q(ijq,l,iq)
     296     &                     *masse(ijq,l,iq)
     297                        zu_m=zu_m-masse(ijq,l,iq)
    290298                        i=mod(i-2+iim,iim)+1
    291299                        ijq=(j-1)*iip1+i
    292300                     ENDDO
    293301c   ajout de la maille non completement advectee
    294                      u_mq(ij,l)=u_mq(ij,l)+zu_m*
    295      &               (q(ijq,l)+0.5*(1.-zu_m/masse(ijq,l))*dxq(ijq,l))
     302                     u_mq(ij,l)=u_mq(ij,l)+zu_m*(q(ijq,l,iq)
     303     &                 +0.5*(1.-zu_m/masse(ijq,l,iq))*dxq(ijq,l))
    296304                  ELSE
    297305                     ijq=ij+1
    298306                     i=ijq-(j-1)*iip1
    299307c   accumulation pour les mailles completements advectees
    300                      do while(-zu_m.gt.masse(ijq,l))
    301                         u_mq(ij,l)=u_mq(ij,l)-q(ijq,l)*masse(ijq,l)
    302                         zu_m=zu_m+masse(ijq,l)
     308                     do while(-zu_m.gt.masse(ijq,l,iq))
     309                        u_mq(ij,l)=u_mq(ij,l)-q(ijq,l,iq)
     310     &                   *masse(ijq,l,iq)
     311                        zu_m=zu_m+masse(ijq,l,iq)
    303312                        i=mod(i,iim)+1
    304313                        ijq=(j-1)*iip1+i
    305314                     ENDDO
    306315c   ajout de la maille non completement advectee
    307                      u_mq(ij,l)=u_mq(ij,l)+zu_m*(q(ijq,l)-
    308      &               0.5*(1.+zu_m/masse(ijq,l))*dxq(ijq,l))
     316                     u_mq(ij,l)=u_mq(ij,l)+zu_m*(q(ijq,l,iq)-
     317     &               0.5*(1.+zu_m/masse(ijq,l,iq))*dxq(ijq,l))
    309318                  ENDIF
    310319               ENDDO
    … …  
    325334c$OMP END DO NOWAIT
    326335
     336! CRisi: appel récursif de l'advection sur les fils.
     337! Il faut faire ça avant d'avoir mis à jour q et masse
     338      !write(*,*) 'vlspltqs 336: iq,ijb_x,nqfils(iq)=',
     339!     &     iq,ijb_x,nqfils(iq) 
     340
     341      if (nqfils(iq).gt.0) then 
     342       do ifils=1,nqdesc(iq)
     343         iq2=iqfils(ifils,iq)
     344c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)   
     345         DO l=1,llm
     346          DO ij=ijb,ije
     347           masse(ij,l,iq2)=masse(ij,l,iq)*q(ij,l,iq)
     348           Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq)     
     349          enddo   
     350         enddo
     351c$OMP END DO NOWAIT
     352        enddo !do ifils=1,nqfils(iq)
     353        do ifils=1,nqfils(iq)
     354         iq2=iqfils(ifils,iq)
     355         !write(*,*) 'vlxqs 349: on appelle vlx pour iq2=',iq2
     356         call vlx_loc(Ratio,pente_max,masse,u_mq,ijb_x,ije_x,iq2)
     357        enddo !do ifils=1,nqfils(iq)
     358      endif !if (nqfils(iq).gt.0) then
     359! end CRisi
     360
     361      !write(*,*) 'vlspltqs 360: iq,ijb_x=',iq,ijb_x   
     362
    327363c   calcul des tendances
    328364c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
    329365      DO l=1,llm
    330366         DO ij=ijb+1,ije
    331             new_m=masse(ij,l)+u_m(ij-1,l)-u_m(ij,l)
    332             q(ij,l)=(q(ij,l)*masse(ij,l)+
     367            new_m=masse(ij,l,iq)+u_m(ij-1,l)-u_m(ij,l)
     368            q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+
    333369     &      u_mq(ij-1,l)-u_mq(ij,l))
    334370     &      /new_m
    335             masse(ij,l)=new_m
    336          ENDDO
    337 c   Modif Fred 22 03 96 correction d'un bug (les scopy ci-dessous)
     371            masse(ij,l,iq)=new_m
     372         ENDDO
     373c   Modif Fred 22 03 96 correction d''un bug (les scopy ci-dessous)
    338374         DO ij=ijb+iip1-1,ije,iip1
    339             q(ij-iim,l)=q(ij,l)
    340             masse(ij-iim,l)=masse(ij,l)
    341          ENDDO
    342       ENDDO
    343 c$OMP END DO NOWAIT
     375            q(ij-iim,l,iq)=q(ij,l,iq)
     376            masse(ij-iim,l,iq)=masse(ij,l,iq)
     377         ENDDO
     378      ENDDO
     379c$OMP END DO NOWAIT
     380
     381      !write(*,*) 'vlspltqs 380: iq,ijb_x=',iq,ijb_x
     382
     383! retablir les fils en rapport de melange par rapport a l'air:
     384      if (nqfils(iq).gt.0) then 
     385       do ifils=1,nqdesc(iq)
     386         iq2=iqfils(ifils,iq) 
     387c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)   
     388         DO l=1,llm
     389          DO ij=ijb+1,ije
     390            q(ij,l,iq2)=q(ij,l,iq)*Ratio(ij,l,iq2)           
     391          enddo
     392          DO ij=ijb+iip1-1,ije,iip1
     393             q(ij-iim,l,iq2)=q(ij,l,iq2)
     394          enddo ! DO ij=ijb+iip1-1,ije,iip1
     395         enddo
     396c$OMP END DO NOWAIT
     397        enddo !do ifils=1,nqdesc(iq)
     398      endif !if (nqfils(iq).gt.0) then
     399
     400      !write(*,*) 'vlspltqs 399: iq,ijb_x=',iq,ijb_x
     401
    344402c     CALL SCOPY((jjm-1)*llm,q(iip1+iip1,1),iip1,q(iip2,1),iip1)
    345 c     CALL SCOPY((jjm-1)*llm,masse(iip1+iip1,1),iip1,masse(iip2,1),iip1)
     403c     CALL SCOPY((jjm-1)*llm,masse(iip1+iip1,1,iq),iip1,masse(iip2,1,iq),iip1)
    346404
    347405
    348406      RETURN
    349407      END
    350       SUBROUTINE vlyqs_loc(q,pente_max,masse,masse_adv_v,qsat)
     408      SUBROUTINE vlyqs_loc(q,pente_max,masse,masse_adv_v,qsat,iq)
    351409c
    352410c     Auteurs:   P.Le Van, F.Hourdin, F.Forget
    … …  
    361419c   --------------------------------------------------------------------
    362420      USE parallel_lmdz
     421      USE infotrac, ONLY : nqtot,nqfils,nqdesc,iqfils ! CRisi 
    363422      IMPLICIT NONE
    364423c
    … …  
    373432c   Arguments:
    374433c   ----------
    375       REAL masse(ijb_u:ije_u,llm),pente_max
     434      REAL masse(ijb_u:ije_u,llm,nqtot),pente_max
    376435      REAL masse_adv_v( ijb_v:ije_v,llm)
    377       REAL q(ijb_u:ije_u,llm)
     436      REAL q(ijb_u:ije_u,llm,nqtot)
    378437      REAL qsat(ijb_u:ije_u,llm)
     438      INTEGER iq ! CRisi
    379439c
    380440c      Local
    … …  
    386446      REAL dyq(ijb_u:ije_u,llm),dyqv(ijb_v:ije_v)
    387447      REAL adyqv(ijb_v:ije_v),dyqmax(ijb_u:ije_u)
    388       REAL qbyv(ijb_v:ije_v,llm)
     448      REAL qbyv(ijb_v:ije_v,llm,nqtot)
    389449
    390450      REAL qpns,qpsn,dyn1,dys1,dyn2,dys2,newmasse,fn,fs
    … …  
    402462c
    403463c
     464      REAL Ratio(ijb_u:ije_u,llm,nqtot) ! CRisi
     465      INTEGER ifils,iq2 ! CRisi
     466
    404467      REAL      SSUM
    405468
    … …  
    407470      INTEGER ijb,ije
    408471
     472      ijb=ij_begin-2*iip1
     473      ije=ij_end+2*iip1 
     474      if (pole_nord) ijb=ij_begin
     475      if (pole_sud)  ije=ij_end
     476      ij=3525
     477      l=3
     478      if ((ij.ge.ijb).and.(ij.le.ije)) then
     479        !write(*,*) 'vlyqs 480: ij,l,iq,ijb,q(ij,l,:)=',
     480!     &             ij,l,iq,ijb,q(ij,l,:)
     481      endif 
     482
    409483      IF(first) THEN
    410484         PRINT*,'Shema  Amont nouveau  appele dans  Vanleer   '
     485         PRINT*,'vlyqs_loc, iq=',iq
    411486         first=.false.
    412487         do i=2,iip1
    … …  
    439514      if (pole_nord) then
    440515        DO i = 1, iim
    441           airescb(i) = aire(i+ iip1) * q(i+ iip1,l)
     516          airescb(i) = aire(i+ iip1) * q(i+ iip1,l,iq)
    442517        ENDDO
    443518        qpns   = SSUM( iim,  airescb ,1 ) / airej2
    … …  
    446521      if (pole_sud) then
    447522        DO i = 1, iim
    448           airesch(i) = aire(i+ ip1jm- iip1) * q(i+ ip1jm- iip1,l)
     523          airesch(i) = aire(i+ ip1jm- iip1) * q(i+ ip1jm- iip1,l,iq)
    449524        ENDDO
    450525        qpsn   = SSUM( iim,  airesch ,1 ) / airejjm
    … …  
    460535     
    461536      DO ij=ijb,ije
    462          dyqv(ij)=q(ij,l)-q(ij+iip1,l)
     537         dyqv(ij)=q(ij,l,iq)-q(ij+iip1,l,iq)
    463538         adyqv(ij)=abs(dyqv(ij))
    464539      ENDDO
    … …  
    482557c   calcul des pentes aux poles
    483558        DO ij=1,iip1
    484            dyq(ij,l)=qpns-q(ij+iip1,l)
     559           dyq(ij,l)=qpns-q(ij+iip1,l,iq)
    485560        ENDDO
    486561
    … …  
    513588
    514589        DO ij=1,iip1
    515            dyq(ip1jm+ij,l)=q(ip1jm+ij-iip1,l)-qpsn
     590           dyq(ip1jm+ij,l)=q(ip1jm+ij-iip1,l,iq)-qpsn
    516591        ENDDO
    517592
    … …  
    636711       DO ij=ijb,ije
    637712         IF( masse_adv_v(ij,l).GT.0. ) THEN
    638            qbyv(ij,l)= MIN( qsat(ij+iip1,l), q(ij+iip1,l )  +
    639      ,      dyq(ij+iip1,l)*0.5*(1.-masse_adv_v(ij,l)/masse(ij+iip1,l)))
     713           qbyv(ij,l,iq)= MIN( qsat(ij+iip1,l), q(ij+iip1,l,iq )  +
     714     ,      dyq(ij+iip1,l)*0.5*(1.-masse_adv_v(ij,l)
     715     ,      /masse(ij+iip1,l,iq)))
    640716         ELSE
    641               qbyv(ij,l)= MIN( qsat(ij,l), q(ij,l) - dyq(ij,l) *
    642      ,                   0.5*(1.+masse_adv_v(ij,l)/masse(ij,l)) )
     717              qbyv(ij,l,iq)= MIN( qsat(ij,l), q(ij,l,iq) - dyq(ij,l) *
     718     ,                   0.5*(1.+masse_adv_v(ij,l)/masse(ij,l,iq)) )
    643719         ENDIF
    644           qbyv(ij,l) = masse_adv_v(ij,l)*qbyv(ij,l)
     720          qbyv(ij,l,iq) = masse_adv_v(ij,l)*qbyv(ij,l,iq)
    645721       ENDDO
    646722      ENDDO
    647723c$OMP END DO NOWAIT
     724
     725! CRisi: appel récursif de l'advection sur les fils.
     726! Il faut faire ça avant d'avoir mis à jour q et masse
     727      !write(*,*) 'vlyqs 689: iq,nqfils(iq)=',iq,nqfils(iq)
     728     
     729      ijb=ij_begin-2*iip1
     730      ije=ij_end+2*iip1
     731      if (pole_nord) ijb=ij_begin
     732      if (pole_sud)  ije=ij_end 
     733
     734      if (nqfils(iq).gt.0) then 
     735       do ifils=1,nqdesc(iq)
     736         iq2=iqfils(ifils,iq)
     737c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)   
     738         DO l=1,llm
     739          DO ij=ijb,ije
     740           masse(ij,l,iq2)=masse(ij,l,iq)*q(ij,l,iq)
     741           Ratio(ij,l,iq2)=q(ij,l,iq2)/q(ij,l,iq)   
     742          enddo   
     743         enddo
     744c$OMP END DO NOWAIT
     745        enddo !do ifils=1,nqdesc(iq)
     746        do ifils=1,nqfils(iq)
     747         iq2=iqfils(ifils,iq)
     748         call vly_loc(Ratio,pente_max,masse,qbyv,iq2)
     749        enddo !do ifils=1,nqfils(iq)
     750      endif !if (nqfils(iq).gt.0) then
     751
     752       
     753! end CRisi
    648754
    649755      ijb=ij_begin
    … …  
    655761      DO l=1,llm
    656762         DO ij=ijb,ije
    657             newmasse=masse(ij,l)
     763            newmasse=masse(ij,l,iq)
    658764     &      +masse_adv_v(ij,l)-masse_adv_v(ij-iip1,l)
    659             q(ij,l)=(q(ij,l)*masse(ij,l)+qbyv(ij,l)-qbyv(ij-iip1,l))
    660      &         /newmasse
    661             masse(ij,l)=newmasse
     765            q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+qbyv(ij,l,iq)
     766     &         -qbyv(ij-iip1,l,iq))/newmasse
     767            masse(ij,l,iq)=newmasse
    662768         ENDDO
    663769c.-. ancienne version
    … …  
    665771         IF (pole_nord) THEN
    666772
    667            convpn=SSUM(iim,qbyv(1,l),1)/apoln
     773           convpn=SSUM(iim,qbyv(1,l,iq),1)/apoln
    668774           convmpn=ssum(iim,masse_adv_v(1,l),1)/apoln
    669775           DO ij = 1,iip1
    670               newmasse=masse(ij,l)+convmpn*aire(ij)
    671               q(ij,l)=(q(ij,l)*masse(ij,l)+convpn*aire(ij))/
     776              newmasse=masse(ij,l,iq)+convmpn*aire(ij)
     777              q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+convpn*aire(ij))/
    672778     &                 newmasse
    673               masse(ij,l)=newmasse
     779              masse(ij,l,iq)=newmasse
    674780           ENDDO
    675781         
    … …  
    678784         IF (pole_sud) THEN
    679785         
    680            convps  = -SSUM(iim,qbyv(ip1jm-iim,l),1)/apols
     786           convps  = -SSUM(iim,qbyv(ip1jm-iim,l,iq),iq,1)/apols
    681787           convmps = -SSUM(iim,masse_adv_v(ip1jm-iim,l),1)/apols
    682788           DO ij = ip1jm+1,ip1jmp1
    683               newmasse=masse(ij,l)+convmps*aire(ij)
    684               q(ij,l)=(q(ij,l)*masse(ij,l)+convps*aire(ij))/
     789              newmasse=masse(ij,l,iq)+convmps*aire(ij)
     790              q(ij,l,iq)=(q(ij,l,iq)*masse(ij,l,iq)+convps*aire(ij))/
    685791     &                 newmasse
    686               masse(ij,l)=newmasse
     792              masse(ij,l,iq)=newmasse
    687793           ENDDO
    688794         
    … …  
    691797
    692798c._. nouvelle version
    693 c        convpn=SSUM(iim,qbyv(1,l),1)
     799c        convpn=SSUM(iim,qbyv(1,l,iq),1)
    694800c        convmpn=ssum(iim,masse_adv_v(1,l),1)
    695 c        oldmasse=ssum(iim,masse(1,l),1)
     801c        oldmasse=ssum(iim,masse(1,l,iq),1)
    696802c        newmasse=oldmasse+convmpn
    697 c        newq=(q(1,l)*oldmasse+convpn)/newmasse
     803c        newq=(q(1,l,iq)*oldmasse+convpn)/newmasse
    698804c        newmasse=newmasse/apoln
    699805c        DO ij = 1,iip1
    700 c           q(ij,l)=newq
    701 c           masse(ij,l)=newmasse*aire(ij)
     806c           q(ij,l,iq)=newq
     807c           masse(ij,l,iq)=newmasse*aire(ij)
    702808c        ENDDO
    703 c        convps=-SSUM(iim,qbyv(ip1jm-iim,l),1)
     809c        convps=-SSUM(iim,qbyv(ip1jm-iim,l,iq),1)
    704810c        convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1)
    705 c        oldmasse=ssum(iim,masse(ip1jm-iim,l),1)
     811c        oldmasse=ssum(iim,masse(ip1jm-iim,l,iq),1)
    706812c        newmasse=oldmasse+convmps
    707 c        newq=(q(ip1jmp1,l)*oldmasse+convps)/newmasse
     813c        newq=(q(ip1jmp1,l,iq)*oldmasse+convps)/newmasse
    708814c        newmasse=newmasse/apols
    709815c        DO ij = ip1jm+1,ip1jmp1
    710 c           q(ij,l)=newq
    711 c           masse(ij,l)=newmasse*aire(ij)
     816c           q(ij,l,iq)=newq
     817c           masse(ij,l,iq)=newmasse*aire(ij)
    712818c        ENDDO
    713819c._. fin nouvelle version
    714820      ENDDO
    715821c$OMP END DO NOWAIT
     822
     823! retablir les fils en rapport de melange par rapport a l'air:
     824      ijb=ij_begin
     825      ije=ij_end
     826!      if (pole_nord) ijb=ij_begin+iip1
     827!      if (pole_sud)  ije=ij_end-iip1
     828 
     829      if (nqfils(iq).gt.0) then 
     830       do ifils=1,nqdesc(iq)
     831         iq2=iqfils(ifils,iq) 
     832c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)   
     833         DO l=1,llm
     834          DO ij=ijb,ije
     835            q(ij,l,iq2)=q(ij,l,iq)*Ratio(ij,l,iq2)           
     836          enddo
     837         enddo
     838c$OMP END DO NOWAIT
     839        enddo !do ifils=1,nqdesc(iq)
     840      endif !if (nqfils(iq).gt.0) then
     841
     842
    716843      RETURN
    717844      END

  • LMDZ5/branches/testing/libf/dyn3dmem/vlz_mod.F90

    r1910 r2298  
    11MODULE vlz_mod
    22
    3   REAL,POINTER,SAVE :: wq(:,:)
     3  REAL,POINTER,SAVE :: wq(:,:,:)
    44  REAL,POINTER,SAVE :: dzq(:,:)
    55  REAL,POINTER,SAVE :: dzqw(:,:)
    66  REAL,POINTER,SAVE :: adzqw(:,:)
     7  ! CRisi: pour les traceurs: 
     8  !REAL,POINTER,SAVE :: masseq(:,:,:)
     9  REAL,POINTER,SAVE :: Ratio(:,:,:)
    710 
    811CONTAINS
    … …  
    1821   
    1922    d=>distrib_vanleer
    20     CALL allocate_u(wq,llm+1,d)
     23    CALL allocate_u(wq,llm+1,nqtot,d)
    2124    CALL allocate_u(dzq,llm,d)
    2225    CALL allocate_u(dzqw,llm,d)
    2326    CALL allocate_u(adzqw,llm,d)
     27    if (nqdesc_tot.gt.0) then
     28    !CALL allocate_u(masseq,llm,nqtot,d)
     29    CALL allocate_u(Ratio,llm,nqtot,d)
     30    endif !if (nqdesc_tot.gt.0) then
    2431
    2532  END SUBROUTINE vlz_allocate
    … …  
    2936  USE bands
    3037  USE parallel_lmdz
     38  USE infotrac
    3139  IMPLICIT NONE
    3240    TYPE(distrib),INTENT(IN) :: dist
    … …  
    3644    CALL switch_u(dzqw,distrib_vanleer,dist)
    3745    CALL switch_u(adzqw,distrib_vanleer,dist)
     46    ! CRisi:
     47    if (nqdesc_tot.gt.0) then   
     48    !CALL switch_u(masseq,distrib_vanleer,dist)
     49    CALL switch_u(Ratio,distrib_vanleer,dist)
     50    endif !if (nqdesc_tot.gt.0) then     
    3851
    3952  END SUBROUTINE vlz_switch_vanleer 

  • LMDZ5/branches/testing/libf/dyn3dpar/advtrac_p.F90

    r1999 r2298  
    1010  !            M.A Filiberti (04/2002)
    1111  !
    12   USE parallel_lmdz
    13   USE Write_Field_p
    14   USE Bands
     12  USE parallel_lmdz, ONLY: ij_begin,ij_end,OMP_CHUNK,pole_nord,pole_sud,&
     13                           setdistrib
     14  USE Write_Field_p, ONLY: WriteField_p
     15  USE Bands, ONLY: jj_Nb_Caldyn,jj_Nb_vanleer
    1516  USE mod_hallo
    1617  USE Vampir

  • LMDZ5/branches/testing/libf/dyn3dpar/covcont_p.F

    r1910 r2298  
    11      SUBROUTINE covcont_p (klevel,ucov, vcov, ucont, vcont )
    2       USE parallel_lmdz
     2      USE parallel_lmdz, ONLY: ij_begin,ij_end,OMP_CHUNK,
     3     &                         pole_nord, pole_sud
    34      IMPLICIT NONE
    45

  • LMDZ5/branches/testing/libf/dyn3dpar/gcm.F

    r2258 r2298  
    1414      USE parallel_lmdz
    1515      USE infotrac
    16       USE mod_interface_dyn_phys
     16#ifdef CPP_PHYS
     17      USE mod_interface_dyn_phys, ONLY: init_interface_dyn_phys
     18#endif
    1719      USE mod_hallo
    1820      USE Bands

  • LMDZ5/branches/testing/libf/dyn3dpar/leapfrog_p.F

    r2258 r2298  
    825825cc$OMP BARRIER
    826826!        CALL FTRACE_REGION_BEGIN("calfis")
     827#ifdef CPP_PHYS
    827828        CALL calfis_p(lafin ,jD_cur, jH_cur,
    828829     $               ucov,vcov,teta,q,masse,ps,p,pk,phis,phi ,
    829830     $               du,dv,dteta,dq,
    830831     $               flxw, dufi,dvfi,dtetafi,dqfi,dpfi  )
     832#endif
    831833!        CALL FTRACE_REGION_END("calfis")
    832834        ijb=ij_begin

  • LMDZ5/branches/testing/libf/dyn3dpar/mod_hallo.F90

    r1910 r2298  
    11module mod_Hallo
    2 USE parallel_lmdz
     2USE mod_const_mpi, ONLY: COMM_LMDZ,MPI_REAL_LMDZ
     3USE parallel_lmdz, ONLY: using_mpi, mpi_size, mpi_rank, omp_chunk, omp_rank, &
     4                         pole_nord, pole_sud, jj_begin, jj_end, &
     5                         jj_begin_para, jj_end_para
    36implicit none
    47  logical,save :: use_mpi_alloc

  • LMDZ5/branches/testing/libf/dyn3dpar/parallel_lmdz.F90

    r2056 r2298  
    3131    integer, save :: omp_size 
    3232!$OMP THREADPRIVATE(omp_rank)
     33
     34! Ehouarn: add "dummy variables" (which are in dyn3d_mem/parallel_lmdz.F90)
     35! so that calfis_loc compiles even if using dyn3dpar
     36    integer,save  :: jjb_u
     37    integer,save  :: jje_u
     38    integer,save  :: jjnb_u
     39    integer,save  :: jjb_v
     40    integer,save  :: jje_v
     41    integer,save  :: jjnb_v   
     42
     43    integer,save  :: ijb_u
     44    integer,save  :: ije_u
     45    integer,save  :: ijnb_u   
     46   
     47    integer,save  :: ijb_v
     48    integer,save  :: ije_v
     49    integer,save  :: ijnb_v   
    3350
    3451 contains

  • LMDZ5/branches/testing/libf/grid/dimension/makdim

    r2220 r2298  
    1212fi
    1313
    14 if (($1 % 8 != 0)) && (( $# = 3 ))
     14if (($1 % 8 != 0)) && (( $# == 3 ))
    1515then
    1616    echo "The number of longitudes must be a multiple of 8."

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

    r1921 r2298  
    44!IM on initialise les variables
    55!
    6         missing_val=nf90_fill_real
     6!       missing_val=nf90_fill_real
    77!
    88        CALL ini_undefSTD(itap,itapm1)

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

    r1910 r2298  
    55CONTAINS
    66  SUBROUTINE calcul_fluxs( knon, nisurf, dtime, &
    7        tsurf, p1lay, cal, beta, coef1lay, ps, &
     7       tsurf, p1lay, cal, beta, cdragh, cdragq, ps, &
    88       precip_rain, precip_snow, snow, qsurf, &
    9        radsol, dif_grnd, t1lay, q1lay, u1lay, v1lay, &
    10        petAcoef, peqAcoef, petBcoef, peqBcoef, &
     9       radsol, dif_grnd, t1lay, q1lay, u1lay, v1lay, gustiness, &
     10       fqsat, petAcoef, peqAcoef, petBcoef, peqBcoef, &
    1111       tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l)
    1212   
    1313    USE dimphy, ONLY : klon
    1414    USE indice_sol_mod
     15
     16    INCLUDE "clesphys.h"
    1517
    1618! Cette routine calcule les fluxs en h et q a l'interface et eventuellement
    … …  
    2628!   cal          capacite calorifique du sol
    2729!   beta         evap reelle
    28 !   coef1lay     coefficient d'echange
     30!   cdragh       coefficient d'echange temperature
     31!   cdragq       coefficient d'echange evaporation
    2932!   ps           pression au sol
    3033!   precip_rain  precipitations liquides
    … …  
    5962    REAL, DIMENSION(klon), INTENT(IN)    :: petBcoef, peqBcoef
    6063    REAL, DIMENSION(klon), INTENT(IN)    :: ps, q1lay
    61     REAL, DIMENSION(klon), INTENT(IN)    :: tsurf, p1lay, cal, beta, coef1lay
     64    REAL, DIMENSION(klon), INTENT(IN)    :: tsurf, p1lay, cal, beta, cdragh,cdragq
    6265    REAL, DIMENSION(klon), INTENT(IN)    :: precip_rain, precip_snow ! pas utiles
    6366    REAL, DIMENSION(klon), INTENT(IN)    :: radsol, dif_grnd
    64     REAL, DIMENSION(klon), INTENT(IN)    :: t1lay, u1lay, v1lay
     67    REAL, DIMENSION(klon), INTENT(IN)    :: t1lay, u1lay, v1lay,gustiness
     68    REAL,                  INTENT(IN)    :: fqsat ! correction factor on qsat (generally 0.98 over salty water, 1 everywhere else)
    6569
    6670! Parametres entree-sorties
    … …  
    7983    REAL, DIMENSION(klon)                :: zx_mh, zx_nh, zx_oh
    8084    REAL, DIMENSION(klon)                :: zx_mq, zx_nq, zx_oq
    81     REAL, DIMENSION(klon)                :: zx_pkh, zx_dq_s_dt, zx_qsat, zx_coef
    82     REAL, DIMENSION(klon)                :: zx_sl, zx_k1
     85    REAL, DIMENSION(klon)                :: zx_pkh, zx_dq_s_dt, zx_qsat
     86    REAL, DIMENSION(klon)                :: zx_sl, zx_coefh, zx_coefq, zx_wind
    8387    REAL, DIMENSION(klon)                :: d_ts
    8488    REAL                                 :: zdelta, zcvm5, zx_qs, zcor, zx_dq_s_dh
    … …  
    125129    fluxlat=0.
    126130    dflux_s = 0.
    127     dflux_l = 0.       
     131    dflux_l = 0.
    128132!
    129133! zx_qs = qsat en kg/kg
    … …  
    154158       zx_dq_s_dt(i) = RCPD * zx_pkh(i) * zx_dq_s_dh
    155159       zx_qsat(i) = zx_qs
    156        zx_coef(i) = coef1lay(i) * &
    157             (1.0+SQRT(u1lay(i)**2+v1lay(i)**2)) * &
    158             p1lay(i)/(RD*t1lay(i))
    159        
     160       zx_wind(i)=min_wind_speed+SQRT(gustiness(i)+u1lay(i)**2+v1lay(i)**2)
     161       zx_coefh(i) = cdragh(i) * zx_wind(i) * p1lay(i)/(RD*t1lay(i))
     162       zx_coefq(i) = cdragq(i) * zx_wind(i) * p1lay(i)/(RD*t1lay(i))
     163!      zx_wind(i)=min_wind_speed+SQRT(gustiness(i)+u1lay(i)**2+v1lay(i)**2) &
     164!                * p1lay(i)/(RD*t1lay(i))
     165!      zx_coefh(i) = cdragh(i) * zx_wind(i)
     166!      zx_coefq(i) = cdragq(i) * zx_wind(i)
    160167    ENDDO
    161168
    … …  
    168175       zx_sl(i) = RLVTT
    169176       IF (tsurf(i) .LT. RTT) zx_sl(i) = RLSTT
    170        zx_k1(i) = zx_coef(i)
    171177    ENDDO
    172178   
    … …  
    174180    DO i = 1, knon
    175181! Q
    176        zx_oq(i) = 1. - (beta(i) * zx_k1(i) * peqBcoef(i) * dtime)
    177        zx_mq(i) = beta(i) * zx_k1(i) * &
    178             (peqAcoef(i) - zx_qsat(i) + &
    179             zx_dq_s_dt(i) * tsurf(i)) &
     182       zx_oq(i) = 1. - (beta(i) * zx_coefq(i) * peqBcoef(i) * dtime)
     183       zx_mq(i) = beta(i) * zx_coefq(i) * &
     184            (peqAcoef(i) -             &
     185! conv num avec precedente version
     186            fqsat * zx_qsat(i) + fqsat * zx_dq_s_dt(i) * tsurf(i))  &
     187!           fqsat * ( zx_qsat(i) - zx_dq_s_dt(i) * tsurf(i)) ) &
    180188            / zx_oq(i)
    181        zx_nq(i) = beta(i) * zx_k1(i) * (-1. * zx_dq_s_dt(i)) &
     189       zx_nq(i) = beta(i) * zx_coefq(i) * (- fqsat * zx_dq_s_dt(i)) &
    182190            / zx_oq(i)
    183191       
    184192! H
    185        zx_oh(i) = 1. - (zx_k1(i) * petBcoef(i) * dtime)
    186        zx_mh(i) = zx_k1(i) * petAcoef(i) / zx_oh(i)
    187        zx_nh(i) = - (zx_k1(i) * RCPD * zx_pkh(i))/ zx_oh(i)
     193       zx_oh(i) = 1. - (zx_coefh(i) * petBcoef(i) * dtime)
     194       zx_mh(i) = zx_coefh(i) * petAcoef(i) / zx_oh(i)
     195       zx_nh(i) = - (zx_coefh(i) * RCPD * zx_pkh(i))/ zx_oh(i)
    188196     
    189197! Tsurface
    … …  
    244252!
    245253  SUBROUTINE calcul_flux_wind(knon, dtime, &
    246        u0, v0, u1, v1, cdrag_m, &
     254       u0, v0, u1, v1, gustiness, cdrag_m, &
    247255       AcoefU, AcoefV, BcoefU, BcoefV, &
    248256       p1lay, t1lay, &
    … …  
    251259    USE dimphy
    252260    INCLUDE "YOMCST.h"
     261    INCLUDE "clesphys.h"
    253262
    254263! Input arguments
    … …  
    257266    REAL, INTENT(IN)                     :: dtime
    258267    REAL, DIMENSION(klon), INTENT(IN)    :: u0, v0  ! u and v at niveau 0
    259     REAL, DIMENSION(klon), INTENT(IN)    :: u1, v1  ! u and v at niveau 1
     268    REAL, DIMENSION(klon), INTENT(IN)    :: u1, v1, gustiness  ! u and v at niveau 1
    260269    REAL, DIMENSION(klon), INTENT(IN)    :: cdrag_m ! cdrag pour momentum
    261270    REAL, DIMENSION(klon), INTENT(IN)    :: AcoefU, AcoefV, BcoefU, BcoefV
    … …  
    277286!****************************************************************************************
    278287    DO i=1,knon
    279        mod_wind = 1.0 + SQRT((u1(i) - u0(i))**2 + (v1(i)-v0(i))**2)
     288       mod_wind = min_wind_speed + SQRT(gustiness(i)+(u1(i) - u0(i))**2 + (v1(i)-v0(i))**2)
    280289       buf = cdrag_m(i) * mod_wind * p1lay(i)/(RD*t1lay(i))
    281290       flux_u1(i) = (AcoefU(i) - u0(i)) / (1/buf - BcoefU(i)*dtime )

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

    r1910 r2298  
    157157    itc=0
    158158    DO it=1,nbtr
    159        iiq=niadv(it+2)
     159!!       iiq=niadv(it+2)                                                            ! jyg
     160       iiq=niadv(it+nqo)                                                            ! jyg
    160161       
    161162       SELECT CASE(tname(iiq))

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

    r2258 r2298  
    44 SUBROUTINE cdrag( knon,  nsrf,   &
    55     speed, t1,    q1,    zgeop1, &
    6      psol,  tsurf, qsurf, rugos,  &
     6     psol,  tsurf, qsurf, z0m, z0h,  &
    77     pcfm,  pcfh,  zri,   pref )
    88
    … …  
    4545! tsurf---input-R- temperature de l'air a la surface
    4646! qsurf---input-R- humidite de l'air a la surface
    47 ! rugos---input-R- rugosite
     47! z0m, z0h---input-R- rugosite
    4848!! u1, v1 are removed, speed is used. Fuxing WANG, 04/03/2015,
    4949!! u1------input-R- vent zonal au 1er niveau du modele
    … …  
    7171  REAL, DIMENSION(klon), INTENT(IN)        :: tsurf ! Surface temperature (K)
    7272  REAL, DIMENSION(klon), INTENT(IN)        :: qsurf ! Surface humidity (Kg/Kg)
    73   REAL, DIMENSION(klon), INTENT(IN)        :: rugos ! Rugosity at surface (m)
     73  REAL, DIMENSION(klon), INTENT(IN)        :: z0m, z0h ! Rugosity at surface (m)
    7474!  paprs, pplay u1, v1: to be deleted
    7575!  they were in the old clcdrag. Fuxing WANG, 04/03/2015
    … …  
    113113  REAL, DIMENSION(klon) :: zcfh1, zcfh2 ! Drag coefficient for heat flux
    114114  LOGICAL, PARAMETER    :: zxli=.FALSE. ! calcul des cdrags selon Laurent Li
    115   REAL, DIMENSION(klon) :: zcdn         ! Drag coefficient in neutral conditions
     115  REAL, DIMENSION(klon) :: zcdn_m, zcdn_h         ! Drag coefficient in neutral conditions
    116116!
    117117! Fonctions thermodynamiques et fonctions d'instabilite
    … …  
    174174          *(1.+RETV*max(q1(i),0.0)) ! negative q1 set to zero
    175175     zri(i) = zgeop1(i)*(ztvd-ztsolv)/(zdu2*ztvd)
    176      zcdn(i) = (CKAP/LOG(1.+zgeop1(i)/(RG*rugos(i))))**2
     176
     177
     178! Coefficients CD neutres pour m et h
     179     zcdn_m(i) = (CKAP/LOG(1.+zgeop1(i)/(RG*z0m(i))))**2
     180     zcdn_h(i) = (CKAP/LOG(1.+zgeop1(i)/(RG*z0h(i))))**2
    177181
    178182     IF (zri(i) .GT. 0.) THEN      ! situation stable
    … …  
    181185           zscf = SQRT(1.+CD*ABS(zri(i)))
    182186           friv = AMAX1(1. / (1.+2.*CB*zri(i)/ZSCF), f_ri_cd_min)
    183            zcfm1(i) = zcdn(i) * friv
     187           zcfm1(i) = zcdn_m(i) * friv
    184188           frih = AMAX1(1./ (1.+3.*CB*zri(i)*ZSCF), f_ri_cd_min )
    185189!!$ PB     zcfh1(i) = zcdn(i) * frih
    186190!!$ PB     zcfh1(i) = f_cdrag_stable * zcdn(i) * frih
    187            zcfh1(i) = f_cdrag_ter * zcdn(i) * frih
    188            IF(nsrf.EQ.is_oce) zcfh1(i) = f_cdrag_oce * zcdn(i) * frih
     191           zcfh1(i) = f_cdrag_ter * zcdn_h(i) * frih
     192           IF(nsrf.EQ.is_oce) zcfh1(i) = f_cdrag_oce * zcdn_h(i) * frih
    189193!!$ PB
    190194           pcfm(i) = zcfm1(i)
    191195           pcfh(i) = zcfh1(i)
    192196        ELSE
    193            pcfm(i) = zcdn(i)* fsta(zri(i))
    194            pcfh(i) = zcdn(i)* fsta(zri(i))
     197           pcfm(i) = zcdn_m(i)* fsta(zri(i))
     198           pcfh(i) = zcdn_h(i)* fsta(zri(i))
    195199        ENDIF
    196200     ELSE                          ! situation instable
    197201        IF (.NOT.zxli) THEN
    198            zucf = 1./(1.+3.0*CB*CC*zcdn(i)*SQRT(ABS(zri(i)) &
    199                 *(1.0+zgeop1(i)/(RG*rugos(i)))))
    200            zcfm2(i) = zcdn(i)*amax1((1.-2.0*CB*zri(i)*zucf),f_ri_cd_min)
    201 !!$ PB     zcfh2(i) = zcdn(i)*amax1((1.-3.0*cb*zri(i)*zucf),f_ri_cd_min)
    202            zcfh2(i) = f_cdrag_ter*zcdn(i)*amax1((1.-3.0*CB*zri(i)*zucf),f_ri_cd_min)
     202           zucf = 1./(1.+3.0*CB*CC*zcdn_m(i)*SQRT(ABS(zri(i)) &
     203                *(1.0+zgeop1(i)/(RG*z0m(i)))))
     204           zcfm2(i) = zcdn_m(i)*amax1((1.-2.0*CB*zri(i)*zucf),f_ri_cd_min)
     205!!$ PB     zcfh2(i) = zcdn_h(i)*amax1((1.-3.0*cb*zri(i)*zucf),f_ri_cd_min)
     206           zcfh2(i) = f_cdrag_ter*zcdn_h(i)*amax1((1.-3.0*CB*zri(i)*zucf),f_ri_cd_min)
    203207           pcfm(i) = zcfm2(i)
    204208           pcfh(i) = zcfh2(i)
    205209        ELSE
    206            pcfm(i) = zcdn(i)* fins(zri(i))
    207            pcfh(i) = zcdn(i)* fins(zri(i))
     210           pcfm(i) = zcdn_m(i)* fins(zri(i))
     211           pcfh(i) = zcdn_h(i)* fins(zri(i))
    208212        ENDIF
    209 ! cdrah sur l'ocean cf. Miller et al. (1992)
    210         zcr = (0.0016/(zcdn(i)*SQRT(zdu2)))*ABS(ztvd-ztsolv)**(1./3.)
    211         IF(nsrf.EQ.is_oce) pcfh(i) =f_cdrag_oce* zcdn(i)*(1.0+zcr**1.25)**(1./1.25)
     213        IF(iflag_gusts==0) THEN
     214! cdrah sur l'ocean cf. Miller et al. (1992) - only active when gustiness parameterization is not active
     215           zcr = (0.0016/(zcdn_m(i)*SQRT(zdu2)))*ABS(ztvd-ztsolv)**(1./3.)
     216           IF(nsrf.EQ.is_oce) pcfh(i) =f_cdrag_oce* zcdn_h(i)*(1.0+zcr**1.25)**(1./1.25)
     217        ENDIF
    212218     ENDIF
    213219  END DO

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

    r2258 r2298  
    1212
    1313  SUBROUTINE change_srf_frac(itime, dtime, jour, &
    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 <<<
     14        pctsrf, evap, z0m, z0h, agesno,              &
     15        alb_dir, alb_dif, tsurf, ustar, u10m, v10m, pbl_tke)
    1816   
    1917
    … …  
    5452   
    5553    REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: pctsrf ! sub-surface fraction
     54    REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: evap, agesno ! sub-surface fraction
     55    REAL, DIMENSION(klon,nbsrf+1), INTENT(INOUT) :: z0m,z0h ! sub-surface fraction
    5656!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
    5957    REAL, DIMENSION(klon,nsw,nbsrf), INTENT(INOUT) :: alb_dir,alb_dif
    6058!albedo SB <<<
    … …  
    176174!****************************************************************************************
    177175
    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 
     176       CALL pbl_surface_newfrac(itime, pctsrf, pctsrf_old,        &
     177           evap, z0m, z0h, agesno,                                &
     178           tsurf, alb_dir,alb_dif, ustar, u10m, v10m, pbl_tke)
    184179
    185180

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

    r2258 r2298  
    129129           pcfh(i) = zcdn(i)* fins(zri(i))
    130130        ENDIF
    131         zcr = (0.0016/(zcdn(i)*SQRT(zdu2)))*ABS(ztvd-ztsolv)**(1./3.)
    132         IF(nsrf.EQ.is_oce) pcfh(i) =f_cdrag_oce* zcdn(i)*(1.0+zcr**1.25)**(1./1.25)
     131        IF(iflag_gusts==0) THEN
     132! cdrah sur l'ocean cf. Miller et al. (1992) - only active when gustiness parameterization is not active
     133           zcr = (0.0016/(zcdn(i)*SQRT(zdu2)))*ABS(ztvd-ztsolv)**(1./3.)
     134           IF(nsrf.EQ.is_oce) pcfh(i) =f_cdrag_oce* zcdn(i)*(1.0+zcr**1.25)**(1./1.25)
     135        ENDIF
    133136     ENDIF
    134137  END DO

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

    r2258 r2298  
    4444! Frottement au sol (Cdrag)
    4545       Real f_cdrag_ter,f_cdrag_oce
     46       REAL min_wind_speed,f_gust_wk,f_gust_bl,f_qsat_oce,f_z0qh_oce
     47       REAL z0m_seaice,z0h_seaice
     48       INTEGER iflag_gusts,iflag_z0_oce
     49
    4650! Rugoro
    47        Real f_rugoro
     51       Real f_rugoro,z0min
    4852
    4953!IM lev_histhf  : niveau sorties 6h
    … …  
    9195     &     , cdmmax, cdhmax, ksta, ksta_ter, f_ri_cd_min                &
    9296     &     , fmagic, pmagic                                             &
    93      &     , f_cdrag_ter,f_cdrag_oce,f_rugoro                           &
     97     &     , f_cdrag_ter,f_cdrag_oce,f_rugoro,z0min                     &
     98     &     , min_wind_speed,f_gust_wk,f_gust_bl,f_qsat_oce,f_z0qh_oce   &
     99     &     , z0m_seaice,z0h_seaice                                      &
    94100     &     , pasphys            , freq_outNMC, freq_calNMC              &
    95101     &     , lonmin_ins, lonmax_ins, latmin_ins, latmax_ins             &
    … …  
    115121     &     , ok_mensuelCOSP,ok_journeCOSP,ok_hfCOSP                     &
    116122     &     , ip_ebil_phy                                                &
     123     &     , iflag_gusts ,iflag_z0_oce                                  &
    117124     &     , ok_lic_melt,           aer_type                            &
    118125     &     , iflag_rrtm, ok_strato,ok_hines, ok_qch4                    &

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

    r2160 r2298  
    55
    66
     7      USE IOIPSL, ONLY : getin
    78      IMPLICIT NONE
    89
    … …  
    3940     
    4041     
    41       REAL sigma1(ngrid,klev)                                                         
     42      REAL sigma1(ngrid,klev)
    4243      REAL sigma2(ngrid,klev)
    4344      REAL qlth(ngrid,klev)
    … …  
    4849      REAL ctot(ngrid,klev)
    4950      REAL rneb(ngrid,klev)
    50       REAL t(ngrid,klev)                                                                 
     51      REAL t(ngrid,klev)
    5152      REAL qsatmmussig1,qsatmmussig2,sqrt2pi,pi
    5253      REAL rdd,cppd,Lv
    … …  
    6263      REAL erf
    6364
    64 
    65 
    66 
    67 
    68 !      print*,ngrid,klev,ind1,ind2,ztv(ind1,ind2),po(ind1),zqta(ind1,ind2), &
    69 !     &       fraca(ind1,ind2),zpspsk(ind1,ind2),paprs(ind1,ind2),ztla(ind1,ind2),zthl(ind1,ind2), &
    70 !     &       'verif'
    71 
    72 
    73 !      LOGICAL active(ngrid)   
    74      
    75 !-----------------------------------------------------------------------------------------------------------------
     65      REAL, SAVE :: iflag_cloudth_vert, iflag_cloudth_vert_omp=0
     66
     67
     68      LOGICAL, SAVE :: first=.true.
     69
     70
     71
     72
     73
     74!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     75! Astuce pour gérer deux versions de cloudth en attendant
     76! de converger sur une version nouvelle
     77!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     78      IF (first) THEN
     79     !$OMP MASTER
     80     CALL getin('iflag_cloudth_vert',iflag_cloudth_vert_omp)
     81     !$OMP END MASTER
     82     !$OMP BARRIER
     83     iflag_cloudth_vert=iflag_cloudth_vert_omp
     84      first=.false.
     85      ENDIF
     86       IF (iflag_cloudth_vert==1) THEN
     87       CALL cloudth_vert(ngrid,klev,ind2,  &
     88     &           ztv,po,zqta,fraca, &
     89     &           qcloud,ctot,zpspsk,paprs,ztla,zthl, &
     90     &           ratqs,zqs,t)
     91       RETURN
     92       ENDIF
     93!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     94
     95
     96
     97!-------------------------------------------------------------------------------
    7698! Initialisation des variables r?elles
    77 !-----------------------------------------------------------------------------------------------------------------
     99!-------------------------------------------------------------------------------
    78100      sigma1(:,:)=0.
    79101      sigma2(:,:)=0.
    … …  
    96118
    97119
    98 !------------------------------------------------------------------------------------------------------------------
     120!-------------------------------------------------------------------------------
    99121! Calcul de la fraction du thermique et des ?cart-types des distributions
    100 !------------------------------------------------------------------------------------------------------------------                 
     122!-------------------------------------------------------------------------------                 
    101123      do ind1=1,ngrid
    102124
    … …  
    139161     
    140162
    141 !-----------------------------------------------------------------------------------------------------------------
     163!------------------------------------------------------------------------------
    142164! Calcul des ?cart-types pour s
    143 !-----------------------------------------------------------------------------------------------------------------
     165!------------------------------------------------------------------------------
    144166
    145167!      sigma1s=(1.1**0.5)*(fraca(ind1,ind2)**0.6)/(1-fraca(ind1,ind2))*((sth-senv)**2)**0.5+ratqs(ind1,ind2)*po(ind1)
    … …  
    155177!      sigma2s=0.11*((sth-senv)**2)**0.5/(fraca(ind1,ind2)+0.02)**0.4+0.00003 
    156178 
    157 !-----------------------------------------------------------------------------------------------------------------
     179!------------------------------------------------------------------------------
    158180! Calcul de l'eau condens?e et de la couverture nuageuse
    159 !-----------------------------------------------------------------------------------------------------------------
     181!------------------------------------------------------------------------------
    160182      sqrt2pi=sqrt(2.*pi)
    161183      xth=sth/(sqrt(2.)*sigma2s)
    … …  
    176198!      print*,senv,sth,sigma1s,sigma2s,fraca(ind1,ind2),'senv et sth et sig1 et sig2 et alpha'
    177199
    178 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     200!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    179201      if (ctot(ind1,ind2).lt.1.e-10) then
    180202      ctot(ind1,ind2)=0.
    … …  
    242264
    243265
    244 
    245 
    246                                                                            
    247 
    248 
    249 
    250 
     266!===========================================================================
     267     SUBROUTINE cloudth_vert(ngrid,klev,ind2,  &
     268     &           ztv,po,zqta,fraca, &
     269     &           qcloud,ctot,zpspsk,paprs,ztla,zthl, &
     270     &           ratqs,zqs,t)
     271
     272
     273      IMPLICIT NONE
     274
     275
     276!===========================================================================
     277! Auteur : Arnaud Octavio Jam (LMD/CNRS)
     278! Date : 25 Mai 2010
     279! Objet : calcule les valeurs de qc et rneb dans les thermiques
     280!===========================================================================
     281
     282
     283#include "YOMCST.h"
     284#include "YOETHF.h"
     285#include "FCTTRE.h"
     286#include "iniprint.h"
     287#include "thermcell.h"
     288
     289      INTEGER itap,ind1,ind2
     290      INTEGER ngrid,klev,klon,l,ig
     291     
     292      REAL ztv(ngrid,klev)
     293      REAL po(ngrid)
     294      REAL zqenv(ngrid)   
     295      REAL zqta(ngrid,klev)
     296         
     297      REAL fraca(ngrid,klev+1)
     298      REAL zpspsk(ngrid,klev)
     299      REAL paprs(ngrid,klev+1)
     300      REAL ztla(ngrid,klev)
     301      REAL zthl(ngrid,klev)
     302
     303      REAL zqsatth(ngrid,klev)
     304      REAL zqsatenv(ngrid,klev)
     305     
     306     
     307      REAL sigma1(ngrid,klev)                                                         
     308      REAL sigma2(ngrid,klev)
     309      REAL qlth(ngrid,klev)
     310      REAL qlenv(ngrid,klev)
     311      REAL qltot(ngrid,klev)
     312      REAL cth(ngrid,klev) 
     313      REAL cenv(ngrid,klev)   
     314      REAL ctot(ngrid,klev)
     315      REAL rneb(ngrid,klev)
     316      REAL t(ngrid,klev)                                                                 
     317      REAL qsatmmussig1,qsatmmussig2,sqrt2pi,pi
     318      REAL rdd,cppd,Lv,sqrt2,sqrtpi
     319      REAL alth,alenv,ath,aenv
     320      REAL sth,senv,sigma1s,sigma2s,xth,xenv
     321      REAL xth1,xth2,xenv1,xenv2,deltasth, deltasenv
     322      REAL IntJ,IntI1,IntI2,IntI3,coeffqlenv,coeffqlth
     323      REAL Tbef,zdelta,qsatbef,zcor
     324      REAL alpha,qlbef 
     325      REAL ratqs(ngrid,klev) ! determine la largeur de distribution de vapeur
     326     
     327      REAL zpdf_sig(ngrid),zpdf_k(ngrid),zpdf_delta(ngrid)
     328      REAL zpdf_a(ngrid),zpdf_b(ngrid),zpdf_e1(ngrid),zpdf_e2(ngrid)
     329      REAL zqs(ngrid), qcloud(ngrid)
     330      REAL erf
     331
     332
     333
     334
     335
     336!------------------------------------------------------------------------------
     337! Initialisation des variables r?elles
     338!------------------------------------------------------------------------------
     339      sigma1(:,:)=0.
     340      sigma2(:,:)=0.
     341      qlth(:,:)=0.
     342      qlenv(:,:)=0. 
     343      qltot(:,:)=0.
     344      rneb(:,:)=0.
     345      qcloud(:)=0.
     346      cth(:,:)=0.
     347      cenv(:,:)=0.
     348      ctot(:,:)=0.
     349      qsatmmussig1=0.
     350      qsatmmussig2=0.
     351      rdd=287.04
     352      cppd=1005.7
     353      pi=3.14159
     354      Lv=2.5e6
     355      sqrt2pi=sqrt(2.*pi)
     356      sqrt2=sqrt(2.)
     357      sqrtpi=sqrt(pi)
     358
     359
     360
     361!-------------------------------------------------------------------------------
     362! Calcul de la fraction du thermique et des ?cart-types des distributions
     363!-------------------------------------------------------------------------------                 
     364      do ind1=1,ngrid
     365
     366      if ((ztv(ind1,1).gt.ztv(ind1,2)).and.(fraca(ind1,ind2).gt.1.e-10)) then
     367
     368      zqenv(ind1)=(po(ind1)-fraca(ind1,ind2)*zqta(ind1,ind2))/(1.-fraca(ind1,ind2))
     369
     370
     371!      zqenv(ind1)=po(ind1)
     372      Tbef=zthl(ind1,ind2)*zpspsk(ind1,ind2)
     373      zdelta=MAX(0.,SIGN(1.,RTT-Tbef))
     374      qsatbef= R2ES * FOEEW(Tbef,zdelta)/paprs(ind1,ind2)
     375      qsatbef=MIN(0.5,qsatbef)
     376      zcor=1./(1.-retv*qsatbef)
     377      qsatbef=qsatbef*zcor
     378      zqsatenv(ind1,ind2)=qsatbef
     379
     380
     381
     382
     383      alenv=(0.622*Lv*zqsatenv(ind1,ind2))/(rdd*zthl(ind1,ind2)**2) 
     384      aenv=1./(1.+(alenv*Lv/cppd))
     385      senv=aenv*(po(ind1)-zqsatenv(ind1,ind2))
     386
     387
     388
     389
     390      Tbef=ztla(ind1,ind2)*zpspsk(ind1,ind2)
     391      zdelta=MAX(0.,SIGN(1.,RTT-Tbef))
     392      qsatbef= R2ES * FOEEW(Tbef,zdelta)/paprs(ind1,ind2)
     393      qsatbef=MIN(0.5,qsatbef)
     394      zcor=1./(1.-retv*qsatbef)
     395      qsatbef=qsatbef*zcor
     396      zqsatth(ind1,ind2)=qsatbef
     397           
     398      alth=(0.622*Lv*zqsatth(ind1,ind2))/(rdd*ztla(ind1,ind2)**2)   
     399      ath=1./(1.+(alth*Lv/cppd))
     400      sth=ath*(zqta(ind1,ind2)-zqsatth(ind1,ind2))
     401     
     402     
     403
     404!------------------------------------------------------------------------------
     405! Calcul des ?cart-types pour s
     406!------------------------------------------------------------------------------
     407
     408      sigma1s=(0.92**0.5)*(fraca(ind1,ind2)**0.5)/(1-fraca(ind1,ind2))*((sth-senv)**2)**0.5+ratqs(ind1,ind2)*po(ind1)
     409      sigma2s=0.09*((sth-senv)**2)**0.5/(fraca(ind1,ind2)+0.02)**0.5+0.002*zqta(ind1,ind2)
     410!       if (paprs(ind1,ind2).gt.90000) then
     411!       ratqs(ind1,ind2)=0.002
     412!       else
     413!       ratqs(ind1,ind2)=0.002+0.0*(90000-paprs(ind1,ind2))/20000
     414!       endif
     415!       sigma1s=(1.1**0.5)*(fraca(ind1,ind2)**0.6)/(1-fraca(ind1,ind2))*((sth-senv)**2)**0.5+0.002*po(ind1)
     416!       sigma2s=0.11*((sth-senv)**2)**0.5/(fraca(ind1,ind2)+0.01)**0.4+0.002*zqta(ind1,ind2)
     417!       sigma1s=ratqs(ind1,ind2)*po(ind1)
     418!      sigma2s=0.11*((sth-senv)**2)**0.5/(fraca(ind1,ind2)+0.02)**0.4+0.00003 
     419 
     420!------------------------------------------------------------------------------
     421! Calcul de l'eau condens?e et de la couverture nuageuse
     422!------------------------------------------------------------------------------
     423      sqrt2pi=sqrt(2.*pi)
     424      xth=sth/(sqrt(2.)*sigma2s)
     425      xenv=senv/(sqrt(2.)*sigma1s)
     426      cth(ind1,ind2)=0.5*(1.+1.*erf(xth))
     427      cenv(ind1,ind2)=0.5*(1.+1.*erf(xenv))
     428      ctot(ind1,ind2)=fraca(ind1,ind2)*cth(ind1,ind2)+(1.-1.*fraca(ind1,ind2))*cenv(ind1,ind2)   
     429!      ctot(ind1,ind2)=alpha*cth(ind1,ind2)+(1.-1.*alpha)*cenv(ind1,ind2)
     430
     431
     432
     433      qlth(ind1,ind2)=sigma2s*((exp(-1.*xth**2)/sqrt2pi)+xth*sqrt(2.)*cth(ind1,ind2))
     434      qlenv(ind1,ind2)=sigma1s*((exp(-1.*xenv**2)/sqrt2pi)+xenv*sqrt(2.)*cenv(ind1,ind2))   
     435      qltot(ind1,ind2)=fraca(ind1,ind2)*qlth(ind1,ind2)+(1.-1.*fraca(ind1,ind2))*qlenv(ind1,ind2)
     436!      qltot(ind1,ind2)=alpha*qlth(ind1,ind2)+(1.-1.*alpha)*qlenv(ind1,ind2)
     437     
     438
     439!      print*,senv,sth,sigma1s,sigma2s,fraca(ind1,ind2),'senv et sth et sig1 et sig2 et alpha'
     440
     441
     442!-------------------------------------------------------------------------------
     443!  Version 2: Modification selon J.-Louis. On condense ?? partir de qsat-ratqs
     444!-------------------------------------------------------------------------------
     445!      deltasenv=aenv*ratqs(ind1,ind2)*po(ind1)
     446!      deltasth=ath*ratqs(ind1,ind2)*zqta(ind1,ind2)
     447      deltasenv=aenv*ratqs(ind1,ind2)*zqsatenv(ind1,ind2)
     448      deltasth=ath*ratqs(ind1,ind2)*zqsatth(ind1,ind2)
     449!      deltasenv=aenv*0.01*po(ind1)
     450!     deltasth=ath*0.01*zqta(ind1,ind2)   
     451      xenv1=(senv-deltasenv)/(sqrt(2.)*sigma1s)
     452      xenv2=(senv+deltasenv)/(sqrt(2.)*sigma1s)
     453      xth1=(sth-deltasth)/(sqrt(2.)*sigma2s)
     454      xth2=(sth+deltasth)/(sqrt(2.)*sigma2s)
     455      coeffqlenv=(sigma1s)**2/(2*sqrtpi*deltasenv)
     456      coeffqlth=(sigma2s)**2/(2*sqrtpi*deltasth)
     457     
     458      cth(ind1,ind2)=0.5*(1.+1.*erf(xth2))
     459      cenv(ind1,ind2)=0.5*(1.+1.*erf(xenv2))
     460      ctot(ind1,ind2)=fraca(ind1,ind2)*cth(ind1,ind2)+(1.-1.*fraca(ind1,ind2))*cenv(ind1,ind2)   
     461
     462      IntJ=sigma1s*(exp(-1.*xenv1**2)/sqrt2pi)+0.5*senv*(1+erf(xenv1))
     463      IntI1=coeffqlenv*0.5*(0.5*sqrtpi*(erf(xenv2)-erf(xenv1))+xenv1*exp(-1.*xenv1**2)-xenv2*exp(-1.*xenv2**2))
     464      IntI2=coeffqlenv*xenv2*(exp(-1.*xenv2**2)-exp(-1.*xenv1**2))
     465      IntI3=coeffqlenv*0.5*sqrtpi*xenv2**2*(erf(xenv2)-erf(xenv1))
     466
     467      qlenv(ind1,ind2)=IntJ+IntI1+IntI2+IntI3
     468!      qlenv(ind1,ind2)=IntJ
     469!      print*, qlenv(ind1,ind2),'VERIF EAU'
     470
     471
     472      IntJ=sigma2s*(exp(-1.*xth1**2)/sqrt2pi)+0.5*sth*(1+erf(xth1))
     473!      IntI1=coeffqlth*((0.5*xth1-xth2)*exp(-1.*xth1**2)+0.5*xth2*exp(-1.*xth2**2))
     474!      IntI2=coeffqlth*0.5*sqrtpi*(0.5+xth2**2)*(erf(xth2)-erf(xth1))
     475      IntI1=coeffqlth*0.5*(0.5*sqrtpi*(erf(xth2)-erf(xth1))+xth1*exp(-1.*xth1**2)-xth2*exp(-1.*xth2**2))
     476      IntI2=coeffqlth*xth2*(exp(-1.*xth2**2)-exp(-1.*xth1**2))
     477      IntI3=coeffqlth*0.5*sqrtpi*xth2**2*(erf(xth2)-erf(xth1))
     478      qlth(ind1,ind2)=IntJ+IntI1+IntI2+IntI3
     479!      qlth(ind1,ind2)=IntJ
     480!      print*, IntJ,IntI1,IntI2,IntI3,qlth(ind1,ind2),'VERIF EAU2'
     481      qltot(ind1,ind2)=fraca(ind1,ind2)*qlth(ind1,ind2)+(1.-1.*fraca(ind1,ind2))*qlenv(ind1,ind2)
     482
     483!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     484      if (cenv(ind1,ind2).lt.1.e-10.or.cth(ind1,ind2).lt.1.e-10) then
     485      ctot(ind1,ind2)=0.
     486      qcloud(ind1)=zqsatenv(ind1,ind2)
     487
     488      else
     489               
     490      ctot(ind1,ind2)=ctot(ind1,ind2)
     491      qcloud(ind1)=qltot(ind1,ind2)/ctot(ind1,ind2)+zqs(ind1)
     492!      qcloud(ind1)=fraca(ind1,ind2)*qlth(ind1,ind2)/cth(ind1,ind2) &
     493!    &             +(1.-1.*fraca(ind1,ind2))*qlenv(ind1,ind2)/cenv(ind1,ind2)+zqs(ind1)
     494
     495      endif 
     496                       
     497     
     498         
     499!     print*,sth,sigma2s,qlth(ind1,ind2),ctot(ind1,ind2),qltot(ind1,ind2),'verif'
     500
     501
     502      else  ! gaussienne environnement seule
     503     
     504      zqenv(ind1)=po(ind1)
     505      Tbef=t(ind1,ind2)
     506      zdelta=MAX(0.,SIGN(1.,RTT-Tbef))
     507      qsatbef= R2ES * FOEEW(Tbef,zdelta)/paprs(ind1,ind2)
     508      qsatbef=MIN(0.5,qsatbef)
     509      zcor=1./(1.-retv*qsatbef)
     510      qsatbef=qsatbef*zcor
     511      zqsatenv(ind1,ind2)=qsatbef
     512     
     513
     514!      qlbef=Max(po(ind1)-zqsatenv(ind1,ind2),0.)
     515      zthl(ind1,ind2)=t(ind1,ind2)*(101325/paprs(ind1,ind2))**(rdd/cppd)
     516      alenv=(0.622*Lv*zqsatenv(ind1,ind2))/(rdd*zthl(ind1,ind2)**2) 
     517      aenv=1./(1.+(alenv*Lv/cppd))
     518      senv=aenv*(po(ind1)-zqsatenv(ind1,ind2))
     519     
     520
     521      sigma1s=ratqs(ind1,ind2)*zqenv(ind1)
     522
     523      sqrt2pi=sqrt(2.*pi)
     524      xenv=senv/(sqrt(2.)*sigma1s)
     525      ctot(ind1,ind2)=0.5*(1.+1.*erf(xenv))
     526      qltot(ind1,ind2)=sigma1s*((exp(-1.*xenv**2)/sqrt2pi)+xenv*sqrt(2.)*cenv(ind1,ind2))
     527     
     528      if (ctot(ind1,ind2).lt.1.e-3) then
     529      ctot(ind1,ind2)=0.
     530      qcloud(ind1)=zqsatenv(ind1,ind2)
     531
     532      else   
     533               
     534      ctot(ind1,ind2)=ctot(ind1,ind2)
     535      qcloud(ind1)=qltot(ind1,ind2)/ctot(ind1,ind2)+zqsatenv(ind1,ind2)
     536
     537      endif   
     538 
     539 
     540 
     541 
     542 
     543 
     544      endif   
     545      enddo
     546     
     547      return
     548      end

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

    r1999 r2298  
    1313!
    1414  SUBROUTINE coef_diff_turb(dtime, nsrf, knon, ni, &
    15        ypaprs, ypplay, yu, yv, yq, yt, yts, yrugos, yqsurf, ycdragm, &
     15       ypaprs, ypplay, yu, yv, yq, yt, yts, yqsurf, ycdragm, &
    1616       ycoefm, ycoefh ,yq2)
    1717 
    … …  
    3434    REAL, DIMENSION(klon,klev), INTENT(IN)     :: yu, yv
    3535    REAL, DIMENSION(klon,klev), INTENT(IN)     :: yq, yt
    36     REAL, DIMENSION(klon), INTENT(IN)          :: yts, yrugos, yqsurf
     36    REAL, DIMENSION(klon), INTENT(IN)          :: yts, yqsurf
    3737    REAL, DIMENSION(klon), INTENT(IN)          :: ycdragm
    3838
    … …  
    7070    CALL coefkz(nsrf, knon, ypaprs, ypplay, &
    7171         ksta, ksta_ter, &
    72          yts, yrugos, yu, yv, yt, yq, &
     72         yts, yu, yv, yt, yq, &
    7373         yqsurf, &
    7474         ycoefm, ycoefh)
    … …  
    181181  SUBROUTINE coefkz(nsrf, knon, paprs, pplay, &
    182182       ksta, ksta_ter, &
    183        ts, rugos, &
     183       ts, &
    184184       u,v,t,q, &
    185185       qsurf, &
    … …  
    200200! pplay----input-R- pression au milieu de chaque couche (en Pa)
    201201! ts-------input-R- temperature du sol (en Kelvin)
    202 ! rugos----input-R- longeur de rugosite (en m)
    203202! u--------input-R- vitesse u
    204203! v--------input-R- vitesse v
    … …  
    223222    REAL, DIMENSION(klon,klev), INTENT(IN)   :: pplay
    224223    REAL, DIMENSION(klon,klev), INTENT(IN)   :: u, v, t, q
    225     REAL, DIMENSION(klon), INTENT(IN)        :: rugos
    226224    REAL, DIMENSION(klon), INTENT(IN)        :: qsurf
    227225

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

    r2220 r2298  
    99      real :: tsurf
    1010      real :: rugos
    11       real :: qsol(1:2)
     11      real :: xqsol(1:2)
    1212      real :: qsurf
    1313      real :: psurf
    … …  
    3232      common/com_par1d/                                                 &
    3333     & nat_surf,tsurf,rugos,                                            &
    34      & qsol,qsurf,psurf,zsurf,albedo,time,time_ini,xlat,xlon,airefi,    &
     34     & xqsol,qsurf,psurf,zsurf,albedo,time,time_ini,xlat,xlon,airefi,   &
    3535     & wtsurf,wqsurf,restart_runoff,xagesno,qsolinp,zpicinp,            &
    3636     & forcing_type,tend_u,tend_v,tend_w,tend_t,tend_q,tend_rayo,       &

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

    r2220 r2298  
    11SUBROUTINE concvl(iflag_clos, &
    2                   dtime, paprs, pplay, &
     2                  dtime, paprs, pplay, k_upper_cv, &
    33                  t, q, t_wake, q_wake, s_wake, u, v, tra, ntra, &
    44                  Ale, Alp, sig1, w01, &
    … …  
    8888
    8989  REAL dtime, paprs(klon, klev+1), pplay(klon, klev)
     90  INTEGER k_upper_cv
    9091  REAL t(klon, klev), q(klon, klev), u(klon, klev), v(klon, klev)
    9192  REAL t_wake(klon, klev), q_wake(klon, klev)
    … …  
    214215  include "FCTTRE.h"
    215216  include "iniprint.h"
     217!jyg<
     218  include "conema3.h"
     219!>jyg
    216220
    217221  IF (first) THEN
    … …  
    307311
    308312  em_sig1feed = 1.
    309   em_sig2feed = 0.97
     313!jyg<
     314!  em_sig2feed = 0.97
     315  em_sig2feed = cvl_sig2feed
     316!>jyg
    310317! em_sig2feed = 0.8
    311318! Relative Weight densities
    … …  
    399406!LF   necessary for gathered fields
    400407    nloc = klon
    401     CALL cva_driver(klon, klev, klev+1, ntra, nloc, &
     408    CALL cva_driver(klon, klev, klev+1, ntra, nloc, k_upper_cv, &
    402409                    iflag_con, iflag_mix, iflag_ice_thermo, &
    403                     iflag_clos, ok_conserv_q, dtime, &
     410                    iflag_clos, ok_conserv_q, dtime, cvl_comp_threshold, &
    404411                    t, q, qs, t_wake, q_wake, qs_wake, s_wake, u, v, tra, &
    405412                    em_p, em_ph, &

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

    r1910 r2298  
    44!
    55      real epmax             ! 0.993
     6!jyg<
     7      REAL  cvl_comp_threshold     ! 0.
     8!>jyg
    69      logical ok_adj_ema      ! F
    710      integer iflag_clw      ! 0
    811      integer iflag_cvl_sigd
    9       real sig1feed      ! 1.
    10       real sig2feed      ! 0.95
     12      real cvl_sig2feed      ! 0.97
    1113
    12       common/comconema1/epmax,ok_adj_ema,iflag_clw,sig1feed,sig2feed
    13       common/comconema2/iflag_cvl_sigd
     14!jyg<
     15!!      common/comconema1/epmax,ok_adj_ema,iflag_clw,sig1feed,sig2feed
     16!!      common/comconema2/iflag_cvl_sigd
     17      common/comconema1/epmax, cvl_comp_threshold, cvl_sig2feed
     18      common/comconema2/iflag_cvl_sigd, iflag_clw, ok_adj_ema
     19!>jyg
    1420
    1521!      common/comconema/epmax,ok_adj_ema,iflag_clw
    1622!$OMP THREADPRIVATE(/comconema1/)
    1723!$OMP THREADPRIVATE(/comconema2/)
     24

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

    r2258 r2298  
    4040    include "thermcell.h"
    4141    include "iniprint.h"
     42
    4243
    4344    !IM : on inclut/initialise les taux de CH4, N2O, CFC11 et CFC12
    … …  
    117118
    118119    Real,SAVE           :: f_cdrag_ter_omp,f_cdrag_oce_omp
    119     Real,SAVE           :: f_rugoro_omp   
     120    Real,SAVE           :: f_rugoro_omp   , z0min_omp
     121    Real,SAVE           :: z0m_seaice_omp,z0h_seaice_omp
     122    REAL,SAVE           :: min_wind_speed_omp,f_gust_wk_omp,f_gust_bl_omp,f_qsat_oce_omp, f_z0qh_oce_omp
     123    INTEGER,SAVE        :: iflag_gusts_omp,iflag_z0_oce_omp
    120124
    121125    ! Local
    … …  
    142146    INTEGER, SAVE :: iflag_mix_omp
    143147    real, save :: scut_omp, qqa1_omp, qqa2_omp, gammas_omp, Fmax_omp, alphas_omp
     148    REAL, SAVE :: tmax_fonte_cv_omp
    144149
    145150    REAL,SAVE :: R_ecc_omp,R_peri_omp,R_incl_omp,solaire_omp
    … …  
    188193    REAL,SAVE :: ecrit_LES_omp
    189194    REAL,SAVE :: ecrit_tra_omp
     195    REAL,SAVE :: cvl_comp_threshold_omp
     196    REAL,SAVE :: cvl_sig2feed_omp
    190197    REAL,SAVE :: cvl_corr_omp
    191198    LOGICAL,SAVE :: ok_lic_melt_omp
    … …  
    213220    !-----------------------------------------------------------------
    214221
     222     print*,'CONFPHYS ENTREE'
    215223    !$OMP MASTER
    216224    !Config Key  = type_ocean
    … …  
    760768    ! KE
    761769    !
     770
     771    !Config key  = cvl_comp_threshold
     772    !Config Desc = maximum fraction of convective points enabling compression
     773    !Config Def  = 1.00
     774    !Config Help = fields are compressed when less than a fraction cvl_comp_threshold
     775    !Config Help = of the points is convective.
     776    cvl_comp_threshold_omp = 1.00
     777    CALL getin('cvl_comp_threshold', cvl_comp_threshold_omp)
     778
     779    !Config key  = cvl_sig2feed
     780    !Config Desc = sigma coordinate at top of feeding layer
     781    !Config Def  = 0.97
     782    !Config Help = deep convection is fed by the layer extending from the surface (pressure ps)
     783    !Config Help = and cvl_sig2feed*ps.
     784    cvl_sig2feed_omp = 0.97
     785    CALL getin('cvl_sig2feed', cvl_sig2feed_omp)
    762786
    763787    !Config key  = cvl_corr
    … …  
    16451669    !
    16461670    !
     1671    print*,'CONFPHYS OOK avant drag_ter'
    16471672    !
    16481673    ! PARAMETRES CDRAG
    1649     !
    1650     !Config Key  = f_cdrag_ter
    1651     !Config Desc =
    1652     !Config Def  = 0.8
    1653     !Config Help =
    16541674    !
    16551675    f_cdrag_ter_omp = 0.8
    16561676    call getin('f_cdrag_ter',f_cdrag_ter_omp)
    16571677    !
    1658     !Config Key  = f_cdrag_oce
    1659     !Config Desc =
    1660     !Config Def  = 0.8
    1661     !Config Help =
    1662     !
    16631678    f_cdrag_oce_omp = 0.8
    16641679    call getin('f_cdrag_oce',f_cdrag_oce_omp)
    16651680    !
    1666     ! RUGORO
    1667     !Config Key  = f_rugoro
    1668     !Config Desc =
    1669     !Config Def  = 0.
    1670     !Config Help =
    1671     !
     1681
     1682! Gustiness flags
     1683    f_z0qh_oce_omp = 1.
     1684    call getin('f_z0qh_oce',f_z0qh_oce_omp)
     1685    !
     1686    f_qsat_oce_omp = 1.
     1687    call getin('f_qsat_oce',f_qsat_oce_omp)
     1688    !
     1689    f_gust_bl_omp = 0.
     1690    call getin('f_gust_bl',f_gust_bl_omp)
     1691    !
     1692    f_gust_wk_omp = 0.
     1693    call getin('f_gust_wk',f_gust_wk_omp)
     1694    !
     1695    iflag_z0_oce_omp=0
     1696    call getin('iflag_z0_oce',iflag_z0_oce_omp)
     1697    !
     1698    iflag_gusts_omp=0
     1699    call getin('iflag_gusts',iflag_gusts_omp)
     1700    !
     1701    min_wind_speed_omp = 1.
     1702    call getin('min_wind_speed',min_wind_speed_omp)
     1703
     1704    z0m_seaice_omp = 0.002 ; call getin('z0m_seaice',z0m_seaice_omp)
     1705    z0h_seaice_omp = 0.002 ; call getin('z0h_seaice',z0h_seaice_omp)
     1706
    16721707    f_rugoro_omp = 0.
    16731708    call getin('f_rugoro',f_rugoro_omp)
     1709
     1710    z0min_omp = 0.000015
     1711    call getin('z0min',z0min_omp)
     1712
    16741713
    16751714    ! PARAMETERS FOR CONVECTIVE INHIBITION BY TROPOS. DRYNESS
    … …  
    17511790    Fmax_omp = 0.65
    17521791    call getin('Fmax',Fmax_omp)
     1792
     1793    !
     1794    !Config Key  = tmax_fonte_cv
     1795    !Config Desc =
     1796    !Config Def  = 275.15
     1797    !Config Help =
     1798    !
     1799    tmax_fonte_cv_omp = 275.15
     1800    call getin('tmax_fonte_cv',tmax_fonte_cv_omp)
    17531801
    17541802    !
    … …  
    20182066    ecrit_tra = ecrit_tra_omp
    20192067    ecrit_reg = ecrit_reg_omp
     2068    cvl_comp_threshold = cvl_comp_threshold_omp
     2069    cvl_sig2feed = cvl_sig2feed_omp
    20202070    cvl_corr = cvl_corr_omp
    20212071    ok_lic_melt = ok_lic_melt_omp
    20222072    f_cdrag_ter=f_cdrag_ter_omp
    20232073    f_cdrag_oce=f_cdrag_oce_omp
     2074
     2075    f_gust_wk=f_gust_wk_omp
     2076    f_gust_bl=f_gust_bl_omp
     2077    f_qsat_oce=f_qsat_oce_omp
     2078    f_z0qh_oce=f_z0qh_oce_omp
     2079    min_wind_speed=min_wind_speed_omp
     2080    iflag_gusts=iflag_gusts_omp
     2081    iflag_z0_oce=iflag_z0_oce_omp
     2082
     2083
     2084    z0m_seaice=z0m_seaice_omp
     2085    z0h_seaice=z0h_seaice_omp
     2086
    20242087    f_rugoro=f_rugoro_omp
     2088
     2089    z0min=z0min_omp
    20252090    supcrit1 = supcrit1_omp
    20262091    supcrit2 = supcrit2_omp
    … …  
    20312096    gammas = gammas_omp
    20322097    Fmax = Fmax_omp
     2098    tmax_fonte_cv = tmax_fonte_cv_omp
    20332099    alphas = alphas_omp
    20342100    ok_strato = ok_strato_omp
    … …  
    21052171    write(lunout,*)' RN2O_per = ',RN2O_per,' RCFC11_per = ', RCFC11_per
    21062172    write(lunout,*)' RCFC12_per = ',RCFC12_per
     2173    write(lunout,*)' cvl_comp_threshold=', cvl_comp_threshold
     2174    write(lunout,*)' cvl_sig2feed=', cvl_sig2feed
    21072175    write(lunout,*)' cvl_corr=', cvl_corr
    21082176    write(lunout,*)'ok_lic_melt=', ok_lic_melt
    … …  
    22102278    write(lunout,*)' f_cdrag_oce = ',f_cdrag_oce
    22112279    write(lunout,*)' f_rugoro = ',f_rugoro
     2280    write(lunout,*)' z0min = ',z0min
    22122281    write(lunout,*)' supcrit1 = ', supcrit1
    22132282    write(lunout,*)' supcrit2 = ', supcrit2
    … …  
    22182287    write(lunout,*)' gammas = ', gammas
    22192288    write(lunout,*)' Fmax = ', Fmax
     2289    write(lunout,*)' tmax_fonte_cv = ', tmax_fonte_cv
    22202290    write(lunout,*)' alphas = ', alphas
    22212291    write(lunout,*)' iflag_wake = ', iflag_wake

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

    r2220 r2298  
    55
    66
    7 SUBROUTINE cv3_param(nd, delt)
     7SUBROUTINE cv3_param(nd, k_upper, delt)
    88
    99  use mod_phys_lmdz_para
    … …  
    3636  include "conema3.h"
    3737
    38   INTEGER nd
    39   REAL delt ! timestep (seconds)
     38  INTEGER, INTENT(IN)              :: nd
     39  INTEGER, INTENT(IN)              :: k_upper
     40  REAL, INTENT(IN)                 :: delt ! timestep (seconds)
    4041
    4142
    … …  
    5152! -- limit levels for convection:
    5253
    53   noff = 1
     54!jyg<
     55!  noff is chosen such that nl = k_upper so that upmost loops end at about 22 km
     56!
     57  noff = min(max(nd-k_upper, 1), (nd+1)/2)
     58!!  noff = 1
     59!>jyg
    5460  minorig = 1
    5561  nl = nd - noff
    … …  
    264270
    265271!inputs:
    266   INTEGER len, nd
    267   LOGICAL ok_conserv_q
    268   REAL t(len, nd), q(len, nd), p(len, nd)
    269   REAL u(len, nd), v(len, nd)
    270   REAL hm(len, nd), gz(len, nd)
    271   REAL ph(len, nd+1)
    272   REAL p1feed(len)
    273 ! ,  wght(len)
    274   REAL wght(nd)
     272  INTEGER, INTENT (IN)                               :: len, nd
     273  LOGICAL, INTENT (IN)                               :: ok_conserv_q
     274  REAL, DIMENSION (len, nd), INTENT (IN)             :: t, q, p
     275  REAL, DIMENSION (len, nd), INTENT (IN)             :: u, v
     276  REAL, DIMENSION (len, nd), INTENT (IN)             :: hm, gz
     277  REAL, DIMENSION (len, nd+1), INTENT (IN)           :: ph
     278  REAL, DIMENSION (len), INTENT (IN)                 :: p1feed
     279  REAL, DIMENSION (nd), INTENT (IN)                  :: wght
    275280!input-output
    276   REAL p2feed(len)
     281  REAL, DIMENSION (len), INTENT (INOUT)              :: p2feed
    277282!outputs:
    278   INTEGER iflag(len), nk(len), icb(len), icbmax
    279 !   real   wghti(len)
    280   REAL wghti(len, nd)
    281   REAL tnk(len), thnk(len), qnk(len), qsnk(len)
    282   REAL unk(len), vnk(len)
    283   REAL cpnk(len), hnk(len), gznk(len)
    284   REAL plcl(len)
     283  INTEGER, INTENT (OUT)                              :: icbmax
     284  INTEGER, DIMENSION (len), INTENT (OUT)             :: iflag, nk, icb
     285  REAL, DIMENSION (len, nd), INTENT (OUT)            :: wghti
     286  REAL, DIMENSION (len), INTENT (OUT)                :: tnk, thnk, qnk, qsnk
     287  REAL, DIMENSION (len), INTENT (OUT)                :: unk, vnk
     288  REAL, DIMENSION (len), INTENT (OUT)                :: cpnk, hnk, gznk
     289  REAL, DIMENSION (len), INTENT (OUT)                :: plcl
    285290
    286291!local variables:
    … …  
    514519
    515520! inputs:
    516   INTEGER len, nd
    517   INTEGER icb(len)
    518   REAL t(len, nd), qs(len, nd), gz(len, nd)
    519   REAL tnk(len), qnk(len), gznk(len)
    520   REAL p(len, nd)
    521   REAL plcl(len) ! convect3
     521  INTEGER, INTENT (IN)                              :: len, nd
     522  INTEGER, DIMENSION (len), INTENT (IN)             :: icb
     523  REAL, DIMENSION (len, nd), INTENT (IN)            :: t, qs, gz
     524  REAL, DIMENSION (len), INTENT (IN)                :: tnk, qnk, gznk
     525  REAL, DIMENSION (len, nd), INTENT (IN)            :: p
     526  REAL, DIMENSION (len), INTENT (IN)                :: plcl              ! convect3
    522527
    523528! outputs:
    524   REAL tp(len, nd), tvp(len, nd), clw(len, nd)
     529  INTEGER, DIMENSION (len), INTENT (OUT)            :: icbs
     530  REAL, DIMENSION (len, nd), INTENT (OUT)           :: tp, tvp, clw
    525531
    526532! local variables:
    527533  INTEGER i, k
    528   INTEGER icb1(len), icbs(len), icbsmax2 ! convect3
     534  INTEGER icb1(len), icbsmax2                                            ! convect3
    529535  REAL tg, qg, alv, s, ahg, tc, denom, es, rg
    530536  REAL ah0(len), cpp(len)
    531537  REAL ticb(len), gzicb(len)
    532   REAL qsicb(len) ! convect3
    533   REAL cpinv(len) ! convect3
     538  REAL qsicb(len)                                                        ! convect3
     539  REAL cpinv(len)                                                        ! convect3
    534540
    535541! -------------------------------------------------------------------
    … …  
    10511057
    10521058!inputs:
    1053   INTEGER ncum, nd, nloc, j
    1054   INTEGER icb(nloc), icbs(nloc), nk(nloc)
    1055   REAL t(nloc, nd), q(nloc, nd), qs(nloc, nd), gz(nloc, nd)
    1056   REAL p(nloc, nd)
    1057   REAL tnk(nloc), qnk(nloc), gznk(nloc)
    1058   REAL hnk(nloc)
    1059   REAL lv(nloc, nd), lf(nloc, nd), tv(nloc, nd), h(nloc, nd)
    1060   REAL pbase(nloc), buoybase(nloc), plcl(nloc)
     1059  INTEGER, INTENT (IN)                               :: ncum, nd, nloc
     1060  INTEGER, DIMENSION (nloc), INTENT (IN)             :: icb, icbs, nk
     1061  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: t, q, qs, gz
     1062  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: p
     1063  REAL, DIMENSION (nloc), INTENT (IN)                :: tnk, qnk, gznk
     1064  REAL, DIMENSION (nloc), INTENT (IN)                :: hnk
     1065  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: lv, lf, tv, h
     1066  REAL, DIMENSION (nloc), INTENT (IN)                :: pbase, buoybase, plcl
     1067
     1068!input/outputs:
     1069  REAL, DIMENSION (nloc, nd), INTENT (INOUT)         :: tp, tvp, clw   ! Input for k = 1, icb+1 (computed in cv3_undilute1)
     1070                                                                       ! Output above
    10611071
    10621072!outputs:
    1063   INTEGER inb(nloc)
    1064   REAL tp(nloc, nd), tvp(nloc, nd), clw(nloc, nd)
    1065   REAL ep(nloc, nd), sigp(nloc, nd), hp(nloc, nd)
    1066   REAL buoy(nloc, nd)
     1073  INTEGER, DIMENSION (nloc), INTENT (OUT)            :: inb
     1074  REAL, DIMENSION (nloc, nd), INTENT (OUT)           :: ep, sigp, hp
     1075  REAL, DIMENSION (nloc, nd), INTENT (OUT)           :: buoy
    10671076
    10681077!local variables:
    1069   INTEGER i, k
     1078  INTEGER i, j, k
    10701079  REAL tg, qg, ahg, alv, alf, s, tc, es, esi, denom, rg, tca, elacrit
    10711080  REAL als
    … …  
    10841093  DO k = 1, nl
    10851094    DO i = 1, ncum
    1086       ep(i, k) = 0.0
    1087       sigp(i, k) = spfac
    10881095      qi(i, k) = 0.
    10891096    END DO
    … …  
    11871194          END IF
    11881195        END IF
    1189       END IF
     1196!jyg<
     1197!!      END IF  ! Endif moved to the end of the loop
     1198!>jyg
    11901199
    11911200      IF (cvflag_ice) THEN
    … …  
    12581267        END IF
    12591268      END IF ! (cvflag_ice)
    1260 
     1269!jyg<
     1270      END IF ! (k>=(icbs(i)+1))
     1271!>jyg
    12611272    END DO
    12621273  END DO
    … …  
    12671278! --- THESE MAY BE FUNCTIONS OF TP(I), P(I) AND CLW(I)
    12681279! =====================================================================
    1269 
     1280!
     1281!jyg<
     1282  DO k = 1, nl
     1283    DO i = 1, ncum
     1284      ep(i, k) = 0.0
     1285      sigp(i, k) = spfac
     1286    END DO
     1287  END DO
     1288!>jyg
     1289!
    12701290  IF (flag_epkeorig/=1) THEN
    12711291    DO k = 1, nl ! convect3
    12721292      DO i = 1, ncum
    1273         pden = ptcrit - pbcrit
    1274         ep(i, k) = (plcl(i)-p(i,k)-pbcrit)/pden*epmax
    1275         ep(i, k) = max(ep(i,k), 0.0)
    1276         ep(i, k) = min(ep(i,k), epmax)
    1277         sigp(i, k) = spfac
     1293!jyg<
     1294       IF(k>=icb(i)) THEN
     1295!>jyg
     1296         pden = ptcrit - pbcrit
     1297         ep(i, k) = (plcl(i)-p(i,k)-pbcrit)/pden*epmax
     1298         ep(i, k) = max(ep(i,k), 0.0)
     1299         ep(i, k) = min(ep(i,k), epmax)
     1300!!         sigp(i, k) = spfac  ! jyg
     1301        ENDIF   ! (k>=icb(i))
    12781302      END DO
    12791303    END DO
    … …  
    12811305    DO k = 1, nl
    12821306      DO i = 1, ncum
    1283         IF (k>=(nk(i)+1)) THEN
     1307        IF(k>=icb(i)) THEN
     1308!!        IF (k>=(nk(i)+1)) THEN
     1309!>jyg
    12841310          tca = tp(i, k) - t0
    12851311          IF (tca>=0.0) THEN
    … …  
    12921318          ep(i, k) = max(ep(i,k), 0.0)
    12931319          ep(i, k) = min(ep(i,k), epmax)
    1294           sigp(i, k) = spfac
    1295         END IF
     1320!!          sigp(i, k) = spfac  ! jyg
     1321        END IF  ! (k>=icb(i))
    12961322      END DO
    12971323    END DO
    12981324  END IF
     1325!
    12991326! =====================================================================
    13001327! --- CALCULATE VIRTUAL TEMPERATURE AND LIFTED PARCEL
    … …  
    13311358! first estimate of buoyancy:
    13321359
    1333   DO i = 1, ncum
    1334     DO k = 1, nl
     1360!jyg : k-loop outside i-loop (07042015)
     1361  DO k = 1, nl
     1362    DO i = 1, ncum
    13351363      buoy(i, k) = tvp(i, k) - tv(i, k)
    13361364    END DO
    … …  
    13401368! for safety, set buoy(icb)=buoybase
    13411369
    1342   DO i = 1, ncum
    1343     DO k = 1, nl
     1370!jyg : k-loop outside i-loop (07042015)
     1371  DO k = 1, nl
     1372    DO i = 1, ncum
    13441373      IF ((k>=icb(i)) .AND. (k<=nl) .AND. (p(i,k)>=pbase(i))) THEN
    13451374        buoy(i, k) = buoybase(i)
    13461375      END IF
    13471376    END DO
     1377  END DO
     1378  DO i = 1, ncum
    13481379!    buoy(icb(i),k)=buoybase(i)
    13491380    buoy(i, icb(i)) = buoybase(i)
    … …  
    14901521  END DO
    14911522
    1492   DO k = minorig + 1, nl
    1493     DO i = 1, ncum
    1494       IF ((k>=icb(i)) .AND. (k<=inb(i))) THEN
    1495 
    1496         IF (cvflag_ice) THEN
     1523!jyg : cvflag_ice test outside the loops (07042015)
     1524!
     1525  IF (cvflag_ice) THEN
     1526!
     1527    DO k = minorig + 1, nl
     1528      DO i = 1, ncum
     1529        IF ((k>=icb(i)) .AND. (k<=inb(i))) THEN
    14971530          frac(i, k) = 1. - (t(i,k)-243.15)/(263.15-243.15)
    14981531          frac(i, k) = min(max(frac(i,k),0.0), 1.0)
    14991532          hp(i, k) = hnk(i) + (lv(i,k)+(cpd-cpv)*t(i,k)+frac(i,k)*lf(i,k))* &
    15001533                              ep(i, k)*clw(i, k)
    1501 
    1502         ELSE
     1534        END IF
     1535      END DO
     1536    END DO
     1537!
     1538  ELSE
     1539!
     1540    DO k = minorig + 1, nl
     1541      DO i = 1, ncum
     1542        IF ((k>=icb(i)) .AND. (k<=inb(i))) THEN
    15031543          hp(i, k) = hnk(i) + (lv(i,k)+(cpd-cpv)*t(i,k))*ep(i, k)*clw(i, k)
    15041544        END IF
    1505 
    1506       END IF
    1507     END DO
    1508   END DO
     1545      END DO
     1546    END DO
     1547!
     1548  END IF  ! (cvflag_ice)
    15091549
    15101550  RETURN
    … …  
    17681808
    17691809!inputs:
    1770   INTEGER ncum, nd, na, ntra, nloc
    1771   INTEGER icb(nloc), inb(nloc), nk(nloc)
    1772   REAL sig(nloc, nd)
    1773   REAL qnk(nloc), unk(nloc), vnk(nloc)
    1774   REAL ph(nloc, nd+1)
    1775   REAL t(nloc, nd), rr(nloc, nd), rs(nloc, nd)
    1776   REAL u(nloc, nd), v(nloc, nd)
    1777   REAL tra(nloc, nd, ntra) ! input of convect3
    1778   REAL lv(nloc, na), h(nloc, na), hp(nloc, na)
    1779   REAL lf(nloc, na), frac(nloc, na)
    1780   REAL tv(nloc, na), tvp(nloc, na), ep(nloc, na), clw(nloc, na)
    1781   REAL m(nloc, na) ! input of convect3
     1810  INTEGER, INTENT (IN)                               :: ncum, nd, na, ntra, nloc
     1811  INTEGER, DIMENSION (nloc), INTENT (IN)             :: icb, inb, nk
     1812  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: sig
     1813  REAL, DIMENSION (nloc), INTENT (IN)                :: qnk, unk, vnk
     1814  REAL, DIMENSION (nloc, nd+1), INTENT (IN)          :: ph
     1815  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: t, rr, rs
     1816  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: u, v
     1817  REAL, DIMENSION (nloc, nd, ntra), INTENT (IN)      :: tra              ! input of convect3
     1818  REAL, DIMENSION (nloc, na), INTENT (IN)            :: lv, h, hp
     1819  REAL, DIMENSION (nloc, na), INTENT (IN)            :: lf, frac
     1820  REAL, DIMENSION (nloc, na), INTENT (IN)            :: tv, tvp, ep, clw
     1821  REAL, DIMENSION (nloc, na), INTENT (IN)            :: m                ! input of convect3
    17821822
    17831823!outputs:
    1784   REAL ment(nloc, na, na), qent(nloc, na, na)
    1785   REAL uent(nloc, na, na), vent(nloc, na, na)
    1786   REAL sij(nloc, na, na), elij(nloc, na, na)
    1787   REAL traent(nloc, nd, nd, ntra)
    1788   REAL ments(nloc, nd, nd), qents(nloc, nd, nd)
    1789   REAL sigij(nloc, nd, nd)
    1790   INTEGER nent(nloc, nd)
     1824  REAL, DIMENSION (nloc, na, na), INTENT (OUT)        :: ment, qent
     1825  REAL, DIMENSION (nloc, na, na), INTENT (OUT)        :: uent, vent
     1826  REAL, DIMENSION (nloc, na, na), INTENT (OUT)        :: sij, elij
     1827  REAL, DIMENSION (nloc, nd, nd, ntra), INTENT (OUT)  :: traent
     1828  REAL, DIMENSION (nloc, nd, nd), INTENT (OUT)        :: ments, qents
     1829  INTEGER, DIMENSION (nloc, nd), INTENT (OUT)         :: nent
    17911830
    17921831!local variables:
    … …  
    17971836  REAL asij(nloc), smax(nloc), scrit(nloc)
    17981837  REAL asum(nloc, nd), bsum(nloc, nd), csum(nloc, nd)
     1838  REAL sigij(nloc, nd, nd)
    17991839  REAL wgh
    18001840  REAL zm(nloc, na)
    … …  
    21842224  include "cv3param.h"
    21852225  include "cvflag.h"
     2226  include "nuage.h"
    21862227
    21872228!inputs:
    … …  
    23632404
    23642405          IF (cvflag_ice) THEN
    2365             thaw = (t(il,i)-273.15)/(275.15-273.15)
     2406!CR:tmax_fonte_cv: T for which ice is totally melted (used to be 275.15)
     2407            thaw = (t(il,i)-273.15)/(tmax_fonte_cv-273.15)
    23662408            thaw = min(max(thaw,0.0), 1.0)
    23672409            frac(il, i) = frac(il, i)*(1.-thaw)
    … …  
    24772519          f6 = -100.*sigd(il)*bfac*(ph(il,i)-ph(il,i+1))*evap(il, i)
    24782520
    2479           thaw = (t(il,i)-273.15)/(275.15-273.15)
     2521!CR:tmax_fonte_cv: T for which ice is totally melted (used to be 275.15)
     2522          thaw = (t(il,i)-273.15)/(tmax_fonte_cv-273.15)
    24802523          thaw = min(max(thaw,0.0), 1.0)
    24812524          water(il, i) = water(il, i+1) + (1-fraci(il,i))*d6
    … …  
    27632806                     iflag, precip, Vprecip, ft, fr, fu, fv, ftra, &
    27642807                     cbmf, upwd, dnwd, dnwd0, ma, mip, &
    2765                      tls, tps, qcondc, wd, &
     2808!!                     tls, tps,                             ! useless . jyg
     2809                     qcondc, wd, &
    27662810                     ftd, fqd, qnk, qtc, sigt, tau_cld_cv, coefw_cld_cv)
    27672811
    … …  
    28112855      REAL dnwd0(nloc, nd), mip(nloc, nd)
    28122856      REAL Vprecip(nloc, nd+1)
    2813       REAL tls(nloc, nd), tps(nloc, nd)
     2857!!      REAL tls(nloc, nd), tps(nloc, nd)                 ! useless . jyg
    28142858      REAL qcondc(nloc, nd) ! cld
    28152859      REAL qtc(nloc,nd), sigt(nloc,nd) ! cld
    … …  
    28232867      REAL cpinv, rdcp, dpinv
    28242868      REAL awat(nloc)
    2825       REAL lvcp(nloc, na), lfcp(nloc, na), mke(nloc, na)
     2869      REAL lvcp(nloc, na), lfcp(nloc, na)                  ! , mke(nloc, na) ! unused . jyg
    28262870      REAL am(nloc), work(nloc), ad(nloc), amp1(nloc)
    28272871!!      real up1(nloc), dn1(nloc)
    … …  
    35883632! ***           reset counter and return           ***
    35893633
     3634! Reset counter only for points actually convective (jyg)
     3635! In order take into account the possibility of changing the compression,
     3636! reset m, sig and w0 to zero for non-convecting points.
    35903637  DO il = 1, ncum
    3591     sig(il, nd) = 2.0
     3638    IF (iflag(il) < 3) THEN
     3639      sig(il, nd) = 2.0
     3640    ENDIF
    35923641  END DO
    35933642
    … …  
    37433792! ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
    37443793
    3745   DO i = 1, nd
    3746     DO il = 1, ncum
    3747       mke(il, i) = upwd(il, i) + dnwd(il, i)
    3748     END DO
    3749   END DO
    3750 
    3751   DO i = 1, nd
    3752     DO il = 1, ncum
    3753       rdcp = (rrd*(1.-rr(il,i))-rr(il,i)*rrv)/(cpd*(1.-rr(il,i))+rr(il,i)*cpv)
    3754       tls(il, i) = t(il, i)*(1000.0/p(il,i))**rdcp
    3755       tps(il, i) = tp(il, i)
    3756     END DO
    3757   END DO
     3794!!  DO i = 1, nd                                  ! unused . jyg
     3795!!    DO il = 1, ncum                             ! unused . jyg
     3796!!      mke(il, i) = upwd(il, i) + dnwd(il, i)    ! unused . jyg
     3797!!    END DO                                      ! unused . jyg
     3798!!  END DO                                        ! unused . jyg
     3799
     3800!!  DO i = 1, nd                                                                 ! unused . jyg
     3801!!    DO il = 1, ncum                                                            ! unused . jyg
     3802!!      rdcp = (rrd*(1.-rr(il,i))-rr(il,i)*rrv)/(cpd*(1.-rr(il,i))+rr(il,i)*cpv) ! unused . jyg
     3803!!      tls(il, i) = t(il, i)*(1000.0/p(il,i))**rdcp                             ! unused . jyg
     3804!!      tps(il, i) = tp(il, i)                                                   ! unused . jyg
     3805!!    END DO                                                                     ! unused . jyg
     3806!!  END DO                                                                       ! unused . jyg
    37583807
    37593808

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

    r2220 r2298  
    1 SUBROUTINE cv3a_compress(len, nloc, ncum, nd, ntra, iflag1, nk1, icb1, icbs1, &
    2     plcl1, tnk1, qnk1, gznk1, hnk1, unk1, vnk1, wghti1, pbase1, buoybase1, &
    3     t1, q1, qs1, t1_wake, q1_wake, qs1_wake, s1_wake, u1, v1, gz1, th1, &
    4     th1_wake, tra1, h1, lv1, lf1, cpn1, p1, ph1, tv1, tp1, tvp1, clw1, &
    5     h1_wake, lv1_wake, lf1_wake, cpn1_wake, tv1_wake, sig1, w01, ptop21, &
    6     ale1, alp1, omega1, iflag, nk, icb, icbs, plcl, tnk, qnk, gznk, hnk, unk, vnk, &
    7     wghti, pbase, buoybase, t, q, qs, t_wake, q_wake, qs_wake, s_wake, u, v, &
    8     gz, th, th_wake, tra, h, lv, lf, cpn, p, ph, tv, tp, tvp, clw, h_wake, &
    9     lv_wake, lf_wake, cpn_wake, tv_wake, sig, w0, ptop2, ale, alp, omega)
     1SUBROUTINE cv3a_compress(len, nloc, ncum, nd, ntra, compress, &
     2                         iflag1, nk1, icb1, icbs1, &
     3                         plcl1, tnk1, qnk1, gznk1, hnk1, unk1, vnk1, &
     4                         wghti1, pbase1, buoybase1, &
     5                         t1, q1, qs1, t1_wake, q1_wake, qs1_wake, s1_wake, &
     6                         u1, v1, gz1, th1, th1_wake, &
     7                         tra1, &
     8                         h1, lv1, lf1, cpn1, p1, ph1, tv1, tp1, tvp1, clw1, &
     9                         h1_wake, lv1_wake, lf1_wake, cpn1_wake, tv1_wake, &
     10                         sig1, w01, ptop21, &
     11                         Ale1, Alp1, omega1, &
     12                         iflag, nk, icb, icbs, &
     13                         plcl, tnk, qnk, gznk, hnk, unk, vnk, &
     14                         wghti, pbase, buoybase, &
     15                         t, q, qs, t_wake, q_wake, qs_wake, s_wake, &
     16                         u, v, gz, th, th_wake, &
     17                         tra, &
     18                         h, lv, lf, cpn, p, ph, tv, tp, tvp, clw, &
     19                         h_wake, lv_wake, lf_wake, cpn_wake, tv_wake, &
     20                         sig, w0, ptop2, &
     21                         Ale, Alp, omega)
    1022  ! **************************************************************
    1123  ! *
    … …  
    2234
    2335  ! inputs:
    24   INTEGER len, nloc, ncum, nd, ntra
    25   INTEGER iflag1(len), nk1(len), icb1(len), icbs1(len)
    26   REAL plcl1(len), tnk1(len), qnk1(len), gznk1(len)
    27   REAL hnk1(len), unk1(len), vnk1(len)
    28   REAL wghti1(len, nd), pbase1(len), buoybase1(len)
    29   REAL t1(len, nd), q1(len, nd), qs1(len, nd)
    30   REAL t1_wake(len, nd), q1_wake(len, nd), qs1_wake(len, nd)
    31   REAL s1_wake(len)
    32   REAL u1(len, nd), v1(len, nd)
    33   REAL gz1(len, nd), th1(len, nd), th1_wake(len, nd)
    34   REAL tra1(len, nd, ntra)
    35   REAL h1(len, nd), lv1(len, nd), lf1(len, nd), cpn1(len, nd)
    36   REAL p1(len, nd), ph1(len, nd+1), tv1(len, nd), tp1(len, nd)
    37   REAL tvp1(len, nd), clw1(len, nd)
    38   REAL h1_wake(len, nd), lv1_wake(len, nd), cpn1_wake(len, nd)
    39   REAL tv1_wake(len, nd), lf1_wake(len, nd)
    40   REAL sig1(len, nd), w01(len, nd), ptop21(len)
    41   REAL ale1(len), alp1(len)
    42   REAL omega1(len,nd)
    43 
     36  INTEGER, INTENT (IN)                               :: len, nloc, nd, ntra
     37!jyg<
     38  LOGICAL, INTENT (IN)                               :: compress  ! compression is performed if compress is true
     39!>jyg
     40  INTEGER, DIMENSION (len), INTENT (IN)              :: iflag1, nk1, icb1, icbs1
     41  REAL, DIMENSION (len), INTENT (IN)                 :: plcl1, tnk1, qnk1, gznk1
     42  REAL, DIMENSION (len), INTENT (IN)                 :: hnk1, unk1, vnk1
     43  REAL, DIMENSION (len, nd), INTENT (IN)             :: wghti1(len, nd)
     44  REAL, DIMENSION (len), INTENT (IN)                 :: pbase1, buoybase1
     45  REAL, DIMENSION (len, nd), INTENT (IN)             :: t1, q1, qs1
     46  REAL, DIMENSION (len, nd), INTENT (IN)             :: t1_wake, q1_wake, qs1_wake
     47  REAL, DIMENSION (len), INTENT (IN)                 :: s1_wake
     48  REAL, DIMENSION (len, nd), INTENT (IN)             :: u1, v1
     49  REAL, DIMENSION (len, nd), INTENT (IN)             :: gz1, th1, th1_wake
     50  REAL, DIMENSION (len, nd,ntra), INTENT (IN)        :: tra1
     51  REAL, DIMENSION (len, nd), INTENT (IN)             :: h1, lv1, lf1, cpn1
     52  REAL, DIMENSION (len, nd), INTENT (IN)             :: p1
     53  REAL, DIMENSION (len, nd+1), INTENT (IN)           :: ph1(len, nd+1)
     54  REAL, DIMENSION (len, nd), INTENT (IN)             :: tv1, tp1
     55  REAL, DIMENSION (len, nd), INTENT (IN)             :: tvp1, clw1
     56  REAL, DIMENSION (len, nd), INTENT (IN)             :: h1_wake, lv1_wake, cpn1_wake
     57  REAL, DIMENSION (len, nd), INTENT (IN)             :: tv1_wake, lf1_wake
     58  REAL, DIMENSION (len, nd), INTENT (IN)             :: sig1, w01
     59  REAL, DIMENSION (len), INTENT (IN)                 :: ptop21
     60  REAL, DIMENSION (len), INTENT (IN)                 :: Ale1, Alp1
     61  REAL, DIMENSION (len, nd), INTENT (IN)             :: omega1
     62!
     63  ! in/out
     64  INTEGER, INTENT (INOUT)                            :: ncum
     65!
    4466  ! outputs:
    4567  ! en fait, on a nloc=len pour l'instant (cf cv_driver)
    46   INTEGER iflag(len), nk(len), icb(len), icbs(len)
    47   REAL plcl(len), tnk(len), qnk(len), gznk(len)
    48   REAL hnk(len), unk(len), vnk(len)
    49   REAL wghti(len, nd), pbase(len), buoybase(len)
    50   REAL t(len, nd), q(len, nd), qs(len, nd)
    51   REAL t_wake(len, nd), q_wake(len, nd), qs_wake(len, nd)
    52   REAL s_wake(len)
    53   REAL u(len, nd), v(len, nd)
    54   REAL gz(len, nd), th(len, nd), th_wake(len, nd)
    55   REAL tra(len, nd, ntra)
    56   REAL h(len, nd), lv(len, nd), lf(len, nd), cpn(len, nd)
    57   REAL p(len, nd), ph(len, nd+1), tv(len, nd), tp(len, nd)
    58   REAL tvp(len, nd), clw(len, nd)
    59   REAL h_wake(len, nd), lv_wake(len, nd), cpn_wake(len, nd)
    60   REAL tv_wake(len, nd), lf_wake(len, nd)
    61   REAL sig(len, nd), w0(len, nd), ptop2(len)
    62   REAL ale(len), alp(len)
    63   REAL omega(len,nd)
     68  INTEGER, DIMENSION (nloc), INTENT (OUT)            ::  iflag, nk, icb, icbs
     69  REAL, DIMENSION (nloc), INTENT (OUT)               ::  plcl, tnk, qnk, gznk
     70  REAL, DIMENSION (nloc), INTENT (OUT)               ::  hnk, unk, vnk
     71  REAL, DIMENSION (nloc, nd), INTENT (OUT)           ::  wghti
     72  REAL, DIMENSION (nloc), INTENT (OUT)               ::  pbase, buoybase
     73  REAL, DIMENSION (nloc, nd), INTENT (OUT)           ::  t, q, qs
     74  REAL, DIMENSION (nloc, nd), INTENT (OUT)           ::  t_wake, q_wake, qs_wake
     75  REAL, DIMENSION (nloc), INTENT (OUT)               ::  s_wake
     76  REAL, DIMENSION (nloc, nd), INTENT (OUT)           ::  u, v
     77  REAL, DIMENSION (nloc, nd), INTENT (OUT)           ::  gz, th, th_wake
     78  REAL, DIMENSION (nloc, nd,ntra), INTENT (OUT)      ::  tra
     79  REAL, DIMENSION (nloc, nd), INTENT (OUT)           ::  h, lv, lf, cpn
     80  REAL, DIMENSION (nloc, nd), INTENT (OUT)           ::  p
     81  REAL, DIMENSION (nloc, nd+1), INTENT (OUT)         ::  ph
     82  REAL, DIMENSION (nloc, nd), INTENT (OUT)           ::  tv, tp
     83  REAL, DIMENSION (nloc, nd), INTENT (OUT)           ::  tvp, clw
     84  REAL, DIMENSION (nloc, nd), INTENT (OUT)           ::  h_wake, lv_wake, cpn_wake
     85  REAL, DIMENSION (nloc, nd), INTENT (OUT)           ::  tv_wake, lf_wake
     86  REAL, DIMENSION (nloc, nd), INTENT (OUT)           ::  sig, w0
     87  REAL, DIMENSION (nloc), INTENT (OUT)               ::  ptop2
     88  REAL, DIMENSION (nloc), INTENT (OUT)               ::  Ale, Alp
     89  REAL, DIMENSION (nloc, nd), INTENT (OUT)           ::  omega
    6490
    6591  ! local variables:
    … …  
    6995  CHARACTER (LEN=80) :: abort_message
    7096
     97!jyg<
     98  IF (compress) THEN
     99!>jyg
    71100
    72101  DO k = 1, nl + 1
    … …  
    108137    END DO
    109138  END DO
    110 
     139!
    111140  ! AC!      do 121 j=1,ntra
    112141  ! AC!ccccc      do 111 k=1,nl+1
    … …  
    146175      pbase(nn) = pbase1(i)
    147176      buoybase(nn) = buoybase1(i)
     177      sig(nn, nd) = sig1(i, nd)
    148178      ptop2(nn) = ptop2(i)
    149       ale(nn) = ale1(i)
    150       alp(nn) = alp1(i)
     179      Ale(nn) = Ale1(i)
     180      Alp(nn) = Alp1(i)
    151181    END IF
    152182  END DO
    … …  
    157187    CALL abort_gcm(modname, abort_message, 1)
    158188  END IF
     189!
     190!jyg<
     191  ELSE  !(compress)
     192!
     193      ncum = len
     194!
     195      wghti(:,1:nl+1) = wghti1(:,1:nl+1)
     196      t(:,1:nl+1) = t1(:,1:nl+1)
     197      q(:,1:nl+1) = q1(:,1:nl+1)
     198      qs(:,1:nl+1) = qs1(:,1:nl+1)
     199      t_wake(:,1:nl+1) = t1_wake(:,1:nl+1)
     200      q_wake(:,1:nl+1) = q1_wake(:,1:nl+1)
     201      qs_wake(:,1:nl+1) = qs1_wake(:,1:nl+1)
     202      u(:,1:nl+1) = u1(:,1:nl+1)
     203      v(:,1:nl+1) = v1(:,1:nl+1)
     204      gz(:,1:nl+1) = gz1(:,1:nl+1)
     205      th(:,1:nl+1) = th1(:,1:nl+1)
     206      th_wake(:,1:nl+1) = th1_wake(:,1:nl+1)
     207      h(:,1:nl+1) = h1(:,1:nl+1)
     208      lv(:,1:nl+1) = lv1(:,1:nl+1)
     209      lf(:,1:nl+1) = lf1(:,1:nl+1)
     210      cpn(:,1:nl+1) = cpn1(:,1:nl+1)
     211      p(:,1:nl+1) = p1(:,1:nl+1)
     212      ph(:,1:nl+1) = ph1(:,1:nl+1)
     213      tv(:,1:nl+1) = tv1(:,1:nl+1)
     214      tp(:,1:nl+1) = tp1(:,1:nl+1)
     215      tvp(:,1:nl+1) = tvp1(:,1:nl+1)
     216      clw(:,1:nl+1) = clw1(:,1:nl+1)
     217      h_wake(:,1:nl+1) = h1_wake(:,1:nl+1)
     218      lv_wake(:,1:nl+1) = lv1_wake(:,1:nl+1)
     219      lf_wake(:,1:nl+1) = lf1_wake(:,1:nl+1)
     220      cpn_wake(:,1:nl+1) = cpn1_wake(:,1:nl+1)
     221      tv_wake(:,1:nl+1) = tv1_wake(:,1:nl+1)
     222      sig(:,1:nl+1) = sig1(:,1:nl+1)
     223      w0(:,1:nl+1) = w01(:,1:nl+1)
     224      omega(:,1:nl+1) = omega1(:,1:nl+1)
     225!
     226      s_wake(:) = s1_wake(:)
     227      iflag(:) = iflag1(:)
     228      nk(:) = nk1(:)
     229      icb(:) = icb1(:)
     230      icbs(:) = icbs1(:)
     231      plcl(:) = plcl1(:)
     232      tnk(:) = tnk1(:)
     233      qnk(:) = qnk1(:)
     234      gznk(:) = gznk1(:)
     235      hnk(:) = hnk1(:)
     236      unk(:) = unk1(:)
     237      vnk(:) = vnk1(:)
     238      pbase(:) = pbase1(:)
     239      buoybase(:) = buoybase1(:)
     240      sig(:, nd) = sig1(:, nd)
     241      ptop2(:) = ptop2(:)
     242      Ale(:) = Ale1(:)
     243      Alp(:) = Alp1(:)
     244!
     245  ENDIF !(compress)
     246!>jyg
    159247
    160248  RETURN

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

    r2220 r2298  
    1 SUBROUTINE cv3a_uncompress(nloc, len, ncum, nd, ntra, idcum, iflag, kbas, &
    2     ktop, precip, cbmf, plcl, plfc, wbeff, sig, w0, ptop2, ft, fq, fu, fv, &
    3     ftra, sigd, ma, mip, vprecip, upwd, dnwd, dnwd0, qcondc, wd, cape, cin, &
    4     tvp, ftd, fqd, plim1, plim2, asupmax, supmax0, asupmaxmin &
    5     , da, phi, mp, phi2, d1a, dam, sigij & ! RomP+AC+jyg
    6     , clw, elij, evap, ep, epmlmmm, eplamm & ! RomP
    7     , wdtraina, wdtrainm &         ! RomP
    8     , qtc, sigt          &
    9 
    10     , iflag1, kbas1, ktop1, precip1, cbmf1, plcl1, plfc1, wbeff1, sig1, w01, &
    11     ptop21, ft1, fq1, fu1, fv1, ftra1, sigd1, ma1, mip1, vprecip1, upwd1, &
    12     dnwd1, dnwd01, qcondc1, wd1, cape1, cin1, tvp1, ftd1, fqd1, plim11, &
    13     plim21, asupmax1, supmax01, asupmaxmin1 &
    14     , da1, phi1, mp1, phi21, d1a1, dam1, sigij1 & ! RomP+AC+jyg
    15     , clw1, elij1, evap1, ep1, epmlmmm1, eplamm1 & ! RomP
    16     , wdtraina1, wdtrainm1 & ! RomP
    17     , qtc1, sigt1)
     1SUBROUTINE cv3a_uncompress(nloc, len, ncum, nd, ntra, idcum, compress, &
     2                           iflag, kbas, ktop, &
     3                           precip, cbmf, plcl, plfc, wbeff, sig, w0, ptop2, &
     4                           ft, fq, fu, fv, ftra,  &
     5                           sigd, ma, mip, vprecip, upwd, dnwd, dnwd0, &
     6                           qcondc, wd, cape, cin, &
     7                           tvp, &
     8                           ftd, fqd, &
     9                           plim1, plim2, asupmax, supmax0, &
     10                           asupmaxmin, &
     11                           da, phi, mp, phi2, d1a, dam, sigij, &                ! RomP+AC+jyg
     12                           clw, elij, evap, ep, epmlmMm, eplaMm, &              ! RomP
     13                           wdtrainA, wdtrainM, &                                ! RomP
     14                           qtc, sigt,          &
     15                         
     16                           iflag1, kbas1, ktop1, &
     17                           precip1, cbmf1, plcl1, plfc1, wbeff1, sig1, w01, ptop21, &
     18                           ft1, fq1, fu1, fv1, ftra1, &
     19                           sigd1, ma1, mip1, vprecip1, upwd1, dnwd1, dnwd01, &
     20                           qcondc1, wd1, cape1, cin1, &
     21                           tvp1, &
     22                           ftd1, fqd1, &
     23                           plim11, plim21, asupmax1, supmax01, &
     24                           asupmaxmin1, &
     25                           da1, phi1, mp1, phi21, d1a1, dam1, sigij1, &         ! RomP+AC+jyg
     26                           clw1, elij1, evap1, ep1, epmlmMm1, eplaMm1, &        ! RomP
     27                           wdtrainA1, wdtrainM1, &                              ! RomP
     28                           qtc1, sigt1)
    1829
    1930  ! **************************************************************
    … …  
    3142
    3243  ! inputs:
    33   INTEGER nloc, len, ncum, nd, ntra
    34   INTEGER idcum(nloc)
    35   INTEGER iflag(nloc), kbas(nloc), ktop(nloc)
    36   REAL precip(nloc), cbmf(nloc), plcl(nloc), plfc(nloc)
    37   REAL wbeff(len)
    38   REAL sig(nloc, nd), w0(nloc, nd), ptop2(nloc)
    39   REAL ft(nloc, nd), fq(nloc, nd), fu(nloc, nd), fv(nloc, nd)
    40   REAL ftra(nloc, nd, ntra)
    41   REAL sigd(nloc)
    42   REAL ma(nloc, nd), mip(nloc, nd), vprecip(nloc, nd+1)
    43   REAL upwd(nloc, nd), dnwd(nloc, nd), dnwd0(nloc, nd)
    44   REAL qcondc(nloc, nd)
    45   REAL wd(nloc), cape(nloc), cin(nloc)
    46   REAL tvp(nloc, nd)
    47   REAL ftd(nloc, nd), fqd(nloc, nd)
    48   REAL plim1(nloc), plim2(nloc)
    49   REAL asupmax(nloc, nd), supmax0(nloc)
    50   REAL asupmaxmin(nloc)
    51 
    52   REAL da(nloc, nd), phi(nloc, nd, nd) !AC!
    53   REAL mp(nloc, nd) !RomP
    54   REAL phi2(nloc, nd, nd) !RomP
    55   REAL d1a(nloc, nd), dam(nloc, nd) !RomP
    56   REAL sigij(nloc, nd, nd) !RomP
    57   REAL clw(nloc, nd), elij(nloc, nd, nd) !RomP
    58   REAL evap(nloc, nd), ep(nloc, nd) !RomP
    59   REAL epmlmmm(nloc, nd, nd), eplamm(nloc, nd) !RomP+jyg
    60   REAL qtc(nloc, nd), sigt(nloc, nd) !RomP
    61   REAL wdtraina(nloc, nd), wdtrainm(nloc, nd) !RomP
     44  INTEGER, INTENT (IN)                               :: nloc, len, ncum, nd, ntra
     45  INTEGER, DIMENSION (nloc), INTENT (IN)             :: idcum(nloc)
     46!jyg<
     47  LOGICAL, INTENT (IN)                               :: compress
     48!>jyg
     49  INTEGER, DIMENSION (nloc), INTENT (IN)             ::iflag, kbas, ktop
     50  REAL, DIMENSION (nloc), INTENT (IN)                :: precip, cbmf, plcl, plfc
     51  REAL, DIMENSION (nloc), INTENT (IN)                :: wbeff
     52  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: sig, w0
     53  REAL, DIMENSION (nloc), INTENT (IN)                :: ptop2
     54  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: ft, fq, fu, fv
     55  REAL, DIMENSION (nloc, nd, ntra), INTENT (IN)      :: ftra
     56  REAL, DIMENSION (nloc), INTENT (IN)                :: sigd
     57  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: ma, mip
     58  REAL, DIMENSION (nloc, nd+1), INTENT (IN)          :: vprecip
     59  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: upwd, dnwd, dnwd0
     60  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: qcondc
     61  REAL, DIMENSION (nloc), INTENT (IN)                :: wd, cape, cin
     62  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: tvp
     63  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: ftd, fqd
     64  REAL, DIMENSION (nloc), INTENT (IN)                :: plim1, plim2
     65  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: asupmax
     66  REAL, DIMENSION (nloc), INTENT (IN)                :: supmax0, asupmaxmin
     67
     68  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: da
     69  REAL, DIMENSION (nloc, nd, nd), INTENT (IN)        :: phi                    !AC!
     70  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: mp                     !RomP
     71  REAL, DIMENSION (nloc, nd, nd), INTENT (IN)        :: phi2                   !RomP
     72  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: d1a, dam               !RomP
     73  REAL, DIMENSION (nloc, nd, nd), INTENT (IN)        :: sigij                  !RomP
     74  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: clw                    !RomP
     75  REAL, DIMENSION (nloc, nd, nd), INTENT (IN)        :: elij                   !RomP
     76  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: evap, ep               !RomP
     77  REAL, DIMENSION (nloc, nd, nd), INTENT (IN)        :: epmlmMm                !RomP+jyg
     78  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: eplamM                 !RomP+jyg
     79  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: qtc, sigt              !RomP
     80  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: wdtrainA, wdtrainM     !RomP
    6281
    6382  ! outputs:
    64   INTEGER iflag1(len), kbas1(len), ktop1(len)
    65   REAL precip1(len), cbmf1(len), plcl1(nloc), plfc1(nloc)
    66   REAL wbeff1(len)
    67   REAL sig1(len, nd), w01(len, nd), ptop21(len)
    68   REAL ft1(len, nd), fq1(len, nd), fu1(len, nd), fv1(len, nd)
    69   REAL ftra1(len, nd, ntra)
    70   REAL sigd1(len)
    71   REAL ma1(len, nd), mip1(len, nd), vprecip1(len, nd+1)
    72   REAL upwd1(len, nd), dnwd1(len, nd), dnwd01(len, nd)
    73   REAL qcondc1(len, nd)
    74   REAL wd1(len), cape1(len), cin1(len)
    75   REAL tvp1(len, nd)
    76   REAL ftd1(len, nd), fqd1(len, nd)
    77   REAL plim11(len), plim21(len)
    78   REAL asupmax1(len, nd), supmax01(len)
    79   REAL asupmaxmin1(len)
    80 
    81   REAL da1(nloc, nd), phi1(nloc, nd, nd) !AC!
    82   REAL mp1(nloc, nd) !RomP
    83   REAL phi21(nloc, nd, nd) !RomP
    84   REAL d1a1(nloc, nd), dam1(nloc, nd) !RomP
    85   REAL sigij1(len, nd, nd) !RomP
    86   REAL clw1(len, nd), elij1(len, nd, nd) !RomP
    87   REAL evap1(len, nd), ep1(len, nd) !RomP
    88   REAL epmlmmm1(len, nd, nd), eplamm1(len, nd) !RomP+jyg
    89   REAL qtc1(len, nd), sigt1(len, nd) !RomP
    90   REAL wdtraina1(len, nd), wdtrainm1(len, nd) !RomP
     83  INTEGER, DIMENSION (len), INTENT (OUT)             :: iflag1, kbas1, ktop1
     84  REAL, DIMENSION (len), INTENT (OUT)                :: precip1, cbmf1, plcl1, plfc1
     85  REAL, DIMENSION (len), INTENT (OUT)                :: wbeff1
     86  REAL, DIMENSION (len, nd), INTENT (OUT)            :: sig1, w01
     87  REAL, DIMENSION (len), INTENT (OUT)                :: ptop21
     88  REAL, DIMENSION (len, nd), INTENT (OUT)            :: ft1, fq1, fu1, fv1
     89  REAL, DIMENSION (len, nd, ntra), INTENT (OUT)      :: ftra1
     90  REAL, DIMENSION (len), INTENT (OUT)                :: sigd1
     91  REAL, DIMENSION (len, nd), INTENT (OUT)            :: ma1, mip1
     92  REAL, DIMENSION (len, nd+1), INTENT (OUT)          :: vprecip1
     93  REAL, DIMENSION (len, nd), INTENT (OUT)            :: upwd1, dnwd1, dnwd01
     94  REAL, DIMENSION (len, nd), INTENT (OUT)            :: qcondc1
     95  REAL, DIMENSION (len), INTENT (OUT)                :: wd1, cape1, cin1
     96  REAL, DIMENSION (len, nd), INTENT (OUT)            :: tvp1
     97  REAL, DIMENSION (len, nd), INTENT (OUT)            :: ftd1, fqd1
     98  REAL, DIMENSION (len), INTENT (OUT)                :: plim11, plim21
     99  REAL, DIMENSION (len, nd), INTENT (OUT)            :: asupmax1
     100  REAL, DIMENSION (len), INTENT (OUT)                :: supmax01, asupmaxmin1
     101                                                   
     102  REAL, DIMENSION (len, nd), INTENT (OUT)            :: da1
     103  REAL, DIMENSION (len, nd, nd), INTENT (OUT)        :: phi1                   !AC!
     104  REAL, DIMENSION (len, nd), INTENT (OUT)            :: mp1                    !RomP
     105  REAL, DIMENSION (len, nd, nd), INTENT (OUT)        :: phi21                  !RomP
     106  REAL, DIMENSION (len, nd), INTENT (OUT)            :: d1a1, dam1 !RomP       !RomP
     107  REAL, DIMENSION (len, nd, nd), INTENT (OUT)        :: sigij1                 !RomP
     108  REAL, DIMENSION (len, nd), INTENT (OUT)            :: clw1                   !RomP
     109  REAL, DIMENSION (len, nd, nd), INTENT (OUT)        :: elij1                  !RomP
     110  REAL, DIMENSION (len, nd), INTENT (OUT)            :: evap1, ep1             !RomP
     111  REAL, DIMENSION (len, nd, nd), INTENT (OUT)        :: epmlmMm1               !RomP+jyg
     112  REAL, DIMENSION (len, nd), INTENT (OUT)            :: eplamM1                !RomP+jyg
     113  REAL, DIMENSION (len, nd), INTENT (OUT)            :: qtc1, sigt1            !RomP
     114  REAL, DIMENSION (len, nd), INTENT (OUT)            :: wdtrainA1, wdtrainM1   !RomP
    91115
    92116
    93117  ! local variables:
    94118  INTEGER i, k, j
     119  INTEGER jdcum
    95120  ! c    integer k1,k2
    96121
    97   DO i = 1, ncum
    98     ptop21(idcum(i)) = ptop2(i)
    99     sigd1(idcum(i)) = sigd(i)
    100     precip1(idcum(i)) = precip(i)
    101     cbmf1(idcum(i)) = cbmf(i)
    102     plcl1(idcum(i)) = plcl(i)
    103     plfc1(idcum(i)) = plfc(i)
    104     wbeff1(idcum(i)) = wbeff(i)
    105     iflag1(idcum(i)) = iflag(i)
    106     kbas1(idcum(i)) = kbas(i)
    107     ktop1(idcum(i)) = ktop(i)
    108     wd1(idcum(i)) = wd(i)
    109     cape1(idcum(i)) = cape(i)
    110     cin1(idcum(i)) = cin(i)
    111     plim11(idcum(i)) = plim1(i)
    112     plim21(idcum(i)) = plim2(i)
    113     supmax01(idcum(i)) = supmax0(i)
    114     asupmaxmin1(idcum(i)) = asupmaxmin(i)
    115   END DO
    116 
    117   DO k = 1, nd
     122!jyg<
     123  IF (compress) THEN
     124!>jyg
    118125    DO i = 1, ncum
    119       sig1(idcum(i), k) = sig(i, k)
    120       w01(idcum(i), k) = w0(i, k)
    121       ft1(idcum(i), k) = ft(i, k)
    122       fq1(idcum(i), k) = fq(i, k)
    123       fu1(idcum(i), k) = fu(i, k)
    124       fv1(idcum(i), k) = fv(i, k)
    125       ma1(idcum(i), k) = ma(i, k)
    126       mip1(idcum(i), k) = mip(i, k)
    127       vprecip1(idcum(i), k) = vprecip(i, k)
    128       upwd1(idcum(i), k) = upwd(i, k)
    129       dnwd1(idcum(i), k) = dnwd(i, k)
    130       dnwd01(idcum(i), k) = dnwd0(i, k)
    131       qcondc1(idcum(i), k) = qcondc(i, k)
    132       tvp1(idcum(i), k) = tvp(i, k)
    133       ftd1(idcum(i), k) = ftd(i, k)
    134       fqd1(idcum(i), k) = fqd(i, k)
    135       asupmax1(idcum(i), k) = asupmax(i, k)
    136 
    137       da1(idcum(i), k) = da(i, k) !AC!
    138       mp1(idcum(i), k) = mp(i, k) !RomP
    139       d1a1(idcum(i), k) = d1a(i, k) !RomP
    140       dam1(idcum(i), k) = dam(i, k) !RomP
    141       clw1(idcum(i), k) = clw(i, k) !RomP
    142       evap1(idcum(i), k) = evap(i, k) !RomP
    143       ep1(idcum(i), k) = ep(i, k) !RomP
    144       eplamm(idcum(i), k) = eplamm(i, k) !RomP+jyg
    145       wdtraina1(idcum(i), k) = wdtraina(i, k) !RomP
    146       wdtrainm1(idcum(i), k) = wdtrainm(i, k) !RomP
    147       qtc1(idcum(i), k) = qtc(i, k)
    148       sigt1(idcum(i), k) = sigt(i, k)
    149 
     126      sig1(idcum(i), nd) = sig(i, nd)
     127      ptop21(idcum(i)) = ptop2(i)
     128      sigd1(idcum(i)) = sigd(i)
     129      precip1(idcum(i)) = precip(i)
     130      cbmf1(idcum(i)) = cbmf(i)
     131      plcl1(idcum(i)) = plcl(i)
     132      plfc1(idcum(i)) = plfc(i)
     133      wbeff1(idcum(i)) = wbeff(i)
     134      iflag1(idcum(i)) = iflag(i)
     135      kbas1(idcum(i)) = kbas(i)
     136      ktop1(idcum(i)) = ktop(i)
     137      wd1(idcum(i)) = wd(i)
     138      cape1(idcum(i)) = cape(i)
     139      cin1(idcum(i)) = cin(i)
     140      plim11(idcum(i)) = plim1(i)
     141      plim21(idcum(i)) = plim2(i)
     142      supmax01(idcum(i)) = supmax0(i)
     143      asupmaxmin1(idcum(i)) = asupmaxmin(i)
    150144    END DO
    151   END DO
    152 
    153   DO i = 1, ncum
    154     sig1(idcum(i), nd) = sig(i, nd)
    155   END DO
    156 
    157 
    158   ! AC!        do 2100 j=1,ntra
    159   ! AC!c oct3         do 2110 k=1,nl
    160   ! AC!         do 2110 k=1,nd ! oct3
    161   ! AC!          do 2120 i=1,ncum
    162   ! AC!            ftra1(idcum(i),k,j)=ftra(i,k,j)
    163   ! AC! 2120     continue
    164   ! AC! 2110    continue
    165   ! AC! 2100   continue
    166 
    167   ! AC!
    168   DO j = 1, nd
    169     DO k = 1, nd
     145   
     146    DO k = 1, nl+1
    170147      DO i = 1, ncum
    171         phi1(idcum(i), k, j) = phi(i, k, j) !AC!
    172         phi21(idcum(i), k, j) = phi2(i, k, j) !RomP
    173         sigij1(idcum(i), k, j) = sigij(i, k, j) !RomP
    174         elij1(idcum(i), k, j) = elij(i, k, j) !RomP
    175         epmlmmm(idcum(i), k, j) = epmlmmm(i, k, j) !RomP+jyg
     148        sig1(idcum(i), k) = sig(i, k)
     149        w01(idcum(i), k) = w0(i, k)
     150        ft1(idcum(i), k) = ft(i, k)
     151        fq1(idcum(i), k) = fq(i, k)
     152        fu1(idcum(i), k) = fu(i, k)
     153        fv1(idcum(i), k) = fv(i, k)
     154        ma1(idcum(i), k) = ma(i, k)
     155        mip1(idcum(i), k) = mip(i, k)
     156        vprecip1(idcum(i), k) = vprecip(i, k)
     157        upwd1(idcum(i), k) = upwd(i, k)
     158        dnwd1(idcum(i), k) = dnwd(i, k)
     159        dnwd01(idcum(i), k) = dnwd0(i, k)
     160        qcondc1(idcum(i), k) = qcondc(i, k)
     161        tvp1(idcum(i), k) = tvp(i, k)
     162        ftd1(idcum(i), k) = ftd(i, k)
     163        fqd1(idcum(i), k) = fqd(i, k)
     164        asupmax1(idcum(i), k) = asupmax(i, k)
     165   
     166        da1(idcum(i), k) = da(i, k) !AC!
     167        mp1(idcum(i), k) = mp(i, k) !RomP
     168        d1a1(idcum(i), k) = d1a(i, k) !RomP
     169        dam1(idcum(i), k) = dam(i, k) !RomP
     170        clw1(idcum(i), k) = clw(i, k) !RomP
     171        evap1(idcum(i), k) = evap(i, k) !RomP
     172        ep1(idcum(i), k) = ep(i, k) !RomP
     173        eplamM1(idcum(i), k) = eplamM(i, k) !RomP+jyg
     174        wdtrainA1(idcum(i), k) = wdtrainA(i, k) !RomP
     175        wdtrainM1(idcum(i), k) = wdtrainM(i, k) !RomP
     176        qtc1(idcum(i), k) = qtc(i, k)
     177        sigt1(idcum(i), k) = sigt(i, k)
     178   
    176179      END DO
    177180    END DO
    178   END DO
    179   ! AC!
    180 
    181 
    182   ! do 2220 k2=1,nd
    183   ! do 2210 k1=1,nd
    184   ! do 2200 i=1,ncum
    185   ! ment1(idcum(i),k1,k2) = ment(i,k1,k2)
    186   ! sigij1(idcum(i),k1,k2) = sigij(i,k1,k2)
    187   ! 2200      enddo
    188   ! 2210     enddo
    189   ! 2220    enddo
     181   
     182    ! AC!        do 2100 j=1,ntra
     183    ! AC!c oct3         do 2110 k=1,nl
     184    ! AC!         do 2110 k=1,nd ! oct3
     185    ! AC!          do 2120 i=1,ncum
     186    ! AC!            ftra1(idcum(i),k,j)=ftra(i,k,j)
     187    ! AC! 2120     continue
     188    ! AC! 2110    continue
     189    ! AC! 2100   continue
     190   
     191    ! AC!
     192!jyg<
     193!  Essais pour gagner du temps en diminuant l'adressage indirect
     194!!    DO j = 1, nd
     195!!      DO k = 1, nd
     196!!        DO i = 1, ncum
     197!!          phi1(idcum(i), k, j) = phi(i, k, j) !AC!
     198!!          phi21(idcum(i), k, j) = phi2(i, k, j) !RomP
     199!!          sigij1(idcum(i), k, j) = sigij(i, k, j) !RomP
     200!!          elij1(idcum(i), k, j) = elij(i, k, j) !RomP
     201!!          epmlmMm(idcum(i), k, j) = epmlmMm(i, k, j) !RomP+jyg
     202!!        END DO
     203!!      END DO
     204!!    END DO
     205      DO i = 1, ncum
     206        jdcum=idcum(i)
     207        phi1    (jdcum, 1:nl+1, 1:nl+1) = phi    (i, 1:nl+1, 1:nl+1)          !AC!
     208        phi21   (jdcum, 1:nl+1, 1:nl+1) = phi2   (i, 1:nl+1, 1:nl+1)          !RomP
     209        sigij1  (jdcum, 1:nl+1, 1:nl+1) = sigij  (i, 1:nl+1, 1:nl+1)          !RomP
     210        elij1   (jdcum, 1:nl+1, 1:nl+1) = elij   (i, 1:nl+1, 1:nl+1)          !RomP
     211        epmlmMm1(jdcum, 1:nl+1, 1:nl+1) = epmlmMm(i, 1:nl+1, 1:nl+1)          !RomP+jyg
     212      END DO
     213!>jyg
     214    ! AC!
     215   
     216   
     217    ! do 2220 k2=1,nd
     218    ! do 2210 k1=1,nd
     219    ! do 2200 i=1,ncum
     220    ! ment1(idcum(i),k1,k2) = ment(i,k1,k2)
     221    ! sigij1(idcum(i),k1,k2) = sigij(i,k1,k2)
     222    ! 2200      enddo
     223    ! 2210     enddo
     224    ! 2220    enddo
     225!
     226!jyg<
     227  ELSE  !(compress)
     228!
     229      sig1(:,nd) = sig(:,nd)
     230      ptop21(:) = ptop2(:)
     231      sigd1(:) = sigd(:)
     232      precip1(:) = precip(:)
     233      cbmf1(:) = cbmf(:)
     234      plcl1(:) = plcl(:)
     235      plfc1(:) = plfc(:)
     236      wbeff1(:) = wbeff(:)
     237      iflag1(:) = iflag(:)
     238      kbas1(:) = kbas(:)
     239      ktop1(:) = ktop(:)
     240      wd1(:) = wd(:)
     241      cape1(:) = cape(:)
     242      cin1(:) = cin(:)
     243      plim11(:) = plim1(:)
     244      plim21(:) = plim2(:)
     245      supmax01(:) = supmax0(:)
     246      asupmaxmin1(:) = asupmaxmin(:)
     247!
     248      sig1(:, 1:nl+1) = sig(:, 1:nl+1)
     249      w01(:, 1:nl+1) = w0(:, 1:nl+1)
     250      ft1(:, 1:nl+1) = ft(:, 1:nl+1)
     251      fq1(:, 1:nl+1) = fq(:, 1:nl+1)
     252      fu1(:, 1:nl+1) = fu(:, 1:nl+1)
     253      fv1(:, 1:nl+1) = fv(:, 1:nl+1)
     254      ma1(:, 1:nl+1) = ma(:, 1:nl+1)
     255      mip1(:, 1:nl+1) = mip(:, 1:nl+1)
     256      vprecip1(:, 1:nl+1) = vprecip(:, 1:nl+1)
     257      upwd1(:, 1:nl+1) = upwd(:, 1:nl+1)
     258      dnwd1(:, 1:nl+1) = dnwd(:, 1:nl+1)
     259      dnwd01(:, 1:nl+1) = dnwd0(:, 1:nl+1)
     260      qcondc1(:, 1:nl+1) = qcondc(:, 1:nl+1)
     261      tvp1(:, 1:nl+1) = tvp(:, 1:nl+1)
     262      ftd1(:, 1:nl+1) = ftd(:, 1:nl+1)
     263      fqd1(:, 1:nl+1) = fqd(:, 1:nl+1)
     264      asupmax1(:, 1:nl+1) = asupmax(:, 1:nl+1)
     265
     266      da1(:, 1:nl+1) = da(:, 1:nl+1)              !AC!
     267      mp1(:, 1:nl+1) = mp(:, 1:nl+1)              !RomP
     268      d1a1(:, 1:nl+1) = d1a(:, 1:nl+1)            !RomP
     269      dam1(:, 1:nl+1) = dam(:, 1:nl+1)            !RomP
     270      clw1(:, 1:nl+1) = clw(:, 1:nl+1)            !RomP
     271      evap1(:, 1:nl+1) = evap(:, 1:nl+1)          !RomP
     272      ep1(:, 1:nl+1) = ep(:, 1:nl+1)              !RomP
     273      eplamM1(:, 1:nl+1) = eplamM(:, 1:nl+1)       !RomP+jyg
     274      wdtrainA1(:, 1:nl+1) = wdtrainA(:, 1:nl+1)  !RomP
     275      wdtrainM1(:, 1:nl+1) = wdtrainM(:, 1:nl+1)  !RomP
     276      qtc1(:, 1:nl+1) = qtc(:, 1:nl+1)
     277      sigt1(:, 1:nl+1) = sigt(:, 1:nl+1)
     278!
     279      phi1    (:, 1:nl+1, 1:nl+1) = phi    (:, 1:nl+1, 1:nl+1)  !AC!
     280      phi21   (:, 1:nl+1, 1:nl+1) = phi2   (:, 1:nl+1, 1:nl+1)  !RomP
     281      sigij1  (:, 1:nl+1, 1:nl+1) = sigij  (:, 1:nl+1, 1:nl+1)  !RomP
     282      elij1   (:, 1:nl+1, 1:nl+1) = elij   (:, 1:nl+1, 1:nl+1)  !RomP
     283      epmlmMm1(:, 1:nl+1, 1:nl+1) = epmlmMm(:, 1:nl+1, 1:nl+1)  !RomP+jyg
     284  ENDIF !(compress)
     285!>jyg
    190286
    191287  RETURN

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

    r2258 r2298  
    2929
    3030  ! input:
    31   INTEGER ncum, nd, nloc
    32   INTEGER icb(nloc), inb(nloc)
    33   REAL pbase(nloc), plcl(nloc)
    34   REAL p(nloc, nd), ph(nloc, nd+1)
    35   REAL tv(nloc, nd), tvp(nloc, nd), buoy(nloc, nd)
    36   REAL supmax(nloc, nd)
    37   LOGICAL ok_inhib ! enable convection inhibition by dryness
    38   REAL ale(nloc), alp(nloc)
    39   REAL omega(nloc,nd)
     31  INTEGER, INTENT (IN)                               :: ncum, nd, nloc
     32  INTEGER, DIMENSION (nloc), INTENT (IN)             :: icb, inb
     33  REAL, DIMENSION (nloc), INTENT (IN)                :: pbase, plcl
     34  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: p
     35  REAL, DIMENSION (nloc, nd+1), INTENT (IN)          :: ph
     36  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: tv, tvp, buoy
     37  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: supmax
     38  LOGICAL, INTENT (IN)                               :: ok_inhib ! enable convection inhibition by dryness
     39  REAL, DIMENSION (nloc), INTENT (IN)                :: ale, alp
     40  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: omega
    4041
    4142  ! input/output:
    42   REAL sig(nloc, nd), w0(nloc, nd), ptop2(nloc)
     43  REAL, DIMENSION (nloc, nd), INTENT (INOUT)         :: sig, w0
     44  REAL, DIMENSION (nloc), INTENT (INOUT)             :: ptop2
    4345
    4446  ! output:
    45   REAL cape(nloc), cin(nloc)
    46   REAL m(nloc, nd)
    47   REAL plim1(nloc), plim2(nloc)
    48   REAL asupmax(nloc, nd), supmax0(nloc)
    49   REAL asupmaxmin(nloc)
    50   REAL cbmf(nloc), plfc(nloc)
    51   REAL wbeff(nloc)
    52   INTEGER iflag(nloc)
     47  REAL, DIMENSION (nloc), INTENT (OUT)               :: cape, cin
     48  REAL, DIMENSION (nloc, nd), INTENT (OUT)           :: m
     49  REAL, DIMENSION (nloc), INTENT (OUT)               :: plim1, plim2
     50  REAL, DIMENSION (nloc, nd), INTENT (OUT)           :: asupmax
     51  REAL, DIMENSION (nloc), INTENT (OUT)               :: supmax0
     52  REAL, DIMENSION (nloc), INTENT (OUT)               :: asupmaxmin
     53  REAL, DIMENSION (nloc), INTENT (OUT)               :: cbmf, plfc
     54  REAL, DIMENSION (nloc), INTENT (OUT)               :: wbeff
     55  INTEGER, DIMENSION (nloc), INTENT (OUT)            :: iflag
    5356
    5457  ! local variables:
    … …  
    9194
    9295
    93 
    9496  DO il = 1, ncum
    9597    alp2(il) = max(alp(il), 1.E-5)
    … …  
    498500  IF (prt_level>=20) PRINT *, 'cv3p1_param apres cbmflim'
    499501
    500   ! c 1.5 Compute cloud base mass flux given by Alp closure (Cbmf1), maximum
    501   ! c     allowed mass flux (Cbmfmax) and final target mass flux (Cbmf)
    502   ! c     Cbmf is set to zero if Cbmflim (the mass flux of elementary cloud)
    503   ! is
    504   ! --    exceedingly small.
     502  ! 1.5 Compute cloud base mass flux given by Alp closure (Cbmf1), maximum
     503  !     allowed mass flux (Cbmfmax) and final target mass flux (Cbmf)
     504  !     Cbmf is set to zero if Cbmflim (the mass flux of elementary cloud)
     505  !     is exceedingly small.
    505506
    506507  DO il = 1, ncum

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

    r1999 r2298  
    1919      real betad
    2020
    21       COMMON /cv3param/  noff, minorig, nl, nlp, nlm &
    22                       ,  sigdz, spfac &
    23                       ,flag_epKEorig &
     21      COMMON /cv3param/ sigdz, spfac &
    2422                      ,pbcrit, ptcrit &
    2523                      ,elcrit, tlcrit &
    … …  
    2725                      ,dtovsh, dpbase, dttrig &
    2826                      ,dtcrit, tau, beta, alpha, alpha1 &
    29                       ,flag_wb,wbmax &
    30                       ,delta, betad
     27                      ,wbmax &
     28                      ,delta, betad  &
     29                      ,flag_epKEorig &
     30                      ,flag_wb &
     31                      ,noff, minorig, nl, nlp, nlm
    3132!$OMP THREADPRIVATE(/cv3param/)
    3233

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

    r2220 r2298  
    22! $Id$
    33
    4 SUBROUTINE cva_driver(len, nd, ndp1, ntra, nloc, &
     4SUBROUTINE cva_driver(len, nd, ndp1, ntra, nloc, k_upper, &
    55                      iflag_con, iflag_mix, iflag_ice_thermo, iflag_clos, ok_conserv_q, &
    6                       delt, t1, q1, qs1, t1_wake, q1_wake, qs1_wake, s1_wake, &
     6!!                      delt, t1, q1, qs1, t1_wake, q1_wake, qs1_wake, s1_wake, &  ! jyg
     7                      delt, comp_threshold, &                                      ! jyg
     8                      t1, q1, qs1, t1_wake, q1_wake, qs1_wake, s1_wake, &          ! jyg
    79                      u1, v1, tra1, &
    810                      p1, ph1, &
    … …  
    1921                      ftd1, fqd1, &
    2022                      Plim11, Plim21, asupmax1, supmax01, asupmaxmin1, &
    21                       lalim_conv, &
     23                      lalim_conv1, &
    2224!!                      da1,phi1,mp1,phi21,d1a1,dam1,sigij1,clw1, &        ! RomP
    2325!!                      elij1,evap1,ep1,epmlmMm1,eplaMm1, &                ! RomP
    … …  
    5254! ndp1          Integer        Input        nd + 1
    5355! ntra          Integer        Input        number of tracors
     56! nloc          Integer        Input        dimension of arrays for compressed fields
     57! k_upper       Integer        Input        upmost level for vertical loops
    5458! iflag_con     Integer        Input        version of convect (3/4)
    5559! iflag_mix     Integer        Input        version of mixing  (0/1/2)
    … …  
    6064! ok_conserv_q  Logical        Input        when true corrections for water conservation are swtiched on
    6165! delt          Real           Input        time step
     66! comp_threshold Real           Input       threshold on the fraction of convective points below which
     67!                                            fields  are compressed
    6268! t1            Real           Input        temperature (sat draught envt)
    6369! q1            Real           Input        specific hum (sat draught envt)
    … …  
    156162  include 'iniprint.h'
    157163
    158 
    159164! Input
    160   INTEGER len
    161   INTEGER nd
    162   INTEGER ndp1
    163   INTEGER ntra
    164   INTEGER iflag_con
    165   INTEGER iflag_mix
    166   INTEGER iflag_ice_thermo
    167   INTEGER iflag_clos
    168   LOGICAL ok_conserv_q
    169   REAL tau_cld_cv
    170   REAL coefw_cld_cv
    171   REAL delt
    172   REAL t1(len, nd)
    173   REAL q1(len, nd)
    174   REAL qs1(len, nd)
    175   REAL t1_wake(len, nd)
    176   REAL q1_wake(len, nd)
    177   REAL qs1_wake(len, nd)
    178   REAL s1_wake(len)
    179   REAL u1(len, nd)
    180   REAL v1(len, nd)
    181   REAL tra1(len, nd, ntra)
    182   REAL p1(len, nd)
    183   REAL ph1(len, ndp1)
    184   REAL Ale1(len)
    185   REAL Alp1(len)
    186   REAL omega1(len,nd)
    187   REAL sig1feed1 ! pressure at lower bound of feeding layer
    188   REAL sig2feed1 ! pressure at upper bound of feeding layer
    189   REAL wght1(nd) ! weight density determining the feeding mixture
     165  INTEGER, INTENT (IN)                               :: len
     166  INTEGER, INTENT (IN)                               :: nd
     167  INTEGER, INTENT (IN)                               :: ndp1
     168  INTEGER, INTENT (IN)                               :: ntra
     169  INTEGER, INTENT(IN)                                :: nloc ! (nloc=klon)  pour l'instant
     170  INTEGER, INTENT (IN)                               :: k_upper
     171  INTEGER, INTENT (IN)                               :: iflag_con
     172  INTEGER, INTENT (IN)                               :: iflag_mix
     173  INTEGER, INTENT (IN)                               :: iflag_ice_thermo
     174  INTEGER, INTENT (IN)                               :: iflag_clos
     175  LOGICAL, INTENT (IN)                               :: ok_conserv_q
     176  REAL, INTENT (IN)                                  :: tau_cld_cv
     177  REAL, INTENT (IN)                                  :: coefw_cld_cv
     178  REAL, INTENT (IN)                                  :: delt
     179  REAL, INTENT (IN)                                  :: comp_threshold
     180  REAL, DIMENSION (len, nd), INTENT (IN)             :: t1
     181  REAL, DIMENSION (len, nd), INTENT (IN)             :: q1
     182  REAL, DIMENSION (len, nd), INTENT (IN)             :: qs1
     183  REAL, DIMENSION (len, nd), INTENT (IN)             :: t1_wake
     184  REAL, DIMENSION (len, nd), INTENT (IN)             :: q1_wake
     185  REAL, DIMENSION (len, nd), INTENT (IN)             :: qs1_wake
     186  REAL, DIMENSION (len), INTENT (IN)                 :: s1_wake
     187  REAL, DIMENSION (len, nd), INTENT (IN)             :: u1
     188  REAL, DIMENSION (len, nd), INTENT (IN)             :: v1
     189  REAL, DIMENSION (len, nd, ntra), INTENT (IN)       :: tra1
     190  REAL, DIMENSION (len, nd), INTENT (IN)             :: p1
     191  REAL, DIMENSION (len, ndp1), INTENT (IN)           :: ph1
     192  REAL, DIMENSION (len), INTENT (IN)                 :: Ale1
     193  REAL, DIMENSION (len), INTENT (IN)                 :: Alp1
     194  REAL, DIMENSION (len, nd), INTENT (IN)             :: omega1
     195  REAL, INTENT (IN)                                  :: sig1feed1 ! pressure at lower bound of feeding layer
     196  REAL, INTENT (IN)                                  :: sig2feed1 ! pressure at upper bound of feeding layer
     197  REAL, DIMENSION (nd), INTENT (IN)                  :: wght1     ! weight density determining the feeding mixture
     198  INTEGER, DIMENSION (len), INTENT (IN)              :: lalim_conv1
     199
     200! Input/Output
     201  REAL, DIMENSION (len, nd), INTENT (INOUT)          :: sig1
     202  REAL, DIMENSION (len, nd), INTENT (INOUT)          :: w01
    190203
    191204! Output
    192   INTEGER iflag1(len)
    193   REAL ft1(len, nd)
    194   REAL fq1(len, nd)
    195   REAL fu1(len, nd)
    196   REAL fv1(len, nd)
    197   REAL ftra1(len, nd, ntra)
    198   REAL precip1(len)
    199   INTEGER kbas1(len)
    200   INTEGER ktop1(len)
    201   REAL cbmf1(len)
    202   REAL plcl1(klon)
    203   REAL plfc1(klon)
    204   REAL wbeff1(klon)
    205   REAL sig1(len, klev) !input/output
    206   REAL w01(len, klev) !input/output
    207   REAL ptop21(len)
    208   REAL sigd1(len)
    209   REAL ma1(len, nd)
    210   REAL mip1(len, nd)
     205  INTEGER, DIMENSION (len), INTENT (OUT)             :: iflag1
     206  REAL, DIMENSION (len, nd), INTENT (OUT)            :: ft1
     207  REAL, DIMENSION (len, nd), INTENT (OUT)            :: fq1
     208  REAL, DIMENSION (len, nd), INTENT (OUT)            :: fu1
     209  REAL, DIMENSION (len, nd), INTENT (OUT)            :: fv1
     210  REAL, DIMENSION (len, nd, ntra), INTENT (OUT)      :: ftra1
     211  REAL, DIMENSION (len), INTENT (OUT)                :: precip1
     212  INTEGER, DIMENSION (len), INTENT (OUT)             :: kbas1
     213  INTEGER, DIMENSION (len), INTENT (OUT)             :: ktop1
     214  REAL, DIMENSION (len), INTENT (OUT)                :: cbmf1
     215  REAL, DIMENSION (len), INTENT (OUT)                :: plcl1
     216  REAL, DIMENSION (len), INTENT (OUT)                :: plfc1
     217  REAL, DIMENSION (len), INTENT (OUT)                :: wbeff1
     218  REAL, DIMENSION (len), INTENT (OUT)                :: ptop21
     219  REAL, DIMENSION (len), INTENT (OUT)                :: sigd1
     220  REAL, DIMENSION (len, nd), INTENT (OUT)            :: ma1
     221  REAL, DIMENSION (len, nd), INTENT (OUT)            :: mip1
    211222! real Vprecip1(len,nd)
    212   REAL vprecip1(len, nd+1)
    213   REAL upwd1(len, nd)
    214   REAL dnwd1(len, nd)
    215   REAL dnwd01(len, nd)
    216   REAL qcondc1(len, nd) ! cld
    217   REAL wd1(len) ! gust
    218   REAL cape1(len)
    219   REAL cin1(len)
    220   REAL tvp1(len, nd)
     223  REAL, DIMENSION (len, ndp1), INTENT (OUT)          :: vprecip1
     224  REAL, DIMENSION (len, nd), INTENT (OUT)            :: upwd1
     225  REAL, DIMENSION (len, nd), INTENT (OUT)            :: dnwd1
     226  REAL, DIMENSION (len, nd), INTENT (OUT)            :: dnwd01
     227  REAL, DIMENSION (len, nd), INTENT (OUT)            :: qcondc1        ! cld
     228  REAL, DIMENSION (len), INTENT (OUT)                :: wd1            ! gust
     229  REAL, DIMENSION (len), INTENT (OUT)                :: cape1
     230  REAL, DIMENSION (len), INTENT (OUT)                :: cin1
     231  REAL, DIMENSION (len, nd), INTENT (OUT)            :: tvp1
    221232
    222233!AC!
    … …  
    224235!!      real da(len,nd),phi(len,nd,nd)
    225236!AC!
    226   REAL ftd1(len, nd)
    227   REAL fqd1(len, nd)
    228   REAL Plim11(len)
    229   REAL Plim21(len)
    230   REAL asupmax1(len, nd)
    231   REAL supmax01(len)
    232   REAL asupmaxmin1(len)
    233   INTEGER lalim_conv(len)
    234   REAL qtc1(len, nd)         ! cld
    235   REAL sigt1(len, nd)        ! cld
     237  REAL, DIMENSION (len, nd), INTENT (OUT)            :: ftd1
     238  REAL, DIMENSION (len, nd), INTENT (OUT)            :: fqd1
     239  REAL, DIMENSION (len), INTENT (OUT)                :: Plim11
     240  REAL, DIMENSION (len), INTENT (OUT)                :: Plim21
     241  REAL, DIMENSION (len, nd), INTENT (OUT)            :: asupmax1
     242  REAL, DIMENSION (len), INTENT (OUT)                :: supmax01
     243  REAL, DIMENSION (len), INTENT (OUT)                :: asupmaxmin1
     244  REAL, DIMENSION (len, nd), INTENT (OUT)            :: qtc1            ! cld
     245  REAL, DIMENSION (len, nd), INTENT (OUT)            :: sigt1           ! cld
    236246
    237247! RomP >>>
    238   REAL wdtrainA1(len, nd), wdtrainM1(len, nd)
    239   REAL da1(len, nd), phi1(len, nd, nd), mp1(len, nd)
    240   REAL epmlmMm1(len, nd, nd), eplaMm1(len, nd)
    241   REAL evap1(len, nd), ep1(len, nd)
    242   REAL sigij1(len, nd, nd), elij1(len, nd, nd)
     248  REAL, DIMENSION (len, nd), INTENT (OUT)            :: wdtrainA1, wdtrainM1
     249  REAL, DIMENSION (len, nd), INTENT (OUT)            :: da1, mp1
     250  REAL, DIMENSION (len, nd, nd), INTENT (OUT)        :: phi1
     251  REAL, DIMENSION (len, nd, nd), INTENT (OUT)        :: epmlmMm1
     252  REAL, DIMENSION (len, nd), INTENT (OUT)            :: eplaMm1
     253  REAL, DIMENSION (len, nd), INTENT (OUT)            :: evap1, ep1
     254  REAL, DIMENSION (len, nd, nd), INTENT (OUT)        :: sigij1, elij1
    243255!JYG,RL
    244   REAL wghti1(len, nd) ! final weight of the feeding layers
     256  REAL, DIMENSION (len, nd), INTENT (OUT)            :: wghti1      ! final weight of the feeding layers
    245257!JYG,RL
    246   REAL phi21(len, nd, nd)
    247   REAL d1a1(len, nd), dam1(len, nd)
     258  REAL, DIMENSION (len, nd, nd), INTENT (OUT)        :: phi21
     259  REAL, DIMENSION (len, nd), INTENT (OUT)            :: d1a1, dam1
    248260! RomP <<<
    249261
    … …  
    388400!$OMP THREADPRIVATE(debut)
    389401
     402  REAL coef_convective(len)   ! = 1 for convective points, = 0 otherwise
    390403  REAL tnk1(klon)
    391404  REAL thnk1(klon)
    … …  
    426439! (local) compressed fields:
    427440
    428   INTEGER nloc
    429 ! parameter (nloc=klon) ! pour l'instant
    430441
    431442  INTEGER idcum(nloc)
     443!jyg<
     444  LOGICAL compress    ! True if compression occurs
     445!>jyg
    432446  INTEGER iflag(nloc), nk(nloc), icb(nloc)
    433447  INTEGER nent(nloc, klev)
    … …  
    480494  REAL fu(nloc, klev), fv(nloc, klev)
    481495  REAL upwd(nloc, klev), dnwd(nloc, klev), dnwd0(nloc, klev)
    482   REAL ma(nloc, klev), mip(nloc, klev), tls(nloc, klev)
    483   REAL tps(nloc, klev), qprime(nloc), tprime(nloc)
     496  REAL ma(nloc, klev), mip(nloc, klev)
     497!!  REAL tls(nloc, klev), tps(nloc, klev)                 ! unused . jyg
     498  REAL qprime(nloc), tprime(nloc)
    484499  REAL precip(nloc)
    485500! real Vprecip(nloc,klev)
    … …  
    547562
    548563  IF (iflag_con==3) THEN
    549     CALL cv3_param(nd, delt)
     564    CALL cv3_param(nd, k_upper, delt)
    550565
    551566  END IF
    … …  
    682697!   p2feed1(i)=ph1(i,3)
    683698!testCR: on prend la couche alim des thermiques
    684 !   p2feed1(i)=ph1(i,lalim_conv(i)+1)
     699!   p2feed1(i)=ph1(i,lalim_conv1(i)+1)
    685700!   print*,'lentr=',lentr(i),ph1(i,lentr(i)+1),ph1(i,2)
    686701  END DO
    … …  
    762777! =====================================================================
    763778
     779!  Determine the number "ncum" of convective gridpoints, the list "idcum" of convective
     780!  gridpoints and the weights "coef_convective" (= 1. for convective gridpoints and = 0.
     781!  elsewhere).
    764782  ncum = 0
     783  coef_convective(:) = 0.
    765784  DO i = 1, len
    766785    IF (iflag1(i)==0) THEN
     786      coef_convective(i) = 1.
    767787      ncum = ncum + 1
    768788      idcum(ncum) = i
    … …  
    782802! print*,'ncum tv1 ',ncum,tv1
    783803! print*,'tvp1 ',tvp1
    784       CALL cv3a_compress(len, nloc, ncum, nd, ntra, &
     804!jyg<
     805!   If the fraction of convective points is larger than comp_threshold, then compression
     806!   is assumed useless.
     807!
     808  compress = ncum .lt. len*comp_threshold
     809!
     810  IF (.not. compress) THEN
     811    DO i = 1,len
     812      idcum(i) = i
     813    ENDDO
     814  ENDIF
     815!
     816!>jyg
     817      CALL cv3a_compress(len, nloc, ncum, nd, ntra, compress, &
    785818                         iflag1, nk1, icb1, icbs1, &
    786819                         plcl1, tnk1, qnk1, gznk1, hnk1, unk1, vnk1, &
    … …  
    837870                         inb, tp, tvp, clw, hp, ep, sigp, buoy, &
    838871                         frac)
    839 
    840872    END IF
    841873
    … …  
    897929                           Plim1, plim2, asupmax, supmax0, &
    898930                           asupmaxmin, cbmf, plfc, wbeff)
    899 
    900931        if (prt_level >= 10) &
    901932             PRINT *, 'cv3p1_closure-> plfc,wbeff ', plfc(1), wbeff(1)
    … …  
    9931024                     iflag, precip, vprecip, ft, fq, fu, fv, ftra, &
    9941025                     cbmf, upwd, dnwd, dnwd0, ma, mip, &
    995                      tls, tps, qcondc, wd, &
     1026!!                     tls, tps, &                            ! useless . jyg
     1027                     qcondc, wd, &
    9961028                     ftd, fqd, qnk, qtc, sigt, tau_cld_cv, coefw_cld_cv)
    9971029    END IF
    … …  
    10351067
    10361068    IF (iflag_con==3) THEN
    1037       CALL cv3a_uncompress(nloc, len, ncum, nd, ntra, idcum, &
     1069      CALL cv3a_uncompress(nloc, len, ncum, nd, ntra, idcum, compress, &
    10381070                           iflag, icb, inb, &
    10391071                           precip, cbmf, plcl, plfc, wbeff, sig, w0, ptop2, &
    … …  
    10781110  END IF ! ncum>0
    10791111
     1112!
     1113! In order take into account the possibility of changing the compression,
     1114! reset m, sig and w0 to zero for non-convective points.
     1115  DO k = 1,nd-1
     1116        sig1(:, k) = sig1(:, k)*coef_convective(:)
     1117        w01(:, k)  = w01(:, k)*coef_convective(:)
     1118  ENDDO
     1119
    10801120  IF (debut) THEN
    1081     PRINT *, ' cv_compress -> '
     1121    PRINT *, ' cv_uncompress -> '
    10821122    debut = .FALSE.
    10831123  END IF  !(debut) THEN

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

    r2160 r2298  
    122122  real                           :: conservMA
    123123
    124   ! ======================================================
    125   ! calcul de l'impaction
    126   ! ======================================================
    127 
    128   ! impaction sur la surface de la colonne de la descente insaturee
    129   ! On prend la moyenne des precip entre le niveau i+1 et i
    130   ! I=3/4* (P(1+1)+P(i))/2 / (sigd*r*rho_l)
    131   ! 1000kg/m3= densite de l'eau
    132   ! 0.75e-3 = 3/4 /1000
    133   ! Par la suite, I est tout le temps multiplie par sig_d pour avoir l'impaction sur la surface de la maille
    134   ! on le neglige ici pour simplifier le code
    135 
    136   DO j=1,klev-1
    137      DO i=1,klon
    138         imp(i,j) = coefcoli_3d(i,j)*0.75e-3/rdrop *&
    139              0.5*(pmflxr(i,j+1)+pmflxs(i,j+1)+pmflxr(i,j)+pmflxs(i,j))
    140      ENDDO
    141   ENDDO
     124!jyg<
     125!!  ! ======================================================
     126!!  ! calcul de l'impaction
     127!!  ! ======================================================
     128!!
     129!!  ! impaction sur la surface de la colonne de la descente insaturee
     130!!  ! On prend la moyenne des precip entre le niveau i+1 et i
     131!!  ! I=3/4* (P(1+1)+P(i))/2 / (sigd*r*rho_l)
     132!!  ! 1000kg/m3= densite de l'eau
     133!!  ! 0.75e-3 = 3/4 /1000
     134!!  ! Par la suite, I est tout le temps multiplie par sig_d pour avoir l'impaction sur la surface de la maille
     135!!!!  ! on le neglige ici pour simplifier le code
     136!!
     137!!  DO j=1,klev-1
     138!!     DO i=1,klon
     139!!        imp(i,j) = coefcoli_3d(i,j)*0.75e-3/rdrop *&
     140!!             0.5*(pmflxr(i,j+1)+pmflxs(i,j+1)+pmflxr(i,j)+pmflxs(i,j))
     141!!     ENDDO
     142!!  ENDDO
     143!>jyg
    142144  !
    143145  ! initialisation pour flux de traceurs, td et autre
    … …  
    237239  END DO
    238240
     241!jyg<
     242  ! ======================================================
     243  ! calcul de l'impaction
     244  ! ======================================================
     245
     246  ! impaction sur la surface de la colonne de la descente insaturee
     247  ! On prend la moyenne des precip entre le niveau i+1 et i
     248  ! I=3/4* (P(1+1)+P(i))/2 / (sigd*r*rho_l)
     249  ! 1000kg/m3= densite de l'eau
     250  ! 0.75e-3 = 3/4 /1000
     251  ! Par la suite, I est tout le temps multiplie par sig_d pour avoir l'impaction sur la surface de la maille
     252  ! on le neglige ici pour simplifier le code
     253
     254  DO j=1,klev-1
     255     DO i=1,klon
     256        imp(i,j) = coefcoli_3d(i,j)*0.75e-3/rdrop *&
     257             0.5*(pmflxr(i,j+1)+pmflxs(i,j+1)+pmflxr(i,j)+pmflxs(i,j))
     258     ENDDO
     259  ENDDO
     260!>jyg
    239261  ! =========================================
    240262  ! calcul des tendances liees au downdraft

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

    r1910 r2298  
    5757      REAL zx_tmp_fiNC(klon,nlevSTD)
    5858
    59       REAL missing_val
     59!     REAL missing_val
    6060      REAL, SAVE :: freq_moyNMC(nout)
    6161!$OMP THREADPRIVATE(freq_moyNMC)

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

    r2258 r2298  
    55!
    66SUBROUTINE etat0_netcdf(ib, masque, phis, letat0)
     7#ifndef CPP_1D
    78!
    89!-------------------------------------------------------------------------------
    … …  
    5354#include "dimsoil.h"
    5455#include "temps.h"
    55   REAL,    DIMENSION(klon)                 :: tsol, qsol
     56  REAL,    DIMENSION(klon)                 :: tsol
    5657  REAL,    DIMENSION(klon)                 :: sn, rugmer, run_off_lic_0
    5758  REAL,    DIMENSION(iip1,jjp1)            :: orog, rugo, psol
    … …  
    6061  REAL,    DIMENSION(iip1,jjm ,llm)        :: vvent
    6162  REAL,    DIMENSION(:,:,:,:), ALLOCATABLE :: q3d
    62   REAL,    DIMENSION(klon,nbsrf)           :: qsolsrf, snsrf, evap
    63   REAL,    DIMENSION(klon,nbsrf)           :: frugs, agesno
     63  REAL,    DIMENSION(klon,nbsrf)           :: qsolsrf, snsrf
    6464  REAL,    DIMENSION(klon,nsoilmx,nbsrf)   :: tsoil
    6565
    … …  
    479479  DO i=1,nbsrf; ftsol(:,i) = tsol; END DO
    480480  DO i=1,nbsrf; snsrf(:,i) = sn;   END DO
    481   falb1(:,is_ter) = 0.08; falb1(:,is_lic) = 0.6
    482   falb1(:,is_oce) = 0.5;  falb1(:,is_sic) = 0.6
    483   falb2 = falb1
    484481!albedo SB >>>
    485482  falb_dir(:,is_ter,:)=0.08; falb_dir(:,is_lic,:)=0.6
    486483  falb_dir(:,is_oce,:)=0.5;  falb_dir(:,is_sic,:)=0.6
    487484!albedo SB <<<
    488   evap(:,:) = 0.
     485  fevap(:,:) = 0.
    489486  DO i=1,nbsrf; qsolsrf(:,i)=150.; END DO
    490487  DO i=1,nbsrf; DO j=1,nsoilmx; tsoil(:,j,i) = tsol; END DO; END DO
    … …  
    494491  q_ancien = 0.
    495492  agesno = 0.
    496   frugs(:,is_oce) = rugmer(:)
    497   frugs(:,is_ter) = MAX(1.0e-05,zstd(:)*zsig(:)/2.0)
    498   frugs(:,is_lic) = MAX(1.0e-05,zstd(:)*zsig(:)/2.0)
    499   frugs(:,is_sic) = 0.001
     493
     494  z0m(:,is_oce) = rugmer(:)
     495  z0m(:,is_ter) = MAX(1.0e-05,zstd(:)*zsig(:)/2.0)
     496  z0m(:,is_lic) = MAX(1.0e-05,zstd(:)*zsig(:)/2.0)
     497  z0m(:,is_sic) = 0.001
     498  z0h(:,:)=z0m(:,:)
     499
    500500  fder = 0.0
    501501  clwcon = 0.0
    … …  
    525525
    526526  CALL fonte_neige_init(run_off_lic_0)
    527   CALL pbl_surface_init( qsol, fder, snsrf, qsolsrf, evap, frugs, agesno, tsoil )
     527  CALL pbl_surface_init( fder, snsrf, qsolsrf, tsoil )
    528528  CALL phyredem( "startphy.nc" )
    529529
    … …  
    535535!#endif of #ifdef CPP_EARTH
    536536  RETURN
    537 
     537#endif
     538!#endif of ifndef CPP_1D
    538539END SUBROUTINE etat0_netcdf
    539540!

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

    r1910 r2298  
    3030!----------------
    3131     DO it = 1,nbtr
    32         iiq = niadv(it+2)
     32!!        iiq = niadv(it+2)                                                         ! jyg
     33        iiq = niadv(it+nqo)                                                         ! jyg
    3334
    3435! CONCENTRATIONS

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

    r1910 r2298  
    33!
    44SUBROUTINE Init_Phys_lmdz(iim,jjp1,llm,nb_proc,distrib)
    5   USE mod_phys_lmdz_para
    6   USE mod_grid_phy_lmdz
     5  USE mod_phys_lmdz_para, ONLY: Init_phys_lmdz_para, klon_omp
     6  USE mod_grid_phy_lmdz, ONLY: Init_grid_phy_lmdz, nbp_lev
    77  USE dimphy, ONLY : Init_dimphy
    88  USE infotrac, ONLY : type_trac

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

    r2187 r2298  
    44!
    55SUBROUTINE limit_netcdf(interbar, extrap, oldice, masque)
     6#ifndef CPP_1D
    67!
    78!-------------------------------------------------------------------------------
    … …  
    662663! of #ifdef CPP_EARTH
    663664
     665#endif
     666! of #ifndef CPP_1D
    664667END SUBROUTINE limit_netcdf

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

    r1910 r2298  
    11!$Id $
    22
    3 SUBROUTINE lsc_scav(pdtime,it,iflag_lscav,oliq,flxr,flxs,rneb,beta_fisrt,  &
     3SUBROUTINE lsc_scav(pdtime,it,iflag_lscav,  &
     4!jyg<
     5                    aerosol,  &
     6!>jyg
     7                    oliq,flxr,flxs,rneb,beta_fisrt,  &
    48                    beta_v1,pplay,paprs,t,tr_seri,d_tr_insc,          &
    59                    d_tr_bcscav,d_tr_evap,qPrls)
    … …  
    3741  REAL,DIMENSION(klon,klev),INTENT(IN)   :: t        ! temperature
    3842! tracers
     43  LOGICAL,DIMENSION(nbtr), INTENT(IN)         :: aerosol
    3944  REAL,DIMENSION(klon,klev,nbtr),INTENT(IN)   :: tr_seri        ! q de traceur 
    4045  REAL,DIMENSION(klon,klev),INTENT(IN)        :: beta_fisrt     ! taux de conversion de l'eau cond
    … …  
    172177  ENDDO
    173178
    174     IF (it.gt.1) THEN                               !  aerosol   
     179!jyg<
     180!!    IF (it.gt.1) THEN                               !  aerosol   
     181!! Temporary correction: all non-aerosol tracers are dealt with in the same way.
     182!! Should be updated once it has been decided how gases should be dealt with.
     183    IF (aerosol(it)) THEN
     184!>jyg
    175185      frac_ev=frac_aer
    176186    ELSE                                                !  gas
    … …  
    178188    ENDIF
    179189
    180     IF(it.gt.1) then  ! aerosol
     190!jyg<
     191!!    IF (it.gt.1) THEN                               !  aerosol   
     192    IF (aerosol(it)) THEN
     193!>jyg
    181194     DO k=1, klev
    182195      DO i=1, klon
    … …  
    214227
    215228!  below-cloud impaction
    216     IF(it.eq.1) then
     229!jyg<
     230!!    IF (it.eq.1) THEN
     231    IF (.NOT.aerosol(it)) THEN
     232!>jyg
    217233      d_tr_bcscav(i,k,it)=0.
    218234    ELSE

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

    r1999 r2298  
    55  USE netcdf
    66  USE dimphy
     7#ifdef CPP_IOIPSL
    78  USE phys_state_var_mod
     9#endif
     10
    811  USE phys_cal_mod, ONLY: mth_len
    912  IMPLICIT NONE
    1013  include "clesphys.h"
     14#ifdef CPP_IOIPSL
     15  REAL :: missing_val
     16#endif
    1117
    1218  ! ====================================================================
    … …  
    5157  REAL un_jour
    5258  PARAMETER (un_jour=86400.)
    53   REAL missing_val
     59! REAL missing_val
    5460
    55   missing_val = nf90_fill_real
     61! missing_val = nf90_fill_real
     62#ifndef CPP_XIOS
     63      missing_val=missing_val_nf90
     64#endif
    5665
    5766  DO n = 1, nout

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

    r2220 r2298  
    77      REAL tau_cld_cv,coefw_cld_cv
    88
     9      REAL tmax_fonte_cv
     10
    911      INTEGER iflag_t_glace,iflag_cld_cv
    1012
    … …  
    1214     &                  t_glace_min,exposant_glace,rei_min,rei_max,     &
    1315     &                  tau_cld_cv,coefw_cld_cv,                        &
    14      &                  iflag_t_glace,iflag_cld_cv
     16     &                  iflag_t_glace,iflag_cld_cv,tmax_fonte_cv
    1517!$OMP THREADPRIVATE(/nuagecom/)

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

    r1910 r2298  
    4646       windsp, fder_old, &
    4747       itime, dtime, knon, knindex, &
    48        p1lay, cdragh, cdragm, precip_rain, precip_snow, temp_air, spechum, &
     48       p1lay, cdragh, cdragq, cdragm, precip_rain, precip_snow, temp_air, spechum, &
    4949       AcoefH, AcoefQ, BcoefH, BcoefQ, &
    5050       AcoefU, AcoefV, BcoefU, BcoefV, &
    51        ps, u1, v1, &
     51       ps, u1, v1, gustiness, &
    5252       radsol, snow, agesno, &
    5353       qsurf, evap, fluxsens, fluxlat, flux_u1, flux_v1, &
    … …  
    6565
    6666    INCLUDE "YOMCST.h"
     67    INCLUDE "clesphys.h"
    6768!   
    6869! Input arguments 
    … …  
    7778    REAL, DIMENSION(klon), INTENT(IN)        :: fder_old
    7879    REAL, DIMENSION(klon), INTENT(IN)        :: p1lay
    79     REAL, DIMENSION(klon), INTENT(IN)        :: cdragh, cdragm
     80    REAL, DIMENSION(klon), INTENT(IN)        :: cdragh, cdragq, cdragm
    8081    REAL, DIMENSION(klon), INTENT(IN)        :: precip_rain, precip_snow
    8182    REAL, DIMENSION(klon), INTENT(IN)        :: temp_air, spechum
    … …  
    8384    REAL, DIMENSION(klon), INTENT(IN)        :: AcoefU, AcoefV, BcoefU, BcoefV
    8485    REAL, DIMENSION(klon), INTENT(IN)        :: ps
    85     REAL, DIMENSION(klon), INTENT(IN)        :: u1, v1
     86    REAL, DIMENSION(klon), INTENT(IN)        :: u1, v1, gustiness
    8687
    8788! In/Output arguments
    … …  
    136137
    137138    CALL calcul_fluxs(knon, is_oce, dtime, &
    138          tsurf_cpl, p1lay, cal, beta, cdragh, ps, &
     139         tsurf_cpl, p1lay, cal, beta, cdragh, cdragq, ps, &
    139140         precip_rain, precip_snow, snow, qsurf,  &
    140          radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, &
    141          AcoefH, AcoefQ, BcoefH, BcoefQ, &
     141         radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, gustiness, &
     142         f_qsat_oce,AcoefH, AcoefQ, BcoefH, BcoefQ, &
    142143         tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l)
    143144   
    144145! - Flux calculation at first modele level for U and V
    145146    CALL calcul_flux_wind(knon, dtime, &
    146          u0_cpl, v0_cpl, u1, v1, cdragm, &
     147         u0_cpl, v0_cpl, u1, v1, gustiness, cdragm, &
    147148         AcoefU, AcoefV, BcoefU, BcoefV, &
    148149         p1lay, temp_air, &
    … …  
    185186       AcoefH, AcoefQ, BcoefH, BcoefQ, &
    186187       AcoefU, AcoefV, BcoefU, BcoefV, &
    187        ps, u1, v1, pctsrf, &
     188       ps, u1, v1, gustiness, pctsrf, &
    188189       radsol, snow, qsurf, &
    189190       alb1_new, alb2_new, evap, fluxsens, fluxlat, flux_u1, flux_v1, &
    … …  
    200201
    201202    INCLUDE "YOMCST.h"
     203    INCLUDE "clesphys.h"
    202204
    203205! Input arguments
    … …  
    219221    REAL, DIMENSION(klon), INTENT(IN)        :: AcoefU, AcoefV, BcoefU, BcoefV
    220222    REAL, DIMENSION(klon), INTENT(IN)        :: ps
    221     REAL, DIMENSION(klon), INTENT(IN)        :: u1, v1
     223    REAL, DIMENSION(klon), INTENT(IN)        :: u1, v1, gustiness
    222224    REAL, DIMENSION(klon,nbsrf), INTENT(IN)  :: pctsrf
    223225
    … …  
    279281
    280282    CALL calcul_fluxs(knon, is_sic, dtime, &
    281          tsurf_cpl, p1lay, cal, beta, cdragh, ps, &
     283         tsurf_cpl, p1lay, cal, beta, cdragh, cdragh, ps, &
    282284         precip_rain, precip_snow, snow, qsurf,  &
    283          radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, &
    284          AcoefH, AcoefQ, BcoefH, BcoefQ, &
     285         radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, gustiness, &
     286         f_qsat_oce,AcoefH, AcoefQ, BcoefH, BcoefQ, &
    285287         tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l)
    286288
    … …  
    288290! - Flux calculation at first modele level for U and V
    289291    CALL calcul_flux_wind(knon, dtime, &
    290          u0, v0, u1, v1, cdragm, &
     292         u0, v0, u1, v1, gustiness, cdragm, &
    291293         AcoefU, AcoefV, BcoefU, BcoefV, &
    292294         p1lay, temp_air, &

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

    r1999 r2298  
    1313  SUBROUTINE ocean_forced_noice( &
    1414       itime, dtime, jour, knon, knindex, &
    15        p1lay, cdragh, cdragm, precip_rain, precip_snow, &
     15       p1lay, cdragh, cdragq, cdragm, precip_rain, precip_snow, &
    1616       temp_air, spechum, &
    1717       AcoefH, AcoefQ, BcoefH, BcoefQ, &
    1818       AcoefU, AcoefV, BcoefU, BcoefV, &
    19        ps, u1, v1, &
     19       ps, u1, v1, gustiness, &
    2020       radsol, snow, agesno, &
    2121       qsurf, evap, fluxsens, fluxlat, flux_u1, flux_v1, &
    … …  
    3333    USE indice_sol_mod
    3434    INCLUDE "YOMCST.h"
     35    INCLUDE "clesphys.h"
     36
    3537
    3638! Input arguments
    … …  
    4042    REAL, INTENT(IN)                         :: dtime
    4143    REAL, DIMENSION(klon), INTENT(IN)        :: p1lay
    42     REAL, DIMENSION(klon), INTENT(IN)        :: cdragh, cdragm
     44    REAL, DIMENSION(klon), INTENT(IN)        :: cdragh, cdragq, cdragm
    4345    REAL, DIMENSION(klon), INTENT(IN)        :: precip_rain, precip_snow
    4446    REAL, DIMENSION(klon), INTENT(IN)        :: temp_air, spechum
    … …  
    4648    REAL, DIMENSION(klon), INTENT(IN)        :: AcoefU, AcoefV, BcoefU, BcoefV
    4749    REAL, DIMENSION(klon), INTENT(IN)        :: ps
    48     REAL, DIMENSION(klon), INTENT(IN)        :: u1, v1
     50    REAL, DIMENSION(klon), INTENT(IN)        :: u1, v1, gustiness
    4951
    5052! In/Output arguments
    … …  
    109111! Calcul de tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l and qsurf
    110112    CALL calcul_fluxs(knon, is_oce, dtime, &
    111          tsurf_lim, p1lay, cal, beta, cdragh, ps, &
     113         tsurf_lim, p1lay, cal, beta, cdragh, cdragq, ps, &
    112114         precip_rain, precip_snow, snow, qsurf,  &
    113          radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, &
    114          AcoefH, AcoefQ, BcoefH, BcoefQ, &
     115         radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, gustiness, &
     116         f_qsat_oce,AcoefH, AcoefQ, BcoefH, BcoefQ, &
    115117         tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l)
    116118
    117119! - Flux calculation at first modele level for U and V
    118120    CALL calcul_flux_wind(knon, dtime, &
    119          u0, v0, u1, v1, cdragm, &
     121         u0, v0, u1, v1, gustiness, cdragm, &
    120122         AcoefU, AcoefV, BcoefU, BcoefV, &
    121123         p1lay, temp_air, &
    … …  
    131133       AcoefH, AcoefQ, BcoefH, BcoefQ, &
    132134       AcoefU, AcoefV, BcoefU, BcoefV, &
    133        ps, u1, v1, &
     135       ps, u1, v1, gustiness, &
    134136       radsol, snow, qsol, agesno, tsoil, &
    135137       qsurf, alb1_new, alb2_new, evap, fluxsens, fluxlat, flux_u1, flux_v1, &
    … …  
    165167    REAL, DIMENSION(klon), INTENT(IN)    :: AcoefU, AcoefV, BcoefU, BcoefV
    166168    REAL, DIMENSION(klon), INTENT(IN)    :: ps
    167     REAL, DIMENSION(klon), INTENT(IN)    :: u1, v1
     169    REAL, DIMENSION(klon), INTENT(IN)    :: u1, v1, gustiness
    168170
    169171! In/Output arguments
    … …  
    231233    v1_lay(:) = v1(:) - v0(:)
    232234    CALL calcul_fluxs(knon, is_sic, dtime, &
    233          tsurf_tmp, p1lay, cal, beta, cdragh, ps, &
     235         tsurf_tmp, p1lay, cal, beta, cdragh, cdragh, ps, &
    234236         precip_rain, precip_snow, snow, qsurf,  &
    235          radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, &
    236          AcoefH, AcoefQ, BcoefH, BcoefQ, &
     237         radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, gustiness, &
     238         f_qsat_oce,AcoefH, AcoefQ, BcoefH, BcoefQ, &
    237239         tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l)
    238240
    239241! - Flux calculation at first modele level for U and V
    240242    CALL calcul_flux_wind(knon, dtime, &
    241          u0, v0, u1, v1, cdragm, &
     243         u0, v0, u1, v1, gustiness, cdragm, &
    242244         AcoefU, AcoefV, BcoefU, BcoefV, &
    243245         p1lay, temp_air, &

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

    r2220 r2298  
    216216  SUBROUTINE ocean_slab_noice( &
    217217       itime, dtime, jour, knon, knindex, &
    218        p1lay, cdragh, cdragm, precip_rain, precip_snow, temp_air, spechum, &
     218       p1lay, cdragh, cdragq, cdragm, precip_rain, precip_snow, temp_air, spechum, &
    219219       AcoefH, AcoefQ, BcoefH, BcoefQ, &
    220220       AcoefU, AcoefV, BcoefU, BcoefV, &
    221        ps, u1, v1, tsurf_in, &
     221       ps, u1, v1, gustiness, tsurf_in, &
    222222       radsol, snow, &
    223223       qsurf, evap, fluxsens, fluxlat, flux_u1, flux_v1, &
    … …  
    227227
    228228    INCLUDE "iniprint.h"
     229    INCLUDE "clesphys.h"
    229230
    230231! Input arguments
    … …  
    236237    REAL, INTENT(IN)                     :: dtime
    237238    REAL, DIMENSION(klon), INTENT(IN)    :: p1lay
    238     REAL, DIMENSION(klon), INTENT(IN)    :: cdragh, cdragm
     239    REAL, DIMENSION(klon), INTENT(IN)    :: cdragh, cdragq, cdragm
    239240    REAL, DIMENSION(klon), INTENT(IN)    :: precip_rain, precip_snow
    240241    REAL, DIMENSION(klon), INTENT(IN)    :: temp_air, spechum
    … …  
    242243    REAL, DIMENSION(klon), INTENT(IN)    :: AcoefU, AcoefV, BcoefU, BcoefV
    243244    REAL, DIMENSION(klon), INTENT(IN)    :: ps
    244     REAL, DIMENSION(klon), INTENT(IN)    :: u1, v1
     245    REAL, DIMENSION(klon), INTENT(IN)    :: u1, v1, gustiness
    245246    REAL, DIMENSION(klon), INTENT(IN)    :: tsurf_in
    246247    REAL, DIMENSION(klon), INTENT(INOUT) :: radsol
    … …  
    287288
    288289    CALL calcul_fluxs(knon, is_oce, dtime, &
    289          tsurf_in, p1lay, cal, beta, cdragh, ps, &
     290         tsurf_in, p1lay, cal, beta, cdragh, cdragq, ps, &
    290291         precip_rain, precip_snow, snow, qsurf,  &
    291          radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, &
    292          AcoefH, AcoefQ, BcoefH, BcoefQ, &
     292         radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, gustiness, &
     293         f_qsat_oce,AcoefH, AcoefQ, BcoefH, BcoefQ, &
    293294         tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l)
    294295
    295296! - Flux calculation at first modele level for U and V
    296297    CALL calcul_flux_wind(knon, dtime, &
    297          u0, v0, u1, v1, cdragm, &
     298         u0, v0, u1, v1, gustiness, cdragm, &
    298299         AcoefU, AcoefV, BcoefU, BcoefV, &
    299300         p1lay, temp_air, &
    … …  
    398399       AcoefH, AcoefQ, BcoefH, BcoefQ, &
    399400       AcoefU, AcoefV, BcoefU, BcoefV, &
    400        ps, u1, v1, &
     401       ps, u1, v1, gustiness, &
    401402       radsol, snow, qsurf, qsol, agesno, &
    402403       alb1_new, alb2_new, evap, fluxsens, fluxlat, flux_u1, flux_v1, &
    … …  
    406407
    407408   INCLUDE "YOMCST.h"
     409   INCLUDE "clesphys.h"
    408410
    409411! Input arguments
    … …  
    420422    REAL, DIMENSION(klon), INTENT(IN)    :: AcoefU, AcoefV, BcoefU, BcoefV
    421423    REAL, DIMENSION(klon), INTENT(IN)    :: ps
    422     REAL, DIMENSION(klon), INTENT(IN)    :: u1, v1
     424    REAL, DIMENSION(klon), INTENT(IN)    :: u1, v1, gustiness
    423425    REAL, DIMENSION(klon), INTENT(IN)    :: swnet
    424426
    … …  
    498500! calcul_fluxs (sens, lat etc)
    499501    CALL calcul_fluxs(knon, is_sic, dtime, &
    500         tsurf_in, p1lay, cal, beta, cdragh, ps, &
     502        tsurf_in, p1lay, cal, beta, cdragh, cdragh, ps, &
    501503        precip_rain, precip_snow, snow, qsurf,  &
    502         radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, &
    503         AcoefH, AcoefQ, BcoefH, BcoefQ, &
     504        radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, gustiness, &
     505        f_qsat_oce,AcoefH, AcoefQ, BcoefH, BcoefQ, &
    504506        tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l)
    505507    DO i=1,knon
    … …  
    509511! calcul_flux_wind
    510512    CALL calcul_flux_wind(knon, dtime, &
    511          u0, v0, u1, v1, cdragm, &
     513         u0, v0, u1, v1, gustiness, cdragm, &
    512514         AcoefU, AcoefV, BcoefU, BcoefV, &
    513515         p1lay, temp_air, &

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

    r2258 r2298  
    2929
    3030! Declaration of variables saved in restart file
    31   REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE     :: qsol   ! water height in the soil (mm)
    32   !$OMP THREADPRIVATE(qsol)
    3331  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE     :: fder   ! flux drift
    3432  !$OMP THREADPRIVATE(fder)
    … …  
    3735  REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE, SAVE   :: qsurf  ! humidity at surface
    3836  !$OMP THREADPRIVATE(qsurf)
    39   REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE, SAVE   :: evap   ! evaporation at surface
    40   !$OMP THREADPRIVATE(evap)
    41   REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE, SAVE   :: rugos  ! rugosity at surface (m)
    42   !$OMP THREADPRIVATE(rugos)
    43   REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE, SAVE   :: agesno ! age of snow at surface
    44   !$OMP THREADPRIVATE(agesno)
    45 ! Correction pour le cas AMMA (PRIVATE)
    4637  REAL, ALLOCATABLE, DIMENSION(:,:,:), SAVE :: ftsoil ! soil temperature
    4738  !$OMP THREADPRIVATE(ftsoil)
    … …  
    5142!****************************************************************************************
    5243!
    53   SUBROUTINE pbl_surface_init(qsol_rst, fder_rst, snow_rst, qsurf_rst,&
    54        evap_rst, rugos_rst, agesno_rst, ftsoil_rst)
     44  SUBROUTINE pbl_surface_init(fder_rst, snow_rst, qsurf_rst, ftsoil_rst)
    5545
    5646! This routine should be called after the restart file has been read.
    … …  
    6555! Input variables
    6656!****************************************************************************************
    67     REAL, DIMENSION(klon), INTENT(IN)                 :: qsol_rst
    6857    REAL, DIMENSION(klon), INTENT(IN)                 :: fder_rst
    6958    REAL, DIMENSION(klon, nbsrf), INTENT(IN)          :: snow_rst
    7059    REAL, DIMENSION(klon, nbsrf), INTENT(IN)          :: qsurf_rst
    71     REAL, DIMENSION(klon, nbsrf), INTENT(IN)          :: evap_rst
    72     REAL, DIMENSION(klon, nbsrf), INTENT(IN)          :: rugos_rst
    73     REAL, DIMENSION(klon, nbsrf), INTENT(IN)          :: agesno_rst
    7460    REAL, DIMENSION(klon, nsoilmx, nbsrf), INTENT(IN) :: ftsoil_rst
    7561
    … …  
    8672!
    8773!****************************************************************************************   
    88     ALLOCATE(qsol(klon), stat=ierr)
    89     IF (ierr /= 0) CALL abort_gcm('pbl_surface_init', 'pb in allocation',1)
    90 
    9174    ALLOCATE(fder(klon), stat=ierr)
    9275    IF (ierr /= 0) CALL abort_gcm('pbl_surface_init', 'pb in allocation',1)
    … …  
    9881    IF (ierr /= 0) CALL abort_gcm('pbl_surface_init', 'pb in allocation',1)
    9982
    100     ALLOCATE(evap(klon,nbsrf), stat=ierr)
    101     IF (ierr /= 0) CALL abort_gcm('pbl_surface_init', 'pb in allocation',1)
    102 
    103     ALLOCATE(rugos(klon,nbsrf), stat=ierr)
    104     IF (ierr /= 0) CALL abort_gcm('pbl_surface_init', 'pb in allocation',1)
    105 
    106     ALLOCATE(agesno(klon,nbsrf), stat=ierr)
    107     IF (ierr /= 0) CALL abort_gcm('pbl_surface_init', 'pb in allocation',1)
    108 
    10983    ALLOCATE(ftsoil(klon,nsoilmx,nbsrf), stat=ierr)
    11084    IF (ierr /= 0) CALL abort_gcm('pbl_surface_init', 'pb in allocation',1)
    11185
    11286
    113     qsol(:)       = qsol_rst(:)
    11487    fder(:)       = fder_rst(:)
    11588    snow(:,:)     = snow_rst(:,:)
    11689    qsurf(:,:)    = qsurf_rst(:,:)
    117     evap(:,:)     = evap_rst(:,:)
    118     rugos(:,:)    = rugos_rst(:,:)
    119     agesno(:,:)   = agesno_rst(:,:)
    12090    ftsoil(:,:,:) = ftsoil_rst(:,:,:)
    12191
    … …  
    174144       zsig,      lwdown_m,  pphi,     cldt,          &
    175145       rain_f,    snow_f,    solsw_m,  sollw_m,       &
     146       gustiness,                                     &
    176147       t,         q,         u,        v,             &
    177148!!! nrlmd+jyg le 02/05/2011 et le 20/02/2012
    … …  
    181152!!!
    182153       pplay,     paprs,     pctsrf,                  &
    183 !albedo SB >>>
    184 !       ts,        alb1, alb2,ustar, u10m, v10m,wstar, &
    185154       ts,SFRWL,   alb_dir, alb_dif,ustar, u10m, v10m,wstar, &
    186 !albedo SB <<<
    187155       cdragh,    cdragm,   zu1,    zv1,              &
    188 !albedo SB >>>
    189 !       alb1_m,    alb2_m,    zxsens,   zxevap,        &
    190156       alb_dir_m,    alb_dif_m,  zxsens,   zxevap,    &
    191 !albedo SB <<<
    192157       alb3_lic,  runoff,    snowhgt,   qsnow,     to_ice,    sissnow,  &
    193158       zxtsol,    zxfluxlat, zt2m,     qsat2m,        &
    … …  
    204169!!!
    205170       zcoefh,    zcoefm,    slab_wfbils,             &
    206        qsol_d,    zq2m,      s_pblh,   s_plcl,        &
     171       qsol,    zq2m,      s_pblh,   s_plcl,        &
    207172!!!
    208173!!! jyg le 08/02/2012
    … …  
    211176       s_capCL,   s_oliqCL,  s_cteiCL, s_pblT,        &
    212177       s_therm,   s_trmb1,   s_trmb2,  s_trmb3,       &
    213        zxrugs,zustar,zu10m,  zv10m,    fder_print,    &
     178       zustar,zu10m,  zv10m,    fder_print,    &
    214179       zxqsurf,   rh2m,      zxfluxu,  zxfluxv,       &
    215        rugos_d,   agesno_d,  sollw,    solsw,         &
    216        d_ts,      evap_d,    fluxlat,  t2m,           &
     180       z0m, z0h,   agesno,  sollw,    solsw,         &
     181       d_ts,      evap,    fluxlat,  t2m,           &
    217182       wfbils,    wfbilo,    flux_t,   flux_u, flux_v,&
    218183       dflux_t,   dflux_q,   zxsnow,                  &
    … …  
    263228! pplay----input-R- pression au milieu de couche (Pa)
    264229! rlat-----input-R- latitude en degree
    265 ! rugos----input-R- longeur de rugosite (en m)
     230! z0m, z0h ----input-R- longeur de rugosite (en m)
    266231! Martin
    267232! zsig-----input-R- slope
    … …  
    334299    REAL, DIMENSION(klon),        INTENT(IN)        :: zsig    ! slope
    335300    REAL, DIMENSION(klon),        INTENT(IN)        :: lwdown_m ! downward longwave radiation at mean s   
     301    REAL, DIMENSION(klon),        INTENT(IN)        :: gustiness ! gustiness
     302
    336303    REAL, DIMENSION(klon),        INTENT(IN)        :: cldt    ! total cloud fraction
    337304    REAL, DIMENSION(klon,klev),   INTENT(IN)        :: pphi    ! geopotential (m2/s2)
    … …  
    356323                                                                   !wake and off-wake regions
    357324!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
    360325    REAL, DIMENSIOn(6),intent(in) :: SFRWL
    361326    REAL, DIMENSION(klon, nsw, nbsrf), INTENT(INOUT)     :: alb_dir,alb_dif
    … …  
    382347    REAL, DIMENSION(klon),        INTENT(OUT)       :: zv1        ! v wind speed in first layer
    383348!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
    388349    REAL, DIMENSION(klon, nsw),        INTENT(OUT)       :: alb_dir_m,alb_dif_m
    389350!albedo SB <<<
    … …  
    434395!!!
    435396    REAL, DIMENSION(klon),        INTENT(OUT)       :: slab_wfbils! heat balance at surface only for slab at ocean points
    436     REAL, DIMENSION(klon),        INTENT(OUT)       :: qsol_d     ! water height in the soil (mm)
     397    REAL, DIMENSION(klon),        INTENT(OUT)       :: qsol     ! water height in the soil (mm)
    437398    REAL, DIMENSION(klon),        INTENT(OUT)       :: zq2m       ! water vapour at 2m, mean for each grid point
    438399    REAL, DIMENSION(klon),        INTENT(OUT)       :: s_pblh     ! height of the planetary boundary layer(HPBL)
    … …  
    454415    REAL, DIMENSION(klon),        INTENT(OUT)       :: s_trmb2    ! inhibition, mean for each grid point
    455416    REAL, DIMENSION(klon),        INTENT(OUT)       :: s_trmb3    ! point Omega, mean for each grid point
    456     REAL, DIMENSION(klon),        INTENT(OUT)       :: zxrugs     ! rugosity at surface (m), mean for each grid point
    457417    REAL, DIMENSION(klon),        INTENT(OUT)       :: zustar     ! u*
    458418    REAL, DIMENSION(klon),        INTENT(OUT)       :: zu10m      ! u speed at 10m, mean for each grid point
    … …  
    463423    REAL, DIMENSION(klon, klev),  INTENT(OUT)       :: zxfluxu    ! u wind tension, mean for each grid point
    464424    REAL, DIMENSION(klon, klev),  INTENT(OUT)       :: zxfluxv    ! v wind tension, mean for each grid point
    465     REAL, DIMENSION(klon, nbsrf), INTENT(OUT)       :: rugos_d    ! rugosity length (m)
    466     REAL, DIMENSION(klon, nbsrf), INTENT(OUT)       :: agesno_d   ! age of snow at surface
     425    REAL, DIMENSION(klon, nbsrf+1), INTENT(INOUT)     :: z0m,z0h      ! rugosity length (m)
     426    REAL, DIMENSION(klon, nbsrf), INTENT(INOUT)       :: agesno   ! age of snow at surface
    467427    REAL, DIMENSION(klon, nbsrf), INTENT(OUT)       :: solsw      ! net shortwave radiation at surface
    468428    REAL, DIMENSION(klon, nbsrf), INTENT(OUT)       :: sollw      ! net longwave radiation at surface
    469429    REAL, DIMENSION(klon, nbsrf), INTENT(OUT)       :: d_ts       ! change in temperature at surface
    470     REAL, DIMENSION(klon, nbsrf), INTENT(OUT)       :: evap_d     ! evaporation at surface
     430    REAL, DIMENSION(klon, nbsrf), INTENT(INOUT)       :: evap     ! evaporation at surface
    471431    REAL, DIMENSION(klon, nbsrf), INTENT(OUT)       :: fluxlat    ! latent flux
    472432    REAL, DIMENSION(klon, nbsrf), INTENT(OUT)       :: t2m        ! temperature at 2 meter height
    … …  
    519479    REAL                               :: f1 ! fraction de longeurs visibles parmi tout SW intervalle
    520480    REAL, DIMENSION(klon)              :: r_co2_ppm     ! taux CO2 atmosphere
    521     REAL, DIMENSION(klon)              :: yts, yrugos, ypct, yz0_new
     481    REAL, DIMENSION(klon)              :: yts, yz0m, yz0h, ypct
    522482!albedo SB >>>
    523 !   REAL, DIMENSION(klon)              :: yalb, yalb1, yalb2
    524483    REAL, DIMENSION(klon)              :: yalb,yalb_vis
    525484!albedo SB <<<
    … …  
    559518    REAL, DIMENSION(klon)              :: AcoefU, AcoefV, BcoefU, BcoefV
    560519    REAL, DIMENSION(klon)              :: ypsref
    561     REAL, DIMENSION(klon)              :: yevap, ytsurf_new, yalb1_new, yalb2_new, yalb3_new
     520    REAL, DIMENSION(klon)              :: yevap, ytsurf_new, yalb3_new
    562521!albedo SB >>>
    563522    REAL, DIMENSION(klon,nsw)          :: yalb_dir_new, yalb_dif_new
    … …  
    795754    REAL, DIMENSION(klon, nbsrf)       :: alb          ! mean albedo for whole SW interval
    796755    REAL, DIMENSION(klon)              :: ylwdown      ! jg : temporary (ysollwdown)
     756    REAL, DIMENSION(klon)              :: ygustiness      ! jg : temporary (ysollwdown)
    797757
    798758    REAL                               :: zx_qs1, zcor1, zdelta1
    … …  
    823783
    824784    IF (first_call) THEN
     785       print*,'PBL SURFACE AVEC GUSTINESS'
    825786       first_call=.FALSE.
    826787     
    … …  
    877838 zu1(:)=0. ; zv1(:)=0.
    878839!albedo SB >>>
    879 ! alb1_m(:)=0. ; alb2_m(:)=0. ; alb3_lic(:)=0.
    880840  alb_dir_m=0. ; alb_dif_m=0. ; alb3_lic(:)=0.
    881841!albedo SB <<<
    … …  
    890850 kh(:)=0. ; kh_x(:)=0. ; kh_w(:)=0.
    891851 slab_wfbils(:)=0.
    892  qsol_d(:)=0.
    893852 s_pblh(:)=0. ; s_pblh_x(:)=0. ; s_pblh_w(:)=0.
    894853 s_plcl(:)=0. ; s_plcl_x(:)=0. ; s_plcl_w(:)=0.
    … …  
    896855 s_therm(:)=0.
    897856 s_trmb1(:)=0. ; s_trmb2(:)=0. ; s_trmb3(:)=0.
    898  zxrugs(:)=0. ; zustar(:)=0.
     857 zustar(:)=0.
    899858 zu10m(:)=0. ; zv10m(:)=0.
    900859 fder_print(:)=0.
    901860 zxqsurf(:)=0.
    902861 zxfluxu(:,:)=0. ; zxfluxv(:,:)=0.
    903  rugos_d(:,:)=0. ; agesno_d(:,:)=0.
    904862 solsw(:,:)=0. ; sollw(:,:)=0.
    905863 d_ts(:,:)=0.
    906  evap_d(:,:)=0.
     864 evap(:,:)=0.
    907865 fluxlat(:,:)=0.
    908866 wfbils(:,:)=0. ; wfbilo(:,:)=0.
    … …  
    943901!!    cdragh = 0.0  ; cdragm = 0.0     ; dflux_t = 0.0   ; dflux_q = 0.0
    944902    ypct = 0.0    ; yts = 0.0        ; ysnow = 0.0
    945 !!    zv1 = 0.0     ; yqsurf = 0.0     ; yalb1 = 0.0     ; yalb2 = 0.0   
     903!!    zv1 = 0.0     ; yqsurf = 0.0
    946904!albedo SB >>>
    947 !    yqsurf = 0.0  ; yalb1 = 0.0      ; yalb2 = 0.0   
    948905    yqsurf = 0.0  ; yalb = 0.0 ; yalb_vis = 0.0
    949906!albedo SB <<<
    950907    yrain_f = 0.0 ; ysnow_f = 0.0    ; yfder = 0.0     ; ysolsw = 0.0   
    951     ysollw = 0.0  ; yrugos = 0.0     ; yu1 = 0.0   
     908    ysollw = 0.0  ; yz0m = 0.0 ; yz0h = 0.0    ; yu1 = 0.0   
    952909    yv1 = 0.0     ; ypaprs = 0.0     ; ypplay = 0.0
    953910    ydelp = 0.0   ; yu = 0.0         ; yv = 0.0        ; yt = 0.0         
    … …  
    10771034!****************************************************************************************
    10781035
    1079     zxrugs(:) = 0.0
    10801036    DO nsrf = 1, nbsrf
    10811037       DO i = 1, klon
    1082           rugos(i,nsrf) = MAX(rugos(i,nsrf),0.000015)
    1083           zxrugs(i) = zxrugs(i) + rugos(i,nsrf)*pctsrf(i,nsrf)
     1038          z0m(i,nsrf) = MAX(z0m(i,nsrf),z0min)
     1039          z0h(i,nsrf) = MAX(z0h(i,nsrf),z0min)
    10841040       ENDDO
    10851041    ENDDO
    … …  
    10871043! Mean calculations of albedo
    10881044!
    1089 ! Albedo at sub-surface
    1090 ! * alb1 : albedo in visible SW interval
    1091 ! * alb2 : albedo in near infrared SW interval
    10921045! * alb  : mean albedo for whole SW interval
    10931046!
    10941047! Mean albedo for grid point
    1095 ! * alb1_m : albedo in visible SW interval
    1096 ! * alb2_m : albedo in near infrared SW interval
    10971048! * alb_m  : mean albedo at whole SW interval
    1098 
    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
    11081049
    11091050    alb_dir_m(:,:) = 0.0
    … …  
    11231064!    f1 = 1    ! put f1=1 to recreate old calculations
    11241065
    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 
    11361066!f1 is already included with SFRWL values in each surf files
    11371067    alb=0.0
    … …  
    11771107       ENDDO
    11781108    ENDDO
    1179 
    11801109
    11811110!****************************************************************************************
    … …  
    12311160          yalb(j)    = alb(i,nsrf)
    12321161!albedo SB >>>
    1233 !         yalb1(j)   = alb1(i,nsrf)
    1234 !         yalb2(j)   = alb2(i,nsrf)
    12351162          yalb_vis(j) = alb_dir(i,1,nsrf)
    12361163          if(nsw==6)then
    … …  
    12441171          yfder(j)   = fder(i)
    12451172          ylwdown(j) = lwdown_m(i)
     1173          ygustiness(j) = gustiness(i)
    12461174          ysolsw(j)  = solsw(i,nsrf)
    12471175          ysollw(j)  = sollw(i,nsrf)
    1248           yrugos(j)  = rugos(i,nsrf)
     1176          yz0m(j)  = z0m(i,nsrf)
     1177          yz0h(j)  = z0h(i,nsrf)
    12491178          yrugoro(j) = rugoro(i)
    12501179          yu1(j)     = u(i,1)
    … …  
    13771306        CALL cdrag(knon, nsrf, &
    13781307            speed, yt(:,1), yq(:,1), zgeo1, ypaprs(:,1),&
    1379             yts, yqsurf, yrugos, &
     1308            yts, yqsurf, yz0m, yz0h, &
    13801309            ycdragm, ycdragh, zri1, pref )
    13811310
    … …  
    14081337        CALL cdrag(knon, nsrf, &
    14091338            speed_x, yt_x(:,1), yq_x(:,1), zgeo1_x, ypaprs(:,1),&
    1410             yts_x, yqsurf, yrugos, &
     1339            yts_x, yqsurf, yz0m, yz0h, &
    14111340            ycdragm_x, ycdragh_x, zri1_x, pref_x )
    14121341
    … …  
    14221351        IF (prt_level >=10) print *,'clcdrag -> ycdragh_x ', ycdragh_x
    14231352!
    1424         CALL clcdrag( knon, nsrf, ypaprs, ypplay, &
    1425             yu_w(:,1), yv_w(:,1), yt_w(:,1), yq_w(:,1), &
    1426             yts_w, yqsurf, yrugos, &
    1427             ycdragm_w, ycdragh_w )
     1353! Faire disparaitre les lignes commentees fin 2015 (le temps des tests)
     1354!        CALL clcdrag( knon, nsrf, ypaprs, ypplay, &
     1355!            yu_w(:,1), yv_w(:,1), yt_w(:,1), yq_w(:,1), &
     1356!            yts_w, yqsurf, yz0m, &
     1357!            ycdragm_w, ycdragh_w )
     1358! Fuxing WANG, 04/03/2015, replace the clcdrag by the merged version: cdrag
     1359        DO i = 1, knon
     1360           zgeo1_w(i) = RD * yt_w(i,1) / (0.5*(ypaprs(i,1)+ypplay(i,1))) &
     1361                * (ypaprs(i,1)-ypplay(i,1))
     1362           speed_w(i) = SQRT(yu_w(i,1)**2+yv_w(i,1)**2)
     1363        END DO
     1364        CALL cdrag(knon, nsrf, &
     1365            speed_w, yt_w(:,1), yq_w(:,1), zgeo1_w, ypaprs(:,1),&
     1366            yts_w, yqsurf, yz0m, yz0h, &
     1367            ycdragm_w, ycdragh_w, zri1_w, pref_w )
     1368
    14281369! --- special Dice. JYG+MPL 25112013
    14291370        IF (ok_prescr_ust) then
    … …  
    14561397      print *,' args coef_diff_turb: yt ',  yt 
    14571398      print *,' args coef_diff_turb: yts ', yts 
    1458       print *,' args coef_diff_turb: yrugos ', yrugos 
     1399      print *,' args coef_diff_turb: yz0m ', yz0m 
    14591400      print *,' args coef_diff_turb: yqsurf ', yqsurf 
    14601401      print *,' args coef_diff_turb: ycdragm ', ycdragm
    … …  
    14631404       ENDIF
    14641405        CALL coef_diff_turb(dtime, nsrf, knon, ni,  &
    1465             ypaprs, ypplay, yu, yv, yq, yt, yts, yrugos, yqsurf, ycdragm, &
     1406            ypaprs, ypplay, yu, yv, yq, yt, yts, yqsurf, ycdragm, &
    14661407            ycoefm, ycoefh, ytke)
    14671408       IF (iflag_pbl>=20.AND.iflag_pbl<30) THEN
    … …  
    14841425      print *,' args coef_diff_turb: yt_x ',  yt_x 
    14851426      print *,' args coef_diff_turb: yts_x ', yts_x 
    1486       print *,' args coef_diff_turb: yrugos ', yrugos 
    14871427      print *,' args coef_diff_turb: yqsurf ', yqsurf 
    14881428      print *,' args coef_diff_turb: ycdragm_x ', ycdragm_x
    … …  
    14911431       ENDIF
    14921432        CALL coef_diff_turb(dtime, nsrf, knon, ni,  &
    1493             ypaprs, ypplay, yu_x, yv_x, yq_x, yt_x, yts_x, yrugos, yqsurf, ycdragm_x, &
     1433            ypaprs, ypplay, yu_x, yv_x, yq_x, yt_x, yts_x, yqsurf, ycdragm_x, &
    14941434            ycoefm_x, ycoefh_x, ytke_x)
    14951435       IF (iflag_pbl>=20.AND.iflag_pbl<30) THEN
    … …  
    15111451      print *,' args coef_diff_turb: yt_w ',  yt_w 
    15121452      print *,' args coef_diff_turb: yts_w ', yts_w 
    1513       print *,' args coef_diff_turb: yrugos ', yrugos 
    15141453      print *,' args coef_diff_turb: yqsurf ', yqsurf 
    15151454      print *,' args coef_diff_turb: ycdragm_w ', ycdragm_w
    … …  
    15181457       ENDIF
    15191458        CALL coef_diff_turb(dtime, nsrf, knon, ni,  &
    1520             ypaprs, ypplay, yu_w, yv_w, yq_w, yt_w, yts_w, yrugos, yqsurf, ycdragm_w, &
     1459            ypaprs, ypplay, yu_w, yv_w, yq_w, yt_w, yts_w, yqsurf, ycdragm_w, &
    15211460            ycoefm_w, ycoefh_w, ytke_w)
    15221461       IF (iflag_pbl>=20.AND.iflag_pbl<30) THEN
    … …  
    17791718          CALL stdlevvar(klon, knon, is_ter, zxli, &
    17801719               yu(:,1), yv(:,1), yt(:,1), yq(:,1), zgeo1, &
    1781                yts, yqsurf, yrugos, ypaprs(:,1), ypplay(:,1), &
     1720               yts, yqsurf, yz0m, yz0h, ypaprs(:,1), ypplay(:,1), &
    17821721               yt2m, yq2m, yt10m, yq10m, yu10m, yustar)
    17831722         
    … …  
    18011740               AcoefH, AcoefQ, BcoefH, BcoefQ, &
    18021741               AcoefU, AcoefV, BcoefU, BcoefV, &
    1803                ypsref, yu1, yv1, yrugoro, pctsrf, &
     1742               ypsref, yu1, yv1, ygustiness, yrugoro, pctsrf, &
    18041743               ylwdown, yq2m, yt2m, &
    18051744               ysnow, yqsol, yagesno, ytsoil, &
    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 <<<
     1745               yz0m, yz0h, SFRWL, yalb_dir_new, yalb_dif_new, yevap, yfluxsens,yfluxlat,&
    18101746               yqsurf, ytsurf_new, y_dflux_t, y_dflux_q, &
    18111747               y_flux_u1, y_flux_v1 )
    … …  
    18181754!         ytsoil(:,:)=300.
    18191755!         yz0_new(:)=0.001
    1820 !         yalb1_new(:)=0.22
    1821 !         yalb2_new(:)=0.22
    18221756!         yevap(:)=flat/RLVTT
    18231757!         yfluxlat(:)=-flat
    … …  
    18411775               AcoefH, AcoefQ, BcoefH, BcoefQ, &
    18421776               AcoefU, AcoefV, BcoefU, BcoefV, &
    1843                ypsref, yu1, yv1, yrugoro, pctsrf, &
     1777               ypsref, yu1, yv1, ygustiness, yrugoro, pctsrf, &
    18441778               ysnow, yqsurf, yqsol, yagesno, &
    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 <<<
     1779               ytsoil, yz0m, yz0h, SFRWL, yalb_dir_new, yalb_dif_new, yevap,yfluxsens,yfluxlat, &
    18491780               ytsurf_new, y_dflux_t, y_dflux_q, &
    18501781               yzsig, ycldt, &
    … …  
    18521783               yalb3_new, yrunoff, &
    18531784               y_flux_u1, y_flux_v1)
    1854           !CALL surf_landice(itap, dtime, knon, ni, &
    1855           !     ysolsw, ysollw, yts, ypplay(:,1), &
    1856           !     ycdragh, ycdragm, yrain_f, ysnow_f, yt(:,1), yq(:,1),&
    1857           !     AcoefH, AcoefQ, BcoefH, BcoefQ, &
    1858           !     AcoefU, AcoefV, BcoefU, BcoefV, &
    1859           !     ypsref, yu1, yv1, yrugoro, pctsrf, &
    1860           !     ysnow, yqsurf, yqsol, yagesno, &
    1861           !     ytsoil, yz0_new, yalb1_new, yalb2_new, yevap, yfluxsens, yfluxlat, &
    1862           !     ytsurf_new, y_dflux_t, y_dflux_q, &
    1863           !     y_flux_u1, y_flux_v1)
    18641785
    18651786!jyg<
    … …  
    18781799         
    18791800       CASE(is_oce)
    1880 !albedo SB >>>
    1881 !          CALL surf_ocean(rlon, rlat, ysolsw, ysollw, yalb1, &
    18821801           CALL surf_ocean(rlon, rlat, ysolsw, ysollw, yalb_vis, &
    1883 !albedo SB <<<
    1884                yrugos, ywindsp, rmu0, yfder, yts, &
     1802               ywindsp, rmu0, yfder, yts, &
    18851803               itap, dtime, jour, knon, ni, &
    1886                ypplay(:,1), ycdragh, ycdragm, yrain_f, ysnow_f, yt(:,1), yq(:,1),&
     1804               ypplay(:,1), zgeo1/RG, ycdragh, ycdragm, yrain_f, ysnow_f, yt(:,1), yq(:,1),&
    18871805               AcoefH, AcoefQ, BcoefH, BcoefQ, &
    18881806               AcoefU, AcoefV, BcoefU, BcoefV, &
    1889                ypsref, yu1, yv1, yrugoro, pctsrf, &
     1807               ypsref, yu1, yv1, ygustiness, yrugoro, pctsrf, &
    18901808               ysnow, yqsurf, yagesno, &
    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 <<<
     1809               yz0m, yz0h, SFRWL,yalb_dir_new, yalb_dif_new, yevap, yfluxsens,yfluxlat,&
    18951810               ytsurf_new, y_dflux_t, y_dflux_q, slab_wfbils, &
    18961811               y_flux_u1, y_flux_v1)
    … …  
    19141829          CALL surf_seaice( &
    19151830!albedo SB >>>
    1916 !               rlon, rlat, ysolsw, ysollw, yalb1, yfder, &
    19171831               rlon, rlat, ysolsw, ysollw, yalb_vis, yfder, &
    19181832!albedo SB <<<
    … …  
    19221836               AcoefH, AcoefQ, BcoefH, BcoefQ, &
    19231837               AcoefU, AcoefV, BcoefU, BcoefV, &
    1924                ypsref, yu1, yv1, yrugoro, pctsrf, &
     1838               ypsref, yu1, yv1, ygustiness, pctsrf, &
    19251839               ysnow, yqsurf, yqsol, yagesno, ytsoil, &
    19261840!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,&
     1841               yz0m, yz0h, SFRWL, yalb_dir_new, yalb_dif_new, yevap, yfluxsens,yfluxlat,&
    19291842!albedo SB <<<
    19301843               ytsurf_new, y_dflux_t, y_dflux_q, &
    … …  
    22982211          d_ts(i,nsrf) = y_d_ts(j)
    22992212!albedo SB >>>
    2300 !          alb1(i,nsrf) = yalb1_new(j) 
    2301 !          alb2(i,nsrf) = yalb2_new(j)
    23022213          do k=1,nsw
    23032214          alb_dir(i,k,nsrf) = yalb_dir_new(j,k)
    … …  
    23072218          snow(i,nsrf) = ysnow(j) 
    23082219          qsurf(i,nsrf) = yqsurf(j)
    2309           rugos(i,nsrf) = yz0_new(j)
     2220          z0m(i,nsrf) = yz0m(j)
     2221          z0h(i,nsrf) = yz0h(j)
    23102222          fluxlat(i,nsrf) = yfluxlat(j)
    23112223          agesno(i,nsrf) = yagesno(j) 
    … …  
    25192431       DO j=1, knon
    25202432          i = ni(j)
    2521           rugo1(j) = yrugos(j)
     2433          rugo1(j) = yz0m(j)
    25222434          IF(nsrf.EQ.is_oce) THEN
    2523              rugo1(j) = rugos(i,nsrf)
     2435             rugo1(j) = z0m(i,nsrf)
    25242436          ENDIF
    25252437          psfce(j)=ypaprs(j,1)
    … …  
    25362448        CALL stdlevvar(klon, knon, nsrf, zxli, &
    25372449            uzon, vmer, tair1, qair1, zgeo1, &
    2538             tairsol, qairsol, rugo1, psfce, patm, &
     2450            tairsol, qairsol, rugo1, rugo1, psfce, patm, &
    25392451            yt2m, yq2m, yt10m, yq10m, yu10m, yustar)
    25402452       ELSE  !(iflag_split .eq.0)
    25412453        CALL stdlevvar(klon, knon, nsrf, zxli, &
    25422454            uzon_x, vmer_x, tair1_x, qair1_x, zgeo1_x, &
    2543             tairsol_x, qairsol, rugo1, psfce, patm, &
     2455            tairsol_x, qairsol, rugo1, rugo1, psfce, patm, &
    25442456            yt2m_x, yq2m_x, yt10m_x, yq10m_x, yu10m_x, yustar_x)
    25452457        CALL stdlevvar(klon, knon, nsrf, zxli, &
    25462458            uzon_w, vmer_w, tair1_w, qair1_w, zgeo1_w, &
    2547             tairsol_w, qairsol, rugo1, psfce, patm, &
     2459            tairsol_w, qairsol, rugo1, rugo1, psfce, patm, &
    25482460            yt2m_w, yq2m_w, yt10m_w, yq10m_w, yu10m_w, yustar_w)
    25492461!!!
    … …  
    27712683!****************************************************************************************
    27722684   
     2685    z0m(:,nbsrf+1) = 0.0
     2686    z0h(:,nbsrf+1) = 0.0
     2687    DO nsrf = 1, nbsrf
     2688       DO i = 1, klon
     2689          z0m(i,nbsrf+1) = z0m(i,nbsrf+1) + z0m(i,nsrf)*pctsrf(i,nsrf)
     2690          z0h(i,nbsrf+1) = z0h(i,nbsrf+1) + z0h(i,nsrf)*pctsrf(i,nsrf)
     2691       ENDDO
     2692    ENDDO
     2693
    27732694!   print*,'OK pbl 7'
    27742695    zxfluxt(:,:) = 0.0 ; zxfluxq(:,:) = 0.0
    … …  
    29872908    zv1(:) = v(:,1)
    29882909
    2989 ! Some of the module declared variables are returned for printing in physiq.F
    2990     qsol_d(:)     = qsol(:)
    2991     evap_d(:,:)   = evap(:,:)
    2992     rugos_d(:,:)  = rugos(:,:)
    2993     agesno_d(:,:) = agesno(:,:)
    2994 
    29952910
    29962911  END SUBROUTINE pbl_surface
    … …  
    29982913!****************************************************************************************
    29992914!
    3000   SUBROUTINE pbl_surface_final(qsol_rst, fder_rst, snow_rst, qsurf_rst, &
    3001        evap_rst, rugos_rst, agesno_rst, ftsoil_rst)
     2915  SUBROUTINE pbl_surface_final(fder_rst, snow_rst, qsurf_rst, ftsoil_rst)
    30022916
    30032917    USE indice_sol_mod
    … …  
    30072921! Ouput variables
    30082922!****************************************************************************************
    3009     REAL, DIMENSION(klon), INTENT(OUT)                 :: qsol_rst
    30102923    REAL, DIMENSION(klon), INTENT(OUT)                 :: fder_rst
    30112924    REAL, DIMENSION(klon, nbsrf), INTENT(OUT)          :: snow_rst
    30122925    REAL, DIMENSION(klon, nbsrf), INTENT(OUT)          :: qsurf_rst
    3013     REAL, DIMENSION(klon, nbsrf), INTENT(OUT)          :: evap_rst
    3014     REAL, DIMENSION(klon, nbsrf), INTENT(OUT)          :: rugos_rst
    3015     REAL, DIMENSION(klon, nbsrf), INTENT(OUT)          :: agesno_rst
    30162926    REAL, DIMENSION(klon, nsoilmx, nbsrf), INTENT(OUT) :: ftsoil_rst
    30172927
    … …  
    30212931!
    30222932!****************************************************************************************   
    3023     qsol_rst(:)       = qsol(:)
    30242933    fder_rst(:)       = fder(:)
    30252934    snow_rst(:,:)     = snow(:,:)
    30262935    qsurf_rst(:,:)    = qsurf(:,:)
    3027     evap_rst(:,:)     = evap(:,:)
    3028     rugos_rst(:,:)    = rugos(:,:)
    3029     agesno_rst(:,:)   = agesno(:,:)
    30302936    ftsoil_rst(:,:,:) = ftsoil(:,:,:)
    30312937
    … …  
    30352941!****************************************************************************************
    30362942!   DEALLOCATE(qsol, fder, snow, qsurf, evap, rugos, agesno, ftsoil)
    3037     IF (ALLOCATED(qsol)) DEALLOCATE(qsol)
    30382943    IF (ALLOCATED(fder)) DEALLOCATE(fder)
    30392944    IF (ALLOCATED(snow)) DEALLOCATE(snow)
    30402945    IF (ALLOCATED(qsurf)) DEALLOCATE(qsurf)
    3041     IF (ALLOCATED(evap)) DEALLOCATE(evap)
    3042     IF (ALLOCATED(rugos)) DEALLOCATE(rugos)
    3043     IF (ALLOCATED(agesno)) DEALLOCATE(agesno)
    30442946    IF (ALLOCATED(ftsoil)) DEALLOCATE(ftsoil)
    30452947
    … …  
    30502952
    30512953!albedo SB >>>
    3052 !  SUBROUTINE pbl_surface_newfrac(itime, pctsrf_new, pctsrf_old, tsurf, alb1, alb2, ustar, u10m, v10m, tke)
    3053 SUBROUTINE pbl_surface_newfrac(itime, pctsrf_new, pctsrf_old, tsurf,alb_dir,alb_dif, ustar, u10m, v10m, tke) 
     2954SUBROUTINE pbl_surface_newfrac(itime, pctsrf_new, pctsrf_old, &
     2955     evap, z0m, z0h, agesno,                                  &
     2956     tsurf,alb_dir,alb_dif, ustar, u10m, v10m, tke) 
    30542957!albedo SB <<<
    30552958    ! Give default values where new fraction has appread
    … …  
    30702973    REAL, DIMENSION(klon,nbsrf), INTENT(INOUT)        :: tsurf
    30712974!albedo SB >>>
    3072 !   REAL, DIMENSION(klon,nbsrf), INTENT(INOUT)        :: alb1, alb2
    30732975    REAL, DIMENSION(klon,nsw,nbsrf), INTENT(INOUT)       :: alb_dir, alb_dif
    30742976    INTEGER :: k
    30752977!albedo SB <<<
    30762978    REAL, DIMENSION(klon,nbsrf), INTENT(INOUT)        :: ustar,u10m, v10m
     2979    REAL, DIMENSION(klon,nbsrf), INTENT(INOUT)        :: evap, agesno
     2980    REAL, DIMENSION(klon,nbsrf+1), INTENT(INOUT)        :: z0m,z0h
    30772981    REAL, DIMENSION(klon,klev+1,nbsrf+1), INTENT(INOUT) :: tke
    30782982
    … …  
    31163020                qsurf(i,nsrf) = qsurf(i,nsrf_comp1)
    31173021                evap(i,nsrf)  = evap(i,nsrf_comp1)
    3118                 rugos(i,nsrf) = rugos(i,nsrf_comp1)
     3022                z0m(i,nsrf) = z0m(i,nsrf_comp1)
     3023                z0h(i,nsrf) = z0h(i,nsrf_comp1)
    31193024                tsurf(i,nsrf) = tsurf(i,nsrf_comp1)
    31203025!albedo SB >>>
    3121 !                alb1(i,nsrf)  = alb1(i,nsrf_comp1)
    3122 !                alb2(i,nsrf)  = alb2(i,nsrf_comp1)
    31233026                DO k=1,nsw
    31243027                 alb_dir(i,k,nsrf)=alb_dir(i,k,nsrf_comp1)
    … …  
    31373040                qsurf(i,nsrf) = qsurf(i,nsrf_comp2)*pctsrf_old(i,nsrf_comp2) + qsurf(i,nsrf_comp3)*pctsrf_old(i,nsrf_comp3)
    31383041                evap(i,nsrf)  = evap(i,nsrf_comp2) *pctsrf_old(i,nsrf_comp2) + evap(i,nsrf_comp3) *pctsrf_old(i,nsrf_comp3)
    3139                 rugos(i,nsrf) = rugos(i,nsrf_comp2)*pctsrf_old(i,nsrf_comp2) + rugos(i,nsrf_comp3)*pctsrf_old(i,nsrf_comp3)
     3042                z0m(i,nsrf) = z0m(i,nsrf_comp2)*pctsrf_old(i,nsrf_comp2) + z0m(i,nsrf_comp3)*pctsrf_old(i,nsrf_comp3)
     3043                z0h(i,nsrf) = z0h(i,nsrf_comp2)*pctsrf_old(i,nsrf_comp2) + z0h(i,nsrf_comp3)*pctsrf_old(i,nsrf_comp3)
    31403044                tsurf(i,nsrf) = tsurf(i,nsrf_comp2)*pctsrf_old(i,nsrf_comp2) + tsurf(i,nsrf_comp3)*pctsrf_old(i,nsrf_comp3)
    31413045!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)
    31443046                DO k=1,nsw
    31453047                 alb_dir(i,k,nsrf)=alb_dir(i,k,nsrf_comp2)*pctsrf_old(i,nsrf_comp2)+&

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

    r2220 r2298  
    4848    REAL :: run_off_lic_0(nlon)
    4949    REAL :: qsolsrf(nlon, nbsrf), snsrf(nlon, nbsrf)
    50     REAL :: frugs(nlon, nbsrf)
    51     REAL :: agesno(nlon, nbsrf)
    5250    REAL :: tsoil(nlon, nsoilmx, nbsrf)
    5351    REAL :: tslab(nlon), seaice(nlon)
    54     REAL evap(nlon, nbsrf), fder(nlon)
     52    REAL fder(nlon)
    5553
    5654
    … …  
    6765    REAL tsurf
    6866    REAL time, timestep, day, day0
    69     REAL qsol_f, qsol(nlon)
     67    REAL qsol_f
    7068    REAL rugsrel(nlon)
    7169    ! real zmea(nlon),zstd(nlon),zsig(nlon)
    … …  
    328326    seaice(:) = 0.
    329327    run_off_lic_0 = 0.
    330     evap = 0.
     328    fevap = 0.
    331329
    332330
    … …  
    336334    qsolsrf(:, :) = qsol(1) ! humidite du sol des sous surface
    337335    snsrf(:, :) = 0. ! couverture de neige des sous surface
    338     frugs(:, :) = rugos ! couverture de neige des sous surface
    339 
    340 
    341     CALL pbl_surface_init(qsol, fder, snsrf, qsolsrf, evap, frugs, agesno, &
    342       tsoil)
     336    z0m(:, :) = rugos ! couverture de neige des sous surface
     337    z0h=z0m
     338
     339
     340    CALL pbl_surface_init(fder, snsrf, qsolsrf, tsoil)
    343341
    344342    PRINT *, 'iniaqua: before phyredem'

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

    r2258 r2298  
    1010  USE surface_data,     ONLY : type_ocean, version_ocean
    1111  USE phys_state_var_mod, ONLY : ancien_ok, clwcon, detr_therm, dtime, &
    12        du_gwd_rando, dv_gwd_rando, entr_therm, f0, falb1, falb2, fm_therm, &
     12       qsol, fevap, z0m, z0h, agesno, &
     13       du_gwd_rando, dv_gwd_rando, entr_therm, f0, fm_therm, &
    1314       falb_dir, falb_dif, &
    1415       ftsol, pbl_tke, pctsrf, q_ancien, radpas, radsol, rain_fall, ratqs, &
    … …  
    2021       zstd, zthe, zval, ale_bl, ale_bl_trig, alp_bl
    2122  USE iostart, ONLY : close_startphy, get_field, get_var, open_startphy
    22   USE infotrac, only: nbtr, type_trac, tname, niadv
     23  USE infotrac, only: nbtr, nqo, type_trac, tname, niadv
    2324  USE traclmdz_mod,    ONLY : traclmdz_from_restart
    2425  USE carbon_cycle_mod, ONLY : carbon_cycle_tr, carbon_cycle_cpl, co2_send
    … …  
    4647  REAL tsoil(klon, nsoilmx, nbsrf)
    4748  REAL qsurf(klon, nbsrf)
    48   REAL qsol(klon)
    4949  REAL snow(klon, nbsrf)
    50   REAL evap(klon, nbsrf)
    5150  real fder(klon)
    52   REAL frugs(klon, nbsrf)
    53   REAL agesno(klon, nbsrf)
    5451  REAL run_off_lic_0(klon)
    5552  REAL fractint(klon)
    … …  
    7471  CHARACTER*7 str7
    7572  CHARACTER*2 str2
    76   LOGICAL :: found
     73  LOGICAL :: found,phyetat0_get,phyetat0_srf
    7774
    7875  ! FH1D
    … …  
    205202  END DO
    206203
    207   ! Lecture des temperatures du sol:
    208 
    209   CALL get_field("TS", ftsol(:, 1), found)
    210   IF (.NOT. found) THEN
    211      PRINT*, 'phyetat0: Le champ <TS> est absent'
    212      PRINT*, '          Mais je vais essayer de lire TS**'
    213      DO nsrf = 1, nbsrf
    214         IF (nsrf.GT.99) THEN
    215            PRINT*, "Trop de sous-mailles"
     204!===================================================================
     205! Lecture des temperatures du sol:
     206!===================================================================
     207
     208  found=phyetat0_get(1,ftsol(:,1),"TS","Surface temperature",283.)
     209  IF (found) THEN
     210     DO nsrf=2,nbsrf
     211        ftsol(:,nsrf)=ftsol(:,1)
     212     ENDDO
     213  ELSE
     214     found=phyetat0_srf(1,ftsol,"TS","Surface temperature",283.)
     215  ENDIF
     216
     217!===================================================================
     218  ! Lecture des albedo difus et direct
     219!===================================================================
     220
     221  DO nsrf = 1, nbsrf
     222     DO isw=1, nsw
     223        IF (isw.GT.99) THEN
     224           PRINT*, "Trop de bandes SW"
    216225           call abort_gcm("phyetat0", "", 1)
    217226        ENDIF
    218         WRITE(str2, '(i2.2)') nsrf
    219         CALL get_field("TS"//str2, ftsol(:, nsrf))
    220 
    221         xmin = 1.0E+20
    222         xmax = -1.0E+20
    223         DO i = 1, klon
    224            xmin = MIN(ftsol(i, nsrf), xmin)
    225            xmax = MAX(ftsol(i, nsrf), xmax)
    226         ENDDO
    227         PRINT*, 'Temperature du sol TS**:', nsrf, xmin, xmax
     227        WRITE(str2, '(i2.2)') isw
     228        found=phyetat0_srf(1,falb_dir(:, isw,:),"A_dir_SW"//str2//"srf","Direct Albedo",0.2)
     229        found=phyetat0_srf(1,falb_dif(:, isw,:),"A_dif_SW"//str2//"srf","Direct Albedo",0.2)
    228230     ENDDO
    229   ELSE
    230      PRINT*, 'phyetat0: Le champ <TS> est present'
    231      PRINT*, '          J ignore donc les autres temperatures TS**'
    232      xmin = 1.0E+20
    233      xmax = -1.0E+20
    234      DO i = 1, klon
    235         xmin = MIN(ftsol(i, 1), xmin)
    236         xmax = MAX(ftsol(i, 1), xmax)
    237      ENDDO
    238      PRINT*, 'Temperature du sol <TS>', xmin, xmax
    239      DO nsrf = 2, nbsrf
    240         DO i = 1, klon
    241            ftsol(i, nsrf) = ftsol(i, 1)
    242         ENDDO
    243      ENDDO
    244   ENDIF
    245 
    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"
     231  ENDDO
     232
     233!===================================================================
     234  ! Lecture des temperatures du sol profond:
     235!===================================================================
     236
     237   DO isoil=1, nsoilmx
     238        IF (isoil.GT.99) THEN
     239           PRINT*, "Trop de couches "
    253240           call abort_gcm("phyetat0", "", 1)
    254241        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 !===================================================================
    277   ! Lecture des temperatures du sol profond:
    278 
    279   DO nsrf = 1, nbsrf
    280      DO isoil=1, nsoilmx
    281         IF (isoil.GT.99 .AND. nsrf.GT.99) THEN
    282            PRINT*, "Trop de couches ou sous-mailles"
    283            call abort_gcm("phyetat0", "", 1)
    284         ENDIF
    285         WRITE(str7, '(i2.2, "srf", i2.2)') isoil, nsrf
    286 
    287         CALL get_field('Tsoil'//str7, tsoil(:, isoil, nsrf), found)
     242        WRITE(str2,'(i2.2)') isoil
     243        found=phyetat0_srf(1,tsoil(:, isoil,:),"Tsoil"//str2//"srf","Temp soil",0.)
    288244        IF (.NOT. found) THEN
    289245           PRINT*, "phyetat0: Le champ <Tsoil"//str7//"> est absent"
    290246           PRINT*, "          Il prend donc la valeur de surface"
    291            DO i=1, klon
    292               tsoil(i, isoil, nsrf)=ftsol(i, nsrf)
    293            ENDDO
     247           tsoil(:, isoil, :)=ftsol(:, :)
    294248        ENDIF
    295      ENDDO
    296   ENDDO
    297 
    298 !===================================================================
    299   ! Lecture de l'humidite de l'air juste au dessus du sol:
    300 
    301   CALL get_field("QS", qsurf(:, 1), found)
     249   ENDDO
     250
     251!=======================================================================
     252! Lecture precipitation/evaporation
     253!=======================================================================
     254
     255  found=phyetat0_srf(1,qsurf,"QS","Near surface hmidity",0.)
     256  found=phyetat0_get(1,qsol,"QSOL","Surface hmidity / bucket",0.)
     257  found=phyetat0_srf(1,snow,"SNOW","Surface snow",0.)
     258  found=phyetat0_srf(1,fevap,"EVAP","evaporation",0.)
     259  found=phyetat0_get(1,snow_fall,"snow_f","snow fall",0.)
     260  found=phyetat0_get(1,rain_fall,"rain_f","rain fall",0.)
     261
     262!=======================================================================
     263! Radiation
     264!=======================================================================
     265
     266  found=phyetat0_get(1,solsw,"solsw","net SW radiation surf",0.)
     267  found=phyetat0_get(1,sollw,"sollw","net LW radiation surf",0.)
     268  found=phyetat0_get(1,sollwdown,"sollwdown","down LW radiation surf",0.)
    302269  IF (.NOT. found) THEN
    303      PRINT*, 'phyetat0: Le champ <QS> est absent'
    304      PRINT*, '          Mais je vais essayer de lire QS**'
    305      DO nsrf = 1, nbsrf
    306         IF (nsrf.GT.99) THEN
    307            PRINT*, "Trop de sous-mailles"
    308            call abort_gcm("phyetat0", "", 1)
    309         ENDIF
    310         WRITE(str2, '(i2.2)') nsrf
    311         CALL get_field("QS"//str2, qsurf(:, nsrf))
    312         xmin = 1.0E+20
    313         xmax = -1.0E+20
    314         DO i = 1, klon
    315            xmin = MIN(qsurf(i, nsrf), xmin)
    316            xmax = MAX(qsurf(i, nsrf), xmax)
    317         ENDDO
    318         PRINT*, 'Humidite pres du sol QS**:', nsrf, xmin, xmax
    319      ENDDO
    320   ELSE
    321      PRINT*, 'phyetat0: Le champ <QS> est present'
    322      PRINT*, '          J ignore donc les autres humidites QS**'
    323      xmin = 1.0E+20
    324      xmax = -1.0E+20
    325      DO i = 1, klon
    326         xmin = MIN(qsurf(i, 1), xmin)
    327         xmax = MAX(qsurf(i, 1), xmax)
    328      ENDDO
    329      PRINT*, 'Humidite pres du sol <QS>', xmin, xmax
    330      DO nsrf = 2, nbsrf
    331         DO i = 1, klon
    332            qsurf(i, nsrf) = qsurf(i, 1)
    333         ENDDO
    334      ENDDO
    335   ENDIF
    336 
    337   ! Eau dans le sol (pour le modele de sol "bucket")
    338 
    339   CALL get_field("QSOL", qsol, found)
    340   IF (.NOT. found) THEN
    341      PRINT*, 'phyetat0: Le champ <QSOL> est absent'
    342      PRINT*, '          Valeur par defaut nulle'
    343      qsol(:)=0.
    344   ENDIF
    345 
    346   xmin = 1.0E+20
    347   xmax = -1.0E+20
    348   DO i = 1, klon
    349      xmin = MIN(qsol(i), xmin)
    350      xmax = MAX(qsol(i), xmax)
    351   ENDDO
    352   PRINT*, 'Eau dans le sol (mm) <QSOL>', xmin, xmax
    353 
    354   ! Lecture de neige au sol:
    355 
    356   CALL get_field("SNOW", snow(:, 1), found)
    357   IF (.NOT. found) THEN
    358      PRINT*, 'phyetat0: Le champ <SNOW> est absent'
    359      PRINT*, '          Mais je vais essayer de lire SNOW**'
    360      DO nsrf = 1, nbsrf
    361         IF (nsrf.GT.99) THEN
    362            PRINT*, "Trop de sous-mailles"
    363            call abort_gcm("phyetat0", "", 1)
    364         ENDIF
    365         WRITE(str2, '(i2.2)') nsrf
    366         CALL get_field( "SNOW"//str2, snow(:, nsrf))
    367         xmin = 1.0E+20
    368         xmax = -1.0E+20
    369         DO i = 1, klon
    370            xmin = MIN(snow(i, nsrf), xmin)
    371            xmax = MAX(snow(i, nsrf), xmax)
    372         ENDDO
    373         PRINT*, 'Neige du sol SNOW**:', nsrf, xmin, xmax
    374      ENDDO
    375   ELSE
    376      PRINT*, 'phyetat0: Le champ <SNOW> est present'
    377      PRINT*, '          J ignore donc les autres neiges SNOW**'
    378      xmin = 1.0E+20
    379      xmax = -1.0E+20
    380      DO i = 1, klon
    381         xmin = MIN(snow(i, 1), xmin)
    382         xmax = MAX(snow(i, 1), xmax)
    383      ENDDO
    384      PRINT*, 'Neige du sol <SNOW>', xmin, xmax
    385      DO nsrf = 2, nbsrf
    386         DO i = 1, klon
    387            snow(i, nsrf) = snow(i, 1)
    388         ENDDO
    389      ENDDO
    390   ENDIF
    391 
    392   ! Lecture de albedo de l'interval visible au sol:
    393 
    394   CALL get_field("ALBE", falb1(:, 1), found)
    395   IF (.NOT. found) THEN
    396      PRINT*, 'phyetat0: Le champ <ALBE> est absent'
    397      PRINT*, '          Mais je vais essayer de lire ALBE**'
    398      DO nsrf = 1, nbsrf
    399         IF (nsrf.GT.99) THEN
    400            PRINT*, "Trop de sous-mailles"
    401            call abort_gcm("phyetat0", "", 1)
    402         ENDIF
    403         WRITE(str2, '(i2.2)') nsrf
    404         CALL get_field("ALBE"//str2, falb1(:, nsrf))
    405         xmin = 1.0E+20
    406         xmax = -1.0E+20
    407         DO i = 1, klon
    408            xmin = MIN(falb1(i, nsrf), xmin)
    409            xmax = MAX(falb1(i, nsrf), xmax)
    410         ENDDO
    411         PRINT*, 'Albedo du sol ALBE**:', nsrf, xmin, xmax
    412      ENDDO
    413   ELSE
    414      PRINT*, 'phyetat0: Le champ <ALBE> est present'
    415      PRINT*, '          J ignore donc les autres ALBE**'
    416      xmin = 1.0E+20
    417      xmax = -1.0E+20
    418      DO i = 1, klon
    419         xmin = MIN(falb1(i, 1), xmin)
    420         xmax = MAX(falb1(i, 1), xmax)
    421      ENDDO
    422      PRINT*, 'Neige du sol <ALBE>', xmin, xmax
    423      DO nsrf = 2, nbsrf
    424         DO i = 1, klon
    425            falb1(i, nsrf) = falb1(i, 1)
    426         ENDDO
    427      ENDDO
    428   ENDIF
    429 
    430   ! Lecture de albedo au sol dans l'interval proche infra-rouge:
    431 
    432   CALL get_field("ALBLW", falb2(:, 1), found)
    433   IF (.NOT. found) THEN
    434      PRINT*, 'phyetat0: Le champ <ALBLW> est absent'
    435      PRINT*, '          Mais je vais prendre ALBE**'
    436      DO nsrf = 1, nbsrf
    437         DO i = 1, klon
    438            falb2(i, nsrf) = falb1(i, nsrf)
    439         ENDDO
    440      ENDDO
    441   ELSE
    442      PRINT*, 'phyetat0: Le champ <ALBLW> est present'
    443      PRINT*, '          J ignore donc les autres ALBLW**'
    444      xmin = 1.0E+20
    445      xmax = -1.0E+20
    446      DO i = 1, klon
    447         xmin = MIN(falb2(i, 1), xmin)
    448         xmax = MAX(falb2(i, 1), xmax)
    449      ENDDO
    450      PRINT*, 'Neige du sol <ALBLW>', xmin, xmax
    451      DO nsrf = 2, nbsrf
    452         DO i = 1, klon
    453            falb2(i, nsrf) = falb2(i, 1)
    454         ENDDO
    455      ENDDO
    456   ENDIF
    457 
    458   ! Lecture de evaporation: 
    459 
    460   CALL get_field("EVAP", evap(:, 1), found)
    461   IF (.NOT. found) THEN
    462      PRINT*, 'phyetat0: Le champ <EVAP> est absent'
    463      PRINT*, '          Mais je vais essayer de lire EVAP**'
    464      DO nsrf = 1, nbsrf
    465         IF (nsrf.GT.99) THEN
    466            PRINT*, "Trop de sous-mailles"
    467            call abort_gcm("phyetat0", "", 1)
    468         ENDIF
    469         WRITE(str2, '(i2.2)') nsrf
    470         CALL get_field("EVAP"//str2, evap(:, nsrf))
    471         xmin = 1.0E+20
    472         xmax = -1.0E+20
    473         DO i = 1, klon
    474            xmin = MIN(evap(i, nsrf), xmin)
    475            xmax = MAX(evap(i, nsrf), xmax)
    476         ENDDO
    477         PRINT*, 'evap du sol EVAP**:', nsrf, xmin, xmax
    478      ENDDO
    479   ELSE
    480      PRINT*, 'phyetat0: Le champ <EVAP> est present'
    481      PRINT*, '          J ignore donc les autres EVAP**'
    482      xmin = 1.0E+20
    483      xmax = -1.0E+20
    484      DO i = 1, klon
    485         xmin = MIN(evap(i, 1), xmin)
    486         xmax = MAX(evap(i, 1), xmax)
    487      ENDDO
    488      PRINT*, 'Evap du sol <EVAP>', xmin, xmax
    489      DO nsrf = 2, nbsrf
    490         DO i = 1, klon
    491            evap(i, nsrf) = evap(i, 1)
    492         ENDDO
    493      ENDDO
    494   ENDIF
    495 
    496   ! Lecture precipitation liquide:
    497 
    498   CALL get_field("rain_f", rain_fall)
    499   xmin = 1.0E+20
    500   xmax = -1.0E+20
    501   DO i = 1, klon
    502      xmin = MIN(rain_fall(i), xmin)
    503      xmax = MAX(rain_fall(i), xmax)
    504   ENDDO
    505   PRINT*, 'Precipitation liquide rain_f:', xmin, xmax
    506 
    507   ! Lecture precipitation solide:
    508 
    509   CALL get_field("snow_f", snow_fall)
    510   xmin = 1.0E+20
    511   xmax = -1.0E+20
    512   DO i = 1, klon
    513      xmin = MIN(snow_fall(i), xmin)
    514      xmax = MAX(snow_fall(i), xmax)
    515   ENDDO
    516   PRINT*, 'Precipitation solide snow_f:', xmin, xmax
    517 
    518   ! Lecture rayonnement solaire au sol:
    519 
    520   CALL get_field("solsw", solsw, found)
    521   IF (.NOT. found) THEN
    522      PRINT*, 'phyetat0: Le champ <solsw> est absent'
    523      PRINT*, 'mis a zero'
    524      solsw(:) = 0.
    525   ENDIF
    526   xmin = 1.0E+20
    527   xmax = -1.0E+20
    528   DO i = 1, klon
    529      xmin = MIN(solsw(i), xmin)
    530      xmax = MAX(solsw(i), xmax)
    531   ENDDO
    532   PRINT*, 'Rayonnement solaire au sol solsw:', xmin, xmax
    533 
    534   ! Lecture rayonnement IF au sol:
    535 
    536   CALL get_field("sollw", sollw, found)
    537   IF (.NOT. found) THEN
    538      PRINT*, 'phyetat0: Le champ <sollw> est absent'
    539      PRINT*, 'mis a zero'
    540      sollw = 0.
    541   ENDIF
    542   xmin = 1.0E+20
    543   xmax = -1.0E+20
    544   DO i = 1, klon
    545      xmin = MIN(sollw(i), xmin)
    546      xmax = MAX(sollw(i), xmax)
    547   ENDDO
    548   PRINT*, 'Rayonnement IF au sol sollw:', xmin, xmax
    549 
    550   CALL get_field("sollwdown", sollwdown, found)
    551   IF (.NOT. found) THEN
    552      PRINT*, 'phyetat0: Le champ <sollwdown> est absent'
    553      PRINT*, 'mis a zero'
    554      sollwdown = 0.
    555      zts=0.
     270     sollwdown = 0. ;  zts=0.
    556271     do nsrf=1,nbsrf
    557272        zts(:)=zts(:)+ftsol(:,nsrf)*pctsrf(:,nsrf)
    … …  
    559274     sollwdown(:)=sollw(:)+RSIGMA*zts(:)**4
    560275  ENDIF
    561 !  print*,'TS SOLL',zts(klon/2),sollw(klon/2),sollwdown(klon/2)
    562   xmin = 1.0E+20
    563   xmax = -1.0E+20
    564   DO i = 1, klon
    565      xmin = MIN(sollwdown(i), xmin)
    566      xmax = MAX(sollwdown(i), xmax)
    567   ENDDO
    568   PRINT*, 'Rayonnement IF au sol sollwdown:', xmin, xmax
    569 
    570 
    571   ! Lecture derive des flux:
    572 
    573   CALL get_field("fder", fder, found)
    574   IF (.NOT. found) THEN
    575      PRINT*, 'phyetat0: Le champ <fder> est absent'
    576      PRINT*, 'mis a zero'
    577      fder = 0.
     276
     277  found=phyetat0_get(1,radsol,"RADS","Solar radiation",0.)
     278  found=phyetat0_get(1,fder,"fder","Flux derivative",0.)
     279
     280
     281  ! Lecture de la longueur de rugosite
     282  found=phyetat0_srf(1,z0m,"RUG","Z0m ancien",0.001)
     283  IF (found) THEN
     284     z0h(:,1:nbsrf)=z0m(:,1:nbsrf)
     285  ELSE
     286     found=phyetat0_srf(1,z0m,"Z0m","Roughness length, momentum ",0.001)
     287     found=phyetat0_srf(1,z0h,"Z0h","Roughness length, enthalpy ",0.001)
    578288  ENDIF
    579   xmin = 1.0E+20
    580   xmax = -1.0E+20
    581   DO i = 1, klon
    582      xmin = MIN(fder(i), xmin)
    583      xmax = MAX(fder(i), xmax)
    584   ENDDO
    585   PRINT*, 'Derive des flux fder:', xmin, xmax
    586 
    587   ! Lecture du rayonnement net au sol:
    588 
    589   CALL get_field("RADS", radsol)
    590   xmin = 1.0E+20
    591   xmax = -1.0E+20
    592   DO i = 1, klon
    593      xmin = MIN(radsol(i), xmin)
    594      xmax = MAX(radsol(i), xmax)
    595   ENDDO
    596   PRINT*, 'Rayonnement net au sol radsol:', xmin, xmax
    597 
    598   ! Lecture de la longueur de rugosite
    599 
    600   CALL get_field("RUG", frugs(:, 1), found)
    601   IF (.NOT. found) THEN
    602      PRINT*, 'phyetat0: Le champ <RUG> est absent'
    603      PRINT*, '          Mais je vais essayer de lire RUG**'
    604      DO nsrf = 1, nbsrf
    605         IF (nsrf.GT.99) THEN
    606            PRINT*, "Trop de sous-mailles"
    607            call abort_gcm("phyetat0", "", 1)
    608         ENDIF
    609         WRITE(str2, '(i2.2)') nsrf
    610         CALL get_field("RUG"//str2, frugs(:, nsrf))
    611         xmin = 1.0E+20
    612         xmax = -1.0E+20
    613         DO i = 1, klon
    614            xmin = MIN(frugs(i, nsrf), xmin)
    615            xmax = MAX(frugs(i, nsrf), xmax)
    616         ENDDO
    617         PRINT*, 'rugosite du sol RUG**:', nsrf, xmin, xmax
    618      ENDDO
    619   ELSE
    620      PRINT*, 'phyetat0: Le champ <RUG> est present'
    621      PRINT*, '          J ignore donc les autres RUG**'
    622      xmin = 1.0E+20
    623      xmax = -1.0E+20
    624      DO i = 1, klon
    625         xmin = MIN(frugs(i, 1), xmin)
    626         xmax = MAX(frugs(i, 1), xmax)
    627      ENDDO
    628      PRINT*, 'rugosite <RUG>', xmin, xmax
    629      DO nsrf = 2, nbsrf
    630         DO i = 1, klon
    631            frugs(i, nsrf) = frugs(i, 1)
    632         ENDDO
    633      ENDDO
     289
     290  ! Lecture de l'age de la neige:
     291  found=phyetat0_srf(1,agesno,"AGESNO","SNOW AGE",0.001)
     292
     293  ancien_ok=.true.
     294  ancien_ok=ancien_ok.AND.phyetat0_get(klev,t_ancien,"TANCIEN","TANCIEN",0.)
     295  ancien_ok=ancien_ok.AND.phyetat0_get(klev,q_ancien,"QANCIEN","QANCIEN",0.)
     296  ancien_ok=ancien_ok.AND.phyetat0_get(klev,u_ancien,"UANCIEN","UANCIEN",0.)
     297  ancien_ok=ancien_ok.AND.phyetat0_get(klev,v_ancien,"VANCIEN","VANCIEN",0.)
     298
     299  found=phyetat0_get(klev,clwcon,"CLWCON","CLWCON",0.)
     300  found=phyetat0_get(klev,rnebcon,"RNEBCON","RNEBCON",0.)
     301  found=phyetat0_get(klev,ratqs,"RATQS","RATQS",0.)
     302
     303  found=phyetat0_get(1,run_off_lic_0,"RUNOFFLIC0","RUNOFFLIC0",0.)
     304
     305!==================================
     306!  TKE
     307!==================================
     308!
     309  IF (iflag_pbl>1) then
     310     found=phyetat0_srf(klev+1,pbl_tke,"TKE","Turb. Kinetic. Energ. ",1.e-8)
    634311  ENDIF
    635312
    636   ! Lecture de l'age de la neige:
    637 
    638   CALL get_field("AGESNO", agesno(:, 1), found)
    639   IF (.NOT. found) THEN
    640      PRINT*, 'phyetat0: Le champ <AGESNO> est absent'
    641      PRINT*, '          Mais je vais essayer de lire AGESNO**'
    642      DO nsrf = 1, nbsrf
    643         IF (nsrf.GT.99) THEN
    644            PRINT*, "Trop de sous-mailles"
    645            call abort_gcm("phyetat0", "", 1)
    646         ENDIF
    647         WRITE(str2, '(i2.2)') nsrf
    648         CALL get_field("AGESNO"//str2, agesno(:, nsrf), found)
    649         IF (.NOT. found) THEN
    650            PRINT*, "phyetat0: Le champ <AGESNO"//str2//"> est absent"
    651            agesno = 50.0
    652         ENDIF
    653         xmin = 1.0E+20
    654         xmax = -1.0E+20
    655         DO i = 1, klon
    656            xmin = MIN(agesno(i, nsrf), xmin)
    657            xmax = MAX(agesno(i, nsrf), xmax)
    658         ENDDO
    659         PRINT*, 'Age de la neige AGESNO**:', nsrf, xmin, xmax
    660      ENDDO
    661   ELSE
    662      PRINT*, 'phyetat0: Le champ <AGESNO> est present'
    663      PRINT*, '          J ignore donc les autres AGESNO**'
    664      xmin = 1.0E+20
    665      xmax = -1.0E+20
    666      DO i = 1, klon
    667         xmin = MIN(agesno(i, 1), xmin)
    668         xmax = MAX(agesno(i, 1), xmax)
    669      ENDDO
    670      PRINT*, 'Age de la neige <AGESNO>', xmin, xmax
    671      DO nsrf = 2, nbsrf
    672         DO i = 1, klon
    673            agesno(i, nsrf) = agesno(i, 1)
    674         ENDDO
    675      ENDDO
    676   ENDIF
    677 
    678   CALL get_field("ZMEA", zmea)
    679   xmin = 1.0E+20
    680   xmax = -1.0E+20
    681   DO i = 1, klon
    682      xmin = MIN(zmea(i), xmin)
    683      xmax = MAX(zmea(i), xmax)
    684   ENDDO
    685   PRINT*, 'OROGRAPHIE SOUS-MAILLE zmea:', xmin, xmax
    686 
    687   CALL get_field("ZSTD", zstd)
    688   xmin = 1.0E+20
    689   xmax = -1.0E+20
    690   DO i = 1, klon
    691      xmin = MIN(zstd(i), xmin)
    692      xmax = MAX(zstd(i), xmax)
    693   ENDDO
    694   PRINT*, 'OROGRAPHIE SOUS-MAILLE zstd:', xmin, xmax
    695 
    696   CALL get_field("ZSIG", zsig)
    697   xmin = 1.0E+20
    698   xmax = -1.0E+20
    699   DO i = 1, klon
    700      xmin = MIN(zsig(i), xmin)
    701      xmax = MAX(zsig(i), xmax)
    702   ENDDO
    703   PRINT*, 'OROGRAPHIE SOUS-MAILLE zsig:', xmin, xmax
    704 
    705   CALL get_field("ZGAM", zgam)
    706   xmin = 1.0E+20
    707   xmax = -1.0E+20
    708   DO i = 1, klon
    709      xmin = MIN(zgam(i), xmin)
    710      xmax = MAX(zgam(i), xmax)
    711   ENDDO
    712   PRINT*, 'OROGRAPHIE SOUS-MAILLE zgam:', xmin, xmax
    713 
    714   CALL get_field("ZTHE", zthe)
    715   xmin = 1.0E+20
    716   xmax = -1.0E+20
    717   DO i = 1, klon
    718      xmin = MIN(zthe(i), xmin)
    719      xmax = MAX(zthe(i), xmax)
    720   ENDDO
    721   PRINT*, 'OROGRAPHIE SOUS-MAILLE zthe:', xmin, xmax
    722 
    723   CALL get_field("ZPIC", zpic)
    724   xmin = 1.0E+20
    725   xmax = -1.0E+20
    726   DO i = 1, klon
    727      xmin = MIN(zpic(i), xmin)
    728      xmax = MAX(zpic(i), xmax)
    729   ENDDO
    730   PRINT*, 'OROGRAPHIE SOUS-MAILLE zpic:', xmin, xmax
    731 
    732   CALL get_field("ZVAL", zval)
    733   xmin = 1.0E+20
    734   xmax = -1.0E+20
    735   DO i = 1, klon
    736      xmin = MIN(zval(i), xmin)
    737      xmax = MAX(zval(i), xmax)
    738   ENDDO
    739   PRINT*, 'OROGRAPHIE SOUS-MAILLE zval:', xmin, xmax
    740 
    741   CALL get_field("RUGSREL", rugoro)
    742   xmin = 1.0E+20
    743   xmax = -1.0E+20
    744   DO i = 1, klon
    745      xmin = MIN(rugoro(i), xmin)
    746      xmax = MAX(rugoro(i), xmax)
    747   ENDDO
    748   PRINT*, 'Rugosite relief (ecart-type) rugsrel:', xmin, xmax
    749 
    750   ancien_ok = .TRUE.
    751 
    752   CALL get_field("TANCIEN", t_ancien, found)
    753   IF (.NOT. found) THEN
    754      PRINT*, "phyetat0: Le champ <TANCIEN> est absent"
    755      PRINT*, "Depart legerement fausse. Mais je continue"
    756      ancien_ok = .FALSE.
    757   ENDIF
    758 
    759   CALL get_field("QANCIEN", q_ancien, found)
    760   IF (.NOT. found) THEN
    761      PRINT*, "phyetat0: Le champ <QANCIEN> est absent"
    762      PRINT*, "Depart legerement fausse. Mais je continue"
    763      ancien_ok = .FALSE.
    764   ENDIF
    765 
    766   CALL get_field("UANCIEN", u_ancien, found)
    767   IF (.NOT. found) THEN
    768      PRINT*, "phyetat0: Le champ <UANCIEN> est absent"
    769      PRINT*, "Depart legerement fausse. Mais je continue"
    770      ancien_ok = .FALSE.
    771   ENDIF
    772 
    773   CALL get_field("VANCIEN", v_ancien, found)
    774   IF (.NOT. found) THEN
    775      PRINT*, "phyetat0: Le champ <VANCIEN> est absent"
    776      PRINT*, "Depart legerement fausse. Mais je continue"
    777      ancien_ok = .FALSE.
    778   ENDIF
    779 
    780   clwcon=0.
    781   CALL get_field("CLWCON", clwcon, found)
    782   IF (.NOT. found) THEN
    783      PRINT*, "phyetat0: Le champ CLWCON est absent"
    784      PRINT*, "Depart legerement fausse. Mais je continue"
    785   ENDIF
    786   xmin = 1.0E+20
    787   xmax = -1.0E+20
    788   xmin = MINval(clwcon)
    789   xmax = MAXval(clwcon)
    790   PRINT*, 'Eau liquide convective (ecart-type) clwcon:', xmin, xmax
    791 
    792   rnebcon = 0.
    793   CALL get_field("RNEBCON", rnebcon, found)
    794   IF (.NOT. found) THEN
    795      PRINT*, "phyetat0: Le champ RNEBCON est absent"
    796      PRINT*, "Depart legerement fausse. Mais je continue"
    797   ENDIF
    798   xmin = 1.0E+20
    799   xmax = -1.0E+20
    800   xmin = MINval(rnebcon)
    801   xmax = MAXval(rnebcon)
    802   PRINT*, 'Nebulosite convective (ecart-type) rnebcon:', xmin, xmax
    803 
    804   ! Lecture ratqs
    805 
    806   ratqs=0.
    807   CALL get_field("RATQS", ratqs, found)
    808   IF (.NOT. found) THEN
    809      PRINT*, "phyetat0: Le champ <RATQS> est absent"
    810      PRINT*, "Depart legerement fausse. Mais je continue"
    811   ENDIF
    812   xmin = 1.0E+20
    813   xmax = -1.0E+20
    814   xmin = MINval(ratqs)
    815   xmax = MAXval(ratqs)
    816   PRINT*, '(ecart-type) ratqs:', xmin, xmax
    817 
    818   ! Lecture run_off_lic_0
    819 
    820   CALL get_field("RUNOFFLIC0", run_off_lic_0, found)
    821   IF (.NOT. found) THEN
    822      PRINT*, "phyetat0: Le champ <RUNOFFLIC0> est absent"
    823      PRINT*, "Depart legerement fausse. Mais je continue"
    824      run_off_lic_0 = 0.
    825   ENDIF
    826   xmin = 1.0E+20
    827   xmax = -1.0E+20
    828   xmin = MINval(run_off_lic_0)
    829   xmax = MAXval(run_off_lic_0)
    830   PRINT*, '(ecart-type) run_off_lic_0:', xmin, xmax
    831 
    832   ! Lecture de l'energie cinetique turbulente
    833 
    834   IF (iflag_pbl>1) then
    835      DO nsrf = 1, nbsrf
    836         IF (nsrf.GT.99) THEN
    837            PRINT*, "Trop de sous-mailles"
    838            call abort_gcm("phyetat0", "", 1)
    839         ENDIF
    840         WRITE(str2, '(i2.2)') nsrf
    841         CALL get_field("TKE"//str2, pbl_tke(:, 1:klev+1, nsrf), found)
    842         IF (.NOT. found) THEN
    843            PRINT*, "phyetat0: <TKE"//str2//"> est absent"
    844            pbl_tke(:, :, nsrf)=1.e-8
    845         ENDIF
    846         xmin = 1.0E+20
    847         xmax = -1.0E+20
    848         DO k = 1, klev+1
    849            DO i = 1, klon
    850               xmin = MIN(pbl_tke(i, k, nsrf), xmin)
    851               xmax = MAX(pbl_tke(i, k, nsrf), xmax)
    852            ENDDO
    853         ENDDO
    854         PRINT*, 'Turbulent kinetic energyl TKE**:', nsrf, xmin, xmax
    855      ENDDO
    856   ENDIF
    857 
    858 ! Lecture de l'ecart de TKE (w) - (x)
    859 !
    860   IF (iflag_pbl>1 .AND. iflag_wake>=1  &
    861            .AND. iflag_pbl_split >=1 ) then
    862     DO nsrf = 1, nbsrf
    863       IF (nsrf.GT.99) THEN
    864         PRINT*, "Trop de sous-mailles"
    865         call abort_gcm("phyetat0", "", 1)
    866       ENDIF
    867       WRITE(str2,'(i2.2)') nsrf
    868       CALL get_field("DELTATKE"//str2, &
    869                     wake_delta_pbl_tke(:,1:klev+1,nsrf),found)
    870       IF (.NOT. found) THEN
    871         PRINT*, "phyetat0: <DELTATKE"//str2//"> est absent"
    872         wake_delta_pbl_tke(:,:,nsrf)=0.
    873       ENDIF
    874       xmin = 1.0E+20
    875       xmax = -1.0E+20
    876       DO k = 1, klev+1
    877         DO i = 1, klon
    878           xmin = MIN(wake_delta_pbl_tke(i,k,nsrf),xmin)
    879           xmax = MAX(wake_delta_pbl_tke(i,k,nsrf),xmax)
    880         ENDDO
    881       ENDDO
    882       PRINT*,'TKE difference (w)-(x) DELTATKE**:', nsrf, xmin, xmax
    883     ENDDO
    884 
    885   ! delta_tsurf
    886 
    887     DO nsrf = 1, nbsrf
    888        IF (nsrf.GT.99) THEN
    889          PRINT*, "Trop de sous-mailles"
    890          call abort_gcm("phyetat0", "", 1)
    891        ENDIF
    892        WRITE(str2,'(i2.2)') nsrf
    893      CALL get_field("DELTA_TSURF"//str2, delta_tsurf(:,nsrf), found)
    894      IF (.NOT. found) THEN
    895         PRINT*, "phyetat0: Le champ <DELTA_TSURF"//str2//"> est absent"
    896         PRINT*, "Depart legerement fausse. Mais je continue"
    897         delta_tsurf(:,nsrf)=0.
    898      ELSE
    899         xmin = 1.0E+20
    900         xmax = -1.0E+20
    901          DO i = 1, klon
    902             xmin = MIN(delta_tsurf(i, nsrf), xmin)
    903             xmax = MAX(delta_tsurf(i, nsrf), xmax)
    904          ENDDO
    905         PRINT*, 'delta_tsurf:', xmin, xmax
    906      ENDIF
    907     ENDDO  ! nsrf = 1, nbsrf
     313  IF (iflag_pbl>1 .AND. iflag_wake>=1  .AND. iflag_pbl_split >=1 ) then
     314    found=phyetat0_srf(klev+1,wake_delta_pbl_tke,"DELTATKE","Del TKE wk/env",0.)
     315    found=phyetat0_srf(1,delta_tsurf,"DELTA_TSURF","Delta Ts wk/env ",0.)
    908316  ENDIF   !(iflag_pbl>1 .AND. iflag_wake>=1 .AND. iflag_pbl_split >=1 )
    909317
    910   ! zmax0
    911   CALL get_field("ZMAX0", zmax0, found)
    912   IF (.NOT. found) THEN
    913      PRINT*, "phyetat0: Le champ <ZMAX0> est absent"
    914      PRINT*, "Depart legerement fausse. Mais je continue"
    915      zmax0=40.
    916   ENDIF
    917   xmin = 1.0E+20
    918   xmax = -1.0E+20
    919   xmin = MINval(zmax0)
    920   xmax = MAXval(zmax0)
    921   PRINT*, '(ecart-type) zmax0:', xmin, xmax
    922 
    923   !           f0(ig)=1.e-5
    924   ! f0
    925   CALL get_field("F0", f0, found)
    926   IF (.NOT. found) THEN
    927      PRINT*, "phyetat0: Le champ <f0> est absent"
    928      PRINT*, "Depart legerement fausse. Mais je continue"
    929      f0=1.e-5
    930   ENDIF
    931   xmin = 1.0E+20
    932   xmax = -1.0E+20
    933   xmin = MINval(f0)
    934   xmax = MAXval(f0)
    935   PRINT*, '(ecart-type) f0:', xmin, xmax
    936 
    937   ! sig1 or ema_work1
    938 
    939   CALL get_field("sig1", sig1, found)
    940   IF (.NOT. found) CALL get_field("EMA_WORK1", sig1, found)
    941   IF (.NOT. found) THEN
    942      PRINT*, "phyetat0: Le champ sig1 est absent"
    943      PRINT*, "Depart legerement fausse. Mais je continue"
    944      sig1=0.
    945   ELSE
    946      xmin = 1.0E+20
    947      xmax = -1.0E+20
    948      DO k = 1, klev
    949         DO i = 1, klon
    950            xmin = MIN(sig1(i, k), xmin)
    951            xmax = MAX(sig1(i, k), xmax)
    952         ENDDO
    953      ENDDO
    954      PRINT*, 'sig1:', xmin, xmax
    955   ENDIF
    956 
    957   ! w01 or ema_work2
    958 
    959   CALL get_field("w01", w01, found)
    960   IF (.NOT. found) CALL get_field("EMA_WORK2", w01, found)
    961   IF (.NOT. found) THEN
    962      PRINT*, "phyetat0: Le champ w01 est absent"
    963      PRINT*, "Depart legerement fausse. Mais je continue"
    964      w01=0.
    965   ELSE
    966      xmin = 1.0E+20
    967      xmax = -1.0E+20
    968      DO k = 1, klev
    969         DO i = 1, klon
    970            xmin = MIN(w01(i, k), xmin)
    971            xmax = MAX(w01(i, k), xmax)
    972         ENDDO
    973      ENDDO
    974      PRINT*, 'w01:', xmin, xmax
    975   ENDIF
    976 
    977   ! wake_deltat
    978 
    979   CALL get_field("WAKE_DELTAT", wake_deltat, found)
    980   IF (.NOT. found) THEN
    981      PRINT*, "phyetat0: Le champ <WAKE_DELTAT> est absent"
    982      PRINT*, "Depart legerement fausse. Mais je continue"
    983      wake_deltat=0.
    984   ELSE
    985      xmin = 1.0E+20
    986      xmax = -1.0E+20
    987      DO k = 1, klev
    988         DO i = 1, klon
    989            xmin = MIN(wake_deltat(i, k), xmin)
    990            xmax = MAX(wake_deltat(i, k), xmax)
    991         ENDDO
    992      ENDDO
    993      PRINT*, 'wake_deltat:', xmin, xmax
    994   ENDIF
    995 
    996   ! wake_deltaq
    997 
    998   CALL get_field("WAKE_DELTAQ", wake_deltaq, found)
    999   IF (.NOT. found) THEN
    1000      PRINT*, "phyetat0: Le champ <WAKE_DELTAQ> est absent"
    1001      PRINT*, "Depart legerement fausse. Mais je continue"
    1002      wake_deltaq=0.
    1003   ELSE
    1004      xmin = 1.0E+20
    1005      xmax = -1.0E+20
    1006      DO k = 1, klev
    1007         DO i = 1, klon
    1008            xmin = MIN(wake_deltaq(i, k), xmin)
    1009            xmax = MAX(wake_deltaq(i, k), xmax)
    1010         ENDDO
    1011      ENDDO
    1012      PRINT*, 'wake_deltaq:', xmin, xmax
    1013   ENDIF
    1014 
    1015   ! wake_s
    1016 
    1017   CALL get_field("WAKE_S", wake_s, found)
    1018   IF (.NOT. found) THEN
    1019      PRINT*, "phyetat0: Le champ <WAKE_S> est absent"
    1020      PRINT*, "Depart legerement fausse. Mais je continue"
    1021      wake_s=0.
    1022   ENDIF
    1023   xmin = 1.0E+20
    1024   xmax = -1.0E+20
    1025   xmin = MINval(wake_s)
    1026   xmax = MAXval(wake_s)
    1027   PRINT*, '(ecart-type) wake_s:', xmin, xmax
    1028 
    1029   ! wake_cstar
    1030 
    1031   CALL get_field("WAKE_CSTAR", wake_cstar, found)
    1032   IF (.NOT. found) THEN
    1033      PRINT*, "phyetat0: Le champ <WAKE_CSTAR> est absent"
    1034      PRINT*, "Depart legerement fausse. Mais je continue"
    1035      wake_cstar=0.
    1036   ENDIF
    1037   xmin = 1.0E+20
    1038   xmax = -1.0E+20
    1039   xmin = MINval(wake_cstar)
    1040   xmax = MAXval(wake_cstar)
    1041   PRINT*, '(ecart-type) wake_cstar:', xmin, xmax
    1042 
    1043   ! wake_pe
    1044 
    1045   CALL get_field("WAKE_PE", wake_pe, found)
    1046   IF (.NOT. found) THEN
    1047      PRINT*, "phyetat0: Le champ <WAKE_PE> est absent"
    1048      PRINT*, "Depart legerement fausse. Mais je continue"
    1049      wake_pe=0.
    1050   ENDIF
    1051   xmin = 1.0E+20
    1052   xmax = -1.0E+20
    1053   xmin = MINval(wake_pe)
    1054   xmax = MAXval(wake_pe)
    1055   PRINT*, '(ecart-type) wake_pe:', xmin, xmax
    1056 
    1057   ! wake_fip
    1058 
    1059   CALL get_field("WAKE_FIP", wake_fip, found)
    1060   IF (.NOT. found) THEN
    1061      PRINT*, "phyetat0: Le champ <WAKE_FIP> est absent"
    1062      PRINT*, "Depart legerement fausse. Mais je continue"
    1063      wake_fip=0.
    1064   ENDIF
    1065   xmin = 1.0E+20
    1066   xmax = -1.0E+20
    1067   xmin = MINval(wake_fip)
    1068   xmax = MAXval(wake_fip)
    1069   PRINT*, '(ecart-type) wake_fip:', xmin, xmax
    1070 
    1071   !  thermiques
    1072 
    1073   CALL get_field("FM_THERM", fm_therm, found)
    1074   IF (.NOT. found) THEN
    1075      PRINT*, "phyetat0: Le champ <fm_therm> est absent"
    1076      PRINT*, "Depart legerement fausse. Mais je continue"
    1077      fm_therm=0.
    1078   ENDIF
    1079   xmin = 1.0E+20
    1080   xmax = -1.0E+20
    1081   xmin = MINval(fm_therm)
    1082   xmax = MAXval(fm_therm)
    1083   PRINT*, '(ecart-type) fm_therm:', xmin, xmax
    1084 
    1085   CALL get_field("ENTR_THERM", entr_therm, found)
    1086   IF (.NOT. found) THEN
    1087      PRINT*, "phyetat0: Le champ <entr_therm> est absent"
    1088      PRINT*, "Depart legerement fausse. Mais je continue"
    1089      entr_therm=0.
    1090   ENDIF
    1091   xmin = 1.0E+20
    1092   xmax = -1.0E+20
    1093   xmin = MINval(entr_therm)
    1094   xmax = MAXval(entr_therm)
    1095   PRINT*, '(ecart-type) entr_therm:', xmin, xmax
    1096 
    1097   CALL get_field("DETR_THERM", detr_therm, found)
    1098   IF (.NOT. found) THEN
    1099      PRINT*, "phyetat0: Le champ <detr_therm> est absent"
    1100      PRINT*, "Depart legerement fausse. Mais je continue"
    1101      detr_therm=0.
    1102   ENDIF
    1103   xmin = 1.0E+20
    1104   xmax = -1.0E+20
    1105   xmin = MINval(detr_therm)
    1106   xmax = MAXval(detr_therm)
    1107   PRINT*, '(ecart-type) detr_therm:', xmin, xmax
    1108 
    1109   CALL get_field("ALE_BL", ale_bl, found)
    1110   IF (.NOT. found) THEN
    1111      PRINT*, "phyetat0: Le champ <ale_bl> est absent"
    1112      PRINT*, "Depart legerement fausse. Mais je continue"
    1113      ale_bl=0.
    1114   ENDIF
    1115   xmin = 1.0E+20
    1116   xmax = -1.0E+20
    1117   xmin = MINval(ale_bl)
    1118   xmax = MAXval(ale_bl)
    1119   PRINT*, '(ecart-type) ale_bl:', xmin, xmax
    1120 
    1121   CALL get_field("ALE_BL_TRIG", ale_bl_trig, found)
    1122   IF (.NOT. found) THEN
    1123      PRINT*, "phyetat0: Le champ <ale_bl_trig> est absent"
    1124      PRINT*, "Depart legerement fausse. Mais je continue"
    1125      ale_bl_trig=0.
    1126   ENDIF
    1127   xmin = 1.0E+20
    1128   xmax = -1.0E+20
    1129   xmin = MINval(ale_bl_trig)
    1130   xmax = MAXval(ale_bl_trig)
    1131   PRINT*, '(ecart-type) ale_bl_trig:', xmin, xmax
    1132 
    1133   CALL get_field("ALP_BL", alp_bl, found)
    1134   IF (.NOT. found) THEN
    1135      PRINT*, "phyetat0: Le champ <alp_bl> est absent"
    1136      PRINT*, "Depart legerement fausse. Mais je continue"
    1137      alp_bl=0.
    1138   ENDIF
    1139   xmin = 1.0E+20
    1140   xmax = -1.0E+20
    1141   xmin = MINval(alp_bl)
    1142   xmax = MAXval(alp_bl)
    1143   PRINT*, '(ecart-type) alp_bl:', xmin, xmax
    1144 
     318!==================================
     319!  thermiques, poches, convection
     320!==================================
     321
     322! Emanuel
     323  found=phyetat0_get(klev,sig1,"sig1","sig1",0.)
     324  found=phyetat0_get(klev,w01,"w01","w01",0.)
     325
     326! Wake
     327  found=phyetat0_get(klev,wake_deltat,"WAKE_DELTAT","Delta T wake/env",0.)
     328  found=phyetat0_get(klev,wake_deltaq,"WAKE_DELTAQ","Delta hum. wake/env",0.)
     329  found=phyetat0_get(1,wake_s,"WAKE_S","WAKE_S",0.)
     330  found=phyetat0_get(1,wake_cstar,"WAKE_CSTAR","WAKE_CSTAR",0.)
     331  found=phyetat0_get(1,wake_pe,"WAKE_PE","WAKE_PE",0.)
     332  found=phyetat0_get(1,wake_fip,"WAKE_FIP","WAKE_FIP",0.)
     333
     334! Thermiques
     335  found=phyetat0_get(1,zmax0,"ZMAX0","ZMAX0",40.)
     336  found=phyetat0_get(1,f0,"F0","F0",1.e-5)
     337  found=phyetat0_get(klev+1,fm_therm,"FM_THERM","Thermals mass flux",0.)
     338  found=phyetat0_get(klev,entr_therm,"ENTR_THERM","Thermals Entrain.",0.)
     339  found=phyetat0_get(klev,detr_therm,"DETR_THERM","Thermals Detrain.",0.)
     340
     341! ALE/ALP
     342  found=phyetat0_get(1,ale_bl,"ALE_BL","ALE BL",0.)
     343  found=phyetat0_get(1,ale_bl_trig,"ALE_BL_TRIG","ALE BL_TRIG",0.)
     344  found=phyetat0_get(1,alp_bl,"ALP_BL","ALP BL",0.)
     345
     346!===========================================
    1145347  ! Read and send field trs to traclmdz
     348!===========================================
    1146349
    1147350  IF (type_trac == 'lmdz') THEN
    1148      DO it=1, nbtr
    1149         iiq=niadv(it+2)
    1150         CALL get_field("trs_"//tname(iiq), trs(:, it), found)
    1151         IF (.NOT. found) THEN
    1152            PRINT*,  &
    1153                 "phyetat0: Le champ <trs_"//tname(iiq)//"> est absent"
    1154            PRINT*, "Depart legerement fausse. Mais je continue"
    1155            trs(:, it) = 0.
    1156         ENDIF
    1157         xmin = 1.0E+20
    1158         xmax = -1.0E+20
    1159         xmin = MINval(trs(:, it))
    1160         xmax = MAXval(trs(:, it))
    1161         PRINT*, "(ecart-type) trs_"//tname(iiq)//" :", xmin, xmax
    1162 
     351     DO it=1, nbtr                                                                 
     352!!        iiq=niadv(it+2)                                                           ! jyg
     353        iiq=niadv(it+nqo)                                                           ! jyg
     354        found=phyetat0_get(1,trs(:,it),"trs_"//tname(iiq), &
     355              "Surf trac"//tname(iiq),0.)
    1163356     END DO
    1164357     CALL traclmdz_from_restart(trs)
    … …  
    1166359     IF (carbon_cycle_cpl) THEN
    1167360        ALLOCATE(co2_send(klon), stat=ierr)
    1168         IF (ierr /= 0) CALL abort_gcm &
    1169              ('phyetat0', 'pb allocation co2_send', 1)
    1170         CALL get_field("co2_send", co2_send, found)
    1171         IF (.NOT. found) THEN
    1172            PRINT*, "phyetat0: Le champ <co2_send> est absent"
    1173            PRINT*, "Initialisation uniforme a co2_ppm=", co2_ppm
    1174            co2_send(:) = co2_ppm
    1175         END IF
     361        IF (ierr /= 0) CALL abort_gcm('phyetat0', 'pb allocation co2_send', 1)
     362        found=phyetat0_get(1,co2_send,"co2_send","co2 send",0.)
    1176363     END IF
    1177364  END IF
    1178365
     366!===========================================
     367!  ondes de gravite / relief
     368!===========================================
     369
     370!  ondes de gravite non orographiques
    1179371  if (ok_gwd_rando) then
    1180      call get_field("du_gwd_rando", du_gwd_rando, found)
    1181      if (.not. found) then
    1182         print *, "du_gwd_rando not found, setting it to 0."
    1183         du_gwd_rando = 0.
    1184      end if
    1185 
    1186      call get_field("dv_gwd_rando", dv_gwd_rando, found)
    1187      if (.not. found) then
    1188         print *, "dv_gwd_rando not found, setting it to 0."
    1189         dv_gwd_rando = 0.
    1190      end if
     372     found=phyetat0_get(klev,du_gwd_rando,"du_gwd_rando","du_gwd_rando",0.)
     373     found=phyetat0_get(klev,dv_gwd_rando,"dv_gwd_rando","dv_gwd_rando",0.)
    1191374  end if
    1192375
    1193   ! Initialize Slab variables
     376!  prise en compte du relief sous-maille
     377  found=phyetat0_get(1,zmea,"ZMEA","sub grid orography",0.)
     378  found=phyetat0_get(1,zstd,"ZSTD","sub grid orography",0.)
     379  found=phyetat0_get(1,zsig,"ZSIG","sub grid orography",0.)
     380  found=phyetat0_get(1,zgam,"ZGAM","sub grid orography",0.)
     381  found=phyetat0_get(1,zthe,"ZTHE","sub grid orography",0.)
     382  found=phyetat0_get(1,zpic,"ZPIC","sub grid orography",0.)
     383  found=phyetat0_get(1,zval,"ZVAL","sub grid orography",0.)
     384  found=phyetat0_get(1,zmea,"ZMEA","sub grid orography",0.)
     385  found=phyetat0_get(1,rugoro,"RUGSREL","sub grid orography",0.)
     386
     387!===========================================
     388! Initialize ocean
     389!===========================================
     390
    1194391  IF ( type_ocean == 'slab' ) THEN
    1195       print*, "calling slab_init"
    1196392      CALL ocean_slab_init(dtime, pctsrf)
    1197       ! tslab
    1198       CALL get_field("tslab", tslab, found)
     393      found=phyetat0_get(nslay,tslab,"tslab","tslab",0.)
    1199394      IF (.NOT. found) THEN
    1200395          PRINT*, "phyetat0: Le champ <tslab> est absent"
    … …  
    1204399          END DO
    1205400      END IF
     401
    1206402      ! Sea ice variables
     403      found=phyetat0_get(1,tice,"slab_tice","slab_tice",0.)
    1207404      IF (version_ocean == 'sicINT') THEN
    1208           CALL get_field("slab_tice", tice, found)
    1209405          IF (.NOT. found) THEN
    1210406              PRINT*, "phyetat0: Le champ <tice> est absent"
    … …  
    1212408                  tice(:)=ftsol(:,is_sic)
    1213409          END IF
    1214           CALL get_field("seaice", seaice, found)
    1215410          IF (.NOT. found) THEN
    1216411              PRINT*, "phyetat0: Le champ <seaice> est absent"
    … …  
    1229424  ! Initialize module pbl_surface_mod
    1230425
    1231   CALL pbl_surface_init(qsol, fder, snow, qsurf, &
    1232        evap, frugs, agesno, tsoil)
     426  CALL pbl_surface_init(fder, snow, qsurf, tsoil)
    1233427
    1234428  ! Initialize module ocean_cpl_mod for the case of coupled ocean
    … …  
    1243437
    1244438END SUBROUTINE phyetat0
     439
     440!===================================================================
     441FUNCTION phyetat0_get(nlev,field,name,descr,default)
     442!===================================================================
     443! Lecture d'un champ avec contrôle
     444! Function logique dont le resultat indique si la lecture
     445! s'est bien passée
     446! On donne une valeur par defaut dans le cas contraire
     447!===================================================================
     448
     449USE iostart, ONLY : get_field
     450USE dimphy, only: klon
     451
     452IMPLICIT NONE
     453INCLUDE "iniprint.h"
     454
     455LOGICAL phyetat0_get
     456
     457! arguments
     458INTEGER,INTENT(IN) :: nlev
     459CHARACTER*(*),INTENT(IN) :: name,descr
     460REAL,INTENT(IN) :: default
     461REAL,DIMENSION(klon,nlev),INTENT(INOUT) :: field
     462
     463! Local variables
     464LOGICAL found
     465
     466   CALL get_field(name, field, found)
     467   IF (.NOT. found) THEN
     468     WRITE(lunout,*) "phyetat0: Le champ <",name,"> est absent"
     469     WRITE(lunout,*) "Depart legerement fausse. Mais je continue"
     470     field(:,:)=default
     471   ENDIF
     472   WRITE(lunout,*) name, descr, MINval(field),MAXval(field)
     473   phyetat0_get=found
     474
     475RETURN
     476END FUNCTION phyetat0_get
     477
     478!================================================================
     479FUNCTION phyetat0_srf(nlev,field,name,descr,default)
     480!===================================================================
     481! Lecture d'un champ par sous-surface avec contrôle
     482! Function logique dont le resultat indique si la lecture
     483! s'est bien passée
     484! On donne une valeur par defaut dans le cas contraire
     485!===================================================================
     486
     487USE iostart, ONLY : get_field
     488USE dimphy, only: klon
     489USE indice_sol_mod, only: nbsrf
     490
     491IMPLICIT NONE
     492INCLUDE "iniprint.h"
     493
     494LOGICAL phyetat0_srf
     495! arguments
     496INTEGER,INTENT(IN) :: nlev
     497CHARACTER*(*),INTENT(IN) :: name,descr
     498REAL,INTENT(IN) :: default
     499REAL,DIMENSION(klon,nlev,nbsrf),INTENT(INOUT) :: field
     500
     501! Local variables
     502LOGICAL found,phyetat0_get
     503INTEGER nsrf
     504CHARACTER*2 str2
     505 
     506     IF (nbsrf.GT.99) THEN
     507        WRITE(lunout,*) "Trop de sous-mailles"
     508        call abort_gcm("phyetat0", "", 1)
     509     ENDIF
     510
     511     DO nsrf = 1, nbsrf
     512        WRITE(str2, '(i2.2)') nsrf
     513        found= phyetat0_get(nlev,field(:,:, nsrf), &
     514        name//str2,descr//" srf:"//str2,default)
     515     ENDDO
     516
     517     phyetat0_srf=found
     518
     519RETURN
     520END FUNCTION phyetat0_srf
     521

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

    r2258 r2298  
    3636  REAL tsoil(klon, nsoilmx, nbsrf)
    3737  REAL qsurf(klon, nbsrf)
    38   REAL qsol(klon)
    3938  REAL snow(klon, nbsrf)
    40   REAL evap(klon, nbsrf)
    4139  real fder(klon)
    42   REAL frugs(klon, nbsrf)
    43   REAL agesno(klon, nbsrf)
    4440  REAL run_off_lic_0(klon)
    4541  REAL trs(klon, nbtr)
    … …  
    6056  ! Get variables which will be written to restart file from module
    6157  ! pbl_surface_mod
    62   CALL pbl_surface_final(qsol, fder, snow, qsurf,  &
    63        evap, frugs, agesno, tsoil)
     58  CALL pbl_surface_final(fder, snow, qsurf,  tsoil)
    6459
    6560  ! Get a variable calculated in module fonte_neige_mod
    … …  
    190185     IF (nsrf.LE.99) THEN
    191186        WRITE(str2, '(i2.2)') nsrf
    192         CALL put_field("ALBE"//str2, "albedo de surface No."//str2, &
    193              falb1(:, nsrf))
    194      ELSE
    195         PRINT*, "Trop de sous-mailles"
    196         call abort_gcm("phyredem", "", 1)
    197      ENDIF
    198   ENDDO
    199 
    200   DO nsrf = 1, nbsrf
    201      IF (nsrf.LE.99) THEN
    202         WRITE(str2, '(i2.2)') nsrf
    203         CALL put_field("ALBLW"//str2, "albedo LW de surface No."//str2, &
    204              falb2(:, nsrf))
    205      ELSE
    206         PRINT*, "Trop de sous-mailles"
    207         call abort_gcm("phyredem", "", 1)
    208      ENDIF
    209   ENDDO
    210 
    211   DO nsrf = 1, nbsrf
    212      IF (nsrf.LE.99) THEN
    213         WRITE(str2, '(i2.2)') nsrf
    214187        CALL put_field("EVAP"//str2, "Evaporation de surface No."//str2 &
    215              , evap(:, nsrf))
     188             , fevap(:, nsrf))
    216189     ELSE
    217190        PRINT*, "Trop de sous-mailles"
    … …  
    248221     IF (nsrf.LE.99) THEN
    249222        WRITE(str2, '(i2.2)') nsrf
    250         CALL put_field("RUG"//str2, "rugosite de surface No."//str2, &
    251              frugs(:, nsrf))
     223        CALL put_field("Z0m"//str2, "rugosite de surface No."//str2, &
     224             z0m(:, nsrf))
     225        CALL put_field("Z0h"//str2, "rugosite de surface No."//str2, &
     226             z0h(:, nsrf))
    252227     ELSE
    253228        PRINT*, "Trop de sous-mailles"
    … …  
    291266
    292267  CALL put_field("VANCIEN", "", v_ancien)
    293 
    294   CALL put_field("RUGMER", "Longueur de rugosite sur mer", &
    295        frugs(:, is_oce))
    296268
    297269  CALL put_field("CLWCON", "Eau liquide convective", clwcon)
    … …  
    313285           CALL put_field("TKE"//str2, "Energ. Cineti. Turb."//str2, &
    314286                pbl_tke(:, 1:klev+1, nsrf))
     287           CALL put_field("DELTATKE"//str2, "Del TKE wk/env."//str2, &
     288                wake_delta_pbl_tke(:, 1:klev+1, nsrf))
    315289        ELSE
    316290           PRINT*, "Trop de sous-mailles"
    … …  
    363337     CALL traclmdz_to_restart(trs)
    364338     DO it=1, nbtr
    365         iiq=niadv(it+2)
     339!!        iiq=niadv(it+2)                                                           ! jyg
     340        iiq=niadv(it+nqo)                                                           ! jyg
    366341        CALL put_field("trs_"//tname(iiq), "", trs(:, it))
    367342     END DO

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

    r2220 r2298  
    239239      REAL,ALLOCATABLE,SAVE,DIMENSION(:) :: cdragm, cdragh
    240240!$OMP THREADPRIVATE(cdragm, cdragh)
    241       REAL,ALLOCATABLE,SAVE,DIMENSION(:) :: cldh, cldl, cldm, cldq, cldt, qsat2m, qsol
    242 !$OMP THREADPRIVATE(cldh, cldl, cldm, cldq, cldt, qsat2m, qsol)
     241      REAL,ALLOCATABLE,SAVE,DIMENSION(:) :: cldh, cldl, cldm, cldq, cldt, qsat2m
     242!$OMP THREADPRIVATE(cldh, cldl, cldm, cldq, cldt, qsat2m )
    243243      REAL,ALLOCATABLE,SAVE,DIMENSION(:) :: cldhjn, cldljn, cldmjn,cldtjn
    244244!$OMP THREADPRIVATE(cldhjn, cldljn, cldmjn, cldtjn)
    … …  
    265265      REAL,ALLOCATABLE,SAVE,DIMENSION(:) :: zxfqcalving
    266266!$OMP THREADPRIVATE(zxfqcalving)
    267       REAL,ALLOCATABLE,SAVE,DIMENSION(:) :: zxfluxlat, zxrugs, zxtsol, snow_lsc, zxfqfonte
    268 !$OMP THREADPRIVATE(zxfluxlat, zxrugs, zxtsol, snow_lsc, zxfqfonte)
     267      REAL,ALLOCATABLE,SAVE,DIMENSION(:) :: zxfluxlat, zxtsol, snow_lsc, zxfqfonte
     268!$OMP THREADPRIVATE(zxfluxlat, zxtsol, snow_lsc, zxfqfonte)
    269269      REAL,ALLOCATABLE,SAVE,DIMENSION(:) :: zxqsurf, rain_lsc
    270270!$OMP THREADPRIVATE(zxqsurf, rain_lsc)
    … …  
    328328      REAL,ALLOCATABLE,SAVE,DIMENSION(:,:) :: fsolsw, wfbils, wfbilo
    329329!$OMP THREADPRIVATE(fsolsw, wfbils, wfbilo)
    330       REAL,ALLOCATABLE,SAVE,DIMENSION(:,:)  :: t2m, fevap, fluxlat, fsollw,evap_pot
    331 !$OMP THREADPRIVATE(t2m, fevap, fluxlat, fsollw,evap_pot)
     330      REAL,ALLOCATABLE,SAVE,DIMENSION(:,:)  :: t2m, fluxlat, fsollw,evap_pot
     331!$OMP THREADPRIVATE(t2m, fluxlat, fsollw,evap_pot)
    332332      REAL,ALLOCATABLE,SAVE,DIMENSION(:,:) :: dnwd, dnwd0, upwd, omega
    333333!$OMP THREADPRIVATE(dnwd, dnwd0, upwd, omega)
    … …  
    343343      REAL,ALLOCATABLE,SAVE,DIMENSION(:,:) :: wake_omg, zx_rh
    344344!$OMP THREADPRIVATE(wake_omg, zx_rh)
    345       REAL,ALLOCATABLE,SAVE,DIMENSION(:,:) :: frugs, agesno
    346 !$OMP THREADPRIVATE(frugs, agesno)
    347345      REAL,ALLOCATABLE,SAVE,DIMENSION(:,:) :: pmflxr, pmflxs, prfl, psfl, fraca
    348346!$OMP THREADPRIVATE(pmflxr, pmflxs, prfl, psfl, fraca)
    … …  
    501499      ALLOCATE(ale_wake(klon), alp_wake(klon), bils(klon))
    502500      ALLOCATE(cdragm(klon), cdragh(klon), cldh(klon), cldl(klon))
    503       ALLOCATE(cldm(klon), cldq(klon), cldt(klon), qsat2m(klon), qsol(klon))
     501      ALLOCATE(cldm(klon), cldq(klon), cldt(klon), qsat2m(klon))
    504502      ALLOCATE(cldhjn(klon), cldljn(klon), cldmjn(klon), cldtjn(klon))
    505503      ALLOCATE(JrNt(klon))
    … …  
    516514      ALLOCATE(slab_wfbils(klon), tpot(klon), tpote(klon), ue(klon))
    517515      ALLOCATE(uq(klon), ve(klon), vq(klon), zxffonte(klon))
    518       ALLOCATE(zxfqcalving(klon), zxfluxlat(klon), zxrugs(klon))
     516      ALLOCATE(zxfqcalving(klon), zxfluxlat(klon))
    519517      ALLOCATE(zxtsol(klon), snow_lsc(klon), zxfqfonte(klon), zxqsurf(klon))
    520518      ALLOCATE(rain_lsc(klon))
    … …  
    557555      ALLOCATE(pmfd(klon, klev), pmfu(klon, klev))
    558556
    559       ALLOCATE(t2m(klon, nbsrf), fevap(klon, nbsrf), fluxlat(klon, nbsrf))
    560       ALLOCATE(frugs(klon, nbsrf), agesno(klon, nbsrf), fsollw(klon, nbsrf))
     557      ALLOCATE(t2m(klon, nbsrf), fluxlat(klon, nbsrf))
     558      ALLOCATE(fsollw(klon, nbsrf))
    561559      ALLOCATE(fsolsw(klon, nbsrf), wfbils(klon, nbsrf), wfbilo(klon, nbsrf))
    562560      ALLOCATE(evap_pot(klon, nbsrf))
    … …  
    701699      DEALLOCATE(ale_wake, alp_wake, bils)
    702700      DEALLOCATE(cdragm, cdragh, cldh, cldl)
    703       DEALLOCATE(cldm, cldq, cldt, qsat2m, qsol)
     701      DEALLOCATE(cldm, cldq, cldt, qsat2m)
    704702      DEALLOCATE(cldljn, cldmjn, cldhjn, cldtjn, JrNt)
    705703      DEALLOCATE(dthmin, evap, fder, plcl, plfc)
    … …  
    714712      DEALLOCATE(slab_wfbils, tpot, tpote, ue)
    715713      DEALLOCATE(uq, ve, vq, zxffonte)
    716       DEALLOCATE(zxfqcalving, zxfluxlat, zxrugs)
     714      DEALLOCATE(zxfqcalving, zxfluxlat)
    717715      DEALLOCATE(zxtsol, snow_lsc, zxfqfonte, zxqsurf)
    718716      DEALLOCATE(rain_lsc)
    … …  
    755753      DEALLOCATE(pmfd, pmfu)
    756754
    757       DEALLOCATE(t2m, fevap, fluxlat)
    758       DEALLOCATE(frugs, agesno, fsollw, evap_pot)
     755      DEALLOCATE(t2m, fluxlat)
     756      DEALLOCATE(fsollw, evap_pot)
    759757      DEALLOCATE(fsolsw, wfbils, wfbilo)
    760758

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

    r2220 r2298  
    7474      ctrl_out((/ 10, 6, 10, 10, 10, 10, 11, 11, 11 /), &
    7575    't2m_sic', "Temp 2m "//clnsurf(4), "K", (/ ('', i=1, 9) /)) /)
     76
     77  TYPE(ctrl_out), SAVE :: o_gusts = ctrl_out((/ 1, 1, 1, 10, 10, 10, 11, 11, 11 /), &
     78    'gusts', 'surface gustiness', 'm2/s2', (/ ('', i=1, 9) /))
    7679
    7780  TYPE(ctrl_out), SAVE :: o_wind10m = ctrl_out((/ 1, 1, 1, 10, 10, 10, 11, 11, 11 /), &
    … …  
    541544  TYPE(ctrl_out), SAVE :: o_proba_notrig = ctrl_out((/ 1, 1, 1, 6, 10, 10, 11, 11, 11 /), &
    542545    'proba_notrig', &
    543                          'Probabilité de non-déclenchement', ' ', (/ ('', i=1, 9) /))
     546                         'Probabilite de non-declenchement', ' ', (/ ('', i=1, 9) /))
    544547  TYPE(ctrl_out), SAVE :: o_random_notrig = ctrl_out((/ 1, 1, 1, 6, 10, 10, 11, 11, 11 /), &
    545548    'random_notrig', &
    546                          'Tirage aléatoire de non-déclenchement', ' ', (/ ('', i=1, 9) /))
     549                         'Tirage aleatoire de non-declenchement', ' ', (/ ('', i=1, 9) /))
    547550  TYPE(ctrl_out), SAVE :: o_ale_bl_stat = ctrl_out((/ 1, 1, 1, 6, 10, 10, 11, 11, 11 /), &
    548551    'ale_bl_stat', &
    … …  
    601604
    602605  TYPE(ctrl_out), SAVE, DIMENSION(7) :: o_wSTDlevs     = (/                    &
    603       ctrl_out((/ 1, 7, 7, 10, 10, 10, 11, 11, 11 /),'w850', "Vertical wind 1hPa", "Pa/s", &
     606      ctrl_out((/ 1, 7, 7, 10, 10, 10, 11, 11, 11 /),'w850', "Vertical wind 850hPa", "Pa/s", &
    604607      (/ 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)' /)), &
    605608      ctrl_out((/ 1, 7, 7, 10, 10, 10, 11, 11, 11 /),'w700', "Vertical wind 700hPa", "Pa/s", &
    … …  
    617620
    618621  TYPE(ctrl_out), SAVE, DIMENSION(7) :: o_tSTDlevs     = (/                    &
    619       ctrl_out((/ 1, 7, 7, 10, 10, 10, 11, 11, 11 /),'t850', "Temperature 1hPa", "K",      &
     622      ctrl_out((/ 1, 7, 7, 10, 10, 10, 11, 11, 11 /),'t850', "Temperature 850hPa", "K",      &
    620623      (/ 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)' /)), &
    621624      ctrl_out((/ 1, 7, 7, 10, 10, 10, 11, 11, 11 /),'t700', "Temperature 700hPa", "K",      &
    … …  
    633636
    634637  TYPE(ctrl_out), SAVE, DIMENSION(7) :: o_qSTDlevs     = (/                             &
    635       ctrl_out((/ 1, 7, 7, 10, 10, 10, 11, 11, 11 /),'q850', "Specific humidity 1hPa", &
     638      ctrl_out((/ 1, 7, 7, 10, 10, 10, 11, 11, 11 /),'q850', "Specific humidity 850hPa", &
    636639      "kg/kg", (/ 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)' /)), &
    637640      ctrl_out((/ 1, 7, 7, 10, 10, 10, 11, 11, 11 /),'q700', "Specific humidity 700hPa", &
    … …  
    649652
    650653  TYPE(ctrl_out), SAVE, DIMENSION(7) :: o_zSTDlevs   = (/                           &
    651       ctrl_out((/ 1, 7, 7, 10, 10, 10, 11, 11, 11 /),'z850', "Geopotential height 1hPa",        &
     654      ctrl_out((/ 1, 7, 7, 10, 10, 10, 11, 11, 11 /),'z850', "Geopotential height 850hPa",        &
    652655      "m", (/ 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)' /)), &
    653656      ctrl_out((/ 1, 7, 7, 10, 10, 10, 11, 11, 11 /),'z700', "Geopotential height 700hPa",        &
    … …  
    776779  TYPE(ctrl_out), SAVE :: o_dtsvdfi = ctrl_out((/ 10, 10, 10, 10, 10, 10, 11, 11, 11 /), &
    777780    'dtsvdfi', 'Boundary-layer dTs(g)', 'K/s', (/ ('', i=1, 9) /))
    778   TYPE(ctrl_out), SAVE :: o_rugs = ctrl_out((/ 10, 10, 10, 10, 10, 10, 11, 11, 11 /), &
    779     'rugs', 'rugosity', '-', (/ ('', i=1, 9) /))
     781  TYPE(ctrl_out), SAVE :: o_z0m = ctrl_out((/ 10, 10, 10, 10, 10, 10, 11, 11, 11 /), &
     782    'z0m', 'roughness length, momentum', '-', (/ ('', i=1, 9) /))
     783  TYPE(ctrl_out), SAVE :: o_z0h = ctrl_out((/ 10, 10, 10, 10, 10, 10, 11, 11, 11 /), &
     784    'z0h', 'roughness length, enthalpy', '-', (/ ('', i=1, 9) /))
    780785  TYPE(ctrl_out), SAVE :: o_topswad = ctrl_out((/ 2, 10, 10, 10, 10, 10, 11, 11, 11 /), &
    781786    'topswad', 'ADE at TOA', 'W/m2', (/ ('', i=1, 9) /))
    … …  
    10211026      ctrl_out((/ 3, 10, 10, 10, 10, 10, 11, 11, 11 /),'snow_sic',"Snow", "kg/m2", (/ ('', i=1, 9) /)) /)
    10221027
    1023   TYPE(ctrl_out), SAVE, DIMENSION(4) :: o_rugs_srf     = (/ &
    1024       ctrl_out((/ 3, 6, 10, 10, 10, 10, 11, 11, 11 /),'rugs_ter', "Surface roughness "//clnsurf(1),"m", (/ ('', i=1, 9) /)), &
    1025       ctrl_out((/ 3, 6, 10, 10, 10, 10, 11, 11, 11 /),'rugs_lic', "Surface roughness "//clnsurf(2),"m", (/ ('', i=1, 9) /)), &
    1026       ctrl_out((/ 3, 6, 10, 10, 10, 10, 11, 11, 11 /),'rugs_oce', "Surface roughness "//clnsurf(3),"m", (/ ('', i=1, 9) /)), &
    1027       ctrl_out((/ 3, 6, 10, 10, 10, 10, 11, 11, 11 /),'rugs_sic', "Surface roughness "//clnsurf(4),"m", (/ ('', i=1, 9) /)) /)
     1028  TYPE(ctrl_out), SAVE, DIMENSION(4) :: o_z0m_srf     = (/ &
     1029      ctrl_out((/ 3, 6, 10, 10, 10, 10, 11, 11, 11 /),'z0m_ter', "Surface roughness "//clnsurf(1),"m", (/ ('', i=1, 9) /)), &
     1030      ctrl_out((/ 3, 6, 10, 10, 10, 10, 11, 11, 11 /),'z0m_lic', "Surface roughness "//clnsurf(2),"m", (/ ('', i=1, 9) /)), &
     1031      ctrl_out((/ 3, 6, 10, 10, 10, 10, 11, 11, 11 /),'z0m_oce', "Surface roughness "//clnsurf(3),"m", (/ ('', i=1, 9) /)), &
     1032      ctrl_out((/ 3, 6, 10, 10, 10, 10, 11, 11, 11 /),'z0m_sic', "Surface roughness "//clnsurf(4),"m", (/ ('', i=1, 9) /)) /)
     1033
     1034  TYPE(ctrl_out), SAVE, DIMENSION(4) :: o_z0h_srf     = (/ &
     1035      ctrl_out((/ 3, 6, 10, 10, 10, 10, 11, 11, 11 /),'z0h_ter', "Surface roughness "//clnsurf(1),"m", (/ ('', i=1, 9) /)), &
     1036      ctrl_out((/ 3, 6, 10, 10, 10, 10, 11, 11, 11 /),'z0h_lic', "Surface roughness "//clnsurf(2),"m", (/ ('', i=1, 9) /)), &
     1037      ctrl_out((/ 3, 6, 10, 10, 10, 10, 11, 11, 11 /),'z0h_oce', "Surface roughness "//clnsurf(3),"m", (/ ('', i=1, 9) /)), &
     1038      ctrl_out((/ 3, 6, 10, 10, 10, 10, 11, 11, 11 /),'z0h_sic', "Surface roughness "//clnsurf(4),"m", (/ ('', i=1, 9) /)) /)
    10281039
    10291040  TYPE(ctrl_out), SAVE :: o_alb1 = ctrl_out((/ 3, 10, 10, 10, 10, 10, 11, 11, 11 /), &

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

    r2220 r2298  
    3232         o_t2m_min_mon, o_t2m_max_mon, &
    3333         o_q2m, o_ustar, o_u10m, o_v10m, &
    34          o_wind10m, o_wind10max, o_sicf, &
     34         o_wind10m, o_wind10max, o_gusts, o_sicf, &
    3535         o_psol, o_mass, o_qsurf, o_qsol, &
    3636         o_precip, o_ndayrain, o_plul, o_pluc, &
    … …  
    8888         o_SWdownOR, o_LWdownOR, o_snowl, &
    8989         o_solldown, o_dtsvdfo, o_dtsvdft, &
    90          o_dtsvdfg, o_dtsvdfi, o_rugs, o_od550aer, &
     90         o_dtsvdfg, o_dtsvdfi, o_z0m, o_z0h, o_od550aer, &
    9191         o_od865aer, o_absvisaer, o_od550lt1aer, &
    9292         o_sconcso4, o_sconcno3, o_sconcoa, o_sconcbc, &
    … …  
    113113         o_zfull, o_zhalf, o_rneb, o_rnebjn, o_rnebcon, &
    114114         o_rnebls, o_rhum, o_ozone, o_ozone_light, &
    115          o_dtphy, o_dqphy, o_albe_srf, o_rugs_srf, &
     115         o_dtphy, o_dqphy, o_albe_srf, o_z0m_srf, o_z0h_srf, &
    116116         o_ages_srf, o_snow_srf, o_alb1, o_alb2, o_tke, &
    117117         o_tke_max, o_kz, o_kz_max, o_clwcon, &
    … …  
    154154
    155155    USE phys_state_var_mod, only: pctsrf, paire_ter, rain_fall, snow_fall, &
     156         qsol, z0m, z0h, fevap, agesno, &
    156157         nday_rain, rain_con, snow_con, &
    157158         topsw, toplw, toplw0, swup, swdn, &
    … …  
    159160         SWdn200, SWdn200clr, LWup200, LWup200clr, &
    160161         LWdn200, LWdn200clr, solsw, solsw0, sollw, &
    161          radsol, sollw0, sollwdown, sollw, &
     162         radsol, sollw0, sollwdown, sollw, gustiness, &
    162163         sollwdownclr, lwdn0, ftsol, ustar, u10m, &
    163164         v10m, pbl_tke, wake_delta_pbl_TKE, &
    … …  
    173174         vqsumSTD, vTsumSTD, O3daysumSTD, wqsumSTD, &
    174175         vphisumSTD, wTsumSTD, u2sumSTD, v2sumSTD, &
    175          T2sumSTD, nlevSTD, du_gwd_rando, dv_gwd_rando
     176         T2sumSTD, nlevSTD, du_gwd_rando, dv_gwd_rando, &
     177         ulevSTD, vlevSTD, wlevSTD, philevSTD, qlevSTD, tlevSTD, &
     178         rhlevSTD, O3STD, O3daySTD, uvSTD, vqSTD, vTSTD, wqSTD, &
     179         vphiSTD, wTSTD, u2STD, v2STD, T2STD, missing_val_nf90
    176180
    177181    USE phys_local_var_mod, only: zxfluxlat, slp, zxtsol, zt2m, &
    178          t2m_min_mon, t2m_max_mon, &
    179          zu10m, zv10m, zq2m, zustar, zxqsurf, qsol, &
    180          rain_lsc, snow_lsc, evap, bils, sens, fder, &
     182         t2m_min_mon, t2m_max_mon, evap, &
     183         zu10m, zv10m, zq2m, zustar, zxqsurf, &
     184         rain_lsc, snow_lsc, bils, sens, fder, &
    181185         zxffonte, zxfqcalving, zxfqfonte, fluxu, &
    182186         fluxv, zxsnow, qsnow, snowhgt, to_ice, &
    183187         sissnow, runoff, albsol3_lic, evap_pot, &
    184          t2m, fevap, fluxt, fluxlat, fsollw, fsolsw, &
     188         t2m, fluxt, fluxlat, fsollw, fsolsw, &
    185189         wfbils, wfbilo, cdragm, cdragh, cldl, cldm, &
    186190         cldh, cldt, JrNt, cldljn, cldmjn, cldhjn, &
    … …  
    197201         weak_inversion, dthmin, cldtau, cldemi, &
    198202         pmflxr, pmflxs, prfl, psfl, re, fl, rh2m, &
    199          qsat2m, tpote, tpot, d_ts, zxrugs, od550aer, &
     203         qsat2m, tpote, tpot, d_ts, od550aer, &
    200204         od865aer, absvisaer, od550lt1aer, sconcso4, sconcno3, &
    201205         sconcoa, sconcbc, sconcss, sconcdust, concso4, concno3, &
    … …  
    211215         lcc, lcc3d, lcc3dcon, lcc3dstra, reffclwtop, &
    212216         ec550aer, flwc, fiwc, t_seri, theta, q_seri, &
    213          ql_seri, zphi, u_seri, v_seri, omega, cldfra, &
    214          rneb, rnebjn, zx_rh, frugs, agesno, d_t_dyn, d_q_dyn, &
     217!jyg<
     218!!         ql_seri, zphi, u_seri, v_seri, omega, cldfra, &
     219         ql_seri, tr_seri, &
     220         zphi, u_seri, v_seri, omega, cldfra, &
     221!>jyg
     222         rneb, rnebjn, zx_rh, d_t_dyn, d_q_dyn, &
    215223         d_u_dyn, d_v_dyn, d_t_con, d_t_ajsb, d_t_ajs, &
    216224         d_u_ajs, d_v_ajs, &
    … …  
    243251    ! ug Pour les sorties XIOS
    244252    USE xios, ONLY: xios_update_calendar
    245     USE wxios, only: wxios_closedef
     253    USE wxios, only: wxios_closedef, missing_val
    246254#endif
    247255    USE phys_cal_mod, only : mth_len
    … …  
    289297    INTEGER, DIMENSION(iim*jjmp1*klev) :: ndex3d
    290298    REAL, PARAMETER :: dobson_u = 2.1415e-05 ! Dobson unit, in kg m-2
    291     REAL, PARAMETER :: missing_val=nf90_fill_real
     299!   REAL, PARAMETER :: missing_val=nf90_fill_real
     300#ifndef CPP_XIOS
     301    REAL :: missing_val
     302#endif
    292303    REAL, PARAMETER :: un_jour=86400.
    293304
    … …  
    354365       ENDIF
    355366       CALL histwrite_phy(o_wind10max, zx_tmp_fi2d)
     367
     368       CALL histwrite_phy(o_gusts, gustiness)
    356369
    357370       IF (vars_defined) THEN
    … …  
    566579          ENDIF
    567580!jyg<
    568           IF (iflag_pbl > 1) THEN
     581          IF (iflag_pbl > 1 .AND. iflag_wake>=1  .AND. iflag_pbl_split >=1) THEN
    569582             CALL histwrite_phy(o_dltpbltke_srf(nsrf), wake_delta_pbl_TKE(:,1:klev,nsrf))
    570583          ENDIF
    … …  
    655668       !       ENDIF
    656669
     670#ifdef CPP_IOIPSL
     671#ifndef CPP_XIOS
     672  IF (.NOT.ok_all_xml) THEN
    657673       ! ATTENTION, LES ANCIENS HISTWRITE ONT ETES CONSERVES EN ATTENDANT MIEUX:
    658674       ! Champs interpolles sur des niveaux de pression
     675       missing_val=missing_val_nf90
    659676       DO iff=1, nfiles
    660677          ll=0
    … …  
    678695          ENDDO
    679696       ENDDO
    680 
     697  ENDIF
     698#endif
     699#endif
     700#ifdef CPP_XIOS
     701  IF(ok_all_xml) THEN
     702!XIOS  CALL xios_get_field_attr("u850",default_value=missing_val)
     703!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     704          ll=0
     705          DO k=1, nlevSTD
     706             bb2=clevSTD(k)
     707             IF(bb2.EQ."850".OR.bb2.EQ."700".OR. &
     708                bb2.EQ."500".OR.bb2.EQ."200".OR. &
     709                bb2.EQ."100".OR. &
     710                bb2.EQ."50".OR.bb2.EQ."10") THEN
     711                ll=ll+1
     712                CALL histwrite_phy(o_uSTDlevs(ll),ulevSTD(:,k))
     713                CALL histwrite_phy(o_vSTDlevs(ll),vlevSTD(:,k))
     714                CALL histwrite_phy(o_wSTDlevs(ll),wlevSTD(:,k))
     715                CALL histwrite_phy(o_zSTDlevs(ll),philevSTD(:,k))
     716                CALL histwrite_phy(o_qSTDlevs(ll),qlevSTD(:,k))
     717                CALL histwrite_phy(o_tSTDlevs(ll),tlevSTD(:,k))
     718             ENDIF !(bb2.EQ."850".OR.bb2.EQ."700".OR.
     719          ENDDO
     720  ENDIF
     721#endif
    681722       IF (vars_defined) THEN
    682723          DO i=1, klon
    … …  
    720761             CALL histwrite_phy(o_dqwak, zx_tmp_fi3d)
    721762          ENDIF ! iflag_wake>=1
    722           CALL histwrite_phy(o_Vprecip, Vprecip)
    723763          CALL histwrite_phy(o_ftd, ftd)
    724764          CALL histwrite_phy(o_fqd, fqd)
    725        ELSEIF (iflag_con.EQ.30) THEN
     765       ENDIF !(iflag_con.EQ.3)
     766       IF (iflag_con.EQ.3.OR.iflag_con.EQ.30) THEN
    726767          ! sortie RomP convection descente insaturee iflag_con=30
     768          ! etendue a iflag_con=3 (jyg)
    727769          CALL histwrite_phy(o_Vprecip, Vprecip)
    728770          CALL histwrite_phy(o_wdtrainA, wdtrainA)
    … …  
    808850       CALL histwrite_phy(o_dtsvdfg,  d_ts(:,is_lic))
    809851       CALL histwrite_phy(o_dtsvdfi, d_ts(:,is_sic))
    810        CALL histwrite_phy(o_rugs, zxrugs)
     852       CALL histwrite_phy(o_z0m, z0m(:,nbsrf+1))
     853       CALL histwrite_phy(o_z0h, z0h(:,nbsrf+1))
    811854       ! OD550 per species
    812855!--OLIVIER
    … …  
    9731016          IF (vars_defined) zx_tmp_fi2d(1 : klon) = falb1( 1 : klon, nsrf)
    9741017          CALL histwrite_phy(o_albe_srf(nsrf), zx_tmp_fi2d)
    975           IF (vars_defined) zx_tmp_fi2d(1 : klon) = frugs( 1 : klon, nsrf)
    976           CALL histwrite_phy(o_rugs_srf(nsrf), zx_tmp_fi2d)
     1018          IF (vars_defined) zx_tmp_fi2d(1 : klon) = z0m( 1 : klon, nsrf)
     1019          CALL histwrite_phy(o_z0m_srf(nsrf), zx_tmp_fi2d)
     1020          IF (vars_defined) zx_tmp_fi2d(1 : klon) = z0h( 1 : klon, nsrf)
     1021          CALL histwrite_phy(o_z0h_srf(nsrf), zx_tmp_fi2d)
    9771022          IF (vars_defined) zx_tmp_fi2d(1 : klon) = agesno( 1 : klon, nsrf)
    9781023          CALL histwrite_phy(o_ages_srf(nsrf), zx_tmp_fi2d)
    … …  
    12671312       ENDIF
    12681313!!!!!!!!!!!! Sorties niveaux de pression NMC !!!!!!!!!!!!!!!!!!!!
     1314#ifdef CPP_IOIPSL
     1315#ifndef CPP_XIOS
     1316  IF (.NOT.ok_all_xml) THEN
     1317       ! ATTENTION, LES ANCIENS HISTWRITE ONT ETES CONSERVES EN ATTENDANT MIEUX:
     1318       ! Champs interpolles sur des niveaux de pression
     1319       missing_val=missing_val_nf90
    12691320       DO iff=7, nfiles
    12701321
    … …  
    13301381          CALL histwrite_phy(o_TxT,T2sumSTD(:,:,iff-6),iff)
    13311382       ENDDO !nfiles
     1383  ENDIF
     1384#endif
     1385#endif
     1386#ifdef CPP_XIOS
     1387  IF(ok_all_xml) THEN
     1388!      DO iff=7, nfiles
     1389
     1390!         CALL histwrite_phy(o_tnondef,tnondef(:,:,3))
     1391          CALL histwrite_phy(o_ta,tlevSTD(:,:))
     1392          CALL histwrite_phy(o_zg,philevSTD(:,:))
     1393          CALL histwrite_phy(o_hus,qlevSTD(:,:))
     1394          CALL histwrite_phy(o_hur,rhlevSTD(:,:))
     1395          CALL histwrite_phy(o_ua,ulevSTD(:,:))
     1396          CALL histwrite_phy(o_va,vlevSTD(:,:))
     1397          CALL histwrite_phy(o_wap,wlevSTD(:,:))
     1398!         IF(vars_defined) THEN
     1399!            DO k=1, nlevSTD
     1400!               DO i=1, klon
     1401!                  IF(tnondef(i,k,3).NE.missing_val) THEN
     1402!                     IF(freq_outNMC(iff-6).LT.0) THEN
     1403!                        freq_moyNMC(iff-6)=(mth_len*un_jour)/freq_calNMC(iff-6)
     1404!                     ELSE
     1405!                        freq_moyNMC(iff-6)=freq_outNMC(iff-6)/freq_calNMC(iff-6)
     1406!                     ENDIF
     1407!                     zx_tmp_fi3d_STD(i,k) = (100.*tnondef(i,k,3))/freq_moyNMC(iff-6)
     1408!                  ELSE
     1409!                     zx_tmp_fi3d_STD(i,k) = missing_val
     1410!                  ENDIF
     1411!               ENDDO
     1412!            ENDDO
     1413!         ENDIF
     1414!         CALL histwrite_phy(o_psbg,zx_tmp_fi3d_STD)
     1415          IF(vars_defined) THEN
     1416             DO k=1, nlevSTD
     1417                DO i=1, klon
     1418                   IF(O3STD(i,k).NE.missing_val) THEN
     1419                      zx_tmp_fi3d_STD(i,k) = O3STD(i,k) * 1.e+9
     1420                   ELSE
     1421                      zx_tmp_fi3d_STD(i,k) = missing_val
     1422                   ENDIF
     1423                ENDDO
     1424             ENDDO !k=1, nlevSTD
     1425          ENDIF
     1426          CALL histwrite_phy(o_tro3,zx_tmp_fi3d_STD)
     1427          if (read_climoz == 2) THEN
     1428             IF(vars_defined) THEN
     1429                DO k=1, nlevSTD
     1430                   DO i=1, klon
     1431                      IF(O3daySTD(i,k).NE.missing_val) THEN
     1432                         zx_tmp_fi3d_STD(i,k) = O3daySTD(i,k) * 1.e+9
     1433                      ELSE
     1434                         zx_tmp_fi3d_STD(i,k) = missing_val
     1435                      ENDIF
     1436                   ENDDO
     1437                ENDDO !k=1, nlevSTD
     1438             ENDIF
     1439             CALL histwrite_phy(o_tro3_daylight,zx_tmp_fi3d_STD)
     1440          endif
     1441          CALL histwrite_phy(o_uxv,uvSTD(:,:))
     1442          CALL histwrite_phy(o_vxq,vqSTD(:,:))
     1443          CALL histwrite_phy(o_vxT,vTSTD(:,:))
     1444          CALL histwrite_phy(o_wxq,wqSTD(:,:))
     1445          CALL histwrite_phy(o_vxphi,vphiSTD(:,:))
     1446          CALL histwrite_phy(o_wxT,wTSTD(:,:))
     1447          CALL histwrite_phy(o_uxu,u2STD(:,:))
     1448          CALL histwrite_phy(o_vxv,v2STD(:,:))
     1449          CALL histwrite_phy(o_TxT,T2STD(:,:))
     1450!      ENDDO !nfiles
     1451  ENDIF
     1452#endif
    13321453!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    13331454        IF (nqtot.GE.nqo+1) THEN
    … …  
    13351456              IF (type_trac == 'lmdz' .OR. type_trac == 'repr') THEN
    13361457
    1337              CALL histwrite_phy(o_trac(iq-nqo), qx(:,:,iq))
     1458!jyg<
     1459!!             CALL histwrite_phy(o_trac(iq-nqo), qx(:,:,iq))
     1460             CALL histwrite_phy(o_trac(iq-nqo), tr_seri(:,:,iq-nqo))
     1461!>jyg
    13381462             CALL histwrite_phy(o_dtr_vdf(iq-nqo),d_tr_cl(:,:,iq-nqo))
    13391463             CALL histwrite_phy(o_dtr_the(iq-nqo),d_tr_th(:,:,iq-nqo))
    … …  
    13521476             IF(vars_defined) THEN
    13531477                DO k=1,klev
    1354                    zx_tmp_fi2d(:)=zx_tmp_fi2d(:)+zmasse(:,k)*qx(:,k,iq)
     1478!jyg<
     1479!!                   zx_tmp_fi2d(:)=zx_tmp_fi2d(:)+zmasse(:,k)*qx(:,k,iq)
     1480                   zx_tmp_fi2d(:)=zx_tmp_fi2d(:)+zmasse(:,k)*tr_seri(:,k,iq-nqo)
     1481!>jyg
    13551482                ENDDO
    13561483             ENDIF

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

    r2258 r2298  
    1010! Declaration des variables
    1111      USE dimphy
     12      USE netcdf, only: nf90_fill_real
    1213      INTEGER, PARAMETER :: nlevSTD=17
    1314      INTEGER, PARAMETER :: nlevSTD8=8
    … …  
    1617      INTEGER, PARAMETER :: napisccp=1
    1718      INTEGER, SAVE :: radpas
     19      REAL, PARAMETER :: missing_val_nf90=nf90_fill_real
    1820!$OMP THREADPRIVATE(radpas)
    1921      REAL, SAVE :: dtime, solaire_etat0
    … …  
    2426      REAL, ALLOCATABLE, SAVE :: ftsol(:,:)
    2527!$OMP THREADPRIVATE(ftsol)
     28      REAL,ALLOCATABLE,SAVE :: qsol(:),fevap(:,:),z0m(:,:),z0h(:,:),agesno(:,:)
     29!$OMP THREADPRIVATE(qsol,fevap,z0m,z0h,agesno)
    2630!      character(len=6), SAVE :: ocean
    2731!!!!!!$OMP THREADPRIVATE(ocean)
    … …  
    304308      REAL,ALLOCATABLE,SAVE :: sollwdown(:)
    305309!$OMP THREADPRIVATE(sollwdown)
     310      REAL,ALLOCATABLE,SAVE :: gustiness(:)
     311!$OMP THREADPRIVATE(gustiness)
    306312      REAL,ALLOCATABLE,SAVE :: sollwdownclr(:)
    307313!$OMP THREADPRIVATE(sollwdownclr)
    … …  
    416422      ALLOCATE(pctsrf(klon,nbsrf))
    417423      ALLOCATE(ftsol(klon,nbsrf))
     424      ALLOCATE(qsol(klon),fevap(klon,nbsrf))
     425      ALLOCATE(z0m(klon,nbsrf+1),z0h(klon,nbsrf+1),agesno(klon,nbsrf))
    418426      ALLOCATE(falb1(klon,nbsrf))
    419427      ALLOCATE(falb2(klon,nbsrf))
    … …  
    544552      ALLOCATE(albplap(klon))
    545553      ALLOCATE(solswp(klon), sollwp(klon))
     554      ALLOCATE(gustiness(klon))
    546555      ALLOCATE(sollwdownp(klon))
    547556      ALLOCATE(topsw0p(klon),toplw0p(klon))
    … …  
    586595
    587596      deallocate(rlat, rlon, pctsrf, ftsol, falb1, falb2)
     597      deallocate(qsol,fevap,z0m,z0h,agesno)
    588598      deallocate(rain_fall, snow_fall, solsw, sollw, radsol)
    589599      deallocate(zmea, zstd, zsig, zgam)
    … …  
    664674      deallocate(topsw, toplw)
    665675      deallocate(sollwdown, sollwdownclr)
     676      deallocate(gustiness)
    666677      deallocate(toplwdown, toplwdownclr)
    667678      deallocate(topsw0,toplw0,solsw0,sollw0)

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

    r2258 r2298  
    4747  use phyaqua_mod, only: zenang_an
    4848  USE control_mod
     49#ifdef CPP_XIOS
     50  USE wxios, ONLY: missing_val, missing_val_omp
     51  USE xios, ONLY: xios_get_field_attr
     52#endif
    4953#ifdef REPROBUS
    5054  USE CHEM_REP, ONLY : Init_chem_rep_xjour
    … …  
    240244  real da(klon,klev),phi(klon,klev,klev),mp(klon,klev)
    241245  real wght_cvfd(klon,klev)
     246#ifndef CPP_XIOS
     247  REAL, SAVE :: missing_val
     248#endif
    242249  ! Variables pour le lessivage convectif
    243250  ! RomP >>>
    … …  
    316323  SAVE top
    317324  !$OMP THREADPRIVATE(bas, top)
    318 
     325  !------------------------------------------------------------------
     326  ! Upmost level reached by deep convection and related variable (jyg)
     327  !
     328  INTEGER izero
     329  INTEGER k_upper_cv
     330  !------------------------------------------------------------------
    319331  !
    320332  !=================================================================================================
    … …  
    528540  !                            !par la masse/airetot (moyglo_pondaima) et la vraie masse (moyglo_pondmass)
    529541  !
    530   ! Variables locales
     542  !
     543!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     544  ! Local variables
     545!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    531546  !
    532547  REAL rhcl(klon,klev)    ! humiditi relative ciel clair
    … …  
    570585  REAL zx_t, zx_qs, zdelta, zcor, zlvdcp, zlsdcp
    571586  real zqsat(klon,klev)
     587!
    572588  INTEGER i, k, iq, ig, j, nsrf, ll, l, iiq
     589!
    573590  REAL t_coup
    574591  PARAMETER (t_coup=234.0)
    … …  
    885902     igout=klon/2+1/klon
    886903     write(lunout,*) 'DEBUT DE PHYSIQ !!!!!!!!!!!!!!!!!!!!'
     904     write(lunout,*) 'igout, rlat, rlon ',igout, rlatd(igout)*180./3.141593, rlond(igout)*180./3.141593
    887905     write(lunout,*) &
    888906          'nlon,klev,nqtot,debut,lafin, jD_cur, jH_cur,pdtphys'
    … …  
    904922
    905923  if (first) then
    906 
     924     
    907925     !CR:nvelles variables convection/poches froides
    908926
    … …  
    957975  pde_u(:,:) = 0.
    958976  aam=0.
     977
     978  alp_bl_conv(:)=0.
    959979
    960980  torsfc=0.
    … …  
    13321352     END IF
    13331353     !
    1334      !
    13351354!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    13361355     ! Nouvelle initialisation pour le rayonnement RRTM
    … …  
    14131432  !
    14141433  CALL change_srf_frac(itap, dtime, days_elapsed+1,  &
    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 <<<
     1434       pctsrf, fevap, z0m, z0h, agesno,              &
     1435       falb_dir, falb_dif, ftsol, ustar, u10m, v10m, pbl_tke)
    14191436
    14201437  ! Update time and other variables in Reprobus
    … …  
    15471564     ENDDO
    15481565!!! RomP >>>   td dyn traceur
    1549      IF (nqtot.GE.3) THEN
    1550         DO iq = 3, nqtot
     1566!!     IF (nqtot.GE.3) THEN       ! jyg
     1567!!        DO iq = 3, nqtot        ! jyg
     1568     IF (nqtot.GE.nqo+1) THEN     ! jyg
     1569        DO iq = nqo+1, nqtot      ! jyg
    15511570           DO k = 1, klev
    15521571              DO i = 1, klon
    1553                  d_tr_dyn(i,k,iq-2)= &
    1554                       (tr_seri(i,k,iq-2)-tr_ancien(i,k,iq-2))/dtime
     1572!!                 d_tr_dyn(i,k,iq-2)= &                                 ! jyg
     1573!!                      (tr_seri(i,k,iq-2)-tr_ancien(i,k,iq-2))/dtime    ! jyg
     1574                 d_tr_dyn(i,k,iq-nqo)= &                                 ! jyg
     1575                      (tr_seri(i,k,iq-nqo)-tr_ancien(i,k,iq-nqo))/dtime  ! jyg
    15551576                 !         iiq=niadv(iq)
    1556                  !         print*,i,k," d_tr_dyn",d_tr_dyn(i,k,iq-2),"tra:",iq,tname(iiq)
     1577                 !         print*,i,k," d_tr_dyn",d_tr_dyn(i,k,iq-nqo),"tra:",iq,tname(iiq)
    15571578              ENDDO
    15581579           ENDDO
    … …  
    15701591     ENDDO
    15711592!!! RomP >>>   td dyn traceur
    1572      IF (nqtot.GE.3) THEN
    1573         DO iq = 3, nqtot
     1593!!     IF (nqtot.GE.3) THEN                                            ! jyg
     1594!!        DO iq = 3, nqtot                                             ! jyg
     1595     IF (nqtot.GE.nqo+1) THEN                                          ! jyg
     1596        DO iq = nqo+1, nqtot                                           ! jyg
    15741597           DO k = 1, klev
    15751598              DO i = 1, klon
    1576                  d_tr_dyn(i,k,iq-2)= 0.0
     1599!!                 d_tr_dyn(i,k,iq-2)= 0.0                             ! jyg
     1600                 d_tr_dyn(i,k,iq-nqo)= 0.0                             ! jyg
    15771601              ENDDO
    15781602           ENDDO
    … …  
    18091833  !   s_capCL,   s_oliqCL,  s_cteiCL,s_pblT,
    18101834  !   s_therm,   s_trmb1,   s_trmb2, s_trmb3,
    1811   !   zxrugs,    zu10m,     zv10m,   fder,
     1835  !   zu10m,     zv10m,   fder,
    18121836  !   zxqsurf,   rh2m,      zxfluxu, zxfluxv,
    18131837  !   frugs,     agesno,    fsollw,  fsolsw,
    … …  
    18411865!>jyg+nrlmd
    18421866!
     1867!-------gustiness calculation-------!
     1868     IF (iflag_gusts==0) THEN
     1869        gustiness(1:klon)=0
     1870     ELSE IF (iflag_gusts==1) THEN
     1871        do i = 1, klon
     1872           gustiness(i)=f_gust_bl*ale_bl(i)+f_gust_wk*ale_wake(i)
     1873        enddo
     1874!     ELSE IF (iflag_gusts==2) THEN
     1875!        do i = 1, klon
     1876!           gustiness(i)=f_gust_bl*ale_bl(i)+sigma_wk(i)*f_gust_wk*ale_wake(i) !! need to make sigma_wk accessible here
     1877!        enddo
     1878!     ELSE IF (iflag_gusts==3) THEN
     1879!        do i = 1, klon
     1880!           gustiness(i)=f_gust_bl*alp_bl(i)+f_gust_wk*alp_wake(i)
     1881!        enddo
     1882     ENDIF
     1883
     1884
     1885
    18431886     CALL pbl_surface(  &
    18441887          dtime,     date0,     itap,    days_elapsed+1, &
    … …  
    18471890          zsig,      sollwdown, pphi,    cldt,      &
    18481891          rain_fall, snow_fall, solsw,   sollw,     &
     1892          gustiness,                                &
    18491893          t_seri,    q_seri,    u_seri,  v_seri,    &
    18501894!nrlmd+jyg<
    … …  
    18521896!>nrlmd+jyg
    18531897          pplay,     paprs,     pctsrf,             &
    1854 !albedo SB >>>
    1855 !          ftsol,falb1,falb2,ustar,u10m,v10m,wstar,  &
    18561898          ftsol,SFRWL,falb_dir,falb_dif,ustar,u10m,v10m,wstar, &
    18571899!albedo SB <<<
    … …  
    18821924          s_capCL,   s_oliqCL,  s_cteiCL,s_pblT, &
    18831925          s_therm,   s_trmb1,   s_trmb2, s_trmb3, &
    1884           zxrugs,    zustar, zu10m,     zv10m,   fder, &
     1926          zustar, zu10m,     zv10m,   fder, &
    18851927          zxqsurf,   rh2m,      zxfluxu, zxfluxv, &
    1886           frugs,     agesno,    fsollw,  fsolsw, &
     1928          z0m, z0h,     agesno,    fsollw,  fsolsw, &
    18871929          d_ts,      fevap,     fluxlat, t2m, &
    18881930          wfbils,    wfbilo,    fluxt,   fluxu,  fluxv, &
    … …  
    21512193        ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    21522194! Estimation d'une vitesse verticale effective pour ALP
     2195        if (1==0) THEN
    21532196        www(1:klon)=0.
    21542197        do k=2,klev-1
    … …  
    21662209           if (www(i)>0. .and. ale_bl(i)>0. ) www(i)=www(i)/ale_bl(i)
    21672210        enddo
     2211        ENDIF
    21682212
    21692213
    … …  
    21782222              ALP(i) = alp_wake(i) + Alp_bl(i) + alp_offset ! modif sb
    21792223           else
     2224       abort_message ='Ne pas passer la car www non calcule'
     2225       CALL abort_gcm (modname,abort_message,1)
    21802226
    21812227!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    … …  
    22222268     !
    22232269     IF (ok_cvl) THEN ! new driver for convectL
    2224 
     2270     !
     2271!jyg<
     2272!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     2273     ! Calculate the upmost level of deep convection loops: k_upper_cv
     2274     !  (near 22 km)
     2275   izero = klon/2+1/klon
     2276   k_upper_cv = klev
     2277   DO k = klev,1,-1
     2278     IF (pphi(izero,k) > 22.e4) k_upper_cv = k
     2279   ENDDO
     2280   IF (prt_level .ge. 5) THEN
     2281     Print *, 'upmost level of deep convection loops: k_upper_cv = ',k_upper_cv
     2282   ENDIF
     2283     !
     2284!>jyg
    22252285        IF (type_trac == 'repr') THEN
    22262286           nbtr_tmp=ntra
    … …  
    22312291        !c          CALL concvl (iflag_con,iflag_clos,
    22322292        CALL concvl (iflag_clos, &
    2233              dtime,paprs,pplay,t_undi,q_undi, &
     2293             dtime, paprs, pplay, k_upper_cv, t_undi,q_undi, &
    22342294             t_wake,q_wake,wake_s, &
    22352295             u_seri,v_seri,tr_seri,nbtr_tmp, &
    … …  
    33823442!albedo SB <<<
    33833443
    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 <<<
    33963444
    33973445     if (mydebug) then
    … …  
    39353983  !IM Interpolation sur les niveaux de pression du NMC
    39363984  !   -------------------------------------------------
     3985#ifdef CPP_XIOS
     3986          !$OMP MASTER
     3987          !On recupere la valeur de la missing value donnee dans le xml
     3988          CALL xios_get_field_attr("t850",default_value=missing_val_omp)
     3989!         PRINT *,"ARNAUD value missing ",missing_val_omp
     3990          !$OMP END MASTER
     3991          !$OMP BARRIER
     3992          missing_val=missing_val_omp
     3993#endif
     3994#ifndef CPP_XIOS
     3995          missing_val=missing_val_nf90
     3996#endif
    39373997  !
    39383998  include "calcul_STDlev.h"
    … …  
    43134373  ENDDO
    43144374  RETURN
    4315 END SUBROUTINE gr_fi_ecrit
     4375  END SUBROUTINE gr_fi_ecrit
     4376

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

    r2220 r2298  
    769769             ! Liu (2001) proposed to use 1.5e-3 kg/kg
    770770
    771              CALL lsc_scav(pdtphys,it,iflag_lscav,ql_incl,prfl,psfl,rneb,beta_fisrt,  &
     771!jyg<
     772!!             CALL lsc_scav(pdtphys,it,iflag_lscav,ql_incl,prfl,psfl,rneb,beta_fisrt,  &
     773             CALL lsc_scav(pdtphys,it,iflag_lscav,aerosol,ql_incl,prfl,psfl,rneb,beta_fisrt,  &
     774!>jyg
    772775                  beta_v1,pplay,paprs,t_seri,tr_seri,d_tr_insc,   &
    773776                  d_tr_bcscav,d_tr_evapls,qPrls)

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

    r1999 r2298  
    99  USE netcdf
    1010  USE dimphy
     11#ifdef CPP_IOIPSL
     12  USE phys_state_var_mod, ONLY: missing_val_nf90
     13#endif
     14#ifdef CPP_XIOS
     15  USE wxios, ONLY: missing_val
     16#endif
    1117  IMPLICIT NONE
    1218
    … …  
    5662  INTEGER i, k
    5763
    58   REAL missing_val
     64! REAL missing_val
     65#ifndef CPP_XIOS
     66  REAL :: missing_val
     67#endif
    5968
    60   missing_val = nf90_fill_real
     69! missing_val = nf90_fill_real
     70
     71#ifndef CPP_XIOS
     72      missing_val=missing_val_nf90
     73#endif
    6174
    6275  IF (first) THEN

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

    r1999 r2298  
    1010  USE netcdf
    1111  USE dimphy
     12#ifdef CPP_IOIPSL
     13  USE phys_state_var_mod, ONLY: missing_val_nf90
     14#endif
     15#ifdef CPP_XIOS
     16  USE wxios, ONLY: missing_val
     17#endif
     18
    1219  IMPLICIT NONE
    1320
    … …  
    5865  INTEGER i, k
    5966
    60   REAL missing_val
     67! REAL missing_val
     68#ifndef CPP_XIOS
     69  REAL :: missing_val
     70#endif
    6171
    62   missing_val = nf90_fill_real
     72! missing_val = nf90_fill_real
     73
     74#ifndef CPP_XIOS
     75      missing_val=missing_val_nf90
     76#endif
    6377
    6478  IF (first) THEN

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

    r2258 r2298  
    44      SUBROUTINE screenc(klon, knon, nsrf, zxli, &
    55                         speed, temp, q_zref, zref, &
    6                          ts, qsurf, rugos, psol, &
     6                         ts, qsurf, z0m, z0h, psol, &
    77                         ustar, testar, qstar, okri, ri1, &
    88                         pref, delu, delte, delq)
    … …  
    3030! ts------input-R- temperature de l'air a la surface
    3131! qsurf---input-R- humidite relative a la surface
    32 ! rugos---input-R- rugosite
     32! z0m, z0h---input-R- rugosite
    3333! psol----input-R- pression au sol
    3434! ustar---input-R- facteur d'echelle pour le vent
    … …  
    4848      REAL, dimension(klon), intent(in) :: speed, temp, q_zref
    4949      REAL, intent(in) :: zref
    50       REAL, dimension(klon), intent(in) :: ts, qsurf, rugos, psol
     50      REAL, dimension(klon), intent(in) :: ts, qsurf, z0m, z0h, psol
    5151      REAL, dimension(klon), intent(in) :: ustar, testar, qstar, ri1         
    5252!
    … …  
    7575      CALL cdrag (knon, nsrf, &
    7676                    speed, temp, q_zref, gref, &
    77                     psol, ts, qsurf, rugos, &
     77                    psol, ts, qsurf, z0m, z0h, &
    7878                    cdram, cdrah, zri1, pref)
    7979      DO i = 1, knon

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

    r2258 r2298  
    44      SUBROUTINE stdlevvar(klon, knon, nsrf, zxli, &
    55                           u1, v1, t1, q1, z1, &
    6                            ts1, qsurf, rugos, psol, pat1, &
     6                           ts1, qsurf, z0m, z0h, psol, pat1, &
    77                           t_2m, q_2m, t_10m, q_10m, u_10m, ustar)
    88      IMPLICIT NONE
    … …  
    3232! ts1-----input-R- temperature de l'air a la surface
    3333! qsurf---input-R- humidite relative a la surface
    34 ! rugos---input-R- rugosite
     34! z0m, z0h---input-R- rugosite
    3535! psol----input-R- pression au sol
    3636! pat1----input-R- pression au 1er niveau du modele
    … …  
    4747      LOGICAL, intent(in) :: zxli
    4848      REAL, dimension(klon), intent(in) :: u1, v1, t1, q1, z1, ts1
    49       REAL, dimension(klon), intent(in) :: qsurf, rugos
     49      REAL, dimension(klon), intent(in) :: qsurf, z0m, z0h
    5050      REAL, dimension(klon), intent(in) :: psol, pat1
    5151!
    … …  
    103103! &                   cdram, cdrah, cdran, zri1, pref)           
    104104! Fuxing WANG, 04/03/2015, replace the coefcdrag by the merged version: cdrag
     105
    105106      CALL cdrag(knon, nsrf, &
    106107 &                   speed, t1, q1, z1, &
    107  &                   psol, ts1, qsurf, rugos, &
     108 &                   psol, ts1, qsurf, z0m, z0h, &
    108109 &                   cdram, cdrah, zri1, pref)
    109110
    … …  
    139140      zref = 2.0
    140141      CALL screenp(klon, knon, nsrf, speed, tpot, q1, &
    141  &                 ts1, qsurf, rugos, lmon, &
     142 &                 ts1, qsurf, z0m, lmon, &
    142143 &                 ustar, testar, qstar, zref, &
    143144 &                 delu, delte, delq)
    … …  
    160161        CALL screenc(klon, knon, nsrf, zxli, &
    161162 &                   u_zref, temp, q_zref, zref, &
    162  &                   ts1, qsurf, rugos, psol, &           
     163 &                   ts1, qsurf, z0m, z0h, psol, &           
    163164 &                   ustar, testar, qstar, okri, ri1, &
    164165 &                   pref, delu, delte, delq)
    … …  
    241242      zref = 10.0
    242243      CALL screenp(klon, knon, nsrf, speed, tpot, q1, &
    243  &                 ts1, qsurf, rugos, lmon, &
     244 &                 ts1, qsurf, z0m, lmon, &
    244245 &                 ustar, testar, qstar, zref, &
    245246 &                 delu, delte, delq)
    … …  
    262263        CALL screenc(klon, knon, nsrf, zxli, &
    263264 &                   u_zref, temp, q_zref, zref, &
    264  &                   ts1, qsurf, rugos, psol, &
     265 &                   ts1, qsurf, z0m, z0h, psol, &
    265266 &                   ustar, testar, qstar, okri, ri1, &
    266267 &                   pref, delu, delte, delq)

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

    r1910 r2298  
    1313       tsurf, p1lay, tq_cdrag, precip_rain, precip_snow, temp_air, &
    1414       spechum, petAcoef, peqAcoef, petBcoef, peqBcoef, pref, &
    15        u1, v1, rugoro, swnet, lwnet, &
     15       u1, v1, gustiness, rugoro, swnet, lwnet, &
    1616       snow, qsol, agesno, tsoil, &
    1717       qsurf, z0_new, alb1_new, alb2_new, evap, &
    … …  
    4949    REAL, DIMENSION(klon), INTENT(IN)       :: petBcoef, peqBcoef
    5050    REAL, DIMENSION(klon), INTENT(IN)       :: pref
    51     REAL, DIMENSION(klon), INTENT(IN)       :: u1, v1
     51    REAL, DIMENSION(klon), INTENT(IN)       :: u1, v1, gustiness
    5252    REAL, DIMENSION(klon), INTENT(IN)       :: rugoro
    5353    REAL, DIMENSION(klon), INTENT(IN)       :: swnet, lwnet
    … …  
    9999    CALL calbeta(dtime, is_ter, knon, snow, qsol, beta, capsol, dif_grnd)
    100100    if (type_veget=='betaclim') then
    101        CALL calbeta_clim(knon,jour,rlatd(knindex(:)),beta)
     101       CALL calbeta_clim(knon,jour,rlatd(knindex(1:knon)),beta)
    102102    endif
    103103       
    … …  
    123123
    124124    CALL calcul_fluxs(knon, is_ter, dtime, &
    125          tsurf, p1lay, cal, beta, tq_cdrag, pref, &
     125         tsurf, p1lay, cal, beta, tq_cdrag, tq_cdrag, pref, &
    126126         precip_rain, precip_snow, snow, qsurf,  &
    127          radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, &
    128          petAcoef, peqAcoef, petBcoef, peqBcoef, &
     127         radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, gustiness, &
     128         1.,petAcoef, peqAcoef, petBcoef, peqBcoef, &
    129129         tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l)
    130130   

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

    r2258 r2298  
    1414       AcoefH, AcoefQ, BcoefH, BcoefQ, &
    1515       AcoefU, AcoefV, BcoefU, BcoefV, &
    16        pref, u1, v1, rugoro, pctsrf, &
     16       pref, u1, v1, gustiness, rugoro, pctsrf, &
    1717       lwdown_m, q2m, t2m, &
    1818       snow, qsol, agesno, tsoil, &
    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 <<<
     19       z0m, z0h, SFRWL, alb_dir_new, alb_dif_new, evap, fluxsens, fluxlat, &   
    2320       qsurf, tsurf_new, dflux_s, dflux_l, &
    2421       flux_u1, flux_v1 )
    … …  
    6158    REAL, DIMENSION(klon), INTENT(IN)       :: AcoefU, AcoefV, BcoefU, BcoefV
    6259    REAL, DIMENSION(klon), INTENT(IN)       :: pref   ! pressure reference
    63     REAL, DIMENSION(klon), INTENT(IN)       :: u1, v1
     60    REAL, DIMENSION(klon), INTENT(IN)       :: u1, v1, gustiness
    6461    REAL, DIMENSION(klon), INTENT(IN)       :: rugoro
    6562    REAL, DIMENSION(klon,nbsrf), INTENT(IN) :: pctsrf
    … …  
    7673! Output variables
    7774!****************************************************************************************
    78     REAL, DIMENSION(klon), INTENT(OUT)       :: z0_new
     75    REAL, DIMENSION(klon), INTENT(OUT)       :: z0m, z0h
    7976!albedo SB >>>
    8077!    REAL, DIMENSION(klon), INTENT(OUT)       :: alb1_new ! albdeo for shortwave interval 1(visible)
    … …  
    137134            knindex, rlon, rlat, pctsrf, &
    138135            debut, lafin, &
    139             zlev,  u1, v1, temp_air, spechum, epot_air, ccanopy, &
     136            zlev,  u1, v1, gustiness, temp_air, spechum, epot_air, ccanopy, &
    140137            cdragh, AcoefH, AcoefQ, BcoefH, BcoefQ, &
    141138            precip_rain, precip_snow, lwdown_m, swnet, swdown, &
    … …  
    143140            evap, fluxsens, fluxlat, &             
    144141            tsol_rad, tsurf_new, alb1_new, alb2_new, &
    145             emis_new, z0_new, qsurf)       
     142            emis_new, z0m, qsurf)       
     143        z0h(1:knon)=z0m(1:knon) ! En attendant mieux
    146144
    147145! 
    … …  
    149147! 
    150148       DO i=1,knon
    151           z0_new(i) = MAX(1.5e-05,SQRT(z0_new(i)**2 + rugoro(i)**2))
     149          z0m(i) = MAX(1.5e-05,SQRT(z0m(i)**2 + rugoro(i)**2))
    152150       ENDDO
    153151
    … …  
    160158            tsurf, p1lay, cdragh, precip_rain, precip_snow, temp_air, &
    161159            spechum, AcoefH, AcoefQ, BcoefH, BcoefQ, pref, &
    162             u1, v1, rugoro, swnet, lwnet, &
     160            u1, v1, gustiness, rugoro, swnet, lwnet, &
    163161            snow, qsol, agesno, tsoil, &
    164             qsurf, z0_new, alb1_new, alb2_new, evap, &
     162            qsurf, z0m, alb1_new, alb2_new, evap, &
    165163            fluxsens, fluxlat, tsurf_new, dflux_s, dflux_l)
     164        z0h(1:knon)=z0m(1:knon) ! En attendant mieux
    166165
    167166    ENDIF ! ok_veget
    … …  
    175174    v0(:)=0.0
    176175    CALL calcul_flux_wind(knon, dtime, &
    177          u0, v0, u1, v1, cdragm, &
     176         u0, v0, u1, v1, gustiness, cdragm, &
    178177         AcoefU, AcoefV, BcoefU, BcoefV, &
    179178         p1lay, temp_air, &

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

    r2160 r2298  
    3333       knindex, rlon, rlat, pctsrf, &
    3434       debut, lafin, &
    35        plev,  u1_lay, v1_lay, temp_air, spechum, epot_air, ccanopy, &
     35       plev,  u1_lay, v1_lay, gustiness, temp_air, spechum, epot_air, ccanopy, &
    3636       tq_cdrag, petAcoef, peqAcoef, petBcoef, peqBcoef, &
    3737       precip_rain, precip_snow, lwdown, swnet, swdown, &
    … …  
    115115    REAL, DIMENSION(klon), INTENT(IN)         :: rlon, rlat
    116116    REAL, DIMENSION(klon), INTENT(IN)         :: plev
    117     REAL, DIMENSION(klon), INTENT(IN)         :: u1_lay, v1_lay
     117    REAL, DIMENSION(klon), INTENT(IN)         :: u1_lay, v1_lay, gustiness
    118118    REAL, DIMENSION(klon), INTENT(IN)         :: temp_air, spechum
    119119    REAL, DIMENSION(klon), INTENT(IN)         :: epot_air, ccanopy

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

    r2258 r2298  
    1515       AcoefH, AcoefQ, BcoefH, BcoefQ, &
    1616       AcoefU, AcoefV, BcoefU, BcoefV, &
    17        ps, u1, v1, rugoro, pctsrf, &
     17       ps, u1, v1, gustiness, rugoro, pctsrf, &
    1818       snow, qsurf, qsol, agesno, &
    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 <<<
     19       tsoil, z0m, z0h, SFRWL, alb_dir, alb_dif, evap, fluxsens, fluxlat, &
    2320       tsurf_new, dflux_s, dflux_l, &
    2421       slope, cloudf, &
    … …  
    5956    REAL, DIMENSION(klon), INTENT(IN)             :: AcoefU, AcoefV, BcoefU, BcoefV
    6057    REAL, DIMENSION(klon), INTENT(IN)             :: ps
    61     REAL, DIMENSION(klon), INTENT(IN)             :: u1, v1
     58    REAL, DIMENSION(klon), INTENT(IN)             :: u1, v1, gustiness
    6259    REAL, DIMENSION(klon), INTENT(IN)             :: rugoro
    6360    REAL, DIMENSION(klon,nbsrf), INTENT(IN)       :: pctsrf
    … …  
    8279!****************************************************************************************
    8380    REAL, DIMENSION(klon), INTENT(OUT)            :: qsurf
    84     REAL, DIMENSION(klon), INTENT(OUT)            :: z0_new
     81    REAL, DIMENSION(klon), INTENT(OUT)            :: z0m, z0h
    8582!albedo SB >>>
    8683!    REAL, DIMENSION(klon), INTENT(OUT)            :: alb1  ! new albedo in visible SW interval
    … …  
    182179          tsoil0(i,:)=tsoil(i,:)
    183180       END DO
    184            ! Martin
    185            PRINT*, 'on appelle surf_sisvat'
    186            ! Martin
     181           ! Martin
     182           PRINT*, 'on appelle surf_sisvat'
     183           ! Martin
    187184       CALL surf_sisvat(knon, rlon, rlat, knindex, itime, dtime, debut, lafin, &
    188185            rmu0, swdown, lwdown, pexner, ps, p1lay, &
    … …  
    194191            run_off_lic, evap, fluxsens, fluxlat, dflux_s, dflux_l, &       
    195192            tsurf_new, alb1, alb2, alb3, &
    196             emis_new, z0_new, qsurf)
     193            emis_new, z0m, qsurf)
     194       z0h(1:knon)=z0m(1:knon) ! en attendant mieux
    197195       
    198196       ! Suppose zero surface speed
    … …  
    205203       
    206204       CALL calcul_flux_wind(knon, dtime, &
    207             u0, v0, u1, v1, cdragm, &
     205            u0, v0, u1, v1, gustiness, cdragm, &
    208206            AcoefU, AcoefV, BcoefU, BcoefV, &
    209207            p1lay, temp_air, &
    … …  
    243241
    244242    CALL calcul_fluxs(knon, is_lic, dtime, &
    245          tsurf, p1lay, cal, beta, cdragh, ps, &
     243         tsurf, p1lay, cal, beta, cdragh, cdragh, ps, &
    246244         precip_rain, precip_snow, snow, qsurf,  &
    247          radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, &
    248          AcoefH, AcoefQ, BcoefH, BcoefQ, &
     245         radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, gustiness, &
     246         1.,AcoefH, AcoefQ, BcoefH, BcoefQ, &
    249247         tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l)
    250248
    251249    CALL calcul_flux_wind(knon, dtime, &
    252          u0, v0, u1, v1, cdragm, &
     250         u0, v0, u1, v1, gustiness, cdragm, &
    253251         AcoefU, AcoefV, BcoefU, BcoefV, &
    254252         p1lay, temp_air, &
    … …  
    290288!
    291289!****************************************************************************************
    292     z0_new(:) = MAX(1.E-3,rugoro(:))
     290    z0m=1.e-3
     291    z0h = z0m
     292    z0m = SQRT(z0m**2+rugoro**2)
     293
    293294    END IF ! ok_snow
    294295

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

    r2258 r2298  
    66CONTAINS
    77!
    8 !****************************************************************************************
     8!******************************************************************************
    99!
    1010  SUBROUTINE surf_ocean(rlon, rlat, swnet, lwnet, alb1, &
    11        rugos, windsp, rmu0, fder, tsurf_in, &
     11       windsp, rmu0, fder, tsurf_in, &
    1212       itime, dtime, jour, knon, knindex, &
    13        p1lay, cdragh, cdragm, precip_rain, precip_snow, temp_air, spechum, &
     13       p1lay, z1lay, cdragh, cdragm, precip_rain, precip_snow, temp_air, spechum, &
    1414       AcoefH, AcoefQ, BcoefH, BcoefQ, &
    1515       AcoefU, AcoefV, BcoefU, BcoefV, &
    16        ps, u1, v1, rugoro, pctsrf, &
     16       ps, u1, v1, gustiness, rugoro, pctsrf, &
    1717       snow, qsurf, agesno, &
    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 <<<
     18       z0m, z0h, SFRWL, alb_dir_new, alb_dif_new, evap, fluxsens, fluxlat, &
    2219       tsurf_new, dflux_s, dflux_l, lmt_bils, &
    2320       flux_u1, flux_v1)
    … …  
    4138
    4239! Input variables
    43 !****************************************************************************************
     40!******************************************************************************
    4441    INTEGER, INTENT(IN)                      :: itime, jour, knon
    4542    INTEGER, DIMENSION(klon), INTENT(IN)     :: knindex
    … …  
    4946    REAL, DIMENSION(klon), INTENT(IN)        :: lwnet  ! net longwave radiation at surface 
    5047    REAL, DIMENSION(klon), INTENT(IN)        :: alb1   ! albedo in visible SW interval
    51     REAL, DIMENSION(klon), INTENT(IN)        :: rugos
    5248    REAL, DIMENSION(klon), INTENT(IN)        :: windsp
    5349    REAL, DIMENSION(klon), INTENT(IN)        :: rmu0 
    5450    REAL, DIMENSION(klon), INTENT(IN)        :: fder
    5551    REAL, DIMENSION(klon), INTENT(IN)        :: tsurf_in
    56     REAL, DIMENSION(klon), INTENT(IN)        :: p1lay
     52    REAL, DIMENSION(klon), INTENT(IN)        :: p1lay,z1lay ! pression (Pa) et altitude (m) du premier niveau
    5753    REAL, DIMENSION(klon), INTENT(IN)        :: cdragh
    5854    REAL, DIMENSION(klon), INTENT(IN)        :: cdragm
    … …  
    6258    REAL, DIMENSION(klon), INTENT(IN)        :: AcoefU, AcoefV, BcoefU, BcoefV
    6359    REAL, DIMENSION(klon), INTENT(IN)        :: ps
    64     REAL, DIMENSION(klon), INTENT(IN)        :: u1, v1
     60    REAL, DIMENSION(klon), INTENT(IN)        :: u1, v1, gustiness
    6561    REAL, DIMENSION(klon), INTENT(IN)        :: rugoro
    6662    REAL, DIMENSION(klon,nbsrf), INTENT(IN)  :: pctsrf
    6763
    6864! In/Output variables
    69 !****************************************************************************************
     65!******************************************************************************
    7066    REAL, DIMENSION(klon), INTENT(INOUT)     :: snow
    7167    REAL, DIMENSION(klon), INTENT(INOUT)     :: qsurf
    … …  
    7369
    7470! Output variables
    75 !****************************************************************************************
    76     REAL, DIMENSION(klon), INTENT(OUT)       :: z0_new
     71!******************************************************************************
     72    REAL, DIMENSION(klon), INTENT(OUT)       :: z0m, z0h
    7773!albedo SB >>>
    7874!    REAL, DIMENSION(klon), INTENT(OUT)       :: alb1_new  ! new albedo in visible SW interval
    … …  
    8884
    8985! Local variables
    90 !****************************************************************************************
     86!******************************************************************************
    9187    INTEGER               :: i, k
    9288    REAL                  :: tmp
    … …  
    9490    REAL, DIMENSION(klon) :: alb_eau
    9591    REAL, DIMENSION(klon) :: radsol
     92    REAL, DIMENSION(klon) :: cdragq ! Cdrag pour l'evaporation
    9693
    9794! End definition
    98 !****************************************************************************************
    99 
    100 
    101 !****************************************************************************************
     95!******************************************************************************
     96
     97
     98!******************************************************************************
    10299! Calculate total net radiance at surface
    103100!
    104 !****************************************************************************************
     101!******************************************************************************
    105102    radsol(:) = 0.0
    106103    radsol(1:knon) = swnet(1:knon) + lwnet(1:knon)
    107104
    108 !****************************************************************************************
     105!******************************************************************************
     106! Cdragq computed from cdrag
     107! The difference comes only from a factor (f_z0qh_oce) on z0, so that
     108! it can be computed inside surf_ocean
     109! More complicated appraches may require the propagation through
     110! pbl_surface of an independant cdragq variable.
     111!******************************************************************************
     112
     113    IF ( f_z0qh_oce .ne. 1.) THEN
     114! Si on suit les formulations par exemple de Tessel, on
     115! a z0h=0.4*nu/u*, z0q=0.62*nu/u*, d'ou f_z0qh_oce=0.62/0.4=1.55
     116       cdragq(:)=cdragh(:)*                                      &
     117       log(z1lay(:)/z0h(:))/log(z1lay(:)/(f_z0qh_oce*z0h(:)))
     118    ELSE
     119       cdragq(:)=cdragh(:)
     120    ENDIF
     121
     122!******************************************************************************
    109123! Switch according to type of ocean (couple, slab or forced)
    110 !****************************************************************************************
     124!******************************************************************************
    111125    SELECT CASE(type_ocean)
    112126    CASE('couple')
    … …  
    115129            windsp, fder, &
    116130            itime, dtime, knon, knindex, &
    117             p1lay, cdragh, cdragm, precip_rain, precip_snow,temp_air,spechum,&
     131            p1lay, cdragh, cdragq, cdragm, precip_rain, precip_snow,temp_air,spechum,&
    118132            AcoefH, AcoefQ, BcoefH, BcoefQ, &
    119133            AcoefU, AcoefV, BcoefU, BcoefV, &
    120             ps, u1, v1, &
     134            ps, u1, v1, gustiness, &
    121135            radsol, snow, agesno, &
    122136            qsurf, evap, fluxsens, fluxlat, flux_u1, flux_v1, &
    … …  
    126140       CALL ocean_slab_noice( &
    127141            itime, dtime, jour, knon, knindex, &
    128             p1lay, cdragh, cdragm, precip_rain, precip_snow, temp_air, spechum,&
     142            p1lay, cdragh, cdragq, cdragm, precip_rain, precip_snow, temp_air, spechum,&
    129143            AcoefH, AcoefQ, BcoefH, BcoefQ, &
    130144            AcoefU, AcoefV, BcoefU, BcoefV, &
    131             ps, u1, v1, tsurf_in, &
     145            ps, u1, v1, gustiness, tsurf_in, &
    132146            radsol, snow, &
    133147            qsurf, evap, fluxsens, fluxlat, flux_u1, flux_v1, &
    … …  
    137151       CALL ocean_forced_noice( &
    138152            itime, dtime, jour, knon, knindex, &
    139             p1lay, cdragh, cdragm, precip_rain, precip_snow, &
     153            p1lay, cdragh, cdragq, cdragm, precip_rain, precip_snow, &
    140154            temp_air, spechum, &
    141155            AcoefH, AcoefQ, BcoefH, BcoefQ, &
    142156            AcoefU, AcoefV, BcoefU, BcoefV, &
    143             ps, u1, v1, &
     157            ps, u1, v1, gustiness, &
    144158            radsol, snow, agesno, &
    145159            qsurf, evap, fluxsens, fluxlat, flux_u1, flux_v1, &
    … …  
    147161    END SELECT
    148162
    149 !****************************************************************************************
     163!******************************************************************************
    150164! fcodron: compute lmt_bils  forced case (same as wfbils_oce / 1.-contfracatm)
    151 !****************************************************************************************
     165!******************************************************************************
    152166    IF (type_ocean.NE.'slab') THEN
    153167        lmt_bils(:)=0.
    … …  
    158172    END IF
    159173
    160 !****************************************************************************************
     174!******************************************************************************
    161175! Calculate albedo
    162 !
    163 !****************************************************************************************
     176!******************************************************************************
    164177!albedo SB >>>
    165 
    166 
    167178  if(iflag_albedo==1)then
    168179    call ocean_albedo(knon,rmu0,knindex,windsp,SFRWL,alb_dir_new,alb_dif_new)
    … …  
    184195!albedo SB <<<
    185196
    186 !****************************************************************************************
     197!******************************************************************************
    187198! Calculate the rugosity
    188 !
    189 !****************************************************************************************
     199!******************************************************************************
     200IF (iflag_z0_oce==0) THEN
    190201    DO i = 1, knon
    191        tmp = MAX(cepdu2,u1(i)**2+v1(i)**2)
    192        z0_new(i) = 0.018*cdragm(i) * (u1(i)**2+v1(i)**2)/RG  &
     202       tmp = MAX(cepdu2,gustiness(i)+u1(i)**2+v1(i)**2)
     203       z0m(i) = 0.018*cdragm(i) * (gustiness(i)+u1(i)**2+v1(i)**2)/RG  &
    193204            +  0.11*14e-6 / SQRT(cdragm(i) * tmp)
    194        z0_new(i) = MAX(1.5e-05,z0_new(i))
     205       z0m(i) = MAX(1.5e-05,z0m(i))
    195206    ENDDO   
    196 !
    197 !****************************************************************************************
    198 !   
     207    z0h(1:knon)=z0m(1:knon) ! En attendant mieux
     208
     209ELSE IF (iflag_z0_oce==1) THEN
     210    DO i = 1, knon
     211       tmp = MAX(cepdu2,gustiness(i)+u1(i)**2+v1(i)**2)
     212       z0m(i) = 0.018*cdragm(i) * (gustiness(i)+u1(i)**2+v1(i)**2)/RG  &
     213            + 0.11*14e-6 / SQRT(cdragm(i) * tmp)
     214       z0m(i) = MAX(1.5e-05,z0m(i))
     215       z0h(i)=0.4*14e-6 / SQRT(cdragm(i) * tmp)
     216    ENDDO
     217ELSE
     218       STOP'version non prevue'
     219ENDIF
     220!
     221!******************************************************************************
    199222  END SUBROUTINE surf_ocean
    200 !
    201 !****************************************************************************************
     223!******************************************************************************
    202224!
    203225END MODULE surf_ocean_mod

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

    r2258 r2298  
    1717       AcoefH, AcoefQ, BcoefH, BcoefQ, &
    1818       AcoefU, AcoefV, BcoefU, BcoefV, &
    19        ps, u1, v1, rugoro, pctsrf, &
     19       ps, u1, v1, gustiness, pctsrf, &
    2020       snow, qsurf, qsol, agesno, tsoil, &
    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 <<<
     21       z0m, z0h, SFRWL, alb_dir_new, alb_dif_new, evap, fluxsens, fluxlat, & 
    2522       tsurf_new, dflux_s, dflux_l, &
    2623       flux_u1, flux_v1)
    … …  
    6057    REAL, DIMENSION(klon), INTENT(IN)        :: AcoefU, AcoefV, BcoefU, BcoefV
    6158    REAL, DIMENSION(klon), INTENT(IN)        :: ps
    62     REAL, DIMENSION(klon), INTENT(IN)        :: u1, v1
    63     REAL, DIMENSION(klon), INTENT(IN)        :: rugoro
     59    REAL, DIMENSION(klon), INTENT(IN)        :: u1, v1, gustiness
    6460    REAL, DIMENSION(klon,nbsrf), INTENT(IN)  :: pctsrf
    6561
    … …  
    7268! Output arguments
    7369!****************************************************************************************
    74     REAL, DIMENSION(klon), INTENT(OUT)       :: z0_new
     70    REAL, DIMENSION(klon), INTENT(OUT)       :: z0m, z0h
    7571!albedo SB >>>
    7672!    REAL, DIMENSION(klon), INTENT(OUT)       :: alb1_new  ! new albedo in visible SW interval
    … …  
    117113            AcoefH, AcoefQ, BcoefH, BcoefQ, &
    118114            AcoefU, AcoefV, BcoefU, BcoefV, &
    119             ps, u1, v1, pctsrf, &
     115            ps, u1, v1, gustiness, pctsrf, &
    120116            radsol, snow, qsurf, &
    121117            alb1_new, alb2_new, evap, fluxsens, fluxlat, flux_u1, flux_v1, &
    … …  
    128124          AcoefH, AcoefQ, BcoefH, BcoefQ, &
    129125            AcoefU, AcoefV, BcoefU, BcoefV, &
    130           ps, u1, v1, &
     126          ps, u1, v1, gustiness, &
    131127          radsol, snow, qsurf, qsol, agesno, &
    132128          alb1_new, alb2_new, evap, fluxsens, fluxlat, flux_u1, flux_v1, &
    … …  
    139135            AcoefH, AcoefQ, BcoefH, BcoefQ, &
    140136            AcoefU, AcoefV, BcoefU, BcoefV, &
    141             ps, u1, v1, &
     137            ps, u1, v1, gustiness, &
    142138            radsol, snow, qsol, agesno, tsoil, &
    143139            qsurf, alb1_new, alb2_new, evap, fluxsens, fluxlat, flux_u1, flux_v1, &
    … …  
    150146!
    151147!****************************************************************************************
    152     z0_new = 0.002
    153     z0_new = SQRT(z0_new**2+rugoro**2)
    154148
     149    z0m=z0m_seaice
     150    z0h = z0h_seaice
    155151
    156152!albedo SB >>>

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

    r2220 r2298  
    66     &           lalim,f0,detr_star,entr_star,f_star,csc,ztva,  &
    77     &           ztla,zqla,zqta,zha,zw2,w_est,ztva_est,zqsatth,lmix,lmix_bis,linter &
    8      &           ,lev_out,lunout1,igout)
    9 !    &           ,lev_out,lunout1,igout,zbuoy,zbuoyjam)
     8    &           ,lev_out,lunout1,igout)
     9!     &           ,lev_out,lunout1,igout,zbuoy,zbuoyjam)
    1010!--------------------------------------------------------------------------
    1111!thermcell_plume: calcule les valeurs de qt, thetal et w dans l ascendance
    … …  
    8787      real ztv_est1,ztv_est2
    8888      real zcor,zdelta,zcvm5,qlbef
    89       real zbetalpha
     89      real zbetalpha, coefzlmel
    9090      real eps
    9191      REAL REPS,RLvCp,DDT0
    … …  
    396396        else  !   if (iflag_thermals_ed.lt.8) then
    397397           lt=l+1
     398           zlt=zlev(ig,lt)
    398399           zdz2=zlev(ig,lt)-zlev(ig,l)
    399400
    … …  
    405406           zdz3=zlev(ig,lt+1)-zlt
    406407           zltdwn=zlev(ig,lt)-zdz3/2
    407 
    408            zbuoyjam(ig,l)=1.*RG*(((lmel+zdz3-zdz2)/zdz3)*(ztva_est(ig,l)- &
    409     &          ztv(ig,lt))/ztv(ig,lt)+((zdz2-lmel)/zdz3)*(ztva_est(ig,l)- &
     408           zlmelup=zlmel+(zdz/2)
     409           coefzlmel=Min(1.,(zlmelup-zltdwn)/zdz)
     410           zbuoyjam(ig,l)=1.*RG*(coefzlmel*(ztva_est(ig,l)- &
     411    &          ztv(ig,lt))/ztv(ig,lt)+(1.-coefzlmel)*(ztva_est(ig,l)- &
    410412    &          ztv(ig,lt-1))/ztv(ig,lt-1))+0.*zbuoy(ig,l)
    411413        endif !   if (iflag_thermals_ed.lt.8) then
    … …  
    422424              zdw2=afact*zbuoy(ig,l)/fact_epsilon
    423425              zdw2bis=afact*zbuoy(ig,l-1)/fact_epsilon
     426!              zdw2bis=0.5*(zdw2+zdw2bis)
    424427              lm=Max(1,l-2)
    425428!              zdw2=(afact/fact_epsilon)*((zdz/zdzbis)*zbuoy(ig,l) &
    … …  
    442445!    &                     (exp(-zw2factbis)*(w_est(ig,l-1)-zdw2bis)+zdw2))
    443446
    444             w_est(ig,l+1)=Max(0.0001,exp(-zw2fact)*(w_est(ig,l)-zdw2bis)+zdw2)
     447            w_est(ig,l+1)=Max(0.0001,exp(-zw2fact)*(w_est(ig,l)-zdw2)+zdw2)
    445448
    446449! Nouvelle version Arnaud
    … …  
    556559    &       mix0 * 0.1 / (zalpha+0.001)               &
    557560    &     + zbetalpha*MAX(entr_min,                   &
    558     &     afact*zbuoyjam(ig,l)/zw2m - fact_epsilon ))
     561    &     afact*zbuoyjam(ig,l)/zw2m - fact_epsilon))
    559562
    560563
    … …  
    645648!    &                     (zw2(ig,l)-zdw2)+zdw2)+(zdzbis-zdz)/zdzbis* &
    646649!    &                     (exp(-zw2factbis)*(zw2(ig,l-1)-zdw2bis)+zdw2))
     650            if (iflag_thermals_ed==8) then
     651            zw2(ig,l+1)=Max(0.0001,exp(-zw2fact)*(zw2(ig,l)-zdw2)+zdw2)
     652            else
    647653            zw2(ig,l+1)=Max(0.0001,exp(-zw2fact)*(zw2(ig,l)-zdw2bis)+zdw2)
     654            endif
    648655!            zw2(ig,l+1)=Max(0.0001,(zdz/(zdz+zdzbis))*(exp(-zw2fact)* &
    649 !    &                     (zw2(ig,l)-zdw2bis)+zdw2)+(zdzbis/(zdz+zdzbis))* &
     656!    &                     (zw2(ig,l)-zdw2)+zdw2bis)+(zdzbis/(zdz+zdzbis))* &
    650657!    &                     (exp(-zw2factbis)*(zw2(ig,l-1)-zdw2bis)+zdw2bis))
    651658

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

    r2187 r2298  
    174174    id_pcsat=0; id_pcocsat=0; id_pcq=0; id_pcs0=0; id_pcos0=0; id_pcq0=0
    175175    DO it=1,nbtr
    176        iiq=niadv(it+2)
    177        IF ( tname(iiq) == "RN" ) THEN
     176!!       iiq=niadv(it+2)                                                            ! jyg
     177       iiq=niadv(it+nqo)                                                            ! jyg
     178       IF ( tname(iiq) == "RN" ) THEN                                               
    178179          id_rn=it ! radon
    179180       ELSE IF ( tname(iiq) == "PB") THEN
    … …  
    293294! ----------------------------------------------
    294295    DO it=1,nbtr
    295        iiq=niadv(it+2)
     296!!       iiq=niadv(it+2)                                                            ! jyg
     297       iiq=niadv(it+nqo)                                                            ! jyg
    296298       ! Test if tracer is zero everywhere.
    297299       ! Done by master process MPI and master thread OpenMP

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

    r1999 r2298  
    55  USE netcdf
    66  USE dimphy
    7   USE phys_state_var_mod ! Variables sauvegardees de la physique
     7#ifdef CPP_IOIPSL
     8  USE phys_state_var_mod
     9#endif
     10
    811  IMPLICIT NONE
    912  include "clesphys.h"
     13#ifdef CPP_IOIPSL
     14  REAL :: missing_val
     15#endif
    1016
    1117  ! ====================================================================
    … …  
    5157  ! REAL tnondef(klon,klevSTD,nout)
    5258
    53   REAL missing_val
     59! REAL missing_val
    5460
    55   missing_val = nf90_fill_real
     61! missing_val = nf90_fill_real
     62#ifndef CPP_XIOS
     63      missing_val=missing_val_nf90
     64#endif
    5665
    5766  DO n = 1, nout

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

    r1910 r2298  
    1717!----------------
    1818     DO it=1,nbtr
    19         iiq=niadv(it+2)
     19!!        iiq=niadv(it+2)                                                           ! jyg
     20        iiq=niadv(it+nqo)                                                           ! jyg
    2021
    2122! CONCENTRATIONS

  • LMDZ5/branches/testing/makelmdz

    r2220 r2298  
    7777
    7878CPP_KEY=""
    79 INCLUDE='-I$(LIBF)/grid -I$(LIBF)/bibio -I$(LIBF)/filtrez -I. '
     79INCLUDE='-I$(LIBF)/grid -I$(LIBF)/misc -I$(LIBF)/filtrez -I. '
    8080LIB=""
    8181adjnt=""
    … …  
    8484PARA_LD=""
    8585EXT_SRC=""
    86 
     86#src_dirs: directories containing source files
     87src_dirs="grid misc"
    8788########################################################################
    8889# lecture des options
    … …  
    106107          true        : (obsolete; for backward compatibility) use ORCHIDEE tag 1.9-1.9.6
    107108[-chimie INCA/false]       : with INCA chemistry model or without (default: false)
     109[-cosp true/false]    : compile with/without cosp package (default: false)
     110[-sisvat true/false]  : compile with/without sisvat package (default: false)
     111[-rrtm true/false]    : compile with/without rrtm package (default: false)
    108112[-parallel none/mpi/omp/mpi_omp] : parallelism (default: none) : mpi, openmp or mixted mpi_openmp
    109113[-g GRI]                   : grid configuration in dyn3d/GRI_xy.h  (default: reg, inclues a zoom)
    … …  
    186190
    187191      "-ext_src")
    188           EXT_SRC=$2 ; shift ; shift ;;
     192          EXT_SRC=$2 ; src_dirs="$src_dirs $EXT_SRC" ; shift ; shift ;;
    189193
    190194      "-arch")
    … …  
    280284for inc in $archfileline ; do INCLUDE="$INCLUDE `echo $inc | grep '\-I'`" ; done
    281285
     286phys_root=$physique
     287if [[ "${physique:0:3}" == "lmd" ]] ; then phys_root=lmd ; fi
     288if [[ "${physique:0:4}" == "mars" ]] ; then phys_root=mars ; fi
     289if [[ "${physique:0:3}" == "std" ]] ; then phys_root=std ; fi
     290if [[ "${physique:0:5}" == "venus" ]] ; then phys_root=venus ; fi
     291if [[ "${physique:0:5}" == "titan" ]] ; then phys_root=titan ; fi
     292if [[ "${physique:0:3}" == "mar" ]] ; then phys_root=mar ; fi
     293if [[ "${physique:0:3}" == "dev" ]] ; then phys_root=dev ; fi
     294
    282295if [[ "$physique" != "nophys" ]]
    283296then
    284297   #We'll use some physics
     298   src_dirs="$src_dirs phy$physique"
     299   LIBPHY='$(LIBO)/libphy'"$physique"'.a'
     300   lib_phy='-lphy'"$physique"
    285301   CPP_KEY="$CPP_KEY CPP_PHYS"
    286    if [[ "${physique:0:3}" == "lmd" ]]
    287    then
    288    #For lmd physics, default planet type is Earth
    289    CPP_KEY="$CPP_KEY CPP_EARTH"
     302   if [[ $phys_root == "lmd" ]]
     303      then
     304      #For lmd physics, default planet type is Earth
     305      CPP_KEY="$CPP_KEY CPP_EARTH"
    290306   fi
    291307fi
    … …  
    316332      echo "You should use option \"-mem\"."
    317333      exit 1
    318   fi     
     334  fi
    319335fi
    320336
    … …  
    412428then
    413429   CPP_KEY="$CPP_KEY CPP_COSP"
    414    COSP_PATH="$LIBFGCM/cosp"
     430   COSP_PATH="$LIBFGCM/phylmd/cosp"
     431   src_dirs="$src_dirs cosp"
    415432#   LIB="${LIB} -l${LIBPREFIX}cosp"
    416433   opt_dep="$opt_dep cosp"
    … …  
    422439then
    423440   CPP_KEY="$CPP_KEY CPP_SISVAT"
     441   src_dirs="$src_dirs phy${physique}/sisvat"
    424442fi
    425443
    … …  
    427445then
    428446   CPP_KEY="$CPP_KEY CPP_RRTM"
     447   src_dirs="$src_dirs phy${physique}/rrtm"
    429448fi
    430449
    … …  
    489508
    490509if (( $dimc == 3 )) ; then
     510   src_dirs="$src_dirs $filtre dyn3d_common dyn3d${FLAG_PARA}"
     511   if [[ $physique != "nophys" ]] ; then
     512     src_dirs="$src_dirs dynlonlat_phylonlat dynlonlat_phylonlat/phy${phys_root}"
     513     libdyn_phy="-ldynlonlat_phylonlat"
     514     LIBDYN_PHYS='$(LIBO)/libdynlonlat_phylonlat.a'
     515     INCLUDE="$INCLUDE "'-I$(LIBF)/dynlonlat_phylonlat'
     516     INCLUDE="$INCLUDE "'-I$(LIBF)/dynlonlat_phylonlat/'"phy${phys_root}"
     517   fi
    491518   cd $LIBFGCM/grid
    492519   \rm fxyprim.h
    … …  
    495522   INCLUDE="$INCLUDE "'-I$(LIBF)/dyn3d${FLAG_PARA} -I$(LIBF)/dyn3d_common '
    496523elif (( $dimc == 2 )) ; then
     524   src_dirs="$src_dirs dyn2d"
    497525   filtre="FILTRE= L_FILTRE= "
    498526   INCLUDE="$INCLUDE "'-I$(LIBF)/dyn2d'
    499527elif (( $dimc == 1 )) ; then
     528   #src_dirs="$src_dirs dyn3d dyn3d_common filtrez"
     529   src_dirs="$src_dirs phy${physique}/dyn1d"
    500530   CPP_KEY="$CPP_KEY CPP_1D"
    501    filtre="L_DYN= DYN= FILTRE= L_FILTRE= DIRMAIN=phy$physique "
    502    INCLUDE="$INCLUDE "'-I$(LIBF)/dyn3d -I$(LIBF)/dyn3d_common ' # Pas tres propre
     531   filtre="L_DYN= DYN= FILTRE= L_FILTRE= "
     532   #INCLUDE="$INCLUDE "'-I$(LIBF)/dyn3d -I$(LIBF)/dyn3d_common ' # Pas tres propre
     533   INCLUDE="$INCLUDE "' -I$(LIBF)/phy'"$physique"'/dyn1d'
    503534else
    504535   echo Dimension dimc=$dimc pas prevu ; exit
    … …  
    539570cd $LMDGCM
    540571
    541 find libf -name '*.[Fh]' -print > tmp77
    542 find libf -name '*.[Fh]' -exec egrep -i " *use *ioipsl" {} \; -print > tmp90
    543 find libf -name '*.F90' -print >> tmp90
    544 
    545 if [[ ! ( -r makefile ) || ! ( -r liste_des_sources_f90 ) || ! ( -r liste_des_sources_f77 ) || ` diff tmp77 liste_des_sources_f77 | wc -w ` -ne 0 || ` diff tmp90 liste_des_sources_f90 | wc -w ` -ne 0 ]]
     572
     573if [[ -r .makelmdz ]]
     574then
     575old_lmdz_configuration=$(cat .makelmdz )
     576else
     577old_lmdz_configuration=""
     578fi
     579lmdz_configuration="$src_dirs"
     580if [[ "$lmdz_configuration" != "$old_lmdz_configuration" ]]
     581then
     582  configuration_change="true"
     583else
     584  configuration_change="false"
     585fi
     586
     587mkdir -p make_dir
     588suf_make=`echo $src_dirs | sed -e 's/\//_/g' -e 's/ /_/g'`
     589echo suf_make $suf_make
     590
     591\rm tmp77 tmp90
     592for dir in $src_dirs ; do
     593find libf/$dir -name '*.[Fh]' -print | sort >> tmp77
     594find libf/$dir -name '*.F90' -print | sort >> tmp90
     595done
     596
     597liste77=make_dir/liste_des_sources_f77_$suf_make
     598liste90=make_dir/liste_des_sources_f90_$suf_make
     599makefile=make_dir/makefile_$suf_make
     600
     601if [[ $configuration_change == "true" || ! ( -r $makefile ) || ! ( -r $liste90 ) || ! ( -r $liste77 ) || ` diff tmp77 $liste77 | wc -w ` -ne 0 || ` diff tmp90 $liste90 | wc -w ` -ne 0 ]]
    546602then
    547603  echo "les fichiers suivants ont ete crees ou detruits"
    548604  echo "ou les fichiers suivants sont passes ou ne sont plus en Fortran 90"
    549   diff liste_des_sources_f77 tmp77
    550   diff liste_des_sources_f90 tmp90
    551   \cp -f tmp77 liste_des_sources_f77
    552   \cp -f tmp90 liste_des_sources_f90
    553   echo "on recree le makefile"
    554   ./create_make_gcm > tmp
    555   \mv -f tmp makefile
    556   echo "Nouveau makefile cree"
    557 fi
     605  diff $liste77 tmp77
     606  diff $liste90 tmp90
     607  \cp -f tmp77 $liste77
     608  \cp -f tmp90 $liste90
     609  echo "Recreating the makefile"
     610  echo "src_dirs: $src_dirs"
     611  ./create_make_gcm $src_dirs > tmp
     612  \mv -f tmp $makefile
     613  echo "New makefile created"
     614fi
     615
     616ln -sf $makefile makefile
     617
     618#Create a .makelmdz file containing main compilation option for later comparisons
     619echo "$lmdz_configuration" > .makelmdz
    558620
    559621#################################################################
    … …  
    562624
    563625source_code=${code}.F
     626dirmain=dyn${dimc}d${FLAG_PARA}
    564627if [[ -r $LMDGCM/libf/dyn${dimc}d${FLAG_PARA}/${code}.F90 ]]
    565628then
    566629  source_code=${code}.F90
    567630elif [[ -r $LMDGCM/libf/phy$physique/${code}.F90 ]] ; then
     631  dirmain=phy$physique
     632  source_code=${code}.F90
     633elif [[ -r $LMDGCM/libf/dynlonlat_phylonlat/phy$phys_root/${code}.F90 ]] ; then
     634  dirmain="dynlonlat_phylonlat/phy${phys_root}"
     635  source_code=${code}.F90
     636elif [[ -r $LMDGCM/libf/phy$physique/dyn1d/${code}.F90 ]] ; then
     637  dirmain=phy$physique/dyn1d
    568638  source_code=${code}.F90
    569639fi
    … …  
    619689LIBO=${LIBOGCM}/${nomlib} \
    620690"PHYS=$physique" \
     691LIBPHY=${LIBPHY} \
     692LIBDYN_PHYS=${LIBDYN_PHYS} \
    621693DIM=$dimc \
    622694FLAG_PARA=$FLAG_PARA \
     695L_PHY="$lib_phy" \
     696L_DYN_PHY="$libdyn_phy" \
    623697L_ADJNT=$adjnt \
    624698L_COSP="$lcosp" \
    … …  
    633707MOD_SUFFIX="mod" \
    634708AR=$arcommand \
     709DIRMAIN=$dirmain \
    635710SOURCE=$source_code \
    636711PROG=$code
    … …  
    645720LIBO=${LIBOGCM}/${nomlib} \
    646721"PHYS=$physique" \
     722LIBPHY=${LIBPHY} \
     723LIBDYN_PHYS=${LIBDYN_PHYS} \
    647724DIM=$dimc \
    648725FLAG_PARA=$FLAG_PARA \
     726L_PHY="$lib_phy" \
     727L_DYN_PHY="$libdyn_phy" \
    649728L_ADJNT=$adjnt \
    650729L_COSP="$lcosp" \
    … …  
    659738MOD_SUFFIX="mod" \
    660739AR=$arcommand \
     740DIRMAIN=$dirmain \
    661741SOURCE=$source_code \
    662742PROG=$code

  • LMDZ5/branches/testing/makelmdz_fcm

    r2220 r2298  
    3838LIBOGCM=$LMDGCM/libo
    3939LIBFGCM=$LMDGCM/libf
     40DYN_COMMON_PATH=$LIBFGCM/dyn3d_common
    4041# path for optional packages, but default set to ".void_dir"
     42FILTRE_PATH=$LMDGCM/.void_dir
     43DYN_PHYS_PATH=$LMDGCM/.void_dir
     44DYN_PHYS_SUB_PATH=$LMDGCM/.void_dir
    4145RRTM_PATH=$LMDGCM/.void_dir
    4246SISVAT_PATH=$LMDGCM/.void_dir
    … …  
    7882          true        : (obsolete; for backward compatibility) use ORCHIDEE tag 1.9-1.9.6
    7983[-chimie INCA/false]       : with INCA chemistry model or without (default: false)
     84[-cosp true/false]    : compile with/without cosp package (default: false)
     85[-sisvat true/false]  : compile with/without sisvat package (default: false)
     86[-rrtm true/false]    : compile with/without rrtm package (default: false)
    8087[-parallel none/mpi/omp/mpi_omp] : parallelism (default: none) : mpi, openmp or mixted mpi_openmp
    8188[-g GRI]                   : grid configuration in dyn3d/GRI_xy.h  (default: reg, inclues a zoom)
    … …  
    176183done
    177184
     185if [[ $code = ce0l && $paramem = mem ]]
     186then
     187    echo "There is no parallel version of ce0l at the moment."
     188    echo "Please compile the sequential version of the code to produce the" \
     189        "executable ce0l."
     190    exit 1
     191fi
     192
    178193###############################################################
    179194# path to fcm
    … …  
    219234fi
    220235
     236phys_root=$physique
     237if [[ "${physique:0:3}" == "lmd" ]] ; then phys_root=lmd ; fi
     238if [[ "${physique:0:4}" == "mars" ]] ; then phys_root=mars ; fi
     239if [[ "${physique:0:3}" == "std" ]] ; then phys_root=std ; fi
     240if [[ "${physique:0:5}" == "venus" ]] ; then phys_root=venus ; fi
     241if [[ "${physique:0:5}" == "titan" ]] ; then phys_root=titan ; fi
     242if [[ "${physique:0:3}" == "mar" ]] ; then phys_root=mar ; fi
     243if [[ "${physique:0:3}" == "dev" ]] ; then phys_root=dev ; fi
     244
    221245if [[ "$physique" != "nophys" ]]
    222246then
    223247   #We'll use some physics
    224248   CPP_KEY="$CPP_KEY CPP_PHYS"
    225    if [[ "${physique:0:3}" == "lmd" ]]
     249   if [[ "${phys_root}" == "lmd" ]]
    226250   then
    227251   #For lmd physics, default planet type is Earth
    228252   CPP_KEY="$CPP_KEY CPP_EARTH"
    229253   fi
     254   # set the dyn/phys interface path
     255   DYN_PHYS_PATH="${LIBFGCM}/dynlonlat_phylonlat"
     256   DYN_PHYS_SUB_PATH="${LIBFGCM}/dynlonlat_phylonlat/phy${phys_root}"
     257fi
     258
     259if [[ "$filtre" == "filtrez" ]]
     260then
     261   FILTRE_PATH=${LIBFGCM}/$filtre
    230262fi
    231263
    … …  
    339371then
    340372   CPP_KEY="$CPP_KEY CPP_COSP"
    341    COSP_PATH="$LIBFGCM/cosp"
     373   COSP_PATH="$LIBFGCM/phylmd/cosp"
    342374#   LIB="${LIB} -l${LIBPREFIX}cosp"
    343375fi
    … …  
    407439  \rm fxyprim.h
    408440  cp -p fxy_${grille}.h fxyprim.h
    409 else
    410   echo "Probleme dans les dimensions de la dynamique !!"
    411   echo "Non reactive pour l'instant !!!"
     441#else
     442#  echo "Probleme dans les dimensions de la dynamique !!"
     443#  echo "Non reactive pour l'instant !!!"
     444fi
     445
     446if (( $dimension == 1 ))
     447then
     448  CPP_KEY="$CPP_KEY CPP_1D"
     449##in 1D, add dyn3d to include path (because main prog is in physics)
     450  INCLUDE="$INCLUDE -Ilibf/dyn3d -Ilibf/dyn3d_common"
     451## no filtre in 1d:
     452  FILTRE_PATH=$LMDGCM/.void_dir
     453## no need to compile all routines in dyn3d_common either:
     454  DYN_COMMON_PATH=$LMDGCM/.void_dir
     455## no need to compile all routines in dynlmdz_phy... ;
     456## (because key ones are included in 1D main program)
     457  DYN_PHYS_PATH=$LMDGCM/.void_dir
     458  DYN_PHYS_SUB_PATH=$LMDGCM/.void_dir
    412459fi
    413460
    … …  
    470517else
    471518  SUFF_NAME=${SUFF_NAME}_seq
    472   DYN=dyn${dimc}d
     519  if (( $dimension == 1 ))
     520  then
     521    # dynamics-related routines in"dyn1d" subdirectory of phy${physique}
     522    DYN=phy${physique}/dyn1d
     523  else
     524    DYN=dyn${dimc}d
     525  fi
    473526fi
    474527
    … …  
    503556echo "%LIBO          $LIBOGCM"       >> $config_fcm
    504557echo "%DYN           $DYN"           >> $config_fcm
     558echo "%DYN_COMMON    $DYN_COMMON_PATH" >> $config_fcm
     559echo "%FILTRE        $FILTRE_PATH"   >> $config_fcm
    505560echo "%PHYS          phy${physique}" >> $config_fcm
     561echo "%DYN_PHYS      $DYN_PHYS_PATH" >> $config_fcm
     562echo "%DYN_PHYS_SUB  $DYN_PHYS_SUB_PATH" >> $config_fcm
    506563echo "%RRTM          $RRTM_PATH"     >> $config_fcm
    507564echo "%SISVAT        $SISVAT_PATH"   >> $config_fcm
    … …  
    525582fi
    526583
    527 
    528584rm -f $LIBOGCM/${arch}${SUFF_NAME}/.config/fcm.bld.lock
    529585./build_gcm ${fcm_path} -j $job $full
Note: See TracChangeset for help on using the changeset viewer.