SUEWS API Site
Documentation of SUEWS source code
suews_util_stringmod.f95
Go to the documentation of this file.
1 ! curtesy by George via http://gbenthien.net/strings/index.php
2 
3 module precision
4 
5 ! Real kinds
6 
7  integer, parameter :: kr4 = selected_real_kind(6, 37) ! single precision real
8  integer, parameter :: kr8 = selected_real_kind(15, 307) ! double precision real
9 
10 ! Integer kinds
11 
12  integer, parameter :: ki4 = selected_int_kind(9) ! single precision integer
13  integer, parameter :: ki8 = selected_int_kind(18) ! double precision integer
14 
15 !Complex kinds
16 
17  integer, parameter :: kc4 = kr4 ! single precision complex
18  integer, parameter :: kc8 = kr8 ! double precision complex
19 
20 end module precision
21 
22 module strings
23 
24  use precision
25 
26  private :: value_dr, value_sr, value_di, value_si
27  private :: write_dr, write_sr, write_di, write_si
29 
30  interface value ! Generic operator for converting a number string to a
31  ! number. Calling syntax is 'call value(numstring,number,ios)'
32  ! where 'numstring' is a number string and 'number' is a
33  ! real number or an integer (single or double precision).
34  module procedure value_dr
35  module procedure value_sr
36  module procedure value_di
37  module procedure value_si
38  end interface
39 
40  interface writenum ! Generic interface for writing a number to a string. The
41  ! number is left justified in the string. The calling syntax
42  ! is 'call writenum(number,string,format)' where 'number' is
43  ! a real number or an integer, 'string' is a character string
44  ! containing the result, and 'format' is the format desired,
45  ! e.g., 'e15.6' or 'i5'.
46  module procedure write_dr
47  module procedure write_sr
48  module procedure write_di
49  module procedure write_si
50  end interface
51 
52  interface writeq ! Generic interface equating a name to a numerical value. The
53  ! calling syntax is 'call writeq(unit,name,value,format)' where
54  ! unit is the integer output unit number, 'name' is the variable
55  ! name, 'value' is the real or integer value of the variable,
56  ! and 'format' is the format of the value. The result written to
57  ! the output unit has the form <name> = <value>.
58  module procedure writeq_dr
59  module procedure writeq_sr
60  module procedure writeq_di
61  module procedure writeq_si
62  end interface
63 
64 !**********************************************************************
65 
66 contains
67 
68 !**********************************************************************
69 
70  subroutine parse(str, delims, args, nargs)
71 
72 ! Parses the string 'str' into arguments args(1), ..., args(nargs) based on
73 ! the delimiters contained in the string 'delims'. Preceding a delimiter in
74 ! 'str' by a backslash (\) makes this particular instance not a delimiter.
75 ! The integer output variable nargs contains the number of arguments found.
76 
77  character(len=*) :: str, delims
78  character(len=len_trim(str)) :: strsav
79  character(len=*), dimension(:) :: args
80 
81  strsav = str
82  call compact(str)
83  na = size(args)
84  do i = 1, na
85  args(i) = ' '
86  end do
87  nargs = 0
88  lenstr = len_trim(str)
89  if (lenstr == 0) return
90  k = 0
91 
92  do
93  if (len_trim(str) == 0) exit
94  nargs = nargs + 1
95  call split(str, delims, args(nargs))
96  call removebksl(args(nargs))
97  end do
98  str = strsav
99 
100  end subroutine parse
101 
102 !**********************************************************************
103 
104  subroutine compact(str)
106 ! Converts multiple spaces and tabs to single spaces; deletes control characters;
107 ! removes initial spaces.
108 
109  character(len=*):: str
110  character(len=1):: ch
111  character(len=len_trim(str)):: outstr
112 
113  str = adjustl(str)
114  lenstr = len_trim(str)
115  outstr = ' '
116  isp = 0
117  k = 0
118 
119  do i = 1, lenstr
120  ch = str(i:i)
121  ich = iachar(ch)
122 
123  select case (ich)
124 
125  case (9, 32) ! space or tab character
126  if (isp == 0) then
127  k = k + 1
128  outstr(k:k) = ' '
129  end if
130  isp = 1
131 
132  case (33:) ! not a space, quote, or control character
133  k = k + 1
134  outstr(k:k) = ch
135  isp = 0
136 
137  end select
138 
139  end do
140 
141  str = adjustl(outstr)
142 
143  end subroutine compact
144 
145 !**********************************************************************
146 
147  subroutine removesp(str)
149 ! Removes spaces, tabs, and control characters in string str
150 
151  character(len=*):: str
152  character(len=1):: ch
153  character(len=len_trim(str))::outstr
154 
155  str = adjustl(str)
156  lenstr = len_trim(str)
157  outstr = ' '
158  k = 0
159 
160  do i = 1, lenstr
161  ch = str(i:i)
162  ich = iachar(ch)
163  select case (ich)
164  case (0:32) ! space, tab, or control character
165  cycle
166  case (33:)
167  k = k + 1
168  outstr(k:k) = ch
169  end select
170  end do
171 
172  str = adjustl(outstr)
173 
174  end subroutine removesp
175 
176 !**********************************************************************
177 
178  subroutine value_dr(str, rnum, ios)
180 ! Converts number string to a double precision real number
181 
182  character(len=*)::str
183  real(kr8)::rnum
184  integer :: ios
185 
186  ilen = len_trim(str)
187  ipos = scan(str, 'Ee')
188  if (.not. is_digit(str(ilen:ilen)) .and. ipos /= 0) then
189  ios = 3
190  return
191  end if
192  read (str, *, iostat=ios) rnum
193 
194  end subroutine value_dr
195 
196 !**********************************************************************
197 
198  subroutine value_sr(str, rnum, ios)
200 ! Converts number string to a single precision real number
201 
202  character(len=*)::str
203  real(kr4) :: rnum
204  real(kr8) :: rnumd
205 
206  call value_dr(str, rnumd, ios)
207  if (abs(rnumd) > huge(rnum)) then
208  ios = 15
209  return
210  end if
211  if (abs(rnumd) < tiny(rnum)) rnum = 0.0_kr4
212  rnum = real(rnumd, kr4)
213 
214  end subroutine value_sr
215 
216 !**********************************************************************
217 
218  subroutine value_di(str, inum, ios)
220 ! Converts number string to a double precision integer value
221 
222  character(len=*)::str
223  integer(ki8) :: inum
224  real(kr8) :: rnum
225 
226  call value_dr(str, rnum, ios)
227  if (abs(rnum) > huge(real(inum, kr8))) then
228  ios = 15
229  return
230  end if
231  inum = nint(rnum, ki8)
232 
233  end subroutine value_di
234 
235 !**********************************************************************
236 
237  subroutine value_si(str, inum, ios)
239 ! Converts number string to a single precision integer value
240 
241  character(len=*)::str
242  integer(ki4) :: inum
243  real(kr8) :: rnum
244 
245  call value_dr(str, rnum, ios)
246  if (abs(rnum) > huge(inum)) then
247  ios = 15
248  return
249  end if
250  inum = nint(rnum, ki4)
251 
252  end subroutine value_si
253 
254 !**********************************************************************
255 
256  subroutine shiftstr(str, n)
258 ! Shifts characters in in the string 'str' n positions (positive values
259 ! denote a right shift and negative values denote a left shift). Characters
260 ! that are shifted off the end are lost. Positions opened up by the shift
261 ! are replaced by spaces.
262 
263  character(len=*):: str
264 
265  lenstr = len(str)
266  nabs = iabs(n)
267  if (nabs >= lenstr) then
268  str = repeat(' ', lenstr)
269  return
270  end if
271  if (n < 0) str = str(nabs + 1:)//repeat(' ', nabs) ! shift left
272  if (n > 0) str = repeat(' ', nabs)//str(:lenstr - nabs) ! shift right
273  return
274 
275  end subroutine shiftstr
276 
277 !**********************************************************************
278 
279  subroutine insertstr(str, strins, loc)
281 ! Inserts the string 'strins' into the string 'str' at position 'loc'.
282 ! Characters in 'str' starting at position 'loc' are shifted right to
283 ! make room for the inserted string. Trailing spaces of 'strins' are
284 ! removed prior to insertion
285 
286  character(len=*):: str, strins
287  character(len=len(str))::tempstr
288 
289  lenstrins = len_trim(strins)
290  tempstr = str(loc:)
291  call shiftstr(tempstr, lenstrins)
292  tempstr(1:lenstrins) = strins(1:lenstrins)
293  str(loc:) = tempstr
294  return
295 
296  end subroutine insertstr
297 
298 !**********************************************************************
299 
300  subroutine delsubstr(str, substr)
302 ! Deletes first occurrence of substring 'substr' from string 'str' and
303 ! shifts characters left to fill hole. Trailing spaces or blanks are
304 ! not considered part of 'substr'.
305 
306  character(len=*):: str, substr
307 
308  lensubstr = len_trim(substr)
309  ipos = index(str, substr)
310  if (ipos == 0) return
311  if (ipos == 1) then
312  str = str(lensubstr + 1:)
313  else
314  str = str(:ipos - 1)//str(ipos + lensubstr:)
315  end if
316  return
317 
318  end subroutine delsubstr
319 
320 !**********************************************************************
321 
322  subroutine delall(str, substr)
324 ! Deletes all occurrences of substring 'substr' from string 'str' and
325 ! shifts characters left to fill holes.
326 
327  character(len=*):: str, substr
328 
329  lensubstr = len_trim(substr)
330  do
331  ipos = index(str, substr)
332  if (ipos == 0) exit
333  if (ipos == 1) then
334  str = str(lensubstr + 1:)
335  else
336  str = str(:ipos - 1)//str(ipos + lensubstr:)
337  end if
338  end do
339  return
340 
341  end subroutine delall
342 
343 !**********************************************************************
344 
345  function uppercase(str) result(ucstr)
347 ! convert string to upper case
348 
349  character(len=*):: str
350  character(len=len_trim(str)):: ucstr
351 
352  ilen = len_trim(str)
353  ioffset = iachar('A') - iachar('a')
354  iquote = 0
355  ucstr = str
356  do i = 1, ilen
357  iav = iachar(str(i:i))
358  if (iquote == 0 .and. (iav == 34 .or. iav == 39)) then
359  iquote = 1
360  iqc = iav
361  cycle
362  end if
363  if (iquote == 1 .and. iav == iqc) then
364  iquote = 0
365  cycle
366  end if
367  if (iquote == 1) cycle
368  if (iav >= iachar('a') .and. iav <= iachar('z')) then
369  ucstr(i:i) = achar(iav + ioffset)
370  else
371  ucstr(i:i) = str(i:i)
372  end if
373  end do
374  return
375 
376  end function uppercase
377 
378 !**********************************************************************
379 
380  function lowercase(str) result(lcstr)
382 ! convert string to lower case
383 
384  character(len=*):: str
385  character(len=len_trim(str)):: lcstr
386 
387  ilen = len_trim(str)
388  ioffset = iachar('A') - iachar('a')
389  iquote = 0
390  lcstr = str
391  do i = 1, ilen
392  iav = iachar(str(i:i))
393  if (iquote == 0 .and. (iav == 34 .or. iav == 39)) then
394  iquote = 1
395  iqc = iav
396  cycle
397  end if
398  if (iquote == 1 .and. iav == iqc) then
399  iquote = 0
400  cycle
401  end if
402  if (iquote == 1) cycle
403  if (iav >= iachar('A') .and. iav <= iachar('Z')) then
404  lcstr(i:i) = achar(iav - ioffset)
405  else
406  lcstr(i:i) = str(i:i)
407  end if
408  end do
409  return
410 
411  end function lowercase
412 
413 !**********************************************************************
414 
415  subroutine readline(nunitr, line, ios)
417 ! Reads line from unit=nunitr, ignoring blank lines
418 ! and deleting comments beginning with an exclamation point(!)
419 
420  character(len=*):: line
421 
422  do
423  read (nunitr, '(a)', iostat=ios) line ! read input line
424  if (ios /= 0) return
425  line = adjustl(line)
426  ipos = index(line, '!')
427  if (ipos == 1) cycle
428  if (ipos /= 0) line = line(:ipos - 1)
429  if (len_trim(line) /= 0) exit
430  end do
431  return
432 
433  end subroutine readline
434 
435 !**********************************************************************
436 
437  subroutine match(str, ipos, imatch)
439 ! Sets imatch to the position in string of the delimiter matching the delimiter
440 ! in position ipos. Allowable delimiters are (), [], {}, <>.
441 
442  character(len=*) :: str
443  character :: delim1, delim2, ch
444 
445  lenstr = len_trim(str)
446  delim1 = str(ipos:ipos)
447  select case (delim1)
448  case ('(')
449  idelim2 = iachar(delim1) + 1
450  istart = ipos + 1
451  iend = lenstr
452  inc = 1
453  case (')')
454  idelim2 = iachar(delim1) - 1
455  istart = ipos - 1
456  iend = 1
457  inc = -1
458  case ('[', '{', '<')
459  idelim2 = iachar(delim1) + 2
460  istart = ipos + 1
461  iend = lenstr
462  inc = 1
463  case (']', '}', '>')
464  idelim2 = iachar(delim1) - 2
465  istart = ipos - 1
466  iend = 1
467  inc = -1
468  case default
469  write (*, *) delim1, ' is not a valid delimiter'
470  return
471  end select
472  if (istart < 1 .or. istart > lenstr) then
473  write (*, *) delim1, ' has no matching delimiter'
474  return
475  end if
476  delim2 = achar(idelim2) ! matching delimiter
477 
478  isum = 1
479  do i = istart, iend, inc
480  ch = str(i:i)
481  if (ch /= delim1 .and. ch /= delim2) cycle
482  if (ch == delim1) isum = isum + 1
483  if (ch == delim2) isum = isum - 1
484  if (isum == 0) exit
485  end do
486  if (isum /= 0) then
487  write (*, *) delim1, ' has no matching delimiter'
488  return
489  end if
490  imatch = i
491 
492  return
493 
494  end subroutine match
495 
496 !**********************************************************************
497 
498  subroutine write_dr(rnum, str, fmt)
500 ! Writes double precision real number rnum to string str using format fmt
501 
502  real(kr8) :: rnum
503  character(len=*) :: str, fmt
504  character(len=80) :: formt
505 
506  formt = '('//trim(fmt)//')'
507  write (str, formt) rnum
508  str = adjustl(str)
509 
510  end subroutine write_dr
511 
512 !***********************************************************************
513 
514  subroutine write_sr(rnum, str, fmt)
516 ! Writes single precision real number rnum to string str using format fmt
517 
518  real(kr4) :: rnum
519  character(len=*) :: str, fmt
520  character(len=80) :: formt
521 
522  formt = '('//trim(fmt)//')'
523  write (str, formt) rnum
524  str = adjustl(str)
525 
526  end subroutine write_sr
527 
528 !***********************************************************************
529 
530  subroutine write_di(inum, str, fmt)
532 ! Writes double precision integer inum to string str using format fmt
533 
534  integer(ki8) :: inum
535  character(len=*) :: str, fmt
536  character(len=80) :: formt
537 
538  formt = '('//trim(fmt)//')'
539  write (str, formt) inum
540  str = adjustl(str)
541 
542  end subroutine write_di
543 
544 !***********************************************************************
545 
546  subroutine write_si(inum, str, fmt)
548 ! Writes single precision integer inum to string str using format fmt
549 
550  integer(ki4) :: inum
551  character(len=*) :: str, fmt
552  character(len=80) :: formt
553 
554  formt = '('//trim(fmt)//')'
555  write (str, formt) inum
556  str = adjustl(str)
557 
558  end subroutine write_si
559 
560 !***********************************************************************
561 
562  subroutine trimzero(str)
564 ! Deletes nonsignificant trailing zeroes from number string str. If number
565 ! string ends in a decimal point, one trailing zero is added.
566 
567  character(len=*) :: str
568  character :: ch
569  character(len=10) :: exp
570 
571  ipos = scan(str, 'eE')
572  if (ipos > 0) then
573  exp = str(ipos:)
574  str = str(1:ipos - 1)
575  endif
576  lstr = len_trim(str)
577  do i = lstr, 1, -1
578  ch = str(i:i)
579  if (ch == '0') cycle
580  if (ch == '.') then
581  str = str(1:i)//'0'
582  if (ipos > 0) str = trim(str)//trim(exp)
583  exit
584  endif
585  str = str(1:i)
586  exit
587  end do
588  if (ipos > 0) str = trim(str)//trim(exp)
589 
590  end subroutine trimzero
591 
592 !**********************************************************************
593 
594  subroutine writeq_dr(unit, namestr, value, fmt)
596 ! Writes a string of the form <name> = value to unit
597 
598  real(kr8) :: value
599  integer :: unit
600  character(len=*) :: namestr, fmt
601  character(len=32) :: tempstr
602 
603  call writenum(value, tempstr, fmt)
604  call trimzero(tempstr)
605  write (unit, *) trim(namestr)//' = '//trim(tempstr)
606 
607  end subroutine writeq_dr
608 
609 !**********************************************************************
610 
611  subroutine writeq_sr(unit, namestr, value, fmt)
613 ! Writes a string of the form <name> = value to unit
614 
615  real(kr4) :: value
616  integer :: unit
617  character(len=*) :: namestr, fmt
618  character(len=32) :: tempstr
619 
620  call writenum(value, tempstr, fmt)
621  call trimzero(tempstr)
622  write (unit, *) trim(namestr)//' = '//trim(tempstr)
623 
624  end subroutine writeq_sr
625 
626 !**********************************************************************
627 
628  subroutine writeq_di(unit, namestr, ivalue, fmt)
630 ! Writes a string of the form <name> = ivalue to unit
631 
632  integer(ki8) :: ivalue
633  integer :: unit
634  character(len=*) :: namestr, fmt
635  character(len=32) :: tempstr
636  call writenum(ivalue, tempstr, fmt)
637  call trimzero(tempstr)
638  write (unit, *) trim(namestr)//' = '//trim(tempstr)
639 
640  end subroutine writeq_di
641 
642 !**********************************************************************
643 
644  subroutine writeq_si(unit, namestr, ivalue, fmt)
646 ! Writes a string of the form <name> = ivalue to unit
647 
648  integer(ki4) :: ivalue
649  integer :: unit
650  character(len=*) :: namestr, fmt
651  character(len=32) :: tempstr
652  call writenum(ivalue, tempstr, fmt)
653  call trimzero(tempstr)
654  write (unit, *) trim(namestr)//' = '//trim(tempstr)
655 
656  end subroutine writeq_si
657 
658 !**********************************************************************
659 
660  function is_letter(ch) result(res)
662 ! Returns .true. if ch is a letter and .false. otherwise
663 
664  character :: ch
665  logical :: res
666 
667  select case (ch)
668  case ('A':'Z', 'a':'z')
669  res = .true.
670  case default
671  res = .false.
672  end select
673  return
674 
675  end function is_letter
676 
677 !**********************************************************************
678 
679  function is_digit(ch) result(res)
681 ! Returns .true. if ch is a digit (0,1,...,9) and .false. otherwise
682 
683  character :: ch
684  logical :: res
685 
686  select case (ch)
687  case ('0':'9')
688  res = .true.
689  case default
690  res = .false.
691  end select
692  return
693 
694  end function is_digit
695 
696 !**********************************************************************
697 
698  subroutine split(str, delims, before, sep)
700 ! Routine finds the first instance of a character from 'delims' in the
701 ! the string 'str'. The characters before the found delimiter are
702 ! output in 'before'. The characters after the found delimiter are
703 ! output in 'str'. The optional output character 'sep' contains the
704 ! found delimiter. A delimiter in 'str' is treated like an ordinary
705 ! character if it is preceded by a backslash (\). If the backslash
706 ! character is desired in 'str', then precede it with another backslash.
707 
708  character(len=*) :: str, delims, before
709  character, optional :: sep
710  logical :: pres
711  character :: ch, cha
712 
713  pres = present(sep)
714  str = adjustl(str)
715  call compact(str)
716  lenstr = len_trim(str)
717  if (lenstr == 0) return ! string str is empty
718  k = 0
719  ibsl = 0 ! backslash initially inactive
720  before = ' '
721  do i = 1, lenstr
722  ch = str(i:i)
723  if (ibsl == 1) then ! backslash active
724  k = k + 1
725  before(k:k) = ch
726  ibsl = 0
727  cycle
728  end if
729  if (ch == '\') then ! backslash with backslash inactive
730  k = k + 1
731  before(k:k) = ch
732  ibsl = 1
733  cycle
734  end if
735  ipos = index(delims, ch)
736  if (ipos == 0) then ! character is not a delimiter
737  k = k + 1
738  before(k:k) = ch
739  cycle
740  end if
741  if (ch /= ' ') then ! character is a delimiter that is not a space
742  str = str(i + 1:)
743  if (pres) sep = ch
744  exit
745  end if
746  cha = str(i + 1:i + 1) ! character is a space delimiter
747  iposa = index(delims, cha)
748  if (iposa > 0) then ! next character is a delimiter
749  str = str(i + 2:)
750  if (pres) sep = cha
751  exit
752  else
753  str = str(i + 1:)
754  if (pres) sep = ch
755  exit
756  end if
757  end do
758  if (i >= lenstr) str = ''
759  str = adjustl(str) ! remove initial spaces
760  return
761 
762  end subroutine split
763 
764 !**********************************************************************
765 
766  subroutine removebksl(str)
767 
768 ! Removes backslash (\) characters. Double backslashes (\\) are replaced
769 ! by a single backslash.
770 
771  character(len=*):: str
772  character(len=1):: ch
773  character(len=len_trim(str))::outstr
774 
775  str = adjustl(str)
776  lenstr = len_trim(str)
777  outstr = ' '
778  k = 0
779  ibsl = 0 ! backslash initially inactive
780 
781  do i = 1, lenstr
782  ch = str(i:i)
783  if (ibsl == 1) then ! backslash active
784  k = k + 1
785  outstr(k:k) = ch
786  ibsl = 0
787  cycle
788  end if
789  if (ch == ') then ! backslash with backslash inactive
790  ibsl = 1
791  cycle
792  end if
793  k = k + 1
794  outstr(k:k) = ch ! non-backslash with backslash inactive
795  end do
796 
797  str = adjustl(outstr)
798 
799  end subroutine removebksl
800 
801 !**********************************************************************
802 
803 end module strings
subroutine, private writeq_dr(unit, namestr, value, fmt)
subroutine shiftstr(str, n)
integer, parameter kr4
integer, parameter ki4
integer, parameter kc4
subroutine insertstr(str, strins, loc)
logical function is_letter(ch)
integer, parameter ki8
subroutine removesp(str)
subroutine, private writeq_di(unit, namestr, ivalue, fmt)
subroutine, private writeq_si(unit, namestr, ivalue, fmt)
logical function is_digit(ch)
subroutine split(str, delims, before, sep)
subroutine match(str, ipos, imatch)
integer, parameter kc8
subroutine, private value_di(str, inum, ios)
subroutine, private write_si(inum, str, fmt)
subroutine, private writeq_sr(unit, namestr, value, fmt)
character(len=len_trim(str)) function uppercase(str)
subroutine trimzero(str)
subroutine readline(nunitr, line, ios)
subroutine, private value_dr(str, rnum, ios)
subroutine, private value_sr(str, rnum, ios)
subroutine, private write_sr(rnum, str, fmt)
subroutine delall(str, substr)
subroutine compact(str)
subroutine, private write_di(inum, str, fmt)
subroutine parse(str, delims, args, nargs)
subroutine, private write_dr(rnum, str, fmt)
character(len=len_trim(str)) function lowercase(str)
subroutine, private value_si(str, inum, ios)
subroutine delsubstr(str, substr)
integer, parameter kr8