FTN4 LOGICAL FUNCTION TSWR(MEDIA,INDIC,ISTAT,KBIN,KSCE,IBUF,IHD), 92080 C-1X313 REV.2026 800514 C C SOURCE 92080-18313 C C C C ************************************************************** C * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. 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 C PROGRAMMER *JCM* HPG C********************************************************************* C* * C* THIS LOGICAL FUNCTION WRITES A TRANSACTION SPECIFICA- * C* TION ON A GIVEN MEDIA SPECIFIED BY THE USER . * C* * C* A TRUE VALUE IS RETURNED IF THE WRITE OPERATION FAILS * C* A FALSE VALUE IS RETURNED IF THE WRITE SUCCEEDS * C* * C* DEFINITION OF PARAMETERS : * C* * C* MEDIA(5) : IS A 5 WORDS LONG BUFFER DEFINES THE MEDIA WHERE * C* THE TRANS. SPECS. MUST BE STORED : * C* -IF A DISC FILE THE FIRST 3 WORDS ARE FILE NAME * C* AND THE FOURTH CR# (0 IF NOT GIVEN) * C* AND THE FIFTH SECURITY CODE (35) * C* IF MEDIA(1) IS > 0 AN OPEN/REWIND OF THE MEDIA * C* IS PERFORMED * C* IF MEDIA(1) IS < 0 NO OPEN/NO REWIND * C* * C* INDIC : IS A 1 WORD LONG VARIABLE TO SPECIFY WHAT OPERATION * C* IS TO BE PERFORMED : * C* INDIC=0 : A NEW MEDIA IS USED (IF DISC FILE * C* CREATE FILE) * C* =1 : OLD MEDIA * WRITE THE SPECS AT CURRENT * C* POSITION IN FILE * C* =2 : OLD MEDIA * PERFORM A BACKSPACE BEFORE * C* WRITING THE SPECS * C* =3 : CLOSE MEDIA * WRITE EOF * C* =4 : CREATE NEW MEDIA ,WRITE HEADER * C* * C* ISTAT : IS A 1 WORD LONG VARIABLE TO RETURN THE STATUS OF * C* THE PERFORMED OPERATION : * C* ISTAT=0 : NO ERROR * C* =1 : FILE TYPE IS NOT GOOD * C* =2 : EOF FOUND * C* =4 : ILLEGAL PARAMETER * C* =5 : ERROR IN LOCKING TYPE 0 LU * C* =6 : ERROR IN UNLOCKING TYPE 0 LU * C* =7 : REACHED EOT ON TYPE 0 LU * C* <0 : FMGR ERROR * C* * C* * C* KBIN : ADDRESS OF STORAGE BUFFER FOR BINARY SPECS * C* * C* KSCE : ADDRESS OF STORAGE BUFFER FOR SOURCE SPECS * C* * C* IBUF : 144 WORDS LONG BUFFER (IDCB BUFFER) * C* * C* IHD : 15 WORDS LONG BUFFER CONTAINING THE LIBRARY HEADER * C* WRITTEN ON THE MEDIA ONLY IF INDIC=0 * C* * C********************************************************************* C* C* C* INTEGER CREATE,OPEN LOGICAL IRW,WRITF,POSNT,RWNDF,POST,EOTCK DIMENSION MEDIA(1),KBIN(1),KSCE(1),IBUF(1),ISIZE(2),IHD(1) C C-----"INREC1" IS THE LENGTH OF THE 1ST RECORD. AS A NEW VERSION OF TGP C IS RELEASED, THE VALUE OF "INREC1" SHOULD BE INCREMENTED BY 1 SO C THAT OLDER TRANSACTIONS CAN NO LONGER BE READ BY THE NEW VERSION C & NO MIX-UP CAN OCCUR. THE SAME VARIABLE (INREC1) SHOULD BE C SIMILARLY CHANGED IN "TSWR". DATA INREC1/13/ C C C INITIALISE LOGICAL FLAGS C C IRW : IF TRUE MUST REWIND C TSWR=.FALSE. IRW=.FALSE. K=(KBIN-INREC1)/127 IR=(KBIN-INREC1)-127*K ITYP0=0 C C C CHECK CALLING PARAMETERS C IF((MEDIA.NE.0).AND.(INDIC.GE.0)) GO TO 100 ISTAT=4 GO TO 900 C C REWIND AND OPEN ? C 100 IF(MEDIA.GT.0) IRW=.TRUE. ISAV=MEDIA IF(MEDIA.LT.0) MEDIA=-MEDIA C GO TO 500 C C NORMAL RETURN C 270 ISTAT=0 MEDIA=ISAV RETURN C C C ERROR RETURN C 900 TSWR=.TRUE. MEDIA=ISAV RETURN C C C IF INDIC=3 CLOSE FILE C 500 IF(INDIC.NE.3) GO TO 505 IF(WRITF(IBUF,ISTAT,IHD,-1)) GO TO 900 JLU=0 C-----TYPE 0 FILE? IF(IBUF(3).EQ.0) JLU=IAND(77B,IBUF(4)) CALL CLOSE(IBUF) IF(JLU.EQ.0) GO TO 270 C-----TYPE 0 FILE C-----REWIND, STANDBY CALL EXEC(3,500B+JLU) C-----UNLOCK IT BEFORE EXITING IF(LURQ(140000B,JLU,1).EQ.0) GO TO 270 C-----ERROR, UNABLE TO UNLOCK IT. C BUT GO AHEAD ANYWAY AS OF 2026 PCO SO AS TO NOT C CAUSE STOP 5000. GO TO 270 C ISTAT=6 C GO TO 900 C C IF INDIC=0 CREATE DISC FILE C 505 IF((INDIC.NE.0).AND.(INDIC.NE.4)) GO TO 510 IF(OPEN(IBUF,ISTAT,MEDIA,0,MEDIA(5),MEDIA(4)).LT.0) GO TO 508 IF(ISTAT.EQ.0) GO TO 507 IF(ISTAT.NE.35) GO TO 900 ISTAT=-2 GO TO 900 C-----TYPE 0 FILE? 507 IF(IBUF(3).EQ.0) GO TO 517 508 IF(ISTAT.NE.-6) GO TO 900 ISIZE=128 IF(CREAT(IBUF,ISTAT,MEDIA,ISIZE,35,MEDIA(5),MEDIA(4)).LT.0) . GO TO 900 C C OPEN/REWIND ? C 510 IF(.NOT.(IRW)) GO TO 520 IF(OPEN(IBUF,ISTAT,MEDIA,0,MEDIA(5),MEDIA(4)).LT.0) GO TO 900 C-----TYPE 0 FILE? IF(ISTAT.EQ.35) GO TO 519 IF(ISTAT.EQ.0) GO TO 517 ISTAT=1 GO TO 900 C C-----TYPE 0 FILE, GET LU NO. C 517 JLU=IAND(77B,IBUF(4)) C-----LOCK IT W/O WAIT. IF(LURQ(140001B,JLU,1).EQ.0) GO TO 519 C-----ERROR, UNABLE TO LOCK IT. C NO HARM DONE? GO AHEAD ANYWAY AS OF 2026 PCO GO TO 519 C-----CLOSE IT BEFORE EXITING C CALL CLOSE(IBUF) C ISTAT=5 C GO TO 900 C 519 IF(RWNDF(IBUF,ISTAT)) GO TO 900 C C BACKSPACE ? C 520 IF((INDIC.NE.0).AND.(INDIC.NE.4)) GO TO 525 IF(WRITF(IBUF,ISTAT,IHD,15)) GO TO 900 IF(INDIC.EQ.4) GO TO 270 525 IF(INDIC.NE.2) GO TO 530 IF(POSNT(IBUF,ISTAT,-1)) GO TO 900 C C WRITE FIRST RECORD C C -CHECK FOR WRITE TO MAG TAPE & IF EOT. 530 IF(EOTCK(ISTAT,IBUF)) GO TO 900 C 535 IF(WRITF(IBUF,ISTAT,KBIN,INREC1)) GO TO 900 C C WRITE BINARY SPECS C 540 L=127 DO 560 I=1,K+1 C -CHECK FOR WRITE TO MAG TAPE, & IF EOT. IF(EOTCK(ISTAT,IBUF)) GO TO 900 C -EXIT IF LAST LOOP & REMAINDER IS 0. IF(I.EQ.K+1 .AND. IR.EQ.0) GO TO 570 C -SET L (LENGTH TO WRITE) TO REMAINDER IF LAST RECORD. 545 IF(I.EQ.K+1) L=IR IF(WRITF(IBUF,ISTAT,KBIN(INREC1+1+(I-1)*127),L)) GO TO 900 560 CONTINUE C C WRITE SOURCE SPECS (TGP COMMON BUFFERS IFORM THRU IMKY) C (2807 WORDS FOR REV.2013 ) C 570 L=127 DO 600 I=1,23 C -CHECK FOR WRITE TO MAG TAPE & IF EOT. IF(EOTCK(ISTAT,IBUF)) GO TO 900 575 IF(I.EQ.23) L=82 IF(WRITF(IBUF,ISTAT,KSCE(1+(I-1)*127),L)) GO TO 900 600 CONTINUE C GO TO 270 C END C LOGICAL FUNCTION EOTCK(ISTAT,IBUF), 92080-1X313 REV.1936 790905 C C THIS FUNCTION WILL CHECK FOR EOT DURING TSWR. IT WORKS BY WRITING C A RECORD, THEN CHECKING THE DYNAMIC STATUS FOR EOT. IF EOT, A C FALSE CONDITION IS RETURNED & ISTAT SET TO -6. IF NOT EOT, THE C DUMMY RECORD WRITTEN IS BACKSPACED OVER & A TRUE CONDITION RETURNED. C C IBUF = THE IDCB. C DIMENSION IBUF(1),IREG(2) EQUIVALENCE (REG,IREG,IA) C C -TYPE 0 FILE? IF(IBUF(3).NE.0) GO TO 999 C -GET LU #. ITYP0=IAND(IBUF(4),77B) C -GET DRIVER TYPE FROM WORD 5 OF EQT. CALL EXEC(13,ITYP0,IEQT5,IEQT4,IDRT2) C -EXIT IF NOT MAG TAPE? IF(IAND(IEQT5,37400B)/256 .NE. 23) GO TO 999 C -WRITE 1 DUMMY RECORD TO DETECT EOT. CALL EXEC(2,ITYP0,IBUF,144) C -GET DYNAMIC STATUS. REG=EXEC(3,600B+ITYP0) C -EOT? IF(IAND(IA,40B).NE.40B) GO TO 99 C -YES. ERROR RETURN. EOTCK=.TRUE. ISTAT=7 RETURN C C -NOT EOT. BACKSPACE OVER DUMMY RECORD. 99 CALL EXEC(3,200B+ITYP0) 999 EOTCK=.FALSE. RETURN END END$