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$
                                                                                                                                                                                                                        