-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathmptext.f90
387 lines (353 loc) · 10.3 KB
/
mptext.f90
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
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
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
! Code converted using TO_F90 by Alan Miller
! Date: 2012-03-16 Time: 11:09:16
!> \file
!! Analyse text string.
!!
!! \author Volker Blobel, University Hamburg, 2005-2009 (initial Fortran77 version)
!! \author Claus Kleinwort, DESY (maintenance and developement)
!!
!! \copyright
!! Copyright (c) 2009 - 2015 Deutsches Elektronen-Synchroton,
!! Member of the Helmholtz Association, (DESY), HAMBURG, GERMANY \n\n
!! This library is free software; you can redistribute it and/or modify
!! it under the terms of the GNU Library General Public License as
!! published by the Free Software Foundation; either version 2 of the
!! License, or (at your option) any later version. \n\n
!! This library is distributed in the hope that it will be useful,
!! but WITHOUT ANY WARRANTY; without even the implied warranty of
!! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!! GNU Library General Public License for more details. \n\n
!! You should have received a copy of the GNU Library General Public
!! License along with this program (see the file COPYING.LIB for more
!! details); if not, write to the Free Software Foundation, Inc.,
!! 675 Mass Ave, Cambridge, MA 02139, USA.
!!
!> Keyword position.
MODULE mptext
USE mpdef
IMPLICIT NONE
SAVE
INTEGER(mpi) :: keya !< start (position) of keyword
INTEGER(mpi) :: keyb !< end (position) of keyword
END MODULE mptext
!> Translate text.
!!
!! Translate TEXT into arrays of double precision numbers DNUMS(NUMS).
!! Text preceeding numbers is TEXT(KEYA:KEYB), if KEYB >= KEYA.
!!
!! \param[in] text text
!! \param[out] nums number of numbers found
!! \param[out] dnum array of numbers found
SUBROUTINE ratext(text,nums,dnum)
USE mptext
IMPLICIT NONE
INTEGER(mpi) :: i
INTEGER(mpi) :: ia
INTEGER(mpi) :: ib
INTEGER(mpi) :: ic
INTEGER(mpi) :: ich
INTEGER(mpi) :: icl
INTEGER(mpi) :: icode
INTEGER(mpi) :: j
INTEGER(mpi) :: k
INTEGER(mpi) :: lent
INTEGER(mpi) :: num
CHARACTER (LEN=*), INTENT(IN) :: text
INTEGER(mpi), INTENT(OUT) :: nums
REAL(mpd), INTENT(OUT) :: dnum(*)
INTEGER(mpi) :: last ! last non-blank character
INTEGER(mpi), PARAMETER :: ndim=1000
INTEGER(mpi), DIMENSION(2,ndim):: icd
CHARACTER (LEN=16) :: keywrd
CHARACTER (LEN=1) :: ch
REAL(mpd) :: dic(ndim)
REAL(mpd) :: dumber
INTEGER(mpi) :: icdt(ndim)
SAVE
! ...
nums=0
last=0
keya=0
keyb=0
IF(text(1:1) == '*') RETURN
num=ICHAR('0')
lent=0
last=0
DO i=1,LEN(text) ! find comment and end
IF(lent == 0.AND.(text(i:i) == '!'.OR.text(i:i) == '%')) lent=i
IF(text(i:i) /= ' ') last=i
END DO
IF(lent == 0) lent=last+1
icd(1,1)=lent
j=1
icdt(1)=0
icl=0
DO i=1,lent-1
ch =text(i:i)
ich=ICHAR(ch)
ic=0
IF(ch == '.') ic=1
IF(ch == '+') ic=2
IF(ch == '-') ic=3
IF(ch == 'E') ic=4
IF(ch == 'D') ic=4
IF(ch == 'e') ic=4
IF(ch == 'd') ic=4
IF(ic > 0) THEN
j=j+1
icd(1,j)=i
icd(2,j)=i
icdt(j)=ic
ELSE
ic=6
IF(ich >= num.AND.ich <= num+9) ic=5 ! digit
IF(ic /= icl) THEN
j=j+1
icd(1,j)=i
icdt(j)=ic
END IF
icd(2,j)=i
END IF
icl=ic ! previous IC
END DO
icdt(j+1)=0
DO i=1,j ! define number
IF(icdt(i) == 5) THEN
dumber=0.0D0
DO k=icd(1,i),icd(2,i)
dumber=10.0_mpd*dumber+REAL(ICHAR(text(k:k))-num,mpd)
END DO
dic(i)=dumber
END IF
END DO
icdt(j+1)=0
DO i=2,j ! get dots
IF(icdt(i) == 1) THEN
icode=0
IF(icdt(i-1) == 5.AND.icd(2,i-1)+1 == icd(1,i)) icode=1
IF(icdt(i+1) == 5.AND.icd(1,i+1)-1 == icd(2,i)) icode=icode+2
IF(icode == 1) THEN ! 123.
icd(2,i-1)=icd(2,i)
icdt(i)=0
ELSE IF(icode == 2) THEN ! .456
dic(i)=10.0D0**(icd(1,i+1)-icd(2,i+1)-1)*dic(i+1)
icdt(i)=5
icd(2,i)=icd(2,i+1)
icdt(i+1)=0
ELSE IF(icode == 3) THEN ! 123.456
dic(i-1)=dic(i-1)+ 10.0D0**(icd(1,i+1)-icd(2,i+1)-1)*dic(i+1)
icd(2,i-1)=icd(2,i+1)
icdt(i)=0
icdt(i+1)=0
END IF
END IF
END DO
k=1 ! remove blanks, compress
DO i=2,j
IF(icdt(i) == 6.AND.text(icd(1,i):icd(2,i)) == ' ') icdt(i)=0
IF(icdt(i) /= 0) THEN
k=k+1
icd(1,k)=icd(1,i)
icd(2,k)=icd(2,i)
icdt(k)=icdt(i)
dic(k)=dic(i)
END IF
END DO
j=k
DO i=2,j-1
IF(icdt(i) == 2.OR.icdt(i) == 3) THEN ! +-
IF(icdt(i+1) == 5) THEN
icd(1,i+1)=icd(1,i)
IF(icdt(i) == 3) dic(i+1)=-dic(i+1)
icdt(i)=0
END IF
END IF
END DO
k=1 ! compress
DO i=2,j
IF(icdt(i) == 6.AND.text(icd(1,i):icd(2,i)) == ' ') icdt(i)=0
IF(icdt(i) /= 0) THEN
k=k+1
icd(1,k)=icd(1,i)
icd(2,k)=icd(2,i)
icdt(k)=icdt(i)
dic(k)=dic(i)
END IF
END DO
j=k
DO i=2,j-1
IF(icdt(i) == 4) THEN ! E or D
IF(icdt(i-1) == 5.AND.icdt(i+1) == 5) THEN
icd(2,i-1)=icd(2,i+1)
dic(i-1)=dic(i-1)*10.0D0**dic(i+1)
icdt(i)=0
icdt(i+1)=0
END IF
END IF
END DO
nums=0 ! compress
DO i=1,j
IF(icdt(i) == 5) THEN
nums=nums+1
icd(1,nums)=icd(1,i)
icd(2,nums)=icd(2,i)
dnum(nums)=dic(i)
END IF
END DO
keywrd=' ' ! assemble keyword
ia=0
ib=-1
DO i=1,icd(1,1)-1
IF(ia == 0.AND.text(i:i) /= ' ') ia=i
IF(text(i:i) /= ' ') ib=i
END DO
IF(ib >= 0) keywrd=text(ia:ib)
keya=ia
keyb=MAX(0,ib)
END SUBROUTINE ratext
!> Analyse text range.
!!
!! \param[in] text text
!! \param[out] ia index of first non-blank character, or =1
!! \param[out] ib index of last non-blank character, or =0 - comment excluded
!! \param[out] nab index of last non-blank character (=0 for blank text)
SUBROUTINE rltext(text,ia,ib,nab)
USE mpdef
IMPLICIT NONE
INTEGER(mpi) :: i
INTEGER(mpi) :: lim
CHARACTER (LEN=*), INTENT(IN) :: text
INTEGER(mpi), INTENT(OUT) :: ia
INTEGER(mpi), INTENT(OUT) :: ib
INTEGER(mpi), INTENT(OUT) :: nab
SAVE
! ...
ia=0
ib=0
nab=0
lim=0
DO i=1,LEN(text)
IF(text(i:i) /= ' ') nab=i
IF((i == 1.AND.text(1:1) == '*').OR.text(i:i) == '!') THEN
IF(lim == 0) lim=i
END IF
END DO
IF(lim == 0) THEN
lim=nab
ELSE
lim=lim-1
END IF
DO i=1,lim
IF(ia == 0.AND.text(i:i) /= ' ') ia=i
IF(text(i:i) /= ' ') ib=i
END DO
END SUBROUTINE rltext
!> Approximate string matching.
!!
!! Approximate string matching - case insensitive.
!! Return number of matches of string PAT in string TEXT,
!! and number NPAT, NTEXT of characters of string PAT and string TEXT.
!! Strings are considered from first to last non-blank character.
!!
!! Example:
!!
!! MATCH = MATINT(' keYs ','keyWO RD',NPAT,NTEXT)
!! returns MATCH=3, NPAT=4, NTEXT=8
!!
!! \param[in] pat pattern
!! \param[in] text text
!! \param[out] npat number of characters in pattern
!! \param[out] ntext number of characters in text
!! \return number of matching characters of pattern in text
INTEGER(mpi) FUNCTION matint(pat,text,npat,ntext)
USE mpdef
IMPLICIT NONE
INTEGER(mpi) :: i
INTEGER(mpi) :: ic
INTEGER(mpi) :: ideq
INTEGER(mpi) :: ip
INTEGER(mpi) :: ipa
INTEGER(mpi) :: ipb
INTEGER(mpi) :: ita
INTEGER(mpi) :: itb
INTEGER(mpi) :: j
INTEGER(mpi) :: jc
INTEGER(mpi) :: jot
INTEGER(mpi) :: jt
INTEGER(mpi) :: npatma
CHARACTER (LEN=*), INTENT(IN) :: pat
CHARACTER (LEN=*), INTENT(IN) :: text
INTEGER(mpi), INTENT(OUT) :: npat
INTEGER(mpi), INTENT(OUT) :: ntext
!GF
! INTEGER ID(0:100,2)
PARAMETER (npatma=512)
INTEGER(mpi) :: id(0:npatma,2)
! end GF
LOGICAL :: start ! for case conversion
CHARACTER (LEN=26) :: chu
CHARACTER (LEN=26) :: chl
INTEGER(mpi) :: nj(0:255)
SAVE
DATA chu/'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
DATA chl/'abcdefghijklmnopqrstuvwxyz'/
DATA start/.TRUE./
DATA nj/256*0/
! ...
IF(start) THEN
start=.FALSE.
DO j=0,255
nj(j)=j
END DO
DO i=1,26
nj(ICHAR(chl(i:i)))=ICHAR(chu(i:i))
END DO
END IF
! ...
matint=0
ntext=0
DO i=1,LEN(text) ! find indices ITA...ITB
IF(text(i:i) /= ' ') GO TO 10
END DO
GO TO 15
10 ita=i
DO i=ita,LEN(text)
IF(text(i:i) /= ' ') itb=i
END DO
ntext=itb-ita+1 ! number of charcaters in TEXT
15 npat=0
DO i=1,LEN(pat) ! find indices IPA...IPB
IF(pat(i:i) /= ' ') GO TO 20
END DO
RETURN
20 ipa=i
DO i=ipa,LEN(pat)
IF(pat(i:i) /= ' ') ipb=i
END DO
npat=ipb-ipa+1
!GF IF(NPAT.GT.100) STOP 'MATINT: string PAT too long! '
IF(npat > npatma) THEN
WRITE(*,*) 'too long PAT (', pat,'):', npat, ' >', npatma
CALL peend(34,'Aborted, pattern string too long')
STOP 'MATINT: string PAT too long! '
END IF
!GF end
id(0,1)=0
DO i=0,npat
id(i,2)=i
END DO
jot=2
DO j=1,ntext
jot=3-jot
jt=j+ita-1
jc=nj(ICHAR(text(jt:jt)))
DO i=1,npat
ip=i+ipa-1
ideq=id(i-1,3-jot)
ic=nj(ICHAR(pat(ip:ip)))
IF(ic /= jc) ideq=ideq+1
id(i,jot)=MIN(ideq,id(i,3-jot)+1,id(i-1,jot)+1)
END DO
matint=MAX(matint,npat-id(npat,jot))
END DO
END FUNCTION matint