MODULE icbdia !!====================================================================== !! *** MODULE icbdia *** !! Icebergs: initialise variables for iceberg budgets and diagnostics !!====================================================================== !! History : 3.3 ! 2010-01 (Martin, Adcroft) Original code !! - ! 2011-03 (Madec) Part conversion to NEMO form !! - ! Removal of mapping from another grid !! - ! 2011-04 (Alderson) Split into separate modules !! - ! 2011-05 (Alderson) Budgets are now all here with lots !! - ! of silly routines to call to get values in !! - ! from the right points in the code !!---------------------------------------------------------------------- !!---------------------------------------------------------------------- !! icb_budget_end : end iceberg budgeting !! icb_budget_init : initialise iceberg budgeting !!---------------------------------------------------------------------- USE par_oce ! ocean parameters USE dom_oce ! ocean domain USE in_out_manager ! nemo IO USE lib_mpp ! MPP library USE iom ! I/O library USE icb_oce ! iceberg variables USE icbutl ! iceberg utility routines IMPLICIT NONE PRIVATE PUBLIC icb_budget_end ! routine called in icbrun.F90 module PUBLIC icb_budget_init ! routine called in icbini.F90 module PUBLIC icb_budget ! routine called in icbrun.F90 module PUBLIC icb_budget_step ! routine called in icbrun.F90 module PUBLIC icb_budget_put ! routine called in icbrun.F90 module PUBLIC melt_budget ! routine called in icbthm.F90 module PUBLIC size_budget ! routine called in icbthm.F90 module PUBLIC speed_budget ! routine called in icbdyn.F90 module PUBLIC calving_budget ! routine called in icbclv.F90 module PUBLIC incoming_budget ! routine called in icbclv.F90 module REAL(wp), DIMENSION(:,:) , POINTER, PUBLIC :: berg_melt => NULL() ! Melting+erosion rate of icebergs [kg/s/m2] REAL(wp), DIMENSION(:,:) , POINTER, PUBLIC :: buoy_melt => NULL() ! Buoyancy component of melting rate [kg/s/m2] REAL(wp), DIMENSION(:,:) , POINTER, PUBLIC :: eros_melt => NULL() ! Erosion component of melting rate [kg/s/m2] REAL(wp), DIMENSION(:,:) , POINTER, PUBLIC :: conv_melt => NULL() ! Convective component of melting rate [kg/s/m2] REAL(wp), DIMENSION(:,:) , POINTER, PUBLIC :: bits_src => NULL() ! Mass flux from berg erosion into bergy bits [kg/s/m2] REAL(wp), DIMENSION(:,:) , POINTER, PUBLIC :: bits_melt => NULL() ! Melting rate of bergy bits [kg/s/m2] REAL(wp), DIMENSION(:,:) , POINTER, PUBLIC :: bits_mass => NULL() ! Mass distribution of bergy bits [kg/s/m2] REAL(wp), DIMENSION(:,:) , POINTER, PUBLIC :: virtual_area => NULL() ! Virtual surface coverage by icebergs [m2] REAL(wp), DIMENSION(:,:) , POINTER, PUBLIC :: berg_mass => NULL() ! Mass distribution [kg/m2] REAL(wp), DIMENSION(:,:,:), POINTER, PUBLIC :: real_calving => NULL() ! Calving rate into iceberg class at ! ! calving locations [kg/s] REAL(wp), DIMENSION(:,:) , POINTER :: tmpc => NULL() ! Temporary work space REAL(wp), DIMENSION(:) , POINTER :: rsumbuf => NULL() ! Temporary work space to reduce mpp exchanges INTEGER , DIMENSION(:) , POINTER :: nsumbuf => NULL() ! Temporary work space to reduce mpp exchanges REAL(wp) :: berg_melt_net REAL(wp) :: bits_src_net REAL(wp) :: bits_melt_net REAL(wp) :: bits_mass_start , bits_mass_end REAL(wp) :: floating_heat_start , floating_heat_end REAL(wp) :: floating_mass_start , floating_mass_end REAL(wp) :: bergs_mass_start , bergs_mass_end REAL(wp) :: stored_start , stored_heat_start REAL(wp) :: stored_end , stored_heat_end REAL(wp) :: calving_src_net , calving_out_net REAL(wp) :: calving_src_heat_net, calving_out_heat_net REAL(wp) :: calving_src_heat_used_net REAL(wp) :: calving_rcv_net , calving_ret_net , calving_used_net REAL(wp) :: heat_to_bergs_net, heat_to_ocean_net, melt_net REAL(wp) :: calving_to_bergs_net INTEGER :: nbergs_start, nbergs_end, nbergs_calved INTEGER :: nbergs_melted INTEGER :: nspeeding_tickets INTEGER , DIMENSION(nclasses) :: nbergs_calved_by_class !!---------------------------------------------------------------------- !! NEMO/OPA 3.3 , NEMO Consortium (2011) !! $Id:$ !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) !!---------------------------------------------------------------------- CONTAINS SUBROUTINE icb_budget_end !!---------------------------------------------------------------------- ! IF( .NOT. ln_bergdia ) RETURN DEALLOCATE( berg_melt ) DEALLOCATE( buoy_melt ) DEALLOCATE( eros_melt ) DEALLOCATE( conv_melt ) DEALLOCATE( bits_src ) DEALLOCATE( bits_melt ) DEALLOCATE( bits_mass ) DEALLOCATE( virtual_area ) DEALLOCATE( berg_mass ) DEALLOCATE( real_calving ) DEALLOCATE( tmpc ) IF( lk_mpp ) THEN DEALLOCATE( rsumbuf ) DEALLOCATE( nsumbuf ) ENDIF ! END SUBROUTINE icb_budget_end !!------------------------------------------------------------------------- SUBROUTINE icb_budget_init( ) !!---------------------------------------------------------------------- !!---------------------------------------------------------------------- ! IF( .NOT. ln_bergdia ) RETURN ALLOCATE( berg_melt (jpi,jpj) ) ; berg_melt (:,:) = 0._wp ALLOCATE( buoy_melt (jpi,jpj) ) ; buoy_melt (:,:) = 0._wp ALLOCATE( eros_melt (jpi,jpj) ) ; eros_melt (:,:) = 0._wp ALLOCATE( conv_melt (jpi,jpj) ) ; conv_melt (:,:) = 0._wp ALLOCATE( bits_src (jpi,jpj) ) ; bits_src (:,:) = 0._wp ALLOCATE( bits_melt (jpi,jpj) ) ; bits_melt (:,:) = 0._wp ALLOCATE( bits_mass (jpi,jpj) ) ; bits_mass (:,:) = 0._wp ALLOCATE( virtual_area (jpi,jpj) ) ; virtual_area(:,:) = 0._wp ALLOCATE( berg_mass (jpi,jpj) ) ; berg_mass (:,:) = 0._wp ALLOCATE( real_calving (jpi,jpj,nclasses) ) ; real_calving(:,:,:) = 0._wp ALLOCATE( tmpc(jpi,jpj) ) ; tmpc (:,:) = 0._wp nbergs_start = 0 nbergs_end = 0 stored_end = 0._wp nbergs_start = 0._wp stored_start = 0._wp nbergs_melted = 0 nbergs_calved = 0 nbergs_calved_by_class(:) = 0 nspeeding_tickets = 0 stored_heat_end = 0._wp floating_heat_end = 0._wp floating_mass_end = 0._wp bergs_mass_end = 0._wp bits_mass_end = 0._wp stored_heat_start = 0._wp floating_heat_start = 0._wp floating_mass_start = 0._wp bergs_mass_start = 0._wp bits_mass_start = 0._wp bits_mass_end = 0._wp calving_used_net = 0._wp calving_to_bergs_net = 0._wp heat_to_bergs_net = 0._wp heat_to_ocean_net = 0._wp calving_rcv_net = 0._wp calving_ret_net = 0._wp calving_src_net = 0._wp calving_out_net = 0._wp calving_src_heat_net = 0._wp calving_src_heat_used_net = 0._wp calving_out_heat_net = 0._wp melt_net = 0._wp berg_melt_net = 0._wp bits_melt_net = 0._wp bits_src_net = 0._wp floating_mass_start = sum_mass( first_berg ) bergs_mass_start = sum_mass( first_berg, justbergs=.true. ) bits_mass_start = sum_mass( first_berg, justbits=.true. ) IF( lk_mpp ) THEN ALLOCATE( rsumbuf(23) ) ; rsumbuf(:) = 0._wp ALLOCATE( nsumbuf(4+nclasses) ) ; nsumbuf(:) = 0 rsumbuf(1) = floating_mass_start rsumbuf(2) = bergs_mass_start rsumbuf(3) = bits_mass_start CALL mpp_sum( rsumbuf(1:3), 3 ) floating_mass_start = rsumbuf(1) bergs_mass_start = rsumbuf(2) bits_mass_start = rsumbuf(3) ENDIF ! END SUBROUTINE icb_budget_init SUBROUTINE icb_budget( ld_budge ) !!---------------------------------------------------------------------- !!---------------------------------------------------------------------- LOGICAL, INTENT(in) :: ld_budge ! INTEGER :: ik REAL(wp) :: zunused_calving, ztmpsum, zgrdd_berg_mass, zgrdd_bits_mass !!---------------------------------------------------------------------- ! IF( .NOT. ln_bergdia ) RETURN zunused_calving = SUM( berg_grid%calving(:,:) ) ztmpsum = SUM( berg_grid%floating_melt(:,:) * e1e2t(:,:) * tmask_i(:,:) ) melt_net = melt_net + ztmpsum * berg_dt calving_out_net = calving_out_net + ( zunused_calving + ztmpsum ) * berg_dt ztmpsum = SUM( berg_melt(:,:) * e1e2t(:,:) * tmask_i(:,:) ) berg_melt_net = berg_melt_net + ztmpsum * berg_dt ztmpsum = SUM( bits_src(:,:) * e1e2t(:,:) * tmask_i(:,:) ) bits_src_net = bits_src_net + ztmpsum * berg_dt ztmpsum = SUM( bits_melt(:,:) * e1e2t(:,:) * tmask_i(:,:) ) bits_melt_net = bits_melt_net + ztmpsum * berg_dt ztmpsum = SUM( src_calving(:,:) * tmask_i(:,:) ) calving_ret_net = calving_ret_net + ztmpsum * berg_dt ztmpsum = SUM( berg_grid%calving_hflx(:,:) * e1e2t(:,:) * tmask_i(:,:) ) calving_out_heat_net = calving_out_heat_net + ztmpsum * berg_dt ! Units of J IF( ld_budge ) THEN stored_end = SUM( berg_grid%stored_ice(:,:,:) ) stored_heat_end = SUM( berg_grid%stored_heat(:,:) ) floating_mass_end = sum_mass( first_berg ) bergs_mass_end = sum_mass( first_berg,justbergs=.true. ) bits_mass_end = sum_mass( first_berg,justbits=.true. ) floating_heat_end = sum_heat( first_berg ) nbergs_end = count_bergs() zgrdd_berg_mass = SUM( berg_mass (:,:)*e1e2t(:,:)*tmask_i(:,:) ) zgrdd_bits_mass = SUM( bits_mass(:,:)*e1e2t(:,:)*tmask_i(:,:) ) IF( lk_mpp ) THEN rsumbuf( 1) = stored_end rsumbuf( 2) = stored_heat_end rsumbuf( 3) = floating_mass_end rsumbuf( 4) = bergs_mass_end rsumbuf( 5) = bits_mass_end rsumbuf( 6) = floating_heat_end rsumbuf( 7) = calving_ret_net rsumbuf( 8) = calving_out_net rsumbuf( 9) = calving_rcv_net rsumbuf(10) = calving_src_net rsumbuf(11) = calving_src_heat_net rsumbuf(12) = calving_src_heat_used_net rsumbuf(13) = calving_out_heat_net rsumbuf(14) = calving_used_net rsumbuf(15) = calving_to_bergs_net rsumbuf(16) = heat_to_bergs_net rsumbuf(17) = heat_to_ocean_net rsumbuf(18) = melt_net rsumbuf(19) = berg_melt_net rsumbuf(20) = bits_src_net rsumbuf(21) = bits_melt_net rsumbuf(22) = zgrdd_berg_mass rsumbuf(23) = zgrdd_bits_mass CALL mpp_sum( rsumbuf(1:23), 23) stored_end = rsumbuf( 1) stored_heat_end = rsumbuf( 2) floating_mass_end = rsumbuf( 3) bergs_mass_end = rsumbuf( 4) bits_mass_end = rsumbuf( 5) floating_heat_end = rsumbuf( 6) calving_ret_net = rsumbuf( 7) calving_out_net = rsumbuf( 8) calving_rcv_net = rsumbuf( 9) calving_src_net = rsumbuf(10) calving_src_heat_net = rsumbuf(11) calving_src_heat_used_net = rsumbuf(12) calving_out_heat_net = rsumbuf(13) calving_used_net = rsumbuf(14) calving_to_bergs_net = rsumbuf(15) heat_to_bergs_net = rsumbuf(16) heat_to_ocean_net = rsumbuf(17) melt_net = rsumbuf(18) berg_melt_net = rsumbuf(19) bits_src_net = rsumbuf(20) bits_melt_net = rsumbuf(21) zgrdd_berg_mass = rsumbuf(22) zgrdd_bits_mass = rsumbuf(23) nsumbuf(1) = nbergs_end nsumbuf(2) = nbergs_calved nsumbuf(3) = nbergs_melted nsumbuf(4) = nspeeding_tickets DO ik = 1, nclasses nsumbuf(4+ik) = nbergs_calved_by_class(ik) END DO CALL mpp_sum( nsumbuf(1:nclasses+4), nclasses+4 ) nbergs_end = nsumbuf(1) nbergs_calved = nsumbuf(2) nbergs_melted = nsumbuf(3) nspeeding_tickets = nsumbuf(4) DO ik = 1,nclasses nbergs_calved_by_class(ik)= nsumbuf(4+ik) ENDDO ENDIF CALL report_state( 'stored ice','kg','',stored_start,'',stored_end,'') CALL report_state( 'floating','kg','',floating_mass_start,'',floating_mass_end,'',nbergs_end) CALL report_state( 'icebergs','kg','',bergs_mass_start,'',bergs_mass_end,'') CALL report_state( 'bits','kg','',bits_mass_start,'',bits_mass_end,'') CALL report_istate( 'berg #','',nbergs_start,'',nbergs_end,'') CALL report_ibudget( 'berg #','calved',nbergs_calved, & 'melted',nbergs_melted, & '#',nbergs_start,nbergs_end) CALL report_budget( 'stored mass','kg','calving used',calving_used_net, & 'bergs',calving_to_bergs_net, & 'stored mass',stored_start,stored_end) CALL report_budget( 'floating mass','kg','calving used',calving_to_bergs_net, & 'bergs',melt_net, & 'stored mass',floating_mass_start,floating_mass_end) CALL report_budget( 'berg mass','kg','calving',calving_to_bergs_net, & 'melt+eros',berg_melt_net, & 'berg mass',bergs_mass_start,bergs_mass_end) CALL report_budget( 'bits mass','kg','eros used',bits_src_net, & 'bergs',bits_melt_net, & 'stored mass',bits_mass_start,bits_mass_end) CALL report_budget( 'net mass','kg','recvd',calving_rcv_net, & 'rtrnd',calving_ret_net, & 'net mass',stored_start+floating_mass_start, & stored_end+floating_mass_end) CALL report_consistant( 'iceberg mass','kg','gridded',zgrdd_berg_mass,'bergs',bergs_mass_end) CALL report_consistant( 'bits mass','kg','gridded',zgrdd_bits_mass,'bits',bits_mass_end) CALL report_state( 'net heat','J','',stored_heat_start+floating_heat_start,'', & stored_heat_end+floating_heat_end,'') CALL report_state( 'stored heat','J','',stored_heat_start,'',stored_heat_end,'') CALL report_state( 'floating heat','J','',floating_heat_start,'',floating_heat_end,'') CALL report_budget( 'net heat','J','net heat',calving_src_heat_net, & 'net heat',calving_out_heat_net, & 'net heat',stored_heat_start+floating_heat_start, & stored_heat_end+floating_heat_end) CALL report_budget( 'stored heat','J','calving used',calving_src_heat_used_net, & 'bergs',heat_to_bergs_net, & 'net heat',stored_heat_start,stored_heat_end) CALL report_budget( 'flting heat','J','calved',heat_to_bergs_net, & 'melt',heat_to_ocean_net, & 'net heat',floating_heat_start,floating_heat_end) IF (nn_verbose_level >= 1) THEN CALL report_consistant( 'top interface','kg','from SIS',calving_src_net, & 'received',calving_rcv_net) CALL report_consistant( 'bot interface','kg','sent',calving_out_net, & 'returned',calving_ret_net) ENDIF WRITE( numicb, '("calved by class = ",i6,20(",",i6))') (nbergs_calved_by_class(ik),ik=1,nclasses) IF ( nspeeding_tickets > 0 ) WRITE( numicb, '("speeding tickets issued = ",i6)') nspeeding_tickets nbergs_start = nbergs_end stored_start = stored_end nbergs_melted = 0 nbergs_calved = 0 nbergs_calved_by_class(:) = 0 nspeeding_tickets = 0 stored_heat_start = stored_heat_end floating_heat_start = floating_heat_end floating_mass_start = floating_mass_end bergs_mass_start = bergs_mass_end bits_mass_start = bits_mass_end calving_used_net = 0._wp calving_to_bergs_net = 0._wp heat_to_bergs_net = 0._wp heat_to_ocean_net = 0._wp calving_rcv_net = 0._wp calving_ret_net = 0._wp calving_src_net = 0._wp calving_out_net = 0._wp calving_src_heat_net = 0._wp calving_src_heat_used_net = 0._wp calving_out_heat_net = 0._wp melt_net = 0._wp berg_melt_net = 0._wp bits_melt_net = 0._wp bits_src_net = 0._wp ENDIF ! END SUBROUTINE icb_budget SUBROUTINE icb_budget_step !!---------------------------------------------------------------------- !! things to reset at the beginning of each timestep !! this probably screws up fields going to diawri, so needs to be looked at - sga !!---------------------------------------------------------------------- ! IF( .NOT. ln_bergdia ) RETURN berg_melt (:,:) = 0._wp buoy_melt (:,:) = 0._wp eros_melt (:,:) = 0._wp conv_melt (:,:) = 0._wp bits_src (:,:) = 0._wp bits_melt (:,:) = 0._wp bits_mass (:,:) = 0._wp berg_mass (:,:) = 0._wp virtual_area (:,:) = 0._wp real_calving (:,:,:) = 0._wp ! END SUBROUTINE icb_budget_step SUBROUTINE icb_budget_put !!---------------------------------------------------------------------- !!---------------------------------------------------------------------- ! IF( .NOT. ln_bergdia ) RETURN !!gm useless iom will control whether it is output or not ! CALL iom_put( "berg_melt" , berg_melt (:,:) ) ! Melt rate of icebergs [kg/m2/s] CALL iom_put( "berg_buoy_melt" , buoy_melt (:,:) ) ! Buoyancy component of iceberg melt rate [kg/m2/s] CALL iom_put( "berg_eros_melt" , eros_melt (:,:) ) ! Erosion component of iceberg melt rate [kg/m2/s] CALL iom_put( "berg_conv_melt" , conv_melt (:,:) ) ! Convective component of iceberg melt rate [kg/m2/s] CALL iom_put( "berg_virtual_area", virtual_area(:,:) ) ! Virtual coverage by icebergs [m2] CALL iom_put( "bits_src" , bits_src (:,:) ) ! Mass source of bergy bits [kg/m2/s] CALL iom_put( "bits_melt" , bits_melt (:,:) ) ! Melt rate of bergy bits [kg/m2/s] CALL iom_put( "bits_mass" , bits_mass (:,:) ) ! Bergy bit density field [kg/m2] CALL iom_put( "berg_mass" , berg_mass (:,:) ) ! Iceberg density field [kg/m2] CALL iom_put( "berg_real_calving", real_calving(:,:,:) ) ! Calving into iceberg class [kg/s] ! END SUBROUTINE icb_budget_put SUBROUTINE calving_budget( ki, kj, kn, pcalved, pheated ) !!---------------------------------------------------------------------- !!---------------------------------------------------------------------- INTEGER, INTENT(in) :: ki, kj, kn REAL(wp), INTENT(in) :: pcalved REAL(wp), INTENT(in) :: pheated !!---------------------------------------------------------------------- ! IF( .NOT. ln_bergdia ) RETURN real_calving(ki,kj,kn) = real_calving(ki,kj,kn) + pcalved / berg_dt nbergs_calved = nbergs_calved + 1 nbergs_calved_by_class(kn) = nbergs_calved_by_class(kn) + 1 calving_to_bergs_net = calving_to_bergs_net + pcalved heat_to_bergs_net = heat_to_bergs_net + pheated ! END SUBROUTINE calving_budget SUBROUTINE incoming_budget( kt, pcalving_used, pheat_used ) !!---------------------------------------------------------------------- !!---------------------------------------------------------------------- INTEGER , INTENT(in) :: kt REAL(wp), INTENT(in) :: pcalving_used REAL(wp), DIMENSION(:,:), INTENT(in) :: pheat_used !!---------------------------------------------------------------------- ! IF( .NOT. ln_bergdia ) RETURN ! IF( kt == nit000 ) THEN stored_start = SUM( berg_grid%stored_ice(:,:,:) ) IF( lk_mpp ) CALL mpp_sum( stored_start ) WRITE(numicb,'(a,es13.6,a)') 'accumulate_calving: initial stored mass=',stored_start,' kg' ! stored_heat_start = SUM( berg_grid%stored_heat(:,:) ) IF( lk_mpp ) CALL mpp_sum( stored_heat_start ) WRITE(numicb,'(a,es13.6,a)') 'accumulate_calving: initial stored heat=',stored_heat_start,' J' ENDIF ! calving_rcv_net = calving_rcv_net + SUM( berg_grid%calving(:,:) ) * berg_dt calving_src_net = calving_rcv_net calving_src_heat_net = calving_src_heat_net + & & SUM( berg_grid%calving_hflx(:,:) * e1e2t(:,:) ) * berg_dt ! Units of J calving_used_net = calving_used_net + pcalving_used * berg_dt calving_src_heat_used_net = calving_src_heat_used_net + SUM( pheat_used(:,:) ) ! END SUBROUTINE incoming_budget SUBROUTINE size_budget(ki, kj, pWn, pLn, pAbits, & & pmass_scale, pMnew, pnMbits, pz1_e1e2) !!---------------------------------------------------------------------- !!---------------------------------------------------------------------- INTEGER, INTENT(in) :: ki, kj REAL(wp), INTENT(in) :: pWn, pLn, pAbits, pmass_scale, pMnew, pnMbits, pz1_e1e2 !!---------------------------------------------------------------------- ! IF( .NOT. ln_bergdia ) RETURN virtual_area(ki,kj) = virtual_area(ki,kj) + ( pWn * pLn + pAbits ) * pmass_scale ! m^2 berg_mass(ki,kj) = berg_mass(ki,kj) + pMnew * pz1_e1e2 ! kg/m2 bits_mass(ki,kj) = bits_mass(ki,kj) + pnMbits * pz1_e1e2 ! kg/m2 ! END SUBROUTINE size_budget SUBROUTINE speed_budget() !!---------------------------------------------------------------------- !!---------------------------------------------------------------------- ! IF( .NOT. ln_bergdia ) RETURN nspeeding_tickets = nspeeding_tickets + 1 ! END SUBROUTINE speed_budget SUBROUTINE melt_budget(ki, kj, pmnew, pheat, pmass_scale, & & pdM, pdMbitsE, pdMbitsM, pdMb, pdMe, & & pdMv, pz1_dt_e1e2 ) !!---------------------------------------------------------------------- !!---------------------------------------------------------------------- INTEGER , INTENT(in) :: ki, kj REAL(wp), INTENT(in) :: pmnew, pheat, pmass_scale REAL(wp), INTENT(in) :: pdM, pdMbitsE, pdMbitsM, pdMb, pdMe, pdMv, pz1_dt_e1e2 !!---------------------------------------------------------------------- ! IF( .NOT. ln_bergdia ) RETURN berg_melt (ki,kj) = berg_melt (ki,kj) + pdM * pz1_dt_e1e2 ! kg/m2/s bits_src (ki,kj) = bits_src (ki,kj) + pdMbitsE * pz1_dt_e1e2 ! mass flux into bergy bitskg/m2/s bits_melt (ki,kj) = bits_melt (ki,kj) + pdMbitsM * pz1_dt_e1e2 ! melt rate of bergy bits kg/m2/s buoy_melt (ki,kj) = buoy_melt (ki,kj) + pdMb * pz1_dt_e1e2 ! kg/m2/s eros_melt (ki,kj) = eros_melt (ki,kj) + pdMe * pz1_dt_e1e2 ! erosion rate kg/m2/s conv_melt (ki,kj) = conv_melt (ki,kj) + pdMv * pz1_dt_e1e2 ! kg/m2/s heat_to_ocean_net = heat_to_ocean_net + pheat * pmass_scale * berg_dt ! J IF( pmnew <= 0._wp ) nbergs_melted = nbergs_melted + 1 ! Delete the berg if completely melted ! END SUBROUTINE melt_budget SUBROUTINE report_state( cd_budgetstr, cd_budgetunits, cd_startstr, pstartval, cd_endstr, & & pendval, cd_delstr, kbergs ) !!---------------------------------------------------------------------- !!---------------------------------------------------------------------- CHARACTER*(*), INTENT(in) :: cd_budgetstr, cd_budgetunits, cd_startstr, cd_endstr, cd_delstr REAL(wp), INTENT(in) :: pstartval, pendval INTEGER, INTENT(in), OPTIONAL :: kbergs !!---------------------------------------------------------------------- ! IF ( PRESENT(kbergs) ) THEN WRITE(numicb,100) cd_budgetstr // ' state:', & cd_startstr // ' start', pstartval, cd_budgetunits, & cd_endstr // ' end', pendval, cd_budgetunits, & 'Delta ' // cd_delstr, pendval-pstartval, cd_budgetunits, & '# of bergs', kbergs ELSE WRITE(numicb,100) cd_budgetstr // ' state:', & cd_startstr // ' start', pstartval, cd_budgetunits, & cd_endstr // ' end', pendval, cd_budgetunits, & cd_delstr // 'Delta', pendval-pstartval, cd_budgetunits ENDIF 100 FORMAT(a19,3(a18,"=",es14.7,x,a2,:,","),a12,i8) END SUBROUTINE report_state SUBROUTINE report_consistant( cd_budgetstr, cd_budgetunits, cd_startstr, pstartval, cd_endstr, pendval) !!---------------------------------------------------------------------- !!---------------------------------------------------------------------- CHARACTER*(*), INTENT(in) :: cd_budgetstr, cd_budgetunits, cd_startstr, cd_endstr REAL(wp), INTENT(in) :: pstartval, pendval !!---------------------------------------------------------------------- ! WRITE(numicb,200) cd_budgetstr // ' check:', & cd_startstr, pstartval, cd_budgetunits, & cd_endstr, pendval, cd_budgetunits, & 'error', (pendval-pstartval)/((pendval+pstartval)+1e-30), 'nd' 200 FORMAT(a19,10(a18,"=",es14.7,x,a2,:,",")) END SUBROUTINE report_consistant SUBROUTINE report_budget( cd_budgetstr, cd_budgetunits, cd_instr, pinval, cd_outstr, & & poutval, cd_delstr, pstartval, pendval) !!---------------------------------------------------------------------- !!---------------------------------------------------------------------- CHARACTER*(*), INTENT(in) :: cd_budgetstr, cd_budgetunits, cd_instr, cd_outstr, cd_delstr REAL(wp), INTENT(in) :: pinval, poutval, pstartval, pendval ! REAL(wp) :: zval !!---------------------------------------------------------------------- ! zval = ( ( pendval - pstartval ) - ( pinval - poutval ) ) / & & MAX( 1.e-30, MAX( abs( pendval - pstartval ) , ABS( pinval - poutval ) ) ) WRITE(numicb,200) cd_budgetstr // ' budget:', & & cd_instr // ' in', pinval, cd_budgetunits, & & cd_outstr // ' out', poutval, cd_budgetunits, & & 'Delta ' // cd_delstr, pinval-poutval, cd_budgetunits, & & 'error', zval, 'nd' 200 FORMAT(a19,3(a18,"=",es14.7,x,a2,:,","),a8,"=",es10.3,x,a2) ! END SUBROUTINE report_budget SUBROUTINE report_istate( cd_budgetstr, cd_startstr, pstartval, cd_endstr, pendval, cd_delstr) !!---------------------------------------------------------------------- !!---------------------------------------------------------------------- CHARACTER*(*), INTENT(in) :: cd_budgetstr, cd_startstr, cd_endstr, cd_delstr INTEGER, INTENT(in) :: pstartval, pendval ! WRITE(numicb,100) cd_budgetstr // ' state:', & & cd_startstr // ' start', pstartval, & & cd_endstr // ' end', pendval, & & cd_delstr // 'Delta', pendval-pstartval 100 FORMAT(a19,3(a18,"=",i14,x,:,",")) ! END SUBROUTINE report_istate SUBROUTINE report_ibudget( cd_budgetstr, cd_instr, pinval, cd_outstr, poutval, & & cd_delstr, pstartval, pendval) !!---------------------------------------------------------------------- !!---------------------------------------------------------------------- CHARACTER*(*), INTENT(in) :: cd_budgetstr, cd_instr, cd_outstr, cd_delstr INTEGER, INTENT(in) :: pinval, poutval, pstartval, pendval !!---------------------------------------------------------------------- ! WRITE(numicb,200) cd_budgetstr // ' budget:', & cd_instr // ' in', pinval, & cd_outstr // ' out', poutval, & 'Delta ' // cd_delstr, pinval-poutval, & 'error', ( ( pendval - pstartval ) - ( pinval - poutval ) ) 200 FORMAT(a19,10(a18,"=",i14,x,:,",")) END SUBROUTINE report_ibudget !!====================================================================== END MODULE icbdia