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