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