Soil Water Balance (SWB2)
Loading...
Searching...
No Matches
parameters.F90
Go to the documentation of this file.
2
3 use iso_c_binding, only : c_int, c_float, c_double, c_bool
4 use datetime, only : datetime_t
5 use exceptions
7 use logfiles
8 use fstring
10 use dictionary
12 implicit none
13
14 private
15
16 !! module to provide a single POC for storage and retrieval of parameter scalars and vectors
17 !! need to provide a method for storing, finding, and retrieving parameters.
18 !! dictionary: keyword, string_list
19
20 !! first create list of files. parse through each file, adding to the param dictionary.
21 !! once complete, allow other modules to interrogate the dictionary. return matches in the
22 !! data type required for the parameter. once all params are in place, the data structures can be
23 !! deallocated.
24
25 type, public :: parameters_t
26
27 type (fstring_list_t) :: filenames
28 type (fstring_list_t) :: delimiters
29 type (fstring_list_t) :: comment_chars
30 integer (c_int) :: count = 0
31
32 contains
33
35 generic :: add_file => add_filename_to_list_sub
36
38 generic :: add_parameters => add_to_param_list_sub
39
42
48
49 generic :: get_parameters => get_parameter_values_int, &
54
55 procedure :: grep_name => grep_parameter_name
56
57
58 ! other functionality:
59 ! * retrieve parameter list:
60 ! 1) input = single string
61 ! 2) input = string list
62 ! * basic error checking re: number of params in list
63
64
65
66 end type parameters_t
67
68 type (parameters_t), public :: params
69 type (dict_t), public :: params_dict
70
71 integer (c_int), parameter :: max_table_record_len = 2048
72
73contains
74
75 subroutine add_filename_to_list_sub( this, sFilename, sDelimiters, sCommentChars )
76
77 class(parameters_t) :: this
78 character (len=*), intent(in) :: sFilename
79 character (len=*), intent(in), optional :: sDelimiters
80 character (len=*), intent(in), optional :: sCommentChars
81
82 ! [ LOCALS ]
83 character (len=:), allocatable :: sDelimiters_
84 character (len=:), allocatable :: sCommentChars_
85
86 if ( present(scommentchars) ) then
87 scommentchars_ = scommentchars
88 else
89 scommentchars_ = comment_characters
90 endif
91
92 if (present(sdelimiters) ) then
93 sdelimiters_ = sdelimiters
94 else
95 sdelimiters_ = tab
96 endif
97
98 this%count = this%count + 1
99
100 call this%filenames%append( sfilename )
101 call this%delimiters%append( sdelimiters_ )
102 call this%comment_chars%append( scommentchars_ )
103
104 end subroutine add_filename_to_list_sub
105
106!--------------------------------------------------------------------------------------------------
107
108 subroutine munge_files_and_add_to_param_list_sub(this, comment_chars, delimiters)
109
110 class(parameters_t) :: this
111 character (len=*), intent(in), optional :: comment_chars
112 character (len=*), intent(in), optional :: delimiters
113
114 ! [ LOCALS ]
115 integer (c_int) :: iFileIndex, iColIndex
116 integer (c_int) :: iStat
117 type (ASCII_FILE_T), allocatable :: DF
118 type (DICT_ENTRY_T), pointer :: pDict
119 type (DICT_ENTRY_T), pointer :: pCurrentDict
120 character (len=256) :: column_name
121 character (len=256) :: filename1
122 character (len=:), allocatable :: comment_chars_
123 character (len=:), allocatable :: delimiters_
124 logical (c_bool), allocatable :: skip_this_column(:)
125 type (FSTRING_LIST_T) :: unique_file_list
126 integer (kind=c_int) :: row_indx
127 integer (c_int) :: number_of_columns
128 character (len=MAX_TABLE_RECORD_LEN) :: sRecord, sItem
129
130 ! Duplicate column verification
131 type (FSTRING_LIST_T), allocatable :: duplicate_column_data(:)
132 type (FSTRING_LIST_T) :: existing_values
133 character (len=:), allocatable :: existing_val, duplicate_val
134 integer (c_int) :: iVerify
135
136 allocate(df)
137
138 if ( present(comment_chars) ) then
139 comment_chars_ = trim(comment_chars)
140 else
141 comment_chars_ = comment_characters
142 endif
143
144 if ( present(delimiters) ) then
145 delimiters_ = trim(delimiters)
146 else
147 delimiters_ = tab
148 endif
149
150 !
151 ! proper way to screen for duplicate filenames is further down in loop
152 !
153 !unique_file_list = this%filenames%unique()
154 !if ( unique_file_list%get(1) .ne. '<NA>' ) then
155
156 if ( this%filenames%get(1) .ne. '<NA>' ) then
157
158 do ifileindex = 1, this%filenames%count
159
160 filename1 = this%filenames%get(ifileindex)
161
162 ! if this filename has already been seen and processed, ignore and move on to next filename
163 if ( unique_file_list%count_matching(filename1) > 0 ) cycle
164
165 call unique_file_list%append(filename1)
166
167 ! open the file associated with current file index value
168 call df%open(sfilename = filename1, &
169 scommentchars = comment_chars_, &
170 sdelimiters = delimiters_ )
171
172 ! obtain the headers from the file
173 df%slColNames = df%readHeader()
174
175 number_of_columns = df%slColNames%count
176
177 call logs%write( "Number of columns in file: "//ascharacter( number_of_columns ), itab=35)
178
179 !call DF%slColNames%print()
180
181 if (allocated(skip_this_column)) deallocate(skip_this_column)
182 allocate(skip_this_column(number_of_columns))
183 skip_this_column = false
184
185 if (allocated(duplicate_column_data)) deallocate(duplicate_column_data)
186 allocate(duplicate_column_data(number_of_columns))
187
188 ! loop over each column header
189 do icolindex = 1, df%slColNames%count
190
191 column_name = df%slColNames%get(icolindex)
192
193 if ( params_dict%key_already_in_use( column_name ) ) then
194
195 skip_this_column( icolindex ) = true
196
197 call logs%write("Column name "//squote(column_name)//" already in use." &
198 //" Values will be verified for consistency." &
199 //" [filename = "//squote(filename1)//"]")
200
201 ! Dec 2019: let try eliminating duplicates from the dictionary altogether
202
203 ! ! add dictionary entry to dictionary, tack "DUP" on end of name
204 ! tempstr = trim(adjustl(tempstr))//"_DUP"
205 ! ! update the string list to reflect duplicate entry
206
207 ! call DF%slColNames%replace( iColIndex, tempstr )
208 ! call pDict%add_key( asUppercase( tempstr ) )
209 ! call PARAMS_DICT%add_entry( pDict )
210
211 else
212
213 ! create and allocate memory for dictionary entry
214 pdict => null()
215 allocate( pdict, stat=istat )
216 call assert(istat == 0, "Failed to allocate memory for dictionary object", &
217 __file__, __line__ )
218
219 ! first add the key to the dictionary entry,
220 ! then add dictionary entry to dictionary
221 call pdict%add_key( column_name )
222 call params_dict%add_entry( pdict )
223
224 endif
225
226 enddo
227
228 row_indx = 0
229
230 ! now read in the remainder of the file
231 do while ( .not. df%isEOF() )
232
233 ! read in next line of file
234 srecord = df%readLine()
235
236 ! skip blank lines
237 if ( len_trim(srecord) == 0 ) cycle
238
239 row_indx = row_indx + 1
240
241 ! loop over each column header
242 do icolindex = 1, df%slColNames%count
243
244 ! break off next column of data for the current record
245 call chomp(srecord, sitem, this%delimiters%get(ifileindex) )
246
247 if ( skip_this_column(icolindex) ) then
248 ! Store data from duplicate columns for post-read verification
249 call duplicate_column_data(icolindex)%append(trim(adjustl(sitem)))
250 cycle
251 end if
252
253 column_name = df%slColNames%get(icolindex)
254
255 ! find pointer associated with header name
256 ! (inefficient, but should be OK for small # of columns)
257 pcurrentdict => params_dict%get_entry( column_name )
258
259 if ( associated( pcurrentdict )) then
260
261 ! if not null, it means that we were able to return a pointer
262 ! associated with the current column heading
263 call pcurrentdict%add_value( sitem )
264
265 else
266
267 call warn("Internal programming error: null pointer detected" &
268 //" -- was trying to find pointer associated with column "//dquote(df%slColNames%get(icolindex)), &
269 __file__, __line__)
270
271 endif
272
273 enddo
274
275 enddo
276
277 ! --- Verify duplicate columns match previously loaded values ---
278 do icolindex = 1, number_of_columns
279 if (.not. skip_this_column(icolindex)) cycle
280 if (duplicate_column_data(icolindex)%count == 0) cycle
281
282 column_name = df%slColNames%get(icolindex)
283
284 ! Retrieve the existing values for this key
285 call params_dict%get_values(skey=column_name, slstring=existing_values)
286
287 ! Check length match
288 if (existing_values%count /= duplicate_column_data(icolindex)%count) then
289 call warn("Duplicate column "//squote(column_name)//" in file " &
290 //squote(filename1)//" has " &
291 //ascharacter(duplicate_column_data(icolindex)%count) &
292 //" entries, but the previously loaded column has " &
293 //ascharacter(existing_values%count)//" entries." &
294 //" All lookup tables must have the same number of rows.", &
295 lfatal=true)
296 end if
297
298 ! Check value-by-value match
299 do iverify = 1, existing_values%count
300 existing_val = trim(existing_values%get(iverify))
301 duplicate_val = trim(duplicate_column_data(icolindex)%get(iverify))
302 if (.not. (existing_val .strapprox. duplicate_val)) then
303 if (column_name .strapprox. "LU_CODE") then
304 call warn("LU_CODE mismatch at row " &
305 //ascharacter(iverify)//": previously loaded value = " &
306 //squote(existing_val)//", value in " &
307 //squote(filename1)//" = "//squote(duplicate_val) &
308 //". LU_CODE must appear in the same order across all" &
309 //" lookup tables. All other columns from this file" &
310 //" may be misaligned.", &
311 lfatal=true)
312 else
313 call warn("Duplicate column "//squote(column_name) &
314 //" mismatch at row "//ascharacter(iverify) &
315 //": previously loaded = "//squote(existing_val) &
316 //", value in "//squote(filename1)//" = " &
317 //squote(duplicate_val)//". Values must be identical.", &
318 lfatal=true)
319 end if
320 end if
321 end do
322
323 end do
324
325 deallocate(skip_this_column)
326 deallocate(duplicate_column_data)
327
328 call df%close()
329
330 enddo
331
332 endif
333
335
336!--------------------------------------------------------------------------------------------------
337
338 subroutine add_to_param_list_sub(this, sKey, sValues, iValues, fValues, dValues, lValues)
339
340 class(parameters_t) :: this
341 character (len=*), intent(in) :: sKey
342 character (len=*), intent(in), optional :: sValues(:)
343 integer (c_int), intent(in), optional :: iValues(:)
344 real (c_float), intent(in), optional :: fValues(:)
345 real (c_double), intent(in), optional :: dValues(:)
346 logical (c_bool), intent(in), optional :: lValues(:)
347
348 ! [ LOCALS ]
349 integer (c_int) :: iStat
350 integer (c_int) :: iIndex
351 type (DICT_ENTRY_T), pointer :: pCurrentDict
352
353
354 pcurrentdict => null()
355 pcurrentdict => params_dict%get_entry( skey )
356
357 if ( .not. associated( pcurrentdict )) then
358
359 ! if key does not currently exist, make a new entry with this key value
360 allocate( pcurrentdict, stat=istat )
361
362 call assert(istat == 0, "Failed to allocate memory for dictionary object", &
363 __file__, __line__ )
364
365 ! add dictionary entry to dictionary
366 call pcurrentdict%add_key( skey )
367 call params_dict%add_entry( pcurrentdict )
368
369 endif
370
371 if ( present( svalues ) ) then
372
373 do iindex = lbound(svalues,1), ubound(svalues,1)
374
375 call pcurrentdict%add_value( svalues( iindex ) )
376
377 enddo
378
379 else if ( present ( ivalues ) ) then
380
381 do iindex = lbound(ivalues,1), ubound(ivalues,1)
382
383 call pcurrentdict%add_value( ivalues( iindex ) )
384
385 enddo
386
387 else if ( present ( fvalues ) ) then
388
389 do iindex = lbound(fvalues,1), ubound(fvalues,1)
390
391 call pcurrentdict%add_value( fvalues( iindex ) )
392
393 enddo
394
395 else if ( present ( dvalues ) ) then
396
397 do iindex = lbound(dvalues,1), ubound(dvalues,1)
398
399 call pcurrentdict%add_value( dvalues( iindex ) )
400
401 enddo
402
403 else if ( present ( lvalues ) ) then
404
405 do iindex = lbound(lvalues,1), ubound(lvalues,1)
406
407 call pcurrentdict%add_value( lvalues( iindex ) )
408
409 enddo
410
411 endif
412
413 end subroutine add_to_param_list_sub
414
415!--------------------------------------------------------------------------------------------------
416
417 function grep_parameter_name( this, sKey, lFatal ) result( slList )
418
419 class(parameters_t) :: this
420 character (len=*), intent(in) :: skey
421 logical (c_bool), intent(in), optional :: lfatal
422 type ( fstring_list_t ) :: sllist
423
424 ! [ LOCALS ]
425 logical (c_bool) :: lfatal_l
426
427 if ( present (lfatal) ) then
428 lfatal_l = lfatal
429 else
430 lfatal_l = false
431 endif
432
433 sllist = params_dict%grep_keys( asuppercase( skey ) )
434
435 if ( lfatal_l ) then
436
437 if ( sllist%get(1) .strequal. "<NA>" ) &
438 call warn( "Failed to find a lookup table column whose name contains " &
439 //dquote( skey )//".", lfatal = lfatal_l )
440
441 endif
442
443 end function grep_parameter_name
444
445!--------------------------------------------------------------------------------------------------
446
447 subroutine get_parameter_values_logical( this, lValues, slKeys, sKey, lFatal )
448
449 class(parameters_t) :: this
450 logical (c_bool), intent(in out), allocatable :: lValues(:)
451 type (FSTRING_LIST_T), intent(in out), optional :: slKeys
452 character (len=*), intent(in ), optional :: sKey
453 logical (c_bool), intent(in), optional :: lFatal
454
455 ! [ LOCALS ]
456 logical (c_bool) :: lFatal_l
457
458 if ( present (lfatal) ) then
459 lfatal_l = lfatal
460 else
461 lfatal_l = false
462 endif
463
464 if ( present( slkeys) ) then
465
466 call params_dict%get_values( slkeys=slkeys, lvalues=lvalues, &
467 is_fatal=lfatal_l )
468
469! if ( any( iValues <= iTINYVAL ) ) &
470! call warn( "Failed to find a lookup table column named " &
471! //dQuote( slKeys%list_all() )//".", lFatal = lFatal_l )
472
473 else if ( present( skey) ) then
474
475 call params_dict%get_values( skey=skey, lvalues=lvalues )
476
477! if ( any( iValues <= iTINYVAL ) ) &
478! call warn( "Failed to find a lookup table column named " &
479! //dQuote( sKey )//".", lFatal = lFatal_l )
480
481 endif
482
483 end subroutine get_parameter_values_logical
484
485!--------------------------------------------------------------------------------------------------
486
487 subroutine get_parameter_values_datetime( this, dtValues, slKeys, sKey, lFatal )
488
489 class(parameters_t) :: this
490 type (DATETIME_T), intent(in out), allocatable :: dtValues(:)
491 type (FSTRING_LIST_T), intent(in out), optional :: slKeys
492 character (len=*), intent(in ), optional :: sKey
493 logical (c_bool), intent(in), optional :: lFatal
494
495 ! [ LOCALS ]
496 logical (c_bool) :: lFatal_l
497 type (FSTRING_LIST_T) :: slValues
498 integer (c_int) :: n
499 integer (c_int) :: istat
500
501 if ( present (lfatal) ) then
502 lfatal_l = lfatal
503 else
504 lfatal_l = false
505 endif
506
507 if ( present( slkeys) ) then
508
509 call params_dict%get_values( slkeys=slkeys, slstring=slvalues, is_fatal=lfatal_l )
510
511 else if ( present( skey) ) then
512
513 call params_dict%get_values( skey=skey, slstring=slvalues )
514
515 endif
516
517 allocate(dtvalues(slvalues%count), stat=istat)
518
519 do n=1, slvalues%count
520 call dtvalues(n)%parseDate(slvalues%get(n))
521 enddo
522
523 end subroutine get_parameter_values_datetime
524
525 !--------------------------------------------------------------------------------------------------
526
527 subroutine get_parameter_values_string_list( this, slValues, slKeys, sKey, lFatal )
528
529 class(parameters_t) :: this
530 type (FSTRING_LIST_T), intent(out) :: slValues
531 type (FSTRING_LIST_T), intent(inout), optional :: slKeys
532 character (len=*), intent(in ), optional :: sKey
533 logical (c_bool), intent(in), optional :: lFatal
534
535 ! [ LOCALS ]
536 logical (c_bool) :: lFatal_l
537
538 if ( present (lfatal) ) then
539 lfatal_l = lfatal
540 else
541 lfatal_l = false
542 endif
543
544 if ( present( slkeys) ) then
545
546 call params_dict%get_values( slkeys=slkeys, slstring=slvalues, &
547 is_fatal=lfatal_l )
548
549 if ( slvalues%get(1) .strequal. "<NA>" ) then
550 call warn( "Failed to find a lookup table column named " &
551 //dquote( slkeys%list_all() )//".", lfatal = lfatal_l )
552 end if
553
554 else if ( present( skey) ) then
555
556 call params_dict%get_values( skey=skey, slstring=slvalues )
557
558 if ( slvalues%get(1) .strequal. "<NA>" ) then
559 call warn( "Failed to find a lookup table column named " &
560 //dquote( skey )//".", lfatal = lfatal_l )
561 end if
562
563 endif
564
566
567!--------------------------------------------------------------------------------------------------
568
569 subroutine get_parameter_values_int( this, iValues, slKeys, sKey, lFatal )
570
571 class(parameters_t) :: this
572 integer (c_int), intent(out), allocatable :: iValues(:)
573 type (FSTRING_LIST_T), intent(in out), optional :: slKeys
574 character (len=*), intent(in ), optional :: sKey
575 logical (c_bool), intent(in), optional :: lFatal
576
577 ! [ LOCALS ]
578 logical (c_bool) :: lFatal_l
579
580 if ( present (lfatal) ) then
581 lfatal_l = lfatal
582 else
583 lfatal_l = false
584 endif
585
586 if ( present( slkeys) ) then
587
588 call params_dict%get_values( slkeys=slkeys, ivalues=ivalues, &
589 is_fatal=lfatal_l )
590
591 if ( any( ivalues <= itinyval ) ) &
592 call warn( "Failed to find a lookup table column named " &
593 //dquote( slkeys%list_all() )//".", lfatal = lfatal_l )
594
595 else if ( present( skey) ) then
596
597 call params_dict%get_values( skey=skey, ivalues=ivalues, &
598 is_fatal=lfatal_l )
599
600 if ( any( ivalues <= itinyval ) ) &
601 call warn( "Failed to find a lookup table column named " &
602 //dquote( skey )//".", lfatal = lfatal_l )
603
604 endif
605
606 end subroutine get_parameter_values_int
607
608!--------------------------------------------------------------------------------------------------
609
610 subroutine get_parameter_values_float( this, fValues, slKeys, sKey, lFatal )
611
612 class(parameters_t) :: this
613 real (c_float), intent(in out), allocatable :: fValues(:)
614 type (FSTRING_LIST_T), intent(in out), optional :: slKeys
615 character (len=*), intent(in ), optional :: sKey
616 logical (c_bool), intent(in), optional :: lFatal
617
618 ! [ LOCALS ]
619 logical (c_bool) :: lFatal_l
620
621 if ( present (lfatal) ) then
622 lfatal_l = lfatal
623 else
624 lfatal_l = false
625 endif
626
627 if ( present( slkeys) ) then
628
629 call params_dict%get_values( slkeys=slkeys, fvalues=fvalues )
630
631 if ( any( fvalues <= ftinyval ) ) &
632 call warn( "Failed to find a lookup table column named " &
633 //dquote( slkeys%list_all() )//".", lfatal = lfatal_l )
634
635 else if ( present( skey) ) then
636
637 call params_dict%get_values( skey=skey, fvalues=fvalues, &
638 is_fatal=lfatal_l )
639
640 if ( any( fvalues <= ftinyval ) ) &
641 call warn( "Failed to find a lookup table column named " &
642 //dquote( skey )//".", lfatal = lfatal_l )
643
644 endif
645
646 end subroutine get_parameter_values_float
647
648!--------------------------------------------------------------------------------------------------
649
650 subroutine get_parameter_table_float( this, fValues, sPrefix, iNumRows, lFatal )
651
652 use fstring
653
654 class(parameters_t) :: this
655 real (c_float), intent(in out), allocatable :: fValues(:,:)
656 character (len=*), intent(in) :: sPrefix
657 integer (c_int), intent(in) :: iNumRows
658 logical (c_bool), intent(in), optional :: lFatal
659
660 ! [ LOCALS ]
661 integer (c_int) :: iIndex
662 integer (c_int) :: iStat
663 character (len=256) :: sText
664 integer (c_int) :: iNumCols
665 type (FSTRING_LIST_T) :: slList
666 real (c_float), allocatable :: fTempVal(:)
667 logical (c_bool) :: lFatal_l
668
669 if ( present (lfatal) ) then
670 lfatal_l = lfatal
671 else
672 lfatal_l = false
673 endif
674
675 sllist = params%grep_name( sprefix )
676
677 inumcols = sllist%count
678
679 if ( inumcols == 0 ) then
680
681 call warn( "Failed to find a lookup table column named " &
682 //dquote( sprefix )//".", lfatal = lfatal_l )
683
684 else
685
686 allocate( ftempval( inumrows ), stat=istat )
687 call assert( istat == 0, "Problem allocating memory.", __file__, __line__ )
688
689 allocate( fvalues( inumrows, inumcols ), stat=istat )
690 call assert( istat == 0, "Problem allocating memory." &
691 //"~iNumCols: "//ascharacter(inumcols)//"; iNumRows: "//ascharacter(inumrows) &
692 //" sPrefix: "//dquote(sprefix), __file__, __line__ )
693
694 do iindex = 1, inumcols
695
696 stext = trim( sllist%get( iindex ) )
697 call params_dict%get_values( skey=stext, fvalues=ftempval, &
698 is_fatal=lfatal_l )
699
700 call assert( size( ftempval, 1) == size( fvalues, 1), &
701 "Mismatch in array size. Dictionary key: "//squote( stext ) &
702 //" expected size: "//ascharacter( size( fvalues, 1) ) &
703 //" size of items in dictionary: " &
704 //ascharacter( size( ftempval, 1) ) )
705
706 fvalues(:,iindex) = ftempval
707 enddo
708
709 endif
710
711 end subroutine get_parameter_table_float
712
713end module parameters
This module contains physical constants and convenience functions aimed at performing unit conversion...
logical(c_bool), parameter, public true
logical(c_bool), parameter, public false
integer(c_int), parameter, public itinyval
This module contains the DATETIME_T class and associated time and date-related routines,...
Definition datetime.F90:9
subroutine, public warn(smessage, smodule, iline, shints, lfatal, iloglevel, lecho)
character(len=1), parameter, public tab
Definition fstring.F90:167
character(len=3), parameter, public comment_characters
Definition fstring.F90:172
type(logfile_t), public logs
Definition logfiles.F90:62
subroutine get_parameter_values_logical(this, lvalues, slkeys, skey, lfatal)
type(parameters_t), public params
subroutine get_parameter_table_float(this, fvalues, sprefix, inumrows, lfatal)
subroutine add_to_param_list_sub(this, skey, svalues, ivalues, fvalues, dvalues, lvalues)
subroutine munge_files_and_add_to_param_list_sub(this, comment_chars, delimiters)
type(dict_t), public params_dict
subroutine get_parameter_values_string_list(this, slvalues, slkeys, skey, lfatal)
integer(c_int), parameter max_table_record_len
type(fstring_list_t) function grep_parameter_name(this, skey, lfatal)
subroutine get_parameter_values_int(this, ivalues, slkeys, skey, lfatal)
subroutine get_parameter_values_datetime(this, dtvalues, slkeys, skey, lfatal)
subroutine add_filename_to_list_sub(this, sfilename, sdelimiters, scommentchars)
subroutine get_parameter_values_float(this, fvalues, slkeys, skey, lfatal)