FTN4 SUBROUTINE TSE, 92080-16520 REV.2026 800605 C C C NAME: TSE C SOURCE: &TSE' 92080-18521 C RELOC: %TSE' ----NONE--- PART OF %TSE 92080-16520 C C PGMR: DANIEL POT/FRANCOIS GAULLIER HPG 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: TSE IS A T.U.S. OF THE TMP C (TRANSACTION MONITOR PROGRAM) C C C TSE = TRANSACTION SET EDITOR C C TSE ALLOWS THE OPERATOR TO CHANGE OR TO LIST THE MIX OF C TRANSACTION SPECS. USED BY TMP, THROUGH AN INTERACTIVE C DIALOG. C THE OPERATOR CAN REMOVE OR ADD A TRANSACTION SPEC. AND C LIST THE DIRECTORY OR THE CONTENT OF A SPECIFIC TRANSAC- C TION SPECIFICATION. C C********************************************** F. GAULLIER (HPG) *** C C DIMENSION INPUT(150),IDCB(144),LTEMP(3),ISTBF(5) INTEGER TSMG(3),FORMN,SQUAL,J,FMGST,STATE,STATLN,TITLE(111) INTEGER BTCHBF,DTL,BCHKL(20) . ,DCMON(3),REST(8),RETUN(25),PROCS(23),LABEL(2) . ,SAVSTA,SAVSTX,CURTSN,BIT15,DCAP(22),DSTR(19) . ,ACTIVE(3),QUIET(3) C C-----NO TRUE COMMON C C-----1ST COMMON BLOCK C COMMON LU,ICTLB,ITYP,IST,ITL,IMAGEX(18),SAVSTX,NPAD(122) C C-----NO 2ND COMMON BLOCK C C-----3ND COMMON BLOCK C COMMON FORMN,SQUAL,J,FMGST,STATLN,STATE(90) . ,MBUFR(9),L,SAVSTA,CURTSN(12),IERTN COMMON BTCHBF(20),NUM,BITCH,ISCBF(15),DTL C C-----LAST COMMON WORD C COMMON ICOMEN C LOGICAL ISSLA,ISBTW,ISSPA,ISNUL,ISBIT,CMPW,CMPB,STRAP,RESET LOGICAL ISNUM,JPAR,IMBED,KPAR,CREAT,CLOSE,NAMF,NAMCK,TDCBC LOGICAL BITCH,STRFLG EQUIVALENCE (REG,IA) C C-----DATA DEFINITIONS C D DATA LUOXXX/1/ DATA LENSC/29/,IFTYP/55/,BIT15/100000B/ DATA TSMG/2HTS,2HMG,2H /,IZERO/0/ DATA DCMON/2HDC,2HMO,2HN / DATA BCHKL/20*2H--/ C C-----DATA DEFINITION FOR LISTING OPERATION C DATA REST/15530B,15555B,15446B,2Hk0,2HB ,15542B,15510B,15512B/ DATA RETUN/6412B,6412B,15446B,60453B,32067B,41440B,15446B . ,62112B,2HPr,2Hes,2Hs ,15446B,62113B,2HNE,2HXT,2H S,2HCR . ,2HEE,2HN ,15446B,62112B,2Hke,74433B,23144B,40040B/ DATA PROCS/15446B,62102B,2HRE,2HAD,2HIN,2HG ,2HTR,2HAN,2HSA, . 2HCT,2HIO,2HN ,2HSP,2HEC,2HIF,2HIC,2HAT,2HIO,2HN ,15446B, . 62100B,6412B,6412B/ DATA ACTIVE/2HAC,2HTI,2HVE/, QUIET/2HQU,2HIE,52000B/ DATA DSTR/6412B,15446B,2Ha+,2H09,2HC ,2HAC,2HTI,2HVE,2H I,2HN . ,2HST,2HOR,2HAG,2HE ,2HMO,2HDU,2HLE,2H. ,6412B/ DATA DCAP/6412B,15446B,2Ha+,2H09,2HC ,2HAC,2HTI,2HVE,2H O,2HN . ,2HDA,2HTA,2H C,2HAP,2HTU,2HRE,2H T,2HER,2HMI,2HNA,2HL. . ,6412B/ DATA TITLE/6412B,15446B,2Ha+,2H16,2HC ,2HT . ,2HR ,2HA ,2HN ,2HS ,2HA ,2HC ,2HT ,2HI ,2HO ,2HN ,2H ,2HS . ,2HE ,2HT ,2H ,2HE ,2HD ,2HI ,2HT ,2HO ,2HR ,6412B,6412B . ,15446B,2Ha+,2H29,2HC ,2HDI,2HRE,2HCT,2HOR,2HY ,2HLI,2HST . ,6412B,6412B,15446B,2Ha+,2H09,2HC ,2HTR,2HAN,2HSA,2HCT,2HIO . ,2HN ,2HSP,2HEC,2HIF,2HIC,2HAT,2HIO,2HN ,2H ,2H ,2H . ,2H T,2H.S,2H. ,2HLI,2HBR,2HAR,2HY ,2H ,2H ,2H ,2H T . ,2H.S,2H. ,6412B,15446B,2Ha+,2H08,2HC ,2HNa,2Hme . ,2H ,2H ,2H N,2Hum,2Hbe,2Hr ,2H ,2HSe,2Hc.,2H C,2Hod . ,2He ,2H ,2H ,2HNa,2Hme,2H ,2H C,2Har,2Htr,2Hid,2Hge . ,2H ,2H ,2H S,2Hta,2Htu,2Hs ,6412B/ C IRS12(M0)=IAND(IALF2(M0),360B)/16 IRS14(M1)=IAND(IALF2(M1),300B)/100B KPAR(ILONG)=JPAR(INPUT,LENSC,IFILD,IDCB,ILONG,IFLAG,INOMB) IGETB(IJBUF,JJJ)=IAND(IALF2(IGET1(IJBUF,JJJ)),177B) C C-----DEFINE COMMON BLOCK STRUCTURE C CALL TMDFN(LU,LU,FORMN,FORMN,ICOMEN) SAVSTX=IST C C CALL TMSAN(6,10,10HTSE 00000) C CALL TMSAN(LUOXXX,100,10HTSE 0001) C C-----CHECK TERMINAL TYPE AND INHIBIT ECHO C IF(ITYP .NE. 2645) RETURN LOCK = LURQW(LUTRU(LU)) STRFLG = STRAP(LU,ISTBF,LOCK) ICTLB=0 C C-----ENABLE 3RD COMMON BLOCK C CALL TMCBE(0,FORMN) C C SET THE BATCH FILE RECORD NUMBER TO ZERO AND THE BATCH FLAG TO C INDICATE NO BATCH STARTUP C NUM=0 BITCH=.FALSE. C C RECOVER THE BATCH FILE NAMR IF ANY C CALL TMPAR(BTCHBF) C C BATCH STARTUP?? C IF(BTCHBF.EQ.BCHKL)GO TO 5 BITCH = .TRUE. CALL TMZAP(BCHKL) C C-----PRINT ON THE CRT THE SOFT KEY ASSIGNEMENTS C 5 IF(BITCH)GO TO 700 CALL TSESF IF(STRFLG)CALL TSEOR(38,1) CALL TMRD(INPUT,-3) IF(ITL.NE.2 .OR. INPUT.NE.2H ) GOTO 5 C C-----INITIALISE SCREEN CONTENT C 700 CALL PUTCA(MBUFR,1H ,1) CALL BLAN(MBUFR,2,6) CALL MOVCA(0,1,MBUFR,8,2) CALL BLAN(MBUFR,10,6) CALL MOVCA(0,1,MBUFR,16,2) C C-----PRINT INTERACTIVE SCREEN ON THE CRT C 1 CALL TSESC(MBUFR) C C-----GET OPERATOR ANSWERS C 10 IF(.NOT.BITCH)GO TO 12 IEER=0 CALL BATCH(BTCHBF,NUM,ISCBF,DTL,IEER) IF(IEER.NE.0)GO TO 13 CALL TMBWR(ISCBF,DTL) CALL ENTER GO TO 12 13 CALL TSEOR(IEER,1) BITCH=.FALSE. 12 CALL TMRD(INPUT,-LENSC-1) IF(ITL.EQ.1 .AND. IGET1(INPUT,1).EQ.60440B) GOTO 18 IF(ITL .NE. LENSC) GOTO 1 C C-----PROCESS RECEIVED BLOCK-MODE BUFFER C C-----GET SELECTED FUNCTION C 18 IFILD=1 IF ( KPAR(1) ) GOTO 20 IERNB=30 IF(IFLAG.EQ.0) GOTO 30 IERNB=24 IF(IFLAG.NE.3) GOTO 30 IH=IGET1(IDCB,1) IF(IH.EQ.1HT) GOTO 40 SQUAL=0 STATE=0 IF(IH.EQ.1HL) SQUAL=-3 IF(IH.EQ.1HA) SQUAL=-2 IF(IH.EQ.1HD) SQUAL=-11 IF(IH.EQ.1HP) SQUAL=-4 IF(IH.EQ.1HS) SQUAL=10 IERNB=26 IF(SQUAL.EQ.0) GOTO 30 CALL MOVCA(IDCB,1,MBUFR,1,1) IF(SQUAL.EQ.-4) GOTO 4000 C C-----SET UP FOR LOAD TRANSACTION SPECIFICATIONS C STATE(1)=BIT15 STATE(4)=BIT15 STATE(5)=BIT15 IF(SQUAL.EQ.-3) GOTO 70 C C-----GET TRANSACTION NAME OR NUMBER C IFILD=2 IF ( KPAR(6) ) GOTO 20 IF(IFLAG.NE.1) GOTO 50 IERNB=29 IF(ISBTW(INOMB,1,9999)) GOTO 30 STATE(4)=INOMB CALL CNUMD(INOMB,IDCB) IF(IDCB(3) .EQ. 2H 0) IDCB(3)=2H GOTO 58 50 IERNB=8 IF(IFLAG.NE.3) GOTO 30 IF(NAMCK(IDCB)) GOTO 30 CALL MOVEW(IDCB,STATE,3) 58 CALL MOVCA(IDCB,1,MBUFR,2,6) C C-----GET TRANSACTION SECURITY CODE C IFILD=3 IF ( KPAR(6) ) GOTO 20 IERNB=27 IF(IFLAG.EQ.3.OR.IFLAG.EQ.2) GOTO 30 IF(IFLAG.EQ.0) INOMB=0 IF(INOMB.EQ.BIT15) GOTO 30 STATE(5)=INOMB CALL MOVCA(INOMB,1,MBUFR,8,2) IF(SQUAL.EQ.10 .OR. SQUAL.EQ.-11) GOTO 4000 C C-----GET DISC FILE NAME C 70 IFILD=4 CALL BLANC(IDCB,3) IF ( KPAR(6) ) GOTO 20 IERNB=25 IF(IFLAG.EQ.1.OR.IFLAG.EQ.2) GOTO 30 IERNB=30 IF(IFLAG.EQ.0) GOTO 30 IERNB=24 IF(IMBED(IDCB,1,6)) GOTO 30 CALL MOVEW(IDCB,STATE(6),3) CALL MOVCA(IDCB,1,MBUFR,10,6) IF(IDCB .EQ. 2H ) GOTO 4000 C C-----GET CARTRIDGE NUMBER C IFILD=5 IF ( KPAR(6) ) GOTO 20 IERNB=31 IF(IFLAG.EQ.2) GOTO 30 IF(IFLAG.EQ.3)GO TO 750 IF(IFLAG.EQ.0) INOMB=0 IF(ISBIT(INOMB,15)) GOTO 30 STATE(9)=INOMB GO TO 760 750 IF(ISUPB(IDCB,3).NE.1)GO TO 30 INOMB=IDCB IF(ISBTW(IGETB(INOMB,1),101B,132B))GO TO 30 IF(ISBTW(IGETB(INOMB,2),101B,132B).AND.ISBTW(IGETB(INOMB,2), . 60B,71B).AND.IGETB(INOMB,2).NE.40B)GO TO 30 STATE(9)=INOMB C C OPEN THE DISC FILE TO GET ITS TYPE C 760 CALL OPEN(IDCB,KER,STATE(6),0,0,STATE(9)) KQFTP=IDCB(4) CALL CLOSE(IDCB) IF(KER.NE.0)GO TO 770 CALL EXEC(13,KQFTP,IEQT5) IEQT5=IAND(IEQT5,37400B)/256 C C IF(IEQT5.EQ.23B.OR.IEQT5.EQ.5B)GO TO 770 IFILD = 4 IERNB=23 GO TO 30 770 CALL MOVCA(INOMB,1,MBUFR,16,2) GOTO 4000 C C-----CHECK FOR ABORT KEY C 20 IF(IFLAG.EQ.9) GOTO 40 IERNB=24 GOTO 30 C C-----ERROR MESSAGE OUTPUT C 30 CALL TSEOR(IERNB,IFILD) BITCH=.FALSE. GOTO 10 C C-----RETURN PROCESS C 40 CALL TMWR(REST,8) STRFLG=RESET(LU,ISTBF,IXX,LOCK) C IF(BITCH)GO TO 48 C C-----SCHEDULE DCMON WITH WAIT C C FIRST, RTE MUST BE FOOLED INTO THINKING TERMINAL IS NOT LOCKED C ILU = LU CALL DRTFK(LUTRU(LU),IDRT) CALL EXEC(100027B,DCMON,LU,1) GO TO 42 6999 IXX = 0 C C ...AND THEN UN-FOOLED C 42 CALL DRTFX(LUTRU(LU),IDRT) 48 RETURN C C-----CALL THE TRANSACTION SPEC. MANAGEMENT SUBROUTINE C 4000 CALL MOVEW(REST,INPUT,8) CALL MOVEW(PROCS,INPUT(9),23) K=8 IF(SQUAL.EQ.-3 .OR. SQUAL.EQ.-2) K=31 CALL TMWR(INPUT,K) J=LU C WRITE(6,40009) FORMN,SQUAL,J,FMGST,STATLN,(STATE(IX),IX=1,10), C + (MBUFR(IJ),IJ=1,9) C40009 FORMAT("TSE F40009 : "5@7/10@7/9@7) C WRITE(6,40008) FORMN,SQUAL,J,FMGST,STATLN,(STATE(IX),IX=1,10), C + (MBUFR(IJ),IJ=1,9) C40008 FORMAT("TSE F40008 : "5I6/10I6/9I6) CALL TMSUB(TSMG) C C-----CHECK REQUEST TYPE/STATUS C IF(SQUAL.EQ.-3 .OR. SQUAL.EQ.-2) GOTO 4020 IF(FMGST .NE. 0) GOTO 5000 IF(SQUAL.EQ.-4 .OR. SQUAL.EQ.10) GOTO 100 IF(SQUAL .EQ. -11) GOTO 4800 CALL TMPER(0,99,0,0,401,SQUAL) C C-----RECALL ALL THE TS AND PERFORM ALL THE CHECKS C 4020 SAVSTA=FMGST IERTN=-1 4025 IERTN=IERTN+1 SQUAL=-10 CALL TMSUB(TSMG) IF(FMGST .EQ. -1) GOTO 4700 IF(FMGST .NE. 0 ) CALL TMPER(0,99,0,0,403,FMGST) D WRITE(LUOXXX,9877)(STATE(KKKK),KKKK=1,36) D9877 FORMAT(" /TSE TS HEADER: TSNAM="3A2" TS#="I4" TSSC="I6,@8,2I5,/ D .6X"REV="@6,2@8,3I3," ERRCD="I6,/6X"LIBNAM="3A2" LIB CR#="I6, D ./6X"DBNAM="3A2" DB SC="I5" DB CR#="I6," DB NODE="I4" DB CRC="@6, D ./,6X,10I3) C C-----SAVE CURRENT TS NAME & NUMBER & SC CALL MOVEW(STATE,CURTSN,5) C C-----CHECK IF TS IS OK FROM 'TSMG' (TSMG ERR FLG RETURNED IN STATE(15)) C IERNB=-STATE(15) IF(IERNB .NE. 0) GOTO 4600 C C-----CHECK LENGTH OF U&M QUESTION C LN=STATE(7)+STATE(8) IERNB=28 IF(LN+STATE(12)+25 .GT. 500) GOTO 4600 C C-----CHECK THE TS REV CODE C IERNB=16 IF( FMGST.EQ.-11 ) GOTO 4600 C C-----CHECK FOR LOGGING C IERNB=13 IF( .NOT. ISBIT(STATE(10),2) ) GOTO 4032 IF( .NOT. ISBIT(SAVSTX,7) ) GOTO 4600 C C-----CHECK THE DATA BASE C 4032 STATE(19)=0 IF(STATE(20) .EQ. 2H ) GOTO 4040 C C CREATE NAMR FROM NAME, SEC. CODE, CR. NO. C CALL MOVEW(STATE(20),STATE(19),3) STATE(22)=27B NCHRS=0 CALL BLANC(INPUT(11),11) CALL INAMR(STATE(19),INPUT(12),20,NCHRS) C CALL DMPTM(6,INPUT(11),15,12H AFTER INAMR ,12,2) C CALL DMPTM(6,NCHRS,1,2H ,1,0) CALL TBOPN(INPUT(11),0,0,INPUT) C CALL DMPTM(6,INPUT,25,12H AFTER TBOPN ,6,0) IERNB=9 IF(INPUT .NE. 0) GOTO 4600 IF(INPUT(4) .NE. STATE(26)) GOTO 4600 C C-----CHECK STORAGE MEDIA, GET STORAGE STATE C 4040 SQUAL=3 J=1 CALL TMSUB(TSMG) IF(FMGST .NE. 0 ) CALL TMPER(0,99,0,0,405,FMGST) I=2 4100 K=IRS12(STATE(I))+1 GOTO (4500,4200,4300,4200,4500),K C-----STORAGE CODE = 1 OR 3, CHECK FILE NAME 4200 IDCB(10)=0 CALL TDCBS(STATE(I+1),IDCB,IERR) IF(IERR .NE. -1) GOTO 4400 C-----THIS FILE IS ALREADY USED BY TMP, SET STORAGE CODE TO 1 4230 STATE(I)=10000B 4250 I=I+6 GOTO 4100 C-----STORAGE CODE = 2, SHOULD NOT EXIST FROM TGP 4300 CALL TMPER(0,99,0,0,410,0) GOTO 4250 C-----SAVE DCB FAILED, TMS-FMP DIRECTORY OVERFLOW ? 4400 IERNB=12 IF(IERR .EQ. -3) GOTO 4600 C-----THE FILE IS NOT USE, OPEN IT CALL OPEN(IDCB,IERR,STATE(I+1),1,STATE(I+5),STATE(I+4),144) C CALL WRITF(IDCB,JERR,IZERO,-1) C CALL RWNDF(IDCB,JERR) CRN=STATE(I+4) SECU=STATE(I+5) IF(IERR .EQ. 0) GOTO 4430 IF(IERR .EQ. IFTYP) GOTO 4450 IF(IERR .NE. -6) GOTO 4440 C-----THE FILE DOESN'T EXIST, CREATE A NEW ONE 4420 IF( CREAT(IDCB,IERR,STATE(I+1),128,IFTYP,STATE(I+5) . ,STATE(I+4),144) )GO TO 4421 CALL WRITF(IDCB,JERR,IZERO,-1) CALL RWNDF(IDCB,JERR) C C --- IF SHARED ACCESS SPECIFIED, CLOSE THE FILE & RE-OPEN IT C IN SHARED MODE. C IF(.NOT.ISBIT(STATE(I),11)) GO TO 4480 CALL CLOSE(IDCB) CALL OPEN(IDCB,IERR,STATE(I+1),1,STATE(I+5),STATE(I+4)) GO TO 4480 C 4421 IERNB=22 IF(IERR.EQ.-33) IERNB=37 GOTO 4600 C-----FILE TYPE 0, CHANGE STORAGE CODE TO 2, AND CHECK DEVICE 4430 STATE(I)=20000B LUSTR=IAND(IDCB(4),77B) IF(CLOSE(IDCB,IFUCK)) CALL TMPER(0,99,0,0,415,IFUCK) STATE(I+1)=LUSTR C -GET STATUS BEFORE TESTING FOR LOCK WHICH WILL RESET STATUS BITS. CALL EXEC(100015B,LUSTR,IEQT5,IEQT4,IDRT2) GO TO 4438 C-----IS THE LU LOCKED 44301 IERNB=19 CALL LURQ(140001B,LUSTR,1) GOTO 4600 4431 CALL ABREG(M,N) IF( M .NE. 0 ) GOTO 4438 IERNB=17 REG=EXEC(3B,LUSTR+600B) C-----CHECK DVR TYPE 4434 IF( IAND(IEQT5,37400B)/256 .NE. 23B ) GOTO 4438 C-----IS LU OR EQT DOWN IERNB=18 IF( ISBIT(IDRT2,15) ) GOTO 4438 IF( IRS14(IEQT5) .EQ. 1 ) GOTO 4438 C-----CHECK STATUS BITS IERNB=20 IF( IAND(IEQT5,77B) .NE. 0 ) GOTO 4438 C-----CHECK THAT THE TAPE IS AFTER AN EOF OR AT THE BEGINNING IF( IAND(IEQT5,300B) .EQ. 0 ) GOTO 4438 IERNB=17 CALL LURQ(40000B,LUSTR,1) GOTO 4600 4436 GOTO 4250 C-----ERROR AFTER THE LU LOCK, UNLOCK LU AND REPORT ERROR 4438 CALL LURQ(40000B,LUSTR,1) GOTO 4600 4439 GOTO 4600 C-----THE FILE TYPE IS INCORRECT, CLOSE THE FILE AND REPORT ERROR 4440 IF( CLOSE(IDCB,I) ) CALL TMPER(0,99,0,0,417,I) IERNB=10 GOTO 4600 C-----THE FILE ALREADY EXIST, ASK A NEW NAME TO RENAME IT 4450 CALL MOVEW(STATE(I+1),CURTSN(6),4) CALL BLAN(LTEMP,1,6) LTEMP=CURTSN(9) IF(.NOT.ISBTW(LTEMP,040501B,055132B)) * CALL JASC(CURTSN(9),LTEMP,1,6) CALL TCVTB(LTEMP,6) CURTSN(9)=LTEMP 4453 CALL TSDFE(CURTSN) 4455 CALL TMRD(INPUT,-7) IF(ITL .EQ. 6) GOTO 4460 C-----WRONG INPUT, CLEAR CRT AND RE-ISSUE CALL TMWR(REST,8) GOTO 4453 C-----CHECK IF THE FILE EXIST 4460 IF( .NOT. ISSPA(INPUT,1,6) ) GOTO 4470 IERNB=23 IF( NAMCK(INPUT) ) GOTO 4461 IERNB=21 IF( CMPW(STATE(I+1),INPUT,3) ) GOTO 4461 CALL OPEN(INPUT(4),IERR,INPUT,1,STATE(I+5),STATE(I+4)) IF(IERR .LT. 0) GOTO 4462 C-----THE FILE ALREADY EXIST, REPORT ERROR IF( CLOSE(INPUT(4),I) ) CALL TMPER(0,99,0,0,419,I) 4461 CALL TSEOR(IERNB,1) BITCH=.FALSE. C C################# I=I+2 C################# C GOTO 4455 C-----THE OPEN FAIL, WHICH ERROR ? 4462 IF(IERR.EQ.-7 .OR. IERR.EQ.-8) GOTO 4461 IERNB=23 IF(IERR .NE. -6) GOTO 4461 C PAUSE 776 IF(NAMF(IDCB,IERR,STATE(I+1),INPUT,STATE(I+5),STATE(I+4))) . CALL TMPER(0,99,0,0,421,IERR) C PAUSE 777 CALL TMBWR(REST,8) GOTO 4420 C-----THE NAME IS BLANK, RESET THE SCREEN AND REJECT THAT TS 4470 CALL TMBWR(REST,8) GOTO 4440 C-----THE STORAGE FILE HAS BEEN SUCCESSFULLY CREATED, PASSES C DCB TO TMS. 4480 CALL TDCBS(STATE(I+1),IDCB,IERR) IF(IERR .EQ. 0) GOTO 4230 IF(IERR .EQ. -3) GOTO 4400 CALL TMPER(0,99,0,0,423,IERR) C-----THE STORAGE DEFINTION IS OK, SEND IT BACK TO 'TSMG' 4500 CALL SETBT(SQUAL,8,1) CALL TMSUB(TSMG) IF(FMGST .NE. 0) CALL TMPER(0,99,0,0,425,FMGST) C-----THIS TS IS OK AND WILL NOT BE DELETED NOW, C UPDATE THE FILE DIRECTORY THAT KEEP TRACK OF IN USE FILE. CALL TSEFD(STATE,1) C C-----THIS TS IS OK, MAKE IT ACCESSIBLE FROM THE DATACATURE TERMINALS C SQUAL=-11 CALL MOVEW(CURTSN,STATE,5) STATE(4)=-STATE(4) CALL TMSUB(TSMG) IF(FMGST .NE. 0) CALL TMPER(0,99,0,0,427,FMGST) INPUT=6412B CALL MSTSN(CURTSN,K,INPUT(2)) CALL MOVEW(30H has been succesfully added. ,INPUT(K+2),15) CALL TMWR(INPUT,K+16) GOTO 4025 C C-----ERROR HAS OCCURS ON THAT TRANSACTION SPEC. C REPORT ERROR AND DELETE IT. C 4600 INPUT=6412B INPUT(2)=5012B CALL MSTSN(CURTSN,K,INPUT(3)) CALL MOVEW(22H has NOT been added. ,INPUT(K+3),11) CALL TMBWR(INPUT,K+12) CALL TSEOR(IERNB,0,IASC(LUSTR)) C-----DELETE THIS TS NOW ! SQUAL=-1 CALL TMSUB(TSMG) IF(FMGST .NE. 0) CALL TMPER(0,99,0,0,429,FMGST) GOTO 4025 C C-----END OF THE CHECK ALL TS, RECALL THE FMGST FROM THE LOAD/ADD C REPORT ERROR IF NECESSARY AND WAIT FOR OPERATOR INPUT C 4700 FMGST=SAVSTA IF(IERTN .EQ. 0) GOTO 295 GOTO 290 C C-----DELETE A TS FORM THE WORKING SET. THIS TS HAS NOW A NEG TS# C NO DATACAPTURE CAN ACCESS IT, UPDATE THE FILE DIRECTORY C CLOSE FILE THAT ARE NOT USE ANY MORE, AND PHISYCALLY C REMOVE THE TS FORM THE WORKING SET. C 4800 SQUAL=3 J=1 CALL TMSUB(TSMG) IF(FMGST .NE. 0) CALL TMPER(0,99,0,0,431,FMGST) C-----UPDATE THE FILE DIRECTORY CALL TSEFD(STATE,-1) C-----CLOSE ALL FILE THAT CAN BE CLOSED 4820 CALL TSEFD(INPUT,0) IF(INPUT .EQ. 0) GOTO 4870 IF( TDCBC(INPUT) ) CALL TMPER(0,99,0,0,435,0) GOTO 4820 C-----ACTUALLY DELETE THE TS FROM WORKING SET 4870 SQUAL=-1 CALL TMSUB(TSMG) IF(FMGST .NE. 0) CALL TMPER(0,99,0,0,437,FMGST) C-----PRINT TS SUCCESSFULLY DELETED INPUT=6412B CALL MSTSN(STATE,K,INPUT(2)) CALL MOVEW(30H has been succesfully deleted.,INPUT(K+2),15) CALL TMWR(INPUT,K+16) GOTO 290 C C-----TSMG ERROR MESSAGE C 5000 IERNB=-FMGST CALL TSESC(MBUFR) IFILD=2 GOTO (30,30,5030,30,30,5060,5070,30,5300,5300,5300,5300,5300, .5200,5200,5300),IERNB C-----TRANSACTION ALREADY IN THE WORKING SET 5030 IF(SQUAL.EQ.-3) IFILD=1 GOTO 30 C-----INTERNAL ERROR (TSMG OR CLOSE MEDIA) !! 5200 CONTINUE GOTO 5300 C-----BAD SECURITY CODE 5060 IFILD=3 GOTO 30 C-----ILLEGAL MEDIA 5070 IFILD=4 GOTO 30 C-----ANY OTHER ERROR (CURSOR ON THE FIRST FIELD) 5300 IFILD=1 GOTO 30 C C C ******************** C * LISTING FUNCTION * ===================== C ******************** C C 100 CALL TMWR(REST,8) IF(SQUAL.EQ.10) GOTO 300 C C-----DIRECTORY LIST ********************* C CALL MOVEW(18H31CDIRECTORY LIST ,TITLE(32),9) CALL TMBWR(TITLE,111) 220 CALL BLANC(INPUT,40) IF(STATLN .EQ. 0) GOTO 250 DO 230 L=1,STATLN K=L*10-8 ASSIGN 230 TO IERTN GOTO 225 230 CONTINUE GOTO 240 C C-----FORMAT ONE LINE FOR THE DIRECTORY PRINT-OUT C 225 CALL MOVEW(STATE(K+1),INPUT(5),3) CALL MOVEW(STATE(K+6),INPUT(21),3) CALL MOVEW(ACTIVE,INPUT(32),3) IF(STATE(K) .EQ. 0) CALL MOVEW(QUIET,INPUT(32),3) CALL JASC(STATE(K+4),INPUT,18,6) CALL JASC(STATE(K+5),INPUT,29,6) CALL JASC(STATE(K+9),LTEMP,1,6) CALL TCVTB(LTEMP,6) CALL MOVCA(LTEMP,1,INPUT,50,6) IF(IGET2(INPUT,54) .EQ. 2H 0) CALL PUTCA(INPUT,1H ,55) CALL TMWR(INPUT,34) GOTO IERTN C C-----GET NEXT DIRECTORY ENTRIES C 240 STATE=STATE+STATLN CALL TMSUB(TSMG) IF(FMGST .NE. 0) GOTO 5000 GOTO 220 C 250 INPUT=6412B INPUT(2)=6412B CALL JASC(STATE,INPUT,21,6) CALL MOVEW(8H ENTRIES,INPUT(14),4) IF(STATE .EQ. 0) CALL MOVEW(14H NO ENTRY,INPUT(11),7) IF(STATE .EQ. 1) CALL MOVEW(14H 1 ENTRY,INPUT(11),7) CALL MOVEW(18H IN THE DIRECTORY ,INPUT(18),9) CALL TMWR(INPUT,26) C C-----END OF LISTING OPERATION: WAIT FOR OPERATOR C 290 CALL TMWR(RETUN,25) IF(BITCH)CALL ENTER CALL TMRD(INPUT,1) IF(ITL.EQ.1 .AND. IGET1(INPUT,1).EQ.60440B) GOTO 40 295 IF(FMGST .NE. 0) GOTO 5000 GOTO 1 C C-----SATUS OF A TRANSACTION SPECIFICATIONS ********************* C 300 CALL MOVEW(STATE,STATE(2),-5) CALL MOVEW(STATE(16),STATE(7),4) STATE=J-1 CALL MOVEW(18H33CT.S. STATUS ,TITLE(32),9) CALL TMWR(TITLE,111) K=1 ASSIGN 305 TO IERTN CALL BLANC(INPUT,40) GOTO 225 C-----PRINT "ACTIVE/QUIET ON DATA CAPTURE TERMINAL" 305 CALL MOVEW(ACTIVE,DCAP(6),3) IF(IAND(STATE,377B) .NE. 0) GOTO 310 CALL MOVEW(QUIET,DCAP(6),3) CALL TMWR(DCAP,21) GOTO 400 C-----DATA CAPTURE TERMINAL ARE ACTIVE, PRINT LU'S 310 CALL TMWR(DCAP,22) L=STATE(STATLN+1) 315 I=9 CALL BLANC(INPUT,40) 320 K=IGETB(STATE(STATLN+2),L) IF(K .EQ. LU) GOTO 325 CALL JASC(K,INPUT,I,2) I=I+3 325 L=L-1 IF(I .GE. 70) GOTO 330 IF(L .GE. 1) GOTO 320 330 CALL TMWR(INPUT,35) IF(L .GE. 1) GOTO 315 C-----PRINT "ACTIVE/QUIET IN STORAGE MODULE" 400 CALL MOVEW(ACTIVE,DSTR(6),3) IF(IAND(J,177400B) .EQ. 0) CALL MOVEW(QUIET,DSTR(6),3) CALL TMWR(DSTR,19) C C-----CLOSE THE TRANSACTION IN THE WORKING SET C SQUAL=11 CALL TMSUB(TSMG) IF(FMGST.NE.0) CALL TMPER(0,99,0,0,439,FMGST) GOTO 290 END SUBROUTINE TSEFD(IBUF,ICOD), 92080-16520 REV.2026 800507 C C C NAME: TSEFD C SOURCE: &TSE' 92080-18521 PART OF &TSE' C BINARY: %TSE' ----NONE--- PART OF %TSE 92080-16520 C C PGMR: FRANCOIS GAULLIER DSD 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 * * C * THIS SUBROUTINE MAINTAIN A DIRECTORY OF ALL THE * C * DATA-STORAGE-DISC-FILE ACCESS BY TMP. THIS IS TO BE * C * ABLE TO CLOSE A FILE WHEN THE LAST TS ACCESSING THAT FILE * C * IS DELETED FROM THE WORKING SET. * C * * C * CALLING SEQUENCE: * C * * C * CALL TSEFD(IBUF,ICOD) * C * * C * IBUF: FILE NAME - CR# * C * PROVIDED IF ICOD=1 OR -1, RETURNED FOR * C * ICOD=0 * C * * C * ICOD: TYPE OF REQUEST * C * = 1 FILE BEING ACCESS BY A TS ADDED TO THE * C * WORKING SET. INCREMENT THE IN USE COUNTER.* C * =-1 FILE BEING ACCESS BY A TS DELETED FROM * C * THE WORKING SET. DECREMENT THE IN USE * C * COUNTER. * C * = 0 SEARCH FOR FILE NOT IN USE. * C * IF NOT FOUND --> RETURN IBUF=0. * C * IF FOUND --> RETURN IBUF=FILE NAME-CR * C * AND THE FILE IS DELETED * C * FROM THE DIRECTORY. * C * * C * * C **************************************************************** C DIMENSION IBUF(1) C INTEGER FILDIR(80),DIRLN,ENTLN C LOGICAL CMPW C DATA FILDIR/80*0/,DIRLN/80/,ENTLN/5/ C IRS12(M0)=IAND(IALF2(M0),360B)/16 C IF( ICOD .EQ. 0 ) GOTO 500 C C-----SEARCH FOR STORAGE CODE = 1, AND UPDATE THE FILE DIRECTORY C IF NECESSARY, INCREMENT OR DECREMENT IN USE COUNTER C IF( ICOD .LT. 0 ) ICD=-1 IF( ICOD .GT. 0 ) ICD=1 I=-3 20 I=I+5 J=1+IRS12(IBUF(I)) I=I+1 GOTO (200,100,20,20,200),J C-----STORAGE CODE = 1 100 DO 120 J=1,DIRLN-1,ENTLN IF(FILDIR(J) .EQ. 0) GOTO 130 IF( CMPW(FILDIR(J),IBUF(I),4) ) GOTO 140 120 CONTINUE CALL TMPER(0,99,0,0,441,0) 130 CALL MOVEW(IBUF(I),FILDIR(J),4) 140 FILDIR(J+4)=FILDIR(J+4)+ICD GOTO 20 200 RETURN C C-----SEARCH IN THE DIRECTORY FOR FILE THAT ARE NOT USED C 500 DO 550 J=1,DIRLN-1,ENTLN IF(FILDIR(J).NE.0 .AND. FILDIR(J+4).EQ.0) GOTO 600 550 CONTINUE IBUF=0 RETURN C-----ONE FILE NOT USE HAS BEEN FIND, RETURN THE FILE NAME C TO THE USER 600 CALL MOVEW(FILDIR(J),IBUF,4) C-----DELETE THAT FILE FROM THE DIRECTORY CALL MOVEW(FILDIR(J+ENTLN),FILDIR(J),DIRLN-J-ENTLN+1) CALL NUL(FILDIR(DIRLN-ENTLN+1),ENTLN) RETURN END SUBROUTINE TCVTB(IARG,IARGLN), 92080-16520 REV.2026 800507 DIMENSION IARG(1) LOGICAL ISBTW,ISSPA IF(ISSPA(IARG,1,IARGLN))GO TO 100 RETURN 100 IF(.NOT.ISBTW(IARG,040501B,055132B))GO TO 200 300 K=NUMD(IARG,1,IARGLN) IF(ISBTW(K,040501B,055132B))RETURN CALL BLAN(IARG,1,IARGLN) IARG=K RETURN 200 CALL JASC(IARG,IARG,1,IARGLN) RETURN END C SUBROUTINE BATCH(FILNM,NUM,DTXMT,DTL,ERR) *, 92080-16520 REV.2026 800507 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 PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * C ************************************************************* C DIMENSION FILNM(1),DTXMT(1) INTEGER FILNM,DTXMT,ERR,PNAMR(10),DTL INTEGER FC,RC,RL,REC(5),DCB(144),FLDLN(5) EQUIVALENCE(ISC,PNAMR(5)),(ICR,PNAMR(6)) C C FIELD LENGTH (BYTES) TABLE C DATA FLDLN/1,6,6,6,6/ ERR=0 FC=1 C C PARSE FILENAMR PASSED TO 'BATCH' C CALL NAMR(PNAMR,FILNM,20,FC) C C OPEN FILE C CALL OPEN(DCB,ERR,PNAMR,ISC,ICR) C C CHECK FOR ERRORS C IF(ERR.LT.0)GO TO 990 C C SPACE DOWN TO CORRECT RECORD IN FILE C IF(NUM.EQ.0)GO TO 468 DO 455 I=1,NUM CALL READF(DCB,ERR,REC,5,RL) IF(RL.EQ.-1) GO TO 995 IF(ERR.LT.0)GO TO 991 455 CONTINUE C C SET UP COUNTERS C C FC=FIELD COUNTER C RC=DATA TRANSMISSION BUFFER POINTER C 468 RC=1 FC=1 C C BLANK OUT DATA TRANSMISSION BUFFER C CALL BLANC(DTXMT,15) C C BLANK OUT RECORD BUFFER C 467 CALL BLANC(REC,5) C C READ A RECORD C CALL READF(DCB,ERR,REC,5,RL) NUM=NUM+1 C C IF END OF FILE THEN DO THE WRITE AND THEN READ C IF(RL.EQ.-1)GO TO 469 C C CHECK FOR ERRORS C IF(ERR.LT.0)GO TO 991 C C TURN WORD COUNT INTO BYTE COUNT C RL=RL*2 C C CHECK LAST CHAR FOR AN 'EDITR' PAD CHARACTER C AND ADJUST BYTE COUNT IF IT IS C C IF(IGETB(REC,RL).EQ.0B.OR.IGETB(REC,RL).EQ.40B)RL=RL-1 C C CHECK BYTE COUNT TO SEE IF IT IS ONE (REQUIRES SPECIAL HANDLING C IF(RL.EQ.1)GO TO 100 C C BYTE COUNT GREATER THAN ONE -- IF FIRST CHAR NOT A '+' THEN ERR C IF(IGET1(REC,1).NE.1H+)GO TO 992 C C MOVE DATA INTO DATA TRANSMISSION BUFFER C CALL MOVCA(REC,2,DTXMT,RC,RL-1) 101 RC=RC+RL-1 FC=FC+1 GO TO 467 C C HANDLING OF ONE-BYTE RECORDS IS HERE C 100 IF(IGET1(REC,RL).EQ.1H-)GO TO 103 IF(IGET1(REC,RL).EQ.1H+)GO TO 102 GO TO 992 102 RC=RC+FLDLN(FC) FC=FC+1 GO TO 467 C 103 IF(FC.GT.6)GO TO 994 C C PASS SCREEN BUFFER BACK TO TSE C 469 IF(RC-1.LE.0)GO TO 1000 DTL=-(RC-1) GO TO 1000 C C C E R R O R SECTION!!! C C C C OPEN ERROR C 990 ERR=32 GO TO 1000 C C READ ERROR C 991 ERR=33 GO TO 1000 C C RECORD LEN IS NOT 1 AND FIRST CHARACTER IS NOT A '+' C OR RECORD LEN IS 1 AND FIRST CHAR IS NOT A '+' OR '-' C 992 ERR=34 GO TO 1000 C C FIELD COUNT > 5 AND NO SCREEN GROUP SEPARATOR FOUND C 994 ERR=35 GO TO 1000 C C END OF FILE REACHED BEFORE A SCREEN GROUP SEPARATOR C 995 ERR=36 1000 CALL CLOSE(DCB) RETURN END END$