FTN4
      SUBROUTINE STORA, 92080-16540 REV.2026  800331
C 
C 
C     NAME:   STORA     STORAGE MODULE # 1
C     SOURCE: &STORA    92080-18540 
C     BINARY: %STORA    92080-16540    THIS IS  %STORA
C 
C     PGMR:    FRANCOIS GAULLIER
C 
C 
C     **************************************************************
C     * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979.  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     THIS PROGRAM IS A PART OF THE:
C 
C                      DATA CAPTURE SOFTWARE
C                        ( D A T A C A P )
C 
C     IT USES FEATURES OF THE TERMINAL MONITOR SOFTWARE (TMS).
C 
C     THIS MODULE: STORA  IS A  T.U.S. OF THE  TMP
C                   (TRANSACTION MONITOR PROGRAM) 
C 
C 
C                  STORA = 1ST STORAGE MODULE (IMAGE STORAGE) 
C 
C     THIS TMS-SUBROUTINE IS THE STORAGE MODULE OF DACORS 
C     IT ACTUALLY STORE INTO AN IMAGE/1000 DATA BASE AND SCHEDULE THE 
C     NON TMS PROGRAM TO STORE ON SEQUENTIAL FILES (MINI CARTRIDGED,
C     MAG TAPE OR DISC FILE) OR TO EXECUTE THE USER WRITTEN STORAGE 
C     MODULE. 
C 
C 
C     TMPER  'INTERNAL ERROR' REPORTED BY  STORA: 
C     =========================================== 
C 
C             FORMAT:   INTERNAL ERROR    5XX**  NNNN 
C 
C 
C        501  'TSMG' FAIL TO RETURN THE STORAGE STATE 
C             NNN = 'TSMG' STATUS 
C        502  'TSMG' FAIL TO CLOSE THE TS 
C             NNN = 'TSMG' STATUS 
C        505  STORAGE CODE=3 FOUND !  (SHOULD BE DELETED BY 'TSE')
C        520  IMAGE STORAGE ADD (DBPUT) FAIL
C             NNN = IMAGE STATUS
C        521  IMAGE STORAGE UPDATE (DBUPD) FAIL 
C             NNN = IMAGE STATUS
C        522  IMAGE STORAGE DELETE (DBDEL) FAIL 
C             NNN = IMAGE STATUS
C 
C 
C**********************************************  F. GAULLIER  (HPG)  ***
C 
C 
      INTEGER TSMG(3),STORB(3),FORMN,SQUAL,FMGST
     .,STATE,STATLN,OBUF,OBULN,OBULNX 
     .,DSN,INBR(50),IVALU(512),IMSTST,IMGSTA(10)
C 
C     ***   DEFINE FLAGS
      LOGICAL FOT 
C     ***   DEFINE LOGICAL FUNCTIONS
      LOGICAL ISBIT,JULIB 
C 
C***   TRUE COMMON
      COMMON ICOM00(5)
C***   1ST COMMON BLOCK 
      COMMON LU,ICTLB,ITYP,IST,ITL,IMAGEX(11),ISAVRT(7),
     .       IDUM(26),J,K,INDEX,IDBNUM  
C***   2ND COMMON BLOCK 
      COMMON NUQ,NMQ,ITSNUM,INDEXM,OBULN,L1,L2,OBUF(512)
C***   3RD COMMON BLOCK 
      COMMON FORMN,SQUAL,JNDEX,FMGST,STATLN,STATE(90) 
C***   4TH COMMON BLOCK 
      COMMON IMSTST(230),IMSTPT 
C***   LAST COMMON WORD 
      COMMON ICOMEN 
C 
D     EQUIVALENCE (LUOXXX,ICOM00) 
C 
      DATA TSMG/2HTS,2HMG,2H  / 
      DATA STORB/2HST,2HOR,2HB /
C 
C-----DEFINE LOCAL FUNCTION 
C 
      IRS12(M0)=IAND(IALF2(M0),360B)/16 
C 
C 
C-----SWAP JUST THE PROGRAM AREA
C 
      CALL EXEC(22,2) 
C 
C------DEFINE COMMON BLOCK STRUCTURE, 
C 
      CALL TMDFN(ICOM00,LU,NUQ,FORMN,IMSTST,ICOMEN) 
C 
C     IF(LU.NE.2 .OR. ITYP.NE.7905)  RETURN 
      IDBNUM=OBUF(OBULN+2)
      CALL TMCBE(0,FORMN) 
      FORMN=ITSNUM
C 
C-----GET STORAGE STATE FROM FORM-MMGT ROUTINE
C     AND SAVE THE FILE STORAGE DEFINITION FOR 'STORB'
C     AT  OBUF(OBULN+9) 
C                   OBUF(OBULN)    = DATA CAPTURE TERMINAL LU 
C                   OBUF(OBULN+1)  = TS OPTION
C                   OBUF(OBULN+2)  = DATA BASE NUMBER 
C                   OBUF(OBULN+3)  = TIME WHEN THE STORAGE HAS BEEN 
C                                    REQUESTED BY ZTMP (6 WORDS)
C 
C-----USE BIT 14 OF TS OPTION AS STORAGE CODE FLAG TO CLOSE THE T.S.
C 
      CALL SETBT(OBUF(OBULN+1),14,0)
C 
      CALL LOGEV(ICOM00(2),OBUF(OBULN),1010,0,ITSNUM,OBUF(OBULN+3)) 
C 
      SQUAL=3 
      JNDEX=1 
      INDEX=1 
   25 CALL TMSUB(TSMG)
C###################################################################
D     WRITE(LUOXXX,9870)STATE 
D9870 FORMAT(" /STORA:  STORAGE STATE VECTOR:",/,10(/,10(1X,@6))) 
C###################################################################
      IF(FMGST .NE. 0) GOTO 8010
C 
      J=2 
      IF(JNDEX .NE. 1)  GOTO 55 
C-----SET UP BUFFER FOR  'STORB' ROUTINE
      CALL MOVEW(STATE(2),OBUF(OBULN+9),15) 
   30 K=IRS12(STATE(J))+1 
      GOTO (60,35,40,8050,50,55),K
C-----STORAGE ON FILE (USE OF TMS-FMP CALL) 
   35 CALL SETBT(OBUF(OBULN+1),14,1)
C-----STORAGE ON DEVICE DEFINED BY LU 
   40 J=J+6 
      GOTO 30 
C-----STORAGE FROM A USER WRITTEN PROGRAM 
   50 J=J+4 
      GOTO 30 
C-----STORAGE IN AN IMAGE/1000 DATA-BASE
   55 IF(J.EQ.2 .AND. JNDEX.EQ.1)  OBUF(OBULN+9)=0
      IF(JNDEX .EQ. 1)  CALL TMCBE(0,IMSTST)
      CALL MOVEW(STATE(J),IMSTST(INDEX),STATLN-J+1) 
      INDEX=INDEX+STATLN-J+1
      JNDEX=JNDEX+1 
      IF( ISBIT(STATE,8) )  GOTO 25 
C-----IF NO STORAGE CODE = 1, CLOSE THE TS IMMEDIATLY 
   60 IF( ISBIT(OBUF(OBULN+1),14) )  GOTO 400 
      SQUAL=13
      CALL TMSUB(TSMG)
      IF( FMGST .NE. 0 )  GOTO 8020 
      CALL TMCBD(FORMN) 
C 
  400 IF( K .EQ. 1 )  GOTO 5050 
C 
C############################################################ 
D     WRITE(LUOXXX,9874)
D9874 FORMAT(" /STORA:  IMAGE DATA BASE STORAGE:",/)
D     WRITE(LUOXXX,9875)(IMSTST(I),I=1,INDEX-1) 
D     WRITE(LUOXXX,9876)INDEXM
D9875 FORMAT(2/," /STORA: IMAGE STORAGE STATE VECTOR:",30(/,7X,8@8))
D9876 FORMAT(" /STORA: INDEX MAXIMUM="I4,/) 
C######################################################## 
C 
      INDEX=0 
  500 IF(INDEX .EQ. INDEXM)  GOTO 5000
      INDEX=INDEX+1 
      IMSTPT=1
  700 IMSC=IAND(IMSTST(IMSTPT),17B) 
      IF(IMSC .EQ. 0)  GOTO 500 
      DSN=IAND(IMSTST(IMSTPT),1760B)/16 
      FOT = ISBIT(IMSTST(IMSTPT),10)
      K=IMSTST(IMSTPT+1)
      GOTO (1000,1000,3000),IMSC
C 
C-----ADD/UPDATE OPERATION
C 
 1000 INBR=K
      IMSTPT=IMSTPT+2 
      IMBUPT=1
      DO 1050 I=1,K 
      INBR(I+1)=IGETB(IMSTST(IMSTPT),2) 
      L=IGETB(IMSTST(IMSTPT),1) 
      IMSTPT=IMSTPT+1 
      IOBUPT=IMSTST(IMSTPT) 
      IMSTPT=IMSTPT+1 
      J=INDEX 
      IF(IOBUPT .LE. L1)  J=1 
      CALL MOVEW(OBUF(IOBUPT+(J-1)*L2),IVALU(IMBUPT),L) 
      IMBUPT=IMBUPT+L 
 1050 CONTINUE
C################################################################## 
D     KKKKKK=IMBUPT-1 
D     WRITE(LUOXXX,6754)DSN,INDEX,IMSC,FOT,K,IMAGEX,ISAVRT
D    .,(INBR(I),I=1,14),KKKKKK,(IVALU(I),I=1,KKKKKK)
D6754 FORMAT(" /STORA: DSN="I3,",   INDEX="I4",   CODE="I2, 
D    .",   FOT="@8",   N ITEM=",I5/," /STORA: IMAGEX:"8O7/5X, 
D    . 3O7/5X,7O7 
D    ./" /STORA: INBR:  "14I4,/" /STORA: IVALU LN="I4,
D    .",  IVALUE:",33(/7X,8@8),/) 
C################################################################## 
      IF(INDEX.NE.1 .AND. FOT)  GOTO 700
      IF(IMSC .EQ. 2)  GOTO 2000
C-----EXECUTE THE ADD  (PUT IN THE DATA-BASE) 
      CALL TBPUT(IDBNUM,DSN,1,IMGSTA,INBR,IVALU)
      IF(IMGSTA .EQ. 0)  GOTO 700 
      IF(IMGSTA.EQ.105 .OR. IMGSTA.EQ.106)  GOTO 8200 
      IERR=520
      GOTO 8550 
C-----EXECUTE THE UPDATE (UPDATE IN THE DATA-BASE)
 2000 CALL MOVEW(OBUF(OBULN-10*INDEX),IMAGEX(9),10) 
      CALL TBUPD(IDBNUM,DSN,1,IMGSTA,INBR,IVALU)
      IF(IMGSTA .EQ. 0)  GOTO 700 
      IERR=521
      GOTO 8550 
C 
C-----DELETE OPERATION
C 
 3000 IMSTPT=IMSTPT+1 
      IF(INDEX.NE.1 .AND. FOT)  GOTO 700
      CALL MOVEW(OBUF(OBULN-10*INDEX),IMAGEX(9),10) 
C###################################################################### 
D     WRITE(LUOXXX,7677)INDEX,DSN,ISAVRT
D7677 FORMAT("   INDEX="I6,5X"DELETE DSN ="I3,/,6I10) 
C#################################################################### 
      CALL TBDEL(IDBNUM,DSN,1,IMGSTA) 
      IF(IMGSTA .EQ. 0)  GOTO 700 
      IERR=522
      GOTO 8550 
C 
C-----LAUNCH PROCESS 'STORB' IF NEEDED
C 
 5000 CALL LOGEV(ICOM00(2),OBUF(OBULN),1020,0,ITSNUM,OBUF(OBULN+3)) 
5050  CONTINUE
      IF(IRS12(OBUF(OBULN+9)).EQ.0)RETURN 
      CALL TMPRO(3,STORB,NUQ) 
      RETURN
C 
C-----FATAL ERROR PROCESSING
C 
 8010 IERR=501
 8015 IMGSTA=FMGST
      GOTO 8550 
 8020 IERR=502
      GOTO 8015 
 8040 IERR=503
      GOTO 8500 
 8050 IERR=505
      GOTO 8500 
C-----DATA SET IS FULL ! (IF LOGGING IS USED, WARNING 25 ONLY)
 8200 IERNB=65
      IF( ISBIT(OBUF(OBULN+1),2) )  IERNB=25
      ASSIGN 700 TO IERTN 
      CALL TMPER(IERTN,IERNB,ITSNUM,OBUF(OBULN),DSN,0)
C-----INTERNAL ERROR !
 8500 IMGSTA=0
 8550 CALL TMPER(0,99,ITSNUM,OBUF(OBULN),IERR,IMGSTA) 
      RETURN
      END 
      END$
                        