Changeset 5
- Timestamp:
- 03/12/07 10:26:08 (18 years ago)
- File:
-
- 1 edited
-
IOIPSL/trunk/src/stringop.f90 (modified) (5 diffs)
Legend:
- Unmodified
- Added
- Removed
-
IOIPSL/trunk/src/stringop.f90
r4 r5 1 !$Head er: /home/ioipsl/CVSROOT/IOIPSL/src/stringop.f90,v 2.0 2004/04/05 14:47:51 adm Exp$2 ! 1 !$HeadURL$ 2 !- 3 3 MODULE stringop 4 4 !--------------------------------------------------------------------- 5 5 !- 6 INTEGER, 7 8 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 9 !- 10 10 !--------------------------------------------------------------------- 11 11 CONTAINS 12 12 != 13 14 !--------------------------------------------------------------------- 15 !- 16 !--------------------------------------------------------------------- 17 18 !- 19 20 !--------------------------------------------------------------------- 21 22 23 24 25 26 27 28 29 30 31 32 !---------------------- ---33 34 != 35 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 36 !--------------------------------------------------------------------- 37 37 !- Finds number of occurences of c_r in c_c 38 38 !--------------------------------------------------------------------- 39 40 !- 41 42 43 44 45 !- 46 INTEGER :: ipos,indx,ires47 !--------------------------------------------------------------------- 48 49 50 51 52 53 54 55 56 57 58 59 !------------------ ---60 61 != 62 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 63 !--------------------------------------------------------------------- 64 64 !- Finds position of c_r in c_c 65 65 !--------------------------------------------------------------------- 66 67 !- 68 69 70 71 72 !--------------------------------------------------------------------- 73 74 IF (findpos == 0)findpos=-175 !------------------- ---76 77 != 78 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 79 !--------------------------------------------------------------------- 80 80 !- This subroutine looks for a string in a table … … 88 88 !- pos : -1 if str not found, else value in the table 89 89 !--------------------------------------------------------------------- 90 91 !- 92 93 94 95 96 97 !- 98 99 !--------------------------------------------------------------------- 100 101 102 103 104 105 106 107 108 109 110 111 !---------------------- ---112 113 != 114 115 !--------------------------------------------------------------------- 116 !- 117 !--------------------------------------------------------------------- 118 119 !- 120 121 !- 122 123 !--------------------------------------------------------------------- 124 125 126 127 !--------------------- ---128 129 != 130 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 131 !--------------------------------------------------------------------- 132 132 !- Converts a string into lowercase 133 133 !--------------------------------------------------------------------- 134 135 !- 136 137 !- 138 139 !--------------------------------------------------------------------- 140 141 142 IF ( (ic >= 65) .AND. (ic <= 90) )str(i:i) = ACHAR(ic+32)143 144 !-------------------------- ---145 146 != 147 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 148 !--------------------------------------------------------------------- 149 149 !- Converts a string into uppercase 150 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 !------------------ 165 SUBROUTINE gensig (str, sig) 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) 166 165 !--------------------------------------------------------------------- 167 166 !- Generate a signature from the first 30 characters of the string … … 169 168 !- one needs to also verify the string. 170 169 !--------------------------------------------------------------------- 171 IMPLICIT NONE 172 !- 173 CHARACTER(LEN=*) :: str 174 INTEGER :: sig 175 !- 176 INTEGER :: i 177 !--------------------------------------------------------------------- 178 sig = 0 179 DO i=1,MIN(len_trim(str),30) 180 sig = sig + prime(i)*IACHAR(str(i:i)) 181 ENDDO 182 !----------------------------- 183 END SUBROUTINE gensig 184 != 185 !------------------ 186 SUBROUTINE find_sig (nb_sig, str_tab, str, sig_tab, sig, pos) 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) 187 185 !--------------------------------------------------------------------- 188 186 !- Find the string signature in a list of signatures … … 191 189 !- nb_sig : length of table of signatures 192 190 !- str_tab : Table of strings 193 !- str : Target string we are looking for 191 !- str : Target string we are looking for 194 192 !- sig_tab : Table of signatures 195 193 !- sig : Target signature we are looking for … … 197 195 !- pos : -1 if str not found, else value in the table 198 196 !--------------------------------------------------------------------- 199 IMPLICIT NONE 200 !- 201 INTEGER :: nb_sig 202 CHARACTER(LEN=*),DIMENSION(nb_sig) :: str_tab 203 CHARACTER(LEN=*) :: str 204 INTEGER, DIMENSION(nb_sig) :: sig_tab 205 INTEGER :: sig 206 !- 207 INTEGER :: pos 208 INTEGER, DIMENSION(nb_sig) :: loczeros 209 !- 210 INTEGER :: il, len 211 INTEGER, DIMENSION(1) :: minpos 212 !--------------------------------------------------------------------- 213 !- 214 pos = -1 215 il = LEN_TRIM(str) 216 !- 217 IF ( nb_sig > 0 ) THEN 218 ! 219 loczeros = ABS(sig_tab(1:nb_sig)-sig) 220 ! 221 IF ( COUNT(loczeros < 1) == 1 ) THEN 222 ! 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 ENDIF 229 ! 230 ELSE IF ( COUNT(loczeros < 1) > 1 ) THEN 231 ! 232 DO WHILE (COUNT(loczeros < 1) >= 1 .AND. pos < 0 ) 233 minpos = MINLOC(loczeros) 234 len = LEN_TRIM(str_tab(minpos(1))) 235 IF ( (INDEX(str_tab(minpos(1)),str(1:il)) > 0) & 236 .AND.(len == il) ) THEN 237 pos = minpos(1) 238 ELSE 239 loczeros(minpos(1)) = 99999 240 ENDIF 241 ENDDO 242 ! 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) 243 222 ENDIF 244 ! 245 ENDIF 246 !- 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 !----------------------- 247 237 END SUBROUTINE find_sig 248 != 238 !=== 249 239 !------------------ 250 240 END MODULE stringop
Note: See TracChangeset
for help on using the changeset viewer.
