source: branches/UKMO/r6232_tracer_advection/NEMOGCM/NEMO/OPA_SRC/ICB/icbdia.F90 @ 9295

Last change on this file since 9295 was 9295, checked in by jcastill, 3 years ago

Remove svn keywords

File size: 30.8 KB
Line 
1MODULE icbdia
2
3   !!======================================================================
4   !!                       ***  MODULE  icbdia  ***
5   !! Icebergs:  initialise variables for iceberg budgets and diagnostics
6   !!======================================================================
7   !! History : 3.3 !  2010-01  (Martin, Adcroft) Original code
8   !!            -  !  2011-03  (Madec)          Part conversion to NEMO form
9   !!            -  !                            Removal of mapping from another grid
10   !!            -  !  2011-04  (Alderson)       Split into separate modules
11   !!            -  !  2011-05  (Alderson)       Budgets are now all here with lots
12   !!            -  !                            of silly routines to call to get values in
13   !!            -  !                            from the right points in the code
14   !!----------------------------------------------------------------------
15   !!----------------------------------------------------------------------
16   !! icb_dia_init : initialise iceberg budgeting
17   !!----------------------------------------------------------------------
18   USE par_oce        ! ocean parameters
19   USE dom_oce        ! ocean domain
20   USE in_out_manager ! nemo IO
21   USE lib_mpp        ! MPP library
22   USE iom            ! I/O library
23   USE icb_oce        ! iceberg variables
24   USE icbutl         ! iceberg utility routines
25
26   IMPLICIT NONE
27   PRIVATE
28
29   PUBLIC   icb_dia_init      ! routine called in icbini.F90 module
30   PUBLIC   icb_dia           ! routine called in icbstp.F90 module
31   PUBLIC   icb_dia_step      ! routine called in icbstp.F90 module
32   PUBLIC   icb_dia_put       ! routine called in icbstp.F90 module
33   PUBLIC   icb_dia_melt      ! routine called in icbthm.F90 module
34   PUBLIC   icb_dia_size      ! routine called in icbthm.F90 module
35   PUBLIC   icb_dia_speed     ! routine called in icbdyn.F90 module
36   PUBLIC   icb_dia_calve     ! routine called in icbclv.F90 module
37   PUBLIC   icb_dia_income    ! routine called in icbclv.F90 module
38
39   REAL(wp), DIMENSION(:,:)  , ALLOCATABLE, PUBLIC  ::   berg_melt       ! Melting+erosion rate of icebergs     [kg/s/m2]
40   REAL(wp), DIMENSION(:,:)  , ALLOCATABLE, PUBLIC  ::   buoy_melt       ! Buoyancy component of melting rate   [kg/s/m2]
41   REAL(wp), DIMENSION(:,:)  , ALLOCATABLE, PUBLIC  ::   eros_melt       ! Erosion component of melting rate    [kg/s/m2]
42   REAL(wp), DIMENSION(:,:)  , ALLOCATABLE, PUBLIC  ::   conv_melt       ! Convective component of melting rate [kg/s/m2]
43   REAL(wp), DIMENSION(:,:)  , ALLOCATABLE, PUBLIC  ::   bits_src        ! Mass flux from berg erosion into bergy bits [kg/s/m2]
44   REAL(wp), DIMENSION(:,:)  , ALLOCATABLE, PUBLIC  ::   bits_melt       ! Melting rate of bergy bits           [kg/s/m2]
45   REAL(wp), DIMENSION(:,:)  , ALLOCATABLE, PUBLIC  ::   bits_mass       ! Mass distribution of bergy bits      [kg/s/m2]
46   REAL(wp), DIMENSION(:,:)  , ALLOCATABLE, PUBLIC  ::   virtual_area    ! Virtual surface coverage by icebergs [m2]
47   REAL(wp), DIMENSION(:,:)  , ALLOCATABLE, PUBLIC  ::   berg_mass       ! Mass distribution                    [kg/m2]
48   REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, PUBLIC  ::   real_calving    ! Calving rate into iceberg class at
49   !                                                                          ! calving locations                    [kg/s]
50   
51   REAL(wp), DIMENSION(:,:)  , ALLOCATABLE ::   tmpc                     ! Temporary work space
52   REAL(wp), DIMENSION(:)    , ALLOCATABLE ::   rsumbuf                  ! Temporary work space to reduce mpp exchanges
53   INTEGER , DIMENSION(:)    , ALLOCATABLE ::   nsumbuf                  ! Temporary work space to reduce mpp exchanges
54
55   REAL(wp)                      ::  berg_melt_net
56   REAL(wp)                      ::  bits_src_net
57   REAL(wp)                      ::  bits_melt_net
58   REAL(wp)                      ::  bits_mass_start     , bits_mass_end
59   REAL(wp)                      ::  floating_heat_start , floating_heat_end
60   REAL(wp)                      ::  floating_mass_start , floating_mass_end
61   REAL(wp)                      ::  bergs_mass_start    , bergs_mass_end
62   REAL(wp)                      ::  stored_start        , stored_heat_start
63   REAL(wp)                      ::  stored_end          , stored_heat_end
64   REAL(wp)                      ::  calving_src_net     , calving_out_net
65   REAL(wp)                      ::  calving_src_heat_net, calving_out_heat_net
66   REAL(wp)                      ::  calving_src_heat_used_net
67   REAL(wp)                      ::  calving_rcv_net  , calving_ret_net  , calving_used_net
68   REAL(wp)                      ::  heat_to_bergs_net, heat_to_ocean_net, melt_net
69   REAL(wp)                      ::  calving_to_bergs_net
70
71   INTEGER                       ::  nbergs_start, nbergs_end, nbergs_calved
72   INTEGER                       ::  nbergs_melted
73   INTEGER                       ::  nspeeding_tickets
74   INTEGER , DIMENSION(nclasses) ::  nbergs_calved_by_class
75
76   !!----------------------------------------------------------------------
77   !! NEMO/OPA 3.3 , NEMO Consortium (2011)
78   !! $Id$
79   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
80   !!----------------------------------------------------------------------
81CONTAINS
82
83   SUBROUTINE icb_dia_init( )
84      !!----------------------------------------------------------------------
85      !!----------------------------------------------------------------------
86      !
87      IF( .NOT. ln_bergdia ) RETURN
88
89      ALLOCATE( berg_melt    (jpi,jpj)   )           ;   berg_melt   (:,:)   = 0._wp
90      ALLOCATE( buoy_melt    (jpi,jpj)   )           ;   buoy_melt   (:,:)   = 0._wp
91      ALLOCATE( eros_melt    (jpi,jpj)   )           ;   eros_melt   (:,:)   = 0._wp
92      ALLOCATE( conv_melt    (jpi,jpj)   )           ;   conv_melt   (:,:)   = 0._wp
93      ALLOCATE( bits_src     (jpi,jpj)   )           ;   bits_src    (:,:)   = 0._wp
94      ALLOCATE( bits_melt    (jpi,jpj)   )           ;   bits_melt   (:,:)   = 0._wp
95      ALLOCATE( bits_mass    (jpi,jpj)   )           ;   bits_mass   (:,:)   = 0._wp
96      ALLOCATE( virtual_area (jpi,jpj)   )           ;   virtual_area(:,:)   = 0._wp
97      ALLOCATE( berg_mass    (jpi,jpj)   )           ;   berg_mass   (:,:)   = 0._wp
98      ALLOCATE( real_calving (jpi,jpj,nclasses) )    ;   real_calving(:,:,:) = 0._wp
99      ALLOCATE( tmpc(jpi,jpj) )                      ;   tmpc        (:,:)   = 0._wp
100
101      nbergs_start              = 0
102      nbergs_end                = 0
103      stored_end                = 0._wp
104      nbergs_start              = 0._wp
105      stored_start              = 0._wp
106      nbergs_melted             = 0
107      nbergs_calved             = 0
108      nbergs_calved_by_class(:) = 0
109      nspeeding_tickets         = 0
110      stored_heat_end           = 0._wp
111      floating_heat_end         = 0._wp
112      floating_mass_end         = 0._wp
113      bergs_mass_end            = 0._wp
114      bits_mass_end             = 0._wp
115      stored_heat_start         = 0._wp
116      floating_heat_start       = 0._wp
117      floating_mass_start       = 0._wp
118      bergs_mass_start          = 0._wp
119      bits_mass_start           = 0._wp
120      bits_mass_end             = 0._wp
121      calving_used_net          = 0._wp
122      calving_to_bergs_net      = 0._wp
123      heat_to_bergs_net         = 0._wp
124      heat_to_ocean_net         = 0._wp
125      calving_rcv_net           = 0._wp
126      calving_ret_net           = 0._wp
127      calving_src_net           = 0._wp
128      calving_out_net           = 0._wp
129      calving_src_heat_net      = 0._wp
130      calving_src_heat_used_net = 0._wp
131      calving_out_heat_net      = 0._wp
132      melt_net                  = 0._wp
133      berg_melt_net             = 0._wp
134      bits_melt_net             = 0._wp
135      bits_src_net              = 0._wp
136
137      floating_mass_start       = icb_utl_mass( first_berg )
138      bergs_mass_start          = icb_utl_mass( first_berg, justbergs=.true. )
139      bits_mass_start           = icb_utl_mass( first_berg, justbits=.true. )
140      IF( lk_mpp ) THEN
141         ALLOCATE( rsumbuf(23) )          ; rsumbuf(:) = 0._wp
142         ALLOCATE( nsumbuf(4+nclasses) )  ; nsumbuf(:) = 0
143         rsumbuf(1) = floating_mass_start
144         rsumbuf(2) = bergs_mass_start
145         rsumbuf(3) = bits_mass_start
146         CALL mpp_sum( rsumbuf(1:3), 3 )
147         floating_mass_start = rsumbuf(1)
148         bergs_mass_start = rsumbuf(2)
149         bits_mass_start = rsumbuf(3)
150      ENDIF
151      !
152   END SUBROUTINE icb_dia_init
153
154
155   SUBROUTINE icb_dia( ld_budge )
156      !!----------------------------------------------------------------------
157      !! sum all the things we've accumulated so far in the current processor
158      !! in MPP case then add these sums across all processors
159      !! for this we pack variables into buffer so we only need one mpp_sum
160      !!----------------------------------------------------------------------
161      LOGICAL, INTENT(in) ::   ld_budge
162      !
163      INTEGER             ::   ik
164      REAL(wp)            ::   zunused_calving, ztmpsum, zgrdd_berg_mass, zgrdd_bits_mass
165      !!----------------------------------------------------------------------
166      !
167      IF( .NOT. ln_bergdia )   RETURN
168
169      zunused_calving      = SUM( berg_grid%calving(:,:) )
170      ztmpsum              = SUM( berg_grid%floating_melt(:,:) * e1e2t(:,:) * tmask_i(:,:) )
171      melt_net             = melt_net + ztmpsum * berg_dt
172      calving_out_net      = calving_out_net + ( zunused_calving + ztmpsum ) * berg_dt
173      ztmpsum              = SUM( berg_melt(:,:) * e1e2t(:,:) * tmask_i(:,:) )
174      berg_melt_net        = berg_melt_net + ztmpsum * berg_dt
175      ztmpsum              = SUM( bits_src(:,:) * e1e2t(:,:) * tmask_i(:,:) )
176      bits_src_net         = bits_src_net + ztmpsum * berg_dt
177      ztmpsum              = SUM( bits_melt(:,:) * e1e2t(:,:) * tmask_i(:,:) )
178      bits_melt_net        = bits_melt_net + ztmpsum * berg_dt
179      ztmpsum              = SUM( src_calving(:,:) * tmask_i(:,:) )
180      calving_ret_net      = calving_ret_net + ztmpsum * berg_dt
181      ztmpsum              = SUM( berg_grid%calving_hflx(:,:) * e1e2t(:,:) * tmask_i(:,:) )
182      calving_out_heat_net = calving_out_heat_net + ztmpsum * berg_dt   ! Units of J
183
184      IF( ld_budge ) THEN
185         stored_end        = SUM( berg_grid%stored_ice(:,:,:) )
186         stored_heat_end   = SUM( berg_grid%stored_heat(:,:) )
187         floating_mass_end = icb_utl_mass( first_berg )
188         bergs_mass_end    = icb_utl_mass( first_berg,justbergs=.true. )
189         bits_mass_end     = icb_utl_mass( first_berg,justbits=.true. )
190         floating_heat_end = icb_utl_heat( first_berg )
191
192         nbergs_end        = icb_utl_count()
193         zgrdd_berg_mass   = SUM( berg_mass (:,:)*e1e2t(:,:)*tmask_i(:,:) )
194         zgrdd_bits_mass   = SUM( bits_mass(:,:)*e1e2t(:,:)*tmask_i(:,:) )
195
196         IF( lk_mpp ) THEN
197            rsumbuf( 1) = stored_end
198            rsumbuf( 2) = stored_heat_end
199            rsumbuf( 3) = floating_mass_end
200            rsumbuf( 4) = bergs_mass_end
201            rsumbuf( 5) = bits_mass_end
202            rsumbuf( 6) = floating_heat_end
203            rsumbuf( 7) = calving_ret_net
204            rsumbuf( 8) = calving_out_net
205            rsumbuf( 9) = calving_rcv_net
206            rsumbuf(10) = calving_src_net
207            rsumbuf(11) = calving_src_heat_net
208            rsumbuf(12) = calving_src_heat_used_net
209            rsumbuf(13) = calving_out_heat_net
210            rsumbuf(14) = calving_used_net
211            rsumbuf(15) = calving_to_bergs_net
212            rsumbuf(16) = heat_to_bergs_net
213            rsumbuf(17) = heat_to_ocean_net
214            rsumbuf(18) = melt_net
215            rsumbuf(19) = berg_melt_net
216            rsumbuf(20) = bits_src_net
217            rsumbuf(21) = bits_melt_net
218            rsumbuf(22) = zgrdd_berg_mass
219            rsumbuf(23) = zgrdd_bits_mass
220
221            CALL mpp_sum( rsumbuf(1:23), 23)
222
223            stored_end                = rsumbuf( 1)
224            stored_heat_end           = rsumbuf( 2)
225            floating_mass_end         = rsumbuf( 3)
226            bergs_mass_end            = rsumbuf( 4)
227            bits_mass_end             = rsumbuf( 5)
228            floating_heat_end         = rsumbuf( 6)
229            calving_ret_net           = rsumbuf( 7)
230            calving_out_net           = rsumbuf( 8)
231            calving_rcv_net           = rsumbuf( 9)
232            calving_src_net           = rsumbuf(10)
233            calving_src_heat_net      = rsumbuf(11)
234            calving_src_heat_used_net = rsumbuf(12)
235            calving_out_heat_net      = rsumbuf(13)
236            calving_used_net          = rsumbuf(14)
237            calving_to_bergs_net      = rsumbuf(15)
238            heat_to_bergs_net         = rsumbuf(16)
239            heat_to_ocean_net         = rsumbuf(17)
240            melt_net                  = rsumbuf(18)
241            berg_melt_net             = rsumbuf(19)
242            bits_src_net              = rsumbuf(20)
243            bits_melt_net             = rsumbuf(21)
244            zgrdd_berg_mass           = rsumbuf(22)
245            zgrdd_bits_mass           = rsumbuf(23)
246
247            nsumbuf(1) = nbergs_end
248            nsumbuf(2) = nbergs_calved
249            nsumbuf(3) = nbergs_melted
250            nsumbuf(4) = nspeeding_tickets
251            DO ik = 1, nclasses
252               nsumbuf(4+ik) = nbergs_calved_by_class(ik)
253            END DO
254
255            CALL mpp_sum( nsumbuf(1:nclasses+4), nclasses+4 )
256
257            nbergs_end        = nsumbuf(1)
258            nbergs_calved     = nsumbuf(2)
259            nbergs_melted     = nsumbuf(3)
260            nspeeding_tickets = nsumbuf(4)
261            DO ik = 1,nclasses
262               nbergs_calved_by_class(ik)= nsumbuf(4+ik)
263            ENDDO
264
265         ENDIF
266
267         CALL report_state( 'stored ice','kg','',stored_start,'',stored_end,'')
268         CALL report_state( 'floating','kg','',floating_mass_start,'',floating_mass_end,'',nbergs_end)
269         CALL report_state( 'icebergs','kg','',bergs_mass_start,'',bergs_mass_end,'')
270         CALL report_state( 'bits','kg','',bits_mass_start,'',bits_mass_end,'')
271         CALL report_istate( 'berg #','',nbergs_start,'',nbergs_end,'')
272         CALL report_ibudget( 'berg #','calved',nbergs_calved, &
273                                       'melted',nbergs_melted, &
274                                       '#',nbergs_start,nbergs_end)
275         CALL report_budget( 'stored mass','kg','calving used',calving_used_net, &
276                                           'bergs',calving_to_bergs_net, &
277                                           'stored mass',stored_start,stored_end)
278         CALL report_budget( 'floating mass','kg','calving used',calving_to_bergs_net, &
279                                             'bergs',melt_net, &
280                                             'stored mass',floating_mass_start,floating_mass_end)
281         CALL report_budget( 'berg mass','kg','calving',calving_to_bergs_net, &
282                                              'melt+eros',berg_melt_net, &
283                                              'berg mass',bergs_mass_start,bergs_mass_end)
284         CALL report_budget( 'bits mass','kg','eros used',bits_src_net, &
285                                              'bergs',bits_melt_net, &
286                                              'stored mass',bits_mass_start,bits_mass_end)
287         CALL report_budget( 'net mass','kg','recvd',calving_rcv_net, &
288                                             'rtrnd',calving_ret_net, &
289                                             'net mass',stored_start+floating_mass_start, &
290                                                        stored_end+floating_mass_end)
291         CALL report_consistant( 'iceberg mass','kg','gridded',zgrdd_berg_mass,'bergs',bergs_mass_end)
292         CALL report_consistant( 'bits mass','kg','gridded',zgrdd_bits_mass,'bits',bits_mass_end)
293         CALL report_state( 'net heat','J','',stored_heat_start+floating_heat_start,'', &
294                                              stored_heat_end+floating_heat_end,'')
295         CALL report_state( 'stored heat','J','',stored_heat_start,'',stored_heat_end,'')
296         CALL report_state( 'floating heat','J','',floating_heat_start,'',floating_heat_end,'')
297         CALL report_budget( 'net heat','J','net heat',calving_src_heat_net, &
298                                            'net heat',calving_out_heat_net, &
299                                            'net heat',stored_heat_start+floating_heat_start, &
300                                                       stored_heat_end+floating_heat_end)
301         CALL report_budget( 'stored heat','J','calving used',calving_src_heat_used_net, &
302                                               'bergs',heat_to_bergs_net, &
303                                               'net heat',stored_heat_start,stored_heat_end)
304         CALL report_budget( 'flting heat','J','calved',heat_to_bergs_net, &
305                                               'melt',heat_to_ocean_net, &
306                                               'net heat',floating_heat_start,floating_heat_end)
307         IF (nn_verbose_level >= 1) THEN
308            CALL report_consistant( 'top interface','kg','from SIS',calving_src_net, &
309                                    'received',calving_rcv_net)
310            CALL report_consistant( 'bot interface','kg','sent',calving_out_net, &
311                                    'returned',calving_ret_net)
312         ENDIF
313         WRITE( numicb, '("calved by class = ",i6,20(",",i6))') (nbergs_calved_by_class(ik),ik=1,nclasses)
314         IF ( nspeeding_tickets > 0 ) WRITE( numicb, '("speeding tickets issued = ",i6)') nspeeding_tickets
315
316         nbergs_start              = nbergs_end
317         stored_start              = stored_end
318         nbergs_melted             = 0
319         nbergs_calved             = 0
320         nbergs_calved_by_class(:) = 0
321         nspeeding_tickets         = 0
322         stored_heat_start         = stored_heat_end
323         floating_heat_start       = floating_heat_end
324         floating_mass_start       = floating_mass_end
325         bergs_mass_start          = bergs_mass_end
326         bits_mass_start           = bits_mass_end
327         calving_used_net          = 0._wp
328         calving_to_bergs_net      = 0._wp
329         heat_to_bergs_net         = 0._wp
330         heat_to_ocean_net         = 0._wp
331         calving_rcv_net           = 0._wp
332         calving_ret_net           = 0._wp
333         calving_src_net           = 0._wp
334         calving_out_net           = 0._wp
335         calving_src_heat_net      = 0._wp
336         calving_src_heat_used_net = 0._wp
337         calving_out_heat_net      = 0._wp
338         melt_net                  = 0._wp
339         berg_melt_net             = 0._wp
340         bits_melt_net             = 0._wp
341         bits_src_net              = 0._wp
342      ENDIF
343      !
344   END SUBROUTINE icb_dia
345
346
347   SUBROUTINE icb_dia_step
348      !!----------------------------------------------------------------------
349      !! things to reset at the beginning of each timestep
350      !!----------------------------------------------------------------------
351      !
352      IF( .NOT. ln_bergdia ) RETURN
353      berg_melt    (:,:)   = 0._wp
354      buoy_melt    (:,:)   = 0._wp
355      eros_melt    (:,:)   = 0._wp
356      conv_melt    (:,:)   = 0._wp
357      bits_src     (:,:)   = 0._wp
358      bits_melt    (:,:)   = 0._wp
359      bits_mass    (:,:)   = 0._wp
360      berg_mass    (:,:)   = 0._wp
361      virtual_area (:,:)   = 0._wp
362      real_calving (:,:,:) = 0._wp
363      !
364   END SUBROUTINE icb_dia_step
365
366
367   SUBROUTINE icb_dia_put
368      !!----------------------------------------------------------------------
369      !!----------------------------------------------------------------------
370      !
371      IF( .NOT. ln_bergdia )   RETURN            !!gm useless iom will control whether it is output or not
372      !
373      CALL iom_put( "berg_melt"        , berg_melt   (:,:)   )   ! Melt rate of icebergs                     [kg/m2/s]
374      CALL iom_put( "berg_buoy_melt"   , buoy_melt   (:,:)   )   ! Buoyancy component of iceberg melt rate   [kg/m2/s]
375      CALL iom_put( "berg_eros_melt"   , eros_melt   (:,:)   )   ! Erosion component of iceberg melt rate    [kg/m2/s]
376      CALL iom_put( "berg_conv_melt"   , conv_melt   (:,:)   )   ! Convective component of iceberg melt rate [kg/m2/s]
377      CALL iom_put( "berg_virtual_area", virtual_area(:,:)   )   ! Virtual coverage by icebergs              [m2]
378      CALL iom_put( "bits_src"         , bits_src    (:,:)   )   ! Mass source of bergy bits                 [kg/m2/s]
379      CALL iom_put( "bits_melt"        , bits_melt   (:,:)   )   ! Melt rate of bergy bits                   [kg/m2/s]
380      CALL iom_put( "bits_mass"        , bits_mass   (:,:)   )   ! Bergy bit density field                   [kg/m2]
381      CALL iom_put( "berg_mass"        , berg_mass   (:,:)   )   ! Iceberg density field                     [kg/m2]
382      CALL iom_put( "berg_real_calving", real_calving(:,:,:) )   ! Calving into iceberg class                [kg/s]
383      !
384   END SUBROUTINE icb_dia_put
385
386
387   SUBROUTINE icb_dia_calve( ki, kj, kn, pcalved, pheated )
388      !!----------------------------------------------------------------------
389      !!----------------------------------------------------------------------
390      INTEGER,  INTENT(in)  ::   ki, kj, kn
391      REAL(wp), INTENT(in)  ::   pcalved
392      REAL(wp), INTENT(in)  ::   pheated
393      !!----------------------------------------------------------------------
394      !
395      IF( .NOT. ln_bergdia ) RETURN
396      real_calving(ki,kj,kn)     = real_calving(ki,kj,kn) + pcalved / berg_dt
397      nbergs_calved              = nbergs_calved              + 1
398      nbergs_calved_by_class(kn) = nbergs_calved_by_class(kn) + 1
399      calving_to_bergs_net       = calving_to_bergs_net + pcalved
400      heat_to_bergs_net          = heat_to_bergs_net    + pheated
401      !
402   END SUBROUTINE icb_dia_calve
403
404
405   SUBROUTINE icb_dia_income( kt,  pcalving_used, pheat_used )
406      !!----------------------------------------------------------------------
407      !!----------------------------------------------------------------------
408      INTEGER ,                 INTENT(in)  :: kt
409      REAL(wp),                 INTENT(in)  :: pcalving_used
410      REAL(wp), DIMENSION(:,:), INTENT(in)  :: pheat_used
411      !!----------------------------------------------------------------------
412      !
413      IF( .NOT. ln_bergdia ) RETURN
414      !
415      IF( kt == nit000 ) THEN
416         stored_start = SUM( berg_grid%stored_ice(:,:,:) )
417         IF( lk_mpp ) CALL mpp_sum( stored_start )
418         WRITE(numicb,'(a,es13.6,a)')   'icb_dia_income: initial stored mass=',stored_start,' kg'
419         !
420         stored_heat_start = SUM( berg_grid%stored_heat(:,:) )
421         IF( lk_mpp ) CALL mpp_sum( stored_heat_start )
422         WRITE(numicb,'(a,es13.6,a)')    'icb_dia_income: initial stored heat=',stored_heat_start,' J'
423      ENDIF
424      !
425      calving_rcv_net = calving_rcv_net + SUM( berg_grid%calving(:,:) ) * berg_dt
426      calving_src_net = calving_rcv_net
427      calving_src_heat_net = calving_src_heat_net +  &
428         &                      SUM( berg_grid%calving_hflx(:,:) * e1e2t(:,:) ) * berg_dt   ! Units of J
429      calving_used_net = calving_used_net + pcalving_used * berg_dt
430      calving_src_heat_used_net = calving_src_heat_used_net + SUM( pheat_used(:,:) )
431      !
432   END SUBROUTINE icb_dia_income
433
434
435   SUBROUTINE icb_dia_size(ki, kj, pWn, pLn, pAbits,   &
436      &                    pmass_scale, pMnew, pnMbits, pz1_e1e2)
437      !!----------------------------------------------------------------------
438      !!----------------------------------------------------------------------
439      INTEGER,  INTENT(in) :: ki, kj
440      REAL(wp), INTENT(in) :: pWn, pLn, pAbits, pmass_scale, pMnew, pnMbits, pz1_e1e2
441      !!----------------------------------------------------------------------
442      !
443      IF( .NOT. ln_bergdia ) RETURN
444      virtual_area(ki,kj) = virtual_area(ki,kj) + ( pWn * pLn + pAbits ) * pmass_scale      ! m^2
445      berg_mass(ki,kj)    = berg_mass(ki,kj) + pMnew * pz1_e1e2                             ! kg/m2
446      bits_mass(ki,kj)    = bits_mass(ki,kj) + pnMbits * pz1_e1e2                           ! kg/m2
447      !
448   END SUBROUTINE icb_dia_size
449
450
451   SUBROUTINE icb_dia_speed()
452      !!----------------------------------------------------------------------
453      !!----------------------------------------------------------------------
454      !
455      IF( .NOT. ln_bergdia ) RETURN
456      nspeeding_tickets = nspeeding_tickets + 1
457      !
458   END SUBROUTINE icb_dia_speed
459
460
461   SUBROUTINE icb_dia_melt(ki, kj, pmnew, pheat, pmass_scale,   &
462      &                   pdM, pdMbitsE, pdMbitsM, pdMb, pdMe,   &
463      &                   pdMv, pz1_dt_e1e2 )
464      !!----------------------------------------------------------------------
465      !!----------------------------------------------------------------------
466      INTEGER , INTENT(in) ::   ki, kj
467      REAL(wp), INTENT(in) ::   pmnew, pheat, pmass_scale
468      REAL(wp), INTENT(in) ::   pdM, pdMbitsE, pdMbitsM, pdMb, pdMe, pdMv, pz1_dt_e1e2
469      !!----------------------------------------------------------------------
470      !
471      IF( .NOT. ln_bergdia ) RETURN
472
473      berg_melt (ki,kj) = berg_melt (ki,kj) + pdM      * pz1_dt_e1e2   ! kg/m2/s
474      bits_src  (ki,kj) = bits_src  (ki,kj) + pdMbitsE * pz1_dt_e1e2   ! mass flux into bergy bitskg/m2/s
475      bits_melt (ki,kj) = bits_melt (ki,kj) + pdMbitsM * pz1_dt_e1e2   ! melt rate of bergy bits kg/m2/s
476      buoy_melt (ki,kj) = buoy_melt (ki,kj) + pdMb     * pz1_dt_e1e2   ! kg/m2/s
477      eros_melt (ki,kj) = eros_melt (ki,kj) + pdMe     * pz1_dt_e1e2   ! erosion rate kg/m2/s
478      conv_melt (ki,kj) = conv_melt (ki,kj) + pdMv     * pz1_dt_e1e2   ! kg/m2/s
479      heat_to_ocean_net = heat_to_ocean_net + pheat * pmass_scale * berg_dt         ! J
480      IF( pmnew <= 0._wp ) nbergs_melted = nbergs_melted + 1                        ! Delete the berg if completely melted
481      !
482   END SUBROUTINE icb_dia_melt
483
484
485   SUBROUTINE report_state( cd_budgetstr, cd_budgetunits, cd_startstr, pstartval, cd_endstr,   &
486      &                     pendval, cd_delstr, kbergs )
487      !!----------------------------------------------------------------------
488      !!----------------------------------------------------------------------
489      CHARACTER*(*), INTENT(in)           :: cd_budgetstr, cd_budgetunits, cd_startstr, cd_endstr, cd_delstr
490      REAL(wp),      INTENT(in)           :: pstartval, pendval
491      INTEGER,       INTENT(in), OPTIONAL :: kbergs
492      !!----------------------------------------------------------------------
493      !
494      IF ( PRESENT(kbergs) ) THEN
495         WRITE(numicb,100) cd_budgetstr // ' state:',                                    &
496                           cd_startstr  // ' start',  pstartval,         cd_budgetunits, &
497                           cd_endstr    // ' end',    pendval,           cd_budgetunits, &
498                           'Delta '     // cd_delstr, pendval-pstartval, cd_budgetunits, &
499                           '# of bergs', kbergs
500      ELSE
501         WRITE(numicb,100) cd_budgetstr // ' state:',                                   &
502                           cd_startstr  // ' start', pstartval,         cd_budgetunits, &
503                           cd_endstr    // ' end',   pendval,           cd_budgetunits, &
504                           cd_delstr    // 'Delta',  pendval-pstartval, cd_budgetunits
505      ENDIF
506      100 FORMAT(a19,3(a18,"=",es14.7,x,a2,:,","),a12,i8)
507   END SUBROUTINE report_state
508
509
510   SUBROUTINE report_consistant( cd_budgetstr, cd_budgetunits, cd_startstr, pstartval, cd_endstr, pendval)
511      !!----------------------------------------------------------------------
512      !!----------------------------------------------------------------------
513      CHARACTER*(*), INTENT(in) :: cd_budgetstr, cd_budgetunits, cd_startstr, cd_endstr
514      REAL(wp),      INTENT(in) :: pstartval, pendval
515      !!----------------------------------------------------------------------
516      !
517      WRITE(numicb,200) cd_budgetstr // ' check:',                 &
518                        cd_startstr,    pstartval, cd_budgetunits, &
519                        cd_endstr,      pendval,   cd_budgetunits, &
520                        'error',        (pendval-pstartval)/((pendval+pstartval)+1e-30), 'nd'
521      200 FORMAT(a19,10(a18,"=",es14.7,x,a2,:,","))
522   END SUBROUTINE report_consistant
523
524
525   SUBROUTINE report_budget( cd_budgetstr, cd_budgetunits, cd_instr, pinval, cd_outstr,   &
526      &                      poutval, cd_delstr, pstartval, pendval)
527      !!----------------------------------------------------------------------
528      !!----------------------------------------------------------------------
529      CHARACTER*(*), INTENT(in) :: cd_budgetstr, cd_budgetunits, cd_instr, cd_outstr, cd_delstr
530      REAL(wp),      INTENT(in) :: pinval, poutval, pstartval, pendval
531      !
532      REAL(wp)                  :: zval
533      !!----------------------------------------------------------------------
534      !
535      zval = ( ( pendval - pstartval ) - ( pinval - poutval ) ) /   &
536         &   MAX( 1.e-30, MAX( abs( pendval - pstartval ) , ABS( pinval - poutval ) ) )
537
538      WRITE(numicb,200) cd_budgetstr // ' budget:', &
539         &              cd_instr     // ' in',      pinval,         cd_budgetunits, &
540         &              cd_outstr    // ' out',     poutval,        cd_budgetunits, &
541         &              'Delta '     // cd_delstr,  pinval-poutval, cd_budgetunits, &
542         &              'error',        zval,                       'nd'
543  200 FORMAT(a19,3(a18,"=",es14.7,x,a2,:,","),a8,"=",es10.3,x,a2)
544      !
545   END SUBROUTINE report_budget
546
547
548   SUBROUTINE report_istate( cd_budgetstr, cd_startstr, pstartval, cd_endstr, pendval, cd_delstr)
549      !!----------------------------------------------------------------------
550      !!----------------------------------------------------------------------
551      CHARACTER*(*), INTENT(in) :: cd_budgetstr, cd_startstr, cd_endstr, cd_delstr
552      INTEGER,       INTENT(in) :: pstartval, pendval
553      !
554      WRITE(numicb,100) cd_budgetstr // ' state:',           &
555         &              cd_startstr  // ' start', pstartval, &
556         &              cd_endstr    // ' end',   pendval,   &
557         &              cd_delstr    // 'Delta',  pendval-pstartval
558  100 FORMAT(a19,3(a18,"=",i14,x,:,","))
559      !
560   END SUBROUTINE report_istate
561
562
563   SUBROUTINE report_ibudget( cd_budgetstr, cd_instr, pinval, cd_outstr, poutval,   &
564      &                       cd_delstr, pstartval, pendval)
565      !!----------------------------------------------------------------------
566      !!----------------------------------------------------------------------
567      CHARACTER*(*), INTENT(in) :: cd_budgetstr, cd_instr, cd_outstr, cd_delstr
568      INTEGER,       INTENT(in) :: pinval, poutval, pstartval, pendval
569      !!----------------------------------------------------------------------
570      !
571      WRITE(numicb,200) cd_budgetstr // ' budget:', &
572                        cd_instr     // ' in',      pinval, &
573                        cd_outstr    // ' out',     poutval, &
574                        'Delta '     // cd_delstr,  pinval-poutval, &
575                        'error',                    ( ( pendval - pstartval ) - ( pinval - poutval ) )
576      200 FORMAT(a19,10(a18,"=",i14,x,:,","))
577   END SUBROUTINE report_ibudget
578
579   !!======================================================================
580END MODULE icbdia
Note: See TracBrowser for help on using the repository browser.