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