7 integer,
parameter ::
kr4 = selected_real_kind(6, 37)
8 integer,
parameter ::
kr8 = selected_real_kind(15, 307)
12 integer,
parameter ::
ki4 = selected_int_kind(9)
13 integer,
parameter ::
ki8 = selected_int_kind(18)
70 subroutine parse(str, delims, args, nargs)
77 character(len=*) :: str, delims
78 character(len=len_trim(str)) :: strsav
79 character(len=*),
dimension(:) :: args
88 lenstr = len_trim(str)
89 if (lenstr == 0)
return 93 if (len_trim(str) == 0)
exit 95 call split(str, delims, args(nargs))
96 call removebksl(args(nargs))
109 character(len=*):: str
110 character(len=1):: ch
111 character(len=len_trim(str)):: outstr
114 lenstr = len_trim(str)
141 str = adjustl(outstr)
151 character(len=*):: str
152 character(len=1):: ch
153 character(len=len_trim(str))::outstr
156 lenstr = len_trim(str)
172 str = adjustl(outstr)
182 character(len=*)::str
187 ipos = scan(str,
'Ee')
188 if (.not.
is_digit(str(ilen:ilen)) .and. ipos /= 0)
then 192 read (str, *, iostat=ios) rnum
202 character(len=*)::str
207 if (abs(rnumd) > huge(rnum))
then 211 if (abs(rnumd) < tiny(rnum)) rnum = 0.0_kr4
212 rnum =
real(rnumd,
kr4)
222 character(len=*)::str
227 if (abs(rnum) > huge(
real(inum,
kr8))) then
231 inum = nint(rnum,
ki8)
241 character(len=*)::str
246 if (abs(rnum) > huge(inum))
then 250 inum = nint(rnum,
ki4)
263 character(len=*):: str
267 if (nabs >= lenstr)
then 268 str = repeat(
' ', lenstr)
271 if (n < 0) str = str(nabs + 1:)//repeat(
' ', nabs)
272 if (n > 0) str = repeat(
' ', nabs)//str(:lenstr - nabs)
286 character(len=*):: str, strins
287 character(len=len(str))::tempstr
289 lenstrins = len_trim(strins)
292 tempstr(1:lenstrins) = strins(1:lenstrins)
306 character(len=*):: str, substr
308 lensubstr = len_trim(substr)
309 ipos = index(str, substr)
310 if (ipos == 0)
return 312 str = str(lensubstr + 1:)
314 str = str(:ipos - 1)//str(ipos + lensubstr:)
322 subroutine delall(str, substr)
327 character(len=*):: str, substr
329 lensubstr = len_trim(substr)
331 ipos = index(str, substr)
334 str = str(lensubstr + 1:)
336 str = str(:ipos - 1)//str(ipos + lensubstr:)
349 character(len=*):: str
350 character(len=len_trim(str)):: ucstr
353 ioffset = iachar(
'A') - iachar(
'a')
357 iav = iachar(str(i:i))
358 if (iquote == 0 .and. (iav == 34 .or. iav == 39))
then 363 if (iquote == 1 .and. iav == iqc)
then 367 if (iquote == 1) cycle
368 if (iav >= iachar(
'a') .and. iav <= iachar(
'z'))
then 369 ucstr(i:i) = achar(iav + ioffset)
371 ucstr(i:i) = str(i:i)
384 character(len=*):: str
385 character(len=len_trim(str)):: lcstr
388 ioffset = iachar(
'A') - iachar(
'a')
392 iav = iachar(str(i:i))
393 if (iquote == 0 .and. (iav == 34 .or. iav == 39))
then 398 if (iquote == 1 .and. iav == iqc)
then 402 if (iquote == 1) cycle
403 if (iav >= iachar(
'A') .and. iav <= iachar(
'Z'))
then 404 lcstr(i:i) = achar(iav - ioffset)
406 lcstr(i:i) = str(i:i)
415 subroutine readline(nunitr, line, ios)
420 character(len=*):: line
423 read (nunitr,
'(a)', iostat=ios) line
426 ipos = index(line,
'!')
428 if (ipos /= 0) line = line(:ipos - 1)
429 if (len_trim(line) /= 0)
exit 437 subroutine match(str, ipos, imatch)
442 character(len=*) :: str
443 character :: delim1, delim2, ch
445 lenstr = len_trim(str)
446 delim1 = str(ipos:ipos)
449 idelim2 = iachar(delim1) + 1
454 idelim2 = iachar(delim1) - 1
459 idelim2 = iachar(delim1) + 2
464 idelim2 = iachar(delim1) - 2
469 write (*, *) delim1,
' is not a valid delimiter' 472 if (istart < 1 .or. istart > lenstr)
then 473 write (*, *) delim1,
' has no matching delimiter' 476 delim2 = achar(idelim2)
479 do i = istart, iend, inc
481 if (ch /= delim1 .and. ch /= delim2) cycle
482 if (ch == delim1) isum = isum + 1
483 if (ch == delim2) isum = isum - 1
487 write (*, *) delim1,
' has no matching delimiter' 503 character(len=*) :: str, fmt
504 character(len=80) :: formt
506 formt =
'('//trim(fmt)//
')' 507 write (str, formt) rnum
519 character(len=*) :: str, fmt
520 character(len=80) :: formt
522 formt =
'('//trim(fmt)//
')' 523 write (str, formt) rnum
535 character(len=*) :: str, fmt
536 character(len=80) :: formt
538 formt =
'('//trim(fmt)//
')' 539 write (str, formt) inum
551 character(len=*) :: str, fmt
552 character(len=80) :: formt
554 formt =
'('//trim(fmt)//
')' 555 write (str, formt) inum
567 character(len=*) :: str
569 character(len=10) :: exp
571 ipos = scan(str,
'eE')
574 str = str(1:ipos - 1)
582 if (ipos > 0) str = trim(str)//trim(exp)
588 if (ipos > 0) str = trim(str)//trim(exp)
594 subroutine writeq_dr(unit, namestr, value, fmt)
600 character(len=*) :: namestr, fmt
601 character(len=32) :: tempstr
605 write (unit, *) trim(namestr)//
' = '//trim(tempstr)
611 subroutine writeq_sr(unit, namestr, value, fmt)
617 character(len=*) :: namestr, fmt
618 character(len=32) :: tempstr
622 write (unit, *) trim(namestr)//
' = '//trim(tempstr)
628 subroutine writeq_di(unit, namestr, ivalue, fmt)
632 integer(ki8) :: ivalue
634 character(len=*) :: namestr, fmt
635 character(len=32) :: tempstr
638 write (unit, *) trim(namestr)//
' = '//trim(tempstr)
644 subroutine writeq_si(unit, namestr, ivalue, fmt)
648 integer(ki4) :: ivalue
650 character(len=*) :: namestr, fmt
651 character(len=32) :: tempstr
654 write (unit, *) trim(namestr)//
' = '//trim(tempstr)
668 case (
'A':
'Z',
'a':
'z')
698 subroutine split(str, delims, before, sep)
708 character(len=*) :: str, delims, before
709 character,
optional :: sep
716 lenstr = len_trim(str)
717 if (lenstr == 0)
return 729 if (ch ==
'\') then ! backslash with backslash inactive 735 ipos = index(delims, ch) 736 if (ipos == 0) then ! character is not a delimiter 741 if (ch /= ' ') then ! character is a delimiter that is not a space 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 758 if (i >= lenstr) str = '' 759 str = adjustl(str) ! remove initial spaces 764 !********************************************************************** 766 subroutine removebksl(str) 768 ! Removes backslash (\) characters. Double backslashes (\\) are replaced 769 ! by a single backslash. 771 character(len=*):: str 772 character(len=1):: ch 773 character(len=len_trim(str))::outstr 776 lenstr = len_trim(str) 779 ibsl = 0 ! backslash initially inactive 783 if (ibsl == 1) then ! backslash active 797 str = adjustl(outstr)
799 end subroutine removebksl
subroutine, private writeq_dr(unit, namestr, value, fmt)
subroutine shiftstr(str, n)
subroutine insertstr(str, strins, loc)
logical function is_letter(ch)
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)
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 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, 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)