-
Notifications
You must be signed in to change notification settings - Fork 0
/
io.f90
1416 lines (1176 loc) · 67 KB
/
io.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
!****m* io/io =================================================================!
! NAME !
! io !
!------------------------------------------------------------------------------!
! DESCRIPTION !
! A collection of routines for file IO, including an implementation of !
! free-form input (which stores its data in a hash table) and error handling.!
!------------------------------------------------------------------------------!
! NOTES !
! io_input_get_single_value_real and io_str_to_real each use the module !
! level definition of a double precision data type. This is to break any !
! cyclic dependencies between this module and the constants module. !
!------------------------------------------------------------------------------!
! AUTHOR !
! Aaron Hopkinson !
!****==========================================================================!
module io
use iso_fortran_env, only: output_unit
use hash_tables, only: hash_table, str_len
implicit none
private
! This must be the same as in consts...
integer, parameter :: dp = selected_real_kind(15,300)
integer, parameter, public :: max_line_len = str_len
! public variables:
character(len=max_line_len), save, public :: seedname = ' ' ! initialize to blank, so we can call io_err
integer, save, public :: stdout = output_unit ! ...without a seedname
! defines the user interface:
character(len=*), parameter :: input_file_extension = '.in'
character(len=*), parameter :: input_comment_marker = '#'
character(len=*), parameter :: input_begin_block_marker = 'begin'
character(len=*), parameter :: input_end_block_marker = 'end'
character(len=*), parameter :: error_file_extension = '.error'
character(len=*), parameter :: output_file_extension = '.out'
! internal variables:
type(hash_table), save :: input_table
logical, save :: err_in_use = .false. ! used for io_err recursion
integer, save, public :: err_unit_num = output_unit ! default is stdout
interface io_input_get_single_value
module procedure io_input_get_single_value_int
module procedure io_input_get_single_value_real
module procedure io_input_get_single_value_logical
module procedure io_input_get_single_value_str
end interface io_input_get_single_value
! public routines:
public :: io_init
public :: io_open_file
public :: io_find_unit
public :: io_close_file
public :: io_err
public :: io_read_input_file
public :: io_input_finalize
public :: io_query_keyword
public :: io_input_get_data
public :: io_input_get_single_value
public :: io_input_hash_echo
public :: io_str_get_num_tokens
public :: io_str_get_token
public :: io_str_to_lcase
public :: io_str_to_ucase
public :: io_str_to_int
public :: io_str_to_real
public :: io_str_to_logical
contains
!****s* io/io_init ============================================================!
! NAME !
! io_init (PUBLIC) !
!------------------------------------------------------------------------------!
! ARGUMENTS !
! character(len=*), optional, intent(in) :: stdout_action !
!------------------------------------------------------------------------------!
! DESCRIPTION !
! Sets up IO ready for use. !
! !
! Gets seedname from command line arguments and calls io_read_input_file, !
! which parses and stores the significant content of the input file: !
! seedname//input_file_extension into the default (module level) hash table. !
! !
! This routine also opens the main output file: !
! seedname//output_file_extension and stores the unit number in the stdout !
! variable - unless stdout_action is 'stdout', in which case we use the OS !
! stdout. !
!------------------------------------------------------------------------------!
! NOTES !
! Only the first command line argument is used at present. !
! !
! input_file_extension is trimmed away from the right hand side of the first !
! command line argument (if present). !
!==============================================================================!
subroutine io_init(stdout_action)
implicit none
character(len=*), optional, intent(in) :: stdout_action
character(len=7) :: int_stdout_action
integer :: extension_pos
! default stdout action
int_stdout_action = 'append'
if (present(stdout_action)) then
if ((stdout_action .ne. 'stdout') .and. (stdout_action .ne. 'replace') &
& .and. (stdout_action .ne. 'append')) then
write(*,*) 'io_init: Invalid stdout_action'
stop
end if
int_stdout_action = stdout_action
end if
if (command_argument_count() .lt. 1) then
! give user help...
write (*,*) 'io_init: No seedname'
stop
else
! only use first argument - if more, these are ignored (for now)
call get_command_argument(1, seedname)
seedname = adjustl(seedname)
! remove input file extension if included
! - go from the back to cut off only the final instance
! this way if this extension is part of the seedname, we can preserve it by typing entire filename
extension_pos = index(seedname, input_file_extension, back=.true.)
if (extension_pos .gt. 0) then
seedname = seedname(1:extension_pos-1)
end if
! read input file into default hash table
call io_read_input_file(trim(seedname)//input_file_extension, input_table)
! open output file - only surpress this if flag set to true
if (int_stdout_action .ne. 'stdout') then
call io_open_file(trim(seedname)//output_file_extension, stdout, int_stdout_action)
end if
end if
end subroutine io_init
!****s* io/io_open_file =======================================================!
! NAME !
! io_open_file (PUBLIC) !
!------------------------------------------------------------------------------!
! ARGUMENTS !
! character(len=*), intent(in) :: filename !
! integer, intent(out) :: unit_num !
! !
! character(len=*), optional, intent(in) :: file_action !
!------------------------------------------------------------------------------!
! DESCRIPTION !
! Attempts to open a file for reading/writing. !
! Do so by calling io_find_unit, which returns the first free unit number. !
! !
! file_action is optional and can be either: !
! 'read' - file must exist and is marked as read only !
! 'replace' - file need not exist and is replaced if it does !
! 'append' - file need not exist, if it does, we append to existing file !
! !
! In the case of file_action = 'replace' or 'append', if the file does not !
! exist then we create a new one. In both of these cases, we are able to !
! read from, or write to, the file, though this may involve repositioning !
! within the file. !
! !
! If file_action is not present, the default action is 'append'. !
!------------------------------------------------------------------------------!
! NOTES !
! Routine must be recursive because we can call io_err, which can call this. !
!==============================================================================!
recursive subroutine io_open_file(filename, unit_num, file_action)
implicit none
character(len=*), intent(in) :: filename
integer, intent(out) :: unit_num
character(len=*), optional, intent(in) :: file_action
character(len=7) :: int_action
logical :: file_exists
integer :: istat
if (len_trim(filename) .lt. 1) call io_err("io_open_file: Blank filename")
if (present(file_action)) then
! give error if invalid file action
if ((file_action .ne. 'read') .and. (file_action .ne. 'append') .and. (file_action .ne. 'replace')) then
call io_err("io_open_file: Unsupported file action")
end if
! then set internal file action:
int_action = file_action
else
int_action = 'append' ! probably the safest
end if
! search until we find suitable unit
call io_find_unit(unit_num)
! check to see if file exists..
inquire(file=trim(filename), exist=file_exists)
select case (int_action)
case ('read')
! to read, we require file to exist
if (.not. file_exists) call io_err("io_open_file: File; "//trim(filename)//" does not exist")
open(unit=unit_num, file=trim(filename), status='old', action='read', position='rewind', iostat=istat)
case ('replace')
! don't care if file already exists - will create new file if it doesn't exist
open(unit=unit_num, file=trim(filename), status='replace', action='readwrite', position='rewind', iostat=istat)
case ('append')
! *probably* don't care if the file exists.. (in terms of flagging a warning to user)
if (file_exists) then
open(unit=unit_num, file=trim(filename), status='old', action='readwrite', position='append', iostat=istat)
else
open(unit=unit_num, file=trim(filename), status='new', action='readwrite', position='rewind', iostat=istat)
end if
case default
! should be impossible
call io_err("io_open_file: Invalid internal file action")
end select
if (istat .ne. 0) call io_err("io_open_file: Failed to open file; "//trim(filename))
end subroutine io_open_file
!****s* io/io_find_unit =======================================================!
! NAME !
! io_find_unit (PUBLIC) !
!------------------------------------------------------------------------------!
! ARGUMENTS !
! integer, intent(out) :: unit_num !
!------------------------------------------------------------------------------!
! DESCRIPTION !
! Attempts to find the first free unit for file IO. Does so by scanning !
! through a list of possible units (up to max_unit) to find one that both !
! exists and is not open. !
!------------------------------------------------------------------------------!
! NOTES !
! Subroutine could equally be a function. !
! !
! We could consider storing a list of previously closed units and selecting !
! from this. !
! !
! Routine must be recursive because we can call io_err, which can call !
! io_open_file, which calls this. !
!==============================================================================!
recursive subroutine io_find_unit(unit_num)
implicit none
integer, intent(out) :: unit_num
integer, parameter :: min_unit = 10, max_unit = 99
integer :: iunit
logical :: unit_exists, unit_open, success
success = .false.
do iunit = min_unit, max_unit
inquire(unit=iunit, exist=unit_exists, opened=unit_open)
! want unit to exist and not be in use
if (unit_exists .and. (.not. unit_open)) then
success = .true.
unit_num = iunit ! only set once we know it is safe
exit
end if
end do
if (.not. success) call io_err("io_find_unit: Could not open any file units")
end subroutine io_find_unit
!****s* io/io_close_file ======================================================!
! NAME !
! io_close_file (PUBLIC) !
!------------------------------------------------------------------------------!
! ARGUMENTS !
! integer, intent(in) :: unit_num !
!------------------------------------------------------------------------------!
! DESCRIPTION !
! Closes the opened file associated with unit_num. !
!------------------------------------------------------------------------------!
! NOTES !
! Routine must be recursive because we can call io_err, which can call this. !
!==============================================================================!
recursive subroutine io_close_file(unit_num)
implicit none
integer, intent(in) :: unit_num
logical :: unit_exists, unit_open
integer :: istat
! check that both the unit exists and is opened:
! no point in giving error if unit doesn't exist/isn't open --
! actually F95 standard says closing a unit that doesn't exist/isn't connected to a file is safe...
inquire(unit=unit_num, exist=unit_exists, opened=unit_open)
if (unit_exists .and. unit_open) then
close(unit_num, iostat=istat)
if (istat .ne. 0) call io_err("io_close file: Failed to close unit")
end if
end subroutine io_close_file
!****s* io/io_err =============================================================!
! NAME !
! io_err (PUBLIC) !
!------------------------------------------------------------------------------!
! ARGUMENTS !
! character(len=*), intent(in) :: string !
!------------------------------------------------------------------------------!
! DESCRIPTION !
! Attempts to write an error to file: seedname//error_file_extension !
! if a seedname is present - if not, we write error to standard out, then !
! we abort. !
! !
! Routine is recursive to deal with errors that arise from io_open_file, !
! io_close_file, or their children. This is a rare case but it allows us to !
! attempt to preserve errors in a relatively straightforward way. !
!==============================================================================!
recursive subroutine io_err(string)
use iso_fortran_env, only: output_unit
implicit none
character(len=*), intent(in) :: string
! if first time calling this:
if (.not. err_in_use) then
call io_err_initialize ! open error file if we can
! err_unit_num could be a file, or stdout
write(err_unit_num, *) string
! if we opened a file, then close it
! (doesn't actually matter if we close stdout, since this won't give an error and we're finished anyway)
if (err_unit_num .ne. output_unit) call io_close_file(err_unit_num)
stop
else
! any further calls don't cause a stop - only the 'root' call
! err_unit_num could be a file, or stdout - although it might be safer if we always write to stdout here...
write(err_unit_num, *) string
end if
end subroutine io_err
!****s* io/io_read_input_file =================================================!
! NAME !
! io_read_input_file (PUBLIC) !
!------------------------------------------------------------------------------!
! ARGUMENTS !
! character(len=*), intent(in) :: filename !
! type(hash_table), intent(inout) :: table !
!------------------------------------------------------------------------------!
! DESCRIPTION !
! Opens, parses and stores the content of the input file into a hash table. !
! Allows for free-form input. !
!------------------------------------------------------------------------------!
! NOTES !
! Input table must be uninitialized. !
! !
! We discard the end block line without checking that the keywords match. !
! !
! Nested blocks not allowed. !
!==============================================================================!
subroutine io_read_input_file(filename, table)
use hash_tables, only: hash_table_init
implicit none
character(len=*), intent(in) :: filename
type(hash_table), intent(inout) :: table
character(len=max_line_len) :: line_str
character(len=max_line_len), allocatable, dimension(:) :: blockdata
character(len=6) :: buffer_format ! only for max_line_len up to 3 digits (999)
character(len=1) :: str_type, block_line_type
integer :: nlines, nblanklines
integer :: nblocklines, nblockblanks
integer :: iblock, iblockdata
integer :: file_unit
integer :: istat
! no need to check length of filename - this is done in io_open_file
call io_open_file(trim(filename), file_unit, 'read')
! allow table to expand if we have many collisions but don't shrink because we will be
! removing (hopefully) all elements anyway (= lots of shrinking = expensive)
! and then destroying entire table when we're done
call hash_table_init(table, nbuckets=16, can_expand=.true., can_shrink=.false.)
nlines = 0
nblanklines = 0
block_line_type = 'e' ! assume end of block unless we encounter one in the file
! make sure we read into the whole of the string length..
write(buffer_format, '(I3)') max_line_len
buffer_format = '('//trim(adjustl(buffer_format))//'A)'
do
! read all lines..
read(file_unit, fmt=buffer_format, iostat=istat, end=100) line_str
if (istat .ne. 0) call io_err("io_read_input_file: Error reading from "//trim(filename))
nlines = nlines + 1
if (len_trim(line_str) .le. 0) then
! blank line
nblanklines = nblanklines + 1
cycle ! rather than having lots of branches
end if
! not a blank line (len_trim(line_str) > 0)
str_type = io_str_get_type(line_str)
! decide what to do with each type:
select case (str_type)
case ('n') ! normal line
call io_parse_store_str(line_str, table)
case ('c') ! comment
nblanklines = nblanklines + 1
case ('b') ! begin block
! store the entire block in one go
! first loop over block to count number of lines (so we can allocate array)
nblocklines = 1 ! start of block line
nblockblanks = 0
block_line_type = 'n' ! we hope they're all "normal" lines... (don't allow for nested blocks)
! count various numbers of lines (and check for nested block)
do while (block_line_type .ne. 'e') ! line isn't 'end block type'
read(file_unit, fmt=buffer_format, iostat=istat, end=100) line_str
if (istat .ne. 0) call io_err("io_read_input_file: Error reading from "//trim(filename))
nblocklines = nblocklines + 1
if (len_trim(line_str) .le. 0) then
! blank line inside block
nblockblanks = nblockblanks + 1
cycle
end if
! not a blank line (len_trim(line_str) > 0)
block_line_type = io_str_get_type(line_str)
! treat comments as blanks and give error if we have nested block
if (block_line_type .eq. 'c') then
nblockblanks = nblockblanks + 1
else if (block_line_type .eq. 'b') then
call io_err("io_read_input_file: Nested block in "//trim(filename))
end if
end do
! make sure block not empty (subtract two to take account for beginning and end block lines)
if (nblocklines-2 .eq. nblockblanks) call io_err("io_read_input_file: Block is empty")
! block_line_type should be 'e' on the last line of a block (or if we haven't passed through one)
! now we backspace through the file to beginning of block
do iblock = 1, nblocklines
backspace(file_unit, iostat=istat)
if (istat .ne. 0) call io_err("io_read_input file: Error rewinding through "//trim(filename))
end do
! allocate array to store block (subtract one element for the end block line):
allocate(blockdata(nblocklines-nblockblanks-1), stat=istat)
if (istat .ne. 0) call io_err("io_read_input_file: Error allocating array to store block data")
! store the block data:
iblockdata = 1
do iblock = 1, nblocklines-1 ! we don't care about the last line (end block line)
read(file_unit, fmt=buffer_format, iostat=istat) line_str
if (istat .ne. 0) call io_err("io_read_input_file: Error reading block data in "//trim(filename))
if (len_trim(line_str) .gt. 0) then
! not blank - check it's not a comment - then store
! no need to check for nested blocks anymore
block_line_type = io_str_get_type(line_str)
if (block_line_type .ne. 'c') then
blockdata(iblockdata) = line_str
iblockdata = iblockdata + 1
end if
end if
end do
! read the last line so we don't get an unmatched end block error later
read(file_unit, fmt=buffer_format, iostat=istat) line_str
if (istat .ne. 0) call io_err("io_read_input_file: Error reading block data in "//trim(filename))
! could check for mismatched begin and end block names here.. for now, let's not bother
! reset block_line_type so we don't get error thinking we left mid-way through a block
block_line_type = 'e'
! finally, we have all the block stored and are ready to parse the data and store in hash table
call io_parse_store_block(blockdata, table)
! done with block data
deallocate(blockdata, stat=istat)
if (istat .ne. 0) call io_err("io_read_input_file: Error deallocating block data")
case ('e') ! unpaired end block
call io_err("io_read_input_file: Error in "//trim(filename)//" unpaired end block command")
case default
! should not ever get here
call io_err("io_read_input_file: Error getting correct line type in "//trim(filename))
end select
end do
100 continue
! give error if we left the file in the middle of a block
if (block_line_type .ne. 'e') call io_err("io_read_input_file: Exited "//trim(filename)//" in the middle of a block.")
! Give error if file contains nothing
if (nlines .eq. nblanklines) call io_err("io_read_input_file: Nothing in "//trim(filename))
call io_close_file(file_unit)
end subroutine io_read_input_file
!****s* io/io_input_finalize ==================================================!
! NAME !
! io_input_finalize (PUBLIC) !
!------------------------------------------------------------------------------!
! ARGUMENTS !
! None. !
!------------------------------------------------------------------------------!
! DESCRIPTION !
! Writes any keywords that remain in the input hash table to the error file !
! and then stops. Hopefully all keywords are removed by calls to !
! io_input_get_data. !
! !
! If no keywords remain, then the hash table is destroyed and the program !
! can continue as normal. !
!==============================================================================!
subroutine io_input_finalize
use iso_fortran_env, only: output_unit
use hash_tables, only: hash_table_size, hash_table_get_keywords, hash_table_destroy
implicit none
character(len=max_line_len), allocatable, dimension(:) :: keywords
integer :: ikeyword, nkeywords
integer :: istat
nkeywords = hash_table_size(input_table)
if (nkeywords .gt. 0) then
allocate(keywords(nkeywords), stat=istat)
if (istat .ne. 0) call io_err("io_input_finalize: Could not allocate keyword array")
call hash_table_get_keywords(input_table, keywords)
! if io_err was called before here, we won't get this far.. so no need to worry about the rest:
call io_err_initialize ! open error file if we can
write(err_unit_num, *) "The following keywords were found in the input file but not used:"
write(err_unit_num, *)
do ikeyword = 1, nkeywords
write(err_unit_num, *) trim(keywords(ikeyword))
end do
write(err_unit_num, *)
write(err_unit_num, *) "It may be possible that these keywords are valid, but not recognised for the calculation " &
& //"you are trying to do."
write(err_unit_num, *) "Please comment out/delete the relevant lines and try again to continue."
deallocate(keywords, stat=istat)
if (istat .ne. 0) call io_err("io_input_finalize: Could not deallocate keyword array")
! did io_err_initialize open a file?
if (err_unit_num .ne. output_unit) call io_close_file(err_unit_num)
end if
! might not be worth destroying if we're going to stop anyway, but let's try and deallocate/free up as much memory as possible
call hash_table_destroy(input_table)
if (nkeywords .gt. 0) stop
end subroutine io_input_finalize
!****f* io/io_query_keyword ===================================================!
! NAME !
! io_query_keyword (PUBLIC) !
!------------------------------------------------------------------------------!
! ARGUMENTS !
! character(len=*), intent(in) :: keyword !
!------------------------------------------------------------------------------!
! DESCRIPTION !
! Queries the default input hash table for a keyword (see if it existed in !
! the input file). !
!------------------------------------------------------------------------------!
! RESULT !
! Same as hash_table_query: !
! Returns number of matches for a given keyword. !
! - 0 if keyword doesn't exist !
! - 1 if keyword matches a single value (scalar) !
! - N>1 if the keyword matches a block (number of lines) !
!------------------------------------------------------------------------------!
! NOTES !
! Since this is just a wrapper for hash_table_query, we do not allow for !
! the desired table to be passed as an input. For more flexibility, use that !
! routine instead. !
!==============================================================================!
function io_query_keyword(keyword)
use hash_tables, only: hash_table_query
implicit none
character(len=*), intent(in) :: keyword
integer :: io_query_keyword
! although hash_table_query checks length of input, check it here so we can make use of io_err
if (len_trim(keyword) .gt. max_line_len) call io_err("io_query_keyword: keyword too long")
io_query_keyword = hash_table_query(input_table, trim(keyword))
end function io_query_keyword
!****s* io/io_input_get_data ==================================================!
! NAME !
! io_input_get_data (PUBLIC) !
!------------------------------------------------------------------------------!
! ARGUMENTS !
! character(len=*), intent(in) :: keyword !
! character(len=max_line_len), allocatable, intent(out) :: values(:) !
! logical, intent(out) :: found !
!------------------------------------------------------------------------------!
! DESCRIPTION !
! Essentially just a wrapper for hash_table_get_remove, but which always !
! acts on input_table (the default IO hash table). !
! !
! Gets the values (either single line or block) associated with the keyword !
! from input_table, and then removes it. !
! !
! found is .true. if the keyword existed in the input file/hash table. !
!------------------------------------------------------------------------------!
! NOTES !
! Calls io_query_keyword to return the number of lines associated with the !
! keyword in the hash table. We don't give an error if there is no match. !
! !
! In order to simplify use, we make use of an array for the values (even if !
! we only have a single line) - this is slower, but we don't have to treat !
! blocks or single lines differently. !
! !
! Note: values array will need deallocating after last call to this routine. !
! To be safe, will have to check if (allocated(values)). !
!==============================================================================!
subroutine io_input_get_data(keyword, values, found)
use hash_tables, only: hash_table_get_remove
implicit none
character(len=*), intent(in) :: keyword
character(len=max_line_len), allocatable, dimension(:), intent(out) :: values
logical, intent(out) :: found
integer :: nlines, istat
nlines = io_query_keyword(keyword)
if (nlines .gt. 0) then
found = .true.
! make sure we do not need to deallocate block before each call (only after the last one)
if (allocated(values) .and. (size(values,1) .ne. nlines)) then
deallocate(values, stat=istat)
if (istat .ne. 0) call io_err("io_input_get_data: Could not deallocate values array")
end if
allocate(values(nlines), stat=istat)
if (istat .ne. 0) call io_err("io_input_get_data: Could not allocate values array")
call hash_table_get_remove(input_table, keyword, values)
else
! don't deallocate unnecessarily
! might be able to use previously allocated array in next call
found = .false.
end if
end subroutine io_input_get_data
subroutine io_input_get_single_value_int(keyword, int_return, int_default, required)
implicit none
character(len=*), intent(in) :: keyword
integer, intent(out) :: int_return
integer, optional, intent(in) :: int_default
logical, optional, intent(in) :: required
character(len=max_line_len), allocatable, dimension(:) :: input_data
logical :: kw_found
logical :: die
integer :: istat
! do we require that the routine find something in the input table?
if (present(required) .and. required) then
die = .true.
else
die = .false.
end if
call io_input_get_data(trim(keyword), input_data, kw_found)
if (kw_found) then
! if keyword found - array must be allocated
! check number of lines
if (size(input_data, 1) .ne. 1) &
& call io_err("io_input_get_single_value_int: Expected single line for "//trim(keyword))
! check number of tokens
if (io_str_get_num_tokens(input_data(1)) .ne. 1) &
& call io_err("io_input_get_single_value_int: Expected single value for "//trim(keyword))
! set:
int_return = io_str_to_int(io_str_get_token(input_data(1), 1))
else
if (die) call io_err("io_input_get_single_value_int: "//trim(keyword)//" must exist in input")
! set default value if we can..
if (present(int_default)) int_return = int_default
end if
if (allocated(input_data)) then
deallocate(input_data, stat=istat)
if (istat .ne. 0) call io_err("io_input_get_single_value_int: Could not deallocate input_data array")
end if
end subroutine io_input_get_single_value_int
subroutine io_input_get_single_value_real(keyword, real_return, real_default, required)
implicit none
character(len=*), intent(in) :: keyword
real(kind=dp), intent(out) :: real_return
real(kind=dp), optional, intent(in) :: real_default
logical, optional, intent(in) :: required
character(len=max_line_len), allocatable, dimension(:) :: input_data
logical :: kw_found
logical :: die
integer :: istat
! do we require that the routine find something in the input table?
if (present(required) .and. required) then
die = .true.
else
die = .false.
end if
call io_input_get_data(trim(keyword), input_data, kw_found)
if (kw_found) then
! if keyword found - array must be allocated
! check number of lines
if (size(input_data, 1) .ne. 1) &
& call io_err("io_input_get_single_value_real: Expected single line for "//trim(keyword))
! check number of tokens
if (io_str_get_num_tokens(input_data(1)) .ne. 1) &
& call io_err("io_input_get_single_value_real: Expected single value for "//trim(keyword))
! set:
real_return = io_str_to_real(io_str_get_token(input_data(1), 1))
else
if (die) call io_err("io_input_get_single_value_real: "//trim(keyword)//" must exist in input")
! set default value if we can..
if (present(real_default)) real_return = real_default
end if
if (allocated(input_data)) then
deallocate(input_data, stat=istat)
if (istat .ne. 0) call io_err("io_input_get_single_value_real: Could not deallocate input_data array")
end if
end subroutine io_input_get_single_value_real
subroutine io_input_get_single_value_logical(keyword, logical_return, logical_default, required)
implicit none
character(len=*), intent(in) :: keyword
logical, intent(out) :: logical_return
logical, optional, intent(in) :: logical_default
logical, optional, intent(in) :: required
character(len=max_line_len), allocatable, dimension(:) :: input_data
logical :: kw_found
logical :: die
integer :: istat
! do we require that the routine find something in the input table?
if (present(required) .and. required) then
die = .true.
else
die = .false.
end if
call io_input_get_data(trim(keyword), input_data, kw_found)
if (kw_found) then
! if keyword found - array must be allocated
! check number of lines
if (size(input_data, 1) .ne. 1) &
& call io_err("io_input_get_single_value_logical: Expected single line for "//trim(keyword))
! check number of tokens
if (io_str_get_num_tokens(input_data(1)) .ne. 1) &
& call io_err("io_input_get_single_value_logical: Expected single value for "//trim(keyword))
! set:
logical_return = io_str_to_logical(io_str_get_token(input_data(1), 1))
else
if (die) call io_err("io_input_get_single_value_logical: "//trim(keyword)//" must exist in input")
! set default value if we can..
if (present(logical_default)) logical_return = logical_default
end if
if (allocated(input_data)) then
deallocate(input_data, stat=istat)
if (istat .ne. 0) call io_err("io_input_get_single_value_logical: Could not deallocate input_data array")
end if
end subroutine io_input_get_single_value_logical
subroutine io_input_get_single_value_str(keyword, str_return, str_default, required)
implicit none
character(len=*), intent(in) :: keyword
character(len=*), intent(out) :: str_return
character(len=*), optional, intent(in) :: str_default
logical, optional, intent(in) :: required
character(len=max_line_len), allocatable, dimension(:) :: input_data
logical :: kw_found
logical :: die
integer :: istat
if (len_trim(str_default) .gt. max_line_len) &
& call io_err("io_input_get_single_value_str: str_default length > max_line_len")
if (len(str_return) .gt. max_line_len) &
& call io_err("io_input_get_single_value_str: str_return length > max_line_len")
! do we require that the routine find something in the input table?
if (present(required) .and. required) then
die = .true.
else
die = .false.
end if
call io_input_get_data(trim(keyword), input_data, kw_found)
if (kw_found) then
! if keyword found - array must be allocated
! check number of lines
if (size(input_data, 1) .ne. 1) &
& call io_err("io_input_get_single_value_str: Expected single line for "//trim(keyword))
! check number of tokens
if (io_str_get_num_tokens(input_data(1)) .ne. 1) &
& call io_err("io_input_get_single_value_str: Expected single value for "//trim(keyword))
! set:
str_return = io_str_get_token(input_data(1), 1)
else
if (die) call io_err("io_input_get_single_value_str: "//trim(keyword)//" must exist in input")
! set default value if we can..
if (present(str_default)) str_return = str_default
end if
if (allocated(input_data)) then
deallocate(input_data, stat=istat)
if (istat .ne. 0) call io_err("io_input_get_single_value_str: Could not deallocate input_data array")
end if
end subroutine io_input_get_single_value_str
!****s* io/io_input_hash_echo =================================================!
! NAME !
! io_input_hash_echo (PUBLIC) !
!------------------------------------------------------------------------------!
! ARGUMENTS !
! logical, optional, intent(in) :: suppress_output_file !
!------------------------------------------------------------------------------!
! DESCRIPTION !
! Outputs the contents of the hash table. By default we write to a file: !
! seedname.hash - but we have the option of suppressing extra files and !
! instead write to whatever 'stdout' is connected to. !
! !
! If we have no seedname, we write to whatever stdout is connected to. !
! !
! Probably just used for debugging, but public anyway. !
!==============================================================================!
subroutine io_input_hash_echo(suppress_output_file)
use hash_tables, only: hash_table_list
implicit none
logical, optional, intent(in) :: suppress_output_file
integer :: out_unit
out_unit = stdout
if ((.not. present(suppress_output_file)) .or. (.not. suppress_output_file)) then
! only create output file if we have a seedname - regardless of suppress_output_file
if (len_trim(seedname) .ge. 1) then
call io_open_file(trim(seedname)//'.hash', out_unit, 'replace')
end if
end if
call hash_table_list(input_table, out_unit)
! only close if we opened a new unit:
if (out_unit .ne. stdout) call io_close_file(out_unit)
end subroutine io_input_hash_echo
!****f* io/io_str_get_num_tokens ==============================================!
! NAME !
! io_str_get_num_tokens (PUBLIC) !
!------------------------------------------------------------------------------!
! ARGUMENTS !
! character(len=*), intent(in) :: str !
!------------------------------------------------------------------------------!
! DESCRIPTION !
! Counts the number of 'tokens' (or 'words') in a string. !
!------------------------------------------------------------------------------!
! NOTES !
! Only works if the tokens are separated by single spaces. ie: We assume !
! that io_str_shrink has been called beforehand. !
!==============================================================================!
function io_str_get_num_tokens(str)
implicit none
integer :: io_str_get_num_tokens
character(len=*), intent(in) :: str
character(len=1), parameter :: space = ' '
integer :: i, j, strlen
! if we assume that we have used str_shrink before then we can just count the spaces..
strlen = len_trim(str)
io_str_get_num_tokens = 1 ! always N-1 spaces to N tokens
i = 1 ! get into loop
j = 1
do while (i .gt. 0)
i = index(str(j:strlen), space)
j = j+i
if (i .gt. 0) io_str_get_num_tokens = io_str_get_num_tokens + 1
end do
end function io_str_get_num_tokens
!****f* io/io_str_get_token ===================================================!
! NAME !
! io_str_get_token (PUBLIC) !
!------------------------------------------------------------------------------!
! ARGUMENTS !
! character(len=*), intent(in) :: str !
! integer, intent(in) :: ntoken !
!------------------------------------------------------------------------------!
! DESCRIPTION !
! Returns the ntoken-th token/'word' of a string. !
!------------------------------------------------------------------------------!
! NOTES !
! Only works if the tokens are separated by single spaces. ie: We assume !
! that io_str_shrink has been called beforehand. !
! !
! If token does not exist, we give an error. Therefore the user should have !
! called io_str_get_num_tokens beforehand to determine how many tokens exist !
! within a string. !
!==============================================================================!
function io_str_get_token(str, ntoken)
implicit none
character(len=*), intent(in) :: str
integer, intent(in) :: ntoken
character(len=len(str)) :: io_str_get_token
character(len=1), parameter :: space = ' '
integer :: i, j, itoken
integer :: strlen
strlen = len_trim(str)
! assume we have shrunk the string..
j = 0
do itoken = 1, ntoken
if (j .ge. strlen) call io_err("io_str_get_token: could not find token")
i = index(str(j+1:strlen)//space, space, back=.false.)
i = i+j
io_str_get_token = str(j+1:i-1)
j = i
end do
end function io_str_get_token