FTN4 SUBROUTINE RING(LU1,TAPE,P5,IERR) +,92069-16204 REV.2013 790413 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-18204 C RELOC: 92069-16204 C C C****************************************************************: C C C**************************************************** C RING CHECKS THAT THE TAPE LU HAS A WRITE RING IN IT. C IF IT DOES, RING IMMEDIATELY RETURNS. C IF IT DOESNT, RING CHECKS P5 AND ABORTS IF P5 RETURNS C AB, AND PROMPTS THE USER TO INSERT A WRITE RING IF C THE USER SPECIFIED NO ABORT. C***************************************************** INTEGER LU1,TAPE,P5,IERR INTEGER ERR1(17) INTEGER NUM(3) DATA ERR1/2H T,2HAP,2HE ,2HLU,2H X,2HXX,2HXX,2HX ,2HHA,2HS , & 2HNO,2H W,2HRI,2HTE,2H R,2HIN,2HG./ C***************************************************************** C GET DYNAMIC STATUS. C CALL EXEC(13,TAPE,ISTAT) ISTAT=IAND(ISTAT,4B) IF (ISTAT .EQ. 0) IERR=0 IF (IERR .EQ. 0) RETURN C***************************************************************** C TAPE HAS NO WRITE RING. C CALL CNUMD(TAPE,NUM) CALL SMOVE(NUM,1,6,ERR1,10) CALL REIO(2,LU1,ERR1,17) IERR=-230 CALL DBER2(LU1,IERR,6HXXXXXX,6HRING ,2HXX) RETURN END