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