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