Changeset 8879 for branches/UKMO
- Timestamp:
- 2017-12-01T14:53:57+01:00 (6 years ago)
- Location:
- branches/UKMO/dev_r8126_LIM3_couple
- Files:
-
- 35 deleted
- 86 edited
- 38 copied
Legend:
- Unmodified
- Added
- Removed
-
branches/UKMO/dev_r8126_LIM3_couple/DOC/Namelists/nambdy_dta
r8877 r8879 11 11 bn_tem = 'amm12_bdyT_tra', 24 , 'votemper', .true. , .false. , 'daily' , '' , '' , '' 12 12 bn_sal = 'amm12_bdyT_tra', 24 , 'vosaline', .true. , .false. , 'daily' , '' , '' , '' 13 ! for lim214 ! bn_frld = 'amm12_bdyT_ice', 24 , 'ileadfra', .true. , .false. , 'daily' , '' , '' , ''15 ! bn_hicif = 'amm12_bdyT_ice', 24 , 'iicethic', .true. , .false. , 'daily' , '' , '' , ''16 ! bn_hsnif = 'amm12_bdyT_ice', 24 , 'isnowthi', .true. , .false. , 'daily' , '' , '' , ''17 13 ! for lim3 18 14 ! bn_a_i = 'amm12_bdyT_ice', 24 , 'ileadfra', .true. , .false. , 'daily' , '' , '' , '' -
branches/UKMO/dev_r8126_LIM3_couple/DOC/Namelists/namsbc
r6997 r8879 23 23 ! = 2 Redistribute a single flux over categories (coupled mode only) 24 24 ! Sea-ice : 25 nn_ice = 2! =0 no ice boundary condition ,25 nn_ice = 3 ! =0 no ice boundary condition , 26 26 ! =1 use observed ice-cover , 27 ! = 2 ice-model used ("key_lim3", "key_lim2", "key_cice")27 ! =3-4 ice-model used ("key_lim3", "key_cice") 28 28 nn_ice_embd = 1 ! =0 levitating ice (no mass exchange, concentration/dilution effect) 29 29 ! =1 levitating ice with mass and salt exchange but no presure effect -
branches/UKMO/dev_r8126_LIM3_couple/DOC/TexFiles/Chapters/Chap_SBC.tex
r7646 r8879 1266 1266 ice-ocean fluxes, that are combined with the air-sea fluxes using the ice fraction of 1267 1267 each model cell to provide the surface ocean fluxes. Note that the activation of a 1268 sea-ice model is is done by defining a CPP key (\key{lim 2}, \key{lim3} or \key{cice}).1268 sea-ice model is is done by defining a CPP key (\key{lim3} or \key{cice}). 1269 1269 The activation automatically overwrites the read value of nn{\_}ice to its appropriate 1270 1270 value ($i.e.$ $2$ for LIM-2, $3$ for LIM-3 or $4$ for CICE). -
branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/CONFIG/ORCA2_LIM3_PISCES/EXP00/1_namelist_cfg
r7942 r8879 20 20 / 21 21 !----------------------------------------------------------------------- 22 &namzgr ! vertical coordinate23 !-----------------------------------------------------------------------24 ln_zps = .true. ! z-coordinate - partial steps25 /26 !-----------------------------------------------------------------------27 22 &namdom ! space and time domain (bathymetry, mesh, timestep) 28 23 !----------------------------------------------------------------------- 29 ln_linssh = . true. ! =T linear free surface ==>> model level are fixed in time24 ln_linssh = .false. ! =T linear free surface ==>> model level are fixed in time 30 25 nn_closea = 0 ! remove (=0) or keep (=1) closed seas and lakes (ORCA) 31 26 ! … … 46 41 !----------------------------------------------------------------------- 47 42 ln_blk = .true. ! CORE bulk formulation (T => fill namsbc_core) 48 nn_ice = 3! =0 no ice boundary condition ,43 nn_ice = 2 ! =0 no ice boundary condition , 49 44 ! =1 use observed ice-cover , 50 ! =2 ice-model used ("key_lim3" or "key_lim2)45 ! =2 ice-model used ("key_lim3") 51 46 ln_rnf = .false. ! runoffs (T => fill namsbc_rnf) 52 47 ln_ssr = .false. ! Sea Surface Restoring on T and/or S (T => fill namsbc_ssr) … … 176 171 &namdyn_hpg ! Hydrostatic pressure gradient option 177 172 !----------------------------------------------------------------------- 173 ln_hpg_sco = .true. ! s-coordinate (standard jacobian formulation) 178 174 / 179 175 !----------------------------------------------------------------------- -
branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/CONFIG/ORCA2_LIM3_PISCES/EXP00/file_def_nemo.xml
r7948 r8879 95 95 <field field_ref="avt" name="difvho" /> 96 96 <field field_ref="w_masstr" name="vovematr" /> 97 98 99 100 101 102 103 97 <!-- variables available with key_zdftmx_new --> 98 <field field_ref="av_wave" name="av_wave" /> 99 <field field_ref="bn2" name="bn2" /> 100 <field field_ref="bflx_tmx" name="bflx_tmx" /> 101 <field field_ref="pcmap_tmx" name="pcmap_tmx" /> 102 <field field_ref="emix_tmx" name="emix_tmx" /> 103 <field field_ref="av_ratio" name="av_ratio" /> 104 104 </file> 105 105 -
branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/CONFIG/ORCA2_LIM3_PISCES/EXP00/namelist_cfg
r7933 r8879 19 19 / 20 20 !----------------------------------------------------------------------- 21 &namzgr ! vertical coordinate22 !-----------------------------------------------------------------------23 ln_zps = .true. ! z-coordinate - partial steps24 /25 !-----------------------------------------------------------------------26 21 &namdom ! space and time domain (bathymetry, mesh, timestep) 27 22 !----------------------------------------------------------------------- … … 53 48 &namtra_qsr ! penetrative solar radiation 54 49 !----------------------------------------------------------------------- 50 / 51 &namsbc_cpl 55 52 / 56 53 !----------------------------------------------------------------------- -
branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/CONFIG/ORCA2_LIM3_PISCES/EXP00/namelist_ice_cfg
r7823 r8879 1 1 !!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 2 !! LIM3 configuration namelist: Overwrites SHARED/namelist_ice_lim3_ref 3 !! 1 - Generic parameters (namicerun) 4 !! 2 - Diagnostics (namicediag) 5 !! 3 - Ice initialization (namiceini) 6 !! 4 - Ice discretization (namiceitd) 7 !! 5 - Ice dynamics and transport (namicedyn) 8 !! 6 - Ice diffusion (namicehdf) 9 !! 7 - Ice thermodynamics (namicethd) 10 !! 8 - Ice salinity (namicesal) 11 !! 9 - Ice mechanical redistribution (namiceitdme) 12 !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 2 !! ESIM configuration namelist: Overwrites SHARED/namelist_ice_lim3_ref 3 !! 1 - Generic parameters (nampar) 4 !! 2 - Ice thickness discretization (namitd) 5 !! 3 - Ice dynamics (namdyn) 6 !! 4 - Ice ridging/rafting (namdyn_rdgrft) 7 !! 5 - Ice rheology (namdyn_rhg) 8 !! 6 - Ice advection (namdyn_adv) 9 !! 7 - Ice surface forcing (namforcing) 10 !! 8 - Ice thermodynamics (namthd) 11 !! 9 - Ice heat diffusion (namthd_zdf) 12 !! 10 - Ice lateral melting (namthd_da) 13 !! 11 - Ice growth in open water (namthd_do) 14 !! 12 - Ice salinity (namthd_sal) 15 !! 13 - Ice melt ponds (namthd_pnd) 16 !! 14 - Ice initialization (namini) 17 !! 15 - Ice/snow albedos (namalb) 18 !! 16 - Ice diagnostics (namdia) 19 !!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 20 ! 13 21 !------------------------------------------------------------------------------ 14 &nam icerun! Generic parameters22 &nampar ! Generic parameters 15 23 !------------------------------------------------------------------------------ 16 24 / 17 25 !------------------------------------------------------------------------------ 18 &nami cediag ! Diagnostics26 &namitd ! Ice discretization 19 27 !------------------------------------------------------------------------------ 20 28 / 21 29 !------------------------------------------------------------------------------ 22 &nam iceini ! Ice initialization30 &namdyn ! Ice dynamics 23 31 !------------------------------------------------------------------------------ 24 32 / 25 33 !------------------------------------------------------------------------------ 26 &nam iceitd ! Ice discretization34 &namdyn_rdgrft ! Ice ridging/rafting 27 35 !------------------------------------------------------------------------------ 28 36 / 29 37 !------------------------------------------------------------------------------ 30 &nam icedyn ! Ice dynamics and transport38 &namdyn_rhg ! Ice rheology 31 39 !------------------------------------------------------------------------------ 32 40 / 33 41 !------------------------------------------------------------------------------ 34 &nam icehdf ! Ice horizontal diffusion42 &namdyn_adv ! Ice advection 35 43 !------------------------------------------------------------------------------ 36 44 / 37 45 !------------------------------------------------------------------------------ 38 &nam icethd ! Ice thermodynamics46 &namforcing ! Ice surface forcing 39 47 !------------------------------------------------------------------------------ 40 48 / 41 49 !------------------------------------------------------------------------------ 42 &nam icesal ! Ice salinity50 &namthd ! Ice thermodynamics 43 51 !------------------------------------------------------------------------------ 44 52 / 45 53 !------------------------------------------------------------------------------ 46 &nam iceitdme ! Ice mechanical redistribution (ridging and rafting)54 &namthd_zdf ! Ice heat diffusion 47 55 !------------------------------------------------------------------------------ 48 56 / 57 !------------------------------------------------------------------------------ 58 &namthd_da ! Ice lateral melting 59 !------------------------------------------------------------------------------ 60 / 61 !------------------------------------------------------------------------------ 62 &namthd_do ! Ice growth in open water 63 !------------------------------------------------------------------------------ 64 / 65 !------------------------------------------------------------------------------ 66 &namthd_sal ! Ice salinity 67 !------------------------------------------------------------------------------ 68 / 69 !------------------------------------------------------------------------------ 70 &namthd_pnd ! Melt ponds 71 !------------------------------------------------------------------------------ 72 / 73 !------------------------------------------------------------------------------ 74 &namini ! Ice initialization 75 !------------------------------------------------------------------------------ 76 / 77 !------------------------------------------------------------------------------ 78 &namalb ! albedo parameters 79 !------------------------------------------------------------------------------ 80 / 81 !------------------------------------------------------------------------------ 82 &namdia ! Diagnostics 83 !------------------------------------------------------------------------------ 84 / -
branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/CONFIG/ORCA2_SAS_LIM3/EXP00/file_def_nemo.xml
r7635 r8879 21 21 --> 22 22 23 <file_definition type=" multiple_file" name="@expname@_@freq@_@startdate@_@enddate@" sync_freq="10d" min_digits="4">23 <file_definition type="one_file" name="@expname@_@freq@_@startdate@_@enddate@" sync_freq="10d" min_digits="4"> 24 24 25 <file_group id=" 1ts" output_freq="1ts" output_level="10" enabled=".TRUE."/> <!-- 1 time step files -->25 <file_group id="2ts" output_freq="2ts" output_level="10" enabled=".TRUE."/> <!-- 1 time step files --> 26 26 27 27 <file_group id="1h" output_freq="1h" output_level="10" enabled=".TRUE."/> <!-- 1h files --> … … 39 39 <file_group id="3d" output_freq="3d" output_level="10" enabled=".TRUE."/> <!-- 3d files --> 40 40 41 <file_group id=" 5d" output_freq="5d" output_level="10" enabled=".TRUE."> <!-- 5d files -->41 <file_group id="1ts" output_freq="1ts" output_level="10" enabled=".TRUE."> <!-- 5d files --> 42 42 43 43 <file id="file1" name_suffix="_grid_T" description="ocean T grid variables" > … … 110 110 111 111 <file id="file6" name_suffix="_icemod" description="ice variables" enabled=".true." > 112 <field field_ref="snowthic_cea" name="snthic" />113 <field field_ref="icethic_cea" name="sithic" />114 112 <field field_ref="icevolu" name="sivolu" /> 115 <field field_ref="snowvol" name="snvolu" />116 <field field_ref="iceconc" name="siconc" />117 118 <field field_ref="vfxbog" name="vfxbog" />119 <field field_ref="vfxdyn" name="vfxdyn" />120 <field field_ref="vfxopw" name="vfxopw" />121 <field field_ref="vfxsni" name="vfxsni" />122 <field field_ref="vfxsum" name="vfxsum" />123 <field field_ref="vfxbom" name="vfxbom" />124 <field field_ref="vfxres" name="vfxres" />125 <field field_ref="vfxice" name="vfxice" />126 <field field_ref="vfxsnw" name="vfxsnw" />127 <field field_ref="vfxsub" name="vfxsub" />128 <field field_ref="vfxspr" name="vfxspr" />129 130 <field field_ref="icetrp" name="sivtrp" />131 <field field_ref="snwtrp" name="snvtrp" />132 <field field_ref="saltrp" name="saltrp" />133 <field field_ref="deitrp" name="deitrp" />134 <field field_ref="destrp" name="destrp" />135 136 <field field_ref="sfxbri" name="sfxbri" />137 <field field_ref="sfxdyn" name="sfxdyn" />138 <field field_ref="sfxres" name="sfxres" />139 <field field_ref="sfxbog" name="sfxbog" />140 <field field_ref="sfxbom" name="sfxbom" />141 <field field_ref="sfxsum" name="sfxsum" />142 <field field_ref="sfxsni" name="sfxsni" />143 <field field_ref="sfxopw" name="sfxopw" />144 <field field_ref="sfx" name="sfx" />145 146 <field field_ref="hfxsum" name="hfxsum" />147 <field field_ref="hfxbom" name="hfxbom" />148 <field field_ref="hfxbog" name="hfxbog" />149 <field field_ref="hfxdif" name="hfxdif" />150 <field field_ref="hfxopw" name="hfxopw" />151 <field field_ref="hfxout" name="hfxout" />152 <field field_ref="hfxin" name="hfxin" />153 <field field_ref="hfxsnw" name="hfxsnw" />154 <field field_ref="hfxerr" name="hfxerr" />155 <field field_ref="hfxerr_rem" name="hfxerr_rem" />156 157 <!-- ice-ocean heat flux from mass exchange -->158 <field field_ref="hfxdyn" name="hfxdyn" />159 <field field_ref="hfxres" name="hfxres" />160 <field field_ref="hfxthd" name="hfxthd" />161 <!-- ice-atm. heat flux from mass exchange -->162 <field field_ref="hfxsub" name="hfxsub" />163 <field field_ref="hfxspr" name="hfxspr" />164 165 <!-- diags -->166 <field field_ref="hfxdhc" name="hfxdhc" />167 <field field_ref="hfxtur" name="hfxtur" />168 169 <field field_ref="isst" name="sst" />170 <field field_ref="isss" name="sss" />171 <field field_ref="micesalt" name="sisali" />172 <field field_ref="micet" name="sitemp" />173 <field field_ref="icest" name="sistem" />174 <field field_ref="icehc" name="siheco" />175 <field field_ref="isnowhc" name="snheco" />176 <field field_ref="miceage" name="siages" />177 178 <field field_ref="uice_ipa" name="sivelu" />179 <field field_ref="vice_ipa" name="sivelv" />180 <field field_ref="icevel" name="sivelo" />181 <field field_ref="idive" name="sidive" />182 <field field_ref="ishear" name="sishea" />183 <field field_ref="icestr" name="sistre" />184 185 <field field_ref="ibrinv" name="sibrin" />186 <field field_ref="icecolf" name="sicolf" />187 188 <field field_ref="iceage_cat" name="siagecat" />189 <field field_ref="iceconc_cat" name="siconcat" />190 <field field_ref="icethic_cat" name="sithicat" />191 <field field_ref="snowthic_cat" name="snthicat" />192 <field field_ref="salinity_cat" name="salincat" />193 <field field_ref="brinevol_cat" name="sibricat" />194 <field field_ref="icetemp_cat" name="sitemcat" />195 <field field_ref="snwtemp_cat" name="sntemcat" />196 113 197 114 </file> 198 199 <file id="file7" name_suffix="_scalar" description="scalar variables" enabled=".true." >200 <field field_ref="voltot" name="scvoltot" />201 <field field_ref="sshtot" name="scsshtot" />202 <field field_ref="sshsteric" name="scsshste" />203 <field field_ref="sshthster" name="scsshtst" />204 <field field_ref="masstot" name="scmastot" />205 <field field_ref="temptot" name="sctemtot" />206 <field field_ref="saltot" name="scsaltot" />207 208 <field field_ref="bgtemper" name="bgtemper" />209 <field field_ref="bgsaline" name="bgsaline" />210 <field field_ref="bgheatco" name="bgheatco" />211 <field field_ref="bgsaltco" name="bgsaltco" />212 <field field_ref="bgvolssh" name="bgvolssh" />213 <field field_ref="bgvole3t" name="bgvole3t" />214 <field field_ref="bgfrcvol" name="bgfrcvol" />215 <field field_ref="bgfrctem" name="bgfrctem" />216 <field field_ref="bgfrcsal" name="bgfrcsal" />217 218 <field field_ref="ibgvoltot" name="ibgvoltot" />219 <field field_ref="sbgvoltot" name="sbgvoltot" />220 <field field_ref="ibgarea" name="ibgarea" />221 <field field_ref="ibgsaline" name="ibgsaline" />222 <field field_ref="ibgtemper" name="ibgtemper" />223 <field field_ref="ibgheatco" name="ibgheatco" />224 <field field_ref="sbgheatco" name="sbgheatco" />225 <field field_ref="ibgsaltco" name="ibgsaltco" />226 227 <field field_ref="ibgvfx" name="ibgvfx" />228 <field field_ref="ibgvfxbog" name="ibgvfxbog" />229 <field field_ref="ibgvfxopw" name="ibgvfxopw" />230 <field field_ref="ibgvfxsni" name="ibgvfxsni" />231 <field field_ref="ibgvfxdyn" name="ibgvfxdyn" />232 <field field_ref="ibgvfxbom" name="ibgvfxbom" />233 <field field_ref="ibgvfxsum" name="ibgvfxsum" />234 <field field_ref="ibgvfxres" name="ibgvfxres" />235 <field field_ref="ibgvfxspr" name="ibgvfxspr" />236 <field field_ref="ibgvfxsnw" name="ibgvfxsnw" />237 <field field_ref="ibgvfxsub" name="ibgvfxsub" />238 239 <field field_ref="ibgsfx" name="ibgsfx" />240 <field field_ref="ibgsfxbri" name="ibgsfxbri" />241 <field field_ref="ibgsfxdyn" name="ibgsfxdyn" />242 <field field_ref="ibgsfxres" name="ibgsfxres" />243 <field field_ref="ibgsfxbog" name="ibgsfxbog" />244 <field field_ref="ibgsfxopw" name="ibgsfxopw" />245 <field field_ref="ibgsfxsni" name="ibgsfxsni" />246 <field field_ref="ibgsfxbom" name="ibgsfxbom" />247 <field field_ref="ibgsfxsum" name="ibgsfxsum" />248 249 <field field_ref="ibghfxdhc" name="ibghfxdhc" />250 <field field_ref="ibghfxspr" name="ibghfxspr" />251 252 <field field_ref="ibghfxres" name="ibghfxres" />253 <field field_ref="ibghfxsub" name="ibghfxsub" />254 <field field_ref="ibghfxdyn" name="ibghfxdyn" />255 <field field_ref="ibghfxthd" name="ibghfxthd" />256 <field field_ref="ibghfxsum" name="ibghfxsum" />257 <field field_ref="ibghfxbom" name="ibghfxbom" />258 <field field_ref="ibghfxbog" name="ibghfxbog" />259 <field field_ref="ibghfxdif" name="ibghfxdif" />260 <field field_ref="ibghfxopw" name="ibghfxopw" />261 <field field_ref="ibghfxout" name="ibghfxout" />262 <field field_ref="ibghfxin" name="ibghfxin" />263 <field field_ref="ibghfxsnw" name="ibghfxsnw" />264 265 <field field_ref="ibgfrcvol" name="ibgfrcvol" />266 <field field_ref="ibgfrcsfx" name="ibgfrcsfx" />267 <field field_ref="ibgvolgrm" name="ibgvolgrm" />268 269 </file>270 115 271 116 <!-- -
branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/CONFIG/ORCA2_SAS_LIM3/EXP00/namelist_cfg
r7404 r8879 19 19 / 20 20 !----------------------------------------------------------------------- 21 &namzgr ! vertical coordinate22 !-----------------------------------------------------------------------23 ln_zps = .true. ! z-coordinate - partial steps24 /25 !-----------------------------------------------------------------------26 21 &namdom ! space and time domain (bathymetry, mesh, timestep) 27 22 !----------------------------------------------------------------------- … … 81 76 &nambbc ! bottom temperature boundary condition (default: NO) 82 77 !----------------------------------------------------------------------- 83 ln_trabbc = .true. ! Apply a geothermal heating at the ocean bottom84 78 / 85 79 !----------------------------------------------------------------------- -
branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/CONFIG/ORCA2_SAS_LIM3/EXP00/namelist_ice_cfg
r7404 r8879 1 1 !!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 2 !! LIM3 configuration namelist: Overwrites SHARED/namelist_ice_lim3_ref 3 !! 1 - Generic parameters (namicerun) 4 !! 2 - Diagnostics (namicediag) 5 !! 3 - Ice initialization (namiceini) 6 !! 4 - Ice discretization (namiceitd) 7 !! 5 - Ice dynamics and transport (namicedyn) 8 !! 6 - Ice diffusion (namicehdf) 9 !! 7 - Ice thermodynamics (namicethd) 10 !! 8 - Ice salinity (namicesal) 11 !! 9 - Ice mechanical redistribution (namiceitdme) 12 !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 2 !! ESIM configuration namelist: Overwrites SHARED/namelist_ice_lim3_ref 3 !! 1 - Generic parameters (nampar) 4 !! 2 - Ice thickness discretization (namitd) 5 !! 3 - Ice dynamics (namdyn) 6 !! 4 - Ice ridging/rafting (namdyn_rdgrft) 7 !! 5 - Ice rheology (namdyn_rhg) 8 !! 6 - Ice advection (namdyn_adv) 9 !! 7 - Ice surface forcing (namforcing) 10 !! 8 - Ice thermodynamics (namthd) 11 !! 9 - Ice heat diffusion (namthd_zdf) 12 !! 10 - Ice lateral melting (namthd_da) 13 !! 11 - Ice growth in open water (namthd_do) 14 !! 12 - Ice salinity (namthd_sal) 15 !! 13 - Ice melt ponds (namthd_pnd) 16 !! 14 - Ice initialization (namini) 17 !! 15 - Ice/snow albedos (namalb) 18 !! 16 - Ice diagnostics (namdia) 19 !!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 20 ! 13 21 !------------------------------------------------------------------------------ 14 &nam icerun! Generic parameters22 &nampar ! Generic parameters 15 23 !------------------------------------------------------------------------------ 16 24 / 17 25 !------------------------------------------------------------------------------ 18 &nami cediag ! Diagnostics26 &namitd ! Ice discretization 19 27 !------------------------------------------------------------------------------ 20 28 / 21 29 !------------------------------------------------------------------------------ 22 &nam iceini ! Ice initialization30 &namdyn ! Ice dynamics 23 31 !------------------------------------------------------------------------------ 24 32 / 25 33 !------------------------------------------------------------------------------ 26 &nam iceitd ! Ice discretization34 &namdyn_rdgrft ! Ice ridging/rafting 27 35 !------------------------------------------------------------------------------ 28 36 / 29 37 !------------------------------------------------------------------------------ 30 &nam icedyn ! Ice dynamics and transport38 &namdyn_rhg ! Ice rheology 31 39 !------------------------------------------------------------------------------ 32 40 / 33 41 !------------------------------------------------------------------------------ 34 &nam icehdf ! Ice horizontal diffusion42 &namdyn_adv ! Ice advection 35 43 !------------------------------------------------------------------------------ 36 44 / 37 45 !------------------------------------------------------------------------------ 38 &nam icethd ! Ice thermodynamics46 &namforcing ! Ice surface forcing 39 47 !------------------------------------------------------------------------------ 40 48 / 41 49 !------------------------------------------------------------------------------ 42 &nam icesal ! Ice salinity50 &namthd ! Ice thermodynamics 43 51 !------------------------------------------------------------------------------ 44 52 / 45 53 !------------------------------------------------------------------------------ 46 &nam iceitdme ! Ice mechanical redistribution (ridging and rafting)54 &namthd_zdf ! Ice heat diffusion 47 55 !------------------------------------------------------------------------------ 48 56 / 57 !------------------------------------------------------------------------------ 58 &namthd_da ! Ice lateral melting 59 !------------------------------------------------------------------------------ 60 / 61 !------------------------------------------------------------------------------ 62 &namthd_do ! Ice growth in open water 63 !------------------------------------------------------------------------------ 64 / 65 !------------------------------------------------------------------------------ 66 &namthd_sal ! Ice salinity 67 !------------------------------------------------------------------------------ 68 / 69 !------------------------------------------------------------------------------ 70 &namthd_pnd ! Melt ponds 71 !------------------------------------------------------------------------------ 72 / 73 !------------------------------------------------------------------------------ 74 &namini ! Ice initialization 75 !------------------------------------------------------------------------------ 76 / 77 !------------------------------------------------------------------------------ 78 &namalb ! albedo parameters 79 !------------------------------------------------------------------------------ 80 / 81 !------------------------------------------------------------------------------ 82 &namdia ! Diagnostics 83 !------------------------------------------------------------------------------ 84 / -
branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/CONFIG/ORCA2_SAS_LIM3/cpp_ORCA2_SAS_LIM3.fcm
r7423 r8879 1 bld::tool::fppkeys key_ trabbl key_lim3 key_zdftke key_zdfddm key_zdftmxkey_iomput key_mpp_mpi1 bld::tool::fppkeys key_lim3 key_iomput key_mpp_mpi -
branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/CONFIG/SHARED/field_def_nemo-lim.xml
r7767 r8879 12 12 <field_group id="SBC" grid_ref="grid_T_2D" > <!-- time step automaticaly defined based on nn_fsbc --> 13 13 14 <!-- LIM2(only) fields --> 15 <field id="qsr_ai_cea" long_name="Air-Ice downward solar heat flux (cell average)" standard_name="surface_downwelling_shortwave_flux_in_air" unit="W/m2" /> 16 <field id="qns_ai_cea" long_name="Air-Ice downward non-solar heat flux (cell average)" unit="W/m2" /> 17 <field id="qla_ai_cea" long_name="Air-Ice downward Latent heat flux (cell average)" standard_name="surface_downward_latent_heat_flux" unit="W/m2" /> 18 <field id="qsr_io_cea" long_name="Ice-Oce downward solar heat flux (cell average)" standard_name="net_downward_shortwave_flux_at_sea_water_surface" unit="W/m2" /> 19 <field id="qns_io_cea" long_name="Ice-Oce downward non-solar heat flux (cell average)" unit="W/m2" /> 20 <field id="iceprod_cea" long_name="Ice production (cell average)" unit="m/s" /> 21 <field id="iiceconc" long_name="Ice concentration" standard_name="sea_ice_area_fraction" unit="1" /> 22 <field id="ice_pres" long_name="Ice presence" unit="" /> 23 <field id="ist_cea" long_name="Ice surface temperature (cell average)" standard_name="surface_temperature" unit="degC" /> 24 <field id="ist_ipa" long_name="Ice surface temperature (ice presence average)" standard_name="surface_temperature" unit="degC" /> 25 <field id="u_imasstr" long_name="Sea-ice mass transport along i-axis" standard_name="sea_ice_x_transport" unit="kg/s" /> 26 <field id="v_imasstr" long_name="Sea-ice mass transport along j-axis" standard_name="sea_ice_y_transport" unit="kg/s" /> 14 <!-- SIMIP LIM fields --> 15 <field id="icethick" long_name="Sea-ice thickness per area" standard_name="sea_ice_thickness" unit="m" /> 16 <field id="icethic" long_name="Sea-ice thickness" standard_name="sea_ice_thickness" unit="m" /> 17 <field id="uice_mv" long_name="X-component of sea ice velocity" standard_name="sea_ice_x_velocity" unit="m/s" /> 18 <field id="vice_mv" long_name="Y-component of sea ice velocity" standard_name="sea_ice_y_velocity" unit="m/s" /> 19 <field id="icevel_mv" long_name="Sea-ice speed" standard_name="sea_ice_speed" unit="m/s" /> 20 <field id="icepres" long_name="Fraction of time steps with sea ice" standard_name="sea_ice_time_fraction" unit="" /> 21 <field id="iceconc" long_name="Sea-ice area fraction" standard_name="sea_ice_area_fraction" unit="" /> 22 <field id="iceconc_pct" long_name="Sea-ice area fraction in percent" standard_name="sea_ice_area_fraction_in_percent" unit="%" > iceconc * 100. </field > 23 <field id="icemass" long_name="Sea-ice mass per area" standard_name="sea_ice_amount" unit="kg/m2" /> 24 <field id="icevolu" long_name="Sea-ice volume per area" standard_name="sea_ice_thickness" unit="m" /> 25 <field id="snomass" long_name="Snow mass per area" standard_name="liquid_water_content_of_surface_snow" unit="kg/m2" /> 26 <field id="snothic" long_name="Snow thickness" standard_name="surface_snow_thickness" unit="m" /> 27 28 <field id="iceconc_cat_mv" long_name="Sea-ice area fractions in thickness categories" standard_name="sea_ice_area_fraction_over_categories" unit="" grid_ref="grid_T_3D_ncatice" /> 29 <field id="iceconc_cat_pct_mv" long_name="Sea-ice area fractions in thickness categories" standard_name="sea_ice_area_fraction_over_categories" unit="%" grid_ref="grid_T_3D_ncatice" > iceconc_cat_mv * 100. </field > 30 <field id="icethic_cat_mv" long_name="Sea-ice thickness in thickness categories" standard_name="sea_ice_thickness_over_categories" unit="m" grid_ref="grid_T_3D_ncatice" /> 31 <field id="snowthic_cat_mv" long_name="Snow thickness in thickness categories" standard_name="snow_thickness_over_categories" unit="m" grid_ref="grid_T_3D_ncatice" /> 32 33 <field id="icestK" long_name="Surface temperature of sea ice" standard_name="sea_ice_surface_temperature" unit="K" /> 34 <field id="icesntK" long_name="Temperature at snow-ice interface" standard_name="sea_ice_snow_interface_temperature" unit="K" /> 35 <field id="icebotK" long_name="Temperature at ice-ocean interface" standard_name="sea_ice_bottom_temperature" unit="K" /> 36 37 <field id="iceage" long_name="Age of sea ice" standard_name="age_of_sea_ice" unit="s" /> 38 <field id="icealb" long_name="Sea-ice or snow albedo" standard_name="sea_ice_albedo" unit="" /> 39 <field id="icesmass" long_name="Mass of salt in sea ice per area" standard_name="sea_ice_salt_mass" unit="kg/m2" /> 40 <field id="icesal" long_name="Sea ice salinity" standard_name="sea_ice_salinity" unit="g/kg" /> 41 <field id="icefb" long_name="Sea-ice freeboard" standard_name="sea_ice_freeboard" unit="m" /> 42 43 <field id="icehcneg" long_name="Sea-ice heat content per unit area" standard_name="integral_of_sea_ice_temperature_wrt_depth_expressed_as_heat_content" unit="J/m2" > (-1.0)*icehc </field> 44 <field id="isnhcneg" long_name="Snow-heat content per unit area" standard_name="thermal_energy_content_of_surface_snow" unit="J/m2" > </field> 45 46 <field id="wfxsum" long_name="Freshwater flux from sea-ice surface" standard_name="freshwater_flux_from_ice_surface" unit="kg/m2/s" /> 47 48 <field id="afxthd" long_name="sea-ice area fraction change from thermodynamics" standard_name="tendency_of_sea_ice_area_fraction_due_to_dynamics" unit="s-1" /> 49 <field id="afxdyn" long_name="sea-ice area fraction change from dynamics" standard_name="tendency_of_sea_ice_area_fraction_due_to_dynamics" unit="s-1" /> 50 51 <field id="dmithd" long_name="sea-ice mass change from thermodynamics" standard_name="tendency_of_sea_ice_amount_due_to_thermodynamics" unit="kg/m2/s" /> 52 <field id="dmidyn" long_name="sea-ice mass change from dynamics" standard_name="tendency_of_sea_ice_amount_due_to_dynamics" unit="kg/m2/s" /> 53 <field id="dmiopw" long_name="sea-ice mass change through growth in supercooled open water (aka frazil)" standard_name="tendency_of_sea_ice_amount_due_to_freezing_in_open_water" unit="kg/m2/s" /> 54 <field id="dmibog" long_name="sea-ice mass change through basal growth" standard_name="tendency_of_sea_ice_amount_due_to_congelation_ice_accumulation" unit="kg/m2/s" /> 55 <field id="dmisni" long_name="sea-ice mass change through snow-to-ice conversion" standard_name="tendency_of_sea_ice_amount_due_to_snow_conversion" unit="kg/m2/s" /> 56 <field id="dmtsub" long_name="snow and sea ice mass change through sublimation" standard_name="tendency_of_snow_and_ice_amount_due_to_sublimation" unit="kg/m2/s" /> 57 <field id="dmssub" long_name="sea-ice mass change through evaporation and sublimation" standard_name="water_evaporation_flux" unit="kg/m2/s" /> 58 <field id="dmisub" long_name="snow mass change through evaporation or sublimation" standard_name="surface_snow_sublimation_flux" unit="kg/m2/s" /> 59 <field id="dmisum" long_name="sea-ice mass change through surface melting" standard_name="tendency_of_sea_ice_amount_due_to_surface_melting" unit="kg/m2/s" /> 60 <field id="dmibom" long_name="sea-ice mass change through bottom melting" standard_name="tendency_of_sea_ice_amount_due_to_basal_melting" unit="kg/m2/s" /> 61 62 <field id="dmsspr" long_name="snow mass change through snow fall" standard_name="snowfall_flux" unit="kg/m2/s" /> 63 <field id="dmsmel" long_name="snow mass change through melt" standard_name="surface_snow_melt_flux" unit="kg/m2/s" /> 64 <field id="dmsdyn" long_name="snow mass change through advection by sea-ice dynamics" standard_name="tendency_of_snow_mass_due_to_sea_ice_dynamics" unit="kg/m2/s" /> 65 <field id="dmsssi" long_name="snow mass change through snow-to-ice conversion" standard_name="tendency_of_snow_mass_due_to_snow_to_ice_conversion" unit="kg/m2/s" /> 66 67 <field id="hfxsenso" long_name="Net sensible heat flux under sea ice" standard_name="ice_ocean_heat_flux" unit="W/m2" /> 68 <field id="hfxconsu" long_name="Net conductive heat flux in ice at the surface" standard_name="conductive_heat_flux_at_sea_ice_surface" unit="W/m2" /> 69 <field id="hfxconbo" long_name="Net conductive heat fluxes in ice at the bottom" standard_name="conductive_heat_flux_at_sea_ice_bottom" unit="W/m2" /> 70 71 <field id="sfx_mv" long_name="Salt flux from sea ice" standard_name="salt_flux_from_ice" unit="kg/m2/s" /> 72 <field id="wfxtot" long_name="Freshwater flux from sea ice" standard_name="freshwater_flux_from_ice" unit="kg/m2/s" /> 73 74 <field id="utau_ice" long_name="X-component of atmospheric stress on sea ice" standard_name="surface_downward_x_stress" unit="N/m2" /> 75 <field id="vtau_ice" long_name="Y-component of atmospheric stress on sea ice" standard_name="surface_downward_y_stress" unit="N/m2" /> 76 77 <field id="utau_oi" long_name="X-component of ocean stress on sea ice" standard_name="sea_ice_base_upward_x_stress" unit="N/m2" /> 78 <field id="vtau_oi" long_name="Y-component of ocean stress on sea ice" standard_name="sea_ice_base_upward_y_stress" unit="N/m2" /> 79 80 <field id="icestr" long_name="Compressive sea ice strength" standard_name="compressive_strength_of_sea_ice" unit="N/m" /> 81 82 <field id="dssh_dx" long_name="Sea-surface tilt term in force balance (x-component)" standard_name="sea_surface_tilt_force_on_sea_ice_x" unit="N/m2" /> 83 <field id="dssh_dy" long_name="Sea-surface tilt term in force balance (y-component)" standard_name="sea_surface_tilt_force_on_sea_ice_y" unit="N/m2" /> 84 85 <field id="corstrx" long_name="Coriolis force term in force balance (x-component)" standard_name="coriolis_force_on_sea_ice_x" unit="N/m2" /> 86 <field id="corstry" long_name="Coriolis force term in force balance (y-component)" standard_name="coriolis_force_on_sea_ice_y" unit="N/m2" /> 87 88 <field id="intstrx" long_name="Internal stress term in force balance (x-component)" standard_name="internal_stress_in_sea_ice_x" unit="N/m2" /> 89 <field id="intstry" long_name="Internal stress term in force balance (y-component)" standard_name="internal_stress_in_sea_ice_y" unit="N/m2" /> 90 91 <field id="xmtrpice" long_name="X-component of ice mass transport" standard_name="ice_x_transport" unit="kg/s" /> 92 <field id="ymtrpice" long_name="Y-component of ice mass transport" standard_name="ice_y_transport" unit="kg/s" /> 93 94 <field id="xmtrpsnw" long_name="X-component of snw mass transport" standard_name="snw_x_transport" unit="kg/s" /> 95 <field id="ymtrpsnw" long_name="Y-component of snw mass transport" standard_name="snw_y_transport" unit="kg/s" /> 96 97 <field id="xatrp" long_name="X-component of ice area transport" standard_name="area_x_transport" unit="m2/s" /> 98 <field id="yatrp" long_name="Y-component of ice area transport" standard_name="area_y_transport" unit="m2/s" /> 99 100 <field id="xmtrptot" long_name="X-component of sea-ice mass transport" standard_name="sea_ice_x_transport" unit="kg/s" > xmtrpice + xmtrpsnw </field> 101 <field id="ymtrptot" long_name="Y-component of sea-ice mass transport" standard_name="sea_ice_y_transport" unit="kg/s" > ymtrpice + ymtrpsnw </field> 102 103 <field id="normstr" long_name="Average normal stress in sea ice" standard_name="average_normal_stress" unit="N/m" /> 104 <field id="sheastr" long_name="Maximum shear stress in sea ice" standard_name="maximum_shear_stress" unit="N/m" /> 105 106 <field id="idive" long_name="Divergence of the sea-ice velocity field" standard_name="divergence_of_sea_ice_velocity" unit="s-1" /> 107 <field id="ishear" long_name="Maximum shear of sea-ice velocity field" standard_name="maximum_shear_of_sea_ice_velocity" unit="s-1" /> 108 109 27 110 28 111 <!-- LIM3 fields --> 112 29 113 <field id="ice_cover" long_name="Ice fraction" standard_name="sea_ice_area_fraction" unit="1" /> 30 31 <field id="snowthic_cea" long_name="Snow thickness (cell average)" standard_name="surface_snow_thickness" unit="m" /> 32 <field id="icethic_cea" long_name="Ice thickness (cell average)" standard_name="sea_ice_thickness" unit="m" /> 33 34 <field id="uice_ipa" long_name="Ice velocity along i-axis at I-point (ice presence average)" standard_name="sea_ice_x_velocity" unit="m/s" /> 35 <field id="vice_ipa" long_name="Ice velocity along j-axis at I-point (ice presence average)" standard_name="sea_ice_y_velocity" unit="m/s" /> 36 <field id="utau_ice" long_name="Wind stress along i-axis over the ice at i-point" standard_name="surface_downward_x_stress" unit="N/m2" /> 37 <field id="vtau_ice" long_name="Wind stress along j-axis over the ice at i-point" standard_name="surface_downward_y_stress" unit="N/m2" /> 38 39 <field id="iceconc" long_name="ice concentration" standard_name="sea_ice_area_fraction" unit="%" /> 114 <field id="icepres" long_name="Ice presence" unit="" /> 115 116 <field id="uice_ipa" long_name="X-component of sea ice velocity" standard_name="sea_ice_x_velocity" unit="m/s" /> 117 <field id="vice_ipa" long_name="Y-component of sea ice velocity" standard_name="sea_ice_y_velocity" unit="m/s" /> 118 <field id="icevel" long_name="Sea-ice speed" standard_name="sea_ice_speed" unit="m/s" /> 40 119 <field id="isst" long_name="sea surface temperature" standard_name="sea_surface_temperature" unit="degC" /> 41 120 <field id="isss" long_name="sea surface salinity" standard_name="sea_surface_salinity" unit="1e-3" /> … … 48 127 <field id="qtr_ice" long_name="solar heat flux transmitted through ice: sum over categories" unit="W/m2" /> 49 128 <field id="qemp_ice" long_name="Downward Heat Flux from E-P over ice" unit="W/m2" /> 50 <field id="micesalt" long_name="Mean ice salinity" unit="1e-3" />51 <field id="miceage" long_name="Mean ice age" unit="years" />52 <field id="alb_ice" long_name="Mean albedo over sea ice" unit="" />53 129 <field id="albedo" long_name="Mean albedo over sea ice and ocean" unit="" /> 54 130 131 <field id="iceamp" long_name="melt pond fraction" standard_name="sea_ice_meltpond_fraction" unit="%" /> 132 <field id="icevmp" long_name="melt pond volume" standard_name="sea_ice_meltpond_volume" unit="m" /> 133 134 <field id="iceconc_cat" long_name="Sea-ice concentration in thickness categories" unit="" grid_ref="grid_T_3D_ncatice" /> 135 <field id="icethic_cat" long_name="Sea-ice thickness in thickness categories" unit="m" grid_ref="grid_T_3D_ncatice" /> 136 <field id="snowthic_cat" long_name="Snow thickness in thickness categories" unit="m" grid_ref="grid_T_3D_ncatice" /> 55 137 <field id="iceage_cat" long_name="Ice age for categories" unit="days" grid_ref="grid_T_3D_ncatice" /> 56 <field id="iceconc_cat" long_name="Ice concentration for categories" unit="%" grid_ref="grid_T_3D_ncatice" />57 <field id="icethic_cat" long_name="Ice thickness for categories" unit="m" grid_ref="grid_T_3D_ncatice" />58 <field id="snowthic_cat" long_name="Snow thicknessi for categories" unit="m" grid_ref="grid_T_3D_ncatice" />59 138 <field id="salinity_cat" long_name="Sea-Ice Bulk salinity for categories" unit="g/kg" grid_ref="grid_T_3D_ncatice" /> 60 139 <field id="brinevol_cat" long_name="Brine volume for categories" unit="%" grid_ref="grid_T_3D_ncatice" /> 61 140 <field id="icetemp_cat" long_name="Ice temperature for categories" unit="degC" grid_ref="grid_T_3D_ncatice" /> 62 141 <field id="snwtemp_cat" long_name="Snow temperature for categories" unit="degC" grid_ref="grid_T_3D_ncatice" /> 142 <field id="iceamp_cat" long_name="Ice melt pond concentration for categories" unit="%" grid_ref="grid_T_3D_ncatice" /> 143 <field id="icevmp_cat" long_name="Ice melt pond volume for categories" unit="m" grid_ref="grid_T_3D_ncatice" /> 144 <field id="icehmp_cat" long_name="Ice melt pond thickness for categories" unit="m" grid_ref="grid_T_3D_ncatice" /> 145 <field id="iceafp_cat" long_name="Ice melt pond fraction for categories" unit="m" grid_ref="grid_T_3D_ncatice" /> 63 146 64 147 <field id="micet" long_name="Mean ice temperature" unit="degC" /> 65 <field id="icehc" long_name="ice total heat content" unit="10^9J" /> 66 <field id="isnowhc" long_name="snow total heat content" unit="10^9J" /> 148 <field id="miceage" long_name="Age of sea ice" unit="s" /> 149 <field id="micesalt" long_name="Sea ice salinity" unit="g/kg" /> 150 <field id="icehc" long_name="ice total heat content" unit="J/m2" /> 151 <field id="isnowhc" long_name="snow total heat content" unit="J/m2" /> 67 152 <field id="icest" long_name="ice surface temperature" unit="degC" /> 68 153 <field id="ibrinv" long_name="brine volume" unit="%" /> 69 154 <field id="icecolf" long_name="frazil ice collection thickness" unit="m" /> 70 <field id="icestr" long_name="ice strength" unit="N/m" />71 <field id="icevel" long_name="ice velocity" unit="m/s" />72 <field id="idive" long_name="divergence" unit="1e-8s-1" />73 <field id="ishear" long_name="shear" unit="1e-8s-1" />74 <field id="icevolu" long_name="ice volume" unit="m" />75 155 <field id="snowvol" long_name="snow volume" unit="m" /> 76 156 <field id="tau_icebfr" long_name="ice friction on ocean bottom for landfast ice" unit="N/2" /> 77 157 78 <field id="icetrp" long_name="ice volume transport" unit="m/day" />79 <field id="snwtrp" long_name="snw volume transport" unit="m/day" />80 <field id="saltrp" long_name="salt content transport" unit="1e-3*kg/m2/day" />158 <field id="icetrp" long_name="ice mass transport" unit="kg/m2/s" /> 159 <field id="snwtrp" long_name="snw mass transport" unit="kg/m2/s" /> 160 <field id="saltrp" long_name="salt transport" unit="1e-3*kg/m2/s" /> 81 161 <field id="deitrp" long_name="advected ice enthalpy" unit="W/m2" /> 82 162 <field id="destrp" long_name="advected snw enthalpy" unit="W/m2" /> 83 163 84 <field id="sfxbri" long_name="brine salt flux" unit="1e-3*kg/m2/day" /> 85 <field id="sfxdyn" long_name="salt flux from ridging rafting" unit="1e-3*kg/m2/day" /> 86 <field id="sfxres" long_name="salt flux from lipupdate (resultant)" unit="1e-3*kg/m2/day" /> 87 <field id="sfxbog" long_name="salt flux from bot growth" unit="1e-3*kg/m2/day" /> 88 <field id="sfxbom" long_name="salt flux from bot melt" unit="1e-3*kg/m2/day" /> 89 <field id="sfxsum" long_name="salt flux from surf melt" unit="1e-3*kg/m2/day" /> 90 <field id="sfxlam" long_name="salt flux from lateral melt" unit="1e-3*kg/m2/day" /> 91 <field id="sfxsni" long_name="salt flux from snow-ice formation" unit="1e-3*kg/m2/day" /> 92 <field id="sfxopw" long_name="salt flux from open water ice formation" unit="1e-3*kg/m2/day" /> 93 <field id="sfxsub" long_name="salt flux from sublimation" unit="1e-3*kg/m2/day" /> 94 <field id="sfx" long_name="salt flux total" unit="1e-3*kg/m2/day" /> 95 96 <field id="vfxbog" long_name="daily bottom thermo ice prod." unit="m/day" /> 97 <field id="vfxdyn" long_name="daily dynamic ice prod." unit="m/day" /> 98 <field id="vfxopw" long_name="daily lateral thermo ice prod." unit="m/day" /> 99 <field id="vfxsni" long_name="daily snowice ice prod." unit="m/day" /> 100 <field id="vfxsum" long_name="surface melt" unit="m/day" /> 101 <field id="vfxlam" long_name="lateral melt" unit="m/day" /> 102 <field id="vfxbom" long_name="bottom melt" unit="m/day" /> 103 <field id="vfxres" long_name="daily resultant ice prod./melting from limupdate" unit="m/day" /> 104 <field id="vfxice" long_name="ice melt/growth" unit="m/day" /> 105 <field id="vfxsnw" long_name="snw melt/growth" unit="m/day" /> 106 <field id="vfxsub" long_name="snw sublimation" unit="m/day" /> 107 <field id="vfxsub_err" long_name="excess of snw sublimation sent to ocean" unit="m/day" /> 108 <field id="vfxspr" long_name="snw precipitation on ice" unit="m/day" /> 109 <field id="vfxthin" long_name="daily thermo ice prod. for thin ice(20cm) + open water" unit="m/day" /> 110 111 <field id="afxtot" long_name="area tendency (total)" unit="day-1" /> 112 <field id="afxdyn" long_name="area tendency (dynamics)" unit="day-1" /> 113 <field id="afxthd" long_name="area tendency (thermo)" unit="day-1" /> 164 <field id="sfxbri" long_name="salt flux from brines" unit="1e-3*kg/m2/s" /> 165 <field id="sfxdyn" long_name="salt flux from ridging rafting" unit="1e-3*kg/m2/s" /> 166 <field id="sfxres" long_name="salt flux from lipupdate (resultant)" unit="1e-3*kg/m2/s" /> 167 <field id="sfxbog" long_name="salt flux from bot growth" unit="1e-3*kg/m2/s" /> 168 <field id="sfxbom" long_name="salt flux from bot melt" unit="1e-3*kg/m2/s" /> 169 <field id="sfxsum" long_name="salt flux from surf melt" unit="1e-3*kg/m2/s" /> 170 <field id="sfxlam" long_name="salt flux from lateral melt" unit="1e-3*kg/m2/s" /> 171 <field id="sfxsni" long_name="salt flux from snow-ice formation" unit="1e-3*kg/m2/s" /> 172 <field id="sfxopw" long_name="salt flux from open water ice formation" unit="1e-3*kg/m2/s" /> 173 <field id="sfxsub" long_name="salt flux from sublimation" unit="1e-3*kg/m2/s" /> 174 <field id="sfx" long_name="Salt flux from sea ice" unit="1e-3*kg/m2/s" /> 175 176 <field id="vfxbog" long_name="bottom thermo ice prod." unit="kg/m2/s" /> 177 <field id="vfxdyn" long_name="dynamic ice prod." unit="kg/m2/s" /> 178 <field id="vfxopw" long_name="lateral thermo ice prod." unit="kg/m2/s" /> 179 <field id="vfxsni" long_name="snowice ice prod." unit="kg/m2/s" /> 180 <field id="vfxsum" long_name="surface melt" unit="kg/m2/s" /> 181 <field id="vfxlam" long_name="lateral melt" unit="kg/m2/s" /> 182 <field id="vfxbom" long_name="bottom melt" unit="kg/m2/s" /> 183 <field id="vfxres" long_name="resultant ice prod./melting" unit="kg/m2/s" /> 184 <field id="vfxice" long_name="ice melt/growth" unit="kg/m2/s" /> 185 <field id="vfxsnw" long_name="snw melt/growth" unit="kg/m2/s" /> 186 <field id="vfxsub" long_name="snw sublimation" unit="kg/m2/s" /> 187 <field id="vfxsub_err" long_name="excess of snw sublimation sent to ocean" unit="kg/m2/s" /> 188 <field id="vfxspr" long_name="snw precipitation on ice" unit="kg/m2/s" /> 189 <field id="vfxthin" long_name="thermo ice prod. for thin ice(20cm) + open water" unit="kg/m2/s" /> 190 <field id="vfxpnd" long_name="melt pond water flux to ocean" unit="kg/m2/s" /> 191 192 <field id="afxtot" long_name="area tendency (total)" unit="s-1" /> 114 193 115 194 <field id="hfxsum" long_name="heat fluxes causing surface ice melt" unit="W/m2" /> … … 135 214 <field id="hfxtur" long_name="turbulent heat flux at the ice base" unit="W/m2" /> 136 215 137 <!-- sbcssm variables -->216 <!-- sbcssm variables --> 138 217 <field id="sst_m" unit="degC" /> 139 218 <field id="sss_m" unit="psu" /> … … 144 223 <field id="frq_m" unit="-" /> 145 224 225 <!-- specific for rheology --> 226 <field id="isig1" long_name="1st principal stress component for EVP rhg" unit="unitless" /> 227 <field id="isig2" long_name="2nd principal stress component for EVP rhg" unit="unitless" /> 228 <field id="isig3" long_name="convergence measure for EVP rheology (must be =1)" unit="unitless" /> 229 146 230 </field_group> 147 231 … … 149 233 <field_group id="SBC_scalar" grid_ref="grid_T_2D" > 150 234 <!-- available with ln_limdiaout --> 151 <field id="ibgfrcvoltop" long_name="global mean ice/snow forcing at interface ice/snow-atm (volume equivalent ocean volume)" unit="km3" />152 <field id="ibgfrcvolbot" long_name="global mean ice/snow forcing at interface ice/snow-ocean (volume equivalent ocean volume)" unit="km3" />153 <field id="ibgfrctemtop" long_name="global mean heat on top of ice/snw/ocean-atm " unit="1e20J" />154 <field id="ibgfrctembot" long_name="global mean heat below ice (on top of ocean) " unit="1e20J" />155 <field id="ibgfrcsal" long_name="global mean ice/snow forcing (salt equivalent ocean volume)" unit="pss*km3" />156 <field id="ibgfrchfxtop" long_name="global mean heat flux on top of ice/snw/ocean-atm " unit="W/m2" />157 <field id="ibgfrchfxbot" long_name="global mean heat flux below ice (on top of ocean) " unit="W/m2" />235 <field id="ibgfrcvoltop" long_name="global mean ice/snow forcing at interface ice/snow-atm (volume equivalent ocean volume)" unit="km3" /> 236 <field id="ibgfrcvolbot" long_name="global mean ice/snow forcing at interface ice/snow-ocean (volume equivalent ocean volume)" unit="km3" /> 237 <field id="ibgfrctemtop" long_name="global mean heat on top of ice/snw/ocean-atm " unit="1e20J" /> 238 <field id="ibgfrctembot" long_name="global mean heat below ice (on top of ocean) " unit="1e20J" /> 239 <field id="ibgfrcsal" long_name="global mean ice/snow forcing (salt equivalent ocean volume)" unit="pss*km3" /> 240 <field id="ibgfrchfxtop" long_name="global mean heat flux on top of ice/snw/ocean-atm " unit="W/m2" /> 241 <field id="ibgfrchfxbot" long_name="global mean heat flux below ice (on top of ocean) " unit="W/m2" /> 158 242 159 <field id="ibgvolume" long_name="drift in ice/snow volume (equivalent ocean volume)" unit="km3" /> 160 <field id="ibgsaltco" long_name="drift in ice salt content (equivalent ocean volume)" unit="pss*km3" /> 161 <field id="ibgheatco" long_name="drift in ice/snow heat content" unit="1e20J" /> 162 <field id="ibgheatfx" long_name="drift in ice/snow heat flux" unit="W/m2" /> 163 164 <field id="ibgvol_tot" long_name="global mean ice volume" unit="km3" /> 165 <field id="sbgvol_tot" long_name="global mean snow volume" unit="km3" /> 166 <field id="ibgarea_tot" long_name="global mean ice area" unit="km2" /> 167 <field id="ibgsalt_tot" long_name="global mean ice salt content" unit="1e-3*km3" /> 168 <field id="ibgheat_tot" long_name="global mean ice heat content" unit="1e20J" /> 169 <field id="sbgheat_tot" long_name="global mean snow heat content" unit="1e20J" /> 243 <field id="ibgvolume" long_name="drift in ice/snow volume (equivalent ocean volume)" unit="km3" /> 244 <field id="ibgsaltco" long_name="drift in ice salt content (equivalent ocean volume)" unit="pss*km3" /> 245 <field id="ibgheatco" long_name="drift in ice/snow heat content" unit="1e20J" /> 246 <field id="ibgheatfx" long_name="drift in ice/snow heat flux" unit="W/m2" /> 247 248 <field id="ibgvol_tot" long_name="global mean ice volume" unit="km3" /> 249 <field id="sbgvol_tot" long_name="global mean snow volume" unit="km3" /> 250 <field id="ibgarea_tot" long_name="global mean ice area" unit="km2" /> 251 <field id="ibgsalt_tot" long_name="global mean ice salt content" unit="1e-3*km3" /> 252 <field id="ibgheat_tot" long_name="global mean ice heat content" unit="1e20J" /> 253 <field id="sbgheat_tot" long_name="global mean snow heat content" unit="1e20J" /> 254 255 <field id="NH_iceextt" long_name="Sea ice extent North" standard_name="sea_ice_extent_n" unit="1e6_km2" /> 256 <field id="SH_iceextt" long_name="Sea ice extent South" standard_name="sea_ice_extent_s" unit="1e6_km2" /> 257 <field id="NH_icevolu" long_name="Sea ice volume North" standard_name="sea_ice_volume_n" unit="1e3_km3" /> 258 <field id="SH_icevolu" long_name="Sea ice volume South" standard_name="sea_ice_volume_s" unit="1e3_km3" /> 259 <field id="NH_icearea" long_name="Sea ice area North" standard_name="sea_ice_area_n" unit="1e6_km2" /> 260 <field id="SH_icearea" long_name="Sea ice area South" standard_name="sea_ice_area_s" unit="1e6_km2" /> 261 262 <field id="strait_mifl" long_name="Sea ice mass flux through straits" standard_name="sea_ice_mass_transport_across_line" unit="kg/s" grid_ref="grid_4strait" /> 263 <field id="strait_arfl" long_name="Sea ice area flux through straits" standard_name="sea_ice_area_transport_across_line" unit="m2/s" grid_ref="grid_4strait" /> 264 <field id="strait_msfl" long_name="Sea ice snow flux through straits" standard_name="snow_mass_transport_across_line" unit="kg/s" grid_ref="grid_4strait" /> 265 170 266 </field_group> 171 267 … … 176 272 177 273 <field_group id="myvarICE" > 178 <field field_ref="icethic _cea"name="sithic" long_name="sea_ice_thickness" />274 <field field_ref="icethick" name="sithic" long_name="sea_ice_thickness" /> 179 275 <field field_ref="icevolu" name="sivolu" /> 180 276 <field field_ref="iceconc" name="siconc" /> 181 277 </field_group> 182 278 279 <field_group id="ICE_globalbudget"> 280 281 <field field_ref="ibgvol_tot" grid_ref="grid_1point" name="ibgvol_tot" /> 282 <field field_ref="sbgvol_tot" grid_ref="grid_1point" name="sbgvol_tot" /> 283 <field field_ref="ibgarea_tot" grid_ref="grid_1point" name="ibgarea_tot" /> 284 <field field_ref="ibgsalt_tot" grid_ref="grid_1point" name="ibgsalt_tot" /> 285 <field field_ref="ibgheat_tot" grid_ref="grid_1point" name="ibgheat_tot" /> 286 <field field_ref="sbgheat_tot" grid_ref="grid_1point" name="sbgheat_tot" /> 287 288 <field field_ref="ibgvolume" grid_ref="grid_1point" name="ibgvolume" /> 289 <field field_ref="ibgsaltco" grid_ref="grid_1point" name="ibgsaltco" /> 290 <field field_ref="ibgheatco" grid_ref="grid_1point" name="ibgheatco" /> 291 <field field_ref="ibgheatfx" grid_ref="grid_1point" name="ibgheatfx" /> 292 293 <field field_ref="ibgfrcvoltop" grid_ref="grid_1point" name="ibgfrcvoltop" /> 294 <field field_ref="ibgfrcvolbot" grid_ref="grid_1point" name="ibgfrcvolbot" /> 295 <field field_ref="ibgfrctemtop" grid_ref="grid_1point" name="ibgfrctemtop" /> 296 <field field_ref="ibgfrctembot" grid_ref="grid_1point" name="ibgfrctembot" /> 297 <field field_ref="ibgfrcsal" grid_ref="grid_1point" name="ibgfrcsal" /> 298 <field field_ref="ibgfrchfxtop" grid_ref="grid_1point" name="ibgfrchfxtop" /> 299 <field field_ref="ibgfrchfxbot" grid_ref="grid_1point" name="ibgfrchfxbot" /> 300 301 </field_group> 302 303 304 <!--============================--> 305 <!-- SIMIP sea ice field groups --> 306 <!-- Notz et al 2016 --> 307 <!--============================--> 308 309 <!-- SIMIP monthly scalar variables --> 310 <field_group id="SImon_scalars"> 311 <!-- Integrated quantities --> 312 <field field_ref="NH_iceextt" grid_ref="grid_1point" name="siextentn" /> 313 <field field_ref="SH_iceextt" grid_ref="grid_1point" name="siextents" /> 314 <field field_ref="NH_icevolu" grid_ref="grid_1point" name="sivoln" /> 315 <field field_ref="SH_icevolu" grid_ref="grid_1point" name="sivols" /> 316 <field field_ref="NH_icearea" grid_ref="grid_1point" name="siarean" /> 317 <field field_ref="SH_icearea" grid_ref="grid_1point" name="siareas" /> 318 </field_group> 319 320 <!-- SIMIP daily fields --> <field_group id="SIday_fields"> 321 <field field_ref="icepres" name="sitimefrac" /> 322 <field field_ref="iceconc_pct" name="siconc" /> 323 <field field_ref="icethic" name="sithick" default_value="1.0e20" detect_missing_value="true" operation="average" /> 324 <field field_ref="snothic" name="sisnthick" default_value="1.0e20" detect_missing_value="true" operation="average" /> 325 <field field_ref="icestK" name="sitemptop" default_value="1.0e20" detect_missing_value="true" operation="average" /> 326 <field field_ref="uice_mv" name="siu" default_value="1.0e20" detect_missing_value="true" operation="average" /> 327 <field field_ref="vice_mv" name="siv" default_value="1.0e20" detect_missing_value="true" operation="average" /> 328 <field field_ref="icevel_mv" name="sispeed" default_value="1.0e20" detect_missing_value="true" operation="average" /> 329 </field_group> 330 331 <!-- SIMIP monthly fields --> 332 <field_group id="SImon_fields"> 333 <!-- Sea-ice state variables --> 334 <field field_ref="icepres" name="sitimefrac" /> 335 <field field_ref="iceconc_pct" name="siconc" /> 336 <field field_ref="icemass" name="simass" /> 337 <field field_ref="icethic" name="sithick" default_value="1.0e20" detect_missing_value="true" operation="average" /> 338 <field field_ref="icevolu" name="sivol" /> 339 <field field_ref="snomass" name="sisnmass" default_value="1.0e20" detect_missing_value="true" operation="average" /> 340 <field field_ref="snothic" name="sisnthick" default_value="1.0e20" detect_missing_value="true" operation="average" /> 341 342 <!-- category-dependent fields --> 343 <field field_ref="iceconc_cat_pct_mv" name="siitdconc" default_value="1.0e20" detect_missing_value="true" operation="average" /> 344 <field field_ref="icethic_cat_mv" name="siitdthick" default_value="1.0e20" detect_missing_value="true" operation="average" /> 345 <field field_ref="snowthic_cat_mv" name="siitdsnthick" default_value="1.0e20" detect_missing_value="true" operation="average"/> 346 347 <!-- additional state variables--> 348 <field field_ref="icestK" name="sitemptop" default_value="1.0e20" detect_missing_value="true" operation="average" /> 349 <field field_ref="icesntK" name="sitempsnic" default_value="1.0e20" detect_missing_value="true" operation="average" /> 350 <field field_ref="icebotK" name="sitempbot" default_value="1.0e20" detect_missing_value="true" operation="average" /> 351 <field field_ref="iceage" name="siage" default_value="1.0e20" detect_missing_value="true" operation="average" /> 352 <field field_ref="icesmass" name="sisaltmass" /> 353 <field field_ref="icesal" name="sisali" default_value="1.0e20" detect_missing_value="true" operation="average" /> 354 <field field_ref="icefb" name="sifb" default_value="1.0e20" detect_missing_value="true" operation="average" /> 355 <field field_ref="icehcneg" name="sihc" /> 356 <field field_ref="isnhcneg" name="sisnhc" default_value="1.0e20" detect_missing_value="true" operation="average" /> 357 358 <!-- freshwater fluxes --> 359 <field field_ref="wfxtot" name="siflfwbot" default_value="1.0e20" detect_missing_value="true" operation="average" /> 360 <field field_ref="wfxsum" name="siflfwdrain" default_value="1.0e20" detect_missing_value="true" operation="average" /> 361 362 <!-- area balance --> 363 <field field_ref="afxthd" name="sidconcth" /> 364 <field field_ref="afxdyn" name="sidconcdyn" /> 365 366 <!-- mass balance --> 367 <field field_ref="dmithd" name="sidmassth" /> 368 <field field_ref="dmidyn" name="sidmassdyn" /> 369 <field field_ref="dmiopw" name="sidmassgrowthwat" /> 370 <field field_ref="dmibog" name="sidmassgrowthbot" /> 371 <field field_ref="dmisni" name="sidmasssi" /> 372 <field field_ref="dmisub" name="sidmassevapsubl" /> 373 <field field_ref="dmisum" name="sidmassmelttop" /> 374 <field field_ref="dmibom" name="sidmassmeltbot" /> 375 <field field_ref="dmsspr" name="sndmasssnf" /> 376 <field field_ref="dmsmel" name="sndmassmelt" /> 377 <field field_ref="dmssub" name="sndmasssubl" /> 378 <field field_ref="dmsdyn" name="sndmassdyn" /> 379 <field field_ref="dmsssi" name="sndmasssi" /> 380 381 <!-- heat balance --> 382 <field field_ref="hfxsenso" name="siflsensupbot" default_value="1.0e20" detect_missing_value="true" operation="average" /> 383 <field field_ref="hfxconsu" name="siflcondtop" default_value="1.0e20" detect_missing_value="true" operation="average" /> 384 <field field_ref="hfxconbo" name="siflcondbot" default_value="1.0e20" detect_missing_value="true" operation="average" /> 385 386 <!-- salt balance --> 387 <field field_ref="sfx_mv" name="siflsaltbot" default_value="1.0e20" detect_missing_value="true" operation="average" /> 388 389 <!-- sea-ice dynamics --> 390 <field field_ref="uice_mv" name="siu" default_value="1.0e20" detect_missing_value="true" operation="average" /> 391 <field field_ref="vice_mv" name="siv" default_value="1.0e20" detect_missing_value="true" operation="average" /> 392 <field field_ref="icevel_mv" name="sispeed" default_value="1.0e20" detect_missing_value="true" operation="average" /> 393 394 <field field_ref="utau_ice" name="sistrxdtop" default_value="1.0e20" detect_missing_value="true" operation="average" /> 395 <field field_ref="vtau_ice" name="sistrydtop" default_value="1.0e20" detect_missing_value="true" operation="average" /> 396 397 <field field_ref="utau_oi" name="sistrxubot" default_value="1.0e20" detect_missing_value="true" operation="average" /> 398 <field field_ref="vtau_oi" name="sistryubot" default_value="1.0e20" detect_missing_value="true" operation="average" /> 399 400 <field field_ref="icestr" name="sicompstren" default_value="1.0e20" detect_missing_value="true" operation="average" /> 401 402 <field field_ref="dssh_dx" name="siforcetiltx" default_value="1.0e20" detect_missing_value="true" operation="average" /> 403 <field field_ref="dssh_dy" name="siforcetilty" default_value="1.0e20" detect_missing_value="true" operation="average" /> 404 405 <field field_ref="corstrx" name="siforcecoriolx" default_value="1.0e20" detect_missing_value="true" operation="average" /> 406 <field field_ref="corstry" name="siforcecorioly" default_value="1.0e20" detect_missing_value="true" operation="average" /> 407 408 <field field_ref="intstrx" name="siforceintstrx" default_value="1.0e20" detect_missing_value="true" operation="average" /> 409 <field field_ref="intstry" name="siforceintstry" default_value="1.0e20" detect_missing_value="true" operation="average" /> 410 411 <field field_ref="xmtrptot" name="sidmasstranx" /> 412 <field field_ref="ymtrptot" name="sidmasstrany" /> 413 414 <field field_ref="normstr" name="sistresave" default_value="1.0e20" detect_missing_value="true" operation="instant" /> 415 <field field_ref="sheastr" name="sistremax" default_value="1.0e20" detect_missing_value="true" operation="instant" /> 416 417 <field field_ref="idive" name="sidivvel" default_value="1.0e20" detect_missing_value="true" operation="instant" /> 418 <field field_ref="ishear" name="sishevel" default_value="1.0e20" detect_missing_value="true" operation="instant" /> 419 420 <!-- sea ice fluxes across straits: 2D arrays to be post-processed --> 421 <field field_ref="xmtrpice" name="simassacrossline_x" /> 422 <field field_ref="ymtrpice" name="simassacrossline_y" /> 423 <field field_ref="xmtrpsnw" name="snmassacrossline_x" /> 424 <field field_ref="ymtrpsnw" name="snmassacrossline_y" /> 425 <field field_ref="xatrp" name="siareaacrossline_x" /> 426 <field field_ref="yatrp" name="siareaacrossline_y" /> 427 428 </field_group> 429 183 430 </field_definition> -
branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/CONFIG/SHARED/namelist_ice_lim3_ref
r7813 r8879 1 1 !!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 2 !! LIM3 namelist: 3 !! 1 - Generic parameters (namicerun) 4 !! 2 - Diagnostics (namicediag) 5 !! 3 - Ice initialization (namiceini) 6 !! 4 - Ice discretization (namiceitd) 7 !! 5 - Ice dynamics and transport (namicedyn) 8 !! 6 - Ice diffusion (namicehdf) 9 !! 7 - Ice thermodynamics (namicethd) 10 !! 8 - Ice salinity (namicesal) 11 !! 9 - Ice mechanical redistribution (namiceitdme) 2 !! ESIM namelist: 3 !! 1 - Generic parameters (nampar) 4 !! 2 - Ice thickness discretization (namitd) 5 !! 3 - Ice dynamics (namdyn) 6 !! 4 - Ice ridging/rafting (namdyn_rdgrft) 7 !! 5 - Ice rheology (namdyn_rhg) 8 !! 6 - Ice advection (namdyn_adv) 9 !! 7 - Ice surface forcing (namforcing) 10 !! 8 - Ice thermodynamics (namthd) 11 !! 9 - Ice heat diffusion (namthd_zdf) 12 !! 10 - Ice lateral melting (namthd_da) 13 !! 11 - Ice growth in open water (namthd_do) 14 !! 12 - Ice salinity (namthd_sal) 15 !! 13 - Ice melt ponds (namthd_pnd) 16 !! 14 - Ice initialization (namini) 17 !! 15 - Ice/snow albedos (namalb) 18 !! 16 - Ice diagnostics (namdia) 12 19 !!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 13 20 ! 14 21 !------------------------------------------------------------------------------ 15 &namicerun ! Generic parameters 16 !------------------------------------------------------------------------------ 17 jpl = 5 ! number of ice categories 18 nlay_i = 2 ! number of ice layers 19 nlay_s = 1 ! number of snow layers (only 1 is working) 20 rn_amax_n = 0.997 ! maximum tolerated ice concentration NH 21 rn_amax_s = 0.997 ! maximum tolerated ice concentration SH 22 cn_icerst_in = "restart_ice" ! suffix of ice restart name (input) 23 cn_icerst_out = "restart_ice" ! suffix of ice restart name (output) 24 cn_icerst_indir = "." ! directory to read input ice restarts 25 cn_icerst_outdir = "." ! directory to write output ice restarts 26 ln_limthd = .true. ! ice thermo (T) or not (F) => DO NOT TOUCH UNLESS U KNOW WHAT U DO 27 ln_limdyn = .true. ! ice dynamics (T) or not (F) => DO NOT TOUCH UNLESS U KNOW WHAT U DO 28 nn_limdyn = 2 ! (ln_limdyn=T) switch for ice dynamics 29 ! 2: total 30 ! 1: advection only (no diffusion, no ridging/rafting) 31 ! 0: advection only (as 1 but with prescribed velocity, bypass rheology) 32 rn_uice = 0.00001 ! (nn_limdyn=0) ice u-velocity 33 rn_vice = -0.00001 ! (nn_limdyn=0) ice v-velocity 34 / 35 !------------------------------------------------------------------------------ 36 &namicediag ! Diagnostics 37 !------------------------------------------------------------------------------ 38 ln_limdiachk = .false. ! check online the heat, mass & salt budgets (T) or not (F) 39 ln_limdiahsb = .false. ! output the heat, mass & salt budgets (T) or not (F) 40 ln_limctl = .false. ! ice points output for debug (T or F) 41 iiceprt = 10 ! i-index for debug 42 jiceprt = 10 ! j-index for debug 43 / 44 !------------------------------------------------------------------------------ 45 &namiceini ! Ice initialization 46 !------------------------------------------------------------------------------ 47 ! -- limistate -- ! 48 ln_limini = .true. ! activate ice initialization (T) or not (F) 49 ln_limini_file = .false. ! netcdf file provided for initialization (T) or not (F) 50 rn_thres_sst = 2.0 ! maximum water temperature with initial ice (degC) 51 rn_hts_ini_n = 0.3 ! initial real snow thickness (m), North 52 rn_hts_ini_s = 0.3 ! " " South 53 rn_hti_ini_n = 3.0 ! initial real ice thickness (m), North 54 rn_hti_ini_s = 1.0 ! " " South 55 rn_ati_ini_n = 0.9 ! initial ice concentration (-), North 56 rn_ati_ini_s = 0.9 ! " " South 57 rn_smi_ini_n = 6.3 ! initial ice salinity (g/kg), North 58 rn_smi_ini_s = 6.3 ! " " South 59 rn_tmi_ini_n = 270. ! initial ice/snw temperature (K), North 60 rn_tmi_ini_s = 270. ! " " South 61 / 62 !------------------------------------------------------------------------------ 63 &namiceitd ! Ice discretization 64 !------------------------------------------------------------------------------ 65 nn_catbnd = 2 ! computation of ice category boundaries based on 66 ! 1: tanh function 67 ! 2: h^(-alpha), function of rn_himean 68 rn_himean = 2.0 ! expected domain-average ice thickness (m), nn_catbnd = 2 only 69 / 70 !------------------------------------------------------------------------------ 71 &namicedyn ! Ice dynamics and transport 72 !------------------------------------------------------------------------------ 73 ! -- limtrp & limadv -- ! 74 nn_limadv = 0 ! choose the advection scheme (-1=Prather ; 0=Ultimate-Macho) 75 nn_limadv_ord = 5 ! choose the order of the advection scheme (if nn_limadv=0) 76 ! -- limitd_me -- ! 77 nn_icestr = 0 ! ice strength parameteriztaion 78 ! 0: Hibler_79 P = pstar*<h>*exp(-c_rhg*A) 79 ! 1: Rothrock_75 P = Cf*coeff*integral(wr.h^2) 80 rn_pe_rdg = 17.0 ! (nn_icestr=1) ridging work divided by pot. energy change in ridging 81 rn_pstar = 2.0e+04 ! (nn_icestr=0) ice strength thickness parameter (N/m2) 82 rn_crhg = 20.0 ! (nn_icestr=0) ice strength conc. parameter (-) 83 ln_icestr_bvf = .false. ! ice strength function brine volume (T) or not (F) 84 ! 85 ! -- limdyn & limrhg -- ! 86 rn_cio = 5.0e-03 ! ice-ocean drag coefficient (-) 87 rn_creepl = 1.0e-12 ! creep limit (s-1) 88 rn_ecc = 2.0 ! eccentricity of the elliptical yield curve 89 nn_nevp = 120 ! number of EVP subcycles 90 rn_relast = 0.333 ! ratio of elastic timescale to ice time step: Telast = dt_ice * rn_relast 91 ! advised value: 1/3 (rn_nevp=120) or 1/9 (rn_nevp=300) 92 ln_landfast = .false. ! landfast ice parameterization (T or F) 93 rn_gamma = 0.15 ! (ln_landfast=T) fraction of ocean depth that ice must reach to initiate landfast 94 ! recommended range: [0.1 ; 0.25] 95 rn_icebfr = 10. ! (ln_landfast=T) maximum bottom stress per unit area of contact (N/m2) 96 ! a very large value ensures ice velocity=0 even with a small contact area 97 ! recommended range: ?? (should be greater than atm-ice stress => >0.1 N/m2) 98 rn_lfrelax = 1.e-5 ! (ln_landfast=T) relaxation time scale to reach static friction (s-1) 99 / 100 !------------------------------------------------------------------------------ 101 &namicehdf ! Ice horizontal diffusion 102 !------------------------------------------------------------------------------ 103 ! -- limhdf -- ! 104 nn_ahi0 = -1 ! horizontal diffusivity computation 105 ! -1: no diffusion (bypass limhdf) 106 ! 0: use rn_ahi0_ref 107 ! 1: use rn_ahi0_ref x mean grid cell length / ( 2deg mean grid cell length ) 108 ! 2: use rn_ahi0_ref x grid cell length / ( 2deg mean grid cell length ) 109 rn_ahi0_ref = 350.0 ! horizontal sea ice diffusivity (m2/s) 110 ! if nn_ahi0 > 0, rn_ahi0_ref is the reference value at a nominal 2 deg resolution 111 / 112 !------------------------------------------------------------------------------ 113 &namicethd ! Ice thermodynamics 114 !------------------------------------------------------------------------------ 115 ! -- limthd_dif -- ! 116 rn_kappa_i = 1.0 ! radiation attenuation coefficient in sea ice (m-1) 117 nn_conv_dif = 50 ! maximal number of iterations for heat diffusion computation 118 rn_terr_dif = 1.0e-04 ! maximum temperature after heat diffusion (degC) 119 nn_ice_thcon = 1 ! sea ice thermal conductivity 120 ! 0: k = k0 + beta.S/T (Untersteiner, 1964) 121 ! 1: k = k0 + beta1.S/T - beta2.T (Pringle et al., 2007) 122 ln_it_qnsice = .true. ! iterate the surface non-solar flux with surface temperature (T) or not (F) 123 nn_monocat = 0 ! virtual ITD mono-category parameterizations (1, jpl = 1 only) or not (0) 124 ! 2: simple piling instead of ridging --- temporary option 125 ! 3: activate G(he) only --- temporary option 126 ! 4: activate extra lateral melting only --- temporary option 127 rn_cdsn = 0.31 ! thermal conductivity of the snow (0.31 W/m/K, Maykut and Untersteiner, 1971) 128 ! Obs: 0.1-0.5 (Lecomte et al, JAMES 2013) 129 ! -- limthd_dh -- ! 130 ln_limdH = .true. ! activate ice thickness change from growing/melting (T) or not (F) => DO NOT TOUCH UNLESS U KNOW WHAT U DO 131 rn_betas = 0.66 ! exponent in lead-ice repratition of snow precipitation 132 ! betas = 1 -> equipartition, betas < 1 -> more on leads 133 ! -- limthd_da -- ! 134 ln_limdA = .true. ! activate lateral melting param. (T) or not (F) => DO NOT TOUCH UNLESS U KNOW WHAT U DO 135 rn_beta = 1.0 ! (ln_latmelt=T) coef. beta for lateral melting param. Recommended range=[0.8-1.2] 136 ! => decrease = more melt and melt peaks toward higher concentration (A~0.5 for beta=1 ; A~0.8 for beta=0.2) 137 ! 0.3 = best fit for western Fram Strait and Antarctica 138 ! 1.4 = best fit for eastern Fram Strait 139 rn_dmin = 8. ! (ln_latmelt=T) minimum floe diameter for lateral melting param. Recommended range=[6-10] 140 ! => 6 vs 8m = +40% melting at the peak (A~0.5) 141 ! 10 vs 8m = -20% melting 142 ! -- limthd_lac -- ! 143 ln_limdO = .true. ! activate ice growth in open-water (T) or not (F) => DO NOT TOUCH UNLESS U KNOW WHAT U DO 144 rn_hnewice = 0.1 ! thickness for new ice formation in open water (m) 145 ln_frazil = .false. ! Frazil ice parameterization (ice collection as a function of wind) 146 rn_maxfrazb = 1.0 ! (ln_frazil=T) maximum fraction of frazil ice collecting at the ice base 147 rn_vfrazb = 0.417 ! (ln_frazil=T) thresold drift speed for frazil ice collecting at the ice bottom (m/s) 148 rn_Cfrazb = 5.0 ! (ln_frazil=T) squeezing coefficient for frazil ice collecting at the ice bottom 149 ! -- limitd_th -- ! 150 rn_himin = 0.1 ! minimum ice thickness (m) used in remapping, must be smaller than rn_hnewice 151 / 152 !------------------------------------------------------------------------------ 153 &namicesal ! Ice salinity 154 !------------------------------------------------------------------------------ 155 ! -- limthd_sal -- ! 156 ln_limdS = .true. ! activate gravity drainage and flushing (T) or not (F) => DO NOT TOUCH UNLESS U KNOW WHAT U DO 157 nn_icesal = 2 ! ice salinity option 158 ! 1: constant ice salinity (S=rn_icesal) 159 ! 2: varying salinity parameterization S(z,t) 160 ! 3: prescribed salinity profile S(z), Schwarzacher, 1959 161 rn_icesal = 4. ! (nn_icesal=1) ice salinity (g/kg) 162 rn_sal_gd = 5. ! restoring ice salinity, gravity drainage (g/kg) 163 rn_time_gd = 1.73e+6 ! restoring time scale, gravity drainage (s) 164 rn_sal_fl = 2. ! restoring ice salinity, flushing (g/kg) 165 rn_time_fl = 8.64e+5 ! restoring time scale, flushing (s) 166 rn_simax = 20. ! maximum tolerated ice salinity (g/kg) 167 rn_simin = 0.1 ! minimum tolerated ice salinity (g/kg) 168 / 169 !------------------------------------------------------------------------------ 170 &namiceitdme ! Ice mechanical redistribution (ridging and rafting) 171 !------------------------------------------------------------------------------ 172 ! -- limitd_me -- ! 173 rn_cs = 0.5 ! fraction of shearing energy contributing to ridging 174 nn_partfun = 1 ! type of ridging participation function 175 ! 0: linear (Thorndike et al, 1975) 176 ! 1: exponential (Lipscomb, 2007) 177 rn_gstar = 0.15 ! (nn_partfun = 0) fractional area of thin ice being ridged 178 rn_astar = 0.03 ! (nn_partfun = 1) exponential measure of ridging ice fraction [set to 0.05 if hstar=100] 179 ln_ridging = .true. ! ridging activated (T) or not (F) => DO NOT TOUCH UNLESS U KNOW WHAT U DO 180 rn_hstar = 25.0 ! (ln_ridging = T) determines the maximum thickness of ridged ice (m) (Hibler, 1980) 181 rn_por_rdg = 0.3 ! (ln_ridging = T) porosity of newly ridged ice (Lepparanta et al., 1995) 182 rn_fsnowrdg = 0.5 ! (ln_ridging = T) snow volume fraction that survives in ridging 183 ln_rafting = .true. ! rafting activated (T) or not (F) => DO NOT TOUCH UNLESS U KNOW WHAT U DO 184 rn_hraft = 0.75 ! (ln_rafting = T) threshold thickness for rafting (m) 185 rn_craft = 5.0 ! (ln_rafting = T) squeezing coefficient used in the rafting function 186 rn_fsnowrft = 0.5 ! (ln_rafting = T) snow volume fraction that survives in rafting 187 / 22 &nampar ! Generic parameters 23 !------------------------------------------------------------------------------ 24 jpl = 5 ! number of ice categories 25 nlay_i = 2 ! number of ice layers 26 nlay_s = 1 ! number of snow layers (only 1 is working) 27 nn_monocat = 0 ! virtual ITD mono-category parameterizations (1-4 => jpl = 1 only) or not (0) 28 ! 2: simple piling instead of ridging --- temporary option 29 ! 3: activate G(he) only --- temporary option 30 ! 4: activate extra lateral melting only --- temporary option 31 ln_icedyn = .true. ! ice dynamics (T) or not (F) 32 ln_icethd = .true. ! ice thermo (T) or not (F) 33 rn_amax_n = 0.997 ! maximum tolerated ice concentration NH 34 rn_amax_s = 0.997 ! maximum tolerated ice concentration SH 35 cn_icerst_in = "restart_ice" ! suffix of ice restart name (input) 36 cn_icerst_out = "restart_ice" ! suffix of ice restart name (output) 37 cn_icerst_indir = "." ! directory to read input ice restarts 38 cn_icerst_outdir = "." ! directory to write output ice restarts 39 / 40 !------------------------------------------------------------------------------ 41 &namitd ! Ice discretization 42 !------------------------------------------------------------------------------ 43 ln_cat_hfn = .true. ! ice categories are defined by a function following rn_himean**(-0.05) 44 rn_himean = 2.0 ! expected domain-average ice thickness (m) 45 ln_cat_usr = .false. ! ice categories are defined by rn_catbnd below (m) 46 rn_catbnd = 0.,0.45,1.1,2.1,3.7,6.0 47 rn_himin = 0.1 ! minimum ice thickness (m) used in remapping 48 / 49 !------------------------------------------------------------------------------ 50 &namdyn ! Ice dynamics 51 !------------------------------------------------------------------------------ 52 ln_dynFULL = .true. ! dyn.: full ice dynamics (rheology + advection + ridging/rafting + correction) 53 ln_dynRHGADV = .false. ! dyn.: no ridge/raft & no corrections (rheology + advection) 54 ln_dynADV = .false. ! dyn.: only advection w prescribed vel.(rn_uvice + advection) 55 rn_uice = 0.00001 ! prescribed ice u-velocity 56 rn_vice = 0. ! prescribed ice v-velocity 57 rn_ishlat = 2. ! free slip (0) ; partial slip (0-2) ; no slip (2) ; strong slip (>2) 58 ln_landfast = .false. ! landfast ice parameterization (T or F) 59 rn_gamma = 0.15 ! fraction of ocean depth that ice must reach to initiate landfast 60 ! recommended range: [0.1 ; 0.25] 61 rn_icebfr = 10. ! maximum bottom stress per unit area of contact [N/m2] 62 ! a very large value ensures ice velocity=0 even with a small contact area 63 ! recommended range: ?? (should be greater than atm-ice stress => >0.1 N/m2) 64 rn_lfrelax = 1.e-5 ! relaxation time scale to reach static friction [s-1] 65 / 66 !------------------------------------------------------------------------------ 67 &namdyn_rdgrft ! Ice ridging/rafting 68 !------------------------------------------------------------------------------ 69 ! -- ice_rdgrft_strength -- ! 70 ln_str_H79 = .true. ! ice strength param.: Hibler_79 => P = pstar*<h>*exp(-c_rhg*A) 71 rn_pstar = 2.0e+04 ! ice strength thickness parameter [N/m2] 72 rn_crhg = 20.0 ! ice strength conc. parameter (-) 73 ! -- ice_rdgrft -- ! 74 rn_csrdg = 0.5 ! fraction of shearing energy contributing to ridging 75 ! -- ice_rdgrft_prep -- ! 76 ln_partf_lin = .false. ! Linear ridging participation function (Thorndike et al, 1975) 77 rn_gstar = 0.15 ! fractional area of thin ice being ridged 78 ln_partf_exp = .true. ! Exponential ridging participation function (Lipscomb, 2007) 79 rn_astar = 0.03 ! exponential measure of ridging ice fraction [set to 0.05 if hstar=100] 80 ln_ridging = .true. ! ridging activated (T) or not (F) 81 rn_hstar = 25.0 ! determines the maximum thickness of ridged ice [m] (Hibler, 1980) 82 rn_porordg = 0.3 ! porosity of newly ridged ice (Lepparanta et al., 1995) 83 rn_fsnwrdg = 0.5 ! snow volume fraction that survives in ridging 84 rn_fpndrdg = 1.0 ! pond fraction that survives in ridging (small a priori) 85 ln_rafting = .true. ! rafting activated (T) or not (F) 86 rn_hraft = 0.75 ! threshold thickness for rafting [m] 87 rn_craft = 5.0 ! squeezing coefficient used in the rafting function 88 rn_fsnwrft = 0.5 ! snow volume fraction that survives in rafting 89 rn_fpndrft = 1.0 ! pond fraction that survives in rafting (0.5 a priori) 90 / 91 !------------------------------------------------------------------------------ 92 &namdyn_rhg ! Ice rheology 93 !------------------------------------------------------------------------------ 94 ln_rhg_EVP = .true. ! EVP rheology 95 ln_aEVP = .false. ! adaptive rheology (Kimmritz et al. 2016 & 2017) 96 rn_creepl = 2.0e-9 ! creep limit [1/s] 97 rn_ecc = 2.0 ! eccentricity of the elliptical yield curve 98 nn_nevp = 120 ! number of EVP subcycles 99 rn_relast = 0.333 ! ratio of elastic timescale to ice time step: Telast = dt_ice * rn_relast 100 ! advised value: 1/3 (rn_nevp=120) or 1/9 (rn_nevp=300) 101 / 102 !------------------------------------------------------------------------------ 103 &namdyn_adv ! Ice advection 104 !------------------------------------------------------------------------------ 105 ln_adv_Pra = .false. ! Advection scheme (Prather) 106 ln_adv_UMx = .true. ! Advection scheme (Ultimate-Macho) 107 nn_UMx = 5 ! order of the scheme for UMx (1-5 ; 20=centered 2nd order) 108 / 109 !------------------------------------------------------------------------------ 110 &namforcing ! Ice surface forcing 111 !------------------------------------------------------------------------------ 112 rn_cio = 5.0e-03 ! ice-ocean drag coefficient (-) 113 rn_blow_s = 0.66 ! mesure of snow blowing into the leads 114 ! = 1 => no snow blowing, < 1 => some snow blowing 115 nn_iceflx = -1 ! Redistribute heat flux over ice categories 116 ! =-1 Do nothing (needs N(cat) fluxes) 117 ! ==> forced mode only 118 ! = 0 Average N(cat) fluxes then apply the average over the N(cat) ice 119 ! ==> forced and coupled modes 120 ! = 1 Average N(cat) fluxes then redistribute over the N(cat) ice using T-ice and albedo sensitivity 121 ! ==> forced mode only 122 ! = 2 Redistribute a single flux over categories 123 ! ==> coupled mode only 124 nice_jules = 1 ! Jules coupling (0=OFF, 1=EMULATED, 2=ACTIVE) 125 / 126 !------------------------------------------------------------------------------ 127 &namthd ! Ice thermodynamics 128 !------------------------------------------------------------------------------ 129 ln_icedH = .true. ! activate ice thickness change from growing/melting (T) or not (F) 130 ln_icedA = .true. ! activate lateral melting param. (T) or not (F) 131 ln_icedO = .true. ! activate ice growth in open-water (T) or not (F) 132 ln_icedS = .true. ! activate brine drainage (T) or not (F) 133 / 134 !------------------------------------------------------------------------------ 135 &namthd_zdf ! Ice heat diffusion 136 !------------------------------------------------------------------------------ 137 ln_zdf_BL99 = .true. ! Heat diffusion follows Bitz and Lipscomb 1999 138 ln_cndi_U64 = .false. ! sea ice thermal conductivity: k = k0 + beta.S/T (Untersteiner, 1964) 139 ln_cndi_P07 = .true. ! sea ice thermal conductivity: k = k0 + beta1.S/T - beta2.T (Pringle et al., 2007) 140 rn_cnd_s = 0.31 ! thermal conductivity of the snow (0.31 W/m/K, Maykut and Untersteiner, 1971) 141 ! Obs: 0.1-0.5 (Lecomte et al, JAMES 2013) 142 rn_kappa_i = 1.0 ! radiation attenuation coefficient in sea ice [1/m] 143 / 144 !------------------------------------------------------------------------------ 145 &namthd_da ! Ice lateral melting 146 !------------------------------------------------------------------------------ 147 rn_beta = 1.0 ! coef. beta for lateral melting param. Recommended range=[0.8-1.2] 148 ! => decrease = more melt and melt peaks toward higher concentration (A~0.5 for beta=1 ; A~0.8 for beta=0.2) 149 ! 0.3 = best fit for western Fram Strait and Antarctica 150 ! 1.4 = best fit for eastern Fram Strait 151 rn_dmin = 8. ! minimum floe diameter for lateral melting param. Recommended range=[6-10] 152 ! => 6 vs 8m = +40% melting at the peak (A~0.5) 153 ! 10 vs 8m = -20% melting 154 / 155 !------------------------------------------------------------------------------ 156 &namthd_do ! Ice growth in open water 157 !------------------------------------------------------------------------------ 158 rn_hinew = 0.1 ! thickness for new ice formation in open water (m), must be larger than rn_hnewice 159 ln_frazil = .false. ! Frazil ice parameterization (ice collection as a function of wind) 160 rn_maxfraz = 1.0 ! maximum fraction of frazil ice collecting at the ice base 161 rn_vfraz = 0.417 ! thresold drift speed for frazil ice collecting at the ice bottom (m/s) 162 rn_Cfraz = 5.0 ! squeezing coefficient for frazil ice collecting at the ice bottom 163 / 164 !------------------------------------------------------------------------------ 165 &namthd_sal ! Ice salinity 166 !------------------------------------------------------------------------------ 167 nn_icesal = 2 ! ice salinity option 168 ! 1: constant ice salinity (S=rn_icesal) 169 ! 2: varying salinity parameterization S(z,t) 170 ! 3: prescribed salinity profile S(z), Schwarzacher, 1959 171 rn_icesal = 4. ! (nn_icesal=1) ice salinity (g/kg) 172 rn_sal_gd = 5. ! restoring ice salinity, gravity drainage (g/kg) 173 rn_time_gd = 1.73e+6 ! restoring time scale, gravity drainage (s) 174 rn_sal_fl = 2. ! restoring ice salinity, flushing (g/kg) 175 rn_time_fl = 8.64e+5 ! restoring time scale, flushing (s) 176 rn_simax = 20. ! maximum tolerated ice salinity (g/kg) 177 rn_simin = 0.1 ! minimum tolerated ice salinity (g/kg) 178 / 179 !------------------------------------------------------------------------------ 180 &namthd_pnd ! Melt ponds 181 !------------------------------------------------------------------------------ 182 ln_pnd_H12 = .false. ! activate evolutive melt ponds (from Holland et al 2012) 183 ln_pnd_fwb = .false. ! melt ponds store freshwater or not 184 ln_pnd_CST = .false. ! activate constant melt ponds 185 rn_apnd = 0.2 ! prescribed pond fraction, at Tsu=0 186 rn_hpnd = 0.05 ! prescribed pond depth, at Tsu=0 187 ln_pnd_alb = .false. ! melt ponds affect albedo or not 188 / 189 !------------------------------------------------------------------------------ 190 &namini ! Ice initialization 191 !------------------------------------------------------------------------------ 192 ln_iceini = .true. ! activate ice initialization (T) or not (F) 193 ln_iceini_file = .false. ! netcdf file provided for initialization (T) or not (F) 194 rn_thres_sst = 2.0 ! max delta temp. above Tfreeze with initial ice = (sst - tfreeze) 195 rn_hts_ini_n = 0.3 ! initial real snow thickness (m), North 196 rn_hts_ini_s = 0.3 ! " " South 197 rn_hti_ini_n = 3.0 ! initial real ice thickness (m), North 198 rn_hti_ini_s = 1.0 ! " " South 199 rn_ati_ini_n = 0.9 ! initial ice concentration (-), North 200 rn_ati_ini_s = 0.9 ! " " South 201 rn_smi_ini_n = 6.3 ! initial ice salinity (g/kg), North 202 rn_smi_ini_s = 6.3 ! " " South 203 rn_tmi_ini_n = 270. ! initial ice/snw temperature (K), North 204 rn_tmi_ini_s = 270. ! " " South 205 206 sn_hti = 'Ice_initialization' , -12 ,'hti' , .false. , .true., 'yearly' , '' , '', '' 207 sn_hts = 'Ice_initialization' , -12 ,'hts' , .false. , .true., 'yearly' , '' , '', '' 208 sn_ati = 'Ice_initialization' , -12 ,'ati' , .false. , .true., 'yearly' , '' , '', '' 209 sn_tsu = 'Ice_initialization' , -12 ,'tsu' , .false. , .true., 'yearly' , '' , '', '' 210 sn_tmi = 'Ice_initialization' , -12 ,'tmi' , .false. , .true., 'yearly' , '' , '', '' 211 sn_smi = 'Ice_initialization' , -12 ,'smi' , .false. , .true., 'yearly' , '' , '', '' 212 cn_dir='./' 213 / 214 !------------------------------------------------------------------------------ 215 &namalb ! albedo parameters 216 !------------------------------------------------------------------------------ 217 ! ! ! obs range (cloud-sky) 218 rn_alb_sdry = 0.85 ! dry snow albedo : 0.85 -- 0.87 219 rn_alb_smlt = 0.75 ! melting snow albedo : 0.72 -- 0.82 220 rn_alb_idry = 0.60 ! dry ice albedo : 0.54 -- 0.65 221 rn_alb_imlt = 0.50 ! bare puddled ice albedo : 0.49 -- 0.58 222 rn_alb_dpnd = 0.27 ! ponded ice albedo : 0.10 -- 0.30 223 / 224 !------------------------------------------------------------------------------ 225 &namdia ! Diagnostics 226 !------------------------------------------------------------------------------ 227 ln_icediachk = .false. ! check online the heat, mass & salt budgets (T) or not (F) 228 ln_icediahsb = .false. ! output the heat, mass & salt budgets (T) or not (F) 229 ln_icectl = .false. ! ice points output for debug (T or F) 230 iiceprt = 10 ! i-index for debug 231 jiceprt = 10 ! j-index for debug 232 / -
branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/CONFIG/SHARED/namelist_ref
r8877 r8879 188 188 ln_cpl = .false. ! atmosphere coupled formulation ( requires key_oasis3 ) 189 189 ln_mixcpl = .false. ! forced-coupled mixed formulation ( requires key_oasis3 ) 190 ln_meto_cpl = .false. ! Met Office coupling formulation, with surface exchange carried out in atmosphere (requires key_oasis3) 190 191 nn_components = 0 ! configuration of the opa-sas OASIS coupling 191 192 ! =0 no opa-sas OASIS coupling: default single executable configuration 192 193 ! =1 opa-sas OASIS coupling: multi executable configuration, OPA component 193 194 ! =2 opa-sas OASIS coupling: multi executable configuration, SAS component 194 nn_limflx = -1 ! LIM3 Multi-category heat flux formulation (use -1 if LIM3 is not used)195 ! =-1 Use per-category fluxes, bypass redistributor, forced mode only, not yet implemented coupled196 ! = 0 Average per-category fluxes (forced and coupled mode)197 ! = 1 Average and redistribute per-category fluxes, forced mode only, not yet implemented coupled198 ! = 2 Redistribute a single flux over categories (coupled mode only)199 195 ! Sea-ice : 200 nn_ice = 3! =0 no ice boundary condition ,196 nn_ice = 2 ! =0 no ice boundary condition , 201 197 ! =1 use observed ice-cover , 202 ! =2 to 4 : ice-model used (LIM2, LIM3 or CICE) ("key_lim3", "key_lim2", or "key_cice") 203 nn_ice_embd = 1 ! =0 levitating ice (no mass exchange, concentration/dilution effect) 204 ! =1 levitating ice with mass and salt exchange but no presure effect 205 ! =2 embedded sea-ice (full salt and mass exchanges and pressure) 198 ! =2 & 3 : ice-model used (LIM3 or CICE) ("key_lim3" or "key_cice") 199 ln_ice_embd = .false. ! =F levitating ice with mass and salt exchange but no presure effect 200 ! =T embedded sea-ice (full salt and mass exchanges and pressure) 206 201 ! Misc. options of sbc : 207 202 ln_traqsr = .true. ! Light penetration in the ocean (T => fill namtra_qsr) … … 264 259 rn_vfac = 0. ! multiplicative factor for ocean/ice velocity 265 260 ! in the calculation of the wind stress (0.=absolute winds or 1.=relative winds) 266 ln_Cd_L12 = .false. ! Modify the drag ice-atm and oce-atm depending on ice concentration267 ! This parameterization is from Lupkes et al. (JGR 2012)261 ln_Cd_L12 = .false. ! Modify the drag ice-atm depending on ice concentration with Lupkes 2012 262 ln_Cd_L15 = .false. ! Modify the drag ice-atm depending on ice concentration with Lupkes 2015 268 263 / 269 264 !----------------------------------------------------------------------- … … 281 276 sn_snd_ifrac = 'none' , 'no' , '' , '' , '' 282 277 sn_snd_wlev = 'coupled' , 'no' , '' , '' , '' 278 sn_snd_cond = 'weighted ice' , 'no' , '' , '' , '' 279 sn_snd_thick1 = 'ice and snow' , 'no' , '' , '' , '' 280 sn_snd_mpnd = 'weighted ice' , 'no' , '' , '' , '' 281 sn_snd_sstfrz = 'coupled' , 'no' , '' , '' , '' 282 sn_snd_ttilyr = 'weighted ice' , 'no' , '' , '' , '' 283 283 ! receive 284 284 sn_rcv_w10m = 'none' , 'no' , '' , '' , '' … … 302 302 sn_rcv_wstrf = 'none' , 'no' , '' , '' , '' 303 303 sn_rcv_wdrag = 'none' , 'no' , '' , '' , '' 304 sn_rcv_ts_ice = 'ice' , 'no' , '' , '' , '' 305 sn_rcv_isf = 'none' , 'no' , '' , '' , '' 306 sn_rcv_icb = 'none' , 'no' , '' , '' , '' 304 307 ! 305 308 nn_cplmodel = 1 ! Maximum number of models to/from which NEMO is potentialy sending/receiving data 306 309 ln_usecplmask = .false. ! use a coupling mask file to merge data received from several models 307 310 ! ! -> file cplmask.nc with the float variable called cplmask (jpi,jpj,nn_cplmodel) 311 nn_cats_cpl = 5 ! Number of sea ice categories over which coupling is to be carried out 308 312 / 309 313 !----------------------------------------------------------------------- … … 313 317 ! ! ! (if <0 months) ! name ! (logical) ! (T/F) ! 'monthly' ! filename ! pairing ! filename ! 314 318 l_sasread = .TRUE. ! Read fields in a file if .TRUE. , or initialize to 0. in sbcssm.F90 if .FALSE. 315 sn_usp = 'sas_grid_U', 120 , 'vozocrtx', .true. , .true. , 'yearly' , '' , '' , ''316 sn_vsp = 'sas_grid_V', 120 , 'vomecrty', .true. , .true. , 'yearly' , '' , '' , ''319 sn_usp = 'sas_grid_U', 120 , 'uos' , .true. , .true. , 'yearly' , '' , '' , '' 320 sn_vsp = 'sas_grid_V', 120 , 'vos' , .true. , .true. , 'yearly' , '' , '' , '' 317 321 sn_tem = 'sas_grid_T', 120 , 'sosstsst', .true. , .true. , 'yearly' , '' , '' , '' 318 322 sn_sal = 'sas_grid_T', 120 , 'sosaline', .true. , .true. , 'yearly' , '' , '' , '' … … 321 325 sn_frq = 'sas_grid_T', 120 , 'frq_m' , .true. , .true. , 'yearly' , '' , '' , '' 322 326 323 ln_3d_uve = . true.! specify whether we are supplying a 3D u,v and e3 field327 ln_3d_uve = .false. ! specify whether we are supplying a 3D u,v and e3 field 324 328 ln_read_frq = .false. ! specify whether we must read frq or not 325 329 cn_dir = './' ! root directory for the location of the bulk files are … … 340 344 rn_si0 = 0.35 ! RGB & 2 bands: shortess depth of extinction 341 345 rn_si1 = 23.0 ! 2 bands: longest depth of extinction 342 ln_qsr_ice = .true. ! light penetration for ice-model LIM3343 346 / 344 347 !----------------------------------------------------------------------- … … 434 437 ln_sssr_bnd = .true. ! flag to bound erp term (associated with nn_sssr=2) 435 438 rn_sssr_bnd = 4.e0 ! ABS(Max/Min) value of the damping erp term [mm/day] 436 /437 !-----------------------------------------------------------------------438 &namsbc_alb ! albedo parameters439 !-----------------------------------------------------------------------440 nn_ice_alb = 1 ! parameterization of ice/snow albedo441 ! 0: Shine & Henderson-Sellers (JGR 1985), giving clear-sky albedo442 ! 1: "home made" based on Brandt et al. (JClim 2005) and Grenfell & Perovich (JGR 2004),443 ! giving cloud-sky albedo444 rn_alb_sdry = 0.85 ! dry snow albedo : 0.80 (nn_ice_alb = 0); 0.85 (nn_ice_alb = 1); obs 0.85-0.87 (cloud-sky)445 rn_alb_smlt = 0.75 ! melting snow albedo : 0.65 ( '' ) ; 0.75 ( '' ) ; obs 0.72-0.82 ( '' )446 rn_alb_idry = 0.60 ! dry ice albedo : 0.72 ( '' ) ; 0.60 ( '' ) ; obs 0.54-0.65 ( '' )447 rn_alb_imlt = 0.50 ! bare puddled ice albedo : 0.53 ( '' ) ; 0.50 ( '' ) ; obs 0.49-0.58 ( '' )448 439 / 449 440 !----------------------------------------------------------------------- … … 581 572 bn_tem = 'amm12_bdyT_tra', 24 , 'votemper', .true. , .false. , 'daily' , '' , '' , '' 582 573 bn_sal = 'amm12_bdyT_tra', 24 , 'vosaline', .true. , .false. , 'daily' , '' , '' , '' 583 ! for lim2584 ! bn_frld = 'amm12_bdyT_ice', 24 , 'ileadfra', .true. , .false. , 'daily' , '' , '' , ''585 ! bn_hicif = 'amm12_bdyT_ice', 24 , 'iicethic', .true. , .false. , 'daily' , '' , '' , ''586 ! bn_hsnif = 'amm12_bdyT_ice', 24 , 'isnowthi', .true. , .false. , 'daily' , '' , '' , ''587 574 ! for lim3 588 575 ! bn_a_i = 'amm12_bdyT_ice', 24 , 'ileadfra', .true. , .false. , 'daily' , '' , '' , '' 589 ! bn_h t_i = 'amm12_bdyT_ice', 24 , 'iicethic', .true. , .false. , 'daily' , '' , '' , ''590 ! bn_h t_s = 'amm12_bdyT_ice', 24 , 'isnowthi', .true. , .false. , 'daily' , '' , '' , ''576 ! bn_h_i = 'amm12_bdyT_ice', 24 , 'iicethic', .true. , .false. , 'daily' , '' , '' , '' 577 ! bn_h_s = 'amm12_bdyT_ice', 24 , 'isnowthi', .true. , .false. , 'daily' , '' , '' , '' 591 578 592 579 cn_dir = 'bdydta/' ! root directory for the location of the bulk files -
branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/CONFIG/TEST_CASES/ISOMIP/EXP00/namelist_cfg
r8018 r8879 64 64 ! =1 use observed ice-cover , 65 65 ! =2 ice-model used 66 nn_ice_embd = 0 ! =0 levitating ice (no mass exchange, concentration/dilution effect)67 ! = 1 levitating ice with mass and salt exchange but no presure effect68 ! =2 embedded sea-ice (full salt and mass exchanges and pressure)66 ln_ice_embd = .false. ! =F levitating ice with mass and salt exchange but no presure effect 67 ! =T embedded sea-ice (full salt and mass exchanges and pressure) 68 ! Misc. options of sbc : 69 69 ln_traqsr = .false. ! Light penetration (T) or not (F) 70 70 ln_rnf = .false. ! runoffs (T => fill namsbc_rnf) -
branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/CONFIG/TEST_CASES/SAS_BIPER/EXP00/namelist_cfg
r7822 r8879 26 26 &namdom ! space and time domain (bathymetry, mesh, timestep) 27 27 !----------------------------------------------------------------------- 28 ln_linssh = . false. ! =T linear free surface ==>> model level are fixed in time28 ln_linssh = .true. ! =T linear free surface ==>> model level are fixed in time 29 29 ! 30 30 nn_msh = 1 ! create (>0) a mesh file or not (=0) -
branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/CONFIG/TEST_CASES/SAS_BIPER/EXP00/namelist_ice_cfg
r7820 r8879 1 1 !!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 2 !! LIM3 namelist: 3 !! 1 - Generic parameters (namicerun) 4 !! 2 - Diagnostics (namicediag) 5 !! 3 - Ice initialization (namiceini) 6 !! 4 - Ice discretization (namiceitd) 7 !! 5 - Ice dynamics and transport (namicedyn) 8 !! 6 - Ice diffusion (namicehdf) 9 !! 7 - Ice thermodynamics (namicethd) 10 !! 8 - Ice salinity (namicesal) 11 !! 9 - Ice mechanical redistribution (namiceitdme) 2 !! ESIM namelist: 3 !! 1 - Generic parameters (nampar) 4 !! 2 - Ice thickness discretization (namitd) 5 !! 3 - Ice dynamics (namdyn) 6 !! 4 - Ice ridging/rafting (namdyn_rdgrft) 7 !! 5 - Ice rheology (namdyn_rhg) 8 !! 6 - Ice advection (namdyn_adv) 9 !! 7 - Ice surface forcing (namforcing) 10 !! 8 - Ice thermodynamics (namthd) 11 !! 9 - Ice heat diffusion (namthd_zdf) 12 !! 10 - Ice lateral melting (namthd_da) 13 !! 11 - Ice growth in open water (namthd_do) 14 !! 12 - Ice salinity (namthd_sal) 15 !! 13 - Ice melt ponds (namthd_pnd) 16 !! 14 - Ice initialization (namini) 17 !! 15 - Ice/snow albedos (namalb) 18 !! 16 - Ice diagnostics (namdia) 12 19 !!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 13 20 ! 14 21 !------------------------------------------------------------------------------ 15 &nam icerun! Generic parameters22 &nampar ! Generic parameters 16 23 !------------------------------------------------------------------------------ 17 jpl = 1 ! number of ice categories 18 nlay_i = 1 ! number of ice layers 19 ln_limthd = .false. ! ice thermo (T) or not (F) => DO NOT TOUCH UNLESS U KNOW WHAT U DO 20 ln_limdyn = .true. ! ice dynamics (T) or not (F) => DO NOT TOUCH UNLESS U KNOW WHAT U DO 21 nn_limdyn = 0 ! (ln_limdyn=T) switch for ice dynamics 22 ! 2: total 23 ! 1: advection only (no diffusion, no ridging/rafting) 24 ! 0: advection only (as 1 but with prescribed velocity, bypass rheology) 25 rn_uice = 0.5 ! (nn_limdyn=0) ice u-velocity 26 rn_vice = 0.0 ! (nn_limdyn=0) ice v-velocity 24 jpl = 1 ! number of ice categories 25 nlay_i = 1 ! number of ice layers 26 ln_icedyn = .true. ! ice dynamics (T) or not (F) 27 ln_icethd = .false. ! ice thermo (T) or not (F) 27 28 / 28 29 !------------------------------------------------------------------------------ 29 &namicediag ! Diagnostics 30 &namitd ! Ice discretization 31 !------------------------------------------------------------------------------ 32 rn_himin = 0.1 ! minimum ice thickness (m) used in remapping 33 / 34 !------------------------------------------------------------------------------ 35 &namdyn ! Ice dynamics 36 !------------------------------------------------------------------------------ 37 ln_dynFULL = .false. ! dyn.: full ice dynamics (rheology + advection + ridging/rafting + correction) 38 ln_dynRHGADV = .false. ! dyn.: no ridge/raft & no corrections (rheology + advection) 39 ln_dynADV = .true. ! dyn.: only advection w prescribed vel.(rn_uvice + advection) 40 rn_uice = 0.5 ! prescribed ice u-velocity 41 rn_vice = 0. ! prescribed ice v-velocity 42 / 43 !------------------------------------------------------------------------------ 44 &namdyn_rdgrft ! Ice ridging/rafting 30 45 !------------------------------------------------------------------------------ 31 46 / 32 47 !------------------------------------------------------------------------------ 33 &namiceini ! Ice initialization 34 !------------------------------------------------------------------------------ 35 ! -- limistate -- ! 36 ln_limini = .true. ! activate ice initialization (T) or not (F) 37 ln_limini_file = .true. ! netcdf file provided for initialization (T) or not (F) 38 cn_dir="./" 39 sn_hti = 'initice' , -12 ,'hti' , .false. , .true., 'yearly' , '' , '', '' 40 sn_hts = 'initice' , -12 ,'hts' , .false. , .true., 'yearly' , '' , '', '' 41 sn_ati = 'initice' , -12 ,'ati' , .false. , .true., 'yearly' , '' , '', '' 42 sn_tsu = 'initice' , -12 ,'tsu' , .false. , .true., 'yearly' , '' , '', '' 43 sn_tmi = 'initice' , -12 ,'tmi' , .false. , .true., 'yearly' , '' , '', '' 44 sn_smi = 'initice' , -12 ,'smi' , .false. , .true., 'yearly' , '' , '', '' 45 / 46 !------------------------------------------------------------------------------ 47 &namiceitd ! Ice discretization 48 &namdyn_rhg ! Ice rheology 48 49 !------------------------------------------------------------------------------ 49 50 / 50 51 !------------------------------------------------------------------------------ 51 &namicedyn ! Ice dynamics and transport 52 !------------------------------------------------------------------------------ 53 ! -- limtrp & limadv -- ! 54 nn_limadv = 0 ! choose the advection scheme (-1=Prather ; 0=Ultimate-Macho) 55 nn_limadv_ord = 5 ! choose the order of the advection scheme (if nn_limadv=0) 56 / 57 !------------------------------------------------------------------------------ 58 &namicehdf ! Ice horizontal diffusion 52 &namdyn_adv ! Ice advection 59 53 !------------------------------------------------------------------------------ 60 54 / 61 55 !------------------------------------------------------------------------------ 62 &nam icethd ! Ice thermodynamics56 &namforcing ! Ice surface forcing 63 57 !------------------------------------------------------------------------------ 64 ! -- limthd_dh -- !65 ln_limdH = .true. ! activate ice thickness change from growing/melting (T) or not (F) => DO NOT TOUCH UNLESS U KNOW WHAT U DO66 ! -- limthd_da -- !67 ln_limdA = .true. ! activate lateral melting param. (T) or not (F) => DO NOT TOUCH UNLESS U KNOW WHAT U DO68 ! -- limthd_lac -- !69 ln_limdO = .true. ! activate ice growth in open-water (T) or not (F) => DO NOT TOUCH UNLESS U KNOW WHAT U DO70 rn_hnewice = 0.02 ! thickness for new ice formation in open water (m)71 ! -- limitd_th -- !72 rn_himin = 0.01 ! minimum ice thickness (m) used in remapping, must be smaller than rn_hnewice73 58 / 74 59 !------------------------------------------------------------------------------ 75 &nam icesal ! Ice salinity60 &namthd ! Ice thermodynamics 76 61 !------------------------------------------------------------------------------ 77 ! -- limthd_sal -- !78 ln_limdS = .true. ! activate gravity drainage and flushing (T) or not (F) => DO NOT TOUCH UNLESS U KNOW WHAT U DO79 62 / 80 63 !------------------------------------------------------------------------------ 81 &nam iceitdme ! Ice mechanical redistribution (ridging and rafting)64 &namthd_zdf ! Ice heat diffusion 82 65 !------------------------------------------------------------------------------ 83 ! -- limitd_me -- !84 ln_ridging = .true. ! ridging activated (T) or not (F) => DO NOT TOUCH UNLESS U KNOW WHAT U DO85 ln_rafting = .true. ! rafting activated (T) or not (F) => DO NOT TOUCH UNLESS U KNOW WHAT U DO86 66 / 67 !------------------------------------------------------------------------------ 68 &namthd_da ! Ice lateral melting 69 !------------------------------------------------------------------------------ 70 / 71 !------------------------------------------------------------------------------ 72 &namthd_do ! Ice growth in open water 73 !------------------------------------------------------------------------------ 74 / 75 !------------------------------------------------------------------------------ 76 &namthd_sal ! Ice salinity 77 !------------------------------------------------------------------------------ 78 / 79 !------------------------------------------------------------------------------ 80 &namthd_pnd ! Melt ponds 81 !------------------------------------------------------------------------------ 82 / 83 !------------------------------------------------------------------------------ 84 &namini ! Ice initialization 85 !------------------------------------------------------------------------------ 86 / 87 !------------------------------------------------------------------------------ 88 &namalb ! albedo parameters 89 !------------------------------------------------------------------------------ 90 / 91 !------------------------------------------------------------------------------ 92 &namdia ! Diagnostics 93 !------------------------------------------------------------------------------ 94 / -
branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/CONFIG/TEST_CASES/WAD/MY_SRC/bdyini.F90
r8877 r8879 351 351 IF(lwp) WRITE(numout,*) 352 352 353 #if defined key_lim2 354 IF(lwp) WRITE(numout,*) 'Boundary conditions for sea ice: ' 355 SELECT CASE( cn_ice_lim(ib_bdy) ) 356 CASE('none') 357 IF(lwp) WRITE(numout,*) ' no open boundary condition' 358 dta_bdy(ib_bdy)%ll_frld = .false. 359 dta_bdy(ib_bdy)%ll_hicif = .false. 360 dta_bdy(ib_bdy)%ll_hsnif = .false. 361 CASE('frs') 362 IF(lwp) WRITE(numout,*) ' Flow Relaxation Scheme' 363 dta_bdy(ib_bdy)%ll_frld = .true. 364 dta_bdy(ib_bdy)%ll_hicif = .true. 365 dta_bdy(ib_bdy)%ll_hsnif = .true. 366 CASE DEFAULT ; CALL ctl_stop( 'unrecognised value for cn_ice_lim' ) 367 END SELECT 368 IF( cn_ice_lim(ib_bdy) /= 'none' ) THEN 369 SELECT CASE( nn_ice_lim_dta(ib_bdy) ) ! 370 CASE( 0 ) ; IF(lwp) WRITE(numout,*) ' initial state used for bdy data' 371 CASE( 1 ) ; IF(lwp) WRITE(numout,*) ' boundary data taken from file' 372 CASE DEFAULT ; CALL ctl_stop( 'nn_ice_lim_dta must be 0 or 1' ) 373 END SELECT 374 ENDIF 375 IF(lwp) WRITE(numout,*) 376 #elif defined key_lim3 353 #if defined key_lim3 377 354 IF(lwp) WRITE(numout,*) 'Boundary conditions for sea ice: ' 378 355 SELECT CASE( cn_ice_lim(ib_bdy) ) -
branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/EXTERNAL/AGRIF/LIB/decl.h
r8877 r8879 36 36 #define LONG_FNAME 1000 // Max length for a file name 37 37 #define LONG_C 200 38 #define LONG_M 150038 #define LONG_M 2000 39 39 40 40 #define NB_CAT_VARIABLES 5 -
branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/NEMO/LIM_SRC_3/ice.F90
r8877 r8879 1 1 MODULE ice 2 2 !!====================================================================== 3 !! *** MODULE ice ***4 !! LIM-3 Sea Ice physics: diagnostics variables of icedefined in memory5 !!===================================================================== 3 !! *** MODULE ice *** 4 !! sea-ice: ice variables defined in memory 5 !!====================================================================== 6 6 !! History : 3.0 ! 2008-03 (M. Vancoppenolle) original code LIM-3 7 7 !! 4.0 ! 2011-02 (G. Madec) dynamical allocation … … 9 9 #if defined key_lim3 10 10 !!---------------------------------------------------------------------- 11 !! 'key_lim3' LIM-3sea-ice model11 !! 'key_lim3' ESIM sea-ice model 12 12 !!---------------------------------------------------------------------- 13 13 USE in_out_manager ! I/O manager … … 17 17 PRIVATE 18 18 19 PUBLIC ice_alloc ! Called in sbc_lim_init19 PUBLIC ice_alloc ! called by icestp.F90 20 20 21 21 !!====================================================================== … … 63 63 !! meaningful and/or used in ice thermodynamics | 64 64 !! | 65 !! Routines in limvar.F90 perform conversions |66 !! - lim_var_glo2eqv : from global to equivalent variables |67 !! - lim_var_eqv2glo : from equivalent to global variables |65 !! Routines in icevar.F90 perform conversions | 66 !! - ice_var_glo2eqv : from global to equivalent variables | 67 !! - ice_var_eqv2glo : from equivalent to global variables | 68 68 !! | 69 69 !! For various purposes, the sea ice state variables have sometimes | 70 70 !! to be aggregated over all ice thickness categories. This operation | 71 71 !! is done in : | 72 !! - lim_var_agg |72 !! - ice_var_agg | 73 73 !! | 74 74 !! in icestp.F90, the routines that compute the changes in the ice | 75 75 !! state variables are called | 76 !! - lim_dyn : ice dynamics | 77 !! - lim_trp : ice transport | 78 !! - lim_itd_me : mechanical redistribution (ridging and rafting) | 79 !! - lim_thd : ice halo-thermodynamics | 80 !! - lim_itd_th : thermodynamic changes in ice thickness distribution | 81 !! and creation of new ice | 76 !! - ice_rhg : ice dynamics | 77 !! - ice_adv : ice advection | 78 !! - ice_rdgrft : ice ridging and rafting | 79 !! - ice_thd : ice halo-thermodynamics and creation of new ice | 80 !! - ice_itd : thermodynamic changes in ice thickness distribution | 82 81 !! | 83 82 !! See the associated routines for more information | … … 107 106 !! v_i | - | Ice volume per unit area | m | 108 107 !! v_s | - | Snow volume per unit area | m | 109 !! s mv_i| - | Sea ice salt content | ppt.m |110 !! oa_i ! - ! Sea ice areal age content | day|108 !! sv_i | - | Sea ice salt content | ppt.m | 109 !! oa_i ! - ! Sea ice areal age content | s | 111 110 !! e_i ! - ! Ice enthalpy | J/m2 | 112 !! - ! q_i_1d ! Ice enthalpy per unit vol. | J/m3 |111 !! - ! e_i_1d ! Ice enthalpy per unit vol. | J/m3 | 113 112 !! e_s ! - ! Snow enthalpy | J/m2 | 114 !! - ! q_s_1d ! Snow enthalpy per unit vol. | J/m3 |113 !! - ! e_s_1d ! Snow enthalpy per unit vol. | J/m3 | 115 114 !! | 116 115 !!-------------|-------------|---------------------------------|-------| … … 119 118 !!-------------|-------------|---------------------------------|-------| 120 119 !! | 121 !! h t_i | ht_i_1d| Ice thickness | m |122 !! h t_s ! ht_s_1d| Snow depth | m |123 !! s m_i ! sm_i_1d| Sea ice bulk salinity ! ppt |124 !! s _i ! s_i_1d| Sea ice salinity profile ! ppt |125 !! o_i ! - | Sea ice Age ! days|120 !! h_i | h_i_1d | Ice thickness | m | 121 !! h_s ! h_s_1d | Snow depth | m | 122 !! s_i ! s_i_1d | Sea ice bulk salinity ! ppt | 123 !! sz_i ! sz_i_1d | Sea ice salinity profile ! ppt | 124 !! o_i ! - | Sea ice Age ! s | 126 125 !! t_i ! t_i_1d | Sea ice temperature ! K | 127 126 !! t_s ! t_s_1d | Snow temperature ! K | … … 144 143 !! vt_i | - | Total ice vol. per unit area | m | 145 144 !! vt_s | - | Total snow vol. per unit ar. | m | 146 !! sm t_i| - | Mean sea ice salinity | ppt |145 !! sm_i | - | Mean sea ice salinity | ppt | 147 146 !! tm_i | - | Mean sea ice temperature | K | 148 147 !! et_i ! - ! Total ice enthalpy | J/m2 | … … 151 150 !!===================================================================== 152 151 153 LOGICAL, PUBLIC :: con_i = .false. ! switch for conservation test 154 155 !!-------------------------------------------------------------------------- 152 !!---------------------------------------------------------------------- 156 153 !! * Share Module variables 157 !!---------------------------------------------------------------------- ----158 ! !!** ice-generic parameters namelist (nam icerun) **154 !!---------------------------------------------------------------------- 155 ! !!** ice-generic parameters namelist (nampar) ** 159 156 INTEGER , PUBLIC :: jpl !: number of ice categories 160 157 INTEGER , PUBLIC :: nlay_i !: number of ice layers 161 158 INTEGER , PUBLIC :: nlay_s !: number of snow layers 159 INTEGER , PUBLIC :: nn_monocat !: virtual ITD mono-category parameterizations (1-4) or not (0) 160 LOGICAL , PUBLIC :: ln_icedyn !: flag for ice dynamics (T) or not (F) 161 LOGICAL , PUBLIC :: ln_icethd !: flag for ice thermo (T) or not (F) 162 162 REAL(wp) , PUBLIC :: rn_amax_n !: maximum ice concentration Northern hemisphere 163 163 REAL(wp) , PUBLIC :: rn_amax_s !: maximum ice concentration Southern hemisphere … … 166 166 CHARACTER(len=256), PUBLIC :: cn_icerst_indir !: ice restart input directory 167 167 CHARACTER(len=256), PUBLIC :: cn_icerst_outdir!: ice restart output directory 168 LOGICAL , PUBLIC :: ln_limthd !: flag for ice thermo (T) or not (F) 169 LOGICAL , PUBLIC :: ln_limdyn !: flag for ice dynamics (T) or not (F) 170 INTEGER , PUBLIC :: nn_limdyn !: flag for ice dynamics 171 REAL(wp) , PUBLIC :: rn_uice !: prescribed u-vel (case nn_limdyn=0) 172 REAL(wp) , PUBLIC :: rn_vice !: prescribed v-vel (case nn_limdyn=0) 168 169 ! !!** ice-itd namelist (namitd) ** 170 REAL(wp), PUBLIC :: rn_himin !: minimum ice thickness 173 171 174 ! !!** ice-diagnostics namelist (namicediag) ** 175 LOGICAL , PUBLIC :: ln_limdiachk !: flag for ice diag (T) or not (F) 176 LOGICAL , PUBLIC :: ln_limdiahsb !: flag for ice diag (T) or not (F) 177 LOGICAL , PUBLIC :: ln_limctl !: flag for sea-ice points output (T) or not (F) 178 INTEGER , PUBLIC :: iiceprt !: debug i-point 179 INTEGER , PUBLIC :: jiceprt !: debug j-point 180 181 ! !!** ice-init namelist (namiceini) ** 182 ! -- limistate -- ! 183 LOGICAL , PUBLIC :: ln_limini ! initialization or not 184 LOGICAL , PUBLIC :: ln_limini_file ! Ice initialization state from 2D netcdf file 185 REAL(wp), PUBLIC :: rn_thres_sst ! threshold water temperature for initial sea ice 186 REAL(wp), PUBLIC :: rn_hts_ini_n ! initial snow thickness in the north 187 REAL(wp), PUBLIC :: rn_hts_ini_s ! initial snow thickness in the south 188 REAL(wp), PUBLIC :: rn_hti_ini_n ! initial ice thickness in the north 189 REAL(wp), PUBLIC :: rn_hti_ini_s ! initial ice thickness in the south 190 REAL(wp), PUBLIC :: rn_ati_ini_n ! initial leads area in the north 191 REAL(wp), PUBLIC :: rn_ati_ini_s ! initial leads area in the south 192 REAL(wp), PUBLIC :: rn_smi_ini_n ! initial salinity 193 REAL(wp), PUBLIC :: rn_smi_ini_s ! initial salinity 194 REAL(wp), PUBLIC :: rn_tmi_ini_n ! initial temperature 195 REAL(wp), PUBLIC :: rn_tmi_ini_s ! initial temperature 196 197 ! !!** ice-thickness distribution namelist (namiceitd) ** 198 INTEGER , PUBLIC :: nn_catbnd !: categories distribution following: tanh function (1), or h^(-alpha) function (2) 199 REAL(wp), PUBLIC :: rn_himean !: mean thickness of the domain (used to compute the distribution, nn_itdshp = 2 only) 200 201 ! !!** ice-dynamics namelist (namicedyn) ** 202 ! -- limtrp & limadv -- ! 203 INTEGER , PUBLIC :: nn_limadv !: choose the advection scheme (-1=Prather ; 0=Ultimate-Macho) 204 INTEGER , PUBLIC :: nn_limadv_ord !: choose the order of the advection scheme (if Ultimate-Macho) 205 ! -- limitd_me -- ! 206 INTEGER , PUBLIC :: nn_icestr !: ice strength parameterization (0=Hibler79 1=Rothrock75) 207 REAL(wp), PUBLIC :: rn_pe_rdg !: ridging work divided by pot. energy change in ridging, nn_icestr = 1 208 REAL(wp), PUBLIC :: rn_pstar !: determines ice strength, Hibler JPO79 209 REAL(wp), PUBLIC :: rn_crhg !: determines changes in ice strength 210 LOGICAL , PUBLIC :: ln_icestr_bvf !: use brine volume to diminish ice strength 211 ! -- limdyn & limrhg -- ! 212 REAL(wp), PUBLIC :: rn_cio !: drag coefficient for oceanic stress 172 ! !!** ice-dynamics namelist (namdyn) ** 173 REAL(wp), PUBLIC :: rn_ishlat !: lateral boundary condition for sea-ice 174 LOGICAL , PUBLIC :: ln_landfast !: landfast ice parameterization (T or F) 175 REAL(wp), PUBLIC :: rn_gamma !: fraction of ocean depth that ice must reach to initiate landfast ice 176 REAL(wp), PUBLIC :: rn_icebfr !: maximum bottom stress per unit area of contact (landfast ice) 177 REAL(wp), PUBLIC :: rn_lfrelax !: relaxation time scale (s-1) to reach static friction (landfast ice) 178 ! 179 ! !!** ice-rheology namelist (namrhg) ** 180 LOGICAL , PUBLIC :: ln_aEVP !: using adaptive EVP (T or F) 213 181 REAL(wp), PUBLIC :: rn_creepl !: creep limit : has to be under 1.0e-9 214 182 REAL(wp), PUBLIC :: rn_ecc !: eccentricity of the elliptical yield curve 215 183 INTEGER , PUBLIC :: nn_nevp !: number of iterations for subcycling 216 184 REAL(wp), PUBLIC :: rn_relast !: ratio => telast/rdt_ice (1/3 or 1/9 depending on nb of subcycling nevp) 217 LOGICAL , PUBLIC :: ln_landfast !: landfast ice parameterization (T or F) 218 REAL(wp), PUBLIC :: rn_gamma !: fraction of ocean depth that ice must reach to initiate landfast ice 219 REAL(wp), PUBLIC :: rn_icebfr !: maximum bottom stress per unit area of contact (landfast ice) 220 REAL(wp), PUBLIC :: rn_lfrelax !: relaxation time scale (s-1) to reach static friction (landfast ice) 221 222 ! !!** ice-diffusion namelist (namicehdf) ** 223 INTEGER , PUBLIC :: nn_ahi0 !: sea-ice hor. eddy diffusivity coeff. (3 ways of calculation) 224 REAL(wp), PUBLIC :: rn_ahi0_ref !: sea-ice hor. eddy diffusivity coeff. (m2/s) 225 226 ! !!** ice-thermodynamics namelist (namicethd) ** 227 ! -- limthd_dif -- ! 228 REAL(wp), PUBLIC :: rn_kappa_i !: coef. for the extinction of radiation Grenfell et al. (2006) [1/m] 229 REAL(wp), PUBLIC :: nn_conv_dif !: maximal number of iterations for heat diffusion 230 REAL(wp), PUBLIC :: rn_terr_dif !: maximal tolerated error (C) for heat diffusion 231 INTEGER , PUBLIC :: nn_ice_thcon !: thermal conductivity: =0 Untersteiner (1964) ; =1 Pringle et al (2007) 232 LOGICAL , PUBLIC :: ln_it_qnsice !: iterate surface flux with changing surface temperature or not (F) 233 INTEGER , PUBLIC :: nn_monocat !: virtual ITD mono-category parameterizations (1) or not (0) 234 REAL(wp), PUBLIC :: rn_cdsn !: thermal conductivity of the snow [W/m/K] 235 ! -- limthd_dh -- ! 236 LOGICAL , PUBLIC :: ln_limdH !: activate ice thickness change from growing/melting (T) or not (F) 237 REAL(wp), PUBLIC :: rn_betas !: coef. for partitioning of snowfall between leads and sea ice 238 ! -- limthd_da -- ! 239 LOGICAL , PUBLIC :: ln_limdA !: activate lateral melting param. (T) or not (F) 240 REAL(wp), PUBLIC :: rn_beta !: coef. beta for lateral melting param. 241 REAL(wp), PUBLIC :: rn_dmin !: minimum floe diameter for lateral melting param. 242 ! -- limthd_lac -- ! 243 LOGICAL , PUBLIC :: ln_limdO !: activate ice growth in open-water (T) or not (F) 244 REAL(wp), PUBLIC :: rn_hnewice !: thickness for new ice formation (m) 245 LOGICAL , PUBLIC :: ln_frazil !: use of frazil ice collection as function of wind (T) or not (F) 246 REAL(wp), PUBLIC :: rn_maxfrazb !: maximum portion of frazil ice collecting at the ice bottom 247 REAL(wp), PUBLIC :: rn_vfrazb !: threshold drift speed for collection of bottom frazil ice 248 REAL(wp), PUBLIC :: rn_Cfrazb !: squeezing coefficient for collection of bottom frazil ice 249 ! -- limitd_th -- ! 250 REAL(wp), PUBLIC :: rn_himin !: minimum ice thickness 251 252 ! !!** ice-salinity namelist (namicesal) ** 253 LOGICAL , PUBLIC :: ln_limdS !: activate gravity drainage and flushing (T) or not (F) 185 ! 186 ! !!** ice-surface forcing namelist (namforcing) ** 187 ! -- icethd_dh -- ! 188 REAL(wp), PUBLIC :: rn_blow_s !: coef. for partitioning of snowfall between leads and sea ice 189 ! -- icethd -- ! 190 REAL(wp), PUBLIC :: rn_cio !: drag coefficient for oceanic stress 191 INTEGER , PUBLIC :: nn_iceflx !: Redistribute heat flux over ice categories 192 ! ! =-1 Do nothing (needs N(cat) fluxes) 193 ! ! = 0 Average N(cat) fluxes then apply the average over the N(cat) ice 194 ! ! = 1 Average N(cat) fluxes then redistribute over the N(cat) ice 195 ! ! using T-ice and albedo sensitivity 196 ! ! = 2 Redistribute a single flux over categories 197 198 INTEGER , PUBLIC :: nice_jules ! Choice of jules coupling 199 ! ! Associated indices 200 INTEGER , PUBLIC, PARAMETER :: np_jules_OFF = 0 ! no Jules coupling (ice thermodynamics forced via qsr and qns) 201 INTEGER , PUBLIC, PARAMETER :: np_jules_EMULE = 1 ! emulated Jules coupling via icethd_zdf.F90 (BL99) (1st round compute qcn and qsr_tr, 2nd round use it) 202 INTEGER , PUBLIC, PARAMETER :: np_jules_ACTIVE = 2 ! active Jules coupling (SM0L) (compute qcn and qsr_tr via sbcblk.F90 or sbccpl.F90) 203 204 ! !!** ice-salinity namelist (namthd_sal) ** 254 205 INTEGER , PUBLIC :: nn_icesal !: salinity configuration used in the model 255 206 ! ! 1 - constant salinity in both space and time … … 257 208 ! ! 3 - salinity profile, constant in time 258 209 REAL(wp), PUBLIC :: rn_icesal !: bulk salinity (ppt) in case of constant salinity 259 REAL(wp), PUBLIC :: rn_sal_gd !: restoring salinity for gravity drainage [PSU]260 REAL(wp), PUBLIC :: rn_time_gd !: restoring time constant for gravity drainage (= 20 days) [s]261 REAL(wp), PUBLIC :: rn_sal_fl !: restoring salinity for flushing [PSU]262 REAL(wp), PUBLIC :: rn_time_fl !: restoring time constant for gravity drainage (= 10 days) [s]263 210 REAL(wp), PUBLIC :: rn_simax !: maximum ice salinity [PSU] 264 211 REAL(wp), PUBLIC :: rn_simin !: minimum ice salinity [PSU] 265 212 266 ! !!** ice-mechanical redistribution namelist (namiceitdme) 267 REAL(wp), PUBLIC :: rn_cs !: fraction of shearing energy contributing to ridging 268 INTEGER , PUBLIC :: nn_partfun !: participation function: =0 Thorndike et al. (1975), =1 Lipscomb et al. (2007) 269 REAL(wp), PUBLIC :: rn_gstar !: fractional area of young ice contributing to ridging 270 REAL(wp), PUBLIC :: rn_astar !: equivalent of G* for an exponential participation function 271 LOGICAL , PUBLIC :: ln_ridging !: ridging of ice or not 272 REAL(wp), PUBLIC :: rn_hstar !: thickness that determines the maximal thickness of ridged ice 273 REAL(wp), PUBLIC :: rn_por_rdg !: initial porosity of ridges (0.3 regular value) 274 REAL(wp), PUBLIC :: rn_fsnowrdg !: fractional snow loss to the ocean during ridging 275 LOGICAL , PUBLIC :: ln_rafting !: rafting of ice or not 276 REAL(wp), PUBLIC :: rn_hraft !: threshold thickness (m) for rafting / ridging 277 REAL(wp), PUBLIC :: rn_craft !: coefficient for smoothness of the hyperbolic tangent in rafting 278 REAL(wp), PUBLIC :: rn_fsnowrft !: fractional snow loss to the ocean during ridging 213 ! !!** namelist namthd_pnd 214 LOGICAL , PUBLIC :: ln_pnd_H12 !: Melt ponds scheme from Holland et al 2012 215 LOGICAL , PUBLIC :: ln_pnd_fwb !: melt ponds store freshwater 216 LOGICAL , PUBLIC :: ln_pnd_CST !: Melt ponds scheme with constant fraction and depth 217 REAL(wp), PUBLIC :: rn_apnd !: prescribed pond fraction (0<rn_apnd<1) 218 REAL(wp), PUBLIC :: rn_hpnd !: prescribed pond depth (0<rn_hpnd<1) 219 LOGICAL , PUBLIC :: ln_pnd_alb !: melt ponds affect albedo 220 221 ! !!** ice-diagnostics namelist (namdia) ** 222 LOGICAL , PUBLIC :: ln_icediachk !: flag for ice diag (T) or not (F) 223 LOGICAL , PUBLIC :: ln_icediahsb !: flag for ice diag (T) or not (F) 224 LOGICAL , PUBLIC :: ln_icectl !: flag for sea-ice points output (T) or not (F) 225 INTEGER , PUBLIC :: iiceprt !: debug i-point 226 INTEGER , PUBLIC :: jiceprt !: debug j-point 279 227 280 228 ! !!** some other parameters 281 INTEGER , PUBLIC :: nstart !: iteration number of the begining of the run 282 INTEGER , PUBLIC :: nlast !: iteration number of the end of the run 283 INTEGER , PUBLIC :: nitrun !: number of iteration 284 INTEGER , PUBLIC :: numit !: iteration number 229 INTEGER , PUBLIC :: kt_ice !: iteration number 285 230 REAL(wp), PUBLIC :: rdt_ice !: ice time step 286 231 REAL(wp), PUBLIC :: r1_rdtice !: = 1. / rdt_ice … … 288 233 REAL(wp), PUBLIC :: r1_nlay_s !: 1 / nlay_s 289 234 REAL(wp), PUBLIC :: rswitch !: switch for the presence of ice (1) or not (0) 290 REAL(wp), PUBLIC, PARAMETER :: epsi06 = 1.e-06_wp !: small number 291 REAL(wp), PUBLIC, PARAMETER :: epsi10 = 1.e-10_wp !: small number 292 REAL(wp), PUBLIC, PARAMETER :: epsi20 = 1.e-20_wp !: small number 235 REAL(wp), PUBLIC :: rdiag_v, rdiag_s, rdiag_t, rdiag_fv, rdiag_fs, rdiag_ft !: conservation diagnostics 236 REAL(wp), PUBLIC, PARAMETER :: epsi06 = 1.e-06_wp !: small number 237 REAL(wp), PUBLIC, PARAMETER :: epsi10 = 1.e-10_wp !: small number 238 REAL(wp), PUBLIC, PARAMETER :: epsi20 = 1.e-20_wp !: small number 239 293 240 294 241 ! !!** define arrays 295 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: u_oce, v_oce !: surface ocean velocity used in ice dynamics 296 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ahiu , ahiv !: hor. diffusivity coeff. at U- and V-points [m2/s] 297 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hicol !: ice collection thickness accreted in leads 242 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: u_oce,v_oce !: surface ocean velocity used in ice dynamics 243 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ht_i_new !: ice collection thickness accreted in leads 298 244 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: strength !: ice strength 299 245 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: stress1_i, stress2_i, stress12_i !: 1st, 2nd & diagonal stress tensor element … … 303 249 ! 304 250 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: t_bo !: Sea-Ice bottom temperature [Kelvin] 305 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: frld !: Leads fraction = 1 - ice fraction306 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: pfrld !: Leads fraction at previous time307 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: phicif !: Old ice thickness308 251 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qlead !: heat balance of the lead (or of the open ocean) 309 252 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fhtur !: net downward heat flux from the ice to the ocean … … 311 254 312 255 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_snw !: snow-ocean mass exchange [kg.m-2.s-1] 256 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_snw_sni !: snow ice growth component of wfx_snw [kg.m-2.s-1] 257 ! MV MP 2016 258 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_snw_sum !: surface melt component of wfx_snw [kg.m-2.s-1] 259 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_pnd !: melt pond-ocean mass exchange [kg.m-2.s-1] 260 ! END MV MP 2016 313 261 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_spr !: snow precipitation on ice [kg.m-2.s-1] 314 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_sub !: snow/ice sublimation [kg.m-2.s-1] 262 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_sub !: sublimation of snow/ice [kg.m-2.s-1] 263 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_snw_sub !: snow sublimation [kg.m-2.s-1] 264 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_ice_sub !: ice sublimation [kg.m-2.s-1] 265 266 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_snw_dyn !: dynamical component of wfx_snw [kg.m-2.s-1] 315 267 316 268 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_ice !: ice-ocean mass exchange [kg.m-2.s-1] … … 325 277 326 278 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: afx_tot !: ice concentration tendency (total) [s-1] 327 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: afx_thd !: ice concentration tendency (thermodynamics) [s-1]328 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: afx_dyn !: ice concentration tendency (dynamics) [s-1]329 279 330 280 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sfx_bog !: salt flux due to ice growth/melt [PSU/m2/s] … … 346 296 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_dif !: total heat flux causing Temp change in the ice [W.m-2] 347 297 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_snw !: heat flux for snow melt [W.m-2] 348 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_err !: heat flux error after heat diffusion [W.m-2]349 298 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_err_dif !: heat flux remaining due to change in non-solar flux [W.m-2] 350 299 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_err_rem !: heat flux error after heat remapping [W.m-2] … … 358 307 359 308 ! heat flux associated with ice-ocean mass exchange 360 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_thd !: ice-ocean heat flux from thermo processes ( limthd_dh)[W.m-2]361 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_dyn !: ice-ocean heat flux from mecanical processes (limitd_me)[W.m-2]309 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_thd !: ice-ocean heat flux from thermo processes (icethd_dh) [W.m-2] 310 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_dyn !: ice-ocean heat flux from ridging [W.m-2] 362 311 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_res !: residual heat flux due to correction of ice thickness [W.m-2] 363 312 364 313 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: rn_amax_2d !: maximum ice concentration 2d array 365 314 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ftr_ice !: transmitted solar radiation under ice 366 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: pahu3D, pahv3D !: ice hor. eddy diffusivity coef. at U- and V-points 367 368 !!-------------------------------------------------------------------------- 315 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: t1_ice !: temperature of the first layer (Jules coupling) [K] 316 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: cnd_ice !: effective conductivity at the top of ice/snow (Jules coupling) [W.m-2.K-1] 317 318 !!---------------------------------------------------------------------- 369 319 !! * Ice global state variables 370 !!---------------------------------------------------------------------- ----320 !!---------------------------------------------------------------------- 371 321 !! Variables defined for each ice category 372 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: h t_i!: Ice thickness (m)322 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: h_i !: Ice thickness (m) 373 323 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: a_i !: Ice fractional areas (concentration) 374 324 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: v_i !: Ice volume per unit area (m) 375 325 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: v_s !: Snow volume per unit area(m) 376 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: h t_s!: Snow thickness (m)326 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: h_s !: Snow thickness (m) 377 327 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: t_su !: Sea-Ice Surface Temperature (K) 378 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: sm_i !: Sea-Ice Bulk salinity (ppt) 379 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: smv_i !: Sea-Ice Bulk salinity times volume per area (ppt.m) 380 ! ! this is an extensive variable that has to be transported 381 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: o_i !: Sea-Ice Age (days) 382 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: oa_i !: Sea-Ice Age times ice area (days) 328 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: s_i !: Sea-Ice Bulk salinity (ppt) 329 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: sv_i !: Sea-Ice Bulk salinity times volume per area (ppt.m) 330 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: o_i !: Sea-Ice Age (s) 331 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: oa_i !: Sea-Ice Age times ice area (s) 383 332 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: bv_i !: brine volume 384 333 … … 391 340 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tm_i !: mean ice temperature over all categories 392 341 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: bvm_i !: brine volume averaged over all categories 393 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sm t_i!: mean sea ice salinity averaged over all categories [PSU]342 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sm_i !: mean sea ice salinity averaged over all categories [PSU] 394 343 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tm_su !: mean surface temperature over all categories 395 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: h tm_i!: mean ice thickness over all categories396 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: h tm_s!: mean snow thickness over all categories344 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hm_i !: mean ice thickness over all categories 345 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hm_s !: mean snow thickness over all categories 397 346 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: om_i !: mean ice age over all categories 398 347 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tau_icebfr !: ice friction with bathy (landfast param activated) 399 348 400 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: t_s !: Snow temperatures [K] 401 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: e_s !: Snow ... 402 403 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: t_i !: ice temperatures [K] 404 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: e_i !: ice thermal contents [J/m2] 405 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: s_i !: ice salinities [PSU] 406 407 !!-------------------------------------------------------------------------- 408 !! * Moments for advection 409 !!-------------------------------------------------------------------------- 410 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sxopw, syopw, sxxopw, syyopw, sxyopw !: open water in sea ice 411 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: sxice, syice, sxxice, syyice, sxyice !: ice thickness 412 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: sxsn , sysn , sxxsn , syysn , sxysn !: snow thickness 413 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: sxa , sya , sxxa , syya , sxya !: lead fraction 414 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: sxc0 , syc0 , sxxc0 , syyc0 , sxyc0 !: snow thermal content 415 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: sxsal, sysal, sxxsal, syysal, sxysal !: ice salinity 416 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: sxage, syage, sxxage, syyage, sxyage !: ice age 417 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: sxe , sye , sxxe , syye , sxye !: ice layers heat content 418 419 !!-------------------------------------------------------------------------- 349 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: t_s !: Snow temperatures [K] 350 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: e_s !: Snow enthalpy [J/m2] 351 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: t_i !: ice temperatures [K] 352 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: e_i !: ice enthalpy [J/m2] 353 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: sz_i !: ice salinity [PSU] 354 355 ! MV MP 2016 356 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: a_ip !: melt pond fraction per grid cell area 357 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: v_ip !: melt pond volume per grid cell area [m] 358 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: a_ip_frac !: melt pond volume per ice area 359 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: h_ip !: melt pond thickness [m] 360 361 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: at_ip !: total melt pond fraction 362 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: vt_ip !: total melt pond volume per unit area [m] 363 ! END MV MP 2016 364 365 !!---------------------------------------------------------------------- 420 366 !! * Old values of global variables 421 !!---------------------------------------------------------------------- ----422 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: v_s_b, v_i_b !: snow and ice volumes423 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: a_i_b, s mv_i_b, oa_i_b!:424 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: e_s_b !: snow heat content425 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: e_i_b !: ice temperatures426 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: u_ice_b, v_ice_b !: ice velocity427 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: at_i_b !: ice concentration (total)367 !!---------------------------------------------------------------------- 368 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: v_s_b, v_i_b, h_s_b, h_i_b !: snow and ice volumes/thickness 369 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: a_i_b, sv_i_b, oa_i_b !: 370 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: e_s_b !: snow heat content 371 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: e_i_b !: ice temperatures 372 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: u_ice_b, v_ice_b !: ice velocity 373 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: at_i_b !: ice concentration (total) 428 374 429 !!---------------------------------------------------------------------- ----375 !!---------------------------------------------------------------------- 430 376 !! * Ice thickness distribution variables 431 !!---------------------------------------------------------------------- ----377 !!---------------------------------------------------------------------- 432 378 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: hi_max !: Boundary of ice thickness categories in thickness space 433 379 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: hi_mean !: Mean ice thickness in catgories 434 380 ! 435 !!---------------------------------------------------------------------- ----381 !!---------------------------------------------------------------------- 436 382 !! * Ice diagnostics 437 !!---------------------------------------------------------------------- ----383 !!---------------------------------------------------------------------- 438 384 ! thd refers to changes induced by thermodynamics 439 385 ! trp '' '' '' advection (transport of ice) … … 443 389 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_trp_ei !: transport of ice enthalpy (W/m2) 444 390 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_trp_es !: transport of snw enthalpy (W/m2) 445 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_trp_s mv!: transport of salt content391 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_trp_sv !: transport of salt content 446 392 ! 447 393 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_heat !: snw/ice heat content variation [W/m2] 448 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_s mvi!: ice salt content variation []394 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_sice !: ice salt content variation [] 449 395 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_vice !: ice volume variation [m/s] 450 396 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_vsnw !: snw volume variation [m/s] 397 398 ! 399 !!---------------------------------------------------------------------- 400 !! * SIMIP extra diagnostics 401 !!---------------------------------------------------------------------- 402 ! Extra sea ice diagnostics to address the data request 403 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: t_si !: Temperature at Snow-ice interface (K) 404 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tm_si !: mean temperature at the snow-ice interface (K) 405 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_fc_bo !: Bottom conduction flux (W/m2) 406 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: diag_fc_su !: Surface conduction flux (W/m2) 407 451 408 ! 452 409 !!---------------------------------------------------------------------- … … 463 420 INTEGER :: ice_alloc 464 421 ! 465 INTEGER :: ierr(1 5), ii422 INTEGER :: ierr(18), ii 466 423 !!----------------------------------------------------------------- 467 424 … … 471 428 ! stay within Fortran's max-line length limit. 472 429 ii = 1 473 ALLOCATE( u_oce (jpi,jpj) , v_oce (jpi,jpj) , & 474 & ahiu (jpi,jpj) , ahiv (jpi,jpj) , hicol (jpi,jpj) , & 430 ALLOCATE( u_oce (jpi,jpj) , v_oce (jpi,jpj) , ht_i_new (jpi,jpj) , & 475 431 & strength(jpi,jpj) , stress1_i(jpi,jpj) , stress2_i(jpi,jpj) , stress12_i(jpi,jpj) , & 476 432 & delta_i (jpi,jpj) , divu_i (jpi,jpj) , shear_i (jpi,jpj) , STAT=ierr(ii) ) 477 433 478 434 ii = ii + 1 479 ALLOCATE( t_bo (jpi,jpj) , frld (jpi,jpj) , pfrld (jpi,jpj) , phicif (jpi,jpj) , & 480 & wfx_snw(jpi,jpj) , wfx_ice(jpi,jpj) , wfx_sub(jpi,jpj) , wfx_lam(jpi,jpj) , & 435 ALLOCATE( t_bo (jpi,jpj) , wfx_snw_sni(jpi,jpj) , & 436 & wfx_snw(jpi,jpj) , wfx_snw_dyn(jpi,jpj) , wfx_snw_sum(jpi,jpj) , wfx_snw_sub(jpi,jpj) , & 437 & wfx_ice(jpi,jpj) , wfx_sub (jpi,jpj) , wfx_ice_sub(jpi,jpj) , wfx_lam (jpi,jpj) , & 438 & wfx_pnd(jpi,jpj) , & 481 439 & wfx_bog(jpi,jpj) , wfx_dyn(jpi,jpj) , wfx_bom(jpi,jpj) , wfx_sum(jpi,jpj) , & 482 440 & wfx_res(jpi,jpj) , wfx_sni(jpi,jpj) , wfx_opw(jpi,jpj) , wfx_spr(jpi,jpj) , & 483 & afx_tot(jpi,jpj) , afx_thd(jpi,jpj), afx_dyn(jpi,jpj) , rn_amax_2d(jpi,jpj),&441 & afx_tot(jpi,jpj) , rn_amax_2d(jpi,jpj), & 484 442 & fhtur (jpi,jpj) , qlead (jpi,jpj) , & 485 443 & sfx_res(jpi,jpj) , sfx_bri(jpi,jpj) , sfx_dyn(jpi,jpj) , sfx_sub(jpi,jpj) , sfx_lam(jpi,jpj) , & 486 444 & sfx_bog(jpi,jpj) , sfx_bom(jpi,jpj) , sfx_sum(jpi,jpj) , sfx_sni(jpi,jpj) , sfx_opw(jpi,jpj) , & 487 & hfx_res(jpi,jpj) , hfx_snw(jpi,jpj) , hfx_sub(jpi,jpj) , hfx_err(jpi,jpj) ,&445 & hfx_res(jpi,jpj) , hfx_snw(jpi,jpj) , hfx_sub(jpi,jpj) , & 488 446 & hfx_in (jpi,jpj) , hfx_out(jpi,jpj) , fhld (jpi,jpj) , & 489 447 & hfx_sum(jpi,jpj) , hfx_bom(jpi,jpj) , hfx_bog(jpi,jpj) , hfx_dif(jpi,jpj) , & … … 493 451 ! * Ice global state variables 494 452 ii = ii + 1 495 ALLOCATE( ftr_ice(jpi,jpj,jpl) , pahu3D(jpi,jpj,jpl+1) , pahv3D(jpi,jpj,jpl+1) ,&496 & h t_i (jpi,jpj,jpl) , a_i (jpi,jpj,jpl) , v_i (jpi,jpj,jpl) , &497 & v_s (jpi,jpj,jpl) , h t_s (jpi,jpj,jpl) , t_su (jpi,jpj,jpl) , &498 & s m_i (jpi,jpj,jpl) , smv_i (jpi,jpj,jpl) , o_i (jpi,jpj,jpl) , &453 ALLOCATE( ftr_ice(jpi,jpj,jpl) ,cnd_ice(jpi,jpj,jpl), t1_ice(jpi,jpj,jpl) , & 454 & h_i (jpi,jpj,jpl) , a_i (jpi,jpj,jpl) , v_i (jpi,jpj,jpl) , & 455 & v_s (jpi,jpj,jpl) , h_s (jpi,jpj,jpl) , t_su (jpi,jpj,jpl) , & 456 & s_i (jpi,jpj,jpl) , sv_i (jpi,jpj,jpl) , o_i (jpi,jpj,jpl) , & 499 457 & oa_i (jpi,jpj,jpl) , bv_i (jpi,jpj,jpl) , STAT=ierr(ii) ) 500 458 ii = ii + 1 … … 502 460 & vt_i (jpi,jpj) , vt_s (jpi,jpj) , at_i (jpi,jpj) , ato_i(jpi,jpj) , & 503 461 & et_i (jpi,jpj) , et_s (jpi,jpj) , tm_i (jpi,jpj) , bvm_i(jpi,jpj) , & 504 & sm t_i(jpi,jpj) , tm_su(jpi,jpj) , htm_i(jpi,jpj) , htm_s(jpi,jpj) , &462 & sm_i (jpi,jpj) , tm_su(jpi,jpj) , hm_i(jpi,jpj) , hm_s(jpi,jpj) , & 505 463 & om_i (jpi,jpj) , tau_icebfr(jpi,jpj) , STAT=ierr(ii) ) 506 464 ii = ii + 1 507 465 ALLOCATE( t_s(jpi,jpj,nlay_s,jpl) , e_s(jpi,jpj,nlay_s,jpl) , STAT=ierr(ii) ) 508 466 ii = ii + 1 509 ALLOCATE( t_i(jpi,jpj,nlay_i,jpl) , e_i(jpi,jpj,nlay_i,jpl) , s_i(jpi,jpj,nlay_i,jpl) , STAT=ierr(ii) ) 510 511 ! * Moments for advection 512 ii = ii + 1 513 ALLOCATE( sxopw(jpi,jpj) , syopw(jpi,jpj) , sxxopw(jpi,jpj) , syyopw(jpi,jpj) , sxyopw(jpi,jpj) , STAT=ierr(ii) ) 514 ii = ii + 1 515 ALLOCATE( sxice(jpi,jpj,jpl) , syice(jpi,jpj,jpl) , sxxice(jpi,jpj,jpl) , syyice(jpi,jpj,jpl) , sxyice(jpi,jpj,jpl) , & 516 & sxsn (jpi,jpj,jpl) , sysn (jpi,jpj,jpl) , sxxsn (jpi,jpj,jpl) , syysn (jpi,jpj,jpl) , sxysn (jpi,jpj,jpl) , & 517 & STAT=ierr(ii) ) 518 ii = ii + 1 519 ALLOCATE( sxa (jpi,jpj,jpl) , sya (jpi,jpj,jpl) , sxxa (jpi,jpj,jpl) , syya (jpi,jpj,jpl) , sxya (jpi,jpj,jpl) , & 520 & sxc0 (jpi,jpj,jpl) , syc0 (jpi,jpj,jpl) , sxxc0 (jpi,jpj,jpl) , syyc0 (jpi,jpj,jpl) , sxyc0 (jpi,jpj,jpl) , & 521 & sxsal(jpi,jpj,jpl) , sysal(jpi,jpj,jpl) , sxxsal(jpi,jpj,jpl) , syysal(jpi,jpj,jpl) , sxysal(jpi,jpj,jpl) , & 522 & sxage(jpi,jpj,jpl) , syage(jpi,jpj,jpl) , sxxage(jpi,jpj,jpl) , syyage(jpi,jpj,jpl) , sxyage(jpi,jpj,jpl) , & 523 & STAT=ierr(ii) ) 524 ii = ii + 1 525 ALLOCATE( sxe (jpi,jpj,nlay_i,jpl) , sye (jpi,jpj,nlay_i,jpl) , sxxe(jpi,jpj,nlay_i,jpl) , & 526 & syye(jpi,jpj,nlay_i,jpl) , sxye(jpi,jpj,nlay_i,jpl) , STAT=ierr(ii) ) 467 ALLOCATE( t_i(jpi,jpj,nlay_i,jpl) , e_i(jpi,jpj,nlay_i,jpl) , sz_i(jpi,jpj,nlay_i,jpl) , STAT=ierr(ii) ) 468 469 ii = ii + 1 470 ALLOCATE( a_ip(jpi,jpj,jpl) , v_ip(jpi,jpj,jpl) , a_ip_frac(jpi,jpj,jpl) , & 471 & h_ip(jpi,jpj,jpl) , STAT = ierr(ii) ) 472 ii = ii + 1 473 ALLOCATE( at_ip(jpi,jpj) , vt_ip(jpi,jpj) , STAT = ierr(ii) ) 527 474 528 475 ! * Old values of global variables 529 476 ii = ii + 1 530 ALLOCATE( v_s_b (jpi,jpj,jpl) , v_i_b (jpi,jpj,jpl) , e_s_b(jpi,jpj,nlay_s,jpl) ,&531 & a_i_b (jpi,jpj,jpl) , s mv_i_b(jpi,jpj,jpl) , e_i_b(jpi,jpj,nlay_i,jpl) ,&532 & oa_i_b (jpi,jpj,jpl) , STAT=ierr(ii) )477 ALLOCATE( v_s_b (jpi,jpj,jpl) , v_i_b (jpi,jpj,jpl) , h_s_b(jpi,jpj,jpl) , h_i_b(jpi,jpj,jpl) , & 478 & a_i_b (jpi,jpj,jpl) , sv_i_b(jpi,jpj,jpl) , e_i_b (jpi,jpj,nlay_i,jpl) , e_s_b (jpi,jpj,nlay_s,jpl) , & 479 & oa_i_b (jpi,jpj,jpl) , STAT=ierr(ii) ) 533 480 ii = ii + 1 534 481 ALLOCATE( u_ice_b(jpi,jpj) , v_ice_b(jpi,jpj) , at_i_b(jpi,jpj) , STAT=ierr(ii) ) … … 541 488 ii = ii + 1 542 489 ALLOCATE( diag_trp_vi(jpi,jpj) , diag_trp_vs (jpi,jpj) , diag_trp_ei(jpi,jpj), & 543 & diag_trp_es(jpi,jpj) , diag_trp_smv(jpi,jpj) , diag_heat (jpi,jpj), & 544 & diag_smvi (jpi,jpj) , diag_vice (jpi,jpj) , diag_vsnw (jpi,jpj), STAT=ierr(ii) ) 490 & diag_trp_es(jpi,jpj) , diag_trp_sv (jpi,jpj) , diag_heat (jpi,jpj), & 491 & diag_sice (jpi,jpj) , diag_vice (jpi,jpj) , diag_vsnw (jpi,jpj), STAT=ierr(ii) ) 492 493 ! * SIMIP diagnostics 494 ii = ii + 1 495 ALLOCATE( t_si (jpi,jpj,jpl) , tm_si(jpi,jpj) , & 496 diag_fc_bo(jpi,jpj) , diag_fc_su(jpi,jpj) , & 497 STAT = ierr(ii) ) 545 498 546 499 ice_alloc = MAXVAL( ierr(:) ) … … 551 504 #else 552 505 !!---------------------------------------------------------------------- 553 !! Default option Empty module NO LIM sea-ice model506 !! Default option Empty module NO ESIM sea-ice model 554 507 !!---------------------------------------------------------------------- 555 508 #endif -
branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/NEMO/NST_SRC/agrif_ice.F90
r8877 r8879 7 7 !! 3.6 ! 2016-05 (C. Rousset) Add LIM3 compatibility 8 8 !!---------------------------------------------------------------------- 9 #if defined key_agrif && defined key_lim2 10 !!---------------------------------------------------------------------- 11 !! 'key_agrif' AGRIF zoom 12 !!---------------------------------------------------------------------- 13 USE par_oce ! ocean parameters 14 15 IMPLICIT NONE 16 PRIVATE 17 18 PUBLIC agrif_ice_alloc ! routine called by nemo_init in nemogcm.F90 19 20 INTEGER, PUBLIC :: u_ice_id, v_ice_id, adv_ice_id 21 REAL(wp), PUBLIC :: lim_nbstep = 0. ! child time position in sea-ice model 22 #if defined key_lim2_vp 23 REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: u_ice_nst, v_ice_nst 24 #else 25 REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:) :: u_ice_oe, u_ice_sn !: boundaries arrays 26 REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:) :: v_ice_oe, v_ice_sn !: " " 27 #endif 28 REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:,:) :: adv_ice_oe, adv_ice_sn !: " " 29 30 !!---------------------------------------------------------------------- 31 !! NEMO/NST 3.3.4 , NEMO Consortium (2012) 32 !! $Id$ 33 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 34 !!---------------------------------------------------------------------- 35 36 CONTAINS 37 38 INTEGER FUNCTION agrif_ice_alloc() 39 !!---------------------------------------------------------------------- 40 !! *** FUNCTION agrif_ice_alloc *** 41 !!---------------------------------------------------------------------- 42 #if defined key_lim2_vp 43 ALLOCATE( u_ice_nst(jpi,jpj), v_ice_nst(jpi,jpj) , & 44 #else 45 ALLOCATE( u_ice_oe(4,jpj,2) , v_ice_oe(4,jpj,2) , & 46 & u_ice_sn(jpi,4,2) , v_ice_sn(jpi,4,2) , & 47 #endif 48 & adv_ice_oe (4,jpj,7,2) , adv_ice_sn (jpi,4,7,2) , & 49 & STAT = agrif_ice_alloc) 50 51 #if ! defined key_lim2_vp 52 u_ice_oe(:,:,:) = 0.e0 53 v_ice_oe(:,:,:) = 0.e0 54 u_ice_sn(:,:,:) = 0.e0 55 v_ice_sn(:,:,:) = 0.e0 56 #endif 57 adv_ice_oe (:,:,:,:) = 0.e0 58 adv_ice_sn (:,:,:,:) = 0.e0 59 ! 60 END FUNCTION agrif_ice_alloc 61 62 #elif defined key_agrif && defined key_lim3 9 #if defined key_agrif && defined key_lim3 63 10 !!---------------------------------------------------------------------- 64 11 !! 'key_agrif' AGRIF zoom -
branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/NEMO/NST_SRC/agrif_lim3_interp.F90
r8877 r8879 52 52 !!----------------------------------------------------------------------- 53 53 ! 54 IF( Agrif_Root() ) RETURN54 IF( Agrif_Root() .OR. nn_ice==0 ) RETURN ! clem2017: do not interpolate if inside Parent domain or if child domain does not have ice 55 55 ! 56 56 SELECT CASE(cd_type) … … 90 90 !! i1 i2 j1 j2 are the index of the boundaries parent(when before) and child (when after) 91 91 !! To solve issues when parent grid is "land" masked but not all the corresponding child grid points, 92 !! put -999 9WHERE the parent grid is masked. The child solution will be found in the 9(?) points around92 !! put -999 WHERE the parent grid is masked. The child solution will be found in the 9(?) points around 93 93 !!----------------------------------------------------------------------- 94 94 INTEGER , INTENT(in) :: i1, i2, j1, j2 … … 101 101 IF( before ) THEN ! parent grid 102 102 ptab(:,:) = e2u(i1:i2,j1:j2) * u_ice_b(i1:i2,j1:j2) 103 WHERE( umask(i1:i2,j1:j2,1) == 0. ) ptab(:,:) = -9999.103 WHERE( umask(i1:i2,j1:j2,1) == 0. ) ptab(i1:i2,j1:j2) = Agrif_SpecialValue 104 104 ELSE ! child grid 105 105 zrhoy = Agrif_Rhoy() 106 u_ice(i1:i2,j1:j2) = ptab( :,:) / ( e2u(i1:i2,j1:j2) * zrhoy ) * umask(i1:i2,j1:j2,1)106 u_ice(i1:i2,j1:j2) = ptab(i1:i2,j1:j2) / ( e2u(i1:i2,j1:j2) * zrhoy ) * umask(i1:i2,j1:j2,1) 107 107 ENDIF 108 108 ! … … 116 116 !! i1 i2 j1 j2 are the index of the boundaries parent(when before) and child (when after) 117 117 !! To solve issues when parent grid is "land" masked but not all the corresponding child grid points, 118 !! put -999 9WHERE the parent grid is masked. The child solution will be found in the 9(?) points around118 !! put -999 WHERE the parent grid is masked. The child solution will be found in the 9(?) points around 119 119 !!----------------------------------------------------------------------- 120 120 INTEGER , INTENT(in) :: i1, i2, j1, j2 … … 127 127 IF( before ) THEN ! parent grid 128 128 ptab(:,:) = e1v(i1:i2,j1:j2) * v_ice_b(i1:i2,j1:j2) 129 WHERE( vmask(i1:i2,j1:j2,1) == 0. ) ptab( :,:) = -9999.129 WHERE( vmask(i1:i2,j1:j2,1) == 0. ) ptab(i1:i2,j1:j2) = Agrif_SpecialValue 130 130 ELSE ! child grid 131 131 zrhox = Agrif_Rhox() 132 v_ice(i1:i2,j1:j2) = ptab( :,:) / ( e1v(i1:i2,j1:j2) * zrhox ) * vmask(i1:i2,j1:j2,1)132 v_ice(i1:i2,j1:j2) = ptab(i1:i2,j1:j2) / ( e1v(i1:i2,j1:j2) * zrhox ) * vmask(i1:i2,j1:j2,1) 133 133 ENDIF 134 134 ! … … 142 142 !! i1 i2 j1 j2 are the index of the boundaries parent(when before) and child (when after) 143 143 !! To solve issues when parent grid is "land" masked but not all the corresponding child grid points, 144 !! put -999 9WHERE the parent grid is masked. The child solution will be found in the 9(?) points around144 !! put -999 WHERE the parent grid is masked. The child solution will be found in the 9(?) points around 145 145 !!----------------------------------------------------------------------- 146 146 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab … … 158 158 ! tracers are not multiplied by grid cell here => before: * e12t ; after: * r1_e12t / rhox / rhoy 159 159 ! and it is ok since we conserve tracers (same as in the ocean). 160 ALLOCATE( ztab(SIZE(a_i _b,1),SIZE(a_i_b,2),SIZE(ptab,3)) )160 ALLOCATE( ztab(SIZE(a_i,1),SIZE(a_i,2),SIZE(ptab,3)) ) 161 161 162 162 IF( before ) THEN ! parent grid 163 163 jm = 1 164 164 DO jl = 1, jpl 165 ptab(i1:i2,j1:j2,jm) = a_i_b (i1:i2,j1:j2,jl) ; jm = jm + 1 166 ptab(i1:i2,j1:j2,jm) = v_i_b (i1:i2,j1:j2,jl) ; jm = jm + 1 167 ptab(i1:i2,j1:j2,jm) = v_s_b (i1:i2,j1:j2,jl) ; jm = jm + 1 168 ptab(i1:i2,j1:j2,jm) = smv_i_b(i1:i2,j1:j2,jl) ; jm = jm + 1 169 ptab(i1:i2,j1:j2,jm) = oa_i_b (i1:i2,j1:j2,jl) ; jm = jm + 1 165 ptab(i1:i2,j1:j2,jm ) = a_i_b (i1:i2,j1:j2,jl) 166 ptab(i1:i2,j1:j2,jm+1) = v_i_b (i1:i2,j1:j2,jl) 167 ptab(i1:i2,j1:j2,jm+2) = v_s_b (i1:i2,j1:j2,jl) 168 ptab(i1:i2,j1:j2,jm+3) = sv_i_b(i1:i2,j1:j2,jl) 169 ptab(i1:i2,j1:j2,jm+4) = oa_i_b(i1:i2,j1:j2,jl) 170 jm = jm + 5 170 171 DO jk = 1, nlay_s 171 172 ptab(i1:i2,j1:j2,jm) = e_s_b(i1:i2,j1:j2,jk,jl) ; jm = jm + 1 … … 177 178 178 179 DO jk = k1, k2 179 WHERE( tmask(i1:i2,j1:j2,1) == 0. ) ptab(i1:i2,j1:j2,jk) = -9999.180 WHERE( tmask(i1:i2,j1:j2,1) == 0. ) ptab(i1:i2,j1:j2,jk) = Agrif_SpecialValue 180 181 ENDDO 181 182 182 183 ELSE ! child grid 183 !! ==> The easiest interpolation is the following commented lines 184 jm = 1 185 DO jl = 1, jpl 186 a_i (i1:i2,j1:j2,jl) = ptab(i1:i2,j1:j2,jm) * tmask(i1:i2,j1:j2,1) ; jm = jm + 1 187 v_i (i1:i2,j1:j2,jl) = ptab(i1:i2,j1:j2,jm) * tmask(i1:i2,j1:j2,1) ; jm = jm + 1 188 v_s (i1:i2,j1:j2,jl) = ptab(i1:i2,j1:j2,jm) * tmask(i1:i2,j1:j2,1) ; jm = jm + 1 189 smv_i(i1:i2,j1:j2,jl) = ptab(i1:i2,j1:j2,jm) * tmask(i1:i2,j1:j2,1) ; jm = jm + 1 190 oa_i (i1:i2,j1:j2,jl) = ptab(i1:i2,j1:j2,jm) * tmask(i1:i2,j1:j2,1) ; jm = jm + 1 191 DO jk = 1, nlay_s 192 e_s(i1:i2,j1:j2,jk,jl) = ptab(i1:i2,j1:j2,jm) * tmask(i1:i2,j1:j2,1) ; jm = jm + 1 193 ENDDO 194 DO jk = 1, nlay_i 195 e_i(i1:i2,j1:j2,jk,jl) = ptab(i1:i2,j1:j2,jm) * tmask(i1:i2,j1:j2,1) ; jm = jm + 1 196 ENDDO 197 ENDDO 198 199 !! ==> this is a more complex interpolation since we mix solutions over a couple of grid points 200 !! it is advised to use it for fields modified by high order schemes (e.g. advection UM5...) 201 !! clem: for some reason (I don't know why), the following lines do not work 202 !! with mpp (or in realistic configurations?). It makes the model crash 203 ! ! record ztab 204 ! jm = 1 205 ! DO jl = 1, jpl 206 ! ztab(:,:,jm) = a_i (:,:,jl) ; jm = jm + 1 207 ! ztab(:,:,jm) = v_i (:,:,jl) ; jm = jm + 1 208 ! ztab(:,:,jm) = v_s (:,:,jl) ; jm = jm + 1 209 ! ztab(:,:,jm) = smv_i(:,:,jl) ; jm = jm + 1 210 ! ztab(:,:,jm) = oa_i (:,:,jl) ; jm = jm + 1 211 ! DO jk = 1, nlay_s 212 ! ztab(:,:,jm) = e_s(:,:,jk,jl) ; jm = jm + 1 213 ! ENDDO 214 ! DO jk = 1, nlay_i 215 ! ztab(:,:,jm) = e_i(:,:,jk,jl) ; jm = jm + 1 216 ! ENDDO 217 ! ENDDO 218 ! ! 219 ! ! borders of the domain 220 ! western_side = (nb == 1).AND.(ndir == 1) ; eastern_side = (nb == 1).AND.(ndir == 2) 221 ! southern_side = (nb == 2).AND.(ndir == 1) ; northern_side = (nb == 2).AND.(ndir == 2) 222 ! ! 223 ! ! spatial smoothing 224 ! zrhox = Agrif_Rhox() 225 ! z1 = ( zrhox - 1. ) * 0.5 226 ! z3 = ( zrhox - 1. ) / ( zrhox + 1. ) 227 ! z6 = 2. * ( zrhox - 1. ) / ( zrhox + 1. ) 228 ! z7 = - ( zrhox - 1. ) / ( zrhox + 3. ) 229 ! z2 = 1. - z1 230 ! z4 = 1. - z3 231 ! z5 = 1. - z6 - z7 232 ! ! 233 ! ! Remove corners 234 ! imin = i1 ; imax = i2 ; jmin = j1 ; jmax = j2 235 ! IF( (nbondj == -1) .OR. (nbondj == 2) ) jmin = 3 236 ! IF( (nbondj == +1) .OR. (nbondj == 2) ) jmax = nlcj-2 237 ! IF( (nbondi == -1) .OR. (nbondi == 2) ) imin = 3 238 ! IF( (nbondi == +1) .OR. (nbondi == 2) ) imax = nlci-2 239 ! 240 ! ! smoothed fields 241 ! IF( eastern_side ) THEN 242 ! ztab(nlci,j1:j2,:) = z1 * ptab(nlci,j1:j2,:) + z2 * ptab(nlci-1,j1:j2,:) 243 ! DO jj = jmin, jmax 244 ! rswitch = 0. 245 ! IF( u_ice(nlci-2,jj) > 0._wp ) rswitch = 1. 246 ! ztab(nlci-1,jj,:) = ( 1. - umask(nlci-2,jj,1) ) * ztab(nlci,jj,:) & 247 ! & + umask(nlci-2,jj,1) * & 248 ! & ( ( 1. - rswitch ) * ( z4 * ztab(nlci,jj,:) + z3 * ztab(nlci-2,jj,:) ) & 249 ! & + rswitch * ( z6 * ztab(nlci-2,jj,:) + z5 * ztab(nlci,jj,:) + z7 * ztab(nlci-3,jj,:) ) ) 250 ! ztab(nlci-1,jj,:) = ztab(nlci-1,jj,:) * tmask(nlci-1,jj,1) 251 ! END DO 252 ! ENDIF 253 ! ! 254 ! IF( northern_side ) THEN 255 ! ztab(i1:i2,nlcj,:) = z1 * ptab(i1:i2,nlcj,:) + z2 * ptab(i1:i2,nlcj-1,:) 256 ! DO ji = imin, imax 257 ! rswitch = 0. 258 ! IF( v_ice(ji,nlcj-2) > 0._wp ) rswitch = 1. 259 ! ztab(ji,nlcj-1,:) = ( 1. - vmask(ji,nlcj-2,1) ) * ztab(ji,nlcj,:) & 260 ! & + vmask(ji,nlcj-2,1) * & 261 ! & ( ( 1. - rswitch ) * ( z4 * ztab(ji,nlcj,:) + z3 * ztab(ji,nlcj-2,:) ) & 262 ! & + rswitch * ( z6 * ztab(ji,nlcj-2,:) + z5 * ztab(ji,nlcj,:) + z7 * ztab(ji,nlcj-3,:) ) ) 263 ! ztab(ji,nlcj-1,:) = ztab(ji,nlcj-1,:) * tmask(ji,nlcj-1,1) 264 ! END DO 265 ! END IF 266 ! ! 267 ! IF( western_side) THEN 268 ! ztab(1,j1:j2,:) = z1 * ptab(1,j1:j2,:) + z2 * ptab(2,j1:j2,:) 269 ! DO jj = jmin, jmax 270 ! rswitch = 0. 271 ! IF( u_ice(2,jj) < 0._wp ) rswitch = 1. 272 ! ztab(2,jj,:) = ( 1. - umask(2,jj,1) ) * ztab(1,jj,:) & 273 ! & + umask(2,jj,1) * & 274 ! & ( ( 1. - rswitch ) * ( z4 * ztab(1,jj,:) + z3 * ztab(3,jj,:) ) & 275 ! & + rswitch * ( z6 * ztab(3,jj,:) + z5 * ztab(1,jj,:) + z7 * ztab(4,jj,:) ) ) 276 ! ztab(2,jj,:) = ztab(2,jj,:) * tmask(2,jj,1) 277 ! END DO 278 ! ENDIF 279 ! ! 280 ! IF( southern_side ) THEN 281 ! ztab(i1:i2,1,:) = z1 * ptab(i1:i2,1,:) + z2 * ptab(i1:i2,2,:) 282 ! DO ji = imin, imax 283 ! rswitch = 0. 284 ! IF( v_ice(ji,2) < 0._wp ) rswitch = 1. 285 ! ztab(ji,2,:) = ( 1. - vmask(ji,2,1) ) * ztab(ji,1,:) & 286 ! & + vmask(ji,2,1) * & 287 ! & ( ( 1. - rswitch ) * ( z4 * ztab(ji,1,:) + z3 * ztab(ji,3,:) ) & 288 ! & + rswitch * ( z6 * ztab(ji,3,:) + z5 * ztab(ji,1,:) + z7 * ztab(ji,4,:) ) ) 289 ! ztab(ji,2,:) = ztab(ji,2,:) * tmask(ji,2,1) 290 ! END DO 291 ! END IF 292 ! ! 293 ! ! Treatment of corners 294 ! IF( (eastern_side) .AND. ((nbondj == -1).OR.(nbondj == 2)) ) ztab(nlci-1,2,:) = ptab(nlci-1,2,:) ! East south 295 ! IF( (eastern_side) .AND. ((nbondj == 1).OR.(nbondj == 2)) ) ztab(nlci-1,nlcj-1,:) = ptab(nlci-1,nlcj-1,:) ! East north 296 ! IF( (western_side) .AND. ((nbondj == -1).OR.(nbondj == 2)) ) ztab(2,2,:) = ptab(2,2,:) ! West south 297 ! IF( (western_side) .AND. ((nbondj == 1).OR.(nbondj == 2)) ) ztab(2,nlcj-1,:) = ptab(2,nlcj-1,:) ! West north 298 ! 299 ! ! retrieve ice tracers 300 ! jm = 1 301 ! DO jl = 1, jpl 302 ! a_i (i1:i2,j1:j2,jl) = ztab(i1:i2,j1:j2,jm) ; jm = jm + 1 303 ! v_i (i1:i2,j1:j2,jl) = ztab(i1:i2,j1:j2,jm) ; jm = jm + 1 304 ! v_s (i1:i2,j1:j2,jl) = ztab(i1:i2,j1:j2,jm) ; jm = jm + 1 305 ! smv_i(i1:i2,j1:j2,jl) = ztab(i1:i2,j1:j2,jm) ; jm = jm + 1 306 ! oa_i (i1:i2,j1:j2,jl) = ztab(i1:i2,j1:j2,jm) ; jm = jm + 1 307 ! DO jk = 1, nlay_s 308 ! e_s(i1:i2,j1:j2,jk,jl) = ztab(i1:i2,j1:j2,jm) ; jm = jm + 1 309 ! ENDDO 310 ! DO jk = 1, nlay_i 311 ! e_i(i1:i2,j1:j2,jk,jl) = ztab(i1:i2,j1:j2,jm) ; jm = jm + 1 312 ! ENDDO 313 ! ENDDO 314 184 185 IF( nbghostcells > 1 ) THEN 186 !! ==> The easiest interpolation is the following lines 187 188 jm = 1 189 DO jl = 1, jpl 190 ! 191 DO jj = j1, j2 192 DO ji = i1, i2 193 a_i (ji,jj,jl) = ptab(ji,jj,jm ) * tmask(ji,jj,1) 194 v_i (ji,jj,jl) = ptab(ji,jj,jm+1) * tmask(ji,jj,1) 195 v_s (ji,jj,jl) = ptab(ji,jj,jm+2) * tmask(ji,jj,1) 196 sv_i(ji,jj,jl) = ptab(ji,jj,jm+3) * tmask(ji,jj,1) 197 oa_i(ji,jj,jl) = ptab(ji,jj,jm+4) * tmask(ji,jj,1) 198 ENDDO 199 ENDDO 200 jm = jm + 5 201 ! 202 DO jk = 1, nlay_s 203 e_s(i1:i2,j1:j2,jk,jl) = ptab(:,:,jm) * tmask(i1:i2,j1:j2,1) 204 jm = jm + 1 205 ENDDO 206 ! 207 DO jk = 1, nlay_i 208 e_i(i1:i2,j1:j2,jk,jl) = ptab(:,:,jm) * tmask(i1:i2,j1:j2,1) 209 jm = jm + 1 210 ENDDO 211 ! 212 ENDDO 213 214 ELSE 215 !! ==> this is a more complex interpolation since we mix solutions over a couple of grid points 216 !! it is advised to use it for fields modified by high order schemes (e.g. advection UM5...) 217 !! clem: for some reason (I don't know why), the following lines do not work 218 !! with mpp (or in realistic configurations?). It makes the model crash 219 ! I think there is an issue with Agrif_SpecialValue here (not taken into account properly) 220 ! record ztab 221 jm = 1 222 DO jl = 1, jpl 223 ztab(:,:,jm ) = a_i (:,:,jl) 224 ztab(:,:,jm+1) = v_i (:,:,jl) 225 ztab(:,:,jm+2) = v_s (:,:,jl) 226 ztab(:,:,jm+3) = sv_i(:,:,jl) 227 ztab(:,:,jm+4) = oa_i(:,:,jl) 228 jm = jm + 5 229 DO jk = 1, nlay_s 230 ztab(:,:,jm) = e_s(:,:,jk,jl) 231 jm = jm + 1 232 ENDDO 233 DO jk = 1, nlay_i 234 ztab(:,:,jm) = e_i(:,:,jk,jl) 235 jm = jm + 1 236 ENDDO 237 ! 238 ENDDO 239 ! 240 ! borders of the domain 241 western_side = (nb == 1).AND.(ndir == 1) ; eastern_side = (nb == 1).AND.(ndir == 2) 242 southern_side = (nb == 2).AND.(ndir == 1) ; northern_side = (nb == 2).AND.(ndir == 2) 243 ! 244 ! spatial smoothing 245 zrhox = Agrif_Rhox() 246 z1 = ( zrhox - 1. ) * 0.5 247 z3 = ( zrhox - 1. ) / ( zrhox + 1. ) 248 z6 = 2. * ( zrhox - 1. ) / ( zrhox + 1. ) 249 z7 = - ( zrhox - 1. ) / ( zrhox + 3. ) 250 z2 = 1. - z1 251 z4 = 1. - z3 252 z5 = 1. - z6 - z7 253 ! 254 ! Remove corners 255 imin = i1 ; imax = i2 ; jmin = j1 ; jmax = j2 256 IF( (nbondj == -1) .OR. (nbondj == 2) ) jmin = 3 257 IF( (nbondj == +1) .OR. (nbondj == 2) ) jmax = nlcj-2 258 IF( (nbondi == -1) .OR. (nbondi == 2) ) imin = 3 259 IF( (nbondi == +1) .OR. (nbondi == 2) ) imax = nlci-2 260 261 ! smoothed fields 262 IF( eastern_side ) THEN 263 ztab(nlci,j1:j2,:) = z1 * ptab(nlci,j1:j2,:) + z2 * ptab(nlci-1,j1:j2,:) 264 DO jj = jmin, jmax 265 rswitch = 0. 266 IF( u_ice(nlci-2,jj) > 0._wp ) rswitch = 1. 267 ztab(nlci-1,jj,:) = ( 1. - umask(nlci-2,jj,1) ) * ztab(nlci,jj,:) & 268 & + umask(nlci-2,jj,1) * & 269 & ( ( 1. - rswitch ) * ( z4 * ztab(nlci,jj,:) + z3 * ztab(nlci-2,jj,:) ) & 270 & + rswitch * ( z6 * ztab(nlci-2,jj,:) + z5 * ztab(nlci,jj,:) + z7 * ztab(nlci-3,jj,:) ) ) 271 ztab(nlci-1,jj,:) = ztab(nlci-1,jj,:) * tmask(nlci-1,jj,1) 272 END DO 273 ENDIF 274 ! 275 IF( northern_side ) THEN 276 ztab(i1:i2,nlcj,:) = z1 * ptab(i1:i2,nlcj,:) + z2 * ptab(i1:i2,nlcj-1,:) 277 DO ji = imin, imax 278 rswitch = 0. 279 IF( v_ice(ji,nlcj-2) > 0._wp ) rswitch = 1. 280 ztab(ji,nlcj-1,:) = ( 1. - vmask(ji,nlcj-2,1) ) * ztab(ji,nlcj,:) & 281 & + vmask(ji,nlcj-2,1) * & 282 & ( ( 1. - rswitch ) * ( z4 * ztab(ji,nlcj,:) + z3 * ztab(ji,nlcj-2,:) ) & 283 & + rswitch * ( z6 * ztab(ji,nlcj-2,:) + z5 * ztab(ji,nlcj,:) + z7 * ztab(ji,nlcj-3,:) ) ) 284 ztab(ji,nlcj-1,:) = ztab(ji,nlcj-1,:) * tmask(ji,nlcj-1,1) 285 END DO 286 END IF 287 ! 288 IF( western_side) THEN 289 ztab(1,j1:j2,:) = z1 * ptab(1,j1:j2,:) + z2 * ptab(2,j1:j2,:) 290 DO jj = jmin, jmax 291 rswitch = 0. 292 IF( u_ice(2,jj) < 0._wp ) rswitch = 1. 293 ztab(2,jj,:) = ( 1. - umask(2,jj,1) ) * ztab(1,jj,:) & 294 & + umask(2,jj,1) * & 295 & ( ( 1. - rswitch ) * ( z4 * ztab(1,jj,:) + z3 * ztab(3,jj,:) ) & 296 & + rswitch * ( z6 * ztab(3,jj,:) + z5 * ztab(1,jj,:) + z7 * ztab(4,jj,:) ) ) 297 ztab(2,jj,:) = ztab(2,jj,:) * tmask(2,jj,1) 298 END DO 299 ENDIF 300 ! 301 IF( southern_side ) THEN 302 ztab(i1:i2,1,:) = z1 * ptab(i1:i2,1,:) + z2 * ptab(i1:i2,2,:) 303 DO ji = imin, imax 304 rswitch = 0. 305 IF( v_ice(ji,2) < 0._wp ) rswitch = 1. 306 ztab(ji,2,:) = ( 1. - vmask(ji,2,1) ) * ztab(ji,1,:) & 307 & + vmask(ji,2,1) * & 308 & ( ( 1. - rswitch ) * ( z4 * ztab(ji,1,:) + z3 * ztab(ji,3,:) ) & 309 & + rswitch * ( z6 * ztab(ji,3,:) + z5 * ztab(ji,1,:) + z7 * ztab(ji,4,:) ) ) 310 ztab(ji,2,:) = ztab(ji,2,:) * tmask(ji,2,1) 311 END DO 312 END IF 313 ! 314 ! Treatment of corners 315 IF( (eastern_side) .AND. ((nbondj == -1).OR.(nbondj == 2)) ) ztab(nlci-1,2,:) = ptab(nlci-1,2,:) ! East south 316 IF( (eastern_side) .AND. ((nbondj == 1).OR.(nbondj == 2)) ) ztab(nlci-1,nlcj-1,:) = ptab(nlci-1,nlcj-1,:) ! East north 317 IF( (western_side) .AND. ((nbondj == -1).OR.(nbondj == 2)) ) ztab(2,2,:) = ptab(2,2,:) ! West south 318 IF( (western_side) .AND. ((nbondj == 1).OR.(nbondj == 2)) ) ztab(2,nlcj-1,:) = ptab(2,nlcj-1,:) ! West north 319 320 ! retrieve ice tracers 321 jm = 1 322 DO jl = 1, jpl 323 ! 324 DO jj = j1, j2 325 DO ji = i1, i2 326 a_i (ji,jj,jl) = ztab(ji,jj,jm ) * tmask(ji,jj,1) 327 v_i (ji,jj,jl) = ztab(ji,jj,jm+1) * tmask(ji,jj,1) 328 v_s (ji,jj,jl) = ztab(ji,jj,jm+2) * tmask(ji,jj,1) 329 sv_i(ji,jj,jl) = ztab(ji,jj,jm+3) * tmask(ji,jj,1) 330 oa_i (ji,jj,jl) = ztab(ji,jj,jm+4) * tmask(ji,jj,1) 331 ENDDO 332 ENDDO 333 jm = jm + 5 334 ! 335 DO jk = 1, nlay_s 336 e_s(i1:i2,j1:j2,jk,jl) = ztab(i1:i2,j1:j2,jm) * tmask(i1:i2,j1:j2,1) 337 jm = jm + 1 338 ENDDO 339 ! 340 DO jk = 1, nlay_i 341 e_i(i1:i2,j1:j2,jk,jl) = ztab(i1:i2,j1:j2,jm) * tmask(i1:i2,j1:j2,1) 342 jm = jm + 1 343 ENDDO 344 ! 345 ENDDO 346 347 ENDIF ! nbghostcells=1 348 315 349 ! integrated values 316 350 vt_i (i1:i2,j1:j2) = SUM( v_i(i1:i2,j1:j2,:), dim=3 ) … … 319 353 et_s(i1:i2,j1:j2) = SUM( SUM( e_s(i1:i2,j1:j2,:,:), dim=4 ), dim=3 ) 320 354 et_i(i1:i2,j1:j2) = SUM( SUM( e_i(i1:i2,j1:j2,:,:), dim=4 ), dim=3 ) 321 355 322 356 ENDIF 357 358 DEALLOCATE( ztab ) 323 359 324 DEALLOCATE( ztab )325 360 ! 326 361 END SUBROUTINE interp_tra_ice -
branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/NEMO/NST_SRC/agrif_lim3_update.F90
r8877 r8879 56 56 IF( ( MOD( (kt-nit000)/nn_fsbc + 1, Agrif_irhot() * Agrif_Parent(nn_fsbc) / nn_fsbc ) /=0 ) .AND. (kt /= 0) ) RETURN ! do not update if nb of child time steps differ from time refinement 57 57 ! i.e. update only at the parent time step 58 IF( nn_ice == 0 ) RETURN ! clem2017: do not update if child domain does not have ice 59 ! 60 Agrif_SpecialValueFineGrid = -9999. 58 61 Agrif_UseSpecialValueInUpdate = .TRUE. 59 Agrif_SpecialValueFineGrid = -9999.60 62 # if defined TWO_WAY 61 63 IF( MOD(nbcline,nbclineupdate) == 0) THEN ! update the whole basin at each nbclineupdate (=nn_cln_update) baroclinic parent time steps … … 70 72 ENDIF 71 73 # endif 74 Agrif_SpecialValueFineGrid = 0. 72 75 Agrif_UseSpecialValueInUpdate = .FALSE. 73 76 ! … … 88 91 LOGICAL , INTENT(in) :: before 89 92 !! 90 INTEGER :: j k, jl, jm93 INTEGER :: ji, jj, jk, jl, jm 91 94 !!----------------------------------------------------------------------- 92 95 ! it is ok not to multiply by e1*e2 since we conserve tracers here (same as in the ocean). … … 94 97 jm = 1 95 98 DO jl = 1, jpl 96 ptab(:,:,jm) = a_i (i1:i2,j1:j2,jl) ; jm = jm + 1 97 ptab(:,:,jm) = v_i (i1:i2,j1:j2,jl) ; jm = jm + 1 98 ptab(:,:,jm) = v_s (i1:i2,j1:j2,jl) ; jm = jm + 1 99 ptab(:,:,jm) = smv_i(i1:i2,j1:j2,jl) ; jm = jm + 1 100 ptab(:,:,jm) = oa_i (i1:i2,j1:j2,jl) ; jm = jm + 1 99 ptab(i1:i2,j1:j2,jm ) = a_i (i1:i2,j1:j2,jl) 100 ptab(i1:i2,j1:j2,jm+1) = v_i (i1:i2,j1:j2,jl) 101 ptab(i1:i2,j1:j2,jm+2) = v_s (i1:i2,j1:j2,jl) 102 ptab(i1:i2,j1:j2,jm+3) = sv_i(i1:i2,j1:j2,jl) 103 ptab(i1:i2,j1:j2,jm+4) = oa_i (i1:i2,j1:j2,jl) 104 jm = jm + 5 101 105 DO jk = 1, nlay_s 102 ptab( :,:,jm) = e_s(i1:i2,j1:j2,jk,jl) ; jm = jm + 1106 ptab(i1:i2,j1:j2,jm) = e_s(i1:i2,j1:j2,jk,jl) ; jm = jm + 1 103 107 ENDDO 104 108 DO jk = 1, nlay_i 105 ptab( :,:,jm) = e_i(i1:i2,j1:j2,jk,jl) ; jm = jm + 1109 ptab(i1:i2,j1:j2,jm) = e_i(i1:i2,j1:j2,jk,jl) ; jm = jm + 1 106 110 ENDDO 107 111 ENDDO 108 112 ! 109 113 DO jk = k1, k2 110 WHERE( tmask(i1:i2,j1:j2,1) == 0. ) ptab( :,:,jk) = -9999.114 WHERE( tmask(i1:i2,j1:j2,1) == 0. ) ptab(i1:i2,j1:j2,jk) = Agrif_SpecialValueFineGrid 111 115 ENDDO 112 116 ! 113 117 ELSE 118 ! 114 119 jm = 1 115 120 DO jl = 1, jpl 116 a_i (i1:i2,j1:j2,jl) = ptab(:,:,jm) * tmask(i1:i2,j1:j2,1) ; jm = jm + 1 117 v_i (i1:i2,j1:j2,jl) = ptab(:,:,jm) * tmask(i1:i2,j1:j2,1) ; jm = jm + 1 118 v_s (i1:i2,j1:j2,jl) = ptab(:,:,jm) * tmask(i1:i2,j1:j2,1) ; jm = jm + 1 119 smv_i(i1:i2,j1:j2,jl) = ptab(:,:,jm) * tmask(i1:i2,j1:j2,1) ; jm = jm + 1 120 oa_i (i1:i2,j1:j2,jl) = ptab(:,:,jm) * tmask(i1:i2,j1:j2,1) ; jm = jm + 1 121 ! 122 DO jj = j1, j2 123 DO ji = i1, i2 124 IF( ptab(ji,jj,jm) /= Agrif_SpecialValueFineGrid ) THEN 125 a_i (ji,jj,jl) = ptab(ji,jj,jm ) * tmask(ji,jj,1) 126 v_i (ji,jj,jl) = ptab(ji,jj,jm+1) * tmask(ji,jj,1) 127 v_s (ji,jj,jl) = ptab(ji,jj,jm+2) * tmask(ji,jj,1) 128 sv_i(ji,jj,jl) = ptab(ji,jj,jm+3) * tmask(ji,jj,1) 129 oa_i(ji,jj,jl) = ptab(ji,jj,jm+4) * tmask(ji,jj,1) 130 ENDIF 131 ENDDO 132 ENDDO 133 jm = jm + 5 134 ! 121 135 DO jk = 1, nlay_s 122 e_s(i1:i2,j1:j2,jk,jl) = ptab(:,:,jm) * tmask(i1:i2,j1:j2,1) ; jm = jm + 1 123 ENDDO 136 WHERE( ptab(i1:i2,j1:j2,jm) /= Agrif_SpecialValueFineGrid ) 137 e_s(i1:i2,j1:j2,jk,jl) = ptab(i1:i2,j1:j2,jm) * tmask(i1:i2,j1:j2,1) 138 ENDWHERE 139 jm = jm + 1 140 ENDDO 141 ! 124 142 DO jk = 1, nlay_i 125 e_i(i1:i2,j1:j2,jk,jl) = ptab(:,:,jm) * tmask(i1:i2,j1:j2,1) ; jm = jm + 1 126 ENDDO 143 WHERE( ptab(i1:i2,j1:j2,jm) /= Agrif_SpecialValueFineGrid ) 144 e_i(i1:i2,j1:j2,jk,jl) = ptab(i1:i2,j1:j2,jm) * tmask(i1:i2,j1:j2,1) 145 ENDWHERE 146 jm = jm + 1 147 ENDDO 148 ! 127 149 ENDDO 128 150 ! 129 151 ! integrated values 130 152 vt_i (i1:i2,j1:j2) = SUM( v_i(i1:i2,j1:j2,:), dim=3 ) … … 154 176 zrhoy = Agrif_Rhoy() 155 177 ptab(:,:) = e2u(i1:i2,j1:j2) * u_ice(i1:i2,j1:j2) * zrhoy 156 WHERE( umask(i1:i2,j1:j2,1) == 0. ) ptab(:,:) = -9999.178 WHERE( umask(i1:i2,j1:j2,1) == 0. ) ptab(:,:) = Agrif_SpecialValueFineGrid 157 179 ELSE 158 u_ice(i1:i2,j1:j2) = ptab(:,:) / e2u(i1:i2,j1:j2) * umask(i1:i2,j1:j2,1) 180 WHERE( ptab(i1:i2,j1:j2) /= Agrif_SpecialValueFineGrid ) 181 u_ice(i1:i2,j1:j2) = ptab(i1:i2,j1:j2) / e2u(i1:i2,j1:j2) * umask(i1:i2,j1:j2,1) 182 ENDWHERE 159 183 ENDIF 160 184 ! … … 177 201 zrhox = Agrif_Rhox() 178 202 ptab(:,:) = e1v(i1:i2,j1:j2) * v_ice(i1:i2,j1:j2) * zrhox 179 WHERE( vmask(i1:i2,j1:j2,1) == 0. ) ptab(:,:) = -9999.203 WHERE( vmask(i1:i2,j1:j2,1) == 0. ) ptab(:,:) = Agrif_SpecialValueFineGrid 180 204 ELSE 181 v_ice(i1:i2,j1:j2) = ptab(:,:) / e1v(i1:i2,j1:j2) * vmask(i1:i2,j1:j2,1) 205 WHERE( ptab(i1:i2,j1:j2) /= Agrif_SpecialValueFineGrid ) 206 v_ice(i1:i2,j1:j2) = ptab(i1:i2,j1:j2) / e1v(i1:i2,j1:j2) * vmask(i1:i2,j1:j2,1) 207 ENDWHERE 182 208 ENDIF 183 209 ! -
branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/NEMO/NST_SRC/agrif_opa_interp.F90
r8877 r8879 35 35 PUBLIC Agrif_tra, Agrif_dyn, Agrif_ssh, Agrif_dyn_ts, Agrif_ssh_ts, Agrif_dta_ts 36 36 PUBLIC interpun, interpvn 37 PUBLIC interptsn, 37 PUBLIC interptsn, interpsshn 38 38 PUBLIC interpunb, interpvnb, interpub2b, interpvb2b 39 39 PUBLIC interpe3t, interpumsk, interpvmsk … … 100 100 IF( nbondi == +1 .OR. nbondi == 2 ) i2 = nlci-2 101 101 102 ! --- West --- ! 102 103 IF( nbondi == -1 .OR. nbondi == 2 ) THEN 103 104 ! 104 ! Smoothing105 ! ---------106 105 IF( .NOT.ln_dynspg_ts ) THEN ! Store transport 107 ua_b(2 ,:) = 0._wp106 ua_b(2:1+nbghostcells,:) = 0._wp 108 107 DO jk = 1, jpkm1 109 108 DO jj = 1, jpj 110 ua_b(2 ,jj) = ua_b(2,jj) + e3u_a(2,jj,jk) * ua(2,jj,jk)109 ua_b(2:1+nbghostcells,jj) = ua_b(2:1+nbghostcells,jj) + e3u_a(2:1+nbghostcells,jj,jk) * ua(2:1+nbghostcells,jj,jk) 111 110 END DO 112 111 END DO 113 112 DO jj = 1, jpj 114 ua_b(2,jj) = ua_b(2,jj) * r1_hu_a(2,jj) 115 END DO 116 ENDIF 117 ! 118 DO jk=1,jpkm1 ! Smooth 119 DO jj=j1,j2 120 ua(2,jj,jk) = 0.25_wp*(ua(1,jj,jk)+2._wp*ua(2,jj,jk)+ua(3,jj,jk)) 121 ua(2,jj,jk) = ua(2,jj,jk) * umask(2,jj,jk) 122 END DO 123 END DO 124 ! 125 zub(2,:) = 0._wp ! Correct transport 126 DO jk = 1, jpkm1 127 DO jj = 1, jpj 128 zub(2,jj) = zub(2,jj) + e3u_a(2,jj,jk) * ua(2,jj,jk) 129 END DO 130 END DO 131 DO jj=1,jpj 132 zub(2,jj) = zub(2,jj) * r1_hu_a(2,jj) 133 END DO 134 135 DO jk=1,jpkm1 136 DO jj=1,jpj 137 ua(2,jj,jk) = (ua(2,jj,jk)+ua_b(2,jj)-zub(2,jj))*umask(2,jj,jk) 138 END DO 139 END DO 140 141 ! Set tangential velocities to time splitting estimate 142 !----------------------------------------------------- 143 IF( ln_dynspg_ts ) THEN 144 zvb(2,:) = 0._wp 113 ua_b(2:1+nbghostcells,jj) = ua_b(2:1+nbghostcells,jj) * r1_hu_a(2:1+nbghostcells,jj) 114 END DO 115 ENDIF 116 ! 117 ! Smoothing if only 1 ghostcell 118 ! ----------------------------- 119 IF( nbghostcells == 1 ) THEN 120 DO jk=1,jpkm1 ! Smooth 121 DO jj=j1,j2 122 ua(2,jj,jk) = 0.25_wp*(ua(1,jj,jk)+2._wp*ua(2,jj,jk)+ua(3,jj,jk)) 123 ua(2,jj,jk) = ua(2,jj,jk) * umask(2,jj,jk) 124 END DO 125 END DO 126 ! 127 zub(2,:) = 0._wp ! Correct transport 145 128 DO jk = 1, jpkm1 146 129 DO jj = 1, jpj 147 zvb(2,jj) = zvb(2,jj) + e3v_a(2,jj,jk) * va(2,jj,jk) 148 END DO 149 END DO 150 DO jj = 1, jpj 151 zvb(2,jj) = zvb(2,jj) * r1_hv_a(2,jj) 152 END DO 130 zub(2,jj) = zub(2,jj) + e3u_a(2,jj,jk) * ua(2,jj,jk) 131 END DO 132 END DO 133 DO jj=1,jpj 134 zub(2,jj) = zub(2,jj) * r1_hu_a(2,jj) 135 END DO 136 137 DO jk=1,jpkm1 138 DO jj=1,jpj 139 ua(2,jj,jk) = (ua(2,jj,jk)+ua_b(2,jj)-zub(2,jj))*umask(2,jj,jk) 140 END DO 141 END DO 142 143 IF( ln_dynspg_ts ) THEN ! Set tangential velocities to time splitting estimate 144 zvb(2,:) = 0._wp 145 DO jk = 1, jpkm1 146 DO jj = 1, jpj 147 zvb(2,jj) = zvb(2,jj) + e3v_a(2,jj,jk) * va(2,jj,jk) 148 END DO 149 END DO 150 DO jj = 1, jpj 151 zvb(2,jj) = zvb(2,jj) * r1_hv_a(2,jj) 152 END DO 153 DO jk = 1, jpkm1 154 DO jj = 1, jpj 155 va(2,jj,jk) = (va(2,jj,jk)+va_b(2,jj)-zvb(2,jj)) * vmask(2,jj,jk) 156 END DO 157 END DO 158 ENDIF 159 ! 160 ENDIF 161 ! 162 ! Mask domain edges: 163 !------------------- 164 ! DO jk = 1, jpkm1 165 ! DO jj = 1, jpj 166 ! ua(1,jj,jk) = 0._wp 167 ! va(1,jj,jk) = 0._wp 168 ! END DO 169 ! END DO 170 ! 171 ENDIF 172 173 ! --- East --- ! 174 IF( nbondi == 1 .OR. nbondi == 2 ) THEN 175 176 IF( .NOT.ln_dynspg_ts ) THEN ! Store transport 177 ua_b(nlci-nbghostcells-1:nlci-2,:) = 0._wp 178 DO jk=1,jpkm1 179 DO jj=1,jpj 180 ua_b(nlci-nbghostcells-1:nlci-2,jj) = ua_b(nlci-nbghostcells-1:nlci-2,jj) + e3u_a(nlci-nbghostcells-1:nlci-2,jj,jk) & 181 & * ua(nlci-nbghostcells-1:nlci-2,jj,jk) 182 END DO 183 END DO 184 DO jj=1,jpj 185 ua_b(nlci-nbghostcells-1:nlci-2,jj) = ua_b(nlci-nbghostcells-1:nlci-2,jj) * r1_hu_a(nlci-nbghostcells-1:nlci-2,jj) 186 END DO 187 ENDIF 188 ! 189 ! Smoothing if only 1 ghostcell 190 ! ----------------------------- 191 IF( nbghostcells == 1 ) THEN 192 DO jk = 1, jpkm1 ! Smooth 193 DO jj = j1, j2 194 ua(nlci-2,jj,jk) = 0.25_wp * umask(nlci-2,jj,jk) & 195 & * ( ua(nlci-3,jj,jk) + 2._wp*ua(nlci-2,jj,jk) + ua(nlci-1,jj,jk) ) 196 END DO 197 END DO 198 199 zub(nlci-2,:) = 0._wp ! Correct transport 153 200 DO jk = 1, jpkm1 154 201 DO jj = 1, jpj 155 va(2,jj,jk) = (va(2,jj,jk)+va_b(2,jj)-zvb(2,jj)) * vmask(2,jj,jk) 156 END DO 157 END DO 202 zub(nlci-2,jj) = zub(nlci-2,jj) + e3u_a(nlci-2,jj,jk) * ua(nlci-2,jj,jk) 203 END DO 204 END DO 205 DO jj = 1, jpj 206 zub(nlci-2,jj) = zub(nlci-2,jj) * r1_hu_a(nlci-2,jj) 207 END DO 208 209 DO jk = 1, jpkm1 210 DO jj = 1, jpj 211 ua(nlci-2,jj,jk) = ( ua(nlci-2,jj,jk) + ua_b(nlci-2,jj) - zub(nlci-2,jj) ) * umask(nlci-2,jj,jk) 212 END DO 213 END DO 214 ! 215 IF( ln_dynspg_ts ) THEN ! Set tangential velocities to time splitting estimate 216 zvb(nlci-1,:) = 0._wp 217 DO jk = 1, jpkm1 218 DO jj = 1, jpj 219 zvb(nlci-1,jj) = zvb(nlci-1,jj) + e3v_a(nlci-1,jj,jk) * va(nlci-1,jj,jk) 220 END DO 221 END DO 222 DO jj=1,jpj 223 zvb(nlci-1,jj) = zvb(nlci-1,jj) * r1_hv_a(nlci-1,jj) 224 END DO 225 DO jk = 1, jpkm1 226 DO jj = 1, jpj 227 va(nlci-1,jj,jk) = ( va(nlci-1,jj,jk) + va_b(nlci-1,jj) - zvb(nlci-1,jj) ) * vmask(nlci-1,jj,jk) 228 END DO 229 END DO 230 ENDIF 231 ! 158 232 ENDIF 159 233 ! 160 234 ! Mask domain edges: 161 235 !------------------- 162 DO jk = 1, jpkm1 163 DO jj = 1, jpj 164 ua(1,jj,jk) = 0._wp 165 va(1,jj,jk) = 0._wp 166 END DO 167 END DO 168 ! 169 ENDIF 170 171 IF( nbondi == 1 .OR. nbondi == 2 ) THEN 172 173 ! Smoothing 174 ! --------- 236 ! DO jk = 1, jpkm1 237 ! DO jj = 1, jpj 238 ! ua(nlci-1,jj,jk) = 0._wp 239 ! va(nlci ,jj,jk) = 0._wp 240 ! END DO 241 ! END DO 242 ! 243 ENDIF 244 245 ! --- South --- ! 246 IF( nbondj == -1 .OR. nbondj == 2 ) THEN 247 175 248 IF( .NOT.ln_dynspg_ts ) THEN ! Store transport 176 ua_b(nlci-2,:) = 0._wp 249 va_b(:,2:nbghostcells+1) = 0._wp 250 DO jk = 1, jpkm1 251 DO ji = 1, jpi 252 va_b(ji,2:nbghostcells+1) = va_b(ji,2:nbghostcells+1) + e3v_a(ji,2:nbghostcells+1,jk) * va(ji,2:nbghostcells+1,jk) 253 END DO 254 END DO 255 DO ji=1,jpi 256 va_b(ji,2:nbghostcells+1) = va_b(ji,2:nbghostcells+1) * r1_hv_a(ji,2:nbghostcells+1) 257 END DO 258 ENDIF 259 ! 260 ! Smoothing if only 1 ghostcell 261 ! ----------------------------- 262 IF( nbghostcells == 1 ) THEN 263 DO jk = 1, jpkm1 ! Smooth 264 DO ji = i1, i2 265 va(ji,2,jk) = 0.25_wp * vmask(ji,2,jk) & 266 & * ( va(ji,1,jk) + 2._wp*va(ji,2,jk) + va(ji,3,jk) ) 267 END DO 268 END DO 269 ! 270 zvb(:,2) = 0._wp ! Correct transport 177 271 DO jk=1,jpkm1 178 DO jj=1,jpj 179 ua_b(nlci-2,jj) = ua_b(nlci-2,jj) + e3u_a(nlci-2,jj,jk) * ua(nlci-2,jj,jk) 180 END DO 181 END DO 182 DO jj=1,jpj 183 ua_b(nlci-2,jj) = ua_b(nlci-2,jj) * r1_hu_a(nlci-2,jj) 184 END DO 185 ENDIF 186 187 DO jk = 1, jpkm1 ! Smooth 188 DO jj = j1, j2 189 ua(nlci-2,jj,jk) = 0.25_wp * umask(nlci-2,jj,jk) & 190 & * ( ua(nlci-3,jj,jk) + 2._wp*ua(nlci-2,jj,jk) + ua(nlci-1,jj,jk) ) 191 END DO 192 END DO 193 194 zub(nlci-2,:) = 0._wp ! Correct transport 195 DO jk = 1, jpkm1 196 DO jj = 1, jpj 197 zub(nlci-2,jj) = zub(nlci-2,jj) + e3u_a(nlci-2,jj,jk) * ua(nlci-2,jj,jk) 198 END DO 199 END DO 200 DO jj = 1, jpj 201 zub(nlci-2,jj) = zub(nlci-2,jj) * r1_hu_a(nlci-2,jj) 202 END DO 203 204 DO jk = 1, jpkm1 205 DO jj = 1, jpj 206 ua(nlci-2,jj,jk) = ( ua(nlci-2,jj,jk) + ua_b(nlci-2,jj) - zub(nlci-2,jj) ) * umask(nlci-2,jj,jk) 207 END DO 208 END DO 209 ! 210 ! Set tangential velocities to time splitting estimate 211 !----------------------------------------------------- 212 IF( ln_dynspg_ts ) THEN 213 zvb(nlci-1,:) = 0._wp 272 DO ji=1,jpi 273 zvb(ji,2) = zvb(ji,2) + e3v_a(ji,2,jk) * va(ji,2,jk) * vmask(ji,2,jk) 274 END DO 275 END DO 276 DO ji = 1, jpi 277 zvb(ji,2) = zvb(ji,2) * r1_hv_a(ji,2) 278 END DO 214 279 DO jk = 1, jpkm1 215 DO jj = 1, jpj 216 zvb(nlci-1,jj) = zvb(nlci-1,jj) + e3v_a(nlci-1,jj,jk) * va(nlci-1,jj,jk) 217 END DO 218 END DO 219 DO jj=1,jpj 220 zvb(nlci-1,jj) = zvb(nlci-1,jj) * r1_hv_a(nlci-1,jj) 221 END DO 222 DO jk = 1, jpkm1 223 DO jj = 1, jpj 224 va(nlci-1,jj,jk) = ( va(nlci-1,jj,jk) + va_b(nlci-1,jj) - zvb(nlci-1,jj) ) * vmask(nlci-1,jj,jk) 225 END DO 226 END DO 280 DO ji = 1, jpi 281 va(ji,2,jk) = ( va(ji,2,jk) + va_b(ji,2) - zvb(ji,2) ) * vmask(ji,2,jk) 282 END DO 283 END DO 284 285 IF( ln_dynspg_ts ) THEN ! Set tangential velocities to time splitting estimate 286 zub(:,2) = 0._wp 287 DO jk = 1, jpkm1 288 DO ji = 1, jpi 289 zub(ji,2) = zub(ji,2) + e3u_a(ji,2,jk) * ua(ji,2,jk) * umask(ji,2,jk) 290 END DO 291 END DO 292 DO ji = 1, jpi 293 zub(ji,2) = zub(ji,2) * r1_hu_a(ji,2) 294 END DO 295 296 DO jk = 1, jpkm1 297 DO ji = 1, jpi 298 ua(ji,2,jk) = ( ua(ji,2,jk) + ua_b(ji,2) - zub(ji,2) ) * umask(ji,2,jk) 299 END DO 300 END DO 301 ENDIF 302 ! 227 303 ENDIF 228 304 ! 229 305 ! Mask domain edges: 230 306 !------------------- 231 DO jk = 1, jpkm1 232 DO jj = 1, jpj 233 ua(nlci-1,jj,jk) = 0._wp 234 va(nlci ,jj,jk) = 0._wp 235 END DO 236 END DO 237 ! 238 ENDIF 239 240 IF( nbondj == -1 .OR. nbondj == 2 ) THEN 241 242 ! Smoothing 243 ! --------- 307 ! DO jk = 1, jpkm1 308 ! DO ji = 1, jpi 309 ! ua(ji,1,jk) = 0._wp 310 ! va(ji,1,jk) = 0._wp 311 ! END DO 312 ! END DO 313 ! 314 ENDIF 315 316 ! --- North --- ! 317 IF( nbondj == 1 .OR. nbondj == 2 ) THEN 318 ! 244 319 IF( .NOT.ln_dynspg_ts ) THEN ! Store transport 245 va_b(:, 2) = 0._wp320 va_b(:,nlcj-nbghostcells-1:nlcj-2) = 0._wp 246 321 DO jk = 1, jpkm1 247 322 DO ji = 1, jpi 248 va_b(ji,2) = va_b(ji,2) + e3v_a(ji,2,jk) * va(ji,2,jk) 249 END DO 250 END DO 251 DO ji=1,jpi 252 va_b(ji,2) = va_b(ji,2) * r1_hv_a(ji,2) 253 END DO 254 ENDIF 255 ! 256 DO jk = 1, jpkm1 ! Smooth 257 DO ji = i1, i2 258 va(ji,2,jk) = 0.25_wp * vmask(ji,2,jk) & 259 & * ( va(ji,1,jk) + 2._wp*va(ji,2,jk) + va(ji,3,jk) ) 260 END DO 261 END DO 262 ! 263 zvb(:,2) = 0._wp ! Correct transport 264 DO jk=1,jpkm1 265 DO ji=1,jpi 266 zvb(ji,2) = zvb(ji,2) + e3v_a(ji,2,jk) * va(ji,2,jk) * vmask(ji,2,jk) 267 END DO 268 END DO 269 DO ji = 1, jpi 270 zvb(ji,2) = zvb(ji,2) * r1_hv_a(ji,2) 271 END DO 272 DO jk = 1, jpkm1 323 va_b(ji,nlcj-nbghostcells-1:nlcj-2) = va_b(ji,nlcj-nbghostcells-1:nlcj-2) + e3v_a(ji,nlcj-nbghostcells-1:nlcj-2,jk) & 324 & * va(ji,nlcj-nbghostcells-1:nlcj-2,jk) 325 END DO 326 END DO 273 327 DO ji = 1, jpi 274 va(ji,2,jk) = ( va(ji,2,jk) + va_b(ji,2) - zvb(ji,2) ) * vmask(ji,2,jk) 275 END DO 276 END DO 277 278 ! Set tangential velocities to time splitting estimate 279 !----------------------------------------------------- 280 IF( ln_dynspg_ts ) THEN 281 zub(:,2) = 0._wp 328 va_b(ji,nlcj-nbghostcells-1:nlcj-2) = va_b(ji,nlcj-nbghostcells-1:nlcj-2) * r1_hv_a(ji,nlcj-nbghostcells-1:nlcj-2) 329 END DO 330 ENDIF 331 ! 332 ! Smoothing if only 1 ghostcell 333 ! ----------------------------- 334 IF( nbghostcells == 1 ) THEN 335 DO jk = 1, jpkm1 ! Smooth 336 DO ji = i1, i2 337 va(ji,nlcj-2,jk) = 0.25_wp * vmask(ji,nlcj-2,jk) & 338 & * ( va(ji,nlcj-3,jk) + 2._wp * va(ji,nlcj-2,jk) + va(ji,nlcj-1,jk) ) 339 END DO 340 END DO 341 ! 342 zvb(:,nlcj-2) = 0._wp ! Correct transport 282 343 DO jk = 1, jpkm1 283 344 DO ji = 1, jpi 284 z ub(ji,2) = zub(ji,2) + e3u_a(ji,2,jk) * ua(ji,2,jk) * umask(ji,2,jk)345 zvb(ji,nlcj-2) = zvb(ji,nlcj-2) + e3v_a(ji,nlcj-2,jk) * va(ji,nlcj-2,jk) * vmask(ji,nlcj-2,jk) 285 346 END DO 286 347 END DO 287 348 DO ji = 1, jpi 288 zub(ji,2) = zub(ji,2) * r1_hu_a(ji,2) 289 END DO 290 349 zvb(ji,nlcj-2) = zvb(ji,nlcj-2) * r1_hv_a(ji,nlcj-2) 350 END DO 291 351 DO jk = 1, jpkm1 292 352 DO ji = 1, jpi 293 ua(ji,2,jk) = ( ua(ji,2,jk) + ua_b(ji,2) - zub(ji,2) ) * umask(ji,2,jk) 294 END DO 295 END DO 296 ENDIF 297 353 va(ji,nlcj-2,jk) = ( va(ji,nlcj-2,jk) + va_b(ji,nlcj-2) - zvb(ji,nlcj-2) ) * vmask(ji,nlcj-2,jk) 354 END DO 355 END DO 356 ! 357 IF( ln_dynspg_ts ) THEN ! Set tangential velocities to time splitting estimate 358 zub(:,nlcj-1) = 0._wp 359 DO jk = 1, jpkm1 360 DO ji = 1, jpi 361 zub(ji,nlcj-1) = zub(ji,nlcj-1) + e3u_a(ji,nlcj-1,jk) * ua(ji,nlcj-1,jk) * umask(ji,nlcj-1,jk) 362 END DO 363 END DO 364 DO ji = 1, jpi 365 zub(ji,nlcj-1) = zub(ji,nlcj-1) * r1_hu_a(ji,nlcj-1) 366 END DO 367 ! 368 DO jk = 1, jpkm1 369 DO ji = 1, jpi 370 ua(ji,nlcj-1,jk) = ( ua(ji,nlcj-1,jk) + ua_b(ji,nlcj-1) - zub(ji,nlcj-1) ) * umask(ji,nlcj-1,jk) 371 END DO 372 END DO 373 ENDIF 374 ! 375 ENDIF 376 ! 298 377 ! Mask domain edges: 299 378 !------------------- 300 DO jk = 1, jpkm1 301 DO ji = 1, jpi 302 ua(ji,1,jk) = 0._wp 303 va(ji,1,jk) = 0._wp 304 END DO 305 END DO 306 307 ENDIF 308 309 IF( nbondj == 1 .OR. nbondj == 2 ) THEN 310 ! 311 ! Smoothing 312 ! --------- 313 IF( .NOT.ln_dynspg_ts ) THEN ! Store transport 314 va_b(:,nlcj-2) = 0._wp 315 DO jk = 1, jpkm1 316 DO ji = 1, jpi 317 va_b(ji,nlcj-2) = va_b(ji,nlcj-2) + e3v_a(ji,nlcj-2,jk) * va(ji,nlcj-2,jk) 318 END DO 319 END DO 320 DO ji = 1, jpi 321 va_b(ji,nlcj-2) = va_b(ji,nlcj-2) * r1_hv_a(ji,nlcj-2) 322 END DO 323 ENDIF 324 ! 325 DO jk = 1, jpkm1 ! Smooth 326 DO ji = i1, i2 327 va(ji,nlcj-2,jk) = 0.25_wp * vmask(ji,nlcj-2,jk) & 328 & * ( va(ji,nlcj-3,jk) + 2._wp * va(ji,nlcj-2,jk) + va(ji,nlcj-1,jk) ) 329 END DO 330 END DO 331 ! 332 zvb(:,nlcj-2) = 0._wp ! Correct transport 333 DO jk = 1, jpkm1 334 DO ji = 1, jpi 335 zvb(ji,nlcj-2) = zvb(ji,nlcj-2) + e3v_a(ji,nlcj-2,jk) * va(ji,nlcj-2,jk) * vmask(ji,nlcj-2,jk) 336 END DO 337 END DO 338 DO ji = 1, jpi 339 zvb(ji,nlcj-2) = zvb(ji,nlcj-2) * r1_hv_a(ji,nlcj-2) 340 END DO 341 DO jk = 1, jpkm1 342 DO ji = 1, jpi 343 va(ji,nlcj-2,jk) = ( va(ji,nlcj-2,jk) + va_b(ji,nlcj-2) - zvb(ji,nlcj-2) ) * vmask(ji,nlcj-2,jk) 344 END DO 345 END DO 346 ! 347 ! Set tangential velocities to time splitting estimate 348 !----------------------------------------------------- 349 IF( ln_dynspg_ts ) THEN 350 zub(:,nlcj-1) = 0._wp 351 DO jk = 1, jpkm1 352 DO ji = 1, jpi 353 zub(ji,nlcj-1) = zub(ji,nlcj-1) + e3u_a(ji,nlcj-1,jk) * ua(ji,nlcj-1,jk) * umask(ji,nlcj-1,jk) 354 END DO 355 END DO 356 DO ji = 1, jpi 357 zub(ji,nlcj-1) = zub(ji,nlcj-1) * r1_hu_a(ji,nlcj-1) 358 END DO 359 ! 360 DO jk = 1, jpkm1 361 DO ji = 1, jpi 362 ua(ji,nlcj-1,jk) = ( ua(ji,nlcj-1,jk) + ua_b(ji,nlcj-1) - zub(ji,nlcj-1) ) * umask(ji,nlcj-1,jk) 363 END DO 364 END DO 365 ENDIF 366 ! 367 ! Mask domain edges: 368 !------------------- 369 DO jk = 1, jpkm1 370 DO ji = 1, jpi 371 ua(ji,nlcj ,jk) = 0._wp 372 va(ji,nlcj-1,jk) = 0._wp 373 END DO 374 END DO 379 ! DO jk = 1, jpkm1 380 ! DO ji = 1, jpi 381 ! ua(ji,nlcj ,jk) = 0._wp 382 ! va(ji,nlcj-1,jk) = 0._wp 383 ! END DO 384 ! END DO 375 385 ! 376 386 ENDIF … … 392 402 ! 393 403 IF( Agrif_Root() ) RETURN 394 ! 404 !! clem ghost 395 405 IF((nbondi == -1).OR.(nbondi == 2)) THEN 396 406 DO jj=1,jpj 397 va_e(2 ,jj) = vbdy_w(jj) * hvr_e(2,jj)407 va_e(2:nbghostcells+1,jj) = vbdy_w(jj) * hvr_e(2:nbghostcells+1,jj) 398 408 ! Specified fluxes: 399 ua_e(2 ,jj) = ubdy_w(jj) * hur_e(2,jj)400 ! Characteristics method :409 ua_e(2:nbghostcells+1,jj) = ubdy_w(jj) * hur_e(2:nbghostcells+1,jj) 410 ! Characteristics method (only if ghostcells=1): 401 411 !alt ua_e(2,jj) = 0.5_wp * ( ubdy_w(jj) * hur_e(2,jj) + ua_e(3,jj) & 402 412 !alt & - sqrt(grav * hur_e(2,jj)) * (sshn_e(3,jj) - hbdy_w(jj)) ) … … 406 416 IF((nbondi == 1).OR.(nbondi == 2)) THEN 407 417 DO jj=1,jpj 408 va_e(nlci- 1,jj) = vbdy_e(jj) * hvr_e(nlci-1,jj)418 va_e(nlci-nbghostcells:nlci-1,jj) = vbdy_e(jj) * hvr_e(nlci-nbghostcells:nlci-1,jj) 409 419 ! Specified fluxes: 410 ua_e(nlci- 2,jj) = ubdy_e(jj) * hur_e(nlci-2,jj)411 ! Characteristics method :420 ua_e(nlci-nbghostcells-1:nlci-2,jj) = ubdy_e(jj) * hur_e(nlci-nbghostcells-1:nlci-2,jj) 421 ! Characteristics method (only if ghostcells=1): 412 422 !alt ua_e(nlci-2,jj) = 0.5_wp * ( ubdy_e(jj) * hur_e(nlci-2,jj) + ua_e(nlci-3,jj) & 413 423 !alt & + sqrt(grav * hur_e(nlci-2,jj)) * (sshn_e(nlci-2,jj) - hbdy_e(jj)) ) … … 417 427 IF((nbondj == -1).OR.(nbondj == 2)) THEN 418 428 DO ji=1,jpi 419 ua_e(ji,2 ) = ubdy_s(ji) * hur_e(ji,2)429 ua_e(ji,2:nbghostcells+1) = ubdy_s(ji) * hur_e(ji,2:nbghostcells+1) 420 430 ! Specified fluxes: 421 va_e(ji,2 ) = vbdy_s(ji) * hvr_e(ji,2)422 ! Characteristics method :431 va_e(ji,2:nbghostcells+1) = vbdy_s(ji) * hvr_e(ji,2:nbghostcells+1) 432 ! Characteristics method (only if ghostcells=1): 423 433 !alt va_e(ji,2) = 0.5_wp * ( vbdy_s(ji) * hvr_e(ji,2) + va_e(ji,3) & 424 434 !alt & - sqrt(grav * hvr_e(ji,2)) * (sshn_e(ji,3) - hbdy_s(ji)) ) … … 428 438 IF((nbondj == 1).OR.(nbondj == 2)) THEN 429 439 DO ji=1,jpi 430 ua_e(ji,nlcj- 1) = ubdy_n(ji) * hur_e(ji,nlcj-1)440 ua_e(ji,nlcj-nbghostcells:nlcj-1) = ubdy_n(ji) * hur_e(ji,nlcj-nbghostcells:nlcj-1) 431 441 ! Specified fluxes: 432 va_e(ji,nlcj- 2) = vbdy_n(ji) * hvr_e(ji,nlcj-2)433 ! Characteristics method :442 va_e(ji,nlcj-nbghostcells-1:nlcj-2) = vbdy_n(ji) * hvr_e(ji,nlcj-nbghostcells-1:nlcj-2) 443 ! Characteristics method (only if ghostcells=1): 434 444 !alt va_e(ji,nlcj-2) = 0.5_wp * ( vbdy_n(ji) * hvr_e(ji,nlcj-2) + va_e(ji,nlcj-3) & 435 445 !alt & + sqrt(grav * hvr_e(ji,nlcj-2)) * (sshn_e(ji,nlcj-2) - hbdy_n(ji)) ) … … 476 486 ! 477 487 IF( ll_int_cons ) THEN ! Conservative interpolation 478 ! order smatters here !!!!!!488 ! order matters here !!!!!! 479 489 CALL Agrif_Bc_variable( ub2b_interp_id, calledweight=1._wp, procname=interpub2b ) ! Time integrated 480 490 CALL Agrif_Bc_variable( vb2b_interp_id, calledweight=1._wp, procname=interpvb2b ) … … 504 514 !!---------------------------------------------------------------------- 505 515 INTEGER, INTENT(in) :: kt 506 !! 516 ! 517 INTEGER :: ji, jj, indx 507 518 !!---------------------------------------------------------------------- 508 519 ! 509 520 IF( Agrif_Root() ) RETURN 510 ! 521 !! clem ghost 522 ! --- West --- ! 511 523 IF((nbondi == -1).OR.(nbondi == 2)) THEN 512 ssha(2,:)=ssha(3,:) 513 sshn(2,:)=sshn(3,:) 514 ENDIF 515 ! 524 indx = 1+nbghostcells 525 DO jj = 1, jpj 526 DO ji = 2, indx 527 ssha(ji,jj)=ssha(indx+1,jj) 528 sshn(ji,jj)=sshn(indx+1,jj) 529 ENDDO 530 ENDDO 531 ENDIF 532 ! 533 ! --- East --- ! 516 534 IF((nbondi == 1).OR.(nbondi == 2)) THEN 517 ssha(nlci-1,:)=ssha(nlci-2,:) 518 sshn(nlci-1,:)=sshn(nlci-2,:) 519 ENDIF 520 ! 535 indx = nlci-nbghostcells 536 DO jj = 1, jpj 537 DO ji = indx, nlci-1 538 ssha(ji,jj)=ssha(indx-1,jj) 539 sshn(ji,jj)=sshn(indx-1,jj) 540 ENDDO 541 ENDDO 542 ENDIF 543 ! 544 ! --- South --- ! 521 545 IF((nbondj == -1).OR.(nbondj == 2)) THEN 522 ssha(:,2)=ssha(:,3) 523 sshn(:,2)=sshn(:,3) 524 ENDIF 525 ! 546 indx = 1+nbghostcells 547 DO jj = 2, indx 548 DO ji = 1, jpi 549 ssha(ji,jj)=ssha(ji,indx+1) 550 sshn(ji,jj)=sshn(ji,indx+1) 551 ENDDO 552 ENDDO 553 ENDIF 554 ! 555 ! --- North --- ! 526 556 IF((nbondj == 1).OR.(nbondj == 2)) THEN 527 ssha(:,nlcj-1)=ssha(:,nlcj-2) 528 sshn(:,nlcj-1)=sshn(:,nlcj-2) 557 indx = nlcj-nbghostcells 558 DO jj = indx, nlcj-1 559 DO ji = 1, jpi 560 ssha(ji,jj)=ssha(ji,indx-1) 561 sshn(ji,jj)=sshn(ji,indx-1) 562 ENDDO 563 ENDDO 529 564 ENDIF 530 565 ! … … 538 573 INTEGER, INTENT(in) :: jn 539 574 !! 540 INTEGER :: ji, jj541 !!---------------------------------------------------------------------- 542 ! 575 INTEGER :: ji, jj 576 !!---------------------------------------------------------------------- 577 !! clem ghost (starting at i,j=1 is important I think otherwise you introduce a grad(ssh)/=0 at point 2) 543 578 IF((nbondi == -1).OR.(nbondi == 2)) THEN 544 579 DO jj = 1, jpj 545 ssha_e(2 ,jj) = hbdy_w(jj)580 ssha_e(2:nbghostcells+1,jj) = hbdy_w(jj) 546 581 END DO 547 582 ENDIF … … 549 584 IF((nbondi == 1).OR.(nbondi == 2)) THEN 550 585 DO jj = 1, jpj 551 ssha_e(nlci- 1,jj) = hbdy_e(jj)586 ssha_e(nlci-nbghostcells:nlci-1,jj) = hbdy_e(jj) 552 587 END DO 553 588 ENDIF … … 555 590 IF((nbondj == -1).OR.(nbondj == 2)) THEN 556 591 DO ji = 1, jpi 557 ssha_e(ji,2 ) = hbdy_s(ji)592 ssha_e(ji,2:nbghostcells+1) = hbdy_s(ji) 558 593 END DO 559 594 ENDIF … … 561 596 IF((nbondj == 1).OR.(nbondj == 2)) THEN 562 597 DO ji = 1, jpi 563 ssha_e(ji,nlcj- 1) = hbdy_n(ji)598 ssha_e(ji,nlcj-nbghostcells:nlcj-1) = hbdy_n(ji) 564 599 END DO 565 600 ENDIF … … 601 636 INTEGER :: ji, jj, jk, jn ! dummy loop indices 602 637 INTEGER :: imin, imax, jmin, jmax 603 REAL(wp) :: zrhox , zalpha1, zalpha2, zalpha3 604 REAL(wp) :: zalpha4, zalpha5, zalpha6, zalpha7 638 REAL(wp) :: zrhox, z1, z2, z3, z4, z5, z6, z7 605 639 LOGICAL :: western_side, eastern_side,northern_side,southern_side 606 640 !!---------------------------------------------------------------------- … … 610 644 ELSE 611 645 ! 612 western_side = (nb == 1).AND.(ndir == 1) 613 eastern_side = (nb == 1).AND.(ndir == 2) 614 southern_side = (nb == 2).AND.(ndir == 1) 615 northern_side = (nb == 2).AND.(ndir == 2) 616 ! 617 zrhox = Agrif_Rhox() 618 ! 619 zalpha1 = ( zrhox - 1. ) * 0.5 620 zalpha2 = 1. - zalpha1 621 ! 622 zalpha3 = ( zrhox - 1. ) / ( zrhox + 1. ) 623 zalpha4 = 1. - zalpha3 624 ! 625 zalpha6 = 2. * ( zrhox - 1. ) / ( zrhox + 1. ) 626 zalpha7 = - ( zrhox - 1. ) / ( zrhox + 3. ) 627 zalpha5 = 1. - zalpha6 - zalpha7 628 ! 629 imin = i1 630 imax = i2 631 jmin = j1 632 jmax = j2 633 ! 634 ! Remove CORNERS 635 IF((nbondj == -1).OR.(nbondj == 2)) jmin = 3 636 IF((nbondj == +1).OR.(nbondj == 2)) jmax = nlcj-2 637 IF((nbondi == -1).OR.(nbondi == 2)) imin = 3 638 IF((nbondi == +1).OR.(nbondi == 2)) imax = nlci-2 639 ! 640 IF( eastern_side ) THEN 641 DO jn = 1, jpts 642 tsa(nlci,j1:j2,k1:k2,jn) = zalpha1 * ptab(nlci,j1:j2,k1:k2,jn) + zalpha2 * ptab(nlci-1,j1:j2,k1:k2,jn) 643 DO jk = 1, jpkm1 644 DO jj = jmin,jmax 645 IF( umask(nlci-2,jj,jk) == 0._wp ) THEN 646 tsa(nlci-1,jj,jk,jn) = tsa(nlci,jj,jk,jn) * tmask(nlci-1,jj,jk) 647 ELSE 648 tsa(nlci-1,jj,jk,jn)=(zalpha4*tsa(nlci,jj,jk,jn)+zalpha3*tsa(nlci-2,jj,jk,jn))*tmask(nlci-1,jj,jk) 649 IF( un(nlci-2,jj,jk) > 0._wp ) THEN 650 tsa(nlci-1,jj,jk,jn)=( zalpha6*tsa(nlci-2,jj,jk,jn)+zalpha5*tsa(nlci,jj,jk,jn) & 651 + zalpha7*tsa(nlci-3,jj,jk,jn) ) * tmask(nlci-1,jj,jk) 646 western_side = (nb == 1).AND.(ndir == 1) ; eastern_side = (nb == 1).AND.(ndir == 2) 647 southern_side = (nb == 2).AND.(ndir == 1) ; northern_side = (nb == 2).AND.(ndir == 2) 648 ! 649 IF( nbghostcells > 1 ) THEN ! no smoothing 650 tsa(i1:i2,j1:j2,k1:k2,n1:n2) = ptab(i1:i2,j1:j2,k1:k2,n1:n2) 651 ELSE ! smoothing 652 ! 653 zrhox = Agrif_Rhox() 654 z1 = ( zrhox - 1. ) * 0.5 655 z3 = ( zrhox - 1. ) / ( zrhox + 1. ) 656 z6 = 2. * ( zrhox - 1. ) / ( zrhox + 1. ) 657 z7 = - ( zrhox - 1. ) / ( zrhox + 3. ) 658 ! 659 z2 = 1. - z1 660 z4 = 1. - z3 661 z5 = 1. - z6 - z7 662 ! 663 imin = i1 ; imax = i2 664 jmin = j1 ; jmax = j2 665 ! 666 ! Remove CORNERS 667 IF((nbondj == -1).OR.(nbondj == 2)) jmin = 3 668 IF((nbondj == +1).OR.(nbondj == 2)) jmax = nlcj-2 669 IF((nbondi == -1).OR.(nbondi == 2)) imin = 3 670 IF((nbondi == +1).OR.(nbondi == 2)) imax = nlci-2 671 ! 672 IF( eastern_side ) THEN 673 DO jn = 1, jpts 674 tsa(nlci,j1:j2,k1:k2,jn) = z1 * ptab(nlci,j1:j2,k1:k2,jn) + z2 * ptab(nlci-1,j1:j2,k1:k2,jn) 675 DO jk = 1, jpkm1 676 DO jj = jmin,jmax 677 IF( umask(nlci-2,jj,jk) == 0._wp ) THEN 678 tsa(nlci-1,jj,jk,jn) = tsa(nlci,jj,jk,jn) * tmask(nlci-1,jj,jk) 679 ELSE 680 tsa(nlci-1,jj,jk,jn)=(z4*tsa(nlci,jj,jk,jn)+z3*tsa(nlci-2,jj,jk,jn))*tmask(nlci-1,jj,jk) 681 IF( un(nlci-2,jj,jk) > 0._wp ) THEN 682 tsa(nlci-1,jj,jk,jn)=( z6*tsa(nlci-2,jj,jk,jn)+z5*tsa(nlci,jj,jk,jn) & 683 + z7*tsa(nlci-3,jj,jk,jn) ) * tmask(nlci-1,jj,jk) 684 ENDIF 652 685 ENDIF 653 END IF686 END DO 654 687 END DO 655 END DO656 tsa(nlci,j1:j2,k1:k2,jn) = 0._wp657 END DO658 ENDIF659 !660 IF( northern_side ) THEN661 DO jn = 1, jpts662 tsa(i1:i2,nlcj,k1:k2,jn) = zalpha1 * ptab(i1:i2,nlcj,k1:k2,jn) + zalpha2 * ptab(i1:i2,nlcj-1,k1:k2,jn)663 DO jk = 1, jpkm1664 DO ji = imin,imax665 IF( vmask(ji,nlcj-2,jk) == 0._wp ) THEN666 tsa(ji,nlcj-1,jk,jn) = tsa(ji,nlcj,jk,jn) * tmask(ji,nlcj-1,jk)667 ELSE668 tsa(ji,nlcj-1,jk,jn)=(zalpha4*tsa(ji,nlcj,jk,jn)+zalpha3*tsa(ji,nlcj-2,jk,jn))*tmask(ji,nlcj-1,jk)669 IF (vn(ji,nlcj-2,jk) > 0._wp ) THEN670 tsa(ji,nlcj-1,jk,jn)=( zalpha6*tsa(ji,nlcj-2,jk,jn)+zalpha5*tsa(ji,nlcj,jk,jn) &671 + zalpha7*tsa(ji,nlcj-3,jk,jn) ) * tmask(ji,nlcj-1,jk)688 tsa(nlci,j1:j2,k1:k2,jn) = 0._wp 689 END DO 690 ENDIF 691 ! 692 IF( northern_side ) THEN 693 DO jn = 1, jpts 694 tsa(i1:i2,nlcj,k1:k2,jn) = z1 * ptab(i1:i2,nlcj,k1:k2,jn) + z2 * 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._wp ) 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)=(z4*tsa(ji,nlcj,jk,jn)+z3*tsa(ji,nlcj-2,jk,jn))*tmask(ji,nlcj-1,jk) 701 IF (vn(ji,nlcj-2,jk) > 0._wp ) THEN 702 tsa(ji,nlcj-1,jk,jn)=( z6*tsa(ji,nlcj-2,jk,jn)+z5*tsa(ji,nlcj,jk,jn) & 703 + z7*tsa(ji,nlcj-3,jk,jn) ) * tmask(ji,nlcj-1,jk) 704 ENDIF 672 705 ENDIF 673 END IF706 END DO 674 707 END DO 675 END DO676 tsa(i1:i2,nlcj,k1:k2,jn) = 0._wp677 END DO678 ENDIF679 !680 IF( western_side ) THEN681 DO jn = 1, jpts682 tsa(1,j1:j2,k1:k2,jn) = zalpha1 * ptab(1,j1:j2,k1:k2,jn) + zalpha2 * ptab(2,j1:j2,k1:k2,jn)683 DO jk = 1, jpkm1684 DO jj = jmin,jmax685 IF( umask(2,jj,jk) == 0._wp ) THEN686 tsa(2,jj,jk,jn) = tsa(1,jj,jk,jn) * tmask(2,jj,jk)687 ELSE688 tsa(2,jj,jk,jn)=(zalpha4*tsa(1,jj,jk,jn)+zalpha3*tsa(3,jj,jk,jn))*tmask(2,jj,jk)689 IF( un(2,jj,jk) < 0._wp ) THEN690 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)708 tsa(i1:i2,nlcj,k1:k2,jn) = 0._wp 709 END DO 710 ENDIF 711 ! 712 IF( western_side ) THEN 713 DO jn = 1, jpts 714 tsa(1,j1:j2,k1:k2,jn) = z1 * ptab(1,j1:j2,k1:k2,jn) + z2 * ptab(2,j1:j2,k1:k2,jn) 715 DO jk = 1, jpkm1 716 DO jj = jmin,jmax 717 IF( umask(2,jj,jk) == 0._wp ) THEN 718 tsa(2,jj,jk,jn) = tsa(1,jj,jk,jn) * tmask(2,jj,jk) 719 ELSE 720 tsa(2,jj,jk,jn)=(z4*tsa(1,jj,jk,jn)+z3*tsa(3,jj,jk,jn))*tmask(2,jj,jk) 721 IF( un(2,jj,jk) < 0._wp ) THEN 722 tsa(2,jj,jk,jn)=(z6*tsa(3,jj,jk,jn)+z5*tsa(1,jj,jk,jn)+z7*tsa(4,jj,jk,jn))*tmask(2,jj,jk) 723 ENDIF 691 724 ENDIF 692 END IF725 END DO 693 726 END DO 694 END DO695 tsa(1,j1:j2,k1:k2,jn) = 0._wp696 END DO697 ENDIF698 !699 IF( southern_side ) THEN700 DO jn = 1, jpts701 tsa(i1:i2,1,k1:k2,jn) = zalpha1 * ptab(i1:i2,1,k1:k2,jn) + zalpha2 * ptab(i1:i2,2,k1:k2,jn)702 DO jk = 1, jpk703 DO ji=imin,imax704 IF( vmask(ji,2,jk) == 0._wp ) THEN705 tsa(ji,2,jk,jn)=tsa(ji,1,jk,jn) * tmask(ji,2,jk)706 ELSE707 tsa(ji,2,jk,jn)=(zalpha4*tsa(ji,1,jk,jn)+zalpha3*tsa(ji,3,jk,jn))*tmask(ji,2,jk)708 IF( vn(ji,2,jk) < 0._wp ) THEN709 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)727 tsa(1,j1:j2,k1:k2,jn) = 0._wp 728 END DO 729 ENDIF 730 ! 731 IF( southern_side ) THEN 732 DO jn = 1, jpts 733 tsa(i1:i2,1,k1:k2,jn) = z1 * ptab(i1:i2,1,k1:k2,jn) + z2 * ptab(i1:i2,2,k1:k2,jn) 734 DO jk = 1, jpk 735 DO ji=imin,imax 736 IF( vmask(ji,2,jk) == 0._wp ) THEN 737 tsa(ji,2,jk,jn)=tsa(ji,1,jk,jn) * tmask(ji,2,jk) 738 ELSE 739 tsa(ji,2,jk,jn)=(z4*tsa(ji,1,jk,jn)+z3*tsa(ji,3,jk,jn))*tmask(ji,2,jk) 740 IF( vn(ji,2,jk) < 0._wp ) THEN 741 tsa(ji,2,jk,jn)=(z6*tsa(ji,3,jk,jn)+z5*tsa(ji,1,jk,jn)+z7*tsa(ji,4,jk,jn))*tmask(ji,2,jk) 742 ENDIF 710 743 ENDIF 711 END IF744 END DO 712 745 END DO 713 END DO 714 tsa(i1:i2,1,k1:k2,jn) = 0._wp 715 END DO 716 ENDIF 717 ! 718 ! Treatment of corners 719 ! 720 ! East south 721 IF ((eastern_side).AND.((nbondj == -1).OR.(nbondj == 2))) THEN 722 tsa(nlci-1,2,:,:) = ptab(nlci-1,2,:,:) 723 ENDIF 724 ! East north 725 IF ((eastern_side).AND.((nbondj == 1).OR.(nbondj == 2))) THEN 726 tsa(nlci-1,nlcj-1,:,:) = ptab(nlci-1,nlcj-1,:,:) 727 ENDIF 728 ! West south 729 IF ((western_side).AND.((nbondj == -1).OR.(nbondj == 2))) THEN 730 tsa(2,2,:,:) = ptab(2,2,:,:) 731 ENDIF 732 ! West north 733 IF ((western_side).AND.((nbondj == 1).OR.(nbondj == 2))) THEN 734 tsa(2,nlcj-1,:,:) = ptab(2,nlcj-1,:,:) 735 ENDIF 736 ! 746 tsa(i1:i2,1,k1:k2,jn) = 0._wp 747 END DO 748 ENDIF 749 ! 750 ! Treatment of corners 751 IF ((eastern_side).AND.((nbondj == -1).OR.(nbondj == 2))) tsa(nlci-1,2,:,:) = ptab(nlci-1,2,:,:) ! East south 752 IF ((eastern_side).AND.((nbondj == 1).OR.(nbondj == 2))) tsa(nlci-1,nlcj-1,:,:) = ptab(nlci-1,nlcj-1,:,:) ! East north 753 IF ((western_side).AND.((nbondj == -1).OR.(nbondj == 2))) tsa(2,2,:,:) = ptab(2,2,:,:) ! West south 754 IF ((western_side).AND.((nbondj == 1).OR.(nbondj == 2))) tsa(2,nlcj-1,:,:) = ptab(2,nlcj-1,:,:) ! West north 755 ! 756 ENDIF 737 757 ENDIF 738 758 ! … … 759 779 southern_side = (nb == 2).AND.(ndir == 1) 760 780 northern_side = (nb == 2).AND.(ndir == 2) 761 IF(western_side) hbdy_w(j1:j2) = ptab(i1,j1:j2) * tmask(i1,j1:j2,1) 762 IF(eastern_side) hbdy_e(j1:j2) = ptab(i1,j1:j2) * tmask(i1,j1:j2,1) 763 IF(southern_side) hbdy_s(i1:i2) = ptab(i1:i2,j1) * tmask(i1:i2,j1,1) 781 !! clem ghost 782 IF(western_side) hbdy_w(j1:j2) = ptab(i2,j1:j2) * tmask(i2,j1:j2,1) 783 IF(eastern_side) hbdy_e(j1:j2) = ptab(i1,j1:j2) * tmask(i1,j1:j2,1) !clem previously i1 784 IF(southern_side) hbdy_s(i1:i2) = ptab(i1:i2,j2) * tmask(i1:i2,j2,1) !clem previously j1 764 785 IF(northern_side) hbdy_n(i1:i2) = ptab(i1:i2,j1) * tmask(i1:i2,j1,1) 765 786 ENDIF … … 854 875 ELSEIF( bdy_tinterp == 2 ) THEN 855 876 ztcoeff = zrhot * ( zt1 * ( zt1 - 1._wp)**2._wp & 856 & - zt0 * ( zt0 - 1._wp)**2._wp ) 857 877 & - zt0 * ( zt0 - 1._wp)**2._wp ) 858 878 ELSE 859 879 ztcoeff = 1 860 880 ENDIF 861 ! 862 IF(western_side) THEN 863 ubdy_w(j1:j2) = ubdy_w(j1:j2) + ztcoeff * ptab(i1,j1:j2) 864 ENDIF 865 IF(eastern_side) THEN 866 ubdy_e(j1:j2) = ubdy_e(j1:j2) + ztcoeff * ptab(i1,j1:j2) 867 ENDIF 868 IF(southern_side) THEN 869 ubdy_s(i1:i2) = ubdy_s(i1:i2) + ztcoeff * ptab(i1:i2,j1) 870 ENDIF 871 IF(northern_side) THEN 872 ubdy_n(i1:i2) = ubdy_n(i1:i2) + ztcoeff * ptab(i1:i2,j1) 873 ENDIF 881 !! clem ghost 882 IF(western_side) ubdy_w(j1:j2) = ubdy_w(j1:j2) + ztcoeff * ptab(i2,j1:j2) 883 IF(eastern_side) ubdy_e(j1:j2) = ubdy_e(j1:j2) + ztcoeff * ptab(i1,j1:j2) !clem previously i1 884 IF(southern_side) ubdy_s(i1:i2) = ubdy_s(i1:i2) + ztcoeff * ptab(i1:i2,j2) !clem previously j1 885 IF(northern_side) ubdy_n(i1:i2) = ubdy_n(i1:i2) + ztcoeff * ptab(i1:i2,j1) 874 886 ! 875 887 IF( bdy_tinterp == 0 .OR. bdy_tinterp == 2) THEN 876 IF(western_side) THEN 877 ubdy_w(j1:j2) = ubdy_w(j1:j2) / (zrhoy*e2u(i1,j1:j2)) * umask(i1,j1:j2,1) 878 ENDIF 879 IF(eastern_side) THEN 880 ubdy_e(j1:j2) = ubdy_e(j1:j2) / (zrhoy*e2u(i1,j1:j2)) * umask(i1,j1:j2,1) 881 ENDIF 882 IF(southern_side) THEN 883 ubdy_s(i1:i2) = ubdy_s(i1:i2) / (zrhoy*e2u(i1:i2,j1)) * umask(i1:i2,j1,1) 884 ENDIF 885 IF(northern_side) THEN 886 ubdy_n(i1:i2) = ubdy_n(i1:i2) / (zrhoy*e2u(i1:i2,j1)) * umask(i1:i2,j1,1) 887 ENDIF 888 IF(western_side) ubdy_w(j1:j2) = ubdy_w(j1:j2) / (zrhoy*e2u(i2,j1:j2)) * umask(i2,j1:j2,1) 889 IF(eastern_side) ubdy_e(j1:j2) = ubdy_e(j1:j2) / (zrhoy*e2u(i1,j1:j2)) * umask(i1,j1:j2,1) 890 IF(southern_side) ubdy_s(i1:i2) = ubdy_s(i1:i2) / (zrhoy*e2u(i1:i2,j2)) * umask(i1:i2,j2,1) 891 IF(northern_side) ubdy_n(i1:i2) = ubdy_n(i1:i2) / (zrhoy*e2u(i1:i2,j1)) * umask(i1:i2,j1,1) 888 892 ENDIF 889 893 ENDIF … … 927 931 ztcoeff = 1 928 932 ENDIF 929 ! 930 IF(western_side) THEN 931 vbdy_w(j1:j2) = vbdy_w(j1:j2) + ztcoeff * ptab(i1,j1:j2) 932 ENDIF 933 IF(eastern_side) THEN 934 vbdy_e(j1:j2) = vbdy_e(j1:j2) + ztcoeff * ptab(i1,j1:j2) 935 ENDIF 936 IF(southern_side) THEN 937 vbdy_s(i1:i2) = vbdy_s(i1:i2) + ztcoeff * ptab(i1:i2,j1) 938 ENDIF 939 IF(northern_side) THEN 940 vbdy_n(i1:i2) = vbdy_n(i1:i2) + ztcoeff * ptab(i1:i2,j1) 941 ENDIF 933 !! clem ghost 934 IF(western_side) vbdy_w(j1:j2) = vbdy_w(j1:j2) + ztcoeff * ptab(i2,j1:j2) 935 IF(eastern_side) vbdy_e(j1:j2) = vbdy_e(j1:j2) + ztcoeff * ptab(i1,j1:j2) !clem previously i1 936 IF(southern_side) vbdy_s(i1:i2) = vbdy_s(i1:i2) + ztcoeff * ptab(i1:i2,j2) !clem previously j1 937 IF(northern_side) vbdy_n(i1:i2) = vbdy_n(i1:i2) + ztcoeff * ptab(i1:i2,j1) 942 938 ! 943 939 IF( bdy_tinterp == 0 .OR. bdy_tinterp == 2) THEN 944 IF(western_side) THEN 945 vbdy_w(j1:j2) = vbdy_w(j1:j2) / (zrhox*e1v(i1,j1:j2)) & 946 & * vmask(i1,j1:j2,1) 947 ENDIF 948 IF(eastern_side) THEN 949 vbdy_e(j1:j2) = vbdy_e(j1:j2) / (zrhox*e1v(i1,j1:j2)) & 950 & * vmask(i1,j1:j2,1) 951 ENDIF 952 IF(southern_side) THEN 953 vbdy_s(i1:i2) = vbdy_s(i1:i2) / (zrhox*e1v(i1:i2,j1)) & 954 & * vmask(i1:i2,j1,1) 955 ENDIF 956 IF(northern_side) THEN 957 vbdy_n(i1:i2) = vbdy_n(i1:i2) / (zrhox*e1v(i1:i2,j1)) & 958 & * vmask(i1:i2,j1,1) 959 ENDIF 940 IF(western_side) vbdy_w(j1:j2) = vbdy_w(j1:j2) / (zrhox*e1v(i2,j1:j2)) * vmask(i2,j1:j2,1) 941 IF(eastern_side) vbdy_e(j1:j2) = vbdy_e(j1:j2) / (zrhox*e1v(i1,j1:j2)) * vmask(i1,j1:j2,1) 942 IF(southern_side) vbdy_s(i1:i2) = vbdy_s(i1:i2) / (zrhox*e1v(i1:i2,j2)) * vmask(i1:i2,j2,1) 943 IF(northern_side) vbdy_n(i1:i2) = vbdy_n(i1:i2) / (zrhox*e1v(i1:i2,j1)) * vmask(i1:i2,j1,1) 960 944 ENDIF 961 945 ENDIF … … 991 975 zat = zrhot * ( zt1**2._wp * (-2._wp*zt1 + 3._wp) & 992 976 & - zt0**2._wp * (-2._wp*zt0 + 3._wp) ) 993 ! 994 IF(western_side ) ubdy_w(j1:j2) = zat * ptab(i 1,j1:j2)995 IF(eastern_side ) ubdy_e(j1:j2) = zat * ptab(i1,j1:j2) 996 IF(southern_side) ubdy_s(i1:i2) = zat * ptab(i1:i2,j 1)977 !! clem ghost 978 IF(western_side ) ubdy_w(j1:j2) = zat * ptab(i2,j1:j2) 979 IF(eastern_side ) ubdy_e(j1:j2) = zat * ptab(i1,j1:j2) !clem previously i1 980 IF(southern_side) ubdy_s(i1:i2) = zat * ptab(i1:i2,j2) !clem previously j1 997 981 IF(northern_side) ubdy_n(i1:i2) = zat * ptab(i1:i2,j1) 998 982 ENDIF … … 1030 1014 & - zt0**2._wp * (-2._wp*zt0 + 3._wp) ) 1031 1015 ! 1032 IF(western_side ) vbdy_w(j1:j2) = zat * ptab(i 1,j1:j2)1033 IF(eastern_side ) vbdy_e(j1:j2) = zat * ptab(i1,j1:j2) 1034 IF(southern_side) vbdy_s(i1:i2) = zat * ptab(i1:i2,j 1)1016 IF(western_side ) vbdy_w(j1:j2) = zat * ptab(i2,j1:j2) 1017 IF(eastern_side ) vbdy_e(j1:j2) = zat * ptab(i1,j1:j2) !clem previously i1 1018 IF(southern_side) vbdy_s(i1:i2) = zat * ptab(i1:i2,j2) !clem previously j1 1035 1019 IF(northern_side) vbdy_n(i1:i2) = zat * ptab(i1:i2,j1) 1036 1020 ENDIF … … 1050 1034 INTEGER :: ji, jj, jk 1051 1035 LOGICAL :: western_side, eastern_side, northern_side, southern_side 1052 REAL(wp) :: ztmpmsk1053 1036 !!---------------------------------------------------------------------- 1054 1037 ! … … 1060 1043 southern_side = (nb == 2).AND.(ndir == 1) 1061 1044 northern_side = (nb == 2).AND.(ndir == 2) 1062 1045 ! 1063 1046 DO jk = k1, k2 1064 1047 DO jj = j1, j2 1065 1048 DO ji = i1, i2 1066 ! Get velocity mask at boundary edge points:1067 IF( western_side ) ztmpmsk = umask(ji ,jj ,1)1068 IF( eastern_side ) ztmpmsk = umask(nlci-2,jj ,1)1069 IF( northern_side) ztmpmsk = vmask(ji ,nlcj-2,1)1070 IF( southern_side) ztmpmsk = vmask(ji ,2 ,1)1071 1049 ! 1072 IF( ABS( ptab(ji,jj,jk) - tmask(ji,jj,jk) * e3t_0(ji,jj,jk) ) *ztmpmsk> 1.D-2) THEN1050 IF( ABS( ptab(ji,jj,jk) - tmask(ji,jj,jk) * e3t_0(ji,jj,jk) ) > 1.D-2) THEN 1073 1051 IF (western_side) THEN 1074 1052 WRITE(numout,*) 'ERROR bathymetry merge at the western border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk -
branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/NEMO/NST_SRC/agrif_opa_sponge.F90
r8877 r8879 34 34 !! *** ROUTINE Agrif_Sponge_Tra *** 35 35 !!--------------------------------------------- 36 REAL(wp) :: timecoeff36 REAL(wp) :: zcoef 37 37 !!--------------------------------------------- 38 38 ! 39 39 #if defined SPONGE 40 timecoeff = REAL(Agrif_NbStepint(),wp)/Agrif_rhot()40 zcoef = REAL(Agrif_NbStepint(),wp)/Agrif_rhot() 41 41 42 42 CALL Agrif_Sponge … … 45 45 tabspongedone_tsn = .FALSE. 46 46 47 CALL Agrif_Bc_Variable(tsn_sponge_id,calledweight= timecoeff,procname=interptsn_sponge)47 CALL Agrif_Bc_Variable(tsn_sponge_id,calledweight=zcoef,procname=interptsn_sponge) 48 48 49 49 Agrif_UseSpecialValue = .FALSE. … … 57 57 !! *** ROUTINE Agrif_Sponge_dyn *** 58 58 !!--------------------------------------------- 59 REAL(wp) :: timecoeff59 REAL(wp) :: zcoef 60 60 !!--------------------------------------------- 61 61 62 62 #if defined SPONGE 63 timecoeff = REAL(Agrif_NbStepint(),wp)/Agrif_rhot()63 zcoef = REAL(Agrif_NbStepint(),wp)/Agrif_rhot() 64 64 65 65 Agrif_SpecialValue=0. … … 68 68 tabspongedone_u = .FALSE. 69 69 tabspongedone_v = .FALSE. 70 CALL Agrif_Bc_Variable(un_sponge_id,calledweight= timecoeff,procname=interpun_sponge)70 CALL Agrif_Bc_Variable(un_sponge_id,calledweight=zcoef,procname=interpun_sponge) 71 71 72 72 tabspongedone_u = .FALSE. 73 73 tabspongedone_v = .FALSE. 74 CALL Agrif_Bc_Variable(vn_sponge_id,calledweight= timecoeff,procname=interpvn_sponge)74 CALL Agrif_Bc_Variable(vn_sponge_id,calledweight=zcoef,procname=interpvn_sponge) 75 75 76 76 Agrif_UseSpecialValue = .FALSE. … … 84 84 !! *** ROUTINE Agrif_Sponge *** 85 85 !!--------------------------------------------- 86 INTEGER :: ji,jj,jk 87 INTEGER :: ispongearea, ilci, ilcj 88 LOGICAL :: ll_spdone 89 REAL(wp) :: z1spongearea, zramp 90 REAL(wp), POINTER, DIMENSION(:,:) :: ztabramp 86 REAL(wp), DIMENSION(jpi,jpj) :: ztabramp 87 ! 88 INTEGER :: ji, jj, ind1, ind2 89 INTEGER :: ispongearea 90 REAL(wp) :: z1_spongearea 91 !!--------------------------------------------- 91 92 92 93 #if defined SPONGE || defined SPONGE_TOP 93 ll_spdone=.TRUE.94 94 IF (( .NOT. spongedoneT ).OR.( .NOT. spongedoneU )) THEN 95 ! Define ramp from boundaries towards domain interior 96 ! at T-points 95 ! Define ramp from boundaries towards domain interior at T-points 97 96 ! Store it in ztabramp 98 ll_spdone=.FALSE.99 100 CALL wrk_alloc( jpi, jpj, ztabramp )101 97 102 98 ispongearea = 2 + nn_sponge_len * Agrif_irhox() 103 ilci = nlci - ispongearea 104 ilcj = nlcj - ispongearea 105 z1spongearea = 1._wp / REAL( ispongearea - 2 ) 106 99 z1_spongearea = 1._wp / REAL( ispongearea - 1 ) 100 107 101 ztabramp(:,:) = 0._wp 108 102 103 ! --- West --- ! 109 104 IF( (nbondi == -1) .OR. (nbondi == 2) ) THEN 105 ind1 = 1+nbghostcells 106 ind2 = 1+nbghostcells + (ispongearea-1) 110 107 DO jj = 1, jpj 111 IF ( umask(2,jj,1) == 1._wp ) THEN 112 DO ji = 2, ispongearea 113 ztabramp(ji,jj) = ( ispongearea-ji ) * z1spongearea 114 END DO 115 ENDIF 108 DO ji = ind1, ind2 109 ztabramp(ji,jj) = REAL( ind2 - ji ) * z1_spongearea * umask(ind1,jj,1) 110 END DO 116 111 ENDDO 117 112 ENDIF 118 113 114 ! --- East --- ! 119 115 IF( (nbondi == 1) .OR. (nbondi == 2) ) THEN 116 ind1 = nlci - (1+nbghostcells) - (ispongearea-1) 117 ind2 = nlci - (1+nbghostcells) 120 118 DO jj = 1, jpj 121 IF ( umask(nlci-2,jj,1) == 1._wp ) THEN 122 DO ji = ilci+1,nlci-1 123 zramp = (ji - (ilci+1) ) * z1spongearea 124 ztabramp(ji,jj) = MAX( ztabramp(ji,jj), zramp ) 125 ENDDO 126 ENDIF 119 DO ji = ind1, ind2 120 ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL( ji - ind2 ) * z1_spongearea * umask(ind2-1,jj,1) ) 121 ENDDO 127 122 ENDDO 128 123 ENDIF 129 124 125 ! --- South --- ! 130 126 IF( (nbondj == -1) .OR. (nbondj == 2) ) THEN 131 DO ji = 1, jpi 132 IF ( vmask(ji,2,1) == 1._wp ) THEN 133 DO jj = 2, ispongearea 134 zramp = ( ispongearea-jj ) * z1spongearea 135 ztabramp(ji,jj) = MAX( ztabramp(ji,jj), zramp ) 136 END DO 137 ENDIF 127 ind1 = 1+nbghostcells 128 ind2 = 1+nbghostcells + (ispongearea-1) 129 DO jj = ind1, ind2 130 DO ji = 1, jpi 131 ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL( ind2 - jj ) * z1_spongearea * vmask(ji,ind1,1) ) 132 END DO 138 133 ENDDO 139 134 ENDIF 140 135 136 ! --- North --- ! 141 137 IF( (nbondj == 1) .OR. (nbondj == 2) ) THEN 142 DO ji = 1, jpi 143 IF ( vmask(ji,nlcj-2,1) == 1._wp ) THEN 144 DO jj = ilcj+1,nlcj-1 145 zramp = (jj - (ilcj+1) ) * z1spongearea 146 ztabramp(ji,jj) = MAX( ztabramp(ji,jj), zramp ) 147 END DO 148 ENDIF 138 ind1 = nlcj - (1+nbghostcells) - (ispongearea-1) 139 ind2 = nlcj - (1+nbghostcells) 140 DO jj = ind1, ind2 141 DO ji = 1, jpi 142 ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL( jj - ind2 ) * z1_spongearea * vmask(ji,ind2-1,1) ) 143 END DO 149 144 ENDDO 150 145 ENDIF … … 158 153 DO jj = 2, jpjm1 159 154 DO ji = 2, jpim1 ! vector opt. 160 fsaht_spu(ji,jj) = 0.5_wp * visc_tra * (ztabramp(ji,jj) + ztabramp(ji+1,jj )) 161 fsaht_spv(ji,jj) = 0.5_wp * visc_tra * (ztabramp(ji,jj) + ztabramp(ji ,jj+1)) 162 END DO 163 END DO 164 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 165 159 CALL lbc_lnk( fsaht_spu, 'U', 1. ) ! Lateral boundary conditions 166 160 CALL lbc_lnk( fsaht_spv, 'V', 1. ) 161 167 162 spongedoneT = .TRUE. 168 163 ENDIF … … 179 174 END DO 180 175 END DO 181 182 176 CALL lbc_lnk( fsahm_spt, 'T', 1. ) ! Lateral boundary conditions 183 177 CALL lbc_lnk( fsahm_spf, 'F', 1. ) 178 184 179 spongedoneU = .TRUE. 185 180 ENDIF 186 !187 IF (.NOT.ll_spdone) CALL wrk_dealloc( jpi, jpj, ztabramp )188 181 ! 189 182 #endif … … 205 198 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2) :: ztu, ztv 206 199 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2) ::tsbdiff 200 !!--------------------------------------------- 207 201 ! 208 202 IF( before ) THEN … … 327 321 328 322 jmax = j2-1 329 IF ((nbondj == 1).OR.(nbondj == 2)) jmax = MIN(jmax,nlcj- 3)323 IF ((nbondj == 1).OR.(nbondj == 2)) jmax = MIN(jmax,nlcj-nbghostcells-2) ! North 330 324 331 325 DO jj = j1+1, jmax … … 404 398 405 399 imax = i2-1 406 IF ((nbondi == 1).OR.(nbondi == 2)) imax = MIN(imax,nlci- 3)400 IF ((nbondi == 1).OR.(nbondi == 2)) imax = MIN(imax,nlci-nbghostcells-2) ! East 407 401 408 402 DO jj = j1+1, j2 -
branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/NEMO/NST_SRC/agrif_top_interp.F90
r8877 r8879 50 50 ! 51 51 INTEGER :: ji, jj, jk, jn ! dummy loop indices 52 INTEGER ::imin, imax, jmin, jmax53 REAL(wp) :: zrhox , zalpha1, zalpha2, zalpha354 REAL(wp) :: zalpha4, zalpha5, zalpha6, zalpha755 LOGICAL :: western_side, eastern_side,northern_side,southern_side56 52 INTEGER :: imin, imax, jmin, jmax 53 REAL(wp) :: zrhox, z1, z2, z3, z4, z5, z6, z7 54 LOGICAL :: western_side, eastern_side,northern_side,southern_side 55 !!----------------------------------------------------------------------- 56 ! 57 57 IF (before) THEN 58 58 ptab(i1:i2,j1:j2,k1:k2,n1:n2) = trn(i1:i2,j1:j2,k1:k2,n1:n2) 59 59 ELSE 60 60 ! 61 western_side = (nb == 1).AND.(ndir == 1) 62 eastern_side = (nb == 1).AND.(ndir == 2) 63 southern_side = (nb == 2).AND.(ndir == 1) 64 northern_side = (nb == 2).AND.(ndir == 2) 65 ! 66 zrhox = Agrif_Rhox() 67 ! 68 zalpha1 = ( zrhox - 1. ) * 0.5 69 zalpha2 = 1. - zalpha1 70 ! 71 zalpha3 = ( zrhox - 1. ) / ( zrhox + 1. ) 72 zalpha4 = 1. - zalpha3 73 ! 74 zalpha6 = 2. * ( zrhox - 1. ) / ( zrhox + 1. ) 75 zalpha7 = - ( zrhox - 1. ) / ( zrhox + 3. ) 76 zalpha5 = 1. - zalpha6 - zalpha7 77 ! 78 imin = i1 79 imax = i2 80 jmin = j1 81 jmax = j2 82 ! 83 ! Remove CORNERS 84 IF((nbondj == -1).OR.(nbondj == 2)) jmin = 3 85 IF((nbondj == +1).OR.(nbondj == 2)) jmax = nlcj-2 86 IF((nbondi == -1).OR.(nbondi == 2)) imin = 3 87 IF((nbondi == +1).OR.(nbondi == 2)) imax = nlci-2 88 ! 89 IF( eastern_side) THEN 90 DO jn = 1, jptra 91 tra(nlci,j1:j2,k1:k2,jn) = zalpha1 * ptab(nlci,j1:j2,k1:k2,jn) + zalpha2 * ptab(nlci-1,j1:j2,k1:k2,jn) 92 DO jk = 1, jpkm1 93 DO jj = jmin,jmax 94 IF( umask(nlci-2,jj,jk) == 0.e0 ) THEN 95 tra(nlci-1,jj,jk,jn) = tra(nlci,jj,jk,jn) * tmask(nlci-1,jj,jk) 96 ELSE 97 tra(nlci-1,jj,jk,jn)=(zalpha4*tra(nlci,jj,jk,jn)+zalpha3*tra(nlci-2,jj,jk,jn))*tmask(nlci-1,jj,jk) 98 IF( un(nlci-2,jj,jk) > 0.e0 ) THEN 99 tra(nlci-1,jj,jk,jn)=( zalpha6*tra(nlci-2,jj,jk,jn)+zalpha5*tra(nlci,jj,jk,jn) & 100 + zalpha7*tra(nlci-3,jj,jk,jn) ) * tmask(nlci-1,jj,jk) 61 IF( nbghostcells > 1 ) THEN ! no smoothing 62 tra(i1:i2,j1:j2,k1:k2,n1:n2) = ptab(i1:i2,j1:j2,k1:k2,n1:n2) 63 ELSE ! smoothing 64 ! 65 western_side = (nb == 1).AND.(ndir == 1) ; eastern_side = (nb == 1).AND.(ndir == 2) 66 southern_side = (nb == 2).AND.(ndir == 1) ; northern_side = (nb == 2).AND.(ndir == 2) 67 ! 68 zrhox = Agrif_Rhox() 69 z1 = ( zrhox - 1. ) * 0.5 70 z3 = ( zrhox - 1. ) / ( zrhox + 1. ) 71 z6 = 2. * ( zrhox - 1. ) / ( zrhox + 1. ) 72 z7 = - ( zrhox - 1. ) / ( zrhox + 3. ) 73 ! 74 z2 = 1. - z1 75 z4 = 1. - z3 76 z5 = 1. - z6 - z7 77 ! 78 imin = i1 ; imax = i2 79 jmin = j1 ; jmax = j2 80 ! 81 ! Remove CORNERS 82 IF((nbondj == -1).OR.(nbondj == 2)) jmin = 3 83 IF((nbondj == +1).OR.(nbondj == 2)) jmax = nlcj-2 84 IF((nbondi == -1).OR.(nbondi == 2)) imin = 3 85 IF((nbondi == +1).OR.(nbondi == 2)) imax = nlci-2 86 ! 87 IF( eastern_side) THEN 88 DO jn = 1, jptra 89 tra(nlci,j1:j2,k1:k2,jn) = z1 * ptab(nlci,j1:j2,k1:k2,jn) + z2 * ptab(nlci-1,j1:j2,k1:k2,jn) 90 DO jk = 1, jpkm1 91 DO jj = jmin,jmax 92 IF( umask(nlci-2,jj,jk) == 0.e0 ) THEN 93 tra(nlci-1,jj,jk,jn) = tra(nlci,jj,jk,jn) * tmask(nlci-1,jj,jk) 94 ELSE 95 tra(nlci-1,jj,jk,jn)=(z4*tra(nlci,jj,jk,jn)+z3*tra(nlci-2,jj,jk,jn))*tmask(nlci-1,jj,jk) 96 IF( un(nlci-2,jj,jk) > 0.e0 ) THEN 97 tra(nlci-1,jj,jk,jn)=( z6*tra(nlci-2,jj,jk,jn)+z5*tra(nlci,jj,jk,jn) & 98 + z7*tra(nlci-3,jj,jk,jn) ) * tmask(nlci-1,jj,jk) 99 ENDIF 101 100 ENDIF 102 ENDIF 101 END DO 102 END DO 103 ENDDO 104 ENDIF 105 ! 106 IF( northern_side ) THEN 107 DO jn = 1, jptra 108 tra(i1:i2,nlcj,k1:k2,jn) = z1 * ptab(i1:i2,nlcj,k1:k2,jn) + z2 * ptab(i1:i2,nlcj-1,k1:k2,jn) 109 DO jk = 1, jpkm1 110 DO ji = imin,imax 111 IF( vmask(ji,nlcj-2,jk) == 0.e0 ) THEN 112 tra(ji,nlcj-1,jk,jn) = tra(ji,nlcj,jk,jn) * tmask(ji,nlcj-1,jk) 113 ELSE 114 tra(ji,nlcj-1,jk,jn)=(z4*tra(ji,nlcj,jk,jn)+z3*tra(ji,nlcj-2,jk,jn))*tmask(ji,nlcj-1,jk) 115 IF (vn(ji,nlcj-2,jk) > 0.e0 ) THEN 116 tra(ji,nlcj-1,jk,jn)=( z6*tra(ji,nlcj-2,jk,jn)+z5*tra(ji,nlcj,jk,jn) & 117 + z7*tra(ji,nlcj-3,jk,jn) ) * tmask(ji,nlcj-1,jk) 118 ENDIF 119 ENDIF 120 END DO 121 END DO 122 ENDDO 123 ENDIF 124 ! 125 IF( western_side) THEN 126 DO jn = 1, jptra 127 tra(1,j1:j2,k1:k2,jn) = z1 * ptab(1,j1:j2,k1:k2,jn) + z2 * ptab(2,j1:j2,k1:k2,jn) 128 DO jk = 1, jpkm1 129 DO jj = jmin,jmax 130 IF( umask(2,jj,jk) == 0.e0 ) THEN 131 tra(2,jj,jk,jn) = tra(1,jj,jk,jn) * tmask(2,jj,jk) 132 ELSE 133 tra(2,jj,jk,jn)=(z4*tra(1,jj,jk,jn)+z3*tra(3,jj,jk,jn))*tmask(2,jj,jk) 134 IF( un(2,jj,jk) < 0.e0 ) THEN 135 tra(2,jj,jk,jn)=(z6*tra(3,jj,jk,jn)+z5*tra(1,jj,jk,jn)+z7*tra(4,jj,jk,jn))*tmask(2,jj,jk) 136 ENDIF 137 ENDIF 138 END DO 103 139 END DO 104 140 END DO 105 ENDDO 141 ENDIF 142 ! 143 IF( southern_side ) THEN 144 DO jn = 1, jptra 145 tra(i1:i2,1,k1:k2,jn) = z1 * ptab(i1:i2,1,k1:k2,jn) + z2 * ptab(i1:i2,2,k1:k2,jn) 146 DO jk=1,jpk 147 DO ji=imin,imax 148 IF( vmask(ji,2,jk) == 0.e0 ) THEN 149 tra(ji,2,jk,jn)=tra(ji,1,jk,jn) * tmask(ji,2,jk) 150 ELSE 151 tra(ji,2,jk,jn)=(z4*tra(ji,1,jk,jn)+z3*tra(ji,3,jk,jn))*tmask(ji,2,jk) 152 IF( vn(ji,2,jk) < 0.e0 ) THEN 153 tra(ji,2,jk,jn)=(z6*tra(ji,3,jk,jn)+z5*tra(ji,1,jk,jn)+z7*tra(ji,4,jk,jn))*tmask(ji,2,jk) 154 ENDIF 155 ENDIF 156 END DO 157 END DO 158 ENDDO 159 ENDIF 160 ! 161 ! Treatment of corners 162 IF ((eastern_side).AND.((nbondj == -1).OR.(nbondj == 2))) tra(nlci-1,2,:,:) = ptab(nlci-1,2,:,:) ! East south 163 IF ((eastern_side).AND.((nbondj == 1).OR.(nbondj == 2))) tra(nlci-1,nlcj-1,:,:) = ptab(nlci-1,nlcj-1,:,:) ! East north 164 IF ((western_side).AND.((nbondj == -1).OR.(nbondj == 2))) tra(2,2,:,:) = ptab(2,2,:,:) ! West south 165 IF ((western_side).AND.((nbondj == 1).OR.(nbondj == 2))) tra(2,nlcj-1,:,:) = ptab(2,nlcj-1,:,:) ! West north 166 ! 106 167 ENDIF 107 !108 IF( northern_side ) THEN109 DO jn = 1, jptra110 tra(i1:i2,nlcj,k1:k2,jn) = zalpha1 * ptab(i1:i2,nlcj,k1:k2,jn) + zalpha2 * ptab(i1:i2,nlcj-1,k1:k2,jn)111 DO jk = 1, jpkm1112 DO ji = imin,imax113 IF( vmask(ji,nlcj-2,jk) == 0.e0 ) THEN114 tra(ji,nlcj-1,jk,jn) = tra(ji,nlcj,jk,jn) * tmask(ji,nlcj-1,jk)115 ELSE116 tra(ji,nlcj-1,jk,jn)=(zalpha4*tra(ji,nlcj,jk,jn)+zalpha3*tra(ji,nlcj-2,jk,jn))*tmask(ji,nlcj-1,jk)117 IF (vn(ji,nlcj-2,jk) > 0.e0 ) THEN118 tra(ji,nlcj-1,jk,jn)=( zalpha6*tra(ji,nlcj-2,jk,jn)+zalpha5*tra(ji,nlcj,jk,jn) &119 + zalpha7*tra(ji,nlcj-3,jk,jn) ) * tmask(ji,nlcj-1,jk)120 ENDIF121 ENDIF122 END DO123 END DO124 ENDDO125 ENDIF126 !127 IF( western_side) THEN128 DO jn = 1, jptra129 tra(1,j1:j2,k1:k2,jn) = zalpha1 * ptab(1,j1:j2,k1:k2,jn) + zalpha2 * ptab(2,j1:j2,k1:k2,jn)130 DO jk = 1, jpkm1131 DO jj = jmin,jmax132 IF( umask(2,jj,jk) == 0.e0 ) THEN133 tra(2,jj,jk,jn) = tra(1,jj,jk,jn) * tmask(2,jj,jk)134 ELSE135 tra(2,jj,jk,jn)=(zalpha4*tra(1,jj,jk,jn)+zalpha3*tra(3,jj,jk,jn))*tmask(2,jj,jk)136 IF( un(2,jj,jk) < 0.e0 ) THEN137 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)138 ENDIF139 ENDIF140 END DO141 END DO142 END DO143 ENDIF144 !145 IF( southern_side ) THEN146 DO jn = 1, jptra147 tra(i1:i2,1,k1:k2,jn) = zalpha1 * ptab(i1:i2,1,k1:k2,jn) + zalpha2 * ptab(i1:i2,2,k1:k2,jn)148 DO jk=1,jpk149 DO ji=imin,imax150 IF( vmask(ji,2,jk) == 0.e0 ) THEN151 tra(ji,2,jk,jn)=tra(ji,1,jk,jn) * tmask(ji,2,jk)152 ELSE153 tra(ji,2,jk,jn)=(zalpha4*tra(ji,1,jk,jn)+zalpha3*tra(ji,3,jk,jn))*tmask(ji,2,jk)154 IF( vn(ji,2,jk) < 0.e0 ) THEN155 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)156 ENDIF157 ENDIF158 END DO159 END DO160 ENDDO161 ENDIF162 !163 ! Treatment of corners164 !165 ! East south166 IF ((eastern_side).AND.((nbondj == -1).OR.(nbondj == 2))) THEN167 tra(nlci-1,2,:,:) = ptab(nlci-1,2,:,:)168 ENDIF169 ! East north170 IF ((eastern_side).AND.((nbondj == 1).OR.(nbondj == 2))) THEN171 tra(nlci-1,nlcj-1,:,:) = ptab(nlci-1,nlcj-1,:,:)172 ENDIF173 ! West south174 IF ((western_side).AND.((nbondj == -1).OR.(nbondj == 2))) THEN175 tra(2,2,:,:) = ptab(2,2,:,:)176 ENDIF177 ! West north178 IF ((western_side).AND.((nbondj == 1).OR.(nbondj == 2))) THEN179 tra(2,nlcj-1,:,:) = ptab(2,nlcj-1,:,:)180 ENDIF181 !182 168 ENDIF 183 169 ! -
branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/NEMO/NST_SRC/agrif_user.F90
r8877 r8879 127 127 !! 128 128 IMPLICIT NONE 129 ! 130 INTEGER :: ind1, ind2, ind3 129 131 !!---------------------------------------------------------------------- 130 132 131 133 ! 1. Declaration of the type of variable which have to be interpolated 132 134 !--------------------------------------------------------------------- 133 CALL agrif_declare_variable((/1,2/),(/2,3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),e1u_id) 134 CALL agrif_declare_variable((/2,1/),(/3,2/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),e2v_id) 135 !!clem ghost 136 ind1 = nbghostcells 137 ind2 = 1 + nbghostcells 138 ind3 = 2 + nbghostcells 139 CALL agrif_declare_variable((/1,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),e1u_id) 140 CALL agrif_declare_variable((/2,1/),(/ind3,ind2/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),e2v_id) 141 !!clem ghost 135 142 136 143 ! 2. Type of interpolation … … 141 148 ! 3. Location of interpolation 142 149 !----------------------------- 143 CALL Agrif_Set_bc(e1u_id,(/0,0/)) 144 CALL Agrif_Set_bc(e2v_id,(/0,0/)) 150 !!clem ghost (previously set to /0,0/) 151 CALL Agrif_Set_bc(e1u_id,(/0,ind1-1/)) 152 CALL Agrif_Set_bc(e2v_id,(/0,ind1-1/)) 153 !!clem ghost 145 154 146 155 ! 5. Update type … … 337 346 !!---------------------------------------------------------------------- 338 347 USE agrif_util 339 USE par_oce ! ONLY : jpts 348 USE par_oce ! ONLY : jpts and ghostcells 340 349 USE oce 341 350 USE agrif_oce 342 351 !! 343 352 IMPLICIT NONE 353 ! 354 INTEGER :: ind1, ind2, ind3 344 355 !!---------------------------------------------------------------------- 345 356 346 357 ! 1. Declaration of the type of variable which have to be interpolated 347 358 !--------------------------------------------------------------------- 348 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) 349 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) 350 351 CALL agrif_declare_variable((/1,2,0/),(/2,3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),un_interp_id) 352 CALL agrif_declare_variable((/2,1,0/),(/3,2,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),vn_interp_id) 353 CALL agrif_declare_variable((/1,2,0/),(/2,3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),un_update_id) 354 CALL agrif_declare_variable((/2,1,0/),(/3,2,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),vn_update_id) 355 CALL agrif_declare_variable((/1,2,0/),(/2,3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),un_sponge_id) 356 CALL agrif_declare_variable((/2,1,0/),(/3,2,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),vn_sponge_id) 357 358 CALL agrif_declare_variable((/2,2,0/),(/3,3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),e3t_id) 359 CALL agrif_declare_variable((/1,2,0/),(/2,3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),umsk_id) 360 CALL agrif_declare_variable((/2,1,0/),(/3,2,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),vmsk_id) 361 362 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) 363 364 CALL agrif_declare_variable((/1,2/),(/2,3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),unb_id) 365 CALL agrif_declare_variable((/2,1/),(/3,2/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),vnb_id) 366 CALL agrif_declare_variable((/1,2/),(/2,3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),ub2b_interp_id) 367 CALL agrif_declare_variable((/2,1/),(/3,2/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),vb2b_interp_id) 368 CALL agrif_declare_variable((/1,2/),(/2,3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),ub2b_update_id) 369 CALL agrif_declare_variable((/2,1/),(/3,2/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),vb2b_update_id) 370 371 CALL agrif_declare_variable((/2,2/),(/3,3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),sshn_id) 359 !!clem ghost 360 ind1 = nbghostcells 361 ind2 = 1 + nbghostcells 362 ind3 = 2 + nbghostcells 363 CALL agrif_declare_variable((/2,2,0,0/),(/ind3,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jpts/),tsn_id) 364 CALL agrif_declare_variable((/2,2,0,0/),(/ind3,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jpts/),tsn_sponge_id) 365 366 CALL agrif_declare_variable((/1,2,0/),(/ind2,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),un_interp_id) 367 CALL agrif_declare_variable((/2,1,0/),(/ind3,ind2,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),vn_interp_id) 368 CALL agrif_declare_variable((/1,2,0/),(/ind2,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),un_update_id) 369 CALL agrif_declare_variable((/2,1,0/),(/ind3,ind2,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),vn_update_id) 370 CALL agrif_declare_variable((/1,2,0/),(/ind2,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),un_sponge_id) 371 CALL agrif_declare_variable((/2,1,0/),(/ind3,ind2,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),vn_sponge_id) 372 373 CALL agrif_declare_variable((/2,2,0/),(/ind3,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),e3t_id) 374 CALL agrif_declare_variable((/1,2,0/),(/ind2,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),umsk_id) 375 CALL agrif_declare_variable((/2,1,0/),(/ind3,ind2,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),vmsk_id) 376 377 CALL agrif_declare_variable((/2,2,0,0/),(/ind3,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,3/),scales_t_id) 378 379 CALL agrif_declare_variable((/1,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),unb_id) 380 CALL agrif_declare_variable((/2,1/),(/ind3,ind2/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),vnb_id) 381 CALL agrif_declare_variable((/1,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),ub2b_interp_id) 382 CALL agrif_declare_variable((/2,1/),(/ind3,ind2/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),vb2b_interp_id) 383 CALL agrif_declare_variable((/1,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),ub2b_update_id) 384 CALL agrif_declare_variable((/2,1/),(/ind3,ind2/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),vb2b_update_id) 385 386 CALL agrif_declare_variable((/2,2/),(/ind3,ind3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),sshn_id) 372 387 373 388 # if defined key_zdftke 374 CALL agrif_declare_variable((/2,2,0/),(/ 3,3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/), en_id)375 CALL agrif_declare_variable((/2,2,0/),(/ 3,3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),avt_id)376 CALL agrif_declare_variable((/2,2,0/),(/ 3,3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),avm_id)389 CALL agrif_declare_variable((/2,2,0/),(/ind3,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/), en_id) 390 CALL agrif_declare_variable((/2,2,0/),(/ind3,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),avt_id) 391 CALL agrif_declare_variable((/2,2,0/),(/ind3,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),avm_id) 377 392 # endif 393 !!clem ghost 378 394 379 395 ! 2. Type of interpolation … … 407 423 ! 3. Location of interpolation 408 424 !----------------------------- 409 CALL Agrif_Set_bc(tsn_id,(/0,1/)) 410 CALL Agrif_Set_bc(un_interp_id,(/0,1/)) 411 CALL Agrif_Set_bc(vn_interp_id,(/0,1/)) 412 413 ! CALL Agrif_Set_bc(tsn_sponge_id,(/-3*Agrif_irhox(),0/)) 414 ! CALL Agrif_Set_bc(un_sponge_id,(/-2*Agrif_irhox()-1,0/)) 415 ! CALL Agrif_Set_bc(vn_sponge_id,(/-2*Agrif_irhox()-1,0/)) 416 CALL Agrif_Set_bc(tsn_sponge_id,(/-nn_sponge_len*Agrif_irhox()-1,0/)) 425 !!clem ghost 426 CALL Agrif_Set_bc(tsn_id,(/0,ind1/)) 427 CALL Agrif_Set_bc(un_interp_id,(/0,ind1/)) 428 CALL Agrif_Set_bc(vn_interp_id,(/0,ind1/)) 429 430 ! clem: previously set to /-,0/ 431 CALL Agrif_Set_bc(tsn_sponge_id,(/-nn_sponge_len*Agrif_irhox()-1,0/)) ! if west and rhox=3 and sponge=2 and ghost=1: columns 2 to 9 417 432 CALL Agrif_Set_bc(un_sponge_id ,(/-nn_sponge_len*Agrif_irhox()-1,0/)) 418 433 CALL Agrif_Set_bc(vn_sponge_id ,(/-nn_sponge_len*Agrif_irhox()-1,0/)) 419 434 420 CALL Agrif_Set_bc(sshn_id,(/0,0/)) 421 CALL Agrif_Set_bc(unb_id ,(/0,0/)) 422 CALL Agrif_Set_bc(vnb_id ,(/0,0/)) 423 CALL Agrif_Set_bc(ub2b_interp_id,(/0,0/)) 424 CALL Agrif_Set_bc(vb2b_interp_id,(/0,0/)) 425 426 CALL Agrif_Set_bc(e3t_id,(/-2*Agrif_irhox()-1,0/)) ! if west and rhox=3: column 2 to 9 427 CALL Agrif_Set_bc(umsk_id,(/0,0/)) 428 CALL Agrif_Set_bc(vmsk_id,(/0,0/)) 429 435 CALL Agrif_Set_bc(sshn_id,(/0,ind1-1/)) 436 CALL Agrif_Set_bc(unb_id ,(/0,ind1-1/)) 437 CALL Agrif_Set_bc(vnb_id ,(/0,ind1-1/)) 438 CALL Agrif_Set_bc(ub2b_interp_id,(/0,ind1-1/)) 439 CALL Agrif_Set_bc(vb2b_interp_id,(/0,ind1-1/)) 440 441 CALL Agrif_Set_bc(e3t_id,(/-2*Agrif_irhox()-1,ind1-1/)) ! if west and rhox=3 and ghost=1: column 2 to 9 442 CALL Agrif_Set_bc(umsk_id,(/0,ind1-1/)) 443 CALL Agrif_Set_bc(vmsk_id,(/0,ind1-1/)) 444 445 ! clem: previously set to /0,1/ 430 446 # if defined key_zdftke 431 CALL Agrif_Set_bc(avm_id ,(/0, 1/))447 CALL Agrif_Set_bc(avm_id ,(/0,ind1/)) 432 448 # endif 449 !!clem ghost 433 450 434 451 ! 5. Update type … … 463 480 ! 464 481 END SUBROUTINE agrif_declare_var 465 466 # if defined key_lim2467 SUBROUTINE Agrif_InitValues_cont_lim2468 !!----------------------------------------------------------------------469 !! *** ROUTINE Agrif_InitValues_cont_lim2 ***470 !!471 !! ** Purpose :: Initialisation of variables to be interpolated for LIM2472 !!----------------------------------------------------------------------473 USE Agrif_Util474 USE ice_2475 USE agrif_ice476 USE in_out_manager477 USE agrif_lim2_update478 USE agrif_lim2_interp479 USE lib_mpp480 !!481 IMPLICIT NONE482 !!----------------------------------------------------------------------483 484 ! 1. Declaration of the type of variable which have to be interpolated485 !---------------------------------------------------------------------486 CALL agrif_declare_var_lim2487 488 ! 2. First interpolations of potentially non zero fields489 !-------------------------------------------------------490 Agrif_SpecialValue=-9999.491 Agrif_UseSpecialValue = .TRUE.492 ! Call Agrif_Bc_variable(zadv ,adv_ice_id ,calledweight=1.,procname=interp_adv_ice )493 ! Call Agrif_Bc_variable(zvel ,u_ice_id ,calledweight=1.,procname=interp_u_ice )494 ! Call Agrif_Bc_variable(zvel ,v_ice_id ,calledweight=1.,procname=interp_v_ice )495 Agrif_SpecialValue=0.496 Agrif_UseSpecialValue = .FALSE.497 498 ! 3. Some controls499 !-----------------500 501 # if ! defined key_lim2_vp502 lim_nbstep = 1.503 CALL agrif_rhg_lim2_load504 CALL agrif_trp_lim2_load505 lim_nbstep = 0.506 # endif507 !RB mandatory but why ???508 ! IF( nbclineupdate /= nn_fsbc .AND. nn_ice == 2 )THEN509 ! CALL ctl_warn ('With ice model on child grid, nbclineupdate is set to nn_fsbc')510 ! nbclineupdate = nn_fsbc511 ! ENDIF512 CALL Agrif_Update_lim2(0)513 !514 END SUBROUTINE Agrif_InitValues_cont_lim2515 516 517 SUBROUTINE agrif_declare_var_lim2518 !!----------------------------------------------------------------------519 !! *** ROUTINE agrif_declare_var_lim2 ***520 !!521 !! ** Purpose :: Declaration of variables to be interpolated for LIM2522 !!----------------------------------------------------------------------523 USE agrif_util524 USE ice_2525 !!526 IMPLICIT NONE527 !!----------------------------------------------------------------------528 529 ! 1. Declaration of the type of variable which have to be interpolated530 !---------------------------------------------------------------------531 CALL agrif_declare_variable((/2,2,0/),(/3,3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj, 7/),adv_ice_id )532 # if defined key_lim2_vp533 CALL agrif_declare_variable((/1,1/),(/3,3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),u_ice_id)534 CALL agrif_declare_variable((/1,1/),(/3,3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),v_ice_id)535 # else536 CALL agrif_declare_variable((/1,2/),(/2,3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),u_ice_id)537 CALL agrif_declare_variable((/2,1/),(/3,2/),(/'x','y'/),(/1,1/),(/jpi,jpj/),v_ice_id)538 # endif539 540 ! 2. Type of interpolation541 !-------------------------542 CALL Agrif_Set_bcinterp(adv_ice_id ,interp=AGRIF_linear)543 CALL Agrif_Set_bcinterp(u_ice_id,interp1=Agrif_linear,interp2=AGRIF_ppm)544 CALL Agrif_Set_bcinterp(v_ice_id,interp1=AGRIF_ppm,interp2=Agrif_linear)545 546 ! 3. Location of interpolation547 !-----------------------------548 CALL Agrif_Set_bc(adv_ice_id ,(/0,1/))549 CALL Agrif_Set_bc(u_ice_id,(/0,1/))550 CALL Agrif_Set_bc(v_ice_id,(/0,1/))551 552 ! 5. Update type553 !---------------554 CALL Agrif_Set_Updatetype(adv_ice_id , update = AGRIF_Update_Average)555 CALL Agrif_Set_Updatetype(u_ice_id,update1 = Agrif_Update_Copy, update2 = Agrif_Update_Average)556 CALL Agrif_Set_Updatetype(v_ice_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy)557 !558 END SUBROUTINE agrif_declare_var_lim2559 # endif560 482 561 483 #if defined key_lim3 … … 623 545 USE Agrif_Util 624 546 USE ice 625 626 IMPLICIT NONE 547 USE par_oce, ONLY : nbghostcells 548 ! 549 IMPLICIT NONE 550 ! 551 INTEGER :: ind1, ind2, ind3 627 552 !!---------------------------------------------------------------------- 628 553 ! … … 634 559 ! 2,2 = two ghost lines 635 560 !------------------------------------------------------------------------------------- 636 CALL agrif_declare_variable((/2,2,0/),(/3,3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpl*(5+nlay_s+nlay_i)/),tra_ice_id ) 637 CALL agrif_declare_variable((/1,2/) ,(/2,3/),(/'x','y'/) ,(/1,1/) ,(/nlci,nlcj/) ,u_ice_id ) 638 CALL agrif_declare_variable((/2,1/) ,(/3,2/),(/'x','y'/) ,(/1,1/) ,(/nlci,nlcj/) ,v_ice_id ) 561 !!clem ghost 562 ind1 = nbghostcells 563 ind2 = 1 + nbghostcells 564 ind3 = 2 + nbghostcells 565 CALL agrif_declare_variable((/2,2,0/),(/ind3,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpl*(5+nlay_s+nlay_i)/),tra_ice_id ) 566 CALL agrif_declare_variable((/1,2/) ,(/ind2,ind3/) ,(/'x','y'/) ,(/1,1/) ,(/nlci,nlcj/) ,u_ice_id ) 567 CALL agrif_declare_variable((/2,1/) ,(/ind3,ind2/) ,(/'x','y'/) ,(/1,1/) ,(/nlci,nlcj/) ,v_ice_id ) 568 !!clem ghost 639 569 640 570 ! 2. Set interpolations (normal & tangent to the grid cell for velocities) … … 646 576 ! 3. Set location of interpolations 647 577 !---------------------------------- 648 CALL Agrif_Set_bc(tra_ice_id,(/0,1/)) 649 CALL Agrif_Set_bc(u_ice_id ,(/0,1/)) 650 CALL Agrif_Set_bc(v_ice_id ,(/0,1/)) 578 !!clem ghost 579 CALL Agrif_Set_bc(tra_ice_id,(/0,ind1/)) 580 CALL Agrif_Set_bc(u_ice_id ,(/0,ind1/)) 581 CALL Agrif_Set_bc(v_ice_id ,(/0,ind1/)) 582 !!clem ghost 651 583 652 584 ! 4. Set update type in case 2 ways (child=>parent) (normal & tangent to the grid cell for velocities) … … 777 709 !! 778 710 IMPLICIT NONE 711 ! 712 INTEGER :: ind1, ind2, ind3 779 713 !!---------------------------------------------------------------------- 780 714 781 715 ! 1. Declaration of the type of variable which have to be interpolated 782 716 !--------------------------------------------------------------------- 783 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) 784 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) 717 !!clem ghost 718 ind1 = nbghostcells 719 ind2 = 1 + nbghostcells 720 ind3 = 2 + nbghostcells 721 CALL agrif_declare_variable((/2,2,0,0/),(/ind3,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jptra/),trn_id) 722 CALL agrif_declare_variable((/2,2,0,0/),(/ind3,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jptra/),trn_sponge_id) 785 723 786 724 ! 2. Type of interpolation … … 791 729 ! 3. Location of interpolation 792 730 !----------------------------- 793 CALL Agrif_Set_bc(trn_id,(/0,1/)) 794 ! CALL Agrif_Set_bc(trn_sponge_id,(/-3*Agrif_irhox(),0/)) 731 !!clem ghost 732 CALL Agrif_Set_bc(trn_id,(/0,ind1/)) 733 !clem: previously set to /-,0/ 795 734 CALL Agrif_Set_bc(trn_sponge_id,(/-nn_sponge_len*Agrif_irhox()-1,0/)) 796 735 … … 868 807 ! 869 808 IF( agrif_oce_alloc() > 0 ) CALL ctl_warn('agrif agrif_oce_alloc: allocation of arrays failed') 870 # if defined key_lim2871 IF( agrif_ice_alloc() > 0 ) CALL ctl_stop('agrif agrif_ice_alloc: allocation of arrays failed') ! only for LIM2 (not LIM3)872 # endif873 809 ! 874 810 END SUBROUTINE agrif_nemo_init -
branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/NEMO/OPA_SRC/ASM/asmbkg.F90
r8877 r8879 38 38 USE asmpar ! Parameters for the assmilation interface 39 39 USE zdfmxl ! mixed layer depth 40 #if defined key_lim241 USE ice_242 #endif43 40 #if defined key_lim3 44 41 USE ice … … 148 145 CALL iom_rstput( kt, nitdin_r, inum, 'sn' , tsn(:,:,:,jp_sal) ) 149 146 CALL iom_rstput( kt, nitdin_r, inum, 'sshn' , sshn ) 150 #if defined key_lim 2 || defined key_lim3151 IF( nn_ice == 2 .OR. nn_ice == 3) THEN152 IF( ALLOCATED( frld) ) THEN153 CALL iom_rstput( kt, nitdin_r, inum, 'iceconc', 1._wp - frld(:,:) )147 #if defined key_lim3 148 IF( nn_ice == 2 ) THEN 149 IF( ALLOCATED(at_i) ) THEN 150 CALL iom_rstput( kt, nitdin_r, inum, 'iceconc', at_i(:,:) ) 154 151 ELSE 155 CALL ctl_warn('Ice concentration not written to background as ice variable frldnot allocated on this timestep')152 CALL ctl_warn('Ice concentration not written to background as ice variable at_i not allocated on this timestep') 156 153 ENDIF 157 154 ENDIF -
branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/NEMO/OPA_SRC/ASM/asminc.F90
r8877 r8879 35 35 USE in_out_manager ! I/O manager 36 36 USE lib_mpp ! MPP library 37 #if defined key_lim 238 USE ice _2 ! LIM237 #if defined key_lim3 38 USE ice, ONLY: hm_i, at_i, at_i_b 39 39 #endif 40 40 USE sbc_oce ! Surface boundary condition variables. … … 809 809 INTEGER :: it 810 810 REAL(wp) :: zincwgt ! IAU weight for current time step 811 #if defined key_lim 2811 #if defined key_lim3 812 812 REAL(wp), DIMENSION(jpi,jpj) :: zofrld, zohicif, zseaicendg, zhicifinc ! LIM 813 813 REAL(wp) :: zhicifmin = 0.5_wp ! ice minimum depth in metres … … 831 831 ENDIF 832 832 ! 833 ! Sea-ice : LIM-3 case (to add) 834 ! 835 #if defined key_lim2 836 ! Sea-ice : LIM-2 case 837 zofrld (:,:) = frld(:,:) 838 zohicif(:,:) = hicif(:,:) 839 ! 840 frld = MIN( MAX( frld (:,:) - seaice_bkginc(:,:) * zincwgt, 0.0_wp), 1.0_wp) 841 pfrld = MIN( MAX( pfrld(:,:) - seaice_bkginc(:,:) * zincwgt, 0.0_wp), 1.0_wp) 842 fr_i(:,:) = 1.0_wp - frld(:,:) ! adjust ice fraction 843 ! 844 zseaicendg(:,:) = zofrld(:,:) - frld(:,:) ! find out actual sea ice nudge applied 833 ! Sea-ice : LIM-3 case 834 ! 835 #if defined key_lim3 836 zofrld (:,:) = 1._wp - at_i(:,:) 837 zohicif(:,:) = hm_i(:,:) 838 ! 839 at_i (:,:) = 1. - MIN( MAX( 1.-at_i (:,:) - seaice_bkginc(:,:) * zincwgt, 0.0_wp), 1.0_wp) 840 at_i_b(:,:) = 1. - MIN( MAX( 1.-at_i_b(:,:) - seaice_bkginc(:,:) * zincwgt, 0.0_wp), 1.0_wp) 841 fr_i(:,:) = at_i(:,:) ! adjust ice fraction 842 ! 843 zseaicendg(:,:) = zofrld(:,:) - (1. - at_i(:,:)) ! find out actual sea ice nudge applied 845 844 ! 846 845 ! Nudge sea ice depth to bring it up to a required minimum depth 847 WHERE( zseaicendg(:,:) > 0.0_wp .AND. h icif(:,:) < zhicifmin )848 zhicifinc(:,:) = (zhicifmin - h icif(:,:)) * zincwgt846 WHERE( zseaicendg(:,:) > 0.0_wp .AND. hm_i(:,:) < zhicifmin ) 847 zhicifinc(:,:) = (zhicifmin - hm_i(:,:)) * zincwgt 849 848 ELSEWHERE 850 849 zhicifinc(:,:) = 0.0_wp … … 852 851 ! 853 852 ! nudge ice depth 854 hicif (:,:) = hicif (:,:) + zhicifinc(:,:) 855 phicif(:,:) = phicif(:,:) + zhicifinc(:,:) 853 hm_i (:,:) = hm_i (:,:) + zhicifinc(:,:) 856 854 ! 857 855 ! seaice salinity balancing (to add) … … 882 880 neuler = 0 ! Force Euler forward step 883 881 ! 884 ! Sea-ice : LIM-3 case (to add) 885 ! 886 #if defined key_lim2 887 ! Sea-ice : LIM-2 case. 888 zofrld(:,:)=frld(:,:) 889 zohicif(:,:)=hicif(:,:) 882 ! Sea-ice : LIM-3 case 883 ! 884 #if defined key_lim3 885 zofrld (:,:) = 1._wp - at_i(:,:) 886 zohicif(:,:) = hm_i(:,:) 890 887 ! 891 888 ! Initialize the now fields the background + increment 892 frld (:,:) = MIN( MAX( frld(:,:) - seaice_bkginc(:,:), 0.0_wp), 1.0_wp) 893 pfrld(:,:) = frld(:,:) 894 fr_i (:,:) = 1.0_wp - frld(:,:) ! adjust ice fraction 895 zseaicendg(:,:) = zofrld(:,:) - frld(:,:) ! find out actual sea ice nudge applied 889 at_i(:,:) = 1. - MIN( MAX( 1.-at_i(:,:) - seaice_bkginc(:,:), 0.0_wp), 1.0_wp) 890 at_i_b(:,:) = at_i(:,:) 891 fr_i(:,:) = at_i(:,:) ! adjust ice fraction 892 ! 893 zseaicendg(:,:) = zofrld(:,:) - (1. - at_i(:,:)) ! find out actual sea ice nudge applied 896 894 ! 897 895 ! Nudge sea ice depth to bring it up to a required minimum depth 898 WHERE( zseaicendg(:,:) > 0.0_wp .AND. h icif(:,:) < zhicifmin )899 zhicifinc(:,:) = (zhicifmin - h icif(:,:)) * zincwgt896 WHERE( zseaicendg(:,:) > 0.0_wp .AND. hm_i(:,:) < zhicifmin ) 897 zhicifinc(:,:) = (zhicifmin - hm_i(:,:)) * zincwgt 900 898 ELSEWHERE 901 zhicifinc(:,:) = 0. _wp899 zhicifinc(:,:) = 0.0_wp 902 900 END WHERE 903 901 ! 904 902 ! nudge ice depth 905 hicif (:,:) = hicif (:,:) + zhicifinc(:,:) 906 phicif(:,:) = phicif(:,:) 903 hm_i (:,:) = hm_i (:,:) + zhicifinc(:,:) 907 904 ! 908 905 ! seaice salinity balancing (to add) … … 926 923 ENDIF 927 924 928 !#if defined defined key_lim 2|| defined key_cice925 !#if defined defined key_lim3 || defined key_cice 929 926 ! 930 927 ! IF (ln_seaicebal ) THEN -
branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/NEMO/OPA_SRC/BDY/bdy_oce.F90
r8877 r8879 55 55 REAL(wp), POINTER, DIMENSION(:,:) :: tem 56 56 REAL(wp), POINTER, DIMENSION(:,:) :: sal 57 #if defined key_lim2 58 LOGICAL :: ll_frld 59 LOGICAL :: ll_hicif 60 LOGICAL :: ll_hsnif 61 REAL(wp), POINTER, DIMENSION(:) :: frld 62 REAL(wp), POINTER, DIMENSION(:) :: hicif 63 REAL(wp), POINTER, DIMENSION(:) :: hsnif 64 #elif defined key_lim3 57 #if defined key_lim3 65 58 LOGICAL :: ll_a_i 66 LOGICAL :: ll_h t_i67 LOGICAL :: ll_h t_s59 LOGICAL :: ll_h_i 60 LOGICAL :: ll_h_s 68 61 REAL(wp), POINTER, DIMENSION(:,:) :: a_i !: now ice leads fraction climatology 69 REAL(wp), POINTER, DIMENSION(:,:) :: h t_i!: Now ice thickness climatology70 REAL(wp), POINTER, DIMENSION(:,:) :: h t_s!: now snow thickness62 REAL(wp), POINTER, DIMENSION(:,:) :: h_i !: Now ice thickness climatology 63 REAL(wp), POINTER, DIMENSION(:,:) :: h_s !: now snow thickness 71 64 #endif 72 65 #if defined key_top -
branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/NEMO/OPA_SRC/BDY/bdydta.F90
r8877 r8879 25 25 USE iom ! IOM library 26 26 USE in_out_manager ! I/O logical units 27 #if defined key_lim2 28 USE ice_2 29 #elif defined key_lim3 27 #if defined key_lim3 30 28 USE ice 31 USE limvar ! redistribute ice input into categories29 USE icevar ! redistribute ice input into categories 32 30 #endif 33 31 USE sbcapr … … 50 48 51 49 #if defined key_lim3 52 LOGICAL :: ll_bdylim3 ! determine whether ice input is lim2 (F) or lim3(T) type50 LOGICAL :: ll_bdylim3 ! determine whether ice input is 1cat (F) or Xcat (T) type 53 51 INTEGER :: jfld_hti, jfld_hts, jfld_ai ! indices of ice thickness, snow thickness and concentration in bf structure 54 52 #endif … … 176 174 ENDIF 177 175 178 #if defined key_lim2 179 IF( nn_ice_lim_dta(ib_bdy) == 0 ) THEN 180 ilen1(:) = nblen(:) 181 IF( dta%ll_frld ) THEN 182 igrd = 1 183 DO ib = 1, ilen1(igrd) 184 ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 185 ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 186 dta_bdy(ib_bdy)%frld(ib) = frld(ii,ij) * tmask(ii,ij,1) 187 END DO 188 END IF 189 IF( dta%ll_hicif ) THEN 190 igrd = 1 191 DO ib = 1, ilen1(igrd) 192 ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 193 ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 194 dta_bdy(ib_bdy)%hicif(ib) = hicif(ii,ij) * tmask(ii,ij,1) 195 END DO 196 END IF 197 IF( dta%ll_hsnif ) THEN 198 igrd = 1 199 DO ib = 1, ilen1(igrd) 200 ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 201 ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 202 dta_bdy(ib_bdy)%hsnif(ib) = hsnif(ii,ij) * tmask(ii,ij,1) 203 END DO 204 END IF 205 ENDIF 206 #elif defined key_lim3 176 #if defined key_lim3 207 177 IF( nn_ice_lim_dta(ib_bdy) == 0 ) THEN 208 178 ilen1(:) = nblen(:) … … 217 187 END DO 218 188 ENDIF 219 IF( dta%ll_h t_i ) THEN189 IF( dta%ll_h_i ) THEN 220 190 igrd = 1 221 191 DO jl = 1, jpl … … 223 193 ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 224 194 ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 225 dta_bdy(ib_bdy)%h t_i (ib,jl) = ht_i(ii,ij,jl) * tmask(ii,ij,1)195 dta_bdy(ib_bdy)%h_i (ib,jl) = h_i(ii,ij,jl) * tmask(ii,ij,1) 226 196 END DO 227 197 END DO 228 198 ENDIF 229 IF( dta%ll_h t_s ) THEN199 IF( dta%ll_h_s ) THEN 230 200 igrd = 1 231 201 DO jl = 1, jpl … … 233 203 ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 234 204 ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 235 dta_bdy(ib_bdy)%h t_s (ib,jl) = ht_s(ii,ij,jl) * tmask(ii,ij,1)205 dta_bdy(ib_bdy)%h_s (ib,jl) = h_s(ii,ij,jl) * tmask(ii,ij,1) 236 206 END DO 237 207 END DO … … 373 343 ENDIF 374 344 #if defined key_lim3 375 IF( .NOT. ll_bdylim3 .AND. cn_ice_lim(ib_bdy) /= 'none' .AND. nn_ice_lim_dta(ib_bdy) == 1 ) THEN ! bdy ice input (case input is lim2 type)376 CALL lim_var_itd ( bf(jfld_hti)%fnow(:,1,1), bf(jfld_hts)%fnow(:,1,1), bf(jfld_ai)%fnow(:,1,1), &377 & dta_bdy(ib_bdy)%h t_i, dta_bdy(ib_bdy)%ht_s, dta_bdy(ib_bdy)%a_i )345 IF( .NOT. ll_bdylim3 .AND. cn_ice_lim(ib_bdy) /= 'none' .AND. nn_ice_lim_dta(ib_bdy) == 1 ) THEN ! bdy ice input (case input is 1cat) 346 CALL ice_var_itd ( bf(jfld_hti)%fnow(:,1,1), bf(jfld_hts)%fnow(:,1,1), bf(jfld_ai)%fnow(:,1,1), & 347 & dta_bdy(ib_bdy)%h_i, dta_bdy(ib_bdy)%h_s, dta_bdy(ib_bdy)%a_i ) 378 348 ENDIF 379 349 #endif … … 449 419 TYPE(FLD_N) :: bn_tem, bn_sal, bn_u3d, bn_v3d ! 450 420 TYPE(FLD_N) :: bn_ssh, bn_u2d, bn_v2d ! informations about the fields to be read 451 #if defined key_lim2 452 TYPE(FLD_N) :: bn_frld, bn_hicif, bn_hsnif ! 453 #elif defined key_lim3 454 TYPE(FLD_N) :: bn_a_i, bn_ht_i, bn_ht_s 421 #if defined key_lim3 422 TYPE(FLD_N) :: bn_a_i, bn_h_i, bn_h_s 455 423 #endif 456 424 NAMELIST/nambdy_dta/ cn_dir, bn_tem, bn_sal, bn_u3d, bn_v3d, bn_ssh, bn_u2d, bn_v2d 457 #if defined key_lim2 458 NAMELIST/nambdy_dta/ bn_frld, bn_hicif, bn_hsnif 459 #elif defined key_lim3 460 NAMELIST/nambdy_dta/ bn_a_i, bn_ht_i, bn_ht_s 425 #if defined key_lim3 426 NAMELIST/nambdy_dta/ bn_a_i, bn_h_i, bn_h_s 461 427 #endif 462 428 NAMELIST/nambdy_dta/ ln_full_vel, nb_jpk_bdy … … 475 441 ,nn_dyn3d_dta(ib_bdy) & 476 442 ,nn_tra_dta(ib_bdy) & 477 #if ( defined key_lim2 || defined key_lim3 )443 #if defined key_lim3 478 444 ,nn_ice_lim_dta(ib_bdy) & 479 445 #endif … … 496 462 nb_bdy_fld(ib_bdy) = nb_bdy_fld(ib_bdy) + 2 497 463 ENDIF 498 #if ( defined key_lim2 || defined key_lim3 )464 #if defined key_lim3 499 465 IF( cn_ice_lim(ib_bdy) /= 'none' .and. nn_ice_lim_dta(ib_bdy) == 1 ) THEN 500 466 nb_bdy_fld(ib_bdy) = nb_bdy_fld(ib_bdy) + 3 … … 637 603 ENDIF 638 604 639 #if defined key_lim 2605 #if defined key_lim3 640 606 ! sea ice 641 607 IF( nn_ice_lim_dta(ib_bdy) == 1 ) THEN 642 643 IF( dta%ll_frld ) THEN 644 jfld = jfld + 1 645 blf_i(jfld) = bn_frld 646 ibdy(jfld) = ib_bdy 647 igrid(jfld) = 1 648 ilen1(jfld) = nblen(igrid(jfld)) 649 ilen3(jfld) = 1 650 ENDIF 651 652 IF( dta%ll_hicif ) THEN 653 jfld = jfld + 1 654 blf_i(jfld) = bn_hicif 655 ibdy(jfld) = ib_bdy 656 igrid(jfld) = 1 657 ilen1(jfld) = nblen(igrid(jfld)) 658 ilen3(jfld) = 1 659 ENDIF 660 661 IF( dta%ll_hsnif ) THEN 662 jfld = jfld + 1 663 blf_i(jfld) = bn_hsnif 664 ibdy(jfld) = ib_bdy 665 igrid(jfld) = 1 666 ilen1(jfld) = nblen(igrid(jfld)) 667 ilen3(jfld) = 1 668 ENDIF 669 670 ENDIF 671 #elif defined key_lim3 672 ! sea ice 673 IF( nn_ice_lim_dta(ib_bdy) == 1 ) THEN 674 ! Test for types of ice input (lim2 or lim3) 608 ! Test for types of ice input (1cat or Xcat) 675 609 ! Build file name to find dimensions 676 610 clname=TRIM( cn_dir )//TRIM(bn_a_i%clname) … … 689 623 690 624 IF ( zndims == 4 ) THEN 691 ll_bdylim3 = .TRUE. ! lim3input625 ll_bdylim3 = .TRUE. ! Xcat input 692 626 ELSE 693 ll_bdylim3 = .FALSE. ! lim2input627 ll_bdylim3 = .FALSE. ! 1cat input 694 628 ENDIF 695 629 ! End test … … 704 638 ENDIF 705 639 706 IF( dta%ll_h t_i ) THEN707 jfld = jfld + 1 708 blf_i(jfld) = bn_h t_i640 IF( dta%ll_h_i ) THEN 641 jfld = jfld + 1 642 blf_i(jfld) = bn_h_i 709 643 ibdy(jfld) = ib_bdy 710 644 igrid(jfld) = 1 … … 713 647 ENDIF 714 648 715 IF( dta%ll_h t_s ) THEN716 jfld = jfld + 1 717 blf_i(jfld) = bn_h t_s649 IF( dta%ll_h_s ) THEN 650 jfld = jfld + 1 651 blf_i(jfld) = bn_h_s 718 652 ibdy(jfld) = ib_bdy 719 653 igrid(jfld) = 1 … … 848 782 ENDIF 849 783 850 #if defined key_lim 2784 #if defined key_lim3 851 785 IF (cn_ice_lim(ib_bdy) /= 'none') THEN 852 786 IF( nn_ice_lim_dta(ib_bdy) == 0 ) THEN 853 ALLOCATE( dta_bdy(ib_bdy)% frld(nblen(1)) )854 ALLOCATE( dta_bdy(ib_bdy)%h icif(nblen(1)) )855 ALLOCATE( dta_bdy(ib_bdy)%h snif(nblen(1)) )787 ALLOCATE( dta_bdy(ib_bdy)%a_i(nblen(1),jpl) ) 788 ALLOCATE( dta_bdy(ib_bdy)%h_i(nblen(1),jpl) ) 789 ALLOCATE( dta_bdy(ib_bdy)%h_s(nblen(1),jpl) ) 856 790 ELSE 857 jfld = jfld + 1 858 dta_bdy(ib_bdy)%frld => bf(jfld)%fnow(:,1,1) 859 jfld = jfld + 1 860 dta_bdy(ib_bdy)%hicif => bf(jfld)%fnow(:,1,1) 861 jfld = jfld + 1 862 dta_bdy(ib_bdy)%hsnif => bf(jfld)%fnow(:,1,1) 863 ENDIF 864 ENDIF 865 #elif defined key_lim3 866 IF (cn_ice_lim(ib_bdy) /= 'none') THEN 867 IF( nn_ice_lim_dta(ib_bdy) == 0 ) THEN 868 ALLOCATE( dta_bdy(ib_bdy)%a_i (nblen(1),jpl) ) 869 ALLOCATE( dta_bdy(ib_bdy)%ht_i(nblen(1),jpl) ) 870 ALLOCATE( dta_bdy(ib_bdy)%ht_s(nblen(1),jpl) ) 871 ELSE 872 IF ( ll_bdylim3 ) THEN ! case input is lim3 type 873 jfld = jfld + 1 874 dta_bdy(ib_bdy)%a_i => bf(jfld)%fnow(:,1,:) 875 jfld = jfld + 1 876 dta_bdy(ib_bdy)%ht_i => bf(jfld)%fnow(:,1,:) 877 jfld = jfld + 1 878 dta_bdy(ib_bdy)%ht_s => bf(jfld)%fnow(:,1,:) 879 ELSE ! case input is lim2 type 791 IF ( ll_bdylim3 ) THEN ! case input is Xcat 792 jfld = jfld + 1 793 dta_bdy(ib_bdy)%a_i => bf(jfld)%fnow(:,1,:) 794 jfld = jfld + 1 795 dta_bdy(ib_bdy)%h_i => bf(jfld)%fnow(:,1,:) 796 jfld = jfld + 1 797 dta_bdy(ib_bdy)%h_s => bf(jfld)%fnow(:,1,:) 798 ELSE ! case input is 1cat 880 799 jfld_ai = jfld + 1 881 800 jfld_hti = jfld + 2 882 801 jfld_hts = jfld + 3 883 802 jfld = jfld + 3 884 ALLOCATE( dta_bdy(ib_bdy)%a_i 885 ALLOCATE( dta_bdy(ib_bdy)%h t_i(nblen(1),jpl) )886 ALLOCATE( dta_bdy(ib_bdy)%h t_s(nblen(1),jpl) )887 dta_bdy(ib_bdy)%a_i 888 dta_bdy(ib_bdy)%h t_i(:,:) = 0._wp889 dta_bdy(ib_bdy)%h t_s(:,:) = 0._wp803 ALLOCATE( dta_bdy(ib_bdy)%a_i(nblen(1),jpl) ) 804 ALLOCATE( dta_bdy(ib_bdy)%h_i(nblen(1),jpl) ) 805 ALLOCATE( dta_bdy(ib_bdy)%h_s(nblen(1),jpl) ) 806 dta_bdy(ib_bdy)%a_i(:,:) = 0._wp 807 dta_bdy(ib_bdy)%h_i(:,:) = 0._wp 808 dta_bdy(ib_bdy)%h_s(:,:) = 0._wp 890 809 ENDIF 891 810 -
branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/NEMO/OPA_SRC/BDY/bdyini.F90
r8877 r8879 351 351 IF(lwp) WRITE(numout,*) 352 352 353 #if defined key_lim 2353 #if defined key_lim3 354 354 IF(lwp) WRITE(numout,*) 'Boundary conditions for sea ice: ' 355 355 SELECT CASE( cn_ice_lim(ib_bdy) ) 356 356 CASE('none') 357 357 IF(lwp) WRITE(numout,*) ' no open boundary condition' 358 dta_bdy(ib_bdy)%ll_ frld= .false.359 dta_bdy(ib_bdy)%ll_h icif= .false.360 dta_bdy(ib_bdy)%ll_h snif= .false.358 dta_bdy(ib_bdy)%ll_a_i = .false. 359 dta_bdy(ib_bdy)%ll_h_i = .false. 360 dta_bdy(ib_bdy)%ll_h_s = .false. 361 361 CASE('frs') 362 362 IF(lwp) WRITE(numout,*) ' Flow Relaxation Scheme' 363 dta_bdy(ib_bdy)%ll_frld = .true. 364 dta_bdy(ib_bdy)%ll_hicif = .true. 365 dta_bdy(ib_bdy)%ll_hsnif = .true. 366 CASE DEFAULT ; CALL ctl_stop( 'unrecognised value for cn_ice_lim' ) 367 END SELECT 368 IF( cn_ice_lim(ib_bdy) /= 'none' ) THEN 369 SELECT CASE( nn_ice_lim_dta(ib_bdy) ) ! 370 CASE( 0 ) ; IF(lwp) WRITE(numout,*) ' initial state used for bdy data' 371 CASE( 1 ) ; IF(lwp) WRITE(numout,*) ' boundary data taken from file' 372 CASE DEFAULT ; CALL ctl_stop( 'nn_ice_lim_dta must be 0 or 1' ) 373 END SELECT 374 ENDIF 375 IF(lwp) WRITE(numout,*) 376 #elif defined key_lim3 377 IF(lwp) WRITE(numout,*) 'Boundary conditions for sea ice: ' 378 SELECT CASE( cn_ice_lim(ib_bdy) ) 379 CASE('none') 380 IF(lwp) WRITE(numout,*) ' no open boundary condition' 381 dta_bdy(ib_bdy)%ll_a_i = .false. 382 dta_bdy(ib_bdy)%ll_ht_i = .false. 383 dta_bdy(ib_bdy)%ll_ht_s = .false. 384 CASE('frs') 385 IF(lwp) WRITE(numout,*) ' Flow Relaxation Scheme' 386 dta_bdy(ib_bdy)%ll_a_i = .true. 387 dta_bdy(ib_bdy)%ll_ht_i = .true. 388 dta_bdy(ib_bdy)%ll_ht_s = .true. 363 dta_bdy(ib_bdy)%ll_a_i = .true. 364 dta_bdy(ib_bdy)%ll_h_i = .true. 365 dta_bdy(ib_bdy)%ll_h_s = .true. 389 366 CASE DEFAULT ; CALL ctl_stop( 'unrecognised value for cn_ice_lim' ) 390 367 END SELECT -
branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/NEMO/OPA_SRC/CRS/crslbclnk.F90
r8877 r8879 15 15 16 16 INTERFACE crs_lbc_lnk 17 MODULE PROCEDURE crs_lbc_lnk_3d, crs_lbc_lnk_ 3d_gather, crs_lbc_lnk_2d17 MODULE PROCEDURE crs_lbc_lnk_3d, crs_lbc_lnk_2d 18 18 END INTERFACE 19 19 … … 56 56 ! 57 57 IF( PRESENT( cd_mpp ) ) THEN ; CALL lbc_lnk( pt3d1, cd_type1, psgn, cd_mpp, pval=zval ) 58 ELSE ; CALL lbc_lnk( pt3d1, cd_type1, psgn , pval=zval )58 ELSE ; CALL lbc_lnk( pt3d1, cd_type1, psgn , pval=zval ) 59 59 ENDIF 60 60 ! … … 62 62 ! 63 63 END SUBROUTINE crs_lbc_lnk_3d 64 65 66 SUBROUTINE crs_lbc_lnk_3d_gather( pt3d1, cd_type1, pt3d2, cd_type2, psgn )67 !!---------------------------------------------------------------------68 !! *** SUBROUTINE crs_lbc_lnk ***69 !!70 !! ** Purpose : set lateral boundary conditions for coarsened grid71 !!72 !! ** Method : Swap domain indices from full to coarse domain73 !! before arguments are passed directly to lbc_lnk.74 !! Upon exiting, switch back to full domain indices.75 !!----------------------------------------------------------------------76 CHARACTER(len=1) , INTENT(in ) :: cd_type1, cd_type2 ! grid type77 REAL(wp) , INTENT(in ) :: psgn ! control of the sign78 REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(inout) :: pt3d1 , pt3d2 ! 3D array on which the lbc is applied79 !80 LOGICAL :: ll_grid_crs81 !!----------------------------------------------------------------------82 !83 ll_grid_crs = ( jpi == jpi_crs )84 !85 IF( .NOT.ll_grid_crs ) CALL dom_grid_crs ! Save the parent grid information & Switch to coarse grid domain86 !87 CALL lbc_lnk( pt3d1, cd_type1, pt3d2, cd_type2, psgn )88 !89 IF( .NOT.ll_grid_crs ) CALL dom_grid_glo ! Return to parent grid domain90 !91 END SUBROUTINE crs_lbc_lnk_3d_gather92 93 64 94 65 … … 121 92 IF( .NOT.ll_grid_crs ) CALL dom_grid_crs ! Save the parent grid information & Switch to coarse grid domain 122 93 ! 123 IF( PRESENT( cd_mpp ) ) THEN ;CALL lbc_lnk( pt2d, cd_type, psgn, cd_mpp, pval=zval )124 ELSE ; CALL lbc_lnk( pt2d, cd_type, psgn,pval=zval )94 IF( PRESENT( cd_mpp ) ) THEN ; CALL lbc_lnk( pt2d, cd_type, psgn, cd_mpp, pval=zval ) 95 ELSE ; CALL lbc_lnk( pt2d, cd_type, psgn, pval=zval ) 125 96 ENDIF 126 97 ! -
branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/NEMO/OPA_SRC/DIA/dia25h.F90
r8877 r8879 148 148 rmxln_25h(:,:,:) = mxln(:,:,:) 149 149 #endif 150 #if defined key_lim3 || defined key_lim2150 #if defined key_lim3 151 151 CALL ctl_stop('STOP', 'dia_25h not setup yet to do tidemean ice') 152 152 #endif … … 207 207 ENDIF 208 208 209 #if defined key_lim3 || defined key_lim2209 #if defined key_lim3 210 210 CALL ctl_stop('STOP', 'dia_wri_tide not setup yet to do tidemean ice') 211 211 #endif -
branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/NEMO/OPA_SRC/DIA/diadct.F90
r8877 r8879 32 32 USE dianam ! build name of file 33 33 USE lib_mpp ! distributed memory computing library 34 #if defined key_lim235 USE ice_236 #endif37 34 #if defined key_lim3 38 35 USE ice … … 747 744 END DO !end of loop on the level 748 745 749 #if defined key_lim 2 || defined key_lim3746 #if defined key_lim3 750 747 751 748 !ICE CASE … … 769 766 zTnorm=zumid_ice*e2u(k%I,k%J)+zvmid_ice*e1v(k%I,k%J) 770 767 771 #if defined key_lim2772 transports_2d(1,jsec,jseg) = transports_2d(1,jsec,jseg) + (zTnorm)* &773 (1.0 - frld(sec%listPoint(jseg)%I,sec%listPoint(jseg)%J)) &774 *(hsnif(sec%listPoint(jseg)%I,sec%listPoint(jseg)%J) + &775 hicif(sec%listPoint(jseg)%I,sec%listPoint(jseg)%J))776 transports_2d(2,jsec,jseg) = transports_2d(2,jsec,jseg) + (zTnorm)* &777 (1.0 - frld(sec%listPoint(jseg)%I,sec%listPoint(jseg)%J))778 #endif779 768 #if defined key_lim3 780 769 DO jl=1,jpl 781 transports_2d(1,jsec,jseg) = transports_2d(1,jsec,jseg) + (zTnorm)* &782 a_i(sec%listPoint(jseg)%I,sec%listPoint(jseg)%J,jl) *&783 ( h t_i(sec%listPoint(jseg)%I,sec%listPoint(jseg)%J,jl) + &784 h t_s(sec%listPoint(jseg)%I,sec%listPoint(jseg)%J,jl) )770 transports_2d(1,jsec,jseg) = transports_2d(1,jsec,jseg) + (zTnorm)* & 771 a_i(sec%listPoint(jseg)%I,sec%listPoint(jseg)%J,jl) * & 772 ( h_i(sec%listPoint(jseg)%I,sec%listPoint(jseg)%J,jl) + & 773 h_s(sec%listPoint(jseg)%I,sec%listPoint(jseg)%J,jl) ) 785 774 786 775 transports_2d(2,jsec,jseg) = transports_2d(2,jsec,jseg) + (zTnorm)* & 787 a_i(sec%listPoint(jseg)%I,sec%listPoint(jseg)%J,jl)776 a_i(sec%listPoint(jseg)%I,sec%listPoint(jseg)%J,jl) 788 777 END DO 789 778 #endif … … 960 949 ENDDO ! loop over jk 961 950 962 #if defined key_lim 2 || defined key_lim3951 #if defined key_lim3 963 952 964 953 !ICE CASE -
branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/NEMO/OPA_SRC/DIA/diawri.F90
r8878 r8879 51 51 USE ioipsl 52 52 53 #if defined key_lim2 54 USE limwri_2 55 #elif defined key_lim3 56 USE limwri 53 #if defined key_lim3 54 USE icewri 57 55 #endif 58 56 USE lib_mpp ! MPP library … … 707 705 #endif 708 706 709 IF( ln_cpl .AND. nn_ice == 2 ) THEN710 CALL histdef( nid_T,"soicetem" , "Ice Surface Temperature" , "K" , & ! tn_ice711 & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout )712 CALL histdef( nid_T,"soicealb" , "Ice Albedo" , "[0,1]" , & ! alb_ice713 & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout )714 ENDIF715 716 707 CALL histend( nid_T, snc4chunks=snc4set ) 717 708 … … 861 852 #endif 862 853 863 IF( ln_cpl .AND. nn_ice == 2 ) THEN864 CALL histwrite( nid_T, "soicetem", it, tn_ice(:,:,1) , ndim_hT, ndex_hT ) ! surf. ice temperature865 CALL histwrite( nid_T, "soicealb", it, alb_ice(:,:,1), ndim_hT, ndex_hT ) ! ice albedo866 ENDIF867 868 854 CALL histwrite( nid_U, "vozocrtx", it, un , ndim_U , ndex_U ) ! i-current 869 855 CALL histwrite( nid_U, "sozotaux", it, utau , ndim_hU, ndex_hU ) ! i-wind stress … … 1009 995 ENDIF 1010 996 1011 #if defined key_lim 21012 CALL lim_wri_state_2( kt, id_i, nh_i )1013 #elif defined key_lim3 1014 CALL lim_wri_state( kt, id_i, nh_i )997 #if defined key_lim3 998 IF( nn_ice == 2 ) THEN ! clem2017: condition in case agrif + lim but no-ice in child grid 999 CALL ice_wri_state( kt, id_i, nh_i ) 1000 ENDIF 1015 1001 #else 1016 1002 CALL histend( id_i, snc4chunks=snc4set ) -
branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/NEMO/OPA_SRC/DOM/iscplhsb.F90
r8877 r8879 184 184 END DO 185 185 186 CALL lbc_sum(pvol_flx(:,:,: ),'T',1.) 187 CALL lbc_sum(pts_flx (:,:,:,jp_sal),'T',1.) 188 CALL lbc_sum(pts_flx (:,:,:,jp_tem),'T',1.) 189 186 !!gm ERROR !!!! 187 !! juste use tmask_i or in case of ISF smask_i (to be created to compute the sum without halos) 188 ! 189 ! CALL lbc_sum(pvol_flx(:,:,: ),'T',1.) 190 ! CALL lbc_sum(pts_flx (:,:,:,jp_sal),'T',1.) 191 ! CALL lbc_sum(pts_flx (:,:,:,jp_tem),'T',1.) 192 STOP ' iscpl_cons: please modify this module !' 193 !!gm end 190 194 ! if no neighbour wet cell in case of 2close a cell", need to find the nearest wet point 191 195 ! allocation and initialisation of the list of problematic point … … 283 287 pts_flx (:,:,:,jp_tem) = pts_flx (:,:,:,jp_tem) * tmask(:,:,:) 284 288 285 ! compute sum over the halo and set it to 0. 286 CALL lbc_sum(pvol_flx(:,:,: ),'T',1._wp) 287 CALL lbc_sum(pts_flx (:,:,:,jp_sal),'T',1._wp) 288 CALL lbc_sum(pts_flx (:,:,:,jp_tem),'T',1._wp) 289 !!gm ERROR !!!! 290 !! juste use tmask_i or in case of ISF smask_i (to be created to compute the sum without halos) 291 ! 292 ! ! compute sum over the halo and set it to 0. 293 ! CALL lbc_sum(pvol_flx(:,:,: ),'T',1._wp) 294 ! CALL lbc_sum(pts_flx (:,:,:,jp_sal),'T',1._wp) 295 ! CALL lbc_sum(pts_flx (:,:,:,jp_tem),'T',1._wp) 296 !!gm end 289 297 290 298 ! deallocate variables -
branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/NEMO/OPA_SRC/DOM/phycst.F90
r8877 r8879 54 54 55 55 REAL(wp), PUBLIC :: rhosn = 330._wp !: volumic mass of snow [kg/m3] 56 ! MV MP 2016 57 REAL(wp), PUBLIC :: rhofw = 1000._wp !: volumic mass of freshwater in melt ponds [kg/m3] 58 ! END MV MP 2016 56 59 REAL(wp), PUBLIC :: emic = 0.97_wp !: emissivity of snow or ice 57 60 REAL(wp), PUBLIC :: sice = 6.0_wp !: salinity of ice [psu] … … 88 91 REAL(wp), PUBLIC :: r1_rhoic !: 1 / rhoic 89 92 REAL(wp), PUBLIC :: r1_rhosn !: 1 / rhosn 93 REAL(wp), PUBLIC :: r1_cpic !: 1 / cpic 90 94 #endif 91 95 !!---------------------------------------------------------------------- … … 156 160 r1_rhoic = 1._wp / rhoic 157 161 r1_rhosn = 1._wp / rhosn 162 r1_cpic = 1._wp / cpic 158 163 #endif 159 164 IF(lwp) THEN … … 176 181 WRITE(numout,*) ' density of sea ice = ', rhoic , ' kg/m^3' 177 182 WRITE(numout,*) ' density of snow = ', rhosn , ' kg/m^3' 183 WRITE(numout,*) ' density of freshwater (in melt ponds) = ', rhofw , ' kg/m^3' 178 184 WRITE(numout,*) ' emissivity of snow or ice = ', emic 179 185 WRITE(numout,*) ' salinity of ice = ', sice , ' psu' -
branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/NEMO/OPA_SRC/DYN/divhor.F90
r8877 r8879 82 82 END DO 83 83 END DO 84 IF( .NOT. AGRIF_Root() ) THEN85 IF( nbondi == 1 .OR. nbondi == 2 ) hdivn(nlci-1, : ,jk) = 0._wp ! east86 IF( nbondi == -1 .OR. nbondi == 2 ) hdivn( 2 , : ,jk) = 0._wp ! west87 IF( nbondj == 1 .OR. nbondj == 2 ) hdivn( : ,nlcj-1,jk) = 0._wp ! north88 IF( nbondj == -1 .OR. nbondj == 2 ) hdivn( : , 2 ,jk) = 0._wp ! south89 ENDIF90 84 END DO 85 #if defined key_agrif 86 IF( .NOT. Agrif_Root() ) THEN 87 IF( nbondi == -1 .OR. nbondi == 2 ) hdivn( 2:nbghostcells+1,: ,:) = 0._wp ! west 88 IF( nbondi == 1 .OR. nbondi == 2 ) hdivn( nlci-nbghostcells:nlci-1,:,:) = 0._wp ! east 89 IF( nbondj == -1 .OR. nbondj == 2 ) hdivn( :,2:nbghostcells+1 ,:) = 0._wp ! south 90 IF( nbondj == 1 .OR. nbondj == 2 ) hdivn( :,nlcj-nbghostcells:nlcj-1,:) = 0._wp ! north 91 ENDIF 92 #endif 91 93 ! 92 94 IF( ln_rnf ) CALL sbc_rnf_div( hdivn ) !== runoffs ==! (update hdivn field) -
branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/NEMO/OPA_SRC/DYN/dynspg.F90
r8877 r8879 17 17 USE phycst ! physical constants 18 18 USE sbc_oce ! surface boundary condition: ocean 19 USE sbc_ice , ONLY : snwice_mass, snwice_mass_b 19 20 USE sbcapr ! surface boundary condition: atmospheric pressure 20 21 USE dynspg_exp ! surface pressure gradient (dyn_spg_exp routine) … … 89 90 IF( ln_apr_dyn & ! atmos. pressure 90 91 .OR. ( .NOT.ln_dynspg_ts .AND. (ln_tide_pot .AND. ln_tide) ) & ! tide potential (no time slitting) 91 .OR. nn_ice_embd == 2 ) THEN! embedded sea-ice92 .OR. ln_ice_embd ) THEN ! embedded sea-ice 92 93 ! 93 94 DO jj = 2, jpjm1 … … 123 124 ENDIF 124 125 ! 125 IF( nn_ice_embd == 2) THEN !== embedded sea ice: Pressure gradient due to snow-ice mass ==!126 IF( ln_ice_embd ) THEN !== embedded sea ice: Pressure gradient due to snow-ice mass ==! 126 127 CALL wrk_alloc( jpi,jpj, zpice ) 127 128 ! -
branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/NEMO/OPA_SRC/DYN/dynspg_ts.F90
r8877 r8879 686 686 IF((nbondi == -1).OR.(nbondi == 2)) THEN 687 687 DO jj=1,jpj 688 zwx(2 ,jj) = ubdy_w(jj) * e2u(2,jj)688 zwx(2:nbghostcells+1,jj) = ubdy_w(jj) * e2u(2:nbghostcells+1,jj) 689 689 END DO 690 690 ENDIF 691 691 IF((nbondi == 1).OR.(nbondi == 2)) THEN 692 692 DO jj=1,jpj 693 zwx(nlci- 2,jj) = ubdy_e(jj) * e2u(nlci-2,jj)693 zwx(nlci-nbghostcells-1:nlci-2,jj) = ubdy_e(jj) * e2u(nlci-nbghostcells-1:nlci-2,jj) 694 694 END DO 695 695 ENDIF 696 696 IF((nbondj == -1).OR.(nbondj == 2)) THEN 697 697 DO ji=1,jpi 698 zwy(ji,2 ) = vbdy_s(ji) * e1v(ji,2)698 zwy(ji,2:nbghostcells+1) = vbdy_s(ji) * e1v(ji,2:nbghostcells+1) 699 699 END DO 700 700 ENDIF 701 701 IF((nbondj == 1).OR.(nbondj == 2)) THEN 702 702 DO ji=1,jpi 703 zwy(ji,nlcj- 2) = vbdy_n(ji) * e1v(ji,nlcj-2)703 zwy(ji,nlcj-nbghostcells-1:nlcj-2) = vbdy_n(ji) * e1v(ji,nlcj-nbghostcells-1:nlcj-2) 704 704 END DO 705 705 ENDIF -
branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/NEMO/OPA_SRC/ICB/icb_oce.F90
r8877 r8879 90 90 REAL(wp), PUBLIC, DIMENSION(:,:), ALLOCATABLE :: ua_e, va_e 91 91 REAL(wp), PUBLIC, DIMENSION(:,:), ALLOCATABLE :: ssh_e 92 #if defined key_lim 2 || defined key_lim3 || defined key_cice92 #if defined key_lim3 || defined key_cice 93 93 REAL(wp), PUBLIC, DIMENSION(:,:), ALLOCATABLE :: ui_e, vi_e 94 94 #endif … … 170 170 ALLOCATE( uo_e(0:jpi+1,0:jpj+1) , ua_e(0:jpi+1,0:jpj+1) , & 171 171 & vo_e(0:jpi+1,0:jpj+1) , va_e(0:jpi+1,0:jpj+1) , & 172 #if defined key_lim 2 || defined key_lim3 || defined key_cice172 #if defined key_lim3 || defined key_cice 173 173 & ui_e(0:jpi+1,0:jpj+1) , & 174 174 & vi_e(0:jpi+1,0:jpj+1) , & -
branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/NEMO/OPA_SRC/ICB/icbutl.F90
r8877 r8879 21 21 USE icb_oce ! define iceberg arrays 22 22 USE sbc_oce ! ocean surface boundary conditions 23 #if defined key_lim2 24 USE ice_2, ONLY: u_ice, v_ice ! LIM-2 ice velocities (CAUTION in C-grid do not use key_vp option) 25 USE ice_2, ONLY: hicif ! LIM-2 ice thickness 26 #elif defined key_lim3 27 USE ice, ONLY: u_ice, v_ice ! LIM-3 variables (always in C-grid) 28 ! gm LIM3 case the mean ice thickness (i.e. averaged over categories) 29 ! gm has to be computed somewhere in the ice and accessed here 23 #if defined key_lim3 24 USE ice, ONLY: u_ice, v_ice, hm_i ! LIM-3 variables 30 25 #endif 31 26 … … 85 80 CALL lbc_lnk_icb( fr_e, 'T', +1._wp, 1, 1 ) 86 81 CALL lbc_lnk_icb( tt_e, 'T', +1._wp, 1, 1 ) 87 #if defined key_lim2 88 hicth(:,:) = 0._wp ; hicth(1:jpi,1:jpj) = hicif(:,:) 89 CALL lbc_lnk_icb(hicth, 'T', +1._wp, 1, 1 ) 90 #endif 91 92 #if defined key_lim2 || defined key_lim3 82 #if defined key_lim3 83 hicth(:,:) = 0._wp ; hicth(1:jpi,1:jpj) = hm_i (:,:) 93 84 ui_e(:,:) = 0._wp ; ui_e(1:jpi, 1:jpj) = u_ice(:,:) 94 85 vi_e(:,:) = 0._wp ; vi_e(1:jpi, 1:jpj) = v_ice(:,:) 95 86 CALL lbc_lnk_icb(hicth, 'T', +1._wp, 1, 1 ) 96 87 CALL lbc_lnk_icb( ui_e, 'U', -1._wp, 1, 1 ) 97 88 CALL lbc_lnk_icb( vi_e, 'V', -1._wp, 1, 1 ) … … 157 148 pva = pva * zmod 158 149 159 #if defined key_lim 2 || defined key_lim3150 #if defined key_lim3 160 151 pui = icb_utl_bilin_h( ui_e, pi, pj, 'U' ) ! sea-ice velocities 161 152 pvi = icb_utl_bilin_h( vi_e, pi, pj, 'V' ) 162 # if defined key_lim3163 phi = 0._wp ! LIM-3 case (to do)164 # else165 153 phi = icb_utl_bilin_h(hicth, pi, pj, 'T' ) ! ice thickness 166 # endif167 154 #else 168 155 pui = 0._wp -
branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/NEMO/OPA_SRC/IOM/in_out_manager.F90
r8877 r8879 88 88 INTEGER :: nitrst !: time step at which restart file should be written 89 89 LOGICAL :: lrst_oce !: logical to control the oce restart write 90 LOGICAL :: lrst_ice !: logical to control the ice restart write 90 91 INTEGER :: numror = 0 !: logical unit for ocean restart (read). Init to 0 is needed for SAS (in daymod.F90) 92 INTEGER :: numrir !: logical unit for ice restart (read) 91 93 INTEGER :: numrow !: logical unit for ocean restart (write) 94 INTEGER :: numriw !: logical unit for ice restart (write) 92 95 INTEGER :: nrst_lst !: number of restart to output next 93 96 … … 126 129 INTEGER :: numoni = -1 !: logical unit for Output Namelist Ice 127 130 INTEGER :: numevo_ice = -1 !: logical unit for ice variables (temp. evolution) 128 INTEGER :: num sol = -1 !: logical unit for solverstatistics131 INTEGER :: numrun = -1 !: logical unit for run statistics 129 132 INTEGER :: numdct_in = -1 !: logical unit for transports computing 130 133 INTEGER :: numdct_vol = -1 !: logical unit for voulume transports output -
branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/NEMO/OPA_SRC/IOM/iom.F90
r8877 r8879 34 34 #if defined key_lim3 35 35 USE ice , ONLY : jpl 36 #elif defined key_lim237 USE par_ice_238 36 #endif 39 37 USE domngb ! ocean space and time domain … … 193 191 CALL iom_set_axis_attr( "nfloat", (/ (REAL(ji,wp), ji=1,nfloat) /) ) 194 192 # endif 195 #if defined key_lim3 || defined key_lim2193 #if defined key_lim3 196 194 CALL iom_set_axis_attr( "ncatice", (/ (REAL(ji,wp), ji=1,jpl) /) ) 195 ! SIMIP diagnostics (4 main arctic straits) 196 CALL iom_set_axis_attr( "nstrait", (/ (REAL(ji,wp), ji=1,4) /) ) 197 197 #endif 198 198 CALL iom_set_axis_attr( "icbcla", class_num ) -
branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/NEMO/OPA_SRC/LBC/lbclnk.F90
r8877 r8879 2 2 !!====================================================================== 3 3 !! *** MODULE lbclnk *** 4 !! Ocean: lateral boundary conditions4 !! NEMO : lateral boundary conditions 5 5 !!===================================================================== 6 6 !! History : OPA ! 1997-06 (G. Madec) Original code 7 7 !! NEMO 1.0 ! 2002-09 (G. Madec) F90: Free form and module 8 8 !! 3.2 ! 2009-03 (R. Benshila) External north fold treatment 9 !! 3.5 ! 2012 (S.Mocavero, I. Epicoco) optimization of BDY comm. via lbc_bdy_lnk and lbc_obc_lnk9 !! 3.5 ! 2012 (S.Mocavero, I. Epicoco) optimization of BDY comm. via lbc_bdy_lnk and lbc_obc_lnk 10 10 !! 3.4 ! 2012-12 (R. Bourdalle-Badie, G. Reffray) add a C1D case 11 11 !! 3.6 ! 2015-06 (O. Tintó and M. Castrillo) add lbc_lnk_multi 12 !! 4.0 ! 2017-03 (G. Madec) automatique allocation of array size (use with any 3rd dim size) 13 !! - ! 2017-04 (G. Madec) remove duplicated routines (lbc_lnk_2d_9, lbc_lnk_2d_multiple, lbc_lnk_3d_gather) 14 !! - ! 2017-05 (G. Madec) create generic.h90 files to generate all lbc and north fold routines 12 15 !!---------------------------------------------------------------------- 13 16 #if defined key_mpp_mpi … … 15 18 !! 'key_mpp_mpi' MPI massively parallel processing library 16 19 !!---------------------------------------------------------------------- 17 !! lbc_lnk : generic interface for mpp_lnk_3d and mpp_lnk_2d routines defined in lib_mpp 18 !! lbc_sum : generic interface for mpp_lnk_sum_3d and mpp_lnk_sum_2d routines defined in lib_mpp 19 !! lbc_lnk_e : generic interface for mpp_lnk_2d_e routine defined in lib_mpp 20 !! lbc_bdy_lnk : generic interface for mpp_lnk_bdy_2d and mpp_lnk_bdy_3d routines defined in lib_mpp 21 !!---------------------------------------------------------------------- 20 !! define the generic interfaces of lib_mpp routines 21 !!---------------------------------------------------------------------- 22 !! lbc_lnk : generic interface for mpp_lnk_3d and mpp_lnk_2d routines defined in lib_mpp 23 !! lbc_lnk_e : generic interface for mpp_lnk_2d_e routine defined in lib_mpp 24 !! lbc_bdy_lnk : generic interface for mpp_lnk_bdy_2d and mpp_lnk_bdy_3d routines defined in lib_mpp 25 !!---------------------------------------------------------------------- 26 USE par_oce ! ocean dynamics and tracers 22 27 USE lib_mpp ! distributed memory computing library 23 28 USE lbcnfd ! north fold 29 30 INTERFACE lbc_lnk 31 MODULE PROCEDURE mpp_lnk_2d , mpp_lnk_3d , mpp_lnk_4d 32 END INTERFACE 33 INTERFACE lbc_lnk_ptr 34 MODULE PROCEDURE mpp_lnk_2d_ptr , mpp_lnk_3d_ptr , mpp_lnk_4d_ptr 35 END INTERFACE 24 36 INTERFACE lbc_lnk_multi 25 MODULE PROCEDURE mpp_lnk_2d_9, mpp_lnk_2d_multiple 26 END INTERFACE 27 ! 28 INTERFACE lbc_lnk 29 MODULE PROCEDURE mpp_lnk_3d_gather, mpp_lnk_3d, mpp_lnk_2d 30 END INTERFACE 31 ! 32 INTERFACE lbc_sum 33 MODULE PROCEDURE mpp_lnk_sum_3d, mpp_lnk_sum_2d 37 MODULE PROCEDURE lbc_lnk_2d_multi, lbc_lnk_3d_multi, lbc_lnk_4d_multi 34 38 END INTERFACE 35 39 ! … … 46 50 END INTERFACE 47 51 48 PUBLIC lbc_lnk ! ocean lateral boundary conditions 49 PUBLIC lbc_lnk_multi ! modified ocean lateral boundary conditions 50 PUBLIC lbc_sum 51 PUBLIC lbc_lnk_e ! 52 PUBLIC lbc_lnk ! ocean/ice lateral boundary conditions 53 PUBLIC lbc_lnk_multi ! modified ocean/ice lateral boundary conditions 54 PUBLIC lbc_lnk_e ! extended ocean/ice lateral boundary conditions 52 55 PUBLIC lbc_bdy_lnk ! ocean lateral BDY boundary conditions 53 PUBLIC lbc_lnk_icb ! 56 PUBLIC lbc_lnk_icb ! iceberg lateral boundary conditions 54 57 55 58 !!---------------------------------------------------------------------- … … 58 61 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 59 62 !!---------------------------------------------------------------------- 63 CONTAINS 64 60 65 #else 61 66 !!---------------------------------------------------------------------- 62 67 !! Default option shared memory computing 63 68 !!---------------------------------------------------------------------- 64 !! lbc_sum : generic interface for mpp_lnk_sum_3d and mpp_lnk_sum_2d 69 !! routines setting the appropriate values 70 !! on first and last row and column of the global domain 71 !!---------------------------------------------------------------------- 65 72 !! lbc_lnk_sum_3d: compute sum over the halos on a 3D variable on ocean mesh 66 73 !! lbc_lnk_sum_3d: compute sum over the halos on a 2D variable on ocean mesh … … 70 77 !! lbc_bdy_lnk : set the lateral BDY boundary condition 71 78 !!---------------------------------------------------------------------- 72 USE oce 73 USE dom_oce 74 USE in_out_manager 75 USE lbcnfd 79 USE oce ! ocean dynamics and tracers 80 USE dom_oce ! ocean space and time domain 81 USE in_out_manager ! I/O manager 82 USE lbcnfd ! north fold 76 83 77 84 IMPLICIT NONE … … 79 86 80 87 INTERFACE lbc_lnk 81 MODULE PROCEDURE lbc_lnk_3d_gather, lbc_lnk_3d, lbc_lnk_2d 82 END INTERFACE 83 ! 84 INTERFACE lbc_sum 85 MODULE PROCEDURE lbc_lnk_sum_3d, lbc_lnk_sum_2d 86 END INTERFACE 87 88 MODULE PROCEDURE lbc_lnk_2d , lbc_lnk_3d , lbc_lnk_4d 89 END INTERFACE 90 INTERFACE lbc_lnk_ptr 91 MODULE PROCEDURE lbc_lnk_2d_ptr , lbc_lnk_3d_ptr , lbc_lnk_4d_ptr 92 END INTERFACE 93 INTERFACE lbc_lnk_multi 94 MODULE PROCEDURE lbc_lnk_2d_multi, lbc_lnk_3d_multi, lbc_lnk_4d_multi 95 END INTERFACE 96 ! 88 97 INTERFACE lbc_lnk_e 89 98 MODULE PROCEDURE lbc_lnk_2d_e 90 99 END INTERFACE 91 100 ! 92 INTERFACE lbc_lnk_multi93 MODULE PROCEDURE lbc_lnk_2d_9, lbc_lnk_2d_multiple94 END INTERFACE95 96 101 INTERFACE lbc_bdy_lnk 97 102 MODULE PROCEDURE lbc_bdy_lnk_2d, lbc_bdy_lnk_3d … … 102 107 END INTERFACE 103 108 104 TYPE arrayptr105 REAL , DIMENSION (:,:), POINTER :: pt2d106 END TYPE arrayptr107 PUBLIC arrayptr108 109 109 PUBLIC lbc_lnk ! ocean/ice lateral boundary conditions 110 PUBLIC lbc_sum ! ocean/ice lateral boundary conditions (sum of the overlap region) 111 PUBLIC lbc_lnk_e ! 112 PUBLIC lbc_lnk_multi ! modified ocean lateral boundary conditions 110 PUBLIC lbc_lnk_e ! extended ocean/ice lateral boundary conditions 111 PUBLIC lbc_lnk_multi ! modified ocean/ice lateral boundary conditions 113 112 PUBLIC lbc_bdy_lnk ! ocean lateral BDY boundary conditions 114 PUBLIC lbc_lnk_icb ! 113 PUBLIC lbc_lnk_icb ! iceberg lateral boundary conditions 115 114 116 115 !!---------------------------------------------------------------------- … … 122 121 123 122 # if defined key_c1d 124 !! ----------------------------------------------------------------------123 !!====================================================================== 125 124 !! 'key_c1d' 1D configuration 126 !!---------------------------------------------------------------------- 127 128 SUBROUTINE lbc_lnk_3d_gather( pt3d1, cd_type1, pt3d2, cd_type2, psgn ) 129 !!--------------------------------------------------------------------- 130 !! *** ROUTINE lbc_lnk_3d_gather *** 131 !! 132 !! ** Purpose : set lateral boundary conditions on two 3D arrays (C1D case) 133 !! 134 !! ** Method : call lbc_lnk_3d on pt3d1 and pt3d2 135 !!---------------------------------------------------------------------- 136 CHARACTER(len=1) , INTENT(in ) :: cd_type1, cd_type2 ! nature of pt3d grid-points 137 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pt3d1 , pt3d2 ! 3D array on which the lbc is applied 138 REAL(wp) , INTENT(in ) :: psgn ! control of the sign 139 !!---------------------------------------------------------------------- 140 ! 141 CALL lbc_lnk_3d( pt3d1, cd_type1, psgn) 142 CALL lbc_lnk_3d( pt3d2, cd_type2, psgn) 143 ! 144 END SUBROUTINE lbc_lnk_3d_gather 145 125 !!====================================================================== 126 !! central point value replicated over the 8 surrounding points 127 !!---------------------------------------------------------------------- 146 128 147 129 SUBROUTINE lbc_lnk_3d( pt3d, cd_type, psgn, cd_mpp, pval ) … … 153 135 !! ** Method : 1D case, the central water column is set everywhere 154 136 !!---------------------------------------------------------------------- 155 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points156 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pt3d ! 3D array on which the lbc is applied157 REAL(wp) , INTENT(in ) :: psgn ! control of the sign158 CHARACTER(len=3) 159 REAL(wp) 137 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pt3d ! 3D array on which the lbc is applied 138 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points 139 REAL(wp) , INTENT(in ) :: psgn ! sign used across north fold 140 CHARACTER(len=3) , INTENT(in ), OPTIONAL :: cd_mpp ! MPP only (here do nothing) 141 REAL(wp) , INTENT(in ), OPTIONAL :: pval ! background value (for closed boundaries) 160 142 ! 161 143 INTEGER :: jk ! dummy loop index … … 163 145 !!---------------------------------------------------------------------- 164 146 ! 165 DO jk = 1, jpk147 DO jk = 1, SIZE( pt3d, 3 ) 166 148 ztab = pt3d(2,2,jk) 167 149 pt3d(:,:,jk) = ztab … … 179 161 !! ** Method : 1D case, the central water column is set everywhere 180 162 !!---------------------------------------------------------------------- 163 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pt2d ! 2D array on which the lbc is applied 181 164 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points 182 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pt2d ! 2D array on which the lbc is applied 183 REAL(wp) , INTENT(in ) :: psgn ! control of the sign 165 REAL(wp) , INTENT(in ) :: psgn ! sign used across north fold 184 166 CHARACTER(len=3) , INTENT(in ), OPTIONAL :: cd_mpp ! MPP only (here do nothing) 185 167 REAL(wp) , INTENT(in ), OPTIONAL :: pval ! background value (for closed boundaries) … … 193 175 END SUBROUTINE lbc_lnk_2d 194 176 195 SUBROUTINE lbc_lnk_2d_multiple( pt2d_array , type_array , psgn_array , num_fields )196 !!197 INTEGER :: num_fields198 TYPE( arrayptr ), DIMENSION(:) :: pt2d_array199 CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: type_array ! define the nature of ptab array grid-points200 ! ! = T , U , V , F , W and I points201 REAL(wp) , DIMENSION(:), INTENT(in ) :: psgn_array ! =-1 the sign change across the north fold boundary202 ! ! = 1. , the sign is kept203 !204 INTEGER :: ii !!MULTI SEND DUMMY LOOP INDICES205 !206 DO ii = 1, num_fields207 CALL lbc_lnk_2d( pt2d_array(ii)%pt2d, type_array(ii), psgn_array(ii) )208 END DO209 !210 END SUBROUTINE lbc_lnk_2d_multiple211 212 SUBROUTINE lbc_lnk_2d_9( pt2dA, cd_typeA, psgnA, pt2dB, cd_typeB, psgnB, pt2dC, cd_typeC, psgnC &213 & , pt2dD, cd_typeD, psgnD, pt2dE, cd_typeE, psgnE, pt2dF, cd_typeF, psgnF &214 & , pt2dG, cd_typeG, psgnG, pt2dH, cd_typeH, psgnH, pt2dI, cd_typeI, psgnI, cd_mpp, pval)215 !!---------------------------------------------------------------------216 ! Second 2D array on which the boundary condition is applied217 REAL(wp), DIMENSION(jpi,jpj), TARGET , INTENT(inout) :: pt2dA218 REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) :: pt2dB , pt2dC , pt2dD , pt2dE219 REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) :: pt2dF , pt2dG , pt2dH , pt2dI220 ! define the nature of ptab array grid-points221 CHARACTER(len=1) , INTENT(in ) :: cd_typeA222 CHARACTER(len=1) , OPTIONAL, INTENT(in ) :: cd_typeB , cd_typeC , cd_typeD , cd_typeE223 CHARACTER(len=1) , OPTIONAL, INTENT(in ) :: cd_typeF , cd_typeG , cd_typeH , cd_typeI224 ! =-1 the sign change across the north fold boundary225 REAL(wp) , INTENT(in ) :: psgnA226 REAL(wp) , OPTIONAL, INTENT(in ) :: psgnB , psgnC , psgnD , psgnE227 REAL(wp) , OPTIONAL, INTENT(in ) :: psgnF , psgnG , psgnH , psgnI228 CHARACTER(len=3) , OPTIONAL, INTENT(in ) :: cd_mpp ! fill the overlap area only229 REAL(wp) , OPTIONAL, INTENT(in ) :: pval ! background value (used at closed boundaries)230 !!231 !!---------------------------------------------------------------------232 233 !!The first array234 CALL lbc_lnk( pt2dA, cd_typeA, psgnA )235 236 !! Look if more arrays to process237 IF(PRESENT (psgnB) )CALL lbc_lnk( pt2dB, cd_typeB, psgnB )238 IF(PRESENT (psgnC) )CALL lbc_lnk( pt2dC, cd_typeC, psgnC )239 IF(PRESENT (psgnD) )CALL lbc_lnk( pt2dD, cd_typeD, psgnD )240 IF(PRESENT (psgnE) )CALL lbc_lnk( pt2dE, cd_typeE, psgnE )241 IF(PRESENT (psgnF) )CALL lbc_lnk( pt2dF, cd_typeF, psgnF )242 IF(PRESENT (psgnG) )CALL lbc_lnk( pt2dG, cd_typeG, psgnG )243 IF(PRESENT (psgnH) )CALL lbc_lnk( pt2dH, cd_typeH, psgnH )244 IF(PRESENT (psgnI) )CALL lbc_lnk( pt2dI, cd_typeI, psgnI )245 246 END SUBROUTINE lbc_lnk_2d_9247 248 249 250 251 252 177 #else 253 !! ----------------------------------------------------------------------178 !!====================================================================== 254 179 !! Default option 3D shared memory computing 255 !!---------------------------------------------------------------------- 256 257 SUBROUTINE lbc_lnk_3d_gather( pt3d1, cd_type1, pt3d2, cd_type2, psgn ) 258 !!--------------------------------------------------------------------- 259 !! *** ROUTINE lbc_lnk_3d_gather *** 260 !! 261 !! ** Purpose : set lateral boundary conditions on two 3D arrays (non mpp case) 262 !! 263 !! ** Method : psign = -1 : change the sign across the north fold 264 !! = 1 : no change of the sign across the north fold 265 !! = 0 : no change of the sign across the north fold and 266 !! strict positivity preserved: use inner row/column 267 !! for closed boundaries. 268 !!---------------------------------------------------------------------- 269 CHARACTER(len=1) , INTENT(in ) :: cd_type1, cd_type2 ! nature of pt3d grid-points 270 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pt3d1 , pt3d2 ! 3D array on which the lbc is applied 271 REAL(wp) , INTENT(in ) :: psgn ! control of the sign 272 !!---------------------------------------------------------------------- 273 ! 274 CALL lbc_lnk_3d( pt3d1, cd_type1, psgn) 275 CALL lbc_lnk_3d( pt3d2, cd_type2, psgn) 276 ! 277 END SUBROUTINE lbc_lnk_3d_gather 278 279 280 SUBROUTINE lbc_lnk_3d( pt3d, cd_type, psgn, cd_mpp, pval ) 281 !!--------------------------------------------------------------------- 282 !! *** ROUTINE lbc_lnk_3d *** 283 !! 284 !! ** Purpose : set lateral boundary conditions on a 3D array (non mpp case) 285 !! 286 !! ** Method : psign = -1 : change the sign across the north fold 287 !! = 1 : no change of the sign across the north fold 288 !! = 0 : no change of the sign across the north fold and 289 !! strict positivity preserved: use inner row/column 290 !! for closed boundaries. 291 !!---------------------------------------------------------------------- 292 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points 293 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pt3d ! 3D array on which the lbc is applied 294 REAL(wp) , INTENT(in ) :: psgn ! control of the sign 295 CHARACTER(len=3) , INTENT(in ), OPTIONAL :: cd_mpp ! MPP only (here do nothing) 296 REAL(wp) , INTENT(in ), OPTIONAL :: pval ! background value (for closed boundaries) 297 !! 298 REAL(wp) :: zland 299 !!---------------------------------------------------------------------- 300 301 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value (zero by default) 302 ELSE ; zland = 0._wp 303 ENDIF 304 305 306 IF( PRESENT( cd_mpp ) ) THEN 307 ! only fill the overlap area and extra allows 308 ! this is in mpp case. In this module, just do nothing 309 ELSE 310 ! ! East-West boundaries 311 ! ! ====================== 312 SELECT CASE ( nperio ) 313 ! 314 CASE ( 1 , 4 , 6 ) !** cyclic east-west 315 pt3d( 1 ,:,:) = pt3d(jpim1,:,:) ! all points 316 pt3d(jpi,:,:) = pt3d( 2 ,:,:) 317 ! 318 CASE DEFAULT !** East closed -- West closed 319 SELECT CASE ( cd_type ) 320 CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points 321 pt3d( 1 ,:,:) = zland 322 pt3d(jpi,:,:) = zland 323 CASE ( 'F' ) ! F-point 324 pt3d(jpi,:,:) = zland 325 END SELECT 326 ! 327 END SELECT 328 ! ! North-South boundaries 329 ! ! ====================== 330 SELECT CASE ( nperio ) 331 ! 332 CASE ( 2 ) !** South symmetric -- North closed 333 SELECT CASE ( cd_type ) 334 CASE ( 'T' , 'U' , 'W' ) ! T-, U-, W-points 335 pt3d(:, 1 ,:) = pt3d(:,3,:) 336 pt3d(:,jpj,:) = zland 337 CASE ( 'V' , 'F' ) ! V-, F-points 338 pt3d(:, 1 ,:) = psgn * pt3d(:,2,:) 339 pt3d(:,jpj,:) = zland 340 END SELECT 341 ! 342 CASE ( 3 , 4 , 5 , 6 ) !** North fold T or F-point pivot -- South closed 343 SELECT CASE ( cd_type ) ! South : closed 344 CASE ( 'T' , 'U' , 'V' , 'W' , 'I' ) ! all points except F-point 345 pt3d(:, 1 ,:) = zland 346 END SELECT 347 ! ! North fold 348 CALL lbc_nfd( pt3d(:,:,:), cd_type, psgn ) 349 ! 350 CASE DEFAULT !** North closed -- South closed 351 SELECT CASE ( cd_type ) 352 CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points 353 pt3d(:, 1 ,:) = zland 354 pt3d(:,jpj,:) = zland 355 CASE ( 'F' ) ! F-point 356 pt3d(:,jpj,:) = zland 357 END SELECT 358 ! 359 END SELECT 360 ! 361 ENDIF 362 ! 363 END SUBROUTINE lbc_lnk_3d 364 365 366 SUBROUTINE lbc_lnk_2d( pt2d, cd_type, psgn, cd_mpp, pval ) 367 !!--------------------------------------------------------------------- 368 !! *** ROUTINE lbc_lnk_2d *** 369 !! 370 !! ** Purpose : set lateral boundary conditions on a 2D array (non mpp case) 371 !! 372 !! ** Method : psign = -1 : change the sign across the north fold 373 !! = 1 : no change of the sign across the north fold 374 !! = 0 : no change of the sign across the north fold and 375 !! strict positivity preserved: use inner row/column 376 !! for closed boundaries. 377 !!---------------------------------------------------------------------- 378 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points 379 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pt2d ! 2D array on which the lbc is applied 380 REAL(wp) , INTENT(in ) :: psgn ! control of the sign 381 CHARACTER(len=3) , INTENT(in ), OPTIONAL :: cd_mpp ! MPP only (here do nothing) 382 REAL(wp) , INTENT(in ), OPTIONAL :: pval ! background value (for closed boundaries) 383 !! 384 REAL(wp) :: zland 385 !!---------------------------------------------------------------------- 386 387 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value (zero by default) 388 ELSE ; zland = 0._wp 389 ENDIF 390 391 IF (PRESENT(cd_mpp)) THEN 392 ! only fill the overlap area and extra allows 393 ! this is in mpp case. In this module, just do nothing 394 ELSE 395 ! ! East-West boundaries 396 ! ! ==================== 397 SELECT CASE ( nperio ) 398 ! 399 CASE ( 1 , 4 , 6 ) !** cyclic east-west 400 pt2d( 1 ,:) = pt2d(jpim1,:) ! all points 401 pt2d(jpi,:) = pt2d( 2 ,:) 402 ! 403 CASE DEFAULT !** East closed -- West closed 404 SELECT CASE ( cd_type ) 405 CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points 406 pt2d( 1 ,:) = zland 407 pt2d(jpi,:) = zland 408 CASE ( 'F' ) ! F-point 409 pt2d(jpi,:) = zland 410 END SELECT 411 ! 412 END SELECT 413 ! ! North-South boundaries 414 ! ! ====================== 415 SELECT CASE ( nperio ) 416 ! 417 CASE ( 2 ) !** South symmetric -- North closed 418 SELECT CASE ( cd_type ) 419 CASE ( 'T' , 'U' , 'W' ) ! T-, U-, W-points 420 pt2d(:, 1 ) = pt2d(:,3) 421 pt2d(:,jpj) = zland 422 CASE ( 'V' , 'F' ) ! V-, F-points 423 pt2d(:, 1 ) = psgn * pt2d(:,2) 424 pt2d(:,jpj) = zland 425 END SELECT 426 ! 427 CASE ( 3 , 4 , 5 , 6 ) !** North fold T or F-point pivot -- South closed 428 SELECT CASE ( cd_type ) ! South : closed 429 CASE ( 'T' , 'U' , 'V' , 'W' , 'I' ) ! all points except F-point 430 pt2d(:, 1 ) = zland 431 END SELECT 432 ! ! North fold 433 CALL lbc_nfd( pt2d(:,:), cd_type, psgn ) 434 ! 435 CASE DEFAULT !** North closed -- South closed 436 SELECT CASE ( cd_type ) 437 CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points 438 pt2d(:, 1 ) = zland 439 pt2d(:,jpj) = zland 440 CASE ( 'F' ) ! F-point 441 pt2d(:,jpj) = zland 442 END SELECT 443 ! 444 END SELECT 445 ! 446 ENDIF 447 ! 448 END SUBROUTINE lbc_lnk_2d 449 450 SUBROUTINE lbc_lnk_2d_multiple( pt2d_array , type_array , psgn_array , num_fields ) 451 !! 452 INTEGER :: num_fields 453 TYPE( arrayptr ), DIMENSION(:) :: pt2d_array 454 CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: type_array ! define the nature of ptab array grid-points 455 ! ! = T , U , V , F , W and I points 456 REAL(wp) , DIMENSION(:), INTENT(in ) :: psgn_array ! =-1 the sign change across the north fold boundary 457 ! ! = 1. , the sign is kept 458 ! 459 INTEGER :: ii !!MULTI SEND DUMMY LOOP INDICES 460 ! 461 DO ii = 1, num_fields 462 CALL lbc_lnk_2d( pt2d_array(ii)%pt2d, type_array(ii), psgn_array(ii) ) 463 END DO 464 ! 465 END SUBROUTINE lbc_lnk_2d_multiple 466 467 SUBROUTINE lbc_lnk_2d_9( pt2dA, cd_typeA, psgnA, pt2dB, cd_typeB, psgnB, pt2dC, cd_typeC, psgnC & 468 & , pt2dD, cd_typeD, psgnD, pt2dE, cd_typeE, psgnE, pt2dF, cd_typeF, psgnF & 469 & , pt2dG, cd_typeG, psgnG, pt2dH, cd_typeH, psgnH, pt2dI, cd_typeI, psgnI, cd_mpp, pval) 470 !!--------------------------------------------------------------------- 471 ! Second 2D array on which the boundary condition is applied 472 REAL(wp), DIMENSION(jpi,jpj), TARGET , INTENT(inout) :: pt2dA 473 REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) :: pt2dB , pt2dC , pt2dD , pt2dE 474 REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) :: pt2dF , pt2dG , pt2dH , pt2dI 475 ! define the nature of ptab array grid-points 476 CHARACTER(len=1) , INTENT(in ) :: cd_typeA 477 CHARACTER(len=1) , OPTIONAL, INTENT(in ) :: cd_typeB , cd_typeC , cd_typeD , cd_typeE 478 CHARACTER(len=1) , OPTIONAL, INTENT(in ) :: cd_typeF , cd_typeG , cd_typeH , cd_typeI 479 ! =-1 the sign change across the north fold boundary 480 REAL(wp) , INTENT(in ) :: psgnA 481 REAL(wp) , OPTIONAL, INTENT(in ) :: psgnB , psgnC , psgnD , psgnE 482 REAL(wp) , OPTIONAL, INTENT(in ) :: psgnF , psgnG , psgnH , psgnI 483 CHARACTER(len=3) , OPTIONAL, INTENT(in ) :: cd_mpp ! fill the overlap area only 484 REAL(wp) , OPTIONAL, INTENT(in ) :: pval ! background value (used at closed boundaries) 485 !! 486 !!--------------------------------------------------------------------- 487 488 !!The first array 489 CALL lbc_lnk( pt2dA, cd_typeA, psgnA ) 490 491 !! Look if more arrays to process 492 IF(PRESENT (psgnB) )CALL lbc_lnk( pt2dB, cd_typeB, psgnB ) 493 IF(PRESENT (psgnC) )CALL lbc_lnk( pt2dC, cd_typeC, psgnC ) 494 IF(PRESENT (psgnD) )CALL lbc_lnk( pt2dD, cd_typeD, psgnD ) 495 IF(PRESENT (psgnE) )CALL lbc_lnk( pt2dE, cd_typeE, psgnE ) 496 IF(PRESENT (psgnF) )CALL lbc_lnk( pt2dF, cd_typeF, psgnF ) 497 IF(PRESENT (psgnG) )CALL lbc_lnk( pt2dG, cd_typeG, psgnG ) 498 IF(PRESENT (psgnH) )CALL lbc_lnk( pt2dH, cd_typeH, psgnH ) 499 IF(PRESENT (psgnI) )CALL lbc_lnk( pt2dI, cd_typeI, psgnI ) 500 501 END SUBROUTINE lbc_lnk_2d_9 502 503 SUBROUTINE lbc_lnk_sum_2d( pt2d, cd_type, psgn, cd_mpp, pval ) 504 !!--------------------------------------------------------------------- 505 !! *** ROUTINE lbc_lnk_sum_2d *** 506 !! 507 !! ** Purpose : set lateral boundary conditions on a 2D array (non mpp case) 508 !! 509 !! ** Comments: compute the sum of the common cell (overlap region) for the ice sheet/ocean 510 !! coupling if conservation option activated. As no ice shelf are present along 511 !! this line, nothing is done along the north fold. 512 !!---------------------------------------------------------------------- 513 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points 514 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pt2d ! 2D array on which the lbc is applied 515 REAL(wp) , INTENT(in ) :: psgn ! control of the sign 516 CHARACTER(len=3) , INTENT(in ), OPTIONAL :: cd_mpp ! MPP only (here do nothing) 517 REAL(wp) , INTENT(in ), OPTIONAL :: pval ! background value (for closed boundaries) 518 !! 519 REAL(wp) :: zland 520 !!---------------------------------------------------------------------- 521 522 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value (zero by default) 523 ELSE ; zland = 0._wp 524 ENDIF 525 526 IF (PRESENT(cd_mpp)) THEN 527 ! only fill the overlap area and extra allows 528 ! this is in mpp case. In this module, just do nothing 529 ELSE 530 ! ! East-West boundaries 531 ! ! ==================== 532 SELECT CASE ( nperio ) 533 ! 534 CASE ( 1 , 4 , 6 ) !** cyclic east-west 535 pt2d(jpim1,:) = pt2d(jpim1,:) + pt2d( 1 ,:) 536 pt2d( 2 ,:) = pt2d( 2 ,:) + pt2d(jpi,:) 537 pt2d( 1 ,:) = 0.0_wp ! all points 538 pt2d(jpi,:) = 0.0_wp 539 ! 540 CASE DEFAULT !** East closed -- West closed 541 SELECT CASE ( cd_type ) 542 CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points 543 pt2d( 1 ,:) = zland 544 pt2d(jpi,:) = zland 545 CASE ( 'F' ) ! F-point 546 pt2d(jpi,:) = zland 547 END SELECT 548 ! 549 END SELECT 550 ! ! North-South boundaries 551 ! ! ====================== 552 ! Nothing to do for the north fold, there is no ice shelf along this line. 553 ! 554 END IF 555 556 END SUBROUTINE 557 558 SUBROUTINE lbc_lnk_sum_3d( pt3d, cd_type, psgn, cd_mpp, pval ) 559 !!--------------------------------------------------------------------- 560 !! *** ROUTINE lbc_lnk_sum_3d *** 561 !! 562 !! ** Purpose : set lateral boundary conditions on a 3D array (non mpp case) 563 !! 564 !! ** Comments: compute the sum of the common cell (overlap region) for the ice sheet/ocean 565 !! coupling if conservation option activated. As no ice shelf are present along 566 !! this line, nothing is done along the north fold. 567 !!---------------------------------------------------------------------- 568 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points 569 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pt3d ! 3D array on which the lbc is applied 570 REAL(wp) , INTENT(in ) :: psgn ! control of the sign 571 CHARACTER(len=3) , INTENT(in ), OPTIONAL :: cd_mpp ! MPP only (here do nothing) 572 REAL(wp) , INTENT(in ), OPTIONAL :: pval ! background value (for closed boundaries) 573 !! 574 REAL(wp) :: zland 575 !!---------------------------------------------------------------------- 576 577 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value (zero by default) 578 ELSE ; zland = 0._wp 579 ENDIF 580 581 582 IF( PRESENT( cd_mpp ) ) THEN 583 ! only fill the overlap area and extra allows 584 ! this is in mpp case. In this module, just do nothing 585 ELSE 586 ! ! East-West boundaries 587 ! ! ====================== 588 SELECT CASE ( nperio ) 589 ! 590 CASE ( 1 , 4 , 6 ) !** cyclic east-west 591 pt3d(jpim1,:,:) = pt3d(jpim1,:,:) + pt3d( 1 ,:,:) 592 pt3d( 2 ,:,:) = pt3d( 2 ,:,:) + pt3d(jpi,:,:) 593 pt3d( 1 ,:,:) = 0.0_wp ! all points 594 pt3d(jpi,:,:) = 0.0_wp 595 ! 596 CASE DEFAULT !** East closed -- West closed 597 SELECT CASE ( cd_type ) 598 CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points 599 pt3d( 1 ,:,:) = zland 600 pt3d(jpi,:,:) = zland 601 CASE ( 'F' ) ! F-point 602 pt3d(jpi,:,:) = zland 603 END SELECT 604 ! 605 END SELECT 606 ! ! North-South boundaries 607 ! ! ====================== 608 ! Nothing to do for the north fold, there is no ice shelf along this line. 609 ! 610 END IF 611 END SUBROUTINE 612 613 180 !!====================================================================== 181 !! routines setting land point, or east-west cyclic, 182 !! or north-south cyclic, or north fold values 183 !! on first and last row and column of the global domain 184 !!---------------------------------------------------------------------- 185 186 !!---------------------------------------------------------------------- 187 !! *** routine lbc_lnk_(2,3,4)d *** 188 !! 189 !! * Argument : dummy argument use in lbc_lnk_... routines 190 !! ptab : array or pointer of arrays on which the boundary condition is applied 191 !! cd_nat : nature of array grid-points 192 !! psgn : sign used across the north fold boundary 193 !! kfld : optional, number of pt3d arrays 194 !! cd_mpp : optional, fill the overlap area only 195 !! pval : optional, background value (used at closed boundaries) 196 !!---------------------------------------------------------------------- 197 ! 198 ! !== 2D array and array of 2D pointer ==! 199 ! 200 # define DIM_2d 201 # define ROUTINE_LNK lbc_lnk_2d 202 # include "lbc_lnk_generic.h90" 203 # undef ROUTINE_LNK 204 # define MULTI 205 # define ROUTINE_LNK lbc_lnk_2d_ptr 206 # include "lbc_lnk_generic.h90" 207 # undef ROUTINE_LNK 208 # undef MULTI 209 # undef DIM_2d 210 ! 211 ! !== 3D array and array of 3D pointer ==! 212 ! 213 # define DIM_3d 214 # define ROUTINE_LNK lbc_lnk_3d 215 # include "lbc_lnk_generic.h90" 216 # undef ROUTINE_LNK 217 # define MULTI 218 # define ROUTINE_LNK lbc_lnk_3d_ptr 219 # include "lbc_lnk_generic.h90" 220 # undef ROUTINE_LNK 221 # undef MULTI 222 # undef DIM_3d 223 ! 224 ! !== 4D array and array of 4D pointer ==! 225 ! 226 # define DIM_4d 227 # define ROUTINE_LNK lbc_lnk_4d 228 # include "lbc_lnk_generic.h90" 229 # undef ROUTINE_LNK 230 # define MULTI 231 # define ROUTINE_LNK lbc_lnk_4d_ptr 232 # include "lbc_lnk_generic.h90" 233 # undef ROUTINE_LNK 234 # undef MULTI 235 # undef DIM_4d 236 614 237 #endif 615 238 239 !!====================================================================== 240 !! identical routines in both C1D and shared memory computing 241 !!====================================================================== 242 243 !!---------------------------------------------------------------------- 244 !! *** routine lbc_bdy_lnk_(2,3)d *** 245 !! 246 !! wrapper rountine to 'lbc_lnk_3d'. This wrapper is used 247 !! to maintain the same interface with regards to the mpp case 248 !!---------------------------------------------------------------------- 249 616 250 SUBROUTINE lbc_bdy_lnk_3d( pt3d, cd_type, psgn, ib_bdy ) 617 !!--------------------------------------------------------------------- 618 !! *** ROUTINE lbc_bdy_lnk *** 619 !! 620 !! ** Purpose : wrapper rountine to 'lbc_lnk_3d'. This wrapper is used 621 !! to maintain the same interface with regards to the mpp case 622 !! 623 !!---------------------------------------------------------------------- 624 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points 625 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pt3d ! 3D array on which the lbc is applied 626 REAL(wp) , INTENT(in ) :: psgn ! control of the sign 627 INTEGER , INTENT(in ) :: ib_bdy ! BDY boundary set 628 !!---------------------------------------------------------------------- 629 ! 251 !!---------------------------------------------------------------------- 252 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pt3d ! 3D array on which the lbc is applied 253 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points 254 REAL(wp) , INTENT(in ) :: psgn ! sign used across north fold 255 INTEGER , INTENT(in ) :: ib_bdy ! BDY boundary set 256 !!---------------------------------------------------------------------- 630 257 CALL lbc_lnk_3d( pt3d, cd_type, psgn) 631 !632 258 END SUBROUTINE lbc_bdy_lnk_3d 633 259 634 260 635 261 SUBROUTINE lbc_bdy_lnk_2d( pt2d, cd_type, psgn, ib_bdy ) 636 !!--------------------------------------------------------------------- 637 !! *** ROUTINE lbc_bdy_lnk *** 638 !! 639 !! ** Purpose : wrapper rountine to 'lbc_lnk_3d'. This wrapper is used 640 !! to maintain the same interface with regards to the mpp case 641 !! 642 !!---------------------------------------------------------------------- 643 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points 644 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pt2d ! 3D array on which the lbc is applied 645 REAL(wp) , INTENT(in ) :: psgn ! control of the sign 646 INTEGER , INTENT(in ) :: ib_bdy ! BDY boundary set 647 !!---------------------------------------------------------------------- 648 ! 262 !!---------------------------------------------------------------------- 263 REAL(wp), DIMENSION(:,:), INTENT(inout) :: pt2d ! 3D array on which the lbc is applied 264 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points 265 REAL(wp) , INTENT(in ) :: psgn ! sign used across north fold 266 INTEGER , INTENT(in ) :: ib_bdy ! BDY boundary set 267 !!---------------------------------------------------------------------- 649 268 CALL lbc_lnk_2d( pt2d, cd_type, psgn) 650 !651 269 END SUBROUTINE lbc_bdy_lnk_2d 652 270 653 271 654 SUBROUTINE lbc_lnk_2d_e( pt2d, cd_type, psgn, jpri, jprj ) 655 !!--------------------------------------------------------------------- 656 !! *** ROUTINE lbc_lnk_2d *** 657 !! 658 !! ** Purpose : set lateral boundary conditions on a 2D array (non mpp case) 659 !! special dummy routine to allow for use of halo indexing in mpp case 660 !! 661 !! ** Method : psign = -1 : change the sign across the north fold 662 !! = 1 : no change of the sign across the north fold 663 !! = 0 : no change of the sign across the north fold and 664 !! strict positivity preserved: use inner row/column 665 !! for closed boundaries. 666 !!---------------------------------------------------------------------- 667 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points 668 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pt2d ! 2D array on which the lbc is applied 669 REAL(wp) , INTENT(in ) :: psgn ! control of the sign 670 INTEGER , INTENT(in ) :: jpri ! size of extra halo (not needed in non-mpp) 671 INTEGER , INTENT(in ) :: jprj ! size of extra halo (not needed in non-mpp) 672 !!---------------------------------------------------------------------- 673 ! 272 !!gm This routine should be remove with an optional halos size added in orgument of generic routines 273 274 SUBROUTINE lbc_lnk_2d_e( pt2d, cd_type, psgn, ki, kj ) 275 !!---------------------------------------------------------------------- 276 REAL(wp), DIMENSION(:,:), INTENT(inout) :: pt2d ! 2D array on which the lbc is applied 277 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points 278 REAL(wp) , INTENT(in ) :: psgn ! sign used across north fold 279 INTEGER , INTENT(in ) :: ki, kj ! sizes of extra halo (not needed in non-mpp) 280 !!---------------------------------------------------------------------- 674 281 CALL lbc_lnk_2d( pt2d, cd_type, psgn ) 675 !676 282 END SUBROUTINE lbc_lnk_2d_e 283 !!gm end 677 284 678 285 #endif 679 286 680 287 !!====================================================================== 288 !! identical routines in both distributed and shared memory computing 289 !!====================================================================== 290 291 !!---------------------------------------------------------------------- 292 !! *** load_ptr_(2,3,4)d *** 293 !! 294 !! * Dummy Argument : 295 !! in ==> ptab ! array to be loaded (2D, 3D or 4D) 296 !! cd_nat ! nature of pt2d array grid-points 297 !! psgn ! sign used across the north fold boundary 298 !! inout <=> ptab_ptr ! array of 2D, 3D or 4D pointers 299 !! cdna_ptr ! nature of ptab array grid-points 300 !! psgn_ptr ! sign used across the north fold boundary 301 !! kfld ! number of elements that has been attributed 302 !!---------------------------------------------------------------------- 303 304 !!---------------------------------------------------------------------- 305 !! *** lbc_lnk_(2,3,4)d_multi *** 306 !! *** load_ptr_(2,3,4)d *** 307 !! 308 !! * Argument : dummy argument use in lbc_lnk_multi_... routines 309 !! 310 !!---------------------------------------------------------------------- 311 312 # define DIM_2d 313 # define ROUTINE_MULTI lbc_lnk_2d_multi 314 # define ROUTINE_LOAD load_ptr_2d 315 # include "lbc_lnk_multi_generic.h90" 316 # undef ROUTINE_MULTI 317 # undef ROUTINE_LOAD 318 # undef DIM_2d 319 320 321 # define DIM_3d 322 # define ROUTINE_MULTI lbc_lnk_3d_multi 323 # define ROUTINE_LOAD load_ptr_3d 324 # include "lbc_lnk_multi_generic.h90" 325 # undef ROUTINE_MULTI 326 # undef ROUTINE_LOAD 327 # undef DIM_3d 328 329 330 # define DIM_4d 331 # define ROUTINE_MULTI lbc_lnk_4d_multi 332 # define ROUTINE_LOAD load_ptr_4d 333 # include "lbc_lnk_multi_generic.h90" 334 # undef ROUTINE_MULTI 335 # undef ROUTINE_LOAD 336 # undef DIM_4d 337 338 !!====================================================================== 681 339 END MODULE lbclnk 682 340 -
branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/NEMO/OPA_SRC/LBC/lbcnfd.F90
r8877 r8879 5 5 !!====================================================================== 6 6 !! History : 3.2 ! 2009-03 (R. Benshila) Original code 7 !! 3.5 ! 2013-07 (I. Epicoco, S. Mocavero - CMCC) MPP optimization 7 !! 3.5 ! 2013-07 (I. Epicoco, S. Mocavero - CMCC) MPP optimization 8 !! 4.0 ! 2017-04 (G. Madec) automatique allocation of array argument (use any 3rd dimension) 8 9 !!---------------------------------------------------------------------- 9 10 … … 12 13 !! lbc_nfd_3d : lateral boundary condition: North fold treatment for a 3D arrays (lbc_nfd) 13 14 !! lbc_nfd_2d : lateral boundary condition: North fold treatment for a 2D arrays (lbc_nfd) 14 !! mpp_lbc_nfd_3d : North fold treatment for a 3D arrays optimized for MPP 15 !! mpp_lbc_nfd_2d : North fold treatment for a 2D arrays optimized for MPP 15 !! lbc_nfd_nogather : generic interface for lbc_nfd_nogather_3d and 16 !! lbc_nfd_nogather_2d routines (designed for use 17 !! with ln_nnogather to avoid global width arrays 18 !! mpi all gather operations) 16 19 !!---------------------------------------------------------------------- 17 20 USE dom_oce ! ocean space and time domain … … 22 25 23 26 INTERFACE lbc_nfd 24 MODULE PROCEDURE lbc_nfd_3d, lbc_nfd_2d 27 MODULE PROCEDURE lbc_nfd_2d , lbc_nfd_3d , lbc_nfd_4d 28 MODULE PROCEDURE lbc_nfd_2d_ptr, lbc_nfd_3d_ptr, lbc_nfd_4d_ptr 25 29 END INTERFACE 26 30 ! 27 INTERFACE mpp_lbc_nfd 28 MODULE PROCEDURE mpp_lbc_nfd_3d, mpp_lbc_nfd_2d 31 INTERFACE lbc_nfd_nogather 32 ! ! Currently only 4d array version is needed 33 ! MODULE PROCEDURE lbc_nfd_nogather_2d , lbc_nfd_nogather_3d 34 MODULE PROCEDURE lbc_nfd_nogather_4d 35 ! MODULE PROCEDURE lbc_nfd_nogather_2d_ptr, lbc_nfd_nogather_3d_ptr 36 ! MODULE PROCEDURE lbc_nfd_nogather_4d_ptr 29 37 END INTERFACE 30 38 31 PUBLIC lbc_nfd ! north fold conditions 32 PUBLIC mpp_lbc_nfd ! north fold conditions (parallel case) 39 TYPE, PUBLIC :: PTR_2D !: array of 2D pointers (also used in lib_mpp) 40 REAL(wp), DIMENSION (:,:) , POINTER :: pt2d 41 END TYPE PTR_2D 42 TYPE, PUBLIC :: PTR_3D !: array of 3D pointers (also used in lib_mpp) 43 REAL(wp), DIMENSION (:,:,:) , POINTER :: pt3d 44 END TYPE PTR_3D 45 TYPE, PUBLIC :: PTR_4D !: array of 4D pointers (also used in lib_mpp) 46 REAL(wp), DIMENSION (:,:,:,:), POINTER :: pt4d 47 END TYPE PTR_4D 48 49 PUBLIC lbc_nfd ! north fold conditions 50 PUBLIC lbc_nfd_nogather ! north fold conditions (no allgather case) 33 51 34 52 INTEGER, PUBLIC, PARAMETER :: jpmaxngh = 3 !: … … 43 61 CONTAINS 44 62 45 SUBROUTINE lbc_nfd_3d( pt3d, cd_type, psgn ) 46 !!---------------------------------------------------------------------- 47 !! *** routine lbc_nfd_3d *** 48 !! 49 !! ** Purpose : 3D lateral boundary condition : North fold treatment 50 !! without processor exchanges. 51 !! 52 !! ** Method : 53 !! 54 !! ** Action : pt3d with updated values along the north fold 55 !!---------------------------------------------------------------------- 56 CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points 57 ! ! = T , U , V , F , W points 58 REAL(wp) , INTENT(in ) :: psgn ! control of the sign change 59 ! ! = -1. , the sign is changed if north fold boundary 60 ! ! = 1. , the sign is kept if north fold boundary 61 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pt3d ! 3D array on which the boundary condition is applied 62 ! 63 INTEGER :: ji, jk 64 INTEGER :: ijt, iju, ijpj, ijpjm1 65 !!---------------------------------------------------------------------- 66 67 SELECT CASE ( jpni ) 68 CASE ( 1 ) ; ijpj = nlcj ! 1 proc only along the i-direction 69 CASE DEFAULT ; ijpj = 4 ! several proc along the i-direction 70 END SELECT 71 ijpjm1 = ijpj-1 72 73 DO jk = 1, jpk 74 ! 75 SELECT CASE ( npolj ) 76 ! 77 CASE ( 3 , 4 ) ! * North fold T-point pivot 78 ! 79 SELECT CASE ( cd_type ) 80 CASE ( 'T' , 'W' ) ! T-, W-point 81 DO ji = 2, jpiglo 82 ijt = jpiglo-ji+2 83 pt3d(ji,ijpj,jk) = psgn * pt3d(ijt,ijpj-2,jk) 84 END DO 85 pt3d(1,ijpj,jk) = psgn * pt3d(3,ijpj-2,jk) 86 DO ji = jpiglo/2+1, jpiglo 87 ijt = jpiglo-ji+2 88 pt3d(ji,ijpjm1,jk) = psgn * pt3d(ijt,ijpjm1,jk) 89 END DO 90 CASE ( 'U' ) ! U-point 91 DO ji = 1, jpiglo-1 92 iju = jpiglo-ji+1 93 pt3d(ji,ijpj,jk) = psgn * pt3d(iju,ijpj-2,jk) 94 END DO 95 pt3d( 1 ,ijpj,jk) = psgn * pt3d( 2 ,ijpj-2,jk) 96 pt3d(jpiglo,ijpj,jk) = psgn * pt3d(jpiglo-1,ijpj-2,jk) 97 DO ji = jpiglo/2, jpiglo-1 98 iju = jpiglo-ji+1 99 pt3d(ji,ijpjm1,jk) = psgn * pt3d(iju,ijpjm1,jk) 100 END DO 101 CASE ( 'V' ) ! V-point 102 DO ji = 2, jpiglo 103 ijt = jpiglo-ji+2 104 pt3d(ji,ijpj-1,jk) = psgn * pt3d(ijt,ijpj-2,jk) 105 pt3d(ji,ijpj ,jk) = psgn * pt3d(ijt,ijpj-3,jk) 106 END DO 107 pt3d(1,ijpj,jk) = psgn * pt3d(3,ijpj-3,jk) 108 CASE ( 'F' ) ! F-point 109 DO ji = 1, jpiglo-1 110 iju = jpiglo-ji+1 111 pt3d(ji,ijpj-1,jk) = psgn * pt3d(iju,ijpj-2,jk) 112 pt3d(ji,ijpj ,jk) = psgn * pt3d(iju,ijpj-3,jk) 113 END DO 114 pt3d( 1 ,ijpj,jk) = psgn * pt3d( 2 ,ijpj-3,jk) 115 pt3d(jpiglo,ijpj,jk) = psgn * pt3d(jpiglo-1,ijpj-3,jk) 116 END SELECT 117 ! 118 CASE ( 5 , 6 ) ! * North fold F-point pivot 119 ! 120 SELECT CASE ( cd_type ) 121 CASE ( 'T' , 'W' ) ! T-, W-point 122 DO ji = 1, jpiglo 123 ijt = jpiglo-ji+1 124 pt3d(ji,ijpj,jk) = psgn * pt3d(ijt,ijpj-1,jk) 125 END DO 126 CASE ( 'U' ) ! U-point 127 DO ji = 1, jpiglo-1 128 iju = jpiglo-ji 129 pt3d(ji,ijpj,jk) = psgn * pt3d(iju,ijpj-1,jk) 130 END DO 131 pt3d(jpiglo,ijpj,jk) = psgn * pt3d(1,ijpj-1,jk) 132 CASE ( 'V' ) ! V-point 133 DO ji = 1, jpiglo 134 ijt = jpiglo-ji+1 135 pt3d(ji,ijpj,jk) = psgn * pt3d(ijt,ijpj-2,jk) 136 END DO 137 DO ji = jpiglo/2+1, jpiglo 138 ijt = jpiglo-ji+1 139 pt3d(ji,ijpjm1,jk) = psgn * pt3d(ijt,ijpjm1,jk) 140 END DO 141 CASE ( 'F' ) ! F-point 142 DO ji = 1, jpiglo-1 143 iju = jpiglo-ji 144 pt3d(ji,ijpj ,jk) = psgn * pt3d(iju,ijpj-2,jk) 145 END DO 146 pt3d(jpiglo,ijpj,jk) = psgn * pt3d(1,ijpj-2,jk) 147 DO ji = jpiglo/2+1, jpiglo-1 148 iju = jpiglo-ji 149 pt3d(ji,ijpjm1,jk) = psgn * pt3d(iju,ijpjm1,jk) 150 END DO 151 END SELECT 152 ! 153 CASE DEFAULT ! * closed : the code probably never go through 154 ! 155 SELECT CASE ( cd_type) 156 CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points 157 pt3d(:, 1 ,jk) = 0.e0 158 pt3d(:,ijpj,jk) = 0.e0 159 CASE ( 'F' ) ! F-point 160 pt3d(:,ijpj,jk) = 0.e0 161 END SELECT 162 ! 163 END SELECT ! npolj 164 ! 165 END DO 166 ! 167 END SUBROUTINE lbc_nfd_3d 168 169 170 SUBROUTINE lbc_nfd_2d( pt2d, cd_type, psgn, pr2dj ) 63 !!---------------------------------------------------------------------- 64 !! *** routine lbc_nfd_(2,3,4)d *** 65 !!---------------------------------------------------------------------- 66 !! 67 !! ** Purpose : lateral boundary condition 68 !! North fold treatment without processor exchanges. 69 !! 70 !! ** Method : 71 !! 72 !! ** Action : ptab with updated values along the north fold 73 !!---------------------------------------------------------------------- 74 ! 75 ! !== 2D array and array of 2D pointer ==! 76 ! 77 # define DIM_2d 78 # define ROUTINE_NFD lbc_nfd_2d 79 # include "lbc_nfd_generic.h90" 80 # undef ROUTINE_NFD 81 # define MULTI 82 # define ROUTINE_NFD lbc_nfd_2d_ptr 83 # include "lbc_nfd_generic.h90" 84 # undef ROUTINE_NFD 85 # undef MULTI 86 # undef DIM_2d 87 ! 88 ! !== 3D array and array of 3D pointer ==! 89 ! 90 # define DIM_3d 91 # define ROUTINE_NFD lbc_nfd_3d 92 # include "lbc_nfd_generic.h90" 93 # undef ROUTINE_NFD 94 # define MULTI 95 # define ROUTINE_NFD lbc_nfd_3d_ptr 96 # include "lbc_nfd_generic.h90" 97 # undef ROUTINE_NFD 98 # undef MULTI 99 # undef DIM_3d 100 ! 101 ! !== 4D array and array of 4D pointer ==! 102 ! 103 # define DIM_4d 104 # define ROUTINE_NFD lbc_nfd_4d 105 # include "lbc_nfd_generic.h90" 106 # undef ROUTINE_NFD 107 # define MULTI 108 # define ROUTINE_NFD lbc_nfd_4d_ptr 109 # include "lbc_nfd_generic.h90" 110 # undef ROUTINE_NFD 111 # undef MULTI 112 # undef DIM_4d 113 ! 114 ! lbc_nfd_nogather routines 115 ! 116 ! !== 2D array and array of 2D pointer ==! 117 ! 118 !# define DIM_2d 119 !# define ROUTINE_NFD lbc_nfd_nogather_2d 120 !# include "lbc_nfd_nogather_generic.h90" 121 !# undef ROUTINE_NFD 122 !# define MULTI 123 !# define ROUTINE_NFD lbc_nfd_nogather_2d_ptr 124 !# include "lbc_nfd_nogather_generic.h90" 125 !# undef ROUTINE_NFD 126 !# undef MULTI 127 !# undef DIM_2d 128 ! 129 ! !== 3D array and array of 3D pointer ==! 130 ! 131 !# define DIM_3d 132 !# define ROUTINE_NFD lbc_nfd_nogather_3d 133 !# include "lbc_nfd_nogather_generic.h90" 134 !# undef ROUTINE_NFD 135 !# define MULTI 136 !# define ROUTINE_NFD lbc_nfd_nogather_3d_ptr 137 !# include "lbc_nfd_nogather_generic.h90" 138 !# undef ROUTINE_NFD 139 !# undef MULTI 140 !# undef DIM_3d 141 ! 142 ! !== 4D array and array of 4D pointer ==! 143 ! 144 # define DIM_4d 145 # define ROUTINE_NFD lbc_nfd_nogather_4d 146 # include "lbc_nfd_nogather_generic.h90" 147 # undef ROUTINE_NFD 148 !# define MULTI 149 !# define ROUTINE_NFD lbc_nfd_nogather_4d_ptr 150 !# include "lbc_nfd_nogather_generic.h90" 151 !# undef ROUTINE_NFD 152 !# undef MULTI 153 # undef DIM_4d 154 155 !!---------------------------------------------------------------------- 156 157 158 !!gm CAUTION HERE optional pr2dj not implemented in generic case 159 !!gm furthermore, in the _org routine it is OK only for T-point pivot !! 160 161 162 SUBROUTINE lbc_nfd_2d_org( pt2d, cd_nat, psgn, pr2dj ) 171 163 !!---------------------------------------------------------------------- 172 164 !! *** routine lbc_nfd_2d *** … … 179 171 !! ** Action : pt2d with updated values along the north fold 180 172 !!---------------------------------------------------------------------- 181 CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points182 ! ! = T , U , V , F , W points183 REAL(wp) , INTENT(in ) :: psgn ! control of the sign change184 ! ! = -1. , the sign is changed if north fold boundary185 ! ! = 1. , the sign is kept if north fold boundary186 173 REAL(wp), DIMENSION(:,:), INTENT(inout) :: pt2d ! 2D array on which the boundary condition is applied 174 CHARACTER(len=1) , INTENT(in ) :: cd_nat ! nature of pt2d grid-point 175 REAL(wp) , INTENT(in ) :: psgn ! sign used across north fold 187 176 INTEGER , OPTIONAL , INTENT(in ) :: pr2dj ! number of additional halos 188 177 ! … … 210 199 CASE ( 3, 4 ) ! * North fold T-point pivot 211 200 ! 212 SELECT CASE ( cd_ type)201 SELECT CASE ( cd_nat ) 213 202 ! 214 203 CASE ( 'T' , 'W' ) ! T- , W-points … … 265 254 END DO 266 255 END DO 267 CASE ( 'J' ) ! first ice U-V point268 DO jl =0, ipr2dj269 pt2d(2,ijpj+jl) = psgn * pt2d(3,ijpj-1+jl)270 DO ji = 3, jpiglo271 iju = jpiglo - ji + 3272 pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj-1-jl)273 END DO274 END DO275 CASE ( 'K' ) ! second ice U-V point276 DO jl =0, ipr2dj277 pt2d(2,ijpj+jl) = psgn * pt2d(3,ijpj-1+jl)278 DO ji = 3, jpiglo279 iju = jpiglo - ji + 3280 pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj-1-jl)281 END DO282 END DO283 256 END SELECT 284 257 ! 285 258 CASE ( 5, 6 ) ! * North fold F-point pivot 286 259 ! 287 SELECT CASE ( cd_ type)260 SELECT CASE ( cd_nat ) 288 261 CASE ( 'T' , 'W' ) ! T-, W-point 289 262 DO jl = 0, ipr2dj … … 325 298 END DO 326 299 CASE ( 'I' ) ! ice U-V point (I-point) 327 pt2d( 2 ,ijpj:ijpj+ipr2dj) = 0. e0300 pt2d( 2 ,ijpj:ijpj+ipr2dj) = 0._wp 328 301 DO jl = 0, ipr2dj 329 302 DO ji = 2 , jpiglo-1 … … 332 305 END DO 333 306 END DO 334 CASE ( 'J' ) ! first ice U-V point335 pt2d( 2 ,ijpj:ijpj+ipr2dj) = 0.e0336 DO jl = 0, ipr2dj337 DO ji = 2 , jpiglo-1338 ijt = jpiglo - ji + 2339 pt2d(ji,ijpj+jl)= pt2d(ji,ijpj-1-jl)340 END DO341 END DO342 CASE ( 'K' ) ! second ice U-V point343 pt2d( 2 ,ijpj:ijpj+ipr2dj) = 0.e0344 DO jl = 0, ipr2dj345 DO ji = 2 , jpiglo-1346 ijt = jpiglo - ji + 2347 pt2d(ji,ijpj+jl)= pt2d(ijt,ijpj-1-jl)348 END DO349 END DO350 307 END SELECT 351 308 ! 352 309 CASE DEFAULT ! * closed : the code probably never go through 353 310 ! 354 SELECT CASE ( cd_ type)311 SELECT CASE ( cd_nat) 355 312 CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points 356 pt2d(:, 1:1-ipr2dj ) = 0. e0357 pt2d(:,ijpj:ijpj+ipr2dj) = 0. e0313 pt2d(:, 1:1-ipr2dj ) = 0._wp 314 pt2d(:,ijpj:ijpj+ipr2dj) = 0._wp 358 315 CASE ( 'F' ) ! F-point 359 pt2d(:,ijpj:ijpj+ipr2dj) = 0. e0316 pt2d(:,ijpj:ijpj+ipr2dj) = 0._wp 360 317 CASE ( 'I' ) ! ice U-V point 361 pt2d(:, 1:1-ipr2dj ) = 0.e0 362 pt2d(:,ijpj:ijpj+ipr2dj) = 0.e0 363 CASE ( 'J' ) ! first ice U-V point 364 pt2d(:, 1:1-ipr2dj ) = 0.e0 365 pt2d(:,ijpj:ijpj+ipr2dj) = 0.e0 366 CASE ( 'K' ) ! second ice U-V point 367 pt2d(:, 1:1-ipr2dj ) = 0.e0 368 pt2d(:,ijpj:ijpj+ipr2dj) = 0.e0 318 pt2d(:, 1:1-ipr2dj ) = 0._wp 319 pt2d(:,ijpj:ijpj+ipr2dj) = 0._wp 369 320 END SELECT 370 321 ! 371 322 END SELECT 372 323 ! 373 END SUBROUTINE lbc_nfd_2d 374 375 376 SUBROUTINE mpp_lbc_nfd_3d( pt3dl, pt3dr, cd_type, psgn ) 377 !!---------------------------------------------------------------------- 378 !! *** routine mpp_lbc_nfd_3d *** 379 !! 380 !! ** Purpose : 3D lateral boundary condition : North fold treatment 381 !! without processor exchanges. 382 !! 383 !! ** Method : 384 !! 385 !! ** Action : pt3d with updated values along the north fold 386 !!---------------------------------------------------------------------- 387 CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points 388 ! ! = T , U , V , F , W points 389 REAL(wp) , INTENT(in ) :: psgn ! control of the sign change 390 ! ! = -1. , the sign is changed if north fold boundary 391 ! ! = 1. , the sign is kept if north fold boundary 392 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pt3dl ! 3D array on which the boundary condition is applied 393 REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pt3dr ! 3D array on which the boundary condition is applied 394 ! 395 INTEGER :: ji, jk 396 INTEGER :: ijt, iju, ijpj, ijpjm1, ijta, ijua, jia, startloop, endloop 397 !!---------------------------------------------------------------------- 398 ! 399 SELECT CASE ( jpni ) 400 CASE ( 1 ) ; ijpj = nlcj ! 1 proc only along the i-direction 401 CASE DEFAULT ; ijpj = 4 ! several proc along the i-direction 402 END SELECT 403 ijpjm1 = ijpj-1 404 405 ! 406 SELECT CASE ( npolj ) 407 ! 408 CASE ( 3 , 4 ) ! * North fold T-point pivot 409 ! 410 SELECT CASE ( cd_type ) 411 CASE ( 'T' , 'W' ) ! T-, W-point 412 IF (nimpp .ne. 1) THEN 413 startloop = 1 414 ELSE 415 startloop = 2 416 ENDIF 417 418 DO jk = 1, jpk 419 DO ji = startloop, nlci 420 ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 421 pt3dl(ji,ijpj,jk) = psgn * pt3dr(ijt,ijpj-2,jk) 422 END DO 423 IF(nimpp .eq. 1) THEN 424 pt3dl(1,ijpj,jk) = psgn * pt3dl(3,ijpj-2,jk) 425 ENDIF 426 END DO 427 428 IF(nimpp .ge. (jpiglo/2+1)) THEN 429 startloop = 1 430 ELSEIF(((nimpp+nlci-1) .ge. (jpiglo/2+1)) .AND. (nimpp .lt. (jpiglo/2+1))) THEN 431 startloop = jpiglo/2+1 - nimpp + 1 432 ELSE 433 startloop = nlci + 1 434 ENDIF 435 IF(startloop .le. nlci) THEN 436 DO jk = 1, jpk 437 DO ji = startloop, nlci 438 ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 439 jia = ji + nimpp - 1 440 ijta = jpiglo - jia + 2 441 IF((ijta .ge. (startloop + nimpp - 1)) .and. (ijta .lt. jia)) THEN 442 pt3dl(ji,ijpjm1,jk) = psgn * pt3dl(ijta-nimpp+1,ijpjm1,jk) 443 ELSE 444 pt3dl(ji,ijpjm1,jk) = psgn * pt3dr(ijt,ijpjm1,jk) 445 ENDIF 446 END DO 447 END DO 448 ENDIF 449 450 451 CASE ( 'U' ) ! U-point 452 IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 453 endloop = nlci 454 ELSE 455 endloop = nlci - 1 456 ENDIF 457 DO jk = 1, jpk 458 DO ji = 1, endloop 459 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 460 pt3dl(ji,ijpj,jk) = psgn * pt3dr(iju,ijpj-2,jk) 461 END DO 462 IF(nimpp .eq. 1) THEN 463 pt3dl( 1 ,ijpj,jk) = psgn * pt3dl( 2 ,ijpj-2,jk) 464 ENDIF 465 IF((nimpp + nlci - 1) .eq. jpiglo) THEN 466 pt3dl(nlci,ijpj,jk) = psgn * pt3dl(nlci-1,ijpj-2,jk) 467 ENDIF 468 END DO 469 470 IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 471 endloop = nlci 472 ELSE 473 endloop = nlci - 1 474 ENDIF 475 IF(nimpp .ge. (jpiglo/2)) THEN 476 startloop = 1 477 ELSEIF(((nimpp+nlci-1) .ge. (jpiglo/2)) .AND. (nimpp .lt. (jpiglo/2))) THEN 478 startloop = jpiglo/2 - nimpp + 1 479 ELSE 480 startloop = endloop + 1 481 ENDIF 482 IF (startloop .le. endloop) THEN 483 DO jk = 1, jpk 484 DO ji = startloop, endloop 485 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 486 jia = ji + nimpp - 1 487 ijua = jpiglo - jia + 1 488 IF((ijua .ge. (startloop + nimpp - 1)) .and. (ijua .lt. jia)) THEN 489 pt3dl(ji,ijpjm1,jk) = psgn * pt3dl(ijua-nimpp+1,ijpjm1,jk) 490 ELSE 491 pt3dl(ji,ijpjm1,jk) = psgn * pt3dr(iju,ijpjm1,jk) 492 ENDIF 493 END DO 494 END DO 495 ENDIF 496 497 CASE ( 'V' ) ! V-point 498 IF (nimpp .ne. 1) THEN 499 startloop = 1 500 ELSE 501 startloop = 2 502 ENDIF 503 DO jk = 1, jpk 504 DO ji = startloop, nlci 505 ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 506 pt3dl(ji,ijpj-1,jk) = psgn * pt3dr(ijt,ijpj-2,jk) 507 pt3dl(ji,ijpj ,jk) = psgn * pt3dr(ijt,ijpj-3,jk) 508 END DO 509 IF(nimpp .eq. 1) THEN 510 pt3dl(1,ijpj,jk) = psgn * pt3dl(3,ijpj-3,jk) 511 ENDIF 512 END DO 513 CASE ( 'F' ) ! F-point 514 IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 515 endloop = nlci 516 ELSE 517 endloop = nlci - 1 518 ENDIF 519 DO jk = 1, jpk 520 DO ji = 1, endloop 521 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 522 pt3dl(ji,ijpj-1,jk) = psgn * pt3dr(iju,ijpj-2,jk) 523 pt3dl(ji,ijpj ,jk) = psgn * pt3dr(iju,ijpj-3,jk) 524 END DO 525 IF(nimpp .eq. 1) THEN 526 pt3dl( 1 ,ijpj,jk) = psgn * pt3dl( 2 ,ijpj-3,jk) 527 ENDIF 528 IF((nimpp + nlci - 1) .eq. jpiglo) THEN 529 pt3dl(nlci,ijpj,jk) = psgn * pt3dl(nlci-1,ijpj-3,jk) 530 ENDIF 531 END DO 532 END SELECT 533 ! 534 535 CASE ( 5 , 6 ) ! * North fold F-point pivot 536 ! 537 SELECT CASE ( cd_type ) 538 CASE ( 'T' , 'W' ) ! T-, W-point 539 DO jk = 1, jpk 540 DO ji = 1, nlci 541 ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 542 pt3dl(ji,ijpj,jk) = psgn * pt3dr(ijt,ijpj-1,jk) 543 END DO 544 END DO 545 546 CASE ( 'U' ) ! U-point 547 IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 548 endloop = nlci 549 ELSE 550 endloop = nlci - 1 551 ENDIF 552 DO jk = 1, jpk 553 DO ji = 1, endloop 554 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 555 pt3dl(ji,ijpj,jk) = psgn * pt3dr(iju,ijpj-1,jk) 556 END DO 557 IF((nimpp + nlci - 1) .eq. jpiglo) THEN 558 pt3dl(nlci,ijpj,jk) = psgn * pt3dr(1,ijpj-1,jk) 559 ENDIF 560 END DO 561 562 CASE ( 'V' ) ! V-point 563 DO jk = 1, jpk 564 DO ji = 1, nlci 565 ijt = jpiglo - ji- nimpp - nfiimpp(isendto(1),jpnj) + 3 566 pt3dl(ji,ijpj,jk) = psgn * pt3dr(ijt,ijpj-2,jk) 567 END DO 568 END DO 569 570 IF(nimpp .ge. (jpiglo/2+1)) THEN 571 startloop = 1 572 ELSEIF(((nimpp+nlci-1) .ge. (jpiglo/2+1)) .AND. (nimpp .lt. (jpiglo/2+1))) THEN 573 startloop = jpiglo/2+1 - nimpp + 1 574 ELSE 575 startloop = nlci + 1 576 ENDIF 577 IF(startloop .le. nlci) THEN 578 DO jk = 1, jpk 579 DO ji = startloop, nlci 580 ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 581 pt3dl(ji,ijpjm1,jk) = psgn * pt3dr(ijt,ijpjm1,jk) 582 END DO 583 END DO 584 ENDIF 585 586 CASE ( 'F' ) ! F-point 587 IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 588 endloop = nlci 589 ELSE 590 endloop = nlci - 1 591 ENDIF 592 DO jk = 1, jpk 593 DO ji = 1, endloop 594 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 595 pt3dl(ji,ijpj ,jk) = psgn * pt3dr(iju,ijpj-2,jk) 596 END DO 597 IF((nimpp + nlci - 1) .eq. jpiglo) THEN 598 pt3dl(nlci,ijpj,jk) = psgn * pt3dr(1,ijpj-2,jk) 599 ENDIF 600 END DO 601 602 IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 603 endloop = nlci 604 ELSE 605 endloop = nlci - 1 606 ENDIF 607 IF(nimpp .ge. (jpiglo/2+1)) THEN 608 startloop = 1 609 ELSEIF(((nimpp+nlci-1) .ge. (jpiglo/2+1)) .AND. (nimpp .lt. (jpiglo/2+1))) THEN 610 startloop = jpiglo/2+1 - nimpp + 1 611 ELSE 612 startloop = endloop + 1 613 ENDIF 614 IF (startloop .le. endloop) THEN 615 DO jk = 1, jpk 616 DO ji = startloop, endloop 617 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 618 pt3dl(ji,ijpjm1,jk) = psgn * pt3dr(iju,ijpjm1,jk) 619 END DO 620 END DO 621 ENDIF 622 623 END SELECT 624 625 CASE DEFAULT ! * closed : the code probably never go through 626 ! 627 SELECT CASE ( cd_type) 628 CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points 629 pt3dl(:, 1 ,jk) = 0.e0 630 pt3dl(:,ijpj,jk) = 0.e0 631 CASE ( 'F' ) ! F-point 632 pt3dl(:,ijpj,jk) = 0.e0 633 END SELECT 634 ! 635 END SELECT ! npolj 636 ! 637 ! 638 END SUBROUTINE mpp_lbc_nfd_3d 639 640 641 SUBROUTINE mpp_lbc_nfd_2d( pt2dl, pt2dr, cd_type, psgn ) 642 !!---------------------------------------------------------------------- 643 !! *** routine mpp_lbc_nfd_2d *** 644 !! 645 !! ** Purpose : 2D lateral boundary condition : North fold treatment 646 !! without processor exchanges. 647 !! 648 !! ** Method : 649 !! 650 !! ** Action : pt2d with updated values along the north fold 651 !!---------------------------------------------------------------------- 652 CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points 653 ! ! = T , U , V , F , W points 654 REAL(wp) , INTENT(in ) :: psgn ! control of the sign change 655 ! ! = -1. , the sign is changed if north fold boundary 656 ! ! = 1. , the sign is kept if north fold boundary 657 REAL(wp), DIMENSION(:,:), INTENT(inout) :: pt2dl ! 2D array on which the boundary condition is applied 658 REAL(wp), DIMENSION(:,:), INTENT(in ) :: pt2dr ! 2D array on which the boundary condition is applied 659 ! 660 INTEGER :: ji 661 INTEGER :: ijt, iju, ijpj, ijpjm1, ijta, ijua, jia, startloop, endloop 662 !!---------------------------------------------------------------------- 663 664 SELECT CASE ( jpni ) 665 CASE ( 1 ) ; ijpj = nlcj ! 1 proc only along the i-direction 666 CASE DEFAULT ; ijpj = 4 ! several proc along the i-direction 667 END SELECT 668 ! 669 ijpjm1 = ijpj-1 670 671 672 SELECT CASE ( npolj ) 673 ! 674 CASE ( 3, 4 ) ! * North fold T-point pivot 675 ! 676 SELECT CASE ( cd_type ) 677 ! 678 CASE ( 'T' , 'W' ) ! T- , W-points 679 IF (nimpp .ne. 1) THEN 680 startloop = 1 681 ELSE 682 startloop = 2 683 ENDIF 684 DO ji = startloop, nlci 685 ijt=jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 686 pt2dl(ji,ijpj) = psgn * pt2dr(ijt,ijpjm1-1) 687 END DO 688 IF (nimpp .eq. 1) THEN 689 pt2dl(1,ijpj) = psgn * pt2dl(3,ijpj-2) 690 ENDIF 691 692 IF(nimpp .ge. (jpiglo/2+1)) THEN 693 startloop = 1 694 ELSEIF(((nimpp+nlci-1) .ge. (jpiglo/2+1)) .AND. (nimpp .lt. (jpiglo/2+1))) THEN 695 startloop = jpiglo/2+1 - nimpp + 1 696 ELSE 697 startloop = nlci + 1 698 ENDIF 699 DO ji = startloop, nlci 700 ijt=jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 701 jia = ji + nimpp - 1 702 ijta = jpiglo - jia + 2 703 IF((ijta .ge. (startloop + nimpp - 1)) .and. (ijta .lt. jia)) THEN 704 pt2dl(ji,ijpjm1) = psgn * pt2dl(ijta-nimpp+1,ijpjm1) 705 ELSE 706 pt2dl(ji,ijpjm1) = psgn * pt2dr(ijt,ijpjm1) 707 ENDIF 708 END DO 709 710 CASE ( 'U' ) ! U-point 711 IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 712 endloop = nlci 713 ELSE 714 endloop = nlci - 1 715 ENDIF 716 DO ji = 1, endloop 717 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 718 pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1-1) 719 END DO 720 721 IF (nimpp .eq. 1) THEN 722 pt2dl( 1 ,ijpj ) = psgn * pt2dl( 2 ,ijpj-2) 723 pt2dl(1 ,ijpj-1) = psgn * pt2dr(jpiglo - nfiimpp(isendto(1), jpnj) + 1, ijpj-1) 724 ENDIF 725 IF((nimpp + nlci - 1) .eq. jpiglo) THEN 726 pt2dl(nlci,ijpj ) = psgn * pt2dl(nlci-1,ijpj-2) 727 ENDIF 728 729 IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 730 endloop = nlci 731 ELSE 732 endloop = nlci - 1 733 ENDIF 734 IF(nimpp .ge. (jpiglo/2)) THEN 735 startloop = 1 736 ELSEIF(((nimpp+nlci-1) .ge. (jpiglo/2)) .AND. (nimpp .lt. (jpiglo/2))) THEN 737 startloop = jpiglo/2 - nimpp + 1 738 ELSE 739 startloop = endloop + 1 740 ENDIF 741 DO ji = startloop, endloop 742 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 743 jia = ji + nimpp - 1 744 ijua = jpiglo - jia + 1 745 IF((ijua .ge. (startloop + nimpp - 1)) .and. (ijua .lt. jia)) THEN 746 pt2dl(ji,ijpjm1) = psgn * pt2dl(ijua-nimpp+1,ijpjm1) 747 ELSE 748 pt2dl(ji,ijpjm1) = psgn * pt2dr(iju,ijpjm1) 749 ENDIF 750 END DO 751 752 CASE ( 'V' ) ! V-point 753 IF (nimpp .ne. 1) THEN 754 startloop = 1 755 ELSE 756 startloop = 2 757 ENDIF 758 DO ji = startloop, nlci 759 ijt=jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 760 pt2dl(ji,ijpjm1) = psgn * pt2dr(ijt,ijpjm1-1) 761 pt2dl(ji,ijpj) = psgn * pt2dr(ijt,ijpjm1-2) 762 END DO 763 IF (nimpp .eq. 1) THEN 764 pt2dl( 1 ,ijpj) = psgn * pt2dl( 3 ,ijpj-3) 765 ENDIF 766 767 CASE ( 'F' ) ! F-point 768 IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 769 endloop = nlci 770 ELSE 771 endloop = nlci - 1 772 ENDIF 773 DO ji = 1, endloop 774 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 775 pt2dl(ji,ijpjm1) = psgn * pt2dr(iju,ijpjm1-1) 776 pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1-2) 777 END DO 778 IF (nimpp .eq. 1) THEN 779 pt2dl( 1 ,ijpj) = psgn * pt2dl( 2 ,ijpj-3) 780 pt2dl( 1 ,ijpj-1) = psgn * pt2dl( 2 ,ijpj-2) 781 ENDIF 782 IF((nimpp + nlci - 1) .eq. jpiglo) THEN 783 pt2dl(nlci,ijpj) = psgn * pt2dl(nlci-1,ijpj-3) 784 pt2dl(nlci,ijpj-1) = psgn * pt2dl(nlci-1,ijpj-2) 785 ENDIF 786 787 CASE ( 'I' ) ! ice U-V point (I-point) 788 IF (nimpp .ne. 1) THEN 789 startloop = 1 790 ELSE 791 startloop = 3 792 pt2dl(2,ijpj) = psgn * pt2dr(3,ijpjm1) 793 ENDIF 794 DO ji = startloop, nlci 795 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 5 796 pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1) 797 END DO 798 799 CASE ( 'J' ) ! first ice U-V point 800 IF (nimpp .ne. 1) THEN 801 startloop = 1 802 ELSE 803 startloop = 3 804 pt2dl(2,ijpj) = psgn * pt2dl(3,ijpjm1) 805 ENDIF 806 DO ji = startloop, nlci 807 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 5 808 pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1) 809 END DO 810 811 CASE ( 'K' ) ! second ice U-V point 812 IF (nimpp .ne. 1) THEN 813 startloop = 1 814 ELSE 815 startloop = 3 816 pt2dl(2,ijpj) = psgn * pt2dl(3,ijpjm1) 817 ENDIF 818 DO ji = startloop, nlci 819 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 5 820 pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1) 821 END DO 822 823 END SELECT 824 ! 825 CASE ( 5, 6 ) ! * North fold F-point pivot 826 ! 827 SELECT CASE ( cd_type ) 828 CASE ( 'T' , 'W' ) ! T-, W-point 829 DO ji = 1, nlci 830 ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 831 pt2dl(ji,ijpj) = psgn * pt2dr(ijt,ijpjm1) 832 END DO 833 834 CASE ( 'U' ) ! U-point 835 IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 836 endloop = nlci 837 ELSE 838 endloop = nlci - 1 839 ENDIF 840 DO ji = 1, endloop 841 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 842 pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1) 843 END DO 844 IF((nimpp + nlci - 1) .eq. jpiglo) THEN 845 pt2dl(nlci,ijpj) = psgn * pt2dr(1,ijpj-1) 846 ENDIF 847 848 CASE ( 'V' ) ! V-point 849 DO ji = 1, nlci 850 ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 851 pt2dl(ji,ijpj) = psgn * pt2dr(ijt,ijpjm1-1) 852 END DO 853 IF(nimpp .ge. (jpiglo/2+1)) THEN 854 startloop = 1 855 ELSEIF(((nimpp+nlci-1) .ge. (jpiglo/2+1)) .AND. (nimpp .lt. (jpiglo/2+1))) THEN 856 startloop = jpiglo/2+1 - nimpp + 1 857 ELSE 858 startloop = nlci + 1 859 ENDIF 860 DO ji = startloop, nlci 861 ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 862 pt2dl(ji,ijpjm1) = psgn * pt2dr(ijt,ijpjm1) 863 END DO 864 865 CASE ( 'F' ) ! F-point 866 IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 867 endloop = nlci 868 ELSE 869 endloop = nlci - 1 870 ENDIF 871 DO ji = 1, endloop 872 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 873 pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1-1) 874 END DO 875 IF((nimpp + nlci - 1) .eq. jpiglo) THEN 876 pt2dl(nlci,ijpj) = psgn * pt2dr(1,ijpj-2) 877 ENDIF 878 879 IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 880 endloop = nlci 881 ELSE 882 endloop = nlci - 1 883 ENDIF 884 IF(nimpp .ge. (jpiglo/2+1)) THEN 885 startloop = 1 886 ELSEIF(((nimpp+nlci-1) .ge. (jpiglo/2+1)) .AND. (nimpp .lt. (jpiglo/2+1))) THEN 887 startloop = jpiglo/2+1 - nimpp + 1 888 ELSE 889 startloop = endloop + 1 890 ENDIF 891 892 DO ji = startloop, endloop 893 iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 894 pt2dl(ji,ijpjm1) = psgn * pt2dr(iju,ijpjm1) 895 END DO 896 897 CASE ( 'I' ) ! ice U-V point (I-point) 898 IF (nimpp .ne. 1) THEN 899 startloop = 1 900 ELSE 901 startloop = 2 902 ENDIF 903 IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 904 endloop = nlci 905 ELSE 906 endloop = nlci - 1 907 ENDIF 908 DO ji = startloop , endloop 909 ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 910 pt2dl(ji,ijpj)= 0.5 * (pt2dl(ji,ijpjm1) + psgn * pt2dr(ijt,ijpjm1)) 911 END DO 912 913 CASE ( 'J' ) ! first ice U-V point 914 IF (nimpp .ne. 1) THEN 915 startloop = 1 916 ELSE 917 startloop = 2 918 ENDIF 919 IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 920 endloop = nlci 921 ELSE 922 endloop = nlci - 1 923 ENDIF 924 DO ji = startloop , endloop 925 ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 926 pt2dl(ji,ijpj) = pt2dl(ji,ijpjm1) 927 END DO 928 929 CASE ( 'K' ) ! second ice U-V point 930 IF (nimpp .ne. 1) THEN 931 startloop = 1 932 ELSE 933 startloop = 2 934 ENDIF 935 IF ((nimpp + nlci - 1) .ne. jpiglo) THEN 936 endloop = nlci 937 ELSE 938 endloop = nlci - 1 939 ENDIF 940 DO ji = startloop, endloop 941 ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 942 pt2dl(ji,ijpj) = pt2dr(ijt,ijpjm1) 943 END DO 944 945 END SELECT 946 ! 947 CASE DEFAULT ! * closed : the code probably never go through 948 ! 949 SELECT CASE ( cd_type) 950 CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points 951 pt2dl(:, 1 ) = 0.e0 952 pt2dl(:,ijpj) = 0.e0 953 CASE ( 'F' ) ! F-point 954 pt2dl(:,ijpj) = 0.e0 955 CASE ( 'I' ) ! ice U-V point 956 pt2dl(:, 1 ) = 0.e0 957 pt2dl(:,ijpj) = 0.e0 958 CASE ( 'J' ) ! first ice U-V point 959 pt2dl(:, 1 ) = 0.e0 960 pt2dl(:,ijpj) = 0.e0 961 CASE ( 'K' ) ! second ice U-V point 962 pt2dl(:, 1 ) = 0.e0 963 pt2dl(:,ijpj) = 0.e0 964 END SELECT 965 ! 966 END SELECT 967 ! 968 END SUBROUTINE mpp_lbc_nfd_2d 324 END SUBROUTINE lbc_nfd_2d_org 969 325 970 326 !!====================================================================== -
branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90
r8878 r8879 8 8 !! 8.0 ! 1998 (M. Imbard, J. Escobar, L. Colombet ) SHMEM and MPI 9 9 !! ! 1998 (J.M. Molines) Open boundary conditions 10 !! NEMO 1.0 ! 2003 (J. -M. Molines, G. Madec) F90, free form10 !! NEMO 1.0 ! 2003 (J.M. Molines, G. Madec) F90, free form 11 11 !! ! 2003 (J.M. Molines) add mpp_ini_north(_3d,_2d) 12 12 !! - ! 2004 (R. Bourdalle Badie) isend option in mpi … … 19 19 !! 3.2 ! 2009 (O. Marti) add mpp_ini_znl 20 20 !! 4.0 ! 2011 (G. Madec) move ctl_ routines from in_out_manager 21 !! 3.5 ! 2012 (S.Mocavero, I. Epicoco) Add 'mpp_lnk_bdy_3d', 'mpp_lnk_obc_3d', 22 !! 'mpp_lnk_bdy_2d' and 'mpp_lnk_obc_2d' routines and update 23 !! the mppobc routine to optimize the BDY and OBC communications 24 !! 3.5 ! 2013 ( C. Ethe, G. Madec ) message passing arrays as local variables 21 !! 3.5 ! 2012 (S.Mocavero, I. Epicoco) Add mpp_lnk_bdy_3d/2d routines to optimize the BDY comm. 22 !! 3.5 ! 2013 (C. Ethe, G. Madec) message passing arrays as local variables 25 23 !! 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' 24 !! 3.6 ! 2015 (O. Tintó and M. Castrillo - BSC) Added '_multiple' case for 2D lbc and max 25 !! 4.0 ! 2017 (G. Madec) automatique allocation of array argument (use any 3rd dimension) 26 !! - ! 2017 (G. Madec) create generic.h90 files to generate all lbc and north fold routines 27 27 !!---------------------------------------------------------------------- 28 28 … … 41 41 !! mynode : indentify the processor unit 42 42 !! mpp_lnk : interface (defined in lbclnk) for message passing of 2d or 3d arrays (mpp_lnk_2d, mpp_lnk_3d) 43 !! mpp_lnk_3d_gather : Message passing manadgement for two 3D arrays44 43 !! mpp_lnk_e : interface (defined in lbclnk) for message passing of 2d array with extra halo (mpp_lnk_2d_e) 45 44 !! mpp_lnk_icb : interface for message passing of 2d arrays with extra halo for icebergs (mpp_lnk_2d_icb) 46 45 !! mpprecv : 47 !! mppsend : SUBROUTINE mpp_ini_znl46 !! mppsend : 48 47 !! mppscatter : 49 48 !! mppgather : … … 56 55 !! mppstop : 57 56 !! mpp_ini_north : initialisation of north fold 58 !! mpp_lbc_north : north fold processors gathering57 !!gm !! mpp_lbc_north : north fold processors gathering 59 58 !! mpp_lbc_north_e : variant of mpp_lbc_north for extra outer halo 60 59 !! mpp_lbc_north_icb : variant of mpp_lbc_north for extra outer halo with icebergs … … 67 66 IMPLICIT NONE 68 67 PRIVATE 69 68 69 INTERFACE mpp_nfd 70 MODULE PROCEDURE mpp_nfd_2d , mpp_nfd_3d , mpp_nfd_4d 71 MODULE PROCEDURE mpp_nfd_2d_ptr, mpp_nfd_3d_ptr, mpp_nfd_4d_ptr 72 END INTERFACE 73 74 ! Interface associated to the mpp_lnk_... routines is defined in lbclnk 75 PUBLIC mpp_lnk_2d , mpp_lnk_3d , mpp_lnk_4d 76 PUBLIC mpp_lnk_2d_ptr, mpp_lnk_3d_ptr, mpp_lnk_4d_ptr 77 PUBLIC mpp_lnk_2d_e 78 ! 79 !!gm this should be useless 80 PUBLIC mpp_nfd_2d , mpp_nfd_3d , mpp_nfd_4d 81 PUBLIC mpp_nfd_2d_ptr, mpp_nfd_3d_ptr, mpp_nfd_4d_ptr 82 !!gm end 83 ! 70 84 PUBLIC ctl_stop, ctl_warn, get_unit, ctl_opn, ctl_nam 71 85 PUBLIC mynode, mppstop, mppsync, mpp_comm_free 72 PUBLIC mpp_ini_north, mpp_lbc_north, mpp_lbc_north_e 86 PUBLIC mpp_ini_north, mpp_lbc_north_e 87 !!gm PUBLIC mpp_ini_north, mpp_lbc_north, mpp_lbc_north_e 88 PUBLIC mpp_lbc_north_icb, mpp_lnk_2d_icb 73 89 PUBLIC mpp_min, mpp_max, mpp_sum, mpp_minloc, mpp_maxloc 74 90 PUBLIC mpp_max_multiple 75 PUBLIC mpp_lnk_3d, mpp_lnk_3d_gather, mpp_lnk_2d, mpp_lnk_2d_e 76 PUBLIC mpp_lnk_2d_9 , mpp_lnk_2d_multiple 77 PUBLIC mpp_lnk_sum_3d, mpp_lnk_sum_2d 91 !!gm PUBLIC mpp_lnk_2d_9 92 !!gm PUBLIC mpp_lnk_sum_3d, mpp_lnk_sum_2d 78 93 PUBLIC mppscatter, mppgather 79 94 PUBLIC mpp_ini_ice, mpp_ini_znl … … 81 96 PUBLIC mppsend, mpprecv ! needed by TAM and ICB routines 82 97 PUBLIC mpp_lnk_bdy_2d, mpp_lnk_bdy_3d 83 PUBLIC mpp_lbc_north_icb, mpp_lnk_2d_icb84 98 PUBLIC mpprank 85 86 TYPE arrayptr87 REAL , DIMENSION (:,:), POINTER :: pt2d88 END TYPE arrayptr89 PUBLIC arrayptr90 99 91 100 !! * Interfaces … … 101 110 INTERFACE mpp_sum 102 111 MODULE PROCEDURE mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real, & 103 112 & mppsum_realdd, mppsum_a_realdd 104 113 END INTERFACE 105 INTERFACE mpp_lbc_north106 MODULE PROCEDURE mpp_lbc_north_3d, mpp_lbc_north_2d107 END INTERFACE114 !!gm INTERFACE mpp_lbc_north 115 !!gm MODULE PROCEDURE mpp_lbc_north_3d, mpp_lbc_north_2d 116 !!gm END INTERFACE 108 117 INTERFACE mpp_minloc 109 118 MODULE PROCEDURE mpp_minloc2d ,mpp_minloc3d … … 112 121 MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d 113 122 END INTERFACE 114 115 123 INTERFACE mpp_max_multiple 116 124 MODULE PROCEDURE mppmax_real_multiple … … 137 145 138 146 ! variables used in case of sea-ice 139 INTEGER, PUBLIC :: ncomm_ice !: communicator made by the processors with sea-ice (public so that it can be freed in limthd)140 INTEGER :: ngrp_iworld ! group ID for the world processors (for rheology)141 INTEGER :: ngrp_ice ! group ID for the ice processors (for rheology)142 INTEGER :: ndim_rank_ice ! number of 'ice' processors143 INTEGER :: n_ice_root ! number (in the comm_ice) of proc 0 in the ice comm147 INTEGER, PUBLIC :: ncomm_ice !: communicator made by the processors with sea-ice (public so that it can be freed in icethd) 148 INTEGER :: ngrp_iworld ! group ID for the world processors (for rheology) 149 INTEGER :: ngrp_ice ! group ID for the ice processors (for rheology) 150 INTEGER :: ndim_rank_ice ! number of 'ice' processors 151 INTEGER :: n_ice_root ! number (in the comm_ice) of proc 0 in the ice comm 144 152 INTEGER, DIMENSION(:), ALLOCATABLE, SAVE :: nrank_ice ! dimension ndim_rank_ice 145 153 146 154 ! variables used for zonal integration 147 155 INTEGER, PUBLIC :: ncomm_znl !: communicator made by the processors on the same zonal average 148 LOGICAL, PUBLIC :: l_znl_root ! True on the 'left'most processor on the same row149 INTEGER :: ngrp_znl !group ID for the znl processors150 INTEGER :: ndim_rank_znl !number of processors on the same zonal average156 LOGICAL, PUBLIC :: l_znl_root !: True on the 'left'most processor on the same row 157 INTEGER :: ngrp_znl ! group ID for the znl processors 158 INTEGER :: ndim_rank_znl ! number of processors on the same zonal average 151 159 INTEGER, DIMENSION(:), ALLOCATABLE, SAVE :: nrank_znl ! dimension ndim_rank_znl, number of the procs into the same znl domain 152 160 153 161 ! North fold condition in mpp_mpi with jpni > 1 (PUBLIC for TAM) 154 INTEGER, PUBLIC :: ngrp_world ! group ID for the world processors155 INTEGER, PUBLIC :: ngrp_opa ! group ID for the opa processors156 INTEGER, PUBLIC :: ngrp_north ! group ID for the northern processors (to be fold)157 INTEGER, PUBLIC :: ncomm_north ! communicator made by the processors belonging to ngrp_north158 INTEGER, PUBLIC :: ndim_rank_north ! number of 'sea' processor in the northern line (can be /= jpni !)159 INTEGER, PUBLIC :: njmppmax ! value of njmpp for the processors of the northern line160 INTEGER, PUBLIC :: north_root ! number (in the comm_opa) of proc 0 in the northern comm161 INTEGER, DIMENSION(:), ALLOCATABLE, SAVE, PUBLIC :: nrank_north !dimension ndim_rank_north162 INTEGER, PUBLIC :: ngrp_world !: group ID for the world processors 163 INTEGER, PUBLIC :: ngrp_opa !: group ID for the opa processors 164 INTEGER, PUBLIC :: ngrp_north !: group ID for the northern processors (to be fold) 165 INTEGER, PUBLIC :: ncomm_north !: communicator made by the processors belonging to ngrp_north 166 INTEGER, PUBLIC :: ndim_rank_north !: number of 'sea' processor in the northern line (can be /= jpni !) 167 INTEGER, PUBLIC :: njmppmax !: value of njmpp for the processors of the northern line 168 INTEGER, PUBLIC :: north_root !: number (in the comm_opa) of proc 0 in the northern comm 169 INTEGER, PUBLIC, DIMENSION(:), ALLOCATABLE, SAVE :: nrank_north !: dimension ndim_rank_north 162 170 163 171 ! Type of send : standard, buffered, immediate 164 CHARACTER(len=1), PUBLIC :: cn_mpi_send !type od mpi send/recieve (S=standard, B=bsend, I=isend)165 LOGICAL , PUBLIC :: l_isend = .FALSE. !isend use indicator (T if cn_mpi_send='I')166 INTEGER , PUBLIC :: nn_buffer !size of the buffer in case of mpi_bsend167 168 REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE :: tampon! buffer in case of bsend169 170 LOGICAL, PUBLIC :: ln_nnogather !namelist control of northfold comms171 LOGICAL, PUBLIC :: l_north_nogather = .FALSE. !internal control of northfold comms172 INTEGER, PUBLIC :: ityp 172 CHARACTER(len=1), PUBLIC :: cn_mpi_send !: type od mpi send/recieve (S=standard, B=bsend, I=isend) 173 LOGICAL , PUBLIC :: l_isend = .FALSE. !: isend use indicator (T if cn_mpi_send='I') 174 INTEGER , PUBLIC :: nn_buffer !: size of the buffer in case of mpi_bsend 175 176 REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE :: tampon ! buffer in case of bsend 177 178 LOGICAL, PUBLIC :: ln_nnogather !: namelist control of northfold comms 179 LOGICAL, PUBLIC :: l_north_nogather = .FALSE. !: internal control of northfold comms 180 173 181 !!---------------------------------------------------------------------- 174 182 !! NEMO/OPA 3.3 , NEMO Consortium (2010) … … 178 186 CONTAINS 179 187 180 181 FUNCTION mynode( ldtxt, ldname, kumnam_ref , kumnam_cfg , kumond , kstop, localComm ) 188 FUNCTION mynode( ldtxt, ldname, kumnam_ref, kumnam_cfg, kumond, kstop, localComm ) 182 189 !!---------------------------------------------------------------------- 183 190 !! *** routine mynode *** … … 204 211 WRITE(ldtxt(ii),*) '~~~~~~ ' ; ii = ii + 1 205 212 ! 206 207 213 REWIND( kumnam_ref ) ! Namelist nammpp in reference namelist: mpi variables 208 214 READ ( kumnam_ref, nammpp, IOSTAT = ios, ERR = 901) 209 215 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nammpp in reference namelist', lwp ) 210 216 ! 211 217 REWIND( kumnam_cfg ) ! Namelist nammpp in configuration namelist: mpi variables 212 218 READ ( kumnam_cfg, nammpp, IOSTAT = ios, ERR = 902 ) 213 219 902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nammpp in configuration namelist', lwp ) 214 220 ! 215 221 ! ! control print 216 222 WRITE(ldtxt(ii),*) ' Namelist nammpp' ; ii = ii + 1 217 223 WRITE(ldtxt(ii),*) ' mpi send type cn_mpi_send = ', cn_mpi_send ; ii = ii + 1 218 224 WRITE(ldtxt(ii),*) ' size exported buffer nn_buffer = ', nn_buffer,' bytes'; ii = ii + 1 219 225 ! 220 226 #if defined key_agrif 221 227 IF( .NOT. Agrif_Root() ) THEN … … 225 231 ENDIF 226 232 #endif 227 228 IF(jpnij < 1)THEN 229 ! If jpnij is not specified in namelist then we calculate it - this 230 ! means there will be no land cutting out. 231 jpnij = jpni * jpnj 232 END IF 233 234 IF( (jpni < 1) .OR. (jpnj < 1) )THEN 233 ! 234 IF( jpnij < 1 ) THEN ! If jpnij is not specified in namelist then we calculate it 235 jpnij = jpni * jpnj ! this means there will be no land cutting out. 236 ENDIF 237 238 IF( jpni < 1 .OR. jpnj < 1 ) THEN 235 239 WRITE(ldtxt(ii),*) ' jpni, jpnj and jpnij will be calculated automatically' ; ii = ii + 1 236 240 ELSE … … 238 242 WRITE(ldtxt(ii),*) ' processor grid extent in j jpnj = ',jpnj ; ii = ii + 1 239 243 WRITE(ldtxt(ii),*) ' number of local domains jpnij = ',jpnij ; ii = ii + 1 240 END 244 ENDIF 241 245 242 246 WRITE(ldtxt(ii),*) ' avoid use of mpi_allgather at the north fold ln_nnogather = ', ln_nnogather ; ii = ii + 1 … … 268 272 kstop = kstop + 1 269 273 END SELECT 270 ELSE IF ( PRESENT(localComm) .and. .not. mpi_was_called ) THEN 274 ! 275 ELSEIF ( PRESENT(localComm) .AND. .NOT. mpi_was_called ) THEN 271 276 WRITE(ldtxt(ii),*) ' lib_mpp: You cannot provide a local communicator ' ; ii = ii + 1 272 277 WRITE(ldtxt(ii),*) ' without calling MPI_Init before ! ' ; ii = ii + 1 … … 309 314 310 315 #if defined key_agrif 311 IF (Agrif_Root()) THEN316 IF( Agrif_Root() ) THEN 312 317 CALL Agrif_MPI_Init(mpi_comm_opa) 313 318 ELSE … … 329 334 END FUNCTION mynode 330 335 331 332 SUBROUTINE mpp_lnk_3d( ptab, cd_type, psgn, cd_mpp, pval ) 333 !!---------------------------------------------------------------------- 334 !! *** routine mpp_lnk_3d *** 335 !! 336 !! ** Purpose : Message passing manadgement 337 !! 338 !! ** Method : Use mppsend and mpprecv function for passing mask 339 !! between processors following neighboring subdomains. 340 !! domain parameters 341 !! nlci : first dimension of the local subdomain 342 !! nlcj : second dimension of the local subdomain 343 !! nbondi : mark for "east-west local boundary" 344 !! nbondj : mark for "north-south local boundary" 345 !! noea : number for local neighboring processors 346 !! nowe : number for local neighboring processors 347 !! noso : number for local neighboring processors 348 !! nono : number for local neighboring processors 349 !! 350 !! ** Action : ptab with update value at its periphery 351 !! 352 !!---------------------------------------------------------------------- 353 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: ptab ! 3D array on which the boundary condition is applied 354 CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points 355 ! ! = T , U , V , F , W points 356 REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary 357 ! ! = 1. , the sign is kept 358 CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only 359 REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries) 360 ! 361 INTEGER :: ji, jj, jk, jl ! dummy loop indices 362 INTEGER :: imigr, iihom, ijhom ! temporary integers 363 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 364 REAL(wp) :: zland 365 INTEGER , DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 366 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: zt3ns, zt3sn ! 3d for north-south & south-north 367 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: zt3ew, zt3we ! 3d for east-west & west-east 368 !!---------------------------------------------------------------------- 369 370 ALLOCATE( zt3ns(jpi,jprecj,jpk,2), zt3sn(jpi,jprecj,jpk,2), & 371 & zt3ew(jpj,jpreci,jpk,2), zt3we(jpj,jpreci,jpk,2) ) 372 373 ! 374 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value 375 ELSE ; zland = 0._wp ! zero by default 376 ENDIF 377 378 ! 1. standard boundary treatment 379 ! ------------------------------ 380 IF( PRESENT( cd_mpp ) ) THEN ! only fill added line/raw with existing values 381 ! 382 ! WARNING ptab is defined only between nld and nle 383 DO jk = 1, jpk 384 DO jj = nlcj+1, jpj ! added line(s) (inner only) 385 ptab(nldi :nlei , jj ,jk) = ptab(nldi:nlei, nlej,jk) 386 ptab(1 :nldi-1, jj ,jk) = ptab(nldi , nlej,jk) 387 ptab(nlei+1:nlci , jj ,jk) = ptab( nlei, nlej,jk) 388 END DO 389 DO ji = nlci+1, jpi ! added column(s) (full) 390 ptab(ji ,nldj :nlej ,jk) = ptab( nlei,nldj:nlej,jk) 391 ptab(ji ,1 :nldj-1,jk) = ptab( nlei,nldj ,jk) 392 ptab(ji ,nlej+1:jpj ,jk) = ptab( nlei, nlej,jk) 393 END DO 394 END DO 395 ! 396 ELSE ! standard close or cyclic treatment 397 ! 398 ! ! East-West boundaries 399 ! !* Cyclic east-west 400 IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 401 ptab( 1 ,:,:) = ptab(jpim1,:,:) 402 ptab(jpi,:,:) = ptab( 2 ,:,:) 403 ELSE !* closed 404 IF( .NOT. cd_type == 'F' ) ptab( 1 :jpreci,:,:) = zland ! south except F-point 405 ptab(nlci-jpreci+1:jpi ,:,:) = zland ! north 406 ENDIF 407 ! North-south cyclic 408 IF ( nbondj == 2 .AND. jperio == 7 ) THEN !* cyclic north south only with no mpp split in latitude 409 ptab(:,1 , :) = ptab(:, jpjm1,:) 410 ptab(:,jpj,:) = ptab(:, 2,:) 411 ELSE ! ! North-South boundaries (closed) 412 IF( .NOT. cd_type == 'F' ) ptab(:, 1 :jprecj,:) = zland ! south except F-point 413 ptab(:,nlcj-jprecj+1:jpj ,:) = zland ! north 414 ENDIF 415 ! 416 ENDIF 417 418 ! 2. East and west directions exchange 419 ! ------------------------------------ 420 ! we play with the neigbours AND the row number because of the periodicity 421 ! 422 SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions 423 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case) 424 iihom = nlci-nreci 425 DO jl = 1, jpreci 426 zt3ew(:,jl,:,1) = ptab(jpreci+jl,:,:) 427 zt3we(:,jl,:,1) = ptab(iihom +jl,:,:) 428 END DO 429 END SELECT 430 ! 431 ! ! Migrations 432 imigr = jpreci * jpj * jpk 433 ! 434 SELECT CASE ( nbondi ) 435 CASE ( -1 ) 436 CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req1 ) 437 CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea ) 438 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 439 CASE ( 0 ) 440 CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 ) 441 CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req2 ) 442 CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea ) 443 CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe ) 444 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 445 IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 446 CASE ( 1 ) 447 CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 ) 448 CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe ) 449 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 450 END SELECT 451 ! 452 ! ! Write Dirichlet lateral conditions 453 iihom = nlci-jpreci 454 ! 455 SELECT CASE ( nbondi ) 456 CASE ( -1 ) 457 DO jl = 1, jpreci 458 ptab(iihom+jl,:,:) = zt3ew(:,jl,:,2) 459 END DO 460 CASE ( 0 ) 461 DO jl = 1, jpreci 462 ptab(jl ,:,:) = zt3we(:,jl,:,2) 463 ptab(iihom+jl,:,:) = zt3ew(:,jl,:,2) 464 END DO 465 CASE ( 1 ) 466 DO jl = 1, jpreci 467 ptab(jl ,:,:) = zt3we(:,jl,:,2) 468 END DO 469 END SELECT 470 471 ! 3. North and south directions 472 ! ----------------------------- 473 ! always closed : we play only with the neigbours 474 ! 475 IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions 476 ijhom = nlcj-nrecj 477 DO jl = 1, jprecj 478 zt3sn(:,jl,:,1) = ptab(:,ijhom +jl,:) 479 zt3ns(:,jl,:,1) = ptab(:,jprecj+jl,:) 480 END DO 481 ENDIF 482 ! 483 ! ! Migrations 484 imigr = jprecj * jpi * jpk 485 ! 486 SELECT CASE ( nbondj ) 487 CASE ( -1 ) 488 CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req1 ) 489 CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono ) 490 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 491 CASE ( 0 ) 492 CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 ) 493 CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req2 ) 494 CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono ) 495 CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso ) 496 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 497 IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 498 CASE ( 1 ) 499 CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 ) 500 CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso ) 501 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 502 END SELECT 503 ! 504 ! ! Write Dirichlet lateral conditions 505 ijhom = nlcj-jprecj 506 ! 507 SELECT CASE ( nbondj ) 508 CASE ( -1 ) 509 DO jl = 1, jprecj 510 ptab(:,ijhom+jl,:) = zt3ns(:,jl,:,2) 511 END DO 512 CASE ( 0 ) 513 DO jl = 1, jprecj 514 ptab(:,jl ,:) = zt3sn(:,jl,:,2) 515 ptab(:,ijhom+jl,:) = zt3ns(:,jl,:,2) 516 END DO 517 CASE ( 1 ) 518 DO jl = 1, jprecj 519 ptab(:,jl,:) = zt3sn(:,jl,:,2) 520 END DO 521 END SELECT 522 523 ! 4. north fold treatment 524 ! ----------------------- 525 ! 526 IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 527 ! 528 SELECT CASE ( jpni ) 529 CASE ( 1 ) ; CALL lbc_nfd ( ptab, cd_type, psgn ) ! only 1 northern proc, no mpp 530 CASE DEFAULT ; CALL mpp_lbc_north( ptab, cd_type, psgn ) ! for all northern procs. 531 END SELECT 532 ! 533 ENDIF 534 ! 535 DEALLOCATE( zt3ns, zt3sn, zt3ew, zt3we ) 536 ! 537 END SUBROUTINE mpp_lnk_3d 538 539 540 SUBROUTINE mpp_lnk_2d_multiple( pt2d_array , type_array , psgn_array , num_fields , cd_mpp, pval ) 541 !!---------------------------------------------------------------------- 542 !! *** routine mpp_lnk_2d_multiple *** 543 !! 544 !! ** Purpose : Message passing management for multiple 2d arrays 545 !! 546 !! ** Method : Use mppsend and mpprecv function for passing mask 547 !! between processors following neighboring subdomains. 548 !! domain parameters 549 !! nlci : first dimension of the local subdomain 550 !! nlcj : second dimension of the local subdomain 551 !! nbondi : mark for "east-west local boundary" 552 !! nbondj : mark for "north-south local boundary" 553 !! noea : number for local neighboring processors 554 !! nowe : number for local neighboring processors 555 !! noso : number for local neighboring processors 556 !! nono : number for local neighboring processors 557 !!---------------------------------------------------------------------- 558 CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: type_array ! define the nature of ptab array grid-points 559 ! ! = T , U , V , F , W and I points 560 REAL(wp) , DIMENSION(:), INTENT(in ) :: psgn_array ! =-1 the sign change across the north fold boundary 561 ! ! = 1. , the sign is kept 562 CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only 563 REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries) 564 !! 565 INTEGER :: ji, jj, jl ! dummy loop indices 566 INTEGER :: ii !!MULTI SEND DUMMY LOOP INDICES 567 INTEGER :: imigr, iihom, ijhom ! temporary integers 568 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 569 INTEGER :: num_fields 570 TYPE( arrayptr ), DIMENSION(:) :: pt2d_array 571 REAL(wp) :: zland 572 INTEGER , DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 573 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ns, zt2sn ! 2d for north-south & south-north 574 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ew, zt2we ! 2d for east-west & west-east 575 576 !!---------------------------------------------------------------------- 577 ! 578 ALLOCATE( zt2ns(jpi,jprecj,2*num_fields), zt2sn(jpi,jprecj,2*num_fields), & 579 & zt2ew(jpj,jpreci,2*num_fields), zt2we(jpj,jpreci,2*num_fields) ) 580 ! 581 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value 582 ELSE ; zland = 0._wp ! zero by default 583 ENDIF 584 585 ! 1. standard boundary treatment 586 ! ------------------------------ 587 ! 588 !First Array 589 DO ii = 1 , num_fields 590 IF( PRESENT( cd_mpp ) ) THEN ! only fill added line/raw with existing values 591 ! 592 ! WARNING pt2d is defined only between nld and nle 593 DO jj = nlcj+1, jpj ! added line(s) (inner only) 594 pt2d_array(ii)%pt2d(nldi :nlei , jj) = pt2d_array(ii)%pt2d(nldi:nlei, nlej) 595 pt2d_array(ii)%pt2d(1 :nldi-1, jj) = pt2d_array(ii)%pt2d(nldi , nlej) 596 pt2d_array(ii)%pt2d(nlei+1:nlci , jj) = pt2d_array(ii)%pt2d( nlei, nlej) 597 END DO 598 DO ji = nlci+1, jpi ! added column(s) (full) 599 pt2d_array(ii)%pt2d(ji, nldj :nlej ) = pt2d_array(ii)%pt2d(nlei, nldj:nlej) 600 pt2d_array(ii)%pt2d(ji, 1 :nldj-1) = pt2d_array(ii)%pt2d(nlei, nldj ) 601 pt2d_array(ii)%pt2d(ji, nlej+1:jpj ) = pt2d_array(ii)%pt2d(nlei, nlej) 602 END DO 603 ! 604 ELSE ! standard close or cyclic treatment 605 ! 606 ! ! East-West boundaries 607 IF( nbondi == 2 .AND. & ! Cyclic east-west 608 & (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 609 pt2d_array(ii)%pt2d( 1 , : ) = pt2d_array(ii)%pt2d( jpim1, : ) ! west 610 pt2d_array(ii)%pt2d( jpi , : ) = pt2d_array(ii)%pt2d( 2 , : ) ! east 611 ELSE ! closed 612 IF( .NOT. type_array(ii) == 'F' ) pt2d_array(ii)%pt2d( 1 : jpreci,:) = zland ! south except F-point 613 pt2d_array(ii)%pt2d(nlci-jpreci+1 : jpi ,:) = zland ! north 614 ENDIF 615 ! Noth-South boundaries 616 IF ( nbondj == 2 .AND. jperio == 7 ) THEN !* cyclic north south 617 pt2d_array(ii)%pt2d(:, 1 ) = pt2d_array(ii)%pt2d(:, jpjm1 ) 618 pt2d_array(ii)%pt2d(:, jpj ) = pt2d_array(ii)%pt2d(:, 2 ) 619 ELSE ! 620 ! ! North-South boundaries (closed) 621 IF( .NOT. type_array(ii) == 'F' ) pt2d_array(ii)%pt2d(:, 1:jprecj ) = zland ! south except F-point 622 pt2d_array(ii)%pt2d(:, nlcj-jprecj+1:jpj ) = zland ! north 623 ! 624 ENDIF 625 ENDIF 626 END DO 627 628 ! 2. East and west directions exchange 629 ! ------------------------------------ 630 ! we play with the neigbours AND the row number because of the periodicity 631 ! 632 DO ii = 1 , num_fields 633 SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions 634 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case) 635 iihom = nlci-nreci 636 DO jl = 1, jpreci 637 zt2ew( : , jl , ii ) = pt2d_array(ii)%pt2d( jpreci+jl , : ) 638 zt2we( : , jl , ii ) = pt2d_array(ii)%pt2d( iihom +jl , : ) 639 END DO 640 END SELECT 641 END DO 642 ! 643 ! ! Migrations 644 imigr = jpreci * jpj 645 ! 646 SELECT CASE ( nbondi ) 647 CASE ( -1 ) 648 CALL mppsend( 2, zt2we(1,1,1), num_fields*imigr, noea, ml_req1 ) 649 CALL mpprecv( 1, zt2ew(1,1,num_fields+1), num_fields*imigr, noea ) 650 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 651 CASE ( 0 ) 652 CALL mppsend( 1, zt2ew(1,1,1), num_fields*imigr, nowe, ml_req1 ) 653 CALL mppsend( 2, zt2we(1,1,1), num_fields*imigr, noea, ml_req2 ) 654 CALL mpprecv( 1, zt2ew(1,1,num_fields+1), num_fields*imigr, noea ) 655 CALL mpprecv( 2, zt2we(1,1,num_fields+1), num_fields*imigr, nowe ) 656 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 657 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 658 CASE ( 1 ) 659 CALL mppsend( 1, zt2ew(1,1,1), num_fields*imigr, nowe, ml_req1 ) 660 CALL mpprecv( 2, zt2we(1,1,num_fields+1), num_fields*imigr, nowe ) 661 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 662 END SELECT 663 ! 664 ! ! Write Dirichlet lateral conditions 665 iihom = nlci - jpreci 666 ! 667 668 DO ii = 1 , num_fields 669 SELECT CASE ( nbondi ) 670 CASE ( -1 ) 671 DO jl = 1, jpreci 672 pt2d_array(ii)%pt2d( iihom+jl , : ) = zt2ew(:,jl,num_fields+ii) 673 END DO 674 CASE ( 0 ) 675 DO jl = 1, jpreci 676 pt2d_array(ii)%pt2d( jl , : ) = zt2we(:,jl,num_fields+ii) 677 pt2d_array(ii)%pt2d( iihom+jl , : ) = zt2ew(:,jl,num_fields+ii) 678 END DO 679 CASE ( 1 ) 680 DO jl = 1, jpreci 681 pt2d_array(ii)%pt2d( jl , : )= zt2we(:,jl,num_fields+ii) 682 END DO 683 END SELECT 684 END DO 685 686 ! 3. North and south directions 687 ! ----------------------------- 688 ! always closed : we play only with the neigbours 689 ! 690 !First Array 691 DO ii = 1 , num_fields 692 IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions 693 ijhom = nlcj-nrecj 694 DO jl = 1, jprecj 695 zt2sn(:,jl , ii) = pt2d_array(ii)%pt2d( : , ijhom +jl ) 696 zt2ns(:,jl , ii) = pt2d_array(ii)%pt2d( : , jprecj+jl ) 697 END DO 698 ENDIF 699 END DO 700 ! 701 ! ! Migrations 702 imigr = jprecj * jpi 703 ! 704 SELECT CASE ( nbondj ) 705 CASE ( -1 ) 706 CALL mppsend( 4, zt2sn(1,1,1), num_fields*imigr, nono, ml_req1 ) 707 CALL mpprecv( 3, zt2ns(1,1,num_fields+1), num_fields*imigr, nono ) 708 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 709 CASE ( 0 ) 710 CALL mppsend( 3, zt2ns(1,1,1), num_fields*imigr, noso, ml_req1 ) 711 CALL mppsend( 4, zt2sn(1,1,1), num_fields*imigr, nono, ml_req2 ) 712 CALL mpprecv( 3, zt2ns(1,1,num_fields+1), num_fields*imigr, nono ) 713 CALL mpprecv( 4, zt2sn(1,1,num_fields+1), num_fields*imigr, noso ) 714 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 715 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 716 CASE ( 1 ) 717 CALL mppsend( 3, zt2ns(1,1,1), num_fields*imigr, noso, ml_req1 ) 718 CALL mpprecv( 4, zt2sn(1,1,num_fields+1), num_fields*imigr, noso ) 719 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 720 END SELECT 721 ! 722 ! ! Write Dirichlet lateral conditions 723 ijhom = nlcj - jprecj 724 ! 725 726 DO ii = 1 , num_fields 727 !First Array 728 SELECT CASE ( nbondj ) 729 CASE ( -1 ) 730 DO jl = 1, jprecj 731 pt2d_array(ii)%pt2d( : , ijhom+jl ) = zt2ns( : , jl , num_fields+ii ) 732 END DO 733 CASE ( 0 ) 734 DO jl = 1, jprecj 735 pt2d_array(ii)%pt2d( : , jl ) = zt2sn( : , jl , num_fields + ii) 736 pt2d_array(ii)%pt2d( : , ijhom + jl ) = zt2ns( : , jl , num_fields + ii ) 737 END DO 738 CASE ( 1 ) 739 DO jl = 1, jprecj 740 pt2d_array(ii)%pt2d( : , jl ) = zt2sn( : , jl , num_fields + ii ) 741 END DO 742 END SELECT 743 END DO 744 745 ! 4. north fold treatment 746 ! ----------------------- 747 ! 748 !First Array 749 IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 750 ! 751 SELECT CASE ( jpni ) 752 CASE ( 1 ) ; 753 DO ii = 1 , num_fields 754 CALL lbc_nfd ( pt2d_array(ii)%pt2d( : , : ), type_array(ii) , psgn_array(ii) ) ! only 1 northern proc, no mpp 755 END DO 756 CASE DEFAULT ; CALL mpp_lbc_north_2d_multiple( pt2d_array, type_array, psgn_array, num_fields ) ! for all northern procs. 757 END SELECT 758 ! 759 ENDIF 760 ! 761 ! 762 DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we ) 763 ! 764 END SUBROUTINE mpp_lnk_2d_multiple 765 766 767 SUBROUTINE load_array( pt2d, cd_type, psgn, pt2d_array, type_array, psgn_array, num_fields ) 768 !!--------------------------------------------------------------------- 769 REAL(wp), DIMENSION(jpi,jpj), TARGET, INTENT(inout) :: pt2d ! Second 2D array on which the boundary condition is applied 770 CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points 771 REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary 772 TYPE(arrayptr) , DIMENSION(9) :: pt2d_array 773 CHARACTER(len=1) , DIMENSION(9) :: type_array ! define the nature of ptab array grid-points 774 REAL(wp) , DIMENSION(9) :: psgn_array ! =-1 the sign change across the north fold boundary 775 INTEGER , INTENT (inout) :: num_fields 776 !!--------------------------------------------------------------------- 777 num_fields = num_fields + 1 778 pt2d_array(num_fields)%pt2d => pt2d 779 type_array(num_fields) = cd_type 780 psgn_array(num_fields) = psgn 781 END SUBROUTINE load_array 336 !!---------------------------------------------------------------------- 337 !! *** routine mpp_lnk_(2,3,4)d *** 338 !! 339 !! * Argument : dummy argument use in mpp_lnk_... routines 340 !! ptab : array or pointer of arrays on which the boundary condition is applied 341 !! cd_nat : nature of array grid-points 342 !! psgn : sign used across the north fold boundary 343 !! kfld : optional, number of pt3d arrays 344 !! cd_mpp : optional, fill the overlap area only 345 !! pval : optional, background value (used at closed boundaries) 346 !!---------------------------------------------------------------------- 347 ! 348 ! !== 2D array and array of 2D pointer ==! 349 ! 350 # define DIM_2d 351 # define ROUTINE_LNK mpp_lnk_2d 352 # include "mpp_lnk_generic.h90" 353 # undef ROUTINE_LNK 354 # define MULTI 355 # define ROUTINE_LNK mpp_lnk_2d_ptr 356 # include "mpp_lnk_generic.h90" 357 # undef ROUTINE_LNK 358 # undef MULTI 359 # undef DIM_2d 360 ! 361 ! !== 3D array and array of 3D pointer ==! 362 ! 363 # define DIM_3d 364 # define ROUTINE_LNK mpp_lnk_3d 365 # include "mpp_lnk_generic.h90" 366 # undef ROUTINE_LNK 367 # define MULTI 368 # define ROUTINE_LNK mpp_lnk_3d_ptr 369 # include "mpp_lnk_generic.h90" 370 # undef ROUTINE_LNK 371 # undef MULTI 372 # undef DIM_3d 373 ! 374 ! !== 4D array and array of 4D pointer ==! 375 ! 376 # define DIM_4d 377 # define ROUTINE_LNK mpp_lnk_4d 378 # include "mpp_lnk_generic.h90" 379 # undef ROUTINE_LNK 380 # define MULTI 381 # define ROUTINE_LNK mpp_lnk_4d_ptr 382 # include "mpp_lnk_generic.h90" 383 # undef ROUTINE_LNK 384 # undef MULTI 385 # undef DIM_4d 386 387 !!---------------------------------------------------------------------- 388 !! *** routine mpp_nfd_(2,3,4)d *** 389 !! 390 !! * Argument : dummy argument use in mpp_nfd_... routines 391 !! ptab : array or pointer of arrays on which the boundary condition is applied 392 !! cd_nat : nature of array grid-points 393 !! psgn : sign used across the north fold boundary 394 !! kfld : optional, number of pt3d arrays 395 !! cd_mpp : optional, fill the overlap area only 396 !! pval : optional, background value (used at closed boundaries) 397 !!---------------------------------------------------------------------- 398 ! 399 ! !== 2D array and array of 2D pointer ==! 400 ! 401 # define DIM_2d 402 # define ROUTINE_NFD mpp_nfd_2d 403 # include "mpp_nfd_generic.h90" 404 # undef ROUTINE_NFD 405 # define MULTI 406 # define ROUTINE_NFD mpp_nfd_2d_ptr 407 # include "mpp_nfd_generic.h90" 408 # undef ROUTINE_NFD 409 # undef MULTI 410 # undef DIM_2d 411 ! 412 ! !== 3D array and array of 3D pointer ==! 413 ! 414 # define DIM_3d 415 # define ROUTINE_NFD mpp_nfd_3d 416 # include "mpp_nfd_generic.h90" 417 # undef ROUTINE_NFD 418 # define MULTI 419 # define ROUTINE_NFD mpp_nfd_3d_ptr 420 # include "mpp_nfd_generic.h90" 421 # undef ROUTINE_NFD 422 # undef MULTI 423 # undef DIM_3d 424 ! 425 ! !== 4D array and array of 4D pointer ==! 426 ! 427 # define DIM_4d 428 # define ROUTINE_NFD mpp_nfd_4d 429 # include "mpp_nfd_generic.h90" 430 # undef ROUTINE_NFD 431 # define MULTI 432 # define ROUTINE_NFD mpp_nfd_4d_ptr 433 # include "mpp_nfd_generic.h90" 434 # undef ROUTINE_NFD 435 # undef MULTI 436 # undef DIM_4d 437 438 439 !!---------------------------------------------------------------------- 440 !! *** routine mpp_lnk_bdy_(2,3,4)d *** 441 !! 442 !! * Argument : dummy argument use in mpp_lnk_... routines 443 !! ptab : array or pointer of arrays on which the boundary condition is applied 444 !! cd_nat : nature of array grid-points 445 !! psgn : sign used across the north fold boundary 446 !! kb_bdy : BDY boundary set 447 !! kfld : optional, number of pt3d arrays 448 !!---------------------------------------------------------------------- 449 ! 450 ! !== 2D array and array of 2D pointer ==! 451 ! 452 # define DIM_2d 453 # define ROUTINE_BDY mpp_lnk_bdy_2d 454 # include "mpp_bdy_generic.h90" 455 # undef ROUTINE_BDY 456 # define MULTI 457 # define ROUTINE_BDY mpp_lnk_bdy_2d_ptr 458 # include "mpp_bdy_generic.h90" 459 # undef ROUTINE_BDY 460 # undef MULTI 461 # undef DIM_2d 462 ! 463 ! !== 3D array and array of 3D pointer ==! 464 ! 465 # define DIM_3d 466 # define ROUTINE_BDY mpp_lnk_bdy_3d 467 # include "mpp_bdy_generic.h90" 468 # undef ROUTINE_BDY 469 # define MULTI 470 # define ROUTINE_BDY mpp_lnk_bdy_3d_ptr 471 # include "mpp_bdy_generic.h90" 472 # undef ROUTINE_BDY 473 # undef MULTI 474 # undef DIM_3d 475 ! 476 ! !== 4D array and array of 4D pointer ==! 477 ! 478 !!# define DIM_4d 479 !!# define ROUTINE_BDY mpp_lnk_bdy_4d 480 !!# include "mpp_bdy_generic.h90" 481 !!# undef ROUTINE_BDY 482 !!# define MULTI 483 !!# define ROUTINE_BDY mpp_lnk_bdy_4d_ptr 484 !!# include "mpp_bdy_generic.h90" 485 !!# undef ROUTINE_BDY 486 !!# undef MULTI 487 !!# undef DIM_4d 488 489 !!---------------------------------------------------------------------- 490 !! 491 !! load_array & mpp_lnk_2d_9 à generaliser a 3D et 4D 782 492 783 493 784 SUBROUTINE mpp_lnk_2d_9( pt2dA, cd_typeA, psgnA, pt2dB, cd_typeB, psgnB, pt2dC, cd_typeC, psgnC & 785 & , pt2dD, cd_typeD, psgnD, pt2dE, cd_typeE, psgnE, pt2dF, cd_typeF, psgnF & 786 & , pt2dG, cd_typeG, psgnG, pt2dH, cd_typeH, psgnH, pt2dI, cd_typeI, psgnI, cd_mpp, pval) 787 !!--------------------------------------------------------------------- 788 ! Second 2D array on which the boundary condition is applied 789 REAL(wp), DIMENSION(jpi,jpj), TARGET , INTENT(inout) :: pt2dA 790 REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) :: pt2dB , pt2dC , pt2dD , pt2dE 791 REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) :: pt2dF , pt2dG , pt2dH , pt2dI 792 ! define the nature of ptab array grid-points 793 CHARACTER(len=1) , INTENT(in ) :: cd_typeA 794 CHARACTER(len=1) , OPTIONAL, INTENT(in ) :: cd_typeB , cd_typeC , cd_typeD , cd_typeE 795 CHARACTER(len=1) , OPTIONAL, INTENT(in ) :: cd_typeF , cd_typeG , cd_typeH , cd_typeI 796 ! =-1 the sign change across the north fold boundary 797 REAL(wp) , INTENT(in ) :: psgnA 798 REAL(wp) , OPTIONAL, INTENT(in ) :: psgnB , psgnC , psgnD , psgnE 799 REAL(wp) , OPTIONAL, INTENT(in ) :: psgnF , psgnG , psgnH , psgnI 800 CHARACTER(len=3) , OPTIONAL, INTENT(in ) :: cd_mpp ! fill the overlap area only 801 REAL(wp) , OPTIONAL, INTENT(in ) :: pval ! background value (used at closed boundaries) 802 !! 803 TYPE(arrayptr) , DIMENSION(9) :: pt2d_array 804 CHARACTER(len=1) , DIMENSION(9) :: type_array ! define the nature of ptab array grid-points 805 ! ! = T , U , V , F , W and I points 806 REAL(wp) , DIMENSION(9) :: psgn_array ! =-1 the sign change across the north fold boundary 807 INTEGER :: num_fields 808 !!--------------------------------------------------------------------- 809 ! 810 num_fields = 0 811 ! 812 ! Load the first array 813 CALL load_array( pt2dA, cd_typeA, psgnA, pt2d_array, type_array, psgn_array, num_fields ) 814 ! 815 ! Look if more arrays are added 816 IF( PRESENT(psgnB) ) CALL load_array(pt2dB,cd_typeB,psgnB,pt2d_array, type_array, psgn_array,num_fields) 817 IF( PRESENT(psgnC) ) CALL load_array(pt2dC,cd_typeC,psgnC,pt2d_array, type_array, psgn_array,num_fields) 818 IF( PRESENT(psgnD) ) CALL load_array(pt2dD,cd_typeD,psgnD,pt2d_array, type_array, psgn_array,num_fields) 819 IF( PRESENT(psgnE) ) CALL load_array(pt2dE,cd_typeE,psgnE,pt2d_array, type_array, psgn_array,num_fields) 820 IF( PRESENT(psgnF) ) CALL load_array(pt2dF,cd_typeF,psgnF,pt2d_array, type_array, psgn_array,num_fields) 821 IF( PRESENT(psgnG) ) CALL load_array(pt2dG,cd_typeG,psgnG,pt2d_array, type_array, psgn_array,num_fields) 822 IF( PRESENT(psgnH) ) CALL load_array(pt2dH,cd_typeH,psgnH,pt2d_array, type_array, psgn_array,num_fields) 823 IF( PRESENT(psgnI) ) CALL load_array(pt2dI,cd_typeI,psgnI,pt2d_array, type_array, psgn_array,num_fields) 824 ! 825 CALL mpp_lnk_2d_multiple( pt2d_array, type_array, psgn_array, num_fields, cd_mpp,pval ) 826 ! 827 END SUBROUTINE mpp_lnk_2d_9 828 829 830 SUBROUTINE mpp_lnk_2d( pt2d, cd_type, psgn, cd_mpp, pval ) 831 !!---------------------------------------------------------------------- 832 !! *** routine mpp_lnk_2d *** 833 !! 834 !! ** Purpose : Message passing manadgement for 2d array 835 !! 836 !! ** Method : Use mppsend and mpprecv function for passing mask 837 !! between processors following neighboring subdomains. 838 !! domain parameters 839 !! nlci : first dimension of the local subdomain 840 !! nlcj : second dimension of the local subdomain 841 !! nbondi : mark for "east-west local boundary" 842 !! nbondj : mark for "north-south local boundary" 843 !! noea : number for local neighboring processors 844 !! nowe : number for local neighboring processors 845 !! noso : number for local neighboring processors 846 !! nono : number for local neighboring processors 847 !! 848 !!---------------------------------------------------------------------- 849 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pt2d ! 2D array on which the boundary condition is applied 850 CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points 851 ! ! = T , U , V , F , W and I points 852 REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary 853 ! ! = 1. , the sign is kept 854 CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only 855 REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries) 856 !! 857 INTEGER :: ji, jj, jl ! dummy loop indices 858 INTEGER :: imigr, iihom, ijhom ! temporary integers 859 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 860 REAL(wp) :: zland 861 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 862 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ns, zt2sn ! 2d for north-south & south-north 863 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ew, zt2we ! 2d for east-west & west-east 864 !!---------------------------------------------------------------------- 865 ! 866 ALLOCATE( zt2ns(jpi,jprecj,2), zt2sn(jpi,jprecj,2), & 867 & zt2ew(jpj,jpreci,2), zt2we(jpj,jpreci,2) ) 868 ! 869 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value 870 ELSE ; zland = 0._wp ! zero by default 871 ENDIF 872 873 ! 1. standard boundary treatment 874 ! ------------------------------ 875 ! 876 IF( PRESENT( cd_mpp ) ) THEN ! only fill added line/raw with existing values 877 ! 878 ! WARNING pt2d is defined only between nld and nle 879 DO jj = nlcj+1, jpj ! added line(s) (inner only) 880 pt2d(nldi :nlei , jj ) = pt2d(nldi:nlei, nlej) 881 pt2d(1 :nldi-1, jj ) = pt2d(nldi , nlej) 882 pt2d(nlei+1:nlci , jj ) = pt2d( nlei, nlej) 883 END DO 884 DO ji = nlci+1, jpi ! added column(s) (full) 885 pt2d(ji ,nldj :nlej ) = pt2d( nlei,nldj:nlej) 886 pt2d(ji ,1 :nldj-1) = pt2d( nlei,nldj ) 887 pt2d(ji ,nlej+1:jpj ) = pt2d( nlei, nlej) 888 END DO 889 ! 890 ELSE ! standard close or cyclic treatment 891 ! 892 ! ! East-West boundaries 893 IF( nbondi == 2 .AND. & ! Cyclic east-west 894 & (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 895 pt2d( 1 ,:) = pt2d(jpim1,:) ! west 896 pt2d(jpi,:) = pt2d( 2 ,:) ! east 897 ELSE ! closed 898 IF( .NOT. cd_type == 'F' ) pt2d( 1 :jpreci,:) = zland ! south except F-point 899 pt2d(nlci-jpreci+1:jpi ,:) = zland ! north 900 ENDIF 901 ! North-South boudaries 902 IF ( nbondj == 2 .AND. jperio == 7 ) THEN !* cyclic north south 903 pt2d(:, 1 ) = pt2d(:,jpjm1) 904 pt2d(:, jpj) = pt2d(:, 2) 905 ELSE 906 ! ! North-South boundaries (closed) 907 IF( .NOT. cd_type == 'F' ) pt2d(:, 1 :jprecj) = zland !south except F-point 908 pt2d(:,nlcj-jprecj+1:jpj ) = zland ! north 909 ENDIF 910 ENDIF 911 912 ! 2. East and west directions exchange 913 ! ------------------------------------ 914 ! we play with the neigbours AND the row number because of the periodicity 915 ! 916 SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions 917 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case) 918 iihom = nlci-nreci 919 DO jl = 1, jpreci 920 zt2ew(:,jl,1) = pt2d(jpreci+jl,:) 921 zt2we(:,jl,1) = pt2d(iihom +jl,:) 922 END DO 923 END SELECT 924 ! 925 ! ! Migrations 926 imigr = jpreci * jpj 927 ! 928 SELECT CASE ( nbondi ) 929 CASE ( -1 ) 930 CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req1 ) 931 CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea ) 932 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 933 CASE ( 0 ) 934 CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 ) 935 CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req2 ) 936 CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea ) 937 CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe ) 938 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 939 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 940 CASE ( 1 ) 941 CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 ) 942 CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe ) 943 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 944 END SELECT 945 ! 946 ! ! Write Dirichlet lateral conditions 947 iihom = nlci - jpreci 948 ! 949 SELECT CASE ( nbondi ) 950 CASE ( -1 ) 951 DO jl = 1, jpreci 952 pt2d(iihom+jl,:) = zt2ew(:,jl,2) 953 END DO 954 CASE ( 0 ) 955 DO jl = 1, jpreci 956 pt2d(jl ,:) = zt2we(:,jl,2) 957 pt2d(iihom+jl,:) = zt2ew(:,jl,2) 958 END DO 959 CASE ( 1 ) 960 DO jl = 1, jpreci 961 pt2d(jl ,:) = zt2we(:,jl,2) 962 END DO 963 END SELECT 964 965 966 ! 3. North and south directions 967 ! ----------------------------- 968 ! always closed : we play only with the neigbours 969 ! 970 IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions 971 ijhom = nlcj-nrecj 972 DO jl = 1, jprecj 973 zt2sn(:,jl,1) = pt2d(:,ijhom +jl) 974 zt2ns(:,jl,1) = pt2d(:,jprecj+jl) 975 END DO 976 ENDIF 977 ! 978 ! ! Migrations 979 imigr = jprecj * jpi 980 ! 981 SELECT CASE ( nbondj ) 982 CASE ( -1 ) 983 CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req1 ) 984 CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono ) 985 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 986 CASE ( 0 ) 987 CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 ) 988 CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req2 ) 989 CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono ) 990 CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso ) 991 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 992 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 993 CASE ( 1 ) 994 CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 ) 995 CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso ) 996 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 997 END SELECT 998 ! 999 ! ! Write Dirichlet lateral conditions 1000 ijhom = nlcj - jprecj 1001 ! 1002 SELECT CASE ( nbondj ) 1003 CASE ( -1 ) 1004 DO jl = 1, jprecj 1005 pt2d(:,ijhom+jl) = zt2ns(:,jl,2) 1006 END DO 1007 CASE ( 0 ) 1008 DO jl = 1, jprecj 1009 pt2d(:,jl ) = zt2sn(:,jl,2) 1010 pt2d(:,ijhom+jl) = zt2ns(:,jl,2) 1011 END DO 1012 CASE ( 1 ) 1013 DO jl = 1, jprecj 1014 pt2d(:,jl ) = zt2sn(:,jl,2) 1015 END DO 1016 END SELECT 1017 1018 1019 ! 4. north fold treatment 1020 ! ----------------------- 1021 ! 1022 IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 1023 ! 1024 SELECT CASE ( jpni ) 1025 CASE ( 1 ) ; CALL lbc_nfd ( pt2d, cd_type, psgn ) ! only 1 northern proc, no mpp 1026 CASE DEFAULT ; CALL mpp_lbc_north( pt2d, cd_type, psgn ) ! for all northern procs. 1027 END SELECT 1028 ! 1029 ENDIF 1030 ! 1031 DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we ) 1032 ! 1033 END SUBROUTINE mpp_lnk_2d 1034 1035 1036 SUBROUTINE mpp_lnk_3d_gather( ptab1, cd_type1, ptab2, cd_type2, psgn ) 1037 !!---------------------------------------------------------------------- 1038 !! *** routine mpp_lnk_3d_gather *** 1039 !! 1040 !! ** Purpose : Message passing manadgement for two 3D arrays 1041 !! 1042 !! ** Method : Use mppsend and mpprecv function for passing mask 1043 !! between processors following neighboring subdomains. 1044 !! domain parameters 1045 !! nlci : first dimension of the local subdomain 1046 !! nlcj : second dimension of the local subdomain 1047 !! nbondi : mark for "east-west local boundary" 1048 !! nbondj : mark for "north-south local boundary" 1049 !! noea : number for local neighboring processors 1050 !! nowe : number for local neighboring processors 1051 !! noso : number for local neighboring processors 1052 !! nono : number for local neighboring processors 1053 !! 1054 !! ** Action : ptab1 and ptab2 with update value at its periphery 1055 !! 1056 !!---------------------------------------------------------------------- 1057 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: ptab1 ! first and second 3D array on which 1058 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: ptab2 ! the boundary condition is applied 1059 CHARACTER(len=1) , INTENT(in ) :: cd_type1 ! nature of ptab1 and ptab2 arrays 1060 CHARACTER(len=1) , INTENT(in ) :: cd_type2 ! i.e. grid-points = T , U , V , F or W points 1061 REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary 1062 !! ! = 1. , the sign is kept 1063 INTEGER :: jl ! dummy loop indices 1064 INTEGER :: imigr, iihom, ijhom ! temporary integers 1065 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 1066 INTEGER , DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 1067 REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE :: zt4ns, zt4sn ! 2 x 3d for north-south & south-north 1068 REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE :: zt4ew, zt4we ! 2 x 3d for east-west & west-east 1069 !!---------------------------------------------------------------------- 1070 ! 1071 ALLOCATE( zt4ns(jpi,jprecj,jpk,2,2), zt4sn(jpi,jprecj,jpk,2,2) , & 1072 & zt4ew(jpj,jpreci,jpk,2,2), zt4we(jpj,jpreci,jpk,2,2) ) 1073 ! 1074 ! 1. standard boundary treatment 1075 ! ------------------------------ 1076 ! ! East-West boundaries 1077 ! !* Cyclic east-west 1078 IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 1079 ptab1( 1 ,:,:) = ptab1(jpim1,:,:) 1080 ptab1(jpi,:,:) = ptab1( 2 ,:,:) 1081 ptab2( 1 ,:,:) = ptab2(jpim1,:,:) 1082 ptab2(jpi,:,:) = ptab2( 2 ,:,:) 1083 ELSE !* closed 1084 IF( .NOT. cd_type1 == 'F' ) ptab1( 1 :jpreci,:,:) = 0.e0 ! south except at F-point 1085 IF( .NOT. cd_type2 == 'F' ) ptab2( 1 :jpreci,:,:) = 0.e0 1086 ptab1(nlci-jpreci+1:jpi ,:,:) = 0.e0 ! north 1087 ptab2(nlci-jpreci+1:jpi ,:,:) = 0.e0 1088 ENDIF 1089 ! North-South boundaries 1090 IF ( nbondj == 2 .AND. jperio == 7 ) THEN !* cyclic north south 1091 ptab1(:, 1 ,:) = ptab1(: , jpjm1 , :) 1092 ptab1(:, jpj ,:) = ptab1(: , 2 , :) 1093 ptab2(:, 1 ,:) = ptab2(: , jpjm1 , :) 1094 ptab2(:, jpj ,:) = ptab2(: , 2 , :) 1095 ELSE 1096 ! ! North-South boundaries closed 1097 IF( .NOT. cd_type1 == 'F' ) ptab1(:, 1 :jprecj,:) = 0.e0 ! south except at F-point 1098 IF( .NOT. cd_type2 == 'F' ) ptab2(:, 1 :jprecj,:) = 0.e0 1099 ptab1(:,nlcj-jprecj+1:jpj ,:) = 0.e0 ! north 1100 ptab2(:,nlcj-jprecj+1:jpj ,:) = 0.e0 1101 ENDIF 1102 1103 ! 2. East and west directions exchange 1104 ! ------------------------------------ 1105 ! we play with the neigbours AND the row number because of the periodicity 1106 ! 1107 SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions 1108 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case) 1109 iihom = nlci-nreci 1110 DO jl = 1, jpreci 1111 zt4ew(:,jl,:,1,1) = ptab1(jpreci+jl,:,:) 1112 zt4we(:,jl,:,1,1) = ptab1(iihom +jl,:,:) 1113 zt4ew(:,jl,:,2,1) = ptab2(jpreci+jl,:,:) 1114 zt4we(:,jl,:,2,1) = ptab2(iihom +jl,:,:) 1115 END DO 1116 END SELECT 1117 ! 1118 ! ! Migrations 1119 imigr = jpreci * jpj * jpk *2 1120 ! 1121 SELECT CASE ( nbondi ) 1122 CASE ( -1 ) 1123 CALL mppsend( 2, zt4we(1,1,1,1,1), imigr, noea, ml_req1 ) 1124 CALL mpprecv( 1, zt4ew(1,1,1,1,2), imigr, noea ) 1125 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 1126 CASE ( 0 ) 1127 CALL mppsend( 1, zt4ew(1,1,1,1,1), imigr, nowe, ml_req1 ) 1128 CALL mppsend( 2, zt4we(1,1,1,1,1), imigr, noea, ml_req2 ) 1129 CALL mpprecv( 1, zt4ew(1,1,1,1,2), imigr, noea ) 1130 CALL mpprecv( 2, zt4we(1,1,1,1,2), imigr, nowe ) 1131 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 1132 IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 1133 CASE ( 1 ) 1134 CALL mppsend( 1, zt4ew(1,1,1,1,1), imigr, nowe, ml_req1 ) 1135 CALL mpprecv( 2, zt4we(1,1,1,1,2), imigr, nowe ) 1136 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 1137 END SELECT 1138 ! 1139 ! ! Write Dirichlet lateral conditions 1140 iihom = nlci - jpreci 1141 ! 1142 SELECT CASE ( nbondi ) 1143 CASE ( -1 ) 1144 DO jl = 1, jpreci 1145 ptab1(iihom+jl,:,:) = zt4ew(:,jl,:,1,2) 1146 ptab2(iihom+jl,:,:) = zt4ew(:,jl,:,2,2) 1147 END DO 1148 CASE ( 0 ) 1149 DO jl = 1, jpreci 1150 ptab1(jl ,:,:) = zt4we(:,jl,:,1,2) 1151 ptab1(iihom+jl,:,:) = zt4ew(:,jl,:,1,2) 1152 ptab2(jl ,:,:) = zt4we(:,jl,:,2,2) 1153 ptab2(iihom+jl,:,:) = zt4ew(:,jl,:,2,2) 1154 END DO 1155 CASE ( 1 ) 1156 DO jl = 1, jpreci 1157 ptab1(jl ,:,:) = zt4we(:,jl,:,1,2) 1158 ptab2(jl ,:,:) = zt4we(:,jl,:,2,2) 1159 END DO 1160 END SELECT 1161 1162 1163 ! 3. North and south directions 1164 ! ----------------------------- 1165 ! always closed : we play only with the neigbours 1166 ! 1167 IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions 1168 ijhom = nlcj - nrecj 1169 DO jl = 1, jprecj 1170 zt4sn(:,jl,:,1,1) = ptab1(:,ijhom +jl,:) 1171 zt4ns(:,jl,:,1,1) = ptab1(:,jprecj+jl,:) 1172 zt4sn(:,jl,:,2,1) = ptab2(:,ijhom +jl,:) 1173 zt4ns(:,jl,:,2,1) = ptab2(:,jprecj+jl,:) 1174 END DO 1175 ENDIF 1176 ! 1177 ! ! Migrations 1178 imigr = jprecj * jpi * jpk * 2 1179 ! 1180 SELECT CASE ( nbondj ) 1181 CASE ( -1 ) 1182 CALL mppsend( 4, zt4sn(1,1,1,1,1), imigr, nono, ml_req1 ) 1183 CALL mpprecv( 3, zt4ns(1,1,1,1,2), imigr, nono ) 1184 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 1185 CASE ( 0 ) 1186 CALL mppsend( 3, zt4ns(1,1,1,1,1), imigr, noso, ml_req1 ) 1187 CALL mppsend( 4, zt4sn(1,1,1,1,1), imigr, nono, ml_req2 ) 1188 CALL mpprecv( 3, zt4ns(1,1,1,1,2), imigr, nono ) 1189 CALL mpprecv( 4, zt4sn(1,1,1,1,2), imigr, noso ) 1190 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 1191 IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 1192 CASE ( 1 ) 1193 CALL mppsend( 3, zt4ns(1,1,1,1,1), imigr, noso, ml_req1 ) 1194 CALL mpprecv( 4, zt4sn(1,1,1,1,2), imigr, noso ) 1195 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 1196 END SELECT 1197 ! 1198 ! ! Write Dirichlet lateral conditions 1199 ijhom = nlcj - jprecj 1200 ! 1201 SELECT CASE ( nbondj ) 1202 CASE ( -1 ) 1203 DO jl = 1, jprecj 1204 ptab1(:,ijhom+jl,:) = zt4ns(:,jl,:,1,2) 1205 ptab2(:,ijhom+jl,:) = zt4ns(:,jl,:,2,2) 1206 END DO 1207 CASE ( 0 ) 1208 DO jl = 1, jprecj 1209 ptab1(:,jl ,:) = zt4sn(:,jl,:,1,2) 1210 ptab1(:,ijhom+jl,:) = zt4ns(:,jl,:,1,2) 1211 ptab2(:,jl ,:) = zt4sn(:,jl,:,2,2) 1212 ptab2(:,ijhom+jl,:) = zt4ns(:,jl,:,2,2) 1213 END DO 1214 CASE ( 1 ) 1215 DO jl = 1, jprecj 1216 ptab1(:,jl,:) = zt4sn(:,jl,:,1,2) 1217 ptab2(:,jl,:) = zt4sn(:,jl,:,2,2) 1218 END DO 1219 END SELECT 1220 1221 1222 ! 4. north fold treatment 1223 ! ----------------------- 1224 IF( npolj /= 0 ) THEN 1225 ! 1226 SELECT CASE ( jpni ) 1227 CASE ( 1 ) 1228 CALL lbc_nfd ( ptab1, cd_type1, psgn ) ! only for northern procs. 1229 CALL lbc_nfd ( ptab2, cd_type2, psgn ) 1230 CASE DEFAULT 1231 CALL mpp_lbc_north( ptab1, cd_type1, psgn ) ! for all northern procs. 1232 CALL mpp_lbc_north (ptab2, cd_type2, psgn) 1233 END SELECT 1234 ! 1235 ENDIF 1236 ! 1237 DEALLOCATE( zt4ns, zt4sn, zt4ew, zt4we ) 1238 ! 1239 END SUBROUTINE mpp_lnk_3d_gather 494 !! mpp_lnk_2d_e utilisé dans ICB 495 496 497 !! mpp_lnk_sum_2d et 3D ====>>>>>> à virer du code !!!! 498 499 500 !!---------------------------------------------------------------------- 1240 501 1241 502 … … 1284 545 1285 546 1286 ! 1. standard boundary treatment 547 ! 1. standard boundary treatment (CAUTION: the order matters Here !!!! ) 1287 548 ! ------------------------------ 1288 ! Order matters Here !!!! 1289 ! 1290 ! North-South cyclic 1291 IF ( nbondj == 2 .AND. jperio == 7 ) THEN !* cyclic north south 1292 pt2d(:, 1-jprj: 1 ) = pt2d ( :, jpjm1-jprj:jpjm1) 549 ! !== North-South boundaries 550 ! !* cyclic 551 IF( nbondj == 2 .AND. jperio == 7 ) THEN 552 pt2d(:, 1-jprj: 1 ) = pt2d ( :, jpjm1-jprj:jpjm1 ) 1293 553 pt2d(:, jpj :jpj+jprj) = pt2d ( :, 2 :2+jprj) 1294 ELSE 1295 1296 ! !* North-South boundaries (closed) 1297 IF( .NOT. cd_type == 'F' ) pt2d(:, 1-jprj : jprecj ) = 0.e0 ! south except at F-point 1298 pt2d(:,nlcj-jprecj+1:jpj+jprj) = 0.e0 ! north 1299 ENDIF 1300 1301 ! ! East-West boundaries 1302 ! !* Cyclic east-west 554 ELSE !* closed 555 IF( .NOT. cd_type == 'F' ) pt2d(:, 1-jprj : jprecj ) = 0._wp ! south except at F-point 556 pt2d(:,nlcj-jprecj+1:jpj+jprj) = 0._wp ! north 557 ENDIF 558 ! !== East-West boundaries 559 ! !* Cyclic east-west 1303 560 IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 1304 pt2d(1-jpri: 1 ,:) = pt2d(jpim1-jpri: jpim1 ,:) ! east 1305 pt2d( jpi :jpi+jpri,:) = pt2d( 2 :2+jpri,:) ! west 1306 ! 1307 ELSE !* closed 1308 IF( .NOT. cd_type == 'F' ) pt2d( 1-jpri :jpreci ,:) = 0.e0 ! south except at F-point 1309 pt2d(nlci-jpreci+1:jpi+jpri,:) = 0.e0 ! north 1310 ENDIF 1311 ! 1312 561 pt2d(1-jpri: 1 ,:) = pt2d(jpim1-jpri: jpim1 ,:) ! east 562 pt2d( jpi :jpi+jpri,:) = pt2d( 2 :2+jpri,:) ! west 563 ELSE !* closed 564 IF( .NOT. cd_type == 'F' ) pt2d( 1-jpri :jpreci ,:) = 0._wp ! south except at F-point 565 pt2d(nlci-jpreci+1:jpi+jpri,:) = 0._wp ! north 566 ENDIF 567 ! 1313 568 ! north fold treatment 1314 ! -------------------- ---569 ! -------------------- 1315 570 IF( npolj /= 0 ) THEN 1316 571 ! 1317 572 SELECT CASE ( jpni ) 1318 1319 CASE DEFAULT ; CALL mpp_lbc_north_e( pt2d , cd_type, psgn)573 !!gm ERROR CASE ( 1 ) ; CALL lbc_nfd ( pt2d(1:jpi,1:jpj+jprj), cd_type, psgn, pr2dj=jprj ) 574 !!gm ERROR CASE DEFAULT ; CALL mpp_lbc_north_e( pt2d , cd_type, psgn ) 1320 575 END SELECT 1321 576 ! … … 1375 630 END SELECT 1376 631 1377 1378 632 ! 3. North and south directions 1379 633 ! ----------------------------- … … 1430 684 END SUBROUTINE mpp_lnk_2d_e 1431 685 1432 SUBROUTINE mpp_lnk_sum_3d( ptab, cd_type, psgn, cd_mpp, pval )1433 !!----------------------------------------------------------------------1434 !! *** routine mpp_lnk_sum_3d ***1435 !!1436 !! ** Purpose : Message passing manadgement (sum the overlap region)1437 !!1438 !! ** Method : Use mppsend and mpprecv function for passing mask1439 !! between processors following neighboring subdomains.1440 !! domain parameters1441 !! nlci : first dimension of the local subdomain1442 !! nlcj : second dimension of the local subdomain1443 !! nbondi : mark for "east-west local boundary"1444 !! nbondj : mark for "north-south local boundary"1445 !! noea : number for local neighboring processors1446 !! nowe : number for local neighboring processors1447 !! noso : number for local neighboring processors1448 !! nono : number for local neighboring processors1449 !!1450 !! ** Action : ptab with update value at its periphery1451 !!1452 !!----------------------------------------------------------------------1453 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: ptab ! 3D array on which the boundary condition is applied1454 CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points1455 ! ! = T , U , V , F , W points1456 REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary1457 ! ! = 1. , the sign is kept1458 CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only1459 REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries)1460 !!1461 INTEGER :: ji, jj, jk, jl ! dummy loop indices1462 INTEGER :: imigr, iihom, ijhom ! temporary integers1463 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend1464 REAL(wp) :: zland1465 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend1466 !1467 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: zt3ns, zt3sn ! 3d for north-south & south-north1468 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: zt3ew, zt3we ! 3d for east-west & west-east1469 1470 !!----------------------------------------------------------------------1471 1472 ALLOCATE( zt3ns(jpi,jprecj,jpk,2), zt3sn(jpi,jprecj,jpk,2), &1473 & zt3ew(jpj,jpreci,jpk,2), zt3we(jpj,jpreci,jpk,2) )1474 1475 !1476 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value1477 ELSE ; zland = 0.e0 ! zero by default1478 ENDIF1479 1480 ! 1. standard boundary treatment1481 ! ------------------------------1482 ! 2. East and west directions exchange1483 ! ------------------------------------1484 ! we play with the neigbours AND the row number because of the periodicity1485 !1486 SELECT CASE ( nbondi ) ! Read lateral conditions1487 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case)1488 iihom = nlci-jpreci1489 DO jl = 1, jpreci1490 zt3ew(:,jl,:,1) = ptab(jl ,:,:) ; ptab(jl ,:,:) = 0.0_wp1491 zt3we(:,jl,:,1) = ptab(iihom+jl,:,:) ; ptab(iihom+jl,:,:) = 0.0_wp1492 END DO1493 END SELECT1494 !1495 ! ! Migrations1496 imigr = jpreci * jpj * jpk1497 !1498 SELECT CASE ( nbondi )1499 CASE ( -1 )1500 CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req1 )1501 CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea )1502 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)1503 CASE ( 0 )1504 CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 )1505 CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req2 )1506 CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea )1507 CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe )1508 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)1509 IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)1510 CASE ( 1 )1511 CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 )1512 CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe )1513 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)1514 END SELECT1515 !1516 ! ! Write lateral conditions1517 iihom = nlci-nreci1518 !1519 SELECT CASE ( nbondi )1520 CASE ( -1 )1521 DO jl = 1, jpreci1522 ptab(iihom+jl,:,:) = ptab(iihom+jl,:,:) + zt3ew(:,jl,:,2)1523 END DO1524 CASE ( 0 )1525 DO jl = 1, jpreci1526 ptab(jpreci+jl,:,:) = ptab(jpreci+jl,:,:) + zt3we(:,jl,:,2)1527 ptab(iihom +jl,:,:) = ptab(iihom +jl,:,:) + zt3ew(:,jl,:,2)1528 END DO1529 CASE ( 1 )1530 DO jl = 1, jpreci1531 ptab(jpreci+jl,:,:) = ptab(jpreci+jl,:,:) + zt3we(:,jl,:,2)1532 END DO1533 END SELECT1534 1535 1536 ! 3. North and south directions1537 ! -----------------------------1538 ! always closed : we play only with the neigbours1539 !1540 IF( nbondj /= 2 ) THEN ! Read lateral conditions1541 ijhom = nlcj-jprecj1542 DO jl = 1, jprecj1543 zt3sn(:,jl,:,1) = ptab(:,ijhom+jl,:) ; ptab(:,ijhom+jl,:) = 0.0_wp1544 zt3ns(:,jl,:,1) = ptab(:,jl ,:) ; ptab(:,jl ,:) = 0.0_wp1545 END DO1546 ENDIF1547 !1548 ! ! Migrations1549 imigr = jprecj * jpi * jpk1550 !1551 SELECT CASE ( nbondj )1552 CASE ( -1 )1553 CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req1 )1554 CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono )1555 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)1556 CASE ( 0 )1557 CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 )1558 CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req2 )1559 CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono )1560 CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso )1561 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)1562 IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)1563 CASE ( 1 )1564 CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 )1565 CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso )1566 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)1567 END SELECT1568 !1569 ! ! Write lateral conditions1570 ijhom = nlcj-nrecj1571 !1572 SELECT CASE ( nbondj )1573 CASE ( -1 )1574 DO jl = 1, jprecj1575 ptab(:,ijhom+jl,:) = ptab(:,ijhom+jl,:) + zt3ns(:,jl,:,2)1576 END DO1577 CASE ( 0 )1578 DO jl = 1, jprecj1579 ptab(:,jprecj+jl,:) = ptab(:,jprecj+jl,:) + zt3sn(:,jl,:,2)1580 ptab(:,ijhom +jl,:) = ptab(:,ijhom +jl,:) + zt3ns(:,jl,:,2)1581 END DO1582 CASE ( 1 )1583 DO jl = 1, jprecj1584 ptab(:,jprecj+jl,:) = ptab(:,jprecj+jl,:) + zt3sn(:,jl ,:,2)1585 END DO1586 END SELECT1587 1588 1589 ! 4. north fold treatment1590 ! -----------------------1591 !1592 IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN1593 !1594 SELECT CASE ( jpni )1595 CASE ( 1 ) ; CALL lbc_nfd ( ptab, cd_type, psgn ) ! only 1 northern proc, no mpp1596 CASE DEFAULT ; CALL mpp_lbc_north( ptab, cd_type, psgn ) ! for all northern procs.1597 END SELECT1598 !1599 ENDIF1600 !1601 DEALLOCATE( zt3ns, zt3sn, zt3ew, zt3we )1602 !1603 END SUBROUTINE mpp_lnk_sum_3d1604 1605 SUBROUTINE mpp_lnk_sum_2d( pt2d, cd_type, psgn, cd_mpp, pval )1606 !!----------------------------------------------------------------------1607 !! *** routine mpp_lnk_sum_2d ***1608 !!1609 !! ** Purpose : Message passing manadgement for 2d array (sum the overlap region)1610 !!1611 !! ** Method : Use mppsend and mpprecv function for passing mask1612 !! between processors following neighboring subdomains.1613 !! domain parameters1614 !! nlci : first dimension of the local subdomain1615 !! nlcj : second dimension of the local subdomain1616 !! nbondi : mark for "east-west local boundary"1617 !! nbondj : mark for "north-south local boundary"1618 !! noea : number for local neighboring processors1619 !! nowe : number for local neighboring processors1620 !! noso : number for local neighboring processors1621 !! nono : number for local neighboring processors1622 !!1623 !!----------------------------------------------------------------------1624 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pt2d ! 2D array on which the boundary condition is applied1625 CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points1626 ! ! = T , U , V , F , W and I points1627 REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary1628 ! ! = 1. , the sign is kept1629 CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only1630 REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries)1631 !!1632 INTEGER :: ji, jj, jl ! dummy loop indices1633 INTEGER :: imigr, iihom, ijhom ! temporary integers1634 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend1635 REAL(wp) :: zland1636 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend1637 !1638 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ns, zt2sn ! 2d for north-south & south-north1639 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ew, zt2we ! 2d for east-west & west-east1640 1641 !!----------------------------------------------------------------------1642 1643 ALLOCATE( zt2ns(jpi,jprecj,2), zt2sn(jpi,jprecj,2), &1644 & zt2ew(jpj,jpreci,2), zt2we(jpj,jpreci,2) )1645 1646 !1647 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value1648 ELSE ; zland = 0.e0 ! zero by default1649 ENDIF1650 1651 ! 1. standard boundary treatment1652 ! ------------------------------1653 ! 2. East and west directions exchange1654 ! ------------------------------------1655 ! we play with the neigbours AND the row number because of the periodicity1656 !1657 SELECT CASE ( nbondi ) ! Read lateral conditions1658 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case)1659 iihom = nlci - jpreci1660 DO jl = 1, jpreci1661 zt2ew(:,jl,1) = pt2d(jl ,:) ; pt2d(jl ,:) = 0.0_wp1662 zt2we(:,jl,1) = pt2d(iihom +jl,:) ; pt2d(iihom +jl,:) = 0.0_wp1663 END DO1664 END SELECT1665 !1666 ! ! Migrations1667 imigr = jpreci * jpj1668 !1669 SELECT CASE ( nbondi )1670 CASE ( -1 )1671 CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req1 )1672 CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea )1673 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)1674 CASE ( 0 )1675 CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 )1676 CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req2 )1677 CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea )1678 CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe )1679 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)1680 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)1681 CASE ( 1 )1682 CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 )1683 CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe )1684 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)1685 END SELECT1686 !1687 ! ! Write lateral conditions1688 iihom = nlci-nreci1689 !1690 SELECT CASE ( nbondi )1691 CASE ( -1 )1692 DO jl = 1, jpreci1693 pt2d(iihom+jl,:) = pt2d(iihom+jl,:) + zt2ew(:,jl,2)1694 END DO1695 CASE ( 0 )1696 DO jl = 1, jpreci1697 pt2d(jpreci+jl,:) = pt2d(jpreci+jl,:) + zt2we(:,jl,2)1698 pt2d(iihom +jl,:) = pt2d(iihom +jl,:) + zt2ew(:,jl,2)1699 END DO1700 CASE ( 1 )1701 DO jl = 1, jpreci1702 pt2d(jpreci+jl,:) = pt2d(jpreci+jl,:) + zt2we(:,jl,2)1703 END DO1704 END SELECT1705 1706 1707 ! 3. North and south directions1708 ! -----------------------------1709 ! always closed : we play only with the neigbours1710 !1711 IF( nbondj /= 2 ) THEN ! Read lateral conditions1712 ijhom = nlcj - jprecj1713 DO jl = 1, jprecj1714 zt2sn(:,jl,1) = pt2d(:,ijhom +jl) ; pt2d(:,ijhom +jl) = 0.0_wp1715 zt2ns(:,jl,1) = pt2d(:,jl ) ; pt2d(:,jl ) = 0.0_wp1716 END DO1717 ENDIF1718 !1719 ! ! Migrations1720 imigr = jprecj * jpi1721 !1722 SELECT CASE ( nbondj )1723 CASE ( -1 )1724 CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req1 )1725 CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono )1726 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)1727 CASE ( 0 )1728 CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 )1729 CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req2 )1730 CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono )1731 CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso )1732 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)1733 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)1734 CASE ( 1 )1735 CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 )1736 CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso )1737 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)1738 END SELECT1739 !1740 ! ! Write lateral conditions1741 ijhom = nlcj-nrecj1742 !1743 SELECT CASE ( nbondj )1744 CASE ( -1 )1745 DO jl = 1, jprecj1746 pt2d(:,ijhom+jl) = pt2d(:,ijhom+jl) + zt2ns(:,jl,2)1747 END DO1748 CASE ( 0 )1749 DO jl = 1, jprecj1750 pt2d(:,jprecj+jl) = pt2d(:,jprecj+jl) + zt2sn(:,jl,2)1751 pt2d(:,ijhom +jl) = pt2d(:,ijhom +jl) + zt2ns(:,jl,2)1752 END DO1753 CASE ( 1 )1754 DO jl = 1, jprecj1755 pt2d(:,jprecj+jl) = pt2d(:,jprecj+jl) + zt2sn(:,jl,2)1756 END DO1757 END SELECT1758 1759 1760 ! 4. north fold treatment1761 ! -----------------------1762 !1763 IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN1764 !1765 SELECT CASE ( jpni )1766 CASE ( 1 ) ; CALL lbc_nfd ( pt2d, cd_type, psgn ) ! only 1 northern proc, no mpp1767 CASE DEFAULT ; CALL mpp_lbc_north( pt2d, cd_type, psgn ) ! for all northern procs.1768 END SELECT1769 !1770 ENDIF1771 !1772 DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we )1773 !1774 END SUBROUTINE mpp_lnk_sum_2d1775 686 1776 687 SUBROUTINE mppsend( ktyp, pmess, kbytes, kdest, md_req ) … … 1874 785 END SUBROUTINE mppscatter 1875 786 1876 787 !!---------------------------------------------------------------------- 788 !! *** mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real *** 789 !! 790 !!---------------------------------------------------------------------- 791 !! 1877 792 SUBROUTINE mppmax_a_int( ktab, kdim, kcom ) 1878 !!----------------------------------------------------------------------1879 !! *** routine mppmax_a_int ***1880 !!1881 !! ** Purpose : Find maximum value in an integer layout array1882 !!1883 793 !!---------------------------------------------------------------------- 1884 794 INTEGER , INTENT(in ) :: kdim ! size of array 1885 795 INTEGER , INTENT(inout), DIMENSION(kdim) :: ktab ! input array 1886 796 INTEGER , INTENT(in ), OPTIONAL :: kcom ! 1887 ! 1888 INTEGER :: ierror, localcomm ! temporary integer 797 INTEGER :: ierror, ilocalcomm ! temporary integer 1889 798 INTEGER, DIMENSION(kdim) :: iwork 1890 799 !!---------------------------------------------------------------------- 1891 ! 1892 localcomm = mpi_comm_opa 1893 IF( PRESENT(kcom) ) localcomm = kcom 1894 ! 1895 CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_max, localcomm, ierror ) 1896 ! 800 ilocalcomm = mpi_comm_opa 801 IF( PRESENT(kcom) ) ilocalcomm = kcom 802 CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_max, ilocalcomm, ierror ) 1897 803 ktab(:) = iwork(:) 1898 !1899 804 END SUBROUTINE mppmax_a_int 1900 1901 805 !! 1902 806 SUBROUTINE mppmax_int( ktab, kcom ) 1903 !!----------------------------------------------------------------------1904 !! *** routine mppmax_int ***1905 !!1906 !! ** Purpose : Find maximum value in an integer layout array1907 !!1908 807 !!---------------------------------------------------------------------- 1909 808 INTEGER, INTENT(inout) :: ktab ! ??? 1910 809 INTEGER, INTENT(in ), OPTIONAL :: kcom ! ??? 1911 ! 1912 INTEGER :: ierror, iwork, localcomm ! temporary integer 1913 !!---------------------------------------------------------------------- 1914 ! 1915 localcomm = mpi_comm_opa 1916 IF( PRESENT(kcom) ) localcomm = kcom 1917 ! 1918 CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_max, localcomm, ierror ) 1919 ! 810 INTEGER :: ierror, iwork, ilocalcomm ! temporary integer 811 !!---------------------------------------------------------------------- 812 ilocalcomm = mpi_comm_opa 813 IF( PRESENT(kcom) ) ilocalcomm = kcom 814 CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_max, ilocalcomm, ierror ) 1920 815 ktab = iwork 1921 !1922 816 END SUBROUTINE mppmax_int 1923 1924 817 !! 818 SUBROUTINE mppmax_a_real( ptab, kdim, kcom ) 819 !!---------------------------------------------------------------------- 820 REAL(wp), DIMENSION(kdim), INTENT(inout) :: ptab 821 INTEGER , INTENT(in ) :: kdim 822 INTEGER , OPTIONAL , INTENT(in ) :: kcom 823 INTEGER :: ierror, ilocalcomm 824 REAL(wp), DIMENSION(kdim) :: zwork 825 !!---------------------------------------------------------------------- 826 ilocalcomm = mpi_comm_opa 827 IF( PRESENT(kcom) ) ilocalcomm = kcom 828 CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_max, ilocalcomm, ierror ) 829 ptab(:) = zwork(:) 830 END SUBROUTINE mppmax_a_real 831 !! 832 SUBROUTINE mppmax_real( ptab, kcom ) 833 !!---------------------------------------------------------------------- 834 REAL(wp), INTENT(inout) :: ptab ! ??? 835 INTEGER , INTENT(in ), OPTIONAL :: kcom ! ??? 836 INTEGER :: ierror, ilocalcomm 837 REAL(wp) :: zwork 838 !!---------------------------------------------------------------------- 839 ilocalcomm = mpi_comm_opa 840 IF( PRESENT(kcom) ) ilocalcomm = kcom! 841 CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_max, ilocalcomm, ierror ) 842 ptab = zwork 843 END SUBROUTINE mppmax_real 844 845 846 !!---------------------------------------------------------------------- 847 !! *** mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real *** 848 !! 849 !!---------------------------------------------------------------------- 850 !! 1925 851 SUBROUTINE mppmin_a_int( ktab, kdim, kcom ) 1926 !!----------------------------------------------------------------------1927 !! *** routine mppmin_a_int ***1928 !!1929 !! ** Purpose : Find minimum value in an integer layout array1930 !!1931 852 !!---------------------------------------------------------------------- 1932 853 INTEGER , INTENT( in ) :: kdim ! size of array … … 1934 855 INTEGER , INTENT( in ), OPTIONAL :: kcom ! input array 1935 856 !! 1936 INTEGER :: ierror, localcomm ! temporary integer857 INTEGER :: ierror, ilocalcomm ! temporary integer 1937 858 INTEGER, DIMENSION(kdim) :: iwork 1938 859 !!---------------------------------------------------------------------- 1939 ! 1940 localcomm = mpi_comm_opa 1941 IF( PRESENT(kcom) ) localcomm = kcom 1942 ! 1943 CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_min, localcomm, ierror ) 1944 ! 860 ilocalcomm = mpi_comm_opa 861 IF( PRESENT(kcom) ) ilocalcomm = kcom 862 CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_min, ilocalcomm, ierror ) 1945 863 ktab(:) = iwork(:) 1946 !1947 864 END SUBROUTINE mppmin_a_int 1948 1949 865 !! 1950 866 SUBROUTINE mppmin_int( ktab, kcom ) 1951 !!----------------------------------------------------------------------1952 !! *** routine mppmin_int ***1953 !!1954 !! ** Purpose : Find minimum value in an integer layout array1955 !!1956 867 !!---------------------------------------------------------------------- 1957 868 INTEGER, INTENT(inout) :: ktab ! ??? 1958 869 INTEGER , INTENT( in ), OPTIONAL :: kcom ! input array 1959 870 !! 1960 INTEGER :: ierror, iwork, localcomm 1961 !!---------------------------------------------------------------------- 1962 ! 1963 localcomm = mpi_comm_opa 1964 IF( PRESENT(kcom) ) localcomm = kcom 1965 ! 1966 CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_min, localcomm, ierror ) 1967 ! 871 INTEGER :: ierror, iwork, ilocalcomm 872 !!---------------------------------------------------------------------- 873 ilocalcomm = mpi_comm_opa 874 IF( PRESENT(kcom) ) ilocalcomm = kcom 875 CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_min, ilocalcomm, ierror ) 1968 876 ktab = iwork 1969 !1970 877 END SUBROUTINE mppmin_int 1971 1972 1973 SUBROUTINE mppsum_a_int( ktab, kdim ) 1974 !!---------------------------------------------------------------------- 1975 !! *** routine mppsum_a_int *** 1976 !! 1977 !! ** Purpose : Global integer sum, 1D array case 1978 !! 1979 !!---------------------------------------------------------------------- 1980 INTEGER, INTENT(in ) :: kdim ! ??? 1981 INTEGER, INTENT(inout), DIMENSION (kdim) :: ktab ! ??? 1982 ! 1983 INTEGER :: ierror 1984 INTEGER, DIMENSION (kdim) :: iwork 1985 !!---------------------------------------------------------------------- 1986 ! 1987 CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_sum, mpi_comm_opa, ierror ) 1988 ! 1989 ktab(:) = iwork(:) 1990 ! 1991 END SUBROUTINE mppsum_a_int 1992 1993 1994 SUBROUTINE mppsum_int( ktab ) 1995 !!---------------------------------------------------------------------- 1996 !! *** routine mppsum_int *** 1997 !! 1998 !! ** Purpose : Global integer sum 1999 !! 2000 !!---------------------------------------------------------------------- 2001 INTEGER, INTENT(inout) :: ktab 2002 !! 2003 INTEGER :: ierror, iwork 2004 !!---------------------------------------------------------------------- 2005 ! 2006 CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_sum, mpi_comm_opa, ierror ) 2007 ! 2008 ktab = iwork 2009 ! 2010 END SUBROUTINE mppsum_int 2011 2012 2013 SUBROUTINE mppmax_a_real( ptab, kdim, kcom ) 2014 !!---------------------------------------------------------------------- 2015 !! *** routine mppmax_a_real *** 2016 !! 2017 !! ** Purpose : Maximum 2018 !! 878 !! 879 SUBROUTINE mppmin_a_real( ptab, kdim, kcom ) 2019 880 !!---------------------------------------------------------------------- 2020 881 INTEGER , INTENT(in ) :: kdim 2021 882 REAL(wp), INTENT(inout), DIMENSION(kdim) :: ptab 2022 883 INTEGER , INTENT(in ), OPTIONAL :: kcom 2023 ! 2024 INTEGER :: ierror, localcomm 2025 REAL(wp), DIMENSION(kdim) :: zwork 2026 !!---------------------------------------------------------------------- 2027 ! 2028 localcomm = mpi_comm_opa 2029 IF( PRESENT(kcom) ) localcomm = kcom 2030 ! 2031 CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_max, localcomm, ierror ) 2032 ptab(:) = zwork(:) 2033 ! 2034 END SUBROUTINE mppmax_a_real 2035 2036 2037 SUBROUTINE mppmax_real( ptab, kcom ) 2038 !!---------------------------------------------------------------------- 2039 !! *** routine mppmax_real *** 2040 !! 2041 !! ** Purpose : Maximum 2042 !! 2043 !!---------------------------------------------------------------------- 2044 REAL(wp), INTENT(inout) :: ptab ! ??? 2045 INTEGER , INTENT(in ), OPTIONAL :: kcom ! ??? 2046 !! 2047 INTEGER :: ierror, localcomm 2048 REAL(wp) :: zwork 2049 !!---------------------------------------------------------------------- 2050 ! 2051 localcomm = mpi_comm_opa 2052 IF( PRESENT(kcom) ) localcomm = kcom 2053 ! 2054 CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_max, localcomm, ierror ) 2055 ptab = zwork 2056 ! 2057 END SUBROUTINE mppmax_real 2058 2059 SUBROUTINE mppmax_real_multiple( ptab, NUM , kcom ) 2060 !!---------------------------------------------------------------------- 2061 !! *** routine mppmax_real *** 2062 !! 2063 !! ** Purpose : Maximum 2064 !! 2065 !!---------------------------------------------------------------------- 2066 REAL(wp), DIMENSION(:) , INTENT(inout) :: ptab ! ??? 2067 INTEGER , INTENT(in ) :: NUM 2068 INTEGER , INTENT(in ), OPTIONAL :: kcom ! ??? 2069 !! 2070 INTEGER :: ierror, localcomm 2071 REAL(wp) , POINTER , DIMENSION(:) :: zwork 2072 !!---------------------------------------------------------------------- 2073 ! 2074 CALL wrk_alloc(NUM , zwork) 2075 localcomm = mpi_comm_opa 2076 IF( PRESENT(kcom) ) localcomm = kcom 2077 ! 2078 CALL mpi_allreduce( ptab, zwork, NUM, mpi_double_precision, mpi_max, localcomm, ierror ) 2079 ptab = zwork 2080 CALL wrk_dealloc(NUM , zwork) 2081 ! 2082 END SUBROUTINE mppmax_real_multiple 2083 2084 2085 SUBROUTINE mppmin_a_real( ptab, kdim, kcom ) 2086 !!---------------------------------------------------------------------- 2087 !! *** routine mppmin_a_real *** 2088 !! 2089 !! ** Purpose : Minimum of REAL, array case 2090 !! 2091 !!----------------------------------------------------------------------- 2092 INTEGER , INTENT(in ) :: kdim 2093 REAL(wp), INTENT(inout), DIMENSION(kdim) :: ptab 2094 INTEGER , INTENT(in ), OPTIONAL :: kcom 2095 !! 2096 INTEGER :: ierror, localcomm 884 INTEGER :: ierror, ilocalcomm 2097 885 REAL(wp), DIMENSION(kdim) :: zwork 2098 886 !!----------------------------------------------------------------------- 2099 ! 2100 localcomm = mpi_comm_opa 2101 IF( PRESENT(kcom) ) localcomm = kcom 2102 ! 2103 CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_min, localcomm, ierror ) 887 ilocalcomm = mpi_comm_opa 888 IF( PRESENT(kcom) ) ilocalcomm = kcom 889 CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_min, ilocalcomm, ierror ) 2104 890 ptab(:) = zwork(:) 2105 !2106 891 END SUBROUTINE mppmin_a_real 2107 2108 892 !! 2109 893 SUBROUTINE mppmin_real( ptab, kcom ) 2110 !!----------------------------------------------------------------------2111 !! *** routine mppmin_real ***2112 !!2113 !! ** Purpose : minimum of REAL, scalar case2114 !!2115 894 !!----------------------------------------------------------------------- 2116 895 REAL(wp), INTENT(inout) :: ptab ! 2117 896 INTEGER , INTENT(in ), OPTIONAL :: kcom 2118 !! 2119 INTEGER :: ierror 2120 REAL(wp) :: zwork 2121 INTEGER :: localcomm 2122 !!----------------------------------------------------------------------- 2123 ! 2124 localcomm = mpi_comm_opa 2125 IF( PRESENT(kcom) ) localcomm = kcom 2126 ! 2127 CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_min, localcomm, ierror ) 2128 ptab = zwork 2129 ! 2130 END SUBROUTINE mppmin_real 2131 2132 2133 SUBROUTINE mppsum_a_real( ptab, kdim, kcom ) 2134 !!---------------------------------------------------------------------- 2135 !! *** routine mppsum_a_real *** 2136 !! 2137 !! ** Purpose : global sum, REAL ARRAY argument case 2138 !! 2139 !!----------------------------------------------------------------------- 2140 INTEGER , INTENT( in ) :: kdim ! size of ptab 2141 REAL(wp), DIMENSION(kdim), INTENT( inout ) :: ptab ! input array 2142 INTEGER , INTENT( in ), OPTIONAL :: kcom 2143 !! 2144 INTEGER :: ierror ! temporary integer 2145 INTEGER :: localcomm 2146 REAL(wp), DIMENSION(kdim) :: zwork ! temporary workspace 2147 !!----------------------------------------------------------------------- 2148 ! 2149 localcomm = mpi_comm_opa 2150 IF( PRESENT(kcom) ) localcomm = kcom 2151 ! 2152 CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_sum, localcomm, ierror ) 2153 ptab(:) = zwork(:) 2154 ! 2155 END SUBROUTINE mppsum_a_real 2156 2157 2158 SUBROUTINE mppsum_real( ptab, kcom ) 2159 !!---------------------------------------------------------------------- 2160 !! *** routine mppsum_real *** 2161 !! 2162 !! ** Purpose : global sum, SCALAR argument case 2163 !! 2164 !!----------------------------------------------------------------------- 2165 REAL(wp), INTENT(inout) :: ptab ! input scalar 2166 INTEGER , INTENT(in ), OPTIONAL :: kcom 2167 !! 2168 INTEGER :: ierror, localcomm 897 INTEGER :: ierror, ilocalcomm 2169 898 REAL(wp) :: zwork 2170 899 !!----------------------------------------------------------------------- 2171 ! 2172 localcomm = mpi_comm_opa 2173 IF( PRESENT(kcom) ) localcomm = kcom 2174 ! 2175 CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_sum, localcomm, ierror ) 900 ilocalcomm = mpi_comm_opa 901 IF( PRESENT(kcom) ) ilocalcomm = kcom 902 CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_min, ilocalcomm, ierror ) 2176 903 ptab = zwork 2177 ! 904 END SUBROUTINE mppmin_real 905 906 907 !!---------------------------------------------------------------------- 908 !! *** mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real *** 909 !! 910 !! Global sum of 1D array or a variable (integer, real or complex) 911 !!---------------------------------------------------------------------- 912 !! 913 SUBROUTINE mppsum_a_int( ktab, kdim ) 914 !!---------------------------------------------------------------------- 915 INTEGER, INTENT(in ) :: kdim ! ??? 916 INTEGER, INTENT(inout), DIMENSION (kdim) :: ktab ! ??? 917 INTEGER :: ierror 918 INTEGER, DIMENSION (kdim) :: iwork 919 !!---------------------------------------------------------------------- 920 CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_sum, mpi_comm_opa, ierror ) 921 ktab(:) = iwork(:) 922 END SUBROUTINE mppsum_a_int 923 !! 924 SUBROUTINE mppsum_int( ktab ) 925 !!---------------------------------------------------------------------- 926 INTEGER, INTENT(inout) :: ktab 927 INTEGER :: ierror, iwork 928 !!---------------------------------------------------------------------- 929 CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_sum, mpi_comm_opa, ierror ) 930 ktab = iwork 931 END SUBROUTINE mppsum_int 932 !! 933 SUBROUTINE mppsum_a_real( ptab, kdim, kcom ) 934 !!----------------------------------------------------------------------- 935 INTEGER , INTENT(in ) :: kdim ! size of ptab 936 REAL(wp), DIMENSION(kdim), INTENT(inout) :: ptab ! input array 937 INTEGER , OPTIONAL , INTENT(in ) :: kcom ! specific communicator 938 INTEGER :: ierror, ilocalcomm ! local integer 939 REAL(wp) :: zwork(kdim) ! local workspace 940 !!----------------------------------------------------------------------- 941 ilocalcomm = mpi_comm_opa 942 IF( PRESENT(kcom) ) ilocalcomm = kcom 943 CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_sum, ilocalcomm, ierror ) 944 ptab(:) = zwork(:) 945 END SUBROUTINE mppsum_a_real 946 !! 947 SUBROUTINE mppsum_real( ptab, kcom ) 948 !!----------------------------------------------------------------------- 949 REAL(wp) , INTENT(inout) :: ptab ! input scalar 950 INTEGER , OPTIONAL, INTENT(in ) :: kcom 951 INTEGER :: ierror, ilocalcomm 952 REAL(wp) :: zwork 953 !!----------------------------------------------------------------------- 954 ilocalcomm = mpi_comm_opa 955 IF( PRESENT(kcom) ) ilocalcomm = kcom 956 CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_sum, ilocalcomm, ierror ) 957 ptab = zwork 2178 958 END SUBROUTINE mppsum_real 2179 2180 959 !! 2181 960 SUBROUTINE mppsum_realdd( ytab, kcom ) 2182 !!----------------------------------------------------------------------2183 !! *** routine mppsum_realdd ***2184 !!2185 !! ** Purpose : global sum in Massively Parallel Processing2186 !! SCALAR argument case for double-double precision2187 !!2188 961 !!----------------------------------------------------------------------- 2189 COMPLEX(wp), INTENT(inout) :: ytab ! input scalar 2190 INTEGER , INTENT(in ), OPTIONAL :: kcom 2191 ! 2192 INTEGER :: ierror 2193 INTEGER :: localcomm 962 COMPLEX(wp) , INTENT(inout) :: ytab ! input scalar 963 INTEGER , OPTIONAL, INTENT(in ) :: kcom 964 INTEGER :: ierror, ilocalcomm 2194 965 COMPLEX(wp) :: zwork 2195 966 !!----------------------------------------------------------------------- 2196 ! 2197 localcomm = mpi_comm_opa 2198 IF( PRESENT(kcom) ) localcomm = kcom 2199 ! 2200 ! reduce local sums into global sum 2201 CALL MPI_ALLREDUCE (ytab, zwork, 1, MPI_DOUBLE_COMPLEX, MPI_SUMDD, localcomm, ierror ) 967 ilocalcomm = mpi_comm_opa 968 IF( PRESENT(kcom) ) ilocalcomm = kcom 969 CALL MPI_ALLREDUCE( ytab, zwork, 1, MPI_DOUBLE_COMPLEX, MPI_SUMDD, ilocalcomm, ierror ) 2202 970 ytab = zwork 2203 !2204 971 END SUBROUTINE mppsum_realdd 2205 2206 972 !! 2207 973 SUBROUTINE mppsum_a_realdd( ytab, kdim, kcom ) 2208 974 !!---------------------------------------------------------------------- 2209 !! *** routine mppsum_a_realdd ***2210 !!2211 !! ** Purpose : global sum in Massively Parallel Processing2212 !! COMPLEX ARRAY case for double-double precision2213 !!2214 !!-----------------------------------------------------------------------2215 975 INTEGER , INTENT(in ) :: kdim ! size of ytab 2216 976 COMPLEX(wp), DIMENSION(kdim), INTENT(inout) :: ytab ! input array 2217 977 INTEGER , OPTIONAL , INTENT(in ) :: kcom 2218 ! 2219 INTEGER:: ierror, localcomm ! local integer 978 INTEGER:: ierror, ilocalcomm ! local integer 2220 979 COMPLEX(wp), DIMENSION(kdim) :: zwork ! temporary workspace 2221 980 !!----------------------------------------------------------------------- 2222 ! 2223 localcomm = mpi_comm_opa 2224 IF( PRESENT(kcom) ) localcomm = kcom 2225 ! 2226 CALL MPI_ALLREDUCE( ytab, zwork, kdim, MPI_DOUBLE_COMPLEX, MPI_SUMDD, localcomm, ierror ) 981 ilocalcomm = mpi_comm_opa 982 IF( PRESENT(kcom) ) ilocalcomm = kcom 983 CALL MPI_ALLREDUCE( ytab, zwork, kdim, MPI_DOUBLE_COMPLEX, MPI_SUMDD, ilocalcomm, ierror ) 2227 984 ytab(:) = zwork(:) 2228 !2229 985 END SUBROUTINE mppsum_a_realdd 986 987 988 SUBROUTINE mppmax_real_multiple( pt1d, kdim, kcom ) 989 !!---------------------------------------------------------------------- 990 !! *** routine mppmax_real *** 991 !! 992 !! ** Purpose : Maximum across processor of each element of a 1D arrays 993 !! 994 !!---------------------------------------------------------------------- 995 REAL(wp), DIMENSION(kdim), INTENT(inout) :: pt1d ! 1D arrays 996 INTEGER , INTENT(in ) :: kdim 997 INTEGER , OPTIONAL , INTENT(in ) :: kcom ! local communicator 998 !! 999 INTEGER :: ierror, ilocalcomm 1000 REAL(wp), DIMENSION(kdim) :: zwork 1001 !!---------------------------------------------------------------------- 1002 ilocalcomm = mpi_comm_opa 1003 IF( PRESENT(kcom) ) ilocalcomm = kcom 1004 ! 1005 CALL mpi_allreduce( pt1d, zwork, kdim, mpi_double_precision, mpi_max, ilocalcomm, ierror ) 1006 pt1d(:) = zwork(:) 1007 ! 1008 END SUBROUTINE mppmax_real_multiple 2230 1009 2231 1010 … … 2243 1022 REAL(wp), DIMENSION (jpi,jpj), INTENT(in ) :: pmask ! Local mask 2244 1023 REAL(wp) , INTENT( out) :: pmin ! Global minimum of ptab 2245 INTEGER , INTENT( out) :: ki, kj 1024 INTEGER , INTENT( out) :: ki, kj ! index of minimum in global frame 2246 1025 ! 2247 1026 INTEGER :: ierror … … 2251 1030 !!----------------------------------------------------------------------- 2252 1031 ! 2253 zmin = MINVAL( ptab(:,:) , mask= pmask == 1. e0)2254 ilocs = MINLOC( ptab(:,:) , mask= pmask == 1. e0)1032 zmin = MINVAL( ptab(:,:) , mask= pmask == 1._wp ) 1033 ilocs = MINLOC( ptab(:,:) , mask= pmask == 1._wp ) 2255 1034 ! 2256 1035 ki = ilocs(1) + nimpp - 1 … … 2279 1058 !! 2280 1059 !!-------------------------------------------------------------------------- 2281 REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in ) :: ptab ! Local 2D array2282 REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in ) :: pmask ! Local mask2283 REAL(wp) 2284 INTEGER 2285 ! !1060 REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: ptab ! Local 2D array 1061 REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pmask ! Local mask 1062 REAL(wp) , INTENT( out) :: pmin ! Global minimum of ptab 1063 INTEGER , INTENT( out) :: ki, kj, kk ! index of minimum in global frame 1064 ! 2286 1065 INTEGER :: ierror 2287 1066 REAL(wp) :: zmin ! local minimum … … 2290 1069 !!----------------------------------------------------------------------- 2291 1070 ! 2292 zmin = MINVAL( ptab(:,:,:) , mask= pmask == 1. e0)2293 ilocs = MINLOC( ptab(:,:,:) , mask= pmask == 1. e0)1071 zmin = MINVAL( ptab(:,:,:) , mask= pmask == 1._wp ) 1072 ilocs = MINLOC( ptab(:,:,:) , mask= pmask == 1._wp ) 2294 1073 ! 2295 1074 ki = ilocs(1) + nimpp - 1 … … 2297 1076 kk = ilocs(3) 2298 1077 ! 2299 zain(1,:) =zmin2300 zain(2,:) =ki+10000.*kj+100000000.*kk1078 zain(1,:) = zmin 1079 zain(2,:) = ki + 10000.*kj + 100000000.*kk 2301 1080 ! 2302 1081 CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MINLOC,MPI_COMM_OPA,ierror) … … 2331 1110 !!----------------------------------------------------------------------- 2332 1111 ! 2333 zmax = MAXVAL( ptab(:,:) , mask= pmask == 1. e0)2334 ilocs = MAXLOC( ptab(:,:) , mask= pmask == 1. e0)1112 zmax = MAXVAL( ptab(:,:) , mask= pmask == 1._wp ) 1113 ilocs = MAXLOC( ptab(:,:) , mask= pmask == 1._wp ) 2335 1114 ! 2336 1115 ki = ilocs(1) + nimpp - 1 … … 2359 1138 !! 2360 1139 !!-------------------------------------------------------------------------- 2361 REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in ) :: ptab ! Local 2D array 2362 REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in ) :: pmask ! Local mask 2363 REAL(wp) , INTENT( out) :: pmax ! Global maximum of ptab 2364 INTEGER , INTENT( out) :: ki, kj, kk ! index of maximum in global frame 2365 !! 2366 REAL(wp) :: zmax ! local maximum 1140 REAL(wp), DIMENSION (:,:,:), INTENT(in ) :: ptab ! Local 2D array 1141 REAL(wp), DIMENSION (:,:,:), INTENT(in ) :: pmask ! Local mask 1142 REAL(wp) , INTENT( out) :: pmax ! Global maximum of ptab 1143 INTEGER , INTENT( out) :: ki, kj, kk ! index of maximum in global frame 1144 ! 1145 INTEGER :: ierror ! local integer 1146 REAL(wp) :: zmax ! local maximum 2367 1147 REAL(wp), DIMENSION(2,1) :: zain, zaout 2368 1148 INTEGER , DIMENSION(3) :: ilocs 2369 INTEGER :: ierror2370 1149 !!----------------------------------------------------------------------- 2371 1150 ! 2372 zmax = MAXVAL( ptab(:,:,:) , mask= pmask == 1. e0)2373 ilocs = MAXLOC( ptab(:,:,:) , mask= pmask == 1. e0)1151 zmax = MAXVAL( ptab(:,:,:) , mask= pmask == 1._wp ) 1152 ilocs = MAXLOC( ptab(:,:,:) , mask= pmask == 1._wp ) 2374 1153 ! 2375 1154 ki = ilocs(1) + nimpp - 1 … … 2377 1156 kk = ilocs(3) 2378 1157 ! 2379 zain(1,:) =zmax2380 zain(2,:) =ki+10000.*kj+100000000.*kk1158 zain(1,:) = zmax 1159 zain(2,:) = ki + 10000.*kj + 100000000.*kk 2381 1160 ! 2382 1161 CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MAXLOC,MPI_COMM_OPA,ierror) … … 2438 1217 2439 1218 SUBROUTINE mpp_comm_free( kcom ) 2440 !!----------------------------------------------------------------------2441 1219 !!---------------------------------------------------------------------- 2442 1220 INTEGER, INTENT(in) :: kcom … … 2696 1474 2697 1475 2698 SUBROUTINE mpp_lbc_north_3d( pt3d, cd_type, psgn )2699 !!---------------------------------------------------------------------2700 !! *** routine mpp_lbc_north_3d ***2701 !!2702 !! ** Purpose : Ensure proper north fold horizontal bondary condition2703 !! in mpp configuration in case of jpn1 > 12704 !!2705 !! ** Method : North fold condition and mpp with more than one proc2706 !! in i-direction require a specific treatment. We gather2707 !! the 4 northern lines of the global domain on 1 processor2708 !! and apply lbc north-fold on this sub array. Then we2709 !! scatter the north fold array back to the processors.2710 !!2711 !!----------------------------------------------------------------------2712 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pt3d ! 3D array on which the b.c. is applied2713 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points2714 ! ! = T , U , V , F or W gridpoints2715 REAL(wp) , INTENT(in ) :: psgn ! = -1. the sign change across the north fold2716 !! ! = 1. , the sign is kept2717 INTEGER :: ji, jj, jr, jk2718 INTEGER :: ierr, itaille, ildi, ilei, iilb2719 INTEGER :: ijpj, ijpjm1, ij, iproc2720 INTEGER, DIMENSION (jpmaxngh) :: ml_req_nf !for mpi_isend when avoiding mpi_allgather2721 INTEGER :: ml_err ! for mpi_isend when avoiding mpi_allgather2722 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for mpi_isend when avoiding mpi_allgather2723 ! ! Workspace for message transfers avoiding mpi_allgather2724 REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: ztab2725 REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: znorthloc, zfoldwk2726 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: znorthgloio2727 REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: ztabl, ztabr2728 2729 INTEGER :: istatus(mpi_status_size)2730 INTEGER :: iflag2731 !!----------------------------------------------------------------------2732 !2733 ALLOCATE( ztab(jpiglo,4,jpk) , znorthloc(jpi,4,jpk), zfoldwk(jpi,4,jpk), znorthgloio(jpi,4,jpk,jpni) )2734 ALLOCATE( ztabl(jpi,4,jpk), ztabr(jpi*jpmaxngh, 4, jpk) )2735 2736 ijpj = 42737 ijpjm1 = 32738 !2739 znorthloc(:,:,:) = 02740 DO jk = 1, jpk2741 DO jj = nlcj - ijpj +1, nlcj ! put in xnorthloc the last 4 jlines of pt3d2742 ij = jj - nlcj + ijpj2743 znorthloc(:,ij,jk) = pt3d(:,jj,jk)2744 END DO2745 END DO2746 !2747 ! ! Build in procs of ncomm_north the znorthgloio2748 itaille = jpi * jpk * ijpj2749 2750 IF ( l_north_nogather ) THEN2751 !2752 ztabr(:,:,:) = 02753 ztabl(:,:,:) = 02754 2755 DO jk = 1, jpk2756 DO jj = nlcj-ijpj+1, nlcj ! First put local values into the global array2757 ij = jj - nlcj + ijpj2758 DO ji = nfsloop, nfeloop2759 ztabl(ji,ij,jk) = pt3d(ji,jj,jk)2760 END DO2761 END DO2762 END DO2763 2764 DO jr = 1,nsndto2765 IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN2766 CALL mppsend( 5, znorthloc, itaille, nfipproc(isendto(jr),jpnj), ml_req_nf(jr) )2767 ENDIF2768 END DO2769 DO jr = 1,nsndto2770 iproc = nfipproc(isendto(jr),jpnj)2771 IF(iproc .ne. -1) THEN2772 ilei = nleit (iproc+1)2773 ildi = nldit (iproc+1)2774 iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj)2775 ENDIF2776 IF((iproc .ne. (narea-1)) .and. (iproc .ne. -1)) THEN2777 CALL mpprecv(5, zfoldwk, itaille, iproc)2778 DO jk = 1, jpk2779 DO jj = 1, ijpj2780 DO ji = ildi, ilei2781 ztabr(iilb+ji,jj,jk) = zfoldwk(ji,jj,jk)2782 END DO2783 END DO2784 END DO2785 ELSE IF (iproc .eq. (narea-1)) THEN2786 DO jk = 1, jpk2787 DO jj = 1, ijpj2788 DO ji = ildi, ilei2789 ztabr(iilb+ji,jj,jk) = pt3d(ji,nlcj-ijpj+jj,jk)2790 END DO2791 END DO2792 END DO2793 ENDIF2794 END DO2795 IF (l_isend) THEN2796 DO jr = 1,nsndto2797 IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN2798 CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err)2799 ENDIF2800 END DO2801 ENDIF2802 CALL mpp_lbc_nfd( ztabl, ztabr, cd_type, psgn ) ! North fold boundary condition2803 DO jk = 1, jpk2804 DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt3d2805 ij = jj - nlcj + ijpj2806 DO ji= 1, nlci2807 pt3d(ji,jj,jk) = ztabl(ji,ij,jk)2808 END DO2809 END DO2810 END DO2811 !2812 2813 ELSE2814 CALL MPI_ALLGATHER( znorthloc , itaille, MPI_DOUBLE_PRECISION, &2815 & znorthgloio, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr )2816 !2817 ztab(:,:,:) = 0.e02818 DO jr = 1, ndim_rank_north ! recover the global north array2819 iproc = nrank_north(jr) + 12820 ildi = nldit (iproc)2821 ilei = nleit (iproc)2822 iilb = nimppt(iproc)2823 DO jk = 1, jpk2824 DO jj = 1, ijpj2825 DO ji = ildi, ilei2826 ztab(ji+iilb-1,jj,jk) = znorthgloio(ji,jj,jk,jr)2827 END DO2828 END DO2829 END DO2830 END DO2831 CALL lbc_nfd( ztab, cd_type, psgn ) ! North fold boundary condition2832 !2833 DO jk = 1, jpk2834 DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt3d2835 ij = jj - nlcj + ijpj2836 DO ji= 1, nlci2837 pt3d(ji,jj,jk) = ztab(ji+nimpp-1,ij,jk)2838 END DO2839 END DO2840 END DO2841 !2842 ENDIF2843 !2844 ! The ztab array has been either:2845 ! a. Fully populated by the mpi_allgather operation or2846 ! b. Had the active points for this domain and northern neighbours populated2847 ! by peer to peer exchanges2848 ! Either way the array may be folded by lbc_nfd and the result for the span of2849 ! this domain will be identical.2850 !2851 DEALLOCATE( ztab, znorthloc, zfoldwk, znorthgloio )2852 DEALLOCATE( ztabl, ztabr )2853 !2854 END SUBROUTINE mpp_lbc_north_3d2855 2856 2857 SUBROUTINE mpp_lbc_north_2d( pt2d, cd_type, psgn)2858 !!---------------------------------------------------------------------2859 !! *** routine mpp_lbc_north_2d ***2860 !!2861 !! ** Purpose : Ensure proper north fold horizontal bondary condition2862 !! in mpp configuration in case of jpn1 > 1 (for 2d array )2863 !!2864 !! ** Method : North fold condition and mpp with more than one proc2865 !! in i-direction require a specific treatment. We gather2866 !! the 4 northern lines of the global domain on 1 processor2867 !! and apply lbc north-fold on this sub array. Then we2868 !! scatter the north fold array back to the processors.2869 !!2870 !!----------------------------------------------------------------------2871 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pt2d ! 2D array on which the b.c. is applied2872 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt2d grid-points2873 ! ! = T , U , V , F or W gridpoints2874 REAL(wp) , INTENT(in ) :: psgn ! = -1. the sign change across the north fold2875 !! ! = 1. , the sign is kept2876 INTEGER :: ji, jj, jr2877 INTEGER :: ierr, itaille, ildi, ilei, iilb2878 INTEGER :: ijpj, ijpjm1, ij, iproc2879 INTEGER, DIMENSION (jpmaxngh) :: ml_req_nf !for mpi_isend when avoiding mpi_allgather2880 INTEGER :: ml_err ! for mpi_isend when avoiding mpi_allgather2881 INTEGER, DIMENSION(MPI_STATUS_SIZE):: ml_stat ! for mpi_isend when avoiding mpi_allgather2882 ! ! Workspace for message transfers avoiding mpi_allgather2883 REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: ztab2884 REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: znorthloc, zfoldwk2885 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: znorthgloio2886 REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: ztabl, ztabr2887 INTEGER :: istatus(mpi_status_size)2888 INTEGER :: iflag2889 !!----------------------------------------------------------------------2890 !2891 ALLOCATE( ztab(jpiglo,4), znorthloc(jpi,4), zfoldwk(jpi,4), znorthgloio(jpi,4,jpni) )2892 ALLOCATE( ztabl(jpi,4), ztabr(jpi*jpmaxngh, 4) )2893 !2894 ijpj = 42895 ijpjm1 = 32896 !2897 DO jj = nlcj-ijpj+1, nlcj ! put in znorthloc the last 4 jlines of pt2d2898 ij = jj - nlcj + ijpj2899 znorthloc(:,ij) = pt2d(:,jj)2900 END DO2901 2902 ! ! Build in procs of ncomm_north the znorthgloio2903 itaille = jpi * ijpj2904 IF ( l_north_nogather ) THEN2905 !2906 ! Avoid the use of mpi_allgather by exchanging only with the processes already identified2907 ! (in nemo_northcomms) as being involved in this process' northern boundary exchange2908 !2909 ztabr(:,:) = 02910 ztabl(:,:) = 02911 2912 DO jj = nlcj-ijpj+1, nlcj ! First put local values into the global array2913 ij = jj - nlcj + ijpj2914 DO ji = nfsloop, nfeloop2915 ztabl(ji,ij) = pt2d(ji,jj)2916 END DO2917 END DO2918 2919 DO jr = 1,nsndto2920 IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN2921 CALL mppsend(5, znorthloc, itaille, nfipproc(isendto(jr),jpnj), ml_req_nf(jr))2922 ENDIF2923 END DO2924 DO jr = 1,nsndto2925 iproc = nfipproc(isendto(jr),jpnj)2926 IF(iproc .ne. -1) THEN2927 ilei = nleit (iproc+1)2928 ildi = nldit (iproc+1)2929 iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj)2930 ENDIF2931 IF((iproc .ne. (narea-1)) .and. (iproc .ne. -1)) THEN2932 CALL mpprecv(5, zfoldwk, itaille, iproc)2933 DO jj = 1, ijpj2934 DO ji = ildi, ilei2935 ztabr(iilb+ji,jj) = zfoldwk(ji,jj)2936 END DO2937 END DO2938 ELSE IF (iproc .eq. (narea-1)) THEN2939 DO jj = 1, ijpj2940 DO ji = ildi, ilei2941 ztabr(iilb+ji,jj) = pt2d(ji,nlcj-ijpj+jj)2942 END DO2943 END DO2944 ENDIF2945 END DO2946 IF (l_isend) THEN2947 DO jr = 1,nsndto2948 IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN2949 CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err)2950 ENDIF2951 END DO2952 ENDIF2953 CALL mpp_lbc_nfd( ztabl, ztabr, cd_type, psgn ) ! North fold boundary condition2954 !2955 DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt2d2956 ij = jj - nlcj + ijpj2957 DO ji = 1, nlci2958 pt2d(ji,jj) = ztabl(ji,ij)2959 END DO2960 END DO2961 !2962 ELSE2963 CALL MPI_ALLGATHER( znorthloc , itaille, MPI_DOUBLE_PRECISION, &2964 & znorthgloio, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr )2965 !2966 ztab(:,:) = 0.e02967 DO jr = 1, ndim_rank_north ! recover the global north array2968 iproc = nrank_north(jr) + 12969 ildi = nldit (iproc)2970 ilei = nleit (iproc)2971 iilb = nimppt(iproc)2972 DO jj = 1, ijpj2973 DO ji = ildi, ilei2974 ztab(ji+iilb-1,jj) = znorthgloio(ji,jj,jr)2975 END DO2976 END DO2977 END DO2978 CALL lbc_nfd( ztab, cd_type, psgn ) ! North fold boundary condition2979 !2980 DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt2d2981 ij = jj - nlcj + ijpj2982 DO ji = 1, nlci2983 pt2d(ji,jj) = ztab(ji+nimpp-1,ij)2984 END DO2985 END DO2986 !2987 ENDIF2988 DEALLOCATE( ztab, znorthloc, zfoldwk, znorthgloio )2989 DEALLOCATE( ztabl, ztabr )2990 !2991 END SUBROUTINE mpp_lbc_north_2d2992 2993 SUBROUTINE mpp_lbc_north_2d_multiple( pt2d_array, cd_type, psgn, num_fields)2994 !!---------------------------------------------------------------------2995 !! *** routine mpp_lbc_north_2d ***2996 !!2997 !! ** Purpose : Ensure proper north fold horizontal bondary condition2998 !! in mpp configuration in case of jpn1 > 12999 !! (for multiple 2d arrays )3000 !!3001 !! ** Method : North fold condition and mpp with more than one proc3002 !! in i-direction require a specific treatment. We gather3003 !! the 4 northern lines of the global domain on 1 processor3004 !! and apply lbc north-fold on this sub array. Then we3005 !! scatter the north fold array back to the processors.3006 !!3007 !!----------------------------------------------------------------------3008 INTEGER , INTENT (in ) :: num_fields ! number of variables contained in pt2d3009 TYPE( arrayptr ), DIMENSION(:) :: pt2d_array3010 CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: cd_type ! nature of pt2d grid-points3011 ! ! = T , U , V , F or W gridpoints3012 REAL(wp), DIMENSION(:), INTENT(in ) :: psgn ! = -1. the sign change across the north fold3013 !! ! = 1. , the sign is kept3014 INTEGER :: ji, jj, jr, jk3015 INTEGER :: ierr, itaille, ildi, ilei, iilb3016 INTEGER :: ijpj, ijpjm1, ij, iproc3017 INTEGER, DIMENSION (jpmaxngh) :: ml_req_nf !for mpi_isend when avoiding mpi_allgather3018 INTEGER :: ml_err ! for mpi_isend when avoiding mpi_allgather3019 INTEGER, DIMENSION(MPI_STATUS_SIZE):: ml_stat ! for mpi_isend when avoiding mpi_allgather3020 ! ! Workspace for message transfers avoiding mpi_allgather3021 REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: ztab3022 REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: znorthloc, zfoldwk3023 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: znorthgloio3024 REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: ztabl, ztabr3025 INTEGER :: istatus(mpi_status_size)3026 INTEGER :: iflag3027 !!----------------------------------------------------------------------3028 !3029 ALLOCATE( ztab(jpiglo,4,num_fields), znorthloc(jpi,4,num_fields), zfoldwk(jpi,4,num_fields), &3030 & znorthgloio(jpi,4,num_fields,jpni) ) ! expanded to 3 dimensions3031 ALLOCATE( ztabl(jpi,4,num_fields), ztabr(jpi*jpmaxngh, 4,num_fields) )3032 !3033 ijpj = 43034 ijpjm1 = 33035 !3036 3037 DO jk = 1, num_fields3038 DO jj = nlcj-ijpj+1, nlcj ! put in znorthloc the last 4 jlines of pt2d (for every variable)3039 ij = jj - nlcj + ijpj3040 znorthloc(:,ij,jk) = pt2d_array(jk)%pt2d(:,jj)3041 END DO3042 END DO3043 ! ! Build in procs of ncomm_north the znorthgloio3044 itaille = jpi * ijpj3045 3046 IF ( l_north_nogather ) THEN3047 !3048 ! Avoid the use of mpi_allgather by exchanging only with the processes already identified3049 ! (in nemo_northcomms) as being involved in this process' northern boundary exchange3050 !3051 ztabr(:,:,:) = 03052 ztabl(:,:,:) = 03053 3054 DO jk = 1, num_fields3055 DO jj = nlcj-ijpj+1, nlcj ! First put local values into the global array3056 ij = jj - nlcj + ijpj3057 DO ji = nfsloop, nfeloop3058 ztabl(ji,ij,jk) = pt2d_array(jk)%pt2d(ji,jj)3059 END DO3060 END DO3061 END DO3062 3063 DO jr = 1,nsndto3064 IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN3065 CALL mppsend(5, znorthloc, itaille*num_fields, nfipproc(isendto(jr),jpnj), ml_req_nf(jr)) ! Buffer expanded "num_fields" times3066 ENDIF3067 END DO3068 DO jr = 1,nsndto3069 iproc = nfipproc(isendto(jr),jpnj)3070 IF(iproc .ne. -1) THEN3071 ilei = nleit (iproc+1)3072 ildi = nldit (iproc+1)3073 iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj)3074 ENDIF3075 IF((iproc .ne. (narea-1)) .and. (iproc .ne. -1)) THEN3076 CALL mpprecv(5, zfoldwk, itaille*num_fields, iproc) ! Buffer expanded "num_fields" times3077 DO jk = 1 , num_fields3078 DO jj = 1, ijpj3079 DO ji = ildi, ilei3080 ztabr(iilb+ji,jj,jk) = zfoldwk(ji,jj,jk) ! Modified to 3D3081 END DO3082 END DO3083 END DO3084 ELSE IF (iproc .eq. (narea-1)) THEN3085 DO jk = 1, num_fields3086 DO jj = 1, ijpj3087 DO ji = ildi, ilei3088 ztabr(iilb+ji,jj,jk) = pt2d_array(jk)%pt2d(ji,nlcj-ijpj+jj) ! Modified to 3D3089 END DO3090 END DO3091 END DO3092 ENDIF3093 END DO3094 IF (l_isend) THEN3095 DO jr = 1,nsndto3096 IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN3097 CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err)3098 ENDIF3099 END DO3100 ENDIF3101 !3102 DO ji = 1, num_fields ! Loop to manage 3D variables3103 CALL mpp_lbc_nfd( ztabl(:,:,ji), ztabr(:,:,ji), cd_type(ji), psgn(ji) ) ! North fold boundary condition3104 END DO3105 !3106 DO jk = 1, num_fields3107 DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt2d3108 ij = jj - nlcj + ijpj3109 DO ji = 1, nlci3110 pt2d_array(jk)%pt2d(ji,jj) = ztabl(ji,ij,jk) ! Modified to 3D3111 END DO3112 END DO3113 END DO3114 3115 !3116 ELSE3117 !3118 CALL MPI_ALLGATHER( znorthloc , itaille*num_fields, MPI_DOUBLE_PRECISION, &3119 & znorthgloio, itaille*num_fields, MPI_DOUBLE_PRECISION, ncomm_north, ierr )3120 !3121 ztab(:,:,:) = 0.e03122 DO jk = 1, num_fields3123 DO jr = 1, ndim_rank_north ! recover the global north array3124 iproc = nrank_north(jr) + 13125 ildi = nldit (iproc)3126 ilei = nleit (iproc)3127 iilb = nimppt(iproc)3128 DO jj = 1, ijpj3129 DO ji = ildi, ilei3130 ztab(ji+iilb-1,jj,jk) = znorthgloio(ji,jj,jk,jr)3131 END DO3132 END DO3133 END DO3134 END DO3135 3136 DO ji = 1, num_fields3137 CALL lbc_nfd( ztab(:,:,ji), cd_type(ji), psgn(ji) ) ! North fold boundary condition3138 END DO3139 !3140 DO jk = 1, num_fields3141 DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt2d3142 ij = jj - nlcj + ijpj3143 DO ji = 1, nlci3144 pt2d_array(jk)%pt2d(ji,jj) = ztab(ji+nimpp-1,ij,jk)3145 END DO3146 END DO3147 END DO3148 !3149 !3150 ENDIF3151 DEALLOCATE( ztab, znorthloc, zfoldwk, znorthgloio )3152 DEALLOCATE( ztabl, ztabr )3153 !3154 END SUBROUTINE mpp_lbc_north_2d_multiple3155 3156 1476 SUBROUTINE mpp_lbc_north_e( pt2d, cd_type, psgn) 3157 1477 !!--------------------------------------------------------------------- … … 3171 1491 REAL(wp), DIMENSION(1-jpr2di:jpi+jpr2di,1-jpr2dj:jpj+jpr2dj), INTENT(inout) :: pt2d ! 2D array with extra halo 3172 1492 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points 3173 ! ! = T , U , V , F or W -points 3174 REAL(wp) , INTENT(in ) :: psgn ! = -1. the sign change across the 3175 !! ! north fold, = 1. otherwise 1493 REAL(wp) , INTENT(in ) :: psgn ! sign used across the north fold 1494 ! 3176 1495 INTEGER :: ji, jj, jr 3177 1496 INTEGER :: ierr, itaille, ildi, ilei, iilb 3178 1497 INTEGER :: ijpj, ij, iproc 3179 !3180 1498 REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: ztab_e, znorthloc_e 3181 1499 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: znorthgloio_e 3182 3183 1500 !!---------------------------------------------------------------------- 3184 1501 ! 3185 1502 ALLOCATE( ztab_e(jpiglo,4+2*jpr2dj), znorthloc_e(jpi,4+2*jpr2dj), znorthgloio_e(jpi,4+2*jpr2dj,jpni) ) 3186 3187 1503 ! 3188 1504 ijpj=4 3189 ztab_e(:,:) = 0. e03190 3191 ij =01505 ztab_e(:,:) = 0._wp 1506 1507 ij = 0 3192 1508 ! put in znorthloc_e the last 4 jlines of pt2d 3193 1509 DO jj = nlcj - ijpj + 1 - jpr2dj, nlcj +jpr2dj 3194 1510 ij = ij + 1 3195 1511 DO ji = 1, jpi 3196 znorthloc_e(ji,ij) =pt2d(ji,jj)1512 znorthloc_e(ji,ij) = pt2d(ji,jj) 3197 1513 END DO 3198 1514 END DO 3199 1515 ! 3200 1516 itaille = jpi * ( ijpj + 2 * jpr2dj ) 3201 CALL MPI_ALLGATHER( znorthloc_e(1,1) , itaille, MPI_DOUBLE_PRECISION, &1517 CALL MPI_ALLGATHER( znorthloc_e(1,1) , itaille, MPI_DOUBLE_PRECISION, & 3202 1518 & znorthgloio_e(1,1,1), itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 3203 1519 ! 3204 1520 DO jr = 1, ndim_rank_north ! recover the global north array 3205 1521 iproc = nrank_north(jr) + 1 3206 ildi = nldit (iproc)3207 ilei = nleit (iproc)3208 iilb = nimppt(iproc)1522 ildi = nldit (iproc) 1523 ilei = nleit (iproc) 1524 iilb = nimppt(iproc) 3209 1525 DO jj = 1, ijpj+2*jpr2dj 3210 1526 DO ji = ildi, ilei … … 3214 1530 END DO 3215 1531 3216 3217 1532 ! 2. North-Fold boundary conditions 3218 1533 ! ---------------------------------- 3219 CALL lbc_nfd( ztab_e(:,:), cd_type, psgn, pr2dj = jpr2dj )1534 !!gm ERROR CALL lbc_nfd( ztab_e(:,:), cd_type, psgn, pr2dj = jpr2dj ) 3220 1535 3221 1536 ij = jpr2dj … … 3231 1546 ! 3232 1547 END SUBROUTINE mpp_lbc_north_e 3233 3234 3235 SUBROUTINE mpp_lnk_bdy_3d( ptab, cd_type, psgn, ib_bdy )3236 !!----------------------------------------------------------------------3237 !! *** routine mpp_lnk_bdy_3d ***3238 !!3239 !! ** Purpose : Message passing management3240 !!3241 !! ** Method : Use mppsend and mpprecv function for passing BDY boundaries3242 !! between processors following neighboring subdomains.3243 !! domain parameters3244 !! nlci : first dimension of the local subdomain3245 !! nlcj : second dimension of the local subdomain3246 !! nbondi_bdy : mark for "east-west local boundary"3247 !! nbondj_bdy : mark for "north-south local boundary"3248 !! noea : number for local neighboring processors3249 !! nowe : number for local neighboring processors3250 !! noso : number for local neighboring processors3251 !! nono : number for local neighboring processors3252 !!3253 !! ** Action : ptab with update value at its periphery3254 !!3255 !!----------------------------------------------------------------------3256 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: ptab ! 3D array on which the boundary condition is applied3257 CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points3258 ! ! = T , U , V , F , W points3259 REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary3260 ! ! = 1. , the sign is kept3261 INTEGER , INTENT(in ) :: ib_bdy ! BDY boundary set3262 !3263 INTEGER :: ji, jj, jk, jl ! dummy loop indices3264 INTEGER :: imigr, iihom, ijhom ! local integers3265 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend3266 REAL(wp) :: zland ! local scalar3267 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend3268 !3269 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: zt3ns, zt3sn ! 3d for north-south & south-north3270 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: zt3ew, zt3we ! 3d for east-west & west-east3271 !!----------------------------------------------------------------------3272 !3273 ALLOCATE( zt3ns(jpi,jprecj,jpk,2), zt3sn(jpi,jprecj,jpk,2), &3274 & zt3ew(jpj,jpreci,jpk,2), zt3we(jpj,jpreci,jpk,2) )3275 3276 zland = 0._wp3277 3278 ! 1. standard boundary treatment3279 ! ------------------------------3280 ! ! East-West boundaries3281 ! !* Cyclic east-west3282 IF( nbondi == 2) THEN3283 IF( nperio == 1 .OR. nperio == 4 .OR. nperio == 6 ) THEN3284 ptab( 1 ,:,:) = ptab(jpim1,:,:)3285 ptab(jpi,:,:) = ptab( 2 ,:,:)3286 ELSE3287 IF( .NOT. cd_type == 'F' ) ptab(1:jpreci,:,:) = zland ! south except F-point3288 ptab(nlci-jpreci+1:jpi,:,:) = zland ! north3289 ENDIF3290 ELSEIF(nbondi == -1) THEN3291 IF( .NOT. cd_type == 'F' ) ptab(1:jpreci,:,:) = zland ! south except F-point3292 ELSEIF(nbondi == 1) THEN3293 ptab(nlci-jpreci+1:jpi,:,:) = zland ! north3294 ENDIF !* closed3295 3296 IF (nbondj == 2 .OR. nbondj == -1) THEN3297 IF( .NOT. cd_type == 'F' ) ptab(:,1:jprecj,:) = zland ! south except F-point3298 ELSEIF (nbondj == 2 .OR. nbondj == 1) THEN3299 ptab(:,nlcj-jprecj+1:jpj,:) = zland ! north3300 ENDIF3301 !3302 ! 2. East and west directions exchange3303 ! ------------------------------------3304 ! we play with the neigbours AND the row number because of the periodicity3305 !3306 SELECT CASE ( nbondi_bdy(ib_bdy) ) ! Read Dirichlet lateral conditions3307 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case)3308 iihom = nlci-nreci3309 DO jl = 1, jpreci3310 zt3ew(:,jl,:,1) = ptab(jpreci+jl,:,:)3311 zt3we(:,jl,:,1) = ptab(iihom +jl,:,:)3312 END DO3313 END SELECT3314 !3315 ! ! Migrations3316 imigr = jpreci * jpj * jpk3317 !3318 SELECT CASE ( nbondi_bdy(ib_bdy) )3319 CASE ( -1 )3320 CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req1 )3321 CASE ( 0 )3322 CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 )3323 CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req2 )3324 CASE ( 1 )3325 CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 )3326 END SELECT3327 !3328 SELECT CASE ( nbondi_bdy_b(ib_bdy) )3329 CASE ( -1 )3330 CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea )3331 CASE ( 0 )3332 CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea )3333 CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe )3334 CASE ( 1 )3335 CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe )3336 END SELECT3337 !3338 SELECT CASE ( nbondi_bdy(ib_bdy) )3339 CASE ( -1 )3340 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)3341 CASE ( 0 )3342 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)3343 IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)3344 CASE ( 1 )3345 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)3346 END SELECT3347 !3348 ! ! Write Dirichlet lateral conditions3349 iihom = nlci-jpreci3350 !3351 SELECT CASE ( nbondi_bdy_b(ib_bdy) )3352 CASE ( -1 )3353 DO jl = 1, jpreci3354 ptab(iihom+jl,:,:) = zt3ew(:,jl,:,2)3355 END DO3356 CASE ( 0 )3357 DO jl = 1, jpreci3358 ptab( jl,:,:) = zt3we(:,jl,:,2)3359 ptab(iihom+jl,:,:) = zt3ew(:,jl,:,2)3360 END DO3361 CASE ( 1 )3362 DO jl = 1, jpreci3363 ptab( jl,:,:) = zt3we(:,jl,:,2)3364 END DO3365 END SELECT3366 3367 3368 ! 3. North and south directions3369 ! -----------------------------3370 ! always closed : we play only with the neigbours3371 !3372 IF( nbondj_bdy(ib_bdy) /= 2 ) THEN ! Read Dirichlet lateral conditions3373 ijhom = nlcj-nrecj3374 DO jl = 1, jprecj3375 zt3sn(:,jl,:,1) = ptab(:,ijhom +jl,:)3376 zt3ns(:,jl,:,1) = ptab(:,jprecj+jl,:)3377 END DO3378 ENDIF3379 !3380 ! ! Migrations3381 imigr = jprecj * jpi * jpk3382 !3383 SELECT CASE ( nbondj_bdy(ib_bdy) )3384 CASE ( -1 )3385 CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req1 )3386 CASE ( 0 )3387 CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 )3388 CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req2 )3389 CASE ( 1 )3390 CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 )3391 END SELECT3392 !3393 SELECT CASE ( nbondj_bdy_b(ib_bdy) )3394 CASE ( -1 )3395 CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono )3396 CASE ( 0 )3397 CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono )3398 CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso )3399 CASE ( 1 )3400 CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso )3401 END SELECT3402 !3403 SELECT CASE ( nbondj_bdy(ib_bdy) )3404 CASE ( -1 )3405 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)3406 CASE ( 0 )3407 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)3408 IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)3409 CASE ( 1 )3410 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)3411 END SELECT3412 !3413 ! ! Write Dirichlet lateral conditions3414 ijhom = nlcj-jprecj3415 !3416 SELECT CASE ( nbondj_bdy_b(ib_bdy) )3417 CASE ( -1 )3418 DO jl = 1, jprecj3419 ptab(:,ijhom+jl,:) = zt3ns(:,jl,:,2)3420 END DO3421 CASE ( 0 )3422 DO jl = 1, jprecj3423 ptab(:,jl ,:) = zt3sn(:,jl,:,2)3424 ptab(:,ijhom+jl,:) = zt3ns(:,jl,:,2)3425 END DO3426 CASE ( 1 )3427 DO jl = 1, jprecj3428 ptab(:,jl,:) = zt3sn(:,jl,:,2)3429 END DO3430 END SELECT3431 3432 3433 ! 4. north fold treatment3434 ! -----------------------3435 !3436 IF( npolj /= 0) THEN3437 !3438 SELECT CASE ( jpni )3439 CASE ( 1 ) ; CALL lbc_nfd ( ptab, cd_type, psgn ) ! only 1 northern proc, no mpp3440 CASE DEFAULT ; CALL mpp_lbc_north( ptab, cd_type, psgn ) ! for all northern procs.3441 END SELECT3442 !3443 ENDIF3444 !3445 DEALLOCATE( zt3ns, zt3sn, zt3ew, zt3we )3446 !3447 END SUBROUTINE mpp_lnk_bdy_3d3448 3449 3450 SUBROUTINE mpp_lnk_bdy_2d( ptab, cd_type, psgn, ib_bdy )3451 !!----------------------------------------------------------------------3452 !! *** routine mpp_lnk_bdy_2d ***3453 !!3454 !! ** Purpose : Message passing management3455 !!3456 !! ** Method : Use mppsend and mpprecv function for passing BDY boundaries3457 !! between processors following neighboring subdomains.3458 !! domain parameters3459 !! nlci : first dimension of the local subdomain3460 !! nlcj : second dimension of the local subdomain3461 !! nbondi_bdy : mark for "east-west local boundary"3462 !! nbondj_bdy : mark for "north-south local boundary"3463 !! noea : number for local neighboring processors3464 !! nowe : number for local neighboring processors3465 !! noso : number for local neighboring processors3466 !! nono : number for local neighboring processors3467 !!3468 !! ** Action : ptab with update value at its periphery3469 !!3470 !!----------------------------------------------------------------------3471 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: ptab ! 3D array on which the boundary condition is applied3472 CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points3473 ! ! = T , U , V , F , W points3474 REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary3475 ! ! = 1. , the sign is kept3476 INTEGER , INTENT(in ) :: ib_bdy ! BDY boundary set3477 !3478 INTEGER :: ji, jj, jl ! dummy loop indices3479 INTEGER :: imigr, iihom, ijhom ! local integers3480 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend3481 REAL(wp) :: zland3482 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend3483 !3484 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ns, zt2sn ! 2d for north-south & south-north3485 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ew, zt2we ! 2d for east-west & west-east3486 !!----------------------------------------------------------------------3487 3488 ALLOCATE( zt2ns(jpi,jprecj,2), zt2sn(jpi,jprecj,2), &3489 & zt2ew(jpj,jpreci,2), zt2we(jpj,jpreci,2) )3490 3491 zland = 0._wp3492 3493 ! 1. standard boundary treatment3494 ! ------------------------------3495 ! ! East-West boundaries3496 ! !* Cyclic east-west3497 IF( nbondi == 2 ) THEN3498 IF (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) THEN3499 ptab( 1 ,:) = ptab(jpim1,:)3500 ptab(jpi,:) = ptab( 2 ,:)3501 ELSE3502 IF(.NOT.cd_type == 'F' ) ptab( 1 :jpreci,:) = zland ! south except F-point3503 ptab(nlci-jpreci+1:jpi ,:) = zland ! north3504 ENDIF3505 ELSEIF(nbondi == -1) THEN3506 IF( .NOT.cd_type == 'F' ) ptab( 1 :jpreci,:) = zland ! south except F-point3507 ELSEIF(nbondi == 1) THEN3508 ptab(nlci-jpreci+1:jpi ,:) = zland ! north3509 ENDIF3510 ! !* closed3511 IF( nbondj == 2 .OR. nbondj == -1 ) THEN3512 IF( .NOT.cd_type == 'F' ) ptab(:, 1 :jprecj) = zland ! south except F-point3513 ELSEIF (nbondj == 2 .OR. nbondj == 1) THEN3514 ptab(:,nlcj-jprecj+1:jpj ) = zland ! north3515 ENDIF3516 !3517 ! 2. East and west directions exchange3518 ! ------------------------------------3519 ! we play with the neigbours AND the row number because of the periodicity3520 !3521 SELECT CASE ( nbondi_bdy(ib_bdy) ) ! Read Dirichlet lateral conditions3522 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case)3523 iihom = nlci-nreci3524 DO jl = 1, jpreci3525 zt2ew(:,jl,1) = ptab(jpreci+jl,:)3526 zt2we(:,jl,1) = ptab(iihom +jl,:)3527 END DO3528 END SELECT3529 !3530 ! ! Migrations3531 imigr = jpreci * jpj3532 !3533 SELECT CASE ( nbondi_bdy(ib_bdy) )3534 CASE ( -1 )3535 CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req1 )3536 CASE ( 0 )3537 CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 )3538 CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req2 )3539 CASE ( 1 )3540 CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 )3541 END SELECT3542 !3543 SELECT CASE ( nbondi_bdy_b(ib_bdy) )3544 CASE ( -1 )3545 CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea )3546 CASE ( 0 )3547 CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea )3548 CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe )3549 CASE ( 1 )3550 CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe )3551 END SELECT3552 !3553 SELECT CASE ( nbondi_bdy(ib_bdy) )3554 CASE ( -1 )3555 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)3556 CASE ( 0 )3557 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)3558 IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)3559 CASE ( 1 )3560 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)3561 END SELECT3562 !3563 ! ! Write Dirichlet lateral conditions3564 iihom = nlci-jpreci3565 !3566 SELECT CASE ( nbondi_bdy_b(ib_bdy) )3567 CASE ( -1 )3568 DO jl = 1, jpreci3569 ptab(iihom+jl,:) = zt2ew(:,jl,2)3570 END DO3571 CASE ( 0 )3572 DO jl = 1, jpreci3573 ptab(jl ,:) = zt2we(:,jl,2)3574 ptab(iihom+jl,:) = zt2ew(:,jl,2)3575 END DO3576 CASE ( 1 )3577 DO jl = 1, jpreci3578 ptab(jl ,:) = zt2we(:,jl,2)3579 END DO3580 END SELECT3581 3582 3583 ! 3. North and south directions3584 ! -----------------------------3585 ! always closed : we play only with the neigbours3586 !3587 IF( nbondj_bdy(ib_bdy) /= 2 ) THEN ! Read Dirichlet lateral conditions3588 ijhom = nlcj-nrecj3589 DO jl = 1, jprecj3590 zt2sn(:,jl,1) = ptab(:,ijhom +jl)3591 zt2ns(:,jl,1) = ptab(:,jprecj+jl)3592 END DO3593 ENDIF3594 !3595 ! ! Migrations3596 imigr = jprecj * jpi3597 !3598 SELECT CASE ( nbondj_bdy(ib_bdy) )3599 CASE ( -1 )3600 CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req1 )3601 CASE ( 0 )3602 CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 )3603 CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req2 )3604 CASE ( 1 )3605 CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 )3606 END SELECT3607 !3608 SELECT CASE ( nbondj_bdy_b(ib_bdy) )3609 CASE ( -1 )3610 CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono )3611 CASE ( 0 )3612 CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono )3613 CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso )3614 CASE ( 1 )3615 CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso )3616 END SELECT3617 !3618 SELECT CASE ( nbondj_bdy(ib_bdy) )3619 CASE ( -1 )3620 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)3621 CASE ( 0 )3622 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)3623 IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)3624 CASE ( 1 )3625 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)3626 END SELECT3627 !3628 ! ! Write Dirichlet lateral conditions3629 ijhom = nlcj-jprecj3630 !3631 SELECT CASE ( nbondj_bdy_b(ib_bdy) )3632 CASE ( -1 )3633 DO jl = 1, jprecj3634 ptab(:,ijhom+jl) = zt2ns(:,jl,2)3635 END DO3636 CASE ( 0 )3637 DO jl = 1, jprecj3638 ptab(:,jl ) = zt2sn(:,jl,2)3639 ptab(:,ijhom+jl) = zt2ns(:,jl,2)3640 END DO3641 CASE ( 1 )3642 DO jl = 1, jprecj3643 ptab(:,jl) = zt2sn(:,jl,2)3644 END DO3645 END SELECT3646 3647 3648 ! 4. north fold treatment3649 ! -----------------------3650 !3651 IF( npolj /= 0) THEN3652 !3653 SELECT CASE ( jpni )3654 CASE ( 1 ) ; CALL lbc_nfd ( ptab, cd_type, psgn ) ! only 1 northern proc, no mpp3655 CASE DEFAULT ; CALL mpp_lbc_north( ptab, cd_type, psgn ) ! for all northern procs.3656 END SELECT3657 !3658 ENDIF3659 !3660 DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we )3661 !3662 END SUBROUTINE mpp_lnk_bdy_2d3663 1548 3664 1549 … … 3722 1607 END SUBROUTINE mpi_init_opa 3723 1608 3724 SUBROUTINE DDPDD_MPI (ydda, yddb, ilen, itype) 1609 1610 SUBROUTINE DDPDD_MPI( ydda, yddb, ilen, itype ) 3725 1611 !!--------------------------------------------------------------------- 3726 1612 !! Routine DDPDD_MPI: used by reduction operator MPI_SUMDD … … 3729 1615 !! This subroutine computes yddb(i) = ydda(i)+yddb(i) 3730 1616 !!--------------------------------------------------------------------- 3731 INTEGER , INTENT(in) ::ilen, itype3732 COMPLEX(wp), DIMENSION(ilen), INTENT(in) ::ydda3733 COMPLEX(wp), DIMENSION(ilen), INTENT(inout) ::yddb1617 INTEGER , INTENT(in) :: ilen, itype 1618 COMPLEX(wp), DIMENSION(ilen), INTENT(in) :: ydda 1619 COMPLEX(wp), DIMENSION(ilen), INTENT(inout) :: yddb 3734 1620 ! 3735 1621 REAL(wp) :: zerr, zt1, zt2 ! local work variables 3736 INTEGER :: ji, ztmp ! local scalar 3737 1622 INTEGER :: ji, ztmp ! local scalar 1623 !!--------------------------------------------------------------------- 1624 ! 3738 1625 ztmp = itype ! avoid compilation warning 3739 1626 ! 3740 1627 DO ji=1,ilen 3741 1628 ! Compute ydda + yddb using Knuth's trick. … … 3748 1635 yddb(ji) = cmplx ( zt1 + zt2, zt2 - ((zt1 + zt2) - zt1),wp ) 3749 1636 END DO 3750 1637 ! 3751 1638 END SUBROUTINE DDPDD_MPI 3752 1639 … … 3818 1705 END DO 3819 1706 3820 3821 1707 ! 2. North-Fold boundary conditions 3822 1708 ! ---------------------------------- 3823 CALL lbc_nfd( ztab_e(:,:), cd_type, psgn, pr2dj = ipr2dj )1709 !!gm ERROR CALL lbc_nfd( ztab_e(:,:), cd_type, psgn, pr2dj = ipr2dj ) 3824 1710 3825 1711 ij = ipr2dj … … 3857 1743 !! nono : number for local neighboring processors 3858 1744 !!---------------------------------------------------------------------- 1745 REAL(wp), DIMENSION(1-jpri:jpi+jpri,1-jprj:jpj+jprj), INTENT(inout) :: pt2d ! 2D array with extra halo 1746 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of ptab array grid-points 1747 REAL(wp) , INTENT(in ) :: psgn ! sign used across the north fold 3859 1748 INTEGER , INTENT(in ) :: jpri 3860 1749 INTEGER , INTENT(in ) :: jprj 3861 REAL(wp), DIMENSION(1-jpri:jpi+jpri,1-jprj:jpj+jprj), INTENT(inout) :: pt2d ! 2D array with extra halo 3862 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of ptab array grid-points 3863 ! ! = T , U , V , F , W and I points 3864 REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the 3865 !! ! north boundary, = 1. otherwise 1750 ! 3866 1751 INTEGER :: jl ! dummy loop indices 3867 INTEGER :: imigr, iihom, ijhom ! temporaryintegers3868 INTEGER :: ipreci, iprecj ! temporary integers1752 INTEGER :: imigr, iihom, ijhom ! local integers 1753 INTEGER :: ipreci, iprecj ! - - 3869 1754 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 3870 1755 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 3871 1756 !! 3872 REAL(wp), DIMENSION(1-jpri:jpi+jpri,jprecj+jprj,2) :: r2dns 3873 REAL(wp), DIMENSION(1-jpri:jpi+jpri,jprecj+jprj,2) :: r2dsn 3874 REAL(wp), DIMENSION(1-jprj:jpj+jprj,jpreci+jpri,2) :: r2dwe 3875 REAL(wp), DIMENSION(1-jprj:jpj+jprj,jpreci+jpri,2) :: r2dew 1757 REAL(wp), DIMENSION(1-jpri:jpi+jpri,jprecj+jprj,2) :: r2dns, r2dsn 1758 REAL(wp), DIMENSION(1-jprj:jpj+jprj,jpreci+jpri,2) :: r2dwe, r2dew 3876 1759 !!---------------------------------------------------------------------- 3877 1760 … … 3891 1774 ! 3892 1775 ELSE !* closed 3893 IF( .NOT. cd_type == 'F' ) pt2d( 1-jpri :jpreci ,:) = 0. e0! south except at F-point3894 pt2d(nlci-jpreci+1:jpi+jpri,:) = 0. e0! north1776 IF( .NOT. cd_type == 'F' ) pt2d( 1-jpri :jpreci ,:) = 0._wp ! south except at F-point 1777 pt2d(nlci-jpreci+1:jpi+jpri,:) = 0._wp ! north 3895 1778 ENDIF 3896 1779 ! … … 3901 1784 ! 3902 1785 SELECT CASE ( jpni ) 3903 CASE ( 1 ) ; CALL lbc_nfd ( pt2d(1:jpi,1:jpj+jprj), cd_type, psgn, pr2dj=jprj )3904 CASE DEFAULT ; CALL mpp_lbc_north_icb( pt2d(1:jpi,1:jpj+jprj) , cd_type, psgn , pr2dj=jprj )1786 !!gm ERROR CASE ( 1 ) ; CALL lbc_nfd ( pt2d(1:jpi,1:jpj+jprj), cd_type, psgn, pr2dj=jprj ) 1787 !!gm ERROR CASE DEFAULT ; CALL mpp_lbc_north_icb( pt2d(1:jpi,1:jpj+jprj) , cd_type, psgn , pr2dj=jprj ) 3905 1788 END SELECT 3906 1789 ! … … 4012 1895 END DO 4013 1896 END SELECT 4014 1897 ! 4015 1898 END SUBROUTINE mpp_lnk_2d_icb 4016 1899 … … 4036 1919 MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d 4037 1920 END INTERFACE 1921 INTERFACE mpp_max_multiple 1922 MODULE PROCEDURE mppmax_real_multiple 1923 END INTERFACE 4038 1924 4039 1925 LOGICAL, PUBLIC, PARAMETER :: lk_mpp = .FALSE. !: mpp flag … … 4207 2093 WRITE(*,*) 'mpp_comm_free: You should not have seen this print! error?', kcom 4208 2094 END SUBROUTINE mpp_comm_free 2095 2096 SUBROUTINE mppmax_real_multiple( ptab, kdim , kcom ) 2097 REAL, DIMENSION(:) :: ptab ! 2098 INTEGER :: kdim ! 2099 INTEGER, OPTIONAL :: kcom ! 2100 WRITE(*,*) 'mppmax_real_multiple: You should not have seen this print! error?', ptab(1), kdim 2101 END SUBROUTINE mppmax_real_multiple 2102 4209 2103 #endif 4210 2104 … … 4241 2135 CALL FLUSH(numout ) 4242 2136 IF( numstp /= -1 ) CALL FLUSH(numstp ) 4243 IF( num sol /= -1 ) CALL FLUSH(numsol)2137 IF( numrun /= -1 ) CALL FLUSH(numrun ) 4244 2138 IF( numevo_ice /= -1 ) CALL FLUSH(numevo_ice) 4245 2139 ! -
branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/NEMO/OPA_SRC/OBS/diaobs.F90
r8877 r8879 291 291 END DO 292 292 ENDIF 293 #if defined key_lim 2 || defined key_lim3293 #if defined key_lim3 294 294 IF (ln_sic) THEN 295 295 jtype = jtype + 1 … … 539 539 #if defined key_lim3 540 540 USE ice, ONLY : & ! LIM3 Ice model variables 541 & frld 542 #endif 543 #if defined key_lim2 544 USE ice_2, ONLY : & ! LIM2 Ice model variables 545 & frld 541 & at_i 546 542 #endif 547 543 IMPLICIT NONE … … 567 563 & zgphi1, & ! Model latitudes for prof variable 1 568 564 & zgphi2 ! Model latitudes for prof variable 2 569 #if ! defined key_lim 2 && ! defined key_lim3570 REAL(wp), POINTER, DIMENSION(:,:) :: frld565 #if ! defined key_lim3 566 REAL(wp), POINTER, DIMENSION(:,:) :: at_i 571 567 #endif 572 568 LOGICAL :: llnightav ! Logical for calculating night-time average … … 582 578 CALL wrk_alloc( jpi, jpj, zgphi1 ) 583 579 CALL wrk_alloc( jpi, jpj, zgphi2 ) 584 #if ! defined key_lim 2 && ! defined key_lim3585 CALL wrk_alloc(jpi,jpj, frld)580 #if ! defined key_lim3 581 CALL wrk_alloc(jpi,jpj,at_i) 586 582 #endif 587 583 … … 595 591 596 592 !----------------------------------------------------------------------- 597 ! No LIM => frld== 0.0_wp598 !----------------------------------------------------------------------- 599 #if ! defined key_lim 2 && ! defined key_lim3600 frld(:,:) = 0.0_wp593 ! No LIM => at_i == 0.0_wp 594 !----------------------------------------------------------------------- 595 #if ! defined key_lim3 596 at_i(:,:) = 0.0_wp 601 597 #endif 602 598 !----------------------------------------------------------------------- … … 665 661 zsurfvar(:,:) = sshn(:,:) 666 662 llnightav = .FALSE. 667 #if defined key_lim 2 || defined key_lim3663 #if defined key_lim3 668 664 CASE('sic') 669 665 IF ( kstp == 0 ) THEN … … 678 674 CYCLE 679 675 ELSE 680 zsurfvar(:,:) = 1._wp - frld(:,:)676 zsurfvar(:,:) = at_i(:,:) 681 677 ENDIF 682 678 … … 702 698 CALL wrk_dealloc( jpi, jpj, zgphi1 ) 703 699 CALL wrk_dealloc( jpi, jpj, zgphi2 ) 704 #if ! defined key_lim 2 && ! defined key_lim3705 CALL wrk_dealloc(jpi,jpj, frld)700 #if ! defined key_lim3 701 CALL wrk_dealloc(jpi,jpj,at_i) 706 702 #endif 707 703 -
branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/NEMO/OPA_SRC/SBC/fldread.F90
r8877 r8879 116 116 END TYPE WGT 117 117 118 INTEGER, PARAMETER :: tot_wgts = 10118 INTEGER, PARAMETER :: tot_wgts = 20 119 119 TYPE( WGT ), DIMENSION(tot_wgts) :: ref_wgts ! array of wgts 120 120 INTEGER :: nxt_wgt = 1 ! point to next available space in ref_wgts array -
branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/NEMO/OPA_SRC/SBC/sbc_ice.F90
r8877 r8879 9 9 !! 3.4 ! 2011-11 (C. Harris) CICE added as an option 10 10 !!---------------------------------------------------------------------- 11 #if defined key_lim3 || defined key_ lim2 || defined key_cice12 !!---------------------------------------------------------------------- 13 !! 'key_lim 2' or 'key_lim3' : LIM-2 orLIM-3 sea-ice model11 #if defined key_lim3 || defined key_cice 12 !!---------------------------------------------------------------------- 13 !! 'key_lim3' : LIM-3 sea-ice model 14 14 !!---------------------------------------------------------------------- 15 15 USE par_oce ! ocean parameters … … 18 18 USE ice ! LIM-3 parameters 19 19 # endif 20 # if defined key_lim221 USE par_ice_2 ! LIM-2 parameters22 USE ice_223 # endif24 20 # if defined key_cice 25 21 USE ice_domain_size, only: ncat … … 31 27 PRIVATE 32 28 33 PUBLIC sbc_ice_alloc ! called in iceini(_2).F90 34 35 # if defined key_lim2 36 LOGICAL , PUBLIC, PARAMETER :: lk_lim2 = .TRUE. !: LIM-2 ice model 37 LOGICAL , PUBLIC, PARAMETER :: lk_lim3 = .FALSE. !: no LIM-3 38 LOGICAL , PUBLIC, PARAMETER :: lk_cice = .FALSE. !: no CICE 39 # if defined key_lim2_vp 40 CHARACTER(len=1), PUBLIC, PARAMETER :: cp_ice_msh = 'I' !: VP : 'I'-grid ice-velocity (B-grid lower left corner) 41 # else 42 CHARACTER(len=1), PUBLIC, PARAMETER :: cp_ice_msh = 'C' !: EVP: 'C'-grid ice-velocity 43 # endif 44 # endif 29 PUBLIC sbc_ice_alloc ! called in sbcmod.F90 30 45 31 # if defined key_lim3 46 LOGICAL , PUBLIC, PARAMETER :: lk_lim2 = .FALSE. !: no LIM-247 32 LOGICAL , PUBLIC, PARAMETER :: lk_lim3 = .TRUE. !: LIM-3 ice model 48 33 LOGICAL , PUBLIC, PARAMETER :: lk_cice = .FALSE. !: no CICE … … 50 35 # endif 51 36 # if defined key_cice 52 LOGICAL , PUBLIC, PARAMETER :: lk_lim2 = .FALSE. !: no LIM-253 37 LOGICAL , PUBLIC, PARAMETER :: lk_lim3 = .FALSE. !: no LIM-3 54 38 LOGICAL , PUBLIC, PARAMETER :: lk_cice = .TRUE. !: CICE ice model … … 64 48 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: alb_ice !: ice albedo [-] 65 49 50 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: qml_ice !: heat available for snow / ice surface melting [W/m2] 51 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: qcn_ice !: heat conduction flux in the layer below surface [W/m2] 52 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: qsr_ice_tr !: solar flux transmitted below the ice surface [W/m2] 53 66 54 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: utau_ice !: atmos-ice u-stress. VP: I-pt ; EVP: U,V-pts [N/m2] 67 55 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: vtau_ice !: atmos-ice v-stress. VP: I-pt ; EVP: U,V-pts [N/m2] 68 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fr1_i0 !: Solar surface transmission parameter, thick ice [-]69 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fr2_i0 !: Solar surface transmission parameter, thin ice [-]70 56 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: emp_ice !: sublimation - precip over sea ice [kg/m2/s] 71 57 … … 83 69 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qprec_ice !: enthalpy of precip over ice [J/m3] 84 70 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: emp_oce !: evap - precip over ocean [kg/m2/s] 85 #endif86 #if defined key_lim3 || defined key_lim287 71 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wndm_ice !: wind speed module at T-point [m/s] 72 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sstfrz !: wind speed module at T-point [m/s] 73 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: tsfc_ice !: sea ice surface skin temperature (on categories) 88 74 #endif 89 75 … … 102 88 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fr_iu !: ice fraction at NEMO U point 103 89 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fr_iv !: ice fraction at NEMO V point 90 104 91 105 92 ! variables used in the coupled interface 106 93 INTEGER , PUBLIC, PARAMETER :: jpl = ncat 107 94 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: u_ice, v_ice ! jpi, jpj 108 #endif109 95 110 #if defined key_lim2 || defined key_cice111 96 ! already defined in ice.F90 for LIM3 112 97 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: a_i 113 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ht_i, ht_s 114 #endif 115 116 #if defined key_cice 98 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: h_i, h_s 99 117 100 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tatm_ice !: air temperature [K] 118 101 #endif 119 102 120 103 REAL(wp), PUBLIC, SAVE :: cldf_ice = 0.81 !: cloud fraction over sea ice, summer CLIO value [-] 104 105 !! arrays relating to embedding ice in the ocean 106 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: snwice_mass !: mass of snow and ice at current ice time step [Kg/m2] 107 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: snwice_mass_b !: mass of snow and ice at previous ice time step [Kg/m2] 108 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: snwice_fmass !: time evolution of mass of snow+ice [Kg/m2/s] 121 109 122 110 !!---------------------------------------------------------------------- … … 131 119 !! *** FUNCTION sbc_ice_alloc *** 132 120 !!---------------------------------------------------------------------- 133 INTEGER :: ierr( 5)121 INTEGER :: ierr(4) 134 122 !!---------------------------------------------------------------------- 135 123 ierr(:) = 0 136 124 137 #if defined key_lim3 || defined key_lim2 125 ALLOCATE( snwice_mass(jpi,jpj) , snwice_mass_b(jpi,jpj), snwice_fmass(jpi,jpj) , STAT=ierr(1) ) 126 127 #if defined key_lim3 138 128 ALLOCATE( qns_ice (jpi,jpj,jpl) , qsr_ice (jpi,jpj,jpl) , & 139 129 & qla_ice (jpi,jpj,jpl) , dqla_ice(jpi,jpj,jpl) , & 140 & dqns_ice(jpi,jpj,jpl) , tn_ice (jpi,jpj,jpl) , alb_ice (jpi,jpj,jpl) , & 130 & dqns_ice(jpi,jpj,jpl) , tn_ice (jpi,jpj,jpl) , alb_ice (jpi,jpj,jpl) , & 131 & qml_ice(jpi,jpj,jpl) , qcn_ice(jpi,jpj,jpl) , qsr_ice_tr(jpi,jpj,jpl), & 141 132 & utau_ice(jpi,jpj) , vtau_ice(jpi,jpj) , wndm_ice(jpi,jpj) , & 142 & fr1_i0 (jpi,jpj) , fr2_i0 (jpi,jpj) , &143 #if defined key_lim2144 & a_i(jpi,jpj,jpl) , &145 #endif146 #if defined key_lim3147 133 & evap_ice(jpi,jpj,jpl) , devap_ice(jpi,jpj,jpl) , qprec_ice(jpi,jpj) , & 148 134 & qemp_ice(jpi,jpj) , qevap_ice(jpi,jpj,jpl) , qemp_oce (jpi,jpj) , & 149 135 & qns_oce (jpi,jpj) , qsr_oce (jpi,jpj) , emp_oce (jpi,jpj) , & 150 #endif 151 & emp_ice(jpi,jpj) , STAT= ierr(1) )136 & emp_ice(jpi,jpj) , tsfc_ice(jpi,jpj,jpl) , sstfrz(jpi,jpj), & 137 STAT= ierr(2) ) 152 138 #endif 153 139 … … 158 144 ss_iov(jpi,jpj) , fr_iu(jpi,jpj) , fr_iv(jpi,jpj) , & 159 145 a_i(jpi,jpj,ncat) , topmelt(jpi,jpj,ncat) , botmelt(jpi,jpj,ncat) , & 160 STAT= ierr( 1) )161 IF( ln_cpl ) ALLOCATE( u_ice(jpi,jpj) , fr1_i0(jpi,jpj) ,tn_ice (jpi,jpj,1) , &162 & v_ice(jpi,jpj) , fr2_i0(jpi,jpj) ,alb_ice(jpi,jpj,1) , &146 STAT= ierr(2) ) 147 IF( ln_cpl ) ALLOCATE( u_ice(jpi,jpj) , tn_ice (jpi,jpj,1) , & 148 & v_ice(jpi,jpj) , alb_ice(jpi,jpj,1) , & 163 149 & emp_ice(jpi,jpj) , qns_ice(jpi,jpj,1) , dqns_ice(jpi,jpj,1) , & 164 & STAT= ierr(2) ) 165 166 #endif 167 ! 168 #if defined key_cice || defined key_lim2 169 IF( ln_cpl ) ALLOCATE( ht_i(jpi,jpj,jpl) , ht_s(jpi,jpj,jpl) , STAT=ierr(5) ) 150 & STAT= ierr(3) ) 151 IF( ln_cpl ) ALLOCATE( h_i(jpi,jpj,jpl) , h_s(jpi,jpj,jpl) , STAT=ierr(4) ) 170 152 #endif 171 153 … … 177 159 #else 178 160 !!---------------------------------------------------------------------- 179 !! Default option NO LIM 2.0 or 3.0 or CICE sea-ice model 180 !!---------------------------------------------------------------------- 161 !! Default option NO LIM3 or CICE sea-ice model 162 !!---------------------------------------------------------------------- 163 USE lib_mpp ! MPP library 181 164 USE in_out_manager ! I/O manager 182 LOGICAL , PUBLIC, PARAMETER :: lk_lim2 = .FALSE. !: no LIM-2 ice model 165 166 IMPLICIT NONE 167 PRIVATE 168 169 PUBLIC sbc_ice_alloc 170 183 171 LOGICAL , PUBLIC, PARAMETER :: lk_lim3 = .FALSE. !: no LIM-3 ice model 184 172 LOGICAL , PUBLIC, PARAMETER :: lk_cice = .FALSE. !: no CICE ice model … … 186 174 REAL , PUBLIC, PARAMETER :: cldf_ice = 0.81 !: cloud fraction over sea ice, summer CLIO value [-] 187 175 INTEGER , PUBLIC, PARAMETER :: jpl = 1 188 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: u_ice, v_ice ,fr1_i0,fr2_i0! jpi, jpj176 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: u_ice, v_ice ! jpi, jpj 189 177 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: tn_ice, alb_ice, qns_ice, dqns_ice ! (jpi,jpj,jpl) 190 178 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: a_i 191 179 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: emp_ice 192 180 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: qsr_ice 193 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: h t_i, ht_s181 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: h_i, h_s 194 182 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: topmelt, botmelt 183 ! 184 !! arrays relating to embedding ice in the ocean. These arrays need to be declared 185 !! even if no ice model is required. In the no ice model or traditional levitating 186 !! ice cases they contain only zeros 187 !! --------------------- 188 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: snwice_mass !: mass of snow and ice at current ice time step [Kg/m2] 189 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: snwice_mass_b !: mass of snow and ice at previous ice time step [Kg/m2] 190 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: snwice_fmass !: time evolution of mass of snow+ice [Kg/m2/s] 191 192 CONTAINS 193 INTEGER FUNCTION sbc_ice_alloc() 194 !!---------------------------------------------------------------------- 195 !! *** FUNCTION sbc_ice_alloc *** 196 !!---------------------------------------------------------------------- 197 INTEGER :: ierr(1) 198 !!---------------------------------------------------------------------- 199 ierr(:) = 0 200 ALLOCATE( snwice_mass(jpi,jpj) , snwice_mass_b(jpi,jpj), snwice_fmass(jpi,jpj) , STAT=ierr(1) ) 201 sbc_ice_alloc = MAXVAL( ierr ) 202 IF( lk_mpp ) CALL mpp_sum ( sbc_ice_alloc ) 203 IF( sbc_ice_alloc > 0 ) CALL ctl_warn('sbc_ice_alloc: allocation of arrays failed') 204 END FUNCTION sbc_ice_alloc 195 205 #endif 196 206 -
branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/NEMO/OPA_SRC/SBC/sbc_oce.F90
r8877 r8879 41 41 LOGICAL , PUBLIC :: ln_cpl !: ocean-atmosphere coupled formulation 42 42 LOGICAL , PUBLIC :: ln_mixcpl !: ocean-atmosphere forced-coupled mixed formulation 43 LOGICAL , PUBLIC :: ln_meto_cpl !: Met Office coupling formulation, with surface exchange carried out in atmosphere 43 44 LOGICAL , PUBLIC :: ln_dm2dc !: Daily mean to Diurnal Cycle short wave (qsr) 44 45 LOGICAL , PUBLIC :: ln_rnf !: runoffs / runoff mouths … … 47 48 LOGICAL , PUBLIC :: ln_apr_dyn !: Atmospheric pressure forcing used on dynamics (ocean & ice) 48 49 INTEGER , PUBLIC :: nn_ice !: flag for ice in the surface boundary condition (=0/1/2/3) 49 INTEGER , PUBLIC :: nn_ice_embd !: flag for levitating/embedding sea-ice in the ocean 50 ! !: =0 levitating ice (no mass exchange, concentration/dilution effect) 51 ! !: =1 levitating ice with mass and salt exchange but no presure effect 52 ! !: =2 embedded sea-ice (full salt and mass exchanges and pressure) 50 LOGICAL , PUBLIC :: ln_ice_embd !: flag for levitating/embedding sea-ice in the ocean 51 ! !: =F levitating ice with mass and salt exchange but no presure effect 52 ! !: =T embedded sea-ice (full salt and mass exchanges and pressure) 53 53 INTEGER , PUBLIC :: nn_components !: flag for sbc module (including sea-ice) coupling mode (see component definition below) 54 INTEGER , PUBLIC :: nn_limflx !: LIM3 Multi-category heat flux formulation55 ! !: =-1 Use of per-category fluxes56 ! !: = 0 Average per-category fluxes57 ! !: = 1 Average then redistribute per-category fluxes58 ! !: = 2 Redistribute a single flux over categories59 54 INTEGER , PUBLIC :: nn_fwb !: FreshWater Budget: 60 55 ! !: = 0 unchecked -
branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/NEMO/OPA_SRC/SBC/sbcblk.F90
r8877 r8879 17 17 !! ==> based on AeroBulk (http://aerobulk.sourceforge.net/) 18 18 !! 4.0 ! 2016-10 (G. Madec) introduce a sbc_blk_init routine 19 !! 4.0 ! 2016-10 (M. Vancoppenolle) Introduce Jules emulator (M. Vancoppenolle) 19 20 !!---------------------------------------------------------------------- 20 21 … … 40 41 USE lib_fortran ! to use key_nosignedzero 41 42 #if defined key_lim3 42 USE ice , ONLY : u_ice, v_ice, jpl, pfrld, a_i_b, at_i_b 43 USE limthd_dh ! for CALL lim_thd_snwblow 44 #elif defined key_lim2 45 USE ice_2 , ONLY : u_ice, v_ice 46 USE par_ice_2 ! LIM-2 parameters 43 USE ice , ONLY : u_ice, v_ice, jpl, a_i_b, at_i_b, tm_su 44 USE icethd_dh ! for CALL ice_thd_snwblow 45 USE icethd_zdf, ONLY: rn_cnd_s ! for blk_ice_qcn 47 46 #endif 48 47 USE sbcblk_algo_ncar ! => turb_ncar : NCAR - CORE (Large & Yeager, 2009) … … 64 63 PUBLIC sbc_blk_init ! called in sbcmod 65 64 PUBLIC sbc_blk ! called in sbcmod 66 #if defined key_lim2 || defined key_lim3 67 PUBLIC blk_ice_tau ! routine called in sbc_ice_lim module 68 PUBLIC blk_ice_flx ! routine called in sbc_ice_lim module 69 #endif 65 #if defined key_lim3 66 PUBLIC blk_ice_tau ! routine called in icestp module 67 PUBLIC blk_ice_flx ! routine called in icestp module 68 PUBLIC blk_ice_qcn ! routine called in icestp module 69 #endif 70 70 71 71 !!Lolo: should ultimately be moved in the module with all physical constants ? … … 96 96 REAL(wp), PARAMETER :: Ls = 2.839e6 ! latent heat of sublimation 97 97 REAL(wp), PARAMETER :: Stef = 5.67e-8 ! Stefan Boltzmann constant 98 REAL(wp), PARAMETER :: Cd_ice = 1.4e-3 ! iovi 1.63e-3 !transfer coefficient over ice98 REAL(wp), PARAMETER :: Cd_ice = 1.4e-3 ! transfer coefficient over ice 99 99 REAL(wp), PARAMETER :: albo = 0.066 ! ocean albedo assumed to be constant 100 100 ! … … 111 111 REAL(wp) :: rn_zqt ! z(q,t) : height of humidity and temperature measurements 112 112 REAL(wp) :: rn_zu ! z(u) : height of wind measurements 113 LOGICAL :: ln_Cd_L12 = .FALSE. ! Modify the drag ice-atm and oce-atm depending on ice concentration (from Lupkes et al. JGR2012) 113 LOGICAL :: ln_Cd_L12 = .FALSE. ! Modify the drag ice-atm depending on ice concentration (from Lupkes et al. JGR2012) 114 LOGICAL :: ln_Cd_L15 = .FALSE. ! Modify the drag ice-atm depending on ice concentration (from Lupkes et al. JGR2015) 114 115 ! 115 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: Cd_oce ! air-ocean drag (clem) 116 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: Cd_atm ! transfer coefficient for momentum (tau) 117 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: Ch_atm ! transfer coefficient for sensible heat (Q_sens) 118 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: Ce_atm ! tansfert coefficient for evaporation (Q_lat) 119 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: t_zu ! air temperature at wind speed height (needed by Lupkes 2015 bulk scheme) 120 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: q_zu ! air spec. hum. at wind speed height (needed by Lupkes 2015 bulk scheme) 121 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: cdn_oce, chn_oce, cen_oce ! needed by Lupkes 2015 bulk scheme 116 122 117 123 INTEGER :: nblk ! choice of the bulk algorithm … … 135 141 !! *** ROUTINE sbc_blk_alloc *** 136 142 !!------------------------------------------------------------------- 137 ALLOCATE( Cd_oce(jpi,jpj) , STAT=sbc_blk_alloc ) 143 ALLOCATE( Cd_atm (jpi,jpj), Ch_atm (jpi,jpj), Ce_atm (jpi,jpj), t_zu(jpi,jpj), q_zu(jpi,jpj), & 144 & cdn_oce(jpi,jpj), chn_oce(jpi,jpj), cen_oce(jpi,jpj), STAT=sbc_blk_alloc ) 138 145 ! 139 146 IF( lk_mpp ) CALL mpp_sum ( sbc_blk_alloc ) … … 167 174 & ln_NCAR, ln_COARE_3p0, ln_COARE_3p5, ln_ECMWF, & ! bulk algorithm 168 175 & cn_dir , ln_taudif, rn_zqt, rn_zu, & 169 & rn_pfac, rn_efac, rn_vfac, ln_Cd_L12 176 & rn_pfac, rn_efac, rn_vfac, ln_Cd_L12, ln_Cd_L15 170 177 !!--------------------------------------------------------------------- 171 178 ! … … 258 265 WRITE(numout,*) ' factor applied on ocean/ice velocity rn_vfac = ', rn_vfac 259 266 WRITE(numout,*) ' (form absolute (=0) to relative winds(=1))' 267 WRITE(numout,*) ' use ice-atm drag from Lupkes2012 ln_Cd_L12 = ', ln_Cd_L12 268 WRITE(numout,*) ' use ice-atm drag from Lupkes2015 ln_Cd_L15 = ', ln_Cd_L15 260 269 ! 261 270 WRITE(numout,*) … … 364 373 REAL(wp), DIMENSION(:,:), POINTER :: zqlw, zqsb ! long wave and sensible heat fluxes 365 374 REAL(wp), DIMENSION(:,:), POINTER :: zqla, zevap ! latent heat fluxes and evaporation 366 REAL(wp), DIMENSION(:,:), POINTER :: Cd ! transfer coefficient for momentum (tau)367 REAL(wp), DIMENSION(:,:), POINTER :: Ch ! transfer coefficient for sensible heat (Q_sens)368 REAL(wp), DIMENSION(:,:), POINTER :: Ce ! tansfert coefficient for evaporation (Q_lat)369 375 REAL(wp), DIMENSION(:,:), POINTER :: zst ! surface temperature in Kelvin 370 REAL(wp), DIMENSION(:,:), POINTER :: zt_zu ! air temperature at wind speed height371 REAL(wp), DIMENSION(:,:), POINTER :: zq_zu ! air spec. hum. at wind speed height372 376 REAL(wp), DIMENSION(:,:), POINTER :: zU_zu ! bulk wind speed at height zu [m/s] 373 377 REAL(wp), DIMENSION(:,:), POINTER :: ztpot ! potential temperature of air at z=rn_zqt [K] … … 378 382 ! 379 383 CALL wrk_alloc( jpi,jpj, zwnd_i, zwnd_j, zsq, zqlw, zqsb, zqla, zevap ) 380 CALL wrk_alloc( jpi,jpj, Cd, Ch, Ce, zst, zt_zu, zq_zu ) 381 CALL wrk_alloc( jpi,jpj, zU_zu, ztpot, zrhoa ) 384 CALL wrk_alloc( jpi,jpj, zst, zU_zu, ztpot, zrhoa ) 382 385 ! 383 386 … … 426 429 zqlw(:,:) = ( sf(jp_qlw)%fnow(:,:,1) - Stef * zst(:,:)*zst(:,:)*zst(:,:)*zst(:,:) ) * tmask(:,:,1) ! Long Wave 427 430 428 429 430 431 ! ----------------------------------------------------------------------------- ! 431 432 ! II Turbulent FLUXES ! … … 443 444 ! 444 445 CASE( np_NCAR ) ; CALL turb_ncar ( rn_zqt, rn_zu, zst, ztpot, zsq, sf(jp_humi)%fnow, wndm, & ! NCAR-COREv2 445 & Cd, Ch, Ce, zt_zu, zq_zu, zU_zu)446 & Cd_atm, Ch_atm, Ce_atm, t_zu, q_zu, zU_zu, cdn_oce, chn_oce, cen_oce ) 446 447 CASE( np_COARE_3p0 ) ; CALL turb_coare ( rn_zqt, rn_zu, zst, ztpot, zsq, sf(jp_humi)%fnow, wndm, & ! COARE v3.0 447 & Cd, Ch, Ce, zt_zu, zq_zu, zU_zu)448 & Cd_atm, Ch_atm, Ce_atm, t_zu, q_zu, zU_zu, cdn_oce, chn_oce, cen_oce ) 448 449 CASE( np_COARE_3p5 ) ; CALL turb_coare3p5( rn_zqt, rn_zu, zst, ztpot, zsq, sf(jp_humi)%fnow, wndm, & ! COARE v3.5 449 & Cd, Ch, Ce, zt_zu, zq_zu, zU_zu)450 & Cd_atm, Ch_atm, Ce_atm, t_zu, q_zu, zU_zu, cdn_oce, chn_oce, cen_oce ) 450 451 CASE( np_ECMWF ) ; CALL turb_ecmwf ( rn_zqt, rn_zu, zst, ztpot, zsq, sf(jp_humi)%fnow, wndm, & ! ECMWF 451 & Cd, Ch, Ce, zt_zu, zq_zu, zU_zu)452 & Cd_atm, Ch_atm, Ce_atm, t_zu, q_zu, zU_zu, cdn_oce, chn_oce, cen_oce ) 452 453 CASE DEFAULT 453 454 CALL ctl_stop( 'STOP', 'sbc_oce: non-existing bulk formula selected' ) … … 456 457 ! ! Compute true air density : 457 458 IF( ABS(rn_zu - rn_zqt) > 0.01 ) THEN ! At zu: (probably useless to remove zrho*grav*rn_zu from SLP...) 458 zrhoa(:,:) = rho_air( zt_zu(:,:) , zq_zu(:,:), sf(jp_slp)%fnow(:,:,1) )459 zrhoa(:,:) = rho_air( t_zu(:,:) , q_zu(:,:) , sf(jp_slp)%fnow(:,:,1) ) 459 460 ELSE ! At zt: 460 461 zrhoa(:,:) = rho_air( sf(jp_tair)%fnow(:,:,1), sf(jp_humi)%fnow(:,:,1), sf(jp_slp)%fnow(:,:,1) ) 461 462 END IF 462 463 463 Cd_oce(:,:) = Cd(:,:) ! record value of pure ocean-atm. drag (clem) 464 !! CALL iom_put( "Cd_oce", Cd_atm) ! output value of pure ocean-atm. transfer coef. 465 !! CALL iom_put( "Ch_oce", Ch_atm) ! output value of pure ocean-atm. transfer coef. 464 466 465 467 DO jj = 1, jpj ! tau module, i and j component 466 468 DO ji = 1, jpi 467 zztmp = zrhoa(ji,jj) * zU_zu(ji,jj) * Cd (ji,jj) ! using bulk wind speed469 zztmp = zrhoa(ji,jj) * zU_zu(ji,jj) * Cd_atm(ji,jj) ! using bulk wind speed 468 470 taum (ji,jj) = zztmp * wndm (ji,jj) 469 471 zwnd_i(ji,jj) = zztmp * zwnd_i(ji,jj) … … 500 502 IF( ABS( rn_zu - rn_zqt) < 0.01_wp ) THEN 501 503 !! q_air and t_air are given at 10m (wind reference height) 502 zevap(:,:) = rn_efac*MAX( 0._wp, zqla(:,:)*Ce (:,:)*(zsq(:,:) - sf(jp_humi)%fnow(:,:,1)) ) ! Evaporation, using bulk wind speed503 zqsb (:,:) = cp_air(sf(jp_humi)%fnow(:,:,1))*zqla(:,:)*Ch (:,:)*(zst(:,:) - ztpot(:,:) ) ! Sensible Heat, using bulk wind speed504 zevap(:,:) = rn_efac*MAX( 0._wp, zqla(:,:)*Ce_atm(:,:)*(zsq(:,:) - sf(jp_humi)%fnow(:,:,1)) ) ! Evaporation, using bulk wind speed 505 zqsb (:,:) = cp_air(sf(jp_humi)%fnow(:,:,1))*zqla(:,:)*Ch_atm(:,:)*(zst(:,:) - ztpot(:,:) ) ! Sensible Heat, using bulk wind speed 504 506 ELSE 505 507 !! q_air and t_air are not given at 10m (wind reference height) 506 508 ! Values of temp. and hum. adjusted to height of wind during bulk algorithm iteration must be used!!! 507 zevap(:,:) = rn_efac*MAX( 0._wp, zqla(:,:)*Ce (:,:)*(zsq(:,:) - zq_zu(:,:) ) ) ! Evaporation !using bulk wind speed508 zqsb (:,:) = cp_air(sf(jp_humi)%fnow(:,:,1))*zqla(:,:)*Ch (:,:)*(zst(:,:) - zt_zu(:,:) ) ! Sensible Heat !using bulk wind speed509 zevap(:,:) = rn_efac*MAX( 0._wp, zqla(:,:)*Ce_atm(:,:)*(zsq(:,:) - q_zu(:,:) ) ) ! Evaporation, using bulk wind speed 510 zqsb (:,:) = cp_air(sf(jp_humi)%fnow(:,:,1))*zqla(:,:)*Ch_atm(:,:)*(zst(:,:) - t_zu(:,:) ) ! Sensible Heat, using bulk wind speed 509 511 ENDIF 510 512 … … 513 515 514 516 IF(ln_ctl) THEN 515 CALL prt_ctl( tab2d_1=zqla , clinfo1=' blk_oce: zqla : ', tab2d_2=Ce , clinfo2=' Ce : ' )516 CALL prt_ctl( tab2d_1=zqsb , clinfo1=' blk_oce: zqsb : ', tab2d_2=Ch , clinfo2=' Ch: ' )517 CALL prt_ctl( tab2d_1=zqla , clinfo1=' blk_oce: zqla : ', tab2d_2=Ce_atm , clinfo2=' Ce_oce : ' ) 518 CALL prt_ctl( tab2d_1=zqsb , clinfo1=' blk_oce: zqsb : ', tab2d_2=Ch_atm , clinfo2=' Ch_oce : ' ) 517 519 CALL prt_ctl( tab2d_1=zqlw , clinfo1=' blk_oce: zqlw : ', tab2d_2=qsr, clinfo2=' qsr : ' ) 518 520 CALL prt_ctl( tab2d_1=zsq , clinfo1=' blk_oce: zsq : ', tab2d_2=zst, clinfo2=' zst : ' ) … … 566 568 ! 567 569 CALL wrk_dealloc( jpi,jpj, zwnd_i, zwnd_j, zsq, zqlw, zqsb, zqla, zevap ) 568 CALL wrk_dealloc( jpi,jpj, Cd, Ch, Ce, zst, zt_zu, zq_zu ) 569 CALL wrk_dealloc( jpi,jpj, zU_zu, ztpot, zrhoa ) 570 CALL wrk_dealloc( jpi,jpj, zst, zU_zu, ztpot, zrhoa ) 570 571 ! 571 572 IF( nn_timing == 1 ) CALL timing_stop('blk_oce') … … 573 574 END SUBROUTINE blk_oce 574 575 575 #if defined key_lim 2 || defined key_lim3576 #if defined key_lim3 576 577 577 578 SUBROUTINE blk_ice_tau … … 591 592 REAL(wp) :: zwnorm_f, zwndi_f , zwndj_f ! relative wind module and components at F-point 592 593 REAL(wp) :: zwndi_t , zwndj_t ! relative wind components at T-point 593 REAL(wp), DIMENSION(:,:), POINTER :: Cd ! transfer coefficient for momentum (tau)594 594 !!--------------------------------------------------------------------- 595 595 ! … … 597 597 ! 598 598 CALL wrk_alloc( jpi,jpj, zrhoa ) 599 CALL wrk_alloc( jpi,jpj, Cd ) 600 601 Cd(:,:) = Cd_ice 602 603 ! Make ice-atm. drag dependent on ice concentration (see Lupkes et al. 2012) (clem) 604 #if defined key_lim3 605 IF( ln_Cd_L12 ) THEN 606 CALL Cdn10_Lupkes2012( Cd ) ! calculate new drag from Lupkes(2012) equations 599 600 ! set transfer coefficients to default sea-ice values 601 Cd_atm(:,:) = Cd_ice 602 Ch_atm(:,:) = Cd_ice 603 Ce_atm(:,:) = Cd_ice 604 605 wndm_ice(:,:) = 0._wp !!gm brutal.... 606 607 ! ------------------------------------------------------------ ! 608 ! Wind module relative to the moving ice ( U10m - U_ice ) ! 609 ! ------------------------------------------------------------ ! 610 SELECT CASE( cp_ice_msh ) 611 CASE( 'I' ) ! B-grid ice dynamics : I-point (i.e. F-point with sea-ice indexation) 612 ! and scalar wind at T-point ( = | U10m - U_ice | ) (masked) 613 DO jj = 2, jpjm1 614 DO ji = 2, jpim1 ! B grid : NO vector opt 615 ! ... scalar wind at T-point (fld being at T-point) 616 zwndi_t = sf(jp_wndi)%fnow(ji,jj,1) - rn_vfac * 0.25 * ( u_ice(ji,jj+1) + u_ice(ji+1,jj+1) & 617 & + u_ice(ji,jj ) + u_ice(ji+1,jj ) ) 618 zwndj_t = sf(jp_wndj)%fnow(ji,jj,1) - rn_vfac * 0.25 * ( v_ice(ji,jj+1) + v_ice(ji+1,jj+1) & 619 & + v_ice(ji,jj ) + v_ice(ji+1,jj ) ) 620 wndm_ice(ji,jj) = SQRT( zwndi_t * zwndi_t + zwndj_t * zwndj_t ) * tmask(ji,jj,1) 621 END DO 622 END DO 623 CALL lbc_lnk( wndm_ice, 'T', 1. ) 624 ! 625 CASE( 'C' ) ! C-grid ice dynamics : U & V-points (same as ocean) 626 DO jj = 2, jpjm1 627 DO ji = fs_2, fs_jpim1 ! vect. opt. 628 zwndi_t = ( sf(jp_wndi)%fnow(ji,jj,1) - rn_vfac * 0.5 * ( u_ice(ji-1,jj ) + u_ice(ji,jj) ) ) 629 zwndj_t = ( sf(jp_wndj)%fnow(ji,jj,1) - rn_vfac * 0.5 * ( v_ice(ji ,jj-1) + v_ice(ji,jj) ) ) 630 wndm_ice(ji,jj) = SQRT( zwndi_t * zwndi_t + zwndj_t * zwndj_t ) * tmask(ji,jj,1) 631 END DO 632 END DO 633 CALL lbc_lnk( wndm_ice, 'T', 1. ) 634 ! 635 END SELECT 636 637 ! Make ice-atm. drag dependent on ice concentration 638 IF ( ln_Cd_L12 ) THEN ! calculate new drag from Lupkes(2012) equations 639 CALL Cdn10_Lupkes2012( Cd_atm ) 640 Ch_atm(:,:) = Cd_atm(:,:) ! momentum and heat transfer coef. are considered identical 641 ELSEIF( ln_Cd_L15 ) THEN ! calculate new drag from Lupkes(2015) equations 642 CALL Cdn10_Lupkes2015( Cd_atm, Ch_atm ) 607 643 ENDIF 608 #endif 644 645 !! CALL iom_put( "Cd_ice", Cd_atm) ! output value of pure ice-atm. transfer coef. 646 !! CALL iom_put( "Ch_ice", Ch_atm) ! output value of pure ice-atm. transfer coef. 609 647 610 648 ! local scalars ( place there for vector optimisation purposes) 611 649 ! Computing density of air! Way denser that 1.2 over sea-ice !!! 612 !!613 650 zrhoa (:,:) = rho_air(sf(jp_tair)%fnow(:,:,1), sf(jp_humi)%fnow(:,:,1), sf(jp_slp)%fnow(:,:,1)) 614 651 … … 616 653 utau_ice (:,:) = 0._wp 617 654 vtau_ice (:,:) = 0._wp 618 wndm_ice (:,:) = 0._wp619 655 !!gm end 620 656 621 ! ------------------------------------------------------------ -----------------!622 ! Wind components and module relative to the moving ocean( U10m - U_ice ) !623 ! ------------------------------------------------------------ -----------------!657 ! ------------------------------------------------------------ ! 658 ! Wind stress relative to the moving ice ( U10m - U_ice ) ! 659 ! ------------------------------------------------------------ ! 624 660 SELECT CASE( cp_ice_msh ) 625 661 CASE( 'I' ) ! B-grid ice dynamics : I-point (i.e. F-point with sea-ice indexation) 626 ! and scalar wind at T-point ( = | U10m - U_ice | ) (masked)627 662 DO jj = 2, jpjm1 628 663 DO ji = 2, jpim1 ! B grid : NO vector opt … … 632 667 zwndj_f = 0.25 * ( sf(jp_wndj)%fnow(ji-1,jj ,1) + sf(jp_wndj)%fnow(ji ,jj ,1) & 633 668 & + sf(jp_wndj)%fnow(ji-1,jj-1,1) + sf(jp_wndj)%fnow(ji ,jj-1,1) ) - rn_vfac * v_ice(ji,jj) 634 zwnorm_f = zrhoa(ji,jj) * Cd(ji,jj) * SQRT( zwndi_f * zwndi_f + zwndj_f * zwndj_f )635 669 ! ... ice stress at I-point 670 zwnorm_f = zrhoa(ji,jj) * Cd_atm(ji,jj) * SQRT( zwndi_f * zwndi_f + zwndj_f * zwndj_f ) 636 671 utau_ice(ji,jj) = zwnorm_f * zwndi_f 637 672 vtau_ice(ji,jj) = zwnorm_f * zwndj_f 638 ! ... scalar wind at T-point (fld being at T-point)639 zwndi_t = sf(jp_wndi)%fnow(ji,jj,1) - rn_vfac * 0.25 * ( u_ice(ji,jj+1) + u_ice(ji+1,jj+1) &640 & + u_ice(ji,jj ) + u_ice(ji+1,jj ) )641 zwndj_t = sf(jp_wndj)%fnow(ji,jj,1) - rn_vfac * 0.25 * ( v_ice(ji,jj+1) + v_ice(ji+1,jj+1) &642 & + v_ice(ji,jj ) + v_ice(ji+1,jj ) )643 wndm_ice(ji,jj) = SQRT( zwndi_t * zwndi_t + zwndj_t * zwndj_t ) * tmask(ji,jj,1)644 673 END DO 645 674 END DO 646 675 CALL lbc_lnk( utau_ice, 'I', -1. ) 647 676 CALL lbc_lnk( vtau_ice, 'I', -1. ) 648 CALL lbc_lnk( wndm_ice, 'T', 1. )649 677 ! 650 678 CASE( 'C' ) ! C-grid ice dynamics : U & V-points (same as ocean) 651 DO jj = 2, jpj652 DO ji = fs_2, jpi ! vect. opt.653 zwndi_t = ( sf(jp_wndi)%fnow(ji,jj,1) - rn_vfac * 0.5 * ( u_ice(ji-1,jj ) + u_ice(ji,jj) ) )654 zwndj_t = ( sf(jp_wndj)%fnow(ji,jj,1) - rn_vfac * 0.5 * ( v_ice(ji ,jj-1) + v_ice(ji,jj) ) )655 wndm_ice(ji,jj) = SQRT( zwndi_t * zwndi_t + zwndj_t * zwndj_t ) * tmask(ji,jj,1)656 END DO657 END DO658 679 DO jj = 2, jpjm1 659 680 DO ji = fs_2, fs_jpim1 ! vect. opt. 660 utau_ice(ji,jj) = 0.5 * zrhoa(ji,jj) * Cd (ji,jj) * ( wndm_ice(ji+1,jj ) + wndm_ice(ji,jj) )&681 utau_ice(ji,jj) = 0.5 * zrhoa(ji,jj) * Cd_atm(ji,jj) * ( wndm_ice(ji+1,jj ) + wndm_ice(ji,jj) ) & 661 682 & * ( 0.5 * (sf(jp_wndi)%fnow(ji+1,jj,1) + sf(jp_wndi)%fnow(ji,jj,1) ) - rn_vfac * u_ice(ji,jj) ) 662 vtau_ice(ji,jj) = 0.5 * zrhoa(ji,jj) * Cd (ji,jj) * ( wndm_ice(ji,jj+1 ) + wndm_ice(ji,jj) )&683 vtau_ice(ji,jj) = 0.5 * zrhoa(ji,jj) * Cd_atm(ji,jj) * ( wndm_ice(ji,jj+1 ) + wndm_ice(ji,jj) ) & 663 684 & * ( 0.5 * (sf(jp_wndj)%fnow(ji,jj+1,1) + sf(jp_wndj)%fnow(ji,jj,1) ) - rn_vfac * v_ice(ji,jj) ) 664 685 END DO … … 666 687 CALL lbc_lnk( utau_ice, 'U', -1. ) 667 688 CALL lbc_lnk( vtau_ice, 'V', -1. ) 668 CALL lbc_lnk( wndm_ice, 'T', 1. )669 689 ! 670 690 END SELECT … … 680 700 681 701 682 SUBROUTINE blk_ice_flx( ptsu, p alb )702 SUBROUTINE blk_ice_flx( ptsu, phs, phi, palb ) 683 703 !!--------------------------------------------------------------------- 684 704 !! *** ROUTINE blk_ice_flx *** … … 693 713 !!--------------------------------------------------------------------- 694 714 REAL(wp), DIMENSION(:,:,:), INTENT(in) :: ptsu ! sea ice surface temperature 715 REAL(wp), DIMENSION(:,:,:), INTENT(in) :: phs ! snow thickness 716 REAL(wp), DIMENSION(:,:,:), INTENT(in) :: phi ! ice thickness 695 717 REAL(wp), DIMENSION(:,:,:), INTENT(in) :: palb ! ice albedo (all skies) 696 718 !! … … 699 721 REAL(wp) :: zcoef_dqlw, zcoef_dqla ! - - 700 722 REAL(wp) :: zztmp, z1_lsub ! - - 723 REAL(wp) :: zfrqsr_tr_i ! sea ice shortwave fraction transmitted below through the ice 724 REAL(wp) :: zfr1, zfr2, zfac ! local variables 701 725 REAL(wp), DIMENSION(:,:,:), POINTER :: z_qlw ! long wave heat flux over ice 702 726 REAL(wp), DIMENSION(:,:,:), POINTER :: z_qsb ! sensible heat flux over ice … … 705 729 REAL(wp), DIMENSION(:,:) , POINTER :: zevap, zsnw ! evaporation and snw distribution after wind blowing (LIM3) 706 730 REAL(wp), DIMENSION(:,:) , POINTER :: zrhoa 707 REAL(wp), DIMENSION(:,:) , POINTER :: Cd ! transfer coefficient for momentum (tau) 731 708 732 !!--------------------------------------------------------------------- 709 733 ! … … 711 735 ! 712 736 CALL wrk_alloc( jpi,jpj,jpl, z_qlw, z_qsb, z_dqlw, z_dqsb ) 713 CALL wrk_alloc( jpi,jpj, zrhoa) 714 CALL wrk_alloc( jpi,jpj, Cd ) 715 716 Cd(:,:) = Cd_ice 717 718 ! Make ice-atm. drag dependent on ice concentration (see Lupkes et al. 2012) (clem) 719 #if defined key_lim3 720 IF( ln_Cd_L12 ) THEN 721 CALL Cdn10_Lupkes2012( Cd ) ! calculate new drag from Lupkes(2012) equations 722 ENDIF 723 #endif 724 725 ! 726 ! local scalars ( place there for vector optimisation purposes) 737 CALL wrk_alloc( jpi,jpj, zrhoa ) 738 ! 739 ! local scalars 727 740 zcoef_dqlw = 4.0 * 0.95 * Stef 728 741 zcoef_dqla = -Ls * 11637800. * (-5897.8) … … 752 765 ! ----------------------------! 753 766 754 ! ... turbulent heat fluxes 767 ! ... turbulent heat fluxes with Ch_atm recalculated in blk_ice_tau 755 768 ! Sensible Heat 756 z_qsb(ji,jj,jl) = zrhoa(ji,jj) * cpa * C d(ji,jj) * wndm_ice(ji,jj) * ( ptsu(ji,jj,jl) - sf(jp_tair)%fnow(ji,jj,1))769 z_qsb(ji,jj,jl) = zrhoa(ji,jj) * cpa * Ch_atm(ji,jj) * wndm_ice(ji,jj) * (ptsu(ji,jj,jl) - sf(jp_tair)%fnow(ji,jj,1)) 757 770 ! Latent Heat 758 qla_ice(ji,jj,jl) = rn_efac * MAX( 0.e0, zrhoa(ji,jj) * Ls * C d(ji,jj) * wndm_ice(ji,jj)&759 & * ( 11637800. * EXP( -5897.8 / ptsu(ji,jj,jl) ) / zrhoa(ji,jj) - sf(jp_humi)%fnow(ji,jj,1)) )771 qla_ice(ji,jj,jl) = rn_efac * MAX( 0.e0, zrhoa(ji,jj) * Ls * Ch_atm(ji,jj) * wndm_ice(ji,jj) * & 772 & ( 11637800. * EXP( -5897.8 / ptsu(ji,jj,jl) ) / zrhoa(ji,jj) - sf(jp_humi)%fnow(ji,jj,1) ) ) 760 773 ! Latent heat sensitivity for ice (Dqla/Dt) 761 774 IF( qla_ice(ji,jj,jl) > 0._wp ) THEN 762 dqla_ice(ji,jj,jl) = rn_efac * zcoef_dqla * C d(ji,jj) * wndm_ice(ji,jj) / ( zst2 ) * EXP( -5897.8 / ptsu(ji,jj,jl))775 dqla_ice(ji,jj,jl) = rn_efac * zcoef_dqla * Ch_atm(ji,jj) * wndm_ice(ji,jj) / zst2 * EXP(-5897.8 / ptsu(ji,jj,jl)) 763 776 ELSE 764 777 dqla_ice(ji,jj,jl) = 0._wp … … 766 779 767 780 ! Sensible heat sensitivity (Dqsb_ice/Dtn_ice) 768 z_dqsb(ji,jj,jl) = zrhoa(ji,jj) * cpa * C d(ji,jj) * wndm_ice(ji,jj)781 z_dqsb(ji,jj,jl) = zrhoa(ji,jj) * cpa * Ch_atm(ji,jj) * wndm_ice(ji,jj) 769 782 770 783 ! ----------------------------! … … 786 799 CALL iom_put( 'precip' , tprecip * 86400. ) ! Total precipitation 787 800 788 #if defined key_lim3789 801 CALL wrk_alloc( jpi,jpj, zevap, zsnw ) 790 802 … … 797 809 ! --- evaporation minus precipitation --- ! 798 810 zsnw(:,:) = 0._wp 799 CALL lim_thd_snwblow( pfrld, zsnw ) ! snow distribution over ice after wind blowing800 emp_oce(:,:) = pfrld(:,:) * zevap(:,:) - ( tprecip(:,:) - sprecip(:,:) ) - sprecip(:,:) * (1._wp - zsnw )811 CALL ice_thd_snwblow( (1.-at_i_b(:,:)), zsnw ) ! snow distribution over ice after wind blowing 812 emp_oce(:,:) = ( 1._wp - at_i_b(:,:) ) * zevap(:,:) - ( tprecip(:,:) - sprecip(:,:) ) - sprecip(:,:) * (1._wp - zsnw ) 801 813 emp_ice(:,:) = SUM( a_i_b(:,:,:) * evap_ice(:,:,:), dim=3 ) - sprecip(:,:) * zsnw 802 814 emp_tot(:,:) = emp_oce(:,:) + emp_ice(:,:) 803 815 804 816 ! --- heat flux associated with emp --- ! 805 qemp_oce(:,:) = - pfrld(:,:) * zevap(:,:) * sst_m(:,:) * rcp& ! evap at sst817 qemp_oce(:,:) = - ( 1._wp - at_i_b(:,:) ) * zevap(:,:) * sst_m(:,:) * rcp & ! evap at sst 806 818 & + ( tprecip(:,:) - sprecip(:,:) ) * ( sf(jp_tair)%fnow(:,:,1) - rt0 ) * rcp & ! liquid precip at Tair 807 819 & + sprecip(:,:) * ( 1._wp - zsnw ) * & ! solid precip at min(Tair,Tsnow) … … 811 823 812 824 ! --- total solar and non solar fluxes --- ! 813 qns_tot(:,:) = pfrld(:,:) * qns_oce(:,:) + SUM( a_i_b(:,:,:) * qns_ice(:,:,:), dim=3 ) + qemp_ice(:,:) + qemp_oce(:,:) 814 qsr_tot(:,:) = pfrld(:,:) * qsr_oce(:,:) + SUM( a_i_b(:,:,:) * qsr_ice(:,:,:), dim=3 ) 825 qns_tot(:,:) = ( 1._wp - at_i_b(:,:) ) * qns_oce(:,:) + SUM( a_i_b(:,:,:) * qns_ice(:,:,:), dim=3 ) & 826 & + qemp_ice(:,:) + qemp_oce(:,:) 827 qsr_tot(:,:) = ( 1._wp - at_i_b(:,:) ) * qsr_oce(:,:) + SUM( a_i_b(:,:,:) * qsr_ice(:,:,:), dim=3 ) 815 828 816 829 ! --- heat content of precip over ice in J/m3 (to be used in 1D-thermo) --- ! … … 824 837 825 838 CALL wrk_dealloc( jpi,jpj, zevap, zsnw ) 826 #endif 827 828 !-------------------------------------------------------------------- 829 ! FRACTIONs of net shortwave radiation which is not absorbed in the 830 ! thin surface layer and penetrates inside the ice cover 831 ! ( Maykut and Untersteiner, 1971 ; Ebert and Curry, 1993 ) 832 ! 833 fr1_i0(:,:) = ( 0.18 * ( 1.0 - cldf_ice ) + 0.35 * cldf_ice ) 834 fr2_i0(:,:) = ( 0.82 * ( 1.0 - cldf_ice ) + 0.65 * cldf_ice ) 835 ! 836 ! 839 840 ! --- absorbed and transmitted shortwave radiation (W/m2) --- ! 841 ! 842 ! former coding was 843 ! fr1_i0(:,:) = ( 0.18 * ( 1.0 - cldf_ice ) + 0.35 * cldf_ice ) 844 ! fr2_i0(:,:) = ( 0.82 * ( 1.0 - cldf_ice ) + 0.65 * cldf_ice ) 845 846 ! --- surface transmission parameter (i0, Grenfell Maykut 77) --- ! 847 zfr1 = ( 0.18 * ( 1.0 - cldf_ice ) + 0.35 * cldf_ice ) ! standard value 848 zfr2 = ( 0.82 * ( 1.0 - cldf_ice ) + 0.65 * cldf_ice ) ! zfr2 such that zfr1 + zfr2 to equal 1 849 850 qsr_ice_tr(:,:,:) = 0._wp 851 852 DO jl = 1, jpl 853 DO jj = 1, jpj 854 DO ji = 1, jpi 855 856 zfac = MAX( 0._wp , 1._wp - phi(ji,jj,jl) * 10._wp ) ! linear weighting factor: =0 for phi=0, =1 for phi = 0.1 857 zfrqsr_tr_i = zfr1 + zfac * zfr2 ! below 10 cm, linearly increase zfrqsr_tr_i until 1 at zero thickness 858 859 IF ( phs(ji,jj,jl) <= 0.0_wp ) THEN 860 zfrqsr_tr_i = zfr1 + zfac * zfr2 861 ELSE 862 zfrqsr_tr_i = 0._wp ! snow fully opaque 863 ENDIF 864 865 qsr_ice_tr(ji,jj,jl) = zfrqsr_tr_i * qsr_ice(ji,jj,jl) ! transmitted solar radiation 866 867 END DO 868 END DO 869 END DO 870 871 837 872 IF(ln_ctl) THEN 838 873 CALL prt_ctl(tab3d_1=qla_ice , clinfo1=' blk_ice: qla_ice : ', tab3d_2=z_qsb , clinfo2=' z_qsb : ', kdim=jpl) … … 846 881 CALL wrk_dealloc( jpi,jpj,jpl, z_qlw, z_qsb, z_dqlw, z_dqsb ) 847 882 CALL wrk_dealloc( jpi,jpj, zrhoa ) 848 CALL wrk_dealloc( jpi,jpj, Cd )849 883 ! 850 884 IF( nn_timing == 1 ) CALL timing_stop('blk_ice_flx') 851 885 852 886 END SUBROUTINE blk_ice_flx 887 888 889 890 SUBROUTINE blk_ice_qcn( k_monocat, ptsu, ptb, phs, phi ) 891 892 !!--------------------------------------------------------------------- 893 !! *** ROUTINE blk_ice_qcn *** 894 !! 895 !! ** Purpose : Compute surface temperature and snow/ice conduction flux 896 !! to force sea ice / snow thermodynamics 897 !! in the case JULES coupler is emulated 898 !! 899 !! ** Method : compute surface energy balance assuming neglecting heat storage 900 !! following the 0-layer Semtner (1976) approach 901 !! 902 !! ** Outputs : - ptsu : sea-ice / snow surface temperature (K) 903 !! - qcn_ice : surface inner conduction flux (W/m2) 904 !! 905 !!--------------------------------------------------------------------- 906 !! 907 INTEGER, INTENT(in) :: k_monocat ! single-category option 908 909 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: ptsu ! sea ice / snow surface temperature 910 911 REAL(wp), DIMENSION(:,:) , INTENT(in) :: ptb ! sea ice base temperature 912 REAL(wp), DIMENSION(:,:,:), INTENT(in) :: phs ! snow thickness 913 REAL(wp), DIMENSION(:,:,:), INTENT(in) :: phi ! sea ice thickness 914 915 INTEGER :: ji, jj, jl ! dummy loop indices 916 INTEGER :: iter ! 917 REAL(wp) :: zfac, zfac2, zfac3 ! dummy factors 918 REAL(wp) :: zkeff_h, ztsu ! 919 REAL(wp) :: zqc, zqnet ! 920 REAL(wp) :: zhe, zqa0 ! 921 922 INTEGER , PARAMETER :: nit = 10 ! number of iterations 923 REAL(wp), PARAMETER :: zepsilon = 0.1_wp ! characteristic thickness for enhanced conduction 924 925 REAL(wp), DIMENSION(:,:,:), POINTER :: zgfac ! enhanced conduction factor 926 927 !!--------------------------------------------------------------------- 928 929 IF( nn_timing == 1 ) CALL timing_start('blk_ice_qcn') 930 ! 931 CALL wrk_alloc( jpi,jpj,jpl, zgfac ) 932 933 ! -------------------------------------! 934 ! I Enhanced conduction factor ! 935 ! -------------------------------------! 936 ! 937 ! Emulates the enhancement of conduction by unresolved thin ice (k_monocat = 1/3) 938 ! Fichefet and Morales Maqueda, JGR 1997 939 ! 940 zgfac(:,:,:) = 1._wp 941 942 SELECT CASE ( k_monocat ) 943 944 CASE ( 1 , 3 ) 945 946 zfac = 1._wp / ( rn_cnd_s + rcdic ) 947 zfac2 = EXP(1._wp) * 0.5_wp * zepsilon 948 zfac3 = 2._wp / zepsilon 949 950 DO jl = 1, jpl 951 DO jj = 1 , jpj 952 DO ji = 1, jpi 953 ! ! Effective thickness 954 zhe = ( rn_cnd_s * phi(ji,jj,jl) + rcdic * phs(ji,jj,jl) ) * zfac 955 ! ! Enhanced conduction factor 956 IF( zhe >= zfac2 ) & 957 zgfac(ji,jj,jl) = MIN( 2._wp, ( 0.5_wp + 0.5 * LOG( zhe * zfac3 ) ) ) 958 END DO 959 END DO 960 END DO 961 962 END SELECT 963 964 ! -------------------------------------------------------------! 965 ! II Surface temperature and conduction flux ! 966 ! -------------------------------------------------------------! 967 968 zfac = rcdic * rn_cnd_s 969 ! ========================== ! 970 DO jl = 1, jpl ! Loop over ice categories ! 971 ! ! ========================== ! 972 DO jj = 1 , jpj 973 DO ji = 1, jpi 974 ! ! Effective conductivity of the snow-ice system divided by thickness 975 zkeff_h = zfac * zgfac(ji,jj,jl) / ( rcdic * phs(ji,jj,jl) + rn_cnd_s * phi(ji,jj,jl) ) 976 ! Store initial surface temperature 977 ztsu = ptsu(ji,jj,jl) 978 ! Net initial atmospheric heat flux 979 zqa0 = qsr_ice(ji,jj,jl) - qsr_ice_tr(ji,jj,jl) + qns_ice(ji,jj,jl) 980 981 DO iter = 1, nit ! --- Iteration loop 982 983 ! ! Conduction heat flux through snow-ice system (>0 downwards) 984 zqc = zkeff_h * ( ztsu - ptb(ji,jj) ) 985 ! ! Surface energy budget 986 zqnet = zqa0 + dqns_ice(ji,jj,jl) * ( ztsu - ptsu(ji,jj,jl) ) - zqc 987 ! ! Temperature update 988 ztsu = ztsu - zqnet / ( dqns_ice(ji,jj,jl) - zkeff_h ) 989 990 END DO 991 992 ptsu(ji,jj,jl) = MIN( rt0, ztsu ) 993 994 qcn_ice(ji,jj,jl) = zkeff_h * ( ptsu(ji,jj,jl) - ptb(ji,jj) ) 995 996 END DO 997 END DO 998 999 END DO 1000 1001 CALL wrk_dealloc( jpi,jpj,jpl, zgfac ) 1002 1003 IF( nn_timing == 1 ) CALL timing_stop('blk_ice_qcn') 1004 1005 END SUBROUTINE blk_ice_qcn 853 1006 854 1007 #endif … … 973 1126 974 1127 #if defined key_lim3 1128 975 1129 SUBROUTINE Cdn10_Lupkes2012( Cd ) 976 1130 !!---------------------------------------------------------------------- … … 1022 1176 1023 1177 END SUBROUTINE Cdn10_Lupkes2012 1178 1179 1180 SUBROUTINE Cdn10_Lupkes2015( Cd, Ch ) 1181 !!---------------------------------------------------------------------- 1182 !! *** ROUTINE Cdn10_Lupkes2015 *** 1183 !! 1184 !! ** pUrpose : 1lternative turbulent transfert coefficients formulation 1185 !! between sea-ice and atmosphere with distinct momentum 1186 !! and heat coefficients depending on sea-ice concentration 1187 !! and atmospheric stability (no meltponds effect for now). 1188 !! 1189 !! ** Method : The parameterization is adapted from Lupkes et al. (2015) 1190 !! and ECHAM6 atmospheric model. Compared to Lupkes2012 scheme, 1191 !! it considers specific skin and form drags (Andreas et al. 2010) 1192 !! to compute neutral transfert coefficients for both heat and 1193 !! momemtum fluxes. Atmospheric stability effect on transfert 1194 !! coefficient is also taken into account following Louis (1979). 1195 !! 1196 !! ** References : Lupkes et al. JGR 2015 (theory) 1197 !! Lupkes et al. ECHAM6 documentation 2015 (implementation) 1198 !! 1199 !!---------------------------------------------------------------------- 1200 ! 1201 REAL(wp), DIMENSION(:,:), INTENT(inout) :: Cd 1202 REAL(wp), DIMENSION(:,:), INTENT(inout) :: Ch 1203 REAL(wp), DIMENSION(jpi,jpj) :: zst, zqo_sat, zqi_sat 1204 ! 1205 ! ECHAM6 constants 1206 REAL(wp), PARAMETER :: z0_skin_ice = 0.69e-3_wp ! Eq. 43 [m] 1207 REAL(wp), PARAMETER :: z0_form_ice = 0.57e-3_wp ! Eq. 42 [m] 1208 REAL(wp), PARAMETER :: z0_ice = 1.00e-3_wp ! Eq. 15 [m] 1209 REAL(wp), PARAMETER :: zce10 = 2.80e-3_wp ! Eq. 41 1210 REAL(wp), PARAMETER :: zbeta = 1.1_wp ! Eq. 41 1211 REAL(wp), PARAMETER :: zc = 5._wp ! Eq. 13 1212 REAL(wp), PARAMETER :: zc2 = zc * zc 1213 REAL(wp), PARAMETER :: zam = 2. * zc ! Eq. 14 1214 REAL(wp), PARAMETER :: zah = 3. * zc ! Eq. 30 1215 REAL(wp), PARAMETER :: z1_alpha = 1._wp / 0.2_wp ! Eq. 51 1216 REAL(wp), PARAMETER :: z1_alphaf = z1_alpha ! Eq. 56 1217 REAL(wp), PARAMETER :: zbetah = 1.e-3_wp ! Eq. 26 1218 REAL(wp), PARAMETER :: zgamma = 1.25_wp ! Eq. 26 1219 REAL(wp), PARAMETER :: z1_gamma = 1._wp / zgamma 1220 REAL(wp), PARAMETER :: r1_3 = 1._wp / 3._wp 1221 ! 1222 INTEGER :: ji, jj ! dummy loop indices 1223 REAL(wp) :: zthetav_os, zthetav_is, zthetav_zu 1224 REAL(wp) :: zrib_o, zrib_i 1225 REAL(wp) :: zCdn_skin_ice, zCdn_form_ice, zCdn_ice 1226 REAL(wp) :: zChn_skin_ice, zChn_form_ice 1227 REAL(wp) :: z0w, z0i, zfmi, zfmw, zfhi, zfhw 1228 REAL(wp) :: zCdn_form_tmp 1229 !!---------------------------------------------------------------------- 1230 1231 ! Momentum Neutral Transfert Coefficients (should be a constant) 1232 zCdn_form_tmp = zce10 * ( LOG( 10._wp / z0_form_ice + 1._wp ) / LOG( rn_zu / z0_form_ice + 1._wp ) )**2 ! Eq. 40 1233 zCdn_skin_ice = ( vkarmn / LOG( rn_zu / z0_skin_ice + 1._wp ) )**2 ! Eq. 7 1234 zCdn_ice = zCdn_skin_ice ! Eq. 7 (cf Lupkes email for details) 1235 !zCdn_ice = 1.89e-3 ! old ECHAM5 value (cf Eq. 32) 1236 1237 ! Heat Neutral Transfert Coefficients 1238 zChn_skin_ice = vkarmn**2 / ( LOG( rn_zu / z0_ice + 1._wp ) * LOG( rn_zu * z1_alpha / z0_skin_ice + 1._wp ) ) ! Eq. 50 + Eq. 52 (cf Lupkes email for details) 1239 1240 ! Atmospheric and Surface Variables 1241 zst(:,:) = sst_m(:,:) + rt0 ! convert SST from Celcius to Kelvin 1242 zqo_sat(:,:) = 0.98_wp * q_sat( zst(:,:) , sf(jp_slp)%fnow(:,:,1) ) ! saturation humidity over ocean [kg/kg] 1243 zqi_sat(:,:) = 0.98_wp * q_sat( tm_su(:,:), sf(jp_slp)%fnow(:,:,1) ) ! saturation humidity over ice [kg/kg] 1244 ! 1245 DO jj = 2, jpjm1 ! reduced loop is necessary for reproducibility 1246 DO ji = fs_2, fs_jpim1 1247 ! Virtual potential temperature [K] 1248 zthetav_os = zst(ji,jj) * ( 1._wp + rctv0 * zqo_sat(ji,jj) ) ! over ocean 1249 zthetav_is = tm_su(ji,jj) * ( 1._wp + rctv0 * zqi_sat(ji,jj) ) ! ocean ice 1250 zthetav_zu = t_zu (ji,jj) * ( 1._wp + rctv0 * q_zu(ji,jj) ) ! at zu 1251 1252 ! Bulk Richardson Number (could use Ri_bulk function from aerobulk instead) 1253 zrib_o = grav / zthetav_os * ( zthetav_zu - zthetav_os ) * rn_zu / MAX( 0.5, wndm(ji,jj) )**2 ! over ocean 1254 zrib_i = grav / zthetav_is * ( zthetav_zu - zthetav_is ) * rn_zu / MAX( 0.5, wndm_ice(ji,jj) )**2 ! over ice 1255 1256 ! Momentum and Heat Neutral Transfert Coefficients 1257 zCdn_form_ice = zCdn_form_tmp * at_i_b(ji,jj) * ( 1._wp - at_i_b(ji,jj) )**zbeta ! Eq. 40 1258 zChn_form_ice = zCdn_form_ice / ( 1._wp + ( LOG( z1_alphaf ) / vkarmn ) * SQRT( zCdn_form_ice ) ) ! Eq. 53 1259 1260 ! Momentum and Heat Stability functions (possibility to use psi_m_ecmwf instead) 1261 z0w = rn_zu * EXP( -1._wp * vkarmn / SQRT( Cdn_oce(ji,jj) ) ) ! over water 1262 z0i = z0_skin_ice ! over ice (cf Lupkes email for details) 1263 IF( zrib_o <= 0._wp ) THEN 1264 zfmw = 1._wp - zam * zrib_o / ( 1._wp + 3._wp * zc2 * Cdn_oce(ji,jj) * SQRT( -zrib_o * ( rn_zu / z0w + 1._wp ) ) ) ! Eq. 10 1265 zfhw = ( 1._wp + ( zbetah * ( zthetav_os - zthetav_zu )**r1_3 / ( Chn_oce(ji,jj) * MAX(0.01, wndm(ji,jj)) ) & ! Eq. 26 1266 & )**zgamma )**z1_gamma 1267 ELSE 1268 zfmw = 1._wp / ( 1._wp + zam * zrib_o / SQRT( 1._wp + zrib_o ) ) ! Eq. 12 1269 zfhw = 1._wp / ( 1._wp + zah * zrib_o / SQRT( 1._wp + zrib_o ) ) ! Eq. 28 1270 ENDIF 1271 1272 IF( zrib_i <= 0._wp ) THEN 1273 zfmi = 1._wp - zam * zrib_i / (1._wp + 3._wp * zc2 * zCdn_ice * SQRT( -zrib_i * ( rn_zu / z0i + 1._wp))) ! Eq. 9 1274 zfhi = 1._wp - zah * zrib_i / (1._wp + 3._wp * zc2 * zCdn_ice * SQRT( -zrib_i * ( rn_zu / z0i + 1._wp))) ! Eq. 25 1275 ELSE 1276 zfmi = 1._wp / ( 1._wp + zam * zrib_i / SQRT( 1._wp + zrib_i ) ) ! Eq. 11 1277 zfhi = 1._wp / ( 1._wp + zah * zrib_i / SQRT( 1._wp + zrib_i ) ) ! Eq. 27 1278 ENDIF 1279 1280 ! Momentum Transfert Coefficients (Eq. 38) 1281 Cd(ji,jj) = zCdn_skin_ice * zfmi + & 1282 & zCdn_form_ice * ( zfmi * at_i_b(ji,jj) + zfmw * ( 1._wp - at_i_b(ji,jj) ) ) / MAX( 1.e-06, at_i_b(ji,jj) ) 1283 1284 ! Heat Transfert Coefficients (Eq. 49) 1285 Ch(ji,jj) = zChn_skin_ice * zfhi + & 1286 & zChn_form_ice * ( zfhi * at_i_b(ji,jj) + zfhw * ( 1._wp - at_i_b(ji,jj) ) ) / MAX( 1.e-06, at_i_b(ji,jj) ) 1287 ! 1288 END DO 1289 END DO 1290 CALL lbc_lnk_multi( Cd, 'T', 1., Ch, 'T', 1. ) 1291 ! 1292 END SUBROUTINE Cdn10_Lupkes2015 1293 1024 1294 #endif 1025 1026 1295 1027 1296 !!====================================================================== -
branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/NEMO/OPA_SRC/SBC/sbcblk_algo_coare.F90
r7646 r8879 52 52 !! COARE own values for given constants: 53 53 REAL(wp), PARAMETER :: & 54 & zi0 = 600., 54 & zi0 = 600., & !: scale height of the atmospheric boundary layer...1 55 55 & Beta0 = 1.25, & !: gustiness parameter 56 56 & rctv0 = 0.608 !: constant to obtain virtual temperature... … … 60 60 61 61 SUBROUTINE turb_coare( zt, zu, sst, t_zt, ssq, q_zt, U_zu, & 62 & Cd, Ch, Ce, t_zu, q_zu, U_blk ) 62 & Cd, Ch, Ce, t_zu, q_zu, U_blk, & 63 & Cdn, Chn, Cen ) 64 63 65 !!---------------------------------------------------------------------- 64 66 !! *** ROUTINE turb_coare *** … … 106 108 REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: q_zu ! spec. humidity adjusted at zu [kg/kg] 107 109 REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: U_blk ! bulk wind at 10m [m/s] 110 REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Cdn, Chn, Cen ! neutral transfer coefficients 108 111 ! 109 112 INTEGER :: j_itt … … 246 249 Ce = ztmp0*q_star/dq_zu 247 250 ! 251 ztmp1 = zu + z0 252 Cdn = vkarmn*vkarmn / (log(ztmp1/z0 )*log(ztmp1/z0 )) 253 Chn = vkarmn*vkarmn / (log(ztmp1/z0t)*log(ztmp1/z0t)) 254 Cen = Chn 255 ! 248 256 CALL wrk_dealloc( jpi,jpj, u_star, t_star, q_star, zeta_u, dt_zu, dq_zu ) 249 257 CALL wrk_dealloc( jpi,jpj, znu_a, z0, z0t, ztmp0, ztmp1, ztmp2 ) -
branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/NEMO/OPA_SRC/SBC/sbcblk_algo_coare3p5.F90
r7646 r8879 58 58 CONTAINS 59 59 60 SUBROUTINE turb_coare3p5( zt, zu, sst, t_zt, ssq, q_zt, U_zu, & 61 & Cd, Ch, Ce, t_zu, q_zu, U_blk ) 60 SUBROUTINE turb_coare3p5( zt, zu, sst, t_zt, ssq, q_zt, U_zu, & 61 & Cd, Ch, Ce, t_zu, q_zu, U_blk, & 62 & Cdn, Chn, Cen ) 63 62 64 !!---------------------------------------------------------------------------------- 63 65 !! *** ROUTINE turb_coare3p5 *** … … 105 107 REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: q_zu ! spec. humidity adjusted at zu [kg/kg] 106 108 REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: U_blk ! bulk wind at 10m [m/s] 109 REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Cdn, Chn, Cen ! neutral transfer coefficients 107 110 ! 108 111 INTEGER :: j_itt … … 252 255 Ce = ztmp0*q_star/dq_zu 253 256 ! 257 ztmp1 = zu + z0 258 Cdn = vkarmn*vkarmn / (log(ztmp1/z0 )*log(ztmp1/z0 )) 259 Chn = vkarmn*vkarmn / (log(ztmp1/z0t)*log(ztmp1/z0t)) 260 Cen = Chn 261 ! 254 262 CALL wrk_dealloc( jpi,jpj, u_star, t_star, q_star, zeta_u, dt_zu, dq_zu ) 255 263 CALL wrk_dealloc( jpi,jpj, znu_a, z0, z0t, ztmp0, ztmp1, ztmp2 ) -
branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/NEMO/OPA_SRC/SBC/sbcblk_algo_ecmwf.F90
r7646 r8879 64 64 65 65 SUBROUTINE TURB_ECMWF( zt, zu, sst, t_zt, ssq , q_zt , U_zu, & 66 & Cd, Ch, Ce , t_zu, q_zu, U_blk ) 66 & Cd, Ch, Ce , t_zu, q_zu, U_blk, & 67 & Cdn, Chn, Cen ) 67 68 !!---------------------------------------------------------------------------------- 68 69 !! *** ROUTINE turb_ecmwf *** … … 112 113 REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: q_zu ! spec. humidity adjusted at zu [kg/kg] 113 114 REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: U_blk ! bulk wind at 10m [m/s] 115 REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Cdn, Chn, Cen ! neutral transfer coefficients 114 116 ! 115 117 INTEGER :: j_itt … … 266 268 dt_zu = t_zu - sst ; dt_zu = SIGN( MAX(ABS(dt_zu),1.E-6), dt_zu ) 267 269 dq_zu = q_zu - ssq ; dq_zu = SIGN( MAX(ABS(dq_zu),1.E-9), dq_zu ) 270 268 271 END IF 269 272 … … 271 274 ztmp1 = zu + z0 272 275 ztmp0 = ztmp1*Linv 273 func_m = log(ztmp1) - LOG(z0 ) - psi_m_ecmwf(ztmp0) + psi_m_ecmwf(z0*Linv)276 func_m = log(ztmp1) - LOG(z0 ) - psi_m_ecmwf(ztmp0) + psi_m_ecmwf(z0 *Linv) 274 277 func_h = log(ztmp1) - LOG(z0t) - psi_h_ecmwf(ztmp0) + psi_h_ecmwf(z0t*Linv) 275 278 … … 280 283 ztmp1 = log((zu + z0)/z0q) - psi_h_ecmwf((zu + z0)*Linv) + psi_h_ecmwf(z0q*Linv) ! func_q 281 284 Ce = vkarmn*vkarmn/(func_m*ztmp1) 285 286 ztmp1 = zu + z0 287 Cdn = vkarmn*vkarmn / (log(ztmp1/z0 )*log(ztmp1/z0 )) 288 Chn = vkarmn*vkarmn / (log(ztmp1/z0t)*log(ztmp1/z0t)) 289 Cen = vkarmn*vkarmn / (log(ztmp1/z0q)*log(ztmp1/z0q)) 282 290 283 291 CALL wrk_dealloc( jpi,jpj, u_star, t_star, q_star, func_m, func_h, dt_zu, dq_zu, Linv ) -
branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/NEMO/OPA_SRC/SBC/sbcblk_algo_ncar.F90
r7753 r8879 48 48 ! ! NCAR own values for given constants: 49 49 REAL(wp), PARAMETER :: rctv0 = 0.608 ! constant to obtain virtual temperature... 50 51 50 !!---------------------------------------------------------------------- 52 51 CONTAINS 53 52 54 53 SUBROUTINE turb_ncar( zt, zu, sst, t_zt, ssq, q_zt, U_zu, & 55 & Cd, Ch, Ce, t_zu, q_zu, U_blk ) 54 & Cd, Ch, Ce, t_zu, q_zu, U_blk, & 55 & Cdn, Chn, Cen ) 56 56 57 !!---------------------------------------------------------------------------------- 57 58 !! *** ROUTINE turb_ncar *** … … 112 113 REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: q_zu ! spec. humidity adjusted at zu [kg/kg] 113 114 REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: U_blk ! bulk wind at 10m [m/s] 115 REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Cdn, Chn, Cen ! neutral transfer coefficients 114 116 ! 115 117 INTEGER :: j_itt … … 199 201 ztmp0 = MAX( 0.25 , U_blk/(1. + sqrt_Cd_n10/vkarmn*(LOG(zu/10.) - ztmp2)) ) ! U_n10 (ztmp2 == psi_m(zeta_u)) 200 202 ztmp0 = cd_neutral_10m(ztmp0) ! Cd_n10 203 Cdn(:,:) = ztmp0 201 204 sqrt_Cd_n10 = sqrt(ztmp0) 202 205 203 206 stab = 0.5 + sign(0.5,zeta_u) ! update stability 204 207 Cx_n10 = 1.e-3*sqrt_Cd_n10*(18.*stab + 32.7*(1. - stab)) ! L&Y 2004 eq. (6c-6d) (Cx_n10 == Ch_n10) 208 Chn(:,:) = Cx_n10 205 209 206 210 !! Update of transfer coefficients: … … 216 220 217 221 Cx_n10 = 1.e-3 * (34.6 * sqrt_Cd_n10) ! L&Y 2004 eq. (6b) ! Cx_n10 == Ce_n10 222 Cen(:,:) = Cx_n10 218 223 ztmp1 = 1. + Cx_n10*ztmp0 219 224 Ce = Cx_n10*ztmp2 / ztmp1 ! L&Y 2004 eq. (10c) -
branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/NEMO/OPA_SRC/SBC/sbccpl.F90
r8878 r8879 29 29 USE ice ! ice variables 30 30 #endif 31 #if defined key_lim232 USE par_ice_2 ! ice parameters33 USE ice_2 ! ice variables34 #endif35 31 USE cpl_oasis3 ! OASIS3 coupling 36 32 USE geo2ocean ! 37 33 USE oce , ONLY : tsn, un, vn, sshn, ub, vb, sshb, fraqsr_1lev 38 USE albedo!34 USE ocealb ! 39 35 USE eosbn2 ! 40 36 USE sbcrnf, ONLY : l_rnfcpl … … 44 40 #endif 45 41 #if defined key_lim3 46 USE limthd_dh ! for CALL lim_thd_snwblow42 USE icethd_dh ! for CALL ice_thd_snwblow 47 43 #endif 48 44 ! … … 58 54 59 55 PUBLIC sbc_cpl_init ! routine called by sbcmod.F90 60 PUBLIC sbc_cpl_rcv ! routine called by sbc_ice_lim(_2).F9056 PUBLIC sbc_cpl_rcv ! routine called by icestp.F90 61 57 PUBLIC sbc_cpl_snd ! routine called by step.F90 62 PUBLIC sbc_cpl_ice_tau ! routine called by sbc_ice_lim(_2).F9063 PUBLIC sbc_cpl_ice_flx ! routine called by sbc_ice_lim(_2).F9058 PUBLIC sbc_cpl_ice_tau ! routine called by icestp.F90 59 PUBLIC sbc_cpl_ice_flx ! routine called by icestp.F90 64 60 PUBLIC sbc_cpl_alloc ! routine called in sbcice_cice.F90 65 61 … … 117 113 INTEGER, PARAMETER :: jpr_isf = 52 118 114 INTEGER, PARAMETER :: jpr_icb = 53 119 120 INTEGER, PARAMETER :: jprcv = 53 ! total number of fields received 115 INTEGER, PARAMETER :: jpr_ts_ice = 54 ! Sea ice surface temp 116 INTEGER, PARAMETER :: jpr_rcv = 55 117 118 INTEGER, PARAMETER :: jprcv = 55 ! total number of fields received 121 119 122 120 INTEGER, PARAMETER :: jps_fice = 1 ! ice fraction sent to the atmosphere … … 152 150 INTEGER, PARAMETER :: jps_ocyw = 31 ! currents on grid 2 153 151 INTEGER, PARAMETER :: jps_wlev = 32 ! water level 154 INTEGER, PARAMETER :: jpsnd = 32 ! total number of fields sent 152 INTEGER, PARAMETER :: jps_fice1 = 33 ! first-order ice concentration (for semi-implicit coupling of atmos-ice fluxes) 153 INTEGER, PARAMETER :: jps_a_p = 34 ! meltpond area 154 INTEGER, PARAMETER :: jps_ht_p = 35 ! meltpond thickness 155 INTEGER, PARAMETER :: jps_kice = 36 ! sea ice effective conductivity 156 INTEGER, PARAMETER :: jps_sstfrz = 37 ! sea surface freezing temperature 157 INTEGER, PARAMETER :: jps_ttilyr = 38 ! sea ice top layer temp 158 INTEGER, PARAMETER :: jpsnd = 38 ! total number of fields sent 159 160 INTEGER :: nn_cats_cpl ! number of sea ice categories over which the coupling is carried out 155 161 156 162 ! !!** namelist namsbc_cpl ** … … 163 169 END TYPE FLD_C 164 170 ! ! Send to the atmosphere 165 TYPE(FLD_C) :: sn_snd_temp, sn_snd_alb, sn_snd_thick, sn_snd_crt, sn_snd_co2 171 TYPE(FLD_C) :: sn_snd_temp, sn_snd_alb, sn_snd_thick, sn_snd_crt, sn_snd_co2, sn_snd_thick1, sn_snd_cond, sn_snd_mpnd, sn_snd_sstfrz, sn_snd_ttilyr 166 172 ! ! Received from the atmosphere 167 TYPE(FLD_C) :: sn_rcv_w10m, sn_rcv_taumod, sn_rcv_tau, sn_rcv_dqnsdt, sn_rcv_qsr, sn_rcv_qns, sn_rcv_emp, sn_rcv_rnf 173 TYPE(FLD_C) :: sn_rcv_w10m, sn_rcv_taumod, sn_rcv_tau, sn_rcv_dqnsdt, sn_rcv_qsr, sn_rcv_qns, sn_rcv_emp, sn_rcv_rnf, sn_rcv_ts_ice 168 174 TYPE(FLD_C) :: sn_rcv_cal, sn_rcv_iceflx, sn_rcv_co2, sn_rcv_mslp, sn_rcv_icb, sn_rcv_isf 169 175 ! Send to waves … … 181 187 TYPE( DYNARR ), SAVE, DIMENSION(jprcv) :: frcv ! all fields recieved from the atmosphere 182 188 183 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: alb edo_oce_mix ! ocean albedo sent to atmosphere (mix clear/overcast sky)189 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: alb_oce_mix ! ocean albedo sent to atmosphere (mix clear/overcast sky) 184 190 185 191 REAL(wp) :: rpref = 101000._wp ! reference atmospheric pressure[N/m2] … … 205 211 ierr(:) = 0 206 212 ! 207 ALLOCATE( alb edo_oce_mix(jpi,jpj), nrcvinfo(jprcv), STAT=ierr(1) )213 ALLOCATE( alb_oce_mix(jpi,jpj), nrcvinfo(jprcv), STAT=ierr(1) ) 208 214 209 #if ! defined key_lim3 && ! defined key_ lim2 && ! defined key_cice215 #if ! defined key_lim3 && ! defined key_cice 210 216 ALLOCATE( a_i(jpi,jpj,1) , STAT=ierr(2) ) ! used in sbcice_if.F90 (done here as there is no sbc_ice_if_init) 211 217 #endif … … 242 248 REAL(wp), POINTER, DIMENSION(:,:) :: zacs, zaos 243 249 !! 250 LOGICAL :: ln_iceshelf_init_atmos 244 251 NAMELIST/namsbc_cpl/ sn_snd_temp , sn_snd_alb , sn_snd_thick , sn_snd_crt , sn_snd_co2, & 245 252 & sn_rcv_w10m, sn_rcv_taumod, sn_rcv_tau , sn_rcv_dqnsdt, sn_rcv_qsr, & 253 & sn_snd_thick1, sn_snd_cond, sn_snd_mpnd, sn_snd_sstfrz , sn_rcv_ts_ice, sn_snd_ttilyr, & 246 254 & sn_snd_ifrac, sn_snd_crtw , sn_snd_wlev , sn_rcv_hsig , sn_rcv_phioc , & 247 255 & sn_rcv_sdrfx, sn_rcv_sdrfy, sn_rcv_wper , sn_rcv_wnum , sn_rcv_wstrf , & 248 256 & sn_rcv_wdrag, sn_rcv_qns , sn_rcv_emp , sn_rcv_rnf , sn_rcv_cal , & 249 257 & sn_rcv_iceflx,sn_rcv_co2 , nn_cplmodel , ln_usecplmask, sn_rcv_mslp , & 250 & sn_rcv_icb , sn_rcv_isf 258 & sn_rcv_icb , sn_rcv_isf, ln_iceshelf_init_atmos, nn_cats_cpl 251 259 252 260 !!--------------------------------------------------------------------- … … 274 282 WRITE(numout,*)'~~~~~~~~~~~~' 275 283 ENDIF 284 285 !!!!! Getting NEMO4-LIM working at the Met Office: Hardcode number of ice cats to 5 during the initialisation 286 jpl = nn_cats_cpl 287 !!!!! 288 276 289 IF( lwp .AND. ln_cpl ) THEN ! control print 277 290 WRITE(numout,*)' received fields (mutiple ice categogies)' … … 300 313 WRITE(numout,*)' Stress frac adsorbed by waves = ', TRIM(sn_rcv_wstrf%cldes ), ' (', TRIM(sn_rcv_wstrf%clcat ), ')' 301 314 WRITE(numout,*)' Neutral surf drag coefficient = ', TRIM(sn_rcv_wdrag%cldes ), ' (', TRIM(sn_rcv_wdrag%clcat ), ')' 315 WRITE(numout,*)' Sea ice surface skin temperature = ', TRIM(sn_rcv_ts_ice%cldes ), ' (', TRIM(sn_rcv_ts_ice%clcat ), ')' 302 316 WRITE(numout,*)' sent fields (multiple ice categories)' 303 317 WRITE(numout,*)' surface temperature = ', TRIM(sn_snd_temp%cldes ), ' (', TRIM(sn_snd_temp%clcat ), ')' 318 WRITE(numout,*)' top ice layer temperature = ', TRIM(sn_snd_ttilyr%cldes ), ' (', TRIM(sn_snd_ttilyr%clcat ), ')' 304 319 WRITE(numout,*)' albedo = ', TRIM(sn_snd_alb%cldes ), ' (', TRIM(sn_snd_alb%clcat ), ')' 305 320 WRITE(numout,*)' ice/snow thickness = ', TRIM(sn_snd_thick%cldes ), ' (', TRIM(sn_snd_thick%clcat ), ')' … … 310 325 WRITE(numout,*)' - mesh = ', sn_snd_crt%clvgrd 311 326 WRITE(numout,*)' oce co2 flux = ', TRIM(sn_snd_co2%cldes ), ' (', TRIM(sn_snd_co2%clcat ), ')' 327 WRITE(numout,*)' ice effective conductivity = ', TRIM(sn_snd_cond%cldes ), ' (', TRIM(sn_snd_cond%clcat ), ')' 328 WRITE(numout,*)' meltponds fraction and depth = ', TRIM(sn_snd_mpnd%cldes ), ' (', TRIM(sn_snd_mpnd%clcat ), ')' 329 WRITE(numout,*)' sea surface freezing temp = ', TRIM(sn_snd_sstfrz%cldes ), ' (', TRIM(sn_snd_sstfrz%clcat ), ')' 312 330 WRITE(numout,*)' water level = ', TRIM(sn_snd_wlev%cldes ), ' (', TRIM(sn_snd_wlev%clcat ), ')' 313 331 WRITE(numout,*)' mean sea level pressure = ', TRIM(sn_rcv_mslp%cldes ), ' (', TRIM(sn_rcv_mslp%clcat ), ')' … … 318 336 WRITE(numout,*)' nn_cplmodel = ', nn_cplmodel 319 337 WRITE(numout,*)' ln_usecplmask = ', ln_usecplmask 338 WRITE(numout,*)' nn_cats_cpl = ', nn_cats_cpl 320 339 ENDIF 321 340 … … 511 530 ! 512 531 ! non solar sensitivity mandatory for LIM ice model 513 IF( TRIM( sn_rcv_dqnsdt%cldes ) == 'none' .AND. k_ice /= 0 .AND. k_ice /= 4 .AND. nn_components /= jp_iam_sas ) & 514 CALL ctl_stop( 'sbc_cpl_init: sn_rcv_dqnsdt%cldes must be coupled in namsbc_cpl namelist' ) 532 533 IF (.NOT. ln_meto_cpl) THEN 534 IF( TRIM( sn_rcv_dqnsdt%cldes ) == 'none' .AND. k_ice /= 0 .AND. k_ice /= 3 .AND. nn_components /= jp_iam_sas) & 535 CALL ctl_stop( 'sbc_cpl_init: sn_rcv_dqnsdt%cldes must be coupled in namsbc_cpl namelist' ) 536 ENDIF 537 515 538 ! non solar sensitivity mandatory for mixed oce-ice solar radiation coupling technique 516 539 IF( TRIM( sn_rcv_dqnsdt%cldes ) == 'none' .AND. TRIM( sn_rcv_qns%cldes ) == 'mixed oce-ice' ) & … … 557 580 srcv(jpr_topm:jpr_botm)%laction = .TRUE. 558 581 ENDIF 582 ! ! ----------------------------- ! 583 584 !!!!! To get NEMO4-LIM working at Met Office 585 srcv(jpr_ts_ice)%clname = 'OTsfIce' 586 IF ( TRIM( sn_rcv_ts_ice%cldes ) == 'ice' ) srcv(jpr_ts_ice)%laction = .TRUE. 587 IF ( TRIM( sn_rcv_ts_ice%clcat ) == 'yes' ) srcv(jpr_ts_ice)%nct = jpl 588 IF ( TRIM( sn_rcv_emp%clcat ) == 'yes' ) srcv(jpr_ievp)%nct = jpl 589 !!!!! 590 559 591 ! ! ------------------------- ! 560 592 ! ! Wave breaking ! … … 719 751 ssnd(jps_toce)%clname = 'O_SSTSST' 720 752 ssnd(jps_tice)%clname = 'O_TepIce' 753 ssnd(jps_ttilyr)%clname = 'O_TtiLyr' 721 754 ssnd(jps_tmix)%clname = 'O_TepMix' 722 755 SELECT CASE( TRIM( sn_snd_temp%cldes ) ) 723 756 CASE( 'none' ) ! nothing to do 724 757 CASE( 'oce only' ) ; ssnd( jps_toce )%laction = .TRUE. 725 CASE( 'oce and ice' , 'weighted oce and ice' )758 CASE( 'oce and ice' , 'weighted oce and ice' , 'oce and weighted ice') 726 759 ssnd( (/jps_toce, jps_tice/) )%laction = .TRUE. 727 760 IF ( TRIM( sn_snd_temp%clcat ) == 'yes' ) ssnd(jps_tice)%nct = jpl … … 746 779 ! 2. receiving mixed oce-ice solar radiation 747 780 IF ( TRIM ( sn_snd_alb%cldes ) == 'mixed oce-ice' .OR. TRIM ( sn_rcv_qsr%cldes ) == 'mixed oce-ice' ) THEN 748 CALL albedo_oce( zaos, zacs )781 CALL oce_alb( zaos, zacs ) 749 782 ! Due to lack of information on nebulosity : mean clear/overcast sky 750 alb edo_oce_mix(:,:) = ( zacs(:,:) + zaos(:,:) ) * 0.5783 alb_oce_mix(:,:) = ( zacs(:,:) + zaos(:,:) ) * 0.5 751 784 ENDIF 752 785 … … 757 790 ssnd(jps_ficet)%clname = 'OIceFrcT' 758 791 ssnd(jps_hice)%clname = 'OIceTck' 792 ssnd(jps_a_p)%clname = 'OPndFrc' 793 ssnd(jps_ht_p)%clname = 'OPndTck' 759 794 ssnd(jps_hsnw)%clname = 'OSnwTck' 795 ssnd(jps_fice1)%clname = 'OIceFrd' 760 796 IF( k_ice /= 0 ) THEN 761 797 ssnd(jps_fice)%laction = .TRUE. ! if ice treated in the ocean (even in climato case) 798 ssnd(jps_fice1)%laction = .TRUE. ! First-order regridded ice concentration, to be used 799 ! producing atmos-to-ice fluxes 762 800 ! Currently no namelist entry to determine sending of multi-category ice fraction so use the thickness entry for now 763 801 IF ( TRIM( sn_snd_thick%clcat ) == 'yes' ) ssnd(jps_fice)%nct = jpl 802 IF ( TRIM( sn_snd_thick1%clcat ) == 'yes' ) ssnd(jps_fice1)%nct = jpl 764 803 ENDIF 765 804 … … 779 818 END SELECT 780 819 820 ! ! ------------------------- ! 821 ! ! Ice Meltponds ! 822 ! ! ------------------------- ! 823 824 825 !!!!! Getting NEMO4-LIM to work at Met Office 826 ssnd(jps_a_p)%clname = 'OPndFrc' 827 ssnd(jps_ht_p)%clname = 'OPndTck' 828 SELECT CASE ( TRIM( sn_snd_mpnd%cldes ) ) 829 CASE ( 'none' ) 830 ssnd(jps_a_p)%laction = .FALSE. 831 ssnd(jps_ht_p)%laction = .FALSE. 832 CASE ( 'ice only' ) 833 ssnd(jps_a_p)%laction = .TRUE. 834 ssnd(jps_ht_p)%laction = .TRUE. 835 IF ( TRIM( sn_snd_mpnd%clcat ) == 'yes' ) THEN 836 ssnd(jps_a_p)%nct = jpl 837 ssnd(jps_ht_p)%nct = jpl 838 ELSE 839 IF ( jpl > 1 ) THEN 840 CALL ctl_stop( 'sbc_cpl_init: use weighted ice option for sn_snd_mpnd%cldes if not exchanging category fields' ) 841 ENDIF 842 ENDIF 843 CASE ( 'weighted ice' ) 844 ssnd(jps_a_p)%laction = .TRUE. 845 ssnd(jps_ht_p)%laction = .TRUE. 846 IF ( TRIM( sn_snd_mpnd%clcat ) == 'yes' ) THEN 847 ssnd(jps_a_p)%nct = jpl 848 ssnd(jps_ht_p)%nct = jpl 849 ENDIF 850 CASE default ; CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_snd_mpnd%cldes; '//sn_snd_mpnd%cldes ) 851 END SELECT 852 !!!!! 853 781 854 ! ! ------------------------- ! 782 855 ! ! Surface current ! … … 828 901 ! ! ------------------------- ! 829 902 ssnd(jps_co2)%clname = 'O_CO2FLX' ; IF( TRIM(sn_snd_co2%cldes) == 'coupled' ) ssnd(jps_co2 )%laction = .TRUE. 830 903 ! 904 905 !!!!! Getting NEMO4-LIM to work at the Met Office 906 ! ! ------------------------- ! 907 ! ! Sea surface freezing temp ! 908 ! ! ------------------------- ! 909 ssnd(jps_sstfrz)%clname = 'O_SSTFrz' ; IF( TRIM(sn_snd_sstfrz%cldes) == 'coupled' ) ssnd(jps_sstfrz)%laction = .TRUE. 910 !!!!! 911 912 ! 913 ! ! ------------------------- ! 914 ! ! Ice conductivity ! 915 ! ! ------------------------- ! 916 ! Note that ultimately we will move to passing an ocean effective conductivity as well so there 917 ! will be some changes to the parts of the code which currently relate only to ice conductivity 918 919 ssnd(jps_ttilyr )%clname = 'O_TtiLyr' 920 SELECT CASE ( TRIM( sn_snd_ttilyr%cldes ) ) 921 CASE ( 'none' ) 922 ssnd(jps_ttilyr)%laction = .FALSE. 923 CASE ( 'ice only' ) 924 ssnd(jps_ttilyr)%laction = .TRUE. 925 IF ( TRIM( sn_snd_ttilyr%clcat ) == 'yes' ) THEN 926 ssnd(jps_ttilyr)%nct = jpl 927 ELSE 928 IF ( jpl > 1 ) THEN 929 CALL ctl_stop( 'sbc_cpl_init: use weighted ice option for sn_snd_ttilyr%cldes if not exchanging category fields' ) 930 ENDIF 931 ENDIF 932 CASE ( 'weighted ice' ) 933 ssnd(jps_ttilyr)%laction = .TRUE. 934 IF ( TRIM( sn_snd_ttilyr%clcat ) == 'yes' ) ssnd(jps_ttilyr)%nct = jpl 935 CASE default ; CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_snd_ttilyr%cldes;'//sn_snd_ttilyr%cldes ) 936 END SELECT 937 938 ssnd(jps_kice )%clname = 'OIceKn' 939 SELECT CASE ( TRIM( sn_snd_cond%cldes ) ) 940 CASE ( 'none' ) 941 ssnd(jps_kice)%laction = .FALSE. 942 CASE ( 'ice only' ) 943 ssnd(jps_kice)%laction = .TRUE. 944 IF ( TRIM( sn_snd_cond%clcat ) == 'yes' ) THEN 945 ssnd(jps_kice)%nct = jpl 946 ELSE 947 IF ( jpl > 1 ) THEN 948 CALL ctl_stop( 'sbc_cpl_init: use weighted ice option for sn_snd_cond%cldes if not exchanging category fields' ) 949 ENDIF 950 ENDIF 951 CASE ( 'weighted ice' ) 952 ssnd(jps_kice)%laction = .TRUE. 953 IF ( TRIM( sn_snd_cond%clcat ) == 'yes' ) ssnd(jps_kice)%nct = jpl 954 CASE default ; CALL ctl_stop( 'sbc_cpl_init: wrong definition of sn_snd_cond%cldes;'//sn_snd_cond%cldes ) 955 END SELECT 956 ! 957 831 958 ! ! ------------------------- ! 832 959 ! ! Sea surface height ! … … 1161 1288 IF( srcv(jpr_co2)%laction ) atm_co2(:,:) = frcv(jpr_co2)%z3(:,:,1) 1162 1289 ! 1290 1291 !!!!! Getting NEMO4-LIM to work at the Met Office 1292 ! ! Sea ice surface skin temp: 1293 IF( srcv(jpr_ts_ice)%laction ) THEN 1294 DO jn = 1, jpl 1295 DO jj = 1, jpj 1296 DO ji = 1, jpi 1297 IF (frcv(jpr_ts_ice)%z3(ji,jj,jn) > 0.0) THEN 1298 tsfc_ice(ji,jj,jn) = 0.0 1299 ELSE IF (frcv(jpr_ts_ice)%z3(ji,jj,jn) < -60.0) THEN 1300 tsfc_ice(ji,jj,jn) = -60.0 1301 ELSE 1302 tsfc_ice(ji,jj,jn) = frcv(jpr_ts_ice)%z3(ji,jj,jn) 1303 ENDIF 1304 END DO 1305 END DO 1306 END DO 1307 ENDIF 1308 !!!!! 1309 1310 1163 1311 ! ! ========================= ! 1164 1312 ! ! Mean Sea Level Pressure ! (taum) … … 1248 1396 IF( srcv(jpr_ocx1)%laction ) THEN ! received by sas in case of opa <-> sas coupling 1249 1397 ssu_m(:,:) = frcv(jpr_ocx1)%z3(:,:,1) 1250 ub (:,:,1) = ssu_m(:,:) ! will be used in sbcice_limin the call of lim_sbc_tau1398 ub (:,:,1) = ssu_m(:,:) ! will be used in icestp in the call of lim_sbc_tau 1251 1399 un (:,:,1) = ssu_m(:,:) ! will be used in sbc_cpl_snd if atmosphere coupling 1252 1400 CALL iom_put( 'ssu_m', ssu_m ) … … 1254 1402 IF( srcv(jpr_ocy1)%laction ) THEN 1255 1403 ssv_m(:,:) = frcv(jpr_ocy1)%z3(:,:,1) 1256 vb (:,:,1) = ssv_m(:,:) ! will be used in sbcice_limin the call of lim_sbc_tau1404 vb (:,:,1) = ssv_m(:,:) ! will be used in icestp in the call of lim_sbc_tau 1257 1405 vn (:,:,1) = ssv_m(:,:) ! will be used in sbc_cpl_snd if atmosphere coupling 1258 1406 CALL iom_put( 'ssv_m', ssv_m ) … … 1558 1706 1559 1707 1560 SUBROUTINE sbc_cpl_ice_flx( p _frld, palbi, psst, pist)1708 SUBROUTINE sbc_cpl_ice_flx( picefr, palbi, psst, pist, phs, phi ) 1561 1709 !!---------------------------------------------------------------------- 1562 1710 !! *** ROUTINE sbc_cpl_ice_flx *** … … 1591 1739 !! 1592 1740 !! ** Details 1593 !! qns_tot = pfrld * qns_oce + ( 1 - pfrld ) * qns_ice=> provided1741 !! qns_tot = (1-a) * qns_oce + a * qns_ice => provided 1594 1742 !! + qemp_oce + qemp_ice => recalculated and added up to qns 1595 1743 !! 1596 !! qsr_tot = pfrld * qsr_oce + ( 1 - pfrld ) * qsr_ice=> provided1744 !! qsr_tot = (1-a) * qsr_oce + a * qsr_ice => provided 1597 1745 !! 1598 1746 !! emp_tot = emp_oce + emp_ice => calving is provided and added to emp_tot (and emp_oce). … … 1608 1756 !! sprecip solid precipitation over the ocean 1609 1757 !!---------------------------------------------------------------------- 1610 REAL(wp), INTENT(in ), DIMENSION(:,:) :: p_frld ! leadfraction [0 to 1]1758 REAL(wp), INTENT(in), DIMENSION(:,:) :: picefr ! ice fraction [0 to 1] 1611 1759 ! optional arguments, used only in 'mixed oce-ice' case 1612 REAL(wp), INTENT(in ), DIMENSION(:,:,:), OPTIONAL :: palbi ! all skies ice albedo 1613 REAL(wp), INTENT(in ), DIMENSION(:,: ), OPTIONAL :: psst ! sea surface temperature [Celsius] 1614 REAL(wp), INTENT(in ), DIMENSION(:,:,:), OPTIONAL :: pist ! ice surface temperature [Kelvin] 1615 ! 1616 INTEGER :: jl ! dummy loop index 1617 REAL(wp), POINTER, DIMENSION(:,: ) :: zcptn, zcptrain, zcptsnw, zicefr, zmsk, zsnw 1618 REAL(wp), POINTER, DIMENSION(:,: ) :: zemp_tot, zemp_ice, zemp_oce, ztprecip, zsprecip, zevap_oce, zevap_ice, zdevap_ice 1760 REAL(wp), INTENT(in), DIMENSION(:,:,:), OPTIONAL :: palbi ! all skies ice albedo 1761 REAL(wp), INTENT(in), DIMENSION(:,: ), OPTIONAL :: psst ! sea surface temperature [Celsius] 1762 REAL(wp), INTENT(in), DIMENSION(:,:,:), OPTIONAL :: pist ! ice surface temperature [Kelvin] 1763 REAL(wp), INTENT(in), DIMENSION(:,:,:), OPTIONAL :: phs ! snow depth [m] 1764 REAL(wp), INTENT(in), DIMENSION(:,:,:), OPTIONAL :: phi ! ice thickness [m] 1765 ! 1766 INTEGER :: ji,jj,jl ! dummy loop index 1767 REAL(wp), POINTER, DIMENSION(:,: ) :: zcptn, zcptrain, zcptsnw, ziceld, zmsk, zsnw 1768 REAL(wp), POINTER, DIMENSION(:,: ) :: zemp_tot, zemp_ice, zemp_oce, ztprecip, zsprecip, zevap_oce, zdevap_ice 1619 1769 REAL(wp), POINTER, DIMENSION(:,: ) :: zqns_tot, zqns_oce, zqsr_tot, zqsr_oce, zqprec_ice, zqemp_oce, zqemp_ice 1620 REAL(wp), POINTER, DIMENSION(:,:,:) :: zqns_ice, zqsr_ice, zdqns_ice, zqevap_ice 1770 REAL(wp), POINTER, DIMENSION(:,:,:) :: zqns_ice, zqsr_ice, zdqns_ice, zqevap_ice, zfrqsr_tr_i, zevap_ice 1621 1771 !!---------------------------------------------------------------------- 1622 1772 ! 1623 1773 IF( nn_timing == 1 ) CALL timing_start('sbc_cpl_ice_flx') 1624 1774 ! 1625 CALL wrk_alloc( jpi,jpj, zcptn, zcptrain, zcptsnw, zice fr, zmsk, zsnw )1626 CALL wrk_alloc( jpi,jpj, zemp_tot, zemp_ice, zemp_oce, ztprecip, zsprecip, zevap_oce, z evap_ice, zdevap_ice )1775 CALL wrk_alloc( jpi,jpj, zcptn, zcptrain, zcptsnw, ziceld, zmsk, zsnw ) 1776 CALL wrk_alloc( jpi,jpj, zemp_tot, zemp_ice, zemp_oce, ztprecip, zsprecip, zevap_oce, zdevap_ice ) 1627 1777 CALL wrk_alloc( jpi,jpj, zqns_tot, zqns_oce, zqsr_tot, zqsr_oce, zqprec_ice, zqemp_oce, zqemp_ice ) 1628 CALL wrk_alloc( jpi,jpj,jpl, zqns_ice, zqsr_ice, zdqns_ice, zqevap_ice ) 1778 CALL wrk_alloc( jpi,jpj,jpl, zqns_ice, zqsr_ice, zdqns_ice, zqevap_ice, zfrqsr_tr_i ) 1779 1780 IF (sn_rcv_emp%clcat == 'yes') THEN 1781 CALL wrk_alloc( jpi, jpj, jpl, zevap_ice) 1782 ELSE 1783 CALL wrk_alloc( jpi, jpj, 1, zevap_ice) 1784 ENDIF 1629 1785 1630 1786 IF( ln_mixcpl ) zmsk(:,:) = 1. - xcplmask(:,:,0) 1631 zice fr(:,:) = 1.- p_frld(:,:)1787 ziceld(:,:) = 1. - picefr(:,:) 1632 1788 zcptn(:,:) = rcp * sst_m(:,:) 1633 1789 ! … … 1645 1801 ztprecip(:,:) = frcv(jpr_rain)%z3(:,:,1) + zsprecip(:,:) ! May need to ensure positive here 1646 1802 zemp_tot(:,:) = frcv(jpr_tevp)%z3(:,:,1) - ztprecip(:,:) 1647 zemp_ice(:,:) = ( frcv(jpr_ievp)%z3(:,:,1) - frcv(jpr_snow)%z3(:,:,1) ) * zicefr(:,:)1803 zemp_ice(:,:) = ( frcv(jpr_ievp)%z3(:,:,1) - frcv(jpr_snow)%z3(:,:,1) ) * picefr(:,:) 1648 1804 CASE( 'oce and ice' ) ! received fields: jpr_sbpr, jpr_semp, jpr_oemp, jpr_ievp 1649 zemp_tot(:,:) = p_frld(:,:) * frcv(jpr_oemp)%z3(:,:,1) + zicefr(:,:) * frcv(jpr_sbpr)%z3(:,:,1)1650 zemp_ice(:,:) = frcv(jpr_semp)%z3(:,:,1) * zicefr(:,:)1805 zemp_tot(:,:) = ziceld(:,:) * frcv(jpr_oemp)%z3(:,:,1) + picefr(:,:) * frcv(jpr_sbpr)%z3(:,:,1) 1806 zemp_ice(:,:) = frcv(jpr_semp)%z3(:,:,1) * picefr(:,:) 1651 1807 zsprecip(:,:) = frcv(jpr_ievp)%z3(:,:,1) - frcv(jpr_semp)%z3(:,:,1) 1652 1808 ztprecip(:,:) = frcv(jpr_semp)%z3(:,:,1) - frcv(jpr_sbpr)%z3(:,:,1) + zsprecip(:,:) … … 1654 1810 1655 1811 #if defined key_lim3 1656 ! zsnw = snow fraction over ice after wind blowing (= zicefr if no blowing)1657 zsnw(:,:) = 0._wp ; CALL lim_thd_snwblow( p_frld, zsnw )1812 ! zsnw = snow fraction over ice after wind blowing (=picefr if no blowing) 1813 zsnw(:,:) = 0._wp ; CALL ice_thd_snwblow( ziceld, zsnw ) 1658 1814 1659 1815 ! --- evaporation minus precipitation corrected (because of wind blowing on snow) --- ! 1660 zemp_ice(:,:) = zemp_ice(:,:) + zsprecip(:,:) * ( zicefr(:,:) - zsnw(:,:) ) ! emp_ice = A * sublimation - zsnw * sprecip1816 zemp_ice(:,:) = zemp_ice(:,:) + zsprecip(:,:) * ( picefr(:,:) - zsnw(:,:) ) ! emp_ice = A * sublimation - zsnw * sprecip 1661 1817 zemp_oce(:,:) = zemp_tot(:,:) - zemp_ice(:,:) ! emp_oce = emp_tot - emp_ice 1662 1818 1663 1819 ! --- evaporation over ocean (used later for qemp) --- ! 1664 zevap_oce(:,:) = frcv(jpr_tevp)%z3(:,:,1) - frcv(jpr_ievp)%z3(:,:,1) * zicefr(:,:)1820 zevap_oce(:,:) = frcv(jpr_tevp)%z3(:,:,1) - frcv(jpr_ievp)%z3(:,:,1) * picefr(:,:) 1665 1821 1666 1822 ! --- evaporation over ice (kg/m2/s) --- ! 1667 zevap_ice(:,:) = frcv(jpr_ievp)%z3(:,:,1) 1823 IF (sn_rcv_emp%clcat == 'yes') THEN 1824 DO jl=1,jpl 1825 zevap_ice(:,:,jl) = frcv(jpr_ievp)%z3(:,:,jl) 1826 ENDDO 1827 ELSE 1828 zevap_ice(:,:,1) = frcv(jpr_ievp)%z3(:,:,1) 1829 ENDIF 1830 1668 1831 ! since the sensitivity of evap to temperature (devap/dT) is not prescribed by the atmosphere, we set it to 0 1669 1832 ! therefore, sublimation is not redistributed over the ice categories when no subgrid scale fluxes are provided by atm. … … 1693 1856 tprecip(:,:) = tprecip(:,:) * xcplmask(:,:,0) + ztprecip(:,:) * zmsk(:,:) 1694 1857 DO jl=1,jpl 1695 evap_ice (:,:,jl) = evap_ice (:,:,jl) * xcplmask(:,:,0) + zevap_ice (:,: ) * zmsk(:,:)1858 evap_ice (:,:,jl) = evap_ice (:,:,jl) * xcplmask(:,:,0) + zevap_ice (:,:,1) * zmsk(:,:) 1696 1859 devap_ice(:,:,jl) = devap_ice(:,:,jl) * xcplmask(:,:,0) + zdevap_ice(:,:) * zmsk(:,:) 1697 1860 ENDDO … … 1703 1866 tprecip(:,:) = ztprecip(:,:) 1704 1867 DO jl=1,jpl 1705 evap_ice (:,:,jl) = zevap_ice (:,:) 1868 IF (sn_rcv_emp%clcat == 'yes') THEN 1869 evap_ice (:,:,jl) = zevap_ice (:,:,jl) 1870 ELSE 1871 evap_ice (:,:,jl) = zevap_ice (:,:,1) 1872 ENDIF 1873 1706 1874 devap_ice(:,:,jl) = zdevap_ice(:,:) 1707 1875 ENDDO … … 1709 1877 1710 1878 #else 1711 zsnw(:,:) = zicefr(:,:)1879 zsnw(:,:) = picefr(:,:) 1712 1880 ! --- Continental fluxes --- ! 1713 1881 IF( srcv(jpr_rnf)%laction ) THEN ! runoffs (included in emp later on) … … 1748 1916 IF( iom_use('snow_ao_cea') ) CALL iom_put( 'snow_ao_cea' , sprecip(:,:) * ( 1._wp - zsnw(:,:) ) ) ! Snow over ice-free ocean (cell average) 1749 1917 IF( iom_use('snow_ai_cea') ) CALL iom_put( 'snow_ai_cea' , sprecip(:,:) * zsnw(:,:) ) ! Snow over sea-ice (cell average) 1750 IF( iom_use('subl_ai_cea') ) CALL iom_put( 'subl_ai_cea' , frcv(jpr_ievp)%z3(:,:,1) * zicefr(:,:) * tmask(:,:,1) ) ! Sublimation over sea-ice (cell average)1918 IF( iom_use('subl_ai_cea') ) CALL iom_put( 'subl_ai_cea' , frcv(jpr_ievp)%z3(:,:,1) * picefr(:,:) * tmask(:,:,1) ) ! Sublimation over sea-ice (cell average) 1751 1919 IF( iom_use('evap_ao_cea') ) CALL iom_put( 'evap_ao_cea' , ( frcv(jpr_tevp)%z3(:,:,1) & 1752 & - frcv(jpr_ievp)%z3(:,:,1) * zicefr(:,:) ) * tmask(:,:,1) ) ! ice-free oce evap (cell average)1920 & - frcv(jpr_ievp)%z3(:,:,1) * picefr(:,:) ) * tmask(:,:,1) ) ! ice-free oce evap (cell average) 1753 1921 ! note: runoff output is done in sbcrnf (which includes icebergs too) and iceshelf output is done in sbcisf 1754 1922 ! … … 1768 1936 ENDIF 1769 1937 CASE( 'oce and ice' ) ! the total flux is computed from ocean and ice fluxes 1770 zqns_tot(:,:) = p_frld(:,:) * frcv(jpr_qnsoce)%z3(:,:,1)1938 zqns_tot(:,:) = ziceld(:,:) * frcv(jpr_qnsoce)%z3(:,:,1) 1771 1939 IF ( TRIM(sn_rcv_qns%clcat) == 'yes' ) THEN 1772 1940 DO jl=1,jpl … … 1775 1943 ENDDO 1776 1944 ELSE 1777 qns_tot(:,:) = qns_tot(:,:) + zicefr(:,:) * frcv(jpr_qnsice)%z3(:,:,1)1945 qns_tot(:,:) = qns_tot(:,:) + picefr(:,:) * frcv(jpr_qnsice)%z3(:,:,1) 1778 1946 DO jl=1,jpl 1779 zqns_tot(:,: ) = zqns_tot(:,:) + zicefr(:,:) * frcv(jpr_qnsice)%z3(:,:,1)1947 zqns_tot(:,: ) = zqns_tot(:,:) + picefr(:,:) * frcv(jpr_qnsice)%z3(:,:,1) 1780 1948 zqns_ice(:,:,jl) = frcv(jpr_qnsice)%z3(:,:,1) 1781 1949 ENDDO … … 1785 1953 zqns_tot(:,: ) = frcv(jpr_qnsmix)%z3(:,:,1) 1786 1954 zqns_ice(:,:,1) = frcv(jpr_qnsmix)%z3(:,:,1) & 1787 & + frcv(jpr_dqnsdt)%z3(:,:,1) * ( pist(:,:,1) - ( (rt0 + psst(:,: ) ) * p_frld(:,:) &1788 & + pist(:,:,1) * zicefr(:,:) ) )1955 & + frcv(jpr_dqnsdt)%z3(:,:,1) * ( pist(:,:,1) - ( (rt0 + psst(:,: ) ) * ziceld(:,:) & 1956 & + pist(:,:,1) * picefr(:,:) ) ) 1789 1957 END SELECT 1790 1958 ! … … 1797 1965 #if defined key_lim3 1798 1966 ! --- non solar flux over ocean --- ! 1799 ! note: p_frld cannot be = 0 since we limit the ice concentration to amax1967 ! note: ziceld cannot be = 0 since we limit the ice concentration to amax 1800 1968 zqns_oce = 0._wp 1801 WHERE( p_frld /= 0._wp ) zqns_oce(:,:) = ( zqns_tot(:,:) - SUM( a_i * zqns_ice, dim=3 ) ) / p_frld(:,:)1969 WHERE( ziceld /= 0._wp ) zqns_oce(:,:) = ( zqns_tot(:,:) - SUM( a_i * zqns_ice, dim=3 ) ) / ziceld(:,:) 1802 1970 1803 1971 ! Heat content per unit mass of snow (J/kg) … … 1806 1974 ENDWHERE 1807 1975 ! Heat content per unit mass of rain (J/kg) 1808 zcptrain(:,:) = rcp * ( SUM( (tn_ice(:,:,:) - rt0) * a_i(:,:,:), dim=3 ) + sst_m(:,:) * p_frld(:,:) )1976 zcptrain(:,:) = rcp * ( SUM( (tn_ice(:,:,:) - rt0) * a_i(:,:,:), dim=3 ) + sst_m(:,:) * ziceld(:,:) ) 1809 1977 1810 1978 ! --- enthalpy of snow precip over ice in J/m3 (to be used in 1D-thermo) --- ! … … 1821 1989 & + zsprecip(:,:) * ( 1._wp - zsnw ) * ( zcptsnw (:,:) - lfus ) ! solid precip over ocean + snow melting 1822 1990 zqemp_ice(:,:) = zsprecip(:,:) * zsnw * ( zcptsnw (:,:) - lfus ) ! solid precip over ice (qevap_ice=0 since atm. does not take it into account) 1823 !! zqemp_ice(:,:) = - frcv(jpr_ievp)%z3(:,:,1) * zicefr(:,:) * zcptsnw (:,:) & ! ice evap1991 !! zqemp_ice(:,:) = - frcv(jpr_ievp)%z3(:,:,1) * picefr(:,:) * zcptsnw (:,:) & ! ice evap 1824 1992 !! & + zsprecip(:,:) * zsnw * zqprec_ice(:,:) * r1_rhosn ! solid precip over ice 1825 1993 … … 1854 2022 ! clem: this formulation is certainly wrong... but better than it was... 1855 2023 zqns_tot(:,:) = zqns_tot(:,:) & ! zqns_tot update over free ocean with: 1856 & - ( p_frld(:,:) * zsprecip(:,:) * lfus ) & ! remove the latent heat flux of solid precip. melting2024 & - ( ziceld(:,:) * zsprecip(:,:) * lfus ) & ! remove the latent heat flux of solid precip. melting 1857 2025 & - ( zemp_tot(:,:) & ! remove the heat content of mass flux (assumed to be at SST) 1858 2026 & - zemp_ice(:,:) ) * zcptn(:,:) 1859 2027 1860 2028 IF( ln_mixcpl ) THEN 1861 qns_tot(:,:) = qns(:,:) * p_frld(:,:) + SUM( qns_ice(:,:,:) * a_i(:,:,:), dim=3 ) ! total flux from blk2029 qns_tot(:,:) = qns(:,:) * ziceld(:,:) + SUM( qns_ice(:,:,:) * a_i(:,:,:), dim=3 ) ! total flux from blk 1862 2030 qns_tot(:,:) = qns_tot(:,:) * xcplmask(:,:,0) + zqns_tot(:,:)* zmsk(:,:) 1863 2031 DO jl=1,jpl … … 1875 2043 IF( iom_use('hflx_snow_cea') ) CALL iom_put('hflx_snow_cea', sprecip(:,:) * ( zcptsnw(:,:) - Lfus ) ) ! heat flux from snow (cell average) 1876 2044 IF( iom_use('hflx_rain_cea') ) CALL iom_put('hflx_rain_cea',( tprecip(:,:) - sprecip(:,:) ) * zcptrain(:,:) ) ! heat flux from rain (cell average) 1877 IF( iom_use('hflx_evap_cea') ) CALL iom_put('hflx_evap_cea',(frcv(jpr_tevp)%z3(:,:,1) - frcv(jpr_ievp)%z3(:,:,1) * zicefr(:,:) & ! heat flux from from evap (cell average)2045 IF( iom_use('hflx_evap_cea') ) CALL iom_put('hflx_evap_cea',(frcv(jpr_tevp)%z3(:,:,1) - frcv(jpr_ievp)%z3(:,:,1) * picefr(:,:) & ! heat flux from from evap (cell average) 1878 2046 & ) * zcptn(:,:) * tmask(:,:,1) ) 1879 2047 IF( iom_use('hflx_snow_ao_cea') ) CALL iom_put('hflx_snow_ao_cea',sprecip(:,:) * (zcptsnw(:,:) - Lfus) * (1._wp - zsnw(:,:)) ) ! heat flux from snow (over ocean) … … 1899 2067 zqsr_ice(:,:,1) = frcv(jpr_qsrice)%z3(:,:,1) 1900 2068 CASE( 'oce and ice' ) 1901 zqsr_tot(:,: ) = p_frld(:,:) * frcv(jpr_qsroce)%z3(:,:,1)2069 zqsr_tot(:,: ) = ziceld(:,:) * frcv(jpr_qsroce)%z3(:,:,1) 1902 2070 IF ( TRIM(sn_rcv_qsr%clcat) == 'yes' ) THEN 1903 2071 DO jl=1,jpl … … 1906 2074 ENDDO 1907 2075 ELSE 1908 qsr_tot(:,: ) = qsr_tot(:,:) + zicefr(:,:) * frcv(jpr_qsrice)%z3(:,:,1)2076 qsr_tot(:,: ) = qsr_tot(:,:) + picefr(:,:) * frcv(jpr_qsrice)%z3(:,:,1) 1909 2077 DO jl=1,jpl 1910 zqsr_tot(:,: ) = zqsr_tot(:,:) + zicefr(:,:) * frcv(jpr_qsrice)%z3(:,:,1)2078 zqsr_tot(:,: ) = zqsr_tot(:,:) + picefr(:,:) * frcv(jpr_qsrice)%z3(:,:,1) 1911 2079 zqsr_ice(:,:,jl) = frcv(jpr_qsrice)%z3(:,:,1) 1912 2080 ENDDO … … 1918 2086 ! ( see OASIS3 user guide, 5th edition, p39 ) 1919 2087 zqsr_ice(:,:,1) = frcv(jpr_qsrmix)%z3(:,:,1) * ( 1.- palbi(:,:,1) ) & 1920 & / ( 1.- ( alb edo_oce_mix(:,: ) * p_frld(:,:) &1921 & + palbi (:,:,1) * zicefr(:,:) ) )2088 & / ( 1.- ( alb_oce_mix(:,: ) * ziceld(:,:) & 2089 & + palbi (:,:,1) * picefr(:,:) ) ) 1922 2090 END SELECT 1923 2091 IF( ln_dm2dc .AND. ln_cpl ) THEN ! modify qsr to include the diurnal cycle … … 1930 2098 #if defined key_lim3 1931 2099 ! --- solar flux over ocean --- ! 1932 ! note: p_frld cannot be = 0 since we limit the ice concentration to amax2100 ! note: ziceld cannot be = 0 since we limit the ice concentration to amax 1933 2101 zqsr_oce = 0._wp 1934 WHERE( p_frld /= 0._wp ) zqsr_oce(:,:) = ( zqsr_tot(:,:) - SUM( a_i * zqsr_ice, dim=3 ) ) / p_frld(:,:)2102 WHERE( ziceld /= 0._wp ) zqsr_oce(:,:) = ( zqsr_tot(:,:) - SUM( a_i * zqsr_ice, dim=3 ) ) / ziceld(:,:) 1935 2103 1936 2104 IF( ln_mixcpl ) THEN ; qsr_oce(:,:) = qsr_oce(:,:) * xcplmask(:,:,0) + zqsr_oce(:,:)* zmsk(:,:) … … 1939 2107 1940 2108 IF( ln_mixcpl ) THEN 1941 qsr_tot(:,:) = qsr(:,:) * p_frld(:,:) + SUM( qsr_ice(:,:,:) * a_i(:,:,:), dim=3 ) ! total flux from blk2109 qsr_tot(:,:) = qsr(:,:) * ziceld(:,:) + SUM( qsr_ice(:,:,:) * a_i(:,:,:), dim=3 ) ! total flux from blk 1942 2110 qsr_tot(:,:) = qsr_tot(:,:) * xcplmask(:,:,0) + zqsr_tot(:,:)* zmsk(:,:) 1943 2111 DO jl=1,jpl … … 1971 2139 ENDIF 1972 2140 1973 ! ! ========================= ! 1974 SELECT CASE( TRIM( sn_rcv_iceflx%cldes ) ) ! topmelt and botmelt ! 1975 ! ! ========================= ! 1976 CASE ('coupled') 1977 topmelt(:,:,:)=frcv(jpr_topm)%z3(:,:,:) 1978 botmelt(:,:,:)=frcv(jpr_botm)%z3(:,:,:) 1979 END SELECT 1980 1981 ! Surface transimission parameter io (Maykut Untersteiner , 1971 ; Ebert and Curry, 1993 ) 1982 ! Used for LIM2 and LIM3 1983 ! Coupled case: since cloud cover is not received from atmosphere 1984 ! ===> used prescribed cloud fraction representative for polar oceans in summer (0.81) 1985 fr1_i0(:,:) = ( 0.18 * ( 1.0 - cldf_ice ) + 0.35 * cldf_ice ) 1986 fr2_i0(:,:) = ( 0.82 * ( 1.0 - cldf_ice ) + 0.65 * cldf_ice ) 1987 1988 CALL wrk_dealloc( jpi,jpj, zcptn, zcptrain, zcptsnw, zicefr, zmsk, zsnw ) 1989 CALL wrk_dealloc( jpi,jpj, zemp_tot, zemp_ice, zemp_oce, ztprecip, zsprecip, zevap_oce, zevap_ice, zdevap_ice ) 2141 IF( ln_meto_cpl ) THEN 2142 ! ! ========================= ! 2143 SELECT CASE( TRIM( sn_rcv_iceflx%cldes ) ) ! topmelt and botmelt ! 2144 ! ! ========================= ! 2145 CASE ('coupled') 2146 qml_ice(:,:,:)=frcv(jpr_topm)%z3(:,:,:) * a_i(:,:,:) 2147 qcn_ice(:,:,:)=frcv(jpr_botm)%z3(:,:,:) * a_i(:,:,:) 2148 END SELECT 2149 ENDIF 2150 2151 ! --- Transmitted shortwave radiation (W/m2) --- ! 2152 2153 IF ( nice_jules == 0 ) THEN 2154 2155 zfrqsr_tr_i(:,:,:) = 0._wp ! surface transmission parameter 2156 2157 ! former coding was 2158 ! Coupled case: since cloud cover is not received from atmosphere 2159 ! ===> used prescribed cloud fraction representative for polar oceans in summer (0.81) 2160 ! fr1_i0(:,:) = ( 0.18 * ( 1.0 - cldf_ice ) + 0.35 * cldf_ice ) 2161 ! fr2_i0(:,:) = ( 0.82 * ( 1.0 - cldf_ice ) + 0.65 * cldf_ice ) 2162 2163 ! to retrieve that coding, we needed to access h_i & h_s from here 2164 ! we could even retrieve cloud fraction from the coupler 2165 2166 DO jl = 1, jpl 2167 DO jj = 1 , jpj 2168 DO ji = 1, jpi 2169 2170 !--- surface transmission parameter (Grenfell Maykut 77) --- ! 2171 zfrqsr_tr_i(ji,jj,jl) = 0.18 * ( 1.0 - cldf_ice ) + 0.35 * cldf_ice 2172 2173 ! --- influence of snow and thin ice --- ! 2174 IF ( phs(ji,jj,jl) >= 0.0_wp ) zfrqsr_tr_i(ji,jj,jl) = 0._wp ! snow fully opaque 2175 IF ( phi(ji,jj,jl) <= 0.1_wp ) zfrqsr_tr_i(ji,jj,jl) = 1._wp ! thin ice transmits all solar radiation 2176 END DO 2177 END DO 2178 END DO 2179 2180 qsr_ice_tr(:,:,:) = zfrqsr_tr_i(:,:,:) * qsr_ice(:,:,:) ! transmitted solar radiation 2181 2182 ENDIF 2183 2184 IF ( nice_jules == 2 ) THEN 2185 2186 ! here we must receive the qsr_ice_tr array from the coupler 2187 ! for now just assume zero 2188 2189 qsr_ice_tr(:,:,:) = 0.0_wp 2190 2191 ENDIF 2192 2193 2194 2195 CALL wrk_dealloc( jpi,jpj, zcptn, zcptrain, zcptsnw, ziceld, zmsk, zsnw ) 2196 CALL wrk_dealloc( jpi,jpj, zemp_tot, zemp_ice, zemp_oce, ztprecip, zsprecip, zevap_oce, zdevap_ice ) 1990 2197 CALL wrk_dealloc( jpi,jpj, zqns_tot, zqns_oce, zqsr_tot, zqsr_oce, zqprec_ice, zqemp_oce, zqemp_ice ) 1991 CALL wrk_dealloc( jpi,jpj,jpl, zqns_ice, zqsr_ice, zdqns_ice, zqevap_ice ) 2198 CALL wrk_dealloc( jpi,jpj,jpl, zqns_ice, zqsr_ice, zdqns_ice, zqevap_ice, zfrqsr_tr_i ) 2199 IF (sn_rcv_emp%clcat == 'yes') THEN 2200 CALL wrk_dealloc( jpi,jpj,jpl,zevap_ice) 2201 ELSE 2202 CALL wrk_dealloc( jpi,jpj,1,zevap_ice) 2203 ENDIF 1992 2204 ! 1993 2205 IF( nn_timing == 1 ) CALL timing_stop('sbc_cpl_ice_flx') … … 2033 2245 ! we must send the surface potential temperature 2034 2246 IF( l_useCT ) THEN ; ztmp1(:,:) = eos_pt_from_ct( tsn(:,:,1,jp_tem), tsn(:,:,1,jp_sal) ) 2035 ELSE 2247 ELSE ; ztmp1(:,:) = tsn(:,:,1,jp_tem) 2036 2248 ENDIF 2037 2249 ! … … 2061 2273 CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_temp%clcat' ) 2062 2274 END SELECT 2275 CASE( 'oce and weighted ice') ; ztmp1(:,:) = tsn(:,:,1,jp_tem) + rt0 2276 SELECT CASE( sn_snd_temp%clcat ) 2277 CASE( 'yes' ) 2278 ztmp3(:,:,1:jpl) = tn_ice(:,:,1:jpl) * a_i(:,:,1:jpl) 2279 CASE( 'no' ) 2280 ztmp3(:,:,:) = 0.0 2281 DO jl=1,jpl 2282 ztmp3(:,:,1) = ztmp3(:,:,1) + tn_ice(:,:,jl) * a_i(:,:,jl) 2283 ENDDO 2284 CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_temp%clcat' ) 2285 END SELECT 2063 2286 CASE( 'mixed oce-ice' ) 2064 2287 ztmp1(:,:) = ( ztmp1(:,:) + rt0 ) * zfr_l(:,:) … … 2073 2296 IF( ssnd(jps_tmix)%laction ) CALL cpl_snd( jps_tmix, isec, RESHAPE ( ztmp1, (/jpi,jpj,1/) ), info ) 2074 2297 ENDIF 2298 2299 !!!!! Getting NEMO4-LIM working at Met Office 2300 ! Top layer ice temperature 2301 IF( ssnd(jps_ttilyr)%laction) THEN 2302 SELECT CASE( sn_snd_ttilyr%cldes) 2303 CASE ('weighted ice') 2304 ztmp3(:,:,1:jpl) = t1_ice(:,:,1:jpl) * a_i(:,:,1:jpl) 2305 CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_ttilyr%cldes' ) 2306 END SELECT 2307 IF( ssnd(jps_ttilyr)%laction ) CALL cpl_snd( jps_ttilyr, isec, ztmp3, info ) 2308 ENDIF 2309 !!!!! 2310 2311 2075 2312 ! ! ------------------------- ! 2076 2313 ! ! Albedo ! … … 2086 2323 ztmp1(:,:) = SUM( alb_ice (:,:,1:jpl) * a_i(:,:,1:jpl), dim=3 ) / SUM( a_i(:,:,1:jpl), dim=3 ) 2087 2324 ELSEWHERE 2088 ztmp1(:,:) = alb edo_oce_mix(:,:)2325 ztmp1(:,:) = alb_oce_mix(:,:) 2089 2326 END WHERE 2090 2327 CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_alb%clcat' ) … … 2114 2351 2115 2352 IF( ssnd(jps_albmix)%laction ) THEN ! mixed ice-ocean 2116 ztmp1(:,:) = alb edo_oce_mix(:,:) * zfr_l(:,:)2353 ztmp1(:,:) = alb_oce_mix(:,:) * zfr_l(:,:) 2117 2354 DO jl=1,jpl 2118 2355 ztmp1(:,:) = ztmp1(:,:) + alb_ice(:,:,jl) * a_i(:,:,jl) … … 2132 2369 IF( ssnd(jps_fice)%laction ) CALL cpl_snd( jps_fice, isec, ztmp3, info ) 2133 2370 ENDIF 2371 2372 IF( ssnd(jps_fice1)%laction ) THEN 2373 SELECT CASE( sn_snd_thick1%clcat ) 2374 CASE( 'yes' ) ; ztmp3(:,:,1:jpl) = a_i(:,:,1:jpl) 2375 CASE( 'no' ) ; ztmp3(:,:,1 ) = fr_i(:,: ) 2376 CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_thick1%clcat' ) 2377 END SELECT 2378 CALL cpl_snd( jps_fice1, isec, ztmp3, info ) 2379 ENDIF 2134 2380 2135 2381 ! Send ice fraction field to OPA (sent by SAS in SAS-OPA coupling) … … 2146 2392 SELECT CASE( sn_snd_thick%clcat ) 2147 2393 CASE( 'yes' ) 2148 ztmp3(:,:,1:jpl) = h t_i(:,:,1:jpl) * a_i(:,:,1:jpl)2149 ztmp4(:,:,1:jpl) = h t_s(:,:,1:jpl) * a_i(:,:,1:jpl)2394 ztmp3(:,:,1:jpl) = h_i(:,:,1:jpl) * a_i(:,:,1:jpl) 2395 ztmp4(:,:,1:jpl) = h_s(:,:,1:jpl) * a_i(:,:,1:jpl) 2150 2396 CASE( 'no' ) 2151 2397 ztmp3(:,:,:) = 0.0 ; ztmp4(:,:,:) = 0.0 2152 2398 DO jl=1,jpl 2153 ztmp3(:,:,1) = ztmp3(:,:,1) + h t_i(:,:,jl) * a_i(:,:,jl)2154 ztmp4(:,:,1) = ztmp4(:,:,1) + h t_s(:,:,jl) * a_i(:,:,jl)2399 ztmp3(:,:,1) = ztmp3(:,:,1) + h_i(:,:,jl) * a_i(:,:,jl) 2400 ztmp4(:,:,1) = ztmp4(:,:,1) + h_s(:,:,jl) * a_i(:,:,jl) 2155 2401 ENDDO 2156 2402 CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_thick%clcat' ) … … 2159 2405 SELECT CASE( sn_snd_thick%clcat ) 2160 2406 CASE( 'yes' ) 2161 ztmp3(:,:,1:jpl) = h t_i(:,:,1:jpl)2162 ztmp4(:,:,1:jpl) = h t_s(:,:,1:jpl)2407 ztmp3(:,:,1:jpl) = h_i(:,:,1:jpl) 2408 ztmp4(:,:,1:jpl) = h_s(:,:,1:jpl) 2163 2409 CASE( 'no' ) 2164 2410 WHERE( SUM( a_i, dim=3 ) /= 0. ) 2165 ztmp3(:,:,1) = SUM( h t_i * a_i, dim=3 ) / SUM( a_i, dim=3 )2166 ztmp4(:,:,1) = SUM( h t_s * a_i, dim=3 ) / SUM( a_i, dim=3 )2411 ztmp3(:,:,1) = SUM( h_i * a_i, dim=3 ) / SUM( a_i, dim=3 ) 2412 ztmp4(:,:,1) = SUM( h_s * a_i, dim=3 ) / SUM( a_i, dim=3 ) 2167 2413 ELSEWHERE 2168 2414 ztmp3(:,:,1) = 0. … … 2176 2422 IF( ssnd(jps_hsnw)%laction ) CALL cpl_snd( jps_hsnw, isec, ztmp4, info ) 2177 2423 ENDIF 2424 2425 ! 2426 ! Send meltpond fields 2427 IF( ssnd(jps_a_p)%laction .OR. ssnd(jps_ht_p)%laction ) THEN 2428 SELECT CASE( sn_snd_mpnd%cldes) 2429 CASE( 'weighted ice' ) 2430 SELECT CASE( sn_snd_mpnd%clcat ) 2431 CASE( 'yes' ) 2432 ztmp3(:,:,1:jpl) = a_ip(:,:,1:jpl) 2433 ztmp4(:,:,1:jpl) = v_ip(:,:,1:jpl) 2434 CASE( 'no' ) 2435 ztmp3(:,:,:) = 0.0 2436 ztmp4(:,:,:) = 0.0 2437 DO jl=1,jpl 2438 ztmp3(:,:,1) = ztmp3(:,:,1) + a_ip(:,:,jpl) 2439 ztmp4(:,:,1) = ztmp4(:,:,1) + v_ip(:,:,jpl) 2440 ENDDO 2441 CASE default ; CALL ctl_stop( 'sbc_cpl_mpd: wrong definition of sn_snd_mpnd%clcat' ) 2442 END SELECT 2443 CASE( 'default' ) ; CALL ctl_stop( 'sbc_cpl_mpd: wrong definition of sn_snd_mpnd%cldes' ) 2444 END SELECT 2445 IF( ssnd(jps_a_p)%laction ) CALL cpl_snd( jps_a_p, isec, ztmp3, info ) 2446 IF( ssnd(jps_ht_p)%laction ) CALL cpl_snd( jps_ht_p, isec, ztmp4, info ) 2447 ! 2448 ! Send ice effective conductivity 2449 SELECT CASE( sn_snd_cond%cldes) 2450 CASE( 'weighted ice' ) 2451 SELECT CASE( sn_snd_cond%clcat ) 2452 CASE( 'yes' ) 2453 ztmp3(:,:,1:jpl) = cnd_ice(:,:,1:jpl) * a_i(:,:,1:jpl) 2454 CASE( 'no' ) 2455 ztmp3(:,:,:) = 0.0 2456 DO jl=1,jpl 2457 ztmp3(:,:,1) = ztmp3(:,:,1) + cnd_ice(:,:,jl) * a_i(:,:,jl) 2458 ENDDO 2459 CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_cond%clcat' ) 2460 END SELECT 2461 CASE( 'ice only' ) 2462 ztmp3(:,:,1:jpl) = cnd_ice(:,:,1:jpl) 2463 END SELECT 2464 IF( ssnd(jps_kice)%laction ) CALL cpl_snd( jps_kice, isec, ztmp3, info ) 2465 ENDIF 2466 ! 2467 !!!!! 2468 2469 2178 2470 ! ! ------------------------- ! 2179 2471 ! ! CO2 flux from PISCES ! … … 2545 2837 IF( ssnd(jps_taum )%laction ) CALL cpl_snd( jps_taum , isec, RESHAPE ( taum, (/jpi,jpj,1/) ), info ) 2546 2838 2839 CALL eos_fzp(tsn(:,:,1,jp_sal), sstfrz) 2840 ztmp1(:,:) = sstfrz(:,:) 2841 IF( ssnd(jps_sstfrz)%laction ) CALL cpl_snd( jps_sstfrz, isec, RESHAPE ( ztmp1, (/jpi,jpj,1/) ), info) 2842 2547 2843 CALL wrk_dealloc( jpi,jpj, zfr_l, ztmp1, ztmp2, zotx1, zoty1, zotz1, zitx1, zity1, zitz1 ) 2548 2844 CALL wrk_dealloc( jpi,jpj,jpl, ztmp3, ztmp4 ) -
branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/NEMO/OPA_SRC/SBC/sbcfwb.F90
r8877 r8879 17 17 USE dom_oce ! ocean space and time domain 18 18 USE sbc_oce ! surface ocean boundary condition 19 USE sbc_ice , ONLY : snwice_mass, snwice_mass_b, snwice_fmass 19 20 USE phycst ! physical constants 20 21 USE sbcrnf ! ocean runoffs … … 94 95 ! and in case of no melt, it can generate HSSW. 95 96 ! 96 #if ! defined key_lim 2 && ! defined key_lim3 && ! defined key_cice97 #if ! defined key_lim3 && ! defined key_cice 97 98 snwice_mass_b(:,:) = 0.e0 ! no sea-ice model is being used : no snow+ice mass 98 99 snwice_mass (:,:) = 0.e0 -
branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/NEMO/OPA_SRC/SBC/sbcice_cice.F90
r8878 r8879 137 137 CALL cice_sbc_force(kt) 138 138 ELSE IF ( ksbc == jp_purecpl ) THEN 139 CALL sbc_cpl_ice_flx( 1.0-fr_i)139 CALL sbc_cpl_ice_flx( fr_i ) 140 140 ENDIF 141 141 … … 230 230 CALL lbc_lnk ( fr_iv , 'V', 1. ) 231 231 232 ! ! embedded sea ice 233 IF( nn_ice_embd /= 0 ) THEN ! mass exchanges between ice and ocean (case 1 or 2) set the snow+ice mass 234 CALL cice2nemo(vsno(:,:,:),ztmp1,'T', 1. ) 235 CALL cice2nemo(vice(:,:,:),ztmp2,'T', 1. ) 236 snwice_mass (:,:) = ( rhosn * ztmp1(:,:) + rhoic * ztmp2(:,:) ) 237 snwice_mass_b(:,:) = snwice_mass(:,:) 238 ELSE 239 snwice_mass (:,:) = 0.0_wp ! no mass exchanges 240 snwice_mass_b(:,:) = 0.0_wp ! no mass exchanges 241 ENDIF 232 ! set the snow+ice mass 233 CALL cice2nemo(vsno(:,:,:),ztmp1,'T', 1. ) 234 CALL cice2nemo(vice(:,:,:),ztmp2,'T', 1. ) 235 snwice_mass (:,:) = ( rhosn * ztmp1(:,:) + rhoic * ztmp2(:,:) ) 236 snwice_mass_b(:,:) = snwice_mass(:,:) 237 242 238 IF( .NOT.ln_rstart ) THEN 243 IF( nn_ice_embd == 2 ) THEN ! full embedment (case 2)deplete the initial ssh below sea-ice area239 IF( ln_ice_embd ) THEN ! embedded sea-ice: deplete the initial ssh below sea-ice area 244 240 sshn(:,:) = sshn(:,:) - snwice_mass(:,:) * r1_rau0 245 241 sshb(:,:) = sshb(:,:) - snwice_mass(:,:) * r1_rau0 … … 477 473 CALL nemo2cice(ztmp,vocn,'F', -1. ) 478 474 479 IF( nn_ice_embd == 2) THEN !== embedded sea ice: compute representative ice top surface ==!475 IF( ln_ice_embd ) THEN !== embedded sea ice: compute representative ice top surface ==! 480 476 ! 481 477 ! average interpolation coeff as used in dynspg = (1/nn_fsbc) * {SUM[n/nn_fsbc], n=0,nn_fsbc-1} … … 680 676 CALL lbc_lnk ( fr_iv , 'V', 1. ) 681 677 682 ! ! embedded sea ice 683 IF( nn_ice_embd /= 0 ) THEN ! mass exchanges between ice and ocean (case 1 or 2) set the snow+ice mass 684 CALL cice2nemo(vsno(:,:,:),ztmp1,'T', 1. ) 685 CALL cice2nemo(vice(:,:,:),ztmp2,'T', 1. ) 686 snwice_mass (:,:) = ( rhosn * ztmp1(:,:) + rhoic * ztmp2(:,:) ) 687 snwice_mass_b(:,:) = snwice_mass(:,:) 688 snwice_fmass (:,:) = ( snwice_mass(:,:) - snwice_mass_b(:,:) ) / dt 689 ENDIF 678 ! set the snow+ice mass 679 CALL cice2nemo(vsno(:,:,:),ztmp1,'T', 1. ) 680 CALL cice2nemo(vice(:,:,:),ztmp2,'T', 1. ) 681 snwice_mass (:,:) = ( rhosn * ztmp1(:,:) + rhoic * ztmp2(:,:) ) 682 snwice_mass_b(:,:) = snwice_mass(:,:) 683 snwice_fmass (:,:) = ( snwice_mass(:,:) - snwice_mass_b(:,:) ) / dt 690 684 691 685 ! Release work space … … 726 720 727 721 DO jl = 1,ncat 728 CALL cice2nemo(vsnon(:,:,jl,:),h t_s(:,:,jl),'T', 1. )729 CALL cice2nemo(vicen(:,:,jl,:),h t_i(:,:,jl),'T', 1. )722 CALL cice2nemo(vsnon(:,:,jl,:),h_s(:,:,jl),'T', 1. ) 723 CALL cice2nemo(vicen(:,:,jl,:),h_i(:,:,jl),'T', 1. ) 730 724 ENDDO 731 725 ! -
branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/NEMO/OPA_SRC/SBC/sbcmod.F90
r8878 r8879 33 33 USE sbcblk ! surface boundary condition: bulk formulation 34 34 USE sbcice_if ! surface boundary condition: ice-if sea-ice model 35 USE sbcice_lim ! surface boundary condition: LIM 3.0 sea-ice model 36 USE sbcice_lim_2 ! surface boundary condition: LIM 2.0 sea-ice model 35 #if defined key_lim3 36 USE icestp ! surface boundary condition: LIM 3.0 sea-ice model 37 #endif 37 38 USE sbcice_cice ! surface boundary condition: CICE sea-ice model 38 39 USE sbcisf ! surface boundary condition: ice-shelf … … 90 91 NAMELIST/namsbc/ nn_fsbc , & 91 92 & ln_usr , ln_flx , ln_blk , & 92 & ln_cpl , ln_mixcpl, nn_components, nn_limflx,&93 & nn_ice , nn_ice_embd, &93 & ln_cpl , ln_mixcpl, ln_meto_cpl , nn_components, & 94 & nn_ice , ln_ice_embd, & 94 95 & ln_traqsr, ln_dm2dc , & 95 96 & ln_rnf , nn_fwb , ln_ssr , ln_isf , ln_apr_dyn , & … … 117 118 #if defined key_agrif 118 119 IF( Agrif_Root() ) THEN ! AGRIF zoom (cf r1242: possibility to run without ice in fine grid) 119 IF( lk_lim2 ) nn_ice = 2 120 IF( lk_lim3 ) nn_ice = 3 121 IF( lk_cice ) nn_ice = 4 120 IF( lk_lim3 ) nn_ice = 2 121 IF( lk_cice ) nn_ice = 3 122 122 ENDIF 123 123 #else 124 IF( lk_lim2 ) nn_ice = 2 125 IF( lk_lim3 ) nn_ice = 3 126 IF( lk_cice ) nn_ice = 4 124 IF( lk_lim3 ) nn_ice = 2 125 IF( lk_cice ) nn_ice = 3 127 126 #endif 128 127 ! … … 138 137 WRITE(numout,*) ' mixed forced-coupled formulation ln_mixcpl = ', ln_mixcpl 139 138 !!gm lk_oasis is controlled by key_oasis3 ===>>> It shoud be removed from the namelist 139 WRITE(numout,*) ' Met Office coupling formulation ln_mixcpl = ', ln_meto_cpl 140 140 WRITE(numout,*) ' OASIS coupling (with atm or sas) lk_oasis = ', lk_oasis 141 141 WRITE(numout,*) ' components of your executable nn_components = ', nn_components 142 WRITE(numout,*) ' Multicategory heat flux formulation (LIM3) nn_limflx = ', nn_limflx143 142 WRITE(numout,*) ' Sea-ice : ' 144 143 WRITE(numout,*) ' ice management in the sbc (=0/1/2/3) nn_ice = ', nn_ice 145 WRITE(numout,*) ' ice -ocean embedded/levitating (=0/1/2) nn_ice_embd = ', nn_ice_embd144 WRITE(numout,*) ' ice embedded into ocean ln_ice_embd = ', ln_ice_embd 146 145 WRITE(numout,*) ' Misc. options of sbc : ' 147 146 WRITE(numout,*) ' Light penetration in temperature Eq. ln_traqsr = ', ln_traqsr … … 201 200 CASE( 0 ) !- no ice in the domain 202 201 CASE( 1 ) !- Ice-cover climatology ("Ice-if" model) 203 CASE( 2 ) !- LIM2 ice model 204 IF( .NOT.( ln_blk .OR. ln_cpl ) ) CALL ctl_stop( 'sbc_init : LIM2 sea-ice model requires ln_blk or ln_cpl = T' ) 205 CASE( 3 ) !- LIM3 ice model 206 IF( nn_ice_embd == 0 ) CALL ctl_stop( 'sbc_init : LIM3 sea-ice models require nn_ice_embd = 1 or 2' ) 207 CASE( 4 ) !- CICE ice model 202 CASE( 2 ) !- LIM3 ice model 203 CASE( 3 ) !- CICE ice model 208 204 IF( .NOT.( ln_blk .OR. ln_cpl ) ) CALL ctl_stop( 'sbc_init : CICE sea-ice model requires ln_blk or ln_cpl = T' ) 209 IF( nn_ice_embd == 0 ) CALL ctl_stop( 'sbc_init : CICE sea-ice models require nn_ice_embd = 1 or 2' )210 205 IF( lk_agrif ) CALL ctl_stop( 'sbc_init : CICE sea-ice model not currently available with AGRIF' ) 211 206 CASE DEFAULT !- not supported 212 207 END SELECT 213 208 ! 214 IF( nn_ice == 3 ) THEN !- LIM3 case: multi-category flux option215 IF(lwp) WRITE(numout,*)216 SELECT CASE( nn_limflx ) ! LIM3 Multi-category heat flux formulation217 CASE ( -1 )218 IF(lwp) WRITE(numout,*) ' LIM3: use per-category fluxes (nn_limflx = -1) '219 IF( ln_cpl ) CALL ctl_stop( 'sbc_init : the chosen nn_limflx for LIM3 in coupled mode must be 0 or 2' )220 CASE ( 0 )221 IF(lwp) WRITE(numout,*) ' LIM3: use average per-category fluxes (nn_limflx = 0) '222 CASE ( 1 )223 IF(lwp) WRITE(numout,*) ' LIM3: use average then redistribute per-category fluxes (nn_limflx = 1) '224 IF( ln_cpl ) CALL ctl_stop( 'sbc_init : the chosen nn_limflx for LIM3 in coupled mode must be 0 or 2' )225 CASE ( 2 )226 IF(lwp) WRITE(numout,*) ' LIM3: Redistribute a single flux over categories (nn_limflx = 2) '227 IF( .NOT.ln_cpl ) CALL ctl_stop( 'sbc_init : the chosen nn_limflx for LIM3 in forced mode cannot be 2' )228 CASE DEFAULT229 CALL ctl_stop( 'sbcmod: LIM3 option, nn_limflx, should be between -1 and 2' )230 END SELECT231 ELSE ! other sea-ice model232 IF( nn_limflx >= 0 ) CALL ctl_warn( 'sbc_init : multi-category flux option (nn_limflx) only available in LIM3' )233 ENDIF234 !235 209 ! !** allocate and set required variables 236 210 ! 237 211 ! !* allocate sbc arrays 238 212 IF( sbc_oce_alloc() /= 0 ) CALL ctl_stop( 'sbc_init : unable to allocate sbc_oce arrays' ) 213 #if ! defined key_lim3 && ! defined key_cice 214 IF( sbc_ice_alloc() /= 0 ) CALL ctl_stop( 'sbc_init : unable to allocate sbc_ice arrays' ) 215 #endif 239 216 ! 240 217 IF( .NOT.ln_isf ) THEN !* No ice-shelf in the domain : allocate and set to zero … … 331 308 IF( ln_ssr ) CALL sbc_ssr_init ! Sea-Surface Restoring initialization 332 309 ! 333 IF( ln_isf ) CALL sbc_isf_init 310 IF( ln_isf ) CALL sbc_isf_init ! Compute iceshelves 334 311 ! 335 312 CALL sbc_rnf_init ! Runof initialization 336 313 ! 337 IF( nn_ice == 3 ) CALL sbc_lim_init ! LIM3 initialization 338 ! 339 IF( nn_ice == 4 ) CALL cice_sbc_init( nsbc ) ! CICE initialization 340 ! 341 IF( ln_wave ) CALL sbc_wave_init ! surface wave initialisation 314 #if defined key_lim3 315 IF ( lk_agrif .AND. nn_ice == 0 ) THEN 316 IF( sbc_ice_alloc() /= 0 ) CALL ctl_stop('STOP', 'sbc_ice_alloc : unable to allocate arrays' ) ! clem2017: allocate ice arrays in case agrif + lim + no-ice in child grid 317 ELSEIF( nn_ice == 2 ) THEN 318 CALL ice_init ! LIM3 initialization 319 ENDIF 320 #endif 321 IF( nn_ice == 3 ) CALL cice_sbc_init( nsbc ) ! CICE initialization 322 ! 323 IF( ln_wave ) CALL sbc_wave_init ! surface wave initialisation 342 324 ! 343 325 END SUBROUTINE sbc_init … … 428 410 ! 429 411 SELECT CASE( nn_ice ) ! Update heat and freshwater fluxes over sea-ice areas 430 CASE( 1 ) ; CALL sbc_ice_if ( kt ) ! Ice-cover climatology ("Ice-if" model) 431 CASE( 2 ) ; CALL sbc_ice_lim_2( kt, nsbc ) ! LIM-2 ice model 432 CASE( 3 ) ; CALL sbc_ice_lim ( kt, nsbc ) ! LIM-3 ice model 433 CASE( 4 ) ; CALL sbc_ice_cice ( kt, nsbc ) ! CICE ice model 412 CASE( 1 ) ; CALL sbc_ice_if ( kt ) ! Ice-cover climatology ("Ice-if" model) 413 #if defined key_lim3 414 CASE( 2 ) ; CALL ice_stp ( kt, nsbc ) ! LIM-3 ice model 415 #endif 416 CASE( 3 ) ; CALL sbc_ice_cice ( kt, nsbc ) ! CICE ice model 434 417 END SELECT 435 418 … … 539 522 !!--------------------------------------------------------------------- 540 523 ! 541 IF( nn_ice == 4) CALL cice_sbc_final524 IF( nn_ice == 3 ) CALL cice_sbc_final 542 525 ! 543 526 END SUBROUTINE sbc_final -
branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/NEMO/OPA_SRC/SBC/sbcssm.F90
r8877 r8879 236 236 ENDIF 237 237 ! 238 IF( .NOT. l_ssm_mean ) THEN ! default initialisation. needed by lim_istate238 IF( .NOT. l_ssm_mean ) THEN ! default initialisation. needed by iceistate 239 239 ! 240 240 IF(lwp) WRITE(numout,*) ' default initialisation of ss._m arrays' -
branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/NEMO/OPA_SRC/SBC/sbcwave.F90
r8877 r8879 137 137 END DO 138 138 END DO 139 CALL lbc_lnk( usd(:,:,:), 'U', vsd(:,:,:), 'V', -1. ) 139 !!gm CALL lbc_lnk( usd(:,:,:), 'U', vsd(:,:,:), 'V', -1. ) 140 CALL lbc_lnk( usd(:,:,:), 'U', -1. ) 141 CALL lbc_lnk( vsd(:,:,:), 'V', -1. ) 142 143 140 144 ! 141 145 ! !== vertical Stokes Drift 3D velocity ==! … … 152 156 END DO 153 157 ! 154 IF( .NOT. AGRIF_Root() ) THEN 155 IF( nbondi == 1 .OR. nbondi == 2 ) ze3divh(nlci-1, : ,:) = 0._wp ! east 156 IF( nbondi == -1 .OR. nbondi == 2 ) ze3divh( 2 , : ,:) = 0._wp ! west 157 IF( nbondj == 1 .OR. nbondj == 2 ) ze3divh( : ,nlcj-1,:) = 0._wp ! north 158 IF( nbondj == -1 .OR. nbondj == 2 ) ze3divh( : , 2 ,:) = 0._wp ! south 159 ENDIF 158 #if defined key_agrif 159 IF( .NOT. Agrif_Root() ) THEN 160 IF( nbondi == -1 .OR. nbondi == 2 ) ze3divh( 2:nbghostcells+1,: ,:) = 0._wp ! west 161 IF( nbondi == 1 .OR. nbondi == 2 ) ze3divh( nlci-nbghostcells:nlci-1,:,:) = 0._wp ! east 162 IF( nbondj == -1 .OR. nbondj == 2 ) ze3divh( :,2:nbghostcells+1 ,:) = 0._wp ! south 163 IF( nbondj == 1 .OR. nbondj == 2 ) ze3divh( :,nlcj-nbghostcells:nlcj-1,:) = 0._wp ! north 164 ENDIF 165 #endif 160 166 ! 161 167 CALL lbc_lnk( ze3divh, 'T', 1. ) -
branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/NEMO/OPA_SRC/TRA/traqsr.F90
r8877 r8879 48 48 LOGICAL , PUBLIC :: ln_qsr_2bd !: 2 band light absorption flag 49 49 LOGICAL , PUBLIC :: ln_qsr_bio !: bio-model light absorption flag 50 LOGICAL , PUBLIC :: ln_qsr_ice !: light penetration for ice-model LIM3 (clem)51 50 INTEGER , PUBLIC :: nn_chldta !: use Chlorophyll data (=1) or not (=0) 52 51 REAL(wp), PUBLIC :: rn_abs !: fraction absorbed in the very near surface (RGB & 2 bands) … … 269 268 END DO 270 269 ! 271 IF( ln_qsr_ice ) THEN ! sea-ice: store the 1st ocean level attenuation coefficient 272 DO jj = 2, jpjm1 273 DO ji = fs_2, fs_jpim1 ! vector opt. 274 IF( qsr(ji,jj) /= 0._wp ) THEN ; fraqsr_1lev(ji,jj) = qsr_hc(ji,jj,1) / ( r1_rau0_rcp * qsr(ji,jj) ) 275 ELSE ; fraqsr_1lev(ji,jj) = 1._wp 276 ENDIF 277 END DO 278 END DO 279 ! Update haloes since lim_thd needs fraqsr_1lev to be defined everywhere 280 CALL lbc_lnk( fraqsr_1lev(:,:), 'T', 1._wp ) 281 ENDIF 270 ! sea-ice: store the 1st ocean level attenuation coefficient 271 DO jj = 2, jpjm1 272 DO ji = fs_2, fs_jpim1 ! vector opt. 273 IF( qsr(ji,jj) /= 0._wp ) THEN ; fraqsr_1lev(ji,jj) = qsr_hc(ji,jj,1) / ( r1_rau0_rcp * qsr(ji,jj) ) 274 ELSE ; fraqsr_1lev(ji,jj) = 1._wp 275 ENDIF 276 END DO 277 END DO 278 CALL lbc_lnk( fraqsr_1lev(:,:), 'T', 1._wp ) 282 279 ! 283 280 IF( iom_use('qsr3d') ) THEN ! output the shortwave Radiation distribution … … 336 333 TYPE(FLD_N) :: sn_chl ! informations about the chlorofyl field to be read 337 334 !! 338 NAMELIST/namtra_qsr/ sn_chl, cn_dir, ln_qsr_rgb, ln_qsr_2bd, ln_qsr_bio, ln_qsr_ice,&335 NAMELIST/namtra_qsr/ sn_chl, cn_dir, ln_qsr_rgb, ln_qsr_2bd, ln_qsr_bio, & 339 336 & nn_chldta, rn_abs, rn_si0, rn_si1 340 337 !!---------------------------------------------------------------------- … … 359 356 WRITE(numout,*) ' 2 band light penetration ln_qsr_2bd = ', ln_qsr_2bd 360 357 WRITE(numout,*) ' bio-model light penetration ln_qsr_bio = ', ln_qsr_bio 361 WRITE(numout,*) ' light penetration for ice-model (LIM3) ln_qsr_ice = ', ln_qsr_ice362 358 WRITE(numout,*) ' RGB : Chl data (=1) or cst value (=0) nn_chldta = ', nn_chldta 363 359 WRITE(numout,*) ' RGB & 2 bands: fraction of light (rn_si1) rn_abs = ', rn_abs -
branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/NEMO/OPA_SRC/USR/usrdef_sbc.F90
r7753 r8879 27 27 28 28 PUBLIC usrdef_sbc_oce ! routine called in sbcmod module 29 PUBLIC usrdef_sbc_ice_tau ! routine called by sbcice_lim.F90 for ice dynamics30 PUBLIC usrdef_sbc_ice_flx ! routine called by sbcice_lim.F90 for ice thermo29 PUBLIC usrdef_sbc_ice_tau ! routine called by icestp.F90 for ice dynamics 30 PUBLIC usrdef_sbc_ice_flx ! routine called by icestp.F90 for ice thermo 31 31 32 32 !! * Substitutions -
branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/NEMO/OPA_SRC/nemogcm.F90
r8878 r8879 141 141 CALL Agrif_Declare_Var_top ! " " " " " TOP 142 142 # endif 143 # if defined key_lim2144 CALL Agrif_Declare_Var_lim2 ! " " " " " LIM2145 # endif146 143 # if defined key_lim3 147 144 CALL Agrif_Declare_Var_lim3 ! " " " " " LIM3 … … 640 637 ! 641 638 IF( numstp /= -1 ) CLOSE( numstp ) ! time-step file 642 IF( num sol /= -1 ) CLOSE( numsol ) ! solverfile639 IF( numrun /= -1 ) CLOSE( numrun ) ! run statistics file 643 640 IF( numnam_ref /= -1 ) CLOSE( numnam_ref ) ! oce reference namelist 644 641 IF( numnam_cfg /= -1 ) CLOSE( numnam_cfg ) ! oce configuration namelist -
branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/NEMO/OPA_SRC/oce.F90
r8877 r8879 65 65 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: rke !: kinetic energy 66 66 67 !! arrays relating to embedding ice in the ocean. These arrays need to be declared68 !! even if no ice model is required. In the no ice model or traditional levitating69 !! ice cases they contain only zeros70 !! ---------------------71 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: snwice_mass !: mass of snow and ice at current ice time step [Kg/m2]72 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: snwice_mass_b !: mass of snow and ice at previous ice time step [Kg/m2]73 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: snwice_fmass !: time evolution of mass of snow+ice [Kg/m2/s]74 75 67 !! Energy budget of the leads (open water embedded in sea ice) 76 68 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fraqsr_1lev !: fraction of solar net radiation absorbed in the first ocean level [-] … … 87 79 !! *** FUNCTION oce_alloc *** 88 80 !!---------------------------------------------------------------------- 89 INTEGER :: ierr( 7)81 INTEGER :: ierr(6) 90 82 !!---------------------------------------------------------------------- 91 83 ! … … 110 102 & riceload(jpi,jpj), STAT=ierr(2) ) 111 103 ! 112 ALLOCATE( snwice_mass(jpi,jpj) , snwice_mass_b(jpi,jpj), snwice_fmass(jpi,jpj) , STAT=ierr(3) ) 113 ! 114 ALLOCATE( fraqsr_1lev(jpi,jpj) , STAT=ierr(4) ) 104 ALLOCATE( fraqsr_1lev(jpi,jpj) , STAT=ierr(3) ) 115 105 ! 116 106 ALLOCATE( ssha_e(jpi,jpj), sshn_e(jpi,jpj), sshb_e(jpi,jpj), sshbb_e(jpi,jpj), & 117 107 & ua_e(jpi,jpj), un_e(jpi,jpj), ub_e(jpi,jpj), ubb_e(jpi,jpj), & 118 108 & va_e(jpi,jpj), vn_e(jpi,jpj), vb_e(jpi,jpj), vbb_e(jpi,jpj), & 119 & hu_e(jpi,jpj), hur_e(jpi,jpj), hv_e(jpi,jpj), hvr_e(jpi,jpj), STAT=ierr( 5) )109 & hu_e(jpi,jpj), hur_e(jpi,jpj), hv_e(jpi,jpj), hvr_e(jpi,jpj), STAT=ierr(4) ) 120 110 ! 121 ALLOCATE( ub2_b(jpi,jpj), vb2_b(jpi,jpj) , STAT=ierr( 6) )111 ALLOCATE( ub2_b(jpi,jpj), vb2_b(jpi,jpj) , STAT=ierr(5) ) 122 112 #if defined key_agrif 123 ALLOCATE( ub2_i_b(jpi,jpj), vb2_i_b(jpi,jpj) , STAT=ierr( 7) )113 ALLOCATE( ub2_i_b(jpi,jpj), vb2_i_b(jpi,jpj) , STAT=ierr(6) ) 124 114 #endif 125 115 ! -
branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/NEMO/OPA_SRC/step.F90
r8878 r8879 61 61 !! *** ROUTINE stp *** 62 62 !! 63 !! ** Purpose : - Time stepping of OPA (momentum and active tracer eqs.)64 !! - Time stepping of LIM (dynamic and thermodynamic eqs.)65 !! - T me stepping of TRC(passive tracer eqs.)63 !! ** Purpose : - Time stepping of OPA (momentum and active tracer eqs.) 64 !! - Time stepping of ESIM (dynamic and thermodynamic eqs.) 65 !! - Time stepping of TRC (passive tracer eqs.) 66 66 !! 67 67 !! ** Method : -1- Update forcings and data -
branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/NEMO/OPA_SRC/stpctl.F90
r8877 r8879 9 9 !! NEMO 1.0 ! 2002-06 (G. Madec) F90: Free form and module 10 10 !! 2.0 ! 2009-07 (G. Madec) Add statistic for time-spliting 11 !! 3.7 ! 2016-09 (G. Madec) Remove solver 12 !! 4.0 ! 2017-04 (G. Madec) regroup global communications 11 13 !!---------------------------------------------------------------------- 12 14 … … 21 23 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 22 24 USE lib_mpp ! distributed memory computing 23 USE lib_fortran ! Fortran routines library24 25 25 26 IMPLICIT NONE … … 42 43 !! ** Method : - Save the time step in numstp 43 44 !! - Print it each 50 time steps 44 !! - Stop the run IF problem ( indic < 0 ) 45 !! - Stop the run IF problem encountered by setting indic=-3 46 !! Problems checked: |ssh| maximum larger than 10 m 47 !! |U| maximum larger than 10 m/s 48 !! negative sea surface salinity 45 49 !! 46 !! ** Actions : 'time.step' file containing thelast ocean time-step47 !! 50 !! ** Actions : "time.step" file = last ocean time-step 51 !! "run.stat" file = run statistics 48 52 !!---------------------------------------------------------------------- 49 53 INTEGER, INTENT(in ) :: kt ! ocean time-step index … … 51 55 !! 52 56 INTEGER :: ji, jj, jk ! dummy loop indices 53 INTEGER :: ii, ij, ik ! local integers 54 REAL(wp) :: zumax, zsmin, zssh2, zsshmax ! local scalars 55 INTEGER, DIMENSION(3) :: ilocu ! 56 INTEGER, DIMENSION(2) :: ilocs ! 57 INTEGER :: iih, ijh ! local integers 58 INTEGER :: iiu, iju, iku ! - - 59 INTEGER :: iis, ijs ! - - 60 REAL(wp) :: zzz ! local real 61 INTEGER , DIMENSION(3) :: ilocu 62 INTEGER , DIMENSION(2) :: ilocs, iloch 63 REAL(wp), DIMENSION(3) :: zmax 57 64 !!---------------------------------------------------------------------- 58 65 ! … … 61 68 WRITE(numout,*) 'stp_ctl : time-stepping control' 62 69 WRITE(numout,*) '~~~~~~~' 63 ! open time.step file70 ! ! open time.step file 64 71 CALL ctl_opn( numstp, 'time.step', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea ) 72 ! ! open run.stat file 73 CALL ctl_opn( numrun, 'run.stat', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea ) 65 74 ENDIF 66 75 ! 67 IF(lwp) WRITE ( numstp, '(1x, i8)' ) kt !* save the current time step in numstp 68 IF(lwp) REWIND( numstp ) ! -------------------------- 76 IF(lwp) THEN !== current time step ==! ("time.step" file) 77 WRITE ( numstp, '(1x, i8)' ) kt 78 REWIND( numstp ) 79 ENDIF 69 80 ! 70 ! !* Test maximum of velocity (zonal only) 71 ! ! ------------------------ 72 !! zumax = MAXVAL( ABS( un(:,:,:) ) ) ! slower than the following loop on NEC SX5 73 zumax = 0.e0 74 DO jk = 1, jpk 75 DO jj = 1, jpj 76 DO ji = 1, jpi 77 zumax = MAX(zumax,ABS(un(ji,jj,jk))) 78 END DO 79 END DO 80 END DO 81 IF( lk_mpp ) CALL mpp_max( zumax ) ! max over the global domain 81 ! !== test of extrema ==! 82 zmax(1) = MAXVAL( ABS( sshn(:,:) ) ) ! ssh max 83 zmax(2) = MAXVAL( ABS( un(:,:,:) ) ) ! velocity max (zonal only) 84 zmax(3) = MAXVAL( -tsn(:,:,1,jp_sal) , mask = tmask(:,:,1) == 1._wp ) ! minus surface salinity max 82 85 ! 83 IF( MOD( kt, nwrite ) == 1 .AND. lwp ) WRITE(numout,*) ' ==>> time-step= ',kt,' abs(U) max: ', zumax86 IF( lk_mpp ) CALL mpp_max_multiple( zmax(:), 3 ) ! max over the global domain 84 87 ! 85 IF( zumax > 20.e0 ) THEN 88 IF( MOD( kt, nwrite ) == 1 .AND. lwp ) THEN 89 WRITE(numout,*) ' ==>> time-step= ', kt, ' |ssh| max: ', zmax(1), ' |U| max: ', zmax(2), & 90 & ' SSS min: ' , - zmax(3) 91 ENDIF 92 ! 93 IF ( zmax(1) > 10._wp .OR. & ! too large sea surface height ( > 10 m) 94 & zmax(2) > 10._wp .OR. & ! too large velocity ( > 10 m/s) 95 & zmax(3) > 0._wp ) THEN ! negative sea surface salinity 86 96 IF( lk_mpp ) THEN 87 CALL mpp_maxloc(ABS(un),umask,zumax,ii,ij,ik) 97 CALL mpp_maxloc( ABS(sshn) , tmask(:,:,1), zzz, iih, ijh ) 98 CALL mpp_maxloc( ABS(un) , umask , zzz, iiu, iju, iku ) 99 CALL mpp_minloc( tsn(:,:,1,jp_sal), tmask(:,:,1), zzz, iis, ijs ) 88 100 ELSE 101 iloch = MINLOC( ABS( sshn(:,:) ) ) 89 102 ilocu = MAXLOC( ABS( un(:,:,:) ) ) 90 ii = ilocu(1) + nimpp - 1 91 ij = ilocu(2) + njmpp - 1 92 ik = ilocu(3) 103 ilocs = MINLOC( tsn(:,:,1,jp_sal), mask = tmask(:,:,1) == 1._wp ) 104 iih = iloch(1) + nimpp - 1 ; ijh = iloch(2) + njmpp - 1 105 iiu = ilocu(1) + nimpp - 1 ; iju = ilocu(2) + njmpp - 1 ; iku = ilocu(3) 106 iis = ilocs(1) + nimpp - 1 ; ijs = ilocs(2) + njmpp - 1 93 107 ENDIF 94 108 IF(lwp) THEN 95 109 WRITE(numout,cform_err) 96 WRITE(numout,*) ' stpctl: the zonal velocity is larger than 20 m/s'110 WRITE(numout,*) ' stpctl: |ssh| > 10 m or |U| > 10 m/s or SSS < 0' 97 111 WRITE(numout,*) ' ====== ' 98 WRITE(numout,9400) kt, zumax, ii, ij, ik 112 WRITE(numout,9100) kt, zmax(1), iih, ijh 113 WRITE(numout,9200) kt, zmax(2), iiu, iju, iku 114 WRITE(numout,9300) kt, - zmax(3), iis, ijs 99 115 WRITE(numout,*) 100 WRITE(numout,*) ' output of last fields in numwso'116 WRITE(numout,*) ' output of last computed fields in output.abort.nc file' 101 117 ENDIF 102 118 kindic = -3 103 119 ENDIF 104 9400 FORMAT (' kt=',i6,' max abs(U): ',1pg11.4,', i j k: ',3i5) 120 9100 FORMAT (' kt=',i8,' |ssh| max: ',1pg11.4,', at i j : ',2i5) 121 9200 FORMAT (' kt=',i8,' |U| max: ',1pg11.4,', at i j k: ',3i5) 122 9300 FORMAT (' kt=',i8,' SSS min: ',1pg11.4,', at i j : ',2i5) 105 123 ! 106 ! !* Test minimum of salinity 107 ! ! ------------------------ 108 !! zsmin = MINVAL( tsn(:,:,1,jp_sal), mask = tmask(:,:,1) == 1.e0 ) slower than the following loop on NEC SX5 109 zsmin = 100._wp 110 DO jj = 2, jpjm1 111 DO ji = 1, jpi 112 IF( tmask(ji,jj,1) == 1) zsmin = MIN(zsmin,tsn(ji,jj,1,jp_sal)) 113 END DO 114 END DO 115 IF( lk_mpp ) CALL mpp_min( zsmin ) ! min over the global domain 124 ! !== run statistics ==! ("run.stat" file) 125 IF(lwp) WRITE(numrun,9400) kt, zmax(1), zmax(2), - zmax(3) 116 126 ! 117 IF( MOD( kt, nwrite ) == 1 .AND. lwp ) WRITE(numout,*) ' ==>> time-step= ',kt,' SSS min:', zsmin 118 ! 119 IF( zsmin < 0.) THEN 120 IF (lk_mpp) THEN 121 CALL mpp_minloc ( tsn(:,:,1,jp_sal),tmask(:,:,1), zsmin, ii,ij ) 122 ELSE 123 ilocs = MINLOC( tsn(:,:,1,jp_sal), mask = tmask(:,:,1) == 1.e0 ) 124 ii = ilocs(1) + nimpp - 1 125 ij = ilocs(2) + njmpp - 1 126 ENDIF 127 ! 128 IF(lwp) THEN 129 WRITE(numout,cform_err) 130 WRITE(numout,*) 'stp_ctl : NEGATIVE sea surface salinity' 131 WRITE(numout,*) '======= ' 132 WRITE(numout,9500) kt, zsmin, ii, ij 133 WRITE(numout,*) 134 WRITE(numout,*) ' output of last fields in numwso' 135 ENDIF 136 kindic = -3 137 ENDIF 138 9500 FORMAT (' kt=',i6,' min SSS: ',1pg11.4,', i j: ',2i5) 139 ! 140 ! 141 IF( lk_c1d ) RETURN ! No log file in case of 1D vertical configuration 142 143 ! log file (ssh statistics) 144 ! -------- !* ssh statistics (and others...) 145 IF( kt == nit000 .AND. lwp ) THEN ! open ssh statistics file (put in solver.stat file) 146 CALL ctl_opn( numsol, 'solver.stat', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea ) 147 ENDIF 148 ! 149 zsshmax = 0.e0 150 DO jj = 1, jpj 151 DO ji = 1, jpi 152 IF( tmask(ji,jj,1) == 1) zsshmax = MAX( zsshmax, ABS(sshn(ji,jj)) ) 153 END DO 154 END DO 155 IF( lk_mpp ) CALL mpp_max( zsshmax ) ! min over the global domain 156 ! 157 IF( MOD( kt, nwrite ) == 1 .AND. lwp ) WRITE(numout,*) ' ==>> time-step= ',kt,' ssh max:', zsshmax 158 ! 159 IF( zsshmax > 10.e0 ) THEN 160 IF (lk_mpp) THEN 161 CALL mpp_maxloc( ABS(sshn(:,:)),tmask(:,:,1),zsshmax,ii,ij) 162 ELSE 163 ilocs = MAXLOC( ABS(sshn(:,:)) ) 164 ii = ilocs(1) + nimpp - 1 165 ij = ilocs(2) + njmpp - 1 166 ENDIF 167 ! 168 IF(lwp) THEN 169 WRITE(numout,cform_err) 170 WRITE(numout,*) 'stp_ctl : the ssh is larger than 10m' 171 WRITE(numout,*) '======= ' 172 WRITE(numout,9600) kt, zsshmax, ii, ij 173 WRITE(numout,*) 174 WRITE(numout,*) ' output of last fields in numwso' 175 ENDIF 176 kindic = -3 177 ENDIF 178 9600 FORMAT (' kt=',i6,' max ssh: ',1pg11.4,', i j: ',2i5) 179 ! 180 zssh2 = glob_sum( sshn(:,:) * sshn(:,:) ) 181 ! 182 IF(lwp) WRITE(numsol,9700) kt, zssh2, zumax, zsmin ! ssh statistics 183 ! 184 9700 FORMAT(' it :', i8, ' ssh2: ', d23.16, ' Umax: ',d23.16,' Smin: ',d23.16) 127 9400 FORMAT(' it :', i8, ' |ssh|_max: ', e16.10, ' |U|_max: ',e16.10,' SSS_min: ',e16.10) 185 128 ! 186 129 END SUBROUTINE stp_ctl -
branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/NEMO/SAS_SRC/diawri.F90
r8877 r8879 38 38 USE iom 39 39 USE ioipsl 40 #if defined key_lim2 41 USE limwri_2 42 #elif defined key_lim3 43 USE limwri 40 #if defined key_lim3 41 USE icewri 44 42 #endif 45 43 USE lib_mpp ! MPP library … … 397 395 & jpi, jpj, nh_i, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) 398 396 399 #if defined key_lim 2400 CALL lim_wri_state_2( kt, id_i, nh_i )401 #elif defined key_lim3 402 CALL lim_wri_state( kt, id_i, nh_i )397 #if defined key_lim3 398 IF( nn_ice == 2 ) THEN ! clem2017: condition in case agrif + lim but no-ice in child grid 399 CALL ice_wri_state( kt, id_i, nh_i ) 400 ENDIF 403 401 #else 404 402 CALL histend( id_i, snc4chunks=snc4set ) -
branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/NEMO/SAS_SRC/nemogcm.F90
r8877 r8879 86 86 CALL Agrif_Declare_Var_top ! " " " " " TOP 87 87 # endif 88 # if defined key_lim289 CALL Agrif_Declare_Var_lim2 ! " " " " " LIM90 # endif91 88 # if defined key_lim3 92 89 CALL Agrif_Declare_Var_lim3 ! " " " " " LIM3 … … 134 131 ! 135 132 #if defined key_agrif 136 IF( .NOT. Agrif_Root() ) THEN133 !!clem2017 IF( .NOT. Agrif_Root() ) THEN 137 134 CALL Agrif_ParentGrid_To_ChildGrid() 138 135 IF( nn_timing == 1 ) CALL timing_finalize 139 136 CALL Agrif_ChildGrid_To_ParentGrid() 140 ENDIF137 !!clem2017 ENDIF 141 138 #endif 142 139 IF( nn_timing == 1 ) CALL timing_finalize … … 513 510 ierr = dia_wri_alloc () 514 511 ierr = ierr + dom_oce_alloc () ! ocean domain 515 ierr = ierr + oce_alloc () ! (tsn...) needed for agrif and/or lim3and bdy512 ierr = ierr + oce_alloc () ! (tsn...) needed for agrif and/or ESIM and bdy 516 513 ierr = ierr + bdy_oce_alloc () ! bdy masks (incl. initialization) 517 514 ! -
branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/NEMO/SAS_SRC/sbcssm.F90
r8877 r8879 115 115 ELSE 116 116 sst_m(:,:) = 0._wp 117 sss_m(:,:) = 0._wp117 sss_m(:,:) = 35._wp 118 118 ssu_m(:,:) = 0._wp 119 119 ssv_m(:,:) = 0._wp … … 313 313 ENDIF 314 314 315 CALL sbc_ssm( nit000 ) ! need to define ss?_m arrays used in limistate315 CALL sbc_ssm( nit000 ) ! need to define ss?_m arrays used in iceistate 316 316 l_initdone = .TRUE. 317 317 ! -
branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/NEMO/SAS_SRC/step.F90
r8877 r8879 24 24 USE diawri ! Standard run outputs (dia_wri routine) 25 25 USE bdy_oce , ONLY: ln_bdy 26 USE bdydta ! clem: mandatory for LIM326 USE bdydta ! clem: mandatory for ESIM 27 27 USE stpctl ! time stepping control (stp_ctl routine) 28 28 ! … … 89 89 CALL iom_setkt( kstp - nit000 + 1, cxios_context ) ! tell iom we are at time step kstp 90 90 91 ! ==> clem: open boundaries is mandatory for LIM3because ice BDY is not decoupled from91 ! ==> clem: open boundaries is mandatory for ESIM because ice BDY is not decoupled from 92 92 ! the environment of ocean BDY. Therefore bdy is called in both OPA and SAS modules. 93 93 ! From SAS: ocean bdy data are wrong (but we do not care) and ice bdy data are OK. -
branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/NEMO/TOP_SRC/TRP/trcsbc.F90
r8877 r8879 63 63 INTEGER :: ji, jj, jn ! dummy loop indices 64 64 REAL(wp) :: zse3t, zrtrn, zratio, zfact ! temporary scalars 65 REAL(wp) :: z switch, zftra, zcd, zdtra, ztfx, ztra! temporary scalars65 REAL(wp) :: zftra, zcd, zdtra, ztfx, ztra ! temporary scalars 66 66 CHARACTER (len=22) :: charout 67 67 REAL(wp), POINTER, DIMENSION(:,: ) :: zsfx … … 77 77 ! 78 78 zrtrn = 1.e-15_wp 79 80 SELECT CASE( nn_ice_embd ) ! levitating or embedded sea-ice option81 CASE( 0 ) ; zswitch = 1 ! (0) standard levitating sea-ice : salt exchange only82 CASE( 1, 2 ) ; zswitch = 0 ! (1) levitating sea-ice: salt and volume exchange but no pressure effect83 ! ! (2) embedded sea-ice : salt and volume fluxes and pressure84 END SELECT85 79 86 80 IF( kt == nittrc000 ) THEN … … 145 139 ! tracer flux only : add concentration dilution term in net tracer flux, no F-M in volume flux 146 140 ! tracer and mass fluxes : no concentration dilution term in net tracer flux, F-M term in volume flux 147 ztfx = zftra + zswitch * zcd ! net tracer flux (+C/D if no ice/ocean mass exchange)141 ztfx = zftra ! net tracer flux 148 142 149 143 zdtra = r1_rau0 * ( ztfx + zsfx(ji,jj) * trn(ji,jj,1,jn) ) -
branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/NEMO/TOP_SRC/oce_trc.F90
r8877 r8879 63 63 USE sbc_oce , ONLY : ln_rnf => ln_rnf !: runoffs / runoff mouths 64 64 USE sbc_oce , ONLY : fr_i => fr_i !: ice fraction (between 0 to 1) 65 USE sbc_oce , ONLY : nn_ice_embd => nn_ice_embd !: flag for levitating/embedding sea-ice in the ocean66 65 USE sbc_oce , ONLY : atm_co2 => atm_co2 ! atmospheric pCO2 67 66 USE traqsr , ONLY : rn_abs => rn_abs !: fraction absorbed in the very near surface -
branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/NEMO/TOP_SRC/trc.F90
r8877 r8879 172 172 CHARACTER(len=20), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: cn_trc ! Choice of boundary condition for tracers 173 173 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nn_trcdmp_bdy !: =T Tracer damping 174 !$AGRIF_DO_NOT_TREAT 174 175 ! External data structure of BDY for TOP. Available elements: cn_obc, ll_trc, trcnow, dmp 175 176 TYPE(OBC_DATA), PUBLIC, ALLOCATABLE, DIMENSION(:,:), TARGET :: trcdta_bdy !: bdy external data (local process) 176 ! 177 177 !$AGRIF_END_DO_NOT_TREAT 178 178 !!---------------------------------------------------------------------- 179 179 !! NEMO/TOP 3.3.1 , NEMO Consortium (2010) -
branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/SETTE/BATCH_TEMPLATE/batch-X64_ADA
r7715 r8879 11 11 # @ total_tasks = NPROCS 12 12 # time 13 # @ wall_clock_limit = 1:30:0013 # @ wall_clock_limit = 00:59:00 14 14 # @ queue 15 15 -
branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/SETTE/BATCH_TEMPLATE/batch-X64_MOBILIS
r7646 r8879 8 8 module load intel/compiler/64/14.0/2013_sp1.2.144 9 9 module load openmpi/intel/64/1.6.5 10 module load slurm/ 2.5.710 module load slurm/16.05.8 11 11 12 12 # -
branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/SETTE/README
r7646 r8879 45 45 INPUT_DIR : directory in which store input files (tar file) 46 46 TMPDIR : temporary directory NEEDED ONLY FOR IBM machines (put EXP00 directory) 47 NEMO_VALIDATION_DIR : directory in which create NEMO_VALIDATION tree, and store restart, solver.stat, tracer.stat and ocean.output files in47 NEMO_VALIDATION_DIR : directory in which create NEMO_VALIDATION tree, and store restart, run.stat, tracer.stat and ocean.output files in 48 48 tree NEMO_VALIDATION_DIR/WCONFIG_NAME/WCOMPILER_NAME/TEST_NAME/REVISION_NUMBER(or DATE) 49 49 in fcm_job.sh : -
branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/SETTE/all_functions.sh
r8877 r8879 219 219 fi 220 220 # Save output & debug files in NEMO_VALIDATION tree 221 echo "saving ocean & ice output, solver.stat, tracer.stat files ...." >> ${SETTE_DIR}/output.sette221 echo "saving ocean & ice output, run.stat, tracer.stat files ...." >> ${SETTE_DIR}/output.sette 222 222 echo " " >> ${SETTE_DIR}/output.sette 223 223 [ -f ${EXE_DIR}/ocean.output ] && cp ${EXE_DIR}/*ocean.output ${NEMO_VALID}/. 224 [ -f ${EXE_DIR}/ solver.stat ] && cp ${EXE_DIR}/*solver.stat ${NEMO_VALID}/.224 [ -f ${EXE_DIR}/run.stat ] && cp ${EXE_DIR}/*run.stat ${NEMO_VALID}/. 225 225 [ -f ${EXE_DIR}/output.namelist.dyn ] && cp ${EXE_DIR}/*output.nam* ${NEMO_VALID}/. 226 226 [ -f ${EXE_DIR}/tracer.stat ] && cp ${EXE_DIR}/*tracer.stat ${NEMO_VALID}/. 227 227 228 if [ -n "$(ls ${NEMO_VALID}/* solver*)" ] ; then229 echo "moved solver.stat in ${NEMO_VALID} directory" >> ${SETTE_DIR}/output.sette230 echo "moved solver.stat in ${NEMO_VALID} directory"228 if [ -n "$(ls ${NEMO_VALID}/*run*)" ] ; then 229 echo "moved run.stat in ${NEMO_VALID} directory" >> ${SETTE_DIR}/output.sette 230 echo "moved run.stat in ${NEMO_VALID} directory" 231 231 else 232 echo "problem in looking for solver.stat file in ${NEMO_VALID} directory" >> ${SETTE_DIR}/output.sette233 echo " solver.stat IS NOT in ${NEMO_VALID} directory"232 echo "problem in looking for run.stat file in ${NEMO_VALID} directory" >> ${SETTE_DIR}/output.sette 233 echo "run.stat IS NOT in ${NEMO_VALID} directory" 234 234 fi 235 235 if [ -n "$(ls ${NEMO_VALID}/*ocean.output*)" ] ; then -
branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/SETTE/sette.sh
r7756 r8879 56 56 # set_namelist : function declared in all_functions that sets namelist parameters 57 57 # post_test_tidyup : creates validation storage directory and copies required output files 58 # ( solver.stat and ocean.output) in it after execution of test.58 # (run.stat and ocean.output) in it after execution of test. 59 59 # 60 60 # VALIDATION tree is: … … 137 137 # ORCA2_OFF_PISCES : 5 & 6 138 138 # AMM12 : 7 & 8 139 # SAS : 9 fos SAS there is no solverso is useless to test REPRO139 # SAS : 9 fos SAS there is no run.stat so is useless to test REPRO 140 140 # ISOMIP : 10 & 11 141 141 # ORCA2_LIM3_OBS : 12 … … 143 143 # 15 & 16 144 144 145 for config in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 145 for config in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 146 146 147 147 do … … 312 312 set_namelist namelist_cfg jpnj 8 313 313 set_namelist namelist_cfg jpnij 32 314 set_namelist namelist_ice_cfg ln_icediachk .true. 315 ## set_namelist namelist_ice_cfg ln_icediahsb .true. 314 316 set_namelist namelist_top_cfg ln_trcdta .false. 315 317 # put ln_ironsed, ln_river, ln_ndepo, ln_dust to false … … 350 352 set_namelist namelist_cfg jpnj 8 351 353 set_namelist namelist_cfg jpnij 32 354 set_namelist namelist_ice_cfg ln_icediachk .true. 355 ## set_namelist namelist_ice_cfg ln_icediahsb .true. 352 356 set_namelist namelist_top_cfg ln_rsttr .true. 353 357 set_namelist namelist_top_cfg nn_rsttr 2 … … 411 415 set_namelist namelist_cfg jpnj 8 412 416 set_namelist namelist_cfg jpnij 32 417 set_namelist namelist_ice_cfg ln_icediachk .true. 418 set_namelist namelist_ice_cfg ln_icediahsb .true. 413 419 set_namelist namelist_top_cfg ln_trcdta .false. 414 420 # put ln_ironsed, ln_river, ln_ndepo, ln_dust to false … … 452 458 set_namelist namelist_cfg jpnj 4 453 459 set_namelist namelist_cfg jpnij 32 460 set_namelist namelist_ice_cfg ln_icediachk .true. 461 set_namelist namelist_ice_cfg ln_icediahsb .true. 454 462 set_namelist namelist_top_cfg ln_trcdta .false. 455 463 # put ln_ironsed, ln_river, ln_ndepo, ln_dust to false … … 661 669 export TEST_NAME="LONG" 662 670 cd ${CONFIG_DIR0} 663 . ./makenemo -m ${CMP_NAM} -n AMM12_LONG -r AMM12 -j 8 add_key "key_tide"del_key ${DEL_KEYS}671 . ./makenemo -m ${CMP_NAM} -n AMM12_LONG -r AMM12 -j 8 del_key ${DEL_KEYS} 664 672 cd ${SETTE_DIR} 665 673 . ./param.cfg … … 810 818 set_namelist namelist_cfg jpnj 8 811 819 set_namelist namelist_cfg jpnij 32 820 set_namelist namelist_ice_cfg ln_icediachk .true. 812 821 if [ ${USING_MPMD} == "yes" ] ; then 813 822 set_xio_using_server iodef.xml true … … 835 844 set_namelist namelist_cfg ln_rstart .true. 836 845 set_namelist namelist_cfg nn_rstctl 2 846 set_namelist namelist_ice_cfg ln_icediachk .true. 837 847 set_namelist namelist_ice_cfg cn_icerst_in \"SAS_00000050_restart_ice\" 838 848 if [ ${USING_MPMD} == "yes" ] ; then … … 1121 1131 set_namelist 1_namelist_cfg nn_it000 1 1122 1132 set_namelist 1_namelist_cfg nn_itend 150 1133 set_namelist 1_namelist_cfg nn_fsbc 1 1123 1134 set_namelist 1_namelist_cfg ln_ctl .false. 1124 1135 set_namelist 1_namelist_cfg ln_clobber .true. … … 1219 1230 export TEST_NAME="LONG" 1220 1231 cd ${CONFIG_DIR0} 1221 . ./makenemo -m ${CMP_NAM} -n ORCA2AGUL_LONG -r ORCA2_LIM3_PISCES -d "OPA_SRC LIM_SRC_3 NST_SRC" -j 8 add_key "key_agrif " del_key "key_zdftmxkey_top"1232 . ./makenemo -m ${CMP_NAM} -n ORCA2AGUL_LONG -r ORCA2_LIM3_PISCES -d "OPA_SRC LIM_SRC_3 NST_SRC" -j 8 add_key "key_agrif key_zdftmx" del_key "key_zdftmx_new key_top" 1222 1233 cd ${SETTE_DIR} 1223 1234 . ./param.cfg … … 1245 1256 set_namelist 1_namelist_cfg nn_itend 300 1246 1257 set_namelist 1_namelist_cfg nn_stock 150 1258 set_namelist 1_namelist_cfg nn_fsbc 1 1247 1259 set_namelist 1_namelist_cfg ln_ctl .false. 1248 1260 set_namelist 1_namelist_cfg ln_clobber .true. … … 1283 1295 set_namelist 1_namelist_cfg nn_itend 300 1284 1296 set_namelist 1_namelist_cfg nn_stock 150 1297 set_namelist 1_namelist_cfg nn_fsbc 1 1285 1298 set_namelist 1_namelist_cfg ln_rstart .true. 1286 1299 set_namelist 1_namelist_cfg nn_rstctl 2 … … 1293 1306 set_namelist namelist_ice_cfg cn_icerst_in \"O2LP_LONG_00000075_restart_ice\" 1294 1307 set_namelist 1_namelist_cfg cn_ocerst_in \"O2LP_LONG_00000150_restart\" 1308 set_namelist 1_namelist_ice_cfg cn_icerst_in \"O2LP_LONG_00000150_restart_ice\" 1295 1309 1296 1310 for (( i=1; i<=$NPROC; i++)) ; do … … 1300 1314 ln -sf ../LONG/O2LP_LONG_00000075_restart_ice_${L_NPROC}.nc . 1301 1315 ln -sf ../LONG/1_O2LP_LONG_00000150_restart_${L_NPROC}.nc . 1316 ln -sf ../LONG/1_O2LP_LONG_00000150_restart_ice_${L_NPROC}.nc . 1302 1317 done 1303 1318 if [ ${USING_MPMD} == "yes" ] ; then … … 1316 1331 export TEST_NAME="REPRO_4_4" 1317 1332 cd ${CONFIG_DIR0} 1318 . ./makenemo -m ${CMP_NAM} -n ORCA2AGUL_16 -r ORCA2_LIM3_PISCES -d "OPA_SRC LIM_SRC_3 NST_SRC" -j 8 add_key "key_agrif " del_key "key_zdftmxkey_top"1333 . ./makenemo -m ${CMP_NAM} -n ORCA2AGUL_16 -r ORCA2_LIM3_PISCES -d "OPA_SRC LIM_SRC_3 NST_SRC" -j 8 add_key "key_agrif key_zdftmx" del_key "key_zdftmx_new key_top" 1319 1334 cd ${SETTE_DIR} 1320 1335 . ./param.cfg … … 1339 1354 set_namelist 1_namelist_cfg nn_it000 1 1340 1355 set_namelist 1_namelist_cfg nn_itend 150 1356 set_namelist 1_namelist_cfg nn_fsbc 1 1341 1357 set_namelist 1_namelist_cfg ln_ctl .false. 1342 1358 set_namelist 1_namelist_cfg ln_clobber .true. … … 1378 1394 set_namelist 1_namelist_cfg nn_itend 150 1379 1395 set_namelist 1_namelist_cfg ln_ctl .false. 1396 set_namelist 1_namelist_cfg nn_fsbc 1 1380 1397 set_namelist 1_namelist_cfg ln_clobber .true. 1381 1398 set_namelist 1_namelist_cfg ln_read_cfg .true. -
branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/SETTE/sette_beginner.sh
r4796 r8879 55 55 # set_namelist : function declared in all_functions that sets namelist parameters 56 56 # post_test_tidyup : creates validation storage directory and copies required output files 57 # ( solver.stat and ocean.output) in it after execution of test.57 # (run.stat and ocean.output) in it after execution of test. 58 58 # 59 59 # VALIDATION tree is: -
branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/SETTE/sette_rpt.sh
r7715 r8879 1 1 #!/bin/bash -f 2 2 # 3 # set -vx 3 4 # simple SETTE report generator. 4 5 # … … 23 24 dorv=`echo $dorv | sed -e 's:.*/::'` 24 25 f1o=$vdir/$nam/$mach/$dorv/LONG/ocean.output 25 f1s=$vdir/$nam/$mach/$dorv/LONG/ solver.stat26 f1s=$vdir/$nam/$mach/$dorv/LONG/run.stat 26 27 f1t=$vdir/$nam/$mach/$dorv/LONG/tracer.stat 27 28 f2o=$vdir/$nam/$mach/$dorv/SHORT/ocean.output 28 f2s=$vdir/$nam/$mach/$dorv/SHORT/ solver.stat29 f2s=$vdir/$nam/$mach/$dorv/SHORT/run.stat 29 30 f2t=$vdir/$nam/$mach/$dorv/SHORT/tracer.stat 30 31 … … 46 47 if [ $? == 0 ]; then 47 48 if [ $pass == 0 ]; then 48 printf "%-20s %s %s\n" $nam " solver.statrestartability passed : " $dorv49 fi 50 else 51 printf "%-20s %s %s\n" $nam " solver.statrestartability FAILED : " $dorv52 # 53 # Offer view of differences on the second pass 54 # 55 if [ $pass == 1 ]; then 56 echo "<return> to view solver.stat differences"49 printf "%-20s %s %s\n" $nam " run.stat restartability passed : " $dorv 50 fi 51 else 52 printf "%-20s %s %s\n" $nam " run.stat restartability FAILED : " $dorv 53 # 54 # Offer view of differences on the second pass 55 # 56 if [ $pass == 1 ]; then 57 echo "<return> to view run.stat differences" 57 58 read y 58 59 sdiff f1.tmp$$ $f2s … … 118 119 rep2=`ls -1rt $vdir/$nam/$mach/$dorv/ | tail -1l` 119 120 f1o=$vdir/$nam/$mach/$dorv/$rep1/ocean.output 120 f1s=$vdir/$nam/$mach/$dorv/$rep1/ solver.stat121 f1s=$vdir/$nam/$mach/$dorv/$rep1/run.stat 121 122 f1t=$vdir/$nam/$mach/$dorv/$rep1/tracer.stat 122 123 f2o=$vdir/$nam/$mach/$dorv/$rep2/ocean.output 123 f2s=$vdir/$nam/$mach/$dorv/$rep2/ solver.stat124 f2s=$vdir/$nam/$mach/$dorv/$rep2/run.stat 124 125 f2t=$vdir/$nam/$mach/$dorv/$rep2/tracer.stat 125 126 … … 139 140 if [ $? == 0 ]; then 140 141 if [ $pass == 0 ]; then 141 printf "%-20s %s %s\n" $nam " solver.statreproducibility passed : " $dorv142 fi 143 else 144 printf "%-20s %s %s\n" $nam " solver.statreproducibility FAILED : " $dorv145 # 146 # Offer view of differences on the second pass 147 # 148 if [ $pass == 1 ]; then 149 echo "<return> to view solver.stat differences"142 printf "%-20s %s %s\n" $nam " run.stat reproducibility passed : " $dorv 143 fi 144 else 145 printf "%-20s %s %s\n" $nam " run.stat reproducibility FAILED : " $dorv 146 # 147 # Offer view of differences on the second pass 148 # 149 if [ $pass == 1 ]; then 150 echo "<return> to view run.stat differences" 150 151 read y 151 152 sdiff f1.tmp$$ $f2s … … 199 200 mach=`grep "COMPILER=" ./sette.sh | sed -e 's/COMPILER=//'` 200 201 NEMO_VALID=`grep "NEMO_VALIDATION_DIR=" ./param.cfg | sed -e 's/NEMO_VALIDATION_DIR=//'` 202 NEMO_VALID=`eval "echo $NEMO_VALID"` 201 203 # 202 204 if [ ! -d $NEMO_VALID ]; then -
branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/SETTE/sette_xios.sh
r4990 r8879 52 52 # set_namelist : function declared in all_functions that sets namelist parameters 53 53 # post_test_tidyup : creates validation storage directory and copies required output files 54 # ( solver.stat and ocean.output) in it after execution of test.54 # (run.stat and ocean.output) in it after execution of test. 55 55 # 56 56 # VALIDATION tree is: -
branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/TOOLS/COMPILE/Fadd_keys.sh
r7646 r8879 65 65 echo "Adding keys in : ${NEW_CONF}" 66 66 for i in ${list_add_key} ; do 67 if [ "$(cat ${CONFIG_DIR}/${NEW_CONF}/cpp_${NEW_CONF}.fcm | grep -c " $i" )" -ne 0 ] ; then67 if [ "$(cat ${CONFIG_DIR}/${NEW_CONF}/cpp_${NEW_CONF}.fcm | grep -c "\<$i\>" )" -ne 0 ] ; then 68 68 echo "key $i already present in cpp_${NEW_CONF}.fcm" 69 69 else -
branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/TOOLS/DOMAINcfg/namelist_ref
r7200 r8879 278 278 ! = 2 Redistribute a single flux over categories (coupled mode only) 279 279 ! Sea-ice : 280 nn_ice = 2! =0 no ice boundary condition ,280 nn_ice = 3 ! =0 no ice boundary condition , 281 281 ! =1 use observed ice-cover , 282 ! = 2 ice-model used ("key_lim3", "key_lim2", "key_cice")282 ! =3-4 ice-model used ("key_lim3", "key_cice") 283 283 nn_ice_embd = 1 ! =0 levitating ice (no mass exchange, concentration/dilution effect) 284 284 ! =1 levitating ice with mass and salt exchange but no presure effect … … 670 670 bn_tem = 'amm12_bdyT_tra', 24 , 'votemper', .true. , .false. , 'daily' , '' , '' , '' 671 671 bn_sal = 'amm12_bdyT_tra', 24 , 'vosaline', .true. , .false. , 'daily' , '' , '' , '' 672 ! for lim2673 ! bn_frld = 'amm12_bdyT_ice', 24 , 'ileadfra', .true. , .false. , 'daily' , '' , '' , ''674 ! bn_hicif = 'amm12_bdyT_ice', 24 , 'iicethic', .true. , .false. , 'daily' , '' , '' , ''675 ! bn_hsnif = 'amm12_bdyT_ice', 24 , 'isnowthi', .true. , .false. , 'daily' , '' , '' , ''676 672 ! for lim3 677 673 ! bn_a_i = 'amm12_bdyT_ice', 24 , 'ileadfra', .true. , .false. , 'daily' , '' , '' , ''
Note: See TracChangeset
for help on using the changeset viewer.