Changeset 921 for trunk/NEMO/LIM_SRC_3
- Timestamp:
- 2008-05-13T10:28:52+02:00 (16 years ago)
- Location:
- trunk/NEMO/LIM_SRC_3
- Files:
-
- 29 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/NEMO/LIM_SRC_3/dom_ice.F90
r834 r921 24 24 INTEGER, PUBLIC :: & !: 25 25 njeq , njeqm1 !: j-index of the equator if it is inside the domain 26 26 ! ! (otherwise = jpj+10 (SH) or -10 (SH) ) 27 27 28 28 REAL(wp), PUBLIC, DIMENSION(jpi,jpj) :: & !: -
trunk/NEMO/LIM_SRC_3/ice.F90
r904 r921 217 217 s_i_min = 0.1 , & !: minimum ice salinity (ppt) 218 218 s_i_0 = 3.5 , & !: 1st sal. value for the computation of sal .prof. 219 !: (ppt)219 !: (ppt) 220 220 s_i_1 = 4.5 , & !: 2nd sal. value for the computation of sal .prof. 221 !: (ppt)221 !: (ppt) 222 222 sal_G = 5.00 , & !: restoring salinity for gravity drainage 223 !: (ppt)223 !: (ppt) 224 224 sal_F = 2.50 , & !: restoring salinity for flushing 225 !: (ppt)225 !: (ppt) 226 226 time_G = 1.728e+06,&!: restoring time constant for gravity drainage 227 !: (= 20 days, in s)227 !: (= 20 days, in s) 228 228 time_F = 8.640e+05,&!: restoring time constant for gravity drainage 229 !: (= 10 days, in s)229 !: (= 10 days, in s) 230 230 bulk_sal = 4.0 !: bulk salinity (ppt) in case of constant salinity 231 231 232 232 INTEGER , PUBLIC :: & !!: ** ice-salinity namelist (namicesal) ** 233 233 num_sal = 1 , & !: salinity configuration used in the model 234 !: 1 - s constant in space and time235 !: 2 - prognostic salinity (s(z,t))236 !: 3 - salinity profile, constant in time237 !: 4 - salinity variations affect only ice238 ! thermodynamics234 !: 1 - s constant in space and time 235 !: 2 - prognostic salinity (s(z,t)) 236 !: 3 - salinity profile, constant in time 237 !: 4 - salinity variations affect only ice 238 ! thermodynamics 239 239 sal_prof = 1 , & !: salinity profile or not 240 240 thcon_i_swi = 1 !: thermal conductivity of Untersteiner (1964) (1) or 241 241 !: Pringle et al (2007) (2) 242 242 243 243 REAL(wp), PUBLIC :: & !!: ** ice-mechanical redistribution namelist (namiceitdme) … … 249 249 astar = 0.05 , & !!: equivalent of G* for an exponential participation function 250 250 Hstar = 100.0 , & !!: thickness that determines the maximal thickness of ridged 251 !!: ice251 !!: ice 252 252 hparmeter = 0.75, & !!: threshold thickness (m) for rafting / ridging 253 253 Craft = 5.0 , & !!: coefficient for smoothness of the hyperbolic tangent in rafting … … 256 256 betas = 1.0 , & !:: coef. for partitioning of snowfall between leads and sea ice 257 257 kappa_i = 1.0 , & !!: coefficient for the extinction of radiation 258 !!: Grenfell et al. (2006) (m-1)258 !!: Grenfell et al. (2006) (m-1) 259 259 nconv_i_thd = 50 , & !!: maximal number of iterations for heat diffusion 260 260 maxer_i_thd = 1.0e-4 !!: maximal tolerated error (C) for heat diffusion … … 264 264 raftswi = 1, & !!: rafting of ice or not 265 265 partfun_swi = 1, & !!: participation function Thorndike et al. JGR75 (0) 266 !!: or Lipscomb et al. JGR07 (1)266 !!: or Lipscomb et al. JGR07 (1) 267 267 transfun_swi = 0, & !!: transfer function of Hibler, MWR80 (0) 268 !!: or Lipscomb et al., 2007 (1)268 !!: or Lipscomb et al., 2007 (1) 269 269 brinstren_swi = 0 !!: use brine volume to diminish ice strength 270 270 … … 301 301 t_bo , & !: Sea-Ice bottom temperature (Kelvin) 302 302 hicifp , & !: Ice production/melting 303 !obsolete... can be removed303 !obsolete... can be removed 304 304 frld , & !: Leads fraction = 1-a/totalarea REFERS TO LEAD FRACTION everywhere 305 !: except in the OUTPUTS!!!!305 !: except in the OUTPUTS!!!! 306 306 pfrld , & !: Leads fraction at previous time 307 307 phicif , & !: Old ice thickness … … 328 328 fheat_res, & !: Residual heat flux due to correction of ice thickness 329 329 fhmec !: Heat flux due to snow loss during compression 330 330 331 331 REAL(wp), PUBLIC, DIMENSION(jpi,jpj) :: & !: 332 332 albege , & !: Albedo of the snow or ice (only for outputs) … … 334 334 tauc !: Cloud optical depth 335 335 336 ! temporary arrays for dummy version of the code336 ! temporary arrays for dummy version of the code 337 337 REAL(wp), PUBLIC, DIMENSION(jpi,jpj) :: & !: 338 338 dh_i_surf2D, dh_i_bott2D, fstbif, fsup2D, focea2D, q_s … … 354 354 sm_i , & !: Sea-Ice Bulk salinity (ppt) 355 355 smv_i , & !: Sea-Ice Bulk salinity times volume per area (ppt.m) 356 !: this is an extensive variable that has to be transported356 !: this is an extensive variable that has to be transported 357 357 o_i , & !: Sea-Ice Age (days) 358 358 ov_i , & !: Sea-Ice Age times volume per area (days.m) … … 401 401 !!-------------------------------------------------------------------------- 402 402 REAL(wp), PUBLIC, DIMENSION(jpi,jpj) :: & !: 403 403 sxopw, syopw, sxxopw, syyopw, sxyopw !: open water in sea ice 404 404 405 405 REAL(wp), PUBLIC, DIMENSION(jpi,jpj,jpl) :: & !: 406 407 408 409 410 411 406 sxice, syice, sxxice, syyice, sxyice, & !: ice thickness moments for advection 407 sxsn, sysn, sxxsn, syysn, sxysn, & !: snow thickness 408 sxa, sya, sxxa, syya, sxya, & !: lead fraction 409 sxc0, syc0, sxxc0, syyc0, sxyc0, & !: snow thermal content 410 sxsal, sysal, sxxsal, syysal, sxysal, & !: ice salinity 411 sxage, syage, sxxage, syyage, sxyage !: ice age 412 412 413 413 REAL(wp), PUBLIC, DIMENSION(jpi,jpj,jkmax,jpl) :: & !: 414 414 sxe , sye , sxxe , syye , sxye !: ice layers heat content 415 415 416 416 !!-------------------------------------------------------------------------- … … 446 446 REAL(wp), PUBLIC, DIMENSION(jpi,jpj,jkmax,jpl) :: & !: 447 447 d_e_i_thd, d_e_i_trp 448 448 449 449 REAL(wp), PUBLIC, DIMENSION(jpi,jpj) :: & !: ice velocity 450 450 d_u_ice_dyn, d_v_ice_dyn … … 459 459 INTEGER, PUBLIC, DIMENSION(jpm,2) :: & !: 460 460 ice_cat_bounds !: Matrix containing the integer upper and 461 461 !: lower boundaries of ice thickness categories 462 462 463 463 ! REMOVE … … 474 474 REAL(wp), PUBLIC, DIMENSION(0:jpl,jpm) :: & !: 475 475 hi_max_typ !: Boundary of ice thickness categories 476 !:in thickness space (same but specific for each ice type) 476 !:in thickness space (same but specific for each ice type) 477 478 !!-------------------------------------------------------------------------- 479 !! * Ice Run 480 !!-------------------------------------------------------------------------- 481 !! Namelist namicerun read in iceini 482 LOGICAL , PUBLIC :: & !!! ** init namelist (namicerun) ** 483 ln_limdyn = .TRUE., & !: flag for ice dynamics (T) or not (F) 484 ln_nicep = .TRUE. !: flag for sea-ice points output (T) or not (F) 485 REAL(wp), PUBLIC :: & !: 486 hsndif = 0.e0 , & !: computation of temp. in snow (0) or not (9999) 487 hicdif = 0.e0 , & !: computation of temp. in ice (0) or not (9999) 488 cai = 1.40e-3 , & !: atmospheric drag over sea ice 489 cao = 1.00e-3 !: atmospheric drag over ocean 490 REAL(wp), PUBLIC, DIMENSION(2) :: & !: 491 acrit = (/ 1.e-06 , 1.e-06 /) !: minimum fraction for leads in 492 ! ! north and south hemisphere 477 493 478 494 !!-------------------------------------------------------------------------- -
trunk/NEMO/LIM_SRC_3/iceini.F90
r888 r921 32 32 33 33 !! * Share Module variables 34 LOGICAL , PUBLIC :: & !!! ** init namelist (namicerun) **35 ln_limdyn = .TRUE., & !: flag for ice dynamics (T) or not (F)36 ln_nicep = .TRUE. !: flag for sea-ice points output (T) or not (F)37 34 INTEGER , PUBLIC :: & !: 38 35 nstart , & !: iteration number of the begining of the run … … 41 38 numit !: iteration number 42 39 REAL(wp), PUBLIC :: & !: 43 hsndif = 0.e0 , & !: computation of temp. in snow (0) or not (9999) 44 hicdif = 0.e0 , & !: computation of temp. in ice (0) or not (9999) 45 tpstot , & !: time of the run in seconds 46 cai = 1.40e-3 , & !: atmospheric drag over sea ice 47 cao = 1.00e-3 !: atmospheric drag over ocean 48 REAL(wp), PUBLIC, DIMENSION(2) :: & !: 49 acrit = (/ 1.e-06 , 1.e-06 /) !: minimum fraction for leads in 50 ! ! north and south hemisphere 40 tpstot !: time of the run in seconds 51 41 !!---------------------------------------------------------------------- 52 42 !! LIM 3.0, UCL-ASTR-LOCEAN-IPSL (2008) … … 72 62 73 63 CALL ice_run ! read in namelist some run parameters 74 64 75 65 ! Louvain la Neuve Ice model 76 66 IF( nacc == 1 ) THEN 77 78 67 dtsd2 = nn_fsbc * rdtmin * 0.5 68 rdt_ice = nn_fsbc * rdtmin 79 69 ELSE 80 81 70 dtsd2 = nn_fsbc * rdt * 0.5 71 rdt_ice = nn_fsbc * rdt 82 72 ENDIF 83 73 84 74 CALL lim_msh ! ice mesh initialization 85 75 86 76 CALL lim_itd_ini ! initialize the ice thickness 87 77 ! distribution 88 78 ! Initial sea-ice state 89 79 IF( .NOT.ln_rstart ) THEN … … 92 82 CALL lim_istate ! start from rest: sea-ice deduced from sst 93 83 CALL lim_var_agg(1) ! aggregate category variables in 94 84 ! bulk variables 95 85 CALL lim_var_glo2eqv ! convert global variables in equivalent 96 86 ! variables 97 87 ELSE 98 88 CALL lim_rst_read ! start from a restart file … … 108 98 alb_ice(:,:,:) = albege(:,:) ! sea-ice albedo 109 99 # endif 110 100 111 101 nstart = numit + nn_fsbc 112 102 nitrun = nitend - nit000 + 1 … … 138 128 REWIND ( numnam_ice ) 139 129 READ ( numnam_ice , namicerun ) 130 ln_nicep = ln_nicep .AND. lwp 140 131 IF(lwp) THEN 141 132 WRITE(numout,*) … … 150 141 WRITE(numout,*) ' Several ice points in the ice or not in ocean.output = ', ln_nicep 151 142 ENDIF 152 143 153 144 END SUBROUTINE ice_run 154 145 155 146 SUBROUTINE lim_itd_ini 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 !!-- End of declarations195 !!------------------------------------------------------------------------------196 197 !------------------------------------------------------------------------------!198 ! 1) Ice thickness distribution parameters initialization199 !------------------------------------------------------------------------------!147 !!------------------------------------------------------------------ 148 !! *** ROUTINE lim_itd_ini *** 149 !! ** Purpose : 150 !! Initializes the ice thickness distribution 151 !! ** Method : 152 !! Very simple. Currently there are no ice types in the 153 !! model... 154 !! 155 !! ** Arguments : 156 !! kideb , kiut : Starting and ending points on which the 157 !! the computation is applied 158 !! 159 !! ** Inputs / Ouputs : (global commons) 160 !! 161 !! ** External : 162 !! 163 !! ** References : 164 !! 165 !! ** History : 166 !! (12-2005) Martin Vancoppenolle 167 !! 168 !!------------------------------------------------------------------ 169 !! * Arguments 170 171 !! * Local variables 172 INTEGER :: jl, & ! ice category dummy loop index 173 jm ! ice types dummy loop index 174 175 REAL(wp) :: & ! constant values 176 zeps = 1.0e-10, & ! 177 zc1 , & ! 178 zc2 , & ! 179 zc3 , & ! 180 zx1 181 182 WRITE(numout,*) 'lim_itd_ini : Initialization of ice thickness distribution ' 183 WRITE(numout,*) '~~~~~~~~~~~~' 184 185 !!-- End of declarations 186 !!------------------------------------------------------------------------------ 187 188 !------------------------------------------------------------------------------! 189 ! 1) Ice thickness distribution parameters initialization 190 !------------------------------------------------------------------------------! 200 191 201 192 !- Types boundaries (integer) … … 266 257 tn_ice(:,:,:) = t_su(:,:,:) 267 258 268 259 END SUBROUTINE lim_itd_ini 269 260 270 261 #else -
trunk/NEMO/LIM_SRC_3/limadv.F90
r888 r921 66 66 pdf , & ! ??? 67 67 pcrh ! = 1. : lim_adv_x is called before lim_adv_y 68 68 ! ! = 0. : lim_adv_x is called after lim_adv_y 69 69 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: & 70 70 put ! i-direction ice velocity at ocean U-point (m/s) … … 114 114 ! Calculate fluxes and moments between boxes i<-->i+1 115 115 DO jj = 1, jpj ! Flux from i to i+1 WHEN u GT 0 116 !i bug DO ji = 1, jpim1117 !i DO jj = 1, jpj ! Flux from i to i+1 WHEN u GT 0116 !i bug DO ji = 1, jpim1 117 !i DO jj = 1, jpj ! Flux from i to i+1 WHEN u GT 0 118 118 DO ji = 1, jpi 119 119 zbet(ji,jj) = MAX( rzero, SIGN( rone, put(ji,jj) ) ) … … 142 142 143 143 DO jj = 1, jpjm1 ! Flux from i+1 to i when u LT 0. 144 !i DO jj = 1, fs_jpjm1 ! Flux from i+1 to i when u LT 0.144 !i DO jj = 1, fs_jpjm1 ! Flux from i+1 to i when u LT 0. 145 145 DO ji = 1, fs_jpim1 146 146 zalf = MAX( rzero, -put(ji,jj) ) * zrdt * e2u(ji,jj) / psm(ji+1,jj) … … 228 228 CALL lbc_lnk( psxy, 'T', 1. ) 229 229 230 IF(ln_ctl) THEN230 IF(ln_ctl) THEN 231 231 CALL prt_ctl(tab2d_1=psm , clinfo1=' lim_adv_x: psm :', tab2d_2=ps0 , clinfo2=' ps0 : ') 232 232 CALL prt_ctl(tab2d_1=psx , clinfo1=' lim_adv_x: psx :', tab2d_2=psxx, clinfo2=' psxx : ') 233 233 CALL prt_ctl(tab2d_1=psy , clinfo1=' lim_adv_x: psy :', tab2d_2=psyy, clinfo2=' psyy : ') 234 234 CALL prt_ctl(tab2d_1=psxy , clinfo1=' lim_adv_x: psxy :') 235 ENDIF235 ENDIF 236 236 237 237 END SUBROUTINE lim_adv_x … … 260 260 pdf, & ! ??? 261 261 pcrh ! = 1. : lim_adv_x is called before lim_adv_y 262 262 ! ! = 0. : lim_adv_x is called after lim_adv_y 263 263 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: & 264 264 pvt ! j-direction ice velocity at ocean V-point (m/s) … … 285 285 zrdt = rdt_ice * pdf ! If ice drift field is too fast, use an appropriate time step for advection. 286 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 !!bug DO jj = 2, jpjm1309 310 311 !!bug DO ji = 1, jpim1312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 !i DO jj = 1, jpjm1 ! Flux from j+1 to j when v LT 0.340 !i DO ji = 2, jpim1341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 287 DO jj = 1, jpj 288 DO ji = 1, jpi 289 zslpmax = MAX( rzero, ps0(ji,jj) ) 290 zs1max = 1.5 * zslpmax 291 zs1new = MIN( zs1max, MAX( -zs1max, psy(ji,jj) ) ) 292 zs2new = MIN( ( 2.0 * zslpmax - 0.3334 * ABS( zs1new ) ), & 293 & MAX( ABS( zs1new )-zslpmax, psyy(ji,jj) ) ) 294 zin0 = ( 1.0 - MAX( rzero, sign ( rone, -zslpmax) ) ) * tms(ji,jj) ! Case of empty boxes & Apply mask 295 ps0 (ji,jj) = zslpmax 296 psx (ji,jj) = psx (ji,jj) * zin0 297 psxx(ji,jj) = psxx(ji,jj) * zin0 298 psy (ji,jj) = zs1new * zin0 299 psyy(ji,jj) = zs2new * zin0 300 psxy(ji,jj) = MIN( zslpmax, MAX( -zslpmax, psxy(ji,jj) ) ) * zin0 301 END DO 302 END DO 303 304 ! Initialize volumes of boxes (=area if adv_x first called, =psm otherwise) 305 psm (:,:) = MAX( pcrh * area(:,:) + ( 1.0 - pcrh ) * psm(:,:) , epsi20 ) 306 307 ! Calculate fluxes and moments between boxes j<-->j+1 308 !!bug DO jj = 2, jpjm1 309 DO jj = 1, jpj 310 DO ji = 1, jpi 311 !!bug DO ji = 1, jpim1 312 ! Flux from j to j+1 WHEN v GT 0 313 zbet(ji,jj) = MAX( rzero, SIGN( rone, pvt(ji,jj) ) ) 314 zalf = MAX( rzero, pvt(ji,jj) ) * zrdt * e1v(ji,jj) / psm(ji,jj) 315 zalfq = zalf * zalf 316 zalf1 = 1.0 - zalf 317 zalf1q = zalf1 * zalf1 318 zfm (ji,jj) = zalf * psm(ji,jj) 319 zf0 (ji,jj) = zalf * ( ps0(ji,jj) + zalf1 * ( psy(ji,jj) + (zalf1-zalf) * psyy(ji,jj) ) ) 320 zfy (ji,jj) = zalfq *( psy(ji,jj) + 3.0*zalf1*psyy(ji,jj) ) 321 zfyy(ji,jj) = zalf * zalfq * psyy(ji,jj) 322 zfx (ji,jj) = zalf * ( psx(ji,jj) + zalf1 * psxy(ji,jj) ) 323 zfxy(ji,jj) = zalfq * psxy(ji,jj) 324 zfxx(ji,jj) = zalf * psxx(ji,jj) 325 326 ! Readjust moments remaining in the box. 327 psm (ji,jj) = psm (ji,jj) - zfm(ji,jj) 328 ps0 (ji,jj) = ps0 (ji,jj) - zf0(ji,jj) 329 psy (ji,jj) = zalf1q * ( psy(ji,jj) -3.0 * zalf * psyy(ji,jj) ) 330 psyy(ji,jj) = zalf1 * zalf1q * psyy(ji,jj) 331 psx (ji,jj) = psx (ji,jj) - zfx(ji,jj) 332 psxx(ji,jj) = psxx(ji,jj) - zfxx(ji,jj) 333 psxy(ji,jj) = zalf1q * psxy(ji,jj) 334 END DO 335 END DO 336 337 DO jj = 1, jpjm1 ! Flux from j+1 to j when v LT 0. 338 DO ji = 1, jpi 339 !i DO jj = 1, jpjm1 ! Flux from j+1 to j when v LT 0. 340 !i DO ji = 2, jpim1 341 zalf = ( MAX(rzero, -pvt(ji,jj) ) * zrdt * e1v(ji,jj) ) / psm(ji,jj+1) 342 zalg (ji,jj) = zalf 343 zalfq = zalf * zalf 344 zalf1 = 1.0 - zalf 345 zalg1 (ji,jj) = zalf1 346 zalf1q = zalf1 * zalf1 347 zalg1q(ji,jj) = zalf1q 348 zfm (ji,jj) = zfm (ji,jj) + zalf * psm(ji,jj+1) 349 zf0 (ji,jj) = zf0 (ji,jj) + zalf * ( ps0(ji,jj+1) - zalf1 * (psy(ji,jj+1) - (zalf1 - zalf ) * psyy(ji,jj+1) ) ) 350 zfy (ji,jj) = zfy (ji,jj) + zalfq * ( psy(ji,jj+1) - 3.0 * zalf1 * psyy(ji,jj+1) ) 351 zfyy (ji,jj) = zfyy(ji,jj) + zalf * zalfq * psyy(ji,jj+1) 352 zfx (ji,jj) = zfx (ji,jj) + zalf * ( psx(ji,jj+1) - zalf1 * psxy(ji,jj+1) ) 353 zfxy (ji,jj) = zfxy(ji,jj) + zalfq * psxy(ji,jj+1) 354 zfxx (ji,jj) = zfxx(ji,jj) + zalf * psxx(ji,jj+1) 355 END DO 356 END DO 357 358 ! Readjust moments remaining in the box. 359 DO jj = 2, jpj 360 DO ji = 1, jpi 361 zbt = zbet(ji,jj-1) 362 zbt1 = ( 1.0 - zbet(ji,jj-1) ) 363 psm (ji,jj) = zbt * psm(ji,jj) + zbt1 * ( psm(ji,jj) - zfm(ji,jj-1) ) 364 ps0 (ji,jj) = zbt * ps0(ji,jj) + zbt1 * ( ps0(ji,jj) - zf0(ji,jj-1) ) 365 psy (ji,jj) = zalg1q(ji,jj-1) * ( psy(ji,jj) + 3.0 * zalg(ji,jj-1) * psyy(ji,jj) ) 366 psyy(ji,jj) = zalg1 (ji,jj-1) * zalg1q(ji,jj-1) * psyy(ji,jj) 367 psx (ji,jj) = zbt * psx (ji,jj) + zbt1 * ( psx (ji,jj) - zfx (ji,jj-1) ) 368 psxx(ji,jj) = zbt * psxx(ji,jj) + zbt1 * ( psxx(ji,jj) - zfxx(ji,jj-1) ) 369 psxy(ji,jj) = zalg1q(ji,jj-1) * psxy(ji,jj) 370 END DO 371 END DO 372 373 ! Put the temporary moments into appropriate neighboring boxes. 374 DO jj = 2, jpjm1 ! Flux from j to j+1 IF v GT 0. 375 DO ji = 1, jpi 376 zbt = zbet(ji,jj-1) 377 zbt1 = ( 1.0 - zbet(ji,jj-1) ) 378 psm(ji,jj) = zbt * ( psm(ji,jj) + zfm(ji,jj-1) ) + zbt1 * psm(ji,jj) 379 zalf = zbt * zfm(ji,jj-1) / psm(ji,jj) 380 zalf1 = 1.0 - zalf 381 ztemp = zalf * ps0(ji,jj) - zalf1 * zf0(ji,jj-1) 382 ps0(ji,jj) = zbt * (ps0(ji,jj) + zf0(ji,jj-1)) + zbt1 * ps0(ji,jj) 383 384 psy(ji,jj) = zbt * ( zalf * zfy(ji,jj-1) + zalf1 * psy(ji,jj) + 3.0 * ztemp ) & 385 & + zbt1 * psy(ji,jj) 386 387 psyy(ji,jj) = zbt * ( zalf * zalf * zfyy(ji,jj-1) + zalf1 * zalf1 * psyy(ji,jj) & 388 & + 5.0 * ( zalf * zalf1 * ( psy(ji,jj) - zfy(ji,jj-1) ) - ( zalf1 - zalf ) * ztemp ) ) & 389 & + zbt1 * psyy(ji,jj) 390 391 psxy(ji,jj) = zbt * ( zalf * zfxy(ji,jj-1) + zalf1 * psxy(ji,jj) & 392 + 3.0 * (- zalf1 * zfx(ji,jj-1) + zalf * psx(ji,jj) ) ) & 393 + zbt1 * psxy(ji,jj) 394 psx (ji,jj) = zbt * ( psx (ji,jj) + zfx (ji,jj-1) ) + zbt1 * psx (ji,jj) 395 psxx(ji,jj) = zbt * ( psxx(ji,jj) + zfxx(ji,jj-1) ) + zbt1 * psxx(ji,jj) 396 END DO 397 END DO 398 399 DO jj = 2, jpjm1 ! Flux from j+1 to j IF v LT 0. 400 DO ji = 1, jpi 401 zbt = zbet(ji,jj) 402 zbt1 = ( 1.0 - zbet(ji,jj) ) 403 psm(ji,jj) = zbt * psm(ji,jj) + zbt1 * ( psm(ji,jj) + zfm(ji,jj) ) 404 zalf = zbt1 * zfm(ji,jj) / psm(ji,jj) 405 zalf1 = 1.0 - zalf 406 ztemp = -zalf * ps0(ji,jj) + zalf1 * zf0(ji,jj) 407 ps0(ji,jj) = zbt * ps0(ji,jj) + zbt1 * ( ps0(ji,jj) + zf0(ji,jj) ) 408 psy(ji,jj) = zbt * psy(ji,jj) & 409 & + zbt1 * ( zalf*zfy(ji,jj) + zalf1 * psy(ji,jj) + 3.0 * ztemp ) 410 psyy(ji,jj) = zbt * psyy(ji,jj) & 411 & + zbt1 * ( zalf * zalf * zfyy(ji,jj) + zalf1 * zalf1 * psyy(ji,jj) & 412 & + 5.0 *( zalf *zalf1 *( -psy(ji,jj) + zfy(ji,jj) ) + ( zalf1 - zalf ) * ztemp ) ) 413 psxy(ji,jj) = zbt * psxy(ji,jj) & 414 & + zbt1 * ( zalf * zfxy(ji,jj) + zalf1 * psxy(ji,jj) & 415 & + 3.0 * ( zalf1 * zfx(ji,jj) - zalf * psx(ji,jj) ) ) 416 psx(ji,jj) = zbt * psx (ji,jj) + zbt1 * ( psx (ji,jj) + zfx (ji,jj) ) 417 psxx(ji,jj) = zbt * psxx(ji,jj) + zbt1 * ( psxx(ji,jj) + zfxx(ji,jj) ) 418 END DO 419 END DO 420 420 421 421 !-- Lateral boundary conditions … … 428 428 CALL lbc_lnk( psxy, 'T', 1. ) 429 429 430 IF(ln_ctl) THEN430 IF(ln_ctl) THEN 431 431 CALL prt_ctl(tab2d_1=psm , clinfo1=' lim_adv_y: psm :', tab2d_2=ps0 , clinfo2=' ps0 : ') 432 432 CALL prt_ctl(tab2d_1=psx , clinfo1=' lim_adv_y: psx :', tab2d_2=psxx, clinfo2=' psxx : ') 433 433 CALL prt_ctl(tab2d_1=psy , clinfo1=' lim_adv_y: psy :', tab2d_2=psyy, clinfo2=' psyy : ') 434 434 CALL prt_ctl(tab2d_1=psxy , clinfo1=' lim_adv_y: psxy :') 435 ENDIF435 ENDIF 436 436 437 437 END SUBROUTINE lim_adv_y -
trunk/NEMO/LIM_SRC_3/limcons.F90
r834 r921 42 42 CONTAINS 43 43 44 !===============================================================================44 !=============================================================================== 45 45 46 46 SUBROUTINE lim_column_sum(nsum,xin,xout) 47 ! !!-------------------------------------------------------------------48 ! !! *** ROUTINE lim_column_sum ***49 ! !!50 ! !! ** Purpose : Compute the sum of xin over nsum categories51 ! !!52 ! !! ** Method : Arithmetics53 ! !!54 ! !! ** Action : Gets xin(ji,jj,jl) and computes xout(ji,jj)55 ! !!56 ! !! History :57 ! !! author: William H. Lipscomb, LANL58 ! !! 2.1 ! 04-06 (M. Vancoppenolle) Energy Conservation59 ! !!---------------------------------------------------------------------60 ! !! * Local variables47 ! !!------------------------------------------------------------------- 48 ! !! *** ROUTINE lim_column_sum *** 49 ! !! 50 ! !! ** Purpose : Compute the sum of xin over nsum categories 51 ! !! 52 ! !! ** Method : Arithmetics 53 ! !! 54 ! !! ** Action : Gets xin(ji,jj,jl) and computes xout(ji,jj) 55 ! !! 56 ! !! History : 57 ! !! author: William H. Lipscomb, LANL 58 ! !! 2.1 ! 04-06 (M. Vancoppenolle) Energy Conservation 59 ! !!--------------------------------------------------------------------- 60 ! !! * Local variables 61 61 INTEGER, INTENT(in) :: & 62 62 nsum ! number of categories/layers 63 63 64 64 REAL (wp), DIMENSION(jpi, jpj, jpl), INTENT(IN) :: & 65 65 xin ! input field 66 66 67 67 REAL (wp), DIMENSION(jpi, jpj), INTENT(OUT) :: & 68 68 xout ! output field 69 69 INTEGER :: & 70 71 72 ! !!---------------------------------------------------------------------73 ! WRITE(numout,*) ' lim_column_sum '74 ! WRITE(numout,*) ' ~~~~~~~~~~~~~~ '70 ji, jj, jl ! horizontal indices 71 72 ! !!--------------------------------------------------------------------- 73 ! WRITE(numout,*) ' lim_column_sum ' 74 ! WRITE(numout,*) ' ~~~~~~~~~~~~~~ ' 75 75 76 76 xout(:,:) = 0.00 … … 86 86 END SUBROUTINE lim_column_sum 87 87 88 !===============================================================================88 !=============================================================================== 89 89 90 90 SUBROUTINE lim_column_sum_energy(nsum,nlay,xin,xout) … … 106 106 !! * Local variables 107 107 INTEGER, INTENT(in) :: & 108 109 108 nsum, & !: number of categories 109 nlay !: number of vertical layers 110 110 111 111 REAL (wp), DIMENSION(jpi, jpj, jkmax, jpl), INTENT(IN) :: & 112 112 xin !: input field 113 113 114 114 REAL (wp), DIMENSION(jpi, jpj), INTENT(OUT) :: & 115 115 xout !: output field 116 116 117 117 INTEGER :: & 118 119 120 !!--------------------------------------------------------------------- 121 122 ! WRITE(numout,*) ' lim_column_sum_energy '123 ! WRITE(numout,*) ' ~~~~~~~~~~~~~~~~~~~~~ '118 ji, jj, & !: horizontal indices 119 jk, jl !: layer and category indices 120 !!--------------------------------------------------------------------- 121 122 ! WRITE(numout,*) ' lim_column_sum_energy ' 123 ! WRITE(numout,*) ' ~~~~~~~~~~~~~~~~~~~~~ ' 124 124 125 125 xout(:,:) = 0.00 … … 137 137 END SUBROUTINE lim_column_sum_energy 138 138 139 !===============================================================================140 139 !=============================================================================== 140 141 141 SUBROUTINE lim_cons_check(x1, x2, max_err, fieldid) 142 142 !!------------------------------------------------------------------- … … 206 206 WRITE (numout,*) ' Point : ', ji, jj 207 207 WRITE (numout,*) ' lat, lon : ', gphit(ji,jj), & 208 208 glamt(ji,jj) 209 209 WRITE (numout,*) ' Initial value : ', x1(ji,jj) 210 210 WRITE (numout,*) ' Final value : ', x2(ji,jj) -
trunk/NEMO/LIM_SRC_3/limdia.F90
r895 r921 95 95 !!------------------------------------------------------------------- 96 96 !! * Local variables 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 ! vinfor(84) = vinfor(84) / vinfor(6) !336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 !MV IF( MOD( numit , ninfo ) == 0 ) THEN423 424 425 426 427 428 !MV ENDIF429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 1000 610 1111 611 612 97 INTEGER :: jv,ji,jj,jl ! dummy loop indices 98 REAL(wp), DIMENSION(jpinfmx) :: & 99 vinfor ! temporary working space 100 REAL(wp) :: & 101 zshift_date , & ! date from the minimum ice extent 102 zday, zday_min, & ! current day, day of minimum extent 103 zafy, zamy, & ! temporary area of fy and my ice 104 zindb 105 !!------------------------------------------------------------------- 106 107 ! 0) date from the minimum of ice extent 108 !--------------------------------------- 109 zday_min = 273.0 ! zday_min = date of minimum extent, here September 30th 110 zday = FLOAT(numit-nit000) * rdt_ice / ( 86400.0 * FLOAT(nn_fsbc) ) 111 IF (zday.GT.zday_min) THEN 112 zshift_date = zday - zday_min 113 ELSE 114 zshift_date = zday - (365.0 - zday_min) 115 ENDIF 116 117 IF( numit == nstart ) CALL lim_dia_init ! initialisation of ice_evolu file 118 119 ! temporal diagnostics 120 vinfor(1) = REAL(numit) 121 vinfor(2) = nyear 122 123 ! put everything to zero 124 DO jv = nbvt + 1, nvinfo 125 vinfor(jv) = 0.0 126 END DO 127 128 !!------------------------------------------------------------------- 129 !! 1) Northern hemisphere 130 !!------------------------------------------------------------------- 131 !! 1.1) Diagnostics independent on age 132 !!------------------------------------ 133 DO jj = njeq, jpjm1 134 DO ji = fs_2, fs_jpim1 ! vector opt. 135 IF( tms(ji,jj) == 1 ) THEN 136 vinfor(3) = vinfor(3) + at_i(ji,jj)*aire(ji,jj) / 1.0e12 !ice area 137 IF (at_i(ji,jj).GT.0.15) vinfor(5) = vinfor(5) + aire(ji,jj) / 1.0e12 !ice extent 138 vinfor(7) = vinfor(7) + vt_i(ji,jj)*aire(ji,jj) / 1.0e12 !ice volume 139 vinfor(9) = vinfor(9) + vt_s(ji,jj)*aire(ji,jj) / 1.0e12 !snow volume 140 vinfor(15) = vinfor(15) + ot_i(ji,jj) *vt_i(ji,jj)*aire(ji,jj) / 1.0e12 !mean age 141 vinfor(29) = vinfor(29) + smt_i(ji,jj)*vt_i(ji,jj)*aire(ji,jj) / 1.0e12 !mean salinity 142 ! the computation of this diagnostic is not reliable 143 vinfor(31) = vinfor(31) + vt_i(ji,jj)*( u_ice(ji,jj)*u_ice(ji,jj) + & 144 v_ice(ji,jj)*v_ice(ji,jj) )*aire(ji,jj)/1.0e12 145 vinfor(53) = vinfor(53) + emps(ji,jj)*aire(ji,jj) / 1.0e12 !salt flux 146 vinfor(55) = vinfor(55) + fsbri(ji,jj)*aire(ji,jj) / 1.0e12 !brine drainage flux 147 vinfor(57) = vinfor(57) + fseqv(ji,jj)*aire(ji,jj) / 1.0e12 !equivalent salt flux 148 vinfor(59) = vinfor(59) +(sst_m(ji,jj)+rt0)*at_i(ji,jj)*aire(ji,jj) / 1.0e12 !SST 149 vinfor(61) = vinfor(61) + sss_m(ji,jj)*at_i(ji,jj)*aire(ji,jj) / 1.0e12 !SSS 150 vinfor(65) = vinfor(65) + et_s(ji,jj)/1.0e9*aire(ji,jj) / 1.0e12 ! snow temperature 151 vinfor(67) = vinfor(67) + et_i(ji,jj)/1.0e9*aire(ji,jj) / 1.0e12 ! ice heat content 152 vinfor(69) = vinfor(69) + v_i(ji,jj,1)*aire(ji,jj) / 1.0e12 !ice volume 153 vinfor(71) = vinfor(71) + v_i(ji,jj,2)*aire(ji,jj) / 1.0e12 !ice volume 154 vinfor(73) = vinfor(73) + v_i(ji,jj,3)*aire(ji,jj) / 1.0e12 !ice volume 155 vinfor(75) = vinfor(75) + v_i(ji,jj,4)*aire(ji,jj) / 1.0e12 !ice volume 156 vinfor(77) = vinfor(77) + v_i(ji,jj,5)*aire(ji,jj) / 1.0e12 !ice volume 157 vinfor(79) = 0.0 158 vinfor(81) = vinfor(81) + emp(ji,jj)*aire(ji,jj) / 1.0e12 ! mass flux 159 ENDIF 160 END DO 161 END DO 162 163 DO jl = ice_cat_bounds(1,1), ice_cat_bounds(1,2) 164 DO jj = njeq, jpjm1 165 DO ji = fs_2, fs_jpim1 ! vector opt. 166 IF( tms(ji,jj) == 1 ) THEN 167 vinfor(11) = vinfor(11) + v_i(ji,jj,jl)*aire(ji,jj) / 1.0e12 !undef def ice volume 168 ENDIF 169 END DO 170 END DO 171 END DO 172 173 vinfor(13) = 0.0 174 175 vinfor(15) = vinfor(15) / MAX(vinfor(7),epsi06) ! these have to be divided by total ice volume to have the 176 vinfor(29) = vinfor(29) / MAX(vinfor(7),epsi06) ! right value 177 vinfor(31) = SQRT( vinfor(31) / MAX( vinfor(7) , epsi06 ) ) 178 vinfor(67) = vinfor(67) / MAX(vinfor(7),epsi06) 179 180 vinfor(53) = vinfor(53) / MAX(vinfor(5),epsi06) ! these have to be divided by total ice extent to have the 181 vinfor(55) = vinfor(55) / MAX(vinfor(5),epsi06) ! right value 182 vinfor(57) = vinfor(57) / MAX(vinfor(5),epsi06) ! 183 vinfor(79) = vinfor(79) / MAX(vinfor(5),epsi06) ! 184 185 zindb = 1.0 - MAX(0.0,SIGN(1.0,-vinfor(3))) ! 186 vinfor(59) = zindb*vinfor(59) / MAX(vinfor(3),epsi06) ! divide by ice area 187 vinfor(61) = zindb*vinfor(61) / MAX(vinfor(3),epsi06) ! 188 189 zindb = 1.0 - MAX(0.0,SIGN(1.0,-vinfor(9))) ! 190 vinfor(65) = zindb*vinfor(65) / MAX(vinfor(9),epsi06) ! divide it by snow volume 191 192 193 DO jl = 1, jpl 194 DO jj = njeq, jpjm1 195 DO ji = fs_2, fs_jpim1 ! vector opt. 196 IF( tms(ji,jj) == 1 ) THEN 197 vinfor(33) = vinfor(33) + d_v_i_trp(ji,jj,jl)*aire(ji,jj) / 1.0e12 !ice volume 198 vinfor(35) = vinfor(35) + d_v_i_thd(ji,jj,jl)*aire(ji,jj) / 1.0e12 !ice volume 199 ENDIF 200 END DO 201 END DO 202 END DO 203 204 DO jj = njeq, jpjm1 205 DO ji = fs_2, fs_jpim1 ! vector opt. 206 IF( tms(ji,jj) == 1 ) THEN 207 vinfor(37) = vinfor(37) + diag_sni_gr(ji,jj)*aire(ji,jj) / 1.0e12 !th growth rates 208 vinfor(39) = vinfor(39) + diag_lat_gr(ji,jj)*aire(ji,jj) / 1.0e12 209 vinfor(41) = vinfor(41) + diag_bot_gr(ji,jj)*aire(ji,jj) / 1.0e12 210 vinfor(43) = vinfor(43) + diag_dyn_gr(ji,jj)*aire(ji,jj) / 1.0e12 211 vinfor(45) = vinfor(45) + dv_dt_thd(ji,jj,5)*aire(ji,jj) / 1.0e12 212 vinfor(47) = vinfor(47) + v_newice(ji,jj) *aire(ji,jj) / 1.0e12 / rdt_ice ! volume acc in OW 213 ENDIF 214 END DO 215 END DO 216 217 DO jl = 1, jpl 218 DO jj = njeq, jpjm1 219 DO ji = fs_2, fs_jpim1 ! vector opt. 220 IF( tms(ji,jj) == 1 ) THEN 221 vinfor(63) = vinfor(63) + t_su(ji,jj,jl)*a_i(ji,jj,jl)*aire(ji,jj) / 1.0e12 222 ENDIF 223 END DO 224 END DO 225 END DO 226 vinfor(63) = vinfor(63) / MAX(vinfor(3),epsi06) ! these have to be divided by total ice area 227 228 !! 1.2) Diagnostics dependent on age 229 !!------------------------------------ 230 DO jj = njeq, jpjm1 231 DO ji = fs_2, fs_jpim1 ! vector opt. 232 IF( tms(ji,jj) == 1 ) THEN 233 zafy = 0.0 234 zamy = 0.0 235 DO jl = 1, jpl 236 IF ((o_i(ji,jj,jl) - zshift_date).LT.0.0) THEN 237 vinfor(17) = vinfor(17) + a_i(ji,jj,jl)*aire(ji,jj) / 1.0e12 ! FY ice area 238 vinfor(25) = vinfor(25) + v_i(ji,jj,jl)*aire(ji,jj) / 1.0e12 ! FY ice volume 239 vinfor(49) = vinfor(49) + sm_i(ji,jj,jl)*v_i(ji,jj,jl)*aire(ji,jj) / 1.0e12 !FY ice salinity 240 zafy = zafy + a_i(ji,jj,jl) 241 ENDIF 242 IF ((o_i(ji,jj,jl) - zshift_date).GT.0.0) THEN 243 vinfor(19) = vinfor(19) + a_i(ji,jj,jl)*aire(ji,jj) / 1.0e12 ! MY ice area 244 vinfor(27) = vinfor(27) + v_i(ji,jj,jl)*aire(ji,jj) / 1.0e12 ! MY ice volume 245 vinfor(51) = vinfor(51) + sm_i(ji,jj,jl)*v_i(ji,jj,jl)*aire(ji,jj) / 1.0e12 !MY ice salinity 246 zamy = zamy + a_i(ji,jj,jl) 247 ENDIF 248 END DO 249 IF ((at_i(ji,jj).GT.0.15).AND.(zafy.GT.zamy)) THEN 250 vinfor(21) = vinfor(21) + aire(ji,jj) / 1.0e12 ! Seasonal ice extent 251 ENDIF 252 IF ((at_i(ji,jj).GT.0.15).AND.(zafy.LE.zamy)) THEN 253 vinfor(23) = vinfor(23) + aire(ji,jj) / 1.0e12 ! Perennial ice extent 254 ENDIF 255 ENDIF 256 END DO 257 END DO 258 zindb = 1.0 - MAX(0.0,SIGN(1.0,-vinfor(25))) !=0 if no multiyear ice 1 if yes 259 vinfor(49) = zindb*vinfor(49) / MAX(vinfor(25),epsi06) 260 zindb = 1.0 - MAX(0.0,SIGN(1.0,-vinfor(27))) !=0 if no multiyear ice 1 if yes 261 vinfor(51) = zindb*vinfor(51) / MAX(vinfor(27),epsi06) 262 263 !! Fram Strait Export 264 !! 83 = area export 265 !! 84 = volume export 266 !! Fram strait in ORCA2 = 5 points 267 !! export = -v_ice*e1t*ddtb*at_i or -v_ice*e1t*ddtb*at_i*h_i 268 jj = 136 ! C grid 269 vinfor(83) = 0.0 270 vinfor(84) = 0.0 271 DO ji = 134, 138 272 vinfor(83) = vinfor(83) - v_ice(ji,jj) * & 273 e1t(ji,jj)*at_i(ji,jj)*rdt_ice / 1.0e12 274 vinfor(84) = vinfor(84) - v_ice(ji,jj) * & 275 e1t(ji,jj)*vt_i(ji,jj)*rdt_ice / 1.0e12 276 END DO 277 278 !!------------------------------------------------------------------- 279 !! 2) Southern hemisphere 280 !!------------------------------------------------------------------- 281 !! 2.1) Diagnostics independent on age 282 !!------------------------------------ 283 DO jj = 2, njeqm1 284 DO ji = fs_2, fs_jpim1 ! vector opt. 285 IF( tms(ji,jj) == 1 ) THEN 286 vinfor(4) = vinfor(4) + at_i(ji,jj)*aire(ji,jj) / 1.0e12 !ice area 287 IF (at_i(ji,jj).GT.0.15) vinfor(6) = vinfor(6) + aire(ji,jj) / 1.0e12 !ice extent 288 vinfor(8) = vinfor(8) + vt_i(ji,jj)*aire(ji,jj) / 1.0e12 !ice volume 289 vinfor(10) = vinfor(10) + vt_s(ji,jj)*aire(ji,jj) / 1.0e12 !snow volume 290 vinfor(16) = vinfor(16) + ot_i(ji,jj)*vt_i(ji,jj)*aire(ji,jj) / 1.0e12 !mean age 291 vinfor(30) = vinfor(30) + smt_i(ji,jj)*vt_i(ji,jj)*aire(ji,jj) / 1.0e12 !mean salinity 292 ! this diagnostic is not well computed (weighted by vol instead 293 ! of area) 294 vinfor(32) = vinfor(32) + vt_i(ji,jj)*( u_ice(ji,jj)*u_ice(ji,jj) + & 295 v_ice(ji,jj)*v_ice(ji,jj) )*aire(ji,jj)/1.0e12 !ice vel 296 vinfor(54) = vinfor(54) + at_i(ji,jj)*emps(ji,jj)*aire(ji,jj) / 1.0e12 ! Total salt flux 297 vinfor(56) = vinfor(56) + at_i(ji,jj)*fsbri(ji,jj)*aire(ji,jj) / 1.0e12 ! Brine drainage salt flux 298 vinfor(58) = vinfor(58) + at_i(ji,jj)*fseqv(ji,jj)*aire(ji,jj) / 1.0e12 ! Equivalent salt flux 299 vinfor(60) = vinfor(60) +(sst_m(ji,jj)+rt0)*at_i(ji,jj)*aire(ji,jj) / 1.0e12 !SST 300 vinfor(62) = vinfor(62) + sss_m(ji,jj)*at_i(ji,jj)*aire(ji,jj) / 1.0e12 !SSS 301 vinfor(66) = vinfor(66) + et_s(ji,jj)/1.0e9*aire(ji,jj) / 1.0e12 ! snow temperature 302 vinfor(68) = vinfor(68) + et_i(ji,jj)/1.0e9*aire(ji,jj) / 1.0e12 ! ice enthalpy 303 vinfor(70) = vinfor(70) + v_i(ji,jj,1)*aire(ji,jj) / 1.0e12 !ice volume 304 vinfor(72) = vinfor(72) + v_i(ji,jj,2)*aire(ji,jj) / 1.0e12 !ice volume 305 vinfor(74) = vinfor(74) + v_i(ji,jj,3)*aire(ji,jj) / 1.0e12 !ice volume 306 vinfor(76) = vinfor(76) + v_i(ji,jj,4)*aire(ji,jj) / 1.0e12 !ice volume 307 vinfor(78) = vinfor(78) + v_i(ji,jj,5)*aire(ji,jj) / 1.0e12 !ice volume 308 vinfor(80) = 0.0 309 vinfor(82) = vinfor(82) + emp(ji,jj)*aire(ji,jj) / 1.0e12 ! mass flux 310 ENDIF 311 END DO 312 END DO 313 314 DO jl = ice_cat_bounds(1,1), ice_cat_bounds(1,2) 315 DO jj = 2, njeqm1 316 DO ji = fs_2, fs_jpim1 ! vector opt. 317 vinfor(12) = vinfor(12) + v_i(ji,jj,jl)*aire(ji,jj) / 1.0e12 !undef def ice volume 318 END DO 319 END DO 320 END DO 321 322 vinfor(14) = 0.0 323 324 zindb = 1.0 - MAX(0.0,SIGN(1.0,-vinfor(8))) 325 vinfor(16) = zindb * vinfor(16) / MAX(vinfor(8),epsi06) ! these have to be divided by ice vol 326 vinfor(30) = zindb * vinfor(30) / MAX(vinfor(8),epsi06) ! 327 vinfor(32) = zindb * SQRT( vinfor(32) / MAX( vinfor(8) , epsi06 ) ) 328 vinfor(68) = zindb * vinfor(68) / MAX(vinfor(8),epsi06) ! 329 330 zindb = 1.0 - MAX(0.0,SIGN(1.0,-vinfor(6))) 331 vinfor(54) = zindb * vinfor(54) / MAX(vinfor(6),epsi06) ! these have to be divided by ice extt 332 vinfor(56) = zindb * vinfor(56) / MAX(vinfor(6),epsi06) ! 333 vinfor(58) = zindb * vinfor(58) / MAX(vinfor(6),epsi06) ! 334 vinfor(80) = zindb * vinfor(80) / MAX(vinfor(6),epsi06) ! 335 ! vinfor(84) = vinfor(84) / vinfor(6) ! 336 337 zindb = 1.0 - MAX(0.0,SIGN(1.0,-vinfor(4))) ! 338 vinfor(60) = zindb*vinfor(60) / ( MAX(vinfor(4), epsi06) ) ! divide by ice area 339 vinfor(62) = zindb*vinfor(62) / ( MAX(vinfor(4), epsi06) ) ! 340 341 zindb = 1.0 - MAX(0.0,SIGN(1.0,-vinfor(10))) ! 342 vinfor(66) = zindb*vinfor(66) / MAX(vinfor(10),epsi06) ! divide it by snow volume 343 344 DO jl = 1, jpl 345 DO jj = 2, njeqm1 346 DO ji = fs_2, fs_jpim1 ! vector opt. 347 IF( tms(ji,jj) == 1 ) THEN 348 vinfor(34) = vinfor(34) + d_v_i_trp(ji,jj,jl)*aire(ji,jj) / 1.0e12 !ice volume 349 vinfor(36) = vinfor(36) + d_v_i_thd(ji,jj,jl)*aire(ji,jj) / 1.0e12 !ice volume 350 ENDIF 351 END DO 352 END DO 353 END DO 354 355 DO jj = 2, njeqm1 356 DO ji = fs_2, fs_jpim1 ! vector opt. 357 IF( tms(ji,jj) == 1 ) THEN 358 vinfor(38) = vinfor(38) + diag_sni_gr(ji,jj)*aire(ji,jj) / 1.0e12 !th growth rates 359 vinfor(40) = vinfor(40) + diag_lat_gr(ji,jj)*aire(ji,jj) / 1.0e12 360 vinfor(42) = vinfor(42) + diag_bot_gr(ji,jj)*aire(ji,jj) / 1.0e12 361 vinfor(44) = vinfor(44) + diag_dyn_gr(ji,jj)*aire(ji,jj) / 1.0e12 362 vinfor(46) = vinfor(46) + dv_dt_thd(ji,jj,5)*aire(ji,jj) / 1.0e12 363 vinfor(48) = vinfor(48) + v_newice(ji,jj) *aire(ji,jj) / 1.0e12 / rdt_ice ! volume acc in OW 364 ENDIF 365 END DO 366 END DO 367 368 369 DO jl = 1, jpl 370 DO jj = 2, njeqm1 371 DO ji = fs_2, fs_jpim1 ! vector opt. 372 IF( tms(ji,jj) == 1 ) THEN 373 vinfor(64) = vinfor(64) + t_su(ji,jj,jl)*a_i(ji,jj,jl)*aire(ji,jj) / 1.0e12 374 ENDIF 375 END DO 376 END DO 377 END DO 378 zindb = 1.0 - MAX(0.0,SIGN(1.0,-vinfor(4))) ! 379 vinfor(64) = zindb * vinfor(64) / MAX(vinfor(4),epsi06) ! divide by ice extt 380 !! 2.2) Diagnostics dependent on age 381 !!------------------------------------ 382 DO jj = 2, njeqm1 383 DO ji = fs_2, fs_jpim1 ! vector opt. 384 IF( tms(ji,jj) == 1 ) THEN 385 zafy = 0.0 386 zamy = 0.0 387 DO jl = 1, jpl 388 IF ((o_i(ji,jj,jl) - zshift_date).LT.0.0) THEN 389 vinfor(18) = vinfor(18) + a_i(ji,jj,jl)*aire(ji,jj) / 1.0e12 ! FY ice area 390 vinfor(26) = vinfor(26) + v_i(ji,jj,jl)*aire(ji,jj) / 1.0e12 ! FY ice volume 391 zafy = zafy + a_i(ji,jj,jl) 392 vinfor(50) = vinfor(50) + sm_i(ji,jj,jl)*v_i(ji,jj,jl)*aire(ji,jj) / 1.0e12 !FY ice salinity 393 ENDIF 394 IF ((o_i(ji,jj,jl) - zshift_date).GT.0.0) THEN 395 vinfor(20) = vinfor(20) + a_i(ji,jj,jl)*aire(ji,jj) / 1.0e12 ! MY ice area 396 vinfor(28) = vinfor(28) + v_i(ji,jj,jl)*aire(ji,jj) / 1.0e12 397 vinfor(52) = vinfor(52) + sm_i(ji,jj,jl)*v_i(ji,jj,jl)*aire(ji,jj) / 1.0e12 !FY ice salinity 398 zamy = zamy + a_i(ji,jj,jl) 399 ENDIF 400 END DO ! jl 401 IF ((at_i(ji,jj).GT.0.15).AND.(zafy.GT.zamy)) THEN 402 vinfor(22) = vinfor(22) + aire(ji,jj) / 1.0e12 ! Seasonal ice extent 403 ENDIF 404 IF ((at_i(ji,jj).GT.0.15).AND.(zafy.LE.zamy)) THEN 405 vinfor(24) = vinfor(24) + aire(ji,jj) / 1.0e12 ! Perennial ice extent 406 ENDIF 407 ENDIF ! tms 408 END DO ! jj 409 END DO ! ji 410 zindb = 1.0 - MAX(0.0,SIGN(1.0,-vinfor(26))) !=0 if no multiyear ice 1 if yes 411 vinfor(50) = zindb*vinfor(50) / MAX(vinfor(26),epsi06) 412 zindb = 1.0 - MAX(0.0,SIGN(1.0,-vinfor(28))) !=0 if no multiyear ice 1 if yes 413 vinfor(52) = zindb*vinfor(52) / MAX(vinfor(28),epsi06) 414 415 ! Accumulation before averaging 416 DO jv = 1, nvinfo 417 vinfom(jv) = vinfom(jv) + vinfor(jv) 418 END DO 419 naveg = naveg + 1 420 421 ! oututs on file ice_evolu 422 !MV IF( MOD( numit , ninfo ) == 0 ) THEN 423 WRITE(numevo_ice,fmtw) ( titvar(jv), vinfom(jv)/naveg, jv = 1, nvinfo ) 424 naveg = 0 425 DO jv = 1, nvinfo 426 vinfom(jv)=0.0 427 END DO 428 !MV ENDIF 429 430 END SUBROUTINE lim_dia 431 432 SUBROUTINE lim_dia_init 433 !!------------------------------------------------------------------- 434 !! *** ROUTINE lim_dia_init *** 435 !! 436 !! ** Purpose : Preparation of the file ice_evolu for the output of 437 !! the temporal evolution of key variables 438 !! 439 !! ** input : Namelist namicedia 440 !! 441 !! history : 442 !! 8.5 ! 03-08 (C. Ethe) original code 443 !! 9.0 ! 08-03 (M. Vancoppenolle) LIM3 444 !!------------------------------------------------------------------- 445 NAMELIST/namicedia/fmtinf, nfrinf, ninfo, ntmoy 446 447 INTEGER :: jv , & ! dummy loop indice 448 & ntot , & 449 & ndeb , & 450 & irecl 451 452 REAL(wp) :: zxx0, zxx1 ! temporary scalars 453 454 CHARACTER(len=jpchinf) :: titinf 455 CHARACTER(len=50) :: clname 456 !!------------------------------------------------------------------- 457 458 459 ! Read Namelist namicedia 460 REWIND ( numnam_ice ) 461 READ ( numnam_ice , namicedia ) 462 IF(lwp) THEN 463 WRITE(numout,*) 464 WRITE(numout,*) 'lim_dia_init : ice parameters for ice diagnostics ' 465 WRITE(numout,*) '~~~~~~~~~~~~' 466 WRITE(numout,*) ' format of the output values fmtinf = ', fmtinf 467 WRITE(numout,*) ' number of variables written in one line nfrinf = ', nfrinf 468 WRITE(numout,*) ' Instantaneous values of ice evolution or averaging ntmoy = ', ntmoy 469 WRITE(numout,*) ' frequency of ouputs on file ice_evolu in case of averaging ninfo = ', ninfo 470 ENDIF 471 472 ! masked grid cell area 473 aire(:,:) = area(:,:) * tms(:,:) 474 475 ! Titles of ice key variables : 476 titvar(1) = 'NoIt' ! iteration number 477 titvar(2) = 'T yr' ! time step in years 478 nbvt = 2 ! number of time variables 479 480 titvar(3) = 'AI_N' ! sea ice area in the northern Hemisp.(10^12 km2) 481 titvar(4) = 'AI_S' ! sea ice area in the southern Hemisp.(10^12 km2) 482 titvar(5) = 'EI_N' ! sea ice extent (15%) in the northern Hemisp.(10^12 km2) 483 titvar(6) = 'EI_S' ! sea ice extent (15%) in the southern Hemisp.(10^12 km2) 484 titvar(7) = 'VI_N' ! sea ice volume in the northern Hemisp.(10^3 km3) 485 titvar(8) = 'VI_S' ! sea ice volume in the southern Hemisp.(10^3 km3) 486 titvar(9) = 'VS_N' ! snow volume over sea ice in the northern Hemisp.(10^3 km3) 487 titvar(10)= 'VS_S' ! snow volume over sea ice in the northern Hemisp.(10^3 km3) 488 titvar(11)= 'VuIN' ! undeformed sea ice volume in the northern Hemisp.(10^3 km3) 489 titvar(12)= 'VuIS' ! undeformed sea ice volume in the southern Hemisp.(10^3 km3) 490 titvar(13)= 'VdIN' ! deformed sea ice volume in the northern Hemisp.(10^3 km3) 491 titvar(14)= 'VdIS' ! deformed sea ice volume in the southern Hemisp.(10^3 km3) 492 titvar(15)= 'OI_N' ! sea ice mean age in the northern Hemisp.(years) 493 titvar(16)= 'OI_S' ! sea ice mean age in the southern Hemisp.(years) 494 titvar(17)= 'AFYN' ! total FY ice area northern Hemisp.(10^12 km2) 495 titvar(18)= 'AFYS' ! total FY ice area southern Hemisp.(10^12 km2) 496 titvar(19)= 'AMYN' ! total MY ice area northern Hemisp.(10^12 km2) 497 titvar(20)= 'AMYS' ! total MY ice area southern Hemisp.(10^12 km2) 498 titvar(21)= 'EFYN' ! total FY ice extent northern Hemisp.(10^12 km2) (with more 50% FY ice) 499 titvar(22)= 'EFYS' ! total FY ice extent southern Hemisp.(10^12 km2) (with more 50% FY ice) 500 titvar(23)= 'EMYN' ! total MY ice extent northern Hemisp.(10^12 km2) (with more 50% MY ice) 501 titvar(24)= 'EMYS' ! total MY ice extent southern Hemisp.(10^12 km2) (with more 50% MY ice) 502 titvar(25)= 'VFYN' ! total undeformed FY ice volume northern Hemisp.(10^3 km3) 503 titvar(26)= 'VFYS' ! total undeformed FY ice volume southern Hemisp.(10^3 km3) 504 titvar(27)= 'VMYN' ! total undeformed MY ice volume northern Hemisp.(10^3 km3) 505 titvar(28)= 'VMYS' ! total undeformed MY ice volume southern Hemisp.(10^3 km3) 506 titvar(29)= 'IS_N' ! sea ice mean salinity in the northern hemisphere (ppt) 507 titvar(30)= 'IS_S' ! sea ice mean salinity in the southern hemisphere (ppt) 508 titvar(31)= 'IVeN' ! sea ice mean velocity in the northern hemisphere (m/s) 509 titvar(32)= 'IVeS' ! sea ice mean velocity in the southern hemisphere (m/s) 510 titvar(33)= 'DVDN' ! variation of sea ice volume due to dynamics in the northern hemisphere 511 titvar(34)= 'DVDS' ! variation of sea ice volume due to dynamics in the southern hemisphere 512 titvar(35)= 'DVTN' ! variation of sea ice volume due to thermo in the northern hemisphere 513 titvar(36)= 'DVTS' ! variation of sea ice volume due to thermo in the southern hemisphere 514 titvar(37)= 'TG1N' ! thermodynamic vertical growth rate in the northern hemisphere, cat 1 515 titvar(38)= 'TG1S' ! thermodynamic vertical growth rate in the souhtern hemisphere, cat 1 516 titvar(39)= 'TG2N' ! thermodynamic vertical growth rate in the northern hemisphere, cat 2 517 titvar(40)= 'TG2S' ! thermodynamic vertical growth rate in the souhtern hemisphere, cat 2 518 titvar(41)= 'TG3N' ! thermodynamic vertical growth rate in the northern hemisphere, cat 3 519 titvar(42)= 'TG3S' ! thermodynamic vertical growth rate in the souhtern hemisphere, cat 3 520 titvar(43)= 'TG4N' ! thermodynamic vertical growth rate in the northern hemisphere, cat 4 521 titvar(44)= 'TG4S' ! thermodynamic vertical growth rate in the souhtern hemisphere, cat 4 522 titvar(45)= 'TG5N' ! thermodynamic vertical growth rate in the northern hemisphere, cat 5 523 titvar(46)= 'TG5S' ! thermodynamic vertical growth rate in the souhtern hemisphere, cat 5 524 titvar(47)= 'LA_N' ! lateral accretion growth rate, northern hemisphere 525 titvar(48)= 'LA_S' ! lateral accretion growth rate, southern hemisphere 526 titvar(49)= 'SF_N' ! Salinity FY, NH 527 titvar(50)= 'SF_S' ! Salinity FY, SH 528 titvar(51)= 'SF_N' ! Salinity MY, NH 529 titvar(52)= 'SF_S' ! Salinity MY, SH 530 titvar(53)= 'Fs_N' ! Total salt flux NH 531 titvar(54)= 'Fs_S' ! Total salt flux SH 532 titvar(55)= 'FsbN' ! Salt - brine drainage flux NH 533 titvar(56)= 'FsbS' ! Salt - brine drainage flux SH 534 titvar(57)= 'FseN' ! Salt - Equivalent salt flux NH 535 titvar(58)= 'FseS' ! Salt - Equivalent salt flux SH 536 titvar(59)= 'SSTN' ! SST, NH 537 titvar(60)= 'SSTS' ! SST, SH 538 titvar(61)= 'SSSN' ! SSS, NH 539 titvar(62)= 'SSSS' ! SSS, SH 540 titvar(63)= 'TsuN' ! Tsu, NH 541 titvar(64)= 'TsuS' ! Tsu, SH 542 titvar(65)= 'TsnN' ! Tsn, NH 543 titvar(66)= 'TsnS' ! Tsn, SH 544 titvar(67)= 'ei_N' ! ei, NH 545 titvar(68)= 'ei_S' ! ei, SH 546 titvar(69)= 'vi1N' ! vi1, NH 547 titvar(70)= 'vi1S' ! vi1, SH 548 titvar(71)= 'vi2N' ! vi2, NH 549 titvar(72)= 'vi2S' ! vi2, SH 550 titvar(73)= 'vi3N' ! vi3, NH 551 titvar(74)= 'vi3S' ! vi3, SH 552 titvar(75)= 'vi4N' ! vi4, NH 553 titvar(76)= 'vi4S' ! vi4, SH 554 titvar(77)= 'vi5N' ! vi5, NH 555 titvar(78)= 'vi5S' ! vi5, SH 556 titvar(79)= 'vi6N' ! vi6, NH 557 titvar(80)= 'vi6S' ! vi6, SH 558 titvar(81)= 'fmaN' ! mass flux in the ocean, NH 559 titvar(82)= 'fmaS' ! mass flux in the ocean, SH 560 titvar(83)= 'AFSE' ! Fram Strait Area export 561 titvar(84)= 'VFSE' ! Fram Strait Volume export 562 nvinfo = 84 563 564 ! Definition et Ecriture de l'entete : nombre d'enregistrements 565 ndeb = ( nstart - 1 ) / ninfo 566 IF( nstart == 1 ) ndeb = -1 567 568 nferme = ( nstart - 1 + nitrun) / ninfo 569 ntot = nferme - ndeb 570 ndeb = ninfo * ( 1 + ndeb ) 571 nferme = ninfo * nferme 572 573 ! definition of formats 574 WRITE( fmtw , '(A,I3,A2,I1,A)' ) '(', nfrinf, '(A', jpchsep, ','//fmtinf//'))' 575 WRITE( fmtr , '(A,I3,A,I1,A)' ) '(', nfrinf, '(', jpchsep, 'X,'//fmtinf//'))' 576 WRITE( fmtitr, '(A,I3,A,I1,A)' ) '(', nvinfo, 'A', jpchinf, ')' 577 578 ! opening "ice_evolu" file 579 clname = 'ice.evolu' 580 irecl = ( jpchinf + 1 ) * nvinfo 581 CALL ctlopn( numevo_ice, clname, 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', & 582 & irecl, numout, lwp, 1 ) 583 584 !- ecriture de 2 lignes d''entete : 585 WRITE(numevo_ice,1000) fmtr, fmtw, fmtitr, nvinfo, ntot, 0, nfrinf 586 zxx0 = 0.001 * REAL(ninfo) 587 zxx1 = 0.001 * REAL(ndeb) 588 WRITE(numevo_ice,1111) REAL(jpchinf), 0., zxx1, zxx0, 0., 0., 0 589 590 !- ecriture de 2 lignes de titre : 591 WRITE(numevo_ice,'(A,I8,A,I8,A,I5)') & 592 'Evolution chronologique - Experience '//cexper & 593 //' de', ndeb, ' a', nferme, ' pas', ninfo 594 WRITE(numevo_ice,fmtitr) ( titvar(jv), jv = 1, nvinfo ) 595 596 597 !--preparation de "titvar" pour l''ecriture parmi les valeurs numeriques : 598 DO jv = 2 , nvinfo 599 titinf = titvar(jv)(:jpchinf) 600 titvar(jv) = ' '//titinf 601 END DO 602 603 !--Initialisation of the arrays for the accumulation 604 DO jv = 1, nvinfo 605 vinfom(jv) = 0. 606 END DO 607 naveg = 0 608 609 1000 FORMAT( 3(A20),4(1x,I6) ) 610 1111 FORMAT( 3(F7.1,1X,F7.3,1X),I3,A ) 611 612 END SUBROUTINE lim_dia_init 613 613 614 614 #else -
trunk/NEMO/LIM_SRC_3/limdyn.F90
r913 r921 48 48 CONTAINS 49 49 50 SUBROUTINE lim_dyn 50 SUBROUTINE lim_dyn( kt ) 51 51 !!------------------------------------------------------------------- 52 52 !! *** ROUTINE lim_dyn *** … … 66 66 !! LIM3, EVP, C-grid 67 67 !!------------------------------------------------------------------------------------ 68 INTEGER, INTENT(in) :: kt ! number of iteration 68 69 !! * Local variables 69 70 INTEGER :: ji, jj, jl, ja ! dummy loop indices … … 75 76 !!--------------------------------------------------------------------- 76 77 77 WRITE(numout,*) ' lim_dyn : Ice dynamics ' 78 WRITE(numout,*) ' ~~~~~~~ ' 78 IF( kt == nit000 .AND. lwp ) THEN 79 WRITE(numout,*) ' lim_dyn : Ice dynamics ' 80 WRITE(numout,*) ' ~~~~~~~ ' 81 ENDIF 79 82 80 83 IF( numit == nstart ) CALL lim_dyn_init ! Initialization (first time-step only) 81 84 82 85 IF ( ln_limdyn ) THEN 83 86 … … 219 222 END SUBROUTINE lim_dyn 220 223 221 224 SUBROUTINE lim_dyn_init 222 225 !!------------------------------------------------------------------- 223 226 !! *** ROUTINE lim_dyn_init *** -
trunk/NEMO/LIM_SRC_3/limhdf.F90
r888 r921 84 84 ! Arrays initialization 85 85 ptab0 (:, : ) = ptab(:,:) 86 !bug zflu (:,jpj) = 0.e087 !bug zflv (:,jpj) = 0.e086 !bug zflu (:,jpj) = 0.e0 87 !bug zflv (:,jpj) = 0.e0 88 88 zdiv0(:, 1 ) = 0.e0 89 89 zdiv0(:,jpj) = 0.e0 -
trunk/NEMO/LIM_SRC_3/limistate.F90
r888 r921 86 86 zvol, zare, zh, zh1, zh2, zh3, zan, zbn, zas, zbs 87 87 !-------------------------------------------------------------------- 88 88 89 89 !-------------------------------------------------------------------- 90 90 ! 1) Preliminary things … … 113 113 zs0 = 34.e0 114 114 ztf = ABS ( rt0 - 0.0575 * zs0 & 115 116 115 & + 1.710523e-03 * zs0 * SQRT( zs0 ) & 116 & - 2.154996e-04 * zs0 *zs0 ) 117 117 118 118 ! constants for heat contents … … 179 179 ! ------------- 180 180 !!! 181 ! retour a LIMA_MEC182 ! ! second ice type183 ! zdummy = hi_max(ice_cat_bounds(2,1)-1)184 ! hi_max(ice_cat_bounds(2,1)-1) = 0.0185 186 ! ! here to change !!!!187 ! jm = 2188 ! DO jl = ice_cat_bounds(jm,1), ice_cat_bounds(jm,2)189 ! zhin (2) = ( hi_max(jl-1) + hi_max(jl) ) / 2.0190 ! zhin (2) = ( hi_max_typ(jl-ice_cat_bounds(2,1),jm ) + &191 ! hi_max_typ(jl-ice_cat_bounds(2,1) + 1,jm) ) / 2.0192 ! zgfactorn(2) = zgfactorn(2) + exp(-(zhin(2)-hginn_d)*(zhin(2)-hginn_d)/2.0)193 ! zhis (2) = ( hi_max(jl-1) + hi_max(jl) ) / 2.0194 ! zhis (2) = ( hi_max_typ(jl-ice_cat_bounds(2,1),jm ) + &195 ! hi_max_typ(jl-ice_cat_bounds(2,1) + 1,jm) ) / 2.0196 ! zgfactors(2) = zgfactors(2) + exp(-(zhis(2)-hgins_d)*(zhis(2)-hgins_d)/2.0)197 ! END DO ! jl198 ! zgfactorn(2) = aginn_d / zgfactorn(2)199 ! zgfactors(2) = agins_d / zgfactors(2)200 ! hi_max(ice_cat_bounds(2,1)-1) = zdummy201 ! END retour a LIMA_MEC181 ! retour a LIMA_MEC 182 ! ! second ice type 183 ! zdummy = hi_max(ice_cat_bounds(2,1)-1) 184 ! hi_max(ice_cat_bounds(2,1)-1) = 0.0 185 186 ! ! here to change !!!! 187 ! jm = 2 188 ! DO jl = ice_cat_bounds(jm,1), ice_cat_bounds(jm,2) 189 ! zhin (2) = ( hi_max(jl-1) + hi_max(jl) ) / 2.0 190 ! zhin (2) = ( hi_max_typ(jl-ice_cat_bounds(2,1),jm ) + & 191 ! hi_max_typ(jl-ice_cat_bounds(2,1) + 1,jm) ) / 2.0 192 ! zgfactorn(2) = zgfactorn(2) + exp(-(zhin(2)-hginn_d)*(zhin(2)-hginn_d)/2.0) 193 ! zhis (2) = ( hi_max(jl-1) + hi_max(jl) ) / 2.0 194 ! zhis (2) = ( hi_max_typ(jl-ice_cat_bounds(2,1),jm ) + & 195 ! hi_max_typ(jl-ice_cat_bounds(2,1) + 1,jm) ) / 2.0 196 ! zgfactors(2) = zgfactors(2) + exp(-(zhis(2)-hgins_d)*(zhis(2)-hgins_d)/2.0) 197 ! END DO ! jl 198 ! zgfactorn(2) = aginn_d / zgfactorn(2) 199 ! zgfactors(2) = agins_d / zgfactors(2) 200 ! hi_max(ice_cat_bounds(2,1)-1) = zdummy 201 ! END retour a LIMA_MEC 202 202 !!! 203 203 DO jj = 1, jpj … … 228 228 zhin(1) = ( hi_max(jl-1) + hi_max(jl) ) / 2.0 229 229 a_i(ji,jj,jl) = zidto * MAX( zgfactorn(1) * exp(-(zhin(1)-hginn_u)* & 230 230 (zhin(1)-hginn_u)/2.0) , epsi06) 231 231 ! new line 232 232 a_i(ji,jj,jl) = zidto * ( zan * zhin(1) * zhin(1) + zbn * zhin(1) ) … … 239 239 240 240 !!! 241 ! retour a LIMA_MEC242 ! !ridged ice243 ! zdummy = hi_max(ice_cat_bounds(2,1)-1)244 ! hi_max(ice_cat_bounds(2,1)-1) = 0.0245 ! DO jl = ice_cat_bounds(2,1), ice_cat_bounds(2,2) ! loop over ice thickness categories246 ! zhin(2) = ( hi_max(jl-1) + hi_max(jl) ) / 2.0247 ! a_i(ji,jj,jl) = zidto * MAX( zgfactorn(2) * exp(-(zhin(2)-hginn_d)* &248 ! (zhin(2)-hginn_d)/2.0) , epsi06)249 ! ht_i(ji,jj,jl) = zidto * zhin(2)250 ! v_i(ji,jj,jl) = ht_i(ji,jj,jl)*a_i(ji,jj,jl)251 ! END DO252 ! hi_max(ice_cat_bounds(2,1)-1) = zdummy253 254 ! !rafted ice255 ! jl = 6256 ! a_i(ji,jj,jl) = 0.0257 ! ht_i(ji,jj,jl) = 0.0258 ! v_i(ji,jj,jl) = 0.0259 ! END retour a LIMA_MEC241 ! retour a LIMA_MEC 242 ! !ridged ice 243 ! zdummy = hi_max(ice_cat_bounds(2,1)-1) 244 ! hi_max(ice_cat_bounds(2,1)-1) = 0.0 245 ! DO jl = ice_cat_bounds(2,1), ice_cat_bounds(2,2) ! loop over ice thickness categories 246 ! zhin(2) = ( hi_max(jl-1) + hi_max(jl) ) / 2.0 247 ! a_i(ji,jj,jl) = zidto * MAX( zgfactorn(2) * exp(-(zhin(2)-hginn_d)* & 248 ! (zhin(2)-hginn_d)/2.0) , epsi06) 249 ! ht_i(ji,jj,jl) = zidto * zhin(2) 250 ! v_i(ji,jj,jl) = ht_i(ji,jj,jl)*a_i(ji,jj,jl) 251 ! END DO 252 ! hi_max(ice_cat_bounds(2,1)-1) = zdummy 253 254 ! !rafted ice 255 ! jl = 6 256 ! a_i(ji,jj,jl) = 0.0 257 ! ht_i(ji,jj,jl) = 0.0 258 ! v_i(ji,jj,jl) = 0.0 259 ! END retour a LIMA_MEC 260 260 !!! 261 261 … … 279 279 o_i(ji,jj,jl) = zidto * 1.0 + ( 1.0 - zidto ) 280 280 oa_i(ji,jj,jl) = o_i(ji,jj,jl) * a_i(ji,jj,jl) 281 281 282 282 !------------------------------ 283 283 ! Sea ice surface temperature … … 298 298 ! Multiply by volume, so that heat content in 10^9 Joules 299 299 e_s(ji,jj,jk,jl) = e_s(ji,jj,jk,jl) * area(ji,jj) * & 300 300 v_s(ji,jj,jl) / nlay_s 301 301 END DO !jk 302 302 … … 309 309 s_i(ji,jj,jk,jl) = zidto * sinn + ( 1.0 - zidto ) * 0.1 310 310 ztmelts = - tmut * s_i(ji,jj,jk,jl) + rtt !Melting temperature in K 311 312 ! heat content per unit volume311 312 ! heat content per unit volume 313 313 e_i(ji,jj,jk,jl) = zidto * rhoic * & 314 ( cpic * ( ztmelts - t_i(ji,jj,jk,jl) ) &315 + lfus * ( 1.0 - (ztmelts-rtt) / MIN((t_i(ji,jj,jk,jl)-rtt),-zeps) ) &316 - rcp * ( ztmelts - rtt ) &317 )318 319 ! Correct dimensions to avoid big values314 ( cpic * ( ztmelts - t_i(ji,jj,jk,jl) ) & 315 + lfus * ( 1.0 - (ztmelts-rtt) / MIN((t_i(ji,jj,jk,jl)-rtt),-zeps) ) & 316 - rcp * ( ztmelts - rtt ) & 317 ) 318 319 ! Correct dimensions to avoid big values 320 320 e_i(ji,jj,jk,jl) = e_i(ji,jj,jk,jl) / unit_fac 321 321 322 ! Mutliply by ice volume, and divide by number of layers to get heat content in 10^9 J322 ! Mutliply by ice volume, and divide by number of layers to get heat content in 10^9 J 323 323 e_i(ji,jj,jk,jl) = e_i(ji,jj,jk,jl) * & 324 325 324 area(ji,jj) * a_i(ji,jj,jl) * ht_i(ji,jj,jl) / & 325 nlay_i 326 326 END DO ! jk 327 327 … … 330 330 ELSE ! on fcor 331 331 332 !--- Southern hemisphere333 !----------------------------------------------------------------332 !--- Southern hemisphere 333 !---------------------------------------------------------------- 334 334 335 335 !----------------------- … … 346 346 347 347 ELSE ! several categories 348 349 !level ice348 349 !level ice 350 350 DO jl = ice_cat_bounds(1,1), ice_cat_bounds(1,2) !over thickness categories 351 351 352 352 zhis(1) = ( hi_max(jl-1) + hi_max(jl) ) / 2.0 353 353 a_i(ji,jj,jl) = zidto * MAX( zgfactors(1) * exp(-(zhis(1)-hgins_u) * & 354 354 (zhis(1)-hgins_u)/2.0) , epsi06 ) 355 355 ! new line square distribution volume conserving 356 356 a_i(ji,jj,jl) = zidto * ( zas * zhis(1) * zhis(1) + zbs * zhis(1) ) 357 357 ht_i(ji,jj,jl) = zidto * zhis(1) 358 358 v_i(ji,jj,jl) = ht_i(ji,jj,jl)*a_i(ji,jj,jl) 359 359 360 360 END DO ! jl 361 361 … … 363 363 364 364 !!! 365 ! retour a LIMA_MEC366 ! !ridged ice367 ! zdummy = hi_max(ice_cat_bounds(2,1)-1)368 ! hi_max(ice_cat_bounds(2,1)-1) = 0.0369 ! DO jl = ice_cat_bounds(2,1), ice_cat_bounds(2,2) !over thickness categories370 ! zhis(2) = ( hi_max(jl-1) + hi_max(jl) ) / 2.0371 ! a_i(ji,jj,jl) = zidto*MAX( zgfactors(2) * exp(-(zhis(2)-hgins_d)*(zhis(2)-hgins_d)/2.0), epsi06 )372 ! ht_i(ji,jj,jl) = zidto * zhis(2)373 ! v_i(ji,jj,jl) = ht_i(ji,jj,jl)*a_i(ji,jj,jl)374 ! END DO375 ! hi_max(ice_cat_bounds(2,1)-1) = zdummy376 377 ! !rafted ice378 ! jl = 6379 ! a_i(ji,jj,jl) = 0.0380 ! ht_i(ji,jj,jl) = 0.0381 ! v_i(ji,jj,jl) = 0.0382 ! END retour a LIMA_MEC365 ! retour a LIMA_MEC 366 ! !ridged ice 367 ! zdummy = hi_max(ice_cat_bounds(2,1)-1) 368 ! hi_max(ice_cat_bounds(2,1)-1) = 0.0 369 ! DO jl = ice_cat_bounds(2,1), ice_cat_bounds(2,2) !over thickness categories 370 ! zhis(2) = ( hi_max(jl-1) + hi_max(jl) ) / 2.0 371 ! a_i(ji,jj,jl) = zidto*MAX( zgfactors(2) * exp(-(zhis(2)-hgins_d)*(zhis(2)-hgins_d)/2.0), epsi06 ) 372 ! ht_i(ji,jj,jl) = zidto * zhis(2) 373 ! v_i(ji,jj,jl) = ht_i(ji,jj,jl)*a_i(ji,jj,jl) 374 ! END DO 375 ! hi_max(ice_cat_bounds(2,1)-1) = zdummy 376 377 ! !rafted ice 378 ! jl = 6 379 ! a_i(ji,jj,jl) = 0.0 380 ! ht_i(ji,jj,jl) = 0.0 381 ! v_i(ji,jj,jl) = 0.0 382 ! END retour a LIMA_MEC 383 383 !!! 384 384 … … 424 424 ! Multiply by volume, so that heat content in 10^9 Joules 425 425 e_s(ji,jj,jk,jl) = e_s(ji,jj,jk,jl) * area(ji,jj) * & 426 426 v_s(ji,jj,jl) / nlay_s 427 427 END DO 428 428 … … 435 435 s_i(ji,jj,jk,jl) = zidto * sins + ( 1.0 - zidto ) * 0.1 436 436 ztmelts = - tmut * s_i(ji,jj,jk,jl) + rtt !Melting temperature in K 437 438 ! heat content per unit volume437 438 ! heat content per unit volume 439 439 e_i(ji,jj,jk,jl) = zidto * rhoic * & 440 ( cpic * ( ztmelts - t_i(ji,jj,jk,jl) ) &441 + lfus * ( 1.0 - (ztmelts-rtt) / MIN((t_i(ji,jj,jk,jl)-rtt),-zeps) ) &442 - rcp * ( ztmelts - rtt ) &443 )444 445 ! Correct dimensions to avoid big values440 ( cpic * ( ztmelts - t_i(ji,jj,jk,jl) ) & 441 + lfus * ( 1.0 - (ztmelts-rtt) / MIN((t_i(ji,jj,jk,jl)-rtt),-zeps) ) & 442 - rcp * ( ztmelts - rtt ) & 443 ) 444 445 ! Correct dimensions to avoid big values 446 446 e_i(ji,jj,jk,jl) = e_i(ji,jj,jk,jl) / unit_fac 447 447 448 ! Mutliply by ice volume, and divide by number of layers to get heat content in 10^9 J448 ! Mutliply by ice volume, and divide by number of layers to get heat content in 10^9 J 449 449 e_i(ji,jj,jk,jl) = e_i(ji,jj,jk,jl) * & 450 451 450 area(ji,jj) * a_i(ji,jj,jl) * ht_i(ji,jj,jl) / & 451 nlay_i 452 452 END DO !jk 453 453 … … 549 549 !!----------------------------------------------------------------------------- 550 550 NAMELIST/namiceini/ ttest, hninn, hginn_u, aginn_u, hginn_d, aginn_d, hnins, & 551 551 hgins_u, agins_u, hgins_d, agins_d, sinn, sins 552 552 !!----------------------------------------------------------------------------- 553 553 … … 576 576 WRITE(numout,*) ' initial ice salinity in the south sins = ', sins 577 577 ENDIF 578 578 579 579 END SUBROUTINE lim_istate_init 580 580 -
trunk/NEMO/LIM_SRC_3/limitd_me.F90
r903 r921 32 32 USE prtctl ! Print control 33 33 USE lib_mpp 34 34 35 35 IMPLICIT NONE 36 36 PRIVATE … … 53 53 zone = 1.e0 54 54 55 !-----------------------------------------------------------------------56 ! Variables shared among ridging subroutines57 !-----------------------------------------------------------------------58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 !81 !-----------------------------------------------------------------------82 ! Ridging diagnostic arrays for history files83 !-----------------------------------------------------------------------84 !85 86 87 88 89 90 55 !----------------------------------------------------------------------- 56 ! Variables shared among ridging subroutines 57 !----------------------------------------------------------------------- 58 REAL(wp), DIMENSION (jpi,jpj) :: & 59 asum , & ! sum of total ice and open water area 60 aksum ! ratio of area removed to area ridged 61 62 REAL(wp), DIMENSION(jpi,jpj,0:jpl) :: & 63 athorn ! participation function; fraction of ridging/ 64 ! closing associated w/ category n 65 66 REAL(wp), DIMENSION(jpi,jpj,jpl) :: & 67 hrmin , & ! minimum ridge thickness 68 hrmax , & ! maximum ridge thickness 69 hraft , & ! thickness of rafted ice 70 krdg , & ! mean ridge thickness/thickness of ridging ice 71 aridge , & ! participating ice ridging 72 araft ! participating ice rafting 73 74 REAL(wp), PARAMETER :: & 75 krdgmin = 1.1, & ! min ridge thickness multiplier 76 kraft = 2.0 ! rafting multipliyer 77 78 REAL(wp) :: & 79 Cp 80 ! 81 !----------------------------------------------------------------------- 82 ! Ridging diagnostic arrays for history files 83 !----------------------------------------------------------------------- 84 ! 85 REAL (wp), DIMENSION(jpi,jpj) :: & 86 dardg1dt , & ! rate of fractional area loss by ridging ice (1/s) 87 dardg2dt , & ! rate of fractional area gain by new ridges (1/s) 88 dvirdgdt , & ! rate of ice volume ridged (m/s) 89 opening ! rate of opening due to divergence/shear (1/s) 90 91 91 92 92 !!---------------------------------------------------------------------- … … 97 97 CONTAINS 98 98 99 !!-----------------------------------------------------------------------------!100 !!-----------------------------------------------------------------------------!99 !!-----------------------------------------------------------------------------! 100 !!-----------------------------------------------------------------------------! 101 101 102 102 SUBROUTINE lim_itd_me ! (subroutine 1/6) 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 !!-- End of declarations204 !-----------------------------------------------------------------------------!103 !!---------------------------------------------------------------------! 104 !! *** ROUTINE lim_itd_me *** 105 !! ** Purpose : 106 !! This routine computes the mechanical redistribution 107 !! of ice thickness 108 !! 109 !! ** Method : a very simple method :-) 110 !! 111 !! ** Arguments : 112 !! kideb , kiut : Starting and ending points on which the 113 !! the computation is applied 114 !! 115 !! ** Inputs / Ouputs : (global commons) 116 !! 117 !! ** External : 118 !! 119 !! ** Steps : 120 !! 1) Thickness categories boundaries, ice / o.w. concentrations 121 !! Ridge preparation 122 !! 2) Dynamical inputs (closing rate, divu_adv, opning) 123 !! 3) Ridging iteration 124 !! 4) Ridging diagnostics 125 !! 5) Heat, salt and freshwater fluxes 126 !! 6) Compute increments of tate variables and come back to old values 127 !! 128 !! ** References : There are a lot of references and can be difficult / 129 !! boring to read 130 !! 131 !! Flato, G. M., and W. D. Hibler III, 1995: Ridging and strength 132 !! in modeling the thickness distribution of Arctic sea ice, 133 !! J. Geophys. Res., 100, 18,611-18,626. 134 !! 135 !! Hibler, W. D. III, 1980: Modeling a variable thickness sea ice 136 !! cover, Mon. Wea. Rev., 108, 1943-1973, 1980. 137 !! 138 !! Rothrock, D. A., 1975: The energetics of the plastic deformation of 139 !! pack ice by ridging, J. Geophys. Res., 80, 4514-4519. 140 !! 141 !! Thorndike, A. S., D. A. Rothrock, G. A. Maykut, and R. Colony, 142 !! 1975: The thickness distribution of sea ice, J. Geophys. Res., 143 !! 80, 4501-4513. 144 !! 145 !! Bitz et al., JGR 2001 146 !! 147 !! Amundrud and Melling, JGR 2005 148 !! 149 !! Babko et al., JGR 2002 150 !! 151 !! ** History : 152 !! This routine is based on CICE code 153 !! and authors William H. Lipscomb, 154 !! and Elizabeth C. Hunke, LANL 155 !! are gratefully acknowledged 156 !! 157 !! (02-2006) Martin Vancoppenolle, UCL-ASTR 158 !! 159 !!--------------------------------------------------------------------! 160 !! * Arguments 161 162 !! * Local variables 163 INTEGER :: ji, & ! spatial dummy loop index 164 jj, & ! spatial dummy loop index 165 jk, & ! vertical layering dummy loop index 166 jl, & ! ice category dummy loop index 167 niter, & ! iteration counter 168 nitermax = 20 ! max number of ridging iterations 169 170 REAL(wp) :: & ! constant values 171 zeps = 1.0e-10, & 172 epsi10 = 1.0e-10, & 173 epsi06 = 1.0e-6 174 175 REAL(wp), DIMENSION(jpi,jpj) :: & 176 closing_net, & ! net rate at which area is removed (1/s) 177 ! (ridging ice area - area of new ridges) / dt 178 divu_adv , & ! divu as implied by transport scheme (1/s) 179 opning , & ! rate of opening due to divergence/shear 180 closing_gross, & ! rate at which area removed, not counting 181 ! area of new ridges 182 msnow_mlt , & ! mass of snow added to ocean (kg m-2) 183 esnow_mlt ! energy needed to melt snow in ocean (J m-2) 184 185 REAL(wp) :: & 186 w1, & ! temporary variable 187 tmpfac, & ! factor by which opening/closing rates are cut 188 dti ! 1 / dt 189 190 LOGICAL :: & 191 asum_error ! flag for asum .ne. 1 192 193 INTEGER :: iterate_ridging ! if true, repeat the ridging 194 195 REAL(wp) :: & 196 big = 1.0e8 197 198 REAL (wp), DIMENSION(jpi,jpj) :: & ! 199 vt_i_init, vt_i_final ! ice volume summed over categories 200 201 CHARACTER (len = 15) :: fieldid 202 203 !!-- End of declarations 204 !-----------------------------------------------------------------------------! 205 205 206 206 IF( numit == nstart ) CALL lim_itd_me_init ! Initialization (first time-step only) … … 211 211 ENDIF 212 212 213 !-----------------------------------------------------------------------------!214 ! 1) Thickness categories boundaries, ice / o.w. concentrations, init_ons215 !-----------------------------------------------------------------------------!216 ! Set hi_max(ncat) to a big value to ensure that all ridged ice217 ! is thinner than hi_max(ncat).213 !-----------------------------------------------------------------------------! 214 ! 1) Thickness categories boundaries, ice / o.w. concentrations, init_ons 215 !-----------------------------------------------------------------------------! 216 ! Set hi_max(ncat) to a big value to ensure that all ridged ice 217 ! is thinner than hi_max(ncat). 218 218 219 219 hi_max(jpl) = 999.99 … … 225 225 IF ( con_i) CALL lim_column_sum (jpl, v_i, vt_i_init) 226 226 227 ! Initialize arrays.227 ! Initialize arrays. 228 228 DO jj = 1, jpj 229 229 DO ji = 1, jpi 230 230 231 msnow_mlt(ji,jj) = 0.0232 esnow_mlt(ji,jj) = 0.0233 dardg1dt(ji,jj) = 0.0234 dardg2dt(ji,jj) = 0.0235 dvirdgdt(ji,jj) = 0.0236 opening (ji,jj) = 0.0237 238 !-----------------------------------------------------------------------------!239 ! 2) Dynamical inputs (closing rate, divu_adv, opning)240 !-----------------------------------------------------------------------------!241 !242 ! 2.1 closing_net243 !-----------------244 ! Compute the net rate of closing due to convergence245 ! and shear, based on Flato and Hibler (1995).246 !247 ! The energy dissipation rate is equal to the net closing rate248 ! times the ice strength.249 !250 ! NOTE: The NET closing rate is equal to the rate that open water251 ! area is removed, plus the rate at which ice area is removed by252 ! ridging, minus the rate at which area is added in new ridges.253 ! The GROSS closing rate is equal to the first two terms (open254 ! water closing and thin ice ridging) without the third term255 ! (thick, newly ridged ice).256 257 closing_net(ji,jj) = &258 Cs*0.5*(Delta_i(ji,jj)-ABS(divu_i(ji,jj))) - MIN(divu_i(ji,jj),0.0)259 260 ! 2.2 divu_adv261 !--------------262 ! Compute divu_adv, the divergence rate given by the transport/263 ! advection scheme, which may not be equal to divu as computed264 ! from the velocity field.265 !266 ! If divu_adv < 0, make sure the closing rate is large enough267 ! to give asum = 1.0 after ridging.268 269 divu_adv(ji,jj) = (1.0-asum(ji,jj)) / rdt_ice ! asum found in ridgeprep270 271 IF (divu_adv(ji,jj) .LT. 0.0) &272 closing_net(ji,jj) = max(closing_net(ji,jj), -divu_adv(ji,jj))273 274 ! 2.3 opning275 !------------276 ! Compute the (non-negative) opening rate that will give277 ! asum = 1.0 after ridging.278 opning(ji,jj) = closing_net(ji,jj) + divu_adv(ji,jj)231 msnow_mlt(ji,jj) = 0.0 232 esnow_mlt(ji,jj) = 0.0 233 dardg1dt(ji,jj) = 0.0 234 dardg2dt(ji,jj) = 0.0 235 dvirdgdt(ji,jj) = 0.0 236 opening (ji,jj) = 0.0 237 238 !-----------------------------------------------------------------------------! 239 ! 2) Dynamical inputs (closing rate, divu_adv, opning) 240 !-----------------------------------------------------------------------------! 241 ! 242 ! 2.1 closing_net 243 !----------------- 244 ! Compute the net rate of closing due to convergence 245 ! and shear, based on Flato and Hibler (1995). 246 ! 247 ! The energy dissipation rate is equal to the net closing rate 248 ! times the ice strength. 249 ! 250 ! NOTE: The NET closing rate is equal to the rate that open water 251 ! area is removed, plus the rate at which ice area is removed by 252 ! ridging, minus the rate at which area is added in new ridges. 253 ! The GROSS closing rate is equal to the first two terms (open 254 ! water closing and thin ice ridging) without the third term 255 ! (thick, newly ridged ice). 256 257 closing_net(ji,jj) = & 258 Cs*0.5*(Delta_i(ji,jj)-ABS(divu_i(ji,jj))) - MIN(divu_i(ji,jj),0.0) 259 260 ! 2.2 divu_adv 261 !-------------- 262 ! Compute divu_adv, the divergence rate given by the transport/ 263 ! advection scheme, which may not be equal to divu as computed 264 ! from the velocity field. 265 ! 266 ! If divu_adv < 0, make sure the closing rate is large enough 267 ! to give asum = 1.0 after ridging. 268 269 divu_adv(ji,jj) = (1.0-asum(ji,jj)) / rdt_ice ! asum found in ridgeprep 270 271 IF (divu_adv(ji,jj) .LT. 0.0) & 272 closing_net(ji,jj) = max(closing_net(ji,jj), -divu_adv(ji,jj)) 273 274 ! 2.3 opning 275 !------------ 276 ! Compute the (non-negative) opening rate that will give 277 ! asum = 1.0 after ridging. 278 opning(ji,jj) = closing_net(ji,jj) + divu_adv(ji,jj) 279 279 280 280 END DO 281 281 END DO 282 282 283 !-----------------------------------------------------------------------------!284 ! 3) Ridging iteration285 !-----------------------------------------------------------------------------!283 !-----------------------------------------------------------------------------! 284 ! 3) Ridging iteration 285 !-----------------------------------------------------------------------------! 286 286 niter = 1 ! iteration counter 287 287 iterate_ridging = 1 … … 290 290 DO WHILE ( iterate_ridging > 0 .AND. niter < nitermax ) 291 291 292 DO jj = 1, jpj 293 DO ji = 1, jpi 294 295 ! 3.2 closing_gross 296 !-----------------------------------------------------------------------------! 297 ! Based on the ITD of ridging and ridged ice, convert the net 298 ! closing rate to a gross closing rate. 299 ! NOTE: 0 < aksum <= 1 300 closing_gross(ji,jj) = closing_net(ji,jj) / aksum(ji,jj) 301 302 ! correction to closing rate and opening if closing rate is excessive 303 !--------------------------------------------------------------------- 304 ! Reduce the closing rate if more than 100% of the open water 305 ! would be removed. Reduce the opening rate proportionately. 306 IF ( ato_i(ji,jj) .GT. epsi11 .AND. athorn(ji,jj,0) .GT. 0.0 ) THEN 307 w1 = athorn(ji,jj,0) * closing_gross(ji,jj) * rdt_ice 308 IF ( w1 .GT. ato_i(ji,jj)) THEN 309 tmpfac = ato_i(ji,jj) / w1 310 closing_gross(ji,jj) = closing_gross(ji,jj) * tmpfac 311 opning(ji,jj) = opning(ji,jj) * tmpfac 312 ENDIF !w1 313 ENDIF !at0i and athorn 314 315 END DO ! ji 316 END DO ! jj 317 318 ! correction to closing rate / opening if excessive ice removal 319 !--------------------------------------------------------------- 320 ! Reduce the closing rate if more than 100% of any ice category 321 ! would be removed. Reduce the opening rate proportionately. 322 323 DO jl = 1, jpl 324 DO jj = 1, jpj 325 DO ji = 1, jpi 326 IF ( a_i(ji,jj,jl) .GT. epsi11 .AND. athorn(ji,jj,jl) .GT. 0.0 ) THEN 327 w1 = athorn(ji,jj,jl) * closing_gross(ji,jj) * rdt_ice 328 IF ( w1 .GT. a_i(ji,jj,jl) ) THEN 329 tmpfac = a_i(ji,jj,jl) / w1 330 closing_gross(ji,jj) = closing_gross(ji,jj) * tmpfac 331 opning(ji,jj) = opning(ji,jj) * tmpfac 332 ENDIF 333 ENDIF 334 END DO !ji 335 END DO ! jj 336 END DO !jl 337 338 ! 3.3 Redistribute area, volume, and energy. 339 !-----------------------------------------------------------------------------! 340 341 CALL lim_itd_me_ridgeshift (opning, closing_gross, & 342 msnow_mlt, esnow_mlt) 343 344 ! 3.4 Compute total area of ice plus open water after ridging. 345 !-----------------------------------------------------------------------------! 346 347 CALL lim_itd_me_asumr 348 349 ! 3.5 Do we keep on iterating ??? 350 !-----------------------------------------------------------------------------! 351 ! Check whether asum = 1. If not (because the closing and opening 352 ! rates were reduced above), ridge again with new rates. 353 354 iterate_ridging = 0 355 356 DO jj = 1, jpj 357 DO ji = 1, jpi 358 IF (ABS(asum(ji,jj) - 1.0) .LT. epsi11) THEN 359 closing_net(ji,jj) = 0.0 360 opning(ji,jj) = 0.0 361 ELSE 362 iterate_ridging = 1 363 divu_adv(ji,jj) = (1.0 - asum(ji,jj)) / rdt_ice 364 closing_net(ji,jj) = MAX(0.0, -divu_adv(ji,jj)) 365 opning(ji,jj) = MAX(0.0, divu_adv(ji,jj)) 366 ENDIF 367 END DO 368 END DO 369 370 IF( lk_mpp ) CALL mpp_max(iterate_ridging) 371 372 ! Repeat if necessary. 373 ! NOTE: If strength smoothing is turned on, the ridging must be 374 ! iterated globally because of the boundary update in the 375 ! smoothing. 376 377 niter = niter + 1 378 379 IF (iterate_ridging == 1) THEN 380 IF (niter .GT. nitermax) THEN 381 WRITE(numout,*) ' ALERTE : non-converging ridging scheme ' 382 WRITE(numout,*) ' niter, iterate_ridging ', niter, iterate_ridging 383 ENDIF 384 CALL lim_itd_me_ridgeprep 385 ENDIF 386 387 END DO !! on the do while over iter 388 389 !-----------------------------------------------------------------------------! 390 ! 4) Ridging diagnostics 391 !-----------------------------------------------------------------------------! 392 ! Convert ridging rate diagnostics to correct units. 393 ! Update fresh water and heat fluxes due to snow melt. 394 395 dti = 1.0/rdt_ice 396 397 asum_error = .false. 398 292 399 DO jj = 1, jpj 293 400 DO ji = 1, jpi 294 401 295 ! 3.2 closing_gross 296 !-----------------------------------------------------------------------------! 297 ! Based on the ITD of ridging and ridged ice, convert the net 298 ! closing rate to a gross closing rate. 299 ! NOTE: 0 < aksum <= 1 300 closing_gross(ji,jj) = closing_net(ji,jj) / aksum(ji,jj) 301 302 ! correction to closing rate and opening if closing rate is excessive 303 !--------------------------------------------------------------------- 304 ! Reduce the closing rate if more than 100% of the open water 305 ! would be removed. Reduce the opening rate proportionately. 306 IF ( ato_i(ji,jj) .GT. epsi11 .AND. athorn(ji,jj,0) .GT. 0.0 ) THEN 307 w1 = athorn(ji,jj,0) * closing_gross(ji,jj) * rdt_ice 308 IF ( w1 .GT. ato_i(ji,jj)) THEN 309 tmpfac = ato_i(ji,jj) / w1 310 closing_gross(ji,jj) = closing_gross(ji,jj) * tmpfac 311 opning(ji,jj) = opning(ji,jj) * tmpfac 312 ENDIF !w1 313 ENDIF !at0i and athorn 314 315 END DO ! ji 316 END DO ! jj 317 318 ! correction to closing rate / opening if excessive ice removal 319 !--------------------------------------------------------------- 320 ! Reduce the closing rate if more than 100% of any ice category 321 ! would be removed. Reduce the opening rate proportionately. 322 323 DO jl = 1, jpl 324 DO jj = 1, jpj 325 DO ji = 1, jpi 326 IF ( a_i(ji,jj,jl) .GT. epsi11 .AND. athorn(ji,jj,jl) .GT. 0.0 ) THEN 327 w1 = athorn(ji,jj,jl) * closing_gross(ji,jj) * rdt_ice 328 IF ( w1 .GT. a_i(ji,jj,jl) ) THEN 329 tmpfac = a_i(ji,jj,jl) / w1 330 closing_gross(ji,jj) = closing_gross(ji,jj) * tmpfac 331 opning(ji,jj) = opning(ji,jj) * tmpfac 332 ENDIF 333 ENDIF 334 END DO !ji 335 END DO ! jj 336 END DO !jl 337 338 ! 3.3 Redistribute area, volume, and energy. 339 !-----------------------------------------------------------------------------! 340 341 CALL lim_itd_me_ridgeshift (opning, closing_gross, & 342 msnow_mlt, esnow_mlt) 343 344 ! 3.4 Compute total area of ice plus open water after ridging. 345 !-----------------------------------------------------------------------------! 346 347 CALL lim_itd_me_asumr 348 349 ! 3.5 Do we keep on iterating ??? 350 !-----------------------------------------------------------------------------! 351 ! Check whether asum = 1. If not (because the closing and opening 352 ! rates were reduced above), ridge again with new rates. 353 354 iterate_ridging = 0 355 356 DO jj = 1, jpj 357 DO ji = 1, jpi 358 IF (ABS(asum(ji,jj) - 1.0) .LT. epsi11) THEN 359 closing_net(ji,jj) = 0.0 360 opning(ji,jj) = 0.0 361 ELSE 362 iterate_ridging = 1 363 divu_adv(ji,jj) = (1.0 - asum(ji,jj)) / rdt_ice 364 closing_net(ji,jj) = MAX(0.0, -divu_adv(ji,jj)) 365 opning(ji,jj) = MAX(0.0, divu_adv(ji,jj)) 366 ENDIF 367 END DO 368 END DO 369 370 IF( lk_mpp ) CALL mpp_max(iterate_ridging) 371 372 ! Repeat if necessary. 373 ! NOTE: If strength smoothing is turned on, the ridging must be 374 ! iterated globally because of the boundary update in the 375 ! smoothing. 376 377 niter = niter + 1 378 379 IF (iterate_ridging == 1) THEN 380 IF (niter .GT. nitermax) THEN 381 WRITE(numout,*) ' ALERTE : non-converging ridging scheme ' 382 WRITE(numout,*) ' niter, iterate_ridging ', niter, iterate_ridging 383 ENDIF 384 CALL lim_itd_me_ridgeprep 385 ENDIF 386 387 END DO !! on the do while over iter 388 389 !-----------------------------------------------------------------------------! 390 ! 4) Ridging diagnostics 391 !-----------------------------------------------------------------------------! 392 ! Convert ridging rate diagnostics to correct units. 393 ! Update fresh water and heat fluxes due to snow melt. 394 395 dti = 1.0/rdt_ice 396 397 asum_error = .false. 398 399 DO jj = 1, jpj 400 DO ji = 1, jpi 401 402 IF (ABS(asum(ji,jj) - 1.0) .GT. epsi11) asum_error = .true. 403 404 dardg1dt(ji,jj) = dardg1dt(ji,jj) * dti 405 dardg2dt(ji,jj) = dardg2dt(ji,jj) * dti 406 dvirdgdt(ji,jj) = dvirdgdt(ji,jj) * dti 407 opening (ji,jj) = opening (ji,jj) * dti 408 409 !-----------------------------------------------------------------------------! 410 ! 5) Heat, salt and freshwater fluxes 411 !-----------------------------------------------------------------------------! 412 ! fresh water source for ocean 413 fmmec(ji,jj) = fmmec(ji,jj) + msnow_mlt(ji,jj)*dti 414 415 ! heat sink for ocean 416 fhmec(ji,jj) = fhmec(ji,jj) + esnow_mlt(ji,jj)*dti 402 IF (ABS(asum(ji,jj) - 1.0) .GT. epsi11) asum_error = .true. 403 404 dardg1dt(ji,jj) = dardg1dt(ji,jj) * dti 405 dardg2dt(ji,jj) = dardg2dt(ji,jj) * dti 406 dvirdgdt(ji,jj) = dvirdgdt(ji,jj) * dti 407 opening (ji,jj) = opening (ji,jj) * dti 408 409 !-----------------------------------------------------------------------------! 410 ! 5) Heat, salt and freshwater fluxes 411 !-----------------------------------------------------------------------------! 412 ! fresh water source for ocean 413 fmmec(ji,jj) = fmmec(ji,jj) + msnow_mlt(ji,jj)*dti 414 415 ! heat sink for ocean 416 fhmec(ji,jj) = fhmec(ji,jj) + esnow_mlt(ji,jj)*dti 417 417 418 418 END DO … … 444 444 ENDIF 445 445 446 !-----------------------------------------------------------------------------!447 ! 6) Updating state variables and trend terms448 !-----------------------------------------------------------------------------!446 !-----------------------------------------------------------------------------! 447 ! 6) Updating state variables and trend terms 448 !-----------------------------------------------------------------------------! 449 449 450 450 CALL lim_var_glo2eqv … … 465 465 d_smv_i_trp(:,:,:) = 0.0 466 466 IF ( ( num_sal .EQ. 2 ) .OR. ( num_sal .EQ. 4 ) ) & 467 d_smv_i_trp(:,:,:) = smv_i(:,:,:) - old_smv_i(:,:,:)467 d_smv_i_trp(:,:,:) = smv_i(:,:,:) - old_smv_i(:,:,:) 468 468 469 469 IF(ln_ctl) THEN ! Control print … … 513 513 oa_i(:,:,:) = old_oa_i(:,:,:) 514 514 IF ( ( num_sal .EQ. 2 ) .OR. ( num_sal .EQ. 4 ) ) & 515 smv_i(:,:,:) = old_smv_i(:,:,:)515 smv_i(:,:,:) = old_smv_i(:,:,:) 516 516 517 517 !----------------------------------------------------! … … 528 528 DO ji = 1, jpi 529 529 IF ( ( old_v_i(ji,jj,jl) .LT. epsi06 ) .AND. & 530 531 532 530 ( d_v_i_trp(ji,jj,jl) .GT. epsi06 ) ) THEN 531 old_e_i(ji,jj,jk,jl) = d_e_i_trp(ji,jj,jk,jl) 532 d_e_i_trp(ji,jj,jk,jl) = 0.0 533 533 ENDIF 534 534 END DO … … 541 541 DO ji = 1, jpi 542 542 IF ( ( old_v_i(ji,jj,jl) .LT. epsi06 ) .AND. & 543 544 545 546 547 548 549 550 551 552 553 554 555 old_smv_i(ji,jj,jl) = d_smv_i_trp(ji,jj,jl)556 543 ( d_v_i_trp(ji,jj,jl) .GT. epsi06 ) ) THEN 544 old_v_i(ji,jj,jl) = d_v_i_trp(ji,jj,jl) 545 d_v_i_trp(ji,jj,jl) = 0.0 546 old_a_i(ji,jj,jl) = d_a_i_trp(ji,jj,jl) 547 d_a_i_trp(ji,jj,jl) = 0.0 548 old_v_s(ji,jj,jl) = d_v_s_trp(ji,jj,jl) 549 d_v_s_trp(ji,jj,jl) = 0.0 550 old_e_s(ji,jj,1,jl) = d_e_s_trp(ji,jj,1,jl) 551 d_e_s_trp(ji,jj,1,jl) = 0.0 552 old_oa_i(ji,jj,jl) = d_oa_i_trp(ji,jj,jl) 553 d_oa_i_trp(ji,jj,jl) = 0.0 554 IF ( ( num_sal .EQ. 2 ) .OR. ( num_sal .EQ. 4 ) ) & 555 old_smv_i(ji,jj,jl) = d_smv_i_trp(ji,jj,jl) 556 d_smv_i_trp(ji,jj,jl) = 0.0 557 557 ENDIF 558 558 END DO 559 559 END DO 560 560 END DO 561 561 562 562 END SUBROUTINE lim_itd_me 563 563 564 !===============================================================================564 !=============================================================================== 565 565 566 566 SUBROUTINE lim_itd_me_icestrength (kstrngth) ! (subroutine 2/6) 567 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 568 !!---------------------------------------------------------------------- 569 !! *** ROUTINE lim_itd_me_icestrength *** 570 !! ** Purpose : 571 !! This routine computes ice strength used in dynamics routines 572 !! of ice thickness 573 !! 574 !! ** Method : 575 !! Compute the strength of the ice pack, defined as the energy (J m-2) 576 !! dissipated per unit area removed from the ice pack under compression, 577 !! and assumed proportional to the change in potential energy caused 578 !! by ridging. Note that only Hibler's formulation is stable and that 579 !! ice strength has to be smoothed 580 !! 581 !! ** Inputs / Ouputs : kstrngth (what kind of ice strength we are using) 582 !! 583 !! ** External : 584 !! 585 !! ** References : 586 !! 587 !!---------------------------------------------------------------------- 588 !! * Arguments 589 590 590 INTEGER, INTENT(in) :: & 591 591 kstrngth ! = 1 for Rothrock formulation, 0 for Hibler (1979) … … 606 606 zworka !: temporary array used here 607 607 608 !------------------------------------------------------------------------------!609 ! 1) Initialize610 !------------------------------------------------------------------------------!608 !------------------------------------------------------------------------------! 609 ! 1) Initialize 610 !------------------------------------------------------------------------------! 611 611 strength(:,:) = 0.0 612 612 613 !------------------------------------------------------------------------------!614 ! 2) Compute thickness distribution of ridging and ridged ice615 !------------------------------------------------------------------------------!613 !------------------------------------------------------------------------------! 614 ! 2) Compute thickness distribution of ridging and ridged ice 615 !------------------------------------------------------------------------------! 616 616 CALL lim_itd_me_ridgeprep 617 617 618 !------------------------------------------------------------------------------!619 ! 3) Rothrock(1975)'s method620 !------------------------------------------------------------------------------!618 !------------------------------------------------------------------------------! 619 ! 3) Rothrock(1975)'s method 620 !------------------------------------------------------------------------------! 621 621 IF (kstrngth == 1) then 622 622 … … 626 626 627 627 IF( ( a_i(ji,jj,jl) .GT. epsi11 ) & 628 .AND. ( athorn(ji,jj,jl) .GT. 0.0 ) ) THEN628 .AND. ( athorn(ji,jj,jl) .GT. 0.0 ) ) THEN 629 629 hi = v_i(ji,jj,jl) / a_i(ji,jj,jl) 630 630 !---------------------------- … … 632 632 !---------------------------- 633 633 strength(ji,jj) = strength(ji,jj) - athorn(ji,jj,jl) * & 634 hi * hi634 hi * hi 635 635 636 636 !-------------------------- … … 638 638 !-------------------------- 639 639 strength(ji,jj) = strength(ji,jj) + 2.0 * araft(ji,jj,jl) & 640 * hi * hi640 * hi * hi 641 641 642 642 !---------------------------- … … 644 644 !---------------------------- 645 645 strength(ji,jj) = strength(ji,jj) & 646 + aridge(ji,jj,jl)/krdg(ji,jj,jl) &647 * 1.0/3.0 * (hrmax(ji,jj,jl)**3 - hrmin(ji,jj,jl)**3) &648 / (hrmax(ji,jj,jl)-hrmin(ji,jj,jl))646 + aridge(ji,jj,jl)/krdg(ji,jj,jl) & 647 * 1.0/3.0 * (hrmax(ji,jj,jl)**3 - hrmin(ji,jj,jl)**3) & 648 / (hrmax(ji,jj,jl)-hrmin(ji,jj,jl)) 649 649 ENDIF ! aicen > epsi11 650 650 … … 656 656 DO ji = 1, jpi 657 657 strength(ji,jj) = Cf * Cp * strength(ji,jj) / aksum(ji,jj) 658 659 660 658 ! Cp = (g/2)*(rhow-rhoi)*(rhoi/rhow) 659 ! Cf accounts for frictional dissipation 660 661 661 END DO ! j 662 662 END DO ! i … … 664 664 ksmooth = 1 665 665 666 !------------------------------------------------------------------------------!667 ! 4) Hibler (1979)' method668 !------------------------------------------------------------------------------!666 !------------------------------------------------------------------------------! 667 ! 4) Hibler (1979)' method 668 !------------------------------------------------------------------------------! 669 669 ELSE ! kstrngth ne 1: Hibler (1979) form 670 670 … … 679 679 ENDIF ! kstrngth 680 680 681 !682 !------------------------------------------------------------------------------!683 ! 5) Impact of brine volume684 !------------------------------------------------------------------------------!685 ! CAN BE REMOVED686 !681 ! 682 !------------------------------------------------------------------------------! 683 ! 5) Impact of brine volume 684 !------------------------------------------------------------------------------! 685 ! CAN BE REMOVED 686 ! 687 687 IF ( brinstren_swi .EQ. 1 ) THEN 688 688 … … 700 700 ENDIF 701 701 702 !703 !------------------------------------------------------------------------------!704 ! 6) Smoothing ice strength705 !------------------------------------------------------------------------------!706 !702 ! 703 !------------------------------------------------------------------------------! 704 ! 6) Smoothing ice strength 705 !------------------------------------------------------------------------------! 706 ! 707 707 !------------------- 708 708 ! Spatial smoothing … … 715 715 DO ji = 2, jpi - 1 716 716 IF ( ( asum(ji,jj) - ato_i(ji,jj) ) .GT. epsi11) THEN ! ice is 717 717 ! present 718 718 zworka(ji,jj) = 4.0 * strength(ji,jj) & 719 720 721 722 719 + strength(ji-1,jj) * tms(ji-1,jj) & 720 + strength(ji+1,jj) * tms(ji+1,jj) & 721 + strength(ji,jj-1) * tms(ji,jj-1) & 722 + strength(ji,jj+1) * tms(ji,jj+1) 723 723 724 724 zw1 = 4.0 + tms(ji-1,jj) + tms(ji+1,jj) & 725 725 + tms(ji,jj-1) + tms(ji,jj+1) 726 726 zworka(ji,jj) = zworka(ji,jj) / zw1 727 727 ELSE … … 749 749 750 750 IF ( ksmooth .EQ. 2 ) THEN 751 752 751 752 753 753 CALL lbc_lnk( strength, 'T', 1. ) 754 754 755 755 DO jj = 1, jpj - 1 756 756 DO ji = 1, jpi - 1 757 757 IF ( ( asum(ji,jj) - ato_i(ji,jj) ) .GT. epsi11) THEN ! ice is 758 758 ! present 759 759 numts_rm = 1 ! number of time steps for the running mean 760 760 IF ( strp1(ji,jj) .GT. 0.0 ) numts_rm = numts_rm + 1 761 761 IF ( strp2(ji,jj) .GT. 0.0 ) numts_rm = numts_rm + 1 762 762 zp = ( strength(ji,jj) + strp1(ji,jj) + strp2(ji,jj) ) / & 763 763 numts_rm 764 764 strp2(ji,jj) = strp1(ji,jj) 765 765 strp1(ji,jj) = strength(ji,jj) … … 771 771 772 772 ENDIF ! ksmooth 773 773 774 774 ! Boundary conditions 775 775 CALL lbc_lnk( strength, 'T', 1. ) 776 776 777 778 779 !===============================================================================780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 777 END SUBROUTINE lim_itd_me_icestrength 778 779 !=============================================================================== 780 781 SUBROUTINE lim_itd_me_ridgeprep !(subroutine 3/6) 782 783 !!---------------------------------------------------------------------! 784 !! *** ROUTINE lim_itd_me_ridgeprep *** 785 !! ** Purpose : 786 !! preparation for ridging and strength calculations 787 !! 788 !! ** Method : 789 !! Compute the thickness distribution of the ice and open water 790 !! participating in ridging and of the resulting ridges. 791 !! 792 !! ** Arguments : 793 !! 794 !! ** External : 795 !! 796 !!---------------------------------------------------------------------! 797 !! * Arguments 798 799 799 INTEGER :: & 800 800 ji,jj, & ! horizontal indices … … 820 820 epsi06 = 1.0e-6 821 821 822 !------------------------------------------------------------------------------!822 !------------------------------------------------------------------------------! 823 823 824 824 Gstari = 1.0/Gstar … … 833 833 krdg (:,:,:) = 1.0 834 834 835 ! ! Zero out categories with very small areas835 ! ! Zero out categories with very small areas 836 836 CALL lim_itd_me_zapsmall 837 837 838 !------------------------------------------------------------------------------!839 ! 1) Participation function840 !------------------------------------------------------------------------------!838 !------------------------------------------------------------------------------! 839 ! 1) Participation function 840 !------------------------------------------------------------------------------! 841 841 842 842 ! Compute total area of ice plus open water. … … 886 886 DO ji = 1, jpi 887 887 Gsum(ji,jj,jl) = Gsum(ji,jj,jl) * zworka(ji,jj) 888 END DO 888 END DO 889 889 END DO 890 890 END DO 891 891 892 ! 1.3 Compute participation function a(h) = b(h).g(h) (athorn)893 !--------------------------------------------------------------------------------------------------894 ! Compute the participation function athorn; this is analogous to895 ! a(h) = b(h)g(h) as defined in Thorndike et al. (1975).896 ! area lost from category n due to ridging/closing897 ! athorn(n) = total area lost due to ridging/closing898 ! assume b(h) = (2/Gstar) * (1 - G(h)/Gstar).899 !900 ! The expressions for athorn are found by integrating b(h)g(h) between901 ! the category boundaries.902 !-----------------------------------------------------------------892 ! 1.3 Compute participation function a(h) = b(h).g(h) (athorn) 893 !-------------------------------------------------------------------------------------------------- 894 ! Compute the participation function athorn; this is analogous to 895 ! a(h) = b(h)g(h) as defined in Thorndike et al. (1975). 896 ! area lost from category n due to ridging/closing 897 ! athorn(n) = total area lost due to ridging/closing 898 ! assume b(h) = (2/Gstar) * (1 - G(h)/Gstar). 899 ! 900 ! The expressions for athorn are found by integrating b(h)g(h) between 901 ! the category boundaries. 902 !----------------------------------------------------------------- 903 903 904 904 krdg_index = 1 … … 906 906 IF ( krdg_index .EQ. 0 ) THEN 907 907 908 !--- Linear formulation (Thorndike et al., 1975)909 DO jl = 0, ice_cat_bounds(1,2) ! only undeformed ice participates910 DO jj = 1, jpj911 DO ji = 1, jpi912 IF (Gsum(ji,jj,jl) < Gstar) THEN913 athorn(ji,jj,jl) = Gstari * (Gsum(ji,jj,jl)-Gsum(ji,jj,jl-1)) * &914 (2.0 - (Gsum(ji,jj,jl-1)+Gsum(ji,jj,jl))*Gstari)915 ELSEIF (Gsum(ji,jj,jl-1) < Gstar) THEN916 athorn(ji,jj,jl) = Gstari * (Gstar-Gsum(ji,jj,jl-1)) * &917 (2.0 - (Gsum(ji,jj,jl-1)+Gstar)*Gstari)918 ELSE919 athorn(ji,jj,jl) = 0.0920 ENDIF921 END DO ! ji922 END DO ! jj923 END DO ! jl908 !--- Linear formulation (Thorndike et al., 1975) 909 DO jl = 0, ice_cat_bounds(1,2) ! only undeformed ice participates 910 DO jj = 1, jpj 911 DO ji = 1, jpi 912 IF (Gsum(ji,jj,jl) < Gstar) THEN 913 athorn(ji,jj,jl) = Gstari * (Gsum(ji,jj,jl)-Gsum(ji,jj,jl-1)) * & 914 (2.0 - (Gsum(ji,jj,jl-1)+Gsum(ji,jj,jl))*Gstari) 915 ELSEIF (Gsum(ji,jj,jl-1) < Gstar) THEN 916 athorn(ji,jj,jl) = Gstari * (Gstar-Gsum(ji,jj,jl-1)) * & 917 (2.0 - (Gsum(ji,jj,jl-1)+Gstar)*Gstari) 918 ELSE 919 athorn(ji,jj,jl) = 0.0 920 ENDIF 921 END DO ! ji 922 END DO ! jj 923 END DO ! jl 924 924 925 925 ELSE ! krdg_index = 1 926 927 !--- Exponential, more stable formulation (Lipscomb et al, 2007)928 ! precompute exponential terms using Gsum as a work array929 zdummy = 1.0 / (1.0-EXP(-astari))930 931 DO jl = -1, jpl932 DO jj = 1, jpj933 DO ji = 1, jpi934 Gsum(ji,jj,jl) = EXP(-Gsum(ji,jj,jl)*astari)*zdummy935 END DO !ji936 END DO !jj937 END DO !jl938 939 ! compute athorn940 DO jl = 0, ice_cat_bounds(1,2)941 DO jj = 1, jpj942 DO ji = 1, jpi943 athorn(ji,jj,jl) = Gsum(ji,jj,jl-1) - Gsum(ji,jj,jl)944 END DO !ji945 END DO ! jj946 END DO !jl926 927 !--- Exponential, more stable formulation (Lipscomb et al, 2007) 928 ! precompute exponential terms using Gsum as a work array 929 zdummy = 1.0 / (1.0-EXP(-astari)) 930 931 DO jl = -1, jpl 932 DO jj = 1, jpj 933 DO ji = 1, jpi 934 Gsum(ji,jj,jl) = EXP(-Gsum(ji,jj,jl)*astari)*zdummy 935 END DO !ji 936 END DO !jj 937 END DO !jl 938 939 ! compute athorn 940 DO jl = 0, ice_cat_bounds(1,2) 941 DO jj = 1, jpj 942 DO ji = 1, jpi 943 athorn(ji,jj,jl) = Gsum(ji,jj,jl-1) - Gsum(ji,jj,jl) 944 END DO !ji 945 END DO ! jj 946 END DO !jl 947 947 948 948 ENDIF ! krdg_index … … 956 956 IF ( athorn(ji,jj,jl) .GT. 0.0 ) THEN 957 957 aridge(ji,jj,jl) = ( TANH ( Craft * ( ht_i(ji,jj,jl) - & 958 959 958 hparmeter ) ) + 1.0 ) / 2.0 * & 959 athorn(ji,jj,jl) 960 960 araft (ji,jj,jl) = ( TANH ( - Craft * ( ht_i(ji,jj,jl) - & 961 962 961 hparmeter ) ) + 1.0 ) / 2.0 * & 962 athorn(ji,jj,jl) 963 963 IF ( araft(ji,jj,jl) .LT. epsi06 ) araft(ji,jj,jl) = 0.0 964 964 aridge(ji,jj,jl) = MAX( athorn(ji,jj,jl) - araft(ji,jj,jl), 0.0) … … 982 982 IF ( raftswi .EQ. 1 ) THEN 983 983 984 IF( MAXVAL(aridge + araft - athorn(:,:,1:jpl)) .GT. epsi11 ) THEN 985 DO jl = 1, jpl 986 DO jj = 1, jpj 987 DO ji = 1, jpi 988 IF ( aridge(ji,jj,jl) + araft(ji,jj,jl) - athorn(ji,jj,jl) .GT. & 989 epsi11 ) THEN 990 WRITE(numout,*) ' ALERTE 96 : wrong participation function ... ' 991 WRITE(numout,*) ' ji, jj, jl : ', ji, jj, jl 992 WRITE(numout,*) ' lat, lon : ', gphit(ji,jj), glamt(ji,jj) 993 WRITE(numout,*) ' aridge : ', aridge(ji,jj,1:jpl) 994 WRITE(numout,*) ' araft : ', araft(ji,jj,1:jpl) 995 WRITE(numout,*) ' athorn : ', athorn(ji,jj,1:jpl) 996 ENDIF 984 IF( MAXVAL(aridge + araft - athorn(:,:,1:jpl)) .GT. epsi11 ) THEN 985 DO jl = 1, jpl 986 DO jj = 1, jpj 987 DO ji = 1, jpi 988 IF ( aridge(ji,jj,jl) + araft(ji,jj,jl) - athorn(ji,jj,jl) .GT. & 989 epsi11 ) THEN 990 WRITE(numout,*) ' ALERTE 96 : wrong participation function ... ' 991 WRITE(numout,*) ' ji, jj, jl : ', ji, jj, jl 992 WRITE(numout,*) ' lat, lon : ', gphit(ji,jj), glamt(ji,jj) 993 WRITE(numout,*) ' aridge : ', aridge(ji,jj,1:jpl) 994 WRITE(numout,*) ' araft : ', araft(ji,jj,1:jpl) 995 WRITE(numout,*) ' athorn : ', athorn(ji,jj,1:jpl) 996 ENDIF 997 END DO 997 998 END DO 998 999 END DO 999 END DO 1000 ENDIF 1001 1000 1002 ENDIF 1001 1003 1002 ENDIF 1003 1004 !----------------------------------------------------------------- 1005 ! 2) Transfer function 1006 !----------------------------------------------------------------- 1007 ! Compute max and min ridged ice thickness for each ridging category. 1008 ! Assume ridged ice is uniformly distributed between hrmin and hrmax. 1009 ! 1010 ! This parameterization is a modified version of Hibler (1980). 1011 ! The mean ridging thickness, hrmean, is proportional to hi^(0.5) 1012 ! and for very thick ridging ice must be >= krdgmin*hi 1013 ! 1014 ! The minimum ridging thickness, hrmin, is equal to 2*hi 1015 ! (i.e., rafting) and for very thick ridging ice is 1016 ! constrained by hrmin <= (hrmean + hi)/2. 1017 ! 1018 ! The maximum ridging thickness, hrmax, is determined by 1019 ! hrmean and hrmin. 1020 ! 1021 ! These modifications have the effect of reducing the ice strength 1022 ! (relative to the Hibler formulation) when very thick ice is 1023 ! ridging. 1024 ! 1025 ! aksum = net area removed/ total area removed 1026 ! where total area removed = area of ice that ridges 1027 ! net area removed = total area removed - area of new ridges 1028 !----------------------------------------------------------------- 1004 !----------------------------------------------------------------- 1005 ! 2) Transfer function 1006 !----------------------------------------------------------------- 1007 ! Compute max and min ridged ice thickness for each ridging category. 1008 ! Assume ridged ice is uniformly distributed between hrmin and hrmax. 1009 ! 1010 ! This parameterization is a modified version of Hibler (1980). 1011 ! The mean ridging thickness, hrmean, is proportional to hi^(0.5) 1012 ! and for very thick ridging ice must be >= krdgmin*hi 1013 ! 1014 ! The minimum ridging thickness, hrmin, is equal to 2*hi 1015 ! (i.e., rafting) and for very thick ridging ice is 1016 ! constrained by hrmin <= (hrmean + hi)/2. 1017 ! 1018 ! The maximum ridging thickness, hrmax, is determined by 1019 ! hrmean and hrmin. 1020 ! 1021 ! These modifications have the effect of reducing the ice strength 1022 ! (relative to the Hibler formulation) when very thick ice is 1023 ! ridging. 1024 ! 1025 ! aksum = net area removed/ total area removed 1026 ! where total area removed = area of ice that ridges 1027 ! net area removed = total area removed - area of new ridges 1028 !----------------------------------------------------------------- 1029 1029 1030 1030 ! Transfer function … … 1062 1062 DO ji = 1, jpi 1063 1063 aksum(ji,jj) = aksum(ji,jj) & 1064 1065 1064 + aridge(ji,jj,jl) * (1.0 - 1.0/krdg(ji,jj,jl)) & 1065 + araft (ji,jj,jl) * (1.0 - 1.0/kraft) 1066 1066 END DO 1067 1067 END DO 1068 1068 END DO 1069 1069 1070 1071 1072 !===============================================================================1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1070 END SUBROUTINE lim_itd_me_ridgeprep 1071 1072 !=============================================================================== 1073 1074 SUBROUTINE lim_itd_me_ridgeshift(opning, closing_gross, & 1075 msnow_mlt, esnow_mlt) ! (subroutine 4/6) 1076 1077 !!----------------------------------------------------------------------------- 1078 !! *** ROUTINE lim_itd_me_icestrength *** 1079 !! ** Purpose : 1080 !! This routine shift ridging ice among thickness categories 1081 !! of ice thickness 1082 !! 1083 !! ** Method : 1084 !! Remove area, volume, and energy from each ridging category 1085 !! and add to thicker ice categories. 1086 !! 1087 !! ** Arguments : 1088 !! 1089 !! ** Inputs / Ouputs : 1090 !! 1091 !! ** External : 1092 !! 1093 1093 1094 1094 REAL (wp), DIMENSION(jpi,jpj), INTENT(IN) :: & 1095 1095 opning, & ! rate of opening due to divergence/shear 1096 1096 closing_gross ! rate at which area removed, not counting 1097 1097 ! area of new ridges 1098 1098 1099 1099 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: & … … 1176 1176 LOGICAL, PARAMETER :: & 1177 1177 l_conservation_check = .true. ! if true, check conservation 1178 1178 ! (useful for debugging) 1179 1179 LOGICAL :: & 1180 1180 neg_ato_i , & ! flag for ato_i(i,j) < -puny … … 1187 1187 zindb ! switch for the presence of ridge poros or not 1188 1188 1189 !----------------------------------------------------------------------------1189 !---------------------------------------------------------------------------- 1190 1190 1191 1191 ! Conservation check … … 1202 1202 epsi10 = 1.0d-10 1203 1203 1204 !-------------------------------------------------------------------------------1205 ! 1) Compute change in open water area due to closing and opening.1206 !-------------------------------------------------------------------------------1204 !------------------------------------------------------------------------------- 1205 ! 1) Compute change in open water area due to closing and opening. 1206 !------------------------------------------------------------------------------- 1207 1207 1208 1208 neg_ato_i = .false. … … 1211 1211 DO ji = 1, jpi 1212 1212 ato_i(ji,jj) = ato_i(ji,jj) & 1213 1214 1213 - athorn(ji,jj,0)*closing_gross(ji,jj)*rdt_ice & 1214 + opning(ji,jj)*rdt_ice 1215 1215 IF (ato_i(ji,jj) .LT. -epsi11) THEN 1216 1216 neg_ato_i = .true. … … 1234 1234 ENDIF ! neg_ato_i 1235 1235 1236 !-----------------------------------------------------------------1237 ! 2) Save initial state variables1238 !-----------------------------------------------------------------1236 !----------------------------------------------------------------- 1237 ! 2) Save initial state variables 1238 !----------------------------------------------------------------- 1239 1239 1240 1240 DO jl = 1, jpl … … 1252 1252 1253 1253 esnon_init(:,:,:) = e_s(:,:,1,:) 1254 1254 1255 1255 DO jl = 1, jpl 1256 1256 DO jk = 1, nlay_i … … 1263 1263 END DO !jl 1264 1264 1265 !1266 !-----------------------------------------------------------------1267 ! 3) Pump everything from ice which is being ridged / rafted1268 !-----------------------------------------------------------------1269 ! Compute the area, volume, and energy of ice ridging in each1270 ! category, along with the area of the resulting ridge.1265 ! 1266 !----------------------------------------------------------------- 1267 ! 3) Pump everything from ice which is being ridged / rafted 1268 !----------------------------------------------------------------- 1269 ! Compute the area, volume, and energy of ice ridging in each 1270 ! category, along with the area of the resulting ridge. 1271 1271 1272 1272 DO jl1 = 1, jpl !jl1 describes the ridging category 1273 1273 1274 !------------------------------------------------1275 ! 3.1) Identify grid cells with nonzero ridging1276 !------------------------------------------------1274 !------------------------------------------------ 1275 ! 3.1) Identify grid cells with nonzero ridging 1276 !------------------------------------------------ 1277 1277 1278 1278 icells = 0 … … 1280 1280 DO ji = 1, jpi 1281 1281 IF (aicen_init(ji,jj,jl1) .GT. epsi11 .AND. athorn(ji,jj,jl1) .GT. 0.0 & 1282 1282 .AND. closing_gross(ji,jj) > 0.0) THEN 1283 1283 icells = icells + 1 1284 1284 indxi(icells) = ji … … 1296 1296 jj = indxj(ij) 1297 1297 1298 !--------------------------------------------------------------------1299 ! 3.2) Compute area of ridging ice (ardg1) and of new ridge (ardg2)1300 !--------------------------------------------------------------------1298 !-------------------------------------------------------------------- 1299 ! 3.2) Compute area of ridging ice (ardg1) and of new ridge (ardg2) 1300 !-------------------------------------------------------------------- 1301 1301 1302 1302 ardg1(ji,jj) = aridge(ji,jj,jl1)*closing_gross(ji,jj)*rdt_ice … … 1310 1310 oirft2(ji,jj)= oirft1(ji,jj) / kraft 1311 1311 1312 !---------------------------------------------------------------1313 ! 3.3) Compute ridging /rafting fractions, make sure afrac <=11314 !---------------------------------------------------------------1312 !--------------------------------------------------------------- 1313 ! 3.3) Compute ridging /rafting fractions, make sure afrac <=1 1314 !--------------------------------------------------------------- 1315 1315 1316 1316 afrac(ji,jj) = ardg1(ji,jj) / aicen_init(ji,jj,jl1) !ridging … … 1328 1328 ENDIF 1329 1329 1330 !--------------------------------------------------------------------------1331 ! 3.4) Subtract area, volume, and energy from ridging1332 ! / rafting category n1.1333 !--------------------------------------------------------------------------1330 !-------------------------------------------------------------------------- 1331 ! 3.4) Subtract area, volume, and energy from ridging 1332 ! / rafting category n1. 1333 !-------------------------------------------------------------------------- 1334 1334 vrdg1(ji,jj) = vicen_init(ji,jj,jl1) * afrac(ji,jj) / & 1335 1335 ( 1.0 + ridge_por ) 1336 1336 vrdg2(ji,jj) = vrdg1(ji,jj) * ( 1. + ridge_por ) 1337 1337 vsw (ji,jj) = vrdg1(ji,jj) * ridge_por … … 1340 1340 esrdg(ji,jj) = esnon_init(ji,jj,jl1) * afrac(ji,jj) 1341 1341 srdg1(ji,jj) = smv_i_init(ji,jj,jl1) * afrac(ji,jj) / & 1342 1342 ( 1. + ridge_por ) 1343 1343 srdg2(ji,jj) = smv_i_init(ji,jj,jl1) * afrac(ji,jj) 1344 1344 … … 1357 1357 smv_i(ji,jj,jl1) = smv_i(ji,jj,jl1) - srdg1(ji,jj) - smrft(ji,jj) 1358 1358 1359 !-----------------------------------------------------------------1360 ! 3.5) Compute properties of new ridges1361 !-----------------------------------------------------------------1359 !----------------------------------------------------------------- 1360 ! 3.5) Compute properties of new ridges 1361 !----------------------------------------------------------------- 1362 1362 !------------- 1363 1363 ! Salinity … … 1373 1373 ! salt flux due to ridge creation 1374 1374 fsalt_rpo(ji,jj) = fsalt_rpo(ji,jj) + & 1375 MAX ( zdummy - srdg2(ji,jj) , 0.0 ) &1376 * rhoic / rdt_ice1375 MAX ( zdummy - srdg2(ji,jj) , 0.0 ) & 1376 * rhoic / rdt_ice 1377 1377 1378 1378 ! sal times volume for new ridges 1379 1379 srdg2(ji,jj) = sm_newridge * vrdg2(ji,jj) 1380 1380 1381 !------------------------------------1382 ! 3.6 Increment ridging diagnostics1383 !------------------------------------1384 1385 ! jl1 looping 1-jpl1386 ! ij looping 1-icells1381 !------------------------------------ 1382 ! 3.6 Increment ridging diagnostics 1383 !------------------------------------ 1384 1385 ! jl1 looping 1-jpl 1386 ! ij looping 1-icells 1387 1387 1388 1388 dardg1dt(ji,jj) = dardg1dt(ji,jj) + ardg1(ji,jj) + arft1(ji,jj) … … 1393 1393 IF (con_i) vice_init(ji,jj) = vice_init(ji,jj) + vrdg2(ji,jj) - vrdg1(ji,jj) 1394 1394 1395 !------------------------------------------1396 ! 3.7 Put the snow somewhere in the ocean1397 !------------------------------------------1398 1399 ! Place part of the snow lost by ridging into the ocean.1400 ! Note that esnow_mlt < 0; the ocean must cool to melt snow.1401 ! If the ocean temp = Tf already, new ice must grow.1402 ! During the next time step, thermo_rates will determine whether1403 ! the ocean cools or new ice grows.1404 ! jl1 looping 1-jpl1405 ! ij looping 1-icells1406 1395 !------------------------------------------ 1396 ! 3.7 Put the snow somewhere in the ocean 1397 !------------------------------------------ 1398 1399 ! Place part of the snow lost by ridging into the ocean. 1400 ! Note that esnow_mlt < 0; the ocean must cool to melt snow. 1401 ! If the ocean temp = Tf already, new ice must grow. 1402 ! During the next time step, thermo_rates will determine whether 1403 ! the ocean cools or new ice grows. 1404 ! jl1 looping 1-jpl 1405 ! ij looping 1-icells 1406 1407 1407 msnow_mlt(ji,jj) = msnow_mlt(ji,jj) & 1408 1409 !rafting included1410 1408 + rhosn*vsrdg(ji,jj)*(1.0-fsnowrdg) & 1409 !rafting included 1410 + rhosn*vsrft(ji,jj)*(1.0-fsnowrft) 1411 1411 1412 1412 esnow_mlt(ji,jj) = esnow_mlt(ji,jj) & 1413 1414 !rafting included1415 1416 1417 !-----------------------------------------------------------------1418 ! 3.8 Compute quantities used to apportion ice among categories1419 ! in the n2 loop below1420 !-----------------------------------------------------------------1421 1422 ! jl1 looping 1-jpl1423 ! ij looping 1-icells1413 + esrdg(ji,jj)*(1.0-fsnowrdg) & 1414 !rafting included 1415 + esrft(ji,jj)*(1.0-fsnowrft) 1416 1417 !----------------------------------------------------------------- 1418 ! 3.8 Compute quantities used to apportion ice among categories 1419 ! in the n2 loop below 1420 !----------------------------------------------------------------- 1421 1422 ! jl1 looping 1-jpl 1423 ! ij looping 1-icells 1424 1424 1425 1425 dhr(ji,jj) = hrmax(ji,jj,jl1) - hrmin(ji,jj,jl1) 1426 1426 dhr2(ji,jj) = hrmax(ji,jj,jl1) * hrmax(ji,jj,jl1) & 1427 1427 - hrmin(ji,jj,jl1) * hrmin(ji,jj,jl1) 1428 1428 1429 1429 1430 1430 END DO ! ij 1431 1431 1432 !--------------------------------------------------------------------1433 ! 3.9 Compute ridging ice enthalpy, remove it from ridging ice and1434 ! compute ridged ice enthalpy1435 !--------------------------------------------------------------------1432 !-------------------------------------------------------------------- 1433 ! 3.9 Compute ridging ice enthalpy, remove it from ridging ice and 1434 ! compute ridged ice enthalpy 1435 !-------------------------------------------------------------------- 1436 1436 DO jk = 1, nlay_i 1437 1437 !CDIR NODEP 1438 1438 DO ij = 1, icells 1439 ji = indxi(ij)1440 jj = indxj(ij)1441 ! heat content of ridged ice1442 erdg1(ji,jj,jk) = eicen_init(ji,jj,jk,jl1) * afrac(ji,jj) / &1443 1444 eirft(ji,jj,jk) = eicen_init(ji,jj,jk,jl1) * afrft(ji,jj)1445 e_i(ji,jj,jk,jl1) = e_i(ji,jj,jk,jl1) &1446 1447 1448 ! sea water heat content1449 ztmelts = - tmut * sss_m(ji,jj) + rtt1450 ! heat content per unit volume1451 zdummy0 = - rcp * ( sst_m(ji,jj) + rt0 - rtt ) * vsw(ji,jj)1452 1453 ! corrected sea water salinity1454 zindb = MAX( 0.0, SIGN( 1.0, vsw(ji,jj) - zeps ) )1455 zdummy = zindb * ( srdg1(ji,jj) - srdg2(ji,jj) ) / &1456 1457 1458 ztmelts = - tmut * zdummy + rtt1459 ersw(ji,jj,jk) = - rcp * ( ztmelts - rtt ) * vsw(ji,jj)1460 1461 ! heat flux1462 fheat_rpo(ji,jj) = fheat_rpo(ji,jj) + ( ersw(ji,jj,jk) - zdummy0 ) / &1463 1464 1465 ! Correct dimensions to avoid big values1466 ersw(ji,jj,jk) = ersw(ji,jj,jk) / 1.0d+091467 1468 ! Mutliply by ice volume, and divide by number of layers to get heat content in 10^9 J1469 ersw(ji,jj,jk) = ersw(ji,jj,jk) * &1470 1471 1472 1473 erdg2(ji,jj,jk) = erdg1(ji,jj,jk) + ersw(ji,jj,jk)1439 ji = indxi(ij) 1440 jj = indxj(ij) 1441 ! heat content of ridged ice 1442 erdg1(ji,jj,jk) = eicen_init(ji,jj,jk,jl1) * afrac(ji,jj) / & 1443 ( 1.0 + ridge_por ) 1444 eirft(ji,jj,jk) = eicen_init(ji,jj,jk,jl1) * afrft(ji,jj) 1445 e_i(ji,jj,jk,jl1) = e_i(ji,jj,jk,jl1) & 1446 - erdg1(ji,jj,jk) & 1447 - eirft(ji,jj,jk) 1448 ! sea water heat content 1449 ztmelts = - tmut * sss_m(ji,jj) + rtt 1450 ! heat content per unit volume 1451 zdummy0 = - rcp * ( sst_m(ji,jj) + rt0 - rtt ) * vsw(ji,jj) 1452 1453 ! corrected sea water salinity 1454 zindb = MAX( 0.0, SIGN( 1.0, vsw(ji,jj) - zeps ) ) 1455 zdummy = zindb * ( srdg1(ji,jj) - srdg2(ji,jj) ) / & 1456 MAX( ridge_por * vsw(ji,jj), zeps ) 1457 1458 ztmelts = - tmut * zdummy + rtt 1459 ersw(ji,jj,jk) = - rcp * ( ztmelts - rtt ) * vsw(ji,jj) 1460 1461 ! heat flux 1462 fheat_rpo(ji,jj) = fheat_rpo(ji,jj) + ( ersw(ji,jj,jk) - zdummy0 ) / & 1463 rdt_ice 1464 1465 ! Correct dimensions to avoid big values 1466 ersw(ji,jj,jk) = ersw(ji,jj,jk) / 1.0d+09 1467 1468 ! Mutliply by ice volume, and divide by number of layers to get heat content in 10^9 J 1469 ersw(ji,jj,jk) = ersw(ji,jj,jk) * & 1470 area(ji,jj) * vsw(ji,jj) / & 1471 nlay_i 1472 1473 erdg2(ji,jj,jk) = erdg1(ji,jj,jk) + ersw(ji,jj,jk) 1474 1474 END DO ! ij 1475 1475 END DO !jk … … 1483 1483 jj = indxj(ij) 1484 1484 eice_init(ji,jj) = eice_init(ji,jj) + erdg2(ji,jj,jk) - & 1485 erdg1(ji,jj,jk)1485 erdg1(ji,jj,jk) 1486 1486 END DO ! ij 1487 1487 END DO !jk … … 1497 1497 WRITE(numout,*) ' ardg > a_i' 1498 1498 WRITE(numout,*) ' ardg, aicen_init : ', & 1499 1499 ardg1(ji,jj), aicen_init(ji,jj,jl1) 1500 1500 ENDIF ! afrac > 1 + puny 1501 1501 ENDDO ! if … … 1510 1510 WRITE(numout,*) ' arft > a_i' 1511 1511 WRITE(numout,*) ' arft, aicen_init : ', & 1512 1512 arft1(ji,jj), aicen_init(ji,jj,jl1) 1513 1513 ENDIF ! afrft > 1 + puny 1514 1514 ENDDO ! if 1515 1515 ENDIF ! large_afrft 1516 1516 1517 !-------------------------------------------------------------------------------1518 ! 4) Add area, volume, and energy of new ridge to each category jl21519 !-------------------------------------------------------------------------------1520 ! jl1 looping 1-jpl1517 !------------------------------------------------------------------------------- 1518 ! 4) Add area, volume, and energy of new ridge to each category jl2 1519 !------------------------------------------------------------------------------- 1520 ! jl1 looping 1-jpl 1521 1521 DO jl2 = ice_cat_bounds(1,1), ice_cat_bounds(1,2) 1522 ! over categories to which ridged ice is transferred1522 ! over categories to which ridged ice is transferred 1523 1523 !CDIR NODEP 1524 1524 DO ij = 1, icells … … 1531 1531 1532 1532 IF (hrmin(ji,jj,jl1) .GE. hi_max(jl2) .OR. & 1533 1533 hrmax(ji,jj,jl1) .LE. hi_max(jl2-1)) THEN 1534 1534 hL = 0.0 1535 1535 hR = 0.0 … … 1546 1546 v_i(ji,jj,jl2) = v_i(ji,jj,jl2) + fvol(ji,jj) * vrdg2(ji,jj) 1547 1547 v_s(ji,jj,jl2) = v_s(ji,jj,jl2) & 1548 1548 + fvol(ji,jj) * vsrdg(ji,jj) * fsnowrdg 1549 1549 e_s(ji,jj,1,jl2) = e_s(ji,jj,1,jl2) & 1550 1550 + fvol(ji,jj) * esrdg(ji,jj) * fsnowrdg 1551 1551 smv_i(ji,jj,jl2) = smv_i(ji,jj,jl2) + fvol(ji,jj) * srdg2(ji,jj) 1552 1552 oa_i(ji,jj,jl2) = oa_i(ji,jj,jl2) + farea * oirdg2(ji,jj) … … 1561 1561 jj = indxj(ij) 1562 1562 e_i(ji,jj,jk,jl2) = e_i(ji,jj,jk,jl2) & 1563 1563 + fvol(ji,jj)*erdg2(ji,jj,jk) 1564 1564 END DO ! ij 1565 1565 END DO !jk … … 1576 1576 ! Compute the fraction of rafted ice area and volume going to 1577 1577 ! thickness category jl2, transfer area, volume, and energy accordingly. 1578 1578 1579 1579 IF (hraft(ji,jj,jl1) .LE. hi_max(jl2) .AND. & 1580 1580 hraft(ji,jj,jl1) .GT. hi_max(jl2-1)) THEN 1581 1581 a_i(ji,jj,jl2) = a_i(ji,jj,jl2) + arft2(ji,jj) 1582 1582 v_i(ji,jj,jl2) = v_i(ji,jj,jl2) + virft(ji,jj) 1583 1583 v_s(ji,jj,jl2) = v_s(ji,jj,jl2) & 1584 1584 + vsrft(ji,jj)*fsnowrft 1585 1585 e_s(ji,jj,1,jl2) = e_s(ji,jj,1,jl2) & 1586 1586 + esrft(ji,jj)*fsnowrft 1587 1587 smv_i(ji,jj,jl2) = smv_i(ji,jj,jl2) & 1588 1588 + smrft(ji,jj) 1589 1589 oa_i(ji,jj,jl2) = oa_i(ji,jj,jl2) & 1590 1590 + oirft2(ji,jj) 1591 1591 ENDIF ! hraft 1592 1592 … … 1600 1600 jj = indxj(ij) 1601 1601 IF (hraft(ji,jj,jl1) .LE. hi_max(jl2) .AND. & 1602 1602 hraft(ji,jj,jl1) .GT. hi_max(jl2-1)) THEN 1603 1603 e_i(ji,jj,jk,jl2) = e_i(ji,jj,jk,jl2) & 1604 1604 + eirft(ji,jj,jk) 1605 1605 ENDIF 1606 1606 END DO ! ij … … 1628 1628 END SUBROUTINE lim_itd_me_ridgeshift 1629 1629 1630 !==============================================================================1630 !============================================================================== 1631 1631 1632 1632 SUBROUTINE lim_itd_me_asumr !(subroutine 5/6) 1633 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1634 !!----------------------------------------------------------------------------- 1635 !! *** ROUTINE lim_itd_me_asumr *** 1636 !! ** Purpose : 1637 !! This routine finds total fractional area 1638 !! 1639 !! ** Method : 1640 !! Find the total area of ice plus open water in each grid cell. 1641 !! 1642 !! This is similar to the aggregate_area subroutine except that the 1643 !! total area can be greater than 1, so the open water area is 1644 !! included in the sum instead of being computed as a residual. 1645 !! 1646 !! ** Arguments : 1647 1647 1648 1648 INTEGER :: ji, jj, jl … … 1672 1672 END SUBROUTINE lim_itd_me_asumr 1673 1673 1674 !==============================================================================1674 !============================================================================== 1675 1675 1676 1676 SUBROUTINE lim_itd_me_init ! (subroutine 6/6) … … 1691 1691 !!------------------------------------------------------------------- 1692 1692 NAMELIST/namiceitdme/ ridge_scheme_swi, Cs, Cf, fsnowrdg, fsnowrft,& 1693 1694 1695 1696 1693 Gstar, astar, & 1694 Hstar, raftswi, hparmeter, Craft, ridge_por, & 1695 sal_max_ridge, partfun_swi, transfun_swi, & 1696 brinstren_swi 1697 1697 !!------------------------------------------------------------------- 1698 1698 … … 1725 1725 END SUBROUTINE lim_itd_me_init 1726 1726 1727 !==============================================================================1727 !============================================================================== 1728 1728 1729 1729 SUBROUTINE lim_itd_me_zapsmall … … 1743 1743 1744 1744 INTEGER :: & 1745 1746 1747 1748 ! ij, & ! combined i/j horizontal index1749 1750 1751 ! INTEGER, DIMENSION(1:(jpi+1)*(jpj+1)) :: &1752 ! indxi, & ! compressed indices for i/j directions1753 ! indxj1745 ji,jj, & ! horizontal indices 1746 jl, & ! ice category index 1747 jk, & ! ice layer index 1748 ! ij, & ! combined i/j horizontal index 1749 icells ! number of cells with ice to zap 1750 1751 ! INTEGER, DIMENSION(1:(jpi+1)*(jpj+1)) :: & 1752 ! indxi, & ! compressed indices for i/j directions 1753 ! indxj 1754 1754 1755 1755 INTEGER, DIMENSION(jpi,jpj) :: zmask … … 1757 1757 1758 1758 REAL(wp) :: & 1759 1759 xtmp ! temporary variable 1760 1760 1761 1761 DO jl = 1, jpl 1762 1762 1763 !-----------------------------------------------------------------1764 ! Count categories to be zapped.1765 ! Abort model in case of negative area.1766 !-----------------------------------------------------------------1767 IF( MINVAL(a_i(:,:,jl)) .LT. -epsi11 ) THEN1763 !----------------------------------------------------------------- 1764 ! Count categories to be zapped. 1765 ! Abort model in case of negative area. 1766 !----------------------------------------------------------------- 1767 IF( MINVAL(a_i(:,:,jl)) .LT. -epsi11 .AND. ln_nicep ) THEN 1768 1768 DO jj = 1, jpj 1769 1769 DO ji = 1, jpi … … 1774 1774 ENDIF 1775 1775 END DO 1776 END DO 1776 END DO 1777 1777 ENDIF 1778 1779 icells = 0 1780 zmask = 0.e0 1781 DO jj = 1, jpj 1782 DO ji = 1, jpi 1783 IF ( ( a_i(ji,jj,jl) .GE. -epsi11 .AND. a_i(ji,jj,jl) .LT. 0.0) & 1784 .OR. & 1785 ( a_i(ji,jj,jl) .GT. 0.0 .AND. a_i(ji,jj,jl) .LE. 1.0e-11 ) & 1786 .OR. & 1787 !new line 1788 ( v_i(ji,jj,jl) .EQ. 0.0 .AND. a_i(ji,jj,jl) .GT. 0.0 ) & 1789 .OR. & 1790 ( v_i(ji,jj,jl) .GT. 0.0 .AND. v_i(ji,jj,jl) .LT. 1.e-12 ) ) THEN 1791 zmask(ji,jj) = 1 1792 ENDIF 1778 1779 icells = 0 1780 zmask = 0.e0 1781 DO jj = 1, jpj 1782 DO ji = 1, jpi 1783 IF ( ( a_i(ji,jj,jl) .GE. -epsi11 .AND. a_i(ji,jj,jl) .LT. 0.0) & 1784 .OR. & 1785 ( a_i(ji,jj,jl) .GT. 0.0 .AND. a_i(ji,jj,jl) .LE. 1.0e-11 ) & 1786 .OR. & 1787 !new line 1788 ( v_i(ji,jj,jl) .EQ. 0.0 .AND. a_i(ji,jj,jl) .GT. 0.0 ) & 1789 .OR. & 1790 ( v_i(ji,jj,jl) .GT. 0.0 .AND. v_i(ji,jj,jl) .LT. 1.e-12 ) ) THEN 1791 zmask(ji,jj) = 1 1792 ENDIF 1793 END DO 1793 1794 END DO 1794 END DO 1795 WRITE(numout,*) SUM(zmask), ' cells of ice zapped in the ocean ' 1796 1797 !----------------------------------------------------------------- 1798 ! Zap ice energy and use ocean heat to melt ice 1799 !----------------------------------------------------------------- 1795 IF( ln_nicep ) WRITE(numout,*) SUM(zmask), ' cells of ice zapped in the ocean ' 1796 1797 !----------------------------------------------------------------- 1798 ! Zap ice energy and use ocean heat to melt ice 1799 !----------------------------------------------------------------- 1800 1800 1801 1801 DO jk = 1, nlay_i … … 1803 1803 DO ji = 1 , jpi 1804 1804 1805 xtmp = e_i(ji,jj,jk,jl) / area(ji,jj) / rdt_ice1806 xtmp = xtmp * unit_fac1807 ! fheat_res(ji,jj) = fheat_res(ji,jj) - xtmp1808 e_i(ji,jj,jk,jl) = e_i(ji,jj,jk,jl) * ( 1 - zmask(ji,jj) )1805 xtmp = e_i(ji,jj,jk,jl) / area(ji,jj) / rdt_ice 1806 xtmp = xtmp * unit_fac 1807 ! fheat_res(ji,jj) = fheat_res(ji,jj) - xtmp 1808 e_i(ji,jj,jk,jl) = e_i(ji,jj,jk,jl) * ( 1 - zmask(ji,jj) ) 1809 1809 END DO ! ji 1810 1810 END DO ! jj … … 1814 1814 DO ji = 1 , jpi 1815 1815 1816 !-----------------------------------------------------------------1817 ! Zap snow energy and use ocean heat to melt snow1818 !-----------------------------------------------------------------1819 1820 ! xtmp = esnon(i,j,n) / dt ! < 01821 ! fhnet(i,j) = fhnet(i,j) + xtmp1822 ! fhnet_hist(i,j) = fhnet_hist(i,j) + xtmp1823 ! xtmp is greater than 01824 ! fluxes are positive to the ocean1825 ! here the flux has to be negative for the ocean1826 xtmp = ( rhosn*cpic*( rtt-t_s(ji,jj,1,jl) ) + rhosn*lfus ) / rdt_ice1827 ! fheat_res(ji,jj) = fheat_res(ji,jj) - xtmp1828 1829 xtmp = ( rhosn*cpic*( rtt-t_s(ji,jj,1,jl) ) + rhosn*lfus ) / rdt_ice !RB ???????1830 1831 t_s(ji,jj,1,jl) = rtt * zmask(ji,jj) + t_s(ji,jj,1,jl) * ( 1 - zmask(ji,jj) )1832 1833 !-----------------------------------------------------------------1834 ! zap ice and snow volume, add water and salt to ocean1835 !-----------------------------------------------------------------1836 1837 ! xtmp = (rhoi*vicen(i,j,n) + rhos*vsnon(i,j,n)) / dt1838 ! fresh(i,j) = fresh(i,j) + xtmp1839 ! fresh_hist(i,j) = fresh_hist(i,j) + xtmp1840 1841 ! fsalt_res(ji,jj) = fsalt_res(ji,jj) + ( sss_m(ji,jj) ) * &1842 ! rhosn * v_s(ji,jj,jl) / rdt_ice1843 1844 ! fsalt_res(ji,jj) = fsalt_res(ji,jj) + ( sss_m(ji,jj) - sm_i(ji,jj,jl) ) * &1845 ! rhoic * v_i(ji,jj,jl) / rdt_ice1846 1847 ! emps(i,j) = emps(i,j) + xtmp1848 ! fsalt_hist(i,j) = fsalt_hist(i,j) + xtmp1849 1850 ato_i(ji,jj) = a_i(ji,jj,jl) * zmask(ji,jj) + ato_i(ji,jj)1851 a_i(ji,jj,jl) = a_i(ji,jj,jl) * ( 1 - zmask(ji,jj) )1852 v_i(ji,jj,jl) = v_i(ji,jj,jl) * ( 1 - zmask(ji,jj) )1853 v_s(ji,jj,jl) = v_s(ji,jj,jl) * ( 1 - zmask(ji,jj) )1854 t_su(ji,jj,jl) = t_su(ji,jj,jl) * (1 -zmask(ji,jj) ) + t_bo(ji,jj) * zmask(ji,jj)1855 oa_i(ji,jj,jl) = oa_i(ji,jj,jl) * ( 1 - zmask(ji,jj) )1856 smv_i(ji,jj,jl) = smv_i(ji,jj,jl) * ( 1 - zmask(ji,jj) )1816 !----------------------------------------------------------------- 1817 ! Zap snow energy and use ocean heat to melt snow 1818 !----------------------------------------------------------------- 1819 1820 ! xtmp = esnon(i,j,n) / dt ! < 0 1821 ! fhnet(i,j) = fhnet(i,j) + xtmp 1822 ! fhnet_hist(i,j) = fhnet_hist(i,j) + xtmp 1823 ! xtmp is greater than 0 1824 ! fluxes are positive to the ocean 1825 ! here the flux has to be negative for the ocean 1826 xtmp = ( rhosn*cpic*( rtt-t_s(ji,jj,1,jl) ) + rhosn*lfus ) / rdt_ice 1827 ! fheat_res(ji,jj) = fheat_res(ji,jj) - xtmp 1828 1829 xtmp = ( rhosn*cpic*( rtt-t_s(ji,jj,1,jl) ) + rhosn*lfus ) / rdt_ice !RB ??????? 1830 1831 t_s(ji,jj,1,jl) = rtt * zmask(ji,jj) + t_s(ji,jj,1,jl) * ( 1 - zmask(ji,jj) ) 1832 1833 !----------------------------------------------------------------- 1834 ! zap ice and snow volume, add water and salt to ocean 1835 !----------------------------------------------------------------- 1836 1837 ! xtmp = (rhoi*vicen(i,j,n) + rhos*vsnon(i,j,n)) / dt 1838 ! fresh(i,j) = fresh(i,j) + xtmp 1839 ! fresh_hist(i,j) = fresh_hist(i,j) + xtmp 1840 1841 ! fsalt_res(ji,jj) = fsalt_res(ji,jj) + ( sss_m(ji,jj) ) * & 1842 ! rhosn * v_s(ji,jj,jl) / rdt_ice 1843 1844 ! fsalt_res(ji,jj) = fsalt_res(ji,jj) + ( sss_m(ji,jj) - sm_i(ji,jj,jl) ) * & 1845 ! rhoic * v_i(ji,jj,jl) / rdt_ice 1846 1847 ! emps(i,j) = emps(i,j) + xtmp 1848 ! fsalt_hist(i,j) = fsalt_hist(i,j) + xtmp 1849 1850 ato_i(ji,jj) = a_i(ji,jj,jl) * zmask(ji,jj) + ato_i(ji,jj) 1851 a_i(ji,jj,jl) = a_i(ji,jj,jl) * ( 1 - zmask(ji,jj) ) 1852 v_i(ji,jj,jl) = v_i(ji,jj,jl) * ( 1 - zmask(ji,jj) ) 1853 v_s(ji,jj,jl) = v_s(ji,jj,jl) * ( 1 - zmask(ji,jj) ) 1854 t_su(ji,jj,jl) = t_su(ji,jj,jl) * (1 -zmask(ji,jj) ) + t_bo(ji,jj) * zmask(ji,jj) 1855 oa_i(ji,jj,jl) = oa_i(ji,jj,jl) * ( 1 - zmask(ji,jj) ) 1856 smv_i(ji,jj,jl) = smv_i(ji,jj,jl) * ( 1 - zmask(ji,jj) ) 1857 1857 1858 1858 END DO ! ji -
trunk/NEMO/LIM_SRC_3/limitd_th.F90
r869 r921 28 28 USE prtctl ! Print control 29 29 USE lib_mpp 30 30 31 31 IMPLICIT NONE 32 32 PRIVATE … … 51 51 !!---------------------------------------------------------------------- 52 52 53 !!----------------------------------------------------------------------------------------------54 !!----------------------------------------------------------------------------------------------53 !!---------------------------------------------------------------------------------------------- 54 !!---------------------------------------------------------------------------------------------- 55 55 56 56 CONTAINS 57 57 58 SUBROUTINE lim_itd_th 59 !!------------------------------------------------------------------ 60 !! *** ROUTINE lim_itd_th *** 61 !! ** Purpose : 62 !! This routine computes the thermodynamics of ice thickness 63 !! distribution 64 !! ** Method : 65 !! 66 !! ** Arguments : 67 !! kideb , kiut : Starting and ending points on which the 68 !! the computation is applied 69 !! 70 !! ** Inputs / Ouputs : (global commons) 71 !! 72 !! ** External : 73 !! 74 !! ** References : 75 !! 76 !! ** History : 77 !! (12-2005) Martin Vancoppenolle 78 !! 79 !!------------------------------------------------------------------ 80 !! * Arguments 81 82 !! * Local variables 83 INTEGER :: jl, ja, & ! ice category, layers 84 jm, & ! ice types dummy loop index 85 jbnd1, & 86 jbnd2 87 88 REAL(wp) :: & ! constant values 89 zeps = 1.0e-10, & 90 epsi10 = 1.0e-10 91 92 !!-- End of declarations 93 !!---------------------------------------------------------------------------------------------- 94 95 IF (lwp) THEN 96 WRITE(numout,*) 97 WRITE(numout,*) 'lim_itd_th : Thermodynamics of the ice thickness distribution' 98 WRITE(numout,*) '~~~~~~~~~~~' 99 ENDIF 100 101 !------------------------------------------------------------------------------| 102 ! 1) Transport of ice between thickness categories. | 103 !------------------------------------------------------------------------------| 58 SUBROUTINE lim_itd_th( kt ) 59 !!------------------------------------------------------------------ 60 !! *** ROUTINE lim_itd_th *** 61 !! ** Purpose : 62 !! This routine computes the thermodynamics of ice thickness 63 !! distribution 64 !! ** Method : 65 !! 66 !! ** Arguments : 67 !! kideb , kiut : Starting and ending points on which the 68 !! the computation is applied 69 !! 70 !! ** Inputs / Ouputs : (global commons) 71 !! 72 !! ** External : 73 !! 74 !! ** References : 75 !! 76 !! ** History : 77 !! (12-2005) Martin Vancoppenolle 78 !! 79 !!------------------------------------------------------------------ 80 !! * Arguments 81 INTEGER, INTENT(in) :: kt 82 !! * Local variables 83 INTEGER :: jl, ja, & ! ice category, layers 84 jm, & ! ice types dummy loop index 85 jbnd1, & 86 jbnd2 87 88 REAL(wp) :: & ! constant values 89 zeps = 1.0e-10, & 90 epsi10 = 1.0e-10 91 92 IF( kt == nit000 .AND. lwp ) THEN 93 WRITE(numout,*) 94 WRITE(numout,*) 'lim_itd_th : Thermodynamics of the ice thickness distribution' 95 WRITE(numout,*) '~~~~~~~~~~~' 96 ENDIF 97 98 !------------------------------------------------------------------------------| 99 ! 1) Transport of ice between thickness categories. | 100 !------------------------------------------------------------------------------| 104 101 ! Given thermodynamic growth rates, transport ice between 105 102 ! thickness categories. … … 107 104 jbnd1 = ice_cat_bounds(jm,1) 108 105 jbnd2 = ice_cat_bounds(jm,2) 109 IF (ice_ncat_types(jm) .GT. 1 ) CALL lim_itd_th_rem( jbnd1, jbnd2, jm)106 IF (ice_ncat_types(jm) .GT. 1 ) CALL lim_itd_th_rem( jbnd1, jbnd2, jm, kt ) 110 107 END DO 111 108 … … 113 110 CALL lim_var_agg(1) 114 111 115 !------------------------------------------------------------------------------|116 ! 3) Add frazil ice growing in leads.117 !------------------------------------------------------------------------------|112 !------------------------------------------------------------------------------| 113 ! 3) Add frazil ice growing in leads. 114 !------------------------------------------------------------------------------| 118 115 119 116 CALL lim_thd_lac 120 117 CALL lim_var_glo2eqv ! only for info 121 118 122 !----------------------------------------------------------------------------------------123 ! 4) Computation of trend terms and get back to old values124 !----------------------------------------------------------------------------------------119 !---------------------------------------------------------------------------------------- 120 ! 4) Computation of trend terms and get back to old values 121 !---------------------------------------------------------------------------------------- 125 122 126 123 !- Trend terms … … 133 130 d_smv_i_thd(:,:,:) = 0.0 134 131 IF ( ( num_sal .EQ. 2 ) .OR. ( num_sal .EQ. 4 ) ) & 135 d_smv_i_thd(:,:,:) = smv_i(:,:,:) - old_smv_i(:,:,:)132 d_smv_i_thd(:,:,:) = smv_i(:,:,:) - old_smv_i(:,:,:) 136 133 137 134 IF(ln_ctl) THEN ! Control print … … 166 163 END DO 167 164 ENDIF 168 165 169 166 !- Recover Old values 170 167 a_i(:,:,:) = old_a_i (:,:,:) … … 175 172 176 173 IF ( ( num_sal .EQ. 2 ) .OR. ( num_sal .EQ. 4 ) ) & 177 smv_i(:,:,:) = old_smv_i (:,:,:) 178 179 180 END SUBROUTINE lim_itd_th 181 182 !!---------------------------------------------------------------------------------------------- 183 !!---------------------------------------------------------------------------------------------- 184 185 SUBROUTINE lim_itd_th_rem(klbnd,kubnd,ntyp) 186 !!------------------------------------------------------------------ 187 !! *** ROUTINE lim_itd_th_rem *** 188 !! ** Purpose : 189 !! This routine computes the redistribution of ice thickness 190 !! after thermodynamic growth of ice thickness 191 !! 192 !! ** Method : Linear remapping 193 !! 194 !! ** Arguments : 195 !! klbnd, kubnd : Starting and ending category index on which the 196 !! the computation is applied 197 !! 198 !! ** Inputs / Ouputs : (global commons) 199 !! 200 !! ** External : 201 !! 202 !! ** References : W.H. Lipscomb, JGR 2001 203 !! 204 !! ** History : 205 !! largely inspired from CICE (c) W. H. Lipscomb and E.C. Hunke 206 !! 207 !! (01-2006) Martin Vancoppenolle, UCL-ASTR, translation from 208 !! CICE 209 !! (06-2006) Adaptation to include salt, age and types 210 !! (04-2007) Mass conservation checked 211 !!------------------------------------------------------------------ 212 !! * Arguments 213 214 INTEGER , INTENT (IN) :: & 215 klbnd , & ! Start thickness category index point 216 kubnd , & ! End point on which the the computation is applied 217 ntyp ! Number of the type used 218 219 !! * Local variables 220 INTEGER :: ji, & ! spatial dummy loop index 221 jj, & ! spatial dummy loop index 222 jl, & ! ice category dummy loop index 223 zji, zjj, & ! dummy indices used when changing coordinates 224 nd ! used for thickness categories 225 226 INTEGER , DIMENSION(jpi,jpj,jpl-1) :: & 227 zdonor ! donor category index 228 229 REAL(wp) :: & ! constant values 230 zeps = 1.0e-10 231 232 REAL(wp) :: & ! constant values for ice enthalpy 233 zindb , & 234 zareamin , & ! minimum tolerated area in a thickness category 235 zwk1, zwk2, & ! all the following are dummy arguments 236 zx1, zx2, zx3, & ! 237 zetamin , & ! minimum value of eta 238 zetamax , & ! maximum value of eta 239 zdh0 , & ! 240 zda0 , & ! 241 zdamax , & ! 242 zhimin 243 244 REAL(wp), DIMENSION(jpi,jpj,jpl) :: & 245 zdhice , & ! ice thickness increment 246 g0 , & ! coefficients for fitting the line of the ITD 247 g1 , & ! coefficients for fitting the line of the ITD 248 hL , & ! left boundary for the ITD for each thickness 249 hR , & ! left boundary for the ITD for each thickness 250 zht_i_o , & ! old ice thickness 251 dummy_es 252 253 REAL(wp), DIMENSION(jpi,jpj,jpl-1) :: & 254 zdaice , & ! local increment of ice area 255 zdvice ! local increment of ice volume 256 257 REAL(wp), DIMENSION(jpi,jpj,0:jpl) :: & 258 zhbnew ! new boundaries of ice categories 259 260 REAL(wp), DIMENSION(jpi,jpj) :: & 261 zhb0, zhb1 ! category boundaries for thinnes categories 262 263 REAL, DIMENSION(1:(jpi+1)*(jpj+1)) :: & 264 zvetamin, zvetamax ! maximum values for etas 265 266 INTEGER, DIMENSION(1:(jpi+1)*(jpj+1)) :: & 267 nind_i , & ! compressed indices for i/j directions 268 nind_j 269 270 INTEGER :: & 271 nbrem ! number of cells with ice to transfer 272 273 LOGICAL, DIMENSION(jpi,jpj) :: & !: 274 zremap_flag ! compute remapping or not ???? 275 276 REAL(wp) :: & ! constant values for ice enthalpy 277 zslope ! used to compute local thermodynamic "speeds" 278 279 REAL (wp), DIMENSION(jpi,jpj) :: & ! 280 vt_i_init, vt_i_final, & ! ice volume summed over categories 281 vt_s_init, vt_s_final, & ! snow volume summed over categories 282 et_i_init, et_i_final, & ! ice energy summed over categories 283 et_s_init, et_s_final ! snow energy summed over categories 284 285 CHARACTER (len = 15) :: fieldid 286 287 !!-- End of declarations 288 !!---------------------------------------------------------------------------------------------- 174 smv_i(:,:,:) = old_smv_i (:,:,:) 175 176 END SUBROUTINE lim_itd_th 177 ! 178 179 SUBROUTINE lim_itd_th_rem( klbnd, kubnd, ntyp, kt ) 180 !!------------------------------------------------------------------ 181 !! *** ROUTINE lim_itd_th_rem *** 182 !! ** Purpose : 183 !! This routine computes the redistribution of ice thickness 184 !! after thermodynamic growth of ice thickness 185 !! 186 !! ** Method : Linear remapping 187 !! 188 !! ** Arguments : 189 !! klbnd, kubnd : Starting and ending category index on which the 190 !! the computation is applied 191 !! 192 !! ** Inputs / Ouputs : (global commons) 193 !! 194 !! ** External : 195 !! 196 !! ** References : W.H. Lipscomb, JGR 2001 197 !! 198 !! ** History : 199 !! largely inspired from CICE (c) W. H. Lipscomb and E.C. Hunke 200 !! 201 !! (01-2006) Martin Vancoppenolle, UCL-ASTR, translation from 202 !! CICE 203 !! (06-2006) Adaptation to include salt, age and types 204 !! (04-2007) Mass conservation checked 205 !!------------------------------------------------------------------ 206 !! * Arguments 207 208 INTEGER , INTENT (IN) :: & 209 klbnd , & ! Start thickness category index point 210 kubnd , & ! End point on which the the computation is applied 211 ntyp , & ! Number of the type used 212 kt ! Ocean time step 213 214 !! * Local variables 215 INTEGER :: ji, & ! spatial dummy loop index 216 jj, & ! spatial dummy loop index 217 jl, & ! ice category dummy loop index 218 zji, zjj, & ! dummy indices used when changing coordinates 219 nd ! used for thickness categories 220 221 INTEGER , DIMENSION(jpi,jpj,jpl-1) :: & 222 zdonor ! donor category index 223 224 REAL(wp) :: & ! constant values 225 zeps = 1.0e-10 226 227 REAL(wp) :: & ! constant values for ice enthalpy 228 zindb , & 229 zareamin , & ! minimum tolerated area in a thickness category 230 zwk1, zwk2, & ! all the following are dummy arguments 231 zx1, zx2, zx3, & ! 232 zetamin , & ! minimum value of eta 233 zetamax , & ! maximum value of eta 234 zdh0 , & ! 235 zda0 , & ! 236 zdamax , & ! 237 zhimin 238 239 REAL(wp), DIMENSION(jpi,jpj,jpl) :: & 240 zdhice , & ! ice thickness increment 241 g0 , & ! coefficients for fitting the line of the ITD 242 g1 , & ! coefficients for fitting the line of the ITD 243 hL , & ! left boundary for the ITD for each thickness 244 hR , & ! left boundary for the ITD for each thickness 245 zht_i_o , & ! old ice thickness 246 dummy_es 247 248 REAL(wp), DIMENSION(jpi,jpj,jpl-1) :: & 249 zdaice , & ! local increment of ice area 250 zdvice ! local increment of ice volume 251 252 REAL(wp), DIMENSION(jpi,jpj,0:jpl) :: & 253 zhbnew ! new boundaries of ice categories 254 255 REAL(wp), DIMENSION(jpi,jpj) :: & 256 zhb0, zhb1 ! category boundaries for thinnes categories 257 258 REAL, DIMENSION(1:(jpi+1)*(jpj+1)) :: & 259 zvetamin, zvetamax ! maximum values for etas 260 261 INTEGER, DIMENSION(1:(jpi+1)*(jpj+1)) :: & 262 nind_i , & ! compressed indices for i/j directions 263 nind_j 264 265 INTEGER :: & 266 nbrem ! number of cells with ice to transfer 267 268 LOGICAL, DIMENSION(jpi,jpj) :: & !: 269 zremap_flag ! compute remapping or not ???? 270 271 REAL(wp) :: & ! constant values for ice enthalpy 272 zslope ! used to compute local thermodynamic "speeds" 273 274 REAL (wp), DIMENSION(jpi,jpj) :: & ! 275 vt_i_init, vt_i_final, & ! ice volume summed over categories 276 vt_s_init, vt_s_final, & ! snow volume summed over categories 277 et_i_init, et_i_final, & ! ice energy summed over categories 278 et_s_init, et_s_final ! snow energy summed over categories 279 280 CHARACTER (len = 15) :: fieldid 281 282 !!-- End of declarations 283 !!---------------------------------------------------------------------------------------------- 289 284 zhimin = 0.1 !minimum ice thickness tolerated by the model 290 285 zareamin = zeps !minimum area in thickness categories tolerated by the conceptors of the model 291 286 292 !!----------------------------------------------------------------------------------------------293 !! 0) Conservation checkand changes in each ice category294 !!----------------------------------------------------------------------------------------------287 !!---------------------------------------------------------------------------------------------- 288 !! 0) Conservation checkand changes in each ice category 289 !!---------------------------------------------------------------------------------------------- 295 290 IF ( con_i ) THEN 296 291 CALL lim_column_sum (jpl, v_i, vt_i_init) … … 300 295 CALL lim_column_sum (jpl, dummy_es(:,:,:) , et_s_init) 301 296 ENDIF 302 303 !!----------------------------------------------------------------------------------------------304 !! 1) Compute thickness and changes in each ice category305 !!----------------------------------------------------------------------------------------------306 IF (lwp) THEN307 WRITE(numout,*)308 WRITE(numout,*) 'lim_itd_th_rem : Remapping the ice thickness distribution'309 WRITE(numout,*) '~~~~~~~~~~~~~~~'310 WRITE(numout,*) ' klbnd : ', klbnd311 WRITE(numout,*) ' kubnd : ', kubnd312 WRITE(numout,*) ' ntyp : ', ntyp313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 !-----------------------------------------------------------------------------------------------331 ! 2) Compute fractional ice area in each grid cell332 !-----------------------------------------------------------------------------------------------297 298 !!---------------------------------------------------------------------------------------------- 299 !! 1) Compute thickness and changes in each ice category 300 !!---------------------------------------------------------------------------------------------- 301 IF (kt == nit000 .AND. lwp) THEN 302 WRITE(numout,*) 303 WRITE(numout,*) 'lim_itd_th_rem : Remapping the ice thickness distribution' 304 WRITE(numout,*) '~~~~~~~~~~~~~~~' 305 WRITE(numout,*) ' klbnd : ', klbnd 306 WRITE(numout,*) ' kubnd : ', kubnd 307 WRITE(numout,*) ' ntyp : ', ntyp 308 ENDIF 309 310 zdhice(:,:,:) = 0.0 311 DO jl = klbnd, kubnd 312 DO jj = 1, jpj 313 DO ji = 1, jpi 314 zindb = 1.0-MAX(0.0,SIGN(1.0,-a_i(ji,jj,jl))) !0 if no ice and 1 if yes 315 ht_i(ji,jj,jl) = v_i(ji,jj,jl) / MAX(a_i(ji,jj,jl),zeps) * zindb 316 zindb = 1.0-MAX(0.0,SIGN(1.0,-old_a_i(ji,jj,jl))) !0 if no ice and 1 if yes 317 zht_i_o(ji,jj,jl) = old_v_i(ji,jj,jl) / MAX(old_a_i(ji,jj,jl),zeps) * zindb 318 IF (a_i(ji,jj,jl).gt.1e-6) THEN 319 zdhice(ji,jj,jl) = ht_i(ji,jj,jl) - zht_i_o(ji,jj,jl) 320 ENDIF 321 END DO 322 END DO 323 END DO 324 325 !----------------------------------------------------------------------------------------------- 326 ! 2) Compute fractional ice area in each grid cell 327 !----------------------------------------------------------------------------------------------- 333 328 at_i(:,:) = 0.0 334 329 DO jl = klbnd, kubnd … … 340 335 END DO 341 336 342 !-----------------------------------------------------------------------------------------------343 ! 3) Identify grid cells with ice344 !-----------------------------------------------------------------------------------------------337 !----------------------------------------------------------------------------------------------- 338 ! 3) Identify grid cells with ice 339 !----------------------------------------------------------------------------------------------- 345 340 nbrem = 0 346 341 DO jj = 1, jpj … … 357 352 END DO !jj 358 353 359 !-----------------------------------------------------------------------------------------------360 ! 4) Compute new category boundaries361 !-----------------------------------------------------------------------------------------------354 !----------------------------------------------------------------------------------------------- 355 ! 4) Compute new category boundaries 356 !----------------------------------------------------------------------------------------------- 362 357 !- 4.1 Compute category boundaries 363 358 ! Tricky trick see limitd_me.F90 … … 374 369 ! 375 370 IF ( ( zht_i_o(zji,zjj,jl) .GT.zeps ) .AND. & 376 371 ( zht_i_o(zji,zjj,jl+1).GT.zeps ) ) THEN 377 372 !interpolate between adjacent category growth rates 378 373 zslope = ( zdhice(zji,zjj,jl+1) - zdhice(zji,zjj,jl) ) / & 379 374 ( zht_i_o (zji,zjj,jl+1) - zht_i_o (zji,zjj,jl) ) 380 375 zhbnew(zji,zjj,jl) = hi_max(jl) + zdhice(zji,zjj,jl) + & 381 376 zslope * ( hi_max(jl) - zht_i_o(zji,zjj,jl) ) 382 377 ELSEIF (zht_i_o(zji,zjj,jl).gt.zeps) THEN 383 378 zhbnew(zji,zjj,jl) = hi_max(jl) + zdhice(zji,zjj,jl) … … 391 386 ! jl 392 387 393 !- 4.2 Check that each zhbnew lies between adjacent values of ice thickness388 !- 4.2 Check that each zhbnew lies between adjacent values of ice thickness 394 389 DO ji = 1, nbrem 395 390 ! jl, ji … … 398 393 ! jl, ji 399 394 IF ( ( a_i(zji,zjj,jl) .GT.zeps) .AND. & 400 395 ( ht_i(zji,zjj,jl).GE. zhbnew(zji,zjj,jl) ) & 401 396 ) THEN 402 397 zremap_flag(zji,zjj) = .false. 403 398 ELSEIF ( ( a_i(zji,zjj,jl+1) .GT. zeps ) .AND. & 404 405 399 ( ht_i(zji,zjj,jl+1).LE. zhbnew(zji,zjj,jl) ) & 400 ) THEN 406 401 zremap_flag(zji,zjj) = .false. 407 402 ENDIF 408 403 409 !- 4.3 Check that each zhbnew does not exceed maximal values hi_max404 !- 4.3 Check that each zhbnew does not exceed maximal values hi_max 410 405 ! jl, ji 411 406 IF (zhbnew(zji,zjj,jl).gt.hi_max(jl+1)) THEN … … 420 415 ! ji 421 416 END DO !jl 422 423 !-----------------------------------------------------------------------------------------------424 ! 5) Identify cells where ITD is to be remapped425 !-----------------------------------------------------------------------------------------------426 nbrem = 0427 DO jj = 1, jpj428 DO ji = 1, jpi429 IF ( zremap_flag(ji,jj) ) THEN430 nbrem = nbrem + 1431 nind_i(nbrem) = ji432 nind_j(nbrem) = jj433 ENDIF434 END DO !ji435 END DO !jj436 437 !-----------------------------------------------------------------------------------------------438 ! 6) Fill arrays with lowermost / uppermost boundaries of 'new' categories439 !-----------------------------------------------------------------------------------------------440 DO jj = 1, jpj441 DO ji = 1, jpi442 zhb0(ji,jj) = hi_max_typ(0,ntyp) ! 0eme443 zhb1(ji,jj) = hi_max_typ(1,ntyp) ! 1er444 445 zhbnew(ji,jj,klbnd-1) = 0.0446 447 IF ( a_i(ji,jj,kubnd) .GT. zeps ) THEN448 zhbnew(ji,jj,kubnd) = 3.0*ht_i(ji,jj,kubnd) - 2.0*zhbnew(ji,jj,kubnd-1)449 ELSE450 zhbnew(ji,jj,kubnd) = hi_max(kubnd)451 ENDIF452 453 IF ( zhbnew(ji,jj,kubnd) .LT. hi_max(kubnd-1) ) &454 zhbnew(ji,jj,kubnd) = hi_max(kubnd-1)455 456 END DO !jj457 END DO !jj458 459 !-----------------------------------------------------------------------------------------------460 ! 7) Compute g(h)461 !-----------------------------------------------------------------------------------------------462 !- 7.1 g(h) for category 1 at start of time step463 CALL lim_itd_fitline(klbnd, zhb0, zhb1, zht_i_o(:,:,klbnd), &464 465 466 467 !- 7.2 Area lost due to melting of thin ice (first category, klbnd)468 DO ji = 1, nbrem469 zji = nind_i(ji)470 zjj = nind_j(ji)471 472 !ji473 IF (a_i(zji,zjj,klbnd) .gt. zeps) THEN474 zdh0 = zdhice(zji,zjj,klbnd) !decrease of ice thickness in the lower category475 ! ji, a_i > zeps476 IF (zdh0 .lt. 0.0) THEN !remove area from category 1477 ! ji, a_i > zeps; zdh0 < 0478 zdh0 = MIN(-zdh0,hi_max(klbnd))479 480 !Integrate g(1) from 0 to dh0 to estimate area melted481 zetamax = MIN(zdh0,hR(zji,zjj,klbnd)) - hL(zji,zjj,klbnd)482 IF (zetamax.gt.0.0) THEN483 zx1 = zetamax484 zx2 = 0.5 * zetamax*zetamax485 zda0 = g1(zji,zjj,klbnd) * zx2 + g0(zji,zjj,klbnd) * zx1 !ice area removed486 ! Constrain new thickness <= ht_i487 zdamax = a_i(zji,zjj,klbnd) * &488 489 !ice area lost due to melting of thin ice490 zda0 = MIN(zda0, zdamax)491 492 ! Remove area, conserving volume493 ht_i(zji,zjj,klbnd) = ht_i(zji,zjj,klbnd) &494 495 a_i(zji,zjj,klbnd) = a_i(zji,zjj,klbnd) - zda0496 v_i(zji,zjj,klbnd) = a_i(zji,zjj,klbnd)*ht_i(zji,zjj,klbnd)497 ENDIF ! zetamax > 0498 ! ji, a_i > zeps499 500 ELSE ! if ice accretion501 ! ji, a_i > zeps; zdh0 > 0502 IF ( ntyp .EQ. 1 ) zhbnew(zji,zjj,klbnd-1) = MIN(zdh0,hi_max(klbnd))503 ! zhbnew was 0, and is shifted to the right to account for thin ice504 ! growth in openwater (F0 = f1)505 IF ( ntyp .NE. 1 ) zhbnew(zji,zjj,0) = 0506 ! in other types there is507 ! no open water growth (F0 = 0)508 ENDIF ! zdh0509 510 ! a_i > zeps511 ENDIF ! a_i > zeps512 513 END DO ! ji514 515 !- 7.3 g(h) for each thickness category516 DO jl = klbnd, kubnd517 CALL lim_itd_fitline(jl, zhbnew(:,:,jl-1), zhbnew(:,:,jl), ht_i(:,:,jl), &518 519 520 END DO521 522 !-----------------------------------------------------------------------------------------------523 ! 8) Compute area and volume to be shifted across each boundary524 !-----------------------------------------------------------------------------------------------525 526 DO jl = klbnd, kubnd - 1527 DO jj = 1, jpj528 DO ji = 1, jpi529 zdonor(ji,jj,jl) = 0530 zdaice(ji,jj,jl) = 0.0531 zdvice(ji,jj,jl) = 0.0532 END DO533 END DO534 535 DO ji = 1, nbrem536 zji = nind_i(ji)537 zjj = nind_j(ji)538 539 IF (zhbnew(zji,zjj,jl) .gt. hi_max(jl)) THEN ! transfer from jl to jl+1540 541 ! left and right integration limits in eta space542 zvetamin(ji) = MAX(hi_max(jl), hL(zji,zjj,jl)) - hL(zji,zjj,jl)543 zvetamax(ji) = MIN(zhbnew(zji,zjj,jl), hR(zji,zjj,jl)) - hL(zji,zjj,jl)544 zdonor(zji,zjj,jl) = jl545 546 ELSE ! zhbnew(jl) <= hi_max(jl) ; transfer from jl+1 to jl547 548 ! left and right integration limits in eta space549 zvetamin(ji) = 0.0550 zvetamax(ji) = MIN(hi_max(jl), hR(zji,zjj,jl+1)) - hL(zji,zjj,jl+1)551 zdonor(zji,zjj,jl) = jl + 1552 553 ENDIF ! zhbnew(jl) > hi_max(jl)554 555 zetamax = MAX(zvetamax(ji), zvetamin(ji)) ! no transfer if etamax < etamin556 zetamin = zvetamin(ji)557 558 zx1 = zetamax - zetamin559 zwk1 = zetamin*zetamin560 zwk2 = zetamax*zetamax561 zx2 = 0.5 * (zwk2 - zwk1)562 zwk1 = zwk1 * zetamin563 zwk2 = zwk2 * zetamax564 zx3 = 1.0/3.0 * (zwk2 - zwk1)565 nd = zdonor(zji,zjj,jl)566 zdaice(zji,zjj,jl) = g1(zji,zjj,nd)*zx2 + g0(zji,zjj,nd)*zx1567 zdvice(zji,zjj,jl) = g1(zji,zjj,nd)*zx3 + g0(zji,zjj,nd)*zx2 + &568 569 570 END DO ! ji571 END DO ! jl klbnd -> kubnd - 1572 573 !!----------------------------------------------------------------------------------------------574 !! 9) Shift ice between categories575 !!----------------------------------------------------------------------------------------------576 CALL lim_itd_shiftice ( klbnd, kubnd, zdonor, zdaice, zdvice )577 578 !!----------------------------------------------------------------------------------------------579 !! 10) Make sure ht_i >= minimum ice thickness hi_min580 !!----------------------------------------------------------------------------------------------581 582 DO ji = 1, nbrem583 zji = nind_i(ji)584 zjj = nind_j(ji)585 IF ( ( zhimin .GT. 0.0 ) .AND. &586 587 ) THEN588 a_i(zji,zjj,1) = a_i(zji,zjj,1) * ht_i(zji,zjj,1) / zhimin589 ht_i(zji,zjj,1) = zhimin590 v_i(zji,zjj,1) = a_i(zji,zjj,1)*ht_i(zji,zjj,1)591 ENDIF592 END DO !ji593 594 !!----------------------------------------------------------------------------------------------595 !! 11) Conservation check596 !!----------------------------------------------------------------------------------------------417 418 !----------------------------------------------------------------------------------------------- 419 ! 5) Identify cells where ITD is to be remapped 420 !----------------------------------------------------------------------------------------------- 421 nbrem = 0 422 DO jj = 1, jpj 423 DO ji = 1, jpi 424 IF ( zremap_flag(ji,jj) ) THEN 425 nbrem = nbrem + 1 426 nind_i(nbrem) = ji 427 nind_j(nbrem) = jj 428 ENDIF 429 END DO !ji 430 END DO !jj 431 432 !----------------------------------------------------------------------------------------------- 433 ! 6) Fill arrays with lowermost / uppermost boundaries of 'new' categories 434 !----------------------------------------------------------------------------------------------- 435 DO jj = 1, jpj 436 DO ji = 1, jpi 437 zhb0(ji,jj) = hi_max_typ(0,ntyp) ! 0eme 438 zhb1(ji,jj) = hi_max_typ(1,ntyp) ! 1er 439 440 zhbnew(ji,jj,klbnd-1) = 0.0 441 442 IF ( a_i(ji,jj,kubnd) .GT. zeps ) THEN 443 zhbnew(ji,jj,kubnd) = 3.0*ht_i(ji,jj,kubnd) - 2.0*zhbnew(ji,jj,kubnd-1) 444 ELSE 445 zhbnew(ji,jj,kubnd) = hi_max(kubnd) 446 ENDIF 447 448 IF ( zhbnew(ji,jj,kubnd) .LT. hi_max(kubnd-1) ) & 449 zhbnew(ji,jj,kubnd) = hi_max(kubnd-1) 450 451 END DO !jj 452 END DO !jj 453 454 !----------------------------------------------------------------------------------------------- 455 ! 7) Compute g(h) 456 !----------------------------------------------------------------------------------------------- 457 !- 7.1 g(h) for category 1 at start of time step 458 CALL lim_itd_fitline(klbnd, zhb0, zhb1, zht_i_o(:,:,klbnd), & 459 g0(:,:,klbnd), g1(:,:,klbnd), hL(:,:,klbnd), & 460 hR(:,:,klbnd), zremap_flag) 461 462 !- 7.2 Area lost due to melting of thin ice (first category, klbnd) 463 DO ji = 1, nbrem 464 zji = nind_i(ji) 465 zjj = nind_j(ji) 466 467 !ji 468 IF (a_i(zji,zjj,klbnd) .gt. zeps) THEN 469 zdh0 = zdhice(zji,zjj,klbnd) !decrease of ice thickness in the lower category 470 ! ji, a_i > zeps 471 IF (zdh0 .lt. 0.0) THEN !remove area from category 1 472 ! ji, a_i > zeps; zdh0 < 0 473 zdh0 = MIN(-zdh0,hi_max(klbnd)) 474 475 !Integrate g(1) from 0 to dh0 to estimate area melted 476 zetamax = MIN(zdh0,hR(zji,zjj,klbnd)) - hL(zji,zjj,klbnd) 477 IF (zetamax.gt.0.0) THEN 478 zx1 = zetamax 479 zx2 = 0.5 * zetamax*zetamax 480 zda0 = g1(zji,zjj,klbnd) * zx2 + g0(zji,zjj,klbnd) * zx1 !ice area removed 481 ! Constrain new thickness <= ht_i 482 zdamax = a_i(zji,zjj,klbnd) * & 483 (1.0 - ht_i(zji,zjj,klbnd)/zht_i_o(zji,zjj,klbnd)) ! zdamax > 0 484 !ice area lost due to melting of thin ice 485 zda0 = MIN(zda0, zdamax) 486 487 ! Remove area, conserving volume 488 ht_i(zji,zjj,klbnd) = ht_i(zji,zjj,klbnd) & 489 * a_i(zji,zjj,klbnd) / ( a_i(zji,zjj,klbnd) - zda0 ) 490 a_i(zji,zjj,klbnd) = a_i(zji,zjj,klbnd) - zda0 491 v_i(zji,zjj,klbnd) = a_i(zji,zjj,klbnd)*ht_i(zji,zjj,klbnd) 492 ENDIF ! zetamax > 0 493 ! ji, a_i > zeps 494 495 ELSE ! if ice accretion 496 ! ji, a_i > zeps; zdh0 > 0 497 IF ( ntyp .EQ. 1 ) zhbnew(zji,zjj,klbnd-1) = MIN(zdh0,hi_max(klbnd)) 498 ! zhbnew was 0, and is shifted to the right to account for thin ice 499 ! growth in openwater (F0 = f1) 500 IF ( ntyp .NE. 1 ) zhbnew(zji,zjj,0) = 0 501 ! in other types there is 502 ! no open water growth (F0 = 0) 503 ENDIF ! zdh0 504 505 ! a_i > zeps 506 ENDIF ! a_i > zeps 507 508 END DO ! ji 509 510 !- 7.3 g(h) for each thickness category 511 DO jl = klbnd, kubnd 512 CALL lim_itd_fitline(jl, zhbnew(:,:,jl-1), zhbnew(:,:,jl), ht_i(:,:,jl), & 513 g0(:,:,jl), g1(:,:,jl), hL(:,:,jl), hR(:,:,jl), & 514 zremap_flag) 515 END DO 516 517 !----------------------------------------------------------------------------------------------- 518 ! 8) Compute area and volume to be shifted across each boundary 519 !----------------------------------------------------------------------------------------------- 520 521 DO jl = klbnd, kubnd - 1 522 DO jj = 1, jpj 523 DO ji = 1, jpi 524 zdonor(ji,jj,jl) = 0 525 zdaice(ji,jj,jl) = 0.0 526 zdvice(ji,jj,jl) = 0.0 527 END DO 528 END DO 529 530 DO ji = 1, nbrem 531 zji = nind_i(ji) 532 zjj = nind_j(ji) 533 534 IF (zhbnew(zji,zjj,jl) .gt. hi_max(jl)) THEN ! transfer from jl to jl+1 535 536 ! left and right integration limits in eta space 537 zvetamin(ji) = MAX(hi_max(jl), hL(zji,zjj,jl)) - hL(zji,zjj,jl) 538 zvetamax(ji) = MIN(zhbnew(zji,zjj,jl), hR(zji,zjj,jl)) - hL(zji,zjj,jl) 539 zdonor(zji,zjj,jl) = jl 540 541 ELSE ! zhbnew(jl) <= hi_max(jl) ; transfer from jl+1 to jl 542 543 ! left and right integration limits in eta space 544 zvetamin(ji) = 0.0 545 zvetamax(ji) = MIN(hi_max(jl), hR(zji,zjj,jl+1)) - hL(zji,zjj,jl+1) 546 zdonor(zji,zjj,jl) = jl + 1 547 548 ENDIF ! zhbnew(jl) > hi_max(jl) 549 550 zetamax = MAX(zvetamax(ji), zvetamin(ji)) ! no transfer if etamax < etamin 551 zetamin = zvetamin(ji) 552 553 zx1 = zetamax - zetamin 554 zwk1 = zetamin*zetamin 555 zwk2 = zetamax*zetamax 556 zx2 = 0.5 * (zwk2 - zwk1) 557 zwk1 = zwk1 * zetamin 558 zwk2 = zwk2 * zetamax 559 zx3 = 1.0/3.0 * (zwk2 - zwk1) 560 nd = zdonor(zji,zjj,jl) 561 zdaice(zji,zjj,jl) = g1(zji,zjj,nd)*zx2 + g0(zji,zjj,nd)*zx1 562 zdvice(zji,zjj,jl) = g1(zji,zjj,nd)*zx3 + g0(zji,zjj,nd)*zx2 + & 563 zdaice(zji,zjj,jl)*hL(zji,zjj,nd) 564 565 END DO ! ji 566 END DO ! jl klbnd -> kubnd - 1 567 568 !!---------------------------------------------------------------------------------------------- 569 !! 9) Shift ice between categories 570 !!---------------------------------------------------------------------------------------------- 571 CALL lim_itd_shiftice ( klbnd, kubnd, zdonor, zdaice, zdvice ) 572 573 !!---------------------------------------------------------------------------------------------- 574 !! 10) Make sure ht_i >= minimum ice thickness hi_min 575 !!---------------------------------------------------------------------------------------------- 576 577 DO ji = 1, nbrem 578 zji = nind_i(ji) 579 zjj = nind_j(ji) 580 IF ( ( zhimin .GT. 0.0 ) .AND. & 581 ( ( a_i(zji,zjj,1) .GT. zeps ) .AND. ( ht_i(zji,zjj,1) .LT. zhimin ) ) & 582 ) THEN 583 a_i(zji,zjj,1) = a_i(zji,zjj,1) * ht_i(zji,zjj,1) / zhimin 584 ht_i(zji,zjj,1) = zhimin 585 v_i(zji,zjj,1) = a_i(zji,zjj,1)*ht_i(zji,zjj,1) 586 ENDIF 587 END DO !ji 588 589 !!---------------------------------------------------------------------------------------------- 590 !! 11) Conservation check 591 !!---------------------------------------------------------------------------------------------- 597 592 IF ( con_i ) THEN 598 593 CALL lim_column_sum (jpl, v_i, vt_i_final) … … 614 609 ENDIF 615 610 616 END SUBROUTINE lim_itd_th_rem 617 618 !!---------------------------------------------------------------------------------------------- 619 !!---------------------------------------------------------------------------------------------- 620 621 SUBROUTINE lim_itd_fitline(num_cat, HbL, Hbr, hice, g0, g1, hL, hR, zremap_flag ) 622 623 !!------------------------------------------------------------------ 624 !! *** ROUTINE lim_itd_fitline *** 625 !! ** Purpose : 626 !! fit g(h) with a line using area, volume constraints 627 !! 628 !! ** Method : 629 !! Fit g(h) with a line, satisfying area and volume constraints. 630 !! To reduce roundoff errors caused by large values of g0 and g1, 631 !! we actually compute g(eta), where eta = h - hL, and hL is the 632 !! left boundary. 633 !! 634 !! ** Arguments : 635 !! 636 !! ** Inputs / Ouputs : (global commons) 637 !! 638 !! ** External : 639 !! 640 !! ** References : 641 !! 642 !! ** History : 643 !! authors: William H. Lipscomb, LANL, Elizabeth C. Hunke, LANL 644 !! (01-2006) Martin Vancoppenolle 645 !! 646 !!------------------------------------------------------------------ 647 !! * Arguments 611 END SUBROUTINE lim_itd_th_rem 612 ! 613 614 SUBROUTINE lim_itd_fitline(num_cat, HbL, Hbr, hice, g0, g1, hL, hR, zremap_flag ) 615 616 !!------------------------------------------------------------------ 617 !! *** ROUTINE lim_itd_fitline *** 618 !! ** Purpose : 619 !! fit g(h) with a line using area, volume constraints 620 !! 621 !! ** Method : 622 !! Fit g(h) with a line, satisfying area and volume constraints. 623 !! To reduce roundoff errors caused by large values of g0 and g1, 624 !! we actually compute g(eta), where eta = h - hL, and hL is the 625 !! left boundary. 626 !! 627 !! ** Arguments : 628 !! 629 !! ** Inputs / Ouputs : (global commons) 630 !! 631 !! ** External : 632 !! 633 !! ** References : 634 !! 635 !! ** History : 636 !! authors: William H. Lipscomb, LANL, Elizabeth C. Hunke, LANL 637 !! (01-2006) Martin Vancoppenolle 638 !! 639 !!------------------------------------------------------------------ 640 !! * Arguments 648 641 649 642 INTEGER, INTENT(in) :: num_cat ! category index … … 674 667 675 668 REAL(wp) :: & ! constant values 676 669 zeps = 1.0e-10 677 670 678 671 zacrith = 1.0e-6 679 !!-- End of declarations680 !!----------------------------------------------------------------------------------------------672 !!-- End of declarations 673 !!---------------------------------------------------------------------------------------------- 681 674 682 675 DO jj = 1, jpj … … 684 677 685 678 IF ( zremap_flag(ji,jj) .AND. a_i(ji,jj,num_cat) .gt. zacrith & 686 687 688 ! Initialize hL and hR679 .AND. hice(ji,jj) .GT. 0.0 ) THEN 680 681 ! Initialize hL and hR 689 682 690 683 hL(ji,jj) = HbL(ji,jj) 691 684 hR(ji,jj) = HbR(ji,jj) 692 685 693 ! Change hL or hR if hice falls outside central third of range686 ! Change hL or hR if hice falls outside central third of range 694 687 695 688 zh13 = 1.0/3.0 * (2.0*hL(ji,jj) + hR(ji,jj)) … … 702 695 ENDIF 703 696 704 ! Compute coefficients of g(eta) = g0 + g1*eta705 697 ! Compute coefficients of g(eta) = g0 + g1*eta 698 706 699 zdhr = 1.0 / (hR(ji,jj) - hL(ji,jj)) 707 700 zwk1 = 6.0 * a_i(ji,jj,num_cat) * zdhr … … 722 715 END DO ! jj 723 716 724 END SUBROUTINE lim_itd_fitline 725 726 !---------------------------------------------------------------------------------------------- 727 !---------------------------------------------------------------------------------------------- 728 729 SUBROUTINE lim_itd_shiftice (klbnd, kubnd, zdonor, zdaice, zdvice) 730 !!------------------------------------------------------------------ 731 !! *** ROUTINE lim_itd_shiftice *** 732 !! ** Purpose : shift ice across category boundaries, conserving everything 733 !! ( area, volume, energy, age*vol, and mass of salt ) 734 !! 735 !! ** Method : 736 !! 737 !! ** Arguments : 738 !! 739 !! ** Inputs / Ouputs : (global commons) 740 !! 741 !! ** External : 742 !! 743 !! ** References : 744 !! 745 !! ** History : 746 !! authors: William H. Lipscomb, LANL, Elizabeth C. Hunke, LANL 747 !! (01-2006) Martin Vancoppenolle 748 !! 749 !!------------------------------------------------------------------ 750 !! * Arguments 717 END SUBROUTINE lim_itd_fitline 718 ! 719 720 SUBROUTINE lim_itd_shiftice (klbnd, kubnd, zdonor, zdaice, zdvice) 721 !!------------------------------------------------------------------ 722 !! *** ROUTINE lim_itd_shiftice *** 723 !! ** Purpose : shift ice across category boundaries, conserving everything 724 !! ( area, volume, energy, age*vol, and mass of salt ) 725 !! 726 !! ** Method : 727 !! 728 !! ** Arguments : 729 !! 730 !! ** Inputs / Ouputs : (global commons) 731 !! 732 !! ** External : 733 !! 734 !! ** References : 735 !! 736 !! ** History : 737 !! authors: William H. Lipscomb, LANL, Elizabeth C. Hunke, LANL 738 !! (01-2006) Martin Vancoppenolle 739 !! 740 !!------------------------------------------------------------------ 741 !! * Arguments 751 742 752 743 INTEGER , INTENT (IN) :: & 753 754 744 klbnd , & ! Start thickness category index point 745 kubnd ! End point on which the the computation is applied 755 746 756 747 INTEGER , DIMENSION(jpi,jpj,jpl-1), INTENT(IN) :: & … … 792 783 793 784 LOGICAL :: & 794 zdaice_negative , & ! true if daice < -puny795 zdvice_negative , & ! true if dvice < -puny796 zdaice_greater_aicen , & ! true if daice > aicen797 zdvice_greater_vicen ! true if dvice > vicen798 799 800 801 802 !!-- End of declarations803 804 !----------------------------------------------------------------------------------------------805 ! 1) Define a variable equal to a_i*T_su806 !----------------------------------------------------------------------------------------------785 zdaice_negative , & ! true if daice < -puny 786 zdvice_negative , & ! true if dvice < -puny 787 zdaice_greater_aicen , & ! true if daice > aicen 788 zdvice_greater_vicen ! true if dvice > vicen 789 790 REAL(wp) :: & ! constant values 791 zeps = 1.0e-10 792 793 !!-- End of declarations 794 795 !---------------------------------------------------------------------------------------------- 796 ! 1) Define a variable equal to a_i*T_su 797 !---------------------------------------------------------------------------------------------- 807 798 808 799 DO jl = klbnd, kubnd … … 814 805 END DO ! jl 815 806 816 !----------------------------------------------------------------------------------------------817 ! 2) Check for daice or dvice out of range, allowing for roundoff error818 !----------------------------------------------------------------------------------------------807 !---------------------------------------------------------------------------------------------- 808 ! 2) Check for daice or dvice out of range, allowing for roundoff error 809 !---------------------------------------------------------------------------------------------- 819 810 ! Note: zdaice < 0 or zdvice < 0 usually happens when category jl 820 811 ! has a small area, with h(n) very close to a boundary. Then … … 834 825 DO ji = 1, jpi 835 826 836 IF (zdonor(ji,jj,jl) .GT. 0) THEN 837 jl1 = zdonor(ji,jj,jl) 838 839 IF (zdaice(ji,jj,jl) .LT. 0.0) THEN 840 IF (zdaice(ji,jj,jl) .GT. -zeps) THEN 841 IF ( ( jl1.EQ.jl .AND. ht_i(ji,jj,jl1) .GT. hi_max(jl) ) & 842 .OR. & 843 ( jl1.EQ.jl+1 .AND. ht_i(ji,jj,jl1) .LE. hi_max(jl) ) & 844 ) THEN 845 zdaice(ji,jj,jl) = a_i(ji,jj,jl1) ! shift entire category 846 zdvice(ji,jj,jl) = v_i(ji,jj,jl1) 827 IF (zdonor(ji,jj,jl) .GT. 0) THEN 828 jl1 = zdonor(ji,jj,jl) 829 830 IF (zdaice(ji,jj,jl) .LT. 0.0) THEN 831 IF (zdaice(ji,jj,jl) .GT. -zeps) THEN 832 IF ( ( jl1.EQ.jl .AND. ht_i(ji,jj,jl1) .GT. hi_max(jl) ) & 833 .OR. & 834 ( jl1.EQ.jl+1 .AND. ht_i(ji,jj,jl1) .LE. hi_max(jl) ) & 835 ) THEN 836 zdaice(ji,jj,jl) = a_i(ji,jj,jl1) ! shift entire category 837 zdvice(ji,jj,jl) = v_i(ji,jj,jl1) 838 ELSE 839 zdaice(ji,jj,jl) = 0.0 ! shift no ice 840 zdvice(ji,jj,jl) = 0.0 841 ENDIF 847 842 ELSE 848 zdaice(ji,jj,jl) = 0.0 ! shift no ice 849 zdvice(ji,jj,jl) = 0.0 843 zdaice_negative = .true. 850 844 ENDIF 851 ELSE852 zdaice_negative = .true.853 845 ENDIF 854 ENDIF 855 856 IF (zdvice(ji,jj,jl) .LT. 0.0) THEN 857 IF (zdvice(ji,jj,jl) .GT. -zeps ) THEN 858 IF ( ( jl1.EQ.jl .AND. ht_i(ji,jj,jl1).GT.hi_max(jl) ) & 859 .OR. & 860 ( jl1.EQ.jl+1 .AND. ht_i(ji,jj,jl1) .LE. hi_max(jl) ) & 861 ) THEN 862 zdaice(ji,jj,jl) = a_i(ji,jj,jl1) ! shift entire category 846 847 IF (zdvice(ji,jj,jl) .LT. 0.0) THEN 848 IF (zdvice(ji,jj,jl) .GT. -zeps ) THEN 849 IF ( ( jl1.EQ.jl .AND. ht_i(ji,jj,jl1).GT.hi_max(jl) ) & 850 .OR. & 851 ( jl1.EQ.jl+1 .AND. ht_i(ji,jj,jl1) .LE. hi_max(jl) ) & 852 ) THEN 853 zdaice(ji,jj,jl) = a_i(ji,jj,jl1) ! shift entire category 854 zdvice(ji,jj,jl) = v_i(ji,jj,jl1) 855 ELSE 856 zdaice(ji,jj,jl) = 0.0 ! shift no ice 857 zdvice(ji,jj,jl) = 0.0 858 ENDIF 859 ELSE 860 zdvice_negative = .true. 861 ENDIF 862 ENDIF 863 864 ! If daice is close to aicen, set daice = aicen. 865 IF (zdaice(ji,jj,jl) .GT. a_i(ji,jj,jl1) - zeps ) THEN 866 IF (zdaice(ji,jj,jl) .LT. a_i(ji,jj,jl1)+zeps) THEN 867 zdaice(ji,jj,jl) = a_i(ji,jj,jl1) 863 868 zdvice(ji,jj,jl) = v_i(ji,jj,jl1) 864 869 ELSE 865 zdaice(ji,jj,jl) = 0.0 ! shift no ice 866 zdvice(ji,jj,jl) = 0.0 870 zdaice_greater_aicen = .true. 867 871 ENDIF 868 ELSE869 zdvice_negative = .true.870 872 ENDIF 871 ENDIF 872 873 ! If daice is close to aicen, set daice = aicen. 874 IF (zdaice(ji,jj,jl) .GT. a_i(ji,jj,jl1) - zeps ) THEN 875 IF (zdaice(ji,jj,jl) .LT. a_i(ji,jj,jl1)+zeps) THEN 876 zdaice(ji,jj,jl) = a_i(ji,jj,jl1) 877 zdvice(ji,jj,jl) = v_i(ji,jj,jl1) 878 ELSE 879 zdaice_greater_aicen = .true. 873 874 IF (zdvice(ji,jj,jl) .GT. v_i(ji,jj,jl1)-zeps) THEN 875 IF (zdvice(ji,jj,jl) .LT. v_i(ji,jj,jl1)+zeps) THEN 876 zdaice(ji,jj,jl) = a_i(ji,jj,jl1) 877 zdvice(ji,jj,jl) = v_i(ji,jj,jl1) 878 ELSE 879 zdvice_greater_vicen = .true. 880 ENDIF 880 881 ENDIF 881 ENDIF 882 883 IF (zdvice(ji,jj,jl) .GT. v_i(ji,jj,jl1)-zeps) THEN 884 IF (zdvice(ji,jj,jl) .LT. v_i(ji,jj,jl1)+zeps) THEN 885 zdaice(ji,jj,jl) = a_i(ji,jj,jl1) 886 zdvice(ji,jj,jl) = v_i(ji,jj,jl1) 887 ELSE 888 zdvice_greater_vicen = .true. 889 ENDIF 890 ENDIF 891 892 ENDIF ! donor > 0 893 END DO ! i 882 883 ENDIF ! donor > 0 884 END DO ! i 894 885 END DO ! j 895 886 896 887 END DO !jl 897 888 898 !-------------------------------------------------------------------------------899 ! 3) Transfer volume and energy between categories900 !-------------------------------------------------------------------------------889 !------------------------------------------------------------------------------- 890 ! 3) Transfer volume and energy between categories 891 !------------------------------------------------------------------------------- 901 892 902 893 DO jl = klbnd, kubnd - 1 … … 1012 1003 DO jl = klbnd, kubnd 1013 1004 DO jj = 1, jpj 1014 DO ji = 1, jpi1015 IF ( a_i(ji,jj,jl) .GT. zeps ) THEN1016 ht_i(ji,jj,jl) = v_i(ji,jj,jl) / a_i(ji,jj,jl)1017 t_su(ji,jj,jl) = zaTsfn(ji,jj,jl) / a_i(ji,jj,jl)1018 zindsn = 1.0 - MAX(0.0,SIGN(1.0,-v_s(ji,jj,jl))) !0 if no ice and 1 if yes1019 ELSE1020 ht_i(ji,jj,jl) = 0.01021 t_su(ji,jj,jl) = rtt1022 ENDIF1023 END DO ! ji1005 DO ji = 1, jpi 1006 IF ( a_i(ji,jj,jl) .GT. zeps ) THEN 1007 ht_i(ji,jj,jl) = v_i(ji,jj,jl) / a_i(ji,jj,jl) 1008 t_su(ji,jj,jl) = zaTsfn(ji,jj,jl) / a_i(ji,jj,jl) 1009 zindsn = 1.0 - MAX(0.0,SIGN(1.0,-v_s(ji,jj,jl))) !0 if no ice and 1 if yes 1010 ELSE 1011 ht_i(ji,jj,jl) = 0.0 1012 t_su(ji,jj,jl) = rtt 1013 ENDIF 1014 END DO ! ji 1024 1015 END DO ! jj 1025 1016 END DO ! jl 1026 1017 1027 END SUBROUTINE lim_itd_shiftice 1028 1029 !---------------------------------------------------------------------------------------- 1030 !---------------------------------------------------------------------------------------- 1031 1032 SUBROUTINE lim_itd_th_reb(klbnd, kubnd, ntyp) 1033 !!------------------------------------------------------------------ 1034 !! *** ROUTINE lim_itd_th_reb *** 1035 !! ** Purpose : rebin - rebins thicknesses into defined categories 1036 !! 1037 !! ** Method : 1038 !! 1039 !! ** Arguments : 1040 !! 1041 !! ** Inputs / Ouputs : (global commons) 1042 !! 1043 !! ** External : 1044 !! 1045 !! ** References : 1046 !! 1047 !! ** History : (2005) Translation from CICE 1048 !! (2006) Adaptation to include salt, age and types 1049 !! (2007) Mass conservation checked 1050 !! 1051 !! authors: William H. Lipscomb, LANL, Elizabeth C. Hunke, LANL 1052 !! (01-2006) Martin Vancoppenolle (adaptation) 1053 !! 1054 !!------------------------------------------------------------------ 1055 !! * Arguments 1018 END SUBROUTINE lim_itd_shiftice 1019 ! 1020 1021 SUBROUTINE lim_itd_th_reb(klbnd, kubnd, ntyp) 1022 !!------------------------------------------------------------------ 1023 !! *** ROUTINE lim_itd_th_reb *** 1024 !! ** Purpose : rebin - rebins thicknesses into defined categories 1025 !! 1026 !! ** Method : 1027 !! 1028 !! ** Arguments : 1029 !! 1030 !! ** Inputs / Ouputs : (global commons) 1031 !! 1032 !! ** External : 1033 !! 1034 !! ** References : 1035 !! 1036 !! ** History : (2005) Translation from CICE 1037 !! (2006) Adaptation to include salt, age and types 1038 !! (2007) Mass conservation checked 1039 !! 1040 !! authors: William H. Lipscomb, LANL, Elizabeth C. Hunke, LANL 1041 !! (01-2006) Martin Vancoppenolle (adaptation) 1042 !! 1043 !!------------------------------------------------------------------ 1044 !! * Arguments 1056 1045 INTEGER , INTENT (in) :: & 1057 1058 1059 1046 klbnd , & ! Start thickness category index point 1047 kubnd , & ! End point on which the the computation is applied 1048 ntyp ! number of the ice type involved in the rebinning process 1060 1049 1061 1050 INTEGER :: & … … 1081 1070 vt_s_init, vt_s_final ! snow volume summed over categories 1082 1071 1083 1084 1085 !!-- End of declarations1086 !------------------------------------------------------------------------------1087 1088 ! ! conservation check1072 CHARACTER (len = 15) :: fieldid 1073 1074 !!-- End of declarations 1075 !------------------------------------------------------------------------------ 1076 1077 ! ! conservation check 1089 1078 IF ( con_i ) THEN 1090 1079 CALL lim_column_sum (jpl, v_i, vt_i_init) … … 1092 1081 ENDIF 1093 1082 1094 !1095 !------------------------------------------------------------------------------1096 ! 1) Compute ice thickness.1097 !------------------------------------------------------------------------------1083 ! 1084 !------------------------------------------------------------------------------ 1085 ! 1) Compute ice thickness. 1086 !------------------------------------------------------------------------------ 1098 1087 DO jl = klbnd, kubnd 1099 1088 DO jj = 1, jpj 1100 DO ji = 1, jpi1101 IF (a_i(ji,jj,jl) .GT. zeps) THEN1102 ht_i(ji,jj,jl) = v_i(ji,jj,jl) / a_i(ji,jj,jl)1103 ELSE1104 ht_i(ji,jj,jl) = 0.01105 ENDIF1106 END DO ! i1089 DO ji = 1, jpi 1090 IF (a_i(ji,jj,jl) .GT. zeps) THEN 1091 ht_i(ji,jj,jl) = v_i(ji,jj,jl) / a_i(ji,jj,jl) 1092 ELSE 1093 ht_i(ji,jj,jl) = 0.0 1094 ENDIF 1095 END DO ! i 1107 1096 END DO ! j 1108 1097 END DO ! n 1109 1098 1110 !------------------------------------------------------------------------------1111 ! 2) Make sure thickness of cat klbnd is at least hi_max_typ(klbnd)1112 !------------------------------------------------------------------------------1099 !------------------------------------------------------------------------------ 1100 ! 2) Make sure thickness of cat klbnd is at least hi_max_typ(klbnd) 1101 !------------------------------------------------------------------------------ 1113 1102 DO jj = 1, jpj 1114 DO ji = 1, jpi 1115 1116 IF (a_i(ji,jj,klbnd) > zeps) THEN 1117 IF (ht_i(ji,jj,klbnd) .LE. hi_max_typ(0,ntyp) .AND. hi_max_typ(0,ntyp) .GT. 0.0 ) THEN 1118 a_i(ji,jj,klbnd) = v_i(ji,jj,klbnd) / hi_max_typ(0,ntyp) 1119 ht_i(ji,jj,klbnd) = hi_max_typ(0,ntyp) 1103 DO ji = 1, jpi 1104 1105 IF (a_i(ji,jj,klbnd) > zeps) THEN 1106 IF (ht_i(ji,jj,klbnd) .LE. hi_max_typ(0,ntyp) .AND. hi_max_typ(0,ntyp) .GT. 0.0 ) THEN 1107 a_i(ji,jj,klbnd) = v_i(ji,jj,klbnd) / hi_max_typ(0,ntyp) 1108 ht_i(ji,jj,klbnd) = hi_max_typ(0,ntyp) 1109 ENDIF 1120 1110 ENDIF 1121 ENDIF 1122 END DO ! i 1111 END DO ! i 1123 1112 END DO ! j 1124 1113 1125 !------------------------------------------------------------------------------1126 ! 3) If a category thickness is not in bounds, shift the1127 ! entire area, volume, and energy to the neighboring category1128 !------------------------------------------------------------------------------1114 !------------------------------------------------------------------------------ 1115 ! 3) If a category thickness is not in bounds, shift the 1116 ! entire area, volume, and energy to the neighboring category 1117 !------------------------------------------------------------------------------ 1129 1118 !------------------------- 1130 1119 ! Initialize shift arrays … … 1133 1122 DO jl = klbnd, kubnd 1134 1123 DO jj = 1, jpj 1135 DO ji = 1, jpi1136 zdonor(ji,jj,jl) = 01137 zdaice(ji,jj,jl) = 0.01138 zdvice(ji,jj,jl) = 0.01139 END DO1124 DO ji = 1, jpi 1125 zdonor(ji,jj,jl) = 0 1126 zdaice(ji,jj,jl) = 0.0 1127 zdvice(ji,jj,jl) = 0.0 1128 END DO 1140 1129 END DO 1141 1130 END DO … … 1147 1136 DO jl = klbnd, kubnd - 1 ! loop over category boundaries 1148 1137 1149 !---------------------------------------1150 ! identify thicknesses that are too big1151 !---------------------------------------1138 !--------------------------------------- 1139 ! identify thicknesses that are too big 1140 !--------------------------------------- 1152 1141 zshiftflag = 0 1153 1142 … … 1166 1155 IF ( zshiftflag == 1 ) THEN 1167 1156 1168 !------------------------------1169 ! Shift ice between categories1170 !------------------------------1157 !------------------------------ 1158 ! Shift ice between categories 1159 !------------------------------ 1171 1160 CALL lim_itd_shiftice (klbnd, kubnd, zdonor, zdaice, zdvice) 1172 1173 !------------------------1174 ! Reset shift parameters1175 !------------------------1161 1162 !------------------------ 1163 ! Reset shift parameters 1164 !------------------------ 1176 1165 DO jj = 1, jpj 1177 DO ji = 1, jpi1178 zdonor(ji,jj,jl) = 01179 zdaice(ji,jj,jl) = 0.01180 zdvice(ji,jj,jl) = 0.01181 END DO1166 DO ji = 1, jpi 1167 zdonor(ji,jj,jl) = 0 1168 zdaice(ji,jj,jl) = 0.0 1169 zdvice(ji,jj,jl) = 0.0 1170 END DO 1182 1171 END DO 1183 1172 … … 1192 1181 DO jl = kubnd - 1, 1, -1 ! loop over category boundaries 1193 1182 1194 !-----------------------------------------1195 ! Identify thicknesses that are too small1196 !-----------------------------------------1183 !----------------------------------------- 1184 ! Identify thicknesses that are too small 1185 !----------------------------------------- 1197 1186 zshiftflag = 0 1198 1187 … … 1213 1202 IF (zshiftflag==1) THEN 1214 1203 1215 !------------------------------1216 ! Shift ice between categories1217 !------------------------------1204 !------------------------------ 1205 ! Shift ice between categories 1206 !------------------------------ 1218 1207 CALL lim_itd_shiftice (klbnd, kubnd, zdonor, zdaice, zdvice) 1219 1208 1220 !------------------------1221 ! Reset shift parameters1222 !------------------------1209 !------------------------ 1210 ! Reset shift parameters 1211 !------------------------ 1223 1212 DO jj = 1, jpj 1224 DO ji = 1, jpi 1225 zdonor(ji,jj,jl) = 0 1226 zdaice(ji,jj,jl) = 0.0 1227 zdvice(ji,jj,jl) = 0.0 1213 DO ji = 1, jpi 1214 zdonor(ji,jj,jl) = 0 1215 zdaice(ji,jj,jl) = 0.0 1216 zdvice(ji,jj,jl) = 0.0 1217 END DO 1228 1218 END DO 1229 END DO1230 1219 1231 1220 ENDIF ! zshiftflag … … 1233 1222 END DO ! jl 1234 1223 1235 !------------------------------------------------------------------------------1236 ! 4) Conservation check1237 !------------------------------------------------------------------------------1238 1239 IF ( con_i ) THEN1240 CALL lim_column_sum (jpl, v_i, vt_i_final)1241 fieldid = ' v_i : limitd_reb '1242 CALL lim_cons_check (vt_i_init, vt_i_final, 1.0e-6, fieldid)1243 1244 CALL lim_column_sum (jpl, v_s, vt_s_final)1245 fieldid = ' v_s : limitd_reb '1246 CALL lim_cons_check (vt_s_init, vt_s_final, 1.0e-6, fieldid)1247 ENDIF1248 1249 1224 !------------------------------------------------------------------------------ 1225 ! 4) Conservation check 1226 !------------------------------------------------------------------------------ 1227 1228 IF ( con_i ) THEN 1229 CALL lim_column_sum (jpl, v_i, vt_i_final) 1230 fieldid = ' v_i : limitd_reb ' 1231 CALL lim_cons_check (vt_i_init, vt_i_final, 1.0e-6, fieldid) 1232 1233 CALL lim_column_sum (jpl, v_s, vt_s_final) 1234 fieldid = ' v_s : limitd_reb ' 1235 CALL lim_cons_check (vt_s_init, vt_s_final, 1.0e-6, fieldid) 1236 ENDIF 1237 1238 END SUBROUTINE lim_itd_th_reb 1250 1239 1251 1240 #else … … 1268 1257 END SUBROUTINE lim_itd_th_reb 1269 1258 #endif 1270 1259 END MODULE limitd_th -
trunk/NEMO/LIM_SRC_3/limmsh.F90
r888 r921 53 53 REAL(wp), DIMENSION(jpi,jpj) :: & 54 54 zd2d1 , zd1d2 ! Derivative of zh2 (resp. zh1) in the x direction 55 55 ! ! (resp. y direction) (defined at the center) 56 56 REAL(wp) :: & 57 57 zh1p , zh2p , & ! Idem zh1, zh2 for the bottom left corner of the grid … … 65 65 WRITE(numout,*) '~~~~~~~' 66 66 ENDIF 67 67 68 68 !---------------------------------------------------------- 69 69 ! Initialization of local and some global (common) variables 70 70 !------------------------------------------------------------------ 71 71 72 72 njeq = INT( jpj / 2 ) !i bug mpp potentiel 73 73 njeqm1 = njeq - 1 74 74 75 75 fcor(:,:) = 2. * omega * SIN( gphit(:,:) * rad ) ! coriolis factor 76 76 77 77 IF( fcor(1,1) * fcor(1,nlcj) < 0.e0 ) THEN ! local domain include both hemisphere 78 78 l_jeq = .TRUE. … … 97 97 ! For each grid, definition of geometric tables 98 98 !------------------------------------------------------------------ 99 99 100 100 !------------------- 101 101 ! Conventions : ! … … 106 106 ! 3 = corner SW x(i-1/2),y(j-1/2) 107 107 !------------------- 108 !!ibug ???108 !!ibug ??? 109 109 akappa(:,:,:,:) = 0.e0 110 110 wght(:,:,:,:) = 0.e0 … … 112 112 tmu(:,:) = 0.e0 113 113 tmv(:,:) = 0.0e0 ! CGrid EVP 114 !!i114 !!i 115 115 ! metric coefficients for sea ice dynamic 116 116 !---------------------------------------- … … 130 130 akappa(:,:,2,1) = zd2d1(:,:) / ( 4.0 * e1t(:,:) * e2t(:,:) ) 131 131 akappa(:,:,2,2) = 1.0 / ( 2.0 * e2t(:,:) ) 132 132 133 133 ! ! weights (wght) 134 134 DO jj = 2, jpj … … 146 146 CALL lbc_lnk( wght(:,:,2,1), 'I', 1. ) ! but it is never used 147 147 CALL lbc_lnk( wght(:,:,2,2), 'I', 1. ) 148 148 149 149 ! Coefficients for divergence of the stress tensor 150 150 !------------------------------------------------- … … 209 209 CALL lbc_lnk( alambd(:,:,2,1,1,1), 'I', 1. ) ! 210 210 CALL lbc_lnk( alambd(:,:,2,1,1,2), 'I', 1. ) ! 211 211 212 212 213 213 ! Initialization of ice masks 214 214 !---------------------------- 215 215 216 216 tms(:,:) = tmask(:,:,1) ! ice T-point : use surface tmask 217 217 218 ! tmu(:,1) = 0.e0219 ! tmu(1,:) = 0.e0220 ! tmv(:,1) = 0.e0221 ! tmv(1,:) = 0.e0218 ! tmu(:,1) = 0.e0 219 ! tmu(1,:) = 0.e0 220 ! tmv(:,1) = 0.e0 221 ! tmv(1,:) = 0.e0 222 222 223 223 DO jj = 1, jpj - 1 … … 226 226 tmv(ji,jj) = tms(ji,jj) * tms(ji,jj+1) 227 227 tmf(ji,jj) = tms(ji,jj) * tms(ji+1,jj) * tms(ji,jj+1) * & 228 229 END DO 230 END DO 231 228 tms(ji+1,jj+1) 229 END DO 230 END DO 231 232 232 !--lateral boundary conditions 233 233 CALL lbc_lnk( tmu(:,:), 'U', 1. ) 234 234 CALL lbc_lnk( tmv(:,:), 'V', 1. ) 235 235 CALL lbc_lnk( tmf(:,:), 'F', 1. ) 236 236 237 237 ! unmasked and masked area of T-grid cell 238 238 area(:,:) = e1t(:,:) * e2t(:,:) 239 239 240 240 END SUBROUTINE lim_msh 241 241 -
trunk/NEMO/LIM_SRC_3/limrhg.F90
r888 r921 139 139 zc1 , & !: ice mass 140 140 zusw , & !: temporary weight for the computation 141 141 !: of ice strength 142 142 u_oce1, v_oce1, & !: ocean u/v component on U points 143 143 u_oce2, v_oce2, & !: ocean u/v component on V points … … 180 180 zresr !: Local error on velocity 181 181 182 !183 !------------------------------------------------------------------------------!184 ! 1) Ice-Snow mass (zc1), ice strength (zpresh) !185 !------------------------------------------------------------------------------!186 !182 ! 183 !------------------------------------------------------------------------------! 184 ! 1) Ice-Snow mass (zc1), ice strength (zpresh) ! 185 !------------------------------------------------------------------------------! 186 ! 187 187 ! Put every vector to 0 188 188 zpresh(:,:) = 0.0 ; zc1(:,:) = 0.0 … … 203 203 ! tmi = 1 where there is ice or on land 204 204 tmi(ji,jj) = 1.0 - ( 1.0 - MAX( 0.0 , SIGN ( 1.0 , vt_i(ji,jj) - & 205 205 epsd ) ) ) * tms(ji,jj) 206 206 END DO 207 207 END DO … … 213 213 !CDIR NOVERRCHK 214 214 DO ji = 2, jpim1 !RB caution no fs_ (ji+1,jj+1) 215 216 217 218 219 220 221 222 223 224 215 zstms = tms(ji+1,jj+1) * wght(ji+1,jj+1,2,2) + & 216 & tms(ji,jj+1) * wght(ji+1,jj+1,1,2) + & 217 & tms(ji+1,jj) * wght(ji+1,jj+1,2,1) + & 218 & tms(ji,jj) * wght(ji+1,jj+1,1,1) 219 zusw(ji,jj) = 1.0 / MAX( zstms, epsd ) 220 zpreshc(ji,jj) = ( zpresh(ji+1,jj+1) * wght(ji+1,jj+1,2,2) + & 221 & zpresh(ji,jj+1) * wght(ji+1,jj+1,1,2) + & 222 & zpresh(ji+1,jj) * wght(ji+1,jj+1,2,1) + & 223 & zpresh(ji,jj) * wght(ji+1,jj+1,1,1) & 224 & ) * zusw(ji,jj) 225 225 END DO 226 226 END DO 227 227 228 228 CALL lbc_lnk( zpreshc(:,:), 'F', 1. ) 229 !230 !------------------------------------------------------------------------------!231 ! 2) Wind / ocean stress, mass terms, coriolis terms232 !------------------------------------------------------------------------------!233 !229 ! 230 !------------------------------------------------------------------------------! 231 ! 2) Wind / ocean stress, mass terms, coriolis terms 232 !------------------------------------------------------------------------------! 233 ! 234 234 ! Wind stress, coriolis and mass terms on the sides of the squares 235 235 ! zfrld1: lead fraction on U-points … … 244 244 ! u_oce2: ocean u component on v points 245 245 ! v_oce2: ocean v component on v points 246 246 247 247 DO jj = k_j1+1, k_jpj-1 248 248 DO ji = fs_2, fs_jpim1 … … 255 255 ! Leads area. 256 256 zfrld1(ji,jj) = ( zt12 * ( 1.0 - at_i(ji,jj) ) + & 257 & zt11 * ( 1.0 - at_i(ji+1,jj) ) ) / ( zt11 + zt12 + epsd )257 & zt11 * ( 1.0 - at_i(ji+1,jj) ) ) / ( zt11 + zt12 + epsd ) 258 258 zfrld2(ji,jj) = ( zt22 * ( 1.0 - at_i(ji,jj) ) + & 259 & zt21 * ( 1.0 - at_i(ji,jj+1) ) ) / ( zt21 + zt22 + epsd )259 & zt21 * ( 1.0 - at_i(ji,jj+1) ) ) / ( zt21 + zt22 + epsd ) 260 260 261 261 ! Mass, coriolis coeff. and currents … … 263 263 zmass2(ji,jj) = ( zt22*zc1(ji,jj) + zt21*zc1(ji,jj+1) ) / (zt21+zt22+epsd) 264 264 zcorl1(ji,jj) = zmass1(ji,jj) * ( e1t(ji+1,jj)*fcor(ji,jj) + & 265 266 265 e1t(ji,jj)*fcor(ji+1,jj) ) & 266 / (e1t(ji,jj) + e1t(ji+1,jj) + epsd ) 267 267 zcorl2(ji,jj) = zmass2(ji,jj) * ( e2t(ji,jj+1)*fcor(ji,jj) + & 268 269 268 e2t(ji,jj)*fcor(ji,jj+1) ) & 269 / ( e2t(ji,jj+1) + e2t(ji,jj) + epsd ) 270 270 ! 271 271 u_oce1(ji,jj) = u_oce(ji,jj) … … 274 274 ! Ocean has no slip boundary condition 275 275 v_oce1(ji,jj) = 0.5*( (v_oce(ji,jj)+v_oce(ji,jj-1))*e1t(ji,jj) & 276 277 276 & +(v_oce(ji+1,jj)+v_oce(ji+1,jj-1))*e1t(ji+1,jj)) & 277 & /(e1t(ji+1,jj)+e1t(ji,jj)) * tmu(ji,jj) 278 278 279 279 u_oce2(ji,jj) = 0.5*((u_oce(ji,jj)+u_oce(ji-1,jj))*e2t(ji,jj) & 280 281 280 & +(u_oce(ji,jj+1)+u_oce(ji-1,jj+1))*e2t(ji,jj+1)) & 281 & / (e2t(ji,jj+1)+e2t(ji,jj)) * tmv(ji,jj) 282 282 283 283 ! Wind stress. … … 302 302 END DO 303 303 304 !305 !------------------------------------------------------------------------------!306 ! 3) Solution of the momentum equation, iterative procedure307 !------------------------------------------------------------------------------!308 !304 ! 305 !------------------------------------------------------------------------------! 306 ! 3) Solution of the momentum equation, iterative procedure 307 !------------------------------------------------------------------------------! 308 ! 309 309 ! Time step for subcycling 310 310 dtevp = rdt_ice / nevp … … 319 319 zs12(:,:) = stress12_i(:,:) 320 320 321 321 !----------------------! 322 322 DO jter = 1 , nevp ! loop over jter ! 323 323 !----------------------! 324 324 DO jj = k_j1, k_jpj-1 325 325 zu_ice(:,jj) = u_ice(:,jj) ! velocity at previous time step 326 326 zv_ice(:,jj) = v_ice(:,jj) 327 END DO 327 END DO 328 328 329 329 DO jj = k_j1+1, k_jpj-1 330 330 DO ji = fs_2, fs_jpim1 331 331 332 !333 !- Divergence, tension and shear (Section a. Appendix B of Hunke & Dukowicz, 2002)334 !- zdd(:,:), zdt(:,:): divergence and tension at centre of grid cells335 !- zds(:,:): shear on northeast corner of grid cells336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 !CDIR NOVERRCHK 394 395 !CDIR NOVERRCHK 396 397 398 399 400 401 402 403 404 405 406 407 & ( zdt(ji,jj)*zdt(ji,jj) + zdst*zdst ) * usecc2 )408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 !CDIR NOVERRCHK 431 432 !CDIR NOVERRCHK 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 332 ! 333 !- Divergence, tension and shear (Section a. Appendix B of Hunke & Dukowicz, 2002) 334 !- zdd(:,:), zdt(:,:): divergence and tension at centre of grid cells 335 !- zds(:,:): shear on northeast corner of grid cells 336 ! 337 !- IMPORTANT REMINDER: Dear Gurvan, note that, the way these terms are coded, 338 ! there are many repeated calculations. 339 ! Speed could be improved by regrouping terms. For 340 ! the moment, however, the stress is on clarity of coding to avoid 341 ! bugs (Martin, for Miguel). 342 ! 343 !- ALSO: arrays zdd, zdt, zds and delta could 344 ! be removed in the future to minimise memory demand. 345 ! 346 !- MORE NOTES: Note that we are calculating deformation rates and stresses on the corners of 347 ! grid cells, exactly as in the B grid case. For simplicity, the indexation on 348 ! the corners is the same as in the B grid. 349 ! 350 ! 351 zdd(ji,jj) = ( e2u(ji,jj)*u_ice(ji,jj) & 352 & -e2u(ji-1,jj)*u_ice(ji-1,jj) & 353 & +e1v(ji,jj)*v_ice(ji,jj) & 354 & -e1v(ji,jj-1)*v_ice(ji,jj-1) & 355 & ) & 356 & / area(ji,jj) 357 358 zdt(ji,jj) = ( ( u_ice(ji,jj)/e2u(ji,jj) & 359 & -u_ice(ji-1,jj)/e2u(ji-1,jj) & 360 & )*e2t(ji,jj)*e2t(ji,jj) & 361 & -( v_ice(ji,jj)/e1v(ji,jj) & 362 & -v_ice(ji,jj-1)/e1v(ji,jj-1) & 363 & )*e1t(ji,jj)*e1t(ji,jj) & 364 & ) & 365 & / area(ji,jj) 366 367 ! 368 zds(ji,jj) = ( ( u_ice(ji,jj+1)/e1u(ji,jj+1) & 369 & -u_ice(ji,jj)/e1u(ji,jj) & 370 & )*e1f(ji,jj)*e1f(ji,jj) & 371 & +( v_ice(ji+1,jj)/e2v(ji+1,jj) & 372 & -v_ice(ji,jj)/e2v(ji,jj) & 373 & )*e2f(ji,jj)*e2f(ji,jj) & 374 & ) & 375 & / ( e1f(ji,jj) * e2f(ji,jj) ) * ( 2.0 - tmf(ji,jj) ) & 376 & * tmi(ji,jj) * tmi(ji,jj+1) & 377 & * tmi(ji+1,jj) * tmi(ji+1,jj+1) 378 379 380 v_ice1(ji,jj) = 0.5*( (v_ice(ji,jj)+v_ice(ji,jj-1))*e1t(ji+1,jj) & 381 & +(v_ice(ji+1,jj)+v_ice(ji+1,jj-1))*e1t(ji,jj)) & 382 & /(e1t(ji+1,jj)+e1t(ji,jj)) * tmu(ji,jj) 383 384 u_ice2(ji,jj) = 0.5*( (u_ice(ji,jj)+u_ice(ji-1,jj))*e2t(ji,jj+1) & 385 & +(u_ice(ji,jj+1)+u_ice(ji-1,jj+1))*e2t(ji,jj)) & 386 & /(e2t(ji,jj+1)+e2t(ji,jj)) * tmv(ji,jj) 387 388 END DO 389 END DO 390 CALL lbc_lnk( v_ice1(:,:), 'U', -1. ) 391 CALL lbc_lnk( u_ice2(:,:), 'V', -1. ) 392 393 !CDIR NOVERRCHK 394 DO jj = k_j1+1, k_jpj-1 395 !CDIR NOVERRCHK 396 DO ji = fs_2, fs_jpim1 397 398 !- Calculate Delta at centre of grid cells 399 zdst = ( e2u( ji , jj ) * v_ice1(ji,jj) & 400 & - e2u( ji-1, jj ) * v_ice1(ji-1,jj) & 401 & + e1v( ji , jj ) * u_ice2(ji,jj) & 402 & - e1v( ji , jj-1 ) * u_ice2(ji,jj-1) & 403 & ) & 404 & / area(ji,jj) 405 406 delta = SQRT( zdd(ji,jj)*zdd(ji,jj) + & 407 & ( zdt(ji,jj)*zdt(ji,jj) + zdst*zdst ) * usecc2 ) 408 deltat(ji,jj) = MAX( SQRT(zdd(ji,jj)**2 + & 409 (zdt(ji,jj)**2 + zdst**2)*usecc2), creepl ) 410 411 !-Calculate stress tensor components zs1 and zs2 412 !-at centre of grid cells (see section 3.5 of CICE user's guide). 413 zs1(ji,jj) = ( zs1(ji,jj) & 414 & - dtotel*( ( 1.0 - alphaevp) * zs1(ji,jj) + & 415 & ( delta / deltat(ji,jj) - zdd(ji,jj) / deltat(ji,jj) ) & 416 * zpresh(ji,jj) ) ) & 417 & / ( 1.0 + alphaevp * dtotel ) 418 419 zs2(ji,jj) = ( zs2(ji,jj) & 420 & - dtotel*((1.0-alphaevp)*ecc2*zs2(ji,jj) - & 421 zdt(ji,jj)/deltat(ji,jj)*zpresh(ji,jj)) ) & 422 & / ( 1.0 + alphaevp*ecc2*dtotel ) 423 424 END DO 425 END DO 426 427 CALL lbc_lnk( zs1(:,:), 'T', 1. ) 428 CALL lbc_lnk( zs2(:,:), 'T', 1. ) 429 430 !CDIR NOVERRCHK 431 DO jj = k_j1+1, k_jpj-1 432 !CDIR NOVERRCHK 433 DO ji = fs_2, fs_jpim1 434 !- Calculate Delta on corners 435 zddc = ( ( v_ice1(ji,jj+1)/e1u(ji,jj+1) & 436 & -v_ice1(ji,jj)/e1u(ji,jj) & 437 & )*e1f(ji,jj)*e1f(ji,jj) & 438 & +( u_ice2(ji+1,jj)/e2v(ji+1,jj) & 439 & -u_ice2(ji,jj)/e2v(ji,jj) & 440 & )*e2f(ji,jj)*e2f(ji,jj) & 441 & ) & 442 & / ( e1f(ji,jj) * e2f(ji,jj) ) 443 444 zdtc = (-( v_ice1(ji,jj+1)/e1u(ji,jj+1) & 445 & -v_ice1(ji,jj)/e1u(ji,jj) & 446 & )*e1f(ji,jj)*e1f(ji,jj) & 447 & +( u_ice2(ji+1,jj)/e2v(ji+1,jj) & 448 & -u_ice2(ji,jj)/e2v(ji,jj) & 449 & )*e2f(ji,jj)*e2f(ji,jj) & 450 & ) & 451 & / ( e1f(ji,jj) * e2f(ji,jj) ) 452 453 deltac(ji,jj) = SQRT(zddc**2+(zdtc**2+zds(ji,jj)**2)*usecc2) + creepl 454 455 !-Calculate stress tensor component zs12 at corners (see section 3.5 of CICE user's guide). 456 zs12(ji,jj) = ( zs12(ji,jj) & 457 & - dtotel*( (1.0-alphaevp)*ecc2*zs12(ji,jj) - zds(ji,jj) / & 458 & ( 2.0*deltac(ji,jj) ) * zpreshc(ji,jj))) & 459 & / ( 1.0 + alphaevp*ecc2*dtotel ) 460 461 END DO ! ji 462 END DO ! jj 463 464 CALL lbc_lnk( zs12(:,:), 'F', 1. ) 465 466 ! Ice internal stresses (Appendix C of Hunke and Dukowicz, 2002) 467 DO jj = k_j1+1, k_jpj-1 468 DO ji = fs_2, fs_jpim1 469 !- contribution of zs1, zs2 and zs12 to zf1 470 zf1(ji,jj) = 0.5*( (zs1(ji+1,jj)-zs1(ji,jj))*e2u(ji,jj) & 471 & +(zs2(ji+1,jj)*e2t(ji+1,jj)**2-zs2(ji,jj)*e2t(ji,jj)**2)/e2u(ji,jj) & 472 & +2.0*(zs12(ji,jj)*e1f(ji,jj)**2-zs12(ji,jj-1)*e1f(ji,jj-1)**2)/e1u(ji,jj) & 473 & ) / ( e1u(ji,jj)*e2u(ji,jj) ) 474 ! contribution of zs1, zs2 and zs12 to zf2 475 zf2(ji,jj) = 0.5*( (zs1(ji,jj+1)-zs1(ji,jj))*e1v(ji,jj) & 476 & -(zs2(ji,jj+1)*e1t(ji,jj+1)**2 - zs2(ji,jj)*e1t(ji,jj)**2)/e1v(ji,jj) & 477 & + 2.0*(zs12(ji,jj)*e2f(ji,jj)**2 - & 478 zs12(ji-1,jj)*e2f(ji-1,jj)**2)/e2v(ji,jj) & 479 & ) / ( e1v(ji,jj)*e2v(ji,jj) ) 480 END DO 481 END DO 482 482 ! 483 483 ! Computation of ice velocity … … 485 485 ! Both the Coriolis term and the ice-ocean drag are solved semi-implicitly. 486 486 ! 487 488 489 !CDIR NOVERRCHK 490 491 !CDIR NOVERRCHK 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 !CDIR NOVERRCHK 515 516 !CDIR NOVERRCHK 517 518 519 520 521 522 523 524 & + (u_ice(ji,jj+1)+u_ice(ji-1,jj+1))*e2t(ji,jj+1)) &525 & /(e2t(ji,jj+1)+e2t(ji,jj)) * tmv(ji,jj)526 527 528 529 530 531 532 533 534 535 536 537 487 IF (MOD(jter,2).eq.0) THEN 488 489 !CDIR NOVERRCHK 490 DO jj = k_j1+1, k_jpj-1 491 !CDIR NOVERRCHK 492 DO ji = fs_2, fs_jpim1 493 zmask = (1.0-MAX(rzero,SIGN(rone,-zmass1(ji,jj))))*tmu(ji,jj) 494 zsang = SIGN ( 1.0 , fcor(ji,jj) ) * sangvg 495 z0 = zmass1(ji,jj)/dtevp 496 497 ! SB modif because ocean has no slip boundary condition 498 zv_ice1 = 0.5*( (v_ice(ji,jj)+v_ice(ji,jj-1))*e1t(ji,jj) & 499 & +(v_ice(ji+1,jj)+v_ice(ji+1,jj-1))*e1t(ji+1,jj)) & 500 & /(e1t(ji+1,jj)+e1t(ji,jj)) * tmu(ji,jj) 501 za = rhoco*SQRT((u_ice(ji,jj)-u_oce1(ji,jj))**2 + & 502 (zv_ice1-v_oce1(ji,jj))**2) * (1.0-zfrld1(ji,jj)) 503 zr = z0*u_ice(ji,jj) + zf1(ji,jj) + za1ct(ji,jj) + & 504 za*(cangvg*u_oce1(ji,jj)-zsang*v_oce1(ji,jj)) 505 zcca = z0+za*cangvg 506 zccb = zcorl1(ji,jj)+za*zsang 507 u_ice(ji,jj) = (zr+zccb*zv_ice1)/(zcca+epsd)*zmask 508 509 END DO 510 END DO 511 512 CALL lbc_lnk( u_ice(:,:), 'U', -1. ) 513 514 !CDIR NOVERRCHK 515 DO jj = k_j1+1, k_jpj-1 516 !CDIR NOVERRCHK 517 DO ji = fs_2, fs_jpim1 518 519 zmask = (1.0-MAX(rzero,SIGN(rone,-zmass2(ji,jj))))*tmv(ji,jj) 520 zsang = SIGN(1.0,fcor(ji,jj))*sangvg 521 z0 = zmass2(ji,jj)/dtevp 522 ! SB modif because ocean has no slip boundary condition 523 zu_ice2 = 0.5*( (u_ice(ji,jj)+u_ice(ji-1,jj))*e2t(ji,jj) & 524 & + (u_ice(ji,jj+1)+u_ice(ji-1,jj+1))*e2t(ji,jj+1)) & 525 & /(e2t(ji,jj+1)+e2t(ji,jj)) * tmv(ji,jj) 526 za = rhoco*SQRT((zu_ice2-u_oce2(ji,jj))**2 + & 527 (v_ice(ji,jj)-v_oce2(ji,jj))**2)*(1.0-zfrld2(ji,jj)) 528 zr = z0*v_ice(ji,jj) + zf2(ji,jj) + & 529 za2ct(ji,jj) + za*(cangvg*v_oce2(ji,jj)+zsang*u_oce2(ji,jj)) 530 zcca = z0+za*cangvg 531 zccb = zcorl2(ji,jj)+za*zsang 532 v_ice(ji,jj) = (zr-zccb*zu_ice2)/(zcca+epsd)*zmask 533 534 END DO 535 END DO 536 537 CALL lbc_lnk( v_ice(:,:), 'V', -1. ) 538 538 539 539 ELSE 540 540 !CDIR NOVERRCHK 541 542 !CDIR NOVERRCHK 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 !CDIR NOVERRCHK 566 567 !CDIR NOVERRCHK 568 569 570 571 572 573 ! GG Bug574 ! zv_ice1 = 0.5*( (v_ice(ji,jj)+v_ice(ji,jj-1))*e1t(ji+1,jj) &575 ! & +(v_ice(ji+1,jj)+v_ice(ji+1,jj-1))*e1t(ji,jj)) &576 ! & /(e1t(ji+1,jj)+e1t(ji,jj)) * tmu(ji,jj)577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 ENDIF594 595 IF(ln_ctl) THEN596 !--- Convergence test.597 DO jj = k_j1+1 , k_jpj-1598 zresr(:,jj) = MAX( ABS( u_ice(:,jj) - zu_ice(:,jj) ) , &599 600 END DO601 zresm = MAXVAL( zresr( 1:jpi , k_j1+1:k_jpj-1 ) )602 IF( lk_mpp ) CALL mpp_max( zresm ) ! max over the global domain603 ENDIF604 605 ! ! ==================== !541 DO jj = k_j1+1, k_jpj-1 542 !CDIR NOVERRCHK 543 DO ji = fs_2, fs_jpim1 544 zmask = (1.0-MAX(rzero,SIGN(rone,-zmass2(ji,jj))))*tmv(ji,jj) 545 zsang = SIGN(1.0,fcor(ji,jj))*sangvg 546 z0 = zmass2(ji,jj)/dtevp 547 ! SB modif because ocean has no slip boundary condition 548 zu_ice2 = 0.5*( (u_ice(ji,jj)+u_ice(ji-1,jj))*e2t(ji,jj) & 549 & +(u_ice(ji,jj+1)+u_ice(ji-1,jj+1))*e2t(ji,jj+1)) & 550 & /(e2t(ji,jj+1)+e2t(ji,jj)) * tmv(ji,jj) 551 552 za = rhoco*SQRT((zu_ice2-u_oce2(ji,jj))**2 + & 553 (v_ice(ji,jj)-v_oce2(ji,jj))**2)*(1.0-zfrld2(ji,jj)) 554 zr = z0*v_ice(ji,jj) + zf2(ji,jj) + & 555 za2ct(ji,jj) + za*(cangvg*v_oce2(ji,jj)+zsang*u_oce2(ji,jj)) 556 zcca = z0+za*cangvg 557 zccb = zcorl2(ji,jj)+za*zsang 558 v_ice(ji,jj) = (zr-zccb*zu_ice2)/(zcca+epsd)*zmask 559 560 END DO 561 END DO 562 563 CALL lbc_lnk( v_ice(:,:), 'V', -1. ) 564 565 !CDIR NOVERRCHK 566 DO jj = k_j1+1, k_jpj-1 567 !CDIR NOVERRCHK 568 DO ji = fs_2, fs_jpim1 569 zmask = (1.0-MAX(rzero,SIGN(rone,-zmass1(ji,jj))))*tmu(ji,jj) 570 zsang = SIGN(1.0,fcor(ji,jj))*sangvg 571 z0 = zmass1(ji,jj)/dtevp 572 ! SB modif because ocean has no slip boundary condition 573 ! GG Bug 574 ! zv_ice1 = 0.5*( (v_ice(ji,jj)+v_ice(ji,jj-1))*e1t(ji+1,jj) & 575 ! & +(v_ice(ji+1,jj)+v_ice(ji+1,jj-1))*e1t(ji,jj)) & 576 ! & /(e1t(ji+1,jj)+e1t(ji,jj)) * tmu(ji,jj) 577 zv_ice1 = 0.5*( (v_ice(ji,jj)+v_ice(ji,jj-1))*e1t(ji,jj) & 578 & +(v_ice(ji+1,jj)+v_ice(ji+1,jj-1))*e1t(ji+1,jj)) & 579 & /(e1t(ji+1,jj)+e1t(ji,jj)) * tmu(ji,jj) 580 581 za = rhoco*SQRT((u_ice(ji,jj)-u_oce1(ji,jj))**2 + & 582 (zv_ice1-v_oce1(ji,jj))**2)*(1.0-zfrld1(ji,jj)) 583 zr = z0*u_ice(ji,jj) + zf1(ji,jj) + za1ct(ji,jj) + & 584 za*(cangvg*u_oce1(ji,jj)-zsang*v_oce1(ji,jj)) 585 zcca = z0+za*cangvg 586 zccb = zcorl1(ji,jj)+za*zsang 587 u_ice(ji,jj) = (zr+zccb*zv_ice1)/(zcca+epsd)*zmask 588 END DO ! ji 589 END DO ! jj 590 591 CALL lbc_lnk( u_ice(:,:), 'U', -1. ) 592 593 ENDIF 594 595 IF(ln_ctl) THEN 596 !--- Convergence test. 597 DO jj = k_j1+1 , k_jpj-1 598 zresr(:,jj) = MAX( ABS( u_ice(:,jj) - zu_ice(:,jj) ) , & 599 ABS( v_ice(:,jj) - zv_ice(:,jj) ) ) 600 END DO 601 zresm = MAXVAL( zresr( 1:jpi , k_j1+1:k_jpj-1 ) ) 602 IF( lk_mpp ) CALL mpp_max( zresm ) ! max over the global domain 603 ENDIF 604 605 ! ! ==================== ! 606 606 END DO ! end loop over jter ! 607 607 ! ! ==================== ! 608 608 609 !610 !------------------------------------------------------------------------------!611 ! 4) Prevent ice velocities when the ice is thin612 !------------------------------------------------------------------------------!613 !609 ! 610 !------------------------------------------------------------------------------! 611 ! 4) Prevent ice velocities when the ice is thin 612 !------------------------------------------------------------------------------! 613 ! 614 614 ! If the ice thickness is below 1cm then ice velocity should equal the 615 615 ! ocean velocity, … … 636 636 zdummy = zindb * vt_i(ji,jj) / MAX(at_i(ji,jj) , 1.0e-06 ) 637 637 IF ( zdummy .LE. 5.0e-2 ) THEN 638 639 640 641 642 643 644 645 638 v_ice1(ji,jj) = 0.5*( (v_ice(ji,jj)+v_ice(ji,jj-1))*e1t(ji+1,jj) & 639 & +(v_ice(ji+1,jj)+v_ice(ji+1,jj-1))*e1t(ji,jj)) & 640 & /(e1t(ji+1,jj)+e1t(ji,jj)) * tmu(ji,jj) 641 642 u_ice2(ji,jj) = 0.5*( (u_ice(ji,jj)+u_ice(ji-1,jj))*e2t(ji,jj+1) & 643 & +(u_ice(ji,jj+1)+u_ice(ji-1,jj+1))*e2t(ji,jj)) & 644 & /(e2t(ji,jj+1)+e2t(ji,jj)) * tmv(ji,jj) 645 ENDIF ! zdummy 646 646 END DO 647 647 END DO … … 662 662 IF ( zdummy .LE. 5.0e-2 ) THEN 663 663 664 zdd(ji,jj) = ( e2u(ji,jj)*u_ice(ji,jj) &665 & -e2u(ji-1,jj)*u_ice(ji-1,jj) &666 & +e1v(ji,jj)*v_ice(ji,jj) &667 & -e1v(ji,jj-1)*v_ice(ji,jj-1) &668 & ) &669 & / area(ji,jj)670 671 zdt(ji,jj) = ( ( u_ice(ji,jj)/e2u(ji,jj) &672 & -u_ice(ji-1,jj)/e2u(ji-1,jj) &673 & )*e2t(ji,jj)*e2t(ji,jj) &674 & -( v_ice(ji,jj)/e1v(ji,jj) &675 & -v_ice(ji,jj-1)/e1v(ji,jj-1) &676 & )*e1t(ji,jj)*e1t(ji,jj) &677 & ) &678 & / area(ji,jj)679 !680 ! SB modif because ocean has no slip boundary condition681 zds(ji,jj) = ( ( u_ice(ji,jj+1) / e1u(ji,jj+1) &682 & - u_ice(ji,jj) / e1u(ji,jj) ) &683 & * e1f(ji,jj) * e1f(ji,jj) &684 & + ( v_ice(ji+1,jj) / e2v(ji+1,jj) &685 & - v_ice(ji,jj) / e2v(ji,jj) ) &686 & * e2f(ji,jj) * e2f(ji,jj) ) &687 & / ( e1f(ji,jj) * e2f(ji,jj) ) * ( 2.0 - tmf(ji,jj) ) &688 & * tmi(ji,jj) * tmi(ji,jj+1) &689 & * tmi(ji+1,jj) * tmi(ji+1,jj+1)690 691 zdst = ( e2u( ji , jj ) * v_ice1(ji,jj) &692 & - e2u( ji-1, jj ) * v_ice1(ji-1,jj) &693 & + e1v( ji , jj ) * u_ice2(ji,jj) &694 & - e1v( ji , jj-1 ) * u_ice2(ji,jj-1) &695 & ) &696 & / area(ji,jj)697 698 deltat(ji,jj) = SQRT( zdd(ji,jj)*zdd(ji,jj) + &699 & ( zdt(ji,jj)*zdt(ji,jj) + zdst*zdst ) * usecc2 &700 & ) + creepl701 702 664 zdd(ji,jj) = ( e2u(ji,jj)*u_ice(ji,jj) & 665 & -e2u(ji-1,jj)*u_ice(ji-1,jj) & 666 & +e1v(ji,jj)*v_ice(ji,jj) & 667 & -e1v(ji,jj-1)*v_ice(ji,jj-1) & 668 & ) & 669 & / area(ji,jj) 670 671 zdt(ji,jj) = ( ( u_ice(ji,jj)/e2u(ji,jj) & 672 & -u_ice(ji-1,jj)/e2u(ji-1,jj) & 673 & )*e2t(ji,jj)*e2t(ji,jj) & 674 & -( v_ice(ji,jj)/e1v(ji,jj) & 675 & -v_ice(ji,jj-1)/e1v(ji,jj-1) & 676 & )*e1t(ji,jj)*e1t(ji,jj) & 677 & ) & 678 & / area(ji,jj) 679 ! 680 ! SB modif because ocean has no slip boundary condition 681 zds(ji,jj) = ( ( u_ice(ji,jj+1) / e1u(ji,jj+1) & 682 & - u_ice(ji,jj) / e1u(ji,jj) ) & 683 & * e1f(ji,jj) * e1f(ji,jj) & 684 & + ( v_ice(ji+1,jj) / e2v(ji+1,jj) & 685 & - v_ice(ji,jj) / e2v(ji,jj) ) & 686 & * e2f(ji,jj) * e2f(ji,jj) ) & 687 & / ( e1f(ji,jj) * e2f(ji,jj) ) * ( 2.0 - tmf(ji,jj) ) & 688 & * tmi(ji,jj) * tmi(ji,jj+1) & 689 & * tmi(ji+1,jj) * tmi(ji+1,jj+1) 690 691 zdst = ( e2u( ji , jj ) * v_ice1(ji,jj) & 692 & - e2u( ji-1, jj ) * v_ice1(ji-1,jj) & 693 & + e1v( ji , jj ) * u_ice2(ji,jj) & 694 & - e1v( ji , jj-1 ) * u_ice2(ji,jj-1) & 695 & ) & 696 & / area(ji,jj) 697 698 deltat(ji,jj) = SQRT( zdd(ji,jj)*zdd(ji,jj) + & 699 & ( zdt(ji,jj)*zdt(ji,jj) + zdst*zdst ) * usecc2 & 700 & ) + creepl 701 702 ENDIF ! zdummy 703 703 704 704 END DO !jj 705 705 END DO !ji 706 !707 !------------------------------------------------------------------------------!708 ! 5) Store stress tensor and its invariants709 !------------------------------------------------------------------------------!710 !706 ! 707 !------------------------------------------------------------------------------! 708 ! 5) Store stress tensor and its invariants 709 !------------------------------------------------------------------------------! 710 ! 711 711 ! * Invariants of the stress tensor are required for limitd_me 712 712 ! accelerates convergence and improves stability … … 729 729 stress12_i(:,:) = zs12(:,:) 730 730 731 !732 !------------------------------------------------------------------------------!733 ! 6) Control prints of residual and charge ellipse734 !------------------------------------------------------------------------------!735 !731 ! 732 !------------------------------------------------------------------------------! 733 ! 6) Control prints of residual and charge ellipse 734 !------------------------------------------------------------------------------! 735 ! 736 736 ! print the residual for convergence 737 737 IF(ln_ctl) THEN -
trunk/NEMO/LIM_SRC_3/limrst.F90
r919 r921 22 22 USE daymod 23 23 USE iom 24 24 25 25 IMPLICIT NONE 26 26 PRIVATE 27 27 28 28 !! * Accessibility 29 29 PUBLIC lim_rst_opn ! routine called by icestep.F90 … … 55 55 ! 56 56 IF( kt == nit000 ) lrst_ice = .FALSE. ! default definition 57 57 58 58 ! to get better performances with NetCDF format: 59 59 ! we open and define the ice restart file one ice time step before writing the data (-> at nitrst - 2*nn_fsbc + 1) … … 101 101 CHARACTER(len=1) :: zchar, zchar1 102 102 !!---------------------------------------------------------------------- 103 103 104 104 iter = kt + nn_fsbc - 1 ! ice restarts are written at kt == nitrst - nn_fsbc + 1 105 105 … … 294 294 ENDIF 295 295 ! 296 297 !+++++++++++ CHECK EVERYTHING ++++++++++298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 !+++++++++++ END CHECK +++++++++++++++++381 382 383 296 297 IF( ln_nicep) THEN 298 WRITE(numout,*) 299 WRITE(numout,*) ' lim_rst_write : CHUKCHI SEA POINT ' 300 WRITE(numout,*) ' ~~~~~~~~~~' 301 WRITE(numout,*) ' ~~~ Arctic' 302 303 ji = jiindx 304 jj = jjindx 305 306 WRITE(numout,*) ' ji, jj ', ji, jj 307 WRITE(numout,*) ' ICE VARIABLES ' 308 WRITE(numout,*) ' open water ', ato_i(ji,jj) 309 DO jl = 1, jpl 310 WRITE(numout,*) ' *** CATEGORY NUMBER *** ', jl 311 WRITE(numout,*) ' ' 312 WRITE(numout,*) ' a_i : ', a_i(ji,jj,jl) 313 WRITE(numout,*) ' v_i : ', v_i(ji,jj,jl) 314 WRITE(numout,*) ' v_s : ', v_s(ji,jj,jl) 315 WRITE(numout,*) ' e_s : ', e_s(ji,jj,1,jl)/1.0e9 316 WRITE(numout,*) ' e_i1 : ', e_i(ji,jj,1,jl)/1.0e9 317 WRITE(numout,*) ' e_i2 : ', e_i(ji,jj,2,jl)/1.0e9 318 WRITE(numout,*) ' smv_i : ', smv_i(ji,jj,jl) 319 WRITE(numout,*) ' oa_i : ', oa_i(ji,jj,jl) 320 WRITE(numout,*) ' t_su : ', t_su(ji,jj,jl) 321 END DO 322 323 WRITE(numout,*) ' MOMENTS OF ADVECTION ' 324 325 WRITE(numout,*) ' open water ' 326 WRITE(numout,*) ' sxopw ', sxopw(ji,jj) 327 WRITE(numout,*) ' syopw ', syopw(ji,jj) 328 WRITE(numout,*) ' sxxopw ', sxxopw(ji,jj) 329 WRITE(numout,*) ' syyopw ', syyopw(ji,jj) 330 WRITE(numout,*) ' sxyopw ', sxyopw(ji,jj) 331 DO jl = 1, jpl 332 WRITE(numout,*) ' jl, ice volume content ', jl 333 WRITE(numout,*) ' sxice ', sxice(ji,jj,jl) 334 WRITE(numout,*) ' syice ', syice(ji,jj,jl) 335 WRITE(numout,*) ' sxxice ', sxxice(ji,jj,jl) 336 WRITE(numout,*) ' syyice ', syyice(ji,jj,jl) 337 WRITE(numout,*) ' sxyice ', sxyice(ji,jj,jl) 338 WRITE(numout,*) ' jl, snow volume content ', jl 339 WRITE(numout,*) ' sxsn ', sxsn(ji,jj,jl) 340 WRITE(numout,*) ' sysn ', sysn(ji,jj,jl) 341 WRITE(numout,*) ' sxxsn ', sxxsn(ji,jj,jl) 342 WRITE(numout,*) ' syysn ', syysn(ji,jj,jl) 343 WRITE(numout,*) ' sxysn ', sxysn(ji,jj,jl) 344 WRITE(numout,*) ' jl, ice area in category ', jl 345 WRITE(numout,*) ' sxa ', sxa (ji,jj,jl) 346 WRITE(numout,*) ' sya ', sya (ji,jj,jl) 347 WRITE(numout,*) ' sxxa ', sxxa (ji,jj,jl) 348 WRITE(numout,*) ' syya ', syya (ji,jj,jl) 349 WRITE(numout,*) ' sxya ', sxya (ji,jj,jl) 350 WRITE(numout,*) ' jl, snow temp ', jl 351 WRITE(numout,*) ' sxc0 ', sxc0(ji,jj,jl) 352 WRITE(numout,*) ' syc0 ', syc0(ji,jj,jl) 353 WRITE(numout,*) ' sxxc0 ', sxxc0(ji,jj,jl) 354 WRITE(numout,*) ' syyc0 ', syyc0(ji,jj,jl) 355 WRITE(numout,*) ' sxyc0 ', sxyc0(ji,jj,jl) 356 WRITE(numout,*) ' jl, ice salinity ', jl 357 WRITE(numout,*) ' sxsal ', sxsal(ji,jj,jl) 358 WRITE(numout,*) ' sysal ', sysal(ji,jj,jl) 359 WRITE(numout,*) ' sxxsal ', sxxsal(ji,jj,jl) 360 WRITE(numout,*) ' syysal ', syysal(ji,jj,jl) 361 WRITE(numout,*) ' sxysal ', sxysal(ji,jj,jl) 362 WRITE(numout,*) ' jl, ice age ', jl 363 WRITE(numout,*) ' sxage ', sxage(ji,jj,jl) 364 WRITE(numout,*) ' syage ', syage(ji,jj,jl) 365 WRITE(numout,*) ' sxxage ', sxxage(ji,jj,jl) 366 WRITE(numout,*) ' syyage ', syyage(ji,jj,jl) 367 WRITE(numout,*) ' sxyage ', sxyage(ji,jj,jl) 368 END DO 369 DO jl = 1, jpl 370 DO jk = 1, nlay_i 371 WRITE(numout,*) ' jk, jl, ice heat content', jk, jl 372 WRITE(numout,*) ' sxe ', sxe(ji,jj,jk,jl) 373 WRITE(numout,*) ' sye ', sye(ji,jj,jk,jl) 374 WRITE(numout,*) ' sxxe ', sxxe(ji,jj,jk,jl) 375 WRITE(numout,*) ' syye ', syye(ji,jj,jk,jl) 376 WRITE(numout,*) ' sxye ', sxye(ji,jj,jk,jl) 377 END DO 378 END DO 379 380 ENDIF 381 382 END SUBROUTINE lim_rst_write 383 384 384 SUBROUTINE lim_rst_read 385 385 !!---------------------------------------------------------------------- … … 398 398 CHARACTER(len=1) :: zchar, zchar1 399 399 !!---------------------------------------------------------------------- 400 400 401 401 IF(lwp) THEN 402 402 WRITE(numout,*) … … 413 413 414 414 !Control of date 415 415 416 416 IF( ( nit000 - INT(ziter) ) /= 1 .AND. ABS( nrstdt ) == 1 ) & 417 417 & CALL ctl_stop( 'lim_rst_read ===>>>> : problem with nit000 in ice restart', & … … 461 461 END DO 462 462 END DO 463 463 464 464 DO jk = 1, nlay_i 465 465 s_i(:,:,jk,:) = sm_i(:,:,:) 466 466 END DO 467 467 468 468 ! Salinity profile 469 469 !----------------- 470 470 WRITE(numout,*) ' num_sal - will restart understand salinity profile ', num_sal 471 471 472 472 num_sal = 2 473 473 IF(num_sal.eq.2) THEN 474 ! CALL lim_var_salprof474 ! CALL lim_var_salprof 475 475 DO jl = 1, jpl 476 476 DO jk = 1, nlay_i … … 479 479 zs_inf = sm_i(ji,jj,jl) 480 480 z_slope_s = 2.0*sm_i(ji,jj,jl)/MAX(0.01,ht_i(ji,jj,jl)) 481 481 !- slope of the salinity profile 482 482 zs_zero(jk) = z_slope_s * ( FLOAT(jk)-1.0/2.0 ) * & 483 483 ht_i(ji,jj,jl) / FLOAT(nlay_i) 484 484 zsmax = 4.5 485 485 zsmin = 3.5 … … 497 497 END DO 498 498 ENDIF 499 499 500 500 # if defined key_coupled 501 501 CALL iom_get( numrir, jpdom_autoglo, 'albege' , albege ) … … 507 507 e_s(:,:,1,jl) = z2d(:,:) 508 508 END DO 509 509 510 510 DO jl = 1, jpl 511 511 WRITE(zchar,'(I1)') jl … … 651 651 CALL iom_close( numrir ) 652 652 653 !+++++++++++ CHECK EVERYTHING ++++++++++654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 !+++++++++++ END CHECK +++++++++++++++++737 738 739 740 653 !+++++++++++ CHECK EVERYTHING ++++++++++ 654 655 WRITE(numout,*) 656 WRITE(numout,*) ' lim_rst_read : CHUKCHI SEA POINT ' 657 WRITE(numout,*) ' ~~~~~~~~~~' 658 WRITE(numout,*) ' ~~~ Arctic' 659 660 indx = 1 661 ji = 24 662 jj = 24 663 WRITE(numout,*) ' ji, jj ', ji, jj 664 WRITE(numout,*) ' ICE VARIABLES ' 665 WRITE(numout,*) ' open water ', ato_i(ji,jj) 666 667 DO jl = 1, jpl 668 WRITE(numout,*) ' *** CATEGORY NUMBER *** ', jl 669 WRITE(numout,*) ' ' 670 WRITE(numout,*) ' a_i : ', a_i(ji,jj,jl) 671 WRITE(numout,*) ' v_i : ', v_i(ji,jj,jl) 672 WRITE(numout,*) ' v_s : ', v_s(ji,jj,jl) 673 WRITE(numout,*) ' e_i1 : ', e_i(ji,jj,1,jl)/1.0e9 674 WRITE(numout,*) ' e_i2 : ', e_i(ji,jj,2,jl)/1.0e9 675 WRITE(numout,*) ' e_s : ', e_s(ji,jj,1,jl) 676 WRITE(numout,*) ' smv_i : ', smv_i(ji,jj,jl) 677 WRITE(numout,*) ' oa_i : ', oa_i(ji,jj,jl) 678 WRITE(numout,*) ' t_su : ', t_su(ji,jj,jl) 679 END DO 680 681 WRITE(numout,*) ' open water ' 682 WRITE(numout,*) ' sxopw ', sxopw(ji,jj) 683 WRITE(numout,*) ' syopw ', syopw(ji,jj) 684 WRITE(numout,*) ' sxxopw ', sxxopw(ji,jj) 685 WRITE(numout,*) ' syyopw ', syyopw(ji,jj) 686 WRITE(numout,*) ' sxyopw ', sxyopw(ji,jj) 687 DO jl = 1, jpl 688 WRITE(numout,*) ' jl, ice volume content ', jl 689 WRITE(numout,*) ' sxice ', sxice(ji,jj,jl) 690 WRITE(numout,*) ' syice ', syice(ji,jj,jl) 691 WRITE(numout,*) ' sxxice ', sxxice(ji,jj,jl) 692 WRITE(numout,*) ' syyice ', syyice(ji,jj,jl) 693 WRITE(numout,*) ' sxyice ', sxyice(ji,jj,jl) 694 WRITE(numout,*) ' jl, snow volume content ', jl 695 WRITE(numout,*) ' sxsn ', sxsn(ji,jj,jl) 696 WRITE(numout,*) ' sysn ', sysn(ji,jj,jl) 697 WRITE(numout,*) ' sxxsn ', sxxsn(ji,jj,jl) 698 WRITE(numout,*) ' syysn ', syysn(ji,jj,jl) 699 WRITE(numout,*) ' sxysn ', sxysn(ji,jj,jl) 700 WRITE(numout,*) ' jl, ice area in category ', jl 701 WRITE(numout,*) ' sxa ', sxa (ji,jj,jl) 702 WRITE(numout,*) ' sya ', sya (ji,jj,jl) 703 WRITE(numout,*) ' sxxa ', sxxa (ji,jj,jl) 704 WRITE(numout,*) ' syya ', syya (ji,jj,jl) 705 WRITE(numout,*) ' sxya ', sxya (ji,jj,jl) 706 WRITE(numout,*) ' jl, snow temp ', jl 707 WRITE(numout,*) ' sxc0 ', sxc0(ji,jj,jl) 708 WRITE(numout,*) ' syc0 ', syc0(ji,jj,jl) 709 WRITE(numout,*) ' sxxc0 ', sxxc0(ji,jj,jl) 710 WRITE(numout,*) ' syyc0 ', syyc0(ji,jj,jl) 711 WRITE(numout,*) ' sxyc0 ', sxyc0(ji,jj,jl) 712 WRITE(numout,*) ' jl, ice salinity ', jl 713 WRITE(numout,*) ' sxsal ', sxsal(ji,jj,jl) 714 WRITE(numout,*) ' sysal ', sysal(ji,jj,jl) 715 WRITE(numout,*) ' sxxsal ', sxxsal(ji,jj,jl) 716 WRITE(numout,*) ' syysal ', syysal(ji,jj,jl) 717 WRITE(numout,*) ' sxysal ', sxysal(ji,jj,jl) 718 WRITE(numout,*) ' jl, ice age ', jl 719 WRITE(numout,*) ' sxage ', sxage(ji,jj,jl) 720 WRITE(numout,*) ' syage ', syage(ji,jj,jl) 721 WRITE(numout,*) ' sxxage ', sxxage(ji,jj,jl) 722 WRITE(numout,*) ' syyage ', syyage(ji,jj,jl) 723 WRITE(numout,*) ' sxyage ', sxyage(ji,jj,jl) 724 END DO 725 DO jl = 1, jpl 726 DO jk = 1, nlay_i 727 WRITE(numout,*) ' jk, jl, ice heat content', jk, jl 728 WRITE(numout,*) ' sxe ', sxe(ji,jj,jk,jl) 729 WRITE(numout,*) ' sye ', sye(ji,jj,jk,jl) 730 WRITE(numout,*) ' sxxe ', sxxe(ji,jj,jk,jl) 731 WRITE(numout,*) ' syye ', syye(ji,jj,jk,jl) 732 WRITE(numout,*) ' sxye ', sxye(ji,jj,jk,jl) 733 END DO 734 END DO 735 736 !+++++++++++ END CHECK +++++++++++++++++ 737 738 END SUBROUTINE lim_rst_read 739 740 741 741 #else 742 742 !!---------------------------------------------------------------------- -
trunk/NEMO/LIM_SRC_3/limsbc.F90
r918 r921 83 83 REAL(wp) :: zat_u, zu_ico, zutaui, zu_u, zv_u, zmodu, zmod 84 84 REAL(wp) :: zat_v, zv_ico, zvtaui, zu_v, zv_v, zmodv, zsang 85 85 86 86 #if defined key_coupled 87 87 REAL(wp), DIMENSION(jpi,jpj,jpl) :: zalb ! albedo of ice under overcast sky 88 88 REAL(wp), DIMENSION(jpi,jpj,jpl) :: zalbp ! albedo of ice under clear sky 89 89 #endif 90 REAL(wp), DIMENSION(jpi,jpj) :: ztio_u, ztio_v ! ocean stress below sea-ice90 REAL(wp), DIMENSION(jpi,jpj) :: ztio_u, ztio_v ! ocean stress below sea-ice 91 91 !!--------------------------------------------------------------------- 92 92 93 93 IF( kt == nit000 ) THEN 94 94 IF(lwp) WRITE(numout,*) … … 98 98 99 99 SELECT CASE( kcpl ) 100 ! !--------------------------------!100 ! !--------------------------------! 101 101 CASE( 0 ) ! LIM 3 old stress computation ! (at ice timestep only) 102 102 ! !--------------------------------! … … 191 191 zat_v = at_i(ji,jj) + at_i(ji,jj+1) * 0.5 192 192 193 !!gm bug mixing U and V points value below ====>>> to be corrected193 !!gm bug mixing U and V points value below ====>>> to be corrected 194 194 zu_ico = u_ice(ji,jj) - 0.5 * ( un(ji,jj,1) - ssu_m(ji,jj) ) ! ice-oce velocity using un and ssu_m 195 195 zv_ico = v_ice(ji,jj) - 0.5 * ( vn(ji,jj,1) - ssu_m(ji,jj) ) … … 199 199 zutaui = rhoco * zmod * ( cangvg * zu_ico - zsang * zv_ico ) 200 200 zvtaui = rhoco * zmod * ( cangvg * zv_ico + zsang * zu_ico ) 201 !201 ! 202 202 utau(ji,jj) = ( 1.-zat_u ) * utau_oce(ji,jj) + zat_u * zutaui ! stress at the ocean surface 203 203 vtau(ji,jj) = ( 1.-zat_v ) * vtau_oce(ji,jj) + zat_v * zvtaui … … 247 247 #endif 248 248 !!--------------------------------------------------------------------- 249 249 250 250 IF( kt == nit000 ) THEN 251 251 IF(lwp) WRITE(numout,*) … … 259 259 ! pfrld is the lead fraction at the previous time step (actually between TRP and THD) 260 260 ! changed to old_frld and old ht_i 261 261 262 262 DO jj = 1, jpj 263 263 DO ji = 1, jpi … … 286 286 ! computation the solar flux at ocean surface 287 287 zfcm1(ji,jj) = pfrld(ji,jj) * qsr(ji,jj) + ( 1. - pfrld(ji,jj) ) * fstric(ji,jj) 288 289 290 ! new line288 ! fstric Solar flux transmitted trough the ice 289 ! qsr Net short wave heat flux on free ocean 290 ! new line 291 291 fscmbq(ji,jj) = ( 1.0 - pfrld(ji,jj) ) * fstric(ji,jj) 292 292 … … 294 294 zfcm2(ji,jj) = - zfcm1(ji,jj) & 295 295 & + iflt * ( fscmbq(ji,jj) ) & ! total abl -> fscmbq is given to the ocean 296 ! fscmbq and ffltbif are obsolete297 ! & + iflt * ffltbif(ji,jj) !!! only if one category is used296 ! fscmbq and ffltbif are obsolete 297 ! & + iflt * ffltbif(ji,jj) !!! only if one category is used 298 298 & + ifral * ( ial * qcmif(ji,jj) + (1 - ial) * qldif(ji,jj) ) / rdt_ice & 299 299 & + ifrdv * ( qfvbq(ji,jj) + qdtcn(ji,jj) ) / rdt_ice & … … 301 301 & + fheat_rpo(ji,jj) & ! contribution from ridge formation 302 302 & + fheat_res(ji,jj) 303 304 305 306 307 308 309 310 311 303 ! fscmbq Part of the solar radiation transmitted through the ice and going to the ocean 304 ! computed in limthd_zdf.F90 305 ! ffltbif Total heat content of the ice (brine pockets+ice) / delta_t 306 ! qcmif Energy needed to bring the ocean surface layer until its freezing (ok) 307 ! qldif heat balance of the lead (or of the open ocean) 308 ! qfvbq i think this is wrong! 309 ! ---> Array used to store energy in case of total lateral ablation 310 ! qfvbq latent heat uptake/release after accretion/ablation 311 ! qdtcn Energy from the turbulent oceanic heat flux heat flux coming in the lead 312 312 313 313 IF ( num_sal .EQ. 2 ) zfcm2(ji,jj) = zfcm2(ji,jj) + & 314 314 fhbri(ji,jj) ! new contribution due to brine drainage 315 315 316 316 ! bottom radiative component is sent to the computation of the … … 321 321 qsr(ji,jj) = zfcm1(ji,jj) ! solar heat flux 322 322 qns(ji,jj) = zfcm2(ji,jj) - fdtcn(ji,jj) ! non solar heat flux 323 ! ! fdtcn : turbulent oceanic heat flux324 325 !!gm this IF prevents the vertorisation of the whole loop323 ! ! fdtcn : turbulent oceanic heat flux 324 325 !!gm this IF prevents the vertorisation of the whole loop 326 326 IF ( ( ji .EQ. jiindx ) .AND. ( jj .EQ. jjindx) ) THEN 327 327 WRITE(numout,*) ' lim_sbc : heat fluxes ' … … 352 352 WRITE(numout,*) ' fheat_res : ', fheat_res(jiindx,jjindx) 353 353 ENDIF 354 !!gm end354 !!gm end 355 355 END DO 356 356 END DO 357 357 358 358 !------------------------------------------! 359 359 ! mass flux at the ocean surface ! 360 360 !------------------------------------------! 361 361 362 !!gm optimisation: this loop have to be merged with the previous one362 !!gm optimisation: this loop have to be merged with the previous one 363 363 DO jj = 1, jpj 364 364 DO ji = 1, jpi … … 375 375 zpme = - emp(ji,jj) * ( 1.0 - at_i(ji,jj) ) & ! evaporation over oceanic fraction 376 376 & + tprecip(ji,jj) * at_i(ji,jj) & ! total precipitation 377 ! old fashioned way378 ! & - sprecip(ji,jj) * ( 1. - pfrld(ji,jj) ) & ! remov. snow precip over ice377 ! old fashioned way 378 ! & - sprecip(ji,jj) * ( 1. - pfrld(ji,jj) ) & ! remov. snow precip over ice 379 379 & - sprecip(ji,jj) * ( 1. - (pfrld(ji,jj)**betas) ) & ! remov. snow precip over ice 380 380 & - rdmsnif(ji,jj) / rdt_ice & ! freshwaterflux due to snow melting 381 ! new contribution from snow falling when ridging381 ! new contribution from snow falling when ridging 382 382 & + fmmec(ji,jj) 383 383 384 384 ! computing salt exchanges at the ice/ocean interface 385 385 ! sice should be the same as computed with the ice model 386 386 zfons = ( soce - sice ) * ( rdmicif(ji,jj) / rdt_ice ) 387 ! SOCE387 ! SOCE 388 388 zfons = ( sss_m(ji,jj) - sice ) * ( rdmicif(ji,jj) / rdt_ice ) 389 390 !CT useless ! salt flux for constant salinity391 !CT useless fsalt(ji,jj) = zfons / ( sss_m(ji,jj) + epsi16 ) + fsalt_res(ji,jj)389 390 !CT useless ! salt flux for constant salinity 391 !CT useless fsalt(ji,jj) = zfons / ( sss_m(ji,jj) + epsi16 ) + fsalt_res(ji,jj) 392 392 ! salt flux for variable salinity 393 393 zinda = 1.0 - MAX( rzero , SIGN( rone , - ( 1.0 - pfrld(ji,jj) ) ) ) … … 415 415 emps(:,:) = fseqv(:,:) + fsalt_res(:,:) + fsalt_rpo(:,:) + emp(:,:) 416 416 ENDIF 417 417 418 418 IF( lk_dynspg_rl ) emp (:,:) = emps(:,:) ! rigid-lid formulation : emp = emps 419 419 … … 442 442 CALL prt_ctl( tab2d_1=freeze, clinfo1=' lim_sbc: freeze : ' ) 443 443 CALL prt_ctl( tab3d_1=tn_ice, clinfo1=' lim_sbc: tn_ice : ', kdim=jpl ) 444 ENDIF 444 ENDIF 445 445 ! 446 446 END SUBROUTINE lim_sbc_flx -
trunk/NEMO/LIM_SRC_3/limtab.F90
r888 r921 44 44 INTEGER :: & 45 45 jn , jid, jjd 46 46 47 47 DO jn = 1, ndim1d 48 48 jid = MOD( tab_ind(jn) - 1, ndim2d_x ) + 1 49 49 jjd = ( tab_ind(jn) - 1 ) / ndim2d_x + 1 50 50 tab1d( jn) = tab2d( jid, jjd) 51 END DO 51 END DO 52 52 53 53 END SUBROUTINE tab_2d_1d -
trunk/NEMO/LIM_SRC_3/limthd.F90
r888 r921 39 39 PUBLIC lim_thd ! called by lim_step 40 40 41 !! * Module variables42 43 44 45 46 47 48 41 !! * Module variables 42 REAL(wp) :: & ! constant values 43 epsi20 = 1e-20 , & 44 epsi16 = 1e-16 , & 45 epsi06 = 1e-06 , & 46 epsi04 = 1e-04 , & 47 zzero = 0.e0 , & 48 zone = 1.e0 49 49 50 50 !! * Substitutions … … 59 59 CONTAINS 60 60 61 SUBROUTINE lim_thd 61 SUBROUTINE lim_thd( kt ) 62 62 !!------------------------------------------------------------------- 63 63 !! *** ROUTINE lim_thd *** … … 84 84 !! salinity variations 85 85 !!--------------------------------------------------------------------- 86 INTEGER, INTENT(in) :: kt ! number of iteration 86 87 !! * Local variables 87 88 INTEGER :: ji, jj, jk, jl, nbpb ! nb of icy pts for thermo. cal. … … 90 91 zfric_umin = 5e-03 , & ! lower bound for the friction velocity 91 92 zfric_umax = 2e-02 ! upper bound for the friction velocity 92 93 93 94 REAL(wp) :: & 94 95 zinda , & ! switch for test. the val. of concen. … … 103 104 REAL(wp) :: & 104 105 zareamin 105 106 106 107 REAL(wp), DIMENSION(jpi,jpj) :: & 107 108 zhicifp , & ! ice thickness for outputs … … 112 113 IF( numit == nstart ) CALL lim_thd_init ! Initialization (first time-step only) 113 114 114 WRITE(numout,*) 'limthd : Ice Thermodynamics' 115 WRITE(numout,*) '~~~~~~' 115 IF( kt == nit000 .AND. lwp ) THEN 116 WRITE(numout,*) 'limthd : Ice Thermodynamics' 117 WRITE(numout,*) '~~~~~~' 118 ENDIF 116 119 117 120 IF( numit == nstart ) CALL lim_thd_sal_init ! Initialization (first time-step only) 118 !------------------------------------------------------------------------------!119 ! 1) Initialization of diagnostic variables !120 !------------------------------------------------------------------------------!121 !------------------------------------------------------------------------------! 122 ! 1) Initialization of diagnostic variables ! 123 !------------------------------------------------------------------------------! 121 124 zeps = 1.0e-10 122 125 tatm_ice(:,:) = tatm_ice(:,:) + 273.15 ! convert C to K … … 129 132 130 133 DO jl = 1, jpl 131 DO jk = 1, nlay_i 132 DO jj = 1, jpj 133 DO ji = 1, jpi 134 !Energy of melting q(S,T) [J.m-3] 135 e_i(ji,jj,jk,jl) = e_i(ji,jj,jk,jl) / area(ji,jj) / & 136 MAX( v_i(ji,jj,jl) , epsi06 ) * nlay_i 137 !0 if no ice and 1 if yes 138 zindb = 1.0 - MAX ( 0.0 , SIGN ( 1.0 , - ht_i(ji,jj,jl) ) ) 139 !convert units ! very important that this line is here 140 e_i(ji,jj,jk,jl) = e_i(ji,jj,jk,jl) * unit_fac * zindb 134 DO jk = 1, nlay_i 135 DO jj = 1, jpj 136 DO ji = 1, jpi 137 !Energy of melting q(S,T) [J.m-3] 138 e_i(ji,jj,jk,jl) = e_i(ji,jj,jk,jl) / area(ji,jj) / & 139 MAX( v_i(ji,jj,jl) , epsi06 ) * nlay_i 140 !0 if no ice and 1 if yes 141 zindb = 1.0 - MAX ( 0.0 , SIGN ( 1.0 , - ht_i(ji,jj,jl) ) ) 142 !convert units ! very important that this line is here 143 e_i(ji,jj,jk,jl) = e_i(ji,jj,jk,jl) * unit_fac * zindb 144 END DO 141 145 END DO 142 END DO 143 END DO 146 END DO 144 147 END DO 145 148 146 149 DO jl = 1, jpl 147 DO jk = 1, nlay_s 148 DO jj = 1, jpj 149 DO ji = 1, jpi 150 !Energy of melting q(S,T) [J.m-3] 151 e_s(ji,jj,jk,jl) = e_s(ji,jj,jk,jl) / area(ji,jj) / & 152 MAX( v_s(ji,jj,jl) , epsi06 ) * nlay_s 153 !0 if no ice and 1 if yes 154 zindb = 1.0 - MAX ( 0.0 , SIGN ( 1.0 , - ht_s(ji,jj,jl) ) ) 155 !convert units ! very important that this line is here 156 e_s(ji,jj,jk,jl) = e_s(ji,jj,jk,jl) * unit_fac * zindb 150 DO jk = 1, nlay_s 151 DO jj = 1, jpj 152 DO ji = 1, jpi 153 !Energy of melting q(S,T) [J.m-3] 154 e_s(ji,jj,jk,jl) = e_s(ji,jj,jk,jl) / area(ji,jj) / & 155 MAX( v_s(ji,jj,jl) , epsi06 ) * nlay_s 156 !0 if no ice and 1 if yes 157 zindb = 1.0 - MAX ( 0.0 , SIGN ( 1.0 , - ht_s(ji,jj,jl) ) ) 158 !convert units ! very important that this line is here 159 e_s(ji,jj,jk,jl) = e_s(ji,jj,jk,jl) * unit_fac * zindb 160 END DO 157 161 END DO 158 END DO 159 END DO 162 END DO 160 163 END DO 161 164 … … 187 190 fatm(:,:) = 0.e0 188 191 189 ! 2) Partial computation of forcing for the thermodynamic sea ice model. !190 !-----------------------------------------------------------------------------!191 192 ! !CDIR NOVERRCHK193 194 ! !CDIR NOVERRCHK195 192 ! 2) Partial computation of forcing for the thermodynamic sea ice model. ! 193 !-----------------------------------------------------------------------------! 194 195 !CDIR NOVERRCHK 196 DO jj = 1, jpj 197 !CDIR NOVERRCHK 198 DO ji = 1, jpi 196 199 zthsnice = SUM( ht_s(ji,jj,1:jpl) ) + SUM( ht_i(ji,jj,1:jpl) ) 197 200 zindb = tms(ji,jj) * ( 1.0 - MAX( zzero , SIGN( zone , - zthsnice ) ) ) … … 199 202 pfrld(ji,jj) = 1.0 - at_i(ji,jj) 200 203 zinda = 1.0 - MAX( zzero , SIGN( zone , - ( 1.0 - pfrld(ji,jj) ) ) ) 201 202 ! ! solar irradiance transmission at the mixed layer bottom and used in the lead heat budget203 ! ! practically no "direct lateral ablation"204 !205 ! ! net downward heat flux from the ice to the ocean, expressed as a function of ocean206 ! ! temperature and turbulent mixing (McPhee, 1992)204 205 ! ! solar irradiance transmission at the mixed layer bottom and used in the lead heat budget 206 ! ! practically no "direct lateral ablation" 207 ! 208 ! ! net downward heat flux from the ice to the ocean, expressed as a function of ocean 209 ! ! temperature and turbulent mixing (McPhee, 1992) 207 210 ! friction velocity 208 211 zfric_u = MAX ( MIN( SQRT( ust2s(ji,jj) ) , zfric_umax ) , zfric_umin ) … … 211 214 fdtcn(ji,jj) = zindb * rau0 * rcp * 0.006 * zfric_u * ( (sst_m(ji,jj) + rt0) - t_bo(ji,jj) ) 212 215 ! also category dependent 213 ! !-- Energy from the turbulent oceanic heat flux heat flux coming in the lead216 ! !-- Energy from the turbulent oceanic heat flux heat flux coming in the lead 214 217 qdtcn(ji,jj) = zindb * fdtcn(ji,jj) * (1.0 - at_i(ji,jj)) * rdt_ice 215 !216 217 ! still need to be updated : fdtcn !!!!218 ! !-- Lead heat budget (part 1, next one is in limthd_dh219 ! !-- qldif -- (or qldif_1d in 1d routines)218 ! 219 220 ! still need to be updated : fdtcn !!!! 221 ! !-- Lead heat budget (part 1, next one is in limthd_dh 222 ! !-- qldif -- (or qldif_1d in 1d routines) 220 223 zfontn = sprecip(ji,jj) * lfus ! energy of melting 221 224 zfnsol = qns(ji,jj) ! total non solar flux … … 232 235 !false 233 236 zqlbsbq(ji,jj) = qldif(ji,jj) * ( 1.0 - zpareff ) / & 234 237 MAX( at_i(ji,jj) * rdt_ice , epsi16 ) 235 238 236 239 ! Heat budget of the lead, energy transferred from ice to ocean … … 244 247 ! calculate oceanic heat flux (limthd_dh) 245 248 fbif (ji,jj) = zindb * ( fsbbq(ji,jj) / MAX( at_i(ji,jj) , epsi20 ) + fdtcn(ji,jj) ) 246 249 247 250 ! computation of the daily thermodynamic ice production (only needed for output) 248 251 zhicifp(ji,jj) = ht_i(ji,jj,1) * at_i(ji,jj) … … 251 254 END DO 252 255 253 !------------------------------------------------------------------------------!254 ! 3) Select icy points and fulfill arrays for the vectorial grid.255 !------------------------------------------------------------------------------!256 !------------------------------------------------------------------------------! 257 ! 3) Select icy points and fulfill arrays for the vectorial grid. 258 !------------------------------------------------------------------------------! 256 259 257 260 DO jl = 1, jpl !loop over ice categories 258 261 259 WRITE(numout,*) ' lim_thd : transfer to 1D vectors. Category no : ', jl 260 WRITE(numout,*) ' ~~~~~~~~' 262 IF( kt == nit000 .AND. lwp ) THEN 263 WRITE(numout,*) ' lim_thd : transfer to 1D vectors. Category no : ', jl 264 WRITE(numout,*) ' ~~~~~~~~' 265 ENDIF 261 266 262 267 zareamin = 1.0e-10 … … 270 275 ! debug point to follow 271 276 IF ( (ji.eq.jiindx).AND.(jj.eq.jjindx) ) THEN 272 277 jiindex_1d = nbpb 273 278 ENDIF 274 279 END DO 275 280 END DO 276 281 277 !------------------------------------------------------------------------------!278 ! 4) Thermodynamic computation279 !------------------------------------------------------------------------------!282 !------------------------------------------------------------------------------! 283 ! 4) Thermodynamic computation 284 !------------------------------------------------------------------------------! 280 285 281 286 IF( lk_mpp ) CALL mpp_ini_ice(nbpb) … … 283 288 IF (nbpb > 0) THEN ! If there is no ice, do nothing. 284 289 285 !-------------------------286 ! 4.1 Move to 1D arrays287 !-------------------------290 !------------------------- 291 ! 4.1 Move to 1D arrays 292 !------------------------- 288 293 289 294 CALL tab_2d_1d( nbpb, at_i_b (1:nbpb) , at_i , jpi, jpj, npb(1:nbpb) ) … … 330 335 CALL tab_2d_1d( nbpb, qfvbq_1d (1:nbpb) , qfvbq , jpi, jpj, npb(1:nbpb) ) 331 336 332 !--------------------------------333 ! 4.3) Thermodynamic processes334 !--------------------------------335 337 !-------------------------------- 338 ! 4.3) Thermodynamic processes 339 !-------------------------------- 340 336 341 IF ( con_i ) CALL lim_thd_enmelt(1,nbpb) ! computes sea ice energy of melting 337 342 IF ( con_i ) CALL lim_thd_glohec( qt_i_in , qt_s_in , & 338 339 340 343 q_i_layer_in , 1 , nbpb , jl ) 344 345 !---------------------------------! 341 346 CALL lim_thd_dif(1,nbpb,jl) ! Ice/Snow Temperature profile ! 342 347 !---------------------------------! 343 348 344 349 CALL lim_thd_enmelt(1,nbpb) ! computes sea ice energy of melting 345 350 ! compulsory for limthd_dh 346 351 347 352 IF ( con_i ) CALL lim_thd_glohec( qt_i_fin , qt_s_fin , & 348 353 q_i_layer_fin , 1 , nbpb , jl ) 349 354 IF ( con_i ) CALL lim_thd_con_dif( 1 , nbpb , jl ) 350 355 351 356 !---------------------------------! 352 357 CALL lim_thd_dh(1,nbpb,jl) ! Ice/Snow thickness ! 353 354 355 358 !---------------------------------! 359 360 !---------------------------------! 356 361 CALL lim_thd_ent(1,nbpb,jl) ! Ice/Snow enthalpy remapping ! 357 358 359 362 !---------------------------------! 363 364 !---------------------------------! 360 365 CALL lim_thd_sal(1,nbpb) ! Ice salinity computation ! 361 362 363 ! CALL lim_thd_enmelt(1,nbpb) ! computes sea ice energy of melting366 !---------------------------------! 367 368 ! CALL lim_thd_enmelt(1,nbpb) ! computes sea ice energy of melting 364 369 IF ( con_i ) CALL lim_thd_glohec( qt_i_fin, qt_s_fin, & 365 370 q_i_layer_fin , 1 , nbpb , jl ) 366 371 IF ( con_i ) CALL lim_thd_con_dh ( 1 , nbpb , jl ) 367 372 368 !--------------------------------369 ! 4.4) Move 1D to 2D vectors370 !--------------------------------373 !-------------------------------- 374 ! 4.4) Move 1D to 2D vectors 375 !-------------------------------- 371 376 372 377 CALL tab_1d_2d( nbpb, at_i , npb, at_i_b (1:nbpb), jpi, jpj ) … … 416 421 !+++++ 417 422 418 IF( lk_mpp ) CALL mpp_comm_free(ncomm_ice) !RB necessary ??423 IF( lk_mpp ) CALL mpp_comm_free(ncomm_ice) !RB necessary ?? 419 424 ENDIF ! nbpb 420 425 421 426 END DO ! jl 422 427 423 !------------------------------------------------------------------------------!424 ! 5) Global variables, diagnostics425 !------------------------------------------------------------------------------!428 !------------------------------------------------------------------------------! 429 ! 5) Global variables, diagnostics 430 !------------------------------------------------------------------------------! 426 431 427 432 !------------------------ … … 431 436 ! Enthalpies are global variables we have to readjust the units 432 437 DO jl = 1, jpl 433 DO jk = 1, nlay_i434 DO jj = 1, jpj435 DO ji = 1, jpi436 ! Change dimensions437 e_i(ji,jj,jk,jl) = e_i(ji,jj,jk,jl) / unit_fac438 439 ! Multiply by volume, divide by nlayers so that heat content in 10^9 Joules440 e_i(ji,jj,jk,jl) = e_i(ji,jj,jk,jl) * &441 442 443 END DO !ji444 END DO !jj445 END DO !jk438 DO jk = 1, nlay_i 439 DO jj = 1, jpj 440 DO ji = 1, jpi 441 ! Change dimensions 442 e_i(ji,jj,jk,jl) = e_i(ji,jj,jk,jl) / unit_fac 443 444 ! Multiply by volume, divide by nlayers so that heat content in 10^9 Joules 445 e_i(ji,jj,jk,jl) = e_i(ji,jj,jk,jl) * & 446 area(ji,jj) * a_i(ji,jj,jl) * & 447 ht_i(ji,jj,jl) / nlay_i 448 END DO !ji 449 END DO !jj 450 END DO !jk 446 451 END DO !jl 447 452 … … 459 464 ! Multiply by volume, so that heat content in 10^9 Joules 460 465 e_s(ji,jj,jk,jl) = e_s(ji,jj,jk,jl) * area(ji,jj) * & 461 466 a_i(ji,jj,jl) * ht_s(ji,jj,jl) / nlay_s 462 467 END DO !ji 463 468 END DO !jj … … 513 518 END SUBROUTINE lim_thd 514 519 515 !===============================================================================520 !=============================================================================== 516 521 517 522 SUBROUTINE lim_thd_glohec(eti,ets,etilayer,kideb,kiut,jl) … … 552 557 DO ji = kideb, kiut 553 558 etilayer(ji,jk) = q_i_b(ji,jk) & 554 559 * ht_i_b(ji) / nlay_i 555 560 eti(ji,jl) = eti(ji,jl) + etilayer(ji,jk) 556 561 END DO … … 567 572 WRITE(numout,*) ' qt_s_in : ', ets(jiindex_1d,jl) / rdt_ice 568 573 WRITE(numout,*) ' qt_in : ', ( eti(jiindex_1d,jl) + & 569 574 ets(jiindex_1d,jl) ) / rdt_ice 570 575 571 576 END SUBROUTINE lim_thd_glohec 572 577 573 !===============================================================================578 !=============================================================================== 574 579 575 580 SUBROUTINE lim_thd_con_dif(kideb,kiut,jl) … … 594 599 INTEGER :: & 595 600 numce !: number of points for which conservation 596 601 ! is violated 597 602 INTEGER :: & 598 603 ji,jk, & !: loop indices … … 602 607 max_cons_err = 1.0 603 608 max_surf_err = 0.001 604 609 605 610 !-------------------------- 606 611 ! Increment of energy … … 608 613 ! global 609 614 DO ji = kideb, kiut 610 611 615 dq_i(ji,jl) = qt_i_fin(ji,jl) - qt_i_in(ji,jl) & 616 + qt_s_fin(ji,jl) - qt_s_in(ji,jl) 612 617 END DO 613 618 ! layer by layer … … 619 624 620 625 DO ji = kideb, kiut 621 622 623 624 625 qnsr_ice_1d(ji) + & ! atm non solar626 (1.0-i0(ji))*qsr_ice_1d(ji) ! atm solar627 628 629 626 zji = MOD( npb(ji) - 1, jpi ) + 1 627 zjj = ( npb(ji) - 1 ) / jpi + 1 628 629 fatm(ji,jl) = & 630 qnsr_ice_1d(ji) + & ! atm non solar 631 (1.0-i0(ji))*qsr_ice_1d(ji) ! atm solar 632 633 sum_fluxq(ji,jl) = fc_su(ji) - fc_bo_i(ji) + qsr_ice_1d(ji)*i0(ji) & 634 - fstroc(zji,zjj,jl) 630 635 END DO 631 636 … … 635 640 636 641 DO ji = kideb, kiut 637 642 cons_error(ji,jl) = ABS( dq_i(ji,jl) / rdt_ice + sum_fluxq(ji,jl) ) 638 643 END DO 639 644 … … 641 646 meance = 0.0 642 647 DO ji = kideb, kiut 643 644 645 646 648 IF ( cons_error(ji,jl) .GT. max_cons_err ) THEN 649 numce = numce + 1 650 meance = meance + cons_error(ji,jl) 651 ENDIF 647 652 ENDDO 648 653 IF (numce .GT. 0 ) meance = meance / numce … … 651 656 WRITE(numout,*) ' After lim_thd_dif, category : ', jl 652 657 WRITE(numout,*) ' Mean conservation error on big error points ', meance, & 653 numit658 numit 654 659 WRITE(numout,*) ' Number of points where there is a cons err gt than c.e. : ', numce, numit 655 660 … … 663 668 surf_error(ji,jl) = ABS ( fatm(ji,jl) - fc_su(ji) ) 664 669 IF ( ( t_su_b(ji) .LT. rtt ) .AND. ( surf_error(ji,jl) .GT. & 665 670 max_surf_err ) ) THEN 666 671 numce = numce + 1 667 672 meance = meance + surf_error(ji,jl) … … 685 690 DO ji = kideb, kiut 686 691 IF ( ( ( t_su_b(ji) .LT. rtt ) .AND. ( surf_error(ji,jl) .GT. max_surf_err ) ) .OR. & 687 688 zji = MOD( npb(ji) - 1, jpi ) + 1689 zjj = ( npb(ji) - 1 ) / jpi + 1690 691 WRITE(numout,*) ' alerte 1 '692 WRITE(numout,*) ' Untolerated conservation / surface error after '693 WRITE(numout,*) ' heat diffusion in the ice '694 WRITE(numout,*) ' Category : ', jl695 WRITE(numout,*) ' zji , zjj : ', zji, zjj696 WRITE(numout,*) ' lat, lon : ', gphit(zji,zjj), glamt(zji,zjj)697 WRITE(numout,*) ' cons_error : ', cons_error(ji,jl)698 WRITE(numout,*) ' surf_error : ', surf_error(ji,jl)699 WRITE(numout,*) ' dq_i : ', - dq_i(ji,jl) / rdt_ice700 WRITE(numout,*) ' Fdt : ', sum_fluxq(ji,jl)701 WRITE(numout,*)702 ! WRITE(numout,*) ' qt_i_in : ', qt_i_in(ji,jl)703 ! WRITE(numout,*) ' qt_s_in : ', qt_s_in(ji,jl)704 ! WRITE(numout,*) ' qt_i_fin : ', qt_i_fin(ji,jl)705 ! WRITE(numout,*) ' qt_s_fin : ', qt_s_fin(ji,jl)706 ! WRITE(numout,*) ' qt : ', qt_i_fin(ji,jl) + &707 ! qt_s_fin(ji,jl)708 WRITE(numout,*) ' ht_i : ', ht_i_b(ji)709 WRITE(numout,*) ' ht_s : ', ht_s_b(ji)710 WRITE(numout,*) ' t_su : ', t_su_b(ji)711 WRITE(numout,*) ' t_s : ', t_s_b(ji,1)712 WRITE(numout,*) ' t_i : ', t_i_b(ji,1:nlay_i)713 WRITE(numout,*) ' t_bo : ', t_bo_b(ji)714 WRITE(numout,*) ' q_i : ', q_i_b(ji,1:nlay_i)715 WRITE(numout,*) ' s_i : ', s_i_b(ji,1:nlay_i)716 WRITE(numout,*) ' tmelts : ', rtt - tmut*s_i_b(ji,1:nlay_i)717 WRITE(numout,*)718 WRITE(numout,*) ' Fluxes '719 WRITE(numout,*) ' ~~~~~~ '720 WRITE(numout,*) ' fatm : ', fatm(ji,jl)721 WRITE(numout,*) ' fc_su : ', fc_su (ji)722 WRITE(numout,*) ' fstr_inice : ', qsr_ice_1d(ji)*i0(ji)723 WRITE(numout,*) ' fc_bo : ', - fc_bo_i (ji)724 WRITE(numout,*) ' foc : ', fbif_1d(ji)725 WRITE(numout,*) ' fstroc : ', fstroc (zji,zjj,jl)726 WRITE(numout,*) ' i0 : ', i0(ji)727 WRITE(numout,*) ' qsr_ice : ', (1.0-i0(ji))*qsr_ice_1d(ji)728 WRITE(numout,*) ' qns_ice : ', qnsr_ice_1d(ji)729 WRITE(numout,*) ' Conduction fluxes : '730 WRITE(numout,*) ' fc_s : ', fc_s(ji,0:nlay_s)731 WRITE(numout,*) ' fc_i : ', fc_i(ji,0:nlay_i)732 WRITE(numout,*)733 WRITE(numout,*) ' Layer by layer ... '734 WRITE(numout,*) ' dq_snow : ', ( qt_s_fin(ji,jl) - &735 736 737 WRITE(numout,*) ' dfc_snow : ', fc_s(ji,1) - &738 739 DO jk = 1, nlay_i740 WRITE(numout,*) ' layer : ', jk741 WRITE(numout,*) ' dq_ice : ', dq_i_layer(ji,jk) / rdt_ice742 WRITE(numout,*) ' radab : ', radab(ji,jk)743 WRITE(numout,*) ' dfc_i : ', fc_i(ji,jk) - &744 745 WRITE(numout,*) ' tot f : ', fc_i(ji,jk) - &746 747 END DO692 ( cons_error(ji,jl) .GT. max_cons_err ) ) THEN 693 zji = MOD( npb(ji) - 1, jpi ) + 1 694 zjj = ( npb(ji) - 1 ) / jpi + 1 695 696 WRITE(numout,*) ' alerte 1 ' 697 WRITE(numout,*) ' Untolerated conservation / surface error after ' 698 WRITE(numout,*) ' heat diffusion in the ice ' 699 WRITE(numout,*) ' Category : ', jl 700 WRITE(numout,*) ' zji , zjj : ', zji, zjj 701 WRITE(numout,*) ' lat, lon : ', gphit(zji,zjj), glamt(zji,zjj) 702 WRITE(numout,*) ' cons_error : ', cons_error(ji,jl) 703 WRITE(numout,*) ' surf_error : ', surf_error(ji,jl) 704 WRITE(numout,*) ' dq_i : ', - dq_i(ji,jl) / rdt_ice 705 WRITE(numout,*) ' Fdt : ', sum_fluxq(ji,jl) 706 WRITE(numout,*) 707 ! WRITE(numout,*) ' qt_i_in : ', qt_i_in(ji,jl) 708 ! WRITE(numout,*) ' qt_s_in : ', qt_s_in(ji,jl) 709 ! WRITE(numout,*) ' qt_i_fin : ', qt_i_fin(ji,jl) 710 ! WRITE(numout,*) ' qt_s_fin : ', qt_s_fin(ji,jl) 711 ! WRITE(numout,*) ' qt : ', qt_i_fin(ji,jl) + & 712 ! qt_s_fin(ji,jl) 713 WRITE(numout,*) ' ht_i : ', ht_i_b(ji) 714 WRITE(numout,*) ' ht_s : ', ht_s_b(ji) 715 WRITE(numout,*) ' t_su : ', t_su_b(ji) 716 WRITE(numout,*) ' t_s : ', t_s_b(ji,1) 717 WRITE(numout,*) ' t_i : ', t_i_b(ji,1:nlay_i) 718 WRITE(numout,*) ' t_bo : ', t_bo_b(ji) 719 WRITE(numout,*) ' q_i : ', q_i_b(ji,1:nlay_i) 720 WRITE(numout,*) ' s_i : ', s_i_b(ji,1:nlay_i) 721 WRITE(numout,*) ' tmelts : ', rtt - tmut*s_i_b(ji,1:nlay_i) 722 WRITE(numout,*) 723 WRITE(numout,*) ' Fluxes ' 724 WRITE(numout,*) ' ~~~~~~ ' 725 WRITE(numout,*) ' fatm : ', fatm(ji,jl) 726 WRITE(numout,*) ' fc_su : ', fc_su (ji) 727 WRITE(numout,*) ' fstr_inice : ', qsr_ice_1d(ji)*i0(ji) 728 WRITE(numout,*) ' fc_bo : ', - fc_bo_i (ji) 729 WRITE(numout,*) ' foc : ', fbif_1d(ji) 730 WRITE(numout,*) ' fstroc : ', fstroc (zji,zjj,jl) 731 WRITE(numout,*) ' i0 : ', i0(ji) 732 WRITE(numout,*) ' qsr_ice : ', (1.0-i0(ji))*qsr_ice_1d(ji) 733 WRITE(numout,*) ' qns_ice : ', qnsr_ice_1d(ji) 734 WRITE(numout,*) ' Conduction fluxes : ' 735 WRITE(numout,*) ' fc_s : ', fc_s(ji,0:nlay_s) 736 WRITE(numout,*) ' fc_i : ', fc_i(ji,0:nlay_i) 737 WRITE(numout,*) 738 WRITE(numout,*) ' Layer by layer ... ' 739 WRITE(numout,*) ' dq_snow : ', ( qt_s_fin(ji,jl) - & 740 qt_s_in(ji,jl) ) & 741 / rdt_ice 742 WRITE(numout,*) ' dfc_snow : ', fc_s(ji,1) - & 743 fc_s(ji,0) 744 DO jk = 1, nlay_i 745 WRITE(numout,*) ' layer : ', jk 746 WRITE(numout,*) ' dq_ice : ', dq_i_layer(ji,jk) / rdt_ice 747 WRITE(numout,*) ' radab : ', radab(ji,jk) 748 WRITE(numout,*) ' dfc_i : ', fc_i(ji,jk) - & 749 fc_i(ji,jk-1) 750 WRITE(numout,*) ' tot f : ', fc_i(ji,jk) - & 751 fc_i(ji,jk-1) - radab(ji,jk) 752 END DO 748 753 749 754 ENDIF 750 755 751 756 END DO 752 757 753 758 END SUBROUTINE lim_thd_con_dif 754 759 755 !==============================================================================760 !============================================================================== 756 761 757 762 SUBROUTINE lim_thd_con_dh(kideb,kiut,jl) … … 775 780 INTEGER :: & 776 781 numce !: number of points for which conservation 777 782 ! is violated 778 783 INTEGER :: ji, zji, zjj ! loop indices 779 784 !!--------------------------------------------------------------------- 780 785 781 786 max_cons_err = 1.0 782 787 783 788 !-------------------------- 784 789 ! Increment of energy … … 786 791 ! global 787 792 DO ji = kideb, kiut 788 789 793 dq_i(ji,jl) = qt_i_fin(ji,jl) - qt_i_in(ji,jl) & 794 + qt_s_fin(ji,jl) - qt_s_in(ji,jl) 790 795 END DO 791 796 ! layer by layer … … 797 802 798 803 DO ji = kideb, kiut 799 800 801 802 803 qnsr_ice_1d(ji) + & ! atm non solar804 ! (1.0-i0(ji))*qsr_ice_1d(ji) ! atm solar805 qsr_ice_1d(ji) ! atm solar806 807 808 809 804 zji = MOD( npb(ji) - 1, jpi ) + 1 805 zjj = ( npb(ji) - 1 ) / jpi + 1 806 807 fatm(ji,jl) = & 808 qnsr_ice_1d(ji) + & ! atm non solar 809 ! (1.0-i0(ji))*qsr_ice_1d(ji) ! atm solar 810 qsr_ice_1d(ji) ! atm solar 811 812 sum_fluxq(ji,jl) = fatm(ji,jl) + fbif_1d(ji) - ftotal_fin(ji) & 813 - fstroc(zji,zjj,jl) 814 cons_error(ji,jl) = ABS( dq_i(ji,jl) / rdt_ice + sum_fluxq(ji,jl) ) 810 815 END DO 811 816 … … 815 820 816 821 DO ji = kideb, kiut 817 822 cons_error(ji,jl) = ABS( dq_i(ji,jl) / rdt_ice + sum_fluxq(ji,jl) ) 818 823 END DO 819 824 … … 821 826 meance = 0.0 822 827 DO ji = kideb, kiut 823 824 825 826 828 IF ( cons_error(ji,jl) .GT. max_cons_err ) THEN 829 numce = numce + 1 830 meance = meance + cons_error(ji,jl) 831 ENDIF 827 832 ENDDO 828 833 IF (numce .GT. 0 ) meance = meance / numce … … 833 838 WRITE(numout,*) ' After lim_thd_ent, category : ', jl 834 839 WRITE(numout,*) ' Mean conservation error on big error points ', meance, & 835 numit840 numit 836 841 WRITE(numout,*) ' Number of points where there is a cons err gt than 0.1 W/m2 : ', numce, numit 837 842 … … 842 847 DO ji = kideb, kiut 843 848 IF ( cons_error(ji,jl) .GT. max_cons_err ) THEN 844 zji = MOD( npb(ji) - 1, jpi ) + 1845 zjj = ( npb(ji) - 1 ) / jpi + 1846 847 WRITE(numout,*) ' alerte 1 - category : ', jl848 WRITE(numout,*) ' Untolerated conservation error after limthd_ent '849 WRITE(numout,*) ' zji , zjj : ', zji, zjj850 WRITE(numout,*) ' lat, lon : ', gphit(zji,zjj), glamt(zji,zjj)851 WRITE(numout,*) ' * '852 WRITE(numout,*) ' Ftotal : ', sum_fluxq(ji,jl)853 WRITE(numout,*) ' dq_t : ', - dq_i(ji,jl) / rdt_ice854 WRITE(numout,*) ' dq_i : ', - ( qt_i_fin(ji,jl) - qt_i_in(ji,jl) ) / rdt_ice855 WRITE(numout,*) ' dq_s : ', - ( qt_s_fin(ji,jl) - qt_s_in(ji,jl) ) / rdt_ice856 WRITE(numout,*) ' cons_error : ', cons_error(ji,jl)857 WRITE(numout,*) ' * '858 WRITE(numout,*) ' Fluxes --- : '859 WRITE(numout,*) ' fatm : ', fatm(ji,jl)860 WRITE(numout,*) ' foce : ', fbif_1d(ji)861 WRITE(numout,*) ' fres : ', ftotal_fin(ji)862 WRITE(numout,*) ' fhbri : ', fhbricat(zji,zjj,jl)863 WRITE(numout,*) ' * '864 WRITE(numout,*) ' Heat contents --- : '865 WRITE(numout,*) ' qt_s_in : ', qt_s_in(ji,jl) / rdt_ice866 WRITE(numout,*) ' qt_i_in : ', qt_i_in(ji,jl) / rdt_ice867 WRITE(numout,*) ' qt_in : ', ( qt_i_in(ji,jl) + &868 869 WRITE(numout,*) ' qt_s_fin : ', qt_s_fin(ji,jl) / rdt_ice870 WRITE(numout,*) ' qt_i_fin : ', qt_i_fin(ji,jl) / rdt_ice871 WRITE(numout,*) ' qt_fin : ', ( qt_i_fin(ji,jl) + &872 873 WRITE(numout,*) ' * '874 WRITE(numout,*) ' Ice variables --- : '875 WRITE(numout,*) ' ht_i : ', ht_i_b(ji)876 WRITE(numout,*) ' ht_s : ', ht_s_b(ji)877 WRITE(numout,*) ' dh_s_tot : ', dh_s_tot(ji)878 WRITE(numout,*) ' dh_snowice: ', dh_snowice(ji)879 WRITE(numout,*) ' dh_i_surf : ', dh_i_surf(ji)880 WRITE(numout,*) ' dh_i_bott : ', dh_i_bott(ji)849 zji = MOD( npb(ji) - 1, jpi ) + 1 850 zjj = ( npb(ji) - 1 ) / jpi + 1 851 852 WRITE(numout,*) ' alerte 1 - category : ', jl 853 WRITE(numout,*) ' Untolerated conservation error after limthd_ent ' 854 WRITE(numout,*) ' zji , zjj : ', zji, zjj 855 WRITE(numout,*) ' lat, lon : ', gphit(zji,zjj), glamt(zji,zjj) 856 WRITE(numout,*) ' * ' 857 WRITE(numout,*) ' Ftotal : ', sum_fluxq(ji,jl) 858 WRITE(numout,*) ' dq_t : ', - dq_i(ji,jl) / rdt_ice 859 WRITE(numout,*) ' dq_i : ', - ( qt_i_fin(ji,jl) - qt_i_in(ji,jl) ) / rdt_ice 860 WRITE(numout,*) ' dq_s : ', - ( qt_s_fin(ji,jl) - qt_s_in(ji,jl) ) / rdt_ice 861 WRITE(numout,*) ' cons_error : ', cons_error(ji,jl) 862 WRITE(numout,*) ' * ' 863 WRITE(numout,*) ' Fluxes --- : ' 864 WRITE(numout,*) ' fatm : ', fatm(ji,jl) 865 WRITE(numout,*) ' foce : ', fbif_1d(ji) 866 WRITE(numout,*) ' fres : ', ftotal_fin(ji) 867 WRITE(numout,*) ' fhbri : ', fhbricat(zji,zjj,jl) 868 WRITE(numout,*) ' * ' 869 WRITE(numout,*) ' Heat contents --- : ' 870 WRITE(numout,*) ' qt_s_in : ', qt_s_in(ji,jl) / rdt_ice 871 WRITE(numout,*) ' qt_i_in : ', qt_i_in(ji,jl) / rdt_ice 872 WRITE(numout,*) ' qt_in : ', ( qt_i_in(ji,jl) + & 873 qt_s_in(ji,jl) ) / rdt_ice 874 WRITE(numout,*) ' qt_s_fin : ', qt_s_fin(ji,jl) / rdt_ice 875 WRITE(numout,*) ' qt_i_fin : ', qt_i_fin(ji,jl) / rdt_ice 876 WRITE(numout,*) ' qt_fin : ', ( qt_i_fin(ji,jl) + & 877 qt_s_fin(ji,jl) ) / rdt_ice 878 WRITE(numout,*) ' * ' 879 WRITE(numout,*) ' Ice variables --- : ' 880 WRITE(numout,*) ' ht_i : ', ht_i_b(ji) 881 WRITE(numout,*) ' ht_s : ', ht_s_b(ji) 882 WRITE(numout,*) ' dh_s_tot : ', dh_s_tot(ji) 883 WRITE(numout,*) ' dh_snowice: ', dh_snowice(ji) 884 WRITE(numout,*) ' dh_i_surf : ', dh_i_surf(ji) 885 WRITE(numout,*) ' dh_i_bott : ', dh_i_bott(ji) 881 886 882 887 ENDIF 883 888 884 889 END DO 885 890 886 891 END SUBROUTINE lim_thd_con_dh 887 !==============================================================================892 !============================================================================== 888 893 889 894 SUBROUTINE lim_thd_enmelt(kideb,kiut) … … 899 904 INTEGER, INTENT(in) :: & 900 905 kideb, kiut !: bounds for the spatial loop 901 906 902 907 REAL(wp) :: & !: goes to trash 903 908 ztmelts , & !: sea ice freezing point in K … … 916 921 ztmelts = - tmut * s_i_b(ji,jk) + rtt 917 922 q_i_b(ji,jk) = rhoic*( cpic * ( ztmelts - t_i_b(ji,jk) ) & 918 919 923 + lfus * ( 1.0 - (ztmelts-rtt)/MIN((t_i_b(ji,jk)-rtt),-zeps) ) & 924 - rcp * ( ztmelts-rtt ) ) 920 925 END DO !ji 921 926 END DO !jk … … 930 935 END SUBROUTINE lim_thd_enmelt 931 936 932 !==============================================================================937 !============================================================================== 933 938 934 939 SUBROUTINE lim_thd_init … … 954 959 & kappa_i, nconv_i_thd, maxer_i_thd, thcon_i_swi 955 960 !!------------------------------------------------------------------- 956 961 957 962 ! Define the initial parameters 958 963 ! ------------------------- … … 990 995 WRITE(numout,*) 991 996 ENDIF 992 997 993 998 rcdsn = hakdif * rcdsn 994 999 rcdic = hakdif * rcdic 995 1000 996 1001 997 1002 END SUBROUTINE lim_thd_init -
trunk/NEMO/LIM_SRC_3/limthd_dh.F90
r888 r921 24 24 USE par_ice 25 25 USE lib_mpp 26 26 27 27 IMPLICIT NONE 28 28 PRIVATE … … 46 46 47 47 SUBROUTINE lim_thd_dh(kideb,kiut,jl) 48 !!------------------------------------------------------------------ 49 !! *** ROUTINE lim_thd_dh *** 50 !!------------------------------------------------------------------ 51 !! ** Purpose : 52 !! This routine determines variations of ice and snow thicknesses. 53 !! ** Method : 54 !! Ice/Snow surface melting arises from imbalance in surface fluxes 55 !! Bottom accretion/ablation arises from flux budget 56 !! Snow thickness can increase by precipitation and decrease by 57 !! sublimation 58 !! If snow load excesses Archmiede limit, snow-ice is formed by 59 !! the flooding of sea-water in the snow 60 !! ** Steps 61 !! 1) Compute available flux of heat for surface ablation 62 !! 2) Compute snow and sea ice enthalpies 63 !! 3) Surface ablation and sublimation 64 !! 4) Bottom accretion/ablation 65 !! 5) Case of Total ablation 66 !! 6) Snow ice formation 67 !! 68 !! ** Arguments 69 !! 70 !! ** Inputs / Outputs 71 !! 72 !! ** External 73 !! 74 !! ** References : Bitz and Lipscomb, JGR 99 75 !! Fichefet T. and M. Maqueda 1997, J. Geophys. Res., 102(C6), 12609-12646 76 !! Vancoppenolle, Fichefet and Bitz, GRL 2005 77 !! Vancoppenolle et al., OM08 78 !! 79 !! ** History : 80 !! original code 01-04 (LIM) 81 !! original routine 82 !! (05-2003) M. Vancoppenolle, Louvain-La-Neuve, Belgium 83 !! (06/07-2005) 3D version 84 !! (03-2008) Clean code 85 !! 86 !!------------------------------------------------------------------ 87 !! * Arguments 88 INTEGER , INTENT (IN) :: & 89 kideb , & !: Start point on which the the computation is applied 90 kiut , & !: End point on which the the computation is applied 91 jl !: Thickness cateogry number 92 93 !! * Local variables 94 INTEGER :: & 95 ji , & !: space index 96 jk , & !: ice layer index 97 isnow , & !: switch for presence (1) or absence (0) of snow 98 zji , & !: 2D corresponding indices to ji 99 zjj , & 100 isnowic , & !: snow ice formation not 101 i_ice_switch , & !: ice thickness above a certain treshold or not 102 iter 103 104 REAL(wp) :: & 105 zhsnew , & !: new snow thickness 106 zihgnew , & !: switch for total ablation 107 ztmelts , & !: melting point 108 zhn , & 109 zdhcf , & 110 zdhbf , & 111 zhni , & 112 zhnfi , & 113 zihg , & 114 zdhnm , & 115 zhnnew , & 116 zeps = 1.0e-13, & 117 zhisn , & 118 zfracs , & !: fractionation coefficient for bottom salt 119 !: entrapment 120 zds , & !: increment of bottom ice salinity 121 zcoeff , & !: dummy argument for snowfall partitioning 122 !: over ice and leads 123 zsm_snowice, & !: snow-ice salinity 124 zswi1 , & !: switch for computation of bottom salinity 125 zswi12 , & !: switch for computation of bottom salinity 126 zswi2 , & !: switch for computation of bottom salinity 127 zgrr , & !: bottom growth rate 128 zihic , & !: 129 ztform !: bottom formation temperature 130 131 REAL(wp) , DIMENSION(jpij) :: & 132 zh_i , & ! ice layer thickness 133 zh_s , & ! snow layer thickness 134 ztfs , & ! melting point 135 zhsold , & ! old snow thickness 136 zqprec , & !: energy of fallen snow 137 zqfont_su , & ! incoming, remaining surface energy 138 zqfont_bo ! incoming, bottom energy 139 140 REAL(wp) , DIMENSION(jpij) :: & 141 z_f_surf, & ! surface heat for ablation 142 zhgnew ! new ice thickness 143 144 REAL(wp), DIMENSION(jpij) :: & 145 zdh_s_mel , & ! snow melt 146 zdh_s_pre , & ! snow precipitation 147 zdh_s_sub , & ! snow sublimation 148 zfsalt_melt ! salt flux due to ice melt 149 150 REAL(wp) , DIMENSION(jpij,jkmax) :: & 151 zdeltah 152 153 ! Pathological cases 154 REAL(wp), DIMENSION(jpij) :: & 155 zfdt_init , & !: total incoming heat for ice melt 156 zfdt_final , & !: total remaing heat for ice melt 157 zqt_i , & !: total ice heat content 158 zqt_s , & !: total snow heat content 159 zqt_dummy !: dummy heat content 160 161 REAL(wp), DIMENSION(jpij,jkmax) :: & 162 zqt_i_lay !: total ice heat content 163 164 ! Heat conservation 165 REAL(wp), DIMENSION(jpij) :: & 166 zfbase, & 167 zdq_i 168 169 INTEGER, DIMENSION(jpij) :: & 170 innermelt 171 172 REAL(wp) :: & 173 meance_dh 174 175 INTEGER :: & 176 num_iter_max, & 177 numce_dh 178 179 !!----------------------------------------------------------------------------- 180 181 WRITE(numout,*) 'lim_thd_dh : computation of vertical snow/ice accretion/ablation' 182 WRITE(numout,*) '~~~~~~~~~' 48 !!------------------------------------------------------------------ 49 !! *** ROUTINE lim_thd_dh *** 50 !!------------------------------------------------------------------ 51 !! ** Purpose : 52 !! This routine determines variations of ice and snow thicknesses. 53 !! ** Method : 54 !! Ice/Snow surface melting arises from imbalance in surface fluxes 55 !! Bottom accretion/ablation arises from flux budget 56 !! Snow thickness can increase by precipitation and decrease by 57 !! sublimation 58 !! If snow load excesses Archmiede limit, snow-ice is formed by 59 !! the flooding of sea-water in the snow 60 !! ** Steps 61 !! 1) Compute available flux of heat for surface ablation 62 !! 2) Compute snow and sea ice enthalpies 63 !! 3) Surface ablation and sublimation 64 !! 4) Bottom accretion/ablation 65 !! 5) Case of Total ablation 66 !! 6) Snow ice formation 67 !! 68 !! ** Arguments 69 !! 70 !! ** Inputs / Outputs 71 !! 72 !! ** External 73 !! 74 !! ** References : Bitz and Lipscomb, JGR 99 75 !! Fichefet T. and M. Maqueda 1997, J. Geophys. Res., 102(C6), 12609-12646 76 !! Vancoppenolle, Fichefet and Bitz, GRL 2005 77 !! Vancoppenolle et al., OM08 78 !! 79 !! ** History : 80 !! original code 01-04 (LIM) 81 !! original routine 82 !! (05-2003) M. Vancoppenolle, Louvain-La-Neuve, Belgium 83 !! (06/07-2005) 3D version 84 !! (03-2008) Clean code 85 !! 86 !!------------------------------------------------------------------ 87 !! * Arguments 88 INTEGER , INTENT (IN) :: & 89 kideb , & !: Start point on which the the computation is applied 90 kiut , & !: End point on which the the computation is applied 91 jl !: Thickness cateogry number 92 93 !! * Local variables 94 INTEGER :: & 95 ji , & !: space index 96 jk , & !: ice layer index 97 isnow , & !: switch for presence (1) or absence (0) of snow 98 zji , & !: 2D corresponding indices to ji 99 zjj , & 100 isnowic , & !: snow ice formation not 101 i_ice_switch , & !: ice thickness above a certain treshold or not 102 iter 103 104 REAL(wp) :: & 105 zhsnew , & !: new snow thickness 106 zihgnew , & !: switch for total ablation 107 ztmelts , & !: melting point 108 zhn , & 109 zdhcf , & 110 zdhbf , & 111 zhni , & 112 zhnfi , & 113 zihg , & 114 zdhnm , & 115 zhnnew , & 116 zeps = 1.0e-13, & 117 zhisn , & 118 zfracs , & !: fractionation coefficient for bottom salt 119 !: entrapment 120 zds , & !: increment of bottom ice salinity 121 zcoeff , & !: dummy argument for snowfall partitioning 122 !: over ice and leads 123 zsm_snowice, & !: snow-ice salinity 124 zswi1 , & !: switch for computation of bottom salinity 125 zswi12 , & !: switch for computation of bottom salinity 126 zswi2 , & !: switch for computation of bottom salinity 127 zgrr , & !: bottom growth rate 128 zihic , & !: 129 ztform !: bottom formation temperature 130 131 REAL(wp) , DIMENSION(jpij) :: & 132 zh_i , & ! ice layer thickness 133 zh_s , & ! snow layer thickness 134 ztfs , & ! melting point 135 zhsold , & ! old snow thickness 136 zqprec , & !: energy of fallen snow 137 zqfont_su , & ! incoming, remaining surface energy 138 zqfont_bo ! incoming, bottom energy 139 140 REAL(wp) , DIMENSION(jpij) :: & 141 z_f_surf, & ! surface heat for ablation 142 zhgnew ! new ice thickness 143 144 REAL(wp), DIMENSION(jpij) :: & 145 zdh_s_mel , & ! snow melt 146 zdh_s_pre , & ! snow precipitation 147 zdh_s_sub , & ! snow sublimation 148 zfsalt_melt ! salt flux due to ice melt 149 150 REAL(wp) , DIMENSION(jpij,jkmax) :: & 151 zdeltah 152 153 ! Pathological cases 154 REAL(wp), DIMENSION(jpij) :: & 155 zfdt_init , & !: total incoming heat for ice melt 156 zfdt_final , & !: total remaing heat for ice melt 157 zqt_i , & !: total ice heat content 158 zqt_s , & !: total snow heat content 159 zqt_dummy !: dummy heat content 160 161 REAL(wp), DIMENSION(jpij,jkmax) :: & 162 zqt_i_lay !: total ice heat content 163 164 ! Heat conservation 165 REAL(wp), DIMENSION(jpij) :: & 166 zfbase, & 167 zdq_i 168 169 INTEGER, DIMENSION(jpij) :: & 170 innermelt 171 172 REAL(wp) :: & 173 meance_dh 174 175 INTEGER :: & 176 num_iter_max, & 177 numce_dh 183 178 184 179 zfsalt_melt(:) = 0.0 … … 191 186 old_ht_s_b(ji) = ht_s_b(ji) 192 187 END DO 193 !194 !------------------------------------------------------------------------------!195 ! 1) Calculate available heat for surface ablation !196 !------------------------------------------------------------------------------!197 !188 ! 189 !------------------------------------------------------------------------------! 190 ! 1) Calculate available heat for surface ablation ! 191 !------------------------------------------------------------------------------! 192 ! 198 193 DO ji = kideb,kiut 199 194 isnow = INT( 1.0 - MAX ( 0.0 , SIGN ( 1.0 , - ht_s_b(ji) ) ) ) 200 195 ztfs(ji) = isnow * rtt + ( 1.0 - isnow ) * rtt 201 196 z_f_surf(ji) = qnsr_ice_1d(ji) + ( 1.0 - i0(ji) ) * & 202 197 qsr_ice_1d(ji) - fc_su(ji) 203 198 z_f_surf(ji) = MAX( zzero , z_f_surf(ji) ) * & 204 199 MAX( zzero , SIGN( zone , t_su_b(ji) - ztfs(ji) ) ) 205 200 zfdt_init(ji) = ( z_f_surf(ji) + & 206 207 201 MAX( fbif_1d(ji) + qlbbq_1d(ji) + fc_bo_i(ji),0.0 ) ) & 202 * rdt_ice 208 203 END DO ! ji 209 204 … … 212 207 dsm_i_se_1d(:) = 0.0 213 208 dsm_i_si_1d(:) = 0.0 214 !215 !------------------------------------------------------------------------------!216 ! 2) Computing layer thicknesses and snow and sea-ice enthalpies. !217 !------------------------------------------------------------------------------!218 !209 ! 210 !------------------------------------------------------------------------------! 211 ! 2) Computing layer thicknesses and snow and sea-ice enthalpies. ! 212 !------------------------------------------------------------------------------! 213 ! 219 214 ! Layer thickness 220 215 DO ji = kideb,kiut … … 239 234 END DO 240 235 END DO 241 !242 !------------------------------------------------------------------------------|243 ! 3) Surface ablation and sublimation |244 !------------------------------------------------------------------------------|245 !236 ! 237 !------------------------------------------------------------------------------| 238 ! 3) Surface ablation and sublimation | 239 !------------------------------------------------------------------------------| 240 ! 246 241 !------------------------- 247 242 ! 3.1 Snow precips / melt … … 272 267 zdeltah(ji,1) = MIN( 0.0 , - zqfont_su(ji) / MAX( zqprec(ji) , epsi13 ) ) 273 268 zqfont_su(ji) = MAX( 0.0 , - zdh_s_pre(ji) - zdeltah(ji,1) ) * & 274 269 zqprec(ji) 275 270 zdeltah(ji,1) = MAX( - zdh_s_pre(ji) , zdeltah(ji,1) ) 276 271 zdh_s_mel(ji) = zdh_s_mel(ji) + zdeltah(ji,1) … … 289 284 zdeltah(ji,jk) = - zqfont_su(ji) / q_s_b(ji,jk) 290 285 zqfont_su(ji) = MAX( 0.0 , - zh_s(ji) - zdeltah(ji,jk) ) * & 291 286 q_s_b(ji,jk) 292 287 zdeltah(ji,jk) = MAX( zdeltah(ji,jk) , - zh_s(ji) ) 293 288 zdh_s_mel(ji) = zdh_s_mel(ji) + zdeltah(ji,jk) !resulting melt of snow … … 306 301 ! Volume and mass variations of snow 307 302 dvsbq_1d(ji) = a_i_b(ji) * ( ht_s_b(ji) - zhsold(ji) & 308 303 - zdh_s_mel(ji) ) 309 304 dvsbq_1d(ji) = MIN( zzero, dvsbq_1d(ji) ) 310 305 rdmsnif_1d(ji) = rhosn*dvsbq_1d(ji) … … 327 322 ! recompute heat available 328 323 zqfont_su(ji) = MAX( 0.0 , - zh_i(ji) - zdeltah(ji,jk) ) * & 329 324 q_i_b(ji,jk) 330 325 ! melt of layer jk cannot be higher than its thickness 331 326 zdeltah(ji,jk) = MAX( zdeltah(ji,jk) , - zh_i(ji) ) … … 334 329 ! for energy conservation 335 330 zdq_i(ji) = zdq_i(ji) + zdeltah(ji,jk) * & 336 331 q_i_b(ji,jk) / rdt_ice 337 332 ! contribution to ice-ocean salt flux 338 333 zji = MOD( npb(ji) - 1, jpi ) + 1 339 334 zjj = ( npb(ji) - 1 ) / jpi + 1 340 335 zfsalt_melt(ji) = zfsalt_melt(ji) + & 341 342 343 336 ( sss_m(zji,zjj) - sm_i_b(ji) ) * & 337 a_i_b(ji) * & 338 MIN( zdeltah(ji,jk) , 0.0 ) * rhoic / rdt_ice 344 339 END DO ! ji 345 340 END DO ! jk … … 349 344 !------------------- 350 345 IF ( con_i ) THEN 351 numce_dh = 0352 meance_dh = 0.0353 DO ji = kideb, kiut354 355 IF ( ( z_f_surf(ji) + zdq_i(ji) ) .GE. 1.0e-3 ) THEN356 numce_dh = numce_dh + 1357 meance_dh = meance_dh + z_f_surf(ji) + zdq_i(ji)358 ENDIF359 360 IF ( z_f_surf(ji) + zdq_i(ji) .GE. 1.0e-3 ) THEN!361 WRITE(numout,*) ' ALERTE heat loss for surface melt '362 WRITE(numout,*) ' zji, zjj, jl :', zji, zjj, jl363 WRITE(numout,*) ' ht_i_b : ', ht_i_b(ji)364 WRITE(numout,*) ' z_f_surf : ', z_f_surf(ji)365 WRITE(numout,*) ' zdq_i : ', zdq_i(ji)366 WRITE(numout,*) ' ht_i_b : ', ht_i_b(ji)367 WRITE(numout,*) ' fc_bo_i : ', fc_bo_i(ji)368 WRITE(numout,*) ' fbif_1d : ', fbif_1d(ji)369 WRITE(numout,*) ' qlbbq_1d: ', qlbbq_1d(ji)370 WRITE(numout,*) ' s_i_new : ', s_i_new(ji)371 WRITE(numout,*) ' sss_m : ', sss_m(zji,zjj)372 ENDIF373 374 END DO ! ji375 376 IF ( numce_dh .GT. 0 ) meance_dh = meance_dh / numce_dh377 WRITE(numout,*) ' Error report - Category : ', jl378 WRITE(numout,*) ' ~~~~~~~~~~~~ '379 WRITE(numout,*) ' Number of points where there is sur. me. error : ', numce_dh380 WRITE(numout,*) ' Mean basal growth error on error points : ', meance_dh346 numce_dh = 0 347 meance_dh = 0.0 348 DO ji = kideb, kiut 349 350 IF ( ( z_f_surf(ji) + zdq_i(ji) ) .GE. 1.0e-3 ) THEN 351 numce_dh = numce_dh + 1 352 meance_dh = meance_dh + z_f_surf(ji) + zdq_i(ji) 353 ENDIF 354 355 IF ( z_f_surf(ji) + zdq_i(ji) .GE. 1.0e-3 ) THEN! 356 WRITE(numout,*) ' ALERTE heat loss for surface melt ' 357 WRITE(numout,*) ' zji, zjj, jl :', zji, zjj, jl 358 WRITE(numout,*) ' ht_i_b : ', ht_i_b(ji) 359 WRITE(numout,*) ' z_f_surf : ', z_f_surf(ji) 360 WRITE(numout,*) ' zdq_i : ', zdq_i(ji) 361 WRITE(numout,*) ' ht_i_b : ', ht_i_b(ji) 362 WRITE(numout,*) ' fc_bo_i : ', fc_bo_i(ji) 363 WRITE(numout,*) ' fbif_1d : ', fbif_1d(ji) 364 WRITE(numout,*) ' qlbbq_1d: ', qlbbq_1d(ji) 365 WRITE(numout,*) ' s_i_new : ', s_i_new(ji) 366 WRITE(numout,*) ' sss_m : ', sss_m(zji,zjj) 367 ENDIF 368 369 END DO ! ji 370 371 IF ( numce_dh .GT. 0 ) meance_dh = meance_dh / numce_dh 372 WRITE(numout,*) ' Error report - Category : ', jl 373 WRITE(numout,*) ' ~~~~~~~~~~~~ ' 374 WRITE(numout,*) ' Number of points where there is sur. me. error : ', numce_dh 375 WRITE(numout,*) ' Mean basal growth error on error points : ', meance_dh 381 376 382 377 ENDIF ! con_i … … 409 404 DO jk = 1, nlay_s !n 410 405 DO ji = kideb, kiut !n 411 ! In case of disparition of the snow, we have to update the snow412 ! temperatures406 ! In case of disparition of the snow, we have to update the snow 407 ! temperatures 413 408 zhisn = MAX( zzero , SIGN( zone, - ht_s_b(ji) ) ) 414 409 t_s_b(ji,jk) = ( 1.0 - zhisn ) * t_s_b(ji,jk) + zhisn * rtt 415 410 q_s_b(ji,jk) = ( 1.0 - zhisn ) * q_s_b(ji,jk) 416 411 END DO 417 END DO 418 419 !420 !------------------------------------------------------------------------------!421 ! 4) Basal growth / melt !422 !------------------------------------------------------------------------------!423 !412 END DO 413 414 ! 415 !------------------------------------------------------------------------------! 416 ! 4) Basal growth / melt ! 417 !------------------------------------------------------------------------------! 418 ! 424 419 ! Ice basal growth / melt is given by the ratio of heat budget over basal 425 420 ! ice heat content. Basal heat budget is given by the difference between … … 439 434 ! New ice heat content (Bitz and Lipscomb, 1999) 440 435 ztform = t_i_b(ji,nlay_i) ! t_bo_b crashes in the 441 436 ! Baltic 442 437 q_i_b(ji,nlay_i+1) = rhoic * & 443 444 445 446 438 ( cpic * ( ztmelts - ztform ) & 439 + lfus * ( 1.0 - ( ztmelts - rtt ) / & 440 ( ztform - rtt ) ) & 441 - rcp * ( ztmelts-rtt ) ) 447 442 ! Basal growth rate = - F*dt / q 448 443 dh_i_bott(ji) = - rdt_ice*( fc_bo_i(ji) + fbif_1d(ji) + & 449 444 qlbbq_1d(ji) ) / q_i_b(ji,nlay_i+1) 450 445 ENDIF ! heat budget 451 446 END DO ! ji … … 476 471 ! New ice heat content (Bitz and Lipscomb, 1999) 477 472 q_i_b(ji,nlay_i+1) = rhoic * & 478 479 480 481 473 ( cpic * ( ztmelts - t_bo_b(ji) ) & 474 + lfus * ( 1.0 - ( ztmelts - rtt ) / & 475 ( t_bo_b(ji) - rtt ) ) & 476 - rcp * ( ztmelts-rtt ) ) 482 477 ! Bottom growth rate = - F*dt / q 483 478 dh_i_bott(ji) = - rdt_ice * ( fc_bo_i(ji) + fbif_1d(ji) & 484 479 + qlbbq_1d(ji) ) / q_i_b(ji,nlay_i+1) 485 480 ! New ice salinity ( Cox and Weeks, JGR, 1988 ) 486 481 ! zswi2 (1) if dh_i_bott/rdt .GT. 3.6e-7 … … 492 487 zswi1 = 1. - zswi2 * zswi12 493 488 zfracs = zswi1 * 0.12 + & 494 495 496 489 zswi12 * ( 0.8925 + 0.0568 * LOG( 100.0 * zgrr ) ) + & 490 zswi2 * 0.26 / & 491 ( 0.26 + 0.74 * EXP ( - 724300.0 * zgrr ) ) 497 492 zds = zfracs*sss_m(zji,zjj) - s_i_new(ji) 498 493 s_i_new(ji) = zfracs * sss_m(zji,zjj) … … 510 505 ! New ice heat content (Bitz and Lipscomb, 1999) 511 506 q_i_b(ji,nlay_i+1) = rhoic * & 512 513 514 515 507 ( cpic * ( ztmelts - t_bo_b(ji) ) & 508 + lfus * ( 1.0 - ( ztmelts - rtt ) / & 509 ( t_bo_b(ji) - rtt ) ) & 510 - rcp * ( ztmelts-rtt ) ) 516 511 ! Basal growth rate = - F*dt / q 517 512 dh_i_bott(ji) = - rdt_ice*( fc_bo_i(ji) + fbif_1d(ji) + & 518 513 qlbbq_1d(ji) ) / q_i_b(ji,nlay_i+1) 519 514 ! Salinity update 520 515 ! entrapment during bottom growth 521 516 dsm_i_se_1d(ji) = ( s_i_new(ji)*dh_i_bott(ji) + & 522 523 524 517 sm_i_b(ji)*ht_i_b(ji) ) / & 518 MAX( ht_i_b(ji) + dh_i_bott(ji) ,zeps ) & 519 - sm_i_b(ji) 525 520 ENDIF ! heat budget 526 521 END DO ! ji … … 537 532 ! heat convergence at the surface > 0 538 533 IF ( ( fc_bo_i(ji) + fbif_1d(ji) + qlbbq_1d(ji) ) .GE. 0.0 ) THEN 539 534 540 535 s_i_new(ji) = s_i_b(ji,nlay_i) 541 536 zqfont_bo(ji) = rdt_ice * ( fc_bo_i(ji) + fbif_1d(ji) + qlbbq_1d(ji) ) … … 559 554 zdeltah(ji,jk) = - zqfont_bo(ji) / q_i_b(ji,jk) 560 555 zqfont_bo(ji) = MAX( 0.0 , - zh_i(ji) - zdeltah(ji,jk) ) * & 561 556 q_i_b(ji,jk) 562 557 zdeltah(ji,jk) = MAX(zdeltah(ji,jk), - zh_i(ji) ) 563 558 dh_i_bott(ji) = dh_i_bott(ji) + zdeltah(ji,jk) 564 559 zdq_i(ji) = zdq_i(ji) + zdeltah(ji,jk) * & 565 566 ! contribution to salt flux560 q_i_b(ji,jk) / rdt_ice 561 ! contribution to salt flux 567 562 zji = MOD( npb(ji) - 1, jpi ) + 1 568 563 zjj = ( npb(ji) - 1 ) / jpi + 1 569 564 zfsalt_melt(ji) = zfsalt_melt(ji) + & 570 571 572 565 ( sss_m(zji,zjj) - sm_i_b(ji) ) * & 566 a_i_b(ji) * & 567 MIN( zdeltah(ji,jk) , 0.0 ) * rhoic / rdt_ice 573 568 ENDIF 574 569 ENDIF … … 580 575 !------------------- 581 576 IF ( con_i ) THEN 582 DO ji = kideb, kiut583 IF ( ( fc_bo_i(ji) + fbif_1d(ji) + qlbbq_1d(ji) ) .GE. 0.0 ) THEN584 IF ( ( zfbase(ji) + zdq_i(ji) ) .GE. 1.0e-3 ) THEN585 numce_dh = numce_dh + 1586 meance_dh = meance_dh + zfbase(ji) + zdq_i(ji)587 ENDIF588 IF ( zfbase(ji) + zdq_i(ji) .GE. 1.0e-3 ) THEN589 WRITE(numout,*) ' ALERTE heat loss for basal melt '590 WRITE(numout,*) ' zji, zjj, jl :', zji, zjj, jl591 WRITE(numout,*) ' ht_i_b : ', ht_i_b(ji)592 WRITE(numout,*) ' zfbase : ', zfbase(ji)593 WRITE(numout,*) ' zdq_i : ', zdq_i(ji)594 WRITE(numout,*) ' ht_i_b : ', ht_i_b(ji)595 WRITE(numout,*) ' fc_bo_i : ', fc_bo_i(ji)596 WRITE(numout,*) ' fbif_1d : ', fbif_1d(ji)597 WRITE(numout,*) ' qlbbq_1d: ', qlbbq_1d(ji)598 WRITE(numout,*) ' s_i_new : ', s_i_new(ji)599 WRITE(numout,*) ' sss_m : ', sss_m(zji,zjj)600 WRITE(numout,*) ' dh_i_bott : ', dh_i_bott(ji)601 WRITE(numout,*) ' innermelt : ', innermelt(ji)602 ENDIF603 ENDIF ! heat convergence at the surface604 END DO ! ji605 606 IF ( numce_dh .GT. 0 ) meance_dh = meance_dh / numce_dh607 WRITE(numout,*) ' Number of points where there is bas. me. error : ', numce_dh608 WRITE(numout,*) ' Mean basal melt error on error points : ', meance_dh609 WRITE(numout,*) ' Remaining bottom heat : ', zqfont_bo(jiindex_1d)577 DO ji = kideb, kiut 578 IF ( ( fc_bo_i(ji) + fbif_1d(ji) + qlbbq_1d(ji) ) .GE. 0.0 ) THEN 579 IF ( ( zfbase(ji) + zdq_i(ji) ) .GE. 1.0e-3 ) THEN 580 numce_dh = numce_dh + 1 581 meance_dh = meance_dh + zfbase(ji) + zdq_i(ji) 582 ENDIF 583 IF ( zfbase(ji) + zdq_i(ji) .GE. 1.0e-3 ) THEN 584 WRITE(numout,*) ' ALERTE heat loss for basal melt ' 585 WRITE(numout,*) ' zji, zjj, jl :', zji, zjj, jl 586 WRITE(numout,*) ' ht_i_b : ', ht_i_b(ji) 587 WRITE(numout,*) ' zfbase : ', zfbase(ji) 588 WRITE(numout,*) ' zdq_i : ', zdq_i(ji) 589 WRITE(numout,*) ' ht_i_b : ', ht_i_b(ji) 590 WRITE(numout,*) ' fc_bo_i : ', fc_bo_i(ji) 591 WRITE(numout,*) ' fbif_1d : ', fbif_1d(ji) 592 WRITE(numout,*) ' qlbbq_1d: ', qlbbq_1d(ji) 593 WRITE(numout,*) ' s_i_new : ', s_i_new(ji) 594 WRITE(numout,*) ' sss_m : ', sss_m(zji,zjj) 595 WRITE(numout,*) ' dh_i_bott : ', dh_i_bott(ji) 596 WRITE(numout,*) ' innermelt : ', innermelt(ji) 597 ENDIF 598 ENDIF ! heat convergence at the surface 599 END DO ! ji 600 601 IF ( numce_dh .GT. 0 ) meance_dh = meance_dh / numce_dh 602 WRITE(numout,*) ' Number of points where there is bas. me. error : ', numce_dh 603 WRITE(numout,*) ' Mean basal melt error on error points : ', meance_dh 604 WRITE(numout,*) ' Remaining bottom heat : ', zqfont_bo(jiindex_1d) 610 605 611 606 ENDIF ! con_i 612 607 613 !614 !------------------------------------------------------------------------------!615 ! 5) Pathological cases !616 !------------------------------------------------------------------------------!617 !608 ! 609 !------------------------------------------------------------------------------! 610 ! 5) Pathological cases ! 611 !------------------------------------------------------------------------------! 612 ! 618 613 !---------------------------------------------- 619 614 ! 5.1 Excessive ablation in a 1-category model … … 626 621 ! excessive energy is sent to lateral ablation 627 622 fsup(ji) = rhoic*lfus * at_i_b(ji) / MAX( ( 1.0 - at_i_b(ji) ),epsi13) & 628 623 * ( zdhbf - dh_i_bott(ji) ) / rdt_ice 629 624 630 625 dh_i_bott(ji) = zdhbf … … 638 633 zjj = ( npb(ji) - 1 ) / jpi + 1 639 634 diag_bot_gr(zji,zjj) = diag_bot_gr(zji,zjj) + MAX(dh_i_bott(ji),0.0)*a_i_b(ji) & 640 635 / rdt_ice 641 636 diag_sur_me(zji,zjj) = diag_sur_me(zji,zjj) + MIN(dh_i_surf(ji),0.0)*a_i_b(ji) & 642 637 / rdt_ice 643 638 diag_bot_me(zji,zjj) = diag_bot_me(zji,zjj) + MIN(dh_i_bott(ji),0.0)*a_i_b(ji) & 644 639 / rdt_ice 645 640 END DO 646 641 … … 667 662 zqt_s(ji) = ( 1. - zihg) * zqt_s(ji) / MAX( zhni, zeps ) 668 663 zdhnm = - ( 1. - zihg ) * ( 1. - zihgnew ) * ( zfdt_final(ji) / & 669 664 MAX( zqt_s(ji) , zeps ) ) 670 665 zhnfi = zhni + zdhnm 671 666 zfdt_final(ji) = MAX ( zfdt_final(ji) + zqt_s(ji) * zdhnm , 0.0 ) … … 676 671 !--------------------------------- 677 672 rdmicif_1d(ji) = rdmicif_1d(ji) + a_i_b(ji) * & 678 673 (zhgnew(ji)-ht_i_b(ji))*rhoic ! good 679 674 680 675 rdmsnif_1d(ji) = rdmsnif_1d(ji) + a_i_b(ji) * & 681 676 (ht_s_b(ji)-zhni)*rhosn ! good too 682 677 683 678 ! Remaining heat to the ocean … … 700 695 zjj = ( npb(ji) - 1 ) / jpi + 1 701 696 IF ( num_sal .NE. 4 ) & 702 fseqv_1d(ji) = fseqv_1d(ji) + zihgnew * zfsalt_melt(ji) + &703 704 697 fseqv_1d(ji) = fseqv_1d(ji) + zihgnew * zfsalt_melt(ji) + & 698 (1.0 - zihgnew) * rdmicif_1d(ji) * & 699 ( sss_m(zji,zjj) - sm_i_b(ji) ) / rdt_ice 705 700 ! new lines 706 701 IF ( num_sal .EQ. 4 ) & 707 fseqv_1d(ji) = fseqv_1d(ji) + zihgnew * zfsalt_melt(ji) + &708 709 702 fseqv_1d(ji) = fseqv_1d(ji) + zihgnew * zfsalt_melt(ji) + & 703 (1.0 - zihgnew) * rdmicif_1d(ji) * & 704 ( sss_m(zji,zjj) - bulk_sal ) / rdt_ice 710 705 ! Heat flux 711 706 ! excessive bottom ablation energy (fsup) - 0 except if jpl = 1 712 707 ! excessive total ablation energy (focea) sent to the ocean 713 708 qfvbq_1d(ji) = qfvbq_1d(ji) + & 714 715 709 fsup(ji) + ( 1.0 - zihgnew ) * & 710 focea(ji) * a_i_b(ji) * rdt_ice 716 711 717 712 zihic = 1.0 - MAX( zzero , SIGN( zone , -ht_i_b(ji) ) ) … … 719 714 fscbq_1d(ji) = a_i_b(ji) * fstbif_1d(ji) 720 715 qldif_1d(ji) = qldif_1d(ji) & 721 722 723 716 + fsup(ji) + ( 1.0 - zihgnew ) * focea(ji) * a_i_b(ji) & 717 * rdt_ice & 718 + ( 1.0 - zihic ) * fscbq_1d(ji) * rdt_ice 724 719 END DO ! ji 725 720 … … 743 738 ht_i_b(ji) = zhgnew(ji) 744 739 END DO ! ji 745 !746 !------------------------------------------------------------------------------|747 ! 6) Snow-Ice formation |748 !------------------------------------------------------------------------------|749 !740 ! 741 !------------------------------------------------------------------------------| 742 ! 6) Snow-Ice formation | 743 !------------------------------------------------------------------------------| 744 ! 750 745 ! When snow load excesses Archimede's limit, snow-ice interface goes down 751 746 ! under sea-level, flooding of seawater transforms snow into ice … … 754 749 755 750 dh_snowice(ji) = MAX(zzero,(rhosn*ht_s_b(ji)+(rhoic-rau0) & 756 751 * ht_i_b(ji))/(rhosn+rau0-rhoic)) 757 752 zhgnew(ji) = MAX(zhgnew(ji),zhgnew(ji)+dh_snowice(ji)) 758 753 zhnnew = MIN(ht_s_b(ji),ht_s_b(ji)-dh_snowice(ji)) 759 754 760 ! Changes in ice volume and ice mass.755 ! Changes in ice volume and ice mass. 761 756 dvnbq_1d(ji) = a_i_b(ji) * (zhgnew(ji)-ht_i_b(ji)) 762 757 dmgwi_1d(ji) = dmgwi_1d(ji) + a_i_b(ji) & 763 758 *(ht_s_b(ji)-zhnnew)*rhosn 764 759 765 760 rdmicif_1d(ji) = rdmicif_1d(ji) + a_i_b(ji) & 766 761 * ( zhgnew(ji) - ht_i_b(ji) )*rhoic 767 762 rdmsnif_1d(ji) = rdmsnif_1d(ji) + a_i_b(ji) & 768 769 770 ! Equivalent salt flux (1) Snow-ice formation component771 ! -----------------------------------------------------763 * ( zhnnew - ht_s_b(ji) )*rhosn 764 765 ! Equivalent salt flux (1) Snow-ice formation component 766 ! ----------------------------------------------------- 772 767 zji = MOD( npb(ji) - 1, jpi ) + 1 773 768 zjj = ( npb(ji) - 1 ) / jpi + 1 774 769 775 770 zsm_snowice = ( rhoic - rhosn ) / rhoic * & 776 771 sss_m(zji,zjj) 777 772 778 773 IF ( num_sal .NE. 2 ) zsm_snowice = sm_i_b(ji) 779 774 780 775 IF ( num_sal .NE. 4 ) & 781 fseqv_1d(ji) = fseqv_1d(ji) + &782 783 784 776 fseqv_1d(ji) = fseqv_1d(ji) + & 777 ( sss_m(zji,zjj) - zsm_snowice ) * & 778 a_i_b(ji) * & 779 ( zhgnew(ji) - ht_i_b(ji) ) * rhoic / rdt_ice 785 780 ! new lines 786 781 IF ( num_sal .EQ. 4 ) & 787 fseqv_1d(ji) = fseqv_1d(ji) + &788 789 790 782 fseqv_1d(ji) = fseqv_1d(ji) + & 783 ( sss_m(zji,zjj) - bulk_sal ) * & 784 a_i_b(ji) * & 785 ( zhgnew(ji) - ht_i_b(ji) ) * rhoic / rdt_ice 791 786 792 787 ! entrapment during snow ice formation 793 788 i_ice_switch = 1.0 - MAX ( 0.0 , SIGN ( 1.0 , - ht_i_b(ji) + 1.0e-6 ) ) 794 789 isnowic = 1.0 - MAX ( 0.0 , SIGN ( 1.0 , - dh_snowice(ji) ) ) * & 795 790 i_ice_switch 796 791 IF ( ( num_sal .EQ. 2 ) .OR. ( num_sal .EQ. 4 ) ) & 797 798 799 800 801 802 ! Actualize new snow and ice thickness.792 dsm_i_si_1d(ji) = ( zsm_snowice*dh_snowice(ji) & 793 + sm_i_b(ji) * ht_i_b(ji) & 794 / MAX( ht_i_b(ji) + dh_snowice(ji), zeps) & 795 - sm_i_b(ji) ) * isnowic 796 797 ! Actualize new snow and ice thickness. 803 798 ht_s_b(ji) = zhnnew 804 799 ht_i_b(ji) = zhgnew(ji) … … 811 806 zjj = ( npb(ji) - 1 ) / jpi + 1 812 807 diag_sni_gr(zji,zjj) = diag_sni_gr(zji,zjj) + dh_snowice(ji)*a_i_b(ji) / & 813 808 rdt_ice 814 809 815 810 END DO !ji 816 811 817 812 END SUBROUTINE lim_thd_dh 818 813 #else 819 814 !!====================================================================== … … 825 820 END SUBROUTINE lim_thd_dh 826 821 #endif 827 822 END MODULE limthd_dh -
trunk/NEMO/LIM_SRC_3/limthd_dif.F90
r869 r921 22 22 USE par_ice 23 23 USE lib_mpp 24 24 25 25 IMPLICIT NONE 26 26 PRIVATE … … 44 44 45 45 SUBROUTINE lim_thd_dif( kideb , kiut , jl ) 46 !!------------------------------------------------------------------ 47 !! *** ROUTINE lim_thd_dif *** 48 !! ** Purpose : 49 !! This routine determines the time evolution of snow and sea-ice 50 !! temperature profiles. 51 !! ** Method : 52 !! This is done by solving the heat equation diffusion with 53 !! a Neumann boundary condition at the surface and a Dirichlet one 54 !! at the bottom. Solar radiation is partially absorbed into the ice. 55 !! The specific heat and thermal conductivities depend on ice salinity 56 !! and temperature to take into account brine pocket melting. The 57 !! numerical 58 !! scheme is an iterative Crank-Nicolson on a non-uniform multilayer grid 59 !! in the ice and snow system. 60 !! 61 !! The successive steps of this routine are 62 !! 1. Thermal conductivity at the interfaces of the ice layers 63 !! 2. Internal absorbed radiation 64 !! 3. Scale factors due to non-uniform grid 65 !! 4. Kappa factors 66 !! Then iterative procedure begins 67 !! 5. specific heat in the ice 68 !! 6. eta factors 69 !! 7. surface flux computation 70 !! 8. tridiagonal system terms 71 !! 9. solving the tridiagonal system with Gauss elimination 72 !! Iterative procedure ends according to a criterion on evolution 73 !! of temperature 74 !! 75 !! ** Arguments : 76 !! kideb , kiut : Starting and ending points on which the 77 !! the computation is applied 78 !! 79 !! ** Inputs / Ouputs : (global commons) 80 !! surface temperature : t_su_b 81 !! ice/snow temperatures : t_i_b, t_s_b 82 !! ice salinities : s_i_b 83 !! number of layers in the ice/snow: nlay_i, nlay_s 84 !! profile of the ice/snow layers : z_i, z_s 85 !! total ice/snow thickness : ht_i_b, ht_s_b 86 !! 87 !! ** External : 88 !! 89 !! ** References : 90 !! 91 !! ** History : 92 !! (02-2003) Martin Vancoppenolle, Louvain-la-Neuve, Belgium 93 !! (06-2005) Martin Vancoppenolle, 3d version 94 !! (11-2006) Vectorized by Xavier Fettweis (UCL-ASTR) 95 !! (04-2007) Energy conservation tested by M. Vancoppenolle 96 !! 97 !!------------------------------------------------------------------ 98 !! * Arguments 99 100 INTEGER , INTENT (in) :: & 101 kideb , & ! Start point on which the the computation is applied 102 kiut , & ! End point on which the the computation is applied 103 jl ! Category number 104 105 !! * Local variables 106 INTEGER :: ji, & ! spatial loop index 107 zji, zjj, & ! temporary dummy loop index 108 numeq, & ! current reference number of equation 109 layer, & ! vertical dummy loop index 110 nconv, & ! number of iterations in iterative procedure 111 minnumeqmin, & ! 112 maxnumeqmax 113 114 INTEGER , DIMENSION(jpij) :: & 115 numeqmin, & ! reference number of top equation 116 numeqmax, & ! reference number of bottom equation 117 isnow ! switch for presence (1) or absence (0) of snow 118 119 !! * New local variables 120 REAL(wp) , DIMENSION(jpij,0:nlay_i) :: & 121 ztcond_i, & !Ice thermal conductivity 122 zradtr_i, & !Radiation transmitted through the ice 123 zradab_i, & !Radiation absorbed in the ice 124 zkappa_i !Kappa factor in the ice 125 126 REAL(wp) , DIMENSION(jpij,0:nlay_s) :: & 127 zradtr_s, & !Radiation transmited through the snow 128 zradab_s, & !Radiation absorbed in the snow 129 zkappa_s !Kappa factor in the snow 130 131 REAL(wp) , DIMENSION(jpij,0:nlay_i) :: & 132 ztiold, & !Old temperature in the ice 133 zeta_i, & !Eta factor in the ice 134 ztitemp, & !Temporary temperature in the ice to check the convergence 135 zspeche_i, & !Ice specific heat 136 z_i !Vertical cotes of the layers in the ice 137 138 REAL(wp) , DIMENSION(jpij,0:nlay_s) :: & 139 zeta_s, & !Eta factor in the snow 140 ztstemp, & !Temporary temperature in the snow to check the convergence 141 ztsold, & !Temporary temperature in the snow 142 z_s !Vertical cotes of the layers in the snow 143 144 REAL(wp) , DIMENSION(jpij,jkmax+2) :: & 145 zindterm, & ! Independent term 146 zindtbis, & ! temporary independent term 147 zdiagbis 148 149 REAL(wp) , DIMENSION(jpij,jkmax+2,3) :: & 150 ztrid ! tridiagonal system terms 151 152 REAL(wp), DIMENSION(jpij) :: & 153 ztfs , & ! ice melting point 154 ztsuold , & ! old surface temperature (before the iterative 155 ! procedure ) 156 ztsuoldit, & ! surface temperature at previous iteration 157 zh_i , & !ice layer thickness 158 zh_s , & !snow layer thickness 159 zfsw , & !solar radiation absorbed at the surface 160 zf , & ! surface flux function 161 dzf ! derivative of the surface flux function 162 163 REAL(wp) :: & ! constant values 164 zeps = 1.0e-10, & ! 165 zg1s = 2.0, & !: for the tridiagonal system 166 zg1 = 2.0, & 167 zgamma = 18009.0, & !: for specific heat 168 zbeta = 0.117, & !: for thermal conductivity (could be 0.13) 169 zraext_s = 1.0e08, & !: extinction coefficient of radiation in the snow 170 zkimin = 0.10 , & !: minimum ice thermal conductivity 171 zht_smin = 1.0e-4 !: minimum snow depth 172 173 REAL(wp) :: & ! local variables 174 ztmelt_i, & ! ice melting temperature 175 zerritmax ! current maximal error on temperature 176 177 REAL(wp), DIMENSION(jpij) :: & 178 zerrit, & ! current error on temperature 179 zdifcase, & ! case of the equation resolution (1->4) 180 zftrice, & ! solar radiation transmitted through the ice 181 zihic, zhsu 182 183 !!-- End of declarations 184 !!---------------------------------------------------------------------------------------------- 185 186 IF(lwp) WRITE(numout,*)'lim_thd_dif : Heat diffusion in sea ice for cat :', jl 187 188 ! 189 !------------------------------------------------------------------------------! 190 ! 1) Initialization ! 191 !------------------------------------------------------------------------------! 192 ! 193 DO ji = kideb , kiut 194 ! is there snow or not 195 isnow(ji)= INT ( 1.0 - MAX( 0.0 , SIGN (1.0, - ht_s_b(ji) ) ) ) 196 ! surface temperature of fusion 197 ztfs(ji) = isnow(ji) * rtt + (1.0-isnow(ji)) * rtt 198 ! layer thickness 199 zh_i(ji) = ht_i_b(ji) / nlay_i 200 zh_s(ji) = ht_s_b(ji) / nlay_s 201 END DO 202 203 !-------------------- 204 ! Ice / snow layers 205 !-------------------- 206 207 z_s(:,0) = 0.0 ! vert. coord. of the up. lim. of the 1st snow layer 208 z_i(:,0) = 0.0 ! vert. coord. of the up. lim. of the 1st ice layer 209 210 DO layer = 1, nlay_s 211 DO ji = kideb , kiut 212 ! vert. coord of the up. lim. of the layer-th snow layer 213 z_s(ji,layer) = z_s(ji,layer-1) + ht_s_b(ji) / nlay_s 214 END DO 215 END DO 216 217 DO layer = 1, nlay_i 218 DO ji = kideb , kiut 219 ! vert. coord of the up. lim. of the layer-th ice layer 220 z_i(ji,layer) = z_i(ji,layer-1) + ht_i_b(ji) / nlay_i 221 END DO 222 END DO 223 ! 224 !------------------------------------------------------------------------------| 225 ! 2) Radiations | 226 !------------------------------------------------------------------------------| 227 ! 228 !------------------- 229 ! Computation of i0 230 !------------------- 231 ! i0 describes the fraction of solar radiation which does not contribute 232 ! to the surface energy budget but rather penetrates inside the ice. 233 ! We assume that no radiation is transmitted through the snow 234 ! If there is no no snow 235 ! zfsw = (1-i0).qsr_ice is absorbed at the surface 236 ! zftrice = io.qsr_ice is below the surface 237 ! fstbif = io.qsr_ice.exp(-k(h_i)) transmitted below the ice 238 239 DO ji = kideb , kiut 240 ! switches 241 isnow(ji) = INT ( 1.0 - MAX ( 0.0 , SIGN ( 1.0 , - ht_s_b(ji) ) ) ) 242 ! hs > 0, isnow = 1 243 zhsu(ji) = hnzst !threshold for the computation of i0 244 zihic(ji) = MAX( zzero , 1.0 - ( ht_i_b(ji) / zhsu(ji) ) ) 245 246 i0(ji) = ( 1.0 - isnow(ji) ) * & 247 ( fr1_i0_1d(ji) + zihic(ji) * fr2_i0_1d(ji) ) 248 !fr1_i0_1d = i0 for a thin ice surface 249 !fr1_i0_2d = i0 for a thick ice surface 250 ! a function of the cloud cover 251 ! 252 !i0(ji) = (1.0-FLOAT(isnow(ji)))*3.0/(100*ht_s_b(ji)+10.0) 253 !formula used in Cice 254 END DO 255 256 !------------------------------------------------------- 257 ! Solar radiation absorbed / transmitted at the surface 258 ! Derivative of the non solar flux 259 !------------------------------------------------------- 260 DO ji = kideb , kiut 261 262 ! Shortwave radiation absorbed at surface 263 zfsw(ji) = qsr_ice_1d(ji) * ( 1 - i0(ji) ) 264 265 ! Solar radiation transmitted below the surface layer 266 zftrice(ji)= qsr_ice_1d(ji) * i0(ji) 267 268 ! derivative of incoming nonsolar flux 269 dzf(ji) = dqns_ice_1d(ji) 270 271 END DO 272 273 !--------------------------------------------------------- 274 ! Transmission - absorption of solar radiation in the ice 275 !--------------------------------------------------------- 276 277 DO ji = kideb , kiut 278 ! Initialization 279 zradtr_s(ji,0) = zftrice(ji) ! radiation penetrating through snow 280 END DO 281 282 ! Radiation through snow 283 DO layer = 1, nlay_s 284 DO ji = kideb , kiut 285 ! radiation transmitted below the layer-th snow layer 286 zradtr_s(ji,layer) = zradtr_s(ji,0) * EXP ( - zraext_s * ( MAX ( 0.0 , & 287 z_s(ji,layer) ) ) ) 288 ! radiation absorbed by the layer-th snow layer 289 zradab_s(ji,layer) = zradtr_s(ji,layer-1) - zradtr_s(ji,layer) 290 END DO 291 END DO 292 293 ! Radiation through ice 294 DO ji = kideb , kiut 295 zradtr_i(ji,0) = zradtr_s(ji,nlay_s) * isnow(ji) + & 296 zftrice(ji) * ( 1 - isnow(ji) ) 297 END DO 298 299 DO layer = 1, nlay_i 300 DO ji = kideb , kiut 301 ! radiation transmitted below the layer-th ice layer 302 zradtr_i(ji,layer) = zradtr_i(ji,0) * EXP ( - kappa_i * ( MAX ( 0.0 , & 303 z_i(ji,layer) ) ) ) 304 ! radiation absorbed by the layer-th ice layer 305 zradab_i(ji,layer) = zradtr_i(ji,layer-1) - zradtr_i(ji,layer) 306 END DO 307 END DO 308 309 ! Radiation transmitted below the ice 310 DO ji = kideb , kiut 311 fstbif_1d(ji) = fstbif_1d(ji) + & 312 zradtr_i(ji,nlay_i) * a_i_b(ji) / at_i_b(ji) 313 END DO 314 315 ! +++++ 316 ! just to check energy conservation 317 DO ji = kideb , kiut 318 zji = MOD( npb(ji) - 1, jpi ) + 1 319 zjj = ( npb(ji) - 1 ) / jpi + 1 320 fstroc(zji,zjj,jl) = & 321 zradtr_i(ji,nlay_i) 322 END DO 323 ! +++++ 324 325 DO layer = 1, nlay_i 326 DO ji = kideb , kiut 327 radab(ji,layer) = zradab_i(ji,layer) 328 END DO 329 END DO 330 331 332 ! 333 !------------------------------------------------------------------------------| 334 ! 3) Iterative procedure begins | 335 !------------------------------------------------------------------------------| 336 ! 337 ! Old surface temperature 338 DO ji = kideb, kiut 339 ztsuold(ji) = t_su_b(ji) ! temperature at the beg of iter pr. 340 ztsuoldit(ji) = t_su_b(ji) ! temperature at the previous iter 341 t_su_b(ji) = MIN(t_su_b(ji),ztfs(ji)-0.00001) !necessary 342 zerrit(ji) = 1000.0 ! initial value of error 343 END DO 344 !RB Min global ?? 345 346 ! Old snow temperature 347 DO layer = 1, nlay_s 348 DO ji = kideb , kiut 349 ztsold(ji,layer) = t_s_b(ji,layer) 350 END DO 351 END DO 352 353 ! Old ice temperature 354 DO layer = 1, nlay_i 355 DO ji = kideb , kiut 356 ztiold(ji,layer) = t_i_b(ji,layer) 357 END DO 358 END DO 359 360 nconv = 0 ! number of iterations 361 zerritmax = 1000.0 ! maximal value of error on all points 362 363 DO WHILE ((zerritmax > maxer_i_thd).AND.(nconv < nconv_i_thd)) 364 365 nconv = nconv+1 366 367 ! 368 !------------------------------------------------------------------------------| 369 ! 4) Sea ice thermal conductivity | 370 !------------------------------------------------------------------------------| 371 ! 372 IF ( thcon_i_swi .EQ. 0 ) THEN 373 ! Untersteiner (1964) formula 374 DO ji = kideb , kiut 375 ztcond_i(ji,0) = rcdic + zbeta*s_i_b(ji,1) / & 376 MIN(-zeps,t_i_b(ji,1)-rtt) 377 ztcond_i(ji,0) = MAX(ztcond_i(ji,0),zkimin) 378 END DO 379 ENDIF 380 381 IF ( thcon_i_swi .EQ. 1 ) THEN 382 ! Pringle et al formula included, 383 ! 2.11 + 0.09 S/T - 0.011.T 384 DO ji = kideb , kiut 385 ztcond_i(ji,0) = rcdic + 0.09*s_i_b(ji,1) / & 386 MIN(-zeps,t_i_b(ji,1)-rtt) - & 387 0.011* ( t_i_b(ji,1) - rtt ) 388 ztcond_i(ji,0) = MAX(ztcond_i(ji,0),zkimin) 389 END DO 390 ENDIF 391 392 IF ( thcon_i_swi .EQ. 0 ) THEN ! Untersteiner 393 DO layer = 1, nlay_i-1 394 DO ji = kideb , kiut 395 ztcond_i(ji,layer) = rcdic + zbeta*( s_i_b(ji,layer) & 396 + s_i_b(ji,layer+1) ) / MIN(-zeps, & 397 t_i_b(ji,layer)+t_i_b(ji,layer+1)-2.0*rtt) 398 ztcond_i(ji,layer) = MAX(ztcond_i(ji,layer),zkimin) 399 END DO 400 END DO 401 ENDIF 402 403 IF ( thcon_i_swi .EQ. 1 ) THEN ! Pringle 404 DO layer = 1, nlay_i-1 405 DO ji = kideb , kiut 406 ztcond_i(ji,layer) = rcdic + 0.09*( s_i_b(ji,layer) & 407 + s_i_b(ji,layer+1) ) / MIN(-zeps, & 408 t_i_b(ji,layer)+t_i_b(ji,layer+1)-2.0*rtt) - & 409 0.011* ( t_i_b(ji,layer) + t_i_b(ji,layer+1) - 2.0*rtt ) 410 ztcond_i(ji,layer) = MAX(ztcond_i(ji,layer),zkimin) 411 END DO 412 END DO 413 ENDIF 414 415 IF ( thcon_i_swi .EQ. 0 ) THEN ! Untersteiner 416 DO ji = kideb , kiut 417 ztcond_i(ji,nlay_i) = rcdic + zbeta*s_i_b(ji,nlay_i) / & 418 MIN(-zeps,t_bo_b(ji)-rtt) 419 ztcond_i(ji,nlay_i) = MAX(ztcond_i(ji,nlay_i),zkimin) 420 END DO 421 ENDIF 422 423 IF ( thcon_i_swi .EQ. 1 ) THEN ! Pringle 424 DO ji = kideb , kiut 425 ztcond_i(ji,nlay_i) = rcdic + 0.09*s_i_b(ji,nlay_i) / & 426 MIN(-zeps,t_bo_b(ji)-rtt) - & 427 0.011* ( t_bo_b(ji) - rtt ) 428 ztcond_i(ji,nlay_i) = MAX(ztcond_i(ji,nlay_i),zkimin) 429 END DO 430 ENDIF 431 ! 432 !------------------------------------------------------------------------------| 433 ! 5) kappa factors | 434 !------------------------------------------------------------------------------| 435 ! 436 DO ji = kideb, kiut 437 438 !-- Snow kappa factors 439 zkappa_s(ji,0) = rcdsn / MAX(zeps,zh_s(ji)) 440 zkappa_s(ji,nlay_s) = rcdsn / MAX(zeps,zh_s(ji)) 441 END DO 442 443 DO layer = 1, nlay_s-1 444 DO ji = kideb , kiut 445 zkappa_s(ji,layer) = 2.0 * rcdsn / & 446 MAX(zeps,2.0*zh_s(ji)) 447 END DO 448 END DO 449 450 DO layer = 1, nlay_i-1 451 DO ji = kideb , kiut 452 !-- Ice kappa factors 453 zkappa_i(ji,layer) = 2.0*ztcond_i(ji,layer)/ & 454 MAX(zeps,2.0*zh_i(ji)) 455 END DO 456 END DO 457 458 DO ji = kideb , kiut 459 zkappa_i(ji,0) = ztcond_i(ji,0)/MAX(zeps,zh_i(ji)) 460 zkappa_i(ji,nlay_i) = ztcond_i(ji,nlay_i) / MAX(zeps,zh_i(ji)) 461 !-- Interface 462 zkappa_s(ji,nlay_s) = 2.0*rcdsn*ztcond_i(ji,0)/MAX(zeps, & 463 (ztcond_i(ji,0)*zh_s(ji) + rcdsn*zh_i(ji))) 464 zkappa_i(ji,0) = zkappa_s(ji,nlay_s)*isnow(ji) & 465 + zkappa_i(ji,0)*(1.0-isnow(ji)) 466 END DO 467 ! 468 !------------------------------------------------------------------------------| 469 ! 6) Sea ice specific heat, eta factors | 470 !------------------------------------------------------------------------------| 471 ! 472 DO layer = 1, nlay_i 473 DO ji = kideb , kiut 474 ztitemp(ji,layer) = t_i_b(ji,layer) 475 zspeche_i(ji,layer) = cpic + zgamma*s_i_b(ji,layer)/ & 476 MAX((t_i_b(ji,layer)-rtt)*(ztiold(ji,layer)-rtt),zeps) 477 zeta_i(ji,layer) = rdt_ice / MAX(rhoic*zspeche_i(ji,layer)*zh_i(ji), & 478 zeps) 479 END DO 480 END DO 481 482 DO layer = 1, nlay_s 483 DO ji = kideb , kiut 484 ztstemp(ji,layer) = t_s_b(ji,layer) 485 zeta_s(ji,layer) = rdt_ice / MAX(rhosn*cpic*zh_s(ji),zeps) 486 END DO 487 END DO 488 ! 489 !------------------------------------------------------------------------------| 490 ! 7) surface flux computation | 491 !------------------------------------------------------------------------------| 492 ! 493 DO ji = kideb , kiut 494 495 ! update of the non solar flux according to the update in T_su 496 qnsr_ice_1d(ji) = qnsr_ice_1d(ji) + dqns_ice_1d(ji) * & 497 ( t_su_b(ji) - ztsuoldit(ji) ) 498 499 ! update incoming flux 500 zf(ji) = zfsw(ji) & ! net absorbed solar radiation 501 + qnsr_ice_1d(ji) ! non solar total flux 502 ! (LWup, LWdw, SH, LH) 503 504 END DO 505 506 ! 507 !------------------------------------------------------------------------------| 508 ! 8) tridiagonal system terms | 509 !------------------------------------------------------------------------------| 510 ! 511 !!layer denotes the number of the layer in the snow or in the ice 512 !!numeq denotes the reference number of the equation in the tridiagonal 513 !!system, terms of tridiagonal system are indexed as following : 514 !!1 is subdiagonal term, 2 is diagonal and 3 is superdiagonal one 515 516 !!ice interior terms (top equation has the same form as the others) 517 518 DO numeq=1,jkmax+2 519 DO ji = kideb , kiut 520 ztrid(ji,numeq,1) = 0. 521 ztrid(ji,numeq,2) = 0. 522 ztrid(ji,numeq,3) = 0. 523 zindterm(ji,numeq)= 0. 524 zindtbis(ji,numeq)= 0. 525 zdiagbis(ji,numeq)= 0. 526 ENDDO 527 ENDDO 528 529 DO numeq = nlay_s + 2, nlay_s + nlay_i 530 DO ji = kideb , kiut 531 layer = numeq - nlay_s - 1 532 ztrid(ji,numeq,1) = - zeta_i(ji,layer)*zkappa_i(ji,layer-1) 533 ztrid(ji,numeq,2) = 1.0 + zeta_i(ji,layer)*(zkappa_i(ji,layer-1) + & 534 zkappa_i(ji,layer)) 535 ztrid(ji,numeq,3) = - zeta_i(ji,layer)*zkappa_i(ji,layer) 536 zindterm(ji,numeq) = ztiold(ji,layer) + zeta_i(ji,layer)* & 537 zradab_i(ji,layer) 538 END DO 539 ENDDO 540 541 numeq = nlay_s + nlay_i + 1 542 DO ji = kideb , kiut 46 !!------------------------------------------------------------------ 47 !! *** ROUTINE lim_thd_dif *** 48 !! ** Purpose : 49 !! This routine determines the time evolution of snow and sea-ice 50 !! temperature profiles. 51 !! ** Method : 52 !! This is done by solving the heat equation diffusion with 53 !! a Neumann boundary condition at the surface and a Dirichlet one 54 !! at the bottom. Solar radiation is partially absorbed into the ice. 55 !! The specific heat and thermal conductivities depend on ice salinity 56 !! and temperature to take into account brine pocket melting. The 57 !! numerical 58 !! scheme is an iterative Crank-Nicolson on a non-uniform multilayer grid 59 !! in the ice and snow system. 60 !! 61 !! The successive steps of this routine are 62 !! 1. Thermal conductivity at the interfaces of the ice layers 63 !! 2. Internal absorbed radiation 64 !! 3. Scale factors due to non-uniform grid 65 !! 4. Kappa factors 66 !! Then iterative procedure begins 67 !! 5. specific heat in the ice 68 !! 6. eta factors 69 !! 7. surface flux computation 70 !! 8. tridiagonal system terms 71 !! 9. solving the tridiagonal system with Gauss elimination 72 !! Iterative procedure ends according to a criterion on evolution 73 !! of temperature 74 !! 75 !! ** Arguments : 76 !! kideb , kiut : Starting and ending points on which the 77 !! the computation is applied 78 !! 79 !! ** Inputs / Ouputs : (global commons) 80 !! surface temperature : t_su_b 81 !! ice/snow temperatures : t_i_b, t_s_b 82 !! ice salinities : s_i_b 83 !! number of layers in the ice/snow: nlay_i, nlay_s 84 !! profile of the ice/snow layers : z_i, z_s 85 !! total ice/snow thickness : ht_i_b, ht_s_b 86 !! 87 !! ** External : 88 !! 89 !! ** References : 90 !! 91 !! ** History : 92 !! (02-2003) Martin Vancoppenolle, Louvain-la-Neuve, Belgium 93 !! (06-2005) Martin Vancoppenolle, 3d version 94 !! (11-2006) Vectorized by Xavier Fettweis (UCL-ASTR) 95 !! (04-2007) Energy conservation tested by M. Vancoppenolle 96 !! 97 !!------------------------------------------------------------------ 98 !! * Arguments 99 100 INTEGER , INTENT (in) :: & 101 kideb , & ! Start point on which the the computation is applied 102 kiut , & ! End point on which the the computation is applied 103 jl ! Category number 104 105 !! * Local variables 106 INTEGER :: ji, & ! spatial loop index 107 zji, zjj, & ! temporary dummy loop index 108 numeq, & ! current reference number of equation 109 layer, & ! vertical dummy loop index 110 nconv, & ! number of iterations in iterative procedure 111 minnumeqmin, & ! 112 maxnumeqmax 113 114 INTEGER , DIMENSION(jpij) :: & 115 numeqmin, & ! reference number of top equation 116 numeqmax, & ! reference number of bottom equation 117 isnow ! switch for presence (1) or absence (0) of snow 118 119 !! * New local variables 120 REAL(wp) , DIMENSION(jpij,0:nlay_i) :: & 121 ztcond_i, & !Ice thermal conductivity 122 zradtr_i, & !Radiation transmitted through the ice 123 zradab_i, & !Radiation absorbed in the ice 124 zkappa_i !Kappa factor in the ice 125 126 REAL(wp) , DIMENSION(jpij,0:nlay_s) :: & 127 zradtr_s, & !Radiation transmited through the snow 128 zradab_s, & !Radiation absorbed in the snow 129 zkappa_s !Kappa factor in the snow 130 131 REAL(wp) , DIMENSION(jpij,0:nlay_i) :: & 132 ztiold, & !Old temperature in the ice 133 zeta_i, & !Eta factor in the ice 134 ztitemp, & !Temporary temperature in the ice to check the convergence 135 zspeche_i, & !Ice specific heat 136 z_i !Vertical cotes of the layers in the ice 137 138 REAL(wp) , DIMENSION(jpij,0:nlay_s) :: & 139 zeta_s, & !Eta factor in the snow 140 ztstemp, & !Temporary temperature in the snow to check the convergence 141 ztsold, & !Temporary temperature in the snow 142 z_s !Vertical cotes of the layers in the snow 143 144 REAL(wp) , DIMENSION(jpij,jkmax+2) :: & 145 zindterm, & ! Independent term 146 zindtbis, & ! temporary independent term 147 zdiagbis 148 149 REAL(wp) , DIMENSION(jpij,jkmax+2,3) :: & 150 ztrid ! tridiagonal system terms 151 152 REAL(wp), DIMENSION(jpij) :: & 153 ztfs , & ! ice melting point 154 ztsuold , & ! old surface temperature (before the iterative 155 ! procedure ) 156 ztsuoldit, & ! surface temperature at previous iteration 157 zh_i , & !ice layer thickness 158 zh_s , & !snow layer thickness 159 zfsw , & !solar radiation absorbed at the surface 160 zf , & ! surface flux function 161 dzf ! derivative of the surface flux function 162 163 REAL(wp) :: & ! constant values 164 zeps = 1.0e-10, & ! 165 zg1s = 2.0, & !: for the tridiagonal system 166 zg1 = 2.0, & 167 zgamma = 18009.0, & !: for specific heat 168 zbeta = 0.117, & !: for thermal conductivity (could be 0.13) 169 zraext_s = 1.0e08, & !: extinction coefficient of radiation in the snow 170 zkimin = 0.10 , & !: minimum ice thermal conductivity 171 zht_smin = 1.0e-4 !: minimum snow depth 172 173 REAL(wp) :: & ! local variables 174 ztmelt_i, & ! ice melting temperature 175 zerritmax ! current maximal error on temperature 176 177 REAL(wp), DIMENSION(jpij) :: & 178 zerrit, & ! current error on temperature 179 zdifcase, & ! case of the equation resolution (1->4) 180 zftrice, & ! solar radiation transmitted through the ice 181 zihic, zhsu 182 183 ! 184 !------------------------------------------------------------------------------! 185 ! 1) Initialization ! 186 !------------------------------------------------------------------------------! 187 ! 188 DO ji = kideb , kiut 189 ! is there snow or not 190 isnow(ji)= INT ( 1.0 - MAX( 0.0 , SIGN (1.0, - ht_s_b(ji) ) ) ) 191 ! surface temperature of fusion 192 ztfs(ji) = isnow(ji) * rtt + (1.0-isnow(ji)) * rtt 193 ! layer thickness 194 zh_i(ji) = ht_i_b(ji) / nlay_i 195 zh_s(ji) = ht_s_b(ji) / nlay_s 196 END DO 197 198 !-------------------- 199 ! Ice / snow layers 200 !-------------------- 201 202 z_s(:,0) = 0.0 ! vert. coord. of the up. lim. of the 1st snow layer 203 z_i(:,0) = 0.0 ! vert. coord. of the up. lim. of the 1st ice layer 204 205 DO layer = 1, nlay_s 206 DO ji = kideb , kiut 207 ! vert. coord of the up. lim. of the layer-th snow layer 208 z_s(ji,layer) = z_s(ji,layer-1) + ht_s_b(ji) / nlay_s 209 END DO 210 END DO 211 212 DO layer = 1, nlay_i 213 DO ji = kideb , kiut 214 ! vert. coord of the up. lim. of the layer-th ice layer 215 z_i(ji,layer) = z_i(ji,layer-1) + ht_i_b(ji) / nlay_i 216 END DO 217 END DO 218 ! 219 !------------------------------------------------------------------------------| 220 ! 2) Radiations | 221 !------------------------------------------------------------------------------| 222 ! 223 !------------------- 224 ! Computation of i0 225 !------------------- 226 ! i0 describes the fraction of solar radiation which does not contribute 227 ! to the surface energy budget but rather penetrates inside the ice. 228 ! We assume that no radiation is transmitted through the snow 229 ! If there is no no snow 230 ! zfsw = (1-i0).qsr_ice is absorbed at the surface 231 ! zftrice = io.qsr_ice is below the surface 232 ! fstbif = io.qsr_ice.exp(-k(h_i)) transmitted below the ice 233 234 DO ji = kideb , kiut 235 ! switches 236 isnow(ji) = INT ( 1.0 - MAX ( 0.0 , SIGN ( 1.0 , - ht_s_b(ji) ) ) ) 237 ! hs > 0, isnow = 1 238 zhsu(ji) = hnzst !threshold for the computation of i0 239 zihic(ji) = MAX( zzero , 1.0 - ( ht_i_b(ji) / zhsu(ji) ) ) 240 241 i0(ji) = ( 1.0 - isnow(ji) ) * & 242 ( fr1_i0_1d(ji) + zihic(ji) * fr2_i0_1d(ji) ) 243 !fr1_i0_1d = i0 for a thin ice surface 244 !fr1_i0_2d = i0 for a thick ice surface 245 ! a function of the cloud cover 246 ! 247 !i0(ji) = (1.0-FLOAT(isnow(ji)))*3.0/(100*ht_s_b(ji)+10.0) 248 !formula used in Cice 249 END DO 250 251 !------------------------------------------------------- 252 ! Solar radiation absorbed / transmitted at the surface 253 ! Derivative of the non solar flux 254 !------------------------------------------------------- 255 DO ji = kideb , kiut 256 257 ! Shortwave radiation absorbed at surface 258 zfsw(ji) = qsr_ice_1d(ji) * ( 1 - i0(ji) ) 259 260 ! Solar radiation transmitted below the surface layer 261 zftrice(ji)= qsr_ice_1d(ji) * i0(ji) 262 263 ! derivative of incoming nonsolar flux 264 dzf(ji) = dqns_ice_1d(ji) 265 266 END DO 267 268 !--------------------------------------------------------- 269 ! Transmission - absorption of solar radiation in the ice 270 !--------------------------------------------------------- 271 272 DO ji = kideb , kiut 273 ! Initialization 274 zradtr_s(ji,0) = zftrice(ji) ! radiation penetrating through snow 275 END DO 276 277 ! Radiation through snow 278 DO layer = 1, nlay_s 279 DO ji = kideb , kiut 280 ! radiation transmitted below the layer-th snow layer 281 zradtr_s(ji,layer) = zradtr_s(ji,0) * EXP ( - zraext_s * ( MAX ( 0.0 , & 282 z_s(ji,layer) ) ) ) 283 ! radiation absorbed by the layer-th snow layer 284 zradab_s(ji,layer) = zradtr_s(ji,layer-1) - zradtr_s(ji,layer) 285 END DO 286 END DO 287 288 ! Radiation through ice 289 DO ji = kideb , kiut 290 zradtr_i(ji,0) = zradtr_s(ji,nlay_s) * isnow(ji) + & 291 zftrice(ji) * ( 1 - isnow(ji) ) 292 END DO 293 294 DO layer = 1, nlay_i 295 DO ji = kideb , kiut 296 ! radiation transmitted below the layer-th ice layer 297 zradtr_i(ji,layer) = zradtr_i(ji,0) * EXP ( - kappa_i * ( MAX ( 0.0 , & 298 z_i(ji,layer) ) ) ) 299 ! radiation absorbed by the layer-th ice layer 300 zradab_i(ji,layer) = zradtr_i(ji,layer-1) - zradtr_i(ji,layer) 301 END DO 302 END DO 303 304 ! Radiation transmitted below the ice 305 DO ji = kideb , kiut 306 fstbif_1d(ji) = fstbif_1d(ji) + & 307 zradtr_i(ji,nlay_i) * a_i_b(ji) / at_i_b(ji) 308 END DO 309 310 ! +++++ 311 ! just to check energy conservation 312 DO ji = kideb , kiut 313 zji = MOD( npb(ji) - 1, jpi ) + 1 314 zjj = ( npb(ji) - 1 ) / jpi + 1 315 fstroc(zji,zjj,jl) = & 316 zradtr_i(ji,nlay_i) 317 END DO 318 ! +++++ 319 320 DO layer = 1, nlay_i 321 DO ji = kideb , kiut 322 radab(ji,layer) = zradab_i(ji,layer) 323 END DO 324 END DO 325 326 327 ! 328 !------------------------------------------------------------------------------| 329 ! 3) Iterative procedure begins | 330 !------------------------------------------------------------------------------| 331 ! 332 ! Old surface temperature 333 DO ji = kideb, kiut 334 ztsuold(ji) = t_su_b(ji) ! temperature at the beg of iter pr. 335 ztsuoldit(ji) = t_su_b(ji) ! temperature at the previous iter 336 t_su_b(ji) = MIN(t_su_b(ji),ztfs(ji)-0.00001) !necessary 337 zerrit(ji) = 1000.0 ! initial value of error 338 END DO 339 !RB Min global ?? 340 341 ! Old snow temperature 342 DO layer = 1, nlay_s 343 DO ji = kideb , kiut 344 ztsold(ji,layer) = t_s_b(ji,layer) 345 END DO 346 END DO 347 348 ! Old ice temperature 349 DO layer = 1, nlay_i 350 DO ji = kideb , kiut 351 ztiold(ji,layer) = t_i_b(ji,layer) 352 END DO 353 END DO 354 355 nconv = 0 ! number of iterations 356 zerritmax = 1000.0 ! maximal value of error on all points 357 358 DO WHILE ((zerritmax > maxer_i_thd).AND.(nconv < nconv_i_thd)) 359 360 nconv = nconv+1 361 362 ! 363 !------------------------------------------------------------------------------| 364 ! 4) Sea ice thermal conductivity | 365 !------------------------------------------------------------------------------| 366 ! 367 IF ( thcon_i_swi .EQ. 0 ) THEN 368 ! Untersteiner (1964) formula 369 DO ji = kideb , kiut 370 ztcond_i(ji,0) = rcdic + zbeta*s_i_b(ji,1) / & 371 MIN(-zeps,t_i_b(ji,1)-rtt) 372 ztcond_i(ji,0) = MAX(ztcond_i(ji,0),zkimin) 373 END DO 374 ENDIF 375 376 IF ( thcon_i_swi .EQ. 1 ) THEN 377 ! Pringle et al formula included, 378 ! 2.11 + 0.09 S/T - 0.011.T 379 DO ji = kideb , kiut 380 ztcond_i(ji,0) = rcdic + 0.09*s_i_b(ji,1) / & 381 MIN(-zeps,t_i_b(ji,1)-rtt) - & 382 0.011* ( t_i_b(ji,1) - rtt ) 383 ztcond_i(ji,0) = MAX(ztcond_i(ji,0),zkimin) 384 END DO 385 ENDIF 386 387 IF ( thcon_i_swi .EQ. 0 ) THEN ! Untersteiner 388 DO layer = 1, nlay_i-1 389 DO ji = kideb , kiut 390 ztcond_i(ji,layer) = rcdic + zbeta*( s_i_b(ji,layer) & 391 + s_i_b(ji,layer+1) ) / MIN(-zeps, & 392 t_i_b(ji,layer)+t_i_b(ji,layer+1)-2.0*rtt) 393 ztcond_i(ji,layer) = MAX(ztcond_i(ji,layer),zkimin) 394 END DO 395 END DO 396 ENDIF 397 398 IF ( thcon_i_swi .EQ. 1 ) THEN ! Pringle 399 DO layer = 1, nlay_i-1 400 DO ji = kideb , kiut 401 ztcond_i(ji,layer) = rcdic + 0.09*( s_i_b(ji,layer) & 402 + s_i_b(ji,layer+1) ) / MIN(-zeps, & 403 t_i_b(ji,layer)+t_i_b(ji,layer+1)-2.0*rtt) - & 404 0.011* ( t_i_b(ji,layer) + t_i_b(ji,layer+1) - 2.0*rtt ) 405 ztcond_i(ji,layer) = MAX(ztcond_i(ji,layer),zkimin) 406 END DO 407 END DO 408 ENDIF 409 410 IF ( thcon_i_swi .EQ. 0 ) THEN ! Untersteiner 411 DO ji = kideb , kiut 412 ztcond_i(ji,nlay_i) = rcdic + zbeta*s_i_b(ji,nlay_i) / & 413 MIN(-zeps,t_bo_b(ji)-rtt) 414 ztcond_i(ji,nlay_i) = MAX(ztcond_i(ji,nlay_i),zkimin) 415 END DO 416 ENDIF 417 418 IF ( thcon_i_swi .EQ. 1 ) THEN ! Pringle 419 DO ji = kideb , kiut 420 ztcond_i(ji,nlay_i) = rcdic + 0.09*s_i_b(ji,nlay_i) / & 421 MIN(-zeps,t_bo_b(ji)-rtt) - & 422 0.011* ( t_bo_b(ji) - rtt ) 423 ztcond_i(ji,nlay_i) = MAX(ztcond_i(ji,nlay_i),zkimin) 424 END DO 425 ENDIF 426 ! 427 !------------------------------------------------------------------------------| 428 ! 5) kappa factors | 429 !------------------------------------------------------------------------------| 430 ! 431 DO ji = kideb, kiut 432 433 !-- Snow kappa factors 434 zkappa_s(ji,0) = rcdsn / MAX(zeps,zh_s(ji)) 435 zkappa_s(ji,nlay_s) = rcdsn / MAX(zeps,zh_s(ji)) 436 END DO 437 438 DO layer = 1, nlay_s-1 439 DO ji = kideb , kiut 440 zkappa_s(ji,layer) = 2.0 * rcdsn / & 441 MAX(zeps,2.0*zh_s(ji)) 442 END DO 443 END DO 444 445 DO layer = 1, nlay_i-1 446 DO ji = kideb , kiut 447 !-- Ice kappa factors 448 zkappa_i(ji,layer) = 2.0*ztcond_i(ji,layer)/ & 449 MAX(zeps,2.0*zh_i(ji)) 450 END DO 451 END DO 452 453 DO ji = kideb , kiut 454 zkappa_i(ji,0) = ztcond_i(ji,0)/MAX(zeps,zh_i(ji)) 455 zkappa_i(ji,nlay_i) = ztcond_i(ji,nlay_i) / MAX(zeps,zh_i(ji)) 456 !-- Interface 457 zkappa_s(ji,nlay_s) = 2.0*rcdsn*ztcond_i(ji,0)/MAX(zeps, & 458 (ztcond_i(ji,0)*zh_s(ji) + rcdsn*zh_i(ji))) 459 zkappa_i(ji,0) = zkappa_s(ji,nlay_s)*isnow(ji) & 460 + zkappa_i(ji,0)*(1.0-isnow(ji)) 461 END DO 462 ! 463 !------------------------------------------------------------------------------| 464 ! 6) Sea ice specific heat, eta factors | 465 !------------------------------------------------------------------------------| 466 ! 467 DO layer = 1, nlay_i 468 DO ji = kideb , kiut 469 ztitemp(ji,layer) = t_i_b(ji,layer) 470 zspeche_i(ji,layer) = cpic + zgamma*s_i_b(ji,layer)/ & 471 MAX((t_i_b(ji,layer)-rtt)*(ztiold(ji,layer)-rtt),zeps) 472 zeta_i(ji,layer) = rdt_ice / MAX(rhoic*zspeche_i(ji,layer)*zh_i(ji), & 473 zeps) 474 END DO 475 END DO 476 477 DO layer = 1, nlay_s 478 DO ji = kideb , kiut 479 ztstemp(ji,layer) = t_s_b(ji,layer) 480 zeta_s(ji,layer) = rdt_ice / MAX(rhosn*cpic*zh_s(ji),zeps) 481 END DO 482 END DO 483 ! 484 !------------------------------------------------------------------------------| 485 ! 7) surface flux computation | 486 !------------------------------------------------------------------------------| 487 ! 488 DO ji = kideb , kiut 489 490 ! update of the non solar flux according to the update in T_su 491 qnsr_ice_1d(ji) = qnsr_ice_1d(ji) + dqns_ice_1d(ji) * & 492 ( t_su_b(ji) - ztsuoldit(ji) ) 493 494 ! update incoming flux 495 zf(ji) = zfsw(ji) & ! net absorbed solar radiation 496 + qnsr_ice_1d(ji) ! non solar total flux 497 ! (LWup, LWdw, SH, LH) 498 499 END DO 500 501 ! 502 !------------------------------------------------------------------------------| 503 ! 8) tridiagonal system terms | 504 !------------------------------------------------------------------------------| 505 ! 506 !!layer denotes the number of the layer in the snow or in the ice 507 !!numeq denotes the reference number of the equation in the tridiagonal 508 !!system, terms of tridiagonal system are indexed as following : 509 !!1 is subdiagonal term, 2 is diagonal and 3 is superdiagonal one 510 511 !!ice interior terms (top equation has the same form as the others) 512 513 DO numeq=1,jkmax+2 514 DO ji = kideb , kiut 515 ztrid(ji,numeq,1) = 0. 516 ztrid(ji,numeq,2) = 0. 517 ztrid(ji,numeq,3) = 0. 518 zindterm(ji,numeq)= 0. 519 zindtbis(ji,numeq)= 0. 520 zdiagbis(ji,numeq)= 0. 521 ENDDO 522 ENDDO 523 524 DO numeq = nlay_s + 2, nlay_s + nlay_i 525 DO ji = kideb , kiut 526 layer = numeq - nlay_s - 1 527 ztrid(ji,numeq,1) = - zeta_i(ji,layer)*zkappa_i(ji,layer-1) 528 ztrid(ji,numeq,2) = 1.0 + zeta_i(ji,layer)*(zkappa_i(ji,layer-1) + & 529 zkappa_i(ji,layer)) 530 ztrid(ji,numeq,3) = - zeta_i(ji,layer)*zkappa_i(ji,layer) 531 zindterm(ji,numeq) = ztiold(ji,layer) + zeta_i(ji,layer)* & 532 zradab_i(ji,layer) 533 END DO 534 ENDDO 535 536 numeq = nlay_s + nlay_i + 1 537 DO ji = kideb , kiut 543 538 !!ice bottom term 544 539 ztrid(ji,numeq,1) = - zeta_i(ji,nlay_i)*zkappa_i(ji,nlay_i-1) 545 540 ztrid(ji,numeq,2) = 1.0 + zeta_i(ji,nlay_i)*( zkappa_i(ji,nlay_i)*zg1 & 546 541 + zkappa_i(ji,nlay_i-1) ) 547 542 ztrid(ji,numeq,3) = 0.0 548 543 zindterm(ji,numeq) = ztiold(ji,nlay_i) + zeta_i(ji,nlay_i)* & 549 550 551 552 553 554 544 ( zradab_i(ji,nlay_i) + zkappa_i(ji,nlay_i)*zg1 & 545 * t_bo_b(ji) ) 546 ENDDO 547 548 549 DO ji = kideb , kiut 555 550 IF ( ht_s_b(ji).gt.0.0 ) THEN 556 !557 !------------------------------------------------------------------------------|558 ! snow-covered cells |559 !------------------------------------------------------------------------------|560 !561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 !------------------------------------------------------------------------------|582 ! case 1 : no surface melting - snow present |583 !------------------------------------------------------------------------------|584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 !602 !------------------------------------------------------------------------------|603 ! case 2 : surface is melting - snow present |604 !------------------------------------------------------------------------------|605 !606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 !621 !------------------------------------------------------------------------------|622 ! cells without snow |623 !------------------------------------------------------------------------------|624 !625 626 !627 !------------------------------------------------------------------------------|628 ! case 3 : no surface melting - no snow |629 !------------------------------------------------------------------------------|630 !631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 ENDIF662 663 664 665 !666 !------------------------------------------------------------------------------|667 ! case 4 : surface is melting - no snow |668 !------------------------------------------------------------------------------|669 !670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 !699 !------------------------------------------------------------------------------|700 ! 9) tridiagonal system solving |701 !------------------------------------------------------------------------------|702 !703 704 ! Solve the tridiagonal system with Gauss elimination method.705 ! Thomas algorithm, from Computational fluid Dynamics, J.D. ANDERSON,706 ! McGraw-Hill 1984.707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 ! ice temperatures730 731 732 733 734 735 736 737 738 739 740 741 551 ! 552 !------------------------------------------------------------------------------| 553 ! snow-covered cells | 554 !------------------------------------------------------------------------------| 555 ! 556 !!snow interior terms (bottom equation has the same form as the others) 557 DO numeq = 3, nlay_s + 1 558 layer = numeq - 1 559 ztrid(ji,numeq,1) = - zeta_s(ji,layer)*zkappa_s(ji,layer-1) 560 ztrid(ji,numeq,2) = 1.0 + zeta_s(ji,layer)*( zkappa_s(ji,layer-1) + & 561 zkappa_s(ji,layer) ) 562 ztrid(ji,numeq,3) = - zeta_s(ji,layer)*zkappa_s(ji,layer) 563 zindterm(ji,numeq) = ztsold(ji,layer) + zeta_s(ji,layer)* & 564 zradab_s(ji,layer) 565 END DO 566 567 !!case of only one layer in the ice (ice equation is altered) 568 IF ( nlay_i.eq.1 ) THEN 569 ztrid(ji,nlay_s+2,3) = 0.0 570 zindterm(ji,nlay_s+2) = zindterm(ji,nlay_s+2) + zkappa_i(ji,1)* & 571 t_bo_b(ji) 572 ENDIF 573 574 IF ( t_su_b(ji) .LT. rtt ) THEN 575 576 !------------------------------------------------------------------------------| 577 ! case 1 : no surface melting - snow present | 578 !------------------------------------------------------------------------------| 579 zdifcase(ji) = 1.0 580 numeqmin(ji) = 1 581 numeqmax(ji) = nlay_i + nlay_s + 1 582 583 !!surface equation 584 ztrid(ji,1,1) = 0.0 585 ztrid(ji,1,2) = dzf(ji) - zg1s*zkappa_s(ji,0) 586 ztrid(ji,1,3) = zg1s*zkappa_s(ji,0) 587 zindterm(ji,1) = dzf(ji)*t_su_b(ji) - zf(ji) 588 589 !!first layer of snow equation 590 ztrid(ji,2,1) = - zkappa_s(ji,0)*zg1s*zeta_s(ji,1) 591 ztrid(ji,2,2) = 1.0 + zeta_s(ji,1)*(zkappa_s(ji,1) + zkappa_s(ji,0)*zg1s) 592 ztrid(ji,2,3) = - zeta_s(ji,1)* zkappa_s(ji,1) 593 zindterm(ji,2) = ztsold(ji,1) + zeta_s(ji,1)*zradab_s(ji,1) 594 595 ELSE 596 ! 597 !------------------------------------------------------------------------------| 598 ! case 2 : surface is melting - snow present | 599 !------------------------------------------------------------------------------| 600 ! 601 zdifcase(ji) = 2.0 602 numeqmin(ji) = 2 603 numeqmax(ji) = nlay_i + nlay_s + 1 604 605 !!first layer of snow equation 606 ztrid(ji,2,1) = 0.0 607 ztrid(ji,2,2) = 1.0 + zeta_s(ji,1) * ( zkappa_s(ji,1) + & 608 zkappa_s(ji,0) * zg1s ) 609 ztrid(ji,2,3) = - zeta_s(ji,1)*zkappa_s(ji,1) 610 zindterm(ji,2) = ztsold(ji,1) + zeta_s(ji,1) * & 611 ( zradab_s(ji,1) + & 612 zkappa_s(ji,0) * zg1s * t_su_b(ji) ) 613 ENDIF 614 ELSE 615 ! 616 !------------------------------------------------------------------------------| 617 ! cells without snow | 618 !------------------------------------------------------------------------------| 619 ! 620 IF (t_su_b(ji) .LT. rtt) THEN 621 ! 622 !------------------------------------------------------------------------------| 623 ! case 3 : no surface melting - no snow | 624 !------------------------------------------------------------------------------| 625 ! 626 zdifcase(ji) = 3.0 627 numeqmin(ji) = nlay_s + 1 628 numeqmax(ji) = nlay_i + nlay_s + 1 629 630 !!surface equation 631 ztrid(ji,numeqmin(ji),1) = 0.0 632 ztrid(ji,numeqmin(ji),2) = dzf(ji) - zkappa_i(ji,0)*zg1 633 ztrid(ji,numeqmin(ji),3) = zkappa_i(ji,0)*zg1 634 zindterm(ji,numeqmin(ji)) = dzf(ji)*t_su_b(ji) - zf(ji) 635 636 !!first layer of ice equation 637 ztrid(ji,numeqmin(ji)+1,1) = - zkappa_i(ji,0) * zg1 * zeta_i(ji,1) 638 ztrid(ji,numeqmin(ji)+1,2) = 1.0 + zeta_i(ji,1) * ( zkappa_i(ji,1) & 639 + zkappa_i(ji,0) * zg1 ) 640 ztrid(ji,numeqmin(ji)+1,3) = - zeta_i(ji,1)*zkappa_i(ji,1) 641 zindterm(ji,numeqmin(ji)+1)= ztiold(ji,1) + zeta_i(ji,1)*zradab_i(ji,1) 642 643 !!case of only one layer in the ice (surface & ice equations are altered) 644 645 IF (nlay_i.eq.1) THEN 646 ztrid(ji,numeqmin(ji),1) = 0.0 647 ztrid(ji,numeqmin(ji),2) = dzf(ji) - zkappa_i(ji,0)*2.0 648 ztrid(ji,numeqmin(ji),3) = zkappa_i(ji,0)*2.0 649 ztrid(ji,numeqmin(ji)+1,1) = -zkappa_i(ji,0)*2.0*zeta_i(ji,1) 650 ztrid(ji,numeqmin(ji)+1,2) = 1.0 + zeta_i(ji,1)*(zkappa_i(ji,0)*2.0 + & 651 zkappa_i(ji,1)) 652 ztrid(ji,numeqmin(ji)+1,3) = 0.0 653 654 zindterm(ji,numeqmin(ji)+1) = ztiold(ji,1) + zeta_i(ji,1)* & 655 ( zradab_i(ji,1) + zkappa_i(ji,1)*t_bo_b(ji) ) 656 ENDIF 657 658 ELSE 659 660 ! 661 !------------------------------------------------------------------------------| 662 ! case 4 : surface is melting - no snow | 663 !------------------------------------------------------------------------------| 664 ! 665 zdifcase(ji) = 4.0 666 numeqmin(ji) = nlay_s + 2 667 numeqmax(ji) = nlay_i + nlay_s + 1 668 669 !!first layer of ice equation 670 ztrid(ji,numeqmin(ji),1) = 0.0 671 ztrid(ji,numeqmin(ji),2) = 1.0 + zeta_i(ji,1)*(zkappa_i(ji,1) + zkappa_i(ji,0)* & 672 zg1) 673 ztrid(ji,numeqmin(ji),3) = - zeta_i(ji,1) * zkappa_i(ji,1) 674 zindterm(ji,numeqmin(ji)) = ztiold(ji,1) + zeta_i(ji,1)*( zradab_i(ji,1) + & 675 zkappa_i(ji,0) * zg1 * t_su_b(ji) ) 676 677 !!case of only one layer in the ice (surface & ice equations are altered) 678 IF (nlay_i.eq.1) THEN 679 ztrid(ji,numeqmin(ji),1) = 0.0 680 ztrid(ji,numeqmin(ji),2) = 1.0 + zeta_i(ji,1)*(zkappa_i(ji,0)*2.0 + & 681 zkappa_i(ji,1)) 682 ztrid(ji,numeqmin(ji),3) = 0.0 683 zindterm(ji,numeqmin(ji)) = ztiold(ji,1) + zeta_i(ji,1)* & 684 (zradab_i(ji,1) + zkappa_i(ji,1)*t_bo_b(ji)) & 685 + t_su_b(ji)*zeta_i(ji,1)*zkappa_i(ji,0)*2.0 686 ENDIF 687 688 ENDIF 689 ENDIF 690 691 END DO 692 693 ! 694 !------------------------------------------------------------------------------| 695 ! 9) tridiagonal system solving | 696 !------------------------------------------------------------------------------| 697 ! 698 699 ! Solve the tridiagonal system with Gauss elimination method. 700 ! Thomas algorithm, from Computational fluid Dynamics, J.D. ANDERSON, 701 ! McGraw-Hill 1984. 702 703 maxnumeqmax = 0 704 minnumeqmin = jkmax+4 705 706 DO ji = kideb , kiut 707 zindtbis(ji,numeqmin(ji)) = zindterm(ji,numeqmin(ji)) 708 zdiagbis(ji,numeqmin(ji)) = ztrid(ji,numeqmin(ji),2) 709 minnumeqmin = MIN(numeqmin(ji),minnumeqmin) 710 maxnumeqmax = MAX(numeqmax(ji),maxnumeqmax) 711 END DO 712 713 DO layer = minnumeqmin+1, maxnumeqmax 714 DO ji = kideb , kiut 715 numeq = min(max(numeqmin(ji)+1,layer),numeqmax(ji)) 716 zdiagbis(ji,numeq) = ztrid(ji,numeq,2) - ztrid(ji,numeq,1)* & 717 ztrid(ji,numeq-1,3)/zdiagbis(ji,numeq-1) 718 zindtbis(ji,numeq) = zindterm(ji,numeq) - ztrid(ji,numeq,1)* & 719 zindtbis(ji,numeq-1)/zdiagbis(ji,numeq-1) 720 END DO 721 END DO 722 723 DO ji = kideb , kiut 724 ! ice temperatures 725 t_i_b(ji,nlay_i) = zindtbis(ji,numeqmax(ji))/zdiagbis(ji,numeqmax(ji)) 726 END DO 727 728 DO numeq = nlay_i + nlay_s + 1, nlay_s + 2, -1 729 DO ji = kideb , kiut 730 layer = numeq - nlay_s - 1 731 t_i_b(ji,layer) = (zindtbis(ji,numeq) - ztrid(ji,numeq,3)* & 732 t_i_b(ji,layer+1))/zdiagbis(ji,numeq) 733 END DO 734 END DO 735 736 DO ji = kideb , kiut 742 737 ! snow temperatures 743 738 IF (ht_s_b(ji).GT.0) & 744 t_s_b(ji,nlay_s) = (zindtbis(ji,nlay_s+1) - ztrid(ji,nlay_s+1,3) &745 746 739 t_s_b(ji,nlay_s) = (zindtbis(ji,nlay_s+1) - ztrid(ji,nlay_s+1,3) & 740 * t_i_b(ji,1))/zdiagbis(ji,nlay_s+1) & 741 * MAX(0.0,SIGN(1.0,ht_s_b(ji)-zeps)) 747 742 748 743 ! surface temperature … … 750 745 ztsuoldit(ji) = t_su_b(ji) 751 746 IF (t_su_b(ji) .LT. ztfs(ji)) & 752 t_su_b(ji) = ( zindtbis(ji,numeqmin(ji)) - ztrid(ji,numeqmin(ji),3)* &753 754 755 756 757 !758 !--------------------------------------------------------------------------759 ! 10) Has the scheme converged ?, end of the iterative procedure |760 !--------------------------------------------------------------------------761 !762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 747 t_su_b(ji) = ( zindtbis(ji,numeqmin(ji)) - ztrid(ji,numeqmin(ji),3)* & 748 ( isnow(ji)*t_s_b(ji,1) + & 749 (1.0-isnow(ji))*t_i_b(ji,1) ) ) / & 750 zdiagbis(ji,numeqmin(ji)) 751 END DO 752 ! 753 !-------------------------------------------------------------------------- 754 ! 10) Has the scheme converged ?, end of the iterative procedure | 755 !-------------------------------------------------------------------------- 756 ! 757 ! check that nowhere it has started to melt 758 ! zerrit(ji) is a measure of error, it has to be under maxer_i_thd 759 DO ji = kideb , kiut 760 t_su_b(ji) = MAX(MIN(t_su_b(ji),ztfs(ji)),190.0) 761 zerrit(ji) = ABS(t_su_b(ji)-ztsuoldit(ji)) 762 END DO 763 764 DO layer = 1, nlay_s 765 DO ji = kideb , kiut 766 zji = MOD( npb(ji) - 1, jpi ) + 1 767 zjj = ( npb(ji) - 1 ) / jpi + 1 768 t_s_b(ji,layer) = MAX(MIN(t_s_b(ji,layer),rtt),190.0) 769 zerrit(ji) = MAX(zerrit(ji),ABS(t_s_b(ji,layer) & 770 - ztstemp(ji,layer))) 771 END DO 772 END DO 773 774 DO layer = 1, nlay_i 775 DO ji = kideb , kiut 776 ztmelt_i = -tmut*s_i_b(ji,layer) +rtt 777 t_i_b(ji,layer) = MAX(MIN(t_i_b(ji,layer),ztmelt_i),190.0) 778 zerrit(ji) = MAX(zerrit(ji),ABS(t_i_b(ji,layer) - ztitemp(ji,layer))) 779 END DO 780 END DO 781 782 ! Compute spatial maximum over all errors 783 ! note that this could be optimized substantially by iterating only 784 ! the non-converging points 785 zerritmax = 0.0 786 DO ji = kideb , kiut 787 zerritmax = MAX(zerritmax,zerrit(ji)) 788 END DO 789 IF( lk_mpp ) CALL mpp_max(zerritmax, kcom=ncomm_ice) 795 790 796 791 END DO ! End of the do while iterative procedure … … 800 795 801 796 802 !803 !--------------------------------------------------------------------------804 ! 11) Fluxes at the interfaces |805 !--------------------------------------------------------------------------806 !807 808 ! update of latent heat fluxes809 810 811 812 ! surface ice conduction flux813 814 815 816 817 818 819 ! bottom ice conduction flux820 821 822 823 824 825 826 827 828 829 830 DO ji = kideb, kiut831 ! Upper snow value832 fc_s(ji,0) = - isnow(ji)* &833 834 835 ! Bott. snow value836 fc_s(ji,1) = - isnow(ji)* &837 838 839 END DO840 841 ! Upper ice layer842 DO ji = kideb, kiut843 fc_i(ji,0) = - isnow(ji) * & ! interface flux if there is snow844 845 846 847 END DO848 849 ! Internal ice layers850 DO layer = 1, nlay_i - 1851 DO ji = kideb, kiut852 fc_i(ji,layer) = - zkappa_i(ji,layer) * ( t_i_b(ji,layer+1) - &853 854 zji = MOD( npb(ji) - 1, jpi ) + 1855 zjj = ( npb(ji) - 1 ) / jpi + 1856 END DO857 END DO858 859 ! Bottom ice layers860 DO ji = kideb, kiut861 fc_i(ji,nlay_i) = - zkappa_i(ji,nlay_i)* &862 863 END DO864 865 866 867 797 ! 798 !-------------------------------------------------------------------------- 799 ! 11) Fluxes at the interfaces | 800 !-------------------------------------------------------------------------- 801 ! 802 DO ji = kideb, kiut 803 ! update of latent heat fluxes 804 qla_ice_1d (ji) = qla_ice_1d (ji) + & 805 dqla_ice_1d(ji) * ( t_su_b(ji) - ztsuold(ji) ) 806 807 ! surface ice conduction flux 808 isnow(ji) = int(1.0-max(0.0,sign(1.0,-ht_s_b(ji)))) 809 fc_su(ji) = - isnow(ji)*zkappa_s(ji,0)*zg1s*(t_s_b(ji,1) - & 810 t_su_b(ji)) & 811 - (1.0-isnow(ji))*zkappa_i(ji,0)*zg1* & 812 (t_i_b(ji,1) - t_su_b(ji)) 813 814 ! bottom ice conduction flux 815 fc_bo_i(ji) = - zkappa_i(ji,nlay_i)* & 816 ( zg1*(t_bo_b(ji) - t_i_b(ji,nlay_i)) ) 817 818 END DO 819 820 !-------------------------! 821 ! Heat conservation ! 822 !-------------------------! 823 IF ( con_i ) THEN 824 825 DO ji = kideb, kiut 826 ! Upper snow value 827 fc_s(ji,0) = - isnow(ji)* & 828 zkappa_s(ji,0) * zg1s * ( t_s_b(ji,1) - & 829 t_su_b(ji) ) 830 ! Bott. snow value 831 fc_s(ji,1) = - isnow(ji)* & 832 zkappa_s(ji,1) * ( t_i_b(ji,1) - & 833 t_s_b(ji,1) ) 834 END DO 835 836 ! Upper ice layer 837 DO ji = kideb, kiut 838 fc_i(ji,0) = - isnow(ji) * & ! interface flux if there is snow 839 ( zkappa_i(ji,0) * ( t_i_b(ji,1) - t_s_b(ji,nlay_s ) ) ) & 840 - ( 1.0 - isnow(ji) ) * ( zkappa_i(ji,0) * & 841 zg1 * ( t_i_b(ji,1) - t_su_b(ji) ) ) ! upper flux if not 842 END DO 843 844 ! Internal ice layers 845 DO layer = 1, nlay_i - 1 846 DO ji = kideb, kiut 847 fc_i(ji,layer) = - zkappa_i(ji,layer) * ( t_i_b(ji,layer+1) - & 848 t_i_b(ji,layer) ) 849 zji = MOD( npb(ji) - 1, jpi ) + 1 850 zjj = ( npb(ji) - 1 ) / jpi + 1 851 END DO 852 END DO 853 854 ! Bottom ice layers 855 DO ji = kideb, kiut 856 fc_i(ji,nlay_i) = - zkappa_i(ji,nlay_i)* & 857 ( zg1*(t_bo_b(ji) - t_i_b(ji,nlay_i)) ) 858 END DO 859 860 ENDIF 861 862 END SUBROUTINE lim_thd_dif 868 863 869 864 #else … … 876 871 END SUBROUTINE lim_thd_dif 877 872 #endif 878 873 END MODULE limthd_dif -
trunk/NEMO/LIM_SRC_3/limthd_ent.F90
r869 r921 46 46 CONTAINS 47 47 48 48 SUBROUTINE lim_thd_ent(kideb,kiut,jl) 49 49 !!------------------------------------------------------------------- 50 50 !! *** ROUTINE lim_thd_ent *** … … 135 135 REAL(wp), DIMENSION(jpij,0:jkmax+3) :: & 136 136 zhl0 ! old and new layer thicknesses 137 137 138 138 REAL(wp), DIMENSION(0:jkmax+3,0:jkmax+3) :: & 139 139 zrl01 … … 144 144 zqti_fin, zqts_fin 145 145 146 !------------------------------------------------------------------------------|146 !------------------------------------------------------------------------------| 147 147 148 148 zeps = 1.0d-20 … … 156 156 z_s(:,:) = 0.0 157 157 158 !159 !------------------------------------------------------------------------------|160 ! 1) Grid |161 !------------------------------------------------------------------------------|162 !158 ! 159 !------------------------------------------------------------------------------| 160 ! 1) Grid | 161 !------------------------------------------------------------------------------| 162 ! 163 163 nlays0 = nlay_s 164 164 nlayi0 = nlay_i … … 169 169 ENDDO 170 170 171 !172 !------------------------------------------------------------------------------|173 ! 2) Switches |174 !------------------------------------------------------------------------------|175 !171 ! 172 !------------------------------------------------------------------------------| 173 ! 2) Switches | 174 !------------------------------------------------------------------------------| 175 ! 176 176 ! 2.1 snind(ji), snswi(ji) 177 177 ! snow surface behaviour : computation of snind(ji)-snswi(ji) … … 181 181 ! 2 if 2nd layer is melting ... 182 182 DO ji = kideb, kiut 183 snind(ji) = 0184 zdeltah(ji) = 0.0183 snind(ji) = 0 184 zdeltah(ji) = 0.0 185 185 ENDDO !ji 186 186 187 187 DO jk = 1, nlays0 188 DO ji = kideb, kiut189 snind(ji) = jk * INT(MAX(0.0,SIGN(1.0,-dh_s_tot(ji)-zdeltah(ji)-zeps))) &190 191 zdeltah(ji)= zdeltah(ji) + zh_s(ji)192 END DO ! ji188 DO ji = kideb, kiut 189 snind(ji) = jk * INT(MAX(0.0,SIGN(1.0,-dh_s_tot(ji)-zdeltah(ji)-zeps))) & 190 + snind(ji) * (1 - INT(MAX(0.0,SIGN(1.0,-dh_s_tot(ji)-zdeltah(ji)-zeps)))) 191 zdeltah(ji)= zdeltah(ji) + zh_s(ji) 192 END DO ! ji 193 193 ENDDO ! jk 194 194 … … 198 198 snswi(ji) = MAX(0,INT(-dh_s_tot(ji)/MAX(zeps,ABS(dh_s_tot(ji))))) 199 199 ENDDO ! ji 200 200 201 201 ! 2.2 icsuind(ji), icsuswi(ji) 202 202 ! ice surface behaviour : computation of icsuind(ji)-icsuswi(ji) … … 206 206 ! 2 if 2nd layer is reached by melt ... 207 207 DO ji = kideb, kiut 208 icsuind(ji) = 0209 zdeltah(ji) = 0.0208 icsuind(ji) = 0 209 zdeltah(ji) = 0.0 210 210 ENDDO !ji 211 211 DO jk = 1, nlayi0 212 DO ji = kideb, kiut213 icsuind(ji) = jk * INT(MAX(0.0,SIGN(1.0,-dh_i_surf(ji)-zdeltah(ji)-zeps))) &214 215 zdeltah(ji) = zdeltah(ji) + zh_i(ji)216 END DO ! ji212 DO ji = kideb, kiut 213 icsuind(ji) = jk * INT(MAX(0.0,SIGN(1.0,-dh_i_surf(ji)-zdeltah(ji)-zeps))) & 214 + icsuind(ji) * (1 - INT(MAX(0.0,SIGN(1.0,-dh_i_surf(ji)-zdeltah(ji)-zeps)))) 215 zdeltah(ji) = zdeltah(ji) + zh_i(ji) 216 END DO ! ji 217 217 ENDDO !jk 218 218 … … 232 232 ! N+1 if all layers melt and that snow transforms into ice 233 233 DO ji = kideb, kiut 234 icboind(ji) = 0235 zdeltah(ji) = 0.0234 icboind(ji) = 0 235 zdeltah(ji) = 0.0 236 236 ENDDO 237 237 DO jk = nlayi0, 1, -1 238 DO ji = kideb, kiut239 icboind(ji) = (nlayi0+1-jk) &240 241 242 243 zdeltah(ji) = zdeltah(ji) + zh_i(ji)244 END DO238 DO ji = kideb, kiut 239 icboind(ji) = (nlayi0+1-jk) & 240 * INT(MAX(0.0,SIGN(1.0,-dh_i_bott(ji)-zdeltah(ji)-zeps))) & 241 + icboind(ji) & 242 * (1 - INT(MAX(0.0,SIGN(1.0,-dh_i_bott(ji)-zdeltah(ji)-zeps)))) 243 zdeltah(ji) = zdeltah(ji) + zh_i(ji) 244 END DO 245 245 ENDDO 246 246 … … 248 248 ! case of total ablation with remaining snow 249 249 IF ( ( ht_i_b(ji) .GT. zeps ) .AND. & 250 250 ( ht_i_b(ji) - dh_snowice(ji) .LT. zeps ) ) icboind(ji) = nlay_i + 1 251 251 END DO 252 252 … … 265 265 ! 2 if penultiem layer ... 266 266 DO ji = kideb, kiut 267 snicind(ji) = 0268 zdeltah(ji) = 0.0267 snicind(ji) = 0 268 zdeltah(ji) = 0.0 269 269 ENDDO 270 270 DO jk = nlays0, 1, -1 271 DO ji = kideb, kiut272 snicind(ji) = (nlays0+1-jk) &273 274 275 276 zdeltah(ji) = zdeltah(ji) + zh_s(ji)277 END DO271 DO ji = kideb, kiut 272 snicind(ji) = (nlays0+1-jk) & 273 * INT(MAX(0.0,SIGN(1.0,dh_snowice(ji)-zdeltah(ji)-zeps))) & 274 + snicind(ji) & 275 * (1 - INT(MAX(0.0,SIGN(1.0,dh_snowice(ji)-zdeltah(ji)-zeps)))) 276 zdeltah(ji) = zdeltah(ji) + zh_s(ji) 277 END DO 278 278 ENDDO 279 279 … … 282 282 ! 0 if not 283 283 DO ji = kideb, kiut 284 snicswi(ji) = MAX(0,INT(dh_snowice(ji)/MAX(zeps,ABS(dh_snowice(ji)))))285 ENDDO 286 287 !288 !------------------------------------------------------------------------------|289 ! 3) Snow redistribution |290 !------------------------------------------------------------------------------|291 !284 snicswi(ji) = MAX(0,INT(dh_snowice(ji)/MAX(zeps,ABS(dh_snowice(ji))))) 285 ENDDO 286 287 ! 288 !------------------------------------------------------------------------------| 289 ! 3) Snow redistribution | 290 !------------------------------------------------------------------------------| 291 ! 292 292 !------------- 293 293 ! Old profile … … 303 303 304 304 DO ji = kideb, kiut 305 nbot0(ji) = nlays0 + 1 - snind(ji) + ( 1. - snicind(ji) ) * &306 307 ! cotes of the top of the layers308 zm0(ji,0) = 0.0309 maxnbot0 = MAX ( maxnbot0 , nbot0(ji) )310 ENDDO 305 nbot0(ji) = nlays0 + 1 - snind(ji) + ( 1. - snicind(ji) ) * & 306 snicswi(ji) 307 ! cotes of the top of the layers 308 zm0(ji,0) = 0.0 309 maxnbot0 = MAX ( maxnbot0 , nbot0(ji) ) 310 ENDDO 311 311 IF( lk_mpp ) CALL mpp_max( maxnbot0, kcom=ncomm_ice ) 312 312 313 313 DO jk = 1, maxnbot0 314 DO ji = kideb, kiut315 !change316 limsum = ( 1 - snswi(ji) ) * ( jk - 1 ) + &317 318 limsum = MIN( limsum , nlay_s )319 zm0(ji,jk) = dh_s_tot(ji) + zh_s(ji) * limsum320 END DO314 DO ji = kideb, kiut 315 !change 316 limsum = ( 1 - snswi(ji) ) * ( jk - 1 ) + & 317 snswi(ji) * ( jk + snind(ji) - 1 ) 318 limsum = MIN( limsum , nlay_s ) 319 zm0(ji,jk) = dh_s_tot(ji) + zh_s(ji) * limsum 320 END DO 321 321 ENDDO 322 322 323 323 DO ji = kideb, kiut 324 324 zm0(ji,nbot0(ji)) = dh_s_tot(ji) - snicswi(ji) * dh_snowice(ji) + & 325 325 zh_s(ji) * nlays0 326 326 zm0(ji,1) = dh_s_tot(ji) * (1 -snswi(ji) ) + & 327 327 snswi(ji) * zm0(ji,1) 328 328 ENDDO 329 329 330 330 DO jk = ntop0, maxnbot0 331 DO ji = kideb, kiut332 ! layer thickness333 zthick0(ji,jk) = zm0(ji,jk) - zm0(ji,jk-1)334 END DO331 DO ji = kideb, kiut 332 ! layer thickness 333 zthick0(ji,jk) = zm0(ji,jk) - zm0(ji,jk-1) 334 END DO 335 335 ENDDO 336 336 337 337 zqts_in(:) = 0.0 338 339 DO ji = kideb, kiut 340 ! layer heat content341 qm0(ji,1) = rhosn * ( cpic * ( rtt - ( 1. - snswi(ji) ) * ( tatm_ice_1d(ji) ) &342 343 344 zqts_in(ji) = zqts_in(ji) + qm0(ji,1)338 339 DO ji = kideb, kiut 340 ! layer heat content 341 qm0(ji,1) = rhosn * ( cpic * ( rtt - ( 1. - snswi(ji) ) * ( tatm_ice_1d(ji) ) & 342 - snswi(ji) * t_s_b(ji,1) ) & 343 + lfus ) * zthick0(ji,1) 344 zqts_in(ji) = zqts_in(ji) + qm0(ji,1) 345 345 ENDDO 346 346 347 347 DO jk = 2, maxnbot0 348 DO ji = kideb, kiut349 limsum = ( 1 - snswi(ji) ) * ( jk - 1 ) + &350 351 limsum = MIN( limsum , nlay_s )352 qm0(ji,jk) = rhosn * ( cpic * ( rtt - t_s_b(ji,limsum) ) + lfus ) &353 354 zswitch = 1.0 - MAX (0.0, SIGN ( 1.0, zeps - ht_s_b(ji) ) )355 zqts_in(ji) = zqts_in(ji) + ( 1. - snswi(ji) ) * qm0(ji,jk) * zswitch356 END DO ! jk348 DO ji = kideb, kiut 349 limsum = ( 1 - snswi(ji) ) * ( jk - 1 ) + & 350 snswi(ji) * ( jk + snind(ji) - 1 ) 351 limsum = MIN( limsum , nlay_s ) 352 qm0(ji,jk) = rhosn * ( cpic * ( rtt - t_s_b(ji,limsum) ) + lfus ) & 353 * zthick0(ji,jk) 354 zswitch = 1.0 - MAX (0.0, SIGN ( 1.0, zeps - ht_s_b(ji) ) ) 355 zqts_in(ji) = zqts_in(ji) + ( 1. - snswi(ji) ) * qm0(ji,jk) * zswitch 356 END DO ! jk 357 357 ENDDO ! ji 358 358 … … 362 362 ! zqsnow, enthalpy of the flooded snow 363 363 DO ji = kideb, kiut 364 zqsnow(ji) = rhosn*lfus365 zdeltah(ji) = 0.0364 zqsnow(ji) = rhosn*lfus 365 zdeltah(ji) = 0.0 366 366 ENDDO 367 367 368 368 DO jk = nlays0, 1, -1 369 DO ji = kideb, kiut370 zhsnow = MAX(0.0,dh_snowice(ji)-zdeltah(ji))371 zqsnow(ji) = zqsnow(ji) + &372 373 zdeltah(ji) = zdeltah(ji) + zh_s(ji)374 END DO369 DO ji = kideb, kiut 370 zhsnow = MAX(0.0,dh_snowice(ji)-zdeltah(ji)) 371 zqsnow(ji) = zqsnow(ji) + & 372 rhosn*cpic*(rtt-t_s_b(ji,jk)) 373 zdeltah(ji) = zdeltah(ji) + zh_s(ji) 374 END DO 375 375 ENDDO 376 376 … … 398 398 399 399 DO jk = 1, nlay_s 400 DO ji = kideb, kiut401 z_s(ji,jk) = zh_s(ji) * jk402 END DO400 DO ji = kideb, kiut 401 z_s(ji,jk) = zh_s(ji) * jk 402 END DO 403 403 ENDDO 404 404 … … 407 407 !----------------- 408 408 DO layer0 = ntop0, maxnbot0 409 DO ji = kideb, kiut410 zhl0(ji,layer0) = zm0(ji,layer0) - zm0(ji,layer0-1)411 END DO409 DO ji = kideb, kiut 410 zhl0(ji,layer0) = zm0(ji,layer0) - zm0(ji,layer0-1) 411 END DO 412 412 ENDDO 413 413 414 414 DO layer1 = ntop1, nbot1 415 DO ji = kideb, kiut416 q_s_b(ji,layer1)= 0.0417 END DO415 DO ji = kideb, kiut 416 q_s_b(ji,layer1)= 0.0 417 END DO 418 418 ENDDO 419 419 … … 422 422 !---------------- 423 423 DO layer0 = ntop0, maxnbot0 424 DO layer1 = ntop1, nbot1425 DO ji = kideb, kiut426 zrl01(layer1,layer0) = MAX(0.0,( MIN(zm0(ji,layer0),z_s(ji,layer1)) &427 - MAX(zm0(ji,layer0-1), z_s(ji,layer1-1)))/MAX(zhl0(ji,layer0),epsi10))428 q_s_b(ji,layer1) = q_s_b(ji,layer1) + zrl01(layer1,layer0)*qm0(ji,layer0) &429 430 END DO431 END DO424 DO layer1 = ntop1, nbot1 425 DO ji = kideb, kiut 426 zrl01(layer1,layer0) = MAX(0.0,( MIN(zm0(ji,layer0),z_s(ji,layer1)) & 427 - MAX(zm0(ji,layer0-1), z_s(ji,layer1-1)))/MAX(zhl0(ji,layer0),epsi10)) 428 q_s_b(ji,layer1) = q_s_b(ji,layer1) + zrl01(layer1,layer0)*qm0(ji,layer0) & 429 * MAX(0.0,SIGN(1.0,nbot0(ji)-layer0+zeps)) 430 END DO 431 END DO 432 432 ENDDO 433 433 … … 441 441 442 442 IF ( con_i ) THEN 443 DO ji = kideb, kiut444 IF ( ABS ( zqts_in(ji) - zqts_fin(ji) ) / rdt_ice .GT. 1.0e-6 ) THEN445 zji = MOD( npb(ji) - 1, jpi ) + 1446 zjj = ( npb(ji) - 1 ) / jpi + 1447 WRITE(numout,*) ' violation of heat conservation : ', &448 449 WRITE(numout,*) ' ji, jj : ', zji, zjj450 WRITE(numout,*) ' ht_s_b : ', ht_s_b(ji)451 WRITE(numout,*) ' zqts_in : ', zqts_in(ji) / rdt_ice452 WRITE(numout,*) ' zqts_fin : ', zqts_fin(ji) / rdt_ice453 WRITE(numout,*) ' dh_snowice : ', dh_snowice(ji)454 WRITE(numout,*) ' dh_s_tot : ', dh_s_tot(ji)455 WRITE(numout,*) ' snswi : ', snswi(ji)456 ENDIF457 END DO443 DO ji = kideb, kiut 444 IF ( ABS ( zqts_in(ji) - zqts_fin(ji) ) / rdt_ice .GT. 1.0e-6 ) THEN 445 zji = MOD( npb(ji) - 1, jpi ) + 1 446 zjj = ( npb(ji) - 1 ) / jpi + 1 447 WRITE(numout,*) ' violation of heat conservation : ', & 448 ABS ( zqts_in(ji) - zqts_fin(ji) ) / rdt_ice 449 WRITE(numout,*) ' ji, jj : ', zji, zjj 450 WRITE(numout,*) ' ht_s_b : ', ht_s_b(ji) 451 WRITE(numout,*) ' zqts_in : ', zqts_in(ji) / rdt_ice 452 WRITE(numout,*) ' zqts_fin : ', zqts_fin(ji) / rdt_ice 453 WRITE(numout,*) ' dh_snowice : ', dh_snowice(ji) 454 WRITE(numout,*) ' dh_s_tot : ', dh_s_tot(ji) 455 WRITE(numout,*) ' snswi : ', snswi(ji) 456 ENDIF 457 END DO 458 458 ENDIF 459 459 … … 473 473 zfac2 = lfus / cpic 474 474 DO jk = 1, nlay_s 475 DO ji = kideb, kiut476 zswitch = MAX ( 0.0 , SIGN ( 1.0, zeps - ht_s_b(ji) ) )477 t_s_b(ji,jk) = rtt &478 479 480 END DO481 ENDDO 482 !483 !------------------------------------------------------------------------------|484 ! 4) Ice redistribution |485 !------------------------------------------------------------------------------|486 !475 DO ji = kideb, kiut 476 zswitch = MAX ( 0.0 , SIGN ( 1.0, zeps - ht_s_b(ji) ) ) 477 t_s_b(ji,jk) = rtt & 478 + ( 1.0 - zswitch ) * & 479 ( - zfac1 * q_s_b(ji,jk) + zfac2 ) 480 END DO 481 ENDDO 482 ! 483 !------------------------------------------------------------------------------| 484 ! 4) Ice redistribution | 485 !------------------------------------------------------------------------------| 486 ! 487 487 !------------- 488 488 ! OLD PROFILE … … 496 496 497 497 DO ji = kideb, kiut 498 ! reference number of the bottommost layer498 ! reference number of the bottommost layer 499 499 nbot0(ji) = MAX( 1 , MIN( nlayi0 + ( 1 - icboind(ji) ) + & 500 501 500 ( 1 - icsuind(ji) ) * icsuswi(ji) + snicswi(ji) , & 501 nlay_i + 2 ) ) 502 502 ! maximum reference number of the bottommost layer over all domain 503 503 maxnbot0 = MAX( maxnbot0 , nbot0(ji) ) … … 508 508 !------------------------- 509 509 zm0(:,0) = 0.0 510 510 511 511 DO jk = 1, maxnbot0 512 512 DO ji = kideb, kiut … … 515 515 ! limsum is the real ice layer number corresponding to present jk 516 516 limsum = ( (icsuswi(ji)*(icsuind(ji)+jk-1) + & 517 517 (1-icsuswi(ji))*jk))*(1-snicswi(ji)) + (jk-1)*snicswi(ji) 518 518 zm0(ji,jk)= icsuswi(ji)*dh_i_surf(ji) + snicswi(ji)*dh_snowice(ji) & 519 519 + limsum * zh_i(ji) 520 520 END DO 521 521 ENDDO … … 523 523 DO ji = kideb, kiut 524 524 zm0(ji,nbot0(ji)) = icsuswi(ji)*dh_i_surf(ji) + snicswi(ji)*dh_snowice(ji) + dh_i_bott(ji) & 525 525 + zh_i(ji) * nlayi0 526 526 zm0(ji,1) = snicswi(ji)*dh_snowice(ji) + (1-snicswi(ji))*zm0(ji,1) 527 527 ENDDO … … 531 531 !----------------------------- 532 532 DO jk = ntop0, maxnbot0 533 DO ji = kideb, kiut534 zthick0(ji,jk) = zm0(ji,jk) - zm0(ji,jk-1)535 END DO533 DO ji = kideb, kiut 534 zthick0(ji,jk) = zm0(ji,jk) - zm0(ji,jk-1) 535 END DO 536 536 ENDDO 537 537 … … 545 545 DO ji = kideb, kiut 546 546 limsum = MAX(1,MIN(snicswi(ji)*(jk-1) + icsuswi(ji)*(jk-1+icsuind(ji)) + & 547 547 (1-icsuswi(ji))*(1-snicswi(ji))*jk,nlay_i)) 548 548 ztmelts = -tmut * s_i_b(ji,limsum) + rtt 549 549 qm0(ji,jk) = rhoic * ( cpic * (ztmelts-t_i_b(ji,limsum)) + lfus * ( 1.0-(ztmelts-rtt)/ & 550 551 550 MIN((t_i_b(ji,limsum)-rtt),-zeps) ) - rcp*(ztmelts-rtt) ) & 551 * zthick0(ji,jk) 552 552 END DO 553 553 ENDDO … … 557 557 !---------------------------- 558 558 DO ji = kideb, kiut 559 ztmelts = ( 1.0 - icboswi(ji) ) * (-tmut * s_i_b(ji,nlayi0)) & ! case of melting ice560 561 562 563 ! bottom formation temperature564 ztform = t_i_b(ji,nlay_i)565 IF ( ( num_sal .EQ. 2 ) .OR. ( num_sal .EQ. 4 ) ) ztform = t_bo_b(ji)566 qm0(ji,nbot0(ji)) = ( 1.0 - icboswi(ji) )*qm0(ji,nbot0(ji)) & ! case of melting ice567 568 569 570 571 572 559 ztmelts = ( 1.0 - icboswi(ji) ) * (-tmut * s_i_b(ji,nlayi0)) & ! case of melting ice 560 + icboswi(ji) * (-tmut * s_i_new(ji)) & ! case of forming ice 561 + rtt ! this temperature is in Celsius 562 563 ! bottom formation temperature 564 ztform = t_i_b(ji,nlay_i) 565 IF ( ( num_sal .EQ. 2 ) .OR. ( num_sal .EQ. 4 ) ) ztform = t_bo_b(ji) 566 qm0(ji,nbot0(ji)) = ( 1.0 - icboswi(ji) )*qm0(ji,nbot0(ji)) & ! case of melting ice 567 + icboswi(ji) * & ! case of forming ice 568 rhoic*( cpic*(ztmelts-ztform) & 569 + lfus *( 1.0-(ztmelts-rtt)/ & 570 MIN ( (ztform-rtt) , - epsi10 ) ) & 571 - rcp*(ztmelts-rtt) ) & 572 *zthick0(ji,nbot0(ji)) 573 573 ENDDO 574 574 … … 579 579 ! energy of the flooding seawater 580 580 zqsnic = rau0 * rcp * ( rtt - t_bo_b(ji) ) * dh_snowice(ji) * & 581 581 (rhoic - rhosn) / rhoic * snicswi(ji) ! generally positive 582 582 ! Heat conservation diagnostic 583 583 qt_i_in(ji,jl) = qt_i_in(ji,jl) + zqsnic … … 593 593 594 594 DO jk = ntop0, maxnbot0 595 DO ji = kideb, kiut596 ! Heat conservation597 zqti_in(ji) = zqti_in(ji) + qm0(ji,jk) &598 599 600 END DO595 DO ji = kideb, kiut 596 ! Heat conservation 597 zqti_in(ji) = zqti_in(ji) + qm0(ji,jk) & 598 * MAX( 0.0 , SIGN(1.0,ht_i_b(ji)-zeps6+zeps) ) & 599 * MAX( 0.0 , SIGN( 1. , nbot0(ji) - jk + zeps ) ) 600 END DO 601 601 ENDDO 602 602 … … 616 616 !------------------ 617 617 DO ji = kideb, kiut 618 zh_i(ji) = ht_i_b(ji) / nlay_i618 zh_i(ji) = ht_i_b(ji) / nlay_i 619 619 ENDDO 620 620 … … 624 624 z_i(:,0) = 0.0 625 625 DO jk = 1, nlay_i 626 DO ji = kideb, kiut627 z_i(ji,jk) = zh_i(ji) * jk628 END DO626 DO ji = kideb, kiut 627 z_i(ji,jk) = zh_i(ji) * jk 628 END DO 629 629 ENDDO 630 630 631 631 !--thicknesses of the layers 632 632 DO layer0 = ntop0, maxnbot0 633 DO ji = kideb, kiut634 zhl0(ji,layer0) = zm0(ji,layer0) - zm0(ji,layer0-1) !thicknesses of the layers635 END DO633 DO ji = kideb, kiut 634 zhl0(ji,layer0) = zm0(ji,layer0) - zm0(ji,layer0-1) !thicknesses of the layers 635 END DO 636 636 ENDDO 637 637 … … 642 642 q_i_b(:,:) = 0.0 643 643 DO layer0 = ntop0, maxnbot0 644 DO layer1 = ntop1, nbot1645 DO ji = kideb, kiut646 zrl01(layer1,layer0) = MAX(0.0,( MIN(zm0(ji,layer0),z_i(ji,layer1)) &647 - MAX(zm0(ji,layer0-1), z_i(ji,layer1-1)))/MAX(zhl0(ji,layer0),epsi10))648 q_i_b(ji,layer1) = q_i_b(ji,layer1) &649 650 651 652 END DO653 END DO644 DO layer1 = ntop1, nbot1 645 DO ji = kideb, kiut 646 zrl01(layer1,layer0) = MAX(0.0,( MIN(zm0(ji,layer0),z_i(ji,layer1)) & 647 - MAX(zm0(ji,layer0-1), z_i(ji,layer1-1)))/MAX(zhl0(ji,layer0),epsi10)) 648 q_i_b(ji,layer1) = q_i_b(ji,layer1) & 649 + zrl01(layer1,layer0)*qm0(ji,layer0) & 650 * MAX(0.0,SIGN(1.0,ht_i_b(ji)-zeps6+zeps)) & 651 * MAX(0.0,SIGN(1.0,nbot0(ji)-layer0+zeps)) 652 END DO 653 END DO 654 654 ENDDO 655 655 … … 663 663 END DO 664 664 END DO 665 !665 ! 666 666 DO ji = kideb, kiut 667 667 IF ( ABS ( zqti_in(ji) - zqti_fin(ji) ) / rdt_ice .GT. 1.0e-6 ) THEN … … 669 669 zjj = ( npb(ji) - 1 ) / jpi + 1 670 670 WRITE(numout,*) ' violation of heat conservation : ', & 671 671 ABS ( zqti_in(ji) - zqti_fin(ji) ) / rdt_ice 672 672 WRITE(numout,*) ' ji, jj : ', zji, zjj 673 673 WRITE(numout,*) ' ht_i_b : ', ht_i_b(ji) … … 700 700 END DO 701 701 702 !703 !------------------------------------------------------------------------------|704 ! 5) Update salinity and recover temperature |705 !------------------------------------------------------------------------------|706 !702 ! 703 !------------------------------------------------------------------------------| 704 ! 5) Update salinity and recover temperature | 705 !------------------------------------------------------------------------------| 706 ! 707 707 ! Update salinity (basal entrapment, snow ice formation) 708 708 DO ji = kideb, kiut 709 709 sm_i_b(ji) = sm_i_b(ji) & 710 710 + dsm_i_se_1d(ji) + dsm_i_si_1d(ji) 711 711 END DO !ji 712 712 … … 720 720 zaaa = cpic 721 721 zbbb = ( rcp - cpic ) * ( ztmelts - rtt ) + & 722 722 q_i_b(ji,jk) / rhoic - lfus 723 723 zccc = lfus * ( ztmelts - rtt ) 724 724 zdiscrim = SQRT( MAX(zbbb*zbbb - 4.0*zaaa*zccc,0.0) ) 725 725 t_i_b(ji,jk) = rtt - ( zbbb + zdiscrim ) / & 726 726 ( 2.0 *zaaa ) 727 727 END DO !ji 728 728 729 729 END DO !jk 730 730 731 731 END SUBROUTINE lim_thd_ent 732 732 733 733 #else … … 740 740 END SUBROUTINE lim_thd_ent 741 741 #endif 742 742 END MODULE limthd_ent -
trunk/NEMO/LIM_SRC_3/limthd_lac.F90
r888 r921 25 25 USE limtab 26 26 USE limcons 27 27 28 28 IMPLICIT NONE 29 29 PRIVATE … … 50 50 51 51 CONTAINS 52 52 53 53 SUBROUTINE lim_thd_lac 54 54 !!------------------------------------------------------------------- … … 146 146 zalphai , & !: factor describing how old and new layers overlap each other [m] 147 147 zindb 148 148 149 149 REAL(wp), DIMENSION(jpij,jkmax+1,jpl) :: & 150 150 zqm0 , & !: old layer-system heat content … … 188 188 189 189 !!-----------------------------------------------------------------------! 190 190 191 191 et_i_init(:,:) = 0.0 192 192 et_s_init(:,:) = 0.0 … … 195 195 zeps6 = 1.0e-6 196 196 197 !------------------------------------------------------------------------------!198 ! 1) Conservation check and changes in each ice category199 !------------------------------------------------------------------------------!197 !------------------------------------------------------------------------------! 198 ! 1) Conservation check and changes in each ice category 199 !------------------------------------------------------------------------------! 200 200 IF ( con_i ) THEN 201 201 CALL lim_column_sum (jpl, v_i, vt_i_init) … … 205 205 ENDIF 206 206 207 !------------------------------------------------------------------------------|208 ! 2) Convert units for ice internal energy209 !------------------------------------------------------------------------------|207 !------------------------------------------------------------------------------| 208 ! 2) Convert units for ice internal energy 209 !------------------------------------------------------------------------------| 210 210 DO jl = 1, jpl 211 DO jk = 1, nlay_i 212 DO jj = 1, jpj 213 DO ji = 1, jpi 214 !Energy of melting q(S,T) [J.m-3] 215 e_i(ji,jj,jk,jl) = e_i(ji,jj,jk,jl) / & 216 MAX( area(ji,jj) * v_i(ji,jj,jl) , zeps ) * & 217 nlay_i 218 zindb = 1.0-MAX(0.0,SIGN(1.0,-v_i(ji,jj,jl))) !0 if no ice and 1 if yes 219 e_i(ji,jj,jk,jl) = e_i(ji,jj,jk,jl)*unit_fac*zindb 211 DO jk = 1, nlay_i 212 DO jj = 1, jpj 213 DO ji = 1, jpi 214 !Energy of melting q(S,T) [J.m-3] 215 e_i(ji,jj,jk,jl) = e_i(ji,jj,jk,jl) / & 216 MAX( area(ji,jj) * v_i(ji,jj,jl) , zeps ) * & 217 nlay_i 218 zindb = 1.0-MAX(0.0,SIGN(1.0,-v_i(ji,jj,jl))) !0 if no ice and 1 if yes 219 e_i(ji,jj,jk,jl) = e_i(ji,jj,jk,jl)*unit_fac*zindb 220 END DO 220 221 END DO 221 END DO 222 END DO 222 END DO 223 223 END DO 224 224 225 !------------------------------------------------------------------------------!226 ! 3) Collection thickness of ice formed in leads and polynyas227 !------------------------------------------------------------------------------!225 !------------------------------------------------------------------------------! 226 ! 3) Collection thickness of ice formed in leads and polynyas 227 !------------------------------------------------------------------------------! 228 228 ! hicol is the thickness of new ice formed in open water 229 229 ! hicol can be either prescribed (frazswi = 0) … … 248 248 IF (fraz_swi.eq.1.0) THEN 249 249 250 251 252 253 254 255 256 257 258 259 260 261 DO ji = 1, jpi262 263 IF ( tms(ji,jj) * ( qcmif(ji,jj) - qldif(ji,jj) ) > 0.e0 ) THEN264 !-------------265 ! Wind stress266 !-------------267 ! C-grid wind stress components268 ztaux = ( utaui_ice(ji-1,jj ) * tmu(ji-1,jj ) &269 270 ztauy = ( vtaui_ice(ji ,jj-1) * tmv(ji ,jj-1) &271 272 ! Square root of wind stress273 ztenagm = SQRT( SQRT( ztaux * ztaux + ztauy * ztauy ) )274 275 !---------------------276 ! Frazil ice velocity277 !---------------------278 zvfrx = zgamafr * zsqcd * ztaux / MAX(ztenagm,zeps)279 zvfry = zgamafr * zsqcd * ztauy / MAX(ztenagm,zeps)280 281 !-------------------282 ! Pack ice velocity283 !-------------------284 ! C-grid ice velocity285 zindb = MAX(0.0, SIGN(1.0, at_i(ji,jj) ))286 zvgx = zindb * ( u_ice(ji-1,jj ) * tmu(ji-1,jj ) &287 288 zvgy = zindb * ( v_ice(ji ,jj-1) * tmv(ji ,jj-1) &289 290 291 !-----------------------------------292 ! Relative frazil/pack ice velocity293 !-----------------------------------294 ! absolute relative velocity295 zvrel2 = MAX( ( zvfrx - zvgx ) * ( zvfrx - zvgx ) + &296 297 298 zvrel(ji,jj) = SQRT(zvrel2)299 300 !---------------------301 ! Iterative procedure302 !---------------------303 hicol(ji,jj) = zhicrit + 0.1304 hicol(ji,jj) = zhicrit + hicol(ji,jj) / &305 306 307 308 iter = 1309 iterate_frazil = .true.310 311 DO WHILE ( iter .LT. 100 .AND. iterate_frazil )312 zf = ( hicol(ji,jj) - zhicrit ) * ( hicol(ji,jj)**2 - zhicrit**2 ) &313 314 zfp = ( hicol(ji,jj) - zhicrit ) * ( 3.0*hicol(ji,jj) + zhicrit ) &315 316 zhicol_new = hicol(ji,jj) - zf/zfp317 hicol(ji,jj) = zhicol_new318 319 iter = iter + 1320 321 END DO ! do while322 323 ENDIF ! end of selection of pixels where ice forms324 325 END DO ! loop on ji ends326 END DO ! loop on jj ends250 !-------------------- 251 ! Physical constants 252 !-------------------- 253 hicol(:,:) = 0.0 254 255 zhicrit = 0.04 ! frazil ice thickness 256 ztwogp = 2. * rau0 / ( grav * 0.3 * ( rau0 - rhoic ) ) ! reduced grav 257 zsqcd = 1.0 / SQRT( 1.3 * cai ) ! 1/SQRT(airdensity*drag) 258 zgamafr = 0.03 259 260 DO jj = 1, jpj 261 DO ji = 1, jpi 262 263 IF ( tms(ji,jj) * ( qcmif(ji,jj) - qldif(ji,jj) ) > 0.e0 ) THEN 264 !------------- 265 ! Wind stress 266 !------------- 267 ! C-grid wind stress components 268 ztaux = ( utaui_ice(ji-1,jj ) * tmu(ji-1,jj ) & 269 + utaui_ice(ji ,jj ) * tmu(ji ,jj ) ) / 2.0 270 ztauy = ( vtaui_ice(ji ,jj-1) * tmv(ji ,jj-1) & 271 + vtaui_ice(ji ,jj ) * tmv(ji ,jj ) ) / 2.0 272 ! Square root of wind stress 273 ztenagm = SQRT( SQRT( ztaux * ztaux + ztauy * ztauy ) ) 274 275 !--------------------- 276 ! Frazil ice velocity 277 !--------------------- 278 zvfrx = zgamafr * zsqcd * ztaux / MAX(ztenagm,zeps) 279 zvfry = zgamafr * zsqcd * ztauy / MAX(ztenagm,zeps) 280 281 !------------------- 282 ! Pack ice velocity 283 !------------------- 284 ! C-grid ice velocity 285 zindb = MAX(0.0, SIGN(1.0, at_i(ji,jj) )) 286 zvgx = zindb * ( u_ice(ji-1,jj ) * tmu(ji-1,jj ) & 287 + u_ice(ji,jj ) * tmu(ji ,jj ) ) / 2.0 288 zvgy = zindb * ( v_ice(ji ,jj-1) * tmv(ji ,jj-1) & 289 + v_ice(ji,jj ) * tmv(ji ,jj ) ) / 2.0 290 291 !----------------------------------- 292 ! Relative frazil/pack ice velocity 293 !----------------------------------- 294 ! absolute relative velocity 295 zvrel2 = MAX( ( zvfrx - zvgx ) * ( zvfrx - zvgx ) + & 296 ( zvfry - zvgy ) * ( zvfry - zvgy ) & 297 , 0.15 * 0.15 ) 298 zvrel(ji,jj) = SQRT(zvrel2) 299 300 !--------------------- 301 ! Iterative procedure 302 !--------------------- 303 hicol(ji,jj) = zhicrit + 0.1 304 hicol(ji,jj) = zhicrit + hicol(ji,jj) / & 305 ( hicol(ji,jj) * hicol(ji,jj) - & 306 zhicrit * zhicrit ) * ztwogp * zvrel2 307 308 iter = 1 309 iterate_frazil = .true. 310 311 DO WHILE ( iter .LT. 100 .AND. iterate_frazil ) 312 zf = ( hicol(ji,jj) - zhicrit ) * ( hicol(ji,jj)**2 - zhicrit**2 ) & 313 - hicol(ji,jj) * zhicrit * ztwogp * zvrel2 314 zfp = ( hicol(ji,jj) - zhicrit ) * ( 3.0*hicol(ji,jj) + zhicrit ) & 315 - zhicrit * ztwogp * zvrel2 316 zhicol_new = hicol(ji,jj) - zf/zfp 317 hicol(ji,jj) = zhicol_new 318 319 iter = iter + 1 320 321 END DO ! do while 322 323 ENDIF ! end of selection of pixels where ice forms 324 325 END DO ! loop on ji ends 326 END DO ! loop on jj ends 327 327 328 328 ENDIF ! End of computation of frazil ice collection thickness 329 329 330 !------------------------------------------------------------------------------!331 ! 4) Identify grid points where new ice forms332 !------------------------------------------------------------------------------!330 !------------------------------------------------------------------------------! 331 ! 4) Identify grid points where new ice forms 332 !------------------------------------------------------------------------------! 333 333 334 334 !------------------------------------- … … 349 349 END DO 350 350 351 IF( lwp) THEN351 IF( ln_nicep ) THEN 352 352 WRITE(numout,*) 'lim_thd_lac : nbpac = ', nbpac 353 353 ENDIF … … 360 360 361 361 IF ( nbpac > 0 ) THEN 362 363 CALL tab_2d_1d( nbpac, zat_i_ac (1:nbpac) , at_i , &364 365 DO jl = 1, jpl366 CALL tab_2d_1d( nbpac, za_i_ac(1:nbpac,jl) , a_i(:,:,jl) , &367 368 CALL tab_2d_1d( nbpac, zv_i_ac(1:nbpac,jl) , v_i(:,:,jl) , &369 370 CALL tab_2d_1d( nbpac, zoa_i_ac(1:nbpac,jl) , oa_i(:,:,jl) , &371 372 CALL tab_2d_1d( nbpac, zsmv_i_ac(1:nbpac,jl), smv_i(:,:,jl), &373 374 DO jk = 1, nlay_i375 CALL tab_2d_1d( nbpac, ze_i_ac(1:nbpac,jk,jl), e_i(:,:,jk,jl) , &376 377 END DO ! jk378 END DO ! jl379 380 CALL tab_2d_1d( nbpac, qldif_1d (1:nbpac) , qldif , &381 382 CALL tab_2d_1d( nbpac, qcmif_1d (1:nbpac) , qcmif , &383 384 CALL tab_2d_1d( nbpac, t_bo_b (1:nbpac) , t_bo , &385 386 CALL tab_2d_1d( nbpac, fseqv_1d (1:nbpac) , fseqv , &387 388 CALL tab_2d_1d( nbpac, hicol_b (1:nbpac) , hicol , &389 390 CALL tab_2d_1d( nbpac, zvrel_ac (1:nbpac) , zvrel , &391 392 393 !------------------------------------------------------------------------------!394 ! 5) Compute thickness, salinity, enthalpy, age, area and volume of new ice395 !------------------------------------------------------------------------------!396 397 !----------------------398 ! Thickness of new ice399 !----------------------400 DO ji = 1, nbpac401 zh_newice(ji) = hiccrit(1)402 END DO403 IF ( fraz_swi .EQ. 1.0 ) zh_newice(:) = hicol_b(:)404 405 !----------------------406 ! Salinity of new ice407 !----------------------408 409 IF ( num_sal .EQ. 1 ) THEN410 zs_newice(:) = bulk_sal411 ENDIF ! num_sal412 413 IF ( ( num_sal .EQ. 2 ) .OR. ( num_sal .EQ. 4 ) ) THEN414 415 DO ji = 1, nbpac416 zs_newice(ji) = MIN( 4.606 + 0.91 / zh_newice(ji) , s_i_max )417 zji = MOD( npac(ji) - 1, jpi ) + 1418 zjj = ( npac(ji) - 1 ) / jpi + 1419 zs_newice(ji) = MIN( 0.5*sss_m(zji,zjj) , zs_newice(ji) )420 END DO ! jl421 422 ENDIF ! num_sal423 424 IF ( num_sal .EQ. 3 ) THEN425 zs_newice(:) = 2.3426 ENDIF ! num_sal427 428 !-------------------------429 ! Heat content of new ice430 !-------------------------431 ! We assume that new ice is formed at the seawater freezing point432 DO ji = 1, nbpac433 ztmelts = - tmut * zs_newice(ji) + rtt ! Melting point (K)434 ze_newice(ji) = rhoic * ( cpic * ( ztmelts - t_bo_b(ji) ) &435 436 437 438 ze_newice(ji) = MAX( ze_newice(ji) , 0.0 ) + &439 440 441 END DO ! ji442 !----------------443 ! Age of new ice444 !----------------445 DO ji = 1, nbpac446 zo_newice(ji) = 0.0447 END DO ! ji448 449 !--------------------------450 ! Open water energy budget451 !--------------------------452 DO ji = 1, nbpac453 zqbgow(ji) = qldif_1d(ji) - qcmif_1d(ji) !<0454 END DO ! ji455 456 !-------------------457 ! Volume of new ice458 !-------------------459 DO ji = 1, nbpac460 zv_newice(ji) = - zqbgow(ji) / ze_newice(ji)461 462 ! A fraction zfrazb of frazil ice is accreted at the ice bottom463 zfrazb = ( TANH ( Cfrazb * ( zvrel_ac(ji) - vfrazb ) ) &464 465 zdh_frazb(ji) = zfrazb*zv_newice(ji)466 zv_newice(ji) = ( 1.0 - zfrazb ) * zv_newice(ji)467 END DO468 469 !---------------------------------470 ! Salt flux due to new ice growth471 !---------------------------------472 IF ( ( num_sal .EQ. 4 ) ) THEN473 DO ji = 1, nbpac474 zji = MOD( npac(ji) - 1, jpi ) + 1475 zjj = ( npac(ji) - 1 ) / jpi + 1476 fseqv_1d(ji) = fseqv_1d(ji) + &477 478 479 END DO480 ELSE481 DO ji = 1, nbpac482 zji = MOD( npac(ji) - 1, jpi ) + 1483 zjj = ( npac(ji) - 1 ) / jpi + 1484 fseqv_1d(ji) = fseqv_1d(ji) + &485 486 487 END DO ! ji488 ENDIF489 490 !------------------------------------491 ! Diags for energy conservation test492 !------------------------------------493 DO ji = 1, nbpac494 ! Volume495 zji = MOD( npac(ji) - 1, jpi ) + 1496 zjj = ( npac(ji) - 1 ) / jpi + 1497 vt_i_init(zji,zjj) = vt_i_init(zji,zjj) + zv_newice(ji)498 ! Energy499 zde = ze_newice(ji) / unit_fac500 zde = zde * area(zji,zjj) * zv_newice(ji)501 et_i_init(zji,zjj) = et_i_init(zji,zjj) + zde502 END DO503 504 ! keep new ice volume in memory505 CALL tab_1d_2d( nbpac, v_newice , npac(1:nbpac), zv_newice(1:nbpac) , &506 507 508 !-----------------509 ! Area of new ice510 !-----------------511 DO ji = 1, nbpac512 za_newice(ji) = zv_newice(ji) / zh_newice(ji)513 ! diagnostic514 zji = MOD( npac(ji) - 1, jpi ) + 1515 zjj = ( npac(ji) - 1 ) / jpi + 1516 diag_lat_gr(zji,zjj) = zv_newice(ji) / rdt_ice517 END DO !ji518 519 !------------------------------------------------------------------------------!520 ! 6) Redistribute new ice area and volume into ice categories !521 !------------------------------------------------------------------------------!522 523 !-----------------------------------------524 ! Keep old ice areas and volume in memory525 !-----------------------------------------526 zv_old(:,:) = zv_i_ac(:,:)527 za_old(:,:) = za_i_ac(:,:)528 529 !-------------------------------------------530 ! Compute excessive new ice area and volume531 !-------------------------------------------532 ! If lateral ice growth gives an ice concentration gt 1, then533 ! we keep the excessive volume in memory and attribute it later534 ! to bottom accretion535 DO ji = 1, nbpac536 ! vectorize537 IF ( za_newice(ji) .GT. ( 1.0 - zat_i_ac(ji) ) ) THEN538 zda_res(ji) = za_newice(ji) - (1.0 - zat_i_ac(ji) )539 zdv_res(ji) = zda_res(ji) * zh_newice(ji)540 za_newice(ji) = za_newice(ji) - zda_res(ji)541 zv_newice(ji) = zv_newice(ji) - zdv_res(ji)542 ELSE543 zda_res(ji) = 0.0544 zdv_res(ji) = 0.0545 ENDIF546 END DO ! ji547 548 !------------------------------------------------549 ! Laterally redistribute new ice volume and area550 !------------------------------------------------551 zat_i_ac(:) = 0.0552 553 DO jl = 1, jpl554 DO ji = 1, nbpac555 ! vectorize556 IF ( ( hi_max(jl-1) .LT. zh_newice(ji) ) &557 558 za_i_ac(ji,jl) = za_i_ac(ji,jl) + za_newice(ji)559 zv_i_ac(ji,jl) = zv_i_ac(ji,jl) + zv_newice(ji)560 zat_i_ac(ji) = zat_i_ac(ji) + za_i_ac(ji,jl)561 zcatac(ji) = jl562 ENDIF563 END DO ! ji564 END DO ! jl565 566 !----------------------------------567 ! Heat content - lateral accretion568 !----------------------------------569 DO ji = 1, nbpac570 jl = zcatac(ji) ! categroy in which new ice is put571 ! zindb = 0 if no ice and 1 if yes572 zindb = 1.0 - MAX ( 0.0 , SIGN ( 1.0 , -za_old(ji,jl) ) )573 ! old ice thickness574 zhice_old(ji,jl) = zv_old(ji,jl) &575 576 ! difference in thickness577 zdhex(ji) = MAX( 0.0, zh_newice(ji) - zhice_old(ji,jl) )578 ! is ice totally new in category jl ?579 zswinew(ji) = MAX( 0.0, SIGN( 1.0 , - za_old(ji,jl) + epsi11 ) )580 END DO581 582 DO jk = 1, nlay_i583 DO ji = 1, nbpac584 jl = zcatac(ji)585 zqold = ze_i_ac(ji,jk,jl) ! [ J.m-3 ]586 zalphai = MIN( zhice_old(ji,jl) * jk / nlay_i , &587 588 589 590 ze_i_ac(ji,jk,jl) = &591 zswinew(ji) * ze_newice(ji) &592 + ( 1.0 - zswinew(ji) ) * &593 ( za_old(ji,jl) * zqold * zhice_old(ji,jl) / nlay_i &594 + za_newice(ji) * ze_newice(ji) * zalphai &595 + za_newice(ji) * ze_newice(ji) * zdhex(ji) / nlay_i ) / &596 ( ( zv_i_ac(ji,jl) ) / nlay_i )597 598 END DO !ji599 END DO !jl600 601 !-----------------------------------------------602 ! Add excessive volume of new ice at the bottom603 !-----------------------------------------------604 ! If the ice concentration exceeds 1, the remaining volume of new ice605 ! is equally redistributed among all ice categories in which there is606 ! ice607 608 ! Fraction of level ice609 jm = 1610 zat_i_lev(:) = 0.0611 612 DO jl = ice_cat_bounds(jm,1), ice_cat_bounds(jm,2)613 DO ji = 1, nbpac614 zat_i_lev(ji) = zat_i_lev(ji) + za_i_ac(ji,jl)615 END DO616 END DO617 618 WRITE(numout,*) ' zv_i_ac : ', zv_i_ac(jiindx, 1:jpl)619 DO jl = ice_cat_bounds(jm,1), ice_cat_bounds(jm,2)620 DO ji = 1, nbpac621 zindb = MAX( 0.0, SIGN( 1.0, zdv_res(ji) ) )622 zv_i_ac(ji,jl) = zv_i_ac(ji,jl) + &623 624 625 END DO ! ji626 END DO ! jl627 WRITE(numout,*) ' zv_i_ac : ', zv_i_ac(jiindx, 1:jpl)628 629 !---------------------------------630 ! Heat content - bottom accretion631 !---------------------------------632 jm = 1633 DO jl = ice_cat_bounds(jm,1), ice_cat_bounds(jm,2)634 DO ji = 1, nbpac635 ! zindb = 0 if no ice and 1 if yes636 zindb = 1.0 - MAX( 0.0 , SIGN( 1.0 &637 638 zhice_old(ji,jl) = zv_i_ac(ji,jl) / &639 640 zdhicbot(ji,jl) = zdv_res(ji) / MAX( za_i_ac(ji,jl) , zeps ) &641 642 643 644 ! thickness of residual ice645 zdummy(ji,jl) = zv_i_ac(ji,jl)/MAX(za_i_ac(ji,jl),zeps)*zindb646 END DO !ji647 END DO !jl648 649 ! old layers thicknesses and enthalpies650 DO jl = ice_cat_bounds(jm,1), ice_cat_bounds(jm,2)651 DO jk = 1, nlay_i652 DO ji = 1, nbpac653 zthick0(ji,jk,jl)= zhice_old(ji,jl) / nlay_i654 zqm0 (ji,jk,jl)= ze_i_ac(ji,jk,jl) * zthick0(ji,jk,jl)655 END DO !ji656 END DO !jk657 END DO !jl658 659 DO jl = ice_cat_bounds(jm,1), ice_cat_bounds(jm,2)660 DO ji = 1, nbpac661 zthick0(ji,nlay_i+1,jl) = zdhicbot(ji,jl)662 zqm0 (ji,nlay_i+1,jl) = ze_newice(ji)*zdhicbot(ji,jl)663 END DO ! ji664 END DO ! jl665 666 ! Redistributing energy on the new grid667 ze_i_ac(:,:,:) = 0.0668 DO jl = ice_cat_bounds(jm,1), ice_cat_bounds(jm,2)669 DO jk = 1, nlay_i670 DO layer = 1, nlay_i + 1671 DO ji = 1, nbpac672 zindb = 1.0 - MAX( 0.0 , SIGN( 1.0 , &673 674 ! Redistributing energy on the new grid675 zweight = MAX ( &676 MIN( zhice_old(ji,jl) * layer , zdummy(ji,jl) * jk ) - &677 MAX( zhice_old(ji,jl) * ( layer - 1 ) , zdummy(ji,jl) * &362 363 CALL tab_2d_1d( nbpac, zat_i_ac (1:nbpac) , at_i , & 364 jpi, jpj, npac(1:nbpac) ) 365 DO jl = 1, jpl 366 CALL tab_2d_1d( nbpac, za_i_ac(1:nbpac,jl) , a_i(:,:,jl) , & 367 jpi, jpj, npac(1:nbpac) ) 368 CALL tab_2d_1d( nbpac, zv_i_ac(1:nbpac,jl) , v_i(:,:,jl) , & 369 jpi, jpj, npac(1:nbpac) ) 370 CALL tab_2d_1d( nbpac, zoa_i_ac(1:nbpac,jl) , oa_i(:,:,jl) , & 371 jpi, jpj, npac(1:nbpac) ) 372 CALL tab_2d_1d( nbpac, zsmv_i_ac(1:nbpac,jl), smv_i(:,:,jl), & 373 jpi, jpj, npac(1:nbpac) ) 374 DO jk = 1, nlay_i 375 CALL tab_2d_1d( nbpac, ze_i_ac(1:nbpac,jk,jl), e_i(:,:,jk,jl) , & 376 jpi, jpj, npac(1:nbpac) ) 377 END DO ! jk 378 END DO ! jl 379 380 CALL tab_2d_1d( nbpac, qldif_1d (1:nbpac) , qldif , & 381 jpi, jpj, npac(1:nbpac) ) 382 CALL tab_2d_1d( nbpac, qcmif_1d (1:nbpac) , qcmif , & 383 jpi, jpj, npac(1:nbpac) ) 384 CALL tab_2d_1d( nbpac, t_bo_b (1:nbpac) , t_bo , & 385 jpi, jpj, npac(1:nbpac) ) 386 CALL tab_2d_1d( nbpac, fseqv_1d (1:nbpac) , fseqv , & 387 jpi, jpj, npac(1:nbpac) ) 388 CALL tab_2d_1d( nbpac, hicol_b (1:nbpac) , hicol , & 389 jpi, jpj, npac(1:nbpac) ) 390 CALL tab_2d_1d( nbpac, zvrel_ac (1:nbpac) , zvrel , & 391 jpi, jpj, npac(1:nbpac) ) 392 393 !------------------------------------------------------------------------------! 394 ! 5) Compute thickness, salinity, enthalpy, age, area and volume of new ice 395 !------------------------------------------------------------------------------! 396 397 !---------------------- 398 ! Thickness of new ice 399 !---------------------- 400 DO ji = 1, nbpac 401 zh_newice(ji) = hiccrit(1) 402 END DO 403 IF ( fraz_swi .EQ. 1.0 ) zh_newice(:) = hicol_b(:) 404 405 !---------------------- 406 ! Salinity of new ice 407 !---------------------- 408 409 IF ( num_sal .EQ. 1 ) THEN 410 zs_newice(:) = bulk_sal 411 ENDIF ! num_sal 412 413 IF ( ( num_sal .EQ. 2 ) .OR. ( num_sal .EQ. 4 ) ) THEN 414 415 DO ji = 1, nbpac 416 zs_newice(ji) = MIN( 4.606 + 0.91 / zh_newice(ji) , s_i_max ) 417 zji = MOD( npac(ji) - 1, jpi ) + 1 418 zjj = ( npac(ji) - 1 ) / jpi + 1 419 zs_newice(ji) = MIN( 0.5*sss_m(zji,zjj) , zs_newice(ji) ) 420 END DO ! jl 421 422 ENDIF ! num_sal 423 424 IF ( num_sal .EQ. 3 ) THEN 425 zs_newice(:) = 2.3 426 ENDIF ! num_sal 427 428 !------------------------- 429 ! Heat content of new ice 430 !------------------------- 431 ! We assume that new ice is formed at the seawater freezing point 432 DO ji = 1, nbpac 433 ztmelts = - tmut * zs_newice(ji) + rtt ! Melting point (K) 434 ze_newice(ji) = rhoic * ( cpic * ( ztmelts - t_bo_b(ji) ) & 435 + lfus * ( 1.0 - ( ztmelts - rtt ) & 436 / ( t_bo_b(ji) - rtt ) ) & 437 - rcp * ( ztmelts-rtt ) ) 438 ze_newice(ji) = MAX( ze_newice(ji) , 0.0 ) + & 439 MAX( 0.0 , SIGN( 1.0 , - ze_newice(ji) ) ) & 440 * rhoic * lfus 441 END DO ! ji 442 !---------------- 443 ! Age of new ice 444 !---------------- 445 DO ji = 1, nbpac 446 zo_newice(ji) = 0.0 447 END DO ! ji 448 449 !-------------------------- 450 ! Open water energy budget 451 !-------------------------- 452 DO ji = 1, nbpac 453 zqbgow(ji) = qldif_1d(ji) - qcmif_1d(ji) !<0 454 END DO ! ji 455 456 !------------------- 457 ! Volume of new ice 458 !------------------- 459 DO ji = 1, nbpac 460 zv_newice(ji) = - zqbgow(ji) / ze_newice(ji) 461 462 ! A fraction zfrazb of frazil ice is accreted at the ice bottom 463 zfrazb = ( TANH ( Cfrazb * ( zvrel_ac(ji) - vfrazb ) ) & 464 + 1.0 ) / 2.0 * maxfrazb 465 zdh_frazb(ji) = zfrazb*zv_newice(ji) 466 zv_newice(ji) = ( 1.0 - zfrazb ) * zv_newice(ji) 467 END DO 468 469 !--------------------------------- 470 ! Salt flux due to new ice growth 471 !--------------------------------- 472 IF ( ( num_sal .EQ. 4 ) ) THEN 473 DO ji = 1, nbpac 474 zji = MOD( npac(ji) - 1, jpi ) + 1 475 zjj = ( npac(ji) - 1 ) / jpi + 1 476 fseqv_1d(ji) = fseqv_1d(ji) + & 477 ( sss_m(zji,zjj) - bulk_sal ) * rhoic * & 478 zv_newice(ji) / rdt_ice 479 END DO 480 ELSE 481 DO ji = 1, nbpac 482 zji = MOD( npac(ji) - 1, jpi ) + 1 483 zjj = ( npac(ji) - 1 ) / jpi + 1 484 fseqv_1d(ji) = fseqv_1d(ji) + & 485 ( sss_m(zji,zjj) - zs_newice(ji) ) * rhoic * & 486 zv_newice(ji) / rdt_ice 487 END DO ! ji 488 ENDIF 489 490 !------------------------------------ 491 ! Diags for energy conservation test 492 !------------------------------------ 493 DO ji = 1, nbpac 494 ! Volume 495 zji = MOD( npac(ji) - 1, jpi ) + 1 496 zjj = ( npac(ji) - 1 ) / jpi + 1 497 vt_i_init(zji,zjj) = vt_i_init(zji,zjj) + zv_newice(ji) 498 ! Energy 499 zde = ze_newice(ji) / unit_fac 500 zde = zde * area(zji,zjj) * zv_newice(ji) 501 et_i_init(zji,zjj) = et_i_init(zji,zjj) + zde 502 END DO 503 504 ! keep new ice volume in memory 505 CALL tab_1d_2d( nbpac, v_newice , npac(1:nbpac), zv_newice(1:nbpac) , & 506 jpi, jpj ) 507 508 !----------------- 509 ! Area of new ice 510 !----------------- 511 DO ji = 1, nbpac 512 za_newice(ji) = zv_newice(ji) / zh_newice(ji) 513 ! diagnostic 514 zji = MOD( npac(ji) - 1, jpi ) + 1 515 zjj = ( npac(ji) - 1 ) / jpi + 1 516 diag_lat_gr(zji,zjj) = zv_newice(ji) / rdt_ice 517 END DO !ji 518 519 !------------------------------------------------------------------------------! 520 ! 6) Redistribute new ice area and volume into ice categories ! 521 !------------------------------------------------------------------------------! 522 523 !----------------------------------------- 524 ! Keep old ice areas and volume in memory 525 !----------------------------------------- 526 zv_old(:,:) = zv_i_ac(:,:) 527 za_old(:,:) = za_i_ac(:,:) 528 529 !------------------------------------------- 530 ! Compute excessive new ice area and volume 531 !------------------------------------------- 532 ! If lateral ice growth gives an ice concentration gt 1, then 533 ! we keep the excessive volume in memory and attribute it later 534 ! to bottom accretion 535 DO ji = 1, nbpac 536 ! vectorize 537 IF ( za_newice(ji) .GT. ( 1.0 - zat_i_ac(ji) ) ) THEN 538 zda_res(ji) = za_newice(ji) - (1.0 - zat_i_ac(ji) ) 539 zdv_res(ji) = zda_res(ji) * zh_newice(ji) 540 za_newice(ji) = za_newice(ji) - zda_res(ji) 541 zv_newice(ji) = zv_newice(ji) - zdv_res(ji) 542 ELSE 543 zda_res(ji) = 0.0 544 zdv_res(ji) = 0.0 545 ENDIF 546 END DO ! ji 547 548 !------------------------------------------------ 549 ! Laterally redistribute new ice volume and area 550 !------------------------------------------------ 551 zat_i_ac(:) = 0.0 552 553 DO jl = 1, jpl 554 DO ji = 1, nbpac 555 ! vectorize 556 IF ( ( hi_max(jl-1) .LT. zh_newice(ji) ) & 557 .AND. ( zh_newice(ji) .LE. hi_max(jl) ) ) THEN 558 za_i_ac(ji,jl) = za_i_ac(ji,jl) + za_newice(ji) 559 zv_i_ac(ji,jl) = zv_i_ac(ji,jl) + zv_newice(ji) 560 zat_i_ac(ji) = zat_i_ac(ji) + za_i_ac(ji,jl) 561 zcatac(ji) = jl 562 ENDIF 563 END DO ! ji 564 END DO ! jl 565 566 !---------------------------------- 567 ! Heat content - lateral accretion 568 !---------------------------------- 569 DO ji = 1, nbpac 570 jl = zcatac(ji) ! categroy in which new ice is put 571 ! zindb = 0 if no ice and 1 if yes 572 zindb = 1.0 - MAX ( 0.0 , SIGN ( 1.0 , -za_old(ji,jl) ) ) 573 ! old ice thickness 574 zhice_old(ji,jl) = zv_old(ji,jl) & 575 / MAX ( za_old(ji,jl) , zeps ) * zindb 576 ! difference in thickness 577 zdhex(ji) = MAX( 0.0, zh_newice(ji) - zhice_old(ji,jl) ) 578 ! is ice totally new in category jl ? 579 zswinew(ji) = MAX( 0.0, SIGN( 1.0 , - za_old(ji,jl) + epsi11 ) ) 580 END DO 581 582 DO jk = 1, nlay_i 583 DO ji = 1, nbpac 584 jl = zcatac(ji) 585 zqold = ze_i_ac(ji,jk,jl) ! [ J.m-3 ] 586 zalphai = MIN( zhice_old(ji,jl) * jk / nlay_i , & 587 zh_newice(ji) ) & 588 - MIN( zhice_old(ji,jl) * ( jk - 1 ) & 589 / nlay_i , zh_newice(ji) ) 590 ze_i_ac(ji,jk,jl) = & 591 zswinew(ji) * ze_newice(ji) & 592 + ( 1.0 - zswinew(ji) ) * & 593 ( za_old(ji,jl) * zqold * zhice_old(ji,jl) / nlay_i & 594 + za_newice(ji) * ze_newice(ji) * zalphai & 595 + za_newice(ji) * ze_newice(ji) * zdhex(ji) / nlay_i ) / & 596 ( ( zv_i_ac(ji,jl) ) / nlay_i ) 597 598 END DO !ji 599 END DO !jl 600 601 !----------------------------------------------- 602 ! Add excessive volume of new ice at the bottom 603 !----------------------------------------------- 604 ! If the ice concentration exceeds 1, the remaining volume of new ice 605 ! is equally redistributed among all ice categories in which there is 606 ! ice 607 608 ! Fraction of level ice 609 jm = 1 610 zat_i_lev(:) = 0.0 611 612 DO jl = ice_cat_bounds(jm,1), ice_cat_bounds(jm,2) 613 DO ji = 1, nbpac 614 zat_i_lev(ji) = zat_i_lev(ji) + za_i_ac(ji,jl) 615 END DO 616 END DO 617 618 IF( ln_nicep ) WRITE(numout,*) ' zv_i_ac : ', zv_i_ac(jiindx, 1:jpl) 619 DO jl = ice_cat_bounds(jm,1), ice_cat_bounds(jm,2) 620 DO ji = 1, nbpac 621 zindb = MAX( 0.0, SIGN( 1.0, zdv_res(ji) ) ) 622 zv_i_ac(ji,jl) = zv_i_ac(ji,jl) + & 623 zindb * zdv_res(ji) * za_i_ac(ji,jl) / & 624 MAX( zat_i_lev(ji) , epsi06 ) 625 END DO ! ji 626 END DO ! jl 627 IF( ln_nicep ) WRITE(numout,*) ' zv_i_ac : ', zv_i_ac(jiindx, 1:jpl) 628 629 !--------------------------------- 630 ! Heat content - bottom accretion 631 !--------------------------------- 632 jm = 1 633 DO jl = ice_cat_bounds(jm,1), ice_cat_bounds(jm,2) 634 DO ji = 1, nbpac 635 ! zindb = 0 if no ice and 1 if yes 636 zindb = 1.0 - MAX( 0.0 , SIGN( 1.0 & 637 , - za_i_ac(ji,jl ) ) ) 638 zhice_old(ji,jl) = zv_i_ac(ji,jl) / & 639 MAX( za_i_ac(ji,jl) , zeps ) * zindb 640 zdhicbot(ji,jl) = zdv_res(ji) / MAX( za_i_ac(ji,jl) , zeps ) & 641 * zindb & 642 + zindb * zdh_frazb(ji) ! frazil ice 643 ! may coalesce 644 ! thickness of residual ice 645 zdummy(ji,jl) = zv_i_ac(ji,jl)/MAX(za_i_ac(ji,jl),zeps)*zindb 646 END DO !ji 647 END DO !jl 648 649 ! old layers thicknesses and enthalpies 650 DO jl = ice_cat_bounds(jm,1), ice_cat_bounds(jm,2) 651 DO jk = 1, nlay_i 652 DO ji = 1, nbpac 653 zthick0(ji,jk,jl)= zhice_old(ji,jl) / nlay_i 654 zqm0 (ji,jk,jl)= ze_i_ac(ji,jk,jl) * zthick0(ji,jk,jl) 655 END DO !ji 656 END DO !jk 657 END DO !jl 658 659 DO jl = ice_cat_bounds(jm,1), ice_cat_bounds(jm,2) 660 DO ji = 1, nbpac 661 zthick0(ji,nlay_i+1,jl) = zdhicbot(ji,jl) 662 zqm0 (ji,nlay_i+1,jl) = ze_newice(ji)*zdhicbot(ji,jl) 663 END DO ! ji 664 END DO ! jl 665 666 ! Redistributing energy on the new grid 667 ze_i_ac(:,:,:) = 0.0 668 DO jl = ice_cat_bounds(jm,1), ice_cat_bounds(jm,2) 669 DO jk = 1, nlay_i 670 DO layer = 1, nlay_i + 1 671 DO ji = 1, nbpac 672 zindb = 1.0 - MAX( 0.0 , SIGN( 1.0 , & 673 - za_i_ac(ji,jl ) ) ) 674 ! Redistributing energy on the new grid 675 zweight = MAX ( & 676 MIN( zhice_old(ji,jl) * layer , zdummy(ji,jl) * jk ) - & 677 MAX( zhice_old(ji,jl) * ( layer - 1 ) , zdummy(ji,jl) * & 678 678 ( jk - 1 ) ) , 0.0 ) & 679 / ( MAX(nlay_i * zthick0(ji,layer,jl),zeps) ) * zindb680 ze_i_ac(ji,jk,jl) = ze_i_ac(ji,jk,jl) + &681 682 END DO ! ji683 END DO ! layer684 END DO ! jk685 END DO ! jl686 687 DO jl = ice_cat_bounds(jm,1), ice_cat_bounds(jm,2)688 DO jk = 1, nlay_i689 DO ji = 1, nbpac690 zindb = 1.0 - MAX( 0.0 , SIGN( 1.0 &691 692 ze_i_ac(ji,jk,jl) = ze_i_ac(ji,jk,jl) / &693 694 695 END DO696 END DO697 END DO698 699 !------------700 ! Update age701 !------------702 DO jl = 1, jpl703 DO ji = 1, nbpac704 !--ice age705 zindb = 1.0 - MAX( 0.0 , SIGN( 1.0 , - &706 707 zoa_i_ac(ji,jl) = za_old(ji,jl) * zoa_i_ac(ji,jl) / &708 709 END DO ! ji710 END DO ! jl711 712 !-----------------713 ! Update salinity714 !-----------------715 IF ( ( num_sal .EQ. 2 ) .OR. ( num_sal .EQ. 4 ) ) THEN716 717 DO jl = 1, jpl718 DO ji = 1, nbpac719 !zindb = 0 if no ice and 1 if yes720 zindb = 1.0 - MAX( 0.0 , SIGN( 1.0 , - &721 722 zdv = zv_i_ac(ji,jl) - zv_old(ji,jl)723 zsmv_i_ac(ji,jl) = ( zsmv_i_ac(ji,jl) + zdv * zs_newice(ji) ) * &724 725 END DO ! ji726 END DO ! jl727 728 ENDIF ! num_sal729 730 731 !------------------------------------------------------------------------------!732 ! 8) Change 2D vectors to 1D vectors733 !------------------------------------------------------------------------------!734 735 DO jl = 1, jpl736 CALL tab_1d_2d( nbpac, a_i(:,:,jl) , npac(1:nbpac) , &737 738 CALL tab_1d_2d( nbpac, v_i(:,:,jl) , npac(1:nbpac) , &739 740 CALL tab_1d_2d( nbpac, oa_i(:,:,jl), npac(1:nbpac) , &741 742 IF ( ( num_sal .EQ. 2 ) .OR. ( num_sal .EQ. 4 ) ) &743 CALL tab_1d_2d( nbpac, smv_i(:,:,jl) , npac(1:nbpac) , &744 745 DO jk = 1, nlay_i746 CALL tab_1d_2d( nbpac, e_i(:,:,jk,jl) , npac(1:nbpac), &747 748 END DO ! jk749 END DO !jl750 CALL tab_1d_2d( nbpac, fseqv , npac(1:nbpac), fseqv_1d (1:nbpac) , &751 752 753 ENDIF ! nbpac > 0754 755 !------------------------------------------------------------------------------!756 ! 9) Change units for e_i757 !------------------------------------------------------------------------------!679 / ( MAX(nlay_i * zthick0(ji,layer,jl),zeps) ) * zindb 680 ze_i_ac(ji,jk,jl) = ze_i_ac(ji,jk,jl) + & 681 zweight * zqm0(ji,layer,jl) 682 END DO ! ji 683 END DO ! layer 684 END DO ! jk 685 END DO ! jl 686 687 DO jl = ice_cat_bounds(jm,1), ice_cat_bounds(jm,2) 688 DO jk = 1, nlay_i 689 DO ji = 1, nbpac 690 zindb = 1.0 - MAX( 0.0 , SIGN( 1.0 & 691 , - zv_i_ac(ji,jl) ) ) !0 if no ice 692 ze_i_ac(ji,jk,jl) = ze_i_ac(ji,jk,jl) / & 693 MAX( zv_i_ac(ji,jl) , zeps) & 694 * za_i_ac(ji,jl) * nlay_i * zindb 695 END DO 696 END DO 697 END DO 698 699 !------------ 700 ! Update age 701 !------------ 702 DO jl = 1, jpl 703 DO ji = 1, nbpac 704 !--ice age 705 zindb = 1.0 - MAX( 0.0 , SIGN( 1.0 , - & 706 za_i_ac(ji,jl) ) ) ! 0 if no ice and 1 if yes 707 zoa_i_ac(ji,jl) = za_old(ji,jl) * zoa_i_ac(ji,jl) / & 708 MAX( za_i_ac(ji,jl) , zeps ) * zindb 709 END DO ! ji 710 END DO ! jl 711 712 !----------------- 713 ! Update salinity 714 !----------------- 715 IF ( ( num_sal .EQ. 2 ) .OR. ( num_sal .EQ. 4 ) ) THEN 716 717 DO jl = 1, jpl 718 DO ji = 1, nbpac 719 !zindb = 0 if no ice and 1 if yes 720 zindb = 1.0 - MAX( 0.0 , SIGN( 1.0 , - & 721 zv_i_ac(ji,jl) ) ) ! 0 if no ice and 1 if yes 722 zdv = zv_i_ac(ji,jl) - zv_old(ji,jl) 723 zsmv_i_ac(ji,jl) = ( zsmv_i_ac(ji,jl) + zdv * zs_newice(ji) ) * & 724 zindb 725 END DO ! ji 726 END DO ! jl 727 728 ENDIF ! num_sal 729 730 731 !------------------------------------------------------------------------------! 732 ! 8) Change 2D vectors to 1D vectors 733 !------------------------------------------------------------------------------! 734 735 DO jl = 1, jpl 736 CALL tab_1d_2d( nbpac, a_i(:,:,jl) , npac(1:nbpac) , & 737 za_i_ac(1:nbpac,jl) , jpi, jpj ) 738 CALL tab_1d_2d( nbpac, v_i(:,:,jl) , npac(1:nbpac) , & 739 zv_i_ac(1:nbpac,jl) , jpi, jpj ) 740 CALL tab_1d_2d( nbpac, oa_i(:,:,jl), npac(1:nbpac) , & 741 zoa_i_ac(1:nbpac,jl), jpi, jpj ) 742 IF ( ( num_sal .EQ. 2 ) .OR. ( num_sal .EQ. 4 ) ) & 743 CALL tab_1d_2d( nbpac, smv_i(:,:,jl) , npac(1:nbpac) , & 744 zsmv_i_ac(1:nbpac,jl) , jpi, jpj ) 745 DO jk = 1, nlay_i 746 CALL tab_1d_2d( nbpac, e_i(:,:,jk,jl) , npac(1:nbpac), & 747 ze_i_ac(1:nbpac,jk,jl), jpi, jpj ) 748 END DO ! jk 749 END DO !jl 750 CALL tab_1d_2d( nbpac, fseqv , npac(1:nbpac), fseqv_1d (1:nbpac) , & 751 jpi, jpj ) 752 753 ENDIF ! nbpac > 0 754 755 !------------------------------------------------------------------------------! 756 ! 9) Change units for e_i 757 !------------------------------------------------------------------------------! 758 758 759 759 DO jl = 1, jpl … … 767 767 ! of layers to get heat content in 10^9 Joules 768 768 e_i(ji,jj,jk,jl) = e_i(ji,jj,jk,jl) * & 769 770 769 area(ji,jj) * v_i(ji,jj,jl) / & 770 nlay_i 771 771 END DO 772 772 END DO 773 773 END DO 774 774 END DO 775 776 !------------------------------------------------------------------------------|777 ! 10) Conservation check and changes in each ice category778 !------------------------------------------------------------------------------|775 776 !------------------------------------------------------------------------------| 777 ! 10) Conservation check and changes in each ice category 778 !------------------------------------------------------------------------------| 779 779 780 780 IF ( con_i ) THEN 781 CALL lim_column_sum (jpl, v_i, vt_i_final) 782 fieldid = 'v_i, limthd_lac' 783 CALL lim_cons_check (vt_i_init, vt_i_final, 1.0e-6, fieldid) 784 785 CALL lim_column_sum_energy(jpl, nlay_i, e_i, et_i_final) 786 fieldid = 'e_i, limthd_lac' 787 CALL lim_cons_check (et_i_final, et_i_final, 1.0e-3, fieldid) 788 789 CALL lim_column_sum (jpl, v_s, vt_s_final) 790 fieldid = 'v_s, limthd_lac' 791 CALL lim_cons_check (vt_s_init, vt_s_final, 1.0e-6, fieldid) 792 793 ! CALL lim_column_sum (jpl, e_s(:,:,1,:) , et_s_init) 794 ! fieldid = 'e_s, limthd_lac' 795 ! CALL lim_cons_check (et_s_init, et_s_final, 1.0e-3, fieldid) 796 797 WRITE(numout,*) ' vt_i_init : ', vt_i_init(jiindx,jjindx) 798 WRITE(numout,*) ' vt_i_final: ', vt_i_final(jiindx,jjindx) 799 WRITE(numout,*) ' et_i_init : ', et_i_init(jiindx,jjindx) 800 WRITE(numout,*) ' et_i_final: ', et_i_final(jiindx,jjindx) 781 CALL lim_column_sum (jpl, v_i, vt_i_final) 782 fieldid = 'v_i, limthd_lac' 783 CALL lim_cons_check (vt_i_init, vt_i_final, 1.0e-6, fieldid) 784 785 CALL lim_column_sum_energy(jpl, nlay_i, e_i, et_i_final) 786 fieldid = 'e_i, limthd_lac' 787 CALL lim_cons_check (et_i_final, et_i_final, 1.0e-3, fieldid) 788 789 CALL lim_column_sum (jpl, v_s, vt_s_final) 790 fieldid = 'v_s, limthd_lac' 791 CALL lim_cons_check (vt_s_init, vt_s_final, 1.0e-6, fieldid) 792 793 ! CALL lim_column_sum (jpl, e_s(:,:,1,:) , et_s_init) 794 ! fieldid = 'e_s, limthd_lac' 795 ! CALL lim_cons_check (et_s_init, et_s_final, 1.0e-3, fieldid) 796 797 IF( ln_nicep ) THEN 798 WRITE(numout,*) ' vt_i_init : ', vt_i_init(jiindx,jjindx) 799 WRITE(numout,*) ' vt_i_final: ', vt_i_final(jiindx,jjindx) 800 WRITE(numout,*) ' et_i_init : ', et_i_init(jiindx,jjindx) 801 WRITE(numout,*) ' et_i_final: ', et_i_final(jiindx,jjindx) 802 ENDIF 801 803 802 804 ENDIF -
trunk/NEMO/LIM_SRC_3/limthd_sal.F90
r888 r921 38 38 zone = 1.e0 39 39 40 40 CONTAINS 41 41 42 42 SUBROUTINE lim_thd_sal(kideb,kiut) … … 95 95 zccc , & !: dummy factor 96 96 zdiscrim !: dummy factor 97 97 98 98 REAL(wp), DIMENSION(jpij) :: & 99 99 ze_init , & !initial total enthalpy … … 103 103 !!--------------------------------------------------------------------- 104 104 105 !------------------------------------------------------------------------------|106 ! 1) Constant salinity, constant in time |107 !------------------------------------------------------------------------------|105 !------------------------------------------------------------------------------| 106 ! 1) Constant salinity, constant in time | 107 !------------------------------------------------------------------------------| 108 108 109 109 IF (num_sal.eq.1) THEN 110 110 111 WRITE(numout,*)112 WRITE(numout,*) 'lim_thd_sal : Ice salinity computation module ', &113 num_sal114 WRITE(numout,*) '~~~~~~~~~~~~'111 ! WRITE(numout,*) 112 ! WRITE(numout,*) 'lim_thd_sal : Ice salinity computation module ', & 113 ! num_sal 114 ! WRITE(numout,*) '~~~~~~~~~~~~' 115 115 116 116 DO jk = 1, nlay_i … … 126 126 ENDIF ! num_sal .EQ. 1 127 127 128 !------------------------------------------------------------------------------|129 ! Module 2 : Constant salinity varying in time |130 !------------------------------------------------------------------------------|128 !------------------------------------------------------------------------------| 129 ! Module 2 : Constant salinity varying in time | 130 !------------------------------------------------------------------------------| 131 131 132 132 IF ( ( num_sal .EQ. 2 ) .OR. ( num_sal .EQ. 4 ) ) THEN 133 133 134 WRITE(numout,*)135 WRITE(numout,*) 'lim_thd_sal : Ice salinity computation module ', &136 num_sal137 WRITE(numout,*) '~~~~~~~~~~~'138 WRITE(numout,*)134 ! WRITE(numout,*) 135 ! WRITE(numout,*) 'lim_thd_sal : Ice salinity computation module ', & 136 ! num_sal 137 ! WRITE(numout,*) '~~~~~~~~~~~' 138 ! WRITE(numout,*) 139 139 140 140 !--------------------------------- … … 143 143 DO ji = kideb, kiut 144 144 zhiold(ji) = ht_i_b(ji) - dh_i_bott(ji) - dh_snowice(ji) - & 145 145 dh_i_surf(ji) 146 146 END DO ! ji 147 147 … … 172 172 i_ice_switch = 1.0 - MAX ( 0.0 , SIGN ( 1.0 , - ht_i_b(ji) + 1.0e-2 ) ) 173 173 isnowic = 1.0 - MAX ( 0.0 , SIGN ( 1.0 , - dh_snowice(ji) ) ) * & 174 174 i_ice_switch 175 175 176 176 !--------------------- … … 180 180 ! drainage by gravity drainage 181 181 dsm_i_gd_1d(ji) = - igravdr * & 182 183 182 MAX( sm_i_b(ji) - sal_G , 0.0 ) / & 183 time_G * rdt_ice 184 184 185 185 ! drainage by flushing 186 186 dsm_i_fl_1d(ji) = - iflush * & 187 188 187 MAX( sm_i_b(ji) - sal_F , 0.0 ) / & 188 time_F * rdt_ice 189 189 190 190 !----------------- … … 197 197 zsiold(ji) = sm_i_b(ji) 198 198 sm_i_b(ji) = sm_i_b(ji) & 199 199 + dsm_i_fl_1d(ji) + dsm_i_gd_1d(ji) ! & 200 200 201 201 ! if no ice, salinity eq 0.1 202 202 i_ice_switch = 1.0 - MAX ( 0.0, SIGN (1.0 , - ht_i_b(ji) ) ) 203 203 sm_i_b(ji) = i_ice_switch*sm_i_b(ji) + s_i_min * ( 1.0 - & 204 204 i_ice_switch ) 205 205 END DO ! ji 206 206 … … 229 229 i_ice_switch = 1.0 - MAX ( 0.0, SIGN (1.0 , - ht_i_b(ji) ) ) 230 230 fsbri_1d(ji) = fsbri_1d(ji) - & 231 232 233 231 i_ice_switch * rhoic * a_i_b(ji) * ht_i_b(ji) * & 232 ( MAX(dsm_i_gd_1d(ji) + dsm_i_fl_1d(ji), & 233 sm_i_b(ji) - zsiold(ji) ) ) / rdt_ice 234 234 IF ( num_sal .EQ. 4 ) fsbri_1d(ji) = 0.0 235 235 … … 248 248 zaaa = cpic 249 249 zbbb = ( rcp - cpic ) * ( ztmelts - rtt ) + & 250 250 q_i_b(ji,jk) / rhoic - lfus 251 251 zccc = lfus * ( ztmelts - rtt ) 252 252 zdiscrim = SQRT( MAX(zbbb*zbbb - 4.0*zaaa*zccc,0.0) ) 253 253 t_i_b(ji,jk) = rtt - ( zbbb + zdiscrim ) / & 254 254 ( 2.0 *zaaa ) 255 255 END DO !ji 256 256 … … 259 259 ENDIF ! num_sal .EQ. 2 260 260 261 !------------------------------------------------------------------------------|262 ! Module 3 : Profile of salinity, constant in time |263 !------------------------------------------------------------------------------|261 !------------------------------------------------------------------------------| 262 ! Module 3 : Profile of salinity, constant in time | 263 !------------------------------------------------------------------------------| 264 264 265 265 IF ( num_sal .EQ. 3 ) THEN … … 267 267 WRITE(numout,*) 268 268 WRITE(numout,*) 'lim_thd_sal : Ice salinity computation module ', & 269 num_sal269 num_sal 270 270 WRITE(numout,*) '~~~~~~~~~~~~' 271 271 … … 274 274 ENDIF ! num_sal .EQ. 3 275 275 276 !------------------------------------------------------------------------------|277 ! Module 4 : Constant salinity varying in time |278 !------------------------------------------------------------------------------|276 !------------------------------------------------------------------------------| 277 ! Module 4 : Constant salinity varying in time | 278 !------------------------------------------------------------------------------| 279 279 280 280 ! Cox and Weeks, 1974 … … 283 283 WRITE(numout,*) 284 284 WRITE(numout,*) 'lim_thd_sal : Ice salinity computation module ', & 285 num_sal285 num_sal 286 286 WRITE(numout,*) '~~~~~~~~~~~~' 287 287 … … 296 296 sm_i_b(ji) = MIN(sm_i_b(ji),zsold) 297 297 ENDIF 298 298 299 299 IF ( ht_i_b(ji) .GT. 3.06918239 ) THEN 300 300 sm_i_b(ji) = 3.0 … … 304 304 s_i_b(ji,jk) = sm_i_b(ji) 305 305 END DO 306 306 307 307 END DO ! ji 308 308 309 309 ENDIF ! num_sal 310 310 311 !------------------------------------------------------------------------------|312 ! 5) Computation of salt flux due to Bottom growth313 !------------------------------------------------------------------------------|311 !------------------------------------------------------------------------------| 312 ! 5) Computation of salt flux due to Bottom growth 313 !------------------------------------------------------------------------------| 314 314 315 315 IF ( num_sal .EQ. 4 ) THEN … … 318 318 zjj = ( npb(ji) - 1 ) / jpi + 1 319 319 fseqv_1d(ji) = fseqv_1d(ji) + & 320 321 322 320 ( sss_m(zji,zjj) - bulk_sal ) * & 321 rhoic * a_i_b(ji) * & 322 MAX( dh_i_bott(ji) , 0.0 ) / rdt_ice 323 323 END DO 324 324 ELSE … … 327 327 zjj = ( npb(ji) - 1 ) / jpi + 1 328 328 fseqv_1d(ji) = fseqv_1d(ji) + & 329 330 331 329 ( sss_m(zji,zjj) - s_i_new(ji) ) * & 330 rhoic * a_i_b(ji) * & 331 MAX( dh_i_bott(ji) , 0.0 ) / rdt_ice 332 332 END DO ! ji 333 333 ENDIF 334 334 335 !-- End of salinity computations335 !-- End of salinity computations 336 336 END SUBROUTINE lim_thd_sal 337 !==============================================================================337 !============================================================================== 338 338 339 339 SUBROUTINE lim_thd_sal_init … … 352 352 !!------------------------------------------------------------------- 353 353 NAMELIST/namicesal/ num_sal, bulk_sal, sal_G, time_G, sal_F, time_F, & 354 354 s_i_max, s_i_min, s_i_0, s_i_1 355 355 !!------------------------------------------------------------------- 356 356 -
trunk/NEMO/LIM_SRC_3/limtrp.F90
r888 r921 57 57 CONTAINS 58 58 59 SUBROUTINE lim_trp 59 SUBROUTINE lim_trp( kt ) 60 60 !!------------------------------------------------------------------- 61 61 !! *** ROUTINE lim_trp *** … … 75 75 !! 3.0 ! 05-11 (M. Vancoppenolle) Multi-layer sea ice, salinity variations 76 76 !!--------------------------------------------------------------------- 77 INTEGER, INTENT(in) :: kt ! number of iteration 77 78 !! * Local Variables 78 79 INTEGER :: ji, jj, jk, jl, layer, & ! dummy loop indices 79 80 initad ! number of sub-timestep for the advection 80 81 INTEGER :: ji_maxu, ji_maxv, jj_maxu, jj_maxv 81 82 … … 102 103 zs0sm , zs0oi 103 104 104 ! MHE Multilayer heat content105 ! MHE Multilayer heat content 105 106 REAL(wp), DIMENSION(jpi,jpj,jkmax,jpl) :: & ! temporary workspace 106 107 zs0e … … 111 112 112 113 zsm(:,:) = area(:,:) 113 114 IF( ln_limdyn ) THEN 115 WRITE(numout,*) 116 WRITE(numout,*) ' lim_trp : Ice Advection' 117 WRITE(numout,*) ' ~~~~~~~' 118 119 !-----------------------------------------------------------------------------! 120 ! 1) CFL Test 121 !-----------------------------------------------------------------------------! 114 115 IF( ln_limdyn .AND. lwp ) THEN 116 IF( kt == nit000 ) THEN 117 WRITE(numout,*) ' lim_trp : Ice Advection' 118 WRITE(numout,*) ' ~~~~~~~' 119 ENDIF 120 121 !-----------------------------------------------------------------------------! 122 ! 1) CFL Test 123 !-----------------------------------------------------------------------------! 122 124 123 125 !------------------------------------------ 124 126 ! ice velocities at ocean U- and V-points 125 127 !------------------------------------------ 126 128 127 129 ! zvbord factor between 1 and 2 to take into account slip or no-slip boundary conditions. 128 130 zvbord = 1.0 + ( 1.0 - bound ) … … 166 168 167 169 IF ( zcfl > 0.5 .AND. lwp ) & 168 WRITE(numout,*) 'lim_trp : violation of cfl criterion the ',nday,'th day, cfl = ',zcfl169 170 !-----------------------------------------------------------------------------!171 ! 2) Computation of transported fields172 !-----------------------------------------------------------------------------!170 WRITE(numout,*) 'lim_trp : violation of cfl criterion the ',nday,'th day, cfl = ',zcfl 171 172 !-----------------------------------------------------------------------------! 173 ! 2) Computation of transported fields 174 !-----------------------------------------------------------------------------! 173 175 174 176 !------------------------------------------------------ … … 185 187 zs0oi (:,:,jl) = oa_i (:,:,jl) * area(:,:) ! Age content 186 188 187 !----------------------------------188 ! 1.2) Ice and snow heat contents189 !----------------------------------189 !---------------------------------- 190 ! 1.2) Ice and snow heat contents 191 !---------------------------------- 190 192 191 193 zs0c0 (:,:,jl) = e_s(:,:,1,jl) ! Snow heat cont. … … 195 197 END DO 196 198 197 !-----------------------------------------------------------------------------!198 ! 3) Advection of Ice fields199 !-----------------------------------------------------------------------------!199 !-----------------------------------------------------------------------------! 200 ! 3) Advection of Ice fields 201 !-----------------------------------------------------------------------------! 200 202 201 203 ! If ice drift field is too fast, use an appropriate time step for advection. 202 204 initad = 1 + INT( MAX( rzero, SIGN( rone, zcfl-0.5 ) ) ) 203 205 zusnit = 1.0 / REAL( initad ) 204 206 205 207 IF ( MOD( nday , 2 ) == 0) THEN 206 208 DO jk = 1,initad 207 209 !--- ice open water area 208 210 CALL lim_adv_x( zusnit, zui_u, rone , zsm, zs0ow(:,:) , sxopw(:,:) , & 209 210 211 sxxopw(:,:), syopw(:,:) , & 212 syyopw(:,:), sxopw(:,:) ) 211 213 CALL lim_adv_y( zusnit, zvi_v, rzero, zsm, zs0ow(:,:) , sxopw (:,:) , & 212 213 214 sxxopw(:,:), syopw (:,:) , & 215 syyopw(:,:), sxyopw(:,:) ) 214 216 DO jl = 1, jpl 215 217 !--- ice volume --- 216 218 CALL lim_adv_x( zusnit, zui_u, rone , zsm, zs0ice(:,:,jl) , sxice (:,:,jl) , & 217 218 219 sxxice(:,:,jl) , syice (:,:,jl) , & 220 syyice(:,:,jl) , sxyice(:,:,jl) ) 219 221 CALL lim_adv_y( zusnit, zvi_v, rzero, zsm, zs0ice(:,:,jl) , sxice (:,:,jl) , & 220 221 222 sxxice(:,:,jl) , syice (:,:,jl) , & 223 syyice(:,:,jl) , sxyice(:,:,jl) ) 222 224 !--- snow volume --- 223 225 CALL lim_adv_x( zusnit, zui_u, rone , zsm, zs0sn (:,:,jl) , sxsn (:,:,jl) , & 224 225 226 sxxsn (:,:,jl) , sysn (:,:,jl) , & 227 syysn (:,:,jl) , sxysn (:,:,jl) ) 226 228 CALL lim_adv_y( zusnit, zvi_v, rzero, zsm, zs0sn (:,:,jl) , sxsn (:,:,jl) , & 227 228 229 sxxsn (:,:,jl) , sysn (:,:,jl) , & 230 syysn (:,:,jl) , sxysn (:,:,jl) ) 229 231 !--- ice salinity --- 230 232 CALL lim_adv_x( zusnit, zui_u, rone , zsm, zs0sm (:,:,jl) , sxsal (:,:,jl) , & 231 232 233 sxxsal(:,:,jl) , sysal (:,:,jl) , & 234 syysal(:,:,jl) , sxysal(:,:,jl) ) 233 235 CALL lim_adv_y( zusnit, zvi_v, rzero, zsm, zs0sm (:,:,jl) , sxsal (:,:,jl) , & 234 235 236 sxxsal(:,:,jl) , sysal (:,:,jl) , & 237 syysal(:,:,jl) , sxysal(:,:,jl) ) 236 238 !--- ice age --- 237 239 CALL lim_adv_x( zusnit, zui_u, rone , zsm, zs0oi (:,:,jl) , sxage (:,:,jl) , & 238 239 240 sxxage(:,:,jl) , syage (:,:,jl) , & 241 syyage(:,:,jl) , sxyage(:,:,jl) ) 240 242 CALL lim_adv_y( zusnit, zvi_v, rzero, zsm, zs0oi (:,:,jl) , sxage (:,:,jl) , & 241 242 243 sxxage(:,:,jl) , syage (:,:,jl) , & 244 syyage(:,:,jl) , sxyage(:,:,jl) ) 243 245 !--- ice concentrations --- 244 246 CALL lim_adv_x( zusnit, zui_u, rone , zsm, zs0a (:,:,jl) , sxa (:,:,jl) , & 245 246 247 sxxa (:,:,jl) , sya (:,:,jl) , & 248 syya (:,:,jl) , sxya (:,:,jl) ) 247 249 CALL lim_adv_y( zusnit, zvi_v, rzero, zsm, zs0a (:,:,jl) , sxa (:,:,jl) , & 248 249 250 sxxa (:,:,jl) , sya (:,:,jl) , & 251 syya (:,:,jl) , sxya (:,:,jl) ) 250 252 !--- ice / snow thermal energetic contents --- 251 253 CALL lim_adv_x( zusnit, zui_u, rone , zsm, zs0c0 (:,:,jl) , sxc0 (:,:,jl) , & 252 253 254 sxxc0 (:,:,jl) , syc0 (:,:,jl) , & 255 syyc0 (:,:,jl) , sxyc0 (:,:,jl) ) 254 256 CALL lim_adv_y( zusnit, zvi_v, rzero, zsm, zs0c0 (:,:,jl) , sxc0 (:,:,jl) , & 255 256 257 sxxc0 (:,:,jl) , syc0 (:,:,jl) , & 258 syyc0 (:,:,jl) , sxyc0 (:,:,jl) ) 257 259 DO layer = 1, nlay_i 258 260 CALL lim_adv_x( zusnit, zui_u, rone , zsm, & 259 260 261 261 zs0e(:,:,layer,jl) , sxe (:,:,layer,jl) , & 262 sxxe(:,:,layer,jl) , sye (:,:,layer,jl) , & 263 syye(:,:,layer,jl) , sxye(:,:,layer,jl) ) 262 264 CALL lim_adv_y( zusnit, zvi_v, rzero, zsm, & 263 264 265 265 zs0e(:,:,layer,jl) , sxe (:,:,layer,jl) , & 266 sxxe(:,:,layer,jl) , sye (:,:,layer,jl) , & 267 syye(:,:,layer,jl) , sxye(:,:,layer,jl) ) 266 268 END DO 267 269 END DO … … 271 273 !--- ice volume --- 272 274 CALL lim_adv_y( zusnit, zvi_v, rone , zsm, zs0ow (:,:) , sxopw (:,:) , & 273 274 275 sxxopw(:,:) , syopw (:,:) , & 276 syyopw(:,:) , sxyopw(:,:) ) 275 277 CALL lim_adv_x( zusnit, zui_u, rzero, zsm, zs0ow (:,:) , sxopw (:,:) , & 276 277 278 sxxopw(:,:) , syopw (:,:) , & 279 syyopw(:,:) , sxyopw(:,:) ) 278 280 DO jl = 1, jpl 279 281 !--- ice volume --- 280 282 CALL lim_adv_y( zusnit, zvi_v, rone , zsm, zs0ice(:,:,jl) , sxice (:,:,jl) , & 281 282 283 sxxice(:,:,jl) , syice (:,:,jl) , & 284 syyice(:,:,jl) , sxyice(:,:,jl) ) 283 285 CALL lim_adv_x( zusnit, zui_u, rzero, zsm, zs0ice(:,:,jl) , sxice (:,:,jl) , & 284 285 286 sxxice(:,:,jl) , syice (:,:,jl) , & 287 syyice(:,:,jl) , sxyice(:,:,jl) ) 286 288 !--- snow volume --- 287 289 CALL lim_adv_y( zusnit, zvi_v, rone , zsm, zs0sn (:,:,jl) , sxsn (:,:,jl) , & 288 289 290 sxxsn (:,:,jl) , sysn (:,:,jl) , & 291 syysn (:,:,jl) , sxysn (:,:,jl) ) 290 292 CALL lim_adv_x( zusnit, zui_u, rzero, zsm, zs0sn (:,:,jl) , sxsn (:,:,jl) , & 291 292 293 sxxsn (:,:,jl) , sysn (:,:,jl) , & 294 syysn (:,:,jl) , sxysn (:,:,jl) ) 293 295 !--- ice salinity --- 294 296 CALL lim_adv_y( zusnit, zvi_v, rone , zsm, zs0sm (:,:,jl) , sxsal (:,:,jl) , & 295 296 297 sxxsal(:,:,jl) , sysal (:,:,jl) , & 298 syysal(:,:,jl) , sxysal(:,:,jl) ) 297 299 CALL lim_adv_x( zusnit, zui_u, rzero, zsm, zs0sm (:,:,jl) , sxsal (:,:,jl) , & 298 299 300 sxxsal(:,:,jl) , sysal (:,:,jl) , & 301 syysal(:,:,jl) , sxysal(:,:,jl) ) 300 302 !--- ice age --- 301 303 CALL lim_adv_y( zusnit, zvi_v, rone , zsm, zs0oi (:,:,jl) , sxage (:,:,jl) , & 302 303 304 sxxage(:,:,jl) , syage (:,:,jl) , & 305 syyage(:,:,jl) , sxyage(:,:,jl) ) 304 306 CALL lim_adv_x( zusnit, zui_u, rzero, zsm, zs0oi (:,:,jl) , sxage (:,:,jl) , & 305 306 307 sxxage(:,:,jl) , syage (:,:,jl) , & 308 syyage(:,:,jl) , sxyage(:,:,jl) ) 307 309 !--- ice concentration --- 308 310 CALL lim_adv_y( zusnit, zvi_v, rone , zsm, zs0a (:,:,jl) , sxa (:,:,jl) , & 309 310 311 sxxa (:,:,jl) , sya (:,:,jl) , & 312 syya (:,:,jl) , sxya (:,:,jl) ) 311 313 CALL lim_adv_x( zusnit, zui_u, rzero, zsm, zs0a (:,:,jl) , sxa (:,:,jl) , & 312 313 314 sxxa (:,:,jl) , sya (:,:,jl) , & 315 syya (:,:,jl) , sxya (:,:,jl) ) 314 316 !--- ice / snow thermal energetic contents --- 315 317 CALL lim_adv_y( zusnit, zvi_v, rone , zsm, zs0c0 (:,:,jl) , sxc0 (:,:,jl) , & 316 317 318 sxxc0 (:,:,jl) , syc0 (:,:,jl) , & 319 syyc0 (:,:,jl) , sxyc0 (:,:,jl) ) 318 320 CALL lim_adv_x( zusnit, zui_u, rzero, zsm, zs0c0 (:,:,jl) , sxc0 (:,:,jl) , & 319 320 321 sxxc0 (:,:,jl) , syc0 (:,:,jl) , & 322 syyc0 (:,:,jl) , sxyc0 (:,:,jl) ) 321 323 DO layer = 1, nlay_i 322 324 CALL lim_adv_y( zusnit, zvi_v, rone , zsm, zs0e(:,:,layer,jl) , & 323 324 325 sxe (:,:,layer,jl) , sxxe (:,:,layer,jl) , sye (:,:,layer,jl) , & 326 syye (:,:,layer,jl), sxye (:,:,layer,jl) ) 325 327 CALL lim_adv_x( zusnit, zui_u, rzero, zsm, zs0e(:,:,layer,jl) , & 326 327 328 sxe (:,:,layer,jl) , sxxe (:,:,layer,jl) , sye (:,:,layer,jl) , & 329 syye (:,:,layer,jl), sxye (:,:,layer,jl) ) 328 330 END DO 329 331 … … 349 351 END DO 350 352 351 !------------------------------------------------------------------------------!352 ! 4) Diffusion of Ice fields353 !------------------------------------------------------------------------------!354 355 !------------------------------------356 ! 4.1) diffusion of open water area357 !------------------------------------353 !------------------------------------------------------------------------------! 354 ! 4) Diffusion of Ice fields 355 !------------------------------------------------------------------------------! 356 357 !------------------------------------ 358 ! 4.1) diffusion of open water area 359 !------------------------------------ 358 360 359 361 ! Compute total ice fraction … … 364 366 zs0at (ji,jj) = zs0at(ji,jj) + zs0a(ji,jj,jl) ! 365 367 END DO 366 END DO 368 END DO 367 369 END DO 368 370 … … 380 382 CALL lim_hdf( zs0ow (:,:) ) 381 383 382 !----------------------------------------383 ! 4.2) Diffusion of other ice variables384 !----------------------------------------385 DO jl = 1, jpl 386 387 ! Masked eddy diffusivity coefficient at ocean U- and V-points384 !---------------------------------------- 385 ! 4.2) Diffusion of other ice variables 386 !---------------------------------------- 387 DO jl = 1, jpl 388 389 ! Masked eddy diffusivity coefficient at ocean U- and V-points 388 390 DO jj = 1, jpjm1 ! NB: has not to be defined on jpj line and jpi row 389 391 DO ji = 1 , fs_jpim1 ! vector opt. … … 406 408 END DO !jl 407 409 408 !-----------------------------------------409 ! 4.3) Remultiply everything by ice area410 !-----------------------------------------410 !----------------------------------------- 411 ! 4.3) Remultiply everything by ice area 412 !----------------------------------------- 411 413 zs0ow(:,:) = MAX(rzero, zs0ow(:,:) * area(:,:) ) 412 414 DO jl = 1, jpl … … 422 424 END DO ! jl 423 425 424 !------------------------------------------------------------------------------!425 ! 5) Update and limit ice properties after transport426 !------------------------------------------------------------------------------!427 428 !--------------------------------------------------429 ! 5.1) Recover mean values over the grid squares.430 !--------------------------------------------------426 !------------------------------------------------------------------------------! 427 ! 5) Update and limit ice properties after transport 428 !------------------------------------------------------------------------------! 429 430 !-------------------------------------------------- 431 ! 5.1) Recover mean values over the grid squares. 432 !-------------------------------------------------- 431 433 432 434 DO jl = 1, jpl … … 435 437 DO ji = 1, jpi 436 438 zs0e (ji,jj,jk,jl) = & 437 MAX( rzero, zs0e (ji,jj,jk,jl) / area(ji,jj) )439 MAX( rzero, zs0e (ji,jj,jk,jl) / area(ji,jj) ) 438 440 END DO 439 441 END DO … … 446 448 END DO 447 449 END DO 448 450 449 451 zs0at(:,:) = 0.0 450 452 DO jl = 1, jpl … … 462 464 END DO 463 465 464 !---------------------------------------------------------465 ! 5.2) Snow thickness, Ice thickness, Ice concentrations466 !---------------------------------------------------------466 !--------------------------------------------------------- 467 ! 5.2) Snow thickness, Ice thickness, Ice concentrations 468 !--------------------------------------------------------- 467 469 468 470 DO jj = 1, jpj … … 501 503 END DO 502 504 503 !----------------------504 ! 5.3) Ice properties505 !----------------------505 !---------------------- 506 ! 5.3) Ice properties 507 !---------------------- 506 508 507 509 zbigval = 1.0d+13 … … 521 523 ! Ice salinity and age 522 524 zsal = MAX( MIN( (rhoic-rhosn)/rhoic*sss_m(ji,jj) , & 523 524 525 zusvoic * zs0sm(ji,jj,jl) ), s_i_min ) * & 526 v_i(ji,jj,jl) 525 527 IF ( ( num_sal .EQ. 2 ) .OR. ( num_sal .EQ. 4 ) ) & 526 528 smv_i(ji,jj,jl) = zindic*zsal + (1.0-zindic)*0.0 527 529 528 530 zage = MAX( MIN( zbigval, zs0oi(ji,jj,jl) / & 529 530 531 MAX( a_i(ji,jj,jl), epsi16 ) ), 0.0 ) * & 532 a_i(ji,jj,jl) 531 533 oa_i (ji,jj,jl) = zindic*zage 532 534 … … 616 618 WRITE(numout,*) 617 619 ENDIF 618 620 619 621 END SUBROUTINE lim_trp_init 620 622 -
trunk/NEMO/LIM_SRC_3/limupdate.F90
r895 r921 82 82 !! * Local variables 83 83 INTEGER :: & 84 85 84 ji, jj, & ! geographical indices 85 jk, jl, jm ! layer, category and type indices 86 86 INTEGER :: & 87 87 jbnd1, jbnd2 88 88 INTEGER :: & 89 89 i_ice_switch 90 90 91 91 REAL(wp) :: & ! constant values … … 99 99 rone = 1.e0 , & 100 100 zhimax ! maximum thickness tolerated for advection of 101 101 ! in an ice-free cell 102 102 REAL(wp) :: & ! dummy switches and arguments 103 103 zindb, zindsn, zindic, zacrith, & … … 116 116 REAL(wp), DIMENSION(jkmax) :: & 117 117 zthick0, zqm0 ! thickness of the layers and heat contents for 118 118 ! internal melt 119 119 REAL(wp) :: & 120 120 zweight, zesum 121 121 122 122 123 123 !!------------------------------------------------------------------- 124 124 125 WRITE(numout,*) ' lim_update ' 126 WRITE(numout,*) ' ~~~~~~~~~~ ' 127 128 !+++++ [ 129 WRITE(numout,*) ' O) Initial values ' 130 WRITE(numout,*) ' a_i : ', a_i(jiindx, jjindx, 1:jpl) 131 WRITE(numout,*) ' at_i: ', at_i(jiindx,jjindx) 132 WRITE(numout,*) ' v_i : ', v_i(jiindx, jjindx, 1:jpl) 133 WRITE(numout,*) ' v_s : ', v_s(jiindx, jjindx, 1:jpl) 134 WRITE(numout,*) ' smv_i: ', smv_i(jiindx, jjindx, 1:jpl) 135 DO jk = 1, nlay_i 136 WRITE(numout,*) ' e_i : ', e_i(jiindx, jjindx, jk, 1:jpl) 137 END DO 138 !+++++ ] 139 140 !------------------------------------------------------------------------------ 141 ! 1. Update of Global variables | 142 !------------------------------------------------------------------------------ 143 144 !--------------------- 145 ! Ice dynamics 146 !--------------------- 147 148 u_ice(:,:) = u_ice(:,:) + d_u_ice_dyn(:,:) 149 v_ice(:,:) = v_ice(:,:) + d_v_ice_dyn(:,:) 150 151 !----------------------------- 152 ! Update ice and snow volumes 153 !----------------------------- 154 155 DO jl = 1, jpl 156 DO jj = 1, jpj 157 DO ji = 1, jpi 158 159 v_i(ji,jj,jl) = v_i(ji,jj,jl) + d_v_i_trp(ji,jj,jl) & 160 + d_v_i_thd(ji,jj,jl) 161 v_s(ji,jj,jl) = v_s(ji,jj,jl) + d_v_s_trp(ji,jj,jl) & 162 + d_v_s_thd(ji,jj,jl) 163 END DO 164 END DO 165 END DO 166 167 !--------------------------------- 168 ! Classify the pathological cases 169 !--------------------------------- 170 ! (1) v_i (new) > 0; d_v_i_thd + v_i(old) > 0 (easy case) 171 ! (2) v_i (new) > 0; d_v_i_thd + v_i(old) = 0 (total thermodynamic ablation) 172 ! (3) v_i (new) < 0; d_v_i_thd + v_i(old) > 0 (combined total ablation) 173 ! (4) v_i (new) < 0; d_v_i_thd + v_i(old) = 0 (total thermodynamic ablation 174 ! with negative advection, very pathological ) 175 ! (5) v_i (old) = 0; d_v_i_trp > 0 (advection of ice in a free-cell) 176 177 DO jl = 1, jpl 178 DO jj = 1, jpj 179 DO ji = 1, jpi 180 patho_case(ji,jj,jl) = 1 181 IF ( v_i(ji,jj,jl) .GE. 0.0 ) THEN 182 IF ( old_v_i(ji,jj,jl) + d_v_i_thd(ji,jj,jl) .LT. epsi10 ) THEN 183 patho_case(ji,jj,jl) = 2 184 ENDIF 185 ELSE 186 patho_case(ji,jj,jl) = 3 187 IF ( old_v_i(ji,jj,jl) + d_v_i_thd(ji,jj,jl) .LT. epsi10 ) THEN 188 patho_case(ji,jj,jl) = 4 189 ENDIF 190 ENDIF 191 IF ( ( old_v_i(ji,jj,jl) .LE. epsi10 ) .AND. & 192 ( d_v_i_trp(ji,jj,jl) .GT. epsi06 ) ) THEN 193 patho_case(ji,jj,jl) = 5 ! advection of ice in an ice-free 194 ! cell 195 WRITE(numout,*) ' ALERTE patho_case still equal to 5 ' 196 WRITE(numout,*) ' ji , jj : ', ji, jj 197 WRITE(numout,*) ' old_v_i : ', old_v_i(ji,jj,jl) 198 WRITE(numout,*) ' d_v_i_trp : ', d_v_i_trp(ji,jj,jl) 199 200 ENDIF 201 END DO 202 END DO 203 END DO 204 205 !-------------------- 206 ! Excessive ablation 207 !-------------------- 208 209 DO jl = 1, jpl 210 DO jj = 1, jpj 211 DO ji = 1, jpi 212 IF ( ( patho_case(ji,jj,jl) .EQ. 3 ) & 213 .OR. ( patho_case(ji,jj,jl) .EQ. 4 ) ) THEN 214 zviold = old_v_i(ji,jj,jl) 215 zvsold = old_v_s(ji,jj,jl) 216 ! in cases 3 ( combined total ablation ) 217 ! and 4 ( total ablation with negative advection ) 218 ! there is excessive total ablation 219 ! advection is chosen to be prioritary in order to conserve mass. 220 ! dv_i_thd is computed as a residual 221 ! negative energy has to be kept in memory and to be given to the ocean 222 ! equivalent salt flux is given to the ocean 223 ! 224 ! This was the best solution found. Otherwise, mass conservation in advection 225 ! scheme should have been revised, which could have been a big problem 226 ! Martin Vancoppenolle (2006, updated 2007) 227 228 ! is there any ice left ? 229 zindic = MAX( rzero, SIGN( rone, v_i(ji,jj,jl) - epsi10 ) ) 230 !=1 if hi > 1e-3 and 0 if not 231 zdvres = MAX(0.0,-v_i(ji,jj,jl)) !residual volume if too much ice was molten 232 !this quantity is positive 233 v_i(ji,jj,jl) = zindic*v_i(ji,jj,jl) !ice volume cannot be negative 234 !correct thermodynamic ablation 235 d_v_i_thd(ji,jj,jl) = zindic * d_v_i_thd(ji,jj,jl) + & 236 (1.0-zindic) * (-zviold - d_v_i_trp(ji,jj,jl)) 237 ! THIS IS NEW 238 d_a_i_thd(ji,jj,jl) = zindic * d_a_i_thd(ji,jj,jl) + & 239 (1.0-zindic) * (-old_a_i(ji,jj,jl)) 240 241 !residual salt flux if ice is over-molten 242 fsalt_res(ji,jj) = fsalt_res(ji,jj) + ( sss_m(ji,jj) - sm_i(ji,jj,jl) ) * & 243 ( rhoic * zdvres / rdt_ice ) 244 ! fheat_res(ji,jj) = fheat_res(ji,jj) + rhoic * lfus * zdvres / rdt_ice 245 246 ! is there any snow left ? 247 zindsn = MAX( rzero, SIGN( rone, v_s(ji,jj,jl) - epsi10 ) ) 248 zvsold = v_s(ji,jj,jl) 249 zdvres = MAX(0.0,-v_s(ji,jj,jl)) !residual volume if too much ice was molten 250 !this quantity is positive 251 v_s(ji,jj,jl) = zindsn*v_s(ji,jj,jl) !snow volume cannot be negative 252 !correct thermodynamic ablation 253 d_v_s_thd(ji,jj,jl) = zindsn * d_v_s_thd(ji,jj,jl) + & 254 (1.0-zindsn) * (-zvsold - d_v_s_trp(ji,jj,jl)) 255 !unsure correction on salt flux.... maybe future will tell it was not that right 256 257 !residual salt flux if snow is over-molten 258 fsalt_res(ji,jj) = fsalt_res(ji,jj) + sss_m(ji,jj) * & 259 ( rhosn * zdvres / rdt_ice ) 260 !this flux will be positive if snow was over-molten 261 ! fheat_res(ji,jj) = fheat_res(ji,jj) + rhosn * lfus * zdvres / rdt_ice 262 ENDIF 263 END DO !ji 264 END DO !jj 265 END DO !jl 266 267 !+++++ [ 268 DO jj = 1, jpj 269 DO ji = 1, jpi 270 IF ( ABS(fsalt_res(ji,jj)) .GT. 1.0 ) THEN 271 WRITE(numout,*) ' ALERTE 1000 : residual salt flux of -> ', & 272 fsalt_res(ji,jj) 273 WRITE(numout,*) ' ji, jj : ', ji, jj, ' gphit, glamt : ', & 274 gphit(ji,jj), glamt(ji,jj) 275 ENDIF 276 END DO 277 END DO 278 279 WRITE(numout,*) ' 1. Before update of Global variables ' 280 WRITE(numout,*) ' a_i : ', a_i(jiindx, jjindx, 1:jpl) 281 WRITE(numout,*) ' at_i: ', at_i(jiindx,jjindx) 282 WRITE(numout,*) ' v_i : ', v_i(jiindx, jjindx, 1:jpl) 283 WRITE(numout,*) ' v_s : ', v_s(jiindx, jjindx, 1:jpl) 284 WRITE(numout,*) ' smv_i: ', smv_i(jiindx, jjindx, 1:jpl) 285 DO jk = 1, nlay_i 286 WRITE(numout,*) ' e_i : ', e_i(jiindx, jjindx, jk, 1:jpl) 287 END DO 288 !+++++ ] 289 290 !--------------------------------------------- 291 ! Ice concentration and ice heat content 292 !--------------------------------------------- 293 294 a_i (:,:,:) = a_i (:,:,:) + d_a_i_trp(:,:,:) & 295 + d_a_i_thd(:,:,:) 296 CALL lim_var_glo2eqv ! useless, just for debug 297 DO jk = 1, nlay_i 298 WRITE(numout,*) ' t_i : ', t_i(jiindx, jjindx, jk, 1:jpl) 299 END DO 300 e_i(:,:,:,:) = e_i(:,:,:,:) + d_e_i_trp(:,:,:,:) 301 CALL lim_var_glo2eqv ! useless, just for debug 302 WRITE(numout,*) ' After transport update ' 303 DO jk = 1, nlay_i 304 WRITE(numout,*) ' t_i : ', t_i(jiindx, jjindx, jk, 1:jpl) 305 END DO 306 e_i(:,:,:,:) = e_i(:,:,:,:) + d_e_i_thd(:,:,:,:) 307 CALL lim_var_glo2eqv ! useless, just for debug 308 WRITE(numout,*) ' After thermodyn update ' 309 DO jk = 1, nlay_i 310 WRITE(numout,*) ' t_i : ', t_i(jiindx, jjindx, jk, 1:jpl) 311 END DO 312 313 at_i(:,:) = 0.0 314 DO jl = 1, jpl 315 at_i(:,:) = a_i(:,:,jl) + at_i(:,:) 316 END DO 317 318 !+++++ [ 319 WRITE(numout,*) ' 1. After update of Global variables (2) ' 320 WRITE(numout,*) ' a_i : ', a_i(jiindx, jjindx, 1:jpl) 321 WRITE(numout,*) ' at_i: ', at_i(jiindx,jjindx) 322 WRITE(numout,*) ' v_i : ', v_i(jiindx, jjindx, 1:jpl) 323 WRITE(numout,*) ' v_s : ', v_s(jiindx, jjindx, 1:jpl) 324 WRITE(numout,*) ' smv_i: ', smv_i(jiindx, jjindx, 1:jpl) 325 WRITE(numout,*) ' oa_i : ', oa_i(jiindx, jjindx, 1:jpl) 326 WRITE(numout,*) ' e_s : ', e_s(jiindx, jjindx, 1, 1:jpl) 327 DO jk = 1, nlay_i 328 WRITE(numout,*) ' e_i : ', e_i(jiindx, jjindx, jk, 1:jpl) 329 END DO 330 !+++++ ] 331 332 !------------------------------ 333 ! Snow temperature and ice age 334 !------------------------------ 335 336 e_s(:,:,:,:) = e_s(:,:,:,:) + & 337 d_e_s_trp(:,:,:,:) + & 338 d_e_s_thd(:,:,:,:) 339 340 oa_i(:,:,:) = oa_i(:,:,:) + & 341 d_oa_i_trp(:,:,:) + & 342 d_oa_i_thd(:,:,:) 343 344 !-------------- 345 ! Ice salinity 346 !-------------- 347 348 IF ( ( num_sal .EQ. 2 ) .OR. ( num_sal .EQ. 4 ) ) THEN ! general case 349 350 !+++++ 351 WRITE(numout,*) ' Before everything ' 352 WRITE(numout,*) ' smv_i: ', smv_i(jiindx, jjindx, 1:jpl) 353 WRITE(numout,*) ' oa_i: ', oa_i(jiindx, jjindx, 1:jpl) 354 DO jk = 1, nlay_i 355 WRITE(numout,*) ' e_i : ', e_i(jiindx, jjindx, jk, 1:jpl) 356 END DO 357 WRITE(numout,*) ' v_s : ', v_s(jiindx, jjindx, 1:jpl) 358 !+++++ 359 360 smv_i(:,:,:) = smv_i(:,:,:) + & 361 d_smv_i_thd(:,:,:) + & 362 d_smv_i_trp(:,:,:) 363 364 !+++++ 365 WRITE(numout,*) ' After advection ' 366 WRITE(numout,*) ' smv_i: ', smv_i(jiindx, jjindx, 1:jpl) 367 WRITE(numout,*) ' v_s : ', v_s(jiindx, jjindx, 1:jpl) 368 !+++++ 369 370 ENDIF ! num_sal .EQ. 2 371 372 CALL lim_var_glo2eqv 373 374 !-------------------------------------- 375 ! 2. Review of all pathological cases 376 !-------------------------------------- 377 378 zrtt = 173.15 * rone 379 zacrith = 1.0e-6 380 381 !------------------------------------------- 382 ! 2.1) Advection of ice in an ice-free cell 383 !------------------------------------------- 384 ! should be removed since it is treated after dynamics now 385 386 zhimax = 5.0 387 ! first category 388 DO jj = 1, jpj 389 DO ji = 1, jpi 390 !--- the thickness of such an ice is often out of bounds 391 !--- thus we recompute a new area while conserving ice volume 392 zat_i_old = SUM(old_a_i(ji,jj,:)) 393 zindb = MAX( rzero, SIGN( rone, ABS(d_a_i_trp(ji,jj,1)) - epsi10 ) ) 394 IF ( ( ABS(d_v_i_trp(ji,jj,1))/MAX(ABS(d_a_i_trp(ji,jj,1)),epsi10)*zindb.GT.zhimax) & 395 .AND.( ( v_i(ji,jj,1)/MAX(a_i(ji,jj,1),epsi10)*zindb).GT.zhimax ) & 396 .AND.( zat_i_old.LT.zacrith ) ) THEN ! new line 397 z_prescr_hi = hi_max(1) / 2.0 398 a_i(ji,jj,1) = v_i(ji,jj,1) / z_prescr_hi 399 ENDIF 400 END DO 401 END DO 402 403 !+++++ [ 404 WRITE(numout,*) ' 2.1 ' 405 WRITE(numout,*) ' a_i : ', a_i(jiindx, jjindx, 1:jpl) 406 WRITE(numout,*) ' at_i: ', at_i(jiindx,jjindx) 407 WRITE(numout,*) ' v_i : ', v_i(jiindx, jjindx, 1:jpl) 408 WRITE(numout,*) ' v_s : ', v_s(jiindx, jjindx, 1:jpl) 409 WRITE(numout,*) ' smv_i: ', smv_i(jiindx, jjindx, 1:jpl) 410 DO jk = 1, nlay_i 411 WRITE(numout,*) ' e_i : ', e_i(jiindx, jjindx, jk, 1:jpl) 412 END DO 413 !+++++ ] 414 415 !change this 14h44 416 zhimax = 20.0 ! line added up 417 ! change this also 17 aug 418 zhimax = 30.0 ! line added up 419 420 DO jl = 2, jpl 421 jm = ice_types(jl) 422 DO jj = 1, jpj 423 DO ji = 1, jpi 424 zindb = MAX( rzero, SIGN( rone, ABS(d_a_i_trp(ji,jj,jl)) - epsi10 ) ) 425 ! this correction is very tricky... sometimes, advection gets wrong i don't know why 426 ! it makes problems when the advected volume and concentration do not seem to be 427 ! related with each other 428 ! the new thickness is sometimes very big! 429 ! and sometimes d_a_i_trp and d_v_i_trp have different sign 430 ! which of course is plausible 431 ! but fuck! it fucks everything up :) 432 IF ( (ABS(d_v_i_trp(ji,jj,jl))/MAX(ABS(d_a_i_trp(ji,jj,jl)),epsi10)*zindb.GT.zhimax) & 433 .AND.(v_i(ji,jj,jl)/MAX(a_i(ji,jj,jl),epsi10)*zindb).GT.zhimax ) THEN 434 z_prescr_hi = ( hi_max_typ(jl-ice_cat_bounds(jm,1) ,jm) + & 435 hi_max_typ(jl-ice_cat_bounds(jm,1)+1,jm) ) / & 436 2.0 437 a_i(ji,jj,jl) = v_i(ji,jj,jl) / z_prescr_hi 438 ht_i(ji,jj,jl) = v_i(ji,jj,jl) / a_i(ji,jj,jl) 439 ENDIF 440 zat_i_old = SUM(old_a_i(ji,jj,:)) 441 442 END DO ! ji 443 END DO !jj 444 END DO !jl 445 446 !+++++ [ 447 WRITE(numout,*) ' 2.1 initial ' 448 WRITE(numout,*) ' a_i : ', a_i(jiindx, jjindx, 1:jpl) 449 WRITE(numout,*) ' at_i: ', at_i(jiindx,jjindx) 450 WRITE(numout,*) ' v_i : ', v_i(jiindx, jjindx, 1:jpl) 451 WRITE(numout,*) ' v_s : ', v_s(jiindx, jjindx, 1:jpl) 452 WRITE(numout,*) ' smv_i: ', smv_i(jiindx, jjindx, 1:jpl) 453 DO jk = 1, nlay_i 454 WRITE(numout,*) ' e_i : ', e_i(jiindx, jjindx, jk, 1:jpl) 455 END DO 456 !+++++ ] 457 458 at_i(:,:) = 0.0 459 DO jl = 1, jpl 460 at_i(:,:) = a_i(:,:,jl) + at_i(:,:) 461 END DO 462 463 !---------------------------------------------------- 464 ! 2.2) Rebin categories with thickness out of bounds 465 !---------------------------------------------------- 466 !+++++ [ 467 WRITE(numout,*) ' 2.1 before rebinning ' 468 WRITE(numout,*) ' a_i : ', a_i(jiindx, jjindx, 1:jpl) 469 WRITE(numout,*) ' at_i: ', at_i(jiindx,jjindx) 470 WRITE(numout,*) ' v_i : ', v_i(jiindx, jjindx, 1:jpl) 471 WRITE(numout,*) ' smv_i: ', smv_i(jiindx, jjindx, 1:jpl) 472 DO jk = 1, nlay_i 473 WRITE(numout,*) ' e_i : ', e_i(jiindx, jjindx, jk, 1:jpl) 474 END DO 475 WRITE(numout,*) ' v_s : ', v_s(jiindx, jjindx, 1:jpl) 476 !+++++ ] 125 IF( ln_nicep ) THEN 126 WRITE(numout,*) ' lim_update ' 127 WRITE(numout,*) ' ~~~~~~~~~~ ' 128 129 WRITE(numout,*) ' O) Initial values ' 130 WRITE(numout,*) ' a_i : ', a_i(jiindx, jjindx, 1:jpl) 131 WRITE(numout,*) ' at_i: ', at_i(jiindx,jjindx) 132 WRITE(numout,*) ' v_i : ', v_i(jiindx, jjindx, 1:jpl) 133 WRITE(numout,*) ' v_s : ', v_s(jiindx, jjindx, 1:jpl) 134 WRITE(numout,*) ' smv_i: ', smv_i(jiindx, jjindx, 1:jpl) 135 DO jk = 1, nlay_i 136 WRITE(numout,*) ' e_i : ', e_i(jiindx, jjindx, jk, 1:jpl) 137 END DO 138 ENDIF 139 140 !------------------------------------------------------------------------------ 141 ! 1. Update of Global variables | 142 !------------------------------------------------------------------------------ 143 144 !--------------------- 145 ! Ice dynamics 146 !--------------------- 147 148 u_ice(:,:) = u_ice(:,:) + d_u_ice_dyn(:,:) 149 v_ice(:,:) = v_ice(:,:) + d_v_ice_dyn(:,:) 150 151 !----------------------------- 152 ! Update ice and snow volumes 153 !----------------------------- 154 155 DO jl = 1, jpl 156 DO jj = 1, jpj 157 DO ji = 1, jpi 158 159 v_i(ji,jj,jl) = v_i(ji,jj,jl) + d_v_i_trp(ji,jj,jl) & 160 + d_v_i_thd(ji,jj,jl) 161 v_s(ji,jj,jl) = v_s(ji,jj,jl) + d_v_s_trp(ji,jj,jl) & 162 + d_v_s_thd(ji,jj,jl) 163 END DO 164 END DO 165 END DO 166 167 !--------------------------------- 168 ! Classify the pathological cases 169 !--------------------------------- 170 ! (1) v_i (new) > 0; d_v_i_thd + v_i(old) > 0 (easy case) 171 ! (2) v_i (new) > 0; d_v_i_thd + v_i(old) = 0 (total thermodynamic ablation) 172 ! (3) v_i (new) < 0; d_v_i_thd + v_i(old) > 0 (combined total ablation) 173 ! (4) v_i (new) < 0; d_v_i_thd + v_i(old) = 0 (total thermodynamic ablation 174 ! with negative advection, very pathological ) 175 ! (5) v_i (old) = 0; d_v_i_trp > 0 (advection of ice in a free-cell) 176 177 DO jl = 1, jpl 178 DO jj = 1, jpj 179 DO ji = 1, jpi 180 patho_case(ji,jj,jl) = 1 181 IF ( v_i(ji,jj,jl) .GE. 0.0 ) THEN 182 IF ( old_v_i(ji,jj,jl) + d_v_i_thd(ji,jj,jl) .LT. epsi10 ) THEN 183 patho_case(ji,jj,jl) = 2 184 ENDIF 185 ELSE 186 patho_case(ji,jj,jl) = 3 187 IF ( old_v_i(ji,jj,jl) + d_v_i_thd(ji,jj,jl) .LT. epsi10 ) THEN 188 patho_case(ji,jj,jl) = 4 189 ENDIF 190 ENDIF 191 IF ( ( old_v_i(ji,jj,jl) .LE. epsi10 ) .AND. & 192 ( d_v_i_trp(ji,jj,jl) .GT. epsi06 ) ) THEN 193 patho_case(ji,jj,jl) = 5 ! advection of ice in an ice-free 194 ! cell 195 IF( ln_nicep ) THEN 196 WRITE(numout,*) ' ALERTE patho_case still equal to 5 ' 197 WRITE(numout,*) ' ji , jj : ', ji, jj 198 WRITE(numout,*) ' old_v_i : ', old_v_i(ji,jj,jl) 199 WRITE(numout,*) ' d_v_i_trp : ', d_v_i_trp(ji,jj,jl) 200 ENDIF 201 202 ENDIF 203 END DO 204 END DO 205 END DO 206 207 !-------------------- 208 ! Excessive ablation 209 !-------------------- 210 211 DO jl = 1, jpl 212 DO jj = 1, jpj 213 DO ji = 1, jpi 214 IF ( ( patho_case(ji,jj,jl) .EQ. 3 ) & 215 .OR. ( patho_case(ji,jj,jl) .EQ. 4 ) ) THEN 216 zviold = old_v_i(ji,jj,jl) 217 zvsold = old_v_s(ji,jj,jl) 218 ! in cases 3 ( combined total ablation ) 219 ! and 4 ( total ablation with negative advection ) 220 ! there is excessive total ablation 221 ! advection is chosen to be prioritary in order to conserve mass. 222 ! dv_i_thd is computed as a residual 223 ! negative energy has to be kept in memory and to be given to the ocean 224 ! equivalent salt flux is given to the ocean 225 ! 226 ! This was the best solution found. Otherwise, mass conservation in advection 227 ! scheme should have been revised, which could have been a big problem 228 ! Martin Vancoppenolle (2006, updated 2007) 229 230 ! is there any ice left ? 231 zindic = MAX( rzero, SIGN( rone, v_i(ji,jj,jl) - epsi10 ) ) 232 !=1 if hi > 1e-3 and 0 if not 233 zdvres = MAX(0.0,-v_i(ji,jj,jl)) !residual volume if too much ice was molten 234 !this quantity is positive 235 v_i(ji,jj,jl) = zindic*v_i(ji,jj,jl) !ice volume cannot be negative 236 !correct thermodynamic ablation 237 d_v_i_thd(ji,jj,jl) = zindic * d_v_i_thd(ji,jj,jl) + & 238 (1.0-zindic) * (-zviold - d_v_i_trp(ji,jj,jl)) 239 ! THIS IS NEW 240 d_a_i_thd(ji,jj,jl) = zindic * d_a_i_thd(ji,jj,jl) + & 241 (1.0-zindic) * (-old_a_i(ji,jj,jl)) 242 243 !residual salt flux if ice is over-molten 244 fsalt_res(ji,jj) = fsalt_res(ji,jj) + ( sss_m(ji,jj) - sm_i(ji,jj,jl) ) * & 245 ( rhoic * zdvres / rdt_ice ) 246 ! fheat_res(ji,jj) = fheat_res(ji,jj) + rhoic * lfus * zdvres / rdt_ice 247 248 ! is there any snow left ? 249 zindsn = MAX( rzero, SIGN( rone, v_s(ji,jj,jl) - epsi10 ) ) 250 zvsold = v_s(ji,jj,jl) 251 zdvres = MAX(0.0,-v_s(ji,jj,jl)) !residual volume if too much ice was molten 252 !this quantity is positive 253 v_s(ji,jj,jl) = zindsn*v_s(ji,jj,jl) !snow volume cannot be negative 254 !correct thermodynamic ablation 255 d_v_s_thd(ji,jj,jl) = zindsn * d_v_s_thd(ji,jj,jl) + & 256 (1.0-zindsn) * (-zvsold - d_v_s_trp(ji,jj,jl)) 257 !unsure correction on salt flux.... maybe future will tell it was not that right 258 259 !residual salt flux if snow is over-molten 260 fsalt_res(ji,jj) = fsalt_res(ji,jj) + sss_m(ji,jj) * & 261 ( rhosn * zdvres / rdt_ice ) 262 !this flux will be positive if snow was over-molten 263 ! fheat_res(ji,jj) = fheat_res(ji,jj) + rhosn * lfus * zdvres / rdt_ice 264 ENDIF 265 END DO !ji 266 END DO !jj 267 END DO !jl 268 269 IF( ln_nicep ) THEN 270 DO jj = 1, jpj 271 DO ji = 1, jpi 272 IF ( ABS(fsalt_res(ji,jj)) .GT. 1.0 ) THEN 273 WRITE(numout,*) ' ALERTE 1000 : residual salt flux of -> ', & 274 fsalt_res(ji,jj) 275 WRITE(numout,*) ' ji, jj : ', ji, jj, ' gphit, glamt : ', & 276 gphit(ji,jj), glamt(ji,jj) 277 ENDIF 278 END DO 279 END DO 280 281 WRITE(numout,*) ' 1. Before update of Global variables ' 282 WRITE(numout,*) ' a_i : ', a_i(jiindx, jjindx, 1:jpl) 283 WRITE(numout,*) ' at_i: ', at_i(jiindx,jjindx) 284 WRITE(numout,*) ' v_i : ', v_i(jiindx, jjindx, 1:jpl) 285 WRITE(numout,*) ' v_s : ', v_s(jiindx, jjindx, 1:jpl) 286 WRITE(numout,*) ' smv_i: ', smv_i(jiindx, jjindx, 1:jpl) 287 DO jk = 1, nlay_i 288 WRITE(numout,*) ' e_i : ', e_i(jiindx, jjindx, jk, 1:jpl) 289 END DO 290 ENDIF 291 292 !--------------------------------------------- 293 ! Ice concentration and ice heat content 294 !--------------------------------------------- 295 296 a_i (:,:,:) = a_i (:,:,:) + d_a_i_trp(:,:,:) & 297 + d_a_i_thd(:,:,:) 298 CALL lim_var_glo2eqv ! useless, just for debug 299 DO jk = 1, nlay_i 300 WRITE(numout,*) ' t_i : ', t_i(jiindx, jjindx, jk, 1:jpl) 301 END DO 302 e_i(:,:,:,:) = e_i(:,:,:,:) + d_e_i_trp(:,:,:,:) 303 CALL lim_var_glo2eqv ! useless, just for debug 304 WRITE(numout,*) ' After transport update ' 305 DO jk = 1, nlay_i 306 WRITE(numout,*) ' t_i : ', t_i(jiindx, jjindx, jk, 1:jpl) 307 END DO 308 e_i(:,:,:,:) = e_i(:,:,:,:) + d_e_i_thd(:,:,:,:) 309 CALL lim_var_glo2eqv ! useless, just for debug 310 WRITE(numout,*) ' After thermodyn update ' 311 DO jk = 1, nlay_i 312 WRITE(numout,*) ' t_i : ', t_i(jiindx, jjindx, jk, 1:jpl) 313 END DO 314 315 at_i(:,:) = 0.0 316 DO jl = 1, jpl 317 at_i(:,:) = a_i(:,:,jl) + at_i(:,:) 318 END DO 319 320 IF( ln_nicep ) THEN 321 WRITE(numout,*) ' 1. After update of Global variables (2) ' 322 WRITE(numout,*) ' a_i : ', a_i(jiindx, jjindx, 1:jpl) 323 WRITE(numout,*) ' at_i: ', at_i(jiindx,jjindx) 324 WRITE(numout,*) ' v_i : ', v_i(jiindx, jjindx, 1:jpl) 325 WRITE(numout,*) ' v_s : ', v_s(jiindx, jjindx, 1:jpl) 326 WRITE(numout,*) ' smv_i: ', smv_i(jiindx, jjindx, 1:jpl) 327 WRITE(numout,*) ' oa_i : ', oa_i(jiindx, jjindx, 1:jpl) 328 WRITE(numout,*) ' e_s : ', e_s(jiindx, jjindx, 1, 1:jpl) 329 DO jk = 1, nlay_i 330 WRITE(numout,*) ' e_i : ', e_i(jiindx, jjindx, jk, 1:jpl) 331 END DO 332 ENDIF 333 334 !------------------------------ 335 ! Snow temperature and ice age 336 !------------------------------ 337 338 e_s(:,:,:,:) = e_s(:,:,:,:) + & 339 d_e_s_trp(:,:,:,:) + & 340 d_e_s_thd(:,:,:,:) 341 342 oa_i(:,:,:) = oa_i(:,:,:) + & 343 d_oa_i_trp(:,:,:) + & 344 d_oa_i_thd(:,:,:) 345 346 !-------------- 347 ! Ice salinity 348 !-------------- 349 350 IF ( ( num_sal .EQ. 2 ) .OR. ( num_sal .EQ. 4 ) ) THEN ! general case 351 352 IF( ln_nicep ) THEN 353 WRITE(numout,*) ' Before everything ' 354 WRITE(numout,*) ' smv_i: ', smv_i(jiindx, jjindx, 1:jpl) 355 WRITE(numout,*) ' oa_i: ', oa_i(jiindx, jjindx, 1:jpl) 356 DO jk = 1, nlay_i 357 WRITE(numout,*) ' e_i : ', e_i(jiindx, jjindx, jk, 1:jpl) 358 END DO 359 WRITE(numout,*) ' v_s : ', v_s(jiindx, jjindx, 1:jpl) 360 ENDIF 361 362 smv_i(:,:,:) = smv_i(:,:,:) + & 363 d_smv_i_thd(:,:,:) + & 364 d_smv_i_trp(:,:,:) 365 366 IF( ln_nicep ) THEN 367 WRITE(numout,*) ' After advection ' 368 WRITE(numout,*) ' smv_i: ', smv_i(jiindx, jjindx, 1:jpl) 369 WRITE(numout,*) ' v_s : ', v_s(jiindx, jjindx, 1:jpl) 370 ENDIF 371 372 ENDIF ! num_sal .EQ. 2 373 374 CALL lim_var_glo2eqv 375 376 !-------------------------------------- 377 ! 2. Review of all pathological cases 378 !-------------------------------------- 379 380 zrtt = 173.15 * rone 381 zacrith = 1.0e-6 382 383 !------------------------------------------- 384 ! 2.1) Advection of ice in an ice-free cell 385 !------------------------------------------- 386 ! should be removed since it is treated after dynamics now 387 388 zhimax = 5.0 389 ! first category 390 DO jj = 1, jpj 391 DO ji = 1, jpi 392 !--- the thickness of such an ice is often out of bounds 393 !--- thus we recompute a new area while conserving ice volume 394 zat_i_old = SUM(old_a_i(ji,jj,:)) 395 zindb = MAX( rzero, SIGN( rone, ABS(d_a_i_trp(ji,jj,1)) - epsi10 ) ) 396 IF ( ( ABS(d_v_i_trp(ji,jj,1))/MAX(ABS(d_a_i_trp(ji,jj,1)),epsi10)*zindb.GT.zhimax) & 397 .AND.( ( v_i(ji,jj,1)/MAX(a_i(ji,jj,1),epsi10)*zindb).GT.zhimax ) & 398 .AND.( zat_i_old.LT.zacrith ) ) THEN ! new line 399 z_prescr_hi = hi_max(1) / 2.0 400 a_i(ji,jj,1) = v_i(ji,jj,1) / z_prescr_hi 401 ENDIF 402 END DO 403 END DO 404 405 IF( ln_nicep ) THEN 406 WRITE(numout,*) ' 2.1 ' 407 WRITE(numout,*) ' a_i : ', a_i(jiindx, jjindx, 1:jpl) 408 WRITE(numout,*) ' at_i: ', at_i(jiindx,jjindx) 409 WRITE(numout,*) ' v_i : ', v_i(jiindx, jjindx, 1:jpl) 410 WRITE(numout,*) ' v_s : ', v_s(jiindx, jjindx, 1:jpl) 411 WRITE(numout,*) ' smv_i: ', smv_i(jiindx, jjindx, 1:jpl) 412 DO jk = 1, nlay_i 413 WRITE(numout,*) ' e_i : ', e_i(jiindx, jjindx, jk, 1:jpl) 414 END DO 415 ENDIF 416 417 !change this 14h44 418 zhimax = 20.0 ! line added up 419 ! change this also 17 aug 420 zhimax = 30.0 ! line added up 421 422 DO jl = 2, jpl 423 jm = ice_types(jl) 424 DO jj = 1, jpj 425 DO ji = 1, jpi 426 zindb = MAX( rzero, SIGN( rone, ABS(d_a_i_trp(ji,jj,jl)) - epsi10 ) ) 427 ! this correction is very tricky... sometimes, advection gets wrong i don't know why 428 ! it makes problems when the advected volume and concentration do not seem to be 429 ! related with each other 430 ! the new thickness is sometimes very big! 431 ! and sometimes d_a_i_trp and d_v_i_trp have different sign 432 ! which of course is plausible 433 ! but fuck! it fucks everything up :) 434 IF ( (ABS(d_v_i_trp(ji,jj,jl))/MAX(ABS(d_a_i_trp(ji,jj,jl)),epsi10)*zindb.GT.zhimax) & 435 .AND.(v_i(ji,jj,jl)/MAX(a_i(ji,jj,jl),epsi10)*zindb).GT.zhimax ) THEN 436 z_prescr_hi = ( hi_max_typ(jl-ice_cat_bounds(jm,1) ,jm) + & 437 hi_max_typ(jl-ice_cat_bounds(jm,1)+1,jm) ) / & 438 2.0 439 a_i(ji,jj,jl) = v_i(ji,jj,jl) / z_prescr_hi 440 ht_i(ji,jj,jl) = v_i(ji,jj,jl) / a_i(ji,jj,jl) 441 ENDIF 442 zat_i_old = SUM(old_a_i(ji,jj,:)) 443 444 END DO ! ji 445 END DO !jj 446 END DO !jl 447 448 IF( ln_nicep ) THEN 449 WRITE(numout,*) ' 2.1 initial ' 450 WRITE(numout,*) ' a_i : ', a_i(jiindx, jjindx, 1:jpl) 451 WRITE(numout,*) ' at_i: ', at_i(jiindx,jjindx) 452 WRITE(numout,*) ' v_i : ', v_i(jiindx, jjindx, 1:jpl) 453 WRITE(numout,*) ' v_s : ', v_s(jiindx, jjindx, 1:jpl) 454 WRITE(numout,*) ' smv_i: ', smv_i(jiindx, jjindx, 1:jpl) 455 DO jk = 1, nlay_i 456 WRITE(numout,*) ' e_i : ', e_i(jiindx, jjindx, jk, 1:jpl) 457 END DO 458 ENDIF 459 460 at_i(:,:) = 0.0 461 DO jl = 1, jpl 462 at_i(:,:) = a_i(:,:,jl) + at_i(:,:) 463 END DO 464 465 !---------------------------------------------------- 466 ! 2.2) Rebin categories with thickness out of bounds 467 !---------------------------------------------------- 468 IF( ln_nicep ) THEN 469 WRITE(numout,*) ' 2.1 before rebinning ' 470 WRITE(numout,*) ' a_i : ', a_i(jiindx, jjindx, 1:jpl) 471 WRITE(numout,*) ' at_i: ', at_i(jiindx,jjindx) 472 WRITE(numout,*) ' v_i : ', v_i(jiindx, jjindx, 1:jpl) 473 WRITE(numout,*) ' smv_i: ', smv_i(jiindx, jjindx, 1:jpl) 474 DO jk = 1, nlay_i 475 WRITE(numout,*) ' e_i : ', e_i(jiindx, jjindx, jk, 1:jpl) 476 END DO 477 WRITE(numout,*) ' v_s : ', v_s(jiindx, jjindx, 1:jpl) 478 ENDIF 477 479 478 480 DO jm = 1, jpm … … 483 485 484 486 485 !+++++ [ 486 WRITE(numout,*) ' 2.1 after rebinning'487 WRITE(numout,*) ' a_i : ', a_i(jiindx, jjindx, 1:jpl)488 WRITE(numout,*) ' at_i: ', at_i(jiindx,jjindx)489 WRITE(numout,*) ' v_i : ', v_i(jiindx, jjindx, 1:jpl)490 WRITE(numout,*) ' smv_i: ', smv_i(jiindx, jjindx, 1:jpl)491 DO jk = 1, nlay_i492 WRITE(numout,*) ' e_i : ', e_i(jiindx, jjindx, jk, 1:jpl)493 WRITE(numout,*) ' t_i : ', t_i(jiindx, jjindx, jk, 1:jpl)494 END DO495 WRITE(numout,*) ' v_s : ', v_s(jiindx, jjindx, 1:jpl)496 !+++++ ] 497 498 at_i(:,:) = 0.0499 DO jl = 1, jpl500 at_i(:,:) = a_i(:,:,jl) + at_i(:,:)501 END DO502 503 !---------------------------------504 ! 2.3) Melt of an internal layer505 !---------------------------------506 internal_melt(:,:,:) = .false.507 508 DO jl = 1, jpl509 DO jk = 1, nlay_i510 DO jj = 1, jpj511 DO ji = 1, jpi512 ztmelts = - tmut * s_i(ji,jj,jk,jl) + rtt513 IF ( ( ( e_i(ji,jj,jk,jl) .LE. 0.0 ) .OR. &514 515 516 517 ! WRITE(numout,*) ' Internal layer melt : '518 ! WRITE(numout,*) ' ji, jj, jk, jl : ', ji,jj,jk,jl519 ! WRITE(numout,*) ' e_i : ', e_i(ji,jj,jk,jl)520 ! WRITE(numout,*) ' v_i : ', v_i(ji,jj,jl)487 IF( ln_nicep ) THEN 488 WRITE(numout,*) ' 2.1 after rebinning' 489 WRITE(numout,*) ' a_i : ', a_i(jiindx, jjindx, 1:jpl) 490 WRITE(numout,*) ' at_i: ', at_i(jiindx,jjindx) 491 WRITE(numout,*) ' v_i : ', v_i(jiindx, jjindx, 1:jpl) 492 WRITE(numout,*) ' smv_i: ', smv_i(jiindx, jjindx, 1:jpl) 493 DO jk = 1, nlay_i 494 WRITE(numout,*) ' e_i : ', e_i(jiindx, jjindx, jk, 1:jpl) 495 WRITE(numout,*) ' t_i : ', t_i(jiindx, jjindx, jk, 1:jpl) 496 END DO 497 WRITE(numout,*) ' v_s : ', v_s(jiindx, jjindx, 1:jpl) 498 ENDIF 499 500 at_i(:,:) = 0.0 501 DO jl = 1, jpl 502 at_i(:,:) = a_i(:,:,jl) + at_i(:,:) 503 END DO 504 505 !--------------------------------- 506 ! 2.3) Melt of an internal layer 507 !--------------------------------- 508 internal_melt(:,:,:) = .false. 509 510 DO jl = 1, jpl 511 DO jk = 1, nlay_i 512 DO jj = 1, jpj 513 DO ji = 1, jpi 514 ztmelts = - tmut * s_i(ji,jj,jk,jl) + rtt 515 IF ( ( ( e_i(ji,jj,jk,jl) .LE. 0.0 ) .OR. & 516 ( t_i(ji,jj,jk,jl) .GE. ztmelts ) ) .AND. & 517 ( v_i(ji,jj,jl) .GT. 0.0 ) .AND. & 518 ( a_i(ji,jj,jl) .GT. 0.0 ) ) THEN 519 ! WRITE(numout,*) ' Internal layer melt : ' 520 ! WRITE(numout,*) ' ji, jj, jk, jl : ', ji,jj,jk,jl 521 ! WRITE(numout,*) ' e_i : ', e_i(ji,jj,jk,jl) 522 ! WRITE(numout,*) ' v_i : ', v_i(ji,jj,jl) 521 523 internal_melt(ji,jj,jl) = .true. 522 ENDIF523 END DO ! ji524 END DO ! jj525 END DO !jk526 END DO !jl527 528 DO jl = 1, jpl529 DO jj = 1, jpj530 DO ji = 1, jpi531 IF ( internal_melt(ji,jj,jl) ) THEN532 ! initial ice thickness533 !-----------------------534 ht_i(ji,jj,jl) = v_i(ji,jj,jl) / a_i(ji,jj,jl)535 ! WRITE(numout,*) ' ji,jj,jl : ', ji,jj,jl536 ! WRITE(numout,*) ' old ht_i: ', ht_i(ji,jj,jl)537 ! WRITE(numout,*) ' Enthalpy at the beg : ', e_i(ji,jj,1:nlay_i,jl)538 ! WRITE(numout,*) ' smv_i : ', smv_i(ji,jj,jl)539 540 ! reduce ice thickness541 !-----------------------542 ind_im = 0543 zesum = 0.0544 DO jk = 1, nlay_i545 ztmelts = - tmut * s_i(ji,jj,jk,jl) + rtt546 IF ( ( e_i(ji,jj,jk,jl) .LE. 0.0 ) .OR. &547 ( t_i(ji,jj,jk,jl) .GE. ztmelts ) ) &548 ind_im = ind_im + 1549 zesum = zesum + e_i(ji,jj,jk,jl)550 END DO551 IF (ind_im .LT.nlay_i ) smv_i(ji,jj,jl)= smv_i(ji,jj,jl) / ht_i(ji,jj,jl) * &552 553 ht_i(ji,jj,jl) = ht_i(ji,jj,jl) - ind_im*ht_i(ji,jj,jl) / nlay_i554 v_i(ji,jj,jl) = ht_i(ji,jj,jl) * a_i(ji,jj,jl)555 556 ! WRITE(numout,*) ' ind_im : ', ind_im557 ! WRITE(numout,*) ' new ht_i: ', ht_i(ji,jj,jl)558 ! WRITE(numout,*) ' smv_i : ', smv_i(ji,jj,jl)559 ! WRITE(numout,*) ' zesum : ', zesum560 561 ! redistribute heat562 !-----------------------563 ! old thicknesses and enthalpies564 ind_im = 0565 DO jk = 1, nlay_i566 ztmelts = - tmut * s_i(ji,jj,jk,jl) + rtt567 IF ( ( e_i(ji,jj,jk,jl) .GT. 0.0 ) .AND. &568 ( t_i(ji,jj,jk,jl) .LT. ztmelts ) ) THEN569 ind_im = ind_im + 1570 zthick0(ind_im) = ht_i(ji,jj,jl) * ind_im / nlay_i571 zqm0 (ind_im) = MAX( e_i(ji,jj,jk,jl) , 0.0 )572 ENDIF573 END DO574 575 ! WRITE(numout,*) ' Old thickness, enthalpy '576 ! WRITE(numout,*) ' Number of layer : ind_im ', ind_im577 ! WRITE(numout,*) ' zthick0 : ', zthick0(1:ind_im)578 ! WRITE(numout,*) ' zqm0 : ', zqm0(1:ind_im)579 580 ! Redistributing energy on the new grid581 IF ( ind_im .GT. 0 ) THEN582 583 DO jk = 1, nlay_i584 e_i(ji,jj,jk,jl) = 0.0585 DO layer = 1, ind_im586 zweight = MAX ( &587 MIN( ht_i(ji,jj,jl) * layer / ind_im , ht_i(ji,jj,jl) * jk / nlay_i ) - &588 MAX( ht_i(ji,jj,jl) * (layer-1) / ind_im , ht_i(ji,jj,jl) * (jk-1) / nlay_i ) , 0.0 ) &589 590 591 e_i(ji,jj,jk,jl) = e_i(ji,jj,jk,jl) + zweight*zqm0(layer)592 END DO !layer593 END DO ! jk594 595 zesum = 0.0596 DO jk = 1, nlay_i597 zesum = zesum + e_i(ji,jj,jk,jl)598 END DO599 600 ! WRITE(numout,*) ' Enthalpy at the end : ', e_i(ji,jj,1:nlay_i,jl)601 ! WRITE(numout,*) ' Volume at the end : ', v_i(ji,jj,jl)602 ! WRITE(numout,*) ' zesum : ', zesum603 604 ELSE ! ind_im .EQ. 0, total melt605 e_i(ji,jj,jk,jl) = 0.0606 ENDIF607 608 ENDIF ! internal_melt609 610 END DO ! ji611 END DO !jj612 END DO !jl613 !+++++ [ 614 WRITE(numout,*) ' 2.3 after melt of an internal ice layer '615 WRITE(numout,*) ' a_i : ', a_i(jiindx, jjindx, 1:jpl)616 WRITE(numout,*) ' at_i: ', at_i(jiindx,jjindx)617 WRITE(numout,*) ' v_i : ', v_i(jiindx, jjindx, 1:jpl)618 WRITE(numout,*) ' smv_i: ', smv_i(jiindx, jjindx, 1:jpl)619 DO jk = 1, nlay_i620 WRITE(numout,*) ' e_i : ', e_i(jiindx, jjindx, jk, 1:jpl)621 WRITE(numout,*) ' t_i : ', t_i(jiindx, jjindx, jk, 1:jpl)622 END DO623 WRITE(numout,*) ' v_s : ', v_s(jiindx, jjindx, 1:jpl)624 !+++++ ] 625 626 internal_melt(:,:,:) = .false.627 628 ! Melt of snow629 !--------------630 DO jl = 1, jpl631 DO jj = 1, jpj632 DO ji = 1, jpi633 ! snow energy of melting634 ze_s = e_s(ji,jj,1,jl) * unit_fac / area(ji,jj) / &635 MAX( v_s(ji,jj,jl), 1.0e-6 ) ! snow energy of melting636 637 ! If snow energy of melting smaller then Lf638 ! Then all snow melts and meltwater, heat go to the ocean639 IF ( ze_s .LE. rhosn * lfus ) internal_melt(ji,jj,jl) = .true.640 641 !++++++642 IF ( (ji.eq.jiindx) .AND. (jj.eq.jjindx) ) THEN643 WRITE(numout,*) ' jl : ', jl644 WRITE(numout,*) ' ze_s : ', ze_s645 WRITE(numout,*) ' v_s : ', v_s(ji,jj,jl)646 WRITE(numout,*) ' rhosn : ', rhosn647 WRITE(numout,*) ' rhosn : ', lfus648 WRITE(numout,*) ' area : ', area(ji,jj)649 WRITE(numout,*) ' rhosn * lfus : ', rhosn * lfus650 WRITE(numout,*) ' internal_melt : ', internal_melt(ji,jj,jl)651 ENDIF652 !++++++653 654 END DO655 END DO656 END DO657 658 DO jl = 1, jpl659 DO jj = 1, jpj660 DO ji = 1, jpi661 IF ( internal_melt(ji,jj,jl) ) THEN524 ENDIF 525 END DO ! ji 526 END DO ! jj 527 END DO !jk 528 END DO !jl 529 530 DO jl = 1, jpl 531 DO jj = 1, jpj 532 DO ji = 1, jpi 533 IF ( internal_melt(ji,jj,jl) ) THEN 534 ! initial ice thickness 535 !----------------------- 536 ht_i(ji,jj,jl) = v_i(ji,jj,jl) / a_i(ji,jj,jl) 537 ! WRITE(numout,*) ' ji,jj,jl : ', ji,jj,jl 538 ! WRITE(numout,*) ' old ht_i: ', ht_i(ji,jj,jl) 539 ! WRITE(numout,*) ' Enthalpy at the beg : ', e_i(ji,jj,1:nlay_i,jl) 540 ! WRITE(numout,*) ' smv_i : ', smv_i(ji,jj,jl) 541 542 ! reduce ice thickness 543 !----------------------- 544 ind_im = 0 545 zesum = 0.0 546 DO jk = 1, nlay_i 547 ztmelts = - tmut * s_i(ji,jj,jk,jl) + rtt 548 IF ( ( e_i(ji,jj,jk,jl) .LE. 0.0 ) .OR. & 549 ( t_i(ji,jj,jk,jl) .GE. ztmelts ) ) & 550 ind_im = ind_im + 1 551 zesum = zesum + e_i(ji,jj,jk,jl) 552 END DO 553 IF (ind_im .LT.nlay_i ) smv_i(ji,jj,jl)= smv_i(ji,jj,jl) / ht_i(ji,jj,jl) * & 554 ( ht_i(ji,jj,jl) - ind_im*ht_i(ji,jj,jl) / nlay_i ) 555 ht_i(ji,jj,jl) = ht_i(ji,jj,jl) - ind_im*ht_i(ji,jj,jl) / nlay_i 556 v_i(ji,jj,jl) = ht_i(ji,jj,jl) * a_i(ji,jj,jl) 557 558 ! WRITE(numout,*) ' ind_im : ', ind_im 559 ! WRITE(numout,*) ' new ht_i: ', ht_i(ji,jj,jl) 560 ! WRITE(numout,*) ' smv_i : ', smv_i(ji,jj,jl) 561 ! WRITE(numout,*) ' zesum : ', zesum 562 563 ! redistribute heat 564 !----------------------- 565 ! old thicknesses and enthalpies 566 ind_im = 0 567 DO jk = 1, nlay_i 568 ztmelts = - tmut * s_i(ji,jj,jk,jl) + rtt 569 IF ( ( e_i(ji,jj,jk,jl) .GT. 0.0 ) .AND. & 570 ( t_i(ji,jj,jk,jl) .LT. ztmelts ) ) THEN 571 ind_im = ind_im + 1 572 zthick0(ind_im) = ht_i(ji,jj,jl) * ind_im / nlay_i 573 zqm0 (ind_im) = MAX( e_i(ji,jj,jk,jl) , 0.0 ) 574 ENDIF 575 END DO 576 577 ! WRITE(numout,*) ' Old thickness, enthalpy ' 578 ! WRITE(numout,*) ' Number of layer : ind_im ', ind_im 579 ! WRITE(numout,*) ' zthick0 : ', zthick0(1:ind_im) 580 ! WRITE(numout,*) ' zqm0 : ', zqm0(1:ind_im) 581 582 ! Redistributing energy on the new grid 583 IF ( ind_im .GT. 0 ) THEN 584 585 DO jk = 1, nlay_i 586 e_i(ji,jj,jk,jl) = 0.0 587 DO layer = 1, ind_im 588 zweight = MAX ( & 589 MIN( ht_i(ji,jj,jl) * layer / ind_im , ht_i(ji,jj,jl) * jk / nlay_i ) - & 590 MAX( ht_i(ji,jj,jl) * (layer-1) / ind_im , ht_i(ji,jj,jl) * (jk-1) / nlay_i ) , 0.0 ) & 591 / ( ht_i(ji,jj,jl) / ind_im ) 592 593 e_i(ji,jj,jk,jl) = e_i(ji,jj,jk,jl) + zweight*zqm0(layer) 594 END DO !layer 595 END DO ! jk 596 597 zesum = 0.0 598 DO jk = 1, nlay_i 599 zesum = zesum + e_i(ji,jj,jk,jl) 600 END DO 601 602 ! WRITE(numout,*) ' Enthalpy at the end : ', e_i(ji,jj,1:nlay_i,jl) 603 ! WRITE(numout,*) ' Volume at the end : ', v_i(ji,jj,jl) 604 ! WRITE(numout,*) ' zesum : ', zesum 605 606 ELSE ! ind_im .EQ. 0, total melt 607 e_i(ji,jj,jk,jl) = 0.0 608 ENDIF 609 610 ENDIF ! internal_melt 611 612 END DO ! ji 613 END DO !jj 614 END DO !jl 615 IF( ln_nicep ) THEN 616 WRITE(numout,*) ' 2.3 after melt of an internal ice layer ' 617 WRITE(numout,*) ' a_i : ', a_i(jiindx, jjindx, 1:jpl) 618 WRITE(numout,*) ' at_i: ', at_i(jiindx,jjindx) 619 WRITE(numout,*) ' v_i : ', v_i(jiindx, jjindx, 1:jpl) 620 WRITE(numout,*) ' smv_i: ', smv_i(jiindx, jjindx, 1:jpl) 621 DO jk = 1, nlay_i 622 WRITE(numout,*) ' e_i : ', e_i(jiindx, jjindx, jk, 1:jpl) 623 WRITE(numout,*) ' t_i : ', t_i(jiindx, jjindx, jk, 1:jpl) 624 END DO 625 WRITE(numout,*) ' v_s : ', v_s(jiindx, jjindx, 1:jpl) 626 ENDIF 627 628 internal_melt(:,:,:) = .false. 629 630 ! Melt of snow 631 !-------------- 632 DO jl = 1, jpl 633 DO jj = 1, jpj 634 DO ji = 1, jpi 635 ! snow energy of melting 636 ze_s = e_s(ji,jj,1,jl) * unit_fac / area(ji,jj) / & 637 MAX( v_s(ji,jj,jl), 1.0e-6 ) ! snow energy of melting 638 639 ! If snow energy of melting smaller then Lf 640 ! Then all snow melts and meltwater, heat go to the ocean 641 IF ( ze_s .LE. rhosn * lfus ) internal_melt(ji,jj,jl) = .true. 642 643 IF( ln_nicep ) THEN 644 IF ( (ji.eq.jiindx) .AND. (jj.eq.jjindx) ) THEN 645 WRITE(numout,*) ' jl : ', jl 646 WRITE(numout,*) ' ze_s : ', ze_s 647 WRITE(numout,*) ' v_s : ', v_s(ji,jj,jl) 648 WRITE(numout,*) ' rhosn : ', rhosn 649 WRITE(numout,*) ' rhosn : ', lfus 650 WRITE(numout,*) ' area : ', area(ji,jj) 651 WRITE(numout,*) ' rhosn * lfus : ', rhosn * lfus 652 WRITE(numout,*) ' internal_melt : ', internal_melt(ji,jj,jl) 653 ENDIF 654 ENDIF 655 656 END DO 657 END DO 658 END DO 659 660 DO jl = 1, jpl 661 DO jj = 1, jpj 662 DO ji = 1, jpi 663 IF ( internal_melt(ji,jj,jl) ) THEN 662 664 v_s(ji,jj,jl) = 0.0 663 665 e_s(ji,jj,1,jl) = 0.0 664 ! ! release heat666 ! ! release heat 665 667 fheat_res(ji,jj) = fheat_res(ji,jj) & 666 668 + ze_s * v_s(ji,jj,jl) / rdt_ice 667 669 ! release mass 668 670 rdmsnif(ji,jj) = rdmsnif(ji,jj) + rhosn * v_s(ji,jj,jl) 669 ENDIF 670 END DO 671 END DO 672 END DO 673 674 zbigvalue = 1.0d+20 675 676 DO jl = 1, jpl 677 DO jj = 1, jpj 678 DO ji = 1, jpi 679 680 !switches 681 zindb = MAX( rzero, SIGN( rone, a_i(ji,jj,jl) - epsi06 ) ) 682 !switch = 1 if a_i > 1e-06 and 0 if not 683 zindsn = MAX( rzero, SIGN( rone, v_s(ji,jj,jl) - epsi06 ) ) !=1 if hs > 1e-6 and 0 if not 684 zindic = MAX( rzero, SIGN( rone, v_i(ji,jj,jl) - epsi04 ) ) !=1 if hi > 1e-3 and 0 if not 685 ! bug fix 25 avril 2007 686 zindb = zindb*zindic 687 688 !--- 2.3 Correction to ice age 689 !------------------------------ 690 ! IF ((o_i(ji,jj,jl)-1.0)*86400.0.gt.(rdt_ice*float(numit))) THEN 691 ! o_i(ji,jj,jl) = rdt_ice*FLOAT(numit)/86400.0 692 ! ENDIF 693 IF ((oa_i(ji,jj,jl)-1.0)*86400.0.gt.(rdt_ice*numit*a_i(ji,jj,jl))) THEN 694 oa_i(ji,jj,jl) = rdt_ice*numit/86400.0*a_i(ji,jj,jl) 695 ENDIF 696 oa_i(ji,jj,jl) = zindb*zindic*oa_i(ji,jj,jl) 697 698 !--- 2.4 Correction to snow thickness 699 !------------------------------------- 700 ! ! snow thickness has to be greater than 0, and if ice concentration smaller than 1e-6 then hs = 0 701 ! v_s(ji,jj,jl) = MAX( zindb * v_s(ji,jj,jl), 0.0) 702 ! snow thickness cannot be smaller than 1e-6 703 v_s(ji,jj,jl) = zindsn*v_s(ji,jj,jl)*zindb 704 v_s(ji,jj,jl) = v_s(ji,jj,jl) * MAX( 0.0 , SIGN( 1.0 , v_s(ji,jj,jl) - epsi06 ) ) 705 706 !--- 2.5 Correction to ice thickness 707 !------------------------------------- 708 ! ice thickness has to be greater than 0, and if ice concentration smaller than 1e-6 then hi = 0 709 v_i(ji,jj,jl) = MAX( zindb * v_i(ji,jj,jl), 0.0) 710 ! ice thickness cannot be smaller than 1e-3 711 v_i(ji,jj,jl) = zindic*v_i(ji,jj,jl) 712 713 !--- 2.6 Snow is transformed into ice if the original ice cover disappears 714 !---------------------------------------------------------------------------- 715 zindg = tms(ji,jj) * MAX( rzero , SIGN( rone , -v_i(ji,jj,jl) ) ) 716 v_i(ji,jj,jl) = v_i(ji,jj,jl) + zindg * rhosn * v_s(ji,jj,jl) / rau0 717 v_s(ji,jj,jl) = ( rone - zindg ) * v_s(ji,jj,jl) + & 718 zindg * v_i(ji,jj,jl) * ( rau0 - rhoic ) / rhosn 719 720 !--- 2.7 Correction to ice concentrations 721 !-------------------------------------------- 722 ! if greater than 0, ice concentration cannot be smaller than 1e-10 723 a_i(ji,jj,jl) = zindb * MAX(zindsn, zindic) * MAX( a_i(ji,jj,jl), epsi06 ) 724 ! then ice volume has to be corrected too... 725 ! instead, zap small areas 726 727 !------------------------- 728 ! 2.8) Snow heat content 729 !------------------------- 730 731 e_s(ji,jj,1,jl) = zindsn * & 732 ( MIN ( MAX ( 0.0, e_s(ji,jj,1,jl) ), zbigvalue ) ) + & 733 ( 1.0 - zindsn ) * 0.0 734 735 END DO ! ji 736 END DO ! jj 737 END DO ! jl 738 739 !+++++ [ 740 WRITE(numout,*) ' 2.8 ' 741 WRITE(numout,*) ' a_i : ', a_i(jiindx, jjindx, 1:jpl) 742 WRITE(numout,*) ' at_i: ', at_i(jiindx,jjindx) 743 WRITE(numout,*) ' v_i : ', v_i(jiindx, jjindx, 1:jpl) 744 WRITE(numout,*) ' smv_i: ', smv_i(jiindx, jjindx, 1:jpl) 745 DO jk = 1, nlay_i 746 WRITE(numout,*) ' e_i : ', e_i(jiindx, jjindx, jk, 1:jpl) 747 END DO 748 WRITE(numout,*) ' v_s : ', v_s(jiindx, jjindx, 1:jpl) 749 !+++++ ] 750 751 !------------------------ 752 ! 2.9) Ice heat content 753 !------------------------ 754 755 DO jl = 1, jpl 756 DO jk = 1, nlay_i 757 DO jj = 1, jpj 758 DO ji = 1, jpi 759 zindic = MAX( rzero, SIGN( rone, v_i(ji,jj,jl) - epsi06 ) ) 760 ! =1 if v_i > 1e-6 and 0 if not 761 e_i(ji,jj,jk,jl)= zindic * & 762 ( MIN ( MAX ( 0.0, e_i(ji,jj,jk,jl) ), zbigvalue ) ) + & 763 ( 1.0 - zindic ) * 0.0 764 END DO ! ji 765 END DO ! jj 766 END DO !jk 767 END DO !jl 768 769 WRITE(numout,*) ' 2.9 ' 770 DO jk = 1, nlay_i 771 WRITE(numout,*) ' e_i : ', e_i(jiindx, jjindx, jk, 1:jpl) 772 END DO 773 WRITE(numout,*) ' v_s : ', v_s(jiindx, jjindx, 1:jpl) 774 775 WRITE(numout,*) ' v_s : ', v_s(jiindx, jjindx, 1:jpl) 776 777 !--------------------- 778 ! 2.11) Ice salinity 779 !--------------------- 780 781 IF ( ( num_sal .EQ. 2 ) .OR. ( num_sal .EQ. 4 ) ) THEN ! general case 782 783 DO jl = 1, jpl 784 DO jk = 1, nlay_i 785 DO jj = 1, jpj 786 DO ji = 1, jpi 787 ! salinity stays in bounds 788 smv_i(ji,jj,jl) = MAX(MIN((rhoic-rhosn)/rhoic*sss_m(ji,jj),smv_i(ji,jj,jl)), & 789 0.1 * v_i(ji,jj,jl) ) 790 i_ice_switch = 1.0-MAX(0.0,SIGN(1.0,-v_i(ji,jj,jl))) 791 smv_i(ji,jj,jl) = i_ice_switch*smv_i(ji,jj,jl) + & 792 0.1*(1.0-i_ice_switch)*v_i(ji,jj,jl) 793 END DO ! ji 794 END DO ! jj 795 END DO !jk 796 END DO !jl 797 798 ENDIF 799 800 !+++++ [ 801 WRITE(numout,*) ' 2.11 ' 802 WRITE(numout,*) ' a_i : ', a_i(jiindx, jjindx, 1:jpl) 803 WRITE(numout,*) ' v_i : ', v_i(jiindx, jjindx, 1:jpl) 804 WRITE(numout,*) ' v_s : ', v_s(jiindx, jjindx, 1:jpl) 805 WRITE(numout,*) ' at_i ', at_i(jiindx,jjindx) 806 WRITE(numout,*) ' smv_i: ', smv_i(jiindx, jjindx, 1:jpl) 807 !+++++ ] 808 809 DO jm = 1, jpm 810 DO jj = 1, jpj 811 DO ji = 1, jpi 812 jl = ice_cat_bounds(jm,1) 813 !--- 2.12 Constrain the thickness of the smallest category above 5 cm 814 !---------------------------------------------------------------------- 815 ! the ice thickness of the smallest category should be higher than 5 cm 816 ! we changed hiclim to 10 817 zindb = MAX( rzero, SIGN( rone, a_i(ji,jj,jl) - epsi06 ) ) 818 ht_i(ji,jj,jl) = zindb*v_i(ji,jj,jl)/MAX(a_i(ji,jj,jl), epsi06) 819 zh = MAX( rone , zindb * hiclim / MAX( ht_i(ji,jj,jl) , epsi20 ) ) 820 ht_s(ji,jj,jl) = ht_s(ji,jj,jl)* zh 821 ! v_s(ji,jj,jl) = v_s(ji,jj,jl) * zh 822 ht_i(ji,jj,jl) = ht_i(ji,jj,jl)* zh 823 ! v_i(ji,jj,jl) = v_i(ji,jj,jl) * zh 824 a_i (ji,jj,jl) = a_i(ji,jj,jl) /zh 825 END DO !ji 826 END DO !jj 827 END DO !jm 828 !+++++ [ 829 WRITE(numout,*) ' 2.12 ' 830 WRITE(numout,*) ' a_i : ', a_i(jiindx, jjindx, 1:jpl) 831 WRITE(numout,*) ' v_i : ', v_i(jiindx, jjindx, 1:jpl) 832 WRITE(numout,*) ' v_s : ', v_s(jiindx, jjindx, 1:jpl) 833 WRITE(numout,*) ' at_i ', at_i(jiindx,jjindx) 834 WRITE(numout,*) ' smv_i: ', smv_i(jiindx, jjindx, 1:jpl) 835 !+++++ ] 836 837 !--- 2.13 Total ice concentration should not exceed 1 838 !----------------------------------------------------- 839 zamax = amax 840 ! 2.13.1) individual concentrations cannot exceed zamax 841 !------------------------------------------------------ 842 843 at_i(:,:) = 0.0 844 DO jl = 1, jpl 845 at_i(:,:) = a_i(:,:,jl) + at_i(:,:) 846 END DO 847 848 ! 2.13.2) Total ice concentration cannot exceed zamax 849 !---------------------------------------------------- 850 at_i(:,:) = 0.0 851 DO jl = 1, jpl 852 at_i(:,:) = a_i(:,:,jl) + at_i(:,:) 853 END DO 854 855 DO jj = 1, jpj 856 DO ji = 1, jpi 857 858 ! 0) Excessive area ? 859 z_da_ex = MAX( at_i(ji,jj) - zamax , 0.0 ) 860 861 ! 1) Count the number of existing categories 862 DO jl = 1, jpl 863 zindb = MAX( rzero, SIGN( rone, v_i(ji,jj,jl) - epsi03 ) ) 864 zindb = MAX( rzero, SIGN( rone, v_i(ji,jj,jl) ) ) 865 z_da_i(jl) = a_i(ji,jj,jl)*zindb*z_da_ex/MAX(at_i(ji,jj),epsi06) 866 z_dv_i(jl) = v_i(ji,jj,jl)*z_da_i(jl)/MAX(at_i(ji,jj),epsi06) 867 a_i(ji,jj,jl) = a_i(ji,jj,jl) - z_da_i(jl) 868 v_i(ji,jj,jl) = v_i(ji,jj,jl) + z_dv_i(jl) 869 870 END DO 871 872 END DO !ji 873 END DO !jj 874 875 !+++++ [ 876 WRITE(numout,*) ' 2.13 ' 877 WRITE(numout,*) ' a_i : ', a_i(jiindx, jjindx, 1:jpl) 878 WRITE(numout,*) ' at_i ', at_i(jiindx,jjindx) 879 WRITE(numout,*) ' v_i : ', v_i(jiindx, jjindx, 1:jpl) 880 WRITE(numout,*) ' v_s : ', v_s(jiindx, jjindx, 1:jpl) 881 WRITE(numout,*) ' smv_i: ', smv_i(jiindx, jjindx, 1:jpl) 882 !+++++ ] 883 884 at_i(:,:) = 0.0 885 DO jl = 1, jpl 886 at_i(:,:) = a_i(:,:,jl) + at_i(:,:) 887 END DO 888 889 DO jj = 1, jpj 890 DO ji = 1, jpi 891 IF (at_i(ji,jj).GT.1.0) THEN 892 WRITE(numout,*) ' lim_update ! : at_i > 1 -> PAS BIEN -> ALERTE ' 893 WRITE(numout,*) ' ~~~~~~~~~~ at_i ', at_i(ji,jj) 894 WRITE(numout,*) ' Point ', ji, jj 895 WRITE(numout,*) ' lat - long ', gphit(ji,jj), glamt(ji,jj) 896 DO jl = 1, jpl 897 WRITE(numout,*) ' a_i *** ', a_i(ji,jj,jl), ' CAT no ', jl 898 WRITE(numout,*) ' a_i_old *** ', old_a_i(ji,jj,jl), ' CAT no ', jl 899 WRITE(numout,*) ' d_a_i_thd / trp ', d_a_i_thd(ji,jj,jl), d_a_i_trp(ji,jj,jl) 900 END DO 901 ! WRITE(numout,*) ' CORRECTION BARBARE ' 902 ! z_da_ex = MAX( at_i(ji,jj) - zamax , 0.0 ) 903 ENDIF 904 END DO 905 END DO 906 907 ! Final thickness distribution rebinning 908 ! -------------------------------------- 909 !+++++ [ 910 WRITE(numout,*) ' rebinning before' 911 WRITE(numout,*) ' a_i : ', a_i(jiindx, jjindx, 1:jpl) 912 WRITE(numout,*) ' at_i ', at_i(jiindx,jjindx) 913 WRITE(numout,*) ' v_i : ', v_i(jiindx, jjindx, 1:jpl) 914 WRITE(numout,*) ' v_s : ', v_s(jiindx, jjindx, 1:jpl) 915 WRITE(numout,*) ' smv_i: ', smv_i(jiindx, jjindx, 1:jpl) 916 !+++++ ] 917 !old version 918 ! CALL lim_itd_th_reb(1,jpl) 671 ENDIF 672 END DO 673 END DO 674 END DO 675 676 zbigvalue = 1.0d+20 677 678 DO jl = 1, jpl 679 DO jj = 1, jpj 680 DO ji = 1, jpi 681 682 !switches 683 zindb = MAX( rzero, SIGN( rone, a_i(ji,jj,jl) - epsi06 ) ) 684 !switch = 1 if a_i > 1e-06 and 0 if not 685 zindsn = MAX( rzero, SIGN( rone, v_s(ji,jj,jl) - epsi06 ) ) !=1 if hs > 1e-6 and 0 if not 686 zindic = MAX( rzero, SIGN( rone, v_i(ji,jj,jl) - epsi04 ) ) !=1 if hi > 1e-3 and 0 if not 687 ! bug fix 25 avril 2007 688 zindb = zindb*zindic 689 690 !--- 2.3 Correction to ice age 691 !------------------------------ 692 ! IF ((o_i(ji,jj,jl)-1.0)*86400.0.gt.(rdt_ice*float(numit))) THEN 693 ! o_i(ji,jj,jl) = rdt_ice*FLOAT(numit)/86400.0 694 ! ENDIF 695 IF ((oa_i(ji,jj,jl)-1.0)*86400.0.gt.(rdt_ice*numit*a_i(ji,jj,jl))) THEN 696 oa_i(ji,jj,jl) = rdt_ice*numit/86400.0*a_i(ji,jj,jl) 697 ENDIF 698 oa_i(ji,jj,jl) = zindb*zindic*oa_i(ji,jj,jl) 699 700 !--- 2.4 Correction to snow thickness 701 !------------------------------------- 702 ! ! snow thickness has to be greater than 0, and if ice concentration smaller than 1e-6 then hs = 0 703 ! v_s(ji,jj,jl) = MAX( zindb * v_s(ji,jj,jl), 0.0) 704 ! snow thickness cannot be smaller than 1e-6 705 v_s(ji,jj,jl) = zindsn*v_s(ji,jj,jl)*zindb 706 v_s(ji,jj,jl) = v_s(ji,jj,jl) * MAX( 0.0 , SIGN( 1.0 , v_s(ji,jj,jl) - epsi06 ) ) 707 708 !--- 2.5 Correction to ice thickness 709 !------------------------------------- 710 ! ice thickness has to be greater than 0, and if ice concentration smaller than 1e-6 then hi = 0 711 v_i(ji,jj,jl) = MAX( zindb * v_i(ji,jj,jl), 0.0) 712 ! ice thickness cannot be smaller than 1e-3 713 v_i(ji,jj,jl) = zindic*v_i(ji,jj,jl) 714 715 !--- 2.6 Snow is transformed into ice if the original ice cover disappears 716 !---------------------------------------------------------------------------- 717 zindg = tms(ji,jj) * MAX( rzero , SIGN( rone , -v_i(ji,jj,jl) ) ) 718 v_i(ji,jj,jl) = v_i(ji,jj,jl) + zindg * rhosn * v_s(ji,jj,jl) / rau0 719 v_s(ji,jj,jl) = ( rone - zindg ) * v_s(ji,jj,jl) + & 720 zindg * v_i(ji,jj,jl) * ( rau0 - rhoic ) / rhosn 721 722 !--- 2.7 Correction to ice concentrations 723 !-------------------------------------------- 724 ! if greater than 0, ice concentration cannot be smaller than 1e-10 725 a_i(ji,jj,jl) = zindb * MAX(zindsn, zindic) * MAX( a_i(ji,jj,jl), epsi06 ) 726 ! then ice volume has to be corrected too... 727 ! instead, zap small areas 728 729 !------------------------- 730 ! 2.8) Snow heat content 731 !------------------------- 732 733 e_s(ji,jj,1,jl) = zindsn * & 734 ( MIN ( MAX ( 0.0, e_s(ji,jj,1,jl) ), zbigvalue ) ) + & 735 ( 1.0 - zindsn ) * 0.0 736 737 END DO ! ji 738 END DO ! jj 739 END DO ! jl 740 741 IF( ln_nicep ) THEN 742 WRITE(numout,*) ' 2.8 ' 743 WRITE(numout,*) ' a_i : ', a_i(jiindx, jjindx, 1:jpl) 744 WRITE(numout,*) ' at_i: ', at_i(jiindx,jjindx) 745 WRITE(numout,*) ' v_i : ', v_i(jiindx, jjindx, 1:jpl) 746 WRITE(numout,*) ' smv_i: ', smv_i(jiindx, jjindx, 1:jpl) 747 DO jk = 1, nlay_i 748 WRITE(numout,*) ' e_i : ', e_i(jiindx, jjindx, jk, 1:jpl) 749 END DO 750 WRITE(numout,*) ' v_s : ', v_s(jiindx, jjindx, 1:jpl) 751 ENDIF 752 753 !------------------------ 754 ! 2.9) Ice heat content 755 !------------------------ 756 757 DO jl = 1, jpl 758 DO jk = 1, nlay_i 759 DO jj = 1, jpj 760 DO ji = 1, jpi 761 zindic = MAX( rzero, SIGN( rone, v_i(ji,jj,jl) - epsi06 ) ) 762 ! =1 if v_i > 1e-6 and 0 if not 763 e_i(ji,jj,jk,jl)= zindic * & 764 ( MIN ( MAX ( 0.0, e_i(ji,jj,jk,jl) ), zbigvalue ) ) + & 765 ( 1.0 - zindic ) * 0.0 766 END DO ! ji 767 END DO ! jj 768 END DO !jk 769 END DO !jl 770 771 IF( ln_nicep ) THEN 772 WRITE(numout,*) ' 2.9 ' 773 DO jk = 1, nlay_i 774 WRITE(numout,*) ' e_i : ', e_i(jiindx, jjindx, jk, 1:jpl) 775 END DO 776 WRITE(numout,*) ' v_s : ', v_s(jiindx, jjindx, 1:jpl) 777 778 WRITE(numout,*) ' v_s : ', v_s(jiindx, jjindx, 1:jpl) 779 ENDIF 780 781 !--------------------- 782 ! 2.11) Ice salinity 783 !--------------------- 784 785 IF ( ( num_sal .EQ. 2 ) .OR. ( num_sal .EQ. 4 ) ) THEN ! general case 786 787 DO jl = 1, jpl 788 DO jk = 1, nlay_i 789 DO jj = 1, jpj 790 DO ji = 1, jpi 791 ! salinity stays in bounds 792 smv_i(ji,jj,jl) = MAX(MIN((rhoic-rhosn)/rhoic*sss_m(ji,jj),smv_i(ji,jj,jl)), & 793 0.1 * v_i(ji,jj,jl) ) 794 i_ice_switch = 1.0-MAX(0.0,SIGN(1.0,-v_i(ji,jj,jl))) 795 smv_i(ji,jj,jl) = i_ice_switch*smv_i(ji,jj,jl) + & 796 0.1*(1.0-i_ice_switch)*v_i(ji,jj,jl) 797 END DO ! ji 798 END DO ! jj 799 END DO !jk 800 END DO !jl 801 802 ENDIF 803 804 IF( ln_nicep ) THEN 805 WRITE(numout,*) ' 2.11 ' 806 WRITE(numout,*) ' a_i : ', a_i(jiindx, jjindx, 1:jpl) 807 WRITE(numout,*) ' v_i : ', v_i(jiindx, jjindx, 1:jpl) 808 WRITE(numout,*) ' v_s : ', v_s(jiindx, jjindx, 1:jpl) 809 WRITE(numout,*) ' at_i ', at_i(jiindx,jjindx) 810 WRITE(numout,*) ' smv_i: ', smv_i(jiindx, jjindx, 1:jpl) 811 ENDIF 812 813 DO jm = 1, jpm 814 DO jj = 1, jpj 815 DO ji = 1, jpi 816 jl = ice_cat_bounds(jm,1) 817 !--- 2.12 Constrain the thickness of the smallest category above 5 cm 818 !---------------------------------------------------------------------- 819 ! the ice thickness of the smallest category should be higher than 5 cm 820 ! we changed hiclim to 10 821 zindb = MAX( rzero, SIGN( rone, a_i(ji,jj,jl) - epsi06 ) ) 822 ht_i(ji,jj,jl) = zindb*v_i(ji,jj,jl)/MAX(a_i(ji,jj,jl), epsi06) 823 zh = MAX( rone , zindb * hiclim / MAX( ht_i(ji,jj,jl) , epsi20 ) ) 824 ht_s(ji,jj,jl) = ht_s(ji,jj,jl)* zh 825 ! v_s(ji,jj,jl) = v_s(ji,jj,jl) * zh 826 ht_i(ji,jj,jl) = ht_i(ji,jj,jl)* zh 827 ! v_i(ji,jj,jl) = v_i(ji,jj,jl) * zh 828 a_i (ji,jj,jl) = a_i(ji,jj,jl) /zh 829 END DO !ji 830 END DO !jj 831 END DO !jm 832 IF( ln_nicep ) THEN 833 WRITE(numout,*) ' 2.12 ' 834 WRITE(numout,*) ' a_i : ', a_i(jiindx, jjindx, 1:jpl) 835 WRITE(numout,*) ' v_i : ', v_i(jiindx, jjindx, 1:jpl) 836 WRITE(numout,*) ' v_s : ', v_s(jiindx, jjindx, 1:jpl) 837 WRITE(numout,*) ' at_i ', at_i(jiindx,jjindx) 838 WRITE(numout,*) ' smv_i: ', smv_i(jiindx, jjindx, 1:jpl) 839 ENDIF 840 841 !--- 2.13 Total ice concentration should not exceed 1 842 !----------------------------------------------------- 843 zamax = amax 844 ! 2.13.1) individual concentrations cannot exceed zamax 845 !------------------------------------------------------ 846 847 at_i(:,:) = 0.0 848 DO jl = 1, jpl 849 at_i(:,:) = a_i(:,:,jl) + at_i(:,:) 850 END DO 851 852 ! 2.13.2) Total ice concentration cannot exceed zamax 853 !---------------------------------------------------- 854 at_i(:,:) = 0.0 855 DO jl = 1, jpl 856 at_i(:,:) = a_i(:,:,jl) + at_i(:,:) 857 END DO 858 859 DO jj = 1, jpj 860 DO ji = 1, jpi 861 862 ! 0) Excessive area ? 863 z_da_ex = MAX( at_i(ji,jj) - zamax , 0.0 ) 864 865 ! 1) Count the number of existing categories 866 DO jl = 1, jpl 867 zindb = MAX( rzero, SIGN( rone, v_i(ji,jj,jl) - epsi03 ) ) 868 zindb = MAX( rzero, SIGN( rone, v_i(ji,jj,jl) ) ) 869 z_da_i(jl) = a_i(ji,jj,jl)*zindb*z_da_ex/MAX(at_i(ji,jj),epsi06) 870 z_dv_i(jl) = v_i(ji,jj,jl)*z_da_i(jl)/MAX(at_i(ji,jj),epsi06) 871 a_i(ji,jj,jl) = a_i(ji,jj,jl) - z_da_i(jl) 872 v_i(ji,jj,jl) = v_i(ji,jj,jl) + z_dv_i(jl) 873 874 END DO 875 876 END DO !ji 877 END DO !jj 878 879 IF( ln_nicep ) THEN 880 WRITE(numout,*) ' 2.13 ' 881 WRITE(numout,*) ' a_i : ', a_i(jiindx, jjindx, 1:jpl) 882 WRITE(numout,*) ' at_i ', at_i(jiindx,jjindx) 883 WRITE(numout,*) ' v_i : ', v_i(jiindx, jjindx, 1:jpl) 884 WRITE(numout,*) ' v_s : ', v_s(jiindx, jjindx, 1:jpl) 885 WRITE(numout,*) ' smv_i: ', smv_i(jiindx, jjindx, 1:jpl) 886 ENDIF 887 888 at_i(:,:) = 0.0 889 DO jl = 1, jpl 890 at_i(:,:) = a_i(:,:,jl) + at_i(:,:) 891 END DO 892 893 IF( ln_nicep ) THEN 894 DO jj = 1, jpj 895 DO ji = 1, jpi 896 IF (at_i(ji,jj).GT.1.0) THEN 897 WRITE(numout,*) ' lim_update ! : at_i > 1 -> PAS BIEN -> ALERTE ' 898 WRITE(numout,*) ' ~~~~~~~~~~ at_i ', at_i(ji,jj) 899 WRITE(numout,*) ' Point ', ji, jj 900 WRITE(numout,*) ' lat - long ', gphit(ji,jj), glamt(ji,jj) 901 DO jl = 1, jpl 902 WRITE(numout,*) ' a_i *** ', a_i(ji,jj,jl), ' CAT no ', jl 903 WRITE(numout,*) ' a_i_old *** ', old_a_i(ji,jj,jl), ' CAT no ', jl 904 WRITE(numout,*) ' d_a_i_thd / trp ', d_a_i_thd(ji,jj,jl), d_a_i_trp(ji,jj,jl) 905 END DO 906 ! WRITE(numout,*) ' CORRECTION BARBARE ' 907 ! z_da_ex = MAX( at_i(ji,jj) - zamax , 0.0 ) 908 ENDIF 909 END DO 910 END DO 911 ENDIF 912 913 ! Final thickness distribution rebinning 914 ! -------------------------------------- 915 IF( ln_nicep ) THEN 916 WRITE(numout,*) ' rebinning before' 917 WRITE(numout,*) ' a_i : ', a_i(jiindx, jjindx, 1:jpl) 918 WRITE(numout,*) ' at_i ', at_i(jiindx,jjindx) 919 WRITE(numout,*) ' v_i : ', v_i(jiindx, jjindx, 1:jpl) 920 WRITE(numout,*) ' v_s : ', v_s(jiindx, jjindx, 1:jpl) 921 WRITE(numout,*) ' smv_i: ', smv_i(jiindx, jjindx, 1:jpl) 922 ENDIF 923 !old version 924 ! CALL lim_itd_th_reb(1,jpl) 919 925 920 926 DO jm = 1, jpm … … 925 931 ENDIF 926 932 END DO 927 !+++++ [ 928 WRITE(numout,*) ' rebinning final' 929 WRITE(numout,*) ' a_i : ', a_i(jiindx, jjindx, 1:jpl) 930 WRITE(numout,*) ' at_i ', at_i(jiindx,jjindx) 931 WRITE(numout,*) ' v_i : ', v_i(jiindx, jjindx, 1:jpl) 932 WRITE(numout,*) ' v_s : ', v_s(jiindx, jjindx, 1:jpl) 933 WRITE(numout,*) ' smv_i: ', smv_i(jiindx, jjindx, 1:jpl) 934 !+++++ ] 935 936 at_i(:,:) = 0.0 937 DO jl = 1, jpl 938 at_i(:,:) = a_i(:,:,jl) + at_i(:,:) 939 END DO 940 941 !------------------------------------------------------------------------------ 942 ! 2) Corrections to avoid wrong values | 943 !------------------------------------------------------------------------------ 944 ! Ice drift 945 !------------ 933 934 IF( ln_nicep ) THEN 935 WRITE(numout,*) ' rebinning final' 936 WRITE(numout,*) ' a_i : ', a_i(jiindx, jjindx, 1:jpl) 937 WRITE(numout,*) ' at_i ', at_i(jiindx,jjindx) 938 WRITE(numout,*) ' v_i : ', v_i(jiindx, jjindx, 1:jpl) 939 WRITE(numout,*) ' v_s : ', v_s(jiindx, jjindx, 1:jpl) 940 WRITE(numout,*) ' smv_i: ', smv_i(jiindx, jjindx, 1:jpl) 941 ENDIF 942 943 at_i(:,:) = 0.0 944 DO jl = 1, jpl 945 at_i(:,:) = a_i(:,:,jl) + at_i(:,:) 946 END DO 947 948 !------------------------------------------------------------------------------ 949 ! 2) Corrections to avoid wrong values | 950 !------------------------------------------------------------------------------ 951 ! Ice drift 952 !------------ 946 953 947 954 DO jj = 2, jpjm1 … … 962 969 CALL lbc_lnk( v_ice(:,:), 'V', -1. ) 963 970 964 !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 965 ! ALERTES 966 !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 967 968 DO jj = 1, jpj 969 DO ji = 1, jpi 970 DO jl = 1, jpl 971 ! IF ((v_i(ji,jj,jl).NE.0.0).AND.(a_i(ji,jj,jl).EQ.0.0)) THEN 972 ! WRITE(numout,*) ' lim_update : incompatible volume and concentration ' 973 END DO ! jl 974 975 DO jl = 1, jpl 976 IF ( (a_i(ji,jj,jl).GT.1.0).OR.(at_i(ji,jj).GT.1.0) ) THEN 977 zindb = MAX( rzero, SIGN( rone, a_i(ji,jj,jl) - epsi06 ) ) 978 WRITE(numout,*) ' lim_update : a_i > 1 ' 979 WRITE(numout,*) ' PAS BIEN ----> ALERTE !!! ' 980 WRITE(numout,*) ' ~~~~~~~~~~ at_i ', at_i(ji,jj) 981 WRITE(numout,*) ' Point - category', ji, jj, jl 982 WRITE(numout,*) ' lat - long ', gphit(ji,jj), glamt(ji,jj) 983 WRITE(numout,*) ' a_i *** a_i_old ', a_i(ji,jj,jl), old_a_i(ji,jj,jl) 984 WRITE(numout,*) ' v_i *** v_i_old ', v_i(ji,jj,jl), old_v_i(ji,jj,jl) 985 WRITE(numout,*) ' ht_i *** ', v_i(ji,jj,jl)/MAX(a_i(ji,jj,jl),epsi06)*zindb 986 WRITE(numout,*) ' hi_max(jl), hi_max(jl-1) ', hi_max(jl), hi_max(jl-1) 987 WRITE(numout,*) ' d_v_i_thd / trp ', d_v_i_thd(ji,jj,jl), d_v_i_trp(ji,jj,jl) 988 WRITE(numout,*) ' d_a_i_thd / trp ', d_a_i_thd(ji,jj,jl), d_a_i_trp(ji,jj,jl) 989 ENDIF 990 END DO 991 992 END DO !jj 993 END DO !ji 994 995 WRITE(numout,*) ' TESTOSC1 ', tio_u(jiindx,jjindx), tio_v(jiindx,jjindx) 996 WRITE(numout,*) ' TESTOSC2 ', u_ice(jiindx,jjindx), v_ice(jiindx,jjindx) 997 WRITE(numout,*) ' TESTOSC3 ', u_oce(jiindx,jjindx), v_oce(jiindx,jjindx) 998 WRITE(numout,*) ' TESTOSC4 ', utau (jiindx,jjindx), vtau (jiindx,jjindx) 971 !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 972 ! ALERTES 973 !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 974 975 IF( ln_nicep ) THEN 976 DO jj = 1, jpj 977 DO ji = 1, jpi 978 DO jl = 1, jpl 979 ! IF ((v_i(ji,jj,jl).NE.0.0).AND.(a_i(ji,jj,jl).EQ.0.0)) THEN 980 ! WRITE(numout,*) ' lim_update : incompatible volume and concentration ' 981 END DO ! jl 982 983 DO jl = 1, jpl 984 IF ( (a_i(ji,jj,jl).GT.1.0).OR.(at_i(ji,jj).GT.1.0) ) THEN 985 zindb = MAX( rzero, SIGN( rone, a_i(ji,jj,jl) - epsi06 ) ) 986 WRITE(numout,*) ' lim_update : a_i > 1 ' 987 WRITE(numout,*) ' PAS BIEN ----> ALERTE !!! ' 988 WRITE(numout,*) ' ~~~~~~~~~~ at_i ', at_i(ji,jj) 989 WRITE(numout,*) ' Point - category', ji, jj, jl 990 WRITE(numout,*) ' lat - long ', gphit(ji,jj), glamt(ji,jj) 991 WRITE(numout,*) ' a_i *** a_i_old ', a_i(ji,jj,jl), old_a_i(ji,jj,jl) 992 WRITE(numout,*) ' v_i *** v_i_old ', v_i(ji,jj,jl), old_v_i(ji,jj,jl) 993 WRITE(numout,*) ' ht_i *** ', v_i(ji,jj,jl)/MAX(a_i(ji,jj,jl),epsi06)*zindb 994 WRITE(numout,*) ' hi_max(jl), hi_max(jl-1) ', hi_max(jl), hi_max(jl-1) 995 WRITE(numout,*) ' d_v_i_thd / trp ', d_v_i_thd(ji,jj,jl), d_v_i_trp(ji,jj,jl) 996 WRITE(numout,*) ' d_a_i_thd / trp ', d_a_i_thd(ji,jj,jl), d_a_i_trp(ji,jj,jl) 997 ENDIF 998 END DO 999 1000 END DO !jj 1001 END DO !ji 1002 1003 WRITE(numout,*) ' TESTOSC1 ', tio_u(jiindx,jjindx), tio_v(jiindx,jjindx) 1004 WRITE(numout,*) ' TESTOSC2 ', u_ice(jiindx,jjindx), v_ice(jiindx,jjindx) 1005 WRITE(numout,*) ' TESTOSC3 ', u_oce(jiindx,jjindx), v_oce(jiindx,jjindx) 1006 WRITE(numout,*) ' TESTOSC4 ', utau (jiindx,jjindx), vtau (jiindx,jjindx) 1007 ENDIF 999 1008 1000 1009 … … 1077 1086 ENDIF 1078 1087 1079 !---------------------1088 !--------------------- 1080 1089 1081 1090 END SUBROUTINE lim_update -
trunk/NEMO/LIM_SRC_3/limvar.F90
r888 r921 44 44 USE ice 45 45 USE par_ice 46 46 47 47 IMPLICIT NONE 48 48 PRIVATE … … 71 71 72 72 SUBROUTINE lim_var_agg(n) 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 !!-- End of declarations112 !!----------------------------------------------------------------------------------------------113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 END DO157 158 159 160 DO jl = 1, jpl161 DO jj = 1, jpj162 DO ji = 1, jpi163 et_s(ji,jj) = et_s(ji,jj) + & ! snow heat content164 165 zinda = MAX( zzero , SIGN( zone , vt_i(ji,jj) - 0.10 ) )166 smt_i(ji,jj) = smt_i(ji,jj) + & ! ice salinity167 168 169 zinda = MAX( zzero , SIGN( zone , at_i(ji,jj) - 0.10 ) )170 ot_i(ji,jj) = ot_i(ji,jj) + & ! ice age171 172 173 END DO174 END DO175 END DO176 177 DO jl = 1, jpl178 DO jk = 1, nlay_i179 DO jj = 1, jpj180 DO ji = 1, jpi181 et_i(ji,jj) = et_i(ji,jj) + e_i(ji,jj,jk,jl) ! ice heat182 183 END DO184 END DO185 END DO186 END DO187 188 189 190 191 192 !==============================================================================193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 !!-- End of declarations233 !!------------------------------------------------------------------------------73 !!------------------------------------------------------------------ 74 !! *** ROUTINE lim_var_agg *** 75 !! ** Purpose : 76 !! This routine aggregates ice-thickness-category variables to 77 !! all-ice variables 78 !! i.e. it turns VGLO into VAGG 79 !! ** Method : 80 !! 81 !! ** Arguments : 82 !! kideb , kiut : Starting and ending points on which the 83 !! the computation is applied 84 !! 85 !! ** Inputs / Ouputs : (global commons) 86 !! ** Arguments : n = 1, at_i vt_i only 87 !! n = 2 everything 88 !! 89 !! ** External : 90 !! 91 !! ** References : 92 !! 93 !! ** History : 94 !! (01-2006) Martin Vancoppenolle, UCL-ASTR 95 !! 96 !! note : you could add an argument when you need only at_i, vt_i 97 !! and when you need everything 98 !!------------------------------------------------------------------ 99 !! * Arguments 100 101 !! * Local variables 102 INTEGER :: ji, & ! spatial dummy loop index 103 jj, & ! spatial dummy loop index 104 jk, & ! vertical layering dummy loop index 105 jl ! ice category dummy loop index 106 107 REAL :: zeps, epsi16, zinda, epsi06 108 109 INTEGER, INTENT( in ) :: n ! describes what is needed 110 111 !!-- End of declarations 112 !!---------------------------------------------------------------------------------------------- 113 zeps = 1.0e-13 114 epsi16 = 1.0e-16 115 epsi06 = 1.0e-6 116 117 !------------------ 118 ! Zero everything 119 !------------------ 120 121 vt_i(:,:) = 0.0 122 vt_s(:,:) = 0.0 123 at_i(:,:) = 0.0 124 ato_i(:,:) = 1.0 125 126 IF ( n .GT. 1 ) THEN 127 et_s(:,:) = 0.0 128 ot_i(:,:) = 0.0 129 smt_i(:,:) = 0.0 130 et_i(:,:) = 0.0 131 ENDIF 132 133 !-------------------- 134 ! Compute variables 135 !-------------------- 136 137 DO jl = 1, jpl 138 DO jj = 1, jpj 139 DO ji = 1, jpi 140 141 vt_i(ji,jj) = vt_i(ji,jj) + v_i(ji,jj,jl) ! ice volume 142 vt_s(ji,jj) = vt_s(ji,jj) + v_s(ji,jj,jl) ! snow volume 143 at_i(ji,jj) = at_i(ji,jj) + a_i(ji,jj,jl) ! ice concentration 144 145 zinda = MAX( zzero , SIGN( zone , at_i(ji,jj) - 0.10 ) ) 146 icethi(ji,jj) = vt_i(ji,jj) / MAX(at_i(ji,jj),epsi16)*zinda 147 ! ice thickness 148 END DO 149 END DO 150 END DO 151 152 DO jj = 1, jpj 153 DO ji = 1, jpi 154 ato_i(ji,jj) = MAX(1.0 - at_i(ji,jj), 0.0) ! open water fraction 155 END DO 156 END DO 157 158 IF ( n .GT. 1 ) THEN 159 160 DO jl = 1, jpl 161 DO jj = 1, jpj 162 DO ji = 1, jpi 163 et_s(ji,jj) = et_s(ji,jj) + & ! snow heat content 164 e_s(ji,jj,1,jl) 165 zinda = MAX( zzero , SIGN( zone , vt_i(ji,jj) - 0.10 ) ) 166 smt_i(ji,jj) = smt_i(ji,jj) + & ! ice salinity 167 smv_i(ji,jj,jl) / MAX( vt_i(ji,jj) , zeps ) * & 168 zinda 169 zinda = MAX( zzero , SIGN( zone , at_i(ji,jj) - 0.10 ) ) 170 ot_i(ji,jj) = ot_i(ji,jj) + & ! ice age 171 oa_i(ji,jj,jl) / MAX( at_i(ji,jj) , zeps ) * & 172 zinda 173 END DO 174 END DO 175 END DO 176 177 DO jl = 1, jpl 178 DO jk = 1, nlay_i 179 DO jj = 1, jpj 180 DO ji = 1, jpi 181 et_i(ji,jj) = et_i(ji,jj) + e_i(ji,jj,jk,jl) ! ice heat 182 ! content 183 END DO 184 END DO 185 END DO 186 END DO 187 188 ENDIF ! n .GT. 1 189 190 END SUBROUTINE lim_var_agg 191 192 !============================================================================== 193 194 SUBROUTINE lim_var_glo2eqv 195 !!------------------------------------------------------------------ 196 !! *** ROUTINE lim_var_glo2eqv ***' 197 !! ** Purpose : 198 !! This routine computes equivalent variables as function of 199 !! global variables 200 !! i.e. it turns VGLO into VEQV 201 !! ** Method : 202 !! 203 !! ** Arguments : 204 !! kideb , kiut : Starting and ending points on which the 205 !! the computation is applied 206 !! 207 !! ** Inputs / Ouputs : 208 !! 209 !! ** External : 210 !! 211 !! ** References : 212 !! 213 !! ** History : 214 !! (01-2006) Martin Vancoppenolle, UCL-ASTR 215 !! 216 !!------------------------------------------------------------------ 217 218 !! * Local variables 219 INTEGER :: ji, & ! spatial dummy loop index 220 jj, & ! spatial dummy loop index 221 jk, & ! vertical layering dummy loop index 222 jl ! ice category dummy loop index 223 224 REAL :: zq_i, zaaa, zbbb, zccc, zdiscrim, & 225 ztmelts, zindb, zq_s, zfac1, zfac2 226 227 REAL :: zeps, epsi06 228 229 zeps = 1.0e-10 230 epsi06 = 1.0e-06 231 232 !!-- End of declarations 233 !!------------------------------------------------------------------------------ 234 234 235 235 !------------------------------------------------------- … … 253 253 254 254 !CDIR NOVERRCHK 255 DO jl = 1, jpl256 !CDIR NOVERRCHK 257 DO jj = 1, jpj258 !CDIR NOVERRCHK 259 DO ji = 1, jpi260 zindb = 1.0-MAX(0.0,SIGN(1.0,-a_i(ji,jj,jl))) !0 if no ice and 1 if yes261 sm_i(ji,jj,jl) = smv_i(ji,jj,jl) / MAX(v_i(ji,jj,jl),zeps) * zindb262 END DO263 END DO264 END DO255 DO jl = 1, jpl 256 !CDIR NOVERRCHK 257 DO jj = 1, jpj 258 !CDIR NOVERRCHK 259 DO ji = 1, jpi 260 zindb = 1.0-MAX(0.0,SIGN(1.0,-a_i(ji,jj,jl))) !0 if no ice and 1 if yes 261 sm_i(ji,jj,jl) = smv_i(ji,jj,jl) / MAX(v_i(ji,jj,jl),zeps) * zindb 262 END DO 263 END DO 264 END DO 265 265 266 266 ENDIF … … 275 275 DO jl = 1, jpl 276 276 !CDIR NOVERRCHK 277 DO jk = 1, nlay_i278 !CDIR NOVERRCHK 279 DO jj = 1, jpj280 !CDIR NOVERRCHK 281 DO ji = 1, jpi282 !Energy of melting q(S,T) [J.m-3]283 zq_i = e_i(ji,jj,jk,jl) / area(ji,jj) / &284 285 ! zindb = 0 if no ice and 1 if yes286 zindb = 1.0 - MAX( 0.0 , SIGN( 1.0 , - v_i(ji,jj,jl) ) )287 !convert units ! very important that this line is here288 zq_i = zq_i * unit_fac * zindb289 !Ice layer melt temperature290 ztmelts = -tmut*s_i(ji,jj,jk,jl) + rtt291 !Conversion q(S,T) -> T (second order equation)292 zaaa = cpic293 zbbb = ( rcp - cpic ) * ( ztmelts - rtt ) + &294 295 zccc = lfus * (ztmelts-rtt)296 zdiscrim = SQRT( MAX(zbbb*zbbb - 4.0*zaaa*zccc,0.0) )297 t_i(ji,jj,jk,jl) = rtt + zindb *( - zbbb - zdiscrim ) / &298 299 t_i(ji,jj,jk,jl) = MIN( rtt, MAX(173.15, t_i(ji,jj,jk,jl) ) )300 END DO301 END DO302 END DO277 DO jk = 1, nlay_i 278 !CDIR NOVERRCHK 279 DO jj = 1, jpj 280 !CDIR NOVERRCHK 281 DO ji = 1, jpi 282 !Energy of melting q(S,T) [J.m-3] 283 zq_i = e_i(ji,jj,jk,jl) / area(ji,jj) / & 284 MAX( v_i(ji,jj,jl) , epsi06 ) * nlay_i 285 ! zindb = 0 if no ice and 1 if yes 286 zindb = 1.0 - MAX( 0.0 , SIGN( 1.0 , - v_i(ji,jj,jl) ) ) 287 !convert units ! very important that this line is here 288 zq_i = zq_i * unit_fac * zindb 289 !Ice layer melt temperature 290 ztmelts = -tmut*s_i(ji,jj,jk,jl) + rtt 291 !Conversion q(S,T) -> T (second order equation) 292 zaaa = cpic 293 zbbb = ( rcp - cpic ) * ( ztmelts - rtt ) + & 294 zq_i / rhoic - lfus 295 zccc = lfus * (ztmelts-rtt) 296 zdiscrim = SQRT( MAX(zbbb*zbbb - 4.0*zaaa*zccc,0.0) ) 297 t_i(ji,jj,jk,jl) = rtt + zindb *( - zbbb - zdiscrim ) / & 298 ( 2.0 *zaaa ) 299 t_i(ji,jj,jk,jl) = MIN( rtt, MAX(173.15, t_i(ji,jj,jk,jl) ) ) 300 END DO 301 END DO 302 END DO 303 303 END DO 304 304 … … 311 311 DO jl = 1, jpl 312 312 !CDIR NOVERRCHK 313 DO jk = 1, nlay_s314 !CDIR NOVERRCHK 315 DO jj = 1, jpj316 !CDIR NOVERRCHK 317 DO ji = 1, jpi318 !Energy of melting q(S,T) [J.m-3]319 zq_s = e_s(ji,jj,jk,jl) / area(ji,jj) / &320 321 ! zindb = 0 if no ice and 1 if yes322 zindb = 1.0 - MAX( 0.0 , SIGN( 1.0 , - v_s(ji,jj,jl) ) )323 !convert units ! very important that this line is here324 zq_s = zq_s * unit_fac * zindb325 t_s(ji,jj,jk,jl) = rtt + zindb * ( - zfac1 * zq_s + zfac2 )326 t_s(ji,jj,jk,jl) = MIN( rtt, MAX(173.15, t_s(ji,jj,jk,jl) ) )327 328 END DO329 END DO330 END DO313 DO jk = 1, nlay_s 314 !CDIR NOVERRCHK 315 DO jj = 1, jpj 316 !CDIR NOVERRCHK 317 DO ji = 1, jpi 318 !Energy of melting q(S,T) [J.m-3] 319 zq_s = e_s(ji,jj,jk,jl) / area(ji,jj) / & 320 MAX( v_s(ji,jj,jl) , epsi06 ) * nlay_s 321 ! zindb = 0 if no ice and 1 if yes 322 zindb = 1.0 - MAX( 0.0 , SIGN( 1.0 , - v_s(ji,jj,jl) ) ) 323 !convert units ! very important that this line is here 324 zq_s = zq_s * unit_fac * zindb 325 t_s(ji,jj,jk,jl) = rtt + zindb * ( - zfac1 * zq_s + zfac2 ) 326 t_s(ji,jj,jk,jl) = MIN( rtt, MAX(173.15, t_s(ji,jj,jk,jl) ) ) 327 328 END DO 329 END DO 330 END DO 331 331 END DO 332 332 … … 346 346 zindb = zindb*1.0-MAX(0.0,SIGN(1.0,-v_i(ji,jj,jl))) 347 347 tm_i(ji,jj) = tm_i(ji,jj) + t_i(ji,jj,jk,jl)*v_i(ji,jj,jl) / & 348 348 REAL(nlay_i) / MAX( vt_i(ji,jj) , zeps ) 349 349 END DO 350 350 END DO … … 354 354 END SUBROUTINE lim_var_glo2eqv 355 355 356 !===============================================================================356 !=============================================================================== 357 357 358 358 SUBROUTINE lim_var_eqv2glo 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 !===============================================================================391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 !!-- End of declarations442 !!------------------------------------------------------------------------------359 !!------------------------------------------------------------------ 360 !! *** ROUTINE lim_var_eqv2glo ***' 361 !! ** Purpose : 362 !! This routine computes global variables as function of 363 !! equivalent variables 364 !! i.e. it turns VEQV into VGLO 365 !! ** Method : 366 !! 367 !! ** Arguments : 368 !! 369 !! ** Inputs / Ouputs : (global commons) 370 !! 371 !! ** External : 372 !! 373 !! ** References : 374 !! 375 !! ** History : 376 !! (01-2006) Martin Vancoppenolle, UCL-ASTR 377 !! Take it easy man 378 !! Life is just a simple game, between 379 !! ups / and downs \ :@) 380 !! 381 !!------------------------------------------------------------------ 382 383 v_i(:,:,:) = ht_i(:,:,:) * a_i(:,:,:) 384 v_s(:,:,:) = ht_s(:,:,:) * a_i(:,:,:) 385 smv_i(:,:,:) = sm_i(:,:,:) * v_i(:,:,:) 386 oa_i (:,:,:) = o_i (:,:,:) * a_i(:,:,:) 387 388 END SUBROUTINE lim_var_eqv2glo 389 390 !=============================================================================== 391 392 SUBROUTINE lim_var_salprof 393 !!------------------------------------------------------------------ 394 !! *** ROUTINE lim_var_salprof ***' 395 !! ** Purpose : 396 !! This routine computes salinity profile in function of 397 !! bulk salinity 398 !! 399 !! ** Method : If bulk salinity greater than s_i_1, 400 !! the profile is assumed to be constant (S_inf) 401 !! If bulk salinity lower than s_i_0, 402 !! the profile is linear with 0 at the surface (S_zero) 403 !! If it is between s_i_0 and s_i_1, it is a 404 !! alpha-weighted linear combination of s_inf and s_zero 405 !! 406 !! ** References : Vancoppenolle et al., 2007 (in preparation) 407 !! 408 !! ** History : 409 !! (08-2006) Martin Vancoppenolle, UCL-ASTR 410 !! Take it easy man 411 !! Life is just a simple game, between ups 412 !! / and downs \ :@) 413 !! 414 !!------------------------------------------------------------------ 415 !! * Arguments 416 417 !! * Local variables 418 INTEGER :: & 419 ji , & !: spatial dummy loop index 420 jj , & !: spatial dummy loop index 421 jk , & !: vertical layering dummy loop index 422 jl !: ice category dummy loop index 423 424 REAL(wp) :: & 425 dummy_fac0 , & !: dummy factor used in computations 426 dummy_fac1 , & !: dummy factor used in computations 427 dummy_fac , & !: dummy factor used in computations 428 zind0 , & !: switch, = 1 if sm_i lt s_i_0 429 zind01 , & !: switch, = 1 if sm_i between s_i_0 and s_i_1 430 zindbal , & !: switch, = 1, if 2*sm_i gt sss_m 431 zargtemp !: dummy factor 432 433 REAL(wp), DIMENSION(nlay_i) :: & 434 zs_zero !: linear salinity profile for salinities under 435 !: s_i_0 436 437 REAL(wp), DIMENSION(jpi,jpj,jpl) :: & 438 z_slope_s , & !: slope of the salinity profile 439 zalpha !: weight factor for s between s_i_0 and s_i_1 440 441 !!-- End of declarations 442 !!------------------------------------------------------------------------------ 443 443 444 444 !--------------------------------------- … … 468 468 DO ji = 1, jpi 469 469 z_slope_s(ji,jj,jl) = 2.0 * sm_i(ji,jj,jl) / MAX( 0.01 & 470 470 , ht_i(ji,jj,jl) ) 471 471 END DO ! ji 472 472 END DO ! jj … … 490 490 ! zind01 = 1 if sm_i is between s_i_0 and s_i_1 and 0 othws 491 491 zind01 = ( 1.0 - zind0 ) * & 492 492 MAX( 0.0 , SIGN( 1.0 , s_i_1 - sm_i(ji,jj,jl) ) ) 493 493 ! If 2.sm_i GE sss_m then zindbal = 1 494 494 zindbal = MAX( 0.0 , SIGN( 1.0 , 2. * sm_i(ji,jj,jl) - & 495 sss_m(ji,jj) ) )495 sss_m(ji,jj) ) ) 496 496 zalpha(ji,jj,jl) = zind0 * 1.0 & 497 498 497 + zind01 * ( sm_i(ji,jj,jl) * dummy_fac0 + & 498 dummy_fac1 ) 499 499 zalpha(ji,jj,jl) = zalpha(ji,jj,jl) * ( 1.0 - zindbal ) 500 500 END DO … … 512 512 ! linear profile with 0 at the surface 513 513 zs_zero(jk) = z_slope_s(ji,jj,jl) * ( jk - 1./2. ) * & 514 514 ht_i(ji,jj,jl) * dummy_fac 515 515 ! weighting the profile 516 516 s_i(ji,jj,jk,jl) = zalpha(ji,jj,jl) * zs_zero(jk) + & 517 517 ( 1.0 - zalpha(ji,jj,jl) ) * sm_i(ji,jj,jl) 518 518 END DO ! ji 519 519 END DO ! jj … … 527 527 !------------------------------------------------------- 528 528 ! Schwarzacher (1959) multiyear salinity profile (mean = 2.30) 529 529 530 530 IF ( num_sal .EQ. 3 ) THEN 531 531 … … 542 542 zargtemp = ( jk - 0.5 ) / nlay_i 543 543 s_i(ji,jj,jk,jl) = 1.6 - 1.6 * COS( 3.14169265 * & 544 545 544 ( zargtemp**(0.407/ & 545 ( 0.573 + zargtemp ) ) ) ) 546 546 END DO ! ji 547 547 END DO ! jj … … 553 553 END SUBROUTINE lim_var_salprof 554 554 555 !===============================================================================555 !=============================================================================== 556 556 557 557 SUBROUTINE lim_var_bv 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 !!-- End of declarations590 !!------------------------------------------------------------------------------591 592 593 594 !CDIR NOVERRCHK 595 596 !CDIR NOVERRCHK 597 598 !CDIR NOVERRCHK 599 600 !CDIR NOVERRCHK 601 602 603 604 605 606 607 608 609 610 611 612 613 END SUBROUTINE lim_var_bv 614 615 !===============================================================================558 !!------------------------------------------------------------------ 559 !! *** ROUTINE lim_var_bv ***' 560 !! ** Purpose : 561 !! This routine computes mean brine volume (%) in sea ice 562 !! 563 !! ** Method : e = - 0.054 * S (ppt) / T (C) 564 !! 565 !! ** Arguments : 566 !! 567 !! ** Inputs / Ouputs : (global commons) 568 !! 569 !! ** External : 570 !! 571 !! ** References : Vancoppenolle et al., JGR, 2007 572 !! 573 !! ** History : 574 !! (08-2006) Martin Vancoppenolle, UCL-ASTR 575 !! 576 !!------------------------------------------------------------------ 577 !! * Arguments 578 579 !! * Local variables 580 INTEGER :: ji, & ! spatial dummy loop index 581 jj, & ! spatial dummy loop index 582 jk, & ! vertical layering dummy loop index 583 jl ! ice category dummy loop index 584 585 REAL :: zbvi, & ! brine volume for a single ice category 586 zeps, & ! very small value 587 zindb ! is there ice or not 588 589 !!-- End of declarations 590 !!------------------------------------------------------------------------------ 591 592 zeps = 1.0e-13 593 bv_i(:,:) = 0.0 594 !CDIR NOVERRCHK 595 DO jl = 1, jpl 596 !CDIR NOVERRCHK 597 DO jk = 1, nlay_i 598 !CDIR NOVERRCHK 599 DO jj = 1, jpj 600 !CDIR NOVERRCHK 601 DO ji = 1, jpi 602 zindb = 1.0-MAX(0.0,SIGN(1.0,-a_i(ji,jj,jl))) !0 if no ice and 1 if yes 603 zbvi = - zindb * tmut *s_i(ji,jj,jk,jl) / & 604 MIN( t_i(ji,jj,jk,jl) - 273.15 , zeps ) & 605 * v_i(ji,jj,jl) / REAL(nlay_i) 606 bv_i(ji,jj) = bv_i(ji,jj) + zbvi & 607 / MAX( vt_i(ji,jj) , zeps ) 608 END DO 609 END DO 610 END DO 611 END DO 612 613 END SUBROUTINE lim_var_bv 614 615 !=============================================================================== 616 616 617 617 SUBROUTINE lim_var_salprof1d(kideb,kiut) … … 642 642 zindbal , & ! switch if in freshwater area 643 643 zargtemp 644 644 645 645 REAL(wp), DIMENSION(jpij) :: & 646 646 z_slope_s … … 649 649 zs_zero 650 650 !!------------------------------------------------------------------- 651 651 652 652 !--------------------------------------- 653 653 ! Vertically constant, constant in time … … 670 670 !CDIR NOVERRCHK 671 671 DO ji = kideb, kiut 672 673 672 z_slope_s(ji) = 2.0 * sm_i_b(ji) / MAX( 0.01 & 673 , ht_i_b(ji) ) 674 674 END DO ! ji 675 675 … … 691 691 ! zind01 = 1 if sm_i is between s_i_0 and s_i_1 and 0 othws 692 692 zind01 = ( 1.0 - zind0 ) * & 693 693 MAX( 0.0 , SIGN( 1.0 , s_i_1 - sm_i_b(ji) ) ) 694 694 ! if 2.sm_i GE sss_m then zindbal = 1 695 695 zindbal = MAX( 0.0 , SIGN( 1.0 , 2. * sm_i_b(ji) - & 696 sss_m(zji,zjj) ) )696 sss_m(zji,zjj) ) ) 697 697 698 698 zalpha = zind0 * 1.0 & 699 700 699 + zind01 * ( sm_i_b(ji) * dummy_fac0 + & 700 dummy_fac1 ) 701 701 zalpha = zalpha * ( 1.0 - zindbal ) 702 702 703 703 zs_zero(ji,jk) = z_slope_s(ji) * ( jk - 1./2. ) * & 704 704 ht_i_b(ji) * dummy_fac2 705 705 ! weighting the profile 706 706 s_i_b(ji,jk) = zalpha * zs_zero(ji,jk) + & 707 707 ( 1.0 - zalpha ) * sm_i_b(ji) 708 708 END DO ! ji 709 709 END DO ! jk … … 726 726 zargtemp = ( jk - 0.5 ) / nlay_i 727 727 s_i_b(ji,jk) = 1.6 - 1.6*cos(3.14169265*(zargtemp**(0.407/ & 728 728 (0.573+zargtemp)))) 729 729 END DO ! jk 730 730 END DO ! ji … … 734 734 END SUBROUTINE lim_var_salprof1d 735 735 736 !===============================================================================736 !=============================================================================== 737 737 738 738 #else … … 751 751 END SUBROUTINE lim_var_salprof 752 752 SUBROUTINE lim_var_bv ! Emtpy routines 753 END SUBROUTINE lim_var_bv 753 END SUBROUTINE lim_var_bv 754 754 SUBROUTINE lim_var_salprof1d ! Emtpy routines 755 755 END SUBROUTINE lim_var_salprof1d -
trunk/NEMO/LIM_SRC_3/limwri.F90
r888 r921 85 85 !!------------------------------------------------------------------- 86 86 INTEGER, INTENT(in) :: & 87 87 kindic ! if kindic < 0 there has been an error somewhere 88 88 89 89 !! * Local variables 90 90 REAL(wp),DIMENSION(1) :: zdept 91 91 92 92 REAL(wp) :: & 93 93 zsto, zsec, zjulian,zout, & … … 96 96 zcmo, & 97 97 zcmoa ! additional fields 98 98 99 99 REAL(wp), DIMENSION(jpi,jpj) :: & 100 100 zfield … … 118 118 ndexitd 119 119 !!------------------------------------------------------------------- 120 120 121 121 ipl = jpl 122 122 … … 124 124 125 125 CALL lim_wri_init 126 126 127 127 WRITE(numout,*) ' lim_wri, first time step ' 128 128 WRITE(numout,*) ' add_diag_swi ', add_diag_swi … … 135 135 ! Normal file 136 136 !------------- 137 137 138 138 zsto = rdt_ice 139 139 clop = "ave(x)" … … 148 148 CALL histvert( nice, "deptht", "Vertical T levels", "m", 1, zdept, ndepid) 149 149 CALL wheneq ( jpij , tmask(:,:,1), 1, 1., ndex51, ndim) 150 150 151 151 DO jf = 1 , noumef 152 152 WRITE(numout,*) 'jf', jf … … 160 160 161 161 CALL histend(nice) 162 162 163 163 !----------------- 164 164 ! ITD file output … … 173 173 CALL dia_nam ( clhstnama, nwrite, 'icemoa' ) 174 174 CALL histbeg ( clhstnama, jpi, glamt, jpj, gphit, & 175 176 177 178 175 1, jpi, 1, jpj, & ! zoom 176 0, zjulian, rdt_ice, & ! time 177 nhorida, & ! ? linked with horizontal ... 178 nicea , domain_id=nidom) ! file 179 179 CALL histvert( nicea, "icethi", "L levels", & 180 180 "m", ipl , hi_mean , nz ) 181 181 DO jl = 1, jpl 182 182 zmaskitd(:,:,jl) = tmask(:,:,1) … … 185 185 CALL wheneq( jpi*jpj*jpl, zmaskitd, 1, 1., ndexitd, ndimitd ) 186 186 CALL histdef( nicea, "iice_itd", "Ice area in categories" , "-" , & 187 187 jpi, jpj, nhorida, jpl, 1, jpl, nz, 15, clop, zsto, zout ) 188 188 CALL histdef( nicea, "iice_hid", "Ice thickness in categories" , "m" , & 189 189 jpi, jpj, nhorida, jpl, 1, jpl, nz, 15, clop, zsto, zout ) 190 190 CALL histdef( nicea, "iice_hsd", "Snow depth in in categories" , "m" , & 191 191 jpi, jpj, nhorida, jpl, 1, jpl, nz, 15, clop, zsto, zout ) 192 192 CALL histdef( nicea, "iice_std", "Ice salinity distribution" , "ppt" , & 193 193 jpi, jpj, nhorida, jpl, 1, jpl, nz, 15, clop, zsto, zout ) 194 194 CALL histdef( nicea, "iice_otd", "Ice age distribution" , "days", & 195 195 jpi, jpj, nhorida, jpl, 1, jpl, nz, 15, clop, zsto, zout ) 196 196 CALL histdef( nicea, "iice_etd", "Brine volume distr. " , "%" , & 197 197 jpi, jpj, nhorida, jpl, 1, jpl, nz, 15, clop, zsto, zout ) 198 198 CALL histend(nicea) 199 199 ENDIF 200 201 ! !-----------------------------------------------------------------------!202 ! !--2. Computation of instantaneous values !203 ! !-----------------------------------------------------------------------!204 205 !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++200 201 ! !-----------------------------------------------------------------------! 202 ! !--2. Computation of instantaneous values ! 203 ! !-----------------------------------------------------------------------! 204 205 !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 206 206 IF(lwp) THEN 207 207 WRITE(numout,*) … … 210 210 WRITE(numout,*) ' kindic = ', kindic 211 211 ENDIF 212 !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++212 !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 213 213 214 214 !-- calculs des valeurs instantanees … … 229 229 230 230 CALL lim_var_bv 231 231 232 232 DO jj = 2 , jpjm1 233 233 DO ji = 2 , jpim1 … … 240 240 zcmo(ji,jj,3) = vt_s(ji,jj)/MAX(at_i(ji,jj),epsi16)*zinda 241 241 zcmo(ji,jj,4) = diag_bot_gr(ji,jj) * & 242 242 86400.0 * zinda !Bottom thermodynamic ice production 243 243 zcmo(ji,jj,5) = diag_dyn_gr(ji,jj) * & 244 244 86400.0 * zinda !Dynamic ice production (rid/raft) 245 245 zcmo(ji,jj,22) = diag_lat_gr(ji,jj) * & 246 246 86400.0 * zinda !Lateral thermodynamic ice production 247 247 zcmo(ji,jj,23) = diag_sni_gr(ji,jj) * & 248 248 86400.0 * zinda !Snow ice production ice production 249 249 zcmo(ji,jj,24) = tm_i(ji,jj) - rtt 250 250 251 251 zcmo(ji,jj,6) = fbif (ji,jj) 252 252 zcmo(ji,jj,7) = zindb * ( u_ice(ji,jj ) * tmu(ji,jj) & 253 & + u_ice(ji-1,jj) * tmu(ji-1,jj) ) &254 & / 2.0253 & + u_ice(ji-1,jj) * tmu(ji-1,jj) ) & 254 & / 2.0 255 255 zcmo(ji,jj,8) = zindb * ( v_ice(ji,jj ) * tmv(ji,jj) & 256 & + v_ice(ji,jj-1) * tmv(ji,jj-1) ) &257 & / 2.0256 & + v_ice(ji,jj-1) * tmv(ji,jj-1) ) & 257 & / 2.0 258 258 zcmo(ji,jj,9) = sst_m(ji,jj) 259 259 zcmo(ji,jj,10) = sss_m(ji,jj) … … 274 274 zcmo(ji,jj,28) = fsbri(ji,jj) 275 275 zcmo(ji,jj,29) = fseqv(ji,jj) 276 276 277 277 zcmo(ji,jj,30) = bv_i(ji,jj) 278 278 zcmo(ji,jj,31) = hicol(ji,jj) 279 279 zcmo(ji,jj,32) = strength(ji,jj) 280 280 zcmo(ji,jj,33) = SQRT( zcmo(ji,jj,7)*zcmo(ji,jj,7) + & 281 281 zcmo(ji,jj,8)*zcmo(ji,jj,8) ) 282 282 zcmo(ji,jj,34) = diag_sur_me(ji,jj) * & 283 283 86400.0 * zinda ! Surface melt 284 284 zcmo(ji,jj,35) = diag_bot_me(ji,jj) * & 285 285 86400.0 * zinda ! Bottom melt 286 286 zcmo(ji,jj,36) = divu_i(ji,jj) 287 287 zcmo(ji,jj,37) = shear_i(ji,jj) … … 299 299 END DO 300 300 END DO 301 301 302 302 IF ( jf == 7 .OR. jf == 8 .OR. jf == 15 .OR. jf == 16 ) THEN 303 303 CALL lbc_lnk( zfield, 'T', -1. ) … … 306 306 ENDIF 307 307 308 !+++++308 !+++++ 309 309 WRITE(numout,*) 310 310 WRITE(numout,*) 'nc(jf), nice, nam(jf), niter, ndim' 311 311 WRITE(numout,*) nc(jf), nice, nam(jf), niter, ndim 312 !+++++312 !+++++ 313 313 IF ( nc(jf) == 1 ) CALL histwrite( nice, nam(jf), niter, zfield, ndim, ndex51 ) 314 314 315 315 END DO 316 316 317 317 IF ( ( nn_fsbc * niter + nit000 - 1 ) >= nitend .OR. kindic < 0 ) THEN 318 319 318 WRITE(numout,*) ' Closing the icemod file ' 319 CALL histclo( nice ) 320 320 ENDIF 321 321 … … 325 325 IF ( add_diag_swi .EQ. 1 ) THEN 326 326 327 DO jl = 1, jpl 328 CALL lbc_lnk( a_i(:,:,jl) , 'T' , 1. ) 329 CALL lbc_lnk( sm_i(:,:,jl) , 'T' , 1. ) 330 CALL lbc_lnk( oa_i(:,:,jl) , 'T' , 1. ) 331 CALL lbc_lnk( ht_i(:,:,jl) , 'T' , 1. ) 332 CALL lbc_lnk( ht_s(:,:,jl) , 'T' , 1. ) 333 END DO 334 335 ! Compute ice age 336 DO jl = 1, jpl 337 DO jj = 1, jpj 338 DO ji = 1, jpi 339 zinda = MAX( zzero , SIGN( zone , a_i(ji,jj,jl) - 1.0e-6 ) ) 340 zoi(ji,jj,jl) = oa_i(ji,jj,jl) / MAX( a_i(ji,jj,jl) , 1.0e-6 ) * & 341 zinda 342 END DO 343 END DO 344 END DO 345 346 ! Compute brine volume 347 zei(:,:,:) = 0.0 348 DO jl = 1, jpl 349 DO jk = 1, nlay_i 327 DO jl = 1, jpl 328 CALL lbc_lnk( a_i(:,:,jl) , 'T' , 1. ) 329 CALL lbc_lnk( sm_i(:,:,jl) , 'T' , 1. ) 330 CALL lbc_lnk( oa_i(:,:,jl) , 'T' , 1. ) 331 CALL lbc_lnk( ht_i(:,:,jl) , 'T' , 1. ) 332 CALL lbc_lnk( ht_s(:,:,jl) , 'T' , 1. ) 333 END DO 334 335 ! Compute ice age 336 DO jl = 1, jpl 350 337 DO jj = 1, jpj 351 338 DO ji = 1, jpi 352 339 zinda = MAX( zzero , SIGN( zone , a_i(ji,jj,jl) - 1.0e-6 ) ) 353 zei(ji,jj,jl) = zei(ji,jj,jl) + 100.0* & 354 ( - tmut * s_i(ji,jj,jk,jl) / MIN( ( t_i(ji,jj,jk,jl) - rtt ), -1.0e-6 ) ) * & 355 zinda / nlay_i 340 zoi(ji,jj,jl) = oa_i(ji,jj,jl) / MAX( a_i(ji,jj,jl) , 1.0e-6 ) * & 341 zinda 356 342 END DO 357 343 END DO 358 344 END DO 359 END DO 360 361 DO jl = 1, jpl 362 CALL lbc_lnk( zei(:,:,jl) , 'T' , 1. ) 363 END DO 364 365 CALL histwrite( nicea, "iice_itd", niter, a_i , ndimitd , ndexitd ) ! area 366 CALL histwrite( nicea, "iice_hid", niter, ht_i , ndimitd , ndexitd ) ! thickness 367 CALL histwrite( nicea, "iice_hsd", niter, ht_s , ndimitd , ndexitd ) ! snow depth 368 CALL histwrite( nicea, "iice_std", niter, sm_i , ndimitd , ndexitd ) ! salinity 369 CALL histwrite( nicea, "iice_otd", niter, zoi , ndimitd , ndexitd ) ! age 370 CALL histwrite( nicea, "iice_etd", niter, zei , ndimitd , ndexitd ) ! brine volume 371 372 ! ! Create an output files (output.lim.abort.nc) if S < 0 or u > 20 m/s 373 ! IF( kindic < 0 ) CALL lim_wri_state( 'output.abort' ) 374 ! not yet implemented 375 376 IF ( ( nn_fsbc * niter + nit000 - 1 ) >= nitend .OR. kindic < 0 ) THEN 377 WRITE(numout,*) ' Closing the icemod file ' 378 CALL histclo( nicea ) 379 ENDIF 345 346 ! Compute brine volume 347 zei(:,:,:) = 0.0 348 DO jl = 1, jpl 349 DO jk = 1, nlay_i 350 DO jj = 1, jpj 351 DO ji = 1, jpi 352 zinda = MAX( zzero , SIGN( zone , a_i(ji,jj,jl) - 1.0e-6 ) ) 353 zei(ji,jj,jl) = zei(ji,jj,jl) + 100.0* & 354 ( - tmut * s_i(ji,jj,jk,jl) / MIN( ( t_i(ji,jj,jk,jl) - rtt ), -1.0e-6 ) ) * & 355 zinda / nlay_i 356 END DO 357 END DO 358 END DO 359 END DO 360 361 DO jl = 1, jpl 362 CALL lbc_lnk( zei(:,:,jl) , 'T' , 1. ) 363 END DO 364 365 CALL histwrite( nicea, "iice_itd", niter, a_i , ndimitd , ndexitd ) ! area 366 CALL histwrite( nicea, "iice_hid", niter, ht_i , ndimitd , ndexitd ) ! thickness 367 CALL histwrite( nicea, "iice_hsd", niter, ht_s , ndimitd , ndexitd ) ! snow depth 368 CALL histwrite( nicea, "iice_std", niter, sm_i , ndimitd , ndexitd ) ! salinity 369 CALL histwrite( nicea, "iice_otd", niter, zoi , ndimitd , ndexitd ) ! age 370 CALL histwrite( nicea, "iice_etd", niter, zei , ndimitd , ndexitd ) ! brine volume 371 372 ! ! Create an output files (output.lim.abort.nc) if S < 0 or u > 20 m/s 373 ! IF( kindic < 0 ) CALL lim_wri_state( 'output.abort' ) 374 ! not yet implemented 375 376 IF ( ( nn_fsbc * niter + nit000 - 1 ) >= nitend .OR. kindic < 0 ) THEN 377 WRITE(numout,*) ' Closing the icemod file ' 378 CALL histclo( nicea ) 379 ENDIF 380 380 381 381 ENDIF … … 472 472 zfield(36) = field_36 473 473 zfield(37) = field_37 474 474 475 475 DO nf = 1, noumef 476 476 titn (nf) = zfield(nf)%ztitle … … 495 495 WRITE(numout,*) ' add_diag_swi ', add_diag_swi 496 496 ENDIF 497 497 498 498 END SUBROUTINE lim_wri_init 499 499 -
trunk/NEMO/LIM_SRC_3/limwri_dimg.h90
r888 r921 1 1 SUBROUTINE lim_wri 2 2 !!---------------------------------------------------------------------- 3 3 !! LIM 2.0, UCL-LOCEAN-IPSL (2005) … … 5 5 !! This software is governed by the CeCILL licence see modipsl/doc/NEMO_CeCILL.txt 6 6 !!---------------------------------------------------------------------- 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 7 !!------------------------------------------------------------------- 8 !! This routine computes the average of some variables and write it 9 !! on the ouput files. 10 !! ATTENTION cette routine n'est valable que si le pas de temps est 11 !! egale a une fraction entiere de 1 jours. 12 !! Diff 1-D 3-D : suppress common also included in etat 13 !! suppress cmoymo 11-18 14 !! modif : 03/06/98 15 !!------------------------------------------------------------------- 16 !! * Local variables 17 USE diawri, ONLY : dia_wri_dimg 18 REAL(wp),DIMENSION(1) :: zdept 19 20 REAL(wp) :: & 21 zsto, zsec, zjulian,zout, & 22 zindh,zinda,zindb, & 23 ztmu 24 REAL(wp), DIMENSION(jpi,jpj,jpnoumax) :: & 25 zcmo 26 REAL(wp), DIMENSION(jpi,jpj) :: & 27 zfield 28 INTEGER, SAVE :: nmoyice, & !: counter for averaging 29 & nwf !: number of fields to write on disk 30 INTEGER, SAVE,DIMENSION (:), ALLOCATABLE :: nsubindex !: subindex to be saved 31 ! according to namelist 32 33 REAL(wp), SAVE, DIMENSION(jpi,jpj,jpnoumax) :: rcmoy 34 34 #if ! defined key_diainstant 35 35 LOGICAL, PARAMETER :: ll_dia_inst=.false. ! local logical variable 36 36 #else 37 37 LOGICAL, PARAMETER :: ll_dia_inst=.true. 38 38 #endif 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 39 INTEGER :: ji, jj, jf, ii ! dummy loop indices and array index 40 INTEGER :: iyear, iday, imon ! 41 42 CHARACTER(LEN=80) :: clname, cltext, clmode 43 44 45 INTEGER , SAVE :: & 46 nice, nhorid, ndim, niter, ndepid 47 INTEGER , DIMENSION( jpij ) , SAVE :: & 48 ndex51 49 !!------------------------------------------------------------------- 50 IF ( numit == nstart ) THEN 51 52 CALL lim_wri_init 53 54 nwf = 0 55 ii = 0 56 57 IF (lwp ) THEN 58 WRITE(numout,*) 'lim_wri : Write ice outputs in dimg' 59 WRITE(numout,*) '~~~~~~~~' 60 WRITE(numout,*) ' According to namelist_ice, following fields saved:' 61 DO jf =1, noumef 62 IF (nc(jf) == 1 ) THEN 63 WRITE(numout,* ) ' -',titn(jf), nam(jf), uni(jf) 64 ENDIF 65 END DO 66 ENDIF 67 68 DO jf = 1, noumef 69 IF (nc(jf) == 1 ) nwf = nwf + 1 70 END DO 71 72 ALLOCATE( nsubindex (nwf) ) 73 74 DO jf = 1, noumef 75 IF (nc(jf) == 1 ) THEN 76 ii = ii +1 77 nsubindex(ii) = jf 78 END IF 79 END DO 80 81 zsto = rdt_ice 82 zout = nwrite * rdt_ice / nn_fsbc 83 zsec = 0. 84 niter = 0 85 zdept(1) = 0. 86 nmoyice = 0 87 88 ENDIF 89 89 90 90 #if ! defined key_diainstant 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 91 !-- calculs des valeurs instantanees 92 93 zcmo(:,:, 1:jpnoumax ) = 0.e0 94 DO jj = 2 , jpjm1 95 DO ji = 2 , jpim1 96 zindh = MAX( zzero , SIGN( zone , ht_i(ji,jj,1) * (1.0 - frld(ji,jj) ) - 0.10 ) ) 97 zinda = MAX( zzero , SIGN( zone , ( 1.0 - frld(ji,jj) ) - 0.10 ) ) 98 zindb = zindh * zinda 99 ztmu = MAX( 0.5 * zone , ( tmu(ji,jj) + tmu(ji+1,jj) + tmu(ji,jj+1) + tmu(ji+1,jj+1) ) ) 100 zcmo(ji,jj,1) = ht_s (ji,jj,1) 101 zcmo(ji,jj,2) = ht_i (ji,jj,1) 102 zcmo(ji,jj,3) = hicifp(ji,jj) 103 zcmo(ji,jj,4) = frld (ji,jj) 104 zcmo(ji,jj,5) = sist (ji,jj) 105 zcmo(ji,jj,6) = fbif (ji,jj) 106 zcmo(ji,jj,7) = zindb * ( u_ice(ji,jj ) * tmu(ji,jj ) + u_ice(ji+1,jj ) * tmu(ji+1,jj ) & 107 + u_ice(ji,jj+1) * tmu(ji,jj+1) + u_ice(ji+1,jj+1) * tmu(ji+1,jj+1) ) & 108 / ztmu 109 110 zcmo(ji,jj,8) = zindb * ( v_ice(ji,jj ) * tmu(ji,jj ) + v_ice(ji+1,jj ) * tmu(ji+1,jj ) & 111 + v_ice(ji,jj+1) * tmu(ji,jj+1) + v_ice(ji+1,jj+1) * tmu(ji+1,jj+1) ) & 112 / ztmu 113 zcmo(ji,jj,9) = sst_m(ji,jj) 114 zcmo(ji,jj,10) = sss_m(ji,jj) 115 116 zcmo(ji,jj,11) = qns(ji,jj) + qsr(ji,jj) 117 zcmo(ji,jj,12) = qsr(ji,jj) 118 zcmo(ji,jj,13) = qns(ji,jj) 119 ! See thersf for the coefficient 120 zcmo(ji,jj,14) = - emps(ji,jj) * rday * ( sss_m(ji,jj) + epsi16 ) / soce 121 zcmo(ji,jj,15) = utaui_ice(ji,jj) 122 zcmo(ji,jj,16) = vtaui_ice(ji,jj) 123 zcmo(ji,jj,17) = qsr (ji,jj) 124 zcmo(ji,jj,18) = qns(ji,jj) 125 zcmo(ji,jj,19) = sprecip(ji,jj) 126 END DO 127 END DO 128 ! Cumulates values between outputs 129 rcmoy(:,:,:)= rcmoy(:,:,:) + zcmo(:,:,:) 130 nmoyice = nmoyice + 1 131 ! compute mean value if it is time to write on file 132 IF ( MOD(numit,nwrite) == 0 ) THEN 133 rcmoy(:,:,:) = rcmoy(:,:,:) / FLOAT(nmoyice) 134 134 #else 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 135 IF ( MOD(numit,nwrite) == 0 ) THEN 136 ! case of instantaneaous output rcmoy(:,:, 1:jpnoumax ) = 0.e0 137 DO jj = 2 , jpjm1 138 DO ji = 2 , jpim1 139 zindh = MAX( zzero , SIGN( zone , ht_i(ji,jj,1) * (1.0 - frld(ji,jj) ) - 0.10 ) ) 140 zinda = MAX( zzero , SIGN( zone , ( 1.0 - frld(ji,jj) ) - 0.10 ) ) 141 zindb = zindh * zinda 142 ztmu = MAX( 0.5 * zone , ( tmu(ji,jj) + tmu(ji+1,jj) + tmu(ji,jj+1) + tmu(ji+1,jj+1) ) ) 143 rcmoy(ji,jj,1) = ht_s (ji,jj,1) 144 rcmoy(ji,jj,2) = ht_i (ji,jj,1) 145 rcmoy(ji,jj,3) = hicifp(ji,jj) 146 rcmoy(ji,jj,4) = frld (ji,jj) 147 rcmoy(ji,jj,5) = sist (ji,jj) 148 rcmoy(ji,jj,6) = fbif (ji,jj) 149 rcmoy(ji,jj,7) = zindb * ( u_ice(ji,jj ) * tmu(ji,jj ) + u_ice(ji+1,jj ) * tmu(ji+1,jj ) & 150 + u_ice(ji,jj+1) * tmu(ji,jj+1) + u_ice(ji+1,jj+1) * tmu(ji+1,jj+1) ) & 151 / ztmu 152 153 rcmoy(ji,jj,8) = zindb * ( v_ice(ji,jj ) * tmu(ji,jj ) + v_ice(ji+1,jj ) * tmu(ji+1,jj ) & 154 + v_ice(ji,jj+1) * tmu(ji,jj+1) + v_ice(ji+1,jj+1) * tmu(ji+1,jj+1) ) & 155 / ztmu 156 rcmoy(ji,jj,9) = sst_m(ji,jj) 157 rcmoy(ji,jj,10) = sss_m(ji,jj) 158 159 rcmoy(ji,jj,11) = qns(ji,jj) + qsr(ji,jj) 160 rcmoy(ji,jj,12) = qsr(ji,jj) 161 rcmoy(ji,jj,13) = qns(ji,jj) 162 ! See thersf for the coefficient 163 rcmoy(ji,jj,14) = - emps(ji,jj) * rday * ( sss_m(ji,jj) + epsi16 ) / soce 164 rcmoy(ji,jj,15) = utaui_ice(ji,jj) 165 rcmoy(ji,jj,16) = vtaui_ice(ji,jj) 166 rcmoy(ji,jj,17) = qsr(ji,jj) 167 rcmoy(ji,jj,18) = qns(ji,jj) 168 rcmoy(ji,jj,19) = sprecip(ji,jj) 169 END DO 170 END DO 171 171 #endif 172 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 clmode='instantaneous'188 189 WRITE(clmode,'(f5.1,a)' ) nwrite*rdt/86400.,' days average'190 191 192 193 194 195 196 197 9000 198 199 200 201 202 203 173 ! 174 niter = niter + 1 175 DO jf = 1 , noumef 176 zfield(:,:) = (rcmoy(:,:,jf) * cmulti(jf) + cadd(jf)) * tmask(:,:,1) 177 178 IF ( jf == 7 .OR. jf == 8 .OR. jf == 15 .OR. jf == 16 ) THEN 179 CALL lbc_lnk( zfield, 'T', -1. ) 180 ELSE 181 CALL lbc_lnk( zfield, 'T', 1. ) 182 ENDIF 183 rcmoy(:,:,jf) = zfield(:,:) 184 END DO 185 186 IF (ll_dia_inst) THEN 187 clmode='instantaneous' 188 ELSE 189 WRITE(clmode,'(f5.1,a)' ) nwrite*rdt/86400.,' days average' 190 END IF 191 iyear = ndastp/10000 192 imon = (ndastp-iyear*10000)/100 193 iday = ndastp - imon*100 - iyear*10000 194 WRITE(clname,9000) TRIM(cexper),'ICEMOD',iyear,imon,iday 195 cltext=TRIM(cexper)//' ice modele output'//TRIM(clmode) 196 CALL dia_wri_dimg (clname, cltext, rcmoy, nwf , 'I', nsubindex) 197 9000 FORMAT(a,"_",a,"_y",i4.4,"m",i2.2,"d",i2.2,".dimgproc") 198 199 rcmoy(:,:,:) = 0.0 200 nmoyice = 0 201 END IF ! MOD(numit, nwrite == 0 ) ! 202 203 END SUBROUTINE lim_wri -
trunk/NEMO/LIM_SRC_3/par_ice.F90
r888 r921 23 23 jkmax = 6 , & !: maximum number of ice layers 24 24 nlay_s = 1 !: number of snow layers 25 25 26 26 !ICE MECHANICAL REDISTRIBUTION 27 27 INTEGER , PARAMETER :: & !: -
trunk/NEMO/LIM_SRC_3/thd_ice.F90
r888 r921 22 22 REAL(wp) , PUBLIC :: & !!! ** ice-thermo namelist (namicethd) ** 23 23 hmelt = -0.15 , & !: maximum melting at the bottom; active only for 24 !: one category24 !: one category 25 25 hicmin = 0.2 , & !: (REMOVE) 26 26 hiclim = 0.05 , & !: minimum ice thickness … … 84 84 qla_ice_1d , & !: " " qla_ice 85 85 dqla_ice_1d , & !: " " dqla_ice 86 ! to reintegrate longwave flux inside the ice thermodynamics86 ! to reintegrate longwave flux inside the ice thermodynamics 87 87 qtur_ice_1d , & !: " " qtur_ice 88 88 dqtu_ice_1d , & !: " " dqtu_ice … … 130 130 q_s_b !: Snow enthalpy per unit volume 131 131 132 ! Clean the following ...133 ! These variables are coded for conservation checks132 ! Clean the following ... 133 ! These variables are coded for conservation checks 134 134 REAL(wp), PUBLIC, DIMENSION(jpij,jpl) :: & ! 135 135 qt_i_in , & !: ice energy summed over categories (initial)
Note: See TracChangeset
for help on using the changeset viewer.