 |
Millepede-II
V04-00-00
|
|
Millepede-II
V04-00-00
|
00001 00002 ! Code converted using TO_F90 by Alan Miller 00003 ! Date: 2012-03-16 Time: 11:09:16 00004 00007 00009 MODULE mptext 00010 IMPLICIT NONE 00011 SAVE 00012 INTEGER:: keya !< start (position) of keyword 00013 INTEGER:: keyb !< end (position) of keyword 00014 00015 END MODULE mptext 00016 00025 00026 SUBROUTINE ratext(text,nums,dnum) 00027 USE mptext 00028 00029 IMPLICIT NONE 00030 INTEGER :: i 00031 INTEGER :: ia 00032 INTEGER :: ib 00033 INTEGER :: ic 00034 INTEGER :: ich 00035 INTEGER :: icl 00036 INTEGER :: icode 00037 INTEGER :: j 00038 INTEGER :: k 00039 00040 INTEGER :: lent 00041 INTEGER :: num 00042 00043 CHARACTER (LEN=*), INTENT(IN) :: text 00044 INTEGER, INTENT(OUT) :: nums 00045 DOUBLE PRECISION, INTENT(OUT) :: dnum(*) 00046 00047 INTEGER :: last ! last non-blank character 00048 INTEGER, PARAMETER :: ndim=1000 00049 INTEGER, DIMENSION(2,ndim):: icd 00050 CHARACTER (LEN=16) :: keywrd 00051 CHARACTER (LEN=1) :: ch 00052 DOUBLE PRECISION :: dic(ndim) 00053 DOUBLE PRECISION :: dumber 00054 INTEGER :: icdt(ndim) 00055 SAVE 00056 ! ... 00057 nums=0 00058 last=0 00059 keya=0 00060 keyb=0 00061 IF(text(1:1) == '*') RETURN 00062 num=ICHAR('0') 00063 lent=0 00064 last=0 00065 DO i=1,LEN(text) ! find comment and end 00066 IF(lent == 0.AND.(text(i:i) == '!'.OR.text(i:i) == '%')) lent=i 00067 IF(text(i:i) /= ' ') last=i 00068 END DO 00069 IF(lent == 0) lent=last+1 00070 icd(1,1)=lent 00071 00072 j=1 00073 icdt(1)=0 00074 icl=0 00075 DO i=1,lent-1 00076 ch =text(i:i) 00077 ich=ICHAR(ch) 00078 ic=0 00079 IF(ch == '.') ic=1 00080 IF(ch == '+') ic=2 00081 IF(ch == '-') ic=3 00082 IF(ch == 'E') ic=4 00083 IF(ch == 'D') ic=4 00084 IF(ch == 'e') ic=4 00085 IF(ch == 'd') ic=4 00086 IF(ic > 0) THEN 00087 j=j+1 00088 icd(1,j)=i 00089 icd(2,j)=i 00090 icdt(j)=ic 00091 ELSE 00092 ic=6 00093 IF(ich >= num.AND.ich <= num+9) ic=5 ! digit 00094 IF(ic /= icl) THEN 00095 j=j+1 00096 icd(1,j)=i 00097 icdt(j)=ic 00098 END IF 00099 icd(2,j)=i 00100 END IF 00101 icl=ic ! previous IC 00102 END DO 00103 icdt(j+1)=0 00104 00105 DO i=1,j ! define number 00106 IF(icdt(i) == 5) THEN 00107 dumber=0.0D0 00108 DO k=icd(1,i),icd(2,i) 00109 dumber=10.d0*dumber+dfloat(ICHAR(text(k:k))-num) 00110 END DO 00111 dic(i)=dumber 00112 END IF 00113 END DO 00114 icdt(j+1)=0 00115 00116 DO i=2,j ! get dots 00117 IF(icdt(i) == 1) THEN 00118 icode=0 00119 IF(icdt(i-1) == 5.AND.icd(2,i-1)+1 == icd(1,i)) icode=1 00120 IF(icdt(i+1) == 5.AND.icd(1,i+1)-1 == icd(2,i)) icode=icode+2 00121 IF(icode == 1) THEN ! 123. 00122 icd(2,i-1)=icd(2,i) 00123 icdt(i)=0 00124 ELSE IF(icode == 2) THEN ! .456 00125 dic(i)=10.0D0**(icd(1,i+1)-icd(2,i+1)-1)*dic(i+1) 00126 icdt(i)=5 00127 icd(2,i)=icd(2,i+1) 00128 icdt(i+1)=0 00129 ELSE IF(icode == 3) THEN ! 123.456 00130 dic(i-1)=dic(i-1)+ 10.0D0**(icd(1,i+1)-icd(2,i+1)-1)*dic(i+1) 00131 icd(2,i-1)=icd(2,i+1) 00132 icdt(i)=0 00133 icdt(i+1)=0 00134 END IF 00135 END IF 00136 END DO 00137 00138 k=1 ! remove blanks, compress 00139 DO i=2,j 00140 IF(icdt(i) == 6.AND.text(icd(1,i):icd(2,i)) == ' ') icdt(i)=0 00141 IF(icdt(i) /= 0) THEN 00142 k=k+1 00143 icd(1,k)=icd(1,i) 00144 icd(2,k)=icd(2,i) 00145 icdt(k)=icdt(i) 00146 dic(k)=dic(i) 00147 END IF 00148 END DO 00149 j=k 00150 00151 DO i=2,j-1 00152 IF(icdt(i) == 2.OR.icdt(i) == 3) THEN ! +- 00153 IF(icdt(i+1) == 5) THEN 00154 icd(1,i+1)=icd(1,i) 00155 IF(icdt(i) == 3) dic(i+1)=-dic(i+1) 00156 icdt(i)=0 00157 END IF 00158 END IF 00159 END DO 00160 00161 k=1 ! compress 00162 DO i=2,j 00163 IF(icdt(i) == 6.AND.text(icd(1,i):icd(2,i)) == ' ') icdt(i)=0 00164 IF(icdt(i) /= 0) THEN 00165 k=k+1 00166 icd(1,k)=icd(1,i) 00167 icd(2,k)=icd(2,i) 00168 icdt(k)=icdt(i) 00169 dic(k)=dic(i) 00170 END IF 00171 END DO 00172 j=k 00173 00174 DO i=2,j-1 00175 IF(icdt(i) == 4) THEN ! E or D 00176 IF(icdt(i-1) == 5.AND.icdt(i+1) == 5) THEN 00177 icd(2,i-1)=icd(2,i+1) 00178 dic(i-1)=dic(i-1)*10.0D0**dic(i+1) 00179 icdt(i)=0 00180 icdt(i+1)=0 00181 END IF 00182 END IF 00183 END DO 00184 00185 nums=0 ! compress 00186 DO i=1,j 00187 IF(icdt(i) == 5) THEN 00188 nums=nums+1 00189 icd(1,nums)=icd(1,i) 00190 icd(2,nums)=icd(2,i) 00191 dnum(nums)=dic(i) 00192 END IF 00193 END DO 00194 00195 keywrd=' ' ! assemble keyword 00196 ia=0 00197 ib=-1 00198 DO i=1,icd(1,1)-1 00199 IF(ia == 0.AND.text(i:i) /= ' ') ia=i 00200 IF(text(i:i) /= ' ') ib=i 00201 END DO 00202 IF(ib >= 0) keywrd=text(ia:ib) 00203 keya=ia 00204 keyb=MAX(0,ib) 00205 END SUBROUTINE ratext 00206 00213 00214 SUBROUTINE rltext(text,ia,ib,nab) 00215 IMPLICIT NONE 00216 INTEGER :: i 00217 INTEGER :: lim 00218 00219 CHARACTER (LEN=*), INTENT(IN) :: text 00220 INTEGER, INTENT(OUT) :: ia 00221 INTEGER, INTENT(OUT) :: ib 00222 INTEGER, INTENT(OUT) :: nab 00223 00224 SAVE 00225 ! ... 00226 ia=0 00227 ib=0 00228 nab=0 00229 lim=0 00230 DO i=1,LEN(text) 00231 IF(text(i:i) /= ' ') nab=i 00232 IF((i == 1.AND.text(1:1) == '*').OR.text(i:i) == '!') THEN 00233 IF(lim == 0) lim=i 00234 END IF 00235 END DO 00236 IF(lim == 0) THEN 00237 lim=nab 00238 ELSE 00239 lim=lim-1 00240 END IF 00241 DO i=1,lim 00242 IF(ia == 0.AND.text(i:i) /= ' ') ia=i 00243 IF(text(i:i) /= ' ') ib=i 00244 END DO 00245 END SUBROUTINE rltext 00246 00264 00265 INTEGER FUNCTION matint(pat,text,npat,ntext) 00266 IMPLICIT NONE 00267 INTEGER :: i 00268 INTEGER :: ic 00269 INTEGER :: ideq 00270 INTEGER :: ip 00271 INTEGER :: ipa 00272 INTEGER :: ipb 00273 INTEGER :: ita 00274 INTEGER :: itb 00275 INTEGER :: j 00276 INTEGER :: jc 00277 INTEGER :: jot 00278 INTEGER :: jt 00279 INTEGER :: npatma 00280 00281 CHARACTER (LEN=*), INTENT(IN) :: pat 00282 CHARACTER (LEN=*), INTENT(IN) :: text 00283 INTEGER, INTENT(OUT) :: npat 00284 INTEGER, INTENT(OUT) :: ntext 00285 00286 !GF 00287 ! INTEGER ID(0:100,2) 00288 PARAMETER (npatma=512) 00289 INTEGER :: id(0:npatma,2) 00290 ! end GF 00291 LOGICAL :: start ! for case conversion 00292 CHARACTER (LEN=26) :: chu 00293 CHARACTER (LEN=26) :: chl 00294 INTEGER :: nj(0:255) 00295 SAVE 00296 DATA chu/'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/ 00297 DATA chl/'abcdefghijklmnopqrstuvwxyz'/ 00298 DATA start/.TRUE./ 00299 DATA nj/256*0/ 00300 ! ... 00301 IF(start) THEN 00302 start=.FALSE. 00303 DO j=0,255 00304 nj(j)=j 00305 END DO 00306 DO i=1,26 00307 nj(ICHAR(chl(i:i)))=ICHAR(chu(i:i)) 00308 END DO 00309 END IF 00310 ! ... 00311 matint=0 00312 ntext=0 00313 DO i=1,LEN(text) ! find indices ITA...ITB 00314 IF(text(i:i) /= ' ') GO TO 10 00315 END DO 00316 GO TO 15 00317 10 ita=i 00318 DO i=ita,LEN(text) 00319 IF(text(i:i) /= ' ') itb=i 00320 END DO 00321 ntext=itb-ita+1 ! number of charcaters in TEXT 00322 00323 15 npat=0 00324 DO i=1,LEN(pat) ! find indices IPA...IPB 00325 IF(pat(i:i) /= ' ') GO TO 20 00326 END DO 00327 RETURN 00328 20 ipa=i 00329 DO i=ipa,LEN(pat) 00330 IF(pat(i:i) /= ' ') ipb=i 00331 END DO 00332 npat=ipb-ipa+1 00333 !GF IF(NPAT.GT.100) STOP 'MATINT: string PAT too long! ' 00334 IF(npat > npatma) THEN 00335 WRITE(*,*) 'too long PAT (', pat,'):', npat, ' >', npatma 00336 STOP 'MATINT: string PAT too long! ' 00337 END IF 00338 !GF end 00339 id(0,1)=0 00340 DO i=0,npat 00341 id(i,2)=i 00342 END DO 00343 jot=2 00344 00345 DO j=1,ntext 00346 jot=3-jot 00347 jt=j+ita-1 00348 jc=nj(ICHAR(text(jt:jt))) 00349 DO i=1,npat 00350 ip=i+ipa-1 00351 ideq=id(i-1,3-jot) 00352 ic=nj(ICHAR(pat(ip:ip))) 00353 IF(ic /= jc) ideq=ideq+1 00354 id(i,jot)=MIN(ideq,id(i,3-jot)+1,id(i-1,jot)+1) 00355 END DO 00356 matint=MAX(matint,npat-id(npat,jot)) 00357 END DO 00358 END FUNCTION matint 00359 00360
1.8.0
