dataset_ascii.F90 coverage: 90.00 %func 79.15 %block
1) module Dataset_Ascii_class
2)
3) use Dataset_Base_class
4)
5) use PFLOTRAN_Constants_module
6)
7) implicit none
8)
9) private
10)
11) #include "petsc/finclude/petscsys.h"
12)
13) type, public, extends(dataset_base_type) :: dataset_ascii_type
14) PetscInt :: array_width
15) end type dataset_ascii_type
16)
17) interface DatasetAsciiRead
18) module procedure DatasetAsciiOpenAndLoad
19) module procedure DatasetAsciiLoad
20) end interface
21)
22) public :: DatasetAsciiCreate, &
23) DatasetAsciiInit, &
24) DatasetAsciiVerify, &
25) DatasetAsciiCast, &
26) DatasetAsciiRead, &
27) DatasetAsciiUpdate, &
28) DatasetAsciiPrint, &
29) DatasetAsciiDestroy
30)
31) contains
32)
33) ! ************************************************************************** !
34)
35) function DatasetAsciiCreate()
36) !
37) ! Creates ascii dataset class
38) !
39) ! Author: Glenn Hammond
40) ! Date: 10/03/13
41) !
42)
43) implicit none
44)
45) class(dataset_ascii_type), pointer :: dataset
46)
47) class(dataset_ascii_type), pointer :: DatasetAsciiCreate
48)
49) allocate(dataset)
50) call DatasetAsciiInit(dataset)
51)
52) DatasetAsciiCreate => dataset
53)
54) end function DatasetAsciiCreate
55)
56) ! ************************************************************************** !
57)
58) function DatasetAsciiCast(this)
59) !
60) ! Casts a dataset_base_type to database_ascii_type
61) !
62) ! Author: Glenn Hammond
63) ! Date: 10/03/13
64) !
65)
66) use Dataset_Base_class
67)
68) implicit none
69)
70) class(dataset_base_type), pointer :: this
71)
72) class(dataset_ascii_type), pointer :: DatasetAsciiCast
73)
74) nullify(DatasetAsciiCast)
75) if (.not.associated(this)) return
76) select type (this)
77) class is (dataset_ascii_type)
78) DatasetAsciiCast => this
79) class default
80) !geh: have default here to pass a null pointer if not of type ascii
81) end select
82)
83) end function DatasetAsciiCast
84)
85) ! ************************************************************************** !
86)
87) subroutine DatasetAsciiInit(this)
88) !
89) ! Initializes members of ascii dataset class
90) !
91) ! Author: Glenn Hammond
92) ! Date: 10/03/13
93) !
94)
95) implicit none
96)
97) class(dataset_ascii_type) :: this
98)
99) call DatasetBaseInit(this)
100) this%array_width = 0
101)
102) end subroutine DatasetAsciiInit
103)
104) ! ************************************************************************** !
105)
106) subroutine DatasetAsciiOpenandLoad(this,filename,data_units_category,option)
107) !
108) ! Opens a file and calls the load routine.
109) !
110) ! Author: Glenn Hammond
111) ! Date: 10/03/13
112) !
113)
114) use Input_Aux_module
115) use Option_module
116)
117) implicit none
118)
119) class(dataset_ascii_type) :: this
120) character(len=MAXSTRINGLENGTH) :: filename
121) character(len=MAXSTRINGLENGTH) :: data_units_category
122) type(option_type) :: option
123)
124) type(input_type), pointer :: input
125)
126) input => InputCreate(IUNIT_TEMP,filename,option)
127) call DatasetAsciiLoad(this,input,data_units_category,option)
128) call InputDestroy(input)
129)
130) end subroutine DatasetAsciiOpenandLoad
131)
132) ! ************************************************************************** !
133)
134) subroutine DatasetAsciiLoad(this,input,data_internal_units,option)
135) !
136) ! Reads a text-based dataset from an ASCII file.
137) !
138) ! Author: Glenn Hammond
139) ! Date: 10/03/13
140) !
141)
142) use Input_Aux_module
143) use String_module
144) use Utility_module, only : reallocateRealArray
145) use Option_module
146) use Units_module, only : UnitsConvertToInternal
147) use Time_Storage_module
148)
149) implicit none
150)
151) class(dataset_ascii_type) :: this
152) type(input_type), pointer :: input
153) character(len=*) :: data_internal_units
154) type(option_type) :: option
155)
156) character(len=MAXWORDLENGTH) :: time_units
157) character(len=MAXSTRINGLENGTH) :: string, data_units
158) character(len=MAXSTRINGLENGTH), pointer :: internal_unit_strings(:)
159) character(len=MAXWORDLENGTH) :: word, internal_units
160) PetscReal, pointer :: temp_array(:,:)
161) PetscReal :: temp_time
162) PetscReal :: conversion
163) PetscInt :: max_size, offset
164) PetscInt :: row_count, column_count, data_count, i, k
165) PetscInt :: default_interpolation_method
166) PetscBool :: force_units_for_all_data
167) PetscErrorCode :: ierr
168)
169) time_units = ''
170) data_units = ''
171) max_size = 1000
172)
173) internal_unit_strings => StringSplit(data_internal_units,',')
174)
175) row_count = 0
176) ierr = 0
177) k = 0
178) default_interpolation_method = INTERPOLATION_NULL
179) do
180) call InputReadPflotranString(input,option)
181) ! reach the end of file or close out block
182) if (InputError(input)) exit ! check for end of file
183) if (InputCheckExit(input,option)) exit ! check for end of list
184) ! check for units on first or second line
185) if (row_count == 0) then
186) string = input%buf
187) ierr = 0
188) call InputReadWord(string,word,PETSC_TRUE,ierr)
189) call InputErrorMsg(input,option,'KEYWORD','CONDITION (LIST or FILE)')
190) call StringToUpper(word)
191) select case(word)
192) case('HEADER')
193) call InputReadWord(string,word,PETSC_TRUE,ierr)
194) call InputErrorMsg(input,option,'header','CONDITION (LIST or FILE)')
195) this%header = trim(input%buf)
196) cycle
197) case('TIME_UNITS')
198) call InputReadWord(string,time_units,PETSC_TRUE,ierr)
199) input%ierr = ierr
200) call InputErrorMsg(input,option,'TIME_UNITS', &
201) 'CONDITION (LIST or FILE)')
202) cycle
203) case('INTERPOLATION')
204) call InputReadWord(string,word,PETSC_TRUE,ierr)
205) input%ierr = ierr
206) call InputErrorMsg(input,option,'INTERPOLATION','CONDITION')
207) call StringToUpper(word)
208) select case(word)
209) case('STEP')
210) default_interpolation_method = INTERPOLATION_STEP
211) case('LINEAR')
212) default_interpolation_method = INTERPOLATION_LINEAR
213) case default
214) call InputKeywordUnrecognized(word,'CONDITION,INTERPOLATION', &
215) option)
216) end select
217) cycle
218) case('DATA_UNITS')
219) ! it is possible to have more than one data unit. therefore, read the
220) ! entire string
221) data_units = adjustl(string)
222) if (len_trim(data_units) < 1) then
223) call InputErrorMsg(input,option,'DATA_UNITS', &
224) 'CONDITION (LIST or FILE)')
225) endif
226) cycle
227) case default
228) ! copy the first row of actual data and count up the number of
229) ! columns.
230) string = input%buf
231) column_count = 0
232) do
233) ierr = 0
234) call InputReadWord(string,word,PETSC_TRUE,ierr)
235) if (ierr /= 0) exit
236) column_count = column_count + 1
237) enddo
238) ! allocate the 2d array to max_size rows and col_count columns.
239) allocate(temp_array(column_count,max_size))
240) temp_array = 0.d0
241) ! do not cycle, as we now need to proceed.
242) end select
243) endif
244)
245) row_count = row_count + 1
246)
247) ! read columns of data, including the time in the first column
248) do i = 1, column_count
249) call InputReadDouble(input,option,temp_array(i,row_count))
250) call InputErrorMsg(input,option,'column data','ascii dataset file')
251) enddo
252)
253) ! enlarge the array as needed.
254) if (row_count+1 > max_size) then
255) call reallocateRealArray(temp_array,max_size)
256) endif
257) enddo
258)
259) if (row_count == 0) then
260) option%io_buffer = 'No values provided in Ascii Dataset.'
261) call printErrMsg(option)
262) endif
263)
264) this%data_type = DATASET_REAL
265) this%rank = 2
266) allocate(this%dims(this%rank))
267) data_count = column_count - 1 ! subtract 1 for time column
268) this%dims(1) = data_count
269) this%dims(2) = row_count
270) this%time_storage => TimeStorageCreate()
271) this%time_storage%max_time_index = row_count
272) allocate(this%time_storage%times(row_count))
273) this%time_storage%times = temp_array(1,1:row_count)
274) allocate(this%rbuffer(data_count*row_count))
275) this%rbuffer = 0.d0 ! we copy after units conversion for efficiency sake
276)
277) ! time units conversion
278) if (len_trim(time_units) > 0) then
279) internal_units = 'sec'
280) conversion = UnitsConvertToInternal(time_units,internal_units,option)
281) this%time_storage%times(:) = conversion * &
282) this%time_storage%times(:)
283) endif
284) ! data units conversion
285) if (len_trim(data_units) > 0) then
286) ! set flag to determine whether we check for data units for each
287) ! data column. if only one data unit is provided, it is applied
288) ! to all columns by default. otherwise, data units must be defined
289) ! for each column - geh.
290) force_units_for_all_data = PETSC_FALSE
291) do i = 1, data_count ! number of data columns
292) if (len_trim(data_units) > 0 .or. force_units_for_all_data) then
293) ! the conditional immediately below will force 'conversion' to be
294) ! calculated for each column. if a unit does not exist, the input
295) ! error below will be spawned.
296) if (i > 1) force_units_for_all_data = PETSC_TRUE
297) ierr = 0
298) call InputReadWord(data_units,word,PETSC_TRUE,ierr)
299) input%ierr = ierr
300) call InputErrorMsg(input,option,'DATA_UNITS','CONDITION FILE')
301) conversion = UnitsConvertToInternal(word,internal_unit_strings(i), &
302) option)
303) endif
304) temp_array(i+1,:) = conversion * temp_array(i+1,:)
305) enddo
306) deallocate(internal_unit_strings)
307) nullify(internal_unit_strings)
308) else
309) call InputCheckMandatoryUnits(input,option)
310) endif
311)
312) ! now that the data units conversion has taken place with temp_array, copy
313) ! over to rbuffer.
314) offset = 0
315) do i = 1, row_count
316) this%rbuffer(offset + 1:offset + data_count) = &
317) temp_array(2:column_count,i)
318) offset = offset + data_count
319) enddo
320)
321) deallocate(temp_array)
322) nullify(temp_array)
323)
324) if (this%array_width > 0) then
325) if (this%array_width /= data_count) then
326) write(word,*) this%array_width
327) option%io_buffer = 'Inconsistency between dataset prescribed rank (' // &
328) trim(word) // ') and rank in file ('
329) write(word,*) data_count
330) option%io_buffer = trim(option%io_buffer) // trim(word) // ').'
331) call printErrMsg(option)
332) endif
333) else
334) this%array_width = data_count
335) endif
336)
337) if (default_interpolation_method /= INTERPOLATION_NULL) then
338) this%time_storage%time_interpolation_method = default_interpolation_method
339) endif
340)
341) end subroutine DatasetAsciiLoad
342)
343) ! ************************************************************************** !
344)
345) subroutine DatasetAsciiUpdate(this,option)
346) !
347) ! Updates an ascii dataset
348) !
349) ! Author: Glenn Hammond
350) ! Date: 10/08/13
351) !
352)
353) use Option_module
354) use Time_Storage_module
355)
356) implicit none
357)
358) class(dataset_ascii_type) :: this
359) type(option_type) :: option
360)
361) if (.not. associated(this%time_storage)) return
362)
363) call TimeStorageUpdate(this%time_storage)
364) call DatasetBaseInterpolateTime(this)
365)
366) end subroutine DatasetAsciiUpdate
367)
368) ! ************************************************************************** !
369)
370) subroutine DatasetAsciiVerify(this,option)
371) !
372) ! Verifies that data structure is properly set up.
373) !
374) ! Author: Glenn Hammond
375) ! Date: 10/08/13
376) !
377)
378) use Option_module
379)
380) implicit none
381)
382) class(dataset_ascii_type) :: this
383) type(option_type) :: option
384)
385) if (len_trim(this%name) < 1) then
386) this%name = 'Unnamed Ascii Dataset'
387) endif
388) call DatasetBaseVerify(this,option)
389) if (associated(this%rbuffer)) then
390) if (this%array_width /= this%dims(1)) then
391) option%io_buffer = &
392) '"array_width" is not equal to "dims(1)" in dataset: ' // &
393) trim(this%name)
394) call printErrMsg(option)
395) endif
396) ! set initial values
397) this%rarray(:) = this%rbuffer(1:this%array_width)
398) endif
399)
400) end subroutine DatasetAsciiVerify
401)
402) ! ************************************************************************** !
403)
404) subroutine DatasetAsciiPrint(this,option)
405) !
406) ! Prints dataset info
407) !
408) ! Author: Glenn Hammond
409) ! Date: 10/22/13
410) !
411)
412) use Option_module
413)
414) implicit none
415)
416) class(dataset_ascii_type) :: this
417) type(option_type) :: option
418)
419) write(option%fid_out,'(10x,''Array Rank: '',i2)') this%array_width
420)
421) end subroutine DatasetAsciiPrint
422)
423) ! ************************************************************************** !
424)
425) subroutine DatasetAsciiStrip(this)
426) !
427) ! Strips allocated objects within Ascii dataset object
428) !
429) ! Author: Glenn Hammond
430) ! Date: 10/03/13
431) !
432)
433) implicit none
434)
435) class(dataset_ascii_type) :: this
436)
437) call DatasetBaseStrip(this)
438)
439) end subroutine DatasetAsciiStrip
440)
441) ! ************************************************************************** !
442)
443) subroutine DatasetAsciiDestroy(this)
444) !
445) ! Destroys a dataset
446) !
447) ! Author: Glenn Hammond
448) ! Date: 10/03/13
449) !
450)
451) implicit none
452)
453) class(dataset_ascii_type), pointer :: this
454)
455) if (.not.associated(this)) return
456)
457) call DatasetAsciiStrip(this)
458)
459) deallocate(this)
460) nullify(this)
461)
462) end subroutine DatasetAsciiDestroy
463)
464) end module Dataset_Ascii_class