libsim Versione 7.2.1
char_utilities.F90
1! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
2! authors:
3! Davide Cesari <dcesari@arpa.emr.it>
4! Paolo Patruno <ppatruno@arpa.emr.it>
5
6! This program is free software; you can redistribute it and/or
7! modify it under the terms of the GNU General Public License as
8! published by the Free Software Foundation; either version 2 of
9! the License, or (at your option) any later version.
10
11! This program is distributed in the hope that it will be useful,
12! but WITHOUT ANY WARRANTY; without even the implied warranty of
13! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14! GNU General Public License for more details.
15
16! You should have received a copy of the GNU General Public License
17! along with this program. If not, see <http://www.gnu.org/licenses/>.
24#include "config.h"
25MODULE char_utilities
26USE kinds
28USE io_units
29IMPLICIT NONE
30
31CHARACTER(len=*),PARAMETER :: LOWER_CASE = 'abcdefghijklmnopqrstuvwxyz'
32CHARACTER(len=*),PARAMETER :: UPPER_CASE = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
33
65INTERFACE to_char
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
69END INTERFACE
70
71
90INTERFACE t2c
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
96END INTERFACE
97
98
103TYPE line_split
104 PRIVATE
105 INTEGER :: align_type, ncols, nlines
106 INTEGER, POINTER :: word_start(:), word_end(:)
107 CHARACTER(len=1), POINTER :: paragraph(:,:)
108END TYPE line_split
109
115INTERFACE delete
116 MODULE PROCEDURE line_split_delete
117END INTERFACE
118
119
180INTERFACE match
181 MODULE PROCEDURE string_match, string_match_v
182END INTERFACE
183
184
192TYPE progress_line
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
201 CONTAINS
202 PROCEDURE :: update => progress_line_update_d, progress_line_update_i
203 PROCEDURE :: alldone => progress_line_alldone
204END TYPE progress_line
205
206CHARACTER(len=4),PARAMETER :: progress_line_spin='-\|/'
207
208PRIVATE
209PUBLIC line_split
210PUBLIC to_char, t2c, c2i, c2r, c2d, delete, match, &
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, &
215 print_status_line, done_status_line, progress_line
216
217CONTAINS
218
219! Version with integer argument, please use the generic \a to_char
220! rather than this function directly.
221ELEMENTAL FUNCTION int_to_char(in, miss, form) RESULT(char)
222INTEGER,INTENT(in) :: in ! value to be represented as CHARACTER
223CHARACTER(len=*),INTENT(in),OPTIONAL :: miss ! replacement for missing value
224CHARACTER(len=*),INTENT(in),OPTIONAL :: form ! optional format
225CHARACTER(len=11) :: char
226
227IF (PRESENT(miss)) THEN
228 IF (.NOT.c_e(in)) THEN
229 char = miss
230 ELSE
231 IF (PRESENT(form)) THEN
232 WRITE(char,form)in
233 ELSE
234 WRITE(char,'(I0)')in
235 ENDIF
236 ENDIF
237ELSE
238 IF (PRESENT(form)) THEN
239 WRITE(char,form)in
240 ELSE
241 WRITE(char,'(I0)')in
242 ENDIF
243ENDIF
244
245END FUNCTION int_to_char
246
247
248FUNCTION trim_int_to_char(in) RESULT(char)
249INTEGER,INTENT(in) :: in ! value to be represented as CHARACTER
250CHARACTER(len=LEN_TRIM(to_char(in))) :: char
251
252char = to_char(in)
254END FUNCTION trim_int_to_char
255
256
257FUNCTION trim_int_to_char_miss(in, miss) RESULT(char)
258INTEGER,INTENT(in) :: in ! value to be represented as CHARACTER
259CHARACTER(len=*),INTENT(in) :: miss ! replacement for missing value
260CHARACTER(len=LEN_TRIM(to_char(in,miss=miss))) :: char
261
262char = to_char(in, miss=miss)
263
264END FUNCTION trim_int_to_char_miss
265
266
267! Version with 1-byte integer argument, please use the generic \a to_char
268! rather than this function directly.
269ELEMENTAL FUNCTION byte_to_char(in, miss, form) RESULT(char)
270INTEGER(kind=int_b),INTENT(in) :: in ! value to be represented as CHARACTER
271CHARACTER(len=*),INTENT(in),OPTIONAL :: miss ! replacement for missing value
272CHARACTER(len=*),INTENT(in),OPTIONAL :: form ! optional format
273CHARACTER(len=11) :: char
274
275IF (PRESENT(miss)) THEN
276 IF (.NOT.c_e(in)) THEN
277 char = miss
278 ELSE
279 IF (PRESENT(form)) THEN
280 WRITE(char,form)in
281 ELSE
282 WRITE(char,'(I0)')in
283 ENDIF
284 ENDIF
285ELSE
286 IF (PRESENT(form)) THEN
287 WRITE(char,form)in
288 ELSE
289 WRITE(char,'(I0)')in
290 ENDIF
291ENDIF
292
293END FUNCTION byte_to_char
294
295
296FUNCTION trim_byte_to_char(in) RESULT(char)
297INTEGER(kind=int_b),INTENT(in) :: in ! value to be represented as CHARACTER
298CHARACTER(len=LEN_TRIM(to_char(in))) :: char
299
300char = to_char(in)
301
302END FUNCTION trim_byte_to_char
304
305FUNCTION trim_byte_to_char_miss(in,miss) RESULT(char)
306INTEGER(kind=int_b),INTENT(in) :: in ! value to be represented as CHARACTER
307CHARACTER(len=*),INTENT(in) :: miss ! replacement for missing value
308CHARACTER(len=LEN_TRIM(to_char(in,miss=miss))) :: char
309
310char = to_char(in, miss=miss)
311
312END FUNCTION trim_byte_to_char_miss
313
314
315! Version with character argument, please use the generic \a to_char
316! rather than this function directly. It is almost useless, just
317! provided for completeness.
318ELEMENTAL FUNCTION char_to_char(in) RESULT(char)
319CHARACTER(len=*),INTENT(in) :: in ! value to be represented as CHARACTER
320CHARACTER(len=LEN(in)) :: char
321
322char = in
323
324END FUNCTION char_to_char
325
326
327ELEMENTAL FUNCTION char_to_char_miss(in, miss) RESULT(char)
328CHARACTER(len=*),INTENT(in) :: in ! value to be represented as CHARACTER
329CHARACTER(len=*),INTENT(in) :: miss ! replacement for missing value
330CHARACTER(len=MAX(LEN(in),LEN(miss))) :: char
331
332IF (c_e(in)) THEN
333 char = in
334ELSE
335 char = miss
336ENDIF
337
338END FUNCTION char_to_char_miss
339
340
341FUNCTION trim_char_to_char(in) result(char)
342CHARACTER(len=*),INTENT(in) :: in ! value to be represented as CHARACTER
343CHARACTER(len=LEN_TRIM(in)) :: char
344
345char = trim(in)
346
347END FUNCTION trim_char_to_char
348
349
350FUNCTION trim_char_to_char_miss(in, miss) RESULT(char)
351CHARACTER(len=*),INTENT(in) :: in ! value to be represented as CHARACTER
352CHARACTER(len=*),INTENT(in) :: miss ! replacement for missing valu
353CHARACTER(len=LEN_TRIM(char_to_char_miss(in,miss))) :: char
354
355char = char_to_char_miss(in, miss)
356
357END FUNCTION trim_char_to_char_miss
358
359
360! Version with single precision real argument, please use the generic
361! \a to_char rather than this function directly.
362ELEMENTAL FUNCTION real_to_char(in, miss, form) RESULT(char)
363REAL,INTENT(in) :: in ! value to be represented as CHARACTER
364CHARACTER(len=*),INTENT(in),OPTIONAL :: miss ! replacement for missing value
365CHARACTER(len=*),INTENT(in),OPTIONAL :: form ! optional format
366CHARACTER(len=15) :: char
367
368CHARACTER(len=15) :: tmpchar
369
370IF (PRESENT(miss)) THEN
371 IF (.NOT.c_e(in)) THEN
372 char = miss
373 ELSE
374 IF (PRESENT(form)) THEN
375 WRITE(char,form)in
376 ELSE
377 WRITE(tmpchar,'(G15.9)') in
378 char = adjustl(tmpchar)
379 ENDIF
380 ENDIF
381ELSE
382 IF (PRESENT(form)) THEN
383 WRITE(char,form)in
384 ELSE
385 WRITE(tmpchar,'(G15.9)') in
386 char = adjustl(tmpchar)
387 ENDIF
388ENDIF
389
390END FUNCTION real_to_char
391
392
393FUNCTION trim_real_to_char(in) RESULT(char)
394REAL,INTENT(in) :: in ! value to be represented as CHARACTER
395CHARACTER(len=LEN_TRIM(to_char(in))) :: char
396
397char = real_to_char(in)
398
399END FUNCTION trim_real_to_char
400
401
402FUNCTION trim_real_to_char_miss(in, miss) RESULT(char)
403REAL,INTENT(in) :: in ! value to be represented as CHARACTER
404CHARACTER(len=*),INTENT(in) :: miss ! replacement for missing value
405CHARACTER(len=LEN_TRIM(to_char(in,miss=miss))) :: char
406
407char = real_to_char(in, miss=miss)
408
409END FUNCTION trim_real_to_char_miss
410
411
412! Version with double precision real argument, please use the generic
413! \a to_char rather than this function directly.
414ELEMENTAL FUNCTION double_to_char(in, miss, form) RESULT(char)
415DOUBLE PRECISION,INTENT(in) :: in ! value to be represented as CHARACTER
416CHARACTER(len=*),INTENT(in),OPTIONAL :: miss ! replacement for missing value
417CHARACTER(len=*),INTENT(in),OPTIONAL :: form ! optional format
418CHARACTER(len=24) :: char
419
420CHARACTER(len=24) :: tmpchar
421
422IF (PRESENT(miss)) THEN
423 IF (.NOT.c_e(in)) THEN
424 char = miss
425 ELSE
426 IF (PRESENT(form)) THEN
427 WRITE(char,form)in
428 ELSE
429 WRITE(tmpchar,'(G24.17)') in
430 char = adjustl(tmpchar)
431 ENDIF
432 ENDIF
433ELSE
434 IF (PRESENT(form)) THEN
435 WRITE(char,form)in
436 ELSE
437 WRITE(tmpchar,'(G24.17)') in
438 char = adjustl(tmpchar)
439 ENDIF
440ENDIF
441
442END FUNCTION double_to_char
443
444
445FUNCTION trim_double_to_char(in) RESULT(char)
446DOUBLE PRECISION,INTENT(in) :: in ! value to be represented as CHARACTER
447CHARACTER(len=LEN_TRIM(to_char(in))) :: char
448
449char=double_to_char(in)
450
451END FUNCTION trim_double_to_char
452
453
454FUNCTION trim_double_to_char_miss(in, miss) RESULT(char)
455DOUBLE PRECISION,INTENT(in) :: in ! value to be represented as CHARACTER
456CHARACTER(len=*),INTENT(in) :: miss ! replacement for missing value
457CHARACTER(len=LEN_TRIM(to_char(in,miss=miss))) :: char
458
459char=double_to_char(in, miss=miss)
460
461END FUNCTION trim_double_to_char_miss
462
463
464! Version with logical argument, please use the generic \a to_char
465! rather than this function directly.
466ELEMENTAL FUNCTION logical_to_char(in, form) RESULT(char)
467LOGICAL,INTENT(in) :: in ! value to be represented as CHARACTER
468CHARACTER(len=*),INTENT(in),OPTIONAL :: form ! optional format
469CHARACTER(len=1) :: char
470
471IF (PRESENT(form)) THEN
472 WRITE(char,form) in
473ELSE
474 WRITE(char,'(L1)') in
475ENDIF
476
477END FUNCTION logical_to_char
478
479
480ELEMENTAL FUNCTION trim_logical_to_char(in) RESULT(char)
481LOGICAL,INTENT(in) :: in ! value to be represented as CHARACTER
482
483CHARACTER(len=1) :: char
484
485WRITE(char,'(L1)') in
486
487END FUNCTION trim_logical_to_char
488
489
494ELEMENTAL FUNCTION c2i(string) RESULT(num)
495CHARACTER(len=*),INTENT(in) :: string
496INTEGER :: num
497
498INTEGER :: lier
499
500IF (.NOT.c_e(string)) THEN
501 num = imiss
502ELSE IF (len_trim(string) == 0) THEN
503 num = imiss
504ELSE
505 READ(string, '(I32)', iostat=lier)num
506 IF (lier /= 0) THEN
507 num = imiss
508 ENDIF
509ENDIF
510
511END FUNCTION c2i
512
513
518ELEMENTAL FUNCTION c2r(string) RESULT(num)
519CHARACTER(len=*),INTENT(in) :: string
520REAL :: num
521
522INTEGER :: lier
523
524IF (.NOT.c_e(string)) THEN
525 num = rmiss
526ELSE IF (len_trim(string) == 0) THEN
527 num = rmiss
528ELSE
529 READ(string, '(F32.0)', iostat=lier)num
530 IF (lier /= 0) THEN
531 num = rmiss
532 ENDIF
533ENDIF
534
535END FUNCTION c2r
536
537
542ELEMENTAL FUNCTION c2d(string) RESULT(num)
543CHARACTER(len=*),INTENT(in) :: string
544DOUBLE PRECISION :: num
545
546INTEGER :: lier
547
548IF (.NOT.c_e(string)) THEN
549 num = rmiss
550ELSE IF (len_trim(string) == 0) THEN
551 num = rmiss
552ELSE
553 READ(string, '(F32.0)', iostat=lier)num
554 IF (lier /= 0) THEN
555 num = rmiss
556 ENDIF
557ENDIF
558
559END FUNCTION c2d
560
561
567FUNCTION fchar_to_cstr(fchar) RESULT(cstr)
568CHARACTER(len=*), INTENT(in) :: fchar
569INTEGER(kind=int_b) :: cstr(len(fchar)+1)
570
571cstr(1:len(fchar)) = transfer(fchar, cstr, len(fchar))
572cstr(len(fchar)+1) = 0 ! zero-terminate
573
574END FUNCTION fchar_to_cstr
575
576
582SUBROUTINE fchar_to_cstr_alloc(fchar, pcstr)
583CHARACTER(len=*), INTENT(in) :: fchar
584INTEGER(kind=int_b), POINTER :: pcstr(:)
585
586ALLOCATE(pcstr(len(fchar)+1))
587pcstr(1:len(fchar)) = transfer(fchar, pcstr, len(fchar))
588pcstr(len(fchar)+1) = 0 ! zero-terminate
589
590END SUBROUTINE fchar_to_cstr_alloc
591
592
596FUNCTION cstr_to_fchar(cstr) RESULT(fchar)
597INTEGER(kind=int_b), INTENT(in) :: cstr(:)
598CHARACTER(len=SIZE(cstr)-1) :: fchar
599
600INTEGER :: i
601
602!l = MIN(LEN(char), SIZE(cstr)-1)
603fchar = transfer(cstr(1:SIZE(cstr)-1), fchar)
604DO i = 1, SIZE(cstr)-1
605 IF (fchar(i:i) == char(0)) THEN ! truncate if the null terminator is found before
606 fchar(i:) = ' '
607 EXIT
608 ENDIF
609ENDDO
610
611END FUNCTION cstr_to_fchar
612
613
615FUNCTION uppercase ( Input_String ) RESULT ( Output_String )
616CHARACTER( * ), INTENT( IN ) :: input_string
617CHARACTER( LEN( Input_String ) ) :: output_string
618 ! -- Local variables
619INTEGER :: i, n
620
621 ! -- Copy input string
622output_string = input_string
623 ! -- Loop over string elements
624DO i = 1, len( output_string )
625 ! -- Find location of letter in lower case constant string
626 n = index( lower_case, output_string( i:i ) )
627 ! -- If current substring is a lower case letter, make it upper case
628 IF ( n /= 0 ) output_string( i:i ) = upper_case( n:n )
629END DO
630END FUNCTION uppercase
631
632
634FUNCTION lowercase ( Input_String ) RESULT ( Output_String )
635 ! -- Argument and result
636CHARACTER( * ), INTENT( IN ) :: input_string
637CHARACTER( LEN( Input_String ) ) :: output_string
638 ! -- Local variables
639INTEGER :: i, n
640
641 ! -- Copy input string
642output_string = input_string
643 ! -- Loop over string elements
644DO i = 1, len( output_string )
645 ! -- Find location of letter in upper case constant string
646 n = index( upper_case, output_string( i:i ) )
647 ! -- If current substring is an upper case letter, make it lower case
648 IF ( n /= 0 ) output_string( i:i ) = lower_case( n:n )
649END DO
650END FUNCTION lowercase
651
652
658ELEMENTAL FUNCTION align_center(input_string) RESULT(aligned)
659CHARACTER(len=*), INTENT(in) :: input_string
660
661CHARACTER(len=LEN(input_string)) :: aligned
662
663INTEGER :: n1, n2
664
665n1 = f_nblnk(input_string)
666n2 = len(input_string)-l_nblnk(input_string)+1
667
668aligned = ''
669aligned((n1+n2)/2:) = input_string(n1:)
670
671END FUNCTION align_center
672
673
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
684INTEGER :: nblnk
685
686IF (PRESENT(blnk)) THEN
687 lblnk = blnk
688ELSE
689 lblnk = ' '
690ENDIF
691
692DO nblnk = len(input_string), 1, -1
693 IF (input_string(nblnk:nblnk) /= lblnk) RETURN
694ENDDO
695
696END FUNCTION l_nblnk
697
698
702ELEMENTAL FUNCTION f_nblnk(input_string, blnk) RESULT(nblnk)
703CHARACTER(len=*), INTENT(in) :: input_string
704CHARACTER(len=1), INTENT(in), OPTIONAL :: blnk
705
706CHARACTER(len=1) :: lblnk
707INTEGER :: nblnk
708
709IF (PRESENT(blnk)) THEN
710 lblnk = blnk
711ELSE
712 lblnk = ' '
713ENDIF
714
715DO nblnk = 1, len(input_string)
716 IF (input_string(nblnk:nblnk) /= lblnk) RETURN
717ENDDO
718
719END FUNCTION f_nblnk
720
721
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
733
734INTEGER :: nword
735
736INTEGER :: ls, le
737INTEGER, POINTER :: lsv(:), lev(:)
738CHARACTER(len=1) :: lsep
739
740IF (PRESENT(sep)) THEN
741 lsep = sep
742ELSE
743 lsep = ' '
744ENDIF
745
746nword = 0
747le = 0
748DO WHILE(.true.)
749 ls = f_nblnk(input_string(le+1:), lsep) + le ! search next nonblank
750 IF (ls > len(input_string)) EXIT ! end of words
751 le = index(input_string(ls:), lsep)
752 IF (le == 0) THEN
753 le = len(input_string)
754 ELSE
755 le = le + ls - 2
756 ENDIF
757 nword = nword + 1
758ENDDO
759
760IF (.NOT.PRESENT(word_start) .AND. .NOT.PRESENT(word_end)) RETURN
761
762ALLOCATE(lsv(nword), lev(nword))
763nword = 0
764le = 0
765DO WHILE(.true.)
766 ls = f_nblnk(input_string(le+1:), lsep) + le ! search next nonblank
767 IF (ls > len(input_string)) EXIT ! end of words
768 le = index(input_string(ls:), lsep)
769 IF (le == 0) THEN
770 le = len(input_string)
771 ELSE
772 le = le + ls - 2
773 ENDIF
774 nword = nword + 1
775 lsv(nword) = ls
776 lev(nword) = le
777ENDDO
778
779IF (PRESENT(word_start)) THEN
780 word_start => lsv
781ELSE
782 DEALLOCATE(lsv)
783ENDIF
784IF (PRESENT(word_end)) THEN
785 word_end => lev
786ELSE
787 DEALLOCATE(lev)
788ENDIF
789
790END FUNCTION word_split
791
792
797FUNCTION line_split_new(line, ncols) RESULT(this)
798CHARACTER(len=*), INTENT(in) :: line
799INTEGER, INTENT(in), OPTIONAL :: ncols
800
801TYPE(line_split) :: this
802
803INTEGER :: nw, nwords, nlines, columns_in_line, words_in_line, ncols_next_word
804
805IF (PRESENT(ncols)) THEN
806 this%ncols = ncols
807ELSE
808 this%ncols = default_columns()
809ENDIF
810! split the input line
811nwords = word_split(line, this%word_start, this%word_end)
812! count the lines required to accomodate the input line in a paragraph
813nlines = 0
814nw = 0
815DO WHILE(nw < nwords)
816 columns_in_line = 0
817 words_in_line = 0
818 DO WHILE(nw < nwords)
819 nw = nw + 1
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 ! previous space
822 IF (columns_in_line + ncols_next_word <= this%ncols .OR. &
823 words_in_line == 0) THEN ! accept the word
824 columns_in_line = columns_in_line + ncols_next_word
825 words_in_line = words_in_line + 1
826 ELSE ! refuse the word
827 nw = nw - 1
828 EXIT
829 ENDIF
830 ENDDO
831 nlines = nlines + 1
832ENDDO
833
834!IF (nlines == 0)
835ALLOCATE(this%paragraph(this%ncols, nlines))
836this%paragraph = ' '
837! repeat filling the paragraph
838nlines = 0
839nw = 0
840DO WHILE(nw < nwords)
841 columns_in_line = 0
842 words_in_line = 0
843 DO WHILE(nw < nwords)
844 nw = nw + 1
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 ! previous space
847 IF (columns_in_line + ncols_next_word <= this%ncols .OR. &
848 words_in_line == 0) THEN ! accept the word
849 columns_in_line = columns_in_line + ncols_next_word
850! now fill the paragraph
851 IF (columns_in_line <= this%ncols) THEN ! non truncated line
852 IF (words_in_line > 0) THEN ! previous space
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)
855 ELSE ! no previous space
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)
858 ENDIF
859 ELSE ! truncated line (word longer than line)
860 this%paragraph(1:this%ncols,nlines+1) = &
861 transfer(line(this%word_start(nw):this%word_start(nw)+this%ncols-1), this%paragraph)
862 ENDIF
863 words_in_line = words_in_line + 1
864 ELSE ! refuse the word
865 nw = nw - 1
866 EXIT
867 ENDIF
868 ENDDO
869 nlines = nlines + 1
870ENDDO
871
872END FUNCTION line_split_new
873
874
875! Cleanly destroy a \a line_split object, deallocating all the
876! dynamically allocated space. Use the generic name \a delete rather
877! than this specfoc subroutine.
878SUBROUTINE line_split_delete(this)
879TYPE(line_split), INTENT(inout) :: this ! object to be destroyed
880
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)
884
885END SUBROUTINE line_split_delete
886
887
889FUNCTION line_split_get_nlines(this) RESULT(nlines)
890TYPE(line_split), INTENT(in) :: this
891
892INTEGER :: nlines
893
894IF (ASSOCIATED(this%paragraph)) THEN
895 nlines = SIZE(this%paragraph, 2)
896ELSE
897 nlines = 0
898ENDIF
899
900END FUNCTION line_split_get_nlines
901
902
907FUNCTION line_split_get_line(this, nline) RESULT(line)
908TYPE(line_split), INTENT(in) :: this
909INTEGER, INTENT(in) :: nline
910
911CHARACTER(len=SIZE(this%paragraph, 1)) :: line
912IF (nline > 0 .AND. nline <= SIZE(this%paragraph, 2)) THEN
913 line = transfer(this%paragraph(:,nline), line)
914ELSE
915 line = cmiss
916ENDIF
917
918END FUNCTION line_split_get_line
919
920
926FUNCTION default_columns() RESULT(cols)
927INTEGER :: cols
928
929INTEGER, PARAMETER :: defaultcols = 80 ! default of the defaults
930INTEGER, PARAMETER :: maxcols = 256 ! maximum value
931CHARACTER(len=10) :: ccols
932
933cols = defaultcols
934CALL getenv('COLUMNS', ccols)
935IF (ccols == '') RETURN
936
937READ(ccols, '(I10)', err=100) cols
938cols = min(cols, maxcols)
939IF (cols <= 0) cols = defaultcols
940RETURN
941
942100 cols = defaultcols ! error in reading the value
943
944END FUNCTION default_columns
945
946
948FUNCTION suffixname ( Input_String ) RESULT ( Output_String )
949! -- Argument and result
950CHARACTER( * ), INTENT( IN ) :: input_string
951CHARACTER( LEN( Input_String ) ) :: output_string
952! -- Local variables
953INTEGER :: i
954
955output_string=""
956i = index(input_string,".",back=.true.)
957if (i > 0 .and. i < len(input_string)) output_string= input_string(i+1:)
958
959END FUNCTION suffixname
960
961
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(:)
974
975CHARACTER(len=len(in)) :: char,charr,charrr
976INTEGER :: i,ia,nchar
977
978char=""
979charr=""
980charrr=""
981
982if (present(goodchar)) then
983
984allocate(igoodchar(len(goodchar)))
986 do i =1, len(goodchar)
987 igoodchar=ichar(goodchar(i:i))
988 end do
989
990 nchar=0
991 do i=1,len(in)
992 ia = ichar(in(i:i))
993 if (any(ia == igoodchar))then
994 nchar=nchar+1
995 charrr(nchar:nchar)=achar(ia)
996 end if
997 end do
998
999deallocate(igoodchar)
1000
1001else
1002
1003 charrr=in
1004
1005end if
1006
1007
1008
1009if (present(badchar)) then
1010
1011allocate(ibadchar(len(badchar)))
1012
1013 do i =1, len(badchar)
1014 ibadchar=ichar(badchar(i:i))
1015 end do
1016
1017 nchar=0
1018 do i=1,len(charrr)
1019 ia = ichar(charrr(i:i))
1020 if (.not. any(ia == ibadchar))then
1021 nchar=nchar+1
1022 charr(nchar:nchar)=achar(ia)
1023 end if
1024 end do
1025
1026deallocate(ibadchar)
1027
1028else
1029
1030 charr=charrr
1031
1032end if
1033
1034
1035if (.not. present(goodchar) .and. .not. present(badchar)) then
1036
1037 nchar=0
1038 do i=1,len(charr)
1039 ia = ichar(charr(i:i))
1040 if ((ia >= 65 .and. ia <= 90) .or. &
1041 (ia >= 97 .and. ia <= 122))then
1042 nchar=nchar+1
1043 char(nchar:nchar)=achar(ia)
1044 end if
1045 end do
1046
1047else
1048
1049 char=charr
1050
1051end if
1052
1053
1054END FUNCTION wash_char
1055
1056
1057! derived by http://sourceforge.net/projects/flibs
1058!
1059! globmatch.f90 --
1060! Match strings according to (simplified) glob patterns
1061!
1062! The pattern matching is limited to literals, * and ?
1063! (character classes are not supported). A backslash escapes
1064! any character.
1065!
1066! $Id: globmatch.f90,v 1.5 2006/03/26 19:03:53 arjenmarkus Exp $
1067!!$Copyright (c) 2008, Arjen Markus
1068!!$
1069!!$All rights reserved.
1070!!$
1071!!$Redistribution and use in source and binary forms, with or without modification,
1072!!$are permitted provided that the following conditions are met:
1073!!$
1074!!$Redistributions of source code must retain the above copyright notice,
1075!!$this list of conditions and the following disclaimer.
1076!!$Redistributions in binary form must reproduce the above copyright notice,
1077!!$this list of conditions and the following disclaimer in the documentation
1078!!$and/or other materials provided with the distribution.
1079!!$Neither the name of the author nor the names of the contributors
1080!!$may be used to endorse or promote products derived from this software
1081!!$without specific prior written permission.
1082!!$THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
1083!!$"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
1084!!$THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
1085!!$ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE
1086!!$FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
1087!!$DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
1088!!$SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
1089!!$CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
1090!!$OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
1091!!$OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
1092!
1093
1097function string_match_v( string, pattern ) result(match)
1098character(len=*), intent(in) :: string(:)
1099character(len=*), intent(in) :: pattern
1100logical :: match(size(string))
1101
1102integer :: i
1103
1104do i =1,size(string)
1105 match(i)=string_match(string(i),pattern)
1106end do
1107
1108end function string_match_v
1109
1110
1114recursive function string_match( string, pattern ) result(match)
1115 character(len=*), intent(in) :: string
1116 character(len=*), intent(in) :: pattern
1117 logical :: match
1118
1119! '\\' without -fbackslash generates a warning on gfortran, '\'
1120! crashes doxygen, so we choose '\\' and -fbackslash in configure.ac
1121 character(len=1), parameter :: backslash = '\\'
1122 character(len=1), parameter :: star = '*'
1123 character(len=1), parameter :: question = '?'
1124
1125 character(len=len(pattern)) :: literal
1126 integer :: ptrim
1127 integer :: p
1128 integer :: k
1129 integer :: ll
1130 integer :: method
1131 integer :: start
1132 integer :: strim
1133
1134 match = .false.
1135 method = 0
1136 ptrim = len_trim( pattern )
1137 strim = len_trim( string )
1138 p = 1
1139 ll = 0
1140 start = 1
1141
1142 !
1143 ! Split off a piece of the pattern
1144 !
1145 do while ( p <= ptrim )
1146 select case ( pattern(p:p) )
1147 case( star )
1148 if ( ll .ne. 0 ) exit
1149 method = 1
1150 case( question )
1151 if ( ll .ne. 0 ) exit
1152 method = 2
1153 start = start + 1
1154 case( backslash )
1155 p = p + 1
1156 ll = ll + 1
1157 literal(ll:ll) = pattern(p:p)
1158 case default
1159 ll = ll + 1
1160 literal(ll:ll) = pattern(p:p)
1161 end select
1162
1163 p = p + 1
1164 enddo
1165
1166 !
1167 ! Now look for the literal string (if any!)
1168 !
1169 if ( method == 0 ) then
1170 !
1171 ! We are at the end of the pattern, and of the string?
1172 !
1173 if ( strim == 0 .and. ptrim == 0 ) then
1174 match = .true.
1175 else
1176 !
1177 ! The string matches a literal part?
1178 !
1179 if ( ll > 0 ) then
1180 if ( string(start:min(strim,start+ll-1)) == literal(1:ll) ) then
1181 start = start + ll
1182 match = string_match( string(start:), pattern(p:) )
1183 endif
1184 endif
1185 endif
1186 endif
1187
1188 if ( method == 1 ) then
1189 !
1190 ! Scan the whole of the remaining string ...
1191 !
1192 if ( ll == 0 ) then
1193 match = .true.
1194 else
1195 do while ( start <= strim )
1196 k = index( string(start:), literal(1:ll) )
1197 if ( k > 0 ) then
1198 start = start + k + ll - 1
1199 match = string_match( string(start:), pattern(p:) )
1200 if ( match ) then
1201 exit
1202 endif
1203 endif
1204
1205 start = start + 1
1206 enddo
1207 endif
1208 endif
1209
1210 if ( method == 2 .and. ll > 0 ) then
1211 !
1212 ! Scan the whole of the remaining string ...
1213 !
1214 if ( string(start:min(strim,start+ll-1)) == literal(1:ll) ) then
1215 match = string_match( string(start+ll:), pattern(p:) )
1216 endif
1217 endif
1218 return
1219end function string_match
1220
1221
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)
1226FLUSH(unit=6) ! probably useless with gfortran, required with Intel fortran
1227END SUBROUTINE print_status_line
1228
1229SUBROUTINE done_status_line()
1230WRITE(stdout_unit,'()')
1231END SUBROUTINE done_status_line
1232
1233
1242SUBROUTINE progress_line_update_d(this, val)
1243CLASS(progress_line),INTENT(inout) :: this
1244DOUBLE PRECISION,INTENT(in) :: val
1245
1246INTEGER :: vint, i
1247CHARACTER(len=512) :: line
1248
1249IF (this%curr >= this%max) RETURN ! line is already closed, do nothing
1250
1251this%curr = max(this%min, min(this%max, val))
1252this%spin = mod(this%spin+1, 4)
1253line = ''
1254
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)
1258vint = vint/10
1259
1260DO i = 1, vint
1261 line(this%barloc+i:this%barloc+i) = this%done
1262ENDDO
1263DO i = vint+1, 10
1264 line(this%barloc+i:this%barloc+i) = this%todo
1265ENDDO
1266CALL print_status_line(line)
1267IF (this%curr >= this%max) CALL done_status_line()
1268
1269END SUBROUTINE progress_line_update_d
1270
1271
1276SUBROUTINE progress_line_update_i(this, val)
1277CLASS(progress_line),INTENT(inout) :: this
1278INTEGER,INTENT(in) :: val
1279
1280CALL progress_line_update_d(this, dble(val))
1281
1282END SUBROUTINE progress_line_update_i
1283
1289SUBROUTINE progress_line_alldone(this)
1290CLASS(progress_line),INTENT(inout) :: this
1291CALL progress_line_update_d(this, this%max)
1292END SUBROUTINE progress_line_alldone
1293
1294
1295END MODULE char_utilities
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.
Index method.
Function to check whether a value is missing or not.
Utilities for CHARACTER variables.
Definition of constants related to I/O units.
Definition: io_units.F90:225
Definition of constants to be used for declaring variables of a desired type.
Definition: kinds.F90:245
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.

Generated with Doxygen.