1!--------------------------------------------------------------------------------------------------! 2! Copyright (C) by the DBCSR developers group - All rights reserved ! 3! This file is part of the DBCSR library. ! 4! ! 5! For information on the license, see the LICENSE file. ! 6! For further information please visit https://dbcsr.cp2k.org ! 7! SPDX-License-Identifier: GPL-2.0+ ! 8!--------------------------------------------------------------------------------------------------! 9 10MODULE dbcsr_string_utilities 11 !! Utilities for string manipulations 12 13 USE dbcsr_kinds, ONLY: default_blank_character 14 15 IMPLICIT NONE 16 17 PRIVATE 18 19 PUBLIC :: ascii_to_string, & 20 compress, & 21 integer_to_string, & 22 is_whitespace, & 23 remove_word, & 24 str_comp, & 25 string_to_ascii, & 26 uppercase, & 27 xstring 28 29CONTAINS 30 31 SUBROUTINE ascii_to_string(nascii, string) 32 !! Convert a sequence of integer numbers (ASCII code) to a string. 33 !! Blanks are inserted for invalid ASCII code numbers. 34 35 INTEGER, DIMENSION(:), INTENT(IN) :: nascii 36 CHARACTER(LEN=*), INTENT(OUT) :: string 37 38 INTEGER :: i 39 40 string = "" 41 42 DO i = 1, MIN(LEN(string), SIZE(nascii)) 43 IF ((nascii(i) >= 0) .AND. (nascii(i) <= 127)) THEN 44 string(i:i) = CHAR(nascii(i)) 45 ELSE 46 string(i:i) = " " 47 END IF 48 END DO 49 50 END SUBROUTINE ascii_to_string 51 52 SUBROUTINE compress(string, full) 53 !! Eliminate multiple space characters in a string. 54 !! If full is .TRUE., then all spaces are eliminated. 55 56 CHARACTER(LEN=*), INTENT(INOUT) :: string 57 LOGICAL, INTENT(IN), OPTIONAL :: full 58 59 CHARACTER :: tmp 60 INTEGER :: i, z 61 LOGICAL :: remove_all 62 63 IF (PRESENT(full)) THEN 64 remove_all = full 65 ELSE 66 remove_all = .FALSE. 67 END IF 68 69 z = 1 70 71 DO i = 1, LEN_TRIM(string) 72 IF ((z == 1) .OR. remove_all) THEN 73 IF (string(i:i) /= " ") THEN 74 tmp = string(i:i) 75 string(z:z) = tmp 76 z = z + 1 77 END IF 78 ELSE 79 IF ((string(i:i) /= " ") .OR. (string(z - 1:z - 1) /= " ")) THEN 80 tmp = string(i:i) 81 string(z:z) = tmp 82 z = z + 1 83 END IF 84 END IF 85 END DO 86 87 string(z:) = "" 88 89 END SUBROUTINE compress 90 91 SUBROUTINE integer_to_string(inumber, string) 92 !! Converts an integer number to a string. 93 !! The WRITE statement will return an error message, if the number of 94 !! digits of the integer number is larger the than the length of the 95 !! supplied string. 96 97 INTEGER, INTENT(IN) :: inumber 98 CHARACTER(LEN=*), INTENT(OUT) :: string 99 100 WRITE (UNIT=string, FMT='(I0)') inumber 101 END SUBROUTINE integer_to_string 102 103 SUBROUTINE string_to_ascii(string, nascii) 104 !! Convert a string to sequence of integer numbers. 105 106 CHARACTER(LEN=*), INTENT(IN) :: string 107 INTEGER, DIMENSION(:), INTENT(OUT) :: nascii 108 109 INTEGER :: i 110 111 nascii(:) = 0 112 113 DO i = 1, MIN(LEN(string), SIZE(nascii)) 114 nascii(i) = ICHAR(string(i:i)) 115 END DO 116 117 END SUBROUTINE string_to_ascii 118 119 SUBROUTINE remove_word(string) 120 !! remove a word from a string (words are separated by white spaces) 121 CHARACTER(LEN=*), INTENT(INOUT) :: string 122 123 INTEGER :: i 124 125 i = 1 126 ! possibly clean white spaces 127 DO WHILE (string(i:i) == " ") 128 i = i + 1 129 END DO 130 ! now remove the word 131 DO WHILE (string(i:i) /= " ") 132 i = i + 1 133 END DO 134 string = string(i:) 135 136 END SUBROUTINE remove_word 137 138 SUBROUTINE uppercase(string) 139 !! Convert all lower case characters in a string to upper case. 140 CHARACTER(LEN=*), INTENT(INOUT) :: string 141 142 INTEGER :: i, iascii 143 144 DO i = 1, LEN_TRIM(string) 145 iascii = ICHAR(string(i:i)) 146 IF ((iascii >= 97) .AND. (iascii <= 122)) THEN 147 string(i:i) = CHAR(iascii - 32) 148 END IF 149 END DO 150 151 END SUBROUTINE uppercase 152 153 SUBROUTINE xstring(string, ia, ib) 154 155 CHARACTER(LEN=*), INTENT(IN) :: string 156 INTEGER, INTENT(OUT) :: ia, ib 157 158 ia = 1 159 ib = LEN_TRIM(string) 160 IF (ib > 0) THEN 161 DO WHILE (string(ia:ia) == ' ') 162 ia = ia + 1 163 END DO 164 END IF 165 166 END SUBROUTINE xstring 167 168 FUNCTION str_comp(str1, str2) RESULT(equal) 169 170 CHARACTER(LEN=*), INTENT(IN) :: str1, str2 171 LOGICAL :: equal 172 173 INTEGER :: i1, i2, j1, j2 174 175 i1 = 0 176 i2 = 0 177 j1 = 0 178 j2 = 0 179 CALL xstring(str1, i1, i2) 180 CALL xstring(str2, j1, j2) 181 equal = (str1(i1:i2) == str2(j1:j2)) 182 END FUNCTION str_comp 183 184 FUNCTION is_whitespace(testchar) RESULT(resval) 185 !! returns .true. if the character passed is a whitespace char. 186 CHARACTER(LEN=1), INTENT(IN) :: testchar 187 LOGICAL :: resval 188 189 resval = .FALSE. 190 IF (ANY(default_blank_character == testchar)) resval = .TRUE. 191 END FUNCTION is_whitespace 192 193END MODULE dbcsr_string_utilities 194