Afivo  0.3
m_config.f90
1 
5 module m_config
6 
7  implicit none
8  private
9 
11  integer, parameter :: dp = kind(0.0d0)
12 
13  integer, parameter :: cfg_num_types = 4
14  integer, parameter :: cfg_integer_type = 1
15  integer, parameter :: cfg_real_type = 2
16  integer, parameter :: cfg_string_type = 3
17  integer, parameter :: cfg_logic_type = 4
18  integer, parameter :: cfg_unknown_type = 0
19 
21  integer, parameter :: cfg_set_by_default = 1
23  integer, parameter :: cfg_set_by_arg = 2
25  integer, parameter :: cfg_set_by_file = 3
26 
28  character(len=10), parameter :: cfg_type_names(0:cfg_num_types) = &
29  [character(len=10) :: "storage", "integer", "real", "string ", "logical"]
30 
31  integer, parameter :: cfg_name_len = 80
32  integer, parameter :: cfg_string_len = 200
33 
35  integer, parameter :: cfg_max_array_size = 1000
36 
37  character, parameter :: tab_char = char(9)
38 
40  character(len=*), parameter :: cfg_separators = " ,'"""//tab_char
41 
43  character(len=*), parameter :: cfg_category_separator = "%"
44 
46  character(len=*), parameter :: unstored_data_string = "__UNSTORED_DATA_STRING"
47 
49  type cfg_var_t
50  private
52  character(len=CFG_name_len) :: var_name
54  character(len=CFG_string_len) :: description
56  integer :: var_type
58  integer :: var_size
60  logical :: dynamic_size
62  logical :: used
64  integer :: set_by = cfg_set_by_default
66  character(len=CFG_string_len) :: stored_data
67 
68  ! These are the arrays used for storage. In the future, a "pointer" based
69  ! approach could be used.
70  real(dp), allocatable :: real_data(:)
71  integer, allocatable :: int_data(:)
72  character(len=CFG_string_len), allocatable :: char_data(:)
73  logical, allocatable :: logic_data(:)
74  end type cfg_var_t
75 
77  type cfg_t
78  logical :: sorted = .false.
79  integer :: num_vars = 0
80  type(cfg_var_t), allocatable :: vars(:)
81  end type cfg_t
82 
84  interface cfg_add
85  module procedure add_real, add_real_array
86  module procedure add_int, add_int_array
87  module procedure add_string, add_string_array
88  module procedure add_logic, add_logic_array
89  end interface cfg_add
90 
92  interface cfg_get
93  module procedure get_real, get_real_array
94  module procedure get_int, get_int_array
95  module procedure get_logic, get_logic_array
96  module procedure get_string, get_string_array
97  end interface cfg_get
98 
100  interface cfg_add_get
101  module procedure add_get_real, add_get_real_array
102  module procedure add_get_int, add_get_int_array
103  module procedure add_get_logic, add_get_logic_array
104  module procedure add_get_string, add_get_string_array
105  end interface cfg_add_get
106 
107  ! Public types
108  public :: cfg_t
109  public :: cfg_integer_type
110  public :: cfg_real_type
111  public :: cfg_string_type
112  public :: cfg_logic_type
113  public :: cfg_type_names
114 
115  ! Constants
116  public :: cfg_name_len
117  public :: cfg_string_len
118  public :: cfg_max_array_size
119 
120  ! Public methods
121  public :: cfg_add
122  public :: cfg_get
123  public :: cfg_add_get
124  public :: cfg_get_size
125  public :: cfg_get_type
126  public :: cfg_check
127  public :: cfg_sort
128  public :: cfg_write
129  public :: cfg_write_markdown
130  public :: cfg_read_file
131  public :: cfg_update_from_arguments
132  public :: cfg_update_from_line
133  public :: cfg_clear
134 
135 contains
136 
142  subroutine cfg_update_from_arguments(cfg, ignore_unknown)
143  type(cfg_t),intent(inout) :: cfg
145  logical, intent(in), optional :: ignore_unknown
146  character(len=CFG_string_len) :: arg
147  integer :: ix, n
148  logical :: valid_syntax, strict
149  character(len=4) :: extension
150 
151  strict = .true.; if (present(ignore_unknown)) strict = .not. ignore_unknown
152 
153  do ix = 1, command_argument_count()
154  call get_command_argument(ix, arg)
155 
156  n = len_trim(arg)
157  if (n > 3) extension = arg(n-3:)
158 
159  ! Look for arguments starting with a single dash
160  if (arg(1:1) == '-' .and. arg(2:2) /= '-') then
161  ! This sets a variable
162  call parse_line(cfg, cfg_set_by_arg, arg(2:), valid_syntax)
163 
164  if (.not. valid_syntax) then
165  call handle_error("Invalid syntax on command line: " // trim(arg))
166  end if
167  else if (arg(1:1) /= '-' .and. &
168  (extension == ".cfg" .or. extension == ".txt")) then
169  ! Read a configuration file
170  call cfg_read_file(cfg, trim(arg))
171  else if (strict) then
172  print *, "This error message can be disabled by setting"
173  print *, "ignore_unknown = .true. for CFG_update_from_arguments"
174  call handle_error("Unknown argument: " // trim(arg))
175  end if
176  end do
177  end subroutine cfg_update_from_arguments
178 
180  subroutine cfg_update_from_line(cfg, line)
181  type(cfg_t), intent(inout) :: cfg
182  character(len=*), intent(in) :: line
183  logical :: valid_syntax
184 
185  ! This sets a variable
186  call parse_line(cfg, cfg_set_by_arg, line, valid_syntax)
187 
188  if (.not. valid_syntax) then
189  call handle_error("CFG_set: invalid syntax")
190  end if
191  end subroutine cfg_update_from_line
192 
195  subroutine handle_error(err_string)
196  character(len=*), intent(in) :: err_string
197 
198  print *, "The following error occured in m_config:"
199  print *, trim(err_string)
200 
201  ! It is usually best to quit after an error, to make sure the error message
202  ! is not overlooked in the program's output
203  error stop
204  end subroutine handle_error
205 
207  subroutine get_var_index(cfg, var_name, ix)
208  type(cfg_t), intent(in) :: cfg
209  character(len=*), intent(in) :: var_name
210  integer, intent(out) :: ix
211  integer :: i
212 
213  if (cfg%sorted) then
214  call binary_search_variable(cfg, var_name, ix)
215  else
216  ! Linear search
217  do i = 1, cfg%num_vars
218  if (cfg%vars(i)%var_name == var_name) exit
219  end do
220 
221  ! If not found, set i to -1
222  if (i == cfg%num_vars + 1) i = -1
223  ix = i
224  end if
225 
226  end subroutine get_var_index
227 
229  subroutine cfg_read_file(cfg, filename)
230  type(cfg_t), intent(inout) :: cfg
231  character(len=*), intent(in) :: filename
232 
233  integer, parameter :: my_unit = 123
234  integer :: io_state
235  integer :: line_number
236  logical :: valid_syntax
237  character(len=CFG_name_len) :: line_fmt
238  character(len=CFG_string_len) :: err_string
239  character(len=CFG_string_len) :: line
240  character(len=CFG_name_len) :: category
241 
242  open(my_unit, file=trim(filename), status="old", action="read")
243  write(line_fmt, "(A,I0,A)") "(A", cfg_string_len, ")"
244 
245  category = "" ! Default category is empty
246  line_number = 0
247 
248  do
249  read(my_unit, fmt=trim(line_fmt), err=998, end=999) line
250  line_number = line_number + 1
251 
252  call parse_line(cfg, cfg_set_by_file, line, valid_syntax, category)
253 
254  if (.not. valid_syntax) then
255  write(err_string, *) "Cannot read line ", line_number, &
256  " from ", trim(filename)
257  call handle_error(err_string)
258  end if
259  end do
260 
261  ! Error handling
262 998 write(err_string, "(A,I0,A,I0)") " IOSTAT = ", io_state, &
263  " while reading from " // trim(filename) // " at line ", &
264  line_number
265  call handle_error("CFG_read_file:" // err_string)
266 
267  ! Routine ends here if the end of "filename" is reached
268 999 close(my_unit, iostat=io_state)
269 
270  end subroutine cfg_read_file
271 
273  subroutine parse_line(cfg, set_by, line_arg, valid_syntax, category_arg)
274  type(cfg_t), intent(inout) :: cfg
275  integer, intent(in) :: set_by
276  character(len=*), intent(in) :: line_arg
277  logical, intent(out) :: valid_syntax
278  character(len=CFG_name_len), intent(inout), optional :: category_arg
279  character(len=CFG_name_len) :: var_name, category
280  integer :: ix, equal_sign_ix
281  logical :: append
282  character(len=CFG_string_len) :: line
283 
284  valid_syntax = .true.
285 
286  ! Work on a copy
287  line = line_arg
288  category = ""
289  if (present(category_arg)) category = category_arg
290 
291  call trim_comment(line, '#;')
292 
293  ! Skip empty lines
294  if (line == "") return
295 
296  ! Locate the '=' sign
297  equal_sign_ix = scan(line, '=')
298 
299  ! if there is no '='-sign then a category is indicated
300  if (equal_sign_ix == 0) then
301  line = adjustl(line)
302 
303  ! The category name should appear like this: [category_name]
304  ix = scan(line, ']')
305  if (line(1:1) /= '[' .or. ix == 0) then
306  valid_syntax = .false.
307  return
308  else
309  if (present(category_arg)) category_arg = line(2:ix-1)
310  return
311  end if
312  end if
313 
314  if (line(equal_sign_ix-1:equal_sign_ix) == '+=') then
315  append = .true.
316  var_name = line(1 : equal_sign_ix - 2) ! Set variable name
317  else
318  append = .false.
319  var_name = line(1 : equal_sign_ix - 1) ! Set variable name
320  end if
321 
322  ! If there are less than two spaces or a tab, reset to no category
323  if (var_name(1:2) /= " " .and. var_name(1:1) /= tab_char) then
324  category = ""
325  end if
326 
327  ! Replace leading tabs by spaces
328  ix = verify(var_name, tab_char) ! Find first non-tab character
329  var_name(1:ix-1) = ""
330 
331  ! Remove leading blanks
332  var_name = adjustl(var_name)
333 
334  ! Add category if it is defined
335  if (category /= "") then
336  var_name = trim(category) // cfg_category_separator // var_name
337  end if
338 
339  line = line(equal_sign_ix + 1:) ! Set line to the values behind the '=' sign
340 
341  ! Find variable corresponding to name in file
342  call get_var_index(cfg, var_name, ix)
343 
344  if (ix <= 0) then
345  ! Variable still needs to be created, for now store data as a string
346  call prepare_store_var(cfg, trim(var_name), cfg_unknown_type, 1, &
347  "Not yet created", ix, .false.)
348  cfg%vars(ix)%stored_data = line
349  else
350  if (append) then
351  cfg%vars(ix)%stored_data = &
352  trim(cfg%vars(ix)%stored_data) // trim(line)
353  else
354  cfg%vars(ix)%stored_data = line
355  end if
356 
357  ! If type is known, read in values
358  if (cfg%vars(ix)%var_type /= cfg_unknown_type) then
359  call read_variable(cfg%vars(ix))
360  end if
361  end if
362 
363  ! Store how the variable was set
364  cfg%vars(ix)%set_by = set_by
365 
366  end subroutine parse_line
367 
368  subroutine read_variable(var)
369  type(cfg_var_t), intent(inout) :: var
370  integer :: n, n_entries
371  integer :: ix_start(CFG_max_array_size)
372  integer :: ix_end(CFG_max_array_size), stat
373 
374  ! Get the start and end positions of the line content, and the number of entries
375  call get_fields_string(var%stored_data, cfg_separators, &
376  cfg_max_array_size, n_entries, ix_start, ix_end)
377 
378  if (var%var_size /= n_entries) then
379 
380  if (.not. var%dynamic_size) then
381  ! Allow strings of length 1 to be automatically concatenated
382  if (var%var_type == cfg_string_type .and. var%var_size == 1) then
383  var%char_data(1) = trim(var%stored_data(ix_start(1):ix_end(n_entries)))
384  return ! Leave routine
385  else
386  call handle_error("read_variable: variable [" // &
387  & trim(var%var_name) // "] has the wrong size")
388  end if
389  else
390  var%var_size = n_entries
391  call resize_storage(var)
392  end if
393  end if
394 
395  do n = 1, n_entries
396  stat = 0
397  select case (var%var_type)
398  case (cfg_integer_type)
399  read(var%stored_data(ix_start(n):ix_end(n)), *, iostat=stat) var%int_data(n)
400  case (cfg_real_type)
401  read(var%stored_data(ix_start(n):ix_end(n)), *, iostat=stat) var%real_data(n)
402  case (cfg_string_type)
403  var%char_data(n) = trim(var%stored_data(ix_start(n):ix_end(n)))
404  case (cfg_logic_type)
405  read(var%stored_data(ix_start(n):ix_end(n)), *, iostat=stat) var%logic_data(n)
406  end select
407 
408  if(stat /= 0) then
409  write (*, *) "** m_config error **"
410  write (*, *) "reading variable: ", trim(var%var_name)
411  write (*, *) "variable type: ", trim(cfg_type_names(var%var_type))
412  write (*, *) "parsing value: ", var%stored_data(ix_start(n):ix_end(n))
413  write (*, "(A,I0)") " iostat value: ", stat
414  stop
415  endif
416  end do
417  end subroutine read_variable
418 
419  subroutine trim_comment(line, comment_chars)
420  character(len=*), intent(inout) :: line
421  character(len=*), intent(in) :: comment_chars
422  character :: current_char, need_char
423  integer :: n
424 
425  ! Strip comments, but only outside quoted strings (so that var = '#yolo' is
426  ! valid when # is a comment char)
427  need_char = ""
428 
429  do n = 1, len(line)
430  current_char = line(n:n)
431 
432  if (need_char == "") then
433  if (current_char == "'") then
434  need_char = "'" ! Open string
435  else if (current_char == '"') then
436  need_char = '"' ! Open string
437  else if (index(comment_chars, current_char) /= 0) then
438  line = line(1:n-1) ! Trim line up to comment character
439  exit
440  end if
441  else if (current_char == need_char) then
442  need_char = "" ! Close string
443  end if
444 
445  end do
446 
447  end subroutine trim_comment
448 
449  subroutine cfg_check(cfg)
450  type(cfg_t), intent(in) :: cfg
451  integer :: n
452  character(len=CFG_string_len) :: err_string
453 
454  do n = 1, cfg%num_vars
455  if (cfg%vars(n)%var_type == cfg_unknown_type) then
456  write(err_string, *) "CFG_check: unknown variable ", &
457  trim(cfg%vars(n)%var_name), " specified"
458  call handle_error(err_string)
459  end if
460  end do
461  end subroutine cfg_check
462 
464  subroutine cfg_write(cfg_in, filename, hide_unused, custom_first)
465  use iso_fortran_env
466  type(cfg_t), intent(in) :: cfg_in
467  character(len=*), intent(in) :: filename
469  logical, intent(in), optional :: hide_unused
471  logical, intent(in), optional :: custom_first
472  logical :: hide_not_used, sort_set_by
473  type(cfg_t) :: cfg
474  integer :: i, j, n, io_state, myunit
475  integer :: n_custom_set
476  integer, allocatable :: cfg_order(:)
477  character(len=CFG_name_len) :: name_format, var_name
478  character(len=CFG_name_len) :: category, prev_category
479  character(len=CFG_string_len) :: err_string
480 
481  hide_not_used = .false.
482  if (present(hide_unused)) hide_not_used = hide_unused
483 
484  sort_set_by = .false.
485  if (present(custom_first)) sort_set_by = custom_first
486 
487  ! Always print a sorted configuration
488  cfg = cfg_in
489  if (.not. cfg%sorted) call cfg_sort(cfg)
490 
491  write(name_format, fmt="(A,I0,A)") "(A,A", cfg_name_len, ",A)"
492 
493  if (filename == "stdout") then
494  myunit = output_unit
495  else
496  open(newunit=myunit, file=filename, action="WRITE")
497  end if
498 
499  category = ""
500  prev_category = ""
501 
502  allocate(cfg_order(cfg%num_vars))
503  if (sort_set_by) then
504  n = 0
505  do i = 1, cfg%num_vars
506  if (cfg%vars(i)%set_by /= cfg_set_by_default) then
507  n = n + 1
508  cfg_order(n) = i
509  end if
510  end do
511  n_custom_set = n
512 
513  do i = 1, cfg%num_vars
514  if (cfg%vars(i)%set_by == cfg_set_by_default) then
515  n = n + 1
516  cfg_order(n) = i
517  end if
518  end do
519  else
520  n_custom_set = -1 ! To prevent undefined warning
521  cfg_order(:) = [(i, i = 1, cfg%num_vars)]
522  end if
523 
524  do n = 1, cfg%num_vars
525  i = cfg_order(n)
526 
527  if (.not. cfg%vars(i)%used .and. hide_not_used) cycle
528  if (cfg%vars(i)%var_type == cfg_unknown_type) cycle
529 
530  if (sort_set_by .and. n == n_custom_set + 1) then
531  write(myunit, err=998, fmt="(A)") '# Variables below have default values'
532  write(myunit, err=998, fmt="(A)") ''
533  end if
534 
535  ! Write category when it changes
536  call split_category(cfg%vars(i), category, var_name)
537 
538  if (category /= prev_category .and. category /= '') then
539  write(myunit, err=998, fmt="(A)") '[' // trim(category) // ']'
540  prev_category = category
541  end if
542 
543  ! Indent if inside category
544  if (category /= "") then
545  write(myunit, err=998, fmt="(A,A,A)") " # ", &
546  trim(cfg%vars(i)%description), ":"
547  write(myunit, advance="NO", err=998, fmt="(A)") &
548  " " // trim(var_name) // " ="
549  else
550  write(myunit, err=998, fmt="(A,A,A)") "# ", &
551  trim(cfg%vars(i)%description), ":"
552  write(myunit, advance="NO", err=998, fmt="(A)") &
553  trim(var_name) // " ="
554  end if
555 
556  select case(cfg%vars(i)%var_type)
557  case (cfg_integer_type)
558  do j = 1, cfg%vars(i)%var_size
559  write(myunit, advance="NO", err=998, fmt="(A,I0)") &
560  " ", cfg%vars(i)%int_data(j)
561  end do
562  case (cfg_real_type)
563  do j = 1, cfg%vars(i)%var_size
564  write(myunit, advance="NO", err=998, fmt="(A,ES11.4)") &
565  " ", cfg%vars(i)%real_data(j)
566  end do
567  case (cfg_string_type)
568  do j = 1, cfg%vars(i)%var_size
569  write(myunit, advance="NO", err=998, fmt="(A)") &
570  " '" // trim(cfg%vars(i)%char_data(j)) // "'"
571  end do
572  case (cfg_logic_type)
573  do j = 1, cfg%vars(i)%var_size
574  write(myunit, advance="NO", err=998, fmt="(A,L1)") &
575  " ", cfg%vars(i)%logic_data(j)
576  end do
577  end select
578  write(myunit, err=998, fmt="(A)") ""
579  write(myunit, err=998, fmt="(A)") ""
580  end do
581 
582  if (myunit /= output_unit) close(myunit, err=999, iostat=io_state)
583  call cfg_check(cfg_in)
584  return
585 
586 998 continue
587  write(err_string, *) "CFG_write error: io_state = ", io_state, &
588  " while writing ", trim(var_name), " to ", filename
589  call handle_error(err_string)
590 
591 999 continue ! If there was an error, the routine will end here
592  write(err_string, *) "CFG_write error: io_state = ", io_state, &
593  " while writing to ", filename
594  call handle_error(err_string)
595 
596  end subroutine cfg_write
597 
599  subroutine cfg_write_markdown(cfg_in, filename, hide_unused)
600  use iso_fortran_env
601  type(cfg_t), intent(in) :: cfg_in
602  character(len=*), intent(in) :: filename
603  logical, intent(in), optional :: hide_unused
604  logical :: hide_not_used
605  integer :: i, j, io_state, myunit
606  type(cfg_t) :: cfg
607  character(len=CFG_name_len) :: name_format, var_name
608  character(len=CFG_name_len) :: category, prev_category
609  character(len=CFG_string_len) :: err_string
610 
611  hide_not_used = .false.
612  if (present(hide_unused)) hide_not_used = hide_unused
613 
614  ! Always print a sorted configuration
615  cfg = cfg_in
616  if (.not. cfg%sorted) call cfg_sort(cfg)
617 
618  write(name_format, fmt="(A,I0,A)") "(A,A", cfg_name_len, ",A)"
619 
620  if (filename == "stdout") then
621  myunit = output_unit
622  else
623  myunit = 333
624  open(myunit, file=filename, action="WRITE")
625  end if
626 
627  category = ""
628  prev_category = "X"
629  write(myunit, err=998, fmt="(A)") "# Configuration file (markdown format)"
630  write(myunit, err=998, fmt="(A)") ""
631 
632  do i = 1, cfg%num_vars
633 
634  if (.not. cfg%vars(i)%used .and. hide_not_used) cycle
635  if (cfg%vars(i)%var_type == cfg_unknown_type) cycle
636 
637  ! Write category when it changes
638  call split_category(cfg%vars(i), category, var_name)
639 
640  if (category /= prev_category) then
641  if (category == "") category = "No category"
642  write(myunit, err=998, fmt="(A)") '## ' // trim(category)
643  write(myunit, err=998, fmt="(A)") ""
644  prev_category = category
645  end if
646 
647  write(myunit, err=998, fmt="(A)") "* " // trim(cfg%vars(i)%description)
648  write(myunit, err=998, fmt="(A)") ""
649  write(myunit, advance="NO", err=998, fmt="(A)") &
650  ' ' // trim(var_name) // " ="
651 
652  select case(cfg%vars(i)%var_type)
653  case (cfg_integer_type)
654  do j = 1, cfg%vars(i)%var_size
655  write(myunit, advance="NO", err=998, fmt="(A,I0)") &
656  " ", cfg%vars(i)%int_data(j)
657  end do
658  case (cfg_real_type)
659  do j = 1, cfg%vars(i)%var_size
660  write(myunit, advance="NO", err=998, fmt="(A,E11.4)") &
661  " ", cfg%vars(i)%real_data(j)
662  end do
663  case (cfg_string_type)
664  do j = 1, cfg%vars(i)%var_size
665  write(myunit, advance="NO", err=998, fmt="(A)") &
666  " '" // trim(cfg%vars(i)%char_data(j)) // "'"
667  end do
668  case (cfg_logic_type)
669  do j = 1, cfg%vars(i)%var_size
670  write(myunit, advance="NO", err=998, fmt="(A,L1)") &
671  " ", cfg%vars(i)%logic_data(j)
672  end do
673  end select
674  write(myunit, err=998, fmt="(A)") ""
675  write(myunit, err=998, fmt="(A)") ""
676  end do
677 
678  if (myunit /= output_unit) close(myunit, err=999, iostat=io_state)
679  call cfg_check(cfg_in)
680  return
681 
682 998 continue
683  write(err_string, *) "CFG_write_markdown error: io_state = ", io_state, &
684  " while writing ", trim(var_name), " to ", filename
685  call handle_error(err_string)
686 
687 999 continue ! If there was an error, the routine will end here
688  write(err_string, *) "CFG_write_markdown error: io_state = ", io_state, &
689  " while writing to ", filename
690  call handle_error(err_string)
691 
692  end subroutine cfg_write_markdown
693 
694  subroutine split_category(variable, category, var_name)
695  type(cfg_var_t), intent(in) :: variable
696  character(CFG_name_len), intent(out) :: category
697  character(CFG_name_len), intent(out) :: var_name
698  integer :: ix
699 
700  ix = index(variable%var_name, cfg_category_separator)
701 
702  if (ix == 0) then
703  category = ""
704  var_name = variable%var_name
705  else
706  category = variable%var_name(1:ix-1)
707  var_name = variable%var_name(ix+1:)
708  end if
709 
710  end subroutine split_category
711 
714  subroutine resize_storage(variable)
715  type(cfg_var_t), intent(inout) :: variable
716 
717  select case (variable%var_type)
718  case (cfg_integer_type)
719  deallocate( variable%int_data )
720  allocate( variable%int_data(variable%var_size) )
721  case (cfg_logic_type)
722  deallocate( variable%logic_data )
723  allocate( variable%logic_data(variable%var_size) )
724  case (cfg_real_type)
725  deallocate( variable%real_data )
726  allocate( variable%real_data(variable%var_size) )
727  case (cfg_string_type)
728  deallocate( variable%char_data )
729  allocate( variable%char_data(variable%var_size) )
730  end select
731  end subroutine resize_storage
732 
735  subroutine prepare_store_var(cfg, var_name, var_type, var_size, &
736  description, ix, dynamic_size)
737  type(cfg_t), intent(inout) :: cfg
738  character(len=*), intent(in) :: var_name, description
739  integer, intent(in) :: var_type, var_size
740  integer, intent(out) :: ix
741  logical, intent(in), optional :: dynamic_size
742 
743  ! Check if variable already exists
744  call get_var_index(cfg, var_name, ix)
745 
746  if (ix == -1) then ! Create a new variable
747  call ensure_free_storage(cfg)
748  cfg%sorted = .false.
749  ix = cfg%num_vars + 1
750  cfg%num_vars = cfg%num_vars + 1
751  cfg%vars(ix)%used = .false.
752  cfg%vars(ix)%stored_data = unstored_data_string
753  else
754  ! Only allowed when the variable is not yet created
755  if (cfg%vars(ix)%var_type /= cfg_unknown_type) then
756  call handle_error("prepare_store_var: variable [" // &
757  & trim(var_name) // "] already exists")
758  end if
759  end if
760 
761  cfg%vars(ix)%var_name = var_name
762  cfg%vars(ix)%description = description
763  cfg%vars(ix)%var_type = var_type
764  cfg%vars(ix)%var_size = var_size
765 
766  if (present(dynamic_size)) then
767  cfg%vars(ix)%dynamic_size = dynamic_size
768  else
769  cfg%vars(ix)%dynamic_size = .false.
770  end if
771 
772  select case (var_type)
773  case (cfg_integer_type)
774  allocate( cfg%vars(ix)%int_data(var_size) )
775  case (cfg_real_type)
776  allocate( cfg%vars(ix)%real_data(var_size) )
777  case (cfg_string_type)
778  allocate( cfg%vars(ix)%char_data(var_size) )
779  case (cfg_logic_type)
780  allocate( cfg%vars(ix)%logic_data(var_size) )
781  end select
782 
783  end subroutine prepare_store_var
784 
787  subroutine prepare_get_var(cfg, var_name, var_type, var_size, ix)
788  type(cfg_t), intent(inout) :: cfg
789  character(len=*), intent(in) :: var_name
790  integer, intent(in) :: var_type, var_size
791  integer, intent(out) :: ix
792  character(len=CFG_string_len) :: err_string
793 
794  call get_var_index(cfg, var_name, ix)
795 
796  if (ix == -1) then
797  call handle_error("CFG_get: variable ["//var_name//"] not found")
798  else if (cfg%vars(ix)%var_type /= var_type) then
799  write(err_string, fmt="(A)") "CFG_get: variable [" &
800  // var_name // "] has different type (" // &
801  trim(cfg_type_names(cfg%vars(ix)%var_type)) // &
802  ") than requested (" // trim(cfg_type_names(var_type)) // ")"
803  call handle_error(err_string)
804  else if (cfg%vars(ix)%var_size /= var_size) then
805  write(err_string, fmt="(A,I0,A,I0,A)") "CFG_get: variable [" &
806  // var_name // "] has different size (", cfg%vars(ix)%var_size, &
807  ") than requested (", var_size, ")"
808  call handle_error(err_string)
809  else ! All good, variable will be used
810  cfg%vars(ix)%used = .true.
811  end if
812  end subroutine prepare_get_var
813 
815  subroutine add_real(cfg, var_name, real_data, comment)
816  type(cfg_t), intent(inout) :: cfg
817  character(len=*), intent(in) :: var_name, comment
818  real(dp), intent(in) :: real_data
819  integer :: ix
820 
821  call prepare_store_var(cfg, var_name, cfg_real_type, 1, comment, ix)
822 
823  if (cfg%vars(ix)%stored_data /= unstored_data_string) then
824  call read_variable(cfg%vars(ix))
825  else
826  cfg%vars(ix)%real_data(1) = real_data
827  end if
828  end subroutine add_real
829 
831  ! real
832  subroutine add_real_array(cfg, var_name, real_data, comment, dynamic_size)
833  type(cfg_t), intent(inout) :: cfg
834  character(len=*), intent(in) :: var_name, comment
835  real(dp), intent(in) :: real_data(:)
836  logical, intent(in), optional :: dynamic_size
837  integer :: ix
838 
839  call prepare_store_var(cfg, var_name, cfg_real_type, &
840  size(real_data), comment, ix, dynamic_size)
841 
842  if (cfg%vars(ix)%stored_data /= unstored_data_string) then
843  call read_variable(cfg%vars(ix))
844  else
845  cfg%vars(ix)%real_data = real_data
846  end if
847  end subroutine add_real_array
848 
850  subroutine add_int(cfg, var_name, int_data, comment)
851  type(cfg_t), intent(inout) :: cfg
852  character(len=*), intent(in) :: var_name, comment
853  integer, intent(in) :: int_data
854  integer :: ix
855 
856  call prepare_store_var(cfg, var_name, cfg_integer_type, 1, comment, ix)
857 
858  if (cfg%vars(ix)%stored_data /= unstored_data_string) then
859  call read_variable(cfg%vars(ix))
860  else
861  cfg%vars(ix)%int_data(1) = int_data
862  end if
863  end subroutine add_int
864 
866  subroutine add_int_array(cfg, var_name, int_data, comment, dynamic_size)
867  type(cfg_t), intent(inout) :: cfg
868  character(len=*), intent(in) :: var_name, comment
869  integer, intent(in) :: int_data(:)
870  logical, intent(in), optional :: dynamic_size
871  integer :: ix
872 
873  call prepare_store_var(cfg, var_name, cfg_integer_type, &
874  size(int_data), comment, ix, dynamic_size)
875 
876  if (cfg%vars(ix)%stored_data /= unstored_data_string) then
877  call read_variable(cfg%vars(ix))
878  else
879  cfg%vars(ix)%int_data = int_data
880  end if
881  end subroutine add_int_array
882 
884  subroutine add_string(cfg, var_name, char_data, comment)
885  type(cfg_t), intent(inout) :: cfg
886  character(len=*), intent(in) :: var_name, comment, char_data
887  integer :: ix
888 
889  call prepare_store_var(cfg, var_name, cfg_string_type, 1, comment, ix)
890  if (cfg%vars(ix)%stored_data /= unstored_data_string) then
891  call read_variable(cfg%vars(ix))
892  else
893  cfg%vars(ix)%char_data(1) = char_data
894  end if
895  end subroutine add_string
896 
898  subroutine add_string_array(cfg, var_name, char_data, &
899  comment, dynamic_size)
900  type(cfg_t), intent(inout) :: cfg
901  character(len=*), intent(in) :: var_name, comment, char_data(:)
902  logical, intent(in), optional :: dynamic_size
903  integer :: ix
904 
905  call prepare_store_var(cfg, var_name, cfg_string_type, &
906  size(char_data), comment, ix, dynamic_size)
907 
908  if (cfg%vars(ix)%stored_data /= unstored_data_string) then
909  call read_variable(cfg%vars(ix))
910  else
911  cfg%vars(ix)%char_data = char_data
912  end if
913  end subroutine add_string_array
914 
916  subroutine add_logic(cfg, var_name, logic_data, comment)
917  type(cfg_t), intent(inout) :: cfg
918  character(len=*), intent(in) :: var_name, comment
919  logical, intent(in) :: logic_data
920  integer :: ix
921 
922  call prepare_store_var(cfg, var_name, cfg_logic_type, 1, comment, ix)
923 
924  if (cfg%vars(ix)%stored_data /= unstored_data_string) then
925  call read_variable(cfg%vars(ix))
926  else
927  cfg%vars(ix)%logic_data(1) = logic_data
928  end if
929  end subroutine add_logic
930 
932  subroutine add_logic_array(cfg, var_name, logic_data, &
933  comment, dynamic_size)
934  type(cfg_t), intent(inout) :: cfg
935  character(len=*), intent(in) :: var_name, comment
936  logical, intent(in) :: logic_data(:)
937  logical, intent(in), optional :: dynamic_size
938  integer :: ix
939 
940  call prepare_store_var(cfg, var_name, cfg_logic_type, &
941  size(logic_data), comment, ix, dynamic_size)
942 
943  if (cfg%vars(ix)%stored_data /= unstored_data_string) then
944  call read_variable(cfg%vars(ix))
945  else
946  cfg%vars(ix)%logic_data = logic_data
947  end if
948  end subroutine add_logic_array
949 
951  subroutine get_real_array(cfg, var_name, real_data)
952  type(cfg_t), intent(inout) :: cfg
953  character(len=*), intent(in) :: var_name
954  real(dp), intent(inout) :: real_data(:)
955  integer :: ix
956 
957  call prepare_get_var(cfg, var_name, cfg_real_type, &
958  size(real_data), ix)
959  real_data = cfg%vars(ix)%real_data
960  end subroutine get_real_array
961 
963  subroutine get_int_array(cfg, var_name, int_data)
964  type(cfg_t), intent(inout) :: cfg
965  character(len=*), intent(in) :: var_name
966  integer, intent(inout) :: int_data(:)
967  integer :: ix
968 
969  call prepare_get_var(cfg, var_name, cfg_integer_type, &
970  size(int_data), ix)
971  int_data = cfg%vars(ix)%int_data
972  end subroutine get_int_array
973 
975  subroutine get_string_array(cfg, var_name, char_data)
976  type(cfg_t), intent(inout) :: cfg
977  character(len=*), intent(in) :: var_name
978  character(len=*), intent(inout) :: char_data(:)
979  integer :: ix
980 
981  call prepare_get_var(cfg, var_name, cfg_string_type, &
982  size(char_data), ix)
983  char_data = cfg%vars(ix)%char_data
984  end subroutine get_string_array
985 
987  subroutine get_logic_array(cfg, var_name, logic_data)
988  type(cfg_t), intent(inout) :: cfg
989  character(len=*), intent(in) :: var_name
990  logical, intent(inout) :: logic_data(:)
991  integer :: ix
992 
993  call prepare_get_var(cfg, var_name, cfg_logic_type, &
994  size(logic_data), ix)
995  logic_data = cfg%vars(ix)%logic_data
996  end subroutine get_logic_array
997 
999  subroutine get_real(cfg, var_name, res)
1000  type(cfg_t), intent(inout) :: cfg
1001  character(len=*), intent(in) :: var_name
1002  real(dp), intent(out) :: res
1003  integer :: ix
1004 
1005  call prepare_get_var(cfg, var_name, cfg_real_type, 1, ix)
1006  res = cfg%vars(ix)%real_data(1)
1007  end subroutine get_real
1008 
1010  subroutine get_int(cfg, var_name, res)
1011  type(cfg_t), intent(inout) :: cfg
1012  character(len=*), intent(in) :: var_name
1013  integer, intent(inout) :: res
1014  integer :: ix
1015 
1016  call prepare_get_var(cfg, var_name, cfg_integer_type, 1, ix)
1017  res = cfg%vars(ix)%int_data(1)
1018  end subroutine get_int
1019 
1021  subroutine get_logic(cfg, var_name, res)
1022  type(cfg_t), intent(inout) :: cfg
1023  character(len=*), intent(in) :: var_name
1024  logical, intent(out) :: res
1025  integer :: ix
1026 
1027  call prepare_get_var(cfg, var_name, cfg_logic_type, 1, ix)
1028  res = cfg%vars(ix)%logic_data(1)
1029  end subroutine get_logic
1030 
1032  subroutine get_string(cfg, var_name, res)
1033  type(cfg_t), intent(inout) :: cfg
1034  character(len=*), intent(in) :: var_name
1035  character(len=*), intent(out) :: res
1036  integer :: ix
1037 
1038  call prepare_get_var(cfg, var_name, cfg_string_type, 1, ix)
1039  res = cfg%vars(ix)%char_data(1)
1040  end subroutine get_string
1041 
1043  subroutine add_get_real_array(cfg, var_name, real_data, &
1044  comment, dynamic_size)
1045  type(cfg_t), intent(inout) :: cfg
1046  character(len=*), intent(in) :: var_name, comment
1047  real(dp), intent(inout) :: real_data(:)
1048  logical, intent(in), optional :: dynamic_size
1049 
1050  call add_real_array(cfg, var_name, real_data, comment, dynamic_size)
1051  call get_real_array(cfg, var_name, real_data)
1052  end subroutine add_get_real_array
1053 
1055  subroutine add_get_int_array(cfg, var_name, int_data, &
1056  comment, dynamic_size)
1057  type(cfg_t), intent(inout) :: cfg
1058  character(len=*), intent(in) :: var_name, comment
1059  integer, intent(inout) :: int_data(:)
1060  logical, intent(in), optional :: dynamic_size
1061 
1062  call add_int_array(cfg, var_name, int_data, comment, dynamic_size)
1063  call get_int_array(cfg, var_name, int_data)
1064  end subroutine add_get_int_array
1065 
1067  subroutine add_get_string_array(cfg, var_name, char_data, &
1068  comment, dynamic_size)
1069  type(cfg_t), intent(inout) :: cfg
1070  character(len=*), intent(in) :: var_name, comment
1071  character(len=*), intent(inout) :: char_data(:)
1072  logical, intent(in), optional :: dynamic_size
1073 
1074  call add_string_array(cfg, var_name, char_data, comment, dynamic_size)
1075  call get_string_array(cfg, var_name, char_data)
1076  end subroutine add_get_string_array
1077 
1079  subroutine add_get_logic_array(cfg, var_name, logic_data, &
1080  comment, dynamic_size)
1081  type(cfg_t), intent(inout) :: cfg
1082  character(len=*), intent(in) :: var_name, comment
1083  logical, intent(inout) :: logic_data(:)
1084  logical, intent(in), optional :: dynamic_size
1085 
1086  call add_logic_array(cfg, var_name, logic_data, comment, dynamic_size)
1087  call get_logic_array(cfg, var_name, logic_data)
1088  end subroutine add_get_logic_array
1089 
1091  subroutine add_get_real(cfg, var_name, real_data, comment)
1092  type(cfg_t), intent(inout) :: cfg
1093  character(len=*), intent(in) :: var_name, comment
1094  real(dp), intent(inout) :: real_data
1095 
1096  call add_real(cfg, var_name, real_data, comment)
1097  call get_real(cfg, var_name, real_data)
1098  end subroutine add_get_real
1099 
1101  subroutine add_get_int(cfg, var_name, int_data, comment)
1102  type(cfg_t), intent(inout) :: cfg
1103  character(len=*), intent(in) :: var_name, comment
1104  integer, intent(inout) :: int_data
1105 
1106  call add_int(cfg, var_name, int_data, comment)
1107  call get_int(cfg, var_name, int_data)
1108  end subroutine add_get_int
1109 
1111  subroutine add_get_logic(cfg, var_name, logical_data, comment)
1112  type(cfg_t), intent(inout) :: cfg
1113  character(len=*), intent(in) :: var_name, comment
1114  logical, intent(inout) :: logical_data
1115 
1116  call add_logic(cfg, var_name, logical_data, comment)
1117  call get_logic(cfg, var_name, logical_data)
1118  end subroutine add_get_logic
1119 
1121  subroutine add_get_string(cfg, var_name, string_data, comment)
1122  type(cfg_t), intent(inout) :: cfg
1123  character(len=*), intent(in) :: var_name, comment
1124  character(len=*), intent(inout) :: string_data
1125 
1126  call add_string(cfg, var_name, string_data, comment)
1127  call get_string(cfg, var_name, string_data)
1128  end subroutine add_get_string
1129 
1131  subroutine cfg_get_size(cfg, var_name, res)
1132  type(cfg_t), intent(in) :: cfg
1133  character(len=*), intent(in) :: var_name
1134  integer, intent(out) :: res
1135  integer :: ix
1136 
1137  call get_var_index(cfg, var_name, ix)
1138  if (ix /= -1) then
1139  res = cfg%vars(ix)%var_size
1140  else
1141  res = -1
1142  call handle_error("CFG_get_size: variable ["//var_name//"] not found")
1143  end if
1144  end subroutine cfg_get_size
1145 
1147  subroutine cfg_get_type(cfg, var_name, res)
1148  type(cfg_t), intent(in) :: cfg
1149  character(len=*), intent(in) :: var_name
1150  integer, intent(out) :: res
1151  integer :: ix
1152 
1153  call get_var_index(cfg, var_name, ix)
1154 
1155  if (ix /= -1) then
1156  res = cfg%vars(ix)%var_type
1157  else
1158  res = -1
1159  call handle_error("CFG_get_type: variable ["//var_name//"] not found")
1160  end if
1161  end subroutine cfg_get_type
1162 
1166  subroutine ensure_free_storage(cfg)
1167  type(cfg_t), intent(inout) :: cfg
1168  type(cfg_var_t), allocatable :: cfg_copy(:)
1169  integer, parameter :: min_dyn_size = 100
1170  integer :: cur_size, new_size
1171 
1172  if (allocated(cfg%vars)) then
1173  cur_size = size(cfg%vars)
1174 
1175  if (cur_size < cfg%num_vars + 1) then
1176  new_size = 2 * cur_size
1177  allocate(cfg_copy(cur_size))
1178  cfg_copy = cfg%vars
1179  deallocate(cfg%vars)
1180  allocate(cfg%vars(new_size))
1181  cfg%vars(1:cur_size) = cfg_copy
1182  end if
1183  else
1184  allocate(cfg%vars(min_dyn_size))
1185  end if
1186 
1187  end subroutine ensure_free_storage
1188 
1190  subroutine get_fields_string(line, delims, n_max, n_found, ixs_start, ixs_end)
1191 
1192  character(len=*), intent(in) :: line
1194  character(len=*), intent(in) :: delims
1196  integer, intent(in) :: n_max
1198  integer, intent(inout) :: n_found
1200  integer, intent(inout) :: ixs_start(n_max)
1202  integer, intent(inout) :: ixs_end(n_max)
1203 
1204  integer :: ix, ix_prev
1205 
1206  ix_prev = 0
1207  n_found = 0
1208 
1209  do while (n_found < n_max)
1210 
1211  ! Find the starting point of the next entry (a non-delimiter value)
1212  ix = verify(line(ix_prev+1:), delims)
1213  if (ix == 0) exit
1214 
1215  n_found = n_found + 1
1216  ixs_start(n_found) = ix_prev + ix ! This is the absolute position in 'line'
1217 
1218  ! Get the end point of the current entry (next delimiter index minus one)
1219  ix = scan(line(ixs_start(n_found)+1:), delims) - 1
1220 
1221  if (ix == -1) then ! If there is no last delimiter,
1222  ixs_end(n_found) = len(line) ! the end of the line is the endpoint
1223  else
1224  ixs_end(n_found) = ixs_start(n_found) + ix
1225  end if
1226 
1227  ix_prev = ixs_end(n_found) ! We continue to search from here
1228  end do
1229 
1230  end subroutine get_fields_string
1231 
1233  subroutine binary_search_variable(cfg, var_name, ix)
1234  type(cfg_t), intent(in) :: cfg
1235  character(len=*), intent(in) :: var_name
1236  integer, intent(out) :: ix
1237  integer :: i_min, i_max, i_mid
1238 
1239  i_min = 1
1240  i_max = cfg%num_vars
1241  ix = - 1
1242 
1243  do while (i_min < i_max)
1244  i_mid = i_min + (i_max - i_min) / 2
1245  if ( llt(cfg%vars(i_mid)%var_name, var_name) ) then
1246  i_min = i_mid + 1
1247  else
1248  i_max = i_mid
1249  end if
1250  end do
1251 
1252  ! If not found, binary_search_variable is not set here, and stays -1
1253  if (i_max == i_min .and. cfg%vars(i_min)%var_name == var_name) then
1254  ix = i_min
1255  else
1256  ix = -1
1257  end if
1258  end subroutine binary_search_variable
1259 
1261  subroutine cfg_sort(cfg)
1262  type(cfg_t), intent(inout) :: cfg
1263 
1264  call qsort_config(cfg%vars(1:cfg%num_vars))
1265  cfg%sorted = .true.
1266  end subroutine cfg_sort
1267 
1269  recursive subroutine qsort_config(list)
1270  type(cfg_var_t), intent(inout) :: list(:)
1271  integer :: split_pos
1272 
1273  if (size(list) > 1) then
1274  call parition_var_list(list, split_pos)
1275  call qsort_config( list(:split_pos-1) )
1276  call qsort_config( list(split_pos:) )
1277  end if
1278  end subroutine qsort_config
1279 
1281  subroutine parition_var_list(list, marker)
1282  type(cfg_var_t), intent(inout) :: list(:)
1283  integer, intent(out) :: marker
1284  integer :: left, right, pivot_ix
1285  type(cfg_var_t) :: temp
1286  character(len=CFG_name_len) :: pivot_value
1287 
1288  left = 0
1289  right = size(list) + 1
1290 
1291  ! Take the middle element as pivot
1292  pivot_ix = size(list) / 2
1293  pivot_value = list(pivot_ix)%var_name
1294 
1295  do while (left < right)
1296 
1297  right = right - 1
1298  do while (lgt(list(right)%var_name, pivot_value))
1299  right = right - 1
1300  end do
1301 
1302  left = left + 1
1303  do while (lgt(pivot_value, list(left)%var_name))
1304  left = left + 1
1305  end do
1306 
1307  if (left < right) then
1308  temp = list(left)
1309  list(left) = list(right)
1310  list(right) = temp
1311  end if
1312  end do
1313 
1314  if (left == right) then
1315  marker = left + 1
1316  else
1317  marker = left
1318  end if
1319  end subroutine parition_var_list
1320 
1323  subroutine cfg_clear(cfg)
1324  implicit none
1325  type(cfg_t) :: cfg
1326 
1327  cfg%sorted = .false.
1328  cfg%num_vars = 0
1329  if(allocated(cfg%vars)) then
1330  deallocate(cfg%vars)
1331  endif
1332  end subroutine cfg_clear
1333 
1334 end module m_config
Interface to get variables from the configuration.
Definition: m_config.f90:100
Interface to add variables to the configuration.
Definition: m_config.f90:84
Interface to get variables from the configuration.
Definition: m_config.f90:92
Module that allows working with a configuration file.
Definition: m_config.f90:5
The configuration that contains all the variables.
Definition: m_config.f90:77
The type of a configuration variable.
Definition: m_config.f90:49