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
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
|
!
! Copyright (C) 2001-2004 Carlo Cavazzoni and PWSCF group
! This file is distributed under the terms of the
! GNU General Public License. See the file `License'
! in the root directory of the present distribution,
! or http://www.gnu.org/copyleft/gpl.txt .
!
!
! ... SUBROUTINE field_count: accepts two string (one of them is optional)
! and one integer and count the number of fields
! in the string separated by a blank or a tab
! character. If the optional string is specified
! (it has anyway len=1) it is assumed as the
! separator character.
! Ignores any character following the exclamation
! mark (fortran comment)
!
! ... SUBROUTINE con_cam: counts the number of fields in a string
! separated by the optional character
!
! ... SUBROUTINE field_compare: accepts two strings and one integer. Counts the
! fields contained in the first string and
! compares it with the integer.
! If they are less than the integer calls the
! routine error and show by the second string the
! name of the field where read-error occurred.
!
! ... SUBROUTINE version_parse: Determine the major, minor and patch numbers
! from a version string with the fmt "i.j.k"
!
! ... FUNCTION version_compare: Compare two version strings; the result can be
! "newer", "equal", "older", ""
!
!
!----------------------------------------------------------------------------
MODULE parser
!----------------------------------------------------------------------------
!
USE io_global, ONLY : stdout
USE kinds, ONLY : DP
!
PRIVATE
!
PUBLIC :: parse_unit, field_count, read_line, get_field
PUBLIC :: version_parse, version_compare
!
INTEGER :: parse_unit = 5 ! normally 5, but can be set otherwise
!
CONTAINS
!
!
!--------------------------------------------------------------------------
PURE SUBROUTINE field_count( num, line, car )
!--------------------------------------------------------------------------
!
IMPLICIT NONE
!
INTEGER, INTENT(OUT) :: num
CHARACTER(LEN=*), INTENT(IN) :: line
CHARACTER(LEN=1), OPTIONAL, INTENT(IN) :: car
#if defined (__XLF)
! ... with the IBM xlf compiler some combination of flags lead to
! ... variables being defined as static, hence giving a conflict
! ... with PURE function. We then force the variable to be AUTOMATIC
CHARACTER(LEN=1), AUTOMATIC :: sep1, sep2
INTEGER, AUTOMATIC :: j
#else
CHARACTER(LEN=1) :: sep1, sep2
INTEGER :: j
#endif
!
!
num = 0
!
IF ( .NOT. present(car) ) THEN
!
sep1 = char(32) ! ... blank character
sep2 = char(9) ! ... tab character
!
DO j = 2, MAX( LEN( line ), 256 )
!
IF ( line(j:j) == '!' .OR. line(j:j) == char(0) ) THEN
!
IF ( line(j-1:j-1) /= sep1 .AND. line(j-1:j-1) /= sep2 ) THEN
!
num = num + 1
!
END IF
!
EXIT
!
END IF
!
IF ( ( line(j:j) == sep1 .OR. line(j:j) == sep2 ) .AND. &
( line(j-1:j-1) /= sep1 .AND. line(j-1:j-1) /= sep2 ) ) THEN
!
num = num + 1
!
END IF
!
END DO
!
ELSE
!
sep1 = car
!
DO j = 2, MAX( LEN( line ), 256 )
!
IF ( line(j:j) == '!' .OR. &
line(j:j) == char(0) .OR. line(j:j) == char(32) ) THEN
!
IF ( line(j-1:j-1) /= sep1 ) num = num + 1
!
EXIT
!
END IF
!
IF ( line(j:j) == sep1 .AND. line(j-1:j-1) /= sep1 ) num = num + 1
!
END DO
!
END IF
!
RETURN
!
END SUBROUTINE field_count
!
!
!--------------------------------------------------------------------------
SUBROUTINE read_line( line, nfield, field, end_of_file, error )
!--------------------------------------------------------------------------
!
USE mp, ONLY : mp_bcast
USE mp_images, ONLY : intra_image_comm
USE io_global, ONLY : ionode, ionode_id
!
IMPLICIT NONE
!
CHARACTER(LEN=*), INTENT(OUT) :: line
CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: field
INTEGER, OPTIONAL, INTENT(IN) :: nfield
LOGICAL, OPTIONAL, INTENT(OUT) :: end_of_file, error
LOGICAL :: tend, terr
!
!
IF( LEN( line ) < 256 ) THEN
CALL errore(' read_line ', ' input line too short ', MAX(LEN(line),1) )
END IF
!
tend = .FALSE.
terr = .FALSE.
IF ( ionode ) THEN
30 READ (parse_unit, fmt='(A256)', ERR=15, END=10) line
IF( line == ' ' .OR. line(1:1) == '#' ) GO TO 30
GO TO 20
10 tend = .TRUE.
GO TO 20
15 terr = .TRUE.
20 CONTINUE
END IF
!
CALL mp_bcast( tend, ionode_id, intra_image_comm )
CALL mp_bcast( terr, ionode_id, intra_image_comm )
CALL mp_bcast( line, ionode_id, intra_image_comm )
!
IF( PRESENT(end_of_file) ) THEN
end_of_file = tend
ELSE IF( tend ) THEN
CALL infomsg(' read_line ', ' end of file ' )
END IF
IF( PRESENT(error) ) THEN
error = terr
ELSE IF( terr ) THEN
CALL infomsg(' read_line ', ' read error ' )
END IF
IF( PRESENT(field) .and. .not.(tend.or.terr) ) &
&CALL field_compare( line, nfield, field )
!
END SUBROUTINE read_line
!
!
!--------------------------------------------------------------------------
SUBROUTINE field_compare( str, nf, var )
!--------------------------------------------------------------------------
!
IMPLICIT NONE
!
CHARACTER(LEN=*), INTENT(IN) :: var
INTEGER, INTENT(IN) :: nf
CHARACTER(LEN=*), INTENT(IN) :: str
INTEGER :: nc
!
CALL field_count( nc, str )
!
IF( nc < nf ) &
CALL errore( ' field_compare ', &
& ' wrong number of fields: ' // TRIM( var ), 1 )
!
RETURN
!
END SUBROUTINE field_compare
!
!
!--------------------------------------------------------------------------
SUBROUTINE con_cam(num, line, car)
!--------------------------------------------------------------------------
CHARACTER(LEN=*) :: line
CHARACTER(LEN=1) :: sep
CHARACTER(LEN=1), OPTIONAL :: car
INTEGER :: num, j
num = 0
IF (len(line) .GT. 256 ) THEN
WRITE( stdout,*) 'riga ', line
WRITE( stdout,*) 'lunga ', len(line)
num = -1
RETURN
END IF
WRITE( stdout,*) '1riga ', line
WRITE( stdout,*) '1lunga ', len(line)
IF ( .NOT. present(car) ) THEN
sep=char(32) !char(32) is the blank character
ELSE
sep=car
END IF
DO j=2, MAX(len(line),256)
IF ( line(j:j) == '!' .OR. line(j:j) == char(0)) THEN
RETURN
END IF
IF ( (line(j:j) .EQ. sep) .AND. &
(line(j-1:j-1) .NE. sep) ) THEN
num = num + 1
END IF
END DO
RETURN
END SUBROUTINE con_cam
!
!--------------------------------------------------------------------------
SUBROUTINE version_parse(str, major, minor, patch, ierr)
!--------------------------------------------------------------------------
!
! Determine the major, minor and patch numbers from
! a version string with the fmt "i.j.k"
!
! The ierr variable assumes the following values
!
! ierr < 0 emtpy string
! ierr = 0 no problem
! ierr > 0 fatal error
!
IMPLICIT NONE
CHARACTER(*), INTENT(in) :: str
INTEGER, INTENT(out) :: major, minor, patch, ierr
!
INTEGER :: i1, i2, length
INTEGER :: ierrtot
CHARACTER(10) :: num(3)
!
major = 0
minor = 0
patch = 0
length = LEN_TRIM( str )
!
IF ( length == 0 ) THEN
!
ierr = -1
RETURN
!
ENDIF
i1 = SCAN( str, ".")
i2 = SCAN( str, ".", BACK=.TRUE.)
!
IF ( i1 == 0 .OR. i2 == 0 .OR. i1 == i2 ) THEN
!
ierr = 1
RETURN
!
ENDIF
!
num(1) = str( 1 : i1-1 )
num(2) = str( i1+1 : i2-1 )
num(3) = str( i2+1 : )
!
ierrtot = 0
!
READ( num(1), *, IOSTAT=ierr ) major
IF (ierr/=0) RETURN
!
READ( num(2), *, IOSTAT=ierr ) minor
IF (ierr/=0) RETURN
!
READ( num(3), *, IOSTAT=ierr ) patch
IF (ierr/=0) RETURN
!
END SUBROUTINE version_parse
!
!--------------------------------------------------------------------------
FUNCTION version_compare(str1, str2)
!--------------------------------------------------------------------------
!
! Compare two version strings; the result is
!
! "newer": str1 is newer that str2
! "equal": str1 is equal to str2
! "older": str1 is older than str2
! " ": str1 or str2 has a wrong format
!
IMPLICIT NONE
CHARACTER(*) :: str1, str2
CHARACTER(10) :: version_compare
!
INTEGER :: version1(3), version2(3)
INTEGER :: basis, icheck1, icheck2
INTEGER :: ierr
!
version_compare = " "
!
CALL version_parse( str1, version1(1), version1(2), version1(3), ierr)
IF ( ierr/=0 ) RETURN
!
CALL version_parse( str2, version2(1), version2(2), version2(3), ierr)
IF ( ierr/=0 ) RETURN
!
!
basis = 1000
!
icheck1 = version1(1) * basis**2 + version1(2)* basis + version1(3)
icheck2 = version2(1) * basis**2 + version2(2)* basis + version2(3)
!
IF ( icheck1 > icheck2 ) THEN
!
version_compare = 'newer'
!
ELSEIF( icheck1 == icheck2 ) THEN
!
version_compare = 'equal'
!
ELSE
!
version_compare = 'older'
!
ENDIF
!
END FUNCTION version_compare
!
!--------------------------------------------------------------------------
SUBROUTINE get_field(n, field, str, sep)
!--------------------------------------------------------------------------
! Extract whitespace-separated nth block from string
IMPLICIT NONE
INTEGER,INTENT(IN) :: n
CHARACTER(len=*),INTENT(OUT) :: field
CHARACTER(len=*),INTENT(IN) :: str
CHARACTER(len=1),OPTIONAL,INTENT(IN) :: sep
INTEGER :: i,j,z ! block start and end
INTEGER :: k ! block counter
CHARACTER(len=1) :: sep1, sep2
!print*, "------------- parser start -------------"
!print '(3a)', "string: -->", str,"<--"
IF(present(sep)) THEN
sep1 = sep
sep2 = sep ! redundant, but easy
ELSE
sep1 = char(32) ! ... blank character
sep2 = char(9) ! ... tab char
ENDIF
!
k = 1 ! counter for the required block
!
DO i = 1,len(str)
! look for the beginning of the required block
z = MAX(i-1,1)
!print '(2a1,3i4,2l)', str(i:i), str(z:z), i,z,k,n,&
! (str(i:i) == sep1 .or. str(i:i) == sep2), (str(z:z) /= sep1 .and. str(z:z) /= sep2)
IF( k == n) EXIT
IF( (str(i:i) == sep1 .or. str(i:i) == sep2) &
.and. &
(str(z:z) /= sep1 .and. str(z:z) /= sep2) &
) &
k = k+1
ENDDO
!
!print*, "i found: ",i
DO j = i,len(str)
! look for the beginning of the next block
z = MAX(j-1,1)
IF( (str(j:j) == sep1 .or. str(j:j) == sep2) &
.and. &
(str(z:z) /= sep1 .and. str(z:z) /= sep2) &
) &
k = k+1
IF( k >n) EXIT
ENDDO
!print*, "j found: ",j
!
IF (j <= len(str)) THEN
! if we are here, the reqired block was followed by a separator
! and another field, we have to trash one char (a separator)
field = TRIM(adjustl(str(i:j-1)))
!print*, "taking: ",i,j-2
ELSE
! if we are here, it was the last block in str, we have to take
! all the remaining chars
field = TRIM(adjustl(str(i:len(str))))
!print*, "taking from ",i
ENDIF
!print*, "------------- parser end -------------"
END SUBROUTINE get_field
END MODULE parser
|
