31CHARACTER(len=*),
PARAMETER :: LOWER_CASE =
'abcdefghijklmnopqrstuvwxyz'
32CHARACTER(len=*),
PARAMETER :: UPPER_CASE =
'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
66 MODULE PROCEDURE int_to_char, byte_to_char, &
67 real_to_char, double_to_char, logical_to_char, &
68 char_to_char, char_to_char_miss
91 MODULE PROCEDURE trim_int_to_char, trim_int_to_char_miss, &
92 trim_byte_to_char, trim_byte_to_char_miss, &
93 trim_real_to_char, trim_real_to_char_miss, &
94 trim_double_to_char, trim_double_to_char_miss, trim_logical_to_char, &
95 trim_char_to_char, trim_char_to_char_miss
105 INTEGER :: align_type, ncols, nlines
106 INTEGER,
POINTER :: word_start(:), word_end(:)
107 CHARACTER(len=1),
POINTER :: paragraph(:,:)
116 MODULE PROCEDURE line_split_delete
181 MODULE PROCEDURE string_match, string_match_v
193 DOUBLE PRECISION :: min=0.0d0
194 DOUBLE PRECISION :: max=100.0d0
195 DOUBLE PRECISION,
PRIVATE :: curr=0.0d0
196 CHARACTER(len=512),
PRIVATE :: form=
'(''|'',I3.0,''%|'',A,''|'',10X,''|'')'
197 CHARACTER(len=1),
PRIVATE :: done=
'='
198 CHARACTER(len=1),
PRIVATE :: todo=
'-'
199 INTEGER,
PRIVATE :: barloc=8
200 INTEGER,
PRIVATE :: spin=0
202 PROCEDURE :: update => progress_line_update_d, progress_line_update_i
203 PROCEDURE :: alldone => progress_line_alldone
206CHARACTER(len=4),
PARAMETER :: progress_line_spin=
'-\|/'
211 fchar_to_cstr, fchar_to_cstr_alloc, cstr_to_fchar, uppercase, lowercase, &
212 align_center, l_nblnk, f_nblnk, word_split, &
213 line_split_new, line_split_get_nlines, line_split_get_line, &
214 suffixname, default_columns, wash_char, &
221ELEMENTAL FUNCTION int_to_char(in, miss, form)
RESULT(char)
222INTEGER,
INTENT(in) :: in
223CHARACTER(len=*),
INTENT(in),
OPTIONAL :: miss
224CHARACTER(len=*),
INTENT(in),
OPTIONAL :: form
225CHARACTER(len=11) :: char
227IF (
PRESENT(miss))
THEN
228 IF (.NOT.
c_e(in))
THEN
231 IF (
PRESENT(form))
THEN
238 IF (
PRESENT(form))
THEN
245END FUNCTION int_to_char
248FUNCTION trim_int_to_char(in)
RESULT(char)
249INTEGER,
INTENT(in) :: in
250CHARACTER(len=LEN_TRIM(to_char(in))) :: char
254END FUNCTION trim_int_to_char
257FUNCTION trim_int_to_char_miss(in, miss)
RESULT(char)
258INTEGER,
INTENT(in) :: in
259CHARACTER(len=*),
INTENT(in) :: miss
260CHARACTER(len=LEN_TRIM(to_char(in,miss=miss))) :: char
264END FUNCTION trim_int_to_char_miss
269ELEMENTAL FUNCTION byte_to_char(in, miss, form)
RESULT(char)
270INTEGER(kind=int_b),
INTENT(in) :: in
271CHARACTER(len=*),
INTENT(in),
OPTIONAL :: miss
272CHARACTER(len=*),
INTENT(in),
OPTIONAL :: form
273CHARACTER(len=11) :: char
275IF (
PRESENT(miss))
THEN
276 IF (.NOT.
c_e(in))
THEN
279 IF (
PRESENT(form))
THEN
286 IF (
PRESENT(form))
THEN
293END FUNCTION byte_to_char
296FUNCTION trim_byte_to_char(in)
RESULT(char)
297INTEGER(kind=int_b),
INTENT(in) :: in
298CHARACTER(len=LEN_TRIM(to_char(in))) :: char
302END FUNCTION trim_byte_to_char
305FUNCTION trim_byte_to_char_miss(in,miss)
RESULT(char)
306INTEGER(kind=int_b),
INTENT(in) :: in
307CHARACTER(len=*),
INTENT(in) :: miss
308CHARACTER(len=LEN_TRIM(to_char(in,miss=miss))) :: char
312END FUNCTION trim_byte_to_char_miss
318ELEMENTAL FUNCTION char_to_char(in)
RESULT(char)
319CHARACTER(len=*),
INTENT(in) :: in
320CHARACTER(len=LEN(in)) :: char
324END FUNCTION char_to_char
327ELEMENTAL FUNCTION char_to_char_miss(in, miss)
RESULT(char)
328CHARACTER(len=*),
INTENT(in) :: in
329CHARACTER(len=*),
INTENT(in) :: miss
330CHARACTER(len=MAX(LEN(in),LEN(miss))) :: char
338END FUNCTION char_to_char_miss
341FUNCTION trim_char_to_char(in)
result(char)
342CHARACTER(len=*),
INTENT(in) :: in
343CHARACTER(len=LEN_TRIM(in)) :: char
347END FUNCTION trim_char_to_char
350FUNCTION trim_char_to_char_miss(in, miss)
RESULT(char)
351CHARACTER(len=*),
INTENT(in) :: in
352CHARACTER(len=*),
INTENT(in) :: miss
353CHARACTER(len=LEN_TRIM(char_to_char_miss(in,miss))) :: char
355char = char_to_char_miss(in, miss)
357END FUNCTION trim_char_to_char_miss
362ELEMENTAL FUNCTION real_to_char(in, miss, form)
RESULT(char)
364CHARACTER(len=*),
INTENT(in),
OPTIONAL :: miss
365CHARACTER(len=*),
INTENT(in),
OPTIONAL :: form
366CHARACTER(len=15) :: char
368CHARACTER(len=15) :: tmpchar
370IF (
PRESENT(miss))
THEN
371 IF (.NOT.
c_e(in))
THEN
374 IF (
PRESENT(form))
THEN
377 WRITE(tmpchar,
'(G15.9)') in
378 char = adjustl(tmpchar)
382 IF (
PRESENT(form))
THEN
385 WRITE(tmpchar,
'(G15.9)') in
386 char = adjustl(tmpchar)
390END FUNCTION real_to_char
393FUNCTION trim_real_to_char(in)
RESULT(char)
395CHARACTER(len=LEN_TRIM(to_char(in))) :: char
397char = real_to_char(in)
399END FUNCTION trim_real_to_char
402FUNCTION trim_real_to_char_miss(in, miss)
RESULT(char)
404CHARACTER(len=*),
INTENT(in) :: miss
405CHARACTER(len=LEN_TRIM(to_char(in,miss=miss))) :: char
407char = real_to_char(in, miss=miss)
409END FUNCTION trim_real_to_char_miss
414ELEMENTAL FUNCTION double_to_char(in, miss, form)
RESULT(char)
415DOUBLE PRECISION,
INTENT(in) :: in
416CHARACTER(len=*),
INTENT(in),
OPTIONAL :: miss
417CHARACTER(len=*),
INTENT(in),
OPTIONAL :: form
418CHARACTER(len=24) :: char
420CHARACTER(len=24) :: tmpchar
422IF (
PRESENT(miss))
THEN
423 IF (.NOT.
c_e(in))
THEN
426 IF (
PRESENT(form))
THEN
429 WRITE(tmpchar,
'(G24.17)') in
430 char = adjustl(tmpchar)
434 IF (
PRESENT(form))
THEN
437 WRITE(tmpchar,
'(G24.17)') in
438 char = adjustl(tmpchar)
442END FUNCTION double_to_char
445FUNCTION trim_double_to_char(in)
RESULT(char)
446DOUBLE PRECISION,
INTENT(in) :: in
447CHARACTER(len=LEN_TRIM(to_char(in))) :: char
449char=double_to_char(in)
451END FUNCTION trim_double_to_char
454FUNCTION trim_double_to_char_miss(in, miss)
RESULT(char)
455DOUBLE PRECISION,
INTENT(in) :: in
456CHARACTER(len=*),
INTENT(in) :: miss
457CHARACTER(len=LEN_TRIM(to_char(in,miss=miss))) :: char
459char=double_to_char(in, miss=miss)
461END FUNCTION trim_double_to_char_miss
466ELEMENTAL FUNCTION logical_to_char(in, form)
RESULT(char)
467LOGICAL,
INTENT(in) :: in
468CHARACTER(len=*),
INTENT(in),
OPTIONAL :: form
469CHARACTER(len=1) :: char
471IF (
PRESENT(form))
THEN
474 WRITE(char,
'(L1)') in
477END FUNCTION logical_to_char
480ELEMENTAL FUNCTION trim_logical_to_char(in)
RESULT(char)
481LOGICAL,
INTENT(in) :: in
483CHARACTER(len=1) :: char
487END FUNCTION trim_logical_to_char
494ELEMENTAL FUNCTION c2i(string)
RESULT(num)
495CHARACTER(len=*),
INTENT(in) :: string
500IF (.NOT.
c_e(string))
THEN
502ELSE IF (len_trim(string) == 0)
THEN
505 READ(string,
'(I32)', iostat=lier)num
518ELEMENTAL FUNCTION c2r(string)
RESULT(num)
519CHARACTER(len=*),
INTENT(in) :: string
524IF (.NOT.
c_e(string))
THEN
526ELSE IF (len_trim(string) == 0)
THEN
529 READ(string,
'(F32.0)', iostat=lier)num
542ELEMENTAL FUNCTION c2d(string)
RESULT(num)
543CHARACTER(len=*),
INTENT(in) :: string
544DOUBLE PRECISION :: num
548IF (.NOT.
c_e(string))
THEN
550ELSE IF (len_trim(string) == 0)
THEN
553 READ(string,
'(F32.0)', iostat=lier)num
567FUNCTION fchar_to_cstr(fchar)
RESULT(cstr)
568CHARACTER(len=*),
INTENT(in) :: fchar
569INTEGER(kind=int_b) :: cstr(len(fchar)+1)
571cstr(1:len(fchar)) = transfer(fchar, cstr, len(fchar))
572cstr(len(fchar)+1) = 0
574END FUNCTION fchar_to_cstr
582SUBROUTINE fchar_to_cstr_alloc(fchar, pcstr)
583CHARACTER(len=*),
INTENT(in) :: fchar
584INTEGER(kind=int_b),
POINTER :: pcstr(:)
586ALLOCATE(pcstr(len(fchar)+1))
587pcstr(1:len(fchar)) = transfer(fchar, pcstr, len(fchar))
588pcstr(len(fchar)+1) = 0
590END SUBROUTINE fchar_to_cstr_alloc
596FUNCTION cstr_to_fchar(cstr)
RESULT(fchar)
597INTEGER(kind=int_b),
INTENT(in) :: cstr(:)
598CHARACTER(len=SIZE(cstr)-1) :: fchar
603fchar = transfer(cstr(1:
SIZE(cstr)-1), fchar)
604DO i = 1,
SIZE(cstr)-1
605 IF (fchar(i:i) == char(0))
THEN
611END FUNCTION cstr_to_fchar
615FUNCTION uppercase ( Input_String )
RESULT ( Output_String )
616CHARACTER( * ),
INTENT( IN ) :: input_string
617CHARACTER( LEN( Input_String ) ) :: output_string
622output_string = input_string
624DO i = 1, len( output_string )
626 n =
index( lower_case, output_string( i:i ) )
628 IF ( n /= 0 ) output_string( i:i ) = upper_case( n:n )
630END FUNCTION uppercase
634FUNCTION lowercase ( Input_String )
RESULT ( Output_String )
636CHARACTER( * ),
INTENT( IN ) :: input_string
637CHARACTER( LEN( Input_String ) ) :: output_string
642output_string = input_string
644DO i = 1, len( output_string )
646 n =
index( upper_case, output_string( i:i ) )
648 IF ( n /= 0 ) output_string( i:i ) = lower_case( n:n )
650END FUNCTION lowercase
658ELEMENTAL FUNCTION align_center(input_string)
RESULT(aligned)
659CHARACTER(len=*),
INTENT(in) :: input_string
661CHARACTER(len=LEN(input_string)) :: aligned
665n1 = f_nblnk(input_string)
666n2 = len(input_string)-l_nblnk(input_string)+1
669aligned((n1+n2)/2:) = input_string(n1:)
671END FUNCTION align_center
679ELEMENTAL FUNCTION l_nblnk(input_string, blnk)
RESULT(nblnk)
680CHARACTER(len=*),
INTENT(in) :: input_string
681CHARACTER(len=1),
INTENT(in),
OPTIONAL :: blnk
683CHARACTER(len=1) :: lblnk
686IF (
PRESENT(blnk))
THEN
692DO nblnk = len(input_string), 1, -1
693 IF (input_string(nblnk:nblnk) /= lblnk)
RETURN
702ELEMENTAL FUNCTION f_nblnk(input_string, blnk)
RESULT(nblnk)
703CHARACTER(len=*),
INTENT(in) :: input_string
704CHARACTER(len=1),
INTENT(in),
OPTIONAL :: blnk
706CHARACTER(len=1) :: lblnk
709IF (
PRESENT(blnk))
THEN
715DO nblnk = 1, len(input_string)
716 IF (input_string(nblnk:nblnk) /= lblnk)
RETURN
728FUNCTION word_split(input_string, word_start, word_end, sep)
RESULT(nword)
729CHARACTER(len=*),
INTENT(in) :: input_string
730INTEGER,
POINTER,
OPTIONAL :: word_start(:)
731INTEGER,
POINTER,
OPTIONAL :: word_end(:)
732CHARACTER(len=1),
OPTIONAL :: sep
737INTEGER,
POINTER :: lsv(:), lev(:)
738CHARACTER(len=1) :: lsep
740IF (
PRESENT(sep))
THEN
749 ls = f_nblnk(input_string(le+1:), lsep) + le
750 IF (ls > len(input_string))
EXIT
751 le =
index(input_string(ls:), lsep)
753 le = len(input_string)
760IF (.NOT.
PRESENT(word_start) .AND. .NOT.
PRESENT(word_end))
RETURN
762ALLOCATE(lsv(nword), lev(nword))
766 ls = f_nblnk(input_string(le+1:), lsep) + le
767 IF (ls > len(input_string))
EXIT
768 le =
index(input_string(ls:), lsep)
770 le = len(input_string)
779IF (
PRESENT(word_start))
THEN
784IF (
PRESENT(word_end))
THEN
790END FUNCTION word_split
797FUNCTION line_split_new(line, ncols)
RESULT(this)
798CHARACTER(len=*),
INTENT(in) :: line
799INTEGER,
INTENT(in),
OPTIONAL :: ncols
803INTEGER :: nw, nwords, nlines, columns_in_line, words_in_line, ncols_next_word
805IF (
PRESENT(ncols))
THEN
808 this%ncols = default_columns()
811nwords = word_split(line, this%word_start, this%word_end)
818 DO WHILE(nw < nwords)
820 ncols_next_word = this%word_end(nw) - this%word_start(nw) + 1
821 IF (words_in_line > 0) ncols_next_word = ncols_next_word + 1
822 IF (columns_in_line + ncols_next_word <= this%ncols .OR. &
823 words_in_line == 0)
THEN
824 columns_in_line = columns_in_line + ncols_next_word
825 words_in_line = words_in_line + 1
835ALLOCATE(this%paragraph(this%ncols, nlines))
843 DO WHILE(nw < nwords)
845 ncols_next_word = this%word_end(nw) - this%word_start(nw) + 1
846 IF (words_in_line > 0) ncols_next_word = ncols_next_word + 1
847 IF (columns_in_line + ncols_next_word <= this%ncols .OR. &
848 words_in_line == 0)
THEN
849 columns_in_line = columns_in_line + ncols_next_word
851 IF (columns_in_line <= this%ncols)
THEN
852 IF (words_in_line > 0)
THEN
853 this%paragraph(columns_in_line-ncols_next_word+1:columns_in_line,nlines+1) = &
854 transfer(
' '//line(this%word_start(nw):this%word_end(nw)), this%paragraph)
856 this%paragraph(columns_in_line-ncols_next_word+1:columns_in_line,nlines+1) = &
857 transfer(line(this%word_start(nw):this%word_end(nw)), this%paragraph)
860 this%paragraph(1:this%ncols,nlines+1) = &
861 transfer(line(this%word_start(nw):this%word_start(nw)+this%ncols-1), this%paragraph)
863 words_in_line = words_in_line + 1
872END FUNCTION line_split_new
878SUBROUTINE line_split_delete(this)
881IF (
ASSOCIATED(this%paragraph))
DEALLOCATE(this%paragraph)
882IF (
ASSOCIATED(this%word_start))
DEALLOCATE(this%word_start)
883IF (
ASSOCIATED(this%word_end))
DEALLOCATE(this%word_end)
885END SUBROUTINE line_split_delete
889FUNCTION line_split_get_nlines(this)
RESULT(nlines)
894IF (
ASSOCIATED(this%paragraph))
THEN
895 nlines =
SIZE(this%paragraph, 2)
900END FUNCTION line_split_get_nlines
907FUNCTION line_split_get_line(this, nline)
RESULT(line)
909INTEGER,
INTENT(in) :: nline
911CHARACTER(len=SIZE(this%paragraph, 1)) :: line
912IF (nline > 0 .AND. nline <=
SIZE(this%paragraph, 2))
THEN
913 line = transfer(this%paragraph(:,nline), line)
918END FUNCTION line_split_get_line
926FUNCTION default_columns()
RESULT(cols)
929INTEGER,
PARAMETER :: defaultcols = 80
930INTEGER,
PARAMETER :: maxcols = 256
931CHARACTER(len=10) :: ccols
934CALL getenv(
'COLUMNS', ccols)
935IF (ccols ==
'')
RETURN
937READ(ccols,
'(I10)', err=100) cols
938cols = min(cols, maxcols)
939IF (cols <= 0) cols = defaultcols
942100 cols = defaultcols
944END FUNCTION default_columns
948FUNCTION suffixname ( Input_String )
RESULT ( Output_String )
950CHARACTER( * ),
INTENT( IN ) :: input_string
951CHARACTER( LEN( Input_String ) ) :: output_string
956i =
index(input_string,
".",back=.true.)
957if (i > 0 .and. i < len(input_string)) output_string= input_string(i+1:)
959END FUNCTION suffixname
968ELEMENTAL FUNCTION wash_char(in, goodchar, badchar)
RESULT(char)
969CHARACTER(len=*),
INTENT(in) :: in
970CHARACTER(len=*),
INTENT(in),
OPTIONAL :: badchar
971CHARACTER(len=*),
INTENT(in),
OPTIONAL :: goodchar
972integer,
allocatable :: igoodchar(:)
973integer,
allocatable :: ibadchar(:)
975CHARACTER(len=len(in)) :: char,charr,charrr
982if (
present(goodchar))
then
984allocate(igoodchar(len(goodchar)))
986 do i =1, len(goodchar)
987 igoodchar=ichar(goodchar(i:i))
993 if (any(ia == igoodchar))
then
995 charrr(nchar:nchar)=achar(ia)
1009if (
present(badchar))
then
1011allocate(ibadchar(len(badchar)))
1013 do i =1, len(badchar)
1014 ibadchar=ichar(badchar(i:i))
1019 ia = ichar(charrr(i:i))
1020 if (.not. any(ia == ibadchar))
then
1022 charr(nchar:nchar)=achar(ia)
1035if (.not.
present(goodchar) .and. .not.
present(badchar))
then
1039 ia = ichar(charr(i:i))
1040 if ((ia >= 65 .and. ia <= 90) .or. &
1041 (ia >= 97 .and. ia <= 122))
then
1043 char(nchar:nchar)=achar(ia)
1054END FUNCTION wash_char
1097function string_match_v( string, pattern )
result(match)
1098character(len=*),
intent(in) :: string(:)
1099character(len=*),
intent(in) :: pattern
1100logical ::
match(size(string))
1105 match(i)=string_match(string(i),pattern)
1108end function string_match_v
1114recursive function string_match( string, pattern )
result(match)
1115 character(len=*),
intent(in) :: string
1116 character(len=*),
intent(in) :: pattern
1121 character(len=1),
parameter :: backslash =
'\\'
1122 character(len=1),
parameter :: star =
'*'
1123 character(len=1),
parameter :: question =
'?'
1125 character(len=len(pattern)) :: literal
1136 ptrim = len_trim( pattern )
1137 strim = len_trim( string )
1145 do while ( p <= ptrim )
1146 select case ( pattern(p:p) )
1148 if ( ll .ne. 0 )
exit
1151 if ( ll .ne. 0 )
exit
1157 literal(ll:ll) = pattern(p:p)
1160 literal(ll:ll) = pattern(p:p)
1169 if ( method == 0 )
then
1173 if ( strim == 0 .and. ptrim == 0 )
then
1180 if ( string(start:min(strim,start+ll-1)) == literal(1:ll) )
then
1182 match = string_match( string(start:), pattern(p:) )
1188 if ( method == 1 )
then
1195 do while ( start <= strim )
1196 k =
index( string(start:), literal(1:ll) )
1198 start = start + k + ll - 1
1199 match = string_match( string(start:), pattern(p:) )
1210 if ( method == 2 .and. ll > 0 )
then
1214 if ( string(start:min(strim,start+ll-1)) == literal(1:ll) )
then
1215 match = string_match( string(start+ll:), pattern(p:) )
1219end function string_match
1222SUBROUTINE print_status_line(line)
1223CHARACTER(len=*),
INTENT(in) :: line
1224CHARACTER(len=1),
PARAMETER :: cr=char(13)
1225WRITE(stdout_unit,
'(2A)',advance=
'no')cr,trim(line)
1227END SUBROUTINE print_status_line
1229SUBROUTINE done_status_line()
1230WRITE(stdout_unit,
'()')
1231END SUBROUTINE done_status_line
1242SUBROUTINE progress_line_update_d(this, val)
1244DOUBLE PRECISION,
INTENT(in) :: val
1247CHARACTER(len=512) :: line
1249IF (this%curr >= this%max)
RETURN
1251this%curr = max(this%min, min(this%max, val))
1252this%spin = mod(this%spin+1, 4)
1255vint = nint((this%curr-this%min)/(this%max-this%min)*100.d0)
1256WRITE(line,this%form)vint, &
1257 progress_line_spin(this%spin+1:this%spin+1)
1261 line(this%barloc+i:this%barloc+i) = this%done
1264 line(this%barloc+i:this%barloc+i) = this%todo
1266CALL print_status_line(line)
1267IF (this%curr >= this%max)
CALL done_status_line()
1269END SUBROUTINE progress_line_update_d
1276SUBROUTINE progress_line_update_i(this, val)
1278INTEGER,
INTENT(in) :: val
1280CALL progress_line_update_d(this, dble(val))
1282END SUBROUTINE progress_line_update_i
1289SUBROUTINE progress_line_alldone(this)
1291CALL progress_line_update_d(this, this%max)
1292END SUBROUTINE progress_line_alldone
Destructor for the line_split class.
Tries to match the given string with the pattern Result: .true.
Set of functions that return a trimmed CHARACTER representation of the input variable.
Set of functions that return a CHARACTER representation of the input variable.
Function to check whether a value is missing or not.
Utilities for CHARACTER variables.
Definition of constants related to I/O units.
Definition of constants to be used for declaring variables of a desired type.
Definitions of constants and functions for working with missing values.
Class that allows splitting a long line into shorter lines of equal length at the occurrence of a spe...
Class to print a progress bar on the screen.