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