FTN4
      SUBROUTINE STORB, 92080-16550 REV.2026  800331
C 
C 
C     NAME:   STORB     STORAGE MODULE # 2
C     SOURCE: &STORB    92080-18550 
C     BINARY: %STORB    92080-16550    THIS IS  %STORB
C 
C     PMGR:   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 
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: STORB  IS A   T.U.S. OF THE  TMP 
C                   (TRANSACTION MONITOR PROGRAM) 
C 
C 
C                  STORB = 2ND STORAGE MODULE (FILE ACCESS & USER STO.) 
C 
C 
C     TMPER  'INTERNAL ERROR' REPORTED BY  STORB: 
C     =========================================== 
C 
C            FORMAT:   INTERNAL ERROR    6XX**  NNNN
C 
C 
C        601  'TDCBR' FAIL TO RESTORE THE DCB 
C             NNN = 'TDCBR' STATUS
C        602  'TDCBS' FAIL TO SAVE THE DCB
C             NNN = 'TDCBS' STATUS
C        605  'LURQ' FIAL 
C             NNN = 'LURQ' STATUS 
C        610  'TSMG' FAIL TO CLOSE THE TS 
C             NNN = 'TSMG' STATUS 
C        620  FMP ERROR 
C             NNN = FMP ERROR # 
C 
C**********************************************  F. GAULLIER  (HPG)  ***
C 
C 
C 
      DIMENSION IBUF(512),IDCB(144),IREG(2) 
      INTEGER DATA,AREG,BREG,TSMG(3),FORMN,SQUAL,JNDEX,FMGST
      EQUIVALENCE (REG,IREG(1),AREG),(BREG,IREG(2)) 
C     ***   LOGICAL FUNCTION
      LOGICAL WRITF,POST,TDCBS,TDCBR,ISBIT
C 
C***   TRUE COMMON
      COMMON ICOM00(5)
C 
C***   1ST COMMON BLOCK 
C 
      COMMON LU,ICTLB,ITYP,IST,ITL,M,LUTERM,ITSN
     .      ,ITSOPT,ITIMPT,NPAD(136)
C 
C***   2ND COMMON BLOCK 
C 
      COMMON NUQ,NMQ,J,INDEXM,K,LUQ,LMQ,DATA(512) 
C 
C***   3RD COMMON BLOCK 
C 
      COMMON FORMN,SQUAL,JNDEX,FMGST
C 
C***   LAST COMMON WORD 
C 
      COMMON ICOMEN 
C 
      DATA TSMG/2HTS,2HMG,2H  / 
C 
C-----DEFINE LOCAL FUNCTION 
C 
      IRS12(M0)=IAND(IALF2(M0),360B)/16 
      IRS8(M2)=IAND(IALF2(M2),377B) 
C 
C------DEFINE COMMON BLOCK STRUCTURE, 
C 
      CALL TMDFN(ICOM00,LU,NUQ,FORMN,ICOMEN)
C 
      IF(LU.NE.3 .OR. ITYP.NE.7905)  RETURN 
C 
      M=K+9 
      ITIMPT=K+3
      LUTERM=DATA(K)
      ITSOPT=DATA(K+1)
      ITSN=J
C 
      CALL LOGEV(ICOM00(2),LUTERM,2000,0,ITSN,DATA(ITIMPT)) 
C 
   30 K=IRS12(DATA(M))+1
      M=M+1 
      GOTO (90,40,45,40,90),K 
C-----WRITE ON DISC FILE
   40 IER1=601
      IF( TDCBR(DATA(M),IDCB,IER2) )  GOTO 720
      GOTO 50 
C-----IF LU, DO LULOCK, CHECK TAPE STATUS AND BACKSPACE ONE EOF 
   45 LUSTR=DATA(M) 
      AREG=LURQ(100001B,LUSTR,1)
      IF(AREG .EQ. 0)  GOTO 47
      CALL TMPZ(50) 
      GOTO 45 
   47 REG=EXEC(3,600B+LUSTR)
      ASSIGN 78 TO IERTN
      CALL EXEC(13,LUSTR,IEQT5) 
      IF( IAND(IEQT5,77B) .NE. 0 )  GOTO 701
      IF( IAND(IEQT5,300B) .EQ. 0 )  GOTO 701 
      REG=EXEC(3,1400B+LUSTR) 
