FTN4 SUBROUTINE CKP50(LU1,P5,TAPE,IERR) +,92069-16212 REV.2013 790316 C C C***************************************************************** C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED. C NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR C TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR C WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. C****************************************************************** C C C SOURCE: 92069-18212 C RELOC: 92069-18212 C C C****************************************************************: C C C************************************************************** C CKP50 CHECKS PARAMETER 5, THE ABORT WORD. C 2-5-79 P5(2) IS SET PERMANENTLY TO CO BY THIS ROUTINE NOW, SO C THAT NWFIL WILL ALWAYS OVERWRITE THE STORAGE FILE. C C IF NO PARAMETER WAS PASSED IN, C CKP50 QUERIES THE USER AT CONSOLE LU, READS IN THE ABORT C RESPONSE, AND SETS UP P5 ACCORDINGLY. C*************************************************************** INTEGER LU1,P5(1),TAPE(1),IERR INTEGER TEMP INTEGER IA(2) EQUIVALENCE(REG,IA),(IA(2),IB) C*************************************************************** C IF THE TYPE IS ASCII, NORMAL RETURN. ELSE RETURN ERROR. C 5 CONTINUE IERR = 0 ITYPE = P5(4) IF (ITYPE .EQ. 0) GO TO 10 IF (ITYPE .EQ. 1) GO TO 20 IF (ITYPE .EQ. 3) GO TO 30 C************************************************************ C PROCESS INTERNAL ERROR. C CALL DBER2(LU1,7777,6HXXXXXX,6HCKP50 ,2HAB) C************************************************************* C PROCESS NO PARAMETER BY PROMPTING THE USER AT THE CONSOLE LU. C READ THE PARAMETER, THEN BUILD P5 ACCORDINGLY. C C 10 CONTINUE P5(2)=2HCO P5(3)=2H P5(4)=3 P5(5)=2H P5(6)=2H C CALL REIO(2,LU1,41H ABORT AT END OF STORAGE DEVICE(YES/NO)?_,-41) REG = REIO(1,LU1+400B,TEMP,1) IF ((TEMP .NE. 2HYE) .AND. (TEMP .NE. 2HNO)) GO TO 10 P5=2HCO IF (TEMP .EQ. 2HYE) P5=2HAB RETURN C************************************************************* C PROCESS AN INTEGER PARAMETER AS AN ERROR. C 20 CONTINUE CALL REIO(2,LU1,20H ILLEGAL ABORT WORD.,-20) IERR=-248 CALL DBER2(LU1,IERR,6HXXXXXX,6HCKP50 ,2HXX) RETURN C************************************************************* C CHECK AN ASCII PARAMETER FOR LEGALITY. C 30 CONTINUE IF ((P5 .NE. 2HAB) .AND. (P5 .NE. 2HCO)) GO TO 20 P5(2)=2HCO RETURN END