Changeset 6839
- Timestamp:
- 2016-08-03T16:04:57+02:00 (8 years ago)
- Location:
- branches/UKMO/dev_r5518_convadj/NEMOGCM
- Files:
-
- 153 edited
- 1 copied
Legend:
- Unmodified
- Added
- Removed
-
branches/UKMO/dev_r5518_convadj/NEMOGCM/CONFIG/AMM12/EXP00/namelist_cfg
r5501 r6839 200 200 / 201 201 !----------------------------------------------------------------------- 202 &namobc ! open boundaries parameters ("key_obc")203 !-----------------------------------------------------------------------204 /205 !-----------------------------------------------------------------------206 202 &namagrif ! AGRIF zoom ("key_agrif") 207 203 !----------------------------------------------------------------------- … … 369 365 / 370 366 !----------------------------------------------------------------------- 367 &namzdf_tmx_new ! new tidal mixing parameterization ("key_zdftmx_new") 368 !----------------------------------------------------------------------- 369 / 370 !----------------------------------------------------------------------- 371 371 &namsol ! elliptic solver / island / free surface 372 372 !----------------------------------------------------------------------- -
branches/UKMO/dev_r5518_convadj/NEMOGCM/CONFIG/C1D_PAPA/EXP00/namelist_cfg
r5407 r6839 141 141 &namtra_qsr ! penetrative solar radiation 142 142 !----------------------------------------------------------------------- 143 ! ! file name ! frequency (hours) ! variable ! time interp. ! clim ! 'yearly'/ ! weights ! rotation ! land/sea mask ! 144 ! ! ! (if <0 months) ! name ! (logical) ! (T/F) ! 'monthly' ! filename ! pairing ! filename ! 145 sn_chl ='chlorophyll_PAPASTATION', -1 , 'CHLA' , .true. , .true. , 'yearly' , '' , '' , '' 143 146 / 144 147 !----------------------------------------------------------------------- … … 173 176 !----------------------------------------------------------------------- 174 177 &namcla ! cross land advection 175 !-----------------------------------------------------------------------176 /177 !-----------------------------------------------------------------------178 &namobc ! open boundaries parameters ("key_obc")179 178 !----------------------------------------------------------------------- 180 179 / … … 304 303 / 305 304 !----------------------------------------------------------------------- 305 &namzdf_tmx_new ! new tidal mixing parameterization ("key_zdftmx_new") 306 !----------------------------------------------------------------------- 307 / 308 !----------------------------------------------------------------------- 306 309 &namsol ! elliptic solver / island / free surface 307 310 !----------------------------------------------------------------------- -
branches/UKMO/dev_r5518_convadj/NEMOGCM/CONFIG/GYRE/EXP00/namelist_cfg
r5407 r6839 160 160 / 161 161 !----------------------------------------------------------------------- 162 &namobc ! open boundaries parameters ("key_obc")163 !-----------------------------------------------------------------------164 /165 !-----------------------------------------------------------------------166 162 &namagrif ! AGRIF zoom ("key_agrif") 167 163 !----------------------------------------------------------------------- … … 304 300 / 305 301 !----------------------------------------------------------------------- 302 &namzdf_tmx_new ! new tidal mixing parameterization ("key_zdftmx_new") 303 !----------------------------------------------------------------------- 304 / 305 !----------------------------------------------------------------------- 306 306 &namsol ! elliptic solver / island / free surface 307 307 !----------------------------------------------------------------------- -
branches/UKMO/dev_r5518_convadj/NEMOGCM/CONFIG/GYRE_BFM/EXP00/namelist_cfg
r5407 r6839 165 165 / 166 166 !----------------------------------------------------------------------- 167 &namobc ! open boundaries parameters ("key_obc")168 !-----------------------------------------------------------------------169 /170 !-----------------------------------------------------------------------171 167 &namagrif ! AGRIF zoom ("key_agrif") 172 168 !----------------------------------------------------------------------- -
branches/UKMO/dev_r5518_convadj/NEMOGCM/CONFIG/GYRE_XIOS/EXP00/iodef.xml
r5363 r6839 2 2 <simulation> 3 3 4 <context id="nemo" time_origin="1900-01-01 00:00:00">4 <context id="nemo" > 5 5 6 6 <!-- $id$ --> … … 19 19 = put the variables you want... = 20 20 ============================================================================================================ 21 --> 22 23 <file_definition type="multiple_file" name="@expname@_@freq@_@startdate@_@enddate@" sync_freq="1d" min_digits="4"> 24 25 <file_group id="1ts" output_freq="1ts" output_level="10" enabled=".TRUE."/> <!-- 1 time step files --> 26 <file_group id="1h" output_freq="1h" output_level="10" enabled=".TRUE."/> <!-- 1h files --> 27 <file_group id="2h" output_freq="2h" output_level="10" enabled=".TRUE."/> <!-- 2h files --> 28 <file_group id="3h" output_freq="3h" output_level="10" enabled=".TRUE."/> <!-- 3h files --> 29 <file_group id="4h" output_freq="4h" output_level="10" enabled=".TRUE."/> <!-- 4h files --> 30 <file_group id="6h" output_freq="6h" output_level="10" enabled=".TRUE."/> <!-- 6h files --> 31 32 <file_group id="1d" output_freq="1d" output_level="10" enabled=".TRUE."/> <!-- 1d files --> 33 <file_group id="3d" output_freq="3d" output_level="10" enabled=".TRUE."/> <!-- 3d files --> 34 <file_group id="5d" output_freq="5d" output_level="10" enabled=".TRUE."> <!-- 5d files --> 21 --> 22 23 <file_definition src="./file_def.xml"/> 24 25 <!-- 35 26 36 <file id="file1" name_suffix="_grid_T" description="ocean T grid variables" >37 <field field_ref="toce" name="votemper" />38 <field field_ref="soce" name="vosaline" />39 <field field_ref="sst" name="sosstsst" />40 <field field_ref="sss" name="sosaline" />41 <field field_ref="ssh" name="sossheig" />42 <field field_ref="empmr" name="sowaflup" />43 <field field_ref="qsr" name="soshfldo" />44 <field field_ref="saltflx" name="sosfldow" />45 <field field_ref="qt" name="sohefldo" />46 <field field_ref="mldr10_1" name="somxl010" />47 <field field_ref="mldkz5" name="somixhgt" />48 </file>49 50 <file id="file2" name_suffix="_grid_U" description="ocean U grid variables" >51 <field field_ref="uoce" name="vozocrtx" />52 <field field_ref="utau" name="sozotaux" />53 </file>54 55 <file id="file3" name_suffix="_grid_V" description="ocean V grid variables" >56 <field field_ref="voce" name="vomecrty" />57 <field field_ref="vtau" name="sometauy" />58 </file>59 60 <file id="file4" name_suffix="_grid_W" description="ocean W grid variables" >61 <field field_ref="woce" name="vovecrtz" />62 <field field_ref="avt" name="votkeavt" />63 <field field_ref="aht2d" name="soleahtw" />64 </file>65 66 </file_group>67 68 <file_group id="1m" output_freq="1mo" output_level="10" enabled=".TRUE."/> <!-- real monthly files -->69 <file_group id="2m" output_freq="2mo" output_level="10" enabled=".TRUE."/> <!-- real 2m files -->70 <file_group id="3m" output_freq="3mo" output_level="10" enabled=".TRUE."/> <!-- real 3m files -->71 <file_group id="4m" output_freq="4mo" output_level="10" enabled=".TRUE."/> <!-- real 4m files -->72 <file_group id="6m" output_freq="6mo" output_level="10" enabled=".TRUE."/> <!-- real 6m files -->73 74 <file_group id="1y" output_freq="1y" output_level="10" enabled=".TRUE."/> <!-- real yearly files -->75 <file_group id="2y" output_freq="2y" output_level="10" enabled=".TRUE."/> <!-- real 2y files -->76 <file_group id="5y" output_freq="5y" output_level="10" enabled=".TRUE."/> <!-- real 5y files -->77 <file_group id="10y" output_freq="10y" output_level="10" enabled=".TRUE."/> <!-- real 10y files -->78 79 </file_definition>80 81 <!--82 27 ============================================================================================================ 83 28 = grid definition = = DO NOT CHANGE = … … 100 45 101 46 <grid_definition> 102 <grid id="grid_T_2D" domain_ref="grid_T"/> 103 <grid id="grid_T_3D" domain_ref="grid_T" axis_ref="deptht"/> 104 <grid id="grid_U_2D" domain_ref="grid_U"/> 105 <grid id="grid_U_3D" domain_ref="grid_U" axis_ref="depthu"/> 106 <grid id="grid_V_2D" domain_ref="grid_V"/> 107 <grid id="grid_V_3D" domain_ref="grid_V" axis_ref="depthv"/> 108 <grid id="grid_W_2D" domain_ref="grid_W"/> 109 <grid id="grid_W_3D" domain_ref="grid_W" axis_ref="depthw"/> 47 <grid id="grid_T_2D" > 48 <domain id="grid_T" /> 49 </grid> 50 <grid id="grid_T_3D" > 51 <domain id="grid_T" /> 52 <axis id="deptht" /> 53 </grid> 54 <grid id="grid_U_2D" > 55 <domain id="grid_U" /> 56 </grid> 57 <grid id="grid_U_3D" > 58 <domain id="grid_U" /> 59 <axis id="depthu" /> 60 </grid> 61 <grid id="grid_V_2D" > 62 <domain id="grid_V" /> 63 </grid> 64 <grid id="grid_V_3D" > 65 <domain id="grid_V" /> 66 <axis id="depthv" /> 67 </grid> 68 <grid id="grid_W_2D" > 69 <domain id="grid_W" /> 70 </grid> 71 <grid id="grid_W_3D" > 72 <domain id="grid_W" /> 73 <axis id="depthw" /> 74 </grid> 75 <grid id="scalarpoint" /> 76 110 77 </grid_definition> 111 78 … … 120 87 We must have buffer_size > jpi*jpj*jpk*8 (with jpi and jpj the subdomain size) 121 88 --> 122 <variable id="buffer_size" type="integer">10000000</variable> 123 <variable id="buffer_server_factor_size" type="integer">2</variable> 124 <variable id="info_level" type="integer">0</variable> 125 <variable id="using_server" type="boolean">false</variable> 126 <variable id="using_oasis" type="boolean">false</variable> 89 <variable id="info_level" type="int">0</variable> 90 <variable id="using_server" type="bool">false</variable> 91 <variable id="using_oasis" type="bool">false</variable> 127 92 <variable id="oasis_codes_id" type="string" >oceanx</variable> 128 93 -
branches/UKMO/dev_r5518_convadj/NEMOGCM/CONFIG/GYRE_XIOS/EXP00/namelist_cfg
r5407 r6839 154 154 / 155 155 !----------------------------------------------------------------------- 156 &namobc ! open boundaries parameters ("key_obc")157 !-----------------------------------------------------------------------158 /159 !-----------------------------------------------------------------------160 156 &namagrif ! AGRIF zoom ("key_agrif") 161 157 !----------------------------------------------------------------------- -
branches/UKMO/dev_r5518_convadj/NEMOGCM/CONFIG/GYRE_XIOS/cpp_GYRE_XIOS.fcm
r4373 r6839 1 bld::tool::fppkeys key_dynspg_flt key_ldfslp key_zdftke key_iomput key_mpp_mpi 1 bld::tool::fppkeys key_dynspg_flt key_ldfslp key_zdftke key_iomput key_mpp_mpi key_xios2 -
branches/UKMO/dev_r5518_convadj/NEMOGCM/CONFIG/ORCA2_LIM/EXP00/1_namelist_cfg
r5499 r6839 6 6 !----------------------------------------------------------------------- 7 7 cn_exp = "Agulhas" ! experience name 8 nn_itend = 480 ! last time step8 nn_itend = 10950 ! last time step 9 9 nn_stock = 10950 ! frequency of creation of a restart file (modulo referenced to 1) 10 10 nn_write = 10950 ! frequency of write in the output file (modulo referenced to nn_it000) -
branches/UKMO/dev_r5518_convadj/NEMOGCM/CONFIG/ORCA2_LIM/EXP00/iodef.xml
r5407 r6839 153 153 </context> 154 154 155 <context id="1_nemo" time_origin="1950-01-01 00:00:00" > 156 157 <!-- $id$ --> 158 159 <!-- 160 ============================================================================================================ 161 = definition of all existing variables = 162 = DO NOT CHANGE = 163 ============================================================================================================ 164 --> 165 <field_definition src="./field_def.xml"/> 166 <!-- 167 ============================================================================================================ 168 = output files definition = 169 = Define your own files = 170 = put the variables you want... = 171 ============================================================================================================ 172 --> 173 174 <file_definition type="multiple_file" name="@expname@_@freq@_@startdate@_@enddate@" sync_freq="10d" min_digits="4"> 175 176 <file_group id="1ts" output_freq="1ts" output_level="10" enabled=".TRUE."/> <!-- 1 time step files --> 177 <file_group id="1h" output_freq="1h" output_level="10" enabled=".TRUE."/> <!-- 1h files --> 178 <file_group id="2h" output_freq="2h" output_level="10" enabled=".TRUE."/> <!-- 2h files --> 179 <file_group id="3h" output_freq="3h" output_level="10" enabled=".TRUE."/> <!-- 3h files --> 180 <file_group id="4h" output_freq="4h" output_level="10" enabled=".TRUE."/> <!-- 4h files --> 181 <file_group id="6h" output_freq="6h" output_level="10" enabled=".TRUE."/> <!-- 6h files --> 182 <file_group id="1d" output_freq="1d" output_level="10" enabled=".TRUE."/> <!-- 1d files --> 183 <file_group id="3d" output_freq="3d" output_level="10" enabled=".TRUE."/> <!-- 3d files --> 184 185 <file_group id="5d" output_freq="5d" output_level="10" enabled=".TRUE." > <!-- 5d files --> 186 187 <file id="file1" name_suffix="_grid_T" description="ocean T grid variables" > 188 <field field_ref="sst" name="tos" long_name="sea_surface_temperature" /> 189 <field field_ref="sss" name="sos" long_name="sea_surface_salinity" /> 190 <field field_ref="ssh" name="zos" long_name="sea_surface_height_above_geoid" /> 191 <field field_ref="toce" name="thetao" long_name="sea_water_potential_temperature" /> 192 <field field_ref="soce" name="so" long_name="sea_water_salinity" /> 193 <field field_ref="sst2" name="tossq" long_name="square_of_sea_surface_temperature" /> 194 <field field_ref="ssh2" name="zossq" long_name="square_of_sea_surface_height_above_geoid" /> 195 <field field_ref="mldkz5" /> 196 <field field_ref="mldr10_1" /> 197 <field field_ref="empmr" name="wfo" long_name="water_flux_into_sea_water" /> 198 <field field_ref="qsr" name="rsntds" long_name="surface_net_downward_shortwave_flux" /> 199 <field field_ref="qt" name="tohfls" long_name="surface_net_downward_total_heat_flux" /> 200 <field field_ref="saltflx" name="sosflxdo" /> 201 <field field_ref="taum" name="taum" /> 202 <field field_ref="wspd" name="sowindsp" /> 203 <field field_ref="precip" name="soprecip" /> 204 </file> 205 206 <file id="file3" name_suffix="_grid_U" description="ocean U grid variables" > 207 <field field_ref="ssu" name="uos" long_name="sea_surface_x_velocity" /> 208 <field field_ref="uoce" name="uo" long_name="sea_water_x_velocity" /> 209 <field field_ref="utau" name="tauuo" long_name="surface_downward_x_stress" /> 210 <!-- variables available with MLE 211 <field field_ref="psiu_mle" name="psiu_mle" long_name="MLE_streamfunction_along_i-axis" /> 212 --> 213 </file> 214 215 <file id="file4" name_suffix="_grid_V" description="ocean V grid variables" > 216 <field field_ref="ssv" name="vos" long_name="sea_surface_y_velocity" /> 217 <field field_ref="voce" name="vo" long_name="sea_water_y_velocity" /> 218 <field field_ref="vtau" name="tauvo" long_name="surface_downward_y_stress" /> 219 <!-- variables available with MLE 220 <field field_ref="psiv_mle" name="psiv_mle" long_name="MLE_streamfunction_along_j-axis" /> 221 --> 222 </file> 223 224 <file id="file5" name_suffix="_grid_W" description="ocean W grid variables" > 225 <field field_ref="woce" name="wo" long_name="ocean vertical velocity" /> 226 <field field_ref="avt" name="difvho" long_name="ocean_vertical_heat_diffusivity" /> 227 </file> 228 <!-- 229 <file id="file6" name_suffix="_icemod" description="ice variables" > 230 <field field_ref="ice_pres" /> 231 <field field_ref="snowthic_cea" name="snd" long_name="surface_snow_thickness" /> 232 <field field_ref="icethic_cea" name="sit" long_name="sea_ice_thickness" /> 233 <field field_ref="iceprod_cea" name="sip" long_name="sea_ice_thickness" /> 234 <field field_ref="ist_ipa" /> 235 <field field_ref="uice_ipa" /> 236 <field field_ref="vice_ipa" /> 237 <field field_ref="utau_ice" /> 238 <field field_ref="vtau_ice" /> 239 <field field_ref="qsr_io_cea" /> 240 <field field_ref="qns_io_cea" /> 241 <field field_ref="snowpre" /> 242 </file> 243 244 <file id="file8" name_suffix="_Tides" description="tidal harmonics" > 245 <field field_ref="M2x" name="M2x" long_name="M2 Elevation harmonic real part" /> 246 <field field_ref="M2y" name="M2y" long_name="M2 Elevation harmonic imaginary part" /> 247 <field field_ref="M2x_u" name="M2x_u" long_name="M2 current barotrope along i-axis harmonic real part " /> 248 <field field_ref="M2y_u" name="M2y_u" long_name="M2 current barotrope along i-axis harmonic imaginary part " /> 249 <field field_ref="M2x_v" name="M2x_v" long_name="M2 current barotrope along j-axis harmonic real part " /> 250 <field field_ref="M2y_v" name="M2y_v" long_name="M2 current barotrope along j-axis harmonic imaginary part " /> 251 </file> 252 --> 253 </file_group> 254 255 256 <file_group id="1m" output_freq="1mo" output_level="10" enabled=".TRUE."/> <!-- real monthly files --> 257 258 259 <file_group id="2m" output_freq="2mo" output_level="10" enabled=".TRUE."/> <!-- real 2m files --> 260 <file_group id="3m" output_freq="3mo" output_level="10" enabled=".TRUE."/> <!-- real 3m files --> 261 <file_group id="4m" output_freq="4mo" output_level="10" enabled=".TRUE."/> <!-- real 4m files --> 262 <file_group id="6m" output_freq="6mo" output_level="10" enabled=".TRUE."/> <!-- real 6m files --> 263 264 <file_group id="1y" output_freq="1y" output_level="10" enabled=".TRUE."/> <!-- real yearly files --> 265 <file_group id="2y" output_freq="2y" output_level="10" enabled=".TRUE."/> <!-- real 2y files --> 266 <file_group id="5y" output_freq="5y" output_level="10" enabled=".TRUE."/> <!-- real 5y files --> 267 <file_group id="10y" output_freq="10y" output_level="10" enabled=".TRUE."/> <!-- real 10y files --> 268 269 </file_definition> 270 271 <!-- 272 ============================================================================================================ 273 = grid definition = = DO NOT CHANGE = 274 ============================================================================================================ 275 --> 276 277 <axis_definition> 278 <axis id="deptht" long_name="Vertical T levels" unit="m" positive="down" /> 279 <axis id="depthu" long_name="Vertical U levels" unit="m" positive="down" /> 280 <axis id="depthv" long_name="Vertical V levels" unit="m" positive="down" /> 281 <axis id="depthw" long_name="Vertical W levels" unit="m" positive="down" /> 282 <axis id="nfloat" long_name="Float number" unit="-" /> 283 <axis id="icbcla" long_name="Iceberg class" unit="-" /> 284 </axis_definition> 285 286 <domain_definition src="./domain_def.xml"/> 287 288 <grid_definition> 289 <grid id="grid_T_2D" domain_ref="grid_T"/> 290 <grid id="grid_T_3D" domain_ref="grid_T" axis_ref="deptht"/> 291 <grid id="grid_U_2D" domain_ref="grid_U"/> 292 <grid id="grid_U_3D" domain_ref="grid_U" axis_ref="depthu"/> 293 <grid id="grid_V_2D" domain_ref="grid_V"/> 294 <grid id="grid_V_3D" domain_ref="grid_V" axis_ref="depthv"/> 295 <grid id="grid_W_2D" domain_ref="grid_W"/> 296 <grid id="grid_W_3D" domain_ref="grid_W" axis_ref="depthw"/> 297 </grid_definition> 298 </context> 155 299 156 300 <context id="xios"> -
branches/UKMO/dev_r5518_convadj/NEMOGCM/CONFIG/ORCA2_LIM/EXP00/namelist_cfg
r4990 r6839 165 165 / 166 166 !----------------------------------------------------------------------- 167 &namzdf_tmx_new ! new tidal mixing parameterization ("key_zdftmx_new") 168 !----------------------------------------------------------------------- 169 / 170 !----------------------------------------------------------------------- 167 171 &namsol ! elliptic solver / island / free surface 168 172 !----------------------------------------------------------------------- -
branches/UKMO/dev_r5518_convadj/NEMOGCM/CONFIG/ORCA2_LIM3/EXP00/iodef.xml
r5517 r6839 61 61 <file id="file2" name_suffix="_SBC" description="surface fluxes variables" > <!-- time step automaticaly defined based on nn_fsbc --> 62 62 <field field_ref="empmr" name="wfo" /> 63 <field field_ref="emp_oce" name="emp_oce" long_name="Evap minus Precip over ocean" /> 64 <field field_ref="emp_ice" name="emp_ice" long_name="Evap minus Precip over ice" /> 63 65 <field field_ref="qsr_oce" name="qsr_oce" /> 64 66 <field field_ref="qns_oce" name="qns_oce" /> -
branches/UKMO/dev_r5518_convadj/NEMOGCM/CONFIG/ORCA2_LIM3/EXP00/namelist_cfg
r4995 r6839 168 168 / 169 169 !----------------------------------------------------------------------- 170 &namzdf_tmx_new ! new tidal mixing parameterization ("key_zdftmx_new") 171 !----------------------------------------------------------------------- 172 / 173 !----------------------------------------------------------------------- 170 174 &namsol ! elliptic solver / island / free surface 171 175 !----------------------------------------------------------------------- -
branches/UKMO/dev_r5518_convadj/NEMOGCM/CONFIG/ORCA2_LIM_CFC_C14b/EXP00/1_namelist_cfg
r5407 r6839 5 5 !! namsbc_cpl, namtra_qsr, namsbc_rnf, 6 6 !! namsbc_apr, namsbc_ssr, namsbc_alb) 7 !! 4 - lateral boundary (namlbc, namcla, nam obc, namagrif, nambdy, nambdy_tide)7 !! 4 - lateral boundary (namlbc, namcla, namagrif, nambdy, nambdy_tide) 8 8 !! 5 - bottom boundary (nambfr, nambbc, nambbl) 9 9 !! 6 - Tracer (nameos, namtra_adv, namtra_ldf, namtra_dmp) … … 303 303 !! namlbc lateral momentum boundary condition 304 304 !! namcla cross land advection 305 !! namobc open boundaries parameters ("key_obc")306 305 !! namagrif agrif nested grid ( read by child model only ) ("key_agrif") 307 306 !! nambdy Unstructured open boundaries ("key_bdy") … … 319 318 !----------------------------------------------------------------------- 320 319 nn_cla = 0 ! advection between 2 ocean pts separates by land 321 /322 !-----------------------------------------------------------------------323 &namobc ! open boundaries parameters ("key_obc")324 !-----------------------------------------------------------------------325 ln_obc_clim = .false. ! climatological obc data files (T) or not (F)326 ln_vol_cst = .true. ! impose the total volume conservation (T) or not (F)327 ln_obc_fla = .false. ! Flather open boundary condition328 nn_obcdta = 1 ! = 0 the obc data are equal to the initial state329 ! = 1 the obc data are read in 'obc.dta' files330 cn_obcdta = 'annual' ! set to annual if obc datafile hold 1 year of data331 ! set to monthly if obc datafile hold 1 month of data332 rn_dpein = 1. ! damping time scale for inflow at east open boundary333 rn_dpwin = 1. ! - - - west - -334 rn_dpnin = 1. ! - - - north - -335 rn_dpsin = 1. ! - - - south - -336 rn_dpeob = 3000. ! time relaxation (days) for the east open boundary337 rn_dpwob = 15. ! - - - west - -338 rn_dpnob = 3000. ! - - - north - -339 rn_dpsob = 15. ! - - - south - -340 rn_volemp = 1. ! = 0 the total volume change with the surface flux (E-P-R)341 ! = 1 the total volume remains constant342 320 / 343 321 !----------------------------------------------------------------------- -
branches/UKMO/dev_r5518_convadj/NEMOGCM/CONFIG/ORCA2_LIM_CFC_C14b/EXP00/namelist_cfg
r5407 r6839 136 136 / 137 137 !----------------------------------------------------------------------- 138 &namobc ! open boundaries parameters ("key_obc")139 !-----------------------------------------------------------------------140 /141 !-----------------------------------------------------------------------142 138 &namagrif ! AGRIF zoom ("key_agrif") 143 139 !----------------------------------------------------------------------- -
branches/UKMO/dev_r5518_convadj/NEMOGCM/CONFIG/ORCA2_LIM_PISCES/EXP00/namelist_cfg
r4370 r6839 165 165 / 166 166 !----------------------------------------------------------------------- 167 &namzdf_tmx_new ! new tidal mixing parameterization ("key_zdftmx_new") 168 !----------------------------------------------------------------------- 169 / 170 !----------------------------------------------------------------------- 167 171 &namsol ! elliptic solver / island / free surface 168 172 !----------------------------------------------------------------------- -
branches/UKMO/dev_r5518_convadj/NEMOGCM/CONFIG/SHARED/field_def.xml
r5517 r6839 23 23 <field_group id="grid_T" grid_ref="grid_T_2D" > 24 24 <field id="e3t" long_name="T-cell thickness" standard_name="cell_thickness" unit="m" grid_ref="grid_T_3D"/> 25 <field id="e3t_0" long_name="Initial T-cell thickness" standard_name="ref_cell_thickness" unit="m" grid_ref="grid_T_3D"/> 25 26 26 27 <field id="toce" long_name="temperature" standard_name="sea_water_potential_temperature" unit="degC" grid_ref="grid_T_3D"/> … … 59 60 <field id="alpha" long_name="thermal expansion" unit="degC-1" grid_ref="grid_T_3D" /> 60 61 <field id="beta" long_name="haline contraction" unit="1e3" grid_ref="grid_T_3D" /> 61 <field id="bn2" long_name="squared Brunt-Vaisala frequency" unit="s-1" grid_ref="grid_T_3D" />62 62 <field id="rhop" long_name="potential density (sigma0)" standard_name="sea_water_sigma_theta" unit="kg/m3" grid_ref="grid_T_3D" /> 63 63 … … 174 174 <field_group id="SBC" grid_ref="grid_T_2D" > <!-- time step automaticaly defined based on nn_fsbc --> 175 175 <field id="empmr" long_name="Net Upward Water Flux" standard_name="water_flux_out_of_sea_ice_and_sea_water" unit="kg/m2/s" /> 176 <field id="empbmr" long_name="Net Upward Water Flux at pre. tstep" standard_name="water_flux_out_of_sea_ice_and_sea_water" unit="kg/m2/s" /> 177 <field id="emp_oce" long_name="Evap minus Precip over ocean" standard_name="evap_minus_precip_over_sea_water" unit="kg/m2/s" /> 178 <field id="emp_ice" long_name="Evap minus Precip over ice" standard_name="evap_minus_precip_over_sea_ice" unit="kg/m2/s" /> 176 179 <field id="saltflx" long_name="Downward salt flux" unit="1e-3/m2/s" /> 177 180 <field id="fmmflx" long_name="Water flux due to freezing/melting" unit="kg/m2/s" /> … … 260 263 <field id="emp_x_sst" long_name="Concentration/Dilution term on SST" unit="kg*degC/m2/s" /> 261 264 <field id="emp_x_sss" long_name="Concentration/Dilution term on SSS" unit="kg*1e-3/m2/s" /> 265 <field id="rnf_x_sst" long_name="Runoff term on SST" unit="kg*degC/m2/s" /> 266 <field id="rnf_x_sss" long_name="Runoff term on SSS" unit="kg*1e-3/m2/s" /> 262 267 263 268 <field id="iceconc" long_name="ice concentration" standard_name="sea_ice_area_fraction" unit="%" /> … … 274 279 <field id="micesalt" long_name="Mean ice salinity" unit="1e-3" /> 275 280 <field id="miceage" long_name="Mean ice age" unit="years" /> 281 <field id="alb_ice" long_name="Mean albedo over sea ice" unit="" /> 282 <field id="albedo" long_name="Mean albedo over sea ice and ocean" unit="" /> 276 283 277 284 <field id="iceage_cat" long_name="Ice age for categories" unit="days" axis_ref="ncatice" /> … … 311 318 <field id="sfxsni" long_name="salt flux from snow-ice formation" unit="1e-3*kg/m2/day" /> 312 319 <field id="sfxopw" long_name="salt flux from open water ice formation" unit="1e-3*kg/m2/day" /> 320 <field id="sfxsub" long_name="salt flux from sublimation" unit="1e-3*kg/m2/day" /> 313 321 <field id="sfx" long_name="salt flux total" unit="1e-3*kg/m2/day" /> 314 322 … … 324 332 <field id="vfxsub" long_name="snw sublimation" unit="m/day" /> 325 333 <field id="vfxspr" long_name="snw precipitation on ice" unit="m/day" /> 334 <field id="vfxthin" long_name="daily thermo ice prod. for thin ice(<20cm) + open water" unit="m/day" /> 326 335 327 336 <field id="afxtot" long_name="area tendency (total)" unit="day-1" /> … … 365 374 <field_group id="grid_U" grid_ref="grid_U_2D"> 366 375 <field id="e3u" long_name="U-cell thickness" standard_name="cell_thickness" unit="m" grid_ref="grid_U_3D" /> 376 <field id="e3u_0" long_name="Initial U-cell thickness" standard_name="ref_cell_thickness" unit="m" grid_ref="grid_U_3D"/> 367 377 <field id="utau" long_name="Wind Stress along i-axis" standard_name="surface_downward_x_stress" unit="N/m2" /> 368 378 <field id="uoce" long_name="ocean current along i-axis" standard_name="sea_water_x_velocity" unit="m/s" grid_ref="grid_U_3D" /> … … 400 410 <field_group id="grid_V" grid_ref="grid_V_2D"> 401 411 <field id="e3v" long_name="V-cell thickness" standard_name="cell_thickness" unit="m" grid_ref="grid_V_3D" /> 412 <field id="e3v_0" long_name="Initial V-cell thickness" standard_name="ref_cell_thickness" unit="m" grid_ref="grid_V_3D"/> 402 413 <field id="vtau" long_name="Wind Stress along j-axis" standard_name="surface_downward_y_stress" unit="N/m2" /> 403 414 <field id="voce" long_name="ocean current along j-axis" standard_name="sea_water_y_velocity" unit="m/s" grid_ref="grid_V_3D" /> … … 441 452 <field id="woce_eiv" long_name="EIV ocean vertical velocity" standard_name="bolus_upward_sea_water_velocity" unit="m/s" /> 442 453 443 <!-- woce_eiv: available with key_trabbl_adv -->444 454 <field id="avt" long_name="vertical eddy diffusivity" standard_name="ocean_vertical_heat_diffusivity" unit="m2/s" /> 455 <field id="logavt" long_name="logarithm of vertical eddy diffusivity" standard_name="ocean_vertical_heat_diffusivity" unit="m2/s" /> 445 456 <field id="avm" long_name="vertical eddy viscosity" standard_name="ocean_vertical_momentum_diffusivity" unit="m2/s" /> 446 457 447 458 <!-- avs: available with key_zdfddm --> 448 459 <field id="avs" long_name="salt vertical eddy diffusivity" standard_name="ocean_vertical_salt_diffusivity" unit="m2/s" /> 460 <field id="logavs" long_name="logarithm of salt vertical eddy diffusivity" standard_name="ocean_vertical_heat_diffusivity" unit="m2/s" /> 449 461 450 462 <!-- avt_evd and avm_evd: available with ln_zdfevd --> … … 454 466 <!-- avt_tide: available with key_zdftmx --> 455 467 <field id="av_tide" long_name="tidal vertical diffusivity" standard_name="ocean_vertical_tracer_diffusivity_due_to_tides" unit="m2/s" /> 468 469 <!-- variables available with key_zdftmx_new --> 470 <field id="av_ratio" long_name="S over T diffusivity ratio" standard_name="salinity_over_temperature_diffusivity_ratio" unit="1" /> 471 <field id="av_wave" long_name="wave-induced vertical diffusivity" standard_name="ocean_vertical_tracer_diffusivity_due_to_internal_waves" unit="m2/s" /> 472 <field id="bn2" long_name="squared Brunt-Vaisala frequency" standard_name="squared_brunt_vaisala_frequency" unit="s-1" /> 473 <field id="bflx_tmx" long_name="wave-induced buoyancy flux" standard_name="buoyancy_flux_due_to_internal_waves" unit="W/kg" /> 474 <field id="pcmap_tmx" long_name="power consumed by wave-driven mixing" standard_name="vertically_integrated_power_consumption_by_wave_driven_mixing" unit="W/m2" grid_ref="grid_W_2D" /> 475 <field id="emix_tmx" long_name="power density available for mixing" standard_name="power_available_for_mixing_from_breaking_internal_waves" unit="W/kg" /> 456 476 457 477 <!-- variables available with key_diaar5 --> … … 527 547 <field id="ibgsfxbom" long_name="global mean salt flux (thermo)" unit="1e-3*m/day" /> 528 548 <field id="ibgsfxsum" long_name="global mean salt flux (thermo)" unit="1e-3*m/day" /> 549 <field id="ibgsfxsub" long_name="global mean salt flux (thermo)" unit="1e-3*m/day" /> 529 550 530 551 <field id="ibghfxdhc" long_name="Heat content variation in snow and ice" unit="W" /> … … 849 870 <field id="Totlig" long_name="Total ligand concentation" unit="nmol/m3" grid_ref="grid_T_3D" /> 850 871 <field id="Biron" long_name="Bioavailable iron" unit="nmol/m3" grid_ref="grid_T_3D" /> 851 <field id="Sdenit" long_name="Nitrate reduction in the sediments" unit="mol/m2/s" /> 872 <field id="Sdenit" long_name="Nitrate reduction in the sediments" unit="molN/m2/s" /> 873 <field id="SedCal" long_name="Calcite burial in the sediments" unit="molC/m2/s" /> 874 <field id="SedSi" long_name="Silicon burial in the sediments" unit="molSi/m2/s" /> 875 <field id="SedC" long_name="Organic C burial in the sediments" unit="molC/m2/s" /> 852 876 <field id="Ironice" long_name="Iron input/uptake due to sea ice" unit="mol/m2/s" /> 853 877 <field id="HYDR" long_name="Iron input from hydrothemal vents" unit="mol/m2/s" grid_ref="grid_T_3D" /> -
branches/UKMO/dev_r5518_convadj/NEMOGCM/CONFIG/SHARED/namelist_ice_lim3_ref
r5429 r6839 21 21 cn_icerst_outdir = "." ! directory in which to write output ice restarts 22 22 ln_limdyn = .true. ! ice dynamics (T) or thermodynamics only (F) 23 rn_amax = 0.999 ! maximum tolerated ice concentration 23 rn_amax_n = 0.999 ! maximum tolerated ice concentration NH 24 rn_amax_s = 0.999 ! maximum tolerated ice concentration SH 24 25 ln_limdiahsb = .false. ! check the heat and salt budgets (T) or not (F) 25 26 ln_limdiaout = .true. ! output the heat and salt budgets (T) or not (F) … … 85 86 rn_hnewice = 0.1 ! thickness for new ice formation in open water (m) 86 87 ln_frazil = .false. ! use frazil ice collection thickness as a function of wind (T) or not (F) 87 rn_maxfrazb = 0.0 ! maximum fraction of frazil ice collecting at the ice base88 rn_maxfrazb = 1.0 ! maximum fraction of frazil ice collecting at the ice base 88 89 rn_vfrazb = 0.417 ! thresold drift speed for frazil ice collecting at the ice bottom (m/s) 89 90 rn_Cfrazb = 5.0 ! squeezing coefficient for frazil ice collecting at the ice bottom -
branches/UKMO/dev_r5518_convadj/NEMOGCM/CONFIG/SHARED/namelist_ref
r6838 r6839 5 5 !! namsbc_cpl, namtra_qsr, namsbc_rnf, 6 6 !! namsbc_apr, namsbc_ssr, namsbc_alb) 7 !! 4 - lateral boundary (namlbc, namcla, nam obc, namagrif, nambdy, nambdy_tide)7 !! 4 - lateral boundary (namlbc, namcla, namagrif, nambdy, nambdy_tide) 8 8 !! 5 - bottom boundary (nambfr, nambbc, nambbl) 9 9 !! 6 - Tracer (nameos, namtra_adv, namtra_ldf, namtra_dmp) 10 10 !! 7 - dynamics (namdyn_adv, namdyn_vor, namdyn_hpg, namdyn_spg, namdyn_ldf) 11 !! 8 - Verical physics (namzdf, namzdf_ric, namzdf_tke, namzdf_kpp, namzdf_ddm, namzdf_tmx )11 !! 8 - Verical physics (namzdf, namzdf_ric, namzdf_tke, namzdf_kpp, namzdf_ddm, namzdf_tmx, namzdf_tmx_new) 12 12 !! 9 - diagnostics (namnc4, namtrd, namspr, namflo, namhsb, namsto) 13 13 !! 10 - miscellaneous (namsol, nammpp, namctl) … … 408 408 ln_qsr_2bd = .false. ! 2 bands light penetration 409 409 ln_qsr_bio = .false. ! bio-model light penetration 410 nn_chldta = 1 ! RGB : Chl data (=1) or cst value (=0)410 nn_chldta = 1 ! RGB : 2D Chl data (=1), 3D Chl data (=2) or cst value (=0) 411 411 rn_abs = 0.58 ! RGB & 2 bands: fraction of light (rn_si1) 412 412 rn_si0 = 0.35 ! RGB & 2 bands: shortess depth of extinction … … 500 500 &namsbc_alb ! albedo parameters 501 501 !----------------------------------------------------------------------- 502 rn_cloud = 0.06 ! cloud correction to snow and ice albedo 503 rn_albice = 0.53 ! albedo of melting ice in the arctic and antarctic 504 rn_alphd = 0.80 ! coefficients for linear interpolation used to 505 rn_alphc = 0.65 ! compute albedo between two extremes values 506 rn_alphdi = 0.72 ! (Pyane, 1972) 502 nn_ice_alb = 0 ! parameterization of ice/snow albedo 503 ! 0: Shine & Henderson-Sellers (JGR 1985) 504 ! 1: "home made" based on Brandt et al. (J. Climate 2005) 505 ! and Grenfell & Perovich (JGR 2004) 506 rn_albice = 0.53 ! albedo of bare puddled ice (values from 0.49 to 0.58) 507 ! 0.53 (default) => if nn_ice_alb=0 508 ! 0.50 (default) => if nn_ice_alb=1 507 509 / 508 510 !----------------------------------------------------------------------- … … 546 548 !! namlbc lateral momentum boundary condition 547 549 !! namcla cross land advection 548 !! namobc open boundaries parameters ("key_obc")549 550 !! namagrif agrif nested grid ( read by child model only ) ("key_agrif") 550 551 !! nambdy Unstructured open boundaries ("key_bdy") … … 563 564 !----------------------------------------------------------------------- 564 565 nn_cla = 0 ! advection between 2 ocean pts separates by land 565 /566 !-----------------------------------------------------------------------567 &namobc ! open boundaries parameters ("key_obc")568 !-----------------------------------------------------------------------569 ln_obc_clim = .false. ! climatological obc data files (T) or not (F)570 ln_vol_cst = .true. ! impose the total volume conservation (T) or not (F)571 ln_obc_fla = .false. ! Flather open boundary condition572 nn_obcdta = 1 ! = 0 the obc data are equal to the initial state573 ! = 1 the obc data are read in 'obc.dta' files574 cn_obcdta = 'annual' ! set to annual if obc datafile hold 1 year of data575 ! set to monthly if obc datafile hold 1 month of data576 rn_dpein = 1. ! damping time scale for inflow at east open boundary577 rn_dpwin = 1. ! - - - west - -578 rn_dpnin = 1. ! - - - north - -579 rn_dpsin = 1. ! - - - south - -580 rn_dpeob = 3000. ! time relaxation (days) for the east open boundary581 rn_dpwob = 15. ! - - - west - -582 rn_dpnob = 3000. ! - - - north - -583 rn_dpsob = 15. ! - - - south - -584 rn_volemp = 1. ! = 0 the total volume change with the surface flux (E-P-R)585 ! = 1 the total volume remains constant586 566 / 587 567 !----------------------------------------------------------------------- … … 898 878 !! Tracers & Dynamics vertical physics namelists 899 879 !!====================================================================== 900 !! namzdf vertical physics 901 !! namzdf_ric richardson number dependent vertical mixing ("key_zdfric") 902 !! namzdf_tke TKE dependent vertical mixing ("key_zdftke") 903 !! namzdf_kpp KPP dependent vertical mixing ("key_zdfkpp") 904 !! namzdf_ddm double diffusive mixing parameterization ("key_zdfddm") 905 !! namzdf_tmx tidal mixing parameterization ("key_zdftmx") 880 !! namzdf vertical physics 881 !! namzdf_ric richardson number dependent vertical mixing ("key_zdfric") 882 !! namzdf_tke TKE dependent vertical mixing ("key_zdftke") 883 !! namzdf_kpp KPP dependent vertical mixing ("key_zdfkpp") 884 !! namzdf_ddm double diffusive mixing parameterization ("key_zdfddm") 885 !! namzdf_tmx tidal mixing parameterization ("key_zdftmx") 886 !! namzdf_tmx_new new tidal mixing parameterization ("key_zdftmx_new") 906 887 !! namzdf_convadj convective adjustment (cliff) 907 888 !!====================================================================== … … 1011 992 rn_tfe_itf = 1. ! ITF tidal dissipation efficiency 1012 993 / 1013 994 !----------------------------------------------------------------------- 995 &namzdf_tmx_new ! new tidal mixing parameterization ("key_zdftmx_new") 996 !----------------------------------------------------------------------- 997 nn_zpyc = 1 ! pycnocline-intensified dissipation scales as N (=1) or N^2 (=2) 998 ln_mevar = .true. ! variable (T) or constant (F) mixing efficiency 999 ln_tsdiff = .true. ! account for differential T/S mixing (T) or not (F) 1000 / 1014 1001 !----------------------------------------------------------------------- 1015 1002 &namzdf_convadj ! Convective adjustment (cliff) parameterization … … 1205 1192 ln_s3d = .false. ! Logical switch for S profile observations 1206 1193 ln_ena = .false. ! Logical switch for ENACT insitu data set 1207 ! ! ln_corLogical switch for Coriolis insitu data set1194 ln_cor = .false. ! Logical switch for Coriolis insitu data set 1208 1195 ln_profb = .false. ! Logical switch for feedback insitu data set 1209 1196 ln_sla = .false. ! Logical switch for SLA observations 1210 1211 1197 ln_sladt = .false. ! Logical switch for AVISO SLA data 1212 1213 1198 ln_slafb = .false. ! Logical switch for feedback SLA data 1214 ! ln_ssh Logical switch for SSH observations 1215 1216 ln_sst = .false. ! Logical switch for SST observations 1217 ln_reysst = .false. ! ln_reysst Logical switch for Reynolds observations 1218 ln_ghrsst = .false. ! ln_ghrsst Logical switch for GHRSST observations 1219 1199 ln_ssh = .false. ! Logical switch for SSH observations 1200 ln_sst = .false. ! Logical switch for SST observations 1201 ln_reysst = .false. ! Logical switch for Reynolds observations 1202 ln_ghrsst = .false. ! Logical switch for GHRSST observations 1220 1203 ln_sstfb = .false. ! Logical switch for feedback SST data 1221 ! ln_sssLogical switch for SSS observations1204 ln_sss = .false. ! Logical switch for SSS observations 1222 1205 ln_seaice = .false. ! Logical switch for Sea Ice observations 1223 ! ln_vel3d Logical switch for velocity observations 1224 ! ln_velavcur Logical switch for velocity daily av. cur. 1225 ! ln_velhrcur Logical switch for velocity high freq. cur. 1226 ! ln_velavadcp Logical switch for velocity daily av. ADCP 1227 ! ln_velhradcp Logical switch for velocity high freq. ADCP 1228 ! ln_velfb Logical switch for feedback velocity data 1229 ! ln_grid_global Global distribtion of observations 1230 ! ln_grid_search_lookup Logical switch for obs grid search w/lookup table 1231 ! grid_search_file Grid search lookup file header 1232 ! enactfiles ENACT input observation file names 1233 ! coriofiles Coriolis input observation file name 1234 ! ! profbfiles: Profile feedback input observation file name 1235 profbfiles = 'profiles_01.nc' 1236 ! ln_profb_enatim Enact feedback input time setting switch 1237 ! slafilesact Active SLA input observation file name 1238 ! slafilespas Passive SLA input observation file name 1239 ! ! slafbfiles: Feedback SLA input observation file name 1240 slafbfiles = 'sla_01.nc' 1241 ! sstfiles GHRSST input observation file name 1242 ! ! sstfbfiles: Feedback SST input observation file name 1243 sstfbfiles = 'sst_01.nc' 1244 ! seaicefiles Sea Ice input observation file names 1245 seaicefiles = 'seaice_01.nc' 1246 ! velavcurfiles Vel. cur. daily av. input file name 1247 ! velhvcurfiles Vel. cur. high freq. input file name 1248 ! velavadcpfiles Vel. ADCP daily av. input file name 1249 ! velhvadcpfiles Vel. ADCP high freq. input file name 1250 ! velfbfiles Vel. feedback input observation file name 1251 ! dobsini Initial date in window YYYYMMDD.HHMMSS 1252 ! dobsend Final date in window YYYYMMDD.HHMMSS 1253 ! n1dint Type of vertical interpolation method 1254 ! n2dint Type of horizontal interpolation method 1255 ! ln_nea Rejection of observations near land switch 1256 nmsshc = 0 ! MSSH correction scheme 1257 ! mdtcorr MDT correction 1258 ! mdtcutoff MDT cutoff for computed correction 1206 ln_vel3d = .false. ! Logical switch for velocity observations 1207 ln_velavcur= .false ! Logical switch for velocity daily av. cur. 1208 ln_velhrcur= .false ! Logical switch for velocity high freq. cur. 1209 ln_velavadcp = .false. ! Logical switch for velocity daily av. ADCP 1210 ln_velhradcp = .false. ! Logical switch for velocity high freq. ADCP 1211 ln_velfb = .false. ! Logical switch for feedback velocity data 1212 ln_grid_global = .false. ! Global distribtion of observations 1213 ln_grid_search_lookup = .false. ! Logical switch for obs grid search w/lookup table 1214 grid_search_file = 'grid_search' ! Grid search lookup file header 1215 ! All of the *files* variables below are arrays. Use namelist_cfg to add more files 1216 enactfiles = 'enact.nc' ! ENACT input observation file names (specify full array in namelist_cfg) 1217 coriofiles = 'corio.nc' ! Coriolis input observation file name 1218 profbfiles = 'profiles_01.nc' ! Profile feedback input observation file name 1219 ln_profb_enatim = .false ! Enact feedback input time setting switch 1220 slafilesact = 'sla_act.nc' ! Active SLA input observation file names 1221 slafilespas = 'sla_pass.nc' ! Passive SLA input observation file names 1222 slafbfiles = 'sla_01.nc' ! slafbfiles: Feedback SLA input observation file names 1223 sstfiles = 'ghrsst.nc' ! GHRSST input observation file names 1224 sstfbfiles = 'sst_01.nc' ! Feedback SST input observation file names 1225 seaicefiles = 'seaice_01.nc' ! Sea Ice input observation file names 1226 velavcurfiles = 'velavcurfile.nc' ! Vel. cur. daily av. input file name 1227 velhrcurfiles = 'velhrcurfile.nc' ! Vel. cur. high freq. input file name 1228 velavadcpfiles = 'velavadcpfile.nc' ! Vel. ADCP daily av. input file name 1229 velhradcpfiles = 'velhradcpfile.nc' ! Vel. ADCP high freq. input file name 1230 velfbfiles = 'velfbfile.nc' ! Vel. feedback input observation file name 1231 dobsini = 20000101.000000 ! Initial date in window YYYYMMDD.HHMMSS 1232 dobsend = 20010101.000000 ! Final date in window YYYYMMDD.HHMMSS 1233 n1dint = 0 ! Type of vertical interpolation method 1234 n2dint = 0 ! Type of horizontal interpolation method 1235 ln_nea = .false. ! Rejection of observations near land switch 1236 nmsshc = 0 ! MSSH correction scheme 1237 mdtcorr = 1.61 ! MDT correction 1238 mdtcutoff = 65.0 ! MDT cutoff for computed correction 1259 1239 ln_altbias = .false. ! Logical switch for alt bias 1260 1240 ln_ignmis = .true. ! Logical switch for ignoring missing files 1261 ! endailyavtypes ENACT daily average types1241 endailyavtypes = 820 ! ENACT daily average types - array (use namelist_cfg to set more values) 1262 1242 ln_grid_global = .true. 1263 1243 ln_grid_search_lookup = .false. -
branches/UKMO/dev_r5518_convadj/NEMOGCM/CONFIG/SHARED/namelist_top_ref
r5416 r6839 62 62 rn_ahtrc_0 = 2000. ! horizontal eddy diffusivity for tracers [m2/s] 63 63 rn_ahtrb_0 = 0. ! background eddy diffusivity for ldf_iso [m2/s] 64 rn_fact_lap = 1. ! enhanced zonal eddy diffusivity 64 65 / 65 66 !----------------------------------------------------------------------- -
branches/UKMO/dev_r5518_convadj/NEMOGCM/CONFIG/cfg.txt
r6836 r6839 6 6 GYRE_BFM OPA_SRC TOP_SRC 7 7 AMM12 OPA_SRC 8 ORCA2_OFF_PISCES OPA_SRC OFF_SRC TOP_SRC 8 9 ORCA2_LIM_PISCES OPA_SRC LIM_SRC_2 NST_SRC TOP_SRC 10 ORCA2_LIM3 OPA_SRC LIM_SRC_3 NST_SRC 9 11 GYRE OPA_SRC 10 ORCA2_LIM3 OPA_SRC LIM_SRC_3 NST_SRC11 12 ORCA2_LIM OPA_SRC LIM_SRC_2 NST_SRC 12 ORCA2_OFF_PISCES OPA_SRC OFF_SRC TOP_SRC -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/LIM_SRC_2/limistate_2.F90
r6836 r6839 69 69 IF( .NOT. ln_limini ) THEN 70 70 71 tfu(:,:) = eos_fzp( tsn(:,:,1,jp_sal) ) * tmask(:,:,1) ! freezing/melting point of sea water [Celcius] 71 CALL eos_fzp( tsn(:,:,1,jp_sal), tfu(:,:) ) ! freezing/melting point of sea water [Celcius] 72 tfu(:,:) = tfu(:,:) * tmask(:,:,1) 72 73 73 74 DO jj = 1, jpj -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/LIM_SRC_3/ice.F90
r6836 r6839 234 234 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: u_oce, v_oce !: surface ocean velocity used in ice dynamics 235 235 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ahiu , ahiv !: hor. diffusivity coeff. at U- and V-points [m2/s] 236 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: pahu , pahv !: ice hor. eddy diffusivity coef. at U- and V-points237 236 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ust2s, hicol !: friction velocity, ice collection thickness accreted in leads 238 237 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: strp1, strp2 !: strength at previous time steps … … 253 252 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fhld !: heat flux from the lead used for bottom melting 254 253 255 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_snw !: snow-ocean mass exchange over 1 time step [kg/m2]256 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_spr !: snow precipitation on ice over 1 time step [kg/m2]257 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_sub !: snow sublimation over 1 time step [kg/m2]258 259 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_ice !: ice-ocean mass exchange over 1 time step [kg/m2]260 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_sni !: snow ice growth component of wfx_ice [kg/m2]261 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_opw !: lateral ice growth component of wfx_ice [kg/m2]262 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_bog !: bottom ice growth component of wfx_ice [kg/m2]263 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_dyn !: dynamical ice growth component of wfx_ice [kg /m2]264 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_bom !: bottom melt component of wfx_ice [kg/m2]265 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_sum !: surface melt component of wfx_ice [kg/m2]266 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_res !: residual component of wfx_ice [kg/m2]267 268 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: afx_tot !: ice concentration tendency (total) [s-1]254 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_snw !: snow-ocean mass exchange [kg.m-2.s-1] 255 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_spr !: snow precipitation on ice [kg.m-2.s-1] 256 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_sub !: snow/ice sublimation [kg.m-2.s-1] 257 258 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_ice !: ice-ocean mass exchange [kg.m-2.s-1] 259 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_sni !: snow ice growth component of wfx_ice [kg.m-2.s-1] 260 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_opw !: lateral ice growth component of wfx_ice [kg.m-2.s-1] 261 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_bog !: bottom ice growth component of wfx_ice [kg.m-2.s-1] 262 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_dyn !: dynamical ice growth component of wfx_ice [kg.m-2.s-1] 263 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_bom !: bottom melt component of wfx_ice [kg.m-2.s-1] 264 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_sum !: surface melt component of wfx_ice [kg.m-2.s-1] 265 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_res !: residual component of wfx_ice [kg.m-2.s-1] 266 267 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: afx_tot !: ice concentration tendency (total) [s-1] 269 268 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: afx_thd !: ice concentration tendency (thermodynamics) [s-1] 270 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: afx_dyn !: ice concentration tendency (dynamics) [s-1]269 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: afx_dyn !: ice concentration tendency (dynamics) [s-1] 271 270 272 271 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sfx_bog !: salt flux due to ice growth/melt [PSU/m2/s] … … 279 278 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sfx_res !: residual salt flux due to correction of ice thickness [PSU/m2/s] 280 279 281 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_bog !: total heat flux causing bottom ice growth 282 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_bom !: total heat flux causing bottom ice melt 283 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_sum !: total heat flux causing surface ice melt 284 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_opw !: total heat flux causing open water ice formation 285 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_dif !: total heat flux causing Temp change in the ice 286 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_snw !: heat flux for snow melt 287 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_err !: heat flux error after heat diffusion 288 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_err_dif !: heat flux remaining due to change in non-solar flux 289 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_err_rem !: heat flux error after heat remapping 290 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_in !: heat flux available for thermo transformations 291 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_out !: heat flux remaining at the end of thermo transformations 292 280 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sfx_sub !: salt flux due to ice sublimation 281 282 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_bog !: total heat flux causing bottom ice growth [W.m-2] 283 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_bom !: total heat flux causing bottom ice melt [W.m-2] 284 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_sum !: total heat flux causing surface ice melt [W.m-2] 285 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_opw !: total heat flux causing open water ice formation [W.m-2] 286 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_dif !: total heat flux causing Temp change in the ice [W.m-2] 287 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_snw !: heat flux for snow melt [W.m-2] 288 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_err !: heat flux error after heat diffusion [W.m-2] 289 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_err_dif !: heat flux remaining due to change in non-solar flux [W.m-2] 290 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_err_rem !: heat flux error after heat remapping [W.m-2] 291 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_in !: heat flux available for thermo transformations [W.m-2] 292 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_out !: heat flux remaining at the end of thermo transformations [W.m-2] 293 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_err_sub !: mass flux error after sublimation [kg.m-2.s-1] 294 293 295 ! heat flux associated with ice-atmosphere mass exchange 294 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_sub !: heat flux for sublimation 295 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_spr !: heat flux of the snow precipitation 296 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_sub !: heat flux for sublimation [W.m-2] 297 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_spr !: heat flux of the snow precipitation [W.m-2] 296 298 297 299 ! heat flux associated with ice-ocean mass exchange 298 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_thd !: ice-ocean heat flux from thermo processes (limthd_dh) 299 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_dyn !: ice-ocean heat flux from mecanical processes (limitd_me) 300 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_res !: residual heat flux due to correction of ice thickness 301 302 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ftr_ice !: transmitted solar radiation under ice 300 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_thd !: ice-ocean heat flux from thermo processes (limthd_dh) [W.m-2] 301 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_dyn !: ice-ocean heat flux from mecanical processes (limitd_me) [W.m-2] 302 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_res !: residual heat flux due to correction of ice thickness [W.m-2] 303 304 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ftr_ice !: transmitted solar radiation under ice 305 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: pahu3D , pahv3D 306 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: rn_amax_2d !: maximum ice concentration 2d array 303 307 304 308 !!-------------------------------------------------------------------------- … … 372 376 INTEGER , PUBLIC :: nlay_i !: number of ice layers 373 377 INTEGER , PUBLIC :: nlay_s !: number of snow layers 374 CHARACTER(len= 32), PUBLIC :: cn_icerst_in !: suffix of ice restart name (input)378 CHARACTER(len=80), PUBLIC :: cn_icerst_in !: suffix of ice restart name (input) 375 379 CHARACTER(len=256), PUBLIC :: cn_icerst_indir !: ice restart input directory 376 CHARACTER(len= 32), PUBLIC :: cn_icerst_out !: suffix of ice restart name (output)380 CHARACTER(len=80), PUBLIC :: cn_icerst_out !: suffix of ice restart name (output) 377 381 CHARACTER(len=256), PUBLIC :: cn_icerst_outdir!: ice restart output directory 378 382 LOGICAL , PUBLIC :: ln_limdyn !: flag for ice dynamics (T) or not (F) 379 383 LOGICAL , PUBLIC :: ln_icectl !: flag for sea-ice points output (T) or not (F) 380 REAL(wp) , PUBLIC :: rn_amax !: maximum ice concentration 384 REAL(wp) , PUBLIC :: rn_amax_n !: maximum ice concentration Northern hemisphere 385 REAL(wp) , PUBLIC :: rn_amax_s !: maximum ice concentration Southern hemisphere 381 386 INTEGER , PUBLIC :: iiceprt !: debug i-point 382 387 INTEGER , PUBLIC :: jiceprt !: debug j-point … … 424 429 ALLOCATE( u_oce (jpi,jpj) , v_oce (jpi,jpj) , & 425 430 & ahiu (jpi,jpj) , ahiv (jpi,jpj) , & 426 & pahu (jpi,jpj) , pahv (jpi,jpj) , &427 431 & ust2s (jpi,jpj) , hicol (jpi,jpj) , & 428 432 & strp1 (jpi,jpj) , strp2 (jpi,jpj) , strength (jpi,jpj) , & … … 437 441 & wfx_res(jpi,jpj) , wfx_sni(jpi,jpj) , wfx_opw(jpi,jpj) , wfx_spr(jpi,jpj) , & 438 442 & afx_tot(jpi,jpj) , afx_thd(jpi,jpj), afx_dyn(jpi,jpj) , & 439 & fhtur (jpi,jpj) , ftr_ice(jpi,jpj,jpl), qlead (jpi,jpj) , & 440 & sfx_res(jpi,jpj) , sfx_bri(jpi,jpj) , sfx_dyn(jpi,jpj) , & 443 & fhtur (jpi,jpj) , ftr_ice(jpi,jpj,jpl), pahu3D(jpi,jpj,jpl+1), pahv3D(jpi,jpj,jpl+1), & 444 & qlead (jpi,jpj) , rn_amax_2d(jpi,jpj), & 445 & sfx_res(jpi,jpj) , sfx_bri(jpi,jpj) , sfx_dyn(jpi,jpj) , sfx_sub(jpi,jpj), & 441 446 & sfx_bog(jpi,jpj) , sfx_bom(jpi,jpj) , sfx_sum(jpi,jpj) , sfx_sni(jpi,jpj) , sfx_opw(jpi,jpj) , & 442 447 & hfx_res(jpi,jpj) , hfx_snw(jpi,jpj) , hfx_sub(jpi,jpj) , hfx_err(jpi,jpj) , & 443 & hfx_err_dif(jpi,jpj) , hfx_err_rem(jpi,jpj) , 448 & hfx_err_dif(jpi,jpj) , hfx_err_rem(jpi,jpj) , wfx_err_sub(jpi,jpj) , & 444 449 & hfx_in (jpi,jpj) , hfx_out(jpi,jpj) , fhld(jpi,jpj) , & 445 450 & hfx_sum(jpi,jpj) , hfx_bom(jpi,jpj) , hfx_bog(jpi,jpj) , hfx_dif(jpi,jpj) , hfx_opw(jpi,jpj) , & … … 508 513 !!====================================================================== 509 514 END MODULE ice 515 -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/LIM_SRC_3/limcons.F90
r6836 r6839 24 24 USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 25 25 USE sbc_oce , ONLY : sfx ! Surface boundary condition: ocean fields 26 26 USE sbc_ice , ONLY : qevap_ice 27 27 28 IMPLICIT NONE 28 29 PRIVATE … … 184 185 ! salt flux 185 186 zfs_b = glob_sum( ( sfx_bri(:,:) + sfx_bog(:,:) + sfx_bom(:,:) + sfx_sum(:,:) + sfx_sni(:,:) + & 186 & sfx_opw(:,:) + sfx_res(:,:) + sfx_dyn(:,:) 187 & sfx_opw(:,:) + sfx_res(:,:) + sfx_dyn(:,:) + sfx_sub(:,:) & 187 188 & ) * e12t(:,:) * tmask(:,:,1) * zconv ) 188 189 … … 209 210 ! salt flux 210 211 zfs = glob_sum( ( sfx_bri(:,:) + sfx_bog(:,:) + sfx_bom(:,:) + sfx_sum(:,:) + sfx_sni(:,:) + & 211 & sfx_opw(:,:) + sfx_res(:,:) + sfx_dyn(:,:) 212 & sfx_opw(:,:) + sfx_res(:,:) + sfx_dyn(:,:) + sfx_sub(:,:) & 212 213 & ) * e12t(:,:) * tmask(:,:,1) * zconv ) - zfs_b 213 214 … … 256 257 ENDIF 257 258 IF ( zvmin < -epsi10 ) WRITE(numout,*) 'violation v_i<0 [m] (',cd_routine,') = ',zvmin 258 IF ( zamax > rn_amax+epsi10 .AND. cd_routine /= 'limtrp' .AND. cd_routine /= 'limitd_me' ) THEN 259 IF ( zamax > MAX( rn_amax_n, rn_amax_s ) + epsi10 .AND. & 260 & cd_routine /= 'limtrp' .AND. cd_routine /= 'limitd_me' ) THEN 259 261 WRITE(numout,*) 'violation a_i>amax (',cd_routine,') = ',zamax 260 262 ENDIF … … 286 288 #if ! defined key_bdy 287 289 ! heat flux 288 zhfx = glob_sum( ( hfx_in - hfx_out - diag_heat - diag_trp_ei - diag_trp_es - hfx_sub ) * e12t * tmask(:,:,1) * zconv ) 290 zhfx = glob_sum( ( hfx_in - hfx_out - diag_heat - diag_trp_ei - diag_trp_es - SUM( qevap_ice * a_i_b, dim=3 ) ) & 291 & * e12t * tmask(:,:,1) * zconv ) 289 292 ! salt flux 290 293 zsfx = glob_sum( ( sfx + diag_smvi ) * e12t * tmask(:,:,1) * zconv ) * rday -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/LIM_SRC_3/limdiahsb.F90
r6836 r6839 56 56 real(wp) :: zbg_ivo, zbg_svo, zbg_are, zbg_sal ,zbg_tem ,zbg_ihc ,zbg_shc 57 57 real(wp) :: zbg_sfx, zbg_sfx_bri, zbg_sfx_bog, zbg_sfx_bom, zbg_sfx_sum, zbg_sfx_sni, & 58 & zbg_sfx_opw, zbg_sfx_res, zbg_sfx_dyn 58 & zbg_sfx_opw, zbg_sfx_res, zbg_sfx_dyn, zbg_sfx_sub 59 59 real(wp) :: zbg_vfx, zbg_vfx_bog, zbg_vfx_opw, zbg_vfx_sni, zbg_vfx_dyn 60 60 real(wp) :: zbg_vfx_bom, zbg_vfx_sum, zbg_vfx_res, zbg_vfx_spr, zbg_vfx_snw, zbg_vfx_sub … … 111 111 zbg_sfx_bom = ztmp * glob_sum( sfx_bom(:,:) * e12t(:,:) * tmask(:,:,1) ) 112 112 zbg_sfx_sum = ztmp * glob_sum( sfx_sum(:,:) * e12t(:,:) * tmask(:,:,1) ) 113 zbg_sfx_sub = ztmp * glob_sum( sfx_sub(:,:) * e12t(:,:) * tmask(:,:,1) ) 113 114 114 115 ! Heat budget … … 189 190 CALL iom_put( 'ibgsfxbom' , zbg_sfx_bom ) ! salt flux bottom melt - 190 191 CALL iom_put( 'ibgsfxsum' , zbg_sfx_sum ) ! salt flux surface melt - 192 CALL iom_put( 'ibgsfxsub' , zbg_sfx_sub ) ! salt flux sublimation - 191 193 192 194 CALL iom_put( 'ibghfxdhc' , zbg_hfx_dhc ) ! Heat content variation in snow and ice [W] -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/LIM_SRC_3/limhdf.F90
r6836 r6839 7 7 !! - ! 2001-05 (G. Madec, R. Hordoir) opa norm 8 8 !! 1.0 ! 2002-08 (C. Ethe) F90, free form 9 !! 3.0 ! 2015-08 (O. Tintó and M. Castrillo) added lim_hdf (multiple) 9 10 !!---------------------------------------------------------------------- 10 11 #if defined key_lim3 … … 27 28 PRIVATE 28 29 29 PUBLIC lim_hdf 30 PUBLIC lim_hdf ! called by lim_trp 30 31 PUBLIC lim_hdf_init ! called by sbc_lim_init 31 32 … … 43 44 CONTAINS 44 45 45 SUBROUTINE lim_hdf( ptab )46 SUBROUTINE lim_hdf( ptab , ihdf_vars , jpl , nlay_i ) 46 47 !!------------------------------------------------------------------- 47 48 !! *** ROUTINE lim_hdf *** … … 54 55 !! ** Action : update ptab with the diffusive contribution 55 56 !!------------------------------------------------------------------- 56 REAL(wp), DIMENSION(jpi,jpj), INTENT( inout ) :: ptab ! Field on which the diffusion is applied 57 ! 58 INTEGER :: ji, jj ! dummy loop indices 57 INTEGER :: jpl, nlay_i, isize, ihdf_vars 58 REAL(wp), DIMENSION(:,:,:), INTENT( inout ),TARGET :: ptab ! Field on which the diffusion is applied 59 ! 60 INTEGER :: ji, jj, jk, jl , jm ! dummy loop indices 59 61 INTEGER :: iter, ierr ! local integers 60 REAL(wp) :: zrlxint, zconv ! local scalars 61 REAL(wp), POINTER, DIMENSION(:,:) :: zrlx, zflu, zflv, zdiv0, zdiv, ztab0 62 REAL(wp) :: zrlxint ! local scalars 63 REAL(wp), POINTER , DIMENSION ( : ) :: zconv ! local scalars 64 REAL(wp), POINTER , DIMENSION(:,:,:) :: zrlx,zdiv0, ztab0 65 REAL(wp), POINTER , DIMENSION(:,:) :: zflu, zflv, zdiv 62 66 CHARACTER(lc) :: charout ! local character 63 67 REAL(wp), PARAMETER :: zrelax = 0.5_wp ! relaxation constant for iterative procedure … … 65 69 INTEGER , PARAMETER :: its = 100 ! Maximum number of iteration 66 70 !!------------------------------------------------------------------- 71 TYPE(arrayptr) , ALLOCATABLE, DIMENSION(:) :: pt2d_array, zrlx_array 72 CHARACTER(len=1) , ALLOCATABLE, DIMENSION(:) :: type_array ! define the nature of ptab array grid-points 73 ! ! = T , U , V , F , W and I points 74 REAL(wp) , ALLOCATABLE, DIMENSION(:) :: psgn_array ! =-1 the sign change across the north fold boundary 75 76 !!--------------------------------------------------------------------- 77 78 ! !== Initialisation ==! 79 ! +1 open water diffusion 80 isize = jpl*(ihdf_vars+nlay_i)+1 81 ALLOCATE( zconv (isize) ) 82 ALLOCATE( pt2d_array(isize) , zrlx_array(isize) ) 83 ALLOCATE( type_array(isize) ) 84 ALLOCATE( psgn_array(isize) ) 67 85 68 CALL wrk_alloc( jpi, jpj, zrlx, zflu, zflv, zdiv0, zdiv, ztab0 ) 69 70 ! !== Initialisation ==! 86 CALL wrk_alloc( jpi, jpj, isize, zrlx, zdiv0, ztab0 ) 87 CALL wrk_alloc( jpi, jpj, zflu, zflv, zdiv ) 88 89 DO jk= 1 , isize 90 pt2d_array(jk)%pt2d=>ptab(:,:,jk) 91 zrlx_array(jk)%pt2d=>zrlx(:,:,jk) 92 type_array(jk)='T' 93 psgn_array(jk)=1. 94 END DO 95 71 96 ! 72 97 IF( linit ) THEN ! Metric coefficient (compute at the first call and saved in efact) … … 74 99 IF( lk_mpp ) CALL mpp_sum( ierr ) 75 100 IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'lim_hdf : unable to allocate arrays' ) 76 DO jj = 2, jpjm1 101 DO jj = 2, jpjm1 77 102 DO ji = fs_2 , fs_jpim1 ! vector opt. 78 103 efact(ji,jj) = ( e2u(ji,jj) + e2u(ji-1,jj) + e1v(ji,jj) + e1v(ji,jj-1) ) * r1_e12t(ji,jj) … … 83 108 ! ! Time integration parameters 84 109 ! 85 ztab0(:, : ) = ptab(:,:) ! Arrays initialization 86 zdiv0(:, 1 ) = 0._wp 87 zdiv0(:,jpj) = 0._wp 88 zflu (jpi,:) = 0._wp 89 zflv (jpi,:) = 0._wp 90 zdiv0(1, :) = 0._wp 91 zdiv0(jpi,:) = 0._wp 110 zflu (jpi,: ) = 0._wp 111 zflv (jpi,: ) = 0._wp 112 113 DO jk=1 , isize 114 ztab0(:, : , jk ) = ptab(:,:,jk) ! Arrays initialization 115 zdiv0(:, 1 , jk ) = 0._wp 116 zdiv0(:,jpj, jk ) = 0._wp 117 zdiv0(1, :, jk ) = 0._wp 118 zdiv0(jpi,:, jk ) = 0._wp 119 END DO 92 120 93 121 zconv = 1._wp !== horizontal diffusion using a Crant-Nicholson scheme ==! 94 122 iter = 0 95 123 ! 96 DO WHILE( zconv> ( 2._wp * 1.e-04 ) .AND. iter <= its ) ! Sub-time step loop124 DO WHILE( MAXVAL(zconv(:)) > ( 2._wp * 1.e-04 ) .AND. iter <= its ) ! Sub-time step loop 97 125 ! 98 126 iter = iter + 1 ! incrementation of the sub-time step number 99 127 ! 128 DO jk = 1 , isize 129 jl = (jk-1) /( ihdf_vars+nlay_i)+1 130 IF (zconv(jk) > ( 2._wp * 1.e-04 )) THEN 131 DO jj = 1, jpjm1 ! diffusive fluxes in U- and V- direction 132 DO ji = 1 , fs_jpim1 ! vector opt. 133 zflu(ji,jj) = pahu3D(ji,jj,jl) * e2u(ji,jj) * r1_e1u(ji,jj) * ( ptab(ji+1,jj,jk) - ptab(ji,jj,jk) ) 134 zflv(ji,jj) = pahv3D(ji,jj,jl) * e1v(ji,jj) * r1_e2v(ji,jj) * ( ptab(ji,jj+1,jk) - ptab(ji,jj,jk) ) 135 END DO 136 END DO 137 ! 138 DO jj= 2, jpjm1 ! diffusive trend : divergence of the fluxes 139 DO ji = fs_2 , fs_jpim1 ! vector opt. 140 zdiv(ji,jj) = ( zflu(ji,jj) - zflu(ji-1,jj) + zflv(ji,jj) - zflv(ji,jj-1) ) * r1_e12t(ji,jj) 141 END DO 142 END DO 143 ! 144 IF( iter == 1 ) zdiv0(:,:,jk) = zdiv(:,:) ! save the 1st evaluation of the diffusive trend in zdiv0 145 ! 146 DO jj = 2, jpjm1 ! iterative evaluation 147 DO ji = fs_2 , fs_jpim1 ! vector opt. 148 zrlxint = ( ztab0(ji,jj,jk) & 149 & + rdt_ice * ( zalfa * ( zdiv(ji,jj) + efact(ji,jj) * ptab(ji,jj,jk) ) & 150 & + ( 1.0 - zalfa ) * zdiv0(ji,jj,jk) ) & 151 & ) / ( 1.0 + zalfa * rdt_ice * efact(ji,jj) ) 152 zrlx(ji,jj,jk) = ptab(ji,jj,jk) + zrelax * ( zrlxint - ptab(ji,jj,jk) ) 153 END DO 154 END DO 155 END IF 156 157 END DO 158 159 CALL lbc_lnk_multi( zrlx_array, type_array , psgn_array , isize ) ! Multiple interchange of all the variables 160 ! 161 162 IF ( MOD( iter-1 , nn_convfrq ) == 0 ) THEN !Convergence test every nn_convfrq iterations (perf. optimization ) 163 DO jk=1,isize 164 zconv(jk) = 0._wp ! convergence test 165 DO jj = 2, jpjm1 166 DO ji = fs_2, fs_jpim1 167 zconv(jk) = MAX( zconv(jk), ABS( zrlx(ji,jj,jk) - ptab(ji,jj,jk) ) ) 168 END DO 169 END DO 170 END DO 171 IF( lk_mpp ) CALL mpp_max_multiple( zconv , isize ) ! max over the global domain for all the variables 172 ENDIF 173 ! 174 DO jk=1,isize 175 ptab(:,:,jk) = zrlx(:,:,jk) 176 END DO 177 ! 178 END DO ! end of sub-time step loop 179 180 ! ----------------------- 181 !!! final step (clem) !!! 182 DO jk = 1, isize 183 jl = (jk-1) /( ihdf_vars+nlay_i)+1 100 184 DO jj = 1, jpjm1 ! diffusive fluxes in U- and V- direction 101 185 DO ji = 1 , fs_jpim1 ! vector opt. 102 zflu(ji,jj) = pahu (ji,jj) * e2u(ji,jj) * r1_e1u(ji,jj) * ( ptab(ji+1,jj) - ptab(ji,jj) )103 zflv(ji,jj) = pahv (ji,jj) * e1v(ji,jj) * r1_e2v(ji,jj) * ( ptab(ji,jj+1) - ptab(ji,jj) )186 zflu(ji,jj) = pahu3D(ji,jj,jl) * e2u(ji,jj) * r1_e1u(ji,jj) * ( ptab(ji+1,jj,jk) - ptab(ji,jj,jk) ) 187 zflv(ji,jj) = pahv3D(ji,jj,jl) * e1v(ji,jj) * r1_e2v(ji,jj) * ( ptab(ji,jj+1,jk) - ptab(ji,jj,jk) ) 104 188 END DO 105 189 END DO … … 108 192 DO ji = fs_2 , fs_jpim1 ! vector opt. 109 193 zdiv(ji,jj) = ( zflu(ji,jj) - zflu(ji-1,jj) + zflv(ji,jj) - zflv(ji,jj-1) ) * r1_e12t(ji,jj) 110 END DO 111 END DO 112 ! 113 IF( iter == 1 ) zdiv0(:,:) = zdiv(:,:) ! save the 1st evaluation of the diffusive trend in zdiv0 114 ! 115 DO jj = 2, jpjm1 ! iterative evaluation 116 DO ji = fs_2 , fs_jpim1 ! vector opt. 117 zrlxint = ( ztab0(ji,jj) & 118 & + rdt_ice * ( zalfa * ( zdiv(ji,jj) + efact(ji,jj) * ptab(ji,jj) ) & 119 & + ( 1.0 - zalfa ) * zdiv0(ji,jj) ) & 120 & ) / ( 1.0 + zalfa * rdt_ice * efact(ji,jj) ) 121 zrlx(ji,jj) = ptab(ji,jj) + zrelax * ( zrlxint - ptab(ji,jj) ) 122 END DO 123 END DO 124 CALL lbc_lnk( zrlx, 'T', 1. ) ! lateral boundary condition 125 ! 126 IF ( MOD( iter, nn_convfrq ) == 0 ) THEN ! convergence test every nn_convfrq iterations (perf. optimization) 127 zconv = 0._wp 128 DO jj = 2, jpjm1 129 DO ji = fs_2, fs_jpim1 130 zconv = MAX( zconv, ABS( zrlx(ji,jj) - ptab(ji,jj) ) ) 131 END DO 132 END DO 133 IF( lk_mpp ) CALL mpp_max( zconv ) ! max over the global domain 134 ENDIF 135 ! 136 ptab(:,:) = zrlx(:,:) 137 ! 138 END DO ! end of sub-time step loop 139 140 ! ----------------------- 141 !!! final step (clem) !!! 142 DO jj = 1, jpjm1 ! diffusive fluxes in U- and V- direction 143 DO ji = 1 , fs_jpim1 ! vector opt. 144 zflu(ji,jj) = pahu(ji,jj) * e2u(ji,jj) * r1_e1u(ji,jj) * ( ptab(ji+1,jj) - ptab(ji,jj) ) 145 zflv(ji,jj) = pahv(ji,jj) * e1v(ji,jj) * r1_e2v(ji,jj) * ( ptab(ji,jj+1) - ptab(ji,jj) ) 194 ptab(ji,jj,jk) = ztab0(ji,jj,jk) + 0.5 * ( zdiv(ji,jj) + zdiv0(ji,jj,jk) ) 195 END DO 146 196 END DO 147 197 END DO 148 ! 149 DO jj= 2, jpjm1 ! diffusive trend : divergence of the fluxes 150 DO ji = fs_2 , fs_jpim1 ! vector opt. 151 zdiv(ji,jj) = ( zflu(ji,jj) - zflu(ji-1,jj) + zflv(ji,jj) - zflv(ji,jj-1) ) * r1_e12t(ji,jj) 152 ptab(ji,jj) = ztab0(ji,jj) + 0.5 * ( zdiv(ji,jj) + zdiv0(ji,jj) ) 153 END DO 154 END DO 155 CALL lbc_lnk( ptab, 'T', 1. ) ! lateral boundary condition 198 199 CALL lbc_lnk_multi( pt2d_array, type_array , psgn_array , isize ) ! Multiple interchange of all the variables 200 156 201 !!! final step (clem) !!! 157 202 ! ----------------------- 158 203 159 204 IF(ln_ctl) THEN 160 zrlx(:,:) = ptab(:,:) - ztab0(:,:) 161 WRITE(charout,FMT="(' lim_hdf : zconv =',D23.16, ' iter =',I4,2X)") zconv, iter 162 CALL prt_ctl( tab2d_1=zrlx, clinfo1=charout ) 163 ENDIF 164 ! 165 CALL wrk_dealloc( jpi, jpj, zrlx, zflu, zflv, zdiv0, zdiv, ztab0 ) 205 DO jk = 1 , isize 206 zrlx(:,:,jk) = ptab(:,:,jk) - ztab0(:,:,jk) 207 WRITE(charout,FMT="(' lim_hdf : zconv =',D23.16, ' iter =',I4,2X)") zconv, iter 208 CALL prt_ctl( tab2d_1=zrlx(:,:,jk), clinfo1=charout ) 209 END DO 210 ENDIF 211 ! 212 CALL wrk_dealloc( jpi, jpj, isize, zrlx, zdiv0, ztab0 ) 213 CALL wrk_dealloc( jpi, jpj, zflu, zflv, zdiv ) 214 215 DEALLOCATE( zconv ) 216 DEALLOCATE( pt2d_array , zrlx_array ) 217 DEALLOCATE( type_array ) 218 DEALLOCATE( psgn_array ) 166 219 ! 167 220 END SUBROUTINE lim_hdf 221 168 222 169 223 … … 179 233 !!------------------------------------------------------------------- 180 234 INTEGER :: ios ! Local integer output status for namelist read 181 NAMELIST/namicehdf/ nn_convfrq 235 NAMELIST/namicehdf/ nn_convfrq 182 236 !!------------------------------------------------------------------- 183 237 ! … … 212 266 !!====================================================================== 213 267 END MODULE limhdf 268 -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/LIM_SRC_3/limistate.F90
r6836 r6839 24 24 USE par_oce ! ocean parameters 25 25 USE dom_ice ! sea-ice domain 26 USE limvar ! lim_var_salprof 26 27 USE in_out_manager ! I/O manager 27 28 USE lib_mpp ! MPP library … … 117 118 118 119 ! basal temperature (considered at freezing point) 119 t_bo(:,:) = ( eos_fzp( sss_m(:,:) ) + rt0 ) * tmask(:,:,1) 120 CALL eos_fzp( sss_m(:,:), t_bo(:,:) ) 121 t_bo(:,:) = ( t_bo(:,:) + rt0 ) * tmask(:,:,1) 120 122 121 123 IF( ln_iceini ) THEN … … 245 247 ztest_1 = 1 246 248 ELSE 247 ! this write is useful248 IF(lwp) WRITE(numout,*) ' * TEST1 AREA NOT CONSERVED *** zA_cons = ', zA_cons,' zat_i_ini = ',zat_i_ini(i_hemis)249 249 ztest_1 = 0 250 250 ENDIF … … 257 257 ztest_2 = 1 258 258 ELSE 259 ! this write is useful260 IF(lwp) WRITE(numout,*) ' * TEST2 VOLUME NOT CONSERVED *** zV_cons = ', zV_cons, &261 ' zvt_i_ini = ', zvt_i_ini(i_hemis)262 259 ztest_2 = 0 263 260 ENDIF … … 267 264 ztest_3 = 1 268 265 ELSE 269 ! this write is useful270 IF(lwp) WRITE(numout,*) ' * TEST 3 THICKNESS OF THE LAST CATEGORY OUT OF BOUNDS *** zh_i_ini(i_fill,i_hemis) = ', &271 zh_i_ini(i_fill,i_hemis), ' hi_max(jpl-1) = ', hi_max(i_fill-1)272 266 ztest_3 = 0 273 267 ENDIF … … 277 271 DO jl = 1, jpl 278 272 IF ( za_i_ini(jl,i_hemis) .LT. 0._wp ) THEN 279 ! this write is useful280 IF(lwp) WRITE(numout,*) ' * TEST 4 POSITIVITY NOT OK FOR CAT ', jl, ' WITH A = ', za_i_ini(jl,i_hemis)281 273 ztest_4 = 0 282 274 ENDIF … … 336 328 END DO 337 329 END DO 330 331 ! for constant salinity in time 332 IF( nn_icesal == 1 .OR. nn_icesal == 3 ) THEN 333 CALL lim_var_salprof 334 smv_i = sm_i * v_i 335 ENDIF 338 336 339 337 ! Snow temperature and heat content -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/LIM_SRC_3/limitd_me.F90
r6836 r6839 45 45 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: asum ! sum of total ice and open water area 46 46 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: aksum ! ratio of area removed to area ridged 47 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: athorn ! participation function; fraction of ridging/ 48 ! ! closing associated w/ category n 47 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: athorn ! participation function; fraction of ridging/closing associated w/ category n 49 48 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: hrmin ! minimum ridge thickness 50 49 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: hrmax ! maximum ridge thickness 51 50 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: hraft ! thickness of rafted ice 52 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: krdg ! mean ridge thickness/thickness of ridging ice51 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: krdg ! thickness of ridging ice / mean ridge thickness 53 52 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: aridge ! participating ice ridging 54 53 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: araft ! participating ice rafting 55 54 56 55 REAL(wp), PARAMETER :: krdgmin = 1.1_wp ! min ridge thickness multiplier 57 REAL(wp), PARAMETER :: kraft = 2.0_wp ! rafting multipliyer 58 REAL(wp), PARAMETER :: kamax = 1.0_wp ! max of ice area authorized (clem: scheme is not stable if kamax <= 0.99) 56 REAL(wp), PARAMETER :: kraft = 0.5_wp ! rafting multipliyer 59 57 60 58 REAL(wp) :: Cp ! 61 59 ! 62 !-----------------------------------------------------------------------63 ! Ridging diagnostic arrays for history files64 !-----------------------------------------------------------------------65 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: dardg1dt ! rate of fractional area loss by ridging ice (1/s)66 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: dardg2dt ! rate of fractional area gain by new ridges (1/s)67 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: dvirdgdt ! rate of ice volume ridged (m/s)68 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: opening ! rate of opening due to divergence/shear (1/s)69 60 ! 70 61 !!---------------------------------------------------------------------- … … 83 74 & asum (jpi,jpj) , athorn(jpi,jpj,0:jpl) , & 84 75 & aksum(jpi,jpj) , & 85 !86 76 & hrmin(jpi,jpj,jpl) , hraft(jpi,jpj,jpl) , aridge(jpi,jpj,jpl) , & 87 & hrmax(jpi,jpj,jpl) , krdg (jpi,jpj,jpl) , araft (jpi,jpj,jpl) , & 88 ! 89 !* Ridging diagnostic arrays for history files 90 & dardg1dt(jpi,jpj) , dardg2dt(jpi,jpj) , & 91 & dvirdgdt(jpi,jpj) , opening(jpi,jpj) , STAT=lim_itd_me_alloc ) 77 & hrmax(jpi,jpj,jpl) , krdg (jpi,jpj,jpl) , araft (jpi,jpj,jpl) , STAT=lim_itd_me_alloc ) 92 78 ! 93 79 IF( lim_itd_me_alloc /= 0 ) CALL ctl_warn( 'lim_itd_me_alloc: failed to allocate arrays' ) … … 132 118 REAL(wp), POINTER, DIMENSION(:,:) :: opning ! rate of opening due to divergence/shear 133 119 REAL(wp), POINTER, DIMENSION(:,:) :: closing_gross ! rate at which area removed, not counting area of new ridges 134 REAL(wp), POINTER, DIMENSION(:,:) :: msnow_mlt ! mass of snow added to ocean (kg m-2)135 REAL(wp), POINTER, DIMENSION(:,:) :: esnow_mlt ! energy needed to melt snow in ocean (J m-2)136 REAL(wp), POINTER, DIMENSION(:,:) :: vt_i_init, vt_i_final ! ice volume summed over categories137 120 ! 138 121 INTEGER, PARAMETER :: nitermax = 20 … … 142 125 IF( nn_timing == 1 ) CALL timing_start('limitd_me') 143 126 144 CALL wrk_alloc( jpi,jpj, closing_net, divu_adv, opning, closing_gross , msnow_mlt, esnow_mlt, vt_i_init, vt_i_final)127 CALL wrk_alloc( jpi,jpj, closing_net, divu_adv, opning, closing_gross ) 145 128 146 129 IF(ln_ctl) THEN … … 154 137 IF( ln_limdiahsb ) CALL lim_cons_hsm(0, 'limitd_me', zvi_b, zsmv_b, zei_b, zfw_b, zfs_b, zft_b) 155 138 156 CALL lim_var_zapsmall157 CALL lim_var_glo2eqv ! equivalent variables, requested for rafting158 159 139 !-----------------------------------------------------------------------------! 160 140 ! 1) Thickness categories boundaries, ice / o.w. concentrations, init_ons … … 164 144 CALL lim_itd_me_ridgeprep ! prepare ridging 165 145 ! 166 IF( con_i) CALL lim_column_sum( jpl, v_i, vt_i_init ) ! conservation check167 146 168 147 DO jj = 1, jpj ! Initialize arrays. 169 148 DO ji = 1, jpi 170 msnow_mlt(ji,jj) = 0._wp171 esnow_mlt(ji,jj) = 0._wp172 dardg1dt (ji,jj) = 0._wp173 dardg2dt (ji,jj) = 0._wp174 dvirdgdt (ji,jj) = 0._wp175 opening (ji,jj) = 0._wp176 149 177 150 !-----------------------------------------------------------------------------! … … 204 177 ! If divu_adv < 0, make sure the closing rate is large enough 205 178 ! to give asum = 1.0 after ridging. 206 207 divu_adv(ji,jj) = ( kamax- asum(ji,jj) ) * r1_rdtice ! asum found in ridgeprep179 180 divu_adv(ji,jj) = ( 1._wp - asum(ji,jj) ) * r1_rdtice ! asum found in ridgeprep 208 181 209 182 IF( divu_adv(ji,jj) < 0._wp ) closing_net(ji,jj) = MAX( closing_net(ji,jj), -divu_adv(ji,jj) ) … … 224 197 DO WHILE ( iterate_ridging > 0 .AND. niter < nitermax ) 225 198 199 ! 3.2 closing_gross 200 !-----------------------------------------------------------------------------! 201 ! Based on the ITD of ridging and ridged ice, convert the net 202 ! closing rate to a gross closing rate. 203 ! NOTE: 0 < aksum <= 1 204 closing_gross(:,:) = closing_net(:,:) / aksum(:,:) 205 206 ! correction to closing rate and opening if closing rate is excessive 207 !--------------------------------------------------------------------- 208 ! Reduce the closing rate if more than 100% of the open water 209 ! would be removed. Reduce the opening rate proportionately. 226 210 DO jj = 1, jpj 227 211 DO ji = 1, jpi 228 229 ! 3.2 closing_gross 230 !-----------------------------------------------------------------------------! 231 ! Based on the ITD of ridging and ridged ice, convert the net 232 ! closing rate to a gross closing rate. 233 ! NOTE: 0 < aksum <= 1 234 closing_gross(ji,jj) = closing_net(ji,jj) / aksum(ji,jj) 235 236 ! correction to closing rate and opening if closing rate is excessive 237 !--------------------------------------------------------------------- 238 ! Reduce the closing rate if more than 100% of the open water 239 ! would be removed. Reduce the opening rate proportionately. 240 za = athorn(ji,jj,0) * closing_gross(ji,jj) * rdt_ice 241 IF( za > epsi20 ) THEN 242 zfac = MIN( 1._wp, ato_i(ji,jj) / za ) 243 closing_gross(ji,jj) = closing_gross(ji,jj) * zfac 244 opning (ji,jj) = opning (ji,jj) * zfac 212 za = ( opning(ji,jj) - athorn(ji,jj,0) * closing_gross(ji,jj) ) * rdt_ice 213 IF( za < 0._wp .AND. za > - ato_i(ji,jj) ) THEN ! would lead to negative ato_i 214 zfac = - ato_i(ji,jj) / za 215 opning(ji,jj) = athorn(ji,jj,0) * closing_gross(ji,jj) - ato_i(ji,jj) * r1_rdtice 216 ELSEIF( za > 0._wp .AND. za > ( asum(ji,jj) - ato_i(ji,jj) ) ) THEN ! would lead to ato_i > asum 217 zfac = ( asum(ji,jj) - ato_i(ji,jj) ) / za 218 opning(ji,jj) = athorn(ji,jj,0) * closing_gross(ji,jj) + ( asum(ji,jj) - ato_i(ji,jj) ) * r1_rdtice 245 219 ENDIF 246 247 220 END DO 248 221 END DO … … 256 229 DO ji = 1, jpi 257 230 za = athorn(ji,jj,jl) * closing_gross(ji,jj) * rdt_ice 258 IF( za > epsi20) THEN259 zfac = MIN( 1._wp, a_i(ji,jj,jl) / za )231 IF( za > a_i(ji,jj,jl) ) THEN 232 zfac = a_i(ji,jj,jl) / za 260 233 closing_gross(ji,jj) = closing_gross(ji,jj) * zfac 261 opning (ji,jj) = opning (ji,jj) * zfac262 234 ENDIF 263 235 END DO … … 268 240 !-----------------------------------------------------------------------------! 269 241 270 CALL lim_itd_me_ridgeshift( opning, closing_gross, msnow_mlt, esnow_mlt ) 271 242 CALL lim_itd_me_ridgeshift( opning, closing_gross ) 243 244 272 245 ! 3.4 Compute total area of ice plus open water after ridging. 273 246 !-----------------------------------------------------------------------------! 274 247 ! This is in general not equal to one because of divergence during transport 275 asum(:,:) = ato_i(:,:) 276 DO jl = 1, jpl 277 asum(:,:) = asum(:,:) + a_i(:,:,jl) 278 END DO 248 asum(:,:) = ato_i(:,:) + SUM( a_i, dim=3 ) 279 249 280 250 ! 3.5 Do we keep on iterating ??? … … 284 254 285 255 iterate_ridging = 0 286 287 256 DO jj = 1, jpj 288 257 DO ji = 1, jpi 289 IF (ABS(asum(ji,jj) - kamax ) < epsi10) THEN258 IF( ABS( asum(ji,jj) - 1._wp ) < epsi10 ) THEN 290 259 closing_net(ji,jj) = 0._wp 291 260 opning (ji,jj) = 0._wp 292 261 ELSE 293 262 iterate_ridging = 1 294 divu_adv (ji,jj) = ( kamax- asum(ji,jj) ) * r1_rdtice263 divu_adv (ji,jj) = ( 1._wp - asum(ji,jj) ) * r1_rdtice 295 264 closing_net(ji,jj) = MAX( 0._wp, -divu_adv(ji,jj) ) 296 265 opning (ji,jj) = MAX( 0._wp, divu_adv(ji,jj) ) … … 309 278 310 279 IF( iterate_ridging == 1 ) THEN 280 CALL lim_itd_me_ridgeprep 311 281 IF( niter > nitermax ) THEN 312 282 WRITE(numout,*) ' ALERTE : non-converging ridging scheme ' 313 283 WRITE(numout,*) ' niter, iterate_ridging ', niter, iterate_ridging 314 284 ENDIF 315 CALL lim_itd_me_ridgeprep316 285 ENDIF 317 286 318 287 END DO !! on the do while over iter 319 320 !-----------------------------------------------------------------------------!321 ! 4) Ridging diagnostics322 !-----------------------------------------------------------------------------!323 ! Convert ridging rate diagnostics to correct units.324 ! Update fresh water and heat fluxes due to snow melt.325 DO jj = 1, jpj326 DO ji = 1, jpi327 328 dardg1dt(ji,jj) = dardg1dt(ji,jj) * r1_rdtice329 dardg2dt(ji,jj) = dardg2dt(ji,jj) * r1_rdtice330 dvirdgdt(ji,jj) = dvirdgdt(ji,jj) * r1_rdtice331 opening (ji,jj) = opening (ji,jj) * r1_rdtice332 333 !-----------------------------------------------------------------------------!334 ! 5) Heat, salt and freshwater fluxes335 !-----------------------------------------------------------------------------!336 wfx_snw(ji,jj) = wfx_snw(ji,jj) + msnow_mlt(ji,jj) * r1_rdtice ! fresh water source for ocean337 hfx_dyn(ji,jj) = hfx_dyn(ji,jj) + esnow_mlt(ji,jj) * r1_rdtice ! heat sink for ocean (<0, W.m-2)338 339 END DO340 END DO341 342 ! Check if there is a ridging error343 IF( lwp ) THEN344 DO jj = 1, jpj345 DO ji = 1, jpi346 IF( ABS( asum(ji,jj) - kamax) > epsi10 ) THEN ! there is a bug347 WRITE(numout,*) ' '348 WRITE(numout,*) ' ALERTE : Ridging error: total area = ', asum(ji,jj)349 WRITE(numout,*) ' limitd_me '350 WRITE(numout,*) ' POINT : ', ji, jj351 WRITE(numout,*) ' jpl, a_i, athorn '352 WRITE(numout,*) 0, ato_i(ji,jj), athorn(ji,jj,0)353 DO jl = 1, jpl354 WRITE(numout,*) jl, a_i(ji,jj,jl), athorn(ji,jj,jl)355 END DO356 ENDIF357 END DO358 END DO359 END IF360 361 ! Conservation check362 IF ( con_i ) THEN363 CALL lim_column_sum (jpl, v_i, vt_i_final)364 fieldid = ' v_i : limitd_me '365 CALL lim_cons_check (vt_i_init, vt_i_final, 1.0e-6, fieldid)366 ENDIF367 288 368 289 CALL lim_var_agg( 1 ) … … 410 331 ENDIF ! ln_limdyn=.true. 411 332 ! 412 CALL wrk_dealloc( jpi, jpj, closing_net, divu_adv, opning, closing_gross , msnow_mlt, esnow_mlt, vt_i_init, vt_i_final)333 CALL wrk_dealloc( jpi, jpj, closing_net, divu_adv, opning, closing_gross ) 413 334 ! 414 335 IF( nn_timing == 1 ) CALL timing_stop('limitd_me') 415 336 END SUBROUTINE lim_itd_me 416 337 338 SUBROUTINE lim_itd_me_ridgeprep 339 !!---------------------------------------------------------------------! 340 !! *** ROUTINE lim_itd_me_ridgeprep *** 341 !! 342 !! ** Purpose : preparation for ridging and strength calculations 343 !! 344 !! ** Method : Compute the thickness distribution of the ice and open water 345 !! participating in ridging and of the resulting ridges. 346 !!---------------------------------------------------------------------! 347 INTEGER :: ji,jj, jl ! dummy loop indices 348 REAL(wp) :: Gstari, astari, hrmean, zdummy ! local scalar 349 REAL(wp), POINTER, DIMENSION(:,:,:) :: Gsum ! Gsum(n) = sum of areas in categories 0 to n 350 !------------------------------------------------------------------------------! 351 352 CALL wrk_alloc( jpi,jpj,jpl+2, Gsum, kkstart = -1 ) 353 354 Gstari = 1.0/rn_gstar 355 astari = 1.0/rn_astar 356 aksum(:,:) = 0.0 357 athorn(:,:,:) = 0.0 358 aridge(:,:,:) = 0.0 359 araft (:,:,:) = 0.0 360 361 ! Zero out categories with very small areas 362 CALL lim_var_zapsmall 363 364 ! Ice thickness needed for rafting 365 DO jl = 1, jpl 366 DO jj = 1, jpj 367 DO ji = 1, jpi 368 rswitch = MAX( 0._wp , SIGN( 1._wp, a_i(ji,jj,jl) - epsi20 ) ) 369 ht_i(ji,jj,jl) = v_i (ji,jj,jl) / MAX( a_i(ji,jj,jl) , epsi20 ) * rswitch 370 END DO 371 END DO 372 END DO 373 374 !------------------------------------------------------------------------------! 375 ! 1) Participation function 376 !------------------------------------------------------------------------------! 377 378 ! Compute total area of ice plus open water. 379 ! This is in general not equal to one because of divergence during transport 380 asum(:,:) = ato_i(:,:) + SUM( a_i, dim=3 ) 381 382 ! Compute cumulative thickness distribution function 383 ! Compute the cumulative thickness distribution function Gsum, 384 ! where Gsum(n) is the fractional area in categories 0 to n. 385 ! initial value (in h = 0) equals open water area 386 Gsum(:,:,-1) = 0._wp 387 Gsum(:,:,0 ) = ato_i(:,:) 388 ! for each value of h, you have to add ice concentration then 389 DO jl = 1, jpl 390 Gsum(:,:,jl) = Gsum(:,:,jl-1) + a_i(:,:,jl) 391 END DO 392 393 ! Normalize the cumulative distribution to 1 394 DO jl = 0, jpl 395 Gsum(:,:,jl) = Gsum(:,:,jl) / asum(:,:) 396 END DO 397 398 ! 1.3 Compute participation function a(h) = b(h).g(h) (athorn) 399 !-------------------------------------------------------------------------------------------------- 400 ! Compute the participation function athorn; this is analogous to 401 ! a(h) = b(h)g(h) as defined in Thorndike et al. (1975). 402 ! area lost from category n due to ridging/closing 403 ! athorn(n) = total area lost due to ridging/closing 404 ! assume b(h) = (2/Gstar) * (1 - G(h)/Gstar). 405 ! 406 ! The expressions for athorn are found by integrating b(h)g(h) between 407 ! the category boundaries. 408 ! athorn is always >= 0 and SUM(athorn(0:jpl))=1 409 !----------------------------------------------------------------- 410 411 IF( nn_partfun == 0 ) THEN !--- Linear formulation (Thorndike et al., 1975) 412 DO jl = 0, jpl 413 DO jj = 1, jpj 414 DO ji = 1, jpi 415 IF ( Gsum(ji,jj,jl) < rn_gstar ) THEN 416 athorn(ji,jj,jl) = Gstari * ( Gsum(ji,jj,jl) - Gsum(ji,jj,jl-1) ) * & 417 & ( 2._wp - ( Gsum(ji,jj,jl-1) + Gsum(ji,jj,jl) ) * Gstari ) 418 ELSEIF( Gsum(ji,jj,jl-1) < rn_gstar ) THEN 419 athorn(ji,jj,jl) = Gstari * ( rn_gstar - Gsum(ji,jj,jl-1) ) * & 420 & ( 2._wp - ( Gsum(ji,jj,jl-1) + rn_gstar ) * Gstari ) 421 ELSE 422 athorn(ji,jj,jl) = 0._wp 423 ENDIF 424 END DO 425 END DO 426 END DO 427 428 ELSE !--- Exponential, more stable formulation (Lipscomb et al, 2007) 429 ! 430 zdummy = 1._wp / ( 1._wp - EXP(-astari) ) ! precompute exponential terms using Gsum as a work array 431 DO jl = -1, jpl 432 Gsum(:,:,jl) = EXP( -Gsum(:,:,jl) * astari ) * zdummy 433 END DO 434 DO jl = 0, jpl 435 athorn(:,:,jl) = Gsum(:,:,jl-1) - Gsum(:,:,jl) 436 END DO 437 ! 438 ENDIF 439 440 IF( ln_rafting ) THEN ! Ridging and rafting ice participation functions 441 ! 442 DO jl = 1, jpl 443 DO jj = 1, jpj 444 DO ji = 1, jpi 445 zdummy = TANH ( rn_craft * ( ht_i(ji,jj,jl) - rn_hraft ) ) 446 aridge(ji,jj,jl) = ( 1._wp + zdummy ) * 0.5_wp * athorn(ji,jj,jl) 447 araft (ji,jj,jl) = ( 1._wp - zdummy ) * 0.5_wp * athorn(ji,jj,jl) 448 END DO 449 END DO 450 END DO 451 452 ELSE 453 ! 454 DO jl = 1, jpl 455 aridge(:,:,jl) = athorn(:,:,jl) 456 END DO 457 ! 458 ENDIF 459 460 !----------------------------------------------------------------- 461 ! 2) Transfer function 462 !----------------------------------------------------------------- 463 ! Compute max and min ridged ice thickness for each ridging category. 464 ! Assume ridged ice is uniformly distributed between hrmin and hrmax. 465 ! 466 ! This parameterization is a modified version of Hibler (1980). 467 ! The mean ridging thickness, hrmean, is proportional to hi^(0.5) 468 ! and for very thick ridging ice must be >= krdgmin*hi 469 ! 470 ! The minimum ridging thickness, hrmin, is equal to 2*hi 471 ! (i.e., rafting) and for very thick ridging ice is 472 ! constrained by hrmin <= (hrmean + hi)/2. 473 ! 474 ! The maximum ridging thickness, hrmax, is determined by 475 ! hrmean and hrmin. 476 ! 477 ! These modifications have the effect of reducing the ice strength 478 ! (relative to the Hibler formulation) when very thick ice is 479 ! ridging. 480 ! 481 ! aksum = net area removed/ total area removed 482 ! where total area removed = area of ice that ridges 483 ! net area removed = total area removed - area of new ridges 484 !----------------------------------------------------------------- 485 486 aksum(:,:) = athorn(:,:,0) 487 ! Transfer function 488 DO jl = 1, jpl !all categories have a specific transfer function 489 DO jj = 1, jpj 490 DO ji = 1, jpi 491 492 IF( athorn(ji,jj,jl) > 0._wp ) THEN 493 hrmean = MAX( SQRT( rn_hstar * ht_i(ji,jj,jl) ), ht_i(ji,jj,jl) * krdgmin ) 494 hrmin(ji,jj,jl) = MIN( 2._wp * ht_i(ji,jj,jl), 0.5_wp * ( hrmean + ht_i(ji,jj,jl) ) ) 495 hrmax(ji,jj,jl) = 2._wp * hrmean - hrmin(ji,jj,jl) 496 hraft(ji,jj,jl) = ht_i(ji,jj,jl) / kraft 497 krdg(ji,jj,jl) = ht_i(ji,jj,jl) / MAX( hrmean, epsi20 ) 498 499 ! Normalization factor : aksum, ensures mass conservation 500 aksum(ji,jj) = aksum(ji,jj) + aridge(ji,jj,jl) * ( 1._wp - krdg(ji,jj,jl) ) & 501 & + araft (ji,jj,jl) * ( 1._wp - kraft ) 502 503 ELSE 504 hrmin(ji,jj,jl) = 0._wp 505 hrmax(ji,jj,jl) = 0._wp 506 hraft(ji,jj,jl) = 0._wp 507 krdg (ji,jj,jl) = 1._wp 508 ENDIF 509 510 END DO 511 END DO 512 END DO 513 ! 514 CALL wrk_dealloc( jpi,jpj,jpl+2, Gsum, kkstart = -1 ) 515 ! 516 END SUBROUTINE lim_itd_me_ridgeprep 517 518 519 SUBROUTINE lim_itd_me_ridgeshift( opning, closing_gross ) 520 !!---------------------------------------------------------------------- 521 !! *** ROUTINE lim_itd_me_icestrength *** 522 !! 523 !! ** Purpose : shift ridging ice among thickness categories of ice thickness 524 !! 525 !! ** Method : Remove area, volume, and energy from each ridging category 526 !! and add to thicker ice categories. 527 !!---------------------------------------------------------------------- 528 REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: opning ! rate of opening due to divergence/shear 529 REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: closing_gross ! rate at which area removed, excluding area of new ridges 530 ! 531 CHARACTER (len=80) :: fieldid ! field identifier 532 ! 533 INTEGER :: ji, jj, jl, jl1, jl2, jk ! dummy loop indices 534 INTEGER :: ij ! horizontal index, combines i and j loops 535 INTEGER :: icells ! number of cells with a_i > puny 536 REAL(wp) :: hL, hR, farea ! left and right limits of integration 537 538 INTEGER , POINTER, DIMENSION(:) :: indxi, indxj ! compressed indices 539 REAL(wp), POINTER, DIMENSION(:) :: zswitch, fvol ! new ridge volume going to n2 540 541 REAL(wp), POINTER, DIMENSION(:) :: afrac ! fraction of category area ridged 542 REAL(wp), POINTER, DIMENSION(:) :: ardg1 , ardg2 ! area of ice ridged & new ridges 543 REAL(wp), POINTER, DIMENSION(:) :: vsrdg , esrdg ! snow volume & energy of ridging ice 544 REAL(wp), POINTER, DIMENSION(:) :: dhr , dhr2 ! hrmax - hrmin & hrmax^2 - hrmin^2 545 546 REAL(wp), POINTER, DIMENSION(:) :: vrdg1 ! volume of ice ridged 547 REAL(wp), POINTER, DIMENSION(:) :: vrdg2 ! volume of new ridges 548 REAL(wp), POINTER, DIMENSION(:) :: vsw ! volume of seawater trapped into ridges 549 REAL(wp), POINTER, DIMENSION(:) :: srdg1 ! sal*volume of ice ridged 550 REAL(wp), POINTER, DIMENSION(:) :: srdg2 ! sal*volume of new ridges 551 REAL(wp), POINTER, DIMENSION(:) :: smsw ! sal*volume of water trapped into ridges 552 REAL(wp), POINTER, DIMENSION(:) :: oirdg1, oirdg2 ! ice age of ice ridged 553 554 REAL(wp), POINTER, DIMENSION(:) :: afrft ! fraction of category area rafted 555 REAL(wp), POINTER, DIMENSION(:) :: arft1 , arft2 ! area of ice rafted and new rafted zone 556 REAL(wp), POINTER, DIMENSION(:) :: virft , vsrft ! ice & snow volume of rafting ice 557 REAL(wp), POINTER, DIMENSION(:) :: esrft , smrft ! snow energy & salinity of rafting ice 558 REAL(wp), POINTER, DIMENSION(:) :: oirft1, oirft2 ! ice age of ice rafted 559 560 REAL(wp), POINTER, DIMENSION(:,:) :: eirft ! ice energy of rafting ice 561 REAL(wp), POINTER, DIMENSION(:,:) :: erdg1 ! enth*volume of ice ridged 562 REAL(wp), POINTER, DIMENSION(:,:) :: erdg2 ! enth*volume of new ridges 563 REAL(wp), POINTER, DIMENSION(:,:) :: ersw ! enth of water trapped into ridges 564 !!---------------------------------------------------------------------- 565 566 CALL wrk_alloc( jpij, indxi, indxj ) 567 CALL wrk_alloc( jpij, zswitch, fvol ) 568 CALL wrk_alloc( jpij, afrac, ardg1, ardg2, vsrdg, esrdg, dhr, dhr2 ) 569 CALL wrk_alloc( jpij, vrdg1, vrdg2, vsw , srdg1, srdg2, smsw, oirdg1, oirdg2 ) 570 CALL wrk_alloc( jpij, afrft, arft1, arft2, virft, vsrft, esrft, smrft, oirft1, oirft2 ) 571 CALL wrk_alloc( jpij,nlay_i, eirft, erdg1, erdg2, ersw ) 572 573 !------------------------------------------------------------------------------- 574 ! 1) Compute change in open water area due to closing and opening. 575 !------------------------------------------------------------------------------- 576 DO jj = 1, jpj 577 DO ji = 1, jpi 578 ato_i(ji,jj) = MAX( 0._wp, ato_i(ji,jj) + & 579 & ( opning(ji,jj) - athorn(ji,jj,0) * closing_gross(ji,jj) ) * rdt_ice ) 580 END DO 581 END DO 582 583 !----------------------------------------------------------------- 584 ! 3) Pump everything from ice which is being ridged / rafted 585 !----------------------------------------------------------------- 586 ! Compute the area, volume, and energy of ice ridging in each 587 ! category, along with the area of the resulting ridge. 588 589 DO jl1 = 1, jpl !jl1 describes the ridging category 590 591 !------------------------------------------------ 592 ! 3.1) Identify grid cells with nonzero ridging 593 !------------------------------------------------ 594 icells = 0 595 DO jj = 1, jpj 596 DO ji = 1, jpi 597 IF( athorn(ji,jj,jl1) > 0._wp .AND. closing_gross(ji,jj) > 0._wp ) THEN 598 icells = icells + 1 599 indxi(icells) = ji 600 indxj(icells) = jj 601 ENDIF 602 END DO 603 END DO 604 605 DO ij = 1, icells 606 ji = indxi(ij) ; jj = indxj(ij) 607 608 !-------------------------------------------------------------------- 609 ! 3.2) Compute area of ridging ice (ardg1) and of new ridge (ardg2) 610 !-------------------------------------------------------------------- 611 ardg1(ij) = aridge(ji,jj,jl1) * closing_gross(ji,jj) * rdt_ice 612 arft1(ij) = araft (ji,jj,jl1) * closing_gross(ji,jj) * rdt_ice 613 614 !--------------------------------------------------------------- 615 ! 3.3) Compute ridging /rafting fractions, make sure afrac <=1 616 !--------------------------------------------------------------- 617 afrac(ij) = ardg1(ij) / a_i(ji,jj,jl1) !ridging 618 afrft(ij) = arft1(ij) / a_i(ji,jj,jl1) !rafting 619 ardg2(ij) = ardg1(ij) * krdg(ji,jj,jl1) 620 arft2(ij) = arft1(ij) * kraft 621 622 !-------------------------------------------------------------------------- 623 ! 3.4) Subtract area, volume, and energy from ridging 624 ! / rafting category n1. 625 !-------------------------------------------------------------------------- 626 vrdg1(ij) = v_i(ji,jj,jl1) * afrac(ij) 627 vrdg2(ij) = vrdg1(ij) * ( 1. + rn_por_rdg ) 628 vsw (ij) = vrdg1(ij) * rn_por_rdg 629 630 vsrdg (ij) = v_s (ji,jj, jl1) * afrac(ij) 631 esrdg (ij) = e_s (ji,jj,1,jl1) * afrac(ij) 632 srdg1 (ij) = smv_i(ji,jj, jl1) * afrac(ij) 633 oirdg1(ij) = oa_i (ji,jj, jl1) * afrac(ij) 634 oirdg2(ij) = oa_i (ji,jj, jl1) * afrac(ij) * krdg(ji,jj,jl1) 635 636 ! rafting volumes, heat contents ... 637 virft (ij) = v_i (ji,jj, jl1) * afrft(ij) 638 vsrft (ij) = v_s (ji,jj, jl1) * afrft(ij) 639 esrft (ij) = e_s (ji,jj,1,jl1) * afrft(ij) 640 smrft (ij) = smv_i(ji,jj, jl1) * afrft(ij) 641 oirft1(ij) = oa_i (ji,jj, jl1) * afrft(ij) 642 oirft2(ij) = oa_i (ji,jj, jl1) * afrft(ij) * kraft 643 644 !----------------------------------------------------------------- 645 ! 3.5) Compute properties of new ridges 646 !----------------------------------------------------------------- 647 smsw(ij) = vsw(ij) * sss_m(ji,jj) ! salt content of seawater frozen in voids 648 srdg2(ij) = srdg1(ij) + smsw(ij) ! salt content of new ridge 649 650 sfx_dyn(ji,jj) = sfx_dyn(ji,jj) - smsw(ij) * rhoic * r1_rdtice 651 wfx_dyn(ji,jj) = wfx_dyn(ji,jj) - vsw (ij) * rhoic * r1_rdtice ! increase in ice volume due to seawater frozen in voids 652 653 ! virtual salt flux to keep salinity constant 654 IF( nn_icesal == 1 .OR. nn_icesal == 3 ) THEN 655 srdg2(ij) = srdg2(ij) - vsw(ij) * ( sss_m(ji,jj) - sm_i(ji,jj,jl1) ) ! ridge salinity = sm_i 656 sfx_bri(ji,jj) = sfx_bri(ji,jj) + sss_m(ji,jj) * vsw(ij) * rhoic * r1_rdtice & ! put back sss_m into the ocean 657 & - sm_i(ji,jj,jl1) * vsw(ij) * rhoic * r1_rdtice ! and get sm_i from the ocean 658 ENDIF 659 660 !------------------------------------------ 661 ! 3.7 Put the snow somewhere in the ocean 662 !------------------------------------------ 663 ! Place part of the snow lost by ridging into the ocean. 664 ! Note that esrdg > 0; the ocean must cool to melt snow. 665 ! If the ocean temp = Tf already, new ice must grow. 666 ! During the next time step, thermo_rates will determine whether 667 ! the ocean cools or new ice grows. 668 wfx_snw(ji,jj) = wfx_snw(ji,jj) + ( rhosn * vsrdg(ij) * ( 1._wp - rn_fsnowrdg ) & 669 & + rhosn * vsrft(ij) * ( 1._wp - rn_fsnowrft ) ) * r1_rdtice ! fresh water source for ocean 670 671 hfx_dyn(ji,jj) = hfx_dyn(ji,jj) + ( - esrdg(ij) * ( 1._wp - rn_fsnowrdg ) & 672 & - esrft(ij) * ( 1._wp - rn_fsnowrft ) ) * r1_rdtice ! heat sink for ocean (<0, W.m-2) 673 674 !----------------------------------------------------------------- 675 ! 3.8 Compute quantities used to apportion ice among categories 676 ! in the n2 loop below 677 !----------------------------------------------------------------- 678 dhr (ij) = 1._wp / ( hrmax(ji,jj,jl1) - hrmin(ji,jj,jl1) ) 679 dhr2(ij) = 1._wp / ( hrmax(ji,jj,jl1) * hrmax(ji,jj,jl1) - hrmin(ji,jj,jl1) * hrmin(ji,jj,jl1) ) 680 681 682 ! update jl1 (removing ridged/rafted area) 683 a_i (ji,jj, jl1) = a_i (ji,jj, jl1) - ardg1 (ij) - arft1 (ij) 684 v_i (ji,jj, jl1) = v_i (ji,jj, jl1) - vrdg1 (ij) - virft (ij) 685 v_s (ji,jj, jl1) = v_s (ji,jj, jl1) - vsrdg (ij) - vsrft (ij) 686 e_s (ji,jj,1,jl1) = e_s (ji,jj,1,jl1) - esrdg (ij) - esrft (ij) 687 smv_i(ji,jj, jl1) = smv_i(ji,jj, jl1) - srdg1 (ij) - smrft (ij) 688 oa_i (ji,jj, jl1) = oa_i (ji,jj, jl1) - oirdg1(ij) - oirft1(ij) 689 690 END DO 691 692 !-------------------------------------------------------------------- 693 ! 3.9 Compute ridging ice enthalpy, remove it from ridging ice and 694 ! compute ridged ice enthalpy 695 !-------------------------------------------------------------------- 696 DO jk = 1, nlay_i 697 DO ij = 1, icells 698 ji = indxi(ij) ; jj = indxj(ij) 699 ! heat content of ridged ice 700 erdg1(ij,jk) = e_i(ji,jj,jk,jl1) * afrac(ij) 701 eirft(ij,jk) = e_i(ji,jj,jk,jl1) * afrft(ij) 702 703 ! enthalpy of the trapped seawater (J/m2, >0) 704 ! clem: if sst>0, then ersw <0 (is that possible?) 705 ersw(ij,jk) = - rhoic * vsw(ij) * rcp * sst_m(ji,jj) * r1_nlay_i 706 707 ! heat flux to the ocean 708 hfx_dyn(ji,jj) = hfx_dyn(ji,jj) + ersw(ij,jk) * r1_rdtice ! > 0 [W.m-2] ocean->ice flux 709 710 ! it is added to sea ice because the sign convention is the opposite of the sign convention for the ocean 711 erdg2(ij,jk) = erdg1(ij,jk) + ersw(ij,jk) 712 713 ! update jl1 714 e_i (ji,jj,jk,jl1) = e_i(ji,jj,jk,jl1) - erdg1(ij,jk) - eirft(ij,jk) 715 716 END DO 717 END DO 718 719 !------------------------------------------------------------------------------- 720 ! 4) Add area, volume, and energy of new ridge to each category jl2 721 !------------------------------------------------------------------------------- 722 DO jl2 = 1, jpl 723 ! over categories to which ridged/rafted ice is transferred 724 DO ij = 1, icells 725 ji = indxi(ij) ; jj = indxj(ij) 726 727 ! Compute the fraction of ridged ice area and volume going to thickness category jl2. 728 IF( hrmin(ji,jj,jl1) <= hi_max(jl2) .AND. hrmax(ji,jj,jl1) > hi_max(jl2-1) ) THEN 729 hL = MAX( hrmin(ji,jj,jl1), hi_max(jl2-1) ) 730 hR = MIN( hrmax(ji,jj,jl1), hi_max(jl2) ) 731 farea = ( hR - hL ) * dhr(ij) 732 fvol(ij) = ( hR * hR - hL * hL ) * dhr2(ij) 733 ELSE 734 farea = 0._wp 735 fvol(ij) = 0._wp 736 ENDIF 737 738 ! Compute the fraction of rafted ice area and volume going to thickness category jl2 739 IF( hraft(ji,jj,jl1) <= hi_max(jl2) .AND. hraft(ji,jj,jl1) > hi_max(jl2-1) ) THEN 740 zswitch(ij) = 1._wp 741 ELSE 742 zswitch(ij) = 0._wp 743 ENDIF 744 745 a_i (ji,jj ,jl2) = a_i (ji,jj ,jl2) + ( ardg2 (ij) * farea + arft2 (ij) * zswitch(ij) ) 746 oa_i (ji,jj ,jl2) = oa_i (ji,jj ,jl2) + ( oirdg2(ij) * farea + oirft2(ij) * zswitch(ij) ) 747 v_i (ji,jj ,jl2) = v_i (ji,jj ,jl2) + ( vrdg2 (ij) * fvol(ij) + virft (ij) * zswitch(ij) ) 748 smv_i(ji,jj ,jl2) = smv_i(ji,jj ,jl2) + ( srdg2 (ij) * fvol(ij) + smrft (ij) * zswitch(ij) ) 749 v_s (ji,jj ,jl2) = v_s (ji,jj ,jl2) + ( vsrdg (ij) * rn_fsnowrdg * fvol(ij) + & 750 & vsrft (ij) * rn_fsnowrft * zswitch(ij) ) 751 e_s (ji,jj,1,jl2) = e_s (ji,jj,1,jl2) + ( esrdg (ij) * rn_fsnowrdg * fvol(ij) + & 752 & esrft (ij) * rn_fsnowrft * zswitch(ij) ) 753 754 END DO 755 756 ! Transfer ice energy to category jl2 by ridging 757 DO jk = 1, nlay_i 758 DO ij = 1, icells 759 ji = indxi(ij) ; jj = indxj(ij) 760 e_i(ji,jj,jk,jl2) = e_i(ji,jj,jk,jl2) + erdg2(ij,jk) * fvol(ij) + eirft(ij,jk) * zswitch(ij) 761 END DO 762 END DO 763 ! 764 END DO ! jl2 765 766 END DO ! jl1 (deforming categories) 767 768 ! 769 CALL wrk_dealloc( jpij, indxi, indxj ) 770 CALL wrk_dealloc( jpij, zswitch, fvol ) 771 CALL wrk_dealloc( jpij, afrac, ardg1, ardg2, vsrdg, esrdg, dhr, dhr2 ) 772 CALL wrk_dealloc( jpij, vrdg1, vrdg2, vsw , srdg1, srdg2, smsw, oirdg1, oirdg2 ) 773 CALL wrk_dealloc( jpij, afrft, arft1, arft2, virft, vsrft, esrft, smrft, oirft1, oirft2 ) 774 CALL wrk_dealloc( jpij,nlay_i, eirft, erdg1, erdg2, ersw ) 775 ! 776 END SUBROUTINE lim_itd_me_ridgeshift 417 777 418 778 SUBROUTINE lim_itd_me_icestrength( kstrngth ) … … 434 794 INTEGER :: ksmooth ! smoothing the resistance to deformation 435 795 INTEGER :: numts_rm ! number of time steps for the P smoothing 436 REAL(wp) :: z hi, zp, z1_3! local scalars796 REAL(wp) :: zp, z1_3 ! local scalars 437 797 REAL(wp), POINTER, DIMENSION(:,:) :: zworka ! temporary array used here 438 798 !!---------------------------------------------------------------------- … … 459 819 DO ji = 1, jpi 460 820 ! 461 IF( a_i(ji,jj,jl) > epsi10 .AND. athorn(ji,jj,jl) > 0._wp ) THEN 462 zhi = v_i(ji,jj,jl) / a_i(ji,jj,jl) 821 IF( athorn(ji,jj,jl) > 0._wp ) THEN 463 822 !---------------------------- 464 823 ! PE loss from deforming ice 465 824 !---------------------------- 466 strength(ji,jj) = strength(ji,jj) - athorn(ji,jj,jl) * zhi * zhi825 strength(ji,jj) = strength(ji,jj) - athorn(ji,jj,jl) * ht_i(ji,jj,jl) * ht_i(ji,jj,jl) 467 826 468 827 !-------------------------- 469 828 ! PE gain from rafting ice 470 829 !-------------------------- 471 strength(ji,jj) = strength(ji,jj) + 2._wp * araft(ji,jj,jl) * zhi * zhi830 strength(ji,jj) = strength(ji,jj) + 2._wp * araft(ji,jj,jl) * ht_i(ji,jj,jl) * ht_i(ji,jj,jl) 472 831 473 832 !---------------------------- 474 833 ! PE gain from ridging ice 475 834 !---------------------------- 476 strength(ji,jj) = strength(ji,jj) + aridge(ji,jj,jl) / krdg(ji,jj,jl) & 477 * z1_3 * ( hrmax(ji,jj,jl)**2 + hrmin(ji,jj,jl)**2 + hrmax(ji,jj,jl) * hrmin(ji,jj,jl) ) 835 strength(ji,jj) = strength(ji,jj) + aridge(ji,jj,jl) * krdg(ji,jj,jl) * z1_3 * & 836 & ( hrmax(ji,jj,jl) * hrmax(ji,jj,jl) + & 837 & hrmin(ji,jj,jl) * hrmin(ji,jj,jl) + & 838 & hrmax(ji,jj,jl) * hrmin(ji,jj,jl) ) 478 839 !!(a**3-b**3)/(a-b) = a*a+ab+b*b 479 840 ENDIF … … 497 858 ! 498 859 ENDIF ! kstrngth 499 500 860 ! 501 861 !------------------------------------------------------------------------------! … … 503 863 !------------------------------------------------------------------------------! 504 864 ! CAN BE REMOVED 505 !506 865 IF( ln_icestr_bvf ) THEN 507 508 866 DO jj = 1, jpj 509 867 DO ji = 1, jpi … … 511 869 END DO 512 870 END DO 513 514 871 ENDIF 515 516 872 ! 517 873 !------------------------------------------------------------------------------! … … 558 914 IF ( ksmooth == 2 ) THEN 559 915 560 561 916 CALL lbc_lnk( strength, 'T', 1. ) 562 917 … … 565 920 IF ( ( asum(ji,jj) - ato_i(ji,jj) ) > 0._wp) THEN 566 921 numts_rm = 1 ! number of time steps for the running mean 567 IF ( strp1(ji,jj) > 0. 0) numts_rm = numts_rm + 1568 IF ( strp2(ji,jj) > 0. 0) numts_rm = numts_rm + 1922 IF ( strp1(ji,jj) > 0._wp ) numts_rm = numts_rm + 1 923 IF ( strp2(ji,jj) > 0._wp ) numts_rm = numts_rm + 1 569 924 zp = ( strength(ji,jj) + strp1(ji,jj) + strp2(ji,jj) ) / numts_rm 570 925 strp2(ji,jj) = strp1(ji,jj) … … 583 938 ! 584 939 END SUBROUTINE lim_itd_me_icestrength 585 586 587 SUBROUTINE lim_itd_me_ridgeprep588 !!---------------------------------------------------------------------!589 !! *** ROUTINE lim_itd_me_ridgeprep ***590 !!591 !! ** Purpose : preparation for ridging and strength calculations592 !!593 !! ** Method : Compute the thickness distribution of the ice and open water594 !! participating in ridging and of the resulting ridges.595 !!---------------------------------------------------------------------!596 INTEGER :: ji,jj, jl ! dummy loop indices597 REAL(wp) :: Gstari, astari, zhi, hrmean, zdummy ! local scalar598 REAL(wp), POINTER, DIMENSION(:,:) :: zworka ! temporary array used here599 REAL(wp), POINTER, DIMENSION(:,:,:) :: Gsum ! Gsum(n) = sum of areas in categories 0 to n600 !------------------------------------------------------------------------------!601 602 CALL wrk_alloc( jpi,jpj, zworka )603 CALL wrk_alloc( jpi,jpj,jpl+2, Gsum, kkstart = -1 )604 605 Gstari = 1.0/rn_gstar606 astari = 1.0/rn_astar607 aksum(:,:) = 0.0608 athorn(:,:,:) = 0.0609 aridge(:,:,:) = 0.0610 araft (:,:,:) = 0.0611 hrmin(:,:,:) = 0.0612 hrmax(:,:,:) = 0.0613 hraft(:,:,:) = 0.0614 krdg (:,:,:) = 1.0615 616 ! ! Zero out categories with very small areas617 CALL lim_var_zapsmall618 619 !------------------------------------------------------------------------------!620 ! 1) Participation function621 !------------------------------------------------------------------------------!622 623 ! Compute total area of ice plus open water.624 ! This is in general not equal to one because of divergence during transport625 asum(:,:) = ato_i(:,:)626 DO jl = 1, jpl627 asum(:,:) = asum(:,:) + a_i(:,:,jl)628 END DO629 630 ! Compute cumulative thickness distribution function631 ! Compute the cumulative thickness distribution function Gsum,632 ! where Gsum(n) is the fractional area in categories 0 to n.633 ! initial value (in h = 0) equals open water area634 635 Gsum(:,:,-1) = 0._wp636 Gsum(:,:,0 ) = ato_i(:,:)637 638 ! for each value of h, you have to add ice concentration then639 DO jl = 1, jpl640 Gsum(:,:,jl) = Gsum(:,:,jl-1) + a_i(:,:,jl)641 END DO642 643 ! Normalize the cumulative distribution to 1644 zworka(:,:) = 1._wp / Gsum(:,:,jpl)645 DO jl = 0, jpl646 Gsum(:,:,jl) = Gsum(:,:,jl) * zworka(:,:)647 END DO648 649 ! 1.3 Compute participation function a(h) = b(h).g(h) (athorn)650 !--------------------------------------------------------------------------------------------------651 ! Compute the participation function athorn; this is analogous to652 ! a(h) = b(h)g(h) as defined in Thorndike et al. (1975).653 ! area lost from category n due to ridging/closing654 ! athorn(n) = total area lost due to ridging/closing655 ! assume b(h) = (2/Gstar) * (1 - G(h)/Gstar).656 !657 ! The expressions for athorn are found by integrating b(h)g(h) between658 ! the category boundaries.659 !-----------------------------------------------------------------660 661 IF( nn_partfun == 0 ) THEN !--- Linear formulation (Thorndike et al., 1975)662 DO jl = 0, jpl663 DO jj = 1, jpj664 DO ji = 1, jpi665 IF( Gsum(ji,jj,jl) < rn_gstar) THEN666 athorn(ji,jj,jl) = Gstari * ( Gsum(ji,jj,jl) - Gsum(ji,jj,jl-1) ) * &667 & ( 2.0 - (Gsum(ji,jj,jl-1) + Gsum(ji,jj,jl) ) * Gstari )668 ELSEIF (Gsum(ji,jj,jl-1) < rn_gstar) THEN669 athorn(ji,jj,jl) = Gstari * ( rn_gstar - Gsum(ji,jj,jl-1) ) * &670 & ( 2.0 - ( Gsum(ji,jj,jl-1) + rn_gstar ) * Gstari )671 ELSE672 athorn(ji,jj,jl) = 0.0673 ENDIF674 END DO675 END DO676 END DO677 678 ELSE !--- Exponential, more stable formulation (Lipscomb et al, 2007)679 !680 zdummy = 1._wp / ( 1._wp - EXP(-astari) ) ! precompute exponential terms using Gsum as a work array681 DO jl = -1, jpl682 Gsum(:,:,jl) = EXP( -Gsum(:,:,jl) * astari ) * zdummy683 END DO684 DO jl = 0, jpl685 athorn(:,:,jl) = Gsum(:,:,jl-1) - Gsum(:,:,jl)686 END DO687 !688 ENDIF689 690 IF( ln_rafting ) THEN ! Ridging and rafting ice participation functions691 !692 DO jl = 1, jpl693 DO jj = 1, jpj694 DO ji = 1, jpi695 IF ( athorn(ji,jj,jl) > 0._wp ) THEN696 !!gm TANH( -X ) = - TANH( X ) so can be computed only 1 time....697 aridge(ji,jj,jl) = ( TANH ( rn_craft * ( ht_i(ji,jj,jl) - rn_hraft ) ) + 1.0 ) * 0.5 * athorn(ji,jj,jl)698 araft (ji,jj,jl) = ( TANH ( -rn_craft * ( ht_i(ji,jj,jl) - rn_hraft ) ) + 1.0 ) * 0.5 * athorn(ji,jj,jl)699 IF ( araft(ji,jj,jl) < epsi06 ) araft(ji,jj,jl) = 0._wp700 aridge(ji,jj,jl) = MAX( athorn(ji,jj,jl) - araft(ji,jj,jl), 0.0 )701 ENDIF702 END DO703 END DO704 END DO705 706 ELSE707 !708 DO jl = 1, jpl709 aridge(:,:,jl) = athorn(:,:,jl)710 END DO711 !712 ENDIF713 714 IF( ln_rafting ) THEN715 716 IF( MAXVAL(aridge + araft - athorn(:,:,1:jpl)) > epsi10 .AND. lwp ) THEN717 DO jl = 1, jpl718 DO jj = 1, jpj719 DO ji = 1, jpi720 IF ( aridge(ji,jj,jl) + araft(ji,jj,jl) - athorn(ji,jj,jl) > epsi10 ) THEN721 WRITE(numout,*) ' ALERTE 96 : wrong participation function ... '722 WRITE(numout,*) ' ji, jj, jl : ', ji, jj, jl723 WRITE(numout,*) ' lat, lon : ', gphit(ji,jj), glamt(ji,jj)724 WRITE(numout,*) ' aridge : ', aridge(ji,jj,1:jpl)725 WRITE(numout,*) ' araft : ', araft(ji,jj,1:jpl)726 WRITE(numout,*) ' athorn : ', athorn(ji,jj,1:jpl)727 ENDIF728 END DO729 END DO730 END DO731 ENDIF732 733 ENDIF734 735 !-----------------------------------------------------------------736 ! 2) Transfer function737 !-----------------------------------------------------------------738 ! Compute max and min ridged ice thickness for each ridging category.739 ! Assume ridged ice is uniformly distributed between hrmin and hrmax.740 !741 ! This parameterization is a modified version of Hibler (1980).742 ! The mean ridging thickness, hrmean, is proportional to hi^(0.5)743 ! and for very thick ridging ice must be >= krdgmin*hi744 !745 ! The minimum ridging thickness, hrmin, is equal to 2*hi746 ! (i.e., rafting) and for very thick ridging ice is747 ! constrained by hrmin <= (hrmean + hi)/2.748 !749 ! The maximum ridging thickness, hrmax, is determined by750 ! hrmean and hrmin.751 !752 ! These modifications have the effect of reducing the ice strength753 ! (relative to the Hibler formulation) when very thick ice is754 ! ridging.755 !756 ! aksum = net area removed/ total area removed757 ! where total area removed = area of ice that ridges758 ! net area removed = total area removed - area of new ridges759 !-----------------------------------------------------------------760 761 ! Transfer function762 DO jl = 1, jpl !all categories have a specific transfer function763 DO jj = 1, jpj764 DO ji = 1, jpi765 766 IF (a_i(ji,jj,jl) > epsi10 .AND. athorn(ji,jj,jl) > 0.0 ) THEN767 zhi = v_i(ji,jj,jl) / a_i(ji,jj,jl)768 hrmean = MAX(SQRT(rn_hstar*zhi), zhi*krdgmin)769 hrmin(ji,jj,jl) = MIN(2.0*zhi, 0.5*(hrmean + zhi))770 hrmax(ji,jj,jl) = 2.0*hrmean - hrmin(ji,jj,jl)771 hraft(ji,jj,jl) = kraft*zhi772 krdg(ji,jj,jl) = hrmean / zhi773 ELSE774 hraft(ji,jj,jl) = 0.0775 hrmin(ji,jj,jl) = 0.0776 hrmax(ji,jj,jl) = 0.0777 krdg (ji,jj,jl) = 1.0778 ENDIF779 780 END DO781 END DO782 END DO783 784 ! Normalization factor : aksum, ensures mass conservation785 aksum(:,:) = athorn(:,:,0)786 DO jl = 1, jpl787 aksum(:,:) = aksum(:,:) + aridge(:,:,jl) * ( 1._wp - 1._wp / krdg(:,:,jl) ) &788 & + araft (:,:,jl) * ( 1._wp - 1._wp / kraft )789 END DO790 !791 CALL wrk_dealloc( jpi,jpj, zworka )792 CALL wrk_dealloc( jpi,jpj,jpl+2, Gsum, kkstart = -1 )793 !794 END SUBROUTINE lim_itd_me_ridgeprep795 796 797 SUBROUTINE lim_itd_me_ridgeshift( opning, closing_gross, msnow_mlt, esnow_mlt )798 !!----------------------------------------------------------------------799 !! *** ROUTINE lim_itd_me_icestrength ***800 !!801 !! ** Purpose : shift ridging ice among thickness categories of ice thickness802 !!803 !! ** Method : Remove area, volume, and energy from each ridging category804 !! and add to thicker ice categories.805 !!----------------------------------------------------------------------806 REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: opning ! rate of opening due to divergence/shear807 REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: closing_gross ! rate at which area removed, excluding area of new ridges808 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: msnow_mlt ! mass of snow added to ocean (kg m-2)809 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: esnow_mlt ! energy needed to melt snow in ocean (J m-2)810 !811 CHARACTER (len=80) :: fieldid ! field identifier812 LOGICAL, PARAMETER :: l_conservation_check = .true. ! if true, check conservation (useful for debugging)813 !814 INTEGER :: ji, jj, jl, jl1, jl2, jk ! dummy loop indices815 INTEGER :: ij ! horizontal index, combines i and j loops816 INTEGER :: icells ! number of cells with aicen > puny817 REAL(wp) :: hL, hR, farea, ztmelts ! left and right limits of integration818 819 INTEGER , POINTER, DIMENSION(:) :: indxi, indxj ! compressed indices820 821 REAL(wp), POINTER, DIMENSION(:,:) :: vice_init, vice_final ! ice volume summed over categories822 REAL(wp), POINTER, DIMENSION(:,:) :: eice_init, eice_final ! ice energy summed over layers823 824 REAL(wp), POINTER, DIMENSION(:,:,:) :: aicen_init, vicen_init ! ice area & volume before ridging825 REAL(wp), POINTER, DIMENSION(:,:,:) :: vsnwn_init, esnwn_init ! snow volume & energy before ridging826 REAL(wp), POINTER, DIMENSION(:,:,:) :: smv_i_init, oa_i_init ! ice salinity & age before ridging827 828 REAL(wp), POINTER, DIMENSION(:,:,:,:) :: eicen_init ! ice energy before ridging829 830 REAL(wp), POINTER, DIMENSION(:,:) :: afrac , fvol ! fraction of category area ridged & new ridge volume going to n2831 REAL(wp), POINTER, DIMENSION(:,:) :: ardg1 , ardg2 ! area of ice ridged & new ridges832 REAL(wp), POINTER, DIMENSION(:,:) :: vsrdg , esrdg ! snow volume & energy of ridging ice833 REAL(wp), POINTER, DIMENSION(:,:) :: dhr , dhr2 ! hrmax - hrmin & hrmax^2 - hrmin^2834 835 REAL(wp), POINTER, DIMENSION(:,:) :: vrdg1 ! volume of ice ridged836 REAL(wp), POINTER, DIMENSION(:,:) :: vrdg2 ! volume of new ridges837 REAL(wp), POINTER, DIMENSION(:,:) :: vsw ! volume of seawater trapped into ridges838 REAL(wp), POINTER, DIMENSION(:,:) :: srdg1 ! sal*volume of ice ridged839 REAL(wp), POINTER, DIMENSION(:,:) :: srdg2 ! sal*volume of new ridges840 REAL(wp), POINTER, DIMENSION(:,:) :: smsw ! sal*volume of water trapped into ridges841 REAL(wp), POINTER, DIMENSION(:,:) :: oirdg1, oirdg2 ! ice age of ice ridged842 843 REAL(wp), POINTER, DIMENSION(:,:) :: afrft ! fraction of category area rafted844 REAL(wp), POINTER, DIMENSION(:,:) :: arft1 , arft2 ! area of ice rafted and new rafted zone845 REAL(wp), POINTER, DIMENSION(:,:) :: virft , vsrft ! ice & snow volume of rafting ice846 REAL(wp), POINTER, DIMENSION(:,:) :: esrft , smrft ! snow energy & salinity of rafting ice847 REAL(wp), POINTER, DIMENSION(:,:) :: oirft1, oirft2 ! ice age of ice rafted848 849 REAL(wp), POINTER, DIMENSION(:,:,:) :: eirft ! ice energy of rafting ice850 REAL(wp), POINTER, DIMENSION(:,:,:) :: erdg1 ! enth*volume of ice ridged851 REAL(wp), POINTER, DIMENSION(:,:,:) :: erdg2 ! enth*volume of new ridges852 REAL(wp), POINTER, DIMENSION(:,:,:) :: ersw ! enth of water trapped into ridges853 !!----------------------------------------------------------------------854 855 CALL wrk_alloc( (jpi+1)*(jpj+1), indxi, indxj )856 CALL wrk_alloc( jpi, jpj, vice_init, vice_final, eice_init, eice_final )857 CALL wrk_alloc( jpi, jpj, afrac, fvol , ardg1, ardg2, vsrdg, esrdg, dhr, dhr2 )858 CALL wrk_alloc( jpi, jpj, vrdg1, vrdg2, vsw , srdg1, srdg2, smsw, oirdg1, oirdg2 )859 CALL wrk_alloc( jpi, jpj, afrft, arft1, arft2, virft, vsrft, esrft, smrft, oirft1, oirft2 )860 CALL wrk_alloc( jpi, jpj, jpl, aicen_init, vicen_init, vsnwn_init, esnwn_init, smv_i_init, oa_i_init )861 CALL wrk_alloc( jpi, jpj, nlay_i, eirft, erdg1, erdg2, ersw )862 CALL wrk_alloc( jpi, jpj, nlay_i, jpl, eicen_init )863 864 ! Conservation check865 eice_init(:,:) = 0._wp866 867 IF( con_i ) THEN868 CALL lim_column_sum (jpl, v_i, vice_init )869 CALL lim_column_sum_energy (jpl, nlay_i, e_i, eice_init )870 DO ji = mi0(iiceprt), mi1(iiceprt)871 DO jj = mj0(jiceprt), mj1(jiceprt)872 WRITE(numout,*) ' vice_init : ', vice_init(ji,jj)873 WRITE(numout,*) ' eice_init : ', eice_init(ji,jj)874 END DO875 END DO876 ENDIF877 878 !-------------------------------------------------------------------------------879 ! 1) Compute change in open water area due to closing and opening.880 !-------------------------------------------------------------------------------881 DO jj = 1, jpj882 DO ji = 1, jpi883 ato_i(ji,jj) = ato_i(ji,jj) - athorn(ji,jj,0) * closing_gross(ji,jj) * rdt_ice &884 & + opning(ji,jj) * rdt_ice885 IF ( ato_i(ji,jj) < -epsi10 ) THEN ! there is a bug886 IF(lwp) WRITE(numout,*) 'Ridging error: ato_i < 0 -- ato_i : ',ato_i(ji,jj)887 ELSEIF( ato_i(ji,jj) < 0._wp ) THEN ! roundoff error888 ato_i(ji,jj) = 0._wp889 ENDIF890 END DO891 END DO892 893 !-----------------------------------------------------------------894 ! 2) Save initial state variables895 !-----------------------------------------------------------------896 aicen_init(:,:,:) = a_i (:,:,:)897 vicen_init(:,:,:) = v_i (:,:,:)898 vsnwn_init(:,:,:) = v_s (:,:,:)899 smv_i_init(:,:,:) = smv_i(:,:,:)900 esnwn_init(:,:,:) = e_s (:,:,1,:)901 eicen_init(:,:,:,:) = e_i (:,:,:,:)902 oa_i_init (:,:,:) = oa_i (:,:,:)903 904 !905 !-----------------------------------------------------------------906 ! 3) Pump everything from ice which is being ridged / rafted907 !-----------------------------------------------------------------908 ! Compute the area, volume, and energy of ice ridging in each909 ! category, along with the area of the resulting ridge.910 911 DO jl1 = 1, jpl !jl1 describes the ridging category912 913 !------------------------------------------------914 ! 3.1) Identify grid cells with nonzero ridging915 !------------------------------------------------916 917 icells = 0918 DO jj = 1, jpj919 DO ji = 1, jpi920 IF( aicen_init(ji,jj,jl1) > epsi10 .AND. athorn(ji,jj,jl1) > 0._wp &921 & .AND. closing_gross(ji,jj) > 0._wp ) THEN922 icells = icells + 1923 indxi(icells) = ji924 indxj(icells) = jj925 ENDIF926 END DO927 END DO928 929 DO ij = 1, icells930 ji = indxi(ij)931 jj = indxj(ij)932 933 !--------------------------------------------------------------------934 ! 3.2) Compute area of ridging ice (ardg1) and of new ridge (ardg2)935 !--------------------------------------------------------------------936 937 ardg1(ji,jj) = aridge(ji,jj,jl1)*closing_gross(ji,jj)*rdt_ice938 arft1(ji,jj) = araft (ji,jj,jl1)*closing_gross(ji,jj)*rdt_ice939 ardg2(ji,jj) = ardg1(ji,jj) / krdg(ji,jj,jl1)940 arft2(ji,jj) = arft1(ji,jj) / kraft941 942 !---------------------------------------------------------------943 ! 3.3) Compute ridging /rafting fractions, make sure afrac <=1944 !---------------------------------------------------------------945 946 afrac(ji,jj) = ardg1(ji,jj) / aicen_init(ji,jj,jl1) !ridging947 afrft(ji,jj) = arft1(ji,jj) / aicen_init(ji,jj,jl1) !rafting948 949 IF( afrac(ji,jj) > kamax + epsi10 ) THEN ! there is a bug950 IF(lwp) WRITE(numout,*) ' ardg > a_i -- ardg, aicen_init : ', ardg1(ji,jj), aicen_init(ji,jj,jl1)951 ELSEIF( afrac(ji,jj) > kamax ) THEN ! roundoff error952 afrac(ji,jj) = kamax953 ENDIF954 955 IF( afrft(ji,jj) > kamax + epsi10 ) THEN ! there is a bug956 IF(lwp) WRITE(numout,*) ' arft > a_i -- arft, aicen_init : ', arft1(ji,jj), aicen_init(ji,jj,jl1)957 ELSEIF( afrft(ji,jj) > kamax) THEN ! roundoff error958 afrft(ji,jj) = kamax959 ENDIF960 961 !--------------------------------------------------------------------------962 ! 3.4) Subtract area, volume, and energy from ridging963 ! / rafting category n1.964 !--------------------------------------------------------------------------965 vrdg1(ji,jj) = vicen_init(ji,jj,jl1) * afrac(ji,jj)966 vrdg2(ji,jj) = vrdg1(ji,jj) * ( 1. + rn_por_rdg )967 vsw (ji,jj) = vrdg1(ji,jj) * rn_por_rdg968 969 vsrdg (ji,jj) = vsnwn_init(ji,jj,jl1) * afrac(ji,jj)970 esrdg (ji,jj) = esnwn_init(ji,jj,jl1) * afrac(ji,jj)971 srdg1 (ji,jj) = smv_i_init(ji,jj,jl1) * afrac(ji,jj)972 oirdg1(ji,jj) = oa_i_init (ji,jj,jl1) * afrac(ji,jj)973 oirdg2(ji,jj) = oa_i_init (ji,jj,jl1) * afrac(ji,jj) / krdg(ji,jj,jl1)974 975 ! rafting volumes, heat contents ...976 virft (ji,jj) = vicen_init(ji,jj,jl1) * afrft(ji,jj)977 vsrft (ji,jj) = vsnwn_init(ji,jj,jl1) * afrft(ji,jj)978 esrft (ji,jj) = esnwn_init(ji,jj,jl1) * afrft(ji,jj)979 smrft (ji,jj) = smv_i_init(ji,jj,jl1) * afrft(ji,jj)980 oirft1(ji,jj) = oa_i_init (ji,jj,jl1) * afrft(ji,jj)981 oirft2(ji,jj) = oa_i_init (ji,jj,jl1) * afrft(ji,jj) / kraft982 983 ! substract everything984 a_i(ji,jj,jl1) = a_i(ji,jj,jl1) - ardg1 (ji,jj) - arft1 (ji,jj)985 v_i(ji,jj,jl1) = v_i(ji,jj,jl1) - vrdg1 (ji,jj) - virft (ji,jj)986 v_s(ji,jj,jl1) = v_s(ji,jj,jl1) - vsrdg (ji,jj) - vsrft (ji,jj)987 e_s(ji,jj,1,jl1) = e_s(ji,jj,1,jl1) - esrdg (ji,jj) - esrft (ji,jj)988 smv_i(ji,jj,jl1) = smv_i(ji,jj,jl1) - srdg1 (ji,jj) - smrft (ji,jj)989 oa_i(ji,jj,jl1) = oa_i(ji,jj,jl1) - oirdg1(ji,jj) - oirft1(ji,jj)990 991 !-----------------------------------------------------------------992 ! 3.5) Compute properties of new ridges993 !-----------------------------------------------------------------994 !---------995 ! Salinity996 !---------997 smsw(ji,jj) = vsw(ji,jj) * sss_m(ji,jj) ! salt content of seawater frozen in voids !! MV HC2014998 srdg2(ji,jj) = srdg1(ji,jj) + smsw(ji,jj) ! salt content of new ridge999 1000 !srdg2(ji,jj) = MIN( rn_simax * vrdg2(ji,jj) , zsrdg2 ) ! impose a maximum salinity1001 1002 sfx_dyn(ji,jj) = sfx_dyn(ji,jj) - smsw(ji,jj) * rhoic * r1_rdtice1003 wfx_dyn(ji,jj) = wfx_dyn(ji,jj) - vsw (ji,jj) * rhoic * r1_rdtice ! increase in ice volume du to seawater frozen in voids1004 1005 !------------------------------------1006 ! 3.6 Increment ridging diagnostics1007 !------------------------------------1008 1009 ! jl1 looping 1-jpl1010 ! ij looping 1-icells1011 1012 dardg1dt (ji,jj) = dardg1dt(ji,jj) + ardg1(ji,jj) + arft1(ji,jj)1013 dardg2dt (ji,jj) = dardg2dt(ji,jj) + ardg2(ji,jj) + arft2(ji,jj)1014 opening (ji,jj) = opening (ji,jj) + opning(ji,jj) * rdt_ice1015 1016 IF( con_i ) vice_init(ji,jj) = vice_init(ji,jj) + vrdg2(ji,jj) - vrdg1(ji,jj)1017 1018 !------------------------------------------1019 ! 3.7 Put the snow somewhere in the ocean1020 !------------------------------------------1021 ! Place part of the snow lost by ridging into the ocean.1022 ! Note that esnow_mlt < 0; the ocean must cool to melt snow.1023 ! If the ocean temp = Tf already, new ice must grow.1024 ! During the next time step, thermo_rates will determine whether1025 ! the ocean cools or new ice grows.1026 ! jl1 looping 1-jpl1027 ! ij looping 1-icells1028 1029 msnow_mlt(ji,jj) = msnow_mlt(ji,jj) + rhosn*vsrdg(ji,jj)*(1.0-rn_fsnowrdg) & ! rafting included1030 & + rhosn*vsrft(ji,jj)*(1.0-rn_fsnowrft)1031 1032 ! in J/m2 (same as e_s)1033 esnow_mlt(ji,jj) = esnow_mlt(ji,jj) - esrdg(ji,jj)*(1.0-rn_fsnowrdg) & !rafting included1034 & - esrft(ji,jj)*(1.0-rn_fsnowrft)1035 1036 !-----------------------------------------------------------------1037 ! 3.8 Compute quantities used to apportion ice among categories1038 ! in the n2 loop below1039 !-----------------------------------------------------------------1040 1041 ! jl1 looping 1-jpl1042 ! ij looping 1-icells1043 1044 dhr (ji,jj) = hrmax(ji,jj,jl1) - hrmin(ji,jj,jl1)1045 dhr2(ji,jj) = hrmax(ji,jj,jl1) * hrmax(ji,jj,jl1) - hrmin(ji,jj,jl1) * hrmin(ji,jj,jl1)1046 1047 END DO1048 1049 !--------------------------------------------------------------------1050 ! 3.9 Compute ridging ice enthalpy, remove it from ridging ice and1051 ! compute ridged ice enthalpy1052 !--------------------------------------------------------------------1053 DO jk = 1, nlay_i1054 DO ij = 1, icells1055 ji = indxi(ij)1056 jj = indxj(ij)1057 ! heat content of ridged ice1058 erdg1(ji,jj,jk) = eicen_init(ji,jj,jk,jl1) * afrac(ji,jj)1059 eirft(ji,jj,jk) = eicen_init(ji,jj,jk,jl1) * afrft(ji,jj)1060 e_i (ji,jj,jk,jl1) = e_i(ji,jj,jk,jl1) - erdg1(ji,jj,jk) - eirft(ji,jj,jk)1061 1062 1063 ! enthalpy of the trapped seawater (J/m2, >0)1064 ! clem: if sst>0, then ersw <0 (is that possible?)1065 ersw(ji,jj,jk) = - rhoic * vsw(ji,jj) * rcp * sst_m(ji,jj) * r1_nlay_i1066 1067 ! heat flux to the ocean1068 hfx_dyn(ji,jj) = hfx_dyn(ji,jj) + ersw(ji,jj,jk) * r1_rdtice ! > 0 [W.m-2] ocean->ice flux1069 1070 ! it is added to sea ice because the sign convention is the opposite of the sign convention for the ocean1071 erdg2(ji,jj,jk) = erdg1(ji,jj,jk) + ersw(ji,jj,jk)1072 1073 END DO1074 END DO1075 1076 1077 IF( con_i ) THEN1078 DO jk = 1, nlay_i1079 DO ij = 1, icells1080 ji = indxi(ij)1081 jj = indxj(ij)1082 eice_init(ji,jj) = eice_init(ji,jj) + erdg2(ji,jj,jk) - erdg1(ji,jj,jk)1083 END DO1084 END DO1085 ENDIF1086 1087 !-------------------------------------------------------------------------------1088 ! 4) Add area, volume, and energy of new ridge to each category jl21089 !-------------------------------------------------------------------------------1090 ! jl1 looping 1-jpl1091 DO jl2 = 1, jpl1092 ! over categories to which ridged ice is transferred1093 DO ij = 1, icells1094 ji = indxi(ij)1095 jj = indxj(ij)1096 1097 ! Compute the fraction of ridged ice area and volume going to1098 ! thickness category jl2.1099 ! Transfer area, volume, and energy accordingly.1100 1101 IF( hrmin(ji,jj,jl1) >= hi_max(jl2) .OR. hrmax(ji,jj,jl1) <= hi_max(jl2-1) ) THEN1102 hL = 0._wp1103 hR = 0._wp1104 ELSE1105 hL = MAX( hrmin(ji,jj,jl1), hi_max(jl2-1) )1106 hR = MIN( hrmax(ji,jj,jl1), hi_max(jl2) )1107 ENDIF1108 1109 ! fraction of ridged ice area and volume going to n21110 farea = ( hR - hL ) / dhr(ji,jj)1111 fvol(ji,jj) = ( hR*hR - hL*hL ) / dhr2(ji,jj)1112 1113 a_i (ji,jj ,jl2) = a_i (ji,jj ,jl2) + ardg2 (ji,jj) * farea1114 v_i (ji,jj ,jl2) = v_i (ji,jj ,jl2) + vrdg2 (ji,jj) * fvol(ji,jj)1115 v_s (ji,jj ,jl2) = v_s (ji,jj ,jl2) + vsrdg (ji,jj) * fvol(ji,jj) * rn_fsnowrdg1116 e_s (ji,jj,1,jl2) = e_s (ji,jj,1,jl2) + esrdg (ji,jj) * fvol(ji,jj) * rn_fsnowrdg1117 smv_i(ji,jj ,jl2) = smv_i(ji,jj ,jl2) + srdg2 (ji,jj) * fvol(ji,jj)1118 oa_i (ji,jj ,jl2) = oa_i (ji,jj ,jl2) + oirdg2(ji,jj) * farea1119 1120 END DO1121 1122 ! Transfer ice energy to category jl2 by ridging1123 DO jk = 1, nlay_i1124 DO ij = 1, icells1125 ji = indxi(ij)1126 jj = indxj(ij)1127 e_i(ji,jj,jk,jl2) = e_i(ji,jj,jk,jl2) + fvol(ji,jj) * erdg2(ji,jj,jk)1128 END DO1129 END DO1130 !1131 END DO ! jl2 (new ridges)1132 1133 DO jl2 = 1, jpl1134 1135 DO ij = 1, icells1136 ji = indxi(ij)1137 jj = indxj(ij)1138 ! Compute the fraction of rafted ice area and volume going to1139 ! thickness category jl2, transfer area, volume, and energy accordingly.1140 !1141 IF( hraft(ji,jj,jl1) <= hi_max(jl2) .AND. hraft(ji,jj,jl1) > hi_max(jl2-1) ) THEN1142 a_i (ji,jj ,jl2) = a_i (ji,jj ,jl2) + arft2 (ji,jj)1143 v_i (ji,jj ,jl2) = v_i (ji,jj ,jl2) + virft (ji,jj)1144 v_s (ji,jj ,jl2) = v_s (ji,jj ,jl2) + vsrft (ji,jj) * rn_fsnowrft1145 e_s (ji,jj,1,jl2) = e_s (ji,jj,1,jl2) + esrft (ji,jj) * rn_fsnowrft1146 smv_i(ji,jj ,jl2) = smv_i(ji,jj ,jl2) + smrft (ji,jj)1147 oa_i (ji,jj ,jl2) = oa_i (ji,jj ,jl2) + oirft2(ji,jj)1148 ENDIF1149 !1150 END DO1151 1152 ! Transfer rafted ice energy to category jl21153 DO jk = 1, nlay_i1154 DO ij = 1, icells1155 ji = indxi(ij)1156 jj = indxj(ij)1157 IF( hraft(ji,jj,jl1) <= hi_max(jl2) .AND. hraft(ji,jj,jl1) > hi_max(jl2-1) ) THEN1158 e_i(ji,jj,jk,jl2) = e_i(ji,jj,jk,jl2) + eirft(ji,jj,jk)1159 ENDIF1160 END DO1161 END DO1162 1163 END DO1164 1165 END DO ! jl1 (deforming categories)1166 1167 ! Conservation check1168 IF ( con_i ) THEN1169 CALL lim_column_sum (jpl, v_i, vice_final)1170 fieldid = ' v_i : limitd_me '1171 CALL lim_cons_check (vice_init, vice_final, 1.0e-6, fieldid)1172 1173 CALL lim_column_sum_energy (jpl, nlay_i, e_i, eice_final )1174 fieldid = ' e_i : limitd_me '1175 CALL lim_cons_check (eice_init, eice_final, 1.0e-2, fieldid)1176 1177 DO ji = mi0(iiceprt), mi1(iiceprt)1178 DO jj = mj0(jiceprt), mj1(jiceprt)1179 WRITE(numout,*) ' vice_init : ', vice_init (ji,jj)1180 WRITE(numout,*) ' vice_final : ', vice_final(ji,jj)1181 WRITE(numout,*) ' eice_init : ', eice_init (ji,jj)1182 WRITE(numout,*) ' eice_final : ', eice_final(ji,jj)1183 END DO1184 END DO1185 ENDIF1186 !1187 CALL wrk_dealloc( (jpi+1)*(jpj+1), indxi, indxj )1188 CALL wrk_dealloc( jpi, jpj, vice_init, vice_final, eice_init, eice_final )1189 CALL wrk_dealloc( jpi, jpj, afrac, fvol , ardg1, ardg2, vsrdg, esrdg, dhr, dhr2 )1190 CALL wrk_dealloc( jpi, jpj, vrdg1, vrdg2, vsw , srdg1, srdg2, smsw, oirdg1, oirdg2 )1191 CALL wrk_dealloc( jpi, jpj, afrft, arft1, arft2, virft, vsrft, esrft, smrft, oirft1, oirft2 )1192 CALL wrk_dealloc( jpi, jpj, jpl, aicen_init, vicen_init, vsnwn_init, esnwn_init, smv_i_init, oa_i_init )1193 CALL wrk_dealloc( jpi, jpj, nlay_i, eirft, erdg1, erdg2, ersw )1194 CALL wrk_dealloc( jpi, jpj, nlay_i, jpl, eicen_init )1195 !1196 END SUBROUTINE lim_itd_me_ridgeshift1197 940 1198 941 SUBROUTINE lim_itd_me_init -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/LIM_SRC_3/limrhg.F90
r6836 r6839 159 159 CALL wrk_alloc( jpi,jpj, u_oce2, u_ice2, v_oce1 , v_ice1 , zmask ) 160 160 CALL wrk_alloc( jpi,jpj, zf1 , zu_ice, zf2 , zv_ice , zdt , zds ) 161 CALL wrk_alloc( jpi,jpj, z dt , zds , zs1 , zs2 , zs12 , zresr , zpice )161 CALL wrk_alloc( jpi,jpj, zs1 , zs2 , zs12 , zresr , zpice ) 162 162 163 163 #if defined key_lim2 && ! defined key_lim2_vp … … 690 690 CALL wrk_dealloc( jpi,jpj, u_oce2, u_ice2, v_oce1 , v_ice1 , zmask ) 691 691 CALL wrk_dealloc( jpi,jpj, zf1 , zu_ice, zf2 , zv_ice , zdt , zds ) 692 CALL wrk_dealloc( jpi,jpj, z dt , zds , zs1 , zs2 , zs12 , zresr , zpice )692 CALL wrk_dealloc( jpi,jpj, zs1 , zs2 , zs12 , zresr , zpice ) 693 693 694 694 END SUBROUTINE lim_rhg -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/LIM_SRC_3/limsbc.F90
r6836 r6839 94 94 !! - fr_i : ice fraction 95 95 !! - tn_ice : sea-ice surface temperature 96 !! - alb_ice : sea-ice albedo ( only useful incoupled mode)96 !! - alb_ice : sea-ice albedo (recomputed only for coupled mode) 97 97 !! 98 98 !! References : Goosse, H. et al. 1996, Bul. Soc. Roy. Sc. Liege, 65, 87-90. … … 106 106 REAL(wp) :: zqsr ! New solar flux received by the ocean 107 107 ! 108 REAL(wp), POINTER, DIMENSION(:,:,:) :: zalb_cs, zalb_os ! 2D/3D workspace 108 REAL(wp), POINTER, DIMENSION(:,:,:) :: zalb_cs, zalb_os ! 3D workspace 109 REAL(wp), POINTER, DIMENSION(:,:) :: zalb ! 2D workspace 109 110 !!--------------------------------------------------------------------- 110 111 111 112 ! make calls for heat fluxes before it is modified 113 ! pfrld is the lead fraction at the previous time step (actually between TRP and THD) 112 114 IF( iom_use('qsr_oce') ) CALL iom_put( "qsr_oce" , qsr_oce(:,:) * pfrld(:,:) ) ! solar flux at ocean surface 113 115 IF( iom_use('qns_oce') ) CALL iom_put( "qns_oce" , qns_oce(:,:) * pfrld(:,:) + qemp_oce(:,:) ) ! non-solar flux at ocean surface … … 118 120 IF( iom_use('qt_ice' ) ) CALL iom_put( "qt_ice" , SUM( ( qns_ice(:,:,:) + qsr_ice(:,:,:) ) & 119 121 & * a_i_b(:,:,:), dim=3 ) + qemp_ice(:,:) ) 120 IF( iom_use('qemp_oce' ) ) CALL iom_put( "qemp_oce" , qemp_oce(:,:) ) 121 IF( iom_use('qemp_ice' ) ) CALL iom_put( "qemp_ice" , qemp_ice(:,:) ) 122 123 ! pfrld is the lead fraction at the previous time step (actually between TRP and THD) 122 IF( iom_use('qemp_oce') ) CALL iom_put( "qemp_oce" , qemp_oce(:,:) ) 123 IF( iom_use('qemp_ice') ) CALL iom_put( "qemp_ice" , qemp_ice(:,:) ) 124 IF( iom_use('emp_oce' ) ) CALL iom_put( "emp_oce" , emp_oce(:,:) ) ! emp over ocean (taking into account the snow blown away from the ice) 125 IF( iom_use('emp_ice' ) ) CALL iom_put( "emp_ice" , emp_ice(:,:) ) ! emp over ice (taking into account the snow blown away from the ice) 126 127 ! albedo output 128 CALL wrk_alloc( jpi,jpj, zalb ) 129 130 zalb(:,:) = 0._wp 131 WHERE ( SUM( a_i_b, dim=3 ) <= epsi06 ) ; zalb(:,:) = 0.066_wp 132 ELSEWHERE ; zalb(:,:) = SUM( alb_ice * a_i_b, dim=3 ) / SUM( a_i_b, dim=3 ) 133 END WHERE 134 IF( iom_use('alb_ice' ) ) CALL iom_put( "alb_ice" , zalb(:,:) ) ! ice albedo output 135 136 zalb(:,:) = SUM( alb_ice * a_i_b, dim=3 ) + 0.066_wp * ( 1._wp - SUM( a_i_b, dim=3 ) ) 137 IF( iom_use('albedo' ) ) CALL iom_put( "albedo" , zalb(:,:) ) ! ice albedo output 138 139 CALL wrk_dealloc( jpi,jpj, zalb ) 140 ! 141 124 142 DO jj = 1, jpj 125 143 DO ji = 1, jpi … … 140 158 hfx_out(ji,jj) = hfx_out(ji,jj) + zqmass + zqsr 141 159 142 ! Add the residual from heat diffusion equation (W.m-2) 143 !------------------------------------------------------- 144 hfx_out(ji,jj) = hfx_out(ji,jj) + hfx_err_dif(ji,jj) 160 ! Add the residual from heat diffusion equation and sublimation (W.m-2) 161 !---------------------------------------------------------------------- 162 hfx_out(ji,jj) = hfx_out(ji,jj) + hfx_err_dif(ji,jj) + & 163 & ( hfx_sub(ji,jj) - SUM( qevap_ice(ji,jj,:) * a_i_b(ji,jj,:) ) ) 145 164 146 165 ! New qsr and qns used to compute the oceanic heat flux at the next time step 147 !--------------------------------------------------- 166 !---------------------------------------------------------------------------- 148 167 qsr(ji,jj) = zqsr 149 168 qns(ji,jj) = hfx_out(ji,jj) - zqsr … … 165 184 166 185 ! mass flux at the ocean/ice interface 167 fmmflx(ji,jj) = - ( wfx_ice(ji,jj) + wfx_snw(ji,jj) ) * r1_rdtice ! F/M mass flux save at least for biogeochemical model 168 emp(ji,jj) = emp_oce(ji,jj) - wfx_ice(ji,jj) - wfx_snw(ji,jj) ! mass flux + F/M mass flux (always ice/ocean mass exchange) 169 186 fmmflx(ji,jj) = - ( wfx_ice(ji,jj) + wfx_snw(ji,jj) + wfx_err_sub(ji,jj) ) ! F/M mass flux save at least for biogeochemical model 187 emp(ji,jj) = emp_oce(ji,jj) - wfx_ice(ji,jj) - wfx_snw(ji,jj) - wfx_err_sub(ji,jj) ! mass flux + F/M mass flux (always ice/ocean mass exchange) 170 188 END DO 171 189 END DO … … 175 193 !------------------------------------------! 176 194 sfx(:,:) = sfx_bog(:,:) + sfx_bom(:,:) + sfx_sum(:,:) + sfx_sni(:,:) + sfx_opw(:,:) & 177 & + sfx_res(:,:) + sfx_dyn(:,:) + sfx_bri(:,:) 195 & + sfx_res(:,:) + sfx_dyn(:,:) + sfx_bri(:,:) + sfx_sub(:,:) 178 196 179 197 !-------------------------------------------------------------! -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/LIM_SRC_3/limthd.F90
r6836 r6839 461 461 462 462 DO ji = kideb, kiut 463 zdh_mel = MIN( 0._wp, dh_i_surf(ji) + dh_i_bott(ji) + dh_snowice(ji) )463 zdh_mel = MIN( 0._wp, dh_i_surf(ji) + dh_i_bott(ji) + dh_snowice(ji) + dh_i_sub(ji) ) 464 464 IF( zdh_mel < 0._wp .AND. a_i_1d(ji) > 0._wp ) THEN 465 465 zvi = a_i_1d(ji) * ht_i_1d(ji) … … 470 470 zda_mel = rswitch * a_i_1d(ji) * zdh_mel / ( 2._wp * MAX( zhi_bef, epsi20 ) ) 471 471 a_i_1d(ji) = MAX( epsi20, a_i_1d(ji) + zda_mel ) 472 472 ! adjust thickness 473 473 ht_i_1d(ji) = zvi / a_i_1d(ji) 474 474 ht_s_1d(ji) = zvs / a_i_1d(ji) … … 514 514 515 515 CALL tab_2d_1d( nbpb, qprec_ice_1d(1:nbpb), qprec_ice(:,:) , jpi, jpj, npb(1:nbpb) ) 516 CALL tab_2d_1d( nbpb, qevap_ice_1d(1:nbpb), qevap_ice(:,:,jl) , jpi, jpj, npb(1:nbpb) ) 516 517 CALL tab_2d_1d( nbpb, qsr_ice_1d (1:nbpb), qsr_ice(:,:,jl) , jpi, jpj, npb(1:nbpb) ) 517 518 CALL tab_2d_1d( nbpb, fr1_i0_1d (1:nbpb), fr1_i0 , jpi, jpj, npb(1:nbpb) ) … … 543 544 CALL tab_2d_1d( nbpb, sfx_bri_1d (1:nbpb), sfx_bri , jpi, jpj, npb(1:nbpb) ) 544 545 CALL tab_2d_1d( nbpb, sfx_res_1d (1:nbpb), sfx_res , jpi, jpj, npb(1:nbpb) ) 545 546 CALL tab_2d_1d( nbpb, sfx_sub_1d (1:nbpb), sfx_sub , jpi, jpj,npb(1:nbpb) ) 547 546 548 CALL tab_2d_1d( nbpb, hfx_thd_1d (1:nbpb), hfx_thd , jpi, jpj, npb(1:nbpb) ) 547 549 CALL tab_2d_1d( nbpb, hfx_spr_1d (1:nbpb), hfx_spr , jpi, jpj, npb(1:nbpb) ) … … 593 595 CALL tab_1d_2d( nbpb, sfx_res , npb, sfx_res_1d(1:nbpb) , jpi, jpj ) 594 596 CALL tab_1d_2d( nbpb, sfx_bri , npb, sfx_bri_1d(1:nbpb) , jpi, jpj ) 595 597 CALL tab_1d_2d( nbpb, sfx_sub , npb, sfx_sub_1d(1:nbpb) , jpi, jpj ) 598 596 599 CALL tab_1d_2d( nbpb, hfx_thd , npb, hfx_thd_1d(1:nbpb) , jpi, jpj ) 597 600 CALL tab_1d_2d( nbpb, hfx_spr , npb, hfx_spr_1d(1:nbpb) , jpi, jpj ) -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/LIM_SRC_3/limthd_dh.F90
r6836 r6839 74 74 75 75 REAL(wp) :: ztmelts ! local scalar 76 REAL(wp) :: z fdum76 REAL(wp) :: zdum 77 77 REAL(wp) :: zfracs ! fractionation coefficient for bottom salt entrapment 78 78 REAL(wp) :: zs_snic ! snow-ice salinity … … 95 95 REAL(wp), POINTER, DIMENSION(:) :: zq_rema ! remaining heat at the end of the routine (J.m-2) 96 96 REAL(wp), POINTER, DIMENSION(:) :: zf_tt ! Heat budget to determine melting or freezing(W.m-2) 97 REAL(wp), POINTER, DIMENSION(:) :: zevap_rema ! remaining mass flux from sublimation (kg.m-2) 97 98 98 99 REAL(wp), POINTER, DIMENSION(:) :: zdh_s_mel ! snow melt … … 105 106 106 107 REAL(wp), POINTER, DIMENSION(:) :: zqh_i ! total ice heat content (J.m-2) 107 REAL(wp), POINTER, DIMENSION(:) :: zqh_s ! total snow heat content (J.m-2)108 REAL(wp), POINTER, DIMENSION(:) :: zq_s ! total snow enthalpy (J.m-3)109 108 REAL(wp), POINTER, DIMENSION(:) :: zsnw ! distribution of snow after wind blowing 110 109 … … 117 116 118 117 ! Discriminate between varying salinity (nn_icesal=2) and prescribed cases (other values) 119 SELECT CASE( nn_icesal ) 120 CASE( 1, 3 , 4) ; zswitch_sal = 0 ! prescribed salinity profile121 CASE( 2 ) 118 SELECT CASE( nn_icesal ) ! varying salinity or not 119 CASE( 1, 3 ) ; zswitch_sal = 0 ! prescribed salinity profile 120 CASE( 2 ) ; zswitch_sal = 1 ! varying salinity profile 122 121 END SELECT 123 122 124 CALL wrk_alloc( jpij, zqprec, zq_su, zq_bo, zf_tt, zq_rema, zsnw )125 CALL wrk_alloc( jpij, zdh_s_mel, zdh_s_pre, zdh_s_sub, zqh_i , zqh_s, zq_s)123 CALL wrk_alloc( jpij, zqprec, zq_su, zq_bo, zf_tt, zq_rema, zsnw, zevap_rema ) 124 CALL wrk_alloc( jpij, zdh_s_mel, zdh_s_pre, zdh_s_sub, zqh_i ) 126 125 CALL wrk_alloc( jpij, nlay_i, zdeltah, zh_i ) 127 126 CALL wrk_alloc( jpij, nlay_i, icount ) 128 127 129 dh_i_surf (:) = 0._wp ; dh_i_bott (:) = 0._wp ; dh_snowice(:) = 0._wp 128 dh_i_surf (:) = 0._wp ; dh_i_bott (:) = 0._wp ; dh_snowice(:) = 0._wp ; dh_i_sub(:) = 0._wp 130 129 dsm_i_se_1d(:) = 0._wp ; dsm_i_si_1d(:) = 0._wp 131 130 132 131 zqprec (:) = 0._wp ; zq_su (:) = 0._wp ; zq_bo (:) = 0._wp ; zf_tt(:) = 0._wp 133 zq_rema (:) = 0._wp ; zsnw (:) = 0._wp 132 zq_rema (:) = 0._wp ; zsnw (:) = 0._wp ; zevap_rema(:) = 0._wp ; 134 133 zdh_s_mel(:) = 0._wp ; zdh_s_pre(:) = 0._wp ; zdh_s_sub(:) = 0._wp ; zqh_i(:) = 0._wp 135 zqh_s (:) = 0._wp ; zq_s (:) = 0._wp136 134 137 135 zdeltah(:,:) = 0._wp ; zh_i(:,:) = 0._wp … … 159 157 ! 160 158 DO ji = kideb, kiut 161 z fdum= qns_ice_1d(ji) + ( 1._wp - i0(ji) ) * qsr_ice_1d(ji) - fc_su(ji)159 zdum = qns_ice_1d(ji) + ( 1._wp - i0(ji) ) * qsr_ice_1d(ji) - fc_su(ji) 162 160 zf_tt(ji) = fc_bo_i(ji) + fhtur_1d(ji) + fhld_1d(ji) 163 161 164 zq_su (ji) = MAX( 0._wp, z fdum* rdt_ice ) * MAX( 0._wp , SIGN( 1._wp, t_su_1d(ji) - rt0 ) )162 zq_su (ji) = MAX( 0._wp, zdum * rdt_ice ) * MAX( 0._wp , SIGN( 1._wp, t_su_1d(ji) - rt0 ) ) 165 163 zq_bo (ji) = MAX( 0._wp, zf_tt(ji) * rdt_ice ) 166 164 END DO … … 187 185 ! 2) Computing layer thicknesses and enthalpies. ! 188 186 !------------------------------------------------------------! 189 !190 DO jk = 1, nlay_s191 DO ji = kideb, kiut192 zqh_s(ji) = zqh_s(ji) + q_s_1d(ji,jk) * ht_s_1d(ji) * r1_nlay_s193 END DO194 END DO195 187 ! 196 188 DO jk = 1, nlay_i … … 275 267 END DO 276 268 277 !---------------------- 278 ! 3.2 S now sublimation279 !---------------------- 269 !------------------------------ 270 ! 3.2 Sublimation (part1: snow) 271 !------------------------------ 280 272 ! qla_ice is always >=0 (upwards), heat goes to the atmosphere, therefore snow sublimates 281 273 ! clem comment: not counted in mass/heat exchange in limsbc since this is an exchange with atm. (not ocean) 282 ! clem comment: ice should also sublimate283 274 zdeltah(:,:) = 0._wp 284 ! coupled mode: sublimation is set to 0 (evap_ice = 0) until further notice 285 ! forced mode: snow thickness change due to sublimation 286 DO ji = kideb, kiut 287 zdh_s_sub(ji) = MAX( - ht_s_1d(ji) , - evap_ice_1d(ji) * r1_rhosn * rdt_ice ) 288 ! Heat flux by sublimation [W.m-2], < 0 289 ! sublimate first snow that had fallen, then pre-existing snow 275 DO ji = kideb, kiut 276 zdh_s_sub(ji) = MAX( - ht_s_1d(ji) , - evap_ice_1d(ji) * r1_rhosn * rdt_ice ) 277 ! remaining evap in kg.m-2 (used for ice melting later on) 278 zevap_rema(ji) = evap_ice_1d(ji) * rdt_ice + zdh_s_sub(ji) * rhosn 279 ! Heat flux by sublimation [W.m-2], < 0 (sublimate first snow that had fallen, then pre-existing snow) 290 280 zdeltah(ji,1) = MAX( zdh_s_sub(ji), - zdh_s_pre(ji) ) 291 281 hfx_sub_1d(ji) = hfx_sub_1d(ji) + ( zdeltah(ji,1) * zqprec(ji) + ( zdh_s_sub(ji) - zdeltah(ji,1) ) * q_s_1d(ji,1) & … … 309 299 !------------------------------------------- 310 300 ! new temp and enthalpy of the snow (remaining snow precip + remaining pre-existing snow) 311 zq_s(:) = 0._wp312 301 DO jk = 1, nlay_s 313 302 DO ji = kideb,kiut 314 rswitch = MAX( 0._wp , SIGN( 1._wp, ht_s_1d(ji) - epsi20 ) ) 315 q_s_1d(ji,jk) = rswitch / MAX( ht_s_1d(ji), epsi20 ) * & 316 & ( ( zdh_s_pre(ji) ) * zqprec(ji) + & 317 & ( ht_s_1d(ji) - zdh_s_pre(ji) ) * rhosn * ( cpic * ( rt0 - t_s_1d(ji,jk) ) + lfus ) ) 318 zq_s(ji) = zq_s(ji) + q_s_1d(ji,jk) 303 rswitch = MAX( 0._wp , SIGN( 1._wp, ht_s_1d(ji) - epsi20 ) ) 304 q_s_1d(ji,jk) = rswitch / MAX( ht_s_1d(ji), epsi20 ) * & 305 & ( ( zdh_s_pre(ji) ) * zqprec(ji) + & 306 & ( ht_s_1d(ji) - zdh_s_pre(ji) ) * rhosn * ( cpic * ( rt0 - t_s_1d(ji,jk) ) + lfus ) ) 319 307 END DO 320 308 END DO … … 370 358 zQm = zfmdt * zEw ! Energy of the melt water sent to the ocean [J/m2, <0] 371 359 372 ! Contribution to salt flux (clem: using sm_i_1d and not s_i_1d(jk) is ok)360 ! Contribution to salt flux >0 (clem: using sm_i_1d and not s_i_1d(jk) is ok) 373 361 sfx_sum_1d(ji) = sfx_sum_1d(ji) - rhoic * a_i_1d(ji) * zdeltah(ji,jk) * sm_i_1d(ji) * r1_rdtice 374 362 … … 383 371 384 372 END IF 373 ! ---------------------- 374 ! Sublimation part2: ice 375 ! ---------------------- 376 zdum = MAX( - ( zh_i(ji,jk) + zdeltah(ji,jk) ) , - zevap_rema(ji) * r1_rhoic ) 377 zdeltah(ji,jk) = zdeltah(ji,jk) + zdum 378 dh_i_sub(ji) = dh_i_sub(ji) + zdum 379 ! Salt flux > 0 (clem2016: flux is sent to the ocean for simplicity but salt should remain in the ice except if all ice is melted. 380 ! It must be corrected at some point) 381 sfx_sub_1d(ji) = sfx_sub_1d(ji) - rhoic * a_i_1d(ji) * zdum * sm_i_1d(ji) * r1_rdtice 382 ! Heat flux [W.m-2], < 0 383 hfx_sub_1d(ji) = hfx_sub_1d(ji) + zdum * q_i_1d(ji,jk) * a_i_1d(ji) * r1_rdtice 384 ! Mass flux > 0 385 wfx_sub_1d(ji) = wfx_sub_1d(ji) - rhoic * a_i_1d(ji) * zdum * r1_rdtice 386 ! update remaining mass flux 387 zevap_rema(ji) = zevap_rema(ji) + zdum * rhoic 388 385 389 ! record which layers have disappeared (for bottom melting) 386 390 ! => icount=0 : no layer has vanished … … 389 393 icount(ji,jk) = NINT( rswitch ) 390 394 zh_i(ji,jk) = MAX( 0._wp , zh_i(ji,jk) + zdeltah(ji,jk) ) 391 395 392 396 ! update heat content (J.m-2) and layer thickness 393 397 qh_i_old(ji,jk) = qh_i_old(ji,jk) + zdeltah(ji,jk) * q_i_1d(ji,jk) … … 397 401 ! update ice thickness 398 402 DO ji = kideb, kiut 399 ht_i_1d(ji) = MAX( 0._wp , ht_i_1d(ji) + dh_i_surf(ji) ) 403 ht_i_1d(ji) = MAX( 0._wp , ht_i_1d(ji) + dh_i_surf(ji) + dh_i_sub(ji) ) 404 END DO 405 406 ! remaining "potential" evap is sent to ocean 407 DO ji = kideb, kiut 408 ii = MOD( npb(ji) - 1, jpi ) + 1 ; ij = ( npb(ji) - 1 ) / jpi + 1 409 wfx_err_sub(ii,ij) = wfx_err_sub(ii,ij) - zevap_rema(ji) * a_i_1d(ji) * r1_rdtice ! <=0 (net evap for the ocean in kg.m-2.s-1) 400 410 END DO 401 411 … … 641 651 642 652 ! Contribution to energy flux to the ocean [J/m2], >0 (if sst<0) 643 ii = MOD( npb(ji) - 1, jpi ) + 1 ; ij = ( npb(ji) - 1 ) / jpi + 1644 653 zfmdt = ( rhosn - rhoic ) * MAX( dh_snowice(ji), 0._wp ) ! <0 645 654 zsstK = sst_m(ii,ij) + rt0 … … 652 661 ! Contribution to salt flux 653 662 sfx_sni_1d(ji) = sfx_sni_1d(ji) + sss_m(ii,ij) * a_i_1d(ji) * zfmdt * r1_rdtice 663 664 ! virtual salt flux to keep salinity constant 665 IF( nn_icesal == 1 .OR. nn_icesal == 3 ) THEN 666 sfx_bri_1d(ji) = sfx_bri_1d(ji) - sss_m(ii,ij) * a_i_1d(ji) * zfmdt * r1_rdtice & ! put back sss_m into the ocean 667 & - sm_i_1d(ji) * a_i_1d(ji) * dh_snowice(ji) * rhoic * r1_rdtice ! and get sm_i from the ocean 668 ENDIF 654 669 655 670 ! Contribution to mass flux … … 686 701 WHERE( ht_i_1d == 0._wp ) a_i_1d = 0._wp 687 702 688 CALL wrk_dealloc( jpij, zqprec, zq_su, zq_bo, zf_tt, zq_rema, zsnw )689 CALL wrk_dealloc( jpij, zdh_s_mel, zdh_s_pre, zdh_s_sub, zqh_i , zqh_s, zq_s)703 CALL wrk_dealloc( jpij, zqprec, zq_su, zq_bo, zf_tt, zq_rema, zsnw, zevap_rema ) 704 CALL wrk_dealloc( jpij, zdh_s_mel, zdh_s_pre, zdh_s_sub, zqh_i ) 690 705 CALL wrk_dealloc( jpij, nlay_i, zdeltah, zh_i ) 691 706 CALL wrk_dealloc( jpij, nlay_i, icount ) -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/LIM_SRC_3/limthd_lac.F90
r6836 r6839 75 75 INTEGER :: ii, ij, iter ! - - 76 76 REAL(wp) :: ztmelts, zdv, zfrazb, zweight, zde ! local scalars 77 REAL(wp) :: zgamafr, zvfrx, zvgx, ztaux, ztwogp, zf , zhicol_new! - -77 REAL(wp) :: zgamafr, zvfrx, zvgx, ztaux, ztwogp, zf ! - - 78 78 REAL(wp) :: ztenagm, zvfry, zvgy, ztauy, zvrel2, zfp, zsqcd , zhicrit ! - - 79 LOGICAL :: iterate_frazil ! iterate frazil ice collection thickness80 79 CHARACTER (len = 15) :: fieldid 81 80 … … 108 107 REAL(wp), POINTER, DIMENSION(:,:) :: zsmv_i_1d ! 1-D version of smv_i 109 108 110 REAL(wp), POINTER, DIMENSION(:,:,:) :: ze_i_1d 111 112 REAL(wp), POINTER, DIMENSION(:,:) :: zvrel 113 114 REAL(wp) :: zcai = 1.4e-3_wp 109 REAL(wp), POINTER, DIMENSION(:,:,:) :: ze_i_1d !: 1-D version of e_i 110 111 REAL(wp), POINTER, DIMENSION(:,:) :: zvrel ! relative ice / frazil velocity 112 113 REAL(wp) :: zcai = 1.4e-3_wp ! ice-air drag (clem: should be dependent on coupling/forcing used) 115 114 !!-----------------------------------------------------------------------! 116 115 … … 143 142 !------------------------------------------------------------------------------! 144 143 ! hicol is the thickness of new ice formed in open water 145 ! hicol can be either prescribed (frazswi = 0) 146 ! or computed (frazswi = 1) 144 ! hicol can be either prescribed (frazswi = 0) or computed (frazswi = 1) 147 145 ! Frazil ice forms in open water, is transported by wind 148 146 ! accumulates at the edge of the consolidated ice edge … … 155 153 zvrel(:,:) = 0._wp 156 154 157 ! Default new ice thickness 158 hicol(:,:) = rn_hnewice 155 ! Default new ice thickness 156 WHERE( qlead(:,:) < 0._wp ) ; hicol = rn_hnewice 157 ELSEWHERE ; hicol = 0._wp 158 END WHERE 159 159 160 160 IF( ln_frazil ) THEN … … 182 182 & + vtau_ice(ji ,jj ) * vmask(ji ,jj ,1) ) * 0.5_wp 183 183 ! Square root of wind stress 184 ztenagm = SQRT( SQRT( ztaux **2 + ztauy**2) )184 ztenagm = SQRT( SQRT( ztaux * ztaux + ztauy * ztauy ) ) 185 185 186 186 !--------------------- … … 205 205 zvrel2 = MAX( ( zvfrx - zvgx ) * ( zvfrx - zvgx ) & 206 206 & + ( zvfry - zvgy ) * ( zvfry - zvgy ) , 0.15 * 0.15 ) 207 zvrel(ji,jj) 207 zvrel(ji,jj) = SQRT( zvrel2 ) 208 208 209 209 !--------------------- 210 210 ! Iterative procedure 211 211 !--------------------- 212 hicol(ji,jj) = zhicrit + 0.1 213 hicol(ji,jj) = zhicrit + hicol(ji,jj) & 214 & / ( hicol(ji,jj) * hicol(ji,jj) - zhicrit * zhicrit ) * ztwogp * zvrel2 215 216 !!gm better coding: above: hicol(ji,jj) * hicol(ji,jj) = (zhicrit + 0.1)*(zhicrit + 0.1) 217 !!gm = zhicrit**2 + 0.2*zhicrit +0.01 218 !!gm therefore the 2 lines with hicol can be replaced by 1 line: 219 !!gm hicol(ji,jj) = zhicrit + (zhicrit + 0.1) / ( 0.2 * zhicrit + 0.01 ) * ztwogp * zvrel2 220 !!gm further more (zhicrit + 0.1)/(0.2 * zhicrit + 0.01 )*ztwogp can be computed one for all outside the DO loop 212 hicol(ji,jj) = zhicrit + ( zhicrit + 0.1 ) & 213 & / ( ( zhicrit + 0.1 ) * ( zhicrit + 0.1 ) - zhicrit * zhicrit ) * ztwogp * zvrel2 221 214 222 215 iter = 1 223 iterate_frazil = .true. 224 225 DO WHILE ( iter < 100 .AND. iterate_frazil ) 226 zf = ( hicol(ji,jj) - zhicrit ) * ( hicol(ji,jj)**2 - zhicrit**2 ) & 227 - hicol(ji,jj) * zhicrit * ztwogp * zvrel2 228 zfp = ( hicol(ji,jj) - zhicrit ) * ( 3.0*hicol(ji,jj) + zhicrit ) & 229 - zhicrit * ztwogp * zvrel2 230 zhicol_new = hicol(ji,jj) - zf/zfp 231 hicol(ji,jj) = zhicol_new 232 216 DO WHILE ( iter < 20 ) 217 zf = ( hicol(ji,jj) - zhicrit ) * ( hicol(ji,jj) * hicol(ji,jj) - zhicrit * zhicrit ) - & 218 & hicol(ji,jj) * zhicrit * ztwogp * zvrel2 219 zfp = ( hicol(ji,jj) - zhicrit ) * ( 3.0 * hicol(ji,jj) + zhicrit ) - zhicrit * ztwogp * zvrel2 220 221 hicol(ji,jj) = hicol(ji,jj) - zf/zfp 233 222 iter = iter + 1 234 235 END DO ! do while 223 END DO 236 224 237 225 ENDIF ! end of selection of pixels where ice forms 238 226 239 END DO ! loop on ji ends240 END DO ! loop on jj ends241 !242 CALL lbc_lnk( zvrel(:,:), 'T', 1. )243 CALL lbc_lnk( hicol(:,:), 'T', 1. )227 END DO 228 END DO 229 ! 230 CALL lbc_lnk( zvrel(:,:), 'T', 1. ) 231 CALL lbc_lnk( hicol(:,:), 'T', 1. ) 244 232 245 233 ENDIF ! End of computation of frazil ice collection thickness … … 282 270 ! Move from 2-D to 1-D vectors 283 271 !------------------------------ 284 ! If ocean gains heat do nothing 285 ! 0therwise compute new ice formation 272 ! If ocean gains heat do nothing. Otherwise compute new ice formation 286 273 287 274 IF ( nbpac > 0 ) THEN … … 297 284 END DO 298 285 299 CALL tab_2d_1d( nbpac, qlead_1d (1:nbpac) , qlead , jpi, jpj, npac(1:nbpac) ) 300 CALL tab_2d_1d( nbpac, t_bo_1d (1:nbpac) , t_bo , jpi, jpj, npac(1:nbpac) ) 301 CALL tab_2d_1d( nbpac, sfx_opw_1d(1:nbpac) , sfx_opw, jpi, jpj, npac(1:nbpac) ) 302 CALL tab_2d_1d( nbpac, wfx_opw_1d(1:nbpac) , wfx_opw, jpi, jpj, npac(1:nbpac) ) 303 CALL tab_2d_1d( nbpac, hicol_1d (1:nbpac) , hicol , jpi, jpj, npac(1:nbpac) ) 304 CALL tab_2d_1d( nbpac, zvrel_1d (1:nbpac) , zvrel , jpi, jpj, npac(1:nbpac) ) 305 306 CALL tab_2d_1d( nbpac, hfx_thd_1d(1:nbpac) , hfx_thd, jpi, jpj, npac(1:nbpac) ) 307 CALL tab_2d_1d( nbpac, hfx_opw_1d(1:nbpac) , hfx_opw, jpi, jpj, npac(1:nbpac) ) 286 CALL tab_2d_1d( nbpac, qlead_1d (1:nbpac) , qlead , jpi, jpj, npac(1:nbpac) ) 287 CALL tab_2d_1d( nbpac, t_bo_1d (1:nbpac) , t_bo , jpi, jpj, npac(1:nbpac) ) 288 CALL tab_2d_1d( nbpac, sfx_opw_1d(1:nbpac) , sfx_opw , jpi, jpj, npac(1:nbpac) ) 289 CALL tab_2d_1d( nbpac, wfx_opw_1d(1:nbpac) , wfx_opw , jpi, jpj, npac(1:nbpac) ) 290 CALL tab_2d_1d( nbpac, hicol_1d (1:nbpac) , hicol , jpi, jpj, npac(1:nbpac) ) 291 CALL tab_2d_1d( nbpac, zvrel_1d (1:nbpac) , zvrel , jpi, jpj, npac(1:nbpac) ) 292 293 CALL tab_2d_1d( nbpac, hfx_thd_1d(1:nbpac) , hfx_thd , jpi, jpj, npac(1:nbpac) ) 294 CALL tab_2d_1d( nbpac, hfx_opw_1d(1:nbpac) , hfx_opw , jpi, jpj, npac(1:nbpac) ) 295 CALL tab_2d_1d( nbpac, rn_amax_1d(1:nbpac) , rn_amax_2d, jpi, jpj, npac(1:nbpac) ) 308 296 309 297 !------------------------------------------------------------------------------! … … 316 304 zv_b(1:nbpac,:) = zv_i_1d(1:nbpac,:) 317 305 za_b(1:nbpac,:) = za_i_1d(1:nbpac,:) 306 318 307 !---------------------- 319 308 ! Thickness of new ice 320 309 !---------------------- 321 DO ji = 1, nbpac 322 zh_newice(ji) = rn_hnewice 323 END DO 324 IF( ln_frazil ) zh_newice(1:nbpac) = hicol_1d(1:nbpac) 310 zh_newice(1:nbpac) = hicol_1d(1:nbpac) 325 311 326 312 !---------------------- … … 384 370 ! salt flux 385 371 sfx_opw_1d(ji) = sfx_opw_1d(ji) - zv_newice(ji) * rhoic * zs_newice(ji) * r1_rdtice 386 372 END DO 373 374 zv_frazb(:) = 0._wp 375 IF( ln_frazil ) THEN 387 376 ! A fraction zfrazb of frazil ice is accreted at the ice bottom 388 rswitch = 1._wp - MAX( 0._wp, SIGN( 1._wp , - zat_i_1d(ji) ) ) 389 zfrazb = rswitch * ( TANH ( rn_Cfrazb * ( zvrel_1d(ji) - rn_vfrazb ) ) + 1.0 ) * 0.5 * rn_maxfrazb 390 zv_frazb(ji) = zfrazb * zv_newice(ji) 391 zv_newice(ji) = ( 1.0 - zfrazb ) * zv_newice(ji) 392 END DO 393 377 DO ji = 1, nbpac 378 rswitch = 1._wp - MAX( 0._wp, SIGN( 1._wp , - zat_i_1d(ji) ) ) 379 zfrazb = rswitch * ( TANH( rn_Cfrazb * ( zvrel_1d(ji) - rn_vfrazb ) ) + 1.0 ) * 0.5 * rn_maxfrazb 380 zv_frazb(ji) = zfrazb * zv_newice(ji) 381 zv_newice(ji) = ( 1.0 - zfrazb ) * zv_newice(ji) 382 END DO 383 END IF 384 394 385 !----------------- 395 386 ! Area of new ice … … 409 400 ! we keep the excessive volume in memory and attribute it later to bottom accretion 410 401 DO ji = 1, nbpac 411 IF ( za_newice(ji) > ( rn_amax - zat_i_1d(ji) ) ) THEN412 zda_res(ji) = za_newice(ji) - ( rn_amax - zat_i_1d(ji) )402 IF ( za_newice(ji) > ( rn_amax_1d(ji) - zat_i_1d(ji) ) ) THEN 403 zda_res(ji) = za_newice(ji) - ( rn_amax_1d(ji) - zat_i_1d(ji) ) 413 404 zdv_res(ji) = zda_res (ji) * zh_newice(ji) 414 405 za_newice(ji) = za_newice(ji) - zda_res (ji) … … 443 434 jl = jcat(ji) 444 435 rswitch = MAX( 0._wp, SIGN( 1._wp , zv_i_1d(ji,jl) - epsi20 ) ) 445 ze_i_1d(ji,jk,jl) = zswinew(ji) * ze_newice(ji) + 436 ze_i_1d(ji,jk,jl) = zswinew(ji) * ze_newice(ji) + & 446 437 & ( 1.0 - zswinew(ji) ) * ( ze_newice(ji) * zv_newice(ji) + ze_i_1d(ji,jk,jl) * zv_b(ji,jl) ) & 447 438 & * rswitch / MAX( zv_i_1d(ji,jl), epsi20 ) -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/LIM_SRC_3/limthd_sal.F90
r6836 r6839 62 62 END DO 63 63 64 !------------------------------------------------------------------------------| 65 ! 1) Constant salinity, constant in time | 66 !------------------------------------------------------------------------------| 67 !!gm comment: if nn_icesal = 1 s_i_new, s_i_1d and sm_i_1d can be set to rn_icesal one for all in the initialisation phase !! 68 !!gm ===>>> simplification of almost all test on nn_icesal value 69 IF( nn_icesal == 1 ) THEN 70 s_i_1d (kideb:kiut,1:nlay_i) = rn_icesal 71 sm_i_1d(kideb:kiut) = rn_icesal 72 s_i_new(kideb:kiut) = rn_icesal 73 ENDIF 64 !--------------------------------------------------------------------| 65 ! 1) salinity constant in time | 66 !--------------------------------------------------------------------| 67 ! do nothing 74 68 75 !---------------------------------------------------------------------- --------|76 ! Module 2 : Constant salinity varying in time|77 !---------------------------------------------------------------------- --------|69 !----------------------------------------------------------------------| 70 ! 2) salinity varying in time | 71 !----------------------------------------------------------------------| 78 72 IF( nn_icesal == 2 ) THEN 79 73 … … 113 107 114 108 !------------------------------------------------------------------------------| 115 ! Module 3 : Profile of salinity, constant in time|109 ! 3) vertical profile of salinity, constant in time | 116 110 !------------------------------------------------------------------------------| 117 111 IF( nn_icesal == 3 ) CALL lim_var_salprof1d( kideb, kiut ) -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/LIM_SRC_3/limtrp.F90
r6836 r6839 63 63 INTEGER, INTENT(in) :: kt ! number of iteration 64 64 ! 65 INTEGER :: ji, jj, jk, j l, jt ! dummy loop indices65 INTEGER :: ji, jj, jk, jm , jl, jt ! dummy loop indices 66 66 INTEGER :: initad ! number of sub-timestep for the advection 67 67 REAL(wp) :: zcfl , zusnit ! - - … … 75 75 REAL(wp), POINTER, DIMENSION(:,:,:) :: zhimax ! old ice thickness 76 76 REAL(wp), POINTER, DIMENSION(:,:) :: zatold, zeiold, zesold ! old concentration, enthalpies 77 REAL(wp), POINTER, DIMENSION(:,:,:) :: zhdfptab 77 78 REAL(wp) :: zdv, zvi, zvs, zsmv, zes, zei 78 79 REAL(wp) :: zvi_b, zsmv_b, zei_b, zfs_b, zfw_b, zft_b 80 !!--------------------------------------------------------------------- 81 INTEGER :: ihdf_vars = 6 !!Number of variables in which we apply horizontal diffusion 82 !! inside limtrp for each ice category , not counting the 83 !! variables corresponding to ice_layers 79 84 !!--------------------------------------------------------------------- 80 85 IF( nn_timing == 1 ) CALL timing_start('limtrp') … … 85 90 CALL wrk_alloc( jpi,jpj,nlay_i,jpl, z0ei ) 86 91 CALL wrk_alloc( jpi,jpj,jpl, zhimax, zviold, zvsold, zsmvold ) 92 CALL wrk_alloc( jpi,jpj,jpl*(ihdf_vars + nlay_i)+1,zhdfptab) 87 93 88 94 IF( numit == nstart .AND. lwp ) THEN … … 170 176 z0oi (:,:,jl) = oa_i (:,:,jl) * e12t(:,:) ! Age content 171 177 z0es (:,:,jl) = e_s (:,:,1,jl) * e12t(:,:) ! Snow heat content 172 178 DO jk = 1, nlay_i 173 179 z0ei (:,:,jk,jl) = e_i (:,:,jk,jl) * e12t(:,:) ! Ice heat content 174 180 END DO … … 284 290 ! Diffusion of Ice fields 285 291 !------------------------------------------------------------------------------! 286 292 !------------------------------------ 293 ! Diffusion of other ice variables 294 !------------------------------------ 295 jm=1 296 DO jl = 1, jpl 297 ! ! Masked eddy diffusivity coefficient at ocean U- and V-points 298 ! DO jj = 1, jpjm1 ! NB: has not to be defined on jpj line and jpi row 299 ! DO ji = 1 , fs_jpim1 ! vector opt. 300 ! pahu(ji,jj) = ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -a_i(ji ,jj,jl) ) ) ) & 301 ! & * ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -a_i(ji+1,jj,jl) ) ) ) * ahiu(ji,jj) 302 ! pahv(ji,jj) = ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -a_i(ji,jj ,jl) ) ) ) & 303 ! & * ( 1._wp - MAX( 0._wp, SIGN( 1._wp,- a_i(ji,jj+1,jl) ) ) ) * ahiv(ji,jj) 304 ! END DO 305 ! END DO 306 DO jj = 1, jpjm1 ! NB: has not to be defined on jpj line and jpi row 307 DO ji = 1 , fs_jpim1 ! vector opt. 308 pahu3D(ji,jj,jl) = ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -a_i(ji ,jj, jl ) ) ) ) & 309 & * ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -a_i(ji+1,jj, jl ) ) ) ) * ahiu(ji,jj) 310 pahv3D(ji,jj,jl) = ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -a_i(ji, jj, jl ) ) ) ) & 311 & * ( 1._wp - MAX( 0._wp, SIGN( 1._wp,- a_i(ji, jj+1,jl ) ) ) ) * ahiv(ji,jj) 312 END DO 313 END DO 314 315 zhdfptab(:,:,jm)= a_i (:,:, jl); jm = jm + 1 316 zhdfptab(:,:,jm)= v_i (:,:, jl); jm = jm + 1 317 zhdfptab(:,:,jm)= v_s (:,:, jl); jm = jm + 1 318 zhdfptab(:,:,jm)= smv_i(:,:, jl); jm = jm + 1 319 zhdfptab(:,:,jm)= oa_i (:,:, jl); jm = jm + 1 320 zhdfptab(:,:,jm)= e_s (:,:,1,jl); jm = jm + 1 321 ! Sample of adding more variables to apply lim_hdf using lim_hdf optimization--- 322 ! zhdfptab(:,:,jm) = variable_1 (:,:,1,jl); jm = jm + 1 323 ! zhdfptab(:,:,jm) = variable_2 (:,:,1,jl); jm = jm + 1 324 ! 325 ! and in this example the parameter ihdf_vars musb be changed to 8 (necessary for allocation) 326 !---------------------------------------------------------------------------------------- 327 DO jk = 1, nlay_i 328 zhdfptab(:,:,jm)=e_i(:,:,jk,jl); jm= jm+1 329 END DO 330 END DO 287 331 ! 288 332 !-------------------------------- … … 290 334 !-------------------------------- 291 335 ! ! Masked eddy diffusivity coefficient at ocean U- and V-points 336 !DO jj = 1, jpjm1 ! NB: has not to be defined on jpj line and jpi row 337 ! DO ji = 1 , fs_jpim1 ! vector opt. 338 ! pahu(ji,jj) = ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -at_i(ji ,jj) ) ) ) & 339 ! & * ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -at_i(ji+1,jj) ) ) ) * ahiu(ji,jj) 340 ! pahv(ji,jj) = ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -at_i(ji,jj ) ) ) ) & 341 ! & * ( 1._wp - MAX( 0._wp, SIGN( 1._wp,- at_i(ji,jj+1) ) ) ) * ahiv(ji,jj) 342 ! END DO 343 !END DO 344 292 345 DO jj = 1, jpjm1 ! NB: has not to be defined on jpj line and jpi row 293 346 DO ji = 1 , fs_jpim1 ! vector opt. 294 pahu (ji,jj) = ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -at_i(ji ,jj) ) ) ) &295 & * ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -at_i(ji+1,jj) ) ) ) * ahiu(ji,jj)296 pahv (ji,jj) = ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -at_i(ji,jj ) ) ) ) &297 & * ( 1._wp - MAX( 0._wp, SIGN( 1._wp,- at_i(ji,jj+1) ) ) ) * ahiv(ji,jj)347 pahu3D(ji,jj,jpl+1) = ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -at_i(ji ,jj) ) ) ) & 348 & * ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -at_i(ji+1,jj) ) ) ) * ahiu(ji,jj) 349 pahv3D(ji,jj,jpl+1) = ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -at_i(ji,jj ) ) ) ) & 350 & * ( 1._wp - MAX( 0._wp, SIGN( 1._wp,- at_i(ji,jj+1) ) ) ) * ahiv(ji,jj) 298 351 END DO 299 352 END DO 300 353 ! 301 CALL lim_hdf( ato_i (:,:) ) 302 303 !------------------------------------ 304 ! Diffusion of other ice variables 305 !------------------------------------ 306 DO jl = 1, jpl 307 ! ! Masked eddy diffusivity coefficient at ocean U- and V-points 308 DO jj = 1, jpjm1 ! NB: has not to be defined on jpj line and jpi row 309 DO ji = 1 , fs_jpim1 ! vector opt. 310 pahu(ji,jj) = ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -a_i(ji ,jj,jl) ) ) ) & 311 & * ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -a_i(ji+1,jj,jl) ) ) ) * ahiu(ji,jj) 312 pahv(ji,jj) = ( 1._wp - MAX( 0._wp, SIGN( 1._wp, -a_i(ji,jj ,jl) ) ) ) & 313 & * ( 1._wp - MAX( 0._wp, SIGN( 1._wp,- a_i(ji,jj+1,jl) ) ) ) * ahiv(ji,jj) 314 END DO 315 END DO 316 317 CALL lim_hdf( v_i (:,:, jl) ) 318 CALL lim_hdf( v_s (:,:, jl) ) 319 CALL lim_hdf( smv_i(:,:, jl) ) 320 CALL lim_hdf( oa_i (:,:, jl) ) 321 CALL lim_hdf( a_i (:,:, jl) ) 322 CALL lim_hdf( e_s (:,:,1,jl) ) 354 zhdfptab(:,:,jm)= ato_i (:,:); 355 CALL lim_hdf( zhdfptab, ihdf_vars, jpl, nlay_i) 356 357 jm=1 358 DO jl = 1, jpl 359 a_i (:,:, jl) = zhdfptab(:,:,jm); jm = jm + 1 360 v_i (:,:, jl) = zhdfptab(:,:,jm); jm = jm + 1 361 v_s (:,:, jl) = zhdfptab(:,:,jm); jm = jm + 1 362 smv_i(:,:, jl) = zhdfptab(:,:,jm); jm = jm + 1 363 oa_i (:,:, jl) = zhdfptab(:,:,jm); jm = jm + 1 364 e_s (:,:,1,jl) = zhdfptab(:,:,jm); jm = jm + 1 365 ! Sample of adding more variables to apply lim_hdf--------- 366 ! variable_1 (:,:,1,jl) = zhdfptab(:,:, jm ) ; jm + 1 367 ! variable_2 (:,:,1,jl) = zhdfptab(:,:, jm ) ; jm + 1 368 !----------------------------------------------------------- 323 369 DO jk = 1, nlay_i 324 CALL lim_hdf( e_i(:,:,jk,jl) ) 325 END DO 326 END DO 370 e_i(:,:,jk,jl) = zhdfptab(:,:,jm);jm= jm + 1 371 END DO 372 END DO 373 374 ato_i (:,:) = zhdfptab(:,:,jm) 327 375 328 376 !------------------------------------------------------------------------------! … … 422 470 DO jj = 1, jpj 423 471 DO ji = 1, jpi 424 a_i(ji,jj,1) = MIN( a_i(ji,jj,1), rn_amax )472 a_i(ji,jj,1) = MIN( a_i(ji,jj,1), rn_amax_2d(ji,jj) ) 425 473 END DO 426 474 END DO … … 464 512 CALL wrk_dealloc( jpi,jpj,nlay_i,jpl, z0ei ) 465 513 CALL wrk_dealloc( jpi,jpj,jpl, zviold, zvsold, zhimax, zsmvold ) 514 CALL wrk_dealloc( jpi,jpj,jpl*(ihdf_vars+nlay_i)+1,zhdfptab) 466 515 ! 467 516 IF( nn_timing == 1 ) CALL timing_stop('limtrp') … … 479 528 !!====================================================================== 480 529 END MODULE limtrp 530 -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/LIM_SRC_3/limupdate1.F90
r6836 r6839 80 80 DO jj = 1, jpj 81 81 DO ji = 1, jpi 82 IF( at_i(ji,jj) > rn_amax .AND. a_i(ji,jj,jl) > 0._wp ) THEN83 a_i (ji,jj,jl) = a_i (ji,jj,jl) * ( 1._wp - ( 1._wp - rn_amax / at_i(ji,jj) ) )84 oa_i(ji,jj,jl) = oa_i(ji,jj,jl) * ( 1._wp - ( 1._wp - rn_amax / at_i(ji,jj) ) )82 IF( at_i(ji,jj) > rn_amax_2d(ji,jj) .AND. a_i(ji,jj,jl) > 0._wp ) THEN 83 a_i (ji,jj,jl) = a_i (ji,jj,jl) * ( 1._wp - ( 1._wp - rn_amax_2d(ji,jj) / at_i(ji,jj) ) ) 84 oa_i(ji,jj,jl) = oa_i(ji,jj,jl) * ( 1._wp - ( 1._wp - rn_amax_2d(ji,jj) / at_i(ji,jj) ) ) 85 85 ENDIF 86 86 END DO -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/LIM_SRC_3/limupdate2.F90
r6836 r6839 94 94 DO jj = 1, jpj 95 95 DO ji = 1, jpi 96 IF( at_i(ji,jj) > rn_amax .AND. a_i(ji,jj,jl) > 0._wp ) THEN97 a_i (ji,jj,jl) = a_i (ji,jj,jl) * ( 1._wp - ( 1._wp - rn_amax / at_i(ji,jj) ) )98 oa_i(ji,jj,jl) = oa_i(ji,jj,jl) * ( 1._wp - ( 1._wp - rn_amax / at_i(ji,jj) ) )96 IF( at_i(ji,jj) > rn_amax_2d(ji,jj) .AND. a_i(ji,jj,jl) > 0._wp ) THEN 97 a_i (ji,jj,jl) = a_i (ji,jj,jl) * ( 1._wp - ( 1._wp - rn_amax_2d(ji,jj) / at_i(ji,jj) ) ) 98 oa_i(ji,jj,jl) = oa_i(ji,jj,jl) * ( 1._wp - ( 1._wp - rn_amax_2d(ji,jj) / at_i(ji,jj) ) ) 99 99 ENDIF 100 100 END DO -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/LIM_SRC_3/limvar.F90
r6836 r6839 163 163 rswitch = MAX( 0._wp , SIGN( 1._wp, a_i(ji,jj,jl) - epsi20 ) ) !0 if no ice and 1 if yes 164 164 ht_i(ji,jj,jl) = v_i (ji,jj,jl) / MAX( a_i(ji,jj,jl) , epsi20 ) * rswitch 165 END DO 166 END DO 167 END DO 168 ! Force the upper limit of ht_i to always be < hi_max (99 m). 169 DO jj = 1, jpj 170 DO ji = 1, jpi 171 rswitch = MAX( 0._wp , SIGN( 1._wp, ht_i(ji,jj,jpl) - epsi20 ) ) 172 ht_i(ji,jj,jpl) = MIN( ht_i(ji,jj,jpl) , hi_max(jpl) ) 173 a_i (ji,jj,jpl) = v_i(ji,jj,jpl) / MAX( ht_i(ji,jj,jpl) , epsi20 ) * rswitch 174 END DO 175 END DO 176 177 DO jl = 1, jpl 178 DO jj = 1, jpj 179 DO ji = 1, jpi 180 rswitch = MAX( 0._wp , SIGN( 1._wp, a_i(ji,jj,jl) - epsi20 ) ) !0 if no ice and 1 if yes 165 181 ht_s(ji,jj,jl) = v_s (ji,jj,jl) / MAX( a_i(ji,jj,jl) , epsi20 ) * rswitch 166 182 o_i(ji,jj,jl) = oa_i(ji,jj,jl) / MAX( a_i(ji,jj,jl) , epsi20 ) * rswitch … … 168 184 END DO 169 185 END DO 170 186 171 187 IF( nn_icesal == 2 )THEN 172 188 DO jl = 1, jpl … … 298 314 ! Vertically constant, constant in time 299 315 !--------------------------------------- 300 IF( nn_icesal == 1 ) s_i(:,:,:,:) = rn_icesal 316 IF( nn_icesal == 1 ) THEN 317 s_i (:,:,:,:) = rn_icesal 318 sm_i(:,:,:) = rn_icesal 319 ENDIF 301 320 302 321 !----------------------------------- -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/LIM_SRC_3/limwri.F90
r6836 r6839 157 157 ENDIF 158 158 159 IF ( iom_use( "icecolf" ) ) THEN 160 DO jj = 1, jpj 161 DO ji = 1, jpi 162 rswitch = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) ) ) 163 z2d(ji,jj) = hicol(ji,jj) * rswitch 164 END DO 165 END DO 166 CALL iom_put( "icecolf" , z2d ) ! frazil ice collection thickness 167 ENDIF 159 IF ( iom_use( "icecolf" ) ) CALL iom_put( "icecolf", hicol ) ! frazil ice collection thickness 168 160 169 161 CALL iom_put( "isst" , sst_m ) ! sea surface temperature … … 190 182 CALL iom_put( "destrp" , diag_trp_es ) ! advected snw enthalpy (W/m2) 191 183 192 CALL iom_put( "sfxbog" , sfx_bog * rday ) ! salt flux from b rines193 CALL iom_put( "sfxbom" , sfx_bom * rday ) ! salt flux from b rines194 CALL iom_put( "sfxsum" , sfx_sum * rday ) ! salt flux from brines195 CALL iom_put( "sfxsni" , sfx_sni * rday ) ! salt flux from brines196 CALL iom_put( "sfxopw" , sfx_opw * rday ) ! salt flux from brines184 CALL iom_put( "sfxbog" , sfx_bog * rday ) ! salt flux from bottom growth 185 CALL iom_put( "sfxbom" , sfx_bom * rday ) ! salt flux from bottom melt 186 CALL iom_put( "sfxsum" , sfx_sum * rday ) ! salt flux from surface melt 187 CALL iom_put( "sfxsni" , sfx_sni * rday ) ! salt flux from snow ice formation 188 CALL iom_put( "sfxopw" , sfx_opw * rday ) ! salt flux from open water formation 197 189 CALL iom_put( "sfxdyn" , sfx_dyn * rday ) ! salt flux from ridging rafting 198 CALL iom_put( "sfxres" , sfx_res * rday ) ! salt flux from limupdate (resultant)190 CALL iom_put( "sfxres" , sfx_res * rday ) ! salt flux from residual 199 191 CALL iom_put( "sfxbri" , sfx_bri * rday ) ! salt flux from brines 192 CALL iom_put( "sfxsub" , sfx_sub * rday ) ! salt flux from sublimation 200 193 CALL iom_put( "sfx" , sfx * rday ) ! total salt flux 201 194 … … 235 228 CALL iom_put ('hfxdhc' , diag_heat(:,:) ) ! Heat content variation in snow and ice 236 229 CALL iom_put ('hfxspr' , hfx_spr(:,:) ) ! Heat content of snow precip 230 231 232 IF ( iom_use( "vfxthin" ) ) THEN ! ice production for open water + thin ice (<20cm) => comparable to observations 233 DO jj = 1, jpj 234 DO ji = 1, jpi 235 z2d(ji,jj) = vt_i(ji,jj) / MAX( at_i(ji,jj), epsi06 ) * zswi(ji,jj) ! mean ice thickness 236 END DO 237 END DO 238 WHERE( z2d(:,:) < 0.2 .AND. z2d(:,:) > 0. ) ; z2da = wfx_bog 239 ELSEWHERE ; z2da = 0._wp 240 END WHERE 241 CALL iom_put( "vfxthin", ( wfx_opw + z2da ) * ztmp ) 242 ENDIF 237 243 238 244 !-------------------------------- … … 311 317 !! 312 318 !! History : 313 !! 4. 1! 2013-06 (C. Rousset)319 !! 4.0 ! 2013-06 (C. Rousset) 314 320 !!---------------------------------------------------------------------- 315 321 INTEGER, INTENT( in ) :: kt ! ocean time-step index) -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/LIM_SRC_3/thd_ice.F90
r6836 r6839 45 45 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: qns_ice_1d 46 46 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: t_bo_1d 47 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: rn_amax_1d 47 48 48 49 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: hfx_sum_1d … … 83 84 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: sfx_res_1d 84 85 86 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: sfx_sub_1d 87 85 88 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: sprecip_1d !: <==> the 2D sprecip 86 89 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: frld_1d !: <==> the 2D frld … … 91 94 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: evap_ice_1d !: <==> the 2D evap_ice 92 95 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: qprec_ice_1d !: <==> the 2D qprec_ice 96 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: qevap_ice_1d !: <==> the 3D qevap_ice 93 97 ! ! to reintegrate longwave flux inside the ice thermodynamics 94 98 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: i0 !: fraction of radiation transmitted to the ice … … 107 111 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: dh_s_tot !: Snow accretion/ablation [m] 108 112 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: dh_i_surf !: Ice surface accretion/ablation [m] 113 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: dh_i_sub !: Ice surface sublimation [m] 109 114 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: dh_i_bott !: Ice bottom accretion/ablation [m] 110 115 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: dh_snowice !: Snow ice formation [m of ice] … … 144 149 & hfx_sum_1d(jpij) , hfx_bom_1d(jpij) ,hfx_bog_1d(jpij) , & 145 150 & hfx_dif_1d(jpij) , hfx_opw_1d(jpij) , & 151 & rn_amax_1d(jpij) , & 146 152 & hfx_thd_1d(jpij) , hfx_spr_1d(jpij) , & 147 153 & hfx_snw_1d(jpij) , hfx_sub_1d(jpij) , hfx_err_1d(jpij) , & … … 153 159 & wfx_sum_1d(jpij) , wfx_sni_1d (jpij) , wfx_opw_1d (jpij) , wfx_res_1d(jpij) , & 154 160 & dqns_ice_1d(jpij) , evap_ice_1d (jpij), & 155 & qprec_ice_1d(jpij), i0 (jpij) ,&161 & qprec_ice_1d(jpij), qevap_ice_1d(jpij), i0 (jpij) , & 156 162 & sfx_bri_1d (jpij) , sfx_bog_1d (jpij) , sfx_bom_1d (jpij) , sfx_sum_1d (jpij), & 157 & sfx_sni_1d (jpij) , sfx_opw_1d (jpij) , sfx_res_1d (jpij) , 163 & sfx_sni_1d (jpij) , sfx_opw_1d (jpij) , sfx_res_1d (jpij) , sfx_sub_1d (jpij), & 158 164 & dsm_i_fl_1d(jpij) , dsm_i_gd_1d(jpij) , dsm_i_se_1d(jpij) , & 159 165 & dsm_i_si_1d(jpij) , hicol_1d (jpij) , STAT=ierr(2) ) … … 161 167 ALLOCATE( t_su_1d (jpij) , a_i_1d (jpij) , ht_i_1d (jpij) , & 162 168 & ht_s_1d (jpij) , fc_su (jpij) , fc_bo_i (jpij) , & 163 & dh_s_tot (jpij) , dh_i_surf(jpij) , dh_i_ bott(jpij) , &164 & dh_ snowice(jpij) , sm_i_1d (jpij) , s_i_new (jpij) , &169 & dh_s_tot (jpij) , dh_i_surf(jpij) , dh_i_sub (jpij) , & 170 & dh_i_bott (jpij) ,dh_snowice(jpij) , sm_i_1d (jpij) , s_i_new (jpij) , & 165 171 & t_s_1d(jpij,nlay_s) , t_i_1d(jpij,nlay_i) , s_i_1d(jpij,nlay_i) , & 166 172 & q_i_1d(jpij,nlay_i+1) , q_s_1d(jpij,nlay_s) , & -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/NST_SRC/agrif2model.F90
r6836 r6839 1 1 #if defined key_agrif 2 3 !! NEMO/NST 3.3, NEMO Consortium (2010)4 5 6 7 8 9 10 11 2 !!---------------------------------------------------------------------- 3 !! NEMO/NST 3.6 , NEMO Consortium (2010) 4 !! $Id$ 5 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 6 !!---------------------------------------------------------------------- 7 SUBROUTINE Agrif2Model 8 !!--------------------------------------------- 9 !! *** ROUTINE Agrif2Model *** 10 !!--------------------------------------------- 11 END SUBROUTINE Agrif2model 12 12 13 14 15 16 17 USE Agrif_Types18 13 SUBROUTINE Agrif_Set_numberofcells(Agrif_Gr) 14 !!--------------------------------------------- 15 !! *** ROUTINE Agrif_Set_numberofcells *** 16 !!--------------------------------------------- 17 USE Agrif_Grids 18 IMPLICIT NONE 19 19 20 Type(Agrif_Grid), Pointer:: Agrif_Gr20 TYPE(Agrif_Grid), POINTER :: Agrif_Gr 21 21 22 IF ( associated(Agrif_Curgrid) )THEN22 IF ( ASSOCIATED(Agrif_Curgrid) )THEN 23 23 #include "SetNumberofcells.h" 24 24 ENDIF 25 25 26 26 END SUBROUTINE Agrif_Set_numberofcells 27 27 28 29 30 31 32 USE Agrif_Types33 28 SUBROUTINE Agrif_Get_numberofcells(Agrif_Gr) 29 !!--------------------------------------------- 30 !! *** ROUTINE Agrif_Get_numberofcells *** 31 !!--------------------------------------------- 32 USE Agrif_Grids 33 IMPLICIT NONE 34 34 35 Type(Agrif_Grid), Pointer:: Agrif_Gr35 TYPE(Agrif_Grid), POINTER :: Agrif_Gr 36 36 37 IF ( ASSOCIATED(Agrif_Curgrid) ) THEN 37 38 #include "GetNumberofcells.h" 39 ENDIF 38 40 39 41 END SUBROUTINE Agrif_Get_numberofcells 40 42 41 42 43 44 45 USE Agrif_Types43 SUBROUTINE Agrif_Allocationcalls(Agrif_Gr) 44 !!--------------------------------------------- 45 !! *** ROUTINE Agrif_Allocationscalls *** 46 !!--------------------------------------------- 47 USE Agrif_Grids 46 48 #include "include_use_Alloc_agrif.h" 47 49 IMPLICIT NONE 48 50 49 Type(Agrif_Grid), Pointer:: Agrif_Gr51 TYPE(Agrif_Grid), POINTER :: Agrif_Gr 50 52 51 53 #include "allocations_calls_agrif.h" 52 54 53 55 END SUBROUTINE Agrif_Allocationcalls 54 56 55 56 57 58 59 60 57 SUBROUTINE Agrif_probdim_modtype_def() 58 !!--------------------------------------------- 59 !! *** ROUTINE Agrif_probdim_modtype_def *** 60 !!--------------------------------------------- 61 USE Agrif_Types 62 IMPLICIT NONE 61 63 62 64 #include "modtype_agrif.h" … … 64 66 #include "keys_agrif.h" 65 67 66 Return68 RETURN 67 69 68 70 END SUBROUTINE Agrif_probdim_modtype_def 69 71 70 SUBROUTINE Agrif_clustering_def() 71 !!--------------------------------------------- 72 !! *** ROUTINE Agrif_clustering_def *** 73 !!--------------------------------------------- 74 Use Agrif_Types 75 IMPLICIT NONE 72 SUBROUTINE Agrif_clustering_def() 73 !!--------------------------------------------- 74 !! *** ROUTINE Agrif_clustering_def *** 75 !!--------------------------------------------- 76 IMPLICIT NONE 76 77 77 Return78 RETURN 78 79 79 80 END SUBROUTINE Agrif_clustering_def 80 81 81 SUBROUTINE Agrif_comm_def(modelcomm) 82 83 !!--------------------------------------------- 84 !! *** ROUTINE Agrif_clustering_def *** 85 !!--------------------------------------------- 86 Use Agrif_Types 87 Use lib_mpp 88 89 IMPLICIT NONE 90 91 INTEGER :: modelcomm 92 93 #if defined key_mpp_mpi 94 modelcomm = mpi_comm_opa 82 #else 83 SUBROUTINE Agrif2Model 84 !!--------------------------------------------- 85 !! *** ROUTINE Agrif2Model *** 86 !!--------------------------------------------- 87 WRITE(*,*) 'Impossible to bet here' 88 END SUBROUTINE Agrif2model 95 89 #endif 96 Return97 98 END SUBROUTINE Agrif_comm_def99 #else100 SUBROUTINE Agrif2Model101 !!---------------------------------------------102 !! *** ROUTINE Agrif2Model ***103 !!---------------------------------------------104 WRITE(*,*) 'Impossible to bet here'105 END SUBROUTINE Agrif2model106 #endif -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/NST_SRC/agrif_lim2_interp.F90
r6836 r6839 9 9 !! 3.4 ! 09-2012 (R. Benshila, C. Herbaut) update and EVP 10 10 !!---------------------------------------------------------------------- 11 #if defined key_agrif && defined key_lim2 11 #if defined key_agrif && defined key_lim2 12 12 !!---------------------------------------------------------------------- 13 13 !! 'key_lim2' : LIM 2.0 sea-ice model … … 41 41 PUBLIC interp_adv_ice 42 42 43 REAL(wp), DIMENSION(:,:) , ALLOCATABLE, PRIVATE :: uice_agr, vice_agr 44 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, PRIVATE :: tabice_agr 45 46 43 47 !!---------------------------------------------------------------------- 44 48 !! NEMO/NST 3.4 , NEMO Consortium (2012) … … 65 69 u_ice_nst(:,:) = 0. 66 70 v_ice_nst(:,:) = 0. 67 CALL Agrif_Bc_variable( u_ice_ nst, u_ice_id ,procname=interp_u_ice, calledweight=1. )68 CALL Agrif_Bc_variable( v_ice_ nst, v_ice_id ,procname=interp_v_ice, calledweight=1. )71 CALL Agrif_Bc_variable( u_ice_id ,procname=interp_u_ice, calledweight=1. ) 72 CALL Agrif_Bc_variable( v_ice_id ,procname=interp_v_ice, calledweight=1. ) 69 73 Agrif_SpecialValue=0. 70 74 Agrif_UseSpecialValue = .FALSE. … … 138 142 !! we are in inside a new parent ice time step 139 143 !!----------------------------------------------------------------------- 140 REAL(wp), DIMENSION(jpi,jpj) :: zuice, zvice141 144 INTEGER :: ji,jj 142 145 REAL(wp) :: zrhox, zrhoy … … 155 158 Agrif_SpecialValue=-9999. 156 159 Agrif_UseSpecialValue = .TRUE. 157 zuice = 0. 158 zvice = 0. 159 CALL Agrif_Bc_variable(zuice,u_ice_id,procname=interp_u_ice, calledweight=1.) 160 CALL Agrif_Bc_variable(zvice,v_ice_id,procname=interp_v_ice, calledweight=1.) 160 IF( .NOT. ALLOCATED(uice_agr) )THEN 161 ALLOCATE(uice_agr(jpi,jpj), vice_agr(jpi,jpj)) 162 ENDIF 163 uice_agr = 0. 164 vice_agr = 0. 165 CALL Agrif_Bc_variable(u_ice_id,procname=interp_u_ice, calledweight=1.) 166 CALL Agrif_Bc_variable(v_ice_id,procname=interp_v_ice, calledweight=1.) 161 167 Agrif_SpecialValue=0. 162 168 Agrif_UseSpecialValue = .FALSE. 163 169 ! 164 170 zrhox = agrif_rhox() ; zrhoy = agrif_rhoy() 165 zuice(:,:) = zuice(:,:)/(zrhoy*e2u(:,:))*umask(:,:,1)166 zvice(:,:) = zvice(:,:)/(zrhox*e1v(:,:))*vmask(:,:,1)171 uice_agr(:,:) = uice_agr(:,:)/(zrhoy*e2u(:,:))*umask(:,:,1) 172 vice_agr(:,:) = vice_agr(:,:)/(zrhox*e1v(:,:))*vmask(:,:,1) 167 173 ! fill boundaries 168 174 DO jj = 1, jpj 169 175 DO ji = 1, 2 170 u_ice_oe(ji, jj,2) = zuice(ji ,jj)171 u_ice_oe(ji+2,jj,2) = zuice(nlci+ji-3,jj)176 u_ice_oe(ji, jj,2) = uice_agr(ji ,jj) 177 u_ice_oe(ji+2,jj,2) = uice_agr(nlci+ji-3,jj) 172 178 END DO 173 179 END DO 174 180 DO jj = 1, jpj 175 v_ice_oe(2,jj,2) = zvice(2 ,jj)176 v_ice_oe(4,jj,2) = zvice(nlci-1,jj)181 v_ice_oe(2,jj,2) = vice_agr(2 ,jj) 182 v_ice_oe(4,jj,2) = vice_agr(nlci-1,jj) 177 183 END DO 178 184 DO ji = 1, jpi 179 u_ice_sn(ji,2,2) = zuice(ji,2 )180 u_ice_sn(ji,4,2) = zuice(ji,nlcj-1)185 u_ice_sn(ji,2,2) = uice_agr(ji,2 ) 186 u_ice_sn(ji,4,2) = uice_agr(ji,nlcj-1) 181 187 END DO 182 188 DO jj = 1, 2 183 189 DO ji = 1, jpi 184 v_ice_sn(ji,jj ,2) = zvice(ji,jj )185 v_ice_sn(ji,jj+2,2) = zvice(ji,nlcj+jj-3)190 v_ice_sn(ji,jj ,2) = vice_agr(ji,jj ) 191 v_ice_sn(ji,jj+2,2) = vice_agr(ji,nlcj+jj-3) 186 192 END DO 187 193 END DO … … 334 340 !! we are in inside a new parent ice time step 335 341 !!----------------------------------------------------------------------- 336 REAL(wp), DIMENSION(jpi,jpj,7) :: ztab337 342 INTEGER :: ji,jj,jn 338 343 !!----------------------------------------------------------------------- … … 345 350 adv_ice_sn(:,:,:,1) = adv_ice_sn(:,:,:,2) 346 351 ! interpolation of boundaries 347 ztab(:,:,:) = 0. 352 IF(.NOT.ALLOCATED(tabice_agr))THEN 353 ALLOCATE(tabice_agr(jpi,jpj,7)) 354 ENDIF 355 tabice_agr(:,:,:) = 0. 348 356 Agrif_SpecialValue=-9999. 349 357 Agrif_UseSpecialValue = .TRUE. 350 CALL Agrif_Bc_variable( ztab,adv_ice_id ,procname=interp_adv_ice,calledweight=1. )358 CALL Agrif_Bc_variable( adv_ice_id ,procname=interp_adv_ice,calledweight=1. ) 351 359 Agrif_SpecialValue=0. 352 360 Agrif_UseSpecialValue = .FALSE. … … 356 364 DO jj = 1, jpj 357 365 DO ji=1,2 358 adv_ice_oe(ji ,jj,jn,2) = ztab(ji ,jj,jn)359 adv_ice_oe(ji+2,jj,jn,2) = ztab(nlci-2+ji,jj,jn)366 adv_ice_oe(ji ,jj,jn,2) = tabice_agr(ji ,jj,jn) 367 adv_ice_oe(ji+2,jj,jn,2) = tabice_agr(nlci-2+ji,jj,jn) 360 368 END DO 361 369 END DO … … 365 373 Do jj =1,2 366 374 DO ji = 1, jpi 367 adv_ice_sn(ji,jj ,jn,2) = ztab(ji,jj ,jn)368 adv_ice_sn(ji,jj+2,jn,2) = ztab(ji,nlcj-2+jj,jn)375 adv_ice_sn(ji,jj ,jn,2) = tabice_agr(ji,jj ,jn) 376 adv_ice_sn(ji,jj+2,jn,2) = tabice_agr(ji,nlcj-2+jj,jn) 369 377 END DO 370 378 END DO … … 384 392 INTEGER :: ji,jj,jn 385 393 REAL(wp) :: zalpha 386 REAL(wp), DIMENSION(jpi,jpj,7) :: ztab394 REAL(wp), DIMENSION(jpi,jpj,7) :: tabice_agr 387 395 !!----------------------------------------------------------------------- 388 396 ! … … 391 399 zalpha = REAL(lim_nbstep,wp) / (Agrif_Rhot()*Agrif_PArent(nn_fsbc)/REAL(nn_fsbc)) 392 400 ! 393 ztab(:,:,:) = 0.e0401 tabice_agr(:,:,:) = 0.e0 394 402 DO jn =1,7 395 403 DO jj =1,2 396 404 DO ji = 1, jpi 397 ztab(ji,jj ,jn) = (1-zalpha)*adv_ice_sn(ji,jj ,jn,1) + zalpha*adv_ice_sn(ji,jj ,jn,2)398 ztab(ji,nlcj-2+jj ,jn) = (1-zalpha)*adv_ice_sn(ji,jj+2,jn,1) + zalpha*adv_ice_sn(ji,jj+2,jn,2)405 tabice_agr(ji,jj ,jn) = (1-zalpha)*adv_ice_sn(ji,jj ,jn,1) + zalpha*adv_ice_sn(ji,jj ,jn,2) 406 tabice_agr(ji,nlcj-2+jj ,jn) = (1-zalpha)*adv_ice_sn(ji,jj+2,jn,1) + zalpha*adv_ice_sn(ji,jj+2,jn,2) 399 407 END DO 400 408 END DO … … 404 412 DO jj = 1, jpj 405 413 DO ji=1,2 406 ztab(ji ,jj,jn) = (1-zalpha)*adv_ice_oe(ji ,jj,jn,1) + zalpha*adv_ice_oe(ji ,jj,jn,2)407 ztab(nlci-2+ji,jj,jn) = (1-zalpha)*adv_ice_oe(ji+2,jj,jn,1) + zalpha*adv_ice_oe(ji+2,jj,jn,2)414 tabice_agr(ji ,jj,jn) = (1-zalpha)*adv_ice_oe(ji ,jj,jn,1) + zalpha*adv_ice_oe(ji ,jj,jn,2) 415 tabice_agr(nlci-2+ji,jj,jn) = (1-zalpha)*adv_ice_oe(ji+2,jj,jn,1) + zalpha*adv_ice_oe(ji+2,jj,jn,2) 408 416 END DO 409 417 END DO 410 418 END DO 411 419 ! 412 CALL parcoursT( ztab(:,:, 1), frld )413 CALL parcoursT( ztab(:,:, 2), hicif )414 CALL parcoursT( ztab(:,:, 3), hsnif )415 CALL parcoursT( ztab(:,:, 4), tbif(:,:,1) )416 CALL parcoursT( ztab(:,:, 5), tbif(:,:,2) )417 CALL parcoursT( ztab(:,:, 6), tbif(:,:,3) )418 CALL parcoursT( ztab(:,:, 7), qstoif )420 CALL parcoursT( tabice_agr(:,:, 1), frld ) 421 CALL parcoursT( tabice_agr(:,:, 2), hicif ) 422 CALL parcoursT( tabice_agr(:,:, 3), hsnif ) 423 CALL parcoursT( tabice_agr(:,:, 4), tbif(:,:,1) ) 424 CALL parcoursT( tabice_agr(:,:, 5), tbif(:,:,2) ) 425 CALL parcoursT( tabice_agr(:,:, 6), tbif(:,:,3) ) 426 CALL parcoursT( tabice_agr(:,:, 7), qstoif ) 419 427 ! 420 428 END SUBROUTINE agrif_trp_lim2 … … 499 507 500 508 501 SUBROUTINE interp_u_ice( tabres, i1, i2, j1, j2 )509 SUBROUTINE interp_u_ice( tabres, i1, i2, j1, j2, before ) 502 510 !!----------------------------------------------------------------------- 503 511 !! *** ROUTINE interp_u_ice *** … … 505 513 INTEGER, INTENT(in) :: i1, i2, j1, j2 506 514 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 515 LOGICAL, INTENT(in) :: before 507 516 !! 508 517 INTEGER :: ji,jj … … 510 519 ! 511 520 #if defined key_lim2_vp 512 DO jj=MAX(j1,2),j2 513 DO ji=MAX(i1,2),i2 514 IF( tmu(ji,jj) == 0. ) THEN 515 tabres(ji,jj) = -9999. 516 ELSE 517 tabres(ji,jj) = e2f(ji-1,jj-1) * u_ice(ji,jj) 518 ENDIF 519 END DO 520 END DO 521 IF( before ) THEN 522 DO jj=MAX(j1,2),j2 523 DO ji=MAX(i1,2),i2 524 IF( tmu(ji,jj) == 0. ) THEN 525 tabres(ji,jj) = -9999. 526 ELSE 527 tabres(ji,jj) = e2f(ji-1,jj-1) * u_ice(ji,jj) 528 ENDIF 529 END DO 530 END DO 531 ENDIF 521 532 #else 522 DO jj= j1, j2 523 DO ji= i1, i2 524 IF( umask(ji,jj,1) == 0. ) THEN 525 tabres(ji,jj) = -9999. 526 ELSE 527 tabres(ji,jj) = e2u(ji,jj) * u_ice(ji,jj) 528 ENDIF 529 END DO 530 END DO 533 IF( before ) THEN 534 DO jj= j1, j2 535 DO ji= i1, i2 536 IF( umask(ji,jj,1) == 0. ) THEN 537 tabres(ji,jj) = -9999. 538 ELSE 539 tabres(ji,jj) = e2u(ji,jj) * u_ice(ji,jj) 540 ENDIF 541 END DO 542 END DO 543 ENDIF 531 544 #endif 532 545 END SUBROUTINE interp_u_ice 533 546 534 547 535 SUBROUTINE interp_v_ice( tabres, i1, i2, j1, j2 )548 SUBROUTINE interp_v_ice( tabres, i1, i2, j1, j2, before ) 536 549 !!----------------------------------------------------------------------- 537 550 !! *** ROUTINE interp_v_ice *** … … 539 552 INTEGER, INTENT(in) :: i1, i2, j1, j2 540 553 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 554 LOGICAL, INTENT(in) :: before 541 555 !! 542 556 INTEGER :: ji, jj … … 544 558 ! 545 559 #if defined key_lim2_vp 546 DO jj=MAX(j1,2),j2 547 DO ji=MAX(i1,2),i2 548 IF( tmu(ji,jj) == 0. ) THEN 549 tabres(ji,jj) = -9999. 550 ELSE 551 tabres(ji,jj) = e1f(ji-1,jj-1) * v_ice(ji,jj) 552 ENDIF 553 END DO 554 END DO 560 IF( before ) THEN 561 DO jj=MAX(j1,2),j2 562 DO ji=MAX(i1,2),i2 563 IF( tmu(ji,jj) == 0. ) THEN 564 tabres(ji,jj) = -9999. 565 ELSE 566 tabres(ji,jj) = e1f(ji-1,jj-1) * v_ice(ji,jj) 567 ENDIF 568 END DO 569 END DO 570 ENDIF 555 571 #else 556 DO jj= j1 ,j2 557 DO ji = i1, i2 558 IF( vmask(ji,jj,1) == 0. ) THEN 559 tabres(ji,jj) = -9999. 560 ELSE 561 tabres(ji,jj) = e1v(ji,jj) * v_ice(ji,jj) 562 ENDIF 563 END DO 564 END DO 572 IF( before ) THEN 573 DO jj= j1 ,j2 574 DO ji = i1, i2 575 IF( vmask(ji,jj,1) == 0. ) THEN 576 tabres(ji,jj) = -9999. 577 ELSE 578 tabres(ji,jj) = e1v(ji,jj) * v_ice(ji,jj) 579 ENDIF 580 END DO 581 END DO 582 ENDIF 565 583 #endif 566 584 END SUBROUTINE interp_v_ice 567 585 568 586 569 SUBROUTINE interp_adv_ice( tabres, i1, i2, j1, j2 )587 SUBROUTINE interp_adv_ice( tabres, i1, i2, j1, j2, before ) 570 588 !!----------------------------------------------------------------------- 571 589 !! *** ROUTINE interp_adv_ice *** … … 577 595 INTEGER, INTENT(in) :: i1, i2, j1, j2 578 596 REAL(wp), DIMENSION(i1:i2,j1:j2,7), INTENT(inout) :: tabres 597 LOGICAL, INTENT(in) :: before 579 598 !! 580 599 INTEGER :: ji, jj, jk 581 600 !!----------------------------------------------------------------------- 582 601 ! 583 DO jj=j1,j2 584 DO ji=i1,i2 585 IF( tms(ji,jj) == 0. ) THEN 586 tabres(ji,jj,:) = -9999. 587 ELSE 588 tabres(ji,jj, 1) = frld (ji,jj) 589 tabres(ji,jj, 2) = hicif (ji,jj) 590 tabres(ji,jj, 3) = hsnif (ji,jj) 591 tabres(ji,jj, 4) = tbif (ji,jj,1) 592 tabres(ji,jj, 5) = tbif (ji,jj,2) 593 tabres(ji,jj, 6) = tbif (ji,jj,3) 594 tabres(ji,jj, 7) = qstoif(ji,jj) 595 ENDIF 596 END DO 597 END DO 602 IF( before ) THEN 603 DO jj=j1,j2 604 DO ji=i1,i2 605 IF( tms(ji,jj) == 0. ) THEN 606 tabres(ji,jj,:) = -9999. 607 ELSE 608 tabres(ji,jj, 1) = frld (ji,jj) 609 tabres(ji,jj, 2) = hicif (ji,jj) 610 tabres(ji,jj, 3) = hsnif (ji,jj) 611 tabres(ji,jj, 4) = tbif (ji,jj,1) 612 tabres(ji,jj, 5) = tbif (ji,jj,2) 613 tabres(ji,jj, 6) = tbif (ji,jj,3) 614 tabres(ji,jj, 7) = qstoif(ji,jj) 615 ENDIF 616 END DO 617 END DO 618 ENDIF 598 619 ! 599 620 END SUBROUTINE interp_adv_ice -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/NST_SRC/agrif_lim2_update.F90
r6836 r6839 52 52 INTEGER, INTENT(in) :: kt 53 53 !! 54 REAL(wp), DIMENSION(jpi,jpj) :: zvel55 REAL(wp), DIMENSION(jpi,jpj,7):: zadv56 54 !!---------------------------------------------------------------------- 57 55 ! … … 60 58 Agrif_UseSpecialValueInUpdate = .TRUE. 61 59 Agrif_SpecialValueFineGrid = 0. 62 63 60 # if defined TWO_WAY 64 61 IF( MOD(nbcline,nbclineupdate) == 0) THEN 65 CALL Agrif_Update_Variable( zadv ,adv_ice_id , procname = update_adv_ice )66 CALL Agrif_Update_Variable( zvel ,u_ice_id , procname = update_u_ice )67 CALL Agrif_Update_Variable( zvel ,v_ice_id , procname = update_v_ice )68 ELSE 69 CALL Agrif_Update_Variable( zadv ,adv_ice_id , locupdate=(/0,2/), procname = update_adv_ice )70 CALL Agrif_Update_Variable( zvel ,u_ice_id , locupdate=(/0,1/), procname = update_u_ice )71 CALL Agrif_Update_Variable( zvel ,v_ice_id , locupdate=(/0,1/), procname = update_v_ice )62 CALL Agrif_Update_Variable( adv_ice_id , procname = update_adv_ice ) 63 CALL Agrif_Update_Variable( u_ice_id , procname = update_u_ice ) 64 CALL Agrif_Update_Variable( v_ice_id , procname = update_v_ice ) 65 ELSE 66 CALL Agrif_Update_Variable( adv_ice_id , locupdate=(/0,2/), procname = update_adv_ice ) 67 CALL Agrif_Update_Variable( u_ice_id , locupdate=(/0,1/), procname = update_u_ice ) 68 CALL Agrif_Update_Variable( v_ice_id , locupdate=(/0,1/), procname = update_v_ice ) 72 69 ENDIF 73 70 # endif -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/NST_SRC/agrif_oce.F90
r6836 r6839 12 12 USE par_oce ! ocean parameters 13 13 USE dom_oce ! domain parameters 14 14 15 15 IMPLICIT NONE 16 16 PRIVATE … … 19 19 20 20 ! !!* Namelist namagrif: AGRIF parameters 21 LOGICAL , PUBLIC :: ln_spc_dyn !: 22 INTEGER , PUBLIC :: nn_cln_update !: update frequency 23 REAL(wp), PUBLIC :: rn_sponge_tra !: sponge coeff. for tracers 24 REAL(wp), PUBLIC :: rn_sponge_dyn !: sponge coeff. for dynamics 21 LOGICAL , PUBLIC :: ln_spc_dyn = .FALSE. !: 22 INTEGER , PUBLIC :: nn_cln_update = 3 !: update frequency 23 INTEGER , PUBLIC, PARAMETER :: nn_sponge_len = 2 !: Sponge width (in number of parent grid points) 24 REAL(wp), PUBLIC :: rn_sponge_tra = 2800. !: sponge coeff. for tracers 25 REAL(wp), PUBLIC :: rn_sponge_dyn = 2800. !: sponge coeff. for dynamics 26 LOGICAL , PUBLIC :: ln_chk_bathy = .FALSE. !: check of parent bathymetry 25 27 26 28 ! !!! OLD namelist names … … 30 32 REAL(wp), PUBLIC :: visc_dyn !: sponge coeff. for dynamics 31 33 32 LOGICAL , PUBLIC :: spongedoneT = .FALSE. !: tracer sponge layer indicator 33 LOGICAL , PUBLIC :: spongedoneU = .FALSE. !: dynamics sponge layer indicator 34 LOGICAL , PUBLIC :: lk_agrif_fstep = .TRUE. !: if true: first step 34 LOGICAL , PUBLIC :: spongedoneT = .FALSE. !: tracer sponge layer indicator 35 LOGICAL , PUBLIC :: spongedoneU = .FALSE. !: dynamics sponge layer indicator 36 LOGICAL , PUBLIC :: lk_agrif_fstep = .TRUE. !: if true: first step 37 LOGICAL , PUBLIC :: lk_agrif_doupd = .TRUE. !: if true: send update from current grid 38 LOGICAL , PUBLIC :: lk_agrif_debug = .FALSE. !: if true: print debugging info 35 39 36 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: spe1ur , spe2vr , spbtr2 !: ??? 37 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: spe1ur2, spe2vr2, spbtr3 !: ??? 38 39 INTEGER :: tsn_id,tsb_id,tsa_id 40 INTEGER :: un_id, vn_id, ua_id, va_id 41 INTEGER :: e1u_id, e2v_id, sshn_id, gcb_id 42 INTEGER :: trn_id, trb_id, tra_id 43 INTEGER :: unb_id, vnb_id, ub2b_id, vb2b_id 40 LOGICAL , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tabspongedone_tsn 41 # if defined key_top 42 LOGICAL , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tabspongedone_trn 43 # endif 44 LOGICAL , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tabspongedone_u 45 LOGICAL , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tabspongedone_v 46 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fsaht_spu, fsaht_spv !: sponge diffusivities 47 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fsahm_spt, fsahm_spf !: sponge viscosities 48 49 ! Barotropic arrays used to store open boundary data during 50 ! time-splitting loop: 51 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) :: ubdy_w, vbdy_w, hbdy_w 52 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) :: ubdy_e, vbdy_e, hbdy_e 53 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) :: ubdy_n, vbdy_n, hbdy_n 54 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) :: ubdy_s, vbdy_s, hbdy_s 55 56 INTEGER :: tsn_id ! AGRIF profile for tracers interpolation and update 57 INTEGER :: un_interp_id, vn_interp_id ! AGRIF profiles for interpolations 58 INTEGER :: un_update_id, vn_update_id ! AGRIF profiles for udpates 59 INTEGER :: tsn_sponge_id, un_sponge_id, vn_sponge_id ! AGRIF profiles for sponge layers 60 # if defined key_top 61 INTEGER :: trn_id, trn_sponge_id 62 # endif 63 INTEGER :: unb_id, vnb_id, ub2b_interp_id, vb2b_interp_id 64 INTEGER :: ub2b_update_id, vb2b_update_id 65 INTEGER :: e3t_id, e1u_id, e2v_id, sshn_id 66 INTEGER :: scales_t_id 67 # if defined key_zdftke 68 INTEGER :: avt_id, avm_id, en_id 69 # endif 70 INTEGER :: umsk_id, vmsk_id 71 INTEGER :: kindic_agr 44 72 45 73 !!---------------------------------------------------------------------- … … 54 82 !! *** FUNCTION agrif_oce_alloc *** 55 83 !!---------------------------------------------------------------------- 56 ALLOCATE( spe1ur (jpi,jpj) , spe2vr (jpi,jpj) , spbtr2(jpi,jpj) , & 57 & spe1ur2(jpi,jpj) , spe2vr2(jpi,jpj) , spbtr3(jpi,jpj) , STAT = agrif_oce_alloc ) 84 INTEGER, DIMENSION(2) :: ierr 85 !!---------------------------------------------------------------------- 86 ierr(:) = 0 87 ! 88 ALLOCATE( fsaht_spu(jpi,jpj), fsaht_spv(jpi,jpj), & 89 & fsahm_spt(jpi,jpj), fsahm_spf(jpi,jpj), & 90 & tabspongedone_tsn(jpi,jpj), & 91 # if defined key_top 92 & tabspongedone_trn(jpi,jpj), & 93 # endif 94 & tabspongedone_u (jpi,jpj), & 95 & tabspongedone_v (jpi,jpj), STAT = ierr(1) ) 96 97 ALLOCATE( ubdy_w(jpj), vbdy_w(jpj), hbdy_w(jpj), & 98 & ubdy_e(jpj), vbdy_e(jpj), hbdy_e(jpj), & 99 & ubdy_n(jpi), vbdy_n(jpi), hbdy_n(jpi), & 100 & ubdy_s(jpi), vbdy_s(jpi), hbdy_s(jpi), STAT = ierr(2) ) 101 102 agrif_oce_alloc = MAXVAL(ierr) 103 ! 58 104 END FUNCTION agrif_oce_alloc 59 105 -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/NST_SRC/agrif_opa_interp.F90
r6836 r6839 7 7 !! - ! 2005-11 (XXX) 8 8 !! 3.2 ! 2009-04 (R. Benshila) 9 !! 3.6 ! 2014-09 (R. Benshila) 9 10 !!---------------------------------------------------------------------- 10 11 #if defined key_agrif && ! defined key_offline … … 29 30 USE wrk_nemo 30 31 USE dynspg_oce 31 32 USE zdf_oce 33 32 34 IMPLICIT NONE 33 35 PRIVATE 34 36 35 ! Barotropic arrays used to store open boundary data during 36 ! time-splitting loop: 37 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) :: ubdy_w, vbdy_w, hbdy_w 38 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) :: ubdy_e, vbdy_e, hbdy_e 39 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) :: ubdy_n, vbdy_n, hbdy_n 40 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) :: ubdy_s, vbdy_s, hbdy_s 41 37 INTEGER :: bdy_tinterp = 0 38 42 39 PUBLIC Agrif_tra, Agrif_dyn, Agrif_ssh, Agrif_dyn_ts, Agrif_ssh_ts, Agrif_dta_ts 43 PUBLIC interpu, interpv, interpunb, interpvnb, interpsshn 40 PUBLIC interpun, interpvn, interpun2d, interpvn2d 41 PUBLIC interptsn, interpsshn 42 PUBLIC interpunb, interpvnb, interpub2b, interpvb2b 43 PUBLIC interpe3t, interpumsk, interpvmsk 44 # if defined key_zdftke 45 PUBLIC Agrif_tke, interpavm 46 # endif 44 47 45 48 # include "domzgr_substitute.h90" 46 49 # include "vectopt_loop_substitute.h90" 47 50 !!---------------------------------------------------------------------- 48 !! NEMO/NST 3. 3, NEMO Consortium (2010)51 !! NEMO/NST 3.6 , NEMO Consortium (2010) 49 52 !! $Id$ 50 53 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 51 54 !!---------------------------------------------------------------------- 52 55 53 54 56 CONTAINS 57 55 58 SUBROUTINE Agrif_tra 56 59 !!---------------------------------------------------------------------- 57 !! *** ROUTINE Agrif_Tra *** 58 !!---------------------------------------------------------------------- 59 !! 60 INTEGER :: ji, jj, jk, jn ! dummy loop indices 61 REAL(wp) :: zrhox , alpha1, alpha2, alpha3 62 REAL(wp) :: alpha4, alpha5, alpha6, alpha7 63 REAL(wp), POINTER, DIMENSION(:,:,:,:) :: ztsa 60 !! *** ROUTINE Agrif_tra *** 64 61 !!---------------------------------------------------------------------- 65 62 ! 66 63 IF( Agrif_Root() ) RETURN 67 68 CALL wrk_alloc( jpi, jpj, jpk, jpts, ztsa )69 64 70 65 Agrif_SpecialValue = 0.e0 71 66 Agrif_UseSpecialValue = .TRUE. 72 ztsa(:,:,:,:) = 0.e0 73 74 CALL Agrif_Bc_variable( ztsa, tsn_id, procname=interptsn ) 67 68 CALL Agrif_Bc_variable( tsn_id, procname=interptsn ) 75 69 Agrif_UseSpecialValue = .FALSE. 76 77 zrhox = Agrif_Rhox()78 79 alpha1 = ( zrhox - 1. ) * 0.580 alpha2 = 1. - alpha181 82 alpha3 = ( zrhox - 1. ) / ( zrhox + 1. )83 alpha4 = 1. - alpha384 85 alpha6 = 2. * ( zrhox - 1. ) / ( zrhox + 1. )86 alpha7 = - ( zrhox - 1. ) / ( zrhox + 3. )87 alpha5 = 1. - alpha6 - alpha788 89 IF( nbondi == 1 .OR. nbondi == 2 ) THEN90 91 DO jn = 1, jpts92 tsa(nlci,:,:,jn) = alpha1 * ztsa(nlci,:,:,jn) + alpha2 * ztsa(nlci-1,:,:,jn)93 DO jk = 1, jpkm194 DO jj = 1, jpj95 IF( umask(nlci-2,jj,jk) == 0.e0 ) THEN96 tsa(nlci-1,jj,jk,jn) = tsa(nlci,jj,jk,jn) * tmask(nlci-1,jj,jk)97 ELSE98 tsa(nlci-1,jj,jk,jn)=(alpha4*tsa(nlci,jj,jk,jn)+alpha3*tsa(nlci-2,jj,jk,jn))*tmask(nlci-1,jj,jk)99 IF( un(nlci-2,jj,jk) > 0.e0 ) THEN100 tsa(nlci-1,jj,jk,jn)=( alpha6*tsa(nlci-2,jj,jk,jn)+alpha5*tsa(nlci,jj,jk,jn) &101 & + alpha7*tsa(nlci-3,jj,jk,jn) ) * tmask(nlci-1,jj,jk)102 ENDIF103 ENDIF104 END DO105 END DO106 ENDDO107 ENDIF108 109 IF( nbondj == 1 .OR. nbondj == 2 ) THEN110 111 DO jn = 1, jpts112 tsa(:,nlcj,:,jn) = alpha1 * ztsa(:,nlcj,:,jn) + alpha2 * ztsa(:,nlcj-1,:,jn)113 DO jk = 1, jpkm1114 DO ji = 1, jpi115 IF( vmask(ji,nlcj-2,jk) == 0.e0 ) THEN116 tsa(ji,nlcj-1,jk,jn) = tsa(ji,nlcj,jk,jn) * tmask(ji,nlcj-1,jk)117 ELSE118 tsa(ji,nlcj-1,jk,jn)=(alpha4*tsa(ji,nlcj,jk,jn)+alpha3*tsa(ji,nlcj-2,jk,jn))*tmask(ji,nlcj-1,jk)119 IF (vn(ji,nlcj-2,jk) > 0.e0 ) THEN120 tsa(ji,nlcj-1,jk,jn)=( alpha6*tsa(ji,nlcj-2,jk,jn)+alpha5*tsa(ji,nlcj,jk,jn) &121 & + alpha7*tsa(ji,nlcj-3,jk,jn) ) * tmask(ji,nlcj-1,jk)122 ENDIF123 ENDIF124 END DO125 END DO126 ENDDO127 ENDIF128 129 IF( nbondi == -1 .OR. nbondi == 2 ) THEN130 DO jn = 1, jpts131 tsa(1,:,:,jn) = alpha1 * ztsa(1,:,:,jn) + alpha2 * ztsa(2,:,:,jn)132 DO jk = 1, jpkm1133 DO jj = 1, jpj134 IF( umask(2,jj,jk) == 0.e0 ) THEN135 tsa(2,jj,jk,jn) = tsa(1,jj,jk,jn) * tmask(2,jj,jk)136 ELSE137 tsa(2,jj,jk,jn)=(alpha4*tsa(1,jj,jk,jn)+alpha3*tsa(3,jj,jk,jn))*tmask(2,jj,jk)138 IF( un(2,jj,jk) < 0.e0 ) THEN139 tsa(2,jj,jk,jn)=(alpha6*tsa(3,jj,jk,jn)+alpha5*tsa(1,jj,jk,jn)+alpha7*tsa(4,jj,jk,jn))*tmask(2,jj,jk)140 ENDIF141 ENDIF142 END DO143 END DO144 END DO145 ENDIF146 147 IF( nbondj == -1 .OR. nbondj == 2 ) THEN148 DO jn = 1, jpts149 tsa(:,1,:,jn) = alpha1 * ztsa(:,1,:,jn) + alpha2 * ztsa(:,2,:,jn)150 DO jk=1,jpk151 DO ji=1,jpi152 IF( vmask(ji,2,jk) == 0.e0 ) THEN153 tsa(ji,2,jk,jn)=tsa(ji,1,jk,jn) * tmask(ji,2,jk)154 ELSE155 tsa(ji,2,jk,jn)=(alpha4*tsa(ji,1,jk,jn)+alpha3*tsa(ji,3,jk,jn))*tmask(ji,2,jk)156 IF( vn(ji,2,jk) < 0.e0 ) THEN157 tsa(ji,2,jk,jn)=(alpha6*tsa(ji,3,jk,jn)+alpha5*tsa(ji,1,jk,jn)+alpha7*tsa(ji,4,jk,jn))*tmask(ji,2,jk)158 ENDIF159 ENDIF160 END DO161 END DO162 ENDDO163 ENDIF164 !165 CALL wrk_dealloc( jpi, jpj, jpk, jpts, ztsa )166 70 ! 167 71 END SUBROUTINE Agrif_tra … … 175 79 INTEGER, INTENT(in) :: kt 176 80 !! 177 INTEGER :: ji,jj,jk 81 INTEGER :: ji,jj,jk, j1,j2, i1,i2 178 82 REAL(wp) :: timeref 179 83 REAL(wp) :: z2dt, znugdt 180 84 REAL(wp) :: zrhox, zrhoy 181 REAL(wp), POINTER, DIMENSION(:,:,:) :: zua, zva 182 REAL(wp), POINTER, DIMENSION(:,:) :: spgv1, spgu1, zua2d, zva2d 85 REAL(wp), POINTER, DIMENSION(:,:) :: spgv1, spgu1 183 86 !!---------------------------------------------------------------------- 184 87 185 88 IF( Agrif_Root() ) RETURN 186 89 187 CALL wrk_alloc( jpi, jpj, spgv1, spgu1, zua2d, zva2d ) 188 CALL wrk_alloc( jpi, jpj, jpk, zua, zva ) 90 CALL wrk_alloc( jpi, jpj, spgv1, spgu1 ) 91 92 Agrif_SpecialValue=0. 93 Agrif_UseSpecialValue = ln_spc_dyn 94 95 CALL Agrif_Bc_variable(un_interp_id,procname=interpun) 96 CALL Agrif_Bc_variable(vn_interp_id,procname=interpvn) 97 98 #if defined key_dynspg_flt 99 CALL Agrif_Bc_variable(e1u_id,calledweight=1., procname=interpun2d) 100 CALL Agrif_Bc_variable(e2v_id,calledweight=1., procname=interpvn2d) 101 #endif 102 103 Agrif_UseSpecialValue = .FALSE. 189 104 190 105 zrhox = Agrif_Rhox() … … 192 107 193 108 timeref = 1. 194 195 109 ! time step: leap-frog 196 110 z2dt = 2. * rdt … … 200 114 znugdt = grav * z2dt 201 115 202 Agrif_SpecialValue=0. 203 Agrif_UseSpecialValue = ln_spc_dyn 204 205 zua = 0. 206 zva = 0. 207 CALL Agrif_Bc_variable(zua,un_id,procname=interpu) 208 CALL Agrif_Bc_variable(zva,vn_id,procname=interpv) 209 zua2d = 0. 210 zva2d = 0. 211 116 ! prevent smoothing in ghost cells 117 i1=1 118 i2=jpi 119 j1=1 120 j2=jpj 121 IF((nbondj == -1).OR.(nbondj == 2)) j1 = 3 122 IF((nbondj == +1).OR.(nbondj == 2)) j2 = nlcj-2 123 IF((nbondi == -1).OR.(nbondi == 2)) i1 = 3 124 IF((nbondi == +1).OR.(nbondi == 2)) i2 = nlci-2 125 126 127 IF((nbondi == -1).OR.(nbondi == 2)) THEN 212 128 #if defined key_dynspg_flt 213 Agrif_SpecialValue=0. 214 Agrif_UseSpecialValue = ln_spc_dyn 215 CALL Agrif_Bc_variable(zua2d,e1u_id,calledweight=1.,procname=interpu2d) 216 CALL Agrif_Bc_variable(zva2d,e2v_id,calledweight=1.,procname=interpv2d) 217 #endif 218 Agrif_UseSpecialValue = .FALSE. 219 220 221 IF((nbondi == -1).OR.(nbondi == 2)) THEN 222 223 #if defined key_dynspg_flt 224 DO jj=1,jpj 225 laplacu(2,jj) = timeref * (zua2d(2,jj)/(zrhoy*e2u(2,jj)))*umask(2,jj,1) 226 END DO 227 #endif 129 DO jk=1,jpkm1 130 DO jj=j1,j2 131 ua(2,jj,jk) = (ua(2,jj,jk) - z2dt * znugdt * laplacu(2,jj))*umask(2,jj,jk) 132 END DO 133 END DO 134 135 spgu(2,:)=0. 228 136 229 137 DO jk=1,jpkm1 230 138 DO jj=1,jpj 231 ua(1:2,jj,jk) = (zua(1:2,jj,jk)/(zrhoy*e2u(1:2,jj))) 232 ua(1:2,jj,jk) = ua(1:2,jj,jk) / fse3u_a(1:2,jj,jk) 233 END DO 234 END DO 235 236 #if defined key_dynspg_flt 237 DO jk=1,jpkm1 238 DO jj=1,jpj 239 ua(2,jj,jk) = (ua(2,jj,jk) - z2dt * znugdt * laplacu(2,jj))*umask(2,jj,jk) 240 END DO 241 END DO 242 243 spgu(2,:)=0. 244 245 DO jk=1,jpkm1 246 DO jj=1,jpj 247 spgu(2,jj)=spgu(2,jj)+fse3u_a(2,jj,jk)*ua(2,jj,jk) 139 spgu(2,jj)=spgu(2,jj)+fse3u(2,jj,jk)*ua(2,jj,jk) 248 140 END DO 249 141 END DO … … 251 143 DO jj=1,jpj 252 144 IF (umask(2,jj,1).NE.0.) THEN 253 spgu(2,jj)=spgu(2,jj) *hur_a(2,jj)145 spgu(2,jj)=spgu(2,jj)/hu(2,jj) 254 146 ENDIF 255 147 END DO … … 259 151 260 152 DO jk=1,jpkm1 261 DO jj= 1,jpj153 DO jj=j1,j2 262 154 ua(2,jj,jk) = 0.25*(ua(1,jj,jk)+2.*ua(2,jj,jk)+ua(3,jj,jk)) 263 155 ua(2,jj,jk) = ua(2,jj,jk) * umask(2,jj,jk) … … 269 161 DO jk=1,jpkm1 270 162 DO jj=1,jpj 271 spgu1(2,jj)=spgu1(2,jj)+fse3u _a(2,jj,jk)*ua(2,jj,jk)163 spgu1(2,jj)=spgu1(2,jj)+fse3u(2,jj,jk)*ua(2,jj,jk) 272 164 END DO 273 165 END DO … … 275 167 DO jj=1,jpj 276 168 IF (umask(2,jj,1).NE.0.) THEN 277 spgu1(2,jj)=spgu1(2,jj) *hur_a(2,jj)278 ENDIF 279 END DO 280 281 DO jk=1,jpkm1 282 DO jj= 1,jpj169 spgu1(2,jj)=spgu1(2,jj)/hu(2,jj) 170 ENDIF 171 END DO 172 173 DO jk=1,jpkm1 174 DO jj=j1,j2 283 175 ua(2,jj,jk) = (ua(2,jj,jk)+spgu(2,jj)-spgu1(2,jj))*umask(2,jj,jk) 284 END DO285 END DO286 287 DO jk=1,jpkm1288 DO jj=1,jpj289 va(2,jj,jk) = (zva(2,jj,jk)/(zrhox*e1v(2,jj)))*vmask(2,jj,jk)290 va(2,jj,jk) = va(2,jj,jk) / fse3v_a(2,jj,jk)291 176 END DO 292 177 END DO … … 300 185 END DO 301 186 END DO 302 303 187 DO jj=1,jpj 304 188 spgv1(2,jj)=spgv1(2,jj)*hvr_a(2,jj) 305 189 END DO 306 307 190 DO jk=1,jpkm1 308 191 DO jj=1,jpj … … 316 199 IF((nbondi == 1).OR.(nbondi == 2)) THEN 317 200 #if defined key_dynspg_flt 318 DO jj=1,jpj 319 laplacu(nlci-2,jj) = timeref * (zua2d(nlci-2,jj)/(zrhoy*e2u(nlci-2,jj))) 320 END DO 321 #endif 322 201 DO jk=1,jpkm1 202 DO jj=j1,j2 203 ua(nlci-2,jj,jk) = (ua(nlci-2,jj,jk)- z2dt * znugdt * laplacu(nlci-2,jj))*umask(nlci-2,jj,jk) 204 END DO 205 END DO 206 spgu(nlci-2,:)=0. 323 207 DO jk=1,jpkm1 324 208 DO jj=1,jpj 325 ua(nlci-2:nlci-1,jj,jk) = (zua(nlci-2:nlci-1,jj,jk)/(zrhoy*e2u(nlci-2:nlci-1,jj))) 326 ua(nlci-2:nlci-1,jj,jk) = ua(nlci-2:nlci-1,jj,jk) / fse3u_a(nlci-2:nlci-1,jj,jk) 327 END DO 328 END DO 329 330 #if defined key_dynspg_flt 331 DO jk=1,jpkm1 332 DO jj=1,jpj 333 ua(nlci-2,jj,jk) = (ua(nlci-2,jj,jk)- z2dt * znugdt * laplacu(nlci-2,jj))*umask(nlci-2,jj,jk) 334 END DO 335 END DO 336 337 338 spgu(nlci-2,:)=0. 339 340 do jk=1,jpkm1 341 do jj=1,jpj 342 spgu(nlci-2,jj)=spgu(nlci-2,jj)+fse3u_a(nlci-2,jj,jk)*ua(nlci-2,jj,jk) 343 enddo 344 enddo 345 209 spgu(nlci-2,jj)=spgu(nlci-2,jj)+fse3u(nlci-2,jj,jk)*ua(nlci-2,jj,jk) 210 ENDDO 211 ENDDO 346 212 DO jj=1,jpj 347 213 IF (umask(nlci-2,jj,1).NE.0.) THEN 348 spgu(nlci-2,jj)=spgu(nlci-2,jj) *hur_a(nlci-2,jj)214 spgu(nlci-2,jj)=spgu(nlci-2,jj)/hu(nlci-2,jj) 349 215 ENDIF 350 216 END DO … … 352 218 spgu(nlci-2,:) = ua_b(nlci-2,:) 353 219 #endif 354 220 DO jk=1,jpkm1 221 DO jj=j1,j2 222 ua(nlci-2,jj,jk) = 0.25*(ua(nlci-3,jj,jk)+2.*ua(nlci-2,jj,jk)+ua(nlci-1,jj,jk)) 223 224 ua(nlci-2,jj,jk) = ua(nlci-2,jj,jk) * umask(nlci-2,jj,jk) 225 226 END DO 227 END DO 228 spgu1(nlci-2,:)=0. 355 229 DO jk=1,jpkm1 356 230 DO jj=1,jpj 357 ua(nlci-2,jj,jk) = 0.25*(ua(nlci-3,jj,jk)+2.*ua(nlci-2,jj,jk)+ua(nlci-1,jj,jk)) 358 359 ua(nlci-2,jj,jk) = ua(nlci-2,jj,jk) * umask(nlci-2,jj,jk) 360 361 END DO 362 END DO 363 364 spgu1(nlci-2,:)=0. 365 366 DO jk=1,jpkm1 367 DO jj=1,jpj 368 spgu1(nlci-2,jj)=spgu1(nlci-2,jj)+fse3u_a(nlci-2,jj,jk)*ua(nlci-2,jj,jk)*umask(nlci-2,jj,jk) 369 END DO 370 END DO 371 231 spgu1(nlci-2,jj)=spgu1(nlci-2,jj)+fse3u(nlci-2,jj,jk)*ua(nlci-2,jj,jk)*umask(nlci-2,jj,jk) 232 END DO 233 END DO 372 234 DO jj=1,jpj 373 235 IF (umask(nlci-2,jj,1).NE.0.) THEN 374 spgu1(nlci-2,jj)=spgu1(nlci-2,jj)*hur_a(nlci-2,jj) 375 ENDIF 376 END DO 377 378 DO jk=1,jpkm1 379 DO jj=1,jpj 236 spgu1(nlci-2,jj)=spgu1(nlci-2,jj)/hu(nlci-2,jj) 237 ENDIF 238 END DO 239 DO jk=1,jpkm1 240 DO jj=j1,j2 380 241 ua(nlci-2,jj,jk) = (ua(nlci-2,jj,jk)+spgu(nlci-2,jj)-spgu1(nlci-2,jj))*umask(nlci-2,jj,jk) 381 END DO382 END DO383 384 DO jk=1,jpkm1385 DO jj=1,jpj-1386 va(nlci-1,jj,jk) = (zva(nlci-1,jj,jk)/(zrhox*e1v(nlci-1,jj)))*vmask(nlci-1,jj,jk)387 va(nlci-1,jj,jk) = va(nlci-1,jj,jk) / fse3v_a(nlci-1,jj,jk)388 242 END DO 389 243 END DO … … 414 268 415 269 #if defined key_dynspg_flt 416 DO ji=1,jpi417 laplacv(ji,2) = timeref * (zva2d(ji,2)/(zrhox*e1v(ji,2)))418 END DO419 #endif420 421 DO jk=1,jpkm1422 DO ji=1,jpi423 va(ji,1:2,jk) = (zva(ji,1:2,jk)/(zrhox*e1v(ji,1:2)))424 va(ji,1:2,jk) = va(ji,1:2,jk) / fse3v_a(ji,1:2,jk)425 END DO426 END DO427 428 #if defined key_dynspg_flt429 270 DO jk=1,jpkm1 430 271 DO ji=1,jpi … … 437 278 DO jk=1,jpkm1 438 279 DO ji=1,jpi 439 spgv(ji,2)=spgv(ji,2)+fse3v _a(ji,2,jk)*va(ji,2,jk)280 spgv(ji,2)=spgv(ji,2)+fse3v(ji,2,jk)*va(ji,2,jk) 440 281 END DO 441 282 END DO … … 443 284 DO ji=1,jpi 444 285 IF (vmask(ji,2,1).NE.0.) THEN 445 spgv(ji,2)=spgv(ji,2) *hvr_a(ji,2)286 spgv(ji,2)=spgv(ji,2)/hv(ji,2) 446 287 ENDIF 447 288 END DO … … 451 292 452 293 DO jk=1,jpkm1 453 DO ji= 1,jpi294 DO ji=i1,i2 454 295 va(ji,2,jk)=0.25*(va(ji,1,jk)+2.*va(ji,2,jk)+va(ji,3,jk)) 455 296 va(ji,2,jk)=va(ji,2,jk)*vmask(ji,2,jk) … … 461 302 DO jk=1,jpkm1 462 303 DO ji=1,jpi 463 spgv1(ji,2)=spgv1(ji,2)+fse3v _a(ji,2,jk)*va(ji,2,jk)*vmask(ji,2,jk)304 spgv1(ji,2)=spgv1(ji,2)+fse3v(ji,2,jk)*va(ji,2,jk)*vmask(ji,2,jk) 464 305 END DO 465 306 END DO … … 467 308 DO ji=1,jpi 468 309 IF (vmask(ji,2,1).NE.0.) THEN 469 spgv1(ji,2)=spgv1(ji,2) *hvr_a(ji,2)310 spgv1(ji,2)=spgv1(ji,2)/hv(ji,2) 470 311 ENDIF 471 312 END DO … … 474 315 DO ji=1,jpi 475 316 va(ji,2,jk) = (va(ji,2,jk)+spgv(ji,2)-spgv1(ji,2))*vmask(ji,2,jk) 476 END DO477 END DO478 479 DO jk=1,jpkm1480 DO ji=1,jpi481 ua(ji,2,jk) = (zua(ji,2,jk)/(zrhoy*e2u(ji,2)))*umask(ji,2,jk)482 ua(ji,2,jk) = ua(ji,2,jk) / fse3u_a(ji,2,jk)483 317 END DO 484 318 END DO … … 508 342 509 343 #if defined key_dynspg_flt 510 DO ji=1,jpi511 laplacv(ji,nlcj-2) = timeref * (zva2d(ji,nlcj-2)/(zrhox*e1v(ji,nlcj-2)))512 END DO513 #endif514 515 DO jk=1,jpkm1516 DO ji=1,jpi517 va(ji,nlcj-2:nlcj-1,jk) = (zva(ji,nlcj-2:nlcj-1,jk)/(zrhox*e1v(ji,nlcj-2:nlcj-1)))518 va(ji,nlcj-2:nlcj-1,jk) = va(ji,nlcj-2:nlcj-1,jk) / fse3v_a(ji,nlcj-2:nlcj-1,jk)519 END DO520 END DO521 522 #if defined key_dynspg_flt523 344 DO jk=1,jpkm1 524 345 DO ji=1,jpi … … 527 348 END DO 528 349 350 529 351 spgv(:,nlcj-2)=0. 530 352 531 353 DO jk=1,jpkm1 532 354 DO ji=1,jpi 533 spgv(ji,nlcj-2)=spgv(ji,nlcj-2)+fse3v _a(ji,nlcj-2,jk)*va(ji,nlcj-2,jk)355 spgv(ji,nlcj-2)=spgv(ji,nlcj-2)+fse3v(ji,nlcj-2,jk)*va(ji,nlcj-2,jk) 534 356 END DO 535 357 END DO … … 537 359 DO ji=1,jpi 538 360 IF (vmask(ji,nlcj-2,1).NE.0.) THEN 539 spgv(ji,nlcj-2)=spgv(ji,nlcj-2)*hvr_a(ji,nlcj-2) 540 ENDIF 541 END DO 361 spgv(ji,nlcj-2)=spgv(ji,nlcj-2)/hv(ji,nlcj-2) 362 ENDIF 363 END DO 364 542 365 #else 543 366 spgv(:,nlcj-2)=va_b(:,nlcj-2) … … 545 368 546 369 DO jk=1,jpkm1 547 DO ji= 1,jpi370 DO ji=i1,i2 548 371 va(ji,nlcj-2,jk)=0.25*(va(ji,nlcj-3,jk)+2.*va(ji,nlcj-2,jk)+va(ji,nlcj-1,jk)) 549 372 va(ji,nlcj-2,jk) = va(ji,nlcj-2,jk) * vmask(ji,nlcj-2,jk) … … 555 378 DO jk=1,jpkm1 556 379 DO ji=1,jpi 557 spgv1(ji,nlcj-2)=spgv1(ji,nlcj-2)+fse3v _a(ji,nlcj-2,jk)*va(ji,nlcj-2,jk)380 spgv1(ji,nlcj-2)=spgv1(ji,nlcj-2)+fse3v(ji,nlcj-2,jk)*va(ji,nlcj-2,jk) 558 381 END DO 559 382 END DO … … 561 384 DO ji=1,jpi 562 385 IF (vmask(ji,nlcj-2,1).NE.0.) THEN 563 spgv1(ji,nlcj-2)=spgv1(ji,nlcj-2) *hvr_a(ji,nlcj-2)386 spgv1(ji,nlcj-2)=spgv1(ji,nlcj-2)/hv(ji,nlcj-2) 564 387 ENDIF 565 388 END DO … … 568 391 DO ji=1,jpi 569 392 va(ji,nlcj-2,jk) = (va(ji,nlcj-2,jk)+spgv(ji,nlcj-2)-spgv1(ji,nlcj-2))*vmask(ji,nlcj-2,jk) 570 END DO571 END DO572 573 DO jk=1,jpkm1574 DO ji=1,jpi575 ua(ji,nlcj-1,jk) = (zua(ji,nlcj-1,jk)/(zrhoy*e2u(ji,nlcj-1)))*umask(ji,nlcj-1,jk)576 ua(ji,nlcj-1,jk) = ua(ji,nlcj-1,jk) / fse3u_a(ji,nlcj-1,jk)577 393 END DO 578 394 END DO … … 600 416 ENDIF 601 417 ! 602 CALL wrk_dealloc( jpi, jpj, spgv1, spgu1, zua2d, zva2d ) 603 CALL wrk_dealloc( jpi, jpj, jpk, zua, zva ) 418 CALL wrk_dealloc( jpi, jpj, spgv1, spgu1 ) 604 419 ! 605 420 END SUBROUTINE Agrif_dyn … … 620 435 DO jj=1,jpj 621 436 va_e(2,jj) = vbdy_w(jj) * hvr_e(2,jj) 622 ! Specified fluxes:437 ! Specified fluxes: 623 438 ua_e(2,jj) = ubdy_w(jj) * hur_e(2,jj) 624 ! Characteristics method:625 !alt ua_e(2,jj) = 0.5_wp * ( ubdy_w(jj) * hur_e(2,jj) + ua_e(3,jj) &626 !alt & - sqrt(grav * hur_e(2,jj)) * (sshn_e(3,jj) - hbdy_w(jj)) )439 ! Characteristics method: 440 !alt ua_e(2,jj) = 0.5_wp * ( ubdy_w(jj) * hur_e(2,jj) + ua_e(3,jj) & 441 !alt & - sqrt(grav * hur_e(2,jj)) * (sshn_e(3,jj) - hbdy_w(jj)) ) 627 442 END DO 628 443 ENDIF … … 631 446 DO jj=1,jpj 632 447 va_e(nlci-1,jj) = vbdy_e(jj) * hvr_e(nlci-1,jj) 633 ! Specified fluxes:448 ! Specified fluxes: 634 449 ua_e(nlci-2,jj) = ubdy_e(jj) * hur_e(nlci-2,jj) 635 ! Characteristics method:636 !alt ua_e(nlci-2,jj) = 0.5_wp * ( ubdy_e(jj) * hur_e(nlci-2,jj) + ua_e(nlci-3,jj) &637 !alt & + sqrt(grav * hur_e(nlci-2,jj)) * (sshn_e(nlci-2,jj) - hbdy_e(jj)) )450 ! Characteristics method: 451 !alt ua_e(nlci-2,jj) = 0.5_wp * ( ubdy_e(jj) * hur_e(nlci-2,jj) + ua_e(nlci-3,jj) & 452 !alt & + sqrt(grav * hur_e(nlci-2,jj)) * (sshn_e(nlci-2,jj) - hbdy_e(jj)) ) 638 453 END DO 639 454 ENDIF … … 642 457 DO ji=1,jpi 643 458 ua_e(ji,2) = ubdy_s(ji) * hur_e(ji,2) 644 ! Specified fluxes:459 ! Specified fluxes: 645 460 va_e(ji,2) = vbdy_s(ji) * hvr_e(ji,2) 646 ! Characteristics method:647 !alt va_e(ji,2) = 0.5_wp * ( vbdy_s(ji) * hvr_e(ji,2) + va_e(ji,3) &648 !alt & - sqrt(grav * hvr_e(ji,2)) * (sshn_e(ji,3) - hbdy_s(ji)) )461 ! Characteristics method: 462 !alt va_e(ji,2) = 0.5_wp * ( vbdy_s(ji) * hvr_e(ji,2) + va_e(ji,3) & 463 !alt & - sqrt(grav * hvr_e(ji,2)) * (sshn_e(ji,3) - hbdy_s(ji)) ) 649 464 END DO 650 465 ENDIF … … 653 468 DO ji=1,jpi 654 469 ua_e(ji,nlcj-1) = ubdy_n(ji) * hur_e(ji,nlcj-1) 655 ! Specified fluxes:470 ! Specified fluxes: 656 471 va_e(ji,nlcj-2) = vbdy_n(ji) * hvr_e(ji,nlcj-2) 657 ! Characteristics method:658 !alt va_e(ji,nlcj-2) = 0.5_wp * ( vbdy_n(ji) * hvr_e(ji,nlcj-2) + va_e(ji,nlcj-3) &659 !alt & + sqrt(grav * hvr_e(ji,nlcj-2)) * (sshn_e(ji,nlcj-2) - hbdy_n(ji)) )472 ! Characteristics method: 473 !alt va_e(ji,nlcj-2) = 0.5_wp * ( vbdy_n(ji) * hvr_e(ji,nlcj-2) + va_e(ji,nlcj-3) & 474 !alt & + sqrt(grav * hvr_e(ji,nlcj-2)) * (sshn_e(ji,nlcj-2) - hbdy_n(ji)) ) 660 475 END DO 661 476 ENDIF … … 672 487 INTEGER :: ji, jj 673 488 LOGICAL :: ll_int_cons 674 REAL(wp) :: zrhox, zrhoy, zrhot, zt 675 REAL(wp) :: zaa, zab, zat 676 REAL(wp) :: zt0, zt1 677 REAL(wp), POINTER, DIMENSION(:,:) :: zunb, zvnb, zsshn 678 REAL(wp), POINTER, DIMENSION(:,:) :: zuab, zvab, zubb, zvbb, zutn, zvtn 489 REAL(wp) :: zrhot, zt 679 490 !!---------------------------------------------------------------------- 680 491 … … 682 493 683 494 ll_int_cons = ln_bt_fw ! Assume conservative temporal integration in 684 ! the forward case only 685 686 zrhox = Agrif_Rhox() 687 zrhoy = Agrif_Rhoy() 495 ! the forward case only 496 688 497 zrhot = Agrif_rhot() 689 690 IF ( kt==nit000 ) THEN ! Allocate boundary data arrays691 ALLOCATE( ubdy_w(jpj), vbdy_w(jpj), hbdy_w(jpj))692 ALLOCATE( ubdy_e(jpj), vbdy_e(jpj), hbdy_e(jpj))693 ALLOCATE( ubdy_n(jpi), vbdy_n(jpi), hbdy_n(jpi))694 ALLOCATE( ubdy_s(jpi), vbdy_s(jpi), hbdy_s(jpi))695 ENDIF696 697 CALL wrk_alloc( jpi, jpj, zunb, zvnb, zsshn )698 498 699 499 ! "Central" time index for interpolation: … … 707 507 Agrif_SpecialValue = 0.e0 708 508 Agrif_UseSpecialValue = .TRUE. 709 CALL Agrif_Bc_variable( zsshn,sshn_id,calledweight=zt, procname=interpsshn )509 CALL Agrif_Bc_variable(sshn_id,calledweight=zt, procname=interpsshn ) 710 510 Agrif_UseSpecialValue = .FALSE. 711 511 … … 715 515 716 516 IF (ll_int_cons) THEN ! Conservative interpolation 717 CALL wrk_alloc( jpi, jpj, zuab, zvab, zubb, zvbb, zutn, zvtn ) 718 zuab(:,:) = 0._wp ; zvab(:,:) = 0._wp 719 zubb(:,:) = 0._wp ; zvbb(:,:) = 0._wp 720 zutn(:,:) = 0._wp ; zvtn(:,:) = 0._wp 721 CALL Agrif_Bc_variable(zubb,unb_id ,calledweight=0._wp, procname=interpunb) ! Before 722 CALL Agrif_Bc_variable(zvbb,vnb_id ,calledweight=0._wp, procname=interpvnb) 723 CALL Agrif_Bc_variable(zuab,unb_id ,calledweight=1._wp, procname=interpunb) ! After 724 CALL Agrif_Bc_variable(zvab,vnb_id ,calledweight=1._wp, procname=interpvnb) 725 CALL Agrif_Bc_variable(zutn,ub2b_id,calledweight=1._wp, procname=interpub2b)! Time integrated 726 CALL Agrif_Bc_variable(zvtn,vb2b_id,calledweight=1._wp, procname=interpvb2b) 727 517 ! orders matters here !!!!!! 518 CALL Agrif_Bc_variable(ub2b_interp_id,calledweight=1._wp, procname=interpub2b) ! Time integrated 519 CALL Agrif_Bc_variable(vb2b_interp_id,calledweight=1._wp, procname=interpvb2b) 520 bdy_tinterp = 1 521 CALL Agrif_Bc_variable(unb_id ,calledweight=1._wp, procname=interpunb) ! After 522 CALL Agrif_Bc_variable(vnb_id ,calledweight=1._wp, procname=interpvnb) 523 bdy_tinterp = 2 524 CALL Agrif_Bc_variable(unb_id ,calledweight=0._wp, procname=interpunb) ! Before 525 CALL Agrif_Bc_variable(vnb_id ,calledweight=0._wp, procname=interpvnb) 526 ELSE ! Linear interpolation 527 bdy_tinterp = 0 528 ubdy_w(:) = 0.e0 ; vbdy_w(:) = 0.e0 529 ubdy_e(:) = 0.e0 ; vbdy_e(:) = 0.e0 530 ubdy_n(:) = 0.e0 ; vbdy_n(:) = 0.e0 531 ubdy_s(:) = 0.e0 ; vbdy_s(:) = 0.e0 532 CALL Agrif_Bc_variable(unb_id,calledweight=zt, procname=interpunb) 533 CALL Agrif_Bc_variable(vnb_id,calledweight=zt, procname=interpvnb) 534 ENDIF 535 Agrif_UseSpecialValue = .FALSE. 536 ! 537 END SUBROUTINE Agrif_dta_ts 538 539 SUBROUTINE Agrif_ssh( kt ) 540 !!---------------------------------------------------------------------- 541 !! *** ROUTINE Agrif_DYN *** 542 !!---------------------------------------------------------------------- 543 INTEGER, INTENT(in) :: kt 544 !! 545 !!---------------------------------------------------------------------- 546 547 IF( Agrif_Root() ) RETURN 548 549 IF((nbondi == -1).OR.(nbondi == 2)) THEN 550 ssha(2,:)=ssha(3,:) 551 sshn(2,:)=sshn(3,:) 552 ENDIF 553 554 IF((nbondi == 1).OR.(nbondi == 2)) THEN 555 ssha(nlci-1,:)=ssha(nlci-2,:) 556 sshn(nlci-1,:)=sshn(nlci-2,:) 557 ENDIF 558 559 IF((nbondj == -1).OR.(nbondj == 2)) THEN 560 ssha(:,2)=ssha(:,3) 561 sshn(:,2)=sshn(:,3) 562 ENDIF 563 564 IF((nbondj == 1).OR.(nbondj == 2)) THEN 565 ssha(:,nlcj-1)=ssha(:,nlcj-2) 566 sshn(:,nlcj-1)=sshn(:,nlcj-2) 567 ENDIF 568 569 END SUBROUTINE Agrif_ssh 570 571 SUBROUTINE Agrif_ssh_ts( jn ) 572 !!---------------------------------------------------------------------- 573 !! *** ROUTINE Agrif_ssh_ts *** 574 !!---------------------------------------------------------------------- 575 INTEGER, INTENT(in) :: jn 576 !! 577 INTEGER :: ji,jj 578 !!---------------------------------------------------------------------- 579 580 IF((nbondi == -1).OR.(nbondi == 2)) THEN 581 DO jj=1,jpj 582 ssha_e(2,jj) = hbdy_w(jj) 583 END DO 584 ENDIF 585 586 IF((nbondi == 1).OR.(nbondi == 2)) THEN 587 DO jj=1,jpj 588 ssha_e(nlci-1,jj) = hbdy_e(jj) 589 END DO 590 ENDIF 591 592 IF((nbondj == -1).OR.(nbondj == 2)) THEN 593 DO ji=1,jpi 594 ssha_e(ji,2) = hbdy_s(ji) 595 END DO 596 ENDIF 597 598 IF((nbondj == 1).OR.(nbondj == 2)) THEN 599 DO ji=1,jpi 600 ssha_e(ji,nlcj-1) = hbdy_n(ji) 601 END DO 602 ENDIF 603 604 END SUBROUTINE Agrif_ssh_ts 605 606 # if defined key_zdftke 607 SUBROUTINE Agrif_tke 608 !!---------------------------------------------------------------------- 609 !! *** ROUTINE Agrif_tke *** 610 !!---------------------------------------------------------------------- 611 REAL(wp) :: zalpha 612 ! 613 zalpha = REAL( Agrif_NbStepint() + Agrif_IRhot() - 1, wp ) / REAL( Agrif_IRhot(), wp ) 614 IF( zalpha > 1. ) zalpha = 1. 615 616 Agrif_SpecialValue = 0.e0 617 Agrif_UseSpecialValue = .TRUE. 618 619 CALL Agrif_Bc_variable(avm_id ,calledweight=zalpha, procname=interpavm) 620 621 Agrif_UseSpecialValue = .FALSE. 622 ! 623 END SUBROUTINE Agrif_tke 624 # endif 625 626 SUBROUTINE interptsn(ptab,i1,i2,j1,j2,k1,k2,n1,n2,before,nb,ndir) 627 !!--------------------------------------------- 628 !! *** ROUTINE interptsn *** 629 !!--------------------------------------------- 630 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: ptab 631 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2 632 LOGICAL, INTENT(in) :: before 633 INTEGER, INTENT(in) :: nb , ndir 634 ! 635 INTEGER :: ji, jj, jk, jn ! dummy loop indices 636 INTEGER :: imin, imax, jmin, jmax 637 REAL(wp) :: zrhox , zalpha1, zalpha2, zalpha3 638 REAL(wp) :: zalpha4, zalpha5, zalpha6, zalpha7 639 LOGICAL :: western_side, eastern_side,northern_side,southern_side 640 641 IF (before) THEN 642 ptab(i1:i2,j1:j2,k1:k2,n1:n2) = tsn(i1:i2,j1:j2,k1:k2,n1:n2) 643 ELSE 644 ! 645 western_side = (nb == 1).AND.(ndir == 1) 646 eastern_side = (nb == 1).AND.(ndir == 2) 647 southern_side = (nb == 2).AND.(ndir == 1) 648 northern_side = (nb == 2).AND.(ndir == 2) 649 ! 650 zrhox = Agrif_Rhox() 651 ! 652 zalpha1 = ( zrhox - 1. ) * 0.5 653 zalpha2 = 1. - zalpha1 654 ! 655 zalpha3 = ( zrhox - 1. ) / ( zrhox + 1. ) 656 zalpha4 = 1. - zalpha3 657 ! 658 zalpha6 = 2. * ( zrhox - 1. ) / ( zrhox + 1. ) 659 zalpha7 = - ( zrhox - 1. ) / ( zrhox + 3. ) 660 zalpha5 = 1. - zalpha6 - zalpha7 661 ! 662 imin = i1 663 imax = i2 664 jmin = j1 665 jmax = j2 666 ! 667 ! Remove CORNERS 668 IF((nbondj == -1).OR.(nbondj == 2)) jmin = 3 669 IF((nbondj == +1).OR.(nbondj == 2)) jmax = nlcj-2 670 IF((nbondi == -1).OR.(nbondi == 2)) imin = 3 671 IF((nbondi == +1).OR.(nbondi == 2)) imax = nlci-2 672 ! 673 IF( eastern_side) THEN 674 DO jn = 1, jpts 675 tsa(nlci,j1:j2,k1:k2,jn) = zalpha1 * ptab(nlci,j1:j2,k1:k2,jn) + zalpha2 * ptab(nlci-1,j1:j2,k1:k2,jn) 676 DO jk = 1, jpkm1 677 DO jj = jmin,jmax 678 IF( umask(nlci-2,jj,jk) == 0.e0 ) THEN 679 tsa(nlci-1,jj,jk,jn) = tsa(nlci,jj,jk,jn) * tmask(nlci-1,jj,jk) 680 ELSE 681 tsa(nlci-1,jj,jk,jn)=(zalpha4*tsa(nlci,jj,jk,jn)+zalpha3*tsa(nlci-2,jj,jk,jn))*tmask(nlci-1,jj,jk) 682 IF( un(nlci-2,jj,jk) > 0.e0 ) THEN 683 tsa(nlci-1,jj,jk,jn)=( zalpha6*tsa(nlci-2,jj,jk,jn)+zalpha5*tsa(nlci,jj,jk,jn) & 684 + zalpha7*tsa(nlci-3,jj,jk,jn) ) * tmask(nlci-1,jj,jk) 685 ENDIF 686 ENDIF 687 END DO 688 END DO 689 ENDDO 690 ENDIF 691 ! 692 IF( northern_side ) THEN 693 DO jn = 1, jpts 694 tsa(i1:i2,nlcj,k1:k2,jn) = zalpha1 * ptab(i1:i2,nlcj,k1:k2,jn) + zalpha2 * ptab(i1:i2,nlcj-1,k1:k2,jn) 695 DO jk = 1, jpkm1 696 DO ji = imin,imax 697 IF( vmask(ji,nlcj-2,jk) == 0.e0 ) THEN 698 tsa(ji,nlcj-1,jk,jn) = tsa(ji,nlcj,jk,jn) * tmask(ji,nlcj-1,jk) 699 ELSE 700 tsa(ji,nlcj-1,jk,jn)=(zalpha4*tsa(ji,nlcj,jk,jn)+zalpha3*tsa(ji,nlcj-2,jk,jn))*tmask(ji,nlcj-1,jk) 701 IF (vn(ji,nlcj-2,jk) > 0.e0 ) THEN 702 tsa(ji,nlcj-1,jk,jn)=( zalpha6*tsa(ji,nlcj-2,jk,jn)+zalpha5*tsa(ji,nlcj,jk,jn) & 703 + zalpha7*tsa(ji,nlcj-3,jk,jn) ) * tmask(ji,nlcj-1,jk) 704 ENDIF 705 ENDIF 706 END DO 707 END DO 708 ENDDO 709 ENDIF 710 ! 711 IF( western_side) THEN 712 DO jn = 1, jpts 713 tsa(1,j1:j2,k1:k2,jn) = zalpha1 * ptab(1,j1:j2,k1:k2,jn) + zalpha2 * ptab(2,j1:j2,k1:k2,jn) 714 DO jk = 1, jpkm1 715 DO jj = jmin,jmax 716 IF( umask(2,jj,jk) == 0.e0 ) THEN 717 tsa(2,jj,jk,jn) = tsa(1,jj,jk,jn) * tmask(2,jj,jk) 718 ELSE 719 tsa(2,jj,jk,jn)=(zalpha4*tsa(1,jj,jk,jn)+zalpha3*tsa(3,jj,jk,jn))*tmask(2,jj,jk) 720 IF( un(2,jj,jk) < 0.e0 ) THEN 721 tsa(2,jj,jk,jn)=(zalpha6*tsa(3,jj,jk,jn)+zalpha5*tsa(1,jj,jk,jn)+zalpha7*tsa(4,jj,jk,jn))*tmask(2,jj,jk) 722 ENDIF 723 ENDIF 724 END DO 725 END DO 726 END DO 727 ENDIF 728 ! 729 IF( southern_side ) THEN 730 DO jn = 1, jpts 731 tsa(i1:i2,1,k1:k2,jn) = zalpha1 * ptab(i1:i2,1,k1:k2,jn) + zalpha2 * ptab(i1:i2,2,k1:k2,jn) 732 DO jk=1,jpk 733 DO ji=imin,imax 734 IF( vmask(ji,2,jk) == 0.e0 ) THEN 735 tsa(ji,2,jk,jn)=tsa(ji,1,jk,jn) * tmask(ji,2,jk) 736 ELSE 737 tsa(ji,2,jk,jn)=(zalpha4*tsa(ji,1,jk,jn)+zalpha3*tsa(ji,3,jk,jn))*tmask(ji,2,jk) 738 IF( vn(ji,2,jk) < 0.e0 ) THEN 739 tsa(ji,2,jk,jn)=(zalpha6*tsa(ji,3,jk,jn)+zalpha5*tsa(ji,1,jk,jn)+zalpha7*tsa(ji,4,jk,jn))*tmask(ji,2,jk) 740 ENDIF 741 ENDIF 742 END DO 743 END DO 744 ENDDO 745 ENDIF 746 ! 747 ! Treatment of corners 748 ! 749 ! East south 750 IF ((eastern_side).AND.((nbondj == -1).OR.(nbondj == 2))) THEN 751 tsa(nlci-1,2,:,:) = ptab(nlci-1,2,:,:) 752 ENDIF 753 ! East north 754 IF ((eastern_side).AND.((nbondj == 1).OR.(nbondj == 2))) THEN 755 tsa(nlci-1,nlcj-1,:,:) = ptab(nlci-1,nlcj-1,:,:) 756 ENDIF 757 ! West south 758 IF ((western_side).AND.((nbondj == -1).OR.(nbondj == 2))) THEN 759 tsa(2,2,:,:) = ptab(2,2,:,:) 760 ENDIF 761 ! West north 762 IF ((western_side).AND.((nbondj == 1).OR.(nbondj == 2))) THEN 763 tsa(2,nlcj-1,:,:) = ptab(2,nlcj-1,:,:) 764 ENDIF 765 ! 766 ENDIF 767 ! 768 END SUBROUTINE interptsn 769 770 SUBROUTINE interpsshn(ptab,i1,i2,j1,j2,before,nb,ndir) 771 !!---------------------------------------------------------------------- 772 !! *** ROUTINE interpsshn *** 773 !!---------------------------------------------------------------------- 774 INTEGER, INTENT(in) :: i1,i2,j1,j2 775 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 776 LOGICAL, INTENT(in) :: before 777 INTEGER, INTENT(in) :: nb , ndir 778 LOGICAL :: western_side, eastern_side,northern_side,southern_side 779 !!---------------------------------------------------------------------- 780 ! 781 IF( before) THEN 782 ptab(i1:i2,j1:j2) = sshn(i1:i2,j1:j2) 783 ELSE 784 western_side = (nb == 1).AND.(ndir == 1) 785 eastern_side = (nb == 1).AND.(ndir == 2) 786 southern_side = (nb == 2).AND.(ndir == 1) 787 northern_side = (nb == 2).AND.(ndir == 2) 788 IF(western_side) hbdy_w(j1:j2) = ptab(i1,j1:j2) * tmask(i1,j1:j2,1) 789 IF(eastern_side) hbdy_e(j1:j2) = ptab(i1,j1:j2) * tmask(i1,j1:j2,1) 790 IF(southern_side) hbdy_s(i1:i2) = ptab(i1:i2,j1) * tmask(i1:i2,j1,1) 791 IF(northern_side) hbdy_n(i1:i2) = ptab(i1:i2,j1) * tmask(i1:i2,j1,1) 792 ENDIF 793 ! 794 END SUBROUTINE interpsshn 795 796 SUBROUTINE interpun(ptab,i1,i2,j1,j2,k1,k2, before) 797 !!--------------------------------------------- 798 !! *** ROUTINE interpun *** 799 !!--------------------------------------------- 800 !! 801 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 802 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 803 LOGICAL, INTENT(in) :: before 804 !! 805 INTEGER :: ji,jj,jk 806 REAL(wp) :: zrhoy 807 !!--------------------------------------------- 808 ! 809 IF (before) THEN 810 DO jk=1,jpk 811 DO jj=j1,j2 812 DO ji=i1,i2 813 ptab(ji,jj,jk) = e2u(ji,jj) * un(ji,jj,jk) 814 ptab(ji,jj,jk) = ptab(ji,jj,jk) * fse3u(ji,jj,jk) 815 END DO 816 END DO 817 END DO 818 ELSE 819 zrhoy = Agrif_Rhoy() 820 DO jk=1,jpkm1 821 DO jj=j1,j2 822 ua(i1:i2,jj,jk) = (ptab(i1:i2,jj,jk)/(zrhoy*e2u(i1:i2,jj))) 823 ua(i1:i2,jj,jk) = ua(i1:i2,jj,jk) / fse3u(i1:i2,jj,jk) 824 END DO 825 END DO 826 ENDIF 827 ! 828 END SUBROUTINE interpun 829 830 831 SUBROUTINE interpun2d(ptab,i1,i2,j1,j2,before) 832 !!--------------------------------------------- 833 !! *** ROUTINE interpun *** 834 !!--------------------------------------------- 835 ! 836 INTEGER, INTENT(in) :: i1,i2,j1,j2 837 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 838 LOGICAL, INTENT(in) :: before 839 ! 840 INTEGER :: ji,jj 841 REAL(wp) :: ztref 842 REAL(wp) :: zrhoy 843 !!--------------------------------------------- 844 ! 845 ztref = 1. 846 847 IF (before) THEN 848 DO jj=j1,j2 849 DO ji=i1,MIN(i2,nlci-1) 850 ptab(ji,jj) = e2u(ji,jj) * ((gcx(ji+1,jj) - gcx(ji,jj))/e1u(ji,jj)) 851 END DO 852 END DO 853 ELSE 854 zrhoy = Agrif_Rhoy() 855 DO jj=j1,j2 856 laplacu(i1:i2,jj) = ztref * (ptab(i1:i2,jj)/(zrhoy*e2u(i1:i2,jj))) !*umask(i1:i2,jj,1) 857 END DO 858 ENDIF 859 ! 860 END SUBROUTINE interpun2d 861 862 863 SUBROUTINE interpvn(ptab,i1,i2,j1,j2,k1,k2, before) 864 !!--------------------------------------------- 865 !! *** ROUTINE interpvn *** 866 !!--------------------------------------------- 867 ! 868 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 869 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 870 LOGICAL, INTENT(in) :: before 871 ! 872 INTEGER :: ji,jj,jk 873 REAL(wp) :: zrhox 874 !!--------------------------------------------- 875 ! 876 IF (before) THEN 877 !interpv entre 1 et k2 et interpv2d en jpkp1 878 DO jk=k1,jpk 879 DO jj=j1,j2 880 DO ji=i1,i2 881 ptab(ji,jj,jk) = e1v(ji,jj) * vn(ji,jj,jk) 882 ptab(ji,jj,jk) = ptab(ji,jj,jk) * fse3v(ji,jj,jk) 883 END DO 884 END DO 885 END DO 886 ELSE 887 zrhox= Agrif_Rhox() 888 DO jk=1,jpkm1 889 DO jj=j1,j2 890 va(i1:i2,jj,jk) = (ptab(i1:i2,jj,jk)/(zrhox*e1v(i1:i2,jj))) 891 va(i1:i2,jj,jk) = va(i1:i2,jj,jk) / fse3v(i1:i2,jj,jk) 892 END DO 893 END DO 894 ENDIF 895 ! 896 END SUBROUTINE interpvn 897 898 SUBROUTINE interpvn2d(ptab,i1,i2,j1,j2,before) 899 !!--------------------------------------------- 900 !! *** ROUTINE interpvn *** 901 !!--------------------------------------------- 902 ! 903 INTEGER, INTENT(in) :: i1,i2,j1,j2 904 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 905 LOGICAL, INTENT(in) :: before 906 ! 907 INTEGER :: ji,jj 908 REAL(wp) :: zrhox 909 REAL(wp) :: ztref 910 !!--------------------------------------------- 911 ! 912 ztref = 1. 913 IF (before) THEN 914 !interpv entre 1 et k2 et interpv2d en jpkp1 915 DO jj=j1,MIN(j2,nlcj-1) 916 DO ji=i1,i2 917 ptab(ji,jj) = e1v(ji,jj) * ((gcx(ji,jj+1) - gcx(ji,jj))/e2v(ji,jj)) * vmask(ji,jj,1) 918 END DO 919 END DO 920 ELSE 921 zrhox = Agrif_Rhox() 922 DO ji=i1,i2 923 laplacv(ji,j1:j2) = ztref * (ptab(ji,j1:j2)/(zrhox*e1v(ji,j1:j2))) 924 END DO 925 ENDIF 926 ! 927 END SUBROUTINE interpvn2d 928 929 SUBROUTINE interpunb(ptab,i1,i2,j1,j2,before,nb,ndir) 930 !!---------------------------------------------------------------------- 931 !! *** ROUTINE interpunb *** 932 !!---------------------------------------------------------------------- 933 INTEGER, INTENT(in) :: i1,i2,j1,j2 934 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 935 LOGICAL, INTENT(in) :: before 936 INTEGER, INTENT(in) :: nb , ndir 937 !! 938 INTEGER :: ji,jj 939 REAL(wp) :: zrhoy, zrhot, zt0, zt1, ztcoeff 940 LOGICAL :: western_side, eastern_side,northern_side,southern_side 941 !!---------------------------------------------------------------------- 942 ! 943 IF (before) THEN 944 DO jj=j1,j2 945 DO ji=i1,i2 946 ptab(ji,jj) = un_b(ji,jj) * e2u(ji,jj) * hu(ji,jj) 947 END DO 948 END DO 949 ELSE 950 western_side = (nb == 1).AND.(ndir == 1) 951 eastern_side = (nb == 1).AND.(ndir == 2) 952 southern_side = (nb == 2).AND.(ndir == 1) 953 northern_side = (nb == 2).AND.(ndir == 2) 954 zrhoy = Agrif_Rhoy() 955 zrhot = Agrif_rhot() 956 ! Time indexes bounds for integration 957 zt0 = REAL(Agrif_NbStepint() , wp) / zrhot 958 zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot 959 ! Polynomial interpolation coefficients: 960 IF( bdy_tinterp == 1 ) THEN 961 ztcoeff = zrhot * ( zt1**2._wp * ( zt1 - 1._wp) & 962 & - zt0**2._wp * ( zt0 - 1._wp) ) 963 ELSEIF( bdy_tinterp == 2 ) THEN 964 ztcoeff = zrhot * ( zt1 * ( zt1 - 1._wp)**2._wp & 965 & - zt0 * ( zt0 - 1._wp)**2._wp ) 966 967 ELSE 968 ztcoeff = 1 969 ENDIF 970 ! 971 IF(western_side) THEN 972 ubdy_w(j1:j2) = ubdy_w(j1:j2) + ztcoeff * ptab(i1,j1:j2) 973 ENDIF 974 IF(eastern_side) THEN 975 ubdy_e(j1:j2) = ubdy_e(j1:j2) + ztcoeff * ptab(i1,j1:j2) 976 ENDIF 977 IF(southern_side) THEN 978 ubdy_s(i1:i2) = ubdy_s(i1:i2) + ztcoeff * ptab(i1:i2,j1) 979 ENDIF 980 IF(northern_side) THEN 981 ubdy_n(i1:i2) = ubdy_n(i1:i2) + ztcoeff * ptab(i1:i2,j1) 982 ENDIF 983 ! 984 IF( bdy_tinterp == 0 .OR. bdy_tinterp == 2) THEN 985 IF(western_side) THEN 986 ubdy_w(j1:j2) = ubdy_w(j1:j2) / (zrhoy*e2u(i1,j1:j2)) & 987 & * umask(i1,j1:j2,1) 988 ENDIF 989 IF(eastern_side) THEN 990 ubdy_e(j1:j2) = ubdy_e(j1:j2) / (zrhoy*e2u(i1,j1:j2)) & 991 & * umask(i1,j1:j2,1) 992 ENDIF 993 IF(southern_side) THEN 994 ubdy_s(i1:i2) = ubdy_s(i1:i2) / (zrhoy*e2u(i1:i2,j1)) & 995 & * umask(i1:i2,j1,1) 996 ENDIF 997 IF(northern_side) THEN 998 ubdy_n(i1:i2) = ubdy_n(i1:i2) / (zrhoy*e2u(i1:i2,j1)) & 999 & * umask(i1:i2,j1,1) 1000 ENDIF 1001 ENDIF 1002 ENDIF 1003 ! 1004 END SUBROUTINE interpunb 1005 1006 SUBROUTINE interpvnb(ptab,i1,i2,j1,j2,before,nb,ndir) 1007 !!---------------------------------------------------------------------- 1008 !! *** ROUTINE interpvnb *** 1009 !!---------------------------------------------------------------------- 1010 INTEGER, INTENT(in) :: i1,i2,j1,j2 1011 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 1012 LOGICAL, INTENT(in) :: before 1013 INTEGER, INTENT(in) :: nb , ndir 1014 !! 1015 INTEGER :: ji,jj 1016 REAL(wp) :: zrhox, zrhot, zt0, zt1, ztcoeff 1017 LOGICAL :: western_side, eastern_side,northern_side,southern_side 1018 !!---------------------------------------------------------------------- 1019 ! 1020 IF (before) THEN 1021 DO jj=j1,j2 1022 DO ji=i1,i2 1023 ptab(ji,jj) = vn_b(ji,jj) * e1v(ji,jj) * hv(ji,jj) 1024 END DO 1025 END DO 1026 ELSE 1027 western_side = (nb == 1).AND.(ndir == 1) 1028 eastern_side = (nb == 1).AND.(ndir == 2) 1029 southern_side = (nb == 2).AND.(ndir == 1) 1030 northern_side = (nb == 2).AND.(ndir == 2) 1031 zrhox = Agrif_Rhox() 1032 zrhot = Agrif_rhot() 1033 ! Time indexes bounds for integration 1034 zt0 = REAL(Agrif_NbStepint() , wp) / zrhot 1035 zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot 1036 IF( bdy_tinterp == 1 ) THEN 1037 ztcoeff = zrhot * ( zt1**2._wp * ( zt1 - 1._wp) & 1038 & - zt0**2._wp * ( zt0 - 1._wp) ) 1039 ELSEIF( bdy_tinterp == 2 ) THEN 1040 ztcoeff = zrhot * ( zt1 * ( zt1 - 1._wp)**2._wp & 1041 & - zt0 * ( zt0 - 1._wp)**2._wp ) 1042 1043 ELSE 1044 ztcoeff = 1 1045 ENDIF 1046 ! 1047 IF(western_side) THEN 1048 vbdy_w(j1:j2) = vbdy_w(j1:j2) + ztcoeff * ptab(i1,j1:j2) 1049 ENDIF 1050 IF(eastern_side) THEN 1051 vbdy_e(j1:j2) = vbdy_e(j1:j2) + ztcoeff * ptab(i1,j1:j2) 1052 ENDIF 1053 IF(southern_side) THEN 1054 vbdy_s(i1:i2) = vbdy_s(i1:i2) + ztcoeff * ptab(i1:i2,j1) 1055 ENDIF 1056 IF(northern_side) THEN 1057 vbdy_n(i1:i2) = vbdy_n(i1:i2) + ztcoeff * ptab(i1:i2,j1) 1058 ENDIF 1059 ! 1060 IF( bdy_tinterp == 0 .OR. bdy_tinterp == 2) THEN 1061 IF(western_side) THEN 1062 vbdy_w(j1:j2) = vbdy_w(j1:j2) / (zrhox*e1v(i1,j1:j2)) & 1063 & * vmask(i1,j1:j2,1) 1064 ENDIF 1065 IF(eastern_side) THEN 1066 vbdy_e(j1:j2) = vbdy_e(j1:j2) / (zrhox*e1v(i1,j1:j2)) & 1067 & * vmask(i1,j1:j2,1) 1068 ENDIF 1069 IF(southern_side) THEN 1070 vbdy_s(i1:i2) = vbdy_s(i1:i2) / (zrhox*e1v(i1:i2,j1)) & 1071 & * vmask(i1:i2,j1,1) 1072 ENDIF 1073 IF(northern_side) THEN 1074 vbdy_n(i1:i2) = vbdy_n(i1:i2) / (zrhox*e1v(i1:i2,j1)) & 1075 & * vmask(i1:i2,j1,1) 1076 ENDIF 1077 ENDIF 1078 ENDIF 1079 ! 1080 END SUBROUTINE interpvnb 1081 1082 SUBROUTINE interpub2b(ptab,i1,i2,j1,j2,before,nb,ndir) 1083 !!---------------------------------------------------------------------- 1084 !! *** ROUTINE interpub2b *** 1085 !!---------------------------------------------------------------------- 1086 INTEGER, INTENT(in) :: i1,i2,j1,j2 1087 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 1088 LOGICAL, INTENT(in) :: before 1089 INTEGER, INTENT(in) :: nb , ndir 1090 !! 1091 INTEGER :: ji,jj 1092 REAL(wp) :: zrhot, zt0, zt1,zat 1093 LOGICAL :: western_side, eastern_side,northern_side,southern_side 1094 !!---------------------------------------------------------------------- 1095 IF( before ) THEN 1096 DO jj=j1,j2 1097 DO ji=i1,i2 1098 ptab(ji,jj) = ub2_b(ji,jj) * e2u(ji,jj) 1099 END DO 1100 END DO 1101 ELSE 1102 western_side = (nb == 1).AND.(ndir == 1) 1103 eastern_side = (nb == 1).AND.(ndir == 2) 1104 southern_side = (nb == 2).AND.(ndir == 1) 1105 northern_side = (nb == 2).AND.(ndir == 2) 1106 zrhot = Agrif_rhot() 728 1107 ! Time indexes bounds for integration 729 1108 zt0 = REAL(Agrif_NbStepint() , wp) / zrhot 730 1109 zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot 731 732 1110 ! Polynomial interpolation coefficients: 733 zaa = zrhot * ( zt1**2._wp * ( zt1 - 1._wp) &734 & - zt0**2._wp * ( zt0 - 1._wp) )735 zab = zrhot * ( zt1 * ( zt1 - 1._wp)**2._wp &736 & - zt0 * ( zt0 - 1._wp)**2._wp )737 1111 zat = zrhot * ( zt1**2._wp * (-2._wp*zt1 + 3._wp) & 738 & - zt0**2._wp * (-2._wp*zt0 + 3._wp) ) 739 740 ! Do time interpolation 741 IF((nbondi == -1).OR.(nbondi == 2)) THEN 742 DO jj=1,jpj 743 zunb(2,jj) = zaa * zuab(2,jj) + zab * zubb(2,jj) + zat * zutn(2,jj) 744 zvnb(2,jj) = zaa * zvab(2,jj) + zab * zvbb(2,jj) + zat * zvtn(2,jj) 745 END DO 746 ENDIF 747 IF((nbondi == 1).OR.(nbondi == 2)) THEN 748 DO jj=1,jpj 749 zunb(nlci-2,jj) = zaa * zuab(nlci-2,jj) + zab * zubb(nlci-2,jj) + zat * zutn(nlci-2,jj) 750 zvnb(nlci-1,jj) = zaa * zvab(nlci-1,jj) + zab * zvbb(nlci-1,jj) + zat * zvtn(nlci-1,jj) 751 END DO 752 ENDIF 753 IF((nbondj == -1).OR.(nbondj == 2)) THEN 754 DO ji=1,jpi 755 zunb(ji,2) = zaa * zuab(ji,2) + zab * zubb(ji,2) + zat * zutn(ji,2) 756 zvnb(ji,2) = zaa * zvab(ji,2) + zab * zvbb(ji,2) + zat * zvtn(ji,2) 757 END DO 758 ENDIF 759 IF((nbondj == 1).OR.(nbondj == 2)) THEN 760 DO ji=1,jpi 761 zunb(ji,nlcj-1) = zaa * zuab(ji,nlcj-1) + zab * zubb(ji,nlcj-1) + zat * zutn(ji,nlcj-1) 762 zvnb(ji,nlcj-2) = zaa * zvab(ji,nlcj-2) + zab * zvbb(ji,nlcj-2) + zat * zvtn(ji,nlcj-2) 763 END DO 764 ENDIF 765 CALL wrk_dealloc( jpi, jpj, zuab, zvab, zubb, zvbb, zutn, zvtn ) 766 767 ELSE ! Linear interpolation 768 zunb(:,:) = 0._wp ; zvnb(:,:) = 0._wp 769 CALL Agrif_Bc_variable(zunb,unb_id,calledweight=zt, procname=interpunb) 770 CALL Agrif_Bc_variable(zvnb,vnb_id,calledweight=zt, procname=interpvnb) 771 ENDIF 772 Agrif_UseSpecialValue = .FALSE. 773 774 ! Fill boundary data arrays: 775 IF((nbondi == -1).OR.(nbondi == 2)) THEN 776 DO jj=1,jpj 777 ubdy_w(jj) = (zunb(2,jj)/(zrhoy*e2u(2,jj))) * umask(2,jj,1) 778 vbdy_w(jj) = (zvnb(2,jj)/(zrhox*e1v(2,jj))) * vmask(2,jj,1) 779 hbdy_w(jj) = zsshn(2,jj) * tmask(2,jj,1) 780 END DO 781 ENDIF 782 783 IF((nbondi == 1).OR.(nbondi == 2)) THEN 784 DO jj=1,jpj 785 ubdy_e(jj) = zunb(nlci-2,jj)/(zrhoy*e2u(nlci-2,jj)) * umask(nlci-2,jj,1) 786 vbdy_e(jj) = zvnb(nlci-1,jj)/(zrhox*e1v(nlci-1,jj)) * vmask(nlci-1,jj,1) 787 hbdy_e(jj) = zsshn(nlci-1,jj) * tmask(nlci-1,jj,1) 788 END DO 789 ENDIF 790 791 IF((nbondj == -1).OR.(nbondj == 2)) THEN 792 DO ji=1,jpi 793 ubdy_s(ji) = zunb(ji,2)/(zrhoy*e2u(ji,2)) * umask(ji,2,1) 794 vbdy_s(ji) = zvnb(ji,2)/(zrhox*e1v(ji,2)) * vmask(ji,2,1) 795 hbdy_s(ji) = zsshn(ji,2) * tmask(ji,2,1) 796 END DO 797 ENDIF 798 799 IF((nbondj == 1).OR.(nbondj == 2)) THEN 800 DO ji=1,jpi 801 ubdy_n(ji) = zunb(ji,nlcj-1)/(zrhoy*e2u(ji,nlcj-1)) * umask(ji,nlcj-1,1) 802 vbdy_n(ji) = zvnb(ji,nlcj-2)/(zrhox*e1v(ji,nlcj-2)) * vmask(ji,nlcj-2,1) 803 hbdy_n(ji) = zsshn(ji,nlcj-1) * tmask(ji,nlcj-1,1) 804 END DO 805 ENDIF 806 807 CALL wrk_dealloc( jpi, jpj, zunb, zvnb, zsshn ) 808 809 END SUBROUTINE Agrif_dta_ts 810 811 SUBROUTINE Agrif_ssh( kt ) 812 !!---------------------------------------------------------------------- 813 !! *** ROUTINE Agrif_DYN *** 814 !!---------------------------------------------------------------------- 815 INTEGER, INTENT(in) :: kt 816 !! 817 !!---------------------------------------------------------------------- 818 819 IF( Agrif_Root() ) RETURN 820 821 822 IF((nbondi == -1).OR.(nbondi == 2)) THEN 823 ssha(2,:)=ssha(3,:) 824 sshn(2,:)=sshn(3,:) 825 ENDIF 826 827 IF((nbondi == 1).OR.(nbondi == 2)) THEN 828 ssha(nlci-1,:)=ssha(nlci-2,:) 829 sshn(nlci-1,:)=sshn(nlci-2,:) 830 ENDIF 831 832 IF((nbondj == -1).OR.(nbondj == 2)) THEN 833 ssha(:,2)=ssha(:,3) 834 sshn(:,2)=sshn(:,3) 835 ENDIF 836 837 IF((nbondj == 1).OR.(nbondj == 2)) THEN 838 ssha(:,nlcj-1)=ssha(:,nlcj-2) 839 sshn(:,nlcj-1)=sshn(:,nlcj-2) 840 ENDIF 841 842 END SUBROUTINE Agrif_ssh 843 844 SUBROUTINE Agrif_ssh_ts( jn ) 845 !!---------------------------------------------------------------------- 846 !! *** ROUTINE Agrif_ssh_ts *** 847 !!---------------------------------------------------------------------- 848 INTEGER, INTENT(in) :: jn 1112 & - zt0**2._wp * (-2._wp*zt0 + 3._wp) ) 1113 ! 1114 IF(western_side ) ubdy_w(j1:j2) = zat * ptab(i1,j1:j2) 1115 IF(eastern_side ) ubdy_e(j1:j2) = zat * ptab(i1,j1:j2) 1116 IF(southern_side) ubdy_s(i1:i2) = zat * ptab(i1:i2,j1) 1117 IF(northern_side) ubdy_n(i1:i2) = zat * ptab(i1:i2,j1) 1118 ENDIF 1119 ! 1120 END SUBROUTINE interpub2b 1121 1122 SUBROUTINE interpvb2b(ptab,i1,i2,j1,j2,before,nb,ndir) 1123 !!---------------------------------------------------------------------- 1124 !! *** ROUTINE interpvb2b *** 1125 !!---------------------------------------------------------------------- 1126 INTEGER, INTENT(in) :: i1,i2,j1,j2 1127 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 1128 LOGICAL, INTENT(in) :: before 1129 INTEGER, INTENT(in) :: nb , ndir 849 1130 !! 850 1131 INTEGER :: ji,jj 851 !!---------------------------------------------------------------------- 852 853 IF((nbondi == -1).OR.(nbondi == 2)) THEN 854 DO jj=1,jpj 855 ssha_e(2,jj) = hbdy_w(jj) 856 END DO 857 ENDIF 858 859 IF((nbondi == 1).OR.(nbondi == 2)) THEN 860 DO jj=1,jpj 861 ssha_e(nlci-1,jj) = hbdy_e(jj) 862 END DO 863 ENDIF 864 865 IF((nbondj == -1).OR.(nbondj == 2)) THEN 866 DO ji=1,jpi 867 ssha_e(ji,2) = hbdy_s(ji) 868 END DO 869 ENDIF 870 871 IF((nbondj == 1).OR.(nbondj == 2)) THEN 872 DO ji=1,jpi 873 ssha_e(ji,nlcj-1) = hbdy_n(ji) 874 END DO 875 ENDIF 876 877 END SUBROUTINE Agrif_ssh_ts 878 879 SUBROUTINE interpsshn(tabres,i1,i2,j1,j2) 880 !!---------------------------------------------------------------------- 881 !! *** ROUTINE interpsshn *** 882 !!---------------------------------------------------------------------- 883 INTEGER, INTENT(in) :: i1,i2,j1,j2 884 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 885 !! 886 INTEGER :: ji,jj 887 !!---------------------------------------------------------------------- 888 889 tabres(i1:i2,j1:j2) = sshn(i1:i2,j1:j2) 890 891 END SUBROUTINE interpsshn 892 893 SUBROUTINE interpu(tabres,i1,i2,j1,j2,k1,k2) 894 !!---------------------------------------------------------------------- 895 !! *** ROUTINE interpu *** 896 !!---------------------------------------------------------------------- 897 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 898 REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres 899 !! 900 INTEGER :: ji,jj,jk 901 !!---------------------------------------------------------------------- 902 903 DO jk=k1,k2 1132 REAL(wp) :: zrhot, zt0, zt1,zat 1133 LOGICAL :: western_side, eastern_side,northern_side,southern_side 1134 !!---------------------------------------------------------------------- 1135 ! 1136 IF( before ) THEN 904 1137 DO jj=j1,j2 905 1138 DO ji=i1,i2 906 tabres(ji,jj,jk) = e2u(ji,jj) * un(ji,jj,jk) 907 tabres(ji,jj,jk) = tabres(ji,jj,jk) * fse3u_n(ji,jj,jk) 908 END DO 909 END DO 910 END DO 911 END SUBROUTINE interpu 912 913 914 SUBROUTINE interpu2d(tabres,i1,i2,j1,j2) 915 !!---------------------------------------------------------------------- 916 !! *** ROUTINE interpu2d *** 917 !!---------------------------------------------------------------------- 918 INTEGER, INTENT(in) :: i1,i2,j1,j2 919 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 920 !! 921 INTEGER :: ji,jj 922 !!---------------------------------------------------------------------- 923 924 DO jj=j1,j2 925 DO ji=i1,i2 926 tabres(ji,jj) = e2u(ji,jj) * ((gcx(ji+1,jj) - gcx(ji,jj))/e1u(ji,jj)) & 927 * umask(ji,jj,1) 928 END DO 929 END DO 930 931 END SUBROUTINE interpu2d 932 933 934 SUBROUTINE interpv(tabres,i1,i2,j1,j2,k1,k2) 935 !!---------------------------------------------------------------------- 936 !! *** ROUTINE interpv *** 937 !!---------------------------------------------------------------------- 1139 ptab(ji,jj) = vb2_b(ji,jj) * e1v(ji,jj) 1140 END DO 1141 END DO 1142 ELSE 1143 western_side = (nb == 1).AND.(ndir == 1) 1144 eastern_side = (nb == 1).AND.(ndir == 2) 1145 southern_side = (nb == 2).AND.(ndir == 1) 1146 northern_side = (nb == 2).AND.(ndir == 2) 1147 zrhot = Agrif_rhot() 1148 ! Time indexes bounds for integration 1149 zt0 = REAL(Agrif_NbStepint() , wp) / zrhot 1150 zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot 1151 ! Polynomial interpolation coefficients: 1152 zat = zrhot * ( zt1**2._wp * (-2._wp*zt1 + 3._wp) & 1153 & - zt0**2._wp * (-2._wp*zt0 + 3._wp) ) 1154 ! 1155 IF(western_side ) vbdy_w(j1:j2) = zat * ptab(i1,j1:j2) 1156 IF(eastern_side ) vbdy_e(j1:j2) = zat * ptab(i1,j1:j2) 1157 IF(southern_side) vbdy_s(i1:i2) = zat * ptab(i1:i2,j1) 1158 IF(northern_side) vbdy_n(i1:i2) = zat * ptab(i1:i2,j1) 1159 ENDIF 1160 ! 1161 END SUBROUTINE interpvb2b 1162 1163 SUBROUTINE interpe3t(ptab,i1,i2,j1,j2,k1,k2,before,nb,ndir) 1164 !!---------------------------------------------------------------------- 1165 !! *** ROUTINE interpe3t *** 1166 !!---------------------------------------------------------------------- 1167 ! 938 1168 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 939 REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres 940 !! 1169 REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 1170 LOGICAL :: before 1171 INTEGER, INTENT(in) :: nb , ndir 1172 ! 941 1173 INTEGER :: ji, jj, jk 942 !!---------------------------------------------------------------------- 943 944 DO jk=k1,k2 945 DO jj=j1,j2 946 DO ji=i1,i2 947 tabres(ji,jj,jk) = e1v(ji,jj) * vn(ji,jj,jk) 948 tabres(ji,jj,jk) = tabres(ji,jj,jk) * fse3v_n(ji,jj,jk) 949 END DO 950 END DO 951 END DO 952 953 END SUBROUTINE interpv 954 955 956 SUBROUTINE interpv2d(tabres,i1,i2,j1,j2) 957 !!---------------------------------------------------------------------- 958 !! *** ROUTINE interpu2d *** 959 !!---------------------------------------------------------------------- 960 INTEGER, INTENT(in) :: i1,i2,j1,j2 961 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 962 !! 963 INTEGER :: ji,jj 964 !!---------------------------------------------------------------------- 965 966 DO jj=j1,j2 967 DO ji=i1,i2 968 tabres(ji,jj) = e1v(ji,jj) * ((gcx(ji,jj+1) - gcx(ji,jj))/e2v(ji,jj)) & 969 * vmask(ji,jj,1) 970 END DO 971 END DO 972 973 END SUBROUTINE interpv2d 974 975 SUBROUTINE interpunb(tabres,i1,i2,j1,j2) 976 !!---------------------------------------------------------------------- 977 !! *** ROUTINE interpunb *** 978 !!---------------------------------------------------------------------- 979 INTEGER, INTENT(in) :: i1,i2,j1,j2 980 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 981 !! 982 INTEGER :: ji,jj 983 !!---------------------------------------------------------------------- 984 985 DO jj=j1,j2 986 DO ji=i1,i2 987 tabres(ji,jj) = un_b(ji,jj) * e2u(ji,jj) * hu(ji,jj) 988 END DO 989 END DO 990 991 END SUBROUTINE interpunb 992 993 SUBROUTINE interpvnb(tabres,i1,i2,j1,j2) 994 !!---------------------------------------------------------------------- 995 !! *** ROUTINE interpvnb *** 996 !!---------------------------------------------------------------------- 997 INTEGER, INTENT(in) :: i1,i2,j1,j2 998 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 999 !! 1000 INTEGER :: ji,jj 1001 !!---------------------------------------------------------------------- 1002 1003 DO jj=j1,j2 1004 DO ji=i1,i2 1005 tabres(ji,jj) = vn_b(ji,jj) * e1v(ji,jj) * hv(ji,jj) 1006 END DO 1007 END DO 1008 1009 END SUBROUTINE interpvnb 1010 1011 SUBROUTINE interpub2b(tabres,i1,i2,j1,j2) 1012 !!---------------------------------------------------------------------- 1013 !! *** ROUTINE interpub2b *** 1014 !!---------------------------------------------------------------------- 1015 INTEGER, INTENT(in) :: i1,i2,j1,j2 1016 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 1017 !! 1018 INTEGER :: ji,jj 1019 !!---------------------------------------------------------------------- 1020 1021 DO jj=j1,j2 1022 DO ji=i1,i2 1023 tabres(ji,jj) = ub2_b(ji,jj) * e2u(ji,jj) 1024 END DO 1025 END DO 1026 1027 END SUBROUTINE interpub2b 1028 1029 SUBROUTINE interpvb2b(tabres,i1,i2,j1,j2) 1030 !!---------------------------------------------------------------------- 1031 !! *** ROUTINE interpvb2b *** 1032 !!---------------------------------------------------------------------- 1033 INTEGER, INTENT(in) :: i1,i2,j1,j2 1034 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 1035 !! 1036 INTEGER :: ji,jj 1037 !!---------------------------------------------------------------------- 1038 1039 DO jj=j1,j2 1040 DO ji=i1,i2 1041 tabres(ji,jj) = vb2_b(ji,jj) * e1v(ji,jj) 1042 END DO 1043 END DO 1044 1045 END SUBROUTINE interpvb2b 1174 LOGICAL :: western_side, eastern_side, northern_side, southern_side 1175 REAL(wp) :: ztmpmsk 1176 !!---------------------------------------------------------------------- 1177 ! 1178 IF (before) THEN 1179 DO jk=k1,k2 1180 DO jj=j1,j2 1181 DO ji=i1,i2 1182 ptab(ji,jj,jk) = tmask(ji,jj,jk) * e3t_0(ji,jj,jk) 1183 END DO 1184 END DO 1185 END DO 1186 ELSE 1187 western_side = (nb == 1).AND.(ndir == 1) 1188 eastern_side = (nb == 1).AND.(ndir == 2) 1189 southern_side = (nb == 2).AND.(ndir == 1) 1190 northern_side = (nb == 2).AND.(ndir == 2) 1191 1192 DO jk=k1,k2 1193 DO jj=j1,j2 1194 DO ji=i1,i2 1195 ! Get velocity mask at boundary edge points: 1196 IF (western_side) ztmpmsk = umask(ji ,jj ,1) 1197 IF (eastern_side) ztmpmsk = umask(nlci-2,jj ,1) 1198 IF (northern_side) ztmpmsk = vmask(ji ,nlcj-2,1) 1199 IF (southern_side) ztmpmsk = vmask(ji ,2 ,1) 1200 1201 IF (ABS(ptab(ji,jj,jk) - tmask(ji,jj,jk) * e3t_0(ji,jj,jk))*ztmpmsk > 1.D-2) THEN 1202 IF (western_side) THEN 1203 WRITE(numout,*) 'ERROR bathymetry merge at the western border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk 1204 ELSEIF (eastern_side) THEN 1205 WRITE(numout,*) 'ERROR bathymetry merge at the eastern border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk 1206 ELSEIF (southern_side) THEN 1207 WRITE(numout,*) 'ERROR bathymetry merge at the southern border ji,jj,jk', ji+nimpp-1,jj+njmpp-1,jk 1208 ELSEIF (northern_side) THEN 1209 WRITE(numout,*) 'ERROR bathymetry merge at the northen border ji,jj,jk', ji+nimpp-1,jj+njmpp-1,jk 1210 ENDIF 1211 WRITE(numout,*) ' ptab(ji,jj,jk), fse3t(ji,jj,jk) ', ptab(ji,jj,jk), e3t_0(ji,jj,jk) 1212 kindic_agr = kindic_agr + 1 1213 ENDIF 1214 END DO 1215 END DO 1216 END DO 1217 1218 ENDIF 1219 ! 1220 END SUBROUTINE interpe3t 1221 1222 SUBROUTINE interpumsk(ptab,i1,i2,j1,j2,k1,k2,before,nb,ndir) 1223 !!---------------------------------------------------------------------- 1224 !! *** ROUTINE interpumsk *** 1225 !!---------------------------------------------------------------------- 1226 ! 1227 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 1228 REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 1229 LOGICAL :: before 1230 INTEGER, INTENT(in) :: nb , ndir 1231 ! 1232 INTEGER :: ji, jj, jk 1233 LOGICAL :: western_side, eastern_side 1234 !!---------------------------------------------------------------------- 1235 ! 1236 IF (before) THEN 1237 DO jk=k1,k2 1238 DO jj=j1,j2 1239 DO ji=i1,i2 1240 ptab(ji,jj,jk) = umask(ji,jj,jk) 1241 END DO 1242 END DO 1243 END DO 1244 ELSE 1245 1246 western_side = (nb == 1).AND.(ndir == 1) 1247 eastern_side = (nb == 1).AND.(ndir == 2) 1248 DO jk=k1,k2 1249 DO jj=j1,j2 1250 DO ji=i1,i2 1251 ! Velocity mask at boundary edge points: 1252 IF (ABS(ptab(ji,jj,jk) - umask(ji,jj,jk)) > 1.D-2) THEN 1253 IF (western_side) THEN 1254 WRITE(numout,*) 'ERROR with umask at the western border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk 1255 WRITE(numout,*) ' masks: parent, child ', ptab(ji,jj,jk), umask(ji,jj,jk) 1256 kindic_agr = kindic_agr + 1 1257 ELSEIF (eastern_side) THEN 1258 WRITE(numout,*) 'ERROR with umask at the eastern border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk 1259 WRITE(numout,*) ' masks: parent, child ', ptab(ji,jj,jk), umask(ji,jj,jk) 1260 kindic_agr = kindic_agr + 1 1261 ENDIF 1262 ENDIF 1263 END DO 1264 END DO 1265 END DO 1266 1267 ENDIF 1268 ! 1269 END SUBROUTINE interpumsk 1270 1271 SUBROUTINE interpvmsk(ptab,i1,i2,j1,j2,k1,k2,before,nb,ndir) 1272 !!---------------------------------------------------------------------- 1273 !! *** ROUTINE interpvmsk *** 1274 !!---------------------------------------------------------------------- 1275 ! 1276 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 1277 REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 1278 LOGICAL :: before 1279 INTEGER, INTENT(in) :: nb , ndir 1280 ! 1281 INTEGER :: ji, jj, jk 1282 LOGICAL :: northern_side, southern_side 1283 !!---------------------------------------------------------------------- 1284 ! 1285 IF (before) THEN 1286 DO jk=k1,k2 1287 DO jj=j1,j2 1288 DO ji=i1,i2 1289 ptab(ji,jj,jk) = vmask(ji,jj,jk) 1290 END DO 1291 END DO 1292 END DO 1293 ELSE 1294 1295 southern_side = (nb == 2).AND.(ndir == 1) 1296 northern_side = (nb == 2).AND.(ndir == 2) 1297 DO jk=k1,k2 1298 DO jj=j1,j2 1299 DO ji=i1,i2 1300 ! Velocity mask at boundary edge points: 1301 IF (ABS(ptab(ji,jj,jk) - vmask(ji,jj,jk)) > 1.D-2) THEN 1302 IF (southern_side) THEN 1303 WRITE(numout,*) 'ERROR with vmask at the southern border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk 1304 WRITE(numout,*) ' masks: parent, child ', ptab(ji,jj,jk), vmask(ji,jj,jk) 1305 kindic_agr = kindic_agr + 1 1306 ELSEIF (northern_side) THEN 1307 WRITE(numout,*) 'ERROR with vmask at the northern border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk 1308 WRITE(numout,*) ' masks: parent, child ', ptab(ji,jj,jk), vmask(ji,jj,jk) 1309 kindic_agr = kindic_agr + 1 1310 ENDIF 1311 ENDIF 1312 END DO 1313 END DO 1314 END DO 1315 1316 ENDIF 1317 ! 1318 END SUBROUTINE interpvmsk 1319 1320 # if defined key_zdftke 1321 1322 SUBROUTINE interpavm(ptab,i1,i2,j1,j2,k1,k2,before) 1323 !!---------------------------------------------------------------------- 1324 !! *** ROUTINE interavm *** 1325 !!---------------------------------------------------------------------- 1326 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 1327 REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 1328 LOGICAL, INTENT(in) :: before 1329 !!---------------------------------------------------------------------- 1330 ! 1331 IF( before) THEN 1332 ptab (i1:i2,j1:j2,k1:k2) = avm_k(i1:i2,j1:j2,k1:k2) 1333 ELSE 1334 avm_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2) 1335 ENDIF 1336 ! 1337 END SUBROUTINE interpavm 1338 1339 # endif /* key_zdftke */ 1046 1340 1047 1341 #else -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/NST_SRC/agrif_opa_sponge.F90
r6836 r6839 1 1 #define SPONGE && define SPONGE_TOP 2 2 3 M oduleagrif_opa_sponge3 MODULE agrif_opa_sponge 4 4 #if defined key_agrif && ! defined key_offline 5 5 USE par_oce … … 9 9 USE agrif_oce 10 10 USE wrk_nemo 11 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 11 12 12 13 IMPLICIT NONE 13 14 PRIVATE 14 15 15 PUBLIC Agrif_Sponge, Agrif_Sponge_Tra, Agrif_Sponge_Dyn, interptsn, interpun, interpvn 16 17 !! * Substitutions 16 PUBLIC Agrif_Sponge, Agrif_Sponge_Tra, Agrif_Sponge_Dyn 17 PUBLIC interptsn_sponge, interpun_sponge, interpvn_sponge 18 19 !! * Substitutions 18 20 # include "domzgr_substitute.h90" 19 21 !!---------------------------------------------------------------------- … … 23 25 !!---------------------------------------------------------------------- 24 26 25 27 CONTAINS 26 28 27 29 SUBROUTINE Agrif_Sponge_Tra … … 30 32 !!--------------------------------------------- 31 33 !! 32 INTEGER :: ji,jj,jk,jn33 34 REAL(wp) :: timecoeff 34 REAL(wp) :: ztsa, zabe1, zabe2, zbtr35 REAL(wp), POINTER, DIMENSION(:,: ) :: ztu, ztv36 REAL(wp), POINTER, DIMENSION(:,:,:,:) :: ztab37 REAL(wp), POINTER, DIMENSION(:,:,:,:) :: tsbdiff38 35 39 36 #if defined SPONGE 40 CALL wrk_alloc( jpi, jpj, ztu, ztv )41 CALL wrk_alloc( jpi, jpj, jpk, jpts, ztab, tsbdiff )42 43 37 timecoeff = REAL(Agrif_NbStepint(),wp)/Agrif_rhot() 44 38 39 CALL Agrif_Sponge 45 40 Agrif_SpecialValue=0. 46 41 Agrif_UseSpecialValue = .TRUE. 47 ztab = 0.e0 48 CALL Agrif_Bc_Variable(ztab, tsa_id,calledweight=timecoeff,procname=interptsn) 42 tabspongedone_tsn = .FALSE. 43 44 CALL Agrif_Bc_Variable(tsn_sponge_id,calledweight=timecoeff,procname=interptsn_sponge) 45 49 46 Agrif_UseSpecialValue = .FALSE. 50 51 tsbdiff(:,:,:,:) = tsb(:,:,:,:) - ztab(:,:,:,:)52 53 CALL Agrif_Sponge54 55 DO jn = 1, jpts56 DO jk = 1, jpkm157 !58 DO jj = 1, jpjm159 DO ji = 1, jpim160 zabe1 = umask(ji,jj,jk) * spe1ur(ji,jj) * fse3u(ji,jj,jk)61 zabe2 = vmask(ji,jj,jk) * spe2vr(ji,jj) * fse3v(ji,jj,jk)62 ztu(ji,jj) = zabe1 * ( tsbdiff(ji+1,jj ,jk,jn) - tsbdiff(ji,jj,jk,jn) )63 ztv(ji,jj) = zabe2 * ( tsbdiff(ji ,jj+1,jk,jn) - tsbdiff(ji,jj,jk,jn) )64 ENDDO65 ENDDO66 67 DO jj = 2, jpjm168 DO ji = 2, jpim169 zbtr = spbtr2(ji,jj) / fse3t(ji,jj,jk)70 ! horizontal diffusive trends71 ztsa = zbtr * ( ztu(ji,jj) - ztu(ji-1,jj ) &72 & + ztv(ji,jj) - ztv(ji ,jj-1) )73 ! add it to the general tracer trends74 tsa(ji,jj,jk,jn) = tsa(ji,jj,jk,jn) + ztsa75 END DO76 END DO77 !78 ENDDO79 ENDDO80 81 CALL wrk_dealloc( jpi, jpj, ztu, ztv )82 CALL wrk_dealloc( jpi, jpj, jpk, jpts, ztab, tsbdiff )83 47 #endif 84 48 … … 90 54 !!--------------------------------------------- 91 55 !! 92 INTEGER :: ji,jj,jk93 56 REAL(wp) :: timecoeff 94 REAL(wp) :: ze2u, ze1v, zua, zva, zbtr95 REAL(wp), POINTER, DIMENSION(:,:,:) :: ubdiff, vbdiff96 REAL(wp), POINTER, DIMENSION(:,:,:) :: rotdiff, hdivdiff97 REAL(wp), POINTER, DIMENSION(:,:,:) :: ztab98 57 99 58 #if defined SPONGE 100 CALL wrk_alloc( jpi, jpj, jpk, ztab, ubdiff, vbdiff, rotdiff, hdivdiff )101 102 59 timecoeff = REAL(Agrif_NbStepint(),wp)/Agrif_rhot() 103 60 104 61 Agrif_SpecialValue=0. 105 62 Agrif_UseSpecialValue = ln_spc_dyn 106 ztab = 0.e0 107 CALL Agrif_Bc_Variable(ztab, ua_id,calledweight=timecoeff,procname=interpun) 63 64 tabspongedone_u = .FALSE. 65 tabspongedone_v = .FALSE. 66 CALL Agrif_Bc_Variable(un_sponge_id,calledweight=timecoeff,procname=interpun_sponge) 67 68 tabspongedone_u = .FALSE. 69 tabspongedone_v = .FALSE. 70 CALL Agrif_Bc_Variable(vn_sponge_id,calledweight=timecoeff,procname=interpvn_sponge) 71 108 72 Agrif_UseSpecialValue = .FALSE. 109 110 ubdiff(:,:,:) = ( ub(:,:,:) - ztab(:,:,:) ) * umask(:,:,:)111 112 ztab = 0.e0113 Agrif_SpecialValue=0.114 Agrif_UseSpecialValue = ln_spc_dyn115 CALL Agrif_Bc_Variable(ztab, va_id,calledweight=timecoeff,procname=interpvn)116 Agrif_UseSpecialValue = .FALSE.117 118 vbdiff(:,:,:) = ( vb(:,:,:) - ztab(:,:,:) ) * vmask(:,:,:)119 120 CALL Agrif_Sponge121 122 DO jk = 1,jpkm1123 ubdiff(:,:,jk) = ubdiff(:,:,jk) * spe1ur2(:,:)124 vbdiff(:,:,jk) = vbdiff(:,:,jk) * spe2vr2(:,:)125 ENDDO126 127 hdivdiff = 0.128 rotdiff = 0.129 130 DO jk = 1, jpkm1 ! Horizontal slab131 ! ! ===============132 133 ! ! --------134 ! Horizontal divergence ! div135 ! ! --------136 DO jj = 2, jpjm1137 DO ji = 2, jpim1 ! vector opt.138 zbtr = spbtr2(ji,jj) / fse3t(ji,jj,jk)139 hdivdiff(ji,jj,jk) = ( e2u(ji ,jj ) * fse3u(ji ,jj ,jk) * ubdiff(ji ,jj ,jk) &140 & - e2u(ji-1,jj ) * fse3u(ji-1,jj ,jk) * ubdiff(ji-1,jj ,jk) &141 & + e1v(ji ,jj ) * fse3v(ji ,jj ,jk) * vbdiff(ji ,jj ,jk) &142 & - e1v(ji ,jj-1) * fse3v(ji ,jj-1,jk) * vbdiff(ji ,jj-1,jk) ) * zbtr143 END DO144 END DO145 146 DO jj = 1, jpjm1147 DO ji = 1, jpim1 ! vector opt.148 zbtr = spbtr3(ji,jj) * fse3f(ji,jj,jk)149 rotdiff(ji,jj,jk) = ( e2v(ji+1,jj ) * vbdiff(ji+1,jj ,jk) - e2v(ji,jj) * vbdiff(ji,jj,jk) &150 & - e1u(ji ,jj+1) * ubdiff(ji ,jj+1,jk) + e1u(ji,jj) * ubdiff(ji,jj,jk) ) &151 & * fmask(ji,jj,jk) * zbtr152 END DO153 END DO154 155 ENDDO156 157 ! ! ===============158 DO jk = 1, jpkm1 ! Horizontal slab159 ! ! ===============160 DO jj = 2, jpjm1161 DO ji = 2, jpim1 ! vector opt.162 ! horizontal diffusive trends163 zua = - ( rotdiff (ji ,jj,jk) - rotdiff (ji,jj-1,jk) ) / ( e2u(ji,jj) * fse3u(ji,jj,jk) ) &164 + ( hdivdiff(ji+1,jj,jk) - hdivdiff(ji,jj ,jk) ) / e1u(ji,jj)165 166 zva = + ( rotdiff (ji,jj ,jk) - rotdiff (ji-1,jj,jk) ) / ( e1v(ji,jj) * fse3v(ji,jj,jk) ) &167 + ( hdivdiff(ji,jj+1,jk) - hdivdiff(ji ,jj,jk) ) / e2v(ji,jj)168 ! add it to the general momentum trends169 ua(ji,jj,jk) = ua(ji,jj,jk) + zua170 va(ji,jj,jk) = va(ji,jj,jk) + zva171 END DO172 END DO173 ! ! ===============174 END DO ! End of slab175 ! ! ===============176 CALL wrk_dealloc( jpi, jpj, jpk, ztab, ubdiff, vbdiff, rotdiff, hdivdiff )177 73 #endif 178 74 … … 199 95 CALL wrk_alloc( jpi, jpj, ztabramp ) 200 96 201 ispongearea = 2 + 2* Agrif_irhox()97 ispongearea = 2 + nn_sponge_len * Agrif_irhox() 202 98 ilci = nlci - ispongearea 203 99 ilcj = nlcj - ispongearea 204 100 z1spongearea = 1._wp / REAL( ispongearea - 2 ) 205 spbtr2(:,:) = 1. / ( e1t(:,:) * e2t(:,:) ) 206 207 ztabramp(:,:) = 0. 101 102 ztabramp(:,:) = 0._wp 208 103 209 104 IF( (nbondi == -1) .OR. (nbondi == 2) ) THEN … … 254 149 ! Tracers 255 150 IF( .NOT. spongedoneT ) THEN 256 spe1ur(:,:) = 0. 257 spe2vr(:,:) = 0. 258 259 IF( (nbondi == -1) .OR. (nbondi == 2) ) THEN 260 spe1ur(2:ispongearea-1,: ) = visc_tra & 261 & * 0.5 * ( ztabramp(2:ispongearea-1,: ) & 262 & + ztabramp(3:ispongearea ,: ) ) & 263 & * e2u(2:ispongearea-1,:) / e1u(2:ispongearea-1,:) 264 265 spe2vr(2:ispongearea ,1:jpjm1 ) = visc_tra & 266 & * 0.5 * ( ztabramp(2:ispongearea ,1:jpjm1) & 267 & + ztabramp(2:ispongearea,2 :jpj ) ) & 268 & * e1v(2:ispongearea,1:jpjm1) / e2v(2:ispongearea,1:jpjm1) 269 ENDIF 270 271 IF( (nbondi == 1) .OR. (nbondi == 2) ) THEN 272 spe1ur(ilci+1:nlci-2,: ) = visc_tra & 273 & * 0.5 * ( ztabramp(ilci+1:nlci-2,: ) & 274 & + ztabramp(ilci+2:nlci-1,: ) ) & 275 & * e2u(ilci+1:nlci-2,:) / e1u(ilci+1:nlci-2,:) 276 277 spe2vr(ilci+1:nlci-1,1:jpjm1 ) = visc_tra & 278 & * 0.5 * ( ztabramp(ilci+1:nlci-1,1:jpjm1) & 279 & + ztabramp(ilci+1:nlci-1,2:jpj ) ) & 280 & * e1v(ilci+1:nlci-1,1:jpjm1) / e2v(ilci+1:nlci-1,1:jpjm1) 281 ENDIF 282 283 IF( (nbondj == -1) .OR. (nbondj == 2) ) THEN 284 spe1ur(1:jpim1,2:ispongearea ) = visc_tra & 285 & * 0.5 * ( ztabramp(1:jpim1,2:ispongearea ) & 286 & + ztabramp(2:jpi ,2:ispongearea ) ) & 287 & * e2u(1:jpim1,2:ispongearea) / e1u(1:jpim1,2:ispongearea) 288 289 spe2vr(: ,2:ispongearea-1) = visc_tra & 290 & * 0.5 * ( ztabramp(: ,2:ispongearea-1) & 291 & + ztabramp(: ,3:ispongearea ) ) & 292 & * e1v(:,2:ispongearea-1) / e2v(:,2:ispongearea-1) 293 ENDIF 294 295 IF( (nbondj == 1) .OR. (nbondj == 2) ) THEN 296 spe1ur(1:jpim1,ilcj+1:nlcj-1) = visc_tra & 297 & * 0.5 * ( ztabramp(1:jpim1,ilcj+1:nlcj-1) & 298 & + ztabramp(2:jpi ,ilcj+1:nlcj-1) ) & 299 & * e2u(1:jpim1,ilcj+1:nlcj-1) / e1u(1:jpim1,ilcj+1:nlcj-1) 300 301 spe2vr(: ,ilcj+1:nlcj-2) = visc_tra & 302 & * 0.5 * ( ztabramp(: ,ilcj+1:nlcj-2) & 303 & + ztabramp(: ,ilcj+2:nlcj-1) ) & 304 & * e1v(:,ilcj+1:nlcj-2) / e2v(:,ilcj+1:nlcj-2) 305 ENDIF 151 fsaht_spu(:,:) = 0._wp 152 fsaht_spv(:,:) = 0._wp 153 DO jj = 2, jpjm1 154 DO ji = 2, jpim1 ! vector opt. 155 fsaht_spu(ji,jj) = 0.5_wp * visc_tra * (ztabramp(ji,jj) + ztabramp(ji+1,jj )) 156 fsaht_spv(ji,jj) = 0.5_wp * visc_tra * (ztabramp(ji,jj) + ztabramp(ji ,jj+1)) 157 END DO 158 END DO 159 160 CALL lbc_lnk( fsaht_spu, 'U', 1. ) ! Lateral boundary conditions 161 CALL lbc_lnk( fsaht_spv, 'V', 1. ) 306 162 spongedoneT = .TRUE. 307 163 ENDIF … … 309 165 ! Dynamics 310 166 IF( .NOT. spongedoneU ) THEN 311 spe1ur2(:,:) = 0. 312 spe2vr2(:,:) = 0. 313 314 IF( (nbondi == -1) .OR. (nbondi == 2) ) THEN 315 spe1ur2(2:ispongearea-1,: ) = visc_dyn & 316 & * 0.5 * ( ztabramp(2:ispongearea-1,: ) & 317 & + ztabramp(3:ispongearea ,: ) ) 318 spe2vr2(2:ispongearea ,1:jpjm1) = visc_dyn & 319 & * 0.5 * ( ztabramp(2:ispongearea ,1:jpjm1) & 320 & + ztabramp(2:ispongearea ,2:jpj ) ) 321 ENDIF 322 323 IF( (nbondi == 1) .OR. (nbondi == 2) ) THEN 324 spe1ur2(ilci+1:nlci-2 ,: ) = visc_dyn & 325 & * 0.5 * ( ztabramp(ilci+1:nlci-2, : ) & 326 & + ztabramp(ilci+2:nlci-1, : ) ) 327 spe2vr2(ilci+1:nlci-1 ,1:jpjm1) = visc_dyn & 328 & * 0.5 * ( ztabramp(ilci+1:nlci-1,1:jpjm1 ) & 329 & + ztabramp(ilci+1:nlci-1,2:jpj ) ) 330 ENDIF 331 332 IF( (nbondj == -1) .OR. (nbondj == 2) ) THEN 333 spe1ur2(1:jpim1,2:ispongearea ) = visc_dyn & 334 & * 0.5 * ( ztabramp(1:jpim1,2:ispongearea ) & 335 & + ztabramp(2:jpi ,2:ispongearea ) ) 336 spe2vr2(: ,2:ispongearea-1) = visc_dyn & 337 & * 0.5 * ( ztabramp(: ,2:ispongearea-1) & 338 & + ztabramp(: ,3:ispongearea ) ) 339 ENDIF 340 341 IF( (nbondj == 1) .OR. (nbondj == 2) ) THEN 342 spe1ur2(1:jpim1,ilcj+1:nlcj-1 ) = visc_dyn & 343 & * 0.5 * ( ztabramp(1:jpim1,ilcj+1:nlcj-1 ) & 344 & + ztabramp(2:jpi ,ilcj+1:nlcj-1 ) ) 345 spe2vr2(: ,ilcj+1:nlcj-2 ) = visc_dyn & 346 & * 0.5 * ( ztabramp(: ,ilcj+1:nlcj-2 ) & 347 & + ztabramp(: ,ilcj+2:nlcj-1 ) ) 348 ENDIF 167 fsahm_spt(:,:) = 0._wp 168 fsahm_spf(:,:) = 0._wp 169 DO jj = 2, jpjm1 170 DO ji = 2, jpim1 ! vector opt. 171 fsahm_spt(ji,jj) = visc_dyn * ztabramp(ji,jj) 172 fsahm_spf(ji,jj) = 0.25_wp * visc_dyn * ( ztabramp(ji,jj) + ztabramp(ji ,jj+1) & 173 & +ztabramp(ji,jj) + ztabramp(ji+1,jj ) ) 174 END DO 175 END DO 176 177 CALL lbc_lnk( fsahm_spt, 'T', 1. ) ! Lateral boundary conditions 178 CALL lbc_lnk( fsahm_spf, 'F', 1. ) 349 179 spongedoneU = .TRUE. 350 spbtr3(:,:) = 1. / ( e1f(:,:) * e2f(:,:) )351 180 ENDIF 352 181 ! … … 357 186 END SUBROUTINE Agrif_Sponge 358 187 359 SUBROUTINE interptsn (tabres,i1,i2,j1,j2,k1,k2,n1,n2)360 !!--------------------------------------------- 361 !! *** ROUTINE interptsn ***188 SUBROUTINE interptsn_sponge(tabres,i1,i2,j1,j2,k1,k2,n1,n2,before) 189 !!--------------------------------------------- 190 !! *** ROUTINE interptsn_sponge *** 362 191 !!--------------------------------------------- 363 192 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2 364 193 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres 365 366 tabres(i1:i2,j1:j2,k1:k2,n1:n2) = tsn(i1:i2,j1:j2,k1:k2,n1:n2) 367 368 END SUBROUTINE interptsn 369 370 SUBROUTINE interpun(tabres,i1,i2,j1,j2,k1,k2) 371 !!--------------------------------------------- 372 !! *** ROUTINE interpun *** 373 !!--------------------------------------------- 194 LOGICAL, INTENT(in) :: before 195 196 197 INTEGER :: ji, jj, jk, jn ! dummy loop indices 198 INTEGER :: iku, ikv 199 REAL(wp) :: ztsa, zabe1, zabe2, zbtr 200 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2) :: ztu, ztv 201 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2) ::tsbdiff 202 ! 203 IF (before) THEN 204 tabres(i1:i2,j1:j2,k1:k2,n1:n2) = tsn(i1:i2,j1:j2,k1:k2,n1:n2) 205 ELSE 206 207 tsbdiff(:,:,:,:) = tsb(i1:i2,j1:j2,:,:) - tabres(:,:,:,:) 208 DO jn = 1, jpts 209 DO jk = 1, jpkm1 210 DO jj = j1,j2-1 211 DO ji = i1,i2-1 212 zabe1 = fsaht_spu(ji,jj) * umask(ji,jj,jk) * re2u_e1u(ji,jj) * fse3u_n(ji,jj,jk) 213 zabe2 = fsaht_spv(ji,jj) * vmask(ji,jj,jk) * re1v_e2v(ji,jj) * fse3v_n(ji,jj,jk) 214 ztu(ji,jj,jk) = zabe1 * ( tsbdiff(ji+1,jj ,jk,jn) - tsbdiff(ji,jj,jk,jn) ) 215 ztv(ji,jj,jk) = zabe2 * ( tsbdiff(ji ,jj+1,jk,jn) - tsbdiff(ji,jj,jk,jn) ) 216 ENDDO 217 ENDDO 218 219 IF( ln_zps ) THEN ! set gradient at partial step level 220 DO jj = j1,j2-1 221 DO ji = i1,i2-1 222 ! last level 223 iku = mbku(ji,jj) 224 ikv = mbkv(ji,jj) 225 IF( iku == jk ) THEN 226 ztu(ji,jj,jk) = 0._wp 227 ENDIF 228 IF( ikv == jk ) THEN 229 ztv(ji,jj,jk) = 0._wp 230 ENDIF 231 END DO 232 END DO 233 ENDIF 234 ENDDO 235 236 DO jk = 1, jpkm1 237 DO jj = j1+1,j2-1 238 DO ji = i1+1,i2-1 239 240 IF (.NOT. tabspongedone_tsn(ji,jj)) THEN 241 zbtr = r1_e12t(ji,jj) / fse3t_n(ji,jj,jk) 242 ! horizontal diffusive trends 243 ztsa = zbtr * ( ztu(ji,jj,jk) - ztu(ji-1,jj,jk) + ztv(ji,jj,jk) - ztv(ji ,jj-1,jk) ) 244 ! add it to the general tracer trends 245 tsa(ji,jj,jk,jn) = tsa(ji,jj,jk,jn) + ztsa 246 ENDIF 247 248 ENDDO 249 ENDDO 250 251 ENDDO 252 ENDDO 253 254 tabspongedone_tsn(i1+1:i2-1,j1+1:j2-1) = .TRUE. 255 256 ENDIF 257 258 END SUBROUTINE interptsn_sponge 259 260 SUBROUTINE interpun_sponge(tabres,i1,i2,j1,j2,k1,k2, before) 261 !!--------------------------------------------- 262 !! *** ROUTINE interpun_sponge *** 263 !!--------------------------------------------- 374 264 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 375 265 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres 376 377 tabres(i1:i2,j1:j2,k1:k2) = un(i1:i2,j1:j2,k1:k2) 378 379 END SUBROUTINE interpun 380 381 SUBROUTINE interpvn(tabres,i1,i2,j1,j2,k1,k2) 382 !!--------------------------------------------- 383 !! *** ROUTINE interpvn *** 384 !!--------------------------------------------- 266 LOGICAL, INTENT(in) :: before 267 268 INTEGER :: ji,jj,jk 269 270 ! sponge parameters 271 REAL(wp) :: ze2u, ze1v, zua, zva, zbtr 272 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2) :: ubdiff 273 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2) :: rotdiff, hdivdiff 274 INTEGER :: jmax 275 ! 276 277 278 IF (before) THEN 279 tabres = un(i1:i2,j1:j2,:) 280 ELSE 281 282 ubdiff(i1:i2,j1:j2,:) = (ub(i1:i2,j1:j2,:) - tabres(:,:,:))*umask(i1:i2,j1:j2,:) 283 284 DO jk = 1, jpkm1 ! Horizontal slab 285 ! ! =============== 286 287 ! ! -------- 288 ! Horizontal divergence ! div 289 ! ! -------- 290 DO jj = j1,j2 291 DO ji = i1+1,i2 ! vector opt. 292 zbtr = r1_e12t(ji,jj) / fse3t_n(ji,jj,jk) * fsahm_spt(ji,jj) 293 hdivdiff(ji,jj,jk) = ( e2u(ji ,jj)*fse3u_n(ji ,jj,jk) * ubdiff(ji ,jj,jk) & 294 & -e2u(ji-1,jj)*fse3u_n(ji-1,jj,jk) * ubdiff(ji-1,jj,jk) ) * zbtr 295 END DO 296 END DO 297 298 DO jj = j1,j2-1 299 DO ji = i1,i2 ! vector opt. 300 zbtr = r1_e12f(ji,jj) * fse3f_n(ji,jj,jk) * fsahm_spf(ji,jj) 301 rotdiff(ji,jj,jk) = (-e1u(ji,jj+1) * ubdiff(ji,jj+1,jk) & 302 +e1u(ji,jj ) * ubdiff(ji,jj ,jk) & 303 & ) * fmask(ji,jj,jk) * zbtr 304 END DO 305 END DO 306 ENDDO 307 308 ! 309 310 311 312 DO jj = j1+1, j2-1 313 DO ji = i1+1, i2-1 ! vector opt. 314 315 IF (.NOT. tabspongedone_u(ji,jj)) THEN 316 DO jk = 1, jpkm1 ! Horizontal slab 317 ze2u = rotdiff (ji,jj,jk) 318 ze1v = hdivdiff(ji,jj,jk) 319 ! horizontal diffusive trends 320 zua = - ( ze2u - rotdiff (ji,jj-1,jk)) / ( e2u(ji,jj) * fse3u_n(ji,jj,jk) ) & 321 + ( hdivdiff(ji+1,jj,jk) - ze1v ) / e1u(ji,jj) 322 323 ! add it to the general momentum trends 324 ua(ji,jj,jk) = ua(ji,jj,jk) + zua 325 326 END DO 327 ENDIF 328 329 END DO 330 END DO 331 332 tabspongedone_u(i1+1:i2-1,j1+1:j2-1) = .TRUE. 333 334 jmax = j2-1 335 IF ((nbondj == 1).OR.(nbondj == 2)) jmax = MIN(jmax,nlcj-3) 336 337 DO jj = j1+1, jmax 338 DO ji = i1+1, i2 ! vector opt. 339 340 IF (.NOT. tabspongedone_v(ji,jj)) THEN 341 DO jk = 1, jpkm1 ! Horizontal slab 342 ze2u = rotdiff (ji,jj,jk) 343 ze1v = hdivdiff(ji,jj,jk) 344 345 ! horizontal diffusive trends 346 zva = + ( ze2u - rotdiff (ji-1,jj,jk)) / ( e1v(ji,jj) * fse3v_n(ji,jj,jk) ) & 347 + ( hdivdiff(ji,jj+1,jk) - ze1v ) / e2v(ji,jj) 348 349 ! add it to the general momentum trends 350 va(ji,jj,jk) = va(ji,jj,jk) + zva 351 END DO 352 ENDIF 353 354 END DO 355 END DO 356 357 358 tabspongedone_v(i1+1:i2,j1+1:jmax) = .TRUE. 359 360 ENDIF 361 362 363 END SUBROUTINE interpun_sponge 364 365 366 SUBROUTINE interpvn_sponge(tabres,i1,i2,j1,j2,k1,k2, before,nb,ndir) 367 !!--------------------------------------------- 368 !! *** ROUTINE interpvn_sponge *** 369 !!--------------------------------------------- 385 370 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 386 371 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres 387 388 tabres(i1:i2,j1:j2,k1:k2) = vn(i1:i2,j1:j2,k1:k2) 389 390 END SUBROUTINE interpvn 372 LOGICAL, INTENT(in) :: before 373 INTEGER, INTENT(in) :: nb , ndir 374 375 INTEGER :: ji,jj,jk 376 377 REAL(wp) :: ze2u, ze1v, zua, zva, zbtr 378 379 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2) :: vbdiff 380 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2) :: rotdiff, hdivdiff 381 INTEGER :: imax 382 ! 383 384 IF (before) THEN 385 tabres = vn(i1:i2,j1:j2,:) 386 ELSE 387 388 vbdiff(i1:i2,j1:j2,:) = (vb(i1:i2,j1:j2,:) - tabres(:,:,:))*vmask(i1:i2,j1:j2,:) 389 390 DO jk = 1, jpkm1 ! Horizontal slab 391 ! ! =============== 392 393 ! ! -------- 394 ! Horizontal divergence ! div 395 ! ! -------- 396 DO jj = j1+1,j2 397 DO ji = i1,i2 ! vector opt. 398 zbtr = r1_e12t(ji,jj) / fse3t_n(ji,jj,jk) * fsahm_spt(ji,jj) 399 hdivdiff(ji,jj,jk) = ( e1v(ji,jj ) * fse3v(ji,jj ,jk) * vbdiff(ji,jj ,jk) & 400 & -e1v(ji,jj-1) * fse3v(ji,jj-1,jk) * vbdiff(ji,jj-1,jk) ) * zbtr 401 END DO 402 END DO 403 DO jj = j1,j2 404 DO ji = i1,i2-1 ! vector opt. 405 zbtr = r1_e12f(ji,jj) * fse3f_n(ji,jj,jk) * fsahm_spf(ji,jj) 406 rotdiff(ji,jj,jk) = ( e2v(ji+1,jj) * vbdiff(ji+1,jj,jk) & 407 & -e2v(ji ,jj) * vbdiff(ji ,jj,jk) & 408 & ) * fmask(ji,jj,jk) * zbtr 409 END DO 410 END DO 411 ENDDO 412 413 ! ! =============== 414 ! 415 416 imax = i2-1 417 IF ((nbondi == 1).OR.(nbondi == 2)) imax = MIN(imax,nlci-3) 418 419 DO jj = j1+1, j2 420 DO ji = i1+1, imax ! vector opt. 421 IF (.NOT. tabspongedone_u(ji,jj)) THEN 422 DO jk = 1, jpkm1 ! Horizontal slab 423 ze2u = rotdiff (ji,jj,jk) 424 ze1v = hdivdiff(ji,jj,jk) 425 ! horizontal diffusive trends 426 zua = - ( ze2u - rotdiff (ji,jj-1,jk)) / ( e2u(ji,jj) * fse3u_n(ji,jj,jk) ) + ( hdivdiff(ji+1,jj,jk) - ze1v) & 427 / e1u(ji,jj) 428 429 430 ! add it to the general momentum trends 431 ua(ji,jj,jk) = ua(ji,jj,jk) + zua 432 END DO 433 434 ENDIF 435 END DO 436 END DO 437 438 tabspongedone_u(i1+1:imax,j1+1:j2) = .TRUE. 439 440 DO jj = j1+1, j2-1 441 DO ji = i1+1, i2-1 ! vector opt. 442 IF (.NOT. tabspongedone_v(ji,jj)) THEN 443 DO jk = 1, jpkm1 ! Horizontal slab 444 ze2u = rotdiff (ji,jj,jk) 445 ze1v = hdivdiff(ji,jj,jk) 446 ! horizontal diffusive trends 447 448 zva = + ( ze2u - rotdiff (ji-1,jj,jk)) / ( e1v(ji,jj) * fse3v_n(ji,jj,jk) ) + ( hdivdiff(ji,jj+1,jk) - ze1v) & 449 / e2v(ji,jj) 450 451 ! add it to the general momentum trends 452 va(ji,jj,jk) = va(ji,jj,jk) + zva 453 END DO 454 ENDIF 455 END DO 456 END DO 457 tabspongedone_v(i1+1:i2-1,j1+1:j2-1) = .TRUE. 458 ENDIF 459 460 END SUBROUTINE interpvn_sponge 391 461 392 462 #else -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/NST_SRC/agrif_opa_update.F90
r6836 r6839 1 #define TWO_WAY 2 1 #define TWO_WAY /* TWO WAY NESTING */ 2 #undef DECAL_FEEDBACK /* SEPARATION of INTERFACES*/ 3 3 4 MODULE agrif_opa_update 4 5 #if defined key_agrif && ! defined key_offline … … 11 12 USE wrk_nemo 12 13 USE dynspg_oce 14 USE zdf_oce ! vertical physics: ocean variables 13 15 14 16 IMPLICIT NONE 15 17 PRIVATE 16 18 17 PUBLIC Agrif_Update_Tra, Agrif_Update_Dyn 18 19 INTEGER, PUBLIC :: nbcline = 020 19 PUBLIC Agrif_Update_Tra, Agrif_Update_Dyn,Update_Scales 20 # if defined key_zdftke 21 PUBLIC Agrif_Update_Tke 22 # endif 21 23 !!---------------------------------------------------------------------- 22 !! NEMO/NST 3. 3, NEMO Consortium (2010)24 !! NEMO/NST 3.6 , NEMO Consortium (2010) 23 25 !! $Id$ 24 26 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 27 29 CONTAINS 28 30 29 SUBROUTINE Agrif_Update_Tra( kt)31 RECURSIVE SUBROUTINE Agrif_Update_Tra( ) 30 32 !!--------------------------------------------- 31 33 !! *** ROUTINE Agrif_Update_Tra *** 32 34 !!--------------------------------------------- 33 !! 34 INTEGER, INTENT(in) :: kt 35 REAL(wp), POINTER, DIMENSION(:,:,:,:) :: ztab 36 37 38 IF((Agrif_NbStepint() .NE. (Agrif_irhot()-1)).AND.(kt /= 0)) RETURN 39 #if defined TWO_WAY 40 CALL wrk_alloc( jpi, jpj, jpk, jpts, ztab ) 35 ! 36 IF (Agrif_Root()) RETURN 37 ! 38 #if defined TWO_WAY 39 IF (lwp.AND.lk_agrif_debug) Write(*,*) 'Update tracers from grid Number',Agrif_Fixed(), 'nbcline', nbcline 41 40 42 41 Agrif_UseSpecialValueInUpdate = .TRUE. 43 42 Agrif_SpecialValueFineGrid = 0. 44 43 ! 45 44 IF (MOD(nbcline,nbclineupdate) == 0) THEN 46 CALL Agrif_Update_Variable(ztab,tsn_id, procname=updateTS) 47 ELSE 48 CALL Agrif_Update_Variable(ztab,tsn_id,locupdate=(/0,2/), procname=updateTS) 49 ENDIF 50 45 # if ! defined DECAL_FEEDBACK 46 CALL Agrif_Update_Variable(tsn_id, procname=updateTS) 47 # else 48 CALL Agrif_Update_Variable(tsn_id, locupdate=(/1,0/),procname=updateTS) 49 # endif 50 ELSE 51 # if ! defined DECAL_FEEDBACK 52 CALL Agrif_Update_Variable(tsn_id,locupdate=(/0,2/), procname=updateTS) 53 # else 54 CALL Agrif_Update_Variable(tsn_id,locupdate=(/1,2/), procname=updateTS) 55 # endif 56 ENDIF 57 ! 51 58 Agrif_UseSpecialValueInUpdate = .FALSE. 52 53 CALL wrk_dealloc( jpi, jpj, jpk, jpts, ztab ) 59 ! 60 IF ( lk_agrif_doupd ) THEN ! Initialisation: do recursive update: 61 CALL Agrif_ChildGrid_To_ParentGrid() 62 CALL Agrif_Update_Tra() 63 CALL Agrif_ParentGrid_To_ChildGrid() 64 ENDIF 65 ! 54 66 #endif 55 67 ! 56 68 END SUBROUTINE Agrif_Update_Tra 57 69 58 SUBROUTINE Agrif_Update_Dyn( kt)70 RECURSIVE SUBROUTINE Agrif_Update_Dyn( ) 59 71 !!--------------------------------------------- 60 72 !! *** ROUTINE Agrif_Update_Dyn *** 61 73 !!--------------------------------------------- 62 !! 63 INTEGER, INTENT(in) :: kt 64 REAL(wp), POINTER, DIMENSION(:,:) :: ztab2d 65 REAL(wp), POINTER, DIMENSION(:,:,:) :: ztab 66 67 68 IF ((Agrif_NbStepint() .NE. (Agrif_irhot()-1)).AND.(kt /= 0)) Return 74 ! 75 IF (Agrif_Root()) RETURN 76 ! 69 77 #if defined TWO_WAY 70 CALL wrk_alloc( jpi, jpj, ztab2d ) 71 CALL wrk_alloc( jpi, jpj, jpk, ztab ) 72 78 IF (lwp.AND.lk_agrif_debug) Write(*,*) 'Update momentum from grid Number',Agrif_Fixed(), 'nbcline', nbcline 79 80 Agrif_UseSpecialValueInUpdate = .FALSE. 81 Agrif_SpecialValueFineGrid = 0. 82 ! 73 83 IF (mod(nbcline,nbclineupdate) == 0) THEN 74 CALL Agrif_Update_Variable(ztab,un_id,procname = updateU) 75 CALL Agrif_Update_Variable(ztab,vn_id,procname = updateV) 76 ELSE 77 CALL Agrif_Update_Variable(ztab,un_id,locupdate=(/0,1/),procname = updateU) 78 CALL Agrif_Update_Variable(ztab,vn_id,locupdate=(/0,1/),procname = updateV) 79 ENDIF 80 81 CALL Agrif_Update_Variable(ztab2d,e1u_id,procname = updateU2d) 82 CALL Agrif_Update_Variable(ztab2d,e2v_id,procname = updateV2d) 83 84 #if defined key_dynspg_ts 84 # if ! defined DECAL_FEEDBACK 85 CALL Agrif_Update_Variable(un_update_id,procname = updateU) 86 CALL Agrif_Update_Variable(vn_update_id,procname = updateV) 87 # else 88 CALL Agrif_Update_Variable(un_update_id,locupdate1=(/0,-1/),locupdate2=(/1,-2/),procname = updateU) 89 CALL Agrif_Update_Variable(vn_update_id,locupdate1=(/1,-2/),locupdate2=(/0,-1/),procname = updateV) 90 # endif 91 ELSE 92 # if ! defined DECAL_FEEDBACK 93 CALL Agrif_Update_Variable(un_update_id,locupdate=(/0,1/),procname = updateU) 94 CALL Agrif_Update_Variable(vn_update_id,locupdate=(/0,1/),procname = updateV) 95 # else 96 CALL Agrif_Update_Variable(un_update_id,locupdate1=(/0,1/),locupdate2=(/1,1/),procname = updateU) 97 CALL Agrif_Update_Variable(vn_update_id,locupdate1=(/1,1/),locupdate2=(/0,1/),procname = updateV) 98 # endif 99 ENDIF 100 101 # if ! defined DECAL_FEEDBACK 102 CALL Agrif_Update_Variable(e1u_id,procname = updateU2d) 103 CALL Agrif_Update_Variable(e2v_id,procname = updateV2d) 104 # else 105 CALL Agrif_Update_Variable(e1u_id,locupdate1=(/0,-1/),locupdate2=(/1,-2/),procname = updateU2d) 106 CALL Agrif_Update_Variable(e2v_id,locupdate1=(/1,-2/),locupdate2=(/0,-1/),procname = updateV2d) 107 # endif 108 109 # if defined key_dynspg_ts 85 110 IF (ln_bt_fw) THEN 86 111 ! Update time integrated transports 87 112 IF (mod(nbcline,nbclineupdate) == 0) THEN 88 CALL Agrif_Update_Variable(ztab2d,ub2b_id,procname = updateub2b) 89 CALL Agrif_Update_Variable(ztab2d,vb2b_id,procname = updatevb2b) 113 # if ! defined DECAL_FEEDBACK 114 CALL Agrif_Update_Variable(ub2b_update_id,procname = updateub2b) 115 CALL Agrif_Update_Variable(vb2b_update_id,procname = updatevb2b) 116 # else 117 CALL Agrif_Update_Variable(ub2b_update_id,locupdate1=(/0,-1/),locupdate2=(/1,-2/),procname = updateub2b) 118 CALL Agrif_Update_Variable(vb2b_update_id,locupdate1=(/1,-2/),locupdate2=(/0,-1/),procname = updatevb2b) 119 # endif 90 120 ELSE 91 CALL Agrif_Update_Variable(ztab2d,ub2b_id,locupdate=(/0,1/),procname = updateub2b) 92 CALL Agrif_Update_Variable(ztab2d,vb2b_id,locupdate=(/0,1/),procname = updatevb2b) 121 # if ! defined DECAL_FEEDBACK 122 CALL Agrif_Update_Variable(ub2b_update_id,locupdate=(/0,1/),procname = updateub2b) 123 CALL Agrif_Update_Variable(vb2b_update_id,locupdate=(/0,1/),procname = updatevb2b) 124 # else 125 CALL Agrif_Update_Variable(ub2b_update_id,locupdate1=(/0,1/),locupdate2=(/1,1/),procname = updateub2b) 126 CALL Agrif_Update_Variable(vb2b_update_id,locupdate1=(/1,1/),locupdate2=(/0,1/),procname = updatevb2b) 127 # endif 93 128 ENDIF 94 END IF 129 END IF 130 # endif 131 ! 132 nbcline = nbcline + 1 133 ! 134 Agrif_UseSpecialValueInUpdate = .TRUE. 135 Agrif_SpecialValueFineGrid = 0. 136 # if ! defined DECAL_FEEDBACK 137 CALL Agrif_Update_Variable(sshn_id,procname = updateSSH) 138 # else 139 CALL Agrif_Update_Variable(sshn_id,locupdate=(/1,0/),procname = updateSSH) 140 # endif 141 Agrif_UseSpecialValueInUpdate = .FALSE. 142 ! 95 143 #endif 96 97 nbcline = nbcline + 1 98 99 Agrif_UseSpecialValueInUpdate = .TRUE. 144 ! 145 ! Do recursive update: 146 IF ( lk_agrif_doupd ) THEN ! Initialisation: do recursive update: 147 CALL Agrif_ChildGrid_To_ParentGrid() 148 CALL Agrif_Update_Dyn() 149 CALL Agrif_ParentGrid_To_ChildGrid() 150 ENDIF 151 ! 152 END SUBROUTINE Agrif_Update_Dyn 153 154 # if defined key_zdftke 155 SUBROUTINE Agrif_Update_Tke( kt ) 156 !!--------------------------------------------- 157 !! *** ROUTINE Agrif_Update_Tke *** 158 !!--------------------------------------------- 159 !! 160 INTEGER, INTENT(in) :: kt 161 ! 162 IF( ( Agrif_NbStepint() .NE. 0 ) .AND. (kt /= 0) ) RETURN 163 # if defined TWO_WAY 164 165 Agrif_UseSpecialValueInUpdate = .TRUE. 100 166 Agrif_SpecialValueFineGrid = 0. 101 CALL Agrif_Update_Variable(ztab2d,sshn_id,procname = updateSSH) 167 168 CALL Agrif_Update_Variable( en_id, locupdate=(/0,0/), procname=updateEN ) 169 CALL Agrif_Update_Variable(avt_id, locupdate=(/0,0/), procname=updateAVT ) 170 CALL Agrif_Update_Variable(avm_id, locupdate=(/0,0/), procname=updateAVM ) 171 102 172 Agrif_UseSpecialValueInUpdate = .FALSE. 103 173 104 CALL wrk_dealloc( jpi, jpj, ztab2d ) 105 CALL wrk_dealloc( jpi, jpj, jpk, ztab ) 106 107 !Done in step 108 ! CALL Agrif_ChildGrid_To_ParentGrid() 109 ! CALL recompute_diags( kt ) 110 ! CALL Agrif_ParentGrid_To_ChildGrid() 111 112 #endif 113 114 END SUBROUTINE Agrif_Update_Dyn 115 116 SUBROUTINE recompute_diags( kt ) 117 !!--------------------------------------------- 118 !! *** ROUTINE recompute_diags *** 119 !!--------------------------------------------- 120 INTEGER, INTENT(in) :: kt 121 122 END SUBROUTINE recompute_diags 174 # endif 175 176 END SUBROUTINE Agrif_Update_Tke 177 # endif /* key_zdftke */ 123 178 124 179 SUBROUTINE updateTS( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before ) … … 127 182 !!--------------------------------------------- 128 183 # include "domzgr_substitute.h90" 129 130 184 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2 131 185 REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres 132 LOGICAL, iNTENT(in) :: before133 186 LOGICAL, INTENT(in) :: before 187 !! 134 188 INTEGER :: ji,jj,jk,jn 135 189 !!--------------------------------------------- 190 ! 136 191 IF (before) THEN 137 192 DO jn = n1,n2 … … 146 201 ELSE 147 202 IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN 148 ! Add asselin part203 ! Add asselin part 149 204 DO jn = n1,n2 150 205 DO jk=k1,k2 … … 153 208 IF( tabres(ji,jj,jk,jn) .NE. 0. ) THEN 154 209 tsb(ji,jj,jk,jn) = tsb(ji,jj,jk,jn) & 155 & + atfp * ( tabres(ji,jj,jk,jn) &156 & - tsn(ji,jj,jk,jn) ) * tmask(ji,jj,jk)210 & + atfp * ( tabres(ji,jj,jk,jn) & 211 & - tsn(ji,jj,jk,jn) ) * tmask(ji,jj,jk) 157 212 ENDIF 158 213 ENDDO … … 161 216 ENDDO 162 217 ENDIF 163 164 218 DO jn = n1,n2 165 219 DO jk=k1,k2 … … 174 228 END DO 175 229 ENDIF 176 230 ! 177 231 END SUBROUTINE updateTS 178 232 … … 182 236 !!--------------------------------------------- 183 237 # include "domzgr_substitute.h90" 184 238 !! 185 239 INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2 186 240 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres 187 241 LOGICAL, INTENT(in) :: before 188 242 !! 189 243 INTEGER :: ji, jj, jk 190 244 REAL(wp) :: zrhoy 191 245 !!--------------------------------------------- 246 ! 192 247 IF (before) THEN 193 248 zrhoy = Agrif_Rhoy() … … 209 264 IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part 210 265 ub(ji,jj,jk) = ub(ji,jj,jk) & 211 & + atfp * ( tabres(ji,jj,jk) - un(ji,jj,jk) ) * umask(ji,jj,jk)266 & + atfp * ( tabres(ji,jj,jk) - un(ji,jj,jk) ) * umask(ji,jj,jk) 212 267 ENDIF 213 268 ! … … 217 272 END DO 218 273 ENDIF 219 274 ! 220 275 END SUBROUTINE updateu 221 276 … … 225 280 !!--------------------------------------------- 226 281 # include "domzgr_substitute.h90" 227 282 !! 228 283 INTEGER :: i1,i2,j1,j2,k1,k2 229 284 INTEGER :: ji,jj,jk 230 285 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2) :: tabres 231 286 LOGICAL :: before 232 287 !! 233 288 REAL(wp) :: zrhox 234 289 !!--------------------------------------------- 290 ! 235 291 IF (before) THEN 236 292 zrhox = Agrif_Rhox() … … 252 308 IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part 253 309 vb(ji,jj,jk) = vb(ji,jj,jk) & 254 & + atfp * ( tabres(ji,jj,jk) - vn(ji,jj,jk) ) * vmask(ji,jj,jk)310 & + atfp * ( tabres(ji,jj,jk) - vn(ji,jj,jk) ) * vmask(ji,jj,jk) 255 311 ENDIF 256 312 ! … … 260 316 END DO 261 317 ENDIF 262 318 ! 263 319 END SUBROUTINE updatev 264 320 … … 268 324 !!--------------------------------------------- 269 325 # include "domzgr_substitute.h90" 270 326 !! 271 327 INTEGER, INTENT(in) :: i1, i2, j1, j2 272 328 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 273 329 LOGICAL, INTENT(in) :: before 274 330 !! 275 331 INTEGER :: ji, jj, jk 276 332 REAL(wp) :: zrhoy 277 333 REAL(wp) :: zcorr 278 334 !!--------------------------------------------- 335 ! 279 336 IF (before) THEN 280 337 zrhoy = Agrif_Rhoy() … … 326 383 END DO 327 384 ENDIF 328 385 ! 329 386 END SUBROUTINE updateu2d 330 387 … … 333 390 !! *** ROUTINE updatev2d *** 334 391 !!--------------------------------------------- 335 336 392 INTEGER, INTENT(in) :: i1, i2, j1, j2 337 393 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 338 394 LOGICAL, INTENT(in) :: before 339 395 !! 340 396 INTEGER :: ji, jj, jk 341 397 REAL(wp) :: zrhox 342 398 REAL(wp) :: zcorr 343 399 !!--------------------------------------------- 400 ! 344 401 IF (before) THEN 345 402 zrhox = Agrif_Rhox() … … 391 448 END DO 392 449 ENDIF 393 450 ! 394 451 END SUBROUTINE updatev2d 395 452 453 396 454 SUBROUTINE updateSSH( tabres, i1, i2, j1, j2, before ) 397 455 !!--------------------------------------------- 398 456 !! *** ROUTINE updateSSH *** 399 457 !!--------------------------------------------- 400 # include "domzgr_substitute.h90"401 402 458 INTEGER, INTENT(in) :: i1, i2, j1, j2 403 459 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 404 460 LOGICAL, INTENT(in) :: before 405 461 !! 406 462 INTEGER :: ji, jj 407 463 !!--------------------------------------------- 464 ! 408 465 IF (before) THEN 409 466 DO jj=j1,j2 … … 413 470 END DO 414 471 ELSE 415 416 472 #if ! defined key_dynspg_ts 417 473 IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN 418 474 DO jj=j1,j2 419 475 DO ji=i1,i2 420 sshb(ji,jj) = sshb(ji,jj) &421 & + atfp * ( tabres(ji,jj) - sshn(ji,jj) ) * tmask(ji,jj,1)476 sshb(ji,jj) = sshb(ji,jj) & 477 & + atfp * ( tabres(ji,jj) - sshn(ji,jj) ) * tmask(ji,jj,1) 422 478 END DO 423 479 END DO … … 430 486 END DO 431 487 ENDIF 432 488 ! 433 489 END SUBROUTINE updateSSH 434 490 … … 437 493 !! *** ROUTINE updateub2b *** 438 494 !!--------------------------------------------- 439 440 495 INTEGER, INTENT(in) :: i1, i2, j1, j2 441 496 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 442 497 LOGICAL, INTENT(in) :: before 443 498 !! 444 499 INTEGER :: ji, jj 445 500 REAL(wp) :: zrhoy 446 501 !!--------------------------------------------- 502 ! 447 503 IF (before) THEN 448 504 zrhoy = Agrif_Rhoy() … … 460 516 END DO 461 517 ENDIF 462 518 ! 463 519 END SUBROUTINE updateub2b 464 520 … … 467 523 !! *** ROUTINE updatevb2b *** 468 524 !!--------------------------------------------- 469 470 525 INTEGER, INTENT(in) :: i1, i2, j1, j2 471 526 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 472 527 LOGICAL, INTENT(in) :: before 473 528 !! 474 529 INTEGER :: ji, jj 475 530 REAL(wp) :: zrhox 476 531 !!--------------------------------------------- 532 ! 477 533 IF (before) THEN 478 534 zrhox = Agrif_Rhox() … … 490 546 END DO 491 547 ENDIF 492 548 ! 493 549 END SUBROUTINE updatevb2b 550 551 552 SUBROUTINE update_scales( tabres, i1, i2, j1, j2, k1, k2, n1,n2, before ) 553 ! currently not used 554 !!--------------------------------------------- 555 !! *** ROUTINE updateT *** 556 !!--------------------------------------------- 557 # include "domzgr_substitute.h90" 558 559 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2 560 REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres 561 LOGICAL, iNTENT(in) :: before 562 563 INTEGER :: ji,jj,jk 564 REAL(wp) :: ztemp 565 566 IF (before) THEN 567 DO jk=k1,k2 568 DO jj=j1,j2 569 DO ji=i1,i2 570 tabres(ji,jj,jk,1) = e1t(ji,jj)*e2t(ji,jj)*tmask(ji,jj,jk) 571 tabres(ji,jj,jk,2) = e1t(ji,jj)*tmask(ji,jj,jk) 572 tabres(ji,jj,jk,3) = e2t(ji,jj)*tmask(ji,jj,jk) 573 END DO 574 END DO 575 END DO 576 tabres(:,:,:,1)=tabres(:,:,:,1)*Agrif_Rhox()*Agrif_Rhoy() 577 tabres(:,:,:,2)=tabres(:,:,:,2)*Agrif_Rhox() 578 tabres(:,:,:,3)=tabres(:,:,:,3)*Agrif_Rhoy() 579 ELSE 580 DO jk=k1,k2 581 DO jj=j1,j2 582 DO ji=i1,i2 583 IF( tabres(ji,jj,jk,1) .NE. 0. ) THEN 584 print *,'VAL = ',ji,jj,jk,tabres(ji,jj,jk,1),e1t(ji,jj)*e2t(ji,jj)*tmask(ji,jj,jk) 585 print *,'VAL2 = ',ji,jj,jk,tabres(ji,jj,jk,2),e1t(ji,jj)*tmask(ji,jj,jk) 586 print *,'VAL3 = ',ji,jj,jk,tabres(ji,jj,jk,3),e2t(ji,jj)*tmask(ji,jj,jk) 587 ztemp = sqrt(tabres(ji,jj,jk,1)/(tabres(ji,jj,jk,2)*tabres(ji,jj,jk,3))) 588 print *,'CORR = ',ztemp-1. 589 print *,'NEW VALS = ',tabres(ji,jj,jk,2)*ztemp,tabres(ji,jj,jk,3)*ztemp, & 590 tabres(ji,jj,jk,2)*ztemp*tabres(ji,jj,jk,3)*ztemp 591 e1t(ji,jj) = tabres(ji,jj,jk,2)*ztemp 592 e2t(ji,jj) = tabres(ji,jj,jk,3)*ztemp 593 END IF 594 END DO 595 END DO 596 END DO 597 ENDIF 598 ! 599 END SUBROUTINE update_scales 600 601 # if defined key_zdftke 602 SUBROUTINE updateEN( ptab, i1, i2, j1, j2, k1, k2, before ) 603 !!--------------------------------------------- 604 !! *** ROUTINE updateen *** 605 !!--------------------------------------------- 606 INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2 607 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 608 LOGICAL, INTENT(in) :: before 609 !!--------------------------------------------- 610 ! 611 IF (before) THEN 612 ptab (i1:i2,j1:j2,k1:k2) = en(i1:i2,j1:j2,k1:k2) 613 ELSE 614 en(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2) 615 ENDIF 616 ! 617 END SUBROUTINE updateEN 618 619 620 SUBROUTINE updateAVT( ptab, i1, i2, j1, j2, k1, k2, before ) 621 !!--------------------------------------------- 622 !! *** ROUTINE updateavt *** 623 !!--------------------------------------------- 624 INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2 625 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 626 LOGICAL, INTENT(in) :: before 627 !!--------------------------------------------- 628 ! 629 IF (before) THEN 630 ptab (i1:i2,j1:j2,k1:k2) = avt_k(i1:i2,j1:j2,k1:k2) 631 ELSE 632 avt_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2) 633 ENDIF 634 ! 635 END SUBROUTINE updateAVT 636 637 638 SUBROUTINE updateAVM( ptab, i1, i2, j1, j2, k1, k2, before ) 639 !!--------------------------------------------- 640 !! *** ROUTINE updateavm *** 641 !!--------------------------------------------- 642 INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2 643 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 644 LOGICAL, INTENT(in) :: before 645 !!--------------------------------------------- 646 ! 647 IF (before) THEN 648 ptab (i1:i2,j1:j2,k1:k2) = avm_k(i1:i2,j1:j2,k1:k2) 649 ELSE 650 avm_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2) 651 ENDIF 652 ! 653 END SUBROUTINE updateAVM 654 655 # endif /* key_zdftke */ 494 656 495 657 #else -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/NST_SRC/agrif_top_interp.F90
r6836 r6839 7 7 USE agrif_oce 8 8 USE agrif_top_sponge 9 USE par_trc 9 10 USE trc 10 11 USE lib_mpp … … 14 15 PRIVATE 15 16 16 PUBLIC Agrif_trc 17 PUBLIC Agrif_trc, interptrn 17 18 18 19 # include "domzgr_substitute.h90" 19 20 # include "vectopt_loop_substitute.h90" 20 21 !!---------------------------------------------------------------------- 21 !! NEMO/NST 3. 3, NEMO Consortium (2010)22 !! NEMO/NST 3.6 , NEMO Consortium (2010) 22 23 !! $Id$ 23 24 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 28 29 SUBROUTINE Agrif_trc 29 30 !!---------------------------------------------------------------------- 30 !! *** ROUTINE Agrif_Tra *** 31 !!---------------------------------------------------------------------- 32 !! 33 INTEGER :: ji, jj, jk, jn ! dummy loop indices 34 REAL(wp) :: zrhox , alpha1, alpha2, alpha3 35 REAL(wp) :: alpha4, alpha5, alpha6, alpha7 36 REAL(wp), POINTER, DIMENSION(:,:,:,:) :: ztra 31 !! *** ROUTINE Agrif_trc *** 37 32 !!---------------------------------------------------------------------- 38 33 ! 39 34 IF( Agrif_Root() ) RETURN 40 35 41 CALL wrk_alloc( jpi, jpj, jpk, jptra, ztra )42 43 36 Agrif_SpecialValue = 0.e0 44 37 Agrif_UseSpecialValue = .TRUE. 45 ztra(:,:,:,:) = 0.e046 38 47 CALL Agrif_Bc_variable( ztra,trn_id, procname=interptrn )39 CALL Agrif_Bc_variable( trn_id, procname=interptrn ) 48 40 Agrif_UseSpecialValue = .FALSE. 41 ! 42 END SUBROUTINE Agrif_trc 49 43 50 zrhox = Agrif_Rhox() 44 SUBROUTINE interptrn(ptab,i1,i2,j1,j2,k1,k2,n1,n2,before,nb,ndir) 45 !!--------------------------------------------- 46 !! *** ROUTINE interptrn *** 47 !!--------------------------------------------- 48 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: ptab 49 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2 50 LOGICAL, INTENT(in) :: before 51 INTEGER, INTENT(in) :: nb , ndir 52 ! 53 INTEGER :: ji, jj, jk, jn ! dummy loop indices 54 INTEGER :: imin, imax, jmin, jmax 55 REAL(wp) :: zrhox , zalpha1, zalpha2, zalpha3 56 REAL(wp) :: zalpha4, zalpha5, zalpha6, zalpha7 57 LOGICAL :: western_side, eastern_side,northern_side,southern_side 51 58 52 alpha1 = ( zrhox - 1. ) * 0.5 53 alpha2 = 1. - alpha1 54 55 alpha3 = ( zrhox - 1. ) / ( zrhox + 1. ) 56 alpha4 = 1. - alpha3 57 58 alpha6 = 2. * ( zrhox - 1. ) / ( zrhox + 1. ) 59 alpha7 = - ( zrhox - 1. ) / ( zrhox + 3. ) 60 alpha5 = 1. - alpha6 - alpha7 61 IF( nbondi == 1 .OR. nbondi == 2 ) THEN 62 63 DO jn = 1, jptra 64 tra(nlci,:,:,jn) = alpha1 * ztra(nlci,:,:,jn) + alpha2 * ztra(nlci-1,:,:,jn) 65 DO jk = 1, jpkm1 66 DO jj = 1, jpj 67 IF( umask(nlci-2,jj,jk) == 0.e0 ) THEN 68 tra(nlci-1,jj,jk,jn) = tra(nlci,jj,jk,jn) * tmask(nlci-1,jj,jk) 69 ELSE 70 tra(nlci-1,jj,jk,jn)=(alpha4*tra(nlci,jj,jk,jn)+alpha3*tra(nlci-2,jj,jk,jn))*tmask(nlci-1,jj,jk) 71 IF( un(nlci-2,jj,jk) > 0.e0 ) THEN 72 tra(nlci-1,jj,jk,jn)=( alpha6*tra(nlci-2,jj,jk,jn)+alpha5*tra(nlci,jj,jk,jn) & 73 & + alpha7*tra(nlci-3,jj,jk,jn) ) * tmask(nlci-1,jj,jk) 59 IF (before) THEN 60 ptab(i1:i2,j1:j2,k1:k2,n1:n2) = trn(i1:i2,j1:j2,k1:k2,n1:n2) 61 ELSE 62 ! 63 western_side = (nb == 1).AND.(ndir == 1) 64 eastern_side = (nb == 1).AND.(ndir == 2) 65 southern_side = (nb == 2).AND.(ndir == 1) 66 northern_side = (nb == 2).AND.(ndir == 2) 67 ! 68 zrhox = Agrif_Rhox() 69 ! 70 zalpha1 = ( zrhox - 1. ) * 0.5 71 zalpha2 = 1. - zalpha1 72 ! 73 zalpha3 = ( zrhox - 1. ) / ( zrhox + 1. ) 74 zalpha4 = 1. - zalpha3 75 ! 76 zalpha6 = 2. * ( zrhox - 1. ) / ( zrhox + 1. ) 77 zalpha7 = - ( zrhox - 1. ) / ( zrhox + 3. ) 78 zalpha5 = 1. - zalpha6 - zalpha7 79 ! 80 imin = i1 81 imax = i2 82 jmin = j1 83 jmax = j2 84 ! 85 ! Remove CORNERS 86 IF((nbondj == -1).OR.(nbondj == 2)) jmin = 3 87 IF((nbondj == +1).OR.(nbondj == 2)) jmax = nlcj-2 88 IF((nbondi == -1).OR.(nbondi == 2)) imin = 3 89 IF((nbondi == +1).OR.(nbondi == 2)) imax = nlci-2 90 ! 91 IF( eastern_side) THEN 92 DO jn = 1, jptra 93 tra(nlci,j1:j2,k1:k2,jn) = zalpha1 * ptab(nlci,j1:j2,k1:k2,jn) + zalpha2 * ptab(nlci-1,j1:j2,k1:k2,jn) 94 DO jk = 1, jpkm1 95 DO jj = jmin,jmax 96 IF( umask(nlci-2,jj,jk) == 0.e0 ) THEN 97 tra(nlci-1,jj,jk,jn) = tra(nlci,jj,jk,jn) * tmask(nlci-1,jj,jk) 98 ELSE 99 tra(nlci-1,jj,jk,jn)=(zalpha4*tra(nlci,jj,jk,jn)+zalpha3*tra(nlci-2,jj,jk,jn))*tmask(nlci-1,jj,jk) 100 IF( un(nlci-2,jj,jk) > 0.e0 ) THEN 101 tra(nlci-1,jj,jk,jn)=( zalpha6*tra(nlci-2,jj,jk,jn)+zalpha5*tra(nlci,jj,jk,jn) & 102 + zalpha7*tra(nlci-3,jj,jk,jn) ) * tmask(nlci-1,jj,jk) 103 ENDIF 74 104 ENDIF 75 ENDIF 105 END DO 106 END DO 107 ENDDO 108 ENDIF 109 ! 110 IF( northern_side ) THEN 111 DO jn = 1, jptra 112 tra(i1:i2,nlcj,k1:k2,jn) = zalpha1 * ptab(i1:i2,nlcj,k1:k2,jn) + zalpha2 * ptab(i1:i2,nlcj-1,k1:k2,jn) 113 DO jk = 1, jpkm1 114 DO ji = imin,imax 115 IF( vmask(ji,nlcj-2,jk) == 0.e0 ) THEN 116 tra(ji,nlcj-1,jk,jn) = tra(ji,nlcj,jk,jn) * tmask(ji,nlcj-1,jk) 117 ELSE 118 tra(ji,nlcj-1,jk,jn)=(zalpha4*tra(ji,nlcj,jk,jn)+zalpha3*tra(ji,nlcj-2,jk,jn))*tmask(ji,nlcj-1,jk) 119 IF (vn(ji,nlcj-2,jk) > 0.e0 ) THEN 120 tra(ji,nlcj-1,jk,jn)=( zalpha6*tra(ji,nlcj-2,jk,jn)+zalpha5*tra(ji,nlcj,jk,jn) & 121 + zalpha7*tra(ji,nlcj-3,jk,jn) ) * tmask(ji,nlcj-1,jk) 122 ENDIF 123 ENDIF 124 END DO 125 END DO 126 ENDDO 127 ENDIF 128 ! 129 IF( western_side) THEN 130 DO jn = 1, jptra 131 tra(1,j1:j2,k1:k2,jn) = zalpha1 * ptab(1,j1:j2,k1:k2,jn) + zalpha2 * ptab(2,j1:j2,k1:k2,jn) 132 DO jk = 1, jpkm1 133 DO jj = jmin,jmax 134 IF( umask(2,jj,jk) == 0.e0 ) THEN 135 tra(2,jj,jk,jn) = tra(1,jj,jk,jn) * tmask(2,jj,jk) 136 ELSE 137 tra(2,jj,jk,jn)=(zalpha4*tra(1,jj,jk,jn)+zalpha3*tra(3,jj,jk,jn))*tmask(2,jj,jk) 138 IF( un(2,jj,jk) < 0.e0 ) THEN 139 tra(2,jj,jk,jn)=(zalpha6*tra(3,jj,jk,jn)+zalpha5*tra(1,jj,jk,jn)+zalpha7*tra(4,jj,jk,jn))*tmask(2,jj,jk) 140 ENDIF 141 ENDIF 142 END DO 76 143 END DO 77 144 END DO 78 ENDDO 79 ENDIF 80 81 IF( nbondj == 1 .OR. nbondj == 2 ) THEN 82 83 DO jn = 1, jptra 84 tra(:,nlcj,:,jn) = alpha1 * ztra(:,nlcj,:,jn) + alpha2 * ztra(:,nlcj-1,:,jn) 85 DO jk = 1, jpkm1 86 DO ji = 1, jpi 87 IF( vmask(ji,nlcj-2,jk) == 0.e0 ) THEN 88 tra(ji,nlcj-1,jk,jn) = tra(ji,nlcj,jk,jn) * tmask(ji,nlcj-1,jk) 89 ELSE 90 tra(ji,nlcj-1,jk,jn)=(alpha4*tra(ji,nlcj,jk,jn)+alpha3*tra(ji,nlcj-2,jk,jn))*tmask(ji,nlcj-1,jk) 91 IF (vn(ji,nlcj-2,jk) > 0.e0 ) THEN 92 tra(ji,nlcj-1,jk,jn)=( alpha6*tra(ji,nlcj-2,jk,jn)+alpha5*tra(ji,nlcj,jk,jn) & 93 & + alpha7*tra(ji,nlcj-3,jk,jn) ) * tmask(ji,nlcj-1,jk) 145 ENDIF 146 ! 147 IF( southern_side ) THEN 148 DO jn = 1, jptra 149 tra(i1:i2,1,k1:k2,jn) = zalpha1 * ptab(i1:i2,1,k1:k2,jn) + zalpha2 * ptab(i1:i2,2,k1:k2,jn) 150 DO jk=1,jpk 151 DO ji=imin,imax 152 IF( vmask(ji,2,jk) == 0.e0 ) THEN 153 tra(ji,2,jk,jn)=tra(ji,1,jk,jn) * tmask(ji,2,jk) 154 ELSE 155 tra(ji,2,jk,jn)=(zalpha4*tra(ji,1,jk,jn)+zalpha3*tra(ji,3,jk,jn))*tmask(ji,2,jk) 156 IF( vn(ji,2,jk) < 0.e0 ) THEN 157 tra(ji,2,jk,jn)=(zalpha6*tra(ji,3,jk,jn)+zalpha5*tra(ji,1,jk,jn)+zalpha7*tra(ji,4,jk,jn))*tmask(ji,2,jk) 158 ENDIF 94 159 ENDIF 95 END IF160 END DO 96 161 END DO 97 END DO 98 ENDDO 99 ENDIF 100 IF( nbondi == -1 .OR. nbondi == 2 ) THEN 101 DO jn = 1, jptra 102 tra(1,:,:,jn) = alpha1 * ztra(1,:,:,jn) + alpha2 * ztra(2,:,:,jn) 103 DO jk = 1, jpkm1 104 DO jj = 1, jpj 105 IF( umask(2,jj,jk) == 0.e0 ) THEN 106 tra(2,jj,jk,jn) = tra(1,jj,jk,jn) * tmask(2,jj,jk) 107 ELSE 108 tra(2,jj,jk,jn)=(alpha4*tra(1,jj,jk,jn)+alpha3*tra(3,jj,jk,jn))*tmask(2,jj,jk) 109 IF( un(2,jj,jk) < 0.e0 ) THEN 110 tra(2,jj,jk,jn)=(alpha6*tra(3,jj,jk,jn)+alpha5*tra(1,jj,jk,jn)+alpha7*tra(4,jj,jk,jn))*tmask(2,jj,jk) 111 ENDIF 112 ENDIF 113 END DO 114 END DO 115 END DO 116 ENDIF 117 118 IF( nbondj == -1 .OR. nbondj == 2 ) THEN 119 DO jn = 1, jptra 120 tra(:,1,:,jn) = alpha1 * ztra(:,1,:,jn) + alpha2 * ztra(:,2,:,jn) 121 DO jk=1,jpk 122 DO ji=1,jpi 123 IF( vmask(ji,2,jk) == 0.e0 ) THEN 124 tra(ji,2,jk,jn)=tra(ji,1,jk,jn) * tmask(ji,2,jk) 125 ELSE 126 tra(ji,2,jk,jn)=(alpha4*tra(ji,1,jk,jn)+alpha3*tra(ji,3,jk,jn))*tmask(ji,2,jk) 127 IF( vn(ji,2,jk) < 0.e0 ) THEN 128 tra(ji,2,jk,jn)=(alpha6*tra(ji,3,jk,jn)+alpha5*tra(ji,1,jk,jn)+alpha7*tra(ji,4,jk,jn))*tmask(ji,2,jk) 129 ENDIF 130 ENDIF 131 END DO 132 END DO 133 ENDDO 162 ENDDO 163 ENDIF 164 ! 165 ! Treatment of corners 166 ! 167 ! East south 168 IF ((eastern_side).AND.((nbondj == -1).OR.(nbondj == 2))) THEN 169 tra(nlci-1,2,:,:) = ptab(nlci-1,2,:,:) 170 ENDIF 171 ! East north 172 IF ((eastern_side).AND.((nbondj == 1).OR.(nbondj == 2))) THEN 173 tra(nlci-1,nlcj-1,:,:) = ptab(nlci-1,nlcj-1,:,:) 174 ENDIF 175 ! West south 176 IF ((western_side).AND.((nbondj == -1).OR.(nbondj == 2))) THEN 177 tra(2,2,:,:) = ptab(2,2,:,:) 178 ENDIF 179 ! West north 180 IF ((western_side).AND.((nbondj == 1).OR.(nbondj == 2))) THEN 181 tra(2,nlcj-1,:,:) = ptab(2,nlcj-1,:,:) 182 ENDIF 183 ! 134 184 ENDIF 135 185 ! 136 CALL wrk_dealloc( jpi, jpj, jpk, jptra, ztra ) 137 ! 138 139 END SUBROUTINE Agrif_trc 186 END SUBROUTINE interptrn 140 187 141 188 #else -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/NST_SRC/agrif_top_sponge.F90
r6836 r6839 1 1 #define SPONGE_TOP 2 2 3 M oduleagrif_top_sponge3 MODULE agrif_top_sponge 4 4 #if defined key_agrif && defined key_top 5 5 USE par_oce 6 USE par_trc 6 7 USE oce 7 8 USE dom_oce … … 16 17 PRIVATE 17 18 18 PUBLIC Agrif_Sponge_ Trc, interptrn19 PUBLIC Agrif_Sponge_trc, interptrn_sponge 19 20 20 !! * Substitutions21 !! * Substitutions 21 22 # include "domzgr_substitute.h90" 22 23 !!---------------------------------------------------------------------- 23 !! NEMO/NST 3. 3, NEMO Consortium (2010)24 !! NEMO/NST 3.6 , NEMO Consortium (2010) 24 25 !! $Id$ 25 26 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 26 27 !!---------------------------------------------------------------------- 27 28 28 29 CONTAINS 29 30 30 SUBROUTINE Agrif_Sponge_ Trc31 SUBROUTINE Agrif_Sponge_trc 31 32 !!--------------------------------------------- 32 33 !! *** ROUTINE Agrif_Sponge_Trc *** 33 34 !!--------------------------------------------- 34 35 !! 35 INTEGER :: ji,jj,jk,jn36 36 REAL(wp) :: timecoeff 37 REAL(wp) :: ztra, zabe1, zabe2, zbtr38 REAL(wp), POINTER, DIMENSION(:,:) :: ztru, ztrv39 REAL(wp), POINTER, DIMENSION(:,:,:,:) :: ztabr40 REAL(wp), POINTER, DIMENSION(:,:,:,:) :: trbdiff41 37 42 38 #if defined SPONGE_TOP 43 CALL wrk_alloc( jpi, jpj, ztru, ztrv )44 CALL wrk_alloc( jpi, jpj, jpk, jptra, ztabr, trbdiff )45 46 39 timecoeff = REAL(Agrif_NbStepint(),wp)/Agrif_rhot() 47 40 CALL Agrif_sponge 48 41 Agrif_SpecialValue=0. 49 42 Agrif_UseSpecialValue = .TRUE. 50 ztabr = 0.e051 CALL Agrif_Bc_Variable( ztabr, tra_id,calledweight=timecoeff,procname=interptrn)43 tabspongedone_trn = .FALSE. 44 CALL Agrif_Bc_Variable(trn_sponge_id,calledweight=timecoeff,procname=interptrn_sponge) 52 45 Agrif_UseSpecialValue = .FALSE. 53 54 trbdiff(:,:,:,:) = trb(:,:,:,:) - ztabr(:,:,:,:)55 56 CALL Agrif_sponge57 58 DO jn = 1, jptra59 DO jk = 1, jpkm160 !61 DO jj = 1, jpjm162 DO ji = 1, jpim163 zabe1 = umask(ji,jj,jk) * spe1ur(ji,jj) * fse3u(ji,jj,jk)64 zabe2 = vmask(ji,jj,jk) * spe2vr(ji,jj) * fse3v(ji,jj,jk)65 ztru(ji,jj) = zabe1 * ( trbdiff(ji+1,jj ,jk,jn) - trbdiff(ji,jj,jk,jn) )66 ztrv(ji,jj) = zabe2 * ( trbdiff(ji ,jj+1,jk,jn) - trbdiff(ji,jj,jk,jn) )67 ENDDO68 ENDDO69 70 DO jj = 2,jpjm171 DO ji = 2,jpim172 zbtr = spbtr2(ji,jj) / fse3t(ji,jj,jk)73 ! horizontal diffusive trends74 ztra = zbtr * ( ztru(ji,jj) - ztru(ji-1,jj) + ztrv(ji,jj) - ztrv(ji,jj-1) )75 ! add it to the general tracer trends76 tra(ji,jj,jk,jn) = tra(ji,jj,jk,jn) + ztra77 END DO78 END DO79 !80 ENDDO81 ENDDO82 83 CALL wrk_dealloc( jpi, jpj, ztru, ztrv )84 CALL wrk_dealloc( jpi, jpj, jpk, jptra, trbdiff, ztabr )85 46 86 47 #endif … … 88 49 END SUBROUTINE Agrif_Sponge_Trc 89 50 90 SUBROUTINE interptrn (tabres,i1,i2,j1,j2,k1,k2,n1,n2)51 SUBROUTINE interptrn_sponge(tabres,i1,i2,j1,j2,k1,k2,n1,n2,before) 91 52 !!--------------------------------------------- 92 !! *** ROUTINE interpt n***53 !! *** ROUTINE interptrn_sponge *** 93 54 !!--------------------------------------------- 94 55 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2 95 56 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres 57 LOGICAL, INTENT(in) :: before 58 59 60 INTEGER :: ji, jj, jk, jn ! dummy loop indices 61 62 REAL(wp) :: ztra, zabe1, zabe2, zbtr 63 REAL(wp), DIMENSION(i1:i2,j1:j2) :: ztu, ztv 64 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2) ::trbdiff 96 65 ! 97 tabres(i1:i2,j1:j2,k1:k2,n1:n2) = trn(i1:i2,j1:j2,k1:k2,n1:n2) 66 IF (before) THEN 67 tabres(i1:i2,j1:j2,k1:k2,n1:n2) = trn(i1:i2,j1:j2,k1:k2,n1:n2) 68 ELSE 98 69 99 END SUBROUTINE interptrn 70 trbdiff(:,:,:,:) = trb(i1:i2,j1:j2,:,:) - tabres(:,:,:,:) 71 DO jn = 1, jptra 72 DO jk = 1, jpkm1 73 74 DO jj = j1,j2-1 75 DO ji = i1,i2-1 76 zabe1 = fsaht_spu(ji,jj) * umask(ji,jj,jk) * re2u_e1u(ji,jj) * fse3u_n(ji,jj,jk) 77 zabe2 = fsaht_spv(ji,jj) * vmask(ji,jj,jk) * re1v_e2v(ji,jj) * fse3v_n(ji,jj,jk) 78 ztu(ji,jj) = zabe1 * ( trbdiff(ji+1,jj ,jk,jn) - trbdiff(ji,jj,jk,jn) ) 79 ztv(ji,jj) = zabe2 * ( trbdiff(ji ,jj+1,jk,jn) - trbdiff(ji,jj,jk,jn) ) 80 ENDDO 81 ENDDO 82 83 DO jj = j1+1,j2-1 84 DO ji = i1+1,i2-1 85 86 IF (.NOT. tabspongedone_trn(ji,jj)) THEN 87 zbtr = r1_e12t(ji,jj) / fse3t(ji,jj,jk) 88 ! horizontal diffusive trends 89 ztra = zbtr * ( ztu(ji,jj) - ztu(ji-1,jj ) + ztv(ji,jj) - ztv(ji ,jj-1) ) 90 ! add it to the general tracer trends 91 tra(ji,jj,jk,jn) = tra(ji,jj,jk,jn) + ztra 92 ENDIF 93 94 ENDDO 95 ENDDO 96 97 ENDDO 98 ENDDO 99 100 tabspongedone_trn(i1+1:i2-1,j1+1:j2-1) = .TRUE. 101 ENDIF 102 ! 103 END SUBROUTINE interptrn_sponge 100 104 101 105 #else -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/NST_SRC/agrif_top_update.F90
r6836 r6839 1 1 #define TWO_WAY 2 #undef DECAL_FEEDBACK 2 3 3 4 MODULE agrif_top_update … … 8 9 USE dom_oce 9 10 USE agrif_oce 11 USE par_trc 10 12 USE trc 11 13 USE wrk_nemo … … 24 26 !!---------------------------------------------------------------------- 25 27 26 28 CONTAINS 27 29 28 30 SUBROUTINE Agrif_Update_Trc( kt ) … … 30 32 !! *** ROUTINE Agrif_Update_Trc *** 31 33 !!--------------------------------------------- 32 !!33 34 INTEGER, INTENT(in) :: kt 34 REAL(wp), POINTER, DIMENSION(:,:,:,:) :: ztra 35 36 37 IF ((Agrif_NbStepint() .NE. (Agrif_irhot()-1)).AND.(kt /= 0)) RETURN 38 39 #if defined TWO_WAY 40 CALL wrk_alloc( jpi, jpj, jpk, jptra, ztra ) 41 35 !!--------------------------------------------- 36 ! 37 IF((Agrif_NbStepint() .NE. (Agrif_irhot()-1)).AND.(kt /= 0)) RETURN 38 #if defined TWO_WAY 42 39 Agrif_UseSpecialValueInUpdate = .TRUE. 43 40 Agrif_SpecialValueFineGrid = 0. 44 45 IF (MOD(nbcline_trc,nbclineupdate) == 0) THEN 46 CALL Agrif_Update_Variable(ztra,trn_id, procname=updateTRC) 41 ! 42 IF (MOD(nbcline_trc,nbclineupdate) == 0) THEN 43 # if ! defined DECAL_FEEDBACK 44 CALL Agrif_Update_Variable(trn_id, procname=updateTRC) 45 # else 46 CALL Agrif_Update_Variable(trn_id, locupdate=(/1,0/),procname=updateTRC) 47 # endif 47 48 ELSE 48 CALL Agrif_Update_Variable(ztra,trn_id,locupdate=(/0,2/), procname=updateTRC) 49 # if ! defined DECAL_FEEDBACK 50 CALL Agrif_Update_Variable(trn_id,locupdate=(/0,2/), procname=updateTRC) 51 # else 52 CALL Agrif_Update_Variable(trn_id,locupdate=(/1,2/), procname=updateTRC) 53 # endif 49 54 ENDIF 50 55 ! 51 56 Agrif_UseSpecialValueInUpdate = .FALSE. 52 57 nbcline_trc = nbcline_trc + 1 53 54 CALL wrk_dealloc( jpi, jpj, jpk, jptra, ztra )55 58 #endif 56 59 ! 57 60 END SUBROUTINE Agrif_Update_Trc 58 61 59 SUBROUTINE updateTRC( tabres,i1,i2,j1,j2,k1,k2,n1,n2,before)62 SUBROUTINE updateTRC( ptab, i1, i2, j1, j2, k1, k2, n1, n2, before ) 60 63 !!--------------------------------------------- 61 !! *** ROUTINE UpdateTrc***64 !! *** ROUTINE updateT *** 62 65 !!--------------------------------------------- 66 # include "domzgr_substitute.h90" 63 67 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2 64 REAL , DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres68 REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: ptab 65 69 LOGICAL, INTENT(in) :: before 66 70 !! 67 71 INTEGER :: ji,jj,jk,jn 68 69 IF( before ) THEN 70 DO jn = n1, n2 71 DO jk = k1, k2 72 DO jj = j1, j2 73 DO ji = i1, i2 74 tabres(ji,jj,jk,jn) = trn(ji,jj,jk,jn) 75 ENDDO 76 ENDDO 77 ENDDO 78 ENDDO 79 ELSE 80 IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN 72 !!--------------------------------------------- 73 ! 74 IF (before) THEN 75 DO jn = n1,n2 76 DO jk=k1,k2 77 DO jj=j1,j2 78 DO ji=i1,i2 79 ptab(ji,jj,jk,jn) = trn(ji,jj,jk,jn) 80 END DO 81 END DO 82 END DO 83 END DO 84 ELSE 85 IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN 81 86 ! Add asselin part 82 DO jn = n1, n2 83 DO jk = k1, k2 84 DO jj = j1, j2 85 DO ji = i1, i2 86 IF( tabres(ji,jj,jk,jn) .NE. 0. ) THEN 87 trb(ji,jj,jk,jn) = trb(ji,jj,jk,jn) & 88 & + atfp * ( tabres(ji,jj,jk,jn) & 89 - trn(ji,jj,jk,jn) ) * tmask(ji,jj,jk) 90 ENDIF 91 ENDDO 92 ENDDO 93 ENDDO 94 ENDDO 95 ENDIF 96 97 DO jn = n1, n2 98 DO jk = k1, k2 99 DO jj = j1, j2 100 DO ji = i1, i2 101 IF( tabres(ji,jj,jk,jn) .NE. 0. ) THEN 102 trn(ji,jj,jk,jn) = tabres(ji,jj,jk,jn) * tmask(ji,jj,jk) 87 DO jn = n1,n2 88 DO jk=k1,k2 89 DO jj=j1,j2 90 DO ji=i1,i2 91 IF( ptab(ji,jj,jk,jn) .NE. 0. ) THEN 92 trb(ji,jj,jk,jn) = trb(ji,jj,jk,jn) & 93 & + atfp * ( ptab(ji,jj,jk,jn) & 94 & - trn(ji,jj,jk,jn) ) * tmask(ji,jj,jk) 103 95 ENDIF 104 96 ENDDO … … 107 99 ENDDO 108 100 ENDIF 109 101 DO jn = n1,n2 102 DO jk=k1,k2 103 DO jj=j1,j2 104 DO ji=i1,i2 105 IF( ptab(ji,jj,jk,jn) .NE. 0. ) THEN 106 trn(ji,jj,jk,jn) = ptab(ji,jj,jk,jn) * tmask(ji,jj,jk) 107 END IF 108 END DO 109 END DO 110 END DO 111 END DO 112 ENDIF 113 ! 110 114 END SUBROUTINE updateTRC 111 115 … … 119 123 END SUBROUTINE agrif_top_update_empty 120 124 #endif 121 END M oduleagrif_top_update125 END MODULE agrif_top_update -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/NST_SRC/agrif_user.F90
r6836 r6839 17 17 USE par_oce 18 18 USE dom_oce 19 USE Agrif_Util20 19 USE nemogcm 21 20 ! … … 31 30 jpi = ( jpiglo-2*jpreci + (jpni-1+0) ) / jpni + 2*jpreci 32 31 jpj = ( jpjglo-2*jprecj + (jpnj-1+0) ) / jpnj + 2*jprecj 33 jpk = jpkdta 32 ! JC: change to allow for different vertical levels 33 ! jpk is already set 34 ! keep it jpk possibly different from jpkdta which 35 ! hold parent grid vertical levels number (set earlier) 36 ! jpk = jpkdta 34 37 jpim1 = jpi-1 35 38 jpjm1 = jpj-1 … … 64 67 ! 0. Initializations 65 68 !------------------- 66 IF( cp_cfg == 'orca' ) then69 IF( cp_cfg == 'orca' ) THEN 67 70 IF ( jp_cfg == 2 .OR. jp_cfg == 025 .OR. jp_cfg == 05 & 68 & .OR. jp_cfg == 4 ) THEN71 & .OR. jp_cfg == 4 ) THEN 69 72 jp_cfg = -1 ! set special value for jp_cfg on fine grids 70 73 cp_cfg = "default" … … 120 123 SUBROUTINE agrif_declare_var_dom 121 124 !!---------------------------------------------------------------------- 122 !! *** ROUTINE agrif_declar E_var ***125 !! *** ROUTINE agrif_declare_var *** 123 126 !! 124 127 !! ** Purpose :: Declaration of variables to be interpolated 125 128 !!---------------------------------------------------------------------- 126 129 USE agrif_util 127 USE par_oce ! ONLY : jpts130 USE par_oce 128 131 USE oce 129 132 IMPLICIT NONE … … 132 135 ! 1. Declaration of the type of variable which have to be interpolated 133 136 !--------------------------------------------------------------------- 134 CALL agrif_declare_variable((/1,2/),(/2,3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),e1u_id) 135 CALL agrif_declare_variable((/2,1/),(/3,2/),(/'x','y'/),(/1,1/),(/jpi,jpj/),e2v_id) 136 137 CALL agrif_declare_variable((/1,2/),(/2,3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),e1u_id) 138 CALL agrif_declare_variable((/2,1/),(/3,2/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),e2v_id) 137 139 138 140 ! 2. Type of interpolation 139 141 !------------------------- 140 C allAgrif_Set_bcinterp(e1u_id,interp1=Agrif_linear,interp2=AGRIF_ppm)141 C allAgrif_Set_bcinterp(e2v_id,interp1=AGRIF_ppm,interp2=Agrif_linear)142 CALL Agrif_Set_bcinterp(e1u_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 143 CALL Agrif_Set_bcinterp(e2v_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 142 144 143 145 ! 3. Location of interpolation 144 146 !----------------------------- 145 C allAgrif_Set_bc(e1u_id,(/0,0/))146 C allAgrif_Set_bc(e2v_id,(/0,0/))147 CALL Agrif_Set_bc(e1u_id,(/0,0/)) 148 CALL Agrif_Set_bc(e2v_id,(/0,0/)) 147 149 148 150 ! 5. Update type 149 151 !--------------- 150 Call Agrif_Set_Updatetype(e1u_id,update1 = Agrif_Update_Copy, update2=Agrif_Update_Average) 151 Call Agrif_Set_Updatetype(e2v_id,update1 = Agrif_Update_Average, update2=Agrif_Update_Copy) 152 152 CALL Agrif_Set_Updatetype(e1u_id,update1 = Agrif_Update_Copy, update2=Agrif_Update_Average) 153 CALL Agrif_Set_Updatetype(e2v_id,update1 = Agrif_Update_Average, update2=Agrif_Update_Copy) 154 155 ! High order updates 156 ! CALL Agrif_Set_Updatetype(e1u_id,update1 = Agrif_Update_Average, update2=Agrif_Update_Full_Weighting) 157 ! CALL Agrif_Set_Updatetype(e2v_id,update1 = Agrif_Update_Full_Weighting, update2=Agrif_Update_Average) 158 ! 153 159 END SUBROUTINE agrif_declare_var_dom 154 160 … … 167 173 USE nemogcm 168 174 USE sol_oce 175 USE lib_mpp 169 176 USE in_out_manager 170 177 USE agrif_opa_update … … 174 181 IMPLICIT NONE 175 182 ! 176 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: tabtstemp177 REAL(wp), DIMENSION(:,:,: ), ALLOCATABLE :: tabuvtemp178 REAL(wp), DIMENSION(:,: ), ALLOCATABLE :: tab2d179 183 LOGICAL :: check_namelist 180 !!---------------------------------------------------------------------- 181 182 ALLOCATE( tabtstemp(jpi, jpj, jpk, jpts) ) 183 ALLOCATE( tabuvtemp(jpi, jpj, jpk) ) 184 ALLOCATE( tab2d(jpi, jpj) ) 185 184 CHARACTER(len=15) :: cl_check1, cl_check2, cl_check3 185 !!---------------------------------------------------------------------- 186 186 187 187 ! 1. Declaration of the type of variable which have to be interpolated … … 193 193 Agrif_SpecialValue=0. 194 194 Agrif_UseSpecialValue = .TRUE. 195 Call Agrif_Bc_variable(tabtstemp,tsn_id,calledweight=1.,procname=interptsn) 196 Call Agrif_Bc_variable(tabtstemp,tsa_id,calledweight=1.,procname=interptsn) 197 198 Call Agrif_Bc_variable(tabuvtemp,un_id,calledweight=1.,procname=interpu) 199 Call Agrif_Bc_variable(tabuvtemp,vn_id,calledweight=1.,procname=interpv) 200 Call Agrif_Bc_variable(tabuvtemp,ua_id,calledweight=1.,procname=interpun) 201 Call Agrif_Bc_variable(tabuvtemp,va_id,calledweight=1.,procname=interpvn) 202 203 Call Agrif_Bc_variable(tab2d,unb_id,calledweight=1.,procname=interpunb) 204 Call Agrif_Bc_variable(tab2d,vnb_id,calledweight=1.,procname=interpvnb) 205 Call Agrif_Bc_variable(tab2d,sshn_id,calledweight=1.,procname=interpsshn) 206 Agrif_UseSpecialValue = .FALSE. 195 CALL Agrif_Bc_variable(tsn_id,calledweight=1.,procname=interptsn) 196 CALL Agrif_Sponge 197 tabspongedone_tsn = .FALSE. 198 CALL Agrif_Bc_variable(tsn_sponge_id,calledweight=1.,procname=interptsn_sponge) 199 ! reset tsa to zero 200 tsa(:,:,:,:) = 0. 201 202 Agrif_UseSpecialValue = ln_spc_dyn 203 CALL Agrif_Bc_variable(un_interp_id,calledweight=1.,procname=interpun) 204 CALL Agrif_Bc_variable(vn_interp_id,calledweight=1.,procname=interpvn) 205 tabspongedone_u = .FALSE. 206 tabspongedone_v = .FALSE. 207 CALL Agrif_Bc_variable(un_sponge_id,calledweight=1.,procname=interpun_sponge) 208 tabspongedone_u = .FALSE. 209 tabspongedone_v = .FALSE. 210 CALL Agrif_Bc_variable(vn_sponge_id,calledweight=1.,procname=interpvn_sponge) 211 212 #if defined key_dynspg_ts 213 Agrif_UseSpecialValue = .TRUE. 214 CALL Agrif_Bc_variable(sshn_id,calledweight=1., procname=interpsshn ) 215 216 Agrif_UseSpecialValue = ln_spc_dyn 217 CALL Agrif_Bc_variable(unb_id,calledweight=1.,procname=interpunb) 218 CALL Agrif_Bc_variable(vnb_id,calledweight=1.,procname=interpvnb) 219 CALL Agrif_Bc_variable(ub2b_interp_id,calledweight=1.,procname=interpub2b) 220 CALL Agrif_Bc_variable(vb2b_interp_id,calledweight=1.,procname=interpvb2b) 221 ubdy_w(:) = 0.e0 ; vbdy_w(:) = 0.e0 ; hbdy_w(:) =0.e0 222 ubdy_e(:) = 0.e0 ; vbdy_e(:) = 0.e0 ; hbdy_e(:) =0.e0 223 ubdy_n(:) = 0.e0 ; vbdy_n(:) = 0.e0 ; hbdy_n(:) =0.e0 224 ubdy_s(:) = 0.e0 ; vbdy_s(:) = 0.e0 ; hbdy_s(:) =0.e0 225 #endif 226 227 Agrif_UseSpecialValue = .FALSE. 228 ! reset velocities to zero 229 ua(:,:,:) = 0. 230 va(:,:,:) = 0. 207 231 208 232 ! 3. Some controls 209 233 !----------------- 210 check_namelist = . true.211 212 IF( check_namelist ) THEN 234 check_namelist = .TRUE. 235 236 IF( check_namelist ) THEN 213 237 214 238 ! Check time steps 215 IF( NINT(Agrif_Rhot()) * nint(rdt) /= Agrif_Parent(rdt) ) THEN 216 WRITE(*,*) 'incompatible time step between grids' 217 WRITE(*,*) 'parent grid value : ',Agrif_Parent(rdt) 218 WRITE(*,*) 'child grid value : ',nint(rdt) 219 WRITE(*,*) 'value on parent grid should be : ',rdt*Agrif_Rhot() 220 STOP 239 IF( NINT(Agrif_Rhot()) * NINT(rdt) .NE. Agrif_Parent(rdt) ) THEN 240 WRITE(cl_check1,*) NINT(Agrif_Parent(rdt)) 241 WRITE(cl_check2,*) NINT(rdt) 242 WRITE(cl_check3,*) NINT(Agrif_Parent(rdt)/Agrif_Rhot()) 243 CALL ctl_warn( 'incompatible time step between grids', & 244 & 'parent grid value : '//cl_check1 , & 245 & 'child grid value : '//cl_check2 , & 246 & 'value on child grid will be changed to : '//cl_check3 ) 247 rdt=Agrif_Parent(rdt)/Agrif_Rhot() 221 248 ENDIF 222 249 223 250 ! Check run length 224 251 IF( Agrif_IRhot() * (Agrif_Parent(nitend)- & 225 Agrif_Parent(nit000)+1) .ne. (nitend-nit000+1) ) THEN 226 WRITE(*,*) 'incompatible run length between grids' 227 WRITE(*,*) 'parent grid value : ',(Agrif_Parent(nitend)- & 228 Agrif_Parent(nit000)+1),' time step' 229 WRITE(*,*) 'child grid value : ', & 230 (nitend-nit000+1),' time step' 231 WRITE(*,*) 'value on child grid should be : ', & 232 Agrif_IRhot() * (Agrif_Parent(nitend)- & 233 Agrif_Parent(nit000)+1) 234 STOP 252 Agrif_Parent(nit000)+1) .NE. (nitend-nit000+1) ) THEN 253 WRITE(cl_check1,*) (Agrif_Parent(nit000)-1)*Agrif_IRhot() + 1 254 WRITE(cl_check2,*) Agrif_Parent(nitend) *Agrif_IRhot() 255 CALL ctl_warn( 'incompatible run length between grids' , & 256 & ' nit000 on fine grid will be change to : '//cl_check1, & 257 & ' nitend on fine grid will be change to : '//cl_check2 ) 258 nit000 = (Agrif_Parent(nit000)-1)*Agrif_IRhot() + 1 259 nitend = Agrif_Parent(nitend) *Agrif_IRhot() 235 260 ENDIF 236 261 … … 238 263 IF( ln_zps ) THEN 239 264 ! check parameters for partial steps 240 IF( Agrif_Parent(e3zps_min) . ne. e3zps_min ) THEN265 IF( Agrif_Parent(e3zps_min) .NE. e3zps_min ) THEN 241 266 WRITE(*,*) 'incompatible e3zps_min between grids' 242 267 WRITE(*,*) 'parent grid :',Agrif_Parent(e3zps_min) … … 253 278 ENDIF 254 279 ENDIF 280 ! check if masks and bathymetries match 281 IF(ln_chk_bathy) THEN 282 ! 283 IF(lwp) WRITE(numout,*) 'AGRIF: Check Bathymetry and masks near bdys. Level: ', Agrif_Level() 284 ! 285 kindic_agr = 0 286 ! check if umask agree with parent along western and eastern boundaries: 287 CALL Agrif_Bc_variable(umsk_id,calledweight=1.,procname=interpumsk) 288 ! check if vmask agree with parent along northern and southern boundaries: 289 CALL Agrif_Bc_variable(vmsk_id,calledweight=1.,procname=interpvmsk) 290 ! check if tmask and vertical scale factors agree with parent over first two coarse grid points: 291 CALL Agrif_Bc_variable(e3t_id,calledweight=1.,procname=interpe3t) 292 ! 293 IF (lk_mpp) CALL mpp_sum( kindic_agr ) 294 IF( kindic_agr /= 0 ) THEN 295 CALL ctl_stop('Child Bathymetry is not correct near boundaries.') 296 ELSE 297 IF(lwp) WRITE(numout,*) 'Child Bathymetry is ok near boundaries.' 298 END IF 299 ENDIF 300 ! 255 301 ENDIF 256 257 CALL Agrif_Update_tra(0) 258 CALL Agrif_Update_dyn(0) 259 302 ! 303 ! Do update at initialisation because not done before writing restarts 304 ! This would indeed change boundary conditions values at initial time 305 ! hence produce restartability issues. 306 ! Note that update below is recursive (with lk_agrif_doupd=T): 307 ! 308 ! JC: I am not sure if Agrif_MaxLevel() is the "relative" 309 ! or the absolute maximum nesting level...TBC 310 IF ( Agrif_Level().EQ.Agrif_MaxLevel() ) THEN 311 ! NB: Do tracers first, dynamics after because nbcline incremented in dynamics 312 CALL Agrif_Update_tra() 313 CALL Agrif_Update_dyn() 314 ENDIF 315 ! 316 # if defined key_zdftke 317 ! CALL Agrif_Update_tke(0) 318 # endif 319 ! 320 Agrif_UseSpecialValueInUpdate = .FALSE. 260 321 nbcline = 0 261 ! 262 DEALLOCATE(tabtstemp) 263 DEALLOCATE(tabuvtemp) 264 DEALLOCATE(tab2d) 322 lk_agrif_doupd = .FALSE. 265 323 ! 266 324 END SUBROUTINE Agrif_InitValues_cont … … 276 334 USE par_oce ! ONLY : jpts 277 335 USE oce 336 USE agrif_oce 278 337 IMPLICIT NONE 279 338 !!---------------------------------------------------------------------- … … 281 340 ! 1. Declaration of the type of variable which have to be interpolated 282 341 !--------------------------------------------------------------------- 283 CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jpts/),tsn_id) 284 CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jpts/),tsa_id) 285 CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jpts/),tsb_id) 286 287 CALL agrif_declare_variable((/1,2,0/),(/2,3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),un_id) 288 CALL agrif_declare_variable((/2,1,0/),(/3,2,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),vn_id) 289 CALL agrif_declare_variable((/1,2,0/),(/2,3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),ua_id) 290 CALL agrif_declare_variable((/2,1,0/),(/3,2,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),va_id) 291 292 CALL agrif_declare_variable((/1,2/),(/2,3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),unb_id) 293 CALL agrif_declare_variable((/2,1/),(/3,2/),(/'x','y'/),(/1,1/),(/jpi,jpj/),vnb_id) 294 CALL agrif_declare_variable((/2,2/),(/3,3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),sshn_id) 295 CALL agrif_declare_variable((/2,2/),(/3,3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),gcb_id) 296 CALL agrif_declare_variable((/1,2/),(/2,3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),ub2b_id) 297 CALL agrif_declare_variable((/2,1/),(/3,2/),(/'x','y'/),(/1,1/),(/jpi,jpj/),vb2b_id) 342 CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jpts/),tsn_id) 343 CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jpts/),tsn_sponge_id) 344 345 CALL agrif_declare_variable((/1,2,0/),(/2,3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),un_interp_id) 346 CALL agrif_declare_variable((/2,1,0/),(/3,2,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),vn_interp_id) 347 CALL agrif_declare_variable((/1,2,0/),(/2,3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),un_update_id) 348 CALL agrif_declare_variable((/2,1,0/),(/3,2,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),vn_update_id) 349 CALL agrif_declare_variable((/1,2,0/),(/2,3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),un_sponge_id) 350 CALL agrif_declare_variable((/2,1,0/),(/3,2,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),vn_sponge_id) 351 352 CALL agrif_declare_variable((/2,2,0/),(/3,3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),e3t_id) 353 CALL agrif_declare_variable((/1,2,0/),(/2,3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),umsk_id) 354 CALL agrif_declare_variable((/2,1,0/),(/3,2,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),vmsk_id) 355 356 CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,3/),scales_t_id) 357 358 CALL agrif_declare_variable((/1,2/),(/2,3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),unb_id) 359 CALL agrif_declare_variable((/2,1/),(/3,2/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),vnb_id) 360 CALL agrif_declare_variable((/1,2/),(/2,3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),ub2b_interp_id) 361 CALL agrif_declare_variable((/2,1/),(/3,2/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),vb2b_interp_id) 362 CALL agrif_declare_variable((/1,2/),(/2,3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),ub2b_update_id) 363 CALL agrif_declare_variable((/2,1/),(/3,2/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),vb2b_update_id) 364 365 CALL agrif_declare_variable((/2,2/),(/3,3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),sshn_id) 366 367 # if defined key_zdftke 368 CALL agrif_declare_variable((/2,2,0/),(/3,3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/), en_id) 369 CALL agrif_declare_variable((/2,2,0/),(/3,3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),avt_id) 370 CALL agrif_declare_variable((/2,2,0/),(/3,3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),avm_id) 371 # endif 298 372 299 373 ! 2. Type of interpolation 300 374 !------------------------- 301 375 CALL Agrif_Set_bcinterp(tsn_id,interp=AGRIF_linear) 302 CALL Agrif_Set_bcinterp(tsa_id,interp=AGRIF_linear) 303 304 Call Agrif_Set_bcinterp(un_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 305 Call Agrif_Set_bcinterp(vn_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 306 307 Call Agrif_Set_bcinterp(ua_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 308 Call Agrif_Set_bcinterp(va_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 376 377 CALL Agrif_Set_bcinterp(un_interp_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 378 CALL Agrif_Set_bcinterp(vn_interp_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 379 380 CALL Agrif_Set_bcinterp(tsn_sponge_id,interp=AGRIF_linear) 309 381 310 382 CALL Agrif_Set_bcinterp(sshn_id,interp=AGRIF_linear) 311 Call Agrif_Set_bcinterp(unb_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 312 Call Agrif_Set_bcinterp(vnb_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 313 Call Agrif_Set_bcinterp(ub2b_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 314 Call Agrif_Set_bcinterp(vb2b_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 383 CALL Agrif_Set_bcinterp(unb_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 384 CALL Agrif_Set_bcinterp(vnb_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 385 CALL Agrif_Set_bcinterp(ub2b_interp_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 386 CALL Agrif_Set_bcinterp(vb2b_interp_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 387 388 389 CALL Agrif_Set_bcinterp(un_sponge_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 390 CALL Agrif_Set_bcinterp(vn_sponge_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 391 392 CALL Agrif_Set_bcinterp(e3t_id,interp=AGRIF_constant) 393 CALL Agrif_Set_bcinterp(umsk_id,interp=AGRIF_constant) 394 CALL Agrif_Set_bcinterp(vmsk_id,interp=AGRIF_constant) 395 396 # if defined key_zdftke 397 CALL Agrif_Set_bcinterp(avm_id ,interp=AGRIF_linear) 398 # endif 399 315 400 316 401 ! 3. Location of interpolation 317 402 !----------------------------- 318 Call Agrif_Set_bc(un_id,(/0,1/)) 319 Call Agrif_Set_bc(vn_id,(/0,1/)) 320 321 Call Agrif_Set_bc(sshn_id,(/0,1/)) 322 Call Agrif_Set_bc(unb_id,(/0,1/)) 323 Call Agrif_Set_bc(vnb_id,(/0,1/)) 324 Call Agrif_Set_bc(ub2b_id,(/0,1/)) 325 Call Agrif_Set_bc(vb2b_id,(/0,1/)) 326 327 Call Agrif_Set_bc(tsn_id,(/0,1/)) 328 Call Agrif_Set_bc(tsa_id,(/-3*Agrif_irhox(),0/)) 329 330 Call Agrif_Set_bc(ua_id,(/-2*Agrif_irhox(),0/)) 331 Call Agrif_Set_bc(va_id,(/-2*Agrif_irhox(),0/)) 403 CALL Agrif_Set_bc(tsn_id,(/0,1/)) 404 CALL Agrif_Set_bc(un_interp_id,(/0,1/)) 405 CALL Agrif_Set_bc(vn_interp_id,(/0,1/)) 406 407 ! CALL Agrif_Set_bc(tsn_sponge_id,(/-3*Agrif_irhox(),0/)) 408 ! CALL Agrif_Set_bc(un_sponge_id,(/-2*Agrif_irhox()-1,0/)) 409 ! CALL Agrif_Set_bc(vn_sponge_id,(/-2*Agrif_irhox()-1,0/)) 410 CALL Agrif_Set_bc(tsn_sponge_id,(/-nn_sponge_len*Agrif_irhox()-1,0/)) 411 CALL Agrif_Set_bc(un_sponge_id ,(/-nn_sponge_len*Agrif_irhox()-1,0/)) 412 CALL Agrif_Set_bc(vn_sponge_id ,(/-nn_sponge_len*Agrif_irhox()-1,0/)) 413 414 CALL Agrif_Set_bc(sshn_id,(/0,0/)) 415 CALL Agrif_Set_bc(unb_id ,(/0,0/)) 416 CALL Agrif_Set_bc(vnb_id ,(/0,0/)) 417 CALL Agrif_Set_bc(ub2b_interp_id,(/0,0/)) 418 CALL Agrif_Set_bc(vb2b_interp_id,(/0,0/)) 419 420 CALL Agrif_Set_bc(e3t_id,(/-2*Agrif_irhox()-1,0/)) ! if west and rhox=3: column 2 to 9 421 CALL Agrif_Set_bc(umsk_id,(/0,0/)) 422 CALL Agrif_Set_bc(vmsk_id,(/0,0/)) 423 424 # if defined key_zdftke 425 CALL Agrif_Set_bc(avm_id ,(/0,1/)) 426 # endif 332 427 333 428 ! 5. Update type 334 429 !--------------- 335 Call Agrif_Set_Updatetype(tsn_id, update = AGRIF_Update_Average) 336 Call Agrif_Set_Updatetype(tsb_id, update = AGRIF_Update_Average) 337 338 Call Agrif_Set_Updatetype(sshn_id, update = AGRIF_Update_Average) 339 Call Agrif_Set_Updatetype(gcb_id,update = AGRIF_Update_Average) 340 341 Call Agrif_Set_Updatetype(un_id,update1 = Agrif_Update_Copy, update2 = Agrif_Update_Average) 342 Call Agrif_Set_Updatetype(vn_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy) 343 344 Call Agrif_Set_Updatetype(ub2b_id,update1 = Agrif_Update_Copy, update2 = Agrif_Update_Average) 345 Call Agrif_Set_Updatetype(vb2b_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy) 346 430 CALL Agrif_Set_Updatetype(tsn_id, update = AGRIF_Update_Average) 431 432 CALL Agrif_Set_Updatetype(scales_t_id, update = AGRIF_Update_Average) 433 434 CALL Agrif_Set_Updatetype(un_update_id,update1 = Agrif_Update_Copy, update2 = Agrif_Update_Average) 435 CALL Agrif_Set_Updatetype(vn_update_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy) 436 437 CALL Agrif_Set_Updatetype(sshn_id, update = AGRIF_Update_Average) 438 439 CALL Agrif_Set_Updatetype(ub2b_update_id,update1 = Agrif_Update_Copy, update2 = Agrif_Update_Average) 440 CALL Agrif_Set_Updatetype(vb2b_update_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy) 441 442 # if defined key_zdftke 443 CALL Agrif_Set_Updatetype( en_id, update = AGRIF_Update_Average) 444 CALL Agrif_Set_Updatetype(avt_id, update = AGRIF_Update_Average) 445 CALL Agrif_Set_Updatetype(avm_id, update = AGRIF_Update_Average) 446 # endif 447 448 ! High order updates 449 ! CALL Agrif_Set_Updatetype(tsn_id, update = Agrif_Update_Full_Weighting) 450 ! CALL Agrif_Set_Updatetype(un_update_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Full_Weighting) 451 ! CALL Agrif_Set_Updatetype(vn_update_id,update1 = Agrif_Update_Full_Weighting, update2 = Agrif_Update_Average) 452 ! 453 ! CALL Agrif_Set_Updatetype(ub2b_update_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Full_Weighting) 454 ! CALL Agrif_Set_Updatetype(vb2b_update_id,update1 = Agrif_Update_Full_Weighting, update2 = Agrif_Update_Average) 455 ! CALL Agrif_Set_Updatetype(sshn_id, update = Agrif_Update_Full_Weighting) 456 457 ! 347 458 END SUBROUTINE agrif_declare_var 348 459 # endif … … 365 476 IMPLICIT NONE 366 477 ! 367 REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: zvel 368 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zadv 369 !!---------------------------------------------------------------------- 370 371 ALLOCATE( zvel(jpi,jpj), zadv(jpi,jpj,7)) 478 !!---------------------------------------------------------------------- 372 479 373 480 ! 1. Declaration of the type of variable which have to be interpolated … … 401 508 CALL Agrif_Update_lim2(0) 402 509 ! 403 DEALLOCATE( zvel, zadv )404 !405 510 END SUBROUTINE Agrif_InitValues_cont_lim2 406 511 … … 431 536 !------------------------- 432 537 CALL Agrif_Set_bcinterp(adv_ice_id ,interp=AGRIF_linear) 433 C allAgrif_Set_bcinterp(u_ice_id,interp1=Agrif_linear,interp2=AGRIF_ppm)434 C allAgrif_Set_bcinterp(v_ice_id,interp1=AGRIF_ppm,interp2=Agrif_linear)538 CALL Agrif_Set_bcinterp(u_ice_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 539 CALL Agrif_Set_bcinterp(v_ice_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 435 540 436 541 ! 3. Location of interpolation 437 542 !----------------------------- 438 C allAgrif_Set_bc(adv_ice_id ,(/0,1/))439 C allAgrif_Set_bc(u_ice_id,(/0,1/))440 C allAgrif_Set_bc(v_ice_id,(/0,1/))543 CALL Agrif_Set_bc(adv_ice_id ,(/0,1/)) 544 CALL Agrif_Set_bc(u_ice_id,(/0,1/)) 545 CALL Agrif_Set_bc(v_ice_id,(/0,1/)) 441 546 442 547 ! 5. Update type 443 548 !--------------- 444 C allAgrif_Set_Updatetype(adv_ice_id , update = AGRIF_Update_Average)445 C allAgrif_Set_Updatetype(u_ice_id,update1 = Agrif_Update_Copy, update2 = Agrif_Update_Average)446 C allAgrif_Set_Updatetype(v_ice_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy)447 549 CALL Agrif_Set_Updatetype(adv_ice_id , update = AGRIF_Update_Average) 550 CALL Agrif_Set_Updatetype(u_ice_id,update1 = Agrif_Update_Copy, update2 = Agrif_Update_Average) 551 CALL Agrif_Set_Updatetype(v_ice_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy) 552 ! 448 553 END SUBROUTINE agrif_declare_var_lim2 449 554 # endif … … 462 567 USE nemogcm 463 568 USE par_trc 569 USE lib_mpp 464 570 USE trc 465 571 USE in_out_manager 572 USE agrif_opa_sponge 466 573 USE agrif_top_update 467 574 USE agrif_top_interp … … 470 577 IMPLICIT NONE 471 578 ! 472 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: tabtrtemp579 CHARACTER(len=10) :: cl_check1, cl_check2, cl_check3 473 580 LOGICAL :: check_namelist 474 581 !!---------------------------------------------------------------------- 475 476 ALLOCATE( tabtrtemp(jpi,jpj,jpk,jptra) )477 582 478 583 … … 485 590 Agrif_SpecialValue=0. 486 591 Agrif_UseSpecialValue = .TRUE. 487 Call Agrif_Bc_variable(tabtrtemp,trn_id,calledweight=1.,procname=interptrn) 488 Call Agrif_Bc_variable(tabtrtemp,tra_id,calledweight=1.,procname=interptrn) 592 CALL Agrif_Bc_variable(trn_id,calledweight=1.,procname=interptrn) 489 593 Agrif_UseSpecialValue = .FALSE. 594 CALL Agrif_Sponge 595 tabspongedone_trn = .FALSE. 596 CALL Agrif_Bc_variable(trn_sponge_id,calledweight=1.,procname=interptrn_sponge) 597 ! reset tsa to zero 598 tra(:,:,:,:) = 0. 599 490 600 491 601 ! 3. Some controls 492 602 !----------------- 493 check_namelist = . true.603 check_namelist = .TRUE. 494 604 495 605 IF( check_namelist ) THEN 496 # if defined offline606 # if defined key_offline 497 607 ! Check time steps 498 IF( nint(Agrif_Rhot()) * nint(rdt) .ne. Agrif_Parent(rdt) ) THEN 499 WRITE(*,*) 'incompatible time step between grids' 500 WRITE(*,*) 'parent grid value : ',Agrif_Parent(rdt) 501 WRITE(*,*) 'child grid value : ',nint(rdt) 502 WRITE(*,*) 'value on parent grid should be : ',rdt*Agrif_Rhot() 503 STOP 608 IF( NINT(Agrif_Rhot()) * NINT(rdt) .NE. Agrif_Parent(rdt) ) THEN 609 WRITE(cl_check1,*) Agrif_Parent(rdt) 610 WRITE(cl_check2,*) rdt 611 WRITE(cl_check3,*) rdt*Agrif_Rhot() 612 CALL ctl_warn( 'incompatible time step between grids', & 613 & 'parent grid value : '//cl_check1 , & 614 & 'child grid value : '//cl_check2 , & 615 & 'value on child grid will be changed to & 616 & :'//cl_check3 ) 617 rdt=rdt*Agrif_Rhot() 504 618 ENDIF 505 619 506 620 ! Check run length 507 621 IF( Agrif_IRhot() * (Agrif_Parent(nitend)- & 508 Agrif_Parent(nit000)+1) .ne. (nitend-nit000+1) ) THEN 509 WRITE(*,*) 'incompatible run length between grids' 510 WRITE(*,*) 'parent grid value : ',(Agrif_Parent(nitend)- & 511 Agrif_Parent(nit000)+1),' time step' 512 WRITE(*,*) 'child grid value : ', & 513 (nitend-nit000+1),' time step' 514 WRITE(*,*) 'value on child grid should be : ', & 515 Agrif_IRhot() * (Agrif_Parent(nitend)- & 516 Agrif_Parent(nit000)+1) 517 STOP 622 Agrif_Parent(nit000)+1) .NE. (nitend-nit000+1) ) THEN 623 WRITE(cl_check1,*) (Agrif_Parent(nit000)-1)*Agrif_IRhot() + 1 624 WRITE(cl_check2,*) Agrif_Parent(nitend) *Agrif_IRhot() 625 CALL ctl_warn( 'incompatible run length between grids' , & 626 & ' nit000 on fine grid will be change to : '//cl_check1, & 627 & ' nitend on fine grid will be change to : '//cl_check2 ) 628 nit000 = (Agrif_Parent(nit000)-1)*Agrif_IRhot() + 1 629 nitend = Agrif_Parent(nitend) *Agrif_IRhot() 518 630 ENDIF 519 631 … … 521 633 IF( ln_zps ) THEN 522 634 ! check parameters for partial steps 523 IF( Agrif_Parent(e3zps_min) . ne. e3zps_min ) THEN635 IF( Agrif_Parent(e3zps_min) .NE. e3zps_min ) THEN 524 636 WRITE(*,*) 'incompatible e3zps_min between grids' 525 637 WRITE(*,*) 'parent grid :',Agrif_Parent(e3zps_min) … … 528 640 STOP 529 641 ENDIF 530 IF( Agrif_Parent(e3zps_rat) . ne. e3zps_rat ) THEN642 IF( Agrif_Parent(e3zps_rat) .NE. e3zps_rat ) THEN 531 643 WRITE(*,*) 'incompatible e3zps_rat between grids' 532 644 WRITE(*,*) 'parent grid :',Agrif_Parent(e3zps_rat) … … 538 650 # endif 539 651 ! Check passive tracer cell 540 IF( nn_dttrc . ne. 1 ) THEN652 IF( nn_dttrc .NE. 1 ) THEN 541 653 WRITE(*,*) 'nn_dttrc should be equal to 1' 542 654 ENDIF 543 655 ENDIF 544 656 545 !ch CALL Agrif_Update_trc(0) 657 CALL Agrif_Update_trc(0) 658 ! 659 Agrif_UseSpecialValueInUpdate = .FALSE. 546 660 nbcline_trc = 0 547 !548 DEALLOCATE(tabtrtemp)549 661 ! 550 662 END SUBROUTINE Agrif_InitValues_cont_top … … 558 670 !!---------------------------------------------------------------------- 559 671 USE agrif_util 672 USE agrif_oce 560 673 USE dom_oce 561 674 USE trc … … 565 678 ! 1. Declaration of the type of variable which have to be interpolated 566 679 !--------------------------------------------------------------------- 567 CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jptra/),trn_id) 568 CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jptra/),trb_id) 569 CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jptra/),tra_id) 680 CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jptra/),trn_id) 681 CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jptra/),trn_sponge_id) 570 682 571 683 ! 2. Type of interpolation 572 684 !------------------------- 573 685 CALL Agrif_Set_bcinterp(trn_id,interp=AGRIF_linear) 574 CALL Agrif_Set_bcinterp(tr a_id,interp=AGRIF_linear)686 CALL Agrif_Set_bcinterp(trn_sponge_id,interp=AGRIF_linear) 575 687 576 688 ! 3. Location of interpolation 577 689 !----------------------------- 578 Call Agrif_Set_bc(trn_id,(/0,1/)) 579 Call Agrif_Set_bc(tra_id,(/-3*Agrif_irhox(),0/)) 690 CALL Agrif_Set_bc(trn_id,(/0,1/)) 691 ! CALL Agrif_Set_bc(trn_sponge_id,(/-3*Agrif_irhox(),0/)) 692 CALL Agrif_Set_bc(trn_sponge_id,(/-nn_sponge_len*Agrif_irhox()-1,0/)) 580 693 581 694 ! 5. Update type 582 695 !--------------- 583 Call Agrif_Set_Updatetype(trn_id, update = AGRIF_Update_Average) 584 Call Agrif_Set_Updatetype(trb_id, update = AGRIF_Update_Average) 585 586 696 CALL Agrif_Set_Updatetype(trn_id, update = AGRIF_Update_Average) 697 698 ! Higher order update 699 ! CALL Agrif_Set_Updatetype(tsn_id, update = Agrif_Update_Full_Weighting) 700 701 ! 587 702 END SUBROUTINE agrif_declare_var_top 588 703 # endif … … 592 707 !! *** ROUTINE Agrif_detect *** 593 708 !!---------------------------------------------------------------------- 594 USE Agrif_Types595 709 ! 596 710 INTEGER, DIMENSION(2) :: ksizex … … 614 728 ! 615 729 INTEGER :: ios ! Local integer output status for namelist read 616 NAMELIST/namagrif/ nn_cln_update, rn_sponge_tra, rn_sponge_dyn, ln_spc_dyn 617 !!---------------------------------------------------------------------- 618 ! 619 REWIND( numnam_ref ) ! Namelist namagrif in reference namelist : AGRIF zoom 620 READ ( numnam_ref, namagrif, IOSTAT = ios, ERR = 901) 621 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namagrif in reference namelist', lwp ) 622 623 REWIND( numnam_cfg ) ! Namelist namagrif in configuration namelist : AGRIF zoom 624 READ ( numnam_cfg, namagrif, IOSTAT = ios, ERR = 902 ) 625 902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namagrif in configuration namelist', lwp ) 626 IF(lwm) WRITE ( numond, namagrif ) 730 INTEGER :: iminspon 731 NAMELIST/namagrif/ nn_cln_update, rn_sponge_tra, rn_sponge_dyn, ln_spc_dyn, ln_chk_bathy 732 !!-------------------------------------------------------------------------------------- 733 ! 734 REWIND( numnam_ref ) ! Namelist namagrif in reference namelist : AGRIF zoom 735 READ ( numnam_ref, namagrif, IOSTAT = ios, ERR = 901) 736 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namagrif in reference namelist', lwp ) 737 738 REWIND( numnam_cfg ) ! Namelist namagrif in configuration namelist : AGRIF zoom 739 READ ( numnam_cfg, namagrif, IOSTAT = ios, ERR = 902 ) 740 902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namagrif in configuration namelist', lwp ) 741 IF(lwm) WRITE ( numond, namagrif ) 627 742 ! 628 743 IF(lwp) THEN ! control print … … 635 750 WRITE(numout,*) ' sponge coefficient for dynamics rn_sponge_tra = ', rn_sponge_dyn, ' s' 636 751 WRITE(numout,*) ' use special values for dynamics ln_spc_dyn = ', ln_spc_dyn 752 WRITE(numout,*) ' check bathymetry ln_chk_bathy = ', ln_chk_bathy 637 753 WRITE(numout,*) 638 754 ENDIF … … 643 759 visc_dyn = rn_sponge_dyn 644 760 ! 645 IF( agrif_oce_alloc() > 0 ) CALL ctl_warn('agrif sol_oce_alloc: allocation of arrays failed') 761 ! Check sponge length: 762 iminspon = MIN(FLOOR(REAL(jpiglo-4)/REAL(2*Agrif_irhox())), FLOOR(REAL(jpjglo-4)/REAL(2*Agrif_irhox())) ) 763 IF (lk_mpp) iminspon = MIN(iminspon,FLOOR(REAL(jpi-2)/REAL(Agrif_irhox())), FLOOR(REAL(jpj-2)/REAL(Agrif_irhox())) ) 764 IF (nn_sponge_len > iminspon) CALL ctl_stop('agrif sponge length is too large') 765 ! 766 IF( agrif_oce_alloc() > 0 ) CALL ctl_warn('agrif agrif_oce_alloc: allocation of arrays failed') 646 767 # if defined key_lim2 647 768 IF( agrif_ice_alloc() > 0 ) CALL ctl_stop('agrif agrif_ice_alloc: allocation of arrays failed') … … 664 785 SELECT CASE( i ) 665 786 CASE(1) ; indglob = indloc + nimppt(nprocloc+1) - 1 666 CASE(2) ; indglob = indloc + njmppt(nprocloc+1) - 1 667 CASE (3) ; indglob = indloc668 CASE(4) ;indglob = indloc787 CASE(2) ; indglob = indloc + njmppt(nprocloc+1) - 1 788 CASE DEFAULT 789 indglob = indloc 669 790 END SELECT 670 791 ! 671 792 END SUBROUTINE Agrif_InvLoc 793 794 SUBROUTINE Agrif_get_proc_info( imin, imax, jmin, jmax ) 795 !!---------------------------------------------------------------------- 796 !! *** ROUTINE Agrif_get_proc_info *** 797 !!---------------------------------------------------------------------- 798 USE par_oce 799 IMPLICIT NONE 800 ! 801 INTEGER, INTENT(out) :: imin, imax 802 INTEGER, INTENT(out) :: jmin, jmax 803 !!---------------------------------------------------------------------- 804 ! 805 imin = nimppt(Agrif_Procrank+1) ! ????? 806 jmin = njmppt(Agrif_Procrank+1) ! ????? 807 imax = imin + jpi - 1 808 jmax = jmin + jpj - 1 809 ! 810 END SUBROUTINE Agrif_get_proc_info 811 812 SUBROUTINE Agrif_estimate_parallel_cost(imin, imax,jmin, jmax, nbprocs, grid_cost) 813 !!---------------------------------------------------------------------- 814 !! *** ROUTINE Agrif_estimate_parallel_cost *** 815 !!---------------------------------------------------------------------- 816 USE par_oce 817 IMPLICIT NONE 818 ! 819 INTEGER, INTENT(in) :: imin, imax 820 INTEGER, INTENT(in) :: jmin, jmax 821 INTEGER, INTENT(in) :: nbprocs 822 REAL(wp), INTENT(out) :: grid_cost 823 !!---------------------------------------------------------------------- 824 ! 825 grid_cost = REAL(imax-imin+1,wp)*REAL(jmax-jmin+1,wp) / REAL(nbprocs,wp) 826 ! 827 END SUBROUTINE Agrif_estimate_parallel_cost 672 828 673 829 # endif -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OFF_SRC/dtadyn.F90
r6836 r6839 431 431 CALL ctl_stop( 'dta_dyn: unable to allocate sf structure' ) ; RETURN 432 432 ENDIF 433 ! ! fill sf with slf_i and control print 434 CALL fld_fill( sf_dyn, slf_d, cn_dir, 'dta_dyn_init', 'Data in file', 'namdta_dyn' ) 433 435 ! Open file for each variable to get his number of dimension 434 436 DO ifpr = 1, jfld 435 CALL iom_open( TRIM( cn_dir )//TRIM( slf_d(ifpr)%clname ), inum ) 436 idv = iom_varid( inum , slf_d(ifpr)%clvar ) ! id of the variable sdjf%clvar 437 idimv = iom_file ( inum )%ndims(idv) ! number of dimension for variable sdjf%clvar 438 IF( inum /= 0 ) CALL iom_close( inum ) ! close file if already open 437 CALL fld_clopn( sf_dyn(ifpr), nyear, nmonth, nday ) 438 idv = iom_varid( sf_dyn(ifpr)%num , slf_d(ifpr)%clvar ) ! id of the variable sdjf%clvar 439 idimv = iom_file ( sf_dyn(ifpr)%num )%ndims(idv) ! number of dimension for variable sdjf%clvar 440 IF( sf_dyn(ifpr)%num /= 0 ) CALL iom_close( sf_dyn(ifpr)%num ) ! close file if already open 441 ierr1=0 439 442 IF( idimv == 3 ) THEN ! 2D variable 440 443 ALLOCATE( sf_dyn(ifpr)%fnow(jpi,jpj,1) , STAT=ierr0 ) … … 448 451 ENDIF 449 452 END DO 450 ! ! fill sf with slf_i and control print451 CALL fld_fill( sf_dyn, slf_d, cn_dir, 'dta_dyn_init', 'Data in file', 'namdta_dyn' )452 453 ! 453 454 IF( lk_ldfslp .AND. .NOT.lk_c1d ) THEN ! slopes -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/ASM/asminc.F90
r6836 r6839 658 658 659 659 DO jk = 1, jpkm1 660 fzptnz(:,:,jk) = eos_fzp( tsn(:,:,jk,jp_sal), fsdept(:,:,jk) )660 CALL eos_fzp( tsn(:,:,jk,jp_sal), fzptnz(:,:,jk), fsdept(:,:,jk) ) 661 661 END DO 662 662 -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/BDY/bdydta.F90
r6836 r6839 430 430 CHARACTER(len=100) :: cn_dir ! Root directory for location of data files 431 431 CHARACTER(len=100), DIMENSION(nb_bdy) :: cn_dir_array ! Root directory for location of data files 432 CHARACTER(len = 256):: clname ! temporary file name 432 433 LOGICAL :: ln_full_vel ! =T => full velocities in 3D boundary data 433 434 ! =F => baroclinic velocities in 3D boundary data … … 669 670 ! sea ice 670 671 IF( nn_ice_lim_dta(ib_bdy) .eq. 1 ) THEN 671 672 ! Test for types of ice input (lim2 or lim3) 673 CALL iom_open ( bn_a_i%clname, inum ) 674 id1 = iom_varid ( inum, bn_a_i%clvar, kdimsz=zdimsz, kndims=zndims, ldstop = .FALSE. ) 672 ! Test for types of ice input (lim2 or lim3) 673 ! Build file name to find dimensions 674 clname=TRIM(bn_a_i%clname) 675 IF( .NOT. bn_a_i%ln_clim ) THEN 676 WRITE(clname, '(a,"_y",i4.4)' ) TRIM( bn_a_i%clname ), nyear ! add year 677 IF( bn_a_i%cltype /= 'yearly' ) WRITE(clname, '(a,"m" ,i2.2)' ) TRIM( clname ), nmonth ! add month 678 ELSE 679 IF( bn_a_i%cltype /= 'yearly' ) WRITE(clname, '(a,"_m",i2.2)' ) TRIM( bn_a_i%clname ), nmonth ! add month 680 ENDIF 681 IF( bn_a_i%cltype == 'daily' .OR. bn_a_i%cltype(1:4) == 'week' ) & 682 & WRITE(clname, '(a,"d" ,i2.2)' ) TRIM( clname ), nday ! add day 683 ! 684 CALL iom_open ( clname, inum ) 685 id1 = iom_varid( inum, bn_a_i%clvar, kdimsz=zdimsz, kndims=zndims, ldstop = .FALSE. ) 675 686 CALL iom_close ( inum ) 676 !CALL fld_clopn ( bn_a_i, nyear, nmonth, nday, ldstop=.TRUE. ) 677 !CALL iom_open ( bn_a_i%clname, inum ) 678 !id1 = iom_varid ( bn_a_i%num, bn_a_i%clvar, kdimsz=zdimsz, kndims=zndims, ldstop = .FALSE. ) 687 679 688 IF ( zndims == 4 ) THEN 680 689 ll_bdylim3 = .TRUE. ! lim3 input -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/BDY/bdydyn2d.F90
r6836 r6839 49 49 !!---------------------------------------------------------------------- 50 50 INTEGER, INTENT(in) :: kt ! Main time step counter 51 REAL(wp), DIMENSION( jpi,jpj), INTENT(inout) :: pua2d, pva2d52 REAL(wp), DIMENSION( jpi,jpj), INTENT(in ) :: pub2d, pvb2d53 REAL(wp), DIMENSION( jpi,jpj), INTENT(in ) :: phur, phvr54 REAL(wp), DIMENSION( jpi,jpj), INTENT(in ) :: pssh51 REAL(wp), DIMENSION(:,:), INTENT(inout) :: pua2d, pva2d 52 REAL(wp), DIMENSION(:,:), INTENT(in ) :: pub2d, pvb2d 53 REAL(wp), DIMENSION(:,:), INTENT(in ) :: phur, phvr 54 REAL(wp), DIMENSION(:,:), INTENT(in ) :: pssh 55 55 !! 56 56 INTEGER :: ib_bdy ! Loop counter … … 92 92 TYPE(OBC_DATA), INTENT(in) :: dta ! OBC external data 93 93 INTEGER, INTENT(in) :: ib_bdy ! BDY set index 94 REAL(wp), DIMENSION( jpi,jpj), INTENT(inout) :: pua2d, pva2d94 REAL(wp), DIMENSION(:,:), INTENT(inout) :: pua2d, pva2d 95 95 !! 96 96 INTEGER :: jb, jk ! dummy loop indices … … 147 147 TYPE(OBC_DATA), INTENT(in) :: dta ! OBC external data 148 148 INTEGER, INTENT(in) :: ib_bdy ! BDY set index 149 REAL(wp), DIMENSION( jpi,jpj), INTENT(inout) :: pua2d, pva2d150 REAL(wp), DIMENSION( jpi,jpj), INTENT(in) :: pssh, phur, phvr149 REAL(wp), DIMENSION(:,:), INTENT(inout) :: pua2d, pva2d 150 REAL(wp), DIMENSION(:,:), INTENT(in) :: pssh, phur, phvr 151 151 152 152 INTEGER :: jb, igrd ! dummy loop indices … … 237 237 TYPE(OBC_DATA), INTENT(in) :: dta ! OBC external data 238 238 INTEGER, INTENT(in) :: ib_bdy ! number of current open boundary set 239 REAL(wp), DIMENSION( jpi,jpj),INTENT(inout) :: pua2d, pva2d240 REAL(wp), DIMENSION( jpi,jpj),INTENT(in) :: pub2d, pvb2d239 REAL(wp), DIMENSION(:,:), INTENT(inout) :: pua2d, pva2d 240 REAL(wp), DIMENSION(:,:), INTENT(in) :: pub2d, pvb2d 241 241 LOGICAL, INTENT(in) :: ll_npo ! flag for NPO version 242 242 … … 271 271 !! 272 272 !!---------------------------------------------------------------------- 273 REAL(wp), DIMENSION( jpi,jpj), INTENT(inout) :: zssh ! Sea level273 REAL(wp), DIMENSION(:,:), INTENT(inout) :: zssh ! Sea level 274 274 !! 275 275 INTEGER :: ib_bdy, ib, igrd ! local integers 276 INTEGER :: ii, ij, zcoef, zcoef1, zcoef2,ip, jp ! " "276 INTEGER :: ii, ij, zcoef, ip, jp ! " " 277 277 278 278 igrd = 1 ! Everything is at T-points here … … 283 283 ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 284 284 ! Set gradient direction: 285 zcoef1 = bdytmask(ii-1,ij ) + bdytmask(ii+1,ij ) 286 zcoef2 = bdytmask(ii ,ij-1) + bdytmask(ii ,ij+1) 287 IF ( zcoef1+zcoef2 == 0 ) THEN 288 ! corner 289 ! zcoef = tmask(ii-1,ij,1) + tmask(ii+1,ij,1) + tmask(ii,ij-1,1) + tmask(ii,ij+1,1) 290 ! zssh(ii,ij) = zssh(ii-1,ij ) * tmask(ii-1,ij ,1) + & 291 ! & zssh(ii+1,ij ) * tmask(ii+1,ij ,1) + & 292 ! & zssh(ii ,ij-1) * tmask(ii ,ij-1,1) + & 293 ! & zssh(ii ,ij+1) * tmask(ii ,ij+1,1) 294 zcoef = bdytmask(ii-1,ij) + bdytmask(ii+1,ij) + bdytmask(ii,ij-1) + bdytmask(ii,ij+1) 295 zssh(ii,ij) = zssh(ii-1,ij ) * bdytmask(ii-1,ij ) + & 296 & zssh(ii+1,ij ) * bdytmask(ii+1,ij ) + & 297 & zssh(ii ,ij-1) * bdytmask(ii ,ij-1) + & 298 & zssh(ii ,ij+1) * bdytmask(ii ,ij+1) 299 zssh(ii,ij) = ( zssh(ii,ij) / MAX( 1, zcoef) ) * tmask(ii,ij,1) 285 zcoef = bdytmask(ii-1,ij) + bdytmask(ii+1,ij) + bdytmask(ii,ij-1) + bdytmask(ii,ij+1) 286 IF ( zcoef == 0 ) THEN 287 zssh(ii,ij) = 0._wp 300 288 ELSE 301 289 ip = bdytmask(ii+1,ij ) - bdytmask(ii-1,ij ) -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/BDY/bdyice_lim.F90
r6836 r6839 107 107 REAL(wp) :: zwgt, zwgt1 ! local scalar 108 108 REAL(wp) :: ztmelts, zdh 109 #if defined key_lim2 && ! defined key_lim2_vp && defined key_agrif 110 USE ice_2, vt_s => hsnm 111 USE ice_2, vt_i => hicm 112 #endif 109 113 110 114 !!------------------------------------------------------------------------------ … … 115 119 ! 116 120 #if defined key_lim2 117 DO jb = 1, idx%nblen (jgrd)121 DO jb = 1, idx%nblenrim(jgrd) 118 122 ji = idx%nbi(jb,jgrd) 119 123 jj = idx%nbj(jb,jgrd) … … 135 139 136 140 DO jl = 1, jpl 137 DO jb = 1, idx%nblen (jgrd)141 DO jb = 1, idx%nblenrim(jgrd) 138 142 ji = idx%nbi(jb,jgrd) 139 143 jj = idx%nbj(jb,jgrd) … … 171 175 172 176 DO jl = 1, jpl 173 DO jb = 1, idx%nblen (jgrd)177 DO jb = 1, idx%nblenrim(jgrd) 174 178 ji = idx%nbi(jb,jgrd) 175 179 jj = idx%nbj(jb,jgrd) … … 324 328 325 329 jgrd = 2 ! u velocity 326 DO jb = 1, idx_bdy(ib_bdy)%nblen (jgrd)330 DO jb = 1, idx_bdy(ib_bdy)%nblenrim(jgrd) 327 331 ji = idx_bdy(ib_bdy)%nbi(jb,jgrd) 328 332 jj = idx_bdy(ib_bdy)%nbj(jb,jgrd) … … 353 357 354 358 jgrd = 3 ! v velocity 355 DO jb = 1, idx_bdy(ib_bdy)%nblen (jgrd)359 DO jb = 1, idx_bdy(ib_bdy)%nblenrim(jgrd) 356 360 ji = idx_bdy(ib_bdy)%nbi(jb,jgrd) 357 361 jj = idx_bdy(ib_bdy)%nbj(jb,jgrd) -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/BDY/bdyini.F90
r6836 r6839 76 76 INTEGER :: ib_bdy, ii, ij, ik, igrd, ib, ir, iseg ! dummy loop indices 77 77 INTEGER :: icount, icountr, ibr_max, ilen1, ibm1 ! local integers 78 INTEGER :: iw , ie, is, in, inum, id_dummy ! - -78 INTEGER :: iwe, ies, iso, ino, inum, id_dummy ! - - 79 79 INTEGER :: igrd_start, igrd_end, jpbdta ! - - 80 80 INTEGER :: jpbdtau, jpbdtas ! - - … … 777 777 ! is = mjg(1) + 1 ! if monotasking and no zoom, is=2 778 778 ! in = mjg(1) + nlcj-1 - 1 ! if monotasking and no zoom, in=jpjm1 779 iw = mig(1) - jpizoom + 2 ! if monotasking and no zoom, iw=2780 ie = mig(1) + nlci - jpizoom - 1 ! if monotasking and no zoom, ie=jpim1781 is = mjg(1) - jpjzoom + 2 ! if monotasking and no zoom, is=2782 in = mjg(1) + nlcj - jpjzoom - 1 ! if monotasking and no zoom, in=jpjm1779 iwe = mig(1) - jpizoom + 2 ! if monotasking and no zoom, iw=2 780 ies = mig(1) + nlci - jpizoom - 1 ! if monotasking and no zoom, ie=jpim1 781 iso = mjg(1) - jpjzoom + 2 ! if monotasking and no zoom, is=2 782 ino = mjg(1) + nlcj - jpjzoom - 1 ! if monotasking and no zoom, in=jpjm1 783 783 784 784 ALLOCATE( nbondi_bdy(nb_bdy)) … … 853 853 ENDIF 854 854 ! check if point is in local domain 855 IF( nbidta(ib,igrd,ib_bdy) >= iw .AND. nbidta(ib,igrd,ib_bdy) <= ie.AND. &856 & nbjdta(ib,igrd,ib_bdy) >= is .AND. nbjdta(ib,igrd,ib_bdy) <= in) THEN855 IF( nbidta(ib,igrd,ib_bdy) >= iwe .AND. nbidta(ib,igrd,ib_bdy) <= ies .AND. & 856 & nbjdta(ib,igrd,ib_bdy) >= iso .AND. nbjdta(ib,igrd,ib_bdy) <= ino ) THEN 857 857 ! 858 858 icount = icount + 1 … … 890 890 com_south_b = 0 891 891 com_north_b = 0 892 892 893 DO igrd = 1, jpbgrd 893 894 icount = 0 … … 896 897 DO ib = 1, nblendta(igrd,ib_bdy) 897 898 ! check if point is in local domain and equals ir 898 IF( nbidta(ib,igrd,ib_bdy) >= iw .AND. nbidta(ib,igrd,ib_bdy) <= ie.AND. &899 & nbjdta(ib,igrd,ib_bdy) >= is .AND. nbjdta(ib,igrd,ib_bdy) <= in.AND. &899 IF( nbidta(ib,igrd,ib_bdy) >= iwe .AND. nbidta(ib,igrd,ib_bdy) <= ies .AND. & 900 & nbjdta(ib,igrd,ib_bdy) >= iso .AND. nbjdta(ib,igrd,ib_bdy) <= ino .AND. & 900 901 & nbrdta(ib,igrd,ib_bdy) == ir ) THEN 901 902 ! … … 1594 1595 ELSE 1595 1596 ! This is a corner 1596 WRITE(numout,*) 'Found a South-West corner at (i,j): ', jpiwob(ib), jpjwdt(ib)1597 IF(lwp) WRITE(numout,*) 'Found a South-West corner at (i,j): ', jpiwob(ib), jpjwdt(ib) 1597 1598 CALL bdy_ctl_corn(npckgw(ib), icornw(ib,1)) 1598 1599 itest=itest+1 … … 1608 1609 ELSE 1609 1610 ! This is a corner 1610 WRITE(numout,*) 'Found a North-West corner at (i,j): ', jpiwob(ib), jpjwft(ib)1611 IF(lwp) WRITE(numout,*) 'Found a North-West corner at (i,j): ', jpiwob(ib), jpjwft(ib) 1611 1612 CALL bdy_ctl_corn(npckgw(ib), icornw(ib,2)) 1612 1613 itest=itest+1 … … 1638 1639 ELSE 1639 1640 ! This is a corner 1640 WRITE(numout,*) 'Found a South-East corner at (i,j): ', jpieob(ib)+1, jpjedt(ib)1641 IF(lwp) WRITE(numout,*) 'Found a South-East corner at (i,j): ', jpieob(ib)+1, jpjedt(ib) 1641 1642 CALL bdy_ctl_corn(npckge(ib), icorne(ib,1)) 1642 1643 itest=itest+1 … … 1652 1653 ELSE 1653 1654 ! This is a corner 1654 WRITE(numout,*) 'Found a North-East corner at (i,j): ', jpieob(ib)+1, jpjeft(ib)1655 IF(lwp) WRITE(numout,*) 'Found a North-East corner at (i,j): ', jpieob(ib)+1, jpjeft(ib) 1655 1656 CALL bdy_ctl_corn(npckge(ib), icorne(ib,2)) 1656 1657 itest=itest+1 -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/BDY/bdytides.F90
r6836 r6839 416 416 ! Absolute time from model initialization: 417 417 IF( PRESENT(kit) ) THEN 418 z_arg = ( kt + (kit+ 0.5_wp*(time_add-1)) / REAL(nn_baro,wp) ) * rdt418 z_arg = ( kt + (kit+time_add-1) / REAL(nn_baro,wp) ) * rdt 419 419 ELSE 420 420 z_arg = ( kt + time_add ) * rdt -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/BDY/bdyvol.F90
r6836 r6839 91 91 ! Calculate the cumulate surface Flux z_cflxemp (m3/s) over all the domain 92 92 ! ----------------------------------------------------------------------- 93 z_cflxemp = SUM ( ( emp(:,:)-rnf(:,:)+ rdivisf*fwfisf(:,:) ) * bdytmask(:,:) * e1t(:,:) * e2t(:,:) ) / rau093 z_cflxemp = SUM ( ( emp(:,:)-rnf(:,:)+fwfisf(:,:) ) * bdytmask(:,:) * e1t(:,:) * e2t(:,:) ) / rau0 94 94 IF( lk_mpp ) CALL mpp_sum( z_cflxemp ) ! sum over the global domain 95 95 -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/DIA/diaar5.F90
r6836 r6839 211 211 REAL(wp) :: zztmp 212 212 REAL(wp), POINTER, DIMENSION(:,:,:,:) :: zsaldta ! Jan/Dec levitus salinity 213 ! reading initial file214 LOGICAL :: ln_tsd_init !: T & S data flag215 LOGICAL :: ln_tsd_tradmp !: internal damping toward input data flag216 CHARACTER(len=100) :: cn_dir217 TYPE(FLD_N) :: sn_tem,sn_sal218 INTEGER :: ios=0219 220 NAMELIST/namtsd/ ln_tsd_init,ln_tsd_tradmp,cn_dir,sn_tem,sn_sal221 !222 223 REWIND( numnam_ref ) ! Namelist namtsd in reference namelist :224 READ ( numnam_ref, namtsd, IOSTAT = ios, ERR = 901)225 901 IF( ios /= 0 ) CALL ctl_nam ( ios , ' namtsd in reference namelist for dia_ar5', lwp )226 REWIND( numnam_cfg ) ! Namelist namtsd in configuration namelist : Parameters of the run227 READ ( numnam_cfg, namtsd, IOSTAT = ios, ERR = 902 )228 902 IF( ios /= 0 ) CALL ctl_nam ( ios , ' namtsd in configuration namelist for dia_ar5', lwp )229 IF(lwm) WRITE ( numond, namtsd )230 213 ! 231 214 !!---------------------------------------------------------------------- … … 233 216 IF( nn_timing == 1 ) CALL timing_start('dia_ar5_init') 234 217 ! 235 CALL wrk_alloc( jpi , jpj , jpk, jpts, zsaldta )218 CALL wrk_alloc( jpi, jpj, jpk, 2, zsaldta ) 236 219 ! ! allocate dia_ar5 arrays 237 220 IF( dia_ar5_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'dia_ar5_init : unable to allocate arrays' ) … … 249 232 IF( lk_mpp ) CALL mpp_sum( vol0 ) 250 233 251 CALL iom_open ( TRIM( cn_dir )//TRIM(sn_sal%clname), inum )252 CALL iom_get ( inum, jpdom_data, TRIM(sn_sal%clvar), zsaldta(:,:,:,1), 1 )253 CALL iom_get ( inum, jpdom_data, TRIM(sn_sal%clvar), zsaldta(:,:,:,2), 12 )234 CALL iom_open ( 'sali_ref_clim_monthly', inum ) 235 CALL iom_get ( inum, jpdom_data, 'vosaline' , zsaldta(:,:,:,1), 1 ) 236 CALL iom_get ( inum, jpdom_data, 'vosaline' , zsaldta(:,:,:,2), 12 ) 254 237 CALL iom_close( inum ) 238 255 239 sn0(:,:,:) = 0.5_wp * ( zsaldta(:,:,:,1) + zsaldta(:,:,:,2) ) 256 240 sn0(:,:,:) = sn0(:,:,:) * tmask(:,:,:) … … 267 251 ENDIF 268 252 ! 269 CALL wrk_dealloc( jpi , jpj , jpk, jpts, zsaldta )253 CALL wrk_dealloc( jpi, jpj, jpk, 2, zsaldta ) 270 254 ! 271 255 IF( nn_timing == 1 ) CALL timing_stop('dia_ar5_init') -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/DIA/diaharm.F90
r6836 r6839 196 196 DO ji = 1,jpi 197 197 ! Elevation 198 ana_temp(ji,jj,nhc,1) = ana_temp(ji,jj,nhc,1) + ztemp*sshn(ji,jj) *tmask_i(ji,jj) 199 #if defined key_dynspg_ts 200 ana_temp(ji,jj,nhc,2) = ana_temp(ji,jj,nhc,2) + ztemp*un_b(ji,jj)*hur(ji,jj)*umask_i(ji,jj) 201 ana_temp(ji,jj,nhc,3) = ana_temp(ji,jj,nhc,3) + ztemp*vn_b(ji,jj)*hvr(ji,jj)*vmask_i(ji,jj) 202 #endif 198 ana_temp(ji,jj,nhc,1) = ana_temp(ji,jj,nhc,1) + ztemp*sshn(ji,jj)*tmask_i(ji,jj) 199 ana_temp(ji,jj,nhc,2) = ana_temp(ji,jj,nhc,2) + ztemp*un_b(ji,jj)*umask_i(ji,jj) 200 ana_temp(ji,jj,nhc,3) = ana_temp(ji,jj,nhc,3) + ztemp*vn_b(ji,jj)*vmask_i(ji,jj) 203 201 END DO 204 202 END DO -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/DIA/diahsb.F90
r6836 r6839 93 93 ! 1 - Trends due to forcing ! 94 94 ! ------------------------- ! 95 z_frc_trd_v = r1_rau0 * glob_sum( - ( emp(:,:) - rnf(:,:) + rdivisf *fwfisf(:,:) ) * surf(:,:) ) ! volume fluxes95 z_frc_trd_v = r1_rau0 * glob_sum( - ( emp(:,:) - rnf(:,:) + fwfisf(:,:) ) * surf(:,:) ) ! volume fluxes 96 96 z_frc_trd_t = glob_sum( sbc_tsc(:,:,jp_tem) * surf(:,:) ) ! heat fluxes 97 97 z_frc_trd_s = glob_sum( sbc_tsc(:,:,jp_sal) * surf(:,:) ) ! salt fluxes … … 101 101 ! Add ice shelf heat & salt input 102 102 IF( nn_isf .GE. 1 ) THEN 103 z_frc_trd_t = z_frc_trd_t & 104 & + glob_sum( ( risf_tsc(:,:,jp_tem) - rdivisf * fwfisf(:,:) * (-1.9) * r1_rau0 ) * surf(:,:) ) 105 z_frc_trd_s = z_frc_trd_s + (1.0_wp - rdivisf) * glob_sum( risf_tsc(:,:,jp_sal) * surf(:,:) ) 103 z_frc_trd_t = z_frc_trd_t + glob_sum( risf_tsc(:,:,jp_tem) * surf(:,:) ) 104 z_frc_trd_s = z_frc_trd_s + glob_sum( risf_tsc(:,:,jp_sal) * surf(:,:) ) 106 105 ENDIF 107 106 … … 200 199 ! ENDIF 201 200 !!gm end 202 203 201 204 202 IF( lk_vvl ) THEN -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/DIA/diawri.F90
r6836 r6839 145 145 ENDIF 146 146 147 IF( .NOT.lk_vvl ) THEN 148 CALL iom_put( "e3t" , fse3t_n(:,:,:) ) 149 CALL iom_put( "e3u" , fse3u_n(:,:,:) ) 150 CALL iom_put( "e3v" , fse3v_n(:,:,:) ) 151 CALL iom_put( "e3w" , fse3w_n(:,:,:) ) 152 ENDIF 147 ! Output of initial vertical scale factor 148 CALL iom_put("e3t_0", e3t_0(:,:,:) ) 149 CALL iom_put("e3u_0", e3t_0(:,:,:) ) 150 CALL iom_put("e3v_0", e3t_0(:,:,:) ) 151 ! 152 CALL iom_put( "e3t" , fse3t_n(:,:,:) ) 153 CALL iom_put( "e3u" , fse3u_n(:,:,:) ) 154 CALL iom_put( "e3v" , fse3v_n(:,:,:) ) 155 CALL iom_put( "e3w" , fse3w_n(:,:,:) ) 156 IF( iom_use("e3tdef") ) & 157 CALL iom_put( "e3tdef" , ( ( fse3t_n(:,:,:) - e3t_0(:,:,:) ) / e3t_0(:,:,:) * 100 * tmask(:,:,:) ) ** 2 ) 158 153 159 154 160 CALL iom_put( "ssh" , sshn ) ! sea surface height 155 if( iom_use('ssh2') ) CALL iom_put( "ssh2", sshn(:,:) * sshn(:,:) ) ! square of sea surface height156 161 157 162 CALL iom_put( "toce", tsn(:,:,:,jp_tem) ) ! 3D temperature … … 243 248 CALL iom_put( "avm" , avmu ) ! T vert. eddy visc. coef. 244 249 CALL iom_put( "avs" , fsavs(:,:,:) ) ! S vert. eddy diff. coef. (useful only with key_zdfddm) 250 ! Log of eddy diff coef 251 IF( iom_use('logavt') ) CALL iom_put( "logavt", LOG( MAX( 1.e-20_wp, avt (:,:,:) ) ) ) 252 IF( iom_use('logavs') ) CALL iom_put( "logavs", LOG( MAX( 1.e-20_wp, fsavs(:,:,:) ) ) ) 245 253 246 254 IF ( iom_use("sstgrad") .OR. iom_use("sstgrad2") ) THEN … … 307 315 CALL iom_put( "eken", rke ) 308 316 ENDIF 309 317 ! 318 CALL iom_put( "hdiv", hdivn ) ! Horizontal divergence 319 ! 310 320 IF( iom_use("u_masstr") .OR. iom_use("u_heattr") .OR. iom_use("u_salttr") ) THEN 311 321 z3d(:,:,jpk) = 0.e0 … … 438 448 zdt = rdt 439 449 IF( nacc == 1 ) zdt = rdtmin 440 IF( ln_mskland ) THEN ; clop = "only(x)" ! put 1.e+20 on land (very expensive!!) 441 ELSE ; clop = "x" ! no use of the mask value (require less cpu time) 442 ENDIF 450 clop = "x" ! no use of the mask value (require less cpu time, and otherwise the model crashes) 443 451 #if defined key_diainstant 444 452 zsto = nwrite * zdt … … 1020 1028 CALL histdef( id_i, "vovvldep", "T point depth" , "m" , & ! t-point depth 1021 1029 & jpi, jpj, nh_i, jpk, 1, jpk, nz_i, 32, clop, zsto, zout ) 1030 CALL histdef( id_i, "vovvle3t", "T point thickness" , "m" , & ! t-point depth 1031 & jpi, jpj, nh_i, jpk, 1, jpk, nz_i, 32, clop, zsto, zout ) 1022 1032 END IF 1023 1033 … … 1050 1060 CALL histwrite( id_i, "sozotaux", kt, utau , jpi*jpj , idex ) ! i-wind stress 1051 1061 CALL histwrite( id_i, "sometauy", kt, vtau , jpi*jpj , idex ) ! j-wind stress 1062 IF( lk_vvl ) THEN 1063 CALL histwrite( id_i, "vovvldep", kt, fsdept_n(:,:,:), jpi*jpj*jpk, idex )! T-cell depth 1064 CALL histwrite( id_i, "vovvle3t", kt, fse3t_n (:,:,:), jpi*jpj*jpk, idex )! T-cell thickness 1065 END IF 1052 1066 1053 1067 ! 3. Close the file -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/DOM/daymod.F90
r6836 r6839 73 73 !!---------------------------------------------------------------------- 74 74 ! 75 ! max number of seconds between each restart 76 IF( REAL( nitend - nit000 + 1 ) * rdt > REAL( HUGE( nsec1jan000 ) ) ) THEN 77 CALL ctl_stop( 'The number of seconds between each restart exceeds the integer 4 max value: 2^31-1. ', & 78 & 'You must do a restart at higher frequency (or remove this stop and recompile the code in I8)' ) 79 ENDIF 75 80 ! all calendar staff is based on the fact that MOD( rday, rdttra(1) ) == 0 76 81 IF( MOD( rday , rdttra(1) ) /= 0. ) CALL ctl_stop( 'the time step must devide the number of second of in a day' ) … … 238 243 nday_year = 1 239 244 nsec_year = ndt05 240 IF( nsec1jan000 >= 2 * (2**30 - nsecd * nyear_len(1) / 2 ) ) THEN ! test integer 4 max value241 CALL ctl_stop( 'The number of seconds between Jan. 1st 00h of nit000 year and Jan. 1st 00h ', &242 & 'of the current year is exceeding the INTEGER 4 max VALUE: 2^31-1 -> 68.09 years in seconds', &243 & 'You must do a restart at higher frequency (or remove this STOP and recompile everything in I8)' )244 ENDIF245 245 nsec1jan000 = nsec1jan000 + nsecd * nyear_len(1) 246 246 IF( nleapy == 1 ) CALL day_mth -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/DOM/domhgr.F90
r6836 r6839 169 169 ! 170 170 ii0 = 282 ; ii1 = 283 ! Gibraltar Strait (e2u = 20 km) 171 ij0 = 2 01 +isrow ; ij1 = 241 - isrow ; e2u( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 20.e3171 ij0 = 241 - isrow ; ij1 = 241 - isrow ; e2u( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 20.e3 172 172 IF(lwp) WRITE(numout,*) 173 173 IF(lwp) WRITE(numout,*) ' orca_r1: Gibraltar : e2u reduced to 20 km' 174 174 175 175 ii0 = 314 ; ii1 = 315 ! Bhosporus Strait (e2u = 10 km) 176 ij0 = 2 08 +isrow ; ij1 = 248 - isrow ; e2u( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 10.e3176 ij0 = 248 - isrow ; ij1 = 248 - isrow ; e2u( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 10.e3 177 177 IF(lwp) WRITE(numout,*) 178 178 IF(lwp) WRITE(numout,*) ' orca_r1: Bhosporus : e2u reduced to 10 km' 179 179 180 180 ii0 = 44 ; ii1 = 44 ! Lombok Strait (e1v = 13 km) 181 ij0 = 1 24 +isrow ; ij1 = 165 - isrow ; e1v( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 13.e3181 ij0 = 164 - isrow ; ij1 = 165 - isrow ; e1v( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 13.e3 182 182 IF(lwp) WRITE(numout,*) 183 183 IF(lwp) WRITE(numout,*) ' orca_r1: Lombok : e1v reduced to 10 km' 184 184 185 185 ii0 = 48 ; ii1 = 48 ! Sumba Strait (e1v = 8 km) [closed from bathy_11 on] 186 ij0 = 1 24 +isrow ; ij1 = 165 - isrow ; e1v( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 8.e3186 ij0 = 164 - isrow ; ij1 = 165 - isrow ; e1v( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 8.e3 187 187 IF(lwp) WRITE(numout,*) 188 188 IF(lwp) WRITE(numout,*) ' orca_r1: Sumba : e1v reduced to 8 km' 189 189 190 190 ii0 = 53 ; ii1 = 53 ! Ombai Strait (e1v = 13 km) 191 ij0 = 1 24 +isrow ; ij1 = 165 - isrow ; e1v( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 13.e3191 ij0 = 164 - isrow ; ij1 = 165 - isrow ; e1v( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 13.e3 192 192 IF(lwp) WRITE(numout,*) 193 193 IF(lwp) WRITE(numout,*) ' orca_r1: Ombai : e1v reduced to 13 km' 194 194 195 195 ii0 = 56 ; ii1 = 56 ! Timor Passage (e1v = 20 km) 196 ij0 = 1 24 +isrow ; ij1 = 145 - isrow ; e1v( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 20.e3196 ij0 = 164 - isrow ; ij1 = 145 - isrow ; e1v( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 20.e3 197 197 IF(lwp) WRITE(numout,*) 198 198 IF(lwp) WRITE(numout,*) ' orca_r1: Timor Passage : e1v reduced to 20 km' 199 199 200 200 ii0 = 55 ; ii1 = 55 ! West Halmahera Strait (e1v = 30 km) 201 ij0 = 1 41 +isrow ; ij1 = 182 - isrow ; e1v( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 30.e3201 ij0 = 181 - isrow ; ij1 = 182 - isrow ; e1v( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 30.e3 202 202 IF(lwp) WRITE(numout,*) 203 203 IF(lwp) WRITE(numout,*) ' orca_r1: W Halmahera : e1v reduced to 30 km' 204 204 205 205 ii0 = 58 ; ii1 = 58 ! East Halmahera Strait (e1v = 50 km) 206 ij0 = 1 41 +isrow ; ij1 = 182 - isrow ; e1v( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 50.e3206 ij0 = 181 - isrow ; ij1 = 182 - isrow ; e1v( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 50.e3 207 207 IF(lwp) WRITE(numout,*) 208 208 IF(lwp) WRITE(numout,*) ' orca_r1: E Halmahera : e1v reduced to 50 km' … … 544 544 IF ( cp_cfg == 'eel' .AND. jp_cfg == 6 ) THEN ! for EEL6 configuration only 545 545 IF( .NOT. Agrif_Root() ) THEN 546 zphi0 = ppgphi0 - FLOAT( Agrif_Parent(jpjglo)/2)*Agrif_Parent(ppe2_m) / (ra * rad) 546 zphi0 = ppgphi0 - FLOAT( Agrif_Parent(jpjglo)/2)*Agrif_Parent(ppe2_m) & 547 & / (ra * rad) 547 548 ENDIF 548 549 ENDIF -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/DOM/dommsk.F90
r6836 r6839 413 413 IF(lwp) WRITE(numout,*) ' Gibraltar ' 414 414 ii0 = 282 ; ii1 = 283 ! Gibraltar Strait 415 ij0 = 2 01 +isrow ; ij1 = 241 - isrow ; fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp415 ij0 = 241 - isrow ; ij1 = 241 - isrow ; fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp 416 416 417 417 IF(lwp) WRITE(numout,*) ' Bhosporus ' 418 418 ii0 = 314 ; ii1 = 315 ! Bhosporus Strait 419 ij0 = 2 08 +isrow ; ij1 = 248 - isrow ; fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp419 ij0 = 248 - isrow ; ij1 = 248 - isrow ; fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp 420 420 421 421 IF(lwp) WRITE(numout,*) ' Makassar (Top) ' 422 422 ii0 = 48 ; ii1 = 48 ! Makassar Strait (Top) 423 ij0 = 1 49 +isrow ; ij1 = 190 - isrow ; fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 3._wp423 ij0 = 189 - isrow ; ij1 = 190 - isrow ; fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 3._wp 424 424 425 425 IF(lwp) WRITE(numout,*) ' Lombok ' 426 426 ii0 = 44 ; ii1 = 44 ! Lombok Strait 427 ij0 = 1 24 +isrow ; ij1 = 165 - isrow ; fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp427 ij0 = 164 - isrow ; ij1 = 165 - isrow ; fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp 428 428 429 429 IF(lwp) WRITE(numout,*) ' Ombai ' 430 430 ii0 = 53 ; ii1 = 53 ! Ombai Strait 431 ij0 = 1 24 +isrow ; ij1 = 165 - isrow ; fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp431 ij0 = 164 - isrow ; ij1 = 165 - isrow ; fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp 432 432 433 433 IF(lwp) WRITE(numout,*) ' Timor Passage ' 434 434 ii0 = 56 ; ii1 = 56 ! Timor Passage 435 ij0 = 1 24 +isrow ; ij1 = 165 - isrow ; fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp435 ij0 = 164 - isrow ; ij1 = 165 - isrow ; fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp 436 436 437 437 IF(lwp) WRITE(numout,*) ' West Halmahera ' 438 438 ii0 = 58 ; ii1 = 58 ! West Halmahera Strait 439 ij0 = 1 41 +isrow ; ij1 = 182 - isrow ; fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 3._wp439 ij0 = 181 - isrow ; ij1 = 182 - isrow ; fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 3._wp 440 440 441 441 IF(lwp) WRITE(numout,*) ' East Halmahera ' 442 442 ii0 = 55 ; ii1 = 55 ! East Halmahera Strait 443 ij0 = 1 41 +isrow ; ij1 = 182 - isrow ; fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 3._wp443 ij0 = 181 - isrow ; ij1 = 182 - isrow ; fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 3._wp 444 444 ! 445 445 ENDIF -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/DOM/domvvl.F90
r6836 r6839 665 665 ht(:,:) = ht(:,:) + fse3t_n(:,:,jk) * tmask(:,:,jk) 666 666 END DO 667 668 ! Write outputs669 ! =============670 CALL iom_put( "e3t" , fse3t_n (:,:,:) )671 CALL iom_put( "e3u" , fse3u_n (:,:,:) )672 CALL iom_put( "e3v" , fse3v_n (:,:,:) )673 CALL iom_put( "e3w" , fse3w_n (:,:,:) )674 CALL iom_put( "tpt_dep" , fsde3w_n (:,:,:) )675 IF( iom_use("e3tdef") ) &676 CALL iom_put( "e3tdef" , ( ( fse3t_n(:,:,:) - e3t_0(:,:,:) ) / e3t_0(:,:,:) * 100 * tmask(:,:,:) ) ** 2 )677 667 678 668 ! write restart file -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/DOM/domwri.F90
r6836 r6839 215 215 CALL iom_rstput( 0, 0, inum4, 'gdept_1d' , gdept_1d ) ! ! stretched system 216 216 CALL iom_rstput( 0, 0, inum4, 'gdepw_1d' , gdepw_1d ) 217 CALL iom_rstput( 0, 0, inum4, 'gdept_0', gdept_0, ktype = jp_r4 ) 218 CALL iom_rstput( 0, 0, inum4, 'gdepw_0', gdepw_0, ktype = jp_r4 ) 217 219 ENDIF 218 220 -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/DOM/domzgr.F90
r6836 r6839 219 219 & ppsur == pp_to_be_computed ) THEN 220 220 ! 221 #if defined key_agrif 222 za1 = ( ppdzmin - pphmax / FLOAT(jpkdta-1) ) & 223 & / ( TANH((1-ppkth)/ppacr) - ppacr/FLOAT(jpkdta-1) * ( LOG( COSH( (jpkdta - ppkth) / ppacr) )& 224 & - LOG( COSH( ( 1 - ppkth) / ppacr) ) ) ) 225 #else 221 226 za1 = ( ppdzmin - pphmax / FLOAT(jpkm1) ) & 222 227 & / ( TANH((1-ppkth)/ppacr) - ppacr/FLOAT(jpk-1) * ( LOG( COSH( (jpk - ppkth) / ppacr) ) & 223 228 & - LOG( COSH( ( 1 - ppkth) / ppacr) ) ) ) 229 #endif 224 230 za0 = ppdzmin - za1 * TANH( (1-ppkth) / ppacr ) 225 231 zsur = - za0 - za1 * ppacr * LOG( COSH( (1-ppkth) / ppacr ) ) … … 236 242 WRITE(numout,*) ' Uniform grid with ',jpk-1,' layers' 237 243 WRITE(numout,*) ' Total depth :', zhmax 244 #if defined key_agrif 245 WRITE(numout,*) ' Layer thickness:', zhmax/(jpkdta-1) 246 #else 238 247 WRITE(numout,*) ' Layer thickness:', zhmax/(jpk-1) 248 #endif 239 249 ELSE 240 250 IF( ppa1 == 0._wp .AND. ppa0 == 0._wp .AND. ppsur == 0._wp ) THEN … … 260 270 ! Reference z-coordinate (depth - scale factor at T- and W-points) 261 271 ! ====================== 262 IF( ppkth == 0._wp ) THEN ! uniform vertical grid 272 IF( ppkth == 0._wp ) THEN ! uniform vertical grid 273 #if defined key_agrif 274 za1 = zhmax / FLOAT(jpkdta-1) 275 #else 263 276 za1 = zhmax / FLOAT(jpk-1) 277 #endif 264 278 DO jk = 1, jpk 265 279 zw = FLOAT( jk ) … … 1870 1884 iim1 = MAX( ji-1, 1 ) 1871 1885 ijm1 = MAX( jj-1, 1 ) 1872 IF( (bathy(iip1,jj) + bathy(iim1,jj) + bathy(ji,ijp1) + bathy(ji,ijm1) + & 1873 & bathy(iip1,ijp1) + bathy(iim1,ijm1) + bathy(iip1,ijp1) + bathy(iim1,ijm1)) > 0._wp ) THEN 1874 zenv(ji,jj) = rn_sbot_min 1886 IF( ( + bathy(iim1,ijp1) + bathy(ji,ijp1) + bathy(iip1,ijp1) & 1887 & + bathy(iim1,jj ) + bathy(iip1,jj ) & 1888 & + bathy(iim1,ijm1) + bathy(ji,ijm1) + bathy(iip1,ijp1) ) > 0._wp ) THEN 1889 zenv(ji,jj) = rn_sbot_min 1875 1890 ENDIF 1876 1891 ENDIF -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/DYN/divcur.F90
r6836 r6839 97 97 IF( nn_timing == 1 ) CALL timing_start('div_cur') 98 98 ! 99 CALL wrk_alloc( jpi , jpj+2, zwu 100 CALL wrk_alloc( jpi+ 4, jpj , zwv, kistart = -1)99 CALL wrk_alloc( jpi , jpj+2, zwu ) 100 CALL wrk_alloc( jpi+2, jpj , zwv ) 101 101 ! 102 102 IF( kt == nit000 ) THEN … … 236 236 CALL lbc_lnk( hdivn, 'T', 1. ) ; CALL lbc_lnk( rotn , 'F', 1. ) ! lateral boundary cond. (no sign change) 237 237 ! 238 CALL wrk_dealloc( jpi , jpj+2, zwu 239 CALL wrk_dealloc( jpi+ 4, jpj , zwv, kistart = -1)238 CALL wrk_dealloc( jpi , jpj+2, zwu ) 239 CALL wrk_dealloc( jpi+2, jpj , zwv ) 240 240 ! 241 241 IF( nn_timing == 1 ) CALL timing_stop('div_cur') -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/DYN/dynnxt.F90
r6836 r6839 266 266 ! Add volume filter correction: compatibility with tracer advection scheme 267 267 ! => time filter + conservation correction (only at the first level) 268 fse3t_b(:,:,1) = fse3t_b(:,:,1) - atfp * rdt * r1_rau0 * ( emp_b(:,:) - emp(:,:) & 269 & -rnf_b(:,:) + rnf(:,:) ) * tmask(:,:,1) 268 IF ( nn_isf == 0) THEN ! if no ice shelf melting 269 fse3t_b(:,:,1) = fse3t_b(:,:,1) - atfp * rdt * r1_rau0 * ( emp_b(:,:) - emp(:,:) & 270 & -rnf_b(:,:) + rnf(:,:) ) * tmask(:,:,1) 271 ELSE ! if ice shelf melting 272 DO jj = 1,jpj 273 DO ji = 1,jpi 274 jk = mikt(ji,jj) 275 fse3t_b(ji,jj,jk) = fse3t_b(ji,jj,jk) - atfp * rdt * r1_rau0 & 276 & * ( (emp_b(ji,jj) - emp(ji,jj) ) & 277 & - (rnf_b(ji,jj) - rnf(ji,jj) ) & 278 & + (fwfisf_b(ji,jj) - fwfisf(ji,jj)) ) * tmask(ji,jj,jk) 279 END DO 280 END DO 281 END IF 270 282 ENDIF 271 283 ! -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/DYN/dynspg_ts.F90
r6836 r6839 187 187 ! 188 188 ! time offset in steps for bdy data update 189 IF (.NOT.ln_bt_fw) THEN ; noffset=- 2*nn_baro ; ELSE ; noffset = 0 ; ENDIF189 IF (.NOT.ln_bt_fw) THEN ; noffset=-nn_baro ; ELSE ; noffset = 0 ; ENDIF 190 190 ! 191 191 IF( kt == nit000 ) THEN !* initialisation … … 454 454 ! ! Surface net water flux and rivers 455 455 IF (ln_bt_fw) THEN 456 zssh_frc(:,:) = zraur * ( emp(:,:) - rnf(:,:) + rdivisf *fwfisf(:,:) )456 zssh_frc(:,:) = zraur * ( emp(:,:) - rnf(:,:) + fwfisf(:,:) ) 457 457 ELSE 458 458 zssh_frc(:,:) = zraur * z1_2 * ( emp(:,:) + emp_b(:,:) - rnf(:,:) - rnf_b(:,:) & 459 & + rdivisf * ( fwfisf(:,:) + fwfisf_b(:,:) ))459 & + fwfisf(:,:) + fwfisf_b(:,:) ) 460 460 ENDIF 461 461 #if defined key_asminc … … 465 465 ENDIF 466 466 #endif 467 ! !* Fill boundary data arrays withAGRIF468 ! ! ------------------------------------ -467 ! !* Fill boundary data arrays for AGRIF 468 ! ! ------------------------------------ 469 469 #if defined key_agrif 470 470 IF( .NOT.Agrif_Root() ) CALL agrif_dta_ts( kt ) … … 523 523 ! Update only tidal forcing at open boundaries 524 524 #if defined key_tide 525 IF ( lk_bdy .AND. lk_tide ) 526 IF ( ln_tide_pot .AND. lk_tide ) CALL upd_tide( kt, kit=jn, koffset=noffset )525 IF ( lk_bdy .AND. lk_tide ) CALL bdy_dta_tides( kt, kit=jn, time_offset=(noffset+1) ) 526 IF ( ln_tide_pot .AND. lk_tide ) CALL upd_tide( kt, kit=jn, time_offset=noffset ) 527 527 #endif 528 528 ! … … 900 900 #if defined key_agrif 901 901 ! Save time integrated fluxes during child grid integration 902 ! (used to update coarse grid transports) 903 ! Useless with 2nd order momentum schemes 902 ! (used to update coarse grid transports at next time step) 904 903 ! 905 904 IF ( (.NOT.Agrif_Root()).AND.(ln_bt_fw) ) THEN -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/DYN/sshwzv.F90
r6836 r6839 31 31 USE bdydyn2d ! bdy_ssh routine 32 32 #if defined key_agrif 33 USE agrif_opa_update34 33 USE agrif_opa_interp 35 34 #endif … … 268 267 ELSE !** Leap-Frog time-stepping: Asselin filter + swap 269 268 sshb(:,:) = sshn(:,:) + atfp * ( sshb(:,:) - 2 * sshn(:,:) + ssha(:,:) ) ! before <-- now filtered 270 IF( lk_vvl ) sshb(:,:) = sshb(:,:) - atfp * rdt / rau0 * ( emp_b(:,:) - emp(:,:) - rnf_b(:,:) + rnf(:,:) ) * ssmask(:,:) 269 IF( lk_vvl ) sshb(:,:) = sshb(:,:) - atfp * rdt / rau0 * ( emp_b(:,:) - emp(:,:) & 270 & - rnf_b(:,:) + rnf(:,:) & 271 & + fwfisf_b(:,:) - fwfisf(:,:) ) * ssmask(:,:) 271 272 sshn(:,:) = ssha(:,:) ! now <-- after 272 273 ENDIF 273 !274 ! Update velocity at AGRIF zoom boundaries275 #if defined key_agrif276 IF ( .NOT.Agrif_Root() ) CALL Agrif_Update_Dyn( kt )277 #endif278 274 ! 279 275 IF(ln_ctl) CALL prt_ctl( tab2d_1=sshb, clinfo1=' sshb - : ', mask1=tmask, ovlap=1 ) -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/IOM/iom.F90
r6836 r6839 94 94 CHARACTER(len=*), INTENT(in) :: cdname 95 95 #if defined key_iomput 96 TYPE(xios_time) :: dtime = xios_time(0, 0, 0, 0, 0, 0) 97 CHARACTER(len=19) :: cldate 98 CHARACTER(len=10) :: clname 99 INTEGER :: ji 96 #if ! defined key_xios2 97 TYPE(xios_time) :: dtime = xios_time(0, 0, 0, 0, 0, 0) 98 CHARACTER(len=19) :: cldate 99 #else 100 TYPE(xios_duration) :: dtime = xios_duration(0, 0, 0, 0, 0, 0) 101 TYPE(xios_date) :: start_date 102 #endif 103 CHARACTER(len=10) :: clname 104 INTEGER :: ji 100 105 ! 101 106 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: z_bnds 102 107 !!---------------------------------------------------------------------- 103 108 #if ! defined key_xios2 104 109 ALLOCATE( z_bnds(jpk,2) ) 110 #else 111 ALLOCATE( z_bnds(2,jpk) ) 112 #endif 105 113 106 114 clname = cdname … … 110 118 111 119 ! calendar parameters 120 #if ! defined key_xios2 112 121 SELECT CASE ( nleapy ) ! Choose calendar for IOIPSL 113 122 CASE ( 1) ; CALL xios_set_context_attr(TRIM(clname), calendar_type= "Gregorian") … … 117 126 WRITE(cldate,"(i4.4,'-',i2.2,'-',i2.2,' 00:00:00')") nyear,nmonth,nday 118 127 CALL xios_set_context_attr(TRIM(clname), start_date=cldate ) 119 128 #else 129 ! Calendar type is now defined in xml file 130 SELECT CASE ( nleapy ) ! Choose calendar for IOIPSL 131 CASE ( 1) ; CALL xios_define_calendar( TYPE = "Gregorian", time_origin = xios_date(1900,01,01,00,00,00), & 132 & start_date = xios_date(nyear,nmonth,nday,0,0,0) ) 133 CASE ( 0) ; CALL xios_define_calendar( TYPE = "NoLeap" , time_origin = xios_date(1900,01,01,00,00,00), & 134 & start_date = xios_date(nyear,nmonth,nday,0,0,0) ) 135 CASE (30) ; CALL xios_define_calendar( TYPE = "D360" , time_origin = xios_date(1900,01,01,00,00,00), & 136 & start_date = xios_date(nyear,nmonth,nday,0,0,0) ) 137 END SELECT 138 #endif 120 139 ! horizontal grid definition 140 121 141 CALL set_scalar 122 142 … … 170 190 171 191 ! Add vertical grid bounds 192 #if ! defined key_xios2 172 193 z_bnds(: ,1) = gdepw_1d(:) 173 194 z_bnds(1:jpkm1,2) = gdepw_1d(2:jpk) 174 195 z_bnds(jpk: ,2) = gdepw_1d(jpk) + e3t_1d(jpk) 196 #else 197 z_bnds(1 ,:) = gdepw_1d(:) 198 z_bnds(2,1:jpkm1) = gdepw_1d(2:jpk) 199 z_bnds(2,jpk: ) = gdepw_1d(jpk) + e3t_1d(jpk) 200 #endif 201 175 202 CALL iom_set_axis_attr( "deptht", bounds=z_bnds ) 176 203 CALL iom_set_axis_attr( "depthu", bounds=z_bnds ) 177 204 CALL iom_set_axis_attr( "depthv", bounds=z_bnds ) 178 z_bnds(: ,2) = gdept_1d(:) 179 z_bnds(2:jpk,1) = gdept_1d(1:jpkm1) 180 z_bnds(1 ,1) = gdept_1d(1) - e3w_1d(1) 205 206 #if ! defined key_xios2 207 z_bnds(: ,2) = gdept_1d(:) 208 z_bnds(2:jpk,1) = gdept_1d(1:jpkm1) 209 z_bnds(1 ,1) = gdept_1d(1) - e3w_1d(1) 210 #else 211 z_bnds(2,: ) = gdept_1d(:) 212 z_bnds(1,2:jpk) = gdept_1d(1:jpkm1) 213 z_bnds(1,1 ) = gdept_1d(1) - e3w_1d(1) 214 #endif 181 215 CALL iom_set_axis_attr( "depthw", bounds=z_bnds ) 216 182 217 183 218 # if defined key_floats … … 1156 1191 REAL(wp), DIMENSION(:) , OPTIONAL, INTENT(in) :: lonvalue, latvalue 1157 1192 REAL(wp), DIMENSION(:,:) , OPTIONAL, INTENT(in) :: bounds_lon, bounds_lat, area 1158 LOGICAL, DIMENSION(:,:) , OPTIONAL, INTENT(in) :: mask 1159 1193 #if ! defined key_xios2 1194 LOGICAL, DIMENSION(:,:) , OPTIONAL, INTENT(in) :: mask 1195 #else 1196 LOGICAL, DIMENSION(:) , OPTIONAL, INTENT(in) :: mask 1197 #endif 1198 1199 #if ! defined key_xios2 1160 1200 IF ( xios_is_valid_domain (cdid) ) THEN 1161 1201 CALL xios_set_domain_attr ( cdid, ni_glo=ni_glo, nj_glo=nj_glo, ibegin=ibegin, jbegin=jbegin, ni=ni, nj=nj, & … … 1164 1204 & lonvalue=lonvalue, latvalue=latvalue, mask=mask, nvertex=nvertex, bounds_lon=bounds_lon, & 1165 1205 & bounds_lat=bounds_lat, area=area ) 1166 ENDIF 1167 1206 ENDIF 1168 1207 IF ( xios_is_valid_domaingroup(cdid) ) THEN 1169 1208 CALL xios_set_domaingroup_attr( cdid, ni_glo=ni_glo, nj_glo=nj_glo, ibegin=ibegin, jbegin=jbegin, ni=ni, nj=nj, & … … 1173 1212 & bounds_lat=bounds_lat, area=area ) 1174 1213 ENDIF 1214 1215 #else 1216 IF ( xios_is_valid_domain (cdid) ) THEN 1217 CALL xios_set_domain_attr ( cdid, ni_glo=ni_glo, nj_glo=nj_glo, ibegin=ibegin, jbegin=jbegin, ni=ni, nj=nj, & 1218 & data_dim=data_dim, data_ibegin=data_ibegin, data_ni=data_ni, data_jbegin=data_jbegin, data_nj=data_nj , & 1219 & lonvalue_1D=lonvalue, latvalue_1D=latvalue, mask_1D=mask, nvertex=nvertex, bounds_lon_1D=bounds_lon, & 1220 & bounds_lat_1D=bounds_lat, area=area, type='curvilinear') 1221 ENDIF 1222 IF ( xios_is_valid_domaingroup(cdid) ) THEN 1223 CALL xios_set_domaingroup_attr( cdid, ni_glo=ni_glo, nj_glo=nj_glo, ibegin=ibegin, jbegin=jbegin, ni=ni, nj=nj, & 1224 & data_dim=data_dim, data_ibegin=data_ibegin, data_ni=data_ni, data_jbegin=data_jbegin, data_nj=data_nj , & 1225 & lonvalue_1D=lonvalue, latvalue_1D=latvalue, mask_1D=mask, nvertex=nvertex, bounds_lon_1D=bounds_lon, & 1226 & bounds_lat_1D=bounds_lat, area=area, type='curvilinear' ) 1227 ENDIF 1228 #endif 1175 1229 CALL xios_solve_inheritance() 1176 1230 1177 1231 END SUBROUTINE iom_set_domain_attr 1232 1233 #if defined key_xios2 1234 SUBROUTINE iom_set_zoom_domain_attr( cdid, ibegin, jbegin, ni, nj) 1235 CHARACTER(LEN=*) , INTENT(in) :: cdid 1236 INTEGER , OPTIONAL, INTENT(in) :: ibegin, jbegin, ni, nj 1237 1238 IF ( xios_is_valid_zoom_domain (cdid) ) THEN 1239 CALL xios_set_zoom_domain_attr ( cdid, ibegin=ibegin, jbegin=jbegin, ni=ni, & 1240 & nj=nj) 1241 ENDIF 1242 END SUBROUTINE iom_set_zoom_domain_attr 1243 #endif 1178 1244 1179 1245 … … 1183 1249 REAL(wp), DIMENSION(:,:), OPTIONAL, INTENT(in) :: bounds 1184 1250 IF ( PRESENT(paxis) ) THEN 1251 #if ! defined key_xios2 1185 1252 IF ( xios_is_valid_axis (cdid) ) CALL xios_set_axis_attr ( cdid, size=SIZE(paxis), value=paxis ) 1186 1253 IF ( xios_is_valid_axisgroup(cdid) ) CALL xios_set_axisgroup_attr( cdid, size=SIZE(paxis), value=paxis ) 1254 #else 1255 IF ( xios_is_valid_axis (cdid) ) CALL xios_set_axis_attr ( cdid, n_glo=SIZE(paxis), value=paxis ) 1256 IF ( xios_is_valid_axisgroup(cdid) ) CALL xios_set_axisgroup_attr( cdid, n_glo=SIZE(paxis), value=paxis ) 1257 #endif 1187 1258 ENDIF 1188 1259 IF ( xios_is_valid_axis (cdid) ) CALL xios_set_axis_attr ( cdid, bounds=bounds ) … … 1191 1262 END SUBROUTINE iom_set_axis_attr 1192 1263 1193 1194 1264 SUBROUTINE iom_set_field_attr( cdid, freq_op, freq_offset ) 1195 1265 CHARACTER(LEN=*) , INTENT(in) :: cdid 1196 CHARACTER(LEN=*),OPTIONAL , INTENT(in) :: freq_op 1197 CHARACTER(LEN=*),OPTIONAL , INTENT(in) :: freq_offset 1198 IF ( xios_is_valid_field (cdid) ) CALL xios_set_field_attr ( cdid, freq_op=freq_op, freq_offset=freq_offset ) 1199 IF ( xios_is_valid_fieldgroup(cdid) ) CALL xios_set_fieldgroup_attr( cdid, freq_op=freq_op, freq_offset=freq_offset ) 1266 #if ! defined key_xios2 1267 CHARACTER(LEN=*) ,OPTIONAL , INTENT(in) :: freq_op 1268 CHARACTER(LEN=*) ,OPTIONAL , INTENT(in) :: freq_offset 1269 #else 1270 TYPE(xios_duration),OPTIONAL , INTENT(in) :: freq_op 1271 TYPE(xios_duration),OPTIONAL , INTENT(in) :: freq_offset 1272 #endif 1273 IF ( xios_is_valid_field (cdid) ) CALL xios_set_field_attr & 1274 & ( cdid, freq_op=freq_op, freq_offset=freq_offset ) 1275 IF ( xios_is_valid_fieldgroup(cdid) ) CALL xios_set_fieldgroup_attr & 1276 & ( cdid, freq_op=freq_op, freq_offset=freq_offset ) 1200 1277 CALL xios_solve_inheritance() 1201 1278 END SUBROUTINE iom_set_field_attr 1202 1203 1279 1204 1280 SUBROUTINE iom_set_file_attr( cdid, name, name_suffix ) … … 1213 1289 SUBROUTINE iom_get_file_attr( cdid, name, name_suffix, output_freq ) 1214 1290 CHARACTER(LEN=*) , INTENT(in ) :: cdid 1215 CHARACTER(LEN=*),OPTIONAL , INTENT(out) :: name, name_suffix, output_freq 1291 CHARACTER(LEN=*),OPTIONAL , INTENT(out) :: name, name_suffix 1292 #if ! defined key_xios2 1293 CHARACTER(LEN=*),OPTIONAL , INTENT(out) :: output_freq 1294 #else 1295 TYPE(xios_duration) ,OPTIONAL , INTENT(out) :: output_freq 1296 #endif 1216 1297 LOGICAL :: llexist1,llexist2,llexist3 1217 1298 !--------------------------------------------------------------------- 1218 1299 IF( PRESENT( name ) ) name = '' ! default values 1219 1300 IF( PRESENT( name_suffix ) ) name_suffix = '' 1301 #if ! defined key_xios2 1220 1302 IF( PRESENT( output_freq ) ) output_freq = '' 1303 #else 1304 IF( PRESENT( output_freq ) ) output_freq = xios_duration(0,0,0,0,0,0) 1305 #endif 1221 1306 IF ( xios_is_valid_file (cdid) ) THEN 1222 1307 CALL xios_solve_inheritance() … … 1239 1324 CHARACTER(LEN=*) , INTENT(in) :: cdid 1240 1325 LOGICAL, DIMENSION(:,:,:), OPTIONAL, INTENT(in) :: mask 1326 #if ! defined key_xios2 1241 1327 IF ( xios_is_valid_grid (cdid) ) CALL xios_set_grid_attr ( cdid, mask=mask ) 1242 1328 IF ( xios_is_valid_gridgroup(cdid) ) CALL xios_set_gridgroup_attr( cdid, mask=mask ) 1329 #else 1330 IF ( xios_is_valid_grid (cdid) ) CALL xios_set_grid_attr ( cdid, mask_3D=mask ) 1331 IF ( xios_is_valid_gridgroup(cdid) ) CALL xios_set_gridgroup_attr( cdid, mask_3D=mask ) 1332 #endif 1243 1333 CALL xios_solve_inheritance() 1244 1334 END SUBROUTINE iom_set_grid_attr … … 1282 1372 ni=nlei-nldi+1 ; nj=nlej-nldj+1 1283 1373 1284 CALL iom_set_domain_attr("grid_"//cdgrd, ni_glo=jpiglo, nj_glo=jpjglo, ibegin=nimpp+nldi-1, jbegin=njmpp+nldj-1, ni=ni, nj=nj) 1374 #if ! defined key_xios2 1375 CALL iom_set_domain_attr("grid_"//cdgrd, ni_glo=jpiglo, nj_glo=jpjglo, ibegin=nimpp+nldi-1, jbegin=njmpp+nldj-1, ni=ni, nj=nj) 1376 #else 1377 CALL iom_set_domain_attr("grid_"//cdgrd, ni_glo=jpiglo, nj_glo=jpjglo, ibegin=nimpp+nldi-2, jbegin=njmpp+nldj-2, ni=ni, nj=nj) 1378 #endif 1285 1379 CALL iom_set_domain_attr("grid_"//cdgrd, data_dim=2, data_ibegin = 1-nldi, data_ni = jpi, data_jbegin = 1-nldj, data_nj = jpj) 1286 1380 CALL iom_set_domain_attr("grid_"//cdgrd, lonvalue = RESHAPE(plon(nldi:nlei, nldj:nlej),(/ ni*nj /)), & … … 1296 1390 END SELECT 1297 1391 ! 1392 #if ! defined key_xios2 1298 1393 CALL iom_set_domain_attr( "grid_"//cdgrd , mask = RESHAPE(zmask(nldi:nlei,nldj:nlej,1),(/ni,nj /)) /= 0. ) 1394 #else 1395 CALL iom_set_domain_attr( "grid_"//cdgrd , mask = RESHAPE(zmask(nldi:nlei,nldj:nlej,1),(/ni*nj /)) /= 0. ) 1396 #endif 1299 1397 CALL iom_set_grid_attr ( "grid_"//cdgrd//"_3D", mask = RESHAPE(zmask(nldi:nlei,nldj:nlej,:),(/ni,nj,jpk/)) /= 0. ) 1300 1398 ENDIF … … 1430 1528 ALLOCATE( zlon(ni*nj) ) ; zlon(:) = 0. 1431 1529 1530 CALL dom_ngb( 180., 90., ix, iy, 'T' ) ! i-line that passes near the North Pole : Reference latitude (used in plots) 1531 #if ! defined key_xios2 1432 1532 CALL iom_set_domain_attr("gznl", ni_glo=jpiglo, nj_glo=jpjglo, ibegin=nimpp+nldi-1, jbegin=njmpp+nldj-1, ni=ni, nj=nj) 1433 1533 CALL iom_set_domain_attr("gznl", data_dim=2, data_ibegin = 1-nldi, data_ni = jpi, data_jbegin = 1-nldj, data_nj = jpj) … … 1435 1535 & latvalue = RESHAPE(plat(nldi:nlei, nldj:nlej),(/ ni*nj /))) 1436 1536 ! 1437 CALL dom_ngb( 180., 90., ix, iy, 'T' ) ! i-line that passes near the North Pole : Reference latitude (used in plots)1438 1537 CALL iom_set_domain_attr ('ptr', zoom_ibegin=ix, zoom_nj=jpjglo) 1538 #else 1539 ! Pas teste : attention aux indices ! 1540 CALL iom_set_domain_attr("gznl", ni_glo=jpiglo, nj_glo=jpjglo, ibegin=nimpp+nldi-2, jbegin=njmpp+nldj-2, ni=ni, nj=nj) 1541 CALL iom_set_domain_attr("gznl", data_dim=2, data_ibegin = 1-nldi, data_ni = jpi, data_jbegin = 1-nldj, data_nj = jpj) 1542 CALL iom_set_domain_attr("gznl", lonvalue = zlon, & 1543 & latvalue = RESHAPE(plat(nldi:nlei, nldj:nlej),(/ ni*nj /))) 1544 CALL iom_set_zoom_domain_attr ("ptr", ibegin=ix-1, jbegin=0, ni=1, nj=jpjglo) 1545 #endif 1546 1439 1547 CALL iom_update_file_name('ptr') 1440 1548 ! … … 1450 1558 REAL(wp), DIMENSION(1) :: zz = 1. 1451 1559 !!---------------------------------------------------------------------- 1560 #if ! defined key_xios2 1452 1561 CALL iom_set_domain_attr('scalarpoint', ni_glo=jpnij, nj_glo=1, ibegin=narea, jbegin=1, ni=1, nj=1) 1562 #else 1563 CALL iom_set_domain_attr('scalarpoint', ni_glo=jpnij, nj_glo=1, ibegin=narea-1, jbegin=0, ni=1, nj=1) 1564 #endif 1453 1565 CALL iom_set_domain_attr('scalarpoint', data_dim=2, data_ibegin = 1, data_ni = 1, data_jbegin = 1, data_nj = 1) 1454 1566 1455 1567 zz=REAL(narea,wp) 1456 1568 CALL iom_set_domain_attr('scalarpoint', lonvalue=zz, latvalue=zz) 1457 1569 1458 1570 END SUBROUTINE set_scalar 1459 1571 … … 1479 1591 REAL(wp) ,DIMENSION( 3) :: zlonpira ! longitudes of pirata moorings 1480 1592 REAL(wp) ,DIMENSION( 9) :: zlatpira ! latitudes of pirata moorings 1593 #if defined key_xios2 1594 TYPE(xios_duration) :: f_op, f_of 1595 #endif 1596 1481 1597 !!---------------------------------------------------------------------- 1482 1598 ! 1483 1599 ! frequency of the call of iom_put (attribut: freq_op) 1484 WRITE(cl1,'(i1)') 1 ; CALL iom_set_field_attr('field_definition', freq_op = cl1//'ts', freq_offset='0ts') 1485 WRITE(cl1,'(i1)') nn_fsbc ; CALL iom_set_field_attr('SBC' , freq_op = cl1//'ts', freq_offset='0ts') 1486 WRITE(cl1,'(i1)') nn_fsbc ; CALL iom_set_field_attr('SBC_scalar' , freq_op = cl1//'ts', freq_offset='0ts') 1487 WRITE(cl1,'(i1)') nn_dttrc ; CALL iom_set_field_attr('ptrc_T' , freq_op = cl1//'ts', freq_offset='0ts') 1488 WRITE(cl1,'(i1)') nn_dttrc ; CALL iom_set_field_attr('diad_T' , freq_op = cl1//'ts', freq_offset='0ts') 1600 #if ! defined key_xios2 1601 WRITE(cl1,'(i1)') 1 ; CALL iom_set_field_attr('field_definition', freq_op=cl1//'ts', freq_offset='0ts') 1602 WRITE(cl1,'(i1)') nn_fsbc ; CALL iom_set_field_attr('SBC' , freq_op=cl1//'ts', freq_offset='0ts') 1603 WRITE(cl1,'(i1)') nn_fsbc ; CALL iom_set_field_attr('SBC_scalar' , freq_op=cl1//'ts', freq_offset='0ts') 1604 WRITE(cl1,'(i1)') nn_dttrc ; CALL iom_set_field_attr('ptrc_T' , freq_op=cl1//'ts', freq_offset='0ts') 1605 WRITE(cl1,'(i1)') nn_dttrc ; CALL iom_set_field_attr('diad_T' , freq_op=cl1//'ts', freq_offset='0ts') 1606 #else 1607 f_op%timestep = 1 ; f_of%timestep = 0 ; CALL iom_set_field_attr('field_definition', freq_op=f_op, freq_offset=f_of) 1608 f_op%timestep = nn_fsbc ; f_of%timestep = 0 ; CALL iom_set_field_attr('SBC' , freq_op=f_op, freq_offset=f_of) 1609 f_op%timestep = nn_fsbc ; f_of%timestep = 0 ; CALL iom_set_field_attr('SBC_scalar' , freq_op=f_op, freq_offset=f_of) 1610 f_op%timestep = nn_dttrc ; f_of%timestep = 0 ; CALL iom_set_field_attr('ptrc_T' , freq_op=f_op, freq_offset=f_of) 1611 f_op%timestep = nn_dttrc ; f_of%timestep = 0 ; CALL iom_set_field_attr('diad_T' , freq_op=f_op, freq_offset=f_of) 1612 #endif 1489 1613 1490 1614 ! output file names (attribut: name) … … 1508 1632 ! Equatorial section (attributs: jbegin, ni, name_suffix) 1509 1633 CALL dom_ngb( 0., 0., ix, iy, cl1 ) 1634 #if ! defined key_xios2 1510 1635 CALL iom_set_domain_attr ('Eq'//cl1, zoom_jbegin=iy, zoom_ni=jpiglo) 1636 #else 1637 CALL iom_set_zoom_domain_attr ('Eq'//cl1, jbegin=iy-1, ni=jpiglo) 1638 #endif 1511 1639 CALL iom_get_file_attr ('Eq'//cl1, name_suffix = clsuff ) 1512 1640 CALL iom_set_file_attr ('Eq'//cl1, name_suffix = TRIM(clsuff)//'_Eq') … … 1588 1716 ENDIF 1589 1717 clname = TRIM(ADJUSTL(clat))//TRIM(ADJUSTL(clon)) 1718 #if ! defined key_xios2 1590 1719 CALL iom_set_domain_attr (TRIM(clname)//cl1, zoom_ibegin= ix, zoom_jbegin= iy) 1720 #else 1721 CALL iom_set_zoom_domain_attr (TRIM(clname)//cl1, ibegin= ix-1, jbegin= iy-1) 1722 #endif 1591 1723 CALL iom_get_file_attr (TRIM(clname)//cl1, name_suffix = clsuff ) 1592 1724 CALL iom_set_file_attr (TRIM(clname)//cl1, name_suffix = TRIM(clsuff)//'_'//TRIM(clname)) … … 1617 1749 REAL(wp) :: zsec 1618 1750 LOGICAL :: llexist 1619 !!---------------------------------------------------------------------- 1751 #if defined key_xios2 1752 TYPE(xios_duration) :: output_freq 1753 #endif 1754 !!---------------------------------------------------------------------- 1755 1620 1756 1621 1757 DO jn = 1,2 1622 1758 #if ! defined key_xios2 1623 1759 IF( jn == 1 ) CALL iom_get_file_attr( cdid, name = clname, output_freq = clfreq ) 1760 #else 1761 output_freq = xios_duration(0,0,0,0,0,0) 1762 IF( jn == 1 ) CALL iom_get_file_attr( cdid, name = clname, output_freq = output_freq ) 1763 #endif 1624 1764 IF( jn == 2 ) CALL iom_get_file_attr( cdid, name_suffix = clname ) 1625 1765 … … 1632 1772 END DO 1633 1773 1774 #if ! defined key_xios2 1634 1775 idx = INDEX(clname,'@freq@') + INDEX(clname,'@FREQ@') 1635 1776 DO WHILE ( idx /= 0 ) … … 1644 1785 idx = INDEX(clname,'@freq@') + INDEX(clname,'@FREQ@') 1645 1786 END DO 1646 1787 #else 1788 idx = INDEX(clname,'@freq@') + INDEX(clname,'@FREQ@') 1789 DO WHILE ( idx /= 0 ) 1790 IF ( output_freq%timestep /= 0) THEN 1791 WRITE(clfreq,'(I18,A2)')INT(output_freq%timestep),'ts' 1792 itrlen = LEN_TRIM(ADJUSTL(clfreq)) 1793 ELSE IF ( output_freq%hour /= 0 ) THEN 1794 WRITE(clfreq,'(I19,A1)')INT(output_freq%hour),'h' 1795 itrlen = LEN_TRIM(ADJUSTL(clfreq)) 1796 ELSE IF ( output_freq%day /= 0 ) THEN 1797 WRITE(clfreq,'(I19,A1)')INT(output_freq%day),'d' 1798 itrlen = LEN_TRIM(ADJUSTL(clfreq)) 1799 ELSE IF ( output_freq%month /= 0 ) THEN 1800 WRITE(clfreq,'(I19,A1)')INT(output_freq%month),'m' 1801 itrlen = LEN_TRIM(ADJUSTL(clfreq)) 1802 ELSE IF ( output_freq%year /= 0 ) THEN 1803 WRITE(clfreq,'(I19,A1)')INT(output_freq%year),'y' 1804 itrlen = LEN_TRIM(ADJUSTL(clfreq)) 1805 ELSE 1806 CALL ctl_stop('error in the name of file id '//TRIM(cdid), & 1807 & ' attribute output_freq is undefined -> cannot replace @freq@ in '//TRIM(clname) ) 1808 ENDIF 1809 clname = clname(1:idx-1)//TRIM(ADJUSTL(clfreq))//clname(idx+6:LEN_TRIM(clname)) 1810 idx = INDEX(clname,'@freq@') + INDEX(clname,'@FREQ@') 1811 END DO 1812 #endif 1647 1813 idx = INDEX(clname,'@startdate@') + INDEX(clname,'@STARTDATE@') 1648 1814 DO WHILE ( idx /= 0 ) … … 1673 1839 END DO 1674 1840 1841 IF( jn == 1 .AND. TRIM(Agrif_CFixed()) /= '0' ) clname = TRIM(Agrif_CFixed())//"_"//TRIM(clname) 1675 1842 IF( jn == 1 ) CALL iom_set_file_attr( cdid, name = clname ) 1676 1843 IF( jn == 2 ) CALL iom_set_file_attr( cdid, name_suffix = clname ) … … 1720 1887 ENDIF 1721 1888 1889 !$AGRIF_DO_NOT_TREAT 1890 ! Should be fixed in the conv 1722 1891 IF( llfull ) THEN 1723 1892 clfmt = TRIM(clfmt)//",'_',i2.2,':',i2.2,':',i2.2" … … 1730 1899 WRITE(iom_sdate, '('//TRIM(clfmt)//')') iyear, imonth, iday ! date of the end of run 1731 1900 ENDIF 1901 !$AGRIF_END_DO_NOT_TREAT 1732 1902 1733 1903 END FUNCTION iom_sdate -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/LBC/lbclnk.F90
r6836 r6839 11 11 !! the BDY/OBC communications 12 12 !! 3.4 ! 2012-12 (R. Bourdalle-Badie and G. Reffray) add a C1D case 13 !! 3.6 ! 2015-06 (O. Tintó and M. Castrillo) add lbc_lnk_multi 13 14 !!---------------------------------------------------------------------- 14 15 #if defined key_mpp_mpi … … 24 25 25 26 INTERFACE lbc_lnk_multi 26 MODULE PROCEDURE mpp_lnk_2d_9 27 MODULE PROCEDURE mpp_lnk_2d_9, mpp_lnk_2d_multiple 27 28 END INTERFACE 28 29 … … 80 81 END INTERFACE 81 82 83 INTERFACE lbc_lnk_multi 84 MODULE PROCEDURE lbc_lnk_2d_9, lbc_lnk_2d_multiple 85 END INTERFACE 86 82 87 INTERFACE lbc_bdy_lnk 83 88 MODULE PROCEDURE lbc_bdy_lnk_2d, lbc_bdy_lnk_3d … … 87 92 MODULE PROCEDURE lbc_lnk_2d_e 88 93 END INTERFACE 94 95 TYPE arrayptr 96 REAL , DIMENSION (:,:), POINTER :: pt2d 97 END TYPE arrayptr 98 PUBLIC arrayptr 89 99 90 100 PUBLIC lbc_lnk ! ocean/ice lateral boundary conditions 91 101 PUBLIC lbc_lnk_e 102 PUBLIC lbc_lnk_multi ! modified ocean lateral boundary conditions 92 103 PUBLIC lbc_bdy_lnk ! ocean lateral BDY boundary conditions 93 104 PUBLIC lbc_lnk_icb … … 171 182 ! 172 183 END SUBROUTINE lbc_lnk_2d 184 185 SUBROUTINE lbc_lnk_2d_multiple( pt2d_array , type_array , psgn_array , num_fields ) 186 !! 187 INTEGER :: num_fields 188 TYPE( arrayptr ), DIMENSION(:) :: pt2d_array 189 CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: type_array ! define the nature of ptab array grid-points 190 ! ! = T , U , V , F , W and I points 191 REAL(wp) , DIMENSION(:), INTENT(in ) :: psgn_array ! =-1 the sign change across the north fold boundary 192 ! ! = 1. , the sign is kept 193 ! 194 INTEGER :: ii !!MULTI SEND DUMMY LOOP INDICES 195 ! 196 DO ii = 1, num_fields 197 CALL lbc_lnk_2d( pt2d_array(ii)%pt2d, type_array(ii), psgn_array(ii) ) 198 END DO 199 ! 200 END SUBROUTINE lbc_lnk_2d_multiple 201 202 SUBROUTINE lbc_lnk_2d_9( pt2dA, cd_typeA, psgnA, pt2dB, cd_typeB, psgnB, pt2dC, cd_typeC, psgnC & 203 & , pt2dD, cd_typeD, psgnD, pt2dE, cd_typeE, psgnE, pt2dF, cd_typeF, psgnF & 204 & , pt2dG, cd_typeG, psgnG, pt2dH, cd_typeH, psgnH, pt2dI, cd_typeI, psgnI, cd_mpp, pval) 205 !!--------------------------------------------------------------------- 206 ! Second 2D array on which the boundary condition is applied 207 REAL(wp), DIMENSION(jpi,jpj), TARGET , INTENT(inout) :: pt2dA 208 REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) :: pt2dB , pt2dC , pt2dD , pt2dE 209 REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) :: pt2dF , pt2dG , pt2dH , pt2dI 210 ! define the nature of ptab array grid-points 211 CHARACTER(len=1) , INTENT(in ) :: cd_typeA 212 CHARACTER(len=1) , OPTIONAL, INTENT(in ) :: cd_typeB , cd_typeC , cd_typeD , cd_typeE 213 CHARACTER(len=1) , OPTIONAL, INTENT(in ) :: cd_typeF , cd_typeG , cd_typeH , cd_typeI 214 ! =-1 the sign change across the north fold boundary 215 REAL(wp) , INTENT(in ) :: psgnA 216 REAL(wp) , OPTIONAL, INTENT(in ) :: psgnB , psgnC , psgnD , psgnE 217 REAL(wp) , OPTIONAL, INTENT(in ) :: psgnF , psgnG , psgnH , psgnI 218 CHARACTER(len=3) , OPTIONAL, INTENT(in ) :: cd_mpp ! fill the overlap area only 219 REAL(wp) , OPTIONAL, INTENT(in ) :: pval ! background value (used at closed boundaries) 220 !! 221 !!--------------------------------------------------------------------- 222 223 !!The first array 224 CALL lbc_lnk( pt2dA, cd_typeA, psgnA ) 225 226 !! Look if more arrays to process 227 IF(PRESENT (psgnB) )CALL lbc_lnk( pt2dA, cd_typeA, psgnA ) 228 IF(PRESENT (psgnC) )CALL lbc_lnk( pt2dC, cd_typeC, psgnC ) 229 IF(PRESENT (psgnD) )CALL lbc_lnk( pt2dD, cd_typeD, psgnD ) 230 IF(PRESENT (psgnE) )CALL lbc_lnk( pt2dE, cd_typeE, psgnE ) 231 IF(PRESENT (psgnF) )CALL lbc_lnk( pt2dF, cd_typeF, psgnF ) 232 IF(PRESENT (psgnG) )CALL lbc_lnk( pt2dG, cd_typeG, psgnG ) 233 IF(PRESENT (psgnH) )CALL lbc_lnk( pt2dH, cd_typeH, psgnH ) 234 IF(PRESENT (psgnI) )CALL lbc_lnk( pt2dI, cd_typeI, psgnI ) 235 236 END SUBROUTINE lbc_lnk_2d_9 237 238 239 240 173 241 174 242 #else … … 372 440 ! 373 441 END SUBROUTINE lbc_lnk_2d 442 443 SUBROUTINE lbc_lnk_2d_multiple( pt2d_array , type_array , psgn_array , num_fields ) 444 !! 445 INTEGER :: num_fields 446 TYPE( arrayptr ), DIMENSION(:) :: pt2d_array 447 CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: type_array ! define the nature of ptab array grid-points 448 ! ! = T , U , V , F , W and I points 449 REAL(wp) , DIMENSION(:), INTENT(in ) :: psgn_array ! =-1 the sign change across the north fold boundary 450 ! ! = 1. , the sign is kept 451 ! 452 INTEGER :: ii !!MULTI SEND DUMMY LOOP INDICES 453 ! 454 DO ii = 1, num_fields 455 CALL lbc_lnk_2d( pt2d_array(ii)%pt2d, type_array(ii), psgn_array(ii) ) 456 END DO 457 ! 458 END SUBROUTINE lbc_lnk_2d_multiple 459 460 SUBROUTINE lbc_lnk_2d_9( pt2dA, cd_typeA, psgnA, pt2dB, cd_typeB, psgnB, pt2dC, cd_typeC, psgnC & 461 & , pt2dD, cd_typeD, psgnD, pt2dE, cd_typeE, psgnE, pt2dF, cd_typeF, psgnF & 462 & , pt2dG, cd_typeG, psgnG, pt2dH, cd_typeH, psgnH, pt2dI, cd_typeI, psgnI, cd_mpp, pval) 463 !!--------------------------------------------------------------------- 464 ! Second 2D array on which the boundary condition is applied 465 REAL(wp), DIMENSION(jpi,jpj), TARGET , INTENT(inout) :: pt2dA 466 REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) :: pt2dB , pt2dC , pt2dD , pt2dE 467 REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) :: pt2dF , pt2dG , pt2dH , pt2dI 468 ! define the nature of ptab array grid-points 469 CHARACTER(len=1) , INTENT(in ) :: cd_typeA 470 CHARACTER(len=1) , OPTIONAL, INTENT(in ) :: cd_typeB , cd_typeC , cd_typeD , cd_typeE 471 CHARACTER(len=1) , OPTIONAL, INTENT(in ) :: cd_typeF , cd_typeG , cd_typeH , cd_typeI 472 ! =-1 the sign change across the north fold boundary 473 REAL(wp) , INTENT(in ) :: psgnA 474 REAL(wp) , OPTIONAL, INTENT(in ) :: psgnB , psgnC , psgnD , psgnE 475 REAL(wp) , OPTIONAL, INTENT(in ) :: psgnF , psgnG , psgnH , psgnI 476 CHARACTER(len=3) , OPTIONAL, INTENT(in ) :: cd_mpp ! fill the overlap area only 477 REAL(wp) , OPTIONAL, INTENT(in ) :: pval ! background value (used at closed boundaries) 478 !! 479 !!--------------------------------------------------------------------- 480 481 !!The first array 482 CALL lbc_lnk( pt2dA, cd_typeA, psgnA ) 483 484 !! Look if more arrays to process 485 IF(PRESENT (psgnB) )CALL lbc_lnk( pt2dA, cd_typeA, psgnA ) 486 IF(PRESENT (psgnC) )CALL lbc_lnk( pt2dC, cd_typeC, psgnC ) 487 IF(PRESENT (psgnD) )CALL lbc_lnk( pt2dD, cd_typeD, psgnD ) 488 IF(PRESENT (psgnE) )CALL lbc_lnk( pt2dE, cd_typeE, psgnE ) 489 IF(PRESENT (psgnF) )CALL lbc_lnk( pt2dF, cd_typeF, psgnF ) 490 IF(PRESENT (psgnG) )CALL lbc_lnk( pt2dG, cd_typeG, psgnG ) 491 IF(PRESENT (psgnH) )CALL lbc_lnk( pt2dH, cd_typeH, psgnH ) 492 IF(PRESENT (psgnI) )CALL lbc_lnk( pt2dI, cd_typeI, psgnI ) 493 494 END SUBROUTINE lbc_lnk_2d_9 495 374 496 375 497 #endif … … 441 563 !!====================================================================== 442 564 END MODULE lbclnk 565 -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90
r6836 r6839 24 24 !! 3.5 ! 2013 ( C. Ethe, G. Madec ) message passing arrays as local variables 25 25 !! 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' 26 27 !!---------------------------------------------------------------------- 27 28 … … 62 63 USE lbcnfd ! north fold treatment 63 64 USE in_out_manager ! I/O manager 65 USE wrk_nemo ! work arrays 64 66 65 67 IMPLICIT NONE … … 70 72 PUBLIC mpp_ini_north, mpp_lbc_north, mpp_lbc_north_e 71 73 PUBLIC mpp_min, mpp_max, mpp_sum, mpp_minloc, mpp_maxloc 74 PUBLIC mpp_max_multiple 72 75 PUBLIC mpp_lnk_3d, mpp_lnk_3d_gather, mpp_lnk_2d, mpp_lnk_2d_e 73 PUBLIC mpp_lnk_2d_9 76 PUBLIC mpp_lnk_2d_9 , mpp_lnk_2d_multiple 74 77 PUBLIC mppscatter, mppgather 75 78 PUBLIC mpp_ini_ice, mpp_ini_znl … … 78 81 PUBLIC mpp_lnk_bdy_2d, mpp_lnk_bdy_3d 79 82 PUBLIC mpp_lbc_north_icb, mpp_lnk_2d_icb 83 PUBLIC mpprank 80 84 81 85 TYPE arrayptr 82 86 REAL , DIMENSION (:,:), POINTER :: pt2d 83 87 END TYPE arrayptr 88 PUBLIC arrayptr 84 89 85 90 !! * Interfaces … … 105 110 INTERFACE mpp_maxloc 106 111 MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d 112 END INTERFACE 113 114 INTERFACE mpp_max_multiple 115 MODULE PROCEDURE mppmax_real_multiple 107 116 END INTERFACE 108 117 … … 298 307 ENDIF 299 308 309 #if defined key_agrif 310 IF (Agrif_Root()) THEN 311 CALL Agrif_MPI_Init(mpi_comm_opa) 312 ELSE 313 CALL Agrif_MPI_set_grid_comm(mpi_comm_opa) 314 ENDIF 315 #endif 316 300 317 CALL mpi_comm_rank( mpi_comm_opa, mpprank, ierr ) 301 318 CALL mpi_comm_size( mpi_comm_opa, mppsize, ierr ) … … 724 741 ! ----------------------- 725 742 ! 726 DO ii = 1 , num_fields727 743 !First Array 728 IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 729 ! 730 SELECT CASE ( jpni ) 731 CASE ( 1 ) ; CALL lbc_nfd ( pt2d_array(ii)%pt2d( : , : ), type_array(ii) , psgn_array(ii) ) ! only 1 northern proc, no mpp 732 CASE DEFAULT ; CALL mpp_lbc_north( pt2d_array(ii)%pt2d( : , : ), type_array(ii), psgn_array(ii) ) ! for all northern procs. 733 END SELECT 734 ! 735 ENDIF 736 ! 737 END DO 744 IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 745 ! 746 SELECT CASE ( jpni ) 747 CASE ( 1 ) ; 748 DO ii = 1 , num_fields 749 CALL lbc_nfd ( pt2d_array(ii)%pt2d( : , : ), type_array(ii) , psgn_array(ii) ) ! only 1 northern proc, no mpp 750 END DO 751 CASE DEFAULT ; CALL mpp_lbc_north_2d_multiple( pt2d_array, type_array, psgn_array, num_fields ) ! for all northern procs. 752 END SELECT 753 ! 754 ENDIF 755 ! 738 756 739 757 DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we ) … … 1681 1699 END SUBROUTINE mppmax_real 1682 1700 1701 SUBROUTINE mppmax_real_multiple( ptab, NUM , kcom ) 1702 !!---------------------------------------------------------------------- 1703 !! *** routine mppmax_real *** 1704 !! 1705 !! ** Purpose : Maximum 1706 !! 1707 !!---------------------------------------------------------------------- 1708 REAL(wp), DIMENSION(:) , INTENT(inout) :: ptab ! ??? 1709 INTEGER , INTENT(in ) :: NUM 1710 INTEGER , INTENT(in ), OPTIONAL :: kcom ! ??? 1711 !! 1712 INTEGER :: ierror, localcomm 1713 REAL(wp) , POINTER , DIMENSION(:) :: zwork 1714 !!---------------------------------------------------------------------- 1715 ! 1716 CALL wrk_alloc(NUM , zwork) 1717 localcomm = mpi_comm_opa 1718 IF( PRESENT(kcom) ) localcomm = kcom 1719 ! 1720 CALL mpi_allreduce( ptab, zwork, NUM, mpi_double_precision, mpi_max, localcomm, ierror ) 1721 ptab = zwork 1722 CALL wrk_dealloc(NUM , zwork) 1723 ! 1724 END SUBROUTINE mppmax_real_multiple 1725 1683 1726 1684 1727 SUBROUTINE mppmin_a_real( ptab, kdim, kcom ) … … 2575 2618 END SUBROUTINE mpp_lbc_north_2d 2576 2619 2620 SUBROUTINE mpp_lbc_north_2d_multiple( pt2d_array, cd_type, psgn, num_fields) 2621 !!--------------------------------------------------------------------- 2622 !! *** routine mpp_lbc_north_2d *** 2623 !! 2624 !! ** Purpose : Ensure proper north fold horizontal bondary condition 2625 !! in mpp configuration in case of jpn1 > 1 2626 !! (for multiple 2d arrays ) 2627 !! 2628 !! ** Method : North fold condition and mpp with more than one proc 2629 !! in i-direction require a specific treatment. We gather 2630 !! the 4 northern lines of the global domain on 1 processor 2631 !! and apply lbc north-fold on this sub array. Then we 2632 !! scatter the north fold array back to the processors. 2633 !! 2634 !!---------------------------------------------------------------------- 2635 INTEGER , INTENT (in ) :: num_fields ! number of variables contained in pt2d 2636 TYPE( arrayptr ), DIMENSION(:) :: pt2d_array 2637 CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: cd_type ! nature of pt2d grid-points 2638 ! ! = T , U , V , F or W gridpoints 2639 REAL(wp), DIMENSION(:), INTENT(in ) :: psgn ! = -1. the sign change across the north fold 2640 !! ! = 1. , the sign is kept 2641 INTEGER :: ji, jj, jr, jk 2642 INTEGER :: ierr, itaille, ildi, ilei, iilb 2643 INTEGER :: ijpj, ijpjm1, ij, iproc 2644 INTEGER, DIMENSION (jpmaxngh) :: ml_req_nf !for mpi_isend when avoiding mpi_allgather 2645 INTEGER :: ml_err ! for mpi_isend when avoiding mpi_allgather 2646 INTEGER, DIMENSION(MPI_STATUS_SIZE):: ml_stat ! for mpi_isend when avoiding mpi_allgather 2647 ! ! Workspace for message transfers avoiding mpi_allgather 2648 REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: ztab 2649 REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: znorthloc, zfoldwk 2650 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: znorthgloio 2651 REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: ztabl, ztabr 2652 INTEGER :: istatus(mpi_status_size) 2653 INTEGER :: iflag 2654 !!---------------------------------------------------------------------- 2655 ! 2656 ALLOCATE( ztab(jpiglo,4,num_fields), znorthloc(jpi,4,num_fields), zfoldwk(jpi,4,num_fields), znorthgloio(jpi,4,num_fields,jpni) ) ! expanded to 3 dimensions 2657 ALLOCATE( ztabl(jpi,4,num_fields), ztabr(jpi*jpmaxngh, 4,num_fields) ) 2658 ! 2659 ijpj = 4 2660 ijpjm1 = 3 2661 ! 2662 2663 DO jk = 1, num_fields 2664 DO jj = nlcj-ijpj+1, nlcj ! put in znorthloc the last 4 jlines of pt2d (for every variable) 2665 ij = jj - nlcj + ijpj 2666 znorthloc(:,ij,jk) = pt2d_array(jk)%pt2d(:,jj) 2667 END DO 2668 END DO 2669 ! ! Build in procs of ncomm_north the znorthgloio 2670 itaille = jpi * ijpj 2671 2672 IF ( l_north_nogather ) THEN 2673 ! 2674 ! Avoid the use of mpi_allgather by exchanging only with the processes already identified 2675 ! (in nemo_northcomms) as being involved in this process' northern boundary exchange 2676 ! 2677 ztabr(:,:,:) = 0 2678 ztabl(:,:,:) = 0 2679 2680 DO jk = 1, num_fields 2681 DO jj = nlcj-ijpj+1, nlcj ! First put local values into the global array 2682 ij = jj - nlcj + ijpj 2683 DO ji = nfsloop, nfeloop 2684 ztabl(ji,ij,jk) = pt2d_array(jk)%pt2d(ji,jj) 2685 END DO 2686 END DO 2687 END DO 2688 2689 DO jr = 1,nsndto 2690 IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN 2691 CALL mppsend(5, znorthloc, itaille*num_fields, nfipproc(isendto(jr),jpnj), ml_req_nf(jr)) ! Buffer expanded "num_fields" times 2692 ENDIF 2693 END DO 2694 DO jr = 1,nsndto 2695 iproc = nfipproc(isendto(jr),jpnj) 2696 IF(iproc .ne. -1) THEN 2697 ilei = nleit (iproc+1) 2698 ildi = nldit (iproc+1) 2699 iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj) 2700 ENDIF 2701 IF((iproc .ne. (narea-1)) .and. (iproc .ne. -1)) THEN 2702 CALL mpprecv(5, zfoldwk, itaille*num_fields, iproc) ! Buffer expanded "num_fields" times 2703 DO jk = 1 , num_fields 2704 DO jj = 1, ijpj 2705 DO ji = ildi, ilei 2706 ztabr(iilb+ji,jj,jk) = zfoldwk(ji,jj,jk) ! Modified to 3D 2707 END DO 2708 END DO 2709 END DO 2710 ELSE IF (iproc .eq. (narea-1)) THEN 2711 DO jk = 1, num_fields 2712 DO jj = 1, ijpj 2713 DO ji = ildi, ilei 2714 ztabr(iilb+ji,jj,jk) = pt2d_array(jk)%pt2d(ji,nlcj-ijpj+jj) ! Modified to 3D 2715 END DO 2716 END DO 2717 END DO 2718 ENDIF 2719 END DO 2720 IF (l_isend) THEN 2721 DO jr = 1,nsndto 2722 IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN 2723 CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err) 2724 ENDIF 2725 END DO 2726 ENDIF 2727 ! 2728 DO ji = 1, num_fields ! Loop to manage 3D variables 2729 CALL mpp_lbc_nfd( ztabl(:,:,ji), ztabr(:,:,ji), cd_type(ji), psgn(ji) ) ! North fold boundary condition 2730 END DO 2731 ! 2732 DO jk = 1, num_fields 2733 DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt2d 2734 ij = jj - nlcj + ijpj 2735 DO ji = 1, nlci 2736 pt2d_array(jk)%pt2d(ji,jj) = ztabl(ji,ij,jk) ! Modified to 3D 2737 END DO 2738 END DO 2739 END DO 2740 2741 ! 2742 ELSE 2743 ! 2744 CALL MPI_ALLGATHER( znorthloc , itaille*num_fields, MPI_DOUBLE_PRECISION, & 2745 & znorthgloio, itaille*num_fields, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 2746 ! 2747 ztab(:,:,:) = 0.e0 2748 DO jk = 1, num_fields 2749 DO jr = 1, ndim_rank_north ! recover the global north array 2750 iproc = nrank_north(jr) + 1 2751 ildi = nldit (iproc) 2752 ilei = nleit (iproc) 2753 iilb = nimppt(iproc) 2754 DO jj = 1, ijpj 2755 DO ji = ildi, ilei 2756 ztab(ji+iilb-1,jj,jk) = znorthgloio(ji,jj,jk,jr) 2757 END DO 2758 END DO 2759 END DO 2760 END DO 2761 2762 DO ji = 1, num_fields 2763 CALL lbc_nfd( ztab(:,:,ji), cd_type(ji), psgn(ji) ) ! North fold boundary condition 2764 END DO 2765 ! 2766 DO jk = 1, num_fields 2767 DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt2d 2768 ij = jj - nlcj + ijpj 2769 DO ji = 1, nlci 2770 pt2d_array(jk)%pt2d(ji,jj) = ztab(ji+nimpp-1,ij,jk) 2771 END DO 2772 END DO 2773 END DO 2774 ! 2775 ! 2776 ENDIF 2777 DEALLOCATE( ztab, znorthloc, zfoldwk, znorthgloio ) 2778 DEALLOCATE( ztabl, ztabr ) 2779 ! 2780 END SUBROUTINE mpp_lbc_north_2d_multiple 2577 2781 2578 2782 SUBROUTINE mpp_lbc_north_e( pt2d, cd_type, psgn) -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/LBC/mppini.F90
r6836 r6839 201 201 202 202 #endif 203 IF(lwp) THEN204 WRITE(numout,*)205 WRITE(numout,*) ' defines mpp subdomains'206 WRITE(numout,*) ' ----------------------'207 WRITE(numout,*) ' iresti=',iresti,' irestj=',irestj208 WRITE(numout,*) ' jpni =',jpni ,' jpnj =',jpnj209 ifreq = 4210 il1 = 1211 DO jn = 1, (jpni-1)/ifreq+1212 il2 = MIN( jpni, il1+ifreq-1 )213 WRITE(numout,*)214 WRITE(numout,9200) ('***',ji = il1,il2-1)215 DO jj = jpnj, 1, -1216 WRITE(numout,9203) (' ',ji = il1,il2-1)217 WRITE(numout,9202) jj, ( ilcit(ji,jj),ilcjt(ji,jj),ji = il1,il2 )218 WRITE(numout,9203) (' ',ji = il1,il2-1)219 WRITE(numout,9200) ('***',ji = il1,il2-1)220 END DO221 WRITE(numout,9201) (ji,ji = il1,il2)222 il1 = il1+ifreq223 END DO224 9200 FORMAT(' ***',20('*************',a3))225 9203 FORMAT(' * ',20(' * ',a3))226 9201 FORMAT(' ',20(' ',i3,' '))227 9202 FORMAT(' ',i3,' * ',20(i3,' x',i3,' * '))228 ENDIF229 230 zidom = nreci231 DO ji = 1, jpni232 zidom = zidom + ilcit(ji,1) - nreci233 END DO234 IF(lwp) WRITE(numout,*)235 IF(lwp) WRITE(numout,*)' sum ilcit(i,1) = ', zidom, ' jpiglo = ', jpiglo236 237 zjdom = nrecj238 DO jj = 1, jpnj239 zjdom = zjdom + ilcjt(1,jj) - nrecj240 END DO241 IF(lwp) WRITE(numout,*)' sum ilcit(1,j) = ', zjdom, ' jpjglo = ', jpjglo242 IF(lwp) WRITE(numout,*)243 244 203 245 204 ! 2. Index arrays for subdomains … … 304 263 nlejt(jn) = nlej 305 264 END DO 306 307 308 ! 4. From global to local 265 266 ! 4. Subdomain print 267 ! ------------------ 268 269 IF(lwp) WRITE(numout,*) 270 IF(lwp) WRITE(numout,*) ' mpp_init: defines mpp subdomains' 271 IF(lwp) WRITE(numout,*) ' ~~~~~~ ----------------------' 272 IF(lwp) WRITE(numout,*) 273 IF(lwp) WRITE(numout,*) 'iresti=',iresti,' irestj=',irestj 274 IF(lwp) WRITE(numout,*) 275 IF(lwp) WRITE(numout,*) 'jpni=',jpni,' jpnj=',jpnj 276 zidom = nreci 277 DO ji = 1, jpni 278 zidom = zidom + ilcit(ji,1) - nreci 279 END DO 280 IF(lwp) WRITE(numout,*) 281 IF(lwp) WRITE(numout,*)' sum ilcit(i,1)=', zidom, ' jpiglo=', jpiglo 282 283 zjdom = nrecj 284 DO jj = 1, jpnj 285 zjdom = zjdom + ilcjt(1,jj) - nrecj 286 END DO 287 IF(lwp) WRITE(numout,*)' sum ilcit(1,j)=', zjdom, ' jpjglo=', jpjglo 288 IF(lwp) WRITE(numout,*) 289 290 IF(lwp) THEN 291 ifreq = 4 292 il1 = 1 293 DO jn = 1, (jpni-1)/ifreq+1 294 il2 = MIN( jpni, il1+ifreq-1 ) 295 WRITE(numout,*) 296 WRITE(numout,9200) ('***',ji = il1,il2-1) 297 DO jj = jpnj, 1, -1 298 WRITE(numout,9203) (' ',ji = il1,il2-1) 299 WRITE(numout,9202) jj, ( ilcit(ji,jj),ilcjt(ji,jj),ji = il1,il2 ) 300 WRITE(numout,9204) (nfipproc(ji,jj),ji=il1,il2) 301 WRITE(numout,9203) (' ',ji = il1,il2-1) 302 WRITE(numout,9200) ('***',ji = il1,il2-1) 303 END DO 304 WRITE(numout,9201) (ji,ji = il1,il2) 305 il1 = il1+ifreq 306 END DO 307 9200 FORMAT(' ***',20('*************',a3)) 308 9203 FORMAT(' * ',20(' * ',a3)) 309 9201 FORMAT(' ',20(' ',i3,' ')) 310 9202 FORMAT(' ',i3,' * ',20(i3,' x',i3,' * ')) 311 9204 FORMAT(' * ',20(' ',i3,' * ')) 312 ENDIF 313 314 ! 5. From global to local 309 315 ! ----------------------- 310 316 … … 313 319 314 320 315 ! 5. Subdomain neighbours321 ! 6. Subdomain neighbours 316 322 ! ---------------------- 317 323 … … 436 442 WRITE(numout,*) ' nimpp = ', nimpp 437 443 WRITE(numout,*) ' njmpp = ', njmpp 438 WRITE(numout,*) ' nbse = ', nbse , ' npse = ', npse 439 WRITE(numout,*) ' nbsw = ', nbsw , ' npsw = ', npsw 440 WRITE(numout,*) ' nbne = ', nbne , ' npne = ', npne 441 WRITE(numout,*) ' nbnw = ', nbnw , ' npnw = ', npnw 444 WRITE(numout,*) ' nreci = ', nreci , ' npse = ', npse 445 WRITE(numout,*) ' nrecj = ', nrecj , ' npsw = ', npsw 446 WRITE(numout,*) ' jpreci = ', jpreci , ' npne = ', npne 447 WRITE(numout,*) ' jprecj = ', jprecj , ' npnw = ', npnw 448 WRITE(numout,*) 442 449 ENDIF 443 450 … … 446 453 ! Prepare mpp north fold 447 454 448 IF (jperio >= 3 .AND. jperio <= 6 .AND. jpni > 1 ) THEN455 IF( jperio >= 3 .AND. jperio <= 6 .AND. jpni > 1 ) THEN 449 456 CALL mpp_ini_north 450 END IF 457 IF(lwp) WRITE(numout,*) ' mpp_init : North fold boundary prepared for jpni >1' 458 ENDIF 451 459 452 460 ! Prepare NetCDF output file (if necessary) -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/LBC/mppini_2.h90
r6836 r6839 318 318 ENDIF 319 319 320 ! Check wet points over the entire domain to preserve the MPI communication stencil 320 321 isurf = 0 321 DO jj = 1 +jprecj, ilj-jprecj322 DO ji = 1 +jpreci, ili-jpreci322 DO jj = 1, ilj 323 DO ji = 1, ili 323 324 IF( imask(ji+iimppt(ii,ij)-1, jj+ijmppt(ii,ij)-1) == 1) isurf = isurf+1 324 325 END DO 325 326 END DO 327 326 328 IF(isurf /= 0) THEN 327 329 icont = icont + 1 … … 333 335 334 336 nfipproc(:,:) = ipproc(:,:) 335 336 337 337 338 ! Control … … 441 442 ii = iin(narea) 442 443 ij = ijn(narea) 444 445 ! set default neighbours 446 noso = ioso(ii,ij) 447 nowe = iowe(ii,ij) 448 noea = ioea(ii,ij) 449 nono = iono(ii,ij) 450 npse = iose(ii,ij) 451 npsw = iosw(ii,ij) 452 npne = ione(ii,ij) 453 npnw = ionw(ii,ij) 454 455 ! check neighbours location 443 456 IF( ioso(ii,ij) >= 0 .AND. ioso(ii,ij) <= (jpni*jpnj-1) ) THEN 444 457 iiso = 1 + MOD(ioso(ii,ij),jpni) … … 511 524 IF (lwp) THEN 512 525 CALL ctl_opn( inum, 'layout.dat', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE., narea ) 526 WRITE(inum,'(a)') ' jpnij jpi jpj jpk jpiglo jpjglo' 513 527 WRITE(inum,'(6i8)') jpnij,jpi,jpj,jpk,jpiglo,jpjglo 514 528 WRITE(inum,'(a)') 'NAREA nlci nlcj nldi nldj nlei nlej nimpp njmpp' … … 523 537 END IF 524 538 525 IF( nperio == 1 .AND.jpni /= 1 ) CALL ctl_stop( ' mpp_init2: error on cyclicity' )526 527 ! Prepare mpp north fold528 529 IF( jperio >= 3 .AND. jperio <= 6 .AND. jpni > 1 ) THEN530 CALL mpp_ini_north531 IF(lwp) WRITE(numout,*) ' mpp_init2 : North fold boundary prepared for jpni >1'532 ENDIF533 534 539 ! Defined npolj, either 0, 3 , 4 , 5 , 6 535 540 ! In this case the important thing is that npolj /= 0 … … 548 553 ENDIF 549 554 555 ! Periodicity : no corner if nbondi = 2 and nperio != 1 556 557 IF(lwp) THEN 558 WRITE(numout,*) ' nproc = ', nproc 559 WRITE(numout,*) ' nowe = ', nowe , ' noea = ', noea 560 WRITE(numout,*) ' nono = ', nono , ' noso = ', noso 561 WRITE(numout,*) ' nbondi = ', nbondi 562 WRITE(numout,*) ' nbondj = ', nbondj 563 WRITE(numout,*) ' npolj = ', npolj 564 WRITE(numout,*) ' nperio = ', nperio 565 WRITE(numout,*) ' nlci = ', nlci 566 WRITE(numout,*) ' nlcj = ', nlcj 567 WRITE(numout,*) ' nimpp = ', nimpp 568 WRITE(numout,*) ' njmpp = ', njmpp 569 WRITE(numout,*) ' nreci = ', nreci , ' npse = ', npse 570 WRITE(numout,*) ' nrecj = ', nrecj , ' npsw = ', npsw 571 WRITE(numout,*) ' jpreci = ', jpreci , ' npne = ', npne 572 WRITE(numout,*) ' jprecj = ', jprecj , ' npnw = ', npnw 573 WRITE(numout,*) 574 ENDIF 575 576 IF( nperio == 1 .AND. jpni /= 1 ) CALL ctl_stop( ' mpp_init2: error on cyclicity' ) 577 578 ! Prepare mpp north fold 579 580 IF( jperio >= 3 .AND. jperio <= 6 .AND. jpni > 1 ) THEN 581 CALL mpp_ini_north 582 IF(lwp) WRITE(numout,*) ' mpp_init2 : North fold boundary prepared for jpni >1' 583 ENDIF 584 550 585 ! Prepare NetCDF output file (if necessary) 551 586 CALL mpp_init_ioipsl 552 587 553 ! Periodicity : no corner if nbondi = 2 and nperio != 1554 555 IF(lwp) THEN556 WRITE(numout,*) ' nproc= ',nproc557 WRITE(numout,*) ' nowe= ',nowe558 WRITE(numout,*) ' noea= ',noea559 WRITE(numout,*) ' nono= ',nono560 WRITE(numout,*) ' noso= ',noso561 WRITE(numout,*) ' nbondi= ',nbondi562 WRITE(numout,*) ' nbondj= ',nbondj563 WRITE(numout,*) ' npolj= ',npolj564 WRITE(numout,*) ' nperio= ',nperio565 WRITE(numout,*) ' nlci= ',nlci566 WRITE(numout,*) ' nlcj= ',nlcj567 WRITE(numout,*) ' nimpp= ',nimpp568 WRITE(numout,*) ' njmpp= ',njmpp569 WRITE(numout,*) ' nbse= ',nbse,' npse= ',npse570 WRITE(numout,*) ' nbsw= ',nbsw,' npsw= ',npsw571 WRITE(numout,*) ' nbne= ',nbne,' npne= ',npne572 WRITE(numout,*) ' nbnw= ',nbnw,' npnw= ',npnw573 ENDIF574 588 575 589 END SUBROUTINE mpp_init2 -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/LDF/ldfeiv.F90
r6836 r6839 157 157 END DO 158 158 ENDIF 159 160 ! ORCA R1: Take the minimum between aeiw and aeiv0 161 IF( cp_cfg == "orca" .AND. jp_cfg == 1 ) THEN 162 DO jj = 2, jpjm1 163 DO ji = fs_2, fs_jpim1 ! vector opt. 164 aeiw(ji,jj) = MIN( aeiw(ji,jj), aeiv0 ) 165 END DO 166 END DO 167 ENDIF 168 159 169 CALL lbc_lnk( aeiw, 'W', 1. ) ! lateral boundary condition on aeiw 160 170 -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/LDF/ldfslp.F90
r6836 r6839 188 188 DO jj = 2, jpjm1 189 189 DO ji = fs_2, fs_jpim1 ! vector opt. 190 IF (miku(ji,jj) .GT. miku(ji+1,jj)) zhmlpu(ji,jj) = MAX(hmlpt(ji ,jj ), 5._wp) 191 IF (miku(ji,jj) .LT. miku(ji+1,jj)) zhmlpu(ji,jj) = MAX(hmlpt(ji+1,jj ), 5._wp) 192 IF (miku(ji,jj) .EQ. miku(ji+1,jj)) zhmlpu(ji,jj) = MAX(hmlpt(ji ,jj ), hmlpt(ji+1,jj ), 5._wp) 193 IF (mikv(ji,jj) .GT. miku(ji,jj+1)) zhmlpv(ji,jj) = MAX(hmlpt(ji ,jj ), 5._wp) 194 IF (mikv(ji,jj) .LT. miku(ji,jj+1)) zhmlpv(ji,jj) = MAX(hmlpt(ji ,jj+1), 5._wp) 195 IF (mikv(ji,jj) .EQ. miku(ji,jj+1)) zhmlpv(ji,jj) = MAX(hmlpt(ji ,jj ), hmlpt(ji ,jj+1), 5._wp) 190 zhmlpu(ji,jj) = ( MAX(hmlpt(ji,jj) , hmlpt (ji+1,jj ), 5._wp) & 191 & - MAX(risfdep(ji,jj), risfdep(ji+1,jj ) ) ) 192 zhmlpv(ji,jj) = ( MAX(hmlpt (ji,jj), hmlpt (ji ,jj+1), 5._wp) & 193 & - MAX(risfdep(ji,jj), risfdep(ji ,jj+1) ) ) 196 194 ENDDO 197 195 ENDDO -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/LDF/ldftra_oce.F90
r6836 r6839 41 41 42 42 REAL(wp), PUBLIC :: rldf !: multiplicative factor of diffusive coefficient 43 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: r_fact_lap 43 44 !: Needed to define the ratio between passive and active tracer diffusion coef. 44 45 … … 92 93 !! *** FUNCTION ldftra_oce_alloc *** 93 94 !!---------------------------------------------------------------------- 94 INTEGER, DIMENSION( 3) :: ierr95 INTEGER, DIMENSION(4) :: ierr 95 96 !!---------------------------------------------------------------------- 96 97 ierr(:) = 0 … … 116 117 # endif 117 118 #endif 119 ALLOCATE( r_fact_lap(jpi,jpj,jpk), STAT=ierr(4) ) 118 120 ldftra_oce_alloc = MAXVAL( ierr ) 119 121 IF( ldftra_oce_alloc /= 0 ) CALL ctl_warn('ldftra_oce_alloc: failed to allocate arrays') -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/LDF/ldftra_substitute.h90
r6836 r6839 13 13 ! 'key_traldf_c3d' : aht: 3D coefficient 14 14 # define fsahtt(i,j,k) rldf * ahtt(i,j,k) 15 # define fsahtu(i,j,k) rldf * ahtu(i,j,k) 15 # define fsahtu(i,j,k) rldf * ahtu(i,j,k) * r_fact_lap(i,j,k) 16 16 # define fsahtv(i,j,k) rldf * ahtv(i,j,k) 17 17 # define fsahtw(i,j,k) rldf * ahtw(i,j,k) … … 19 19 ! 'key_traldf_c2d' : aht: 2D coefficient 20 20 # define fsahtt(i,j,k) rldf * ahtt(i,j) 21 # define fsahtu(i,j,k) rldf * ahtu(i,j) 21 # define fsahtu(i,j,k) rldf * ahtu(i,j) * r_fact_lap(i,j,k) 22 22 # define fsahtv(i,j,k) rldf * ahtv(i,j) 23 23 # define fsahtw(i,j,k) rldf * ahtw(i,j) … … 25 25 ! 'key_traldf_c1d' : aht: 1D coefficient 26 26 # define fsahtt(i,j,k) rldf * ahtt(k) 27 # define fsahtu(i,j,k) rldf * ahtu(k) 27 # define fsahtu(i,j,k) rldf * ahtu(k) * r_fact_lap(i,j,k) 28 28 # define fsahtv(i,j,k) rldf * ahtv(k) 29 29 # define fsahtw(i,j,k) rldf * ahtw(k) … … 31 31 ! Default option : aht: Constant coefficient 32 32 # define fsahtt(i,j,k) rldf * aht0 33 # define fsahtu(i,j,k) rldf * aht0 33 # define fsahtu(i,j,k) rldf * aht0 * r_fact_lap(i,j,k) 34 34 # define fsahtv(i,j,k) rldf * aht0 35 35 # define fsahtw(i,j,k) rldf * aht0 -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/SBC/albedo.F90
r6836 r6839 9 9 !! - ! 2001-06 (M. Vancoppenolle) LIM 3.0 10 10 !! - ! 2006-08 (G. Madec) cleaning for surface module 11 !! 3.6 ! 2016-01 (C. Rousset) new parameterization for sea ice albedo 11 12 !!---------------------------------------------------------------------- 12 13 … … 29 30 30 31 INTEGER :: albd_init = 0 !: control flag for initialization 31 REAL(wp) :: zzero = 0.e0 ! constant values32 REAL(wp) :: zone = 1.e0 ! " "33 34 REAL(wp) :: c1 = 0.05 ! constants values35 REAL(wp) :: c2 = 0.10 !" "36 REAL(wp) :: r mue = 0.40 ! cosine of local solar altitude37 32 33 REAL(wp) :: rmue = 0.40 ! cosine of local solar altitude 34 REAL(wp) :: ralb_oce = 0.066 ! ocean or lead albedo (Pegau and Paulson, Ann. Glac. 2001) 35 REAL(wp) :: c1 = 0.05 ! snow thickness (only for nn_ice_alb=0) 36 REAL(wp) :: c2 = 0.10 ! " " 37 REAL(wp) :: rcloud = 0.06 ! cloud effect on albedo (only-for nn_ice_alb=0) 38 38 39 ! !!* namelist namsbc_alb 39 REAL(wp) :: rn_cloud ! cloudiness effect on snow or ice albedo (Grenfell & Perovich, 1984) 40 #if defined key_lim3 41 REAL(wp) :: rn_albice ! albedo of melting ice in the arctic and antarctic (Shine & Hendersson-Sellers) 42 #else 43 REAL(wp) :: rn_albice ! albedo of melting ice in the arctic and antarctic (Shine & Hendersson-Sellers) 44 #endif 45 REAL(wp) :: rn_alphd ! coefficients for linear interpolation used to compute 46 REAL(wp) :: rn_alphdi ! albedo between two extremes values (Pyane, 1972) 47 REAL(wp) :: rn_alphc ! 40 INTEGER :: nn_ice_alb 41 REAL(wp) :: rn_albice 48 42 49 43 !!---------------------------------------------------------------------- … … 59 53 !! 60 54 !! ** Purpose : Computation of the albedo of the snow/ice system 61 !! as well as the ocean one62 55 !! 63 !! ** Method : - Computation of the albedo of snow or ice (choose the 64 !! rignt one by a large number of tests 65 !! - Computation of the albedo of the ocean 66 !! 67 !! References : Shine and Hendersson-Sellers 1985, JGR, 90(D1), 2243-2250. 56 !! ** Method : Two schemes are available (from namelist parameter nn_ice_alb) 57 !! 0: the scheme is that of Shine & Henderson-Sellers (JGR 1985) for clear-skies 58 !! 1: the scheme is "home made" (for cloudy skies) and based on Brandt et al. (J. Climate 2005) 59 !! and Grenfell & Perovich (JGR 2004) 60 !! Description of scheme 1: 61 !! 1) Albedo dependency on ice thickness follows the findings from Brandt et al (2005) 62 !! which are an update of Allison et al. (JGR 1993) ; Brandt et al. 1999 63 !! 0-5cm : linear function of ice thickness 64 !! 5-150cm: log function of ice thickness 65 !! > 150cm: constant 66 !! 2) Albedo dependency on snow thickness follows the findings from Grenfell & Perovich (2004) 67 !! i.e. it increases as -EXP(-snw_thick/0.02) during freezing and -EXP(-snw_thick/0.03) during melting 68 !! 3) Albedo dependency on clouds is speculated from measurements of Grenfell and Perovich (2004) 69 !! i.e. cloudy-clear albedo depend on cloudy albedo following a 2d order polynomial law 70 !! 4) The needed 4 parameters are: dry and melting snow, freezing ice and bare puddled ice 71 !! 72 !! ** Note : The parameterization from Shine & Henderson-Sellers presents several misconstructions: 73 !! 1) ice albedo when ice thick. tends to 0 is different than ocean albedo 74 !! 2) for small ice thick. covered with some snow (<3cm?), albedo is larger 75 !! under melting conditions than under freezing conditions 76 !! 3) the evolution of ice albedo as a function of ice thickness shows 77 !! 3 sharp inflexion points (at 5cm, 100cm and 150cm) that look highly unrealistic 78 !! 79 !! References : Shine & Henderson-Sellers 1985, JGR, 90(D1), 2243-2250. 80 !! Brandt et al. 2005, J. Climate, vol 18 81 !! Grenfell & Perovich 2004, JGR, vol 109 68 82 !!---------------------------------------------------------------------- 69 83 REAL(wp), INTENT(in ), DIMENSION(:,:,:) :: pt_ice ! ice surface temperature (Kelvin) … … 73 87 REAL(wp), INTENT( out), DIMENSION(:,:,:) :: pa_ice_os ! albedo of ice under overcast sky 74 88 !! 75 INTEGER :: ji, jj, jl ! dummy loop indices 76 INTEGER :: ijpl ! number of ice categories (3rd dim of ice input arrays) 77 REAL(wp) :: zalbpsnm ! albedo of ice under clear sky when snow is melting 78 REAL(wp) :: zalbpsnf ! albedo of ice under clear sky when snow is freezing 79 REAL(wp) :: zalbpsn ! albedo of snow/ice system when ice is coverd by snow 80 REAL(wp) :: zalbpic ! albedo of snow/ice system when ice is free of snow 81 REAL(wp) :: zithsn ! = 1 for hsn >= 0 ( ice is cov. by snow ) ; = 0 otherwise (ice is free of snow) 82 REAL(wp) :: zitmlsn ! = 1 freezinz snow (pt_ice >=rt0_snow) ; = 0 melting snow (pt_ice<rt0_snow) 83 REAL(wp) :: zihsc1 ! = 1 hsn <= c1 ; = 0 hsn > c1 84 REAL(wp) :: zihsc2 ! = 1 hsn >= c2 ; = 0 hsn < c2 85 !! 86 REAL(wp), POINTER, DIMENSION(:,:,:) :: zalbfz ! = rn_alphdi for freezing ice ; = rn_albice for melting ice 87 REAL(wp), POINTER, DIMENSION(:,:,:) :: zficeth ! function of ice thickness 89 INTEGER :: ji, jj, jl ! dummy loop indices 90 INTEGER :: ijpl ! number of ice categories (3rd dim of ice input arrays) 91 REAL(wp) :: ralb_im, ralb_sf, ralb_sm, ralb_if 92 REAL(wp) :: zswitch, z1_c1, z1_c2 93 REAL(wp) :: zalb_sm, zalb_sf, zalb_st ! albedo of snow melting, freezing, total 94 REAL(wp), POINTER, DIMENSION(:,:,:) :: zalb, zalb_it ! intermediate variable & albedo of ice (snow free) 88 95 !!--------------------------------------------------------------------- 89 96 90 97 ijpl = SIZE( pt_ice, 3 ) ! number of ice categories 91 92 CALL wrk_alloc( jpi,jpj,ijpl, zalb fz, zficeth)98 99 CALL wrk_alloc( jpi,jpj,ijpl, zalb, zalb_it ) 93 100 94 101 IF( albd_init == 0 ) CALL albedo_init ! initialization 95 102 96 !--------------------------- 97 ! Computation of zficeth 98 !--------------------------- 99 ! ice free of snow and melts 100 WHERE ( ph_snw == 0._wp .AND. pt_ice >= rt0_ice ) ; zalbfz(:,:,:) = rn_albice 101 ELSE WHERE ; zalbfz(:,:,:) = rn_alphdi 102 END WHERE 103 104 WHERE ( 1.5 < ph_ice ) ; zficeth = zalbfz 105 ELSE WHERE( 1.0 < ph_ice .AND. ph_ice <= 1.5 ) ; zficeth = 0.472 + 2.0 * ( zalbfz - 0.472 ) * ( ph_ice - 1.0 ) 106 ELSE WHERE( 0.05 < ph_ice .AND. ph_ice <= 1.0 ) ; zficeth = 0.2467 + 0.7049 * ph_ice & 107 & - 0.8608 * ph_ice * ph_ice & 108 & + 0.3812 * ph_ice * ph_ice * ph_ice 109 ELSE WHERE ; zficeth = 0.1 + 3.6 * ph_ice 110 END WHERE 111 112 !!gm old code 113 ! DO jl = 1, ijpl 114 ! DO jj = 1, jpj 115 ! DO ji = 1, jpi 116 ! IF( ph_ice(ji,jj,jl) > 1.5 ) THEN 117 ! zficeth(ji,jj,jl) = zalbfz(ji,jj,jl) 118 ! ELSEIF( ph_ice(ji,jj,jl) > 1.0 .AND. ph_ice(ji,jj,jl) <= 1.5 ) THEN 119 ! zficeth(ji,jj,jl) = 0.472 + 2.0 * ( zalbfz(ji,jj,jl) - 0.472 ) * ( ph_ice(ji,jj,jl) - 1.0 ) 120 ! ELSEIF( ph_ice(ji,jj,jl) > 0.05 .AND. ph_ice(ji,jj,jl) <= 1.0 ) THEN 121 ! zficeth(ji,jj,jl) = 0.2467 + 0.7049 * ph_ice(ji,jj,jl) & 122 ! & - 0.8608 * ph_ice(ji,jj,jl) * ph_ice(ji,jj,jl) & 123 ! & + 0.3812 * ph_ice(ji,jj,jl) * ph_ice(ji,jj,jl) * ph_ice (ji,jj,jl) 124 ! ELSE 125 ! zficeth(ji,jj,jl) = 0.1 + 3.6 * ph_ice(ji,jj,jl) 126 ! ENDIF 127 ! END DO 128 ! END DO 129 ! END DO 130 !!gm end old code 131 132 !----------------------------------------------- 133 ! Computation of the snow/ice albedo system 134 !-------------------------- --------------------- 135 136 ! Albedo of snow-ice for clear sky. 137 !----------------------------------------------- 138 DO jl = 1, ijpl 139 DO jj = 1, jpj 140 DO ji = 1, jpi 141 ! Case of ice covered by snow. 142 ! ! freezing snow 143 zihsc1 = 1.0 - MAX( zzero , SIGN( zone , - ( ph_snw(ji,jj,jl) - c1 ) ) ) 144 zalbpsnf = ( 1.0 - zihsc1 ) * ( zficeth(ji,jj,jl) & 145 & + ph_snw(ji,jj,jl) * ( rn_alphd - zficeth(ji,jj,jl) ) / c1 ) & 146 & + zihsc1 * rn_alphd 147 ! ! melting snow 148 zihsc2 = MAX( zzero , SIGN( zone , ph_snw(ji,jj,jl) - c2 ) ) 149 zalbpsnm = ( 1.0 - zihsc2 ) * ( rn_albice + ph_snw(ji,jj,jl) * ( rn_alphc - rn_albice ) / c2 ) & 150 & + zihsc2 * rn_alphc 151 ! 152 zitmlsn = MAX( zzero , SIGN( zone , pt_ice(ji,jj,jl) - rt0_snow ) ) 153 zalbpsn = zitmlsn * zalbpsnm + ( 1.0 - zitmlsn ) * zalbpsnf 154 155 ! Case of ice free of snow. 156 zalbpic = zficeth(ji,jj,jl) 157 158 ! albedo of the system 159 zithsn = 1.0 - MAX( zzero , SIGN( zone , - ph_snw(ji,jj,jl) ) ) 160 pa_ice_cs(ji,jj,jl) = zithsn * zalbpsn + ( 1.0 - zithsn ) * zalbpic 103 104 SELECT CASE ( nn_ice_alb ) 105 106 !------------------------------------------ 107 ! Shine and Henderson-Sellers (1985) 108 !------------------------------------------ 109 CASE( 0 ) 110 111 ralb_sf = 0.80 ! dry snow 112 ralb_sm = 0.65 ! melting snow 113 ralb_if = 0.72 ! bare frozen ice 114 ralb_im = rn_albice ! bare puddled ice 115 116 ! Computation of ice albedo (free of snow) 117 WHERE ( ph_snw == 0._wp .AND. pt_ice >= rt0_ice ) ; zalb(:,:,:) = ralb_im 118 ELSE WHERE ; zalb(:,:,:) = ralb_if 119 END WHERE 120 121 WHERE ( 1.5 < ph_ice ) ; zalb_it = zalb 122 ELSE WHERE( 1.0 < ph_ice .AND. ph_ice <= 1.5 ) ; zalb_it = 0.472 + 2.0 * ( zalb - 0.472 ) * ( ph_ice - 1.0 ) 123 ELSE WHERE( 0.05 < ph_ice .AND. ph_ice <= 1.0 ) ; zalb_it = 0.2467 + 0.7049 * ph_ice & 124 & - 0.8608 * ph_ice * ph_ice & 125 & + 0.3812 * ph_ice * ph_ice * ph_ice 126 ELSE WHERE ; zalb_it = 0.1 + 3.6 * ph_ice 127 END WHERE 128 129 DO jl = 1, ijpl 130 DO jj = 1, jpj 131 DO ji = 1, jpi 132 ! freezing snow 133 ! no effect of underlying ice layer IF snow thickness > c1. Albedo does not depend on snow thick if > c2 134 ! ! freezing snow 135 zswitch = 1._wp - MAX( 0._wp , SIGN( 1._wp , - ( ph_snw(ji,jj,jl) - c1 ) ) ) 136 zalb_sf = ( 1._wp - zswitch ) * ( zalb_it(ji,jj,jl) & 137 & + ph_snw(ji,jj,jl) * ( ralb_sf - zalb_it(ji,jj,jl) ) / c1 ) & 138 & + zswitch * ralb_sf 139 140 ! melting snow 141 ! no effect of underlying ice layer. Albedo does not depend on snow thick IF > c2 142 zswitch = MAX( 0._wp , SIGN( 1._wp , ph_snw(ji,jj,jl) - c2 ) ) 143 zalb_sm = ( 1._wp - zswitch ) * ( ralb_im + ph_snw(ji,jj,jl) * ( ralb_sm - ralb_im ) / c2 ) & 144 & + zswitch * ralb_sm 145 ! 146 ! snow albedo 147 zswitch = MAX( 0._wp , SIGN( 1._wp , pt_ice(ji,jj,jl) - rt0_snow ) ) 148 zalb_st = zswitch * zalb_sm + ( 1._wp - zswitch ) * zalb_sf 149 150 ! Ice/snow albedo 151 zswitch = 1._wp - MAX( 0._wp , SIGN( 1._wp , - ph_snw(ji,jj,jl) ) ) 152 pa_ice_cs(ji,jj,jl) = zswitch * zalb_st + ( 1._wp - zswitch ) * zalb_it(ji,jj,jl) 153 ! 154 END DO 161 155 END DO 162 156 END DO 163 END DO 164 165 ! Albedo of snow-ice for overcast sky. 166 !---------------------------------------------- 167 pa_ice_os(:,:,:) = pa_ice_cs(:,:,:) + rn_cloud ! Oberhuber correction 168 ! 169 CALL wrk_dealloc( jpi,jpj,ijpl, zalbfz, zficeth ) 157 158 pa_ice_os(:,:,:) = pa_ice_cs(:,:,:) + rcloud ! Oberhuber correction for overcast sky 159 160 !------------------------------------------ 161 ! New parameterization (2016) 162 !------------------------------------------ 163 CASE( 1 ) 164 165 ralb_im = rn_albice ! bare puddled ice 166 ! compilation of values from literature 167 ralb_sf = 0.85 ! dry snow 168 ralb_sm = 0.75 ! melting snow 169 ralb_if = 0.60 ! bare frozen ice 170 ! Perovich et al 2002 (Sheba) => the only dataset for which all types of ice/snow were retrieved 171 ! ralb_sf = 0.85 ! dry snow 172 ! ralb_sm = 0.72 ! melting snow 173 ! ralb_if = 0.65 ! bare frozen ice 174 ! Brandt et al 2005 (East Antarctica) 175 ! ralb_sf = 0.87 ! dry snow 176 ! ralb_sm = 0.82 ! melting snow 177 ! ralb_if = 0.54 ! bare frozen ice 178 ! 179 ! Computation of ice albedo (free of snow) 180 z1_c1 = 1. / ( LOG(1.5) - LOG(0.05) ) 181 z1_c2 = 1. / 0.05 182 WHERE ( ph_snw == 0._wp .AND. pt_ice >= rt0_ice ) ; zalb = ralb_im 183 ELSE WHERE ; zalb = ralb_if 184 END WHERE 185 186 WHERE ( 1.5 < ph_ice ) ; zalb_it = zalb 187 ELSE WHERE( 0.05 < ph_ice .AND. ph_ice <= 1.5 ) ; zalb_it = zalb + ( 0.18 - zalb ) * z1_c1 * & 188 & ( LOG(1.5) - LOG(ph_ice) ) 189 ELSE WHERE ; zalb_it = ralb_oce + ( 0.18 - ralb_oce ) * z1_c2 * ph_ice 190 END WHERE 191 192 z1_c1 = 1. / 0.02 193 z1_c2 = 1. / 0.03 194 ! Computation of the snow/ice albedo 195 DO jl = 1, ijpl 196 DO jj = 1, jpj 197 DO ji = 1, jpi 198 zalb_sf = ralb_sf - ( ralb_sf - zalb_it(ji,jj,jl)) * EXP( - ph_snw(ji,jj,jl) * z1_c1 ); 199 zalb_sm = ralb_sm - ( ralb_sm - zalb_it(ji,jj,jl)) * EXP( - ph_snw(ji,jj,jl) * z1_c2 ); 200 201 ! snow albedo 202 zswitch = MAX( 0._wp , SIGN( 1._wp , pt_ice(ji,jj,jl) - rt0_snow ) ) 203 zalb_st = zswitch * zalb_sm + ( 1._wp - zswitch ) * zalb_sf 204 205 ! Ice/snow albedo 206 zswitch = MAX( 0._wp , SIGN( 1._wp , - ph_snw(ji,jj,jl) ) ) 207 pa_ice_os(ji,jj,jl) = ( 1._wp - zswitch ) * zalb_st + zswitch * zalb_it(ji,jj,jl) 208 209 END DO 210 END DO 211 END DO 212 ! Effect of the clouds (2d order polynomial) 213 pa_ice_cs = pa_ice_os - ( - 0.1010 * pa_ice_os * pa_ice_os + 0.1933 * pa_ice_os - 0.0148 ); 214 215 END SELECT 216 217 CALL wrk_dealloc( jpi,jpj,ijpl, zalb, zalb_it ) 170 218 ! 171 219 END SUBROUTINE albedo_ice … … 181 229 REAL(wp), DIMENSION(:,:), INTENT(out) :: pa_oce_cs ! albedo of ocean under clear sky 182 230 !! 183 REAL(wp) :: zcoef ! local scalar184 !!---------------------------------------------------------------------- 185 ! 186 zcoef = 0.05 / ( 1.1 * rmue**1.4 + 0.15 ) ! Parameterization of Briegled and Ramanathan, 1982187 pa_oce_cs(:,:) = zcoef 188 pa_oce_os(:,:) = 0.06! Parameterization of Kondratyev, 1969 and Payne, 1972231 REAL(wp) :: zcoef 232 !!---------------------------------------------------------------------- 233 ! 234 zcoef = 0.05 / ( 1.1 * rmue**1.4 + 0.15 ) ! Parameterization of Briegled and Ramanathan, 1982 235 pa_oce_cs(:,:) = zcoef 236 pa_oce_os(:,:) = 0.06 ! Parameterization of Kondratyev, 1969 and Payne, 1972 189 237 ! 190 238 END SUBROUTINE albedo_oce … … 200 248 !!---------------------------------------------------------------------- 201 249 INTEGER :: ios ! Local integer output status for namelist read 202 NAMELIST/namsbc_alb/ rn_cloud, rn_albice, rn_alphd, rn_alphdi, rn_alphc250 NAMELIST/namsbc_alb/ nn_ice_alb, rn_albice 203 251 !!---------------------------------------------------------------------- 204 252 ! … … 219 267 WRITE(numout,*) '~~~~~~~' 220 268 WRITE(numout,*) ' Namelist namsbc_alb : albedo ' 221 WRITE(numout,*) ' correction for snow and ice albedo rn_cloud = ', rn_cloud 222 WRITE(numout,*) ' albedo of melting ice in the arctic and antarctic rn_albice = ', rn_albice 223 WRITE(numout,*) ' coefficients for linear rn_alphd = ', rn_alphd 224 WRITE(numout,*) ' interpolation used to compute albedo rn_alphdi = ', rn_alphdi 225 WRITE(numout,*) ' between two extremes values (Pyane, 1972) rn_alphc = ', rn_alphc 269 WRITE(numout,*) ' choose the albedo parameterization nn_ice_alb = ', nn_ice_alb 270 WRITE(numout,*) ' albedo of bare puddled ice rn_albice = ', rn_albice 226 271 ENDIF 227 272 ! -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/SBC/fldread.F90
r6836 r6839 32 32 PUBLIC fld_map ! routine called by tides_init 33 33 PUBLIC fld_read, fld_fill ! called by sbc... modules 34 PUBLIC fld_clopn 34 35 35 36 TYPE, PUBLIC :: FLD_N !: Namelist field informations … … 815 816 imonth = kmonth 816 817 iday = kday 818 IF ( sdjf%cltype(1:4) == 'week' ) THEN ! find the day of the beginning of the week 819 isec_week = ksec_week( sdjf%cltype(6:8) )- (86400 * 8 ) 820 llprevmth = isec_week > nsec_month ! longer time since beginning of the week than the month 821 llprevyr = llprevmth .AND. nmonth == 1 822 iyear = nyear - COUNT((/llprevyr /)) 823 imonth = nmonth - COUNT((/llprevmth/)) + 12 * COUNT((/llprevyr /)) 824 iday = nday + nmonth_len(nmonth-1) * COUNT((/llprevmth/)) - isec_week / NINT(rday) 825 ENDIF 817 826 ELSE ! use current day values 818 827 IF ( sdjf%cltype(1:4) == 'week' ) THEN ! find the day of the beginning of the week … … 1281 1290 CHARACTER(LEN=*) , INTENT(in ) :: lsmfile ! land sea mask file name 1282 1291 !! 1283 REAL(wp),DIMENSION(:,:,:),ALLOCATABLE :: ztmp_fly_dta ,zfieldo! temporary array of values on input grid1292 REAL(wp),DIMENSION(:,:,:),ALLOCATABLE :: ztmp_fly_dta ! temporary array of values on input grid 1284 1293 INTEGER, DIMENSION(3) :: rec1,recn ! temporary arrays for start and length 1285 1294 INTEGER, DIMENSION(3) :: rec1_lsm,recn_lsm ! temporary arrays for start and length in case of seaoverland … … 1347 1356 1348 1357 1349 itmpi= SIZE(ztmp_fly_dta(jpi1_lsm:jpi2_lsm,jpj1_lsm:jpj2_lsm,:),1)1350 itmpj= SIZE(ztmp_fly_dta(jpi1_lsm:jpi2_lsm,jpj1_lsm:jpj2_lsm,:),2)1358 itmpi=jpi2_lsm-jpi1_lsm+1 1359 itmpj=jpj2_lsm-jpj1_lsm+1 1351 1360 itmpz=kk 1352 1361 ALLOCATE(ztmp_fly_dta(itmpi,itmpj,itmpz)) -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/SBC/sbc_ice.F90
r6836 r6839 80 80 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qemp_oce !: heat flux of precip and evap over ocean [W/m2] 81 81 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qemp_ice !: heat flux of precip and evap over ice [W/m2] 82 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qprec_ice !: heat flux of precip over ice [J/m3] 82 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: qevap_ice !: heat flux of evap over ice [W/m2] 83 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qprec_ice !: enthalpy of precip over ice [J/m3] 83 84 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: emp_oce !: evap - precip over ocean [kg/m2/s] 84 85 #endif … … 144 145 #endif 145 146 #if defined key_lim3 146 & evap_ice(jpi,jpj,jpl) , devap_ice(jpi,jpj,jpl) , qprec_ice(jpi,jpj) , &147 & qemp_ice(jpi,jpj) , qe mp_oce(jpi,jpj) ,&148 & qns_oce (jpi,jpj) , qsr_oce (jpi,jpj) , emp_oce (jpi,jpj) ,&147 & evap_ice(jpi,jpj,jpl) , devap_ice(jpi,jpj,jpl) , qprec_ice(jpi,jpj) , & 148 & qemp_ice(jpi,jpj) , qevap_ice(jpi,jpj,jpl) , qemp_oce (jpi,jpj) , & 149 & qns_oce (jpi,jpj) , qsr_oce (jpi,jpj) , emp_oce (jpi,jpj) , & 149 150 #endif 150 151 & emp_ice(jpi,jpj) , STAT= ierr(1) ) -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/SBC/sbcblk_clio.F90
r6836 r6839 684 684 qprec_ice(:,:) = rhosn * ( ( MIN( sf(jp_tair)%fnow(:,:,1), rt0_snow ) - rt0 ) * cpic * tmask(:,:,1) - lfus ) 685 685 686 ! --- heat content of evap over ice in W/m2 (to be used in 1D-thermo) --- ! 687 DO jl = 1, jpl 688 qevap_ice(:,:,jl) = 0._wp ! should be -evap_ice(:,:,jl)*( ( Tice - rt0 ) * cpic * tmask(:,:,1) - lfus ) 689 ! but then qemp_ice should also include sublimation 690 END DO 691 686 692 CALL wrk_dealloc( jpi,jpj, zevap, zsnw ) 687 693 #endif -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/SBC/sbcblk_core.F90
r6836 r6839 403 403 CALL iom_put( "qsr_oce" , qsr ) ! output downward solar heat over the ocean 404 404 CALL iom_put( "qt_oce" , qns+qsr ) ! output total downward heat over the ocean 405 tprecip(:,:) = sf(jp_prec)%fnow(:,:,1) * rn_pfac ! output total precipitation [kg/m2/s] 406 sprecip(:,:) = sf(jp_snow)%fnow(:,:,1) * rn_pfac ! output solid precipitation [kg/m2/s] 407 CALL iom_put( 'snowpre', sprecip * 86400. ) ! Snow 408 CALL iom_put( 'precip' , tprecip * 86400. ) ! Total precipitation 405 409 ENDIF 406 410 ! … … 608 612 ! --- evaporation --- ! 609 613 z1_lsub = 1._wp / Lsub 610 evap_ice (:,:,:) = qla_ice (:,:,:) * z1_lsub! sublimation611 devap_ice(:,:,:) = dqla_ice(:,:,:) * z1_lsub612 zevap (:,:) = emp(:,:) + tprecip(:,:)! evaporation over ocean614 evap_ice (:,:,:) = rn_efac * qla_ice (:,:,:) * z1_lsub ! sublimation 615 devap_ice(:,:,:) = rn_efac * dqla_ice(:,:,:) * z1_lsub ! d(sublimation)/dT 616 zevap (:,:) = rn_efac * ( emp(:,:) + tprecip(:,:) ) ! evaporation over ocean 613 617 614 618 ! --- evaporation minus precipitation --- ! … … 633 637 ! --- heat content of precip over ice in J/m3 (to be used in 1D-thermo) --- ! 634 638 qprec_ice(:,:) = rhosn * ( ( MIN( sf(jp_tair)%fnow(:,:,1), rt0_snow ) - rt0 ) * cpic * tmask(:,:,1) - lfus ) 639 640 ! --- heat content of evap over ice in W/m2 (to be used in 1D-thermo) --- ! 641 DO jl = 1, jpl 642 qevap_ice(:,:,jl) = 0._wp ! should be -evap_ice(:,:,jl)*( ( Tice - rt0 ) * cpic * tmask(:,:,1) ) 643 ! But we do not have Tice => consider it at 0°C => evap=0 644 END DO 635 645 636 646 CALL wrk_dealloc( jpi,jpj, zevap, zsnw ) -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/SBC/sbccpl.F90
r6836 r6839 1029 1029 ssu_m(:,:) = frcv(jpr_ocx1)%z3(:,:,1) 1030 1030 ub (:,:,1) = ssu_m(:,:) ! will be used in sbcice_lim in the call of lim_sbc_tau 1031 un (:,:,1) = ssu_m(:,:) ! will be used in sbc_cpl_snd if atmosphere coupling 1031 1032 CALL iom_put( 'ssu_m', ssu_m ) 1032 1033 ENDIF … … 1034 1035 ssv_m(:,:) = frcv(jpr_ocy1)%z3(:,:,1) 1035 1036 vb (:,:,1) = ssv_m(:,:) ! will be used in sbcice_lim in the call of lim_sbc_tau 1037 vn (:,:,1) = ssv_m(:,:) ! will be used in sbc_cpl_snd if atmosphere coupling 1036 1038 CALL iom_put( 'ssv_m', ssv_m ) 1037 1039 ENDIF … … 1333 1335 !! *** ROUTINE sbc_cpl_ice_flx *** 1334 1336 !! 1335 !! ** Purpose : provide the heat and freshwater fluxes of the 1336 !! ocean-ice system. 1337 !! ** Purpose : provide the heat and freshwater fluxes of the ocean-ice system 1337 1338 !! 1338 1339 !! ** Method : transform the fields received from the atmosphere into 1339 1340 !! surface heat and fresh water boundary condition for the 1340 1341 !! ice-ocean system. The following fields are provided: 1341 !! * total non solar, solar and freshwater fluxes (qns_tot,1342 !! * total non solar, solar and freshwater fluxes (qns_tot, 1342 1343 !! qsr_tot and emp_tot) (total means weighted ice-ocean flux) 1343 1344 !! NB: emp_tot include runoffs and calving. 1344 !! * fluxes over ice (qns_ice, qsr_ice, emp_ice) where1345 !! * fluxes over ice (qns_ice, qsr_ice, emp_ice) where 1345 1346 !! emp_ice = sublimation - solid precipitation as liquid 1346 1347 !! precipitation are re-routed directly to the ocean and 1347 !! runoffs and calving directly enter the ocean.1348 !! * solid precipitation (sprecip), used to add to qns_tot1348 !! calving directly enter the ocean (runoffs are read but included in trasbc.F90) 1349 !! * solid precipitation (sprecip), used to add to qns_tot 1349 1350 !! the heat lost associated to melting solid precipitation 1350 1351 !! over the ocean fraction. 1351 !! ===>> CAUTION here this changes the net heat flux received from 1352 !! the atmosphere 1353 !! 1354 !! - the fluxes have been separated from the stress as 1355 !! (a) they are updated at each ice time step compare to 1356 !! an update at each coupled time step for the stress, and 1357 !! (b) the conservative computation of the fluxes over the 1358 !! sea-ice area requires the knowledge of the ice fraction 1359 !! after the ice advection and before the ice thermodynamics, 1360 !! so that the stress is updated before the ice dynamics 1361 !! while the fluxes are updated after it. 1352 !! * heat content of rain, snow and evap can also be provided, 1353 !! otherwise heat flux associated with these mass flux are 1354 !! guessed (qemp_oce, qemp_ice) 1355 !! 1356 !! - the fluxes have been separated from the stress as 1357 !! (a) they are updated at each ice time step compare to 1358 !! an update at each coupled time step for the stress, and 1359 !! (b) the conservative computation of the fluxes over the 1360 !! sea-ice area requires the knowledge of the ice fraction 1361 !! after the ice advection and before the ice thermodynamics, 1362 !! so that the stress is updated before the ice dynamics 1363 !! while the fluxes are updated after it. 1364 !! 1365 !! ** Details 1366 !! qns_tot = pfrld * qns_oce + ( 1 - pfrld ) * qns_ice => provided 1367 !! + qemp_oce + qemp_ice => recalculated and added up to qns 1368 !! 1369 !! qsr_tot = pfrld * qsr_oce + ( 1 - pfrld ) * qsr_ice => provided 1370 !! 1371 !! emp_tot = emp_oce + emp_ice => calving is provided and added to emp_tot (and emp_oce) 1372 !! river runoff (rnf) is provided but not included here 1362 1373 !! 1363 1374 !! ** Action : update at each nf_ice time step: 1364 1375 !! qns_tot, qsr_tot non-solar and solar total heat fluxes 1365 1376 !! qns_ice, qsr_ice non-solar and solar heat fluxes over the ice 1366 !! emp_tot total evaporation - precipitation(liquid and solid) (-runoff)(-calving)1367 !! emp_ice 1368 !! dqns_ice 1369 !! sprecip 1377 !! emp_tot total evaporation - precipitation(liquid and solid) (-calving) 1378 !! emp_ice ice sublimation - solid precipitation over the ice 1379 !! dqns_ice d(non-solar heat flux)/d(Temperature) over the ice 1380 !! sprecip solid precipitation over the ocean 1370 1381 !!---------------------------------------------------------------------- 1371 1382 REAL(wp), INTENT(in ), DIMENSION(:,:) :: p_frld ! lead fraction [0 to 1] … … 1376 1387 ! 1377 1388 INTEGER :: jl ! dummy loop index 1378 REAL(wp), POINTER, DIMENSION(:,: ) :: zcptn, ztmp, zicefr, zmsk 1379 REAL(wp), POINTER, DIMENSION(:,: ) :: zemp_tot, zemp_ice, z sprecip, ztprecip, zqns_tot, zqsr_tot1380 REAL(wp), POINTER, DIMENSION(:,: ,:) :: zqns_ice, zqsr_ice, zdqns_ice1381 REAL(wp), POINTER, DIMENSION(:,: ) :: zevap, zsnw, zqns_oce, zqsr_oce, zqprec_ice, zqemp_oce ! for LIM31389 REAL(wp), POINTER, DIMENSION(:,: ) :: zcptn, ztmp, zicefr, zmsk, zsnw 1390 REAL(wp), POINTER, DIMENSION(:,: ) :: zemp_tot, zemp_ice, zemp_oce, ztprecip, zsprecip, zevap_oce, zevap_ice, zdevap_ice 1391 REAL(wp), POINTER, DIMENSION(:,: ) :: zqns_tot, zqns_oce, zqsr_tot, zqsr_oce, zqprec_ice, zqemp_oce, zqemp_ice 1392 REAL(wp), POINTER, DIMENSION(:,:,:) :: zqns_ice, zqsr_ice, zdqns_ice, zqevap_ice 1382 1393 !!---------------------------------------------------------------------- 1383 1394 ! 1384 1395 IF( nn_timing == 1 ) CALL timing_start('sbc_cpl_ice_flx') 1385 1396 ! 1386 CALL wrk_alloc( jpi,jpj, zcptn, ztmp, zicefr, zmsk, zemp_tot, zemp_ice, zsprecip, ztprecip, zqns_tot, zqsr_tot ) 1387 CALL wrk_alloc( jpi,jpj,jpl, zqns_ice, zqsr_ice, zdqns_ice ) 1397 CALL wrk_alloc( jpi,jpj, zcptn, ztmp, zicefr, zmsk, zsnw ) 1398 CALL wrk_alloc( jpi,jpj, zemp_tot, zemp_ice, zemp_oce, ztprecip, zsprecip, zevap_oce, zevap_ice, zdevap_ice ) 1399 CALL wrk_alloc( jpi,jpj, zqns_tot, zqns_oce, zqsr_tot, zqsr_oce, zqprec_ice, zqemp_oce, zqemp_ice ) 1400 CALL wrk_alloc( jpi,jpj,jpl, zqns_ice, zqsr_ice, zdqns_ice, zqevap_ice ) 1388 1401 1389 1402 IF( ln_mixcpl ) zmsk(:,:) = 1. - xcplmask(:,:,0) … … 1392 1405 ! 1393 1406 ! ! ========================= ! 1394 ! ! freshwater budget ! (emp )1407 ! ! freshwater budget ! (emp_tot) 1395 1408 ! ! ========================= ! 1396 1409 ! 1397 ! ! total Precipitation - total Evaporation (emp_tot)1398 ! ! solid precipitation - sublimation (emp_ice)1399 ! ! solid Precipitation (sprecip)1400 ! ! liquid + solid Precipitation (tprecip)1410 ! ! solid Precipitation (sprecip) 1411 ! ! liquid + solid Precipitation (tprecip) 1412 ! ! total Evaporation - total Precipitation (emp_tot) 1413 ! ! sublimation - solid precipitation (cell average) (emp_ice) 1401 1414 SELECT CASE( TRIM( sn_rcv_emp%cldes ) ) 1402 CASE( 'conservative' 1403 zsprecip(:,:) = frcv(jpr_snow)%z3(:,:,1) ! May need to ensure positive here1404 ztprecip(:,:) = frcv(jpr_rain)%z3(:,:,1) + zsprecip(:,:) ! May need to ensure positive here1405 zemp_tot(:,:) = frcv(jpr_tevp)%z3(:,:,1) - ztprecip(:,:)1406 zemp_ice(:,:) = frcv(jpr_ievp)%z3(:,:,1) - frcv(jpr_snow)%z3(:,:,1)1407 CALL iom_put( 'rain' , frcv(jpr_rain)%z3(:,:,1) )! liquid precipitation1415 CASE( 'conservative' ) ! received fields: jpr_rain, jpr_snow, jpr_ievp, jpr_tevp 1416 zsprecip(:,:) = frcv(jpr_snow)%z3(:,:,1) ! May need to ensure positive here 1417 ztprecip(:,:) = frcv(jpr_rain)%z3(:,:,1) + zsprecip(:,:) ! May need to ensure positive here 1418 zemp_tot(:,:) = frcv(jpr_tevp)%z3(:,:,1) - ztprecip(:,:) 1419 zemp_ice(:,:) = ( frcv(jpr_ievp)%z3(:,:,1) - frcv(jpr_snow)%z3(:,:,1) ) * zicefr(:,:) 1420 CALL iom_put( 'rain' , frcv(jpr_rain)%z3(:,:,1) ) ! liquid precipitation 1408 1421 IF( iom_use('hflx_rain_cea') ) & 1409 CALL iom_put( 'hflx_rain_cea', frcv(jpr_rain)%z3(:,:,1) * zcptn(:,:) ) ! heat flux from liq. precip. 1410 IF( iom_use('evap_ao_cea') .OR. iom_use('hflx_evap_cea') ) & 1411 ztmp(:,:) = frcv(jpr_tevp)%z3(:,:,1) - frcv(jpr_ievp)%z3(:,:,1) * zicefr(:,:) 1422 & CALL iom_put( 'hflx_rain_cea', frcv(jpr_rain)%z3(:,:,1) * zcptn(:,:) ) ! heat flux from liq. precip. 1412 1423 IF( iom_use('evap_ao_cea' ) ) & 1413 CALL iom_put( 'evap_ao_cea' , ztmp )! ice-free oce evap (cell average)1424 & CALL iom_put( 'evap_ao_cea' , frcv(jpr_tevp)%z3(:,:,1) - frcv(jpr_ievp)%z3(:,:,1) * zicefr(:,:) ) ! ice-free oce evap (cell average) 1414 1425 IF( iom_use('hflx_evap_cea') ) & 1415 CALL iom_put( 'hflx_evap_cea', ztmp(:,:) * zcptn(:,:) )! heat flux from from evap (cell average)1416 CASE( 'oce and ice' 1426 & CALL iom_put( 'hflx_evap_cea', ( frcv(jpr_tevp)%z3(:,:,1) - frcv(jpr_ievp)%z3(:,:,1) * zicefr(:,:) ) * zcptn(:,:) ) ! heat flux from from evap (cell average) 1427 CASE( 'oce and ice' ) ! received fields: jpr_sbpr, jpr_semp, jpr_oemp, jpr_ievp 1417 1428 zemp_tot(:,:) = p_frld(:,:) * frcv(jpr_oemp)%z3(:,:,1) + zicefr(:,:) * frcv(jpr_sbpr)%z3(:,:,1) 1418 zemp_ice(:,:) = frcv(jpr_semp)%z3(:,:,1) 1429 zemp_ice(:,:) = frcv(jpr_semp)%z3(:,:,1) * zicefr(:,:) 1419 1430 zsprecip(:,:) = frcv(jpr_ievp)%z3(:,:,1) - frcv(jpr_semp)%z3(:,:,1) 1420 1431 ztprecip(:,:) = frcv(jpr_semp)%z3(:,:,1) - frcv(jpr_sbpr)%z3(:,:,1) + zsprecip(:,:) 1421 1432 END SELECT 1422 1433 1423 IF( iom_use('subl_ai_cea') ) & 1424 CALL iom_put( 'subl_ai_cea', frcv(jpr_ievp)%z3(:,:,1) * zicefr(:,:) ) ! Sublimation over sea-ice (cell average) 1425 ! 1426 ! ! runoffs and calving (put in emp_tot) 1434 #if defined key_lim3 1435 ! zsnw = snow fraction over ice after wind blowing 1436 zsnw(:,:) = 0._wp ; CALL lim_thd_snwblow( p_frld, zsnw ) 1437 1438 ! --- evaporation minus precipitation corrected (because of wind blowing on snow) --- ! 1439 zemp_ice(:,:) = zemp_ice(:,:) + zsprecip(:,:) * ( zicefr(:,:) - zsnw(:,:) ) ! emp_ice = A * sublimation - zsnw * sprecip 1440 zemp_oce(:,:) = zemp_tot(:,:) - zemp_ice(:,:) ! emp_oce = emp_tot - emp_ice 1441 1442 ! --- evaporation over ocean (used later for qemp) --- ! 1443 zevap_oce(:,:) = frcv(jpr_tevp)%z3(:,:,1) - frcv(jpr_ievp)%z3(:,:,1) * zicefr(:,:) 1444 1445 ! --- evaporation over ice (kg/m2/s) --- ! 1446 zevap_ice(:,:) = frcv(jpr_ievp)%z3(:,:,1) 1447 ! since the sensitivity of evap to temperature (devap/dT) is not prescribed by the atmosphere, we set it to 0 1448 ! therefore, sublimation is not redistributed over the ice categories in case no subgrid scale fluxes are provided by atm. 1449 zdevap_ice(:,:) = 0._wp 1450 1451 ! --- runoffs (included in emp later on) --- ! 1452 IF( srcv(jpr_rnf)%laction ) rnf(:,:) = frcv(jpr_rnf)%z3(:,:,1) 1453 1454 ! --- calving (put in emp_tot and emp_oce) --- ! 1455 IF( srcv(jpr_cal)%laction ) THEN 1456 zemp_tot(:,:) = zemp_tot(:,:) - frcv(jpr_cal)%z3(:,:,1) 1457 zemp_oce(:,:) = zemp_oce(:,:) - frcv(jpr_cal)%z3(:,:,1) 1458 CALL iom_put( 'calving_cea', frcv(jpr_cal)%z3(:,:,1) ) 1459 ENDIF 1460 1461 IF( ln_mixcpl ) THEN 1462 emp_tot(:,:) = emp_tot(:,:) * xcplmask(:,:,0) + zemp_tot(:,:) * zmsk(:,:) 1463 emp_ice(:,:) = emp_ice(:,:) * xcplmask(:,:,0) + zemp_ice(:,:) * zmsk(:,:) 1464 emp_oce(:,:) = emp_oce(:,:) * xcplmask(:,:,0) + zemp_oce(:,:) * zmsk(:,:) 1465 sprecip(:,:) = sprecip(:,:) * xcplmask(:,:,0) + zsprecip(:,:) * zmsk(:,:) 1466 tprecip(:,:) = tprecip(:,:) * xcplmask(:,:,0) + ztprecip(:,:) * zmsk(:,:) 1467 DO jl=1,jpl 1468 evap_ice (:,:,jl) = evap_ice (:,:,jl) * xcplmask(:,:,0) + zevap_ice (:,:) * zmsk(:,:) 1469 devap_ice(:,:,jl) = devap_ice(:,:,jl) * xcplmask(:,:,0) + zdevap_ice(:,:) * zmsk(:,:) 1470 ENDDO 1471 ELSE 1472 emp_tot(:,:) = zemp_tot(:,:) 1473 emp_ice(:,:) = zemp_ice(:,:) 1474 emp_oce(:,:) = zemp_oce(:,:) 1475 sprecip(:,:) = zsprecip(:,:) 1476 tprecip(:,:) = ztprecip(:,:) 1477 DO jl=1,jpl 1478 evap_ice (:,:,jl) = zevap_ice (:,:) 1479 devap_ice(:,:,jl) = zdevap_ice(:,:) 1480 ENDDO 1481 ENDIF 1482 1483 IF( iom_use('subl_ai_cea') ) CALL iom_put( 'subl_ai_cea', zevap_ice(:,:) * zicefr(:,:) ) ! Sublimation over sea-ice (cell average) 1484 CALL iom_put( 'snowpre' , sprecip(:,:) ) ! Snow 1485 IF( iom_use('snow_ao_cea') ) CALL iom_put( 'snow_ao_cea', sprecip(:,:) * ( 1._wp - zsnw(:,:) ) ) ! Snow over ice-free ocean (cell average) 1486 IF( iom_use('snow_ai_cea') ) CALL iom_put( 'snow_ai_cea', sprecip(:,:) * zsnw(:,:) ) ! Snow over sea-ice (cell average) 1487 #else 1488 ! runoffs and calving (put in emp_tot) 1427 1489 IF( srcv(jpr_rnf)%laction ) rnf(:,:) = frcv(jpr_rnf)%z3(:,:,1) 1428 1490 IF( srcv(jpr_cal)%laction ) THEN … … 1443 1505 ENDIF 1444 1506 1445 CALL iom_put( 'snowpre' , sprecip ) ! Snow1446 IF( iom_use('snow_ao_cea') ) &1447 CALL iom_put( 'snow_ao_cea', sprecip(:,:) * p_frld(:,:) ) ! Snowover ice-free ocean (cell average)1448 IF( iom_use('snow_ai_cea') ) &1449 CALL iom_put( 'snow_ai_cea', sprecip(:,:) * zicefr(:,:) ) ! Snow over sea-ice (cell average) 1507 IF( iom_use('subl_ai_cea') ) CALL iom_put( 'subl_ai_cea', frcv(jpr_ievp)%z3(:,:,1) * zicefr(:,:) ) ! Sublimation over sea-ice (cell average) 1508 CALL iom_put( 'snowpre' , sprecip(:,:) ) ! Snow 1509 IF( iom_use('snow_ao_cea') ) CALL iom_put( 'snow_ao_cea', sprecip(:,:) * p_frld(:,:) ) ! Snow over ice-free ocean (cell average) 1510 IF( iom_use('snow_ai_cea') ) CALL iom_put( 'snow_ai_cea', sprecip(:,:) * zicefr(:,:) ) ! Snow over sea-ice (cell average) 1511 #endif 1450 1512 1451 1513 ! ! ========================= ! 1452 1514 SELECT CASE( TRIM( sn_rcv_qns%cldes ) ) ! non solar heat fluxes ! (qns) 1453 1515 ! ! ========================= ! 1454 CASE( 'oce only' ) 1455 zqns_tot(:,: 1456 CASE( 'conservative' ) 1457 zqns_tot(:,: 1516 CASE( 'oce only' ) ! the required field is directly provided 1517 zqns_tot(:,:) = frcv(jpr_qnsoce)%z3(:,:,1) 1518 CASE( 'conservative' ) ! the required fields are directly provided 1519 zqns_tot(:,:) = frcv(jpr_qnsmix)%z3(:,:,1) 1458 1520 IF ( TRIM(sn_rcv_qns%clcat) == 'yes' ) THEN 1459 1521 zqns_ice(:,:,1:jpl) = frcv(jpr_qnsice)%z3(:,:,1:jpl) 1460 1522 ELSE 1461 ! Set all category values equal for the moment1462 1523 DO jl=1,jpl 1463 zqns_ice(:,:,jl) = frcv(jpr_qnsice)%z3(:,:,1) 1524 zqns_ice(:,:,jl) = frcv(jpr_qnsice)%z3(:,:,1) ! Set all category values equal 1464 1525 ENDDO 1465 1526 ENDIF 1466 CASE( 'oce and ice' ) 1467 zqns_tot(:,: 1527 CASE( 'oce and ice' ) ! the total flux is computed from ocean and ice fluxes 1528 zqns_tot(:,:) = p_frld(:,:) * frcv(jpr_qnsoce)%z3(:,:,1) 1468 1529 IF ( TRIM(sn_rcv_qns%clcat) == 'yes' ) THEN 1469 1530 DO jl=1,jpl … … 1472 1533 ENDDO 1473 1534 ELSE 1474 qns_tot(:,: 1535 qns_tot(:,:) = qns_tot(:,:) + zicefr(:,:) * frcv(jpr_qnsice)%z3(:,:,1) 1475 1536 DO jl=1,jpl 1476 1537 zqns_tot(:,: ) = zqns_tot(:,:) + zicefr(:,:) * frcv(jpr_qnsice)%z3(:,:,1) … … 1478 1539 ENDDO 1479 1540 ENDIF 1480 CASE( 'mixed oce-ice' ) 1541 CASE( 'mixed oce-ice' ) ! the ice flux is cumputed from the total flux, the SST and ice informations 1481 1542 ! ** NEED TO SORT OUT HOW THIS SHOULD WORK IN THE MULTI-CATEGORY CASE - CURRENTLY NOT ALLOWED WHEN INTERFACE INITIALISED ** 1482 1543 zqns_tot(:,: ) = frcv(jpr_qnsmix)%z3(:,:,1) 1483 1544 zqns_ice(:,:,1) = frcv(jpr_qnsmix)%z3(:,:,1) & 1484 1545 & + frcv(jpr_dqnsdt)%z3(:,:,1) * ( pist(:,:,1) - ( (rt0 + psst(:,: ) ) * p_frld(:,:) & 1485 & + pist(:,:,1)* zicefr(:,:) ) )1546 & + pist(:,:,1) * zicefr(:,:) ) ) 1486 1547 END SELECT 1487 1548 !!gm … … 1493 1554 !! similar job should be done for snow and precipitation temperature 1494 1555 ! 1495 IF( srcv(jpr_cal)%laction ) THEN ! Iceberg melting 1496 ztmp(:,:) = frcv(jpr_cal)%z3(:,:,1) * lfus ! add the latent heat of iceberg melting 1497 zqns_tot(:,:) = zqns_tot(:,:) - ztmp(:,:) 1498 IF( iom_use('hflx_cal_cea') ) & 1499 CALL iom_put( 'hflx_cal_cea', ztmp + frcv(jpr_cal)%z3(:,:,1) * zcptn(:,:) ) ! heat flux from calving 1500 ENDIF 1501 1502 ztmp(:,:) = p_frld(:,:) * zsprecip(:,:) * lfus 1503 IF( iom_use('hflx_snow_cea') ) CALL iom_put( 'hflx_snow_cea', ztmp + sprecip(:,:) * zcptn(:,:) ) ! heat flux from snow (cell average) 1504 1505 #if defined key_lim3 1506 CALL wrk_alloc( jpi,jpj, zevap, zsnw, zqns_oce, zqprec_ice, zqemp_oce ) 1507 1508 ! --- evaporation --- ! 1509 ! clem: evap_ice is set to 0 for LIM3 since we still do not know what to do with sublimation 1510 ! the problem is: the atm. imposes both mass evaporation and heat removed from the snow/ice 1511 ! but it is incoherent WITH the ice model 1512 DO jl=1,jpl 1513 evap_ice(:,:,jl) = 0._wp ! should be: frcv(jpr_ievp)%z3(:,:,1) 1514 ENDDO 1515 zevap(:,:) = zemp_tot(:,:) + ztprecip(:,:) ! evaporation over ocean 1516 1517 ! --- evaporation minus precipitation --- ! 1518 emp_oce(:,:) = emp_tot(:,:) - emp_ice(:,:) 1519 1556 IF( srcv(jpr_cal)%laction ) THEN ! Iceberg melting 1557 zqns_tot(:,:) = zqns_tot(:,:) - frcv(jpr_cal)%z3(:,:,1) * lfus ! add the latent heat of iceberg melting 1558 ! we suppose it melts at 0deg, though it should be temp. of surrounding ocean 1559 IF( iom_use('hflx_cal_cea') ) CALL iom_put( 'hflx_cal_cea', - frcv(jpr_cal)%z3(:,:,1) * lfus ) ! heat flux from calving 1560 ENDIF 1561 1562 #if defined key_lim3 1520 1563 ! --- non solar flux over ocean --- ! 1521 1564 ! note: p_frld cannot be = 0 since we limit the ice concentration to amax … … 1523 1566 WHERE( p_frld /= 0._wp ) zqns_oce(:,:) = ( zqns_tot(:,:) - SUM( a_i * zqns_ice, dim=3 ) ) / p_frld(:,:) 1524 1567 1525 ! --- heat flux associated with emp --- !1526 z snw(:,:) = 0._wp1527 CALL lim_thd_snwblow( p_frld, zsnw ) ! snow distribution over ice after wind blowing1528 zqemp_oce(:,:) = - zevap(:,:) * p_frld(:,:) * zcptn(:,:) & ! evap1529 & + ( ztprecip(:,:) - zsprecip(:,:) ) * zcptn(:,:) & ! liquid precip1530 & + zsprecip(:,:) * ( 1._wp - zsnw ) * ( zcptn(:,:) - lfus ) ! solid precip over ocean 1531 qemp_ice(:,:) = - frcv(jpr_ievp)%z3(:,:,1) * zicefr(:,:) * zcptn(:,:) & ! ice evap1532 & + zsprecip(:,:) * zsnw * ( zcptn(:,:) - lfus ) ! solid precip over ice1533 1534 ! --- heat content ofprecip over ice in J/m3 (to be used in 1D-thermo) --- !1568 ! --- heat flux associated with emp (W/m2) --- ! 1569 zqemp_oce(:,:) = - zevap_oce(:,:) * zcptn(:,:) & ! evap 1570 & + ( ztprecip(:,:) - zsprecip(:,:) ) * zcptn(:,:) & ! liquid precip 1571 & + zsprecip(:,:) * ( 1._wp - zsnw ) * ( zcptn(:,:) - lfus ) ! solid precip over ocean + snow melting 1572 ! zqemp_ice(:,:) = - frcv(jpr_ievp)%z3(:,:,1) * zicefr(:,:) * zcptn(:,:) & ! ice evap 1573 ! & + zsprecip(:,:) * zsnw * ( zcptn(:,:) - lfus ) ! solid precip over ice 1574 zqemp_ice(:,:) = zsprecip(:,:) * zsnw * ( zcptn(:,:) - lfus ) ! solid precip over ice (only) 1575 ! qevap_ice=0 since we consider Tice=0degC 1576 1577 ! --- enthalpy of snow precip over ice in J/m3 (to be used in 1D-thermo) --- ! 1535 1578 zqprec_ice(:,:) = rhosn * ( zcptn(:,:) - lfus ) 1536 1579 1537 ! --- total non solar flux --- ! 1538 zqns_tot(:,:) = zqns_tot(:,:) + qemp_ice(:,:) + zqemp_oce(:,:) 1580 ! --- heat content of evap over ice in W/m2 (to be used in 1D-thermo) --- ! 1581 DO jl = 1, jpl 1582 zqevap_ice(:,:,jl) = 0._wp ! should be -evap * ( ( Tice - rt0 ) * cpic ) but we do not have Tice, so we consider Tice=0degC 1583 END DO 1584 1585 ! --- total non solar flux (including evap/precip) --- ! 1586 zqns_tot(:,:) = zqns_tot(:,:) + zqemp_ice(:,:) + zqemp_oce(:,:) 1539 1587 1540 1588 ! --- in case both coupled/forced are active, we must mix values --- ! … … 1543 1591 qns_oce(:,:) = qns_oce(:,:) * xcplmask(:,:,0) + zqns_oce(:,:)* zmsk(:,:) 1544 1592 DO jl=1,jpl 1545 qns_ice(:,:,jl) = qns_ice(:,:,jl) * xcplmask(:,:,0) + zqns_ice(:,:,jl)* zmsk(:,:) 1593 qns_ice (:,:,jl) = qns_ice (:,:,jl) * xcplmask(:,:,0) + zqns_ice (:,:,jl)* zmsk(:,:) 1594 qevap_ice(:,:,jl) = qevap_ice(:,:,jl) * xcplmask(:,:,0) + zqevap_ice(:,:,jl)* zmsk(:,:) 1546 1595 ENDDO 1547 1596 qprec_ice(:,:) = qprec_ice(:,:) * xcplmask(:,:,0) + zqprec_ice(:,:)* zmsk(:,:) 1548 1597 qemp_oce (:,:) = qemp_oce(:,:) * xcplmask(:,:,0) + zqemp_oce(:,:)* zmsk(:,:) 1549 !!clem evap_ice(:,:) = evap_ice(:,:) * xcplmask(:,:,0)1598 qemp_ice (:,:) = qemp_ice(:,:) * xcplmask(:,:,0) + zqemp_ice(:,:)* zmsk(:,:) 1550 1599 ELSE 1551 1600 qns_tot (:,: ) = zqns_tot (:,: ) 1552 1601 qns_oce (:,: ) = zqns_oce (:,: ) 1553 1602 qns_ice (:,:,:) = zqns_ice (:,:,:) 1554 qprec_ice(:,:) = zqprec_ice(:,:) 1555 qemp_oce (:,:) = zqemp_oce (:,:) 1556 ENDIF 1557 1558 CALL wrk_dealloc( jpi,jpj, zevap, zsnw, zqns_oce, zqprec_ice, zqemp_oce ) 1603 qevap_ice(:,:,:) = zqevap_ice(:,:,:) 1604 qprec_ice(:,: ) = zqprec_ice(:,: ) 1605 qemp_oce (:,: ) = zqemp_oce (:,: ) 1606 qemp_ice (:,: ) = zqemp_ice (:,: ) 1607 ENDIF 1608 1609 !! clem: we should output qemp_oce and qemp_ice (at least) 1610 IF( iom_use('hflx_snow_cea') ) CALL iom_put( 'hflx_snow_cea', sprecip(:,:) * ( zcptn(:,:) - Lfus ) ) ! heat flux from snow (cell average) 1611 !! these diags are not outputed yet 1612 !! IF( iom_use('hflx_rain_cea') ) CALL iom_put( 'hflx_rain_cea', ( tprecip(:,:) - sprecip(:,:) ) * zcptn(:,:) ) ! heat flux from rain (cell average) 1613 !! IF( iom_use('hflx_snow_ao_cea') ) CALL iom_put( 'hflx_snow_ao_cea', sprecip(:,:) * ( zcptn(:,:) - Lfus ) * (1._wp - zsnw(:,:)) ) ! heat flux from snow (cell average) 1614 !! IF( iom_use('hflx_snow_ai_cea') ) CALL iom_put( 'hflx_snow_ai_cea', sprecip(:,:) * ( zcptn(:,:) - Lfus ) * zsnw(:,:) ) ! heat flux from snow (cell average) 1615 1559 1616 #else 1560 1561 1617 ! clem: this formulation is certainly wrong... but better than it was... 1562 1618 zqns_tot(:,:) = zqns_tot(:,:) & ! zqns_tot update over free ocean with: 1563 1619 & - ztmp(:,:) & ! remove the latent heat flux of solid precip. melting 1564 1620 & - ( zemp_tot(:,:) & ! remove the heat content of mass flux (assumed to be at SST) 1565 & - zemp_ice(:,:) * zicefr(:,:)) * zcptn(:,:)1621 & - zemp_ice(:,:) ) * zcptn(:,:) 1566 1622 1567 1623 IF( ln_mixcpl ) THEN … … 1575 1631 qns_ice(:,:,:) = zqns_ice(:,:,:) 1576 1632 ENDIF 1577 1578 1633 #endif 1579 1634 … … 1626 1681 1627 1682 #if defined key_lim3 1628 CALL wrk_alloc( jpi,jpj, zqsr_oce )1629 1683 ! --- solar flux over ocean --- ! 1630 1684 ! note: p_frld cannot be = 0 since we limit the ice concentration to amax … … 1634 1688 IF( ln_mixcpl ) THEN ; qsr_oce(:,:) = qsr_oce(:,:) * xcplmask(:,:,0) + zqsr_oce(:,:)* zmsk(:,:) 1635 1689 ELSE ; qsr_oce(:,:) = zqsr_oce(:,:) ; ENDIF 1636 1637 CALL wrk_dealloc( jpi,jpj, zqsr_oce )1638 1690 #endif 1639 1691 … … 1686 1738 fr2_i0(:,:) = ( 0.82 * ( 1.0 - cldf_ice ) + 0.65 * cldf_ice ) 1687 1739 1688 CALL wrk_dealloc( jpi,jpj, zcptn, ztmp, zicefr, zmsk, zemp_tot, zemp_ice, zsprecip, ztprecip, zqns_tot, zqsr_tot ) 1689 CALL wrk_dealloc( jpi,jpj,jpl, zqns_ice, zqsr_ice, zdqns_ice ) 1740 CALL wrk_dealloc( jpi,jpj, zcptn, ztmp, zicefr, zmsk, zsnw ) 1741 CALL wrk_dealloc( jpi,jpj, zemp_tot, zemp_ice, zemp_oce, ztprecip, zsprecip, zevap_oce, zevap_ice, zdevap_ice ) 1742 CALL wrk_dealloc( jpi,jpj, zqns_tot, zqns_oce, zqsr_tot, zqsr_oce, zqprec_ice, zqemp_oce, zqemp_ice ) 1743 CALL wrk_dealloc( jpi,jpj,jpl, zqns_ice, zqsr_ice, zdqns_ice, zqevap_ice ) 1690 1744 ! 1691 1745 IF( nn_timing == 1 ) CALL timing_stop('sbc_cpl_ice_flx') … … 1743 1797 ztmp3(:,:,1) = SUM( tn_ice * a_i, dim=3 ) / SUM( a_i, dim=3 ) 1744 1798 ELSEWHERE 1745 ztmp3(:,:,1) = rt0 ! TODO: Is freezing point a good default? (Maybe SST is better?)1799 ztmp3(:,:,1) = rt0 1746 1800 END WHERE 1747 1801 CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_temp%clcat' ) … … 1774 1828 ! ! ------------------------- ! 1775 1829 IF( ssnd(jps_albice)%laction ) THEN ! ice 1776 SELECT CASE( sn_snd_alb%cldes ) 1777 CASE( 'ice' ) ; ztmp3(:,:,1:jpl) = alb_ice(:,:,1:jpl) 1778 CASE( 'weighted ice' ) ; ztmp3(:,:,1:jpl) = alb_ice(:,:,1:jpl) * a_i(:,:,1:jpl) 1779 CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_alb%cldes' ) 1830 SELECT CASE( sn_snd_alb%cldes ) 1831 CASE( 'ice' ) 1832 SELECT CASE( sn_snd_alb%clcat ) 1833 CASE( 'yes' ) 1834 ztmp3(:,:,1:jpl) = alb_ice(:,:,1:jpl) 1835 CASE( 'no' ) 1836 WHERE( SUM( a_i, dim=3 ) /= 0. ) 1837 ztmp1(:,:) = SUM( alb_ice (:,:,1:jpl) * a_i(:,:,1:jpl), dim=3 ) / SUM( a_i(:,:,1:jpl), dim=3 ) 1838 ELSEWHERE 1839 ztmp1(:,:) = albedo_oce_mix(:,:) 1840 END WHERE 1841 CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_alb%clcat' ) 1842 END SELECT 1843 CASE( 'weighted ice' ) ; 1844 SELECT CASE( sn_snd_alb%clcat ) 1845 CASE( 'yes' ) 1846 ztmp3(:,:,1:jpl) = alb_ice(:,:,1:jpl) * a_i(:,:,1:jpl) 1847 CASE( 'no' ) 1848 WHERE( fr_i (:,:) > 0. ) 1849 ztmp1(:,:) = SUM ( alb_ice(:,:,1:jpl) * a_i(:,:,1:jpl), dim=3 ) 1850 ELSEWHERE 1851 ztmp1(:,:) = 0. 1852 END WHERE 1853 CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_ice%clcat' ) 1854 END SELECT 1855 CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_alb%cldes' ) 1780 1856 END SELECT 1781 CALL cpl_snd( jps_albice, isec, ztmp3, info ) 1782 ENDIF 1857 1858 SELECT CASE( sn_snd_alb%clcat ) 1859 CASE( 'yes' ) 1860 CALL cpl_snd( jps_albice, isec, ztmp3, info ) !-> MV this has never been checked in coupled mode 1861 CASE( 'no' ) 1862 CALL cpl_snd( jps_albice, isec, RESHAPE ( ztmp1, (/jpi,jpj,1/) ), info ) 1863 END SELECT 1864 ENDIF 1865 1783 1866 IF( ssnd(jps_albmix)%laction ) THEN ! mixed ice-ocean 1784 1867 ztmp1(:,:) = albedo_oce_mix(:,:) * zfr_l(:,:) -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/SBC/sbcfwb.F90
r6836 r6839 108 108 ! 109 109 IF( MOD( kt-1, kn_fsbc ) == 0 ) THEN 110 z_fwf = glob_sum( e1e2t(:,:) * ( emp(:,:) - rnf(:,:) + rdivisf * fwfisf(:,:) -snwice_fmass(:,:) ) ) / area ! sum over the global domain110 z_fwf = glob_sum( e1e2t(:,:) * ( emp(:,:) - rnf(:,:) + fwfisf(:,:) - snwice_fmass(:,:) ) ) / area ! sum over the global domain 111 111 zcoef = z_fwf * rcp 112 112 emp(:,:) = emp(:,:) - z_fwf * tmask(:,:,1) … … 162 162 zsurf_pos = glob_sum( e1e2t(:,:)*ztmsk_pos(:,:) ) 163 163 ! ! fwf global mean (excluding ocean to ice/snow exchanges) 164 z_fwf = glob_sum( e1e2t(:,:) * ( emp(:,:) - rnf(:,:) + rdivisf *fwfisf(:,:) - snwice_fmass(:,:) ) ) / area164 z_fwf = glob_sum( e1e2t(:,:) * ( emp(:,:) - rnf(:,:) + fwfisf(:,:) - snwice_fmass(:,:) ) ) / area 165 165 ! 166 166 IF( z_fwf < 0._wp ) THEN ! spread out over >0 erp area to increase evaporation -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/SBC/sbcice_if.F90
r6836 r6839 103 103 ! ( d rho / dt ) / ( d rho / ds ) ( s = 34, t = -1.8 ) 104 104 105 fr_i(:,:) = eos_fzp( sss_m ) * tmask(:,:,1) ! sea surface freezing temperature [Celcius] 105 CALL eos_fzp( sss_m(:,:), fr_i(:,:) ) ! sea surface freezing temperature [Celcius] 106 fr_i(:,:) = fr_i(:,:) * tmask(:,:,1) 106 107 107 108 IF( ln_cpl ) a_i(:,:,1) = fr_i(:,:) -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/SBC/sbcice_lim.F90
r6836 r6839 110 110 INTEGER :: jl ! dummy loop index 111 111 REAL(wp), POINTER, DIMENSION(:,:,:) :: zalb_os, zalb_cs ! ice albedo under overcast/clear sky 112 REAL(wp), POINTER, DIMENSION(:,:,:) :: zalb_ice ! mean ice albedo (for coupled)113 112 REAL(wp), POINTER, DIMENSION(:,: ) :: zutau_ice, zvtau_ice 114 113 !!---------------------------------------------------------------------- … … 126 125 127 126 ! masked sea surface freezing temperature [Kelvin] (set to rt0 over land) 128 t_bo(:,:) = ( eos_fzp( sss_m ) + rt0 ) * tmask(:,:,1) + rt0 * ( 1._wp - tmask(:,:,1) ) 129 127 CALL eos_fzp( sss_m(:,:) , t_bo(:,:) ) 128 t_bo(:,:) = ( t_bo(:,:) + rt0 ) * tmask(:,:,1) + rt0 * ( 1._wp - tmask(:,:,1) ) 129 130 130 ! Mask sea ice surface temperature (set to rt0 over land) 131 131 DO jl = 1, jpl … … 196 196 ! fr1_i0 , fr2_i0 : 1sr & 2nd fraction of qsr penetration in ice [%] 197 197 !---------------------------------------------------------------------------------------- 198 CALL wrk_alloc( jpi,jpj,jpl, zalb_os, zalb_cs , zalb_ice)198 CALL wrk_alloc( jpi,jpj,jpl, zalb_os, zalb_cs ) 199 199 CALL albedo_ice( t_su, ht_i, ht_s, zalb_cs, zalb_os ) ! cloud-sky and overcast-sky ice albedos 200 200 … … 202 202 CASE( jp_clio ) ! CLIO bulk formulation 203 203 ! In CLIO the cloud fraction is read in the climatology and the all-sky albedo 204 ! ( zalb_ice) is computed within the bulk routine205 CALL blk_ice_clio_flx( t_su, zalb_cs, zalb_os, zalb_ice )206 IF( ln_mixcpl ) CALL sbc_cpl_ice_flx( p_frld=pfrld, palbi= zalb_ice, psst=sst_m, pist=t_su )207 IF( nn_limflx /= 2 ) CALL ice_lim_flx( t_su, zalb_ice, qns_ice, qsr_ice, dqns_ice, evap_ice, devap_ice, nn_limflx )204 ! (alb_ice) is computed within the bulk routine 205 CALL blk_ice_clio_flx( t_su, zalb_cs, zalb_os, alb_ice ) 206 IF( ln_mixcpl ) CALL sbc_cpl_ice_flx( p_frld=pfrld, palbi=alb_ice, psst=sst_m, pist=t_su ) 207 IF( nn_limflx /= 2 ) CALL ice_lim_flx( t_su, alb_ice, qns_ice, qsr_ice, dqns_ice, evap_ice, devap_ice, nn_limflx ) 208 208 CASE( jp_core ) ! CORE bulk formulation 209 209 ! albedo depends on cloud fraction because of non-linear spectral effects 210 zalb_ice(:,:,:) = ( 1. - cldf_ice ) * zalb_cs(:,:,:) + cldf_ice * zalb_os(:,:,:)211 CALL blk_ice_core_flx( t_su, zalb_ice )212 IF( ln_mixcpl ) CALL sbc_cpl_ice_flx( p_frld=pfrld, palbi= zalb_ice, psst=sst_m, pist=t_su )213 IF( nn_limflx /= 2 ) CALL ice_lim_flx( t_su, zalb_ice, qns_ice, qsr_ice, dqns_ice, evap_ice, devap_ice, nn_limflx )210 alb_ice(:,:,:) = ( 1. - cldf_ice ) * zalb_cs(:,:,:) + cldf_ice * zalb_os(:,:,:) 211 CALL blk_ice_core_flx( t_su, alb_ice ) 212 IF( ln_mixcpl ) CALL sbc_cpl_ice_flx( p_frld=pfrld, palbi=alb_ice, psst=sst_m, pist=t_su ) 213 IF( nn_limflx /= 2 ) CALL ice_lim_flx( t_su, alb_ice, qns_ice, qsr_ice, dqns_ice, evap_ice, devap_ice, nn_limflx ) 214 214 CASE ( jp_purecpl ) 215 215 ! albedo depends on cloud fraction because of non-linear spectral effects 216 zalb_ice(:,:,:) = ( 1. - cldf_ice ) * zalb_cs(:,:,:) + cldf_ice * zalb_os(:,:,:) 217 CALL sbc_cpl_ice_flx( p_frld=pfrld, palbi=zalb_ice, psst=sst_m, pist=t_su ) 218 ! clem: evap_ice is forced to 0 in coupled mode for now 219 ! but it needs to be changed (along with modif in limthd_dh) once heat flux from evap will be avail. from atm. models 220 evap_ice (:,:,:) = 0._wp ; devap_ice (:,:,:) = 0._wp 221 IF( nn_limflx == 2 ) CALL ice_lim_flx( t_su, zalb_ice, qns_ice, qsr_ice, dqns_ice, evap_ice, devap_ice, nn_limflx ) 216 alb_ice(:,:,:) = ( 1. - cldf_ice ) * zalb_cs(:,:,:) + cldf_ice * zalb_os(:,:,:) 217 CALL sbc_cpl_ice_flx( p_frld=pfrld, palbi=alb_ice, psst=sst_m, pist=t_su ) 218 IF( nn_limflx == 2 ) CALL ice_lim_flx( t_su, alb_ice, qns_ice, qsr_ice, dqns_ice, evap_ice, devap_ice, nn_limflx ) 222 219 END SELECT 223 CALL wrk_dealloc( jpi,jpj,jpl, zalb_os, zalb_cs , zalb_ice)220 CALL wrk_dealloc( jpi,jpj,jpl, zalb_os, zalb_cs ) 224 221 225 222 !----------------------------! … … 264 261 !!---------------------------------------------------------------------- 265 262 INTEGER :: ierr 263 INTEGER :: ji, jj 266 264 !!---------------------------------------------------------------------- 267 265 IF(lwp) WRITE(numout,*) … … 320 318 tn_ice(:,:,:) = t_su(:,:,:) ! initialisation of surface temp for coupled simu 321 319 ! 320 DO jj = 1, jpj 321 DO ji = 1, jpi 322 IF( gphit(ji,jj) > 0._wp ) THEN ; rn_amax_2d(ji,jj) = rn_amax_n ! NH 323 ELSE ; rn_amax_2d(ji,jj) = rn_amax_s ! SH 324 ENDIF 325 ENDDO 326 ENDDO 327 ! 322 328 nstart = numit + nn_fsbc 323 329 nitrun = nitend - nit000 + 1 … … 342 348 INTEGER :: ios ! Local integer output status for namelist read 343 349 NAMELIST/namicerun/ jpl, nlay_i, nlay_s, cn_icerst_in, cn_icerst_indir, cn_icerst_out, cn_icerst_outdir, & 344 & ln_limdyn, rn_amax , ln_limdiahsb, ln_limdiaout, ln_icectl, iiceprt, jiceprt350 & ln_limdyn, rn_amax_n, rn_amax_s, ln_limdiahsb, ln_limdiaout, ln_icectl, iiceprt, jiceprt 345 351 !!------------------------------------------------------------------- 346 352 ! … … 363 369 WRITE(numout,*) ' number of snow layers = ', nlay_s 364 370 WRITE(numout,*) ' switch for ice dynamics (1) or not (0) ln_limdyn = ', ln_limdyn 365 WRITE(numout,*) ' maximum ice concentration = ', rn_amax 371 WRITE(numout,*) ' maximum ice concentration for NH = ', rn_amax_n 372 WRITE(numout,*) ' maximum ice concentration for SH = ', rn_amax_s 366 373 WRITE(numout,*) ' Diagnose heat/salt budget or not ln_limdiahsb = ', ln_limdiahsb 367 374 WRITE(numout,*) ' Output heat/salt budget or not ln_limdiaout = ', ln_limdiaout … … 578 585 sfx_bog(:,:) = 0._wp ; sfx_dyn(:,:) = 0._wp 579 586 sfx_bom(:,:) = 0._wp ; sfx_sum(:,:) = 0._wp 580 sfx_res(:,:) = 0._wp 587 sfx_res(:,:) = 0._wp ; sfx_sub(:,:) = 0._wp 581 588 582 589 wfx_snw(:,:) = 0._wp ; wfx_ice(:,:) = 0._wp … … 594 601 hfx_spr(:,:) = 0._wp ; hfx_dif(:,:) = 0._wp 595 602 hfx_err(:,:) = 0._wp ; hfx_err_rem(:,:) = 0._wp 596 hfx_err_dif(:,:) = 0._wp ; 597 603 hfx_err_dif(:,:) = 0._wp 604 wfx_err_sub(:,:) = 0._wp 605 598 606 afx_tot(:,:) = 0._wp ; 599 607 afx_dyn(:,:) = 0._wp ; afx_thd(:,:) = 0._wp -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/SBC/sbcice_lim_2.F90
r6836 r6839 150 150 151 151 ! ... masked sea surface freezing temperature [Kelvin] (set to rt0 over land) 152 tfu(:,:) = eos_fzp( sss_m ) + rt0 152 CALL eos_fzp( sss_m(:,:), tfu(:,:) ) 153 tfu(:,:) = tfu(:,:) + rt0 153 154 154 155 zsist (:,:,1) = sist (:,:) + rt0 * ( 1. - tmask(:,:,1) ) -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/SBC/sbcisf.F90
r6836 r6839 53 53 REAL(wp) , PUBLIC, ALLOCATABLE, SAVE, DIMENSION (:,:) :: risfLeff !:effective length (Leff) BG03 nn_isf==2 54 54 REAL(wp) , PUBLIC, ALLOCATABLE, SAVE, DIMENSION (:,:) :: ttbl, stbl, utbl, vtbl !:top boundary layer variable at T point 55 #if defined key_agrif56 ! AGRIF can not handle these arrays as integers. The reason is a mystery but problems avoided by declaring them as reals57 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION (:,:) :: misfkt, misfkb !:Level of ice shelf base58 !: (first wet level and last level include in the tbl)59 #else60 55 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION (:,:) :: misfkt, misfkb !:Level of ice shelf base 61 #endif62 56 63 57 … … 92 86 REAL(wp) :: rmin 93 87 REAL(wp) :: zhk 94 CHARACTER(len=256) :: cfisf, cvarzisf, cvarhisf ! name for isf file 88 REAL(wp) :: zt_frz, zpress 89 CHARACTER(len=256) :: cfisf , cvarzisf, cvarhisf ! name for isf file 95 90 CHARACTER(LEN=256) :: cnameis ! name of iceshelf file 96 91 CHARACTER (LEN=32) :: cvarLeff ! variable name for efficient Length scale … … 176 171 DO jj = 1, jpj 177 172 jk = 2 178 DO WHILE ( jk .LE. mbkt(ji,jj) .AND. fsdepw(ji,jj,jk) < rzisf_tbl(ji,jj) ) ; jk = jk + 1 ; END DO173 DO WHILE ( jk .LE. mbkt(ji,jj) .AND. gdepw_0(ji,jj,jk) < rzisf_tbl(ji,jj) ) ; jk = jk + 1 ; END DO 179 174 misfkt(ji,jj) = jk-1 180 175 END DO … … 194 189 END IF 195 190 191 ! save initial top boundary layer thickness 196 192 rhisf_tbl_0(:,:) = rhisf_tbl(:,:) 193 194 END IF 195 196 ! ! ---------------------------------------- ! 197 IF( kt /= nit000 ) THEN ! Swap of forcing fields ! 198 ! ! ---------------------------------------- ! 199 fwfisf_b (:,: ) = fwfisf (:,: ) ! Swap the ocean forcing fields except at nit000 200 risf_tsc_b(:,:,:) = risf_tsc(:,:,:) ! where before fields are set at the end of the routine 201 ! 202 ENDIF 203 204 IF( MOD( kt-1, nn_fsbc) == 0 ) THEN 197 205 198 206 ! compute bottom level of isf tbl and thickness of tbl below the ice shelf … … 205 213 206 214 ! determine the deepest level influenced by the boundary layer 207 ! test on tmask useless ?????208 215 DO jk = ikt, mbkt(ji,jj) 209 216 IF ( (SUM(fse3t_n(ji,jj,ikt:jk-1)) .LT. rhisf_tbl(ji,jj)) .AND. (tmask(ji,jj,jk) == 1) ) ikb = jk … … 217 224 END DO 218 225 END DO 219 220 END IF221 222 ! ! ---------------------------------------- !223 IF( kt /= nit000 ) THEN ! Swap of forcing fields !224 ! ! ---------------------------------------- !225 fwfisf_b (:,: ) = fwfisf (:,: ) ! Swap the ocean forcing fields except at nit000226 risf_tsc_b(:,:,:) = risf_tsc(:,:,:) ! where before fields are set at the end of the routine227 !228 ENDIF229 230 IF( MOD( kt-1, nn_fsbc) == 0 ) THEN231 232 226 233 227 ! compute salf and heat flux … … 270 264 END IF 271 265 ! compute tsc due to isf 272 ! WARNING water add at temp = 0C, correction term is added in trasbc, maybe better here but need a 3D variable). 273 risf_tsc(:,:,jp_tem) = qisf(:,:) * r1_rau0_rcp ! 266 ! WARNING water add at temp = 0C, correction term is added, maybe better here but need a 3D variable). 267 ! zpress = grav*rau0*fsdept(ji,jj,jk)*1.e-04 268 zt_frz = -1.9 !eos_fzp( tsn(ji,jj,jk,jp_sal), zpress ) 269 risf_tsc(:,:,jp_tem) = qisf(:,:) * r1_rau0_rcp - rdivisf * fwfisf(:,:) * zt_frz * r1_rau0 ! 274 270 275 271 ! salt effect already take into account in vertical advection 276 272 risf_tsc(:,:,jp_sal) = (1.0_wp-rdivisf) * fwfisf(:,:) * stbl(:,:) * r1_rau0 277 273 274 ! output 275 IF( iom_use('qisf' ) ) CALL iom_put('qisf' , qisf) 276 IF( iom_use('fwfisf') ) CALL iom_put('fwfisf', fwfisf * stbl(:,:) / soce ) 277 278 ! if apply only on the trend and not as a volume flux (rdivisf = 0), fwfisf have to be set to 0 now 279 fwfisf(:,:) = rdivisf * fwfisf(:,:) 280 278 281 ! lbclnk 279 282 CALL lbc_lnk(risf_tsc(:,:,jp_tem),'T',1.) … … 295 298 ENDIF 296 299 ! 297 ! output298 CALL iom_put('qisf' , qisf)299 IF( iom_use('fwfisf') ) CALL iom_put('fwfisf', fwfisf * stbl(:,:) / soce )300 300 END IF 301 301 … … 370 370 ! Calculate freezing temperature 371 371 zpress = grav*rau0*fsdept(ji,jj,ik)*1.e-04 372 zt_frz = eos_fzp(tsb(ji,jj,ik,jp_sal), zpress)372 CALL eos_fzp(tsb(ji,jj,ik,jp_sal), zt_frz, zpress) 373 373 zt_sum = zt_sum + (tsn(ji,jj,ik,jp_tem)-zt_frz) * fse3t(ji,jj,ik) * tmask(ji,jj,ik) ! sum temp 374 374 ENDDO … … 452 452 zti(:,:)=tinsitu( ttbl, stbl, zpress ) 453 453 ! Calculate freezing temperature 454 zfrz(:,:)=eos_fzp( sss_m(:,:), zpress )454 CALL eos_fzp( sss_m(:,:), zfrz(:,:), zpress ) 455 455 456 456 … … 472 472 473 473 nit = nit + 1 474 IF (nit .GE. 100) THEN 475 !WRITE(numout,*) "sbcisf : too many iteration ... ", zhtflx, zhtflx_b,zgammat, rn_gammat0, rn_tfri2, nn_gammablk, ji,jj 476 !WRITE(numout,*) "sbcisf : too many iteration ... ", (zhtflx - zhtflx_b)/zhtflx 477 CALL ctl_stop( 'STOP', 'sbc_isf_hol99 : too many iteration ...' ) 478 END IF 474 IF (nit .GE. 100) CALL ctl_stop( 'STOP', 'sbc_isf_hol99 : too many iteration ...' ) 475 479 476 ! save gammat and compute zhtflx_b 480 477 zgammat2d(ji,jj)=zgammat … … 794 791 ! test on tmask useless ????? 795 792 DO jk = ikt, mbkt(ji,jj) 796 !IF ( (SUM(fse3t(ji,jj,ikt:jk-1)) .LT. rhisf_tbl(ji,jj)) .AND. (tmask(ji,jj,jk) == 1) ) ikb = jk793 IF ( (SUM(fse3t(ji,jj,ikt:jk-1)) .LT. rhisf_tbl(ji,jj)) .AND. (tmask(ji,jj,jk) == 1) ) ikb = jk 797 794 END DO 798 795 rhisf_tbl(ji,jj) = MIN(rhisf_tbl(ji,jj), SUM(fse3t(ji,jj,ikt:ikb))) ! limit the tbl to water thickness. -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/SBC/sbcmod.F90
r6836 r6839 179 179 180 180 ! ! Checks: 181 IF( nn_isf .EQ. 0 ) THEN ! no specific treatment in vicinity ofice shelf181 IF( nn_isf .EQ. 0 ) THEN ! variable initialisation if no ice shelf 182 182 IF( sbc_isf_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'sbc_init : unable to allocate sbc_isf arrays' ) 183 fwfisf (:,:) = 0.0_wp 184 fwfisf_b(:,:) = 0.0_wp 183 fwfisf (:,:) = 0.0_wp ; fwfisf_b (:,:) = 0.0_wp 184 risf_tsc(:,:,:) = 0.0_wp ; risf_tsc_b(:,:,:) = 0.0_wp 185 rdivisf = 0.0_wp 185 186 END IF 186 187 IF( nn_ice == 0 .AND. nn_components /= jp_iam_opa ) fr_i(:,:) = 0.e0 ! no ice in the domain, ice fraction is always zero … … 339 340 emp_b(:,:) = emp(:,:) 340 341 sfx_b(:,:) = sfx(:,:) 342 IF ( ln_rnf ) THEN 343 rnf_b (:,: ) = rnf (:,: ) 344 rnf_tsc_b(:,:,:) = rnf_tsc(:,:,:) 345 ENDIF 341 346 ENDIF 342 347 ! ! ---------------------------------------- ! … … 455 460 ! ! ---------------------------------------- ! 456 461 IF( MOD( kt-1, nn_fsbc ) == 0 ) THEN 457 CALL iom_put( "empmr" , emp - rnf ) ! upward water flux 462 CALL iom_put( "empmr" , emp - rnf ) ! upward water flux 463 CALL iom_put( "empbmr" , emp_b - rnf ) ! before upward water flux ( needed to recalculate the time evolution of ssh in offline ) 458 464 CALL iom_put( "saltflx", sfx ) ! downward salt flux 459 465 ! (includes virtual salt flux beneath ice -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/SBC/sbcrnf.F90
r6836 r6839 52 52 REAL(wp) :: rn_hrnf !: runoffs, depth over which enhanced vertical mixing is used 53 53 REAL(wp) , PUBLIC :: rn_avt_rnf !: runoffs, value of the additional vertical mixing coef. [m2/s] 54 REAL(wp) 54 REAL(wp) , PUBLIC :: rn_rfact !: multiplicative factor for runoff 55 55 56 56 LOGICAL , PUBLIC :: l_rnfcpl = .false. ! runoffs recieved from oasis … … 109 109 ! 110 110 CALL wrk_alloc( jpi,jpj, ztfrz) 111 112 ! ! ---------------------------------------- ! 113 IF( kt /= nit000 ) THEN ! Swap of forcing fields ! 114 ! ! ---------------------------------------- ! 115 rnf_b (:,: ) = rnf (:,: ) ! Swap the ocean forcing fields except at nit000 116 rnf_tsc_b(:,:,:) = rnf_tsc(:,:,:) ! where before fields are set at the end of the routine 117 ! 118 ENDIF 119 111 ! 120 112 ! !-------------------! 121 113 ! ! Update runoff ! … … 125 117 IF( ln_rnf_tem ) CALL fld_read ( kt, nn_fsbc, sf_t_rnf ) ! idem for runoffs temperature if required 126 118 IF( ln_rnf_sal ) CALL fld_read ( kt, nn_fsbc, sf_s_rnf ) ! idem for runoffs salinity if required 127 !128 ! Runoff reduction only associated to the ORCA2_LIM configuration129 ! when reading the NetCDF file runoff_1m_nomask.nc130 IF( cp_cfg == 'orca' .AND. jp_cfg == 2 .AND. .NOT. l_rnfcpl ) THEN131 WHERE( 40._wp < gphit(:,:) .AND. gphit(:,:) < 65._wp )132 sf_rnf(1)%fnow(:,:,1) = 0.85 * sf_rnf(1)%fnow(:,:,1)133 END WHERE134 ENDIF135 119 ! 136 120 IF( MOD( kt - 1, nn_fsbc ) == 0 ) THEN -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/SBC/updtide.F90
r6836 r6839 31 31 CONTAINS 32 32 33 SUBROUTINE upd_tide( kt, kit, kbaro, koffset )33 SUBROUTINE upd_tide( kt, kit, time_offset ) 34 34 !!---------------------------------------------------------------------- 35 35 !! *** ROUTINE upd_tide *** … … 42 42 !!---------------------------------------------------------------------- 43 43 INTEGER, INTENT(in) :: kt ! ocean time-step index 44 INTEGER, INTENT(in), OPTIONAL :: kit ! external mode sub-time-step index (lk_dynspg_ts=T only)45 INTEGER, INTENT(in), OPTIONAL :: kbaro ! number of sub-time-step (lk_dynspg_ts=T only)46 INTEGER, INTENT(in), OPTIONAL :: koffset ! time offset in number47 ! of sub-time-steps (lk_dynspg_ts=T only)44 INTEGER, INTENT(in), OPTIONAL :: kit ! external mode sub-time-step index (lk_dynspg_ts=T) 45 INTEGER, INTENT(in), OPTIONAL :: time_offset ! time offset in number 46 ! of internal steps (lk_dynspg_ts=F) 47 ! of external steps (lk_dynspg_ts=T) 48 48 ! 49 49 INTEGER :: joffset ! local integer … … 57 57 ! 58 58 joffset = 0 59 IF( PRESENT( koffset ) ) joffset = koffset59 IF( PRESENT( time_offset ) ) joffset = time_offset 60 60 ! 61 IF( PRESENT( kit ) .AND. PRESENT( kbaro )) THEN62 zt = zt + ( kit + 0.5_wp * ( joffset - 1 ) ) * rdt / REAL( kbaro, wp )61 IF( PRESENT( kit ) ) THEN 62 zt = zt + ( kit + joffset - 1 ) * rdt / REAL( nn_baro, wp ) 63 63 ELSE 64 64 zt = zt + joffset * rdt … … 74 74 IF( ln_tide_ramp ) THEN ! linear increase if asked 75 75 zt = ( kt - nit000 ) * rdt 76 IF( PRESENT( kit ) .AND. PRESENT( kbaro ) ) zt = zt + kit * rdt / REAL( kbaro, wp )76 IF( PRESENT( kit ) ) zt = zt + ( kit + joffset -1) * rdt / REAL( nn_baro, wp ) 77 77 zramp = MIN( MAX( zt / (rdttideramp*rday) , 0._wp ) , 1._wp ) 78 78 pot_astro(:,:) = zramp * pot_astro(:,:) … … 86 86 !!---------------------------------------------------------------------- 87 87 CONTAINS 88 SUBROUTINE upd_tide( kt, kit, kbaro, koffset )! Empty routine88 SUBROUTINE upd_tide( kt, kit, time_offset ) ! Empty routine 89 89 INTEGER, INTENT(in) :: kt ! integer arg, dummy routine 90 90 INTEGER, INTENT(in), OPTIONAL :: kit ! optional arg, dummy routine 91 INTEGER, INTENT(in), OPTIONAL :: kbaro ! optional arg, dummy routine 92 INTEGER, INTENT(in), OPTIONAL :: koffset ! optional arg, dummy routine 91 INTEGER, INTENT(in), OPTIONAL :: time_offset ! optional arg, dummy routine 93 92 WRITE(*,*) 'upd_tide: You should not have seen this print! error?', kt 94 93 END SUBROUTINE upd_tide -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/SOL/solver.F90
r6836 r6839 92 92 IF( .NOT. lk_agrif .OR. .NOT. ln_rstart) THEN 93 93 IF( sol_oce_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'solver_init : unable to allocate sol_oce arrays' ) 94 gcx (:,:) = 0.e0 95 gcxb(:,:) = 0.e0 94 96 ENDIF 95 97 -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/STO/stopar.F90
r6836 r6839 849 849 850 850 851 REAL(wp)FUNCTION sto_par_flt_fac( kpasses )851 FUNCTION sto_par_flt_fac( kpasses ) 852 852 !!---------------------------------------------------------------------- 853 853 !! *** FUNCTION sto_par_flt_fac *** … … 858 858 !!---------------------------------------------------------------------- 859 859 INTEGER, INTENT(in) :: kpasses 860 REAL(wp) :: sto_par_flt_fac 860 861 !! 861 862 INTEGER :: jpasses, ji, jj, jflti, jfltj -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/TRA/eosbn2.F90
r6836 r6839 22 22 !! - ! 2013-04 (F. Roquet, G. Madec) add eos_rab, change bn2 computation and reorganize the module 23 23 !! - ! 2014-09 (F. Roquet) add TEOS-10, S-EOS, and modify EOS-80 24 !! - ! 2015-06 (P.A. Bouttier) eos_fzp functions changed to subroutines for AGRIF 24 25 !!---------------------------------------------------------------------- 25 26 … … 991 992 992 993 993 FUNCTION eos_fzp_2d( psal, pdep ) RESULT( ptf)994 SUBROUTINE eos_fzp_2d( psal, ptf, pdep ) 994 995 !!---------------------------------------------------------------------- 995 996 !! *** ROUTINE eos_fzp *** … … 1005 1006 REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: psal ! salinity [psu] 1006 1007 REAL(wp), DIMENSION(jpi,jpj), INTENT(in ), OPTIONAL :: pdep ! depth [m] 1007 REAL(wp), DIMENSION(jpi,jpj) :: ptf! freezing temperature [Celcius]1008 REAL(wp), DIMENSION(jpi,jpj), INTENT(out ) :: ptf ! freezing temperature [Celcius] 1008 1009 ! 1009 1010 INTEGER :: ji, jj ! dummy loop indices … … 1017 1018 DO jj = 1, jpj 1018 1019 DO ji = 1, jpi 1019 zs= SQRT( ABS( psal(ji,jj) ) * r1_S0) ! square root salinity1020 zs= SQRT( ABS( psal(ji,jj) ) / 35.16504_wp ) ! square root salinity 1020 1021 ptf(ji,jj) = ((((1.46873e-03_wp*zs-9.64972e-03_wp)*zs+2.28348e-02_wp)*zs & 1021 1022 & - 3.12775e-02_wp)*zs+2.07679e-02_wp)*zs-5.87701e-02_wp … … 1038 1039 nstop = nstop + 1 1039 1040 ! 1040 END SELECT 1041 ! 1042 END FUNCTIONeos_fzp_2d1043 1044 FUNCTION eos_fzp_0d( psal, pdep ) RESULT( ptf)1041 END SELECT 1042 ! 1043 END SUBROUTINE eos_fzp_2d 1044 1045 SUBROUTINE eos_fzp_0d( psal, ptf, pdep ) 1045 1046 !!---------------------------------------------------------------------- 1046 1047 !! *** ROUTINE eos_fzp *** … … 1054 1055 !! Reference : UNESCO tech. papers in the marine science no. 28. 1978 1055 1056 !!---------------------------------------------------------------------- 1056 REAL(wp), INTENT(in ) :: psal! salinity [psu]1057 REAL(wp), INTENT(in ), OPTIONAL :: pdep! depth [m]1058 REAL(wp) :: ptf! freezing temperature [Celcius]1057 REAL(wp), INTENT(in ) :: psal ! salinity [psu] 1058 REAL(wp), INTENT(in ), OPTIONAL :: pdep ! depth [m] 1059 REAL(wp), INTENT(out) :: ptf ! freezing temperature [Celcius] 1059 1060 ! 1060 1061 REAL(wp) :: zs ! local scalars … … 1065 1066 CASE ( -1, 1 ) !== CT,SA (TEOS-10 formulation) ==! 1066 1067 ! 1067 zs = SQRT( ABS( psal ) * r1_S0) ! square root salinity1068 zs = SQRT( ABS( psal ) / 35.16504_wp ) ! square root salinity 1068 1069 ptf = ((((1.46873e-03_wp*zs-9.64972e-03_wp)*zs+2.28348e-02_wp)*zs & 1069 1070 & - 3.12775e-02_wp)*zs+2.07679e-02_wp)*zs-5.87701e-02_wp … … 1086 1087 END SELECT 1087 1088 ! 1088 END FUNCTIONeos_fzp_0d1089 END SUBROUTINE eos_fzp_0d 1089 1090 1090 1091 … … 1255 1256 WRITE(numout,*) ' model does not use Conservative Temperature' 1256 1257 ENDIF 1258 ENDIF 1259 ! 1260 ! Consistency check on ln_useCT and nn_eos 1261 IF ((nn_eos .EQ. -1) .AND. (.NOT. ln_useCT)) THEN 1262 CALL ctl_stop("ln_useCT should be set to True if using TEOS-10 (nn_eos=-1)") 1263 ELSE IF ((nn_eos .NE. -1) .AND. (ln_useCT)) THEN 1264 CALL ctl_stop("ln_useCT should be set to False if using TEOS-80 or simplified equation of state (nn_eos=0 or nn_eos=1)") 1257 1265 ENDIF 1258 1266 ! -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_cen2.F90
r6836 r6839 173 173 END DO 174 174 END DO 175 zfzp(:,:) = eos_fzp( tsn(:,:,1,jp_sal), zpres(:,:) )175 CALL eos_fzp( tsn(:,:,1,jp_sal), zfzp(:,:), zpres(:,:) ) 176 176 DO jk = 1, jpk 177 177 DO jj = 1, jpj -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_eiv.F90
r6836 r6839 212 212 CHARACTER(len=3) :: cdtype 213 213 REAL, DIMENSION(:,:,:) :: pun, pvn, pwn 214 WRITE(*,*) 'tra_adv_eiv: You should not have seen this print! error?', kt, cdtype, pun(1,1,1), pvn(1,1,1), pwn(1,1,1) 214 WRITE(*,*) 'tra_adv_eiv: You should not have seen this print! error?', & 215 & kt, cdtype, pun(1,1,1), pvn(1,1,1), pwn(1,1,1) 215 216 END SUBROUTINE tra_adv_eiv 216 217 #endif -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_tvd.F90
r6836 r6839 173 173 DO jj = 2, jpjm1 174 174 DO ji = fs_2, fs_jpim1 ! vector opt. 175 zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) )176 175 ! total intermediate advective trends 177 ztra = - zbtr *( zwx(ji,jj,jk) - zwx(ji-1,jj ,jk ) &178 & 179 & + zwz(ji,jj,jk) - zwz(ji ,jj ,jk+1))176 ztra = - ( zwx(ji,jj,jk) - zwx(ji-1,jj ,jk ) & 177 & + zwy(ji,jj,jk) - zwy(ji ,jj-1,jk ) & 178 & + zwz(ji,jj,jk) - zwz(ji ,jj ,jk+1) ) / e1e2t(ji,jj) 180 179 ! update and guess with monotonic sheme 181 pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) + ztra* tmask(ji,jj,jk)182 zwi(ji,jj,jk) = ( ptb(ji,jj,jk,jn) + z2dtt * ztra) * tmask(ji,jj,jk)180 pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) + ztra / fse3t_n(ji,jj,jk) * tmask(ji,jj,jk) 181 zwi(ji,jj,jk) = ( fse3t_b(ji,jj,jk) * ptb(ji,jj,jk,jn) + z2dtt * ztra ) / fse3t_a(ji,jj,jk) * tmask(ji,jj,jk) 183 182 END DO 184 183 END DO … … 326 325 CALL wrk_alloc( jpi, jpj, zwx_sav, zwy_sav ) 327 326 CALL wrk_alloc( jpi, jpj, jpk, zwi, zwz , zhdiv, zwz_sav, zwzts ) 328 CALL wrk_alloc( jpi, jpj, jpk, 3, ztrs )327 CALL wrk_alloc( jpi, jpj, jpk, kjpt+1, ztrs ) 329 328 ! 330 329 IF( kt == kit000 ) THEN … … 410 409 DO jj = 2, jpjm1 411 410 DO ji = fs_2, fs_jpim1 ! vector opt. 412 zbtr = 1._wp / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) )413 411 ! total intermediate advective trends 414 ztra = - zbtr *( zwx(ji,jj,jk) - zwx(ji-1,jj ,jk ) &415 & 416 & + zwz(ji,jj,jk) - zwz(ji ,jj ,jk+1))412 ztra = - ( zwx(ji,jj,jk) - zwx(ji-1,jj ,jk ) & 413 & + zwy(ji,jj,jk) - zwy(ji ,jj-1,jk ) & 414 & + zwz(ji,jj,jk) - zwz(ji ,jj ,jk+1) ) / e1e2t(ji,jj) 417 415 ! update and guess with monotonic sheme 418 pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) + ztra419 zwi(ji,jj,jk) = ( ptb(ji,jj,jk,jn) + z2dtt * ztra) * tmask(ji,jj,jk)416 pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) + ztra / fse3t_n(ji,jj,jk) * tmask(ji,jj,jk) 417 zwi(ji,jj,jk) = ( fse3t_b(ji,jj,jk) * ptb(ji,jj,jk,jn) + z2dtt * ztra ) / fse3t_a(ji,jj,jk) * tmask(ji,jj,jk) 420 418 END DO 421 419 END DO … … 438 436 ! -------------------------------------------------- 439 437 ! antidiffusive flux on i and j 440 441 442 DO jk = 1, jpkm1 443 438 ! 439 DO jk = 1, jpkm1 440 ! 444 441 DO jj = 1, jpjm1 445 442 DO ji = 1, fs_jpim1 ! vector opt. … … 564 561 ! 565 562 CALL wrk_dealloc( jpi, jpj, jpk, zwi, zwz, zhdiv, zwz_sav, zwzts ) 566 CALL wrk_dealloc( jpi, jpj, jpk, 3, ztrs )563 CALL wrk_dealloc( jpi, jpj, jpk, kjpt+1, ztrs ) 567 564 CALL wrk_dealloc( jpi, jpj, zwx_sav, zwy_sav ) 568 565 IF( l_trd ) CALL wrk_dealloc( jpi, jpj, jpk, ztrdx, ztrdy, ztrdz ) … … 571 568 ! 572 569 END SUBROUTINE tra_adv_tvd_zts 570 573 571 574 572 SUBROUTINE nonosc( pbef, paa, pbb, pcc, paft, p2dt ) -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/TRA/traldf.F90
r6836 r6839 68 68 ! 69 69 rldf = 1 ! For active tracers the 70 r_fact_lap(:,:,:) = 1.0 70 71 71 72 IF( l_trdtra ) THEN !* Save ta and sa trends … … 214 215 IF( ierr == 1 ) CALL ctl_stop( ' iso-level in z-coordinate - partial step, not allowed' ) 215 216 IF( ierr == 2 ) CALL ctl_stop( ' isoneutral bilaplacian operator does not exist' ) 217 IF( ln_traldf_grif .AND. ln_isfcav ) & 218 CALL ctl_stop( ' ice shelf and traldf_grif not tested') 216 219 IF( lk_traldf_eiv .AND. .NOT.ln_traldf_iso ) & 217 220 CALL ctl_stop( ' eddy induced velocity on tracers', & -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/TRA/tranxt.F90
r6836 r6839 28 28 USE sbc_oce ! surface boundary condition: ocean 29 29 USE sbcrnf ! river runoffs 30 USE sbcisf ! ice shelf melting/freezing 30 31 USE zdf_oce ! ocean vertical mixing 31 32 USE domvvl ! variable volume … … 46 47 USE timing ! Timing 47 48 #if defined key_agrif 48 USE agrif_opa_update49 49 USE agrif_opa_interp 50 50 #endif … … 110 110 ! Update after tracer on domain lateral boundaries 111 111 ! 112 #if defined key_agrif 113 CALL Agrif_tra ! AGRIF zoom boundaries 114 #endif 115 ! 112 116 CALL lbc_lnk( tsa(:,:,:,jp_tem), 'T', 1._wp ) ! local domain boundaries (T-point, unchanged sign) 113 117 CALL lbc_lnk( tsa(:,:,:,jp_sal), 'T', 1._wp ) … … 115 119 #if defined key_bdy 116 120 IF( lk_bdy ) CALL bdy_tra( kt ) ! BDY open boundaries 117 #endif118 #if defined key_agrif119 CALL Agrif_tra ! AGRIF zoom boundaries120 121 #endif 121 122 … … 148 149 ELSE ; CALL tra_nxt_fix( kt, nit000, 'TRA', tsb, tsn, tsa, jpts ) ! fixed volume level 149 150 ENDIF 150 ENDIF 151 ! 152 #if defined key_agrif 153 ! Update tracer at AGRIF zoom boundaries 154 IF( .NOT.Agrif_Root() ) CALL Agrif_Update_Tra( kt ) ! children only 155 #endif 156 ! 157 ! trends computation 151 ENDIF 152 ! 153 ! trends computation 158 154 IF( l_trdtra ) THEN ! trend of the Asselin filter (tb filtered - tb)/dt 159 155 DO jk = 1, jpkm1 … … 279 275 280 276 !! 281 LOGICAL :: ll_tra_hpg, ll_traqsr, ll_rnf ! local logical277 LOGICAL :: ll_tra_hpg, ll_traqsr, ll_rnf, ll_isf ! local logical 282 278 INTEGER :: ji, jj, jk, jn ! dummy loop indices 283 279 REAL(wp) :: zfact1, ztc_a , ztc_n , ztc_b , ztc_f , ztc_d ! local scalar … … 295 291 ll_traqsr = ln_traqsr ! active tracers case and solar penetration 296 292 ll_rnf = ln_rnf ! active tracers case and river runoffs 293 IF (nn_isf .GE. 1) THEN 294 ll_isf = .TRUE. ! active tracers case and ice shelf melting/freezing 295 ELSE 296 ll_isf = .FALSE. 297 END IF 297 298 ELSE 298 299 ll_tra_hpg = .FALSE. ! passive tracers case or NO semi-implicit hpg 299 300 ll_traqsr = .FALSE. ! active tracers case and NO solar penetration 300 301 ll_rnf = .FALSE. ! passive tracers or NO river runoffs 302 ll_isf = .FALSE. ! passive tracers or NO ice shelf melting/freezing 301 303 ENDIF 302 304 ! … … 321 323 ztc_f = ztc_n + atfp * ztc_d 322 324 ! 323 IF( jk == 1 ) THEN ! first level 324 ze3t_f = ze3t_f - zfact2 * ( emp_b(ji,jj) - emp(ji,jj) + rnf(ji,jj) - rnf_b(ji,jj) ) 325 IF( jk == mikt(ji,jj) ) THEN ! first level 326 ze3t_f = ze3t_f - zfact2 * ( (emp_b(ji,jj) - emp(ji,jj) ) & 327 & - (rnf_b(ji,jj) - rnf(ji,jj) ) & 328 & + (fwfisf_b(ji,jj) - fwfisf(ji,jj)) ) 325 329 ztc_f = ztc_f - zfact1 * ( psbc_tc(ji,jj,jn) - psbc_tc_b(ji,jj,jn) ) 326 330 ENDIF 327 331 328 IF( ll_traqsr .AND. jn == jp_tem .AND. jk <= nksr ) & ! solar penetration (temperature only) 332 ! solar penetration (temperature only) 333 IF( ll_traqsr .AND. jn == jp_tem .AND. jk <= nksr ) & 329 334 & ztc_f = ztc_f - zfact1 * ( qsr_hc(ji,jj,jk) - qsr_hc_b(ji,jj,jk) ) 330 335 331 IF( ll_rnf .AND. jk <= nk_rnf(ji,jj) ) & ! river runoffs 336 ! river runoff 337 IF( ll_rnf .AND. jk <= nk_rnf(ji,jj) ) & 332 338 & ztc_f = ztc_f - zfact1 * ( rnf_tsc(ji,jj,jn) - rnf_tsc_b(ji,jj,jn) ) & 333 339 & * fse3t_n(ji,jj,jk) / h_rnf(ji,jj) 340 341 ! ice shelf 342 IF( ll_isf ) THEN 343 ! level fully include in the Losch_2008 ice shelf boundary layer 344 IF ( jk >= misfkt(ji,jj) .AND. jk < misfkb(ji,jj) ) & 345 ztc_f = ztc_f - zfact1 * ( risf_tsc(ji,jj,jn) - risf_tsc_b(ji,jj,jn) ) & 346 & * fse3t_n(ji,jj,jk) * r1_hisf_tbl (ji,jj) 347 ! level partially include in Losch_2008 ice shelf boundary layer 348 IF ( jk == misfkb(ji,jj) ) & 349 ztc_f = ztc_f - zfact1 * ( risf_tsc(ji,jj,jn) - risf_tsc_b(ji,jj,jn) ) & 350 & * fse3t_n(ji,jj,jk) * r1_hisf_tbl (ji,jj) * ralpha(ji,jj) 351 END IF 334 352 335 353 ze3t_f = 1.e0 / ze3t_f -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/TRA/traqsr.F90
r6836 r6839 10 10 !! - ! 2005-11 (G. Madec) zco, zps, sco coordinate 11 11 !! 3.2 ! 2009-04 (G. Madec & NEMO team) 12 !! 4.0 ! 2012-05 (C. Rousset) store attenuation coef for use in ice model 12 !! 3.4 ! 2012-05 (C. Rousset) store attenuation coef for use in ice model 13 !! 3.6 ! 2015-12 (O. Aumont, J. Jouanno, C. Ethe) use vertical profile of chlorophyll 13 14 !!---------------------------------------------------------------------- 14 15 … … 93 94 !! Reference : Jerlov, N. G., 1968 Optical Oceanography, Elsevier, 194pp. 94 95 !! Lengaigne et al. 2007, Clim. Dyn., V28, 5, 503-516. 96 !! Morel, A. et Berthon, JF, 1989, Limnol Oceanogr 34(8), 1545-1562 95 97 !!---------------------------------------------------------------------- 96 98 ! … … 101 103 REAL(wp) :: zchl, zcoef, zfact ! local scalars 102 104 REAL(wp) :: zc0, zc1, zc2, zc3 ! - - 103 REAL(wp) :: zzc0, zzc1, zzc2, zzc3 ! - -104 105 REAL(wp) :: zz0, zz1, z1_e3t ! - - 106 REAL(wp) :: zCb, zCmax, zze, zpsi, zpsimax, zdelpsi, zCtot, zCze 107 REAL(wp) :: zlogc, zlogc2, zlogc3 105 108 REAL(wp), POINTER, DIMENSION(:,: ) :: zekb, zekg, zekr 106 REAL(wp), POINTER, DIMENSION(:,:,:) :: ze0, ze1, ze2, ze3, zea, ztrdt 107 !!---------------------------------------------------------------------- 109 REAL(wp), POINTER, DIMENSION(:,:,:) :: ze0, ze1, ze2, ze3, zea, ztrdt, zchl3d 110 !!-------------------------------------------------------------------------- 108 111 ! 109 112 IF( nn_timing == 1 ) CALL timing_start('tra_qsr') 110 113 ! 111 114 CALL wrk_alloc( jpi, jpj, zekb, zekg, zekr ) 112 CALL wrk_alloc( jpi, jpj, jpk, ze0, ze1, ze2, ze3, zea )115 CALL wrk_alloc( jpi, jpj, jpk, ze0, ze1, ze2, ze3, zea, zchl3d ) 113 116 ! 114 117 IF( kt == nit000 ) THEN … … 183 186 ! ! ------------------------- ! 184 187 ! Set chlorophyl concentration 185 IF( nn_chldta == 1 .OR. lk_vvl ) THEN !* Variable Chlorophyll or ocean volume 186 ! 187 IF( nn_chldta == 1 ) THEN !* Variable Chlorophyll 188 ! 189 CALL fld_read( kt, 1, sf_chl ) ! Read Chl data and provides it at the current time step 190 ! 191 !CDIR COLLAPSE 188 IF( nn_chldta == 1 .OR. nn_chldta == 2 .OR. lk_vvl ) THEN !* Variable Chlorophyll or ocean volume 189 ! 190 IF( nn_chldta == 1 ) THEN !* 2D Variable Chlorophyll 191 ! 192 CALL fld_read( kt, 1, sf_chl ) ! Read Chl data and provides it at the current time step 193 DO jk = 1, nksr + 1 194 zchl3d(:,:,jk) = sf_chl(1)%fnow(:,:,1) 195 ENDDO 196 ! 197 ELSE IF( nn_chldta == 2 ) THEN !* -3-D Variable Chlorophyll 198 ! 199 CALL fld_read( kt, 1, sf_chl ) ! Read Chl data and provides it at the current time step 200 !CDIR NOVERRCHK ! 201 DO jj = 1, jpj 192 202 !CDIR NOVERRCHK 193 DO jj = 1, jpj ! Separation in R-G-B depending of the surface Chl 194 !CDIR NOVERRCHK 195 DO ji = 1, jpi 196 zchl = MIN( 10. , MAX( 0.03, sf_chl(1)%fnow(ji,jj,1) ) ) 197 irgb = NINT( 41 + 20.*LOG10(zchl) + 1.e-15 ) 198 zekb(ji,jj) = rkrgb(1,irgb) 199 zekg(ji,jj) = rkrgb(2,irgb) 200 zekr(ji,jj) = rkrgb(3,irgb) 201 END DO 202 END DO 203 ELSE ! Variable ocean volume but constant chrlorophyll 204 zchl = 0.05 ! constant chlorophyll 205 irgb = NINT( 41 + 20.*LOG10( zchl ) + 1.e-15 ) 206 zekb(:,:) = rkrgb(1,irgb) ! Separation in R-G-B depending of the chlorophyll 207 zekg(:,:) = rkrgb(2,irgb) 208 zekr(:,:) = rkrgb(3,irgb) 203 DO ji = 1, jpi 204 zchl = sf_chl(1)%fnow(ji,jj,1) 205 zCtot = 40.6 * zchl**0.459 206 zze = 568.2 * zCtot**(-0.746) 207 IF( zze > 102. ) zze = 200.0 * zCtot**(-0.293) 208 zlogc = LOG( zchl ) 209 zlogc2 = zlogc * zlogc 210 zlogc3 = zlogc * zlogc * zlogc 211 zCb = 0.768 + 0.087 * zlogc - 0.179 * zlogc2 - 0.025 * zlogc3 212 zCmax = 0.299 - 0.289 * zlogc + 0.579 * zlogc2 213 zpsimax = 0.6 - 0.640 * zlogc + 0.021 * zlogc2 + 0.115 * zlogc3 214 zdelpsi = 0.710 + 0.159 * zlogc + 0.021 * zlogc2 215 zCze = 1.12 * (zchl)**0.803 216 DO jk = 1, nksr + 1 217 zpsi = fsdept(ji,jj,jk) / zze 218 zchl3d(ji,jj,jk) = zCze * ( zCb + zCmax * EXP( -( (zpsi - zpsimax) / zdelpsi )**2 ) ) 219 END DO 220 ! 221 END DO 222 END DO 223 ! 224 ELSE !* Variable ocean volume but constant chrlorophyll 225 DO jk = 1, nksr + 1 226 zchl3d(:,:,jk) = 0.05 227 ENDDO 209 228 ENDIF 210 229 ! 211 zcoef = ( 1. - rn_abs ) / 3.e0 ! equi-partition in R-G-B230 zcoef = ( 1. - rn_abs ) / 3.e0 ! equi-partition in R-G-B 212 231 ze0(:,:,1) = rn_abs * qsr(:,:) 213 232 ze1(:,:,1) = zcoef * qsr(:,:) … … 217 236 ! 218 237 DO jk = 2, nksr+1 238 ! 239 DO jj = 1, jpj ! Separation in R-G-B depending of vertical profile of Chl 240 !CDIR NOVERRCHK 241 DO ji = 1, jpi 242 zchl = MIN( 10. , MAX( 0.03, zchl3d(ji,jj,jk) ) ) 243 irgb = NINT( 41 + 20.*LOG10(zchl) + 1.e-15 ) 244 zekb(ji,jj) = rkrgb(1,irgb) 245 zekg(ji,jj) = rkrgb(2,irgb) 246 zekr(ji,jj) = rkrgb(3,irgb) 247 END DO 248 END DO 219 249 !CDIR NOVERRCHK 220 250 DO jj = 1, jpj … … 233 263 END DO 234 264 END DO 235 ! clem: store attenuation coefficient of the first ocean level236 IF ( ln_qsr_ice ) THEN237 DO jj = 1, jpj238 DO ji = 1, jpi239 zzc0 = rn_abs * EXP( - fse3t(ji,jj,1) * xsi0r )240 zzc1 = zcoef * EXP( - fse3t(ji,jj,1) * zekb(ji,jj) )241 zzc2 = zcoef * EXP( - fse3t(ji,jj,1) * zekg(ji,jj) )242 zzc3 = zcoef * EXP( - fse3t(ji,jj,1) * zekr(ji,jj) )243 fraqsr_1lev(ji,jj) = 1.0 - ( zzc0 + zzc1 + zzc2 + zzc3 ) * tmask(ji,jj,2)244 END DO245 END DO246 ENDIF247 265 ! 248 266 DO jk = 1, nksr ! compute and add qsr trend to ta … … 251 269 zea(:,:,nksr+1:jpk) = 0.e0 ! below 400m set to zero 252 270 CALL iom_put( 'qsr3d', zea ) ! Shortwave Radiation 3D distribution 271 ! 272 IF ( ln_qsr_ice ) THEN ! store attenuation coefficient of the first ocean level 273 !CDIR NOVERRCHK 274 DO jj = 1, jpj ! Separation in R-G-B depending of the surface Chl 275 !CDIR NOVERRCHK 276 DO ji = 1, jpi 277 zchl = MIN( 10. , MAX( 0.03, zchl3d(ji,jj,1) ) ) 278 irgb = NINT( 41 + 20.*LOG10(zchl) + 1.e-15 ) 279 zekb(ji,jj) = rkrgb(1,irgb) 280 zekg(ji,jj) = rkrgb(2,irgb) 281 zekr(ji,jj) = rkrgb(3,irgb) 282 END DO 283 END DO 284 ! 285 DO jj = 1, jpj 286 DO ji = 1, jpi 287 zc0 = rn_abs * EXP( - fse3t(ji,jj,1) * xsi0r ) 288 zc1 = zcoef * EXP( - fse3t(ji,jj,1) * zekb(ji,jj) ) 289 zc2 = zcoef * EXP( - fse3t(ji,jj,1) * zekg(ji,jj) ) 290 zc3 = zcoef * EXP( - fse3t(ji,jj,1) * zekr(ji,jj) ) 291 fraqsr_1lev(ji,jj) = 1.0 - ( zc0 + zc1 + zc2 + zc3 ) * tmask(ji,jj,2) 292 END DO 293 END DO 294 ! 295 ENDIF 253 296 ! 254 297 ELSE !* Constant Chlorophyll … … 256 299 qsr_hc(:,:,jk) = etot3(:,:,jk) * qsr(:,:) 257 300 END DO 258 ! clem:store attenuation coefficient of the first ocean level259 IF 301 ! store attenuation coefficient of the first ocean level 302 IF( ln_qsr_ice ) THEN 260 303 fraqsr_1lev(:,:) = etot3(:,:,1) / r1_rau0_rcp 261 304 ENDIF … … 339 382 ! 340 383 CALL wrk_dealloc( jpi, jpj, zekb, zekg, zekr ) 341 CALL wrk_dealloc( jpi, jpj, jpk, ze0, ze1, ze2, ze3, zea )384 CALL wrk_dealloc( jpi, jpj, jpk, ze0, ze1, ze2, ze3, zea, zchl3d ) 342 385 ! 343 386 IF( nn_timing == 1 ) CALL timing_stop('tra_qsr') … … 405 448 WRITE(numout,*) ' bio-model light penetration ln_qsr_bio = ', ln_qsr_bio 406 449 WRITE(numout,*) ' light penetration for ice-model LIM3 ln_qsr_ice = ', ln_qsr_ice 407 WRITE(numout,*) ' RGB : Chl data (=1 ) or cst value (=0)nn_chldta = ', nn_chldta450 WRITE(numout,*) ' RGB : Chl data (=1/2) or cst value (=0) nn_chldta = ', nn_chldta 408 451 WRITE(numout,*) ' RGB & 2 bands: fraction of light (rn_si1) rn_abs = ', rn_abs 409 452 WRITE(numout,*) ' RGB & 2 bands: shortess depth of extinction rn_si0 = ', rn_si0 … … 429 472 IF( ln_qsr_rgb .AND. nn_chldta == 0 ) nqsr = 1 430 473 IF( ln_qsr_rgb .AND. nn_chldta == 1 ) nqsr = 2 431 IF( ln_qsr_2bd ) nqsr = 3 432 IF( ln_qsr_bio ) nqsr = 4 474 IF( ln_qsr_rgb .AND. nn_chldta == 2 ) nqsr = 3 475 IF( ln_qsr_2bd ) nqsr = 4 476 IF( ln_qsr_bio ) nqsr = 5 433 477 ! 434 478 IF(lwp) THEN ! Print the choice 435 479 WRITE(numout,*) 436 480 IF( nqsr == 1 ) WRITE(numout,*) ' R-G-B light penetration - Constant Chlorophyll' 437 IF( nqsr == 2 ) WRITE(numout,*) ' R-G-B light penetration - Chl data ' 438 IF( nqsr == 3 ) WRITE(numout,*) ' 2 bands light penetration' 439 IF( nqsr == 4 ) WRITE(numout,*) ' bio-model light penetration' 481 IF( nqsr == 2 ) WRITE(numout,*) ' R-G-B light penetration - 2D Chl data ' 482 IF( nqsr == 3 ) WRITE(numout,*) ' R-G-B light penetration - 3D Chl data ' 483 IF( nqsr == 4 ) WRITE(numout,*) ' 2 bands light penetration' 484 IF( nqsr == 5 ) WRITE(numout,*) ' bio-model light penetration' 440 485 ENDIF 441 486 ! … … 460 505 IF(lwp) WRITE(numout,*) ' level of light extinction = ', nksr, ' ref depth = ', gdepw_1d(nksr+1), ' m' 461 506 ! 462 IF( nn_chldta == 1 ) THEN !* Chl data : set sf_chl structure507 IF( nn_chldta == 1 .OR. nn_chldta == 2 ) THEN !* Chl data : set sf_chl structure 463 508 IF(lwp) WRITE(numout,*) 464 509 IF(lwp) WRITE(numout,*) ' Chlorophyll read in a file' -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/TRA/trasbc.F90
r6836 r6839 120 120 REAL(wp) :: zfact, z1_e3t, zdep 121 121 REAL(wp) :: zalpha, zhk 122 REAL(wp) :: zt_frz, zpress123 122 REAL(wp), POINTER, DIMENSION(:,:,:) :: ztrdt, ztrds 124 123 !!---------------------------------------------------------------------- … … 159 158 ELSE ! No restart or restart not found: Euler forward time stepping 160 159 zfact = 1._wp 160 sbc_tsc(:,:,:) = 0._wp 161 161 sbc_tsc_b(:,:,:) = 0._wp 162 162 ENDIF … … 232 232 DO jk = ikt, ikb - 1 233 233 ! compute tfreez for the temperature correction (we add water at freezing temperature) 234 ! zpress = grav*rau0*fsdept(ji,jj,jk)*1.e-04235 zt_frz = -1.9 !eos_fzp( tsn(ji,jj,jk,jp_sal), zpress )236 234 ! compute trend 237 235 tsa(ji,jj,jk,jp_tem) = tsa(ji,jj,jk,jp_tem) & 238 & + zfact * (risf_tsc_b(ji,jj,jp_tem) + risf_tsc(ji,jj,jp_tem) & 239 & - rdivisf * (fwfisf(ji,jj) + fwfisf_b(ji,jj)) * zt_frz * r1_rau0) & 240 & * r1_hisf_tbl(ji,jj) 236 & + zfact * (risf_tsc_b(ji,jj,jp_tem) + risf_tsc(ji,jj,jp_tem)) * r1_hisf_tbl(ji,jj) 241 237 tsa(ji,jj,jk,jp_sal) = tsa(ji,jj,jk,jp_sal) & 242 238 & + zfact * (risf_tsc_b(ji,jj,jp_sal) + risf_tsc(ji,jj,jp_sal)) * r1_hisf_tbl(ji,jj) … … 245 241 ! level partially include in ice shelf boundary layer 246 242 ! compute tfreez for the temperature correction (we add water at freezing temperature) 247 ! zpress = grav*rau0*fsdept(ji,jj,ikb)*1.e-04248 zt_frz = -1.9 !eos_fzp( tsn(ji,jj,ikb,jp_sal), zpress )249 243 ! compute trend 250 244 tsa(ji,jj,ikb,jp_tem) = tsa(ji,jj,ikb,jp_tem) & 251 & + zfact * (risf_tsc_b(ji,jj,jp_tem) + risf_tsc(ji,jj,jp_tem) & 252 & - rdivisf * (fwfisf(ji,jj) + fwfisf_b(ji,jj)) * zt_frz * r1_rau0) & 253 & * r1_hisf_tbl(ji,jj) * ralpha(ji,jj) 245 & + zfact * (risf_tsc_b(ji,jj,jp_tem) + risf_tsc(ji,jj,jp_tem)) * r1_hisf_tbl(ji,jj) * ralpha(ji,jj) 254 246 tsa(ji,jj,ikb,jp_sal) = tsa(ji,jj,ikb,jp_sal) & 255 247 & + zfact * (risf_tsc_b(ji,jj,jp_sal) + risf_tsc(ji,jj,jp_sal)) * r1_hisf_tbl(ji,jj) * ralpha(ji,jj) … … 287 279 END DO 288 280 ENDIF 289 281 282 IF( iom_use('rnf_x_sst') ) CALL iom_put( "rnf_x_sst", rnf*tsn(:,:,1,jp_tem) ) ! runoff term on sst 283 IF( iom_use('rnf_x_sss') ) CALL iom_put( "rnf_x_sss", rnf*tsn(:,:,1,jp_sal) ) ! runoff term on sss 284 290 285 IF( l_trdtra ) THEN ! send trends for further diagnostics 291 286 ztrdt(:,:,:) = tsa(:,:,:,jp_tem) - ztrdt(:,:,:) -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/TRD/trdken.F90
r6836 r6839 117 117 ! 118 118 SELECT CASE( ktrd ) 119 120 121 122 123 124 125 126 127 128 119 CASE( jpdyn_hpg ) ; CALL iom_put( "ketrd_hpg", zke ) ! hydrostatic pressure gradient 120 CASE( jpdyn_spg ) ; CALL iom_put( "ketrd_spg", zke ) ! surface pressure gradient 121 CASE( jpdyn_spgexp ); CALL iom_put( "ketrd_spgexp", zke ) ! surface pressure gradient (explicit) 122 CASE( jpdyn_spgflt ); CALL iom_put( "ketrd_spgflt", zke ) ! surface pressure gradient (filter) 123 CASE( jpdyn_pvo ) ; CALL iom_put( "ketrd_pvo", zke ) ! planetary vorticity 124 CASE( jpdyn_rvo ) ; CALL iom_put( "ketrd_rvo", zke ) ! relative vorticity (or metric term) 125 CASE( jpdyn_keg ) ; CALL iom_put( "ketrd_keg", zke ) ! Kinetic Energy gradient (or had) 126 CASE( jpdyn_zad ) ; CALL iom_put( "ketrd_zad", zke ) ! vertical advection 127 CASE( jpdyn_ldf ) ; CALL iom_put( "ketrd_ldf", zke ) ! lateral diffusion 128 CASE( jpdyn_zdf ) ; CALL iom_put( "ketrd_zdf", zke ) ! vertical diffusion 129 129 ! ! wind stress trends 130 131 132 133 134 135 136 137 138 139 140 141 142 130 CALL wrk_alloc( jpi, jpj, z2dx, z2dy, zke2d ) 131 z2dx(:,:) = un(:,:,1) * ( utau_b(:,:) + utau(:,:) ) * e1u(:,:) * e2u(:,:) * umask(:,:,1) 132 z2dy(:,:) = vn(:,:,1) * ( vtau_b(:,:) + vtau(:,:) ) * e1v(:,:) * e2v(:,:) * vmask(:,:,1) 133 zke2d(1,:) = 0._wp ; zke2d(:,1) = 0._wp 134 DO jj = 2, jpj 135 DO ji = 2, jpi 136 zke2d(ji,jj) = 0.5_wp * ( z2dx(ji,jj) + z2dx(ji-1,jj) & 137 & + z2dy(ji,jj) + z2dy(ji,jj-1) ) * r1_bt(ji,jj,1) 138 END DO 139 END DO 140 CALL iom_put( "ketrd_tau", zke2d ) 141 CALL wrk_dealloc( jpi, jpj , z2dx, z2dy, zke2d ) 142 CASE( jpdyn_bfr ) ; CALL iom_put( "ketrd_bfr", zke ) ! bottom friction (explicit case) 143 143 !!gm TO BE DONE properly 144 144 !!gm only valid if ln_bfrimp=F otherwise the bottom stress as to be recomputed at the end of the computation.... … … 162 162 ! ENDIF 163 163 !!gm end 164 164 CASE( jpdyn_atf ) ; CALL iom_put( "ketrd_atf", zke ) ! asselin filter trends 165 165 !! a faire !!!! idee changer dynnxt pour avoir un appel a jpdyn_bfr avant le swap !!! 166 166 !! reflechir a une possible sauvegarde du "vrai" un,vn pour le calcul de atf.... … … 184 184 ! CALL iom_put( "ketrd_bfri", zke2d ) 185 185 ! ENDIF 186 187 188 189 190 191 192 193 186 CASE( jpdyn_ken ) ; ! kinetic energy 187 ! called in dynnxt.F90 before asselin time filter 188 ! with putrd=ua and pvtrd=va 189 zke(:,:,:) = 0.5_wp * zke(:,:,:) 190 CALL iom_put( "KE", zke ) 191 ! 192 CALL ken_p2k( kt , zke ) 193 CALL iom_put( "ketrd_convP2K", zke ) ! conversion -rau*g*w 194 194 ! 195 195 END SELECT -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/TRD/trdmxl.F90
r6836 r6839 165 165 166 166 167 168 167 SELECT CASE( ktrd ) 168 CASE( jptra_npc ) ! non-penetrative convection: regrouped with zdf 169 169 !!gm : to be completed ! 170 ! 170 ! IF( .... 171 171 !!gm end 172 173 172 CASE( jptra_zdfp ) ! iso-neutral diffusion: "pure" vertical diffusion 173 ! ! regroup iso-neutral diffusion in one term 174 174 tmltrd(:,:,jpmxl_ldf) = tmltrd(:,:,jpmxl_ldf) + ( tmltrd(:,:,jpmxl_zdf) - tmltrd(:,:,jpmxl_zdfp) ) 175 175 smltrd(:,:,jpmxl_ldf) = smltrd(:,:,jpmxl_ldf) + ( smltrd(:,:,jpmxl_zdf) - smltrd(:,:,jpmxl_zdfp) ) … … 811 811 812 812 813 813 nkstp = nit000 - 1 ! current time step indicator initialization 814 814 815 815 … … 851 851 IF( nn_ctls == 1 ) THEN 852 852 CALL ctl_opn( inum, 'ctlsurf_idx', 'OLD', 'UNFORMATTED', 'SEQUENTIAL', -1, numout, lwp ) 853 READ ( inum ) nbol853 READ ( inum, * ) nbol 854 854 CLOSE( inum ) 855 855 END IF -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/TRD/trdmxl_oce.F90
r6836 r6839 15 15 16 16 ! !* mixed layer trend indices 17 INTEGER, PUBLIC, PARAMETER :: jpltrd = 1 1!: number of mixed-layer trends arrays17 INTEGER, PUBLIC, PARAMETER :: jpltrd = 12 !: number of mixed-layer trends arrays 18 18 INTEGER, PUBLIC :: jpktrd !: max level for mixed-layer trends diag. 19 19 ! … … 28 28 INTEGER, PUBLIC, PARAMETER :: jpmxl_for = 9 !: forcing 29 29 INTEGER, PUBLIC, PARAMETER :: jpmxl_dmp = 10 !: internal restoring trend 30 INTEGER, PUBLIC, PARAMETER :: jpmxl_zdfp = 11 !: asselin trend (**MUST BE THE LAST ONE**)31 INTEGER, PUBLIC, PARAMETER :: jpmxl_atf = 12 30 INTEGER, PUBLIC, PARAMETER :: jpmxl_zdfp = 11 !: iso-neutral diffusion:"pure" vertical diffusion 31 INTEGER, PUBLIC, PARAMETER :: jpmxl_atf = 12 !: asselin trend (**MUST BE THE LAST ONE**) 32 32 ! !!* Namelist namtrd_mxl: trend diagnostics in the mixed layer * 33 33 INTEGER , PUBLIC :: nn_ctls = 0 !: control surface type for trends vertical integration -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/TRD/trdpen.F90
r6836 r6839 99 99 CALL wrk_alloc( jpi, jpj, z2d ) 100 100 z2d(:,:) = wn(:,:,1) * ( & 101 102 103 &) / fse3t(:,:,1)101 & - ( rab_n(:,:,1,jp_tem) + rab_pe(:,:,1,jp_tem) ) * tsn(:,:,1,jp_tem) & 102 & + ( rab_n(:,:,1,jp_sal) + rab_pe(:,:,1,jp_sal) ) * tsn(:,:,1,jp_sal) & 103 & ) / fse3t(:,:,1) 104 104 CALL iom_put( "petrd_sad" , z2d ) 105 105 CALL wrk_dealloc( jpi, jpj, z2d ) -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/ZDF/zdf_oce.F90
r6836 r6839 43 43 REAL(wp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: avmu , avmv !: vertical viscosity coef at uw- & vw-pts [m2/s] 44 44 REAL(wp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: avm , avt !: vertical viscosity & diffusivity coef at w-pt [m2/s] 45 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: avt_k , avm_k ! not enhanced Kz 46 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: avmu_k, avmv_k ! not enhanced Kz 47 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: en !: now turbulent kinetic energy [m2/s2] 45 48 46 49 !!---------------------------------------------------------------------- … … 60 63 & tfrua(jpi, jpj), tfrva(jpi, jpj) , & 61 64 & avmu(jpi,jpj,jpk), avm(jpi,jpj,jpk) , & 62 & avmv(jpi,jpj,jpk), avt(jpi,jpj,jpk) , STAT = zdf_oce_alloc ) 65 & avmv (jpi,jpj,jpk), avt (jpi,jpj,jpk) , & 66 & avt_k (jpi,jpj,jpk), avm_k (jpi,jpj,jpk) , & 67 & avmu_k(jpi,jpj,jpk), avmv_k(jpi,jpj,jpk) , & 68 & en (jpi,jpj,jpk), STAT = zdf_oce_alloc ) 63 69 ! 64 70 IF( zdf_oce_alloc /= 0 ) CALL ctl_warn('zdf_oce_alloc: failed to allocate arrays') -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfddm.F90
r6836 r6839 177 177 & + 0.15 * zrau(ji,jj) * zmskd2(ji,jj) ) 178 178 ! add to the eddy viscosity coef. previously computed 179 # if defined key_zdftmx_new 180 ! key_zdftmx_new: New internal wave-driven param: use avs value computed by zdftmx 181 avs (ji,jj,jk) = avs(ji,jj,jk) + zavfs + zavds 182 # else 179 183 avs (ji,jj,jk) = avt(ji,jj,jk) + zavfs + zavds 184 # endif 180 185 avt (ji,jj,jk) = avt(ji,jj,jk) + zavft + zavdt 181 186 avm (ji,jj,jk) = avm(ji,jj,jk) + MAX( zavft + zavdt, zavfs + zavds ) -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfgls.F90
r6836 r6839 42 42 LOGICAL , PUBLIC, PARAMETER :: lk_zdfgls = .TRUE. !: TKE vertical mixing flag 43 43 ! 44 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: en !: now turbulent kinetic energy45 44 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: mxln !: now mixing length 46 45 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: zwall !: wall function 47 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: avt_k ! not enhanced Kz48 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: avm_k ! not enhanced Kz49 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: avmu_k ! not enhanced Kz50 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: avmv_k ! not enhanced Kz51 46 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ustars2 !: Squared surface velocity scale at T-points 52 47 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ustarb2 !: Squared bottom velocity scale at T-points … … 120 115 !! *** FUNCTION zdf_gls_alloc *** 121 116 !!---------------------------------------------------------------------- 122 ALLOCATE( en(jpi,jpj,jpk), mxln(jpi,jpj,jpk), zwall(jpi,jpj,jpk) , & 123 & avt_k (jpi,jpj,jpk) , avm_k (jpi,jpj,jpk), & 124 & avmu_k(jpi,jpj,jpk) , avmv_k(jpi,jpj,jpk), & 125 & ustars2(jpi,jpj), ustarb2(jpi,jpj) , STAT= zdf_gls_alloc ) 117 ALLOCATE( mxln(jpi,jpj,jpk), zwall(jpi,jpj,jpk) , & 118 & ustars2(jpi,jpj) , ustarb2(jpi,jpj) , STAT= zdf_gls_alloc ) 126 119 ! 127 120 IF( lk_mpp ) CALL mpp_sum ( zdf_gls_alloc ) … … 329 322 ! 330 323 ! One level below 331 en(:,:,2) = rc02r * ustars2(:,:) * (1._wp + rsbc_tke1 * ((zhsro(:,:)+fsdepw(:,:,2))/zhsro(:,:) )**(1.5_wp*ra_sf))**(2._wp/3._wp) 324 en(:,:,2) = rc02r * ustars2(:,:) * (1._wp + rsbc_tke1 * ((zhsro(:,:)+fsdepw(:,:,2)) & 325 & / zhsro(:,:) )**(1.5_wp*ra_sf))**(2._wp/3._wp) 332 326 en(:,:,2) = MAX(en(:,:,2), rn_emin ) 333 327 z_elem_a(:,:,2) = 0._wp … … 350 344 z_elem_a(:,:,2) = 0._wp 351 345 zkar(:,:) = (rl_sf + (vkarmn-rl_sf)*(1.-exp(-rtrans*fsdept(:,:,1)/zhsro(:,:)) )) 352 zflxs(:,:) = rsbc_tke2 * ustars2(:,:)**1.5_wp * zkar(:,:) * ((zhsro(:,:)+fsdept(:,:,1))/zhsro(:,:) )**(1.5_wp*ra_sf) 346 zflxs(:,:) = rsbc_tke2 * ustars2(:,:)**1.5_wp * zkar(:,:) & 347 & * ((zhsro(:,:)+fsdept(:,:,1))/zhsro(:,:) )**(1.5_wp*ra_sf) 353 348 354 349 en(:,:,2) = en(:,:,2) + zflxs(:,:)/fse3w(:,:,2) -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfmxl.F90
r6836 r6839 27 27 28 28 PUBLIC zdf_mxl ! called by step.F90 29 PUBLIC zdf_mxl_alloc ! Used in zdf_tke_init 29 30 30 31 INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: nmln !: number of level in the mixed layer (used by TOP) … … 79 80 INTEGER, INTENT(in) :: kt ! ocean time-step index 80 81 ! 81 INTEGER :: ji, jj, jk ! dummy loop indices82 INTEGER :: iikn, iiki, ikt , imkt! local integer83 REAL(wp) :: zN2_c ! local scalar82 INTEGER :: ji, jj, jk ! dummy loop indices 83 INTEGER :: iikn, iiki, ikt ! local integer 84 REAL(wp) :: zN2_c ! local scalar 84 85 INTEGER, POINTER, DIMENSION(:,:) :: imld ! 2D workspace 85 86 !!---------------------------------------------------------------------- … … 116 117 DO jj = 1, jpj 117 118 DO ji = 1, jpi 118 imkt = mikt(ji,jj) 119 IF( avt (ji,jj,jk) < avt_c ) imld(ji,jj) = MAX( imkt, jk ) ! Turbocline 119 IF( avt (ji,jj,jk) < avt_c * wmask(ji,jj,jk) ) imld(ji,jj) = jk ! Turbocline 120 120 END DO 121 121 END DO … … 126 126 iiki = imld(ji,jj) 127 127 iikn = nmln(ji,jj) 128 imkt = mikt(ji,jj) 129 hmld (ji,jj) = ( fsdepw(ji,jj,iiki ) - fsdepw(ji,jj,imkt ) ) * ssmask(ji,jj) ! Turbocline depth 130 hmlp (ji,jj) = ( fsdepw(ji,jj,iikn ) - fsdepw(ji,jj,MAX( imkt,nla10 ) ) ) * ssmask(ji,jj) ! Mixed layer depth 131 hmlpt(ji,jj) = ( fsdept(ji,jj,iikn-1) - fsdepw(ji,jj,imkt ) ) * ssmask(ji,jj) ! depth of the last T-point inside the mixed layer 128 hmld (ji,jj) = fsdepw(ji,jj,iiki ) * ssmask(ji,jj) ! Turbocline depth 129 hmlp (ji,jj) = fsdepw(ji,jj,iikn ) * ssmask(ji,jj) ! Mixed layer depth 130 hmlpt(ji,jj) = fsdept(ji,jj,iikn-1) * ssmask(ji,jj) ! depth of the last T-point inside the mixed layer 132 131 END DO 133 132 END DO 134 IF( .NOT.lk_offline ) THEN ! no need to output in offline mode 135 CALL iom_put( "mldr10_1", hmlp ) ! mixed layer depth 136 CALL iom_put( "mldkz5" , hmld ) ! turbocline depth 133 ! no need to output in offline mode 134 IF( .NOT.lk_offline ) THEN 135 IF ( iom_use("mldr10_1") ) THEN 136 IF( ln_isfcav ) THEN 137 CALL iom_put( "mldr10_1", hmlp - risfdep) ! mixed layer thickness 138 ELSE 139 CALL iom_put( "mldr10_1", hmlp ) ! mixed layer depth 140 END IF 141 END IF 142 IF ( iom_use("mldkz5") ) THEN 143 IF( ln_isfcav ) THEN 144 CALL iom_put( "mldkz5" , hmld - risfdep ) ! turbocline thickness 145 ELSE 146 CALL iom_put( "mldkz5" , hmld ) ! turbocline depth 147 END IF 148 END IF 137 149 ENDIF 138 150 -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/ZDF/zdftke.F90
r6836 r6839 53 53 USE timing ! Timing 54 54 USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 55 #if defined key_agrif 56 USE agrif_opa_interp 57 USE agrif_opa_update 58 #endif 59 60 55 61 56 62 IMPLICIT NONE … … 85 91 REAL(wp) :: rhftau_scl = 1.0_wp ! scale factor applied to HF part of taum (nn_etau=3) 86 92 87 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: en !: now turbulent kinetic energy [m2/s2]88 93 REAL(wp) , ALLOCATABLE, SAVE, DIMENSION(:,:) :: htau ! depth of tke penetration (nn_htau) 89 94 REAL(wp) , ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: dissl ! now mixing lenght of dissipation 90 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: avt_k , avm_k ! not enhanced Kz91 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: avmu_k, avmv_k ! not enhanced Kz92 95 #if defined key_c1d 93 96 ! !!** 1D cfg only ** ('key_c1d') … … 115 118 & e_pdl(jpi,jpj,jpk) , e_ric(jpi,jpj,jpk) , & 116 119 #endif 117 & en (jpi,jpj,jpk) , htau (jpi,jpj) , dissl(jpi,jpj,jpk) , & 118 & avt_k (jpi,jpj,jpk) , avm_k (jpi,jpj,jpk), & 119 & avmu_k(jpi,jpj,jpk) , avmv_k(jpi,jpj,jpk), STAT= zdf_tke_alloc ) 120 & htau (jpi,jpj) , dissl(jpi,jpj,jpk) , STAT= zdf_tke_alloc ) 120 121 ! 121 122 IF( lk_mpp ) CALL mpp_sum ( zdf_tke_alloc ) … … 189 190 avmv_k(:,:,:) = avmv(:,:,:) 190 191 ! 192 #if defined key_agrif 193 ! Update child grid f => parent grid 194 IF( .NOT.Agrif_Root() ) CALL Agrif_Update_Tke( kt ) ! children only 195 #endif 196 ! 191 197 END SUBROUTINE zdf_tke 192 198 … … 317 323 zwlc = zind * rn_lc * zus * SIN( rpi * fsdepw(ji,jj,jk) / zhlc(ji,jj) ) 318 324 ! ! TKE Langmuir circulation source term 319 en(ji,jj,jk) = en(ji,jj,jk) + rdt * ( zwlc * zwlc * zwlc ) / zhlc(ji,jj) * wmask(ji,jj,jk) * tmask(ji,jj,1) 325 en(ji,jj,jk) = en(ji,jj,jk) + rdt * ( 1._wp - fr_i(ji,jj) ) * ( zwlc * zwlc * zwlc ) / & 326 & zhlc(ji,jj) * wmask(ji,jj,jk) * tmask(ji,jj,1) 320 327 END DO 321 328 END DO … … 350 357 DO ji = fs_2, fs_jpim1 ! vector opt. 351 358 zcof = zfact1 * tmask(ji,jj,jk) 359 # if defined key_zdftmx_new 360 ! key_zdftmx_new: New internal wave-driven param: set a minimum value for Kz on TKE (ensure numerical stability) 361 zzd_up = zcof * ( MAX( avm(ji,jj,jk+1) + avm(ji,jj,jk), 2.e-5_wp ) ) & ! upper diagonal 362 & / ( fse3t(ji,jj,jk ) * fse3w(ji,jj,jk ) ) 363 zzd_lw = zcof * ( MAX( avm(ji,jj,jk) + avm(ji,jj,jk-1), 2.e-5_wp ) ) & ! lower diagonal 364 & / ( fse3t(ji,jj,jk-1) * fse3w(ji,jj,jk ) ) 365 # else 352 366 zzd_up = zcof * ( avm (ji,jj,jk+1) + avm (ji,jj,jk ) ) & ! upper diagonal 353 367 & / ( fse3t(ji,jj,jk ) * fse3w(ji,jj,jk ) ) 354 368 zzd_lw = zcof * ( avm (ji,jj,jk ) + avm (ji,jj,jk-1) ) & ! lower diagonal 355 369 & / ( fse3t(ji,jj,jk-1) * fse3w(ji,jj,jk ) ) 370 # endif 356 371 ! ! shear prod. at w-point weightened by mask 357 372 zesh2 = ( avmu(ji-1,jj,jk) + avmu(ji,jj,jk) ) / MAX( 1._wp , umask(ji-1,jj,jk) + umask(ji,jj,jk) ) & … … 710 725 !!---------------------------------------------------------------------- 711 726 INTEGER :: ji, jj, jk ! dummy loop indices 712 INTEGER :: ios 727 INTEGER :: ios, ierr 713 728 !! 714 729 NAMELIST/namzdf_tke/ rn_ediff, rn_ediss , rn_ebb , rn_emin , & … … 728 743 ! 729 744 ri_cri = 2._wp / ( 2._wp + rn_ediss / rn_ediff ) ! resulting critical Richardson number 745 # if defined key_zdftmx_new 746 ! key_zdftmx_new: New internal wave-driven param: specified value of rn_emin & rmxl_min are used 747 rn_emin = 1.e-10_wp 748 rmxl_min = 1.e-03_wp 749 IF(lwp) THEN ! Control print 750 WRITE(numout,*) 751 WRITE(numout,*) 'zdf_tke_init : New tidal mixing case: force rn_emin = 1.e-10 and rmxl_min = 1.e-3 ' 752 WRITE(numout,*) '~~~~~~~~~~~~' 753 ENDIF 754 # else 730 755 rmxl_min = 1.e-6_wp / ( rn_ediff * SQRT( rn_emin ) ) ! resulting minimum length to recover molecular viscosity 756 # endif 731 757 ! 732 758 IF(lwp) THEN !* Control print … … 768 794 ENDIF 769 795 770 IF( nn_etau == 2 ) CALL zdf_mxl( nit000 ) ! Initialization of nmln 796 IF( nn_etau == 2 ) THEN 797 ierr = zdf_mxl_alloc() 798 nmln(:,:) = nlb10 ! Initialization of nmln 799 ENDIF 771 800 772 801 ! !* depth of penetration of surface tke -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/ZDF/zdftmx.F90
r6836 r6839 561 561 END SUBROUTINE zdf_tmx_init 562 562 563 #elif defined key_zdftmx_new 564 !!---------------------------------------------------------------------- 565 !! 'key_zdftmx_new' Internal wave-driven vertical mixing 566 !!---------------------------------------------------------------------- 567 !! zdf_tmx : global momentum & tracer Kz with wave induced Kz 568 !! zdf_tmx_init : global momentum & tracer Kz with wave induced Kz 569 !!---------------------------------------------------------------------- 570 USE oce ! ocean dynamics and tracers variables 571 USE dom_oce ! ocean space and time domain variables 572 USE zdf_oce ! ocean vertical physics variables 573 USE zdfddm ! ocean vertical physics: double diffusive mixing 574 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 575 USE eosbn2 ! ocean equation of state 576 USE phycst ! physical constants 577 USE prtctl ! Print control 578 USE in_out_manager ! I/O manager 579 USE iom ! I/O Manager 580 USE lib_mpp ! MPP library 581 USE wrk_nemo ! work arrays 582 USE timing ! Timing 583 USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 584 585 IMPLICIT NONE 586 PRIVATE 587 588 PUBLIC zdf_tmx ! called in step module 589 PUBLIC zdf_tmx_init ! called in nemogcm module 590 PUBLIC zdf_tmx_alloc ! called in nemogcm module 591 592 LOGICAL, PUBLIC, PARAMETER :: lk_zdftmx = .TRUE. !: wave-driven mixing flag 593 594 ! !!* Namelist namzdf_tmx : internal wave-driven mixing * 595 INTEGER :: nn_zpyc ! pycnocline-intensified mixing energy proportional to N (=1) or N^2 (=2) 596 LOGICAL :: ln_mevar ! variable (=T) or constant (=F) mixing efficiency 597 LOGICAL :: ln_tsdiff ! account for differential T/S wave-driven mixing (=T) or not (=F) 598 599 REAL(wp) :: r1_6 = 1._wp / 6._wp 600 601 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: ebot_tmx ! power available from high-mode wave breaking (W/m2) 602 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: epyc_tmx ! power available from low-mode, pycnocline-intensified wave breaking (W/m2) 603 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: ecri_tmx ! power available from low-mode, critical slope wave breaking (W/m2) 604 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: hbot_tmx ! WKB decay scale for high-mode energy dissipation (m) 605 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: hcri_tmx ! decay scale for low-mode critical slope dissipation (m) 606 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: emix_tmx ! local energy density available for mixing (W/kg) 607 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: bflx_tmx ! buoyancy flux Kz * N^2 (W/kg) 608 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: pcmap_tmx ! vertically integrated buoyancy flux (W/m2) 609 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: zav_ratio ! S/T diffusivity ratio (only for ln_tsdiff=T) 610 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: zav_wave ! Internal wave-induced diffusivity 611 612 !! * Substitutions 613 # include "zdfddm_substitute.h90" 614 # include "domzgr_substitute.h90" 615 # include "vectopt_loop_substitute.h90" 616 !!---------------------------------------------------------------------- 617 !! NEMO/OPA 4.0 , NEMO Consortium (2016) 618 !! $Id$ 619 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 620 !!---------------------------------------------------------------------- 621 CONTAINS 622 623 INTEGER FUNCTION zdf_tmx_alloc() 624 !!---------------------------------------------------------------------- 625 !! *** FUNCTION zdf_tmx_alloc *** 626 !!---------------------------------------------------------------------- 627 ALLOCATE( ebot_tmx(jpi,jpj), epyc_tmx(jpi,jpj), ecri_tmx(jpi,jpj) , & 628 & hbot_tmx(jpi,jpj), hcri_tmx(jpi,jpj), emix_tmx(jpi,jpj,jpk), & 629 & bflx_tmx(jpi,jpj,jpk), pcmap_tmx(jpi,jpj), zav_ratio(jpi,jpj,jpk), & 630 & zav_wave(jpi,jpj,jpk), STAT=zdf_tmx_alloc ) 631 ! 632 IF( lk_mpp ) CALL mpp_sum ( zdf_tmx_alloc ) 633 IF( zdf_tmx_alloc /= 0 ) CALL ctl_warn('zdf_tmx_alloc: failed to allocate arrays') 634 END FUNCTION zdf_tmx_alloc 635 636 637 SUBROUTINE zdf_tmx( kt ) 638 !!---------------------------------------------------------------------- 639 !! *** ROUTINE zdf_tmx *** 640 !! 641 !! ** Purpose : add to the vertical mixing coefficients the effect of 642 !! breaking internal waves. 643 !! 644 !! ** Method : - internal wave-driven vertical mixing is given by: 645 !! Kz_wave = min( 100 cm2/s, f( Reb = emix_tmx /( Nu * N^2 ) ) 646 !! where emix_tmx is the 3D space distribution of the wave-breaking 647 !! energy and Nu the molecular kinematic viscosity. 648 !! The function f(Reb) is linear (constant mixing efficiency) 649 !! if the namelist parameter ln_mevar = F and nonlinear if ln_mevar = T. 650 !! 651 !! - Compute emix_tmx, the 3D power density that allows to compute 652 !! Reb and therefrom the wave-induced vertical diffusivity. 653 !! This is divided into three components: 654 !! 1. Bottom-intensified low-mode dissipation at critical slopes 655 !! emix_tmx(z) = ( ecri_tmx / rau0 ) * EXP( -(H-z)/hcri_tmx ) 656 !! / ( 1. - EXP( - H/hcri_tmx ) ) * hcri_tmx 657 !! where hcri_tmx is the characteristic length scale of the bottom 658 !! intensification, ecri_tmx a map of available power, and H the ocean depth. 659 !! 2. Pycnocline-intensified low-mode dissipation 660 !! emix_tmx(z) = ( epyc_tmx / rau0 ) * ( sqrt(rn2(z))^nn_zpyc ) 661 !! / SUM( sqrt(rn2(z))^nn_zpyc * e3w(z) ) 662 !! where epyc_tmx is a map of available power, and nn_zpyc 663 !! is the chosen stratification-dependence of the internal wave 664 !! energy dissipation. 665 !! 3. WKB-height dependent high mode dissipation 666 !! emix_tmx(z) = ( ebot_tmx / rau0 ) * rn2(z) * EXP(-z_wkb(z)/hbot_tmx) 667 !! / SUM( rn2(z) * EXP(-z_wkb(z)/hbot_tmx) * e3w(z) ) 668 !! where hbot_tmx is the characteristic length scale of the WKB bottom 669 !! intensification, ebot_tmx is a map of available power, and z_wkb is the 670 !! WKB-stretched height above bottom defined as 671 !! z_wkb(z) = H * SUM( sqrt(rn2(z'>=z)) * e3w(z'>=z) ) 672 !! / SUM( sqrt(rn2(z')) * e3w(z') ) 673 !! 674 !! - update the model vertical eddy viscosity and diffusivity: 675 !! avt = avt + av_wave 676 !! avm = avm + av_wave 677 !! avmu = avmu + mi(av_wave) 678 !! avmv = avmv + mj(av_wave) 679 !! 680 !! - if namelist parameter ln_tsdiff = T, account for differential mixing: 681 !! avs = avt + av_wave * diffusivity_ratio(Reb) 682 !! 683 !! ** Action : - Define emix_tmx used to compute internal wave-induced mixing 684 !! - avt, avs, avm, avmu, avmv increased by internal wave-driven mixing 685 !! 686 !! References : de Lavergne et al. 2015, JPO; 2016, in prep. 687 !!---------------------------------------------------------------------- 688 INTEGER, INTENT(in) :: kt ! ocean time-step 689 ! 690 INTEGER :: ji, jj, jk ! dummy loop indices 691 REAL(wp) :: ztpc ! scalar workspace 692 REAL(wp), DIMENSION(:,:) , POINTER :: zfact ! Used for vertical structure 693 REAL(wp), DIMENSION(:,:) , POINTER :: zhdep ! Ocean depth 694 REAL(wp), DIMENSION(:,:,:), POINTER :: zwkb ! WKB-stretched height above bottom 695 REAL(wp), DIMENSION(:,:,:), POINTER :: zweight ! Weight for high mode vertical distribution 696 REAL(wp), DIMENSION(:,:,:), POINTER :: znu_t ! Molecular kinematic viscosity (T grid) 697 REAL(wp), DIMENSION(:,:,:), POINTER :: znu_w ! Molecular kinematic viscosity (W grid) 698 REAL(wp), DIMENSION(:,:,:), POINTER :: zReb ! Turbulence intensity parameter 699 !!---------------------------------------------------------------------- 700 ! 701 IF( nn_timing == 1 ) CALL timing_start('zdf_tmx') 702 ! 703 CALL wrk_alloc( jpi,jpj, zfact, zhdep ) 704 CALL wrk_alloc( jpi,jpj,jpk, zwkb, zweight, znu_t, znu_w, zReb ) 705 706 ! ! ----------------------------- ! 707 ! ! Internal wave-driven mixing ! (compute zav_wave) 708 ! ! ----------------------------- ! 709 ! 710 ! !* Critical slope mixing: distribute energy over the time-varying ocean depth, 711 ! using an exponential decay from the seafloor. 712 DO jj = 1, jpj ! part independent of the level 713 DO ji = 1, jpi 714 zhdep(ji,jj) = fsdepw(ji,jj,mbkt(ji,jj)+1) ! depth of the ocean 715 zfact(ji,jj) = rau0 * ( 1._wp - EXP( -zhdep(ji,jj) / hcri_tmx(ji,jj) ) ) 716 IF( zfact(ji,jj) /= 0 ) zfact(ji,jj) = ecri_tmx(ji,jj) / zfact(ji,jj) 717 END DO 718 END DO 719 720 DO jk = 2, jpkm1 ! complete with the level-dependent part 721 emix_tmx(:,:,jk) = zfact(:,:) * ( EXP( ( fsde3w(:,:,jk ) - zhdep(:,:) ) / hcri_tmx(:,:) ) & 722 & - EXP( ( fsde3w(:,:,jk-1) - zhdep(:,:) ) / hcri_tmx(:,:) ) ) * wmask(:,:,jk) & 723 & / ( fsde3w(:,:,jk) - fsde3w(:,:,jk-1) ) 724 END DO 725 726 ! !* Pycnocline-intensified mixing: distribute energy over the time-varying 727 ! !* ocean depth as proportional to sqrt(rn2)^nn_zpyc 728 729 SELECT CASE ( nn_zpyc ) 730 731 CASE ( 1 ) ! Dissipation scales as N (recommended) 732 733 zfact(:,:) = 0._wp 734 DO jk = 2, jpkm1 ! part independent of the level 735 zfact(:,:) = zfact(:,:) + fse3w(:,:,jk) * SQRT( MAX( 0._wp, rn2(:,:,jk) ) ) * wmask(:,:,jk) 736 END DO 737 738 DO jj = 1, jpj 739 DO ji = 1, jpi 740 IF( zfact(ji,jj) /= 0 ) zfact(ji,jj) = epyc_tmx(ji,jj) / ( rau0 * zfact(ji,jj) ) 741 END DO 742 END DO 743 744 DO jk = 2, jpkm1 ! complete with the level-dependent part 745 emix_tmx(:,:,jk) = emix_tmx(:,:,jk) + zfact(:,:) * SQRT( MAX( 0._wp, rn2(:,:,jk) ) ) * wmask(:,:,jk) 746 END DO 747 748 CASE ( 2 ) ! Dissipation scales as N^2 749 750 zfact(:,:) = 0._wp 751 DO jk = 2, jpkm1 ! part independent of the level 752 zfact(:,:) = zfact(:,:) + fse3w(:,:,jk) * MAX( 0._wp, rn2(:,:,jk) ) * wmask(:,:,jk) 753 END DO 754 755 DO jj= 1, jpj 756 DO ji = 1, jpi 757 IF( zfact(ji,jj) /= 0 ) zfact(ji,jj) = epyc_tmx(ji,jj) / ( rau0 * zfact(ji,jj) ) 758 END DO 759 END DO 760 761 DO jk = 2, jpkm1 ! complete with the level-dependent part 762 emix_tmx(:,:,jk) = emix_tmx(:,:,jk) + zfact(:,:) * MAX( 0._wp, rn2(:,:,jk) ) * wmask(:,:,jk) 763 END DO 764 765 END SELECT 766 767 ! !* WKB-height dependent mixing: distribute energy over the time-varying 768 ! !* ocean depth as proportional to rn2 * exp(-z_wkb/rn_hbot) 769 770 zwkb(:,:,:) = 0._wp 771 zfact(:,:) = 0._wp 772 DO jk = 2, jpkm1 773 zfact(:,:) = zfact(:,:) + fse3w(:,:,jk) * SQRT( MAX( 0._wp, rn2(:,:,jk) ) ) * wmask(:,:,jk) 774 zwkb(:,:,jk) = zfact(:,:) 775 END DO 776 777 DO jk = 2, jpkm1 778 DO jj = 1, jpj 779 DO ji = 1, jpi 780 IF( zfact(ji,jj) /= 0 ) zwkb(ji,jj,jk) = zhdep(ji,jj) * ( zfact(ji,jj) - zwkb(ji,jj,jk) ) & 781 & * tmask(ji,jj,jk) / zfact(ji,jj) 782 END DO 783 END DO 784 END DO 785 zwkb(:,:,1) = zhdep(:,:) * tmask(:,:,1) 786 787 zweight(:,:,:) = 0._wp 788 DO jk = 2, jpkm1 789 zweight(:,:,jk) = MAX( 0._wp, rn2(:,:,jk) ) * hbot_tmx(:,:) * wmask(:,:,jk) & 790 & * ( EXP( -zwkb(:,:,jk) / hbot_tmx(:,:) ) - EXP( -zwkb(:,:,jk-1) / hbot_tmx(:,:) ) ) 791 END DO 792 793 zfact(:,:) = 0._wp 794 DO jk = 2, jpkm1 ! part independent of the level 795 zfact(:,:) = zfact(:,:) + zweight(:,:,jk) 796 END DO 797 798 DO jj = 1, jpj 799 DO ji = 1, jpi 800 IF( zfact(ji,jj) /= 0 ) zfact(ji,jj) = ebot_tmx(ji,jj) / ( rau0 * zfact(ji,jj) ) 801 END DO 802 END DO 803 804 DO jk = 2, jpkm1 ! complete with the level-dependent part 805 emix_tmx(:,:,jk) = emix_tmx(:,:,jk) + zweight(:,:,jk) * zfact(:,:) * wmask(:,:,jk) & 806 & / ( fsde3w(:,:,jk) - fsde3w(:,:,jk-1) ) 807 END DO 808 809 810 ! Calculate molecular kinematic viscosity 811 znu_t(:,:,:) = 1.e-4_wp * ( 17.91_wp - 0.53810_wp * tsn(:,:,:,jp_tem) + 0.00694_wp * tsn(:,:,:,jp_tem) * tsn(:,:,:,jp_tem) & 812 & + 0.02305_wp * tsn(:,:,:,jp_sal) ) * tmask(:,:,:) * r1_rau0 813 DO jk = 2, jpkm1 814 znu_w(:,:,jk) = 0.5_wp * ( znu_t(:,:,jk-1) + znu_t(:,:,jk) ) * wmask(:,:,jk) 815 END DO 816 817 ! Calculate turbulence intensity parameter Reb 818 DO jk = 2, jpkm1 819 zReb(:,:,jk) = emix_tmx(:,:,jk) / MAX( 1.e-20_wp, znu_w(:,:,jk) * rn2(:,:,jk) ) 820 END DO 821 822 ! Define internal wave-induced diffusivity 823 DO jk = 2, jpkm1 824 zav_wave(:,:,jk) = znu_w(:,:,jk) * zReb(:,:,jk) * r1_6 ! This corresponds to a constant mixing efficiency of 1/6 825 END DO 826 827 IF( ln_mevar ) THEN ! Variable mixing efficiency case : modify zav_wave in the 828 DO jk = 2, jpkm1 ! energetic (Reb > 480) and buoyancy-controlled (Reb <10.224 ) regimes 829 DO jj = 1, jpj 830 DO ji = 1, jpi 831 IF( zReb(ji,jj,jk) > 480.00_wp ) THEN 832 zav_wave(ji,jj,jk) = 3.6515_wp * znu_w(ji,jj,jk) * SQRT( zReb(ji,jj,jk) ) 833 ELSEIF( zReb(ji,jj,jk) < 10.224_wp ) THEN 834 zav_wave(ji,jj,jk) = 0.052125_wp * znu_w(ji,jj,jk) * zReb(ji,jj,jk) * SQRT( zReb(ji,jj,jk) ) 835 ENDIF 836 END DO 837 END DO 838 END DO 839 ENDIF 840 841 DO jk = 2, jpkm1 ! Bound diffusivity by molecular value and 100 cm2/s 842 zav_wave(:,:,jk) = MIN( MAX( 1.4e-7_wp, zav_wave(:,:,jk) ), 1.e-2_wp ) * wmask(:,:,jk) 843 END DO 844 845 IF( kt == nit000 ) THEN !* Control print at first time-step: diagnose the energy consumed by zav_wave 846 ztpc = 0._wp 847 DO jk = 2, jpkm1 848 DO jj = 1, jpj 849 DO ji = 1, jpi 850 ztpc = ztpc + fse3w(ji,jj,jk) * e1e2t(ji,jj) & 851 & * MAX( 0._wp, rn2(ji,jj,jk) ) * zav_wave(ji,jj,jk) * wmask(ji,jj,jk) * tmask_i(ji,jj) 852 END DO 853 END DO 854 END DO 855 IF( lk_mpp ) CALL mpp_sum( ztpc ) 856 ztpc = rau0 * ztpc ! Global integral of rauo * Kz * N^2 = power contributing to mixing 857 858 IF(lwp) THEN 859 WRITE(numout,*) 860 WRITE(numout,*) 'zdf_tmx : Internal wave-driven mixing (tmx)' 861 WRITE(numout,*) '~~~~~~~ ' 862 WRITE(numout,*) 863 WRITE(numout,*) ' Total power consumption by av_wave: ztpc = ', ztpc * 1.e-12_wp, 'TW' 864 ENDIF 865 ENDIF 866 867 ! ! ----------------------- ! 868 ! ! Update mixing coefs ! 869 ! ! ----------------------- ! 870 ! 871 IF( ln_tsdiff ) THEN !* Option for differential mixing of salinity and temperature 872 DO jk = 2, jpkm1 ! Calculate S/T diffusivity ratio as a function of Reb 873 DO jj = 1, jpj 874 DO ji = 1, jpi 875 zav_ratio(ji,jj,jk) = ( 0.505_wp + 0.495_wp * & 876 & TANH( 0.92_wp * ( LOG10( MAX( 1.e-20_wp, zReb(ji,jj,jk) * 5._wp * r1_6 ) ) - 0.60_wp ) ) & 877 & ) * wmask(ji,jj,jk) 878 END DO 879 END DO 880 END DO 881 CALL iom_put( "av_ratio", zav_ratio ) 882 DO jk = 2, jpkm1 !* update momentum & tracer diffusivity with wave-driven mixing 883 fsavs(:,:,jk) = avt(:,:,jk) + zav_wave(:,:,jk) * zav_ratio(:,:,jk) 884 avt (:,:,jk) = avt(:,:,jk) + zav_wave(:,:,jk) 885 avm (:,:,jk) = avm(:,:,jk) + zav_wave(:,:,jk) 886 END DO 887 ! 888 ELSE !* update momentum & tracer diffusivity with wave-driven mixing 889 DO jk = 2, jpkm1 890 fsavs(:,:,jk) = avt(:,:,jk) + zav_wave(:,:,jk) 891 avt (:,:,jk) = avt(:,:,jk) + zav_wave(:,:,jk) 892 avm (:,:,jk) = avm(:,:,jk) + zav_wave(:,:,jk) 893 END DO 894 ENDIF 895 896 DO jk = 2, jpkm1 !* update momentum diffusivity at wu and wv points 897 DO jj = 2, jpjm1 898 DO ji = fs_2, fs_jpim1 ! vector opt. 899 avmu(ji,jj,jk) = avmu(ji,jj,jk) + 0.5_wp * ( zav_wave(ji,jj,jk) + zav_wave(ji+1,jj ,jk) ) * wumask(ji,jj,jk) 900 avmv(ji,jj,jk) = avmv(ji,jj,jk) + 0.5_wp * ( zav_wave(ji,jj,jk) + zav_wave(ji ,jj+1,jk) ) * wvmask(ji,jj,jk) 901 END DO 902 END DO 903 END DO 904 CALL lbc_lnk( avmu, 'U', 1. ) ; CALL lbc_lnk( avmv, 'V', 1. ) ! lateral boundary condition 905 906 ! !* output internal wave-driven mixing coefficient 907 CALL iom_put( "av_wave", zav_wave ) 908 !* output useful diagnostics: N^2, Kz * N^2 (bflx_tmx), 909 ! vertical integral of rau0 * Kz * N^2 (pcmap_tmx), energy density (emix_tmx) 910 IF( iom_use("bflx_tmx") .OR. iom_use("pcmap_tmx") ) THEN 911 bflx_tmx(:,:,:) = MAX( 0._wp, rn2(:,:,:) ) * zav_wave(:,:,:) 912 pcmap_tmx(:,:) = 0._wp 913 DO jk = 2, jpkm1 914 pcmap_tmx(:,:) = pcmap_tmx(:,:) + fse3w(:,:,jk) * bflx_tmx(:,:,jk) * wmask(:,:,jk) 915 END DO 916 pcmap_tmx(:,:) = rau0 * pcmap_tmx(:,:) 917 CALL iom_put( "bflx_tmx", bflx_tmx ) 918 CALL iom_put( "pcmap_tmx", pcmap_tmx ) 919 ENDIF 920 CALL iom_put( "bn2", rn2 ) 921 CALL iom_put( "emix_tmx", emix_tmx ) 922 923 CALL wrk_dealloc( jpi,jpj, zfact, zhdep ) 924 CALL wrk_dealloc( jpi,jpj,jpk, zwkb, zweight, znu_t, znu_w, zReb ) 925 926 IF(ln_ctl) CALL prt_ctl(tab3d_1=zav_wave , clinfo1=' tmx - av_wave: ', tab3d_2=avt, clinfo2=' avt: ', ovlap=1, kdim=jpk) 927 ! 928 IF( nn_timing == 1 ) CALL timing_stop('zdf_tmx') 929 ! 930 END SUBROUTINE zdf_tmx 931 932 933 SUBROUTINE zdf_tmx_init 934 !!---------------------------------------------------------------------- 935 !! *** ROUTINE zdf_tmx_init *** 936 !! 937 !! ** Purpose : Initialization of the wave-driven vertical mixing, reading 938 !! of input power maps and decay length scales in netcdf files. 939 !! 940 !! ** Method : - Read the namzdf_tmx namelist and check the parameters 941 !! 942 !! - Read the input data in NetCDF files : 943 !! power available from high-mode wave breaking (mixing_power_bot.nc) 944 !! power available from pycnocline-intensified wave-breaking (mixing_power_pyc.nc) 945 !! power available from critical slope wave-breaking (mixing_power_cri.nc) 946 !! WKB decay scale for high-mode wave-breaking (decay_scale_bot.nc) 947 !! decay scale for critical slope wave-breaking (decay_scale_cri.nc) 948 !! 949 !! ** input : - Namlist namzdf_tmx 950 !! - NetCDF files : mixing_power_bot.nc, mixing_power_pyc.nc, mixing_power_cri.nc, 951 !! decay_scale_bot.nc decay_scale_cri.nc 952 !! 953 !! ** Action : - Increase by 1 the nstop flag is setting problem encounter 954 !! - Define ebot_tmx, epyc_tmx, ecri_tmx, hbot_tmx, hcri_tmx 955 !! 956 !! References : de Lavergne et al. 2015, JPO; 2016, in prep. 957 !! 958 !!---------------------------------------------------------------------- 959 INTEGER :: ji, jj, jk ! dummy loop indices 960 INTEGER :: inum ! local integer 961 INTEGER :: ios 962 REAL(wp) :: zbot, zpyc, zcri ! local scalars 963 !! 964 NAMELIST/namzdf_tmx_new/ nn_zpyc, ln_mevar, ln_tsdiff 965 !!---------------------------------------------------------------------- 966 ! 967 IF( nn_timing == 1 ) CALL timing_start('zdf_tmx_init') 968 ! 969 REWIND( numnam_ref ) ! Namelist namzdf_tmx in reference namelist : Wave-driven mixing 970 READ ( numnam_ref, namzdf_tmx_new, IOSTAT = ios, ERR = 901) 971 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzdf_tmx in reference namelist', lwp ) 972 ! 973 REWIND( numnam_cfg ) ! Namelist namzdf_tmx in configuration namelist : Wave-driven mixing 974 READ ( numnam_cfg, namzdf_tmx_new, IOSTAT = ios, ERR = 902 ) 975 902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzdf_tmx in configuration namelist', lwp ) 976 IF(lwm) WRITE ( numond, namzdf_tmx_new ) 977 ! 978 IF(lwp) THEN ! Control print 979 WRITE(numout,*) 980 WRITE(numout,*) 'zdf_tmx_init : internal wave-driven mixing' 981 WRITE(numout,*) '~~~~~~~~~~~~' 982 WRITE(numout,*) ' Namelist namzdf_tmx_new : set wave-driven mixing parameters' 983 WRITE(numout,*) ' Pycnocline-intensified diss. scales as N (=1) or N^2 (=2) = ', nn_zpyc 984 WRITE(numout,*) ' Variable (T) or constant (F) mixing efficiency = ', ln_mevar 985 WRITE(numout,*) ' Differential internal wave-driven mixing (T) or not (F) = ', ln_tsdiff 986 ENDIF 987 988 ! The new wave-driven mixing parameterization elevates avt and avm in the interior, and 989 ! ensures that avt remains larger than its molecular value (=1.4e-7). Therefore, avtb should 990 ! be set here to a very small value, and avmb to its (uniform) molecular value (=1.4e-6). 991 avmb(:) = 1.4e-6_wp ! viscous molecular value 992 avtb(:) = 1.e-10_wp ! very small diffusive minimum (background avt is specified in zdf_tmx) 993 avtb_2d(:,:) = 1.e0_wp ! uniform 994 IF(lwp) THEN ! Control print 995 WRITE(numout,*) 996 WRITE(numout,*) ' Force the background value applied to avm & avt in TKE to be everywhere ', & 997 & 'the viscous molecular value & a very small diffusive value, resp.' 998 ENDIF 999 1000 IF( .NOT.lk_zdfddm ) CALL ctl_stop( 'STOP', 'zdf_tmx_init_new : key_zdftmx_new requires key_zdfddm' ) 1001 1002 ! ! allocate tmx arrays 1003 IF( zdf_tmx_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'zdf_tmx_init : unable to allocate tmx arrays' ) 1004 ! 1005 ! ! read necessary fields 1006 CALL iom_open('mixing_power_bot',inum) ! energy flux for high-mode wave breaking [W/m2] 1007 CALL iom_get (inum, jpdom_data, 'field', ebot_tmx, 1 ) 1008 CALL iom_close(inum) 1009 ! 1010 CALL iom_open('mixing_power_pyc',inum) ! energy flux for pynocline-intensified wave breaking [W/m2] 1011 CALL iom_get (inum, jpdom_data, 'field', epyc_tmx, 1 ) 1012 CALL iom_close(inum) 1013 ! 1014 CALL iom_open('mixing_power_cri',inum) ! energy flux for critical slope wave breaking [W/m2] 1015 CALL iom_get (inum, jpdom_data, 'field', ecri_tmx, 1 ) 1016 CALL iom_close(inum) 1017 ! 1018 CALL iom_open('decay_scale_bot',inum) ! spatially variable decay scale for high-mode wave breaking [m] 1019 CALL iom_get (inum, jpdom_data, 'field', hbot_tmx, 1 ) 1020 CALL iom_close(inum) 1021 ! 1022 CALL iom_open('decay_scale_cri',inum) ! spatially variable decay scale for critical slope wave breaking [m] 1023 CALL iom_get (inum, jpdom_data, 'field', hcri_tmx, 1 ) 1024 CALL iom_close(inum) 1025 1026 ebot_tmx(:,:) = ebot_tmx(:,:) * ssmask(:,:) 1027 epyc_tmx(:,:) = epyc_tmx(:,:) * ssmask(:,:) 1028 ecri_tmx(:,:) = ecri_tmx(:,:) * ssmask(:,:) 1029 1030 ! Set once for all to zero the first and last vertical levels of appropriate variables 1031 emix_tmx (:,:, 1 ) = 0._wp 1032 emix_tmx (:,:,jpk) = 0._wp 1033 zav_ratio(:,:, 1 ) = 0._wp 1034 zav_ratio(:,:,jpk) = 0._wp 1035 zav_wave (:,:, 1 ) = 0._wp 1036 zav_wave (:,:,jpk) = 0._wp 1037 1038 zbot = glob_sum( e1e2t(:,:) * ebot_tmx(:,:) ) 1039 zpyc = glob_sum( e1e2t(:,:) * epyc_tmx(:,:) ) 1040 zcri = glob_sum( e1e2t(:,:) * ecri_tmx(:,:) ) 1041 IF(lwp) THEN 1042 WRITE(numout,*) ' High-mode wave-breaking energy: ', zbot * 1.e-12_wp, 'TW' 1043 WRITE(numout,*) ' Pycnocline-intensifed wave-breaking energy: ', zpyc * 1.e-12_wp, 'TW' 1044 WRITE(numout,*) ' Critical slope wave-breaking energy: ', zcri * 1.e-12_wp, 'TW' 1045 ENDIF 1046 ! 1047 IF( nn_timing == 1 ) CALL timing_stop('zdf_tmx_init') 1048 ! 1049 END SUBROUTINE zdf_tmx_init 1050 563 1051 #else 564 1052 !!---------------------------------------------------------------------- -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/nemogcm.F90
r6836 r6839 161 161 ENDIF 162 162 163 #if defined key_agrif 164 CALL Agrif_Regrid() 165 #endif 166 163 167 DO WHILE ( istp <= nitend .AND. nstop == 0 ) 164 168 #if defined key_agrif 165 CALL Agrif_Step( stp )! AGRIF: time stepping169 CALL stp ! AGRIF: time stepping 166 170 #else 167 171 CALL stp( istp ) ! standard time stepping … … 187 191 ! 188 192 #if defined key_agrif 189 CALL Agrif_ParentGrid_To_ChildGrid() 190 IF( lk_diaobs ) CALL dia_obs_wri 191 IF( nn_timing == 1 ) CALL timing_finalize 192 CALL Agrif_ChildGrid_To_ParentGrid() 193 IF( .NOT. Agrif_Root() ) THEN 194 CALL Agrif_ParentGrid_To_ChildGrid() 195 IF( lk_diaobs ) CALL dia_obs_wri 196 IF( nn_timing == 1 ) CALL timing_finalize 197 CALL Agrif_ChildGrid_To_ParentGrid() 198 ENDIF 193 199 #endif 194 200 IF( nn_timing == 1 ) CALL timing_finalize … … 334 340 jpj = ( jpjglo-2*jprecj + (jpnj-1) ) / jpnj + 2*jprecj ! second dim. 335 341 #endif 336 ENDIF 342 ENDIF 337 343 jpk = jpkdta ! third dim 344 #if defined key_agrif 345 ! simple trick to use same vertical grid as parent 346 ! but different number of levels: 347 ! Save maximum number of levels in jpkdta, then define all vertical grids 348 ! with this number. 349 ! Suppress once vertical online interpolation is ok 350 IF(.NOT.Agrif_Root()) jpkdta = Agrif_Parent(jpkdta) 351 #endif 338 352 jpim1 = jpi-1 ! inner domain indices 339 353 jpjm1 = jpj-1 ! " " … … 710 724 INTEGER :: ifac, jl, inu 711 725 INTEGER, PARAMETER :: ntest = 14 712 INTEGER :: ilfax(ntest) 713 ! 714 ! lfax contains the set of allowed factors. 715 data (ilfax(jl),jl=1,ntest) / 16384, 8192, 4096, 2048, 1024, 512, 256, & 716 & 128, 64, 32, 16, 8, 4, 2 / 717 !!---------------------------------------------------------------------- 726 INTEGER, DIMENSION(ntest) :: ilfax 727 ! 728 ! ilfax contains the set of allowed factors. 729 ilfax(:) = (/(2**jl,jl=ntest,1,-1)/) 730 !!---------------------------------------------------------------------- 731 ! ilfax contains the set of allowed factors. 732 ilfax(:) = (/(2**jl,jl=ntest,1,-1)/) 718 733 719 734 ! Clear the error flag and initialise output vars -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/step.F90
r6837 r6839 50 50 51 51 #if defined key_agrif 52 SUBROUTINE stp( )52 RECURSIVE SUBROUTINE stp( ) 53 53 INTEGER :: kstp ! ocean time-step index 54 54 #else … … 79 79 #if defined key_agrif 80 80 kstp = nit000 + Agrif_Nb_Step() 81 ! IF ( Agrif_Root() .and. lwp) Write(*,*) '---' 82 ! IF (lwp) Write(*,*) 'Grid Number',Agrif_Fixed(),' time step ',kstp 81 IF ( lk_agrif_debug ) THEN 82 IF ( Agrif_Root() .and. lwp) Write(*,*) '---' 83 IF (lwp) Write(*,*) 'Grid Number',Agrif_Fixed(),' time step ',kstp, 'int tstep',Agrif_NbStepint() 84 ENDIF 85 83 86 IF ( kstp == (nit000 + 1) ) lk_agrif_fstep = .FALSE. 87 84 88 # if defined key_iomput 85 89 IF( Agrif_Nbstepint() == 0 ) CALL iom_swap( cxios_context ) … … 114 118 ! Update stochastic parameters and random T/S fluctuations 115 119 !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 116 CALL sto_par( kstp ) ! Stochastic parameters 120 IF( ln_sto_eos ) CALL sto_par( kstp ) ! Stochastic parameters 121 IF( ln_sto_eos ) CALL sto_pts( tsn ) ! Random T/S fluctuations 117 122 118 123 !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> … … 156 161 ! 157 162 IF( lk_ldfslp ) THEN ! slope of lateral mixing 158 IF(ln_sto_eos ) CALL sto_pts( tsn ) ! Random T/S fluctuations159 163 CALL eos( tsb, rhd, gdept_0(:,:,:) ) ! before in situ density 160 164 IF( ln_zps .AND. .NOT. ln_isfcav) & … … 192 196 ! Note that the computation of vertical velocity above, hence "after" sea level 193 197 ! is necessary to compute momentum advection for the rhs of barotropic loop: 194 IF(ln_sto_eos ) CALL sto_pts( tsn ) ! Random T/S fluctuations195 198 CALL eos ( tsn, rhd, rhop, fsdept_n(:,:,:) ) ! now in situ density for hpg computation 196 199 IF( ln_zps .AND. .NOT. ln_isfcav) & … … 204 207 ua(:,:,:) = 0.e0 ! set dynamics trends to zero 205 208 va(:,:,:) = 0.e0 206 IF( l n_asmiau .AND. &209 IF( lk_asminc .AND. ln_asmiau .AND. & 207 210 & ln_dyninc ) CALL dyn_asm_inc ( kstp ) ! apply dynamics assimilation increment 208 211 IF( ln_neptsimp ) CALL dyn_nept_cor ( kstp ) ! subtract Neptune velocities (simplified) … … 252 255 tsa(:,:,:,:) = 0.e0 ! set tracer trends to zero 253 256 254 IF( l n_asmiau .AND. &257 IF( lk_asminc .AND. ln_asmiau .AND. & 255 258 & ln_trainc ) CALL tra_asm_inc( kstp ) ! apply tracer assimilation increment 256 259 CALL tra_sbc ( kstp ) ! surface boundary condition … … 274 277 IF( ln_zdfnpc ) CALL tra_npc( kstp ) ! update after fields by non-penetrative convection 275 278 CALL tra_nxt( kstp ) ! tracer fields at next time step 276 IF( ln_sto_eos ) CALL sto_pts( tsn ) ! Random T/S fluctuations277 279 CALL eos ( tsa, rhd, rhop, fsdept_n(:,:,:) ) ! Time-filtered in situ density for hpg computation 278 280 IF( ln_zps .AND. .NOT. ln_isfcav) & … … 285 287 ELSE ! centered hpg (eos then time stepping) 286 288 IF ( .NOT. lk_dynspg_ts ) THEN ! eos already called in time-split case 287 IF( ln_sto_eos ) CALL sto_pts( tsn ) ! Random T/S fluctuations288 289 CALL eos ( tsn, rhd, rhop, fsdept_n(:,:,:) ) ! now in situ density for hpg computation 289 290 IF( ln_zps .AND. .NOT. ln_isfcav) & … … 318 319 va(:,:,:) = 0.e0 319 320 320 IF( l n_asmiau .AND. &321 IF( lk_asminc .AND. ln_asmiau .AND. & 321 322 & ln_dyninc ) CALL dyn_asm_inc( kstp ) ! apply dynamics assimilation increment 322 323 IF( ln_bkgwri ) CALL asm_bkg_wri( kstp ) ! output background fields … … 339 340 CALL ssh_swp( kstp ) ! swap of sea surface height 340 341 IF( lk_vvl ) CALL dom_vvl_sf_swp( kstp ) ! swap of vertical scale factors 341 342 ! 343 IF( lrst_oce ) CALL rst_write( kstp ) ! write output ocean restart file 344 IF( ln_sto_eos ) CALL sto_rst_write( kstp ) ! write restart file for stochastic parameters 345 346 #if defined key_agrif 347 !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 348 ! AGRIF 349 !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 350 CALL Agrif_Integrate_ChildGrids( stp ) 351 352 IF ( Agrif_NbStepint().EQ.0 ) THEN 353 CALL Agrif_Update_Tra() ! Update active tracers 354 CALL Agrif_Update_Dyn() ! Update momentum 355 ENDIF 356 #endif 342 357 IF( ln_diahsb ) CALL dia_hsb( kstp ) ! - ML - global conservation diagnostics 343 358 IF( lk_diaobs ) CALL dia_obs( kstp ) ! obs-minus-model (assimilation) diagnostics (call after dynamics update) 344 359 345 360 !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 346 ! Control and restarts361 ! Control 347 362 !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 348 363 CALL stp_ctl( kstp, indic ) … … 356 371 IF( lwm.AND.numoni /= -1 ) CALL FLUSH ( numoni ) ! flush output namelist ice 357 372 ENDIF 358 IF( lrst_oce ) CALL rst_write ( kstp ) ! write output ocean restart file359 373 360 374 !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> … … 371 385 ! 372 386 IF( nn_timing == 1 .AND. kstp == nit000 ) CALL timing_reset 387 ! 373 388 ! 374 389 END SUBROUTINE stp -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/step_oce.F90
r6837 r6839 113 113 #if defined key_agrif 114 114 USE agrif_opa_sponge ! Momemtum and tracers sponges 115 USE agrif_opa_update ! Update (2-way nesting) 115 116 #endif 116 117 #if defined key_top -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/OPA_SRC/stpctl.F90
r6836 r6839 17 17 USE dom_oce ! ocean space and time domain variables 18 18 USE sol_oce ! ocean space and time domain variables 19 USE sbc_oce ! surface boundary conditions variables 19 20 USE in_out_manager ! I/O manager 20 21 USE lbclnk ! ocean lateral boundary conditions (or mpp link) … … 22 23 USE dynspg_oce ! pressure gradient schemes 23 24 USE c1d ! 1D vertical configuration 25 24 26 25 27 IMPLICIT NONE … … 52 54 INTEGER, INTENT( inout ) :: kindic ! indicator of solver convergence 53 55 !! 56 CHARACTER(len = 32) :: clfname ! time stepping output file name 54 57 INTEGER :: ji, jj, jk ! dummy loop indices 55 58 INTEGER :: ii, ij, ik ! temporary integers … … 63 66 WRITE(numout,*) 'stp_ctl : time-stepping control' 64 67 WRITE(numout,*) '~~~~~~~' 65 ! open time.step file 66 CALL ctl_opn( numstp, 'time.step', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea ) 68 ! open time.step file with special treatment for SAS 69 IF ( nn_components == jp_iam_sas ) THEN 70 clfname = 'time.step.sas' 71 ELSE 72 clfname = 'time.step' 73 ENDIF 74 CALL ctl_opn( numstp, TRIM(clfname), 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea ) 67 75 ENDIF 68 76 -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/SAS_SRC/daymod.F90
r6836 r6839 71 71 !!---------------------------------------------------------------------- 72 72 ! 73 ! max number of seconds between each restart 74 IF( REAL( nitend - nit000 + 1 ) * rdt > REAL( HUGE( nsec1jan000 ) ) ) THEN 75 CALL ctl_stop( 'The number of seconds between each restart exceeds the integer 4 max value: 2^31-1. ', & 76 & 'You must do a restart at higher frequency (or remove this stop and recompile the code in I8)' ) 77 ENDIF 73 78 ! all calendar staff is based on the fact that MOD( rday, rdttra(1) ) == 0 74 79 IF( MOD( rday , rdttra(1) ) /= 0. ) CALL ctl_stop( 'the time step must devide the number of second of in a day' ) … … 239 244 nday_year = 1 240 245 nsec_year = ndt05 241 IF( nsec1jan000 >= 2 * (2**30 - nsecd * nyear_len(1) / 2 ) ) THEN ! test integer 4 max value242 CALL ctl_stop( 'The number of seconds between Jan. 1st 00h of nit000 year and Jan. 1st 00h ', &243 & 'of the current year is exceeding the INTEGER 4 max VALUE: 2^31-1 -> 68.09 years in seconds', &244 & 'You must do a restart at higher frequency (or remove this STOP and recompile everything in I8)' )245 ENDIF246 246 nsec1jan000 = nsec1jan000 + nsecd * nyear_len(1) 247 247 IF( nleapy == 1 ) CALL day_mth -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/SAS_SRC/nemogcm.F90
r6836 r6839 521 521 #endif 522 522 ! 523 INTEGER :: ierr,ierr1,ierr2,ierr3,ierr4,ierr5,ierr6 523 INTEGER :: ierr,ierr1,ierr2,ierr3,ierr4,ierr5,ierr6,ierr7,ierr8 524 524 INTEGER :: jpm 525 525 !!---------------------------------------------------------------------- … … 545 545 ALLOCATE( tsb(jpi,jpj,1,jpm) , STAT=ierr5 ) 546 546 ALLOCATE( sshn(jpi,jpj) , STAT=ierr6 ) 547 ierr = ierr + ierr1 + ierr2 + ierr3 + ierr4 + ierr5 + ierr6 547 ALLOCATE( un(jpi,jpj,1) , STAT=ierr7 ) 548 ALLOCATE( vn(jpi,jpj,1) , STAT=ierr8 ) 549 ierr = ierr + ierr1 + ierr2 + ierr3 + ierr4 + ierr5 + ierr6 + ierr7 + ierr8 548 550 #endif 549 551 ! -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/TOP_SRC/PISCES/P2Z/p2zbio.F90
r6836 r6839 599 599 600 600 !!====================================================================== 601 END MODULE 601 END MODULE p2zbio -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/TOP_SRC/PISCES/P2Z/p2zsms.F90
r6836 r6839 84 84 85 85 !!====================================================================== 86 END MODULE 86 END MODULE p2zsms -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zbio.F90
r6836 r6839 109 109 110 110 !!====================================================================== 111 END MODULE p4zbio 112 111 END MODULE p4zbio -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zche.F90
r6836 r6839 31 31 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: sio3eq ! chemistry of Si 32 32 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: fekeq ! chemistry of Fe 33 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,: ,:):: chemc ! Solubilities of O2 and CO234 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: chemo2 33 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: chemc ! Solubilities of O2 and CO2 34 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: chemo2 ! Solubilities of O2 and CO2 35 35 36 36 REAL(wp), PUBLIC :: atcox = 0.20946 ! units atm … … 76 76 REAL(wp) :: st1 = 0.14 ! constants for calculate concentrations for sulfate 77 77 REAL(wp) :: st2 = 1./96.062 ! (Morris & Riley 1966) 78 REAL(wp) :: ks0 = 141.32879 REAL(wp) :: ks1 = -4276.180 REAL(wp) :: ks2 = -23.09381 REAL(wp) :: ks3 = -13856.82 REAL(wp) :: ks4 = 324.5783 REAL(wp) :: ks5 = -47.98684 REAL(wp) :: ks6 = 35474.85 REAL(wp) :: ks7 = -771.5486 REAL(wp) :: ks8 = 114.72387 REAL(wp) :: ks9 = -2698.88 REAL(wp) :: ks10 = 1776.89 REAL(wp) :: ks11 = 1.90 REAL(wp) :: ks12 = -0.00100591 78 92 79 REAL(wp) :: ft1 = 0.000067 ! constants for calculate concentrations for fluorides 93 80 REAL(wp) :: ft2 = 1./18.9984 ! (Dickson & Riley 1979 ) 94 REAL(wp) :: kf0 = -12.64195 REAL(wp) :: kf1 = 1590.296 REAL(wp) :: kf2 = 1.52597 REAL(wp) :: kf3 = 1.098 REAL(wp) :: kf4 = -0.00100599 100 REAL(wp) :: cb0 = -8966.90 ! Coeff. for 1. dissoc. of boric acid101 REAL(wp) :: cb1 = -2890.53 ! (Dickson and Goyet, 1994)102 REAL(wp) :: cb2 = -77.942103 REAL(wp) :: cb3 = 1.728104 REAL(wp) :: cb4 = -0.0996105 REAL(wp) :: cb5 = 148.0248106 REAL(wp) :: cb6 = 137.1942107 REAL(wp) :: cb7 = 1.62142108 REAL(wp) :: cb8 = -24.4344109 REAL(wp) :: cb9 = -25.085110 REAL(wp) :: cb10 = -0.2474111 REAL(wp) :: cb11 = 0.053105112 113 REAL(wp) :: cw0 = -13847.26 ! Coeff. for dissoc. of water (Dickson and Riley, 1979 )114 REAL(wp) :: cw1 = 148.9652115 REAL(wp) :: cw2 = -23.6521116 REAL(wp) :: cw3 = 118.67117 REAL(wp) :: cw4 = -5.977118 REAL(wp) :: cw5 = 1.0495119 REAL(wp) :: cw6 = -0.01615120 81 121 82 ! ! volumetric solubility constants for o2 in ml/L … … 200 161 DO ji = 1, jpi 201 162 ! ! SET ABSOLUTE TEMPERATURE 202 ztkel = tsn(ji,jj,1,jp_tem) + 273.1 6163 ztkel = tsn(ji,jj,1,jp_tem) + 273.15 203 164 zt = ztkel * 0.01 204 165 zt2 = zt * zt … … 209 170 ! ! AND FOR THE ATMOSPHERE FOR NON IDEAL GAS 210 171 zcek1 = ca0 + ca1 / zt + ca2 * zlogt + ca3 * zt2 + zsal * ( ca4 + ca5 * zt + ca6 * zt2 ) 211 ! ! LN(K0) OF SOLUBILITY OF O2 and N2 in ml/L (EQ. 8, GARCIA AND GORDON, 1992)212 ztgg = LOG( ( 298.15 - tsn(ji,jj,1,jp_tem) ) / ztkel ) ! Set the GORDON & GARCIA scaled temperature213 ztgg2 = ztgg * ztgg214 ztgg3 = ztgg2 * ztgg215 ztgg4 = ztgg3 * ztgg216 ztgg5 = ztgg4 * ztgg217 zoxy = ox0 + ox1 * ztgg + ox2 * ztgg2 + ox3 * ztgg3 + ox4 * ztgg4 + ox5 * ztgg5 &218 + zsal * ( ox6 + ox7 * ztgg + ox8 * ztgg2 + ox9 * ztgg3 ) + ox10 * zsal2219 220 172 ! ! SET SOLUBILITIES OF O2 AND CO2 221 chemc(ji,jj,1) = EXP( zcek1 ) * 1.e-6 * rhop(ji,jj,1) / 1000. ! mol/(L uatm) 222 chemc(ji,jj,2) = ( EXP( zoxy ) * o2atm ) * oxyco ! mol/(L atm) 173 chemc(ji,jj) = EXP( zcek1 ) * 1.e-6 * rhop(ji,jj,1) / 1000. ! mol/(L uatm) 223 174 ! 224 175 END DO … … 233 184 !CDIR NOVERRCHK 234 185 DO ji = 1, jpi 235 ztkel = tsn(ji,jj,jk,jp_tem) + 273.1 6186 ztkel = tsn(ji,jj,jk,jp_tem) + 273.15 236 187 zsal = tsn(ji,jj,jk,jp_sal) + ( 1.- tmask(ji,jj,jk) ) * 35. 237 188 zsal2 = zsal * zsal … … 263 214 264 215 ! SET ABSOLUTE TEMPERATURE 265 ztkel = tsn(ji,jj,jk,jp_tem) + 273.1 6216 ztkel = tsn(ji,jj,jk,jp_tem) + 273.15 266 217 zsal = tsn(ji,jj,jk,jp_sal) + ( 1.-tmask(ji,jj,jk) ) * 35. 267 218 zsqrt = SQRT( zsal ) … … 284 235 285 236 ! DISSOCIATION CONSTANT FOR SULFATES on free H scale (Dickson 1990) 286 zcks = EXP( ks1 * ztr + ks0 + ks2 * zlogt & 287 & + ( ks3 * ztr + ks4 + ks5 * zlogt ) * zisqrt & 288 & + ( ks6 * ztr + ks7 + ks8 * zlogt ) * zis & 289 & + ks9 * ztr * zis * zisqrt + ks10 * ztr *zis2 + LOG( ks11 + ks12 *zsal ) ) 237 zcks = EXP(-4276.1 * ztr + 141.328 - 23.093 * zlogt & 238 & + (-13856. * ztr + 324.57 - 47.986 * zlogt) * zisqrt & 239 & + (35474. * ztr - 771.54 + 114.723 * zlogt) * zis & 240 & - 2698. * ztr * zis**1.5 + 1776.* ztr * zis2 & 241 & + LOG(1.0 - 0.001005 * zsal)) 242 ! 243 aphscale(ji,jj,jk) = ( 1. + zst / zcks ) 290 244 291 245 ! DISSOCIATION CONSTANT FOR FLUORIDES on free H scale (Dickson and Riley 79) 292 zckf = EXP( kf1 * ztr + kf0 + kf2 * zisqrt + LOG( kf3 + kf4 * zsal ) ) 246 zckf = EXP( 1590.2*ztr - 12.641 + 1.525*zisqrt & 247 & + LOG(1.0d0 - 0.001005d0*zsal) & 248 & + LOG(1.0d0 + zst/zcks)) 293 249 294 250 ! DISSOCIATION CONSTANT FOR CARBONATE AND BORATE 295 zckb = ( cb0 + cb1 * zsqrt + cb2 * zsal + cb3 * zsal15 + cb4 * zsal * zsal ) * ztr & 296 & + ( cb5 + cb6 * zsqrt + cb7 * zsal ) & 297 & + ( cb8 + cb9 * zsqrt + cb10 * zsal ) * zlogt + cb11 * zsqrt * ztkel & 298 & + LOG( ( 1.+ zst / zcks + zft / zckf ) / ( 1.+ zst / zcks ) ) 251 zckb= (-8966.90 - 2890.53*zsqrt - 77.942*zsal & 252 & + 1.728*zsal15 - 0.0996*zsal*zsal)*ztr & 253 & + (148.0248 + 137.1942*zsqrt + 1.62142*zsal) & 254 & + (-24.4344 - 25.085*zsqrt - 0.2474*zsal) & 255 & * zlogt + 0.053105*zsqrt*ztkel 256 299 257 300 258 zck1 = c10 * ztr + c11 + c12 * zlogt + c13 * zsal + c14 * zsal * zsal … … 302 260 303 261 ! PKW (H2O) (DICKSON AND RILEY, 1979) 304 zckw = cw0 * ztr + cw1 + cw2 * zlogt + ( cw3 * ztr + cw4 + cw5 * zlogt ) * zsqrt + cw6 * zsal 305 262 zckw = -13847.26*ztr + 148.9652 - 23.6521 * zlogt & 263 & + (118.67*ztr - 5.977 + 1.0495 * zlogt) & 264 & * zsqrt - 0.01615 * zsal 306 265 307 266 ! APPARENT SOLUBILITY PRODUCT K'SP OF CALCITE IN SEAWATER … … 378 337 !! *** ROUTINE p4z_che_alloc *** 379 338 !!---------------------------------------------------------------------- 380 ALLOCATE( sio3eq(jpi,jpj,jpk), fekeq(jpi,jpj,jpk), chemc(jpi,jpj,2), chemo2(jpi,jpj,jpk), STAT=p4z_che_alloc ) 339 ALLOCATE( sio3eq(jpi,jpj,jpk), fekeq(jpi,jpj,jpk), chemc(jpi,jpj), chemo2(jpi,jpj,jpk), & 340 & STAT=p4z_che_alloc ) 381 341 ! 382 342 IF( p4z_che_alloc /= 0 ) CALL ctl_warn('p4z_che_alloc : failed to allocate arrays.') … … 396 356 397 357 !!====================================================================== 398 END MODULE 358 END MODULE p4zche -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zflx.F90
r6836 r6839 84 84 ! 85 85 INTEGER :: ji, jj, jm, iind, iindm1 86 REAL(wp) :: ztc, ztc2, ztc3, z ws, zkgwan86 REAL(wp) :: ztc, ztc2, ztc3, ztc4, zws, zkgwan 87 87 REAL(wp) :: zfld, zflu, zfld16, zflu16, zfact 88 88 REAL(wp) :: zph, zah2, zbot, zdic, zalk, zsch_o2, zalka, zsch_co2 … … 135 135 136 136 ! CALCULATE [ALK]([CO3--], [HCO3-]) 137 zalk = zalka - ( akw3(ji,jj,1) / zph - zph + zbot / ( 1.+ zph / akb3(ji,jj,1) ) ) 137 zalk = zalka - ( akw3(ji,jj,1) / zph - zph / aphscale(ji,jj,1) & 138 & + zbot / ( 1.+ zph / akb3(ji,jj,1) ) ) 138 139 139 140 ! CALCULATE [H+] AND [H2CO3] … … 162 163 ztc2 = ztc * ztc 163 164 ztc3 = ztc * ztc2 165 ztc4 = ztc2 * ztc2 164 166 ! Compute the schmidt Number both O2 and CO2 165 zsch_co2 = 2 073.1 - 125.62 * ztc + 3.6276 * ztc2 - 0.043126 * ztc3166 zsch_o2 = 19 53.4 - 128.0 * ztc + 3.9918 * ztc2 - 0.050091 * ztc3167 zsch_co2 = 2116.8 - 136.25 * ztc + 4.7353 * ztc2 - 0.092307 * ztc3 + 0.0007555 * ztc4 168 zsch_o2 = 1920.4 - 135.6 * ztc + 5.2122 * ztc2 - 0.109390 * ztc3 + 0.0009377 * ztc4 167 169 ! wind speed 168 170 zws = wndm(ji,jj) * wndm(ji,jj) 169 171 ! Compute the piston velocity for O2 and CO2 170 zkgwan = 0. 3 * zws + 2.5 * ( 0.5246 + 0.016256 * ztc + 0.00049946 * ztc2 )172 zkgwan = 0.251 * zws 171 173 zkgwan = zkgwan * xconv * ( 1.- fr_i(ji,jj) ) * tmask(ji,jj,1) 172 174 # if defined key_degrad … … 182 184 DO ji = 1, jpi 183 185 ! Compute CO2 flux for the sea and air 184 zfld = satmco2(ji,jj) * patm(ji,jj) * tmask(ji,jj,1) * chemc(ji,jj ,1) * zkgco2(ji,jj) ! (mol/L) * (m/s)186 zfld = satmco2(ji,jj) * patm(ji,jj) * tmask(ji,jj,1) * chemc(ji,jj) * zkgco2(ji,jj) ! (mol/L) * (m/s) 185 187 zflu = zh2co3(ji,jj) * tmask(ji,jj,1) * zkgco2(ji,jj) ! (mol/L) (m/s) ? 186 188 oce_co2(ji,jj) = ( zfld - zflu ) * rfact2 * e1e2t(ji,jj) * tmask(ji,jj,1) * 1000. … … 189 191 190 192 ! Compute O2 flux 191 zfld16 = atcox * patm(ji,jj) * chemc(ji,jj,2) * tmask(ji,jj,1) * zkgo2(ji,jj) ! (mol/L) * (m/s)193 zfld16 = patm(ji,jj) * chemo2(ji,jj,1) * tmask(ji,jj,1) * zkgo2(ji,jj) ! (mol/L) * (m/s) 192 194 zflu16 = trb(ji,jj,1,jpoxy) * tmask(ji,jj,1) * zkgo2(ji,jj) 193 195 zoflx(ji,jj) = zfld16 - zflu16 … … 222 224 ENDIF 223 225 IF( iom_use( "Dpco2" ) ) THEN 224 zw2d(:,:) = ( satmco2(:,:) * patm(:,:) - zh2co3(:,:) / ( chemc(:,: ,1) + rtrn ) ) * tmask(:,:,1)226 zw2d(:,:) = ( satmco2(:,:) * patm(:,:) - zh2co3(:,:) / ( chemc(:,:) + rtrn ) ) * tmask(:,:,1) 225 227 CALL iom_put( "Dpco2" , zw2d ) 226 228 ENDIF 227 229 IF( iom_use( "Dpo2" ) ) THEN 228 zw2d(:,:) = ( atcox * patm(:,:) - trb(:,:,1,jpoxy) / ( chemc(:,:,2) + rtrn ) ) * tmask(:,:,1)230 zw2d(:,:) = ( atcox * patm(:,:) - atcox * trn(:,:,1,jpoxy) / ( chemo2(:,:,1) + rtrn ) ) * tmask(:,:,1) 229 231 CALL iom_put( "Dpo2" , zw2d ) 230 232 ENDIF … … 238 240 trc2d(:,:,jp_pcs0_2d + 1) = zoflx(:,:) * 1000 * tmask(:,:,1) 239 241 trc2d(:,:,jp_pcs0_2d + 2) = zkgco2(:,:) * tmask(:,:,1) 240 trc2d(:,:,jp_pcs0_2d + 3) = ( satmco2(:,:) * patm(:,:) - zh2co3(:,:) / ( chemc(:,: ,1) + rtrn ) ) * tmask(:,:,1)242 trc2d(:,:,jp_pcs0_2d + 3) = ( satmco2(:,:) * patm(:,:) - zh2co3(:,:) / ( chemc(:,:) + rtrn ) ) * tmask(:,:,1) 241 243 ENDIF 242 244 ENDIF … … 400 402 401 403 !!====================================================================== 402 END MODULE 404 END MODULE p4zflx -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zint.F90
r6836 r6839 81 81 82 82 !!====================================================================== 83 END MODULE 83 END MODULE p4zint -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zlim.F90
r6836 r6839 265 265 266 266 !!====================================================================== 267 END MODULE 267 END MODULE p4zlim -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zlys.F90
r6836 r6839 91 91 zalka = trb(ji,jj,jk,jptal) / zfact 92 92 ! CALCULATE [ALK]([CO3--], [HCO3-]) 93 zalk = zalka - ( akw3(ji,jj,jk) / zph - zph + borat(ji,jj,jk) / ( 1. + zph / akb3(ji,jj,jk) ) ) 93 zalk = zalka - ( akw3(ji,jj,jk) / zph - zph / ( aphscale(ji,jj,jk) + rtrn ) & 94 & + borat(ji,jj,jk) / ( 1. + zph / akb3(ji,jj,jk) ) ) 94 95 ! CALCULATE [H+] and [CO3--] 95 96 zaldi = zdic - zalk … … 152 153 IF( iom_use( "DCAL" ) ) CALL iom_put( "DCAL" , zcaldiss(:,:,:) * 1.e+3 * rfact2r * tmask(:,:,:) ) 153 154 ELSE 154 trc3d(:,:,:,jp_pcs0_3d ) = -1. * LOG10( hi(:,:,:) ) * tmask(:,:,:) 155 trc3d(:,:,:,jp_pcs0_3d + 1) = zco3(:,:,:) * tmask(:,:,:) 156 trc3d(:,:,:,jp_pcs0_3d + 2) = aksp(:,:,:) / calcon * tmask(:,:,:) 155 IF( ln_diatrc ) THEN 156 trc3d(:,:,:,jp_pcs0_3d ) = -1. * LOG10( hi(:,:,:) ) * tmask(:,:,:) 157 trc3d(:,:,:,jp_pcs0_3d + 1) = zco3(:,:,:) * tmask(:,:,:) 158 trc3d(:,:,:,jp_pcs0_3d + 2) = aksp(:,:,:) / calcon * tmask(:,:,:) 159 ENDIF 157 160 ENDIF 158 161 ! … … 223 226 #endif 224 227 !!====================================================================== 225 END MODULE 228 END MODULE p4zlys -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zmeso.F90
r6836 r6839 340 340 341 341 !!====================================================================== 342 END MODULE 342 END MODULE p4zmeso -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zmicro.F90
r6836 r6839 273 273 274 274 !!====================================================================== 275 END MODULE 275 END MODULE p4zmicro -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zmort.F90
r6836 r6839 277 277 278 278 !!====================================================================== 279 END MODULE 279 END MODULE p4zmort -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zopt.F90
r6836 r6839 76 76 REAL(wp) :: zchl 77 77 REAL(wp) :: zc0 , zc1 , zc2, zc3, z1_dep 78 REAL(wp), POINTER, DIMENSION(:,: ) :: zdepmoy, zetmp1, zetmp2, zetmp3, zetmp4, zqsr100 78 REAL(wp), POINTER, DIMENSION(:,: ) :: zdepmoy, zetmp1, zetmp2, zetmp3, zetmp4 79 REAL(wp), POINTER, DIMENSION(:,: ) :: zqsr100, zqsr_corr 79 80 REAL(wp), POINTER, DIMENSION(:,:,:) :: zpar, ze0, ze1, ze2, ze3 80 81 !!--------------------------------------------------------------------- … … 83 84 ! 84 85 ! Allocate temporary workspace 85 CALL wrk_alloc( jpi, jpj, zqsr100, zdepmoy, zetmp1, zetmp2, zetmp3, zetmp4 ) 86 CALL wrk_alloc( jpi, jpj, zdepmoy, zetmp1, zetmp2, zetmp3, zetmp4 ) 87 CALL wrk_alloc( jpi, jpj, zqsr100, zqsr_corr ) 86 88 CALL wrk_alloc( jpi, jpj, jpk, zpar, ze0, ze1, ze2, ze3 ) 87 89 … … 112 114 ! ! -------------------------------------- 113 115 IF( l_trcdm2dc ) THEN ! diurnal cycle 114 ! 1% of qsr to compute euphotic layer116 ! ! 1% of qsr to compute euphotic layer 115 117 zqsr100(:,:) = 0.01 * qsr_mean(:,:) ! daily mean qsr 116 118 ! 117 CALL p4z_opt_par( kt, qsr_mean, ze1, ze2, ze3 ) 119 zqsr_corr(:,:) = qsr_mean(:,:) / ( 1. - fr_i(:,:) + rtrn ) 120 ! 121 CALL p4z_opt_par( kt, zqsr_corr, ze1, ze2, ze3 ) 118 122 ! 119 123 DO jk = 1, nksrp … … 123 127 END DO 124 128 ! 125 CALL p4z_opt_par( kt, qsr, ze1, ze2, ze3 ) 129 zqsr_corr(:,:) = qsr(:,:) / ( 1. - fr_i(:,:) + rtrn ) 130 ! 131 CALL p4z_opt_par( kt, zqsr_corr, ze1, ze2, ze3 ) 126 132 ! 127 133 DO jk = 1, nksrp … … 133 139 zqsr100(:,:) = 0.01 * qsr(:,:) 134 140 ! 135 CALL p4z_opt_par( kt, qsr, ze1, ze2, ze3 ) 141 zqsr_corr(:,:) = qsr(:,:) / ( 1. - fr_i(:,:) + rtrn ) 142 ! 143 CALL p4z_opt_par( kt, zqsr_corr, ze1, ze2, ze3 ) 136 144 ! 137 145 DO jk = 1, nksrp … … 226 234 ENDIF 227 235 ! 228 CALL wrk_dealloc( jpi, jpj, zqsr100, zdepmoy, zetmp1, zetmp2, zetmp3, zetmp4 ) 236 CALL wrk_dealloc( jpi, jpj, zdepmoy, zetmp1, zetmp2, zetmp3, zetmp4 ) 237 CALL wrk_dealloc( jpi, jpj, zqsr100, zqsr_corr ) 229 238 CALL wrk_dealloc( jpi, jpj, jpk, zpar, ze0, ze1, ze2, ze3 ) 230 239 ! … … 439 448 440 449 !!====================================================================== 441 END MODULE 450 END MODULE p4zopt -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zprod.F90
r6836 r6839 136 136 zval = MAX( 1., zstrn(ji,jj) ) 137 137 zval = 1.5 * zval / ( 12. + zval ) 138 zprbio(ji,jj,jk) = prmax(ji,jj,jk) * zval 138 zprbio(ji,jj,jk) = prmax(ji,jj,jk) * zval * ( 1. - fr_i(ji,jj) ) 139 139 zprdia(ji,jj,jk) = zprbio(ji,jj,jk) 140 140 ENDIF … … 629 629 630 630 !!====================================================================== 631 END MODULE 631 END MODULE p4zprod -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zsbc.F90
r6836 r6839 519 519 520 520 !!====================================================================== 521 END MODULE 521 END MODULE p4zsbc -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zsed.F90
r6836 r6839 72 72 CHARACTER (len=25) :: charout 73 73 REAL(wp), POINTER, DIMENSION(:,: ) :: zpdep, zsidep, zwork1, zwork2, zwork3 74 REAL(wp), POINTER, DIMENSION(:,:) :: zsedcal, zsedsi, zsedc 74 75 REAL(wp), POINTER, DIMENSION(:,: ) :: zdenit2d, zironice, zbureff 75 76 REAL(wp), POINTER, DIMENSION(:,: ) :: zwsbio3, zwsbio4, zwscal … … 83 84 ! Allocate temporary workspace 84 85 CALL wrk_alloc( jpi, jpj, zdenit2d, zwork1, zwork2, zwork3, zbureff ) 86 CALL wrk_alloc( jpi, jpj, zsedcal, zsedsi, zsedc ) 85 87 CALL wrk_alloc( jpi, jpj, zwsbio3, zwsbio4, zwscal ) 86 88 CALL wrk_alloc( jpi, jpj, jpk, zsoufer ) … … 91 93 zwork2 (:,:) = 0.e0 92 94 zwork3 (:,:) = 0.e0 95 zsedsi (:,:) = 0.e0 96 zsedcal (:,:) = 0.e0 97 zsedc (:,:) = 0.e0 93 98 94 99 ! Iron input/uptake due to sea ice : Crude parameterization based on Lancelot et al. … … 298 303 tra(ji,jj,ikt,jptal) = tra(ji,jj,ikt,jptal) + zcaloss * zrivalk * 2.0 299 304 tra(ji,jj,ikt,jpdic) = tra(ji,jj,ikt,jpdic) + zcaloss * zrivalk 305 zsedcal(ji,jj) = (1.0 - zrivalk) * zcaloss / zdep 306 zsedsi (ji,jj) = (1.0 - zrivsil) * zsiloss / zdep 300 307 #endif 301 308 END DO … … 336 343 tra(ji,jj,ikt,jptal) = tra(ji,jj,ikt,jptal) + rno3 * (zolimit + (1.+rdenit) * (zpdenit + zdenitt) ) 337 344 tra(ji,jj,ikt,jpdic) = tra(ji,jj,ikt,jpdic) + zpdenit + zolimit + zdenitt 338 sdenit(ji,jj) = rdenit * zpdenit * fse3t(ji,jj,ikt) 345 sdenit(ji,jj) = rdenit * zpdenit / zdep 346 zsedc(ji,jj) = (1. - zrivno3) * zwstpoc / zdep 339 347 #endif 340 348 END DO … … 392 400 CALL iom_put( "INTNFIX" , zwork1 ) 393 401 ENDIF 402 IF( iom_use("SedCal" ) ) CALL iom_put( "SedCal", zsedcal(:,:) * 1.e+3 ) 403 IF( iom_use("SedSi" ) ) CALL iom_put( "SedSi", zsedsi (:,:) * 1.e+3 ) 404 IF( iom_use("SedC" ) ) CALL iom_put( "SedC", zsedc (:,:) * 1.e+3 ) 405 IF( iom_use("Sdenit" ) ) CALL iom_put( "Sdenit", sdenit (:,:) * 1.e+3 * rno3 ) 394 406 ENDIF 395 407 ELSE … … 405 417 ! 406 418 CALL wrk_dealloc( jpi, jpj, zdenit2d, zwork1, zwork2, zwork3, zbureff ) 419 CALL wrk_dealloc( jpi, jpj, zsedcal , zsedsi, zsedc ) 407 420 CALL wrk_dealloc( jpi, jpj, zwsbio3, zwsbio4, zwscal ) 408 421 CALL wrk_dealloc( jpi, jpj, jpk, zsoufer ) … … 436 449 437 450 !!====================================================================== 438 END MODULE 451 END MODULE p4zsed -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zsink.F90
r6836 r6839 913 913 914 914 !!====================================================================== 915 END MODULE 915 END MODULE p4zsink -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zsms.F90
r6836 r6839 38 38 39 39 REAL(wp) :: alkbudget, no3budget, silbudget, ferbudget, po4budget 40 REAL(wp) :: xfact1, xfact2 40 REAL(wp) :: xfact1, xfact2, xfact3 41 41 INTEGER :: numco2, numnut, numnit !: logical unit for co2 budget 42 42 … … 133 133 ! 134 134 CALL p4z_bio( kt, jnt ) ! Biology 135 CALL p4z_sed( kt, jnt ) ! Sedimentation136 135 CALL p4z_lys( kt, jnt ) ! Compute CaCO3 saturation 136 CALL p4z_sed( kt, jnt ) ! Surface and Bottom boundary conditions 137 137 CALL p4z_flx( kt, jnt ) ! Compute surface fluxes 138 138 ! … … 474 474 !!--------------------------------------------------------------------- 475 475 ! 476 INTEGER , INTENT( in ) :: kt ! ocean time-step index 477 REAL(wp) :: zfact 478 REAL(wp) :: zrdenittot, zsdenittot, znitrpottot 476 INTEGER, INTENT( in ) :: kt ! ocean time-step index 477 REAL(wp) :: zrdenittot, zsdenittot, znitrpottot 479 478 CHARACTER(LEN=100) :: cltxt 480 479 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zvol … … 492 491 xfact1 = rfact2r * 12. / 1.e15 * ryyss ! conversion molC/kt --> PgC/yr 493 492 xfact2 = 1.e+3 * rno3 * 14. / 1.e12 * ryyss ! conversion molC/l/s ----> TgN/m3/yr 493 xfact3 = 1.e+3 * rfact2r * rno3 ! conversion molC/l/kt ----> molN/m3/s 494 494 cltxt='time-step Alkalinity Nitrate Phosphorus Silicate Iron' 495 495 IF( lwp ) WRITE(numnut,*) TRIM(cltxt) … … 574 574 IF( iom_use( "Sdenit" ) .OR. ( ln_check_mass .AND. kt == nitend ) ) THEN 575 575 zsdenittot = glob_sum ( sdenit(:,:) * e1e2t(:,:) ) 576 CALL iom_put( "Sdenit", sdenit(:,:) * zfact* tmask(:,:,1) ) ! Nitrate reduction in the sediments576 CALL iom_put( "Sdenit", sdenit(:,:) * xfact3 * tmask(:,:,1) ) ! Nitrate reduction in the sediments 577 577 ENDIF 578 578 -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/TOP_SRC/PISCES/sms_pisces.F90
r6836 r6839 101 101 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: hi !: ??? 102 102 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: excess !: ??? 103 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: aphscale !: 104 103 105 104 106 !!* Temperature dependancy of SMS terms … … 154 156 & ak23(jpi,jpj,jpk) , aksp (jpi,jpj,jpk) , & 155 157 & akw3(jpi,jpj,jpk) , borat (jpi,jpj,jpk) , & 156 & hi (jpi,jpj,jpk) , excess(jpi,jpj,jpk) , STAT=ierr(4) ) 158 & hi (jpi,jpj,jpk) , excess(jpi,jpj,jpk) , & 159 & aphscale(jpi,jpj,jpk), STAT=ierr(4) ) 157 160 ! 158 161 !* Temperature dependancy of SMS terms -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/TOP_SRC/PISCES/trcice_pisces.F90
r5385 r6839 29 29 CONTAINS 30 30 31 31 32 SUBROUTINE trc_ice_ini_pisces 32 33 !!---------------------------------------------------------------------- 33 !! *** ROUTINE trc_ice_ini_pisces *** 34 !! *** ROUTINE trc_ini_pisces *** 35 !! 36 !! ** Purpose : Initialisation of the PISCES biochemical model 37 !!---------------------------------------------------------------------- 38 39 IF( lk_p4z ) THEN ; CALL p4z_ice_ini ! PISCES 40 ELSE ; CALL p2z_ice_ini ! LOBSTER 41 ENDIF 42 43 END SUBROUTINE trc_ice_ini_pisces 44 45 46 SUBROUTINE p4z_ice_ini 47 48 #if defined key_pisces 49 !!---------------------------------------------------------------------- 50 !! *** ROUTINE p4z_ice_ini *** 34 51 !! 35 52 !! ** Purpose : PISCES fake sea ice model setting … … 58 75 59 76 !--- Dummy variables 60 REAL(wp), DIMENSION(jptra,2) & 61 :: zratio ! effective ice-ocean tracer cc ratio 77 REAL(wp), DIMENSION(jp_pisces,2) :: zratio ! effective ice-ocean tracer cc ratio 78 REAL(wp), DIMENSION(jp_pisces,4) :: zpisc ! prescribes concentration 79 ! ! 1:global, 2:Arctic, 3:Antarctic, 4:Baltic 80 62 81 REAL(wp), DIMENSION(2) :: zrs ! ice-ocean salinity ratio, 1 - global, 2- Baltic 63 82 REAL(wp) :: zsice_bal ! prescribed ice salinity in the Baltic … … 80 99 ! fluxes 81 100 82 !--- Global case83 IF ( cn_trc_o(jpdic) == 'GL ' ) trc_o(:,:,jpdic) = 1.99e-3_wp84 IF ( cn_trc_o(jpdoc) == 'GL ' ) trc_o(:,:,jpdoc) = 2.04e-5_wp85 IF ( cn_trc_o(jptal) == 'GL ' ) trc_o(:,:,jptal) = 2.31e-3_wp86 IF ( cn_trc_o(jpoxy) == 'GL ' ) trc_o(:,:,jpoxy) = 2.47e-4_wp87 IF ( cn_trc_o(jpcal) == 'GL ' ) trc_o(:,:,jpcal) = 1.04e-8_wp88 IF ( cn_trc_o(jppo4) == 'GL ' ) trc_o(:,:,jppo4) = 5.77e-7_wp / po4r89 IF ( cn_trc_o(jppoc) == 'GL ' ) trc_o(:,:,jppoc) = 1.27e-6_wp101 !--- Global values 102 zpisc(jpdic,1) = 1.99e-3_wp 103 zpisc(jpdoc,1) = 2.04e-5_wp 104 zpisc(jptal,1) = 2.31e-3_wp 105 zpisc(jpoxy,1) = 2.47e-4_wp 106 zpisc(jpcal,1) = 1.04e-8_wp 107 zpisc(jppo4,1) = 5.77e-7_wp / po4r 108 zpisc(jppoc,1) = 1.27e-6_wp 90 109 # if ! defined key_kriest 91 IF ( cn_trc_o(jpgoc) == 'GL ' ) trc_o(:,:,jpgoc) = 5.23e-8_wp92 IF ( cn_trc_o(jpbfe) == 'GL ' ) trc_o(:,:,jpbfe) = 9.84e-13_wp110 zpisc(jpgoc,1) = 5.23e-8_wp 111 zpisc(jpbfe,1) = 9.84e-13_wp 93 112 # else 94 IF ( cn_trc_o(jpnum) == 'GL ' ) trc_o(:,:,jpnum) = 0. ! could not get this value since did not use it113 zpisc(jpnum,1) = 0. ! could not get this value since did not use it 95 114 # endif 96 IF ( cn_trc_o(jpsil) == 'GL ' ) trc_o(:,:,jpsil) = 7.36e-6_wp97 IF ( cn_trc_o(jpdsi) == 'GL ' ) trc_o(:,:,jpdsi) = 1.07e-7_wp98 IF ( cn_trc_o(jpgsi) == 'GL ' ) trc_o(:,:,jpgsi) = 1.53e-8_wp99 IF ( cn_trc_o(jpphy) == 'GL ' ) trc_o(:,:,jpphy) = 9.57e-8_wp100 IF ( cn_trc_o(jpdia) == 'GL ' ) trc_o(:,:,jpdia) = 4.24e-7_wp101 IF ( cn_trc_o(jpzoo) == 'GL ' ) trc_o(:,:,jpzoo) = 6.07e-7_wp102 IF ( cn_trc_o(jpmes) == 'GL ' ) trc_o(:,:,jpmes) = 3.44e-7_wp103 IF ( cn_trc_o(jpfer) == 'GL ' ) trc_o(:,:,jpfer) = 4.06e-10_wp104 IF ( cn_trc_o(jpsfe) == 'GL ' ) trc_o(:,:,jpsfe) = 2.51e-11_wp105 IF ( cn_trc_o(jpdfe) == 'GL ' ) trc_o(:,:,jpdfe) = 6.57e-12_wp106 IF ( cn_trc_o(jpnfe) == 'GL ' ) trc_o(:,:,jpnfe) = 1.76e-11_wp107 IF ( cn_trc_o(jpnch) == 'GL ' ) trc_o(:,:,jpnch) = 1.67e-7_wp108 IF ( cn_trc_o(jpdch) == 'GL ' ) trc_o(:,:,jpdch) = 1.02e-7_wp109 IF ( cn_trc_o(jpno3) == 'GL ' ) trc_o(:,:,jpno3) = 5.79e-6_wp / rno3110 IF ( cn_trc_o(jpnh4) == 'GL ' ) trc_o(:,:,jpnh4) = 3.22e-7_wp / rno3115 zpisc(jpsil,1) = 7.36e-6_wp 116 zpisc(jpdsi,1) = 1.07e-7_wp 117 zpisc(jpgsi,1) = 1.53e-8_wp 118 zpisc(jpphy,1) = 9.57e-8_wp 119 zpisc(jpdia,1) = 4.24e-7_wp 120 zpisc(jpzoo,1) = 6.07e-7_wp 121 zpisc(jpmes,1) = 3.44e-7_wp 122 zpisc(jpfer,1) = 4.06e-10_wp 123 zpisc(jpsfe,1) = 2.51e-11_wp 124 zpisc(jpdfe,1) = 6.57e-12_wp 125 zpisc(jpnfe,1) = 1.76e-11_wp 126 zpisc(jpnch,1) = 1.67e-7_wp 127 zpisc(jpdch,1) = 1.02e-7_wp 128 zpisc(jpno3,1) = 5.79e-6_wp / rno3 129 zpisc(jpnh4,1) = 3.22e-7_wp / rno3 111 130 112 131 !--- Arctic specificities (dissolved inorganic & DOM) 113 IF ( cn_trc_o(jpdic) == 'AA ' ) THEN ; WHERE( gphit(:,:) >= 00._wp ) ; trc_o(:,:,jpdic) = 1.98e-3_wp ; END WHERE ; ENDIF114 IF ( cn_trc_o(jpdoc) == 'AA ' ) THEN ; WHERE( gphit(:,:) >= 00._wp ) ; trc_o(:,:,jpdoc) = 6.00e-6_wp ; END WHERE ; ENDIF115 IF ( cn_trc_o(jptal) == 'AA ' ) THEN ; WHERE( gphit(:,:) >= 00._wp ) ; trc_o(:,:,jptal) = 2.13e-3_wp ; END WHERE ; ENDIF116 IF ( cn_trc_o(jpoxy) == 'AA ' ) THEN ; WHERE( gphit(:,:) >= 00._wp ) ; trc_o(:,:,jpoxy) = 3.65e-4_wp ; END WHERE ; ENDIF117 IF ( cn_trc_o(jpcal) == 'AA ' ) THEN ; WHERE( gphit(:,:) >= 00._wp ) ; trc_o(:,:,jpcal) = 1.50e-9_wp ; END WHERE ; ENDIF118 IF ( cn_trc_o(jppo4) == 'AA ' ) THEN ; WHERE( gphit(:,:) >= 00._wp ) ; trc_o(:,:,jppo4) = 4.09e-7_wp / po4r ; END WHERE ; ENDIF119 IF ( cn_trc_o(jppoc) == 'AA ' ) THEN ; WHERE( gphit(:,:) >= 00._wp ) ; trc_o(:,:,jppoc) = 4.05e-7_wp ; END WHERE ; ENDIF132 zpisc(jpdic,2) = 1.98e-3_wp 133 zpisc(jpdoc,2) = 6.00e-6_wp 134 zpisc(jptal,2) = 2.13e-3_wp 135 zpisc(jpoxy,2) = 3.65e-4_wp 136 zpisc(jpcal,2) = 1.50e-9_wp 137 zpisc(jppo4,2) = 4.09e-7_wp / po4r 138 zpisc(jppoc,2) = 4.05e-7_wp 120 139 # if ! defined key_kriest 121 IF ( cn_trc_o(jpgoc) == 'AA ' ) THEN ; WHERE( gphit(:,:) >= 00._wp ) ; trc_o(:,:,jpgoc) = 2.84e-8_wp ; END WHERE ; ENDIF122 IF ( cn_trc_o(jpbfe) == 'AA ' ) THEN ; WHERE( gphit(:,:) >= 00._wp ) ; trc_o(:,:,jpbfe) = 7.03e-13_wp ; END WHERE ; ENDIF140 zpisc(jpgoc,2) = 2.84e-8_wp 141 zpisc(jpbfe,2) = 7.03e-13_wp 123 142 # else 124 IF ( cn_trc_o(jpnum) == 'AA ' ) THEN ; WHERE( gphit(:,:) >= 00._wp ) ; trc_o(:,:,jpnum) = 0.00e-00_wp ; END WHERE ; ENDIF143 zpisc(jpnum,2) = 0.00e-00_wp 125 144 # endif 126 IF ( cn_trc_o(jpsil) == 'AA ' ) THEN ; WHERE( gphit(:,:) >= 00._wp ) ; trc_o(:,:,jpsil) = 6.87e-6_wp ; END WHERE ; ENDIF127 IF ( cn_trc_o(jpdsi) == 'AA ' ) THEN ; WHERE( gphit(:,:) >= 00._wp ) ; trc_o(:,:,jpdsi) = 1.73e-7_wp ; END WHERE ; ENDIF128 IF ( cn_trc_o(jpgsi) == 'AA ' ) THEN ; WHERE( gphit(:,:) >= 00._wp ) ; trc_o(:,:,jpgsi) = 7.93e-9_wp ; END WHERE ; ENDIF129 IF ( cn_trc_o(jpphy) == 'AA ' ) THEN ; WHERE( gphit(:,:) >= 00._wp ) ; trc_o(:,:,jpphy) = 5.25e-7_wp ; END WHERE ; ENDIF130 IF ( cn_trc_o(jpdia) == 'AA ' ) THEN ; WHERE( gphit(:,:) >= 00._wp ) ; trc_o(:,:,jpdia) = 7.75e-7_wp ; END WHERE ; ENDIF131 IF ( cn_trc_o(jpzoo) == 'AA ' ) THEN ; WHERE( gphit(:,:) >= 00._wp ) ; trc_o(:,:,jpzoo) = 3.34e-7_wp ; END WHERE ; ENDIF132 IF ( cn_trc_o(jpmes) == 'AA ' ) THEN ; WHERE( gphit(:,:) >= 00._wp ) ; trc_o(:,:,jpmes) = 2.49e-7_wp ; END WHERE ; ENDIF133 IF ( cn_trc_o(jpfer) == 'AA ' ) THEN ; WHERE( gphit(:,:) >= 00._wp ) ; trc_o(:,:,jpfer) = 1.43e-9_wp ; END WHERE ; ENDIF134 IF ( cn_trc_o(jpsfe) == 'AA ' ) THEN ; WHERE( gphit(:,:) >= 00._wp ) ; trc_o(:,:,jpsfe) = 2.21e-11_wp ; END WHERE ; ENDIF135 IF ( cn_trc_o(jpdfe) == 'AA ' ) THEN ; WHERE( gphit(:,:) >= 00._wp ) ; trc_o(:,:,jpdfe) = 2.04e-11_wp ; END WHERE ; ENDIF136 IF ( cn_trc_o(jpnfe) == 'AA ' ) THEN ; WHERE( gphit(:,:) >= 00._wp ) ; trc_o(:,:,jpnfe) = 1.75e-11_wp ; END WHERE ; ENDIF137 IF ( cn_trc_o(jpnch) == 'AA ' ) THEN ; WHERE( gphit(:,:) >= 00._wp ) ; trc_o(:,:,jpnch) = 1.46e-07_wp ; END WHERE ; ENDIF138 IF ( cn_trc_o(jpdch) == 'AA ' ) THEN ; WHERE( gphit(:,:) >= 00._wp ) ; trc_o(:,:,jpdch) = 2.36e-07_wp ; END WHERE ; ENDIF139 IF ( cn_trc_o(jpno3) == 'AA ' ) THEN ; WHERE( gphit(:,:) >= 00._wp ) ; trc_o(:,:,jpno3) = 3.51e-06_wp / rno3 ; END WHERE ; ENDIF140 IF ( cn_trc_o(jpnh4) == 'AA ' ) THEN ; WHERE( gphit(:,:) >= 00._wp ) ; trc_o(:,:,jpnh4) = 6.15e-08_wp / rno3 ; END WHERE ; ENDIF145 zpisc(jpsil,2) = 6.87e-6_wp 146 zpisc(jpdsi,2) = 1.73e-7_wp 147 zpisc(jpgsi,2) = 7.93e-9_wp 148 zpisc(jpphy,2) = 5.25e-7_wp 149 zpisc(jpdia,2) = 7.75e-7_wp 150 zpisc(jpzoo,2) = 3.34e-7_wp 151 zpisc(jpmes,2) = 2.49e-7_wp 152 zpisc(jpfer,2) = 1.43e-9_wp 153 zpisc(jpsfe,2) = 2.21e-11_wp 154 zpisc(jpdfe,2) = 2.04e-11_wp 155 zpisc(jpnfe,2) = 1.75e-11_wp 156 zpisc(jpnch,2) = 1.46e-07_wp 157 zpisc(jpdch,2) = 2.36e-07_wp 158 zpisc(jpno3,2) = 3.51e-06_wp / rno3 159 zpisc(jpnh4,2) = 6.15e-08_wp / rno3 141 160 142 161 !--- Antarctic specificities (dissolved inorganic & DOM) 143 IF ( cn_trc_o(jpdic) == 'AA ' ) THEN ; WHERE( gphit(:,:) < 00._wp ) ; trc_o(:,:,jpdic) = 2.20e-3_wp ; END WHERE ; ENDIF144 IF ( cn_trc_o(jpdoc) == 'AA ' ) THEN ; WHERE( gphit(:,:) < 00._wp ) ; trc_o(:,:,jpdoc) = 7.02e-6_wp ; END WHERE ; ENDIF145 IF ( cn_trc_o(jptal) == 'AA ' ) THEN ; WHERE( gphit(:,:) < 00._wp ) ; trc_o(:,:,jptal) = 2.37e-3_wp ; END WHERE ; ENDIF146 IF ( cn_trc_o(jpoxy) == 'AA ' ) THEN ; WHERE( gphit(:,:) < 00._wp ) ; trc_o(:,:,jpoxy) = 3.42e-4_wp ; END WHERE ; ENDIF147 IF ( cn_trc_o(jpcal) == 'AA ' ) THEN ; WHERE( gphit(:,:) < 00._wp ) ; trc_o(:,:,jpcal) = 3.17e-9_wp ; END WHERE ; ENDIF148 IF ( cn_trc_o(jppo4) == 'AA ' ) THEN ; WHERE( gphit(:,:) < 00._wp ) ; trc_o(:,:,jppo4) = 1.88e-6_wp / po4r ; END WHERE ; ENDIF149 IF ( cn_trc_o(jppoc) == 'AA ' ) THEN ; WHERE( gphit(:,:) < 00._wp ) ; trc_o(:,:,jppoc) = 1.13e-6_wp ; END WHERE ; ENDIF162 zpisc(jpdic,3) = 2.20e-3_wp 163 zpisc(jpdoc,3) = 7.02e-6_wp 164 zpisc(jptal,3) = 2.37e-3_wp 165 zpisc(jpoxy,3) = 3.42e-4_wp 166 zpisc(jpcal,3) = 3.17e-9_wp 167 zpisc(jppo4,3) = 1.88e-6_wp / po4r 168 zpisc(jppoc,3) = 1.13e-6_wp 150 169 # if ! defined key_kriest 151 IF ( cn_trc_o(jpgoc) == 'AA ' ) THEN ; WHERE( gphit(:,:) < 00._wp ) ; trc_o(:,:,jpgoc) = 2.89e-8_wp ; END WHERE ; ENDIF152 IF ( cn_trc_o(jpbfe) == 'AA ' ) THEN ; WHERE( gphit(:,:) < 00._wp ) ; trc_o(:,:,jpbfe) = 5.63e-13_wp ; END WHERE ; ENDIF170 zpisc(jpgoc,3) = 2.89e-8_wp 171 zpisc(jpbfe,3) = 5.63e-13_wp 153 172 # else 154 IF ( cn_trc_o(jpnum) == 'AA ' ) THEN ; WHERE( gphit(:,:) < 00._wp ) ; trc_o(:,:,jpnum) = 0.00e-00_wp ; END WHERE ; ENDIF173 zpisc(jpnum,3) = 0.00e-00_wp 155 174 # endif 156 IF ( cn_trc_o(jpsil) == 'AA ' ) THEN ; WHERE( gphit(:,:) < 00._wp ) ; trc_o(:,:,jpsil) = 4.96e-5_wp ; END WHERE ; ENDIF157 IF ( cn_trc_o(jpdsi) == 'AA ' ) THEN ; WHERE( gphit(:,:) < 00._wp ) ; trc_o(:,:,jpdsi) = 5.63e-7_wp ; END WHERE ; ENDIF158 IF ( cn_trc_o(jpgsi) == 'AA ' ) THEN ; WHERE( gphit(:,:) < 00._wp ) ; trc_o(:,:,jpgsi) = 5.35e-8_wp ; END WHERE ; ENDIF159 IF ( cn_trc_o(jpphy) == 'AA ' ) THEN ; WHERE( gphit(:,:) < 00._wp ) ; trc_o(:,:,jpphy) = 8.10e-7_wp ; END WHERE ; ENDIF160 IF ( cn_trc_o(jpdia) == 'AA ' ) THEN ; WHERE( gphit(:,:) < 00._wp ) ; trc_o(:,:,jpdia) = 5.77e-7_wp ; END WHERE ; ENDIF161 IF ( cn_trc_o(jpzoo) == 'AA ' ) THEN ; WHERE( gphit(:,:) < 00._wp ) ; trc_o(:,:,jpzoo) = 6.68e-7_wp ; END WHERE ; ENDIF162 IF ( cn_trc_o(jpmes) == 'AA ' ) THEN ; WHERE( gphit(:,:) < 00._wp ) ; trc_o(:,:,jpmes) = 3.55e-7_wp ; END WHERE ; ENDIF163 IF ( cn_trc_o(jpfer) == 'AA ' ) THEN ; WHERE( gphit(:,:) < 00._wp ) ; trc_o(:,:,jpfer) = 1.62e-10_wp ; END WHERE ; ENDIF164 IF ( cn_trc_o(jpsfe) == 'AA ' ) THEN ; WHERE( gphit(:,:) < 00._wp ) ; trc_o(:,:,jpsfe) = 2.29e-11_wp ; END WHERE ; ENDIF165 IF ( cn_trc_o(jpdfe) == 'AA ' ) THEN ; WHERE( gphit(:,:) < 00._wp ) ; trc_o(:,:,jpdfe) = 8.75e-12_wp ; END WHERE ; ENDIF166 IF ( cn_trc_o(jpnfe) == 'AA ' ) THEN ; WHERE( gphit(:,:) < 00._wp ) ; trc_o(:,:,jpnfe) = 1.48e-11_wp ; END WHERE ; ENDIF167 IF ( cn_trc_o(jpnch) == 'AA ' ) THEN ; WHERE( gphit(:,:) < 00._wp ) ; trc_o(:,:,jpnch) = 2.02e-7_wp ; END WHERE ; ENDIF168 IF ( cn_trc_o(jpdch) == 'AA ' ) THEN ; WHERE( gphit(:,:) < 00._wp ) ; trc_o(:,:,jpdch) = 1.60e-7_wp ; END WHERE ; ENDIF169 IF ( cn_trc_o(jpno3) == 'AA ' ) THEN ; WHERE( gphit(:,:) < 00._wp ) ; trc_o(:,:,jpno3) = 2.64e-5_wp / rno3 ; END WHERE ; ENDIF170 IF ( cn_trc_o(jpnh4) == 'AA ' ) THEN ; WHERE( gphit(:,:) < 00._wp ) ; trc_o(:,:,jpnh4) = 3.39e-7_wp / rno3 ; END WHERE ; ENDIF175 zpisc(jpsil,3) = 4.96e-5_wp 176 zpisc(jpdsi,3) = 5.63e-7_wp 177 zpisc(jpgsi,3) = 5.35e-8_wp 178 zpisc(jpphy,3) = 8.10e-7_wp 179 zpisc(jpdia,3) = 5.77e-7_wp 180 zpisc(jpzoo,3) = 6.68e-7_wp 181 zpisc(jpmes,3) = 3.55e-7_wp 182 zpisc(jpfer,3) = 1.62e-10_wp 183 zpisc(jpsfe,3) = 2.29e-11_wp 184 zpisc(jpdfe,3) = 8.75e-12_wp 185 zpisc(jpnfe,3) = 1.48e-11_wp 186 zpisc(jpnch,3) = 2.02e-7_wp 187 zpisc(jpdch,3) = 1.60e-7_wp 188 zpisc(jpno3,3) = 2.64e-5_wp / rno3 189 zpisc(jpnh4,3) = 3.39e-7_wp / rno3 171 190 172 191 !--- Baltic Sea particular case for ORCA configurations 173 IF( cp_cfg == "orca" ) THEN ! Baltic mask 174 WHERE( 14._wp <= glamt(:,:) .AND. glamt(:,:) <= 32._wp .AND. & 175 54._wp <= gphit(:,:) .AND. gphit(:,:) <= 66._wp ) 176 trc_o(:,:,jpdic) = 1.14e-3_wp 177 trc_o(:,:,jpdoc) = 1.06e-5_wp 178 trc_o(:,:,jptal) = 1.16e-3_wp 179 trc_o(:,:,jpoxy) = 3.71e-4_wp 180 trc_o(:,:,jpcal) = 1.51e-9_wp 181 trc_o(:,:,jppo4) = 2.85e-9_wp / po4r 182 trc_o(:,:,jppoc) = 4.84e-7_wp 192 zpisc(jpdic,4) = 1.14e-3_wp 193 zpisc(jpdoc,4) = 1.06e-5_wp 194 zpisc(jptal,4) = 1.16e-3_wp 195 zpisc(jpoxy,4) = 3.71e-4_wp 196 zpisc(jpcal,4) = 1.51e-9_wp 197 zpisc(jppo4,4) = 2.85e-9_wp / po4r 198 zpisc(jppoc,4) = 4.84e-7_wp 183 199 # if ! defined key_kriest 184 trc_o(:,:,jpgoc) = 1.05e-8_wp185 trc_o(:,:,jpbfe) = 4.97e-13_wp200 zpisc(jpgoc,4) = 1.05e-8_wp 201 zpisc(jpbfe,4) = 4.97e-13_wp 186 202 # else 187 trc_o(:,:,jpnum) = 0. ! could not get this value203 zpisc(jpnum,4) = 0. ! could not get this value 188 204 # endif 189 trc_o(:,:,jpsil) = 4.91e-5_wp 190 trc_o(:,:,jpdsi) = 3.25e-7_wp 191 trc_o(:,:,jpgsi) = 1.93e-8_wp 192 trc_o(:,:,jpphy) = 6.64e-7_wp 193 trc_o(:,:,jpdia) = 3.41e-7_wp 194 trc_o(:,:,jpzoo) = 3.83e-7_wp 195 trc_o(:,:,jpmes) = 0.225e-6_wp 196 trc_o(:,:,jpfer) = 2.45e-9_wp 197 trc_o(:,:,jpsfe) = 3.89e-11_wp 198 trc_o(:,:,jpdfe) = 1.33e-11_wp 199 trc_o(:,:,jpnfe) = 2.62e-11_wp 200 trc_o(:,:,jpnch) = 1.17e-7_wp 201 trc_o(:,:,jpdch) = 9.69e-8_wp 202 trc_o(:,:,jpno3) = 5.36e-5_wp / rno3 203 trc_o(:,:,jpnh4) = 7.18e-7_wp / rno3 204 END WHERE 205 ENDIF ! cfg 205 zpisc(jpsil,4) = 4.91e-5_wp 206 zpisc(jpdsi,4) = 3.25e-7_wp 207 zpisc(jpgsi,4) = 1.93e-8_wp 208 zpisc(jpphy,4) = 6.64e-7_wp 209 zpisc(jpdia,4) = 3.41e-7_wp 210 zpisc(jpzoo,4) = 3.83e-7_wp 211 zpisc(jpmes,4) = 0.225e-6_wp 212 zpisc(jpfer,4) = 2.45e-9_wp 213 zpisc(jpsfe,4) = 3.89e-11_wp 214 zpisc(jpdfe,4) = 1.33e-11_wp 215 zpisc(jpnfe,4) = 2.62e-11_wp 216 zpisc(jpnch,4) = 1.17e-7_wp 217 zpisc(jpdch,4) = 9.69e-8_wp 218 zpisc(jpno3,4) = 5.36e-5_wp / rno3 219 zpisc(jpnh4,4) = 7.18e-7_wp / rno3 220 221 DO jn = jp_pcs0, jp_pcs1 222 IF( cn_trc_o(jn) == 'GL ' ) trc_o(:,:,jn) = zpisc(jn,1) ! Global case 223 IF( cn_trc_o(jn) == 'AA ' ) THEN 224 WHERE( gphit(:,:) >= 0._wp ) ; trc_o(:,:,jn) = zpisc(jn,2) ; END WHERE ! Arctic 225 WHERE( gphit(:,:) < 0._wp ) ; trc_o(:,:,jn) = zpisc(jn,3) ; END WHERE ! Antarctic 226 ENDIF 227 IF( cp_cfg == "orca" ) THEN ! Baltic Sea particular case for ORCA configurations 228 WHERE( 14._wp <= glamt(:,:) .AND. glamt(:,:) <= 32._wp .AND. & 229 54._wp <= gphit(:,:) .AND. gphit(:,:) <= 66._wp ) 230 trc_o(:,:,jn) = zpisc(jn,4) 231 END WHERE 232 ENDIF 233 ENDDO 234 235 206 236 207 237 !----------------------------- … … 217 247 218 248 DO jn = jp_pcs0, jp_pcs1 219 IF 220 IF 221 IF 249 IF( trc_ice_ratio(jn) >= 0._wp ) zratio(jn,:) = trc_ice_ratio(jn) 250 IF( trc_ice_ratio(jn) == -1._wp ) zratio(jn,:) = zrs(:) 251 IF( trc_ice_ratio(jn) == -2._wp ) zratio(jn,:) = -9999.99_wp 222 252 END DO 223 253 … … 227 257 DO jn = jp_pcs0, jp_pcs1 228 258 !-- Everywhere but in the Baltic 229 IF ( trc_ice_ratio(jn) >= -1._wp ) THEN !! no prescribed concentration 230 !! (typically everything but iron) 259 IF ( trc_ice_ratio(jn) >= -1._wp ) THEN ! no prescribed conc. ; typically everything but iron) 231 260 trc_i(:,:,jn) = zratio(jn,1) * trc_o(:,:,jn) 232 ELSE !! prescribed concentration261 ELSE ! prescribed concentration 233 262 trc_i(:,:,jn) = trc_ice_prescr(jn) 234 263 ENDIF 235 264 236 265 !-- Baltic 237 IF( cp_cfg == "orca" ) THEN !! Baltic treated seperately for ORCA configs 238 IF ( trc_ice_ratio(jn) >= - 1._wp ) THEN !! no prescribed concentration 239 !! (typically everything but iron) 266 IF( cp_cfg == "orca" ) THEN ! Baltic treated seperately for ORCA configs 267 IF ( trc_ice_ratio(jn) >= - 1._wp ) THEN ! no prescribed conc. ; typically everything but iron) 240 268 WHERE( 14._wp <= glamt(:,:) .AND. glamt(:,:) <= 32._wp .AND. & 241 269 54._wp <= gphit(:,:) .AND. gphit(:,:) <= 66._wp ) 242 270 trc_i(:,:,jn) = zratio(jn,2) * trc_o(:,:,jn) 243 271 END WHERE 244 ELSE ! !prescribed tracer concentration in ice272 ELSE ! prescribed tracer concentration in ice 245 273 WHERE( 14._wp <= glamt(:,:) .AND. glamt(:,:) <= 32._wp .AND. & 246 274 54._wp <= gphit(:,:) .AND. gphit(:,:) <= 66._wp ) … … 251 279 ! 252 280 END DO ! jn 253 254 END SUBROUTINE trc_ice_ini_pisces 281 #endif 282 283 END SUBROUTINE p4z_ice_ini 284 285 SUBROUTINE p2z_ice_ini 286 #if defined key_pisces_reduced 287 !!---------------------------------------------------------------------- 288 !! *** ROUTINE p2z_ice_ini *** 289 !! 290 !! ** Purpose : Initialisation of the LOBSTER biochemical model 291 !!---------------------------------------------------------------------- 292 #endif 293 END SUBROUTINE p2z_ice_ini 294 255 295 256 296 #else -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/TOP_SRC/PISCES/trcini_pisces.F90
r6836 r6839 115 115 po4r = 1._wp / 122._wp 116 116 o2nit = 32._wp / 122._wp 117 rdenit = 105._wp / 16._wp 117 o2ut = 133._wp / 122._wp 118 rdenit = ( ( o2ut + o2nit ) * 0.80 - rno3 - rno3 * 0.60 ) / rno3 118 119 rdenita = 3._wp / 5._wp 119 o2ut = 133._wp / 122._wp 120 120 121 121 122 ! Initialization of tracer concentration in case of no restart -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/TOP_SRC/TRP/trcdmp.F90
r6836 r6839 35 35 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: restotr ! restoring coeff. on tracers (s-1) 36 36 37 INTEGER, PARAMETER :: npncts = 5! number of closed sea37 INTEGER, PARAMETER :: npncts = 8 ! number of closed sea 38 38 INTEGER, DIMENSION(npncts) :: nctsi1, nctsj1 ! south-west closed sea limits (i,j) 39 39 INTEGER, DIMENSION(npncts) :: nctsi2, nctsj2 ! north-east closed sea limits (i,j) … … 107 107 108 108 jl = n_trc_index(jn) 109 CALL trc_dta( kt, sf_trcdta(jl),rf_trfac(jl) ) ! read tracer data at nit000 110 ztrcdta(:,:,:) = sf_trcdta(jl)%fnow(:,:,:) 109 CALL trc_dta( kt, sf_trcdta(jl), rf_trfac(jl), ztrcdta ) ! read tracer data at nit000 111 110 112 111 SELECT CASE ( nn_zdmp_tr ) … … 208 207 ! 209 208 ! Caspian Sea 210 nctsi1(1) = 332 ; nctsj1(1) = 243 - isrow 211 nctsi2(1) = 344 ; nctsj2(1) = 275 - isrow 209 nctsi1(1) = 333 ; nctsj1(1) = 243 - isrow 210 nctsi2(1) = 342 ; nctsj2(1) = 274 - isrow 211 ! ! Lake Superior 212 nctsi1(2) = 198 ; nctsj1(2) = 258 - isrow 213 nctsi2(2) = 204 ; nctsj2(2) = 262 - isrow 214 ! ! Lake Michigan 215 nctsi1(3) = 201 ; nctsj1(3) = 250 - isrow 216 nctsi2(3) = 203 ; nctsj2(3) = 256 - isrow 217 ! ! Lake Huron 218 nctsi1(4) = 204 ; nctsj1(4) = 252 - isrow 219 nctsi2(4) = 209 ; nctsj2(4) = 256 - isrow 220 ! ! Lake Erie 221 nctsi1(5) = 206 ; nctsj1(5) = 249 - isrow 222 nctsi2(5) = 209 ; nctsj2(5) = 251 - isrow 223 ! ! Lake Ontario 224 nctsi1(6) = 210 ; nctsj1(6) = 252 - isrow 225 nctsi2(6) = 212 ; nctsj2(6) = 252 - isrow 226 ! ! Victoria Lake 227 nctsi1(7) = 321 ; nctsj1(7) = 180 - isrow 228 nctsi2(7) = 322 ; nctsj2(7) = 189 - isrow 229 ! ! Baltic Sea 230 nctsi1(8) = 297 ; nctsj1(8) = 270 - isrow 231 nctsi2(8) = 308 ; nctsj2(8) = 293 - isrow 212 232 ! 213 233 ! ! ======================= … … 283 303 IF( ln_trc_ini(jn) ) THEN ! update passive tracers arrays with input data read from file 284 304 jl = n_trc_index(jn) 285 CALL trc_dta( kt, sf_trcdta(jl),rf_trfac(jl) ) ! read tracer data at nit000 286 ztrcdta(:,:,:) = sf_trcdta(jl)%fnow(:,:,:) 305 CALL trc_dta( kt, sf_trcdta(jl), rf_trfac(jl), ztrcdta ) ! read tracer data at nit000 287 306 DO jc = 1, npncts 288 307 DO jk = 1, jpkm1 289 308 DO jj = nctsj1(jc), nctsj2(jc) 290 309 DO ji = nctsi1(jc), nctsi2(jc) 291 trn(ji,jj,jk,jn) = ztrcdta(ji,jj,jk) * tmask(ji,jj,jk)310 trn(ji,jj,jk,jn) = ztrcdta(ji,jj,jk) 292 311 trb(ji,jj,jk,jn) = trn(ji,jj,jk,jn) 293 312 ENDDO … … 317 336 IF( nn_timing == 1 ) CALL timing_start('trc_dmp_init') 318 337 ! 338 !Allocate arrays 339 IF( trc_dmp_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'trc_dmp_init: unable to allocate arrays' ) 319 340 320 341 IF( lzoom ) nn_zdmp_tr = 0 ! restoring to climatology at closed north or south boundaries -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/TOP_SRC/TRP/trcldf.F90
r6836 r6839 56 56 INTEGER, INTENT( in ) :: kt ! ocean time-step index 57 57 !! 58 INTEGER :: jn 58 INTEGER :: ji, jj, jk, jn 59 REAL(wp) :: zdep 59 60 CHARACTER (len=22) :: charout 60 61 REAL(wp), POINTER, DIMENSION(:,:,:,:) :: ztrtrd … … 66 67 67 68 rldf = rldf_rat 68 69 ! 70 r_fact_lap(:,:,:) = 1. 71 DO jk= 1, jpk 72 DO jj = 1, jpj 73 DO ji = 1, jpi 74 IF( fsdept(ji,jj,jk) > 200. .AND. gphit(ji,jj) < 5. .AND. gphit(ji,jj) > -5. ) THEN 75 zdep = MAX( fsdept(ji,jj,jk) - 1000., 0. ) / 1000. 76 r_fact_lap(ji,jj,jk) = MAX( 1., rn_fact_lap * EXP( -zdep ) ) 77 ENDIF 78 END DO 79 END DO 80 END DO 81 ! 69 82 IF( l_trdtrc ) THEN 70 83 CALL wrk_alloc( jpi, jpj, jpk, jptra, ztrtrd ) -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/TOP_SRC/TRP/trcnam_trp.F90
r6836 r6839 40 40 REAL(wp), PUBLIC :: rn_ahtrc_0 !: diffusivity coefficient for passive tracer (m2/s) 41 41 REAL(wp), PUBLIC :: rn_ahtrb_0 !: background diffusivity coefficient for passive tracer (m2/s) 42 REAL(wp), PUBLIC :: rn_fact_lap !: Enhanced zonal diffusivity coefficent in the equatorial domain 42 43 43 44 ! !!: ** Treatment of Negative concentrations ( nam_trcrad ) … … 74 75 NAMELIST/namtrc_ldf/ ln_trcldf_lap , & 75 76 & ln_trcldf_bilap, ln_trcldf_level, & 76 & ln_trcldf_hor , ln_trcldf_iso , rn_ahtrc_0, rn_ahtrb_0 77 & ln_trcldf_hor , ln_trcldf_iso , rn_ahtrc_0, rn_ahtrb_0, & 78 & rn_fact_lap 79 77 80 NAMELIST/namtrc_zdf/ ln_trczdf_exp , nn_trczdf_exp 78 81 NAMELIST/namtrc_rad/ ln_trcrad … … 127 130 WRITE(numout,*) ' diffusivity coefficient rn_ahtrc_0 = ', rn_ahtrc_0 128 131 WRITE(numout,*) ' background hor. diffusivity rn_ahtrb_0 = ', rn_ahtrb_0 132 WRITE(numout,*) ' enhanced zonal diffusivity rn_fact_lap = ', rn_fact_lap 129 133 ENDIF 130 134 -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/TOP_SRC/TRP/trcnxt.F90
r6836 r6839 102 102 ENDIF 103 103 104 #if defined key_agrif 105 CALL Agrif_trc ! AGRIF zoom boundaries 106 #endif 104 107 ! Update after tracer on domain lateral boundaries 105 108 DO jn = 1, jptra … … 110 113 #if defined key_bdy 111 114 !! CALL bdy_trc( kt ) ! BDY open boundaries 112 #endif113 #if defined key_agrif114 CALL Agrif_trc ! AGRIF zoom boundaries115 115 #endif 116 116 -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/TOP_SRC/TRP/trcsbc.F90
r6836 r6839 170 170 END DO 171 171 ENDIF 172 ! 173 CALL lbc_lnk( sbc_trc(:,:,jn), 'T', 1. ) 172 174 ! Concentration dilution effect on tracers due to evaporation & precipitation 173 175 DO jj = 2, jpj -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/TOP_SRC/TRP/trctrp.F90
r6836 r6839 67 67 IF( lk_trabbl ) CALL trc_bbl( kstp ) ! advective (and/or diffusive) bottom boundary layer scheme 68 68 IF( ln_trcdmp ) CALL trc_dmp( kstp ) ! internal damping trends 69 IF( ln_trcdmp_clo ) CALL trc_dmp_clo( kstp ) ! internal damping trends on closed seas only70 69 CALL trc_adv( kstp ) ! horizontal & vertical advection 71 70 CALL trc_ldf( kstp ) ! lateral mixing … … 78 77 CALL trc_nxt( kstp ) ! tracer fields at next time step 79 78 IF( ln_trcrad ) CALL trc_rad( kstp ) ! Correct artificial negative concentrations 79 IF( ln_trcdmp_clo ) CALL trc_dmp_clo( kstp ) ! internal damping trends on closed seas only 80 80 81 81 #if defined key_agrif -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/TOP_SRC/oce_trc.F90
r6836 r6839 116 116 USE ldftra_oce , ONLY : aeiw => aeiw !: eddy induced velocity coef. at w-points (m2/s) 117 117 USE ldftra_oce , ONLY : lk_traldf_eiv => lk_traldf_eiv !: eddy induced velocity flag 118 USE ldftra_oce , ONLY : r_fact_lap => r_fact_lap !: enhanced zonal diffusivity coefficient 118 119 119 120 !* vertical diffusion * -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/TOP_SRC/trcdta.F90
r6836 r6839 77 77 ALLOCATE( n_trc_index(ntrc), slf_i(ntrc), STAT=ierr0 ) 78 78 IF( ierr0 > 0 ) THEN 79 CALL ctl_stop( 'trc_ nam: unable to allocate n_trc_index' ) ; RETURN79 CALL ctl_stop( 'trc_dta_init: unable to allocate n_trc_index' ) ; RETURN 80 80 ENDIF 81 81 nb_trcdta = 0 … … 91 91 IF(lwp) THEN 92 92 WRITE(numout,*) ' ' 93 WRITE(numout,*) 'trc_dta_init : Passive tracers Initial Conditions ' 94 WRITE(numout,*) '~~~~~~~~~~~~~~ ' 93 95 WRITE(numout,*) ' number of passive tracers to be initialize by data :', ntra 94 96 WRITE(numout,*) ' ' … … 107 109 DO jn = 1, ntrc 108 110 IF( ln_trc_ini(jn) ) THEN ! open input file only if ln_trc_ini(jn) is true 109 clndta = TRIM( sn_trcdta(jn)%clvar ) 110 clntrc = TRIM( ctrcnm (jn) ) 111 clndta = TRIM( sn_trcdta(jn)%clvar ) 112 if (jn > jptra) then 113 clntrc='Dummy' ! By pass weird formats in ocean.output if ntrc > jptra 114 else 115 clntrc = TRIM( ctrcnm (jn) ) 116 endif 111 117 zfact = rn_trfac(jn) 112 IF( clndta /= clntrc ) THEN 113 CALL ctl_warn( 'trc_dta_init: passive tracer data initialisation :', &114 & ' the variable name in the data file : '//clndta// &115 & ' must be the same than the name of the passive tracer : '//clntrc//' ')118 IF( clndta /= clntrc ) THEN 119 CALL ctl_warn( 'trc_dta_init: passive tracer data initialisation ', & 120 & 'Input name of data file : '//TRIM(clndta)// & 121 & ' differs from that of tracer : '//TRIM(clntrc)//' ') 116 122 ENDIF 117 WRITE(numout, *) ' read an initial file for passive tracer number :', jn, ' name : ', clndta, &118 & ' multiplicativefactor : ', zfact123 WRITE(numout,'(a, i4,3a,e11.3)') ' Read IC file for tracer number :', & 124 & jn, ', name : ', TRIM(clndta), ', Multiplicative Scaling factor : ', zfact 119 125 ENDIF 120 126 END DO … … 124 130 ALLOCATE( sf_trcdta(nb_trcdta), rf_trfac(nb_trcdta), STAT=ierr1 ) 125 131 IF( ierr1 > 0 ) THEN 126 CALL ctl_stop( 'trc_dta_ini : unable to allocate sf_trcdta structure' ) ; RETURN132 CALL ctl_stop( 'trc_dta_init: unable to allocate sf_trcdta structure' ) ; RETURN 127 133 ENDIF 128 134 ! … … 135 141 IF( sn_trcdta(jn)%ln_tint ) ALLOCATE( sf_trcdta(jl)%fdta(jpi,jpj,jpk,2) , STAT=ierr3 ) 136 142 IF( ierr2 + ierr3 > 0 ) THEN 137 CALL ctl_stop( 'trc_dta : unable to allocate passive tracer data arrays' ) ; RETURN143 CALL ctl_stop( 'trc_dta_init : unable to allocate passive tracer data arrays' ) ; RETURN 138 144 ENDIF 139 145 ENDIF … … 141 147 ENDDO 142 148 ! ! fill sf_trcdta with slf_i and control print 143 CALL fld_fill( sf_trcdta, slf_i, cn_dir, 'trc_dta ', 'Passive tracer data', 'namtrc' )149 CALL fld_fill( sf_trcdta, slf_i, cn_dir, 'trc_dta_init', 'Passive tracer data', 'namtrc' ) 144 150 ! 145 151 ENDIF … … 151 157 152 158 153 SUBROUTINE trc_dta( kt, sf_dta, zrf_trfac)159 SUBROUTINE trc_dta( kt, sf_dta, ptrfac, ptrc) 154 160 !!---------------------------------------------------------------------- 155 161 !! *** ROUTINE trc_dta *** … … 164 170 !!---------------------------------------------------------------------- 165 171 INTEGER , INTENT(in ) :: kt ! ocean time-step 166 TYPE(FLD), DIMENSION(1) , INTENT(inout) :: sf_dta ! array of information on the field to read 167 REAL(wp) , INTENT(in ) :: zrf_trfac ! multiplication factor 172 TYPE(FLD), DIMENSION(1) , INTENT(inout) :: sf_dta ! array of information on the field to read 173 REAL(wp) , INTENT(in ) :: ptrfac ! multiplication factor 174 REAL(wp), DIMENSION(jpi,jpj,jpk), OPTIONAL , INTENT(out ) :: ptrc 168 175 ! 169 176 INTEGER :: ji, jj, jk, jl, jkk, ik ! dummy loop indices 170 177 REAL(wp):: zl, zi 171 178 REAL(wp), DIMENSION(jpk) :: ztp ! 1D workspace 179 REAL(wp), POINTER, DIMENSION(:,:,:) :: ztrcdta ! 3D workspace 172 180 CHARACTER(len=100) :: clndta 173 181 !!---------------------------------------------------------------------- … … 177 185 IF( nb_trcdta > 0 ) THEN 178 186 ! 187 CALL wrk_alloc( jpi, jpj, jpk, ztrcdta ) ! Memory allocation 188 ! 179 189 CALL fld_read( kt, 1, sf_dta ) !== read data at kt time step ==! 190 ztrcdta(:,:,:) = sf_dta(1)%fnow(:,:,:) * tmask(:,:,:) ! Mask 180 191 ! 181 192 IF( ln_sco ) THEN !== s- or mixed s-zps-coordinate ==! … … 186 197 ENDIF 187 198 ! 188 DO jj = 1, jpj ! vertical interpolation of T & S 199 DO jj = 1, jpj ! vertical interpolation of T & S 200 DO ji = 1, jpi 201 DO jk = 1, jpk ! determines the intepolated T-S profiles at each (i,j) points 202 zl = fsdept_n(ji,jj,jk) 203 IF( zl < gdept_1d(1 ) ) THEN ! above the first level of data 204 ztp(jk) = ztrcdta(ji,jj,1) 205 ELSEIF( zl > gdept_1d(jpk) ) THEN ! below the last level of data 206 ztp(jk) = ztrcdta(ji,jj,jpkm1) 207 ELSE ! inbetween : vertical interpolation between jkk & jkk+1 208 DO jkk = 1, jpkm1 ! when gdept(jkk) < zl < gdept(jkk+1) 209 IF( (zl-gdept_1d(jkk)) * (zl-gdept_1d(jkk+1)) <= 0._wp ) THEN 210 zi = ( zl - gdept_1d(jkk) ) / (gdept_1d(jkk+1)-gdept_1d(jkk)) 211 ztp(jk) = ztrcdta(ji,jj,jkk) + ( ztrcdta(ji,jj,jkk+1) - & 212 ztrcdta(ji,jj,jkk) ) * zi 213 ENDIF 214 END DO 215 ENDIF 216 END DO 217 DO jk = 1, jpkm1 218 ztrcdta(ji,jj,jk) = ztp(jk) * tmask(ji,jj,jk) ! mask required for mixed zps-s-coord 219 END DO 220 ztrcdta(ji,jj,jpk) = 0._wp 221 END DO 222 END DO 223 ! 224 ELSE !== z- or zps- coordinate ==! 225 ! 226 IF( ln_zps ) THEN ! zps-coordinate (partial steps) interpolation at the last ocean level 227 DO jj = 1, jpj 189 228 DO ji = 1, jpi 190 DO jk = 1, jpk ! determines the intepolated T-S profiles at each (i,j) points 191 zl = fsdept_n(ji,jj,jk) 192 IF( zl < gdept_1d(1 ) ) THEN ! above the first level of data 193 ztp(jk) = sf_dta(1)%fnow(ji,jj,1) 194 ELSEIF( zl > gdept_1d(jpk) ) THEN ! below the last level of data 195 ztp(jk) = sf_dta(1)%fnow(ji,jj,jpkm1) 196 ELSE ! inbetween : vertical interpolation between jkk & jkk+1 197 DO jkk = 1, jpkm1 ! when gdept(jkk) < zl < gdept(jkk+1) 198 IF( (zl-gdept_1d(jkk)) * (zl-gdept_1d(jkk+1)) <= 0._wp ) THEN 199 zi = ( zl - gdept_1d(jkk) ) / (gdept_1d(jkk+1)-gdept_1d(jkk)) 200 ztp(jk) = sf_dta(1)%fnow(ji,jj,jkk) + ( sf_dta(1)%fnow(ji,jj,jkk+1) - & 201 sf_dta(1)%fnow(ji,jj,jkk) ) * zi 202 ENDIF 203 END DO 204 ENDIF 205 END DO 206 DO jk = 1, jpkm1 207 sf_dta(1)%fnow(ji,jj,jk) = ztp(jk) * tmask(ji,jj,jk) ! mask required for mixed zps-s-coord 208 END DO 209 sf_dta(1)%fnow(ji,jj,jpk) = 0._wp 229 ik = mbkt(ji,jj) 230 IF( ik > 1 ) THEN 231 zl = ( gdept_1d(ik) - fsdept_n(ji,jj,ik) ) / ( gdept_1d(ik) - gdept_1d(ik-1) ) 232 ztrcdta(ji,jj,ik) = (1.-zl) * ztrcdta(ji,jj,ik) + zl * ztrcdta(ji,jj,ik-1) 233 ENDIF 234 ik = mikt(ji,jj) 235 IF( ik > 1 ) THEN 236 zl = ( fsdept_n(ji,jj,ik) - gdept_1d(ik) ) / ( gdept_1d(ik+1) - gdept_1d(ik) ) 237 ztrcdta(ji,jj,ik) = (1.-zl) * ztrcdta(ji,jj,ik) + zl * ztrcdta(ji,jj,ik+1) 238 ENDIF 210 239 END DO 211 240 END DO 212 ! 213 ELSE !== z- or zps- coordinate ==! 214 ! 215 sf_dta(1)%fnow(:,:,:) = sf_dta(1)%fnow(:,:,:) * tmask(:,:,:) ! Mask 216 ! 217 IF( ln_zps ) THEN ! zps-coordinate (partial steps) interpolation at the last ocean level 218 DO jj = 1, jpj 219 DO ji = 1, jpi 220 ik = mbkt(ji,jj) 221 IF( ik > 1 ) THEN 222 zl = ( gdept_1d(ik) - fsdept_n(ji,jj,ik) ) / ( gdept_1d(ik) - gdept_1d(ik-1) ) 223 sf_dta(1)%fnow(ji,jj,ik) = (1.-zl) * sf_dta(1)%fnow(ji,jj,ik) + zl * sf_dta(1)%fnow(ji,jj,ik-1) 224 ENDIF 225 ik = mikt(ji,jj) 226 IF( ik > 1 ) THEN 227 zl = ( gdept_0(ji,jj,ik) - gdept_1d(ik) ) / ( gdept_1d(ik+1) - gdept_1d(ik) ) 228 sf_dta(1)%fnow(ji,jj,ik) = (1.-zl) * sf_dta(1)%fnow(ji,jj,ik) + zl * sf_dta(1)%fnow(ji,jj,ik+1) 229 ENDIF 230 END DO 231 END DO 232 ENDIF 233 ! 234 ENDIF 235 ! 236 sf_dta(1)%fnow(:,:,:) = sf_dta(1)%fnow(:,:,:) * zrf_trfac ! multiplicative factor 241 ENDIF 242 ! 243 ENDIF 244 ! 245 ! Add multiplicative factor 246 ztrcdta(:,:,:) = ztrcdta(:,:,:) * ptrfac 247 ! 248 ! Data structure for trc_ini (and BFMv5.1 coupling) 249 IF( .NOT. PRESENT(ptrc) ) sf_dta(1)%fnow(:,:,:) = ztrcdta(:,:,:) 250 ! 251 ! Data structure for trc_dmp 252 IF( PRESENT(ptrc) ) ptrc(:,:,:) = ztrcdta(:,:,:) 237 253 ! 238 254 IF( lwp .AND. kt == nit000 ) THEN … … 241 257 WRITE(numout,*) 242 258 WRITE(numout,*)' level = 1' 243 CALL prihre( sf_dta(1)%fnow(:,:,1), jpi, jpj, 1, jpi, 20, 1, jpj, 20, 1., numout )259 CALL prihre( ztrcdta(:,:,1), jpi, jpj, 1, jpi, 20, 1, jpj, 20, 1., numout ) 244 260 WRITE(numout,*)' level = ', jpk/2 245 CALL prihre( sf_dta(1)%fnow(:,:,jpk/2), jpi, jpj, 1, jpi, 20, 1, jpj, 20, 1., numout )261 CALL prihre( ztrcdta(:,:,jpk/2), jpi, jpj, 1, jpi, 20, 1, jpj, 20, 1., numout ) 246 262 WRITE(numout,*)' level = ', jpkm1 247 CALL prihre( sf_dta(1)%fnow(:,:,jpkm1), jpi, jpj, 1, jpi, 20, 1, jpj, 20, 1., numout )263 CALL prihre( ztrcdta(:,:,jpkm1), jpi, jpj, 1, jpi, 20, 1, jpj, 20, 1., numout ) 248 264 WRITE(numout,*) 249 265 ENDIF 266 ! 267 CALL wrk_dealloc( jpi, jpj, jpk, ztrcdta ) 268 ! 250 269 ENDIF 251 270 ! … … 258 277 !!---------------------------------------------------------------------- 259 278 CONTAINS 260 SUBROUTINE trc_dta( kt, sf_dta, zrf_trfac) ! Empty routine279 SUBROUTINE trc_dta( kt, sf_dta, ptrfac, ptrc) ! Empty routine 261 280 WRITE(*,*) 'trc_dta: You should not have seen this print! error?', kt 262 281 END SUBROUTINE trc_dta -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/TOP_SRC/trcini.F90
r6836 r6839 61 61 INTEGER :: jk, jn, jl ! dummy loop indices 62 62 CHARACTER (len=25) :: charout 63 REAL(wp), POINTER, DIMENSION(:,:,:) :: ztrcdta ! 4D workspace64 63 !!--------------------------------------------------------------------- 65 64 ! … … 121 120 IF( ln_trcdta .AND. nb_trcdta > 0 ) THEN ! Initialisation of tracer from a file that may also be used for damping 122 121 ! 123 CALL wrk_alloc( jpi, jpj, jpk, ztrcdta ) ! Memory allocation124 !125 122 DO jn = 1, jptra 126 123 IF( ln_trc_ini(jn) ) THEN ! update passive tracers arrays with input data read from file 127 124 jl = n_trc_index(jn) 128 CALL trc_dta( nit000, sf_trcdta(jl),rf_trfac(jl) ) ! read tracer data at nit000 129 ztrcdta(:,:,:) = sf_trcdta(jl)%fnow(:,:,:) 130 trn(:,:,:,jn) = ztrcdta(:,:,:) * tmask(:,:,:) 125 CALL trc_dta( nit000, sf_trcdta(jl), rf_trfac(jl) ) ! read tracer data at nit000 126 trn(:,:,:,jn) = sf_trcdta(jl)%fnow(:,:,:) 131 127 IF( .NOT.ln_trcdmp .AND. .NOT.ln_trcdmp_clo ) THEN !== deallocate data structure ==! 132 128 ! (data used only for initialisation) … … 138 134 ENDIF 139 135 ENDDO 140 CALL wrk_dealloc( jpi, jpj, jpk, ztrcdta )136 ! 141 137 ENDIF 142 138 ! -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/TOP_SRC/trcnam.F90
r6836 r6839 397 397 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 398 398 !!====================================================================== 399 END MODULE 399 END MODULE trcnam -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/TOP_SRC/trcsms.F90
r6836 r6839 75 75 76 76 !!====================================================================== 77 END MODULE 77 END MODULE trcsms -
branches/UKMO/dev_r5518_convadj/NEMOGCM/NEMO/TOP_SRC/trcstp.F90
r6836 r6839 32 32 REAL(wp), DIMENSION(:,:,:), SAVE, ALLOCATABLE :: qsr_arr ! save qsr during TOP time-step 33 33 REAL(wp) :: rdt_sampl 34 INTEGER :: nb_rec_per_day s34 INTEGER :: nb_rec_per_day 35 35 INTEGER :: isecfst, iseclast 36 36 LOGICAL :: llnew … … 123 123 !! of diurnal cycle 124 124 !! 125 !! ** Method : store in TOP the qsr every hour ( or every time-step the latter125 !! ** Method : store in TOP the qsr every hour ( or every time-step if the latter 126 126 !! is greater than 1 hour ) and then, compute the mean with 127 127 !! a moving average over 24 hours. … … 134 134 IF( ln_cpl ) THEN 135 135 rdt_sampl = 86400. / ncpl_qsr_freq 136 nb_rec_per_day s= ncpl_qsr_freq136 nb_rec_per_day = ncpl_qsr_freq 137 137 ELSE 138 138 rdt_sampl = MAX( 3600., rdt * nn_dttrc ) 139 nb_rec_per_day s= INT( 86400 / rdt_sampl )139 nb_rec_per_day = INT( 86400 / rdt_sampl ) 140 140 ENDIF 141 141 ! 142 142 IF( lwp ) THEN 143 143 WRITE(numout,*) 144 WRITE(numout,*) ' Sampling frequency dt = ', rdt_sampl, 's',' Number of sampling per day nrec = ', nb_rec_per_day s144 WRITE(numout,*) ' Sampling frequency dt = ', rdt_sampl, 's',' Number of sampling per day nrec = ', nb_rec_per_day 145 145 WRITE(numout,*) 146 146 ENDIF 147 147 ! 148 ALLOCATE( qsr_arr(jpi,jpj,nb_rec_per_days ) ) 149 DO jn = 1, nb_rec_per_days 150 qsr_arr(:,:,jn) = qsr(:,:) 148 ! !* Restart: read in restart file 149 IF( ln_rsttr .AND. iom_varid( numrtr, 'qsr_mean', ldstop = .FALSE. ) > 0 ) THEN 150 IF(lwp) WRITE(numout,*) 'trc_qsr_mean: qsr_mean read in the restart file' 151 CALL iom_get( numrtr, jpdom_autoglo, 'qsr_mean', qsr_mean ) ! A mean of qsr 152 ELSE !* no restart: set from nit000 values 153 IF(lwp) WRITE(numout,*) 'trc_qsr_mean: qsr_mean set to nit000 values' 154 qsr_mean(:,:) = qsr(:,:) 155 ENDIF 156 ! 157 ALLOCATE( qsr_arr(jpi,jpj,nb_rec_per_day ) ) 158 DO jn = 1, nb_rec_per_day 159 qsr_arr(:,:,jn) = qsr_mean(:,:) 151 160 ENDDO 152 qsr_mean(:,:) = qsr(:,:)153 161 ! 154 162 isecfst = nsec_year + nsec1jan000 ! number of seconds between Jan. 1st 00h of nit000 year and the middle of time step … … 163 171 & ' time = ', (iseclast+rdt*nn_dttrc/2.)/3600.,'hours ' 164 172 isecfst = iseclast 165 DO jn = 1, nb_rec_per_day s- 1173 DO jn = 1, nb_rec_per_day - 1 166 174 qsr_arr(:,:,jn) = qsr_arr(:,:,jn+1) 167 175 ENDDO 168 qsr_arr (:,:,nb_rec_per_days) = qsr(:,:) 169 qsr_mean(:,: ) = SUM( qsr_arr(:,:,:), 3 ) / nb_rec_per_days 170 ENDIF 171 ! 176 qsr_arr (:,:,nb_rec_per_day) = qsr(:,:) 177 qsr_mean(:,: ) = SUM( qsr_arr(:,:,:), 3 ) / nb_rec_per_day 178 ENDIF 179 ! 180 IF( lrst_trc ) THEN !* Write the mean of qsr in restart file 181 IF(lwp) WRITE(numout,*) 182 IF(lwp) WRITE(numout,*) 'trc_mean_qsr : write qsr_mean in restart file kt =', kt 183 IF(lwp) WRITE(numout,*) '~~~~~~~' 184 CALL iom_rstput( kt, nitrst, numrtw, 'qsr_mean', qsr_mean(:,:) ) 185 ENDIF 186 ! 172 187 END SUBROUTINE trc_mean_qsr 173 188
Note: See TracChangeset
for help on using the changeset viewer.