31 CHARACTER(len=*),
PARAMETER :: LOWER_CASE =
'abcdefghijklmnopqrstuvwxyz'
32 CHARACTER(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
206 CHARACTER(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, &
221 ELEMENTAL FUNCTION int_to_char(in, miss, form)
RESULT(char)
222 INTEGER,
INTENT(in) :: in
223 CHARACTER(len=*),
INTENT(in),
OPTIONAL :: miss
224 CHARACTER(len=*),
INTENT(in),
OPTIONAL :: form
225 CHARACTER(len=11) :: char
227 IF (
PRESENT(miss))
THEN
228 IF (.NOT.
c_e(in))
THEN
231 IF (
PRESENT(form))
THEN
238 IF (
PRESENT(form))
THEN
245 END FUNCTION int_to_char
248 FUNCTION trim_int_to_char(in)
RESULT(char)
249 INTEGER,
INTENT(in) :: in
250 CHARACTER(len=LEN_TRIM(to_char(in))) :: char
254 END FUNCTION trim_int_to_char
257 FUNCTION trim_int_to_char_miss(in, miss)
RESULT(char)
258 INTEGER,
INTENT(in) :: in
259 CHARACTER(len=*),
INTENT(in) :: miss
260 CHARACTER(len=LEN_TRIM(to_char(in,miss=miss))) :: char
264 END FUNCTION trim_int_to_char_miss
269 ELEMENTAL FUNCTION byte_to_char(in, miss, form)
RESULT(char)
270 INTEGER(kind=int_b),
INTENT(in) :: in
271 CHARACTER(len=*),
INTENT(in),
OPTIONAL :: miss
272 CHARACTER(len=*),
INTENT(in),
OPTIONAL :: form
273 CHARACTER(len=11) :: char
275 IF (
PRESENT(miss))
THEN
276 IF (.NOT.
c_e(in))
THEN
279 IF (
PRESENT(form))
THEN
286 IF (
PRESENT(form))
THEN
293 END FUNCTION byte_to_char
296 FUNCTION trim_byte_to_char(in)
RESULT(char)
297 INTEGER(kind=int_b),
INTENT(in) :: in
298 CHARACTER(len=LEN_TRIM(to_char(in))) :: char
302 END FUNCTION trim_byte_to_char
305 FUNCTION trim_byte_to_char_miss(in,miss)
RESULT(char)
306 INTEGER(kind=int_b),
INTENT(in) :: in
307 CHARACTER(len=*),
INTENT(in) :: miss
308 CHARACTER(len=LEN_TRIM(to_char(in,miss=miss))) :: char
312 END FUNCTION trim_byte_to_char_miss
318 elemental_unlessxlf
FUNCTION char_to_char(in)
RESULT(char)
319 CHARACTER(len=*),
INTENT(in) :: in
320 CHARACTER(len=LEN(in)) :: char
324 END FUNCTION char_to_char
327 elemental_unlessxlf
FUNCTION char_to_char_miss(in, miss)
RESULT(char)
328 CHARACTER(len=*),
INTENT(in) :: in
329 CHARACTER(len=*),
INTENT(in) :: miss
330 CHARACTER(len=MAX(LEN(in),LEN(miss))) :: char
338 END FUNCTION char_to_char_miss
341 FUNCTION trim_char_to_char(in)
result(char)
342 CHARACTER(len=*),
INTENT(in) :: in
343 CHARACTER(len=LEN_TRIM(in)) :: char
347 END FUNCTION trim_char_to_char
350 FUNCTION trim_char_to_char_miss(in, miss)
RESULT(char)
351 CHARACTER(len=*),
INTENT(in) :: in
352 CHARACTER(len=*),
INTENT(in) :: miss
353 CHARACTER(len=LEN_TRIM(char_to_char_miss(in,miss))) :: char
355 char = char_to_char_miss(in, miss)
357 END FUNCTION trim_char_to_char_miss
362 ELEMENTAL FUNCTION real_to_char(in, miss, form)
RESULT(char)
363 REAL,
INTENT(in) :: in
364 CHARACTER(len=*),
INTENT(in),
OPTIONAL :: miss
365 CHARACTER(len=*),
INTENT(in),
OPTIONAL :: form
366 CHARACTER(len=15) :: char
368 CHARACTER(len=15) :: tmpchar
370 IF (
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)
390 END FUNCTION real_to_char
393 FUNCTION trim_real_to_char(in)
RESULT(char)
394 REAL,
INTENT(in) :: in
395 CHARACTER(len=LEN_TRIM(to_char(in))) :: char
397 char = real_to_char(in)
399 END FUNCTION trim_real_to_char
402 FUNCTION trim_real_to_char_miss(in, miss)
RESULT(char)
403 REAL,
INTENT(in) :: in
404 CHARACTER(len=*),
INTENT(in) :: miss
405 CHARACTER(len=LEN_TRIM(to_char(in,miss=miss))) :: char
407 char = real_to_char(in, miss=miss)
409 END FUNCTION trim_real_to_char_miss
414 ELEMENTAL FUNCTION double_to_char(in, miss, form)
RESULT(char)
415 DOUBLE PRECISION,
INTENT(in) :: in
416 CHARACTER(len=*),
INTENT(in),
OPTIONAL :: miss
417 CHARACTER(len=*),
INTENT(in),
OPTIONAL :: form
418 CHARACTER(len=24) :: char
420 CHARACTER(len=24) :: tmpchar
422 IF (
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)
442 END FUNCTION double_to_char
445 FUNCTION trim_double_to_char(in)
RESULT(char)
446 DOUBLE PRECISION,
INTENT(in) :: in
447 CHARACTER(len=LEN_TRIM(to_char(in))) :: char
449 char=double_to_char(in)
451 END FUNCTION trim_double_to_char
454 FUNCTION trim_double_to_char_miss(in, miss)
RESULT(char)
455 DOUBLE PRECISION,
INTENT(in) :: in
456 CHARACTER(len=*),
INTENT(in) :: miss
457 CHARACTER(len=LEN_TRIM(to_char(in,miss=miss))) :: char
459 char=double_to_char(in, miss=miss)
461 END FUNCTION trim_double_to_char_miss
466 ELEMENTAL FUNCTION logical_to_char(in, form)
RESULT(char)
467 LOGICAL,
INTENT(in) :: in
468 CHARACTER(len=*),
INTENT(in),
OPTIONAL :: form
469 CHARACTER(len=1) :: char
471 IF (
PRESENT(form))
THEN
474 WRITE(char,
'(L1)') in
477 END FUNCTION logical_to_char
480 ELEMENTAL FUNCTION trim_logical_to_char(in)
RESULT(char)
481 LOGICAL,
INTENT(in) :: in
483 CHARACTER(len=1) :: char
485 WRITE(char,
'(L1)') in
487 END FUNCTION trim_logical_to_char
494 ELEMENTAL FUNCTION c2i(string)
RESULT(num)
495 CHARACTER(len=*),
INTENT(in) :: string
500 IF (.NOT.
c_e(string))
THEN
502 ELSE IF (len_trim(string) == 0)
THEN
505 READ(string,
'(I32)', iostat=lier)num
518 ELEMENTAL FUNCTION c2r(string)
RESULT(num)
519 CHARACTER(len=*),
INTENT(in) :: string
524 IF (.NOT.
c_e(string))
THEN
526 ELSE IF (len_trim(string) == 0)
THEN
529 READ(string,
'(F32.0)', iostat=lier)num
542 ELEMENTAL FUNCTION c2d(string)
RESULT(num)
543 CHARACTER(len=*),
INTENT(in) :: string
544 DOUBLE PRECISION :: num
548 IF (.NOT.
c_e(string))
THEN
550 ELSE IF (len_trim(string) == 0)
THEN
553 READ(string,
'(F32.0)', iostat=lier)num
567 FUNCTION fchar_to_cstr(fchar)
RESULT(cstr)
568 CHARACTER(len=*),
INTENT(in) :: fchar
569 INTEGER(kind=int_b) :: cstr(len(fchar)+1)
571 cstr(1:len(fchar)) = transfer(fchar, cstr, len(fchar))
572 cstr(len(fchar)+1) = 0
574 END FUNCTION fchar_to_cstr
582 SUBROUTINE fchar_to_cstr_alloc(fchar, pcstr)
583 CHARACTER(len=*),
INTENT(in) :: fchar
584 INTEGER(kind=int_b),
POINTER :: pcstr(:)
586 ALLOCATE(pcstr(len(fchar)+1))
587 pcstr(1:len(fchar)) = transfer(fchar, pcstr, len(fchar))
588 pcstr(len(fchar)+1) = 0
590 END SUBROUTINE fchar_to_cstr_alloc
596 FUNCTION cstr_to_fchar(cstr)
RESULT(fchar)
597 INTEGER(kind=int_b),
INTENT(in) :: cstr(:)
598 CHARACTER(len=SIZE(cstr)-1) :: fchar
603 fchar = transfer(cstr(1:
SIZE(cstr)-1), fchar)
604 DO i = 1,
SIZE(cstr)-1
605 IF (fchar(i:i) == char(0))
THEN
611 END FUNCTION cstr_to_fchar
615 FUNCTION uppercase ( Input_String )
RESULT ( Output_String )
616 CHARACTER( * ),
INTENT( IN ) :: input_string
617 CHARACTER( LEN( Input_String ) ) :: output_string
622 output_string = input_string
624 DO 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 )
630 END FUNCTION uppercase
634 FUNCTION lowercase ( Input_String )
RESULT ( Output_String )
636 CHARACTER( * ),
INTENT( IN ) :: input_string
637 CHARACTER( LEN( Input_String ) ) :: output_string
642 output_string = input_string
644 DO 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 )
650 END FUNCTION lowercase
658 elemental_unlessxlf
FUNCTION align_center(input_string)
RESULT(aligned)
659 CHARACTER(len=*),
INTENT(in) :: input_string
661 CHARACTER(len=LEN(input_string)) :: aligned
665 n1 = f_nblnk(input_string)
666 n2 = len(input_string)-l_nblnk(input_string)+1
669 aligned((n1+n2)/2:) = input_string(n1:)
671 END FUNCTION align_center
679 ELEMENTAL FUNCTION l_nblnk(input_string, blnk)
RESULT(nblnk)
680 CHARACTER(len=*),
INTENT(in) :: input_string
681 CHARACTER(len=1),
INTENT(in),
OPTIONAL :: blnk
683 CHARACTER(len=1) :: lblnk
686 IF (
PRESENT(blnk))
THEN
692 DO nblnk = len(input_string), 1, -1
693 IF (input_string(nblnk:nblnk) /= lblnk)
RETURN
702 ELEMENTAL FUNCTION f_nblnk(input_string, blnk)
RESULT(nblnk)
703 CHARACTER(len=*),
INTENT(in) :: input_string
704 CHARACTER(len=1),
INTENT(in),
OPTIONAL :: blnk
706 CHARACTER(len=1) :: lblnk
709 IF (
PRESENT(blnk))
THEN
715 DO nblnk = 1, len(input_string)
716 IF (input_string(nblnk:nblnk) /= lblnk)
RETURN
728 FUNCTION word_split(input_string, word_start, word_end, sep)
RESULT(nword)
729 CHARACTER(len=*),
INTENT(in) :: input_string
730 INTEGER,
POINTER,
OPTIONAL :: word_start(:)
731 INTEGER,
POINTER,
OPTIONAL :: word_end(:)
732 CHARACTER(len=1),
OPTIONAL :: sep
737 INTEGER,
POINTER :: lsv(:), lev(:)
738 CHARACTER(len=1) :: lsep
740 IF (
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)
760 IF (.NOT.
PRESENT(word_start) .AND. .NOT.
PRESENT(word_end))
RETURN
762 ALLOCATE(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)
779 IF (
PRESENT(word_start))
THEN
784 IF (
PRESENT(word_end))
THEN
790 END FUNCTION word_split
797 FUNCTION line_split_new(line, ncols)
RESULT(this)
798 CHARACTER(len=*),
INTENT(in) :: line
799 INTEGER,
INTENT(in),
OPTIONAL :: ncols
803 INTEGER :: nw, nwords, nlines, columns_in_line, words_in_line, ncols_next_word
805 IF (
PRESENT(ncols))
THEN
808 this%ncols = default_columns()
811 nwords = word_split(line, this%word_start, this%word_end)
815 DO WHILE(nw < nwords)
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
835 ALLOCATE(this%paragraph(this%ncols, nlines))
840 DO WHILE(nw < nwords)
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
872 END FUNCTION line_split_new
878 SUBROUTINE line_split_delete(this)
881 IF (
ASSOCIATED(this%paragraph))
DEALLOCATE(this%paragraph)
882 IF (
ASSOCIATED(this%word_start))
DEALLOCATE(this%word_start)
883 IF (
ASSOCIATED(this%word_end))
DEALLOCATE(this%word_end)
885 END SUBROUTINE line_split_delete
889 FUNCTION line_split_get_nlines(this)
RESULT(nlines)
894 IF (
ASSOCIATED(this%paragraph))
THEN
895 nlines =
SIZE(this%paragraph, 2)
900 END FUNCTION line_split_get_nlines
907 FUNCTION line_split_get_line(this, nline)
RESULT(line)
909 INTEGER,
INTENT(in) :: nline
911 CHARACTER(len=SIZE(this%paragraph, 1)) :: line
912 IF (nline > 0 .AND. nline <=
SIZE(this%paragraph, 2))
THEN
913 line = transfer(this%paragraph(:,nline), line)
918 END FUNCTION line_split_get_line
926 FUNCTION default_columns()
RESULT(cols)
929 INTEGER,
PARAMETER :: defaultcols = 80
930 INTEGER,
PARAMETER :: maxcols = 256
931 CHARACTER(len=10) :: ccols
934 CALL getenv(
'COLUMNS', ccols)
935 IF (ccols ==
'')
RETURN
937 READ(ccols,
'(I10)', err=100) cols
938 cols = min(cols, maxcols)
939 IF (cols <= 0) cols = defaultcols
942 100 cols = defaultcols
944 END FUNCTION default_columns
948 FUNCTION suffixname ( Input_String )
RESULT ( Output_String )
950 CHARACTER( * ),
INTENT( IN ) :: input_string
951 CHARACTER( LEN( Input_String ) ) :: output_string
956 i =
index(input_string,
".",back=.true.)
957 if (i > 0 .and. i < len(input_string)) output_string= input_string(i+1:)
959 END FUNCTION suffixname
968 elemental_unlessxlf
FUNCTION wash_char(in, goodchar, badchar)
RESULT(char)
969 CHARACTER(len=*),
INTENT(in) :: in
970 CHARACTER(len=*),
INTENT(in),
OPTIONAL :: badchar
971 CHARACTER(len=*),
INTENT(in),
OPTIONAL :: goodchar
972 integer,
allocatable :: igoodchar(:)
973 integer,
allocatable :: ibadchar(:)
975 CHARACTER(len=len(in)) :: char,charr,charrr
976 INTEGER :: i,ia,nchar
982 if (
present(goodchar))
then
984 allocate(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)
999 deallocate(igoodchar)
1009 if (
present(badchar))
then
1011 allocate(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)
1026 deallocate(ibadchar)
1035 if (.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)
1054 END FUNCTION wash_char
1097 function string_match_v( string, pattern )
result(match)
1098 character(len=*),
intent(in) :: string(:)
1099 character(len=*),
intent(in) :: pattern
1100 logical ::
match(size(string))
1104 do i =1,
size(string)
1105 match(i)=string_match(string(i),pattern)
1108 end function string_match_v
1114 recursive 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:) )
1219 end function string_match
1222 SUBROUTINE print_status_line(line)
1223 CHARACTER(len=*),
INTENT(in) :: line
1224 CHARACTER(len=1),
PARAMETER :: cr=char(13)
1225 WRITE(stdout_unit,
'(2A)',advance=
'no')cr,trim(line)
1227 END SUBROUTINE print_status_line
1229 SUBROUTINE done_status_line()
1230 WRITE(stdout_unit,
'()')
1231 END SUBROUTINE done_status_line
1242 SUBROUTINE progress_line_update_d(this, val)
1244 DOUBLE PRECISION,
INTENT(in) :: val
1247 CHARACTER(len=512) :: line
1249 IF (this%curr >= this%max)
RETURN
1251 this%curr = max(this%min, min(this%max, val))
1252 this%spin = mod(this%spin+1, 4)
1255 vint = nint((this%curr-this%min)/(this%max-this%min)*100.d0)
1256 WRITE(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
1266 CALL print_status_line(line)
1267 IF (this%curr >= this%max)
CALL done_status_line()
1269 END SUBROUTINE progress_line_update_d
1276 SUBROUTINE progress_line_update_i(this, val)
1278 INTEGER,
INTENT(in) :: val
1280 CALL progress_line_update_d(this, dble(val))
1282 END SUBROUTINE progress_line_update_i
1289 SUBROUTINE progress_line_alldone(this)
1291 CALL progress_line_update_d(this, this%max)
1292 END 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.