GCC Code Coverage Report

Directory: ./
File: misc/ioipsl_stringop.f90
Date: 2022-01-11 19:19:34
Exec Total Coverage
Lines: 0 65 0.0%
Branches: 0 82 0.0%
Line Branch Exec Source
1 !
2 ! $Id$
3 !
4 ! Module/Routines extracted from IOIPSL v2_1_8
5 !
6 MODULE ioipsl_stringop
7 !-
8 !$Id: stringop.f90 386 2008-09-04 08:38:48Z bellier $
9 !-
10 ! This software is governed by the CeCILL license
11 ! See IOIPSL/IOIPSL_License_CeCILL.txt
12 !---------------------------------------------------------------------
13 !-
14 INTEGER,DIMENSION(30) :: &
15 & prime=(/1,2,3,5,7,11,13,17,19,23,29,31,37,41,43, &
16 & 47,53,59,61,67,71,73,79,83,89,97,101,103,107,109/)
17 !-
18 !---------------------------------------------------------------------
19 CONTAINS
20 !=
21 ✗ SUBROUTINE cmpblank (str)
22 !---------------------------------------------------------------------
23 !- Compact blanks
24 !---------------------------------------------------------------------
25 CHARACTER(LEN=*),INTENT(inout) :: str
26 !-
27 INTEGER :: lcc,ipb
28 !---------------------------------------------------------------------
29 ✗ lcc = LEN_TRIM(str)
30 ipb = 1
31 DO
32 ✗ IF (ipb >= lcc) EXIT
33 ✗ IF (str(ipb:ipb+1) == ' ') THEN
34 ✗ str(ipb+1:) = str(ipb+2:lcc)
35 ✗ lcc = lcc-1
36 ELSE
37 ipb = ipb+1
38 ENDIF
39 ENDDO
40 !----------------------
41 ✗ END SUBROUTINE cmpblank
42 !===
43 ✗ INTEGER FUNCTION cntpos (c_c,l_c,c_r,l_r)
44 !---------------------------------------------------------------------
45 !- Finds number of occurences of c_r in c_c
46 !---------------------------------------------------------------------
47 IMPLICIT NONE
48 !-
49 CHARACTER(LEN=*),INTENT(in) :: c_c
50 INTEGER,INTENT(IN) :: l_c
51 CHARACTER(LEN=*),INTENT(in) :: c_r
52 INTEGER,INTENT(IN) :: l_r
53 !-
54 INTEGER :: ipos,indx
55 !---------------------------------------------------------------------
56 cntpos = 0
57 ipos = 1
58 ✗ DO
59 ✗ indx = INDEX(c_c(ipos:l_c),c_r(1:l_r))
60 ✗ IF (indx > 0) THEN
61 ✗ cntpos = cntpos+1
62 ✗ ipos = ipos+indx+l_r-1
63 ELSE
64 EXIT
65 ENDIF
66 ENDDO
67 !------------------
68 ✗ END FUNCTION cntpos
69 !===
70 ✗ INTEGER FUNCTION findpos (c_c,l_c,c_r,l_r)
71 !---------------------------------------------------------------------
72 !- Finds position of c_r in c_c
73 !---------------------------------------------------------------------
74 IMPLICIT NONE
75 !-
76 CHARACTER(LEN=*),INTENT(in) :: c_c
77 INTEGER,INTENT(IN) :: l_c
78 CHARACTER(LEN=*),INTENT(in) :: c_r
79 INTEGER,INTENT(IN) :: l_r
80 !---------------------------------------------------------------------
81 ✗ findpos = INDEX(c_c(1:l_c),c_r(1:l_r))
82 ✗ IF (findpos == 0) findpos=-1
83 !-------------------
84 ✗ END FUNCTION findpos
85 !===
86 ✗ SUBROUTINE find_str (str_tab,str,pos)
87 !---------------------------------------------------------------------
88 !- This subroutine looks for a string in a table
89 !---------------------------------------------------------------------
90 !- INPUT
91 !- str_tab : Table of strings
92 !- str : Target we are looking for
93 !- OUTPUT
94 !- pos : -1 if str not found, else value in the table
95 !---------------------------------------------------------------------
96 IMPLICIT NONE
97 !-
98 CHARACTER(LEN=*),DIMENSION(:),INTENT(in) :: str_tab
99 CHARACTER(LEN=*),INTENT(in) :: str
100 INTEGER,INTENT(out) :: pos
101 !-
102 INTEGER :: nb_str,i
103 !---------------------------------------------------------------------
104 ✗ pos = -1
105 ✗ nb_str=SIZE(str_tab)
106 ✗ IF ( nb_str > 0 ) THEN
107 ✗ DO i=1,nb_str
108 ✗ IF ( TRIM(str_tab(i)) == TRIM(str) ) THEN
109 ✗ pos = i
110 ✗ EXIT
111 ENDIF
112 ENDDO
113 ENDIF
114 !----------------------
115 ✗ END SUBROUTINE find_str
116 !===
117 ✗ SUBROUTINE nocomma (str)
118 !---------------------------------------------------------------------
119 !- Replace commas with blanks
120 !---------------------------------------------------------------------
121 IMPLICIT NONE
122 !-
123 CHARACTER(LEN=*) :: str
124 !-
125 INTEGER :: i
126 !---------------------------------------------------------------------
127 ✗ DO i=1,LEN_TRIM(str)
128 ✗ IF (str(i:i) == ',') str(i:i) = ' '
129 ENDDO
130 !---------------------
131 ✗ END SUBROUTINE nocomma
132 !===
133 ✗ SUBROUTINE strlowercase (str)
134 !---------------------------------------------------------------------
135 !- Converts a string into lowercase
136 !---------------------------------------------------------------------
137 IMPLICIT NONE
138 !-
139 CHARACTER(LEN=*) :: str
140 !-
141 INTEGER :: i,ic
142 !---------------------------------------------------------------------
143 ✗ DO i=1,LEN_TRIM(str)
144 ✗ ic = IACHAR(str(i:i))
145 ✗ IF ( (ic >= 65).AND.(ic <= 90) ) str(i:i) = ACHAR(ic+32)
146 ENDDO
147 !--------------------------
148 ✗ END SUBROUTINE strlowercase
149 !===
150 ✗ SUBROUTINE struppercase (str)
151 !---------------------------------------------------------------------
152 !- Converts a string into uppercase
153 !---------------------------------------------------------------------
154 IMPLICIT NONE
155 !-
156 CHARACTER(LEN=*) :: str
157 !-
158 INTEGER :: i,ic
159 !---------------------------------------------------------------------
160 ✗ DO i=1,LEN_TRIM(str)
161 ✗ ic = IACHAR(str(i:i))
162 ✗ IF ( (ic >= 97).AND.(ic <= 122) ) str(i:i) = ACHAR(ic-32)
163 ENDDO
164 !--------------------------
165 ✗ END SUBROUTINE struppercase
166 !===
167 ✗ SUBROUTINE gensig (str,sig)
168 !---------------------------------------------------------------------
169 !- Generate a signature from the first 30 characters of the string
170 !- This signature is not unique and thus when one looks for the
171 !- one needs to also verify the string.
172 !---------------------------------------------------------------------
173 IMPLICIT NONE
174 !-
175 CHARACTER(LEN=*) :: str
176 INTEGER :: sig
177 !-
178 INTEGER :: i
179 !---------------------------------------------------------------------
180 ✗ sig = 0
181 ✗ DO i=1,MIN(LEN_TRIM(str),30)
182 ✗ sig = sig + prime(i)*IACHAR(str(i:i))
183 ENDDO
184 !--------------------
185 ✗ END SUBROUTINE gensig
186 !===
187 ✗ SUBROUTINE find_sig (nb_sig,str_tab,str,sig_tab,sig,pos)
188 !---------------------------------------------------------------------
189 !- Find the string signature in a list of signatures
190 !---------------------------------------------------------------------
191 !- INPUT
192 !- nb_sig : length of table of signatures
193 !- str_tab : Table of strings
194 !- str : Target string we are looking for
195 !- sig_tab : Table of signatures
196 !- sig : Target signature we are looking for
197 !- OUTPUT
198 !- pos : -1 if str not found, else value in the table
199 !---------------------------------------------------------------------
200 IMPLICIT NONE
201 !-
202 INTEGER :: nb_sig
203 CHARACTER(LEN=*),DIMENSION(nb_sig) :: str_tab
204 CHARACTER(LEN=*) :: str
205 INTEGER,DIMENSION(nb_sig) :: sig_tab
206 INTEGER :: sig
207 !-
208 INTEGER :: pos
209 ✗ INTEGER,DIMENSION(nb_sig) :: loczeros
210 !-
211 INTEGER :: il,len
212 INTEGER,DIMENSION(1) :: minpos
213 !---------------------------------------------------------------------
214 ✗ pos = -1
215 ✗ il = LEN_TRIM(str)
216 !-
217 ✗ IF ( nb_sig > 0 ) THEN
218 ✗ loczeros = ABS(sig_tab(1:nb_sig)-sig)
219 ✗ IF ( COUNT(loczeros < 1) == 1 ) THEN
220 ✗ minpos = MINLOC(loczeros)
221 ✗ len = LEN_TRIM(str_tab(minpos(1)))
222 IF ( (INDEX(str_tab(minpos(1)),str(1:il)) > 0) &
223 ✗ .AND.(len == il) ) THEN
224 ✗ pos = minpos(1)
225 ENDIF
226 ✗ ELSE IF ( COUNT(loczeros < 1) > 1 ) THEN
227 ✗ DO WHILE (COUNT(loczeros < 1) >= 1 .AND. pos < 0 )
228 ✗ minpos = MINLOC(loczeros)
229 ✗ len = LEN_TRIM(str_tab(minpos(1)))
230 IF ( (INDEX(str_tab(minpos(1)),str(1:il)) > 0) &
231 ✗ .AND.(len == il) ) THEN
232 ✗ pos = minpos(1)
233 ELSE
234 ✗ loczeros(minpos(1)) = 99999
235 ENDIF
236 ENDDO
237 ENDIF
238 ENDIF
239 !-----------------------
240 ✗ END SUBROUTINE find_sig
241 !===
242 !------------------
243 END MODULE ioipsl_stringop
244