Changeset 8327 for branches/2017
- Timestamp:
- 2017-07-13T11:29:29+02:00 (7 years ago)
- Location:
- branches/2017/dev_r8183_ICEMODEL/NEMOGCM/NEMO/LIM_SRC_3
- Files:
-
- 5 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2017/dev_r8183_ICEMODEL/NEMOGCM/NEMO/LIM_SRC_3/limthd.F90
r8326 r8327 83 83 ! 84 84 INTEGER :: ji, jj, jk, jl ! dummy loop indices 85 INTEGER :: n bpb! nb of icy pts for vertical thermo calculations85 INTEGER :: nidx ! nb of icy pts for vertical thermo calculations 86 86 REAL(wp) :: zfric_u, zqld, zqfr, zqfr_neg 87 87 REAL(wp) :: zvi_b, zsmv_b, zei_b, zfs_b, zfw_b, zft_b … … 213 213 214 214 ! select ice covered grid points 215 n bpb= 0216 DO jj = 1, jpj217 DO ji = 1, jpi215 nidx = 0 ; idxice(:) = 0 216 DO jj = 2, jpjm1 217 DO ji = 2, jpim1 218 218 IF ( a_i(ji,jj,jl) > epsi10 ) THEN 219 n bpb = nbpb+ 1220 npb(nbpb) = (jj - 1) * jpi + ji219 nidx = nidx + 1 220 idxice(nidx) = (jj - 1) * jpi + ji 221 221 ENDIF 222 222 END DO … … 234 234 ENDIF 235 235 236 IF( lk_mpp ) CALL mpp_ini_ice( n bpb, numout )237 238 IF( n bpb> 0 ) THEN ! If there is no ice, do nothing.236 IF( lk_mpp ) CALL mpp_ini_ice( nidx , numout ) 237 238 IF( nidx > 0 ) THEN ! If there is no ice, do nothing. 239 239 ! 240 240 s_i_new (:) = 0._wp ; dh_s_tot (:) = 0._wp ! --- some init --- ! … … 242 242 dh_snowice(:) = 0._wp ; dh_i_sub (:) = 0._wp 243 243 244 CALL lim_thd_1d2d( n bpb, jl, 1 ) ! --- Move to 1D arrays --- !244 CALL lim_thd_1d2d( nidx, jl, 1 ) ! --- Move to 1D arrays --- ! 245 245 ! 246 246 DO jk = 1, nlay_i ! --- Change units from J/m2 to J/m3 --- ! … … 251 251 ENDDO 252 252 ! 253 IF( ln_limdH ) CALL lim_thd_dif( 1, n bpb) ! --- Ice/Snow Temperature profile --- !254 ! 255 IF( ln_limdH ) CALL lim_thd_dh( 1, n bpb) ! --- Ice/Snow thickness --- !256 ! 257 IF( ln_limdH ) CALL lim_thd_ent( 1, n bpb, e_i_1d(1:nbpb,:) ) ! --- Ice enthalpy remapping --- !258 ! 259 CALL lim_thd_sal( 1, n bpb) ! --- Ice salinity --- !260 ! 261 CALL lim_thd_temp( 1, n bpb) ! --- temperature update --- !253 IF( ln_limdH ) CALL lim_thd_dif( 1, nidx ) ! --- Ice/Snow Temperature profile --- ! 254 ! 255 IF( ln_limdH ) CALL lim_thd_dh( 1, nidx ) ! --- Ice/Snow thickness --- ! 256 ! 257 IF( ln_limdH ) CALL lim_thd_ent( 1, nidx, e_i_1d(1:nidx,:) ) ! --- Ice enthalpy remapping --- ! 258 ! 259 CALL lim_thd_sal( 1, nidx ) ! --- Ice salinity --- ! 260 ! 261 CALL lim_thd_temp( 1, nidx ) ! --- temperature update --- ! 262 262 ! 263 263 IF( ln_limdH ) THEN 264 264 IF ( ( nn_monocat == 1 .OR. nn_monocat == 4 ) .AND. jpl == 1 ) THEN 265 CALL lim_thd_lam( 1, n bpb) ! --- extra lateral melting if monocat --- !265 CALL lim_thd_lam( 1, nidx ) ! --- extra lateral melting if monocat --- ! 266 266 END IF 267 267 END IF … … 274 274 ENDDO 275 275 ! 276 CALL lim_thd_1d2d( n bpb, jl, 2 ) ! --- Move to 2D arrays --- !276 CALL lim_thd_1d2d( nidx, jl, 2 ) ! --- Move to 2D arrays --- ! 277 277 ! 278 278 IF( lk_mpp ) CALL mpp_comm_free( ncomm_ice ) !RB necessary ?? … … 282 282 283 283 IF( ln_limdA) CALL lim_thd_da ! --- lateral melting --- ! 284 285 at_i(:,:) = SUM( a_i(:,:,:), dim=3 ) 284 286 285 287 ! Change thickness to volume … … 404 406 405 407 406 SUBROUTINE lim_thd_1d2d( n bpb, jl, kn )408 SUBROUTINE lim_thd_1d2d( nidx, jl, kn ) 407 409 !!----------------------------------------------------------------------- 408 410 !! *** ROUTINE lim_thd_1d2d *** … … 411 413 !!----------------------------------------------------------------------- 412 414 INTEGER, INTENT(in) :: kn ! 1= from 2D to 1D ; 2= from 1D to 2D 413 INTEGER, INTENT(in) :: n bpb! size of 1D arrays415 INTEGER, INTENT(in) :: nidx ! size of 1D arrays 414 416 INTEGER, INTENT(in) :: jl ! ice cat 415 417 ! … … 421 423 CASE( 1 ) ! from 2D to 1D 422 424 ! 423 CALL tab_2d_1d( n bpb, at_i_1d (1:nbpb), at_i , jpi, jpj, npb(1:nbpb) )424 CALL tab_2d_1d( n bpb, a_i_1d (1:nbpb), a_i(:,:,jl) , jpi, jpj, npb(1:nbpb) )425 CALL tab_2d_1d( n bpb, ht_i_1d (1:nbpb), ht_i(:,:,jl) , jpi, jpj, npb(1:nbpb) )426 CALL tab_2d_1d( n bpb, ht_s_1d (1:nbpb), ht_s(:,:,jl) , jpi, jpj, npb(1:nbpb) )427 ! 428 CALL tab_2d_1d( n bpb, t_su_1d (1:nbpb), t_su(:,:,jl) , jpi, jpj, npb(1:nbpb) )429 CALL tab_2d_1d( n bpb, sm_i_1d (1:nbpb), sm_i(:,:,jl) , jpi, jpj, npb(1:nbpb) )425 CALL tab_2d_1d( nidx, at_i_1d (1:nidx), at_i , jpi, jpj, idxice(1:nidx) ) 426 CALL tab_2d_1d( nidx, a_i_1d (1:nidx), a_i(:,:,jl) , jpi, jpj, idxice(1:nidx) ) 427 CALL tab_2d_1d( nidx, ht_i_1d (1:nidx), ht_i(:,:,jl) , jpi, jpj, idxice(1:nidx) ) 428 CALL tab_2d_1d( nidx, ht_s_1d (1:nidx), ht_s(:,:,jl) , jpi, jpj, idxice(1:nidx) ) 429 ! 430 CALL tab_2d_1d( nidx, t_su_1d (1:nidx), t_su(:,:,jl) , jpi, jpj, idxice(1:nidx) ) 431 CALL tab_2d_1d( nidx, sm_i_1d (1:nidx), sm_i(:,:,jl) , jpi, jpj, idxice(1:nidx) ) 430 432 DO jk = 1, nlay_s 431 CALL tab_2d_1d( n bpb, t_s_1d(1:nbpb,jk), t_s(:,:,jk,jl) , jpi, jpj, npb(1:nbpb) )432 CALL tab_2d_1d( n bpb, e_s_1d(1:nbpb,jk), e_s(:,:,jk,jl) , jpi, jpj, npb(1:nbpb) )433 CALL tab_2d_1d( nidx, t_s_1d(1:nidx,jk), t_s(:,:,jk,jl) , jpi, jpj, idxice(1:nidx) ) 434 CALL tab_2d_1d( nidx, e_s_1d(1:nidx,jk), e_s(:,:,jk,jl) , jpi, jpj, idxice(1:nidx) ) 433 435 END DO 434 436 DO jk = 1, nlay_i 435 CALL tab_2d_1d( nbpb, t_i_1d(1:nbpb,jk), t_i(:,:,jk,jl) , jpi, jpj, npb(1:nbpb) ) 436 CALL tab_2d_1d( nbpb, e_i_1d(1:nbpb,jk), e_i(:,:,jk,jl) , jpi, jpj, npb(1:nbpb) ) 437 CALL tab_2d_1d( nbpb, s_i_1d(1:nbpb,jk), s_i(:,:,jk,jl) , jpi, jpj, npb(1:nbpb) ) 438 END DO 439 ! 440 CALL tab_2d_1d( nbpb, qprec_ice_1d(1:nbpb), qprec_ice(:,:) , jpi, jpj, npb(1:nbpb) ) 441 CALL tab_2d_1d( nbpb, qevap_ice_1d(1:nbpb), qevap_ice(:,:,jl) , jpi, jpj, npb(1:nbpb) ) 442 CALL tab_2d_1d( nbpb, qsr_ice_1d (1:nbpb), qsr_ice(:,:,jl) , jpi, jpj, npb(1:nbpb) ) 443 CALL tab_2d_1d( nbpb, fr1_i0_1d (1:nbpb), fr1_i0 , jpi, jpj, npb(1:nbpb) ) 444 CALL tab_2d_1d( nbpb, fr2_i0_1d (1:nbpb), fr2_i0 , jpi, jpj, npb(1:nbpb) ) 445 CALL tab_2d_1d( nbpb, qns_ice_1d (1:nbpb), qns_ice(:,:,jl) , jpi, jpj, npb(1:nbpb) ) 446 CALL tab_2d_1d( nbpb, ftr_ice_1d (1:nbpb), ftr_ice(:,:,jl) , jpi, jpj, npb(1:nbpb) ) 447 CALL tab_2d_1d( nbpb, evap_ice_1d (1:nbpb), evap_ice(:,:,jl), jpi, jpj, npb(1:nbpb) ) 448 CALL tab_2d_1d( nbpb, dqns_ice_1d(1:nbpb), dqns_ice(:,:,jl), jpi, jpj, npb(1:nbpb) ) 449 CALL tab_2d_1d( nbpb, t_bo_1d (1:nbpb), t_bo , jpi, jpj, npb(1:nbpb) ) 450 CALL tab_2d_1d( nbpb, sprecip_1d (1:nbpb), sprecip , jpi, jpj, npb(1:nbpb) ) 451 CALL tab_2d_1d( nbpb, fhtur_1d (1:nbpb), fhtur , jpi, jpj, npb(1:nbpb) ) 452 CALL tab_2d_1d( nbpb, qlead_1d (1:nbpb), qlead , jpi, jpj, npb(1:nbpb) ) 453 CALL tab_2d_1d( nbpb, fhld_1d (1:nbpb), fhld , jpi, jpj, npb(1:nbpb) ) 454 ! 455 CALL tab_2d_1d( nbpb, wfx_snw_1d (1:nbpb), wfx_snw , jpi, jpj, npb(1:nbpb) ) 456 CALL tab_2d_1d( nbpb, wfx_snw_sum_1d(1:nbpb), wfx_snw_sum , jpi, jpj, npb(1:nbpb) ) 457 CALL tab_2d_1d( nbpb, wfx_sub_1d (1:nbpb), wfx_sub , jpi, jpj, npb(1:nbpb) ) 458 CALL tab_2d_1d( nbpb, wfx_snw_sub_1d(1:nbpb), wfx_snw_sub , jpi, jpj, npb(1:nbpb) ) 459 CALL tab_2d_1d( nbpb, wfx_ice_sub_1d(1:nbpb), wfx_ice_sub , jpi, jpj, npb(1:nbpb) ) 460 CALL tab_2d_1d( nbpb, wfx_err_sub_1d(1:nbpb), wfx_err_sub , jpi, jpj, npb(1:nbpb) ) 461 ! 462 CALL tab_2d_1d( nbpb, wfx_bog_1d (1:nbpb), wfx_bog , jpi, jpj, npb(1:nbpb) ) 463 CALL tab_2d_1d( nbpb, wfx_bom_1d (1:nbpb), wfx_bom , jpi, jpj, npb(1:nbpb) ) 464 CALL tab_2d_1d( nbpb, wfx_sum_1d (1:nbpb), wfx_sum , jpi, jpj, npb(1:nbpb) ) 465 CALL tab_2d_1d( nbpb, wfx_sni_1d (1:nbpb), wfx_sni , jpi, jpj, npb(1:nbpb) ) 466 CALL tab_2d_1d( nbpb, wfx_res_1d (1:nbpb), wfx_res , jpi, jpj, npb(1:nbpb) ) 467 CALL tab_2d_1d( nbpb, wfx_spr_1d (1:nbpb), wfx_spr , jpi, jpj, npb(1:nbpb) ) 468 ! 469 CALL tab_2d_1d( nbpb, sfx_bog_1d (1:nbpb), sfx_bog , jpi, jpj, npb(1:nbpb) ) 470 CALL tab_2d_1d( nbpb, sfx_bom_1d (1:nbpb), sfx_bom , jpi, jpj, npb(1:nbpb) ) 471 CALL tab_2d_1d( nbpb, sfx_sum_1d (1:nbpb), sfx_sum , jpi, jpj, npb(1:nbpb) ) 472 CALL tab_2d_1d( nbpb, sfx_sni_1d (1:nbpb), sfx_sni , jpi, jpj, npb(1:nbpb) ) 473 CALL tab_2d_1d( nbpb, sfx_bri_1d (1:nbpb), sfx_bri , jpi, jpj, npb(1:nbpb) ) 474 CALL tab_2d_1d( nbpb, sfx_res_1d (1:nbpb), sfx_res , jpi, jpj, npb(1:nbpb) ) 475 CALL tab_2d_1d( nbpb, sfx_sub_1d (1:nbpb), sfx_sub , jpi, jpj,npb(1:nbpb) ) 476 ! 477 CALL tab_2d_1d( nbpb, hfx_thd_1d (1:nbpb), hfx_thd , jpi, jpj, npb(1:nbpb) ) 478 CALL tab_2d_1d( nbpb, hfx_spr_1d (1:nbpb), hfx_spr , jpi, jpj, npb(1:nbpb) ) 479 CALL tab_2d_1d( nbpb, hfx_sum_1d (1:nbpb), hfx_sum , jpi, jpj, npb(1:nbpb) ) 480 CALL tab_2d_1d( nbpb, hfx_bom_1d (1:nbpb), hfx_bom , jpi, jpj, npb(1:nbpb) ) 481 CALL tab_2d_1d( nbpb, hfx_bog_1d (1:nbpb), hfx_bog , jpi, jpj, npb(1:nbpb) ) 482 CALL tab_2d_1d( nbpb, hfx_dif_1d (1:nbpb), hfx_dif , jpi, jpj, npb(1:nbpb) ) 483 CALL tab_2d_1d( nbpb, hfx_opw_1d (1:nbpb), hfx_opw , jpi, jpj, npb(1:nbpb) ) 484 CALL tab_2d_1d( nbpb, hfx_snw_1d (1:nbpb), hfx_snw , jpi, jpj, npb(1:nbpb) ) 485 CALL tab_2d_1d( nbpb, hfx_sub_1d (1:nbpb), hfx_sub , jpi, jpj, npb(1:nbpb) ) 486 CALL tab_2d_1d( nbpb, hfx_err_1d (1:nbpb), hfx_err , jpi, jpj, npb(1:nbpb) ) 487 CALL tab_2d_1d( nbpb, hfx_res_1d (1:nbpb), hfx_res , jpi, jpj, npb(1:nbpb) ) 488 CALL tab_2d_1d( nbpb, hfx_err_dif_1d (1:nbpb), hfx_err_dif , jpi, jpj, npb(1:nbpb) ) 489 CALL tab_2d_1d( nbpb, hfx_err_rem_1d (1:nbpb), hfx_err_rem , jpi, jpj, npb(1:nbpb) ) 490 CALL tab_2d_1d( nbpb, hfx_out_1d (1:nbpb), hfx_out , jpi, jpj, npb(1:nbpb) ) 437 CALL tab_2d_1d( nidx, t_i_1d(1:nidx,jk), t_i(:,:,jk,jl) , jpi, jpj, idxice(1:nidx) ) 438 CALL tab_2d_1d( nidx, e_i_1d(1:nidx,jk), e_i(:,:,jk,jl) , jpi, jpj, idxice(1:nidx) ) 439 CALL tab_2d_1d( nidx, s_i_1d(1:nidx,jk), s_i(:,:,jk,jl) , jpi, jpj, idxice(1:nidx) ) 440 END DO 441 ! 442 CALL tab_2d_1d( nidx, qprec_ice_1d(1:nidx), qprec_ice(:,:) , jpi, jpj, idxice(1:nidx) ) 443 CALL tab_2d_1d( nidx, qevap_ice_1d(1:nidx), qevap_ice(:,:,jl) , jpi, jpj, idxice(1:nidx) ) 444 CALL tab_2d_1d( nidx, qsr_ice_1d (1:nidx), qsr_ice(:,:,jl) , jpi, jpj, idxice(1:nidx) ) 445 CALL tab_2d_1d( nidx, fr1_i0_1d (1:nidx), fr1_i0 , jpi, jpj, idxice(1:nidx) ) 446 CALL tab_2d_1d( nidx, fr2_i0_1d (1:nidx), fr2_i0 , jpi, jpj, idxice(1:nidx) ) 447 CALL tab_2d_1d( nidx, qns_ice_1d (1:nidx), qns_ice(:,:,jl) , jpi, jpj, idxice(1:nidx) ) 448 CALL tab_2d_1d( nidx, ftr_ice_1d (1:nidx), ftr_ice(:,:,jl) , jpi, jpj, idxice(1:nidx) ) 449 CALL tab_2d_1d( nidx, evap_ice_1d (1:nidx), evap_ice(:,:,jl), jpi, jpj, idxice(1:nidx) ) 450 CALL tab_2d_1d( nidx, dqns_ice_1d(1:nidx), dqns_ice(:,:,jl), jpi, jpj, idxice(1:nidx) ) 451 CALL tab_2d_1d( nidx, t_bo_1d (1:nidx), t_bo , jpi, jpj, idxice(1:nidx) ) 452 CALL tab_2d_1d( nidx, sprecip_1d (1:nidx), sprecip , jpi, jpj, idxice(1:nidx) ) 453 CALL tab_2d_1d( nidx, fhtur_1d (1:nidx), fhtur , jpi, jpj, idxice(1:nidx) ) 454 CALL tab_2d_1d( nidx, fhld_1d (1:nidx), fhld , jpi, jpj, idxice(1:nidx) ) 455 ! 456 CALL tab_2d_1d( nidx, wfx_snw_1d (1:nidx), wfx_snw , jpi, jpj, idxice(1:nidx) ) 457 CALL tab_2d_1d( nidx, wfx_snw_sum_1d(1:nidx), wfx_snw_sum , jpi, jpj, idxice(1:nidx) ) 458 CALL tab_2d_1d( nidx, wfx_sub_1d (1:nidx), wfx_sub , jpi, jpj, idxice(1:nidx) ) 459 CALL tab_2d_1d( nidx, wfx_snw_sub_1d(1:nidx), wfx_snw_sub , jpi, jpj, idxice(1:nidx) ) 460 CALL tab_2d_1d( nidx, wfx_ice_sub_1d(1:nidx), wfx_ice_sub , jpi, jpj, idxice(1:nidx) ) 461 CALL tab_2d_1d( nidx, wfx_err_sub_1d(1:nidx), wfx_err_sub , jpi, jpj, idxice(1:nidx) ) 462 ! 463 CALL tab_2d_1d( nidx, wfx_bog_1d (1:nidx), wfx_bog , jpi, jpj, idxice(1:nidx) ) 464 CALL tab_2d_1d( nidx, wfx_bom_1d (1:nidx), wfx_bom , jpi, jpj, idxice(1:nidx) ) 465 CALL tab_2d_1d( nidx, wfx_sum_1d (1:nidx), wfx_sum , jpi, jpj, idxice(1:nidx) ) 466 CALL tab_2d_1d( nidx, wfx_sni_1d (1:nidx), wfx_sni , jpi, jpj, idxice(1:nidx) ) 467 CALL tab_2d_1d( nidx, wfx_res_1d (1:nidx), wfx_res , jpi, jpj, idxice(1:nidx) ) 468 CALL tab_2d_1d( nidx, wfx_spr_1d (1:nidx), wfx_spr , jpi, jpj, idxice(1:nidx) ) 469 ! 470 CALL tab_2d_1d( nidx, sfx_bog_1d (1:nidx), sfx_bog , jpi, jpj, idxice(1:nidx) ) 471 CALL tab_2d_1d( nidx, sfx_bom_1d (1:nidx), sfx_bom , jpi, jpj, idxice(1:nidx) ) 472 CALL tab_2d_1d( nidx, sfx_sum_1d (1:nidx), sfx_sum , jpi, jpj, idxice(1:nidx) ) 473 CALL tab_2d_1d( nidx, sfx_sni_1d (1:nidx), sfx_sni , jpi, jpj, idxice(1:nidx) ) 474 CALL tab_2d_1d( nidx, sfx_bri_1d (1:nidx), sfx_bri , jpi, jpj, idxice(1:nidx) ) 475 CALL tab_2d_1d( nidx, sfx_res_1d (1:nidx), sfx_res , jpi, jpj, idxice(1:nidx) ) 476 CALL tab_2d_1d( nidx, sfx_sub_1d (1:nidx), sfx_sub , jpi, jpj,idxice(1:nidx) ) 477 ! 478 CALL tab_2d_1d( nidx, hfx_thd_1d (1:nidx), hfx_thd , jpi, jpj, idxice(1:nidx) ) 479 CALL tab_2d_1d( nidx, hfx_spr_1d (1:nidx), hfx_spr , jpi, jpj, idxice(1:nidx) ) 480 CALL tab_2d_1d( nidx, hfx_sum_1d (1:nidx), hfx_sum , jpi, jpj, idxice(1:nidx) ) 481 CALL tab_2d_1d( nidx, hfx_bom_1d (1:nidx), hfx_bom , jpi, jpj, idxice(1:nidx) ) 482 CALL tab_2d_1d( nidx, hfx_bog_1d (1:nidx), hfx_bog , jpi, jpj, idxice(1:nidx) ) 483 CALL tab_2d_1d( nidx, hfx_dif_1d (1:nidx), hfx_dif , jpi, jpj, idxice(1:nidx) ) 484 CALL tab_2d_1d( nidx, hfx_opw_1d (1:nidx), hfx_opw , jpi, jpj, idxice(1:nidx) ) 485 CALL tab_2d_1d( nidx, hfx_snw_1d (1:nidx), hfx_snw , jpi, jpj, idxice(1:nidx) ) 486 CALL tab_2d_1d( nidx, hfx_sub_1d (1:nidx), hfx_sub , jpi, jpj, idxice(1:nidx) ) 487 CALL tab_2d_1d( nidx, hfx_err_1d (1:nidx), hfx_err , jpi, jpj, idxice(1:nidx) ) 488 CALL tab_2d_1d( nidx, hfx_res_1d (1:nidx), hfx_res , jpi, jpj, idxice(1:nidx) ) 489 CALL tab_2d_1d( nidx, hfx_err_dif_1d (1:nidx), hfx_err_dif , jpi, jpj, idxice(1:nidx) ) 490 CALL tab_2d_1d( nidx, hfx_err_rem_1d (1:nidx), hfx_err_rem , jpi, jpj, idxice(1:nidx) ) 491 CALL tab_2d_1d( nidx, hfx_out_1d (1:nidx), hfx_out , jpi, jpj, idxice(1:nidx) ) 491 492 ! 492 493 ! SIMIP diagnostics 493 CALL tab_2d_1d( n bpb, diag_fc_bo_1d (1:nbpb), diag_fc_bo , jpi, jpj, npb(1:nbpb) )494 CALL tab_2d_1d( n bpb, diag_fc_su_1d (1:nbpb), diag_fc_su , jpi, jpj, npb(1:nbpb) )494 CALL tab_2d_1d( nidx, diag_fc_bo_1d (1:nidx), diag_fc_bo , jpi, jpj, idxice(1:nidx) ) 495 CALL tab_2d_1d( nidx, diag_fc_su_1d (1:nidx), diag_fc_su , jpi, jpj, idxice(1:nidx) ) 495 496 ! ocean surface fields 496 CALL tab_2d_1d( n bpb, sst_1d(1:nbpb), sst_m, jpi, jpj, npb(1:nbpb) )497 CALL tab_2d_1d( n bpb, sss_1d(1:nbpb), sss_m, jpi, jpj, npb(1:nbpb) )497 CALL tab_2d_1d( nidx, sst_1d(1:nidx), sst_m, jpi, jpj, idxice(1:nidx) ) 498 CALL tab_2d_1d( nidx, sss_1d(1:nidx), sss_m, jpi, jpj, idxice(1:nidx) ) 498 499 ! 499 500 CASE( 2 ) ! from 1D to 2D 500 501 ! 501 CALL tab_1d_2d( n bpb, at_i , npb, at_i_1d (1:nbpb) , jpi, jpj )502 CALL tab_1d_2d( n bpb, ht_i(:,:,jl) , npb, ht_i_1d (1:nbpb) , jpi, jpj )503 CALL tab_1d_2d( n bpb, ht_s(:,:,jl) , npb, ht_s_1d (1:nbpb) , jpi, jpj )504 CALL tab_1d_2d( n bpb, a_i (:,:,jl) , npb, a_i_1d (1:nbpb) , jpi, jpj )505 CALL tab_1d_2d( n bpb, t_su(:,:,jl) , npb, t_su_1d (1:nbpb) , jpi, jpj )506 CALL tab_1d_2d( n bpb, sm_i(:,:,jl) , npb, sm_i_1d (1:nbpb) , jpi, jpj )502 CALL tab_1d_2d( nidx, at_i , idxice, at_i_1d (1:nidx) , jpi, jpj ) 503 CALL tab_1d_2d( nidx, ht_i(:,:,jl) , idxice, ht_i_1d (1:nidx) , jpi, jpj ) 504 CALL tab_1d_2d( nidx, ht_s(:,:,jl) , idxice, ht_s_1d (1:nidx) , jpi, jpj ) 505 CALL tab_1d_2d( nidx, a_i (:,:,jl) , idxice, a_i_1d (1:nidx) , jpi, jpj ) 506 CALL tab_1d_2d( nidx, t_su(:,:,jl) , idxice, t_su_1d (1:nidx) , jpi, jpj ) 507 CALL tab_1d_2d( nidx, sm_i(:,:,jl) , idxice, sm_i_1d (1:nidx) , jpi, jpj ) 507 508 DO jk = 1, nlay_s 508 CALL tab_1d_2d( n bpb, t_s(:,:,jk,jl), npb, t_s_1d (1:nbpb,jk), jpi, jpj)509 CALL tab_1d_2d( n bpb, e_s(:,:,jk,jl), npb, e_s_1d (1:nbpb,jk), jpi, jpj)509 CALL tab_1d_2d( nidx, t_s(:,:,jk,jl), idxice, t_s_1d (1:nidx,jk), jpi, jpj) 510 CALL tab_1d_2d( nidx, e_s(:,:,jk,jl), idxice, e_s_1d (1:nidx,jk), jpi, jpj) 510 511 END DO 511 512 DO jk = 1, nlay_i 512 CALL tab_1d_2d( nbpb, t_i(:,:,jk,jl), npb, t_i_1d (1:nbpb,jk), jpi, jpj) 513 CALL tab_1d_2d( nbpb, e_i(:,:,jk,jl), npb, e_i_1d (1:nbpb,jk), jpi, jpj) 514 CALL tab_1d_2d( nbpb, s_i(:,:,jk,jl), npb, s_i_1d (1:nbpb,jk), jpi, jpj) 515 END DO 516 CALL tab_1d_2d( nbpb, qlead , npb, qlead_1d (1:nbpb) , jpi, jpj ) 517 ! 518 CALL tab_1d_2d( nbpb, wfx_snw , npb, wfx_snw_1d(1:nbpb) , jpi, jpj ) 519 CALL tab_1d_2d( nbpb, wfx_snw_sum , npb, wfx_snw_sum_1d(1:nbpb),jpi, jpj ) 520 CALL tab_1d_2d( nbpb, wfx_sub , npb, wfx_sub_1d(1:nbpb) , jpi, jpj ) 521 CALL tab_1d_2d( nbpb, wfx_snw_sub , npb, wfx_snw_sub_1d(1:nbpb), jpi, jpj ) 522 CALL tab_1d_2d( nbpb, wfx_ice_sub , npb, wfx_ice_sub_1d(1:nbpb), jpi, jpj ) 523 CALL tab_1d_2d( nbpb, wfx_err_sub , npb, wfx_err_sub_1d(1:nbpb), jpi, jpj ) 524 ! 525 CALL tab_1d_2d( nbpb, wfx_bog , npb, wfx_bog_1d(1:nbpb) , jpi, jpj ) 526 CALL tab_1d_2d( nbpb, wfx_bom , npb, wfx_bom_1d(1:nbpb) , jpi, jpj ) 527 CALL tab_1d_2d( nbpb, wfx_sum , npb, wfx_sum_1d(1:nbpb) , jpi, jpj ) 528 CALL tab_1d_2d( nbpb, wfx_sni , npb, wfx_sni_1d(1:nbpb) , jpi, jpj ) 529 CALL tab_1d_2d( nbpb, wfx_res , npb, wfx_res_1d(1:nbpb) , jpi, jpj ) 530 CALL tab_1d_2d( nbpb, wfx_spr , npb, wfx_spr_1d(1:nbpb) , jpi, jpj ) 531 ! 532 CALL tab_1d_2d( nbpb, sfx_bog , npb, sfx_bog_1d(1:nbpb) , jpi, jpj ) 533 CALL tab_1d_2d( nbpb, sfx_bom , npb, sfx_bom_1d(1:nbpb) , jpi, jpj ) 534 CALL tab_1d_2d( nbpb, sfx_sum , npb, sfx_sum_1d(1:nbpb) , jpi, jpj ) 535 CALL tab_1d_2d( nbpb, sfx_sni , npb, sfx_sni_1d(1:nbpb) , jpi, jpj ) 536 CALL tab_1d_2d( nbpb, sfx_res , npb, sfx_res_1d(1:nbpb) , jpi, jpj ) 537 CALL tab_1d_2d( nbpb, sfx_bri , npb, sfx_bri_1d(1:nbpb) , jpi, jpj ) 538 CALL tab_1d_2d( nbpb, sfx_sub , npb, sfx_sub_1d(1:nbpb) , jpi, jpj ) 539 ! 540 CALL tab_1d_2d( nbpb, hfx_thd , npb, hfx_thd_1d(1:nbpb) , jpi, jpj ) 541 CALL tab_1d_2d( nbpb, hfx_spr , npb, hfx_spr_1d(1:nbpb) , jpi, jpj ) 542 CALL tab_1d_2d( nbpb, hfx_sum , npb, hfx_sum_1d(1:nbpb) , jpi, jpj ) 543 CALL tab_1d_2d( nbpb, hfx_bom , npb, hfx_bom_1d(1:nbpb) , jpi, jpj ) 544 CALL tab_1d_2d( nbpb, hfx_bog , npb, hfx_bog_1d(1:nbpb) , jpi, jpj ) 545 CALL tab_1d_2d( nbpb, hfx_dif , npb, hfx_dif_1d(1:nbpb) , jpi, jpj ) 546 CALL tab_1d_2d( nbpb, hfx_opw , npb, hfx_opw_1d(1:nbpb) , jpi, jpj ) 547 CALL tab_1d_2d( nbpb, hfx_snw , npb, hfx_snw_1d(1:nbpb) , jpi, jpj ) 548 CALL tab_1d_2d( nbpb, hfx_sub , npb, hfx_sub_1d(1:nbpb) , jpi, jpj ) 549 CALL tab_1d_2d( nbpb, hfx_err , npb, hfx_err_1d(1:nbpb) , jpi, jpj ) 550 CALL tab_1d_2d( nbpb, hfx_res , npb, hfx_res_1d(1:nbpb) , jpi, jpj ) 551 CALL tab_1d_2d( nbpb, hfx_err_rem , npb, hfx_err_rem_1d(1:nbpb), jpi, jpj ) 552 CALL tab_1d_2d( nbpb, hfx_err_dif , npb, hfx_err_dif_1d(1:nbpb), jpi, jpj ) 553 CALL tab_1d_2d( nbpb, hfx_out , npb, hfx_out_1d(1:nbpb) , jpi, jpj ) 554 ! 555 CALL tab_1d_2d( nbpb, qns_ice(:,:,jl), npb, qns_ice_1d(1:nbpb) , jpi, jpj) 556 CALL tab_1d_2d( nbpb, ftr_ice(:,:,jl), npb, ftr_ice_1d(1:nbpb) , jpi, jpj ) 513 CALL tab_1d_2d( nidx, t_i(:,:,jk,jl), idxice, t_i_1d (1:nidx,jk), jpi, jpj) 514 CALL tab_1d_2d( nidx, e_i(:,:,jk,jl), idxice, e_i_1d (1:nidx,jk), jpi, jpj) 515 CALL tab_1d_2d( nidx, s_i(:,:,jk,jl), idxice, s_i_1d (1:nidx,jk), jpi, jpj) 516 END DO 517 ! 518 CALL tab_1d_2d( nidx, wfx_snw , idxice, wfx_snw_1d(1:nidx) , jpi, jpj ) 519 CALL tab_1d_2d( nidx, wfx_snw_sum , idxice, wfx_snw_sum_1d(1:nidx),jpi, jpj ) 520 CALL tab_1d_2d( nidx, wfx_sub , idxice, wfx_sub_1d(1:nidx) , jpi, jpj ) 521 CALL tab_1d_2d( nidx, wfx_snw_sub , idxice, wfx_snw_sub_1d(1:nidx), jpi, jpj ) 522 CALL tab_1d_2d( nidx, wfx_ice_sub , idxice, wfx_ice_sub_1d(1:nidx), jpi, jpj ) 523 CALL tab_1d_2d( nidx, wfx_err_sub , idxice, wfx_err_sub_1d(1:nidx), jpi, jpj ) 524 ! 525 CALL tab_1d_2d( nidx, wfx_bog , idxice, wfx_bog_1d(1:nidx) , jpi, jpj ) 526 CALL tab_1d_2d( nidx, wfx_bom , idxice, wfx_bom_1d(1:nidx) , jpi, jpj ) 527 CALL tab_1d_2d( nidx, wfx_sum , idxice, wfx_sum_1d(1:nidx) , jpi, jpj ) 528 CALL tab_1d_2d( nidx, wfx_sni , idxice, wfx_sni_1d(1:nidx) , jpi, jpj ) 529 CALL tab_1d_2d( nidx, wfx_res , idxice, wfx_res_1d(1:nidx) , jpi, jpj ) 530 CALL tab_1d_2d( nidx, wfx_spr , idxice, wfx_spr_1d(1:nidx) , jpi, jpj ) 531 ! 532 CALL tab_1d_2d( nidx, sfx_bog , idxice, sfx_bog_1d(1:nidx) , jpi, jpj ) 533 CALL tab_1d_2d( nidx, sfx_bom , idxice, sfx_bom_1d(1:nidx) , jpi, jpj ) 534 CALL tab_1d_2d( nidx, sfx_sum , idxice, sfx_sum_1d(1:nidx) , jpi, jpj ) 535 CALL tab_1d_2d( nidx, sfx_sni , idxice, sfx_sni_1d(1:nidx) , jpi, jpj ) 536 CALL tab_1d_2d( nidx, sfx_res , idxice, sfx_res_1d(1:nidx) , jpi, jpj ) 537 CALL tab_1d_2d( nidx, sfx_bri , idxice, sfx_bri_1d(1:nidx) , jpi, jpj ) 538 CALL tab_1d_2d( nidx, sfx_sub , idxice, sfx_sub_1d(1:nidx) , jpi, jpj ) 539 ! 540 CALL tab_1d_2d( nidx, hfx_thd , idxice, hfx_thd_1d(1:nidx) , jpi, jpj ) 541 CALL tab_1d_2d( nidx, hfx_spr , idxice, hfx_spr_1d(1:nidx) , jpi, jpj ) 542 CALL tab_1d_2d( nidx, hfx_sum , idxice, hfx_sum_1d(1:nidx) , jpi, jpj ) 543 CALL tab_1d_2d( nidx, hfx_bom , idxice, hfx_bom_1d(1:nidx) , jpi, jpj ) 544 CALL tab_1d_2d( nidx, hfx_bog , idxice, hfx_bog_1d(1:nidx) , jpi, jpj ) 545 CALL tab_1d_2d( nidx, hfx_dif , idxice, hfx_dif_1d(1:nidx) , jpi, jpj ) 546 CALL tab_1d_2d( nidx, hfx_opw , idxice, hfx_opw_1d(1:nidx) , jpi, jpj ) 547 CALL tab_1d_2d( nidx, hfx_snw , idxice, hfx_snw_1d(1:nidx) , jpi, jpj ) 548 CALL tab_1d_2d( nidx, hfx_sub , idxice, hfx_sub_1d(1:nidx) , jpi, jpj ) 549 CALL tab_1d_2d( nidx, hfx_err , idxice, hfx_err_1d(1:nidx) , jpi, jpj ) 550 CALL tab_1d_2d( nidx, hfx_res , idxice, hfx_res_1d(1:nidx) , jpi, jpj ) 551 CALL tab_1d_2d( nidx, hfx_err_rem , idxice, hfx_err_rem_1d(1:nidx), jpi, jpj ) 552 CALL tab_1d_2d( nidx, hfx_err_dif , idxice, hfx_err_dif_1d(1:nidx), jpi, jpj ) 553 CALL tab_1d_2d( nidx, hfx_out , idxice, hfx_out_1d(1:nidx) , jpi, jpj ) 554 ! 555 CALL tab_1d_2d( nidx, qns_ice(:,:,jl), idxice, qns_ice_1d(1:nidx) , jpi, jpj) 556 CALL tab_1d_2d( nidx, ftr_ice(:,:,jl), idxice, ftr_ice_1d(1:nidx) , jpi, jpj ) 557 557 ! 558 558 ! SIMIP diagnostics 559 CALL tab_1d_2d( n bpb, t_si(:,:,jl) , npb, t_si_1d (1:nbpb) , jpi, jpj )560 CALL tab_1d_2d( n bpb, diag_fc_bo , npb, diag_fc_bo_1d(1:nbpb) , jpi, jpj )561 CALL tab_1d_2d( n bpb, diag_fc_su , npb, diag_fc_su_1d(1:nbpb) , jpi, jpj )559 CALL tab_1d_2d( nidx, t_si(:,:,jl) , idxice, t_si_1d (1:nidx) , jpi, jpj ) 560 CALL tab_1d_2d( nidx, diag_fc_bo , idxice, diag_fc_bo_1d(1:nidx) , jpi, jpj ) 561 CALL tab_1d_2d( nidx, diag_fc_su , idxice, diag_fc_su_1d(1:nidx) , jpi, jpj ) 562 562 END SELECT 563 563 ! -
branches/2017/dev_r8183_ICEMODEL/NEMOGCM/NEMO/LIM_SRC_3/limthd_da.F90
r8325 r8327 12 12 !! lim_thd_da : sea ice lateral melting 13 13 !!---------------------------------------------------------------------- 14 USE par_oce ! ocean parameters 15 USE phycst ! physical constants (ocean directory) 16 USE sbc_oce, ONLY: sst_m ! Surface boundary condition: ocean fields 17 USE ice ! LIM variables 18 USE lib_mpp ! MPP library 19 USE wrk_nemo ! work arrays 20 USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 14 USE par_oce ! ocean parameters 15 USE phycst ! physical constants (ocean directory) 16 USE sbc_oce , ONLY : sst_m 17 USE ice ! LIM variables 18 USE thd_ice ! thermodynamic sea-ice variables 19 USE limtab ! 1D <==> 2D transformation 20 ! 21 USE lib_mpp ! MPP library 22 USE wrk_nemo ! work arrays 23 USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 21 24 22 25 IMPLICIT NONE … … 97 100 !! Phil. Trans. R. Soc. A, 373(2052), 20140167. 98 101 !!--------------------------------------------------------------------- 99 INTEGER :: ji, jj, jl ! dummy loop indices 102 INTEGER :: ji, jj, jk, jl ! dummy loop indices 103 INTEGER :: nidx 100 104 REAL(wp) :: zastar, zdfloe, zperi, zwlat, zda 101 105 REAL(wp), PARAMETER :: zdmax = 300._wp … … 104 108 REAL(wp), PARAMETER :: zm2 = 1.36_wp 105 109 ! 106 REAL(wp), POINTER, DIMENSION(:,:) :: zda_tot110 REAL(wp), DIMENSION(jpij) :: zda_tot 107 111 !!--------------------------------------------------------------------- 108 CALL wrk_alloc( jpi,jpj, zda_tot ) 112 113 ! select ice covered grid points 114 nidx = 0 ; idxice(:) = 0 115 DO jj = 2, jpjm1 116 DO ji = 2, jpim1 117 IF ( at_i(ji,jj) > epsi10 ) THEN 118 nidx = nidx + 1 119 idxice(nidx) = (jj - 1) * jpi + ji 120 ENDIF 121 END DO 122 END DO 109 123 110 124 !------------------------------------------------------------! … … 112 126 !------------------------------------------------------------! 113 127 zastar = 1._wp / ( 1._wp - (rn_dmin / zdmax)**(1._wp/rn_beta) ) 114 115 DO jj = 1, jpj 116 DO ji = 1, jpi 117 118 ! Mean floe caliper diameter [m] 119 zdfloe = rn_dmin * ( zastar / ( zastar - at_i(ji,jj) ) )**rn_beta 120 121 ! Mean perimeter of the floe = N*pi*D = (A/cs*D^2)*pi*D [m.m-2] 122 zperi = at_i(ji,jj) * rpi / ( zcs * zdfloe ) 123 124 ! Melt speed rate [m/s] 125 zwlat = zm1 * ( MAX( 0._wp, sst_m(ji,jj) - ( t_bo(ji,jj) - rt0 ) ) )**zm2 126 127 ! sea ice concentration decrease 128 zda_tot(ji,jj) = - MIN( zwlat * zperi * rdt_ice, at_i(ji,jj) ) 129 130 END DO 128 129 CALL tab_2d_1d( nidx, at_i_1d(1:nidx), at_i , jpi, jpj, idxice(1:nidx) ) 130 CALL tab_2d_1d( nidx, t_bo_1d(1:nidx), t_bo , jpi, jpj, idxice(1:nidx) ) 131 CALL tab_2d_1d( nidx, sst_1d (1:nidx), sst_m, jpi, jpj, idxice(1:nidx) ) 132 DO ji = 1, nidx 133 zdfloe = rn_dmin * ( zastar / ( zastar - at_i_1d(ji) ) )**rn_beta ! Mean floe caliper diameter [m] 134 zperi = at_i_1d(ji) * rpi / ( zcs * zdfloe ) ! Mean perimeter of the floe = N*pi*D = (A/cs*D^2)*pi*D [m.m-2] 135 zwlat = zm1 * ( MAX( 0._wp, sst_1d(ji) - ( t_bo_1d(ji) - rt0 ) ) )**zm2 ! Melt speed rate [m/s] 136 137 zda_tot(ji) = - MIN( zwlat * zperi * rdt_ice, at_i_1d(ji) ) ! sea ice concentration decrease 131 138 END DO 132 139 … … 134 141 ! --- Distribute reduction among ice categories and calculate associated ice-ocean fluxes --- ! 135 142 !---------------------------------------------------------------------------------------------! 136 DO jl = jpl, 1, -1 137 DO jj = 1, jpj 138 DO ji = 1, jpi 139 140 ! decrease of concentration for the category jl 141 ! 1st option: each category contributes to melting in proportion to its concentration 142 rswitch = MAX( 0._wp , SIGN( 1._wp, at_i(ji,jj) - epsi10 ) ) 143 zda = rswitch * zda_tot(ji,jj) * a_i(ji,jj,jl) / MAX( at_i(ji,jj), epsi10 ) 144 ! 2d option: melting of the upper cat first 145 !!zda = MAX( zda_tot(ji,jj), - a_i(ji,jj,jl) ) 146 !!zda_tot(ji,jj) = zda_tot(ji,jj) + zda 147 148 ! Contribution to salt flux 149 sfx_lam(ji,jj) = sfx_lam(ji,jj) - rhoic * ht_i(ji,jj,jl) * zda * sm_i(ji,jj,jl) * r1_rdtice 150 151 ! Contribution to heat flux into the ocean [W.m-2], <0 152 !clemX hfx_thd(ji,jj) = hfx_thd(ji,jj) + zda * r1_rdtice * ( ht_i(ji,jj,jl) * SUM( e_i(ji,jj,:,jl) ) * r1_nlay_i & 153 ! & + ht_s(ji,jj,jl) * e_s(ji,jj,1,jl) * r1_nlay_s ) 154 hfx_thd(ji,jj) = hfx_thd(ji,jj) + rswitch * zda_tot(ji,jj) / MAX( at_i(ji,jj), epsi10 ) & 155 & * r1_rdtice * ( SUM( e_i(ji,jj,:,jl) ) + e_s(ji,jj,1,jl) ) 156 157 ! Contribution to mass flux 158 wfx_lam(ji,jj) = wfx_lam(ji,jj) - zda * r1_rdtice * ( rhoic * ht_i(ji,jj,jl) + rhosn * ht_s(ji,jj,jl) ) 159 160 ! new concentration 161 a_i(ji,jj,jl) = a_i(ji,jj,jl) + zda 162 END DO 163 END DO 143 DO jl = 1, jpl 144 CALL tab_2d_1d( nidx, a_i_1d (1:nidx), a_i(:,:,jl) , jpi, jpj, idxice(1:nidx) ) 145 CALL tab_2d_1d( nidx, ht_i_1d (1:nidx), ht_i(:,:,jl), jpi, jpj, idxice(1:nidx) ) 146 CALL tab_2d_1d( nidx, sm_i_1d (1:nidx), sm_i(:,:,jl), jpi, jpj, idxice(1:nidx) ) 147 CALL tab_2d_1d( nidx, sfx_lam_1d(1:nidx), sfx_lam , jpi, jpj, idxice(1:nidx) ) 148 CALL tab_2d_1d( nidx, hfx_thd_1d(1:nidx), hfx_thd , jpi, jpj, idxice(1:nidx) ) 149 CALL tab_2d_1d( nidx, wfx_lam_1d(1:nidx), wfx_lam , jpi, jpj, idxice(1:nidx) ) 150 DO jk = 1, nlay_i 151 CALL tab_2d_1d( nidx, e_i_1d(1:nidx,jk), e_i(:,:,jk,jl) , jpi, jpj, idxice(1:nidx) ) 152 END DO 153 DO jk = 1, nlay_s 154 CALL tab_2d_1d( nidx, e_s_1d(1:nidx,jk), e_s(:,:,jk,jl) , jpi, jpj, idxice(1:nidx) ) 155 END DO 156 157 DO ji = 1, nidx 158 ! decrease of concentration for the category jl 159 ! each category contributes to melting in proportion to its concentration 160 zda = zda_tot(ji) * a_i_1d(ji) / at_i_1d(ji) 161 162 ! Contribution to salt flux 163 sfx_lam_1d(ji) = sfx_lam_1d(ji) - rhoic * ht_i_1d(ji) * zda * sm_i_1d(ji) * r1_rdtice 164 165 ! Contribution to heat flux into the ocean [W.m-2], <0 166 !clemX hfx_thd_1d(ji) = hfx_thd_1d(ji) + zda * r1_rdtice * ( ht_i_1d(ji) * SUM( e_i_1d(ji,:) ) * r1_nlay_i & 167 ! & + ht_s_1d(ji) * e_s_1d(ji,1) * r1_nlay_s ) 168 hfx_thd_1d(ji) = hfx_thd_1d(ji) + zda_tot(ji) / at_i_1d(ji) * r1_rdtice * ( SUM( e_i_1d(ji,:) ) + e_s_1d(ji,1) ) 169 170 ! Contribution to mass flux 171 wfx_lam_1d(ji) = wfx_lam_1d(ji) - zda * r1_rdtice * ( rhoic * ht_i_1d(ji) + rhosn * ht_s_1d(ji) ) 172 173 ! new concentration 174 a_i_1d(ji) = a_i_1d(ji) + zda 175 176 ! ensure that ht_i = 0 where a_i = 0 177 IF( a_i_1d(ji) == 0._wp ) ht_i_1d(ji) = 0._wp 178 END DO 179 180 CALL tab_1d_2d( nidx, a_i (:,:,jl), idxice, a_i_1d (1:nidx), jpi, jpj ) 181 CALL tab_1d_2d( nidx, ht_i(:,:,jl), idxice, ht_i_1d (1:nidx), jpi, jpj ) 182 CALL tab_1d_2d( nidx, sfx_lam , idxice, sfx_lam_1d(1:nidx) , jpi, jpj ) 183 CALL tab_1d_2d( nidx, hfx_thd , idxice, hfx_thd_1d(1:nidx) , jpi, jpj ) 184 CALL tab_1d_2d( nidx, wfx_lam , idxice, wfx_lam_1d(1:nidx) , jpi, jpj ) 185 164 186 END DO 165 166 ! total concentration 167 at_i(:,:) = SUM( a_i(:,:,:), dim=3 ) 168 169 ! --- ensure that ht_i = 0 where a_i = 0 --- 170 WHERE( a_i == 0._wp ) ht_i = 0._wp 171 ! 172 CALL wrk_dealloc( jpi,jpj, zda_tot ) 187 173 188 ! 174 189 END SUBROUTINE lim_thd_da -
branches/2017/dev_r8183_ICEMODEL/NEMOGCM/NEMO/LIM_SRC_3/limthd_lac.F90
r8325 r8327 71 71 !!------------------------------------------------------------------------ 72 72 INTEGER :: ji,jj,jk,jl ! dummy loop indices 73 INTEGER :: n bpac! local integers74 INTEGER :: i i, ij, iter ! - -73 INTEGER :: nidx ! local integers 74 INTEGER :: iter ! - - 75 75 REAL(wp) :: ztmelts, zdv, zfrazb, zweight, zde ! local scalars 76 76 REAL(wp) :: zgamafr, zvfrx, zvgx, ztaux, ztwogp, zf ! - - 77 77 REAL(wp) :: ztenagm, zvfry, zvgy, ztauy, zvrel2, zfp, zsqcd , zhicrit ! - - 78 CHARACTER (len = 15) :: fieldid79 78 80 79 REAL(wp) :: zQm ! enthalpy exchanged with the ocean (J/m2, >0 towards ocean) … … 122 121 CALL lim_var_agg(1) 123 122 CALL lim_var_glo2eqv 124 !------------------------------------------------------------------------------|125 ! 2) Convert units for ice internal energy126 !------------------------------------------------------------------------------|127 DO jl = 1, jpl128 DO jk = 1, nlay_i129 DO jj = 1, jpj130 DO ji = 1, jpi131 !Energy of melting q(S,T) [J.m-3]132 rswitch = MAX( 0._wp , SIGN( 1._wp , v_i(ji,jj,jl) - epsi20 ) ) !0 if no ice133 e_i(ji,jj,jk,jl) = rswitch * e_i(ji,jj,jk,jl) / MAX( v_i(ji,jj,jl), epsi20 ) * REAL( nlay_i, wp )134 END DO135 END DO136 END DO137 END DO138 123 139 124 !------------------------------------------------------------------------------! … … 240 225 !------------------------------------- 241 226 ! This occurs if open water energy budget is negative (cooling) and there is no landfast ice 242 nbpac = 0 243 npac(:) = 0 244 ! 245 DO jj = 1, jpj 246 DO ji = 1, jpi 227 nidx = 0 ; idxice(:) = 0 228 DO jj = 2, jpjm1 229 DO ji = 2, jpim1 247 230 IF ( qlead(ji,jj) < 0._wp .AND. tau_icebfr(ji,jj) == 0._wp ) THEN 248 n bpac = nbpac+ 1249 npac( nbpac) = (jj - 1) * jpi + ji231 nidx = nidx + 1 232 idxice( nidx ) = (jj - 1) * jpi + ji 250 233 ENDIF 251 234 END DO … … 264 247 ENDIF 265 248 266 IF( ln_limctl ) WRITE(numout,*) 'lim_thd_lac : n bpac = ', nbpac249 IF( ln_limctl ) WRITE(numout,*) 'lim_thd_lac : nidx = ', nidx 267 250 268 251 !------------------------------ … … 271 254 ! If ocean gains heat do nothing. Otherwise compute new ice formation 272 255 273 IF ( n bpac> 0 ) THEN274 275 CALL tab_2d_1d( n bpac, zat_i_1d (1:nbpac) , at_i , jpi, jpj, npac(1:nbpac) )276 DO jl = 1, jpl 277 CALL tab_2d_1d( n bpac, za_i_1d (1:nbpac,jl), a_i (:,:,jl), jpi, jpj, npac(1:nbpac) )278 CALL tab_2d_1d( n bpac, zv_i_1d (1:nbpac,jl), v_i (:,:,jl), jpi, jpj, npac(1:nbpac) )279 CALL tab_2d_1d( n bpac, zsmv_i_1d(1:nbpac,jl), smv_i(:,:,jl), jpi, jpj, npac(1:nbpac) )256 IF ( nidx > 0 ) THEN 257 258 CALL tab_2d_1d( nidx, zat_i_1d (1:nidx) , at_i , jpi, jpj, idxice(1:nidx) ) 259 DO jl = 1, jpl 260 CALL tab_2d_1d( nidx, za_i_1d (1:nidx,jl), a_i (:,:,jl), jpi, jpj, idxice(1:nidx) ) 261 CALL tab_2d_1d( nidx, zv_i_1d (1:nidx,jl), v_i (:,:,jl), jpi, jpj, idxice(1:nidx) ) 262 CALL tab_2d_1d( nidx, zsmv_i_1d(1:nidx,jl), smv_i(:,:,jl), jpi, jpj, idxice(1:nidx) ) 280 263 DO jk = 1, nlay_i 281 CALL tab_2d_1d( nbpac, ze_i_1d(1:nbpac,jk,jl), e_i(:,:,jk,jl) , jpi, jpj, npac(1:nbpac) ) 282 END DO 283 END DO 284 285 CALL tab_2d_1d( nbpac, qlead_1d (1:nbpac) , qlead , jpi, jpj, npac(1:nbpac) ) 286 CALL tab_2d_1d( nbpac, t_bo_1d (1:nbpac) , t_bo , jpi, jpj, npac(1:nbpac) ) 287 CALL tab_2d_1d( nbpac, sfx_opw_1d(1:nbpac) , sfx_opw , jpi, jpj, npac(1:nbpac) ) 288 CALL tab_2d_1d( nbpac, wfx_opw_1d(1:nbpac) , wfx_opw , jpi, jpj, npac(1:nbpac) ) 289 CALL tab_2d_1d( nbpac, hicol_1d (1:nbpac) , hicol , jpi, jpj, npac(1:nbpac) ) 290 CALL tab_2d_1d( nbpac, zvrel_1d (1:nbpac) , zvrel , jpi, jpj, npac(1:nbpac) ) 291 292 CALL tab_2d_1d( nbpac, hfx_thd_1d(1:nbpac) , hfx_thd , jpi, jpj, npac(1:nbpac) ) 293 CALL tab_2d_1d( nbpac, hfx_opw_1d(1:nbpac) , hfx_opw , jpi, jpj, npac(1:nbpac) ) 294 CALL tab_2d_1d( nbpac, rn_amax_1d(1:nbpac) , rn_amax_2d, jpi, jpj, npac(1:nbpac) ) 295 264 CALL tab_2d_1d( nidx, ze_i_1d(1:nidx,jk,jl), e_i(:,:,jk,jl) , jpi, jpj, idxice(1:nidx) ) 265 END DO 266 END DO 267 268 CALL tab_2d_1d( nidx, qlead_1d (1:nidx) , qlead , jpi, jpj, idxice(1:nidx) ) 269 CALL tab_2d_1d( nidx, t_bo_1d (1:nidx) , t_bo , jpi, jpj, idxice(1:nidx) ) 270 CALL tab_2d_1d( nidx, sfx_opw_1d(1:nidx) , sfx_opw , jpi, jpj, idxice(1:nidx) ) 271 CALL tab_2d_1d( nidx, wfx_opw_1d(1:nidx) , wfx_opw , jpi, jpj, idxice(1:nidx) ) 272 CALL tab_2d_1d( nidx, hicol_1d (1:nidx) , hicol , jpi, jpj, idxice(1:nidx) ) 273 CALL tab_2d_1d( nidx, zvrel_1d (1:nidx) , zvrel , jpi, jpj, idxice(1:nidx) ) 274 275 CALL tab_2d_1d( nidx, hfx_thd_1d(1:nidx) , hfx_thd , jpi, jpj, idxice(1:nidx) ) 276 CALL tab_2d_1d( nidx, hfx_opw_1d(1:nidx) , hfx_opw , jpi, jpj, idxice(1:nidx) ) 277 CALL tab_2d_1d( nidx, rn_amax_1d(1:nidx) , rn_amax_2d, jpi, jpj, idxice(1:nidx) ) 278 CALL tab_2d_1d( nidx, sss_1d (1:nidx) , sss_m , jpi, jpj, idxice(1:nidx) ) 279 280 !------------------------------------------------------------------------------| 281 ! 2) Convert units for ice internal energy 282 !------------------------------------------------------------------------------| 283 DO jl = 1, jpl 284 DO jk = 1, nlay_i 285 DO ji = 1, nidx 286 IF( zv_i_1d(ji,jl) > 0._wp ) ze_i_1d(ji,jk,jl) = ze_i_1d(ji,jk,jl) / zv_i_1d(ji,jl) * REAL( nlay_i ) 287 END DO 288 END DO 289 END DO 296 290 !------------------------------------------------------------------------------! 297 291 ! 5) Compute thickness, salinity, enthalpy, age, area and volume of new ice … … 301 295 ! Keep old ice areas and volume in memory 302 296 !----------------------------------------- 303 zv_b(1:n bpac,:) = zv_i_1d(1:nbpac,:)304 za_b(1:n bpac,:) = za_i_1d(1:nbpac,:)297 zv_b(1:nidx,:) = zv_i_1d(1:nidx,:) 298 za_b(1:nidx,:) = za_i_1d(1:nidx,:) 305 299 306 300 !---------------------- 307 301 ! Thickness of new ice 308 302 !---------------------- 309 zh_newice(1:n bpac) = hicol_1d(1:nbpac)303 zh_newice(1:nidx) = hicol_1d(1:nidx) 310 304 311 305 !---------------------- … … 314 308 SELECT CASE ( nn_icesal ) 315 309 CASE ( 1 ) ! Sice = constant 316 zs_newice(1:n bpac) = rn_icesal310 zs_newice(1:nidx) = rn_icesal 317 311 CASE ( 2 ) ! Sice = F(z,t) [Vancoppenolle et al (2005)] 318 DO ji = 1, nbpac 319 ii = MOD( npac(ji) - 1 , jpi ) + 1 320 ij = ( npac(ji) - 1 ) / jpi + 1 321 zs_newice(ji) = MIN( 4.606 + 0.91 / zh_newice(ji) , rn_simax , 0.5 * sss_m(ii,ij) ) 312 DO ji = 1, nidx 313 zs_newice(ji) = MIN( 4.606 + 0.91 / zh_newice(ji) , rn_simax , 0.5 * sss_1d(ji) ) 322 314 END DO 323 315 CASE ( 3 ) ! Sice = F(z) [multiyear ice] 324 zs_newice(1:n bpac) = 2.3316 zs_newice(1:nidx) = 2.3 325 317 END SELECT 326 318 … … 329 321 !------------------------- 330 322 ! We assume that new ice is formed at the seawater freezing point 331 DO ji = 1, n bpac323 DO ji = 1, nidx 332 324 ztmelts = - tmut * zs_newice(ji) + rt0 ! Melting point (K) 333 325 ze_newice(ji) = rhoic * ( cpic * ( ztmelts - t_bo_1d(ji) ) & … … 339 331 ! Age of new ice 340 332 !---------------- 341 DO ji = 1, n bpac333 DO ji = 1, nidx 342 334 zo_newice(ji) = 0._wp 343 335 END DO … … 346 338 ! Volume of new ice 347 339 !------------------- 348 DO ji = 1, n bpac340 DO ji = 1, nidx 349 341 350 342 zEi = - ze_newice(ji) * r1_rhoic ! specific enthalpy of forming ice [J/kg] … … 374 366 IF( ln_frazil ) THEN 375 367 ! A fraction zfrazb of frazil ice is accreted at the ice bottom 376 DO ji = 1, n bpac368 DO ji = 1, nidx 377 369 rswitch = 1._wp - MAX( 0._wp, SIGN( 1._wp , - zat_i_1d(ji) ) ) 378 370 zfrazb = rswitch * ( TANH( rn_Cfrazb * ( zvrel_1d(ji) - rn_vfrazb ) ) + 1.0 ) * 0.5 * rn_maxfrazb … … 385 377 ! Area of new ice 386 378 !----------------- 387 DO ji = 1, n bpac379 DO ji = 1, nidx 388 380 za_newice(ji) = zv_newice(ji) / zh_newice(ji) 389 381 END DO … … 398 390 ! If lateral ice growth gives an ice concentration gt 1, then 399 391 ! we keep the excessive volume in memory and attribute it later to bottom accretion 400 DO ji = 1, n bpac392 DO ji = 1, nidx 401 393 IF ( za_newice(ji) > ( rn_amax_1d(ji) - zat_i_1d(ji) ) ) THEN 402 394 zda_res(ji) = za_newice(ji) - ( rn_amax_1d(ji) - zat_i_1d(ji) ) … … 413 405 zat_i_1d(:) = 0._wp 414 406 DO jl = 1, jpl 415 DO ji = 1, n bpac407 DO ji = 1, nidx 416 408 IF( zh_newice(ji) > hi_max(jl-1) .AND. zh_newice(ji) <= hi_max(jl) ) THEN 417 409 za_i_1d (ji,jl) = za_i_1d (ji,jl) + za_newice(ji) … … 424 416 425 417 ! Heat content 426 DO ji = 1, n bpac418 DO ji = 1, nidx 427 419 jl = jcat(ji) ! categroy in which new ice is put 428 420 zswinew (ji) = MAX( 0._wp , SIGN( 1._wp , - za_b(ji,jl) ) ) ! 0 if old ice … … 430 422 431 423 DO jk = 1, nlay_i 432 DO ji = 1, n bpac424 DO ji = 1, nidx 433 425 jl = jcat(ji) 434 426 rswitch = MAX( 0._wp, SIGN( 1._wp , zv_i_1d(ji,jl) - epsi20 ) ) … … 445 437 446 438 ! for remapping 447 h_i_old (1:n bpac,0:nlay_i+1) = 0._wp448 eh_i_old(1:n bpac,0:nlay_i+1) = 0._wp439 h_i_old (1:nidx,0:nlay_i+1) = 0._wp 440 eh_i_old(1:nidx,0:nlay_i+1) = 0._wp 449 441 DO jk = 1, nlay_i 450 DO ji = 1, n bpac442 DO ji = 1, nidx 451 443 h_i_old (ji,jk) = zv_i_1d(ji,jl) * r1_nlay_i 452 444 eh_i_old(ji,jk) = ze_i_1d(ji,jk,jl) * h_i_old(ji,jk) … … 455 447 456 448 ! new volumes including lateral/bottom accretion + residual 457 DO ji = 1, n bpac449 DO ji = 1, nidx 458 450 rswitch = MAX( 0._wp, SIGN( 1._wp , zat_i_1d(ji) - epsi20 ) ) 459 451 zv_newfra = rswitch * ( zdv_res(ji) + zv_frazb(ji) ) * za_i_1d(ji,jl) / MAX( zat_i_1d(ji) , epsi20 ) … … 465 457 ENDDO 466 458 ! --- Ice enthalpy remapping --- ! 467 CALL lim_thd_ent( 1, n bpac, ze_i_1d(1:nbpac,:,jl) )459 CALL lim_thd_ent( 1, nidx, ze_i_1d(1:nidx,:,jl) ) 468 460 ENDDO 469 461 … … 472 464 !----------------- 473 465 DO jl = 1, jpl 474 DO ji = 1, n bpac466 DO ji = 1, nidx 475 467 zdv = zv_i_1d(ji,jl) - zv_b(ji,jl) 476 468 zsmv_i_1d(ji,jl) = zsmv_i_1d(ji,jl) + zdv * zs_newice(ji) … … 479 471 480 472 !------------------------------------------------------------------------------! 473 ! 8) Change units for e_i 474 !------------------------------------------------------------------------------! 475 DO jl = 1, jpl 476 DO jk = 1, nlay_i 477 DO ji = 1, nidx 478 ze_i_1d(ji,jk,jl) = ze_i_1d(ji,jk,jl) * zv_i_1d(ji,jl) * r1_nlay_i 479 END DO 480 END DO 481 END DO 482 !------------------------------------------------------------------------------! 481 483 ! 7) Change 2D vectors to 1D vectors 482 484 !------------------------------------------------------------------------------! 483 485 DO jl = 1, jpl 484 CALL tab_1d_2d( n bpac, a_i (:,:,jl), npac(1:nbpac), za_i_1d (1:nbpac,jl), jpi, jpj )485 CALL tab_1d_2d( n bpac, v_i (:,:,jl), npac(1:nbpac), zv_i_1d (1:nbpac,jl), jpi, jpj )486 CALL tab_1d_2d( n bpac, smv_i (:,:,jl), npac(1:nbpac), zsmv_i_1d(1:nbpac,jl) , jpi, jpj )486 CALL tab_1d_2d( nidx, a_i (:,:,jl), idxice(1:nidx), za_i_1d (1:nidx,jl), jpi, jpj ) 487 CALL tab_1d_2d( nidx, v_i (:,:,jl), idxice(1:nidx), zv_i_1d (1:nidx,jl), jpi, jpj ) 488 CALL tab_1d_2d( nidx, smv_i (:,:,jl), idxice(1:nidx), zsmv_i_1d(1:nidx,jl) , jpi, jpj ) 487 489 DO jk = 1, nlay_i 488 CALL tab_1d_2d( nbpac, e_i(:,:,jk,jl), npac(1:nbpac), ze_i_1d(1:nbpac,jk,jl), jpi, jpj ) 489 END DO 490 END DO 491 CALL tab_1d_2d( nbpac, sfx_opw, npac(1:nbpac), sfx_opw_1d(1:nbpac), jpi, jpj ) 492 CALL tab_1d_2d( nbpac, wfx_opw, npac(1:nbpac), wfx_opw_1d(1:nbpac), jpi, jpj ) 493 494 CALL tab_1d_2d( nbpac, hfx_thd, npac(1:nbpac), hfx_thd_1d(1:nbpac), jpi, jpj ) 495 CALL tab_1d_2d( nbpac, hfx_opw, npac(1:nbpac), hfx_opw_1d(1:nbpac), jpi, jpj ) 490 CALL tab_1d_2d( nidx, e_i(:,:,jk,jl), idxice(1:nidx), ze_i_1d(1:nidx,jk,jl), jpi, jpj ) 491 END DO 492 END DO 493 CALL tab_1d_2d( nidx, sfx_opw, idxice(1:nidx), sfx_opw_1d(1:nidx), jpi, jpj ) 494 CALL tab_1d_2d( nidx, wfx_opw, idxice(1:nidx), wfx_opw_1d(1:nidx), jpi, jpj ) 495 CALL tab_1d_2d( nidx, hfx_thd, idxice(1:nidx), hfx_thd_1d(1:nidx), jpi, jpj ) 496 CALL tab_1d_2d( nidx, hfx_opw, idxice(1:nidx), hfx_opw_1d(1:nidx), jpi, jpj ) 496 497 ! 497 ENDIF ! nbpac > 0 498 499 !------------------------------------------------------------------------------! 500 ! 8) Change units for e_i 501 !------------------------------------------------------------------------------! 502 DO jl = 1, jpl 503 DO jk = 1, nlay_i 504 DO jj = 1, jpj 505 DO ji = 1, jpi 506 ! heat content in J/m2 507 e_i(ji,jj,jk,jl) = e_i(ji,jj,jk,jl) * v_i(ji,jj,jl) * r1_nlay_i 508 END DO 509 END DO 510 END DO 511 END DO 512 498 ENDIF ! nidx > 0 513 499 ! 514 500 CALL wrk_dealloc( jpij, jcat ) ! integer -
branches/2017/dev_r8183_ICEMODEL/NEMOGCM/NEMO/LIM_SRC_3/limvar.F90
r8325 r8327 476 476 DO jk = 1, nlay_i 477 477 DO ji = kideb, kiut 478 ii = MOD( npb(ji) - 1 , jpi ) + 1479 ij = ( npb(ji) - 1 ) / jpi + 1478 ii = MOD( idxice(ji) - 1 , jpi ) + 1 479 ij = ( idxice(ji) - 1 ) / jpi + 1 480 480 ! zswi0 = 1 if sm_i le zsi0 and 0 otherwise 481 481 zswi0 = MAX( 0._wp , SIGN( 1._wp , zsi0 - sm_i_1d(ji) ) ) -
branches/2017/dev_r8183_ICEMODEL/NEMOGCM/NEMO/LIM_SRC_3/thd_ice.F90
r8326 r8327 26 26 !: are the variables corresponding to 2d vectors 27 27 28 INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: npb !: address vector for 1d vertical thermo computations 29 INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nplm !: address vector for mono-category lateral melting 30 INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: npac !: address vector for new ice formation 28 INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: idxice !: selected points for ice thermo 31 29 32 30 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: qlead_1d … … 64 62 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: wfx_ice_sub_1d 65 63 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: wfx_err_sub_1d 64 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: wfx_lam_1d 66 65 67 66 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: wfx_bog_1d … … 80 79 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: sfx_opw_1d 81 80 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: sfx_res_1d 82 83 81 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: sfx_sub_1d 82 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: sfx_lam_1d 84 83 85 84 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: sprecip_1d !: <==> the 2D sprecip … … 146 145 147 146 ii = 1 148 ALLOCATE( npb (jpij) , nplm (jpij) , npac(jpij) , &147 ALLOCATE( idxice (jpij) , & 149 148 & qlead_1d (jpij) , ftr_ice_1d(jpij) , qsr_ice_1d (jpij) , & 150 149 & fr1_i0_1d(jpij) , fr2_i0_1d (jpij) , qns_ice_1d(jpij) , & … … 163 162 & wfx_sum_1d(jpij) , wfx_sni_1d (jpij) , wfx_opw_1d (jpij) , wfx_res_1d(jpij) , & 164 163 & wfx_snw_sub_1d(jpij), wfx_ice_sub_1d(jpij), wfx_err_sub_1d(jpij) , & 165 & dqns_ice_1d(jpij) , evap_ice_1d (jpij),&164 & wfx_lam_1d(jpij) , dqns_ice_1d(jpij) , evap_ice_1d (jpij), & 166 165 & qprec_ice_1d(jpij), qevap_ice_1d(jpij), i0 (jpij) , & 167 166 & sfx_bri_1d (jpij) , sfx_bog_1d (jpij) , sfx_bom_1d (jpij) , sfx_sum_1d (jpij), & 168 167 & sfx_sni_1d (jpij) , sfx_opw_1d (jpij) , sfx_res_1d (jpij) , sfx_sub_1d (jpij), & 169 & hicol_1d (jpij) , STAT=ierr(ii) )168 & sfx_lam_1d (jpij) , hicol_1d (jpij) , STAT=ierr(ii) ) 170 169 ! 171 170 ii = ii + 1
Note: See TracChangeset
for help on using the changeset viewer.