Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

icbdia.F90 @ 14167

Last change on this file since 14167 was 14167, checked in by davestorkey, 4 years ago
UKMO/NEMO_4.0.3_icb_speed_limit branch : iterative iceberg speed limit
File size: 34.0 KB

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

Note: See TracBrowser for help on using the repository browser.

New URL for NEMO forge! http://forge.nemo-ocean.eu

Context Navigation

source: NEMO/branches/UKMO/NEMO_4.0.3_icb_speed_limit/src/OCE/ICB/icbdia.F90 @ 14167

Download in other formats: