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$