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$