- Timestamp:
- 2012-04-30T12:50:36+02:00 (12 years ago)
- Location:
- branches/2012/dev_r3337_NOCS10_ICB/NEMOGCM/NEMO/OPA_SRC/ICB
- Files:
-
- 10 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2012/dev_r3337_NOCS10_ICB/NEMOGCM/NEMO/OPA_SRC/ICB/icbclv.F90
r3370 r3372 12 12 !!---------------------------------------------------------------------- 13 13 !!---------------------------------------------------------------------- 14 !! accumulate_calving :15 !! icb_ gen : generate test icebergs14 !! icb_clv_flx : transfer input flux of ice into iceberg classes 15 !! icb_clv : calve icebergs from stored ice 16 16 !!---------------------------------------------------------------------- 17 17 USE par_oce ! NEMO parameters … … 28 28 PRIVATE 29 29 30 PUBLIC accumulate_calving! routine called in icbrun.F90 module31 PUBLIC calve_icebergs! routine called in icbrun.F90 module30 PUBLIC icb_clv_flx ! routine called in icbrun.F90 module 31 PUBLIC icb_clv ! routine called in icbrun.F90 module 32 32 33 33 !!---------------------------------------------------------------------- … … 38 38 CONTAINS 39 39 40 SUBROUTINE accumulate_calving( kt )40 SUBROUTINE icb_clv_flx( kt ) 41 41 !!---------------------------------------------------------------------- 42 !! *** ROUTINE accumulate_calving***42 !! *** ROUTINE icb_clv_flx *** 43 43 !! 44 44 !! ** Purpose : ? … … 95 95 berg_grid%tmp(:,:) = berg_dt * berg_grid%calving_hflx(:,:) * e1e2t(:,:) * tmask_i(:,:) 96 96 berg_grid%stored_heat (:,:) = berg_grid%stored_heat (:,:) + berg_grid%tmp(:,:) 97 CALL i ncoming_budget( kt, zcalving_used, berg_grid%tmp )97 CALL icb_dia_income( kt, zcalving_used, berg_grid%tmp ) 98 98 ! 99 END SUBROUTINE accumulate_calving99 END SUBROUTINE icb_clv_flx 100 100 101 SUBROUTINE calve_icebergs()101 SUBROUTINE icb_clv() 102 102 !!---------------------------------------------------------------------- 103 !! *** ROUTINE calve_icebergs***103 !! *** ROUTINE icb_clv *** 104 104 !! 105 !! ** Purpose : This seems to be the routine thattakes a stored ice field and calves to the ocean,106 !! so I assume thatthe gridded array stored_ice has only non-zero entries at selected105 !! ** Purpose : This routine takes a stored ice field and calves to the ocean, 106 !! so the gridded array stored_ice has only non-zero entries at selected 107 107 !! wet points adjacent to known land based calving points 108 108 !! 109 109 !! ** method : - Look at each grid point and see if there's enough for each size class to calve 110 110 !! If there is, a new iceberg is calved. This happens in the order determined by 111 !! the class definition arrays ( largest first?)111 !! the class definition arrays (which in the default case is smallest first) 112 112 !! Note that only the non-overlapping part of the processor where icebergs are allowed 113 113 !! is considered … … 150 150 newpt%heat_density = berg_grid%stored_heat(ji,jj) / berg_grid%stored_ice(ji,jj,jn) ! This is in J/kg 151 151 ! 152 CALL i ncrement_kounter()152 CALL icb_utl_incr() 153 153 newberg%number(:) = num_bergs(:) 154 154 ! 155 CALL add_new_berg_to_list( newberg, newpt )155 CALL icb_utl_add( newberg, newpt ) 156 156 ! 157 157 zcalved_to_berg = rn_initial_mass(jn) * rn_mass_scaling(jn) ! Units of kg … … 165 165 icnt = icnt + 1 166 166 ! 167 CALL calving_budget(ji, jj, jn, zcalved_to_berg, zheat_to_berg )167 CALL icb_dia_calve(ji, jj, jn, zcalved_to_berg, zheat_to_berg ) 168 168 END DO 169 169 icntmax = MAX( icntmax, icnt ) … … 177 177 CALL lbc_lnk( berg_grid%stored_heat, 'T', 1._wp ) 178 178 ! 179 IF( nn_verbose_level > 0 .AND. icntmax > 1 ) WRITE(numicb,*) ' calve_icebergs: icnt=', icnt,' on', narea179 IF( nn_verbose_level > 0 .AND. icntmax > 1 ) WRITE(numicb,*) 'icb_clv: icnt=', icnt,' on', narea 180 180 ! 181 END SUBROUTINE calve_icebergs181 END SUBROUTINE icb_clv 182 182 183 183 !!====================================================================== -
branches/2012/dev_r3337_NOCS10_ICB/NEMOGCM/NEMO/OPA_SRC/ICB/icbdia.F90
r3370 r3372 14 14 !!---------------------------------------------------------------------- 15 15 !!---------------------------------------------------------------------- 16 !! icb_ budget_end : end iceberg budgeting17 !! icb_ budget_init : initialise iceberg budgeting16 !! icb_dia_end : end iceberg budgeting 17 !! icb_dia_init : initialise iceberg budgeting 18 18 !!---------------------------------------------------------------------- 19 19 USE par_oce ! ocean parameters … … 28 28 PRIVATE 29 29 30 PUBLIC icb_ budget_end! routine called in icbrun.F90 module31 PUBLIC icb_ budget_init! routine called in icbini.F90 module32 PUBLIC icb_ budget! routine called in icbrun.F90 module33 PUBLIC icb_ budget_step! routine called in icbrun.F90 module34 PUBLIC icb_ budget_put! routine called in icbrun.F90 module35 PUBLIC melt_budget! routine called in icbthm.F90 module36 PUBLIC size_budget! routine called in icbthm.F90 module37 PUBLIC speed_budget! routine called in icbdyn.F90 module38 PUBLIC calving_budget! routine called in icbclv.F90 module39 PUBLIC i ncoming_budget! routine called in icbclv.F90 module30 PUBLIC icb_dia_end ! routine called in icbrun.F90 module 31 PUBLIC icb_dia_init ! routine called in icbini.F90 module 32 PUBLIC icb_dia ! routine called in icbrun.F90 module 33 PUBLIC icb_dia_step ! routine called in icbrun.F90 module 34 PUBLIC icb_dia_put ! routine called in icbrun.F90 module 35 PUBLIC icb_dia_melt ! routine called in icbthm.F90 module 36 PUBLIC icb_dia_size ! routine called in icbthm.F90 module 37 PUBLIC icb_dia_speed ! routine called in icbdyn.F90 module 38 PUBLIC icb_dia_calve ! routine called in icbclv.F90 module 39 PUBLIC icb_dia_income ! routine called in icbclv.F90 module 40 40 41 41 REAL(wp), DIMENSION(:,:) , POINTER, PUBLIC :: berg_melt => NULL() ! Melting+erosion rate of icebergs [kg/s/m2] … … 83 83 CONTAINS 84 84 85 SUBROUTINE icb_ budget_end85 SUBROUTINE icb_dia_end 86 86 !!---------------------------------------------------------------------- 87 87 ! … … 103 103 ENDIF 104 104 ! 105 END SUBROUTINE icb_budget_end 106 107 !!------------------------------------------------------------------------- 108 109 SUBROUTINE icb_budget_init( ) 105 END SUBROUTINE icb_dia_end 106 107 108 SUBROUTINE icb_dia_init( ) 110 109 !!---------------------------------------------------------------------- 111 110 !!---------------------------------------------------------------------- … … 160 159 bits_src_net = 0._wp 161 160 162 floating_mass_start = sum_mass( first_berg )163 bergs_mass_start = sum_mass( first_berg, justbergs=.true. )164 bits_mass_start = sum_mass( first_berg, justbits=.true. )161 floating_mass_start = icb_utl_mass( first_berg ) 162 bergs_mass_start = icb_utl_mass( first_berg, justbergs=.true. ) 163 bits_mass_start = icb_utl_mass( first_berg, justbits=.true. ) 165 164 IF( lk_mpp ) THEN 166 165 ALLOCATE( rsumbuf(23) ) ; rsumbuf(:) = 0._wp … … 175 174 ENDIF 176 175 ! 177 END SUBROUTINE icb_ budget_init178 179 180 SUBROUTINE icb_ budget( ld_budge )176 END SUBROUTINE icb_dia_init 177 178 179 SUBROUTINE icb_dia( ld_budge ) 181 180 !!---------------------------------------------------------------------- 182 181 !!---------------------------------------------------------------------- … … 207 206 stored_end = SUM( berg_grid%stored_ice(:,:,:) ) 208 207 stored_heat_end = SUM( berg_grid%stored_heat(:,:) ) 209 floating_mass_end = sum_mass( first_berg )210 bergs_mass_end = sum_mass( first_berg,justbergs=.true. )211 bits_mass_end = sum_mass( first_berg,justbits=.true. )212 floating_heat_end = sum_heat( first_berg )213 214 nbergs_end = count_bergs()208 floating_mass_end = icb_utl_mass( first_berg ) 209 bergs_mass_end = icb_utl_mass( first_berg,justbergs=.true. ) 210 bits_mass_end = icb_utl_mass( first_berg,justbits=.true. ) 211 floating_heat_end = icb_utl_heat( first_berg ) 212 213 nbergs_end = icb_utl_count() 215 214 zgrdd_berg_mass = SUM( berg_mass (:,:)*e1e2t(:,:)*tmask_i(:,:) ) 216 215 zgrdd_bits_mass = SUM( bits_mass(:,:)*e1e2t(:,:)*tmask_i(:,:) ) … … 364 363 ENDIF 365 364 ! 366 END SUBROUTINE icb_ budget367 368 369 SUBROUTINE icb_ budget_step365 END SUBROUTINE icb_dia 366 367 368 SUBROUTINE icb_dia_step 370 369 !!---------------------------------------------------------------------- 371 370 !! things to reset at the beginning of each timestep … … 385 384 real_calving (:,:,:) = 0._wp 386 385 ! 387 END SUBROUTINE icb_ budget_step388 389 390 SUBROUTINE icb_ budget_put386 END SUBROUTINE icb_dia_step 387 388 389 SUBROUTINE icb_dia_put 391 390 !!---------------------------------------------------------------------- 392 391 !!---------------------------------------------------------------------- … … 405 404 CALL iom_put( "berg_real_calving", real_calving(:,:,:) ) ! Calving into iceberg class [kg/s] 406 405 ! 407 END SUBROUTINE icb_ budget_put408 409 410 SUBROUTINE calving_budget( ki, kj, kn, pcalved, pheated )406 END SUBROUTINE icb_dia_put 407 408 409 SUBROUTINE icb_dia_calve( ki, kj, kn, pcalved, pheated ) 411 410 !!---------------------------------------------------------------------- 412 411 !!---------------------------------------------------------------------- … … 423 422 heat_to_bergs_net = heat_to_bergs_net + pheated 424 423 ! 425 END SUBROUTINE calving_budget426 427 428 SUBROUTINE i ncoming_budget( kt, pcalving_used, pheat_used )424 END SUBROUTINE icb_dia_calve 425 426 427 SUBROUTINE icb_dia_income( kt, pcalving_used, pheat_used ) 429 428 !!---------------------------------------------------------------------- 430 429 !!---------------------------------------------------------------------- … … 439 438 stored_start = SUM( berg_grid%stored_ice(:,:,:) ) 440 439 IF( lk_mpp ) CALL mpp_sum( stored_start ) 441 WRITE(numicb,'(a,es13.6,a)') ' accumulate_calving: initial stored mass=',stored_start,' kg'440 WRITE(numicb,'(a,es13.6,a)') 'icb_dia_income: initial stored mass=',stored_start,' kg' 442 441 ! 443 442 stored_heat_start = SUM( berg_grid%stored_heat(:,:) ) 444 443 IF( lk_mpp ) CALL mpp_sum( stored_heat_start ) 445 WRITE(numicb,'(a,es13.6,a)') ' accumulate_calving: initial stored heat=',stored_heat_start,' J'444 WRITE(numicb,'(a,es13.6,a)') 'icb_dia_income: initial stored heat=',stored_heat_start,' J' 446 445 ENDIF 447 446 ! … … 453 452 calving_src_heat_used_net = calving_src_heat_used_net + SUM( pheat_used(:,:) ) 454 453 ! 455 END SUBROUTINE i ncoming_budget456 457 458 SUBROUTINE size_budget(ki, kj, pWn, pLn, pAbits, &459 & pmass_scale, pMnew, pnMbits, pz1_e1e2)454 END SUBROUTINE icb_dia_income 455 456 457 SUBROUTINE icb_dia_size(ki, kj, pWn, pLn, pAbits, & 458 & pmass_scale, pMnew, pnMbits, pz1_e1e2) 460 459 !!---------------------------------------------------------------------- 461 460 !!---------------------------------------------------------------------- … … 469 468 bits_mass(ki,kj) = bits_mass(ki,kj) + pnMbits * pz1_e1e2 ! kg/m2 470 469 ! 471 END SUBROUTINE size_budget472 473 474 SUBROUTINE speed_budget()470 END SUBROUTINE icb_dia_size 471 472 473 SUBROUTINE icb_dia_speed() 475 474 !!---------------------------------------------------------------------- 476 475 !!---------------------------------------------------------------------- … … 479 478 nspeeding_tickets = nspeeding_tickets + 1 480 479 ! 481 END SUBROUTINE speed_budget482 483 484 SUBROUTINE melt_budget(ki, kj, pmnew, pheat, pmass_scale, &480 END SUBROUTINE icb_dia_speed 481 482 483 SUBROUTINE icb_dia_melt(ki, kj, pmnew, pheat, pmass_scale, & 485 484 & pdM, pdMbitsE, pdMbitsM, pdMb, pdMe, & 486 485 & pdMv, pz1_dt_e1e2 ) … … 503 502 IF( pmnew <= 0._wp ) nbergs_melted = nbergs_melted + 1 ! Delete the berg if completely melted 504 503 ! 505 END SUBROUTINE melt_budget504 END SUBROUTINE icb_dia_melt 506 505 507 506 -
branches/2012/dev_r3337_NOCS10_ICB/NEMOGCM/NEMO/OPA_SRC/ICB/icbdyn.F90
r3370 r3372 24 24 PRIVATE 25 25 26 PUBLIC evolve_icebergs! routine called in icbrun.F90 module26 PUBLIC icb_dyn ! routine called in icbrun.F90 module 27 27 28 28 !!---------------------------------------------------------------------- … … 33 33 CONTAINS 34 34 35 SUBROUTINE evolve_icebergs()36 !!---------------------------------------------------------------------- 37 !! *** ROUTINE evolve_icebergs***35 SUBROUTINE icb_dyn() 36 !!---------------------------------------------------------------------- 37 !! *** ROUTINE icb_dyn *** 38 38 !! 39 39 !! ** Purpose : iceberg evolution. … … 84 84 85 85 ! !** A1 = A(X1,V1) 86 CALL accel( berg , zxi1, ze1, zuvel1, zuvel1, zax1, &87 & zyj1, ze2, zvvel1, zvvel1, zay1, zdt_2 )86 CALL icb_accel( berg , zxi1, ze1, zuvel1, zuvel1, zax1, & 87 & zyj1, ze2, zvvel1, zvvel1, zay1, zdt_2 ) 88 88 ! 89 89 zu1 = zuvel1 / ze1 !** V1 in d(i,j)/dt … … 97 97 zyj2 = zyj1 + zdt_2 * zv1 ; zvvel2 = zvvel1 + zdt_2 * zay1 98 98 ! 99 CALL adjust_to_ground( zxi2, zxi1, zu1, &100 & 99 CALL icb_ground( zxi2, zxi1, zu1, & 100 & zyj2, zyj1, zv1, ll_bounced ) 101 101 102 102 ! !** A2 = A(X2,V2) 103 CALL accel( berg , zxi2, ze1, zuvel2, zuvel1, zax2, &104 & zyj2, ze2, zvvel2, zvvel1, zay2, zdt_2 )103 CALL icb_accel( berg , zxi2, ze1, zuvel2, zuvel1, zax2, & 104 & zyj2, ze2, zvvel2, zvvel1, zay2, zdt_2 ) 105 105 ! 106 106 zu2 = zuvel2 / ze1 !** V2 in d(i,j)/dt … … 113 113 zyj3 = zyj1 + zdt_2 * zv2 ; zvvel3 = zvvel1 + zdt_2 * zay2 114 114 ! 115 CALL adjust_to_ground( zxi3, zxi1, zu3, &116 & 115 CALL icb_ground( zxi3, zxi1, zu3, & 116 & zyj3, zyj1, zv3, ll_bounced ) 117 117 118 118 ! !** A3 = A(X3,V3) 119 CALL accel( berg , zxi3, ze1, zuvel3, zuvel1, zax3, &120 & zyj3, ze2, zvvel3, zvvel1, zay3, zdt )119 CALL icb_accel( berg , zxi3, ze1, zuvel3, zuvel1, zax3, & 120 & zyj3, ze2, zvvel3, zvvel1, zay3, zdt ) 121 121 ! 122 122 zu3 = zuvel3 / ze1 !** V3 in d(i,j)/dt … … 129 129 zyj4 = zyj1 + zdt * zv3 ; zvvel4 = zvvel1 + zdt * zay3 130 130 131 CALL adjust_to_ground( zxi4, zxi1, zu4, &132 & 131 CALL icb_ground( zxi4, zxi1, zu4, & 132 & zyj4, zyj1, zv4, ll_bounced ) 133 133 134 134 ! !** A4 = A(X4,V4) 135 CALL accel( berg , zxi4, ze1, zuvel4, zuvel1, zax4, &136 & zyj4, ze2, zvvel4, zvvel1, zay4, zdt )135 CALL icb_accel( berg , zxi4, ze1, zuvel4, zuvel1, zax4, & 136 & zyj4, ze2, zvvel4, zvvel1, zay4, zdt ) 137 137 138 138 zu4 = zuvel4 / ze1 !** V4 in d(i,j)/dt … … 148 148 zvvel_n = pt%vvel + zdt_6 * ( zay1 + 2.*(zay2 + zay3) + zay4 ) 149 149 150 CALL adjust_to_ground( zxi_n, zxi1, zuvel_n, &150 CALL icb_ground( zxi_n, zxi1, zuvel_n, & 151 151 & zyj_n, zyj1, zvvel_n, ll_bounced ) 152 152 … … 157 157 158 158 ! update actual position 159 pt%lon = bilin_x(glamt, pt%xi, pt%yj )160 pt%lat = bilin(gphit, pt%xi, pt%yj, 'T', 0, 0 )159 pt%lon = icb_utl_bilin_x(glamt, pt%xi, pt%yj ) 160 pt%lat = icb_utl_bilin(gphit, pt%xi, pt%yj, 'T', 0, 0 ) 161 161 162 162 berg => berg%next ! switch to the next berg … … 164 164 END DO !== end loop over all bergs ==! 165 165 ! 166 END SUBROUTINE evolve_icebergs167 168 169 SUBROUTINE adjust_to_ground( pi, pi0, pu, &166 END SUBROUTINE icb_dyn 167 168 169 SUBROUTINE icb_ground( pi, pi0, pu, & 170 170 & pj, pj0, pv, ld_bounced ) 171 171 !!---------------------------------------------------------------------- 172 !! *** ROUTINE adjust_to_ground ***172 !! *** ROUTINE icb_ground *** 173 173 !! 174 174 !! ** Purpose : iceberg grounding. … … 230 230 END SELECT 231 231 ! 232 END SUBROUTINE adjust_to_ground233 234 235 SUBROUTINE accel( berg , pxi, pe1, puvel, puvel0, pax, &236 & pyj, pe2, pvvel, pvvel0, pay, pdt )237 !!---------------------------------------------------------------------- 238 !! *** ROUTINE accel ***232 END SUBROUTINE icb_ground 233 234 235 SUBROUTINE icb_accel( berg , pxi, pe1, puvel, puvel0, pax, & 236 & pyj, pe2, pvvel, pvvel0, pay, pdt ) 237 !!---------------------------------------------------------------------- 238 !! *** ROUTINE icb_accel *** 239 239 !! 240 240 !! ** Purpose : compute the iceberg acceleration. … … 268 268 ! Interpolate gridded fields to berg 269 269 nknberg = berg%number(1) 270 CALL i nterp_flds( pxi, pe1, zuo, zui, zua, zssh_x, &271 & pyj, pe2, zvo, zvi, zva, zssh_y, zsst, zcn, zhi, zff )270 CALL icb_utl_interp( pxi, pe1, zuo, zui, zua, zssh_x, & 271 & pyj, pe2, zvo, zvi, zva, zssh_y, zsst, zcn, zhi, zff ) 272 272 273 273 zM = berg%current_point%mass … … 364 364 zuveln = zuveln * ( zspeed_new / zspeed ) ! Scale velocity to reduce speed 365 365 zvveln = zvveln * ( zspeed_new / zspeed ) ! without changing the direction 366 CALL speed_budget()366 CALL icb_dia_speed() 367 367 ENDIF 368 368 ENDIF … … 374 374 WRITE(numicb,'("pe=",i3,x,a)') narea,'Dump triggered by excessive acceleration' 375 375 ! 376 END SUBROUTINE accel376 END SUBROUTINE icb_accel 377 377 378 378 !!====================================================================== -
branches/2012/dev_r3337_NOCS10_ICB/NEMOGCM/NEMO/OPA_SRC/ICB/icbini.F90
r3371 r3372 12 12 !!---------------------------------------------------------------------- 13 13 !!---------------------------------------------------------------------- 14 !! icb_init 15 !! icb_ gen: generate test icebergs16 !! icb_nam 14 !! icb_init : initialise icebergs 15 !! icb_ini_gen : generate test icebergs 16 !! icb_nam : read iceberg namelist 17 17 !!---------------------------------------------------------------------- 18 18 USE dom_oce ! ocean domain … … 34 34 35 35 PUBLIC icb_init ! routine called in nemogcm.F90 module 36 PUBLIC icb_gen ! routine called in icbclv.F90 module37 36 38 37 CHARACTER(len=100) :: cn_dir = './' ! Root directory for location of icb files … … 244 243 245 244 IF( .NOT.ln_rstart ) THEN 246 IF( nn_test_icebergs > 0 ) CALL icb_ gen()245 IF( nn_test_icebergs > 0 ) CALL icb_ini_gen() 247 246 ELSE 248 247 IF( nn_test_icebergs > 0 ) THEN 249 CALL icb_ gen()248 CALL icb_ini_gen() 250 249 ELSE 251 CALL ic ebergs_read_restart()252 253 ENDIF 254 ENDIF 255 ! 256 IF( nn_sample_rate .GT. 0 ) CALL traj_init( nitend )257 ! 258 CALL icb_ budget_init()259 ! 260 IF( nn_verbose_level >= 2 ) CALL print_bergs('icb_init, initial status', nit000-1)250 CALL icb_rst_read() 251 l_restarted_bergs = .TRUE. 252 ENDIF 253 ENDIF 254 ! 255 IF( nn_sample_rate .GT. 0 ) CALL icb_trj_init( nitend ) 256 ! 257 CALL icb_dia_init() 258 ! 259 IF( nn_verbose_level >= 2 ) CALL icb_utl_print('icb_init, initial status', nit000-1) 261 260 ! 262 261 END SUBROUTINE icb_init 263 262 264 SUBROUTINE icb_ gen()265 !!---------------------------------------------------------------------- 266 !! *** ROUTINE icb_ gen ***263 SUBROUTINE icb_ini_gen() 264 !!---------------------------------------------------------------------- 265 !! *** ROUTINE icb_ini_gen *** 267 266 !! 268 267 !! ** Purpose : iceberg generation 269 268 !! 270 !! ** Method : - blah blah 269 !! ** Method : - at each grid point of the test box supplied in the namelist 270 !! generate an iceberg in one class determined by the value of 271 !! parameter nn_test_icebergs 271 272 !!---------------------------------------------------------------------- 272 273 INTEGER :: ji, jj, ibergs … … 301 302 localpt%xi = REAL( nimpp+ji-1, wp ) 302 303 localpt%yj = REAL( njmpp+jj-1, wp ) 303 localpt%lon = bilin(glamt, localpt%xi, localpt%yj, 'T', 0, 0 )304 localpt%lat = bilin(gphit, localpt%xi, localpt%yj, 'T', 0, 0 )304 localpt%lon = icb_utl_bilin(glamt, localpt%xi, localpt%yj, 'T', 0, 0 ) 305 localpt%lat = icb_utl_bilin(gphit, localpt%xi, localpt%yj, 'T', 0, 0 ) 305 306 localpt%mass = rn_initial_mass (iberg) 306 307 localpt%thickness = rn_initial_thickness(iberg) … … 313 314 localpt%uvel = 0._wp 314 315 localpt%vvel = 0._wp 315 CALL i ncrement_kounter()316 CALL icb_utl_incr() 316 317 localberg%number(:) = num_bergs(:) 317 call add_new_berg_to_list(localberg, localpt)318 call icb_utl_add(localberg, localpt) 318 319 ENDIF 319 320 END DO 320 321 END DO 321 322 ! 322 ibergs = count_bergs()323 ibergs = icb_utl_count() 323 324 IF( lk_mpp ) CALL mpp_sum(ibergs) 324 WRITE(numicb,'(a,i6,a)') 'diamonds, icb_ gen: ',ibergs,' were generated'325 ! 326 END SUBROUTINE icb_ gen325 WRITE(numicb,'(a,i6,a)') 'diamonds, icb_ini_gen: ',ibergs,' were generated' 326 ! 327 END SUBROUTINE icb_ini_gen 327 328 328 329 SUBROUTINE icb_nam … … 381 382 IF( zfact < 1._wp ) THEN 382 383 IF( zfact <= 0._wp ) THEN 383 CALL ctl_stop( 'icb_ init: sum of berg distribution equal to zero' )384 CALL ctl_stop( 'icb_nam: sum of berg distribution equal to zero' ) 384 385 ELSE 385 386 rn_distribution(:) = rn_distribution(:) / zfact 386 CALL ctl_warn( 'icb_ init: sum of berg input distribution not equal to one and so RESCALED' )387 CALL ctl_warn( 'icb_nam: sum of berg input distribution not equal to one and so RESCALED' ) 387 388 ENDIF 388 389 ENDIF -
branches/2012/dev_r3337_NOCS10_ICB/NEMOGCM/NEMO/OPA_SRC/ICB/icblbc.F90
r3370 r3372 14 14 !!---------------------------------------------------------------------- 15 15 !!---------------------------------------------------------------------- 16 !! mpp_send_bergs : In MPP pass icebergs from linked list between processors 17 !! as they advect around 18 !! Lagrangian processes cannot be handled by existing NEMO MPP 19 !! routines because they do not lie on regular jpi,jpj grids 20 !! Processor exchanges are handled as in lib_mpp whenever icebergs step 21 !! across boundary of interior domain (nicbdi-nicbei, nicbdj-nicbej) 22 !! so that iceberg does not exist in more than one processor 23 !! North fold exchanges controlled by three arrays: 24 !! nicbflddest - unique processor numbers that current one exchanges with 25 !! nicbfldproc - processor number that current grid point exchanges with 26 !! nicbfldpts - packed i,j point in exchanging processor 16 !! icb_lbc : Pass icebergs across cyclic boundaries 17 !! icb_lbc_mpp : In MPP pass icebergs from linked list between processors 18 !! as they advect around 19 !! Lagrangian processes cannot be handled by existing NEMO MPP 20 !! routines because they do not lie on regular jpi,jpj grids 21 !! Processor exchanges are handled as in lib_mpp whenever icebergs step 22 !! across boundary of interior domain (nicbdi-nicbei, nicbdj-nicbej) 23 !! so that iceberg does not exist in more than one processor 24 !! North fold exchanges controlled by three arrays: 25 !! nicbflddest - unique processor numbers that current one exchanges with 26 !! nicbfldproc - processor number that current grid point exchanges with 27 !! nicbfldpts - packed i,j point in exchanging processor 27 28 !!---------------------------------------------------------------------- 28 29 … … 61 62 #endif 62 63 63 PUBLIC lbc_send_bergs 64 PRIVATE lbc_nfld_bergs 65 PUBLIC mpp_send_bergs 66 PUBLIC dealloc_buffers 67 68 #if defined key_mpp_mpi 69 PRIVATE mpp_nfld_bergs 70 PRIVATE dealloc_buffer 71 PRIVATE pack_berg_into_buffer 72 PRIVATE unpack_berg_from_buffer 73 PRIVATE increase_buffer 74 PRIVATE increase_ibuffer 75 #endif 64 PUBLIC icb_lbc 65 PUBLIC icb_lbc_mpp 76 66 77 67 !!---------------------------------------------------------------------- … … 82 72 CONTAINS 83 73 84 SUBROUTINE lbc_send_bergs()85 !!---------------------------------------------------------------------- 86 !! *** SUBROUTINE lbc_send_bergs***74 SUBROUTINE icb_lbc() 75 !!---------------------------------------------------------------------- 76 !! *** SUBROUTINE icb_lbc *** 87 77 !! 88 78 !! ** Purpose : in non-mpp case need to deal with cyclic conditions … … 118 108 IF( nperio == 2 ) CALL ctl_stop(' south symmetric condition not implemented for icebergs') 119 109 ! north fold 120 IF( nperio == 3 .OR. nperio == 4 .OR. nperio == 5 .OR. nperio == 6 ) CALL lbc_nfld_bergs()121 ! 122 END SUBROUTINE lbc_send_bergs123 124 125 SUBROUTINE lbc_nfld_bergs()126 !!---------------------------------------------------------------------- 127 !! *** SUBROUTINE lbc_nfld_bergs***110 IF( nperio == 3 .OR. nperio == 4 .OR. nperio == 5 .OR. nperio == 6 ) CALL icb_lbc_nfld() 111 ! 112 END SUBROUTINE icb_lbc 113 114 115 SUBROUTINE icb_lbc_nfld() 116 !!---------------------------------------------------------------------- 117 !! *** SUBROUTINE icb_lbc_nfld *** 128 118 !! 129 119 !! ** Purpose : single processor north fold exchange … … 156 146 END DO 157 147 ! 158 END SUBROUTINE lbc_nfld_bergs148 END SUBROUTINE icb_lbc_nfld 159 149 160 150 #if defined key_mpp_mpi … … 163 153 !!---------------------------------------------------------------------- 164 154 165 SUBROUTINE mpp_send_bergs()166 !!---------------------------------------------------------------------- 167 !! *** SUBROUTINE mpp_send_bergs***155 SUBROUTINE icb_lbc_mpp() 156 !!---------------------------------------------------------------------- 157 !! *** SUBROUTINE icb_lbc_mpp *** 168 158 !! 169 159 !! ** Purpose : multi processor exchange … … 221 211 ! periodicity is handled here when using mpp when there is more than one processor in 222 212 ! the i direction, but it also has to happen when jpni=1 case so this is dealt with 223 ! in lbc_send_bergsand called here224 225 IF( jpni == 1 ) CALL lbc_send_bergs()213 ! in icb_lbc and called here 214 215 IF( jpni == 1 ) CALL icb_lbc() 226 216 227 217 ! Note that xi is adjusted when swapping because of periodic condition … … 229 219 IF( nn_verbose_level > 0 ) THEN 230 220 ! store the number of icebergs on this processor at start 231 ibergs_start = count_bergs()221 ibergs_start = icb_utl_count() 232 222 ENDIF 233 223 … … 257 247 tmpberg%current_point%xi = ricb_right + MOD(tmpberg%current_point%xi, 1._wp ) - 1._wp 258 248 ! now pack it into buffer and delete from list 259 CALL pack_berg_into_buffer( tmpberg, obuffer_e, ibergs_to_send_e)260 CALL delete_iceberg_from_list(first_berg, tmpberg)249 CALL icb_pack_into_buffer( tmpberg, obuffer_e, ibergs_to_send_e) 250 CALL icb_utl_delete(first_berg, tmpberg) 261 251 ELSE IF( ipe_W >= 0 .AND. iine < nimpp+nicbdi-1 ) THEN 262 252 tmpberg => this … … 270 260 tmpberg%current_point%xi = ricb_left + MOD(tmpberg%current_point%xi, 1._wp ) 271 261 ! now pack it into buffer and delete from list 272 CALL pack_berg_into_buffer( tmpberg, obuffer_w, ibergs_to_send_w)273 CALL delete_iceberg_from_list(first_berg, tmpberg)262 CALL icb_pack_into_buffer( tmpberg, obuffer_w, ibergs_to_send_w) 263 CALL icb_utl_delete(first_berg, tmpberg) 274 264 ELSE 275 265 this => this%next … … 320 310 IF( ibergs_to_send_e > 0 ) CALL mppsend( 14, obuffer_e%data, ibergs_to_send_e*jp_buffer_width, ipe_E, iml_req1 ) 321 311 IF( ibergs_rcvd_from_e > 0 ) THEN 322 CALL i ncrease_ibuffer(ibuffer_e, ibergs_rcvd_from_e)312 CALL icb_increase_ibuffer(ibuffer_e, ibergs_rcvd_from_e) 323 313 CALL mpprecv( 13, ibuffer_e%data, ibergs_rcvd_from_e*jp_buffer_width ) 324 314 ENDIF … … 329 319 CALL flush( numicb ) 330 320 ENDIF 331 CALL unpack_berg_from_buffer(first_berg, ibuffer_e, i)321 CALL icb_unpack_from_buffer(first_berg, ibuffer_e, i) 332 322 ENDDO 333 323 CASE( 0 ) … … 335 325 IF( ibergs_to_send_e > 0 ) CALL mppsend( 14, obuffer_e%data, ibergs_to_send_e*jp_buffer_width, ipe_E, iml_req3 ) 336 326 IF( ibergs_rcvd_from_e > 0 ) THEN 337 CALL i ncrease_ibuffer(ibuffer_e, ibergs_rcvd_from_e)327 CALL icb_increase_ibuffer(ibuffer_e, ibergs_rcvd_from_e) 338 328 CALL mpprecv( 13, ibuffer_e%data, ibergs_rcvd_from_e*jp_buffer_width ) 339 329 ENDIF 340 330 IF( ibergs_rcvd_from_w > 0 ) THEN 341 CALL i ncrease_ibuffer(ibuffer_w, ibergs_rcvd_from_w)331 CALL icb_increase_ibuffer(ibuffer_w, ibergs_rcvd_from_w) 342 332 CALL mpprecv( 14, ibuffer_w%data, ibergs_rcvd_from_w*jp_buffer_width ) 343 333 ENDIF … … 349 339 CALL flush( numicb ) 350 340 ENDIF 351 CALL unpack_berg_from_buffer(first_berg, ibuffer_e, i)341 CALL icb_unpack_from_buffer(first_berg, ibuffer_e, i) 352 342 END DO 353 343 DO i = 1, ibergs_rcvd_from_w … … 356 346 CALL flush( numicb ) 357 347 ENDIF 358 CALL unpack_berg_from_buffer(first_berg, ibuffer_w, i)348 CALL icb_unpack_from_buffer(first_berg, ibuffer_w, i) 359 349 ENDDO 360 350 CASE( 1 ) 361 351 IF( ibergs_to_send_w > 0 ) CALL mppsend( 13, obuffer_w%data, ibergs_to_send_w*jp_buffer_width, ipe_W, iml_req4 ) 362 352 IF( ibergs_rcvd_from_w > 0 ) THEN 363 CALL i ncrease_ibuffer(ibuffer_w, ibergs_rcvd_from_w)353 CALL icb_increase_ibuffer(ibuffer_w, ibergs_rcvd_from_w) 364 354 CALL mpprecv( 14, ibuffer_w%data, ibergs_rcvd_from_w*jp_buffer_width ) 365 355 ENDIF … … 370 360 CALL flush( numicb ) 371 361 ENDIF 372 CALL unpack_berg_from_buffer(first_berg, ibuffer_w, i)362 CALL icb_unpack_from_buffer(first_berg, ibuffer_w, i) 373 363 END DO 374 364 END SELECT … … 392 382 CALL flush( numicb ) 393 383 ENDIF 394 CALL pack_berg_into_buffer( tmpberg, obuffer_n, ibergs_to_send_n)395 CALL delete_iceberg_from_list(first_berg, tmpberg)384 CALL icb_pack_into_buffer( tmpberg, obuffer_n, ibergs_to_send_n) 385 CALL icb_utl_delete(first_berg, tmpberg) 396 386 ELSE IF( ipe_S >= 0 .AND. ijne .LT. njmpp+nicbdj-1 ) THEN 397 387 tmpberg => this … … 402 392 CALL flush( numicb ) 403 393 ENDIF 404 CALL pack_berg_into_buffer( tmpberg, obuffer_s, ibergs_to_send_s)405 CALL delete_iceberg_from_list(first_berg, tmpberg)394 CALL icb_pack_into_buffer( tmpberg, obuffer_s, ibergs_to_send_s) 395 CALL icb_utl_delete(first_berg, tmpberg) 406 396 ELSE 407 397 this => this%next … … 451 441 IF( ibergs_to_send_n > 0 ) CALL mppsend( 18, obuffer_n%data, ibergs_to_send_n*jp_buffer_width, ipe_N, iml_req1 ) 452 442 IF( ibergs_rcvd_from_n > 0 ) THEN 453 CALL i ncrease_ibuffer(ibuffer_n, ibergs_rcvd_from_n)443 CALL icb_increase_ibuffer(ibuffer_n, ibergs_rcvd_from_n) 454 444 CALL mpprecv( 17, ibuffer_n%data, ibergs_rcvd_from_n*jp_buffer_width ) 455 445 ENDIF … … 460 450 CALL flush( numicb ) 461 451 ENDIF 462 CALL unpack_berg_from_buffer(first_berg, ibuffer_n, i)452 CALL icb_unpack_from_buffer(first_berg, ibuffer_n, i) 463 453 END DO 464 454 CASE( 0 ) … … 466 456 IF( ibergs_to_send_n > 0 ) CALL mppsend( 18, obuffer_n%data, ibergs_to_send_n*jp_buffer_width, ipe_N, iml_req3 ) 467 457 IF( ibergs_rcvd_from_n > 0 ) THEN 468 CALL i ncrease_ibuffer(ibuffer_n, ibergs_rcvd_from_n)458 CALL icb_increase_ibuffer(ibuffer_n, ibergs_rcvd_from_n) 469 459 CALL mpprecv( 17, ibuffer_n%data, ibergs_rcvd_from_n*jp_buffer_width ) 470 460 ENDIF 471 461 IF( ibergs_rcvd_from_s > 0 ) THEN 472 CALL i ncrease_ibuffer(ibuffer_s, ibergs_rcvd_from_s)462 CALL icb_increase_ibuffer(ibuffer_s, ibergs_rcvd_from_s) 473 463 CALL mpprecv( 18, ibuffer_s%data, ibergs_rcvd_from_s*jp_buffer_width ) 474 464 ENDIF … … 480 470 CALL flush( numicb ) 481 471 ENDIF 482 CALL unpack_berg_from_buffer(first_berg, ibuffer_n, i)472 CALL icb_unpack_from_buffer(first_berg, ibuffer_n, i) 483 473 END DO 484 474 DO i = 1, ibergs_rcvd_from_s … … 487 477 CALL flush( numicb ) 488 478 ENDIF 489 CALL unpack_berg_from_buffer(first_berg, ibuffer_s, i)479 CALL icb_unpack_from_buffer(first_berg, ibuffer_s, i) 490 480 ENDDO 491 481 CASE( 1 ) 492 482 IF( ibergs_to_send_s > 0 ) CALL mppsend( 17, obuffer_s%data, ibergs_to_send_s*jp_buffer_width, ipe_S, iml_req4 ) 493 483 IF( ibergs_rcvd_from_s > 0 ) THEN 494 CALL i ncrease_ibuffer(ibuffer_s, ibergs_rcvd_from_s)484 CALL icb_increase_ibuffer(ibuffer_s, ibergs_rcvd_from_s) 495 485 CALL mpprecv( 18, ibuffer_s%data, ibergs_rcvd_from_s*jp_buffer_width ) 496 486 ENDIF … … 501 491 CALL flush( numicb ) 502 492 ENDIF 503 CALL unpack_berg_from_buffer(first_berg, ibuffer_s, i)493 CALL icb_unpack_from_buffer(first_berg, ibuffer_s, i) 504 494 END DO 505 495 END SELECT … … 507 497 IF( nn_verbose_level > 0 ) THEN 508 498 ! compare the number of icebergs on this processor from the start to the end 509 ibergs_end = count_bergs()499 ibergs_end = icb_utl_count() 510 500 i = ( ibergs_rcvd_from_n + ibergs_rcvd_from_s + ibergs_rcvd_from_e + ibergs_rcvd_from_w ) - & 511 501 ( ibergs_to_send_n + ibergs_to_send_s + ibergs_to_send_e + ibergs_to_send_w ) … … 542 532 543 533 ! deal with north fold if we necessary when there is more than one top row processor 544 ! note that for jpni=1 north fold has been dealt with above in call to lbc_send_bergs545 IF( npolj /= 0 .AND. jpni > 1 ) CALL mpp_nfld_bergs( )534 ! note that for jpni=1 north fold has been dealt with above in call to icb_lbc 535 IF( npolj /= 0 .AND. jpni > 1 ) CALL icb_lbc_mpp_nfld( ) 546 536 547 537 IF( nn_verbose_level > 0 ) THEN … … 574 564 CALL mppsync() 575 565 ! 576 END SUBROUTINE mpp_send_bergs577 578 579 SUBROUTINE mpp_nfld_bergs()580 !!---------------------------------------------------------------------- 581 !! *** SUBROUTINE mpp_nfld_bergs***566 END SUBROUTINE icb_lbc_mpp 567 568 569 SUBROUTINE icb_lbc_mpp_nfld() 570 !!---------------------------------------------------------------------- 571 !! *** SUBROUTINE icb_lbc_mpp_nfld *** 582 572 !! 583 573 !! ** Purpose : north fold treatment in multi processor exchange … … 639 629 CALL flush( numicb ) 640 630 ENDIF 641 CALL pack_berg_into_buffer( tmpberg, obuffer_f, ibergs_to_send)642 CALL delete_iceberg_from_list(first_berg, tmpberg)631 CALL icb_pack_into_buffer( tmpberg, obuffer_f, ibergs_to_send) 632 CALL icb_utl_delete(first_berg, tmpberg) 643 633 ENDIF 644 634 ! … … 668 658 CALL mppsend( 12, obuffer_f%data, ibergs_to_send*jp_buffer_width, ifldproc-1, iml_req2 ) 669 659 IF( ibergs_to_rcv > 0 ) THEN 670 CALL i ncrease_ibuffer(ibuffer_f, ibergs_to_rcv)660 CALL icb_increase_ibuffer(ibuffer_f, ibergs_to_rcv) 671 661 CALL mpprecv( 12, ibuffer_f%data, ibergs_to_rcv*jp_buffer_width ) 672 662 ENDIF … … 677 667 CALL flush( numicb ) 678 668 ENDIF 679 CALL unpack_berg_from_buffer(first_berg, ibuffer_f, jk )669 CALL icb_unpack_from_buffer(first_berg, ibuffer_f, jk ) 680 670 END DO 681 671 ! 682 672 END DO 683 673 ! 684 END SUBROUTINE mpp_nfld_bergs 685 686 687 SUBROUTINE dealloc_buffers() 688 !!---------------------------------------------------------------------- 689 !!---------------------------------------------------------------------- 690 CALL dealloc_buffer( obuffer_n ) 691 CALL dealloc_buffer( obuffer_s ) 692 CALL dealloc_buffer( obuffer_e ) 693 CALL dealloc_buffer( obuffer_w ) 694 CALL dealloc_buffer( ibuffer_n ) 695 CALL dealloc_buffer( ibuffer_s ) 696 CALL dealloc_buffer( ibuffer_e ) 697 CALL dealloc_buffer( ibuffer_w ) 698 699 END SUBROUTINE dealloc_buffers 700 701 702 SUBROUTINE dealloc_buffer( pbuff ) 703 !!---------------------------------------------------------------------- 704 !!---------------------------------------------------------------------- 705 TYPE(buffer), POINTER :: pbuff 706 !!---------------------------------------------------------------------- 707 IF( ASSOCIATED(pbuff) ) THEN 708 IF( ASSOCIATED(pbuff%data)) DEALLOCATE(pbuff%data) 709 DEALLOCATE(pbuff) 710 ENDIF 711 END SUBROUTINE dealloc_buffer 712 713 714 SUBROUTINE pack_berg_into_buffer( berg, pbuff, kb ) 674 END SUBROUTINE icb_lbc_mpp_nfld 675 676 677 SUBROUTINE icb_pack_into_buffer( berg, pbuff, kb ) 715 678 !!---------------------------------------------------------------------- 716 679 !!---------------------------------------------------------------------- … … 722 685 !!---------------------------------------------------------------------- 723 686 ! 724 IF( .NOT. ASSOCIATED(pbuff) ) CALL i ncrease_buffer( pbuff, jp_delta_buf )725 IF( kb .GT. pbuff%size ) CALL i ncrease_buffer( pbuff, jp_delta_buf )687 IF( .NOT. ASSOCIATED(pbuff) ) CALL icb_increase_buffer( pbuff, jp_delta_buf ) 688 IF( kb .GT. pbuff%size ) CALL icb_increase_buffer( pbuff, jp_delta_buf ) 726 689 727 690 !! pack points into buffer … … 747 710 END DO 748 711 ! 749 END SUBROUTINE pack_berg_into_buffer750 751 752 SUBROUTINE unpack_berg_from_buffer(first, pbuff, kb)712 END SUBROUTINE icb_pack_into_buffer 713 714 715 SUBROUTINE icb_unpack_from_buffer(first, pbuff, kb) 753 716 !!---------------------------------------------------------------------- 754 717 !!---------------------------------------------------------------------- … … 782 745 END DO 783 746 ! 784 CALL add_new_berg_to_list(currentberg, pt )785 ! 786 END SUBROUTINE unpack_berg_from_buffer787 788 789 SUBROUTINE i ncrease_buffer(old,kdelta)747 CALL icb_utl_add(currentberg, pt ) 748 ! 749 END SUBROUTINE icb_unpack_from_buffer 750 751 752 SUBROUTINE icb_increase_buffer(old,kdelta) 790 753 !!---------------------------------------------------------------------- 791 754 TYPE(buffer), POINTER :: old … … 809 772 old => new 810 773 ! 811 END SUBROUTINE i ncrease_buffer812 813 814 SUBROUTINE i ncrease_ibuffer(old,kdelta)774 END SUBROUTINE icb_increase_buffer 775 776 777 SUBROUTINE icb_increase_ibuffer(old,kdelta) 815 778 !!---------------------------------------------------------------------- 816 779 !!---------------------------------------------------------------------- … … 844 807 ENDIF 845 808 old => new 846 !WRITE( numicb,*) 'i ncrease_ibuffer',narea,' increased to',inew_size847 ENDIF 848 ! 849 END SUBROUTINE i ncrease_ibuffer809 !WRITE( numicb,*) 'icb_increase_ibuffer',narea,' increased to',inew_size 810 ENDIF 811 ! 812 END SUBROUTINE icb_increase_ibuffer 850 813 851 814 #else … … 853 816 !! Default case: Dummy module share memory computing 854 817 !!---------------------------------------------------------------------- 855 SUBROUTINE mpp_send_bergs() 856 WRITE(numout,*) 'mpp_send_bergs: You should not have seen this message!!' 857 END SUBROUTINE mpp_send_bergs 858 859 SUBROUTINE dealloc_buffers() 860 WRITE(numout,*) 'dealloc_buffers: You should not have seen this message!!' 861 END SUBROUTINE dealloc_buffers 818 SUBROUTINE icb_lbc_mpp() 819 WRITE(numout,*) 'icb_lbc_mpp: You should not have seen this message!!' 820 END SUBROUTINE icb_lbc_mpp 862 821 863 822 #endif -
branches/2012/dev_r3337_NOCS10_ICB/NEMOGCM/NEMO/OPA_SRC/ICB/icbrst.F90
r3370 r3372 14 14 !!---------------------------------------------------------------------- 15 15 !!---------------------------------------------------------------------- 16 !! ic ebergs_read_restart: initialise !!gm suggested name : icebergs_rst_read or better icb_rst_read17 !! ic ebergs_write_restart: generate test icebergs !!gm icebergs_rst_write or better icb_rst_write16 !! icb_rst_read : initialise !!gm suggested name : icebergs_rst_read or better icb_rst_read 17 !! icb_rst_write : generate test icebergs !!gm icebergs_rst_write or better icb_rst_write 18 18 !!---------------------------------------------------------------------- 19 19 USE par_oce ! NEMO parameters … … 28 28 PRIVATE 29 29 30 PUBLIC ic ebergs_read_restart! routine called in icbini.F90 module31 PUBLIC ic ebergs_write_restart! routine called in icbrun.F90 module30 PUBLIC icb_rst_read ! routine called in icbini.F90 module 31 PUBLIC icb_rst_write ! routine called in icbrun.F90 module 32 32 33 33 INTEGER :: nlonid, nlatid, nxid, nyid, nuvelid, nvvelid … … 48 48 CONTAINS 49 49 50 SUBROUTINE ic ebergs_read_restart()51 !!---------------------------------------------------------------------- 52 !! *** SUBROUTINE ic ebergs_read_restart***50 SUBROUTINE icb_rst_read() 51 !!---------------------------------------------------------------------- 52 !! *** SUBROUTINE icb_rst_read *** 53 53 !! 54 54 !! ** Purpose : read a iceberg restart file … … 176 176 localpt%heat_density = zdata(1) 177 177 ! 178 CALL add_new_berg_to_list( localberg, localpt )178 CALL icb_utl_add( localberg, localpt ) 179 179 END DO 180 180 ! … … 216 216 217 217 ! Sanity check 218 jn = count_bergs()218 jn = icb_utl_count() 219 219 IF (nn_verbose_level >= 0) & 220 220 WRITE(numout,'(2(a,i5))') 'icebergs, read_restart_bergs: # bergs =',jn,' on PE',narea-1 … … 228 228 IF( lwp .and. nn_verbose_level >= 0) WRITE(numout,'(a)') 'icebergs, read_restart_bergs: completed' 229 229 ! 230 END SUBROUTINE ic ebergs_read_restart231 232 233 SUBROUTINE ic ebergs_write_restart( kt )234 !!---------------------------------------------------------------------- 235 !! *** SUBROUTINE ic ebergs_write_restart***230 END SUBROUTINE icb_rst_read 231 232 233 SUBROUTINE icb_rst_write( kt ) 234 !!---------------------------------------------------------------------- 235 !! *** SUBROUTINE icb_rst_write *** 236 236 !! 237 237 !!---------------------------------------------------------------------- … … 420 420 IF (nret /= NF90_NOERR) CALL ctl_stop('icebergs, write_restart: nf_close failed') 421 421 ! 422 END SUBROUTINE ic ebergs_write_restart422 END SUBROUTINE icb_rst_write 423 423 ! 424 424 END MODULE icbrst -
branches/2012/dev_r3337_NOCS10_ICB/NEMOGCM/NEMO/OPA_SRC/ICB/icbrun.F90
r3370 r3372 77 77 78 78 ! anything that needs to be reset to zero each timestep for budgets is dealt with here 79 CALL icb_ budget_step()79 CALL icb_dia_step() 80 80 81 81 ! Manage time … … 89 89 isec = nsec_day - ihr*3600 - imin*60 90 90 current_year = iyr 91 current_yearday = yearday(imon, iday, ihr, imin, isec)91 current_yearday = icb_utl_yearday(imon, iday, ihr, imin, isec) 92 92 93 93 ll_verbose = .FALSE. … … 100 100 ! copy nemo forcing arrays into iceberg versions with extra halo 101 101 ! only necessary for variables not on T points 102 CALL copy_flds()102 CALL icb_utl_copy() 103 103 104 104 !!---------------------------------------------------------------------- 105 105 !! process icebergs 106 106 107 CALL accumulate_calving( kt ) ! Accumulate ice from calving108 109 CALL calve_icebergs() ! Calve excess stored ice into icebergs110 111 112 113 ! 114 IF( ASSOCIATED(first_berg) ) CALL evolve_icebergs()! ice berg dynamics115 116 IF( lk_mpp ) THEN ; CALL mpp_send_bergs ()! Send bergs to other PEs117 ELSE ; CALL lbc_send_bergs() ! Deal with any cyclic boundaries in non-mpp case107 CALL icb_clv_flx( kt ) ! Accumulate ice from calving 108 109 CALL icb_clv() ! Calve excess stored ice into icebergs 110 111 112 ! !== For each berg, evolve ==! 113 ! 114 IF( ASSOCIATED(first_berg) ) CALL icb_dyn() ! ice berg dynamics 115 116 IF( lk_mpp ) THEN ; CALL icb_lbc_mpp() ! Send bergs to other PEs 117 ELSE ; CALL icb_lbc() ! Deal with any cyclic boundaries in non-mpp case 118 118 ENDIF 119 119 120 IF( ASSOCIATED(first_berg) ) CALL thermodynamics ( kt )! Ice berg thermodynamics (melting) + rolling120 IF( ASSOCIATED(first_berg) ) CALL icb_thm( kt ) ! Ice berg thermodynamics (melting) + rolling 121 121 122 122 !!---------------------------------------------------------------------- … … 126 126 IF( nn_sample_rate > 0 .AND. MOD(kt-1,nn_sample_rate) == 0 ) ll_sample_traj = .TRUE. 127 127 IF( ll_sample_traj .AND. & 128 ASSOCIATED(first_berg) ) CALL traj_write( kt ) ! For each berg, record trajectory128 ASSOCIATED(first_berg) ) CALL icb_trj_write( kt ) ! For each berg, record trajectory 129 129 130 130 ! Gridded diagnostics … … 136 136 CALL iom_put( "berg_stored_ice" , berg_grid%stored_ice (:,:,:) ) ! 'Accumulated ice mass by class', 'kg' 137 137 138 ! write outmean budgets139 CALL icb_ budget_put()138 ! store mean budgets 139 CALL icb_dia_put() 140 140 141 141 ! Dump icebergs to screen 142 if ( nn_verbose_level >= 2 ) CALL print_bergs( 'icb_stp, status', kt )142 if ( nn_verbose_level >= 2 ) CALL icb_utl_print( 'icb_stp, status', kt ) 143 143 144 144 ! Diagnose budgets 145 145 ll_budget = .FALSE. 146 146 IF( nn_verbose_write > 0 .AND. MOD(kt-1,nn_verbose_write) == 0 ) ll_budget = ln_bergdia 147 CALL icb_ budget( ll_budget )147 CALL icb_dia( ll_budget ) 148 148 149 149 IF( MOD(kt,nn_stock) == 0 ) THEN 150 CALL ic ebergs_write_restart( kt )151 IF( nn_sample_rate > 0 ) CALL traj_sync()150 CALL icb_rst_write( kt ) 151 IF( nn_sample_rate > 0 ) CALL icb_trj_sync() 152 152 ENDIF 153 153 … … 160 160 !! *** ROUTINE icb_end *** 161 161 !! 162 !! ** Purpose : deallocate icebergs arrays and162 !! ** Purpose : close iceberg files 163 163 !! 164 164 !!---------------------------------------------------------------------- … … 184 184 DEALLOCATE( nicbfldproc ) 185 185 186 IF( lk_mpp ) CALL dealloc_buffers()187 188 186 IF (.NOT.ASSOCIATED(berg_grid)) RETURN 189 187 190 188 ! only write a restart if not done in icb_stp 191 IF( MOD(kt,nn_stock) .NE. 0 ) CALL ic ebergs_write_restart( kt )189 IF( MOD(kt,nn_stock) .NE. 0 ) CALL icb_rst_write( kt ) 192 190 193 191 ! finish with trajectories if they were written 194 IF( nn_sample_rate .GT. 0 ) CALL traj_end()192 IF( nn_sample_rate .GT. 0 ) CALL icb_trj_end() 195 193 196 194 ! Delete bergs and structures … … 198 196 DO WHILE (ASSOCIATED(this)) 199 197 next=>this%next 200 CALL destroy_iceberg(this)198 CALL icb_utl_destroy(this) 201 199 this=>next 202 200 END DO 203 201 204 CALL icb_ budget_end()202 CALL icb_dia_end() 205 203 206 204 DEALLOCATE(berg_grid%calving) -
branches/2012/dev_r3337_NOCS10_ICB/NEMOGCM/NEMO/OPA_SRC/ICB/icbthm.F90
r3370 r3372 12 12 !!---------------------------------------------------------------------- 13 13 !!---------------------------------------------------------------------- 14 !! thermodynamics: initialise15 !! 14 !! icb_thm : initialise 15 !! reference for equations - M = Martin + Adcroft, OM 34, 2010 16 16 !!---------------------------------------------------------------------- 17 17 USE par_oce ! NEMO parameters … … 29 29 PRIVATE 30 30 31 PUBLIC thermodynamics! routine called in icbrun.F90 module31 PUBLIC icb_thm ! routine called in icbrun.F90 module 32 32 33 33 CONTAINS 34 34 35 SUBROUTINE thermodynamics( kt )35 SUBROUTINE icb_thm( kt ) 36 36 !!---------------------------------------------------------------------- 37 !! *** ROUTINE thermodynamics***37 !! *** ROUTINE icb_thm *** 38 38 !! 39 39 !! ** Purpose : compute the iceberg thermodynamics. … … 41 41 !! ** Method : - blah blah 42 42 !!---------------------------------------------------------------------- 43 INTEGER, INTENT(in) :: kt ! timestep number, just passed to print_berg43 INTEGER, INTENT(in) :: kt ! timestep number, just passed to icb_utl_print_berg 44 44 ! 45 45 INTEGER :: ii, ij … … 68 68 pt => this%current_point 69 69 nknberg = this%number(1) 70 CALL i nterp_flds( pt%xi, pt%e1, pt%uo, pt%ui, pt%ua, pt%ssh_x, &71 & pt%yj, pt%e2, pt%vo, pt%vi, pt%va, pt%ssh_y, &70 CALL icb_utl_interp( pt%xi, pt%e1, pt%uo, pt%ui, pt%ua, pt%ssh_x, & 71 & pt%yj, pt%e2, pt%vo, pt%vi, pt%va, pt%ssh_y, & 72 72 & pt%sst, pt%cn, pt%hi, zff ) 73 73 ! … … 159 159 zheat = zmelt * pt%heat_density ! kg/s x J/kg = J/s 160 160 berg_grid%calving_hflx (ii,ij) = berg_grid%calving_hflx (ii,ij) + zheat * z1_e1e2 ! W/m2 161 CALL melt_budget( ii, ij, zMnew, zheat, this%mass_scaling, &162 & zdM, zdMbitsE, zdMbitsM, zdMb, zdMe, &163 & zdMv, z1_dt_e1e2 )161 CALL icb_dia_melt( ii, ij, zMnew, zheat, this%mass_scaling, & 162 & zdM, zdMbitsE, zdMbitsM, zdMb, zdMe, & 163 & zdMv, z1_dt_e1e2 ) 164 164 ELSE 165 WRITE(numout,*) ' thermodynamics: berg ',this%number(:),' appears to have grounded at ',narea,ii,ij166 CALL print_berg( this, kt )165 WRITE(numout,*) 'icb_thm: berg ',this%number(:),' appears to have grounded at ',narea,ii,ij 166 CALL icb_utl_print_berg( this, kt ) 167 167 WRITE(numout,*) 'msk=',tmask(ii,ij,1), e1e2t(ii,ij) 168 CALL ctl_stop(' thermodynamics', 'berg appears to have grounded!')168 CALL ctl_stop('icb_thm', 'berg appears to have grounded!') 169 169 ENDIF 170 170 … … 189 189 190 190 IF( zMnew <= 0._wp ) THEN ! Delete the berg if completely melted 191 CALL delete_iceberg_from_list( first_berg, this )191 CALL icb_utl_delete( first_berg, this ) 192 192 ! 193 193 ELSE ! Diagnose mass distribution on grid 194 194 z1_e1e2 = 1._wp / e1e2t(ii,ij) * this%mass_scaling 195 CALL size_budget( ii, ij, zWn, zLn, zAbits, &196 & this%mass_scaling, zMnew, znMbits, z1_e1e2)195 CALL icb_dia_size( ii, ij, zWn, zLn, zAbits, & 196 & this%mass_scaling, zMnew, znMbits, z1_e1e2) 197 197 ENDIF 198 198 ! … … 209 209 ENDIF 210 210 ! 211 END SUBROUTINE thermodynamics211 END SUBROUTINE icb_thm 212 212 213 213 !!====================================================================== -
branches/2012/dev_r3337_NOCS10_ICB/NEMOGCM/NEMO/OPA_SRC/ICB/icbtrj.F90
r3370 r3372 26 26 PRIVATE 27 27 28 PUBLIC traj_init ! routine called in icbini.F90 module29 PUBLIC traj_write ! routine called in icbrun.F90 module30 PUBLIC traj_sync ! routine called in icbrun.F90 module31 PUBLIC traj_end ! routine called in icbrun.F90 module28 PUBLIC icb_trj_init ! routine called in icbini.F90 module 29 PUBLIC icb_trj_write ! routine called in icbrun.F90 module 30 PUBLIC icb_trj_sync ! routine called in icbrun.F90 module 31 PUBLIC icb_trj_end ! routine called in icbrun.F90 module 32 32 33 33 INTEGER :: num_traj … … 51 51 !!------------------------------------------------------------------------- 52 52 53 SUBROUTINE traj_init( ktend )53 SUBROUTINE icb_trj_init( ktend ) 54 54 55 55 ! local variables … … 64 64 ELSE ; WRITE(cl_filename,'("trajectory_icebergs_",I6.6 ,".nc")') ktend 65 65 ENDIF 66 IF ( lwp .AND. nn_verbose_level >= 0) WRITE(numout,'(2a)') 'icebergs, traj_init: creating ',TRIM(cl_filename)66 IF ( lwp .AND. nn_verbose_level >= 0) WRITE(numout,'(2a)') 'icebergs, icb_trj_init: creating ',TRIM(cl_filename) 67 67 68 68 iret = NF90_CREATE(TRIM(cl_filename), NF90_CLOBBER, ntrajid) 69 IF (iret .NE. NF90_NOERR) CALL ctl_stop('icebergs, traj_init: nf_create failed')69 IF (iret .NE. NF90_NOERR) CALL ctl_stop('icebergs, icb_trj_init: nf_create failed') 70 70 71 71 ! Dimensions 72 72 iret = NF90_DEF_DIM(ntrajid, 'n', NF90_UNLIMITED, n_dim) 73 IF (iret .NE. NF90_NOERR) CALL ctl_stop('icebergs, traj_init: nf_def_dim n failed')73 IF (iret .NE. NF90_NOERR) CALL ctl_stop('icebergs, icb_trj_init: nf_def_dim n failed') 74 74 iret = NF90_DEF_DIM(ntrajid, 'k', nkounts, m_dim) 75 IF (iret .NE. NF90_NOERR) CALL ctl_stop('icebergs, traj_init: nf_def_dim k failed')75 IF (iret .NE. NF90_NOERR) CALL ctl_stop('icebergs, icb_trj_init: nf_def_dim k failed') 76 76 77 77 ! Variables … … 166 166 iret = NF90_ENDDEF(ntrajid) 167 167 ! 168 END SUBROUTINE traj_init169 170 171 SUBROUTINE traj_write( kt )172 !!---------------------------------------------------------------------- 173 !! *** ROUTINE traj_write ***168 END SUBROUTINE icb_trj_init 169 170 171 SUBROUTINE icb_trj_write( kt ) 172 !!---------------------------------------------------------------------- 173 !! *** ROUTINE icb_trj_write *** 174 174 !! 175 !! ** Purpose : compute the iceberg thermodynamics.175 !! ** Purpose : write out iceberg trajectories 176 176 !! 177 177 !! ** Method : - for the moment write out each snapshot of positions later 178 !! can rewrite so that it is buffered and written out more efficiently178 !! can rewrite so that it is buffered and written out more efficiently 179 179 !!---------------------------------------------------------------------- 180 180 INTEGER, INTENT( in ) :: kt … … 230 230 num_traj = jn 231 231 ! 232 END SUBROUTINE traj_write232 END SUBROUTINE icb_trj_write 233 233 234 234 !!------------------------------------------------------------------------- 235 235 236 SUBROUTINE traj_sync()237 !!---------------------------------------------------------------------- 238 !! *** ROUTINE traj_sync ***236 SUBROUTINE icb_trj_sync() 237 !!---------------------------------------------------------------------- 238 !! *** ROUTINE icb_trj_sync *** 239 239 !! 240 240 !! ** Purpose : … … 244 244 ! flush to file 245 245 iret = NF90_SYNC(ntrajid) 246 IF(iret /= NF90_NOERR) CALL ctl_stop( 'icebergs, traj_sync: nf_sync failed' )247 ! 248 END SUBROUTINE traj_sync249 250 251 SUBROUTINE traj_end()246 IF(iret /= NF90_NOERR) CALL ctl_stop( 'icebergs, icb_trj_sync: nf_sync failed' ) 247 ! 248 END SUBROUTINE icb_trj_sync 249 250 251 SUBROUTINE icb_trj_end() 252 252 ! Local variables 253 253 INTEGER :: iret … … 255 255 ! Finish up 256 256 iret = NF90_CLOSE(ntrajid) 257 IF (iret /= NF90_NOERR) CALL ctl_stop( 'icebergs, traj_end: nf_close failed' )258 ! 259 END SUBROUTINE traj_end257 IF (iret /= NF90_NOERR) CALL ctl_stop( 'icebergs, icb_trj_end: nf_close failed' ) 258 ! 259 END SUBROUTINE icb_trj_end 260 260 261 261 !!------------------------------------------------------------------------- -
branches/2012/dev_r3337_NOCS10_ICB/NEMOGCM/NEMO/OPA_SRC/ICB/icbutl.F90
r3370 r3372 11 11 !!---------------------------------------------------------------------- 12 12 !!---------------------------------------------------------------------- 13 !! i nterp_flds:14 !! bilin:15 !! bilin_e:13 !! icb_utl_interp : 14 !! icb_utl_bilin : 15 !! icb_utl_bilin_e : 16 16 !!---------------------------------------------------------------------- 17 17 USE par_oce ! ocean parameters … … 34 34 PRIVATE 35 35 36 PUBLIC copy_flds ! routine called in icbrun module 37 PUBLIC interp_flds ! routine called in icbdyn, icbthm modules 38 PUBLIC bilin ! routine called in icbini, icbdyn modules 39 PUBLIC bilin_x ! routine called in icbdyn module 40 PRIVATE bilin_e 41 PUBLIC add_new_berg_to_list ! routine called in icbini.F90, icbclv, icblbc and icbrst modules 42 PRIVATE insert_berg_into_list 43 PUBLIC delete_iceberg_from_list ! routine called in icblbc, icbthm modules 44 PUBLIC destroy_iceberg ! routine called in icbrun module 45 PUBLIC track_berg ! routine not currently used, retain just in case 46 PUBLIC print_berg ! routine called in icbthm module 47 PUBLIC print_bergs ! routine called in icbini, icbrun module 48 PUBLIC count_bergs ! routine called in icbdia, icbini, icblbc, icbrst modules 49 PUBLIC increment_kounter ! routine called in icbini, icbclv modules 50 PUBLIC yearday ! routine called in icbclv, icbrun module 51 PUBLIC sum_mass ! routine called in icbdia module 52 PUBLIC sum_heat ! routine called in icbdia module 53 54 PRIVATE create_iceberg 36 PUBLIC icb_utl_copy ! routine called in icbrun module 37 PUBLIC icb_utl_interp ! routine called in icbdyn, icbthm modules 38 PUBLIC icb_utl_bilin ! routine called in icbini, icbdyn modules 39 PUBLIC icb_utl_bilin_x ! routine called in icbdyn module 40 PUBLIC icb_utl_add ! routine called in icbini.F90, icbclv, icblbc and icbrst modules 41 PUBLIC icb_utl_delete ! routine called in icblbc, icbthm modules 42 PUBLIC icb_utl_destroy ! routine called in icbrun module 43 PUBLIC icb_utl_track ! routine not currently used, retain just in case 44 PUBLIC icb_utl_print_berg ! routine called in icbthm module 45 PUBLIC icb_utl_print ! routine called in icbini, icbrun module 46 PUBLIC icb_utl_count ! routine called in icbdia, icbini, icblbc, icbrst modules 47 PUBLIC icb_utl_incr ! routine called in icbini, icbclv modules 48 PUBLIC icb_utl_yearday ! routine called in icbclv, icbrun module 49 PUBLIC icb_utl_mass ! routine called in icbdia module 50 PUBLIC icb_utl_heat ! routine called in icbdia module 55 51 56 52 !!---------------------------------------------------------------------- … … 62 58 CONTAINS 63 59 64 SUBROUTINE copy_flds()65 !!---------------------------------------------------------------------- 66 !! *** ROUTINE copy_flds***60 SUBROUTINE icb_utl_copy() 61 !!---------------------------------------------------------------------- 62 !! *** ROUTINE icb_utl_copy *** 67 63 !! 68 64 !! ** Purpose : iceberg initialization. … … 109 105 CALL lbc_lnk_e( ssh_e, 'T', +1._wp, 1, 1 ) 110 106 ! 111 END SUBROUTINE copy_flds112 113 114 SUBROUTINE i nterp_flds( pi, pe1, puo, pui, pua, pssh_i, &115 & pj, pe2, pvo, pvi, pva, pssh_j, &107 END SUBROUTINE icb_utl_copy 108 109 110 SUBROUTINE icb_utl_interp( pi, pe1, puo, pui, pua, pssh_i, & 111 & pj, pe2, pvo, pvi, pva, pssh_j, & 116 112 & psst, pcn, phi, pff ) 117 113 !!---------------------------------------------------------------------- 118 !! *** ROUTINE i nterp_flds***114 !! *** ROUTINE icb_utl_interp *** 119 115 !! 120 116 !! ** Purpose : iceberg initialization. … … 138 134 !!---------------------------------------------------------------------- 139 135 140 pe1 = bilin_e( e1t, e1u, e1v, e1f, pi, pj )! scale factors141 pe2 = bilin_e( e2t, e2u, e2v, e2f, pi, pj )142 ! 143 puo = bilin( uo_e, pi, pj, 'U', 1, 1 )! ocean velocities144 pvo = bilin( vo_e, pi, pj, 'V', 1, 1 )145 psst = bilin( sst_m, pi, pj, 'T', 0, 0 )! SST146 pcn = bilin( fr_i , pi, pj, 'T', 0, 0 )! ice concentration147 pff = bilin( ff_e , pi, pj, 'F', 1, 1 )! Coriolis parameter148 ! 149 pua = bilin( ua_e , pi, pj, 'U', 1, 1 )! 10m wind150 pva = bilin( va_e , pi, pj, 'V', 1, 1 )! here (ua,va) are stress => rough conversion from stress to speed136 pe1 = icb_utl_bilin_e( e1t, e1u, e1v, e1f, pi, pj ) ! scale factors 137 pe2 = icb_utl_bilin_e( e2t, e2u, e2v, e2f, pi, pj ) 138 ! 139 puo = icb_utl_bilin( uo_e, pi, pj, 'U', 1, 1 ) ! ocean velocities 140 pvo = icb_utl_bilin( vo_e, pi, pj, 'V', 1, 1 ) 141 psst = icb_utl_bilin( sst_m, pi, pj, 'T', 0, 0 ) ! SST 142 pcn = icb_utl_bilin( fr_i , pi, pj, 'T', 0, 0 ) ! ice concentration 143 pff = icb_utl_bilin( ff_e , pi, pj, 'F', 1, 1 ) ! Coriolis parameter 144 ! 145 pua = icb_utl_bilin( ua_e , pi, pj, 'U', 1, 1 ) ! 10m wind 146 pva = icb_utl_bilin( va_e , pi, pj, 'V', 1, 1 ) ! here (ua,va) are stress => rough conversion from stress to speed 151 147 zcd = 1.22_wp * 1.5e-3_wp ! air density * drag coefficient 152 148 zmod = 1._wp / MAX( 1.e-20, SQRT( zcd * SQRT( pua*pua + pva*pva) ) ) … … 155 151 156 152 #if defined key_lim2 || defined key_lim3 157 pui = bilin( ui_e, pi, pj, 'U', 1, 1 )! sea-ice velocities158 pvi = bilin( vi_e, pi, pj, 'V', 1, 1 )159 phi = bilin( hi , pi, pj, 'T', 0, 0 )! ice thickness153 pui = icb_utl_bilin( ui_e, pi, pj, 'U', 1, 1 ) ! sea-ice velocities 154 pvi = icb_utl_bilin( vi_e, pi, pj, 'V', 1, 1 ) 155 phi = icb_utl_bilin( hi , pi, pj, 'T', 0, 0 ) ! ice thickness 160 156 #else 161 157 pui = 0._wp … … 165 161 166 162 ! Estimate SSH gradient in i- and j-direction (centred evaluation) 167 pssh_i = ( bilin( ssh_e, pi+0.1_wp, pj, 'T', 1, 1 ) - bilin( ssh_e, pi-0.1_wp, pj, 'T', 1, 1 ) ) / ( 0.2_wp * pe1 ) 168 pssh_j = ( bilin( ssh_e, pi, pj+0.1_wp, 'T', 1, 1 ) - bilin( ssh_e, pi, pj-0.1_wp, 'T', 1, 1 ) ) / ( 0.2_wp * pe2 ) 169 ! 170 END SUBROUTINE interp_flds 171 172 173 REAL(wp) FUNCTION bilin( pfld, pi, pj, cd_type, kdi, kdj ) 174 !!---------------------------------------------------------------------- 175 !! *** FUNCTION bilin *** 163 pssh_i = ( icb_utl_bilin( ssh_e, pi+0.1_wp, pj, 'T', 1, 1 ) - & 164 & icb_utl_bilin( ssh_e, pi-0.1_wp, pj, 'T', 1, 1 ) ) / ( 0.2_wp * pe1 ) 165 pssh_j = ( icb_utl_bilin( ssh_e, pi, pj+0.1_wp, 'T', 1, 1 ) - & 166 & icb_utl_bilin( ssh_e, pi, pj-0.1_wp, 'T', 1, 1 ) ) / ( 0.2_wp * pe2 ) 167 ! 168 END SUBROUTINE icb_utl_interp 169 170 171 REAL(wp) FUNCTION icb_utl_bilin( pfld, pi, pj, cd_type, kdi, kdj ) 172 !!---------------------------------------------------------------------- 173 !! *** FUNCTION icb_utl_bilin *** 176 174 !! 177 175 !! ** Purpose : bilinear interpolation at berg location depending on the grid-point type … … 220 218 ij = ij - njmpp + 1 221 219 ! 222 bilin = ( pfld(ii,ij ) * (1.-zi) + pfld(ii+1,ij ) * zi ) * (1.-zj) &223 & + ( pfld(ii,ij+1) * (1.-zi) + pfld(ii+1,ij+1) * zi ) * zj224 ! 225 END FUNCTION bilin226 227 228 REAL(wp) FUNCTION bilin_x( pfld, pi, pj )229 !!---------------------------------------------------------------------- 230 !! *** FUNCTION bilin_x ***220 icb_utl_bilin = ( pfld(ii,ij ) * (1.-zi) + pfld(ii+1,ij ) * zi ) * (1.-zj) & 221 & + ( pfld(ii,ij+1) * (1.-zi) + pfld(ii+1,ij+1) * zi ) * zj 222 ! 223 END FUNCTION icb_utl_bilin 224 225 226 REAL(wp) FUNCTION icb_utl_bilin_x( pfld, pi, pj ) 227 !!---------------------------------------------------------------------- 228 !! *** FUNCTION icb_utl_bilin_x *** 231 229 !! 232 230 !! ** Purpose : bilinear interpolation at berg location depending on the grid-point type … … 242 240 INTEGER :: ii, ij ! local integer 243 241 REAL(wp) :: zi, zj ! local real 242 REAL(wp) :: zret ! local real 244 243 REAL(wp), DIMENSION(4) :: z4 245 244 !!---------------------------------------------------------------------- … … 264 263 ENDIF 265 264 ! 266 bilin_x = (z4(1) * (1.-zi) + z4(2) * zi) * (1.-zj) + (z4(3) * (1.-zi) + z4(4) * zi) * zj 267 IF( bilin_x > 180._wp ) bilin_x = bilin_x - 360._wp 268 ! 269 END FUNCTION bilin_x 270 271 272 REAL(wp) FUNCTION bilin_e( pet, peu, pev, pef, pi, pj ) 265 zret = (z4(1) * (1.-zi) + z4(2) * zi) * (1.-zj) + (z4(3) * (1.-zi) + z4(4) * zi) * zj 266 IF( zret > 180._wp ) zret = zret - 360._wp 267 icb_utl_bilin_x = zret 268 ! 269 END FUNCTION icb_utl_bilin_x 270 271 272 REAL(wp) FUNCTION icb_utl_bilin_e( pet, peu, pev, pef, pi, pj ) 273 273 !!---------------------------------------------------------------------- 274 274 !! *** FUNCTION dom_init *** … … 336 336 ENDIF 337 337 ! 338 bilin_e = ( ze01 * (1.-zi) + ze11 * zi ) * zj &339 & + ( ze00 * (1.-zi) + ze10 * zi ) * (1.-zj)340 ! 341 END FUNCTION bilin_e342 343 344 SUBROUTINE add_new_berg_to_list( bergvals, ptvals )345 !!---------------------------------------------------------------------- 346 !! *** ROUTINE add_new_berg_to_list***338 icb_utl_bilin_e = ( ze01 * (1.-zi) + ze11 * zi ) * zj & 339 & + ( ze00 * (1.-zi) + ze10 * zi ) * (1.-zj) 340 ! 341 END FUNCTION icb_utl_bilin_e 342 343 344 SUBROUTINE icb_utl_add( bergvals, ptvals ) 345 !!---------------------------------------------------------------------- 346 !! *** ROUTINE icb_utl_add *** 347 347 !! 348 348 !! ** Purpose : add a new berg to the iceberg list … … 357 357 ! 358 358 new => NULL() 359 CALL create_iceberg( new, bergvals, ptvals )360 CALL i nsert_berg_into_list( new )359 CALL icb_utl_create( new, bergvals, ptvals ) 360 CALL icb_utl_insert( new ) 361 361 new => NULL() ! Clear new 362 362 ! 363 END SUBROUTINE add_new_berg_to_list364 365 366 SUBROUTINE create_iceberg( berg, bergvals, ptvals )367 !!---------------------------------------------------------------------- 368 !! *** ROUTINE add_new_berg_to_list***363 END SUBROUTINE icb_utl_add 364 365 366 SUBROUTINE icb_utl_create( berg, bergvals, ptvals ) 367 !!---------------------------------------------------------------------- 368 !! *** ROUTINE icb_utl_create *** 369 369 !! 370 370 !! ** Purpose : add a new berg to the iceberg list … … 380 380 !!---------------------------------------------------------------------- 381 381 ! 382 IF( ASSOCIATED(berg) ) CALL ctl_stop( 'icebergs, create_iceberg: berg already associated' )382 IF( ASSOCIATED(berg) ) CALL ctl_stop( 'icebergs, icb_utl_create: berg already associated' ) 383 383 ALLOCATE(berg, STAT=istat) 384 384 IF( istat /= 0 ) CALL ctl_stop( 'failed to allocate iceberg' ) … … 393 393 berg%current_point => pt 394 394 ! 395 END SUBROUTINE create_iceberg396 397 398 SUBROUTINE i nsert_berg_into_list( newberg )399 !!---------------------------------------------------------------------- 400 !! *** ROUTINE i nsert_berg_into_list ***395 END SUBROUTINE icb_utl_create 396 397 398 SUBROUTINE icb_utl_insert( newberg ) 399 !!---------------------------------------------------------------------- 400 !! *** ROUTINE icb_utl_insert *** 401 401 !! 402 402 !! ** Purpose : add a new berg to the iceberg list … … 422 422 ENDIF 423 423 ! 424 END SUBROUTINE i nsert_berg_into_list425 426 427 REAL(wp) FUNCTION yearday(kmon, kday, khr, kmin, ksec)428 !!---------------------------------------------------------------------- 429 !! *** FUNCTION yearday ***424 END SUBROUTINE icb_utl_insert 425 426 427 REAL(wp) FUNCTION icb_utl_yearday(kmon, kday, khr, kmin, ksec) 428 !!---------------------------------------------------------------------- 429 !! *** FUNCTION icb_utl_yearday *** 430 430 !! 431 431 !! ** Purpose : … … 442 442 !!---------------------------------------------------------------------- 443 443 ! 444 yearday = FLOAT( SUM( imonths(1:kmon) ) )445 yearday =yearday + FLOAT(kday-1) + (FLOAT(khr) + (FLOAT(kmin) + FLOAT(ksec)/60.)/60.)/24.446 ! 447 END FUNCTION yearday444 icb_utl_yearday = FLOAT( SUM( imonths(1:kmon) ) ) 445 icb_utl_yearday = icb_utl_yearday + FLOAT(kday-1) + (FLOAT(khr) + (FLOAT(kmin) + FLOAT(ksec)/60.)/60.)/24. 446 ! 447 END FUNCTION icb_utl_yearday 448 448 449 449 !!------------------------------------------------------------------------- 450 450 451 SUBROUTINE delete_iceberg_from_list( first, berg )452 !!---------------------------------------------------------------------- 453 !! *** ROUTINE delete_iceberg_from_list***451 SUBROUTINE icb_utl_delete( first, berg ) 452 !!---------------------------------------------------------------------- 453 !! *** ROUTINE icb_utl_delete *** 454 454 !! 455 455 !! ** Purpose : … … 467 467 ! 468 468 ! Bye-bye berg 469 CALL destroy_iceberg(berg)470 ! 471 END SUBROUTINE delete_iceberg_from_list472 473 474 SUBROUTINE destroy_iceberg( berg )475 !!---------------------------------------------------------------------- 476 !! *** ROUTINE destroy_iceberg***469 CALL icb_utl_destroy(berg) 470 ! 471 END SUBROUTINE icb_utl_delete 472 473 474 SUBROUTINE icb_utl_destroy( berg ) 475 !!---------------------------------------------------------------------- 476 !! *** ROUTINE icb_utl_destroy *** 477 477 !! 478 478 !! ** Purpose : … … 488 488 DEALLOCATE(berg) 489 489 ! 490 END SUBROUTINE destroy_iceberg491 492 493 SUBROUTINE track_berg( knum, cd_label, kt )494 !!---------------------------------------------------------------------- 495 !! *** ROUTINE track_berg***490 END SUBROUTINE icb_utl_destroy 491 492 493 SUBROUTINE icb_utl_track( knum, cd_label, kt ) 494 !!---------------------------------------------------------------------- 495 !! *** ROUTINE icb_utl_track *** 496 496 !! 497 497 !! ** Purpose : … … 513 513 IF( this%number(k) /= knum(k) ) match = .FALSE. 514 514 END DO 515 IF( match ) CALL print_berg(this, kt)515 IF( match ) CALL icb_utl_print_berg(this, kt) 516 516 this => this%next 517 517 END DO 518 518 ! 519 END SUBROUTINE track_berg520 521 522 SUBROUTINE print_berg( berg, kt )523 !!---------------------------------------------------------------------- 524 !! *** ROUTINE print_berg ***519 END SUBROUTINE icb_utl_track 520 521 522 SUBROUTINE icb_utl_print_berg( berg, kt ) 523 !!---------------------------------------------------------------------- 524 !! *** ROUTINE icb_utl_print_berg *** 525 525 !! 526 526 !! ** Purpose : … … 539 539 9200 FORMAT(5x,i5,2x,i10,6(2x,2f10.4)) 540 540 ! 541 END SUBROUTINE print_berg542 543 544 SUBROUTINE print_bergs( cd_label, kt )545 !!---------------------------------------------------------------------- 546 !! *** ROUTINE print_bergs***541 END SUBROUTINE icb_utl_print_berg 542 543 544 SUBROUTINE icb_utl_print( cd_label, kt ) 545 !!---------------------------------------------------------------------- 546 !! *** ROUTINE icb_utl_print *** 547 547 !! 548 548 !! ** Purpose : … … 563 563 ENDIF 564 564 DO WHILE( ASSOCIATED(this) ) 565 CALL print_berg(this, kt)565 CALL icb_utl_print_berg(this, kt) 566 566 this => this%next 567 567 END DO 568 ibergs = count_bergs()568 ibergs = icb_utl_count() 569 569 inbergs = ibergs 570 570 IF( lk_mpp ) CALL mpp_sum(inbergs) … … 572 572 & cd_label, ibergs, inbergs, narea 573 573 ! 574 END SUBROUTINE print_bergs575 576 577 SUBROUTINE i ncrement_kounter()578 !!---------------------------------------------------------------------- 579 !! *** ROUTINE i ncrement_kounter ***574 END SUBROUTINE icb_utl_print 575 576 577 SUBROUTINE icb_utl_incr() 578 !!---------------------------------------------------------------------- 579 !! *** ROUTINE icb_utl_incr *** 580 580 !! 581 581 !! ** Purpose : … … 607 607 ENDIF 608 608 ! 609 END SUBROUTINE i ncrement_kounter610 611 612 INTEGER FUNCTION count_bergs()613 !!---------------------------------------------------------------------- 614 !! *** FUNCTION count_bergs***609 END SUBROUTINE icb_utl_incr 610 611 612 INTEGER FUNCTION icb_utl_count() 613 !!---------------------------------------------------------------------- 614 !! *** FUNCTION icb_utl_count *** 615 615 !! 616 616 !! ** Purpose : … … 619 619 !!---------------------------------------------------------------------- 620 620 ! 621 count_bergs= 0621 icb_utl_count = 0 622 622 this => first_berg 623 623 DO WHILE( ASSOCIATED(this) ) 624 count_bergs = count_bergs+1624 icb_utl_count = icb_utl_count+1 625 625 this => this%next 626 626 END DO 627 627 ! 628 END FUNCTION count_bergs629 630 631 REAL(wp) FUNCTION sum_mass( first, justbits, justbergs )632 !!---------------------------------------------------------------------- 633 !! *** FUNCTION sum_mass ***628 END FUNCTION icb_utl_count 629 630 631 REAL(wp) FUNCTION icb_utl_mass( first, justbits, justbergs ) 632 !!---------------------------------------------------------------------- 633 !! *** FUNCTION icb_utl_mass *** 634 634 !! 635 635 !! ** Purpose : compute the mass all iceberg, all bergies or all bergs. … … 641 641 TYPE(iceberg), POINTER :: this 642 642 !!---------------------------------------------------------------------- 643 sum_mass = 0._wp643 icb_utl_mass = 0._wp 644 644 this => first 645 645 ! … … 647 647 DO WHILE( ASSOCIATED( this ) ) 648 648 pt => this%current_point 649 sum_mass = sum_mass + pt%mass * this%mass_scaling649 icb_utl_mass = icb_utl_mass + pt%mass * this%mass_scaling 650 650 this => this%next 651 651 END DO … … 653 653 DO WHILE( ASSOCIATED( this ) ) 654 654 pt => this%current_point 655 sum_mass = sum_mass + pt%mass_of_bits * this%mass_scaling655 icb_utl_mass = icb_utl_mass + pt%mass_of_bits * this%mass_scaling 656 656 this => this%next 657 657 END DO … … 659 659 DO WHILE( ASSOCIATED( this ) ) 660 660 pt => this%current_point 661 sum_mass = sum_mass + ( pt%mass + pt%mass_of_bits ) * this%mass_scaling661 icb_utl_mass = icb_utl_mass + ( pt%mass + pt%mass_of_bits ) * this%mass_scaling 662 662 this => this%next 663 663 END DO 664 664 ENDIF 665 665 ! 666 END FUNCTION sum_mass667 668 669 REAL(wp) FUNCTION sum_heat( first, justbits, justbergs )670 !!---------------------------------------------------------------------- 671 !! *** FUNCTION sum_heat ***666 END FUNCTION icb_utl_mass 667 668 669 REAL(wp) FUNCTION icb_utl_heat( first, justbits, justbergs ) 670 !!---------------------------------------------------------------------- 671 !! *** FUNCTION icb_utl_heat *** 672 672 !! 673 673 !! ** Purpose : compute the heat in all iceberg, all bergies or all bergs. … … 679 679 TYPE(point) , POINTER :: pt 680 680 !!---------------------------------------------------------------------- 681 sum_heat = 0._wp681 icb_utl_heat = 0._wp 682 682 this => first 683 683 ! … … 685 685 DO WHILE( ASSOCIATED( this ) ) 686 686 pt => this%current_point 687 sum_heat = sum_heat + pt%mass * this%mass_scaling * pt%heat_density687 icb_utl_heat = icb_utl_heat + pt%mass * this%mass_scaling * pt%heat_density 688 688 this => this%next 689 689 END DO … … 691 691 DO WHILE( ASSOCIATED( this ) ) 692 692 pt => this%current_point 693 sum_heat = sum_heat + pt%mass_of_bits * this%mass_scaling * pt%heat_density693 icb_utl_heat = icb_utl_heat + pt%mass_of_bits * this%mass_scaling * pt%heat_density 694 694 this => this%next 695 695 END DO … … 697 697 DO WHILE( ASSOCIATED( this ) ) 698 698 pt => this%current_point 699 sum_heat = sum_heat + ( pt%mass + pt%mass_of_bits ) * this%mass_scaling * pt%heat_density699 icb_utl_heat = icb_utl_heat + ( pt%mass + pt%mass_of_bits ) * this%mass_scaling * pt%heat_density 700 700 this => this%next 701 701 END DO 702 702 ENDIF 703 703 ! 704 END FUNCTION sum_heat704 END FUNCTION icb_utl_heat 705 705 706 706 !!======================================================================
Note: See TracChangeset
for help on using the changeset viewer.