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
|
C*GRGE03
C+
SUBROUTINE GRGE03(QBUF,ICNT)
C
C GRPCKG (Internal routine): Write ICNT bytes in QBUF onto logical
C unit LUN. Reset ICNT to zero.
C Based on GRxx03 routines, this version does not contain a common
C block.
C ***NOTE*** INIT03 must be called before any calls to GRGE02 to
C set the LUN/Channel to which the buffer should be dumped.
C This subroutine contains the entry point INIT03 that defines
C the variables ITYPE, LUN and IFUNC. If ITYPE=0 then LUN is
C the Fortran logical unit number to which the data should be
C written. If ITYPE>0 then LUN is the Channel number for a QIO
C operation and IFUNC is the QIO write function.
C
C Arguments:
C
C QBUF I/O Byte The output buffer.
C ICNT I/O I Current number of bytes used in QBUF.
C
C 5-Aug-1986 - [AFT].
C-----------------------------------------------------------------------
IMPLICIT NONE
INCLUDE '($SSDEF)'
INTEGER SYS$QIOW
INTEGER ICNT
BYTE QBUF(*)
INTEGER RESULT, N, I
INTEGER*2 IOSB(4)
INTEGER INTYPE,INLUN,INFUNC
INTEGER ITYPE,LUN,IFUNC
SAVE ITYPE,LUN,IFUNC
C
N = ICNT
ICNT = 0
IF (N.LT.1) RETURN
C
IF(ITYPE.EQ.0) THEN
WRITE(LUN,101, ERR=900) (QBUF(I),I=1,N)
101 FORMAT(130A1)
ELSE
RESULT = SYS$QIOW(,%VAL(LUN),
1 %VAL(IFUNC),IOSB,,,
2 QBUF,%VAL(N),%VAL(5),,,)
IF (RESULT.NE.SS$_NORMAL) THEN
CALL GRGMSG(RESULT)
CALL GRGMSG('SYS$QIOW error writing to device. '//
& 'Program continues.')
END IF
IF (IOSB(1).NE.SS$_NORMAL) THEN
CALL GRGMSG(IOSB(1))
CALL GRGMSG('SYS$QIOW (IOSB) status writing to device. '//
& 'Program continues.')
END IF
END IF
RETURN
C---
900 CONTINUE
RETURN
C---
ENTRY INIT03(INTYPE,INLUN,INFUNC)
C--- Save info needed to dump buffer.
ITYPE=INTYPE
LUN=INLUN
IFUNC=INFUNC
RETURN
END
|
