-
Notifications
You must be signed in to change notification settings - Fork 6
/
m_config.f90
1349 lines (1122 loc) · 46.9 KB
/
m_config.f90
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
!> Module that allows working with a configuration file
!>
!> Author: Jannis Teunissen and others
!> Repository: https://github.com/jannisteunissen/config_fortran
module m_config
implicit none
private
!> The double precision kind-parameter
integer, parameter :: dp = kind(0.0d0)
integer, parameter :: CFG_num_types = 4 !< Number of variable types
integer, parameter :: CFG_integer_type = 1 !< Integer type
integer, parameter :: CFG_real_type = 2 !< Real number type
integer, parameter :: CFG_string_type = 3 !< String type
integer, parameter :: CFG_logic_type = 4 !< Boolean/logical type
integer, parameter :: CFG_unknown_type = 0 !< Used before a variable is created
!> Indicates a variable has its default value
integer, parameter :: CFG_set_by_default = 1
!> Indicates a variable was set by a command line argument
integer, parameter :: CFG_set_by_arg = 2
!> Indicates a variable was set by reading a file
integer, parameter :: CFG_set_by_file = 3
!> Names of the types
character(len=10), parameter :: CFG_type_names(0:CFG_num_types) = &
[character(len=10) :: "storage", "integer", "real", "string ", "logical"]
integer, parameter :: CFG_name_len = 80 !< Maximum length of variable names
integer, parameter :: CFG_string_len = 200 !< Fixed length of string type
!> Maximum length of line containing multiple arguments/values
integer, parameter :: CFG_max_line_len = 1000
!> Maximum number of entries in a variable (if it's an array)
integer, parameter :: CFG_max_array_size = 1000
character, parameter :: tab_char = char(9)
!> The separator(s) for array-like variables (space, comma, ', ", and tab)
character(len=*), parameter :: CFG_separators = " ,'"""//tab_char
!> The separator for categories (stored in var_name)
character(len=*), parameter :: CFG_category_separator = "%"
!> The default string for data that is not yet stored
character(len=*), parameter :: unstored_data_string = "__UNSTORED_DATA_STRING"
!> The type of a configuration variable
type CFG_var_t
private
!> Name of the variable
character(len=CFG_name_len) :: var_name
!> Description of variable
character(len=CFG_string_len) :: description
!> Type of variable
integer :: var_type
!> Size of variable, 1 means scalar, > 1 means array
integer :: var_size
!> Whether the variable size is flexible
logical :: dynamic_size
!> Whether the variable's value has been requested
logical :: used
!> How the variable has been set (default, command line, file)
integer :: set_by = CFG_set_by_default
!> Data that has been read in for this variable
character(len=CFG_max_line_len) :: stored_data
! These are the arrays used for storage. In the future, a "pointer" based
! approach could be used.
real(dp), allocatable :: real_data(:)
integer, allocatable :: int_data(:)
character(len=CFG_string_len), allocatable :: char_data(:)
logical, allocatable :: logic_data(:)
end type CFG_var_t
!> The configuration that contains all the variables
type CFG_t
logical :: sorted = .false.
integer :: num_vars = 0
type(CFG_var_t), allocatable :: vars(:)
end type CFG_t
!> Interface to add variables to the configuration
interface CFG_add
module procedure add_real, add_real_array
module procedure add_int, add_int_array
module procedure add_string, add_string_array
module procedure add_logic, add_logic_array
end interface CFG_add
!> Interface to get variables from the configuration
interface CFG_get
module procedure get_real, get_real_array
module procedure get_int, get_int_array
module procedure get_logic, get_logic_array
module procedure get_string, get_string_array
end interface CFG_get
!> Interface to get variables from the configuration
interface CFG_add_get
module procedure add_get_real, add_get_real_array
module procedure add_get_int, add_get_int_array
module procedure add_get_logic, add_get_logic_array
module procedure add_get_string, add_get_string_array
end interface CFG_add_get
! Public types
public :: CFG_t
public :: CFG_integer_type
public :: CFG_real_type
public :: CFG_string_type
public :: CFG_logic_type
public :: CFG_type_names
! Constants
public :: CFG_name_len
public :: CFG_string_len
public :: CFG_max_line_len
public :: CFG_max_array_size
! Public methods
public :: CFG_add
public :: CFG_get
public :: CFG_add_get
public :: CFG_get_size
public :: CFG_get_type
public :: CFG_check
public :: CFG_sort
public :: CFG_write
public :: CFG_write_markdown
public :: CFG_read_file
public :: CFG_update_from_arguments
public :: CFG_update_from_line
public :: CFG_clear
contains
!> Read command line arguments. Both files and variables can be specified, for
!> example as: ./my_program config.cfg -n_runs=3
!>
!> config files should have an extension .cfg or .txt
!> command line arguments should be preceded by a single dash
subroutine CFG_update_from_arguments(cfg, ignore_unknown)
type(CFG_t),intent(inout) :: cfg
!> Ignore unknown arguments (default: false)
logical, intent(in), optional :: ignore_unknown
character(len=CFG_max_line_len) :: arg
integer :: ix, n, arg_status
logical :: valid_syntax, strict
character(len=4) :: extension
strict = .true.; if (present(ignore_unknown)) strict = .not. ignore_unknown
do ix = 1, command_argument_count()
call get_command_argument(ix, arg, status=arg_status)
if (arg_status > 0) then
call handle_error("Error in get_command_argument (status > 0)")
else if (arg_status == -1) then
call handle_error("Argument too long, increase CFG_max_line_len")
end if
n = len_trim(arg)
if (n > 3) extension = arg(n-3:)
! Look for arguments starting with a single dash
if (arg(1:1) == '-' .and. arg(2:2) /= '-') then
! This sets a variable
call parse_line(cfg, CFG_set_by_arg, arg(2:), valid_syntax)
if (.not. valid_syntax) then
call handle_error("Invalid syntax on command line: " // trim(arg))
end if
else if (arg(1:1) /= '-' .and. &
(extension == ".cfg" .or. extension == ".txt")) then
! Read a configuration file
call CFG_read_file(cfg, trim(arg))
else if (strict) then
print *, "This error message can be disabled by setting"
print *, "ignore_unknown = .true. for CFG_update_from_arguments"
call handle_error("Unknown argument: " // trim(arg))
end if
end do
end subroutine CFG_update_from_arguments
!> Update the configuration by parsing a line
subroutine CFG_update_from_line(cfg, line)
type(CFG_t), intent(inout) :: cfg
character(len=*), intent(in) :: line
logical :: valid_syntax
! This sets a variable
call parse_line(cfg, CFG_set_by_arg, line, valid_syntax)
if (.not. valid_syntax) then
call handle_error("CFG_set: invalid syntax")
end if
end subroutine CFG_update_from_line
!> This routine will be called if an error occurs in one of the subroutines of
!> this module.
subroutine handle_error(err_string)
character(len=*), intent(in) :: err_string
print *, "The following error occured in m_config:"
print *, trim(err_string)
! It is usually best to quit after an error, to make sure the error message
! is not overlooked in the program's output
error stop
end subroutine handle_error
!> Return the index of the variable with name 'var_name', or -1 if not found.
subroutine get_var_index(cfg, var_name, ix)
type(CFG_t), intent(in) :: cfg
character(len=*), intent(in) :: var_name
integer, intent(out) :: ix
integer :: i
if (cfg%sorted) then
call binary_search_variable(cfg, var_name, ix)
else
! Linear search
do i = 1, cfg%num_vars
if (cfg%vars(i)%var_name == var_name) exit
end do
! If not found, set i to -1
if (i == cfg%num_vars + 1) i = -1
ix = i
end if
end subroutine get_var_index
!> Update the variables in the configartion with the values found in 'filename'
subroutine CFG_read_file(cfg, filename)
type(CFG_t), intent(inout) :: cfg
character(len=*), intent(in) :: filename
integer, parameter :: my_unit = 123
integer :: io_state
integer :: line_number
logical :: valid_syntax
character(len=CFG_name_len) :: line_fmt
character(len=CFG_string_len) :: err_string
character(len=CFG_max_line_len) :: line
character(len=CFG_name_len) :: category
open(my_unit, file=trim(filename), status="old", action="read")
write(line_fmt, "(A,I0,A)") "(A", CFG_max_line_len, ")"
category = "" ! Default category is empty
line_number = 0
do
read(my_unit, FMT=trim(line_fmt), ERR=998, end=999) line
line_number = line_number + 1
if (len_trim(line) > CFG_max_line_len - 2) then
write(err_string, *) "Possible truncation in line ", line_number, &
" from ", trim(filename)
call handle_error(err_string)
end if
call parse_line(cfg, CFG_set_by_file, line, valid_syntax, category)
if (.not. valid_syntax) then
write(err_string, *) "Cannot read line ", line_number, &
" from ", trim(filename)
call handle_error(err_string)
end if
end do
! Error handling
998 write(err_string, "(A,I0,A,I0)") " IOSTAT = ", io_state, &
" while reading from " // trim(filename) // " at line ", &
line_number
call handle_error("CFG_read_file:" // err_string)
! Routine ends here if the end of "filename" is reached
999 close(my_unit, iostat=io_state)
end subroutine CFG_read_file
!> Update the cfg by parsing one line
subroutine parse_line(cfg, set_by, line_arg, valid_syntax, category_arg)
type(CFG_t), intent(inout) :: cfg
integer, intent(in) :: set_by !< Where the line came from
character(len=*), intent(in) :: line_arg !< Line to parse
logical, intent(out) :: valid_syntax
character(len=CFG_name_len), intent(inout), optional :: category_arg !< The category
character(len=CFG_name_len) :: var_name, category
integer :: ix, equal_sign_ix
logical :: append
character(len=CFG_max_line_len) :: line
valid_syntax = .true.
! Work on a copy
line = line_arg
category = ""
if (present(category_arg)) category = category_arg
call trim_comment(line, '#;')
! Skip empty lines
if (line == "") return
! Locate the '=' sign
equal_sign_ix = scan(line, '=')
! if there is no '='-sign then a category is indicated
if (equal_sign_ix == 0) then
line = adjustl(line)
! The category name should appear like this: [category_name]
ix = scan(line, ']')
if (line(1:1) /= '[' .or. ix == 0) then
valid_syntax = .false.
return
else
if (present(category_arg)) category_arg = line(2:ix-1)
return
end if
end if
if (line(equal_sign_ix-1:equal_sign_ix) == '+=') then
append = .true.
var_name = line(1 : equal_sign_ix - 2) ! Set variable name
else
append = .false.
var_name = line(1 : equal_sign_ix - 1) ! Set variable name
end if
! If there are less than two spaces or a tab, reset to no category
if (var_name(1:2) /= " " .and. var_name(1:1) /= tab_char) then
category = ""
end if
! Replace leading tabs by spaces
ix = verify(var_name, tab_char) ! Find first non-tab character
var_name(1:ix-1) = ""
! Remove leading blanks
var_name = adjustl(var_name)
! Add category if it is defined
if (category /= "") then
var_name = trim(category) // CFG_category_separator // var_name
end if
line = line(equal_sign_ix + 1:) ! Set line to the values behind the '=' sign
! Find variable corresponding to name in file
call get_var_index(cfg, var_name, ix)
if (ix <= 0) then
! Variable still needs to be created, for now store data as a string
call prepare_store_var(cfg, trim(var_name), CFG_unknown_type, 1, &
"Not yet created", ix, .false.)
cfg%vars(ix)%stored_data = line
else
if (append) then
cfg%vars(ix)%stored_data = &
trim(cfg%vars(ix)%stored_data) // trim(line)
else
cfg%vars(ix)%stored_data = line
end if
! If type is known, read in values
if (cfg%vars(ix)%var_type /= CFG_unknown_type) then
call read_variable(cfg%vars(ix))
end if
end if
! Store how the variable was set
cfg%vars(ix)%set_by = set_by
end subroutine parse_line
subroutine read_variable(var)
type(CFG_var_t), intent(inout) :: var
integer :: n, n_entries
integer :: ix_start(CFG_max_array_size)
integer :: ix_end(CFG_max_array_size), stat
! Get the start and end positions of the line content, and the number of entries
call get_fields_string(var%stored_data, CFG_separators, &
CFG_max_array_size, n_entries, ix_start, ix_end)
if (var%var_size /= n_entries) then
if (.not. var%dynamic_size) then
! Allow strings of length 1 to be automatically concatenated
if (var%var_type == CFG_string_type .and. var%var_size == 1) then
var%char_data(1) = trim(var%stored_data(ix_start(1):ix_end(n_entries)))
return ! Leave routine
else
call handle_error("read_variable: variable [" // &
& trim(var%var_name) // "] has the wrong size")
end if
else
var%var_size = n_entries
call resize_storage(var)
end if
end if
do n = 1, n_entries
stat = 0
select case (var%var_type)
case (CFG_integer_type)
read(var%stored_data(ix_start(n):ix_end(n)), *, iostat=stat) var%int_data(n)
case (CFG_real_type)
read(var%stored_data(ix_start(n):ix_end(n)), *, iostat=stat) var%real_data(n)
case (CFG_string_type)
var%char_data(n) = trim(var%stored_data(ix_start(n):ix_end(n)))
case (CFG_logic_type)
read(var%stored_data(ix_start(n):ix_end(n)), *, iostat=stat) var%logic_data(n)
end select
if(stat /= 0) then
write (*, *) "** m_config error **"
write (*, *) "reading variable: ", trim(var%var_name)
write (*, *) "variable type: ", trim(CFG_type_names(var%var_type))
write (*, *) "parsing value: ", var%stored_data(ix_start(n):ix_end(n))
write (*, "(A,I0)") " iostat value: ", stat
stop
endif
end do
end subroutine read_variable
subroutine trim_comment(line, comment_chars)
character(len=*), intent(inout) :: line
character(len=*), intent(in) :: comment_chars
character :: current_char, need_char
integer :: n
! Strip comments, but only outside quoted strings (so that var = '#yolo' is
! valid when # is a comment char)
need_char = ""
do n = 1, len(line)
current_char = line(n:n)
if (need_char == "") then
if (current_char == "'") then
need_char = "'" ! Open string
else if (current_char == '"') then
need_char = '"' ! Open string
else if (index(comment_chars, current_char) /= 0) then
line = line(1:n-1) ! Trim line up to comment character
exit
end if
else if (current_char == need_char) then
need_char = "" ! Close string
end if
end do
end subroutine trim_comment
subroutine CFG_check(cfg)
type(CFG_t), intent(in) :: cfg
integer :: n
character(len=CFG_string_len) :: err_string
do n = 1, cfg%num_vars
if (cfg%vars(n)%var_type == CFG_unknown_type) then
write(err_string, *) "CFG_check: unknown variable ", &
trim(cfg%vars(n)%var_name), " specified"
call handle_error(err_string)
end if
end do
end subroutine CFG_check
!> This routine writes the current configuration to a file with descriptions
subroutine CFG_write(cfg_in, filename, hide_unused, custom_first)
use iso_fortran_env
type(CFG_t), intent(in) :: cfg_in
character(len=*), intent(in) :: filename
!> Hide variables whose value was not requested
logical, intent(in), optional :: hide_unused
!> Show user-set variables first (default: false)
logical, intent(in), optional :: custom_first
logical :: hide_not_used, sort_set_by
type(CFG_t) :: cfg
integer :: i, j, n, io_state, myUnit
integer :: n_custom_set
integer, allocatable :: cfg_order(:)
character(len=CFG_name_len) :: name_format, var_name
character(len=CFG_name_len) :: category, prev_category
character(len=CFG_string_len) :: err_string
hide_not_used = .false.
if (present(hide_unused)) hide_not_used = hide_unused
sort_set_by = .false.
if (present(custom_first)) sort_set_by = custom_first
! Always print a sorted configuration
cfg = cfg_in
if (.not. cfg%sorted) call CFG_sort(cfg)
write(name_format, FMT="(A,I0,A)") "(A,A", CFG_name_len, ",A)"
if (filename == "stdout") then
myUnit = output_unit
else
open(newunit=myUnit, FILE=filename, ACTION="WRITE")
end if
category = ""
prev_category = ""
allocate(cfg_order(cfg%num_vars))
if (sort_set_by) then
n = 0
do i = 1, cfg%num_vars
if (cfg%vars(i)%set_by /= CFG_set_by_default) then
n = n + 1
cfg_order(n) = i
end if
end do
n_custom_set = n
do i = 1, cfg%num_vars
if (cfg%vars(i)%set_by == CFG_set_by_default) then
n = n + 1
cfg_order(n) = i
end if
end do
else
n_custom_set = -1 ! To prevent undefined warning
cfg_order(:) = [(i, i = 1, cfg%num_vars)]
end if
do n = 1, cfg%num_vars
i = cfg_order(n)
if (.not. cfg%vars(i)%used .and. hide_not_used) cycle
if (cfg%vars(i)%var_type == CFG_unknown_type) cycle
if (sort_set_by .and. n == n_custom_set + 1) then
write(myUnit, ERR=998, FMT="(A)") '# Variables below have default values'
write(myUnit, ERR=998, FMT="(A)") ''
end if
! Write category when it changes
call split_category(cfg%vars(i), category, var_name)
if (category /= prev_category .and. category /= '') then
write(myUnit, ERR=998, FMT="(A)") '[' // trim(category) // ']'
prev_category = category
end if
! Indent if inside category
if (category /= "") then
write(myUnit, ERR=998, FMT="(A,A,A)") " # ", &
trim(cfg%vars(i)%description), ":"
write(myUnit, ADVANCE="NO", ERR=998, FMT="(A)") &
" " // trim(var_name) // " ="
else
write(myUnit, ERR=998, FMT="(A,A,A)") "# ", &
trim(cfg%vars(i)%description), ":"
write(myUnit, ADVANCE="NO", ERR=998, FMT="(A)") &
trim(var_name) // " ="
end if
select case(cfg%vars(i)%var_type)
case (CFG_integer_type)
do j = 1, cfg%vars(i)%var_size
write(myUnit, ADVANCE="NO", ERR=998, FMT="(A,I0)") &
" ", cfg%vars(i)%int_data(j)
end do
case (CFG_real_type)
do j = 1, cfg%vars(i)%var_size
write(myUnit, ADVANCE="NO", ERR=998, FMT="(A,ES11.4)") &
" ", cfg%vars(i)%real_data(j)
end do
case (CFG_string_type)
do j = 1, cfg%vars(i)%var_size
write(myUnit, ADVANCE="NO", ERR=998, FMT="(A)") &
" '" // trim(cfg%vars(i)%char_data(j)) // "'"
end do
case (CFG_logic_type)
do j = 1, cfg%vars(i)%var_size
write(myUnit, ADVANCE="NO", ERR=998, FMT="(A,L1)") &
" ", cfg%vars(i)%logic_data(j)
end do
end select
write(myUnit, ERR=998, FMT="(A)") ""
write(myUnit, ERR=998, FMT="(A)") ""
end do
if (myUnit /= output_unit) close(myUnit, ERR=999, IOSTAT=io_state)
call CFG_check(cfg_in)
return
998 continue
write(err_string, *) "CFG_write error: io_state = ", io_state, &
" while writing ", trim(var_name), " to ", filename
call handle_error(err_string)
999 continue ! If there was an error, the routine will end here
write(err_string, *) "CFG_write error: io_state = ", io_state, &
" while writing to ", filename
call handle_error(err_string)
end subroutine CFG_write
!> This routine writes the current configuration to a markdown file
subroutine CFG_write_markdown(cfg_in, filename, hide_unused)
use iso_fortran_env
type(CFG_t), intent(in) :: cfg_in
character(len=*), intent(in) :: filename
logical, intent(in), optional :: hide_unused
logical :: hide_not_used
integer :: i, j, io_state, myUnit
type(CFG_t) :: cfg
character(len=CFG_name_len) :: name_format, var_name
character(len=CFG_name_len) :: category, prev_category
character(len=CFG_string_len) :: err_string
hide_not_used = .false.
if (present(hide_unused)) hide_not_used = hide_unused
! Always print a sorted configuration
cfg = cfg_in
if (.not. cfg%sorted) call CFG_sort(cfg)
write(name_format, FMT="(A,I0,A)") "(A,A", CFG_name_len, ",A)"
if (filename == "stdout") then
myUnit = output_unit
else
myUnit = 333
open(myUnit, FILE=filename, ACTION="WRITE")
end if
category = ""
prev_category = "X"
write(myUnit, ERR=998, FMT="(A)") "# Configuration file (markdown format)"
write(myUnit, ERR=998, FMT="(A)") ""
do i = 1, cfg%num_vars
if (.not. cfg%vars(i)%used .and. hide_not_used) cycle
if (cfg%vars(i)%var_type == CFG_unknown_type) cycle
! Write category when it changes
call split_category(cfg%vars(i), category, var_name)
if (category /= prev_category) then
if (category == "") category = "No category"
write(myUnit, ERR=998, FMT="(A)") '## ' // trim(category)
write(myUnit, ERR=998, FMT="(A)") ""
prev_category = category
end if
write(myUnit, ERR=998, FMT="(A)") "* " // trim(cfg%vars(i)%description)
write(myUnit, ERR=998, FMT="(A)") ""
write(myUnit, ADVANCE="NO", ERR=998, FMT="(A)") &
' ' // trim(var_name) // " ="
select case(cfg%vars(i)%var_type)
case (CFG_integer_type)
do j = 1, cfg%vars(i)%var_size
write(myUnit, ADVANCE="NO", ERR=998, FMT="(A,I0)") &
" ", cfg%vars(i)%int_data(j)
end do
case (CFG_real_type)
do j = 1, cfg%vars(i)%var_size
write(myUnit, ADVANCE="NO", ERR=998, FMT="(A,E11.4)") &
" ", cfg%vars(i)%real_data(j)
end do
case (CFG_string_type)
do j = 1, cfg%vars(i)%var_size
write(myUnit, ADVANCE="NO", ERR=998, FMT="(A)") &
" '" // trim(cfg%vars(i)%char_data(j)) // "'"
end do
case (CFG_logic_type)
do j = 1, cfg%vars(i)%var_size
write(myUnit, ADVANCE="NO", ERR=998, FMT="(A,L1)") &
" ", cfg%vars(i)%logic_data(j)
end do
end select
write(myUnit, ERR=998, FMT="(A)") ""
write(myUnit, ERR=998, FMT="(A)") ""
end do
if (myUnit /= output_unit) close(myUnit, ERR=999, IOSTAT=io_state)
call CFG_check(cfg_in)
return
998 continue
write(err_string, *) "CFG_write_markdown error: io_state = ", io_state, &
" while writing ", trim(var_name), " to ", filename
call handle_error(err_string)
999 continue ! If there was an error, the routine will end here
write(err_string, *) "CFG_write_markdown error: io_state = ", io_state, &
" while writing to ", filename
call handle_error(err_string)
end subroutine CFG_write_markdown
subroutine split_category(variable, category, var_name)
type(CFG_var_t), intent(in) :: variable
character(CFG_name_len), intent(out) :: category
character(CFG_name_len), intent(out) :: var_name
integer :: ix
ix = index(variable%var_name, CFG_category_separator)
if (ix == 0) then
category = ""
var_name = variable%var_name
else
category = variable%var_name(1:ix-1)
var_name = variable%var_name(ix+1:)
end if
end subroutine split_category
!> Resize the storage size of variable, which can be of type integer, logical,
!> real or character
subroutine resize_storage(variable)
type(CFG_var_t), intent(inout) :: variable
select case (variable%var_type)
case (CFG_integer_type)
deallocate( variable%int_data )
allocate( variable%int_data(variable%var_size) )
case (CFG_logic_type)
deallocate( variable%logic_data )
allocate( variable%logic_data(variable%var_size) )
case (CFG_real_type)
deallocate( variable%real_data )
allocate( variable%real_data(variable%var_size) )
case (CFG_string_type)
deallocate( variable%char_data )
allocate( variable%char_data(variable%var_size) )
end select
end subroutine resize_storage
!> Helper routine to store variables. This is useful because a lot of the same
!> code is executed for the different types of variables.
subroutine prepare_store_var(cfg, var_name, var_type, var_size, &
description, ix, dynamic_size)
type(CFG_t), intent(inout) :: cfg
character(len=*), intent(in) :: var_name, description
integer, intent(in) :: var_type, var_size
integer, intent(out) :: ix !< Index of variable
logical, intent(in), optional :: dynamic_size
! Check if variable already exists
call get_var_index(cfg, var_name, ix)
if (ix == -1) then ! Create a new variable
call ensure_free_storage(cfg)
cfg%sorted = .false.
ix = cfg%num_vars + 1
cfg%num_vars = cfg%num_vars + 1
cfg%vars(ix)%used = .false.
cfg%vars(ix)%stored_data = unstored_data_string
else
! Only allowed when the variable is not yet created
if (cfg%vars(ix)%var_type /= CFG_unknown_type) then
call handle_error("prepare_store_var: variable [" // &
& trim(var_name) // "] already exists")
end if
end if
cfg%vars(ix)%var_name = var_name
cfg%vars(ix)%description = description
cfg%vars(ix)%var_type = var_type
cfg%vars(ix)%var_size = var_size
if (present(dynamic_size)) then
cfg%vars(ix)%dynamic_size = dynamic_size
else
cfg%vars(ix)%dynamic_size = .false.
end if
select case (var_type)
case (CFG_integer_type)
allocate( cfg%vars(ix)%int_data(var_size) )
case (CFG_real_type)
allocate( cfg%vars(ix)%real_data(var_size) )
case (CFG_string_type)
allocate( cfg%vars(ix)%char_data(var_size) )
case (CFG_logic_type)
allocate( cfg%vars(ix)%logic_data(var_size) )
end select
end subroutine prepare_store_var
!> Helper routine to get variables. This is useful because a lot of the same
!> code is executed for the different types of variables.
subroutine prepare_get_var(cfg, var_name, var_type, var_size, ix)
type(CFG_t), intent(inout) :: cfg
character(len=*), intent(in) :: var_name
integer, intent(in) :: var_type, var_size
integer, intent(out) :: ix
character(len=CFG_string_len) :: err_string
call get_var_index(cfg, var_name, ix)
if (ix == -1) then
call handle_error("CFG_get: variable ["//var_name//"] not found")
else if (cfg%vars(ix)%var_type /= var_type) then
write(err_string, fmt="(A)") "CFG_get: variable [" &
// var_name // "] has different type (" // &
trim(CFG_type_names(cfg%vars(ix)%var_type)) // &
") than requested (" // trim(CFG_type_names(var_type)) // ")"
call handle_error(err_string)
else if (cfg%vars(ix)%var_size /= var_size) then
write(err_string, fmt="(A,I0,A,I0,A)") "CFG_get: variable [" &
// var_name // "] has different size (", cfg%vars(ix)%var_size, &
") than requested (", var_size, ")"
call handle_error(err_string)
else ! All good, variable will be used
cfg%vars(ix)%used = .true.
end if
end subroutine prepare_get_var
!> Add a configuration variable with a real value
subroutine add_real(cfg, var_name, real_data, comment)
type(CFG_t), intent(inout) :: cfg
character(len=*), intent(in) :: var_name, comment
real(dp), intent(in) :: real_data
integer :: ix
call prepare_store_var(cfg, var_name, CFG_real_type, 1, comment, ix)
if (cfg%vars(ix)%stored_data /= unstored_data_string) then
call read_variable(cfg%vars(ix))
else
cfg%vars(ix)%real_data(1) = real_data
end if
end subroutine add_real
!> Add a configuration variable with an array of type
! real
subroutine add_real_array(cfg, var_name, real_data, comment, dynamic_size)
type(CFG_t), intent(inout) :: cfg
character(len=*), intent(in) :: var_name, comment
real(dp), intent(in) :: real_data(:)
logical, intent(in), optional :: dynamic_size
integer :: ix
call prepare_store_var(cfg, var_name, CFG_real_type, &
size(real_data), comment, ix, dynamic_size)
if (cfg%vars(ix)%stored_data /= unstored_data_string) then
call read_variable(cfg%vars(ix))
else
cfg%vars(ix)%real_data = real_data
end if
end subroutine add_real_array
!> Add a configuration variable with an integer value
subroutine add_int(cfg, var_name, int_data, comment)
type(CFG_t), intent(inout) :: cfg
character(len=*), intent(in) :: var_name, comment
integer, intent(in) :: int_data
integer :: ix
call prepare_store_var(cfg, var_name, CFG_integer_type, 1, comment, ix)
if (cfg%vars(ix)%stored_data /= unstored_data_string) then
call read_variable(cfg%vars(ix))
else
cfg%vars(ix)%int_data(1) = int_data
end if
end subroutine add_int
!> Add a configuration variable with an array of type integer
subroutine add_int_array(cfg, var_name, int_data, comment, dynamic_size)
type(CFG_t), intent(inout) :: cfg
character(len=*), intent(in) :: var_name, comment
integer, intent(in) :: int_data(:)
logical, intent(in), optional :: dynamic_size
integer :: ix
call prepare_store_var(cfg, var_name, CFG_integer_type, &
size(int_data), comment, ix, dynamic_size)
if (cfg%vars(ix)%stored_data /= unstored_data_string) then
call read_variable(cfg%vars(ix))
else
cfg%vars(ix)%int_data = int_data
end if
end subroutine add_int_array
!> Add a configuration variable with an character value
subroutine add_string(cfg, var_name, char_data, comment)
type(CFG_t), intent(inout) :: cfg
character(len=*), intent(in) :: var_name, comment, char_data
integer :: ix
call prepare_store_var(cfg, var_name, CFG_string_type, 1, comment, ix)
if (cfg%vars(ix)%stored_data /= unstored_data_string) then
call read_variable(cfg%vars(ix))
else
cfg%vars(ix)%char_data(1) = char_data
end if
end subroutine add_string
!> Add a configuration variable with an array of type character
subroutine add_string_array(cfg, var_name, char_data, &
comment, dynamic_size)
type(CFG_t), intent(inout) :: cfg
character(len=*), intent(in) :: var_name, comment, char_data(:)
logical, intent(in), optional :: dynamic_size
integer :: ix
call prepare_store_var(cfg, var_name, CFG_string_type, &
size(char_data), comment, ix, dynamic_size)
if (cfg%vars(ix)%stored_data /= unstored_data_string) then
call read_variable(cfg%vars(ix))
else
cfg%vars(ix)%char_data = char_data
end if
end subroutine add_string_array
!> Add a configuration variable with an logical value
subroutine add_logic(cfg, var_name, logic_data, comment)
type(CFG_t), intent(inout) :: cfg
character(len=*), intent(in) :: var_name, comment
logical, intent(in) :: logic_data
integer :: ix
call prepare_store_var(cfg, var_name, CFG_logic_type, 1, comment, ix)
if (cfg%vars(ix)%stored_data /= unstored_data_string) then
call read_variable(cfg%vars(ix))
else
cfg%vars(ix)%logic_data(1) = logic_data
end if
end subroutine add_logic
!> Add a configuration variable with an array of type logical
subroutine add_logic_array(cfg, var_name, logic_data, &
comment, dynamic_size)
type(CFG_t), intent(inout) :: cfg
character(len=*), intent(in) :: var_name, comment
logical, intent(in) :: logic_data(:)
logical, intent(in), optional :: dynamic_size
integer :: ix
call prepare_store_var(cfg, var_name, CFG_logic_type, &
size(logic_data), comment, ix, dynamic_size)
if (cfg%vars(ix)%stored_data /= unstored_data_string) then
call read_variable(cfg%vars(ix))
else
cfg%vars(ix)%logic_data = logic_data
end if
end subroutine add_logic_array
!> Get a real array of a given name
subroutine get_real_array(cfg, var_name, real_data)
type(CFG_t), intent(inout) :: cfg
character(len=*), intent(in) :: var_name
real(dp), intent(inout) :: real_data(:)
integer :: ix
call prepare_get_var(cfg, var_name, CFG_real_type, &
size(real_data), ix)
real_data = cfg%vars(ix)%real_data
end subroutine get_real_array
!> Get a integer array of a given name
subroutine get_int_array(cfg, var_name, int_data)
type(CFG_t), intent(inout) :: cfg
character(len=*), intent(in) :: var_name
integer, intent(inout) :: int_data(:)
integer :: ix
call prepare_get_var(cfg, var_name, CFG_integer_type, &
size(int_data), ix)
int_data = cfg%vars(ix)%int_data
end subroutine get_int_array
!> Get a character array of a given name
subroutine get_string_array(cfg, var_name, char_data)
type(CFG_t), intent(inout) :: cfg
character(len=*), intent(in) :: var_name
character(len=*), intent(inout) :: char_data(:)
integer :: ix
call prepare_get_var(cfg, var_name, CFG_string_type, &
size(char_data), ix)
char_data = cfg%vars(ix)%char_data
end subroutine get_string_array