FTN4
      SUBROUTINE CRDIM(IFLAG),92069-16001 REV.1912 781120 
C 
C 
C*************************************************************
C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979.  ALL RIGHTS    *
C RESERVED.  NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- *
C PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH-  *
C OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY.  *
C*************************************************************
C 
C 
C     SOURCE:    92069-18012
C     RELOC:     92069-16001
C 
C 
C************************************************************ 
C 
C***********************************************************************
C CRDIM GETS A CARD IMAGE FROM CARDS, PAPER TAPE, MAG TAPE, OR DISK FILE
C     AND RETURNS IT IN CARD. 
C     COL IS SET TO 1.
C     IF THE LIST OPTION IS TURNED ON, IT LISTS CARD ON THE LIST DEVICE.
C PARAMETERS SET BY CALLER: 
C     INPUT=INPUT DEVICE #
C     LIST=DEVICE # OF LISTING DEVICE 
C     LST =TRUE IF LIST OPTION REQUESTED
C 
C CALLING SEQUENCE
C     CALL CRDIM(IFLAG) 
C 
C        WHERE: 
C 
C        IFLAG = 0 IF NO ERROR
C              = -1 IF ERROR
C 
C***********************************************************************
C 
C 
      INTEGER RECNO(2)
      INTEGER IOBUF(41),IA
      INTEGER OUTCHR
C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$  AUGUST 10,1978 $$$
      INTEGER ERROR,P,PLEN,CARD,LOG,COL 
      INTEGER ELECT,ITEM,LENTH,TYPE 
      INTEGER IDCB,LDCB,LIST,INPUT,PRTLM,CHECK,LST
      INTEGER IBASE 
      INTEGER SETERR
      INTEGER TRUE,FALSE,SEMI,COMMA 
      INTEGER L,CHAR
      INTEGER SETNO 
      INTEGER QTFLAG
C 
      COMMON ERROR,P(40),PLEN,CARD(256),LOG,COL 
      COMMON ELECT(129),ITEM(129),LENTH(129),TYPE(129)
      COMMON IDCB(144),LDCB(144),LIST,INPUT,PRTLM,CHECK,LST 
      COMMON IBASE(10)
      COMMON SETERR 
      COMMON L,CHAR 
      COMMON SETNO
      COMMON QTFLAG 
      COMMON/CONST/TRUE,FALSE,SEMI,COMMA
C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$  OCTOBER 16,1978 $$
      DATA IBLNK/2H  /
      DATA I1/1/
      DATA I2/2/
      DATA I13/13/
      DATA I209,I220/209,220/ 
      DATA RECNO/0,0/ 
C 
C 
C 
C 
C 
C 
C 
C CLEAR THE ERROR INDICATOR 
C 
      IFLAG = 0 
C 
C 
C BLANK FILL THE CARD 
      DO 100 IMOVE=1,256
100   CARD(IMOVE)=IBLNK 
C INPUT FROM DISK?
C 
      IF (INPUT .EQ.-1) GOTO 104
C 
C READ A RECORD FROM CARDS, PAPER TAPE, MAG TAPE INTO CARD
101   CONTINUE
      NCHAR = -PRTLM
C 
C MAKE I/O CALL WITH NO ABORT BIT SET 
C 
      CALL REIO(I1+100000B,INPUT,CARD,NCHAR)
      GOTO 109
7000  CALL ABREG(IA,NCHAR)
      LOG=NCHAR 
      CALL EXEC(I13+100000B,INPUT,ISTAT)
      GOTO 109
C 
C END OF FILE?
C 
7001  IF (IAND(ISTAT,40B).NE.0) GO TO 108 
C 
C IF LIST OPTION TURNED ON, LIST CARD ON LIST DEVICE
C 
102   IF (LST.NE. TRUE) GO TO 103 
C     MOVE CARD IMAGE TO OUTPUT BUFFER AND LIST LINE BY LINE
      ICHAR=1 
1020  JCHAR=NCHAR 
      IF(NCHAR .LE. 0) GOTO 108 
      IF (NCHAR.GT.80) JCHAR=80 
      OUTCHR=JCHAR
      CALL SMOVE(CARD,ICHAR,(ICHAR+JCHAR-1),IOBUF,I1,OUTCHR)
      CALL OUTLN(IOBUF,(OUTCHR+1)/2)
      IF (NCHAR.LE.80) GO TO 103
      NCHAR=NCHAR-80
      ICHAR=ICHAR+80
      GO TO 1020
C INITIALIZE COLUMN POINTER 
103   COL=1 
      RETURN
C 
C GET CARD IMAGE FROM DISK
C 
104   CALL EREAD(IDCB,IERR,CARD,(PRTLM/2)+1,ILEN,RECNO) 
      NCHAR=ILEN*2
      LOG=NCHAR 
      IF (IERR .LT.0) GOTO 107
      IF (LOG .LE. 0) GOTO 108
      GOTO 102
C IF ERROR DETECTED WRITE ERROR MESSAGE 
107   CALL ERROT(IERR)
      IFLAG = -1
      RETURN
C 
C OUT PUT END OF FILE DETECTED
C 
108   CALL ERROT(I209)
      IFLAG = -1
      RETURN
C 
C OUTPUT SYSTEM TRIED TO ABORT INPUT I/O
C 
109   CONTINUE
      CALL ERROT(I220)
      IFLAG = -1
      RETURN
      END 
      END$
                                                                                                                                                                                                                      