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