libsim  Versione7.2.6
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"
25 MODULE char_utilities
26 USE kinds
28 USE io_units
29 IMPLICIT NONE
30 
31 CHARACTER(len=*),PARAMETER :: LOWER_CASE = 'abcdefghijklmnopqrstuvwxyz'
32 CHARACTER(len=*),PARAMETER :: UPPER_CASE = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
33 
65 INTERFACE 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
69 END INTERFACE
70 
71 
90 INTERFACE 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
96 END INTERFACE
97 
98 
103 TYPE line_split
104  PRIVATE
105  INTEGER :: align_type, ncols, nlines
106  INTEGER, POINTER :: word_start(:), word_end(:)
107  CHARACTER(len=1), POINTER :: paragraph(:,:)
108 END TYPE line_split
109 
115 INTERFACE delete
116  MODULE PROCEDURE line_split_delete
117 END INTERFACE
118 
119 
180 INTERFACE match
181  MODULE PROCEDURE string_match, string_match_v
182 END INTERFACE
183 
184 
192 TYPE 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
204 END TYPE progress_line
205 
206 CHARACTER(len=4),PARAMETER :: progress_line_spin='-\|/'
207 
208 PRIVATE
209 PUBLIC line_split
210 PUBLIC 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 
217 CONTAINS
218 
219 ! Version with integer argument, please use the generic \a to_char
220 ! rather than this function directly.
221 ELEMENTAL FUNCTION int_to_char(in, miss, form) RESULT(char)
222 INTEGER,INTENT(in) :: in ! value to be represented as CHARACTER
223 CHARACTER(len=*),INTENT(in),OPTIONAL :: miss ! replacement for missing value
224 CHARACTER(len=*),INTENT(in),OPTIONAL :: form ! optional format
225 CHARACTER(len=11) :: char
226 
227 IF (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
237 ELSE
238  IF (PRESENT(form)) THEN
239  WRITE(char,form)in
240  ELSE
241  WRITE(char,'(I0)')in
242  ENDIF
243 ENDIF
244 
245 END FUNCTION int_to_char
246 
247 
248 FUNCTION trim_int_to_char(in) RESULT(char)
249 INTEGER,INTENT(in) :: in ! value to be represented as CHARACTER
250 CHARACTER(len=LEN_TRIM(to_char(in))) :: char
251 
252 char = to_char(in)
253 
254 END FUNCTION trim_int_to_char
255 
256 
257 FUNCTION trim_int_to_char_miss(in, miss) RESULT(char)
258 INTEGER,INTENT(in) :: in ! value to be represented as CHARACTER
259 CHARACTER(len=*),INTENT(in) :: miss ! replacement for missing value
260 CHARACTER(len=LEN_TRIM(to_char(in,miss=miss))) :: char
261 
262 char = to_char(in, miss=miss)
264 END 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.
269 ELEMENTAL FUNCTION byte_to_char(in, miss, form) RESULT(char)
270 INTEGER(kind=int_b),INTENT(in) :: in ! value to be represented as CHARACTER
271 CHARACTER(len=*),INTENT(in),OPTIONAL :: miss ! replacement for missing value
272 CHARACTER(len=*),INTENT(in),OPTIONAL :: form ! optional format
273 CHARACTER(len=11) :: char
274 
275 IF (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
285 ELSE
286  IF (PRESENT(form)) THEN
287  WRITE(char,form)in
288  ELSE
289  WRITE(char,'(I0)')in
290  ENDIF
291 ENDIF
292 
293 END FUNCTION byte_to_char
294 
295 
296 FUNCTION trim_byte_to_char(in) RESULT(char)
297 INTEGER(kind=int_b),INTENT(in) :: in ! value to be represented as CHARACTER
298 CHARACTER(len=LEN_TRIM(to_char(in))) :: char
299 
300 char = to_char(in)
302 END FUNCTION trim_byte_to_char
303 
304 
305 FUNCTION trim_byte_to_char_miss(in,miss) RESULT(char)
306 INTEGER(kind=int_b),INTENT(in) :: in ! value to be represented as CHARACTER
307 CHARACTER(len=*),INTENT(in) :: miss ! replacement for missing value
308 CHARACTER(len=LEN_TRIM(to_char(in,miss=miss))) :: char
309 
310 char = to_char(in, miss=miss)
311 
312 END FUNCTION trim_byte_to_char_miss
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.
318 ELEMENTAL FUNCTION char_to_char(in) RESULT(char)
319 CHARACTER(len=*),INTENT(in) :: in ! value to be represented as CHARACTER
320 CHARACTER(len=LEN(in)) :: char
321 
322 char = in
323 
324 END FUNCTION char_to_char
325 
326 
327 ELEMENTAL FUNCTION char_to_char_miss(in, miss) RESULT(char)
328 CHARACTER(len=*),INTENT(in) :: in ! value to be represented as CHARACTER
329 CHARACTER(len=*),INTENT(in) :: miss ! replacement for missing value
330 CHARACTER(len=MAX(LEN(in),LEN(miss))) :: char
331 
332 IF (c_e(in)) THEN
333  char = in
334 ELSE
335  char = miss
336 ENDIF
337 
338 END FUNCTION char_to_char_miss
339 
340 
341 FUNCTION trim_char_to_char(in) result(char)
342 CHARACTER(len=*),INTENT(in) :: in ! value to be represented as CHARACTER
343 CHARACTER(len=LEN_TRIM(in)) :: char
344 
345 char = trim(in)
346 
347 END FUNCTION trim_char_to_char
348 
349 
350 FUNCTION trim_char_to_char_miss(in, miss) RESULT(char)
351 CHARACTER(len=*),INTENT(in) :: in ! value to be represented as CHARACTER
352 CHARACTER(len=*),INTENT(in) :: miss ! replacement for missing valu
353 CHARACTER(len=LEN_TRIM(char_to_char_miss(in,miss))) :: char
354 
355 char = char_to_char_miss(in, miss)
356 
357 END 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.
362 ELEMENTAL FUNCTION real_to_char(in, miss, form) RESULT(char)
363 REAL,INTENT(in) :: in ! value to be represented as CHARACTER
364 CHARACTER(len=*),INTENT(in),OPTIONAL :: miss ! replacement for missing value
365 CHARACTER(len=*),INTENT(in),OPTIONAL :: form ! optional format
366 CHARACTER(len=15) :: char
367 
368 CHARACTER(len=15) :: tmpchar
369 
370 IF (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
381 ELSE
382  IF (PRESENT(form)) THEN
383  WRITE(char,form)in
384  ELSE
385  WRITE(tmpchar,'(G15.9)') in
386  char = adjustl(tmpchar)
387  ENDIF
388 ENDIF
389 
390 END FUNCTION real_to_char
393 FUNCTION trim_real_to_char(in) RESULT(char)
394 REAL,INTENT(in) :: in ! value to be represented as CHARACTER
395 CHARACTER(len=LEN_TRIM(to_char(in))) :: char
396 
397 char = real_to_char(in)
398 
399 END FUNCTION trim_real_to_char
400 
401 
402 FUNCTION trim_real_to_char_miss(in, miss) RESULT(char)
403 REAL,INTENT(in) :: in ! value to be represented as CHARACTER
404 CHARACTER(len=*),INTENT(in) :: miss ! replacement for missing value
405 CHARACTER(len=LEN_TRIM(to_char(in,miss=miss))) :: char
406 
407 char = real_to_char(in, miss=miss)
408 
409 END 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.
414 ELEMENTAL FUNCTION double_to_char(in, miss, form) RESULT(char)
415 DOUBLE PRECISION,INTENT(in) :: in ! value to be represented as CHARACTER
416 CHARACTER(len=*),INTENT(in),OPTIONAL :: miss ! replacement for missing value
417 CHARACTER(len=*),INTENT(in),OPTIONAL :: form ! optional format
418 CHARACTER(len=24) :: char
419 
420 CHARACTER(len=24) :: tmpchar
421 
422 IF (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
433 ELSE
434  IF (PRESENT(form)) THEN
435  WRITE(char,form)in
436  ELSE
437  WRITE(tmpchar,'(G24.17)') in
438  char = adjustl(tmpchar)
439  ENDIF
440 ENDIF
441 
442 END FUNCTION double_to_char
443 
444 
445 FUNCTION trim_double_to_char(in) RESULT(char)
446 DOUBLE PRECISION,INTENT(in) :: in ! value to be represented as CHARACTER
447 CHARACTER(len=LEN_TRIM(to_char(in))) :: char
448 
449 char=double_to_char(in)
450 
451 END FUNCTION trim_double_to_char
452 
453 
454 FUNCTION trim_double_to_char_miss(in, miss) RESULT(char)
455 DOUBLE PRECISION,INTENT(in) :: in ! value to be represented as CHARACTER
456 CHARACTER(len=*),INTENT(in) :: miss ! replacement for missing value
457 CHARACTER(len=LEN_TRIM(to_char(in,miss=miss))) :: char
458 
459 char=double_to_char(in, miss=miss)
460 
461 END 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.
466 ELEMENTAL FUNCTION logical_to_char(in, form) RESULT(char)
467 LOGICAL,INTENT(in) :: in ! value to be represented as CHARACTER
468 CHARACTER(len=*),INTENT(in),OPTIONAL :: form ! optional format
469 CHARACTER(len=1) :: char
470 
471 IF (PRESENT(form)) THEN
472  WRITE(char,form) in
473 ELSE
474  WRITE(char,'(L1)') in
475 ENDIF
476 
477 END FUNCTION logical_to_char
478 
479 
480 ELEMENTAL FUNCTION trim_logical_to_char(in) RESULT(char)
481 LOGICAL,INTENT(in) :: in ! value to be represented as CHARACTER
482 
483 CHARACTER(len=1) :: char
484 
485 WRITE(char,'(L1)') in
486 
487 END FUNCTION trim_logical_to_char
488 
489 
494 ELEMENTAL FUNCTION c2i(string) RESULT(num)
495 CHARACTER(len=*),INTENT(in) :: string
496 INTEGER :: num
497 
498 INTEGER :: lier
499 
500 IF (.NOT.c_e(string)) THEN
501  num = imiss
502 ELSE IF (len_trim(string) == 0) THEN
503  num = imiss
504 ELSE
505  READ(string, '(I32)', iostat=lier)num
506  IF (lier /= 0) THEN
507  num = imiss
508  ENDIF
509 ENDIF
510 
511 END FUNCTION c2i
512 
513 
518 ELEMENTAL FUNCTION c2r(string) RESULT(num)
519 CHARACTER(len=*),INTENT(in) :: string
520 REAL :: num
521 
522 INTEGER :: lier
523 
524 IF (.NOT.c_e(string)) THEN
525  num = rmiss
526 ELSE IF (len_trim(string) == 0) THEN
527  num = rmiss
528 ELSE
529  READ(string, '(F32.0)', iostat=lier)num
530  IF (lier /= 0) THEN
531  num = rmiss
532  ENDIF
533 ENDIF
534 
535 END FUNCTION c2r
536 
537 
542 ELEMENTAL FUNCTION c2d(string) RESULT(num)
543 CHARACTER(len=*),INTENT(in) :: string
544 DOUBLE PRECISION :: num
545 
546 INTEGER :: lier
547 
548 IF (.NOT.c_e(string)) THEN
549  num = rmiss
550 ELSE IF (len_trim(string) == 0) THEN
551  num = rmiss
552 ELSE
553  READ(string, '(F32.0)', iostat=lier)num
554  IF (lier /= 0) THEN
555  num = rmiss
556  ENDIF
557 ENDIF
558 
559 END FUNCTION c2d
560 
561 
567 FUNCTION fchar_to_cstr(fchar) RESULT(cstr)
568 CHARACTER(len=*), INTENT(in) :: fchar
569 INTEGER(kind=int_b) :: cstr(len(fchar)+1)
570 
571 cstr(1:len(fchar)) = transfer(fchar, cstr, len(fchar))
572 cstr(len(fchar)+1) = 0 ! zero-terminate
573 
574 END FUNCTION fchar_to_cstr
575 
576 
582 SUBROUTINE fchar_to_cstr_alloc(fchar, pcstr)
583 CHARACTER(len=*), INTENT(in) :: fchar
584 INTEGER(kind=int_b), POINTER :: pcstr(:)
585 
586 ALLOCATE(pcstr(len(fchar)+1))
587 pcstr(1:len(fchar)) = transfer(fchar, pcstr, len(fchar))
588 pcstr(len(fchar)+1) = 0 ! zero-terminate
589 
590 END SUBROUTINE fchar_to_cstr_alloc
591 
592 
596 FUNCTION cstr_to_fchar(cstr) RESULT(fchar)
597 INTEGER(kind=int_b), INTENT(in) :: cstr(:)
598 CHARACTER(len=SIZE(cstr)-1) :: fchar
599 
600 INTEGER :: i
601 
602 !l = MIN(LEN(char), SIZE(cstr)-1)
603 fchar = transfer(cstr(1:SIZE(cstr)-1), fchar)
604 DO 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
609 ENDDO
610 
611 END FUNCTION cstr_to_fchar
612 
613 
615 FUNCTION uppercase ( Input_String ) RESULT ( Output_String )
616 CHARACTER( * ), INTENT( IN ) :: input_string
617 CHARACTER( LEN( Input_String ) ) :: output_string
618  ! -- Local variables
619 INTEGER :: i, n
620 
621  ! -- Copy input string
622 output_string = input_string
623  ! -- Loop over string elements
624 DO 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 )
629 END DO
630 END FUNCTION uppercase
631 
632 
634 FUNCTION lowercase ( Input_String ) RESULT ( Output_String )
635  ! -- Argument and result
636 CHARACTER( * ), INTENT( IN ) :: input_string
637 CHARACTER( LEN( Input_String ) ) :: output_string
638  ! -- Local variables
639 INTEGER :: i, n
640 
641  ! -- Copy input string
642 output_string = input_string
643  ! -- Loop over string elements
644 DO 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 )
649 END DO
650 END FUNCTION lowercase
651 
652 
658 ELEMENTAL FUNCTION align_center(input_string) RESULT(aligned)
659 CHARACTER(len=*), INTENT(in) :: input_string
660 
661 CHARACTER(len=LEN(input_string)) :: aligned
662 
663 INTEGER :: n1, n2
664 
665 n1 = f_nblnk(input_string)
666 n2 = len(input_string)-l_nblnk(input_string)+1
667 
668 aligned = ''
669 aligned((n1+n2)/2:) = input_string(n1:)
670 
671 END FUNCTION align_center
672 
673 
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
682 
683 CHARACTER(len=1) :: lblnk
684 INTEGER :: nblnk
685 
686 IF (PRESENT(blnk)) THEN
687  lblnk = blnk
688 ELSE
689  lblnk = ' '
690 ENDIF
691 
692 DO nblnk = len(input_string), 1, -1
693  IF (input_string(nblnk:nblnk) /= lblnk) RETURN
694 ENDDO
695 
696 END FUNCTION l_nblnk
697 
698 
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
705 
706 CHARACTER(len=1) :: lblnk
707 INTEGER :: nblnk
708 
709 IF (PRESENT(blnk)) THEN
710  lblnk = blnk
711 ELSE
712  lblnk = ' '
713 ENDIF
714 
715 DO nblnk = 1, len(input_string)
716  IF (input_string(nblnk:nblnk) /= lblnk) RETURN
717 ENDDO
718 
719 END FUNCTION f_nblnk
720 
721 
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
733 
734 INTEGER :: nword
735 
736 INTEGER :: ls, le
737 INTEGER, POINTER :: lsv(:), lev(:)
738 CHARACTER(len=1) :: lsep
739 
740 IF (PRESENT(sep)) THEN
741  lsep = sep
742 ELSE
743  lsep = ' '
744 ENDIF
745 
746 nword = 0
747 le = 0
748 DO 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
758 ENDDO
759 
760 IF (.NOT.PRESENT(word_start) .AND. .NOT.PRESENT(word_end)) RETURN
761 
762 ALLOCATE(lsv(nword), lev(nword))
763 nword = 0
764 le = 0
765 DO 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
777 ENDDO
778 
779 IF (PRESENT(word_start)) THEN
780  word_start => lsv
781 ELSE
782  DEALLOCATE(lsv)
783 ENDIF
784 IF (PRESENT(word_end)) THEN
785  word_end => lev
786 ELSE
787  DEALLOCATE(lev)
788 ENDIF
789 
790 END FUNCTION word_split
791 
792 
797 FUNCTION line_split_new(line, ncols) RESULT(this)
798 CHARACTER(len=*), INTENT(in) :: line
799 INTEGER, INTENT(in), OPTIONAL :: ncols
800 
801 TYPE(line_split) :: this
802 
803 INTEGER :: nw, nwords, nlines, columns_in_line, words_in_line, ncols_next_word
804 
805 IF (PRESENT(ncols)) THEN
806  this%ncols = ncols
807 ELSE
808  this%ncols = default_columns()
809 ENDIF
810 ! split the input line
811 nwords = word_split(line, this%word_start, this%word_end)
812 ! count the lines required to accomodate the input line in a paragraph
813 nlines = 0
814 nw = 0
815 DO 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
832 ENDDO
834 !IF (nlines == 0)
835 ALLOCATE(this%paragraph(this%ncols, nlines))
836 this%paragraph = ' '
837 ! repeat filling the paragraph
838 nlines = 0
839 nw = 0
840 DO 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
870 ENDDO
871 
872 END 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.
878 SUBROUTINE line_split_delete(this)
879 TYPE(line_split), INTENT(inout) :: this ! object to be destroyed
880 
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)
884 
885 END SUBROUTINE line_split_delete
886 
887 
889 FUNCTION line_split_get_nlines(this) RESULT(nlines)
890 TYPE(line_split), INTENT(in) :: this
891 
892 INTEGER :: nlines
893 
894 IF (ASSOCIATED(this%paragraph)) THEN
895  nlines = SIZE(this%paragraph, 2)
896 ELSE
897  nlines = 0
898 ENDIF
899 
900 END FUNCTION line_split_get_nlines
902 
907 FUNCTION line_split_get_line(this, nline) RESULT(line)
908 TYPE(line_split), INTENT(in) :: this
909 INTEGER, INTENT(in) :: nline
910 
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)
914 ELSE
915  line = cmiss
916 ENDIF
917 
918 END FUNCTION line_split_get_line
919 
920 
926 FUNCTION default_columns() RESULT(cols)
927 INTEGER :: cols
928 
929 INTEGER, PARAMETER :: defaultcols = 80 ! default of the defaults
930 INTEGER, PARAMETER :: maxcols = 256 ! maximum value
931 CHARACTER(len=10) :: ccols
932 
933 cols = defaultcols
934 CALL getenv('COLUMNS', ccols)
935 IF (ccols == '') RETURN
936 
937 READ(ccols, '(I10)', err=100) cols
938 cols = min(cols, maxcols)
939 IF (cols <= 0) cols = defaultcols
940 RETURN
941 
942 100 cols = defaultcols ! error in reading the value
943 
944 END FUNCTION default_columns
945 
946 
948 FUNCTION suffixname ( Input_String ) RESULT ( Output_String )
949 ! -- Argument and result
950 CHARACTER( * ), INTENT( IN ) :: input_string
951 CHARACTER( LEN( Input_String ) ) :: output_string
952 ! -- Local variables
953 INTEGER :: i
954 
955 output_string=""
956 i = index(input_string,".",back=.true.)
957 if (i > 0 .and. i < len(input_string)) output_string= input_string(i+1:)
958 
959 END FUNCTION suffixname
960 
961 
968 ELEMENTAL 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(:)
974 
975 CHARACTER(len=len(in)) :: char,charr,charrr
976 INTEGER :: i,ia,nchar
977 
978 char=""
979 charr=""
980 charrr=""
981 
982 if (present(goodchar)) then
983 
984 allocate(igoodchar(len(goodchar)))
985 
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 
999 deallocate(igoodchar)
1000 
1001 else
1002 
1003  charrr=in
1004 
1005 end if
1006 
1007 
1008 
1009 if (present(badchar)) then
1010 
1011 allocate(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 
1026 deallocate(ibadchar)
1027 
1028 else
1029 
1030  charr=charrr
1031 
1032 end if
1033 
1034 
1035 if (.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 
1047 else
1048 
1049  char=charr
1050 
1051 end if
1052 
1053 
1054 END 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 
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))
1101 
1102 integer :: i
1103 
1104 do i =1,size(string)
1105  match(i)=string_match(string(i),pattern)
1106 end do
1107 
1108 end function string_match_v
1109 
1110 
1114 recursive 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
1219 end function string_match
1220 
1221 
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)
1226 FLUSH(unit=6) ! probably useless with gfortran, required with Intel fortran
1227 END SUBROUTINE print_status_line
1228 
1229 SUBROUTINE done_status_line()
1230 WRITE(stdout_unit,'()')
1231 END SUBROUTINE done_status_line
1232 
1233 
1242 SUBROUTINE progress_line_update_d(this, val)
1243 CLASS(progress_line),INTENT(inout) :: this
1244 DOUBLE PRECISION,INTENT(in) :: val
1245 
1246 INTEGER :: vint, i
1247 CHARACTER(len=512) :: line
1248 
1249 IF (this%curr >= this%max) RETURN ! line is already closed, do nothing
1250 
1251 this%curr = max(this%min, min(this%max, val))
1252 this%spin = mod(this%spin+1, 4)
1253 line = ''
1254 
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)
1258 vint = vint/10
1259 
1260 DO i = 1, vint
1261  line(this%barloc+i:this%barloc+i) = this%done
1262 ENDDO
1263 DO i = vint+1, 10
1264  line(this%barloc+i:this%barloc+i) = this%todo
1265 ENDDO
1266 CALL print_status_line(line)
1267 IF (this%curr >= this%max) CALL done_status_line()
1268 
1269 END SUBROUTINE progress_line_update_d
1270 
1271 
1276 SUBROUTINE progress_line_update_i(this, val)
1277 CLASS(progress_line),INTENT(inout) :: this
1278 INTEGER,INTENT(in) :: val
1279 
1280 CALL progress_line_update_d(this, dble(val))
1281 
1282 END SUBROUTINE progress_line_update_i
1283 
1289 SUBROUTINE progress_line_alldone(this)
1290 CLASS(progress_line),INTENT(inout) :: this
1291 CALL progress_line_update_d(this, this%max)
1292 END SUBROUTINE progress_line_alldone
1293 
1294 
1295 END MODULE char_utilities
Function to check whether a value is missing or not.
Set of functions that return a trimmed CHARACTER representation of the input variable.
Tries to match the given string with the pattern Result: .true.
Destructor for the line_split class.
Class to print a progress bar on the screen.
Index method.
Set of functions that return a CHARACTER representation of the input variable.
Definitions of constants and functions for working with missing values.
Definition of constants related to I/O units.
Definition: io_units.F90:235
Class that allows splitting a long line into shorter lines of equal length at the occurrence of a spe...
Utilities for CHARACTER variables.
Definition of constants to be used for declaring variables of a desired type.
Definition: kinds.F90:255

Generated with Doxygen.