C 
C-----FORMAT THE BUFFER FOR THE STORAGE 
C 
   50 CALL MOVEW(DATA,IBUF,LUQ) 
      J=0 
  570 IF(J .EQ. INDEXM)  GOTO 70
      J=J+1 
      CALL MOVEW(DATA(LUQ+1+(J-1)*LMQ),IBUF(LUQ+1),LMQ) 
C-----IF STORAGE ON LU, USE EXEC CALL INSTEAD OF FMP CALL 
      IF( K .EQ. 3 )  GOTO 60 
      ASSIGN 80 TO IERTN
      IF( WRITF(IDCB,IER2,IBUF,LUQ+LMQ) )  GOTO 700 
      GOTO 66 
   60 REG=EXEC(2,DATA(M),IBUF,LUQ+LMQ)
C-----------CHECK FOR DEVICE FUL  ???????????? !!!!!!!!!!!!!!!!!
   66 IF(MOD(J,3)  .NE. 0)  GOTO 570
      CALL TMPZ 
      GOTO 570
C 
C-----THE DATA BUFFER IS EXAUSTED, GOTO NEXT STORAGE MEDIA
C 
   70 IF( K .EQ. 3 )  GOTO 75 
      ASSIGN 80 TO IERTN
      IF( POST(IDCB,IER2) )  GOTO 700 
      IER1=602
      IF( TDCBS(DATA(M),IDCB,IER2) )  GOTO 720
      GOTO 80 
C-----IF LU, WRITE EOF AND UNLOCK THE LU
   75 REG=EXEC(3,100B+DATA(M))
C----------CHECK FOR DEVICE FULL  ?????????????? !!!!!!!!!!!!!!!
   78 CALL LURQ(0,DATA(M),1)
   80 M=M+5 
      GOTO 30 
C 
C-----CLOSE THE TS IF STORAGE CODE = 1 WAS USED 
C 
   90 IF( .NOT. ISBIT(ITSOPT,14) )  GOTO 95 
      CALL TMCBE(0,FORMN) 
      FORMN=ITSN
      SQUAL=13
      CALL TMSUB(TSMG)
      IF(FMGST .NE. 0)  GOTO 715
      CALL TMCBD(FORMN) 
C 
C-----STORAGE FROM A USER WRITTEN SUBROUTINE
C 
   95 IF(K .NE. 5)  GOTO 999
      DATA(M)=IOR(DATA(M),100000B)
      CALL TMSUB(DATA(M)) 
      IF(IST .NE. 0)  CALL TMPER(0,53,ITSN,LUTERM,DATA(M),IST)
      M=M+3 
      GOTO 30 
C 
C                   FATAL ERROR PROCESSING
C                   ----------------------
C 
C 
C-----CR FULL WHEN WRITTING A DISC FILE ! 
C     (IF LOGGING IS USED, WARNING 26 ONLY) 
  700 IER1=620
      IF( TDCBS(DATA(M),IDCB) )  GOTO 720 
      IERNB=66
      IF(IER2 .NE. -6)  GOTO 720
      GOTO 702
C-----THE MAG. TAPE IS NOT POSITIONNED WERE IT MUST BE !
C     (IF LOGGING IS USED, WARNING 28 ONLY) 
  701 IERNB=68
  702 IF( ISBIT(ITSOPT,2) )  IERNB=IERNB-40 
      CALL TMPER(IERTN,IERNB,ITSN,LUTERM,DATA(M),DATA(M+3)) 
C-----ERROR ON LURQ 
  710 CONTINUE
  713 IER1=605
      GOTO 720
C-----ERROR IN TSMG 
  715 IER1=610
      IER2=FMGST
C-----ERROR DURING  TMS-FMP DCB SAVE ROUTINE
  720 CALL TMPER(0,99,ITSN,LUTERM,IER1,IER2)
C 
C     EXIT
C 
  999 CONTINUE
      CALL LOGEV(ICOM00(2),LUTERM,2010,0,ITSN,DATA(ITIMPT)) 
      RETURN
      END 
      END$
                                                                                                    