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
|
C Callback test
SUBROUTINE CALBCK(R, DUNIT, SUBERROR, LINE)
INCLUDE "getdata.f"
INTEGER R, DUNIT, SUBERROR
CHARACTER*(GD_MLL) LINE
C Tell the parser to ignore syntax errors
R = GDSX_I
END SUBROUTINE
PROGRAM GETTST
EXTERNAL CALBCK
INCLUDE "getdata.f"
CHARACTER*12 fildir
PARAMETER (fildir = 'test_dirfile')
CHARACTER*19 frmat
PARAMETER (frmat = 'test_dirfile/format')
CHARACTER*17 dat
PARAMETER (dat = 'test_dirfile/data')
CHARACTER*15 frmdat1
PARAMETER (frmdat1 = 'data RAW INT8 8')
CHARACTER*9 frmdat2
PARAMETER (frmdat2 = 'bad line')
INTEGER*1 datdat(80)
INTEGER*1 i;
INTEGER d;
INTEGER e;
CALL SYSTEM ( 'rm -rf ' // fildir )
CALL SYSTEM ( 'mkdir ' // fildir )
DO 20 i = 1, 80
datdat(i) = i
20 CONTINUE
OPEN(1, FILE=frmat, STATUS='NEW')
WRITE(1, *) frmdat1
WRITE(1, *) frmdat2
CLOSE(1, STATUS='KEEP')
OPEN(1, FILE=dat, FORM='UNFORMATTED', ACCESS='DIRECT', RECL=80,
+STATUS='NEW')
WRITE (1,REC=1) datdat
CLOSE(1, STATUS='KEEP')
CALL GDCOPN(d, fildir, 12, GD_RO, CALBCK)
CALL GDEROR(e, d)
CALL GDCLOS(d)
CALL SYSTEM ( 'rm -rf ' // fildir )
IF (e .NE. GD_EOK) CALL EXIT(1)
STOP
END
|
