|
Oasis3 4.0.2
|
|
Oasis3 4.0.2
|
00001 00002 MODULE stringop_psmile 00003 USE mod_kinds_model 00004 !--------------------------------------------------------------------- 00005 !- 00006 INTEGER(kind=ip_intwp_p), DIMENSION(30) :: 00007 prime=(/1,2,3,5,7,11,13,17,19,23,29,31,37,41,43, & 00008 47,53,59,61,67,71,73,79,83,89,97,101,103,107,109/) 00009 !- 00010 !--------------------------------------------------------------------- 00011 CONTAINS 00012 != 00013 SUBROUTINE cmpblank (str) 00014 USE mod_kinds_model 00015 !--------------------------------------------------------------------- 00016 !- 00017 !--------------------------------------------------------------------- 00018 CHARACTER(LEN=*),INTENT(inout) :: str 00019 !- 00020 INTEGER (kind=ip_intwp_p) :: lcc,ipb 00021 !--------------------------------------------------------------------- 00022 lcc = LEN_TRIM(str) 00023 ipb = 1 00024 DO 00025 IF (ipb >= lcc) EXIT 00026 IF (str(ipb:ipb+1) == ' ') THEN 00027 str(ipb+1:) = str(ipb+2:lcc) 00028 lcc = lcc-1 00029 ELSE 00030 ipb = ipb+1 00031 ENDIF 00032 ENDDO 00033 !------------------------- 00034 END SUBROUTINE cmpblank 00035 != 00036 FUNCTION cntpos (c_c,l_c,c_r,l_r) 00037 !--------------------------------------------------------------------- 00038 !- Finds number of occurences of c_r in c_c 00039 !--------------------------------------------------------------------- 00040 USE mod_kinds_model 00041 IMPLICIT NONE 00042 !- 00043 INTEGER (kind=ip_intwp_p) :: cntpos 00044 00045 CHARACTER(LEN=*),INTENT(in) :: c_c 00046 INTEGER (kind=ip_intwp_p),INTENT(IN) :: l_c 00047 CHARACTER(LEN=*),INTENT(in) :: c_r 00048 INTEGER (kind=ip_intwp_p),INTENT(IN) :: l_r 00049 !- 00050 INTEGER (kind=ip_intwp_p) :: ipos,indx,ires 00051 !--------------------------------------------------------------------- 00052 cntpos = 0 00053 ipos = 1 00054 DO 00055 indx = INDEX(c_c(ipos:l_c),c_r(1:l_r)) 00056 IF (indx > 0) THEN 00057 cntpos = cntpos+1 00058 ipos = ipos+indx+l_r-1 00059 ELSE 00060 EXIT 00061 ENDIF 00062 ENDDO 00063 !--------------------- 00064 END FUNCTION cntpos 00065 != 00066 FUNCTION findpos (c_c,l_c,c_r,l_r) 00067 !--------------------------------------------------------------------- 00068 !- Finds position of c_r in c_c 00069 !--------------------------------------------------------------------- 00070 USE mod_kinds_model 00071 IMPLICIT NONE 00072 !- 00073 INTEGER (kind=ip_intwp_p) :: findpos 00074 CHARACTER(LEN=*),INTENT(in) :: c_c 00075 INTEGER (kind=ip_intwp_p),INTENT(IN) :: l_c 00076 CHARACTER(LEN=*),INTENT(in) :: c_r 00077 INTEGER (kind=ip_intwp_p),INTENT(IN) :: l_r 00078 !--------------------------------------------------------------------- 00079 findpos = INDEX(c_c(1:l_c),c_r(1:l_r)) 00080 IF (findpos == 0) findpos=-1 00081 !---------------------- 00082 END FUNCTION findpos 00083 != 00084 SUBROUTINE find_str (nb_str,str_tab,str_len_tab,str,pos) 00085 !--------------------------------------------------------------------- 00086 !- This subroutine looks for a string in a table 00087 !--------------------------------------------------------------------- 00088 !- INPUT 00089 !- nb_str : length of table 00090 !- str_tab : Table of strings 00091 !- str_len_tab : Table of string-length 00092 !- str : Target we are looking for 00093 !- OUTPUT 00094 !- pos : -1 if str not found, else value in the table 00095 !--------------------------------------------------------------------- 00096 USE mod_kinds_model 00097 IMPLICIT NONE 00098 !- 00099 INTEGER (kind=ip_intwp_p) :: nb_str 00100 CHARACTER(LEN=*),DIMENSION(nb_str) :: str_tab 00101 INTEGER (kind=ip_intwp_p),DIMENSION(nb_str) :: str_len_tab 00102 CHARACTER(LEN=*) :: str 00103 INTEGER (kind=ip_intwp_p) :: pos 00104 !- 00105 INTEGER (kind=ip_intwp_p) :: i,il 00106 !--------------------------------------------------------------------- 00107 pos = -1 00108 il = LEN_TRIM(str) 00109 IF ( nb_str > 0 ) THEN 00110 DO i=1,nb_str 00111 IF ( (INDEX(str_tab(i),str(1:il)) > 0) & 00112 .AND.(str_len_tab(i) == il) ) THEN 00113 pos = i 00114 EXIT 00115 ENDIF 00116 ENDDO 00117 ENDIF 00118 !------------------------- 00119 END SUBROUTINE find_str 00120 != 00121 SUBROUTINE nocomma (str) 00122 !--------------------------------------------------------------------- 00123 !- 00124 !--------------------------------------------------------------------- 00125 USE mod_kinds_model 00126 IMPLICIT NONE 00127 !- 00128 CHARACTER(LEN=*) :: str 00129 !- 00130 INTEGER (kind=ip_intwp_p) :: i 00131 !--------------------------------------------------------------------- 00132 DO i=1,LEN_TRIM(str) 00133 IF (str(i:i) == ',') str(i:i) = ' ' 00134 ENDDO 00135 !------------------------ 00136 END SUBROUTINE nocomma 00137 != 00138 SUBROUTINE strlowercase (str) 00139 !--------------------------------------------------------------------- 00140 !- Converts a string into lowercase 00141 !--------------------------------------------------------------------- 00142 USE mod_kinds_model 00143 IMPLICIT NONE 00144 !- 00145 CHARACTER(LEN=*) :: str 00146 !- 00147 INTEGER (kind=ip_intwp_p) :: i,ic 00148 !--------------------------------------------------------------------- 00149 DO i=1,LEN_TRIM(str) 00150 ic = IACHAR(str(i:i)) 00151 IF ( (ic >= 65) .AND. (ic <= 90) ) str(i:i) = ACHAR(ic+32) 00152 ENDDO 00153 !----------------------------- 00154 END SUBROUTINE strlowercase 00155 != 00156 SUBROUTINE struppercase (str) 00157 !--------------------------------------------------------------------- 00158 !- Converts a string into uppercase 00159 !--------------------------------------------------------------------- 00160 USE mod_kinds_model 00161 IMPLICIT NONE 00162 !- 00163 CHARACTER(LEN=*) :: str 00164 !- 00165 INTEGER (kind=ip_intwp_p) :: i,ic 00166 !--------------------------------------------------------------------- 00167 DO i=1,LEN_TRIM(str) 00168 ic = IACHAR(str(i:i)) 00169 IF ( (ic >= 97) .AND. (ic <= 122) ) str(i:i) = ACHAR(ic-32) 00170 ENDDO 00171 !----------------------------- 00172 END SUBROUTINE struppercase 00173 != 00174 !------------------ 00175 SUBROUTINE gensig (str, sig) 00176 !--------------------------------------------------------------------- 00177 !- Generate a signature from the first 30 characters of the string 00178 !- This signature is not unique and thus when one looks for the 00179 !- one needs to also verify the string. 00180 !--------------------------------------------------------------------- 00181 USE mod_kinds_model 00182 IMPLICIT NONE 00183 !- 00184 CHARACTER(LEN=*) :: str 00185 INTEGER (kind=ip_intwp_p) :: sig 00186 !- 00187 INTEGER (kind=ip_intwp_p) :: i 00188 !--------------------------------------------------------------------- 00189 sig = 0 00190 DO i=1,MIN(len_trim(str),30) 00191 sig = sig + prime(i)*IACHAR(str(i:i)) 00192 ENDDO 00193 !----------------------------- 00194 END SUBROUTINE gensig 00195 != 00196 !------------------ 00197 SUBROUTINE find_sig (nb_sig, str_tab, str, sig_tab, sig, pos) 00198 !--------------------------------------------------------------------- 00199 !- Find the string signature in a list of signatures 00200 !--------------------------------------------------------------------- 00201 !- INPUT 00202 !- nb_sig : length of table of signatures 00203 !- str_tab : Table of strings 00204 !- str : Target string we are looking for 00205 !- sig_tab : Table of signatures 00206 !- sig : Target signature we are looking for 00207 !- OUTPUT 00208 !- pos : -1 if str not found, else value in the table 00209 !--------------------------------------------------------------------- 00210 USE mod_kinds_model 00211 IMPLICIT NONE 00212 !- 00213 INTEGER (kind=ip_intwp_p) :: nb_sig 00214 CHARACTER(LEN=*),DIMENSION(nb_sig) :: str_tab 00215 CHARACTER(LEN=*) :: str 00216 INTEGER (kind=ip_intwp_p), DIMENSION(nb_sig) :: sig_tab 00217 INTEGER (kind=ip_intwp_p) :: sig 00218 !- 00219 INTEGER (kind=ip_intwp_p) :: pos 00220 INTEGER (kind=ip_intwp_p), DIMENSION(nb_sig) :: loczeros 00221 !- 00222 INTEGER (kind=ip_intwp_p) :: il, len 00223 INTEGER (kind=ip_intwp_p), DIMENSION(1) :: minpos 00224 !--------------------------------------------------------------------- 00225 !- 00226 pos = -1 00227 il = LEN_TRIM(str) 00228 !- 00229 IF ( nb_sig > 0 ) THEN 00230 ! 00231 loczeros = ABS(sig_tab(1:nb_sig)-sig) 00232 ! 00233 IF ( COUNT(loczeros < 1) == 1 ) THEN 00234 ! 00235 minpos = MINLOC(loczeros) 00236 len = LEN_TRIM(str_tab(minpos(1))) 00237 IF ( (INDEX(str_tab(minpos(1)),str(1:il)) > 0) & 00238 .AND.(len == il) ) THEN 00239 pos = minpos(1) 00240 ENDIF 00241 ! 00242 ELSE IF ( COUNT(loczeros < 1) > 1 ) THEN 00243 ! 00244 DO WHILE (COUNT(loczeros < 1) >= 1 .AND. pos < 0 ) 00245 minpos = MINLOC(loczeros) 00246 len = LEN_TRIM(str_tab(minpos(1))) 00247 IF ( (INDEX(str_tab(minpos(1)),str(1:il)) > 0) & 00248 .AND.(len == il) ) THEN 00249 pos = minpos(1) 00250 ELSE 00251 loczeros(minpos(1)) = 99999 00252 ENDIF 00253 ENDDO 00254 ! 00255 ENDIF 00256 ! 00257 ENDIF 00258 !- 00259 END SUBROUTINE find_sig 00260 != 00261 !------------------ 00262 END MODULE stringop_psmile
1.7.4 
