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 lowercase(string) 139 !! Convert all upper case characters in a string to lower 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 >= 65) .AND. (iascii <= 90)) THEN 147 string(i:i) = CHAR(iascii + 32) 148 END IF 149 END DO 150 151 END SUBROUTINE lowercase 152 153 SUBROUTINE uppercase(string) 154 !! Convert all lower case characters in a string to upper case. 155 CHARACTER(LEN=*), INTENT(INOUT) :: string 156 157 INTEGER :: i, iascii 158 159 DO i = 1, LEN_TRIM(string) 160 iascii = ICHAR(string(i:i)) 161 IF ((iascii >= 97) .AND. (iascii <= 122)) THEN 162 string(i:i) = CHAR(iascii - 32) 163 END IF 164 END DO 165 166 END SUBROUTINE uppercase 167 168 SUBROUTINE xstring(string, ia, ib) 169 170 CHARACTER(LEN=*), INTENT(IN) :: string 171 INTEGER, INTENT(OUT) :: ia, ib 172 173 ia = 1 174 ib = LEN_TRIM(string) 175 IF (ib > 0) THEN 176 DO WHILE (string(ia:ia) == ' ') 177 ia = ia + 1 178 END DO 179 END IF 180 181 END SUBROUTINE xstring 182 183 FUNCTION str_comp(str1, str2) RESULT(equal) 184 185 CHARACTER(LEN=*), INTENT(IN) :: str1, str2 186 LOGICAL :: equal 187 188 INTEGER :: i1, i2, j1, j2 189 190 i1 = 0 191 i2 = 0 192 j1 = 0 193 j2 = 0 194 CALL xstring(str1, i1, i2) 195 CALL xstring(str2, j1, j2) 196 equal = (str1(i1:i2) == str2(j1:j2)) 197 END FUNCTION str_comp 198 199 FUNCTION is_whitespace(testchar) RESULT(resval) 200 !! returns .true. if the character passed is a whitespace char. 201 CHARACTER(LEN=1), INTENT(IN) :: testchar 202 LOGICAL :: resval 203 204 resval = .FALSE. 205 IF (ANY(default_blank_character == testchar)) resval = .TRUE. 206 END FUNCTION is_whitespace 207 208END MODULE dbcsr_string_utilities 209