- Timestamp:
- 2017-09-27T12:09:10+02:00 (7 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2017/dev_r8183_ICEMODEL/NEMOGCM/NEMO/LIM_SRC_3/icethd_do.F90
r8564 r8565 222 222 !------------------------------------- 223 223 ! This occurs if open water energy budget is negative (cooling) and there is no landfast ice 224 n idx = 0 ; idxice(:) = 0224 npti = 0 ; nptidx(:) = 0 225 225 DO jj = 1, jpj 226 226 DO ji = 1, jpi 227 227 IF ( qlead(ji,jj) < 0._wp .AND. tau_icebfr(ji,jj) == 0._wp ) THEN 228 n idx = nidx+ 1229 idxice( nidx) = (jj - 1) * jpi + ji228 npti = npti + 1 229 nptidx( npti ) = (jj - 1) * jpi + ji 230 230 ENDIF 231 231 END DO … … 237 237 ! If ocean gains heat do nothing. Otherwise compute new ice formation 238 238 239 IF ( n idx> 0 ) THEN240 241 CALL tab_2d_1d( n idx, idxice(1:nidx), at_i_1d(1:nidx) , at_i )242 CALL tab_3d_2d( n idx, idxice(1:nidx), a_i_2d (1:nidx,1:jpl), a_i (:,:,:) )243 CALL tab_3d_2d( n idx, idxice(1:nidx), v_i_2d (1:nidx,1:jpl), v_i (:,:,:) )244 CALL tab_3d_2d( n idx, idxice(1:nidx), sv_i_2d(1:nidx,1:jpl), sv_i(:,:,:) )239 IF ( npti > 0 ) THEN 240 241 CALL tab_2d_1d( npti, nptidx(1:npti), at_i_1d(1:npti) , at_i ) 242 CALL tab_3d_2d( npti, nptidx(1:npti), a_i_2d (1:npti,1:jpl), a_i (:,:,:) ) 243 CALL tab_3d_2d( npti, nptidx(1:npti), v_i_2d (1:npti,1:jpl), v_i (:,:,:) ) 244 CALL tab_3d_2d( npti, nptidx(1:npti), sv_i_2d(1:npti,1:jpl), sv_i(:,:,:) ) 245 245 DO jl = 1, jpl 246 246 DO jk = 1, nlay_i 247 CALL tab_2d_1d( n idx, idxice(1:nidx), ze_i_2d(1:nidx,jk,jl), e_i(:,:,jk,jl) )248 END DO 249 END DO 250 CALL tab_2d_1d( n idx, idxice(1:nidx), qlead_1d (1:nidx) , qlead )251 CALL tab_2d_1d( n idx, idxice(1:nidx), t_bo_1d (1:nidx) , t_bo )252 CALL tab_2d_1d( n idx, idxice(1:nidx), sfx_opw_1d(1:nidx) , sfx_opw )253 CALL tab_2d_1d( n idx, idxice(1:nidx), wfx_opw_1d(1:nidx) , wfx_opw )254 CALL tab_2d_1d( n idx, idxice(1:nidx), zh_newice (1:nidx) , ht_i_new )255 CALL tab_2d_1d( n idx, idxice(1:nidx), zvrel_1d (1:nidx) , zvrel )256 257 CALL tab_2d_1d( n idx, idxice(1:nidx), hfx_thd_1d(1:nidx) , hfx_thd )258 CALL tab_2d_1d( n idx, idxice(1:nidx), hfx_opw_1d(1:nidx) , hfx_opw )259 CALL tab_2d_1d( n idx, idxice(1:nidx), rn_amax_1d(1:nidx) , rn_amax_2d )260 CALL tab_2d_1d( n idx, idxice(1:nidx), sss_1d (1:nidx) , sss_m )247 CALL tab_2d_1d( npti, nptidx(1:npti), ze_i_2d(1:npti,jk,jl), e_i(:,:,jk,jl) ) 248 END DO 249 END DO 250 CALL tab_2d_1d( npti, nptidx(1:npti), qlead_1d (1:npti) , qlead ) 251 CALL tab_2d_1d( npti, nptidx(1:npti), t_bo_1d (1:npti) , t_bo ) 252 CALL tab_2d_1d( npti, nptidx(1:npti), sfx_opw_1d(1:npti) , sfx_opw ) 253 CALL tab_2d_1d( npti, nptidx(1:npti), wfx_opw_1d(1:npti) , wfx_opw ) 254 CALL tab_2d_1d( npti, nptidx(1:npti), zh_newice (1:npti) , ht_i_new ) 255 CALL tab_2d_1d( npti, nptidx(1:npti), zvrel_1d (1:npti) , zvrel ) 256 257 CALL tab_2d_1d( npti, nptidx(1:npti), hfx_thd_1d(1:npti) , hfx_thd ) 258 CALL tab_2d_1d( npti, nptidx(1:npti), hfx_opw_1d(1:npti) , hfx_opw ) 259 CALL tab_2d_1d( npti, nptidx(1:npti), rn_amax_1d(1:npti) , rn_amax_2d ) 260 CALL tab_2d_1d( npti, nptidx(1:npti), sss_1d (1:npti) , sss_m ) 261 261 262 262 !------------------------------------------------------------------------------| … … 265 265 DO jl = 1, jpl 266 266 DO jk = 1, nlay_i 267 WHERE( v_i_2d(1:n idx,jl) > 0._wp )268 ze_i_2d(1:n idx,jk,jl) = ze_i_2d(1:nidx,jk,jl) / v_i_2d(1:nidx,jl) * REAL( nlay_i )267 WHERE( v_i_2d(1:npti,jl) > 0._wp ) 268 ze_i_2d(1:npti,jk,jl) = ze_i_2d(1:npti,jk,jl) / v_i_2d(1:npti,jl) * REAL( nlay_i ) 269 269 ELSEWHERE 270 ze_i_2d(1:n idx,jk,jl) = 0._wp270 ze_i_2d(1:npti,jk,jl) = 0._wp 271 271 END WHERE 272 272 END DO … … 279 279 ! Keep old ice areas and volume in memory 280 280 !----------------------------------------- 281 zv_b(1:n idx,:) = v_i_2d(1:nidx,:)282 za_b(1:n idx,:) = a_i_2d(1:nidx,:)281 zv_b(1:npti,:) = v_i_2d(1:npti,:) 282 za_b(1:npti,:) = a_i_2d(1:npti,:) 283 283 284 284 !---------------------- … … 287 287 SELECT CASE ( nn_icesal ) 288 288 CASE ( 1 ) ! Sice = constant 289 zs_newice(1:n idx) = rn_icesal289 zs_newice(1:npti) = rn_icesal 290 290 CASE ( 2 ) ! Sice = F(z,t) [Vancoppenolle et al (2005)] 291 DO ji = 1, n idx291 DO ji = 1, npti 292 292 zs_newice(ji) = MIN( 4.606 + 0.91 / zh_newice(ji) , rn_simax , 0.5 * sss_1d(ji) ) 293 293 END DO 294 294 CASE ( 3 ) ! Sice = F(z) [multiyear ice] 295 zs_newice(1:n idx) = 2.3295 zs_newice(1:npti) = 2.3 296 296 END SELECT 297 297 … … 300 300 !------------------------- 301 301 ! We assume that new ice is formed at the seawater freezing point 302 DO ji = 1, n idx302 DO ji = 1, npti 303 303 ztmelts = - tmut * zs_newice(ji) ! Melting point (C) 304 304 ze_newice(ji) = rhoic * ( cpic * ( ztmelts - ( t_bo_1d(ji) - rt0 ) ) & … … 310 310 ! Age of new ice 311 311 !---------------- 312 zo_newice(1:n idx) = 0._wp312 zo_newice(1:npti) = 0._wp 313 313 314 314 !------------------- 315 315 ! Volume of new ice 316 316 !------------------- 317 DO ji = 1, n idx317 DO ji = 1, npti 318 318 319 319 zEi = - ze_newice(ji) * r1_rhoic ! specific enthalpy of forming ice [J/kg] … … 340 340 END DO 341 341 342 zv_frazb(1:n idx) = 0._wp342 zv_frazb(1:npti) = 0._wp 343 343 IF( ln_frazil ) THEN 344 344 ! A fraction zfrazb of frazil ice is accreted at the ice bottom 345 DO ji = 1, n idx345 DO ji = 1, npti 346 346 rswitch = 1._wp - MAX( 0._wp, SIGN( 1._wp , - at_i_1d(ji) ) ) 347 347 zfrazb = rswitch * ( TANH( rn_Cfraz * ( zvrel_1d(ji) - rn_vfraz ) ) + 1.0 ) * 0.5 * rn_maxfraz … … 354 354 ! Area of new ice 355 355 !----------------- 356 DO ji = 1, n idx356 DO ji = 1, npti 357 357 za_newice(ji) = zv_newice(ji) / zh_newice(ji) 358 358 END DO … … 367 367 ! If lateral ice growth gives an ice concentration gt 1, then 368 368 ! we keep the excessive volume in memory and attribute it later to bottom accretion 369 DO ji = 1, n idx369 DO ji = 1, npti 370 370 IF ( za_newice(ji) > ( rn_amax_1d(ji) - at_i_1d(ji) ) ) THEN 371 371 zda_res(ji) = za_newice(ji) - ( rn_amax_1d(ji) - at_i_1d(ji) ) … … 381 381 ! find which category to fill 382 382 DO jl = 1, jpl 383 DO ji = 1, n idx383 DO ji = 1, npti 384 384 IF( zh_newice(ji) > hi_max(jl-1) .AND. zh_newice(ji) <= hi_max(jl) ) THEN 385 385 a_i_2d(ji,jl) = a_i_2d(ji,jl) + za_newice(ji) … … 389 389 END DO 390 390 END DO 391 at_i_1d(1:n idx) = SUM( a_i_2d(1:nidx,:), dim=2 )391 at_i_1d(1:npti) = SUM( a_i_2d(1:npti,:), dim=2 ) 392 392 393 393 ! Heat content 394 DO ji = 1, n idx394 DO ji = 1, npti 395 395 jl = jcat(ji) ! categroy in which new ice is put 396 396 zswinew (ji) = MAX( 0._wp , SIGN( 1._wp , - za_b(ji,jl) ) ) ! 0 if old ice … … 398 398 399 399 DO jk = 1, nlay_i 400 DO ji = 1, n idx400 DO ji = 1, npti 401 401 jl = jcat(ji) 402 402 rswitch = MAX( 0._wp, SIGN( 1._wp , v_i_2d(ji,jl) - epsi20 ) ) … … 413 413 414 414 ! for remapping 415 h_i_old (1:n idx,0:nlay_i+1) = 0._wp416 eh_i_old(1:n idx,0:nlay_i+1) = 0._wp415 h_i_old (1:npti,0:nlay_i+1) = 0._wp 416 eh_i_old(1:npti,0:nlay_i+1) = 0._wp 417 417 DO jk = 1, nlay_i 418 DO ji = 1, n idx418 DO ji = 1, npti 419 419 h_i_old (ji,jk) = v_i_2d(ji,jl) * r1_nlay_i 420 420 eh_i_old(ji,jk) = ze_i_2d(ji,jk,jl) * h_i_old(ji,jk) … … 423 423 424 424 ! new volumes including lateral/bottom accretion + residual 425 DO ji = 1, n idx425 DO ji = 1, npti 426 426 rswitch = MAX( 0._wp, SIGN( 1._wp , at_i_1d(ji) - epsi20 ) ) 427 427 zv_newfra = rswitch * ( zdv_res(ji) + zv_frazb(ji) ) * a_i_2d(ji,jl) / MAX( at_i_1d(ji) , epsi20 ) … … 433 433 ENDDO 434 434 ! --- Ice enthalpy remapping --- ! 435 CALL ice_thd_ent( ze_i_2d(1:n idx,:,jl) )435 CALL ice_thd_ent( ze_i_2d(1:npti,:,jl) ) 436 436 ENDDO 437 437 … … 440 440 !----------------- 441 441 DO jl = 1, jpl 442 DO ji = 1, n idx442 DO ji = 1, npti 443 443 sv_i_2d(ji,jl) = sv_i_2d(ji,jl) + zs_newice(ji) * ( v_i_2d(ji,jl) - zv_b(ji,jl) ) 444 444 END DO … … 450 450 DO jl = 1, jpl 451 451 DO jk = 1, nlay_i 452 ze_i_2d(1:n idx,jk,jl) = ze_i_2d(1:nidx,jk,jl) * v_i_2d(1:nidx,jl) * r1_nlay_i452 ze_i_2d(1:npti,jk,jl) = ze_i_2d(1:npti,jk,jl) * v_i_2d(1:npti,jl) * r1_nlay_i 453 453 END DO 454 454 END DO … … 456 456 ! 7) Change 2D vectors to 1D vectors 457 457 !------------------------------------------------------------------------------! 458 CALL tab_2d_3d( n idx, idxice(1:nidx), a_i_2d (1:nidx,1:jpl), a_i (:,:,:) )459 CALL tab_2d_3d( n idx, idxice(1:nidx), v_i_2d (1:nidx,1:jpl), v_i (:,:,:) )460 CALL tab_2d_3d( n idx, idxice(1:nidx), sv_i_2d(1:nidx,1:jpl), sv_i(:,:,:) )458 CALL tab_2d_3d( npti, nptidx(1:npti), a_i_2d (1:npti,1:jpl), a_i (:,:,:) ) 459 CALL tab_2d_3d( npti, nptidx(1:npti), v_i_2d (1:npti,1:jpl), v_i (:,:,:) ) 460 CALL tab_2d_3d( npti, nptidx(1:npti), sv_i_2d(1:npti,1:jpl), sv_i(:,:,:) ) 461 461 DO jl = 1, jpl 462 462 DO jk = 1, nlay_i 463 CALL tab_1d_2d( n idx, idxice(1:nidx), ze_i_2d(1:nidx,jk,jl), e_i(:,:,jk,jl) )464 END DO 465 END DO 466 CALL tab_1d_2d( n idx, idxice(1:nidx), sfx_opw_1d(1:nidx), sfx_opw )467 CALL tab_1d_2d( n idx, idxice(1:nidx), wfx_opw_1d(1:nidx), wfx_opw )468 CALL tab_1d_2d( n idx, idxice(1:nidx), hfx_thd_1d(1:nidx), hfx_thd )469 CALL tab_1d_2d( n idx, idxice(1:nidx), hfx_opw_1d(1:nidx), hfx_opw )463 CALL tab_1d_2d( npti, nptidx(1:npti), ze_i_2d(1:npti,jk,jl), e_i(:,:,jk,jl) ) 464 END DO 465 END DO 466 CALL tab_1d_2d( npti, nptidx(1:npti), sfx_opw_1d(1:npti), sfx_opw ) 467 CALL tab_1d_2d( npti, nptidx(1:npti), wfx_opw_1d(1:npti), wfx_opw ) 468 CALL tab_1d_2d( npti, nptidx(1:npti), hfx_thd_1d(1:npti), hfx_thd ) 469 CALL tab_1d_2d( npti, nptidx(1:npti), hfx_opw_1d(1:npti), hfx_opw ) 470 470 ! 471 ENDIF ! n idx> 0471 ENDIF ! npti > 0 472 472 ! 473 473 IF( ln_icediachk ) CALL ice_cons_hsm(1, 'icethd_do', rdiag_v, rdiag_s, rdiag_t, rdiag_fv, rdiag_fs, rdiag_ft)
Note: See TracChangeset
for help on using the changeset viewer.