New URL for NEMO forge!   http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
Changeset 6839 for branches – NEMO

Changeset 6839 for branches


Ignore:
Timestamp:
2016-08-03T16:04:57+02:00 (8 years ago)
Author:
timgraham
Message:

Merged in nemo_v3_6_STABLE at r6721

Location:
branches/UKMO/dev_r5518_convadj/NEMOGCM
Files:
153 edited
1 copied

Legend:

Unmodified
Added
Removed

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/CONFIG/AMM12/EXP00/namelist_cfg

    r5501 r6839  
    200200/ 
    201201!----------------------------------------------------------------------- 
    202 &namobc        !   open boundaries parameters                           ("key_obc") 
    203 !----------------------------------------------------------------------- 
    204 / 
    205 !----------------------------------------------------------------------- 
    206202&namagrif      !  AGRIF zoom                                            ("key_agrif") 
    207203!----------------------------------------------------------------------- 
    … …  
    369365/ 
    370366!----------------------------------------------------------------------- 
     367&namzdf_tmx_new !  new tidal mixing parameterization                    ("key_zdftmx_new") 
     368!----------------------------------------------------------------------- 
     369/ 
     370!----------------------------------------------------------------------- 
    371371&namsol        !   elliptic solver / island / free surface 
    372372!----------------------------------------------------------------------- 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/CONFIG/C1D_PAPA/EXP00/namelist_cfg

    r5407 r6839  
    141141&namtra_qsr    !   penetrative solar radiation 
    142142!----------------------------------------------------------------------- 
     143!              !  file name  ! frequency (hours) ! variable  ! time interp. !  clim  ! 'yearly'/ ! weights  ! rotation ! land/sea mask ! 
     144!              !             !  (if <0  months)  !   name    !   (logical)  !  (T/F) ! 'monthly' ! filename ! pairing  ! filename      ! 
     145   sn_chl      ='chlorophyll_PAPASTATION', -1    , 'CHLA'    ,   .true.     , .true. , 'yearly'  , ''       , ''       , '' 
    143146/ 
    144147!----------------------------------------------------------------------- 
    … …  
    173176!----------------------------------------------------------------------- 
    174177&namcla        !   cross land advection 
    175 !----------------------------------------------------------------------- 
    176 / 
    177 !----------------------------------------------------------------------- 
    178 &namobc        !   open boundaries parameters                           ("key_obc") 
    179178!----------------------------------------------------------------------- 
    180179/ 
    … …  
    304303/ 
    305304!----------------------------------------------------------------------- 
     305&namzdf_tmx_new !  new tidal mixing parameterization                    ("key_zdftmx_new") 
     306!----------------------------------------------------------------------- 
     307/ 
     308!----------------------------------------------------------------------- 
    306309&namsol        !   elliptic solver / island / free surface 
    307310!----------------------------------------------------------------------- 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/CONFIG/GYRE/EXP00/namelist_cfg

    r5407 r6839  
    160160/ 
    161161!----------------------------------------------------------------------- 
    162 &namobc        !   open boundaries parameters                           ("key_obc") 
    163 !----------------------------------------------------------------------- 
    164 / 
    165 !----------------------------------------------------------------------- 
    166162&namagrif      !  AGRIF zoom                                            ("key_agrif") 
    167163!----------------------------------------------------------------------- 
    … …  
    304300/ 
    305301!----------------------------------------------------------------------- 
     302&namzdf_tmx_new !  new tidal mixing parameterization                    ("key_zdftmx_new") 
     303!----------------------------------------------------------------------- 
     304/ 
     305!----------------------------------------------------------------------- 
    306306&namsol        !   elliptic solver / island / free surface 
    307307!----------------------------------------------------------------------- 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/CONFIG/GYRE_BFM/EXP00/namelist_cfg

    r5407 r6839  
    165165/ 
    166166!----------------------------------------------------------------------- 
    167 &namobc        !   open boundaries parameters                           ("key_obc") 
    168 !----------------------------------------------------------------------- 
    169 / 
    170 !----------------------------------------------------------------------- 
    171167&namagrif      !  AGRIF zoom                                            ("key_agrif") 
    172168!----------------------------------------------------------------------- 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/CONFIG/GYRE_XIOS/EXP00/iodef.xml

    r5363 r6839  
    22<simulation>  
    33 
    4  <context id="nemo" time_origin="1900-01-01 00:00:00" > 
     4 <context id="nemo" > 
    55     
    66    <!-- $id$ --> 
    … …  
    1919=                                         put the variables you want...                                    = 
    2020============================================================================================================ 
    21     --> 
    22      
    23     <file_definition type="multiple_file" name="@expname@_@freq@_@startdate@_@enddate@" sync_freq="1d" min_digits="4"> 
    24      
    25       <file_group id="1ts" output_freq="1ts"  output_level="10" enabled=".TRUE."/> <!-- 1 time step files --> 
    26       <file_group id="1h" output_freq="1h"  output_level="10" enabled=".TRUE."/> <!-- 1h files --> 
    27       <file_group id="2h" output_freq="2h"  output_level="10" enabled=".TRUE."/> <!-- 2h files --> 
    28       <file_group id="3h" output_freq="3h"  output_level="10" enabled=".TRUE."/> <!-- 3h files -->      
    29       <file_group id="4h" output_freq="4h"  output_level="10" enabled=".TRUE."/> <!-- 4h files --> 
    30       <file_group id="6h" output_freq="6h"  output_level="10" enabled=".TRUE."/> <!-- 6h files --> 
    31       
    32       <file_group id="1d" output_freq="1d"  output_level="10" enabled=".TRUE."/> <!-- 1d files --> 
    33       <file_group id="3d" output_freq="3d"  output_level="10" enabled=".TRUE."/> <!-- 3d files -->     
    34       <file_group id="5d" output_freq="5d"  output_level="10" enabled=".TRUE.">  <!-- 5d files -->   
     21       --> 
     22 
     23    <file_definition src="./file_def.xml"/> 
     24 
     25    <!-- 
    3526  
    36    <file id="file1" name_suffix="_grid_T" description="ocean T grid variables" > 
    37      <field field_ref="toce"         name="votemper"  /> 
    38      <field field_ref="soce"         name="vosaline"  /> 
    39      <field field_ref="sst"          name="sosstsst"  /> 
    40      <field field_ref="sss"          name="sosaline"  /> 
    41      <field field_ref="ssh"          name="sossheig"  /> 
    42      <field field_ref="empmr"        name="sowaflup"  /> 
    43      <field field_ref="qsr"          name="soshfldo"  /> 
    44       <field field_ref="saltflx"      name="sosfldow"  /> 
    45      <field field_ref="qt"           name="sohefldo"  /> 
    46      <field field_ref="mldr10_1"     name="somxl010"  /> 
    47      <field field_ref="mldkz5"       name="somixhgt"  /> 
    48     </file> 
    49     
    50    <file id="file2" name_suffix="_grid_U" description="ocean U grid variables" > 
    51           <field field_ref="uoce"         name="vozocrtx"  /> 
    52           <field field_ref="utau"         name="sozotaux"  /> 
    53     </file> 
    54     
    55    <file id="file3" name_suffix="_grid_V" description="ocean V grid variables" > 
    56           <field field_ref="voce"         name="vomecrty"  />  
    57           <field field_ref="vtau"         name="sometauy"  />  
    58     </file> 
    59     
    60    <file id="file4" name_suffix="_grid_W" description="ocean W grid variables" > 
    61           <field field_ref="woce"         name="vovecrtz" /> 
    62           <field field_ref="avt"          name="votkeavt" /> 
    63           <field field_ref="aht2d"        name="soleahtw" /> 
    64     </file> 
    65  
    66       </file_group> 
    67        
    68       <file_group id="1m" output_freq="1mo" output_level="10" enabled=".TRUE."/> <!-- real monthly files --> 
    69       <file_group id="2m" output_freq="2mo" output_level="10" enabled=".TRUE."/> <!-- real 2m files --> 
    70       <file_group id="3m" output_freq="3mo" output_level="10" enabled=".TRUE."/> <!-- real 3m files --> 
    71       <file_group id="4m" output_freq="4mo" output_level="10" enabled=".TRUE."/> <!-- real 4m files --> 
    72       <file_group id="6m" output_freq="6mo" output_level="10" enabled=".TRUE."/> <!-- real 6m files --> 
    73  
    74       <file_group id="1y"  output_freq="1y" output_level="10" enabled=".TRUE."/> <!-- real yearly files --> 
    75       <file_group id="2y"  output_freq="2y" output_level="10" enabled=".TRUE."/> <!-- real 2y files --> 
    76       <file_group id="5y"  output_freq="5y" output_level="10" enabled=".TRUE."/> <!-- real 5y files --> 
    77       <file_group id="10y" output_freq="10y" output_level="10" enabled=".TRUE."/> <!-- real 10y files --> 
    78  
    79    </file_definition> 
    80      
    81     <!--  
    8227============================================================================================================ 
    8328= grid definition = = DO NOT CHANGE = 
    … …  
    10045    
    10146   <grid_definition>     
    102      <grid id="grid_T_2D" domain_ref="grid_T"/> 
    103      <grid id="grid_T_3D" domain_ref="grid_T" axis_ref="deptht"/> 
    104      <grid id="grid_U_2D" domain_ref="grid_U"/> 
    105      <grid id="grid_U_3D" domain_ref="grid_U" axis_ref="depthu"/> 
    106      <grid id="grid_V_2D" domain_ref="grid_V"/> 
    107      <grid id="grid_V_3D" domain_ref="grid_V" axis_ref="depthv"/> 
    108      <grid id="grid_W_2D" domain_ref="grid_W"/> 
    109      <grid id="grid_W_3D" domain_ref="grid_W" axis_ref="depthw"/> 
     47     <grid id="grid_T_2D" > 
     48       <domain id="grid_T" /> 
     49     </grid> 
     50     <grid id="grid_T_3D" > 
     51       <domain id="grid_T" /> 
     52       <axis id="deptht" /> 
     53     </grid> 
     54     <grid id="grid_U_2D" > 
     55       <domain id="grid_U" /> 
     56     </grid> 
     57     <grid id="grid_U_3D" > 
     58       <domain id="grid_U" /> 
     59       <axis id="depthu" /> 
     60     </grid> 
     61     <grid id="grid_V_2D" > 
     62       <domain id="grid_V" /> 
     63     </grid> 
     64     <grid id="grid_V_3D" > 
     65       <domain id="grid_V" /> 
     66       <axis id="depthv" /> 
     67     </grid> 
     68     <grid id="grid_W_2D" > 
     69       <domain id="grid_W" /> 
     70     </grid> 
     71     <grid id="grid_W_3D" > 
     72       <domain id="grid_W" /> 
     73       <axis id="depthw" /> 
     74     </grid> 
     75     <grid id="scalarpoint" /> 
     76 
    11077    </grid_definition>  
    11178 
    … …  
    12087        We must have buffer_size > jpi*jpj*jpk*8 (with jpi and jpj the subdomain size) 
    12188--> 
    122      <variable id="buffer_size"               type="integer">10000000</variable> 
    123      <variable id="buffer_server_factor_size" type="integer">2</variable> 
    124      <variable id="info_level"                type="integer">0</variable> 
    125      <variable id="using_server"              type="boolean">false</variable> 
    126      <variable id="using_oasis"               type="boolean">false</variable> 
     89     <variable id="info_level"                type="int">0</variable> 
     90     <variable id="using_server"              type="bool">false</variable> 
     91     <variable id="using_oasis"               type="bool">false</variable> 
    12792     <variable id="oasis_codes_id"            type="string" >oceanx</variable> 
    12893    

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/CONFIG/GYRE_XIOS/EXP00/namelist_cfg

    r5407 r6839  
    154154/ 
    155155!----------------------------------------------------------------------- 
    156 &namobc        !   open boundaries parameters                           ("key_obc") 
    157 !----------------------------------------------------------------------- 
    158 / 
    159 !----------------------------------------------------------------------- 
    160156&namagrif      !  AGRIF zoom                                            ("key_agrif") 
    161157!----------------------------------------------------------------------- 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/CONFIG/GYRE_XIOS/cpp_GYRE_XIOS.fcm

    r4373 r6839  
    1  bld::tool::fppkeys key_dynspg_flt key_ldfslp key_zdftke key_iomput key_mpp_mpi 
     1 bld::tool::fppkeys key_dynspg_flt key_ldfslp key_zdftke key_iomput key_mpp_mpi key_xios2 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/CONFIG/ORCA2_LIM/EXP00/1_namelist_cfg

    r5499 r6839  
    66!----------------------------------------------------------------------- 
    77   cn_exp      = "Agulhas" !  experience name  
    8    nn_itend    =     480   !  last  time step 
     8   nn_itend    =   10950   !  last  time step 
    99   nn_stock    =   10950   !  frequency of creation of a restart file (modulo referenced to 1) 
    1010   nn_write    =   10950   !  frequency of write in the output file   (modulo referenced to nn_it000) 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/CONFIG/ORCA2_LIM/EXP00/iodef.xml

    r5407 r6839  
    153153  </context> 
    154154   
     155 <context id="1_nemo" time_origin="1950-01-01 00:00:00" > 
     156     
     157    <!-- $id$ --> 
     158     
     159    <!--  
     160============================================================================================================ 
     161=                                  definition of all existing variables                                    = 
     162=                                            DO NOT CHANGE                                                 = 
     163============================================================================================================ 
     164    --> 
     165    <field_definition src="./field_def.xml"/> 
     166    <!--  
     167============================================================================================================ 
     168=                                           output files definition                                        = 
     169=                                            Define your own files                                         = 
     170=                                         put the variables you want...                                    = 
     171============================================================================================================ 
     172    --> 
     173     
     174    <file_definition type="multiple_file" name="@expname@_@freq@_@startdate@_@enddate@" sync_freq="10d" min_digits="4"> 
     175     
     176      <file_group id="1ts" output_freq="1ts"  output_level="10" enabled=".TRUE."/> <!-- 1 time step files --> 
     177      <file_group id="1h" output_freq="1h"  output_level="10" enabled=".TRUE."/> <!-- 1h files --> 
     178      <file_group id="2h" output_freq="2h"  output_level="10" enabled=".TRUE."/> <!-- 2h files --> 
     179      <file_group id="3h" output_freq="3h"  output_level="10" enabled=".TRUE."/> <!-- 3h files -->      
     180      <file_group id="4h" output_freq="4h"  output_level="10" enabled=".TRUE."/> <!-- 4h files --> 
     181      <file_group id="6h" output_freq="6h"  output_level="10" enabled=".TRUE."/> <!-- 6h files -->      
     182      <file_group id="1d" output_freq="1d"  output_level="10" enabled=".TRUE."/> <!-- 1d files --> 
     183      <file_group id="3d" output_freq="3d"  output_level="10" enabled=".TRUE."/> <!-- 3d files -->     
     184 
     185      <file_group id="5d" output_freq="5d"  output_level="10" enabled=".TRUE." >  <!-- 5d files -->   
     186  
     187   <file id="file1" name_suffix="_grid_T" description="ocean T grid variables" > 
     188     <field field_ref="sst"          name="tos"      long_name="sea_surface_temperature"                       /> 
     189     <field field_ref="sss"          name="sos"      long_name="sea_surface_salinity"                          /> 
     190     <field field_ref="ssh"          name="zos"      long_name="sea_surface_height_above_geoid"                /> 
     191     <field field_ref="toce"         name="thetao"   long_name="sea_water_potential_temperature"               /> 
     192     <field field_ref="soce"         name="so"       long_name="sea_water_salinity"                            /> 
     193     <field field_ref="sst2"         name="tossq"    long_name="square_of_sea_surface_temperature"             /> 
     194     <field field_ref="ssh2"         name="zossq"    long_name="square_of_sea_surface_height_above_geoid"      /> 
     195     <field field_ref="mldkz5"       /> 
     196     <field field_ref="mldr10_1"     /> 
     197     <field field_ref="empmr"        name="wfo"      long_name="water_flux_into_sea_water"                     /> 
     198     <field field_ref="qsr"          name="rsntds"   long_name="surface_net_downward_shortwave_flux"           /> 
     199     <field field_ref="qt"           name="tohfls"   long_name="surface_net_downward_total_heat_flux"          /> 
     200     <field field_ref="saltflx"      name="sosflxdo"  /> 
     201     <field field_ref="taum"         name="taum" /> 
     202     <field field_ref="wspd"         name="sowindsp"  /> 
     203          <field field_ref="precip"       name="soprecip" /> 
     204   </file> 
     205 
     206   <file id="file3" name_suffix="_grid_U" description="ocean U grid variables" > 
     207     <field field_ref="ssu"          name="uos"     long_name="sea_surface_x_velocity"    /> 
     208     <field field_ref="uoce"         name="uo"      long_name="sea_water_x_velocity"      /> 
     209     <field field_ref="utau"         name="tauuo"   long_name="surface_downward_x_stress" /> 
     210          <!-- variables available with MLE 
     211          <field field_ref="psiu_mle"     name="psiu_mle"  long_name="MLE_streamfunction_along_i-axis" /> 
     212     --> 
     213   </file> 
     214    
     215   <file id="file4" name_suffix="_grid_V" description="ocean V grid variables" > 
     216     <field field_ref="ssv"          name="vos"     long_name="sea_surface_y_velocity"    /> 
     217     <field field_ref="voce"         name="vo"      long_name="sea_water_y_velocity"      /> 
     218     <field field_ref="vtau"         name="tauvo"   long_name="surface_downward_y_stress" /> 
     219          <!-- variables available with MLE 
     220          <field field_ref="psiv_mle"     name="psiv_mle"  long_name="MLE_streamfunction_along_j-axis" /> 
     221     --> 
     222   </file> 
     223    
     224   <file id="file5" name_suffix="_grid_W" description="ocean W grid variables" > 
     225     <field field_ref="woce"         name="wo"      long_name="ocean vertical velocity"         /> 
     226     <field field_ref="avt"          name="difvho"  long_name="ocean_vertical_heat_diffusivity" /> 
     227   </file> 
     228<!-- 
     229   <file id="file6" name_suffix="_icemod" description="ice variables" > 
     230     <field field_ref="ice_pres"                     /> 
     231     <field field_ref="snowthic_cea" name="snd"     long_name="surface_snow_thickness"   /> 
     232     <field field_ref="icethic_cea"  name="sit"     long_name="sea_ice_thickness"        /> 
     233     <field field_ref="iceprod_cea"  name="sip"     long_name="sea_ice_thickness"        /> 
     234     <field field_ref="ist_ipa"      /> 
     235     <field field_ref="uice_ipa"     /> 
     236     <field field_ref="vice_ipa"     /> 
     237     <field field_ref="utau_ice"     /> 
     238     <field field_ref="vtau_ice"     /> 
     239     <field field_ref="qsr_io_cea"   /> 
     240     <field field_ref="qns_io_cea"   /> 
     241     <field field_ref="snowpre"      /> 
     242   </file> 
     243 
     244   <file id="file8" name_suffix="_Tides" description="tidal harmonics" > 
     245     <field field_ref="M2x"          name="M2x"      long_name="M2 Elevation harmonic real part"                       /> 
     246     <field field_ref="M2y"          name="M2y"      long_name="M2 Elevation harmonic imaginary part"                  /> 
     247     <field field_ref="M2x_u"        name="M2x_u"    long_name="M2 current barotrope along i-axis harmonic real part "       /> 
     248     <field field_ref="M2y_u"        name="M2y_u"    long_name="M2 current barotrope along i-axis harmonic imaginary part "  /> 
     249     <field field_ref="M2x_v"        name="M2x_v"    long_name="M2 current barotrope along j-axis harmonic real part "       /> 
     250     <field field_ref="M2y_v"        name="M2y_v"    long_name="M2 current barotrope along j-axis harmonic imaginary part "  /> 
     251   </file> 
     252   --> 
     253      </file_group> 
     254 
     255 
     256      <file_group id="1m" output_freq="1mo" output_level="10" enabled=".TRUE."/> <!-- real monthly files --> 
     257 
     258 
     259      <file_group id="2m" output_freq="2mo" output_level="10" enabled=".TRUE."/> <!-- real 2m files --> 
     260      <file_group id="3m" output_freq="3mo" output_level="10" enabled=".TRUE."/> <!-- real 3m files --> 
     261      <file_group id="4m" output_freq="4mo" output_level="10" enabled=".TRUE."/> <!-- real 4m files --> 
     262      <file_group id="6m" output_freq="6mo" output_level="10" enabled=".TRUE."/> <!-- real 6m files --> 
     263 
     264      <file_group id="1y"  output_freq="1y" output_level="10" enabled=".TRUE."/> <!-- real yearly files --> 
     265      <file_group id="2y"  output_freq="2y" output_level="10" enabled=".TRUE."/> <!-- real 2y files --> 
     266      <file_group id="5y"  output_freq="5y" output_level="10" enabled=".TRUE."/> <!-- real 5y files --> 
     267      <file_group id="10y" output_freq="10y" output_level="10" enabled=".TRUE."/> <!-- real 10y files --> 
     268 
     269   </file_definition> 
     270     
     271    <!--  
     272============================================================================================================ 
     273= grid definition = = DO NOT CHANGE = 
     274============================================================================================================ 
     275    --> 
     276     
     277   <axis_definition>   
     278      <axis id="deptht" long_name="Vertical T levels" unit="m" positive="down" /> 
     279      <axis id="depthu" long_name="Vertical U levels" unit="m" positive="down" /> 
     280      <axis id="depthv" long_name="Vertical V levels" unit="m" positive="down" /> 
     281      <axis id="depthw" long_name="Vertical W levels" unit="m" positive="down" /> 
     282      <axis id="nfloat" long_name="Float number"      unit="-"  /> 
     283      <axis id="icbcla" long_name="Iceberg class"     unit="-"  /> 
     284   </axis_definition>  
     285     
     286   <domain_definition src="./domain_def.xml"/> 
     287    
     288   <grid_definition>     
     289     <grid id="grid_T_2D" domain_ref="grid_T"/> 
     290     <grid id="grid_T_3D" domain_ref="grid_T" axis_ref="deptht"/> 
     291     <grid id="grid_U_2D" domain_ref="grid_U"/> 
     292     <grid id="grid_U_3D" domain_ref="grid_U" axis_ref="depthu"/> 
     293     <grid id="grid_V_2D" domain_ref="grid_V"/> 
     294     <grid id="grid_V_3D" domain_ref="grid_V" axis_ref="depthv"/> 
     295     <grid id="grid_W_2D" domain_ref="grid_W"/> 
     296     <grid id="grid_W_3D" domain_ref="grid_W" axis_ref="depthw"/> 
     297    </grid_definition>    
     298  </context> 
    155299 
    156300  <context id="xios"> 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/CONFIG/ORCA2_LIM/EXP00/namelist_cfg

    r4990 r6839  
    165165/ 
    166166!----------------------------------------------------------------------- 
     167&namzdf_tmx_new !  new tidal mixing parameterization                    ("key_zdftmx_new") 
     168!----------------------------------------------------------------------- 
     169/ 
     170!----------------------------------------------------------------------- 
    167171&namsol        !   elliptic solver / island / free surface 
    168172!----------------------------------------------------------------------- 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/CONFIG/ORCA2_LIM3/EXP00/iodef.xml

    r5517 r6839  
    6161   <file id="file2" name_suffix="_SBC" description="surface fluxes variables" > <!-- time step automaticaly defined based on nn_fsbc --> 
    6262     <field field_ref="empmr"        name="wfo"      /> 
     63          <field field_ref="emp_oce"      name="emp_oce"  long_name="Evap minus Precip over ocean"              /> 
     64          <field field_ref="emp_ice"      name="emp_ice"  long_name="Evap minus Precip over ice"                /> 
    6365     <field field_ref="qsr_oce"      name="qsr_oce"  /> 
    6466     <field field_ref="qns_oce"      name="qns_oce"  /> 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/CONFIG/ORCA2_LIM3/EXP00/namelist_cfg

    r4995 r6839  
    168168/ 
    169169!----------------------------------------------------------------------- 
     170&namzdf_tmx_new !  new tidal mixing parameterization                    ("key_zdftmx_new") 
     171!----------------------------------------------------------------------- 
     172/ 
     173!----------------------------------------------------------------------- 
    170174&namsol        !   elliptic solver / island / free surface 
    171175!----------------------------------------------------------------------- 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/CONFIG/ORCA2_LIM_CFC_C14b/EXP00/1_namelist_cfg

    r5407 r6839  
    55!!                                    namsbc_cpl, namtra_qsr, namsbc_rnf,  
    66!!                                    namsbc_apr, namsbc_ssr, namsbc_alb) 
    7 !!              4 - lateral boundary (namlbc, namcla, namobc, namagrif, nambdy, nambdy_tide) 
     7!!              4 - lateral boundary (namlbc, namcla, namagrif, nambdy, nambdy_tide) 
    88!!              5 - bottom  boundary (nambfr, nambbc, nambbl) 
    99!!              6 - Tracer           (nameos, namtra_adv, namtra_ldf, namtra_dmp) 
    … …  
    303303!!   namlbc        lateral momentum boundary condition 
    304304!!   namcla        cross land advection 
    305 !!   namobc        open boundaries parameters                           ("key_obc") 
    306305!!   namagrif      agrif nested grid ( read by child model only )       ("key_agrif")  
    307306!!   nambdy        Unstructured open boundaries                         ("key_bdy") 
    … …  
    319318!----------------------------------------------------------------------- 
    320319   nn_cla      =    0      !  advection between 2 ocean pts separates by land 
    321 / 
    322 !----------------------------------------------------------------------- 
    323 &namobc        !   open boundaries parameters                           ("key_obc") 
    324 !----------------------------------------------------------------------- 
    325    ln_obc_clim = .false.   !  climatological obc data files (T) or not (F) 
    326    ln_vol_cst  = .true.    !  impose the total volume conservation (T) or not (F) 
    327    ln_obc_fla  = .false.   !  Flather open boundary condition  
    328    nn_obcdta   =    1      !  = 0 the obc data are equal to the initial state 
    329                            !  = 1 the obc data are read in 'obc.dta' files 
    330    cn_obcdta   = 'annual'  !  set to annual if obc datafile hold 1 year of data 
    331                            !  set to monthly if obc datafile hold 1 month of data 
    332    rn_dpein    =    1.     !  damping time scale for inflow at east  open boundary 
    333    rn_dpwin    =    1.     !     -           -         -       west    -      - 
    334    rn_dpnin    =    1.     !     -           -         -       north   -      - 
    335    rn_dpsin    =    1.     !     -           -         -       south   -      - 
    336    rn_dpeob    = 3000.     !  time relaxation (days) for the east  open boundary 
    337    rn_dpwob    =   15.     !     -           -         -     west    -      - 
    338    rn_dpnob    = 3000.     !     -           -         -     north   -      - 
    339    rn_dpsob    =   15.     !     -           -         -     south   -      - 
    340    rn_volemp   =    1.     !  = 0 the total volume change with the surface flux (E-P-R) 
    341                            !  = 1 the total volume remains constant 
    342320/ 
    343321!----------------------------------------------------------------------- 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/CONFIG/ORCA2_LIM_CFC_C14b/EXP00/namelist_cfg

    r5407 r6839  
    136136/ 
    137137!----------------------------------------------------------------------- 
    138 &namobc        !   open boundaries parameters                           ("key_obc") 
    139 !----------------------------------------------------------------------- 
    140 / 
    141 !----------------------------------------------------------------------- 
    142138&namagrif      !  AGRIF zoom                                            ("key_agrif") 
    143139!----------------------------------------------------------------------- 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/CONFIG/ORCA2_LIM_PISCES/EXP00/namelist_cfg

    r4370 r6839  
    165165/ 
    166166!----------------------------------------------------------------------- 
     167&namzdf_tmx_new !  new tidal mixing parameterization                    ("key_zdftmx_new") 
     168!----------------------------------------------------------------------- 
     169/ 
     170!----------------------------------------------------------------------- 
    167171&namsol        !   elliptic solver / island / free surface 
    168172!----------------------------------------------------------------------- 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/CONFIG/SHARED/field_def.xml

    r5517 r6839  
    2323      <field_group id="grid_T" grid_ref="grid_T_2D" > 
    2424         <field id="e3t"          long_name="T-cell thickness"   standard_name="cell_thickness"   unit="m"   grid_ref="grid_T_3D"/> 
     25         <field id="e3t_0"        long_name="Initial T-cell thickness"   standard_name="ref_cell_thickness"   unit="m"   grid_ref="grid_T_3D"/> 
    2526 
    2627         <field id="toce"         long_name="temperature"         standard_name="sea_water_potential_temperature"   unit="degC"     grid_ref="grid_T_3D"/> 
    … …  
    5960         <field id="alpha"        long_name="thermal expansion"                                                         unit="degC-1" grid_ref="grid_T_3D" /> 
    6061         <field id="beta"         long_name="haline contraction"                                                        unit="1e3"    grid_ref="grid_T_3D" /> 
    61          <field id="bn2"          long_name="squared Brunt-Vaisala frequency"                                           unit="s-1"    grid_ref="grid_T_3D" /> 
    6262         <field id="rhop"         long_name="potential density (sigma0)"        standard_name="sea_water_sigma_theta"   unit="kg/m3"  grid_ref="grid_T_3D" /> 
    6363 
    … …  
    174174      <field_group id="SBC" grid_ref="grid_T_2D" > <!-- time step automaticaly defined based on nn_fsbc --> 
    175175         <field id="empmr"        long_name="Net Upward Water Flux"                standard_name="water_flux_out_of_sea_ice_and_sea_water"                              unit="kg/m2/s"   /> 
     176         <field id="empbmr"       long_name="Net Upward Water Flux at pre. tstep"  standard_name="water_flux_out_of_sea_ice_and_sea_water"                              unit="kg/m2/s"   /> 
     177         <field id="emp_oce"      long_name="Evap minus Precip over ocean"         standard_name="evap_minus_precip_over_sea_water"                                     unit="kg/m2/s"   /> 
     178         <field id="emp_ice"      long_name="Evap minus Precip over ice"           standard_name="evap_minus_precip_over_sea_ice"                                       unit="kg/m2/s"   /> 
    176179         <field id="saltflx"      long_name="Downward salt flux"                                                                                                        unit="1e-3/m2/s" /> 
    177180         <field id="fmmflx"       long_name="Water flux due to freezing/melting"                                                                                        unit="kg/m2/s"   /> 
    … …  
    260263         <field id="emp_x_sst"    long_name="Concentration/Dilution term on SST"                                                                                              unit="kg*degC/m2/s" /> 
    261264         <field id="emp_x_sss"    long_name="Concentration/Dilution term on SSS"                                                                                              unit="kg*1e-3/m2/s" />         
     265         <field id="rnf_x_sst"    long_name="Runoff term on SST"                                                                                                              unit="kg*degC/m2/s" /> 
     266         <field id="rnf_x_sss"    long_name="Runoff term on SSS"                                                                                                              unit="kg*1e-3/m2/s" /> 
    262267        
    263268         <field id="iceconc"      long_name="ice concentration"                                            standard_name="sea_ice_area_fraction"                              unit="%"            /> 
    … …  
    274279         <field id="micesalt"     long_name="Mean ice salinity"                                                                                                               unit="1e-3"         /> 
    275280         <field id="miceage"      long_name="Mean ice age"                                                                                                                    unit="years"        /> 
     281         <field id="alb_ice"      long_name="Mean albedo over sea ice"                                                                                                        unit=""             /> 
     282         <field id="albedo"       long_name="Mean albedo over sea ice and ocean"                                                                                              unit=""             /> 
    276283 
    277284         <field id="iceage_cat"   long_name="Ice age for categories"                                       unit="days"   axis_ref="ncatice" /> 
    … …  
    311318         <field id="sfxsni"       long_name="salt flux from snow-ice formation"                            unit="1e-3*kg/m2/day" /> 
    312319         <field id="sfxopw"       long_name="salt flux from open water ice formation"                      unit="1e-3*kg/m2/day" /> 
     320         <field id="sfxsub"       long_name="salt flux from sublimation"                                   unit="1e-3*kg/m2/day" /> 
    313321         <field id="sfx"          long_name="salt flux total"                                              unit="1e-3*kg/m2/day" /> 
    314322 
    … …  
    324332         <field id="vfxsub"       long_name="snw sublimation"                                              unit="m/day"   /> 
    325333         <field id="vfxspr"       long_name="snw precipitation on ice"                                     unit="m/day"   /> 
     334         <field id="vfxthin"      long_name="daily thermo ice prod. for thin ice(<20cm) + open water"      unit="m/day"   /> 
    326335 
    327336         <field id="afxtot"       long_name="area tendency (total)"                                        unit="day-1"   /> 
    … …  
    365374      <field_group id="grid_U"   grid_ref="grid_U_2D"> 
    366375         <field id="e3u"          long_name="U-cell thickness"                                       standard_name="cell_thickness"              unit="m"          grid_ref="grid_U_3D" /> 
     376         <field id="e3u_0"        long_name="Initial U-cell thickness"                               standard_name="ref_cell_thickness"          unit="m"          grid_ref="grid_U_3D"/> 
    367377         <field id="utau"         long_name="Wind Stress along i-axis"                               standard_name="surface_downward_x_stress"   unit="N/m2"                            /> 
    368378         <field id="uoce"         long_name="ocean current along i-axis"                             standard_name="sea_water_x_velocity"        unit="m/s"        grid_ref="grid_U_3D" /> 
    … …  
    400410      <field_group id="grid_V"   grid_ref="grid_V_2D"> 
    401411         <field id="e3v"          long_name="V-cell thickness"                                       standard_name="cell_thickness"              unit="m"          grid_ref="grid_V_3D" /> 
     412         <field id="e3v_0"        long_name="Initial V-cell thickness"                               standard_name="ref_cell_thickness"          unit="m"          grid_ref="grid_V_3D"/> 
    402413         <field id="vtau"         long_name="Wind Stress along j-axis"                               standard_name="surface_downward_y_stress"   unit="N/m2"                            /> 
    403414         <field id="voce"         long_name="ocean current along j-axis"                             standard_name="sea_water_y_velocity"        unit="m/s"        grid_ref="grid_V_3D" /> 
    … …  
    441452        <field id="woce_eiv"     long_name="EIV ocean vertical velocity"   standard_name="bolus_upward_sea_water_velocity"   unit="m/s" /> 
    442453 
    443         <!-- woce_eiv: available with key_trabbl_adv --> 
    444454        <field id="avt"          long_name="vertical eddy diffusivity"   standard_name="ocean_vertical_heat_diffusivity"       unit="m2/s" /> 
     455        <field id="logavt"       long_name="logarithm of vertical eddy diffusivity"   standard_name="ocean_vertical_heat_diffusivity"       unit="m2/s" /> 
    445456        <field id="avm"          long_name="vertical eddy viscosity"     standard_name="ocean_vertical_momentum_diffusivity"   unit="m2/s" /> 
    446457 
    447458        <!-- avs: available with key_zdfddm --> 
    448459        <field id="avs"          long_name="salt vertical eddy diffusivity"   standard_name="ocean_vertical_salt_diffusivity"   unit="m2/s" /> 
     460        <field id="logavs"       long_name="logarithm of salt vertical eddy diffusivity"   standard_name="ocean_vertical_heat_diffusivity"       unit="m2/s" /> 
    449461 
    450462        <!-- avt_evd and avm_evd: available with ln_zdfevd --> 
    … …  
    454466        <!-- avt_tide: available with key_zdftmx --> 
    455467        <field id="av_tide"      long_name="tidal vertical diffusivity"   standard_name="ocean_vertical_tracer_diffusivity_due_to_tides"   unit="m2/s" /> 
     468 
     469       <!-- variables available with key_zdftmx_new --> 
     470        <field id="av_ratio"     long_name="S over T diffusivity ratio"            standard_name="salinity_over_temperature_diffusivity_ratio"                     unit="1"    /> 
     471        <field id="av_wave"      long_name="wave-induced vertical diffusivity"     standard_name="ocean_vertical_tracer_diffusivity_due_to_internal_waves"         unit="m2/s" /> 
     472        <field id="bn2"          long_name="squared Brunt-Vaisala frequency"       standard_name="squared_brunt_vaisala_frequency"                                 unit="s-1"  /> 
     473        <field id="bflx_tmx"     long_name="wave-induced buoyancy flux"            standard_name="buoyancy_flux_due_to_internal_waves"                             unit="W/kg" /> 
     474        <field id="pcmap_tmx"    long_name="power consumed by wave-driven mixing"  standard_name="vertically_integrated_power_consumption_by_wave_driven_mixing"   unit="W/m2"      grid_ref="grid_W_2D" /> 
     475        <field id="emix_tmx"     long_name="power density available for mixing"    standard_name="power_available_for_mixing_from_breaking_internal_waves"         unit="W/kg" /> 
    456476 
    457477        <!-- variables available with key_diaar5 -->    
    … …  
    527547         <field id="ibgsfxbom"    long_name="global mean salt flux (thermo)"                         unit="1e-3*m/day" /> 
    528548         <field id="ibgsfxsum"    long_name="global mean salt flux (thermo)"                         unit="1e-3*m/day" /> 
     549         <field id="ibgsfxsub"    long_name="global mean salt flux (thermo)"                         unit="1e-3*m/day" /> 
    529550 
    530551         <field id="ibghfxdhc"    long_name="Heat content variation in snow and ice"                 unit="W"          /> 
    … …  
    849870       <field id="Totlig"      long_name="Total ligand concentation"               unit="nmol/m3"    grid_ref="grid_T_3D" /> 
    850871       <field id="Biron"       long_name="Bioavailable iron"                       unit="nmol/m3"    grid_ref="grid_T_3D" /> 
    851        <field id="Sdenit"      long_name="Nitrate reduction in the sediments"      unit="mol/m2/s"                        /> 
     872       <field id="Sdenit"      long_name="Nitrate reduction in the sediments"      unit="molN/m2/s"                       /> 
     873       <field id="SedCal"      long_name="Calcite burial in the sediments"         unit="molC/m2/s"                       /> 
     874       <field id="SedSi"       long_name="Silicon burial in the sediments"         unit="molSi/m2/s"                      /> 
     875       <field id="SedC"        long_name="Organic C burial in the sediments"       unit="molC/m2/s"                       /> 
    852876       <field id="Ironice"     long_name="Iron input/uptake due to sea ice"        unit="mol/m2/s"                        /> 
    853877       <field id="HYDR"        long_name="Iron input from hydrothemal vents"       unit="mol/m2/s"   grid_ref="grid_T_3D" /> 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/CONFIG/SHARED/namelist_ice_lim3_ref

    r5429 r6839  
    2121   cn_icerst_outdir = "."          !  directory in which to write output ice restarts 
    2222   ln_limdyn     = .true.          !  ice dynamics (T) or thermodynamics only (F) 
    23    rn_amax       = 0.999           !  maximum tolerated ice concentration  
     23   rn_amax_n     = 0.999           !  maximum tolerated ice concentration NH 
     24   rn_amax_s     = 0.999           !  maximum tolerated ice concentration SH 
    2425   ln_limdiahsb  = .false.         !  check the heat and salt budgets (T) or not (F) 
    2526   ln_limdiaout  = .true.          !  output the heat and salt budgets (T) or not (F) 
    … …  
    8586   rn_hnewice  = 0.1               !  thickness for new ice formation in open water (m) 
    8687   ln_frazil   = .false.           !  use frazil ice collection thickness as a function of wind (T) or not (F) 
    87    rn_maxfrazb = 0.0               !  maximum fraction of frazil ice collecting at the ice base 
     88   rn_maxfrazb = 1.0               !  maximum fraction of frazil ice collecting at the ice base 
    8889   rn_vfrazb   = 0.417             !  thresold drift speed for frazil ice collecting at the ice bottom (m/s) 
    8990   rn_Cfrazb   = 5.0               !  squeezing coefficient for frazil ice collecting at the ice bottom 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/CONFIG/SHARED/namelist_ref

    r6838 r6839  
    55!!                                    namsbc_cpl, namtra_qsr, namsbc_rnf, 
    66!!                                    namsbc_apr, namsbc_ssr, namsbc_alb) 
    7 !!              4 - lateral boundary (namlbc, namcla, namobc, namagrif, nambdy, nambdy_tide) 
     7!!              4 - lateral boundary (namlbc, namcla, namagrif, nambdy, nambdy_tide) 
    88!!              5 - bottom  boundary (nambfr, nambbc, nambbl) 
    99!!              6 - Tracer           (nameos, namtra_adv, namtra_ldf, namtra_dmp) 
    1010!!              7 - dynamics         (namdyn_adv, namdyn_vor, namdyn_hpg, namdyn_spg, namdyn_ldf) 
    11 !!              8 - Verical physics  (namzdf, namzdf_ric, namzdf_tke, namzdf_kpp, namzdf_ddm, namzdf_tmx) 
     11!!              8 - Verical physics  (namzdf, namzdf_ric, namzdf_tke, namzdf_kpp, namzdf_ddm, namzdf_tmx, namzdf_tmx_new) 
    1212!!              9 - diagnostics      (namnc4, namtrd, namspr, namflo, namhsb, namsto) 
    1313!!             10 - miscellaneous    (namsol, nammpp, namctl) 
    … …  
    408408   ln_qsr_2bd  = .false.   !  2 bands              light penetration 
    409409   ln_qsr_bio  = .false.   !  bio-model light penetration 
    410    nn_chldta   =      1    !  RGB : Chl data (=1) or cst value (=0) 
     410   nn_chldta   =      1    !  RGB : 2D Chl data (=1), 3D Chl data (=2) or cst value (=0) 
    411411   rn_abs      =   0.58    !  RGB & 2 bands: fraction of light (rn_si1) 
    412412   rn_si0      =   0.35    !  RGB & 2 bands: shortess depth of extinction 
    … …  
    500500&namsbc_alb    !   albedo parameters 
    501501!----------------------------------------------------------------------- 
    502    rn_cloud    =    0.06   !  cloud correction to snow and ice albedo 
    503    rn_albice   =    0.53   !  albedo of melting ice in the arctic and antarctic 
    504    rn_alphd    =    0.80   !  coefficients for linear interpolation used to 
    505    rn_alphc    =    0.65   !  compute albedo between two extremes values 
    506    rn_alphdi   =    0.72   !  (Pyane, 1972) 
     502   nn_ice_alb  =    0   !  parameterization of ice/snow albedo 
     503                        !     0: Shine & Henderson-Sellers (JGR 1985) 
     504                        !     1: "home made" based on Brandt et al. (J. Climate 2005) 
     505                        !                         and Grenfell & Perovich (JGR 2004) 
     506   rn_albice   =  0.53  !  albedo of bare puddled ice (values from 0.49 to 0.58) 
     507                        !     0.53 (default) => if nn_ice_alb=0 
     508                        !     0.50 (default) => if nn_ice_alb=1 
    507509/ 
    508510!----------------------------------------------------------------------- 
    … …  
    546548!!   namlbc        lateral momentum boundary condition 
    547549!!   namcla        cross land advection 
    548 !!   namobc        open boundaries parameters                           ("key_obc") 
    549550!!   namagrif      agrif nested grid ( read by child model only )       ("key_agrif") 
    550551!!   nambdy        Unstructured open boundaries                         ("key_bdy") 
    … …  
    563564!----------------------------------------------------------------------- 
    564565   nn_cla      =    0      !  advection between 2 ocean pts separates by land 
    565 / 
    566 !----------------------------------------------------------------------- 
    567 &namobc        !   open boundaries parameters                           ("key_obc") 
    568 !----------------------------------------------------------------------- 
    569    ln_obc_clim = .false.   !  climatological obc data files (T) or not (F) 
    570    ln_vol_cst  = .true.    !  impose the total volume conservation (T) or not (F) 
    571    ln_obc_fla  = .false.   !  Flather open boundary condition 
    572    nn_obcdta   =    1      !  = 0 the obc data are equal to the initial state 
    573                            !  = 1 the obc data are read in 'obc.dta' files 
    574    cn_obcdta   = 'annual'  !  set to annual if obc datafile hold 1 year of data 
    575                            !  set to monthly if obc datafile hold 1 month of data 
    576    rn_dpein    =    1.     !  damping time scale for inflow at east  open boundary 
    577    rn_dpwin    =    1.     !     -           -         -       west    -      - 
    578    rn_dpnin    =    1.     !     -           -         -       north   -      - 
    579    rn_dpsin    =    1.     !     -           -         -       south   -      - 
    580    rn_dpeob    = 3000.     !  time relaxation (days) for the east  open boundary 
    581    rn_dpwob    =   15.     !     -           -         -     west    -      - 
    582    rn_dpnob    = 3000.     !     -           -         -     north   -      - 
    583    rn_dpsob    =   15.     !     -           -         -     south   -      - 
    584    rn_volemp   =    1.     !  = 0 the total volume change with the surface flux (E-P-R) 
    585                            !  = 1 the total volume remains constant 
    586566/ 
    587567!----------------------------------------------------------------------- 
    … …  
    898878!!             Tracers & Dynamics vertical physics namelists 
    899879!!====================================================================== 
    900 !!    namzdf        vertical physics 
    901 !!    namzdf_ric    richardson number dependent vertical mixing         ("key_zdfric") 
    902 !!    namzdf_tke    TKE dependent vertical mixing                       ("key_zdftke") 
    903 !!    namzdf_kpp    KPP dependent vertical mixing                       ("key_zdfkpp") 
    904 !!    namzdf_ddm    double diffusive mixing parameterization            ("key_zdfddm") 
    905 !!    namzdf_tmx    tidal mixing parameterization                       ("key_zdftmx") 
     880!!    namzdf            vertical physics 
     881!!    namzdf_ric        richardson number dependent vertical mixing     ("key_zdfric") 
     882!!    namzdf_tke        TKE dependent vertical mixing                   ("key_zdftke") 
     883!!    namzdf_kpp        KPP dependent vertical mixing                   ("key_zdfkpp") 
     884!!    namzdf_ddm        double diffusive mixing parameterization        ("key_zdfddm") 
     885!!    namzdf_tmx        tidal mixing parameterization                   ("key_zdftmx") 
     886!!    namzdf_tmx_new    new tidal mixing parameterization               ("key_zdftmx_new") 
    906887!!    namzdf_convadj  convective adjustment (cliff)                      
    907888!!====================================================================== 
    … …  
    1011992   rn_tfe_itf  = 1.        !  ITF tidal dissipation efficiency 
    1012993/ 
    1013  
     994!----------------------------------------------------------------------- 
     995&namzdf_tmx_new    !   new tidal mixing parameterization                ("key_zdftmx_new") 
     996!----------------------------------------------------------------------- 
     997   nn_zpyc     = 1         !  pycnocline-intensified dissipation scales as N (=1) or N^2 (=2) 
     998   ln_mevar    = .true.    !  variable (T) or constant (F) mixing efficiency 
     999   ln_tsdiff   = .true.    !  account for differential T/S mixing (T) or not (F) 
     1000/ 
    10141001!----------------------------------------------------------------------- 
    10151002&namzdf_convadj    !   Convective adjustment (cliff) parameterization    
    … …  
    12051192   ln_s3d     = .false.    ! Logical switch for S profile observations 
    12061193   ln_ena     = .false.    ! Logical switch for ENACT insitu data set 
    1207    !                       !     ln_cor                  Logical switch for Coriolis insitu data set 
     1194   ln_cor     = .false.    ! Logical switch for Coriolis insitu data set 
    12081195   ln_profb   = .false.    ! Logical switch for feedback insitu data set 
    12091196   ln_sla     = .false.    ! Logical switch for SLA observations 
    1210  
    12111197   ln_sladt   = .false.    ! Logical switch for AVISO SLA data 
    1212  
    12131198   ln_slafb   = .false.    ! Logical switch for feedback SLA data 
    1214                            !     ln_ssh                  Logical switch for SSH observations 
    1215  
    1216    ln_sst     = .false.     ! Logical switch for SST observations 
    1217    ln_reysst  = .false.     !     ln_reysst               Logical switch for Reynolds observations 
    1218    ln_ghrsst  = .false.    !     ln_ghrsst               Logical switch for GHRSST observations 
    1219  
     1199   ln_ssh     = .false.    ! Logical switch for SSH observations 
     1200   ln_sst     = .false.    ! Logical switch for SST observations 
     1201   ln_reysst  = .false.    ! Logical switch for Reynolds observations 
     1202   ln_ghrsst  = .false.    ! Logical switch for GHRSST observations 
    12201203   ln_sstfb   = .false.    ! Logical switch for feedback SST data 
    1221                            !     ln_sss                  Logical switch for SSS observations 
     1204   ln_sss     = .false.    ! Logical switch for SSS observations 
    12221205   ln_seaice  = .false.    ! Logical switch for Sea Ice observations 
    1223                            !     ln_vel3d                Logical switch for velocity observations 
    1224                            !     ln_velavcur             Logical switch for velocity daily av. cur. 
    1225                            !     ln_velhrcur             Logical switch for velocity high freq. cur. 
    1226                            !     ln_velavadcp            Logical switch for velocity daily av. ADCP 
    1227                            !     ln_velhradcp            Logical switch for velocity high freq. ADCP 
    1228                            !     ln_velfb                Logical switch for feedback velocity data 
    1229                            !     ln_grid_global          Global distribtion of observations 
    1230                            !     ln_grid_search_lookup   Logical switch for obs grid search w/lookup table 
    1231                            !     grid_search_file        Grid search lookup file header 
    1232                            !     enactfiles              ENACT input observation file names 
    1233                            !     coriofiles              Coriolis input observation file name 
    1234    !                       ! profbfiles: Profile feedback input observation file name 
    1235    profbfiles = 'profiles_01.nc' 
    1236                            !     ln_profb_enatim         Enact feedback input time setting switch 
    1237                            !     slafilesact             Active SLA input observation file name 
    1238                            !     slafilespas             Passive SLA input observation file name 
    1239    !                       ! slafbfiles: Feedback SLA input observation file name 
    1240    slafbfiles = 'sla_01.nc' 
    1241                            !     sstfiles                GHRSST input observation file name 
    1242    !                       ! sstfbfiles: Feedback SST input observation file name 
    1243    sstfbfiles = 'sst_01.nc' 
    1244                            !     seaicefiles             Sea Ice input observation file names 
    1245    seaicefiles = 'seaice_01.nc' 
    1246                            !     velavcurfiles           Vel. cur. daily av. input file name 
    1247                            !     velhvcurfiles           Vel. cur. high freq. input file name 
    1248                            !     velavadcpfiles          Vel. ADCP daily av. input file name 
    1249                            !     velhvadcpfiles          Vel. ADCP high freq. input file name 
    1250                            !     velfbfiles              Vel. feedback input observation file name 
    1251                            !     dobsini                 Initial date in window YYYYMMDD.HHMMSS 
    1252                            !     dobsend                 Final date in window YYYYMMDD.HHMMSS 
    1253                            !     n1dint                  Type of vertical interpolation method 
    1254                            !     n2dint                  Type of horizontal interpolation method 
    1255                            !     ln_nea                  Rejection of observations near land switch 
    1256    nmsshc     = 0          ! MSSH correction scheme 
    1257                            !     mdtcorr                 MDT  correction 
    1258                            !     mdtcutoff               MDT cutoff for computed correction 
     1206   ln_vel3d   = .false.    ! Logical switch for velocity observations 
     1207   ln_velavcur= .false     ! Logical switch for velocity daily av. cur. 
     1208   ln_velhrcur= .false     ! Logical switch for velocity high freq. cur. 
     1209   ln_velavadcp = .false.  ! Logical switch for velocity daily av. ADCP 
     1210   ln_velhradcp = .false.  ! Logical switch for velocity high freq. ADCP 
     1211   ln_velfb   = .false.    ! Logical switch for feedback velocity data 
     1212   ln_grid_global = .false. ! Global distribtion of observations 
     1213   ln_grid_search_lookup = .false. !  Logical switch for obs grid search w/lookup table 
     1214   grid_search_file = 'grid_search'  !  Grid search lookup file header 
     1215! All of the *files* variables below are arrays. Use namelist_cfg to add more files 
     1216   enactfiles = 'enact.nc' !  ENACT input observation file names (specify full array in namelist_cfg) 
     1217   coriofiles = 'corio.nc' !  Coriolis input observation file name 
     1218   profbfiles = 'profiles_01.nc' ! Profile feedback input observation file name 
     1219   ln_profb_enatim = .false !        Enact feedback input time setting switch 
     1220   slafilesact = 'sla_act.nc' !  Active SLA input observation file names 
     1221   slafilespas = 'sla_pass.nc' ! Passive SLA input observation file names 
     1222   slafbfiles = 'sla_01.nc' ! slafbfiles: Feedback SLA input observation file names 
     1223   sstfiles = 'ghrsst.nc'   ! GHRSST input observation file names 
     1224   sstfbfiles = 'sst_01.nc' ! Feedback SST input observation file names 
     1225   seaicefiles = 'seaice_01.nc' ! Sea Ice input observation file names 
     1226   velavcurfiles = 'velavcurfile.nc'  ! Vel. cur. daily av. input file name 
     1227   velhrcurfiles = 'velhrcurfile.nc'  ! Vel. cur. high freq. input file name 
     1228   velavadcpfiles = 'velavadcpfile.nc' ! Vel. ADCP daily av. input file name 
     1229   velhradcpfiles = 'velhradcpfile.nc' ! Vel. ADCP high freq. input file name 
     1230   velfbfiles = 'velfbfile.nc' ! Vel. feedback input observation file name 
     1231   dobsini = 20000101.000000  !  Initial date in window YYYYMMDD.HHMMSS 
     1232   dobsend = 20010101.000000  !  Final date in window YYYYMMDD.HHMMSS 
     1233   n1dint = 0  !               Type of vertical interpolation method 
     1234   n2dint = 0  !               Type of horizontal interpolation method 
     1235   ln_nea = .false.   !        Rejection of observations near land switch 
     1236   nmsshc     = 0     !        MSSH correction scheme 
     1237   mdtcorr = 1.61     !        MDT  correction 
     1238   mdtcutoff = 65.0   !        MDT cutoff for computed correction 
    12591239   ln_altbias = .false.    ! Logical switch for alt bias 
    12601240   ln_ignmis  = .true.     ! Logical switch for ignoring missing files 
    1261                            !     endailyavtypes   ENACT daily average types 
     1241   endailyavtypes = 820    ! ENACT daily average types - array (use namelist_cfg to set more values) 
    12621242   ln_grid_global = .true. 
    12631243   ln_grid_search_lookup = .false. 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/CONFIG/SHARED/namelist_top_ref

    r5416 r6839  
    6262   rn_ahtrc_0       =  2000.    !  horizontal eddy diffusivity for tracers [m2/s] 
    6363   rn_ahtrb_0       =     0.    !     background eddy diffusivity for ldf_iso [m2/s] 
     64   rn_fact_lap      =     1.    !     enhanced zonal eddy diffusivity 
    6465/ 
    6566!----------------------------------------------------------------------- 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/CONFIG/cfg.txt

    r6836 r6839  
    66GYRE_BFM OPA_SRC TOP_SRC 
    77AMM12 OPA_SRC 
     8ORCA2_OFF_PISCES OPA_SRC OFF_SRC TOP_SRC 
    89ORCA2_LIM_PISCES OPA_SRC LIM_SRC_2 NST_SRC TOP_SRC 
     10ORCA2_LIM3 OPA_SRC LIM_SRC_3 NST_SRC 
    911GYRE OPA_SRC 
    10 ORCA2_LIM3 OPA_SRC LIM_SRC_3 NST_SRC 
    1112ORCA2_LIM OPA_SRC LIM_SRC_2 NST_SRC 
    12 ORCA2_OFF_PISCES OPA_SRC OFF_SRC TOP_SRC 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/LIM_SRC_2/limistate_2.F90

    r6836 r6839  
    6969      IF( .NOT. ln_limini ) THEN   
    7070          
    71          tfu(:,:) = eos_fzp( tsn(:,:,1,jp_sal) ) * tmask(:,:,1)       ! freezing/melting point of sea water [Celcius] 
     71         CALL eos_fzp( tsn(:,:,1,jp_sal), tfu(:,:) )       ! freezing/melting point of sea water [Celcius] 
     72         tfu(:,:) = tfu(:,:) *  tmask(:,:,1) 
    7273 
    7374         DO jj = 1, jpj 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/LIM_SRC_3/ice.F90

    r6836 r6839  
    234234   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   u_oce, v_oce   !: surface ocean velocity used in ice dynamics 
    235235   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   ahiu , ahiv    !: hor. diffusivity coeff. at U- and V-points [m2/s] 
    236    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   pahu , pahv    !: ice hor. eddy diffusivity coef. at U- and V-points 
    237236   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   ust2s, hicol   !: friction velocity, ice collection thickness accreted in leads 
    238237   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   strp1, strp2   !: strength at previous time steps 
    … …  
    253252   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   fhld        !: heat flux from the lead used for bottom melting 
    254253 
    255    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_snw    !: snow-ocean mass exchange over 1 time step [kg/m2] 
    256    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_spr    !: snow precipitation on ice over 1 time step [kg/m2] 
    257    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_sub    !: snow sublimation over 1 time step [kg/m2] 
    258  
    259    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_ice    !: ice-ocean mass exchange over 1 time step [kg/m2] 
    260    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_sni    !: snow ice growth component of wfx_ice [kg/m2] 
    261    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_opw    !: lateral ice growth component of wfx_ice [kg/m2] 
    262    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_bog    !: bottom ice growth component of wfx_ice [kg/m2] 
    263    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_dyn    !: dynamical ice growth component of wfx_ice [kg/m2] 
    264    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_bom    !: bottom melt component of wfx_ice [kg/m2] 
    265    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_sum    !: surface melt component of wfx_ice [kg/m2] 
    266    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_res    !: residual component of wfx_ice [kg/m2] 
    267  
    268    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   afx_tot     !: ice concentration tendency (total) [s-1] 
     254   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_snw    !: snow-ocean mass exchange   [kg.m-2.s-1] 
     255   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_spr    !: snow precipitation on ice  [kg.m-2.s-1] 
     256   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_sub    !: snow/ice sublimation       [kg.m-2.s-1] 
     257 
     258   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_ice    !: ice-ocean mass exchange                   [kg.m-2.s-1] 
     259   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_sni    !: snow ice growth component of wfx_ice      [kg.m-2.s-1] 
     260   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_opw    !: lateral ice growth component of wfx_ice   [kg.m-2.s-1] 
     261   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_bog    !: bottom ice growth component of wfx_ice    [kg.m-2.s-1] 
     262   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_dyn    !: dynamical ice growth component of wfx_ice [kg.m-2.s-1] 
     263   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_bom    !: bottom melt component of wfx_ice          [kg.m-2.s-1] 
     264   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_sum    !: surface melt component of wfx_ice         [kg.m-2.s-1] 
     265   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_res    !: residual component of wfx_ice             [kg.m-2.s-1] 
     266 
     267   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   afx_tot     !: ice concentration tendency (total)          [s-1] 
    269268   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   afx_thd     !: ice concentration tendency (thermodynamics) [s-1] 
    270    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   afx_dyn     !: ice concentration tendency (dynamics) [s-1] 
     269   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   afx_dyn     !: ice concentration tendency (dynamics)       [s-1] 
    271270 
    272271   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   sfx_bog     !: salt flux due to ice growth/melt                      [PSU/m2/s] 
    … …  
    279278   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   sfx_res     !: residual salt flux due to correction of ice thickness [PSU/m2/s] 
    280279 
    281    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_bog     !: total heat flux causing bottom ice growth  
    282    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_bom     !: total heat flux causing bottom ice melt  
    283    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_sum     !: total heat flux causing surface ice melt  
    284    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_opw     !: total heat flux causing open water ice formation 
    285    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_dif     !: total heat flux causing Temp change in the ice  
    286    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_snw     !: heat flux for snow melt  
    287    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_err     !: heat flux error after heat diffusion  
    288    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_err_dif !: heat flux remaining due to change in non-solar flux 
    289    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_err_rem !: heat flux error after heat remapping  
    290    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_in      !: heat flux available for thermo transformations  
    291    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_out     !: heat flux remaining at the end of thermo transformations  
    292  
     280   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   sfx_sub     !: salt flux due to ice sublimation 
     281 
     282   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_bog     !: total heat flux causing bottom ice growth        [W.m-2] 
     283   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_bom     !: total heat flux causing bottom ice melt          [W.m-2] 
     284   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_sum     !: total heat flux causing surface ice melt         [W.m-2] 
     285   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_opw     !: total heat flux causing open water ice formation [W.m-2] 
     286   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_dif     !: total heat flux causing Temp change in the ice   [W.m-2] 
     287   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_snw     !: heat flux for snow melt                          [W.m-2] 
     288   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_err     !: heat flux error after heat diffusion             [W.m-2] 
     289   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_err_dif !: heat flux remaining due to change in non-solar flux [W.m-2] 
     290   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_err_rem !: heat flux error after heat remapping             [W.m-2] 
     291   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_in      !: heat flux available for thermo transformations   [W.m-2] 
     292   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_out     !: heat flux remaining at the end of thermo transformations  [W.m-2] 
     293   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_err_sub !: mass flux error after sublimation [kg.m-2.s-1] 
     294    
    293295   ! heat flux associated with ice-atmosphere mass exchange 
    294    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_sub     !: heat flux for sublimation  
    295    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_spr     !: heat flux of the snow precipitation  
     296   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_sub     !: heat flux for sublimation  [W.m-2] 
     297   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_spr     !: heat flux of the snow precipitation  [W.m-2] 
    296298 
    297299   ! heat flux associated with ice-ocean mass exchange 
    298    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_thd     !: ice-ocean heat flux from thermo processes (limthd_dh)  
    299    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_dyn     !: ice-ocean heat flux from mecanical processes (limitd_me)  
    300    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_res     !: residual heat flux due to correction of ice thickness 
    301  
    302    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   ftr_ice   !: transmitted solar radiation under ice 
     300   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_thd     !: ice-ocean heat flux from thermo processes (limthd_dh)  [W.m-2] 
     301   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_dyn     !: ice-ocean heat flux from mecanical processes (limitd_me)  [W.m-2] 
     302   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_res     !: residual heat flux due to correction of ice thickness [W.m-2] 
     303 
     304   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   ftr_ice   !: transmitted solar radiation under ice    
     305   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   pahu3D , pahv3D 
     306   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   rn_amax_2d  !: maximum ice concentration 2d array 
    303307 
    304308   !!-------------------------------------------------------------------------- 
    … …  
    372376   INTEGER          , PUBLIC ::   nlay_i          !: number of ice  layers  
    373377   INTEGER          , PUBLIC ::   nlay_s          !: number of snow layers  
    374    CHARACTER(len=32), PUBLIC ::   cn_icerst_in    !: suffix of ice restart name (input) 
     378   CHARACTER(len=80), PUBLIC ::   cn_icerst_in    !: suffix of ice restart name (input) 
    375379   CHARACTER(len=256), PUBLIC ::   cn_icerst_indir !: ice restart input directory 
    376    CHARACTER(len=32), PUBLIC ::   cn_icerst_out   !: suffix of ice restart name (output) 
     380   CHARACTER(len=80), PUBLIC ::   cn_icerst_out   !: suffix of ice restart name (output) 
    377381   CHARACTER(len=256), PUBLIC ::   cn_icerst_outdir!: ice restart output directory 
    378382   LOGICAL          , PUBLIC ::   ln_limdyn       !: flag for ice dynamics (T) or not (F) 
    379383   LOGICAL          , PUBLIC ::   ln_icectl       !: flag for sea-ice points output (T) or not (F) 
    380    REAL(wp)         , PUBLIC ::   rn_amax         !: maximum ice concentration 
     384   REAL(wp)         , PUBLIC ::   rn_amax_n       !: maximum ice concentration Northern hemisphere 
     385   REAL(wp)         , PUBLIC ::   rn_amax_s       !: maximum ice concentration Southern hemisphere 
    381386   INTEGER          , PUBLIC ::   iiceprt         !: debug i-point 
    382387   INTEGER          , PUBLIC ::   jiceprt         !: debug j-point 
    … …  
    424429      ALLOCATE( u_oce    (jpi,jpj) , v_oce    (jpi,jpj) ,                           & 
    425430         &      ahiu     (jpi,jpj) , ahiv     (jpi,jpj) ,                           & 
    426          &      pahu     (jpi,jpj) , pahv     (jpi,jpj) ,                           & 
    427431         &      ust2s    (jpi,jpj) , hicol    (jpi,jpj) ,                           & 
    428432         &      strp1    (jpi,jpj) , strp2    (jpi,jpj) , strength  (jpi,jpj) ,     & 
    … …  
    437441         &      wfx_res(jpi,jpj) , wfx_sni(jpi,jpj) , wfx_opw(jpi,jpj) , wfx_spr(jpi,jpj) ,     & 
    438442         &      afx_tot(jpi,jpj) , afx_thd(jpi,jpj),  afx_dyn(jpi,jpj) ,                        & 
    439          &      fhtur  (jpi,jpj) , ftr_ice(jpi,jpj,jpl), qlead  (jpi,jpj) ,                     & 
    440          &      sfx_res(jpi,jpj) , sfx_bri(jpi,jpj) , sfx_dyn(jpi,jpj) ,                        & 
     443         &      fhtur  (jpi,jpj) , ftr_ice(jpi,jpj,jpl), pahu3D(jpi,jpj,jpl+1), pahv3D(jpi,jpj,jpl+1),            & 
     444         &      qlead  (jpi,jpj) , rn_amax_2d(jpi,jpj),                                         & 
     445         &      sfx_res(jpi,jpj) , sfx_bri(jpi,jpj) , sfx_dyn(jpi,jpj) , sfx_sub(jpi,jpj),      & 
    441446         &      sfx_bog(jpi,jpj) , sfx_bom(jpi,jpj) , sfx_sum(jpi,jpj) , sfx_sni(jpi,jpj) , sfx_opw(jpi,jpj) ,    & 
    442447         &      hfx_res(jpi,jpj) , hfx_snw(jpi,jpj) , hfx_sub(jpi,jpj) , hfx_err(jpi,jpj) ,     &  
    443          &      hfx_err_dif(jpi,jpj) , hfx_err_rem(jpi,jpj) ,                                   & 
     448         &      hfx_err_dif(jpi,jpj) , hfx_err_rem(jpi,jpj) , wfx_err_sub(jpi,jpj) ,       & 
    444449         &      hfx_in (jpi,jpj) , hfx_out(jpi,jpj) , fhld(jpi,jpj) ,                           & 
    445450         &      hfx_sum(jpi,jpj) , hfx_bom(jpi,jpj) , hfx_bog(jpi,jpj) , hfx_dif(jpi,jpj) , hfx_opw(jpi,jpj) ,    & 
    … …  
    508513   !!====================================================================== 
    509514END MODULE ice 
     515 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/LIM_SRC_3/limcons.F90

    r6836 r6839  
    2424   USE lib_fortran    ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)   
    2525   USE sbc_oce , ONLY : sfx  ! Surface boundary condition: ocean fields 
    26  
     26   USE sbc_ice , ONLY : qevap_ice 
     27    
    2728   IMPLICIT NONE 
    2829   PRIVATE 
    … …  
    184185         ! salt flux 
    185186         zfs_b  = glob_sum(  ( sfx_bri(:,:) + sfx_bog(:,:) + sfx_bom(:,:) + sfx_sum(:,:) + sfx_sni(:,:) +  & 
    186             &                  sfx_opw(:,:) + sfx_res(:,:) + sfx_dyn(:,:)                                  & 
     187            &                  sfx_opw(:,:) + sfx_res(:,:) + sfx_dyn(:,:) + sfx_sub(:,:)                   & 
    187188            &                ) *  e12t(:,:) * tmask(:,:,1) * zconv ) 
    188189 
    … …  
    209210         ! salt flux 
    210211         zfs  = glob_sum(  ( sfx_bri(:,:) + sfx_bog(:,:) + sfx_bom(:,:) + sfx_sum(:,:) + sfx_sni(:,:) +  & 
    211             &                sfx_opw(:,:) + sfx_res(:,:) + sfx_dyn(:,:)                                  &  
     212            &                sfx_opw(:,:) + sfx_res(:,:) + sfx_dyn(:,:) + sfx_sub(:,:)                   &  
    212213            &              ) * e12t(:,:) * tmask(:,:,1) * zconv ) - zfs_b 
    213214 
    … …  
    256257            ENDIF 
    257258            IF (     zvmin   < -epsi10 ) WRITE(numout,*) 'violation v_i<0  [m]          (',cd_routine,') = ',zvmin 
    258             IF (     zamax   > rn_amax+epsi10 .AND. cd_routine /= 'limtrp' .AND. cd_routine /= 'limitd_me' ) THEN 
     259            IF (     zamax   > MAX( rn_amax_n, rn_amax_s ) + epsi10 .AND. & 
     260               &                         cd_routine /= 'limtrp' .AND. cd_routine /= 'limitd_me' ) THEN 
    259261                                         WRITE(numout,*) 'violation a_i>amax            (',cd_routine,') = ',zamax 
    260262            ENDIF 
    … …  
    286288#if ! defined key_bdy 
    287289      ! heat flux 
    288       zhfx  = glob_sum( ( hfx_in - hfx_out - diag_heat - diag_trp_ei - diag_trp_es - hfx_sub ) * e12t * tmask(:,:,1) * zconv )  
     290      zhfx  = glob_sum( ( hfx_in - hfx_out - diag_heat - diag_trp_ei - diag_trp_es - SUM( qevap_ice * a_i_b, dim=3 ) )  & 
     291         &              * e12t * tmask(:,:,1) * zconv )  
    289292      ! salt flux 
    290293      zsfx  = glob_sum( ( sfx + diag_smvi ) * e12t * tmask(:,:,1) * zconv ) * rday 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/LIM_SRC_3/limdiahsb.F90

    r6836 r6839  
    5656      real(wp)   ::   zbg_ivo, zbg_svo, zbg_are, zbg_sal ,zbg_tem ,zbg_ihc ,zbg_shc 
    5757      real(wp)   ::   zbg_sfx, zbg_sfx_bri, zbg_sfx_bog, zbg_sfx_bom, zbg_sfx_sum, zbg_sfx_sni,   & 
    58       &               zbg_sfx_opw, zbg_sfx_res, zbg_sfx_dyn  
     58      &               zbg_sfx_opw, zbg_sfx_res, zbg_sfx_dyn, zbg_sfx_sub  
    5959      real(wp)   ::   zbg_vfx, zbg_vfx_bog, zbg_vfx_opw, zbg_vfx_sni, zbg_vfx_dyn 
    6060      real(wp)   ::   zbg_vfx_bom, zbg_vfx_sum, zbg_vfx_res, zbg_vfx_spr, zbg_vfx_snw, zbg_vfx_sub   
    … …  
    111111      zbg_sfx_bom = ztmp * glob_sum( sfx_bom(:,:) * e12t(:,:) * tmask(:,:,1) ) 
    112112      zbg_sfx_sum = ztmp * glob_sum( sfx_sum(:,:) * e12t(:,:) * tmask(:,:,1) ) 
     113      zbg_sfx_sub = ztmp * glob_sum( sfx_sub(:,:) * e12t(:,:) * tmask(:,:,1) ) 
    113114 
    114115      ! Heat budget 
    … …  
    189190      CALL iom_put( 'ibgsfxbom' , zbg_sfx_bom                              )   ! salt flux bottom melt       - 
    190191      CALL iom_put( 'ibgsfxsum' , zbg_sfx_sum                              )   ! salt flux surface melt      - 
     192      CALL iom_put( 'ibgsfxsub' , zbg_sfx_sub                              )   ! salt flux sublimation      - 
    191193 
    192194      CALL iom_put( 'ibghfxdhc' , zbg_hfx_dhc                              )   ! Heat content variation in snow and ice [W] 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/LIM_SRC_3/limhdf.F90

    r6836 r6839  
    77   !!             -   !  2001-05 (G. Madec, R. Hordoir) opa norm 
    88   !!            1.0  !  2002-08 (C. Ethe)  F90, free form 
     9   !!            3.0  !  2015-08 (O. Tintó and M. Castrillo)  added lim_hdf (multiple) 
    910   !!---------------------------------------------------------------------- 
    1011#if defined key_lim3 
    … …  
    2728   PRIVATE 
    2829 
    29    PUBLIC   lim_hdf         ! called by lim_trp 
     30   PUBLIC   lim_hdf ! called by lim_trp 
    3031   PUBLIC   lim_hdf_init    ! called by sbc_lim_init 
    3132 
    … …  
    4344CONTAINS 
    4445 
    45    SUBROUTINE lim_hdf( ptab ) 
     46   SUBROUTINE lim_hdf( ptab , ihdf_vars , jpl , nlay_i ) 
    4647      !!------------------------------------------------------------------- 
    4748      !!                  ***  ROUTINE lim_hdf  *** 
    … …  
    5455      !! ** Action  :    update ptab with the diffusive contribution 
    5556      !!------------------------------------------------------------------- 
    56       REAL(wp), DIMENSION(jpi,jpj), INTENT( inout ) ::   ptab    ! Field on which the diffusion is applied 
    57       ! 
    58       INTEGER                           ::  ji, jj                    ! dummy loop indices 
     57      INTEGER                           :: jpl, nlay_i, isize, ihdf_vars 
     58      REAL(wp),  DIMENSION(:,:,:), INTENT( inout ),TARGET ::   ptab    ! Field on which the diffusion is applied 
     59      ! 
     60      INTEGER                           ::  ji, jj, jk, jl , jm               ! dummy loop indices 
    5961      INTEGER                           ::  iter, ierr           ! local integers 
    60       REAL(wp)                          ::  zrlxint, zconv     ! local scalars 
    61       REAL(wp), POINTER, DIMENSION(:,:) ::  zrlx, zflu, zflv, zdiv0, zdiv, ztab0 
     62      REAL(wp)                          ::  zrlxint     ! local scalars 
     63      REAL(wp), POINTER , DIMENSION ( : )        :: zconv     ! local scalars 
     64      REAL(wp), POINTER , DIMENSION(:,:,:) ::  zrlx,zdiv0, ztab0 
     65      REAL(wp), POINTER , DIMENSION(:,:) ::  zflu, zflv, zdiv 
    6266      CHARACTER(lc)                     ::  charout                   ! local character 
    6367      REAL(wp), PARAMETER               ::  zrelax = 0.5_wp           ! relaxation constant for iterative procedure 
    … …  
    6569      INTEGER , PARAMETER               ::  its    = 100              ! Maximum number of iteration 
    6670      !!------------------------------------------------------------------- 
     71      TYPE(arrayptr)   , ALLOCATABLE, DIMENSION(:) ::   pt2d_array, zrlx_array 
     72      CHARACTER(len=1) , ALLOCATABLE, DIMENSION(:) ::   type_array ! define the nature of ptab array grid-points 
     73      !                                                            ! = T , U , V , F , W and I points 
     74      REAL(wp)        , ALLOCATABLE, DIMENSION(:)  ::   psgn_array    ! =-1 the sign change across the north fold boundary 
     75 
     76     !!---------------------------------------------------------------------  
     77 
     78      !                       !==  Initialisation  ==! 
     79      ! +1 open water diffusion 
     80      isize = jpl*(ihdf_vars+nlay_i)+1 
     81      ALLOCATE( zconv (isize) ) 
     82      ALLOCATE( pt2d_array(isize) , zrlx_array(isize) ) 
     83      ALLOCATE( type_array(isize) ) 
     84      ALLOCATE( psgn_array(isize) ) 
    6785       
    68       CALL wrk_alloc( jpi, jpj, zrlx, zflu, zflv, zdiv0, zdiv, ztab0 ) 
    69  
    70       !                       !==  Initialisation  ==! 
     86      CALL wrk_alloc( jpi, jpj, isize, zrlx, zdiv0, ztab0 ) 
     87      CALL wrk_alloc( jpi, jpj, zflu, zflv, zdiv ) 
     88 
     89      DO jk= 1 , isize 
     90         pt2d_array(jk)%pt2d=>ptab(:,:,jk) 
     91         zrlx_array(jk)%pt2d=>zrlx(:,:,jk) 
     92         type_array(jk)='T' 
     93         psgn_array(jk)=1. 
     94      END DO 
     95 
    7196      ! 
    7297      IF( linit ) THEN              ! Metric coefficient (compute at the first call and saved in efact) 
    … …  
    7499         IF( lk_mpp    )   CALL mpp_sum( ierr ) 
    75100         IF( ierr /= 0 )   CALL ctl_stop( 'STOP', 'lim_hdf : unable to allocate arrays' ) 
    76          DO jj = 2, jpjm1   
     101         DO jj = 2, jpjm1 
    77102            DO ji = fs_2 , fs_jpim1   ! vector opt. 
    78103               efact(ji,jj) = ( e2u(ji,jj) + e2u(ji-1,jj) + e1v(ji,jj) + e1v(ji,jj-1) ) * r1_e12t(ji,jj) 
    … …  
    83108      !                             ! Time integration parameters 
    84109      ! 
    85       ztab0(:, : ) = ptab(:,:)      ! Arrays initialization 
    86       zdiv0(:, 1 ) = 0._wp 
    87       zdiv0(:,jpj) = 0._wp 
    88       zflu (jpi,:) = 0._wp    
    89       zflv (jpi,:) = 0._wp 
    90       zdiv0(1,  :) = 0._wp 
    91       zdiv0(jpi,:) = 0._wp 
     110      zflu (jpi,: ) = 0._wp 
     111      zflv (jpi,: ) = 0._wp 
     112 
     113      DO jk=1 , isize 
     114         ztab0(:, : , jk ) = ptab(:,:,jk)      ! Arrays initialization 
     115         zdiv0(:, 1 , jk ) = 0._wp 
     116         zdiv0(:,jpj, jk ) = 0._wp 
     117         zdiv0(1,  :, jk ) = 0._wp 
     118         zdiv0(jpi,:, jk ) = 0._wp 
     119      END DO 
    92120 
    93121      zconv = 1._wp           !==  horizontal diffusion using a Crant-Nicholson scheme  ==! 
    94122      iter  = 0 
    95123      ! 
    96       DO WHILE( zconv > ( 2._wp * 1.e-04 ) .AND. iter <= its )   ! Sub-time step loop 
     124      DO WHILE( MAXVAL(zconv(:)) > ( 2._wp * 1.e-04 ) .AND. iter <= its )   ! Sub-time step loop 
    97125         ! 
    98126         iter = iter + 1                                 ! incrementation of the sub-time step number 
    99127         ! 
     128         DO jk = 1 , isize 
     129            jl = (jk-1) /( ihdf_vars+nlay_i)+1 
     130            IF (zconv(jk) > ( 2._wp * 1.e-04 )) THEN 
     131               DO jj = 1, jpjm1                                ! diffusive fluxes in U- and V- direction 
     132                  DO ji = 1 , fs_jpim1   ! vector opt. 
     133                     zflu(ji,jj) = pahu3D(ji,jj,jl) * e2u(ji,jj) * r1_e1u(ji,jj) * ( ptab(ji+1,jj,jk) - ptab(ji,jj,jk) ) 
     134                     zflv(ji,jj) = pahv3D(ji,jj,jl) * e1v(ji,jj) * r1_e2v(ji,jj) * ( ptab(ji,jj+1,jk) - ptab(ji,jj,jk) ) 
     135                  END DO 
     136               END DO 
     137               ! 
     138               DO jj= 2, jpjm1                                 ! diffusive trend : divergence of the fluxes 
     139                  DO ji = fs_2 , fs_jpim1   ! vector opt.  
     140                     zdiv(ji,jj) = ( zflu(ji,jj) - zflu(ji-1,jj) + zflv(ji,jj) - zflv(ji,jj-1) ) * r1_e12t(ji,jj) 
     141                  END DO 
     142               END DO 
     143               ! 
     144               IF( iter == 1 )   zdiv0(:,:,jk) = zdiv(:,:)        ! save the 1st evaluation of the diffusive trend in zdiv0 
     145               ! 
     146               DO jj = 2, jpjm1                                ! iterative evaluation 
     147                  DO ji = fs_2 , fs_jpim1   ! vector opt. 
     148                     zrlxint = (   ztab0(ji,jj,jk)    & 
     149                        &       +  rdt_ice * (           zalfa   * ( zdiv(ji,jj) + efact(ji,jj) * ptab(ji,jj,jk) )   & 
     150                        &                      + ( 1.0 - zalfa ) *   zdiv0(ji,jj,jk) )                               & 
     151                        &      ) / ( 1.0 + zalfa * rdt_ice * efact(ji,jj) ) 
     152                     zrlx(ji,jj,jk) = ptab(ji,jj,jk) + zrelax * ( zrlxint - ptab(ji,jj,jk) ) 
     153                  END DO 
     154               END DO 
     155            END IF 
     156 
     157         END DO 
     158 
     159         CALL lbc_lnk_multi( zrlx_array, type_array , psgn_array , isize ) ! Multiple interchange of all the variables 
     160         ! 
     161          
     162         IF ( MOD( iter-1 , nn_convfrq ) == 0 )  THEN   !Convergence test every nn_convfrq iterations (perf. optimization )  
     163            DO jk=1,isize 
     164               zconv(jk) = 0._wp                                   ! convergence test 
     165               DO jj = 2, jpjm1 
     166                  DO ji = fs_2, fs_jpim1 
     167                     zconv(jk) = MAX( zconv(jk), ABS( zrlx(ji,jj,jk) - ptab(ji,jj,jk) )  ) 
     168                  END DO 
     169               END DO 
     170            END DO 
     171            IF( lk_mpp ) CALL mpp_max_multiple( zconv , isize )            ! max over the global domain for all the variables 
     172         ENDIF 
     173         ! 
     174         DO jk=1,isize 
     175            ptab(:,:,jk) = zrlx(:,:,jk) 
     176         END DO 
     177         ! 
     178      END DO                                       ! end of sub-time step loop 
     179 
     180     ! ----------------------- 
     181      !!! final step (clem) !!! 
     182      DO jk = 1, isize 
     183         jl = (jk-1) /( ihdf_vars+nlay_i)+1 
    100184         DO jj = 1, jpjm1                                ! diffusive fluxes in U- and V- direction 
    101185            DO ji = 1 , fs_jpim1   ! vector opt. 
    102                zflu(ji,jj) = pahu(ji,jj) * e2u(ji,jj) * r1_e1u(ji,jj) * ( ptab(ji+1,jj) - ptab(ji,jj) ) 
    103                zflv(ji,jj) = pahv(ji,jj) * e1v(ji,jj) * r1_e2v(ji,jj) * ( ptab(ji,jj+1) - ptab(ji,jj) ) 
     186               zflu(ji,jj) = pahu3D(ji,jj,jl) * e2u(ji,jj) * r1_e1u(ji,jj) * ( ptab(ji+1,jj,jk) - ptab(ji,jj,jk) ) 
     187               zflv(ji,jj) = pahv3D(ji,jj,jl) * e1v(ji,jj) * r1_e2v(ji,jj) * ( ptab(ji,jj+1,jk) - ptab(ji,jj,jk) ) 
    104188            END DO 
    105189         END DO 
    … …  
    108192            DO ji = fs_2 , fs_jpim1   ! vector opt.  
    109193               zdiv(ji,jj) = ( zflu(ji,jj) - zflu(ji-1,jj) + zflv(ji,jj) - zflv(ji,jj-1) ) * r1_e12t(ji,jj) 
    110             END DO 
    111          END DO 
    112          ! 
    113          IF( iter == 1 )   zdiv0(:,:) = zdiv(:,:)        ! save the 1st evaluation of the diffusive trend in zdiv0 
    114          ! 
    115          DO jj = 2, jpjm1                                ! iterative evaluation 
    116             DO ji = fs_2 , fs_jpim1   ! vector opt. 
    117                zrlxint = (   ztab0(ji,jj)    & 
    118                   &       +  rdt_ice * (           zalfa   * ( zdiv(ji,jj) + efact(ji,jj) * ptab(ji,jj) )   & 
    119                   &                      + ( 1.0 - zalfa ) *   zdiv0(ji,jj) )                               &  
    120                   &      ) / ( 1.0 + zalfa * rdt_ice * efact(ji,jj) ) 
    121                zrlx(ji,jj) = ptab(ji,jj) + zrelax * ( zrlxint - ptab(ji,jj) ) 
    122             END DO 
    123          END DO 
    124          CALL lbc_lnk( zrlx, 'T', 1. )                   ! lateral boundary condition 
    125          ! 
    126          IF ( MOD( iter, nn_convfrq ) == 0 )  THEN    ! convergence test every nn_convfrq iterations (perf. optimization) 
    127             zconv = 0._wp 
    128             DO jj = 2, jpjm1 
    129                DO ji = fs_2, fs_jpim1 
    130                   zconv = MAX( zconv, ABS( zrlx(ji,jj) - ptab(ji,jj) )  ) 
    131                END DO 
    132             END DO 
    133             IF( lk_mpp )   CALL mpp_max( zconv )      ! max over the global domain 
    134          ENDIF 
    135          ! 
    136          ptab(:,:) = zrlx(:,:) 
    137          ! 
    138       END DO                                       ! end of sub-time step loop 
    139  
    140       ! ----------------------- 
    141       !!! final step (clem) !!! 
    142       DO jj = 1, jpjm1                                ! diffusive fluxes in U- and V- direction 
    143          DO ji = 1 , fs_jpim1   ! vector opt. 
    144             zflu(ji,jj) = pahu(ji,jj) * e2u(ji,jj) * r1_e1u(ji,jj) * ( ptab(ji+1,jj) - ptab(ji,jj) ) 
    145             zflv(ji,jj) = pahv(ji,jj) * e1v(ji,jj) * r1_e2v(ji,jj) * ( ptab(ji,jj+1) - ptab(ji,jj) ) 
     194               ptab(ji,jj,jk) = ztab0(ji,jj,jk) + 0.5 * ( zdiv(ji,jj) + zdiv0(ji,jj,jk) ) 
     195            END DO 
    146196         END DO 
    147197      END DO 
    148       ! 
    149       DO jj= 2, jpjm1                                 ! diffusive trend : divergence of the fluxes 
    150          DO ji = fs_2 , fs_jpim1   ! vector opt.  
    151             zdiv(ji,jj) = ( zflu(ji,jj) - zflu(ji-1,jj) + zflv(ji,jj) - zflv(ji,jj-1) ) * r1_e12t(ji,jj) 
    152             ptab(ji,jj) = ztab0(ji,jj) + 0.5 * ( zdiv(ji,jj) + zdiv0(ji,jj) ) 
    153          END DO 
    154       END DO 
    155       CALL lbc_lnk( ptab, 'T', 1. )                   ! lateral boundary condition 
     198 
     199      CALL lbc_lnk_multi( pt2d_array, type_array , psgn_array , isize ) ! Multiple interchange of all the variables 
     200 
    156201      !!! final step (clem) !!! 
    157202      ! ----------------------- 
    158203 
    159204      IF(ln_ctl)   THEN 
    160          zrlx(:,:) = ptab(:,:) - ztab0(:,:) 
    161          WRITE(charout,FMT="(' lim_hdf  : zconv =',D23.16, ' iter =',I4,2X)") zconv, iter 
    162          CALL prt_ctl( tab2d_1=zrlx, clinfo1=charout ) 
    163       ENDIF 
    164       ! 
    165       CALL wrk_dealloc( jpi, jpj, zrlx, zflu, zflv, zdiv0, zdiv, ztab0 ) 
     205         DO jk = 1 , isize 
     206            zrlx(:,:,jk) = ptab(:,:,jk) - ztab0(:,:,jk) 
     207            WRITE(charout,FMT="(' lim_hdf  : zconv =',D23.16, ' iter =',I4,2X)") zconv, iter 
     208            CALL prt_ctl( tab2d_1=zrlx(:,:,jk), clinfo1=charout ) 
     209         END DO 
     210      ENDIF 
     211      ! 
     212      CALL wrk_dealloc( jpi, jpj, isize, zrlx, zdiv0, ztab0 ) 
     213      CALL wrk_dealloc( jpi, jpj, zflu, zflv, zdiv ) 
     214 
     215      DEALLOCATE( zconv ) 
     216      DEALLOCATE( pt2d_array , zrlx_array ) 
     217      DEALLOCATE( type_array ) 
     218      DEALLOCATE( psgn_array ) 
    166219      ! 
    167220   END SUBROUTINE lim_hdf 
     221 
    168222 
    169223    
    … …  
    179233      !!------------------------------------------------------------------- 
    180234      INTEGER  ::   ios                 ! Local integer output status for namelist read 
    181       NAMELIST/namicehdf/ nn_convfrq 
     235      NAMELIST/namicehdf/ nn_convfrq  
    182236      !!------------------------------------------------------------------- 
    183237      ! 
    … …  
    212266   !!====================================================================== 
    213267END MODULE limhdf 
     268 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/LIM_SRC_3/limistate.F90

    r6836 r6839  
    2424   USE par_oce          ! ocean parameters 
    2525   USE dom_ice          ! sea-ice domain 
     26   USE limvar           ! lim_var_salprof 
    2627   USE in_out_manager   ! I/O manager 
    2728   USE lib_mpp          ! MPP library 
    … …  
    117118 
    118119      ! basal temperature (considered at freezing point) 
    119       t_bo(:,:) = ( eos_fzp( sss_m(:,:) ) + rt0 ) * tmask(:,:,1)  
     120      CALL eos_fzp( sss_m(:,:), t_bo(:,:) ) 
     121      t_bo(:,:) = ( t_bo(:,:) + rt0 ) * tmask(:,:,1)  
    120122 
    121123      IF( ln_iceini ) THEN 
    … …  
    245247               ztest_1 = 1 
    246248            ELSE  
    247               ! this write is useful 
    248               IF(lwp)  WRITE(numout,*) ' * TEST1 AREA NOT CONSERVED *** zA_cons = ', zA_cons,' zat_i_ini = ',zat_i_ini(i_hemis)  
    249249               ztest_1 = 0 
    250250            ENDIF 
    … …  
    257257               ztest_2 = 1 
    258258            ELSE 
    259               ! this write is useful 
    260               IF(lwp)  WRITE(numout,*) ' * TEST2 VOLUME NOT CONSERVED *** zV_cons = ', zV_cons, & 
    261                             ' zvt_i_ini = ', zvt_i_ini(i_hemis) 
    262259               ztest_2 = 0 
    263260            ENDIF 
    … …  
    267264               ztest_3 = 1 
    268265            ELSE 
    269                ! this write is useful 
    270                IF(lwp) WRITE(numout,*) ' * TEST 3 THICKNESS OF THE LAST CATEGORY OUT OF BOUNDS *** zh_i_ini(i_fill,i_hemis) = ', & 
    271                zh_i_ini(i_fill,i_hemis), ' hi_max(jpl-1) = ', hi_max(i_fill-1) 
    272266               ztest_3 = 0 
    273267            ENDIF 
    … …  
    277271            DO jl = 1, jpl 
    278272               IF ( za_i_ini(jl,i_hemis) .LT. 0._wp ) THEN  
    279                   ! this write is useful 
    280                   IF(lwp) WRITE(numout,*) ' * TEST 4 POSITIVITY NOT OK FOR CAT ', jl, ' WITH A = ', za_i_ini(jl,i_hemis) 
    281273                  ztest_4 = 0 
    282274               ENDIF 
    … …  
    336328         END DO 
    337329      END DO 
     330 
     331      ! for constant salinity in time 
     332      IF( nn_icesal == 1 .OR. nn_icesal == 3 )  THEN 
     333         CALL lim_var_salprof 
     334         smv_i = sm_i * v_i 
     335      ENDIF 
    338336 
    339337      ! Snow temperature and heat content 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/LIM_SRC_3/limitd_me.F90

    r6836 r6839  
    4545   REAL(wp), ALLOCATABLE, DIMENSION(:,:)   ::   asum     ! sum of total ice and open water area 
    4646   REAL(wp), ALLOCATABLE, DIMENSION(:,:)   ::   aksum    ! ratio of area removed to area ridged 
    47    REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::   athorn   ! participation function; fraction of ridging/ 
    48    !                                                     ! closing associated w/ category n 
     47   REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::   athorn   ! participation function; fraction of ridging/closing associated w/ category n 
    4948   REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::   hrmin    ! minimum ridge thickness 
    5049   REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::   hrmax    ! maximum ridge thickness 
    5150   REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::   hraft    ! thickness of rafted ice 
    52    REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::   krdg     ! mean ridge thickness/thickness of ridging ice  
     51   REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::   krdg     ! thickness of ridging ice / mean ridge thickness 
    5352   REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::   aridge   ! participating ice ridging 
    5453   REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::   araft    ! participating ice rafting 
    5554 
    5655   REAL(wp), PARAMETER ::   krdgmin = 1.1_wp    ! min ridge thickness multiplier 
    57    REAL(wp), PARAMETER ::   kraft   = 2.0_wp    ! rafting multipliyer 
    58    REAL(wp), PARAMETER ::   kamax   = 1.0_wp    ! max of ice area authorized (clem: scheme is not stable if kamax <= 0.99) 
     56   REAL(wp), PARAMETER ::   kraft   = 0.5_wp    ! rafting multipliyer 
    5957 
    6058   REAL(wp) ::   Cp                             !  
    6159   ! 
    62    !----------------------------------------------------------------------- 
    63    ! Ridging diagnostic arrays for history files 
    64    !----------------------------------------------------------------------- 
    65    REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   dardg1dt   ! rate of fractional area loss by ridging ice (1/s) 
    66    REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   dardg2dt   ! rate of fractional area gain by new ridges (1/s) 
    67    REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   dvirdgdt   ! rate of ice volume ridged (m/s) 
    68    REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   opening    ! rate of opening due to divergence/shear (1/s) 
    6960   ! 
    7061   !!---------------------------------------------------------------------- 
    … …  
    8374         &      asum (jpi,jpj)     , athorn(jpi,jpj,0:jpl)                    ,     & 
    8475         &      aksum(jpi,jpj)                                                ,     & 
    85          ! 
    8676         &      hrmin(jpi,jpj,jpl) , hraft(jpi,jpj,jpl) , aridge(jpi,jpj,jpl) ,     & 
    87          &      hrmax(jpi,jpj,jpl) , krdg (jpi,jpj,jpl) , araft (jpi,jpj,jpl) ,     & 
    88          ! 
    89          !* Ridging diagnostic arrays for history files 
    90          &      dardg1dt(jpi,jpj)  , dardg2dt(jpi,jpj)                        ,     &  
    91          &      dvirdgdt(jpi,jpj)  , opening(jpi,jpj)                         , STAT=lim_itd_me_alloc ) 
     77         &      hrmax(jpi,jpj,jpl) , krdg (jpi,jpj,jpl) , araft (jpi,jpj,jpl) , STAT=lim_itd_me_alloc ) 
    9278         ! 
    9379      IF( lim_itd_me_alloc /= 0 )   CALL ctl_warn( 'lim_itd_me_alloc: failed to allocate arrays' ) 
    … …  
    132118      REAL(wp), POINTER, DIMENSION(:,:)   ::   opning          ! rate of opening due to divergence/shear 
    133119      REAL(wp), POINTER, DIMENSION(:,:)   ::   closing_gross   ! rate at which area removed, not counting area of new ridges 
    134       REAL(wp), POINTER, DIMENSION(:,:)   ::   msnow_mlt       ! mass of snow added to ocean (kg m-2) 
    135       REAL(wp), POINTER, DIMENSION(:,:)   ::   esnow_mlt       ! energy needed to melt snow in ocean (J m-2) 
    136       REAL(wp), POINTER, DIMENSION(:,:)   ::   vt_i_init, vt_i_final  !  ice volume summed over categories 
    137120      ! 
    138121      INTEGER, PARAMETER ::   nitermax = 20     
    … …  
    142125      IF( nn_timing == 1 )  CALL timing_start('limitd_me') 
    143126 
    144       CALL wrk_alloc( jpi,jpj, closing_net, divu_adv, opning, closing_gross, msnow_mlt, esnow_mlt, vt_i_init, vt_i_final ) 
     127      CALL wrk_alloc( jpi,jpj, closing_net, divu_adv, opning, closing_gross ) 
    145128 
    146129      IF(ln_ctl) THEN 
    … …  
    154137      IF( ln_limdiahsb ) CALL lim_cons_hsm(0, 'limitd_me', zvi_b, zsmv_b, zei_b, zfw_b, zfs_b, zft_b) 
    155138 
    156       CALL lim_var_zapsmall 
    157       CALL lim_var_glo2eqv            ! equivalent variables, requested for rafting 
    158  
    159139      !-----------------------------------------------------------------------------! 
    160140      ! 1) Thickness categories boundaries, ice / o.w. concentrations, init_ons 
    … …  
    164144      CALL lim_itd_me_ridgeprep                                    ! prepare ridging 
    165145      ! 
    166       IF( con_i)   CALL lim_column_sum( jpl, v_i, vt_i_init )      ! conservation check 
    167146 
    168147      DO jj = 1, jpj                                     ! Initialize arrays. 
    169148         DO ji = 1, jpi 
    170             msnow_mlt(ji,jj) = 0._wp 
    171             esnow_mlt(ji,jj) = 0._wp 
    172             dardg1dt (ji,jj) = 0._wp 
    173             dardg2dt (ji,jj) = 0._wp 
    174             dvirdgdt (ji,jj) = 0._wp 
    175             opening  (ji,jj) = 0._wp 
    176149 
    177150            !-----------------------------------------------------------------------------! 
    … …  
    204177            ! If divu_adv < 0, make sure the closing rate is large enough 
    205178            ! to give asum = 1.0 after ridging. 
    206  
    207             divu_adv(ji,jj) = ( kamax - asum(ji,jj) ) * r1_rdtice  ! asum found in ridgeprep 
     179             
     180            divu_adv(ji,jj) = ( 1._wp - asum(ji,jj) ) * r1_rdtice  ! asum found in ridgeprep 
    208181 
    209182            IF( divu_adv(ji,jj) < 0._wp )   closing_net(ji,jj) = MAX( closing_net(ji,jj), -divu_adv(ji,jj) ) 
    … …  
    224197      DO WHILE ( iterate_ridging > 0 .AND. niter < nitermax ) 
    225198 
     199         ! 3.2 closing_gross 
     200         !-----------------------------------------------------------------------------! 
     201         ! Based on the ITD of ridging and ridged ice, convert the net 
     202         !  closing rate to a gross closing rate.   
     203         ! NOTE: 0 < aksum <= 1 
     204         closing_gross(:,:) = closing_net(:,:) / aksum(:,:) 
     205 
     206         ! correction to closing rate and opening if closing rate is excessive 
     207         !--------------------------------------------------------------------- 
     208         ! Reduce the closing rate if more than 100% of the open water  
     209         ! would be removed.  Reduce the opening rate proportionately. 
    226210         DO jj = 1, jpj 
    227211            DO ji = 1, jpi 
    228  
    229                ! 3.2 closing_gross 
    230                !-----------------------------------------------------------------------------! 
    231                ! Based on the ITD of ridging and ridged ice, convert the net 
    232                !  closing rate to a gross closing rate.   
    233                ! NOTE: 0 < aksum <= 1 
    234                closing_gross(ji,jj) = closing_net(ji,jj) / aksum(ji,jj) 
    235  
    236                ! correction to closing rate and opening if closing rate is excessive 
    237                !--------------------------------------------------------------------- 
    238                ! Reduce the closing rate if more than 100% of the open water  
    239                ! would be removed.  Reduce the opening rate proportionately. 
    240                za   = athorn(ji,jj,0) * closing_gross(ji,jj) * rdt_ice 
    241                IF( za > epsi20 ) THEN 
    242                   zfac = MIN( 1._wp, ato_i(ji,jj) / za ) 
    243                   closing_gross(ji,jj) = closing_gross(ji,jj) * zfac 
    244                   opning       (ji,jj) = opning       (ji,jj) * zfac 
     212               za   = ( opning(ji,jj) - athorn(ji,jj,0) * closing_gross(ji,jj) ) * rdt_ice 
     213               IF( za < 0._wp .AND. za > - ato_i(ji,jj) ) THEN  ! would lead to negative ato_i 
     214                  zfac = - ato_i(ji,jj) / za 
     215                  opning(ji,jj) = athorn(ji,jj,0) * closing_gross(ji,jj) - ato_i(ji,jj) * r1_rdtice  
     216               ELSEIF( za > 0._wp .AND. za > ( asum(ji,jj) - ato_i(ji,jj) ) ) THEN  ! would lead to ato_i > asum 
     217                  zfac = ( asum(ji,jj) - ato_i(ji,jj) ) / za 
     218                  opning(ji,jj) = athorn(ji,jj,0) * closing_gross(ji,jj) + ( asum(ji,jj) - ato_i(ji,jj) ) * r1_rdtice  
    245219               ENDIF 
    246  
    247220            END DO 
    248221         END DO 
    … …  
    256229               DO ji = 1, jpi 
    257230                  za = athorn(ji,jj,jl) * closing_gross(ji,jj) * rdt_ice 
    258                   IF( za  >  epsi20 ) THEN 
    259                      zfac = MIN( 1._wp, a_i(ji,jj,jl) / za ) 
     231                  IF( za  >  a_i(ji,jj,jl) ) THEN 
     232                     zfac = a_i(ji,jj,jl) / za 
    260233                     closing_gross(ji,jj) = closing_gross(ji,jj) * zfac 
    261                      opning       (ji,jj) = opning       (ji,jj) * zfac 
    262234                  ENDIF 
    263235               END DO 
    … …  
    268240         !-----------------------------------------------------------------------------! 
    269241 
    270          CALL lim_itd_me_ridgeshift( opning, closing_gross, msnow_mlt, esnow_mlt ) 
    271  
     242         CALL lim_itd_me_ridgeshift( opning, closing_gross ) 
     243 
     244          
    272245         ! 3.4 Compute total area of ice plus open water after ridging. 
    273246         !-----------------------------------------------------------------------------! 
    274247         ! This is in general not equal to one because of divergence during transport 
    275          asum(:,:) = ato_i(:,:) 
    276          DO jl = 1, jpl 
    277             asum(:,:) = asum(:,:) + a_i(:,:,jl) 
    278          END DO 
     248         asum(:,:) = ato_i(:,:) + SUM( a_i, dim=3 ) 
    279249 
    280250         ! 3.5 Do we keep on iterating ??? 
    … …  
    284254 
    285255         iterate_ridging = 0 
    286  
    287256         DO jj = 1, jpj 
    288257            DO ji = 1, jpi 
    289                IF (ABS(asum(ji,jj) - kamax ) < epsi10) THEN 
     258               IF( ABS( asum(ji,jj) - 1._wp ) < epsi10 ) THEN 
    290259                  closing_net(ji,jj) = 0._wp 
    291260                  opning     (ji,jj) = 0._wp 
    292261               ELSE 
    293262                  iterate_ridging    = 1 
    294                   divu_adv   (ji,jj) = ( kamax - asum(ji,jj) ) * r1_rdtice 
     263                  divu_adv   (ji,jj) = ( 1._wp - asum(ji,jj) ) * r1_rdtice 
    295264                  closing_net(ji,jj) = MAX( 0._wp, -divu_adv(ji,jj) ) 
    296265                  opning     (ji,jj) = MAX( 0._wp,  divu_adv(ji,jj) ) 
    … …  
    309278 
    310279         IF( iterate_ridging == 1 ) THEN 
     280            CALL lim_itd_me_ridgeprep 
    311281            IF( niter  >  nitermax ) THEN 
    312282               WRITE(numout,*) ' ALERTE : non-converging ridging scheme ' 
    313283               WRITE(numout,*) ' niter, iterate_ridging ', niter, iterate_ridging 
    314284            ENDIF 
    315             CALL lim_itd_me_ridgeprep 
    316285         ENDIF 
    317286 
    318287      END DO !! on the do while over iter 
    319  
    320       !-----------------------------------------------------------------------------! 
    321       ! 4) Ridging diagnostics 
    322       !-----------------------------------------------------------------------------! 
    323       ! Convert ridging rate diagnostics to correct units. 
    324       ! Update fresh water and heat fluxes due to snow melt. 
    325       DO jj = 1, jpj 
    326          DO ji = 1, jpi 
    327  
    328             dardg1dt(ji,jj) = dardg1dt(ji,jj) * r1_rdtice 
    329             dardg2dt(ji,jj) = dardg2dt(ji,jj) * r1_rdtice 
    330             dvirdgdt(ji,jj) = dvirdgdt(ji,jj) * r1_rdtice 
    331             opening (ji,jj) = opening (ji,jj) * r1_rdtice 
    332  
    333             !-----------------------------------------------------------------------------! 
    334             ! 5) Heat, salt and freshwater fluxes 
    335             !-----------------------------------------------------------------------------! 
    336             wfx_snw(ji,jj) = wfx_snw(ji,jj) + msnow_mlt(ji,jj) * r1_rdtice     ! fresh water source for ocean 
    337             hfx_dyn(ji,jj) = hfx_dyn(ji,jj) + esnow_mlt(ji,jj) * r1_rdtice     ! heat sink for ocean (<0, W.m-2) 
    338  
    339          END DO 
    340       END DO 
    341  
    342       ! Check if there is a ridging error 
    343       IF( lwp ) THEN 
    344          DO jj = 1, jpj 
    345             DO ji = 1, jpi 
    346                IF( ABS( asum(ji,jj) - kamax)  >  epsi10 ) THEN   ! there is a bug 
    347                   WRITE(numout,*) ' ' 
    348                   WRITE(numout,*) ' ALERTE : Ridging error: total area = ', asum(ji,jj) 
    349                   WRITE(numout,*) ' limitd_me ' 
    350                   WRITE(numout,*) ' POINT : ', ji, jj 
    351                   WRITE(numout,*) ' jpl, a_i, athorn ' 
    352                   WRITE(numout,*) 0, ato_i(ji,jj), athorn(ji,jj,0) 
    353                   DO jl = 1, jpl 
    354                      WRITE(numout,*) jl, a_i(ji,jj,jl), athorn(ji,jj,jl) 
    355                   END DO 
    356                ENDIF 
    357             END DO 
    358          END DO 
    359       END IF 
    360  
    361       ! Conservation check 
    362       IF ( con_i ) THEN 
    363          CALL lim_column_sum (jpl,   v_i, vt_i_final) 
    364          fieldid = ' v_i : limitd_me ' 
    365          CALL lim_cons_check (vt_i_init, vt_i_final, 1.0e-6, fieldid)  
    366       ENDIF 
    367288 
    368289      CALL lim_var_agg( 1 )  
    … …  
    410331      ENDIF  ! ln_limdyn=.true. 
    411332      ! 
    412       CALL wrk_dealloc( jpi, jpj, closing_net, divu_adv, opning, closing_gross, msnow_mlt, esnow_mlt, vt_i_init, vt_i_final ) 
     333      CALL wrk_dealloc( jpi, jpj, closing_net, divu_adv, opning, closing_gross ) 
    413334      ! 
    414335      IF( nn_timing == 1 )  CALL timing_stop('limitd_me') 
    415336   END SUBROUTINE lim_itd_me 
    416337 
     338   SUBROUTINE lim_itd_me_ridgeprep 
     339      !!---------------------------------------------------------------------! 
     340      !!                ***  ROUTINE lim_itd_me_ridgeprep *** 
     341      !! 
     342      !! ** Purpose :   preparation for ridging and strength calculations 
     343      !! 
     344      !! ** Method  :   Compute the thickness distribution of the ice and open water  
     345      !!              participating in ridging and of the resulting ridges. 
     346      !!---------------------------------------------------------------------! 
     347      INTEGER ::   ji,jj, jl    ! dummy loop indices 
     348      REAL(wp) ::   Gstari, astari, hrmean, zdummy   ! local scalar 
     349      REAL(wp), POINTER, DIMENSION(:,:,:) ::   Gsum      ! Gsum(n) = sum of areas in categories 0 to n 
     350      !------------------------------------------------------------------------------! 
     351 
     352      CALL wrk_alloc( jpi,jpj,jpl+2, Gsum, kkstart = -1 ) 
     353 
     354      Gstari     = 1.0/rn_gstar     
     355      astari     = 1.0/rn_astar     
     356      aksum(:,:)    = 0.0 
     357      athorn(:,:,:) = 0.0 
     358      aridge(:,:,:) = 0.0 
     359      araft (:,:,:) = 0.0 
     360 
     361      ! Zero out categories with very small areas 
     362      CALL lim_var_zapsmall 
     363 
     364      ! Ice thickness needed for rafting 
     365      DO jl = 1, jpl 
     366         DO jj = 1, jpj 
     367            DO ji = 1, jpi 
     368               rswitch = MAX( 0._wp , SIGN( 1._wp, a_i(ji,jj,jl) - epsi20 ) ) 
     369               ht_i(ji,jj,jl) = v_i (ji,jj,jl) / MAX( a_i(ji,jj,jl) , epsi20 ) * rswitch 
     370            END DO 
     371         END DO 
     372      END DO 
     373 
     374      !------------------------------------------------------------------------------! 
     375      ! 1) Participation function  
     376      !------------------------------------------------------------------------------! 
     377 
     378      ! Compute total area of ice plus open water. 
     379      ! This is in general not equal to one because of divergence during transport 
     380      asum(:,:) = ato_i(:,:) + SUM( a_i, dim=3 ) 
     381 
     382      ! Compute cumulative thickness distribution function 
     383      ! Compute the cumulative thickness distribution function Gsum, 
     384      ! where Gsum(n) is the fractional area in categories 0 to n. 
     385      ! initial value (in h = 0) equals open water area 
     386      Gsum(:,:,-1) = 0._wp 
     387      Gsum(:,:,0 ) = ato_i(:,:) 
     388      ! for each value of h, you have to add ice concentration then 
     389      DO jl = 1, jpl 
     390         Gsum(:,:,jl) = Gsum(:,:,jl-1) + a_i(:,:,jl) 
     391      END DO 
     392 
     393      ! Normalize the cumulative distribution to 1 
     394      DO jl = 0, jpl 
     395         Gsum(:,:,jl) = Gsum(:,:,jl) / asum(:,:) 
     396      END DO 
     397 
     398      ! 1.3 Compute participation function a(h) = b(h).g(h) (athorn) 
     399      !-------------------------------------------------------------------------------------------------- 
     400      ! Compute the participation function athorn; this is analogous to 
     401      ! a(h) = b(h)g(h) as defined in Thorndike et al. (1975). 
     402      ! area lost from category n due to ridging/closing 
     403      ! athorn(n)   = total area lost due to ridging/closing 
     404      ! assume b(h) = (2/Gstar) * (1 - G(h)/Gstar).  
     405      ! 
     406      ! The expressions for athorn are found by integrating b(h)g(h) between 
     407      ! the category boundaries. 
     408      ! athorn is always >= 0 and SUM(athorn(0:jpl))=1 
     409      !----------------------------------------------------------------- 
     410 
     411      IF( nn_partfun == 0 ) THEN       !--- Linear formulation (Thorndike et al., 1975) 
     412         DO jl = 0, jpl     
     413            DO jj = 1, jpj  
     414               DO ji = 1, jpi 
     415                  IF    ( Gsum(ji,jj,jl)   < rn_gstar ) THEN 
     416                     athorn(ji,jj,jl) = Gstari * ( Gsum(ji,jj,jl) - Gsum(ji,jj,jl-1) ) * & 
     417                        &                        ( 2._wp - ( Gsum(ji,jj,jl-1) + Gsum(ji,jj,jl) ) * Gstari ) 
     418                  ELSEIF( Gsum(ji,jj,jl-1) < rn_gstar ) THEN 
     419                     athorn(ji,jj,jl) = Gstari * ( rn_gstar       - Gsum(ji,jj,jl-1) ) *  & 
     420                        &                        ( 2._wp - ( Gsum(ji,jj,jl-1) + rn_gstar       ) * Gstari ) 
     421                  ELSE 
     422                     athorn(ji,jj,jl) = 0._wp 
     423                  ENDIF 
     424               END DO 
     425            END DO 
     426         END DO 
     427 
     428      ELSE                             !--- Exponential, more stable formulation (Lipscomb et al, 2007) 
     429         !                         
     430         zdummy = 1._wp / ( 1._wp - EXP(-astari) )        ! precompute exponential terms using Gsum as a work array 
     431         DO jl = -1, jpl 
     432            Gsum(:,:,jl) = EXP( -Gsum(:,:,jl) * astari ) * zdummy 
     433         END DO 
     434         DO jl = 0, jpl 
     435             athorn(:,:,jl) = Gsum(:,:,jl-1) - Gsum(:,:,jl) 
     436         END DO 
     437         ! 
     438      ENDIF 
     439 
     440      IF( ln_rafting ) THEN      ! Ridging and rafting ice participation functions 
     441         ! 
     442         DO jl = 1, jpl 
     443            DO jj = 1, jpj  
     444               DO ji = 1, jpi 
     445                  zdummy           = TANH ( rn_craft * ( ht_i(ji,jj,jl) - rn_hraft ) ) 
     446                  aridge(ji,jj,jl) = ( 1._wp + zdummy ) * 0.5_wp * athorn(ji,jj,jl) 
     447                  araft (ji,jj,jl) = ( 1._wp - zdummy ) * 0.5_wp * athorn(ji,jj,jl) 
     448               END DO 
     449            END DO 
     450         END DO 
     451 
     452      ELSE 
     453         ! 
     454         DO jl = 1, jpl 
     455            aridge(:,:,jl) = athorn(:,:,jl) 
     456         END DO 
     457         ! 
     458      ENDIF 
     459 
     460      !----------------------------------------------------------------- 
     461      ! 2) Transfer function 
     462      !----------------------------------------------------------------- 
     463      ! Compute max and min ridged ice thickness for each ridging category. 
     464      ! Assume ridged ice is uniformly distributed between hrmin and hrmax. 
     465      !  
     466      ! This parameterization is a modified version of Hibler (1980). 
     467      ! The mean ridging thickness, hrmean, is proportional to hi^(0.5) 
     468      !  and for very thick ridging ice must be >= krdgmin*hi 
     469      ! 
     470      ! The minimum ridging thickness, hrmin, is equal to 2*hi  
     471      !  (i.e., rafting) and for very thick ridging ice is 
     472      !  constrained by hrmin <= (hrmean + hi)/2. 
     473      !  
     474      ! The maximum ridging thickness, hrmax, is determined by 
     475      !  hrmean and hrmin. 
     476      ! 
     477      ! These modifications have the effect of reducing the ice strength 
     478      ! (relative to the Hibler formulation) when very thick ice is 
     479      ! ridging. 
     480      ! 
     481      ! aksum = net area removed/ total area removed 
     482      ! where total area removed = area of ice that ridges 
     483      !         net area removed = total area removed - area of new ridges 
     484      !----------------------------------------------------------------- 
     485 
     486      aksum(:,:) = athorn(:,:,0) 
     487      ! Transfer function 
     488      DO jl = 1, jpl !all categories have a specific transfer function 
     489         DO jj = 1, jpj 
     490            DO ji = 1, jpi 
     491                
     492               IF( athorn(ji,jj,jl) > 0._wp ) THEN 
     493                  hrmean          = MAX( SQRT( rn_hstar * ht_i(ji,jj,jl) ), ht_i(ji,jj,jl) * krdgmin ) 
     494                  hrmin(ji,jj,jl) = MIN( 2._wp * ht_i(ji,jj,jl), 0.5_wp * ( hrmean + ht_i(ji,jj,jl) ) ) 
     495                  hrmax(ji,jj,jl) = 2._wp * hrmean - hrmin(ji,jj,jl) 
     496                  hraft(ji,jj,jl) = ht_i(ji,jj,jl) / kraft 
     497                  krdg(ji,jj,jl)  = ht_i(ji,jj,jl) / MAX( hrmean, epsi20 ) 
     498 
     499                  ! Normalization factor : aksum, ensures mass conservation 
     500                  aksum(ji,jj) = aksum(ji,jj) + aridge(ji,jj,jl) * ( 1._wp - krdg(ji,jj,jl) )    & 
     501                     &                        + araft (ji,jj,jl) * ( 1._wp - kraft          ) 
     502 
     503               ELSE 
     504                  hrmin(ji,jj,jl)  = 0._wp  
     505                  hrmax(ji,jj,jl)  = 0._wp  
     506                  hraft(ji,jj,jl)  = 0._wp  
     507                  krdg (ji,jj,jl)  = 1._wp 
     508               ENDIF 
     509 
     510            END DO 
     511         END DO 
     512      END DO 
     513      ! 
     514      CALL wrk_dealloc( jpi,jpj,jpl+2, Gsum, kkstart = -1 ) 
     515      ! 
     516   END SUBROUTINE lim_itd_me_ridgeprep 
     517 
     518 
     519   SUBROUTINE lim_itd_me_ridgeshift( opning, closing_gross ) 
     520      !!---------------------------------------------------------------------- 
     521      !!                ***  ROUTINE lim_itd_me_icestrength *** 
     522      !! 
     523      !! ** Purpose :   shift ridging ice among thickness categories of ice thickness 
     524      !! 
     525      !! ** Method  :   Remove area, volume, and energy from each ridging category 
     526      !!              and add to thicker ice categories. 
     527      !!---------------------------------------------------------------------- 
     528      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ) ::   opning         ! rate of opening due to divergence/shear 
     529      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ) ::   closing_gross  ! rate at which area removed, excluding area of new ridges 
     530      ! 
     531      CHARACTER (len=80) ::   fieldid   ! field identifier 
     532      ! 
     533      INTEGER ::   ji, jj, jl, jl1, jl2, jk   ! dummy loop indices 
     534      INTEGER ::   ij                ! horizontal index, combines i and j loops 
     535      INTEGER ::   icells            ! number of cells with a_i > puny 
     536      REAL(wp) ::   hL, hR, farea    ! left and right limits of integration 
     537 
     538      INTEGER , POINTER, DIMENSION(:) ::   indxi, indxj   ! compressed indices 
     539      REAL(wp), POINTER, DIMENSION(:) ::   zswitch, fvol   ! new ridge volume going to n2 
     540 
     541      REAL(wp), POINTER, DIMENSION(:) ::   afrac            ! fraction of category area ridged  
     542      REAL(wp), POINTER, DIMENSION(:) ::   ardg1 , ardg2    ! area of ice ridged & new ridges 
     543      REAL(wp), POINTER, DIMENSION(:) ::   vsrdg , esrdg    ! snow volume & energy of ridging ice 
     544      REAL(wp), POINTER, DIMENSION(:) ::   dhr   , dhr2     ! hrmax - hrmin  &  hrmax^2 - hrmin^2 
     545 
     546      REAL(wp), POINTER, DIMENSION(:) ::   vrdg1   ! volume of ice ridged 
     547      REAL(wp), POINTER, DIMENSION(:) ::   vrdg2   ! volume of new ridges 
     548      REAL(wp), POINTER, DIMENSION(:) ::   vsw     ! volume of seawater trapped into ridges 
     549      REAL(wp), POINTER, DIMENSION(:) ::   srdg1   ! sal*volume of ice ridged 
     550      REAL(wp), POINTER, DIMENSION(:) ::   srdg2   ! sal*volume of new ridges 
     551      REAL(wp), POINTER, DIMENSION(:) ::   smsw    ! sal*volume of water trapped into ridges 
     552      REAL(wp), POINTER, DIMENSION(:) ::   oirdg1, oirdg2   ! ice age of ice ridged 
     553 
     554      REAL(wp), POINTER, DIMENSION(:) ::   afrft            ! fraction of category area rafted 
     555      REAL(wp), POINTER, DIMENSION(:) ::   arft1 , arft2    ! area of ice rafted and new rafted zone 
     556      REAL(wp), POINTER, DIMENSION(:) ::   virft , vsrft    ! ice & snow volume of rafting ice 
     557      REAL(wp), POINTER, DIMENSION(:) ::   esrft , smrft    ! snow energy & salinity of rafting ice 
     558      REAL(wp), POINTER, DIMENSION(:) ::   oirft1, oirft2   ! ice age of ice rafted 
     559 
     560      REAL(wp), POINTER, DIMENSION(:,:) ::   eirft      ! ice energy of rafting ice 
     561      REAL(wp), POINTER, DIMENSION(:,:) ::   erdg1      ! enth*volume of ice ridged 
     562      REAL(wp), POINTER, DIMENSION(:,:) ::   erdg2      ! enth*volume of new ridges 
     563      REAL(wp), POINTER, DIMENSION(:,:) ::   ersw       ! enth of water trapped into ridges 
     564      !!---------------------------------------------------------------------- 
     565 
     566      CALL wrk_alloc( jpij,        indxi, indxj ) 
     567      CALL wrk_alloc( jpij,        zswitch, fvol ) 
     568      CALL wrk_alloc( jpij,        afrac, ardg1, ardg2, vsrdg, esrdg, dhr, dhr2 ) 
     569      CALL wrk_alloc( jpij,        vrdg1, vrdg2, vsw  , srdg1, srdg2, smsw, oirdg1, oirdg2 ) 
     570      CALL wrk_alloc( jpij,        afrft, arft1, arft2, virft, vsrft, esrft, smrft, oirft1, oirft2 ) 
     571      CALL wrk_alloc( jpij,nlay_i, eirft, erdg1, erdg2, ersw ) 
     572 
     573      !------------------------------------------------------------------------------- 
     574      ! 1) Compute change in open water area due to closing and opening. 
     575      !------------------------------------------------------------------------------- 
     576      DO jj = 1, jpj 
     577         DO ji = 1, jpi 
     578            ato_i(ji,jj) = MAX( 0._wp, ato_i(ji,jj) +  & 
     579               &                     ( opning(ji,jj) - athorn(ji,jj,0) * closing_gross(ji,jj) ) * rdt_ice ) 
     580         END DO 
     581      END DO 
     582 
     583      !----------------------------------------------------------------- 
     584      ! 3) Pump everything from ice which is being ridged / rafted 
     585      !----------------------------------------------------------------- 
     586      ! Compute the area, volume, and energy of ice ridging in each 
     587      ! category, along with the area of the resulting ridge. 
     588 
     589      DO jl1 = 1, jpl !jl1 describes the ridging category 
     590 
     591         !------------------------------------------------ 
     592         ! 3.1) Identify grid cells with nonzero ridging 
     593         !------------------------------------------------ 
     594         icells = 0 
     595         DO jj = 1, jpj 
     596            DO ji = 1, jpi 
     597               IF( athorn(ji,jj,jl1) > 0._wp .AND. closing_gross(ji,jj) > 0._wp ) THEN 
     598                  icells = icells + 1 
     599                  indxi(icells) = ji 
     600                  indxj(icells) = jj 
     601               ENDIF 
     602            END DO 
     603         END DO 
     604 
     605         DO ij = 1, icells 
     606            ji = indxi(ij) ; jj = indxj(ij) 
     607 
     608            !-------------------------------------------------------------------- 
     609            ! 3.2) Compute area of ridging ice (ardg1) and of new ridge (ardg2) 
     610            !-------------------------------------------------------------------- 
     611            ardg1(ij) = aridge(ji,jj,jl1) * closing_gross(ji,jj) * rdt_ice 
     612            arft1(ij) = araft (ji,jj,jl1) * closing_gross(ji,jj) * rdt_ice 
     613 
     614            !--------------------------------------------------------------- 
     615            ! 3.3) Compute ridging /rafting fractions, make sure afrac <=1  
     616            !--------------------------------------------------------------- 
     617            afrac(ij) = ardg1(ij) / a_i(ji,jj,jl1) !ridging 
     618            afrft(ij) = arft1(ij) / a_i(ji,jj,jl1) !rafting 
     619            ardg2(ij) = ardg1(ij) * krdg(ji,jj,jl1) 
     620            arft2(ij) = arft1(ij) * kraft 
     621 
     622            !-------------------------------------------------------------------------- 
     623            ! 3.4) Subtract area, volume, and energy from ridging  
     624            !     / rafting category n1. 
     625            !-------------------------------------------------------------------------- 
     626            vrdg1(ij) = v_i(ji,jj,jl1) * afrac(ij) 
     627            vrdg2(ij) = vrdg1(ij) * ( 1. + rn_por_rdg ) 
     628            vsw  (ij) = vrdg1(ij) * rn_por_rdg 
     629 
     630            vsrdg (ij) = v_s  (ji,jj,  jl1) * afrac(ij) 
     631            esrdg (ij) = e_s  (ji,jj,1,jl1) * afrac(ij) 
     632            srdg1 (ij) = smv_i(ji,jj,  jl1) * afrac(ij) 
     633            oirdg1(ij) = oa_i (ji,jj,  jl1) * afrac(ij) 
     634            oirdg2(ij) = oa_i (ji,jj,  jl1) * afrac(ij) * krdg(ji,jj,jl1)  
     635 
     636            ! rafting volumes, heat contents ... 
     637            virft (ij) = v_i  (ji,jj,  jl1) * afrft(ij) 
     638            vsrft (ij) = v_s  (ji,jj,  jl1) * afrft(ij) 
     639            esrft (ij) = e_s  (ji,jj,1,jl1) * afrft(ij) 
     640            smrft (ij) = smv_i(ji,jj,  jl1) * afrft(ij)  
     641            oirft1(ij) = oa_i (ji,jj,  jl1) * afrft(ij)  
     642            oirft2(ij) = oa_i (ji,jj,  jl1) * afrft(ij) * kraft  
     643 
     644            !----------------------------------------------------------------- 
     645            ! 3.5) Compute properties of new ridges 
     646            !----------------------------------------------------------------- 
     647            smsw(ij)  = vsw(ij) * sss_m(ji,jj)                   ! salt content of seawater frozen in voids 
     648            srdg2(ij) = srdg1(ij) + smsw(ij)                     ! salt content of new ridge 
     649             
     650            sfx_dyn(ji,jj) = sfx_dyn(ji,jj) - smsw(ij) * rhoic * r1_rdtice 
     651            wfx_dyn(ji,jj) = wfx_dyn(ji,jj) - vsw (ij) * rhoic * r1_rdtice   ! increase in ice volume due to seawater frozen in voids 
     652             
     653             ! virtual salt flux to keep salinity constant 
     654            IF( nn_icesal == 1 .OR. nn_icesal == 3 )  THEN 
     655               srdg2(ij)      = srdg2(ij) - vsw(ij) * ( sss_m(ji,jj) - sm_i(ji,jj,jl1) )           ! ridge salinity = sm_i 
     656               sfx_bri(ji,jj) = sfx_bri(ji,jj) + sss_m(ji,jj)    * vsw(ij) * rhoic * r1_rdtice  &  ! put back sss_m into the ocean 
     657                  &                            - sm_i(ji,jj,jl1) * vsw(ij) * rhoic * r1_rdtice     ! and get  sm_i  from the ocean  
     658            ENDIF 
     659 
     660            !------------------------------------------             
     661            ! 3.7 Put the snow somewhere in the ocean 
     662            !------------------------------------------             
     663            !  Place part of the snow lost by ridging into the ocean.  
     664            !  Note that esrdg > 0; the ocean must cool to melt snow. 
     665            !  If the ocean temp = Tf already, new ice must grow. 
     666            !  During the next time step, thermo_rates will determine whether 
     667            !  the ocean cools or new ice grows. 
     668            wfx_snw(ji,jj) = wfx_snw(ji,jj) + ( rhosn * vsrdg(ij) * ( 1._wp - rn_fsnowrdg )   &  
     669               &                              + rhosn * vsrft(ij) * ( 1._wp - rn_fsnowrft ) ) * r1_rdtice  ! fresh water source for ocean 
     670 
     671            hfx_dyn(ji,jj) = hfx_dyn(ji,jj) + ( - esrdg(ij) * ( 1._wp - rn_fsnowrdg )         &  
     672               &                                - esrft(ij) * ( 1._wp - rn_fsnowrft ) ) * r1_rdtice        ! heat sink for ocean (<0, W.m-2) 
     673                
     674            !----------------------------------------------------------------- 
     675            ! 3.8 Compute quantities used to apportion ice among categories 
     676            ! in the n2 loop below 
     677            !----------------------------------------------------------------- 
     678            dhr (ij) = 1._wp / ( hrmax(ji,jj,jl1)                    - hrmin(ji,jj,jl1)                    ) 
     679            dhr2(ij) = 1._wp / ( hrmax(ji,jj,jl1) * hrmax(ji,jj,jl1) - hrmin(ji,jj,jl1) * hrmin(ji,jj,jl1) ) 
     680 
     681 
     682            ! update jl1 (removing ridged/rafted area) 
     683            a_i  (ji,jj,  jl1) = a_i  (ji,jj,  jl1) - ardg1 (ij) - arft1 (ij) 
     684            v_i  (ji,jj,  jl1) = v_i  (ji,jj,  jl1) - vrdg1 (ij) - virft (ij) 
     685            v_s  (ji,jj,  jl1) = v_s  (ji,jj,  jl1) - vsrdg (ij) - vsrft (ij) 
     686            e_s  (ji,jj,1,jl1) = e_s  (ji,jj,1,jl1) - esrdg (ij) - esrft (ij) 
     687            smv_i(ji,jj,  jl1) = smv_i(ji,jj,  jl1) - srdg1 (ij) - smrft (ij) 
     688            oa_i (ji,jj,  jl1) = oa_i (ji,jj,  jl1) - oirdg1(ij) - oirft1(ij) 
     689 
     690         END DO 
     691 
     692         !-------------------------------------------------------------------- 
     693         ! 3.9 Compute ridging ice enthalpy, remove it from ridging ice and 
     694         !      compute ridged ice enthalpy  
     695         !-------------------------------------------------------------------- 
     696         DO jk = 1, nlay_i 
     697            DO ij = 1, icells 
     698               ji = indxi(ij) ; jj = indxj(ij) 
     699               ! heat content of ridged ice 
     700               erdg1(ij,jk) = e_i(ji,jj,jk,jl1) * afrac(ij)  
     701               eirft(ij,jk) = e_i(ji,jj,jk,jl1) * afrft(ij)                
     702                
     703               ! enthalpy of the trapped seawater (J/m2, >0) 
     704               ! clem: if sst>0, then ersw <0 (is that possible?) 
     705               ersw(ij,jk)  = - rhoic * vsw(ij) * rcp * sst_m(ji,jj) * r1_nlay_i 
     706 
     707               ! heat flux to the ocean 
     708               hfx_dyn(ji,jj) = hfx_dyn(ji,jj) + ersw(ij,jk) * r1_rdtice  ! > 0 [W.m-2] ocean->ice flux  
     709 
     710               ! it is added to sea ice because the sign convention is the opposite of the sign convention for the ocean 
     711               erdg2(ij,jk) = erdg1(ij,jk) + ersw(ij,jk) 
     712 
     713               ! update jl1 
     714               e_i  (ji,jj,jk,jl1) = e_i(ji,jj,jk,jl1) - erdg1(ij,jk) - eirft(ij,jk) 
     715 
     716            END DO 
     717         END DO 
     718 
     719         !------------------------------------------------------------------------------- 
     720         ! 4) Add area, volume, and energy of new ridge to each category jl2 
     721         !------------------------------------------------------------------------------- 
     722         DO jl2  = 1, jpl  
     723            ! over categories to which ridged/rafted ice is transferred 
     724            DO ij = 1, icells 
     725               ji = indxi(ij) ; jj = indxj(ij) 
     726 
     727               ! Compute the fraction of ridged ice area and volume going to thickness category jl2. 
     728               IF( hrmin(ji,jj,jl1) <= hi_max(jl2) .AND. hrmax(ji,jj,jl1) > hi_max(jl2-1) ) THEN 
     729                  hL = MAX( hrmin(ji,jj,jl1), hi_max(jl2-1) ) 
     730                  hR = MIN( hrmax(ji,jj,jl1), hi_max(jl2)   ) 
     731                  farea    = ( hR      - hL      ) * dhr(ij)  
     732                  fvol(ij) = ( hR * hR - hL * hL ) * dhr2(ij) 
     733               ELSE 
     734                  farea    = 0._wp  
     735                  fvol(ij) = 0._wp                   
     736               ENDIF 
     737 
     738               ! Compute the fraction of rafted ice area and volume going to thickness category jl2 
     739               IF( hraft(ji,jj,jl1) <= hi_max(jl2) .AND. hraft(ji,jj,jl1) >  hi_max(jl2-1) ) THEN 
     740                  zswitch(ij) = 1._wp 
     741               ELSE 
     742                  zswitch(ij) = 0._wp                   
     743               ENDIF 
     744 
     745               a_i  (ji,jj  ,jl2) = a_i  (ji,jj  ,jl2) + ( ardg2 (ij) * farea    + arft2 (ij) * zswitch(ij) ) 
     746               oa_i (ji,jj  ,jl2) = oa_i (ji,jj  ,jl2) + ( oirdg2(ij) * farea    + oirft2(ij) * zswitch(ij) ) 
     747               v_i  (ji,jj  ,jl2) = v_i  (ji,jj  ,jl2) + ( vrdg2 (ij) * fvol(ij) + virft (ij) * zswitch(ij) ) 
     748               smv_i(ji,jj  ,jl2) = smv_i(ji,jj  ,jl2) + ( srdg2 (ij) * fvol(ij) + smrft (ij) * zswitch(ij) ) 
     749               v_s  (ji,jj  ,jl2) = v_s  (ji,jj  ,jl2) + ( vsrdg (ij) * rn_fsnowrdg * fvol(ij)  +  & 
     750                  &                                        vsrft (ij) * rn_fsnowrft * zswitch(ij) ) 
     751               e_s  (ji,jj,1,jl2) = e_s  (ji,jj,1,jl2) + ( esrdg (ij) * rn_fsnowrdg * fvol(ij)  +  & 
     752                  &                                        esrft (ij) * rn_fsnowrft * zswitch(ij) ) 
     753 
     754            END DO 
     755 
     756            ! Transfer ice energy to category jl2 by ridging 
     757            DO jk = 1, nlay_i 
     758               DO ij = 1, icells 
     759                  ji = indxi(ij) ; jj = indxj(ij) 
     760                  e_i(ji,jj,jk,jl2) = e_i(ji,jj,jk,jl2) + erdg2(ij,jk) * fvol(ij) + eirft(ij,jk) * zswitch(ij)                   
     761               END DO 
     762            END DO 
     763            ! 
     764         END DO ! jl2 
     765          
     766      END DO ! jl1 (deforming categories) 
     767 
     768      ! 
     769      CALL wrk_dealloc( jpij,        indxi, indxj ) 
     770      CALL wrk_dealloc( jpij,        zswitch, fvol ) 
     771      CALL wrk_dealloc( jpij,        afrac, ardg1, ardg2, vsrdg, esrdg, dhr, dhr2 ) 
     772      CALL wrk_dealloc( jpij,        vrdg1, vrdg2, vsw  , srdg1, srdg2, smsw, oirdg1, oirdg2 ) 
     773      CALL wrk_dealloc( jpij,        afrft, arft1, arft2, virft, vsrft, esrft, smrft, oirft1, oirft2 ) 
     774      CALL wrk_dealloc( jpij,nlay_i, eirft, erdg1, erdg2, ersw ) 
     775      ! 
     776   END SUBROUTINE lim_itd_me_ridgeshift 
    417777 
    418778   SUBROUTINE lim_itd_me_icestrength( kstrngth ) 
    … …  
    434794      INTEGER             ::   ksmooth     ! smoothing the resistance to deformation 
    435795      INTEGER             ::   numts_rm    ! number of time steps for the P smoothing 
    436       REAL(wp)            ::   zhi, zp, z1_3  ! local scalars 
     796      REAL(wp)            ::   zp, z1_3    ! local scalars 
    437797      REAL(wp), POINTER, DIMENSION(:,:) ::   zworka   ! temporary array used here 
    438798      !!---------------------------------------------------------------------- 
    … …  
    459819               DO ji = 1, jpi 
    460820                  ! 
    461                   IF( a_i(ji,jj,jl) > epsi10 .AND. athorn(ji,jj,jl) > 0._wp ) THEN 
    462                      zhi = v_i(ji,jj,jl) / a_i(ji,jj,jl) 
     821                  IF( athorn(ji,jj,jl) > 0._wp ) THEN 
    463822                     !---------------------------- 
    464823                     ! PE loss from deforming ice 
    465824                     !---------------------------- 
    466                      strength(ji,jj) = strength(ji,jj) - athorn(ji,jj,jl) * zhi * zhi 
     825                     strength(ji,jj) = strength(ji,jj) - athorn(ji,jj,jl) * ht_i(ji,jj,jl) * ht_i(ji,jj,jl) 
    467826 
    468827                     !-------------------------- 
    469828                     ! PE gain from rafting ice 
    470829                     !-------------------------- 
    471                      strength(ji,jj) = strength(ji,jj) + 2._wp * araft(ji,jj,jl) * zhi * zhi 
     830                     strength(ji,jj) = strength(ji,jj) + 2._wp * araft(ji,jj,jl) * ht_i(ji,jj,jl) * ht_i(ji,jj,jl) 
    472831 
    473832                     !---------------------------- 
    474833                     ! PE gain from ridging ice 
    475834                     !---------------------------- 
    476                      strength(ji,jj) = strength(ji,jj) + aridge(ji,jj,jl) / krdg(ji,jj,jl)     & 
    477                         * z1_3 * ( hrmax(ji,jj,jl)**2 + hrmin(ji,jj,jl)**2 +  hrmax(ji,jj,jl) * hrmin(ji,jj,jl) )   
     835                     strength(ji,jj) = strength(ji,jj) + aridge(ji,jj,jl) * krdg(ji,jj,jl) * z1_3 *  & 
     836                        &                              ( hrmax(ji,jj,jl) * hrmax(ji,jj,jl) +         & 
     837                        &                                hrmin(ji,jj,jl) * hrmin(ji,jj,jl) +         & 
     838                        &                                hrmax(ji,jj,jl) * hrmin(ji,jj,jl) )   
    478839                        !!(a**3-b**3)/(a-b) = a*a+ab+b*b                       
    479840                  ENDIF 
    … …  
    497858         ! 
    498859      ENDIF                     ! kstrngth 
    499  
    500860      ! 
    501861      !------------------------------------------------------------------------------! 
    … …  
    503863      !------------------------------------------------------------------------------! 
    504864      ! CAN BE REMOVED 
    505       ! 
    506865      IF( ln_icestr_bvf ) THEN 
    507  
    508866         DO jj = 1, jpj 
    509867            DO ji = 1, jpi 
    … …  
    511869            END DO 
    512870         END DO 
    513  
    514871      ENDIF 
    515  
    516872      ! 
    517873      !------------------------------------------------------------------------------! 
    … …  
    558914      IF ( ksmooth == 2 ) THEN 
    559915 
    560  
    561916         CALL lbc_lnk( strength, 'T', 1. ) 
    562917 
    … …  
    565920               IF ( ( asum(ji,jj) - ato_i(ji,jj) ) > 0._wp) THEN  
    566921                  numts_rm = 1 ! number of time steps for the running mean 
    567                   IF ( strp1(ji,jj) > 0.0 ) numts_rm = numts_rm + 1 
    568                   IF ( strp2(ji,jj) > 0.0 ) numts_rm = numts_rm + 1 
     922                  IF ( strp1(ji,jj) > 0._wp ) numts_rm = numts_rm + 1 
     923                  IF ( strp2(ji,jj) > 0._wp ) numts_rm = numts_rm + 1 
    569924                  zp = ( strength(ji,jj) + strp1(ji,jj) + strp2(ji,jj) ) / numts_rm 
    570925                  strp2(ji,jj) = strp1(ji,jj) 
    … …  
    583938      ! 
    584939   END SUBROUTINE lim_itd_me_icestrength 
    585  
    586  
    587    SUBROUTINE lim_itd_me_ridgeprep 
    588       !!---------------------------------------------------------------------! 
    589       !!                ***  ROUTINE lim_itd_me_ridgeprep *** 
    590       !! 
    591       !! ** Purpose :   preparation for ridging and strength calculations 
    592       !! 
    593       !! ** Method  :   Compute the thickness distribution of the ice and open water  
    594       !!              participating in ridging and of the resulting ridges. 
    595       !!---------------------------------------------------------------------! 
    596       INTEGER ::   ji,jj, jl    ! dummy loop indices 
    597       REAL(wp) ::   Gstari, astari, zhi, hrmean, zdummy   ! local scalar 
    598       REAL(wp), POINTER, DIMENSION(:,:)   ::   zworka    ! temporary array used here 
    599       REAL(wp), POINTER, DIMENSION(:,:,:) ::   Gsum      ! Gsum(n) = sum of areas in categories 0 to n 
    600       !------------------------------------------------------------------------------! 
    601  
    602       CALL wrk_alloc( jpi,jpj, zworka ) 
    603       CALL wrk_alloc( jpi,jpj,jpl+2, Gsum, kkstart = -1 ) 
    604  
    605       Gstari     = 1.0/rn_gstar     
    606       astari     = 1.0/rn_astar     
    607       aksum(:,:)    = 0.0 
    608       athorn(:,:,:) = 0.0 
    609       aridge(:,:,:) = 0.0 
    610       araft (:,:,:) = 0.0 
    611       hrmin(:,:,:)  = 0.0  
    612       hrmax(:,:,:)  = 0.0  
    613       hraft(:,:,:)  = 0.0  
    614       krdg (:,:,:)  = 1.0 
    615  
    616       !     ! Zero out categories with very small areas 
    617       CALL lim_var_zapsmall 
    618  
    619       !------------------------------------------------------------------------------! 
    620       ! 1) Participation function  
    621       !------------------------------------------------------------------------------! 
    622  
    623       ! Compute total area of ice plus open water. 
    624       ! This is in general not equal to one because of divergence during transport 
    625       asum(:,:) = ato_i(:,:) 
    626       DO jl = 1, jpl 
    627          asum(:,:) = asum(:,:) + a_i(:,:,jl) 
    628       END DO 
    629  
    630       ! Compute cumulative thickness distribution function 
    631       ! Compute the cumulative thickness distribution function Gsum, 
    632       ! where Gsum(n) is the fractional area in categories 0 to n. 
    633       ! initial value (in h = 0) equals open water area 
    634  
    635       Gsum(:,:,-1) = 0._wp 
    636       Gsum(:,:,0 ) = ato_i(:,:) 
    637  
    638       ! for each value of h, you have to add ice concentration then 
    639       DO jl = 1, jpl 
    640          Gsum(:,:,jl) = Gsum(:,:,jl-1) + a_i(:,:,jl) 
    641       END DO 
    642  
    643       ! Normalize the cumulative distribution to 1 
    644       zworka(:,:) = 1._wp / Gsum(:,:,jpl) 
    645       DO jl = 0, jpl 
    646          Gsum(:,:,jl) = Gsum(:,:,jl) * zworka(:,:) 
    647       END DO 
    648  
    649       ! 1.3 Compute participation function a(h) = b(h).g(h) (athorn) 
    650       !-------------------------------------------------------------------------------------------------- 
    651       ! Compute the participation function athorn; this is analogous to 
    652       ! a(h) = b(h)g(h) as defined in Thorndike et al. (1975). 
    653       ! area lost from category n due to ridging/closing 
    654       ! athorn(n)   = total area lost due to ridging/closing 
    655       ! assume b(h) = (2/Gstar) * (1 - G(h)/Gstar).  
    656       ! 
    657       ! The expressions for athorn are found by integrating b(h)g(h) between 
    658       ! the category boundaries. 
    659       !----------------------------------------------------------------- 
    660  
    661       IF( nn_partfun == 0 ) THEN       !--- Linear formulation (Thorndike et al., 1975) 
    662          DO jl = 0, jpl     
    663             DO jj = 1, jpj  
    664                DO ji = 1, jpi 
    665                   IF( Gsum(ji,jj,jl) < rn_gstar) THEN 
    666                      athorn(ji,jj,jl) = Gstari * ( Gsum(ji,jj,jl) - Gsum(ji,jj,jl-1) ) * & 
    667                         &                        ( 2.0 - (Gsum(ji,jj,jl-1) + Gsum(ji,jj,jl) ) * Gstari ) 
    668                   ELSEIF (Gsum(ji,jj,jl-1) < rn_gstar) THEN 
    669                      athorn(ji,jj,jl) = Gstari * ( rn_gstar - Gsum(ji,jj,jl-1) ) *  & 
    670                         &                        ( 2.0 - ( Gsum(ji,jj,jl-1) + rn_gstar ) * Gstari ) 
    671                   ELSE 
    672                      athorn(ji,jj,jl) = 0.0 
    673                   ENDIF 
    674                END DO 
    675             END DO 
    676          END DO 
    677  
    678       ELSE                             !--- Exponential, more stable formulation (Lipscomb et al, 2007) 
    679          !                         
    680          zdummy = 1._wp / ( 1._wp - EXP(-astari) )        ! precompute exponential terms using Gsum as a work array 
    681          DO jl = -1, jpl 
    682             Gsum(:,:,jl) = EXP( -Gsum(:,:,jl) * astari ) * zdummy 
    683          END DO 
    684          DO jl = 0, jpl 
    685              athorn(:,:,jl) = Gsum(:,:,jl-1) - Gsum(:,:,jl) 
    686          END DO 
    687          ! 
    688       ENDIF 
    689  
    690       IF( ln_rafting ) THEN      ! Ridging and rafting ice participation functions 
    691          ! 
    692          DO jl = 1, jpl 
    693             DO jj = 1, jpj  
    694                DO ji = 1, jpi 
    695                   IF ( athorn(ji,jj,jl) > 0._wp ) THEN 
    696 !!gm  TANH( -X ) = - TANH( X )  so can be computed only 1 time.... 
    697                      aridge(ji,jj,jl) = ( TANH (  rn_craft * ( ht_i(ji,jj,jl) - rn_hraft ) ) + 1.0 ) * 0.5 * athorn(ji,jj,jl) 
    698                      araft (ji,jj,jl) = ( TANH ( -rn_craft * ( ht_i(ji,jj,jl) - rn_hraft ) ) + 1.0 ) * 0.5 * athorn(ji,jj,jl) 
    699                      IF ( araft(ji,jj,jl) < epsi06 )   araft(ji,jj,jl)  = 0._wp 
    700                      aridge(ji,jj,jl) = MAX( athorn(ji,jj,jl) - araft(ji,jj,jl), 0.0 ) 
    701                   ENDIF 
    702                END DO 
    703             END DO 
    704          END DO 
    705  
    706       ELSE 
    707          ! 
    708          DO jl = 1, jpl 
    709             aridge(:,:,jl) = athorn(:,:,jl) 
    710          END DO 
    711          ! 
    712       ENDIF 
    713  
    714       IF( ln_rafting ) THEN 
    715  
    716          IF( MAXVAL(aridge + araft - athorn(:,:,1:jpl)) > epsi10 .AND. lwp ) THEN 
    717             DO jl = 1, jpl 
    718                DO jj = 1, jpj 
    719                   DO ji = 1, jpi 
    720                      IF ( aridge(ji,jj,jl) + araft(ji,jj,jl) - athorn(ji,jj,jl) > epsi10 ) THEN 
    721                         WRITE(numout,*) ' ALERTE 96 : wrong participation function ... ' 
    722                         WRITE(numout,*) ' ji, jj, jl : ', ji, jj, jl 
    723                         WRITE(numout,*) ' lat, lon   : ', gphit(ji,jj), glamt(ji,jj) 
    724                         WRITE(numout,*) ' aridge     : ', aridge(ji,jj,1:jpl) 
    725                         WRITE(numout,*) ' araft      : ', araft(ji,jj,1:jpl) 
    726                         WRITE(numout,*) ' athorn     : ', athorn(ji,jj,1:jpl) 
    727                      ENDIF 
    728                   END DO 
    729                END DO 
    730             END DO 
    731          ENDIF 
    732  
    733       ENDIF 
    734  
    735       !----------------------------------------------------------------- 
    736       ! 2) Transfer function 
    737       !----------------------------------------------------------------- 
    738       ! Compute max and min ridged ice thickness for each ridging category. 
    739       ! Assume ridged ice is uniformly distributed between hrmin and hrmax. 
    740       !  
    741       ! This parameterization is a modified version of Hibler (1980). 
    742       ! The mean ridging thickness, hrmean, is proportional to hi^(0.5) 
    743       !  and for very thick ridging ice must be >= krdgmin*hi 
    744       ! 
    745       ! The minimum ridging thickness, hrmin, is equal to 2*hi  
    746       !  (i.e., rafting) and for very thick ridging ice is 
    747       !  constrained by hrmin <= (hrmean + hi)/2. 
    748       !  
    749       ! The maximum ridging thickness, hrmax, is determined by 
    750       !  hrmean and hrmin. 
    751       ! 
    752       ! These modifications have the effect of reducing the ice strength 
    753       ! (relative to the Hibler formulation) when very thick ice is 
    754       ! ridging. 
    755       ! 
    756       ! aksum = net area removed/ total area removed 
    757       ! where total area removed = area of ice that ridges 
    758       !         net area removed = total area removed - area of new ridges 
    759       !----------------------------------------------------------------- 
    760  
    761       ! Transfer function 
    762       DO jl = 1, jpl !all categories have a specific transfer function 
    763          DO jj = 1, jpj 
    764             DO ji = 1, jpi 
    765  
    766                IF (a_i(ji,jj,jl) > epsi10 .AND. athorn(ji,jj,jl) > 0.0 ) THEN 
    767                   zhi = v_i(ji,jj,jl) / a_i(ji,jj,jl) 
    768                   hrmean          = MAX(SQRT(rn_hstar*zhi), zhi*krdgmin) 
    769                   hrmin(ji,jj,jl) = MIN(2.0*zhi, 0.5*(hrmean + zhi)) 
    770                   hrmax(ji,jj,jl) = 2.0*hrmean - hrmin(ji,jj,jl) 
    771                   hraft(ji,jj,jl) = kraft*zhi 
    772                   krdg(ji,jj,jl)  = hrmean / zhi 
    773                ELSE 
    774                   hraft(ji,jj,jl) = 0.0 
    775                   hrmin(ji,jj,jl) = 0.0  
    776                   hrmax(ji,jj,jl) = 0.0  
    777                   krdg (ji,jj,jl) = 1.0 
    778                ENDIF 
    779  
    780             END DO 
    781          END DO 
    782       END DO 
    783  
    784       ! Normalization factor : aksum, ensures mass conservation 
    785       aksum(:,:) = athorn(:,:,0) 
    786       DO jl = 1, jpl  
    787          aksum(:,:)    = aksum(:,:) + aridge(:,:,jl) * ( 1._wp - 1._wp / krdg(:,:,jl) )    & 
    788             &                       + araft (:,:,jl) * ( 1._wp - 1._wp / kraft        ) 
    789       END DO 
    790       ! 
    791       CALL wrk_dealloc( jpi,jpj, zworka ) 
    792       CALL wrk_dealloc( jpi,jpj,jpl+2, Gsum, kkstart = -1 ) 
    793       ! 
    794    END SUBROUTINE lim_itd_me_ridgeprep 
    795  
    796  
    797    SUBROUTINE lim_itd_me_ridgeshift( opning, closing_gross, msnow_mlt, esnow_mlt ) 
    798       !!---------------------------------------------------------------------- 
    799       !!                ***  ROUTINE lim_itd_me_icestrength *** 
    800       !! 
    801       !! ** Purpose :   shift ridging ice among thickness categories of ice thickness 
    802       !! 
    803       !! ** Method  :   Remove area, volume, and energy from each ridging category 
    804       !!              and add to thicker ice categories. 
    805       !!---------------------------------------------------------------------- 
    806       REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ) ::   opning         ! rate of opening due to divergence/shear 
    807       REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ) ::   closing_gross  ! rate at which area removed, excluding area of new ridges 
    808       REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   msnow_mlt      ! mass of snow added to ocean (kg m-2) 
    809       REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   esnow_mlt      ! energy needed to melt snow in ocean (J m-2) 
    810       ! 
    811       CHARACTER (len=80) ::   fieldid   ! field identifier 
    812       LOGICAL, PARAMETER ::   l_conservation_check = .true.  ! if true, check conservation (useful for debugging) 
    813       ! 
    814       INTEGER ::   ji, jj, jl, jl1, jl2, jk   ! dummy loop indices 
    815       INTEGER ::   ij                ! horizontal index, combines i and j loops 
    816       INTEGER ::   icells            ! number of cells with aicen > puny 
    817       REAL(wp) ::   hL, hR, farea, ztmelts    ! left and right limits of integration 
    818  
    819       INTEGER , POINTER, DIMENSION(:) ::   indxi, indxj   ! compressed indices 
    820  
    821       REAL(wp), POINTER, DIMENSION(:,:) ::   vice_init, vice_final   ! ice volume summed over categories 
    822       REAL(wp), POINTER, DIMENSION(:,:) ::   eice_init, eice_final   ! ice energy summed over layers 
    823  
    824       REAL(wp), POINTER, DIMENSION(:,:,:) ::   aicen_init, vicen_init   ! ice  area    & volume before ridging 
    825       REAL(wp), POINTER, DIMENSION(:,:,:) ::   vsnwn_init, esnwn_init   ! snow volume  & energy before ridging 
    826       REAL(wp), POINTER, DIMENSION(:,:,:) ::   smv_i_init, oa_i_init    ! ice salinity & age    before ridging 
    827  
    828       REAL(wp), POINTER, DIMENSION(:,:,:,:) ::   eicen_init        ! ice energy before ridging 
    829  
    830       REAL(wp), POINTER, DIMENSION(:,:) ::   afrac , fvol     ! fraction of category area ridged & new ridge volume going to n2 
    831       REAL(wp), POINTER, DIMENSION(:,:) ::   ardg1 , ardg2    ! area of ice ridged & new ridges 
    832       REAL(wp), POINTER, DIMENSION(:,:) ::   vsrdg , esrdg    ! snow volume & energy of ridging ice 
    833       REAL(wp), POINTER, DIMENSION(:,:) ::   dhr   , dhr2     ! hrmax - hrmin  &  hrmax^2 - hrmin^2 
    834  
    835       REAL(wp), POINTER, DIMENSION(:,:) ::   vrdg1   ! volume of ice ridged 
    836       REAL(wp), POINTER, DIMENSION(:,:) ::   vrdg2   ! volume of new ridges 
    837       REAL(wp), POINTER, DIMENSION(:,:) ::   vsw     ! volume of seawater trapped into ridges 
    838       REAL(wp), POINTER, DIMENSION(:,:) ::   srdg1   ! sal*volume of ice ridged 
    839       REAL(wp), POINTER, DIMENSION(:,:) ::   srdg2   ! sal*volume of new ridges 
    840       REAL(wp), POINTER, DIMENSION(:,:) ::   smsw    ! sal*volume of water trapped into ridges 
    841       REAL(wp), POINTER, DIMENSION(:,:) ::   oirdg1, oirdg2   ! ice age of ice ridged 
    842  
    843       REAL(wp), POINTER, DIMENSION(:,:) ::   afrft            ! fraction of category area rafted 
    844       REAL(wp), POINTER, DIMENSION(:,:) ::   arft1 , arft2    ! area of ice rafted and new rafted zone 
    845       REAL(wp), POINTER, DIMENSION(:,:) ::   virft , vsrft    ! ice & snow volume of rafting ice 
    846       REAL(wp), POINTER, DIMENSION(:,:) ::   esrft , smrft    ! snow energy & salinity of rafting ice 
    847       REAL(wp), POINTER, DIMENSION(:,:) ::   oirft1, oirft2   ! ice age of ice rafted 
    848  
    849       REAL(wp), POINTER, DIMENSION(:,:,:) ::   eirft      ! ice energy of rafting ice 
    850       REAL(wp), POINTER, DIMENSION(:,:,:) ::   erdg1      ! enth*volume of ice ridged 
    851       REAL(wp), POINTER, DIMENSION(:,:,:) ::   erdg2      ! enth*volume of new ridges 
    852       REAL(wp), POINTER, DIMENSION(:,:,:) ::   ersw       ! enth of water trapped into ridges 
    853       !!---------------------------------------------------------------------- 
    854  
    855       CALL wrk_alloc( (jpi+1)*(jpj+1),       indxi, indxj ) 
    856       CALL wrk_alloc( jpi, jpj,              vice_init, vice_final, eice_init, eice_final ) 
    857       CALL wrk_alloc( jpi, jpj,              afrac, fvol , ardg1, ardg2, vsrdg, esrdg, dhr, dhr2 ) 
    858       CALL wrk_alloc( jpi, jpj,              vrdg1, vrdg2, vsw  , srdg1, srdg2, smsw, oirdg1, oirdg2 ) 
    859       CALL wrk_alloc( jpi, jpj,              afrft, arft1, arft2, virft, vsrft, esrft, smrft, oirft1, oirft2 ) 
    860       CALL wrk_alloc( jpi, jpj, jpl,         aicen_init, vicen_init, vsnwn_init, esnwn_init, smv_i_init, oa_i_init ) 
    861       CALL wrk_alloc( jpi, jpj, nlay_i,      eirft, erdg1, erdg2, ersw ) 
    862       CALL wrk_alloc( jpi, jpj, nlay_i, jpl, eicen_init ) 
    863  
    864       ! Conservation check 
    865       eice_init(:,:) = 0._wp 
    866  
    867       IF( con_i ) THEN 
    868          CALL lim_column_sum        (jpl,    v_i,       vice_init ) 
    869          CALL lim_column_sum_energy (jpl, nlay_i,  e_i, eice_init ) 
    870          DO ji = mi0(iiceprt), mi1(iiceprt) 
    871             DO jj = mj0(jiceprt), mj1(jiceprt) 
    872                WRITE(numout,*) ' vice_init  : ', vice_init(ji,jj) 
    873                WRITE(numout,*) ' eice_init  : ', eice_init(ji,jj) 
    874             END DO 
    875          END DO 
    876       ENDIF 
    877  
    878       !------------------------------------------------------------------------------- 
    879       ! 1) Compute change in open water area due to closing and opening. 
    880       !------------------------------------------------------------------------------- 
    881       DO jj = 1, jpj 
    882          DO ji = 1, jpi 
    883             ato_i(ji,jj) = ato_i(ji,jj) - athorn(ji,jj,0) * closing_gross(ji,jj) * rdt_ice        & 
    884                &                        + opning(ji,jj)                          * rdt_ice 
    885             IF    ( ato_i(ji,jj) < -epsi10 ) THEN    ! there is a bug 
    886                IF(lwp)   WRITE(numout,*) 'Ridging error: ato_i < 0 -- ato_i : ',ato_i(ji,jj) 
    887             ELSEIF( ato_i(ji,jj) < 0._wp   ) THEN    ! roundoff error 
    888                ato_i(ji,jj) = 0._wp 
    889             ENDIF 
    890          END DO 
    891       END DO 
    892  
    893       !----------------------------------------------------------------- 
    894       ! 2) Save initial state variables 
    895       !----------------------------------------------------------------- 
    896       aicen_init(:,:,:)   = a_i  (:,:,:) 
    897       vicen_init(:,:,:)   = v_i  (:,:,:) 
    898       vsnwn_init(:,:,:)   = v_s  (:,:,:) 
    899       smv_i_init(:,:,:)   = smv_i(:,:,:) 
    900       esnwn_init(:,:,:)   = e_s  (:,:,1,:) 
    901       eicen_init(:,:,:,:) = e_i  (:,:,:,:) 
    902       oa_i_init (:,:,:)   = oa_i (:,:,:) 
    903  
    904       ! 
    905       !----------------------------------------------------------------- 
    906       ! 3) Pump everything from ice which is being ridged / rafted 
    907       !----------------------------------------------------------------- 
    908       ! Compute the area, volume, and energy of ice ridging in each 
    909       ! category, along with the area of the resulting ridge. 
    910  
    911       DO jl1 = 1, jpl !jl1 describes the ridging category 
    912  
    913          !------------------------------------------------ 
    914          ! 3.1) Identify grid cells with nonzero ridging 
    915          !------------------------------------------------ 
    916  
    917          icells = 0 
    918          DO jj = 1, jpj 
    919             DO ji = 1, jpi 
    920                IF( aicen_init(ji,jj,jl1) > epsi10 .AND. athorn(ji,jj,jl1) > 0._wp  & 
    921                   &   .AND. closing_gross(ji,jj) > 0._wp ) THEN 
    922                   icells = icells + 1 
    923                   indxi(icells) = ji 
    924                   indxj(icells) = jj 
    925                ENDIF 
    926             END DO 
    927          END DO 
    928  
    929          DO ij = 1, icells 
    930             ji = indxi(ij) 
    931             jj = indxj(ij) 
    932  
    933             !-------------------------------------------------------------------- 
    934             ! 3.2) Compute area of ridging ice (ardg1) and of new ridge (ardg2) 
    935             !-------------------------------------------------------------------- 
    936  
    937             ardg1(ji,jj) = aridge(ji,jj,jl1)*closing_gross(ji,jj)*rdt_ice 
    938             arft1(ji,jj) = araft (ji,jj,jl1)*closing_gross(ji,jj)*rdt_ice 
    939             ardg2(ji,jj) = ardg1(ji,jj) / krdg(ji,jj,jl1) 
    940             arft2(ji,jj) = arft1(ji,jj) / kraft 
    941  
    942             !--------------------------------------------------------------- 
    943             ! 3.3) Compute ridging /rafting fractions, make sure afrac <=1  
    944             !--------------------------------------------------------------- 
    945  
    946             afrac(ji,jj) = ardg1(ji,jj) / aicen_init(ji,jj,jl1) !ridging 
    947             afrft(ji,jj) = arft1(ji,jj) / aicen_init(ji,jj,jl1) !rafting 
    948  
    949             IF( afrac(ji,jj) > kamax + epsi10 ) THEN  ! there is a bug 
    950                IF(lwp)   WRITE(numout,*) ' ardg > a_i -- ardg, aicen_init : ', ardg1(ji,jj), aicen_init(ji,jj,jl1) 
    951             ELSEIF( afrac(ji,jj) > kamax ) THEN       ! roundoff error 
    952                afrac(ji,jj) = kamax 
    953             ENDIF 
    954  
    955             IF( afrft(ji,jj) > kamax + epsi10 ) THEN ! there is a bug 
    956                IF(lwp)   WRITE(numout,*) ' arft > a_i -- arft, aicen_init : ', arft1(ji,jj), aicen_init(ji,jj,jl1)  
    957             ELSEIF( afrft(ji,jj) > kamax) THEN       ! roundoff error 
    958                afrft(ji,jj) = kamax 
    959             ENDIF 
    960  
    961             !-------------------------------------------------------------------------- 
    962             ! 3.4) Subtract area, volume, and energy from ridging  
    963             !     / rafting category n1. 
    964             !-------------------------------------------------------------------------- 
    965             vrdg1(ji,jj) = vicen_init(ji,jj,jl1) * afrac(ji,jj) 
    966             vrdg2(ji,jj) = vrdg1(ji,jj) * ( 1. + rn_por_rdg ) 
    967             vsw  (ji,jj) = vrdg1(ji,jj) * rn_por_rdg 
    968  
    969             vsrdg (ji,jj) = vsnwn_init(ji,jj,jl1) * afrac(ji,jj) 
    970             esrdg (ji,jj) = esnwn_init(ji,jj,jl1) * afrac(ji,jj) 
    971             srdg1 (ji,jj) = smv_i_init(ji,jj,jl1) * afrac(ji,jj) 
    972             oirdg1(ji,jj) = oa_i_init (ji,jj,jl1) * afrac(ji,jj) 
    973             oirdg2(ji,jj) = oa_i_init (ji,jj,jl1) * afrac(ji,jj) / krdg(ji,jj,jl1)  
    974  
    975             ! rafting volumes, heat contents ... 
    976             virft (ji,jj) = vicen_init(ji,jj,jl1) * afrft(ji,jj) 
    977             vsrft (ji,jj) = vsnwn_init(ji,jj,jl1) * afrft(ji,jj) 
    978             esrft (ji,jj) = esnwn_init(ji,jj,jl1) * afrft(ji,jj) 
    979             smrft (ji,jj) = smv_i_init(ji,jj,jl1) * afrft(ji,jj)  
    980             oirft1(ji,jj) = oa_i_init (ji,jj,jl1) * afrft(ji,jj)  
    981             oirft2(ji,jj) = oa_i_init (ji,jj,jl1) * afrft(ji,jj) / kraft  
    982  
    983             ! substract everything 
    984             a_i(ji,jj,jl1)   = a_i(ji,jj,jl1)   - ardg1 (ji,jj) - arft1 (ji,jj) 
    985             v_i(ji,jj,jl1)   = v_i(ji,jj,jl1)   - vrdg1 (ji,jj) - virft (ji,jj) 
    986             v_s(ji,jj,jl1)   = v_s(ji,jj,jl1)   - vsrdg (ji,jj) - vsrft (ji,jj) 
    987             e_s(ji,jj,1,jl1) = e_s(ji,jj,1,jl1) - esrdg (ji,jj) - esrft (ji,jj) 
    988             smv_i(ji,jj,jl1) = smv_i(ji,jj,jl1) - srdg1 (ji,jj) - smrft (ji,jj) 
    989             oa_i(ji,jj,jl1)  = oa_i(ji,jj,jl1)  - oirdg1(ji,jj) - oirft1(ji,jj) 
    990  
    991             !----------------------------------------------------------------- 
    992             ! 3.5) Compute properties of new ridges 
    993             !----------------------------------------------------------------- 
    994             !--------- 
    995             ! Salinity 
    996             !--------- 
    997             smsw(ji,jj)  = vsw(ji,jj) * sss_m(ji,jj)                      ! salt content of seawater frozen in voids !! MV HC2014 
    998             srdg2(ji,jj) = srdg1(ji,jj) + smsw(ji,jj)                     ! salt content of new ridge 
    999  
    1000             !srdg2(ji,jj) = MIN( rn_simax * vrdg2(ji,jj) , zsrdg2 )         ! impose a maximum salinity 
    1001              
    1002             sfx_dyn(ji,jj) = sfx_dyn(ji,jj) - smsw(ji,jj) * rhoic * r1_rdtice 
    1003             wfx_dyn(ji,jj) = wfx_dyn(ji,jj) - vsw (ji,jj) * rhoic * r1_rdtice   ! increase in ice volume du to seawater frozen in voids              
    1004  
    1005             !------------------------------------             
    1006             ! 3.6 Increment ridging diagnostics 
    1007             !------------------------------------             
    1008  
    1009             !        jl1 looping 1-jpl 
    1010             !           ij looping 1-icells 
    1011  
    1012             dardg1dt   (ji,jj) = dardg1dt(ji,jj) + ardg1(ji,jj) + arft1(ji,jj) 
    1013             dardg2dt   (ji,jj) = dardg2dt(ji,jj) + ardg2(ji,jj) + arft2(ji,jj) 
    1014             opening    (ji,jj) = opening (ji,jj) + opning(ji,jj) * rdt_ice 
    1015  
    1016             IF( con_i )   vice_init(ji,jj) = vice_init(ji,jj) + vrdg2(ji,jj) - vrdg1(ji,jj) 
    1017  
    1018             !------------------------------------------             
    1019             ! 3.7 Put the snow somewhere in the ocean 
    1020             !------------------------------------------             
    1021             !  Place part of the snow lost by ridging into the ocean.  
    1022             !  Note that esnow_mlt < 0; the ocean must cool to melt snow. 
    1023             !  If the ocean temp = Tf already, new ice must grow. 
    1024             !  During the next time step, thermo_rates will determine whether 
    1025             !  the ocean cools or new ice grows. 
    1026             !        jl1 looping 1-jpl 
    1027             !           ij looping 1-icells 
    1028  
    1029             msnow_mlt(ji,jj) = msnow_mlt(ji,jj) + rhosn*vsrdg(ji,jj)*(1.0-rn_fsnowrdg)   &   ! rafting included 
    1030                &                                + rhosn*vsrft(ji,jj)*(1.0-rn_fsnowrft) 
    1031  
    1032             ! in J/m2 (same as e_s) 
    1033             esnow_mlt(ji,jj) = esnow_mlt(ji,jj) - esrdg(ji,jj)*(1.0-rn_fsnowrdg)         &   !rafting included 
    1034                &                                - esrft(ji,jj)*(1.0-rn_fsnowrft)           
    1035  
    1036             !----------------------------------------------------------------- 
    1037             ! 3.8 Compute quantities used to apportion ice among categories 
    1038             ! in the n2 loop below 
    1039             !----------------------------------------------------------------- 
    1040  
    1041             !        jl1 looping 1-jpl 
    1042             !           ij looping 1-icells 
    1043  
    1044             dhr (ji,jj) = hrmax(ji,jj,jl1) - hrmin(ji,jj,jl1) 
    1045             dhr2(ji,jj) = hrmax(ji,jj,jl1) * hrmax(ji,jj,jl1) - hrmin(ji,jj,jl1) * hrmin(ji,jj,jl1) 
    1046  
    1047          END DO 
    1048  
    1049          !-------------------------------------------------------------------- 
    1050          ! 3.9 Compute ridging ice enthalpy, remove it from ridging ice and 
    1051          !      compute ridged ice enthalpy  
    1052          !-------------------------------------------------------------------- 
    1053          DO jk = 1, nlay_i 
    1054             DO ij = 1, icells 
    1055                ji = indxi(ij) 
    1056                jj = indxj(ij) 
    1057                ! heat content of ridged ice 
    1058                erdg1(ji,jj,jk)      = eicen_init(ji,jj,jk,jl1) * afrac(ji,jj)  
    1059                eirft(ji,jj,jk)      = eicen_init(ji,jj,jk,jl1) * afrft(ji,jj) 
    1060                e_i  (ji,jj,jk,jl1)  = e_i(ji,jj,jk,jl1) - erdg1(ji,jj,jk) - eirft(ji,jj,jk) 
    1061                 
    1062                 
    1063                ! enthalpy of the trapped seawater (J/m2, >0) 
    1064                ! clem: if sst>0, then ersw <0 (is that possible?) 
    1065                ersw(ji,jj,jk)   = - rhoic * vsw(ji,jj) * rcp * sst_m(ji,jj) * r1_nlay_i 
    1066  
    1067                ! heat flux to the ocean 
    1068                hfx_dyn(ji,jj) = hfx_dyn(ji,jj) + ersw(ji,jj,jk) * r1_rdtice  ! > 0 [W.m-2] ocean->ice flux  
    1069  
    1070                ! it is added to sea ice because the sign convention is the opposite of the sign convention for the ocean 
    1071                erdg2(ji,jj,jk)  = erdg1(ji,jj,jk) + ersw(ji,jj,jk) 
    1072  
    1073             END DO 
    1074          END DO 
    1075  
    1076  
    1077          IF( con_i ) THEN 
    1078             DO jk = 1, nlay_i 
    1079                DO ij = 1, icells 
    1080                   ji = indxi(ij) 
    1081                   jj = indxj(ij) 
    1082                   eice_init(ji,jj) = eice_init(ji,jj) + erdg2(ji,jj,jk) - erdg1(ji,jj,jk) 
    1083                END DO 
    1084             END DO 
    1085          ENDIF 
    1086  
    1087          !------------------------------------------------------------------------------- 
    1088          ! 4) Add area, volume, and energy of new ridge to each category jl2 
    1089          !------------------------------------------------------------------------------- 
    1090          !        jl1 looping 1-jpl 
    1091          DO jl2  = 1, jpl  
    1092             ! over categories to which ridged ice is transferred 
    1093             DO ij = 1, icells 
    1094                ji = indxi(ij) 
    1095                jj = indxj(ij) 
    1096  
    1097                ! Compute the fraction of ridged ice area and volume going to  
    1098                ! thickness category jl2. 
    1099                ! Transfer area, volume, and energy accordingly. 
    1100  
    1101                IF( hrmin(ji,jj,jl1) >= hi_max(jl2) .OR. hrmax(ji,jj,jl1) <= hi_max(jl2-1) ) THEN 
    1102                   hL = 0._wp 
    1103                   hR = 0._wp 
    1104                ELSE 
    1105                   hL = MAX( hrmin(ji,jj,jl1), hi_max(jl2-1) ) 
    1106                   hR = MIN( hrmax(ji,jj,jl1), hi_max(jl2)   ) 
    1107                ENDIF 
    1108  
    1109                ! fraction of ridged ice area and volume going to n2 
    1110                farea = ( hR - hL ) / dhr(ji,jj)  
    1111                fvol(ji,jj) = ( hR*hR - hL*hL ) / dhr2(ji,jj) 
    1112  
    1113                a_i  (ji,jj  ,jl2) = a_i  (ji,jj  ,jl2) + ardg2 (ji,jj) * farea 
    1114                v_i  (ji,jj  ,jl2) = v_i  (ji,jj  ,jl2) + vrdg2 (ji,jj) * fvol(ji,jj) 
    1115                v_s  (ji,jj  ,jl2) = v_s  (ji,jj  ,jl2) + vsrdg (ji,jj) * fvol(ji,jj) * rn_fsnowrdg 
    1116                e_s  (ji,jj,1,jl2) = e_s  (ji,jj,1,jl2) + esrdg (ji,jj) * fvol(ji,jj) * rn_fsnowrdg 
    1117                smv_i(ji,jj  ,jl2) = smv_i(ji,jj  ,jl2) + srdg2 (ji,jj) * fvol(ji,jj) 
    1118                oa_i (ji,jj  ,jl2) = oa_i (ji,jj  ,jl2) + oirdg2(ji,jj) * farea 
    1119  
    1120             END DO 
    1121  
    1122             ! Transfer ice energy to category jl2 by ridging 
    1123             DO jk = 1, nlay_i 
    1124                DO ij = 1, icells 
    1125                   ji = indxi(ij) 
    1126                   jj = indxj(ij) 
    1127                   e_i(ji,jj,jk,jl2) = e_i(ji,jj,jk,jl2) + fvol(ji,jj) * erdg2(ji,jj,jk) 
    1128                END DO 
    1129             END DO 
    1130             ! 
    1131          END DO                 ! jl2 (new ridges)             
    1132  
    1133          DO jl2 = 1, jpl  
    1134  
    1135             DO ij = 1, icells 
    1136                ji = indxi(ij) 
    1137                jj = indxj(ij) 
    1138                ! Compute the fraction of rafted ice area and volume going to  
    1139                ! thickness category jl2, transfer area, volume, and energy accordingly. 
    1140                ! 
    1141                IF( hraft(ji,jj,jl1) <= hi_max(jl2) .AND. hraft(ji,jj,jl1) >  hi_max(jl2-1) ) THEN 
    1142                   a_i  (ji,jj  ,jl2) = a_i  (ji,jj  ,jl2) + arft2 (ji,jj) 
    1143                   v_i  (ji,jj  ,jl2) = v_i  (ji,jj  ,jl2) + virft (ji,jj) 
    1144                   v_s  (ji,jj  ,jl2) = v_s  (ji,jj  ,jl2) + vsrft (ji,jj) * rn_fsnowrft 
    1145                   e_s  (ji,jj,1,jl2) = e_s  (ji,jj,1,jl2) + esrft (ji,jj) * rn_fsnowrft 
    1146                   smv_i(ji,jj  ,jl2) = smv_i(ji,jj  ,jl2) + smrft (ji,jj)     
    1147                   oa_i (ji,jj  ,jl2) = oa_i (ji,jj  ,jl2) + oirft2(ji,jj) 
    1148                ENDIF 
    1149                ! 
    1150             END DO 
    1151  
    1152             ! Transfer rafted ice energy to category jl2  
    1153             DO jk = 1, nlay_i 
    1154                DO ij = 1, icells 
    1155                   ji = indxi(ij) 
    1156                   jj = indxj(ij) 
    1157                   IF( hraft(ji,jj,jl1) <= hi_max(jl2) .AND. hraft(ji,jj,jl1) > hi_max(jl2-1)  ) THEN 
    1158                      e_i(ji,jj,jk,jl2) = e_i(ji,jj,jk,jl2) + eirft(ji,jj,jk) 
    1159                   ENDIF 
    1160                END DO 
    1161             END DO 
    1162  
    1163          END DO 
    1164  
    1165       END DO ! jl1 (deforming categories) 
    1166  
    1167       ! Conservation check 
    1168       IF ( con_i ) THEN 
    1169          CALL lim_column_sum (jpl,   v_i, vice_final) 
    1170          fieldid = ' v_i : limitd_me ' 
    1171          CALL lim_cons_check (vice_init, vice_final, 1.0e-6, fieldid)  
    1172  
    1173          CALL lim_column_sum_energy (jpl, nlay_i,  e_i, eice_final ) 
    1174          fieldid = ' e_i : limitd_me ' 
    1175          CALL lim_cons_check (eice_init, eice_final, 1.0e-2, fieldid)  
    1176  
    1177          DO ji = mi0(iiceprt), mi1(iiceprt) 
    1178             DO jj = mj0(jiceprt), mj1(jiceprt) 
    1179                WRITE(numout,*) ' vice_init  : ', vice_init (ji,jj) 
    1180                WRITE(numout,*) ' vice_final : ', vice_final(ji,jj) 
    1181                WRITE(numout,*) ' eice_init  : ', eice_init (ji,jj) 
    1182                WRITE(numout,*) ' eice_final : ', eice_final(ji,jj) 
    1183             END DO 
    1184          END DO 
    1185       ENDIF 
    1186       ! 
    1187       CALL wrk_dealloc( (jpi+1)*(jpj+1),        indxi, indxj ) 
    1188       CALL wrk_dealloc( jpi, jpj,               vice_init, vice_final, eice_init, eice_final ) 
    1189       CALL wrk_dealloc( jpi, jpj,               afrac, fvol , ardg1, ardg2, vsrdg, esrdg, dhr, dhr2 ) 
    1190       CALL wrk_dealloc( jpi, jpj,               vrdg1, vrdg2, vsw  , srdg1, srdg2, smsw, oirdg1, oirdg2 ) 
    1191       CALL wrk_dealloc( jpi, jpj,               afrft, arft1, arft2, virft, vsrft, esrft, smrft, oirft1, oirft2 ) 
    1192       CALL wrk_dealloc( jpi, jpj, jpl,          aicen_init, vicen_init, vsnwn_init, esnwn_init, smv_i_init, oa_i_init ) 
    1193       CALL wrk_dealloc( jpi, jpj, nlay_i,       eirft, erdg1, erdg2, ersw ) 
    1194       CALL wrk_dealloc( jpi, jpj, nlay_i, jpl,  eicen_init ) 
    1195       ! 
    1196    END SUBROUTINE lim_itd_me_ridgeshift 
    1197940 
    1198941   SUBROUTINE lim_itd_me_init 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/LIM_SRC_3/limrhg.F90

    r6836 r6839  
    159159      CALL wrk_alloc( jpi,jpj, u_oce2, u_ice2, v_oce1 , v_ice1 , zmask               ) 
    160160      CALL wrk_alloc( jpi,jpj, zf1   , zu_ice, zf2   , zv_ice , zdt    , zds  ) 
    161       CALL wrk_alloc( jpi,jpj, zdt   , zds   , zs1   , zs2   , zs12   , zresr , zpice                 ) 
     161      CALL wrk_alloc( jpi,jpj, zs1   , zs2   , zs12   , zresr , zpice                 ) 
    162162 
    163163#if  defined key_lim2 && ! defined key_lim2_vp 
    … …  
    690690      CALL wrk_dealloc( jpi,jpj, u_oce2, u_ice2, v_oce1 , v_ice1 , zmask               ) 
    691691      CALL wrk_dealloc( jpi,jpj, zf1   , zu_ice, zf2   , zv_ice , zdt    , zds  ) 
    692       CALL wrk_dealloc( jpi,jpj, zdt   , zds   , zs1   , zs2   , zs12   , zresr , zpice                 ) 
     692      CALL wrk_dealloc( jpi,jpj, zs1   , zs2   , zs12   , zresr , zpice                 ) 
    693693 
    694694   END SUBROUTINE lim_rhg 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/LIM_SRC_3/limsbc.F90

    r6836 r6839  
    9494      !!              - fr_i    : ice fraction 
    9595      !!              - tn_ice  : sea-ice surface temperature 
    96       !!              - alb_ice : sea-ice albedo (only useful in coupled mode) 
     96      !!              - alb_ice : sea-ice albedo (recomputed only for coupled mode) 
    9797      !! 
    9898      !! References : Goosse, H. et al. 1996, Bul. Soc. Roy. Sc. Liege, 65, 87-90. 
    … …  
    106106      REAL(wp) ::   zqsr                                           ! New solar flux received by the ocean 
    107107      ! 
    108       REAL(wp), POINTER, DIMENSION(:,:,:) ::   zalb_cs, zalb_os     ! 2D/3D workspace 
     108      REAL(wp), POINTER, DIMENSION(:,:,:) ::   zalb_cs, zalb_os     ! 3D workspace 
     109      REAL(wp), POINTER, DIMENSION(:,:)   ::   zalb                 ! 2D workspace 
    109110      !!--------------------------------------------------------------------- 
    110111 
    111112      ! make calls for heat fluxes before it is modified 
     113      ! pfrld is the lead fraction at the previous time step (actually between TRP and THD) 
    112114      IF( iom_use('qsr_oce') )   CALL iom_put( "qsr_oce" , qsr_oce(:,:) * pfrld(:,:) )                                   !     solar flux at ocean surface 
    113115      IF( iom_use('qns_oce') )   CALL iom_put( "qns_oce" , qns_oce(:,:) * pfrld(:,:) + qemp_oce(:,:) )                   ! non-solar flux at ocean surface 
    … …  
    118120      IF( iom_use('qt_ice' ) )   CALL iom_put( "qt_ice"  , SUM( ( qns_ice(:,:,:) + qsr_ice(:,:,:) )   & 
    119121         &                                                      * a_i_b(:,:,:), dim=3 ) + qemp_ice(:,:) ) 
    120       IF( iom_use('qemp_oce' ) )   CALL iom_put( "qemp_oce"  , qemp_oce(:,:) )   
    121       IF( iom_use('qemp_ice' ) )   CALL iom_put( "qemp_ice"  , qemp_ice(:,:) )   
    122  
    123       ! pfrld is the lead fraction at the previous time step (actually between TRP and THD) 
     122      IF( iom_use('qemp_oce') )  CALL iom_put( "qemp_oce" , qemp_oce(:,:) )   
     123      IF( iom_use('qemp_ice') )  CALL iom_put( "qemp_ice" , qemp_ice(:,:) )   
     124      IF( iom_use('emp_oce' ) )  CALL iom_put( "emp_oce"  , emp_oce(:,:) )   ! emp over ocean (taking into account the snow blown away from the ice) 
     125      IF( iom_use('emp_ice' ) )  CALL iom_put( "emp_ice"  , emp_ice(:,:) )   ! emp over ice   (taking into account the snow blown away from the ice) 
     126 
     127      ! albedo output 
     128      CALL wrk_alloc( jpi,jpj, zalb )     
     129 
     130      zalb(:,:) = 0._wp 
     131      WHERE     ( SUM( a_i_b, dim=3 ) <= epsi06 )  ;  zalb(:,:) = 0.066_wp 
     132      ELSEWHERE                                    ;  zalb(:,:) = SUM( alb_ice * a_i_b, dim=3 ) / SUM( a_i_b, dim=3 ) 
     133      END WHERE 
     134      IF( iom_use('alb_ice' ) )  CALL iom_put( "alb_ice"  , zalb(:,:) )           ! ice albedo output 
     135 
     136      zalb(:,:) = SUM( alb_ice * a_i_b, dim=3 ) + 0.066_wp * ( 1._wp - SUM( a_i_b, dim=3 ) )       
     137      IF( iom_use('albedo'  ) )  CALL iom_put( "albedo"  , zalb(:,:) )           ! ice albedo output 
     138 
     139      CALL wrk_dealloc( jpi,jpj, zalb )     
     140      ! 
     141       
    124142      DO jj = 1, jpj 
    125143         DO ji = 1, jpi 
    … …  
    140158            hfx_out(ji,jj) = hfx_out(ji,jj) + zqmass + zqsr 
    141159 
    142             ! Add the residual from heat diffusion equation (W.m-2) 
    143             !------------------------------------------------------- 
    144             hfx_out(ji,jj) = hfx_out(ji,jj) + hfx_err_dif(ji,jj) 
     160            ! Add the residual from heat diffusion equation and sublimation (W.m-2) 
     161            !---------------------------------------------------------------------- 
     162            hfx_out(ji,jj) = hfx_out(ji,jj) + hfx_err_dif(ji,jj) +   & 
     163               &           ( hfx_sub(ji,jj) - SUM( qevap_ice(ji,jj,:) * a_i_b(ji,jj,:) ) ) 
    145164 
    146165            ! New qsr and qns used to compute the oceanic heat flux at the next time step 
    147             !--------------------------------------------------- 
     166            !---------------------------------------------------------------------------- 
    148167            qsr(ji,jj) = zqsr                                       
    149168            qns(ji,jj) = hfx_out(ji,jj) - zqsr               
    … …  
    165184 
    166185            ! mass flux at the ocean/ice interface 
    167             fmmflx(ji,jj) = - ( wfx_ice(ji,jj) + wfx_snw(ji,jj) ) * r1_rdtice  ! F/M mass flux save at least for biogeochemical model 
    168             emp(ji,jj)    = emp_oce(ji,jj) - wfx_ice(ji,jj) - wfx_snw(ji,jj)   ! mass flux + F/M mass flux (always ice/ocean mass exchange) 
    169              
     186            fmmflx(ji,jj) = - ( wfx_ice(ji,jj) + wfx_snw(ji,jj) + wfx_err_sub(ji,jj) )              ! F/M mass flux save at least for biogeochemical model 
     187            emp(ji,jj)    = emp_oce(ji,jj) - wfx_ice(ji,jj) - wfx_snw(ji,jj) - wfx_err_sub(ji,jj)   ! mass flux + F/M mass flux (always ice/ocean mass exchange) 
    170188         END DO 
    171189      END DO 
    … …  
    175193      !------------------------------------------! 
    176194      sfx(:,:) = sfx_bog(:,:) + sfx_bom(:,:) + sfx_sum(:,:) + sfx_sni(:,:) + sfx_opw(:,:)   & 
    177          &     + sfx_res(:,:) + sfx_dyn(:,:) + sfx_bri(:,:) 
     195         &     + sfx_res(:,:) + sfx_dyn(:,:) + sfx_bri(:,:) + sfx_sub(:,:) 
    178196 
    179197      !-------------------------------------------------------------! 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/LIM_SRC_3/limthd.F90

    r6836 r6839  
    461461 
    462462      DO ji = kideb, kiut 
    463          zdh_mel = MIN( 0._wp, dh_i_surf(ji) + dh_i_bott(ji) + dh_snowice(ji) ) 
     463         zdh_mel = MIN( 0._wp, dh_i_surf(ji) + dh_i_bott(ji) + dh_snowice(ji) + dh_i_sub(ji) ) 
    464464         IF( zdh_mel < 0._wp .AND. a_i_1d(ji) > 0._wp )  THEN 
    465465            zvi          = a_i_1d(ji) * ht_i_1d(ji) 
    … …  
    470470            zda_mel     = rswitch * a_i_1d(ji) * zdh_mel / ( 2._wp * MAX( zhi_bef, epsi20 ) ) 
    471471            a_i_1d(ji)  = MAX( epsi20, a_i_1d(ji) + zda_mel )  
    472              ! adjust thickness 
     472            ! adjust thickness 
    473473            ht_i_1d(ji) = zvi / a_i_1d(ji)             
    474474            ht_s_1d(ji) = zvs / a_i_1d(ji)             
    … …  
    514514          
    515515         CALL tab_2d_1d( nbpb, qprec_ice_1d(1:nbpb), qprec_ice(:,:) , jpi, jpj, npb(1:nbpb) ) 
     516         CALL tab_2d_1d( nbpb, qevap_ice_1d(1:nbpb), qevap_ice(:,:,jl) , jpi, jpj, npb(1:nbpb) ) 
    516517         CALL tab_2d_1d( nbpb, qsr_ice_1d (1:nbpb), qsr_ice(:,:,jl) , jpi, jpj, npb(1:nbpb) ) 
    517518         CALL tab_2d_1d( nbpb, fr1_i0_1d  (1:nbpb), fr1_i0          , jpi, jpj, npb(1:nbpb) ) 
    … …  
    543544         CALL tab_2d_1d( nbpb, sfx_bri_1d (1:nbpb), sfx_bri         , jpi, jpj, npb(1:nbpb) ) 
    544545         CALL tab_2d_1d( nbpb, sfx_res_1d (1:nbpb), sfx_res         , jpi, jpj, npb(1:nbpb) ) 
    545           
     546         CALL tab_2d_1d( nbpb, sfx_sub_1d (1:nbpb), sfx_sub         , jpi, jpj,npb(1:nbpb) ) 
     547  
    546548         CALL tab_2d_1d( nbpb, hfx_thd_1d (1:nbpb), hfx_thd         , jpi, jpj, npb(1:nbpb) ) 
    547549         CALL tab_2d_1d( nbpb, hfx_spr_1d (1:nbpb), hfx_spr         , jpi, jpj, npb(1:nbpb) ) 
    … …  
    593595         CALL tab_1d_2d( nbpb, sfx_res       , npb, sfx_res_1d(1:nbpb)   , jpi, jpj ) 
    594596         CALL tab_1d_2d( nbpb, sfx_bri       , npb, sfx_bri_1d(1:nbpb)   , jpi, jpj ) 
    595           
     597         CALL tab_1d_2d( nbpb, sfx_sub       , npb, sfx_sub_1d(1:nbpb)   , jpi, jpj )         
     598  
    596599         CALL tab_1d_2d( nbpb, hfx_thd       , npb, hfx_thd_1d(1:nbpb)   , jpi, jpj ) 
    597600         CALL tab_1d_2d( nbpb, hfx_spr       , npb, hfx_spr_1d(1:nbpb)   , jpi, jpj ) 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/LIM_SRC_3/limthd_dh.F90

    r6836 r6839  
    7474 
    7575      REAL(wp) ::   ztmelts             ! local scalar 
    76       REAL(wp) ::   zfdum        
     76      REAL(wp) ::   zdum        
    7777      REAL(wp) ::   zfracs       ! fractionation coefficient for bottom salt entrapment 
    7878      REAL(wp) ::   zs_snic      ! snow-ice salinity 
    … …  
    9595      REAL(wp), POINTER, DIMENSION(:) ::   zq_rema     ! remaining heat at the end of the routine    (J.m-2) 
    9696      REAL(wp), POINTER, DIMENSION(:) ::   zf_tt       ! Heat budget to determine melting or freezing(W.m-2) 
     97      REAL(wp), POINTER, DIMENSION(:) ::   zevap_rema  ! remaining mass flux from sublimation        (kg.m-2) 
    9798 
    9899      REAL(wp), POINTER, DIMENSION(:) ::   zdh_s_mel   ! snow melt  
    … …  
    105106 
    106107      REAL(wp), POINTER, DIMENSION(:) ::   zqh_i       ! total ice heat content  (J.m-2) 
    107       REAL(wp), POINTER, DIMENSION(:) ::   zqh_s       ! total snow heat content (J.m-2) 
    108       REAL(wp), POINTER, DIMENSION(:) ::   zq_s        ! total snow enthalpy     (J.m-3) 
    109108      REAL(wp), POINTER, DIMENSION(:) ::   zsnw        ! distribution of snow after wind blowing 
    110109 
    … …  
    117116 
    118117      ! Discriminate between varying salinity (nn_icesal=2) and prescribed cases (other values) 
    119       SELECT CASE( nn_icesal )                       ! varying salinity or not 
    120          CASE( 1, 3, 4 ) ;   zswitch_sal = 0       ! prescribed salinity profile 
    121          CASE( 2 )       ;   zswitch_sal = 1       ! varying salinity profile 
     118      SELECT CASE( nn_icesal )                  ! varying salinity or not 
     119         CASE( 1, 3 ) ;   zswitch_sal = 0       ! prescribed salinity profile 
     120         CASE( 2 )    ;   zswitch_sal = 1       ! varying salinity profile 
    122121      END SELECT 
    123122 
    124       CALL wrk_alloc( jpij, zqprec, zq_su, zq_bo, zf_tt, zq_rema, zsnw ) 
    125       CALL wrk_alloc( jpij, zdh_s_mel, zdh_s_pre, zdh_s_sub, zqh_i, zqh_s, zq_s ) 
     123      CALL wrk_alloc( jpij, zqprec, zq_su, zq_bo, zf_tt, zq_rema, zsnw, zevap_rema ) 
     124      CALL wrk_alloc( jpij, zdh_s_mel, zdh_s_pre, zdh_s_sub, zqh_i ) 
    126125      CALL wrk_alloc( jpij, nlay_i, zdeltah, zh_i ) 
    127126      CALL wrk_alloc( jpij, nlay_i, icount ) 
    128127        
    129       dh_i_surf  (:) = 0._wp ; dh_i_bott  (:) = 0._wp ; dh_snowice(:) = 0._wp 
     128      dh_i_surf  (:) = 0._wp ; dh_i_bott  (:) = 0._wp ; dh_snowice(:) = 0._wp ; dh_i_sub(:) = 0._wp 
    130129      dsm_i_se_1d(:) = 0._wp ; dsm_i_si_1d(:) = 0._wp    
    131130 
    132131      zqprec   (:) = 0._wp ; zq_su    (:) = 0._wp ; zq_bo    (:) = 0._wp ; zf_tt(:) = 0._wp 
    133       zq_rema  (:) = 0._wp ; zsnw     (:) = 0._wp 
     132      zq_rema  (:) = 0._wp ; zsnw     (:) = 0._wp ; zevap_rema(:) = 0._wp ; 
    134133      zdh_s_mel(:) = 0._wp ; zdh_s_pre(:) = 0._wp ; zdh_s_sub(:) = 0._wp ; zqh_i(:) = 0._wp 
    135       zqh_s    (:) = 0._wp ; zq_s     (:) = 0._wp      
    136134 
    137135      zdeltah(:,:) = 0._wp ; zh_i(:,:) = 0._wp        
    … …  
    159157      ! 
    160158      DO ji = kideb, kiut 
    161          zfdum      = qns_ice_1d(ji) + ( 1._wp - i0(ji) ) * qsr_ice_1d(ji) - fc_su(ji)  
     159         zdum       = qns_ice_1d(ji) + ( 1._wp - i0(ji) ) * qsr_ice_1d(ji) - fc_su(ji)  
    162160         zf_tt(ji)  = fc_bo_i(ji) + fhtur_1d(ji) + fhld_1d(ji)  
    163161 
    164          zq_su (ji) = MAX( 0._wp, zfdum     * rdt_ice ) * MAX( 0._wp , SIGN( 1._wp, t_su_1d(ji) - rt0 ) ) 
     162         zq_su (ji) = MAX( 0._wp, zdum      * rdt_ice ) * MAX( 0._wp , SIGN( 1._wp, t_su_1d(ji) - rt0 ) ) 
    165163         zq_bo (ji) = MAX( 0._wp, zf_tt(ji) * rdt_ice ) 
    166164      END DO 
    … …  
    187185      !  2) Computing layer thicknesses and enthalpies.            ! 
    188186      !------------------------------------------------------------! 
    189       ! 
    190       DO jk = 1, nlay_s 
    191          DO ji = kideb, kiut 
    192             zqh_s(ji) =  zqh_s(ji) + q_s_1d(ji,jk) * ht_s_1d(ji) * r1_nlay_s 
    193          END DO 
    194       END DO 
    195187      ! 
    196188      DO jk = 1, nlay_i 
    … …  
    275267      END DO 
    276268 
    277       !---------------------- 
    278       ! 3.2 Snow sublimation  
    279       !---------------------- 
     269      !------------------------------ 
     270      ! 3.2 Sublimation (part1: snow)  
     271      !------------------------------ 
    280272      ! qla_ice is always >=0 (upwards), heat goes to the atmosphere, therefore snow sublimates 
    281273      ! clem comment: not counted in mass/heat exchange in limsbc since this is an exchange with atm. (not ocean) 
    282       ! clem comment: ice should also sublimate 
    283274      zdeltah(:,:) = 0._wp 
    284       ! coupled mode: sublimation is set to 0 (evap_ice = 0) until further notice 
    285       ! forced  mode: snow thickness change due to sublimation 
    286       DO ji = kideb, kiut 
    287          zdh_s_sub(ji)  =  MAX( - ht_s_1d(ji) , - evap_ice_1d(ji) * r1_rhosn * rdt_ice ) 
    288          ! Heat flux by sublimation [W.m-2], < 0 
    289          !      sublimate first snow that had fallen, then pre-existing snow 
     275      DO ji = kideb, kiut 
     276         zdh_s_sub(ji)  = MAX( - ht_s_1d(ji) , - evap_ice_1d(ji) * r1_rhosn * rdt_ice ) 
     277         ! remaining evap in kg.m-2 (used for ice melting later on) 
     278         zevap_rema(ji)  = evap_ice_1d(ji) * rdt_ice + zdh_s_sub(ji) * rhosn 
     279         ! Heat flux by sublimation [W.m-2], < 0 (sublimate first snow that had fallen, then pre-existing snow) 
    290280         zdeltah(ji,1)  = MAX( zdh_s_sub(ji), - zdh_s_pre(ji) ) 
    291281         hfx_sub_1d(ji) = hfx_sub_1d(ji) + ( zdeltah(ji,1) * zqprec(ji) + ( zdh_s_sub(ji) - zdeltah(ji,1) ) * q_s_1d(ji,1)  & 
    … …  
    309299      !------------------------------------------- 
    310300      ! new temp and enthalpy of the snow (remaining snow precip + remaining pre-existing snow) 
    311       zq_s(:) = 0._wp  
    312301      DO jk = 1, nlay_s 
    313302         DO ji = kideb,kiut 
    314             rswitch       = MAX(  0._wp , SIGN( 1._wp, ht_s_1d(ji) - epsi20 )  ) 
    315             q_s_1d(ji,jk) = rswitch / MAX( ht_s_1d(ji), epsi20 ) *                          & 
    316               &            ( (   zdh_s_pre(ji)             ) * zqprec(ji) +  & 
    317               &              (   ht_s_1d(ji) - zdh_s_pre(ji) ) * rhosn * ( cpic * ( rt0 - t_s_1d(ji,jk) ) + lfus ) ) 
    318             zq_s(ji)     =  zq_s(ji) + q_s_1d(ji,jk) 
     303            rswitch       = MAX( 0._wp , SIGN( 1._wp, ht_s_1d(ji) - epsi20 ) ) 
     304            q_s_1d(ji,jk) = rswitch / MAX( ht_s_1d(ji), epsi20 ) *           & 
     305              &            ( ( zdh_s_pre(ji)               ) * zqprec(ji) +  & 
     306              &              ( ht_s_1d(ji) - zdh_s_pre(ji) ) * rhosn * ( cpic * ( rt0 - t_s_1d(ji,jk) ) + lfus ) ) 
    319307         END DO 
    320308      END DO 
    … …  
    370358               zQm            = zfmdt * zEw                           ! Energy of the melt water sent to the ocean [J/m2, <0] 
    371359                
    372                ! Contribution to salt flux (clem: using sm_i_1d and not s_i_1d(jk) is ok) 
     360               ! Contribution to salt flux >0 (clem: using sm_i_1d and not s_i_1d(jk) is ok) 
    373361               sfx_sum_1d(ji) = sfx_sum_1d(ji) - rhoic * a_i_1d(ji) * zdeltah(ji,jk) * sm_i_1d(ji) * r1_rdtice 
    374362                
    … …  
    383371                
    384372            END IF 
     373            ! ---------------------- 
     374            ! Sublimation part2: ice 
     375            ! ---------------------- 
     376            zdum      = MAX( - ( zh_i(ji,jk) + zdeltah(ji,jk) ) , - zevap_rema(ji) * r1_rhoic ) 
     377            zdeltah(ji,jk) = zdeltah(ji,jk) + zdum 
     378            dh_i_sub(ji)  = dh_i_sub(ji) + zdum 
     379            ! Salt flux > 0 (clem2016: flux is sent to the ocean for simplicity but salt should remain in the ice except if all ice is melted. 
     380            !                          It must be corrected at some point) 
     381            sfx_sub_1d(ji) = sfx_sub_1d(ji) - rhoic * a_i_1d(ji) * zdum * sm_i_1d(ji) * r1_rdtice 
     382            ! Heat flux [W.m-2], < 0 
     383            hfx_sub_1d(ji) = hfx_sub_1d(ji) + zdum * q_i_1d(ji,jk) * a_i_1d(ji) * r1_rdtice 
     384            ! Mass flux > 0 
     385            wfx_sub_1d(ji) =  wfx_sub_1d(ji) - rhoic * a_i_1d(ji) * zdum * r1_rdtice 
     386            ! update remaining mass flux 
     387            zevap_rema(ji)  = zevap_rema(ji) + zdum * rhoic 
     388             
    385389            ! record which layers have disappeared (for bottom melting)  
    386390            !    => icount=0 : no layer has vanished 
    … …  
    389393            icount(ji,jk) = NINT( rswitch ) 
    390394            zh_i(ji,jk)   = MAX( 0._wp , zh_i(ji,jk) + zdeltah(ji,jk) ) 
    391  
     395                         
    392396            ! update heat content (J.m-2) and layer thickness 
    393397            qh_i_old(ji,jk) = qh_i_old(ji,jk) + zdeltah(ji,jk) * q_i_1d(ji,jk) 
    … …  
    397401      ! update ice thickness 
    398402      DO ji = kideb, kiut 
    399          ht_i_1d(ji) =  MAX( 0._wp , ht_i_1d(ji) + dh_i_surf(ji) ) 
     403         ht_i_1d(ji) =  MAX( 0._wp , ht_i_1d(ji) + dh_i_surf(ji) + dh_i_sub(ji) ) 
     404      END DO 
     405 
     406      ! remaining "potential" evap is sent to ocean 
     407      DO ji = kideb, kiut 
     408         ii = MOD( npb(ji) - 1, jpi ) + 1 ; ij = ( npb(ji) - 1 ) / jpi + 1 
     409         wfx_err_sub(ii,ij) = wfx_err_sub(ii,ij) - zevap_rema(ji) * a_i_1d(ji) * r1_rdtice  ! <=0 (net evap for the ocean in kg.m-2.s-1) 
    400410      END DO 
    401411 
    … …  
    641651 
    642652         ! Contribution to energy flux to the ocean [J/m2], >0 (if sst<0) 
    643          ii = MOD( npb(ji) - 1, jpi ) + 1 ; ij = ( npb(ji) - 1 ) / jpi + 1 
    644653         zfmdt          = ( rhosn - rhoic ) * MAX( dh_snowice(ji), 0._wp )    ! <0 
    645654         zsstK          = sst_m(ii,ij) + rt0                                 
    … …  
    652661         ! Contribution to salt flux 
    653662         sfx_sni_1d(ji) = sfx_sni_1d(ji) + sss_m(ii,ij) * a_i_1d(ji) * zfmdt * r1_rdtice  
     663 
     664         ! virtual salt flux to keep salinity constant 
     665         IF( nn_icesal == 1 .OR. nn_icesal == 3 )  THEN 
     666            sfx_bri_1d(ji) = sfx_bri_1d(ji) - sss_m(ii,ij) * a_i_1d(ji) * zfmdt                  * r1_rdtice  & ! put back sss_m into the ocean 
     667               &                            - sm_i_1d(ji)  * a_i_1d(ji) * dh_snowice(ji) * rhoic * r1_rdtice    ! and get  sm_i  from the ocean  
     668         ENDIF 
    654669           
    655670         ! Contribution to mass flux 
    … …  
    686701      WHERE( ht_i_1d == 0._wp ) a_i_1d = 0._wp 
    687702       
    688       CALL wrk_dealloc( jpij, zqprec, zq_su, zq_bo, zf_tt, zq_rema, zsnw ) 
    689       CALL wrk_dealloc( jpij, zdh_s_mel, zdh_s_pre, zdh_s_sub, zqh_i, zqh_s, zq_s ) 
     703      CALL wrk_dealloc( jpij, zqprec, zq_su, zq_bo, zf_tt, zq_rema, zsnw, zevap_rema ) 
     704      CALL wrk_dealloc( jpij, zdh_s_mel, zdh_s_pre, zdh_s_sub, zqh_i ) 
    690705      CALL wrk_dealloc( jpij, nlay_i, zdeltah, zh_i ) 
    691706      CALL wrk_dealloc( jpij, nlay_i, icount ) 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/LIM_SRC_3/limthd_lac.F90

    r6836 r6839  
    7575      INTEGER ::   ii, ij, iter     !   -       - 
    7676      REAL(wp)  ::   ztmelts, zdv, zfrazb, zweight, zde                         ! local scalars 
    77       REAL(wp) ::   zgamafr, zvfrx, zvgx, ztaux, ztwogp, zf , zhicol_new        !   -      - 
     77      REAL(wp) ::   zgamafr, zvfrx, zvgx, ztaux, ztwogp, zf                     !   -      - 
    7878      REAL(wp) ::   ztenagm, zvfry, zvgy, ztauy, zvrel2, zfp, zsqcd , zhicrit   !   -      - 
    79       LOGICAL  ::   iterate_frazil   ! iterate frazil ice collection thickness 
    8079      CHARACTER (len = 15) :: fieldid 
    8180 
    … …  
    108107      REAL(wp), POINTER, DIMENSION(:,:) ::   zsmv_i_1d ! 1-D version of smv_i 
    109108 
    110       REAL(wp), POINTER, DIMENSION(:,:,:) ::   ze_i_1d   !: 1-D version of e_i 
    111  
    112       REAL(wp), POINTER, DIMENSION(:,:) ::   zvrel                   ! relative ice / frazil velocity 
    113  
    114       REAL(wp) :: zcai = 1.4e-3_wp 
     109      REAL(wp), POINTER, DIMENSION(:,:,:) ::   ze_i_1d !: 1-D version of e_i 
     110 
     111      REAL(wp), POINTER, DIMENSION(:,:) ::   zvrel     ! relative ice / frazil velocity 
     112 
     113      REAL(wp) :: zcai = 1.4e-3_wp                     ! ice-air drag (clem: should be dependent on coupling/forcing used) 
    115114      !!-----------------------------------------------------------------------! 
    116115 
    … …  
    143142      !------------------------------------------------------------------------------!     
    144143      ! hicol is the thickness of new ice formed in open water 
    145       ! hicol can be either prescribed (frazswi = 0) 
    146       ! or computed (frazswi = 1) 
     144      ! hicol can be either prescribed (frazswi = 0) or computed (frazswi = 1) 
    147145      ! Frazil ice forms in open water, is transported by wind 
    148146      ! accumulates at the edge of the consolidated ice edge 
    … …  
    155153      zvrel(:,:) = 0._wp 
    156154 
    157       ! Default new ice thickness  
    158       hicol(:,:) = rn_hnewice 
     155      ! Default new ice thickness 
     156      WHERE( qlead(:,:) < 0._wp ) ; hicol = rn_hnewice 
     157      ELSEWHERE                   ; hicol = 0._wp 
     158      END WHERE 
    159159 
    160160      IF( ln_frazil ) THEN 
    … …  
    182182                     &          +   vtau_ice(ji  ,jj  ) * vmask(ji  ,jj  ,1) ) * 0.5_wp 
    183183                  ! Square root of wind stress 
    184                   ztenagm       =  SQRT( SQRT( ztaux**2 + ztauy**2 ) ) 
     184                  ztenagm       =  SQRT( SQRT( ztaux * ztaux + ztauy * ztauy ) ) 
    185185 
    186186                  !--------------------- 
    … …  
    205205                  zvrel2 = MAX(  ( zvfrx - zvgx ) * ( zvfrx - zvgx )   & 
    206206                     &         + ( zvfry - zvgy ) * ( zvfry - zvgy ) , 0.15 * 0.15 ) 
    207                   zvrel(ji,jj)  = SQRT( zvrel2 ) 
     207                  zvrel(ji,jj) = SQRT( zvrel2 ) 
    208208 
    209209                  !--------------------- 
    210210                  ! Iterative procedure 
    211211                  !--------------------- 
    212                   hicol(ji,jj) = zhicrit + 0.1  
    213                   hicol(ji,jj) = zhicrit +   hicol(ji,jj)    & 
    214                      &                   / ( hicol(ji,jj) * hicol(ji,jj) -  zhicrit * zhicrit ) * ztwogp * zvrel2 
    215  
    216 !!gm better coding: above: hicol(ji,jj) * hicol(ji,jj) = (zhicrit + 0.1)*(zhicrit + 0.1) 
    217 !!gm                                                   = zhicrit**2 + 0.2*zhicrit +0.01 
    218 !!gm                therefore the 2 lines with hicol can be replaced by 1 line: 
    219 !!gm              hicol(ji,jj) = zhicrit + (zhicrit + 0.1) / ( 0.2 * zhicrit + 0.01 ) * ztwogp * zvrel2 
    220 !!gm further more (zhicrit + 0.1)/(0.2 * zhicrit + 0.01 )*ztwogp can be computed one for all outside the DO loop 
     212                  hicol(ji,jj) = zhicrit +   ( zhicrit + 0.1 )    & 
     213                     &                   / ( ( zhicrit + 0.1 ) * ( zhicrit + 0.1 ) -  zhicrit * zhicrit ) * ztwogp * zvrel2 
    221214 
    222215                  iter = 1 
    223                   iterate_frazil = .true. 
    224  
    225                   DO WHILE ( iter < 100 .AND. iterate_frazil )  
    226                      zf = ( hicol(ji,jj) - zhicrit ) * ( hicol(ji,jj)**2 - zhicrit**2 ) & 
    227                         - hicol(ji,jj) * zhicrit * ztwogp * zvrel2 
    228                      zfp = ( hicol(ji,jj) - zhicrit ) * ( 3.0*hicol(ji,jj) + zhicrit ) & 
    229                         - zhicrit * ztwogp * zvrel2 
    230                      zhicol_new = hicol(ji,jj) - zf/zfp 
    231                      hicol(ji,jj)   = zhicol_new 
    232  
     216                  DO WHILE ( iter < 20 )  
     217                     zf  = ( hicol(ji,jj) - zhicrit ) * ( hicol(ji,jj) * hicol(ji,jj) - zhicrit * zhicrit ) -   & 
     218                        &    hicol(ji,jj) * zhicrit * ztwogp * zvrel2 
     219                     zfp = ( hicol(ji,jj) - zhicrit ) * ( 3.0 * hicol(ji,jj) + zhicrit ) - zhicrit * ztwogp * zvrel2 
     220 
     221                     hicol(ji,jj) = hicol(ji,jj) - zf/zfp 
    233222                     iter = iter + 1 
    234  
    235                   END DO ! do while 
     223                  END DO 
    236224 
    237225               ENDIF ! end of selection of pixels where ice forms 
    238226 
    239             END DO ! loop on ji ends 
    240          END DO ! loop on jj ends 
    241       !  
    242       CALL lbc_lnk( zvrel(:,:), 'T', 1. ) 
    243       CALL lbc_lnk( hicol(:,:), 'T', 1. ) 
     227            END DO  
     228         END DO  
     229         !  
     230         CALL lbc_lnk( zvrel(:,:), 'T', 1. ) 
     231         CALL lbc_lnk( hicol(:,:), 'T', 1. ) 
    244232 
    245233      ENDIF ! End of computation of frazil ice collection thickness 
    … …  
    282270      ! Move from 2-D to 1-D vectors 
    283271      !------------------------------ 
    284       ! If ocean gains heat do nothing  
    285       ! 0therwise compute new ice formation 
     272      ! If ocean gains heat do nothing. Otherwise compute new ice formation 
    286273 
    287274      IF ( nbpac > 0 ) THEN 
    … …  
    297284         END DO 
    298285 
    299          CALL tab_2d_1d( nbpac, qlead_1d  (1:nbpac)     , qlead  , jpi, jpj, npac(1:nbpac) ) 
    300          CALL tab_2d_1d( nbpac, t_bo_1d   (1:nbpac)     , t_bo   , jpi, jpj, npac(1:nbpac) ) 
    301          CALL tab_2d_1d( nbpac, sfx_opw_1d(1:nbpac)     , sfx_opw, jpi, jpj, npac(1:nbpac) ) 
    302          CALL tab_2d_1d( nbpac, wfx_opw_1d(1:nbpac)     , wfx_opw, jpi, jpj, npac(1:nbpac) ) 
    303          CALL tab_2d_1d( nbpac, hicol_1d  (1:nbpac)     , hicol  , jpi, jpj, npac(1:nbpac) ) 
    304          CALL tab_2d_1d( nbpac, zvrel_1d  (1:nbpac)     , zvrel  , jpi, jpj, npac(1:nbpac) ) 
    305  
    306          CALL tab_2d_1d( nbpac, hfx_thd_1d(1:nbpac)     , hfx_thd, jpi, jpj, npac(1:nbpac) ) 
    307          CALL tab_2d_1d( nbpac, hfx_opw_1d(1:nbpac)     , hfx_opw, jpi, jpj, npac(1:nbpac) ) 
     286         CALL tab_2d_1d( nbpac, qlead_1d  (1:nbpac)     , qlead     , jpi, jpj, npac(1:nbpac) ) 
     287         CALL tab_2d_1d( nbpac, t_bo_1d   (1:nbpac)     , t_bo      , jpi, jpj, npac(1:nbpac) ) 
     288         CALL tab_2d_1d( nbpac, sfx_opw_1d(1:nbpac)     , sfx_opw   , jpi, jpj, npac(1:nbpac) ) 
     289         CALL tab_2d_1d( nbpac, wfx_opw_1d(1:nbpac)     , wfx_opw   , jpi, jpj, npac(1:nbpac) ) 
     290         CALL tab_2d_1d( nbpac, hicol_1d  (1:nbpac)     , hicol     , jpi, jpj, npac(1:nbpac) ) 
     291         CALL tab_2d_1d( nbpac, zvrel_1d  (1:nbpac)     , zvrel     , jpi, jpj, npac(1:nbpac) ) 
     292 
     293         CALL tab_2d_1d( nbpac, hfx_thd_1d(1:nbpac)     , hfx_thd   , jpi, jpj, npac(1:nbpac) ) 
     294         CALL tab_2d_1d( nbpac, hfx_opw_1d(1:nbpac)     , hfx_opw   , jpi, jpj, npac(1:nbpac) ) 
     295         CALL tab_2d_1d( nbpac, rn_amax_1d(1:nbpac)     , rn_amax_2d, jpi, jpj, npac(1:nbpac) ) 
    308296 
    309297         !------------------------------------------------------------------------------! 
    … …  
    316304         zv_b(1:nbpac,:) = zv_i_1d(1:nbpac,:)  
    317305         za_b(1:nbpac,:) = za_i_1d(1:nbpac,:) 
     306 
    318307         !---------------------- 
    319308         ! Thickness of new ice 
    320309         !---------------------- 
    321          DO ji = 1, nbpac 
    322             zh_newice(ji) = rn_hnewice 
    323          END DO 
    324          IF( ln_frazil ) zh_newice(1:nbpac) = hicol_1d(1:nbpac) 
     310         zh_newice(1:nbpac) = hicol_1d(1:nbpac) 
    325311 
    326312         !---------------------- 
    … …  
    384370            ! salt flux 
    385371            sfx_opw_1d(ji) = sfx_opw_1d(ji) - zv_newice(ji) * rhoic * zs_newice(ji) * r1_rdtice 
    386  
     372         END DO 
     373          
     374         zv_frazb(:) = 0._wp 
     375         IF( ln_frazil ) THEN 
    387376            ! A fraction zfrazb of frazil ice is accreted at the ice bottom 
    388             rswitch       = 1._wp - MAX( 0._wp, SIGN( 1._wp , - zat_i_1d(ji) ) ) 
    389             zfrazb        = rswitch * ( TANH ( rn_Cfrazb * ( zvrel_1d(ji) - rn_vfrazb ) ) + 1.0 ) * 0.5 * rn_maxfrazb 
    390             zv_frazb(ji)  =         zfrazb   * zv_newice(ji) 
    391             zv_newice(ji) = ( 1.0 - zfrazb ) * zv_newice(ji) 
    392          END DO 
    393  
     377            DO ji = 1, nbpac 
     378               rswitch       = 1._wp - MAX( 0._wp, SIGN( 1._wp , - zat_i_1d(ji) ) ) 
     379               zfrazb        = rswitch * ( TANH( rn_Cfrazb * ( zvrel_1d(ji) - rn_vfrazb ) ) + 1.0 ) * 0.5 * rn_maxfrazb 
     380               zv_frazb(ji)  =         zfrazb   * zv_newice(ji) 
     381               zv_newice(ji) = ( 1.0 - zfrazb ) * zv_newice(ji) 
     382            END DO 
     383         END IF 
     384          
    394385         !----------------- 
    395386         ! Area of new ice 
    … …  
    409400         ! we keep the excessive volume in memory and attribute it later to bottom accretion 
    410401         DO ji = 1, nbpac 
    411             IF ( za_newice(ji) >  ( rn_amax - zat_i_1d(ji) ) ) THEN 
    412                zda_res(ji)   = za_newice(ji) - ( rn_amax - zat_i_1d(ji) ) 
     402            IF ( za_newice(ji) >  ( rn_amax_1d(ji) - zat_i_1d(ji) ) ) THEN 
     403               zda_res(ji)   = za_newice(ji) - ( rn_amax_1d(ji) - zat_i_1d(ji) ) 
    413404               zdv_res(ji)   = zda_res  (ji) * zh_newice(ji)  
    414405               za_newice(ji) = za_newice(ji) - zda_res  (ji) 
    … …  
    443434               jl = jcat(ji) 
    444435               rswitch = MAX( 0._wp, SIGN( 1._wp , zv_i_1d(ji,jl) - epsi20 ) ) 
    445                ze_i_1d(ji,jk,jl) = zswinew(ji)   *   ze_newice(ji) +                                                      & 
     436               ze_i_1d(ji,jk,jl) = zswinew(ji)   *   ze_newice(ji) +                                                    & 
    446437                  &        ( 1.0 - zswinew(ji) ) * ( ze_newice(ji) * zv_newice(ji) + ze_i_1d(ji,jk,jl) * zv_b(ji,jl) )  & 
    447438                  &        * rswitch / MAX( zv_i_1d(ji,jl), epsi20 ) 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/LIM_SRC_3/limthd_sal.F90

    r6836 r6839  
    6262      END DO 
    6363  
    64       !------------------------------------------------------------------------------| 
    65       ! 1) Constant salinity, constant in time                                       | 
    66       !------------------------------------------------------------------------------| 
    67 !!gm comment: if nn_icesal = 1 s_i_new, s_i_1d and sm_i_1d can be set to rn_icesal one for all in the initialisation phase !! 
    68 !!gm           ===>>>   simplification of almost all test on nn_icesal value 
    69       IF(  nn_icesal == 1  ) THEN 
    70             s_i_1d (kideb:kiut,1:nlay_i) =  rn_icesal 
    71             sm_i_1d(kideb:kiut)          =  rn_icesal  
    72             s_i_new(kideb:kiut)          =  rn_icesal 
    73       ENDIF 
     64      !--------------------------------------------------------------------| 
     65      ! 1) salinity constant in time                                       | 
     66      !--------------------------------------------------------------------| 
     67      ! do nothing 
    7468 
    75       !------------------------------------------------------------------------------| 
    76       !  Module 2 : Constant salinity varying in time                                | 
    77       !------------------------------------------------------------------------------| 
     69      !----------------------------------------------------------------------| 
     70      !  2) salinity varying in time                                         | 
     71      !----------------------------------------------------------------------| 
    7872      IF(  nn_icesal == 2  ) THEN 
    7973 
    … …  
    113107 
    114108      !------------------------------------------------------------------------------| 
    115       !  Module 3 : Profile of salinity, constant in time                            | 
     109      !  3) vertical profile of salinity, constant in time                           | 
    116110      !------------------------------------------------------------------------------| 
    117111      IF(  nn_icesal == 3  )   CALL lim_var_salprof1d( kideb, kiut ) 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/LIM_SRC_3/limtrp.F90

    r6836 r6839  
    6363      INTEGER, INTENT(in) ::   kt           ! number of iteration 
    6464      ! 
    65       INTEGER  ::   ji, jj, jk, jl, jt      ! dummy loop indices 
     65      INTEGER  ::   ji, jj, jk, jm , jl, jt      ! dummy loop indices 
    6666      INTEGER  ::   initad                  ! number of sub-timestep for the advection 
    6767      REAL(wp) ::   zcfl , zusnit           !   -      - 
    … …  
    7575      REAL(wp), POINTER, DIMENSION(:,:,:)    ::   zhimax                   ! old ice thickness 
    7676      REAL(wp), POINTER, DIMENSION(:,:)      ::   zatold, zeiold, zesold   ! old concentration, enthalpies 
     77      REAL(wp), POINTER, DIMENSION(:,:,:)             ::   zhdfptab 
    7778      REAL(wp) ::    zdv, zvi, zvs, zsmv, zes, zei 
    7879      REAL(wp) ::    zvi_b, zsmv_b, zei_b, zfs_b, zfw_b, zft_b 
     80      !!--------------------------------------------------------------------- 
     81      INTEGER                                ::  ihdf_vars  = 6  !!Number of variables in which we apply horizontal diffusion 
     82                                                                   !!  inside limtrp for each ice category , not counting the  
     83                                                                   !!  variables corresponding to ice_layers  
    7984      !!--------------------------------------------------------------------- 
    8085      IF( nn_timing == 1 )  CALL timing_start('limtrp') 
    … …  
    8590      CALL wrk_alloc( jpi,jpj,nlay_i,jpl, z0ei ) 
    8691      CALL wrk_alloc( jpi,jpj,jpl,        zhimax, zviold, zvsold, zsmvold ) 
     92      CALL wrk_alloc( jpi,jpj,jpl*(ihdf_vars + nlay_i)+1,zhdfptab) 
    8793 
    8894      IF( numit == nstart .AND. lwp ) THEN 
    … …  
    170176            z0oi (:,:,jl)   = oa_i (:,:,jl) * e12t(:,:)    ! Age content 
    171177            z0es (:,:,jl)   = e_s  (:,:,1,jl) * e12t(:,:)  ! Snow heat content 
    172             DO jk = 1, nlay_i 
     178           DO jk = 1, nlay_i 
    173179               z0ei  (:,:,jk,jl) = e_i  (:,:,jk,jl) * e12t(:,:) ! Ice  heat content 
    174180            END DO 
    … …  
    284290         ! Diffusion of Ice fields                   
    285291         !------------------------------------------------------------------------------! 
    286  
     292         !------------------------------------ 
     293         !  Diffusion of other ice variables 
     294         !------------------------------------ 
     295         jm=1 
     296         DO jl = 1, jpl 
     297         !                             ! Masked eddy diffusivity coefficient at ocean U- and V-points 
     298         !   DO jj = 1, jpjm1                 ! NB: has not to be defined on jpj line and jpi row 
     299         !      DO ji = 1 , fs_jpim1   ! vector opt. 
     300         !         pahu(ji,jj) = ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -a_i(ji  ,jj,jl) ) ) )   & 
     301         !            &        * ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -a_i(ji+1,jj,jl) ) ) ) * ahiu(ji,jj) 
     302         !         pahv(ji,jj) = ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -a_i(ji,jj  ,jl) ) ) )   & 
     303         !            &        * ( 1._wp - MAX( 0._wp, SIGN( 1._wp,- a_i(ji,jj+1,jl) ) ) ) * ahiv(ji,jj) 
     304         !      END DO 
     305         !   END DO 
     306            DO jj = 1, jpjm1                 ! NB: has not to be defined on jpj line and jpi row 
     307               DO ji = 1 , fs_jpim1   ! vector opt. 
     308                  pahu3D(ji,jj,jl) = ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -a_i(ji  ,jj,  jl ) ) ) )   & 
     309                  &                * ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -a_i(ji+1,jj,  jl ) ) ) ) * ahiu(ji,jj) 
     310                  pahv3D(ji,jj,jl) = ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -a_i(ji,  jj,  jl ) ) ) )   & 
     311                  &                * ( 1._wp - MAX( 0._wp, SIGN( 1._wp,- a_i(ji,  jj+1,jl ) ) ) ) * ahiv(ji,jj) 
     312               END DO 
     313            END DO 
     314 
     315            zhdfptab(:,:,jm)= a_i  (:,:,  jl); jm = jm + 1     
     316            zhdfptab(:,:,jm)= v_i  (:,:,  jl); jm = jm + 1 
     317            zhdfptab(:,:,jm)= v_s  (:,:,  jl); jm = jm + 1  
     318            zhdfptab(:,:,jm)= smv_i(:,:,  jl); jm = jm + 1 
     319            zhdfptab(:,:,jm)= oa_i (:,:,  jl); jm = jm + 1 
     320            zhdfptab(:,:,jm)= e_s  (:,:,1,jl); jm = jm + 1 
     321         ! Sample of adding more variables to apply lim_hdf using lim_hdf optimization--- 
     322         !   zhdfptab(:,:,jm) = variable_1 (:,:,1,jl); jm = jm + 1   
     323         !   zhdfptab(:,:,jm) = variable_2 (:,:,1,jl); jm = jm + 1  
     324         ! 
     325         ! and in this example the parameter ihdf_vars musb be changed to 8 (necessary for allocation) 
     326         !---------------------------------------------------------------------------------------- 
     327            DO jk = 1, nlay_i 
     328              zhdfptab(:,:,jm)=e_i(:,:,jk,jl); jm= jm+1 
     329            END DO 
     330         END DO 
    287331         ! 
    288332         !-------------------------------- 
    … …  
    290334         !-------------------------------- 
    291335         !                             ! Masked eddy diffusivity coefficient at ocean U- and V-points 
     336         !DO jj = 1, jpjm1                    ! NB: has not to be defined on jpj line and jpi row 
     337         !   DO ji = 1 , fs_jpim1   ! vector opt. 
     338         !      pahu(ji,jj) = ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -at_i(ji  ,jj) ) ) )   & 
     339         !         &        * ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -at_i(ji+1,jj) ) ) ) * ahiu(ji,jj) 
     340         !      pahv(ji,jj) = ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -at_i(ji,jj  ) ) ) )   & 
     341         !         &        * ( 1._wp - MAX( 0._wp, SIGN( 1._wp,- at_i(ji,jj+1) ) ) ) * ahiv(ji,jj) 
     342         !   END DO 
     343         !END DO 
     344          
    292345         DO jj = 1, jpjm1                    ! NB: has not to be defined on jpj line and jpi row 
    293346            DO ji = 1 , fs_jpim1   ! vector opt. 
    294                pahu(ji,jj) = ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -at_i(ji  ,jj) ) ) )   & 
    295                   &        * ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -at_i(ji+1,jj) ) ) ) * ahiu(ji,jj) 
    296                pahv(ji,jj) = ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -at_i(ji,jj  ) ) ) )   & 
    297                   &        * ( 1._wp - MAX( 0._wp, SIGN( 1._wp,- at_i(ji,jj+1) ) ) ) * ahiv(ji,jj) 
     347               pahu3D(ji,jj,jpl+1) = ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -at_i(ji  ,jj) ) ) )   & 
     348                  &                * ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -at_i(ji+1,jj) ) ) ) * ahiu(ji,jj) 
     349               pahv3D(ji,jj,jpl+1) = ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -at_i(ji,jj  ) ) ) )   & 
     350                  &                * ( 1._wp - MAX( 0._wp, SIGN( 1._wp,- at_i(ji,jj+1) ) ) ) * ahiv(ji,jj) 
    298351            END DO 
    299352         END DO 
    300353         ! 
    301          CALL lim_hdf( ato_i (:,:) ) 
    302  
    303          !------------------------------------ 
    304          !  Diffusion of other ice variables 
    305          !------------------------------------ 
    306          DO jl = 1, jpl 
    307          !                             ! Masked eddy diffusivity coefficient at ocean U- and V-points 
    308             DO jj = 1, jpjm1                 ! NB: has not to be defined on jpj line and jpi row 
    309                DO ji = 1 , fs_jpim1   ! vector opt. 
    310                   pahu(ji,jj) = ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -a_i(ji  ,jj,jl) ) ) )   & 
    311                      &        * ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -a_i(ji+1,jj,jl) ) ) ) * ahiu(ji,jj) 
    312                   pahv(ji,jj) = ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -a_i(ji,jj  ,jl) ) ) )   & 
    313                      &        * ( 1._wp - MAX( 0._wp, SIGN( 1._wp,- a_i(ji,jj+1,jl) ) ) ) * ahiv(ji,jj) 
    314                END DO 
    315             END DO 
    316  
    317             CALL lim_hdf( v_i  (:,:,  jl) ) 
    318             CALL lim_hdf( v_s  (:,:,  jl) ) 
    319             CALL lim_hdf( smv_i(:,:,  jl) ) 
    320             CALL lim_hdf( oa_i (:,:,  jl) ) 
    321             CALL lim_hdf( a_i  (:,:,  jl) ) 
    322             CALL lim_hdf( e_s  (:,:,1,jl) ) 
     354         zhdfptab(:,:,jm)= ato_i  (:,:); 
     355         CALL lim_hdf( zhdfptab, ihdf_vars, jpl, nlay_i)  
     356 
     357         jm=1 
     358         DO jl = 1, jpl 
     359            a_i  (:,:,  jl) = zhdfptab(:,:,jm); jm = jm + 1       
     360            v_i  (:,:,  jl) = zhdfptab(:,:,jm); jm = jm + 1  
     361            v_s  (:,:,  jl) = zhdfptab(:,:,jm); jm = jm + 1  
     362            smv_i(:,:,  jl) = zhdfptab(:,:,jm); jm = jm + 1  
     363            oa_i (:,:,  jl) = zhdfptab(:,:,jm); jm = jm + 1  
     364            e_s  (:,:,1,jl) = zhdfptab(:,:,jm); jm = jm + 1  
     365         ! Sample of adding more variables to apply lim_hdf--------- 
     366         !   variable_1  (:,:,1,jl) = zhdfptab(:,:, jm  ) ; jm + 1  
     367         !   variable_2  (:,:,1,jl) = zhdfptab(:,:, jm  ) ; jm + 1 
     368         !----------------------------------------------------------- 
    323369            DO jk = 1, nlay_i 
    324                CALL lim_hdf( e_i(:,:,jk,jl) ) 
    325             END DO 
    326          END DO 
     370               e_i(:,:,jk,jl) = zhdfptab(:,:,jm);jm= jm + 1  
     371            END DO 
     372         END DO 
     373 
     374         ato_i  (:,:) = zhdfptab(:,:,jm) 
    327375 
    328376         !------------------------------------------------------------------------------! 
    … …  
    422470            DO jj = 1, jpj 
    423471               DO ji = 1, jpi 
    424                   a_i(ji,jj,1)  = MIN( a_i(ji,jj,1), rn_amax ) 
     472                  a_i(ji,jj,1)  = MIN( a_i(ji,jj,1), rn_amax_2d(ji,jj) ) 
    425473               END DO 
    426474            END DO 
    … …  
    464512      CALL wrk_dealloc( jpi,jpj,nlay_i,jpl, z0ei ) 
    465513      CALL wrk_dealloc( jpi,jpj,jpl,        zviold, zvsold, zhimax, zsmvold ) 
     514      CALL wrk_dealloc( jpi,jpj,jpl*(ihdf_vars+nlay_i)+1,zhdfptab) 
    466515      ! 
    467516      IF( nn_timing == 1 )  CALL timing_stop('limtrp') 
    … …  
    479528   !!====================================================================== 
    480529END MODULE limtrp 
     530 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/LIM_SRC_3/limupdate1.F90

    r6836 r6839  
    8080         DO jj = 1, jpj 
    8181            DO ji = 1, jpi 
    82                IF( at_i(ji,jj) > rn_amax .AND. a_i(ji,jj,jl) > 0._wp ) THEN 
    83                   a_i (ji,jj,jl) = a_i (ji,jj,jl) * ( 1._wp - ( 1._wp - rn_amax / at_i(ji,jj) ) ) 
    84                   oa_i(ji,jj,jl) = oa_i(ji,jj,jl) * ( 1._wp - ( 1._wp - rn_amax / at_i(ji,jj) ) ) 
     82               IF( at_i(ji,jj) > rn_amax_2d(ji,jj) .AND. a_i(ji,jj,jl) > 0._wp ) THEN 
     83                  a_i (ji,jj,jl) = a_i (ji,jj,jl) * ( 1._wp - ( 1._wp - rn_amax_2d(ji,jj) / at_i(ji,jj) ) ) 
     84                  oa_i(ji,jj,jl) = oa_i(ji,jj,jl) * ( 1._wp - ( 1._wp - rn_amax_2d(ji,jj) / at_i(ji,jj) ) ) 
    8585               ENDIF 
    8686            END DO 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/LIM_SRC_3/limupdate2.F90

    r6836 r6839  
    9494         DO jj = 1, jpj 
    9595            DO ji = 1, jpi 
    96                IF( at_i(ji,jj) > rn_amax .AND. a_i(ji,jj,jl) > 0._wp ) THEN 
    97                   a_i (ji,jj,jl) = a_i (ji,jj,jl) * ( 1._wp - ( 1._wp - rn_amax / at_i(ji,jj) ) ) 
    98                   oa_i(ji,jj,jl) = oa_i(ji,jj,jl) * ( 1._wp - ( 1._wp - rn_amax / at_i(ji,jj) ) ) 
     96               IF( at_i(ji,jj) > rn_amax_2d(ji,jj) .AND. a_i(ji,jj,jl) > 0._wp ) THEN 
     97                  a_i (ji,jj,jl) = a_i (ji,jj,jl) * ( 1._wp - ( 1._wp - rn_amax_2d(ji,jj) / at_i(ji,jj) ) ) 
     98                  oa_i(ji,jj,jl) = oa_i(ji,jj,jl) * ( 1._wp - ( 1._wp - rn_amax_2d(ji,jj) / at_i(ji,jj) ) ) 
    9999               ENDIF 
    100100            END DO 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/LIM_SRC_3/limvar.F90

    r6836 r6839  
    163163               rswitch = MAX( 0._wp , SIGN( 1._wp, a_i(ji,jj,jl) - epsi20 ) )   !0 if no ice and 1 if yes 
    164164               ht_i(ji,jj,jl) = v_i (ji,jj,jl) / MAX( a_i(ji,jj,jl) , epsi20 ) * rswitch 
     165            END DO 
     166         END DO 
     167      END DO 
     168      ! Force the upper limit of ht_i to always be < hi_max (99 m). 
     169      DO jj = 1, jpj 
     170         DO ji = 1, jpi 
     171            rswitch = MAX( 0._wp , SIGN( 1._wp, ht_i(ji,jj,jpl) - epsi20 ) ) 
     172            ht_i(ji,jj,jpl) = MIN( ht_i(ji,jj,jpl) , hi_max(jpl) ) 
     173            a_i (ji,jj,jpl) = v_i(ji,jj,jpl) / MAX( ht_i(ji,jj,jpl) , epsi20 ) * rswitch 
     174         END DO 
     175      END DO 
     176 
     177      DO jl = 1, jpl 
     178         DO jj = 1, jpj 
     179            DO ji = 1, jpi 
     180               rswitch = MAX( 0._wp , SIGN( 1._wp, a_i(ji,jj,jl) - epsi20 ) )   !0 if no ice and 1 if yes 
    165181               ht_s(ji,jj,jl) = v_s (ji,jj,jl) / MAX( a_i(ji,jj,jl) , epsi20 ) * rswitch 
    166182               o_i(ji,jj,jl)  = oa_i(ji,jj,jl) / MAX( a_i(ji,jj,jl) , epsi20 ) * rswitch 
    … …  
    168184         END DO 
    169185      END DO 
    170  
     186       
    171187      IF(  nn_icesal == 2  )THEN 
    172188         DO jl = 1, jpl 
    … …  
    298314      ! Vertically constant, constant in time 
    299315      !--------------------------------------- 
    300       IF(  nn_icesal == 1  )   s_i(:,:,:,:) = rn_icesal 
     316      IF(  nn_icesal == 1  )  THEN 
     317         s_i (:,:,:,:) = rn_icesal 
     318         sm_i(:,:,:)   = rn_icesal 
     319      ENDIF 
    301320 
    302321      !----------------------------------- 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/LIM_SRC_3/limwri.F90

    r6836 r6839  
    157157      ENDIF 
    158158 
    159       IF ( iom_use( "icecolf" ) ) THEN  
    160          DO jj = 1, jpj 
    161             DO ji = 1, jpi 
    162                rswitch  = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) ) ) 
    163                z2d(ji,jj) = hicol(ji,jj) * rswitch 
    164             END DO 
    165          END DO 
    166          CALL iom_put( "icecolf"     , z2d              )        ! frazil ice collection thickness 
    167       ENDIF 
     159      IF ( iom_use( "icecolf" ) )   CALL iom_put( "icecolf", hicol )  ! frazil ice collection thickness 
    168160 
    169161      CALL iom_put( "isst"        , sst_m               )        ! sea surface temperature 
    … …  
    190182      CALL iom_put( "destrp"      , diag_trp_es         )        ! advected snw enthalpy (W/m2) 
    191183 
    192       CALL iom_put( "sfxbog"      , sfx_bog * rday      )        ! salt flux from brines 
    193       CALL iom_put( "sfxbom"      , sfx_bom * rday      )        ! salt flux from brines 
    194       CALL iom_put( "sfxsum"      , sfx_sum * rday      )        ! salt flux from brines 
    195       CALL iom_put( "sfxsni"      , sfx_sni * rday      )        ! salt flux from brines 
    196       CALL iom_put( "sfxopw"      , sfx_opw * rday      )        ! salt flux from brines 
     184      CALL iom_put( "sfxbog"      , sfx_bog * rday      )        ! salt flux from bottom growth 
     185      CALL iom_put( "sfxbom"      , sfx_bom * rday      )        ! salt flux from bottom melt 
     186      CALL iom_put( "sfxsum"      , sfx_sum * rday      )        ! salt flux from surface melt 
     187      CALL iom_put( "sfxsni"      , sfx_sni * rday      )        ! salt flux from snow ice formation 
     188      CALL iom_put( "sfxopw"      , sfx_opw * rday      )        ! salt flux from open water formation 
    197189      CALL iom_put( "sfxdyn"      , sfx_dyn * rday      )        ! salt flux from ridging rafting 
    198       CALL iom_put( "sfxres"      , sfx_res * rday      )        ! salt flux from limupdate (resultant) 
     190      CALL iom_put( "sfxres"      , sfx_res * rday      )        ! salt flux from residual 
    199191      CALL iom_put( "sfxbri"      , sfx_bri * rday      )        ! salt flux from brines 
     192      CALL iom_put( "sfxsub"      , sfx_sub * rday      )        ! salt flux from sublimation 
    200193      CALL iom_put( "sfx"         , sfx     * rday      )        ! total salt flux 
    201194 
    … …  
    235228      CALL iom_put ('hfxdhc'     , diag_heat(:,:)       )   ! Heat content variation in snow and ice  
    236229      CALL iom_put ('hfxspr'     , hfx_spr(:,:)         )   ! Heat content of snow precip  
     230 
     231 
     232      IF ( iom_use( "vfxthin" ) ) THEN   ! ice production for open water + thin ice (<20cm) => comparable to observations   
     233         DO jj = 1, jpj  
     234            DO ji = 1, jpi 
     235               z2d(ji,jj)  = vt_i(ji,jj) / MAX( at_i(ji,jj), epsi06 ) * zswi(ji,jj) ! mean ice thickness 
     236            END DO 
     237         END DO 
     238         WHERE( z2d(:,:) < 0.2 .AND. z2d(:,:) > 0. ) ; z2da = wfx_bog 
     239         ELSEWHERE                                   ; z2da = 0._wp 
     240         END WHERE 
     241         CALL iom_put( "vfxthin", ( wfx_opw + z2da ) * ztmp ) 
     242      ENDIF 
    237243       
    238244      !-------------------------------- 
    … …  
    311317      !! 
    312318      !! History : 
    313       !!   4.1  !  2013-06  (C. Rousset) 
     319      !!   4.0  !  2013-06  (C. Rousset) 
    314320      !!---------------------------------------------------------------------- 
    315321      INTEGER, INTENT( in ) ::   kt               ! ocean time-step index) 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/LIM_SRC_3/thd_ice.F90

    r6836 r6839  
    4545   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   qns_ice_1d   
    4646   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   t_bo_1d      
     47   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   rn_amax_1d 
    4748 
    4849   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   hfx_sum_1d 
    … …  
    8384   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   sfx_res_1d   
    8485 
     86   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   sfx_sub_1d 
     87 
    8588   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   sprecip_1d    !: <==> the 2D  sprecip 
    8689   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   frld_1d       !: <==> the 2D  frld 
    … …  
    9194   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   evap_ice_1d   !: <==> the 2D  evap_ice 
    9295   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   qprec_ice_1d  !: <==> the 2D  qprec_ice 
     96   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   qevap_ice_1d  !: <==> the 3D  qevap_ice 
    9397   !                                                     ! to reintegrate longwave flux inside the ice thermodynamics 
    9498   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   i0            !: fraction of radiation transmitted to the ice 
    … …  
    107111   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   dh_s_tot      !: Snow accretion/ablation        [m] 
    108112   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   dh_i_surf     !: Ice surface accretion/ablation [m] 
     113   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   dh_i_sub      !: Ice surface sublimation [m] 
    109114   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   dh_i_bott     !: Ice bottom accretion/ablation  [m] 
    110115   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   dh_snowice    !: Snow ice formation             [m of ice] 
    … …  
    144149         &      hfx_sum_1d(jpij) , hfx_bom_1d(jpij) ,hfx_bog_1d(jpij) ,    &  
    145150         &      hfx_dif_1d(jpij) , hfx_opw_1d(jpij) ,                      & 
     151         &      rn_amax_1d(jpij) ,                                         & 
    146152         &      hfx_thd_1d(jpij) , hfx_spr_1d(jpij) ,                      & 
    147153         &      hfx_snw_1d(jpij) , hfx_sub_1d(jpij) , hfx_err_1d(jpij) ,   & 
    … …  
    153159         &      wfx_sum_1d(jpij)  , wfx_sni_1d (jpij) , wfx_opw_1d (jpij) , wfx_res_1d(jpij) ,  & 
    154160         &      dqns_ice_1d(jpij) , evap_ice_1d (jpij),                                         & 
    155          &      qprec_ice_1d(jpij), i0         (jpij) ,                                         &   
     161         &      qprec_ice_1d(jpij), qevap_ice_1d(jpij), i0         (jpij) ,                     &   
    156162         &      sfx_bri_1d (jpij) , sfx_bog_1d (jpij) , sfx_bom_1d (jpij) , sfx_sum_1d (jpij),  & 
    157          &      sfx_sni_1d (jpij) , sfx_opw_1d (jpij) , sfx_res_1d (jpij) ,                     & 
     163         &      sfx_sni_1d (jpij) , sfx_opw_1d (jpij) , sfx_res_1d (jpij) , sfx_sub_1d (jpij),  & 
    158164         &      dsm_i_fl_1d(jpij) , dsm_i_gd_1d(jpij) , dsm_i_se_1d(jpij) ,                     &      
    159165         &      dsm_i_si_1d(jpij) , hicol_1d    (jpij)                     , STAT=ierr(2) ) 
    … …  
    161167      ALLOCATE( t_su_1d   (jpij) , a_i_1d   (jpij) , ht_i_1d  (jpij) ,    &    
    162168         &      ht_s_1d   (jpij) , fc_su    (jpij) , fc_bo_i  (jpij) ,    &     
    163          &      dh_s_tot  (jpij) , dh_i_surf(jpij) , dh_i_bott(jpij) ,    &     
    164          &      dh_snowice(jpij) , sm_i_1d  (jpij) , s_i_new  (jpij) ,    & 
     169         &      dh_s_tot  (jpij) , dh_i_surf(jpij) , dh_i_sub (jpij) ,    &     
     170         &      dh_i_bott (jpij) ,dh_snowice(jpij) , sm_i_1d  (jpij) , s_i_new  (jpij) ,    & 
    165171         &      t_s_1d(jpij,nlay_s) , t_i_1d(jpij,nlay_i) , s_i_1d(jpij,nlay_i) ,  &             
    166172         &      q_i_1d(jpij,nlay_i+1) , q_s_1d(jpij,nlay_s) ,                        & 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/NST_SRC/agrif2model.F90

    r6836 r6839  
    11#if defined key_agrif 
    2    !!---------------------------------------------------------------------- 
    3    !! NEMO/NST 3.3 , NEMO Consortium (2010) 
    4    !! $Id$ 
    5    !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
    6    !!---------------------------------------------------------------------- 
    7    SUBROUTINE Agrif2Model 
    8       !!--------------------------------------------- 
    9       !!   *** ROUTINE Agrif2Model *** 
    10       !!---------------------------------------------  
    11    END SUBROUTINE Agrif2model 
     2!!---------------------------------------------------------------------- 
     3!! NEMO/NST 3.6 , NEMO Consortium (2010) 
     4!! $Id$ 
     5!! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
     6!!---------------------------------------------------------------------- 
     7SUBROUTINE Agrif2Model 
     8   !!--------------------------------------------- 
     9   !!   *** ROUTINE Agrif2Model *** 
     10   !!---------------------------------------------  
     11END SUBROUTINE Agrif2model 
    1212 
    13    SUBROUTINE Agrif_Set_numberofcells(Agrif_Gr) 
    14       !!--------------------------------------------- 
    15       !!   *** ROUTINE Agrif_Set_numberofcells *** 
    16       !!---------------------------------------------  
    17       USE Agrif_Types 
    18       IMPLICIT NONE 
     13SUBROUTINE Agrif_Set_numberofcells(Agrif_Gr) 
     14   !!--------------------------------------------- 
     15   !!   *** ROUTINE Agrif_Set_numberofcells *** 
     16   !!---------------------------------------------  
     17   USE Agrif_Grids 
     18   IMPLICIT NONE 
    1919 
    20       Type(Agrif_Grid), Pointer :: Agrif_Gr 
     20   TYPE(Agrif_Grid), POINTER :: Agrif_Gr 
    2121 
    22       IF ( associated(Agrif_Curgrid) )THEN 
     22   IF ( ASSOCIATED(Agrif_Curgrid) )THEN 
    2323#include "SetNumberofcells.h" 
    24       ENDIF 
     24   ENDIF 
    2525 
    26    END SUBROUTINE Agrif_Set_numberofcells 
     26END SUBROUTINE Agrif_Set_numberofcells 
    2727 
    28    SUBROUTINE Agrif_Get_numberofcells(Agrif_Gr) 
    29       !!--------------------------------------------- 
    30       !!   *** ROUTINE Agrif_Get_numberofcells *** 
    31       !!---------------------------------------------  
    32       USE Agrif_Types 
    33       IMPLICIT NONE 
     28SUBROUTINE Agrif_Get_numberofcells(Agrif_Gr) 
     29   !!--------------------------------------------- 
     30   !!   *** ROUTINE Agrif_Get_numberofcells *** 
     31   !!---------------------------------------------  
     32   USE Agrif_Grids 
     33   IMPLICIT NONE 
    3434 
    35       Type(Agrif_Grid), Pointer :: Agrif_Gr 
     35   TYPE(Agrif_Grid), POINTER :: Agrif_Gr 
    3636 
     37   IF ( ASSOCIATED(Agrif_Curgrid) ) THEN 
    3738#include "GetNumberofcells.h" 
     39   ENDIF 
    3840 
    39    END SUBROUTINE Agrif_Get_numberofcells 
     41END SUBROUTINE Agrif_Get_numberofcells 
    4042 
    41    SUBROUTINE Agrif_Allocationcalls(Agrif_Gr) 
    42       !!--------------------------------------------- 
    43       !!   *** ROUTINE Agrif_Allocationscalls *** 
    44       !!---------------------------------------------  
    45       USE Agrif_Types  
     43SUBROUTINE Agrif_Allocationcalls(Agrif_Gr) 
     44   !!--------------------------------------------- 
     45   !!   *** ROUTINE Agrif_Allocationscalls *** 
     46   !!---------------------------------------------  
     47   USE Agrif_Grids  
    4648#include "include_use_Alloc_agrif.h" 
    47       IMPLICIT NONE 
     49   IMPLICIT NONE 
    4850 
    49       Type(Agrif_Grid), Pointer :: Agrif_Gr 
     51   TYPE(Agrif_Grid), POINTER :: Agrif_Gr 
    5052 
    5153#include "allocations_calls_agrif.h" 
    5254 
    53    END SUBROUTINE Agrif_Allocationcalls 
     55END SUBROUTINE Agrif_Allocationcalls 
    5456 
    55    SUBROUTINE Agrif_probdim_modtype_def() 
    56       !!--------------------------------------------- 
    57       !!   *** ROUTINE Agrif_probdim_modtype_def *** 
    58       !!---------------------------------------------  
    59       USE Agrif_Types 
    60       IMPLICIT NONE 
     57SUBROUTINE Agrif_probdim_modtype_def() 
     58   !!--------------------------------------------- 
     59   !!   *** ROUTINE Agrif_probdim_modtype_def *** 
     60   !!---------------------------------------------  
     61   USE Agrif_Types 
     62   IMPLICIT NONE 
    6163 
    6264#include "modtype_agrif.h" 
    … …  
    6466#include "keys_agrif.h" 
    6567 
    66       Return 
     68   RETURN 
    6769 
    68    END SUBROUTINE Agrif_probdim_modtype_def 
     70END SUBROUTINE Agrif_probdim_modtype_def 
    6971 
    70    SUBROUTINE Agrif_clustering_def() 
    71       !!--------------------------------------------- 
    72       !!   *** ROUTINE Agrif_clustering_def *** 
    73       !!---------------------------------------------  
    74       Use Agrif_Types 
    75       IMPLICIT NONE 
     72SUBROUTINE Agrif_clustering_def() 
     73   !!--------------------------------------------- 
     74   !!   *** ROUTINE Agrif_clustering_def *** 
     75   !!---------------------------------------------  
     76   IMPLICIT NONE 
    7677 
    77       Return 
     78   RETURN 
    7879 
    79    END SUBROUTINE Agrif_clustering_def 
     80END SUBROUTINE Agrif_clustering_def 
    8081 
    81    SUBROUTINE Agrif_comm_def(modelcomm) 
    82  
    83       !!--------------------------------------------- 
    84       !!   *** ROUTINE Agrif_clustering_def *** 
    85       !!---------------------------------------------  
    86       Use Agrif_Types 
    87       Use lib_mpp 
    88  
    89       IMPLICIT NONE 
    90  
    91       INTEGER :: modelcomm 
    92  
    93 #if defined key_mpp_mpi 
    94       modelcomm = mpi_comm_opa 
     82#else 
     83SUBROUTINE Agrif2Model 
     84   !!--------------------------------------------- 
     85   !!   *** ROUTINE Agrif2Model *** 
     86   !!---------------------------------------------  
     87   WRITE(*,*) 'Impossible to bet here' 
     88END SUBROUTINE Agrif2model 
    9589#endif 
    96       Return 
    97  
    98    END SUBROUTINE Agrif_comm_def 
    99 #else 
    100    SUBROUTINE Agrif2Model 
    101       !!--------------------------------------------- 
    102       !!   *** ROUTINE Agrif2Model *** 
    103       !!---------------------------------------------  
    104       WRITE(*,*) 'Impossible to bet here' 
    105    END SUBROUTINE Agrif2model 
    106 #endif 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/NST_SRC/agrif_lim2_interp.F90

    r6836 r6839  
    99   !!            3.4   !  09-2012  (R. Benshila, C. Herbaut) update and EVP 
    1010   !!---------------------------------------------------------------------- 
    11 #if defined key_agrif && defined key_lim2 
     11#if defined key_agrif && defined key_lim2  
    1212   !!---------------------------------------------------------------------- 
    1313   !!   'key_lim2'  :                                 LIM 2.0 sea-ice model 
    … …  
    4141   PUBLIC interp_adv_ice 
    4242 
     43   REAL(wp), DIMENSION(:,:)  , ALLOCATABLE, PRIVATE :: uice_agr, vice_agr 
     44   REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, PRIVATE :: tabice_agr  
     45 
     46 
    4347   !!---------------------------------------------------------------------- 
    4448   !! NEMO/NST 3.4 , NEMO Consortium (2012) 
    … …  
    6569      u_ice_nst(:,:) = 0. 
    6670      v_ice_nst(:,:) = 0. 
    67       CALL Agrif_Bc_variable( u_ice_nst, u_ice_id ,procname=interp_u_ice, calledweight=1. ) 
    68       CALL Agrif_Bc_variable( v_ice_nst, v_ice_id ,procname=interp_v_ice, calledweight=1. ) 
     71      CALL Agrif_Bc_variable( u_ice_id ,procname=interp_u_ice, calledweight=1. ) 
     72      CALL Agrif_Bc_variable( v_ice_id ,procname=interp_v_ice, calledweight=1. ) 
    6973      Agrif_SpecialValue=0. 
    7074      Agrif_UseSpecialValue = .FALSE. 
    … …  
    138142      !!  we are in inside a new parent ice time step 
    139143      !!----------------------------------------------------------------------- 
    140       REAL(wp), DIMENSION(jpi,jpj) :: zuice, zvice 
    141144      INTEGER :: ji,jj 
    142145      REAL(wp) :: zrhox, zrhoy 
    … …  
    155158         Agrif_SpecialValue=-9999. 
    156159         Agrif_UseSpecialValue = .TRUE. 
    157          zuice = 0. 
    158          zvice = 0. 
    159          CALL Agrif_Bc_variable(zuice,u_ice_id,procname=interp_u_ice, calledweight=1.) 
    160          CALL Agrif_Bc_variable(zvice,v_ice_id,procname=interp_v_ice, calledweight=1.) 
     160         IF( .NOT. ALLOCATED(uice_agr) )THEN 
     161            ALLOCATE(uice_agr(jpi,jpj), vice_agr(jpi,jpj)) 
     162         ENDIF 
     163         uice_agr = 0. 
     164         vice_agr = 0. 
     165         CALL Agrif_Bc_variable(u_ice_id,procname=interp_u_ice, calledweight=1.) 
     166         CALL Agrif_Bc_variable(v_ice_id,procname=interp_v_ice, calledweight=1.) 
    161167         Agrif_SpecialValue=0. 
    162168         Agrif_UseSpecialValue = .FALSE. 
    163169         !   
    164170         zrhox = agrif_rhox() ;    zrhoy = agrif_rhoy()       
    165          zuice(:,:) =  zuice(:,:)/(zrhoy*e2u(:,:))*umask(:,:,1) 
    166          zvice(:,:) =  zvice(:,:)/(zrhox*e1v(:,:))*vmask(:,:,1) 
     171         uice_agr(:,:) =  uice_agr(:,:)/(zrhoy*e2u(:,:))*umask(:,:,1) 
     172         vice_agr(:,:) =  vice_agr(:,:)/(zrhox*e1v(:,:))*vmask(:,:,1) 
    167173         ! fill  boundaries 
    168174         DO jj = 1, jpj 
    169175            DO ji = 1, 2 
    170                u_ice_oe(ji,  jj,2) = zuice(ji       ,jj)  
    171                u_ice_oe(ji+2,jj,2) = zuice(nlci+ji-3,jj) 
     176               u_ice_oe(ji,  jj,2) = uice_agr(ji       ,jj)  
     177               u_ice_oe(ji+2,jj,2) = uice_agr(nlci+ji-3,jj) 
    172178            END DO 
    173179         END DO 
    174180         DO jj = 1, jpj 
    175             v_ice_oe(2,jj,2) = zvice(2     ,jj)  
    176             v_ice_oe(4,jj,2) = zvice(nlci-1,jj) 
     181            v_ice_oe(2,jj,2) = vice_agr(2     ,jj)  
     182            v_ice_oe(4,jj,2) = vice_agr(nlci-1,jj) 
    177183         END DO 
    178184         DO ji = 1, jpi 
    179             u_ice_sn(ji,2,2) = zuice(ji,2     )  
    180             u_ice_sn(ji,4,2) = zuice(ji,nlcj-1) 
     185            u_ice_sn(ji,2,2) = uice_agr(ji,2     )  
     186            u_ice_sn(ji,4,2) = uice_agr(ji,nlcj-1) 
    181187         END DO 
    182188         DO jj = 1, 2 
    183189            DO ji = 1, jpi 
    184                v_ice_sn(ji,jj  ,2) = zvice(ji,jj       )  
    185                v_ice_sn(ji,jj+2,2) = zvice(ji,nlcj+jj-3) 
     190               v_ice_sn(ji,jj  ,2) = vice_agr(ji,jj       )  
     191               v_ice_sn(ji,jj+2,2) = vice_agr(ji,nlcj+jj-3) 
    186192            END DO 
    187193         END DO 
    … …  
    334340      !!  we are in inside a new parent ice time step 
    335341     !!----------------------------------------------------------------------- 
    336       REAL(wp), DIMENSION(jpi,jpj,7) :: ztab  
    337342      INTEGER :: ji,jj,jn 
    338343      !!----------------------------------------------------------------------- 
    … …  
    345350         adv_ice_sn(:,:,:,1) =  adv_ice_sn(:,:,:,2) 
    346351         ! interpolation of boundaries 
    347          ztab(:,:,:) = 0. 
     352         IF(.NOT.ALLOCATED(tabice_agr))THEN 
     353            ALLOCATE(tabice_agr(jpi,jpj,7))    
     354         ENDIF 
     355         tabice_agr(:,:,:) = 0. 
    348356         Agrif_SpecialValue=-9999. 
    349357         Agrif_UseSpecialValue = .TRUE. 
    350          CALL Agrif_Bc_variable( ztab, adv_ice_id ,procname=interp_adv_ice,calledweight=1. ) 
     358         CALL Agrif_Bc_variable( adv_ice_id ,procname=interp_adv_ice,calledweight=1. ) 
    351359         Agrif_SpecialValue=0. 
    352360         Agrif_UseSpecialValue = .FALSE. 
    … …  
    356364            DO jj = 1, jpj 
    357365               DO ji=1,2 
    358                   adv_ice_oe(ji  ,jj,jn,2) = ztab(ji       ,jj,jn)  
    359                   adv_ice_oe(ji+2,jj,jn,2) = ztab(nlci-2+ji,jj,jn) 
     366                  adv_ice_oe(ji  ,jj,jn,2) = tabice_agr(ji       ,jj,jn)  
     367                  adv_ice_oe(ji+2,jj,jn,2) = tabice_agr(nlci-2+ji,jj,jn) 
    360368               END DO 
    361369            END DO 
    … …  
    365373            Do jj =1,2 
    366374               DO ji = 1, jpi 
    367                   adv_ice_sn(ji,jj  ,jn,2) = ztab(ji,jj       ,jn)  
    368                   adv_ice_sn(ji,jj+2,jn,2) = ztab(ji,nlcj-2+jj,jn) 
     375                  adv_ice_sn(ji,jj  ,jn,2) = tabice_agr(ji,jj       ,jn)  
     376                  adv_ice_sn(ji,jj+2,jn,2) = tabice_agr(ji,nlcj-2+jj,jn) 
    369377               END DO 
    370378            END DO 
    … …  
    384392      INTEGER :: ji,jj,jn 
    385393      REAL(wp) :: zalpha 
    386       REAL(wp), DIMENSION(jpi,jpj,7) :: ztab  
     394      REAL(wp), DIMENSION(jpi,jpj,7) :: tabice_agr  
    387395      !!-----------------------------------------------------------------------       
    388396      ! 
    … …  
    391399      zalpha = REAL(lim_nbstep,wp) / (Agrif_Rhot()*Agrif_PArent(nn_fsbc)/REAL(nn_fsbc)) 
    392400      ! 
    393       ztab(:,:,:) = 0.e0 
     401      tabice_agr(:,:,:) = 0.e0 
    394402      DO jn =1,7 
    395403         DO jj =1,2 
    396404            DO ji = 1, jpi 
    397                ztab(ji,jj        ,jn) = (1-zalpha)*adv_ice_sn(ji,jj  ,jn,1) + zalpha*adv_ice_sn(ji,jj  ,jn,2)  
    398                ztab(ji,nlcj-2+jj ,jn) = (1-zalpha)*adv_ice_sn(ji,jj+2,jn,1) + zalpha*adv_ice_sn(ji,jj+2,jn,2)  
     405               tabice_agr(ji,jj        ,jn) = (1-zalpha)*adv_ice_sn(ji,jj  ,jn,1) + zalpha*adv_ice_sn(ji,jj  ,jn,2)  
     406               tabice_agr(ji,nlcj-2+jj ,jn) = (1-zalpha)*adv_ice_sn(ji,jj+2,jn,1) + zalpha*adv_ice_sn(ji,jj+2,jn,2)  
    399407            END DO 
    400408         END DO 
    … …  
    404412         DO jj = 1, jpj 
    405413            DO ji=1,2 
    406                ztab(ji       ,jj,jn) = (1-zalpha)*adv_ice_oe(ji  ,jj,jn,1) + zalpha*adv_ice_oe(ji  ,jj,jn,2)  
    407                ztab(nlci-2+ji,jj,jn) = (1-zalpha)*adv_ice_oe(ji+2,jj,jn,1) + zalpha*adv_ice_oe(ji+2,jj,jn,2)  
     414               tabice_agr(ji       ,jj,jn) = (1-zalpha)*adv_ice_oe(ji  ,jj,jn,1) + zalpha*adv_ice_oe(ji  ,jj,jn,2)  
     415               tabice_agr(nlci-2+ji,jj,jn) = (1-zalpha)*adv_ice_oe(ji+2,jj,jn,1) + zalpha*adv_ice_oe(ji+2,jj,jn,2)  
    408416            END DO 
    409417         END DO 
    410418      END DO 
    411419      ! 
    412       CALL parcoursT( ztab(:,:, 1), frld  ) 
    413       CALL parcoursT( ztab(:,:, 2), hicif ) 
    414       CALL parcoursT( ztab(:,:, 3), hsnif ) 
    415       CALL parcoursT( ztab(:,:, 4), tbif(:,:,1) ) 
    416       CALL parcoursT( ztab(:,:, 5), tbif(:,:,2) ) 
    417       CALL parcoursT( ztab(:,:, 6), tbif(:,:,3) ) 
    418       CALL parcoursT( ztab(:,:, 7), qstoif ) 
     420      CALL parcoursT( tabice_agr(:,:, 1), frld  ) 
     421      CALL parcoursT( tabice_agr(:,:, 2), hicif ) 
     422      CALL parcoursT( tabice_agr(:,:, 3), hsnif ) 
     423      CALL parcoursT( tabice_agr(:,:, 4), tbif(:,:,1) ) 
     424      CALL parcoursT( tabice_agr(:,:, 5), tbif(:,:,2) ) 
     425      CALL parcoursT( tabice_agr(:,:, 6), tbif(:,:,3) ) 
     426      CALL parcoursT( tabice_agr(:,:, 7), qstoif ) 
    419427      ! 
    420428   END SUBROUTINE agrif_trp_lim2 
    … …  
    499507 
    500508 
    501    SUBROUTINE interp_u_ice( tabres, i1, i2, j1, j2 ) 
     509   SUBROUTINE interp_u_ice( tabres, i1, i2, j1, j2, before ) 
    502510      !!----------------------------------------------------------------------- 
    503511      !!                     *** ROUTINE interp_u_ice *** 
    … …  
    505513      INTEGER, INTENT(in) :: i1, i2, j1, j2 
    506514      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 
     515      LOGICAL, INTENT(in) :: before 
    507516      !! 
    508517      INTEGER :: ji,jj 
    … …  
    510519      ! 
    511520#if defined key_lim2_vp 
    512       DO jj=MAX(j1,2),j2 
    513          DO ji=MAX(i1,2),i2 
    514             IF( tmu(ji,jj) == 0. ) THEN 
    515                tabres(ji,jj) = -9999. 
    516             ELSE 
    517                tabres(ji,jj) = e2f(ji-1,jj-1) * u_ice(ji,jj) 
    518             ENDIF 
    519          END DO 
    520       END DO 
     521      IF( before ) THEN 
     522         DO jj=MAX(j1,2),j2 
     523            DO ji=MAX(i1,2),i2 
     524               IF( tmu(ji,jj) == 0. ) THEN 
     525                  tabres(ji,jj) = -9999. 
     526               ELSE 
     527                  tabres(ji,jj) = e2f(ji-1,jj-1) * u_ice(ji,jj) 
     528               ENDIF 
     529            END DO 
     530         END DO 
     531      ENDIF 
    521532#else 
    522       DO jj= j1, j2 
    523          DO ji= i1, i2 
    524             IF( umask(ji,jj,1) == 0. ) THEN 
    525                tabres(ji,jj) = -9999. 
    526             ELSE 
    527                tabres(ji,jj) = e2u(ji,jj) * u_ice(ji,jj) 
    528             ENDIF 
    529          END DO 
    530       END DO 
     533      IF( before ) THEN 
     534         DO jj= j1, j2 
     535            DO ji= i1, i2 
     536               IF( umask(ji,jj,1) == 0. ) THEN 
     537                  tabres(ji,jj) = -9999. 
     538               ELSE 
     539                  tabres(ji,jj) = e2u(ji,jj) * u_ice(ji,jj) 
     540               ENDIF 
     541            END DO 
     542         END DO 
     543      ENDIF 
    531544#endif 
    532545   END SUBROUTINE interp_u_ice 
    533546 
    534547 
    535    SUBROUTINE interp_v_ice( tabres, i1, i2, j1, j2 ) 
     548   SUBROUTINE interp_v_ice( tabres, i1, i2, j1, j2, before ) 
    536549      !!----------------------------------------------------------------------- 
    537550      !!                    *** ROUTINE interp_v_ice *** 
    … …  
    539552      INTEGER, INTENT(in) :: i1, i2, j1, j2 
    540553      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 
     554      LOGICAL, INTENT(in) :: before 
    541555      !! 
    542556      INTEGER :: ji, jj 
    … …  
    544558      ! 
    545559#if defined key_lim2_vp 
    546       DO jj=MAX(j1,2),j2 
    547          DO ji=MAX(i1,2),i2 
    548             IF( tmu(ji,jj) == 0. ) THEN 
    549                tabres(ji,jj) = -9999. 
    550             ELSE 
    551                tabres(ji,jj) = e1f(ji-1,jj-1) * v_ice(ji,jj) 
    552             ENDIF 
    553          END DO 
    554       END DO 
     560      IF( before ) THEN 
     561         DO jj=MAX(j1,2),j2 
     562            DO ji=MAX(i1,2),i2 
     563               IF( tmu(ji,jj) == 0. ) THEN 
     564                  tabres(ji,jj) = -9999. 
     565               ELSE 
     566                  tabres(ji,jj) = e1f(ji-1,jj-1) * v_ice(ji,jj) 
     567               ENDIF 
     568            END DO 
     569         END DO 
     570      ENDIF    
    555571#else 
    556       DO jj= j1 ,j2 
    557          DO ji = i1, i2 
    558             IF( vmask(ji,jj,1) == 0. ) THEN 
    559                tabres(ji,jj) = -9999. 
    560             ELSE 
    561                tabres(ji,jj) = e1v(ji,jj) * v_ice(ji,jj) 
    562             ENDIF 
    563          END DO 
    564       END DO 
     572      IF( before ) THEN 
     573         DO jj= j1 ,j2 
     574            DO ji = i1, i2 
     575               IF( vmask(ji,jj,1) == 0. ) THEN 
     576                  tabres(ji,jj) = -9999. 
     577               ELSE 
     578                  tabres(ji,jj) = e1v(ji,jj) * v_ice(ji,jj) 
     579               ENDIF 
     580            END DO 
     581         END DO 
     582      ENDIF 
    565583#endif 
    566584   END SUBROUTINE interp_v_ice 
    567585 
    568586 
    569    SUBROUTINE interp_adv_ice( tabres, i1, i2, j1, j2 ) 
     587   SUBROUTINE interp_adv_ice( tabres, i1, i2, j1, j2, before ) 
    570588      !!----------------------------------------------------------------------- 
    571589      !!                    *** ROUTINE interp_adv_ice ***                            
    … …  
    577595      INTEGER, INTENT(in) :: i1, i2, j1, j2 
    578596      REAL(wp), DIMENSION(i1:i2,j1:j2,7), INTENT(inout) :: tabres 
     597      LOGICAL, INTENT(in) :: before 
    579598      !! 
    580599      INTEGER :: ji, jj, jk 
    581600      !!----------------------------------------------------------------------- 
    582601      ! 
    583       DO jj=j1,j2 
    584          DO ji=i1,i2 
    585             IF( tms(ji,jj) == 0. ) THEN 
    586                tabres(ji,jj,:) = -9999.  
    587             ELSE 
    588                tabres(ji,jj, 1) = frld  (ji,jj) 
    589                tabres(ji,jj, 2) = hicif (ji,jj) 
    590                tabres(ji,jj, 3) = hsnif (ji,jj) 
    591                tabres(ji,jj, 4) = tbif  (ji,jj,1) 
    592                tabres(ji,jj, 5) = tbif  (ji,jj,2) 
    593                tabres(ji,jj, 6) = tbif  (ji,jj,3) 
    594                tabres(ji,jj, 7) = qstoif(ji,jj) 
    595             ENDIF 
    596          END DO 
    597       END DO 
     602      IF( before ) THEN 
     603         DO jj=j1,j2 
     604            DO ji=i1,i2 
     605               IF( tms(ji,jj) == 0. ) THEN 
     606                  tabres(ji,jj,:) = -9999.  
     607               ELSE 
     608                  tabres(ji,jj, 1) = frld  (ji,jj) 
     609                  tabres(ji,jj, 2) = hicif (ji,jj) 
     610                  tabres(ji,jj, 3) = hsnif (ji,jj) 
     611                  tabres(ji,jj, 4) = tbif  (ji,jj,1) 
     612                  tabres(ji,jj, 5) = tbif  (ji,jj,2) 
     613                  tabres(ji,jj, 6) = tbif  (ji,jj,3) 
     614                  tabres(ji,jj, 7) = qstoif(ji,jj) 
     615               ENDIF 
     616            END DO 
     617         END DO 
     618      ENDIF 
    598619      ! 
    599620   END SUBROUTINE interp_adv_ice 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/NST_SRC/agrif_lim2_update.F90

    r6836 r6839  
    5252      INTEGER, INTENT(in) :: kt 
    5353      !! 
    54       REAL(wp), DIMENSION(jpi,jpj)  :: zvel 
    55       REAL(wp), DIMENSION(jpi,jpj,7):: zadv 
    5654      !!---------------------------------------------------------------------- 
    5755      ! 
    … …  
    6058      Agrif_UseSpecialValueInUpdate = .TRUE. 
    6159      Agrif_SpecialValueFineGrid = 0. 
    62  
    6360# if defined TWO_WAY 
    6461      IF( MOD(nbcline,nbclineupdate) == 0) THEN 
    65          CALL Agrif_Update_Variable( zadv , adv_ice_id , procname = update_adv_ice  ) 
    66          CALL Agrif_Update_Variable( zvel , u_ice_id   , procname = update_u_ice    ) 
    67          CALL Agrif_Update_Variable( zvel , v_ice_id   , procname = update_v_ice    ) 
    68       ELSE 
    69          CALL Agrif_Update_Variable( zadv , adv_ice_id , locupdate=(/0,2/), procname = update_adv_ice  ) 
    70          CALL Agrif_Update_Variable( zvel , u_ice_id   , locupdate=(/0,1/), procname = update_u_ice    ) 
    71          CALL Agrif_Update_Variable( zvel , v_ice_id   , locupdate=(/0,1/), procname = update_v_ice    ) 
     62         CALL Agrif_Update_Variable( adv_ice_id , procname = update_adv_ice  ) 
     63         CALL Agrif_Update_Variable( u_ice_id   , procname = update_u_ice    ) 
     64         CALL Agrif_Update_Variable( v_ice_id   , procname = update_v_ice    ) 
     65      ELSE 
     66         CALL Agrif_Update_Variable( adv_ice_id , locupdate=(/0,2/), procname = update_adv_ice  ) 
     67         CALL Agrif_Update_Variable( u_ice_id   , locupdate=(/0,1/), procname = update_u_ice    ) 
     68         CALL Agrif_Update_Variable( v_ice_id   , locupdate=(/0,1/), procname = update_v_ice    ) 
    7269      ENDIF 
    7370# endif 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/NST_SRC/agrif_oce.F90

    r6836 r6839  
    1212   USE par_oce      ! ocean parameters 
    1313   USE dom_oce      ! domain parameters 
    14     
     14 
    1515   IMPLICIT NONE 
    1616   PRIVATE  
    … …  
    1919 
    2020   !                                              !!* Namelist namagrif: AGRIF parameters 
    21    LOGICAL , PUBLIC ::   ln_spc_dyn      !: 
    22    INTEGER , PUBLIC ::   nn_cln_update   !: update frequency  
    23    REAL(wp), PUBLIC ::   rn_sponge_tra   !: sponge coeff. for tracers 
    24    REAL(wp), PUBLIC ::   rn_sponge_dyn   !: sponge coeff. for dynamics 
     21   LOGICAL , PUBLIC ::   ln_spc_dyn    = .FALSE.   !: 
     22   INTEGER , PUBLIC ::   nn_cln_update = 3         !: update frequency  
     23   INTEGER , PUBLIC, PARAMETER ::   nn_sponge_len = 2  !: Sponge width (in number of parent grid points) 
     24   REAL(wp), PUBLIC ::   rn_sponge_tra = 2800.     !: sponge coeff. for tracers 
     25   REAL(wp), PUBLIC ::   rn_sponge_dyn = 2800.     !: sponge coeff. for dynamics 
     26   LOGICAL , PUBLIC ::   ln_chk_bathy  = .FALSE.   !: check of parent bathymetry  
    2527 
    2628   !                                              !!! OLD namelist names 
    … …  
    3032   REAL(wp), PUBLIC ::   visc_dyn                  !: sponge coeff. for dynamics 
    3133 
    32    LOGICAL , PUBLIC :: spongedoneT = .FALSE.   !: tracer   sponge layer indicator 
    33    LOGICAL , PUBLIC :: spongedoneU = .FALSE.   !: dynamics sponge layer indicator 
    34    LOGICAL , PUBLIC :: lk_agrif_fstep = .TRUE. !: if true: first step 
     34   LOGICAL , PUBLIC :: spongedoneT = .FALSE.       !: tracer   sponge layer indicator 
     35   LOGICAL , PUBLIC :: spongedoneU = .FALSE.       !: dynamics sponge layer indicator 
     36   LOGICAL , PUBLIC :: lk_agrif_fstep = .TRUE.     !: if true: first step 
     37   LOGICAL , PUBLIC :: lk_agrif_doupd = .TRUE.     !: if true: send update from current grid 
     38   LOGICAL , PUBLIC :: lk_agrif_debug = .FALSE.    !: if true: print debugging info 
    3539 
    36    REAL(wp), PUBLIC, ALLOCATABLE, SAVE,  DIMENSION(:,:) ::   spe1ur , spe2vr , spbtr2   !: ??? 
    37    REAL(wp), PUBLIC, ALLOCATABLE, SAVE,  DIMENSION(:,:) ::   spe1ur2, spe2vr2, spbtr3   !: ??? 
    38     
    39    INTEGER :: tsn_id,tsb_id,tsa_id 
    40    INTEGER :: un_id, vn_id, ua_id, va_id 
    41    INTEGER :: e1u_id, e2v_id, sshn_id, gcb_id 
    42    INTEGER :: trn_id, trb_id, tra_id 
    43    INTEGER :: unb_id, vnb_id, ub2b_id, vb2b_id 
     40   LOGICAL , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tabspongedone_tsn 
     41# if defined key_top 
     42   LOGICAL , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tabspongedone_trn 
     43# endif 
     44   LOGICAL , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tabspongedone_u 
     45   LOGICAL , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tabspongedone_v 
     46   REAL(wp), PUBLIC, ALLOCATABLE, SAVE,  DIMENSION(:,:) :: fsaht_spu, fsaht_spv !: sponge diffusivities 
     47   REAL(wp), PUBLIC, ALLOCATABLE, SAVE,  DIMENSION(:,:) :: fsahm_spt, fsahm_spf !: sponge viscosities 
     48 
     49   ! Barotropic arrays used to store open boundary data during 
     50   ! time-splitting loop: 
     51   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) ::  ubdy_w, vbdy_w, hbdy_w 
     52   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) ::  ubdy_e, vbdy_e, hbdy_e 
     53   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) ::  ubdy_n, vbdy_n, hbdy_n 
     54   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) ::  ubdy_s, vbdy_s, hbdy_s 
     55 
     56   INTEGER :: tsn_id                                                  ! AGRIF profile for tracers interpolation and update 
     57   INTEGER :: un_interp_id, vn_interp_id                              ! AGRIF profiles for interpolations 
     58   INTEGER :: un_update_id, vn_update_id                              ! AGRIF profiles for udpates 
     59   INTEGER :: tsn_sponge_id, un_sponge_id, vn_sponge_id               ! AGRIF profiles for sponge layers 
     60# if defined key_top 
     61   INTEGER :: trn_id, trn_sponge_id 
     62# endif   
     63   INTEGER :: unb_id, vnb_id, ub2b_interp_id, vb2b_interp_id 
     64   INTEGER :: ub2b_update_id, vb2b_update_id 
     65   INTEGER :: e3t_id, e1u_id, e2v_id, sshn_id 
     66   INTEGER :: scales_t_id 
     67# if defined key_zdftke 
     68   INTEGER :: avt_id, avm_id, en_id 
     69# endif   
     70   INTEGER :: umsk_id, vmsk_id 
     71   INTEGER :: kindic_agr 
    4472 
    4573   !!---------------------------------------------------------------------- 
    … …  
    5482      !!                ***  FUNCTION agrif_oce_alloc  *** 
    5583      !!---------------------------------------------------------------------- 
    56       ALLOCATE( spe1ur (jpi,jpj) , spe2vr (jpi,jpj) , spbtr2(jpi,jpj) ,      & 
    57          &      spe1ur2(jpi,jpj) , spe2vr2(jpi,jpj) , spbtr3(jpi,jpj) , STAT = agrif_oce_alloc )  
     84      INTEGER, DIMENSION(2) :: ierr 
     85      !!---------------------------------------------------------------------- 
     86      ierr(:) = 0 
     87      ! 
     88      ALLOCATE( fsaht_spu(jpi,jpj), fsaht_spv(jpi,jpj),   & 
     89         &      fsahm_spt(jpi,jpj), fsahm_spf(jpi,jpj),   & 
     90         &      tabspongedone_tsn(jpi,jpj),           & 
     91# if defined key_top          
     92         &      tabspongedone_trn(jpi,jpj),           & 
     93# endif          
     94         &      tabspongedone_u  (jpi,jpj),           & 
     95         &      tabspongedone_v  (jpi,jpj), STAT = ierr(1) ) 
     96 
     97      ALLOCATE( ubdy_w(jpj), vbdy_w(jpj), hbdy_w(jpj),   & 
     98         &      ubdy_e(jpj), vbdy_e(jpj), hbdy_e(jpj),   &  
     99         &      ubdy_n(jpi), vbdy_n(jpi), hbdy_n(jpi),   &  
     100         &      ubdy_s(jpi), vbdy_s(jpi), hbdy_s(jpi), STAT = ierr(2) ) 
     101 
     102      agrif_oce_alloc = MAXVAL(ierr) 
     103      ! 
    58104   END FUNCTION agrif_oce_alloc 
    59105 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/NST_SRC/agrif_opa_interp.F90

    r6836 r6839  
    77   !!             -   !  2005-11  (XXX)  
    88   !!            3.2  !  2009-04  (R. Benshila)  
     9   !!            3.6  !  2014-09  (R. Benshila)  
    910   !!---------------------------------------------------------------------- 
    1011#if defined key_agrif && ! defined key_offline 
    … …  
    2930   USE wrk_nemo 
    3031   USE dynspg_oce 
    31  
     32   USE zdf_oce 
     33  
    3234   IMPLICIT NONE 
    3335   PRIVATE 
    3436 
    35    ! Barotropic arrays used to store open boundary data during 
    36    ! time-splitting loop: 
    37    REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) ::  ubdy_w, vbdy_w, hbdy_w 
    38    REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) ::  ubdy_e, vbdy_e, hbdy_e 
    39    REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) ::  ubdy_n, vbdy_n, hbdy_n 
    40    REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) ::  ubdy_s, vbdy_s, hbdy_s 
    41      
     37   INTEGER :: bdy_tinterp = 0 
     38 
    4239   PUBLIC   Agrif_tra, Agrif_dyn, Agrif_ssh, Agrif_dyn_ts, Agrif_ssh_ts, Agrif_dta_ts 
    43    PUBLIC   interpu, interpv, interpunb, interpvnb, interpsshn 
     40   PUBLIC   interpun, interpvn, interpun2d, interpvn2d  
     41   PUBLIC   interptsn,  interpsshn 
     42   PUBLIC   interpunb, interpvnb, interpub2b, interpvb2b 
     43   PUBLIC   interpe3t, interpumsk, interpvmsk 
     44# if defined key_zdftke 
     45   PUBLIC   Agrif_tke, interpavm 
     46# endif 
    4447 
    4548#  include "domzgr_substitute.h90"   
    4649#  include "vectopt_loop_substitute.h90" 
    4750   !!---------------------------------------------------------------------- 
    48    !! NEMO/NST 3.3 , NEMO Consortium (2010) 
     51   !! NEMO/NST 3.6 , NEMO Consortium (2010) 
    4952   !! $Id$ 
    5053   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
    5154   !!---------------------------------------------------------------------- 
    5255 
    53    CONTAINS 
    54     
     56CONTAINS 
     57 
    5558   SUBROUTINE Agrif_tra 
    5659      !!---------------------------------------------------------------------- 
    57       !!                  ***  ROUTINE Agrif_Tra  *** 
    58       !!---------------------------------------------------------------------- 
    59       !! 
    60       INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices 
    61       REAL(wp) ::   zrhox , alpha1, alpha2, alpha3 
    62       REAL(wp) ::   alpha4, alpha5, alpha6, alpha7 
    63       REAL(wp), POINTER, DIMENSION(:,:,:,:) :: ztsa 
     60      !!                  ***  ROUTINE Agrif_tra  *** 
    6461      !!---------------------------------------------------------------------- 
    6562      ! 
    6663      IF( Agrif_Root() )   RETURN 
    67  
    68       CALL wrk_alloc( jpi, jpj, jpk, jpts, ztsa )  
    6964 
    7065      Agrif_SpecialValue    = 0.e0 
    7166      Agrif_UseSpecialValue = .TRUE. 
    72       ztsa(:,:,:,:) = 0.e0 
    73  
    74       CALL Agrif_Bc_variable( ztsa, tsn_id, procname=interptsn ) 
     67 
     68      CALL Agrif_Bc_variable( tsn_id, procname=interptsn ) 
    7569      Agrif_UseSpecialValue = .FALSE. 
    76  
    77       zrhox = Agrif_Rhox() 
    78  
    79       alpha1 = ( zrhox - 1. ) * 0.5 
    80       alpha2 = 1. - alpha1 
    81  
    82       alpha3 = ( zrhox - 1. ) / ( zrhox + 1. ) 
    83       alpha4 = 1. - alpha3 
    84  
    85       alpha6 = 2. * ( zrhox - 1. ) / ( zrhox + 1. ) 
    86       alpha7 =    - ( zrhox - 1. ) / ( zrhox + 3. ) 
    87       alpha5 = 1. - alpha6 - alpha7 
    88  
    89       IF( nbondi == 1 .OR. nbondi == 2 ) THEN 
    90  
    91          DO jn = 1, jpts 
    92             tsa(nlci,:,:,jn) = alpha1 * ztsa(nlci,:,:,jn) + alpha2 * ztsa(nlci-1,:,:,jn) 
    93             DO jk = 1, jpkm1 
    94                DO jj = 1, jpj 
    95                   IF( umask(nlci-2,jj,jk) == 0.e0 ) THEN 
    96                      tsa(nlci-1,jj,jk,jn) = tsa(nlci,jj,jk,jn) * tmask(nlci-1,jj,jk) 
    97                   ELSE 
    98                      tsa(nlci-1,jj,jk,jn)=(alpha4*tsa(nlci,jj,jk,jn)+alpha3*tsa(nlci-2,jj,jk,jn))*tmask(nlci-1,jj,jk) 
    99                      IF( un(nlci-2,jj,jk) > 0.e0 ) THEN 
    100                         tsa(nlci-1,jj,jk,jn)=( alpha6*tsa(nlci-2,jj,jk,jn)+alpha5*tsa(nlci,jj,jk,jn)  & 
    101                            &                 + alpha7*tsa(nlci-3,jj,jk,jn) ) * tmask(nlci-1,jj,jk) 
    102                      ENDIF 
    103                   ENDIF 
    104                END DO 
    105             END DO 
    106          ENDDO 
    107       ENDIF 
    108  
    109       IF( nbondj == 1 .OR. nbondj == 2 ) THEN 
    110  
    111          DO jn = 1, jpts 
    112             tsa(:,nlcj,:,jn) = alpha1 * ztsa(:,nlcj,:,jn) + alpha2 * ztsa(:,nlcj-1,:,jn) 
    113             DO jk = 1, jpkm1 
    114                DO ji = 1, jpi 
    115                   IF( vmask(ji,nlcj-2,jk) == 0.e0 ) THEN 
    116                      tsa(ji,nlcj-1,jk,jn) = tsa(ji,nlcj,jk,jn) * tmask(ji,nlcj-1,jk) 
    117                   ELSE 
    118                      tsa(ji,nlcj-1,jk,jn)=(alpha4*tsa(ji,nlcj,jk,jn)+alpha3*tsa(ji,nlcj-2,jk,jn))*tmask(ji,nlcj-1,jk)         
    119                      IF (vn(ji,nlcj-2,jk) > 0.e0 ) THEN 
    120                         tsa(ji,nlcj-1,jk,jn)=( alpha6*tsa(ji,nlcj-2,jk,jn)+alpha5*tsa(ji,nlcj,jk,jn)  & 
    121                            &                 + alpha7*tsa(ji,nlcj-3,jk,jn) ) * tmask(ji,nlcj-1,jk) 
    122                      ENDIF 
    123                   ENDIF 
    124                END DO 
    125             END DO 
    126          ENDDO  
    127       ENDIF 
    128  
    129       IF( nbondi == -1 .OR. nbondi == 2 ) THEN 
    130          DO jn = 1, jpts 
    131             tsa(1,:,:,jn) = alpha1 * ztsa(1,:,:,jn) + alpha2 * ztsa(2,:,:,jn) 
    132             DO jk = 1, jpkm1 
    133                DO jj = 1, jpj 
    134                   IF( umask(2,jj,jk) == 0.e0 ) THEN 
    135                      tsa(2,jj,jk,jn) = tsa(1,jj,jk,jn) * tmask(2,jj,jk) 
    136                   ELSE 
    137                      tsa(2,jj,jk,jn)=(alpha4*tsa(1,jj,jk,jn)+alpha3*tsa(3,jj,jk,jn))*tmask(2,jj,jk)         
    138                      IF( un(2,jj,jk) < 0.e0 ) THEN 
    139                         tsa(2,jj,jk,jn)=(alpha6*tsa(3,jj,jk,jn)+alpha5*tsa(1,jj,jk,jn)+alpha7*tsa(4,jj,jk,jn))*tmask(2,jj,jk) 
    140                      ENDIF 
    141                   ENDIF 
    142                END DO 
    143             END DO 
    144          END DO 
    145       ENDIF 
    146  
    147       IF( nbondj == -1 .OR. nbondj == 2 ) THEN 
    148          DO jn = 1, jpts 
    149             tsa(:,1,:,jn) = alpha1 * ztsa(:,1,:,jn) + alpha2 * ztsa(:,2,:,jn) 
    150             DO jk=1,jpk       
    151                DO ji=1,jpi 
    152                   IF( vmask(ji,2,jk) == 0.e0 ) THEN 
    153                      tsa(ji,2,jk,jn)=tsa(ji,1,jk,jn) * tmask(ji,2,jk) 
    154                   ELSE 
    155                      tsa(ji,2,jk,jn)=(alpha4*tsa(ji,1,jk,jn)+alpha3*tsa(ji,3,jk,jn))*tmask(ji,2,jk) 
    156                      IF( vn(ji,2,jk) < 0.e0 ) THEN 
    157                         tsa(ji,2,jk,jn)=(alpha6*tsa(ji,3,jk,jn)+alpha5*tsa(ji,1,jk,jn)+alpha7*tsa(ji,4,jk,jn))*tmask(ji,2,jk) 
    158                      ENDIF 
    159                   ENDIF 
    160                END DO 
    161             END DO 
    162          ENDDO 
    163       ENDIF 
    164       ! 
    165       CALL wrk_dealloc( jpi, jpj, jpk, jpts, ztsa )  
    16670      ! 
    16771   END SUBROUTINE Agrif_tra 
    … …  
    17579      INTEGER, INTENT(in) ::   kt 
    17680      !! 
    177       INTEGER :: ji,jj,jk 
     81      INTEGER :: ji,jj,jk, j1,j2, i1,i2 
    17882      REAL(wp) :: timeref 
    17983      REAL(wp) :: z2dt, znugdt 
    18084      REAL(wp) :: zrhox, zrhoy 
    181       REAL(wp), POINTER, DIMENSION(:,:,:) :: zua, zva 
    182       REAL(wp), POINTER, DIMENSION(:,:) :: spgv1, spgu1, zua2d, zva2d 
     85      REAL(wp), POINTER, DIMENSION(:,:) :: spgv1, spgu1 
    18386      !!----------------------------------------------------------------------   
    18487 
    18588      IF( Agrif_Root() )   RETURN 
    18689 
    187       CALL wrk_alloc( jpi, jpj, spgv1, spgu1, zua2d, zva2d ) 
    188       CALL wrk_alloc( jpi, jpj, jpk, zua, zva ) 
     90      CALL wrk_alloc( jpi, jpj, spgv1, spgu1 ) 
     91 
     92      Agrif_SpecialValue=0. 
     93      Agrif_UseSpecialValue = ln_spc_dyn 
     94 
     95      CALL Agrif_Bc_variable(un_interp_id,procname=interpun) 
     96      CALL Agrif_Bc_variable(vn_interp_id,procname=interpvn) 
     97 
     98#if defined key_dynspg_flt 
     99      CALL Agrif_Bc_variable(e1u_id,calledweight=1., procname=interpun2d) 
     100      CALL Agrif_Bc_variable(e2v_id,calledweight=1., procname=interpvn2d) 
     101#endif 
     102 
     103      Agrif_UseSpecialValue = .FALSE. 
    189104 
    190105      zrhox = Agrif_Rhox() 
    … …  
    192107 
    193108      timeref = 1. 
    194  
    195109      ! time step: leap-frog 
    196110      z2dt = 2. * rdt 
    … …  
    200114      znugdt =  grav * z2dt     
    201115 
    202       Agrif_SpecialValue=0. 
    203       Agrif_UseSpecialValue = ln_spc_dyn 
    204  
    205       zua = 0. 
    206       zva = 0. 
    207       CALL Agrif_Bc_variable(zua,un_id,procname=interpu) 
    208       CALL Agrif_Bc_variable(zva,vn_id,procname=interpv) 
    209       zua2d = 0. 
    210       zva2d = 0. 
    211  
     116      ! prevent smoothing in ghost cells 
     117      i1=1 
     118      i2=jpi 
     119      j1=1 
     120      j2=jpj 
     121      IF((nbondj == -1).OR.(nbondj == 2)) j1 = 3 
     122      IF((nbondj == +1).OR.(nbondj == 2)) j2 = nlcj-2 
     123      IF((nbondi == -1).OR.(nbondi == 2)) i1 = 3 
     124      IF((nbondi == +1).OR.(nbondi == 2)) i2 = nlci-2 
     125 
     126 
     127      IF((nbondi == -1).OR.(nbondi == 2)) THEN 
    212128#if defined key_dynspg_flt 
    213       Agrif_SpecialValue=0. 
    214       Agrif_UseSpecialValue = ln_spc_dyn 
    215       CALL Agrif_Bc_variable(zua2d,e1u_id,calledweight=1.,procname=interpu2d) 
    216       CALL Agrif_Bc_variable(zva2d,e2v_id,calledweight=1.,procname=interpv2d) 
    217 #endif 
    218       Agrif_UseSpecialValue = .FALSE. 
    219  
    220  
    221       IF((nbondi == -1).OR.(nbondi == 2)) THEN 
    222  
    223 #if defined key_dynspg_flt 
    224          DO jj=1,jpj 
    225             laplacu(2,jj) = timeref * (zua2d(2,jj)/(zrhoy*e2u(2,jj)))*umask(2,jj,1) 
    226          END DO 
    227 #endif 
     129         DO jk=1,jpkm1 
     130            DO jj=j1,j2 
     131               ua(2,jj,jk) = (ua(2,jj,jk) - z2dt * znugdt * laplacu(2,jj))*umask(2,jj,jk) 
     132            END DO 
     133         END DO 
     134 
     135         spgu(2,:)=0. 
    228136 
    229137         DO jk=1,jpkm1 
    230138            DO jj=1,jpj 
    231                ua(1:2,jj,jk) = (zua(1:2,jj,jk)/(zrhoy*e2u(1:2,jj))) 
    232                ua(1:2,jj,jk) = ua(1:2,jj,jk) / fse3u_a(1:2,jj,jk) 
    233             END DO 
    234          END DO 
    235  
    236 #if defined key_dynspg_flt 
    237          DO jk=1,jpkm1 
    238             DO jj=1,jpj 
    239                ua(2,jj,jk) = (ua(2,jj,jk) - z2dt * znugdt * laplacu(2,jj))*umask(2,jj,jk) 
    240             END DO 
    241          END DO 
    242  
    243          spgu(2,:)=0. 
    244  
    245          DO jk=1,jpkm1 
    246             DO jj=1,jpj 
    247                spgu(2,jj)=spgu(2,jj)+fse3u_a(2,jj,jk)*ua(2,jj,jk) 
     139               spgu(2,jj)=spgu(2,jj)+fse3u(2,jj,jk)*ua(2,jj,jk) 
    248140            END DO 
    249141         END DO 
    … …  
    251143         DO jj=1,jpj 
    252144            IF (umask(2,jj,1).NE.0.) THEN 
    253                spgu(2,jj)=spgu(2,jj)*hur_a(2,jj) 
     145               spgu(2,jj)=spgu(2,jj)/hu(2,jj) 
    254146            ENDIF 
    255147         END DO 
    … …  
    259151 
    260152         DO jk=1,jpkm1 
    261             DO jj=1,jpj 
     153            DO jj=j1,j2 
    262154               ua(2,jj,jk) = 0.25*(ua(1,jj,jk)+2.*ua(2,jj,jk)+ua(3,jj,jk)) 
    263155               ua(2,jj,jk) = ua(2,jj,jk) * umask(2,jj,jk) 
    … …  
    269161         DO jk=1,jpkm1 
    270162            DO jj=1,jpj 
    271                spgu1(2,jj)=spgu1(2,jj)+fse3u_a(2,jj,jk)*ua(2,jj,jk) 
     163               spgu1(2,jj)=spgu1(2,jj)+fse3u(2,jj,jk)*ua(2,jj,jk) 
    272164            END DO 
    273165         END DO 
    … …  
    275167         DO jj=1,jpj 
    276168            IF (umask(2,jj,1).NE.0.) THEN 
    277                spgu1(2,jj)=spgu1(2,jj)*hur_a(2,jj) 
    278             ENDIF 
    279          END DO 
    280  
    281          DO jk=1,jpkm1 
    282             DO jj=1,jpj 
     169               spgu1(2,jj)=spgu1(2,jj)/hu(2,jj) 
     170            ENDIF 
     171         END DO 
     172 
     173         DO jk=1,jpkm1 
     174            DO jj=j1,j2 
    283175               ua(2,jj,jk) = (ua(2,jj,jk)+spgu(2,jj)-spgu1(2,jj))*umask(2,jj,jk) 
    284             END DO 
    285          END DO 
    286  
    287          DO jk=1,jpkm1 
    288             DO jj=1,jpj 
    289                va(2,jj,jk) = (zva(2,jj,jk)/(zrhox*e1v(2,jj)))*vmask(2,jj,jk) 
    290                va(2,jj,jk) = va(2,jj,jk) / fse3v_a(2,jj,jk) 
    291176            END DO 
    292177         END DO 
    … …  
    300185            END DO 
    301186         END DO 
    302  
    303187         DO jj=1,jpj 
    304188            spgv1(2,jj)=spgv1(2,jj)*hvr_a(2,jj) 
    305189         END DO 
    306  
    307190         DO jk=1,jpkm1 
    308191            DO jj=1,jpj 
    … …  
    316199      IF((nbondi == 1).OR.(nbondi == 2)) THEN 
    317200#if defined key_dynspg_flt 
    318          DO jj=1,jpj 
    319             laplacu(nlci-2,jj) = timeref * (zua2d(nlci-2,jj)/(zrhoy*e2u(nlci-2,jj))) 
    320          END DO 
    321 #endif 
    322  
     201         DO jk=1,jpkm1 
     202            DO jj=j1,j2 
     203               ua(nlci-2,jj,jk) = (ua(nlci-2,jj,jk)- z2dt * znugdt * laplacu(nlci-2,jj))*umask(nlci-2,jj,jk) 
     204            END DO 
     205         END DO 
     206         spgu(nlci-2,:)=0. 
    323207         DO jk=1,jpkm1 
    324208            DO jj=1,jpj 
    325                ua(nlci-2:nlci-1,jj,jk) = (zua(nlci-2:nlci-1,jj,jk)/(zrhoy*e2u(nlci-2:nlci-1,jj))) 
    326                ua(nlci-2:nlci-1,jj,jk) = ua(nlci-2:nlci-1,jj,jk) / fse3u_a(nlci-2:nlci-1,jj,jk) 
    327             END DO 
    328          END DO 
    329  
    330 #if defined key_dynspg_flt 
    331          DO jk=1,jpkm1 
    332             DO jj=1,jpj 
    333                ua(nlci-2,jj,jk) = (ua(nlci-2,jj,jk)- z2dt * znugdt * laplacu(nlci-2,jj))*umask(nlci-2,jj,jk) 
    334             END DO 
    335          END DO 
    336  
    337  
    338          spgu(nlci-2,:)=0. 
    339  
    340          do jk=1,jpkm1 
    341             do jj=1,jpj 
    342                spgu(nlci-2,jj)=spgu(nlci-2,jj)+fse3u_a(nlci-2,jj,jk)*ua(nlci-2,jj,jk) 
    343             enddo 
    344          enddo 
    345  
     209               spgu(nlci-2,jj)=spgu(nlci-2,jj)+fse3u(nlci-2,jj,jk)*ua(nlci-2,jj,jk) 
     210            ENDDO 
     211         ENDDO 
    346212         DO jj=1,jpj 
    347213            IF (umask(nlci-2,jj,1).NE.0.) THEN 
    348                spgu(nlci-2,jj)=spgu(nlci-2,jj)*hur_a(nlci-2,jj) 
     214               spgu(nlci-2,jj)=spgu(nlci-2,jj)/hu(nlci-2,jj) 
    349215            ENDIF 
    350216         END DO 
    … …  
    352218         spgu(nlci-2,:) = ua_b(nlci-2,:) 
    353219#endif 
    354  
     220         DO jk=1,jpkm1 
     221            DO jj=j1,j2 
     222               ua(nlci-2,jj,jk) = 0.25*(ua(nlci-3,jj,jk)+2.*ua(nlci-2,jj,jk)+ua(nlci-1,jj,jk)) 
     223 
     224               ua(nlci-2,jj,jk) = ua(nlci-2,jj,jk) * umask(nlci-2,jj,jk) 
     225 
     226            END DO 
     227         END DO 
     228         spgu1(nlci-2,:)=0. 
    355229         DO jk=1,jpkm1 
    356230            DO jj=1,jpj 
    357                ua(nlci-2,jj,jk) = 0.25*(ua(nlci-3,jj,jk)+2.*ua(nlci-2,jj,jk)+ua(nlci-1,jj,jk)) 
    358  
    359                ua(nlci-2,jj,jk) = ua(nlci-2,jj,jk) * umask(nlci-2,jj,jk) 
    360  
    361             END DO 
    362          END DO 
    363  
    364          spgu1(nlci-2,:)=0. 
    365  
    366          DO jk=1,jpkm1 
    367             DO jj=1,jpj 
    368                spgu1(nlci-2,jj)=spgu1(nlci-2,jj)+fse3u_a(nlci-2,jj,jk)*ua(nlci-2,jj,jk)*umask(nlci-2,jj,jk) 
    369             END DO 
    370          END DO 
    371  
     231               spgu1(nlci-2,jj)=spgu1(nlci-2,jj)+fse3u(nlci-2,jj,jk)*ua(nlci-2,jj,jk)*umask(nlci-2,jj,jk) 
     232            END DO 
     233         END DO 
    372234         DO jj=1,jpj 
    373235            IF (umask(nlci-2,jj,1).NE.0.) THEN 
    374                spgu1(nlci-2,jj)=spgu1(nlci-2,jj)*hur_a(nlci-2,jj) 
    375             ENDIF 
    376          END DO 
    377  
    378          DO jk=1,jpkm1 
    379             DO jj=1,jpj 
     236               spgu1(nlci-2,jj)=spgu1(nlci-2,jj)/hu(nlci-2,jj) 
     237            ENDIF 
     238         END DO 
     239         DO jk=1,jpkm1 
     240            DO jj=j1,j2 
    380241               ua(nlci-2,jj,jk) = (ua(nlci-2,jj,jk)+spgu(nlci-2,jj)-spgu1(nlci-2,jj))*umask(nlci-2,jj,jk) 
    381             END DO 
    382          END DO 
    383  
    384          DO jk=1,jpkm1 
    385             DO jj=1,jpj-1 
    386                va(nlci-1,jj,jk) = (zva(nlci-1,jj,jk)/(zrhox*e1v(nlci-1,jj)))*vmask(nlci-1,jj,jk) 
    387                va(nlci-1,jj,jk) = va(nlci-1,jj,jk) / fse3v_a(nlci-1,jj,jk) 
    388242            END DO 
    389243         END DO 
    … …  
    414268 
    415269#if defined key_dynspg_flt 
    416          DO ji=1,jpi 
    417             laplacv(ji,2) = timeref * (zva2d(ji,2)/(zrhox*e1v(ji,2))) 
    418          END DO 
    419 #endif 
    420  
    421          DO jk=1,jpkm1 
    422             DO ji=1,jpi 
    423                va(ji,1:2,jk) = (zva(ji,1:2,jk)/(zrhox*e1v(ji,1:2))) 
    424                va(ji,1:2,jk) = va(ji,1:2,jk) / fse3v_a(ji,1:2,jk) 
    425             END DO 
    426          END DO 
    427  
    428 #if defined key_dynspg_flt 
    429270         DO jk=1,jpkm1 
    430271            DO ji=1,jpi 
    … …  
    437278         DO jk=1,jpkm1 
    438279            DO ji=1,jpi 
    439                spgv(ji,2)=spgv(ji,2)+fse3v_a(ji,2,jk)*va(ji,2,jk) 
     280               spgv(ji,2)=spgv(ji,2)+fse3v(ji,2,jk)*va(ji,2,jk) 
    440281            END DO 
    441282         END DO 
    … …  
    443284         DO ji=1,jpi 
    444285            IF (vmask(ji,2,1).NE.0.) THEN 
    445                spgv(ji,2)=spgv(ji,2)*hvr_a(ji,2) 
     286               spgv(ji,2)=spgv(ji,2)/hv(ji,2) 
    446287            ENDIF 
    447288         END DO 
    … …  
    451292 
    452293         DO jk=1,jpkm1 
    453             DO ji=1,jpi 
     294            DO ji=i1,i2 
    454295               va(ji,2,jk)=0.25*(va(ji,1,jk)+2.*va(ji,2,jk)+va(ji,3,jk)) 
    455296               va(ji,2,jk)=va(ji,2,jk)*vmask(ji,2,jk) 
    … …  
    461302         DO jk=1,jpkm1 
    462303            DO ji=1,jpi 
    463                spgv1(ji,2)=spgv1(ji,2)+fse3v_a(ji,2,jk)*va(ji,2,jk)*vmask(ji,2,jk) 
     304               spgv1(ji,2)=spgv1(ji,2)+fse3v(ji,2,jk)*va(ji,2,jk)*vmask(ji,2,jk) 
    464305            END DO 
    465306         END DO 
    … …  
    467308         DO ji=1,jpi 
    468309            IF (vmask(ji,2,1).NE.0.) THEN 
    469                spgv1(ji,2)=spgv1(ji,2)*hvr_a(ji,2) 
     310               spgv1(ji,2)=spgv1(ji,2)/hv(ji,2) 
    470311            ENDIF 
    471312         END DO 
    … …  
    474315            DO ji=1,jpi 
    475316               va(ji,2,jk) = (va(ji,2,jk)+spgv(ji,2)-spgv1(ji,2))*vmask(ji,2,jk) 
    476             END DO 
    477          END DO 
    478  
    479          DO jk=1,jpkm1 
    480             DO ji=1,jpi 
    481                ua(ji,2,jk) = (zua(ji,2,jk)/(zrhoy*e2u(ji,2)))*umask(ji,2,jk)  
    482                ua(ji,2,jk) = ua(ji,2,jk) / fse3u_a(ji,2,jk) 
    483317            END DO 
    484318         END DO 
    … …  
    508342 
    509343#if defined key_dynspg_flt 
    510          DO ji=1,jpi 
    511             laplacv(ji,nlcj-2) = timeref * (zva2d(ji,nlcj-2)/(zrhox*e1v(ji,nlcj-2))) 
    512          END DO 
    513 #endif 
    514  
    515          DO jk=1,jpkm1 
    516             DO ji=1,jpi 
    517                va(ji,nlcj-2:nlcj-1,jk) = (zva(ji,nlcj-2:nlcj-1,jk)/(zrhox*e1v(ji,nlcj-2:nlcj-1))) 
    518                va(ji,nlcj-2:nlcj-1,jk) = va(ji,nlcj-2:nlcj-1,jk) / fse3v_a(ji,nlcj-2:nlcj-1,jk) 
    519             END DO 
    520          END DO 
    521  
    522 #if defined key_dynspg_flt 
    523344         DO jk=1,jpkm1 
    524345            DO ji=1,jpi 
    … …  
    527348         END DO 
    528349 
     350 
    529351         spgv(:,nlcj-2)=0. 
    530352 
    531353         DO jk=1,jpkm1 
    532354            DO ji=1,jpi 
    533                spgv(ji,nlcj-2)=spgv(ji,nlcj-2)+fse3v_a(ji,nlcj-2,jk)*va(ji,nlcj-2,jk) 
     355               spgv(ji,nlcj-2)=spgv(ji,nlcj-2)+fse3v(ji,nlcj-2,jk)*va(ji,nlcj-2,jk) 
    534356            END DO 
    535357         END DO 
    … …  
    537359         DO ji=1,jpi 
    538360            IF (vmask(ji,nlcj-2,1).NE.0.) THEN 
    539                spgv(ji,nlcj-2)=spgv(ji,nlcj-2)*hvr_a(ji,nlcj-2) 
    540             ENDIF 
    541          END DO 
     361               spgv(ji,nlcj-2)=spgv(ji,nlcj-2)/hv(ji,nlcj-2) 
     362            ENDIF 
     363         END DO 
     364 
    542365#else 
    543366         spgv(:,nlcj-2)=va_b(:,nlcj-2) 
    … …  
    545368 
    546369         DO jk=1,jpkm1 
    547             DO ji=1,jpi 
     370            DO ji=i1,i2 
    548371               va(ji,nlcj-2,jk)=0.25*(va(ji,nlcj-3,jk)+2.*va(ji,nlcj-2,jk)+va(ji,nlcj-1,jk)) 
    549372               va(ji,nlcj-2,jk) = va(ji,nlcj-2,jk) * vmask(ji,nlcj-2,jk) 
    … …  
    555378         DO jk=1,jpkm1 
    556379            DO ji=1,jpi 
    557                spgv1(ji,nlcj-2)=spgv1(ji,nlcj-2)+fse3v_a(ji,nlcj-2,jk)*va(ji,nlcj-2,jk) 
     380               spgv1(ji,nlcj-2)=spgv1(ji,nlcj-2)+fse3v(ji,nlcj-2,jk)*va(ji,nlcj-2,jk) 
    558381            END DO 
    559382         END DO 
    … …  
    561384         DO ji=1,jpi 
    562385            IF (vmask(ji,nlcj-2,1).NE.0.) THEN 
    563                spgv1(ji,nlcj-2)=spgv1(ji,nlcj-2)*hvr_a(ji,nlcj-2) 
     386               spgv1(ji,nlcj-2)=spgv1(ji,nlcj-2)/hv(ji,nlcj-2) 
    564387            ENDIF 
    565388         END DO 
    … …  
    568391            DO ji=1,jpi 
    569392               va(ji,nlcj-2,jk) = (va(ji,nlcj-2,jk)+spgv(ji,nlcj-2)-spgv1(ji,nlcj-2))*vmask(ji,nlcj-2,jk) 
    570             END DO 
    571          END DO 
    572  
    573          DO jk=1,jpkm1 
    574             DO ji=1,jpi 
    575                ua(ji,nlcj-1,jk) = (zua(ji,nlcj-1,jk)/(zrhoy*e2u(ji,nlcj-1)))*umask(ji,nlcj-1,jk) 
    576                ua(ji,nlcj-1,jk) = ua(ji,nlcj-1,jk) / fse3u_a(ji,nlcj-1,jk) 
    577393            END DO 
    578394         END DO 
    … …  
    600416      ENDIF 
    601417      ! 
    602       CALL wrk_dealloc( jpi, jpj, spgv1, spgu1, zua2d, zva2d ) 
    603       CALL wrk_dealloc( jpi, jpj, jpk, zua, zva ) 
     418      CALL wrk_dealloc( jpi, jpj, spgv1, spgu1 ) 
    604419      ! 
    605420   END SUBROUTINE Agrif_dyn 
    … …  
    620435         DO jj=1,jpj 
    621436            va_e(2,jj) = vbdy_w(jj) * hvr_e(2,jj) 
    622 ! Specified fluxes: 
     437            ! Specified fluxes: 
    623438            ua_e(2,jj) = ubdy_w(jj) * hur_e(2,jj) 
    624 ! Characteristics method: 
    625 !alt            ua_e(2,jj) = 0.5_wp * ( ubdy_w(jj) * hur_e(2,jj) + ua_e(3,jj) & 
    626 !alt                       &           - sqrt(grav * hur_e(2,jj)) * (sshn_e(3,jj) - hbdy_w(jj)) ) 
     439            ! Characteristics method: 
     440            !alt            ua_e(2,jj) = 0.5_wp * ( ubdy_w(jj) * hur_e(2,jj) + ua_e(3,jj) & 
     441            !alt                       &           - sqrt(grav * hur_e(2,jj)) * (sshn_e(3,jj) - hbdy_w(jj)) ) 
    627442         END DO 
    628443      ENDIF 
    … …  
    631446         DO jj=1,jpj 
    632447            va_e(nlci-1,jj) = vbdy_e(jj) * hvr_e(nlci-1,jj) 
    633 ! Specified fluxes: 
     448            ! Specified fluxes: 
    634449            ua_e(nlci-2,jj) = ubdy_e(jj) * hur_e(nlci-2,jj) 
    635 ! Characteristics method: 
    636 !alt            ua_e(nlci-2,jj) = 0.5_wp * ( ubdy_e(jj) * hur_e(nlci-2,jj) + ua_e(nlci-3,jj) & 
    637 !alt                            &           + sqrt(grav * hur_e(nlci-2,jj)) * (sshn_e(nlci-2,jj) - hbdy_e(jj)) ) 
     450            ! Characteristics method: 
     451            !alt            ua_e(nlci-2,jj) = 0.5_wp * ( ubdy_e(jj) * hur_e(nlci-2,jj) + ua_e(nlci-3,jj) & 
     452            !alt                            &           + sqrt(grav * hur_e(nlci-2,jj)) * (sshn_e(nlci-2,jj) - hbdy_e(jj)) ) 
    638453         END DO 
    639454      ENDIF 
    … …  
    642457         DO ji=1,jpi 
    643458            ua_e(ji,2) = ubdy_s(ji) * hur_e(ji,2) 
    644 ! Specified fluxes: 
     459            ! Specified fluxes: 
    645460            va_e(ji,2) = vbdy_s(ji) * hvr_e(ji,2) 
    646 ! Characteristics method: 
    647 !alt            va_e(ji,2) = 0.5_wp * ( vbdy_s(ji) * hvr_e(ji,2) + va_e(ji,3) & 
    648 !alt                       &           - sqrt(grav * hvr_e(ji,2)) * (sshn_e(ji,3) - hbdy_s(ji)) ) 
     461            ! Characteristics method: 
     462            !alt            va_e(ji,2) = 0.5_wp * ( vbdy_s(ji) * hvr_e(ji,2) + va_e(ji,3) & 
     463            !alt                       &           - sqrt(grav * hvr_e(ji,2)) * (sshn_e(ji,3) - hbdy_s(ji)) ) 
    649464         END DO 
    650465      ENDIF 
    … …  
    653468         DO ji=1,jpi 
    654469            ua_e(ji,nlcj-1) = ubdy_n(ji) * hur_e(ji,nlcj-1) 
    655 ! Specified fluxes: 
     470            ! Specified fluxes: 
    656471            va_e(ji,nlcj-2) = vbdy_n(ji) * hvr_e(ji,nlcj-2) 
    657 ! Characteristics method: 
    658 !alt            va_e(ji,nlcj-2) = 0.5_wp * ( vbdy_n(ji) * hvr_e(ji,nlcj-2)  + va_e(ji,nlcj-3) & 
    659 !alt                            &           + sqrt(grav * hvr_e(ji,nlcj-2)) * (sshn_e(ji,nlcj-2) - hbdy_n(ji)) ) 
     472            ! Characteristics method: 
     473            !alt            va_e(ji,nlcj-2) = 0.5_wp * ( vbdy_n(ji) * hvr_e(ji,nlcj-2)  + va_e(ji,nlcj-3) & 
     474            !alt                            &           + sqrt(grav * hvr_e(ji,nlcj-2)) * (sshn_e(ji,nlcj-2) - hbdy_n(ji)) ) 
    660475         END DO 
    661476      ENDIF 
    … …  
    672487      INTEGER :: ji, jj 
    673488      LOGICAL :: ll_int_cons 
    674       REAL(wp) :: zrhox, zrhoy, zrhot, zt 
    675       REAL(wp) :: zaa, zab, zat 
    676       REAL(wp) :: zt0, zt1 
    677       REAL(wp), POINTER, DIMENSION(:,:) :: zunb, zvnb, zsshn 
    678       REAL(wp), POINTER, DIMENSION(:,:) :: zuab, zvab, zubb, zvbb, zutn, zvtn 
     489      REAL(wp) :: zrhot, zt 
    679490      !!----------------------------------------------------------------------   
    680491 
    … …  
    682493 
    683494      ll_int_cons = ln_bt_fw ! Assume conservative temporal integration in 
    684                              ! the forward case only 
    685  
    686       zrhox = Agrif_Rhox() 
    687       zrhoy = Agrif_Rhoy() 
     495      ! the forward case only 
     496 
    688497      zrhot = Agrif_rhot() 
    689  
    690       IF ( kt==nit000 ) THEN ! Allocate boundary data arrays 
    691          ALLOCATE( ubdy_w(jpj), vbdy_w(jpj), hbdy_w(jpj)) 
    692          ALLOCATE( ubdy_e(jpj), vbdy_e(jpj), hbdy_e(jpj)) 
    693          ALLOCATE( ubdy_n(jpi), vbdy_n(jpi), hbdy_n(jpi)) 
    694          ALLOCATE( ubdy_s(jpi), vbdy_s(jpi), hbdy_s(jpi)) 
    695       ENDIF 
    696  
    697       CALL wrk_alloc( jpi, jpj, zunb, zvnb, zsshn ) 
    698498 
    699499      ! "Central" time index for interpolation: 
    … …  
    707507      Agrif_SpecialValue    = 0.e0 
    708508      Agrif_UseSpecialValue = .TRUE. 
    709       CALL Agrif_Bc_variable(zsshn, sshn_id,calledweight=zt, procname=interpsshn ) 
     509      CALL Agrif_Bc_variable(sshn_id,calledweight=zt, procname=interpsshn ) 
    710510      Agrif_UseSpecialValue = .FALSE. 
    711511 
    … …  
    715515 
    716516      IF (ll_int_cons) THEN ! Conservative interpolation 
    717          CALL wrk_alloc( jpi, jpj, zuab, zvab, zubb, zvbb, zutn, zvtn ) 
    718          zuab(:,:) = 0._wp ; zvab(:,:) = 0._wp 
    719          zubb(:,:) = 0._wp ; zvbb(:,:) = 0._wp 
    720          zutn(:,:) = 0._wp ; zvtn(:,:) = 0._wp 
    721          CALL Agrif_Bc_variable(zubb,unb_id ,calledweight=0._wp, procname=interpunb) ! Before 
    722          CALL Agrif_Bc_variable(zvbb,vnb_id ,calledweight=0._wp, procname=interpvnb) 
    723          CALL Agrif_Bc_variable(zuab,unb_id ,calledweight=1._wp, procname=interpunb) ! After 
    724          CALL Agrif_Bc_variable(zvab,vnb_id ,calledweight=1._wp, procname=interpvnb) 
    725          CALL Agrif_Bc_variable(zutn,ub2b_id,calledweight=1._wp, procname=interpub2b)! Time integrated 
    726          CALL Agrif_Bc_variable(zvtn,vb2b_id,calledweight=1._wp, procname=interpvb2b) 
    727           
     517         ! orders matters here !!!!!! 
     518         CALL Agrif_Bc_variable(ub2b_interp_id,calledweight=1._wp, procname=interpub2b) ! Time integrated 
     519         CALL Agrif_Bc_variable(vb2b_interp_id,calledweight=1._wp, procname=interpvb2b) 
     520         bdy_tinterp = 1 
     521         CALL Agrif_Bc_variable(unb_id ,calledweight=1._wp, procname=interpunb) ! After 
     522         CALL Agrif_Bc_variable(vnb_id ,calledweight=1._wp, procname=interpvnb) 
     523         bdy_tinterp = 2 
     524         CALL Agrif_Bc_variable(unb_id ,calledweight=0._wp, procname=interpunb) ! Before 
     525         CALL Agrif_Bc_variable(vnb_id ,calledweight=0._wp, procname=interpvnb)          
     526      ELSE ! Linear interpolation 
     527         bdy_tinterp = 0 
     528         ubdy_w(:) = 0.e0 ; vbdy_w(:) = 0.e0  
     529         ubdy_e(:) = 0.e0 ; vbdy_e(:) = 0.e0  
     530         ubdy_n(:) = 0.e0 ; vbdy_n(:) = 0.e0  
     531         ubdy_s(:) = 0.e0 ; vbdy_s(:) = 0.e0  
     532         CALL Agrif_Bc_variable(unb_id,calledweight=zt, procname=interpunb) 
     533         CALL Agrif_Bc_variable(vnb_id,calledweight=zt, procname=interpvnb) 
     534      ENDIF 
     535      Agrif_UseSpecialValue = .FALSE. 
     536      !  
     537   END SUBROUTINE Agrif_dta_ts 
     538 
     539   SUBROUTINE Agrif_ssh( kt ) 
     540      !!---------------------------------------------------------------------- 
     541      !!                  ***  ROUTINE Agrif_DYN  *** 
     542      !!----------------------------------------------------------------------   
     543      INTEGER, INTENT(in) ::   kt 
     544      !! 
     545      !!----------------------------------------------------------------------   
     546 
     547      IF( Agrif_Root() )   RETURN 
     548 
     549      IF((nbondi == -1).OR.(nbondi == 2)) THEN 
     550         ssha(2,:)=ssha(3,:) 
     551         sshn(2,:)=sshn(3,:) 
     552      ENDIF 
     553 
     554      IF((nbondi == 1).OR.(nbondi == 2)) THEN 
     555         ssha(nlci-1,:)=ssha(nlci-2,:) 
     556         sshn(nlci-1,:)=sshn(nlci-2,:) 
     557      ENDIF 
     558 
     559      IF((nbondj == -1).OR.(nbondj == 2)) THEN 
     560         ssha(:,2)=ssha(:,3) 
     561         sshn(:,2)=sshn(:,3) 
     562      ENDIF 
     563 
     564      IF((nbondj == 1).OR.(nbondj == 2)) THEN 
     565         ssha(:,nlcj-1)=ssha(:,nlcj-2) 
     566         sshn(:,nlcj-1)=sshn(:,nlcj-2) 
     567      ENDIF 
     568 
     569   END SUBROUTINE Agrif_ssh 
     570 
     571   SUBROUTINE Agrif_ssh_ts( jn ) 
     572      !!---------------------------------------------------------------------- 
     573      !!                  ***  ROUTINE Agrif_ssh_ts  *** 
     574      !!----------------------------------------------------------------------   
     575      INTEGER, INTENT(in) ::   jn 
     576      !! 
     577      INTEGER :: ji,jj 
     578      !!----------------------------------------------------------------------   
     579 
     580      IF((nbondi == -1).OR.(nbondi == 2)) THEN 
     581         DO jj=1,jpj 
     582            ssha_e(2,jj) = hbdy_w(jj) 
     583         END DO 
     584      ENDIF 
     585 
     586      IF((nbondi == 1).OR.(nbondi == 2)) THEN 
     587         DO jj=1,jpj 
     588            ssha_e(nlci-1,jj) = hbdy_e(jj) 
     589         END DO 
     590      ENDIF 
     591 
     592      IF((nbondj == -1).OR.(nbondj == 2)) THEN 
     593         DO ji=1,jpi 
     594            ssha_e(ji,2) = hbdy_s(ji) 
     595         END DO 
     596      ENDIF 
     597 
     598      IF((nbondj == 1).OR.(nbondj == 2)) THEN 
     599         DO ji=1,jpi 
     600            ssha_e(ji,nlcj-1) = hbdy_n(ji) 
     601         END DO 
     602      ENDIF 
     603 
     604   END SUBROUTINE Agrif_ssh_ts 
     605 
     606# if defined key_zdftke 
     607   SUBROUTINE Agrif_tke 
     608      !!---------------------------------------------------------------------- 
     609      !!                  ***  ROUTINE Agrif_tke  *** 
     610      !!----------------------------------------------------------------------   
     611      REAL(wp) ::   zalpha 
     612      ! 
     613      zalpha = REAL( Agrif_NbStepint() + Agrif_IRhot() - 1, wp ) / REAL( Agrif_IRhot(), wp ) 
     614      IF( zalpha > 1. )   zalpha = 1. 
     615       
     616      Agrif_SpecialValue    = 0.e0 
     617      Agrif_UseSpecialValue = .TRUE. 
     618       
     619      CALL Agrif_Bc_variable(avm_id ,calledweight=zalpha, procname=interpavm)        
     620               
     621      Agrif_UseSpecialValue = .FALSE. 
     622      ! 
     623   END SUBROUTINE Agrif_tke 
     624# endif 
     625 
     626   SUBROUTINE interptsn(ptab,i1,i2,j1,j2,k1,k2,n1,n2,before,nb,ndir) 
     627      !!--------------------------------------------- 
     628      !!   *** ROUTINE interptsn *** 
     629      !!--------------------------------------------- 
     630      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: ptab 
     631      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2 
     632      LOGICAL, INTENT(in) :: before 
     633      INTEGER, INTENT(in) :: nb , ndir 
     634      ! 
     635      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices 
     636      INTEGER :: imin, imax, jmin, jmax 
     637      REAL(wp) ::   zrhox , zalpha1, zalpha2, zalpha3 
     638      REAL(wp) ::   zalpha4, zalpha5, zalpha6, zalpha7 
     639      LOGICAL :: western_side, eastern_side,northern_side,southern_side 
     640 
     641      IF (before) THEN          
     642         ptab(i1:i2,j1:j2,k1:k2,n1:n2) = tsn(i1:i2,j1:j2,k1:k2,n1:n2) 
     643      ELSE 
     644         ! 
     645         western_side  = (nb == 1).AND.(ndir == 1) 
     646         eastern_side  = (nb == 1).AND.(ndir == 2) 
     647         southern_side = (nb == 2).AND.(ndir == 1) 
     648         northern_side = (nb == 2).AND.(ndir == 2) 
     649         ! 
     650         zrhox = Agrif_Rhox() 
     651         !  
     652         zalpha1 = ( zrhox - 1. ) * 0.5 
     653         zalpha2 = 1. - zalpha1 
     654         !  
     655         zalpha3 = ( zrhox - 1. ) / ( zrhox + 1. ) 
     656         zalpha4 = 1. - zalpha3 
     657         !  
     658         zalpha6 = 2. * ( zrhox - 1. ) / ( zrhox + 1. ) 
     659         zalpha7 =    - ( zrhox - 1. ) / ( zrhox + 3. ) 
     660         zalpha5 = 1. - zalpha6 - zalpha7 
     661         ! 
     662         imin = i1 
     663         imax = i2 
     664         jmin = j1 
     665         jmax = j2 
     666         !  
     667         ! Remove CORNERS 
     668         IF((nbondj == -1).OR.(nbondj == 2)) jmin = 3 
     669         IF((nbondj == +1).OR.(nbondj == 2)) jmax = nlcj-2 
     670         IF((nbondi == -1).OR.(nbondi == 2)) imin = 3 
     671         IF((nbondi == +1).OR.(nbondi == 2)) imax = nlci-2         
     672         ! 
     673         IF( eastern_side) THEN 
     674            DO jn = 1, jpts 
     675               tsa(nlci,j1:j2,k1:k2,jn) = zalpha1 * ptab(nlci,j1:j2,k1:k2,jn) + zalpha2 * ptab(nlci-1,j1:j2,k1:k2,jn) 
     676               DO jk = 1, jpkm1 
     677                  DO jj = jmin,jmax 
     678                     IF( umask(nlci-2,jj,jk) == 0.e0 ) THEN 
     679                        tsa(nlci-1,jj,jk,jn) = tsa(nlci,jj,jk,jn) * tmask(nlci-1,jj,jk) 
     680                     ELSE 
     681                        tsa(nlci-1,jj,jk,jn)=(zalpha4*tsa(nlci,jj,jk,jn)+zalpha3*tsa(nlci-2,jj,jk,jn))*tmask(nlci-1,jj,jk) 
     682                        IF( un(nlci-2,jj,jk) > 0.e0 ) THEN 
     683                           tsa(nlci-1,jj,jk,jn)=( zalpha6*tsa(nlci-2,jj,jk,jn)+zalpha5*tsa(nlci,jj,jk,jn) &  
     684                                 + zalpha7*tsa(nlci-3,jj,jk,jn) ) * tmask(nlci-1,jj,jk) 
     685                        ENDIF 
     686                     ENDIF 
     687                  END DO 
     688               END DO 
     689            ENDDO 
     690         ENDIF 
     691         !  
     692         IF( northern_side ) THEN             
     693            DO jn = 1, jpts 
     694               tsa(i1:i2,nlcj,k1:k2,jn) = zalpha1 * ptab(i1:i2,nlcj,k1:k2,jn) + zalpha2 * ptab(i1:i2,nlcj-1,k1:k2,jn) 
     695               DO jk = 1, jpkm1 
     696                  DO ji = imin,imax 
     697                     IF( vmask(ji,nlcj-2,jk) == 0.e0 ) THEN 
     698                        tsa(ji,nlcj-1,jk,jn) = tsa(ji,nlcj,jk,jn) * tmask(ji,nlcj-1,jk) 
     699                     ELSE 
     700                        tsa(ji,nlcj-1,jk,jn)=(zalpha4*tsa(ji,nlcj,jk,jn)+zalpha3*tsa(ji,nlcj-2,jk,jn))*tmask(ji,nlcj-1,jk)         
     701                        IF (vn(ji,nlcj-2,jk) > 0.e0 ) THEN 
     702                           tsa(ji,nlcj-1,jk,jn)=( zalpha6*tsa(ji,nlcj-2,jk,jn)+zalpha5*tsa(ji,nlcj,jk,jn)  & 
     703                                 + zalpha7*tsa(ji,nlcj-3,jk,jn) ) * tmask(ji,nlcj-1,jk) 
     704                        ENDIF 
     705                     ENDIF 
     706                  END DO 
     707               END DO 
     708            ENDDO 
     709         ENDIF 
     710         ! 
     711         IF( western_side) THEN             
     712            DO jn = 1, jpts 
     713               tsa(1,j1:j2,k1:k2,jn) = zalpha1 * ptab(1,j1:j2,k1:k2,jn) + zalpha2 * ptab(2,j1:j2,k1:k2,jn) 
     714               DO jk = 1, jpkm1 
     715                  DO jj = jmin,jmax 
     716                     IF( umask(2,jj,jk) == 0.e0 ) THEN 
     717                        tsa(2,jj,jk,jn) = tsa(1,jj,jk,jn) * tmask(2,jj,jk) 
     718                     ELSE 
     719                        tsa(2,jj,jk,jn)=(zalpha4*tsa(1,jj,jk,jn)+zalpha3*tsa(3,jj,jk,jn))*tmask(2,jj,jk)         
     720                        IF( un(2,jj,jk) < 0.e0 ) THEN 
     721                           tsa(2,jj,jk,jn)=(zalpha6*tsa(3,jj,jk,jn)+zalpha5*tsa(1,jj,jk,jn)+zalpha7*tsa(4,jj,jk,jn))*tmask(2,jj,jk) 
     722                        ENDIF 
     723                     ENDIF 
     724                  END DO 
     725               END DO 
     726            END DO 
     727         ENDIF 
     728         ! 
     729         IF( southern_side ) THEN            
     730            DO jn = 1, jpts 
     731               tsa(i1:i2,1,k1:k2,jn) = zalpha1 * ptab(i1:i2,1,k1:k2,jn) + zalpha2 * ptab(i1:i2,2,k1:k2,jn) 
     732               DO jk=1,jpk       
     733                  DO ji=imin,imax 
     734                     IF( vmask(ji,2,jk) == 0.e0 ) THEN 
     735                        tsa(ji,2,jk,jn)=tsa(ji,1,jk,jn) * tmask(ji,2,jk) 
     736                     ELSE 
     737                        tsa(ji,2,jk,jn)=(zalpha4*tsa(ji,1,jk,jn)+zalpha3*tsa(ji,3,jk,jn))*tmask(ji,2,jk) 
     738                        IF( vn(ji,2,jk) < 0.e0 ) THEN 
     739                           tsa(ji,2,jk,jn)=(zalpha6*tsa(ji,3,jk,jn)+zalpha5*tsa(ji,1,jk,jn)+zalpha7*tsa(ji,4,jk,jn))*tmask(ji,2,jk) 
     740                        ENDIF 
     741                     ENDIF 
     742                  END DO 
     743               END DO 
     744            ENDDO 
     745         ENDIF 
     746         ! 
     747         ! Treatment of corners 
     748         !  
     749         ! East south 
     750         IF ((eastern_side).AND.((nbondj == -1).OR.(nbondj == 2))) THEN 
     751            tsa(nlci-1,2,:,:) = ptab(nlci-1,2,:,:) 
     752         ENDIF 
     753         ! East north 
     754         IF ((eastern_side).AND.((nbondj == 1).OR.(nbondj == 2))) THEN 
     755            tsa(nlci-1,nlcj-1,:,:) = ptab(nlci-1,nlcj-1,:,:) 
     756         ENDIF 
     757         ! West south 
     758         IF ((western_side).AND.((nbondj == -1).OR.(nbondj == 2))) THEN 
     759            tsa(2,2,:,:) = ptab(2,2,:,:) 
     760         ENDIF 
     761         ! West north 
     762         IF ((western_side).AND.((nbondj == 1).OR.(nbondj == 2))) THEN 
     763            tsa(2,nlcj-1,:,:) = ptab(2,nlcj-1,:,:) 
     764         ENDIF 
     765         ! 
     766      ENDIF 
     767      ! 
     768   END SUBROUTINE interptsn 
     769 
     770   SUBROUTINE interpsshn(ptab,i1,i2,j1,j2,before,nb,ndir) 
     771      !!---------------------------------------------------------------------- 
     772      !!                  ***  ROUTINE interpsshn  *** 
     773      !!----------------------------------------------------------------------   
     774      INTEGER, INTENT(in) :: i1,i2,j1,j2 
     775      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 
     776      LOGICAL, INTENT(in) :: before 
     777      INTEGER, INTENT(in) :: nb , ndir 
     778      LOGICAL :: western_side, eastern_side,northern_side,southern_side 
     779      !!----------------------------------------------------------------------   
     780      ! 
     781      IF( before) THEN 
     782         ptab(i1:i2,j1:j2) = sshn(i1:i2,j1:j2) 
     783      ELSE 
     784         western_side  = (nb == 1).AND.(ndir == 1) 
     785         eastern_side  = (nb == 1).AND.(ndir == 2) 
     786         southern_side = (nb == 2).AND.(ndir == 1) 
     787         northern_side = (nb == 2).AND.(ndir == 2) 
     788         IF(western_side)  hbdy_w(j1:j2) = ptab(i1,j1:j2) * tmask(i1,j1:j2,1) 
     789         IF(eastern_side)  hbdy_e(j1:j2) = ptab(i1,j1:j2) * tmask(i1,j1:j2,1) 
     790         IF(southern_side) hbdy_s(i1:i2) = ptab(i1:i2,j1) * tmask(i1:i2,j1,1) 
     791         IF(northern_side) hbdy_n(i1:i2) = ptab(i1:i2,j1) * tmask(i1:i2,j1,1) 
     792      ENDIF 
     793      ! 
     794   END SUBROUTINE interpsshn 
     795 
     796   SUBROUTINE interpun(ptab,i1,i2,j1,j2,k1,k2, before) 
     797      !!--------------------------------------------- 
     798      !!   *** ROUTINE interpun *** 
     799      !!---------------------------------------------     
     800      !! 
     801      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 
     802      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 
     803      LOGICAL, INTENT(in) :: before 
     804      !! 
     805      INTEGER :: ji,jj,jk 
     806      REAL(wp) :: zrhoy  
     807      !!---------------------------------------------     
     808      ! 
     809      IF (before) THEN  
     810         DO jk=1,jpk 
     811            DO jj=j1,j2 
     812               DO ji=i1,i2 
     813                  ptab(ji,jj,jk) = e2u(ji,jj) * un(ji,jj,jk) 
     814                  ptab(ji,jj,jk) = ptab(ji,jj,jk) * fse3u(ji,jj,jk) 
     815               END DO 
     816            END DO 
     817         END DO 
     818      ELSE 
     819         zrhoy = Agrif_Rhoy() 
     820         DO jk=1,jpkm1 
     821            DO jj=j1,j2 
     822               ua(i1:i2,jj,jk) = (ptab(i1:i2,jj,jk)/(zrhoy*e2u(i1:i2,jj))) 
     823               ua(i1:i2,jj,jk) = ua(i1:i2,jj,jk) / fse3u(i1:i2,jj,jk) 
     824            END DO 
     825         END DO 
     826      ENDIF 
     827      !  
     828   END SUBROUTINE interpun 
     829 
     830 
     831   SUBROUTINE interpun2d(ptab,i1,i2,j1,j2,before) 
     832      !!--------------------------------------------- 
     833      !!   *** ROUTINE interpun *** 
     834      !!---------------------------------------------     
     835      ! 
     836      INTEGER, INTENT(in) :: i1,i2,j1,j2 
     837      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 
     838      LOGICAL, INTENT(in) :: before 
     839      ! 
     840      INTEGER :: ji,jj 
     841      REAL(wp) :: ztref 
     842      REAL(wp) :: zrhoy  
     843      !!---------------------------------------------     
     844      ! 
     845      ztref = 1. 
     846 
     847      IF (before) THEN  
     848         DO jj=j1,j2 
     849            DO ji=i1,MIN(i2,nlci-1) 
     850               ptab(ji,jj) = e2u(ji,jj) * ((gcx(ji+1,jj) - gcx(ji,jj))/e1u(ji,jj))  
     851            END DO 
     852         END DO 
     853      ELSE 
     854         zrhoy = Agrif_Rhoy() 
     855         DO jj=j1,j2 
     856            laplacu(i1:i2,jj) = ztref * (ptab(i1:i2,jj)/(zrhoy*e2u(i1:i2,jj))) !*umask(i1:i2,jj,1) 
     857         END DO 
     858      ENDIF 
     859      !  
     860   END SUBROUTINE interpun2d 
     861 
     862 
     863   SUBROUTINE interpvn(ptab,i1,i2,j1,j2,k1,k2, before) 
     864      !!--------------------------------------------- 
     865      !!   *** ROUTINE interpvn *** 
     866      !!---------------------------------------------     
     867      ! 
     868      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 
     869      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 
     870      LOGICAL, INTENT(in) :: before 
     871      ! 
     872      INTEGER :: ji,jj,jk 
     873      REAL(wp) :: zrhox  
     874      !!---------------------------------------------     
     875      !       
     876      IF (before) THEN           
     877         !interpv entre 1 et k2 et interpv2d en jpkp1 
     878         DO jk=k1,jpk 
     879            DO jj=j1,j2 
     880               DO ji=i1,i2 
     881                  ptab(ji,jj,jk) = e1v(ji,jj) * vn(ji,jj,jk) 
     882                  ptab(ji,jj,jk) = ptab(ji,jj,jk) * fse3v(ji,jj,jk) 
     883               END DO 
     884            END DO 
     885         END DO 
     886      ELSE           
     887         zrhox= Agrif_Rhox() 
     888         DO jk=1,jpkm1 
     889            DO jj=j1,j2 
     890               va(i1:i2,jj,jk) = (ptab(i1:i2,jj,jk)/(zrhox*e1v(i1:i2,jj))) 
     891               va(i1:i2,jj,jk) = va(i1:i2,jj,jk) / fse3v(i1:i2,jj,jk) 
     892            END DO 
     893         END DO 
     894      ENDIF 
     895      !         
     896   END SUBROUTINE interpvn 
     897 
     898   SUBROUTINE interpvn2d(ptab,i1,i2,j1,j2,before) 
     899      !!--------------------------------------------- 
     900      !!   *** ROUTINE interpvn *** 
     901      !!---------------------------------------------     
     902      ! 
     903      INTEGER, INTENT(in) :: i1,i2,j1,j2 
     904      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 
     905      LOGICAL, INTENT(in) :: before 
     906      ! 
     907      INTEGER :: ji,jj 
     908      REAL(wp) :: zrhox  
     909      REAL(wp) :: ztref 
     910      !!---------------------------------------------     
     911      !  
     912      ztref = 1.     
     913      IF (before) THEN  
     914         !interpv entre 1 et k2 et interpv2d en jpkp1 
     915         DO jj=j1,MIN(j2,nlcj-1) 
     916            DO ji=i1,i2 
     917               ptab(ji,jj) = e1v(ji,jj) * ((gcx(ji,jj+1) - gcx(ji,jj))/e2v(ji,jj)) * vmask(ji,jj,1) 
     918            END DO 
     919         END DO 
     920      ELSE            
     921         zrhox = Agrif_Rhox() 
     922         DO ji=i1,i2 
     923            laplacv(ji,j1:j2) = ztref * (ptab(ji,j1:j2)/(zrhox*e1v(ji,j1:j2))) 
     924         END DO 
     925      ENDIF 
     926      !       
     927   END SUBROUTINE interpvn2d 
     928 
     929   SUBROUTINE interpunb(ptab,i1,i2,j1,j2,before,nb,ndir) 
     930      !!---------------------------------------------------------------------- 
     931      !!                  ***  ROUTINE interpunb  *** 
     932      !!----------------------------------------------------------------------   
     933      INTEGER, INTENT(in) :: i1,i2,j1,j2 
     934      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 
     935      LOGICAL, INTENT(in) :: before 
     936      INTEGER, INTENT(in) :: nb , ndir 
     937      !! 
     938      INTEGER :: ji,jj 
     939      REAL(wp) :: zrhoy, zrhot, zt0, zt1, ztcoeff 
     940      LOGICAL :: western_side, eastern_side,northern_side,southern_side 
     941      !!----------------------------------------------------------------------   
     942      ! 
     943      IF (before) THEN  
     944         DO jj=j1,j2 
     945            DO ji=i1,i2 
     946               ptab(ji,jj) = un_b(ji,jj) * e2u(ji,jj) * hu(ji,jj)  
     947            END DO 
     948         END DO 
     949      ELSE 
     950         western_side  = (nb == 1).AND.(ndir == 1) 
     951         eastern_side  = (nb == 1).AND.(ndir == 2) 
     952         southern_side = (nb == 2).AND.(ndir == 1) 
     953         northern_side = (nb == 2).AND.(ndir == 2) 
     954         zrhoy = Agrif_Rhoy() 
     955         zrhot = Agrif_rhot() 
     956         ! Time indexes bounds for integration 
     957         zt0 = REAL(Agrif_NbStepint()  , wp) / zrhot 
     958         zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot       
     959         ! Polynomial interpolation coefficients: 
     960         IF( bdy_tinterp == 1 ) THEN 
     961            ztcoeff = zrhot * (  zt1**2._wp * (       zt1 - 1._wp)        & 
     962                  &      - zt0**2._wp * (       zt0 - 1._wp)        ) 
     963         ELSEIF( bdy_tinterp == 2 ) THEN 
     964            ztcoeff = zrhot * (  zt1        * (       zt1 - 1._wp)**2._wp & 
     965                  &      - zt0        * (       zt0 - 1._wp)**2._wp )  
     966 
     967         ELSE 
     968            ztcoeff = 1 
     969         ENDIF 
     970         !    
     971         IF(western_side) THEN 
     972            ubdy_w(j1:j2) = ubdy_w(j1:j2) + ztcoeff * ptab(i1,j1:j2)   
     973         ENDIF 
     974         IF(eastern_side) THEN 
     975            ubdy_e(j1:j2) = ubdy_e(j1:j2) + ztcoeff * ptab(i1,j1:j2)   
     976         ENDIF 
     977         IF(southern_side) THEN 
     978            ubdy_s(i1:i2) = ubdy_s(i1:i2) + ztcoeff * ptab(i1:i2,j1)  
     979         ENDIF 
     980         IF(northern_side) THEN 
     981            ubdy_n(i1:i2) = ubdy_n(i1:i2) + ztcoeff * ptab(i1:i2,j1)  
     982         ENDIF 
     983         !             
     984         IF( bdy_tinterp == 0 .OR. bdy_tinterp == 2) THEN 
     985            IF(western_side) THEN 
     986               ubdy_w(j1:j2) = ubdy_w(j1:j2) / (zrhoy*e2u(i1,j1:j2))   & 
     987                     &                                  * umask(i1,j1:j2,1) 
     988            ENDIF 
     989            IF(eastern_side) THEN 
     990               ubdy_e(j1:j2) = ubdy_e(j1:j2) / (zrhoy*e2u(i1,j1:j2))   & 
     991                     &                                  * umask(i1,j1:j2,1) 
     992            ENDIF 
     993            IF(southern_side) THEN 
     994               ubdy_s(i1:i2) = ubdy_s(i1:i2) / (zrhoy*e2u(i1:i2,j1))   & 
     995                     &                                  * umask(i1:i2,j1,1) 
     996            ENDIF 
     997            IF(northern_side) THEN 
     998               ubdy_n(i1:i2) = ubdy_n(i1:i2) / (zrhoy*e2u(i1:i2,j1))   & 
     999                     &                                  * umask(i1:i2,j1,1) 
     1000            ENDIF 
     1001         ENDIF 
     1002      ENDIF 
     1003      !  
     1004   END SUBROUTINE interpunb 
     1005 
     1006   SUBROUTINE interpvnb(ptab,i1,i2,j1,j2,before,nb,ndir) 
     1007      !!---------------------------------------------------------------------- 
     1008      !!                  ***  ROUTINE interpvnb  *** 
     1009      !!----------------------------------------------------------------------   
     1010      INTEGER, INTENT(in) :: i1,i2,j1,j2 
     1011      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 
     1012      LOGICAL, INTENT(in) :: before 
     1013      INTEGER, INTENT(in) :: nb , ndir 
     1014      !! 
     1015      INTEGER :: ji,jj 
     1016      REAL(wp) :: zrhox, zrhot, zt0, zt1, ztcoeff    
     1017      LOGICAL :: western_side, eastern_side,northern_side,southern_side 
     1018      !!----------------------------------------------------------------------   
     1019      !  
     1020      IF (before) THEN  
     1021         DO jj=j1,j2 
     1022            DO ji=i1,i2 
     1023               ptab(ji,jj) = vn_b(ji,jj) * e1v(ji,jj) * hv(ji,jj)  
     1024            END DO 
     1025         END DO 
     1026      ELSE 
     1027         western_side  = (nb == 1).AND.(ndir == 1) 
     1028         eastern_side  = (nb == 1).AND.(ndir == 2) 
     1029         southern_side = (nb == 2).AND.(ndir == 1) 
     1030         northern_side = (nb == 2).AND.(ndir == 2) 
     1031         zrhox = Agrif_Rhox() 
     1032         zrhot = Agrif_rhot() 
     1033         ! Time indexes bounds for integration 
     1034         zt0 = REAL(Agrif_NbStepint()  , wp) / zrhot 
     1035         zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot       
     1036         IF( bdy_tinterp == 1 ) THEN 
     1037            ztcoeff = zrhot * (  zt1**2._wp * (       zt1 - 1._wp)        & 
     1038                  &      - zt0**2._wp * (       zt0 - 1._wp)        ) 
     1039         ELSEIF( bdy_tinterp == 2 ) THEN 
     1040            ztcoeff = zrhot * (  zt1        * (       zt1 - 1._wp)**2._wp & 
     1041                  &      - zt0        * (       zt0 - 1._wp)**2._wp )  
     1042 
     1043         ELSE 
     1044            ztcoeff = 1 
     1045         ENDIF 
     1046         ! 
     1047         IF(western_side) THEN 
     1048            vbdy_w(j1:j2) = vbdy_w(j1:j2) + ztcoeff * ptab(i1,j1:j2)   
     1049         ENDIF 
     1050         IF(eastern_side) THEN 
     1051            vbdy_e(j1:j2) = vbdy_e(j1:j2) + ztcoeff * ptab(i1,j1:j2)   
     1052         ENDIF 
     1053         IF(southern_side) THEN 
     1054            vbdy_s(i1:i2) = vbdy_s(i1:i2) + ztcoeff * ptab(i1:i2,j1) 
     1055         ENDIF 
     1056         IF(northern_side) THEN 
     1057            vbdy_n(i1:i2) = vbdy_n(i1:i2) + ztcoeff * ptab(i1:i2,j1)  
     1058         ENDIF 
     1059         !             
     1060         IF( bdy_tinterp == 0 .OR. bdy_tinterp == 2) THEN 
     1061            IF(western_side) THEN 
     1062               vbdy_w(j1:j2) = vbdy_w(j1:j2) / (zrhox*e1v(i1,j1:j2))   & 
     1063                     &                                  * vmask(i1,j1:j2,1) 
     1064            ENDIF 
     1065            IF(eastern_side) THEN 
     1066               vbdy_e(j1:j2) = vbdy_e(j1:j2) / (zrhox*e1v(i1,j1:j2))   & 
     1067                     &                                  * vmask(i1,j1:j2,1) 
     1068            ENDIF 
     1069            IF(southern_side) THEN 
     1070               vbdy_s(i1:i2) = vbdy_s(i1:i2) / (zrhox*e1v(i1:i2,j1))   & 
     1071                     &                                  * vmask(i1:i2,j1,1) 
     1072            ENDIF 
     1073            IF(northern_side) THEN 
     1074               vbdy_n(i1:i2) = vbdy_n(i1:i2) / (zrhox*e1v(i1:i2,j1))   & 
     1075                     &                                  * vmask(i1:i2,j1,1) 
     1076            ENDIF 
     1077         ENDIF 
     1078      ENDIF 
     1079      ! 
     1080   END SUBROUTINE interpvnb 
     1081 
     1082   SUBROUTINE interpub2b(ptab,i1,i2,j1,j2,before,nb,ndir) 
     1083      !!---------------------------------------------------------------------- 
     1084      !!                  ***  ROUTINE interpub2b  *** 
     1085      !!----------------------------------------------------------------------   
     1086      INTEGER, INTENT(in) :: i1,i2,j1,j2 
     1087      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 
     1088      LOGICAL, INTENT(in) :: before 
     1089      INTEGER, INTENT(in) :: nb , ndir 
     1090      !! 
     1091      INTEGER :: ji,jj 
     1092      REAL(wp) :: zrhot, zt0, zt1,zat 
     1093      LOGICAL :: western_side, eastern_side,northern_side,southern_side 
     1094      !!----------------------------------------------------------------------   
     1095      IF( before ) THEN 
     1096         DO jj=j1,j2 
     1097            DO ji=i1,i2 
     1098               ptab(ji,jj) = ub2_b(ji,jj) * e2u(ji,jj) 
     1099            END DO 
     1100         END DO 
     1101      ELSE 
     1102         western_side  = (nb == 1).AND.(ndir == 1) 
     1103         eastern_side  = (nb == 1).AND.(ndir == 2) 
     1104         southern_side = (nb == 2).AND.(ndir == 1) 
     1105         northern_side = (nb == 2).AND.(ndir == 2) 
     1106         zrhot = Agrif_rhot() 
    7281107         ! Time indexes bounds for integration 
    7291108         zt0 = REAL(Agrif_NbStepint()  , wp) / zrhot 
    7301109         zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot 
    731  
    7321110         ! Polynomial interpolation coefficients: 
    733          zaa = zrhot * (  zt1**2._wp * (       zt1 - 1._wp)        & 
    734                  &      - zt0**2._wp * (       zt0 - 1._wp)        ) 
    735          zab = zrhot * (  zt1        * (       zt1 - 1._wp)**2._wp & 
    736                  &      - zt0        * (       zt0 - 1._wp)**2._wp ) 
    7371111         zat = zrhot * (  zt1**2._wp * (-2._wp*zt1 + 3._wp)        & 
    738                  &      - zt0**2._wp * (-2._wp*zt0 + 3._wp)        )  
    739  
    740          ! Do time interpolation 
    741          IF((nbondi == -1).OR.(nbondi == 2)) THEN 
    742             DO jj=1,jpj 
    743                zunb(2,jj) = zaa * zuab(2,jj) + zab * zubb(2,jj) + zat * zutn(2,jj) 
    744                zvnb(2,jj) = zaa * zvab(2,jj) + zab * zvbb(2,jj) + zat * zvtn(2,jj) 
    745             END DO 
    746          ENDIF 
    747          IF((nbondi == 1).OR.(nbondi == 2)) THEN 
    748             DO jj=1,jpj 
    749                zunb(nlci-2,jj) = zaa * zuab(nlci-2,jj) + zab * zubb(nlci-2,jj) + zat * zutn(nlci-2,jj) 
    750                zvnb(nlci-1,jj) = zaa * zvab(nlci-1,jj) + zab * zvbb(nlci-1,jj) + zat * zvtn(nlci-1,jj) 
    751             END DO 
    752          ENDIF 
    753          IF((nbondj == -1).OR.(nbondj == 2)) THEN 
    754             DO ji=1,jpi 
    755                zunb(ji,2) = zaa * zuab(ji,2) + zab * zubb(ji,2) + zat * zutn(ji,2) 
    756                zvnb(ji,2) = zaa * zvab(ji,2) + zab * zvbb(ji,2) + zat * zvtn(ji,2) 
    757             END DO 
    758          ENDIF 
    759          IF((nbondj == 1).OR.(nbondj == 2)) THEN 
    760             DO ji=1,jpi 
    761                zunb(ji,nlcj-1) = zaa * zuab(ji,nlcj-1) + zab * zubb(ji,nlcj-1) + zat * zutn(ji,nlcj-1) 
    762                zvnb(ji,nlcj-2) = zaa * zvab(ji,nlcj-2) + zab * zvbb(ji,nlcj-2) + zat * zvtn(ji,nlcj-2) 
    763             END DO 
    764          ENDIF 
    765          CALL wrk_dealloc( jpi, jpj, zuab, zvab, zubb, zvbb, zutn, zvtn ) 
    766  
    767       ELSE ! Linear interpolation 
    768          zunb(:,:) = 0._wp ; zvnb(:,:) = 0._wp 
    769          CALL Agrif_Bc_variable(zunb,unb_id,calledweight=zt, procname=interpunb) 
    770          CALL Agrif_Bc_variable(zvnb,vnb_id,calledweight=zt, procname=interpvnb) 
    771       ENDIF 
    772       Agrif_UseSpecialValue = .FALSE. 
    773  
    774       ! Fill boundary data arrays: 
    775       IF((nbondi == -1).OR.(nbondi == 2)) THEN 
    776          DO jj=1,jpj 
    777                ubdy_w(jj) = (zunb(2,jj)/(zrhoy*e2u(2,jj))) * umask(2,jj,1) 
    778                vbdy_w(jj) = (zvnb(2,jj)/(zrhox*e1v(2,jj))) * vmask(2,jj,1) 
    779                hbdy_w(jj) = zsshn(2,jj) * tmask(2,jj,1) 
    780          END DO 
    781       ENDIF 
    782  
    783       IF((nbondi == 1).OR.(nbondi == 2)) THEN 
    784          DO jj=1,jpj 
    785                ubdy_e(jj) = zunb(nlci-2,jj)/(zrhoy*e2u(nlci-2,jj)) * umask(nlci-2,jj,1) 
    786                vbdy_e(jj) = zvnb(nlci-1,jj)/(zrhox*e1v(nlci-1,jj)) * vmask(nlci-1,jj,1) 
    787                hbdy_e(jj) = zsshn(nlci-1,jj) * tmask(nlci-1,jj,1) 
    788          END DO 
    789       ENDIF 
    790  
    791       IF((nbondj == -1).OR.(nbondj == 2)) THEN 
    792          DO ji=1,jpi 
    793                ubdy_s(ji) = zunb(ji,2)/(zrhoy*e2u(ji,2)) * umask(ji,2,1) 
    794                vbdy_s(ji) = zvnb(ji,2)/(zrhox*e1v(ji,2)) * vmask(ji,2,1) 
    795                hbdy_s(ji) = zsshn(ji,2) * tmask(ji,2,1) 
    796          END DO 
    797       ENDIF 
    798  
    799       IF((nbondj == 1).OR.(nbondj == 2)) THEN 
    800          DO ji=1,jpi 
    801             ubdy_n(ji) = zunb(ji,nlcj-1)/(zrhoy*e2u(ji,nlcj-1)) * umask(ji,nlcj-1,1) 
    802             vbdy_n(ji) = zvnb(ji,nlcj-2)/(zrhox*e1v(ji,nlcj-2)) * vmask(ji,nlcj-2,1) 
    803             hbdy_n(ji) = zsshn(ji,nlcj-1) * tmask(ji,nlcj-1,1) 
    804          END DO 
    805       ENDIF 
    806  
    807       CALL wrk_dealloc( jpi, jpj, zunb, zvnb, zsshn ) 
    808  
    809    END SUBROUTINE Agrif_dta_ts 
    810  
    811    SUBROUTINE Agrif_ssh( kt ) 
    812       !!---------------------------------------------------------------------- 
    813       !!                  ***  ROUTINE Agrif_DYN  *** 
    814       !!----------------------------------------------------------------------   
    815       INTEGER, INTENT(in) ::   kt 
    816       !! 
    817       !!----------------------------------------------------------------------   
    818  
    819       IF( Agrif_Root() )   RETURN 
    820  
    821  
    822       IF((nbondi == -1).OR.(nbondi == 2)) THEN 
    823          ssha(2,:)=ssha(3,:) 
    824          sshn(2,:)=sshn(3,:) 
    825       ENDIF 
    826  
    827       IF((nbondi == 1).OR.(nbondi == 2)) THEN 
    828          ssha(nlci-1,:)=ssha(nlci-2,:) 
    829          sshn(nlci-1,:)=sshn(nlci-2,:)         
    830       ENDIF 
    831  
    832       IF((nbondj == -1).OR.(nbondj == 2)) THEN 
    833          ssha(:,2)=ssha(:,3) 
    834          sshn(:,2)=sshn(:,3) 
    835       ENDIF 
    836  
    837       IF((nbondj == 1).OR.(nbondj == 2)) THEN 
    838          ssha(:,nlcj-1)=ssha(:,nlcj-2) 
    839          sshn(:,nlcj-1)=sshn(:,nlcj-2)                 
    840       ENDIF 
    841  
    842    END SUBROUTINE Agrif_ssh 
    843  
    844    SUBROUTINE Agrif_ssh_ts( jn ) 
    845       !!---------------------------------------------------------------------- 
    846       !!                  ***  ROUTINE Agrif_ssh_ts  *** 
    847       !!----------------------------------------------------------------------   
    848       INTEGER, INTENT(in) ::   jn 
     1112               &      - zt0**2._wp * (-2._wp*zt0 + 3._wp)        )  
     1113         !  
     1114         IF(western_side ) ubdy_w(j1:j2) = zat * ptab(i1,j1:j2)   
     1115         IF(eastern_side ) ubdy_e(j1:j2) = zat * ptab(i1,j1:j2)   
     1116         IF(southern_side) ubdy_s(i1:i2) = zat * ptab(i1:i2,j1)  
     1117         IF(northern_side) ubdy_n(i1:i2) = zat * ptab(i1:i2,j1)  
     1118      ENDIF 
     1119      !  
     1120   END SUBROUTINE interpub2b 
     1121 
     1122   SUBROUTINE interpvb2b(ptab,i1,i2,j1,j2,before,nb,ndir) 
     1123      !!---------------------------------------------------------------------- 
     1124      !!                  ***  ROUTINE interpvb2b  *** 
     1125      !!----------------------------------------------------------------------   
     1126      INTEGER, INTENT(in) :: i1,i2,j1,j2 
     1127      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 
     1128      LOGICAL, INTENT(in) :: before 
     1129      INTEGER, INTENT(in) :: nb , ndir 
    8491130      !! 
    8501131      INTEGER :: ji,jj 
    851       !!----------------------------------------------------------------------   
    852  
    853       IF((nbondi == -1).OR.(nbondi == 2)) THEN 
    854          DO jj=1,jpj 
    855             ssha_e(2,jj) = hbdy_w(jj) 
    856          END DO 
    857       ENDIF 
    858  
    859       IF((nbondi == 1).OR.(nbondi == 2)) THEN 
    860          DO jj=1,jpj 
    861             ssha_e(nlci-1,jj) = hbdy_e(jj) 
    862          END DO 
    863       ENDIF 
    864  
    865       IF((nbondj == -1).OR.(nbondj == 2)) THEN 
    866          DO ji=1,jpi 
    867             ssha_e(ji,2) = hbdy_s(ji) 
    868          END DO 
    869       ENDIF 
    870  
    871       IF((nbondj == 1).OR.(nbondj == 2)) THEN 
    872          DO ji=1,jpi 
    873             ssha_e(ji,nlcj-1) = hbdy_n(ji) 
    874          END DO 
    875       ENDIF 
    876  
    877    END SUBROUTINE Agrif_ssh_ts 
    878  
    879    SUBROUTINE interpsshn(tabres,i1,i2,j1,j2) 
    880       !!---------------------------------------------------------------------- 
    881       !!                  ***  ROUTINE interpsshn  *** 
    882       !!----------------------------------------------------------------------   
    883       INTEGER, INTENT(in) :: i1,i2,j1,j2 
    884       REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 
    885       !! 
    886       INTEGER :: ji,jj 
    887       !!----------------------------------------------------------------------   
    888  
    889       tabres(i1:i2,j1:j2) = sshn(i1:i2,j1:j2) 
    890  
    891    END SUBROUTINE interpsshn 
    892  
    893    SUBROUTINE interpu(tabres,i1,i2,j1,j2,k1,k2) 
    894       !!---------------------------------------------------------------------- 
    895       !!                  ***  ROUTINE interpu  *** 
    896       !!----------------------------------------------------------------------   
    897       INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 
    898       REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres 
    899       !! 
    900       INTEGER :: ji,jj,jk 
    901       !!----------------------------------------------------------------------   
    902  
    903       DO jk=k1,k2 
     1132      REAL(wp) :: zrhot, zt0, zt1,zat 
     1133      LOGICAL :: western_side, eastern_side,northern_side,southern_side 
     1134      !!----------------------------------------------------------------------   
     1135      ! 
     1136      IF( before ) THEN 
    9041137         DO jj=j1,j2 
    9051138            DO ji=i1,i2 
    906                tabres(ji,jj,jk) = e2u(ji,jj) * un(ji,jj,jk) 
    907                tabres(ji,jj,jk) = tabres(ji,jj,jk) * fse3u_n(ji,jj,jk) 
    908             END DO 
    909          END DO 
    910       END DO 
    911    END SUBROUTINE interpu 
    912  
    913  
    914    SUBROUTINE interpu2d(tabres,i1,i2,j1,j2) 
    915       !!---------------------------------------------------------------------- 
    916       !!                  ***  ROUTINE interpu2d  *** 
    917       !!----------------------------------------------------------------------   
    918       INTEGER, INTENT(in) :: i1,i2,j1,j2 
    919       REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 
    920       !! 
    921       INTEGER :: ji,jj 
    922       !!----------------------------------------------------------------------   
    923  
    924       DO jj=j1,j2 
    925          DO ji=i1,i2 
    926             tabres(ji,jj) = e2u(ji,jj) * ((gcx(ji+1,jj) - gcx(ji,jj))/e1u(ji,jj)) & 
    927                * umask(ji,jj,1) 
    928          END DO 
    929       END DO 
    930  
    931    END SUBROUTINE interpu2d 
    932  
    933  
    934    SUBROUTINE interpv(tabres,i1,i2,j1,j2,k1,k2) 
    935       !!---------------------------------------------------------------------- 
    936       !!                  ***  ROUTINE interpv  *** 
    937       !!----------------------------------------------------------------------   
     1139               ptab(ji,jj) = vb2_b(ji,jj) * e1v(ji,jj) 
     1140            END DO 
     1141         END DO 
     1142      ELSE       
     1143         western_side  = (nb == 1).AND.(ndir == 1) 
     1144         eastern_side  = (nb == 1).AND.(ndir == 2) 
     1145         southern_side = (nb == 2).AND.(ndir == 1) 
     1146         northern_side = (nb == 2).AND.(ndir == 2) 
     1147         zrhot = Agrif_rhot() 
     1148         ! Time indexes bounds for integration 
     1149         zt0 = REAL(Agrif_NbStepint()  , wp) / zrhot 
     1150         zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot 
     1151         ! Polynomial interpolation coefficients: 
     1152         zat = zrhot * (  zt1**2._wp * (-2._wp*zt1 + 3._wp)        & 
     1153               &      - zt0**2._wp * (-2._wp*zt0 + 3._wp)        )  
     1154         ! 
     1155         IF(western_side ) vbdy_w(j1:j2) = zat * ptab(i1,j1:j2)   
     1156         IF(eastern_side ) vbdy_e(j1:j2) = zat * ptab(i1,j1:j2)   
     1157         IF(southern_side) vbdy_s(i1:i2) = zat * ptab(i1:i2,j1)  
     1158         IF(northern_side) vbdy_n(i1:i2) = zat * ptab(i1:i2,j1)  
     1159      ENDIF 
     1160      !       
     1161   END SUBROUTINE interpvb2b 
     1162 
     1163   SUBROUTINE interpe3t(ptab,i1,i2,j1,j2,k1,k2,before,nb,ndir) 
     1164      !!---------------------------------------------------------------------- 
     1165      !!                  ***  ROUTINE interpe3t  *** 
     1166      !!----------------------------------------------------------------------   
     1167      !  
    9381168      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 
    939       REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres 
    940       !! 
     1169      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 
     1170      LOGICAL :: before 
     1171      INTEGER, INTENT(in) :: nb , ndir 
     1172      ! 
    9411173      INTEGER :: ji, jj, jk 
    942       !!----------------------------------------------------------------------   
    943  
    944       DO jk=k1,k2 
    945          DO jj=j1,j2 
    946             DO ji=i1,i2 
    947                tabres(ji,jj,jk) = e1v(ji,jj) * vn(ji,jj,jk) 
    948                tabres(ji,jj,jk) = tabres(ji,jj,jk) * fse3v_n(ji,jj,jk) 
    949             END DO 
    950          END DO 
    951       END DO 
    952  
    953    END SUBROUTINE interpv 
    954  
    955  
    956    SUBROUTINE interpv2d(tabres,i1,i2,j1,j2) 
    957       !!---------------------------------------------------------------------- 
    958       !!                  ***  ROUTINE interpu2d  *** 
    959       !!----------------------------------------------------------------------   
    960       INTEGER, INTENT(in) :: i1,i2,j1,j2 
    961       REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 
    962       !! 
    963       INTEGER :: ji,jj 
    964       !!----------------------------------------------------------------------   
    965  
    966       DO jj=j1,j2 
    967          DO ji=i1,i2 
    968             tabres(ji,jj) = e1v(ji,jj) * ((gcx(ji,jj+1) - gcx(ji,jj))/e2v(ji,jj)) & 
    969                * vmask(ji,jj,1) 
    970          END DO 
    971       END DO 
    972  
    973    END SUBROUTINE interpv2d 
    974  
    975    SUBROUTINE interpunb(tabres,i1,i2,j1,j2) 
    976       !!---------------------------------------------------------------------- 
    977       !!                  ***  ROUTINE interpunb  *** 
    978       !!----------------------------------------------------------------------   
    979       INTEGER, INTENT(in) :: i1,i2,j1,j2 
    980       REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 
    981       !! 
    982       INTEGER :: ji,jj 
    983       !!----------------------------------------------------------------------   
    984  
    985       DO jj=j1,j2 
    986          DO ji=i1,i2 
    987             tabres(ji,jj) = un_b(ji,jj) * e2u(ji,jj) * hu(ji,jj)  
    988          END DO 
    989       END DO 
    990  
    991    END SUBROUTINE interpunb 
    992  
    993    SUBROUTINE interpvnb(tabres,i1,i2,j1,j2) 
    994       !!---------------------------------------------------------------------- 
    995       !!                  ***  ROUTINE interpvnb  *** 
    996       !!----------------------------------------------------------------------   
    997       INTEGER, INTENT(in) :: i1,i2,j1,j2 
    998       REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 
    999       !! 
    1000       INTEGER :: ji,jj 
    1001       !!----------------------------------------------------------------------   
    1002  
    1003       DO jj=j1,j2 
    1004          DO ji=i1,i2 
    1005             tabres(ji,jj) = vn_b(ji,jj) * e1v(ji,jj) * hv(ji,jj) 
    1006          END DO 
    1007       END DO 
    1008  
    1009    END SUBROUTINE interpvnb 
    1010  
    1011    SUBROUTINE interpub2b(tabres,i1,i2,j1,j2) 
    1012       !!---------------------------------------------------------------------- 
    1013       !!                  ***  ROUTINE interpub2b  *** 
    1014       !!----------------------------------------------------------------------   
    1015       INTEGER, INTENT(in) :: i1,i2,j1,j2 
    1016       REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 
    1017       !! 
    1018       INTEGER :: ji,jj 
    1019       !!----------------------------------------------------------------------   
    1020  
    1021       DO jj=j1,j2 
    1022          DO ji=i1,i2 
    1023             tabres(ji,jj) = ub2_b(ji,jj) * e2u(ji,jj) 
    1024          END DO 
    1025       END DO 
    1026  
    1027    END SUBROUTINE interpub2b 
    1028  
    1029    SUBROUTINE interpvb2b(tabres,i1,i2,j1,j2) 
    1030       !!---------------------------------------------------------------------- 
    1031       !!                  ***  ROUTINE interpvb2b  *** 
    1032       !!----------------------------------------------------------------------   
    1033       INTEGER, INTENT(in) :: i1,i2,j1,j2 
    1034       REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 
    1035       !! 
    1036       INTEGER :: ji,jj 
    1037       !!----------------------------------------------------------------------   
    1038  
    1039       DO jj=j1,j2 
    1040          DO ji=i1,i2 
    1041             tabres(ji,jj) = vb2_b(ji,jj) * e1v(ji,jj) 
    1042          END DO 
    1043       END DO 
    1044  
    1045    END SUBROUTINE interpvb2b 
     1174      LOGICAL :: western_side, eastern_side, northern_side, southern_side 
     1175      REAL(wp) :: ztmpmsk       
     1176      !!----------------------------------------------------------------------   
     1177      !     
     1178      IF (before) THEN 
     1179         DO jk=k1,k2 
     1180            DO jj=j1,j2 
     1181               DO ji=i1,i2 
     1182                  ptab(ji,jj,jk) = tmask(ji,jj,jk) * e3t_0(ji,jj,jk) 
     1183               END DO 
     1184            END DO 
     1185         END DO 
     1186      ELSE 
     1187         western_side  = (nb == 1).AND.(ndir == 1) 
     1188         eastern_side  = (nb == 1).AND.(ndir == 2) 
     1189         southern_side = (nb == 2).AND.(ndir == 1) 
     1190         northern_side = (nb == 2).AND.(ndir == 2) 
     1191 
     1192         DO jk=k1,k2 
     1193            DO jj=j1,j2 
     1194               DO ji=i1,i2 
     1195                  ! Get velocity mask at boundary edge points: 
     1196                  IF (western_side)  ztmpmsk = umask(ji    ,jj    ,1) 
     1197                  IF (eastern_side)  ztmpmsk = umask(nlci-2,jj    ,1) 
     1198                  IF (northern_side) ztmpmsk = vmask(ji    ,nlcj-2,1) 
     1199                  IF (southern_side) ztmpmsk = vmask(ji    ,2     ,1) 
     1200 
     1201                  IF (ABS(ptab(ji,jj,jk) - tmask(ji,jj,jk) * e3t_0(ji,jj,jk))*ztmpmsk > 1.D-2) THEN 
     1202                     IF (western_side) THEN 
     1203                        WRITE(numout,*) 'ERROR bathymetry merge at the western border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk 
     1204                     ELSEIF (eastern_side) THEN 
     1205                        WRITE(numout,*) 'ERROR bathymetry merge at the eastern border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk 
     1206                     ELSEIF (southern_side) THEN 
     1207                        WRITE(numout,*) 'ERROR bathymetry merge at the southern border ji,jj,jk', ji+nimpp-1,jj+njmpp-1,jk 
     1208                     ELSEIF (northern_side) THEN 
     1209                        WRITE(numout,*) 'ERROR bathymetry merge at the northen border ji,jj,jk', ji+nimpp-1,jj+njmpp-1,jk 
     1210                     ENDIF 
     1211                     WRITE(numout,*) '      ptab(ji,jj,jk), fse3t(ji,jj,jk) ', ptab(ji,jj,jk), e3t_0(ji,jj,jk) 
     1212                     kindic_agr = kindic_agr + 1 
     1213                  ENDIF 
     1214               END DO 
     1215            END DO 
     1216         END DO 
     1217 
     1218      ENDIF 
     1219      !  
     1220   END SUBROUTINE interpe3t 
     1221 
     1222   SUBROUTINE interpumsk(ptab,i1,i2,j1,j2,k1,k2,before,nb,ndir) 
     1223      !!---------------------------------------------------------------------- 
     1224      !!                  ***  ROUTINE interpumsk  *** 
     1225      !!----------------------------------------------------------------------   
     1226      !  
     1227      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 
     1228      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 
     1229      LOGICAL :: before 
     1230      INTEGER, INTENT(in) :: nb , ndir 
     1231      ! 
     1232      INTEGER :: ji, jj, jk 
     1233      LOGICAL :: western_side, eastern_side    
     1234      !!----------------------------------------------------------------------   
     1235      !     
     1236      IF (before) THEN 
     1237         DO jk=k1,k2 
     1238            DO jj=j1,j2 
     1239               DO ji=i1,i2 
     1240                  ptab(ji,jj,jk) = umask(ji,jj,jk) 
     1241               END DO 
     1242            END DO 
     1243         END DO 
     1244      ELSE 
     1245 
     1246         western_side  = (nb == 1).AND.(ndir == 1) 
     1247         eastern_side  = (nb == 1).AND.(ndir == 2) 
     1248         DO jk=k1,k2 
     1249            DO jj=j1,j2 
     1250               DO ji=i1,i2 
     1251                   ! Velocity mask at boundary edge points: 
     1252                  IF (ABS(ptab(ji,jj,jk) - umask(ji,jj,jk)) > 1.D-2) THEN 
     1253                     IF (western_side) THEN 
     1254                        WRITE(numout,*) 'ERROR with umask at the western border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk 
     1255                        WRITE(numout,*) '      masks: parent, child ', ptab(ji,jj,jk), umask(ji,jj,jk) 
     1256                        kindic_agr = kindic_agr + 1 
     1257                     ELSEIF (eastern_side) THEN 
     1258                        WRITE(numout,*) 'ERROR with umask at the eastern border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk 
     1259                        WRITE(numout,*) '      masks: parent, child ', ptab(ji,jj,jk), umask(ji,jj,jk) 
     1260                        kindic_agr = kindic_agr + 1 
     1261                     ENDIF 
     1262                  ENDIF 
     1263               END DO 
     1264            END DO 
     1265         END DO 
     1266 
     1267      ENDIF 
     1268      !  
     1269   END SUBROUTINE interpumsk 
     1270 
     1271   SUBROUTINE interpvmsk(ptab,i1,i2,j1,j2,k1,k2,before,nb,ndir) 
     1272      !!---------------------------------------------------------------------- 
     1273      !!                  ***  ROUTINE interpvmsk  *** 
     1274      !!----------------------------------------------------------------------   
     1275      !  
     1276      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 
     1277      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 
     1278      LOGICAL :: before 
     1279      INTEGER, INTENT(in) :: nb , ndir 
     1280      ! 
     1281      INTEGER :: ji, jj, jk 
     1282      LOGICAL :: northern_side, southern_side      
     1283      !!----------------------------------------------------------------------   
     1284      !     
     1285      IF (before) THEN 
     1286         DO jk=k1,k2 
     1287            DO jj=j1,j2 
     1288               DO ji=i1,i2 
     1289                  ptab(ji,jj,jk) = vmask(ji,jj,jk) 
     1290               END DO 
     1291            END DO 
     1292         END DO 
     1293      ELSE 
     1294 
     1295         southern_side = (nb == 2).AND.(ndir == 1) 
     1296         northern_side = (nb == 2).AND.(ndir == 2) 
     1297         DO jk=k1,k2 
     1298            DO jj=j1,j2 
     1299               DO ji=i1,i2 
     1300                   ! Velocity mask at boundary edge points: 
     1301                  IF (ABS(ptab(ji,jj,jk) - vmask(ji,jj,jk)) > 1.D-2) THEN 
     1302                     IF (southern_side) THEN 
     1303                        WRITE(numout,*) 'ERROR with vmask at the southern border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk 
     1304                        WRITE(numout,*) '      masks: parent, child ', ptab(ji,jj,jk), vmask(ji,jj,jk) 
     1305                        kindic_agr = kindic_agr + 1 
     1306                     ELSEIF (northern_side) THEN 
     1307                        WRITE(numout,*) 'ERROR with vmask at the northern border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk 
     1308                        WRITE(numout,*) '      masks: parent, child ', ptab(ji,jj,jk), vmask(ji,jj,jk) 
     1309                        kindic_agr = kindic_agr + 1 
     1310                     ENDIF 
     1311                  ENDIF 
     1312               END DO 
     1313            END DO 
     1314         END DO 
     1315 
     1316      ENDIF 
     1317      !  
     1318   END SUBROUTINE interpvmsk 
     1319 
     1320# if defined key_zdftke 
     1321 
     1322   SUBROUTINE interpavm(ptab,i1,i2,j1,j2,k1,k2,before) 
     1323      !!---------------------------------------------------------------------- 
     1324      !!                  ***  ROUTINE interavm  *** 
     1325      !!----------------------------------------------------------------------   
     1326      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 
     1327      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 
     1328      LOGICAL, INTENT(in) :: before 
     1329      !!----------------------------------------------------------------------   
     1330      !       
     1331      IF( before) THEN 
     1332         ptab (i1:i2,j1:j2,k1:k2) = avm_k(i1:i2,j1:j2,k1:k2) 
     1333      ELSE 
     1334         avm_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2) 
     1335      ENDIF 
     1336      ! 
     1337   END SUBROUTINE interpavm 
     1338 
     1339# endif /* key_zdftke */ 
    10461340 
    10471341#else 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/NST_SRC/agrif_opa_sponge.F90

    r6836 r6839  
    11#define SPONGE && define SPONGE_TOP 
    22 
    3 Module agrif_opa_sponge 
     3MODULE agrif_opa_sponge 
    44#if defined key_agrif  && ! defined key_offline 
    55   USE par_oce 
    … …  
    99   USE agrif_oce 
    1010   USE wrk_nemo   
     11   USE lbclnk          ! ocean lateral boundary conditions (or mpp link) 
    1112 
    1213   IMPLICIT NONE 
    1314   PRIVATE 
    1415 
    15    PUBLIC Agrif_Sponge, Agrif_Sponge_Tra, Agrif_Sponge_Dyn, interptsn, interpun, interpvn 
    16  
    17   !! * Substitutions 
     16   PUBLIC Agrif_Sponge, Agrif_Sponge_Tra, Agrif_Sponge_Dyn 
     17   PUBLIC interptsn_sponge, interpun_sponge, interpvn_sponge 
     18 
     19   !! * Substitutions 
    1820#  include "domzgr_substitute.h90" 
    1921   !!---------------------------------------------------------------------- 
    … …  
    2325   !!---------------------------------------------------------------------- 
    2426 
    25    CONTAINS 
     27CONTAINS 
    2628 
    2729   SUBROUTINE Agrif_Sponge_Tra 
    … …  
    3032      !!--------------------------------------------- 
    3133      !! 
    32       INTEGER :: ji,jj,jk,jn 
    3334      REAL(wp) :: timecoeff 
    34       REAL(wp) :: ztsa, zabe1, zabe2, zbtr 
    35       REAL(wp), POINTER, DIMENSION(:,:    ) :: ztu, ztv 
    36       REAL(wp), POINTER, DIMENSION(:,:,:,:) :: ztab 
    37       REAL(wp), POINTER, DIMENSION(:,:,:,:) :: tsbdiff 
    3835 
    3936#if defined SPONGE 
    40       CALL wrk_alloc( jpi, jpj, ztu, ztv ) 
    41       CALL wrk_alloc( jpi, jpj, jpk, jpts, ztab, tsbdiff  ) 
    42  
    4337      timecoeff = REAL(Agrif_NbStepint(),wp)/Agrif_rhot() 
    4438 
     39      CALL Agrif_Sponge 
    4540      Agrif_SpecialValue=0. 
    4641      Agrif_UseSpecialValue = .TRUE. 
    47       ztab = 0.e0 
    48       CALL Agrif_Bc_Variable(ztab, tsa_id,calledweight=timecoeff,procname=interptsn) 
     42      tabspongedone_tsn = .FALSE. 
     43 
     44      CALL Agrif_Bc_Variable(tsn_sponge_id,calledweight=timecoeff,procname=interptsn_sponge) 
     45 
    4946      Agrif_UseSpecialValue = .FALSE. 
    50  
    51       tsbdiff(:,:,:,:) = tsb(:,:,:,:) - ztab(:,:,:,:) 
    52  
    53       CALL Agrif_Sponge 
    54  
    55       DO jn = 1, jpts 
    56          DO jk = 1, jpkm1 
    57             ! 
    58             DO jj = 1, jpjm1 
    59                DO ji = 1, jpim1 
    60                   zabe1 = umask(ji,jj,jk) * spe1ur(ji,jj) * fse3u(ji,jj,jk) 
    61                   zabe2 = vmask(ji,jj,jk) * spe2vr(ji,jj) * fse3v(ji,jj,jk) 
    62                   ztu(ji,jj) = zabe1 * ( tsbdiff(ji+1,jj  ,jk,jn) - tsbdiff(ji,jj,jk,jn) ) 
    63                   ztv(ji,jj) = zabe2 * ( tsbdiff(ji  ,jj+1,jk,jn) - tsbdiff(ji,jj,jk,jn) ) 
    64                ENDDO 
    65             ENDDO 
    66  
    67             DO jj = 2, jpjm1 
    68                DO ji = 2, jpim1 
    69                   zbtr = spbtr2(ji,jj) / fse3t(ji,jj,jk) 
    70                   ! horizontal diffusive trends 
    71                   ztsa = zbtr * (  ztu(ji,jj) - ztu(ji-1,jj  )   & 
    72                   &              + ztv(ji,jj) - ztv(ji  ,jj-1)  ) 
    73                   ! add it to the general tracer trends 
    74                   tsa(ji,jj,jk,jn) = tsa(ji,jj,jk,jn) + ztsa 
    75                END DO 
    76             END DO 
    77             ! 
    78          ENDDO 
    79       ENDDO 
    80  
    81       CALL wrk_dealloc( jpi, jpj, ztu, ztv ) 
    82       CALL wrk_dealloc( jpi, jpj, jpk, jpts, ztab, tsbdiff  ) 
    8347#endif 
    8448 
    … …  
    9054      !!--------------------------------------------- 
    9155      !! 
    92       INTEGER :: ji,jj,jk 
    9356      REAL(wp) :: timecoeff 
    94       REAL(wp) :: ze2u, ze1v, zua, zva, zbtr 
    95       REAL(wp), POINTER, DIMENSION(:,:,:) :: ubdiff, vbdiff 
    96       REAL(wp), POINTER, DIMENSION(:,:,:) :: rotdiff, hdivdiff 
    97       REAL(wp), POINTER, DIMENSION(:,:,:) :: ztab 
    9857 
    9958#if defined SPONGE 
    100       CALL wrk_alloc( jpi, jpj, jpk, ztab, ubdiff, vbdiff, rotdiff, hdivdiff ) 
    101  
    10259      timecoeff = REAL(Agrif_NbStepint(),wp)/Agrif_rhot() 
    10360 
    10461      Agrif_SpecialValue=0. 
    10562      Agrif_UseSpecialValue = ln_spc_dyn 
    106       ztab = 0.e0 
    107       CALL Agrif_Bc_Variable(ztab, ua_id,calledweight=timecoeff,procname=interpun) 
     63 
     64      tabspongedone_u = .FALSE. 
     65      tabspongedone_v = .FALSE.          
     66      CALL Agrif_Bc_Variable(un_sponge_id,calledweight=timecoeff,procname=interpun_sponge) 
     67 
     68      tabspongedone_u = .FALSE. 
     69      tabspongedone_v = .FALSE. 
     70      CALL Agrif_Bc_Variable(vn_sponge_id,calledweight=timecoeff,procname=interpvn_sponge) 
     71 
    10872      Agrif_UseSpecialValue = .FALSE. 
    109  
    110       ubdiff(:,:,:) = ( ub(:,:,:) - ztab(:,:,:) ) * umask(:,:,:) 
    111  
    112       ztab = 0.e0 
    113       Agrif_SpecialValue=0. 
    114       Agrif_UseSpecialValue = ln_spc_dyn 
    115       CALL Agrif_Bc_Variable(ztab, va_id,calledweight=timecoeff,procname=interpvn) 
    116       Agrif_UseSpecialValue = .FALSE. 
    117  
    118       vbdiff(:,:,:) = ( vb(:,:,:) - ztab(:,:,:) ) * vmask(:,:,:) 
    119  
    120       CALL Agrif_Sponge 
    121  
    122       DO jk = 1,jpkm1 
    123          ubdiff(:,:,jk) = ubdiff(:,:,jk) * spe1ur2(:,:) 
    124          vbdiff(:,:,jk) = vbdiff(:,:,jk) * spe2vr2(:,:) 
    125       ENDDO 
    126        
    127       hdivdiff = 0. 
    128       rotdiff = 0. 
    129  
    130       DO jk = 1, jpkm1                                 ! Horizontal slab 
    131          !                                             ! =============== 
    132  
    133          !                                             ! -------- 
    134          ! Horizontal divergence                       !   div 
    135          !                                             ! -------- 
    136          DO jj = 2, jpjm1 
    137             DO ji = 2, jpim1   ! vector opt. 
    138                zbtr = spbtr2(ji,jj) / fse3t(ji,jj,jk) 
    139                hdivdiff(ji,jj,jk) =  (  e2u(ji  ,jj  ) * fse3u(ji  ,jj  ,jk) * ubdiff(ji  ,jj  ,jk)     & 
    140                   &                   - e2u(ji-1,jj  ) * fse3u(ji-1,jj  ,jk) * ubdiff(ji-1,jj  ,jk)     & 
    141                   &                   + e1v(ji  ,jj  ) * fse3v(ji  ,jj  ,jk) * vbdiff(ji  ,jj  ,jk)     & 
    142                   &                   - e1v(ji  ,jj-1) * fse3v(ji  ,jj-1,jk) * vbdiff(ji  ,jj-1,jk)  ) * zbtr 
    143             END DO 
    144          END DO 
    145  
    146          DO jj = 1, jpjm1 
    147             DO ji = 1, jpim1   ! vector opt. 
    148                zbtr = spbtr3(ji,jj) * fse3f(ji,jj,jk) 
    149                rotdiff(ji,jj,jk) = (  e2v(ji+1,jj  ) * vbdiff(ji+1,jj  ,jk) - e2v(ji,jj) * vbdiff(ji,jj,jk)    & 
    150                   &                 - e1u(ji  ,jj+1) * ubdiff(ji  ,jj+1,jk) + e1u(ji,jj) * ubdiff(ji,jj,jk)  ) & 
    151                   &               * fmask(ji,jj,jk) * zbtr 
    152             END DO 
    153          END DO 
    154  
    155       ENDDO 
    156  
    157       !                                                ! =============== 
    158       DO jk = 1, jpkm1                                 ! Horizontal slab 
    159          !                                             ! =============== 
    160          DO jj = 2, jpjm1 
    161             DO ji = 2, jpim1   ! vector opt. 
    162                ! horizontal diffusive trends 
    163                zua = - ( rotdiff (ji  ,jj,jk) - rotdiff (ji,jj-1,jk) ) / ( e2u(ji,jj) * fse3u(ji,jj,jk) )   & 
    164                      + ( hdivdiff(ji+1,jj,jk) - hdivdiff(ji,jj  ,jk) ) / e1u(ji,jj) 
    165  
    166                zva = + ( rotdiff (ji,jj  ,jk) - rotdiff (ji-1,jj,jk) ) / ( e1v(ji,jj) * fse3v(ji,jj,jk) )   & 
    167                      + ( hdivdiff(ji,jj+1,jk) - hdivdiff(ji  ,jj,jk) ) / e2v(ji,jj) 
    168                ! add it to the general momentum trends 
    169                ua(ji,jj,jk) = ua(ji,jj,jk) + zua 
    170                va(ji,jj,jk) = va(ji,jj,jk) + zva 
    171             END DO 
    172          END DO 
    173          !                                             ! =============== 
    174       END DO                                           !   End of slab 
    175       !                                                ! =============== 
    176       CALL wrk_dealloc( jpi, jpj, jpk, ztab, ubdiff, vbdiff, rotdiff, hdivdiff ) 
    17773#endif 
    17874 
    … …  
    19995         CALL wrk_alloc( jpi, jpj, ztabramp ) 
    20096 
    201          ispongearea  = 2 + 2 * Agrif_irhox() 
     97         ispongearea  = 2 + nn_sponge_len * Agrif_irhox() 
    20298         ilci = nlci - ispongearea 
    20399         ilcj = nlcj - ispongearea  
    204100         z1spongearea = 1._wp / REAL( ispongearea - 2 ) 
    205          spbtr2(:,:) = 1. / ( e1t(:,:) * e2t(:,:) ) 
    206  
    207          ztabramp(:,:) = 0. 
     101 
     102         ztabramp(:,:) = 0._wp 
    208103 
    209104         IF( (nbondi == -1) .OR. (nbondi == 2) ) THEN 
    … …  
    254149      ! Tracers 
    255150      IF( .NOT. spongedoneT ) THEN 
    256          spe1ur(:,:) = 0. 
    257          spe2vr(:,:) = 0. 
    258  
    259          IF( (nbondi == -1) .OR. (nbondi == 2) ) THEN 
    260             spe1ur(2:ispongearea-1,:       ) = visc_tra                                        & 
    261                &                             *    0.5 * (  ztabramp(2:ispongearea-1,:      )   & 
    262                &                                         + ztabramp(3:ispongearea  ,:      ) ) & 
    263                &                             * e2u(2:ispongearea-1,:) / e1u(2:ispongearea-1,:) 
    264  
    265             spe2vr(2:ispongearea  ,1:jpjm1 ) = visc_tra                                        & 
    266                &                             *    0.5 * (  ztabramp(2:ispongearea  ,1:jpjm1)   & 
    267                &                                         + ztabramp(2:ispongearea,2  :jpj  ) ) & 
    268                &                             * e1v(2:ispongearea,1:jpjm1) / e2v(2:ispongearea,1:jpjm1) 
    269          ENDIF 
    270  
    271          IF( (nbondi == 1) .OR. (nbondi == 2) ) THEN 
    272             spe1ur(ilci+1:nlci-2,:        ) = visc_tra                                   & 
    273                &                            * 0.5 * (  ztabramp(ilci+1:nlci-2,:      )   &  
    274                &                                     + ztabramp(ilci+2:nlci-1,:      ) ) & 
    275                &                            * e2u(ilci+1:nlci-2,:) / e1u(ilci+1:nlci-2,:) 
    276  
    277             spe2vr(ilci+1:nlci-1,1:jpjm1  )  = visc_tra                                  & 
    278                &                            * 0.5 * (  ztabramp(ilci+1:nlci-1,1:jpjm1)   &  
    279                &                                     + ztabramp(ilci+1:nlci-1,2:jpj  ) ) &  
    280                &                            * e1v(ilci+1:nlci-1,1:jpjm1) / e2v(ilci+1:nlci-1,1:jpjm1) 
    281          ENDIF 
    282  
    283          IF( (nbondj == -1) .OR. (nbondj == 2) ) THEN 
    284             spe1ur(1:jpim1,2:ispongearea  ) = visc_tra                                     & 
    285                &                            * 0.5 * (  ztabramp(1:jpim1,2:ispongearea  )   &  
    286                &                                     + ztabramp(2:jpi  ,2:ispongearea  ) ) & 
    287                &                            * e2u(1:jpim1,2:ispongearea) / e1u(1:jpim1,2:ispongearea) 
    288     
    289             spe2vr(:      ,2:ispongearea-1) = visc_tra                                     & 
    290                &                            * 0.5 * (  ztabramp(:      ,2:ispongearea-1)   & 
    291                &                                     + ztabramp(:      ,3:ispongearea  ) ) & 
    292                &                            * e1v(:,2:ispongearea-1) / e2v(:,2:ispongearea-1) 
    293          ENDIF 
    294  
    295          IF( (nbondj == 1) .OR. (nbondj == 2) ) THEN 
    296             spe1ur(1:jpim1,ilcj+1:nlcj-1) = visc_tra                                   & 
    297                &                          * 0.5 * (  ztabramp(1:jpim1,ilcj+1:nlcj-1)   & 
    298                &                                   + ztabramp(2:jpi  ,ilcj+1:nlcj-1) ) & 
    299                &                                * e2u(1:jpim1,ilcj+1:nlcj-1) / e1u(1:jpim1,ilcj+1:nlcj-1) 
    300  
    301             spe2vr(:      ,ilcj+1:nlcj-2) = visc_tra                                   & 
    302                &                          * 0.5 * (  ztabramp(:      ,ilcj+1:nlcj-2)   & 
    303                &                                   + ztabramp(:      ,ilcj+2:nlcj-1) ) & 
    304                &                                * e1v(:,ilcj+1:nlcj-2) / e2v(:,ilcj+1:nlcj-2) 
    305          ENDIF 
     151         fsaht_spu(:,:) = 0._wp 
     152         fsaht_spv(:,:) = 0._wp 
     153         DO jj = 2, jpjm1 
     154            DO ji = 2, jpim1   ! vector opt. 
     155               fsaht_spu(ji,jj) = 0.5_wp * visc_tra * (ztabramp(ji,jj) + ztabramp(ji+1,jj  )) 
     156               fsaht_spv(ji,jj) = 0.5_wp * visc_tra * (ztabramp(ji,jj) + ztabramp(ji  ,jj+1)) 
     157            END DO 
     158         END DO 
     159 
     160         CALL lbc_lnk( fsaht_spu, 'U', 1. )   ! Lateral boundary conditions 
     161         CALL lbc_lnk( fsaht_spv, 'V', 1. ) 
    306162         spongedoneT = .TRUE. 
    307163      ENDIF 
    … …  
    309165      ! Dynamics 
    310166      IF( .NOT. spongedoneU ) THEN 
    311          spe1ur2(:,:) = 0. 
    312          spe2vr2(:,:) = 0. 
    313  
    314          IF( (nbondi == -1) .OR. (nbondi == 2) ) THEN 
    315             spe1ur2(2:ispongearea-1,:      ) = visc_dyn                                   & 
    316                &                             * 0.5 * (  ztabramp(2:ispongearea-1,:      ) & 
    317                &                                      + ztabramp(3:ispongearea  ,:      ) ) 
    318             spe2vr2(2:ispongearea  ,1:jpjm1) = visc_dyn                                   & 
    319                &                             * 0.5 * (  ztabramp(2:ispongearea  ,1:jpjm1) & 
    320                &                                      + ztabramp(2:ispongearea  ,2:jpj  ) )  
    321          ENDIF 
    322  
    323          IF( (nbondi == 1) .OR. (nbondi == 2) ) THEN 
    324             spe1ur2(ilci+1:nlci-2  ,:      ) = visc_dyn                                   & 
    325                &                             * 0.5 * (  ztabramp(ilci+1:nlci-2, :       ) & 
    326                &                                      + ztabramp(ilci+2:nlci-1, :       ) )                       
    327             spe2vr2(ilci+1:nlci-1  ,1:jpjm1) = visc_dyn                                   & 
    328                &                             * 0.5 * (  ztabramp(ilci+1:nlci-1,1:jpjm1  ) & 
    329                &                                      + ztabramp(ilci+1:nlci-1,2:jpj    ) )  
    330          ENDIF 
    331  
    332          IF( (nbondj == -1) .OR. (nbondj == 2) ) THEN 
    333             spe1ur2(1:jpim1,2:ispongearea  ) = visc_dyn                                   &   
    334                &                             * 0.5 * (  ztabramp(1:jpim1,2:ispongearea  ) & 
    335                &                                      + ztabramp(2:jpi  ,2:ispongearea  ) )  
    336             spe2vr2(:      ,2:ispongearea-1) = visc_dyn                                   & 
    337                &                             * 0.5 * (  ztabramp(:      ,2:ispongearea-1) & 
    338                &                                      + ztabramp(:      ,3:ispongearea  ) ) 
    339          ENDIF 
    340  
    341          IF( (nbondj == 1) .OR. (nbondj == 2) ) THEN 
    342             spe1ur2(1:jpim1,ilcj+1:nlcj-1  ) = visc_dyn                                   & 
    343                &                             * 0.5 * (  ztabramp(1:jpim1,ilcj+1:nlcj-1  ) & 
    344                &                                      + ztabramp(2:jpi  ,ilcj+1:nlcj-1  ) )  
    345             spe2vr2(:      ,ilcj+1:nlcj-2  ) = visc_dyn                                   & 
    346                &                             * 0.5 * (  ztabramp(:      ,ilcj+1:nlcj-2  ) & 
    347                &                                      + ztabramp(:      ,ilcj+2:nlcj-1  ) ) 
    348          ENDIF 
     167         fsahm_spt(:,:) = 0._wp 
     168         fsahm_spf(:,:) = 0._wp 
     169         DO jj = 2, jpjm1 
     170            DO ji = 2, jpim1   ! vector opt. 
     171               fsahm_spt(ji,jj) = visc_dyn * ztabramp(ji,jj) 
     172               fsahm_spf(ji,jj) = 0.25_wp * visc_dyn * ( ztabramp(ji,jj) + ztabramp(ji  ,jj+1) & 
     173                                                     &  +ztabramp(ji,jj) + ztabramp(ji+1,jj  ) ) 
     174            END DO 
     175         END DO 
     176 
     177         CALL lbc_lnk( fsahm_spt, 'T', 1. )   ! Lateral boundary conditions 
     178         CALL lbc_lnk( fsahm_spf, 'F', 1. ) 
    349179         spongedoneU = .TRUE. 
    350          spbtr3(:,:) = 1. / ( e1f(:,:) * e2f(:,:) ) 
    351180      ENDIF 
    352181      ! 
    … …  
    357186   END SUBROUTINE Agrif_Sponge 
    358187 
    359    SUBROUTINE interptsn(tabres,i1,i2,j1,j2,k1,k2,n1,n2) 
    360       !!--------------------------------------------- 
    361       !!   *** ROUTINE interptsn *** 
     188   SUBROUTINE interptsn_sponge(tabres,i1,i2,j1,j2,k1,k2,n1,n2,before) 
     189      !!--------------------------------------------- 
     190      !!   *** ROUTINE interptsn_sponge *** 
    362191      !!--------------------------------------------- 
    363192      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2 
    364193      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres 
    365  
    366       tabres(i1:i2,j1:j2,k1:k2,n1:n2) = tsn(i1:i2,j1:j2,k1:k2,n1:n2) 
    367  
    368    END SUBROUTINE interptsn 
    369  
    370    SUBROUTINE interpun(tabres,i1,i2,j1,j2,k1,k2) 
    371       !!--------------------------------------------- 
    372       !!   *** ROUTINE interpun *** 
    373       !!--------------------------------------------- 
     194      LOGICAL, INTENT(in) :: before 
     195 
     196 
     197      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices 
     198      INTEGER  ::   iku, ikv 
     199      REAL(wp) :: ztsa, zabe1, zabe2, zbtr 
     200      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2) :: ztu, ztv 
     201      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2) ::tsbdiff 
     202      ! 
     203      IF (before) THEN 
     204         tabres(i1:i2,j1:j2,k1:k2,n1:n2) = tsn(i1:i2,j1:j2,k1:k2,n1:n2) 
     205      ELSE    
     206    
     207         tsbdiff(:,:,:,:) = tsb(i1:i2,j1:j2,:,:) - tabres(:,:,:,:)     
     208         DO jn = 1, jpts             
     209            DO jk = 1, jpkm1 
     210               DO jj = j1,j2-1 
     211                  DO ji = i1,i2-1 
     212                     zabe1 = fsaht_spu(ji,jj) * umask(ji,jj,jk) * re2u_e1u(ji,jj) * fse3u_n(ji,jj,jk) 
     213                     zabe2 = fsaht_spv(ji,jj) * vmask(ji,jj,jk) * re1v_e2v(ji,jj) * fse3v_n(ji,jj,jk) 
     214                     ztu(ji,jj,jk) = zabe1 * ( tsbdiff(ji+1,jj  ,jk,jn) - tsbdiff(ji,jj,jk,jn) )  
     215                     ztv(ji,jj,jk) = zabe2 * ( tsbdiff(ji  ,jj+1,jk,jn) - tsbdiff(ji,jj,jk,jn) ) 
     216                  ENDDO 
     217               ENDDO 
     218 
     219               IF( ln_zps ) THEN      ! set gradient at partial step level 
     220                  DO jj = j1,j2-1 
     221                     DO ji = i1,i2-1 
     222                        ! last level 
     223                        iku = mbku(ji,jj) 
     224                        ikv = mbkv(ji,jj) 
     225                        IF( iku == jk ) THEN 
     226                           ztu(ji,jj,jk) = 0._wp 
     227                        ENDIF 
     228                        IF( ikv == jk ) THEN 
     229                           ztv(ji,jj,jk) = 0._wp 
     230                        ENDIF 
     231                     END DO 
     232                  END DO 
     233               ENDIF 
     234            ENDDO 
     235 
     236            DO jk = 1, jpkm1 
     237               DO jj = j1+1,j2-1 
     238                  DO ji = i1+1,i2-1 
     239 
     240                     IF (.NOT. tabspongedone_tsn(ji,jj)) THEN  
     241                        zbtr = r1_e12t(ji,jj) / fse3t_n(ji,jj,jk) 
     242                        ! horizontal diffusive trends 
     243                        ztsa = zbtr * (  ztu(ji,jj,jk) - ztu(ji-1,jj,jk) + ztv(ji,jj,jk) - ztv(ji  ,jj-1,jk)  ) 
     244                        ! add it to the general tracer trends 
     245                        tsa(ji,jj,jk,jn) = tsa(ji,jj,jk,jn) + ztsa 
     246                     ENDIF 
     247 
     248                  ENDDO 
     249               ENDDO 
     250 
     251            ENDDO 
     252         ENDDO 
     253 
     254         tabspongedone_tsn(i1+1:i2-1,j1+1:j2-1) = .TRUE. 
     255 
     256      ENDIF 
     257 
     258   END SUBROUTINE interptsn_sponge 
     259 
     260   SUBROUTINE interpun_sponge(tabres,i1,i2,j1,j2,k1,k2, before) 
     261      !!--------------------------------------------- 
     262      !!   *** ROUTINE interpun_sponge *** 
     263      !!---------------------------------------------     
    374264      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 
    375265      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres 
    376  
    377       tabres(i1:i2,j1:j2,k1:k2) = un(i1:i2,j1:j2,k1:k2) 
    378  
    379    END SUBROUTINE interpun 
    380  
    381    SUBROUTINE interpvn(tabres,i1,i2,j1,j2,k1,k2) 
    382       !!--------------------------------------------- 
    383       !!   *** ROUTINE interpvn *** 
    384       !!--------------------------------------------- 
     266      LOGICAL, INTENT(in) :: before 
     267 
     268      INTEGER :: ji,jj,jk 
     269 
     270      ! sponge parameters  
     271      REAL(wp) :: ze2u, ze1v, zua, zva, zbtr 
     272      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2) :: ubdiff 
     273      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2) :: rotdiff, hdivdiff 
     274      INTEGER :: jmax 
     275      ! 
     276 
     277 
     278      IF (before) THEN 
     279         tabres = un(i1:i2,j1:j2,:) 
     280      ELSE 
     281 
     282         ubdiff(i1:i2,j1:j2,:) = (ub(i1:i2,j1:j2,:) - tabres(:,:,:))*umask(i1:i2,j1:j2,:) 
     283 
     284         DO jk = 1, jpkm1                                 ! Horizontal slab 
     285            !                                             ! =============== 
     286 
     287            !                                             ! -------- 
     288            ! Horizontal divergence                       !   div 
     289            !                                             ! -------- 
     290            DO jj = j1,j2 
     291               DO ji = i1+1,i2   ! vector opt. 
     292                  zbtr = r1_e12t(ji,jj) / fse3t_n(ji,jj,jk) * fsahm_spt(ji,jj) 
     293                  hdivdiff(ji,jj,jk) = (  e2u(ji  ,jj)*fse3u_n(ji  ,jj,jk) * ubdiff(ji  ,jj,jk) & 
     294                                     &   -e2u(ji-1,jj)*fse3u_n(ji-1,jj,jk) * ubdiff(ji-1,jj,jk) ) * zbtr 
     295               END DO 
     296            END DO 
     297 
     298            DO jj = j1,j2-1 
     299               DO ji = i1,i2   ! vector opt. 
     300                  zbtr = r1_e12f(ji,jj) * fse3f_n(ji,jj,jk) * fsahm_spf(ji,jj) 
     301                  rotdiff(ji,jj,jk) = (-e1u(ji,jj+1) * ubdiff(ji,jj+1,jk) & 
     302                                       +e1u(ji,jj  ) * ubdiff(ji,jj  ,jk) &  
     303                                    & ) * fmask(ji,jj,jk) * zbtr  
     304               END DO 
     305            END DO 
     306         ENDDO 
     307 
     308         ! 
     309 
     310 
     311 
     312         DO jj = j1+1, j2-1 
     313            DO ji = i1+1, i2-1   ! vector opt. 
     314 
     315               IF (.NOT. tabspongedone_u(ji,jj)) THEN 
     316                  DO jk = 1, jpkm1                                 ! Horizontal slab 
     317                     ze2u = rotdiff (ji,jj,jk) 
     318                     ze1v = hdivdiff(ji,jj,jk) 
     319                     ! horizontal diffusive trends 
     320                     zua = - ( ze2u - rotdiff (ji,jj-1,jk)) / ( e2u(ji,jj) * fse3u_n(ji,jj,jk) )   & 
     321                           + ( hdivdiff(ji+1,jj,jk) - ze1v  ) / e1u(ji,jj) 
     322 
     323                     ! add it to the general momentum trends 
     324                     ua(ji,jj,jk) = ua(ji,jj,jk) + zua 
     325 
     326                  END DO 
     327               ENDIF 
     328 
     329            END DO 
     330         END DO 
     331 
     332         tabspongedone_u(i1+1:i2-1,j1+1:j2-1) = .TRUE. 
     333 
     334         jmax = j2-1 
     335         IF ((nbondj == 1).OR.(nbondj == 2)) jmax = MIN(jmax,nlcj-3) 
     336 
     337         DO jj = j1+1, jmax 
     338            DO ji = i1+1, i2   ! vector opt. 
     339 
     340               IF (.NOT. tabspongedone_v(ji,jj)) THEN 
     341                  DO jk = 1, jpkm1                                 ! Horizontal slab 
     342                     ze2u = rotdiff (ji,jj,jk) 
     343                     ze1v = hdivdiff(ji,jj,jk) 
     344 
     345                     ! horizontal diffusive trends 
     346                     zva = + ( ze2u - rotdiff (ji-1,jj,jk)) / ( e1v(ji,jj) * fse3v_n(ji,jj,jk) )   & 
     347                           + ( hdivdiff(ji,jj+1,jk) - ze1v  ) / e2v(ji,jj) 
     348 
     349                     ! add it to the general momentum trends 
     350                     va(ji,jj,jk) = va(ji,jj,jk) + zva 
     351                  END DO 
     352               ENDIF 
     353 
     354            END DO 
     355         END DO 
     356 
     357 
     358         tabspongedone_v(i1+1:i2,j1+1:jmax) = .TRUE. 
     359 
     360      ENDIF 
     361 
     362 
     363   END SUBROUTINE interpun_sponge 
     364 
     365 
     366   SUBROUTINE interpvn_sponge(tabres,i1,i2,j1,j2,k1,k2, before,nb,ndir) 
     367      !!--------------------------------------------- 
     368      !!   *** ROUTINE interpvn_sponge *** 
     369      !!---------------------------------------------  
    385370      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 
    386371      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres 
    387  
    388       tabres(i1:i2,j1:j2,k1:k2) = vn(i1:i2,j1:j2,k1:k2) 
    389  
    390    END SUBROUTINE interpvn 
     372      LOGICAL, INTENT(in) :: before 
     373      INTEGER, INTENT(in) :: nb , ndir 
     374 
     375      INTEGER :: ji,jj,jk 
     376 
     377      REAL(wp) :: ze2u, ze1v, zua, zva, zbtr 
     378 
     379      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2) :: vbdiff 
     380      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2) :: rotdiff, hdivdiff 
     381      INTEGER :: imax 
     382      ! 
     383 
     384      IF (before) THEN  
     385         tabres = vn(i1:i2,j1:j2,:) 
     386      ELSE 
     387 
     388         vbdiff(i1:i2,j1:j2,:) = (vb(i1:i2,j1:j2,:) - tabres(:,:,:))*vmask(i1:i2,j1:j2,:) 
     389 
     390         DO jk = 1, jpkm1                                 ! Horizontal slab 
     391            !                                             ! =============== 
     392 
     393            !                                             ! -------- 
     394            ! Horizontal divergence                       !   div 
     395            !                                             ! -------- 
     396            DO jj = j1+1,j2 
     397               DO ji = i1,i2   ! vector opt. 
     398                  zbtr = r1_e12t(ji,jj) / fse3t_n(ji,jj,jk) * fsahm_spt(ji,jj) 
     399                  hdivdiff(ji,jj,jk) = ( e1v(ji,jj  ) * fse3v(ji,jj  ,jk) * vbdiff(ji,jj  ,jk)  & 
     400                                     &  -e1v(ji,jj-1) * fse3v(ji,jj-1,jk) * vbdiff(ji,jj-1,jk)  ) * zbtr 
     401               END DO 
     402            END DO 
     403            DO jj = j1,j2 
     404               DO ji = i1,i2-1   ! vector opt. 
     405                  zbtr = r1_e12f(ji,jj) * fse3f_n(ji,jj,jk) * fsahm_spf(ji,jj) 
     406                  rotdiff(ji,jj,jk) = ( e2v(ji+1,jj) * vbdiff(ji+1,jj,jk) &  
     407                                    &  -e2v(ji  ,jj) * vbdiff(ji  ,jj,jk) & 
     408                                    & ) * fmask(ji,jj,jk) * zbtr 
     409               END DO 
     410            END DO 
     411         ENDDO 
     412 
     413         !                                                ! =============== 
     414         !                                                 
     415 
     416         imax = i2-1 
     417         IF ((nbondi == 1).OR.(nbondi == 2)) imax = MIN(imax,nlci-3) 
     418 
     419         DO jj = j1+1, j2 
     420            DO ji = i1+1, imax   ! vector opt. 
     421               IF (.NOT. tabspongedone_u(ji,jj)) THEN 
     422                  DO jk = 1, jpkm1                                 ! Horizontal slab 
     423                     ze2u = rotdiff (ji,jj,jk) 
     424                     ze1v = hdivdiff(ji,jj,jk) 
     425                     ! horizontal diffusive trends 
     426                     zua = - ( ze2u - rotdiff (ji,jj-1,jk)) / ( e2u(ji,jj) * fse3u_n(ji,jj,jk) ) + ( hdivdiff(ji+1,jj,jk) - ze1v) & 
     427                           / e1u(ji,jj) 
     428 
     429 
     430                     ! add it to the general momentum trends 
     431                     ua(ji,jj,jk) = ua(ji,jj,jk) + zua 
     432                  END DO 
     433 
     434               ENDIF 
     435            END DO 
     436         END DO 
     437 
     438         tabspongedone_u(i1+1:imax,j1+1:j2) = .TRUE. 
     439 
     440         DO jj = j1+1, j2-1 
     441            DO ji = i1+1, i2-1   ! vector opt. 
     442               IF (.NOT. tabspongedone_v(ji,jj)) THEN 
     443                  DO jk = 1, jpkm1                                 ! Horizontal slab 
     444                     ze2u = rotdiff (ji,jj,jk) 
     445                     ze1v = hdivdiff(ji,jj,jk) 
     446                     ! horizontal diffusive trends 
     447 
     448                     zva = + ( ze2u - rotdiff (ji-1,jj,jk)) / ( e1v(ji,jj) * fse3v_n(ji,jj,jk) ) + ( hdivdiff(ji,jj+1,jk) - ze1v) & 
     449                           / e2v(ji,jj) 
     450 
     451                     ! add it to the general momentum trends 
     452                     va(ji,jj,jk) = va(ji,jj,jk) + zva 
     453                  END DO 
     454               ENDIF 
     455            END DO 
     456         END DO 
     457         tabspongedone_v(i1+1:i2-1,j1+1:j2-1) = .TRUE. 
     458      ENDIF 
     459 
     460   END SUBROUTINE interpvn_sponge 
    391461 
    392462#else 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/NST_SRC/agrif_opa_update.F90

    r6836 r6839  
    1 #define TWO_WAY 
    2  
     1#define TWO_WAY        /* TWO WAY NESTING */ 
     2#undef DECAL_FEEDBACK /* SEPARATION of INTERFACES*/ 
     3  
    34MODULE agrif_opa_update 
    45#if defined key_agrif  && ! defined key_offline 
    … …  
    1112   USE wrk_nemo   
    1213   USE dynspg_oce 
     14   USE zdf_oce        ! vertical physics: ocean variables  
    1315 
    1416   IMPLICIT NONE 
    1517   PRIVATE 
    1618 
    17    PUBLIC Agrif_Update_Tra, Agrif_Update_Dyn 
    18  
    19    INTEGER, PUBLIC :: nbcline = 0 
    20  
     19   PUBLIC Agrif_Update_Tra, Agrif_Update_Dyn,Update_Scales 
     20# if defined key_zdftke 
     21   PUBLIC Agrif_Update_Tke 
     22# endif 
    2123   !!---------------------------------------------------------------------- 
    22    !! NEMO/NST 3.3 , NEMO Consortium (2010) 
     24   !! NEMO/NST 3.6 , NEMO Consortium (2010) 
    2325   !! $Id$ 
    2426   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
    … …  
    2729CONTAINS 
    2830 
    29    SUBROUTINE Agrif_Update_Tra( kt ) 
     31   RECURSIVE SUBROUTINE Agrif_Update_Tra( ) 
    3032      !!--------------------------------------------- 
    3133      !!   *** ROUTINE Agrif_Update_Tra *** 
    3234      !!--------------------------------------------- 
    33       !! 
    34       INTEGER, INTENT(in) :: kt 
    35       REAL(wp), POINTER, DIMENSION(:,:,:,:) :: ztab 
    36  
    37  
    38       IF((Agrif_NbStepint() .NE. (Agrif_irhot()-1)).AND.(kt /= 0)) RETURN 
    39 #if defined TWO_WAY 
    40       CALL wrk_alloc( jpi, jpj, jpk, jpts, ztab ) 
     35      !  
     36      IF (Agrif_Root()) RETURN 
     37      ! 
     38#if defined TWO_WAY   
     39      IF (lwp.AND.lk_agrif_debug) Write(*,*) 'Update tracers  from grid Number',Agrif_Fixed(), 'nbcline', nbcline 
    4140 
    4241      Agrif_UseSpecialValueInUpdate = .TRUE. 
    4342      Agrif_SpecialValueFineGrid = 0. 
    44  
     43      !  
    4544      IF (MOD(nbcline,nbclineupdate) == 0) THEN 
    46          CALL Agrif_Update_Variable(ztab,tsn_id, procname=updateTS) 
    47       ELSE 
    48          CALL Agrif_Update_Variable(ztab,tsn_id,locupdate=(/0,2/), procname=updateTS) 
    49       ENDIF 
    50  
     45# if ! defined DECAL_FEEDBACK 
     46         CALL Agrif_Update_Variable(tsn_id, procname=updateTS) 
     47# else 
     48         CALL Agrif_Update_Variable(tsn_id, locupdate=(/1,0/),procname=updateTS) 
     49# endif 
     50      ELSE 
     51# if ! defined DECAL_FEEDBACK 
     52         CALL Agrif_Update_Variable(tsn_id,locupdate=(/0,2/), procname=updateTS) 
     53# else 
     54         CALL Agrif_Update_Variable(tsn_id,locupdate=(/1,2/), procname=updateTS) 
     55# endif 
     56      ENDIF 
     57      ! 
    5158      Agrif_UseSpecialValueInUpdate = .FALSE. 
    52  
    53       CALL wrk_dealloc( jpi, jpj, jpk, jpts, ztab ) 
     59      ! 
     60      IF ( lk_agrif_doupd ) THEN ! Initialisation: do recursive update: 
     61         CALL Agrif_ChildGrid_To_ParentGrid() 
     62         CALL Agrif_Update_Tra() 
     63         CALL Agrif_ParentGrid_To_ChildGrid() 
     64      ENDIF 
     65      ! 
    5466#endif 
    55  
     67      ! 
    5668   END SUBROUTINE Agrif_Update_Tra 
    5769 
    58    SUBROUTINE Agrif_Update_Dyn( kt ) 
     70   RECURSIVE SUBROUTINE Agrif_Update_Dyn( ) 
    5971      !!--------------------------------------------- 
    6072      !!   *** ROUTINE Agrif_Update_Dyn *** 
    6173      !!--------------------------------------------- 
    62       !! 
    63       INTEGER, INTENT(in) :: kt 
    64       REAL(wp), POINTER, DIMENSION(:,:) :: ztab2d 
    65       REAL(wp), POINTER, DIMENSION(:,:,:) :: ztab 
    66  
    67  
    68       IF ((Agrif_NbStepint() .NE. (Agrif_irhot()-1)).AND.(kt /= 0)) Return 
     74      !  
     75      IF (Agrif_Root()) RETURN 
     76      ! 
    6977#if defined TWO_WAY 
    70       CALL wrk_alloc( jpi, jpj,      ztab2d ) 
    71       CALL wrk_alloc( jpi, jpj, jpk, ztab   ) 
    72  
     78      IF (lwp.AND.lk_agrif_debug) Write(*,*) 'Update momentum from grid Number',Agrif_Fixed(), 'nbcline', nbcline 
     79 
     80      Agrif_UseSpecialValueInUpdate = .FALSE. 
     81      Agrif_SpecialValueFineGrid = 0. 
     82      !      
    7383      IF (mod(nbcline,nbclineupdate) == 0) THEN 
    74          CALL Agrif_Update_Variable(ztab,un_id,procname = updateU) 
    75          CALL Agrif_Update_Variable(ztab,vn_id,procname = updateV) 
    76       ELSE 
    77          CALL Agrif_Update_Variable(ztab,un_id,locupdate=(/0,1/),procname = updateU) 
    78          CALL Agrif_Update_Variable(ztab,vn_id,locupdate=(/0,1/),procname = updateV)          
    79       ENDIF 
    80  
    81       CALL Agrif_Update_Variable(ztab2d,e1u_id,procname = updateU2d) 
    82       CALL Agrif_Update_Variable(ztab2d,e2v_id,procname = updateV2d) 
    83  
    84 #if defined key_dynspg_ts 
     84# if ! defined DECAL_FEEDBACK 
     85         CALL Agrif_Update_Variable(un_update_id,procname = updateU) 
     86         CALL Agrif_Update_Variable(vn_update_id,procname = updateV) 
     87# else 
     88         CALL Agrif_Update_Variable(un_update_id,locupdate1=(/0,-1/),locupdate2=(/1,-2/),procname = updateU) 
     89         CALL Agrif_Update_Variable(vn_update_id,locupdate1=(/1,-2/),locupdate2=(/0,-1/),procname = updateV) 
     90# endif 
     91      ELSE 
     92# if ! defined DECAL_FEEDBACK 
     93         CALL Agrif_Update_Variable(un_update_id,locupdate=(/0,1/),procname = updateU) 
     94         CALL Agrif_Update_Variable(vn_update_id,locupdate=(/0,1/),procname = updateV)          
     95# else 
     96         CALL Agrif_Update_Variable(un_update_id,locupdate1=(/0,1/),locupdate2=(/1,1/),procname = updateU) 
     97         CALL Agrif_Update_Variable(vn_update_id,locupdate1=(/1,1/),locupdate2=(/0,1/),procname = updateV) 
     98# endif 
     99      ENDIF 
     100 
     101# if ! defined DECAL_FEEDBACK 
     102      CALL Agrif_Update_Variable(e1u_id,procname = updateU2d) 
     103      CALL Agrif_Update_Variable(e2v_id,procname = updateV2d)   
     104# else 
     105      CALL Agrif_Update_Variable(e1u_id,locupdate1=(/0,-1/),locupdate2=(/1,-2/),procname = updateU2d) 
     106      CALL Agrif_Update_Variable(e2v_id,locupdate1=(/1,-2/),locupdate2=(/0,-1/),procname = updateV2d)   
     107# endif 
     108 
     109# if defined key_dynspg_ts 
    85110      IF (ln_bt_fw) THEN 
    86111         ! Update time integrated transports 
    87112         IF (mod(nbcline,nbclineupdate) == 0) THEN 
    88             CALL Agrif_Update_Variable(ztab2d,ub2b_id,procname = updateub2b) 
    89             CALL Agrif_Update_Variable(ztab2d,vb2b_id,procname = updatevb2b) 
     113#  if ! defined DECAL_FEEDBACK 
     114            CALL Agrif_Update_Variable(ub2b_update_id,procname = updateub2b) 
     115            CALL Agrif_Update_Variable(vb2b_update_id,procname = updatevb2b) 
     116#  else 
     117            CALL Agrif_Update_Variable(ub2b_update_id,locupdate1=(/0,-1/),locupdate2=(/1,-2/),procname = updateub2b) 
     118            CALL Agrif_Update_Variable(vb2b_update_id,locupdate1=(/1,-2/),locupdate2=(/0,-1/),procname = updatevb2b) 
     119#  endif 
    90120         ELSE 
    91             CALL Agrif_Update_Variable(ztab2d,ub2b_id,locupdate=(/0,1/),procname = updateub2b) 
    92             CALL Agrif_Update_Variable(ztab2d,vb2b_id,locupdate=(/0,1/),procname = updatevb2b) 
     121#  if ! defined DECAL_FEEDBACK 
     122            CALL Agrif_Update_Variable(ub2b_update_id,locupdate=(/0,1/),procname = updateub2b) 
     123            CALL Agrif_Update_Variable(vb2b_update_id,locupdate=(/0,1/),procname = updatevb2b) 
     124#  else 
     125            CALL Agrif_Update_Variable(ub2b_update_id,locupdate1=(/0,1/),locupdate2=(/1,1/),procname = updateub2b) 
     126            CALL Agrif_Update_Variable(vb2b_update_id,locupdate1=(/1,1/),locupdate2=(/0,1/),procname = updatevb2b) 
     127#  endif 
    93128         ENDIF 
    94       END IF  
     129      END IF 
     130# endif 
     131      ! 
     132      nbcline = nbcline + 1 
     133      ! 
     134      Agrif_UseSpecialValueInUpdate = .TRUE. 
     135      Agrif_SpecialValueFineGrid = 0. 
     136# if ! defined DECAL_FEEDBACK 
     137      CALL Agrif_Update_Variable(sshn_id,procname = updateSSH) 
     138# else 
     139      CALL Agrif_Update_Variable(sshn_id,locupdate=(/1,0/),procname = updateSSH) 
     140# endif 
     141      Agrif_UseSpecialValueInUpdate = .FALSE. 
     142      !  
    95143#endif 
    96  
    97       nbcline = nbcline + 1 
    98  
    99       Agrif_UseSpecialValueInUpdate = .TRUE.  
     144      ! 
     145      ! Do recursive update: 
     146      IF ( lk_agrif_doupd ) THEN ! Initialisation: do recursive update: 
     147         CALL Agrif_ChildGrid_To_ParentGrid() 
     148         CALL Agrif_Update_Dyn() 
     149         CALL Agrif_ParentGrid_To_ChildGrid() 
     150      ENDIF 
     151      ! 
     152   END SUBROUTINE Agrif_Update_Dyn 
     153 
     154# if defined key_zdftke 
     155   SUBROUTINE Agrif_Update_Tke( kt ) 
     156      !!--------------------------------------------- 
     157      !!   *** ROUTINE Agrif_Update_Tke *** 
     158      !!--------------------------------------------- 
     159      !! 
     160      INTEGER, INTENT(in) :: kt 
     161      !        
     162      IF( ( Agrif_NbStepint() .NE. 0 ) .AND. (kt /= 0) ) RETURN 
     163#  if defined TWO_WAY 
     164 
     165      Agrif_UseSpecialValueInUpdate = .TRUE. 
    100166      Agrif_SpecialValueFineGrid = 0. 
    101       CALL Agrif_Update_Variable(ztab2d,sshn_id,procname = updateSSH) 
     167 
     168      CALL Agrif_Update_Variable( en_id, locupdate=(/0,0/), procname=updateEN  ) 
     169      CALL Agrif_Update_Variable(avt_id, locupdate=(/0,0/), procname=updateAVT ) 
     170      CALL Agrif_Update_Variable(avm_id, locupdate=(/0,0/), procname=updateAVM ) 
     171 
    102172      Agrif_UseSpecialValueInUpdate = .FALSE. 
    103173 
    104       CALL wrk_dealloc( jpi, jpj,      ztab2d ) 
    105       CALL wrk_dealloc( jpi, jpj, jpk, ztab   ) 
    106  
    107 !Done in step 
    108 !      CALL Agrif_ChildGrid_To_ParentGrid() 
    109 !      CALL recompute_diags( kt ) 
    110 !      CALL Agrif_ParentGrid_To_ChildGrid() 
    111  
    112 #endif 
    113  
    114    END SUBROUTINE Agrif_Update_Dyn 
    115  
    116    SUBROUTINE recompute_diags( kt ) 
    117       !!--------------------------------------------- 
    118       !!   *** ROUTINE recompute_diags *** 
    119       !!--------------------------------------------- 
    120       INTEGER, INTENT(in) :: kt 
    121  
    122    END SUBROUTINE recompute_diags 
     174#  endif 
     175       
     176   END SUBROUTINE Agrif_Update_Tke 
     177# endif /* key_zdftke */ 
    123178 
    124179   SUBROUTINE updateTS( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before ) 
    … …  
    127182      !!--------------------------------------------- 
    128183#  include "domzgr_substitute.h90" 
    129  
    130184      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2 
    131185      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres 
    132       LOGICAL, iNTENT(in) :: before 
    133  
     186      LOGICAL, INTENT(in) :: before 
     187      !! 
    134188      INTEGER :: ji,jj,jk,jn 
    135  
     189      !!--------------------------------------------- 
     190      ! 
    136191      IF (before) THEN 
    137192         DO jn = n1,n2 
    … …  
    146201      ELSE 
    147202         IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN 
    148          ! Add asselin part 
     203            ! Add asselin part 
    149204            DO jn = n1,n2 
    150205               DO jk=k1,k2 
    … …  
    153208                        IF( tabres(ji,jj,jk,jn) .NE. 0. ) THEN 
    154209                           tsb(ji,jj,jk,jn) = tsb(ji,jj,jk,jn) &  
    155                               & + atfp * ( tabres(ji,jj,jk,jn) & 
    156                               &             - tsn(ji,jj,jk,jn) ) * tmask(ji,jj,jk) 
     210                                 & + atfp * ( tabres(ji,jj,jk,jn) & 
     211                                 &             - tsn(ji,jj,jk,jn) ) * tmask(ji,jj,jk) 
    157212                        ENDIF 
    158213                     ENDDO 
    … …  
    161216            ENDDO 
    162217         ENDIF 
    163  
    164218         DO jn = n1,n2 
    165219            DO jk=k1,k2 
    … …  
    174228         END DO 
    175229      ENDIF 
    176  
     230      !  
    177231   END SUBROUTINE updateTS 
    178232 
    … …  
    182236      !!--------------------------------------------- 
    183237#  include "domzgr_substitute.h90" 
    184  
     238      !! 
    185239      INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2 
    186240      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres 
    187241      LOGICAL, INTENT(in) :: before 
    188  
     242      !!  
    189243      INTEGER :: ji, jj, jk 
    190244      REAL(wp) :: zrhoy 
    191  
     245      !!--------------------------------------------- 
     246      !  
    192247      IF (before) THEN 
    193248         zrhoy = Agrif_Rhoy() 
    … …  
    209264                  IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part 
    210265                     ub(ji,jj,jk) = ub(ji,jj,jk) &  
    211                        & + atfp * ( tabres(ji,jj,jk) - un(ji,jj,jk) ) * umask(ji,jj,jk) 
     266                           & + atfp * ( tabres(ji,jj,jk) - un(ji,jj,jk) ) * umask(ji,jj,jk) 
    212267                  ENDIF 
    213268                  ! 
    … …  
    217272         END DO 
    218273      ENDIF 
    219  
     274      !  
    220275   END SUBROUTINE updateu 
    221276 
    … …  
    225280      !!--------------------------------------------- 
    226281#  include "domzgr_substitute.h90" 
    227  
     282      !! 
    228283      INTEGER :: i1,i2,j1,j2,k1,k2 
    229284      INTEGER :: ji,jj,jk 
    230285      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2) :: tabres 
    231286      LOGICAL :: before 
    232  
     287      !! 
    233288      REAL(wp) :: zrhox 
    234  
     289      !!---------------------------------------------       
     290      ! 
    235291      IF (before) THEN 
    236292         zrhox = Agrif_Rhox() 
    … …  
    252308                  IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part 
    253309                     vb(ji,jj,jk) = vb(ji,jj,jk) &  
    254                        & + atfp * ( tabres(ji,jj,jk) - vn(ji,jj,jk) ) * vmask(ji,jj,jk) 
     310                           & + atfp * ( tabres(ji,jj,jk) - vn(ji,jj,jk) ) * vmask(ji,jj,jk) 
    255311                  ENDIF 
    256312                  ! 
    … …  
    260316         END DO 
    261317      ENDIF 
    262  
     318      !  
    263319   END SUBROUTINE updatev 
    264320 
    … …  
    268324      !!--------------------------------------------- 
    269325#  include "domzgr_substitute.h90" 
    270  
     326      !! 
    271327      INTEGER, INTENT(in) :: i1, i2, j1, j2 
    272328      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 
    273329      LOGICAL, INTENT(in) :: before 
    274  
     330      !!  
    275331      INTEGER :: ji, jj, jk 
    276332      REAL(wp) :: zrhoy 
    277333      REAL(wp) :: zcorr 
    278  
     334      !!--------------------------------------------- 
     335      ! 
    279336      IF (before) THEN 
    280337         zrhoy = Agrif_Rhoy() 
    … …  
    326383         END DO 
    327384      ENDIF 
    328  
     385      ! 
    329386   END SUBROUTINE updateu2d 
    330387 
    … …  
    333390      !!          *** ROUTINE updatev2d *** 
    334391      !!--------------------------------------------- 
    335  
    336392      INTEGER, INTENT(in) :: i1, i2, j1, j2 
    337393      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 
    338394      LOGICAL, INTENT(in) :: before 
    339  
     395      !!  
    340396      INTEGER :: ji, jj, jk 
    341397      REAL(wp) :: zrhox 
    342398      REAL(wp) :: zcorr 
    343  
     399      !!--------------------------------------------- 
     400      ! 
    344401      IF (before) THEN 
    345402         zrhox = Agrif_Rhox() 
    … …  
    391448         END DO 
    392449      ENDIF 
    393  
     450      !  
    394451   END SUBROUTINE updatev2d 
    395452 
     453 
    396454   SUBROUTINE updateSSH( tabres, i1, i2, j1, j2, before ) 
    397455      !!--------------------------------------------- 
    398456      !!          *** ROUTINE updateSSH *** 
    399457      !!--------------------------------------------- 
    400 #  include "domzgr_substitute.h90" 
    401  
    402458      INTEGER, INTENT(in) :: i1, i2, j1, j2 
    403459      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 
    404460      LOGICAL, INTENT(in) :: before 
    405  
     461      !! 
    406462      INTEGER :: ji, jj 
    407  
     463      !!--------------------------------------------- 
     464      !  
    408465      IF (before) THEN 
    409466         DO jj=j1,j2 
    … …  
    413470         END DO 
    414471      ELSE 
    415  
    416472#if ! defined key_dynspg_ts 
    417473         IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN 
    418474            DO jj=j1,j2 
    419475               DO ji=i1,i2 
    420                 sshb(ji,jj) =   sshb(ji,jj) & 
    421                  & + atfp * ( tabres(ji,jj) - sshn(ji,jj) ) * tmask(ji,jj,1) 
     476                  sshb(ji,jj) =   sshb(ji,jj) & 
     477                        & + atfp * ( tabres(ji,jj) - sshn(ji,jj) ) * tmask(ji,jj,1) 
    422478               END DO 
    423479            END DO 
    … …  
    430486         END DO 
    431487      ENDIF 
    432  
     488      ! 
    433489   END SUBROUTINE updateSSH 
    434490 
    … …  
    437493      !!          *** ROUTINE updateub2b *** 
    438494      !!--------------------------------------------- 
    439  
    440495      INTEGER, INTENT(in) :: i1, i2, j1, j2 
    441496      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 
    442497      LOGICAL, INTENT(in) :: before 
    443  
     498      !! 
    444499      INTEGER :: ji, jj 
    445500      REAL(wp) :: zrhoy 
    446  
     501      !!--------------------------------------------- 
     502      ! 
    447503      IF (before) THEN 
    448504         zrhoy = Agrif_Rhoy() 
    … …  
    460516         END DO 
    461517      ENDIF 
    462  
     518      ! 
    463519   END SUBROUTINE updateub2b 
    464520 
    … …  
    467523      !!          *** ROUTINE updatevb2b *** 
    468524      !!--------------------------------------------- 
    469  
    470525      INTEGER, INTENT(in) :: i1, i2, j1, j2 
    471526      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 
    472527      LOGICAL, INTENT(in) :: before 
    473  
     528      !! 
    474529      INTEGER :: ji, jj 
    475530      REAL(wp) :: zrhox 
    476  
     531      !!--------------------------------------------- 
     532      ! 
    477533      IF (before) THEN 
    478534         zrhox = Agrif_Rhox() 
    … …  
    490546         END DO 
    491547      ENDIF 
    492  
     548      ! 
    493549   END SUBROUTINE updatevb2b 
     550 
     551 
     552   SUBROUTINE update_scales( tabres, i1, i2, j1, j2, k1, k2, n1,n2, before ) 
     553      ! currently not used 
     554      !!--------------------------------------------- 
     555      !!           *** ROUTINE updateT *** 
     556      !!--------------------------------------------- 
     557#  include "domzgr_substitute.h90" 
     558 
     559      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2 
     560      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres 
     561      LOGICAL, iNTENT(in) :: before 
     562 
     563      INTEGER :: ji,jj,jk 
     564      REAL(wp) :: ztemp 
     565 
     566      IF (before) THEN 
     567         DO jk=k1,k2 
     568            DO jj=j1,j2 
     569               DO ji=i1,i2 
     570                  tabres(ji,jj,jk,1) = e1t(ji,jj)*e2t(ji,jj)*tmask(ji,jj,jk) 
     571                  tabres(ji,jj,jk,2) = e1t(ji,jj)*tmask(ji,jj,jk) 
     572                  tabres(ji,jj,jk,3) = e2t(ji,jj)*tmask(ji,jj,jk) 
     573               END DO 
     574            END DO 
     575         END DO 
     576         tabres(:,:,:,1)=tabres(:,:,:,1)*Agrif_Rhox()*Agrif_Rhoy() 
     577         tabres(:,:,:,2)=tabres(:,:,:,2)*Agrif_Rhox() 
     578         tabres(:,:,:,3)=tabres(:,:,:,3)*Agrif_Rhoy() 
     579      ELSE 
     580         DO jk=k1,k2 
     581            DO jj=j1,j2 
     582               DO ji=i1,i2 
     583                  IF( tabres(ji,jj,jk,1) .NE. 0. ) THEN  
     584                     print *,'VAL = ',ji,jj,jk,tabres(ji,jj,jk,1),e1t(ji,jj)*e2t(ji,jj)*tmask(ji,jj,jk) 
     585                     print *,'VAL2 = ',ji,jj,jk,tabres(ji,jj,jk,2),e1t(ji,jj)*tmask(ji,jj,jk) 
     586                     print *,'VAL3 = ',ji,jj,jk,tabres(ji,jj,jk,3),e2t(ji,jj)*tmask(ji,jj,jk) 
     587                     ztemp = sqrt(tabres(ji,jj,jk,1)/(tabres(ji,jj,jk,2)*tabres(ji,jj,jk,3))) 
     588                     print *,'CORR = ',ztemp-1. 
     589                     print *,'NEW VALS = ',tabres(ji,jj,jk,2)*ztemp,tabres(ji,jj,jk,3)*ztemp, & 
     590                           tabres(ji,jj,jk,2)*ztemp*tabres(ji,jj,jk,3)*ztemp 
     591                     e1t(ji,jj) = tabres(ji,jj,jk,2)*ztemp 
     592                     e2t(ji,jj) = tabres(ji,jj,jk,3)*ztemp 
     593                  END IF 
     594               END DO 
     595            END DO 
     596         END DO 
     597      ENDIF 
     598      ! 
     599   END SUBROUTINE update_scales 
     600 
     601# if defined key_zdftke 
     602   SUBROUTINE updateEN( ptab, i1, i2, j1, j2, k1, k2, before ) 
     603      !!--------------------------------------------- 
     604      !!           *** ROUTINE updateen *** 
     605      !!--------------------------------------------- 
     606      INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2 
     607      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 
     608      LOGICAL, INTENT(in) :: before 
     609      !!--------------------------------------------- 
     610      ! 
     611      IF (before) THEN 
     612         ptab (i1:i2,j1:j2,k1:k2) = en(i1:i2,j1:j2,k1:k2) 
     613      ELSE 
     614         en(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2)  
     615      ENDIF 
     616      ! 
     617   END SUBROUTINE updateEN 
     618 
     619 
     620   SUBROUTINE updateAVT( ptab, i1, i2, j1, j2, k1, k2, before ) 
     621      !!--------------------------------------------- 
     622      !!           *** ROUTINE updateavt *** 
     623      !!--------------------------------------------- 
     624      INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2 
     625      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 
     626      LOGICAL, INTENT(in) :: before 
     627      !!--------------------------------------------- 
     628      ! 
     629      IF (before) THEN 
     630         ptab (i1:i2,j1:j2,k1:k2) = avt_k(i1:i2,j1:j2,k1:k2) 
     631      ELSE 
     632         avt_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2)  
     633      ENDIF 
     634      ! 
     635   END SUBROUTINE updateAVT 
     636 
     637 
     638   SUBROUTINE updateAVM( ptab, i1, i2, j1, j2, k1, k2, before ) 
     639      !!--------------------------------------------- 
     640      !!           *** ROUTINE updateavm *** 
     641      !!--------------------------------------------- 
     642      INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2 
     643      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 
     644      LOGICAL, INTENT(in) :: before 
     645      !!--------------------------------------------- 
     646      ! 
     647      IF (before) THEN 
     648         ptab (i1:i2,j1:j2,k1:k2) = avm_k(i1:i2,j1:j2,k1:k2) 
     649      ELSE 
     650         avm_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2)  
     651      ENDIF 
     652      ! 
     653   END SUBROUTINE updateAVM 
     654 
     655# endif /* key_zdftke */  
    494656 
    495657#else 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/NST_SRC/agrif_top_interp.F90

    r6836 r6839  
    77   USE agrif_oce 
    88   USE agrif_top_sponge 
     9   USE par_trc 
    910   USE trc 
    1011   USE lib_mpp 
    … …  
    1415   PRIVATE 
    1516 
    16    PUBLIC Agrif_trc 
     17   PUBLIC Agrif_trc, interptrn 
    1718 
    1819#  include "domzgr_substitute.h90"   
    1920#  include "vectopt_loop_substitute.h90" 
    2021  !!---------------------------------------------------------------------- 
    21    !! NEMO/NST 3.3 , NEMO Consortium (2010) 
     22   !! NEMO/NST 3.6 , NEMO Consortium (2010) 
    2223   !! $Id$ 
    2324   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
    … …  
    2829   SUBROUTINE Agrif_trc 
    2930      !!---------------------------------------------------------------------- 
    30       !!                  ***  ROUTINE Agrif_Tra  *** 
    31       !!---------------------------------------------------------------------- 
    32       !! 
    33       INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices 
    34       REAL(wp) ::   zrhox , alpha1, alpha2, alpha3 
    35       REAL(wp) ::   alpha4, alpha5, alpha6, alpha7 
    36       REAL(wp), POINTER, DIMENSION(:,:,:,:) :: ztra 
     31      !!                  ***  ROUTINE Agrif_trc  *** 
    3732      !!---------------------------------------------------------------------- 
    3833      ! 
    3934      IF( Agrif_Root() )   RETURN 
    4035 
    41       CALL wrk_alloc( jpi, jpj, jpk, jptra, ztra ) 
    42  
    4336      Agrif_SpecialValue    = 0.e0 
    4437      Agrif_UseSpecialValue = .TRUE. 
    45       ztra(:,:,:,:) = 0.e0 
    4638 
    47       CALL Agrif_Bc_variable( ztra, trn_id, procname=interptrn ) 
     39      CALL Agrif_Bc_variable( trn_id, procname=interptrn ) 
    4840      Agrif_UseSpecialValue = .FALSE. 
     41      ! 
     42   END SUBROUTINE Agrif_trc 
    4943 
    50       zrhox = Agrif_Rhox() 
     44   SUBROUTINE interptrn(ptab,i1,i2,j1,j2,k1,k2,n1,n2,before,nb,ndir) 
     45      !!--------------------------------------------- 
     46      !!   *** ROUTINE interptrn *** 
     47      !!--------------------------------------------- 
     48      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: ptab 
     49      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2 
     50      LOGICAL, INTENT(in) :: before 
     51      INTEGER, INTENT(in) :: nb , ndir 
     52      ! 
     53      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices 
     54      INTEGER :: imin, imax, jmin, jmax 
     55      REAL(wp) ::   zrhox , zalpha1, zalpha2, zalpha3 
     56      REAL(wp) ::   zalpha4, zalpha5, zalpha6, zalpha7 
     57      LOGICAL :: western_side, eastern_side,northern_side,southern_side 
    5158 
    52       alpha1 = ( zrhox - 1. ) * 0.5 
    53       alpha2 = 1. - alpha1 
    54  
    55       alpha3 = ( zrhox - 1. ) / ( zrhox + 1. ) 
    56       alpha4 = 1. - alpha3 
    57  
    58       alpha6 = 2. * ( zrhox - 1. ) / ( zrhox + 1. ) 
    59       alpha7 =    - ( zrhox - 1. ) / ( zrhox + 3. ) 
    60       alpha5 = 1. - alpha6 - alpha7 
    61       IF( nbondi == 1 .OR. nbondi == 2 ) THEN 
    62  
    63          DO jn = 1, jptra 
    64             tra(nlci,:,:,jn) = alpha1 * ztra(nlci,:,:,jn) + alpha2 * ztra(nlci-1,:,:,jn) 
    65             DO jk = 1, jpkm1 
    66                DO jj = 1, jpj 
    67                   IF( umask(nlci-2,jj,jk) == 0.e0 ) THEN 
    68                      tra(nlci-1,jj,jk,jn) = tra(nlci,jj,jk,jn) * tmask(nlci-1,jj,jk) 
    69                   ELSE 
    70                      tra(nlci-1,jj,jk,jn)=(alpha4*tra(nlci,jj,jk,jn)+alpha3*tra(nlci-2,jj,jk,jn))*tmask(nlci-1,jj,jk) 
    71                      IF( un(nlci-2,jj,jk) > 0.e0 ) THEN 
    72                         tra(nlci-1,jj,jk,jn)=( alpha6*tra(nlci-2,jj,jk,jn)+alpha5*tra(nlci,jj,jk,jn)  & 
    73                            &                 + alpha7*tra(nlci-3,jj,jk,jn) ) * tmask(nlci-1,jj,jk) 
     59      IF (before) THEN          
     60         ptab(i1:i2,j1:j2,k1:k2,n1:n2) = trn(i1:i2,j1:j2,k1:k2,n1:n2) 
     61      ELSE 
     62         ! 
     63         western_side  = (nb == 1).AND.(ndir == 1) 
     64         eastern_side  = (nb == 1).AND.(ndir == 2) 
     65         southern_side = (nb == 2).AND.(ndir == 1) 
     66         northern_side = (nb == 2).AND.(ndir == 2) 
     67         ! 
     68         zrhox = Agrif_Rhox() 
     69         !  
     70         zalpha1 = ( zrhox - 1. ) * 0.5 
     71         zalpha2 = 1. - zalpha1 
     72         !  
     73         zalpha3 = ( zrhox - 1. ) / ( zrhox + 1. ) 
     74         zalpha4 = 1. - zalpha3 
     75         !  
     76         zalpha6 = 2. * ( zrhox - 1. ) / ( zrhox + 1. ) 
     77         zalpha7 =    - ( zrhox - 1. ) / ( zrhox + 3. ) 
     78         zalpha5 = 1. - zalpha6 - zalpha7 
     79         ! 
     80         imin = i1 
     81         imax = i2 
     82         jmin = j1 
     83         jmax = j2 
     84         !  
     85         ! Remove CORNERS 
     86         IF((nbondj == -1).OR.(nbondj == 2)) jmin = 3 
     87         IF((nbondj == +1).OR.(nbondj == 2)) jmax = nlcj-2 
     88         IF((nbondi == -1).OR.(nbondi == 2)) imin = 3 
     89         IF((nbondi == +1).OR.(nbondi == 2)) imax = nlci-2         
     90         ! 
     91         IF( eastern_side) THEN 
     92            DO jn = 1, jptra 
     93               tra(nlci,j1:j2,k1:k2,jn) = zalpha1 * ptab(nlci,j1:j2,k1:k2,jn) + zalpha2 * ptab(nlci-1,j1:j2,k1:k2,jn) 
     94               DO jk = 1, jpkm1 
     95                  DO jj = jmin,jmax 
     96                     IF( umask(nlci-2,jj,jk) == 0.e0 ) THEN 
     97                        tra(nlci-1,jj,jk,jn) = tra(nlci,jj,jk,jn) * tmask(nlci-1,jj,jk) 
     98                     ELSE 
     99                        tra(nlci-1,jj,jk,jn)=(zalpha4*tra(nlci,jj,jk,jn)+zalpha3*tra(nlci-2,jj,jk,jn))*tmask(nlci-1,jj,jk) 
     100                        IF( un(nlci-2,jj,jk) > 0.e0 ) THEN 
     101                           tra(nlci-1,jj,jk,jn)=( zalpha6*tra(nlci-2,jj,jk,jn)+zalpha5*tra(nlci,jj,jk,jn) &  
     102                                 + zalpha7*tra(nlci-3,jj,jk,jn) ) * tmask(nlci-1,jj,jk) 
     103                        ENDIF 
    74104                     ENDIF 
    75                   ENDIF 
     105                  END DO 
     106               END DO 
     107            ENDDO 
     108         ENDIF 
     109         !  
     110         IF( northern_side ) THEN             
     111            DO jn = 1, jptra 
     112               tra(i1:i2,nlcj,k1:k2,jn) = zalpha1 * ptab(i1:i2,nlcj,k1:k2,jn) + zalpha2 * ptab(i1:i2,nlcj-1,k1:k2,jn) 
     113               DO jk = 1, jpkm1 
     114                  DO ji = imin,imax 
     115                     IF( vmask(ji,nlcj-2,jk) == 0.e0 ) THEN 
     116                        tra(ji,nlcj-1,jk,jn) = tra(ji,nlcj,jk,jn) * tmask(ji,nlcj-1,jk) 
     117                     ELSE 
     118                        tra(ji,nlcj-1,jk,jn)=(zalpha4*tra(ji,nlcj,jk,jn)+zalpha3*tra(ji,nlcj-2,jk,jn))*tmask(ji,nlcj-1,jk)         
     119                        IF (vn(ji,nlcj-2,jk) > 0.e0 ) THEN 
     120                           tra(ji,nlcj-1,jk,jn)=( zalpha6*tra(ji,nlcj-2,jk,jn)+zalpha5*tra(ji,nlcj,jk,jn)  & 
     121                                 + zalpha7*tra(ji,nlcj-3,jk,jn) ) * tmask(ji,nlcj-1,jk) 
     122                        ENDIF 
     123                     ENDIF 
     124                  END DO 
     125               END DO 
     126            ENDDO 
     127         ENDIF 
     128         ! 
     129         IF( western_side) THEN             
     130            DO jn = 1, jptra 
     131               tra(1,j1:j2,k1:k2,jn) = zalpha1 * ptab(1,j1:j2,k1:k2,jn) + zalpha2 * ptab(2,j1:j2,k1:k2,jn) 
     132               DO jk = 1, jpkm1 
     133                  DO jj = jmin,jmax 
     134                     IF( umask(2,jj,jk) == 0.e0 ) THEN 
     135                        tra(2,jj,jk,jn) = tra(1,jj,jk,jn) * tmask(2,jj,jk) 
     136                     ELSE 
     137                        tra(2,jj,jk,jn)=(zalpha4*tra(1,jj,jk,jn)+zalpha3*tra(3,jj,jk,jn))*tmask(2,jj,jk)         
     138                        IF( un(2,jj,jk) < 0.e0 ) THEN 
     139                           tra(2,jj,jk,jn)=(zalpha6*tra(3,jj,jk,jn)+zalpha5*tra(1,jj,jk,jn)+zalpha7*tra(4,jj,jk,jn))*tmask(2,jj,jk) 
     140                        ENDIF 
     141                     ENDIF 
     142                  END DO 
    76143               END DO 
    77144            END DO 
    78          ENDDO 
    79       ENDIF 
    80  
    81       IF( nbondj == 1 .OR. nbondj == 2 ) THEN 
    82  
    83          DO jn = 1, jptra 
    84             tra(:,nlcj,:,jn) = alpha1 * ztra(:,nlcj,:,jn) + alpha2 * ztra(:,nlcj-1,:,jn) 
    85             DO jk = 1, jpkm1 
    86                DO ji = 1, jpi 
    87                   IF( vmask(ji,nlcj-2,jk) == 0.e0 ) THEN 
    88                      tra(ji,nlcj-1,jk,jn) = tra(ji,nlcj,jk,jn) * tmask(ji,nlcj-1,jk) 
    89                   ELSE 
    90                      tra(ji,nlcj-1,jk,jn)=(alpha4*tra(ji,nlcj,jk,jn)+alpha3*tra(ji,nlcj-2,jk,jn))*tmask(ji,nlcj-1,jk) 
    91                      IF (vn(ji,nlcj-2,jk) > 0.e0 ) THEN 
    92                         tra(ji,nlcj-1,jk,jn)=( alpha6*tra(ji,nlcj-2,jk,jn)+alpha5*tra(ji,nlcj,jk,jn)  & 
    93                            &                 + alpha7*tra(ji,nlcj-3,jk,jn) ) * tmask(ji,nlcj-1,jk) 
     145         ENDIF 
     146         ! 
     147         IF( southern_side ) THEN            
     148            DO jn = 1, jptra 
     149               tra(i1:i2,1,k1:k2,jn) = zalpha1 * ptab(i1:i2,1,k1:k2,jn) + zalpha2 * ptab(i1:i2,2,k1:k2,jn) 
     150               DO jk=1,jpk       
     151                  DO ji=imin,imax 
     152                     IF( vmask(ji,2,jk) == 0.e0 ) THEN 
     153                        tra(ji,2,jk,jn)=tra(ji,1,jk,jn) * tmask(ji,2,jk) 
     154                     ELSE 
     155                        tra(ji,2,jk,jn)=(zalpha4*tra(ji,1,jk,jn)+zalpha3*tra(ji,3,jk,jn))*tmask(ji,2,jk) 
     156                        IF( vn(ji,2,jk) < 0.e0 ) THEN 
     157                           tra(ji,2,jk,jn)=(zalpha6*tra(ji,3,jk,jn)+zalpha5*tra(ji,1,jk,jn)+zalpha7*tra(ji,4,jk,jn))*tmask(ji,2,jk) 
     158                        ENDIF 
    94159                     ENDIF 
    95                   ENDIF 
     160                  END DO 
    96161               END DO 
    97             END DO 
    98          ENDDO 
    99       ENDIF 
    100       IF( nbondi == -1 .OR. nbondi == 2 ) THEN 
    101          DO jn = 1, jptra 
    102             tra(1,:,:,jn) = alpha1 * ztra(1,:,:,jn) + alpha2 * ztra(2,:,:,jn) 
    103             DO jk = 1, jpkm1 
    104                DO jj = 1, jpj 
    105                   IF( umask(2,jj,jk) == 0.e0 ) THEN 
    106                      tra(2,jj,jk,jn) = tra(1,jj,jk,jn) * tmask(2,jj,jk) 
    107                   ELSE 
    108                      tra(2,jj,jk,jn)=(alpha4*tra(1,jj,jk,jn)+alpha3*tra(3,jj,jk,jn))*tmask(2,jj,jk) 
    109                      IF( un(2,jj,jk) < 0.e0 ) THEN 
    110                         tra(2,jj,jk,jn)=(alpha6*tra(3,jj,jk,jn)+alpha5*tra(1,jj,jk,jn)+alpha7*tra(4,jj,jk,jn))*tmask(2,jj,jk) 
    111                      ENDIF 
    112                   ENDIF 
    113                END DO 
    114             END DO 
    115          END DO 
    116       ENDIF 
    117  
    118       IF( nbondj == -1 .OR. nbondj == 2 ) THEN 
    119          DO jn = 1, jptra 
    120             tra(:,1,:,jn) = alpha1 * ztra(:,1,:,jn) + alpha2 * ztra(:,2,:,jn) 
    121             DO jk=1,jpk 
    122                DO ji=1,jpi 
    123                   IF( vmask(ji,2,jk) == 0.e0 ) THEN 
    124                      tra(ji,2,jk,jn)=tra(ji,1,jk,jn) * tmask(ji,2,jk) 
    125                   ELSE 
    126                      tra(ji,2,jk,jn)=(alpha4*tra(ji,1,jk,jn)+alpha3*tra(ji,3,jk,jn))*tmask(ji,2,jk) 
    127                      IF( vn(ji,2,jk) < 0.e0 ) THEN 
    128                         tra(ji,2,jk,jn)=(alpha6*tra(ji,3,jk,jn)+alpha5*tra(ji,1,jk,jn)+alpha7*tra(ji,4,jk,jn))*tmask(ji,2,jk) 
    129                      ENDIF 
    130                   ENDIF 
    131                END DO 
    132             END DO 
    133          ENDDO 
     162            ENDDO 
     163         ENDIF 
     164         ! 
     165         ! Treatment of corners 
     166         !  
     167         ! East south 
     168         IF ((eastern_side).AND.((nbondj == -1).OR.(nbondj == 2))) THEN 
     169            tra(nlci-1,2,:,:) = ptab(nlci-1,2,:,:) 
     170         ENDIF 
     171         ! East north 
     172         IF ((eastern_side).AND.((nbondj == 1).OR.(nbondj == 2))) THEN 
     173            tra(nlci-1,nlcj-1,:,:) = ptab(nlci-1,nlcj-1,:,:) 
     174         ENDIF 
     175         ! West south 
     176         IF ((western_side).AND.((nbondj == -1).OR.(nbondj == 2))) THEN 
     177            tra(2,2,:,:) = ptab(2,2,:,:) 
     178         ENDIF 
     179         ! West north 
     180         IF ((western_side).AND.((nbondj == 1).OR.(nbondj == 2))) THEN 
     181            tra(2,nlcj-1,:,:) = ptab(2,nlcj-1,:,:) 
     182         ENDIF 
     183         ! 
    134184      ENDIF 
    135185      ! 
    136       CALL wrk_dealloc( jpi, jpj, jpk, jptra, ztra ) 
    137       ! 
    138  
    139    END SUBROUTINE Agrif_trc 
     186   END SUBROUTINE interptrn 
    140187 
    141188#else 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/NST_SRC/agrif_top_sponge.F90

    r6836 r6839  
    11#define SPONGE_TOP 
    22 
    3 Module agrif_top_sponge 
     3MODULE agrif_top_sponge 
    44#if defined key_agrif && defined key_top 
    55   USE par_oce 
     6   USE par_trc 
    67   USE oce 
    78   USE dom_oce 
    … …  
    1617   PRIVATE 
    1718 
    18    PUBLIC Agrif_Sponge_Trc, interptrn 
     19   PUBLIC Agrif_Sponge_trc, interptrn_sponge 
    1920 
    20   !! * Substitutions 
     21   !! * Substitutions 
    2122#  include "domzgr_substitute.h90" 
    2223   !!---------------------------------------------------------------------- 
    23    !! NEMO/NST 3.3 , NEMO Consortium (2010) 
     24   !! NEMO/NST 3.6 , NEMO Consortium (2010) 
    2425   !! $Id$ 
    2526   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
    2627   !!---------------------------------------------------------------------- 
    2728 
    28    CONTAINS 
     29CONTAINS 
    2930 
    30    SUBROUTINE Agrif_Sponge_Trc 
     31   SUBROUTINE Agrif_Sponge_trc 
    3132      !!--------------------------------------------- 
    3233      !!   *** ROUTINE Agrif_Sponge_Trc *** 
    3334      !!--------------------------------------------- 
    3435      !!  
    35       INTEGER :: ji,jj,jk,jn 
    3636      REAL(wp) :: timecoeff 
    37       REAL(wp) :: ztra, zabe1, zabe2, zbtr 
    38       REAL(wp), POINTER, DIMENSION(:,:) :: ztru, ztrv 
    39       REAL(wp), POINTER, DIMENSION(:,:,:,:) :: ztabr 
    40       REAL(wp), POINTER, DIMENSION(:,:,:,:) :: trbdiff 
    4137 
    4238#if defined SPONGE_TOP 
    43       CALL wrk_alloc( jpi, jpj, ztru, ztrv ) 
    44       CALL wrk_alloc( jpi, jpj, jpk, jptra, ztabr, trbdiff ) 
    45  
    4639      timecoeff = REAL(Agrif_NbStepint(),wp)/Agrif_rhot() 
    47  
     40      CALL Agrif_sponge 
    4841      Agrif_SpecialValue=0. 
    4942      Agrif_UseSpecialValue = .TRUE. 
    50       ztabr = 0.e0 
    51       CALL Agrif_Bc_Variable(ztabr, tra_id,calledweight=timecoeff,procname=interptrn) 
     43      tabspongedone_trn = .FALSE. 
     44      CALL Agrif_Bc_Variable(trn_sponge_id,calledweight=timecoeff,procname=interptrn_sponge) 
    5245      Agrif_UseSpecialValue = .FALSE. 
    53  
    54       trbdiff(:,:,:,:) = trb(:,:,:,:) - ztabr(:,:,:,:) 
    55  
    56       CALL Agrif_sponge 
    57  
    58       DO jn = 1, jptra 
    59          DO jk = 1, jpkm1 
    60             ! 
    61             DO jj = 1, jpjm1 
    62                DO ji = 1, jpim1 
    63                   zabe1 = umask(ji,jj,jk) * spe1ur(ji,jj) * fse3u(ji,jj,jk) 
    64                   zabe2 = vmask(ji,jj,jk) * spe2vr(ji,jj) * fse3v(ji,jj,jk) 
    65                   ztru(ji,jj) = zabe1 * ( trbdiff(ji+1,jj  ,jk,jn) - trbdiff(ji,jj,jk,jn) ) 
    66                   ztrv(ji,jj) = zabe2 * ( trbdiff(ji  ,jj+1,jk,jn) - trbdiff(ji,jj,jk,jn) ) 
    67                ENDDO 
    68             ENDDO 
    69  
    70             DO jj = 2,jpjm1 
    71                DO ji = 2,jpim1 
    72                   zbtr = spbtr2(ji,jj) / fse3t(ji,jj,jk) 
    73                   ! horizontal diffusive trends 
    74                   ztra = zbtr * ( ztru(ji,jj) - ztru(ji-1,jj) + ztrv(ji,jj) - ztrv(ji,jj-1)  ) 
    75                   ! add it to the general tracer trends 
    76                   tra(ji,jj,jk,jn) = tra(ji,jj,jk,jn) + ztra 
    77                END DO 
    78             END DO 
    79             ! 
    80          ENDDO 
    81       ENDDO 
    82   
    83       CALL wrk_dealloc( jpi, jpj, ztru, ztrv ) 
    84       CALL wrk_dealloc( jpi, jpj, jpk, jptra, trbdiff, ztabr ) 
    8546 
    8647#endif 
    … …  
    8849   END SUBROUTINE Agrif_Sponge_Trc 
    8950 
    90    SUBROUTINE interptrn(tabres,i1,i2,j1,j2,k1,k2,n1,n2) 
     51   SUBROUTINE interptrn_sponge(tabres,i1,i2,j1,j2,k1,k2,n1,n2,before) 
    9152      !!--------------------------------------------- 
    92       !!   *** ROUTINE interptn *** 
     53      !!   *** ROUTINE interptrn_sponge *** 
    9354      !!--------------------------------------------- 
    9455      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2 
    9556      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres 
     57      LOGICAL, INTENT(in) :: before 
     58 
     59 
     60      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices 
     61 
     62      REAL(wp) :: ztra, zabe1, zabe2, zbtr 
     63      REAL(wp), DIMENSION(i1:i2,j1:j2) :: ztu, ztv 
     64      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2) ::trbdiff 
    9665      ! 
    97       tabres(i1:i2,j1:j2,k1:k2,n1:n2) = trn(i1:i2,j1:j2,k1:k2,n1:n2) 
     66      IF (before) THEN 
     67         tabres(i1:i2,j1:j2,k1:k2,n1:n2) = trn(i1:i2,j1:j2,k1:k2,n1:n2) 
     68      ELSE       
    9869 
    99    END SUBROUTINE interptrn 
     70         trbdiff(:,:,:,:) = trb(i1:i2,j1:j2,:,:) - tabres(:,:,:,:)       
     71         DO jn = 1, jptra 
     72            DO jk = 1, jpkm1 
     73 
     74               DO jj = j1,j2-1 
     75                  DO ji = i1,i2-1 
     76                     zabe1 = fsaht_spu(ji,jj) * umask(ji,jj,jk) * re2u_e1u(ji,jj) * fse3u_n(ji,jj,jk) 
     77                     zabe2 = fsaht_spv(ji,jj) * vmask(ji,jj,jk) * re1v_e2v(ji,jj) * fse3v_n(ji,jj,jk) 
     78                     ztu(ji,jj) = zabe1 * ( trbdiff(ji+1,jj  ,jk,jn) - trbdiff(ji,jj,jk,jn) ) 
     79                     ztv(ji,jj) = zabe2 * ( trbdiff(ji  ,jj+1,jk,jn) - trbdiff(ji,jj,jk,jn) ) 
     80                  ENDDO 
     81               ENDDO 
     82 
     83               DO jj = j1+1,j2-1 
     84                  DO ji = i1+1,i2-1 
     85 
     86                     IF (.NOT. tabspongedone_trn(ji,jj)) THEN  
     87                        zbtr = r1_e12t(ji,jj) / fse3t(ji,jj,jk) 
     88                        ! horizontal diffusive trends 
     89                        ztra = zbtr * (  ztu(ji,jj) - ztu(ji-1,jj  ) + ztv(ji,jj) - ztv(ji  ,jj-1)  ) 
     90                        ! add it to the general tracer trends 
     91                        tra(ji,jj,jk,jn) = tra(ji,jj,jk,jn) + ztra 
     92                     ENDIF 
     93 
     94                  ENDDO 
     95               ENDDO 
     96 
     97            ENDDO 
     98         ENDDO 
     99 
     100         tabspongedone_trn(i1+1:i2-1,j1+1:j2-1) = .TRUE. 
     101      ENDIF 
     102      !                  
     103   END SUBROUTINE interptrn_sponge 
    100104 
    101105#else 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/NST_SRC/agrif_top_update.F90

    r6836 r6839  
    11#define TWO_WAY 
     2#undef DECAL_FEEDBACK 
    23 
    34MODULE agrif_top_update 
    … …  
    89   USE dom_oce 
    910   USE agrif_oce 
     11   USE par_trc 
    1012   USE trc 
    1113   USE wrk_nemo   
    … …  
    2426   !!---------------------------------------------------------------------- 
    2527 
    26    CONTAINS 
     28CONTAINS 
    2729 
    2830   SUBROUTINE Agrif_Update_Trc( kt ) 
    … …  
    3032      !!   *** ROUTINE Agrif_Update_Trc *** 
    3133      !!--------------------------------------------- 
    32       !! 
    3334      INTEGER, INTENT(in) :: kt 
    34       REAL(wp), POINTER, DIMENSION(:,:,:,:) :: ztra 
    35  
    36    
    37       IF ((Agrif_NbStepint() .NE. (Agrif_irhot()-1)).AND.(kt /= 0)) RETURN 
    38  
    39 #if defined TWO_WAY 
    40       CALL wrk_alloc( jpi, jpj, jpk, jptra, ztra ) 
    41  
     35      !!--------------------------------------------- 
     36      !  
     37      IF((Agrif_NbStepint() .NE. (Agrif_irhot()-1)).AND.(kt /= 0)) RETURN 
     38#if defined TWO_WAY    
    4239      Agrif_UseSpecialValueInUpdate = .TRUE. 
    4340      Agrif_SpecialValueFineGrid = 0. 
    44   
    45      IF (MOD(nbcline_trc,nbclineupdate) == 0) THEN 
    46          CALL Agrif_Update_Variable(ztra,trn_id, procname=updateTRC) 
     41      !  
     42      IF (MOD(nbcline_trc,nbclineupdate) == 0) THEN 
     43# if ! defined DECAL_FEEDBACK 
     44         CALL Agrif_Update_Variable(trn_id, procname=updateTRC) 
     45# else 
     46         CALL Agrif_Update_Variable(trn_id, locupdate=(/1,0/),procname=updateTRC) 
     47# endif 
    4748      ELSE 
    48          CALL Agrif_Update_Variable(ztra,trn_id,locupdate=(/0,2/), procname=updateTRC) 
     49# if ! defined DECAL_FEEDBACK 
     50         CALL Agrif_Update_Variable(trn_id,locupdate=(/0,2/), procname=updateTRC) 
     51# else 
     52         CALL Agrif_Update_Variable(trn_id,locupdate=(/1,2/), procname=updateTRC) 
     53# endif 
    4954      ENDIF 
    50  
     55      ! 
    5156      Agrif_UseSpecialValueInUpdate = .FALSE. 
    5257      nbcline_trc = nbcline_trc + 1 
    53  
    54       CALL wrk_dealloc( jpi, jpj, jpk, jptra, ztra ) 
    5558#endif 
    56  
     59      ! 
    5760   END SUBROUTINE Agrif_Update_Trc 
    5861 
    59    SUBROUTINE updateTRC(tabres,i1,i2,j1,j2,k1,k2,n1,n2,before) 
     62   SUBROUTINE updateTRC( ptab, i1, i2, j1, j2, k1, k2, n1, n2, before ) 
    6063      !!--------------------------------------------- 
    61       !!   *** ROUTINE UpdateTrc *** 
     64      !!           *** ROUTINE updateT *** 
    6265      !!--------------------------------------------- 
     66#  include "domzgr_substitute.h90" 
    6367      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2 
    64       REAL, DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres 
     68      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: ptab 
    6569      LOGICAL, INTENT(in) :: before 
    66     
     70      !! 
    6771      INTEGER :: ji,jj,jk,jn 
    68  
    69          IF( before ) THEN 
    70             DO jn = n1, n2 
    71                DO jk = k1, k2 
    72                   DO jj = j1, j2 
    73                      DO ji = i1, i2 
    74                         tabres(ji,jj,jk,jn) = trn(ji,jj,jk,jn) 
    75                      ENDDO 
    76                   ENDDO 
    77                ENDDO 
    78             ENDDO 
    79          ELSE 
    80             IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN 
     72      !!--------------------------------------------- 
     73      ! 
     74      IF (before) THEN 
     75         DO jn = n1,n2 
     76            DO jk=k1,k2 
     77               DO jj=j1,j2 
     78                  DO ji=i1,i2 
     79                     ptab(ji,jj,jk,jn) = trn(ji,jj,jk,jn) 
     80                  END DO 
     81               END DO 
     82            END DO 
     83         END DO 
     84      ELSE 
     85         IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN 
    8186            ! Add asselin part 
    82                DO jn = n1, n2 
    83                   DO jk = k1, k2 
    84                      DO jj = j1, j2 
    85                         DO ji = i1, i2 
    86                            IF( tabres(ji,jj,jk,jn) .NE. 0. ) THEN 
    87                               trb(ji,jj,jk,jn) = trb(ji,jj,jk,jn) &  
    88                                  & + atfp * ( tabres(ji,jj,jk,jn) & 
    89                                                - trn(ji,jj,jk,jn) ) * tmask(ji,jj,jk) 
    90                            ENDIF 
    91                         ENDDO 
    92                      ENDDO 
    93                   ENDDO 
    94                ENDDO 
    95             ENDIF 
    96  
    97             DO jn = n1, n2 
    98                DO jk = k1, k2 
    99                   DO jj = j1, j2 
    100                      DO ji = i1, i2 
    101                         IF( tabres(ji,jj,jk,jn) .NE. 0. ) THEN 
    102                            trn(ji,jj,jk,jn) = tabres(ji,jj,jk,jn) * tmask(ji,jj,jk) 
     87            DO jn = n1,n2 
     88               DO jk=k1,k2 
     89                  DO jj=j1,j2 
     90                     DO ji=i1,i2 
     91                        IF( ptab(ji,jj,jk,jn) .NE. 0. ) THEN 
     92                           trb(ji,jj,jk,jn) = trb(ji,jj,jk,jn) &  
     93                                 & + atfp * ( ptab(ji,jj,jk,jn) & 
     94                                 &             - trn(ji,jj,jk,jn) ) * tmask(ji,jj,jk) 
    10395                        ENDIF 
    10496                     ENDDO 
    … …  
    10799            ENDDO 
    108100         ENDIF 
    109  
     101         DO jn = n1,n2 
     102            DO jk=k1,k2 
     103               DO jj=j1,j2 
     104                  DO ji=i1,i2 
     105                     IF( ptab(ji,jj,jk,jn) .NE. 0. ) THEN  
     106                        trn(ji,jj,jk,jn) = ptab(ji,jj,jk,jn) * tmask(ji,jj,jk) 
     107                     END IF 
     108                  END DO 
     109               END DO 
     110            END DO 
     111         END DO 
     112      ENDIF 
     113      !  
    110114   END SUBROUTINE updateTRC 
    111115 
    … …  
    119123   END SUBROUTINE agrif_top_update_empty 
    120124#endif 
    121 END Module agrif_top_update 
     125END MODULE agrif_top_update 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/NST_SRC/agrif_user.F90

    r6836 r6839  
    1717   USE par_oce 
    1818   USE dom_oce 
    19    USE Agrif_Util 
    2019   USE nemogcm 
    2120   ! 
    … …  
    3130      jpi     = ( jpiglo-2*jpreci + (jpni-1+0) ) / jpni + 2*jpreci 
    3231      jpj     = ( jpjglo-2*jprecj + (jpnj-1+0) ) / jpnj + 2*jprecj 
    33       jpk     = jpkdta  
     32! JC: change to allow for different vertical levels 
     33!     jpk is already set 
     34!     keep it jpk possibly different from jpkdta which  
     35!     hold parent grid vertical levels number (set earlier) 
     36!      jpk     = jpkdta  
    3437      jpim1   = jpi-1  
    3538      jpjm1   = jpj-1  
    … …  
    6467   ! 0. Initializations 
    6568   !------------------- 
    66    IF( cp_cfg == 'orca' ) then 
     69   IF( cp_cfg == 'orca' ) THEN 
    6770      IF ( jp_cfg == 2 .OR. jp_cfg == 025 .OR. jp_cfg == 05 & 
    68   &                      .OR. jp_cfg == 4 ) THEN 
     71            &                      .OR. jp_cfg == 4 ) THEN 
    6972         jp_cfg = -1    ! set special value for jp_cfg on fine grids 
    7073         cp_cfg = "default" 
    … …  
    120123SUBROUTINE agrif_declare_var_dom 
    121124   !!---------------------------------------------------------------------- 
    122    !!                 *** ROUTINE agrif_declarE_var *** 
     125   !!                 *** ROUTINE agrif_declare_var *** 
    123126   !! 
    124127   !! ** Purpose :: Declaration of variables to be interpolated 
    125128   !!---------------------------------------------------------------------- 
    126129   USE agrif_util 
    127    USE par_oce       !   ONLY : jpts 
     130   USE par_oce        
    128131   USE oce 
    129132   IMPLICIT NONE 
    … …  
    132135   ! 1. Declaration of the type of variable which have to be interpolated 
    133136   !--------------------------------------------------------------------- 
    134    CALL agrif_declare_variable((/1,2/),(/2,3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),e1u_id) 
    135    CALL agrif_declare_variable((/2,1/),(/3,2/),(/'x','y'/),(/1,1/),(/jpi,jpj/),e2v_id) 
    136  
     137   CALL agrif_declare_variable((/1,2/),(/2,3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),e1u_id) 
     138   CALL agrif_declare_variable((/2,1/),(/3,2/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),e2v_id) 
    137139 
    138140   ! 2. Type of interpolation 
    139141   !------------------------- 
    140    Call Agrif_Set_bcinterp(e1u_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
    141    Call Agrif_Set_bcinterp(e2v_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
     142   CALL Agrif_Set_bcinterp(e1u_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
     143   CALL Agrif_Set_bcinterp(e2v_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
    142144 
    143145   ! 3. Location of interpolation 
    144146   !----------------------------- 
    145    Call Agrif_Set_bc(e1u_id,(/0,0/)) 
    146    Call Agrif_Set_bc(e2v_id,(/0,0/)) 
     147   CALL Agrif_Set_bc(e1u_id,(/0,0/)) 
     148   CALL Agrif_Set_bc(e2v_id,(/0,0/)) 
    147149 
    148150   ! 5. Update type 
    149151   !---------------  
    150    Call Agrif_Set_Updatetype(e1u_id,update1 = Agrif_Update_Copy, update2=Agrif_Update_Average) 
    151    Call Agrif_Set_Updatetype(e2v_id,update1 = Agrif_Update_Average, update2=Agrif_Update_Copy) 
    152  
     152   CALL Agrif_Set_Updatetype(e1u_id,update1 = Agrif_Update_Copy, update2=Agrif_Update_Average) 
     153   CALL Agrif_Set_Updatetype(e2v_id,update1 = Agrif_Update_Average, update2=Agrif_Update_Copy) 
     154 
     155! High order updates 
     156!   CALL Agrif_Set_Updatetype(e1u_id,update1 = Agrif_Update_Average,            update2=Agrif_Update_Full_Weighting) 
     157!   CALL Agrif_Set_Updatetype(e2v_id,update1 = Agrif_Update_Full_Weighting,     update2=Agrif_Update_Average) 
     158    ! 
    153159END SUBROUTINE agrif_declare_var_dom 
    154160 
    … …  
    167173   USE nemogcm 
    168174   USE sol_oce 
     175   USE lib_mpp 
    169176   USE in_out_manager 
    170177   USE agrif_opa_update 
    … …  
    174181   IMPLICIT NONE 
    175182   ! 
    176    REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: tabtstemp 
    177    REAL(wp), DIMENSION(:,:,:  ), ALLOCATABLE :: tabuvtemp 
    178    REAL(wp), DIMENSION(:,:    ), ALLOCATABLE :: tab2d 
    179183   LOGICAL :: check_namelist 
    180    !!---------------------------------------------------------------------- 
    181  
    182    ALLOCATE( tabtstemp(jpi, jpj, jpk, jpts) ) 
    183    ALLOCATE( tabuvtemp(jpi, jpj, jpk)       ) 
    184    ALLOCATE( tab2d(jpi, jpj)                ) 
    185  
     184   CHARACTER(len=15) :: cl_check1, cl_check2, cl_check3 
     185   !!---------------------------------------------------------------------- 
    186186 
    187187   ! 1. Declaration of the type of variable which have to be interpolated 
    … …  
    193193   Agrif_SpecialValue=0. 
    194194   Agrif_UseSpecialValue = .TRUE. 
    195    Call Agrif_Bc_variable(tabtstemp,tsn_id,calledweight=1.,procname=interptsn) 
    196    Call Agrif_Bc_variable(tabtstemp,tsa_id,calledweight=1.,procname=interptsn) 
    197  
    198    Call Agrif_Bc_variable(tabuvtemp,un_id,calledweight=1.,procname=interpu) 
    199    Call Agrif_Bc_variable(tabuvtemp,vn_id,calledweight=1.,procname=interpv) 
    200    Call Agrif_Bc_variable(tabuvtemp,ua_id,calledweight=1.,procname=interpun) 
    201    Call Agrif_Bc_variable(tabuvtemp,va_id,calledweight=1.,procname=interpvn) 
    202  
    203    Call Agrif_Bc_variable(tab2d,unb_id,calledweight=1.,procname=interpunb) 
    204    Call Agrif_Bc_variable(tab2d,vnb_id,calledweight=1.,procname=interpvnb) 
    205    Call Agrif_Bc_variable(tab2d,sshn_id,calledweight=1.,procname=interpsshn) 
    206    Agrif_UseSpecialValue = .FALSE. 
     195   CALL Agrif_Bc_variable(tsn_id,calledweight=1.,procname=interptsn) 
     196   CALL Agrif_Sponge 
     197   tabspongedone_tsn = .FALSE. 
     198   CALL Agrif_Bc_variable(tsn_sponge_id,calledweight=1.,procname=interptsn_sponge) 
     199   ! reset tsa to zero 
     200   tsa(:,:,:,:) = 0. 
     201 
     202   Agrif_UseSpecialValue = ln_spc_dyn 
     203   CALL Agrif_Bc_variable(un_interp_id,calledweight=1.,procname=interpun) 
     204   CALL Agrif_Bc_variable(vn_interp_id,calledweight=1.,procname=interpvn) 
     205   tabspongedone_u = .FALSE. 
     206   tabspongedone_v = .FALSE. 
     207   CALL Agrif_Bc_variable(un_sponge_id,calledweight=1.,procname=interpun_sponge) 
     208   tabspongedone_u = .FALSE. 
     209   tabspongedone_v = .FALSE. 
     210   CALL Agrif_Bc_variable(vn_sponge_id,calledweight=1.,procname=interpvn_sponge) 
     211 
     212#if defined key_dynspg_ts 
     213   Agrif_UseSpecialValue = .TRUE. 
     214   CALL Agrif_Bc_variable(sshn_id,calledweight=1., procname=interpsshn ) 
     215 
     216   Agrif_UseSpecialValue = ln_spc_dyn 
     217   CALL Agrif_Bc_variable(unb_id,calledweight=1.,procname=interpunb) 
     218   CALL Agrif_Bc_variable(vnb_id,calledweight=1.,procname=interpvnb) 
     219   CALL Agrif_Bc_variable(ub2b_interp_id,calledweight=1.,procname=interpub2b) 
     220   CALL Agrif_Bc_variable(vb2b_interp_id,calledweight=1.,procname=interpvb2b) 
     221   ubdy_w(:) = 0.e0 ; vbdy_w(:) = 0.e0 ; hbdy_w(:) =0.e0 
     222   ubdy_e(:) = 0.e0 ; vbdy_e(:) = 0.e0 ; hbdy_e(:) =0.e0  
     223   ubdy_n(:) = 0.e0 ; vbdy_n(:) = 0.e0 ; hbdy_n(:) =0.e0  
     224   ubdy_s(:) = 0.e0 ; vbdy_s(:) = 0.e0 ; hbdy_s(:) =0.e0 
     225#endif 
     226 
     227   Agrif_UseSpecialValue = .FALSE.  
     228   ! reset velocities to zero 
     229   ua(:,:,:) = 0. 
     230   va(:,:,:) = 0. 
    207231 
    208232   ! 3. Some controls 
    209233   !----------------- 
    210    check_namelist = .true. 
    211  
    212    IF( check_namelist ) THEN 
     234   check_namelist = .TRUE. 
     235 
     236   IF( check_namelist ) THEN  
    213237 
    214238      ! Check time steps            
    215       IF( NINT(Agrif_Rhot()) * nint(rdt) /= Agrif_Parent(rdt) ) THEN 
    216          WRITE(*,*) 'incompatible time step between grids' 
    217          WRITE(*,*) 'parent grid value : ',Agrif_Parent(rdt) 
    218          WRITE(*,*) 'child  grid value : ',nint(rdt) 
    219          WRITE(*,*) 'value on parent grid should be : ',rdt*Agrif_Rhot() 
    220          STOP 
     239      IF( NINT(Agrif_Rhot()) * NINT(rdt) .NE. Agrif_Parent(rdt) ) THEN 
     240         WRITE(cl_check1,*)  NINT(Agrif_Parent(rdt)) 
     241         WRITE(cl_check2,*)  NINT(rdt) 
     242         WRITE(cl_check3,*)  NINT(Agrif_Parent(rdt)/Agrif_Rhot()) 
     243         CALL ctl_warn( 'incompatible time step between grids',   & 
     244               &               'parent grid value : '//cl_check1    ,   &  
     245               &               'child  grid value : '//cl_check2    ,   &  
     246               &               'value on child grid will be changed to : '//cl_check3 ) 
     247         rdt=Agrif_Parent(rdt)/Agrif_Rhot() 
    221248      ENDIF 
    222249 
    223250      ! Check run length 
    224251      IF( Agrif_IRhot() * (Agrif_Parent(nitend)- & 
    225            Agrif_Parent(nit000)+1) .ne. (nitend-nit000+1) ) THEN 
    226          WRITE(*,*) 'incompatible run length between grids' 
    227          WRITE(*,*) 'parent grid value : ',(Agrif_Parent(nitend)- & 
    228               Agrif_Parent(nit000)+1),' time step' 
    229          WRITE(*,*) 'child  grid value : ', & 
    230               (nitend-nit000+1),' time step' 
    231          WRITE(*,*) 'value on child grid should be : ', & 
    232               Agrif_IRhot() * (Agrif_Parent(nitend)- & 
    233               Agrif_Parent(nit000)+1) 
    234          STOP 
     252            Agrif_Parent(nit000)+1) .NE. (nitend-nit000+1) ) THEN 
     253         WRITE(cl_check1,*)  (Agrif_Parent(nit000)-1)*Agrif_IRhot() + 1 
     254         WRITE(cl_check2,*)   Agrif_Parent(nitend)   *Agrif_IRhot() 
     255         CALL ctl_warn( 'incompatible run length between grids'               ,   & 
     256               &              ' nit000 on fine grid will be change to : '//cl_check1,   & 
     257               &              ' nitend on fine grid will be change to : '//cl_check2    ) 
     258         nit000 = (Agrif_Parent(nit000)-1)*Agrif_IRhot() + 1 
     259         nitend =  Agrif_Parent(nitend)   *Agrif_IRhot() 
    235260      ENDIF 
    236261 
    … …  
    238263      IF( ln_zps ) THEN 
    239264         ! check parameters for partial steps  
    240          IF( Agrif_Parent(e3zps_min) .ne. e3zps_min ) THEN 
     265         IF( Agrif_Parent(e3zps_min) .NE. e3zps_min ) THEN 
    241266            WRITE(*,*) 'incompatible e3zps_min between grids' 
    242267            WRITE(*,*) 'parent grid :',Agrif_Parent(e3zps_min) 
    … …  
    253278         ENDIF 
    254279      ENDIF 
     280      ! check if masks and bathymetries match 
     281      IF(ln_chk_bathy) THEN 
     282         ! 
     283         IF(lwp) WRITE(numout,*) 'AGRIF: Check Bathymetry and masks near bdys. Level: ', Agrif_Level() 
     284         ! 
     285         kindic_agr = 0 
     286         ! check if umask agree with parent along western and eastern boundaries: 
     287         CALL Agrif_Bc_variable(umsk_id,calledweight=1.,procname=interpumsk) 
     288         ! check if vmask agree with parent along northern and southern boundaries: 
     289         CALL Agrif_Bc_variable(vmsk_id,calledweight=1.,procname=interpvmsk) 
     290    ! check if tmask and vertical scale factors agree with parent over first two coarse grid points: 
     291         CALL Agrif_Bc_variable(e3t_id,calledweight=1.,procname=interpe3t) 
     292         ! 
     293         IF (lk_mpp) CALL mpp_sum( kindic_agr ) 
     294         IF( kindic_agr /= 0 ) THEN                    
     295            CALL ctl_stop('Child Bathymetry is not correct near boundaries.') 
     296         ELSE 
     297            IF(lwp) WRITE(numout,*) 'Child Bathymetry is ok near boundaries.' 
     298         END IF 
     299      ENDIF 
     300      ! 
    255301   ENDIF 
    256  
    257    CALL Agrif_Update_tra(0) 
    258    CALL Agrif_Update_dyn(0) 
    259  
     302   !  
     303   ! Do update at initialisation because not done before writing restarts 
     304   ! This would indeed change boundary conditions values at initial time 
     305   ! hence produce restartability issues. 
     306   ! Note that update below is recursive (with lk_agrif_doupd=T): 
     307   !  
     308! JC: I am not sure if Agrif_MaxLevel() is the "relative" 
     309!     or the absolute maximum nesting level...TBC                         
     310   IF ( Agrif_Level().EQ.Agrif_MaxLevel() ) THEN  
     311      ! NB: Do tracers first, dynamics after because nbcline incremented in dynamics 
     312      CALL Agrif_Update_tra() 
     313      CALL Agrif_Update_dyn() 
     314   ENDIF 
     315   ! 
     316# if defined key_zdftke 
     317!   CALL Agrif_Update_tke(0) 
     318# endif 
     319   ! 
     320   Agrif_UseSpecialValueInUpdate = .FALSE. 
    260321   nbcline = 0 
    261    ! 
    262    DEALLOCATE(tabtstemp) 
    263    DEALLOCATE(tabuvtemp) 
    264    DEALLOCATE(tab2d) 
     322   lk_agrif_doupd = .FALSE. 
    265323   ! 
    266324END SUBROUTINE Agrif_InitValues_cont 
    … …  
    276334   USE par_oce       !   ONLY : jpts 
    277335   USE oce 
     336   USE agrif_oce 
    278337   IMPLICIT NONE 
    279338   !!---------------------------------------------------------------------- 
    … …  
    281340   ! 1. Declaration of the type of variable which have to be interpolated 
    282341   !--------------------------------------------------------------------- 
    283    CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jpts/),tsn_id) 
    284    CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jpts/),tsa_id) 
    285    CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jpts/),tsb_id) 
    286  
    287    CALL agrif_declare_variable((/1,2,0/),(/2,3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),un_id) 
    288    CALL agrif_declare_variable((/2,1,0/),(/3,2,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),vn_id) 
    289    CALL agrif_declare_variable((/1,2,0/),(/2,3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),ua_id) 
    290    CALL agrif_declare_variable((/2,1,0/),(/3,2,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),va_id) 
    291  
    292    CALL agrif_declare_variable((/1,2/),(/2,3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),unb_id) 
    293    CALL agrif_declare_variable((/2,1/),(/3,2/),(/'x','y'/),(/1,1/),(/jpi,jpj/),vnb_id) 
    294    CALL agrif_declare_variable((/2,2/),(/3,3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),sshn_id) 
    295    CALL agrif_declare_variable((/2,2/),(/3,3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),gcb_id) 
    296    CALL agrif_declare_variable((/1,2/),(/2,3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),ub2b_id) 
    297    CALL agrif_declare_variable((/2,1/),(/3,2/),(/'x','y'/),(/1,1/),(/jpi,jpj/),vb2b_id) 
     342   CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jpts/),tsn_id) 
     343   CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jpts/),tsn_sponge_id) 
     344 
     345   CALL agrif_declare_variable((/1,2,0/),(/2,3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),un_interp_id) 
     346   CALL agrif_declare_variable((/2,1,0/),(/3,2,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),vn_interp_id) 
     347   CALL agrif_declare_variable((/1,2,0/),(/2,3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),un_update_id) 
     348   CALL agrif_declare_variable((/2,1,0/),(/3,2,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),vn_update_id) 
     349   CALL agrif_declare_variable((/1,2,0/),(/2,3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),un_sponge_id) 
     350   CALL agrif_declare_variable((/2,1,0/),(/3,2,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),vn_sponge_id) 
     351 
     352   CALL agrif_declare_variable((/2,2,0/),(/3,3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),e3t_id) 
     353   CALL agrif_declare_variable((/1,2,0/),(/2,3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),umsk_id) 
     354   CALL agrif_declare_variable((/2,1,0/),(/3,2,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),vmsk_id) 
     355 
     356   CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,3/),scales_t_id) 
     357 
     358   CALL agrif_declare_variable((/1,2/),(/2,3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),unb_id) 
     359   CALL agrif_declare_variable((/2,1/),(/3,2/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),vnb_id) 
     360   CALL agrif_declare_variable((/1,2/),(/2,3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),ub2b_interp_id) 
     361   CALL agrif_declare_variable((/2,1/),(/3,2/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),vb2b_interp_id) 
     362   CALL agrif_declare_variable((/1,2/),(/2,3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),ub2b_update_id) 
     363   CALL agrif_declare_variable((/2,1/),(/3,2/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),vb2b_update_id) 
     364 
     365   CALL agrif_declare_variable((/2,2/),(/3,3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),sshn_id) 
     366 
     367# if defined key_zdftke 
     368   CALL agrif_declare_variable((/2,2,0/),(/3,3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/), en_id) 
     369   CALL agrif_declare_variable((/2,2,0/),(/3,3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),avt_id) 
     370   CALL agrif_declare_variable((/2,2,0/),(/3,3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),avm_id) 
     371# endif 
    298372 
    299373   ! 2. Type of interpolation 
    300374   !------------------------- 
    301375   CALL Agrif_Set_bcinterp(tsn_id,interp=AGRIF_linear) 
    302    CALL Agrif_Set_bcinterp(tsa_id,interp=AGRIF_linear) 
    303  
    304    Call Agrif_Set_bcinterp(un_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
    305    Call Agrif_Set_bcinterp(vn_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
    306  
    307    Call Agrif_Set_bcinterp(ua_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
    308    Call Agrif_Set_bcinterp(va_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
     376 
     377   CALL Agrif_Set_bcinterp(un_interp_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
     378   CALL Agrif_Set_bcinterp(vn_interp_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
     379 
     380   CALL Agrif_Set_bcinterp(tsn_sponge_id,interp=AGRIF_linear) 
    309381 
    310382   CALL Agrif_Set_bcinterp(sshn_id,interp=AGRIF_linear) 
    311    Call Agrif_Set_bcinterp(unb_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
    312    Call Agrif_Set_bcinterp(vnb_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
    313    Call Agrif_Set_bcinterp(ub2b_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
    314    Call Agrif_Set_bcinterp(vb2b_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
     383   CALL Agrif_Set_bcinterp(unb_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
     384   CALL Agrif_Set_bcinterp(vnb_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
     385   CALL Agrif_Set_bcinterp(ub2b_interp_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
     386   CALL Agrif_Set_bcinterp(vb2b_interp_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
     387 
     388 
     389   CALL Agrif_Set_bcinterp(un_sponge_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
     390   CALL Agrif_Set_bcinterp(vn_sponge_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
     391 
     392   CALL Agrif_Set_bcinterp(e3t_id,interp=AGRIF_constant) 
     393   CALL Agrif_Set_bcinterp(umsk_id,interp=AGRIF_constant) 
     394   CALL Agrif_Set_bcinterp(vmsk_id,interp=AGRIF_constant) 
     395 
     396# if defined key_zdftke 
     397   CALL Agrif_Set_bcinterp(avm_id ,interp=AGRIF_linear) 
     398# endif 
     399 
    315400 
    316401   ! 3. Location of interpolation 
    317402   !----------------------------- 
    318    Call Agrif_Set_bc(un_id,(/0,1/)) 
    319    Call Agrif_Set_bc(vn_id,(/0,1/)) 
    320  
    321    Call Agrif_Set_bc(sshn_id,(/0,1/)) 
    322    Call Agrif_Set_bc(unb_id,(/0,1/)) 
    323    Call Agrif_Set_bc(vnb_id,(/0,1/)) 
    324    Call Agrif_Set_bc(ub2b_id,(/0,1/)) 
    325    Call Agrif_Set_bc(vb2b_id,(/0,1/)) 
    326  
    327    Call Agrif_Set_bc(tsn_id,(/0,1/)) 
    328    Call Agrif_Set_bc(tsa_id,(/-3*Agrif_irhox(),0/)) 
    329  
    330    Call Agrif_Set_bc(ua_id,(/-2*Agrif_irhox(),0/)) 
    331    Call Agrif_Set_bc(va_id,(/-2*Agrif_irhox(),0/)) 
     403   CALL Agrif_Set_bc(tsn_id,(/0,1/)) 
     404   CALL Agrif_Set_bc(un_interp_id,(/0,1/)) 
     405   CALL Agrif_Set_bc(vn_interp_id,(/0,1/)) 
     406 
     407!   CALL Agrif_Set_bc(tsn_sponge_id,(/-3*Agrif_irhox(),0/)) 
     408!   CALL Agrif_Set_bc(un_sponge_id,(/-2*Agrif_irhox()-1,0/)) 
     409!   CALL Agrif_Set_bc(vn_sponge_id,(/-2*Agrif_irhox()-1,0/)) 
     410   CALL Agrif_Set_bc(tsn_sponge_id,(/-nn_sponge_len*Agrif_irhox()-1,0/)) 
     411   CALL Agrif_Set_bc(un_sponge_id ,(/-nn_sponge_len*Agrif_irhox()-1,0/)) 
     412   CALL Agrif_Set_bc(vn_sponge_id ,(/-nn_sponge_len*Agrif_irhox()-1,0/)) 
     413 
     414   CALL Agrif_Set_bc(sshn_id,(/0,0/)) 
     415   CALL Agrif_Set_bc(unb_id ,(/0,0/)) 
     416   CALL Agrif_Set_bc(vnb_id ,(/0,0/)) 
     417   CALL Agrif_Set_bc(ub2b_interp_id,(/0,0/)) 
     418   CALL Agrif_Set_bc(vb2b_interp_id,(/0,0/)) 
     419 
     420   CALL Agrif_Set_bc(e3t_id,(/-2*Agrif_irhox()-1,0/))   ! if west and rhox=3: column 2 to 9 
     421   CALL Agrif_Set_bc(umsk_id,(/0,0/)) 
     422   CALL Agrif_Set_bc(vmsk_id,(/0,0/)) 
     423 
     424# if defined key_zdftke 
     425   CALL Agrif_Set_bc(avm_id ,(/0,1/)) 
     426# endif 
    332427 
    333428   ! 5. Update type 
    334429   !---------------  
    335    Call Agrif_Set_Updatetype(tsn_id, update = AGRIF_Update_Average) 
    336    Call Agrif_Set_Updatetype(tsb_id, update = AGRIF_Update_Average) 
    337  
    338    Call Agrif_Set_Updatetype(sshn_id, update = AGRIF_Update_Average) 
    339    Call Agrif_Set_Updatetype(gcb_id,update = AGRIF_Update_Average) 
    340  
    341    Call Agrif_Set_Updatetype(un_id,update1 = Agrif_Update_Copy, update2 = Agrif_Update_Average) 
    342    Call Agrif_Set_Updatetype(vn_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy) 
    343  
    344    Call Agrif_Set_Updatetype(ub2b_id,update1 = Agrif_Update_Copy, update2 = Agrif_Update_Average) 
    345    Call Agrif_Set_Updatetype(vb2b_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy) 
    346  
     430   CALL Agrif_Set_Updatetype(tsn_id, update = AGRIF_Update_Average) 
     431 
     432   CALL Agrif_Set_Updatetype(scales_t_id, update = AGRIF_Update_Average) 
     433 
     434   CALL Agrif_Set_Updatetype(un_update_id,update1 = Agrif_Update_Copy, update2 = Agrif_Update_Average) 
     435   CALL Agrif_Set_Updatetype(vn_update_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy) 
     436 
     437   CALL Agrif_Set_Updatetype(sshn_id, update = AGRIF_Update_Average) 
     438 
     439   CALL Agrif_Set_Updatetype(ub2b_update_id,update1 = Agrif_Update_Copy, update2 = Agrif_Update_Average) 
     440   CALL Agrif_Set_Updatetype(vb2b_update_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy) 
     441 
     442# if defined key_zdftke 
     443   CALL Agrif_Set_Updatetype( en_id, update = AGRIF_Update_Average) 
     444   CALL Agrif_Set_Updatetype(avt_id, update = AGRIF_Update_Average) 
     445   CALL Agrif_Set_Updatetype(avm_id, update = AGRIF_Update_Average) 
     446# endif 
     447 
     448! High order updates 
     449!   CALL Agrif_Set_Updatetype(tsn_id, update = Agrif_Update_Full_Weighting) 
     450!   CALL Agrif_Set_Updatetype(un_update_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Full_Weighting) 
     451!   CALL Agrif_Set_Updatetype(vn_update_id,update1 = Agrif_Update_Full_Weighting, update2 = Agrif_Update_Average) 
     452! 
     453!   CALL Agrif_Set_Updatetype(ub2b_update_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Full_Weighting) 
     454!   CALL Agrif_Set_Updatetype(vb2b_update_id,update1 = Agrif_Update_Full_Weighting, update2 = Agrif_Update_Average) 
     455!   CALL Agrif_Set_Updatetype(sshn_id, update = Agrif_Update_Full_Weighting) 
     456  
     457   ! 
    347458END SUBROUTINE agrif_declare_var 
    348459# endif 
    … …  
    365476   IMPLICIT NONE 
    366477   ! 
    367    REAL(wp), DIMENSION(:,:)  , ALLOCATABLE :: zvel 
    368    REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zadv 
    369    !!---------------------------------------------------------------------- 
    370  
    371    ALLOCATE( zvel(jpi,jpj), zadv(jpi,jpj,7)) 
     478   !!---------------------------------------------------------------------- 
    372479 
    373480   ! 1. Declaration of the type of variable which have to be interpolated 
    … …  
    401508   CALL Agrif_Update_lim2(0) 
    402509   ! 
    403    DEALLOCATE( zvel, zadv ) 
    404    ! 
    405510END SUBROUTINE Agrif_InitValues_cont_lim2 
    406511 
    … …  
    431536   !------------------------- 
    432537   CALL Agrif_Set_bcinterp(adv_ice_id ,interp=AGRIF_linear) 
    433    Call Agrif_Set_bcinterp(u_ice_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
    434    Call Agrif_Set_bcinterp(v_ice_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
     538   CALL Agrif_Set_bcinterp(u_ice_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
     539   CALL Agrif_Set_bcinterp(v_ice_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
    435540 
    436541   ! 3. Location of interpolation 
    437542   !----------------------------- 
    438    Call Agrif_Set_bc(adv_ice_id ,(/0,1/)) 
    439    Call Agrif_Set_bc(u_ice_id,(/0,1/)) 
    440    Call Agrif_Set_bc(v_ice_id,(/0,1/)) 
     543   CALL Agrif_Set_bc(adv_ice_id ,(/0,1/)) 
     544   CALL Agrif_Set_bc(u_ice_id,(/0,1/)) 
     545   CALL Agrif_Set_bc(v_ice_id,(/0,1/)) 
    441546 
    442547   ! 5. Update type 
    443548   !--------------- 
    444    Call Agrif_Set_Updatetype(adv_ice_id , update = AGRIF_Update_Average) 
    445    Call Agrif_Set_Updatetype(u_ice_id,update1 = Agrif_Update_Copy, update2 = Agrif_Update_Average) 
    446    Call Agrif_Set_Updatetype(v_ice_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy) 
    447  
     549   CALL Agrif_Set_Updatetype(adv_ice_id , update = AGRIF_Update_Average) 
     550   CALL Agrif_Set_Updatetype(u_ice_id,update1 = Agrif_Update_Copy, update2 = Agrif_Update_Average) 
     551   CALL Agrif_Set_Updatetype(v_ice_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy) 
     552   !  
    448553END SUBROUTINE agrif_declare_var_lim2 
    449554#  endif 
    … …  
    462567   USE nemogcm 
    463568   USE par_trc 
     569   USE lib_mpp 
    464570   USE trc 
    465571   USE in_out_manager 
     572   USE agrif_opa_sponge 
    466573   USE agrif_top_update 
    467574   USE agrif_top_interp 
    … …  
    470577   IMPLICIT NONE 
    471578   ! 
    472    REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: tabtrtemp 
     579   CHARACTER(len=10) :: cl_check1, cl_check2, cl_check3 
    473580   LOGICAL :: check_namelist 
    474581   !!---------------------------------------------------------------------- 
    475  
    476    ALLOCATE( tabtrtemp(jpi,jpj,jpk,jptra) ) 
    477582 
    478583 
    … …  
    485590   Agrif_SpecialValue=0. 
    486591   Agrif_UseSpecialValue = .TRUE. 
    487    Call Agrif_Bc_variable(tabtrtemp,trn_id,calledweight=1.,procname=interptrn) 
    488    Call Agrif_Bc_variable(tabtrtemp,tra_id,calledweight=1.,procname=interptrn) 
     592   CALL Agrif_Bc_variable(trn_id,calledweight=1.,procname=interptrn) 
    489593   Agrif_UseSpecialValue = .FALSE. 
     594   CALL Agrif_Sponge 
     595   tabspongedone_trn = .FALSE. 
     596   CALL Agrif_Bc_variable(trn_sponge_id,calledweight=1.,procname=interptrn_sponge) 
     597   ! reset tsa to zero 
     598   tra(:,:,:,:) = 0. 
     599 
    490600 
    491601   ! 3. Some controls 
    492602   !----------------- 
    493    check_namelist = .true. 
     603   check_namelist = .TRUE. 
    494604 
    495605   IF( check_namelist ) THEN 
    496 #  if defined offline      
     606# if defined key_offline 
    497607      ! Check time steps 
    498       IF( nint(Agrif_Rhot()) * nint(rdt) .ne. Agrif_Parent(rdt) ) THEN 
    499          WRITE(*,*) 'incompatible time step between grids' 
    500          WRITE(*,*) 'parent grid value : ',Agrif_Parent(rdt) 
    501          WRITE(*,*) 'child  grid value : ',nint(rdt) 
    502          WRITE(*,*) 'value on parent grid should be : ',rdt*Agrif_Rhot() 
    503          STOP 
     608      IF( NINT(Agrif_Rhot()) * NINT(rdt) .NE. Agrif_Parent(rdt) ) THEN 
     609         WRITE(cl_check1,*)  Agrif_Parent(rdt) 
     610         WRITE(cl_check2,*)  rdt 
     611         WRITE(cl_check3,*)  rdt*Agrif_Rhot() 
     612         CALL ctl_warn( 'incompatible time step between grids',   & 
     613               &               'parent grid value : '//cl_check1    ,   &  
     614               &               'child  grid value : '//cl_check2    ,   &  
     615               &               'value on child grid will be changed to  & 
     616               &               :'//cl_check3  ) 
     617         rdt=rdt*Agrif_Rhot() 
    504618      ENDIF 
    505619 
    506620      ! Check run length 
    507621      IF( Agrif_IRhot() * (Agrif_Parent(nitend)- & 
    508            Agrif_Parent(nit000)+1) .ne. (nitend-nit000+1) ) THEN 
    509          WRITE(*,*) 'incompatible run length between grids' 
    510          WRITE(*,*) 'parent grid value : ',(Agrif_Parent(nitend)- & 
    511               Agrif_Parent(nit000)+1),' time step' 
    512          WRITE(*,*) 'child  grid value : ', & 
    513               (nitend-nit000+1),' time step' 
    514          WRITE(*,*) 'value on child grid should be : ', & 
    515               Agrif_IRhot() * (Agrif_Parent(nitend)- & 
    516               Agrif_Parent(nit000)+1) 
    517          STOP 
     622            Agrif_Parent(nit000)+1) .NE. (nitend-nit000+1) ) THEN 
     623         WRITE(cl_check1,*)  (Agrif_Parent(nit000)-1)*Agrif_IRhot() + 1 
     624         WRITE(cl_check2,*)   Agrif_Parent(nitend)   *Agrif_IRhot() 
     625         CALL ctl_warn( 'incompatible run length between grids'               ,   & 
     626               &              ' nit000 on fine grid will be change to : '//cl_check1,   & 
     627               &              ' nitend on fine grid will be change to : '//cl_check2    ) 
     628         nit000 = (Agrif_Parent(nit000)-1)*Agrif_IRhot() + 1 
     629         nitend =  Agrif_Parent(nitend)   *Agrif_IRhot() 
    518630      ENDIF 
    519631 
    … …  
    521633      IF( ln_zps ) THEN 
    522634         ! check parameters for partial steps  
    523          IF( Agrif_Parent(e3zps_min) .ne. e3zps_min ) THEN 
     635         IF( Agrif_Parent(e3zps_min) .NE. e3zps_min ) THEN 
    524636            WRITE(*,*) 'incompatible e3zps_min between grids' 
    525637            WRITE(*,*) 'parent grid :',Agrif_Parent(e3zps_min) 
    … …  
    528640            STOP 
    529641         ENDIF 
    530          IF( Agrif_Parent(e3zps_rat) .ne. e3zps_rat ) THEN 
     642         IF( Agrif_Parent(e3zps_rat) .NE. e3zps_rat ) THEN 
    531643            WRITE(*,*) 'incompatible e3zps_rat between grids' 
    532644            WRITE(*,*) 'parent grid :',Agrif_Parent(e3zps_rat) 
    … …  
    538650#  endif          
    539651      ! Check passive tracer cell 
    540       IF( nn_dttrc .ne. 1 ) THEN 
     652      IF( nn_dttrc .NE. 1 ) THEN 
    541653         WRITE(*,*) 'nn_dttrc should be equal to 1' 
    542654      ENDIF 
    543655   ENDIF 
    544656 
    545 !ch   CALL Agrif_Update_trc(0) 
     657   CALL Agrif_Update_trc(0) 
     658   ! 
     659   Agrif_UseSpecialValueInUpdate = .FALSE. 
    546660   nbcline_trc = 0 
    547    ! 
    548    DEALLOCATE(tabtrtemp) 
    549661   ! 
    550662END SUBROUTINE Agrif_InitValues_cont_top 
    … …  
    558670   !!---------------------------------------------------------------------- 
    559671   USE agrif_util 
     672   USE agrif_oce 
    560673   USE dom_oce 
    561674   USE trc 
    … …  
    565678   ! 1. Declaration of the type of variable which have to be interpolated 
    566679   !--------------------------------------------------------------------- 
    567    CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jptra/),trn_id) 
    568    CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jptra/),trb_id) 
    569    CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jptra/),tra_id) 
     680   CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jptra/),trn_id) 
     681   CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jptra/),trn_sponge_id) 
    570682 
    571683   ! 2. Type of interpolation 
    572684   !------------------------- 
    573685   CALL Agrif_Set_bcinterp(trn_id,interp=AGRIF_linear) 
    574    CALL Agrif_Set_bcinterp(tra_id,interp=AGRIF_linear) 
     686   CALL Agrif_Set_bcinterp(trn_sponge_id,interp=AGRIF_linear) 
    575687 
    576688   ! 3. Location of interpolation 
    577689   !----------------------------- 
    578    Call Agrif_Set_bc(trn_id,(/0,1/)) 
    579    Call Agrif_Set_bc(tra_id,(/-3*Agrif_irhox(),0/)) 
     690   CALL Agrif_Set_bc(trn_id,(/0,1/)) 
     691!   CALL Agrif_Set_bc(trn_sponge_id,(/-3*Agrif_irhox(),0/)) 
     692   CALL Agrif_Set_bc(trn_sponge_id,(/-nn_sponge_len*Agrif_irhox()-1,0/)) 
    580693 
    581694   ! 5. Update type 
    582695   !---------------  
    583    Call Agrif_Set_Updatetype(trn_id, update = AGRIF_Update_Average) 
    584    Call Agrif_Set_Updatetype(trb_id, update = AGRIF_Update_Average) 
    585  
    586  
     696   CALL Agrif_Set_Updatetype(trn_id, update = AGRIF_Update_Average) 
     697 
     698!   Higher order update 
     699!   CALL Agrif_Set_Updatetype(tsn_id, update = Agrif_Update_Full_Weighting) 
     700 
     701   ! 
    587702END SUBROUTINE agrif_declare_var_top 
    588703# endif 
    … …  
    592707   !!   *** ROUTINE Agrif_detect *** 
    593708   !!---------------------------------------------------------------------- 
    594    USE Agrif_Types 
    595709   ! 
    596710   INTEGER, DIMENSION(2) :: ksizex 
    … …  
    614728   ! 
    615729   INTEGER  ::   ios                 ! Local integer output status for namelist read 
    616    NAMELIST/namagrif/ nn_cln_update, rn_sponge_tra, rn_sponge_dyn, ln_spc_dyn 
    617    !!---------------------------------------------------------------------- 
    618    ! 
    619       REWIND( numnam_ref )              ! Namelist namagrif in reference namelist : AGRIF zoom 
    620       READ  ( numnam_ref, namagrif, IOSTAT = ios, ERR = 901) 
    621 901   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namagrif in reference namelist', lwp ) 
    622  
    623       REWIND( numnam_cfg )              ! Namelist namagrif in configuration namelist : AGRIF zoom 
    624       READ  ( numnam_cfg, namagrif, IOSTAT = ios, ERR = 902 ) 
    625 902   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namagrif in configuration namelist', lwp ) 
    626       IF(lwm) WRITE ( numond, namagrif ) 
     730   INTEGER  ::   iminspon 
     731   NAMELIST/namagrif/ nn_cln_update, rn_sponge_tra, rn_sponge_dyn, ln_spc_dyn, ln_chk_bathy 
     732   !!-------------------------------------------------------------------------------------- 
     733   ! 
     734   REWIND( numnam_ref )              ! Namelist namagrif in reference namelist : AGRIF zoom 
     735   READ  ( numnam_ref, namagrif, IOSTAT = ios, ERR = 901) 
     736901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namagrif in reference namelist', lwp ) 
     737 
     738   REWIND( numnam_cfg )              ! Namelist namagrif in configuration namelist : AGRIF zoom 
     739   READ  ( numnam_cfg, namagrif, IOSTAT = ios, ERR = 902 ) 
     740902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namagrif in configuration namelist', lwp ) 
     741   IF(lwm) WRITE ( numond, namagrif ) 
    627742   ! 
    628743   IF(lwp) THEN                    ! control print 
    … …  
    635750      WRITE(numout,*) '      sponge coefficient for dynamics   rn_sponge_tra = ', rn_sponge_dyn, ' s' 
    636751      WRITE(numout,*) '      use special values for dynamics   ln_spc_dyn    = ', ln_spc_dyn 
     752      WRITE(numout,*) '      check bathymetry                  ln_chk_bathy  = ', ln_chk_bathy 
    637753      WRITE(numout,*)  
    638754   ENDIF 
    … …  
    643759   visc_dyn      = rn_sponge_dyn 
    644760   ! 
    645    IF( agrif_oce_alloc()  > 0 )   CALL ctl_warn('agrif sol_oce_alloc: allocation of arrays failed') 
     761   ! Check sponge length: 
     762   iminspon = MIN(FLOOR(REAL(jpiglo-4)/REAL(2*Agrif_irhox())), FLOOR(REAL(jpjglo-4)/REAL(2*Agrif_irhox())) ) 
     763   IF (lk_mpp) iminspon = MIN(iminspon,FLOOR(REAL(jpi-2)/REAL(Agrif_irhox())), FLOOR(REAL(jpj-2)/REAL(Agrif_irhox())) ) 
     764   IF (nn_sponge_len > iminspon)  CALL ctl_stop('agrif sponge length is too large') 
     765   ! 
     766   IF( agrif_oce_alloc()  > 0 )   CALL ctl_warn('agrif agrif_oce_alloc: allocation of arrays failed') 
    646767# if defined key_lim2 
    647768   IF( agrif_ice_alloc()  > 0 )   CALL ctl_stop('agrif agrif_ice_alloc: allocation of arrays failed') 
    … …  
    664785   SELECT CASE( i ) 
    665786   CASE(1)   ;   indglob = indloc + nimppt(nprocloc+1) - 1 
    666    CASE(2)   ;   indglob = indloc + njmppt(nprocloc+1) - 1  
    667    CASE(3)   ;   indglob = indloc 
    668    CASE(4)   ;   indglob = indloc 
     787   CASE(2)   ;   indglob = indloc + njmppt(nprocloc+1) - 1 
     788   CASE DEFAULT 
     789      indglob = indloc 
    669790   END SELECT 
    670791   ! 
    671792END SUBROUTINE Agrif_InvLoc 
     793 
     794SUBROUTINE Agrif_get_proc_info( imin, imax, jmin, jmax ) 
     795   !!---------------------------------------------------------------------- 
     796   !!                 *** ROUTINE Agrif_get_proc_info *** 
     797   !!---------------------------------------------------------------------- 
     798   USE par_oce 
     799   IMPLICIT NONE 
     800   ! 
     801   INTEGER, INTENT(out) :: imin, imax 
     802   INTEGER, INTENT(out) :: jmin, jmax 
     803   !!---------------------------------------------------------------------- 
     804   ! 
     805   imin = nimppt(Agrif_Procrank+1)  ! ????? 
     806   jmin = njmppt(Agrif_Procrank+1)  ! ????? 
     807   imax = imin + jpi - 1 
     808   jmax = jmin + jpj - 1 
     809   !  
     810END SUBROUTINE Agrif_get_proc_info 
     811 
     812SUBROUTINE Agrif_estimate_parallel_cost(imin, imax,jmin, jmax, nbprocs, grid_cost) 
     813   !!---------------------------------------------------------------------- 
     814   !!                 *** ROUTINE Agrif_estimate_parallel_cost *** 
     815   !!---------------------------------------------------------------------- 
     816   USE par_oce 
     817   IMPLICIT NONE 
     818   ! 
     819   INTEGER,  INTENT(in)  :: imin, imax 
     820   INTEGER,  INTENT(in)  :: jmin, jmax 
     821   INTEGER,  INTENT(in)  :: nbprocs 
     822   REAL(wp), INTENT(out) :: grid_cost 
     823   !!---------------------------------------------------------------------- 
     824   ! 
     825   grid_cost = REAL(imax-imin+1,wp)*REAL(jmax-jmin+1,wp) / REAL(nbprocs,wp) 
     826   ! 
     827END SUBROUTINE Agrif_estimate_parallel_cost 
    672828 
    673829# endif 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OFF_SRC/dtadyn.F90

    r6836 r6839  
    431431         CALL ctl_stop( 'dta_dyn: unable to allocate sf structure' )   ;   RETURN 
    432432      ENDIF 
     433      !                                         ! fill sf with slf_i and control print 
     434      CALL fld_fill( sf_dyn, slf_d, cn_dir, 'dta_dyn_init', 'Data in file', 'namdta_dyn' ) 
    433435      ! Open file for each variable to get his number of dimension 
    434436      DO ifpr = 1, jfld 
    435          CALL iom_open( TRIM( cn_dir )//TRIM( slf_d(ifpr)%clname ), inum ) 
    436          idv   = iom_varid( inum , slf_d(ifpr)%clvar )  ! id of the variable sdjf%clvar 
    437          idimv = iom_file ( inum )%ndims(idv)             ! number of dimension for variable sdjf%clvar 
    438          IF( inum /= 0 )   CALL iom_close( inum )       ! close file if already open 
     437         CALL fld_clopn( sf_dyn(ifpr), nyear, nmonth, nday ) 
     438         idv   = iom_varid( sf_dyn(ifpr)%num , slf_d(ifpr)%clvar )        ! id of the variable sdjf%clvar 
     439         idimv = iom_file ( sf_dyn(ifpr)%num )%ndims(idv)                 ! number of dimension for variable sdjf%clvar 
     440         IF( sf_dyn(ifpr)%num /= 0 )   CALL iom_close( sf_dyn(ifpr)%num ) ! close file if already open 
     441         ierr1=0 
    439442         IF( idimv == 3 ) THEN    ! 2D variable 
    440443                                      ALLOCATE( sf_dyn(ifpr)%fnow(jpi,jpj,1)    , STAT=ierr0 ) 
    … …  
    448451         ENDIF 
    449452      END DO 
    450       !                                         ! fill sf with slf_i and control print 
    451       CALL fld_fill( sf_dyn, slf_d, cn_dir, 'dta_dyn_init', 'Data in file', 'namdta_dyn' ) 
    452453      ! 
    453454      IF( lk_ldfslp .AND. .NOT.lk_c1d ) THEN                  ! slopes  

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/ASM/asminc.F90

    r6836 r6839  
    658658 
    659659      DO jk = 1, jpkm1 
    660          fzptnz(:,:,jk) = eos_fzp( tsn(:,:,jk,jp_sal), fsdept(:,:,jk) ) 
     660        CALL eos_fzp( tsn(:,:,jk,jp_sal), fzptnz(:,:,jk), fsdept(:,:,jk) ) 
    661661      END DO 
    662662 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/BDY/bdydta.F90

    r6836 r6839  
    430430      CHARACTER(len=100)                     ::   cn_dir        ! Root directory for location of data files 
    431431      CHARACTER(len=100), DIMENSION(nb_bdy)  ::   cn_dir_array  ! Root directory for location of data files 
     432      CHARACTER(len = 256)::   clname                           ! temporary file name 
    432433      LOGICAL                                ::   ln_full_vel   ! =T => full velocities in 3D boundary data 
    433434                                                                ! =F => baroclinic velocities in 3D boundary data 
    … …  
    669670            ! sea ice 
    670671            IF( nn_ice_lim_dta(ib_bdy) .eq. 1 ) THEN 
    671  
    672                ! Test for types of ice input (lim2 or lim3)  
    673                CALL iom_open ( bn_a_i%clname, inum ) 
    674                id1 = iom_varid ( inum, bn_a_i%clvar, kdimsz=zdimsz, kndims=zndims, ldstop = .FALSE. ) 
     672               ! Test for types of ice input (lim2 or lim3) 
     673               ! Build file name to find dimensions  
     674               clname=TRIM(bn_a_i%clname) 
     675               IF( .NOT. bn_a_i%ln_clim ) THEN    
     676                                                  WRITE(clname, '(a,"_y",i4.4)' ) TRIM( bn_a_i%clname ), nyear    ! add year 
     677                  IF( bn_a_i%cltype /= 'yearly' ) WRITE(clname, '(a,"m" ,i2.2)' ) TRIM( clname        ), nmonth   ! add month 
     678               ELSE 
     679                  IF( bn_a_i%cltype /= 'yearly' ) WRITE(clname, '(a,"_m",i2.2)' ) TRIM( bn_a_i%clname ), nmonth   ! add month 
     680               ENDIF 
     681               IF( bn_a_i%cltype == 'daily' .OR. bn_a_i%cltype(1:4) == 'week' ) & 
     682               &                                  WRITE(clname, '(a,"d" ,i2.2)' ) TRIM( clname        ), nday     ! add day 
     683               ! 
     684               CALL iom_open  ( clname, inum ) 
     685               id1 = iom_varid( inum, bn_a_i%clvar, kdimsz=zdimsz, kndims=zndims, ldstop = .FALSE. ) 
    675686               CALL iom_close ( inum ) 
    676                !CALL fld_clopn ( bn_a_i, nyear, nmonth, nday, ldstop=.TRUE. ) 
    677                !CALL iom_open ( bn_a_i%clname, inum ) 
    678                !id1 = iom_varid ( bn_a_i%num, bn_a_i%clvar, kdimsz=zdimsz, kndims=zndims, ldstop = .FALSE. ) 
     687 
    679688                IF ( zndims == 4 ) THEN 
    680689                 ll_bdylim3 = .TRUE.   ! lim3 input 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/BDY/bdydyn2d.F90

    r6836 r6839  
    4949      !!---------------------------------------------------------------------- 
    5050      INTEGER,                      INTENT(in) ::   kt   ! Main time step counter 
    51       REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pua2d, pva2d  
    52       REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ) :: pub2d, pvb2d 
    53       REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ) :: phur, phvr 
    54       REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ) :: pssh 
     51      REAL(wp), DIMENSION(:,:), INTENT(inout) :: pua2d, pva2d  
     52      REAL(wp), DIMENSION(:,:), INTENT(in   ) :: pub2d, pvb2d 
     53      REAL(wp), DIMENSION(:,:), INTENT(in   ) :: phur, phvr 
     54      REAL(wp), DIMENSION(:,:), INTENT(in   ) :: pssh 
    5555      !! 
    5656      INTEGER                                  ::   ib_bdy ! Loop counter 
    … …  
    9292      TYPE(OBC_DATA),  INTENT(in) ::   dta  ! OBC external data 
    9393      INTEGER,         INTENT(in) ::   ib_bdy  ! BDY set index 
    94       REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pua2d, pva2d  
     94      REAL(wp), DIMENSION(:,:), INTENT(inout) :: pua2d, pva2d  
    9595      !! 
    9696      INTEGER  ::   jb, jk         ! dummy loop indices 
    … …  
    147147      TYPE(OBC_DATA),               INTENT(in) ::   dta  ! OBC external data 
    148148      INTEGER,                      INTENT(in) ::   ib_bdy  ! BDY set index 
    149       REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pua2d, pva2d 
    150       REAL(wp), DIMENSION(jpi,jpj), INTENT(in) ::   pssh, phur, phvr  
     149      REAL(wp), DIMENSION(:,:), INTENT(inout) :: pua2d, pva2d 
     150      REAL(wp), DIMENSION(:,:), INTENT(in) ::   pssh, phur, phvr  
    151151 
    152152      INTEGER  ::   jb, igrd                         ! dummy loop indices 
    … …  
    237237      TYPE(OBC_DATA),               INTENT(in) ::   dta  ! OBC external data 
    238238      INTEGER,                      INTENT(in) ::   ib_bdy  ! number of current open boundary set 
    239       REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pua2d, pva2d 
    240       REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pub2d, pvb2d  
     239      REAL(wp), DIMENSION(:,:),    INTENT(inout) :: pua2d, pva2d 
     240      REAL(wp), DIMENSION(:,:),    INTENT(in) :: pub2d, pvb2d  
    241241      LOGICAL,                      INTENT(in) ::   ll_npo  ! flag for NPO version 
    242242 
    … …  
    271271      !! 
    272272      !!---------------------------------------------------------------------- 
    273       REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   zssh ! Sea level 
     273      REAL(wp), DIMENSION(:,:), INTENT(inout) ::   zssh ! Sea level 
    274274      !! 
    275275      INTEGER  ::   ib_bdy, ib, igrd                        ! local integers 
    276       INTEGER  ::   ii, ij, zcoef, zcoef1, zcoef2, ip, jp   !   "       " 
     276      INTEGER  ::   ii, ij, zcoef, ip, jp   !   "       " 
    277277 
    278278      igrd = 1                       ! Everything is at T-points here 
    … …  
    283283            ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 
    284284            ! Set gradient direction: 
    285             zcoef1 = bdytmask(ii-1,ij  ) +  bdytmask(ii+1,ij  ) 
    286             zcoef2 = bdytmask(ii  ,ij-1) +  bdytmask(ii  ,ij+1) 
    287             IF ( zcoef1+zcoef2 == 0 ) THEN 
    288                ! corner 
    289 !               zcoef = tmask(ii-1,ij,1) + tmask(ii+1,ij,1) +  tmask(ii,ij-1,1) +  tmask(ii,ij+1,1) 
    290 !               zssh(ii,ij) = zssh(ii-1,ij  ) * tmask(ii-1,ij  ,1) + & 
    291 !                 &           zssh(ii+1,ij  ) * tmask(ii+1,ij  ,1) + & 
    292 !                 &           zssh(ii  ,ij-1) * tmask(ii  ,ij-1,1) + & 
    293 !                 &           zssh(ii  ,ij+1) * tmask(ii  ,ij+1,1) 
    294                zcoef = bdytmask(ii-1,ij) + bdytmask(ii+1,ij) +  bdytmask(ii,ij-1) +  bdytmask(ii,ij+1) 
    295                zssh(ii,ij) = zssh(ii-1,ij  ) * bdytmask(ii-1,ij  ) + & 
    296                  &           zssh(ii+1,ij  ) * bdytmask(ii+1,ij  ) + & 
    297                  &           zssh(ii  ,ij-1) * bdytmask(ii  ,ij-1) + & 
    298                  &           zssh(ii  ,ij+1) * bdytmask(ii  ,ij+1) 
    299                zssh(ii,ij) = ( zssh(ii,ij) / MAX( 1, zcoef) ) * tmask(ii,ij,1) 
     285            zcoef = bdytmask(ii-1,ij) + bdytmask(ii+1,ij) +  bdytmask(ii,ij-1) +  bdytmask(ii,ij+1) 
     286            IF ( zcoef == 0 ) THEN 
     287               zssh(ii,ij) = 0._wp 
    300288            ELSE 
    301289               ip = bdytmask(ii+1,ij  ) - bdytmask(ii-1,ij  ) 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/BDY/bdyice_lim.F90

    r6836 r6839  
    107107      REAL(wp) ::   zwgt, zwgt1        ! local scalar 
    108108      REAL(wp) ::   ztmelts, zdh 
     109#if  defined key_lim2 && ! defined key_lim2_vp && defined key_agrif 
     110     USE ice_2, vt_s => hsnm 
     111     USE ice_2, vt_i => hicm 
     112#endif 
    109113 
    110114      !!------------------------------------------------------------------------------ 
    … …  
    115119      ! 
    116120#if defined key_lim2 
    117       DO jb = 1, idx%nblen(jgrd) 
     121      DO jb = 1, idx%nblenrim(jgrd) 
    118122         ji    = idx%nbi(jb,jgrd) 
    119123         jj    = idx%nbj(jb,jgrd) 
    … …  
    135139 
    136140      DO jl = 1, jpl 
    137          DO jb = 1, idx%nblen(jgrd) 
     141         DO jb = 1, idx%nblenrim(jgrd) 
    138142            ji    = idx%nbi(jb,jgrd) 
    139143            jj    = idx%nbj(jb,jgrd) 
    … …  
    171175 
    172176      DO jl = 1, jpl 
    173          DO jb = 1, idx%nblen(jgrd) 
     177         DO jb = 1, idx%nblenrim(jgrd) 
    174178            ji    = idx%nbi(jb,jgrd) 
    175179            jj    = idx%nbj(jb,jgrd) 
    … …  
    324328                
    325329               jgrd = 2      ! u velocity 
    326                DO jb = 1, idx_bdy(ib_bdy)%nblen(jgrd) 
     330               DO jb = 1, idx_bdy(ib_bdy)%nblenrim(jgrd) 
    327331                  ji    = idx_bdy(ib_bdy)%nbi(jb,jgrd) 
    328332                  jj    = idx_bdy(ib_bdy)%nbj(jb,jgrd) 
    … …  
    353357                
    354358               jgrd = 3      ! v velocity 
    355                DO jb = 1, idx_bdy(ib_bdy)%nblen(jgrd) 
     359               DO jb = 1, idx_bdy(ib_bdy)%nblenrim(jgrd) 
    356360                  ji    = idx_bdy(ib_bdy)%nbi(jb,jgrd) 
    357361                  jj    = idx_bdy(ib_bdy)%nbj(jb,jgrd) 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/BDY/bdyini.F90

    r6836 r6839  
    7676      INTEGER  ::   ib_bdy, ii, ij, ik, igrd, ib, ir, iseg ! dummy loop indices 
    7777      INTEGER  ::   icount, icountr, ibr_max, ilen1, ibm1  ! local integers 
    78       INTEGER  ::   iw, ie, is, in, inum, id_dummy         !   -       - 
     78      INTEGER  ::   iwe, ies, iso, ino, inum, id_dummy         !   -       - 
    7979      INTEGER  ::   igrd_start, igrd_end, jpbdta           !   -       - 
    8080      INTEGER  ::   jpbdtau, jpbdtas                       !   -       - 
    … …  
    777777!      is = mjg(1) + 1            ! if monotasking and no zoom, is=2 
    778778!      in = mjg(1) + nlcj-1 - 1   ! if monotasking and no zoom, in=jpjm1       
    779       iw = mig(1) - jpizoom + 2         ! if monotasking and no zoom, iw=2 
    780       ie = mig(1) + nlci - jpizoom - 1  ! if monotasking and no zoom, ie=jpim1 
    781       is = mjg(1) - jpjzoom + 2         ! if monotasking and no zoom, is=2 
    782       in = mjg(1) + nlcj - jpjzoom - 1  ! if monotasking and no zoom, in=jpjm1 
     779      iwe = mig(1) - jpizoom + 2         ! if monotasking and no zoom, iw=2 
     780      ies = mig(1) + nlci - jpizoom - 1  ! if monotasking and no zoom, ie=jpim1 
     781      iso = mjg(1) - jpjzoom + 2         ! if monotasking and no zoom, is=2 
     782      ino = mjg(1) + nlcj - jpjzoom - 1  ! if monotasking and no zoom, in=jpjm1 
    783783 
    784784      ALLOCATE( nbondi_bdy(nb_bdy)) 
    … …  
    853853               ENDIF 
    854854               ! check if point is in local domain 
    855                IF(  nbidta(ib,igrd,ib_bdy) >= iw .AND. nbidta(ib,igrd,ib_bdy) <= ie .AND.   & 
    856                   & nbjdta(ib,igrd,ib_bdy) >= is .AND. nbjdta(ib,igrd,ib_bdy) <= in       ) THEN 
     855               IF(  nbidta(ib,igrd,ib_bdy) >= iwe .AND. nbidta(ib,igrd,ib_bdy) <= ies .AND.   & 
     856                  & nbjdta(ib,igrd,ib_bdy) >= iso .AND. nbjdta(ib,igrd,ib_bdy) <= ino      ) THEN 
    857857                  ! 
    858858                  icount = icount  + 1 
    … …  
    890890         com_south_b = 0 
    891891         com_north_b = 0 
     892 
    892893         DO igrd = 1, jpbgrd 
    893894            icount  = 0 
    … …  
    896897               DO ib = 1, nblendta(igrd,ib_bdy) 
    897898                  ! check if point is in local domain and equals ir 
    898                   IF(  nbidta(ib,igrd,ib_bdy) >= iw .AND. nbidta(ib,igrd,ib_bdy) <= ie .AND.   & 
    899                      & nbjdta(ib,igrd,ib_bdy) >= is .AND. nbjdta(ib,igrd,ib_bdy) <= in .AND.   & 
     899                  IF(  nbidta(ib,igrd,ib_bdy) >= iwe .AND. nbidta(ib,igrd,ib_bdy) <= ies .AND.   & 
     900                     & nbjdta(ib,igrd,ib_bdy) >= iso .AND. nbjdta(ib,igrd,ib_bdy) <= ino .AND.   & 
    900901                     & nbrdta(ib,igrd,ib_bdy) == ir  ) THEN 
    901902                     ! 
    … …  
    15941595            ELSE 
    15951596               ! This is a corner 
    1596                WRITE(numout,*) 'Found a South-West corner at (i,j): ', jpiwob(ib), jpjwdt(ib) 
     1597               IF(lwp) WRITE(numout,*) 'Found a South-West corner at (i,j): ', jpiwob(ib), jpjwdt(ib) 
    15971598               CALL bdy_ctl_corn(npckgw(ib), icornw(ib,1)) 
    15981599               itest=itest+1 
    … …  
    16081609            ELSE 
    16091610               ! This is a corner 
    1610                WRITE(numout,*) 'Found a North-West corner at (i,j): ', jpiwob(ib), jpjwft(ib) 
     1611               IF(lwp) WRITE(numout,*) 'Found a North-West corner at (i,j): ', jpiwob(ib), jpjwft(ib) 
    16111612               CALL bdy_ctl_corn(npckgw(ib), icornw(ib,2)) 
    16121613               itest=itest+1 
    … …  
    16381639            ELSE 
    16391640               ! This is a corner 
    1640                WRITE(numout,*) 'Found a South-East corner at (i,j): ', jpieob(ib)+1, jpjedt(ib) 
     1641               IF(lwp) WRITE(numout,*) 'Found a South-East corner at (i,j): ', jpieob(ib)+1, jpjedt(ib) 
    16411642               CALL bdy_ctl_corn(npckge(ib), icorne(ib,1)) 
    16421643               itest=itest+1 
    … …  
    16521653            ELSE 
    16531654               ! This is a corner 
    1654                WRITE(numout,*) 'Found a North-East corner at (i,j): ', jpieob(ib)+1, jpjeft(ib) 
     1655               IF(lwp) WRITE(numout,*) 'Found a North-East corner at (i,j): ', jpieob(ib)+1, jpjeft(ib) 
    16551656               CALL bdy_ctl_corn(npckge(ib), icorne(ib,2)) 
    16561657               itest=itest+1 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/BDY/bdytides.F90

    r6836 r6839  
    416416      ! Absolute time from model initialization:    
    417417      IF( PRESENT(kit) ) THEN   
    418          z_arg = ( kt + (kit+0.5_wp*(time_add-1)) / REAL(nn_baro,wp) ) * rdt 
     418         z_arg = ( kt + (kit+time_add-1) / REAL(nn_baro,wp) ) * rdt 
    419419      ELSE                               
    420420         z_arg = ( kt + time_add ) * rdt 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/BDY/bdyvol.F90

    r6836 r6839  
    9191      ! Calculate the cumulate surface Flux z_cflxemp (m3/s) over all the domain 
    9292      ! ----------------------------------------------------------------------- 
    93       z_cflxemp = SUM ( ( emp(:,:)-rnf(:,:)+rdivisf*fwfisf(:,:) ) * bdytmask(:,:) * e1t(:,:) * e2t(:,:) ) / rau0 
     93      z_cflxemp = SUM ( ( emp(:,:)-rnf(:,:)+fwfisf(:,:) ) * bdytmask(:,:) * e1t(:,:) * e2t(:,:) ) / rau0 
    9494      IF( lk_mpp )   CALL mpp_sum( z_cflxemp )     ! sum over the global domain 
    9595 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/DIA/diaar5.F90

    r6836 r6839  
    211211      REAL(wp) ::   zztmp   
    212212      REAL(wp), POINTER, DIMENSION(:,:,:,:) ::   zsaldta   ! Jan/Dec levitus salinity 
    213       ! reading initial file 
    214       LOGICAL  ::   ln_tsd_init      !: T & S data flag 
    215       LOGICAL  ::   ln_tsd_tradmp    !: internal damping toward input data flag 
    216       CHARACTER(len=100)            ::   cn_dir 
    217       TYPE(FLD_N)                   ::  sn_tem,sn_sal 
    218       INTEGER  ::   ios=0 
    219  
    220       NAMELIST/namtsd/ ln_tsd_init,ln_tsd_tradmp,cn_dir,sn_tem,sn_sal 
    221       ! 
    222  
    223       REWIND( numnam_ref )              ! Namelist namtsd in reference namelist : 
    224       READ  ( numnam_ref, namtsd, IOSTAT = ios, ERR = 901) 
    225 901   IF( ios /= 0 ) CALL ctl_nam ( ios , ' namtsd in reference namelist for dia_ar5', lwp ) 
    226       REWIND( numnam_cfg )              ! Namelist namtsd in configuration namelist : Parameters of the run 
    227       READ  ( numnam_cfg, namtsd, IOSTAT = ios, ERR = 902 ) 
    228 902   IF( ios /= 0 ) CALL ctl_nam ( ios , ' namtsd in configuration namelist for dia_ar5', lwp ) 
    229       IF(lwm) WRITE ( numond, namtsd ) 
    230213      ! 
    231214      !!---------------------------------------------------------------------- 
    … …  
    233216      IF( nn_timing == 1 )   CALL timing_start('dia_ar5_init') 
    234217      ! 
    235       CALL wrk_alloc( jpi , jpj , jpk, jpts, zsaldta ) 
     218      CALL wrk_alloc( jpi, jpj, jpk, 2, zsaldta ) 
    236219      !                                      ! allocate dia_ar5 arrays 
    237220      IF( dia_ar5_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'dia_ar5_init : unable to allocate arrays' ) 
    … …  
    249232      IF( lk_mpp )   CALL mpp_sum( vol0 ) 
    250233 
    251       CALL iom_open ( TRIM( cn_dir )//TRIM(sn_sal%clname), inum ) 
    252       CALL iom_get  ( inum, jpdom_data, TRIM(sn_sal%clvar), zsaldta(:,:,:,1), 1  ) 
    253       CALL iom_get  ( inum, jpdom_data, TRIM(sn_sal%clvar), zsaldta(:,:,:,2), 12 ) 
     234      CALL iom_open ( 'sali_ref_clim_monthly', inum ) 
     235      CALL iom_get  ( inum, jpdom_data, 'vosaline' , zsaldta(:,:,:,1), 1  ) 
     236      CALL iom_get  ( inum, jpdom_data, 'vosaline' , zsaldta(:,:,:,2), 12 ) 
    254237      CALL iom_close( inum ) 
     238 
    255239      sn0(:,:,:) = 0.5_wp * ( zsaldta(:,:,:,1) + zsaldta(:,:,:,2) )         
    256240      sn0(:,:,:) = sn0(:,:,:) * tmask(:,:,:) 
    … …  
    267251      ENDIF 
    268252      ! 
    269       CALL wrk_dealloc( jpi , jpj , jpk, jpts, zsaldta ) 
     253      CALL wrk_dealloc( jpi, jpj, jpk, 2, zsaldta ) 
    270254      ! 
    271255      IF( nn_timing == 1 )   CALL timing_stop('dia_ar5_init') 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/DIA/diaharm.F90

    r6836 r6839  
    196196                  DO ji = 1,jpi 
    197197                     ! Elevation 
    198                      ana_temp(ji,jj,nhc,1) = ana_temp(ji,jj,nhc,1) + ztemp*sshn(ji,jj)           *tmask_i(ji,jj)         
    199 #if defined key_dynspg_ts 
    200                      ana_temp(ji,jj,nhc,2) = ana_temp(ji,jj,nhc,2) + ztemp*un_b(ji,jj)*hur(ji,jj)*umask_i(ji,jj) 
    201                      ana_temp(ji,jj,nhc,3) = ana_temp(ji,jj,nhc,3) + ztemp*vn_b(ji,jj)*hvr(ji,jj)*vmask_i(ji,jj) 
    202 #endif 
     198                     ana_temp(ji,jj,nhc,1) = ana_temp(ji,jj,nhc,1) + ztemp*sshn(ji,jj)*tmask_i(ji,jj)         
     199                     ana_temp(ji,jj,nhc,2) = ana_temp(ji,jj,nhc,2) + ztemp*un_b(ji,jj)*umask_i(ji,jj) 
     200                     ana_temp(ji,jj,nhc,3) = ana_temp(ji,jj,nhc,3) + ztemp*vn_b(ji,jj)*vmask_i(ji,jj) 
    203201                  END DO 
    204202               END DO 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/DIA/diahsb.F90

    r6836 r6839  
    9393      ! 1 - Trends due to forcing ! 
    9494      ! ------------------------- ! 
    95       z_frc_trd_v = r1_rau0 * glob_sum( - ( emp(:,:) - rnf(:,:) + rdivisf * fwfisf(:,:) ) * surf(:,:) ) ! volume fluxes 
     95      z_frc_trd_v = r1_rau0 * glob_sum( - ( emp(:,:) - rnf(:,:) + fwfisf(:,:) ) * surf(:,:) ) ! volume fluxes 
    9696      z_frc_trd_t =           glob_sum( sbc_tsc(:,:,jp_tem) * surf(:,:) )                               ! heat fluxes 
    9797      z_frc_trd_s =           glob_sum( sbc_tsc(:,:,jp_sal) * surf(:,:) )                               ! salt fluxes 
    … …  
    101101      ! Add ice shelf heat & salt input 
    102102      IF( nn_isf .GE. 1 )  THEN 
    103           z_frc_trd_t = z_frc_trd_t & 
    104               &   + glob_sum( ( risf_tsc(:,:,jp_tem) - rdivisf * fwfisf(:,:) * (-1.9) * r1_rau0 ) * surf(:,:) ) 
    105           z_frc_trd_s = z_frc_trd_s + (1.0_wp - rdivisf) * glob_sum( risf_tsc(:,:,jp_sal) * surf(:,:) ) 
     103          z_frc_trd_t = z_frc_trd_t + glob_sum( risf_tsc(:,:,jp_tem) * surf(:,:) ) 
     104          z_frc_trd_s = z_frc_trd_s + glob_sum( risf_tsc(:,:,jp_sal) * surf(:,:) ) 
    106105      ENDIF 
    107106 
    … …  
    200199!      ENDIF 
    201200!!gm end 
    202  
    203201 
    204202      IF( lk_vvl ) THEN 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/DIA/diawri.F90

    r6836 r6839  
    145145      ENDIF 
    146146 
    147       IF( .NOT.lk_vvl ) THEN 
    148          CALL iom_put( "e3t" , fse3t_n(:,:,:) ) 
    149          CALL iom_put( "e3u" , fse3u_n(:,:,:) ) 
    150          CALL iom_put( "e3v" , fse3v_n(:,:,:) ) 
    151          CALL iom_put( "e3w" , fse3w_n(:,:,:) ) 
    152       ENDIF 
     147      ! Output of initial vertical scale factor 
     148      CALL iom_put("e3t_0", e3t_0(:,:,:) ) 
     149      CALL iom_put("e3u_0", e3t_0(:,:,:) ) 
     150      CALL iom_put("e3v_0", e3t_0(:,:,:) ) 
     151      ! 
     152      CALL iom_put( "e3t" , fse3t_n(:,:,:) ) 
     153      CALL iom_put( "e3u" , fse3u_n(:,:,:) ) 
     154      CALL iom_put( "e3v" , fse3v_n(:,:,:) ) 
     155      CALL iom_put( "e3w" , fse3w_n(:,:,:) ) 
     156      IF( iom_use("e3tdef") )   & 
     157         CALL iom_put( "e3tdef"  , ( ( fse3t_n(:,:,:) - e3t_0(:,:,:) ) / e3t_0(:,:,:) * 100 * tmask(:,:,:) ) ** 2 ) 
     158 
    153159 
    154160      CALL iom_put( "ssh" , sshn )                 ! sea surface height 
    155       if( iom_use('ssh2') )   CALL iom_put( "ssh2", sshn(:,:) * sshn(:,:) )   ! square of sea surface height 
    156161       
    157162      CALL iom_put( "toce", tsn(:,:,:,jp_tem) )    ! 3D temperature 
    … …  
    243248      CALL iom_put( "avm" , avmu                       )    ! T vert. eddy visc. coef. 
    244249      CALL iom_put( "avs" , fsavs(:,:,:)               )    ! S vert. eddy diff. coef. (useful only with key_zdfddm) 
     250                                                            ! Log of eddy diff coef 
     251      IF( iom_use('logavt') )   CALL iom_put( "logavt", LOG( MAX( 1.e-20_wp, avt  (:,:,:) ) ) ) 
     252      IF( iom_use('logavs') )   CALL iom_put( "logavs", LOG( MAX( 1.e-20_wp, fsavs(:,:,:) ) ) ) 
    245253 
    246254      IF ( iom_use("sstgrad") .OR. iom_use("sstgrad2") ) THEN 
    … …  
    307315         CALL iom_put( "eken", rke )            
    308316      ENDIF 
    309           
     317      ! 
     318      CALL iom_put( "hdiv", hdivn )                  ! Horizontal divergence 
     319      ! 
    310320      IF( iom_use("u_masstr") .OR. iom_use("u_heattr") .OR. iom_use("u_salttr") ) THEN 
    311321         z3d(:,:,jpk) = 0.e0 
    … …  
    438448      zdt = rdt 
    439449      IF( nacc == 1 ) zdt = rdtmin 
    440       IF( ln_mskland )   THEN   ;   clop = "only(x)"   ! put 1.e+20 on land (very expensive!!) 
    441       ELSE                      ;   clop = "x"         ! no use of the mask value (require less cpu time) 
    442       ENDIF 
     450      clop = "x"         ! no use of the mask value (require less cpu time, and otherwise the model crashes) 
    443451#if defined key_diainstant 
    444452      zsto = nwrite * zdt 
    … …  
    10201028         CALL histdef( id_i, "vovvldep", "T point depth"         , "m"      ,   &   ! t-point depth 
    10211029            &          jpi, jpj, nh_i, jpk, 1, jpk, nz_i, 32, clop, zsto, zout ) 
     1030         CALL histdef( id_i, "vovvle3t", "T point thickness"         , "m"      ,   &   ! t-point depth 
     1031            &          jpi, jpj, nh_i, jpk, 1, jpk, nz_i, 32, clop, zsto, zout ) 
    10221032      END IF 
    10231033 
    … …  
    10501060      CALL histwrite( id_i, "sozotaux", kt, utau             , jpi*jpj    , idex )    ! i-wind stress 
    10511061      CALL histwrite( id_i, "sometauy", kt, vtau             , jpi*jpj    , idex )    ! j-wind stress 
     1062      IF( lk_vvl ) THEN 
     1063         CALL histwrite( id_i, "vovvldep", kt, fsdept_n(:,:,:), jpi*jpj*jpk, idex )!  T-cell depth        
     1064         CALL histwrite( id_i, "vovvle3t", kt, fse3t_n (:,:,:), jpi*jpj*jpk, idex )!  T-cell thickness   
     1065      END IF 
    10521066 
    10531067      ! 3. Close the file 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/DOM/daymod.F90

    r6836 r6839  
    7373      !!---------------------------------------------------------------------- 
    7474      ! 
     75      ! max number of seconds between each restart 
     76      IF( REAL( nitend - nit000 + 1 ) * rdt > REAL( HUGE( nsec1jan000 ) ) ) THEN 
     77         CALL ctl_stop( 'The number of seconds between each restart exceeds the integer 4 max value: 2^31-1. ',   & 
     78            &           'You must do a restart at higher frequency (or remove this stop and recompile the code in I8)' ) 
     79      ENDIF 
    7580      ! all calendar staff is based on the fact that MOD( rday, rdttra(1) ) == 0 
    7681      IF( MOD( rday     , rdttra(1) ) /= 0. )   CALL ctl_stop( 'the time step must devide the number of second of in a day' ) 
    … …  
    238243               nday_year = 1 
    239244               nsec_year = ndt05 
    240                IF( nsec1jan000 >= 2 * (2**30 - nsecd * nyear_len(1) / 2 ) ) THEN   ! test integer 4 max value 
    241                   CALL ctl_stop( 'The number of seconds between Jan. 1st 00h of nit000 year and Jan. 1st 00h ',   & 
    242                      &           'of the current year is exceeding the INTEGER 4 max VALUE: 2^31-1 -> 68.09 years in seconds', & 
    243                      & 'You must do a restart at higher frequency (or remove this STOP and recompile everything in I8)' ) 
    244                ENDIF 
    245245               nsec1jan000 = nsec1jan000 + nsecd * nyear_len(1) 
    246246               IF( nleapy == 1 )   CALL day_mth 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/DOM/domhgr.F90

    r6836 r6839  
    169169            ! 
    170170            ii0 = 282           ;   ii1 = 283        ! Gibraltar Strait (e2u = 20 km) 
    171             ij0 = 201 + isrow   ;   ij1 = 241 - isrow   ;   e2u( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) =  20.e3 
     171            ij0 = 241 - isrow   ;   ij1 = 241 - isrow   ;   e2u( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) =  20.e3 
    172172            IF(lwp) WRITE(numout,*) 
    173173            IF(lwp) WRITE(numout,*) '             orca_r1: Gibraltar : e2u reduced to 20 km' 
    174174 
    175175            ii0 = 314           ;   ii1 = 315        ! Bhosporus Strait (e2u = 10 km) 
    176             ij0 = 208 + isrow   ;   ij1 = 248 - isrow   ;   e2u( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) =  10.e3 
     176            ij0 = 248 - isrow   ;   ij1 = 248 - isrow   ;   e2u( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) =  10.e3 
    177177            IF(lwp) WRITE(numout,*) 
    178178            IF(lwp) WRITE(numout,*) '             orca_r1: Bhosporus : e2u reduced to 10 km' 
    179179 
    180180            ii0 =  44           ;   ii1 =  44        ! Lombok Strait (e1v = 13 km) 
    181             ij0 = 124 + isrow   ;   ij1 = 165 - isrow   ;   e1v( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) =  13.e3 
     181            ij0 = 164 - isrow   ;   ij1 = 165 - isrow   ;   e1v( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) =  13.e3 
    182182            IF(lwp) WRITE(numout,*) 
    183183            IF(lwp) WRITE(numout,*) '             orca_r1: Lombok : e1v reduced to 10 km' 
    184184 
    185185            ii0 =  48           ;   ii1 =  48        ! Sumba Strait (e1v = 8 km) [closed from bathy_11 on] 
    186             ij0 = 124 + isrow   ;   ij1 = 165 - isrow   ;   e1v( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) =  8.e3 
     186            ij0 = 164 - isrow   ;   ij1 = 165 - isrow   ;   e1v( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) =  8.e3 
    187187            IF(lwp) WRITE(numout,*) 
    188188            IF(lwp) WRITE(numout,*) '             orca_r1: Sumba : e1v reduced to 8 km' 
    189189 
    190190            ii0 =  53           ;   ii1 =  53        ! Ombai Strait (e1v = 13 km) 
    191             ij0 = 124 + isrow   ;   ij1 = 165 - isrow   ;   e1v( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 13.e3 
     191            ij0 = 164 - isrow   ;   ij1 = 165 - isrow   ;   e1v( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 13.e3 
    192192            IF(lwp) WRITE(numout,*) 
    193193            IF(lwp) WRITE(numout,*) '             orca_r1: Ombai : e1v reduced to 13 km' 
    194194 
    195195            ii0 =  56           ;   ii1 =  56        ! Timor Passage (e1v = 20 km) 
    196             ij0 = 124 + isrow   ;   ij1 = 145 - isrow   ;   e1v( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 20.e3 
     196            ij0 = 164 - isrow   ;   ij1 = 145 - isrow   ;   e1v( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 20.e3 
    197197            IF(lwp) WRITE(numout,*) 
    198198            IF(lwp) WRITE(numout,*) '             orca_r1: Timor Passage : e1v reduced to 20 km' 
    199199 
    200200            ii0 =  55           ;   ii1 =  55        ! West Halmahera Strait (e1v = 30 km) 
    201             ij0 = 141 + isrow   ;   ij1 = 182 - isrow   ;   e1v( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 30.e3 
     201            ij0 = 181 - isrow   ;   ij1 = 182 - isrow   ;   e1v( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 30.e3 
    202202            IF(lwp) WRITE(numout,*) 
    203203            IF(lwp) WRITE(numout,*) '             orca_r1: W Halmahera : e1v reduced to 30 km' 
    204204 
    205205            ii0 =  58           ;   ii1 =  58        ! East Halmahera Strait (e1v = 50 km) 
    206             ij0 = 141 + isrow   ;   ij1 = 182 - isrow   ;   e1v( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 50.e3 
     206            ij0 = 181 - isrow   ;   ij1 = 182 - isrow   ;   e1v( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 50.e3 
    207207            IF(lwp) WRITE(numout,*) 
    208208            IF(lwp) WRITE(numout,*) '             orca_r1: E Halmahera : e1v reduced to 50 km' 
    … …  
    544544         IF ( cp_cfg == 'eel' .AND. jp_cfg == 6 ) THEN    ! for EEL6 configuration only 
    545545            IF( .NOT. Agrif_Root() ) THEN 
    546               zphi0 = ppgphi0 - FLOAT( Agrif_Parent(jpjglo)/2)*Agrif_Parent(ppe2_m) / (ra * rad) 
     546              zphi0 = ppgphi0 - FLOAT( Agrif_Parent(jpjglo)/2)*Agrif_Parent(ppe2_m)   &  
     547                    &           / (ra * rad) 
    547548            ENDIF 
    548549         ENDIF 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/DOM/dommsk.F90

    r6836 r6839  
    413413         IF(lwp) WRITE(numout,*) '      Gibraltar ' 
    414414         ii0 = 282           ;   ii1 = 283        ! Gibraltar Strait  
    415          ij0 = 201 + isrow   ;   ij1 = 241 - isrow   ;   fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp   
     415         ij0 = 241 - isrow   ;   ij1 = 241 - isrow   ;   fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp   
    416416 
    417417         IF(lwp) WRITE(numout,*) '      Bhosporus ' 
    418418         ii0 = 314           ;   ii1 = 315        ! Bhosporus Strait  
    419          ij0 = 208 + isrow   ;   ij1 = 248 - isrow   ;   fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp   
     419         ij0 = 248 - isrow   ;   ij1 = 248 - isrow   ;   fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp   
    420420 
    421421         IF(lwp) WRITE(numout,*) '      Makassar (Top) ' 
    422422         ii0 =  48           ;   ii1 =  48        ! Makassar Strait (Top)  
    423          ij0 = 149 + isrow   ;   ij1 = 190 - isrow   ;   fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 3._wp   
     423         ij0 = 189 - isrow   ;   ij1 = 190 - isrow   ;   fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 3._wp   
    424424 
    425425         IF(lwp) WRITE(numout,*) '      Lombok ' 
    426426         ii0 =  44           ;   ii1 =  44        ! Lombok Strait  
    427          ij0 = 124 + isrow   ;   ij1 = 165 - isrow   ;   fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp   
     427         ij0 = 164 - isrow   ;   ij1 = 165 - isrow   ;   fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp   
    428428 
    429429         IF(lwp) WRITE(numout,*) '      Ombai ' 
    430430         ii0 =  53           ;   ii1 =  53        ! Ombai Strait  
    431          ij0 = 124 + isrow   ;   ij1 = 165 - isrow   ;   fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp   
     431         ij0 = 164 - isrow   ;   ij1 = 165 - isrow   ;   fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp   
    432432 
    433433         IF(lwp) WRITE(numout,*) '      Timor Passage ' 
    434434         ii0 =  56           ;   ii1 =  56        ! Timor Passage  
    435          ij0 = 124 + isrow   ;   ij1 = 165 - isrow   ;   fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp   
     435         ij0 = 164 - isrow   ;   ij1 = 165 - isrow   ;   fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp   
    436436 
    437437         IF(lwp) WRITE(numout,*) '      West Halmahera ' 
    438438         ii0 =  58           ;   ii1 =  58        ! West Halmahera Strait  
    439          ij0 = 141 + isrow   ;   ij1 = 182 - isrow   ;   fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 3._wp   
     439         ij0 = 181 - isrow   ;   ij1 = 182 - isrow   ;   fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 3._wp   
    440440 
    441441         IF(lwp) WRITE(numout,*) '      East Halmahera ' 
    442442         ii0 =  55           ;   ii1 =  55        ! East Halmahera Strait  
    443          ij0 = 141 + isrow   ;   ij1 = 182 - isrow   ;   fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 3._wp   
     443         ij0 = 181 - isrow   ;   ij1 = 182 - isrow   ;   fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 3._wp   
    444444         ! 
    445445      ENDIF 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/DOM/domvvl.F90

    r6836 r6839  
    665665         ht(:,:) = ht(:,:) + fse3t_n(:,:,jk) * tmask(:,:,jk) 
    666666      END DO 
    667  
    668       ! Write outputs 
    669       ! ============= 
    670       CALL iom_put(     "e3t" , fse3t_n  (:,:,:) ) 
    671       CALL iom_put(     "e3u" , fse3u_n  (:,:,:) ) 
    672       CALL iom_put(     "e3v" , fse3v_n  (:,:,:) ) 
    673       CALL iom_put(     "e3w" , fse3w_n  (:,:,:) ) 
    674       CALL iom_put( "tpt_dep" , fsde3w_n (:,:,:) ) 
    675       IF( iom_use("e3tdef") )   & 
    676          CALL iom_put( "e3tdef"  , ( ( fse3t_n(:,:,:) - e3t_0(:,:,:) ) / e3t_0(:,:,:) * 100 * tmask(:,:,:) ) ** 2 ) 
    677667 
    678668      ! write restart file 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/DOM/domwri.F90

    r6836 r6839  
    215215         CALL iom_rstput( 0, 0, inum4, 'gdept_1d' , gdept_1d )  !    ! stretched system 
    216216         CALL iom_rstput( 0, 0, inum4, 'gdepw_1d' , gdepw_1d ) 
     217         CALL iom_rstput( 0, 0, inum4, 'gdept_0', gdept_0, ktype = jp_r4 )      
     218         CALL iom_rstput( 0, 0, inum4, 'gdepw_0', gdepw_0, ktype = jp_r4 )      
    217219      ENDIF 
    218220       

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/DOM/domzgr.F90

    r6836 r6839  
    219219         &  ppsur == pp_to_be_computed           ) THEN 
    220220         ! 
     221#if defined key_agrif 
     222         za1  = (  ppdzmin - pphmax / FLOAT(jpkdta-1)  )                                                   & 
     223            & / ( TANH((1-ppkth)/ppacr) - ppacr/FLOAT(jpkdta-1) * (  LOG( COSH( (jpkdta - ppkth) / ppacr) )& 
     224            &                                                      - LOG( COSH( ( 1  - ppkth) / ppacr) )  )  ) 
     225#else 
    221226         za1  = (  ppdzmin - pphmax / FLOAT(jpkm1)  )                                                      & 
    222227            & / ( TANH((1-ppkth)/ppacr) - ppacr/FLOAT(jpk-1) * (  LOG( COSH( (jpk - ppkth) / ppacr) )      & 
    223228            &                                                   - LOG( COSH( ( 1  - ppkth) / ppacr) )  )  ) 
     229#endif 
    224230         za0  = ppdzmin - za1 *              TANH( (1-ppkth) / ppacr ) 
    225231         zsur =   - za0 - za1 * ppacr * LOG( COSH( (1-ppkth) / ppacr )  ) 
    … …  
    236242              WRITE(numout,*) '            Uniform grid with ',jpk-1,' layers' 
    237243              WRITE(numout,*) '            Total depth    :', zhmax 
     244#if defined key_agrif 
     245              WRITE(numout,*) '            Layer thickness:', zhmax/(jpkdta-1) 
     246#else 
    238247              WRITE(numout,*) '            Layer thickness:', zhmax/(jpk-1) 
     248#endif 
    239249         ELSE 
    240250            IF( ppa1 == 0._wp .AND. ppa0 == 0._wp .AND. ppsur == 0._wp ) THEN 
    … …  
    260270      ! Reference z-coordinate (depth - scale factor at T- and W-points) 
    261271      ! ====================== 
    262       IF( ppkth == 0._wp ) THEN            !  uniform vertical grid        
     272      IF( ppkth == 0._wp ) THEN            !  uniform vertical grid  
     273#if defined key_agrif 
     274         za1 = zhmax / FLOAT(jpkdta-1)  
     275#else 
    263276         za1 = zhmax / FLOAT(jpk-1)  
     277#endif 
    264278         DO jk = 1, jpk 
    265279            zw = FLOAT( jk ) 
    … …  
    18701884             iim1 = MAX( ji-1, 1 ) 
    18711885             ijm1 = MAX( jj-1, 1 ) 
    1872              IF( (bathy(iip1,jj) + bathy(iim1,jj) + bathy(ji,ijp1) + bathy(ji,ijm1) +              & 
    1873         &         bathy(iip1,ijp1) + bathy(iim1,ijm1) + bathy(iip1,ijp1) + bathy(iim1,ijm1)) > 0._wp ) THEN 
    1874                zenv(ji,jj) = rn_sbot_min 
     1886             IF( ( + bathy(iim1,ijp1) + bathy(ji,ijp1) + bathy(iip1,ijp1)  & 
     1887                &  + bathy(iim1,jj  )                  + bathy(iip1,jj  )  & 
     1888                &  + bathy(iim1,ijm1) + bathy(ji,ijm1) + bathy(iip1,ijp1)  ) > 0._wp ) THEN 
     1889                zenv(ji,jj) = rn_sbot_min 
    18751890             ENDIF 
    18761891           ENDIF 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/DYN/divcur.F90

    r6836 r6839  
    9797      IF( nn_timing == 1 )  CALL timing_start('div_cur') 
    9898      ! 
    99       CALL wrk_alloc( jpi  , jpj+2, zwu               ) 
    100       CALL wrk_alloc( jpi+4, jpj  , zwv, kistart = -1 ) 
     99      CALL wrk_alloc( jpi  , jpj+2, zwu  ) 
     100      CALL wrk_alloc( jpi+2, jpj  , zwv ) 
    101101      ! 
    102102      IF( kt == nit000 ) THEN 
    … …  
    236236      CALL lbc_lnk( hdivn, 'T', 1. )   ;   CALL lbc_lnk( rotn , 'F', 1. )    ! lateral boundary cond. (no sign change) 
    237237      ! 
    238       CALL wrk_dealloc( jpi  , jpj+2, zwu               ) 
    239       CALL wrk_dealloc( jpi+4, jpj  , zwv, kistart = -1 ) 
     238      CALL wrk_dealloc( jpi  , jpj+2, zwu ) 
     239      CALL wrk_dealloc( jpi+2, jpj  , zwv ) 
    240240      ! 
    241241      IF( nn_timing == 1 )  CALL timing_stop('div_cur') 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/DYN/dynnxt.F90

    r6836 r6839  
    266266               ! Add volume filter correction: compatibility with tracer advection scheme 
    267267               ! => time filter + conservation correction (only at the first level) 
    268                fse3t_b(:,:,1) = fse3t_b(:,:,1) - atfp * rdt * r1_rau0 * ( emp_b(:,:) - emp(:,:) & 
    269                               &                                          -rnf_b(:,:) + rnf(:,:) ) * tmask(:,:,1) 
     268               IF ( nn_isf == 0) THEN   ! if no ice shelf melting 
     269                  fse3t_b(:,:,1) = fse3t_b(:,:,1) - atfp * rdt * r1_rau0 * ( emp_b(:,:) - emp(:,:) & 
     270                                 &                                          -rnf_b(:,:) + rnf(:,:) ) * tmask(:,:,1) 
     271               ELSE                     ! if ice shelf melting 
     272                  DO jj = 1,jpj 
     273                     DO ji = 1,jpi 
     274                        jk = mikt(ji,jj) 
     275                        fse3t_b(ji,jj,jk) = fse3t_b(ji,jj,jk) - atfp * rdt * r1_rau0                       & 
     276                                          &                          * ( (emp_b(ji,jj)    - emp(ji,jj)   ) & 
     277                                          &                            - (rnf_b(ji,jj)    - rnf(ji,jj)   ) & 
     278                                          &                            + (fwfisf_b(ji,jj) - fwfisf(ji,jj)) ) * tmask(ji,jj,jk) 
     279                     END DO 
     280                  END DO 
     281               END IF 
    270282            ENDIF 
    271283            ! 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/DYN/dynspg_ts.F90

    r6836 r6839  
    187187      ! 
    188188                                                       ! time offset in steps for bdy data update 
    189       IF (.NOT.ln_bt_fw) THEN ; noffset=-2*nn_baro ; ELSE ;  noffset = 0 ; ENDIF 
     189      IF (.NOT.ln_bt_fw) THEN ; noffset=-nn_baro ; ELSE ;  noffset = 0 ; ENDIF 
    190190      ! 
    191191      IF( kt == nit000 ) THEN                !* initialisation 
    … …  
    454454      !                                         ! Surface net water flux and rivers 
    455455      IF (ln_bt_fw) THEN 
    456          zssh_frc(:,:) = zraur * ( emp(:,:) - rnf(:,:) + rdivisf * fwfisf(:,:) ) 
     456         zssh_frc(:,:) = zraur * ( emp(:,:) - rnf(:,:) + fwfisf(:,:) ) 
    457457      ELSE 
    458458         zssh_frc(:,:) = zraur * z1_2 * (  emp(:,:) + emp_b(:,:) - rnf(:,:) - rnf_b(:,:)   & 
    459                 &                        + rdivisf * ( fwfisf(:,:) + fwfisf_b(:,:) )       ) 
     459                &                        + fwfisf(:,:) + fwfisf_b(:,:)                     ) 
    460460      ENDIF 
    461461#if defined key_asminc 
    … …  
    465465      ENDIF 
    466466#endif 
    467       !                                   !* Fill boundary data arrays with AGRIF 
    468       !                                   ! ------------------------------------- 
     467      !                                   !* Fill boundary data arrays for AGRIF 
     468      !                                   ! ------------------------------------ 
    469469#if defined key_agrif 
    470470         IF( .NOT.Agrif_Root() ) CALL agrif_dta_ts( kt ) 
    … …  
    523523         ! Update only tidal forcing at open boundaries 
    524524#if defined key_tide 
    525          IF ( lk_bdy .AND. lk_tide )      CALL bdy_dta_tides( kt, kit=jn, time_offset=(noffset+1) ) 
    526          IF ( ln_tide_pot .AND. lk_tide ) CALL upd_tide( kt, kit=jn, koffset=noffset ) 
     525         IF ( lk_bdy .AND. lk_tide ) CALL bdy_dta_tides( kt, kit=jn, time_offset=(noffset+1) ) 
     526         IF ( ln_tide_pot .AND. lk_tide ) CALL upd_tide( kt, kit=jn, time_offset=noffset ) 
    527527#endif 
    528528         ! 
    … …  
    900900#if defined key_agrif 
    901901      ! Save time integrated fluxes during child grid integration 
    902       ! (used to update coarse grid transports) 
    903       ! Useless with 2nd order momentum schemes 
     902      ! (used to update coarse grid transports at next time step) 
    904903      ! 
    905904      IF ( (.NOT.Agrif_Root()).AND.(ln_bt_fw) ) THEN 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/DYN/sshwzv.F90

    r6836 r6839  
    3131   USE bdydyn2d        ! bdy_ssh routine 
    3232#if defined key_agrif 
    33    USE agrif_opa_update 
    3433   USE agrif_opa_interp 
    3534#endif 
    … …  
    268267      ELSE                                         !** Leap-Frog time-stepping: Asselin filter + swap 
    269268         sshb(:,:) = sshn(:,:) + atfp * ( sshb(:,:) - 2 * sshn(:,:) + ssha(:,:) )     ! before <-- now filtered 
    270          IF( lk_vvl ) sshb(:,:) = sshb(:,:) - atfp * rdt / rau0 * ( emp_b(:,:) - emp(:,:) - rnf_b(:,:) + rnf(:,:) ) * ssmask(:,:) 
     269         IF( lk_vvl ) sshb(:,:) = sshb(:,:) - atfp * rdt / rau0 * ( emp_b(:,:)    - emp(:,:)    & 
     270                                &                                 - rnf_b(:,:)    + rnf(:,:)    & 
     271                                &                                 + fwfisf_b(:,:) - fwfisf(:,:) ) * ssmask(:,:) 
    271272         sshn(:,:) = ssha(:,:)                           ! now <-- after 
    272273      ENDIF 
    273       ! 
    274       ! Update velocity at AGRIF zoom boundaries 
    275 #if defined key_agrif 
    276       IF ( .NOT.Agrif_Root() ) CALL Agrif_Update_Dyn( kt ) 
    277 #endif 
    278274      ! 
    279275      IF(ln_ctl)   CALL prt_ctl( tab2d_1=sshb, clinfo1=' sshb  - : ', mask1=tmask, ovlap=1 ) 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/IOM/iom.F90

    r6836 r6839  
    9494      CHARACTER(len=*), INTENT(in)  :: cdname 
    9595#if defined key_iomput 
    96       TYPE(xios_time)   :: dtime    = xios_time(0, 0, 0, 0, 0, 0) 
    97       CHARACTER(len=19) :: cldate  
    98       CHARACTER(len=10) :: clname 
    99       INTEGER           ::   ji 
     96#if ! defined key_xios2 
     97      TYPE(xios_time)     :: dtime    = xios_time(0, 0, 0, 0, 0, 0) 
     98      CHARACTER(len=19)   :: cldate  
     99#else 
     100      TYPE(xios_duration) :: dtime    = xios_duration(0, 0, 0, 0, 0, 0) 
     101      TYPE(xios_date)     :: start_date 
     102#endif 
     103      CHARACTER(len=10)   :: clname 
     104      INTEGER             :: ji 
    100105      ! 
    101106      REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: z_bnds 
    102107      !!---------------------------------------------------------------------- 
    103  
     108#if ! defined key_xios2 
    104109      ALLOCATE( z_bnds(jpk,2) ) 
     110#else 
     111      ALLOCATE( z_bnds(2,jpk) ) 
     112#endif 
    105113 
    106114      clname = cdname 
    … …  
    110118 
    111119      ! calendar parameters 
     120#if ! defined key_xios2 
    112121      SELECT CASE ( nleapy )        ! Choose calendar for IOIPSL 
    113122      CASE ( 1)   ;   CALL xios_set_context_attr(TRIM(clname), calendar_type= "Gregorian") 
    … …  
    117126      WRITE(cldate,"(i4.4,'-',i2.2,'-',i2.2,' 00:00:00')") nyear,nmonth,nday  
    118127      CALL xios_set_context_attr(TRIM(clname), start_date=cldate ) 
    119  
     128#else 
     129      ! Calendar type is now defined in xml file  
     130      SELECT CASE ( nleapy )        ! Choose calendar for IOIPSL 
     131      CASE ( 1)   ; CALL xios_define_calendar( TYPE = "Gregorian", time_origin = xios_date(1900,01,01,00,00,00), & 
     132          &                                    start_date = xios_date(nyear,nmonth,nday,0,0,0) ) 
     133      CASE ( 0)   ; CALL xios_define_calendar( TYPE = "NoLeap"   , time_origin = xios_date(1900,01,01,00,00,00), & 
     134          &                                    start_date = xios_date(nyear,nmonth,nday,0,0,0) ) 
     135      CASE (30)   ; CALL xios_define_calendar( TYPE = "D360"     , time_origin = xios_date(1900,01,01,00,00,00), & 
     136          &                                    start_date = xios_date(nyear,nmonth,nday,0,0,0) ) 
     137      END SELECT 
     138#endif 
    120139      ! horizontal grid definition 
     140 
    121141      CALL set_scalar 
    122142 
    … …  
    170190 
    171191      ! Add vertical grid bounds 
     192#if ! defined key_xios2 
    172193      z_bnds(:      ,1) = gdepw_1d(:) 
    173194      z_bnds(1:jpkm1,2) = gdepw_1d(2:jpk) 
    174195      z_bnds(jpk:   ,2) = gdepw_1d(jpk) + e3t_1d(jpk) 
     196#else 
     197      z_bnds(1      ,:) = gdepw_1d(:) 
     198      z_bnds(2,1:jpkm1) = gdepw_1d(2:jpk) 
     199      z_bnds(2,jpk:   ) = gdepw_1d(jpk) + e3t_1d(jpk) 
     200#endif 
     201 
    175202      CALL iom_set_axis_attr( "deptht", bounds=z_bnds ) 
    176203      CALL iom_set_axis_attr( "depthu", bounds=z_bnds ) 
    177204      CALL iom_set_axis_attr( "depthv", bounds=z_bnds ) 
    178       z_bnds(:    ,2) = gdept_1d(:) 
    179       z_bnds(2:jpk,1) = gdept_1d(1:jpkm1) 
    180       z_bnds(1    ,1) = gdept_1d(1) - e3w_1d(1) 
     205 
     206#if ! defined key_xios2 
     207      z_bnds(:    ,2)  = gdept_1d(:) 
     208      z_bnds(2:jpk,1)  = gdept_1d(1:jpkm1) 
     209      z_bnds(1    ,1)  = gdept_1d(1) - e3w_1d(1) 
     210#else 
     211      z_bnds(2,:    )  = gdept_1d(:) 
     212      z_bnds(1,2:jpk)  = gdept_1d(1:jpkm1) 
     213      z_bnds(1,1    )  = gdept_1d(1) - e3w_1d(1) 
     214#endif 
    181215      CALL iom_set_axis_attr( "depthw", bounds=z_bnds ) 
     216 
    182217 
    183218# if defined key_floats 
    … …  
    11561191      REAL(wp), DIMENSION(:)   , OPTIONAL, INTENT(in) ::   lonvalue, latvalue 
    11571192      REAL(wp), DIMENSION(:,:) , OPTIONAL, INTENT(in) ::   bounds_lon, bounds_lat, area 
    1158       LOGICAL,  DIMENSION(:,:) , OPTIONAL, INTENT(in) ::   mask 
    1159  
     1193#if ! defined key_xios2 
     1194     LOGICAL,  DIMENSION(:,:) , OPTIONAL, INTENT(in) ::   mask 
     1195#else 
     1196      LOGICAL,  DIMENSION(:) , OPTIONAL, INTENT(in) ::   mask 
     1197#endif 
     1198 
     1199#if ! defined key_xios2 
    11601200      IF ( xios_is_valid_domain     (cdid) ) THEN 
    11611201         CALL xios_set_domain_attr     ( cdid, ni_glo=ni_glo, nj_glo=nj_glo, ibegin=ibegin, jbegin=jbegin, ni=ni, nj=nj,   & 
    … …  
    11641204            &    lonvalue=lonvalue, latvalue=latvalue, mask=mask, nvertex=nvertex, bounds_lon=bounds_lon,                  & 
    11651205            &    bounds_lat=bounds_lat, area=area ) 
    1166       ENDIF 
    1167  
     1206     ENDIF 
    11681207      IF ( xios_is_valid_domaingroup(cdid) ) THEN 
    11691208         CALL xios_set_domaingroup_attr( cdid, ni_glo=ni_glo, nj_glo=nj_glo, ibegin=ibegin, jbegin=jbegin, ni=ni, nj=nj,   & 
    … …  
    11731212            &    bounds_lat=bounds_lat, area=area ) 
    11741213      ENDIF 
     1214 
     1215#else 
     1216      IF ( xios_is_valid_domain     (cdid) ) THEN 
     1217         CALL xios_set_domain_attr     ( cdid, ni_glo=ni_glo, nj_glo=nj_glo, ibegin=ibegin, jbegin=jbegin, ni=ni, nj=nj,   & 
     1218            &    data_dim=data_dim, data_ibegin=data_ibegin, data_ni=data_ni, data_jbegin=data_jbegin, data_nj=data_nj ,   & 
     1219            &    lonvalue_1D=lonvalue, latvalue_1D=latvalue, mask_1D=mask, nvertex=nvertex, bounds_lon_1D=bounds_lon,                  & 
     1220            &    bounds_lat_1D=bounds_lat, area=area, type='curvilinear') 
     1221     ENDIF 
     1222      IF ( xios_is_valid_domaingroup(cdid) ) THEN 
     1223         CALL xios_set_domaingroup_attr( cdid, ni_glo=ni_glo, nj_glo=nj_glo, ibegin=ibegin, jbegin=jbegin, ni=ni, nj=nj,   & 
     1224            &    data_dim=data_dim, data_ibegin=data_ibegin, data_ni=data_ni, data_jbegin=data_jbegin, data_nj=data_nj ,   & 
     1225            &    lonvalue_1D=lonvalue, latvalue_1D=latvalue, mask_1D=mask, nvertex=nvertex, bounds_lon_1D=bounds_lon,                  & 
     1226            &    bounds_lat_1D=bounds_lat, area=area, type='curvilinear' ) 
     1227      ENDIF 
     1228#endif 
    11751229      CALL xios_solve_inheritance() 
    11761230 
    11771231   END SUBROUTINE iom_set_domain_attr 
     1232 
     1233#if defined key_xios2 
     1234  SUBROUTINE iom_set_zoom_domain_attr( cdid, ibegin, jbegin, ni, nj) 
     1235     CHARACTER(LEN=*)                   , INTENT(in) ::   cdid 
     1236     INTEGER                  , OPTIONAL, INTENT(in) ::   ibegin, jbegin, ni, nj 
     1237 
     1238     IF ( xios_is_valid_zoom_domain     (cdid) ) THEN 
     1239         CALL xios_set_zoom_domain_attr     ( cdid, ibegin=ibegin, jbegin=jbegin, ni=ni,    & 
     1240           &   nj=nj) 
     1241    ENDIF 
     1242  END SUBROUTINE iom_set_zoom_domain_attr 
     1243#endif 
    11781244 
    11791245 
    … …  
    11831249      REAL(wp), DIMENSION(:,:), OPTIONAL, INTENT(in) ::   bounds 
    11841250      IF ( PRESENT(paxis) ) THEN 
     1251#if ! defined key_xios2 
    11851252         IF ( xios_is_valid_axis     (cdid) )   CALL xios_set_axis_attr     ( cdid, size=SIZE(paxis), value=paxis ) 
    11861253         IF ( xios_is_valid_axisgroup(cdid) )   CALL xios_set_axisgroup_attr( cdid, size=SIZE(paxis), value=paxis ) 
     1254#else 
     1255         IF ( xios_is_valid_axis     (cdid) )   CALL xios_set_axis_attr     ( cdid, n_glo=SIZE(paxis), value=paxis ) 
     1256         IF ( xios_is_valid_axisgroup(cdid) )   CALL xios_set_axisgroup_attr( cdid, n_glo=SIZE(paxis), value=paxis ) 
     1257#endif 
    11871258      ENDIF 
    11881259      IF ( xios_is_valid_axis     (cdid) )   CALL xios_set_axis_attr     ( cdid, bounds=bounds ) 
    … …  
    11911262   END SUBROUTINE iom_set_axis_attr 
    11921263 
    1193  
    11941264   SUBROUTINE iom_set_field_attr( cdid, freq_op, freq_offset ) 
    11951265      CHARACTER(LEN=*)          , INTENT(in) ::   cdid 
    1196       CHARACTER(LEN=*),OPTIONAL , INTENT(in) ::   freq_op 
    1197       CHARACTER(LEN=*),OPTIONAL , INTENT(in) ::   freq_offset 
    1198       IF ( xios_is_valid_field     (cdid) )   CALL xios_set_field_attr     ( cdid, freq_op=freq_op, freq_offset=freq_offset ) 
    1199       IF ( xios_is_valid_fieldgroup(cdid) )   CALL xios_set_fieldgroup_attr( cdid, freq_op=freq_op, freq_offset=freq_offset ) 
     1266#if ! defined key_xios2 
     1267      CHARACTER(LEN=*)   ,OPTIONAL , INTENT(in) ::   freq_op 
     1268      CHARACTER(LEN=*)   ,OPTIONAL , INTENT(in) ::   freq_offset 
     1269#else 
     1270      TYPE(xios_duration),OPTIONAL , INTENT(in) ::   freq_op 
     1271      TYPE(xios_duration),OPTIONAL , INTENT(in) ::   freq_offset 
     1272#endif 
     1273      IF ( xios_is_valid_field     (cdid) )   CALL xios_set_field_attr       & 
     1274    &     ( cdid, freq_op=freq_op, freq_offset=freq_offset ) 
     1275      IF ( xios_is_valid_fieldgroup(cdid) )   CALL xios_set_fieldgroup_attr  & 
     1276    &                    ( cdid, freq_op=freq_op, freq_offset=freq_offset ) 
    12001277      CALL xios_solve_inheritance() 
    12011278   END SUBROUTINE iom_set_field_attr 
    1202  
    12031279 
    12041280   SUBROUTINE iom_set_file_attr( cdid, name, name_suffix ) 
    … …  
    12131289   SUBROUTINE iom_get_file_attr( cdid, name, name_suffix, output_freq ) 
    12141290      CHARACTER(LEN=*)          , INTENT(in ) ::   cdid 
    1215       CHARACTER(LEN=*),OPTIONAL , INTENT(out) ::   name, name_suffix, output_freq 
     1291      CHARACTER(LEN=*),OPTIONAL , INTENT(out) ::   name, name_suffix 
     1292#if ! defined key_xios2 
     1293      CHARACTER(LEN=*),OPTIONAL , INTENT(out) ::    output_freq 
     1294#else 
     1295      TYPE(xios_duration)   ,OPTIONAL , INTENT(out) :: output_freq 
     1296#endif   
    12161297      LOGICAL                                 ::   llexist1,llexist2,llexist3 
    12171298      !--------------------------------------------------------------------- 
    12181299      IF( PRESENT( name        ) )   name = ''          ! default values 
    12191300      IF( PRESENT( name_suffix ) )   name_suffix = '' 
     1301#if ! defined key_xios2 
    12201302      IF( PRESENT( output_freq ) )   output_freq = '' 
     1303#else 
     1304      IF( PRESENT( output_freq ) )   output_freq = xios_duration(0,0,0,0,0,0) 
     1305#endif 
    12211306      IF ( xios_is_valid_file     (cdid) ) THEN 
    12221307         CALL xios_solve_inheritance() 
    … …  
    12391324      CHARACTER(LEN=*)                   , INTENT(in) ::   cdid 
    12401325      LOGICAL, DIMENSION(:,:,:), OPTIONAL, INTENT(in) ::   mask 
     1326#if ! defined key_xios2 
    12411327      IF ( xios_is_valid_grid     (cdid) )   CALL xios_set_grid_attr     ( cdid, mask=mask ) 
    12421328      IF ( xios_is_valid_gridgroup(cdid) )   CALL xios_set_gridgroup_attr( cdid, mask=mask ) 
     1329#else 
     1330      IF ( xios_is_valid_grid     (cdid) )   CALL xios_set_grid_attr     ( cdid, mask_3D=mask ) 
     1331      IF ( xios_is_valid_gridgroup(cdid) )   CALL xios_set_gridgroup_attr( cdid, mask_3D=mask ) 
     1332#endif 
    12431333      CALL xios_solve_inheritance() 
    12441334   END SUBROUTINE iom_set_grid_attr 
    … …  
    12821372      ni=nlei-nldi+1 ; nj=nlej-nldj+1 
    12831373 
    1284       CALL iom_set_domain_attr("grid_"//cdgrd, ni_glo=jpiglo, nj_glo=jpjglo, ibegin=nimpp+nldi-1, jbegin=njmpp+nldj-1, ni=ni, nj=nj) 
     1374#if ! defined key_xios2 
     1375     CALL iom_set_domain_attr("grid_"//cdgrd, ni_glo=jpiglo, nj_glo=jpjglo, ibegin=nimpp+nldi-1, jbegin=njmpp+nldj-1, ni=ni, nj=nj) 
     1376#else 
     1377     CALL iom_set_domain_attr("grid_"//cdgrd, ni_glo=jpiglo, nj_glo=jpjglo, ibegin=nimpp+nldi-2, jbegin=njmpp+nldj-2, ni=ni, nj=nj) 
     1378#endif      
    12851379      CALL iom_set_domain_attr("grid_"//cdgrd, data_dim=2, data_ibegin = 1-nldi, data_ni = jpi, data_jbegin = 1-nldj, data_nj = jpj) 
    12861380      CALL iom_set_domain_attr("grid_"//cdgrd, lonvalue = RESHAPE(plon(nldi:nlei, nldj:nlej),(/ ni*nj /)),   & 
    … …  
    12961390         END SELECT 
    12971391         ! 
     1392#if ! defined key_xios2 
    12981393         CALL iom_set_domain_attr( "grid_"//cdgrd       , mask = RESHAPE(zmask(nldi:nlei,nldj:nlej,1),(/ni,nj    /)) /= 0. ) 
     1394#else 
     1395         CALL iom_set_domain_attr( "grid_"//cdgrd       , mask = RESHAPE(zmask(nldi:nlei,nldj:nlej,1),(/ni*nj    /)) /= 0. ) 
     1396#endif   
    12991397         CALL iom_set_grid_attr  ( "grid_"//cdgrd//"_3D", mask = RESHAPE(zmask(nldi:nlei,nldj:nlej,:),(/ni,nj,jpk/)) /= 0. ) 
    13001398      ENDIF 
    … …  
    14301528      ALLOCATE( zlon(ni*nj) )       ;       zlon(:) = 0. 
    14311529 
     1530      CALL dom_ngb( 180., 90., ix, iy, 'T' ) !  i-line that passes near the North Pole : Reference latitude (used in plots) 
     1531#if ! defined key_xios2 
    14321532      CALL iom_set_domain_attr("gznl", ni_glo=jpiglo, nj_glo=jpjglo, ibegin=nimpp+nldi-1, jbegin=njmpp+nldj-1, ni=ni, nj=nj) 
    14331533      CALL iom_set_domain_attr("gznl", data_dim=2, data_ibegin = 1-nldi, data_ni = jpi, data_jbegin = 1-nldj, data_nj = jpj) 
    … …  
    14351535         &                             latvalue = RESHAPE(plat(nldi:nlei, nldj:nlej),(/ ni*nj /)))   
    14361536      ! 
    1437       CALL dom_ngb( 180., 90., ix, iy, 'T' ) !  i-line that passes near the North Pole : Reference latitude (used in plots) 
    14381537      CALL iom_set_domain_attr ('ptr', zoom_ibegin=ix, zoom_nj=jpjglo) 
     1538#else 
     1539! Pas teste : attention aux indices ! 
     1540      CALL iom_set_domain_attr("gznl", ni_glo=jpiglo, nj_glo=jpjglo, ibegin=nimpp+nldi-2, jbegin=njmpp+nldj-2, ni=ni, nj=nj) 
     1541      CALL iom_set_domain_attr("gznl", data_dim=2, data_ibegin = 1-nldi, data_ni = jpi, data_jbegin = 1-nldj, data_nj = jpj) 
     1542      CALL iom_set_domain_attr("gznl", lonvalue = zlon,   & 
     1543         &                             latvalue = RESHAPE(plat(nldi:nlei, nldj:nlej),(/ ni*nj /)))   
     1544       CALL iom_set_zoom_domain_attr ("ptr", ibegin=ix-1, jbegin=0, ni=1, nj=jpjglo) 
     1545#endif 
     1546 
    14391547      CALL iom_update_file_name('ptr') 
    14401548      ! 
    … …  
    14501558      REAL(wp), DIMENSION(1)   ::   zz = 1. 
    14511559      !!---------------------------------------------------------------------- 
     1560#if ! defined key_xios2 
    14521561      CALL iom_set_domain_attr('scalarpoint', ni_glo=jpnij, nj_glo=1, ibegin=narea, jbegin=1, ni=1, nj=1) 
     1562#else 
     1563      CALL iom_set_domain_attr('scalarpoint', ni_glo=jpnij, nj_glo=1, ibegin=narea-1, jbegin=0, ni=1, nj=1) 
     1564#endif 
    14531565      CALL iom_set_domain_attr('scalarpoint', data_dim=2, data_ibegin = 1, data_ni = 1, data_jbegin = 1, data_nj = 1) 
    14541566       
    14551567      zz=REAL(narea,wp) 
    14561568      CALL iom_set_domain_attr('scalarpoint', lonvalue=zz, latvalue=zz) 
    1457  
     1569       
    14581570   END SUBROUTINE set_scalar 
    14591571 
    … …  
    14791591      REAL(wp)        ,DIMENSION( 3) ::   zlonpira                 ! longitudes of pirata moorings 
    14801592      REAL(wp)        ,DIMENSION( 9) ::   zlatpira                 ! latitudes  of pirata moorings 
     1593#if  defined key_xios2 
     1594      TYPE(xios_duration)            ::   f_op, f_of 
     1595#endif 
     1596  
    14811597      !!---------------------------------------------------------------------- 
    14821598      !  
    14831599      ! frequency of the call of iom_put (attribut: freq_op) 
    1484       WRITE(cl1,'(i1)')        1   ;   CALL iom_set_field_attr('field_definition', freq_op = cl1//'ts', freq_offset='0ts') 
    1485       WRITE(cl1,'(i1)')  nn_fsbc   ;   CALL iom_set_field_attr('SBC'             , freq_op = cl1//'ts', freq_offset='0ts') 
    1486       WRITE(cl1,'(i1)')  nn_fsbc   ;   CALL iom_set_field_attr('SBC_scalar'      , freq_op = cl1//'ts', freq_offset='0ts') 
    1487       WRITE(cl1,'(i1)') nn_dttrc   ;   CALL iom_set_field_attr('ptrc_T'          , freq_op = cl1//'ts', freq_offset='0ts') 
    1488       WRITE(cl1,'(i1)') nn_dttrc   ;   CALL iom_set_field_attr('diad_T'          , freq_op = cl1//'ts', freq_offset='0ts') 
     1600#if ! defined key_xios2 
     1601      WRITE(cl1,'(i1)')        1   ;   CALL iom_set_field_attr('field_definition', freq_op=cl1//'ts', freq_offset='0ts') 
     1602      WRITE(cl1,'(i1)')  nn_fsbc   ;   CALL iom_set_field_attr('SBC'             , freq_op=cl1//'ts', freq_offset='0ts') 
     1603      WRITE(cl1,'(i1)')  nn_fsbc   ;   CALL iom_set_field_attr('SBC_scalar'      , freq_op=cl1//'ts', freq_offset='0ts') 
     1604      WRITE(cl1,'(i1)') nn_dttrc   ;   CALL iom_set_field_attr('ptrc_T'          , freq_op=cl1//'ts', freq_offset='0ts') 
     1605      WRITE(cl1,'(i1)') nn_dttrc   ;   CALL iom_set_field_attr('diad_T'          , freq_op=cl1//'ts', freq_offset='0ts') 
     1606#else 
     1607      f_op%timestep = 1        ;  f_of%timestep = 0  ; CALL iom_set_field_attr('field_definition', freq_op=f_op, freq_offset=f_of) 
     1608      f_op%timestep = nn_fsbc  ;  f_of%timestep = 0  ; CALL iom_set_field_attr('SBC'             , freq_op=f_op, freq_offset=f_of) 
     1609      f_op%timestep = nn_fsbc  ;  f_of%timestep = 0  ; CALL iom_set_field_attr('SBC_scalar'      , freq_op=f_op, freq_offset=f_of) 
     1610      f_op%timestep = nn_dttrc ;  f_of%timestep = 0  ; CALL iom_set_field_attr('ptrc_T'          , freq_op=f_op, freq_offset=f_of) 
     1611      f_op%timestep = nn_dttrc ;  f_of%timestep = 0  ; CALL iom_set_field_attr('diad_T'          , freq_op=f_op, freq_offset=f_of) 
     1612#endif 
    14891613        
    14901614      ! output file names (attribut: name) 
    … …  
    15081632         ! Equatorial section (attributs: jbegin, ni, name_suffix) 
    15091633         CALL dom_ngb( 0., 0., ix, iy, cl1 ) 
     1634#if ! defined key_xios2 
    15101635         CALL iom_set_domain_attr ('Eq'//cl1, zoom_jbegin=iy, zoom_ni=jpiglo) 
     1636#else 
     1637         CALL iom_set_zoom_domain_attr ('Eq'//cl1, jbegin=iy-1, ni=jpiglo) 
     1638#endif 
    15111639         CALL iom_get_file_attr   ('Eq'//cl1, name_suffix = clsuff             ) 
    15121640         CALL iom_set_file_attr   ('Eq'//cl1, name_suffix = TRIM(clsuff)//'_Eq') 
    … …  
    15881716               ENDIF 
    15891717               clname = TRIM(ADJUSTL(clat))//TRIM(ADJUSTL(clon)) 
     1718#if ! defined key_xios2 
    15901719               CALL iom_set_domain_attr (TRIM(clname)//cl1, zoom_ibegin= ix, zoom_jbegin= iy) 
     1720#else 
     1721               CALL iom_set_zoom_domain_attr  (TRIM(clname)//cl1, ibegin= ix-1, jbegin= iy-1) 
     1722#endif 
    15911723               CALL iom_get_file_attr   (TRIM(clname)//cl1, name_suffix = clsuff                         ) 
    15921724               CALL iom_set_file_attr   (TRIM(clname)//cl1, name_suffix = TRIM(clsuff)//'_'//TRIM(clname)) 
    … …  
    16171749      REAL(wp)           ::   zsec 
    16181750      LOGICAL            ::   llexist 
    1619       !!---------------------------------------------------------------------- 
     1751#if  defined key_xios2 
     1752      TYPE(xios_duration)   ::   output_freq  
     1753#endif       
     1754      !!---------------------------------------------------------------------- 
     1755 
    16201756 
    16211757      DO jn = 1,2 
    1622  
     1758#if ! defined key_xios2 
    16231759         IF( jn == 1 )   CALL iom_get_file_attr( cdid, name        = clname, output_freq = clfreq ) 
     1760#else 
     1761         output_freq = xios_duration(0,0,0,0,0,0) 
     1762         IF( jn == 1 )   CALL iom_get_file_attr( cdid, name        = clname, output_freq = output_freq ) 
     1763#endif 
    16241764         IF( jn == 2 )   CALL iom_get_file_attr( cdid, name_suffix = clname ) 
    16251765 
    … …  
    16321772            END DO 
    16331773 
     1774#if ! defined key_xios2 
    16341775            idx = INDEX(clname,'@freq@') + INDEX(clname,'@FREQ@') 
    16351776            DO WHILE ( idx /= 0 )  
    … …  
    16441785               idx = INDEX(clname,'@freq@') + INDEX(clname,'@FREQ@') 
    16451786            END DO 
    1646  
     1787#else 
     1788            idx = INDEX(clname,'@freq@') + INDEX(clname,'@FREQ@') 
     1789            DO WHILE ( idx /= 0 )  
     1790              IF ( output_freq%timestep /= 0) THEN 
     1791                  WRITE(clfreq,'(I18,A2)')INT(output_freq%timestep),'ts'  
     1792                  itrlen = LEN_TRIM(ADJUSTL(clfreq)) 
     1793              ELSE IF ( output_freq%hour /= 0 ) THEN 
     1794                  WRITE(clfreq,'(I19,A1)')INT(output_freq%hour),'h'  
     1795                  itrlen = LEN_TRIM(ADJUSTL(clfreq)) 
     1796              ELSE IF ( output_freq%day /= 0 ) THEN 
     1797                  WRITE(clfreq,'(I19,A1)')INT(output_freq%day),'d'  
     1798                  itrlen = LEN_TRIM(ADJUSTL(clfreq)) 
     1799              ELSE IF ( output_freq%month /= 0 ) THEN    
     1800                  WRITE(clfreq,'(I19,A1)')INT(output_freq%month),'m'  
     1801                  itrlen = LEN_TRIM(ADJUSTL(clfreq)) 
     1802              ELSE IF ( output_freq%year /= 0 ) THEN    
     1803                  WRITE(clfreq,'(I19,A1)')INT(output_freq%year),'y'  
     1804                  itrlen = LEN_TRIM(ADJUSTL(clfreq)) 
     1805              ELSE 
     1806                  CALL ctl_stop('error in the name of file id '//TRIM(cdid),   & 
     1807                     & ' attribute output_freq is undefined -> cannot replace @freq@ in '//TRIM(clname) ) 
     1808              ENDIF 
     1809              clname = clname(1:idx-1)//TRIM(ADJUSTL(clfreq))//clname(idx+6:LEN_TRIM(clname)) 
     1810              idx = INDEX(clname,'@freq@') + INDEX(clname,'@FREQ@') 
     1811            END DO 
     1812#endif 
    16471813            idx = INDEX(clname,'@startdate@') + INDEX(clname,'@STARTDATE@') 
    16481814            DO WHILE ( idx /= 0 )  
    … …  
    16731839            END DO 
    16741840 
     1841            IF( jn == 1 .AND. TRIM(Agrif_CFixed()) /= '0' )   clname = TRIM(Agrif_CFixed())//"_"//TRIM(clname) 
    16751842            IF( jn == 1 )   CALL iom_set_file_attr( cdid, name        = clname ) 
    16761843            IF( jn == 2 )   CALL iom_set_file_attr( cdid, name_suffix = clname ) 
    … …  
    17201887      ENDIF 
    17211888       
     1889!$AGRIF_DO_NOT_TREAT       
     1890! Should be fixed in the conv 
    17221891      IF( llfull ) THEN  
    17231892         clfmt = TRIM(clfmt)//",'_',i2.2,':',i2.2,':',i2.2" 
    … …  
    17301899         WRITE(iom_sdate, '('//TRIM(clfmt)//')') iyear, imonth, iday                          ! date of the end of run 
    17311900      ENDIF 
     1901!$AGRIF_END_DO_NOT_TREAT       
    17321902 
    17331903   END FUNCTION iom_sdate 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/LBC/lbclnk.F90

    r6836 r6839  
    1111   !!                            the BDY/OBC communications 
    1212   !!            3.4  ! 2012-12  (R. Bourdalle-Badie and G. Reffray)  add a C1D case   
     13   !!            3.6  ! 2015-06  (O. Tintó and M. Castrillo)  add lbc_lnk_multi   
    1314   !!---------------------------------------------------------------------- 
    1415#if defined key_mpp_mpi 
    … …  
    2425 
    2526   INTERFACE lbc_lnk_multi 
    26       MODULE PROCEDURE mpp_lnk_2d_9 
     27      MODULE PROCEDURE mpp_lnk_2d_9, mpp_lnk_2d_multiple 
    2728   END INTERFACE 
    2829 
    … …  
    8081   END INTERFACE 
    8182 
     83   INTERFACE lbc_lnk_multi 
     84      MODULE PROCEDURE lbc_lnk_2d_9, lbc_lnk_2d_multiple 
     85   END INTERFACE 
     86 
    8287   INTERFACE lbc_bdy_lnk 
    8388      MODULE PROCEDURE lbc_bdy_lnk_2d, lbc_bdy_lnk_3d 
    … …  
    8792      MODULE PROCEDURE lbc_lnk_2d_e 
    8893   END INTERFACE 
     94    
     95   TYPE arrayptr 
     96      REAL , DIMENSION (:,:),  POINTER :: pt2d 
     97   END TYPE arrayptr 
     98   PUBLIC   arrayptr 
    8999 
    90100   PUBLIC   lbc_lnk       ! ocean/ice  lateral boundary conditions 
    91101   PUBLIC   lbc_lnk_e  
     102   PUBLIC   lbc_lnk_multi ! modified ocean lateral boundary conditions 
    92103   PUBLIC   lbc_bdy_lnk   ! ocean lateral BDY boundary conditions 
    93104   PUBLIC   lbc_lnk_icb 
    … …  
    171182      ! 
    172183   END SUBROUTINE lbc_lnk_2d 
     184    
     185   SUBROUTINE lbc_lnk_2d_multiple( pt2d_array , type_array , psgn_array , num_fields ) 
     186      !! 
     187      INTEGER :: num_fields 
     188      TYPE( arrayptr ), DIMENSION(:) :: pt2d_array 
     189      CHARACTER(len=1), DIMENSION(:), INTENT(in   ) ::   type_array   ! define the nature of ptab array grid-points 
     190      !                                                               ! = T , U , V , F , W and I points 
     191      REAL(wp)        , DIMENSION(:), INTENT(in   ) ::   psgn_array   ! =-1 the sign change across the north fold boundary 
     192      !                                                               ! =  1. , the sign is kept 
     193      ! 
     194      INTEGER  ::   ii    !!MULTI SEND DUMMY LOOP INDICES 
     195      ! 
     196      DO ii = 1, num_fields 
     197        CALL lbc_lnk_2d( pt2d_array(ii)%pt2d, type_array(ii), psgn_array(ii) ) 
     198      END DO      
     199      ! 
     200   END SUBROUTINE lbc_lnk_2d_multiple 
     201 
     202   SUBROUTINE lbc_lnk_2d_9( pt2dA, cd_typeA, psgnA, pt2dB, cd_typeB, psgnB, pt2dC, cd_typeC, psgnC   & 
     203      &                   , pt2dD, cd_typeD, psgnD, pt2dE, cd_typeE, psgnE, pt2dF, cd_typeF, psgnF   & 
     204      &                   , pt2dG, cd_typeG, psgnG, pt2dH, cd_typeH, psgnH, pt2dI, cd_typeI, psgnI, cd_mpp, pval) 
     205      !!--------------------------------------------------------------------- 
     206      ! Second 2D array on which the boundary condition is applied 
     207      REAL(wp), DIMENSION(jpi,jpj), TARGET          , INTENT(inout) ::   pt2dA 
     208      REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) ::   pt2dB , pt2dC , pt2dD , pt2dE 
     209      REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) ::   pt2dF , pt2dG , pt2dH , pt2dI 
     210      ! define the nature of ptab array grid-points 
     211      CHARACTER(len=1)                              , INTENT(in   ) ::   cd_typeA 
     212      CHARACTER(len=1)                    , OPTIONAL, INTENT(in   ) ::   cd_typeB , cd_typeC , cd_typeD , cd_typeE 
     213      CHARACTER(len=1)                    , OPTIONAL, INTENT(in   ) ::   cd_typeF , cd_typeG , cd_typeH , cd_typeI 
     214      ! =-1 the sign change across the north fold boundary 
     215      REAL(wp)                                      , INTENT(in   ) ::   psgnA 
     216      REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   psgnB , psgnC , psgnD , psgnE 
     217      REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   psgnF , psgnG , psgnH , psgnI 
     218      CHARACTER(len=3)                    , OPTIONAL, INTENT(in   ) ::   cd_mpp   ! fill the overlap area only 
     219      REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   pval     ! background value (used at closed boundaries) 
     220      !! 
     221      !!--------------------------------------------------------------------- 
     222 
     223      !!The first array 
     224      CALL lbc_lnk( pt2dA, cd_typeA, psgnA )  
     225 
     226      !! Look if more arrays to process 
     227      IF(PRESENT (psgnB) )CALL lbc_lnk( pt2dA, cd_typeA, psgnA )  
     228      IF(PRESENT (psgnC) )CALL lbc_lnk( pt2dC, cd_typeC, psgnC )  
     229      IF(PRESENT (psgnD) )CALL lbc_lnk( pt2dD, cd_typeD, psgnD )  
     230      IF(PRESENT (psgnE) )CALL lbc_lnk( pt2dE, cd_typeE, psgnE )  
     231      IF(PRESENT (psgnF) )CALL lbc_lnk( pt2dF, cd_typeF, psgnF )  
     232      IF(PRESENT (psgnG) )CALL lbc_lnk( pt2dG, cd_typeG, psgnG )  
     233      IF(PRESENT (psgnH) )CALL lbc_lnk( pt2dH, cd_typeH, psgnH )  
     234      IF(PRESENT (psgnI) )CALL lbc_lnk( pt2dI, cd_typeI, psgnI )  
     235 
     236   END SUBROUTINE lbc_lnk_2d_9 
     237 
     238 
     239 
     240 
    173241 
    174242#else 
    … …  
    372440      !     
    373441   END SUBROUTINE lbc_lnk_2d 
     442    
     443   SUBROUTINE lbc_lnk_2d_multiple( pt2d_array , type_array , psgn_array , num_fields ) 
     444      !! 
     445      INTEGER :: num_fields 
     446      TYPE( arrayptr ), DIMENSION(:) :: pt2d_array 
     447      CHARACTER(len=1), DIMENSION(:), INTENT(in   ) ::   type_array   ! define the nature of ptab array grid-points 
     448      !                                                               ! = T , U , V , F , W and I points 
     449      REAL(wp)        , DIMENSION(:), INTENT(in   ) ::   psgn_array   ! =-1 the sign change across the north fold boundary 
     450      !                                                               ! =  1. , the sign is kept 
     451      ! 
     452      INTEGER  ::   ii    !!MULTI SEND DUMMY LOOP INDICES 
     453      ! 
     454      DO ii = 1, num_fields 
     455        CALL lbc_lnk_2d( pt2d_array(ii)%pt2d, type_array(ii), psgn_array(ii) ) 
     456      END DO      
     457      ! 
     458   END SUBROUTINE lbc_lnk_2d_multiple 
     459 
     460   SUBROUTINE lbc_lnk_2d_9( pt2dA, cd_typeA, psgnA, pt2dB, cd_typeB, psgnB, pt2dC, cd_typeC, psgnC   & 
     461      &                   , pt2dD, cd_typeD, psgnD, pt2dE, cd_typeE, psgnE, pt2dF, cd_typeF, psgnF   & 
     462      &                   , pt2dG, cd_typeG, psgnG, pt2dH, cd_typeH, psgnH, pt2dI, cd_typeI, psgnI, cd_mpp, pval) 
     463      !!--------------------------------------------------------------------- 
     464      ! Second 2D array on which the boundary condition is applied 
     465      REAL(wp), DIMENSION(jpi,jpj), TARGET          , INTENT(inout) ::   pt2dA 
     466      REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) ::   pt2dB , pt2dC , pt2dD , pt2dE 
     467      REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) ::   pt2dF , pt2dG , pt2dH , pt2dI 
     468      ! define the nature of ptab array grid-points 
     469      CHARACTER(len=1)                              , INTENT(in   ) ::   cd_typeA 
     470      CHARACTER(len=1)                    , OPTIONAL, INTENT(in   ) ::   cd_typeB , cd_typeC , cd_typeD , cd_typeE 
     471      CHARACTER(len=1)                    , OPTIONAL, INTENT(in   ) ::   cd_typeF , cd_typeG , cd_typeH , cd_typeI 
     472      ! =-1 the sign change across the north fold boundary 
     473      REAL(wp)                                      , INTENT(in   ) ::   psgnA 
     474      REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   psgnB , psgnC , psgnD , psgnE 
     475      REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   psgnF , psgnG , psgnH , psgnI 
     476      CHARACTER(len=3)                    , OPTIONAL, INTENT(in   ) ::   cd_mpp   ! fill the overlap area only 
     477      REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   pval     ! background value (used at closed boundaries) 
     478      !! 
     479      !!--------------------------------------------------------------------- 
     480 
     481      !!The first array 
     482      CALL lbc_lnk( pt2dA, cd_typeA, psgnA )  
     483 
     484      !! Look if more arrays to process 
     485      IF(PRESENT (psgnB) )CALL lbc_lnk( pt2dA, cd_typeA, psgnA )  
     486      IF(PRESENT (psgnC) )CALL lbc_lnk( pt2dC, cd_typeC, psgnC )  
     487      IF(PRESENT (psgnD) )CALL lbc_lnk( pt2dD, cd_typeD, psgnD )  
     488      IF(PRESENT (psgnE) )CALL lbc_lnk( pt2dE, cd_typeE, psgnE )  
     489      IF(PRESENT (psgnF) )CALL lbc_lnk( pt2dF, cd_typeF, psgnF )  
     490      IF(PRESENT (psgnG) )CALL lbc_lnk( pt2dG, cd_typeG, psgnG )  
     491      IF(PRESENT (psgnH) )CALL lbc_lnk( pt2dH, cd_typeH, psgnH )  
     492      IF(PRESENT (psgnI) )CALL lbc_lnk( pt2dI, cd_typeI, psgnI )  
     493 
     494   END SUBROUTINE lbc_lnk_2d_9 
     495 
    374496 
    375497#endif 
    … …  
    441563   !!====================================================================== 
    442564END MODULE lbclnk 
     565 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90

    r6836 r6839  
    2424   !!            3.5  !  2013  ( C. Ethe, G. Madec ) message passing arrays as local variables  
    2525   !!            3.5  !  2013 (S.Mocavero, I.Epicoco - CMCC) north fold optimizations 
     26   !!            3.6  !  2015 (O. Tintó and M. Castrillo - BSC) Added 'mpp_lnk_2d_multiple', 'mpp_lbc_north_2d_multiple', 'mpp_max_multiple'  
    2627   !!---------------------------------------------------------------------- 
    2728 
    … …  
    6263   USE lbcnfd         ! north fold treatment 
    6364   USE in_out_manager ! I/O manager 
     65   USE wrk_nemo       ! work arrays 
    6466 
    6567   IMPLICIT NONE 
    … …  
    7072   PUBLIC   mpp_ini_north, mpp_lbc_north, mpp_lbc_north_e 
    7173   PUBLIC   mpp_min, mpp_max, mpp_sum, mpp_minloc, mpp_maxloc 
     74   PUBLIC   mpp_max_multiple 
    7275   PUBLIC   mpp_lnk_3d, mpp_lnk_3d_gather, mpp_lnk_2d, mpp_lnk_2d_e 
    73    PUBLIC   mpp_lnk_2d_9  
     76   PUBLIC   mpp_lnk_2d_9 , mpp_lnk_2d_multiple  
    7477   PUBLIC   mppscatter, mppgather 
    7578   PUBLIC   mpp_ini_ice, mpp_ini_znl 
    … …  
    7881   PUBLIC   mpp_lnk_bdy_2d, mpp_lnk_bdy_3d 
    7982   PUBLIC   mpp_lbc_north_icb, mpp_lnk_2d_icb 
     83   PUBLIC   mpprank 
    8084 
    8185   TYPE arrayptr 
    8286      REAL , DIMENSION (:,:),  POINTER :: pt2d 
    8387   END TYPE arrayptr 
     88   PUBLIC   arrayptr 
    8489    
    8590   !! * Interfaces 
    … …  
    105110   INTERFACE mpp_maxloc 
    106111      MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d 
     112   END INTERFACE 
     113 
     114   INTERFACE mpp_max_multiple 
     115      MODULE PROCEDURE mppmax_real_multiple 
    107116   END INTERFACE 
    108117 
    … …  
    298307      ENDIF 
    299308 
     309#if defined key_agrif 
     310      IF (Agrif_Root()) THEN 
     311         CALL Agrif_MPI_Init(mpi_comm_opa) 
     312      ELSE 
     313         CALL Agrif_MPI_set_grid_comm(mpi_comm_opa) 
     314      ENDIF 
     315#endif 
     316 
    300317      CALL mpi_comm_rank( mpi_comm_opa, mpprank, ierr ) 
    301318      CALL mpi_comm_size( mpi_comm_opa, mppsize, ierr ) 
    … …  
    724741      ! ----------------------- 
    725742      ! 
    726       DO ii = 1 , num_fields 
    727743         !First Array 
    728          IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 
    729             ! 
    730             SELECT CASE ( jpni ) 
    731             CASE ( 1 )     ;   CALL lbc_nfd      ( pt2d_array(ii)%pt2d( : , : ), type_array(ii) , psgn_array(ii) )   ! only 1 northern proc, no mpp 
    732             CASE DEFAULT   ;   CALL mpp_lbc_north( pt2d_array(ii)%pt2d( : , : ), type_array(ii), psgn_array(ii) )   ! for all northern procs. 
    733             END SELECT 
    734             ! 
    735          ENDIF 
    736          ! 
    737       END DO 
     744      IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 
     745         ! 
     746         SELECT CASE ( jpni ) 
     747         CASE ( 1 )     ;    
     748             DO ii = 1 , num_fields   
     749                       CALL lbc_nfd      ( pt2d_array(ii)%pt2d( : , : ), type_array(ii) , psgn_array(ii) )   ! only 1 northern proc, no mpp 
     750             END DO 
     751         CASE DEFAULT   ;   CALL mpp_lbc_north_2d_multiple( pt2d_array, type_array, psgn_array, num_fields )   ! for all northern procs. 
     752         END SELECT 
     753         ! 
     754      ENDIF 
     755        ! 
    738756       
    739757      DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we ) 
    … …  
    16811699   END SUBROUTINE mppmax_real 
    16821700 
     1701   SUBROUTINE mppmax_real_multiple( ptab, NUM , kcom  ) 
     1702      !!---------------------------------------------------------------------- 
     1703      !!                  ***  routine mppmax_real  *** 
     1704      !! 
     1705      !! ** Purpose :   Maximum 
     1706      !! 
     1707      !!---------------------------------------------------------------------- 
     1708      REAL(wp), DIMENSION(:) ,  INTENT(inout)           ::   ptab   ! ??? 
     1709      INTEGER , INTENT(in   )           ::   NUM 
     1710      INTEGER , INTENT(in   ), OPTIONAL ::   kcom   ! ??? 
     1711      !! 
     1712      INTEGER  ::   ierror, localcomm 
     1713      REAL(wp) , POINTER , DIMENSION(:) ::   zwork 
     1714      !!---------------------------------------------------------------------- 
     1715      ! 
     1716      CALL wrk_alloc(NUM , zwork) 
     1717      localcomm = mpi_comm_opa 
     1718      IF( PRESENT(kcom) )   localcomm = kcom 
     1719      ! 
     1720      CALL mpi_allreduce( ptab, zwork, NUM, mpi_double_precision, mpi_max, localcomm, ierror ) 
     1721      ptab = zwork 
     1722      CALL wrk_dealloc(NUM , zwork) 
     1723      ! 
     1724   END SUBROUTINE mppmax_real_multiple 
     1725 
    16831726 
    16841727   SUBROUTINE mppmin_a_real( ptab, kdim, kcom ) 
    … …  
    25752618   END SUBROUTINE mpp_lbc_north_2d 
    25762619 
     2620   SUBROUTINE mpp_lbc_north_2d_multiple( pt2d_array, cd_type, psgn, num_fields) 
     2621      !!--------------------------------------------------------------------- 
     2622      !!                   ***  routine mpp_lbc_north_2d  *** 
     2623      !! 
     2624      !! ** Purpose :   Ensure proper north fold horizontal bondary condition 
     2625      !!              in mpp configuration in case of jpn1 > 1 
     2626      !!              (for multiple 2d arrays ) 
     2627      !! 
     2628      !! ** Method  :   North fold condition and mpp with more than one proc 
     2629      !!              in i-direction require a specific treatment. We gather 
     2630      !!              the 4 northern lines of the global domain on 1 processor 
     2631      !!              and apply lbc north-fold on this sub array. Then we 
     2632      !!              scatter the north fold array back to the processors. 
     2633      !! 
     2634      !!---------------------------------------------------------------------- 
     2635      INTEGER ,  INTENT (in   ) ::   num_fields  ! number of variables contained in pt2d 
     2636      TYPE( arrayptr ), DIMENSION(:) :: pt2d_array 
     2637      CHARACTER(len=1), DIMENSION(:), INTENT(in   ) ::   cd_type   ! nature of pt2d grid-points 
     2638      !                                                          !   = T ,  U , V , F or W  gridpoints 
     2639      REAL(wp), DIMENSION(:), INTENT(in   ) ::   psgn      ! = -1. the sign change across the north fold  
     2640      !!                                                             ! =  1. , the sign is kept 
     2641      INTEGER ::   ji, jj, jr, jk 
     2642      INTEGER ::   ierr, itaille, ildi, ilei, iilb 
     2643      INTEGER ::   ijpj, ijpjm1, ij, iproc 
     2644      INTEGER, DIMENSION (jpmaxngh)      ::   ml_req_nf          !for mpi_isend when avoiding mpi_allgather 
     2645      INTEGER                            ::   ml_err             ! for mpi_isend when avoiding mpi_allgather 
     2646      INTEGER, DIMENSION(MPI_STATUS_SIZE)::   ml_stat            ! for mpi_isend when avoiding mpi_allgather 
     2647      !                                                              ! Workspace for message transfers avoiding mpi_allgather 
     2648      REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: ztab 
     2649      REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: znorthloc, zfoldwk 
     2650      REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE   :: znorthgloio 
     2651      REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: ztabl, ztabr 
     2652      INTEGER :: istatus(mpi_status_size) 
     2653      INTEGER :: iflag 
     2654      !!---------------------------------------------------------------------- 
     2655      ! 
     2656      ALLOCATE( ztab(jpiglo,4,num_fields), znorthloc(jpi,4,num_fields), zfoldwk(jpi,4,num_fields), znorthgloio(jpi,4,num_fields,jpni) )   ! expanded to 3 dimensions 
     2657      ALLOCATE( ztabl(jpi,4,num_fields), ztabr(jpi*jpmaxngh, 4,num_fields) ) 
     2658      ! 
     2659      ijpj   = 4 
     2660      ijpjm1 = 3 
     2661      ! 
     2662       
     2663      DO jk = 1, num_fields 
     2664         DO jj = nlcj-ijpj+1, nlcj             ! put in znorthloc the last 4 jlines of pt2d (for every variable) 
     2665            ij = jj - nlcj + ijpj 
     2666            znorthloc(:,ij,jk) = pt2d_array(jk)%pt2d(:,jj) 
     2667         END DO 
     2668      END DO 
     2669      !                                     ! Build in procs of ncomm_north the znorthgloio 
     2670      itaille = jpi * ijpj 
     2671                                                                   
     2672      IF ( l_north_nogather ) THEN 
     2673         ! 
     2674         ! Avoid the use of mpi_allgather by exchanging only with the processes already identified  
     2675         ! (in nemo_northcomms) as being  involved in this process' northern boundary exchange 
     2676         ! 
     2677         ztabr(:,:,:) = 0 
     2678         ztabl(:,:,:) = 0 
     2679 
     2680         DO jk = 1, num_fields 
     2681            DO jj = nlcj-ijpj+1, nlcj          ! First put local values into the global array 
     2682               ij = jj - nlcj + ijpj 
     2683               DO ji = nfsloop, nfeloop 
     2684                  ztabl(ji,ij,jk) = pt2d_array(jk)%pt2d(ji,jj) 
     2685               END DO 
     2686            END DO 
     2687         END DO 
     2688 
     2689         DO jr = 1,nsndto 
     2690            IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN 
     2691               CALL mppsend(5, znorthloc, itaille*num_fields, nfipproc(isendto(jr),jpnj), ml_req_nf(jr)) ! Buffer expanded "num_fields" times 
     2692            ENDIF 
     2693         END DO 
     2694         DO jr = 1,nsndto 
     2695            iproc = nfipproc(isendto(jr),jpnj) 
     2696            IF(iproc .ne. -1) THEN 
     2697               ilei = nleit (iproc+1) 
     2698               ildi = nldit (iproc+1) 
     2699               iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj) 
     2700            ENDIF 
     2701            IF((iproc .ne. (narea-1)) .and. (iproc .ne. -1)) THEN 
     2702              CALL mpprecv(5, zfoldwk, itaille*num_fields, iproc) ! Buffer expanded "num_fields" times 
     2703              DO jk = 1 , num_fields 
     2704                 DO jj = 1, ijpj 
     2705                    DO ji = ildi, ilei 
     2706                       ztabr(iilb+ji,jj,jk) = zfoldwk(ji,jj,jk)       ! Modified to 3D 
     2707                    END DO 
     2708                 END DO 
     2709              END DO 
     2710            ELSE IF (iproc .eq. (narea-1)) THEN 
     2711              DO jk = 1, num_fields 
     2712                 DO jj = 1, ijpj 
     2713                    DO ji = ildi, ilei 
     2714                          ztabr(iilb+ji,jj,jk) = pt2d_array(jk)%pt2d(ji,nlcj-ijpj+jj)       ! Modified to 3D 
     2715                    END DO 
     2716                 END DO 
     2717              END DO 
     2718            ENDIF 
     2719         END DO 
     2720         IF (l_isend) THEN 
     2721            DO jr = 1,nsndto 
     2722               IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN 
     2723                  CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err) 
     2724               ENDIF 
     2725            END DO 
     2726         ENDIF 
     2727         ! 
     2728         DO ji = 1, num_fields     ! Loop to manage 3D variables 
     2729            CALL mpp_lbc_nfd( ztabl(:,:,ji), ztabr(:,:,ji), cd_type(ji), psgn(ji) )  ! North fold boundary condition 
     2730         END DO 
     2731         ! 
     2732         DO jk = 1, num_fields 
     2733            DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt2d 
     2734               ij = jj - nlcj + ijpj 
     2735               DO ji = 1, nlci 
     2736                  pt2d_array(jk)%pt2d(ji,jj) = ztabl(ji,ij,jk)       ! Modified to 3D 
     2737               END DO 
     2738            END DO 
     2739         END DO 
     2740          
     2741         ! 
     2742      ELSE 
     2743         ! 
     2744         CALL MPI_ALLGATHER( znorthloc  , itaille*num_fields, MPI_DOUBLE_PRECISION,        & 
     2745            &                znorthgloio, itaille*num_fields, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 
     2746         ! 
     2747         ztab(:,:,:) = 0.e0 
     2748         DO jk = 1, num_fields 
     2749            DO jr = 1, ndim_rank_north            ! recover the global north array 
     2750               iproc = nrank_north(jr) + 1 
     2751               ildi = nldit (iproc) 
     2752               ilei = nleit (iproc) 
     2753               iilb = nimppt(iproc) 
     2754               DO jj = 1, ijpj 
     2755                  DO ji = ildi, ilei 
     2756                     ztab(ji+iilb-1,jj,jk) = znorthgloio(ji,jj,jk,jr) 
     2757                  END DO 
     2758               END DO 
     2759            END DO 
     2760         END DO 
     2761          
     2762         DO ji = 1, num_fields 
     2763            CALL lbc_nfd( ztab(:,:,ji), cd_type(ji), psgn(ji) )   ! North fold boundary condition 
     2764         END DO 
     2765         ! 
     2766         DO jk = 1, num_fields 
     2767            DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt2d 
     2768               ij = jj - nlcj + ijpj 
     2769               DO ji = 1, nlci 
     2770                  pt2d_array(jk)%pt2d(ji,jj) = ztab(ji+nimpp-1,ij,jk) 
     2771               END DO 
     2772            END DO 
     2773         END DO 
     2774         ! 
     2775         ! 
     2776      ENDIF 
     2777      DEALLOCATE( ztab, znorthloc, zfoldwk, znorthgloio ) 
     2778      DEALLOCATE( ztabl, ztabr ) 
     2779      ! 
     2780   END SUBROUTINE mpp_lbc_north_2d_multiple 
    25772781 
    25782782   SUBROUTINE mpp_lbc_north_e( pt2d, cd_type, psgn) 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/LBC/mppini.F90

    r6836 r6839  
    201201       
    202202#endif 
    203       IF(lwp) THEN 
    204          WRITE(numout,*) 
    205          WRITE(numout,*) '           defines mpp subdomains' 
    206          WRITE(numout,*) '           ----------------------' 
    207          WRITE(numout,*) '           iresti=',iresti,' irestj=',irestj 
    208          WRITE(numout,*) '           jpni  =',jpni  ,' jpnj  =',jpnj 
    209          ifreq = 4 
    210          il1   = 1 
    211          DO jn = 1, (jpni-1)/ifreq+1 
    212             il2 = MIN( jpni, il1+ifreq-1 ) 
    213             WRITE(numout,*) 
    214             WRITE(numout,9200) ('***',ji = il1,il2-1) 
    215             DO jj = jpnj, 1, -1 
    216                WRITE(numout,9203) ('   ',ji = il1,il2-1) 
    217                WRITE(numout,9202) jj, ( ilcit(ji,jj),ilcjt(ji,jj),ji = il1,il2 ) 
    218                WRITE(numout,9203) ('   ',ji = il1,il2-1) 
    219                WRITE(numout,9200) ('***',ji = il1,il2-1) 
    220             END DO 
    221             WRITE(numout,9201) (ji,ji = il1,il2) 
    222             il1 = il1+ifreq 
    223          END DO 
    224  9200    FORMAT('     ***',20('*************',a3)) 
    225  9203    FORMAT('     *     ',20('         *   ',a3)) 
    226  9201    FORMAT('        ',20('   ',i3,'          ')) 
    227  9202    FORMAT(' ',i3,' *  ',20(i3,'  x',i3,'   *   ')) 
    228       ENDIF 
    229  
    230       zidom = nreci 
    231       DO ji = 1, jpni 
    232          zidom = zidom + ilcit(ji,1) - nreci 
    233       END DO 
    234       IF(lwp) WRITE(numout,*) 
    235       IF(lwp) WRITE(numout,*)' sum ilcit(i,1) = ', zidom, ' jpiglo = ', jpiglo 
    236        
    237       zjdom = nrecj 
    238       DO jj = 1, jpnj 
    239          zjdom = zjdom + ilcjt(1,jj) - nrecj 
    240       END DO 
    241       IF(lwp) WRITE(numout,*)' sum ilcit(1,j) = ', zjdom, ' jpjglo = ', jpjglo 
    242       IF(lwp) WRITE(numout,*) 
    243        
    244203 
    245204      !  2. Index arrays for subdomains 
    … …  
    304263         nlejt(jn) = nlej 
    305264      END DO 
    306        
    307  
    308       ! 4. From global to local 
     265 
     266      ! 4. Subdomain print 
     267      ! ------------------ 
     268       
     269      IF(lwp) WRITE(numout,*) 
     270      IF(lwp) WRITE(numout,*) ' mpp_init: defines mpp subdomains' 
     271      IF(lwp) WRITE(numout,*) ' ~~~~~~  ----------------------' 
     272      IF(lwp) WRITE(numout,*) 
     273      IF(lwp) WRITE(numout,*) 'iresti=',iresti,' irestj=',irestj 
     274      IF(lwp) WRITE(numout,*) 
     275      IF(lwp) WRITE(numout,*) 'jpni=',jpni,' jpnj=',jpnj 
     276      zidom = nreci 
     277      DO ji = 1, jpni 
     278         zidom = zidom + ilcit(ji,1) - nreci 
     279      END DO 
     280      IF(lwp) WRITE(numout,*) 
     281      IF(lwp) WRITE(numout,*)' sum ilcit(i,1)=', zidom, ' jpiglo=', jpiglo 
     282 
     283      zjdom = nrecj 
     284      DO jj = 1, jpnj 
     285         zjdom = zjdom + ilcjt(1,jj) - nrecj 
     286      END DO 
     287      IF(lwp) WRITE(numout,*)' sum ilcit(1,j)=', zjdom, ' jpjglo=', jpjglo 
     288      IF(lwp) WRITE(numout,*) 
     289 
     290      IF(lwp) THEN 
     291         ifreq = 4 
     292         il1   = 1 
     293         DO jn = 1, (jpni-1)/ifreq+1 
     294            il2 = MIN( jpni, il1+ifreq-1 ) 
     295            WRITE(numout,*) 
     296            WRITE(numout,9200) ('***',ji = il1,il2-1) 
     297            DO jj = jpnj, 1, -1 
     298               WRITE(numout,9203) ('   ',ji = il1,il2-1) 
     299               WRITE(numout,9202) jj, ( ilcit(ji,jj),ilcjt(ji,jj),ji = il1,il2 ) 
     300               WRITE(numout,9204) (nfipproc(ji,jj),ji=il1,il2) 
     301               WRITE(numout,9203) ('   ',ji = il1,il2-1) 
     302               WRITE(numout,9200) ('***',ji = il1,il2-1) 
     303            END DO 
     304            WRITE(numout,9201) (ji,ji = il1,il2) 
     305            il1 = il1+ifreq 
     306         END DO 
     307 9200     FORMAT('     ***',20('*************',a3)) 
     308 9203     FORMAT('     *     ',20('         *   ',a3)) 
     309 9201     FORMAT('        ',20('   ',i3,'          ')) 
     310 9202     FORMAT(' ',i3,' *  ',20(i3,'  x',i3,'   *   ')) 
     311 9204     FORMAT('     *  ',20('      ',i3,'   *   ')) 
     312      ENDIF 
     313 
     314      ! 5. From global to local 
    309315      ! ----------------------- 
    310316 
    … …  
    313319 
    314320 
    315       ! 5. Subdomain neighbours 
     321      ! 6. Subdomain neighbours 
    316322      ! ---------------------- 
    317323 
    … …  
    436442         WRITE(numout,*) ' nimpp  = ', nimpp 
    437443         WRITE(numout,*) ' njmpp  = ', njmpp 
    438          WRITE(numout,*) ' nbse   = ', nbse  , ' npse   = ', npse 
    439          WRITE(numout,*) ' nbsw   = ', nbsw  , ' npsw   = ', npsw 
    440          WRITE(numout,*) ' nbne   = ', nbne  , ' npne   = ', npne 
    441          WRITE(numout,*) ' nbnw   = ', nbnw  , ' npnw   = ', npnw 
     444         WRITE(numout,*) ' nreci  = ', nreci  , ' npse   = ', npse 
     445         WRITE(numout,*) ' nrecj  = ', nrecj  , ' npsw   = ', npsw 
     446         WRITE(numout,*) ' jpreci = ', jpreci , ' npne   = ', npne 
     447         WRITE(numout,*) ' jprecj = ', jprecj , ' npnw   = ', npnw 
     448         WRITE(numout,*) 
    442449      ENDIF 
    443450 
    … …  
    446453      ! Prepare mpp north fold 
    447454 
    448       IF (jperio >= 3 .AND. jperio <= 6 .AND. jpni > 1 ) THEN 
     455      IF( jperio >= 3 .AND. jperio <= 6 .AND. jpni > 1 ) THEN 
    449456         CALL mpp_ini_north 
    450       END IF 
     457         IF(lwp) WRITE(numout,*) ' mpp_init : North fold boundary prepared for jpni >1' 
     458      ENDIF 
    451459 
    452460      ! Prepare NetCDF output file (if necessary) 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/LBC/mppini_2.h90

    r6836 r6839  
    318318         ENDIF 
    319319 
     320         ! Check wet points over the entire domain to preserve the MPI communication stencil 
    320321         isurf = 0 
    321          DO jj = 1+jprecj, ilj-jprecj 
    322             DO  ji = 1+jpreci, ili-jpreci 
     322         DO jj = 1, ilj 
     323            DO  ji = 1, ili 
    323324               IF( imask(ji+iimppt(ii,ij)-1, jj+ijmppt(ii,ij)-1) == 1) isurf = isurf+1 
    324325            END DO 
    325326         END DO 
     327 
    326328         IF(isurf /= 0) THEN 
    327329            icont = icont + 1 
    … …  
    333335 
    334336      nfipproc(:,:) = ipproc(:,:) 
    335  
    336337 
    337338      ! Control 
    … …  
    441442      ii = iin(narea) 
    442443      ij = ijn(narea) 
     444 
     445      ! set default neighbours 
     446      noso = ioso(ii,ij) 
     447      nowe = iowe(ii,ij) 
     448      noea = ioea(ii,ij) 
     449      nono = iono(ii,ij)  
     450      npse = iose(ii,ij) 
     451      npsw = iosw(ii,ij) 
     452      npne = ione(ii,ij) 
     453      npnw = ionw(ii,ij) 
     454 
     455      ! check neighbours location 
    443456      IF( ioso(ii,ij) >= 0 .AND. ioso(ii,ij) <= (jpni*jpnj-1) ) THEN  
    444457         iiso = 1 + MOD(ioso(ii,ij),jpni) 
    … …  
    511524      IF (lwp) THEN 
    512525         CALL ctl_opn( inum, 'layout.dat', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE., narea ) 
     526         WRITE(inum,'(a)') '   jpnij     jpi     jpj     jpk  jpiglo  jpjglo' 
    513527         WRITE(inum,'(6i8)') jpnij,jpi,jpj,jpk,jpiglo,jpjglo 
    514528         WRITE(inum,'(a)') 'NAREA nlci nlcj nldi nldj nlei nlej nimpp njmpp' 
    … …  
    523537      END IF 
    524538 
    525       IF( nperio == 1 .AND.jpni /= 1 ) CALL ctl_stop( ' mpp_init2:  error on cyclicity' ) 
    526  
    527       ! Prepare mpp north fold 
    528  
    529       IF( jperio >= 3 .AND. jperio <= 6 .AND. jpni > 1 ) THEN 
    530          CALL mpp_ini_north 
    531          IF(lwp) WRITE(numout,*) ' mpp_init2 : North fold boundary prepared for jpni >1' 
    532       ENDIF 
    533  
    534539      ! Defined npolj, either 0, 3 , 4 , 5 , 6 
    535540      ! In this case the important thing is that npolj /= 0 
    … …  
    548553      ENDIF 
    549554 
     555      ! Periodicity : no corner if nbondi = 2 and nperio != 1 
     556 
     557      IF(lwp) THEN 
     558         WRITE(numout,*) ' nproc  = ', nproc 
     559         WRITE(numout,*) ' nowe   = ', nowe  , ' noea   =  ', noea 
     560         WRITE(numout,*) ' nono   = ', nono  , ' noso   =  ', noso 
     561         WRITE(numout,*) ' nbondi = ', nbondi 
     562         WRITE(numout,*) ' nbondj = ', nbondj 
     563         WRITE(numout,*) ' npolj  = ', npolj 
     564         WRITE(numout,*) ' nperio = ', nperio 
     565         WRITE(numout,*) ' nlci   = ', nlci 
     566         WRITE(numout,*) ' nlcj   = ', nlcj 
     567         WRITE(numout,*) ' nimpp  = ', nimpp 
     568         WRITE(numout,*) ' njmpp  = ', njmpp 
     569         WRITE(numout,*) ' nreci  = ', nreci  , ' npse   = ', npse 
     570         WRITE(numout,*) ' nrecj  = ', nrecj  , ' npsw   = ', npsw 
     571         WRITE(numout,*) ' jpreci = ', jpreci , ' npne   = ', npne 
     572         WRITE(numout,*) ' jprecj = ', jprecj , ' npnw   = ', npnw 
     573         WRITE(numout,*) 
     574      ENDIF 
     575 
     576      IF( nperio == 1 .AND. jpni /= 1 ) CALL ctl_stop( ' mpp_init2: error on cyclicity' ) 
     577 
     578      ! Prepare mpp north fold 
     579 
     580      IF( jperio >= 3 .AND. jperio <= 6 .AND. jpni > 1 ) THEN 
     581         CALL mpp_ini_north 
     582         IF(lwp) WRITE(numout,*) ' mpp_init2 : North fold boundary prepared for jpni >1' 
     583      ENDIF 
     584 
    550585      ! Prepare NetCDF output file (if necessary) 
    551586      CALL mpp_init_ioipsl 
    552587 
    553       ! Periodicity : no corner if nbondi = 2 and nperio != 1 
    554  
    555       IF(lwp) THEN 
    556          WRITE(numout,*) ' nproc=  ',nproc 
    557          WRITE(numout,*) ' nowe=   ',nowe 
    558          WRITE(numout,*) ' noea=   ',noea 
    559          WRITE(numout,*) ' nono=   ',nono 
    560          WRITE(numout,*) ' noso=   ',noso 
    561          WRITE(numout,*) ' nbondi= ',nbondi 
    562          WRITE(numout,*) ' nbondj= ',nbondj 
    563          WRITE(numout,*) ' npolj=  ',npolj 
    564          WRITE(numout,*) ' nperio= ',nperio 
    565          WRITE(numout,*) ' nlci=   ',nlci 
    566          WRITE(numout,*) ' nlcj=   ',nlcj 
    567          WRITE(numout,*) ' nimpp=  ',nimpp 
    568          WRITE(numout,*) ' njmpp=  ',njmpp 
    569          WRITE(numout,*) ' nbse=   ',nbse,' npse= ',npse 
    570          WRITE(numout,*) ' nbsw=   ',nbsw,' npsw= ',npsw 
    571          WRITE(numout,*) ' nbne=   ',nbne,' npne= ',npne 
    572          WRITE(numout,*) ' nbnw=   ',nbnw,' npnw= ',npnw 
    573       ENDIF 
    574588 
    575589   END SUBROUTINE mpp_init2 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/LDF/ldfeiv.F90

    r6836 r6839  
    157157         END DO 
    158158      ENDIF 
     159 
     160      ! ORCA R1: Take the minimum between aeiw  and aeiv0 
     161      IF( cp_cfg == "orca" .AND. jp_cfg == 1 ) THEN 
     162         DO jj = 2, jpjm1 
     163            DO ji = fs_2, fs_jpim1   ! vector opt. 
     164               aeiw(ji,jj) = MIN( aeiw(ji,jj), aeiv0 ) 
     165            END DO 
     166         END DO 
     167      ENDIF 
     168 
    159169      CALL lbc_lnk( aeiw, 'W', 1. )      ! lateral boundary condition on aeiw  
    160170 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/LDF/ldfslp.F90

    r6836 r6839  
    188188            DO jj = 2, jpjm1 
    189189               DO ji = fs_2, fs_jpim1   ! vector opt. 
    190                   IF (miku(ji,jj) .GT. miku(ji+1,jj)) zhmlpu(ji,jj) = MAX(hmlpt(ji  ,jj  ),                   5._wp) 
    191                   IF (miku(ji,jj) .LT. miku(ji+1,jj)) zhmlpu(ji,jj) = MAX(hmlpt(ji+1,jj  ),                   5._wp) 
    192                   IF (miku(ji,jj) .EQ. miku(ji+1,jj)) zhmlpu(ji,jj) = MAX(hmlpt(ji  ,jj  ), hmlpt(ji+1,jj  ), 5._wp) 
    193                   IF (mikv(ji,jj) .GT. miku(ji,jj+1)) zhmlpv(ji,jj) = MAX(hmlpt(ji  ,jj  ),                   5._wp) 
    194                   IF (mikv(ji,jj) .LT. miku(ji,jj+1)) zhmlpv(ji,jj) = MAX(hmlpt(ji  ,jj+1),                   5._wp) 
    195                   IF (mikv(ji,jj) .EQ. miku(ji,jj+1)) zhmlpv(ji,jj) = MAX(hmlpt(ji  ,jj  ), hmlpt(ji  ,jj+1), 5._wp) 
     190               zhmlpu(ji,jj) = ( MAX(hmlpt(ji,jj)  , hmlpt  (ji+1,jj  ), 5._wp)   & 
     191                  &            - MAX(risfdep(ji,jj), risfdep(ji+1,jj  )       )   ) 
     192               zhmlpv(ji,jj) = ( MAX(hmlpt  (ji,jj), hmlpt  (ji  ,jj+1), 5._wp)   & 
     193                  &            - MAX(risfdep(ji,jj), risfdep(ji  ,jj+1)       )   ) 
    196194               ENDDO 
    197195            ENDDO 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/LDF/ldftra_oce.F90

    r6836 r6839  
    4141 
    4242   REAL(wp), PUBLIC ::   rldf                        !: multiplicative factor of diffusive coefficient 
     43   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   r_fact_lap 
    4344                                                     !: Needed to define the ratio between passive and active tracer diffusion coef.  
    4445 
    … …  
    9293      !!                 ***  FUNCTION ldftra_oce_alloc  *** 
    9394     !!---------------------------------------------------------------------- 
    94      INTEGER, DIMENSION(3) :: ierr 
     95     INTEGER, DIMENSION(4) :: ierr 
    9596     !!---------------------------------------------------------------------- 
    9697     ierr(:) = 0 
    … …  
    116117# endif 
    117118#endif 
     119      ALLOCATE( r_fact_lap(jpi,jpj,jpk), STAT=ierr(4) ) 
    118120      ldftra_oce_alloc = MAXVAL( ierr ) 
    119121      IF( ldftra_oce_alloc /= 0 )   CALL ctl_warn('ldftra_oce_alloc: failed to allocate arrays') 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/LDF/ldftra_substitute.h90

    r6836 r6839  
    1313!   'key_traldf_c3d' :                 aht: 3D coefficient 
    1414#       define   fsahtt(i,j,k)   rldf * ahtt(i,j,k) 
    15 #       define   fsahtu(i,j,k)   rldf * ahtu(i,j,k) 
     15#       define   fsahtu(i,j,k)   rldf * ahtu(i,j,k) * r_fact_lap(i,j,k) 
    1616#       define   fsahtv(i,j,k)   rldf * ahtv(i,j,k) 
    1717#       define   fsahtw(i,j,k)   rldf * ahtw(i,j,k) 
    … …  
    1919!   'key_traldf_c2d' :                 aht: 2D coefficient 
    2020#       define   fsahtt(i,j,k)   rldf * ahtt(i,j) 
    21 #       define   fsahtu(i,j,k)   rldf * ahtu(i,j) 
     21#       define   fsahtu(i,j,k)   rldf * ahtu(i,j) * r_fact_lap(i,j,k) 
    2222#       define   fsahtv(i,j,k)   rldf * ahtv(i,j) 
    2323#       define   fsahtw(i,j,k)   rldf * ahtw(i,j) 
    … …  
    2525!   'key_traldf_c1d' :                aht: 1D coefficient 
    2626#       define   fsahtt(i,j,k)   rldf * ahtt(k) 
    27 #       define   fsahtu(i,j,k)   rldf * ahtu(k) 
     27#       define   fsahtu(i,j,k)   rldf * ahtu(k) * r_fact_lap(i,j,k) 
    2828#       define   fsahtv(i,j,k)   rldf * ahtv(k) 
    2929#       define   fsahtw(i,j,k)   rldf * ahtw(k) 
    … …  
    3131!   Default option :             aht: Constant coefficient 
    3232#      define   fsahtt(i,j,k)   rldf * aht0 
    33 #      define   fsahtu(i,j,k)   rldf * aht0 
     33#      define   fsahtu(i,j,k)   rldf * aht0 * r_fact_lap(i,j,k) 
    3434#      define   fsahtv(i,j,k)   rldf * aht0 
    3535#      define   fsahtw(i,j,k)   rldf * aht0 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/SBC/albedo.F90

    r6836 r6839  
    99   !!             -   ! 2001-06  (M. Vancoppenolle) LIM 3.0 
    1010   !!             -   ! 2006-08  (G. Madec)  cleaning for surface module 
     11   !!            3.6  ! 2016-01  (C. Rousset) new parameterization for sea ice albedo 
    1112   !!---------------------------------------------------------------------- 
    1213 
    … …  
    2930 
    3031   INTEGER  ::   albd_init = 0      !: control flag for initialization 
    31    REAL(wp) ::   zzero     = 0.e0   ! constant values 
    32    REAL(wp) ::   zone      = 1.e0   !    "       " 
    33  
    34    REAL(wp) ::   c1     = 0.05    ! constants values 
    35    REAL(wp) ::   c2     = 0.10    !    "        " 
    36    REAL(wp) ::   rmue   = 0.40    !  cosine of local solar altitude 
    37  
     32   
     33   REAL(wp) ::   rmue     = 0.40    !  cosine of local solar altitude 
     34   REAL(wp) ::   ralb_oce = 0.066   ! ocean or lead albedo (Pegau and Paulson, Ann. Glac. 2001) 
     35   REAL(wp) ::   c1       = 0.05    ! snow thickness (only for nn_ice_alb=0) 
     36   REAL(wp) ::   c2       = 0.10    !  "        " 
     37   REAL(wp) ::   rcloud   = 0.06    ! cloud effect on albedo (only-for nn_ice_alb=0) 
     38  
    3839   !                             !!* namelist namsbc_alb 
    39    REAL(wp) ::   rn_cloud         !  cloudiness effect on snow or ice albedo (Grenfell & Perovich, 1984) 
    40 #if defined key_lim3 
    41    REAL(wp) ::   rn_albice        !  albedo of melting ice in the arctic and antarctic (Shine & Hendersson-Sellers) 
    42 #else 
    43    REAL(wp) ::   rn_albice        !  albedo of melting ice in the arctic and antarctic (Shine & Hendersson-Sellers) 
    44 #endif 
    45    REAL(wp) ::   rn_alphd         !  coefficients for linear interpolation used to compute 
    46    REAL(wp) ::   rn_alphdi        !  albedo between two extremes values (Pyane, 1972) 
    47    REAL(wp) ::   rn_alphc         !  
     40   INTEGER  ::   nn_ice_alb 
     41   REAL(wp) ::   rn_albice 
    4842 
    4943   !!---------------------------------------------------------------------- 
    … …  
    5953      !!           
    6054      !! ** Purpose :   Computation of the albedo of the snow/ice system  
    61       !!                as well as the ocean one 
    6255      !!        
    63       !! ** Method  : - Computation of the albedo of snow or ice (choose the  
    64       !!                rignt one by a large number of tests 
    65       !!              - Computation of the albedo of the ocean 
    66       !! 
    67       !! References :   Shine and Hendersson-Sellers 1985, JGR, 90(D1), 2243-2250. 
     56      !! ** Method  :   Two schemes are available (from namelist parameter nn_ice_alb) 
     57      !!                  0: the scheme is that of Shine & Henderson-Sellers (JGR 1985) for clear-skies 
     58      !!                  1: the scheme is "home made" (for cloudy skies) and based on Brandt et al. (J. Climate 2005) 
     59      !!                                                                           and Grenfell & Perovich (JGR 2004) 
     60      !!                Description of scheme 1: 
     61      !!                  1) Albedo dependency on ice thickness follows the findings from Brandt et al (2005) 
     62      !!                     which are an update of Allison et al. (JGR 1993) ; Brandt et al. 1999 
     63      !!                     0-5cm  : linear function of ice thickness 
     64      !!                     5-150cm: log    function of ice thickness 
     65      !!                     > 150cm: constant 
     66      !!                  2) Albedo dependency on snow thickness follows the findings from Grenfell & Perovich (2004) 
     67      !!                     i.e. it increases as -EXP(-snw_thick/0.02) during freezing and -EXP(-snw_thick/0.03) during melting 
     68      !!                  3) Albedo dependency on clouds is speculated from measurements of Grenfell and Perovich (2004) 
     69      !!                     i.e. cloudy-clear albedo depend on cloudy albedo following a 2d order polynomial law 
     70      !!                  4) The needed 4 parameters are: dry and melting snow, freezing ice and bare puddled ice 
     71      !! 
     72      !! ** Note    :   The parameterization from Shine & Henderson-Sellers presents several misconstructions: 
     73      !!                  1) ice albedo when ice thick. tends to 0 is different than ocean albedo 
     74      !!                  2) for small ice thick. covered with some snow (<3cm?), albedo is larger  
     75      !!                     under melting conditions than under freezing conditions 
     76      !!                  3) the evolution of ice albedo as a function of ice thickness shows   
     77      !!                     3 sharp inflexion points (at 5cm, 100cm and 150cm) that look highly unrealistic 
     78      !! 
     79      !! References :   Shine & Henderson-Sellers 1985, JGR, 90(D1), 2243-2250. 
     80      !!                Brandt et al. 2005, J. Climate, vol 18 
     81      !!                Grenfell & Perovich 2004, JGR, vol 109  
    6882      !!---------------------------------------------------------------------- 
    6983      REAL(wp), INTENT(in   ), DIMENSION(:,:,:) ::   pt_ice      !  ice surface temperature (Kelvin) 
    … …  
    7387      REAL(wp), INTENT(  out), DIMENSION(:,:,:) ::   pa_ice_os   !  albedo of ice under overcast sky 
    7488      !! 
    75       INTEGER  ::   ji, jj, jl    ! dummy loop indices 
    76       INTEGER  ::   ijpl          ! number of ice categories (3rd dim of ice input arrays) 
    77       REAL(wp) ::   zalbpsnm      ! albedo of ice under clear sky when snow is melting 
    78       REAL(wp) ::   zalbpsnf      ! albedo of ice under clear sky when snow is freezing 
    79       REAL(wp) ::   zalbpsn       ! albedo of snow/ice system when ice is coverd by snow 
    80       REAL(wp) ::   zalbpic       ! albedo of snow/ice system when ice is free of snow 
    81       REAL(wp) ::   zithsn        ! = 1 for hsn >= 0 ( ice is cov. by snow ) ; = 0 otherwise (ice is free of snow) 
    82       REAL(wp) ::   zitmlsn       ! = 1 freezinz snow (pt_ice >=rt0_snow) ; = 0 melting snow (pt_ice<rt0_snow) 
    83       REAL(wp) ::   zihsc1        ! = 1 hsn <= c1 ; = 0 hsn > c1 
    84       REAL(wp) ::   zihsc2        ! = 1 hsn >= c2 ; = 0 hsn < c2 
    85       !! 
    86       REAL(wp), POINTER, DIMENSION(:,:,:) ::   zalbfz    ! = rn_alphdi for freezing ice ; = rn_albice for melting ice 
    87       REAL(wp), POINTER, DIMENSION(:,:,:) ::   zficeth   !  function of ice thickness 
     89      INTEGER  ::   ji, jj, jl         ! dummy loop indices 
     90      INTEGER  ::   ijpl               ! number of ice categories (3rd dim of ice input arrays) 
     91      REAL(wp)            ::   ralb_im, ralb_sf, ralb_sm, ralb_if 
     92      REAL(wp)            ::   zswitch, z1_c1, z1_c2 
     93      REAL(wp)                            ::   zalb_sm, zalb_sf, zalb_st ! albedo of snow melting, freezing, total 
     94      REAL(wp), POINTER, DIMENSION(:,:,:) ::   zalb, zalb_it             ! intermediate variable & albedo of ice (snow free) 
    8895      !!--------------------------------------------------------------------- 
    89        
     96 
    9097      ijpl = SIZE( pt_ice, 3 )                     ! number of ice categories 
    91  
    92       CALL wrk_alloc( jpi,jpj,ijpl, zalbfz, zficeth ) 
     98       
     99      CALL wrk_alloc( jpi,jpj,ijpl, zalb, zalb_it ) 
    93100 
    94101      IF( albd_init == 0 )   CALL albedo_init      ! initialization  
    95102 
    96       !--------------------------- 
    97       !  Computation of  zficeth 
    98       !--------------------------- 
    99       ! ice free of snow and melts 
    100       WHERE     ( ph_snw == 0._wp .AND. pt_ice >= rt0_ice )   ;   zalbfz(:,:,:) = rn_albice 
    101       ELSE WHERE                                              ;   zalbfz(:,:,:) = rn_alphdi 
    102       END  WHERE 
    103  
    104       WHERE     ( 1.5  < ph_ice                     )  ;  zficeth = zalbfz 
    105       ELSE WHERE( 1.0  < ph_ice .AND. ph_ice <= 1.5 )  ;  zficeth = 0.472  + 2.0 * ( zalbfz - 0.472 ) * ( ph_ice - 1.0 ) 
    106       ELSE WHERE( 0.05 < ph_ice .AND. ph_ice <= 1.0 )  ;  zficeth = 0.2467 + 0.7049 * ph_ice              & 
    107          &                                                                 - 0.8608 * ph_ice * ph_ice     & 
    108          &                                                                 + 0.3812 * ph_ice * ph_ice * ph_ice 
    109       ELSE WHERE                                       ;  zficeth = 0.1    + 3.6    * ph_ice 
    110       END WHERE 
    111  
    112 !!gm old code 
    113 !      DO jl = 1, ijpl 
    114 !         DO jj = 1, jpj 
    115 !            DO ji = 1, jpi 
    116 !               IF( ph_ice(ji,jj,jl) > 1.5 ) THEN 
    117 !                  zficeth(ji,jj,jl) = zalbfz(ji,jj,jl) 
    118 !               ELSEIF( ph_ice(ji,jj,jl) > 1.0  .AND. ph_ice(ji,jj,jl) <= 1.5 ) THEN 
    119 !                  zficeth(ji,jj,jl) = 0.472 + 2.0 * ( zalbfz(ji,jj,jl) - 0.472 ) * ( ph_ice(ji,jj,jl) - 1.0 ) 
    120 !               ELSEIF( ph_ice(ji,jj,jl) > 0.05 .AND. ph_ice(ji,jj,jl) <= 1.0 ) THEN 
    121 !                  zficeth(ji,jj,jl) = 0.2467 + 0.7049 * ph_ice(ji,jj,jl)                               & 
    122 !                     &                    - 0.8608 * ph_ice(ji,jj,jl) * ph_ice(ji,jj,jl)                 & 
    123 !                     &                    + 0.3812 * ph_ice(ji,jj,jl) * ph_ice(ji,jj,jl) * ph_ice (ji,jj,jl) 
    124 !               ELSE 
    125 !                  zficeth(ji,jj,jl) = 0.1 + 3.6 * ph_ice(ji,jj,jl)  
    126 !               ENDIF 
    127 !            END DO 
    128 !         END DO 
    129 !      END DO 
    130 !!gm end old code 
    131        
    132       !-----------------------------------------------  
    133       !    Computation of the snow/ice albedo system  
    134       !-------------------------- --------------------- 
    135        
    136       !    Albedo of snow-ice for clear sky. 
    137       !-----------------------------------------------     
    138       DO jl = 1, ijpl 
    139          DO jj = 1, jpj 
    140             DO ji = 1, jpi 
    141                !  Case of ice covered by snow.              
    142                !                                        !  freezing snow         
    143                zihsc1   = 1.0 - MAX( zzero , SIGN( zone , - ( ph_snw(ji,jj,jl) - c1 ) ) ) 
    144                zalbpsnf = ( 1.0 - zihsc1 ) * (  zficeth(ji,jj,jl)                                             & 
    145                   &                           + ph_snw(ji,jj,jl) * ( rn_alphd - zficeth(ji,jj,jl) ) / c1  )   & 
    146                   &     +         zihsc1   * rn_alphd   
    147                !                                        !  melting snow                 
    148                zihsc2   = MAX( zzero , SIGN( zone , ph_snw(ji,jj,jl) - c2 ) ) 
    149                zalbpsnm = ( 1.0 - zihsc2 ) * ( rn_albice + ph_snw(ji,jj,jl) * ( rn_alphc - rn_albice ) / c2 )   & 
    150                   &     +         zihsc2   *   rn_alphc  
    151                ! 
    152                zitmlsn  =  MAX( zzero , SIGN( zone , pt_ice(ji,jj,jl) - rt0_snow ) )    
    153                zalbpsn  =  zitmlsn * zalbpsnm + ( 1.0 - zitmlsn ) * zalbpsnf 
    154              
    155                !  Case of ice free of snow. 
    156                zalbpic  = zficeth(ji,jj,jl)  
    157              
    158                ! albedo of the system    
    159                zithsn   = 1.0 - MAX( zzero , SIGN( zone , - ph_snw(ji,jj,jl) ) ) 
    160                pa_ice_cs(ji,jj,jl) =  zithsn * zalbpsn + ( 1.0 - zithsn ) *  zalbpic 
     103       
     104      SELECT CASE ( nn_ice_alb ) 
     105 
     106      !------------------------------------------ 
     107      !  Shine and Henderson-Sellers (1985) 
     108      !------------------------------------------ 
     109      CASE( 0 ) 
     110        
     111         ralb_sf = 0.80       ! dry snow 
     112         ralb_sm = 0.65       ! melting snow 
     113         ralb_if = 0.72       ! bare frozen ice 
     114         ralb_im = rn_albice  ! bare puddled ice  
     115          
     116         !  Computation of ice albedo (free of snow) 
     117         WHERE     ( ph_snw == 0._wp .AND. pt_ice >= rt0_ice )   ;   zalb(:,:,:) = ralb_im 
     118         ELSE WHERE                                              ;   zalb(:,:,:) = ralb_if 
     119         END  WHERE 
     120       
     121         WHERE     ( 1.5  < ph_ice                     )  ;  zalb_it = zalb 
     122         ELSE WHERE( 1.0  < ph_ice .AND. ph_ice <= 1.5 )  ;  zalb_it = 0.472  + 2.0 * ( zalb - 0.472 ) * ( ph_ice - 1.0 ) 
     123         ELSE WHERE( 0.05 < ph_ice .AND. ph_ice <= 1.0 )  ;  zalb_it = 0.2467 + 0.7049 * ph_ice              & 
     124            &                                                                 - 0.8608 * ph_ice * ph_ice     & 
     125            &                                                                 + 0.3812 * ph_ice * ph_ice * ph_ice 
     126         ELSE WHERE                                       ;  zalb_it = 0.1    + 3.6    * ph_ice 
     127         END WHERE 
     128      
     129         DO jl = 1, ijpl 
     130            DO jj = 1, jpj 
     131               DO ji = 1, jpi 
     132                  ! freezing snow 
     133                  ! no effect of underlying ice layer IF snow thickness > c1. Albedo does not depend on snow thick if > c2 
     134                  !                                        !  freezing snow         
     135                  zswitch   = 1._wp - MAX( 0._wp , SIGN( 1._wp , - ( ph_snw(ji,jj,jl) - c1 ) ) ) 
     136                  zalb_sf   = ( 1._wp - zswitch ) * (  zalb_it(ji,jj,jl)  & 
     137                     &                           + ph_snw(ji,jj,jl) * ( ralb_sf - zalb_it(ji,jj,jl) ) / c1  )   & 
     138                     &        +         zswitch   * ralb_sf   
     139 
     140                  ! melting snow 
     141                  ! no effect of underlying ice layer. Albedo does not depend on snow thick IF > c2 
     142                  zswitch   = MAX( 0._wp , SIGN( 1._wp , ph_snw(ji,jj,jl) - c2 ) ) 
     143                  zalb_sm = ( 1._wp - zswitch ) * ( ralb_im + ph_snw(ji,jj,jl) * ( ralb_sm - ralb_im ) / c2 )   & 
     144                      &     +         zswitch   *   ralb_sm  
     145                  ! 
     146                  ! snow albedo 
     147                  zswitch  =  MAX( 0._wp , SIGN( 1._wp , pt_ice(ji,jj,jl) - rt0_snow ) )    
     148                  zalb_st  =  zswitch * zalb_sm + ( 1._wp - zswitch ) * zalb_sf 
     149                
     150                  ! Ice/snow albedo 
     151                  zswitch   = 1._wp - MAX( 0._wp , SIGN( 1._wp , - ph_snw(ji,jj,jl) ) ) 
     152                  pa_ice_cs(ji,jj,jl) =  zswitch * zalb_st + ( 1._wp - zswitch ) * zalb_it(ji,jj,jl) 
     153                  ! 
     154               END DO 
    161155            END DO 
    162156         END DO 
    163       END DO 
    164        
    165       !    Albedo of snow-ice for overcast sky. 
    166       !----------------------------------------------   
    167       pa_ice_os(:,:,:) = pa_ice_cs(:,:,:) + rn_cloud       ! Oberhuber correction 
    168       ! 
    169       CALL wrk_dealloc( jpi,jpj,ijpl, zalbfz, zficeth ) 
     157 
     158         pa_ice_os(:,:,:) = pa_ice_cs(:,:,:) + rcloud       ! Oberhuber correction for overcast sky 
     159 
     160      !------------------------------------------ 
     161      !  New parameterization (2016) 
     162      !------------------------------------------ 
     163      CASE( 1 )  
     164 
     165         ralb_im = rn_albice  ! bare puddled ice 
     166! compilation of values from literature 
     167         ralb_sf = 0.85      ! dry snow 
     168         ralb_sm = 0.75      ! melting snow 
     169         ralb_if = 0.60      ! bare frozen ice 
     170! Perovich et al 2002 (Sheba) => the only dataset for which all types of ice/snow were retrieved 
     171!         ralb_sf = 0.85       ! dry snow 
     172!         ralb_sm = 0.72       ! melting snow 
     173!         ralb_if = 0.65       ! bare frozen ice 
     174! Brandt et al 2005 (East Antarctica) 
     175!         ralb_sf = 0.87      ! dry snow 
     176!         ralb_sm = 0.82      ! melting snow 
     177!         ralb_if = 0.54      ! bare frozen ice 
     178!  
     179         !  Computation of ice albedo (free of snow) 
     180         z1_c1 = 1. / ( LOG(1.5) - LOG(0.05) )  
     181         z1_c2 = 1. / 0.05 
     182         WHERE     ( ph_snw == 0._wp .AND. pt_ice >= rt0_ice )   ;   zalb = ralb_im 
     183         ELSE WHERE                                              ;   zalb = ralb_if 
     184         END  WHERE 
     185          
     186         WHERE     ( 1.5  < ph_ice                     )  ;  zalb_it = zalb 
     187         ELSE WHERE( 0.05 < ph_ice .AND. ph_ice <= 1.5 )  ;  zalb_it = zalb     + ( 0.18 - zalb     ) * z1_c1 *  & 
     188            &                                                                     ( LOG(1.5) - LOG(ph_ice) ) 
     189         ELSE WHERE                                       ;  zalb_it = ralb_oce + ( 0.18 - ralb_oce ) * z1_c2 * ph_ice 
     190         END WHERE 
     191 
     192         z1_c1 = 1. / 0.02 
     193         z1_c2 = 1. / 0.03 
     194         !  Computation of the snow/ice albedo 
     195         DO jl = 1, ijpl 
     196            DO jj = 1, jpj 
     197               DO ji = 1, jpi 
     198                  zalb_sf = ralb_sf - ( ralb_sf - zalb_it(ji,jj,jl)) * EXP( - ph_snw(ji,jj,jl) * z1_c1 ); 
     199                  zalb_sm = ralb_sm - ( ralb_sm - zalb_it(ji,jj,jl)) * EXP( - ph_snw(ji,jj,jl) * z1_c2 ); 
     200 
     201                   ! snow albedo 
     202                  zswitch = MAX( 0._wp , SIGN( 1._wp , pt_ice(ji,jj,jl) - rt0_snow ) )    
     203                  zalb_st = zswitch * zalb_sm + ( 1._wp - zswitch ) * zalb_sf 
     204 
     205                  ! Ice/snow albedo    
     206                  zswitch             = MAX( 0._wp , SIGN( 1._wp , - ph_snw(ji,jj,jl) ) ) 
     207                  pa_ice_os(ji,jj,jl) = ( 1._wp - zswitch ) * zalb_st + zswitch *  zalb_it(ji,jj,jl) 
     208 
     209              END DO 
     210            END DO 
     211         END DO 
     212         ! Effect of the clouds (2d order polynomial) 
     213         pa_ice_cs = pa_ice_os - ( - 0.1010 * pa_ice_os * pa_ice_os + 0.1933 * pa_ice_os - 0.0148 );  
     214 
     215      END SELECT 
     216       
     217      CALL wrk_dealloc( jpi,jpj,ijpl, zalb, zalb_it ) 
    170218      ! 
    171219   END SUBROUTINE albedo_ice 
    … …  
    181229      REAL(wp), DIMENSION(:,:), INTENT(out) ::   pa_oce_cs   !  albedo of ocean under clear sky 
    182230      !! 
    183       REAL(wp) ::   zcoef   ! local scalar 
    184       !!---------------------------------------------------------------------- 
    185       ! 
    186       zcoef = 0.05 / ( 1.1 * rmue**1.4 + 0.15 )      ! Parameterization of Briegled and Ramanathan, 1982  
    187       pa_oce_cs(:,:) = zcoef                
    188       pa_oce_os(:,:)  = 0.06                         ! Parameterization of Kondratyev, 1969 and Payne, 1972 
     231      REAL(wp) :: zcoef  
     232      !!---------------------------------------------------------------------- 
     233      ! 
     234      zcoef = 0.05 / ( 1.1 * rmue**1.4 + 0.15 )   ! Parameterization of Briegled and Ramanathan, 1982 
     235      pa_oce_cs(:,:) = zcoef  
     236      pa_oce_os(:,:) = 0.06                       ! Parameterization of Kondratyev, 1969 and Payne, 1972 
    189237      ! 
    190238   END SUBROUTINE albedo_oce 
    … …  
    200248      !!---------------------------------------------------------------------- 
    201249      INTEGER  ::   ios                 ! Local integer output status for namelist read 
    202       NAMELIST/namsbc_alb/ rn_cloud, rn_albice, rn_alphd, rn_alphdi, rn_alphc 
     250      NAMELIST/namsbc_alb/ nn_ice_alb, rn_albice  
    203251      !!---------------------------------------------------------------------- 
    204252      ! 
    … …  
    219267         WRITE(numout,*) '~~~~~~~' 
    220268         WRITE(numout,*) '   Namelist namsbc_alb : albedo ' 
    221          WRITE(numout,*) '      correction for snow and ice albedo                  rn_cloud  = ', rn_cloud 
    222          WRITE(numout,*) '      albedo of melting ice in the arctic and antarctic   rn_albice = ', rn_albice 
    223          WRITE(numout,*) '      coefficients for linear                             rn_alphd  = ', rn_alphd 
    224          WRITE(numout,*) '      interpolation used to compute albedo                rn_alphdi = ', rn_alphdi 
    225          WRITE(numout,*) '      between two extremes values (Pyane, 1972)           rn_alphc  = ', rn_alphc 
     269         WRITE(numout,*) '      choose the albedo parameterization                  nn_ice_alb = ', nn_ice_alb 
     270         WRITE(numout,*) '      albedo of bare puddled ice                          rn_albice  = ', rn_albice 
    226271      ENDIF 
    227272      ! 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/SBC/fldread.F90

    r6836 r6839  
    3232   PUBLIC   fld_map    ! routine called by tides_init 
    3333   PUBLIC   fld_read, fld_fill   ! called by sbc... modules 
     34   PUBLIC   fld_clopn 
    3435 
    3536   TYPE, PUBLIC ::   FLD_N      !: Namelist field informations 
    … …  
    815816         imonth = kmonth 
    816817         iday = kday 
     818         IF ( sdjf%cltype(1:4) == 'week' ) THEN             ! find the day of the beginning of the week 
     819            isec_week = ksec_week( sdjf%cltype(6:8) )- (86400 * 8 )   
     820            llprevmth  = isec_week > nsec_month             ! longer time since beginning of the week than the month 
     821            llprevyr   = llprevmth .AND. nmonth == 1 
     822            iyear  = nyear  - COUNT((/llprevyr /)) 
     823            imonth = nmonth - COUNT((/llprevmth/)) + 12 * COUNT((/llprevyr /)) 
     824            iday   = nday   + nmonth_len(nmonth-1) * COUNT((/llprevmth/)) - isec_week / NINT(rday) 
     825         ENDIF 
    817826      ELSE                                                  ! use current day values 
    818827         IF ( sdjf%cltype(1:4) == 'week' ) THEN             ! find the day of the beginning of the week 
    … …  
    12811290      CHARACTER(LEN=*)          , INTENT(in   ) ::   lsmfile ! land sea mask file name 
    12821291      !!  
    1283       REAL(wp),DIMENSION(:,:,:),ALLOCATABLE     ::   ztmp_fly_dta,zfieldo                  ! temporary array of values on input grid 
     1292      REAL(wp),DIMENSION(:,:,:),ALLOCATABLE     ::   ztmp_fly_dta                          ! temporary array of values on input grid 
    12841293      INTEGER, DIMENSION(3)                     ::   rec1,recn                             ! temporary arrays for start and length 
    12851294      INTEGER, DIMENSION(3)                     ::   rec1_lsm,recn_lsm                     ! temporary arrays for start and length in case of seaoverland 
    … …  
    13471356 
    13481357 
    1349          itmpi=SIZE(ztmp_fly_dta(jpi1_lsm:jpi2_lsm,jpj1_lsm:jpj2_lsm,:),1) 
    1350          itmpj=SIZE(ztmp_fly_dta(jpi1_lsm:jpi2_lsm,jpj1_lsm:jpj2_lsm,:),2) 
     1358         itmpi=jpi2_lsm-jpi1_lsm+1 
     1359         itmpj=jpj2_lsm-jpj1_lsm+1 
    13511360         itmpz=kk 
    13521361         ALLOCATE(ztmp_fly_dta(itmpi,itmpj,itmpz)) 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/SBC/sbc_ice.F90

    r6836 r6839  
    8080   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   qemp_oce       !: heat flux of precip and evap over ocean     [W/m2] 
    8181   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   qemp_ice       !: heat flux of precip and evap over ice       [W/m2] 
    82    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   qprec_ice      !: heat flux of precip over ice                [J/m3] 
     82   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   qevap_ice      !: heat flux of evap over ice                  [W/m2] 
     83   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   qprec_ice      !: enthalpy of precip over ice                 [J/m3] 
    8384   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   emp_oce        !: evap - precip over ocean                 [kg/m2/s] 
    8485#endif 
    … …  
    144145#endif 
    145146#if defined key_lim3 
    146          &      evap_ice(jpi,jpj,jpl) , devap_ice(jpi,jpj,jpl) , qprec_ice(jpi,jpj) ,  & 
    147          &      qemp_ice(jpi,jpj)     , qemp_oce(jpi,jpj)      ,                       & 
    148          &      qns_oce (jpi,jpj)     , qsr_oce (jpi,jpj)      , emp_oce (jpi,jpj)  ,  & 
     147         &      evap_ice(jpi,jpj,jpl) , devap_ice(jpi,jpj,jpl) , qprec_ice(jpi,jpj) ,   & 
     148         &      qemp_ice(jpi,jpj)     , qevap_ice(jpi,jpj,jpl) , qemp_oce (jpi,jpj) ,   & 
     149         &      qns_oce (jpi,jpj)     , qsr_oce  (jpi,jpj)     , emp_oce (jpi,jpj)  ,   & 
    149150#endif 
    150151         &      emp_ice(jpi,jpj)      ,  STAT= ierr(1) ) 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/SBC/sbcblk_clio.F90

    r6836 r6839  
    684684      qprec_ice(:,:) = rhosn * ( ( MIN( sf(jp_tair)%fnow(:,:,1), rt0_snow ) - rt0 ) * cpic * tmask(:,:,1) - lfus ) 
    685685 
     686      ! --- heat content of evap over ice in W/m2 (to be used in 1D-thermo) --- ! 
     687      DO jl = 1, jpl 
     688         qevap_ice(:,:,jl) = 0._wp ! should be -evap_ice(:,:,jl)*( ( Tice - rt0 ) * cpic * tmask(:,:,1) - lfus ) 
     689                                   ! but then qemp_ice should also include sublimation  
     690      END DO 
     691 
    686692      CALL wrk_dealloc( jpi,jpj, zevap, zsnw )  
    687693#endif 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/SBC/sbcblk_core.F90

    r6836 r6839  
    403403         CALL iom_put( "qsr_oce" ,   qsr  )                 ! output downward solar heat over the ocean 
    404404         CALL iom_put( "qt_oce"  ,   qns+qsr )              ! output total downward heat over the ocean 
     405         tprecip(:,:) = sf(jp_prec)%fnow(:,:,1) * rn_pfac   ! output total precipitation [kg/m2/s] 
     406         sprecip(:,:) = sf(jp_snow)%fnow(:,:,1) * rn_pfac   ! output solid precipitation [kg/m2/s] 
     407         CALL iom_put( 'snowpre', sprecip * 86400. )        ! Snow 
     408         CALL iom_put( 'precip' , tprecip * 86400. )        ! Total precipitation 
    405409      ENDIF 
    406410      ! 
    … …  
    608612      ! --- evaporation --- ! 
    609613      z1_lsub = 1._wp / Lsub 
    610       evap_ice (:,:,:) = qla_ice (:,:,:) * z1_lsub ! sublimation 
    611       devap_ice(:,:,:) = dqla_ice(:,:,:) * z1_lsub 
    612       zevap    (:,:)   = emp(:,:) + tprecip(:,:)   ! evaporation over ocean 
     614      evap_ice (:,:,:) = rn_efac * qla_ice (:,:,:) * z1_lsub    ! sublimation 
     615      devap_ice(:,:,:) = rn_efac * dqla_ice(:,:,:) * z1_lsub    ! d(sublimation)/dT 
     616      zevap    (:,:)   = rn_efac * ( emp(:,:) + tprecip(:,:) )  ! evaporation over ocean 
    613617 
    614618      ! --- evaporation minus precipitation --- ! 
    … …  
    633637      ! --- heat content of precip over ice in J/m3 (to be used in 1D-thermo) --- ! 
    634638      qprec_ice(:,:) = rhosn * ( ( MIN( sf(jp_tair)%fnow(:,:,1), rt0_snow ) - rt0 ) * cpic * tmask(:,:,1) - lfus ) 
     639 
     640      ! --- heat content of evap over ice in W/m2 (to be used in 1D-thermo) --- ! 
     641      DO jl = 1, jpl 
     642         qevap_ice(:,:,jl) = 0._wp ! should be -evap_ice(:,:,jl)*( ( Tice - rt0 ) * cpic * tmask(:,:,1) ) 
     643                                   ! But we do not have Tice => consider it at 0°C => evap=0  
     644      END DO 
    635645 
    636646      CALL wrk_dealloc( jpi,jpj, zevap, zsnw )  

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/SBC/sbccpl.F90

    r6836 r6839  
    10291029         ssu_m(:,:) = frcv(jpr_ocx1)%z3(:,:,1) 
    10301030         ub (:,:,1) = ssu_m(:,:)                             ! will be used in sbcice_lim in the call of lim_sbc_tau 
     1031         un (:,:,1) = ssu_m(:,:)                             ! will be used in sbc_cpl_snd if atmosphere coupling 
    10311032         CALL iom_put( 'ssu_m', ssu_m ) 
    10321033      ENDIF 
    … …  
    10341035         ssv_m(:,:) = frcv(jpr_ocy1)%z3(:,:,1) 
    10351036         vb (:,:,1) = ssv_m(:,:)                             ! will be used in sbcice_lim in the call of lim_sbc_tau 
     1037         vn (:,:,1) = ssv_m(:,:)                             ! will be used in sbc_cpl_snd if atmosphere coupling 
    10361038         CALL iom_put( 'ssv_m', ssv_m ) 
    10371039      ENDIF 
    … …  
    13331335      !!             ***  ROUTINE sbc_cpl_ice_flx  *** 
    13341336      !! 
    1335       !! ** Purpose :   provide the heat and freshwater fluxes of the  
    1336       !!              ocean-ice system. 
     1337      !! ** Purpose :   provide the heat and freshwater fluxes of the ocean-ice system 
    13371338      !! 
    13381339      !! ** Method  :   transform the fields received from the atmosphere into 
    13391340      !!             surface heat and fresh water boundary condition for the  
    13401341      !!             ice-ocean system. The following fields are provided: 
    1341       !!              * total non solar, solar and freshwater fluxes (qns_tot,  
     1342      !!               * total non solar, solar and freshwater fluxes (qns_tot,  
    13421343      !!             qsr_tot and emp_tot) (total means weighted ice-ocean flux) 
    13431344      !!             NB: emp_tot include runoffs and calving. 
    1344       !!              * fluxes over ice (qns_ice, qsr_ice, emp_ice) where 
     1345      !!               * fluxes over ice (qns_ice, qsr_ice, emp_ice) where 
    13451346      !!             emp_ice = sublimation - solid precipitation as liquid 
    13461347      !!             precipitation are re-routed directly to the ocean and  
    1347       !!             runoffs and calving directly enter the ocean. 
    1348       !!              * solid precipitation (sprecip), used to add to qns_tot  
     1348      !!             calving directly enter the ocean (runoffs are read but included in trasbc.F90) 
     1349      !!               * solid precipitation (sprecip), used to add to qns_tot  
    13491350      !!             the heat lost associated to melting solid precipitation 
    13501351      !!             over the ocean fraction. 
    1351       !!       ===>> CAUTION here this changes the net heat flux received from 
    1352       !!             the atmosphere 
    1353       !! 
    1354       !!                  - the fluxes have been separated from the stress as 
    1355       !!                 (a) they are updated at each ice time step compare to 
    1356       !!                 an update at each coupled time step for the stress, and 
    1357       !!                 (b) the conservative computation of the fluxes over the 
    1358       !!                 sea-ice area requires the knowledge of the ice fraction 
    1359       !!                 after the ice advection and before the ice thermodynamics, 
    1360       !!                 so that the stress is updated before the ice dynamics 
    1361       !!                 while the fluxes are updated after it. 
     1352      !!               * heat content of rain, snow and evap can also be provided, 
     1353      !!             otherwise heat flux associated with these mass flux are 
     1354      !!             guessed (qemp_oce, qemp_ice) 
     1355      !! 
     1356      !!             - the fluxes have been separated from the stress as 
     1357      !!               (a) they are updated at each ice time step compare to 
     1358      !!               an update at each coupled time step for the stress, and 
     1359      !!               (b) the conservative computation of the fluxes over the 
     1360      !!               sea-ice area requires the knowledge of the ice fraction 
     1361      !!               after the ice advection and before the ice thermodynamics, 
     1362      !!               so that the stress is updated before the ice dynamics 
     1363      !!               while the fluxes are updated after it. 
     1364      !! 
     1365      !! ** Details 
     1366      !!             qns_tot = pfrld * qns_oce + ( 1 - pfrld ) * qns_ice   => provided 
     1367      !!                     + qemp_oce + qemp_ice                         => recalculated and added up to qns 
     1368      !! 
     1369      !!             qsr_tot = pfrld * qsr_oce + ( 1 - pfrld ) * qsr_ice   => provided 
     1370      !! 
     1371      !!             emp_tot = emp_oce + emp_ice                           => calving is provided and added to emp_tot (and emp_oce) 
     1372      !!                                                                      river runoff (rnf) is provided but not included here 
    13621373      !! 
    13631374      !! ** Action  :   update at each nf_ice time step: 
    13641375      !!                   qns_tot, qsr_tot  non-solar and solar total heat fluxes 
    13651376      !!                   qns_ice, qsr_ice  non-solar and solar heat fluxes over the ice 
    1366       !!                   emp_tot            total evaporation - precipitation(liquid and solid) (-runoff)(-calving) 
    1367       !!                   emp_ice            ice sublimation - solid precipitation over the ice 
    1368       !!                   dqns_ice           d(non-solar heat flux)/d(Temperature) over the ice 
    1369       !!                   sprecip             solid precipitation over the ocean   
     1377      !!                   emp_tot           total evaporation - precipitation(liquid and solid) (-calving) 
     1378      !!                   emp_ice           ice sublimation - solid precipitation over the ice 
     1379      !!                   dqns_ice          d(non-solar heat flux)/d(Temperature) over the ice 
     1380      !!                   sprecip           solid precipitation over the ocean   
    13701381      !!---------------------------------------------------------------------- 
    13711382      REAL(wp), INTENT(in   ), DIMENSION(:,:)   ::   p_frld     ! lead fraction                [0 to 1] 
    … …  
    13761387      ! 
    13771388      INTEGER ::   jl         ! dummy loop index 
    1378       REAL(wp), POINTER, DIMENSION(:,:  ) ::   zcptn, ztmp, zicefr, zmsk 
    1379       REAL(wp), POINTER, DIMENSION(:,:  ) ::   zemp_tot, zemp_ice, zsprecip, ztprecip, zqns_tot, zqsr_tot 
    1380       REAL(wp), POINTER, DIMENSION(:,:,:) ::   zqns_ice, zqsr_ice, zdqns_ice 
    1381       REAL(wp), POINTER, DIMENSION(:,:  ) ::   zevap, zsnw, zqns_oce, zqsr_oce, zqprec_ice, zqemp_oce ! for LIM3 
     1389      REAL(wp), POINTER, DIMENSION(:,:  ) ::   zcptn, ztmp, zicefr, zmsk, zsnw 
     1390      REAL(wp), POINTER, DIMENSION(:,:  ) ::   zemp_tot, zemp_ice, zemp_oce, ztprecip, zsprecip, zevap_oce, zevap_ice, zdevap_ice 
     1391      REAL(wp), POINTER, DIMENSION(:,:  ) ::   zqns_tot, zqns_oce, zqsr_tot, zqsr_oce, zqprec_ice, zqemp_oce, zqemp_ice 
     1392      REAL(wp), POINTER, DIMENSION(:,:,:) ::   zqns_ice, zqsr_ice, zdqns_ice, zqevap_ice 
    13821393      !!---------------------------------------------------------------------- 
    13831394      ! 
    13841395      IF( nn_timing == 1 )  CALL timing_start('sbc_cpl_ice_flx') 
    13851396      ! 
    1386       CALL wrk_alloc( jpi,jpj,     zcptn, ztmp, zicefr, zmsk, zemp_tot, zemp_ice, zsprecip, ztprecip, zqns_tot, zqsr_tot ) 
    1387       CALL wrk_alloc( jpi,jpj,jpl, zqns_ice, zqsr_ice, zdqns_ice ) 
     1397      CALL wrk_alloc( jpi,jpj,     zcptn, ztmp, zicefr, zmsk, zsnw ) 
     1398      CALL wrk_alloc( jpi,jpj,     zemp_tot, zemp_ice, zemp_oce, ztprecip, zsprecip, zevap_oce, zevap_ice, zdevap_ice ) 
     1399      CALL wrk_alloc( jpi,jpj,     zqns_tot, zqns_oce, zqsr_tot, zqsr_oce, zqprec_ice, zqemp_oce, zqemp_ice ) 
     1400      CALL wrk_alloc( jpi,jpj,jpl, zqns_ice, zqsr_ice, zdqns_ice, zqevap_ice ) 
    13881401 
    13891402      IF( ln_mixcpl )   zmsk(:,:) = 1. - xcplmask(:,:,0) 
    … …  
    13921405      ! 
    13931406      !                                                      ! ========================= ! 
    1394       !                                                      !    freshwater budget      !   (emp) 
     1407      !                                                      !    freshwater budget      !   (emp_tot) 
    13951408      !                                                      ! ========================= ! 
    13961409      ! 
    1397       !                                                           ! total Precipitation - total Evaporation (emp_tot) 
    1398       !                                                           ! solid precipitation - sublimation       (emp_ice) 
    1399       !                                                           ! solid Precipitation                     (sprecip) 
    1400       !                                                           ! liquid + solid Precipitation            (tprecip) 
     1410      !                                                           ! solid Precipitation                                (sprecip) 
     1411      !                                                           ! liquid + solid Precipitation                       (tprecip) 
     1412      !                                                           ! total Evaporation - total Precipitation            (emp_tot) 
     1413      !                                                           ! sublimation - solid precipitation (cell average)   (emp_ice) 
    14011414      SELECT CASE( TRIM( sn_rcv_emp%cldes ) ) 
    1402       CASE( 'conservative'  )   ! received fields: jpr_rain, jpr_snow, jpr_ievp, jpr_tevp 
    1403          zsprecip(:,:) = frcv(jpr_snow)%z3(:,:,1)                  ! May need to ensure positive here 
    1404          ztprecip(:,:) = frcv(jpr_rain)%z3(:,:,1) + zsprecip(:,:)  ! May need to ensure positive here 
    1405          zemp_tot(:,:) = frcv(jpr_tevp)%z3(:,:,1) - ztprecip(:,:) 
    1406          zemp_ice(:,:) = frcv(jpr_ievp)%z3(:,:,1) - frcv(jpr_snow)%z3(:,:,1) 
    1407             CALL iom_put( 'rain'         , frcv(jpr_rain)%z3(:,:,1)              )   ! liquid precipitation  
     1415      CASE( 'conservative' )   ! received fields: jpr_rain, jpr_snow, jpr_ievp, jpr_tevp 
     1416         zsprecip(:,:) =   frcv(jpr_snow)%z3(:,:,1)                  ! May need to ensure positive here 
     1417         ztprecip(:,:) =   frcv(jpr_rain)%z3(:,:,1) + zsprecip(:,:)  ! May need to ensure positive here 
     1418         zemp_tot(:,:) =   frcv(jpr_tevp)%z3(:,:,1) - ztprecip(:,:) 
     1419         zemp_ice(:,:) = ( frcv(jpr_ievp)%z3(:,:,1) - frcv(jpr_snow)%z3(:,:,1) ) * zicefr(:,:) 
     1420               CALL iom_put( 'rain'         ,   frcv(jpr_rain)%z3(:,:,1)                                                         )  ! liquid precipitation  
    14081421         IF( iom_use('hflx_rain_cea') )   & 
    1409             CALL iom_put( 'hflx_rain_cea', frcv(jpr_rain)%z3(:,:,1) * zcptn(:,:) )   ! heat flux from liq. precip.  
    1410          IF( iom_use('evap_ao_cea') .OR. iom_use('hflx_evap_cea') )   & 
    1411             ztmp(:,:) = frcv(jpr_tevp)%z3(:,:,1) - frcv(jpr_ievp)%z3(:,:,1) * zicefr(:,:) 
     1422            &  CALL iom_put( 'hflx_rain_cea',   frcv(jpr_rain)%z3(:,:,1) * zcptn(:,:)                                            )  ! heat flux from liq. precip.  
    14121423         IF( iom_use('evap_ao_cea'  ) )   & 
    1413             CALL iom_put( 'evap_ao_cea'  , ztmp                   )   ! ice-free oce evap (cell average) 
     1424            &  CALL iom_put( 'evap_ao_cea'  ,   frcv(jpr_tevp)%z3(:,:,1) - frcv(jpr_ievp)%z3(:,:,1) * zicefr(:,:)                )  ! ice-free oce evap (cell average) 
    14141425         IF( iom_use('hflx_evap_cea') )   & 
    1415             CALL iom_put( 'hflx_evap_cea', ztmp(:,:) * zcptn(:,:) )   ! heat flux from from evap (cell average) 
    1416       CASE( 'oce and ice'   )   ! received fields: jpr_sbpr, jpr_semp, jpr_oemp, jpr_ievp 
     1426            &  CALL iom_put( 'hflx_evap_cea', ( frcv(jpr_tevp)%z3(:,:,1) - frcv(jpr_ievp)%z3(:,:,1) * zicefr(:,:) ) * zcptn(:,:) )  ! heat flux from from evap (cell average) 
     1427      CASE( 'oce and ice' )   ! received fields: jpr_sbpr, jpr_semp, jpr_oemp, jpr_ievp 
    14171428         zemp_tot(:,:) = p_frld(:,:) * frcv(jpr_oemp)%z3(:,:,1) + zicefr(:,:) * frcv(jpr_sbpr)%z3(:,:,1) 
    1418          zemp_ice(:,:) = frcv(jpr_semp)%z3(:,:,1) 
     1429         zemp_ice(:,:) = frcv(jpr_semp)%z3(:,:,1) * zicefr(:,:) 
    14191430         zsprecip(:,:) = frcv(jpr_ievp)%z3(:,:,1) - frcv(jpr_semp)%z3(:,:,1) 
    14201431         ztprecip(:,:) = frcv(jpr_semp)%z3(:,:,1) - frcv(jpr_sbpr)%z3(:,:,1) + zsprecip(:,:) 
    14211432      END SELECT 
    14221433 
    1423       IF( iom_use('subl_ai_cea') )   & 
    1424          CALL iom_put( 'subl_ai_cea', frcv(jpr_ievp)%z3(:,:,1) * zicefr(:,:) )   ! Sublimation over sea-ice         (cell average) 
    1425       !    
    1426       !                                                           ! runoffs and calving (put in emp_tot) 
     1434#if defined key_lim3 
     1435      ! zsnw = snow fraction over ice after wind blowing 
     1436      zsnw(:,:) = 0._wp  ;  CALL lim_thd_snwblow( p_frld, zsnw ) 
     1437       
     1438      ! --- evaporation minus precipitation corrected (because of wind blowing on snow) --- ! 
     1439      zemp_ice(:,:) = zemp_ice(:,:) + zsprecip(:,:) * ( zicefr(:,:) - zsnw(:,:) )  ! emp_ice = A * sublimation - zsnw * sprecip 
     1440      zemp_oce(:,:) = zemp_tot(:,:) - zemp_ice(:,:)                                ! emp_oce = emp_tot - emp_ice 
     1441 
     1442      ! --- evaporation over ocean (used later for qemp) --- ! 
     1443      zevap_oce(:,:) = frcv(jpr_tevp)%z3(:,:,1) - frcv(jpr_ievp)%z3(:,:,1) * zicefr(:,:) 
     1444 
     1445      ! --- evaporation over ice (kg/m2/s) --- ! 
     1446      zevap_ice(:,:) = frcv(jpr_ievp)%z3(:,:,1) 
     1447      ! since the sensitivity of evap to temperature (devap/dT) is not prescribed by the atmosphere, we set it to 0 
     1448      ! therefore, sublimation is not redistributed over the ice categories in case no subgrid scale fluxes are provided by atm. 
     1449      zdevap_ice(:,:) = 0._wp 
     1450       
     1451      ! --- runoffs (included in emp later on) --- ! 
     1452      IF( srcv(jpr_rnf)%laction )   rnf(:,:) = frcv(jpr_rnf)%z3(:,:,1) 
     1453 
     1454      ! --- calving (put in emp_tot and emp_oce) --- ! 
     1455      IF( srcv(jpr_cal)%laction ) THEN  
     1456         zemp_tot(:,:) = zemp_tot(:,:) - frcv(jpr_cal)%z3(:,:,1) 
     1457         zemp_oce(:,:) = zemp_oce(:,:) - frcv(jpr_cal)%z3(:,:,1) 
     1458         CALL iom_put( 'calving_cea', frcv(jpr_cal)%z3(:,:,1) ) 
     1459      ENDIF 
     1460 
     1461      IF( ln_mixcpl ) THEN 
     1462         emp_tot(:,:) = emp_tot(:,:) * xcplmask(:,:,0) + zemp_tot(:,:) * zmsk(:,:) 
     1463         emp_ice(:,:) = emp_ice(:,:) * xcplmask(:,:,0) + zemp_ice(:,:) * zmsk(:,:) 
     1464         emp_oce(:,:) = emp_oce(:,:) * xcplmask(:,:,0) + zemp_oce(:,:) * zmsk(:,:) 
     1465         sprecip(:,:) = sprecip(:,:) * xcplmask(:,:,0) + zsprecip(:,:) * zmsk(:,:) 
     1466         tprecip(:,:) = tprecip(:,:) * xcplmask(:,:,0) + ztprecip(:,:) * zmsk(:,:) 
     1467         DO jl=1,jpl 
     1468            evap_ice (:,:,jl) = evap_ice (:,:,jl) * xcplmask(:,:,0) + zevap_ice (:,:) * zmsk(:,:) 
     1469            devap_ice(:,:,jl) = devap_ice(:,:,jl) * xcplmask(:,:,0) + zdevap_ice(:,:) * zmsk(:,:) 
     1470         ENDDO 
     1471      ELSE 
     1472         emp_tot(:,:) =         zemp_tot(:,:) 
     1473         emp_ice(:,:) =         zemp_ice(:,:) 
     1474         emp_oce(:,:) =         zemp_oce(:,:)      
     1475         sprecip(:,:) =         zsprecip(:,:) 
     1476         tprecip(:,:) =         ztprecip(:,:) 
     1477         DO jl=1,jpl 
     1478            evap_ice (:,:,jl) = zevap_ice (:,:) 
     1479            devap_ice(:,:,jl) = zdevap_ice(:,:) 
     1480         ENDDO 
     1481      ENDIF 
     1482 
     1483      IF( iom_use('subl_ai_cea') )   CALL iom_put( 'subl_ai_cea', zevap_ice(:,:) * zicefr(:,:)         )  ! Sublimation over sea-ice (cell average) 
     1484                                     CALL iom_put( 'snowpre'    , sprecip(:,:)                         )  ! Snow 
     1485      IF( iom_use('snow_ao_cea') )   CALL iom_put( 'snow_ao_cea', sprecip(:,:) * ( 1._wp - zsnw(:,:) ) )  ! Snow over ice-free ocean  (cell average) 
     1486      IF( iom_use('snow_ai_cea') )   CALL iom_put( 'snow_ai_cea', sprecip(:,:) *           zsnw(:,:)   )  ! Snow over sea-ice         (cell average) 
     1487#else 
     1488      ! runoffs and calving (put in emp_tot) 
    14271489      IF( srcv(jpr_rnf)%laction )   rnf(:,:) = frcv(jpr_rnf)%z3(:,:,1) 
    14281490      IF( srcv(jpr_cal)%laction ) THEN  
    … …  
    14431505      ENDIF 
    14441506 
    1445          CALL iom_put( 'snowpre'    , sprecip                                )   ! Snow 
    1446       IF( iom_use('snow_ao_cea') )   & 
    1447          CALL iom_put( 'snow_ao_cea', sprecip(:,:) * p_frld(:,:)             )   ! Snow        over ice-free ocean  (cell average) 
    1448       IF( iom_use('snow_ai_cea') )   & 
    1449          CALL iom_put( 'snow_ai_cea', sprecip(:,:) * zicefr(:,:)             )   ! Snow        over sea-ice         (cell average) 
     1507      IF( iom_use('subl_ai_cea') )  CALL iom_put( 'subl_ai_cea', frcv(jpr_ievp)%z3(:,:,1) * zicefr(:,:) )  ! Sublimation over sea-ice (cell average) 
     1508                                    CALL iom_put( 'snowpre'    , sprecip(:,:)               )   ! Snow 
     1509      IF( iom_use('snow_ao_cea') )  CALL iom_put( 'snow_ao_cea', sprecip(:,:) * p_frld(:,:) )   ! Snow over ice-free ocean  (cell average) 
     1510      IF( iom_use('snow_ai_cea') )  CALL iom_put( 'snow_ai_cea', sprecip(:,:) * zicefr(:,:) )   ! Snow over sea-ice         (cell average) 
     1511#endif 
    14501512 
    14511513      !                                                      ! ========================= ! 
    14521514      SELECT CASE( TRIM( sn_rcv_qns%cldes ) )                !   non solar heat fluxes   !   (qns) 
    14531515      !                                                      ! ========================= ! 
    1454       CASE( 'oce only' )                                     ! the required field is directly provided 
    1455          zqns_tot(:,:  ) = frcv(jpr_qnsoce)%z3(:,:,1) 
    1456       CASE( 'conservative' )                                      ! the required fields are directly provided 
    1457          zqns_tot(:,:  ) = frcv(jpr_qnsmix)%z3(:,:,1) 
     1516      CASE( 'oce only' )         ! the required field is directly provided 
     1517         zqns_tot(:,:) = frcv(jpr_qnsoce)%z3(:,:,1) 
     1518      CASE( 'conservative' )     ! the required fields are directly provided 
     1519         zqns_tot(:,:) = frcv(jpr_qnsmix)%z3(:,:,1) 
    14581520         IF ( TRIM(sn_rcv_qns%clcat) == 'yes' ) THEN 
    14591521            zqns_ice(:,:,1:jpl) = frcv(jpr_qnsice)%z3(:,:,1:jpl) 
    14601522         ELSE 
    1461             ! Set all category values equal for the moment 
    14621523            DO jl=1,jpl 
    1463                zqns_ice(:,:,jl) = frcv(jpr_qnsice)%z3(:,:,1) 
     1524               zqns_ice(:,:,jl) = frcv(jpr_qnsice)%z3(:,:,1) ! Set all category values equal 
    14641525            ENDDO 
    14651526         ENDIF 
    1466       CASE( 'oce and ice' )       ! the total flux is computed from ocean and ice fluxes 
    1467          zqns_tot(:,:  ) =  p_frld(:,:) * frcv(jpr_qnsoce)%z3(:,:,1) 
     1527      CASE( 'oce and ice' )      ! the total flux is computed from ocean and ice fluxes 
     1528         zqns_tot(:,:) =  p_frld(:,:) * frcv(jpr_qnsoce)%z3(:,:,1) 
    14681529         IF ( TRIM(sn_rcv_qns%clcat) == 'yes' ) THEN 
    14691530            DO jl=1,jpl 
    … …  
    14721533            ENDDO 
    14731534         ELSE 
    1474             qns_tot(:,:   ) = qns_tot(:,:) + zicefr(:,:) * frcv(jpr_qnsice)%z3(:,:,1) 
     1535            qns_tot(:,:) = qns_tot(:,:) + zicefr(:,:) * frcv(jpr_qnsice)%z3(:,:,1) 
    14751536            DO jl=1,jpl 
    14761537               zqns_tot(:,:   ) = zqns_tot(:,:) + zicefr(:,:) * frcv(jpr_qnsice)%z3(:,:,1) 
    … …  
    14781539            ENDDO 
    14791540         ENDIF 
    1480       CASE( 'mixed oce-ice' )     ! the ice flux is cumputed from the total flux, the SST and ice informations 
     1541      CASE( 'mixed oce-ice' )    ! the ice flux is cumputed from the total flux, the SST and ice informations 
    14811542! ** NEED TO SORT OUT HOW THIS SHOULD WORK IN THE MULTI-CATEGORY CASE - CURRENTLY NOT ALLOWED WHEN INTERFACE INITIALISED ** 
    14821543         zqns_tot(:,:  ) = frcv(jpr_qnsmix)%z3(:,:,1) 
    14831544         zqns_ice(:,:,1) = frcv(jpr_qnsmix)%z3(:,:,1)    & 
    14841545            &            + frcv(jpr_dqnsdt)%z3(:,:,1) * ( pist(:,:,1) - ( (rt0 + psst(:,:  ) ) * p_frld(:,:)   & 
    1485             &                                                   +          pist(:,:,1)  * zicefr(:,:) ) ) 
     1546            &                                           + pist(:,:,1) * zicefr(:,:) ) ) 
    14861547      END SELECT 
    14871548!!gm 
    … …  
    14931554!! similar job should be done for snow and precipitation temperature 
    14941555      !                                      
    1495       IF( srcv(jpr_cal)%laction ) THEN                            ! Iceberg melting  
    1496          ztmp(:,:) = frcv(jpr_cal)%z3(:,:,1) * lfus               ! add the latent heat of iceberg melting  
    1497          zqns_tot(:,:) = zqns_tot(:,:) - ztmp(:,:) 
    1498          IF( iom_use('hflx_cal_cea') )   & 
    1499             CALL iom_put( 'hflx_cal_cea', ztmp + frcv(jpr_cal)%z3(:,:,1) * zcptn(:,:) )   ! heat flux from calving 
    1500       ENDIF 
    1501  
    1502       ztmp(:,:) = p_frld(:,:) * zsprecip(:,:) * lfus 
    1503       IF( iom_use('hflx_snow_cea') )    CALL iom_put( 'hflx_snow_cea', ztmp + sprecip(:,:) * zcptn(:,:) )   ! heat flux from snow (cell average) 
    1504  
    1505 #if defined key_lim3 
    1506       CALL wrk_alloc( jpi,jpj, zevap, zsnw, zqns_oce, zqprec_ice, zqemp_oce )  
    1507  
    1508       ! --- evaporation --- ! 
    1509       ! clem: evap_ice is set to 0 for LIM3 since we still do not know what to do with sublimation 
    1510       ! the problem is: the atm. imposes both mass evaporation and heat removed from the snow/ice 
    1511       !                 but it is incoherent WITH the ice model   
    1512       DO jl=1,jpl 
    1513          evap_ice(:,:,jl) = 0._wp  ! should be: frcv(jpr_ievp)%z3(:,:,1) 
    1514       ENDDO 
    1515       zevap(:,:) = zemp_tot(:,:) + ztprecip(:,:) ! evaporation over ocean 
    1516  
    1517       ! --- evaporation minus precipitation --- ! 
    1518       emp_oce(:,:) = emp_tot(:,:) - emp_ice(:,:) 
    1519  
     1556      IF( srcv(jpr_cal)%laction ) THEN   ! Iceberg melting  
     1557         zqns_tot(:,:) = zqns_tot(:,:) - frcv(jpr_cal)%z3(:,:,1) * lfus  ! add the latent heat of iceberg melting 
     1558                                                                         ! we suppose it melts at 0deg, though it should be temp. of surrounding ocean 
     1559         IF( iom_use('hflx_cal_cea') )   CALL iom_put( 'hflx_cal_cea', - frcv(jpr_cal)%z3(:,:,1) * lfus )   ! heat flux from calving 
     1560      ENDIF 
     1561 
     1562#if defined key_lim3       
    15201563      ! --- non solar flux over ocean --- ! 
    15211564      !         note: p_frld cannot be = 0 since we limit the ice concentration to amax 
    … …  
    15231566      WHERE( p_frld /= 0._wp )  zqns_oce(:,:) = ( zqns_tot(:,:) - SUM( a_i * zqns_ice, dim=3 ) ) / p_frld(:,:) 
    15241567 
    1525       ! --- heat flux associated with emp --- ! 
    1526       zsnw(:,:) = 0._wp 
    1527       CALL lim_thd_snwblow( p_frld, zsnw )  ! snow distribution over ice after wind blowing 
    1528       zqemp_oce(:,:) = -      zevap(:,:)                   * p_frld(:,:)      *   zcptn(:,:)   &      ! evap 
    1529          &             + ( ztprecip(:,:) - zsprecip(:,:) )                    *   zcptn(:,:)   &      ! liquid precip 
    1530          &             +   zsprecip(:,:)                   * ( 1._wp - zsnw ) * ( zcptn(:,:) - lfus ) ! solid precip over ocean 
    1531       qemp_ice(:,:)  = -   frcv(jpr_ievp)%z3(:,:,1)        * zicefr(:,:)      *   zcptn(:,:)   &      ! ice evap 
    1532          &             +   zsprecip(:,:)                   * zsnw             * ( zcptn(:,:) - lfus ) ! solid precip over ice 
    1533  
    1534       ! --- heat content of precip over ice in J/m3 (to be used in 1D-thermo) --- ! 
     1568      ! --- heat flux associated with emp (W/m2) --- ! 
     1569      zqemp_oce(:,:) = -  zevap_oce(:,:)                                      *   zcptn(:,:)   &       ! evap 
     1570         &             + ( ztprecip(:,:) - zsprecip(:,:) )                    *   zcptn(:,:)   &       ! liquid precip 
     1571         &             +   zsprecip(:,:)                   * ( 1._wp - zsnw ) * ( zcptn(:,:) - lfus )  ! solid precip over ocean + snow melting 
     1572!      zqemp_ice(:,:) = -   frcv(jpr_ievp)%z3(:,:,1)        * zicefr(:,:)      *   zcptn(:,:)   &      ! ice evap 
     1573!         &             +   zsprecip(:,:)                   * zsnw             * ( zcptn(:,:) - lfus ) ! solid precip over ice 
     1574      zqemp_ice(:,:) =      zsprecip(:,:)                   * zsnw             * ( zcptn(:,:) - lfus ) ! solid precip over ice (only) 
     1575                                                                                                       ! qevap_ice=0 since we consider Tice=0degC 
     1576       
     1577      ! --- enthalpy of snow precip over ice in J/m3 (to be used in 1D-thermo) --- ! 
    15351578      zqprec_ice(:,:) = rhosn * ( zcptn(:,:) - lfus ) 
    15361579 
    1537       ! --- total non solar flux --- ! 
    1538       zqns_tot(:,:) = zqns_tot(:,:) + qemp_ice(:,:) + zqemp_oce(:,:) 
     1580      ! --- heat content of evap over ice in W/m2 (to be used in 1D-thermo) --- ! 
     1581      DO jl = 1, jpl 
     1582         zqevap_ice(:,:,jl) = 0._wp ! should be -evap * ( ( Tice - rt0 ) * cpic ) but we do not have Tice, so we consider Tice=0degC 
     1583      END DO 
     1584 
     1585      ! --- total non solar flux (including evap/precip) --- ! 
     1586      zqns_tot(:,:) = zqns_tot(:,:) + zqemp_ice(:,:) + zqemp_oce(:,:) 
    15391587 
    15401588      ! --- in case both coupled/forced are active, we must mix values --- !  
    … …  
    15431591         qns_oce(:,:) = qns_oce(:,:) * xcplmask(:,:,0) + zqns_oce(:,:)* zmsk(:,:) 
    15441592         DO jl=1,jpl 
    1545             qns_ice(:,:,jl) = qns_ice(:,:,jl) * xcplmask(:,:,0) +  zqns_ice(:,:,jl)* zmsk(:,:) 
     1593            qns_ice  (:,:,jl) = qns_ice  (:,:,jl) * xcplmask(:,:,0) +  zqns_ice  (:,:,jl)* zmsk(:,:) 
     1594            qevap_ice(:,:,jl) = qevap_ice(:,:,jl) * xcplmask(:,:,0) +  zqevap_ice(:,:,jl)* zmsk(:,:) 
    15461595         ENDDO 
    15471596         qprec_ice(:,:) = qprec_ice(:,:) * xcplmask(:,:,0) + zqprec_ice(:,:)* zmsk(:,:) 
    15481597         qemp_oce (:,:) =  qemp_oce(:,:) * xcplmask(:,:,0) +  zqemp_oce(:,:)* zmsk(:,:) 
    1549 !!clem         evap_ice(:,:) = evap_ice(:,:) * xcplmask(:,:,0) 
     1598         qemp_ice (:,:) =  qemp_ice(:,:) * xcplmask(:,:,0) +  zqemp_ice(:,:)* zmsk(:,:) 
    15501599      ELSE 
    15511600         qns_tot  (:,:  ) = zqns_tot  (:,:  ) 
    15521601         qns_oce  (:,:  ) = zqns_oce  (:,:  ) 
    15531602         qns_ice  (:,:,:) = zqns_ice  (:,:,:) 
    1554          qprec_ice(:,:)   = zqprec_ice(:,:) 
    1555          qemp_oce (:,:)   = zqemp_oce (:,:) 
    1556       ENDIF 
    1557  
    1558       CALL wrk_dealloc( jpi,jpj, zevap, zsnw, zqns_oce, zqprec_ice, zqemp_oce )  
     1603         qevap_ice(:,:,:) = zqevap_ice(:,:,:) 
     1604         qprec_ice(:,:  ) = zqprec_ice(:,:  ) 
     1605         qemp_oce (:,:  ) = zqemp_oce (:,:  ) 
     1606         qemp_ice (:,:  ) = zqemp_ice (:,:  ) 
     1607      ENDIF 
     1608 
     1609      !! clem: we should output qemp_oce and qemp_ice (at least) 
     1610      IF( iom_use('hflx_snow_cea') )   CALL iom_put( 'hflx_snow_cea', sprecip(:,:) * ( zcptn(:,:) - Lfus ) )   ! heat flux from snow (cell average) 
     1611      !! these diags are not outputed yet 
     1612!!      IF( iom_use('hflx_rain_cea') )   CALL iom_put( 'hflx_rain_cea', ( tprecip(:,:) - sprecip(:,:) ) * zcptn(:,:) )   ! heat flux from rain (cell average) 
     1613!!      IF( iom_use('hflx_snow_ao_cea') ) CALL iom_put( 'hflx_snow_ao_cea', sprecip(:,:) * ( zcptn(:,:) - Lfus ) * (1._wp - zsnw(:,:)) ) ! heat flux from snow (cell average) 
     1614!!      IF( iom_use('hflx_snow_ai_cea') ) CALL iom_put( 'hflx_snow_ai_cea', sprecip(:,:) * ( zcptn(:,:) - Lfus ) * zsnw(:,:) ) ! heat flux from snow (cell average) 
     1615 
    15591616#else 
    1560  
    15611617      ! clem: this formulation is certainly wrong... but better than it was... 
    15621618      zqns_tot(:,:) = zqns_tot(:,:)                       &            ! zqns_tot update over free ocean with: 
    15631619         &          - ztmp(:,:)                           &            ! remove the latent heat flux of solid precip. melting 
    15641620         &          - (  zemp_tot(:,:)                    &            ! remove the heat content of mass flux (assumed to be at SST) 
    1565          &             - zemp_ice(:,:) * zicefr(:,:)  ) * zcptn(:,:)  
     1621         &             - zemp_ice(:,:) ) * zcptn(:,:)  
    15661622 
    15671623     IF( ln_mixcpl ) THEN 
    … …  
    15751631         qns_ice(:,:,:) = zqns_ice(:,:,:) 
    15761632      ENDIF 
    1577  
    15781633#endif 
    15791634 
    … …  
    16261681 
    16271682#if defined key_lim3 
    1628       CALL wrk_alloc( jpi,jpj, zqsr_oce )  
    16291683      ! --- solar flux over ocean --- ! 
    16301684      !         note: p_frld cannot be = 0 since we limit the ice concentration to amax 
    … …  
    16341688      IF( ln_mixcpl ) THEN   ;   qsr_oce(:,:) = qsr_oce(:,:) * xcplmask(:,:,0) +  zqsr_oce(:,:)* zmsk(:,:) 
    16351689      ELSE                   ;   qsr_oce(:,:) = zqsr_oce(:,:)   ;   ENDIF 
    1636  
    1637       CALL wrk_dealloc( jpi,jpj, zqsr_oce )  
    16381690#endif 
    16391691 
    … …  
    16861738      fr2_i0(:,:) = ( 0.82 * ( 1.0 - cldf_ice ) + 0.65 * cldf_ice ) 
    16871739 
    1688       CALL wrk_dealloc( jpi,jpj,     zcptn, ztmp, zicefr, zmsk, zemp_tot, zemp_ice, zsprecip, ztprecip, zqns_tot, zqsr_tot ) 
    1689       CALL wrk_dealloc( jpi,jpj,jpl, zqns_ice, zqsr_ice, zdqns_ice ) 
     1740      CALL wrk_dealloc( jpi,jpj,     zcptn, ztmp, zicefr, zmsk, zsnw ) 
     1741      CALL wrk_dealloc( jpi,jpj,     zemp_tot, zemp_ice, zemp_oce, ztprecip, zsprecip, zevap_oce, zevap_ice, zdevap_ice ) 
     1742      CALL wrk_dealloc( jpi,jpj,     zqns_tot, zqns_oce, zqsr_tot, zqsr_oce, zqprec_ice, zqemp_oce, zqemp_ice ) 
     1743      CALL wrk_dealloc( jpi,jpj,jpl, zqns_ice, zqsr_ice, zdqns_ice, zqevap_ice ) 
    16901744      ! 
    16911745      IF( nn_timing == 1 )  CALL timing_stop('sbc_cpl_ice_flx') 
    … …  
    17431797                     ztmp3(:,:,1) = SUM( tn_ice * a_i, dim=3 ) / SUM( a_i, dim=3 ) 
    17441798                  ELSEWHERE 
    1745                      ztmp3(:,:,1) = rt0 ! TODO: Is freezing point a good default? (Maybe SST is better?) 
     1799                     ztmp3(:,:,1) = rt0 
    17461800                  END WHERE 
    17471801               CASE default   ;   CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_temp%clcat' ) 
    … …  
    17741828      !                                                      ! ------------------------- ! 
    17751829      IF( ssnd(jps_albice)%laction ) THEN                         ! ice  
    1776          SELECT CASE( sn_snd_alb%cldes ) 
    1777          CASE( 'ice'          )   ; ztmp3(:,:,1:jpl) = alb_ice(:,:,1:jpl) 
    1778          CASE( 'weighted ice' )   ; ztmp3(:,:,1:jpl) = alb_ice(:,:,1:jpl) * a_i(:,:,1:jpl) 
    1779          CASE default             ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_alb%cldes' ) 
     1830          SELECT CASE( sn_snd_alb%cldes ) 
     1831          CASE( 'ice' ) 
     1832             SELECT CASE( sn_snd_alb%clcat ) 
     1833             CASE( 'yes' )    
     1834                ztmp3(:,:,1:jpl) = alb_ice(:,:,1:jpl) 
     1835             CASE( 'no' ) 
     1836                WHERE( SUM( a_i, dim=3 ) /= 0. ) 
     1837                   ztmp1(:,:) = SUM( alb_ice (:,:,1:jpl) * a_i(:,:,1:jpl), dim=3 ) / SUM( a_i(:,:,1:jpl), dim=3 ) 
     1838                ELSEWHERE 
     1839                   ztmp1(:,:) = albedo_oce_mix(:,:) 
     1840                END WHERE 
     1841             CASE default   ;   CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_alb%clcat' ) 
     1842             END SELECT 
     1843          CASE( 'weighted ice' )   ; 
     1844             SELECT CASE( sn_snd_alb%clcat ) 
     1845             CASE( 'yes' )    
     1846                ztmp3(:,:,1:jpl) =  alb_ice(:,:,1:jpl) * a_i(:,:,1:jpl) 
     1847             CASE( 'no' ) 
     1848                WHERE( fr_i (:,:) > 0. ) 
     1849                   ztmp1(:,:) = SUM (  alb_ice(:,:,1:jpl) * a_i(:,:,1:jpl), dim=3 ) 
     1850                ELSEWHERE 
     1851                   ztmp1(:,:) = 0. 
     1852                END WHERE 
     1853             CASE default   ;   CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_ice%clcat' ) 
     1854             END SELECT 
     1855          CASE default      ;   CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_alb%cldes' ) 
    17801856         END SELECT 
    1781          CALL cpl_snd( jps_albice, isec, ztmp3, info ) 
    1782       ENDIF 
     1857 
     1858         SELECT CASE( sn_snd_alb%clcat ) 
     1859            CASE( 'yes' )    
     1860               CALL cpl_snd( jps_albice, isec, ztmp3, info )      !-> MV this has never been checked in coupled mode 
     1861            CASE( 'no'  )    
     1862               CALL cpl_snd( jps_albice, isec, RESHAPE ( ztmp1, (/jpi,jpj,1/) ), info )  
     1863         END SELECT 
     1864      ENDIF 
     1865 
    17831866      IF( ssnd(jps_albmix)%laction ) THEN                         ! mixed ice-ocean 
    17841867         ztmp1(:,:) = albedo_oce_mix(:,:) * zfr_l(:,:) 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/SBC/sbcfwb.F90

    r6836 r6839  
    108108         ! 
    109109         IF( MOD( kt-1, kn_fsbc ) == 0 ) THEN 
    110             z_fwf = glob_sum( e1e2t(:,:) * ( emp(:,:) - rnf(:,:) + rdivisf * fwfisf(:,:) - snwice_fmass(:,:) ) ) / area   ! sum over the global domain 
     110            z_fwf = glob_sum( e1e2t(:,:) * ( emp(:,:) - rnf(:,:) + fwfisf(:,:) - snwice_fmass(:,:) ) ) / area   ! sum over the global domain 
    111111            zcoef = z_fwf * rcp 
    112112            emp(:,:) = emp(:,:) - z_fwf              * tmask(:,:,1) 
    … …  
    162162            zsurf_pos = glob_sum( e1e2t(:,:)*ztmsk_pos(:,:) ) 
    163163            !                                                  ! fwf global mean (excluding ocean to ice/snow exchanges)  
    164             z_fwf     = glob_sum( e1e2t(:,:) * ( emp(:,:) - rnf(:,:) + rdivisf * fwfisf(:,:) - snwice_fmass(:,:) ) ) / area 
     164            z_fwf     = glob_sum( e1e2t(:,:) * ( emp(:,:) - rnf(:,:) + fwfisf(:,:) - snwice_fmass(:,:) ) ) / area 
    165165            !             
    166166            IF( z_fwf < 0._wp ) THEN         ! spread out over >0 erp area to increase evaporation 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/SBC/sbcice_if.F90

    r6836 r6839  
    103103                                 ! ( d rho / dt ) / ( d rho / ds )      ( s = 34, t = -1.8 ) 
    104104          
    105          fr_i(:,:) = eos_fzp( sss_m ) * tmask(:,:,1)      ! sea surface freezing temperature [Celcius] 
     105         CALL eos_fzp( sss_m(:,:), fr_i(:,:) )       ! sea surface freezing temperature [Celcius] 
     106         fr_i(:,:) = fr_i(:,:) * tmask(:,:,1) 
    106107 
    107108         IF( ln_cpl )   a_i(:,:,1) = fr_i(:,:)          

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/SBC/sbcice_lim.F90

    r6836 r6839  
    110110      INTEGER  ::   jl                 ! dummy loop index 
    111111      REAL(wp), POINTER, DIMENSION(:,:,:)   ::   zalb_os, zalb_cs  ! ice albedo under overcast/clear sky 
    112       REAL(wp), POINTER, DIMENSION(:,:,:)   ::   zalb_ice          ! mean ice albedo (for coupled) 
    113112      REAL(wp), POINTER, DIMENSION(:,:  )   ::   zutau_ice, zvtau_ice  
    114113      !!---------------------------------------------------------------------- 
    … …  
    126125          
    127126         ! masked sea surface freezing temperature [Kelvin] (set to rt0 over land) 
    128          t_bo(:,:) = ( eos_fzp( sss_m ) + rt0 ) * tmask(:,:,1) + rt0 * ( 1._wp - tmask(:,:,1) )   
    129           
     127         CALL eos_fzp( sss_m(:,:) , t_bo(:,:) ) 
     128         t_bo(:,:) = ( t_bo(:,:) + rt0 ) * tmask(:,:,1) + rt0 * ( 1._wp - tmask(:,:,1) ) 
     129           
    130130         ! Mask sea ice surface temperature (set to rt0 over land) 
    131131         DO jl = 1, jpl 
    … …  
    196196         ! fr1_i0  , fr2_i0   : 1sr & 2nd fraction of qsr penetration in ice             [%] 
    197197         !---------------------------------------------------------------------------------------- 
    198          CALL wrk_alloc( jpi,jpj,jpl, zalb_os, zalb_cs, zalb_ice ) 
     198         CALL wrk_alloc( jpi,jpj,jpl, zalb_os, zalb_cs ) 
    199199         CALL albedo_ice( t_su, ht_i, ht_s, zalb_cs, zalb_os ) ! cloud-sky and overcast-sky ice albedos 
    200200 
    … …  
    202202         CASE( jp_clio )                                       ! CLIO bulk formulation 
    203203            ! In CLIO the cloud fraction is read in the climatology and the all-sky albedo  
    204             ! (zalb_ice) is computed within the bulk routine 
    205             CALL blk_ice_clio_flx( t_su, zalb_cs, zalb_os, zalb_ice ) 
    206             IF( ln_mixcpl      ) CALL sbc_cpl_ice_flx( p_frld=pfrld, palbi=zalb_ice, psst=sst_m, pist=t_su ) 
    207             IF( nn_limflx /= 2 ) CALL ice_lim_flx( t_su, zalb_ice, qns_ice, qsr_ice, dqns_ice, evap_ice, devap_ice, nn_limflx ) 
     204            ! (alb_ice) is computed within the bulk routine 
     205                                 CALL blk_ice_clio_flx( t_su, zalb_cs, zalb_os, alb_ice ) 
     206            IF( ln_mixcpl      ) CALL sbc_cpl_ice_flx( p_frld=pfrld, palbi=alb_ice, psst=sst_m, pist=t_su ) 
     207            IF( nn_limflx /= 2 ) CALL ice_lim_flx( t_su, alb_ice, qns_ice, qsr_ice, dqns_ice, evap_ice, devap_ice, nn_limflx ) 
    208208         CASE( jp_core )                                       ! CORE bulk formulation 
    209209            ! albedo depends on cloud fraction because of non-linear spectral effects 
    210             zalb_ice(:,:,:) = ( 1. - cldf_ice ) * zalb_cs(:,:,:) + cldf_ice * zalb_os(:,:,:) 
    211             CALL blk_ice_core_flx( t_su, zalb_ice ) 
    212             IF( ln_mixcpl      ) CALL sbc_cpl_ice_flx( p_frld=pfrld, palbi=zalb_ice, psst=sst_m, pist=t_su ) 
    213             IF( nn_limflx /= 2 ) CALL ice_lim_flx( t_su, zalb_ice, qns_ice, qsr_ice, dqns_ice, evap_ice, devap_ice, nn_limflx ) 
     210            alb_ice(:,:,:) = ( 1. - cldf_ice ) * zalb_cs(:,:,:) + cldf_ice * zalb_os(:,:,:) 
     211                                 CALL blk_ice_core_flx( t_su, alb_ice ) 
     212            IF( ln_mixcpl      ) CALL sbc_cpl_ice_flx( p_frld=pfrld, palbi=alb_ice, psst=sst_m, pist=t_su ) 
     213            IF( nn_limflx /= 2 ) CALL ice_lim_flx( t_su, alb_ice, qns_ice, qsr_ice, dqns_ice, evap_ice, devap_ice, nn_limflx ) 
    214214         CASE ( jp_purecpl ) 
    215215            ! albedo depends on cloud fraction because of non-linear spectral effects 
    216             zalb_ice(:,:,:) = ( 1. - cldf_ice ) * zalb_cs(:,:,:) + cldf_ice * zalb_os(:,:,:) 
    217                                  CALL sbc_cpl_ice_flx( p_frld=pfrld, palbi=zalb_ice, psst=sst_m, pist=t_su ) 
    218             ! clem: evap_ice is forced to 0 in coupled mode for now  
    219             !       but it needs to be changed (along with modif in limthd_dh) once heat flux from evap will be avail. from atm. models 
    220             evap_ice  (:,:,:) = 0._wp   ;   devap_ice (:,:,:) = 0._wp 
    221             IF( nn_limflx == 2 ) CALL ice_lim_flx( t_su, zalb_ice, qns_ice, qsr_ice, dqns_ice, evap_ice, devap_ice, nn_limflx ) 
     216            alb_ice(:,:,:) = ( 1. - cldf_ice ) * zalb_cs(:,:,:) + cldf_ice * zalb_os(:,:,:) 
     217                                 CALL sbc_cpl_ice_flx( p_frld=pfrld, palbi=alb_ice, psst=sst_m, pist=t_su ) 
     218            IF( nn_limflx == 2 ) CALL ice_lim_flx( t_su, alb_ice, qns_ice, qsr_ice, dqns_ice, evap_ice, devap_ice, nn_limflx ) 
    222219         END SELECT 
    223          CALL wrk_dealloc( jpi,jpj,jpl, zalb_os, zalb_cs, zalb_ice ) 
     220         CALL wrk_dealloc( jpi,jpj,jpl, zalb_os, zalb_cs ) 
    224221 
    225222         !----------------------------! 
    … …  
    264261      !!---------------------------------------------------------------------- 
    265262      INTEGER :: ierr 
     263      INTEGER :: ji, jj 
    266264      !!---------------------------------------------------------------------- 
    267265      IF(lwp) WRITE(numout,*) 
    … …  
    320318      tn_ice(:,:,:) = t_su(:,:,:)       ! initialisation of surface temp for coupled simu 
    321319      ! 
     320      DO jj = 1, jpj 
     321         DO ji = 1, jpi 
     322            IF( gphit(ji,jj) > 0._wp ) THEN  ;  rn_amax_2d(ji,jj) = rn_amax_n  ! NH 
     323            ELSE                             ;  rn_amax_2d(ji,jj) = rn_amax_s  ! SH 
     324            ENDIF 
     325        ENDDO 
     326      ENDDO  
     327      ! 
    322328      nstart = numit  + nn_fsbc       
    323329      nitrun = nitend - nit000 + 1  
    … …  
    342348      INTEGER  ::   ios                 ! Local integer output status for namelist read 
    343349      NAMELIST/namicerun/ jpl, nlay_i, nlay_s, cn_icerst_in, cn_icerst_indir, cn_icerst_out, cn_icerst_outdir,  & 
    344          &                ln_limdyn, rn_amax, ln_limdiahsb, ln_limdiaout, ln_icectl, iiceprt, jiceprt   
     350         &                ln_limdyn, rn_amax_n, rn_amax_s, ln_limdiahsb, ln_limdiaout, ln_icectl, iiceprt, jiceprt   
    345351      !!------------------------------------------------------------------- 
    346352      !                     
    … …  
    363369         WRITE(numout,*) '   number of snow layers                                   = ', nlay_s 
    364370         WRITE(numout,*) '   switch for ice dynamics (1) or not (0)      ln_limdyn   = ', ln_limdyn 
    365          WRITE(numout,*) '   maximum ice concentration                               = ', rn_amax  
     371         WRITE(numout,*) '   maximum ice concentration for NH                        = ', rn_amax_n  
     372         WRITE(numout,*) '   maximum ice concentration for SH                        = ', rn_amax_s 
    366373         WRITE(numout,*) '   Diagnose heat/salt budget or not          ln_limdiahsb  = ', ln_limdiahsb 
    367374         WRITE(numout,*) '   Output   heat/salt budget or not          ln_limdiaout  = ', ln_limdiaout 
    … …  
    578585      sfx_bog(:,:) = 0._wp   ;   sfx_dyn(:,:) = 0._wp 
    579586      sfx_bom(:,:) = 0._wp   ;   sfx_sum(:,:) = 0._wp 
    580       sfx_res(:,:) = 0._wp 
     587      sfx_res(:,:) = 0._wp   ;   sfx_sub(:,:) = 0._wp 
    581588       
    582589      wfx_snw(:,:) = 0._wp   ;   wfx_ice(:,:) = 0._wp 
    … …  
    594601      hfx_spr(:,:) = 0._wp   ;   hfx_dif(:,:) = 0._wp  
    595602      hfx_err(:,:) = 0._wp   ;   hfx_err_rem(:,:) = 0._wp 
    596       hfx_err_dif(:,:) = 0._wp   ; 
    597  
     603      hfx_err_dif(:,:) = 0._wp 
     604      wfx_err_sub(:,:) = 0._wp 
     605       
    598606      afx_tot(:,:) = 0._wp   ; 
    599607      afx_dyn(:,:) = 0._wp   ;   afx_thd(:,:) = 0._wp 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/SBC/sbcice_lim_2.F90

    r6836 r6839  
    150150 
    151151         ! ... masked sea surface freezing temperature [Kelvin] (set to rt0 over land) 
    152          tfu(:,:) = eos_fzp( sss_m ) +  rt0  
     152         CALL eos_fzp( sss_m(:,:), tfu(:,:) ) 
     153         tfu(:,:) = tfu(:,:) + rt0 
    153154 
    154155         zsist (:,:,1) = sist (:,:) + rt0 * ( 1. - tmask(:,:,1) ) 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/SBC/sbcisf.F90

    r6836 r6839  
    5353   REAL(wp)   , PUBLIC, ALLOCATABLE, SAVE, DIMENSION (:,:)     ::  risfLeff               !:effective length (Leff) BG03 nn_isf==2 
    5454   REAL(wp)   , PUBLIC, ALLOCATABLE, SAVE, DIMENSION (:,:)     ::  ttbl, stbl, utbl, vtbl !:top boundary layer variable at T point 
    55 #if defined key_agrif 
    56    ! AGRIF can not handle these arrays as integers. The reason is a mystery but problems avoided by declaring them as reals 
    57    REAL(wp),    PUBLIC, ALLOCATABLE, SAVE, DIMENSION (:,:)     ::  misfkt, misfkb         !:Level of ice shelf base 
    58                                                                                           !: (first wet level and last level include in the tbl) 
    59 #else 
    6055   INTEGER,    PUBLIC, ALLOCATABLE, SAVE, DIMENSION (:,:)     ::  misfkt, misfkb         !:Level of ice shelf base 
    61 #endif 
    6256 
    6357 
    … …  
    9286    REAL(wp)                     ::   rmin 
    9387    REAL(wp)                     ::   zhk 
    94     CHARACTER(len=256)           ::   cfisf, cvarzisf, cvarhisf   ! name for isf file 
     88    REAL(wp)                     ::   zt_frz, zpress 
     89    CHARACTER(len=256)           ::   cfisf , cvarzisf, cvarhisf   ! name for isf file 
    9590    CHARACTER(LEN=256)           :: cnameis                     ! name of iceshelf file 
    9691    CHARACTER (LEN=32)           :: cvarLeff                    ! variable name for efficient Length scale 
    … …  
    176171              DO jj = 1, jpj 
    177172                  jk = 2 
    178                   DO WHILE ( jk .LE. mbkt(ji,jj) .AND. fsdepw(ji,jj,jk) < rzisf_tbl(ji,jj) ) ;  jk = jk + 1 ;  END DO 
     173                  DO WHILE ( jk .LE. mbkt(ji,jj) .AND. gdepw_0(ji,jj,jk) < rzisf_tbl(ji,jj) ) ;  jk = jk + 1 ;  END DO 
    179174                  misfkt(ji,jj) = jk-1 
    180175               END DO 
    … …  
    194189         END IF 
    195190          
     191         ! save initial top boundary layer thickness          
    196192         rhisf_tbl_0(:,:) = rhisf_tbl(:,:) 
     193 
     194      END IF 
     195 
     196      !                                            ! ---------------------------------------- ! 
     197      IF( kt /= nit000 ) THEN                      !          Swap of forcing fields          ! 
     198         !                                         ! ---------------------------------------- ! 
     199         fwfisf_b  (:,:  ) = fwfisf  (:,:  )               ! Swap the ocean forcing fields except at nit000 
     200         risf_tsc_b(:,:,:) = risf_tsc(:,:,:)               ! where before fields are set at the end of the routine 
     201         ! 
     202      ENDIF 
     203 
     204      IF( MOD( kt-1, nn_fsbc) == 0 ) THEN 
    197205 
    198206         ! compute bottom level of isf tbl and thickness of tbl below the ice shelf 
    … …  
    205213 
    206214               ! determine the deepest level influenced by the boundary layer 
    207                ! test on tmask useless ????? 
    208215               DO jk = ikt, mbkt(ji,jj) 
    209216                  IF ( (SUM(fse3t_n(ji,jj,ikt:jk-1)) .LT. rhisf_tbl(ji,jj)) .AND. (tmask(ji,jj,jk) == 1) ) ikb = jk 
    … …  
    217224            END DO 
    218225         END DO 
    219           
    220       END IF 
    221  
    222       !                                            ! ---------------------------------------- ! 
    223       IF( kt /= nit000 ) THEN                      !          Swap of forcing fields          ! 
    224          !                                         ! ---------------------------------------- ! 
    225          fwfisf_b  (:,:  ) = fwfisf  (:,:  )               ! Swap the ocean forcing fields except at nit000 
    226          risf_tsc_b(:,:,:) = risf_tsc(:,:,:)               ! where before fields are set at the end of the routine 
    227          ! 
    228       ENDIF 
    229  
    230       IF( MOD( kt-1, nn_fsbc) == 0 ) THEN 
    231  
    232226 
    233227         ! compute salf and heat flux 
    … …  
    270264         END IF 
    271265         ! compute tsc due to isf 
    272          ! WARNING water add at temp = 0C, correction term is added in trasbc, maybe better here but need a 3D variable). 
    273          risf_tsc(:,:,jp_tem) = qisf(:,:) * r1_rau0_rcp ! 
     266         ! WARNING water add at temp = 0C, correction term is added, maybe better here but need a 3D variable). 
     267!         zpress = grav*rau0*fsdept(ji,jj,jk)*1.e-04 
     268         zt_frz = -1.9 !eos_fzp( tsn(ji,jj,jk,jp_sal), zpress ) 
     269         risf_tsc(:,:,jp_tem) = qisf(:,:) * r1_rau0_rcp - rdivisf * fwfisf(:,:) * zt_frz * r1_rau0 ! 
    274270          
    275271         ! salt effect already take into account in vertical advection 
    276272         risf_tsc(:,:,jp_sal) = (1.0_wp-rdivisf) * fwfisf(:,:) * stbl(:,:) * r1_rau0 
    277            
     273 
     274         ! output 
     275         IF( iom_use('qisf'  ) )   CALL iom_put('qisf'  , qisf) 
     276         IF( iom_use('fwfisf') )   CALL iom_put('fwfisf', fwfisf * stbl(:,:) / soce ) 
     277 
     278         ! if apply only on the trend and not as a volume flux (rdivisf = 0), fwfisf have to be set to 0 now 
     279         fwfisf(:,:) = rdivisf * fwfisf(:,:)          
     280  
    278281         ! lbclnk 
    279282         CALL lbc_lnk(risf_tsc(:,:,jp_tem),'T',1.) 
    … …  
    295298         ENDIF 
    296299         !  
    297          ! output 
    298          CALL iom_put('qisf'  , qisf) 
    299          IF( iom_use('fwfisf') )   CALL iom_put('fwfisf', fwfisf * stbl(:,:) / soce ) 
    300300      END IF 
    301301   
    … …  
    370370             ! Calculate freezing temperature 
    371371                zpress = grav*rau0*fsdept(ji,jj,ik)*1.e-04  
    372                 zt_frz = eos_fzp(tsb(ji,jj,ik,jp_sal), zpress)  
     372                CALL eos_fzp(tsb(ji,jj,ik,jp_sal), zt_frz, zpress)  
    373373                zt_sum = zt_sum + (tsn(ji,jj,ik,jp_tem)-zt_frz) * fse3t(ji,jj,ik) * tmask(ji,jj,ik)  ! sum temp 
    374374             ENDDO 
    … …  
    452452      zti(:,:)=tinsitu( ttbl, stbl, zpress ) 
    453453! Calculate freezing temperature 
    454       zfrz(:,:)=eos_fzp( sss_m(:,:), zpress ) 
     454      CALL eos_fzp( sss_m(:,:), zfrz(:,:), zpress ) 
    455455 
    456456       
    … …  
    472472 
    473473                     nit = nit + 1 
    474                      IF (nit .GE. 100) THEN 
    475                         !WRITE(numout,*) "sbcisf : too many iteration ... ", zhtflx, zhtflx_b,zgammat, rn_gammat0, rn_tfri2, nn_gammablk, ji,jj 
    476                         !WRITE(numout,*) "sbcisf : too many iteration ... ", (zhtflx - zhtflx_b)/zhtflx 
    477                         CALL ctl_stop( 'STOP', 'sbc_isf_hol99 : too many iteration ...' ) 
    478                      END IF 
     474                     IF (nit .GE. 100) CALL ctl_stop( 'STOP', 'sbc_isf_hol99 : too many iteration ...' ) 
     475 
    479476! save gammat and compute zhtflx_b 
    480477                     zgammat2d(ji,jj)=zgammat 
    … …  
    794791               ! test on tmask useless ????? 
    795792               DO jk = ikt, mbkt(ji,jj) 
    796 !                  IF ( (SUM(fse3t(ji,jj,ikt:jk-1)) .LT. rhisf_tbl(ji,jj)) .AND. (tmask(ji,jj,jk) == 1) ) ikb = jk 
     793                  IF ( (SUM(fse3t(ji,jj,ikt:jk-1)) .LT. rhisf_tbl(ji,jj)) .AND. (tmask(ji,jj,jk) == 1) ) ikb = jk 
    797794               END DO 
    798795               rhisf_tbl(ji,jj) = MIN(rhisf_tbl(ji,jj), SUM(fse3t(ji,jj,ikt:ikb)))  ! limit the tbl to water thickness. 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/SBC/sbcmod.F90

    r6836 r6839  
    179179 
    180180      !                          ! Checks: 
    181       IF( nn_isf .EQ. 0 ) THEN                      ! no specific treatment in vicinity of ice shelf  
     181      IF( nn_isf .EQ. 0 ) THEN                      ! variable initialisation if no ice shelf  
    182182         IF( sbc_isf_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'sbc_init : unable to allocate sbc_isf arrays' ) 
    183          fwfisf  (:,:) = 0.0_wp 
    184          fwfisf_b(:,:) = 0.0_wp 
     183         fwfisf  (:,:)   = 0.0_wp ; fwfisf_b  (:,:)   = 0.0_wp 
     184         risf_tsc(:,:,:) = 0.0_wp ; risf_tsc_b(:,:,:) = 0.0_wp 
     185         rdivisf       = 0.0_wp 
    185186      END IF 
    186187      IF( nn_ice == 0 .AND. nn_components /= jp_iam_opa )   fr_i(:,:) = 0.e0 ! no ice in the domain, ice fraction is always zero 
    … …  
    339340         emp_b(:,:) = emp(:,:) 
    340341         sfx_b(:,:) = sfx(:,:) 
     342         IF ( ln_rnf ) THEN 
     343            rnf_b    (:,:  ) = rnf    (:,:  ) 
     344            rnf_tsc_b(:,:,:) = rnf_tsc(:,:,:) 
     345         ENDIF 
    341346      ENDIF 
    342347      !                                            ! ---------------------------------------- ! 
    … …  
    455460      !                                                ! ---------------------------------------- ! 
    456461      IF( MOD( kt-1, nn_fsbc ) == 0 ) THEN 
    457          CALL iom_put( "empmr" , emp  - rnf )                   ! upward water flux 
     462         CALL iom_put( "empmr"  , emp    - rnf )                ! upward water flux 
     463         CALL iom_put( "empbmr" , emp_b  - rnf )                ! before upward water flux ( needed to recalculate the time evolution of ssh in offline ) 
    458464         CALL iom_put( "saltflx", sfx  )                        ! downward salt flux   
    459465                                                                ! (includes virtual salt flux beneath ice  

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/SBC/sbcrnf.F90

    r6836 r6839  
    5252   REAL(wp)                   ::   rn_hrnf         !: runoffs, depth over which enhanced vertical mixing is used 
    5353   REAL(wp)          , PUBLIC ::   rn_avt_rnf      !: runoffs, value of the additional vertical mixing coef. [m2/s] 
    54    REAL(wp)                  ::   rn_rfact        !: multiplicative factor for runoff 
     54   REAL(wp)          , PUBLIC ::   rn_rfact        !: multiplicative factor for runoff 
    5555 
    5656   LOGICAL           , PUBLIC ::   l_rnfcpl = .false.       ! runoffs recieved from oasis 
    … …  
    109109      ! 
    110110      CALL wrk_alloc( jpi,jpj, ztfrz) 
    111  
    112       !                                            ! ---------------------------------------- ! 
    113       IF( kt /= nit000 ) THEN                      !          Swap of forcing fields          ! 
    114          !                                         ! ---------------------------------------- ! 
    115          rnf_b    (:,:  ) = rnf    (:,:  )               ! Swap the ocean forcing fields except at nit000 
    116          rnf_tsc_b(:,:,:) = rnf_tsc(:,:,:)               ! where before fields are set at the end of the routine 
    117          ! 
    118       ENDIF 
    119  
     111      ! 
    120112      !                                            !-------------------! 
    121113      !                                            !   Update runoff   ! 
    … …  
    125117      IF(   ln_rnf_tem   )   CALL fld_read ( kt, nn_fsbc, sf_t_rnf )    ! idem for runoffs temperature if required 
    126118      IF(   ln_rnf_sal   )   CALL fld_read ( kt, nn_fsbc, sf_s_rnf )    ! idem for runoffs salinity    if required 
    127       ! 
    128       ! Runoff reduction only associated to the ORCA2_LIM configuration 
    129       ! when reading the NetCDF file runoff_1m_nomask.nc 
    130       IF( cp_cfg == 'orca' .AND. jp_cfg == 2 .AND. .NOT. l_rnfcpl )   THEN 
    131          WHERE( 40._wp < gphit(:,:) .AND. gphit(:,:) < 65._wp ) 
    132             sf_rnf(1)%fnow(:,:,1) = 0.85 * sf_rnf(1)%fnow(:,:,1) 
    133          END WHERE 
    134       ENDIF 
    135119      ! 
    136120      IF( MOD( kt - 1, nn_fsbc ) == 0 ) THEN 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/SBC/updtide.F90

    r6836 r6839  
    3131CONTAINS 
    3232 
    33    SUBROUTINE upd_tide( kt, kit, kbaro, koffset ) 
     33   SUBROUTINE upd_tide( kt, kit, time_offset ) 
    3434      !!---------------------------------------------------------------------- 
    3535      !!                 ***  ROUTINE upd_tide  *** 
    … …  
    4242      !!----------------------------------------------------------------------       
    4343      INTEGER, INTENT(in)           ::   kt      ! ocean time-step index 
    44       INTEGER, INTENT(in), OPTIONAL ::   kit     ! external mode sub-time-step index (lk_dynspg_ts=T only) 
    45       INTEGER, INTENT(in), OPTIONAL ::   kbaro   ! number of sub-time-step           (lk_dynspg_ts=T only) 
    46       INTEGER, INTENT(in), OPTIONAL ::   koffset ! time offset in number  
    47                                                  ! of sub-time-steps                 (lk_dynspg_ts=T only) 
     44      INTEGER, INTENT(in), OPTIONAL ::   kit     ! external mode sub-time-step index (lk_dynspg_ts=T) 
     45      INTEGER, INTENT(in), OPTIONAL ::   time_offset ! time offset in number  
     46                                                     ! of internal steps             (lk_dynspg_ts=F) 
     47                                                     ! of external steps             (lk_dynspg_ts=T) 
    4848      ! 
    4949      INTEGER  ::   joffset      ! local integer 
    … …  
    5757      ! 
    5858      joffset = 0 
    59       IF( PRESENT( koffset ) )   joffset = koffset 
     59      IF( PRESENT( time_offset ) )   joffset = time_offset 
    6060      ! 
    61       IF( PRESENT( kit ) .AND. PRESENT( kbaro ) )   THEN 
    62          zt = zt + ( kit + 0.5_wp * ( joffset - 1 ) ) * rdt / REAL( kbaro, wp ) 
     61      IF( PRESENT( kit ) )   THEN 
     62         zt = zt + ( kit +  joffset - 1 ) * rdt / REAL( nn_baro, wp ) 
    6363      ELSE 
    6464         zt = zt + joffset * rdt 
    … …  
    7474      IF( ln_tide_ramp ) THEN         ! linear increase if asked 
    7575         zt = ( kt - nit000 ) * rdt 
    76          IF( PRESENT( kit ) .AND. PRESENT( kbaro ) )   zt = zt + kit * rdt / REAL( kbaro, wp ) 
     76         IF( PRESENT( kit ) )   zt = zt + ( kit + joffset -1) * rdt / REAL( nn_baro, wp ) 
    7777         zramp = MIN(  MAX( zt / (rdttideramp*rday) , 0._wp ) , 1._wp  ) 
    7878         pot_astro(:,:) = zramp * pot_astro(:,:) 
    … …  
    8686  !!---------------------------------------------------------------------- 
    8787CONTAINS 
    88   SUBROUTINE upd_tide( kt, kit, kbaro, koffset )          ! Empty routine 
     88  SUBROUTINE upd_tide( kt, kit, time_offset )  ! Empty routine 
    8989    INTEGER, INTENT(in)           ::   kt      !  integer  arg, dummy routine 
    9090    INTEGER, INTENT(in), OPTIONAL ::   kit     !  optional arg, dummy routine 
    91     INTEGER, INTENT(in), OPTIONAL ::   kbaro   !  optional arg, dummy routine 
    92     INTEGER, INTENT(in), OPTIONAL ::   koffset !  optional arg, dummy routine 
     91    INTEGER, INTENT(in), OPTIONAL ::   time_offset !  optional arg, dummy routine 
    9392    WRITE(*,*) 'upd_tide: You should not have seen this print! error?', kt 
    9493  END SUBROUTINE upd_tide 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/SOL/solver.F90

    r6836 r6839  
    9292      IF( .NOT. lk_agrif .OR. .NOT. ln_rstart) THEN 
    9393         IF( sol_oce_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'solver_init : unable to allocate sol_oce arrays' ) 
     94         gcx (:,:) = 0.e0 
     95         gcxb(:,:) = 0.e0 
    9496      ENDIF 
    9597 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/STO/stopar.F90

    r6836 r6839  
    849849 
    850850 
    851    REAL(wp) FUNCTION sto_par_flt_fac( kpasses ) 
     851   FUNCTION sto_par_flt_fac( kpasses ) 
    852852      !!---------------------------------------------------------------------- 
    853853      !!                  ***  FUNCTION sto_par_flt_fac  *** 
    … …  
    858858      !!---------------------------------------------------------------------- 
    859859      INTEGER, INTENT(in) :: kpasses 
     860      REAL(wp) :: sto_par_flt_fac 
    860861      !! 
    861862      INTEGER :: jpasses, ji, jj, jflti, jfltj 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/TRA/eosbn2.F90

    r6836 r6839  
    2222   !!             -   ! 2013-04  (F. Roquet, G. Madec)  add eos_rab, change bn2 computation and reorganize the module 
    2323   !!             -   ! 2014-09  (F. Roquet)  add TEOS-10, S-EOS, and modify EOS-80 
     24   !!             -   ! 2015-06  (P.A. Bouttier) eos_fzp functions changed to subroutines for AGRIF 
    2425   !!---------------------------------------------------------------------- 
    2526 
    … …  
    991992 
    992993 
    993    FUNCTION eos_fzp_2d( psal, pdep ) RESULT( ptf ) 
     994   SUBROUTINE  eos_fzp_2d( psal, ptf, pdep ) 
    994995      !!---------------------------------------------------------------------- 
    995996      !!                 ***  ROUTINE eos_fzp  *** 
    … …  
    10051006      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   )           ::   psal   ! salinity   [psu] 
    10061007      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ), OPTIONAL ::   pdep   ! depth      [m] 
    1007       REAL(wp), DIMENSION(jpi,jpj)                          ::   ptf   ! freezing temperature [Celcius] 
     1008      REAL(wp), DIMENSION(jpi,jpj), INTENT(out  )           ::   ptf    ! freezing temperature [Celcius] 
    10081009      ! 
    10091010      INTEGER  ::   ji, jj   ! dummy loop indices 
    … …  
    10171018         DO jj = 1, jpj 
    10181019            DO ji = 1, jpi 
    1019                zs= SQRT( ABS( psal(ji,jj) ) * r1_S0 )           ! square root salinity 
     1020               zs= SQRT( ABS( psal(ji,jj) ) / 35.16504_wp )           ! square root salinity 
    10201021               ptf(ji,jj) = ((((1.46873e-03_wp*zs-9.64972e-03_wp)*zs+2.28348e-02_wp)*zs & 
    10211022                  &          - 3.12775e-02_wp)*zs+2.07679e-02_wp)*zs-5.87701e-02_wp 
    … …  
    10381039         nstop = nstop + 1 
    10391040         ! 
    1040       END SELECT 
    1041       ! 
    1042    END FUNCTION eos_fzp_2d 
    1043  
    1044   FUNCTION eos_fzp_0d( psal, pdep ) RESULT( ptf ) 
     1041      END SELECT       
     1042      ! 
     1043  END SUBROUTINE eos_fzp_2d 
     1044 
     1045  SUBROUTINE eos_fzp_0d( psal, ptf, pdep ) 
    10451046      !!---------------------------------------------------------------------- 
    10461047      !!                 ***  ROUTINE eos_fzp  *** 
    … …  
    10541055      !! Reference  :   UNESCO tech. papers in the marine science no. 28. 1978 
    10551056      !!---------------------------------------------------------------------- 
    1056       REAL(wp), INTENT(in)           ::   psal   ! salinity   [psu] 
    1057       REAL(wp), INTENT(in), OPTIONAL ::   pdep   ! depth      [m] 
    1058       REAL(wp)                       ::   ptf   ! freezing temperature [Celcius] 
     1057      REAL(wp), INTENT(in )           ::   psal         ! salinity   [psu] 
     1058      REAL(wp), INTENT(in ), OPTIONAL ::   pdep         ! depth      [m] 
     1059      REAL(wp), INTENT(out)           ::   ptf          ! freezing temperature [Celcius] 
    10591060      ! 
    10601061      REAL(wp) :: zs   ! local scalars 
    … …  
    10651066      CASE ( -1, 1 )                !==  CT,SA (TEOS-10 formulation) ==! 
    10661067         ! 
    1067          zs  = SQRT( ABS( psal ) * r1_S0 )           ! square root salinity 
     1068         zs  = SQRT( ABS( psal ) / 35.16504_wp )           ! square root salinity 
    10681069         ptf = ((((1.46873e-03_wp*zs-9.64972e-03_wp)*zs+2.28348e-02_wp)*zs & 
    10691070                  &          - 3.12775e-02_wp)*zs+2.07679e-02_wp)*zs-5.87701e-02_wp 
    … …  
    10861087      END SELECT 
    10871088      ! 
    1088    END FUNCTION eos_fzp_0d 
     1089   END SUBROUTINE eos_fzp_0d 
    10891090 
    10901091 
    … …  
    12551256            WRITE(numout,*) '             model does not use Conservative Temperature' 
    12561257         ENDIF 
     1258      ENDIF 
     1259      ! 
     1260      ! Consistency check on ln_useCT and nn_eos 
     1261      IF ((nn_eos .EQ. -1) .AND. (.NOT. ln_useCT)) THEN 
     1262         CALL ctl_stop("ln_useCT should be set to True if using TEOS-10 (nn_eos=-1)") 
     1263      ELSE IF ((nn_eos .NE. -1) .AND. (ln_useCT)) THEN 
     1264         CALL ctl_stop("ln_useCT should be set to False if using TEOS-80 or simplified equation of state (nn_eos=0 or nn_eos=1)") 
    12571265      ENDIF 
    12581266      ! 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_cen2.F90

    r6836 r6839  
    173173         END DO  
    174174      END DO  
    175       zfzp(:,:) = eos_fzp( tsn(:,:,1,jp_sal), zpres(:,:) ) 
     175      CALL eos_fzp( tsn(:,:,1,jp_sal), zfzp(:,:), zpres(:,:) ) 
    176176      DO jk = 1, jpk 
    177177         DO jj = 1, jpj 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_eiv.F90

    r6836 r6839  
    212212      CHARACTER(len=3) ::   cdtype 
    213213      REAL, DIMENSION(:,:,:) ::   pun, pvn, pwn 
    214       WRITE(*,*) 'tra_adv_eiv: You should not have seen this print! error?', kt, cdtype, pun(1,1,1), pvn(1,1,1), pwn(1,1,1) 
     214      WRITE(*,*) 'tra_adv_eiv: You should not have seen this print! error?', & 
     215          &  kt, cdtype, pun(1,1,1), pvn(1,1,1), pwn(1,1,1) 
    215216   END SUBROUTINE tra_adv_eiv 
    216217#endif 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_tvd.F90

    r6836 r6839  
    173173            DO jj = 2, jpjm1 
    174174               DO ji = fs_2, fs_jpim1   ! vector opt. 
    175                   zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 
    176175                  ! total intermediate advective trends 
    177                   ztra = - zbtr * (  zwx(ji,jj,jk) - zwx(ji-1,jj  ,jk  )   & 
    178                      &             + zwy(ji,jj,jk) - zwy(ji  ,jj-1,jk  )   & 
    179                      &             + zwz(ji,jj,jk) - zwz(ji  ,jj  ,jk+1) ) 
     176                  ztra = - (  zwx(ji,jj,jk) - zwx(ji-1,jj  ,jk  )   & 
     177                     &      + zwy(ji,jj,jk) - zwy(ji  ,jj-1,jk  )   & 
     178                     &      + zwz(ji,jj,jk) - zwz(ji  ,jj  ,jk+1) ) / e1e2t(ji,jj) 
    180179                  ! update and guess with monotonic sheme 
    181                   pta(ji,jj,jk,jn) =   pta(ji,jj,jk,jn)         + ztra  * tmask(ji,jj,jk) 
    182                   zwi(ji,jj,jk)    = ( ptb(ji,jj,jk,jn) + z2dtt * ztra ) * tmask(ji,jj,jk) 
     180                  pta(ji,jj,jk,jn) =                       pta(ji,jj,jk,jn) +         ztra   / fse3t_n(ji,jj,jk) * tmask(ji,jj,jk) 
     181                  zwi(ji,jj,jk)    = ( fse3t_b(ji,jj,jk) * ptb(ji,jj,jk,jn) + z2dtt * ztra ) / fse3t_a(ji,jj,jk) * tmask(ji,jj,jk) 
    183182               END DO 
    184183            END DO 
    … …  
    326325      CALL wrk_alloc( jpi, jpj, zwx_sav, zwy_sav ) 
    327326      CALL wrk_alloc( jpi, jpj, jpk, zwi, zwz , zhdiv, zwz_sav, zwzts ) 
    328       CALL wrk_alloc( jpi, jpj, jpk, 3, ztrs ) 
     327      CALL wrk_alloc( jpi, jpj, jpk, kjpt+1, ztrs ) 
    329328      ! 
    330329      IF( kt == kit000 )  THEN 
    … …  
    410409            DO jj = 2, jpjm1 
    411410               DO ji = fs_2, fs_jpim1   ! vector opt. 
    412                   zbtr = 1._wp / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 
    413411                  ! total intermediate advective trends 
    414                   ztra = - zbtr * (  zwx(ji,jj,jk) - zwx(ji-1,jj  ,jk  )   & 
    415                      &             + zwy(ji,jj,jk) - zwy(ji  ,jj-1,jk  )   & 
    416                      &             + zwz(ji,jj,jk) - zwz(ji  ,jj  ,jk+1) ) 
     412                  ztra = - (  zwx(ji,jj,jk) - zwx(ji-1,jj  ,jk  )   & 
     413                     &      + zwy(ji,jj,jk) - zwy(ji  ,jj-1,jk  )   & 
     414                     &      + zwz(ji,jj,jk) - zwz(ji  ,jj  ,jk+1) ) / e1e2t(ji,jj) 
    417415                  ! update and guess with monotonic sheme 
    418                   pta(ji,jj,jk,jn) =   pta(ji,jj,jk,jn)         + ztra 
    419                   zwi(ji,jj,jk)    = ( ptb(ji,jj,jk,jn) + z2dtt * ztra ) * tmask(ji,jj,jk) 
     416                  pta(ji,jj,jk,jn) =                       pta(ji,jj,jk,jn) +         ztra   / fse3t_n(ji,jj,jk) * tmask(ji,jj,jk) 
     417                  zwi(ji,jj,jk)    = ( fse3t_b(ji,jj,jk) * ptb(ji,jj,jk,jn) + z2dtt * ztra ) / fse3t_a(ji,jj,jk) * tmask(ji,jj,jk) 
    420418               END DO 
    421419            END DO 
    … …  
    438436         ! -------------------------------------------------- 
    439437         ! antidiffusive flux on i and j 
    440  
    441  
    442          DO jk = 1, jpkm1 
    443  
     438         ! 
     439         DO jk = 1, jpkm1 
     440            ! 
    444441            DO jj = 1, jpjm1 
    445442               DO ji = 1, fs_jpim1   ! vector opt. 
    … …  
    564561      ! 
    565562                   CALL wrk_dealloc( jpi, jpj, jpk, zwi, zwz, zhdiv, zwz_sav, zwzts ) 
    566                    CALL wrk_dealloc( jpi, jpj, jpk, 3, ztrs ) 
     563                   CALL wrk_dealloc( jpi, jpj, jpk, kjpt+1, ztrs ) 
    567564                   CALL wrk_dealloc( jpi, jpj, zwx_sav, zwy_sav ) 
    568565      IF( l_trd )  CALL wrk_dealloc( jpi, jpj, jpk, ztrdx, ztrdy, ztrdz ) 
    … …  
    571568      ! 
    572569   END SUBROUTINE tra_adv_tvd_zts 
     570 
    573571 
    574572   SUBROUTINE nonosc( pbef, paa, pbb, pcc, paft, p2dt ) 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/TRA/traldf.F90

    r6836 r6839  
    6868      ! 
    6969      rldf = 1     ! For active tracers the  
     70      r_fact_lap(:,:,:) = 1.0 
    7071 
    7172      IF( l_trdtra )   THEN                    !* Save ta and sa trends 
    … …  
    214215      IF( ierr == 1 )   CALL ctl_stop( ' iso-level in z-coordinate - partial step, not allowed' ) 
    215216      IF( ierr == 2 )   CALL ctl_stop( ' isoneutral bilaplacian operator does not exist' ) 
     217      IF( ln_traldf_grif .AND. ln_isfcav         )   & 
     218           CALL ctl_stop( ' ice shelf and traldf_grif not tested') 
    216219      IF( lk_traldf_eiv .AND. .NOT.ln_traldf_iso )   & 
    217220           CALL ctl_stop( '          eddy induced velocity on tracers',   & 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/TRA/tranxt.F90

    r6836 r6839  
    2828   USE sbc_oce         ! surface boundary condition: ocean 
    2929   USE sbcrnf          ! river runoffs 
     30   USE sbcisf          ! ice shelf melting/freezing 
    3031   USE zdf_oce         ! ocean vertical mixing 
    3132   USE domvvl          ! variable volume 
    … …  
    4647   USE timing          ! Timing 
    4748#if defined key_agrif 
    48    USE agrif_opa_update 
    4949   USE agrif_opa_interp 
    5050#endif 
    … …  
    110110      ! Update after tracer on domain lateral boundaries 
    111111      !  
     112#if defined key_agrif 
     113      CALL Agrif_tra                     ! AGRIF zoom boundaries 
     114#endif 
     115      ! 
    112116      CALL lbc_lnk( tsa(:,:,:,jp_tem), 'T', 1._wp )      ! local domain boundaries  (T-point, unchanged sign) 
    113117      CALL lbc_lnk( tsa(:,:,:,jp_sal), 'T', 1._wp ) 
    … …  
    115119#if defined key_bdy  
    116120      IF( lk_bdy )   CALL bdy_tra( kt )  ! BDY open boundaries 
    117 #endif 
    118 #if defined key_agrif 
    119       CALL Agrif_tra                     ! AGRIF zoom boundaries 
    120121#endif 
    121122  
    … …  
    148149         ELSE                 ;   CALL tra_nxt_fix( kt, nit000,         'TRA', tsb, tsn, tsa, jpts )  ! fixed    volume level  
    149150         ENDIF 
    150       ENDIF  
    151       ! 
    152 #if defined key_agrif 
    153       ! Update tracer at AGRIF zoom boundaries 
    154       IF( .NOT.Agrif_Root() )    CALL Agrif_Update_Tra( kt )      ! children only 
    155 #endif       
    156       ! 
    157       ! trends computation 
     151      ENDIF      
     152      ! 
     153     ! trends computation 
    158154      IF( l_trdtra ) THEN      ! trend of the Asselin filter (tb filtered - tb)/dt      
    159155         DO jk = 1, jpkm1 
    … …  
    279275 
    280276      !!      
    281       LOGICAL  ::   ll_tra_hpg, ll_traqsr, ll_rnf   ! local logical 
     277      LOGICAL  ::   ll_tra_hpg, ll_traqsr, ll_rnf, ll_isf   ! local logical 
    282278      INTEGER  ::   ji, jj, jk, jn              ! dummy loop indices 
    283279      REAL(wp) ::   zfact1, ztc_a , ztc_n , ztc_b , ztc_f , ztc_d    ! local scalar 
    … …  
    295291         ll_traqsr  = ln_traqsr        ! active  tracers case  and  solar penetration 
    296292         ll_rnf     = ln_rnf           ! active  tracers case  and  river runoffs 
     293         IF (nn_isf .GE. 1) THEN  
     294            ll_isf = .TRUE.            ! active  tracers case  and  ice shelf melting/freezing 
     295         ELSE 
     296            ll_isf = .FALSE. 
     297         END IF 
    297298      ELSE                           
    298299         ll_tra_hpg = .FALSE.          ! passive tracers case or NO semi-implicit hpg 
    299300         ll_traqsr  = .FALSE.          ! active  tracers case and NO solar penetration 
    300301         ll_rnf     = .FALSE.          ! passive tracers or NO river runoffs 
     302         ll_isf     = .FALSE.          ! passive tracers or NO ice shelf melting/freezing 
    301303      ENDIF 
    302304      ! 
    … …  
    321323                  ztc_f  = ztc_n  + atfp * ztc_d 
    322324                  ! 
    323                   IF( jk == 1 ) THEN           ! first level  
    324                      ze3t_f = ze3t_f - zfact2 * ( emp_b(ji,jj) - emp(ji,jj) + rnf(ji,jj) - rnf_b(ji,jj) ) 
     325                  IF( jk == mikt(ji,jj) ) THEN           ! first level  
     326                     ze3t_f = ze3t_f - zfact2 * ( (emp_b(ji,jj)    - emp(ji,jj)   )  & 
     327                            &                   - (rnf_b(ji,jj)    - rnf(ji,jj)   )  & 
     328                            &                   + (fwfisf_b(ji,jj) - fwfisf(ji,jj))  ) 
    325329                     ztc_f  = ztc_f  - zfact1 * ( psbc_tc(ji,jj,jn) - psbc_tc_b(ji,jj,jn) ) 
    326330                  ENDIF 
    327331 
    328                   IF( ll_traqsr .AND. jn == jp_tem .AND. jk <= nksr )   &     ! solar penetration (temperature only) 
     332                  ! solar penetration (temperature only) 
     333                  IF( ll_traqsr .AND. jn == jp_tem .AND. jk <= nksr )                            &  
    329334                     &     ztc_f  = ztc_f  - zfact1 * ( qsr_hc(ji,jj,jk) - qsr_hc_b(ji,jj,jk) )  
    330335 
    331                   IF( ll_rnf .AND. jk <= nk_rnf(ji,jj) )   &            ! river runoffs 
     336                  ! river runoff 
     337                  IF( ll_rnf .AND. jk <= nk_rnf(ji,jj) )                                          & 
    332338                     &     ztc_f  = ztc_f  - zfact1 * ( rnf_tsc(ji,jj,jn) - rnf_tsc_b(ji,jj,jn) ) &  
    333339                     &                              * fse3t_n(ji,jj,jk) / h_rnf(ji,jj) 
     340 
     341                  ! ice shelf 
     342                  IF( ll_isf ) THEN 
     343                     ! level fully include in the Losch_2008 ice shelf boundary layer 
     344                     IF ( jk >= misfkt(ji,jj) .AND. jk < misfkb(ji,jj) )                          & 
     345                        ztc_f  = ztc_f  - zfact1 * ( risf_tsc(ji,jj,jn) - risf_tsc_b(ji,jj,jn) )  & 
     346                               &                 * fse3t_n(ji,jj,jk) * r1_hisf_tbl (ji,jj) 
     347                     ! level partially include in Losch_2008 ice shelf boundary layer  
     348                     IF ( jk == misfkb(ji,jj) )                                                   & 
     349                        ztc_f  = ztc_f  - zfact1 * ( risf_tsc(ji,jj,jn) - risf_tsc_b(ji,jj,jn) )  & 
     350                               &                 * fse3t_n(ji,jj,jk) * r1_hisf_tbl (ji,jj) * ralpha(ji,jj) 
     351                  END IF 
    334352 
    335353                  ze3t_f = 1.e0 / ze3t_f 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/TRA/traqsr.F90

    r6836 r6839  
    1010   !!             -   !  2005-11  (G. Madec) zco, zps, sco coordinate 
    1111   !!            3.2  !  2009-04  (G. Madec & NEMO team)  
    12    !!            4.0  !  2012-05  (C. Rousset) store attenuation coef for use in ice model  
     12   !!            3.4  !  2012-05  (C. Rousset) store attenuation coef for use in ice model  
     13   !!            3.6  !  2015-12  (O. Aumont, J. Jouanno, C. Ethe) use vertical profile of chlorophyll 
    1314   !!---------------------------------------------------------------------- 
    1415 
    … …  
    9394      !! Reference  : Jerlov, N. G., 1968 Optical Oceanography, Elsevier, 194pp. 
    9495      !!              Lengaigne et al. 2007, Clim. Dyn., V28, 5, 503-516. 
     96      !!              Morel, A. et Berthon, JF, 1989, Limnol Oceanogr 34(8), 1545-1562 
    9597      !!---------------------------------------------------------------------- 
    9698      ! 
    … …  
    101103      REAL(wp) ::   zchl, zcoef, zfact   ! local scalars 
    102104      REAL(wp) ::   zc0, zc1, zc2, zc3   !    -         - 
    103       REAL(wp) ::   zzc0, zzc1, zzc2, zzc3   !    -         - 
    104105      REAL(wp) ::   zz0, zz1, z1_e3t     !    -         - 
     106      REAL(wp) ::   zCb, zCmax, zze, zpsi, zpsimax, zdelpsi, zCtot, zCze 
     107      REAL(wp) ::   zlogc, zlogc2, zlogc3  
    105108      REAL(wp), POINTER, DIMENSION(:,:  ) :: zekb, zekg, zekr 
    106       REAL(wp), POINTER, DIMENSION(:,:,:) :: ze0, ze1, ze2, ze3, zea, ztrdt 
    107       !!---------------------------------------------------------------------- 
     109      REAL(wp), POINTER, DIMENSION(:,:,:) :: ze0, ze1, ze2, ze3, zea, ztrdt, zchl3d 
     110      !!-------------------------------------------------------------------------- 
    108111      ! 
    109112      IF( nn_timing == 1 )  CALL timing_start('tra_qsr') 
    110113      ! 
    111114      CALL wrk_alloc( jpi, jpj,      zekb, zekg, zekr        )  
    112       CALL wrk_alloc( jpi, jpj, jpk, ze0, ze1, ze2, ze3, zea )  
     115      CALL wrk_alloc( jpi, jpj, jpk, ze0, ze1, ze2, ze3, zea, zchl3d )  
    113116      ! 
    114117      IF( kt == nit000 ) THEN 
    … …  
    183186            !                                             ! ------------------------- ! 
    184187            ! Set chlorophyl concentration 
    185             IF( nn_chldta == 1 .OR. lk_vvl ) THEN            !*  Variable Chlorophyll or ocean volume 
    186                ! 
    187                IF( nn_chldta == 1 ) THEN                             !*  Variable Chlorophyll 
    188                   ! 
    189                   CALL fld_read( kt, 1, sf_chl )                         ! Read Chl data and provides it at the current time step 
    190                   !          
    191 !CDIR COLLAPSE 
     188            IF( nn_chldta == 1 .OR. nn_chldta == 2 .OR. lk_vvl ) THEN    !*  Variable Chlorophyll or ocean volume 
     189               ! 
     190               IF( nn_chldta == 1 ) THEN        !*  2D Variable Chlorophyll 
     191                  ! 
     192                  CALL fld_read( kt, 1, sf_chl )            ! Read Chl data and provides it at the current time step 
     193                  DO jk = 1, nksr + 1 
     194                     zchl3d(:,:,jk) = sf_chl(1)%fnow(:,:,1)  
     195                  ENDDO 
     196                  ! 
     197               ELSE IF( nn_chldta == 2 ) THEN    !*   -3-D Variable Chlorophyll 
     198                  ! 
     199                  CALL fld_read( kt, 1, sf_chl )            ! Read Chl data and provides it at the current time step 
     200!CDIR NOVERRCHK   ! 
     201                  DO jj = 1, jpj 
    192202!CDIR NOVERRCHK 
    193                   DO jj = 1, jpj                                         ! Separation in R-G-B depending of the surface Chl 
    194 !CDIR NOVERRCHK 
    195                      DO ji = 1, jpi 
    196                         zchl = MIN( 10. , MAX( 0.03, sf_chl(1)%fnow(ji,jj,1) ) ) 
    197                         irgb = NINT( 41 + 20.*LOG10(zchl) + 1.e-15 ) 
    198                         zekb(ji,jj) = rkrgb(1,irgb) 
    199                         zekg(ji,jj) = rkrgb(2,irgb) 
    200                         zekr(ji,jj) = rkrgb(3,irgb) 
    201                      END DO 
    202                   END DO 
    203                ELSE                                            ! Variable ocean volume but constant chrlorophyll 
    204                   zchl = 0.05                                     ! constant chlorophyll 
    205                   irgb = NINT( 41 + 20.*LOG10( zchl ) + 1.e-15 ) 
    206                   zekb(:,:) = rkrgb(1,irgb)                       ! Separation in R-G-B depending of the chlorophyll  
    207                   zekg(:,:) = rkrgb(2,irgb) 
    208                   zekr(:,:) = rkrgb(3,irgb) 
     203                     DO ji = 1, jpi 
     204                        zchl    = sf_chl(1)%fnow(ji,jj,1) 
     205                        zCtot   = 40.6  * zchl**0.459 
     206                        zze     = 568.2 * zCtot**(-0.746) 
     207                        IF( zze > 102. ) zze = 200.0 * zCtot**(-0.293) 
     208                        zlogc   = LOG( zchl ) 
     209                        zlogc2  = zlogc * zlogc 
     210                        zlogc3  = zlogc * zlogc * zlogc 
     211                        zCb     = 0.768 + 0.087 * zlogc - 0.179 * zlogc2 - 0.025 * zlogc3 
     212                        zCmax   = 0.299 - 0.289 * zlogc + 0.579 * zlogc2 
     213                        zpsimax = 0.6   - 0.640 * zlogc + 0.021 * zlogc2 + 0.115 * zlogc3 
     214                        zdelpsi = 0.710 + 0.159 * zlogc + 0.021 * zlogc2 
     215                        zCze    = 1.12  * (zchl)**0.803  
     216                        DO jk = 1, nksr + 1 
     217                           zpsi = fsdept(ji,jj,jk) / zze 
     218                           zchl3d(ji,jj,jk) = zCze * ( zCb + zCmax * EXP( -( (zpsi - zpsimax) / zdelpsi )**2 ) ) 
     219                        END DO 
     220                        ! 
     221                      END DO 
     222                   END DO 
     223                     ! 
     224               ELSE                              !* Variable ocean volume but constant chrlorophyll 
     225                  DO jk = 1, nksr + 1 
     226                     zchl3d(:,:,jk) = 0.05  
     227                  ENDDO 
    209228               ENDIF 
    210229               ! 
    211                zcoef  = ( 1. - rn_abs ) / 3.e0                        ! equi-partition in R-G-B 
     230               zcoef  = ( 1. - rn_abs ) / 3.e0                        !  equi-partition in R-G-B 
    212231               ze0(:,:,1) = rn_abs  * qsr(:,:) 
    213232               ze1(:,:,1) = zcoef * qsr(:,:) 
    … …  
    217236               ! 
    218237               DO jk = 2, nksr+1 
     238                  ! 
     239                  DO jj = 1, jpj                                         ! Separation in R-G-B depending of vertical profile of Chl 
     240!CDIR NOVERRCHK 
     241                     DO ji = 1, jpi 
     242                        zchl = MIN( 10. , MAX( 0.03, zchl3d(ji,jj,jk) ) ) 
     243                        irgb = NINT( 41 + 20.*LOG10(zchl) + 1.e-15 ) 
     244                        zekb(ji,jj) = rkrgb(1,irgb) 
     245                        zekg(ji,jj) = rkrgb(2,irgb) 
     246                        zekr(ji,jj) = rkrgb(3,irgb) 
     247                     END DO 
     248                  END DO 
    219249!CDIR NOVERRCHK 
    220250                  DO jj = 1, jpj 
    … …  
    233263                  END DO 
    234264               END DO 
    235                ! clem: store attenuation coefficient of the first ocean level 
    236                IF ( ln_qsr_ice ) THEN 
    237                   DO jj = 1, jpj 
    238                      DO ji = 1, jpi 
    239                         zzc0 = rn_abs * EXP( - fse3t(ji,jj,1) * xsi0r     ) 
    240                         zzc1 = zcoef  * EXP( - fse3t(ji,jj,1) * zekb(ji,jj) ) 
    241                         zzc2 = zcoef  * EXP( - fse3t(ji,jj,1) * zekg(ji,jj) ) 
    242                         zzc3 = zcoef  * EXP( - fse3t(ji,jj,1) * zekr(ji,jj) ) 
    243                         fraqsr_1lev(ji,jj) = 1.0 - ( zzc0 + zzc1 + zzc2  + zzc3  ) * tmask(ji,jj,2)  
    244                      END DO 
    245                   END DO 
    246                ENDIF 
    247265               ! 
    248266               DO jk = 1, nksr                                        ! compute and add qsr trend to ta 
    … …  
    251269               zea(:,:,nksr+1:jpk) = 0.e0     ! below 400m set to zero 
    252270               CALL iom_put( 'qsr3d', zea )   ! Shortwave Radiation 3D distribution 
     271               ! 
     272               IF ( ln_qsr_ice ) THEN    ! store attenuation coefficient of the first ocean level 
     273!CDIR NOVERRCHK 
     274                  DO jj = 1, jpj                                         ! Separation in R-G-B depending of the surface Chl 
     275!CDIR NOVERRCHK 
     276                     DO ji = 1, jpi 
     277                        zchl = MIN( 10. , MAX( 0.03, zchl3d(ji,jj,1) ) ) 
     278                        irgb = NINT( 41 + 20.*LOG10(zchl) + 1.e-15 ) 
     279                        zekb(ji,jj) = rkrgb(1,irgb) 
     280                        zekg(ji,jj) = rkrgb(2,irgb) 
     281                        zekr(ji,jj) = rkrgb(3,irgb) 
     282                     END DO 
     283                  END DO 
     284                  !  
     285                  DO jj = 1, jpj 
     286                     DO ji = 1, jpi 
     287                        zc0 = rn_abs * EXP( - fse3t(ji,jj,1) * xsi0r     ) 
     288                        zc1 = zcoef  * EXP( - fse3t(ji,jj,1) * zekb(ji,jj) ) 
     289                        zc2 = zcoef  * EXP( - fse3t(ji,jj,1) * zekg(ji,jj) ) 
     290                        zc3 = zcoef  * EXP( - fse3t(ji,jj,1) * zekr(ji,jj) ) 
     291                        fraqsr_1lev(ji,jj) = 1.0 - ( zc0 + zc1 + zc2  + zc3  ) * tmask(ji,jj,2)  
     292                     END DO 
     293                  END DO 
     294                  ! 
     295               ENDIF 
    253296               ! 
    254297            ELSE                                                 !*  Constant Chlorophyll 
    … …  
    256299                  qsr_hc(:,:,jk) =  etot3(:,:,jk) * qsr(:,:) 
    257300               END DO 
    258                ! clem: store attenuation coefficient of the first ocean level 
    259                IF ( ln_qsr_ice ) THEN 
     301               ! store attenuation coefficient of the first ocean level 
     302               IF( ln_qsr_ice ) THEN 
    260303                  fraqsr_1lev(:,:) = etot3(:,:,1) / r1_rau0_rcp 
    261304               ENDIF 
    … …  
    339382      ! 
    340383      CALL wrk_dealloc( jpi, jpj,      zekb, zekg, zekr        )  
    341       CALL wrk_dealloc( jpi, jpj, jpk, ze0, ze1, ze2, ze3, zea )  
     384      CALL wrk_dealloc( jpi, jpj, jpk, ze0, ze1, ze2, ze3, zea, zchl3d )  
    342385      ! 
    343386      IF( nn_timing == 1 )  CALL timing_stop('tra_qsr') 
    … …  
    405448         WRITE(numout,*) '      bio-model            light penetration   ln_qsr_bio = ', ln_qsr_bio 
    406449         WRITE(numout,*) '      light penetration for ice-model LIM3     ln_qsr_ice = ', ln_qsr_ice 
    407          WRITE(numout,*) '      RGB : Chl data (=1) or cst value (=0)    nn_chldta  = ', nn_chldta 
     450         WRITE(numout,*) '      RGB : Chl data (=1/2) or cst value (=0)  nn_chldta  = ', nn_chldta 
    408451         WRITE(numout,*) '      RGB & 2 bands: fraction of light (rn_si1)    rn_abs = ', rn_abs 
    409452         WRITE(numout,*) '      RGB & 2 bands: shortess depth of extinction  rn_si0 = ', rn_si0 
    … …  
    429472         IF( ln_qsr_rgb .AND. nn_chldta == 0 )   nqsr =  1  
    430473         IF( ln_qsr_rgb .AND. nn_chldta == 1 )   nqsr =  2 
    431          IF( ln_qsr_2bd                      )   nqsr =  3 
    432          IF( ln_qsr_bio                      )   nqsr =  4 
     474         IF( ln_qsr_rgb .AND. nn_chldta == 2 )   nqsr =  3 
     475         IF( ln_qsr_2bd                      )   nqsr =  4 
     476         IF( ln_qsr_bio                      )   nqsr =  5 
    433477         ! 
    434478         IF(lwp) THEN                   ! Print the choice 
    435479            WRITE(numout,*) 
    436480            IF( nqsr ==  1 )   WRITE(numout,*) '         R-G-B   light penetration - Constant Chlorophyll' 
    437             IF( nqsr ==  2 )   WRITE(numout,*) '         R-G-B   light penetration - Chl data ' 
    438             IF( nqsr ==  3 )   WRITE(numout,*) '         2 bands light penetration' 
    439             IF( nqsr ==  4 )   WRITE(numout,*) '         bio-model light penetration' 
     481            IF( nqsr ==  2 )   WRITE(numout,*) '         R-G-B   light penetration - 2D Chl data ' 
     482            IF( nqsr ==  3 )   WRITE(numout,*) '         R-G-B   light penetration - 3D Chl data ' 
     483            IF( nqsr ==  4 )   WRITE(numout,*) '         2 bands light penetration' 
     484            IF( nqsr ==  5 )   WRITE(numout,*) '         bio-model light penetration' 
    440485         ENDIF 
    441486         ! 
    … …  
    460505            IF(lwp) WRITE(numout,*) '        level of light extinction = ', nksr, ' ref depth = ', gdepw_1d(nksr+1), ' m' 
    461506            ! 
    462             IF( nn_chldta == 1 ) THEN           !* Chl data : set sf_chl structure 
     507            IF( nn_chldta == 1  .OR. nn_chldta == 2 ) THEN           !* Chl data : set sf_chl structure 
    463508               IF(lwp) WRITE(numout,*) 
    464509               IF(lwp) WRITE(numout,*) '        Chlorophyll read in a file' 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/TRA/trasbc.F90

    r6836 r6839  
    120120      REAL(wp) ::   zfact, z1_e3t, zdep 
    121121      REAL(wp) ::   zalpha, zhk 
    122       REAL(wp) ::  zt_frz, zpress 
    123122      REAL(wp), POINTER, DIMENSION(:,:,:) ::  ztrdt, ztrds 
    124123      !!---------------------------------------------------------------------- 
    … …  
    159158         ELSE                                         ! No restart or restart not found: Euler forward time stepping 
    160159            zfact = 1._wp 
     160            sbc_tsc(:,:,:) = 0._wp 
    161161            sbc_tsc_b(:,:,:) = 0._wp 
    162162         ENDIF 
    … …  
    232232               DO jk = ikt, ikb - 1 
    233233               ! compute tfreez for the temperature correction (we add water at freezing temperature) 
    234 !                  zpress = grav*rau0*fsdept(ji,jj,jk)*1.e-04 
    235                   zt_frz = -1.9 !eos_fzp( tsn(ji,jj,jk,jp_sal), zpress ) 
    236234               ! compute trend 
    237235                  tsa(ji,jj,jk,jp_tem) = tsa(ji,jj,jk,jp_tem)                                          & 
    238                      &           + zfact * (risf_tsc_b(ji,jj,jp_tem) + risf_tsc(ji,jj,jp_tem)          & 
    239                      &               - rdivisf * (fwfisf(ji,jj) + fwfisf_b(ji,jj)) * zt_frz * r1_rau0) & 
    240                      &           * r1_hisf_tbl(ji,jj) 
     236                     &           + zfact * (risf_tsc_b(ji,jj,jp_tem) + risf_tsc(ji,jj,jp_tem)) * r1_hisf_tbl(ji,jj) 
    241237                  tsa(ji,jj,jk,jp_sal) = tsa(ji,jj,jk,jp_sal)                                          & 
    242238                     &           + zfact * (risf_tsc_b(ji,jj,jp_sal) + risf_tsc(ji,jj,jp_sal)) * r1_hisf_tbl(ji,jj) 
    … …  
    245241               ! level partially include in ice shelf boundary layer  
    246242               ! compute tfreez for the temperature correction (we add water at freezing temperature) 
    247 !               zpress = grav*rau0*fsdept(ji,jj,ikb)*1.e-04 
    248                zt_frz = -1.9 !eos_fzp( tsn(ji,jj,ikb,jp_sal), zpress ) 
    249243               ! compute trend 
    250244               tsa(ji,jj,ikb,jp_tem) = tsa(ji,jj,ikb,jp_tem)                                           & 
    251                   &              + zfact * (risf_tsc_b(ji,jj,jp_tem) + risf_tsc(ji,jj,jp_tem)          & 
    252                   &                  - rdivisf * (fwfisf(ji,jj) + fwfisf_b(ji,jj)) * zt_frz * r1_rau0) &  
    253                   &              * r1_hisf_tbl(ji,jj) * ralpha(ji,jj) 
     245                  &              + zfact * (risf_tsc_b(ji,jj,jp_tem) + risf_tsc(ji,jj,jp_tem)) * r1_hisf_tbl(ji,jj) * ralpha(ji,jj) 
    254246               tsa(ji,jj,ikb,jp_sal) = tsa(ji,jj,ikb,jp_sal)                                           & 
    255247                  &              + zfact * (risf_tsc_b(ji,jj,jp_sal) + risf_tsc(ji,jj,jp_sal)) * r1_hisf_tbl(ji,jj) * ralpha(ji,jj)  
    … …  
    287279         END DO   
    288280      ENDIF 
    289   
     281 
     282      IF( iom_use('rnf_x_sst') )   CALL iom_put( "rnf_x_sst", rnf*tsn(:,:,1,jp_tem) )   ! runoff term on sst 
     283      IF( iom_use('rnf_x_sss') )   CALL iom_put( "rnf_x_sss", rnf*tsn(:,:,1,jp_sal) )   ! runoff term on sss 
     284 
    290285      IF( l_trdtra )   THEN                      ! send trends for further diagnostics 
    291286         ztrdt(:,:,:) = tsa(:,:,:,jp_tem) - ztrdt(:,:,:) 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/TRD/trdken.F90

    r6836 r6839  
    117117      ! 
    118118      SELECT CASE( ktrd ) 
    119          CASE( jpdyn_hpg )   ;   CALL iom_put( "ketrd_hpg", zke )    ! hydrostatic pressure gradient 
    120          CASE( jpdyn_spg )   ;   CALL iom_put( "ketrd_spg", zke )    ! surface pressure gradient 
    121          CASE( jpdyn_spgexp );   CALL iom_put( "ketrd_spgexp", zke ) ! surface pressure gradient (explicit) 
    122          CASE( jpdyn_spgflt );   CALL iom_put( "ketrd_spgflt", zke ) ! surface pressure gradient (filter) 
    123          CASE( jpdyn_pvo )   ;   CALL iom_put( "ketrd_pvo", zke )    ! planetary vorticity 
    124          CASE( jpdyn_rvo )   ;   CALL iom_put( "ketrd_rvo", zke )    ! relative  vorticity     (or metric term) 
    125          CASE( jpdyn_keg )   ;   CALL iom_put( "ketrd_keg", zke )    ! Kinetic Energy gradient (or had) 
    126          CASE( jpdyn_zad )   ;   CALL iom_put( "ketrd_zad", zke )    ! vertical   advection 
    127          CASE( jpdyn_ldf )   ;   CALL iom_put( "ketrd_ldf", zke )    ! lateral diffusion 
    128          CASE( jpdyn_zdf )   ;   CALL iom_put( "ketrd_zdf", zke )    ! vertical diffusion  
     119        CASE( jpdyn_hpg )   ;   CALL iom_put( "ketrd_hpg", zke )    ! hydrostatic pressure gradient 
     120        CASE( jpdyn_spg )   ;   CALL iom_put( "ketrd_spg", zke )    ! surface pressure gradient 
     121        CASE( jpdyn_spgexp );   CALL iom_put( "ketrd_spgexp", zke ) ! surface pressure gradient (explicit) 
     122        CASE( jpdyn_spgflt );   CALL iom_put( "ketrd_spgflt", zke ) ! surface pressure gradient (filter) 
     123        CASE( jpdyn_pvo )   ;   CALL iom_put( "ketrd_pvo", zke )    ! planetary vorticity 
     124        CASE( jpdyn_rvo )   ;   CALL iom_put( "ketrd_rvo", zke )    ! relative  vorticity     (or metric term) 
     125        CASE( jpdyn_keg )   ;   CALL iom_put( "ketrd_keg", zke )    ! Kinetic Energy gradient (or had) 
     126        CASE( jpdyn_zad )   ;   CALL iom_put( "ketrd_zad", zke )    ! vertical   advection 
     127        CASE( jpdyn_ldf )   ;   CALL iom_put( "ketrd_ldf", zke )    ! lateral diffusion 
     128        CASE( jpdyn_zdf )   ;   CALL iom_put( "ketrd_zdf", zke )    ! vertical diffusion  
    129129                                 !                                   ! wind stress trends 
    130                                  CALL wrk_alloc( jpi, jpj, z2dx, z2dy, zke2d ) 
    131                            z2dx(:,:) = un(:,:,1) * ( utau_b(:,:) + utau(:,:) ) * e1u(:,:) * e2u(:,:) * umask(:,:,1) 
    132                            z2dy(:,:) = vn(:,:,1) * ( vtau_b(:,:) + vtau(:,:) ) * e1v(:,:) * e2v(:,:) * vmask(:,:,1) 
    133                            zke2d(1,:) = 0._wp   ;   zke2d(:,1) = 0._wp 
    134                            DO jj = 2, jpj 
    135                               DO ji = 2, jpi 
    136                                  zke2d(ji,jj) = 0.5_wp * (   z2dx(ji,jj) + z2dx(ji-1,jj)   & 
    137                                  &                         + z2dy(ji,jj) + z2dy(ji,jj-1)   ) * r1_bt(ji,jj,1) 
    138                               END DO 
    139                            END DO 
    140                                  CALL iom_put( "ketrd_tau", zke2d ) 
    141                                  CALL wrk_dealloc( jpi, jpj     , z2dx, z2dy, zke2d ) 
    142          CASE( jpdyn_bfr )   ;   CALL iom_put( "ketrd_bfr", zke )    ! bottom friction (explicit case)  
     130                                CALL wrk_alloc( jpi, jpj, z2dx, z2dy, zke2d ) 
     131                     z2dx(:,:) = un(:,:,1) * ( utau_b(:,:) + utau(:,:) ) * e1u(:,:) * e2u(:,:) * umask(:,:,1) 
     132                     z2dy(:,:) = vn(:,:,1) * ( vtau_b(:,:) + vtau(:,:) ) * e1v(:,:) * e2v(:,:) * vmask(:,:,1) 
     133                     zke2d(1,:) = 0._wp   ;   zke2d(:,1) = 0._wp 
     134                     DO jj = 2, jpj 
     135                         DO ji = 2, jpi 
     136                           zke2d(ji,jj) = 0.5_wp * (   z2dx(ji,jj) + z2dx(ji-1,jj)   & 
     137                            &                         + z2dy(ji,jj) + z2dy(ji,jj-1)   ) * r1_bt(ji,jj,1) 
     138                         END DO 
     139                     END DO 
     140                                CALL iom_put( "ketrd_tau", zke2d ) 
     141                                CALL wrk_dealloc( jpi, jpj     , z2dx, z2dy, zke2d ) 
     142        CASE( jpdyn_bfr )   ;   CALL iom_put( "ketrd_bfr", zke )    ! bottom friction (explicit case)  
    143143!!gm TO BE DONE properly 
    144144!!gm only valid if ln_bfrimp=F otherwise the bottom stress as to be recomputed at the end of the computation.... 
    … …  
    162162!         ENDIF 
    163163!!gm end 
    164          CASE( jpdyn_atf )   ;   CALL iom_put( "ketrd_atf", zke )    ! asselin filter trends  
     164        CASE( jpdyn_atf )   ;   CALL iom_put( "ketrd_atf", zke )    ! asselin filter trends  
    165165!! a faire !!!!  idee changer dynnxt pour avoir un appel a jpdyn_bfr avant le swap !!! 
    166166!! reflechir a une possible sauvegarde du "vrai" un,vn pour le calcul de atf.... 
    … …  
    184184!                              CALL iom_put( "ketrd_bfri", zke2d ) 
    185185!         ENDIF 
    186          CASE( jpdyn_ken )   ;   ! kinetic energy 
    187                            ! called in dynnxt.F90 before asselin time filter 
    188                            ! with putrd=ua and pvtrd=va 
    189                            zke(:,:,:) = 0.5_wp * zke(:,:,:) 
    190                            CALL iom_put( "KE", zke ) 
    191                            ! 
    192                            CALL ken_p2k( kt , zke ) 
    193                            CALL iom_put( "ketrd_convP2K", zke )     ! conversion -rau*g*w 
     186        CASE( jpdyn_ken )   ;   ! kinetic energy 
     187                    ! called in dynnxt.F90 before asselin time filter 
     188                    ! with putrd=ua and pvtrd=va 
     189                    zke(:,:,:) = 0.5_wp * zke(:,:,:) 
     190                    CALL iom_put( "KE", zke ) 
     191                    ! 
     192                    CALL ken_p2k( kt , zke ) 
     193                      CALL iom_put( "ketrd_convP2K", zke )     ! conversion -rau*g*w 
    194194         ! 
    195195      END SELECT 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/TRD/trdmxl.F90

    r6836 r6839  
    165165 
    166166 
    167       SELECT CASE( ktrd ) 
    168       CASE( jptra_npc  )               ! non-penetrative convection: regrouped with zdf 
     167      SELECT CASE( ktrd ) 
     168      CASE( jptra_npc  )               ! non-penetrative convection: regrouped with zdf 
    169169!!gm : to be completed !  
    170 !        IF( .... 
     170!         IF( .... 
    171171!!gm end 
    172       CASE( jptra_zdfp )               ! iso-neutral diffusion: "pure" vertical diffusion 
    173          !                                   ! regroup iso-neutral diffusion in one term 
     172      CASE( jptra_zdfp )               ! iso-neutral diffusion: "pure" vertical diffusion 
     173         !                                   ! regroup iso-neutral diffusion in one term 
    174174         tmltrd(:,:,jpmxl_ldf) = tmltrd(:,:,jpmxl_ldf) + ( tmltrd(:,:,jpmxl_zdf) - tmltrd(:,:,jpmxl_zdfp) ) 
    175175         smltrd(:,:,jpmxl_ldf) = smltrd(:,:,jpmxl_ldf) + ( smltrd(:,:,jpmxl_zdf) - smltrd(:,:,jpmxl_zdfp) ) 
    … …  
    811811 
    812812 
    813       nkstp     = nit000 - 1              ! current time step indicator initialization 
     813      nkstp     = nit000 - 1              ! current time step indicator initialization 
    814814 
    815815 
    … …  
    851851      IF( nn_ctls == 1 ) THEN 
    852852         CALL ctl_opn( inum, 'ctlsurf_idx', 'OLD', 'UNFORMATTED', 'SEQUENTIAL', -1, numout, lwp ) 
    853          READ ( inum ) nbol 
     853         READ ( inum, * ) nbol 
    854854         CLOSE( inum ) 
    855855      END IF 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/TRD/trdmxl_oce.F90

    r6836 r6839  
    1515 
    1616   !                                                !* mixed layer trend indices 
    17    INTEGER, PUBLIC, PARAMETER ::   jpltrd = 11      !: number of mixed-layer trends arrays 
     17   INTEGER, PUBLIC, PARAMETER ::   jpltrd = 12      !: number of mixed-layer trends arrays 
    1818   INTEGER, PUBLIC            ::   jpktrd           !: max level for mixed-layer trends diag. 
    1919   ! 
    … …  
    2828   INTEGER, PUBLIC, PARAMETER ::   jpmxl_for =  9   !: forcing  
    2929   INTEGER, PUBLIC, PARAMETER ::   jpmxl_dmp = 10   !: internal restoring trend 
    30    INTEGER, PUBLIC, PARAMETER ::   jpmxl_zdfp = 11   !: asselin trend (**MUST BE THE LAST ONE**) 
    31    INTEGER, PUBLIC, PARAMETER ::   jpmxl_atf  = 12   !: asselin trend (**MUST BE THE LAST ONE**) 
     30   INTEGER, PUBLIC, PARAMETER ::   jpmxl_zdfp = 11  !: iso-neutral diffusion:"pure" vertical diffusion 
     31   INTEGER, PUBLIC, PARAMETER ::   jpmxl_atf  = 12  !: asselin trend (**MUST BE THE LAST ONE**) 
    3232   !                                                            !!* Namelist namtrd_mxl:  trend diagnostics in the mixed layer * 
    3333   INTEGER           , PUBLIC ::   nn_ctls  = 0                  !: control surface type for trends vertical integration 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/TRD/trdpen.F90

    r6836 r6839  
    9999                                   CALL wrk_alloc( jpi, jpj, z2d ) 
    100100                                   z2d(:,:) = wn(:,:,1) * ( & 
    101                                       &   - ( rab_n(:,:,1,jp_tem) + rab_pe(:,:,1,jp_tem) ) * tsn(:,:,1,jp_tem)    & 
    102                                       &   + ( rab_n(:,:,1,jp_sal) + rab_pe(:,:,1,jp_sal) ) * tsn(:,:,1,jp_sal)    & 
    103                                       &                  ) / fse3t(:,:,1) 
     101                                       &   - ( rab_n(:,:,1,jp_tem) + rab_pe(:,:,1,jp_tem) ) * tsn(:,:,1,jp_tem)    & 
     102                                       &   + ( rab_n(:,:,1,jp_sal) + rab_pe(:,:,1,jp_sal) ) * tsn(:,:,1,jp_sal)    & 
     103                                       &             ) / fse3t(:,:,1) 
    104104                                   CALL iom_put( "petrd_sad" , z2d ) 
    105105                                   CALL wrk_dealloc( jpi, jpj, z2d ) 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/ZDF/zdf_oce.F90

    r6836 r6839  
    4343   REAL(wp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:,:) ::   avmu , avmv    !: vertical viscosity coef at uw- & vw-pts       [m2/s] 
    4444   REAL(wp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:,:) ::   avm  , avt     !: vertical viscosity & diffusivity coef at w-pt [m2/s] 
     45   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   avt_k , avm_k  ! not enhanced Kz 
     46   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   avmu_k, avmv_k ! not enhanced Kz 
     47   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   en              !: now turbulent kinetic energy   [m2/s2] 
    4548  
    4649   !!---------------------------------------------------------------------- 
    … …  
    6063         &     tfrua(jpi, jpj), tfrva(jpi, jpj)              ,      & 
    6164         &     avmu(jpi,jpj,jpk), avm(jpi,jpj,jpk)           ,      & 
    62          &     avmv(jpi,jpj,jpk), avt(jpi,jpj,jpk)           , STAT = zdf_oce_alloc ) 
     65         &     avmv  (jpi,jpj,jpk), avt   (jpi,jpj,jpk)      ,      & 
     66         &     avt_k (jpi,jpj,jpk), avm_k (jpi,jpj,jpk)      ,      &  
     67         &     avmu_k(jpi,jpj,jpk), avmv_k(jpi,jpj,jpk)      ,      & 
     68         &     en    (jpi,jpj,jpk), STAT = zdf_oce_alloc ) 
    6369         ! 
    6470      IF( zdf_oce_alloc /= 0 )   CALL ctl_warn('zdf_oce_alloc: failed to allocate arrays') 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfddm.F90

    r6836 r6839  
    177177                  &                             +  0.15 * zrau(ji,jj)          * zmskd2(ji,jj)  ) 
    178178               ! add to the eddy viscosity coef. previously computed 
     179# if defined key_zdftmx_new 
     180               ! key_zdftmx_new: New internal wave-driven param: use avs value computed by zdftmx 
     181               avs (ji,jj,jk) = avs(ji,jj,jk) + zavfs + zavds 
     182# else 
    179183               avs (ji,jj,jk) = avt(ji,jj,jk) + zavfs + zavds 
     184# endif 
    180185               avt (ji,jj,jk) = avt(ji,jj,jk) + zavft + zavdt 
    181186               avm (ji,jj,jk) = avm(ji,jj,jk) + MAX( zavft + zavdt, zavfs + zavds ) 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfgls.F90

    r6836 r6839  
    4242   LOGICAL , PUBLIC, PARAMETER ::   lk_zdfgls = .TRUE.   !: TKE vertical mixing flag 
    4343   ! 
    44    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   en      !: now turbulent kinetic energy 
    4544   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   mxln    !: now mixing length 
    4645   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   zwall   !: wall function 
    47    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   avt_k   ! not enhanced Kz 
    48    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   avm_k   ! not enhanced Kz 
    49    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   avmu_k  ! not enhanced Kz 
    50    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   avmv_k  ! not enhanced Kz 
    5146   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   ustars2 !: Squared surface velocity scale at T-points 
    5247   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   ustarb2 !: Squared bottom  velocity scale at T-points 
    … …  
    120115      !!                ***  FUNCTION zdf_gls_alloc  *** 
    121116      !!---------------------------------------------------------------------- 
    122       ALLOCATE( en(jpi,jpj,jpk),  mxln(jpi,jpj,jpk), zwall(jpi,jpj,jpk) ,     & 
    123          &      avt_k (jpi,jpj,jpk) , avm_k (jpi,jpj,jpk),                    & 
    124          &      avmu_k(jpi,jpj,jpk) , avmv_k(jpi,jpj,jpk),                    & 
    125          &      ustars2(jpi,jpj), ustarb2(jpi,jpj)                      , STAT= zdf_gls_alloc ) 
     117      ALLOCATE( mxln(jpi,jpj,jpk), zwall(jpi,jpj,jpk) ,     & 
     118         &      ustars2(jpi,jpj) , ustarb2(jpi,jpj)   , STAT= zdf_gls_alloc ) 
    126119         ! 
    127120      IF( lk_mpp             )   CALL mpp_sum ( zdf_gls_alloc ) 
    … …  
    329322      !  
    330323      ! One level below 
    331       en(:,:,2) = rc02r * ustars2(:,:) * (1._wp + rsbc_tke1 * ((zhsro(:,:)+fsdepw(:,:,2))/zhsro(:,:) )**(1.5_wp*ra_sf))**(2._wp/3._wp) 
     324      en(:,:,2) = rc02r * ustars2(:,:) * (1._wp + rsbc_tke1 * ((zhsro(:,:)+fsdepw(:,:,2)) & 
     325          &            / zhsro(:,:) )**(1.5_wp*ra_sf))**(2._wp/3._wp) 
    332326      en(:,:,2) = MAX(en(:,:,2), rn_emin ) 
    333327      z_elem_a(:,:,2) = 0._wp  
    … …  
    350344      z_elem_a(:,:,2) = 0._wp 
    351345      zkar(:,:)       = (rl_sf + (vkarmn-rl_sf)*(1.-exp(-rtrans*fsdept(:,:,1)/zhsro(:,:)) )) 
    352       zflxs(:,:)      = rsbc_tke2 * ustars2(:,:)**1.5_wp * zkar(:,:) * ((zhsro(:,:)+fsdept(:,:,1))/zhsro(:,:) )**(1.5_wp*ra_sf) 
     346      zflxs(:,:)      = rsbc_tke2 * ustars2(:,:)**1.5_wp * zkar(:,:) & 
     347           &                      * ((zhsro(:,:)+fsdept(:,:,1))/zhsro(:,:) )**(1.5_wp*ra_sf) 
    353348 
    354349      en(:,:,2) = en(:,:,2) + zflxs(:,:)/fse3w(:,:,2) 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfmxl.F90

    r6836 r6839  
    2727 
    2828   PUBLIC   zdf_mxl       ! called by step.F90 
     29   PUBLIC   zdf_mxl_alloc ! Used in zdf_tke_init 
    2930 
    3031   INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   nmln    !: number of level in the mixed layer (used by TOP) 
    … …  
    7980      INTEGER, INTENT(in) ::   kt   ! ocean time-step index 
    8081      ! 
    81       INTEGER  ::   ji, jj, jk   ! dummy loop indices 
    82       INTEGER  ::   iikn, iiki, ikt, imkt  ! local integer 
    83       REAL(wp) ::   zN2_c        ! local scalar 
     82      INTEGER  ::   ji, jj, jk      ! dummy loop indices 
     83      INTEGER  ::   iikn, iiki, ikt ! local integer 
     84      REAL(wp) ::   zN2_c           ! local scalar 
    8485      INTEGER, POINTER, DIMENSION(:,:) ::   imld   ! 2D workspace 
    8586      !!---------------------------------------------------------------------- 
    … …  
    116117         DO jj = 1, jpj 
    117118            DO ji = 1, jpi 
    118                imkt = mikt(ji,jj) 
    119                IF( avt (ji,jj,jk) < avt_c )   imld(ji,jj) = MAX( imkt, jk )      ! Turbocline  
     119               IF( avt (ji,jj,jk) < avt_c * wmask(ji,jj,jk) )   imld(ji,jj) = jk      ! Turbocline  
    120120            END DO 
    121121         END DO 
    … …  
    126126            iiki = imld(ji,jj) 
    127127            iikn = nmln(ji,jj) 
    128             imkt = mikt(ji,jj) 
    129             hmld (ji,jj) = ( fsdepw(ji,jj,iiki  ) - fsdepw(ji,jj,imkt )            )   * ssmask(ji,jj)    ! Turbocline depth  
    130             hmlp (ji,jj) = ( fsdepw(ji,jj,iikn  ) - fsdepw(ji,jj,MAX( imkt,nla10 ) ) ) * ssmask(ji,jj)    ! Mixed layer depth 
    131             hmlpt(ji,jj) = ( fsdept(ji,jj,iikn-1) - fsdepw(ji,jj,imkt )            )   * ssmask(ji,jj)    ! depth of the last T-point inside the mixed layer 
     128            hmld (ji,jj) = fsdepw(ji,jj,iiki  ) * ssmask(ji,jj)    ! Turbocline depth  
     129            hmlp (ji,jj) = fsdepw(ji,jj,iikn  ) * ssmask(ji,jj)    ! Mixed layer depth 
     130            hmlpt(ji,jj) = fsdept(ji,jj,iikn-1) * ssmask(ji,jj)    ! depth of the last T-point inside the mixed layer 
    132131         END DO 
    133132      END DO 
    134       IF( .NOT.lk_offline ) THEN            ! no need to output in offline mode 
    135          CALL iom_put( "mldr10_1", hmlp )   ! mixed layer depth 
    136          CALL iom_put( "mldkz5"  , hmld )   ! turbocline depth 
     133      ! no need to output in offline mode 
     134      IF( .NOT.lk_offline ) THEN    
     135         IF ( iom_use("mldr10_1") ) THEN 
     136            IF( ln_isfcav ) THEN 
     137               CALL iom_put( "mldr10_1", hmlp - risfdep)   ! mixed layer thickness 
     138            ELSE 
     139               CALL iom_put( "mldr10_1", hmlp )            ! mixed layer depth 
     140            END IF 
     141         END IF 
     142         IF ( iom_use("mldkz5") ) THEN 
     143            IF( ln_isfcav ) THEN 
     144               CALL iom_put( "mldkz5"  , hmld - risfdep )   ! turbocline thickness 
     145            ELSE 
     146               CALL iom_put( "mldkz5"  , hmld )             ! turbocline depth 
     147            END IF 
     148         END IF 
    137149      ENDIF 
    138150       

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/ZDF/zdftke.F90

    r6836 r6839  
    5353   USE timing         ! Timing 
    5454   USE lib_fortran    ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)   
     55#if defined key_agrif 
     56   USE agrif_opa_interp 
     57   USE agrif_opa_update 
     58#endif 
     59 
     60 
    5561 
    5662   IMPLICIT NONE 
    … …  
    8591   REAL(wp) ::   rhftau_scl = 1.0_wp       ! scale factor applied to HF part of taum  (nn_etau=3) 
    8692 
    87    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   en             !: now turbulent kinetic energy   [m2/s2] 
    8893   REAL(wp)        , ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   htau           ! depth of tke penetration (nn_htau) 
    8994   REAL(wp)        , ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   dissl          ! now mixing lenght of dissipation 
    90    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   avt_k , avm_k  ! not enhanced Kz 
    91    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   avmu_k, avmv_k ! not enhanced Kz 
    9295#if defined key_c1d 
    9396   !                                                                        !!** 1D cfg only  **   ('key_c1d') 
    … …  
    115118         &      e_pdl(jpi,jpj,jpk) , e_ric(jpi,jpj,jpk) ,                          & 
    116119#endif 
    117          &      en    (jpi,jpj,jpk) , htau  (jpi,jpj)    , dissl(jpi,jpj,jpk) ,     &  
    118          &      avt_k (jpi,jpj,jpk) , avm_k (jpi,jpj,jpk),                          & 
    119          &      avmu_k(jpi,jpj,jpk) , avmv_k(jpi,jpj,jpk), STAT= zdf_tke_alloc      ) 
     120         &      htau  (jpi,jpj)    , dissl(jpi,jpj,jpk) , STAT= zdf_tke_alloc      ) 
    120121         ! 
    121122      IF( lk_mpp             )   CALL mpp_sum ( zdf_tke_alloc ) 
    … …  
    189190      avmv_k(:,:,:) = avmv(:,:,:)  
    190191      ! 
     192#if defined key_agrif 
     193      ! Update child grid f => parent grid  
     194      IF( .NOT.Agrif_Root() )   CALL Agrif_Update_Tke( kt )      ! children only 
     195#endif       
     196     !  
    191197   END SUBROUTINE zdf_tke 
    192198 
    … …  
    317323                  zwlc = zind * rn_lc * zus * SIN( rpi * fsdepw(ji,jj,jk) / zhlc(ji,jj) ) 
    318324                  !                                           ! TKE Langmuir circulation source term 
    319                   en(ji,jj,jk) = en(ji,jj,jk) + rdt * ( zwlc * zwlc * zwlc ) / zhlc(ji,jj) * wmask(ji,jj,jk) * tmask(ji,jj,1) 
     325                  en(ji,jj,jk) = en(ji,jj,jk) + rdt * ( 1._wp - fr_i(ji,jj) ) * ( zwlc * zwlc * zwlc ) /   & 
     326                     &   zhlc(ji,jj) * wmask(ji,jj,jk) * tmask(ji,jj,1) 
    320327               END DO 
    321328            END DO 
    … …  
    350357            DO ji = fs_2, fs_jpim1   ! vector opt. 
    351358               zcof   = zfact1 * tmask(ji,jj,jk) 
     359# if defined key_zdftmx_new 
     360               ! key_zdftmx_new: New internal wave-driven param: set a minimum value for Kz on TKE (ensure numerical stability) 
     361               zzd_up = zcof * ( MAX( avm(ji,jj,jk+1) + avm(ji,jj,jk), 2.e-5_wp ) )   &  ! upper diagonal 
     362                  &          / ( fse3t(ji,jj,jk  ) * fse3w(ji,jj,jk  ) ) 
     363               zzd_lw = zcof * ( MAX( avm(ji,jj,jk) + avm(ji,jj,jk-1), 2.e-5_wp ) )   &  ! lower diagonal 
     364                  &          / ( fse3t(ji,jj,jk-1) * fse3w(ji,jj,jk  ) ) 
     365# else 
    352366               zzd_up = zcof * ( avm  (ji,jj,jk+1) + avm  (ji,jj,jk  ) )   &  ! upper diagonal 
    353367                  &          / ( fse3t(ji,jj,jk  ) * fse3w(ji,jj,jk  ) ) 
    354368               zzd_lw = zcof * ( avm  (ji,jj,jk  ) + avm  (ji,jj,jk-1) )   &  ! lower diagonal 
    355369                  &          / ( fse3t(ji,jj,jk-1) * fse3w(ji,jj,jk  ) ) 
     370# endif 
    356371                  !                                                           ! shear prod. at w-point weightened by mask 
    357372               zesh2  =  ( avmu(ji-1,jj,jk) + avmu(ji,jj,jk) ) / MAX( 1._wp , umask(ji-1,jj,jk) + umask(ji,jj,jk) )   & 
    … …  
    710725      !!---------------------------------------------------------------------- 
    711726      INTEGER ::   ji, jj, jk   ! dummy loop indices 
    712       INTEGER ::   ios 
     727      INTEGER ::   ios, ierr 
    713728      !! 
    714729      NAMELIST/namzdf_tke/ rn_ediff, rn_ediss , rn_ebb , rn_emin  ,   & 
    … …  
    728743      ! 
    729744      ri_cri   = 2._wp    / ( 2._wp + rn_ediss / rn_ediff )   ! resulting critical Richardson number 
     745# if defined key_zdftmx_new 
     746      ! key_zdftmx_new: New internal wave-driven param: specified value of rn_emin & rmxl_min are used 
     747      rn_emin  = 1.e-10_wp 
     748      rmxl_min = 1.e-03_wp 
     749      IF(lwp) THEN                  ! Control print 
     750         WRITE(numout,*) 
     751         WRITE(numout,*) 'zdf_tke_init :  New tidal mixing case: force rn_emin = 1.e-10 and rmxl_min = 1.e-3 ' 
     752         WRITE(numout,*) '~~~~~~~~~~~~' 
     753      ENDIF 
     754# else 
    730755      rmxl_min = 1.e-6_wp / ( rn_ediff * SQRT( rn_emin ) )    ! resulting minimum length to recover molecular viscosity 
     756# endif 
    731757      ! 
    732758      IF(lwp) THEN                    !* Control print 
    … …  
    768794      ENDIF 
    769795       
    770       IF( nn_etau == 2  )   CALL zdf_mxl( nit000 )      ! Initialization of nmln  
     796      IF( nn_etau == 2  ) THEN 
     797          ierr = zdf_mxl_alloc() 
     798          nmln(:,:) = nlb10           ! Initialization of nmln 
     799      ENDIF 
    771800 
    772801      !                               !* depth of penetration of surface tke 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/ZDF/zdftmx.F90

    r6836 r6839  
    561561   END SUBROUTINE zdf_tmx_init 
    562562 
     563#elif defined key_zdftmx_new 
     564   !!---------------------------------------------------------------------- 
     565   !!   'key_zdftmx_new'               Internal wave-driven vertical mixing 
     566   !!---------------------------------------------------------------------- 
     567   !!   zdf_tmx       : global     momentum & tracer Kz with wave induced Kz 
     568   !!   zdf_tmx_init  : global     momentum & tracer Kz with wave induced Kz 
     569   !!---------------------------------------------------------------------- 
     570   USE oce            ! ocean dynamics and tracers variables 
     571   USE dom_oce        ! ocean space and time domain variables 
     572   USE zdf_oce        ! ocean vertical physics variables 
     573   USE zdfddm         ! ocean vertical physics: double diffusive mixing 
     574   USE lbclnk         ! ocean lateral boundary conditions (or mpp link) 
     575   USE eosbn2         ! ocean equation of state 
     576   USE phycst         ! physical constants 
     577   USE prtctl         ! Print control 
     578   USE in_out_manager ! I/O manager 
     579   USE iom            ! I/O Manager 
     580   USE lib_mpp        ! MPP library 
     581   USE wrk_nemo       ! work arrays 
     582   USE timing         ! Timing 
     583   USE lib_fortran    ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)   
     584 
     585   IMPLICIT NONE 
     586   PRIVATE 
     587 
     588   PUBLIC   zdf_tmx         ! called in step module  
     589   PUBLIC   zdf_tmx_init    ! called in nemogcm module  
     590   PUBLIC   zdf_tmx_alloc   ! called in nemogcm module 
     591 
     592   LOGICAL, PUBLIC, PARAMETER ::   lk_zdftmx = .TRUE.    !: wave-driven mixing flag 
     593 
     594   !                       !!* Namelist  namzdf_tmx : internal wave-driven mixing * 
     595   INTEGER  ::  nn_zpyc     ! pycnocline-intensified mixing energy proportional to N (=1) or N^2 (=2) 
     596   LOGICAL  ::  ln_mevar    ! variable (=T) or constant (=F) mixing efficiency 
     597   LOGICAL  ::  ln_tsdiff   ! account for differential T/S wave-driven mixing (=T) or not (=F) 
     598 
     599   REAL(wp) ::  r1_6 = 1._wp / 6._wp 
     600 
     601   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   ebot_tmx     ! power available from high-mode wave breaking (W/m2) 
     602   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   epyc_tmx     ! power available from low-mode, pycnocline-intensified wave breaking (W/m2) 
     603   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   ecri_tmx     ! power available from low-mode, critical slope wave breaking (W/m2) 
     604   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   hbot_tmx     ! WKB decay scale for high-mode energy dissipation (m) 
     605   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   hcri_tmx     ! decay scale for low-mode critical slope dissipation (m) 
     606   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   emix_tmx     ! local energy density available for mixing (W/kg) 
     607   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   bflx_tmx     ! buoyancy flux Kz * N^2 (W/kg) 
     608   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   pcmap_tmx    ! vertically integrated buoyancy flux (W/m2) 
     609   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   zav_ratio    ! S/T diffusivity ratio (only for ln_tsdiff=T) 
     610   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   zav_wave     ! Internal wave-induced diffusivity 
     611 
     612   !! * Substitutions 
     613#  include "zdfddm_substitute.h90" 
     614#  include "domzgr_substitute.h90" 
     615#  include "vectopt_loop_substitute.h90" 
     616   !!---------------------------------------------------------------------- 
     617   !! NEMO/OPA 4.0 , NEMO Consortium (2016) 
     618   !! $Id$ 
     619   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
     620   !!---------------------------------------------------------------------- 
     621CONTAINS 
     622 
     623   INTEGER FUNCTION zdf_tmx_alloc() 
     624      !!---------------------------------------------------------------------- 
     625      !!                ***  FUNCTION zdf_tmx_alloc  *** 
     626      !!---------------------------------------------------------------------- 
     627      ALLOCATE(     ebot_tmx(jpi,jpj),  epyc_tmx(jpi,jpj),  ecri_tmx(jpi,jpj)    ,   & 
     628      &             hbot_tmx(jpi,jpj),  hcri_tmx(jpi,jpj),  emix_tmx(jpi,jpj,jpk),   & 
     629      &         bflx_tmx(jpi,jpj,jpk), pcmap_tmx(jpi,jpj), zav_ratio(jpi,jpj,jpk),   &  
     630      &         zav_wave(jpi,jpj,jpk), STAT=zdf_tmx_alloc     ) 
     631      ! 
     632      IF( lk_mpp             )   CALL mpp_sum ( zdf_tmx_alloc ) 
     633      IF( zdf_tmx_alloc /= 0 )   CALL ctl_warn('zdf_tmx_alloc: failed to allocate arrays') 
     634   END FUNCTION zdf_tmx_alloc 
     635 
     636 
     637   SUBROUTINE zdf_tmx( kt ) 
     638      !!---------------------------------------------------------------------- 
     639      !!                  ***  ROUTINE zdf_tmx  *** 
     640      !!                    
     641      !! ** Purpose :   add to the vertical mixing coefficients the effect of 
     642      !!              breaking internal waves. 
     643      !! 
     644      !! ** Method  : - internal wave-driven vertical mixing is given by: 
     645      !!                  Kz_wave = min(  100 cm2/s, f(  Reb = emix_tmx /( Nu * N^2 )  ) 
     646      !!              where emix_tmx is the 3D space distribution of the wave-breaking  
     647      !!              energy and Nu the molecular kinematic viscosity. 
     648      !!              The function f(Reb) is linear (constant mixing efficiency) 
     649      !!              if the namelist parameter ln_mevar = F and nonlinear if ln_mevar = T. 
     650      !! 
     651      !!              - Compute emix_tmx, the 3D power density that allows to compute 
     652      !!              Reb and therefrom the wave-induced vertical diffusivity. 
     653      !!              This is divided into three components: 
     654      !!                 1. Bottom-intensified low-mode dissipation at critical slopes 
     655      !!                     emix_tmx(z) = ( ecri_tmx / rau0 ) * EXP( -(H-z)/hcri_tmx ) 
     656      !!                                   / ( 1. - EXP( - H/hcri_tmx ) ) * hcri_tmx 
     657      !!              where hcri_tmx is the characteristic length scale of the bottom  
     658      !!              intensification, ecri_tmx a map of available power, and H the ocean depth. 
     659      !!                 2. Pycnocline-intensified low-mode dissipation 
     660      !!                     emix_tmx(z) = ( epyc_tmx / rau0 ) * ( sqrt(rn2(z))^nn_zpyc ) 
     661      !!                                   / SUM( sqrt(rn2(z))^nn_zpyc * e3w(z) ) 
     662      !!              where epyc_tmx is a map of available power, and nn_zpyc 
     663      !!              is the chosen stratification-dependence of the internal wave 
     664      !!              energy dissipation. 
     665      !!                 3. WKB-height dependent high mode dissipation 
     666      !!                     emix_tmx(z) = ( ebot_tmx / rau0 ) * rn2(z) * EXP(-z_wkb(z)/hbot_tmx) 
     667      !!                                   / SUM( rn2(z) * EXP(-z_wkb(z)/hbot_tmx) * e3w(z) ) 
     668      !!              where hbot_tmx is the characteristic length scale of the WKB bottom  
     669      !!              intensification, ebot_tmx is a map of available power, and z_wkb is the 
     670      !!              WKB-stretched height above bottom defined as 
     671      !!                    z_wkb(z) = H * SUM( sqrt(rn2(z'>=z)) * e3w(z'>=z) ) 
     672      !!                                 / SUM( sqrt(rn2(z'))    * e3w(z')    ) 
     673      !! 
     674      !!              - update the model vertical eddy viscosity and diffusivity:  
     675      !!                     avt  = avt  +    av_wave 
     676      !!                     avm  = avm  +    av_wave 
     677      !!                     avmu = avmu + mi(av_wave) 
     678      !!                     avmv = avmv + mj(av_wave) 
     679      !! 
     680      !!              - if namelist parameter ln_tsdiff = T, account for differential mixing: 
     681      !!                     avs  = avt  +    av_wave * diffusivity_ratio(Reb) 
     682      !! 
     683      !! ** Action  : - Define emix_tmx used to compute internal wave-induced mixing 
     684      !!              - avt, avs, avm, avmu, avmv increased by internal wave-driven mixing     
     685      !! 
     686      !! References :  de Lavergne et al. 2015, JPO; 2016, in prep. 
     687      !!---------------------------------------------------------------------- 
     688      INTEGER, INTENT(in) ::   kt   ! ocean time-step  
     689      ! 
     690      INTEGER  ::   ji, jj, jk   ! dummy loop indices 
     691      REAL(wp) ::   ztpc         ! scalar workspace 
     692      REAL(wp), DIMENSION(:,:)  , POINTER ::  zfact     ! Used for vertical structure 
     693      REAL(wp), DIMENSION(:,:)  , POINTER ::  zhdep     ! Ocean depth 
     694      REAL(wp), DIMENSION(:,:,:), POINTER ::  zwkb      ! WKB-stretched height above bottom 
     695      REAL(wp), DIMENSION(:,:,:), POINTER ::  zweight   ! Weight for high mode vertical distribution 
     696      REAL(wp), DIMENSION(:,:,:), POINTER ::  znu_t     ! Molecular kinematic viscosity (T grid) 
     697      REAL(wp), DIMENSION(:,:,:), POINTER ::  znu_w     ! Molecular kinematic viscosity (W grid) 
     698      REAL(wp), DIMENSION(:,:,:), POINTER ::  zReb      ! Turbulence intensity parameter 
     699      !!---------------------------------------------------------------------- 
     700      ! 
     701      IF( nn_timing == 1 )   CALL timing_start('zdf_tmx') 
     702      ! 
     703      CALL wrk_alloc( jpi,jpj,       zfact, zhdep ) 
     704      CALL wrk_alloc( jpi,jpj,jpk,   zwkb, zweight, znu_t, znu_w, zReb ) 
     705 
     706      !                          ! ----------------------------- ! 
     707      !                          !  Internal wave-driven mixing  !  (compute zav_wave) 
     708      !                          ! ----------------------------- ! 
     709      !                              
     710      !                        !* Critical slope mixing: distribute energy over the time-varying ocean depth, 
     711      !                                                 using an exponential decay from the seafloor. 
     712      DO jj = 1, jpj                ! part independent of the level 
     713         DO ji = 1, jpi 
     714            zhdep(ji,jj) = fsdepw(ji,jj,mbkt(ji,jj)+1)       ! depth of the ocean 
     715            zfact(ji,jj) = rau0 * (  1._wp - EXP( -zhdep(ji,jj) / hcri_tmx(ji,jj) )  ) 
     716            IF( zfact(ji,jj) /= 0 )   zfact(ji,jj) = ecri_tmx(ji,jj) / zfact(ji,jj) 
     717         END DO 
     718      END DO 
     719 
     720      DO jk = 2, jpkm1              ! complete with the level-dependent part 
     721         emix_tmx(:,:,jk) = zfact(:,:) * (  EXP( ( fsde3w(:,:,jk  ) - zhdep(:,:) ) / hcri_tmx(:,:) )                      & 
     722            &                             - EXP( ( fsde3w(:,:,jk-1) - zhdep(:,:) ) / hcri_tmx(:,:) )  ) * wmask(:,:,jk)   & 
     723            &                          / ( fsde3w(:,:,jk) - fsde3w(:,:,jk-1) ) 
     724      END DO 
     725 
     726      !                        !* Pycnocline-intensified mixing: distribute energy over the time-varying  
     727      !                        !* ocean depth as proportional to sqrt(rn2)^nn_zpyc 
     728 
     729      SELECT CASE ( nn_zpyc ) 
     730 
     731      CASE ( 1 )               ! Dissipation scales as N (recommended) 
     732 
     733         zfact(:,:) = 0._wp 
     734         DO jk = 2, jpkm1              ! part independent of the level 
     735            zfact(:,:) = zfact(:,:) + fse3w(:,:,jk) * SQRT(  MAX( 0._wp, rn2(:,:,jk) )  ) * wmask(:,:,jk) 
     736         END DO 
     737 
     738         DO jj = 1, jpj 
     739            DO ji = 1, jpi 
     740               IF( zfact(ji,jj) /= 0 )   zfact(ji,jj) = epyc_tmx(ji,jj) / ( rau0 * zfact(ji,jj) ) 
     741            END DO 
     742         END DO 
     743 
     744         DO jk = 2, jpkm1              ! complete with the level-dependent part 
     745            emix_tmx(:,:,jk) = emix_tmx(:,:,jk) + zfact(:,:) * SQRT(  MAX( 0._wp, rn2(:,:,jk) )  ) * wmask(:,:,jk) 
     746         END DO 
     747 
     748      CASE ( 2 )               ! Dissipation scales as N^2 
     749 
     750         zfact(:,:) = 0._wp 
     751         DO jk = 2, jpkm1              ! part independent of the level 
     752            zfact(:,:) = zfact(:,:) + fse3w(:,:,jk) * MAX( 0._wp, rn2(:,:,jk) ) * wmask(:,:,jk) 
     753         END DO 
     754 
     755         DO jj= 1, jpj 
     756            DO ji = 1, jpi 
     757               IF( zfact(ji,jj) /= 0 )   zfact(ji,jj) = epyc_tmx(ji,jj) / ( rau0 * zfact(ji,jj) ) 
     758            END DO 
     759         END DO 
     760 
     761         DO jk = 2, jpkm1              ! complete with the level-dependent part 
     762            emix_tmx(:,:,jk) = emix_tmx(:,:,jk) + zfact(:,:) * MAX( 0._wp, rn2(:,:,jk) ) * wmask(:,:,jk) 
     763         END DO 
     764 
     765      END SELECT 
     766 
     767      !                        !* WKB-height dependent mixing: distribute energy over the time-varying  
     768      !                        !* ocean depth as proportional to rn2 * exp(-z_wkb/rn_hbot) 
     769       
     770      zwkb(:,:,:) = 0._wp 
     771      zfact(:,:) = 0._wp 
     772      DO jk = 2, jpkm1 
     773         zfact(:,:) = zfact(:,:) + fse3w(:,:,jk) * SQRT(  MAX( 0._wp, rn2(:,:,jk) )  ) * wmask(:,:,jk) 
     774         zwkb(:,:,jk) = zfact(:,:) 
     775      END DO 
     776 
     777      DO jk = 2, jpkm1 
     778         DO jj = 1, jpj 
     779            DO ji = 1, jpi 
     780               IF( zfact(ji,jj) /= 0 )   zwkb(ji,jj,jk) = zhdep(ji,jj) * ( zfact(ji,jj) - zwkb(ji,jj,jk) )   & 
     781                                            &           * tmask(ji,jj,jk) / zfact(ji,jj) 
     782            END DO 
     783         END DO 
     784      END DO 
     785      zwkb(:,:,1) = zhdep(:,:) * tmask(:,:,1) 
     786 
     787      zweight(:,:,:) = 0._wp 
     788      DO jk = 2, jpkm1 
     789         zweight(:,:,jk) = MAX( 0._wp, rn2(:,:,jk) ) * hbot_tmx(:,:) * wmask(:,:,jk)                    & 
     790            &   * (  EXP( -zwkb(:,:,jk) / hbot_tmx(:,:) ) - EXP( -zwkb(:,:,jk-1) / hbot_tmx(:,:) )  ) 
     791      END DO 
     792 
     793      zfact(:,:) = 0._wp 
     794      DO jk = 2, jpkm1              ! part independent of the level 
     795         zfact(:,:) = zfact(:,:) + zweight(:,:,jk) 
     796      END DO 
     797 
     798      DO jj = 1, jpj 
     799         DO ji = 1, jpi 
     800            IF( zfact(ji,jj) /= 0 )   zfact(ji,jj) = ebot_tmx(ji,jj) / ( rau0 * zfact(ji,jj) ) 
     801         END DO 
     802      END DO 
     803 
     804      DO jk = 2, jpkm1              ! complete with the level-dependent part 
     805         emix_tmx(:,:,jk) = emix_tmx(:,:,jk) + zweight(:,:,jk) * zfact(:,:) * wmask(:,:,jk)   & 
     806            &                                / ( fsde3w(:,:,jk) - fsde3w(:,:,jk-1) ) 
     807      END DO 
     808 
     809 
     810      ! Calculate molecular kinematic viscosity 
     811      znu_t(:,:,:) = 1.e-4_wp * (  17.91_wp - 0.53810_wp * tsn(:,:,:,jp_tem) + 0.00694_wp * tsn(:,:,:,jp_tem) * tsn(:,:,:,jp_tem)  & 
     812         &                                  + 0.02305_wp * tsn(:,:,:,jp_sal)  ) * tmask(:,:,:) * r1_rau0 
     813      DO jk = 2, jpkm1 
     814         znu_w(:,:,jk) = 0.5_wp * ( znu_t(:,:,jk-1) + znu_t(:,:,jk) ) * wmask(:,:,jk) 
     815      END DO 
     816 
     817      ! Calculate turbulence intensity parameter Reb 
     818      DO jk = 2, jpkm1 
     819         zReb(:,:,jk) = emix_tmx(:,:,jk) / MAX( 1.e-20_wp, znu_w(:,:,jk) * rn2(:,:,jk) ) 
     820      END DO 
     821 
     822      ! Define internal wave-induced diffusivity 
     823      DO jk = 2, jpkm1 
     824         zav_wave(:,:,jk) = znu_w(:,:,jk) * zReb(:,:,jk) * r1_6   ! This corresponds to a constant mixing efficiency of 1/6 
     825      END DO 
     826 
     827      IF( ln_mevar ) THEN              ! Variable mixing efficiency case : modify zav_wave in the 
     828         DO jk = 2, jpkm1              ! energetic (Reb > 480) and buoyancy-controlled (Reb <10.224 ) regimes 
     829            DO jj = 1, jpj 
     830               DO ji = 1, jpi 
     831                  IF( zReb(ji,jj,jk) > 480.00_wp ) THEN 
     832                     zav_wave(ji,jj,jk) = 3.6515_wp * znu_w(ji,jj,jk) * SQRT( zReb(ji,jj,jk) ) 
     833                  ELSEIF( zReb(ji,jj,jk) < 10.224_wp ) THEN 
     834                     zav_wave(ji,jj,jk) = 0.052125_wp * znu_w(ji,jj,jk) * zReb(ji,jj,jk) * SQRT( zReb(ji,jj,jk) ) 
     835                  ENDIF 
     836               END DO 
     837            END DO 
     838         END DO 
     839      ENDIF 
     840 
     841      DO jk = 2, jpkm1                 ! Bound diffusivity by molecular value and 100 cm2/s 
     842         zav_wave(:,:,jk) = MIN(  MAX( 1.4e-7_wp, zav_wave(:,:,jk) ), 1.e-2_wp  ) * wmask(:,:,jk) 
     843      END DO 
     844 
     845      IF( kt == nit000 ) THEN        !* Control print at first time-step: diagnose the energy consumed by zav_wave 
     846         ztpc = 0._wp 
     847         DO jk = 2, jpkm1 
     848            DO jj = 1, jpj 
     849               DO ji = 1, jpi 
     850                  ztpc = ztpc + fse3w(ji,jj,jk) * e1e2t(ji,jj)   & 
     851                     &         * MAX( 0._wp, rn2(ji,jj,jk) ) * zav_wave(ji,jj,jk) * wmask(ji,jj,jk) * tmask_i(ji,jj) 
     852               END DO 
     853            END DO 
     854         END DO 
     855         IF( lk_mpp )   CALL mpp_sum( ztpc ) 
     856         ztpc = rau0 * ztpc ! Global integral of rauo * Kz * N^2 = power contributing to mixing  
     857  
     858         IF(lwp) THEN 
     859            WRITE(numout,*) 
     860            WRITE(numout,*) 'zdf_tmx : Internal wave-driven mixing (tmx)' 
     861            WRITE(numout,*) '~~~~~~~ ' 
     862            WRITE(numout,*) 
     863            WRITE(numout,*) '      Total power consumption by av_wave: ztpc =  ', ztpc * 1.e-12_wp, 'TW' 
     864         ENDIF 
     865      ENDIF 
     866 
     867      !                          ! ----------------------- ! 
     868      !                          !   Update  mixing coefs  !                           
     869      !                          ! ----------------------- ! 
     870      !       
     871      IF( ln_tsdiff ) THEN          !* Option for differential mixing of salinity and temperature 
     872         DO jk = 2, jpkm1              ! Calculate S/T diffusivity ratio as a function of Reb 
     873            DO jj = 1, jpj 
     874               DO ji = 1, jpi 
     875                  zav_ratio(ji,jj,jk) = ( 0.505_wp + 0.495_wp *                                                                  & 
     876                      &   TANH(    0.92_wp * (   LOG10(  MAX( 1.e-20_wp, zReb(ji,jj,jk) * 5._wp * r1_6 )  ) - 0.60_wp   )    )   & 
     877                      &                 ) * wmask(ji,jj,jk) 
     878               END DO 
     879            END DO 
     880         END DO 
     881         CALL iom_put( "av_ratio", zav_ratio ) 
     882         DO jk = 2, jpkm1           !* update momentum & tracer diffusivity with wave-driven mixing 
     883            fsavs(:,:,jk) = avt(:,:,jk) + zav_wave(:,:,jk) * zav_ratio(:,:,jk) 
     884            avt  (:,:,jk) = avt(:,:,jk) + zav_wave(:,:,jk) 
     885            avm  (:,:,jk) = avm(:,:,jk) + zav_wave(:,:,jk) 
     886         END DO 
     887         ! 
     888      ELSE                          !* update momentum & tracer diffusivity with wave-driven mixing 
     889         DO jk = 2, jpkm1 
     890            fsavs(:,:,jk) = avt(:,:,jk) + zav_wave(:,:,jk) 
     891            avt  (:,:,jk) = avt(:,:,jk) + zav_wave(:,:,jk) 
     892            avm  (:,:,jk) = avm(:,:,jk) + zav_wave(:,:,jk) 
     893         END DO 
     894      ENDIF 
     895 
     896      DO jk = 2, jpkm1              !* update momentum diffusivity at wu and wv points 
     897         DO jj = 2, jpjm1 
     898            DO ji = fs_2, fs_jpim1  ! vector opt. 
     899               avmu(ji,jj,jk) = avmu(ji,jj,jk) + 0.5_wp * ( zav_wave(ji,jj,jk) + zav_wave(ji+1,jj  ,jk) ) * wumask(ji,jj,jk) 
     900               avmv(ji,jj,jk) = avmv(ji,jj,jk) + 0.5_wp * ( zav_wave(ji,jj,jk) + zav_wave(ji  ,jj+1,jk) ) * wvmask(ji,jj,jk) 
     901            END DO 
     902         END DO 
     903      END DO 
     904      CALL lbc_lnk( avmu, 'U', 1. )   ;   CALL lbc_lnk( avmv, 'V', 1. )      ! lateral boundary condition 
     905 
     906      !                             !* output internal wave-driven mixing coefficient 
     907      CALL iom_put( "av_wave", zav_wave ) 
     908                                    !* output useful diagnostics: N^2, Kz * N^2 (bflx_tmx),  
     909                                    !  vertical integral of rau0 * Kz * N^2 (pcmap_tmx), energy density (emix_tmx) 
     910      IF( iom_use("bflx_tmx") .OR. iom_use("pcmap_tmx") ) THEN 
     911         bflx_tmx(:,:,:) = MAX( 0._wp, rn2(:,:,:) ) * zav_wave(:,:,:) 
     912         pcmap_tmx(:,:) = 0._wp 
     913         DO jk = 2, jpkm1 
     914            pcmap_tmx(:,:) = pcmap_tmx(:,:) + fse3w(:,:,jk) * bflx_tmx(:,:,jk) * wmask(:,:,jk) 
     915         END DO 
     916         pcmap_tmx(:,:) = rau0 * pcmap_tmx(:,:) 
     917         CALL iom_put( "bflx_tmx", bflx_tmx ) 
     918         CALL iom_put( "pcmap_tmx", pcmap_tmx ) 
     919      ENDIF 
     920      CALL iom_put( "bn2", rn2 ) 
     921      CALL iom_put( "emix_tmx", emix_tmx ) 
     922       
     923      CALL wrk_dealloc( jpi,jpj,       zfact, zhdep ) 
     924      CALL wrk_dealloc( jpi,jpj,jpk,   zwkb, zweight, znu_t, znu_w, zReb ) 
     925 
     926      IF(ln_ctl)   CALL prt_ctl(tab3d_1=zav_wave , clinfo1=' tmx - av_wave: ', tab3d_2=avt, clinfo2=' avt: ', ovlap=1, kdim=jpk) 
     927      ! 
     928      IF( nn_timing == 1 )   CALL timing_stop('zdf_tmx') 
     929      ! 
     930   END SUBROUTINE zdf_tmx 
     931 
     932 
     933   SUBROUTINE zdf_tmx_init 
     934      !!---------------------------------------------------------------------- 
     935      !!                  ***  ROUTINE zdf_tmx_init  *** 
     936      !!                      
     937      !! ** Purpose :   Initialization of the wave-driven vertical mixing, reading 
     938      !!              of input power maps and decay length scales in netcdf files. 
     939      !! 
     940      !! ** Method  : - Read the namzdf_tmx namelist and check the parameters 
     941      !! 
     942      !!              - Read the input data in NetCDF files : 
     943      !!              power available from high-mode wave breaking (mixing_power_bot.nc) 
     944      !!              power available from pycnocline-intensified wave-breaking (mixing_power_pyc.nc) 
     945      !!              power available from critical slope wave-breaking (mixing_power_cri.nc) 
     946      !!              WKB decay scale for high-mode wave-breaking (decay_scale_bot.nc) 
     947      !!              decay scale for critical slope wave-breaking (decay_scale_cri.nc) 
     948      !! 
     949      !! ** input   : - Namlist namzdf_tmx 
     950      !!              - NetCDF files : mixing_power_bot.nc, mixing_power_pyc.nc, mixing_power_cri.nc, 
     951      !!              decay_scale_bot.nc decay_scale_cri.nc 
     952      !! 
     953      !! ** Action  : - Increase by 1 the nstop flag is setting problem encounter 
     954      !!              - Define ebot_tmx, epyc_tmx, ecri_tmx, hbot_tmx, hcri_tmx 
     955      !! 
     956      !! References : de Lavergne et al. 2015, JPO; 2016, in prep. 
     957      !!          
     958      !!---------------------------------------------------------------------- 
     959      INTEGER  ::   ji, jj, jk   ! dummy loop indices 
     960      INTEGER  ::   inum         ! local integer 
     961      INTEGER  ::   ios 
     962      REAL(wp) ::   zbot, zpyc, zcri   ! local scalars 
     963      !! 
     964      NAMELIST/namzdf_tmx_new/ nn_zpyc, ln_mevar, ln_tsdiff 
     965      !!---------------------------------------------------------------------- 
     966      ! 
     967      IF( nn_timing == 1 )  CALL timing_start('zdf_tmx_init') 
     968      ! 
     969      REWIND( numnam_ref )              ! Namelist namzdf_tmx in reference namelist : Wave-driven mixing 
     970      READ  ( numnam_ref, namzdf_tmx_new, IOSTAT = ios, ERR = 901) 
     971901   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzdf_tmx in reference namelist', lwp ) 
     972      ! 
     973      REWIND( numnam_cfg )              ! Namelist namzdf_tmx in configuration namelist : Wave-driven mixing 
     974      READ  ( numnam_cfg, namzdf_tmx_new, IOSTAT = ios, ERR = 902 ) 
     975902   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzdf_tmx in configuration namelist', lwp ) 
     976      IF(lwm) WRITE ( numond, namzdf_tmx_new ) 
     977      ! 
     978      IF(lwp) THEN                  ! Control print 
     979         WRITE(numout,*) 
     980         WRITE(numout,*) 'zdf_tmx_init : internal wave-driven mixing' 
     981         WRITE(numout,*) '~~~~~~~~~~~~' 
     982         WRITE(numout,*) '   Namelist namzdf_tmx_new : set wave-driven mixing parameters' 
     983         WRITE(numout,*) '      Pycnocline-intensified diss. scales as N (=1) or N^2 (=2) = ', nn_zpyc 
     984         WRITE(numout,*) '      Variable (T) or constant (F) mixing efficiency            = ', ln_mevar 
     985         WRITE(numout,*) '      Differential internal wave-driven mixing (T) or not (F)   = ', ln_tsdiff 
     986      ENDIF 
     987       
     988      ! The new wave-driven mixing parameterization elevates avt and avm in the interior, and 
     989      ! ensures that avt remains larger than its molecular value (=1.4e-7). Therefore, avtb should  
     990      ! be set here to a very small value, and avmb to its (uniform) molecular value (=1.4e-6). 
     991      avmb(:) = 1.4e-6_wp        ! viscous molecular value 
     992      avtb(:) = 1.e-10_wp        ! very small diffusive minimum (background avt is specified in zdf_tmx)     
     993      avtb_2d(:,:) = 1.e0_wp     ! uniform  
     994      IF(lwp) THEN                  ! Control print 
     995         WRITE(numout,*) 
     996         WRITE(numout,*) '   Force the background value applied to avm & avt in TKE to be everywhere ',   & 
     997            &               'the viscous molecular value & a very small diffusive value, resp.' 
     998      ENDIF 
     999       
     1000      IF( .NOT.lk_zdfddm )   CALL ctl_stop( 'STOP', 'zdf_tmx_init_new : key_zdftmx_new requires key_zdfddm' ) 
     1001       
     1002      !                             ! allocate tmx arrays 
     1003      IF( zdf_tmx_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'zdf_tmx_init : unable to allocate tmx arrays' ) 
     1004      ! 
     1005      !                             ! read necessary fields 
     1006      CALL iom_open('mixing_power_bot',inum)       ! energy flux for high-mode wave breaking [W/m2] 
     1007      CALL iom_get  (inum, jpdom_data, 'field', ebot_tmx, 1 )  
     1008      CALL iom_close(inum) 
     1009      ! 
     1010      CALL iom_open('mixing_power_pyc',inum)       ! energy flux for pynocline-intensified wave breaking [W/m2] 
     1011      CALL iom_get  (inum, jpdom_data, 'field', epyc_tmx, 1 ) 
     1012      CALL iom_close(inum) 
     1013      ! 
     1014      CALL iom_open('mixing_power_cri',inum)       ! energy flux for critical slope wave breaking [W/m2] 
     1015      CALL iom_get  (inum, jpdom_data, 'field', ecri_tmx, 1 ) 
     1016      CALL iom_close(inum) 
     1017      ! 
     1018      CALL iom_open('decay_scale_bot',inum)        ! spatially variable decay scale for high-mode wave breaking [m] 
     1019      CALL iom_get  (inum, jpdom_data, 'field', hbot_tmx, 1 ) 
     1020      CALL iom_close(inum) 
     1021      ! 
     1022      CALL iom_open('decay_scale_cri',inum)        ! spatially variable decay scale for critical slope wave breaking [m] 
     1023      CALL iom_get  (inum, jpdom_data, 'field', hcri_tmx, 1 ) 
     1024      CALL iom_close(inum) 
     1025 
     1026      ebot_tmx(:,:) = ebot_tmx(:,:) * ssmask(:,:) 
     1027      epyc_tmx(:,:) = epyc_tmx(:,:) * ssmask(:,:) 
     1028      ecri_tmx(:,:) = ecri_tmx(:,:) * ssmask(:,:) 
     1029 
     1030      ! Set once for all to zero the first and last vertical levels of appropriate variables 
     1031      emix_tmx (:,:, 1 ) = 0._wp 
     1032      emix_tmx (:,:,jpk) = 0._wp 
     1033      zav_ratio(:,:, 1 ) = 0._wp 
     1034      zav_ratio(:,:,jpk) = 0._wp 
     1035      zav_wave (:,:, 1 ) = 0._wp 
     1036      zav_wave (:,:,jpk) = 0._wp 
     1037 
     1038      zbot = glob_sum( e1e2t(:,:) * ebot_tmx(:,:) ) 
     1039      zpyc = glob_sum( e1e2t(:,:) * epyc_tmx(:,:) ) 
     1040      zcri = glob_sum( e1e2t(:,:) * ecri_tmx(:,:) ) 
     1041      IF(lwp) THEN 
     1042         WRITE(numout,*) '      High-mode wave-breaking energy:             ', zbot * 1.e-12_wp, 'TW' 
     1043         WRITE(numout,*) '      Pycnocline-intensifed wave-breaking energy: ', zpyc * 1.e-12_wp, 'TW' 
     1044         WRITE(numout,*) '      Critical slope wave-breaking energy:        ', zcri * 1.e-12_wp, 'TW' 
     1045      ENDIF 
     1046      ! 
     1047      IF( nn_timing == 1 )  CALL timing_stop('zdf_tmx_init') 
     1048      ! 
     1049   END SUBROUTINE zdf_tmx_init 
     1050 
    5631051#else 
    5641052   !!---------------------------------------------------------------------- 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/nemogcm.F90

    r6836 r6839  
    161161          ENDIF 
    162162 
     163#if defined key_agrif 
     164          CALL Agrif_Regrid() 
     165#endif 
     166 
    163167         DO WHILE ( istp <= nitend .AND. nstop == 0 ) 
    164168#if defined key_agrif 
    165             CALL Agrif_Step( stp )           ! AGRIF: time stepping 
     169            CALL stp                         ! AGRIF: time stepping 
    166170#else 
    167171            CALL stp( istp )                 ! standard time stepping 
    … …  
    187191      ! 
    188192#if defined key_agrif 
    189       CALL Agrif_ParentGrid_To_ChildGrid() 
    190       IF( lk_diaobs ) CALL dia_obs_wri 
    191       IF( nn_timing == 1 )   CALL timing_finalize 
    192       CALL Agrif_ChildGrid_To_ParentGrid() 
     193      IF( .NOT. Agrif_Root() ) THEN 
     194         CALL Agrif_ParentGrid_To_ChildGrid() 
     195         IF( lk_diaobs ) CALL dia_obs_wri 
     196         IF( nn_timing == 1 )   CALL timing_finalize 
     197         CALL Agrif_ChildGrid_To_ParentGrid() 
     198      ENDIF 
    193199#endif 
    194200      IF( nn_timing == 1 )   CALL timing_finalize 
    … …  
    334340         jpj = ( jpjglo-2*jprecj + (jpnj-1) ) / jpnj + 2*jprecj   ! second dim. 
    335341#endif 
    336       ENDIF 
     342      ENDIF          
    337343         jpk = jpkdta                                             ! third dim 
     344#if defined key_agrif 
     345         ! simple trick to use same vertical grid as parent 
     346         ! but different number of levels:  
     347         ! Save maximum number of levels in jpkdta, then define all vertical grids 
     348         ! with this number. 
     349         ! Suppress once vertical online interpolation is ok 
     350         IF(.NOT.Agrif_Root()) jpkdta = Agrif_Parent(jpkdta) 
     351#endif 
    338352         jpim1 = jpi-1                                            ! inner domain indices 
    339353         jpjm1 = jpj-1                                            !   "           " 
    … …  
    710724      INTEGER :: ifac, jl, inu 
    711725      INTEGER, PARAMETER :: ntest = 14 
    712       INTEGER :: ilfax(ntest) 
    713       ! 
    714       ! lfax contains the set of allowed factors. 
    715       data (ilfax(jl),jl=1,ntest) / 16384, 8192, 4096, 2048, 1024, 512, 256,  & 
    716          &                            128,   64,   32,   16,    8,   4,   2  / 
    717       !!---------------------------------------------------------------------- 
     726      INTEGER, DIMENSION(ntest) :: ilfax 
     727      ! 
     728      ! ilfax contains the set of allowed factors. 
     729      ilfax(:) = (/(2**jl,jl=ntest,1,-1)/) 
     730      !!---------------------------------------------------------------------- 
     731      ! ilfax contains the set of allowed factors. 
     732      ilfax(:) = (/(2**jl,jl=ntest,1,-1)/) 
    718733 
    719734      ! Clear the error flag and initialise output vars 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/step.F90

    r6837 r6839  
    5050 
    5151#if defined key_agrif 
    52    SUBROUTINE stp( ) 
     52   RECURSIVE SUBROUTINE stp( ) 
    5353      INTEGER             ::   kstp   ! ocean time-step index 
    5454#else 
    … …  
    7979#if defined key_agrif 
    8080      kstp = nit000 + Agrif_Nb_Step() 
    81 !      IF ( Agrif_Root() .and. lwp) Write(*,*) '---' 
    82 !      IF (lwp) Write(*,*) 'Grid Number',Agrif_Fixed(),' time step ',kstp 
     81      IF ( lk_agrif_debug ) THEN 
     82         IF ( Agrif_Root() .and. lwp) Write(*,*) '---' 
     83         IF (lwp) Write(*,*) 'Grid Number',Agrif_Fixed(),' time step ',kstp, 'int tstep',Agrif_NbStepint() 
     84      ENDIF 
     85 
    8386      IF ( kstp == (nit000 + 1) ) lk_agrif_fstep = .FALSE. 
     87 
    8488# if defined key_iomput 
    8589      IF( Agrif_Nbstepint() == 0 )   CALL iom_swap( cxios_context ) 
    … …  
    114118      ! Update stochastic parameters and random T/S fluctuations 
    115119      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 
    116                         CALL sto_par( kstp )          ! Stochastic parameters 
     120       IF( ln_sto_eos ) CALL sto_par( kstp )          ! Stochastic parameters 
     121       IF( ln_sto_eos ) CALL sto_pts( tsn  )          ! Random T/S fluctuations 
    117122 
    118123      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 
    … …  
    156161      ! 
    157162      IF( lk_ldfslp ) THEN                            ! slope of lateral mixing 
    158          IF(ln_sto_eos ) CALL sto_pts( tsn )          ! Random T/S fluctuations 
    159163                         CALL eos( tsb, rhd, gdept_0(:,:,:) )               ! before in situ density 
    160164         IF( ln_zps .AND. .NOT. ln_isfcav)                               & 
    … …  
    192196          ! Note that the computation of vertical velocity above, hence "after" sea level 
    193197          ! is necessary to compute momentum advection for the rhs of barotropic loop: 
    194             IF(ln_sto_eos ) CALL sto_pts( tsn )                             ! Random T/S fluctuations 
    195198                            CALL eos    ( tsn, rhd, rhop, fsdept_n(:,:,:) ) ! now in situ density for hpg computation 
    196199            IF( ln_zps .AND. .NOT. ln_isfcav)                               & 
    … …  
    204207                                  ua(:,:,:) = 0.e0             ! set dynamics trends to zero 
    205208                                  va(:,:,:) = 0.e0 
    206           IF(  ln_asmiau .AND. & 
     209          IF(  lk_asminc .AND. ln_asmiau .AND. & 
    207210             & ln_dyninc       )  CALL dyn_asm_inc  ( kstp )   ! apply dynamics assimilation increment 
    208211          IF( ln_neptsimp )       CALL dyn_nept_cor ( kstp )   ! subtract Neptune velocities (simplified) 
    … …  
    252255                             tsa(:,:,:,:) = 0.e0            ! set tracer trends to zero 
    253256 
    254       IF(  ln_asmiau .AND. & 
     257      IF(  lk_asminc .AND. ln_asmiau .AND. & 
    255258         & ln_trainc     )   CALL tra_asm_inc( kstp )       ! apply tracer assimilation increment 
    256259                             CALL tra_sbc    ( kstp )       ! surface boundary condition 
    … …  
    274277         IF( ln_zdfnpc   )   CALL tra_npc( kstp )                ! update after fields by non-penetrative convection 
    275278                             CALL tra_nxt( kstp )                ! tracer fields at next time step 
    276             IF( ln_sto_eos ) CALL sto_pts( tsn )                 ! Random T/S fluctuations 
    277279                             CALL eos    ( tsa, rhd, rhop, fsdept_n(:,:,:) )  ! Time-filtered in situ density for hpg computation 
    278280            IF( ln_zps .AND. .NOT. ln_isfcav)                                & 
    … …  
    285287      ELSE                                                  ! centered hpg  (eos then time stepping) 
    286288         IF ( .NOT. lk_dynspg_ts ) THEN                     ! eos already called in time-split case 
    287             IF( ln_sto_eos ) CALL sto_pts( tsn )    ! Random T/S fluctuations 
    288289                             CALL eos    ( tsn, rhd, rhop, fsdept_n(:,:,:) )  ! now in situ density for hpg computation 
    289290         IF( ln_zps .AND. .NOT. ln_isfcav)                                   & 
    … …  
    318319                               va(:,:,:) = 0.e0 
    319320 
    320         IF(  ln_asmiau .AND. & 
     321        IF(  lk_asminc .AND. ln_asmiau .AND. & 
    321322           & ln_dyninc      )  CALL dyn_asm_inc( kstp )     ! apply dynamics assimilation increment 
    322323        IF( ln_bkgwri )        CALL asm_bkg_wri( kstp )     ! output background fields 
    … …  
    339340                               CALL ssh_swp( kstp )         ! swap of sea surface height 
    340341      IF( lk_vvl           )   CALL dom_vvl_sf_swp( kstp )  ! swap of vertical scale factors 
    341  
     342      ! 
     343      IF( lrst_oce         )   CALL rst_write( kstp )       ! write output ocean restart file 
     344      IF( ln_sto_eos       )   CALL sto_rst_write( kstp )   ! write restart file for stochastic parameters 
     345 
     346#if defined key_agrif 
     347      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 
     348      ! AGRIF 
     349      !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<       
     350                               CALL Agrif_Integrate_ChildGrids( stp )   
     351 
     352      IF ( Agrif_NbStepint().EQ.0 ) THEN 
     353                               CALL Agrif_Update_Tra()      ! Update active tracers 
     354                               CALL Agrif_Update_Dyn()      ! Update momentum 
     355      ENDIF 
     356#endif 
    342357      IF( ln_diahsb        )   CALL dia_hsb( kstp )         ! - ML - global conservation diagnostics 
    343358      IF( lk_diaobs  )         CALL dia_obs( kstp )         ! obs-minus-model (assimilation) diagnostics (call after dynamics update) 
    344359 
    345360      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 
    346       ! Control and restarts 
     361      ! Control 
    347362      !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
    348363                               CALL stp_ctl( kstp, indic ) 
    … …  
    356371         IF( lwm.AND.numoni /= -1 ) CALL FLUSH    ( numoni )     ! flush output namelist ice 
    357372      ENDIF 
    358       IF( lrst_oce         )   CALL rst_write    ( kstp )   ! write output ocean restart file 
    359373 
    360374      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 
    … …  
    371385      ! 
    372386      IF( nn_timing == 1 .AND.  kstp == nit000  )   CALL timing_reset 
     387      !      
    373388      ! 
    374389   END SUBROUTINE stp 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/step_oce.F90

    r6837 r6839  
    113113#if defined key_agrif 
    114114   USE agrif_opa_sponge ! Momemtum and tracers sponges 
     115   USE agrif_opa_update ! Update (2-way nesting) 
    115116#endif 
    116117#if defined key_top 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/stpctl.F90

    r6836 r6839  
    1717   USE dom_oce         ! ocean space and time domain variables  
    1818   USE sol_oce         ! ocean space and time domain variables  
     19   USE sbc_oce         ! surface boundary conditions variables 
    1920   USE in_out_manager  ! I/O manager 
    2021   USE lbclnk          ! ocean lateral boundary conditions (or mpp link) 
    … …  
    2223   USE dynspg_oce      ! pressure gradient schemes  
    2324   USE c1d             ! 1D vertical configuration 
     25 
    2426 
    2527   IMPLICIT NONE 
    … …  
    5254      INTEGER, INTENT( inout ) ::   kindic  ! indicator of solver convergence 
    5355      !! 
     56      CHARACTER(len = 32) ::        clfname ! time stepping output file name 
    5457      INTEGER  ::   ji, jj, jk              ! dummy loop indices 
    5558      INTEGER  ::   ii, ij, ik              ! temporary integers 
    … …  
    6366         WRITE(numout,*) 'stp_ctl : time-stepping control' 
    6467         WRITE(numout,*) '~~~~~~~' 
    65          ! open time.step file 
    66          CALL ctl_opn( numstp, 'time.step', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea ) 
     68         ! open time.step file with special treatment for SAS 
     69         IF ( nn_components == jp_iam_sas ) THEN 
     70            clfname = 'time.step.sas' 
     71         ELSE 
     72            clfname = 'time.step' 
     73         ENDIF 
     74         CALL ctl_opn( numstp, TRIM(clfname), 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea ) 
    6775      ENDIF 
    6876 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/SAS_SRC/daymod.F90

    r6836 r6839  
    7171      !!---------------------------------------------------------------------- 
    7272      ! 
     73      ! max number of seconds between each restart 
     74      IF( REAL( nitend - nit000 + 1 ) * rdt > REAL( HUGE( nsec1jan000 ) ) ) THEN 
     75         CALL ctl_stop( 'The number of seconds between each restart exceeds the integer 4 max value: 2^31-1. ',   & 
     76            &           'You must do a restart at higher frequency (or remove this stop and recompile the code in I8)' ) 
     77      ENDIF 
    7378      ! all calendar staff is based on the fact that MOD( rday, rdttra(1) ) == 0 
    7479      IF( MOD( rday     , rdttra(1) ) /= 0. )   CALL ctl_stop( 'the time step must devide the number of second of in a day' ) 
    … …  
    239244               nday_year = 1 
    240245               nsec_year = ndt05 
    241                IF( nsec1jan000 >= 2 * (2**30 - nsecd * nyear_len(1) / 2 ) ) THEN   ! test integer 4 max value 
    242                   CALL ctl_stop( 'The number of seconds between Jan. 1st 00h of nit000 year and Jan. 1st 00h ',   & 
    243                      &           'of the current year is exceeding the INTEGER 4 max VALUE: 2^31-1 -> 68.09 years in seconds', & 
    244                      & 'You must do a restart at higher frequency (or remove this STOP and recompile everything in I8)' ) 
    245                ENDIF 
    246246               nsec1jan000 = nsec1jan000 + nsecd * nyear_len(1) 
    247247               IF( nleapy == 1 )   CALL day_mth 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/SAS_SRC/nemogcm.F90

    r6836 r6839  
    521521#endif 
    522522      ! 
    523       INTEGER :: ierr,ierr1,ierr2,ierr3,ierr4,ierr5,ierr6 
     523      INTEGER :: ierr,ierr1,ierr2,ierr3,ierr4,ierr5,ierr6,ierr7,ierr8 
    524524      INTEGER :: jpm 
    525525      !!---------------------------------------------------------------------- 
    … …  
    545545      ALLOCATE( tsb(jpi,jpj,1,jpm)  , STAT=ierr5 ) 
    546546      ALLOCATE( sshn(jpi,jpj)       , STAT=ierr6 ) 
    547       ierr = ierr + ierr1 + ierr2 + ierr3 + ierr4 + ierr5 + ierr6  
     547      ALLOCATE( un(jpi,jpj,1)       , STAT=ierr7 ) 
     548      ALLOCATE( vn(jpi,jpj,1)       , STAT=ierr8 ) 
     549      ierr = ierr + ierr1 + ierr2 + ierr3 + ierr4 + ierr5 + ierr6  + ierr7 + ierr8 
    548550#endif 
    549551      ! 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/TOP_SRC/PISCES/P2Z/p2zbio.F90

    r6836 r6839  
    599599 
    600600   !!====================================================================== 
    601 END MODULE  p2zbio 
     601END MODULE p2zbio 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/TOP_SRC/PISCES/P2Z/p2zsms.F90

    r6836 r6839  
    8484 
    8585   !!====================================================================== 
    86 END MODULE  p2zsms 
     86END MODULE p2zsms 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zbio.F90

    r6836 r6839  
    109109 
    110110   !!====================================================================== 
    111 END MODULE  p4zbio 
    112  
     111END MODULE p4zbio 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zche.F90

    r6836 r6839  
    3131   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   sio3eq   ! chemistry of Si 
    3232   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   fekeq    ! chemistry of Fe 
    33    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   chemc    ! Solubilities of O2 and CO2 
    34    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   chemo2    ! Solubilities of O2 and CO2 
     33   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)  ::   chemc    ! Solubilities of O2 and CO2 
     34   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   chemo2   ! Solubilities of O2 and CO2 
    3535 
    3636   REAL(wp), PUBLIC ::   atcox  = 0.20946         ! units atm 
    … …  
    7676   REAL(wp) ::   st1    =      0.14     ! constants for calculate concentrations for sulfate 
    7777   REAL(wp) ::   st2    =  1./96.062    !  (Morris & Riley 1966) 
    78    REAL(wp) ::   ks0    =    141.328  
    79    REAL(wp) ::   ks1    =  -4276.1   
    80    REAL(wp) ::   ks2    =    -23.093 
    81    REAL(wp) ::   ks3    = -13856.   
    82    REAL(wp) ::   ks4    =   324.57  
    83    REAL(wp) ::   ks5    =   -47.986 
    84    REAL(wp) ::   ks6    =  35474.  
    85    REAL(wp) ::   ks7    =   -771.54 
    86    REAL(wp) ::   ks8    =    114.723 
    87    REAL(wp) ::   ks9    =  -2698.   
    88    REAL(wp) ::   ks10   =   1776.  
    89    REAL(wp) ::   ks11   =      1. 
    90    REAL(wp) ::   ks12   =     -0.001005  
    9178 
    9279   REAL(wp) ::   ft1    =    0.000067   ! constants for calculate concentrations for fluorides 
    9380   REAL(wp) ::   ft2    = 1./18.9984    ! (Dickson & Riley 1979 ) 
    94    REAL(wp) ::   kf0    =  -12.641     
    95    REAL(wp) ::   kf1    = 1590.2     
    96    REAL(wp) ::   kf2    =    1.525     
    97    REAL(wp) ::   kf3    =    1.0      
    98    REAL(wp) ::   kf4    =   -0.001005 
    99  
    100    REAL(wp) ::   cb0    = -8966.90      ! Coeff. for 1. dissoc. of boric acid  
    101    REAL(wp) ::   cb1    = -2890.53      ! (Dickson and Goyet, 1994) 
    102    REAL(wp) ::   cb2    =   -77.942 
    103    REAL(wp) ::   cb3    =     1.728 
    104    REAL(wp) ::   cb4    =    -0.0996 
    105    REAL(wp) ::   cb5    =   148.0248 
    106    REAL(wp) ::   cb6    =   137.1942 
    107    REAL(wp) ::   cb7    =     1.62142 
    108    REAL(wp) ::   cb8    =   -24.4344 
    109    REAL(wp) ::   cb9    =   -25.085 
    110    REAL(wp) ::   cb10   =    -0.2474  
    111    REAL(wp) ::   cb11   =     0.053105 
    112  
    113    REAL(wp) ::   cw0    = -13847.26     ! Coeff. for dissoc. of water (Dickson and Riley, 1979 ) 
    114    REAL(wp) ::   cw1    =    148.9652   
    115    REAL(wp) ::   cw2    =    -23.6521 
    116    REAL(wp) ::   cw3    =    118.67  
    117    REAL(wp) ::   cw4    =     -5.977  
    118    REAL(wp) ::   cw5    =      1.0495   
    119    REAL(wp) ::   cw6    =     -0.01615 
    12081 
    12182   !                                    ! volumetric solubility constants for o2 in ml/L   
    … …  
    200161         DO ji = 1, jpi 
    201162            !                             ! SET ABSOLUTE TEMPERATURE 
    202             ztkel = tsn(ji,jj,1,jp_tem) + 273.16 
     163            ztkel = tsn(ji,jj,1,jp_tem) + 273.15 
    203164            zt    = ztkel * 0.01 
    204165            zt2   = zt * zt 
    … …  
    209170            !                             !     AND FOR THE ATMOSPHERE FOR NON IDEAL GAS 
    210171            zcek1 = ca0 + ca1 / zt + ca2 * zlogt + ca3 * zt2 + zsal * ( ca4 + ca5 * zt + ca6 * zt2 ) 
    211             !                             ! LN(K0) OF SOLUBILITY OF O2 and N2 in ml/L (EQ. 8, GARCIA AND GORDON, 1992) 
    212             ztgg  = LOG( ( 298.15 - tsn(ji,jj,1,jp_tem) ) / ztkel )  ! Set the GORDON & GARCIA scaled temperature 
    213             ztgg2 = ztgg  * ztgg 
    214             ztgg3 = ztgg2 * ztgg 
    215             ztgg4 = ztgg3 * ztgg 
    216             ztgg5 = ztgg4 * ztgg 
    217             zoxy  = ox0 + ox1 * ztgg + ox2 * ztgg2 + ox3 * ztgg3 + ox4 * ztgg4 + ox5 * ztgg5   & 
    218                    + zsal * ( ox6 + ox7 * ztgg + ox8 * ztgg2 + ox9 * ztgg3 ) +  ox10 * zsal2 
    219  
    220172            !                             ! SET SOLUBILITIES OF O2 AND CO2  
    221             chemc(ji,jj,1) = EXP( zcek1 ) * 1.e-6 * rhop(ji,jj,1) / 1000.  ! mol/(L uatm) 
    222             chemc(ji,jj,2) = ( EXP( zoxy  ) * o2atm ) * oxyco              ! mol/(L atm) 
     173            chemc(ji,jj) = EXP( zcek1 ) * 1.e-6 * rhop(ji,jj,1) / 1000.  ! mol/(L uatm) 
    223174            ! 
    224175         END DO 
    … …  
    233184!CDIR NOVERRCHK 
    234185            DO ji = 1, jpi 
    235               ztkel = tsn(ji,jj,jk,jp_tem) + 273.16 
     186              ztkel = tsn(ji,jj,jk,jp_tem) + 273.15 
    236187              zsal  = tsn(ji,jj,jk,jp_sal) + ( 1.- tmask(ji,jj,jk) ) * 35. 
    237188              zsal2 = zsal * zsal 
    … …  
    263214 
    264215               ! SET ABSOLUTE TEMPERATURE 
    265                ztkel   = tsn(ji,jj,jk,jp_tem) + 273.16 
     216               ztkel   = tsn(ji,jj,jk,jp_tem) + 273.15 
    266217               zsal    = tsn(ji,jj,jk,jp_sal) + ( 1.-tmask(ji,jj,jk) ) * 35. 
    267218               zsqrt  = SQRT( zsal ) 
    … …  
    284235 
    285236               ! DISSOCIATION CONSTANT FOR SULFATES on free H scale (Dickson 1990) 
    286                zcks    = EXP(  ks1 * ztr + ks0 + ks2 * zlogt                           & 
    287                   &                     + ( ks3 * ztr + ks4 + ks5 * zlogt ) * zisqrt   & 
    288                   &                     + ( ks6 * ztr + ks7 + ks8 * zlogt ) * zis      & 
    289                   &                     + ks9 * ztr * zis * zisqrt + ks10 * ztr *zis2 + LOG( ks11 + ks12 *zsal )  ) 
     237               zcks    = EXP(-4276.1 * ztr + 141.328 - 23.093 * zlogt         & 
     238               &         + (-13856. * ztr + 324.57 - 47.986 * zlogt) * zisqrt & 
     239               &         + (35474. * ztr - 771.54 + 114.723 * zlogt) * zis    & 
     240               &         - 2698. * ztr * zis**1.5 + 1776.* ztr * zis2         & 
     241               &         + LOG(1.0 - 0.001005 * zsal)) 
     242               ! 
     243               aphscale(ji,jj,jk) = ( 1. + zst / zcks ) 
    290244 
    291245               ! DISSOCIATION CONSTANT FOR FLUORIDES on free H scale (Dickson and Riley 79) 
    292                zckf    = EXP(  kf1 * ztr + kf0 + kf2 * zisqrt + LOG( kf3 + kf4 * zsal )  ) 
     246               zckf    = EXP( 1590.2*ztr - 12.641 + 1.525*zisqrt   & 
     247               &         + LOG(1.0d0 - 0.001005d0*zsal)            & 
     248               &         + LOG(1.0d0 + zst/zcks)) 
    293249 
    294250               ! DISSOCIATION CONSTANT FOR CARBONATE AND BORATE 
    295                zckb    = ( cb0 + cb1 * zsqrt + cb2  * zsal + cb3 * zsal15 + cb4 * zsal * zsal ) * ztr   & 
    296                   &    + ( cb5 + cb6 * zsqrt + cb7  * zsal )                                            & 
    297                   &    + ( cb8 + cb9 * zsqrt + cb10 * zsal ) * zlogt + cb11 * zsqrt * ztkel             & 
    298                   &    + LOG(  ( 1.+ zst / zcks + zft / zckf ) / ( 1.+ zst / zcks )  ) 
     251               zckb=  (-8966.90 - 2890.53*zsqrt - 77.942*zsal        & 
     252               &      + 1.728*zsal15 - 0.0996*zsal*zsal)*ztr         & 
     253               &      + (148.0248 + 137.1942*zsqrt + 1.62142*zsal)   & 
     254               &      + (-24.4344 - 25.085*zsqrt - 0.2474*zsal)      &  
     255               &      * zlogt + 0.053105*zsqrt*ztkel 
     256 
    299257 
    300258               zck1    = c10 * ztr + c11 + c12 * zlogt + c13 * zsal + c14 * zsal * zsal 
    … …  
    302260 
    303261               ! PKW (H2O) (DICKSON AND RILEY, 1979) 
    304                zckw    = cw0 * ztr + cw1 + cw2 * zlogt + ( cw3 * ztr + cw4 + cw5 * zlogt ) * zsqrt + cw6 * zsal 
    305  
     262               zckw = -13847.26*ztr + 148.9652 - 23.6521 * zlogt    &  
     263               &     + (118.67*ztr - 5.977 + 1.0495 * zlogt)        & 
     264               &     * zsqrt - 0.01615 * zsal 
    306265 
    307266               ! APPARENT SOLUBILITY PRODUCT K'SP OF CALCITE IN SEAWATER 
    … …  
    378337      !!                     ***  ROUTINE p4z_che_alloc  *** 
    379338      !!---------------------------------------------------------------------- 
    380       ALLOCATE( sio3eq(jpi,jpj,jpk), fekeq(jpi,jpj,jpk), chemc(jpi,jpj,2), chemo2(jpi,jpj,jpk), STAT=p4z_che_alloc ) 
     339      ALLOCATE( sio3eq(jpi,jpj,jpk), fekeq(jpi,jpj,jpk), chemc(jpi,jpj), chemo2(jpi,jpj,jpk),   & 
     340      &         STAT=p4z_che_alloc ) 
    381341      ! 
    382342      IF( p4z_che_alloc /= 0 )   CALL ctl_warn('p4z_che_alloc : failed to allocate arrays.') 
    … …  
    396356 
    397357   !!====================================================================== 
    398 END MODULE  p4zche 
     358END MODULE p4zche 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zflx.F90

    r6836 r6839  
    8484      ! 
    8585      INTEGER  ::   ji, jj, jm, iind, iindm1 
    86       REAL(wp) ::   ztc, ztc2, ztc3, zws, zkgwan 
     86      REAL(wp) ::   ztc, ztc2, ztc3, ztc4, zws, zkgwan 
    8787      REAL(wp) ::   zfld, zflu, zfld16, zflu16, zfact 
    8888      REAL(wp) ::   zph, zah2, zbot, zdic, zalk, zsch_o2, zalka, zsch_co2 
    … …  
    135135 
    136136               ! CALCULATE [ALK]([CO3--], [HCO3-]) 
    137                zalk  = zalka - (  akw3(ji,jj,1) / zph - zph + zbot / ( 1.+ zph / akb3(ji,jj,1) )  ) 
     137               zalk  = zalka - (  akw3(ji,jj,1) / zph - zph / aphscale(ji,jj,1)    & 
     138               &       + zbot / ( 1.+ zph / akb3(ji,jj,1) )  ) 
    138139 
    139140               ! CALCULATE [H+] AND [H2CO3] 
    … …  
    162163            ztc2 = ztc * ztc 
    163164            ztc3 = ztc * ztc2  
     165            ztc4 = ztc2 * ztc2  
    164166            ! Compute the schmidt Number both O2 and CO2 
    165             zsch_co2 = 2073.1 - 125.62 * ztc + 3.6276 * ztc2 - 0.043126 * ztc3 
    166             zsch_o2  = 1953.4 - 128.0  * ztc + 3.9918 * ztc2 - 0.050091 * ztc3 
     167            zsch_co2 = 2116.8 - 136.25 * ztc + 4.7353 * ztc2 - 0.092307 * ztc3 + 0.0007555 * ztc4 
     168            zsch_o2  = 1920.4 - 135.6  * ztc + 5.2122 * ztc2 - 0.109390 * ztc3 + 0.0009377 * ztc4 
    167169            !  wind speed  
    168170            zws  = wndm(ji,jj) * wndm(ji,jj) 
    169171            ! Compute the piston velocity for O2 and CO2 
    170             zkgwan = 0.3 * zws  + 2.5 * ( 0.5246 + 0.016256 * ztc + 0.00049946  * ztc2 ) 
     172            zkgwan = 0.251 * zws 
    171173            zkgwan = zkgwan * xconv * ( 1.- fr_i(ji,jj) ) * tmask(ji,jj,1) 
    172174# if defined key_degrad 
    … …  
    182184         DO ji = 1, jpi 
    183185            ! Compute CO2 flux for the sea and air 
    184             zfld = satmco2(ji,jj) * patm(ji,jj) * tmask(ji,jj,1) * chemc(ji,jj,1) * zkgco2(ji,jj)   ! (mol/L) * (m/s) 
     186            zfld = satmco2(ji,jj) * patm(ji,jj) * tmask(ji,jj,1) * chemc(ji,jj) * zkgco2(ji,jj)   ! (mol/L) * (m/s) 
    185187            zflu = zh2co3(ji,jj) * tmask(ji,jj,1) * zkgco2(ji,jj)                                   ! (mol/L) (m/s) ? 
    186188            oce_co2(ji,jj) = ( zfld - zflu ) * rfact2 * e1e2t(ji,jj) * tmask(ji,jj,1) * 1000. 
    … …  
    189191 
    190192            ! Compute O2 flux  
    191             zfld16 = atcox * patm(ji,jj) * chemc(ji,jj,2) * tmask(ji,jj,1) * zkgo2(ji,jj)          ! (mol/L) * (m/s) 
     193            zfld16 = patm(ji,jj) * chemo2(ji,jj,1) * tmask(ji,jj,1) * zkgo2(ji,jj)          ! (mol/L) * (m/s) 
    192194            zflu16 = trb(ji,jj,1,jpoxy) * tmask(ji,jj,1) * zkgo2(ji,jj) 
    193195            zoflx(ji,jj) = zfld16 - zflu16 
    … …  
    222224         ENDIF 
    223225         IF( iom_use( "Dpco2" ) ) THEN 
    224            zw2d(:,:) = ( satmco2(:,:) * patm(:,:) - zh2co3(:,:) / ( chemc(:,:,1) + rtrn ) ) * tmask(:,:,1) 
     226           zw2d(:,:) = ( satmco2(:,:) * patm(:,:) - zh2co3(:,:) / ( chemc(:,:) + rtrn ) ) * tmask(:,:,1) 
    225227           CALL iom_put( "Dpco2" ,  zw2d ) 
    226228         ENDIF 
    227229         IF( iom_use( "Dpo2" ) )  THEN 
    228            zw2d(:,:) = ( atcox * patm(:,:) - trb(:,:,1,jpoxy) / ( chemc(:,:,2) + rtrn ) ) * tmask(:,:,1) 
     230           zw2d(:,:) = ( atcox * patm(:,:) - atcox * trn(:,:,1,jpoxy) / ( chemo2(:,:,1) + rtrn ) ) * tmask(:,:,1) 
    229231           CALL iom_put( "Dpo2"  , zw2d ) 
    230232         ENDIF 
    … …  
    238240            trc2d(:,:,jp_pcs0_2d + 1) = zoflx(:,:) * 1000 * tmask(:,:,1)  
    239241            trc2d(:,:,jp_pcs0_2d + 2) = zkgco2(:,:) * tmask(:,:,1)  
    240             trc2d(:,:,jp_pcs0_2d + 3) = ( satmco2(:,:) * patm(:,:) - zh2co3(:,:) / ( chemc(:,:,1) + rtrn ) ) * tmask(:,:,1)  
     242            trc2d(:,:,jp_pcs0_2d + 3) = ( satmco2(:,:) * patm(:,:) - zh2co3(:,:) / ( chemc(:,:) + rtrn ) ) * tmask(:,:,1)  
    241243         ENDIF 
    242244      ENDIF 
    … …  
    400402 
    401403   !!====================================================================== 
    402 END MODULE  p4zflx 
     404END MODULE p4zflx 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zint.F90

    r6836 r6839  
    8181 
    8282   !!====================================================================== 
    83 END MODULE  p4zint 
     83END MODULE p4zint 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zlim.F90

    r6836 r6839  
    265265 
    266266   !!====================================================================== 
    267 END MODULE  p4zlim 
     267END MODULE p4zlim 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zlys.F90

    r6836 r6839  
    9191                  zalka = trb(ji,jj,jk,jptal) / zfact 
    9292                  ! CALCULATE [ALK]([CO3--], [HCO3-]) 
    93                   zalk  = zalka - ( akw3(ji,jj,jk) / zph - zph + borat(ji,jj,jk) / ( 1. + zph / akb3(ji,jj,jk) ) ) 
     93                  zalk  = zalka - ( akw3(ji,jj,jk) / zph - zph / ( aphscale(ji,jj,jk) + rtrn )  & 
     94                  &       + borat(ji,jj,jk) / ( 1. + zph / akb3(ji,jj,jk) ) ) 
    9495                  ! CALCULATE [H+] and [CO3--] 
    9596                  zaldi = zdic - zalk 
    … …  
    152153         IF( iom_use( "DCAL"   ) ) CALL iom_put( "DCAL"  , zcaldiss(:,:,:) * 1.e+3 * rfact2r   * tmask(:,:,:) ) 
    153154      ELSE 
    154          trc3d(:,:,:,jp_pcs0_3d    ) = -1. * LOG10( hi(:,:,:) ) * tmask(:,:,:) 
    155          trc3d(:,:,:,jp_pcs0_3d + 1) = zco3(:,:,:)              * tmask(:,:,:) 
    156          trc3d(:,:,:,jp_pcs0_3d + 2) = aksp(:,:,:) / calcon     * tmask(:,:,:) 
     155         IF( ln_diatrc ) THEN 
     156            trc3d(:,:,:,jp_pcs0_3d    ) = -1. * LOG10( hi(:,:,:) ) * tmask(:,:,:) 
     157            trc3d(:,:,:,jp_pcs0_3d + 1) = zco3(:,:,:)              * tmask(:,:,:) 
     158            trc3d(:,:,:,jp_pcs0_3d + 2) = aksp(:,:,:) / calcon     * tmask(:,:,:) 
     159         ENDIF 
    157160      ENDIF 
    158161      ! 
    … …  
    223226#endif  
    224227   !!====================================================================== 
    225 END MODULE  p4zlys 
     228END MODULE p4zlys 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zmeso.F90

    r6836 r6839  
    340340 
    341341   !!====================================================================== 
    342 END MODULE  p4zmeso 
     342END MODULE p4zmeso 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zmicro.F90

    r6836 r6839  
    273273 
    274274   !!====================================================================== 
    275 END MODULE  p4zmicro 
     275END MODULE p4zmicro 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zmort.F90

    r6836 r6839  
    277277 
    278278   !!====================================================================== 
    279 END MODULE  p4zmort 
     279END MODULE p4zmort 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zopt.F90

    r6836 r6839  
    7676      REAL(wp) ::   zchl 
    7777      REAL(wp) ::   zc0 , zc1 , zc2, zc3, z1_dep 
    78       REAL(wp), POINTER, DIMENSION(:,:  ) :: zdepmoy, zetmp1, zetmp2, zetmp3, zetmp4, zqsr100 
     78      REAL(wp), POINTER, DIMENSION(:,:  ) :: zdepmoy, zetmp1, zetmp2, zetmp3, zetmp4 
     79      REAL(wp), POINTER, DIMENSION(:,:  ) :: zqsr100, zqsr_corr 
    7980      REAL(wp), POINTER, DIMENSION(:,:,:) :: zpar, ze0, ze1, ze2, ze3 
    8081      !!--------------------------------------------------------------------- 
    … …  
    8384      ! 
    8485      ! Allocate temporary workspace 
    85       CALL wrk_alloc( jpi, jpj,      zqsr100, zdepmoy, zetmp1, zetmp2, zetmp3, zetmp4 ) 
     86      CALL wrk_alloc( jpi, jpj,      zdepmoy, zetmp1, zetmp2, zetmp3, zetmp4 ) 
     87      CALL wrk_alloc( jpi, jpj,      zqsr100, zqsr_corr ) 
    8688      CALL wrk_alloc( jpi, jpj, jpk, zpar, ze0, ze1, ze2, ze3 ) 
    8789 
    … …  
    112114      !                                        !  -------------------------------------- 
    113115      IF( l_trcdm2dc ) THEN                     !  diurnal cycle 
    114          ! 1% of qsr to compute euphotic layer 
     116         !                                       ! 1% of qsr to compute euphotic layer 
    115117         zqsr100(:,:) = 0.01 * qsr_mean(:,:)     !  daily mean qsr 
    116118         ! 
    117          CALL p4z_opt_par( kt, qsr_mean, ze1, ze2, ze3 )  
     119         zqsr_corr(:,:) = qsr_mean(:,:) / ( 1. - fr_i(:,:) + rtrn ) 
     120         ! 
     121         CALL p4z_opt_par( kt, zqsr_corr, ze1, ze2, ze3 )  
    118122         ! 
    119123         DO jk = 1, nksrp       
    … …  
    123127         END DO 
    124128         ! 
    125          CALL p4z_opt_par( kt, qsr, ze1, ze2, ze3 )  
     129         zqsr_corr(:,:) = qsr(:,:) / ( 1. - fr_i(:,:) + rtrn ) 
     130         ! 
     131         CALL p4z_opt_par( kt, zqsr_corr, ze1, ze2, ze3 )  
    126132         ! 
    127133         DO jk = 1, nksrp       
    … …  
    133139         zqsr100(:,:) = 0.01 * qsr(:,:) 
    134140         ! 
    135          CALL p4z_opt_par( kt, qsr, ze1, ze2, ze3 )  
     141         zqsr_corr(:,:) = qsr(:,:) / ( 1. - fr_i(:,:) + rtrn ) 
     142         ! 
     143         CALL p4z_opt_par( kt, zqsr_corr, ze1, ze2, ze3 )  
    136144         ! 
    137145         DO jk = 1, nksrp       
    … …  
    226234      ENDIF 
    227235      ! 
    228       CALL wrk_dealloc( jpi, jpj,      zqsr100, zdepmoy, zetmp1, zetmp2, zetmp3, zetmp4 ) 
     236      CALL wrk_dealloc( jpi, jpj,      zdepmoy, zetmp1, zetmp2, zetmp3, zetmp4 ) 
     237      CALL wrk_dealloc( jpi, jpj,      zqsr100, zqsr_corr ) 
    229238      CALL wrk_dealloc( jpi, jpj, jpk, zpar,  ze0, ze1, ze2, ze3 ) 
    230239      ! 
    … …  
    439448 
    440449   !!====================================================================== 
    441 END MODULE  p4zopt 
     450END MODULE p4zopt 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zprod.F90

    r6836 r6839  
    136136                  zval = MAX( 1., zstrn(ji,jj) ) 
    137137                  zval = 1.5 * zval / ( 12. + zval ) 
    138                   zprbio(ji,jj,jk) = prmax(ji,jj,jk) * zval 
     138                  zprbio(ji,jj,jk) = prmax(ji,jj,jk) * zval * ( 1. - fr_i(ji,jj) ) 
    139139                  zprdia(ji,jj,jk) = zprbio(ji,jj,jk) 
    140140               ENDIF 
    … …  
    629629 
    630630   !!====================================================================== 
    631 END MODULE  p4zprod 
     631END MODULE p4zprod 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zsbc.F90

    r6836 r6839  
    519519 
    520520   !!====================================================================== 
    521 END MODULE  p4zsbc 
     521END MODULE p4zsbc 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zsed.F90

    r6836 r6839  
    7272      CHARACTER (len=25) :: charout 
    7373      REAL(wp), POINTER, DIMENSION(:,:  ) :: zpdep, zsidep, zwork1, zwork2, zwork3 
     74      REAL(wp), POINTER, DIMENSION(:,:)   :: zsedcal, zsedsi, zsedc 
    7475      REAL(wp), POINTER, DIMENSION(:,:  ) :: zdenit2d, zironice, zbureff 
    7576      REAL(wp), POINTER, DIMENSION(:,:  ) :: zwsbio3, zwsbio4, zwscal 
    … …  
    8384      ! Allocate temporary workspace 
    8485      CALL wrk_alloc( jpi, jpj, zdenit2d, zwork1, zwork2, zwork3, zbureff ) 
     86      CALL wrk_alloc( jpi, jpj, zsedcal,  zsedsi, zsedc ) 
    8587      CALL wrk_alloc( jpi, jpj, zwsbio3, zwsbio4, zwscal ) 
    8688      CALL wrk_alloc( jpi, jpj, jpk, zsoufer ) 
    … …  
    9193      zwork2  (:,:) = 0.e0 
    9294      zwork3  (:,:) = 0.e0 
     95      zsedsi   (:,:) = 0.e0 
     96      zsedcal  (:,:) = 0.e0 
     97      zsedc    (:,:) = 0.e0 
    9398 
    9499      ! Iron input/uptake due to sea ice : Crude parameterization based on Lancelot et al. 
    … …  
    298303            tra(ji,jj,ikt,jptal) =  tra(ji,jj,ikt,jptal) + zcaloss * zrivalk * 2.0 
    299304            tra(ji,jj,ikt,jpdic) =  tra(ji,jj,ikt,jpdic) + zcaloss * zrivalk 
     305            zsedcal(ji,jj) = (1.0 - zrivalk) * zcaloss / zdep 
     306            zsedsi (ji,jj) = (1.0 - zrivsil) * zsiloss / zdep 
    300307#endif 
    301308         END DO 
    … …  
    336343            tra(ji,jj,ikt,jptal) = tra(ji,jj,ikt,jptal) + rno3 * (zolimit + (1.+rdenit) * (zpdenit + zdenitt) ) 
    337344            tra(ji,jj,ikt,jpdic) = tra(ji,jj,ikt,jpdic) + zpdenit + zolimit + zdenitt 
    338             sdenit(ji,jj) = rdenit * zpdenit * fse3t(ji,jj,ikt) 
     345            sdenit(ji,jj) = rdenit * zpdenit / zdep 
     346            zsedc(ji,jj)   = (1. - zrivno3) * zwstpoc / zdep 
    339347#endif 
    340348         END DO 
    … …  
    392400               CALL iom_put( "INTNFIX" , zwork1 )  
    393401            ENDIF 
     402            IF( iom_use("SedCal" ) ) CALL iom_put( "SedCal", zsedcal(:,:) * 1.e+3 ) 
     403            IF( iom_use("SedSi" ) )  CALL iom_put( "SedSi",  zsedsi (:,:) * 1.e+3 ) 
     404            IF( iom_use("SedC" ) )   CALL iom_put( "SedC",   zsedc  (:,:) * 1.e+3 ) 
     405            IF( iom_use("Sdenit" ) ) CALL iom_put( "Sdenit", sdenit (:,:) * 1.e+3 * rno3 ) 
    394406         ENDIF 
    395407      ELSE 
    … …  
    405417      ! 
    406418      CALL wrk_dealloc( jpi, jpj, zdenit2d, zwork1, zwork2, zwork3, zbureff ) 
     419      CALL wrk_dealloc( jpi, jpj, zsedcal , zsedsi, zsedc ) 
    407420      CALL wrk_dealloc( jpi, jpj, zwsbio3, zwsbio4, zwscal ) 
    408421      CALL wrk_dealloc( jpi, jpj, jpk, zsoufer ) 
    … …  
    436449 
    437450   !!====================================================================== 
    438 END MODULE  p4zsed 
     451END MODULE p4zsed 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zsink.F90

    r6836 r6839  
    913913 
    914914   !!====================================================================== 
    915 END MODULE  p4zsink 
     915END MODULE p4zsink 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zsms.F90

    r6836 r6839  
    3838 
    3939   REAL(wp) :: alkbudget, no3budget, silbudget, ferbudget, po4budget 
    40    REAL(wp) :: xfact1, xfact2 
     40   REAL(wp) :: xfact1, xfact2, xfact3 
    4141   INTEGER ::  numco2, numnut, numnit  !: logical unit for co2 budget 
    4242 
    … …  
    133133         ! 
    134134         CALL p4z_bio( kt, jnt )   ! Biology 
    135          CALL p4z_sed( kt, jnt )   ! Sedimentation 
    136135         CALL p4z_lys( kt, jnt )   ! Compute CaCO3 saturation 
     136         CALL p4z_sed( kt, jnt )   ! Surface and Bottom boundary conditions 
    137137         CALL p4z_flx( kt, jnt )   ! Compute surface fluxes 
    138138         ! 
    … …  
    474474      !!--------------------------------------------------------------------- 
    475475      ! 
    476       INTEGER , INTENT( in ) ::   kt      ! ocean time-step index       
    477       REAL(wp)               ::  zfact        
    478       REAL(wp) ::  zrdenittot, zsdenittot, znitrpottot 
     476      INTEGER, INTENT( in ) ::   kt      ! ocean time-step index       
     477      REAL(wp)             ::  zrdenittot, zsdenittot, znitrpottot 
    479478      CHARACTER(LEN=100)   ::   cltxt 
    480479      REAL(wp), DIMENSION(jpi,jpj,jpk) :: zvol 
    … …  
    492491            xfact1 = rfact2r * 12. / 1.e15 * ryyss    ! conversion molC/kt --> PgC/yr 
    493492            xfact2 = 1.e+3 * rno3 * 14. / 1.e12 * ryyss   ! conversion molC/l/s ----> TgN/m3/yr 
     493            xfact3 = 1.e+3 * rfact2r * rno3   ! conversion molC/l/kt ----> molN/m3/s 
    494494            cltxt='time-step   Alkalinity        Nitrate        Phosphorus         Silicate           Iron' 
    495495            IF( lwp ) WRITE(numnut,*)  TRIM(cltxt) 
    … …  
    574574      IF( iom_use( "Sdenit" ) .OR.  ( ln_check_mass .AND. kt == nitend )  ) THEN 
    575575         zsdenittot   = glob_sum ( sdenit(:,:) * e1e2t(:,:) ) 
    576          CALL iom_put( "Sdenit", sdenit(:,:) * zfact * tmask(:,:,1) )  ! Nitrate reduction in the sediments 
     576         CALL iom_put( "Sdenit", sdenit(:,:) * xfact3 * tmask(:,:,1) )  ! Nitrate reduction in the sediments 
    577577      ENDIF 
    578578 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/TOP_SRC/PISCES/sms_pisces.F90

    r6836 r6839  
    101101   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   hi         !: ??? 
    102102   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   excess     !: ??? 
     103   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   aphscale   !:  
     104 
    103105 
    104106   !!* Temperature dependancy of SMS terms 
    … …  
    154156         &      ak23(jpi,jpj,jpk)    , aksp  (jpi,jpj,jpk) ,       & 
    155157         &      akw3(jpi,jpj,jpk)    , borat (jpi,jpj,jpk) ,       & 
    156          &      hi  (jpi,jpj,jpk)    , excess(jpi,jpj,jpk) ,     STAT=ierr(4) ) 
     158         &      hi  (jpi,jpj,jpk)    , excess(jpi,jpj,jpk) ,       & 
     159         &      aphscale(jpi,jpj,jpk),                           STAT=ierr(4) ) 
    157160         ! 
    158161      !* Temperature dependancy of SMS terms 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/TOP_SRC/PISCES/trcice_pisces.F90

    r5385 r6839  
    2929CONTAINS 
    3030 
     31 
    3132   SUBROUTINE trc_ice_ini_pisces 
    3233      !!---------------------------------------------------------------------- 
    33       !!                   ***  ROUTINE trc_ice_ini_pisces *** 
     34      !!                   ***  ROUTINE trc_ini_pisces *** 
     35      !! 
     36      !! ** Purpose :   Initialisation of the PISCES biochemical model 
     37      !!---------------------------------------------------------------------- 
     38 
     39      IF( lk_p4z ) THEN  ;   CALL p4z_ice_ini   !  PISCES 
     40      ELSE               ;   CALL p2z_ice_ini   !  LOBSTER 
     41      ENDIF 
     42 
     43   END SUBROUTINE trc_ice_ini_pisces 
     44 
     45 
     46   SUBROUTINE p4z_ice_ini 
     47 
     48#if defined key_pisces  
     49      !!---------------------------------------------------------------------- 
     50      !!                   ***  ROUTINE p4z_ice_ini *** 
    3451      !! 
    3552      !! ** Purpose :   PISCES fake sea ice model setting 
    … …  
    5875 
    5976                                        !--- Dummy variables 
    60       REAL(wp), DIMENSION(jptra,2) & 
    61                ::  zratio            ! effective ice-ocean tracer cc ratio 
     77      REAL(wp), DIMENSION(jp_pisces,2)  :: zratio  ! effective ice-ocean tracer cc ratio 
     78      REAL(wp), DIMENSION(jp_pisces,4)  :: zpisc   ! prescribes concentration  
     79      !                                            !  1:global, 2:Arctic, 3:Antarctic, 4:Baltic 
     80 
    6281      REAL(wp), DIMENSION(2) :: zrs  ! ice-ocean salinity ratio, 1 - global, 2- Baltic 
    6382      REAL(wp) :: zsice_bal          ! prescribed ice salinity in the Baltic 
    … …  
    8099      ! fluxes 
    81100 
    82       !--- Global case  
    83       IF ( cn_trc_o(jpdic) == 'GL ' ) trc_o(:,:,jpdic) =  1.99e-3_wp  
    84       IF ( cn_trc_o(jpdoc) == 'GL ' ) trc_o(:,:,jpdoc) =  2.04e-5_wp  
    85       IF ( cn_trc_o(jptal) == 'GL ' ) trc_o(:,:,jptal) =  2.31e-3_wp  
    86       IF ( cn_trc_o(jpoxy) == 'GL ' ) trc_o(:,:,jpoxy) =  2.47e-4_wp 
    87       IF ( cn_trc_o(jpcal) == 'GL ' ) trc_o(:,:,jpcal) =  1.04e-8_wp 
    88       IF ( cn_trc_o(jppo4) == 'GL ' ) trc_o(:,:,jppo4) =  5.77e-7_wp / po4r  
    89       IF ( cn_trc_o(jppoc) == 'GL ' ) trc_o(:,:,jppoc) =  1.27e-6_wp   
     101      !--- Global values 
     102      zpisc(jpdic,1) =  1.99e-3_wp  
     103      zpisc(jpdoc,1) =  2.04e-5_wp  
     104      zpisc(jptal,1) =  2.31e-3_wp  
     105      zpisc(jpoxy,1) =  2.47e-4_wp 
     106      zpisc(jpcal,1) =  1.04e-8_wp 
     107      zpisc(jppo4,1) =  5.77e-7_wp / po4r  
     108      zpisc(jppoc,1) =  1.27e-6_wp   
    90109#  if ! defined key_kriest 
    91       IF ( cn_trc_o(jpgoc) == 'GL ' ) trc_o(:,:,jpgoc) =  5.23e-8_wp   
    92       IF ( cn_trc_o(jpbfe) == 'GL ' ) trc_o(:,:,jpbfe) =  9.84e-13_wp  
     110      zpisc(jpgoc,1) =  5.23e-8_wp   
     111      zpisc(jpbfe,1) =  9.84e-13_wp  
    93112#  else 
    94       IF ( cn_trc_o(jpnum) == 'GL ' ) trc_o(:,:,jpnum) = 0. ! could not get this value since did not use it 
     113      zpisc(jpnum,1) = 0. ! could not get this value since did not use it 
    95114#  endif 
    96       IF ( cn_trc_o(jpsil) == 'GL ' ) trc_o(:,:,jpsil) =  7.36e-6_wp   
    97       IF ( cn_trc_o(jpdsi) == 'GL ' ) trc_o(:,:,jpdsi) =  1.07e-7_wp  
    98       IF ( cn_trc_o(jpgsi) == 'GL ' ) trc_o(:,:,jpgsi) =  1.53e-8_wp 
    99       IF ( cn_trc_o(jpphy) == 'GL ' ) trc_o(:,:,jpphy) =  9.57e-8_wp 
    100       IF ( cn_trc_o(jpdia) == 'GL ' ) trc_o(:,:,jpdia) =  4.24e-7_wp 
    101       IF ( cn_trc_o(jpzoo) == 'GL ' ) trc_o(:,:,jpzoo) =  6.07e-7_wp 
    102       IF ( cn_trc_o(jpmes) == 'GL ' ) trc_o(:,:,jpmes) =  3.44e-7_wp 
    103       IF ( cn_trc_o(jpfer) == 'GL ' ) trc_o(:,:,jpfer) =  4.06e-10_wp 
    104       IF ( cn_trc_o(jpsfe) == 'GL ' ) trc_o(:,:,jpsfe) =  2.51e-11_wp 
    105       IF ( cn_trc_o(jpdfe) == 'GL ' ) trc_o(:,:,jpdfe) =  6.57e-12_wp 
    106       IF ( cn_trc_o(jpnfe) == 'GL ' ) trc_o(:,:,jpnfe) =  1.76e-11_wp 
    107       IF ( cn_trc_o(jpnch) == 'GL ' ) trc_o(:,:,jpnch) =  1.67e-7_wp 
    108       IF ( cn_trc_o(jpdch) == 'GL ' ) trc_o(:,:,jpdch) =  1.02e-7_wp 
    109       IF ( cn_trc_o(jpno3) == 'GL ' ) trc_o(:,:,jpno3) =  5.79e-6_wp / rno3  
    110       IF ( cn_trc_o(jpnh4) == 'GL ' ) trc_o(:,:,jpnh4) =  3.22e-7_wp / rno3 
     115      zpisc(jpsil,1) =  7.36e-6_wp   
     116      zpisc(jpdsi,1) =  1.07e-7_wp  
     117      zpisc(jpgsi,1) =  1.53e-8_wp 
     118      zpisc(jpphy,1) =  9.57e-8_wp 
     119      zpisc(jpdia,1) =  4.24e-7_wp 
     120      zpisc(jpzoo,1) =  6.07e-7_wp 
     121      zpisc(jpmes,1) =  3.44e-7_wp 
     122      zpisc(jpfer,1) =  4.06e-10_wp 
     123      zpisc(jpsfe,1) =  2.51e-11_wp 
     124      zpisc(jpdfe,1) =  6.57e-12_wp 
     125      zpisc(jpnfe,1) =  1.76e-11_wp 
     126      zpisc(jpnch,1) =  1.67e-7_wp 
     127      zpisc(jpdch,1) =  1.02e-7_wp 
     128      zpisc(jpno3,1) =  5.79e-6_wp / rno3  
     129      zpisc(jpnh4,1) =  3.22e-7_wp / rno3 
    111130 
    112131      !--- Arctic specificities (dissolved inorganic & DOM) 
    113       IF ( cn_trc_o(jpdic) == 'AA ' ) THEN ; WHERE( gphit(:,:) >= 00._wp ) ; trc_o(:,:,jpdic) =  1.98e-3_wp  ; END WHERE ; ENDIF 
    114       IF ( cn_trc_o(jpdoc) == 'AA ' ) THEN ; WHERE( gphit(:,:) >= 00._wp ) ; trc_o(:,:,jpdoc) =  6.00e-6_wp  ; END WHERE ; ENDIF 
    115       IF ( cn_trc_o(jptal) == 'AA ' ) THEN ; WHERE( gphit(:,:) >= 00._wp ) ; trc_o(:,:,jptal) =  2.13e-3_wp  ; END WHERE ; ENDIF 
    116       IF ( cn_trc_o(jpoxy) == 'AA ' ) THEN ; WHERE( gphit(:,:) >= 00._wp ) ; trc_o(:,:,jpoxy) =  3.65e-4_wp  ; END WHERE ; ENDIF 
    117       IF ( cn_trc_o(jpcal) == 'AA ' ) THEN ; WHERE( gphit(:,:) >= 00._wp ) ; trc_o(:,:,jpcal) =  1.50e-9_wp  ; END WHERE ; ENDIF 
    118       IF ( cn_trc_o(jppo4) == 'AA ' ) THEN ; WHERE( gphit(:,:) >= 00._wp ) ; trc_o(:,:,jppo4) =  4.09e-7_wp / po4r ; END WHERE ; ENDIF 
    119       IF ( cn_trc_o(jppoc) == 'AA ' ) THEN ; WHERE( gphit(:,:) >= 00._wp ) ; trc_o(:,:,jppoc) =  4.05e-7_wp  ; END WHERE ; ENDIF 
     132      zpisc(jpdic,2) =  1.98e-3_wp  
     133      zpisc(jpdoc,2) =  6.00e-6_wp  
     134      zpisc(jptal,2) =  2.13e-3_wp  
     135      zpisc(jpoxy,2) =  3.65e-4_wp   
     136      zpisc(jpcal,2) =  1.50e-9_wp   
     137      zpisc(jppo4,2) =  4.09e-7_wp / po4r  
     138      zpisc(jppoc,2) =  4.05e-7_wp   
    120139#  if ! defined key_kriest 
    121       IF ( cn_trc_o(jpgoc) == 'AA ' ) THEN ; WHERE( gphit(:,:) >= 00._wp ) ; trc_o(:,:,jpgoc) =  2.84e-8_wp  ; END WHERE ; ENDIF 
    122       IF ( cn_trc_o(jpbfe) == 'AA ' ) THEN ; WHERE( gphit(:,:) >= 00._wp ) ; trc_o(:,:,jpbfe) =  7.03e-13_wp ; END WHERE ; ENDIF 
     140      zpisc(jpgoc,2) =  2.84e-8_wp   
     141      zpisc(jpbfe,2) =  7.03e-13_wp  
    123142#  else 
    124       IF ( cn_trc_o(jpnum) == 'AA ' ) THEN ; WHERE( gphit(:,:) >= 00._wp ) ; trc_o(:,:,jpnum) =  0.00e-00_wp ; END WHERE ; ENDIF 
     143      zpisc(jpnum,2) =  0.00e-00_wp  
    125144#  endif 
    126       IF ( cn_trc_o(jpsil) == 'AA ' ) THEN ; WHERE( gphit(:,:) >= 00._wp ) ; trc_o(:,:,jpsil) =  6.87e-6_wp  ; END WHERE ; ENDIF 
    127       IF ( cn_trc_o(jpdsi) == 'AA ' ) THEN ; WHERE( gphit(:,:) >= 00._wp ) ; trc_o(:,:,jpdsi) =  1.73e-7_wp  ; END WHERE ; ENDIF 
    128       IF ( cn_trc_o(jpgsi) == 'AA ' ) THEN ; WHERE( gphit(:,:) >= 00._wp ) ; trc_o(:,:,jpgsi) =  7.93e-9_wp  ; END WHERE ; ENDIF 
    129       IF ( cn_trc_o(jpphy) == 'AA ' ) THEN ; WHERE( gphit(:,:) >= 00._wp ) ; trc_o(:,:,jpphy) =  5.25e-7_wp  ; END WHERE ; ENDIF 
    130       IF ( cn_trc_o(jpdia) == 'AA ' ) THEN ; WHERE( gphit(:,:) >= 00._wp ) ; trc_o(:,:,jpdia) =  7.75e-7_wp  ; END WHERE ; ENDIF 
    131       IF ( cn_trc_o(jpzoo) == 'AA ' ) THEN ; WHERE( gphit(:,:) >= 00._wp ) ; trc_o(:,:,jpzoo) =  3.34e-7_wp  ; END WHERE ; ENDIF 
    132       IF ( cn_trc_o(jpmes) == 'AA ' ) THEN ; WHERE( gphit(:,:) >= 00._wp ) ; trc_o(:,:,jpmes) =  2.49e-7_wp  ; END WHERE ; ENDIF 
    133       IF ( cn_trc_o(jpfer) == 'AA ' ) THEN ; WHERE( gphit(:,:) >= 00._wp ) ; trc_o(:,:,jpfer) =  1.43e-9_wp  ; END WHERE ; ENDIF 
    134       IF ( cn_trc_o(jpsfe) == 'AA ' ) THEN ; WHERE( gphit(:,:) >= 00._wp ) ; trc_o(:,:,jpsfe) =  2.21e-11_wp ; END WHERE ; ENDIF 
    135       IF ( cn_trc_o(jpdfe) == 'AA ' ) THEN ; WHERE( gphit(:,:) >= 00._wp ) ; trc_o(:,:,jpdfe) =  2.04e-11_wp ; END WHERE ; ENDIF 
    136       IF ( cn_trc_o(jpnfe) == 'AA ' ) THEN ; WHERE( gphit(:,:) >= 00._wp ) ; trc_o(:,:,jpnfe) =  1.75e-11_wp ; END WHERE ; ENDIF 
    137       IF ( cn_trc_o(jpnch) == 'AA ' ) THEN ; WHERE( gphit(:,:) >= 00._wp ) ; trc_o(:,:,jpnch) =  1.46e-07_wp ; END WHERE ; ENDIF 
    138       IF ( cn_trc_o(jpdch) == 'AA ' ) THEN ; WHERE( gphit(:,:) >= 00._wp ) ; trc_o(:,:,jpdch) =  2.36e-07_wp ; END WHERE ; ENDIF 
    139       IF ( cn_trc_o(jpno3) == 'AA ' ) THEN ; WHERE( gphit(:,:) >= 00._wp ) ; trc_o(:,:,jpno3) =  3.51e-06_wp / rno3 ; END WHERE ; ENDIF 
    140       IF ( cn_trc_o(jpnh4) == 'AA ' ) THEN ; WHERE( gphit(:,:) >= 00._wp ) ; trc_o(:,:,jpnh4) =  6.15e-08_wp / rno3 ; END WHERE ; ENDIF 
     145      zpisc(jpsil,2) =  6.87e-6_wp   
     146      zpisc(jpdsi,2) =  1.73e-7_wp  
     147      zpisc(jpgsi,2) =  7.93e-9_wp 
     148      zpisc(jpphy,2) =  5.25e-7_wp   
     149      zpisc(jpdia,2) =  7.75e-7_wp  
     150      zpisc(jpzoo,2) =  3.34e-7_wp 
     151      zpisc(jpmes,2) =  2.49e-7_wp   
     152      zpisc(jpfer,2) =  1.43e-9_wp  
     153      zpisc(jpsfe,2) =  2.21e-11_wp  
     154      zpisc(jpdfe,2) =  2.04e-11_wp  
     155      zpisc(jpnfe,2) =  1.75e-11_wp  
     156      zpisc(jpnch,2) =  1.46e-07_wp  
     157      zpisc(jpdch,2) =  2.36e-07_wp  
     158      zpisc(jpno3,2) =  3.51e-06_wp / rno3  
     159      zpisc(jpnh4,2) =  6.15e-08_wp / rno3  
    141160 
    142161      !--- Antarctic specificities (dissolved inorganic & DOM) 
    143       IF ( cn_trc_o(jpdic) == 'AA ' ) THEN ; WHERE( gphit(:,:) <  00._wp ) ; trc_o(:,:,jpdic) =  2.20e-3_wp  ; END WHERE ; ENDIF 
    144       IF ( cn_trc_o(jpdoc) == 'AA ' ) THEN ; WHERE( gphit(:,:) <  00._wp ) ; trc_o(:,:,jpdoc) =  7.02e-6_wp  ; END WHERE ; ENDIF 
    145       IF ( cn_trc_o(jptal) == 'AA ' ) THEN ; WHERE( gphit(:,:) <  00._wp ) ; trc_o(:,:,jptal) =  2.37e-3_wp  ; END WHERE ; ENDIF 
    146       IF ( cn_trc_o(jpoxy) == 'AA ' ) THEN ; WHERE( gphit(:,:) <  00._wp ) ; trc_o(:,:,jpoxy) =  3.42e-4_wp  ; END WHERE ; ENDIF 
    147       IF ( cn_trc_o(jpcal) == 'AA ' ) THEN ; WHERE( gphit(:,:) <  00._wp ) ; trc_o(:,:,jpcal) =  3.17e-9_wp  ; END WHERE ; ENDIF 
    148       IF ( cn_trc_o(jppo4) == 'AA ' ) THEN ; WHERE( gphit(:,:) <  00._wp ) ; trc_o(:,:,jppo4) =  1.88e-6_wp / po4r  ; END WHERE ; ENDIF 
    149       IF ( cn_trc_o(jppoc) == 'AA ' ) THEN ; WHERE( gphit(:,:) <  00._wp ) ; trc_o(:,:,jppoc) =  1.13e-6_wp  ; END WHERE ; ENDIF 
     162      zpisc(jpdic,3) =  2.20e-3_wp   
     163      zpisc(jpdoc,3) =  7.02e-6_wp   
     164      zpisc(jptal,3) =  2.37e-3_wp   
     165      zpisc(jpoxy,3) =  3.42e-4_wp   
     166      zpisc(jpcal,3) =  3.17e-9_wp   
     167      zpisc(jppo4,3) =  1.88e-6_wp / po4r   
     168      zpisc(jppoc,3) =  1.13e-6_wp   
    150169#  if ! defined key_kriest 
    151       IF ( cn_trc_o(jpgoc) == 'AA ' ) THEN ; WHERE( gphit(:,:) <  00._wp ) ; trc_o(:,:,jpgoc) =  2.89e-8_wp  ; END WHERE ; ENDIF 
    152       IF ( cn_trc_o(jpbfe) == 'AA ' ) THEN ; WHERE( gphit(:,:) <  00._wp ) ; trc_o(:,:,jpbfe) =  5.63e-13_wp ; END WHERE ; ENDIF 
     170      zpisc(jpgoc,3) =  2.89e-8_wp   
     171      zpisc(jpbfe,3) =  5.63e-13_wp  
    153172#  else 
    154       IF ( cn_trc_o(jpnum) == 'AA ' ) THEN ; WHERE( gphit(:,:) <  00._wp ) ; trc_o(:,:,jpnum) =  0.00e-00_wp ; END WHERE ; ENDIF 
     173      zpisc(jpnum,3) =  0.00e-00_wp  
    155174#  endif 
    156       IF ( cn_trc_o(jpsil) == 'AA ' ) THEN ; WHERE( gphit(:,:) <  00._wp ) ; trc_o(:,:,jpsil) =  4.96e-5_wp  ; END WHERE ; ENDIF 
    157       IF ( cn_trc_o(jpdsi) == 'AA ' ) THEN ; WHERE( gphit(:,:) <  00._wp ) ; trc_o(:,:,jpdsi) =  5.63e-7_wp  ; END WHERE ; ENDIF 
    158       IF ( cn_trc_o(jpgsi) == 'AA ' ) THEN ; WHERE( gphit(:,:) <  00._wp ) ; trc_o(:,:,jpgsi) =  5.35e-8_wp  ; END WHERE ; ENDIF 
    159       IF ( cn_trc_o(jpphy) == 'AA ' ) THEN ; WHERE( gphit(:,:) <  00._wp ) ; trc_o(:,:,jpphy) =  8.10e-7_wp  ; END WHERE ; ENDIF 
    160       IF ( cn_trc_o(jpdia) == 'AA ' ) THEN ; WHERE( gphit(:,:) <  00._wp ) ; trc_o(:,:,jpdia) =  5.77e-7_wp  ; END WHERE ; ENDIF 
    161       IF ( cn_trc_o(jpzoo) == 'AA ' ) THEN ; WHERE( gphit(:,:) <  00._wp ) ; trc_o(:,:,jpzoo) =  6.68e-7_wp  ; END WHERE ; ENDIF 
    162       IF ( cn_trc_o(jpmes) == 'AA ' ) THEN ; WHERE( gphit(:,:) <  00._wp ) ; trc_o(:,:,jpmes) =  3.55e-7_wp  ; END WHERE ; ENDIF 
    163       IF ( cn_trc_o(jpfer) == 'AA ' ) THEN ; WHERE( gphit(:,:) <  00._wp ) ; trc_o(:,:,jpfer) =  1.62e-10_wp ; END WHERE ; ENDIF 
    164       IF ( cn_trc_o(jpsfe) == 'AA ' ) THEN ; WHERE( gphit(:,:) <  00._wp ) ; trc_o(:,:,jpsfe) =  2.29e-11_wp ; END WHERE ; ENDIF 
    165       IF ( cn_trc_o(jpdfe) == 'AA ' ) THEN ; WHERE( gphit(:,:) <  00._wp ) ; trc_o(:,:,jpdfe) =  8.75e-12_wp ; END WHERE ; ENDIF 
    166       IF ( cn_trc_o(jpnfe) == 'AA ' ) THEN ; WHERE( gphit(:,:) <  00._wp ) ; trc_o(:,:,jpnfe) =  1.48e-11_wp ; END WHERE ; ENDIF 
    167       IF ( cn_trc_o(jpnch) == 'AA ' ) THEN ; WHERE( gphit(:,:) <  00._wp ) ; trc_o(:,:,jpnch) =  2.02e-7_wp  ; END WHERE ; ENDIF 
    168       IF ( cn_trc_o(jpdch) == 'AA ' ) THEN ; WHERE( gphit(:,:) <  00._wp ) ; trc_o(:,:,jpdch) =  1.60e-7_wp  ; END WHERE ; ENDIF 
    169       IF ( cn_trc_o(jpno3) == 'AA ' ) THEN ; WHERE( gphit(:,:) <  00._wp ) ; trc_o(:,:,jpno3) =  2.64e-5_wp / rno3  ; END WHERE ; ENDIF 
    170       IF ( cn_trc_o(jpnh4) == 'AA ' ) THEN ; WHERE( gphit(:,:) <  00._wp ) ; trc_o(:,:,jpnh4) =  3.39e-7_wp / rno3  ; END WHERE ; ENDIF 
     175      zpisc(jpsil,3) =  4.96e-5_wp   
     176      zpisc(jpdsi,3) =  5.63e-7_wp  
     177      zpisc(jpgsi,3) =  5.35e-8_wp 
     178      zpisc(jpphy,3) =  8.10e-7_wp   
     179      zpisc(jpdia,3) =  5.77e-7_wp  
     180      zpisc(jpzoo,3) =  6.68e-7_wp 
     181      zpisc(jpmes,3) =  3.55e-7_wp   
     182      zpisc(jpfer,3) =  1.62e-10_wp 
     183      zpisc(jpsfe,3) =  2.29e-11_wp  
     184      zpisc(jpdfe,3) =  8.75e-12_wp 
     185      zpisc(jpnfe,3) =  1.48e-11_wp  
     186      zpisc(jpnch,3) =  2.02e-7_wp   
     187      zpisc(jpdch,3) =  1.60e-7_wp   
     188      zpisc(jpno3,3) =  2.64e-5_wp / rno3   
     189      zpisc(jpnh4,3) =  3.39e-7_wp / rno3   
    171190 
    172191      !--- Baltic Sea particular case for ORCA configurations 
    173       IF( cp_cfg == "orca" ) THEN            ! Baltic mask 
    174          WHERE( 14._wp <= glamt(:,:) .AND. glamt(:,:) <= 32._wp .AND.    & 
    175                 54._wp <= gphit(:,:) .AND. gphit(:,:) <= 66._wp ) 
    176          trc_o(:,:,jpdic) = 1.14e-3_wp 
    177          trc_o(:,:,jpdoc) = 1.06e-5_wp 
    178          trc_o(:,:,jptal) = 1.16e-3_wp 
    179          trc_o(:,:,jpoxy) = 3.71e-4_wp 
    180          trc_o(:,:,jpcal) = 1.51e-9_wp 
    181          trc_o(:,:,jppo4) = 2.85e-9_wp / po4r 
    182          trc_o(:,:,jppoc) = 4.84e-7_wp 
     192      zpisc(jpdic,4) = 1.14e-3_wp 
     193      zpisc(jpdoc,4) = 1.06e-5_wp 
     194      zpisc(jptal,4) = 1.16e-3_wp 
     195      zpisc(jpoxy,4) = 3.71e-4_wp 
     196      zpisc(jpcal,4) = 1.51e-9_wp 
     197      zpisc(jppo4,4) = 2.85e-9_wp / po4r 
     198      zpisc(jppoc,4) = 4.84e-7_wp 
    183199#  if ! defined key_kriest 
    184          trc_o(:,:,jpgoc) = 1.05e-8_wp 
    185          trc_o(:,:,jpbfe) = 4.97e-13_wp 
     200      zpisc(jpgoc,4) = 1.05e-8_wp 
     201      zpisc(jpbfe,4) = 4.97e-13_wp 
    186202#  else 
    187          trc_o(:,:,jpnum) = 0. ! could not get this value 
     203      zpisc(jpnum,4) = 0. ! could not get this value 
    188204#  endif 
    189          trc_o(:,:,jpsil) = 4.91e-5_wp 
    190          trc_o(:,:,jpdsi) = 3.25e-7_wp 
    191          trc_o(:,:,jpgsi) = 1.93e-8_wp 
    192          trc_o(:,:,jpphy) = 6.64e-7_wp 
    193          trc_o(:,:,jpdia) = 3.41e-7_wp 
    194          trc_o(:,:,jpzoo) = 3.83e-7_wp 
    195          trc_o(:,:,jpmes) = 0.225e-6_wp 
    196          trc_o(:,:,jpfer) = 2.45e-9_wp 
    197          trc_o(:,:,jpsfe) = 3.89e-11_wp 
    198          trc_o(:,:,jpdfe) = 1.33e-11_wp 
    199          trc_o(:,:,jpnfe) = 2.62e-11_wp 
    200          trc_o(:,:,jpnch) = 1.17e-7_wp 
    201          trc_o(:,:,jpdch) = 9.69e-8_wp 
    202          trc_o(:,:,jpno3) = 5.36e-5_wp / rno3 
    203          trc_o(:,:,jpnh4) = 7.18e-7_wp / rno3 
    204          END WHERE 
    205       ENDIF ! cfg 
     205      zpisc(jpsil,4) = 4.91e-5_wp 
     206      zpisc(jpdsi,4) = 3.25e-7_wp 
     207      zpisc(jpgsi,4) = 1.93e-8_wp 
     208      zpisc(jpphy,4) = 6.64e-7_wp 
     209      zpisc(jpdia,4) = 3.41e-7_wp 
     210      zpisc(jpzoo,4) = 3.83e-7_wp 
     211      zpisc(jpmes,4) = 0.225e-6_wp 
     212      zpisc(jpfer,4) = 2.45e-9_wp 
     213      zpisc(jpsfe,4) = 3.89e-11_wp 
     214      zpisc(jpdfe,4) = 1.33e-11_wp 
     215      zpisc(jpnfe,4) = 2.62e-11_wp 
     216      zpisc(jpnch,4) = 1.17e-7_wp 
     217      zpisc(jpdch,4) = 9.69e-8_wp 
     218      zpisc(jpno3,4) = 5.36e-5_wp / rno3 
     219      zpisc(jpnh4,4) = 7.18e-7_wp / rno3 
     220  
     221      DO jn = jp_pcs0, jp_pcs1 
     222         IF( cn_trc_o(jn) == 'GL ' ) trc_o(:,:,jn) = zpisc(jn,1)  ! Global case 
     223         IF( cn_trc_o(jn) == 'AA ' ) THEN  
     224            WHERE( gphit(:,:) >= 0._wp ) ; trc_o(:,:,jn) = zpisc(jn,2) ; END WHERE ! Arctic  
     225            WHERE( gphit(:,:) <  0._wp ) ; trc_o(:,:,jn) = zpisc(jn,3) ; END WHERE ! Antarctic  
     226         ENDIF 
     227         IF( cp_cfg == "orca" ) THEN     !  Baltic Sea particular case for ORCA configurations 
     228             WHERE( 14._wp <= glamt(:,:) .AND. glamt(:,:) <= 32._wp .AND.    & 
     229                    54._wp <= gphit(:,:) .AND. gphit(:,:) <= 66._wp ) 
     230                    trc_o(:,:,jn) = zpisc(jn,4) 
     231            END WHERE 
     232         ENDIF  
     233      ENDDO 
     234 
     235 
    206236 
    207237      !----------------------------- 
    … …  
    217247 
    218248      DO jn = jp_pcs0, jp_pcs1 
    219          IF ( trc_ice_ratio(jn) >= 0._wp )  zratio(jn,:) = trc_ice_ratio(jn) 
    220          IF ( trc_ice_ratio(jn) == -1._wp ) zratio(jn,:) = zrs(:) 
    221          IF ( trc_ice_ratio(jn) == -2._wp ) zratio(jn,:) = -9999.99_wp 
     249         IF( trc_ice_ratio(jn) >= 0._wp )  zratio(jn,:) = trc_ice_ratio(jn) 
     250         IF( trc_ice_ratio(jn) == -1._wp ) zratio(jn,:) = zrs(:) 
     251         IF( trc_ice_ratio(jn) == -2._wp ) zratio(jn,:) = -9999.99_wp 
    222252      END DO 
    223253 
    … …  
    227257      DO jn = jp_pcs0, jp_pcs1 
    228258         !-- Everywhere but in the Baltic 
    229          IF ( trc_ice_ratio(jn) >= -1._wp ) THEN !! no prescribed concentration 
    230                                               !! (typically everything but iron)  
     259         IF ( trc_ice_ratio(jn) >= -1._wp ) THEN ! no prescribed conc. ; typically everything but iron)  
    231260            trc_i(:,:,jn) = zratio(jn,1) * trc_o(:,:,jn)  
    232          ELSE                                 !! prescribed concentration 
     261         ELSE                                    ! prescribed concentration 
    233262            trc_i(:,:,jn) = trc_ice_prescr(jn) 
    234263         ENDIF 
    235264        
    236265         !-- Baltic 
    237          IF( cp_cfg == "orca" ) THEN !! Baltic treated seperately for ORCA configs 
    238             IF ( trc_ice_ratio(jn) >= - 1._wp ) THEN !! no prescribed concentration 
    239                                                  !! (typically everything but iron)  
     266         IF( cp_cfg == "orca" ) THEN  ! Baltic treated seperately for ORCA configs 
     267            IF ( trc_ice_ratio(jn) >= - 1._wp ) THEN ! no prescribed conc. ; typically everything but iron)  
    240268               WHERE( 14._wp <= glamt(:,:) .AND. glamt(:,:) <= 32._wp .AND.    & 
    241269                      54._wp <= gphit(:,:) .AND. gphit(:,:) <= 66._wp ) 
    242270                     trc_i(:,:,jn) = zratio(jn,2) * trc_o(:,:,jn)  
    243271               END WHERE 
    244             ELSE                                 !! prescribed tracer concentration in ice 
     272            ELSE                                 ! prescribed tracer concentration in ice 
    245273               WHERE( 14._wp <= glamt(:,:) .AND. glamt(:,:) <= 32._wp .AND.    & 
    246274                   54._wp <= gphit(:,:) .AND. gphit(:,:) <= 66._wp ) 
    … …  
    251279      ! 
    252280      END DO ! jn 
    253  
    254    END SUBROUTINE trc_ice_ini_pisces 
     281#endif 
     282 
     283   END SUBROUTINE p4z_ice_ini 
     284 
     285   SUBROUTINE p2z_ice_ini 
     286#if defined key_pisces_reduced  
     287      !!---------------------------------------------------------------------- 
     288      !!                   ***  ROUTINE p2z_ice_ini *** 
     289      !! 
     290      !! ** Purpose :   Initialisation of the LOBSTER biochemical model 
     291      !!---------------------------------------------------------------------- 
     292#endif 
     293   END SUBROUTINE p2z_ice_ini 
     294 
    255295 
    256296#else 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/TOP_SRC/PISCES/trcini_pisces.F90

    r6836 r6839  
    115115      po4r    =   1._wp / 122._wp 
    116116      o2nit   =  32._wp / 122._wp 
    117       rdenit  = 105._wp /  16._wp 
     117      o2ut    = 133._wp / 122._wp 
     118      rdenit  =  ( ( o2ut + o2nit ) * 0.80 - rno3 - rno3 * 0.60 ) / rno3 
    118119      rdenita =   3._wp /  5._wp 
    119       o2ut    = 133._wp / 122._wp 
     120 
    120121 
    121122      ! Initialization of tracer concentration in case of  no restart  

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/TOP_SRC/TRP/trcdmp.F90

    r6836 r6839  
    3535   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   restotr   ! restoring coeff. on tracers (s-1) 
    3636 
    37    INTEGER, PARAMETER           ::   npncts   = 5        ! number of closed sea 
     37   INTEGER, PARAMETER           ::   npncts   = 8        ! number of closed sea 
    3838   INTEGER, DIMENSION(npncts)   ::   nctsi1, nctsj1      ! south-west closed sea limits (i,j) 
    3939   INTEGER, DIMENSION(npncts)   ::   nctsi2, nctsj2      ! north-east closed sea limits (i,j) 
    … …  
    107107                
    108108               jl = n_trc_index(jn)  
    109                CALL trc_dta( kt, sf_trcdta(jl),rf_trfac(jl) )   ! read tracer data at nit000 
    110                ztrcdta(:,:,:) = sf_trcdta(jl)%fnow(:,:,:) 
     109               CALL trc_dta( kt, sf_trcdta(jl), rf_trfac(jl), ztrcdta )   ! read tracer data at nit000 
    111110 
    112111               SELECT CASE ( nn_zdmp_tr ) 
    … …  
    208207            ! 
    209208                                                        ! Caspian Sea 
    210             nctsi1(1)   = 332  ; nctsj1(1)   = 243 - isrow 
    211             nctsi2(1)   = 344  ; nctsj2(1)   = 275 - isrow 
     209            nctsi1(1)   = 333  ; nctsj1(1)   = 243 - isrow 
     210            nctsi2(1)   = 342  ; nctsj2(1)   = 274 - isrow 
     211            !                                           ! Lake Superior 
     212            nctsi1(2)   = 198  ; nctsj1(2)   = 258 - isrow 
     213            nctsi2(2)   = 204  ; nctsj2(2)   = 262 - isrow 
     214            !                                           ! Lake Michigan 
     215            nctsi1(3)   = 201  ; nctsj1(3)   = 250 - isrow 
     216            nctsi2(3)   = 203  ; nctsj2(3)   = 256 - isrow 
     217            !                                           ! Lake Huron 
     218            nctsi1(4)   = 204  ; nctsj1(4)   = 252 - isrow 
     219            nctsi2(4)   = 209  ; nctsj2(4)   = 256 - isrow 
     220            !                                           ! Lake Erie 
     221            nctsi1(5)   = 206  ; nctsj1(5)   = 249 - isrow 
     222            nctsi2(5)   = 209  ; nctsj2(5)   = 251 - isrow 
     223            !                                           ! Lake Ontario 
     224            nctsi1(6)   = 210  ; nctsj1(6)   = 252 - isrow 
     225            nctsi2(6)   = 212  ; nctsj2(6)   = 252 - isrow 
     226            !                                           ! Victoria Lake 
     227            nctsi1(7)   = 321  ; nctsj1(7)   = 180 - isrow 
     228            nctsi2(7)   = 322  ; nctsj2(7)   = 189 - isrow 
     229            !                                           ! Baltic Sea 
     230            nctsi1(8)   = 297  ; nctsj1(8)   = 270 - isrow 
     231            nctsi2(8)   = 308  ; nctsj2(8)   = 293 - isrow 
    212232            !                                         
    213233            !                                           ! ======================= 
    … …  
    283303            IF( ln_trc_ini(jn) ) THEN      ! update passive tracers arrays with input data read from file 
    284304                jl = n_trc_index(jn) 
    285                 CALL trc_dta( kt, sf_trcdta(jl),rf_trfac(jl) )   ! read tracer data at nit000 
    286                 ztrcdta(:,:,:) = sf_trcdta(jl)%fnow(:,:,:) 
     305                CALL trc_dta( kt, sf_trcdta(jl), rf_trfac(jl), ztrcdta )   ! read tracer data at nit000 
    287306                DO jc = 1, npncts 
    288307                   DO jk = 1, jpkm1 
    289308                      DO jj = nctsj1(jc), nctsj2(jc) 
    290309                         DO ji = nctsi1(jc), nctsi2(jc) 
    291                             trn(ji,jj,jk,jn) = ztrcdta(ji,jj,jk) * tmask(ji,jj,jk) 
     310                            trn(ji,jj,jk,jn) = ztrcdta(ji,jj,jk) 
    292311                            trb(ji,jj,jk,jn) = trn(ji,jj,jk,jn) 
    293312                         ENDDO 
    … …  
    317336      IF( nn_timing == 1 )  CALL timing_start('trc_dmp_init') 
    318337      ! 
     338      !Allocate arrays 
     339      IF( trc_dmp_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'trc_dmp_init: unable to allocate arrays' ) 
    319340 
    320341      IF( lzoom )   nn_zdmp_tr = 0           ! restoring to climatology at closed north or south boundaries 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/TOP_SRC/TRP/trcldf.F90

    r6836 r6839  
    5656      INTEGER, INTENT( in ) ::   kt   ! ocean time-step index 
    5757      !! 
    58       INTEGER            :: jn 
     58      INTEGER            :: ji, jj, jk, jn 
     59      REAL(wp)           :: zdep 
    5960      CHARACTER (len=22) :: charout 
    6061      REAL(wp), POINTER, DIMENSION(:,:,:,:) ::   ztrtrd 
    … …  
    6667 
    6768      rldf = rldf_rat 
    68  
     69      ! 
     70      r_fact_lap(:,:,:) = 1. 
     71      DO jk= 1, jpk 
     72         DO jj = 1, jpj 
     73            DO ji = 1, jpi 
     74               IF( fsdept(ji,jj,jk) > 200. .AND. gphit(ji,jj) < 5. .AND. gphit(ji,jj) > -5. ) THEN 
     75                  zdep = MAX( fsdept(ji,jj,jk) - 1000., 0. ) / 1000. 
     76                  r_fact_lap(ji,jj,jk) = MAX( 1., rn_fact_lap * EXP( -zdep ) ) 
     77               ENDIF 
     78            END DO 
     79         END DO 
     80      END DO 
     81      ! 
    6982      IF( l_trdtrc )  THEN 
    7083         CALL wrk_alloc( jpi, jpj, jpk, jptra, ztrtrd ) 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/TOP_SRC/TRP/trcnam_trp.F90

    r6836 r6839  
    4040   REAL(wp), PUBLIC ::   rn_ahtrc_0          !: diffusivity coefficient for passive tracer (m2/s) 
    4141   REAL(wp), PUBLIC ::   rn_ahtrb_0          !: background diffusivity coefficient for passive tracer (m2/s) 
     42   REAL(wp), PUBLIC ::   rn_fact_lap         !: Enhanced zonal diffusivity coefficent in the equatorial domain 
    4243 
    4344   !                                        !!: ** Treatment of Negative concentrations ( nam_trcrad ) 
    … …  
    7475      NAMELIST/namtrc_ldf/ ln_trcldf_lap  ,     & 
    7576         &                 ln_trcldf_bilap, ln_trcldf_level,     & 
    76          &                 ln_trcldf_hor  , ln_trcldf_iso  , rn_ahtrc_0, rn_ahtrb_0 
     77         &                 ln_trcldf_hor  , ln_trcldf_iso  , rn_ahtrc_0, rn_ahtrb_0,   & 
     78         &                 rn_fact_lap 
     79 
    7780      NAMELIST/namtrc_zdf/ ln_trczdf_exp  , nn_trczdf_exp 
    7881      NAMELIST/namtrc_rad/ ln_trcrad 
    … …  
    127130         WRITE(numout,*) '      diffusivity coefficient                                 rn_ahtrc_0 = ', rn_ahtrc_0 
    128131         WRITE(numout,*) '      background hor. diffusivity                             rn_ahtrb_0 = ', rn_ahtrb_0 
     132         WRITE(numout,*) '      enhanced zonal diffusivity                             rn_fact_lap = ', rn_fact_lap 
    129133      ENDIF 
    130134 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/TOP_SRC/TRP/trcnxt.F90

    r6836 r6839  
    102102      ENDIF 
    103103 
     104#if defined key_agrif 
     105      CALL Agrif_trc                   ! AGRIF zoom boundaries 
     106#endif 
    104107      ! Update after tracer on domain lateral boundaries 
    105108      DO jn = 1, jptra 
    … …  
    110113#if defined key_bdy 
    111114!!      CALL bdy_trc( kt )               ! BDY open boundaries 
    112 #endif 
    113 #if defined key_agrif 
    114       CALL Agrif_trc                   ! AGRIF zoom boundaries 
    115115#endif 
    116116 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/TOP_SRC/TRP/trcsbc.F90

    r6836 r6839  
    170170            END DO 
    171171         ENDIF 
     172         ! 
     173         CALL lbc_lnk( sbc_trc(:,:,jn), 'T', 1. ) 
    172174         !                                       Concentration dilution effect on tracers due to evaporation & precipitation  
    173175         DO jj = 2, jpj 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/TOP_SRC/TRP/trctrp.F90

    r6836 r6839  
    6767         IF( lk_trabbl )        CALL trc_bbl( kstp )            ! advective (and/or diffusive) bottom boundary layer scheme 
    6868         IF( ln_trcdmp )        CALL trc_dmp( kstp )            ! internal damping trends 
    69          IF( ln_trcdmp_clo )    CALL trc_dmp_clo( kstp )        ! internal damping trends on closed seas only 
    7069                                CALL trc_adv( kstp )            ! horizontal & vertical advection  
    7170                                CALL trc_ldf( kstp )            ! lateral mixing 
    … …  
    7877                                CALL trc_nxt( kstp )            ! tracer fields at next time step      
    7978         IF( ln_trcrad )        CALL trc_rad( kstp )            ! Correct artificial negative concentrations 
     79         IF( ln_trcdmp_clo )    CALL trc_dmp_clo( kstp )        ! internal damping trends on closed seas only 
    8080 
    8181#if defined key_agrif 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/TOP_SRC/oce_trc.F90

    r6836 r6839  
    116116   USE ldftra_oce , ONLY :  aeiw     =>   aeiw        !: eddy induced velocity coef. at w-points (m2/s)  
    117117   USE ldftra_oce , ONLY :  lk_traldf_eiv  =>  lk_traldf_eiv     !: eddy induced velocity flag 
     118   USE ldftra_oce , ONLY :  r_fact_lap     =>  r_fact_lap        !: enhanced zonal diffusivity coefficient 
    118119 
    119120   !* vertical diffusion * 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/TOP_SRC/trcdta.F90

    r6836 r6839  
    7777      ALLOCATE( n_trc_index(ntrc), slf_i(ntrc), STAT=ierr0 ) 
    7878      IF( ierr0 > 0 ) THEN 
    79          CALL ctl_stop( 'trc_nam: unable to allocate n_trc_index' )   ;   RETURN 
     79         CALL ctl_stop( 'trc_dta_init: unable to allocate n_trc_index' )   ;   RETURN 
    8080      ENDIF 
    8181      nb_trcdta      = 0 
    … …  
    9191      IF(lwp) THEN 
    9292         WRITE(numout,*) ' ' 
     93         WRITE(numout,*) 'trc_dta_init : Passive tracers Initial Conditions ' 
     94         WRITE(numout,*) '~~~~~~~~~~~~~~ ' 
    9395         WRITE(numout,*) ' number of passive tracers to be initialize by data :', ntra 
    9496         WRITE(numout,*) ' ' 
    … …  
    107109         DO jn = 1, ntrc 
    108110            IF( ln_trc_ini(jn) )  THEN    ! open input file only if ln_trc_ini(jn) is true 
    109                clndta = TRIM( sn_trcdta(jn)%clvar )  
    110                clntrc = TRIM( ctrcnm   (jn)       )  
     111               clndta = TRIM( sn_trcdta(jn)%clvar ) 
     112               if (jn > jptra) then 
     113                  clntrc='Dummy' ! By pass weird formats in ocean.output if ntrc > jptra 
     114               else 
     115                  clntrc = TRIM( ctrcnm   (jn)       ) 
     116               endif 
    111117               zfact  = rn_trfac(jn) 
    112                IF( clndta /=  clntrc ) THEN  
    113                   CALL ctl_warn( 'trc_dta_init: passive tracer data initialisation :  ',   & 
    114                   &              'the variable name in the data file : '//clndta//   &  
    115                   &              '  must be the same than the name of the passive tracer : '//clntrc//' ') 
     118               IF( clndta /=  clntrc ) THEN 
     119                  CALL ctl_warn( 'trc_dta_init: passive tracer data initialisation    ',   & 
     120                  &              'Input name of data file : '//TRIM(clndta)//   & 
     121                  &              ' differs from that of tracer : '//TRIM(clntrc)//' ') 
    116122               ENDIF 
    117                WRITE(numout,*) ' read an initial file for passive tracer number :', jn, ' name : ', clndta, &  
    118                &               ' multiplicative factor : ', zfact 
     123               WRITE(numout,'(a, i4,3a,e11.3)') ' Read IC file for tracer number :', & 
     124               &            jn, ', name : ', TRIM(clndta), ', Multiplicative Scaling factor : ', zfact 
    119125            ENDIF 
    120126         END DO 
    … …  
    124130         ALLOCATE( sf_trcdta(nb_trcdta), rf_trfac(nb_trcdta), STAT=ierr1 ) 
    125131         IF( ierr1 > 0 ) THEN 
    126             CALL ctl_stop( 'trc_dta_ini: unable to allocate  sf_trcdta structure' )   ;   RETURN 
     132            CALL ctl_stop( 'trc_dta_init: unable to allocate  sf_trcdta structure' )   ;   RETURN 
    127133         ENDIF 
    128134         ! 
    … …  
    135141               IF( sn_trcdta(jn)%ln_tint )  ALLOCATE( sf_trcdta(jl)%fdta(jpi,jpj,jpk,2) , STAT=ierr3 ) 
    136142               IF( ierr2 + ierr3 > 0 ) THEN 
    137                  CALL ctl_stop( 'trc_dta : unable to allocate passive tracer data arrays' )   ;   RETURN 
     143                 CALL ctl_stop( 'trc_dta_init : unable to allocate passive tracer data arrays' )   ;   RETURN 
    138144               ENDIF 
    139145            ENDIF 
    … …  
    141147         ENDDO 
    142148         !                         ! fill sf_trcdta with slf_i and control print 
    143          CALL fld_fill( sf_trcdta, slf_i, cn_dir, 'trc_dta', 'Passive tracer data', 'namtrc' ) 
     149         CALL fld_fill( sf_trcdta, slf_i, cn_dir, 'trc_dta_init', 'Passive tracer data', 'namtrc' ) 
    144150         ! 
    145151      ENDIF 
    … …  
    151157 
    152158 
    153    SUBROUTINE trc_dta( kt, sf_dta, zrf_trfac ) 
     159   SUBROUTINE trc_dta( kt, sf_dta, ptrfac, ptrc) 
    154160      !!---------------------------------------------------------------------- 
    155161      !!                   ***  ROUTINE trc_dta  *** 
    … …  
    164170      !!---------------------------------------------------------------------- 
    165171      INTEGER                     , INTENT(in   ) ::   kt     ! ocean time-step 
    166       TYPE(FLD), DIMENSION(1)   , INTENT(inout) ::   sf_dta     ! array of information on the field to read 
    167       REAL(wp)                  , INTENT(in   ) ::   zrf_trfac  ! multiplication factor 
     172      TYPE(FLD), DIMENSION(1)     , INTENT(inout) ::   sf_dta     ! array of information on the field to read 
     173      REAL(wp)                    , INTENT(in   ) ::   ptrfac  ! multiplication factor 
     174      REAL(wp), DIMENSION(jpi,jpj,jpk), OPTIONAL  , INTENT(out  ) ::   ptrc 
    168175      ! 
    169176      INTEGER ::   ji, jj, jk, jl, jkk, ik    ! dummy loop indices 
    170177      REAL(wp)::   zl, zi 
    171178      REAL(wp), DIMENSION(jpk) ::  ztp                ! 1D workspace 
     179      REAL(wp), POINTER, DIMENSION(:,:,:) ::  ztrcdta   ! 3D  workspace 
    172180      CHARACTER(len=100) :: clndta 
    173181      !!---------------------------------------------------------------------- 
    … …  
    177185      IF( nb_trcdta > 0 ) THEN 
    178186         ! 
     187         CALL wrk_alloc( jpi, jpj, jpk, ztrcdta )    ! Memory allocation 
     188         ! 
    179189         CALL fld_read( kt, 1, sf_dta )      !==   read data at kt time step   ==! 
     190         ztrcdta(:,:,:) = sf_dta(1)%fnow(:,:,:) * tmask(:,:,:)    ! Mask 
    180191         ! 
    181192         IF( ln_sco ) THEN                   !==   s- or mixed s-zps-coordinate   ==! 
    … …  
    186197            ENDIF 
    187198            ! 
    188                DO jj = 1, jpj                         ! vertical interpolation of T & S 
     199            DO jj = 1, jpj                         ! vertical interpolation of T & S 
     200               DO ji = 1, jpi 
     201                  DO jk = 1, jpk                        ! determines the intepolated T-S profiles at each (i,j) points 
     202                     zl = fsdept_n(ji,jj,jk) 
     203                     IF(     zl < gdept_1d(1  ) ) THEN         ! above the first level of data 
     204                        ztp(jk) = ztrcdta(ji,jj,1) 
     205                     ELSEIF( zl > gdept_1d(jpk) ) THEN         ! below the last level of data 
     206                        ztp(jk) =  ztrcdta(ji,jj,jpkm1) 
     207                     ELSE                                      ! inbetween : vertical interpolation between jkk & jkk+1 
     208                        DO jkk = 1, jpkm1                                  ! when  gdept(jkk) < zl < gdept(jkk+1) 
     209                           IF( (zl-gdept_1d(jkk)) * (zl-gdept_1d(jkk+1)) <= 0._wp ) THEN 
     210                              zi = ( zl - gdept_1d(jkk) ) / (gdept_1d(jkk+1)-gdept_1d(jkk)) 
     211                              ztp(jk) = ztrcdta(ji,jj,jkk) + ( ztrcdta(ji,jj,jkk+1) - & 
     212                                        ztrcdta(ji,jj,jkk) ) * zi  
     213                           ENDIF 
     214                        END DO 
     215                     ENDIF 
     216                  END DO 
     217                  DO jk = 1, jpkm1 
     218                    ztrcdta(ji,jj,jk) = ztp(jk) * tmask(ji,jj,jk)     ! mask required for mixed zps-s-coord 
     219                  END DO 
     220                  ztrcdta(ji,jj,jpk) = 0._wp 
     221                END DO 
     222            END DO 
     223            !  
     224         ELSE                                !==   z- or zps- coordinate   ==! 
     225            ! 
     226            IF( ln_zps ) THEN                      ! zps-coordinate (partial steps) interpolation at the last ocean level 
     227               DO jj = 1, jpj 
    189228                  DO ji = 1, jpi 
    190                      DO jk = 1, jpk                        ! determines the intepolated T-S profiles at each (i,j) points 
    191                         zl = fsdept_n(ji,jj,jk) 
    192                         IF(     zl < gdept_1d(1  ) ) THEN         ! above the first level of data 
    193                            ztp(jk) =  sf_dta(1)%fnow(ji,jj,1) 
    194                         ELSEIF( zl > gdept_1d(jpk) ) THEN         ! below the last level of data 
    195                            ztp(jk) =  sf_dta(1)%fnow(ji,jj,jpkm1) 
    196                         ELSE                                      ! inbetween : vertical interpolation between jkk & jkk+1 
    197                            DO jkk = 1, jpkm1                                  ! when  gdept(jkk) < zl < gdept(jkk+1) 
    198                               IF( (zl-gdept_1d(jkk)) * (zl-gdept_1d(jkk+1)) <= 0._wp ) THEN 
    199                                  zi = ( zl - gdept_1d(jkk) ) / (gdept_1d(jkk+1)-gdept_1d(jkk)) 
    200                                  ztp(jk) = sf_dta(1)%fnow(ji,jj,jkk) + ( sf_dta(1)%fnow(ji,jj,jkk+1) - & 
    201                                            sf_dta(1)%fnow(ji,jj,jkk) ) * zi  
    202                               ENDIF 
    203                            END DO 
    204                         ENDIF 
    205                      END DO 
    206                      DO jk = 1, jpkm1 
    207                         sf_dta(1)%fnow(ji,jj,jk) = ztp(jk) * tmask(ji,jj,jk)     ! mask required for mixed zps-s-coord 
    208                      END DO 
    209                      sf_dta(1)%fnow(ji,jj,jpk) = 0._wp 
     229                     ik = mbkt(ji,jj)  
     230                     IF( ik > 1 ) THEN 
     231                        zl = ( gdept_1d(ik) - fsdept_n(ji,jj,ik) ) / ( gdept_1d(ik) - gdept_1d(ik-1) ) 
     232                        ztrcdta(ji,jj,ik) = (1.-zl) * ztrcdta(ji,jj,ik) + zl * ztrcdta(ji,jj,ik-1) 
     233                     ENDIF 
     234                     ik = mikt(ji,jj) 
     235                     IF( ik > 1 ) THEN 
     236                        zl = ( fsdept_n(ji,jj,ik) - gdept_1d(ik) ) / ( gdept_1d(ik+1) - gdept_1d(ik) ) 
     237                        ztrcdta(ji,jj,ik) = (1.-zl) * ztrcdta(ji,jj,ik) + zl * ztrcdta(ji,jj,ik+1) 
     238                     ENDIF 
    210239                  END DO 
    211240               END DO 
    212             !  
    213          ELSE                                !==   z- or zps- coordinate   ==! 
    214             !                              
    215                sf_dta(1)%fnow(:,:,:) = sf_dta(1)%fnow(:,:,:) * tmask(:,:,:)    ! Mask 
    216                ! 
    217                IF( ln_zps ) THEN                      ! zps-coordinate (partial steps) interpolation at the last ocean level 
    218                   DO jj = 1, jpj 
    219                      DO ji = 1, jpi 
    220                         ik = mbkt(ji,jj)  
    221                         IF( ik > 1 ) THEN 
    222                            zl = ( gdept_1d(ik) - fsdept_n(ji,jj,ik) ) / ( gdept_1d(ik) - gdept_1d(ik-1) ) 
    223                            sf_dta(1)%fnow(ji,jj,ik) = (1.-zl) * sf_dta(1)%fnow(ji,jj,ik) + zl * sf_dta(1)%fnow(ji,jj,ik-1) 
    224                         ENDIF 
    225                         ik = mikt(ji,jj) 
    226                         IF( ik > 1 ) THEN 
    227                            zl = ( gdept_0(ji,jj,ik) - gdept_1d(ik) ) / ( gdept_1d(ik+1) - gdept_1d(ik) ) 
    228                            sf_dta(1)%fnow(ji,jj,ik) = (1.-zl) * sf_dta(1)%fnow(ji,jj,ik) + zl * sf_dta(1)%fnow(ji,jj,ik+1) 
    229                         ENDIF 
    230                      END DO 
    231                   END DO 
    232                ENDIF 
    233             ! 
    234          ENDIF 
    235          ! 
    236          sf_dta(1)%fnow(:,:,:) = sf_dta(1)%fnow(:,:,:) * zrf_trfac   !  multiplicative factor 
     241            ENDIF 
     242            ! 
     243         ENDIF 
     244         ! 
     245         ! Add multiplicative factor 
     246         ztrcdta(:,:,:) = ztrcdta(:,:,:) * ptrfac 
     247         ! 
     248         ! Data structure for trc_ini (and BFMv5.1 coupling) 
     249         IF( .NOT. PRESENT(ptrc) ) sf_dta(1)%fnow(:,:,:) = ztrcdta(:,:,:) 
     250         ! 
     251         ! Data structure for trc_dmp 
     252         IF( PRESENT(ptrc) )  ptrc(:,:,:) = ztrcdta(:,:,:) 
    237253         ! 
    238254         IF( lwp .AND. kt == nit000 ) THEN 
    … …  
    241257               WRITE(numout,*) 
    242258               WRITE(numout,*)'  level = 1' 
    243                CALL prihre( sf_dta(1)%fnow(:,:,1), jpi, jpj, 1, jpi, 20, 1, jpj, 20, 1., numout ) 
     259               CALL prihre( ztrcdta(:,:,1), jpi, jpj, 1, jpi, 20, 1, jpj, 20, 1., numout ) 
    244260               WRITE(numout,*)'  level = ', jpk/2 
    245                CALL prihre( sf_dta(1)%fnow(:,:,jpk/2), jpi, jpj, 1, jpi, 20, 1, jpj, 20, 1., numout ) 
     261               CALL prihre( ztrcdta(:,:,jpk/2), jpi, jpj, 1, jpi, 20, 1, jpj, 20, 1., numout ) 
    246262               WRITE(numout,*)'  level = ', jpkm1 
    247                CALL prihre( sf_dta(1)%fnow(:,:,jpkm1), jpi, jpj, 1, jpi, 20, 1, jpj, 20, 1., numout ) 
     263               CALL prihre( ztrcdta(:,:,jpkm1), jpi, jpj, 1, jpi, 20, 1, jpj, 20, 1., numout ) 
    248264               WRITE(numout,*) 
    249265         ENDIF 
     266         ! 
     267         CALL wrk_dealloc( jpi, jpj, jpk, ztrcdta ) 
     268         ! 
    250269      ENDIF 
    251270      ! 
    … …  
    258277   !!---------------------------------------------------------------------- 
    259278CONTAINS 
    260    SUBROUTINE trc_dta( kt, sf_dta, zrf_trfac )        ! Empty routine 
     279   SUBROUTINE trc_dta( kt, sf_dta, ptrfac, ptrc)        ! Empty routine 
    261280      WRITE(*,*) 'trc_dta: You should not have seen this print! error?', kt 
    262281   END SUBROUTINE trc_dta 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/TOP_SRC/trcini.F90

    r6836 r6839  
    6161      INTEGER ::   jk, jn, jl    ! dummy loop indices 
    6262      CHARACTER (len=25) :: charout 
    63       REAL(wp), POINTER, DIMENSION(:,:,:) ::  ztrcdta   ! 4D  workspace 
    6463      !!--------------------------------------------------------------------- 
    6564      ! 
    … …  
    121120        IF( ln_trcdta .AND. nb_trcdta > 0 ) THEN  ! Initialisation of tracer from a file that may also be used for damping 
    122121            ! 
    123             CALL wrk_alloc( jpi, jpj, jpk, ztrcdta )    ! Memory allocation 
    124             ! 
    125122            DO jn = 1, jptra 
    126123               IF( ln_trc_ini(jn) ) THEN      ! update passive tracers arrays with input data read from file 
    127124                  jl = n_trc_index(jn)  
    128                   CALL trc_dta( nit000, sf_trcdta(jl),rf_trfac(jl) )   ! read tracer data at nit000 
    129                   ztrcdta(:,:,:) = sf_trcdta(jl)%fnow(:,:,:) 
    130                   trn(:,:,:,jn) = ztrcdta(:,:,:) * tmask(:,:,:)   
     125                  CALL trc_dta( nit000, sf_trcdta(jl), rf_trfac(jl) )   ! read tracer data at nit000 
     126                  trn(:,:,:,jn) = sf_trcdta(jl)%fnow(:,:,:)  
    131127                  IF( .NOT.ln_trcdmp .AND. .NOT.ln_trcdmp_clo ) THEN      !== deallocate data structure   ==! 
    132128                     !                                                    (data used only for initialisation) 
    … …  
    138134               ENDIF 
    139135            ENDDO 
    140             CALL wrk_dealloc( jpi, jpj, jpk, ztrcdta ) 
     136            ! 
    141137        ENDIF 
    142138        ! 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/TOP_SRC/trcnam.F90

    r6836 r6839  
    397397   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
    398398   !!====================================================================== 
    399 END MODULE  trcnam 
     399END MODULE trcnam 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/TOP_SRC/trcsms.F90

    r6836 r6839  
    7575 
    7676   !!====================================================================== 
    77 END MODULE  trcsms 
     77END MODULE trcsms 

  • branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/TOP_SRC/trcstp.F90

    r6836 r6839  
    3232   REAL(wp), DIMENSION(:,:,:), SAVE, ALLOCATABLE ::   qsr_arr ! save qsr during TOP time-step 
    3333   REAL(wp) :: rdt_sampl 
    34    INTEGER  :: nb_rec_per_days 
     34   INTEGER  :: nb_rec_per_day 
    3535   INTEGER  :: isecfst, iseclast 
    3636   LOGICAL  :: llnew 
    … …  
    123123      !!               of diurnal cycle 
    124124      !! 
    125       !! ** Method  : store in TOP the qsr every hour ( or every time-step the latter  
     125      !! ** Method  : store in TOP the qsr every hour ( or every time-step if the latter  
    126126      !!              is greater than 1 hour ) and then, compute the  mean with  
    127127      !!              a moving average over 24 hours.  
    … …  
    134134         IF( ln_cpl )  THEN   
    135135            rdt_sampl = 86400. / ncpl_qsr_freq 
    136             nb_rec_per_days = ncpl_qsr_freq 
     136            nb_rec_per_day = ncpl_qsr_freq 
    137137         ELSE   
    138138            rdt_sampl = MAX( 3600., rdt * nn_dttrc ) 
    139             nb_rec_per_days = INT( 86400 / rdt_sampl ) 
     139            nb_rec_per_day = INT( 86400 / rdt_sampl ) 
    140140         ENDIF 
    141141         ! 
    142142         IF( lwp ) THEN 
    143143            WRITE(numout,*)  
    144             WRITE(numout,*) ' Sampling frequency dt = ', rdt_sampl, 's','   Number of sampling per day  nrec = ', nb_rec_per_days 
     144            WRITE(numout,*) ' Sampling frequency dt = ', rdt_sampl, 's','   Number of sampling per day  nrec = ', nb_rec_per_day 
    145145            WRITE(numout,*)  
    146146         ENDIF 
    147147         ! 
    148          ALLOCATE( qsr_arr(jpi,jpj,nb_rec_per_days ) ) 
    149          DO jn = 1, nb_rec_per_days 
    150             qsr_arr(:,:,jn) = qsr(:,:) 
     148         !                                            !* Restart: read in restart file 
     149         IF( ln_rsttr .AND. iom_varid( numrtr, 'qsr_mean', ldstop = .FALSE. ) > 0 ) THEN  
     150            IF(lwp) WRITE(numout,*) 'trc_qsr_mean:   qsr_mean read in the restart file' 
     151            CALL iom_get( numrtr, jpdom_autoglo, 'qsr_mean', qsr_mean )   !  A mean of qsr 
     152         ELSE                                         !* no restart: set from nit000 values 
     153            IF(lwp) WRITE(numout,*) 'trc_qsr_mean:   qsr_mean set to nit000 values' 
     154            qsr_mean(:,:) = qsr(:,:) 
     155         ENDIF 
     156         ! 
     157         ALLOCATE( qsr_arr(jpi,jpj,nb_rec_per_day ) ) 
     158         DO jn = 1, nb_rec_per_day 
     159             qsr_arr(:,:,jn) = qsr_mean(:,:) 
    151160         ENDDO 
    152          qsr_mean(:,:) = qsr(:,:) 
    153161         ! 
    154162         isecfst  = nsec_year + nsec1jan000   !   number of seconds between Jan. 1st 00h of nit000 year and the middle of time step 
    … …  
    163171             &                      ' time = ', (iseclast+rdt*nn_dttrc/2.)/3600.,'hours ' 
    164172          isecfst = iseclast 
    165           DO jn = 1, nb_rec_per_days - 1 
     173          DO jn = 1, nb_rec_per_day - 1 
    166174             qsr_arr(:,:,jn) = qsr_arr(:,:,jn+1) 
    167175          ENDDO 
    168           qsr_arr (:,:,nb_rec_per_days) = qsr(:,:) 
    169           qsr_mean(:,:                ) = SUM( qsr_arr(:,:,:), 3 ) / nb_rec_per_days 
    170       ENDIF 
    171       ! 
     176          qsr_arr (:,:,nb_rec_per_day) = qsr(:,:) 
     177          qsr_mean(:,:                ) = SUM( qsr_arr(:,:,:), 3 ) / nb_rec_per_day 
     178      ENDIF 
     179      ! 
     180      IF( lrst_trc ) THEN    !* Write the mean of qsr in restart file  
     181         IF(lwp) WRITE(numout,*) 
     182         IF(lwp) WRITE(numout,*) 'trc_mean_qsr : write qsr_mean in restart file  kt =', kt 
     183         IF(lwp) WRITE(numout,*) '~~~~~~~' 
     184         CALL iom_rstput( kt, nitrst, numrtw, 'qsr_mean', qsr_mean(:,:) ) 
     185      ENDIF 
     186     ! 
    172187   END SUBROUTINE trc_mean_qsr 
    173188 
Note: See TracChangeset for help on using the changeset viewer.