Context Navigation

storage_module.F90

Last change on this file was 11, checked in by aslmd, 14 years ago
spiga@svn-planeto:ajoute le modele meso-echelle martien
File size: 31.7 KB

Line
1	module storage_module
2
3	use datatype_module
4	use minheap_module
5	use misc_definitions_module
6	use module_debug
7	use parallel_module
8
9	! Maximum umber of words to keep in memory at a time
10	! THIS MUST BE AT LEAST AS LARGE AS THE SIZE OF THE LARGEST ARRAY TO BE STORED
11	integer, parameter :: MEMSIZE_MAX = 1E9
12
13	! Name (when formatted as i9.9) of next file to be used as array storage
14	integer :: next_filenumber = 1
15
16	! Time counter used by policy for evicting arrays to Fortran units
17	integer :: global_time = 0
18
19	! Current memory usage of module
20	integer :: memsize = 0
21
22	! Primary head and tail pointers
23	type (head_node), pointer :: head => null()
24	type (head_node), pointer :: tail => null()
25
26	! Pointer for get_next_output_fieldname
27	type (head_node), pointer :: next_output_field => null()
28
29	contains
30
31	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
32	! Name: storage_init
33	!
34	! Purpose: Initialize the storage module.
35	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
36	subroutine storage_init()
37
38	implicit none
39
40	call init_heap()
41
42	end subroutine storage_init
43
44
45	subroutine reset_next_field()
46
47	implicit none
48
49	next_output_field => head
50
51	end subroutine reset_next_field
52
53
54	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
55	! Name: storage_put_field
56	!
57	! Purpose: Stores an fg_input type. Upon return, IT MUST NOT BE ASSUMED that
58	! store_me contains valid data, since all such data may have been written
59	! to a Fortran unit
60	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
61	subroutine storage_put_field(store_me)
62
63	implicit none
64
65	! Arguments
66	type (fg_input) :: store_me
67
68	! Local variables
69	integer :: funit
70	logical :: is_used
71	character (len=64) :: fname
72	type (head_node), pointer :: name_cursor
73	type (data_node), pointer :: data_cursor
74	type (data_node), pointer :: newnode
75	type (data_node), pointer :: evictnode
76
77	! We'll first see if there is already a list for this fieldname
78	name_cursor => head
79	do while (associated(name_cursor))
80	if (primary_cmp(name_cursor%fg_data, store_me) == EQUAL) exit
81	name_cursor => name_cursor%next
82	end do
83
84	! If not, create a new node in the primary list
85	if (.not. associated(name_cursor)) then
86	allocate(name_cursor)
87	call dup(store_me, name_cursor%fg_data)
88	nullify(name_cursor%fg_data%r_arr)
89	nullify(name_cursor%fg_data%valid_mask)
90	nullify(name_cursor%fg_data%modified_mask)
91	nullify(name_cursor%fieldlist_head)
92	nullify(name_cursor%fieldlist_tail)
93	nullify(name_cursor%prev)
94	name_cursor%next => head
95	if (.not. associated(head)) tail => name_cursor
96	head => name_cursor
97	else
98	if ((name_cursor%fg_data%header%time_dependent .and. .not. store_me%header%time_dependent) .or. &
99	(.not. name_cursor%fg_data%header%time_dependent .and. store_me%header%time_dependent)) then
100	call mprintf(.true.,ERROR,'Cannot combine time-independent data with '// &
101	'time-dependent data for field %s',s1=store_me%header%field)
102	end if
103	end if
104
105	! At this point, name_cursor points to a valid head node for fieldname
106	data_cursor => name_cursor%fieldlist_head
107	do while ( associated(data_cursor) )
108	if ((secondary_cmp(store_me, data_cursor%fg_data) == LESS) .or. &
109	(secondary_cmp(store_me, data_cursor%fg_data) == EQUAL)) exit
110	data_cursor => data_cursor%next
111	end do
112
113	if (associated(data_cursor)) then
114	if (secondary_cmp(store_me, data_cursor%fg_data) == EQUAL) then
115	if (data_cursor%filenumber > 0) then
116	! BUG: Might need to deal with freeing up a file
117	call mprintf(.true.,WARN,'WE NEED TO FREE THE FILE ASSOCIATED WITH DATA_CURSOR')
118	call mprintf(.true.,WARN,'PLEASE REPORT THIS BUG TO THE DEVELOPER!')
119	end if
120	data_cursor%fg_data%r_arr => store_me%r_arr
121	data_cursor%fg_data%valid_mask => store_me%valid_mask
122	data_cursor%fg_data%modified_mask => store_me%modified_mask
123	return
124	end if
125	end if
126
127	allocate(newnode)
128	call dup(store_me, newnode%fg_data)
129
130	newnode%field_shape = shape(newnode%fg_data%r_arr)
131	memsize = memsize + size(newnode%fg_data%r_arr)
132	newnode%last_used = global_time
133	global_time = global_time + 1
134	newnode%filenumber = 0
135	call add_to_heap(newnode)
136
137	do while (memsize > MEMSIZE_MAX)
138	call get_min(evictnode)
139	evictnode%filenumber = next_filenumber
140	next_filenumber = next_filenumber + 1
141	do funit=10,100
142	inquire(unit=funit, opened=is_used)
143	if (.not. is_used) exit
144	end do
145	memsize = memsize - size(evictnode%fg_data%r_arr)
146	write(fname,'(i9.9,a2,i3.3)') evictnode%filenumber,'.p',my_proc_id
147	open(funit,file=trim(fname),form='unformatted',status='unknown')
148	write(funit) evictnode%fg_data%r_arr
149	close(funit)
150	deallocate(evictnode%fg_data%r_arr)
151	end do
152
153	! Inserting node at the tail of list
154	if (.not. associated(data_cursor)) then
155	newnode%prev => name_cursor%fieldlist_tail
156	nullify(newnode%next)
157
158	! List is actually empty
159	if (.not. associated(name_cursor%fieldlist_head)) then
160	name_cursor%fieldlist_head => newnode
161	name_cursor%fieldlist_tail => newnode
162	else
163	name_cursor%fieldlist_tail%next => newnode
164	name_cursor%fieldlist_tail => newnode
165	end if
166
167	! Inserting node at the head of list
168	else if ((secondary_cmp(name_cursor%fieldlist_head%fg_data, newnode%fg_data) == GREATER) .or. &
169	(secondary_cmp(name_cursor%fieldlist_head%fg_data, newnode%fg_data) == EQUAL)) then
170	nullify(newnode%prev)
171	newnode%next => name_cursor%fieldlist_head
172	name_cursor%fieldlist_head%prev => newnode
173	name_cursor%fieldlist_head => newnode
174
175	! Inserting somewhere in the middle of the list
176	else
177	newnode%prev => data_cursor%prev
178	newnode%next => data_cursor
179	data_cursor%prev%next => newnode
180	data_cursor%prev => newnode
181	end if
182
183	end subroutine storage_put_field
184
185
186	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
187	! Name: storage_get_field
188	!
189	! Purpose: Retrieves an fg_input type from storage; if the fg_input type whose
190	! header matches the header of get_me does not exist, istatus = 1 upon
191	! return; if the requested fg_input type is found, istatus = 0
192	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
193	subroutine storage_get_field(get_me, istatus)
194
195	implicit none
196
197	! Arguments
198	type (fg_input), intent(inout) :: get_me
199	integer, intent(out) :: istatus
200
201	! Local variables
202	integer :: funit
203	logical :: is_used
204	character (len=64) :: fname
205	type (head_node), pointer :: name_cursor
206	type (data_node), pointer :: data_cursor
207	type (data_node), pointer :: evictnode
208
209	global_time = global_time + 1
210
211	istatus = 1
212
213	! We'll first see if there is already a list for this fieldname
214	name_cursor => head
215	do while (associated(name_cursor))
216	if (primary_cmp(name_cursor%fg_data, get_me) == EQUAL) exit
217	name_cursor => name_cursor%next
218	end do
219
220	if (.not. associated(name_cursor)) return
221
222	! At this point, name_cursor points to a valid head node for fieldname
223	data_cursor => name_cursor%fieldlist_head
224	do while ( associated(data_cursor) )
225	if (secondary_cmp(get_me, data_cursor%fg_data) == EQUAL) then
226	call dup(data_cursor%fg_data, get_me)
227
228	! Before deciding whether we need to write an array to disk, first consider
229	! that reading the requested array will use memory
230	if (data_cursor%filenumber > 0) then
231	memsize = memsize + data_cursor%field_shape(1)*data_cursor%field_shape(2)
232	end if
233
234	! If we exceed our memory limit, we need to evict
235	do while (memsize > MEMSIZE_MAX)
236	call get_min(evictnode)
237	evictnode%filenumber = next_filenumber
238	next_filenumber = next_filenumber + 1
239	do funit=10,100
240	inquire(unit=funit, opened=is_used)
241	if (.not. is_used) exit
242	end do
243	memsize = memsize - size(evictnode%fg_data%r_arr)
244	write(fname,'(i9.9,a2,i3.3)') evictnode%filenumber,'.p',my_proc_id
245	open(funit,file=trim(fname),form='unformatted',status='unknown')
246	write(funit) evictnode%fg_data%r_arr
247	close(funit)
248	deallocate(evictnode%fg_data%r_arr)
249	end do
250
251	! Get requested array
252	if (data_cursor%filenumber > 0) then
253	data_cursor%last_used = global_time
254	global_time = global_time + 1
255	call add_to_heap(data_cursor)
256	write(fname,'(i9.9,a2,i3.3)') data_cursor%filenumber,'.p',my_proc_id
257	do funit=10,100
258	inquire(unit=funit, opened=is_used)
259	if (.not. is_used) exit
260	end do
261	open(funit,file=trim(fname),form='unformatted',status='old')
262	allocate(data_cursor%fg_data%r_arr(data_cursor%field_shape(1),data_cursor%field_shape(2)))
263	read(funit) data_cursor%fg_data%r_arr
264	get_me%r_arr => data_cursor%fg_data%r_arr
265	close(funit,status='delete')
266	data_cursor%filenumber = 0
267	else
268	get_me%r_arr => data_cursor%fg_data%r_arr
269
270	call remove_index(data_cursor%heap_index)
271	data_cursor%last_used = global_time
272	global_time = global_time + 1
273	call add_to_heap(data_cursor)
274	end if
275
276	istatus = 0
277	return
278	end if
279	data_cursor => data_cursor%next
280	end do
281
282	end subroutine storage_get_field
283
284
285	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
286	! Name: storage_query_field
287	!
288	! Purpose:
289	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
290	subroutine storage_query_field(get_me, istatus)
291
292	implicit none
293
294	! Arguments
295	type (fg_input), intent(inout) :: get_me
296	integer, intent(out) :: istatus
297
298	! Local variables
299	type (head_node), pointer :: name_cursor
300	type (data_node), pointer :: data_cursor
301
302	istatus = 1
303
304	! We'll first see if there is already a list for this fieldname
305	name_cursor => head
306	do while (associated(name_cursor))
307	if (primary_cmp(name_cursor%fg_data, get_me) == EQUAL) exit
308	name_cursor => name_cursor%next
309	end do
310
311	if (.not. associated(name_cursor)) return
312
313	! At this point, name_cursor points to a valid head node for fieldname
314	data_cursor => name_cursor%fieldlist_head
315	do while ( associated(data_cursor) )
316	if (secondary_cmp(get_me, data_cursor%fg_data) == EQUAL) then
317	get_me%r_arr => data_cursor%fg_data%r_arr
318	get_me%valid_mask => data_cursor%fg_data%valid_mask
319	get_me%modified_mask => data_cursor%fg_data%modified_mask
320	istatus = 0
321	return
322	end if
323	data_cursor => data_cursor%next
324	end do
325
326	end subroutine storage_query_field
327
328
329	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
330	! Name: get_next_output_fieldname
331	!
332	! Purpose:
333	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
334	subroutine get_next_output_fieldname(field_name, ndims, &
335	min_level, max_level, &
336	istagger, mem_order, dim_names, units, description, &
337	istatus)
338
339	implicit none
340
341	! Arguments
342	integer, intent(out) :: ndims, min_level, max_level, istagger, istatus
343	character (len=128), intent(out) :: field_name, mem_order, units, description
344	character (len=128), dimension(3), intent(out) :: dim_names
345
346	#include "wrf_io_flags.h"
347	#include "wrf_status_codes.h"
348
349	! Local variables
350	character (len=64) :: fname
351	type (data_node), pointer :: data_cursor
352
353	istatus = 1
354
355	if (.not. associated(next_output_field)) return
356
357	min_level = 1
358	max_level = 0
359	ndims = 2
360
361	do while (max_level == 0 .and. associated(next_output_field))
362
363	data_cursor => next_output_field%fieldlist_head
364	if (associated(data_cursor)) then
365	if (.not. is_mask_field(data_cursor%fg_data)) then
366	do while ( associated(data_cursor) )
367	istatus = 0
368	max_level = max_level + 1
369	data_cursor => data_cursor%next
370	end do
371	end if
372	end if
373
374	if (max_level == 0) next_output_field => next_output_field%next
375	end do
376
377	if (max_level > 0 .and. associated(next_output_field)) then
378
379	if (max_level > 1) ndims = 3
380	if (ndims == 2) then
381	mem_order = 'XY '
382	dim_names(3) = ' '
383	else
384	mem_order = 'XYZ'
385	if (is_time_dependent(next_output_field%fg_data)) then
386	dim_names(3) = ' '
387	dim_names(3)(1:32) = next_output_field%fg_data%header%vertical_coord
388	else
389	write(dim_names(3),'(a11,i4.4)') 'z-dimension', max_level
390	end if
391	end if
392	field_name = get_fieldname(next_output_field%fg_data)
393	istagger = get_staggering(next_output_field%fg_data)
394	if (istagger == M .or. istagger == HH .or. istagger == VV) then
395	dim_names(1) = 'west_east'
396	dim_names(2) = 'south_north'
397	else if (istagger == U) then
398	dim_names(1) = 'west_east_stag'
399	dim_names(2) = 'south_north'
400	else if (istagger == V) then
401	dim_names(1) = 'west_east'
402	dim_names(2) = 'south_north_stag'
403	else
404	dim_names(1) = 'i-dimension'
405	dim_names(2) = 'j-dimension'
406	end if
407	units = get_units(next_output_field%fg_data)
408	description = get_description(next_output_field%fg_data)
409
410	next_output_field => next_output_field%next
411	end if
412
413	end subroutine get_next_output_fieldname
414
415
416	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
417	! Name: get_next_output_field
418	!
419	! Purpose:
420	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
421	subroutine get_next_output_field(field_name, r_array, &
422	start_i, end_i, start_j, end_j, min_level, max_level, istatus)
423
424	implicit none
425
426	! Arguments
427	integer, intent(out) :: start_i, end_i, start_j, end_j, min_level, max_level, istatus
428	real, pointer, dimension(:,:,:) :: r_array
429	character (len=128), intent(out) :: field_name
430
431	#include "wrf_io_flags.h"
432	#include "wrf_status_codes.h"
433
434	! Local variables
435	integer :: i, j, k
436	character (len=64) :: fname
437	type (data_node), pointer :: data_cursor
438	type (fg_input) :: temp_field
439
440	istatus = 1
441
442	if (.not. associated(next_output_field)) return
443
444	min_level = 1
445	max_level = 0
446
447	do while (max_level == 0 .and. associated(next_output_field))
448
449	data_cursor => next_output_field%fieldlist_head
450	if (associated(data_cursor)) then
451	if (.not. is_mask_field(data_cursor%fg_data)) then
452	do while ( associated(data_cursor) )
453	istatus = 0
454	max_level = max_level + 1
455	data_cursor => data_cursor%next
456	end do
457	end if
458	end if
459
460	if (max_level == 0) next_output_field => next_output_field%next
461	end do
462
463	if (max_level > 0 .and. associated(next_output_field)) then
464
465	start_i = 1
466	end_i = next_output_field%fieldlist_head%field_shape(1)
467	start_j = 1
468	end_j = next_output_field%fieldlist_head%field_shape(2)
469
470	allocate(r_array(next_output_field%fieldlist_head%field_shape(1), &
471	next_output_field%fieldlist_head%field_shape(2), &
472	max_level) )
473
474	k = 1
475	data_cursor => next_output_field%fieldlist_head
476	do while ( associated(data_cursor) )
477	call dup(data_cursor%fg_data, temp_field)
478	call storage_get_field(temp_field, istatus)
479	r_array(:,:,k) = temp_field%r_arr
480	k = k + 1
481	data_cursor => data_cursor%next
482	end do
483
484	field_name = get_fieldname(next_output_field%fg_data)
485
486	next_output_field => next_output_field%next
487	end if
488
489	end subroutine get_next_output_field
490
491
492	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
493	! Name: storage_delete_field
494	!
495	! Purpose: Deletes the stored fg_input type whose header matches delete_me
496	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
497	subroutine storage_delete_field(delete_me)
498
499	implicit none
500
501	! Arguments
502	type (fg_input), intent(in) :: delete_me
503
504	! Local variables
505	integer :: funit
506	logical :: is_used
507	character (len=64) :: fname
508	type (head_node), pointer :: name_cursor
509	type (data_node), pointer :: data_cursor
510
511	! We'll first see if there is a list for this fieldname
512	name_cursor => head
513	do while (associated(name_cursor))
514	if (primary_cmp(name_cursor%fg_data, delete_me) == EQUAL) exit
515	name_cursor => name_cursor%next
516	end do
517
518	if (.not. associated(name_cursor)) return
519
520	! At this point, name_cursor points to a valid head node for fieldname
521	data_cursor => name_cursor%fieldlist_head
522	do while ( associated(data_cursor) )
523	if (secondary_cmp(delete_me, data_cursor%fg_data) == EQUAL) then
524
525	if (data_cursor%filenumber > 0) then
526	do funit=10,100
527	inquire(unit=funit, opened=is_used)
528	if (.not. is_used) exit
529	end do
530	write(fname,'(i9.9,a2,i3.3)') data_cursor%filenumber,'.p',my_proc_id
531	open(funit,file=trim(fname),form='unformatted',status='old')
532	close(funit,status='delete')
533	else
534	call remove_index(data_cursor%heap_index)
535	memsize = memsize - size(data_cursor%fg_data%r_arr)
536	deallocate(data_cursor%fg_data%r_arr)
537	end if
538	if (associated(data_cursor%fg_data%valid_mask)) call bitarray_destroy(data_cursor%fg_data%valid_mask)
539	nullify(data_cursor%fg_data%valid_mask)
540	if (associated(data_cursor%fg_data%modified_mask)) call bitarray_destroy(data_cursor%fg_data%modified_mask)
541	nullify(data_cursor%fg_data%modified_mask)
542
543	! Only item in the list
544	if (.not. associated(data_cursor%next) .and. &
545	.not. associated(data_cursor%prev)) then
546	nullify(name_cursor%fieldlist_head)
547	nullify(name_cursor%fieldlist_tail)
548	deallocate(data_cursor)
549	! DO WE REMOVE THIS HEADER NODE AT THIS POINT?
550	return
551
552	! Head of the list
553	else if (.not. associated(data_cursor%prev)) then
554	name_cursor%fieldlist_head => data_cursor%next
555	nullify(data_cursor%next%prev)
556	deallocate(data_cursor)
557	return
558
559	! Tail of the list
560	else if (.not. associated(data_cursor%next)) then
561	name_cursor%fieldlist_tail => data_cursor%prev
562	nullify(data_cursor%prev%next)
563	deallocate(data_cursor)
564	return
565
566	! Middle of the list
567	else
568	data_cursor%prev%next => data_cursor%next
569	data_cursor%next%prev => data_cursor%prev
570	deallocate(data_cursor)
571	return
572
573	end if
574
575	end if
576	data_cursor => data_cursor%next
577	end do
578
579	end subroutine storage_delete_field
580
581
582	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
583	! Name: storage_delete_all_td
584	!
585	! Purpose: Deletes the stored time-dependent data
586	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
587	subroutine storage_delete_all_td()
588
589	implicit none
590
591	! Local variables
592	integer :: funit
593	logical :: is_used
594	character (len=64) :: fname
595	type (head_node), pointer :: name_cursor
596	type (data_node), pointer :: data_cursor, next_cursor
597
598	! We'll first see if there is a list for this fieldname
599	name_cursor => head
600	do while (associated(name_cursor))
601
602	data_cursor => name_cursor%fieldlist_head
603	do while ( associated(data_cursor) )
604	if ( is_time_dependent(data_cursor%fg_data) ) then
605
606	if (data_cursor%filenumber > 0) then
607	do funit=10,100
608	inquire(unit=funit, opened=is_used)
609	if (.not. is_used) exit
610	end do
611	write(fname,'(i9.9,a2,i3.3)') data_cursor%filenumber,'.p',my_proc_id
612	open(funit,file=trim(fname),form='unformatted',status='old')
613	close(funit,status='delete')
614	else
615	call remove_index(data_cursor%heap_index)
616	memsize = memsize - size(data_cursor%fg_data%r_arr)
617	deallocate(data_cursor%fg_data%r_arr)
618	end if
619	if (associated(data_cursor%fg_data%valid_mask)) call bitarray_destroy(data_cursor%fg_data%valid_mask)
620	nullify(data_cursor%fg_data%valid_mask)
621	if (associated(data_cursor%fg_data%modified_mask)) call bitarray_destroy(data_cursor%fg_data%modified_mask)
622	nullify(data_cursor%fg_data%modified_mask)
623
624	! We should handle individual cases, that way we can deal with a list
625	! that has both time independent and time dependent nodes in it.
626
627	! Only item in the list
628	if (.not. associated(data_cursor%next) .and. &
629	.not. associated(data_cursor%prev)) then
630	next_cursor => null()
631	nullify(name_cursor%fieldlist_head)
632	nullify(name_cursor%fieldlist_tail)
633	deallocate(data_cursor)
634	! DO WE REMOVE THIS HEADER NODE AT THIS POINT?
635
636	! Head of the list
637	else if (.not. associated(data_cursor%prev)) then
638	name_cursor%fieldlist_head => data_cursor%next
639	next_cursor => data_cursor%next
640	nullify(data_cursor%next%prev)
641	deallocate(data_cursor)
642
643	! Tail of the list
644	else if (.not. associated(data_cursor%next)) then
645	! THIS CASE SHOULD PROBABLY NOT OCCUR
646	name_cursor%fieldlist_tail => data_cursor%prev
647	next_cursor => null()
648	nullify(data_cursor%prev%next)
649	deallocate(data_cursor)
650
651	! Middle of the list
652	else
653	! THIS CASE SHOULD PROBABLY NOT OCCUR
654	next_cursor => data_cursor%next
655	data_cursor%prev%next => data_cursor%next
656	data_cursor%next%prev => data_cursor%prev
657	deallocate(data_cursor)
658
659	end if
660
661	end if
662	data_cursor => next_cursor
663	end do
664
665	name_cursor => name_cursor%next
666	end do
667
668	end subroutine storage_delete_all_td
669
670
671	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
672	! Name: storage_get_levels
673	!
674	! Purpose: Returns a list of all levels for the field indicated in the_header.
675	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
676	subroutine storage_get_levels(the_header, list)
677
678	implicit none
679
680	! Arguments
681	integer, pointer, dimension(:) :: list
682	type (fg_input), intent(in) :: the_header
683
684	! Local variables
685	integer :: n
686	type (head_node), pointer :: name_cursor
687	type (data_node), pointer :: data_cursor
688
689	if (associated(list)) deallocate(list)
690	nullify(list)
691
692	! We'll first see if there is a list for this header
693	name_cursor => head
694	do while (associated(name_cursor))
695	if (primary_cmp(name_cursor%fg_data, the_header) == EQUAL) exit
696	name_cursor => name_cursor%next
697	end do
698
699	if (.not. associated(name_cursor)) return
700
701	n = 0
702	! At this point, name_cursor points to a valid head node for fieldname
703	data_cursor => name_cursor%fieldlist_head
704	do while ( associated(data_cursor) )
705	n = n + 1
706	if (.not. associated(data_cursor%next)) exit
707	data_cursor => data_cursor%next
708	end do
709
710	if (n > 0) allocate(list(n))
711
712	n = 1
713	do while ( associated(data_cursor) )
714	list(n) = get_level(data_cursor%fg_data)
715	n = n + 1
716	data_cursor => data_cursor%prev
717	end do
718
719	end subroutine storage_get_levels
720
721
722	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
723	! Name: storage_delete_all
724	!
725	! Purpose: Deletes all data, both time-independent and time-dependent.
726	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
727	subroutine storage_delete_all()
728
729	implicit none
730
731	! Local variables
732	integer :: funit
733	logical :: is_used
734	character (len=64) :: fname
735	type (head_node), pointer :: name_cursor
736	type (data_node), pointer :: data_cursor
737
738	! We'll first see if there is already a list for this fieldname
739	name_cursor => head
740	do while (associated(name_cursor))
741
742	if (associated(name_cursor%fieldlist_head)) then
743	data_cursor => name_cursor%fieldlist_head
744	do while ( associated(data_cursor) )
745	name_cursor%fieldlist_head => data_cursor%next
746
747	if (data_cursor%filenumber > 0) then
748	do funit=10,100
749	inquire(unit=funit, opened=is_used)
750	if (.not. is_used) exit
751	end do
752	write(fname,'(i9.9,a2,i3.3)') data_cursor%filenumber,'.p',my_proc_id
753	open(funit,file=trim(fname),form='unformatted',status='old')
754	close(funit,status='delete')
755	else
756	call remove_index(data_cursor%heap_index)
757	memsize = memsize - size(data_cursor%fg_data%r_arr)
758	deallocate(data_cursor%fg_data%r_arr)
759	end if
760	if (associated(data_cursor%fg_data%valid_mask)) call bitarray_destroy(data_cursor%fg_data%valid_mask)
761	nullify(data_cursor%fg_data%valid_mask)
762	if (associated(data_cursor%fg_data%modified_mask)) call bitarray_destroy(data_cursor%fg_data%modified_mask)
763	nullify(data_cursor%fg_data%modified_mask)
764
765	deallocate(data_cursor)
766	data_cursor => name_cursor%fieldlist_head
767	end do
768	end if
769
770	head => name_cursor%next
771	deallocate(name_cursor)
772	name_cursor => head
773	end do
774
775	nullify(head)
776	nullify(tail)
777
778	call heap_destroy()
779
780	end subroutine storage_delete_all
781
782
783	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
784	! Name: storage_get_all_headers
785	!
786	! Purpose:
787	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
788	subroutine storage_get_all_headers(header_list)
789
790	implicit none
791
792	! Arguments
793	type (fg_input), pointer, dimension(:) :: header_list
794
795	! Local variables
796	integer :: nheaders
797	type (head_node), pointer :: name_cursor
798	type (data_node), pointer :: data_cursor
799
800	nullify(header_list)
801
802	! First find out how many time-dependent headers there are
803	name_cursor => head
804	nheaders = 0
805	do while (associated(name_cursor))
806	if (associated(name_cursor%fieldlist_head)) then
807	if (.not. is_mask_field(name_cursor%fieldlist_head%fg_data)) then
808	nheaders = nheaders + 1
809	end if
810	end if
811	name_cursor => name_cursor%next
812	end do
813
814	allocate(header_list(nheaders))
815
816	name_cursor => head
817	nheaders = 0
818	do while (associated(name_cursor))
819	if (associated(name_cursor%fieldlist_head)) then
820	if (.not. is_mask_field(name_cursor%fieldlist_head%fg_data)) then
821	nheaders = nheaders + 1
822	call dup(name_cursor%fieldlist_head%fg_data, header_list(nheaders))
823	end if
824	end if
825	name_cursor => name_cursor%next
826	end do
827
828	end subroutine storage_get_all_headers
829
830
831	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
832	! Name: storage_get_all_td_headers
833	!
834	! Purpose:
835	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
836	subroutine storage_get_td_headers(header_list)
837
838	implicit none
839
840	! Arguments
841	type (fg_input), pointer, dimension(:) :: header_list
842
843	! Local variables
844	integer :: nheaders
845	type (head_node), pointer :: name_cursor
846	type (data_node), pointer :: data_cursor
847
848	nullify(header_list)
849
850	! First find out how many time-dependent headers there are
851	name_cursor => head
852	nheaders = 0
853	do while (associated(name_cursor))
854	if (associated(name_cursor%fieldlist_head)) then
855	if (is_time_dependent(name_cursor%fieldlist_head%fg_data) .and. &
856	.not. is_mask_field(name_cursor%fieldlist_head%fg_data)) then
857	nheaders = nheaders + 1
858	end if
859	end if
860	name_cursor => name_cursor%next
861	end do
862
863	allocate(header_list(nheaders))
864
865	name_cursor => head
866	nheaders = 0
867	do while (associated(name_cursor))
868	if (associated(name_cursor%fieldlist_head)) then
869	if (is_time_dependent(name_cursor%fieldlist_head%fg_data) .and. &
870	.not. is_mask_field(name_cursor%fieldlist_head%fg_data)) then
871	nheaders = nheaders + 1
872	call dup(name_cursor%fieldlist_head%fg_data, header_list(nheaders))
873	end if
874	end if
875	name_cursor => name_cursor%next
876	end do
877
878	end subroutine storage_get_td_headers
879
880
881	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
882	! Name: storage_print_headers
883	!
884	! Purpose:
885	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
886	subroutine storage_print_headers()
887
888	implicit none
889
890	! Local variables
891	type (head_node), pointer :: name_cursor
892	type (data_node), pointer :: data_cursor
893
894	call mprintf(.true.,DEBUG,'>>>> STORED FIELDS <<<<')
895	call mprintf(.true.,DEBUG,'=======================')
896
897	! We'll first see if there is already a list for this fieldname
898	name_cursor => head
899	do while (associated(name_cursor))
900	call print_header(name_cursor%fg_data)
901
902	if (associated(name_cursor%fieldlist_head)) then
903	data_cursor => name_cursor%fieldlist_head
904	do while ( associated(data_cursor) )
905	call mprintf(.true.,DEBUG,' - %i', i1=get_level(data_cursor%fg_data))
906	call mprintf(.true.,DEBUG,' ')
907	data_cursor => data_cursor%next
908	end do
909	end if
910
911	name_cursor => name_cursor%next
912	end do
913
914	end subroutine storage_print_headers
915
916	end module storage_module

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

Download in other formats:

Original Format