1*-----------------------------------------------------------------------
2      SUBROUTINE FCPACK
3
4      INTEGER   IBUF(*)
5      LOGICAL   LEOL
6      CHARACTER CDSN*(*),CACT*(*),CBUF*(*),CLX*(*)
7
8      PARAMETER (MAXNR=99)
9      PARAMETER (MAXCL=2,ISLCT=2)
10
11      INTEGER   NR(MAXNR),NZ(MAXNR),ILZ(2,MAXCL)
12      LOGICAL   LE(MAXNR),LCHREQ,LEXIST,LSLFC,LCHNG,LSEOL
13      CHARACTER CS(MAXNR)*1,CL*2,CLL(MAXCL)*2,CZ*1,CLR*2
14
15      EXTERNAL  LCHREQ,LENC
16
17      SAVE
18
19      DATA      ILZ/ 10,  0, 13, 10 /
20*     HEX. DECIMAL   '0A00', '0D0A'
21
22      DATA      LSLFC/.FALSE./, LSEOL/.FALSE./
23      DATA      LE/MAXNR*.FALSE./
24      DATA      CS/MAXNR*'C'/
25
26      RETURN
27*-----------------------------------------------------------------------
28      ENTRY FCSLFC(CLX)
29
30      IF (LSLFC) THEN
31        CALL MSGDMP('E','FCSLFC',
32     +       'FCSLFC SHOULD BE CALLED BEFORE FCLEOL.')
33      END IF
34      NCLX=LENC(CLX)
35      IF (.NOT.(NCLX.LE.2)) THEN
36        CALL MSGDMP('E','FCSLFC',
37     +       'LENGTH OF <LF> CHARACTER SHOULD BE 1 OR 2.')
38      END IF
39
40      CL=CLX(1:NCLX)
41      LSLFC=.TRUE.
42
43      RETURN
44*-----------------------------------------------------------------------
45      ENTRY FCLEOL(IOU,LEOL)
46
47      IF (LCHREQ(CS(IOU),'C')) THEN
48        LE(IOU)=LEOL
49        IF (.NOT.LSEOL) THEN
50          DO 5 N=1,MAXCL
51            CLL(N)=CHAR(ILZ(1,N))//CHAR(ILZ(2,N))
52    5     CONTINUE
53          LSEOL=.TRUE.
54        END IF
55        IF (.NOT.LSLFC) THEN
56          CL=CLL(ISLCT)
57          LSLFC=.TRUE.
58        END IF
59        NL=LENC(CL)
60      ELSE
61        CALL MSGDMP('E','FCLEOL',
62     +       'FCLEOL SHOULD BE CALLED BEFORE FCOPEN.')
63      END IF
64
65      RETURN
66*-----------------------------------------------------------------------
67      ENTRY FCOPEN(IOU,CDSN,NRL,CACT,ICON)
68
69      IF (.NOT.(LCHREQ(CACT(1:1),'R') .OR. LCHREQ(CACT(1:1),'W'))) THEN
70        CALL MSGDMP('E','FCOPEN',
71     +       'ACCESS MODE SHOULD BE ''R'' OR ''W''.')
72      ELSE
73        CS(IOU)=CACT(1:1)
74      END IF
75
76      INQUIRE(FILE=CDSN,EXIST=LEXIST)
77
78      IF (LCHREQ(CACT(1:1),'R')) THEN
79        IF (.NOT.LEXIST) THEN
80          CALL MSGDMP('E','FCOPEN','FILE DOES NOT EXIST.')
81        END IF
82      ELSE IF (LCHREQ(CACT(1:1),'W')) THEN
83        IF (LEXIST) THEN
84          OPEN(UNIT=IOU,FILE=CDSN)
85          CLOSE(UNIT=IOU,STATUS='DELETE')
86        END IF
87      END IF
88
89      NR(IOU)=1
90      NZ(IOU)=NRL
91      IF (LE(IOU)) THEN
92        IF (LCHREQ(CACT(1:1),'R')) THEN
93          OPEN(UNIT=IOU,FILE=CDSN,FORM='UNFORMATTED',
94     +         ACCESS='DIRECT',RECL=1)
95          DO 10 N=1,2
96            READ(IOU,REC=NRL+N,IOSTAT=IOS) CZ
97            IF (IOS.EQ.0) THEN
98              CLR(N:N)=CZ
99            ELSE
100              IF (N.EQ.1) THEN
101                CALL MSGDMP('E','FCOPEN','RECORD LENGTH IS WRONG.')
102              ELSE
103                CLR(N:N)=CHAR(0)
104              END IF
105            END IF
106   10     CONTINUE
107          IF (CLR(1:NL).EQ.CL(1:NL)) THEN
108            NRECL=NRL+NL
109          ELSE
110            LCHNG=.FALSE.
111            DO 20 N=1,MAXCL
112              NLX=LENC(CLL(N))
113              IF (CLR(1:NLX).EQ.CLL(N)(1:NLX)) THEN
114                CALL MSGDMP('W','FCOPEN',
115     +               '<LF> CHARACTER IS NOT CONSISTENT, BUT ACCEPTED.')
116                NRECL=NRL+NLX
117                LCHNG=.TRUE.
118              END IF
119   20       CONTINUE
120            IF (.NOT.LCHNG) THEN
121              CALL MSGDMP('E','FCOPEN','<LF> CHARACTER IS NOT FOUND.')
122            END IF
123          END IF
124          CLOSE(UNIT=IOU)
125        ELSE
126          NRECL=NRL+NL
127        ENDIF
128      ELSE
129        NRECL=NRL
130      END IF
131
132      OPEN(UNIT=IOU,FILE=CDSN,FORM='UNFORMATTED',
133     +     ACCESS='DIRECT',RECL=NRECL,
134     +     IOSTAT=ICON)
135
136      RETURN
137*-----------------------------------------------------------------------
138      ENTRY FCCLOS(IOU,ICON)
139
140      CLOSE(UNIT=IOU,IOSTAT=ICON)
141      CS(IOU)='C'
142
143      RETURN
144*-----------------------------------------------------------------------
145      ENTRY FCNREC(IOU,NREC)
146
147      IF (LCHREQ(CS(IOU),'R')) THEN
148        NR(IOU)=NREC
149      ELSE
150        CALL MSGDMP('E','FCNREC',
151     +       'RECORD NUMBER CAN BE SPECIFIED ONLY FOR READ MODE.')
152      END IF
153
154      RETURN
155*-----------------------------------------------------------------------
156      ENTRY FCGETR(IOU,CBUF,ICON)
157
158      IF (.NOT.LCHREQ(CS(IOU),'R')) THEN
159        CALL MSGDMP('E','FCGETR','ACCESS MODE IS NOT ''R''.')
160      END IF
161
162      READ(UNIT=IOU,REC=NR(IOU),IOSTAT=ICON) CBUF(1:NZ(IOU))
163
164      IF (ICON.EQ.0) THEN
165        NR(IOU)=NR(IOU)+1
166      END IF
167
168      RETURN
169*-----------------------------------------------------------------------
170      ENTRY FCPUTR(IOU,CBUF,ICON)
171
172      IF (.NOT.LCHREQ(CS(IOU),'W')) THEN
173        CALL MSGDMP('E','FCPUTR','ACCESS MODE IS NOT ''W''.')
174      END IF
175
176      IF (LE(IOU)) THEN
177        WRITE(UNIT=IOU,REC=NR(IOU),IOSTAT=ICON) CBUF(1:NZ(IOU)),CL(1:NL)
178      ELSE
179        WRITE(UNIT=IOU,REC=NR(IOU),IOSTAT=ICON) CBUF(1:NZ(IOU))
180      END IF
181
182      IF (ICON.EQ.0) THEN
183        NR(IOU)=NR(IOU)+1
184      END IF
185
186      RETURN
187*-----------------------------------------------------------------------
188      ENTRY FCGETS(IOU,IBUF,ICON)
189
190      IF (.NOT.LCHREQ(CS(IOU),'R')) THEN
191        CALL MSGDMP('E','FCGETS','ACCESS MODE IS NOT ''R''.')
192      END IF
193      IF (.NOT.(MOD(NZ(IOU),4).EQ.0)) THEN
194        CALL MSGDMP('E','FCGETS',
195     +       'RECORD LENGTH SHOULD BE A MULTIPLE OF 4.')
196      END IF
197      NA=NZ(IOU)/4
198
199      IF (LE(IOU)) THEN
200        CALL MSGDMP('E','FCGETS',
201     +       '<LF> CHARACTER CAN BE HANDLED FOR CHARACTER I/O.')
202      ELSE
203        READ(UNIT=IOU,REC=NR(IOU),IOSTAT=ICON) (IBUF(N),N=1,NA)
204      END IF
205
206      IF (ICON.EQ.0) THEN
207        NR(IOU)=NR(IOU)+1
208      END IF
209
210      RETURN
211*-----------------------------------------------------------------------
212      ENTRY FCPUTS(IOU,IBUF,ICON)
213
214      IF (.NOT.LCHREQ(CS(IOU),'W')) THEN
215        CALL MSGDMP('E','FCPUTS','ACCESS MODE IS NOT ''W''.')
216      END IF
217      IF (.NOT.(MOD(NZ(IOU),4).EQ.0)) THEN
218        CALL MSGDMP('E','FCPUTS',
219     +       'RECORD LENGTH SHOULD BE A MULTIPLE OF 4.')
220      END IF
221      NA=NZ(IOU)/4
222
223      IF (LE(IOU)) THEN
224        CALL MSGDMP('E','FCPUTS',
225     +       '<LF> CHARACTER CAN BE HANDLED FOR CHARACTER I/O.')
226      ELSE
227        WRITE(UNIT=IOU,REC=NR(IOU),IOSTAT=ICON) (IBUF(N),N=1,NA)
228      END IF
229
230      IF (ICON.EQ.0) THEN
231        NR(IOU)=NR(IOU)+1
232      END IF
233
234      RETURN
235*-----------------------------------------------------------------------
236      ENTRY FCRWND(IOU,ICON)
237
238      REWIND(UNIT=IOU,IOSTAT=ICON)
239
240      NR(IOU)=1
241
242      RETURN
243      END
244