FTN4
      LOGICAL FUNCTION TSWR(MEDIA,INDIC,ISTAT,KBIN,KSCE,IBUF,IHD), 92903
     C-16313 REV.1913  790112 1715
C 
C     SOURCE 92903-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(4) : IS A 4 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*               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*                      <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
      DIMENSION MEDIA(1),KBIN(1),KSCE(1),IBUF(1),ISIZE(2),IHD(1)
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/11/ 
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
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(100000B,JLU,1).EQ.0) GO TO 270
C-----ERROR, UNABLE TO UNLOCK IT. 
      ISTAT=6 
      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,0,MEDIA(4)).LT.0) GO TO 508
      IF(ISTAT.NE.0) GO TO 506
C-----TYPE 0 FILE?
      IF(IBUF(3).EQ.0) GO TO 517
506   ISTAT=-2
      GO TO 900 
508   IF(ISTAT.NE.-6) GO TO 506 
      ISIZE=128 
      IF(CREAT(IBUF,ISTAT,MEDIA,ISIZE,35,0,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,0,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(377B,IBUF(4))
C-----LOCK IT W/O WAIT. 
      IF(LURQ(100001B,JLU,1).EQ.0) GO TO 519
C-----ERROR, UNABLE TO LOCK IT. 
C-----CLOSE IT BEFORE EXITING 
      CALL CLOSE(IBUF)
      ISTAT=5 
      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 
530   IF(WRITF(IBUF,ISTAT,KBIN,INREC1)) GO TO 900 
C 
C  WRITE BINARY SPECS 
C 
540   L=127 
      DO 560 I=1,K+1
      IF((I.EQ.K+1).AND.(IR.EQ.0)) GO TO 570
      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 
C 
570   L=127 
      DO 600 I=1,21 
      IF(I.EQ.21) L=7 
      IF(WRITF(IBUF,ISTAT,KSCE(1+(I-1)*127),L)) GO TO 900 
600   CONTINUE
C 
      GO TO 270 
C 
      END 
      END$
                                                                                                                                                                                                        