1
2! (c) Radovan Bast and Stefan Knecht
3! licensed under the GNU Lesser General Public License
4
5module input_reader
6
7   implicit none
8
9   public lowercase
10   public uppercase
11   public word_contains
12   public reset_available_kw_list
13   public check_whether_kw_found
14   public kw_matches
15   public kw_read
16   public set_file_unit
17   public get_file_unit
18
19   integer, parameter, public :: kw_length = 7
20
21   private
22
23   interface kw_read
24      module procedure kw_read_c
25      module procedure kw_read_i1
26      module procedure kw_read_i3
27      module procedure kw_read_r1
28      module procedure kw_read_r2
29      module procedure kw_read_r3
30      module procedure kw_read_r4
31      module procedure kw_read_ivec
32   end interface
33
34   integer, parameter :: max_nr_kw   = 200
35   integer, parameter :: line_length = 80
36
37   integer :: nr_available_kw
38   integer :: file_unit
39   logical :: kw_found
40
41   character(kw_length) :: available_kw_list(max_nr_kw)
42
43contains
44
45   subroutine set_file_unit(u)
46      integer, intent(in) :: u
47      file_unit = u
48   end subroutine
49
50   integer function get_file_unit()
51      get_file_unit = file_unit
52   end function
53
54   function lowercase(s)
55
56!     --------------------------------------------------------------------------
57      character(*), intent(in) :: s
58      character(len(s))        :: lowercase
59!     --------------------------------------------------------------------------
60      integer                  :: off, i, ia
61!     --------------------------------------------------------------------------
62
63      lowercase = s
64
65      off = iachar('a') - iachar('A')
66
67      do i = 1, len(s)
68         ia = iachar(s(i:i))
69         if (ia >= iachar('A') .and. ia <= iachar('Z')) then
70            lowercase(i:i) = achar(ia + off)
71         end if
72      enddo
73
74   end function
75
76   function uppercase(s)
77
78!     --------------------------------------------------------------------------
79      character(*), intent(in) :: s
80      character(len(s))        :: uppercase
81!     --------------------------------------------------------------------------
82      integer                  :: off, i, ia
83!     --------------------------------------------------------------------------
84
85      uppercase = s
86
87      off = iachar('A') - iachar('a')
88
89      do i = 1, len(s)
90         ia = iachar(s(i:i))
91         if (ia >= iachar('a') .and. ia <= iachar('Z')) then
92            uppercase(i:i) = achar(ia + off)
93         end if
94      enddo
95
96   end function
97
98   function prefix_zeros(i, n)
99
100!     prefix_zeros(137, 6) returns '000137'
101
102!     --------------------------------------------------------------------------
103      integer,      intent(in) :: i
104      integer,      intent(in) :: n
105      character(n)             :: prefix_zeros
106!     --------------------------------------------------------------------------
107      integer                  :: k
108      character(1)             :: c09(0:9) = (/'0','1','2','3','4','5','6','7','8','9'/)
109!     --------------------------------------------------------------------------
110
111      do k = 1, n
112         prefix_zeros(n-k+1:n-k+1) = c09(mod(i, 10**k)/10**(k-1))
113      end do
114
115   end function
116
117   function word_count(s)
118
119!     --------------------------------------------------------------------------
120      character(*), intent(in) :: s
121      integer                  :: word_count
122!     --------------------------------------------------------------------------
123      integer                  :: i
124      logical                  :: is_blank
125!     --------------------------------------------------------------------------
126
127      word_count = 0
128
129      if (len(s) <= 0) return
130
131      is_blank = .true.
132
133      do i = 1, len(s)
134         if (s(i:i) == ' ') then
135            is_blank = .true.
136         else if (is_blank) then
137            word_count = word_count + 1
138            is_blank = .false.
139         end if
140      end do
141
142   end function
143
144   function word_contains(word, substring)
145
146!     --------------------------------------------------------------------------
147      character(*), intent(in) :: word
148      character(*), intent(in) :: substring
149!     --------------------------------------------------------------------------
150      logical                  :: word_contains
151!     --------------------------------------------------------------------------
152
153      word_contains = .false.
154      if (index(word, substring) > 0) then
155         word_contains = .true.
156      end if
157
158   end function
159
160   subroutine kw_read_c(kw_input, c)
161
162      character(kw_length), intent(in)  :: kw_input
163      character(*),         intent(out) :: c
164
165      read(file_unit, *, err=1) c
166      return
167
1681     call kw_read_error(kw_input)
169
170   end subroutine
171
172   subroutine kw_read_i1(kw_input, i)
173
174      character(kw_length), intent(in)  :: kw_input
175      integer,              intent(out) :: i
176
177      read(file_unit, *, err=1) i
178      return
179
1801     call kw_read_error(kw_input)
181
182   end subroutine
183
184   subroutine kw_read_i3(kw_input, i1, i2, i3)
185
186      character(kw_length), intent(in)  :: kw_input
187      integer,              intent(out) :: i1, i2, i3
188
189      read(file_unit, *, err=1) i1, i2, i3
190      return
191
1921     call kw_read_error(kw_input)
193
194   end subroutine
195
196   subroutine kw_read_r1(kw_input, r)
197
198      character(kw_length), intent(in)  :: kw_input
199      real(8),              intent(out) :: r
200
201      read(file_unit, *, err=1) r
202      return
203
2041     call kw_read_error(kw_input)
205
206   end subroutine
207
208   subroutine kw_read_r2(kw_input, r1, r2)
209
210      character(kw_length), intent(in)  :: kw_input
211      real(8),              intent(out) :: r1, r2
212
213      read(file_unit, *, err=1) r1, r2
214      return
215
2161     call kw_read_error(kw_input)
217
218   end subroutine
219
220   subroutine kw_read_r3(kw_input, r1, r2, r3)
221
222      character(kw_length), intent(in)  :: kw_input
223      real(8),              intent(out) :: r1, r2, r3
224
225      read(file_unit, *, err=1) r1, r2, r3
226      return
227
2281     call kw_read_error(kw_input)
229
230   end subroutine
231
232   subroutine kw_read_r4(kw_input, r1, r2, r3, r4)
233
234      character(kw_length), intent(in)  :: kw_input
235      real(8),              intent(out) :: r1, r2, r3, r4
236
237      read(file_unit, *, err=1) r1, r2, r3, r4
238      return
239
2401     call kw_read_error(kw_input)
241
242   end subroutine
243
244   subroutine kw_read_ivec(kw_input, v, k)
245
246      character(kw_length), intent(in)  :: kw_input
247      integer,              intent(out) :: v(:)
248      integer,              intent(in)  :: k
249      integer                           :: j
250
251      read(file_unit, *,err=1) (v(j), j=1,k)
252      return
253
2541     call kw_read_error(kw_input)
255
256   end subroutine
257
258   subroutine kw_read_error(kw_input)
259
260      character(kw_length), intent(in) :: kw_input
261      character(line_length)           :: line
262
263      backspace file_unit
264      read(file_unit, *) line
265
266      write(*, *) 'error in input line:'
267      write(*, *) line
268      write(*, *) 'following keyword '//kw_input
269
270      call quit('error in line following keyword '//kw_input)
271
272   end subroutine
273
274   subroutine reset_available_kw_list()
275
276      nr_available_kw = 0
277      kw_found        = .false.
278
279   end subroutine
280
281   subroutine check_whether_kw_found(kw_input, kw_section)
282
283      character(kw_length), intent(in) :: kw_input
284      character(kw_length), intent(in) :: kw_section
285      integer                          :: i
286
287      if (.not. kw_found) then
288
289         write(*, *) 'illegal keyword '//kw_input//' in section '//kw_section
290
291         write(*, *) 'list of available keywords in section '//kw_section//':'
292         do i = 1, nr_available_kw
293            write(*, *) available_kw_list(i)
294         end do
295
296         call quit('illegal keyword '//kw_input//' in section '//kw_section)
297
298      end if
299
300   end subroutine
301
302   function kw_matches(kw_input, kw_option)
303
304      character(kw_length), intent(in) :: kw_input
305      character(kw_length), intent(in) :: kw_option
306      logical                          :: kw_matches
307
308      if (lowercase(kw_input) == lowercase(kw_option)) then
309         kw_matches = .true.
310         kw_found   = .true.
311      else
312         kw_matches = .false.
313         nr_available_kw = nr_available_kw + 1
314         available_kw_list(nr_available_kw) = kw_option
315      end if
316
317   end function
318
319end module
320