FTN4 PROGRAM TMPG4(5),92080-16456 REV.2026 800502 C C C NAME: TMPG4 C SOURCE: &TMG4A 92080-18456 C RELOC: %TMG4A 92080-16456 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 C ************************************************************** C * * C * THIS PROGRAM HANDLES SCREEN # 4 USING AN INTERACTIVE * C * DIALOGUE ON A 2645/2648 TERMINAL. * C * DEFINITION OF THE IMAGE DATA-BASE * C * * C ************************************************************** C C STOP USED: 4000 - 4010 C ---------- C C C IJOB = 2 THE SCREEN HAS BEEN PRINT, READ AND ANALYSE ANSWER C IJOB = 0 DO IMAGE & MAIN PROG DEFINITION C C IEND = 0 : CURRENT INTERACTIVE PROCESS C IEND = 1 : END OF INTERACTIVE PROCESS C IEND = 2 : ABORT TMPGN PROGRAM C IEND = 3 : PREVIOUS FAMILY SCREEN C C CCB1 C********************************************************************* C C-----LABELED COMMON # 1 GENERAL INFORMATION C COMMON /TMGC1/LU,LUPRT,LUOUT,ISYTP,IPARAM(5) C C LU - USER TERMIAL LU C LUPRT - LISTING LU C LUOUT - NOT USED C ISYTP - SYSTEM TYPE (MUST BE .EQ. -9, RTE-IV) C IPARAM - TMSGN OPERATING PARAMETERS: C ISCRN - CURRENT SCREEN NO. EQUIVALENCE (ISCRN,IPARAM(1)) C IOFST - OFFSET INTO BUFFER NCRTH EQUIVALENCE (IOFST,IPARAM(2)) C IEND - INTERACTIVE OPERATION INDICATOR C 0 - CURRENT PROCESS C 1 - END OF PROCESS C 2 - ABORT TMSGN C 3 - PREVIOUS SCREEN EQUIVALENCE (IEND,IPARAM(3)) C IJOB - TMS FUNCTION INDICATOR C 0 - DEFINE (INT. AND AUX. LU'S, AND T.U.S.) C 1 - SCREEN HAS BEEN PRINTED, PERFORM ANALYSIS C 3 - DEFINE T.U.S. INTO USER PARTITION EQUIVALENCE (IJOB,IPARAM(4)) C C********************************************************************* CCB1 C C C CCB2 C********************************************************************* C C-----LABELED COMMON # 2 FLAGS C COMMON /TMGC2/ITMFL,IRQFLG(30),IMOTR(9),IVASC0(9) C C ITMFL - C IRQFLG - LOAD FLAGS C IMOTR - BUFFER FOR TMS INFORMATION: C IMOFNC - TMS OPERATION CODE C 1 - CREATE/MODIFY C 2 - MODIFY LU # C 3 - MODIFY MAIN PROG C 4 - RELOAD TMS-SUBROUTINES C 5 - LOAD AN APPLICATION C 6 - LIST C 7 - PURGE APPLICATION C 8 - END TMSGN EQUIVALENCE (IMOFNC,IMOTR(1)) C IMOLOA - LOAD OPTION (SCREEN 0) C 1 - NO LOAD C 2 - BACKGROUND TEMPORARILY C 3 - BACKGROUND REPLACEMENT C 4 - BACKGROUND ADDITION C 5 - REAL TIME TEMPORARILY C 6 - REAL TIME REPLACEMENT C 7 - REAL TIME ADDITION EQUIVALENCE (IMOTR(2),IMOLOA) C IMOMAP - LOADER MAP OPTION EQUIVALENCE (IMOTR(3),IMOMAP) C IMOFLG - SEARCH %TMSLB FLAG EQUIVALENCE (IMOTR(4),IMOFLG) C IMONAM - APPLICATION NAME DIMENSION IMONAM(2) EQUIVALENCE (IMOTR(6),IMONAM(1)) C IMOSEC - SECURITY CODE EQUIVALENCE (IMOTR(8),IMOSEC) C IMOCRN - CARTRIDGE NUMBER EQUIVALENCE (IMOTR(9),IMOCRN) C IVASC0 - DISPLAY BUFFER FOR SCREEN INFORMATION C C********************************************************************* CCB2 C C C CCB3 C********************************************************************* C C-----LABELED COMMON # 3 BUFFER AREA C COMMON /TMGC3/IREFC,ILUGH,INTMS,ILPRG,IDECL,ILGMX,NBPRO . ,NCRTH(2540) C C IREFC - C ILUGH - C INTMS - C ILPRG - C IDECL - C ILGMX - C NBPRO - C NCRTH - OUTPUT FILE BUFFER: C NCNOWD - NO. OF WORDS IN FILE EQUIVALENCE (NCNOWD,NCRTH(1)) C NCINLU - BUFFER ADDR OF INTERACTIVE LU TABLE EQUIVALENCE (NCINLU,NCRTH(2)) C NCAXLU - BUFFER ADDR OF AUX LU TABLE EQUIVALENCE (NCAXLU,NCRTH(3)) C NCPAR1 - BUFFER ADDR OF FIRST PARTITION EQUIVALENCE (NCPAR1,NCRTH(4)) C NCNAME - APPLICATION NAME (2 WDS) DIMENSION NCNAME(2) EQUIVALENCE (NCNAME,NCRTH(5)) C NCSCOD - SECURITY CODE EQUIVALENCE (NCSCOD,NCRTH(7)) C NCCRNO - CARTRIDGE NO. EQUIVALENCE (NCCRNO,NCRTH(8)) C NCEMAS - EMA SIZE IN KWDS EQUIVALENCE (NCEMAS,NCRTH(9)) C NCMSEG - MSEG SIZE IN KWDS EQUIVALENCE (NCMSEG,NCRTH(10)) C NCPARS - PARTITION SIZE IN KWDS EQUIVALENCE (NCPARS,NCRTH(11)) C NCPARN - PARTITION NO. EQUIVALENCE (NCPARN,NCRTH(12)) C NCLOGD - LOGGING DEVICE LU OR FILENAME (5 WDS) DIMENSION NCLOGD(5) EQUIVALENCE (NCLOGD(1),NCRTH(13)) C NCTUSP - TUS NAME OF STARTING PROCESS (3 WDS) DIMENSION NCTUSP(3) EQUIVALENCE (NCTUSP(1),NCRTH(18)) C NCSTCK - STACK LENGTH EQUIVALENCE (NCSTCK,NCRTH(21)) C NCINIP - TUS NAME OF INITIAL PROCESS (3 WDS) DIMENSION NCINIP(3) EQUIVALENCE (NCINIP(1),NCRTH(22)) C NCLUIN - LU FOR INITIAL PROCESS EQUIVALENCE (NCLUIN,NCRTH(25)) C NCDBNO - NO. OF DATA BASES EQUIVALENCE (NCDBNO,NCRTH(26)) C C NOTE: THE FOLLOWING VARIABLES ARE EQUIVALENCED TO "NCRTH" FOR USE C BY TMSG5. C C IEXFL - EQUIVALENCE (IEXFL,NCRTH(2101)) C IPTR - EQUIVALENCE (IPTR,NCRTH(2102)) C NBSCR - EQUIVALENCE (NBSCR,NCRTH(2103)) C IFSCR - EQUIVALENCE (IFSCR,NCRTH(2104)) C ILAST - EQUIVALENCE (ILAST,NCRTH(2105)) C IFLG - C DIMENSION IFLG(29) C EQUIVALENCE (IFLG(1),NCRTH(2106)) C IPRVS - C DIMENSION IPRVS(29) C EQUIVALENCE (IPRVS(1),NCRTH(2135)) C IBUFR - DATA BUFFER USED BY SUBROUTINE "TMPRS" DIMENSION IBUFR(62) EQUIVALENCE (IBUFR(1),NCRTH(2164)) C ITEMP - DIMENSION ITEMP(3) EQUIVALENCE (ITEMP(1),NCRTH(2226)) C ITOSC - EQUIVALENCE (ITOSC,NCRTH(2229)) C C********************************************************************* CCB3 C C C CCB4 C********************************************************************* C C-----LABELED COMMON # 4 BUFFER USED IN CREATION PHASE & ERROR FLAG C OR I/O BUFFER USED IN THE INTERACTIVE DEFINITION C PHASE. C COMMON /TMGC4/IERFL,IERNB,IERTN,IERMS(7),IRLOC(70),ITRSF(20) C C NOTE: THE VARIABLES IN THIS COMMON ARE EQUIVALENCED TO "IOBUF" C FOR USE BY TMSG4 & TMSG5. C DIMENSION IOBUF(100) EQUIVALENCE (IOBUF(1),IERFL) C IERFL - C IERNB - C IERMS - C IRLOC - C ITRSF - C C********************************************************************* CCB4 C DIMENSION NAME(3),IPOB(3),IBUFF(30) DIMENSION KBUFR(44),LNFLD(5) DIMENSION ISTAT2(16) C LOGICAL JPAR,KPAR,CMPW,GETBK,OKABT,STUSP,INAMR LOGICAL PSFLG LOGICAL JJJJ LOGICAL IMBED,ISBTW,CMPW LOGICAL ISBIT INTEGER OPEN,PURGE C DATA LNFLD/5,5,6,6,1/,IBFSZ/15/ DATA LUOXXX/6 / C KPAR(IX1,IX2,IX3)=JPAR(IOBUF,LENGH,IFLD,IX1,IX2,IFLG,IX3) C C C JOB ? C C ISZSC=27 NOCHRS=0 IF(IJOB.EQ.2) GOTO 220 IF(IJOB.NE.0) STOP 4000 C C ***************************************************************** C * * C * DATA-BASE DEFINITION: * C * * C ***************************************************************** C C DISPLAY SCREEN # 4 C 5 ISCRN=4 IF(IOFST .EQ. 0) IOFST=IDECL-ISZSC 10 IOFST=IOFST+ISZSC K=1+(IOFST-IDECL)/ISZSC J=27+IBFSZ*(K-1) 11 IF(NCRTH(J) .NE. 0) GOTO 12 C-----NO DATA-BASE DEFINED YET, INIT THE BUFFER CALL MOVEW(12H ,NCRTH(J),6) NCRTH(J+6)=0 NCRTH(J+7)=0 NCRTH(J+8)=0 12 CALL MOVCA(K,1,NCRTH,IOFST+1,2) CALL MOVCA(NCRTH(J),1,NCRTH,IOFST+3,5) CALL MOVCA(NCRTH(J+3),1,NCRTH,IOFST+8,6) CALL MOVCA(NCRTH(J+6),1,NCRTH,IOFST+14,2) CALL MOVCA(NCRTH(J+7),1,NCRTH,IOFST+16,2) D I1=IDECL/2+1 D WRITE(LUOXXX,9877)K,J,IOFST,(NCRTH(I),I=I1,I1+79) D9877 FORMAT(/" K="I2,", J="I3", IOFST="I6", NCRTH:" D .,10(/8@8)) D WRITE(LUOXXX,9878)K,J,IOFST,(NCRTH(I),I=I1,I1+79) D9878 FORMAT(/" K="I2,", J="I3", IORST="I6", NCRTH:" D .,10(/8A2)) GOTO 210 C C PROCESS SCREEN # 4 C 20 PSFLG=.FALSE. K=1+(IOFST-IDECL)/ISZSC J=27+IBFSZ*(K-1) L=J I=1 C C DATA BASE NAME C IFLD=1 IF(KPAR(IBUFF,LNFLD(IFLD),IPOB)) GO TO 360 NUERO=18 IF(IFLG.NE.0 .AND. IFLG.NE.3) GO TO 440 IF(IMBED(IBUFF,1,LNFLD(IFLD))) GO TO 440 CALL ISUPB(IBUFF,3) CALL MOVEW(IBUFF,NCRTH(J),3) C C DATA BASE SECURITY CODE C 30 I=I+2 IFLD=2 IF(KPAR(IBUFF,LNFLD(IFLD),IPOB)) GO TO 360 NUERO=39 IF(IFLG.NE.0 .AND. NCRTH(J).EQ.2H ) GO TO 440 NUERO=29 IF(IFLG.NE.0 .AND. IFLG.NE.1 .AND. IFLG.NE.3) GO TO 440 IF(IFLG.NE.3) GO TO 37 IF(ISUPB(IBUFF,3).NE.1) GO TO 440 IF(ISBTW(IGETB(IBUFF,1),101B,132B)) GO TO 440 IF(ISBTW(IGETB(IBUFF,2),101B,132B) .AND. . ISBTW(IGETB(IBUFF,2),60B,71B) .AND. . IGETB(IBUFF,2).NE.40B) GO TO 440 NCRTH(J+6)=IBUFF GO TO 38 37 NUERO=29 IF(IPOB.LT.0) GO TO 440 NCRTH(J+6)=IPOB C C DATA BASE CARTRIDGE REFERENCE NUMBER C 38 IFLD=3 IF(KPAR(IBUFF,LNFLD(IFLD),IPOB)) GO TO 360 NUERO=39 IF(IFLG.NE.0 .AND. NCRTH(J).EQ.2H ) GO TO 440 NUERO=5 IF(IFLG.NE.0 .AND. IFLG.NE.1 .AND. IFLG.NE.3) GO TO 440 IF(IFLG.NE.3) GO TO 371 IF(ISUPB(IBUFF,3).NE.1) GO TO 440 IF(ISBTW(IGETB(IBUFF,1),101B,132B)) GO TO 440 IF(ISBTW(IGETB(IBUFF,2),101B,132B) .AND. . ISBTW(IGETB(IBUFF,2),60B,71B) .AND. . IGETB(IBUFF,2).NE.40B) GO TO 440 NCRTH(J+7)=IBUFF NUERO=35 IF(ICRLU(NCRTH(J+7)) .EQ. -1) GO TO 440 GO TO 372 371 IF(IPOB.LT.0) GO TO 440 NUERO=35 IF(ICRLU(IPOB) .EQ. -1) GO TO 440 NCRTH(J+7)=IPOB C C DATA BASE HIGHEST LEVEL ACCESS WORD C 372 IFLD=4 IF(KPAR(IBUFF,LNFLD(IFLD),IPOB)) GO TO 360 NUERO=18 IF(IFLG.NE.0 .AND. IFLG.NE.1 .AND. IFLG.NE.3) GO TO 440 IF(IMBED(IBUFF,1,LNFLD(IFLD))) GO TO 440 CALL ISUPB(IBUFF,3) NUERO=39 IF(NCRTH(J).EQ.2H .AND.IFLG.NE.0) GO TO 440 CALL MOVEW(IBUFF,NCRTH(J+3),3) C C LOCKK DATA BASE ON DEMAND? C IFLD=5 IF(KPAR(IBUFF,LNFLD(IFLD),IPOB)) GO TO 360 NCRTH(J+8)=0 NUERO=39 IF(IFLG.NE.0.AND.NCRTH(J).EQ.2H ) GO TO 440 NUERO=19 IF(IBUFF.NE.1H .AND.IBUFF.NE.1HX) GO TO 440 C C-----IF AN X WAS ENTERRED, SET THE NODE NUMBER (NOT USED) TO 1. C IF TMP2 IS BEING CREATED SET HIGH BIT ON, ELSE LEAVE 0 C FOR TMP1. C IF(IBUFF.EQ.1HX) NCRTH(J+8)=1 IF(IMOTR(7).EQ.2HP2) CALL SETBT(NCRTH(J+8),15,1) IF(NCRTH(J) .EQ. 2H ) GOTO 130 C C-----VERIFY THAT THE SAME DATA BASE IS NOT DEFINED TWICE C IF(K .EQ. 1) GOTO 70 L=27 NUERO=40 IKK=1 DO 53 KK=1,K-1 IF( CMPW(NCRTH(L),NCRTH(J),3) ) GOTO 400 53 L=L+15 C C THE DATA BASE IS DEFINED BY NAME,... OPEN IT C TO VERIFY SECURITY CODE, HIGHEST LEVEL ACCESS WORD, C AND CART. REF. # C C NOTE: NAME IS AT NCRTH(J) C LEVEL ACCESS WORD IS AT NCRTH(J+3) C SECURITY CODE IS AT NCRTH(J+6) C CR# IS AT NCRTH(J+7) C LOCK DATA BASE ON DEMAND ONLY AT NCRTH(J+8) C C NOTE FOR FUTURE ENHANCEMENT -- DB NODE # WILL BE AT NCRTH(J+8) C C 70 CALL NUL (KBUFR,44) NOCHRS=0 KBUFR(1)=2H CALL MOVEW(NCRTH(J),IBUFF,3) IBUFF(5)=NCRTH(J+6) IBUFF(6)=NCRTH(J+7) IBUFF(4)=27B IBUFF(7)=0B IBUFF(8)=0B IBUFF(9)=0B IBUFF(10)=0B JJJJ=INAMR(IBUFF,KBUFR(2),22,NOCHRS) CALL PUTCA(KBUFR,035400B,NOCHRS+2) CALL MOVEW(NCRTH(J+3),IBUFF,3) CALL DBOPN(KBUFR,IBUFF,1,IPOB) IF(IPOB .NE. 0) GOTO 75 IF(IPOB(2) .NE. 15) IPOB=10000 75 CALL DBCLS(KBUFR,1,1,ISTAT) IF(IPOB .EQ. 0) GOTO 82 78 IFLD=1 NUERO=0 IF(IPOB .EQ. 128) NUERO=25 IF(IPOB .EQ. 129) NUERO=26 IF(IPOB .EQ. 119) NUERO=27 IF(IPOB .EQ. 116) NUERO=27 IF(IPOB .EQ. 6) NUERO=27 IF(NUERO .NE. 0) GOTO 410 IFLD=4 IF(IPOB .EQ. 10000) NUERO=28 IF(NUERO .NE. 0) GOTO 410 IFLD=2 IF(IPOB .EQ. 117) NUERO=29 IF(NUERO .NE. 0) GOTO 410 IFLD=1 IF(IPOB.NE.0)NUERO=30 C IF(NUERO.NE.0)GO TO 410 CALL JASC(IPOB,IBUFF,1,6) CALL TMPGE(30,2,IBUFF(2)) GOTO 220 82 IPOB=ISTAT IF(IPOB .NE. 0) GOTO 78 CALL VFYDB(NCRTH(J),ISTAT2) IF(ISTAT2(1).EQ.1) GO TO 84 IFLD=1 NUERO=49 IF((ISBIT(ISTAT2(11),15).AND.IMOTR(7).NE.2HP2).OR. .((.NOT.ISBIT(ISTAT2(11),15)).AND.IMOTR(7).NE.2HP1)) GO TO 440 NUERO=50 IF(ISTAT2(1).EQ.3) GO TO 440 NUERO=51 IF(ISTAT2(1).EQ.0.AND.ISTAT2(2).GT.0.AND. . ISTAT2(11).NE.NCRTH(J+8)) GO TO 440 84 CONTINUE C C-----IMAGE DEFINITION OK, SET THE PROGRAM NAME C CHANGE CR# AND SEC-COD TO 2 ASCII CHARS IF REQ'D. C CALL MOVEW(NCRTH(J),NCRTH(J+9),3) C-----SET LOCK TABLE SIZE NCRTH(J+14)=4096 IF( PSFLG ) GOTO 368 GOTO 140 130 CALL NUL(NCRTH(J),IBFSZ) IF( PSFLG ) GOTO 368 IF(K .EQ. 4) GOTO 160 CALL MOVEW(NCRTH(J+IBFSZ),NCRTH(J),IBFSZ*(4-K)) CALL NUL(NCRTH(27+3*IBFSZ),IBFSZ) IOFST=IOFST-ISZSC IF(NCRTH(J) .EQ. 0) GOTO 160 140 IF(K .LT. 4) GOTO 10 K=K+1 C-----END OF INTERACTIVE PROCESS, RETURN TO MONITOR (SEG# 0) 160 NCRTH(26)=K-1 CALL TMGSC(0,0,0,1,2) C C C PRINT SCREEN C 210 CALL TMGSC(3,ISCRN,IOFST,IEND,2) C C READ FROM THE 2645 TERMINAL C 220 LENGH=0 IF(IEND .LT. 0) GOTO 420 IF(ISCRN.EQ.4) LENGH=27 IF(LENGH.EQ.0) STOP 4010 C IF(.NOT.GETBK(LU,IOBUF,LENGH)) GOTO 350 C C RE-DISPATCH AFTER AN HARD ERROR, RE-ISSUE THE SCREEN C 310 IF(ISCRN.EQ.4) GOTO 11 STOP 4012 C C DISPATCH TO SCREEN ANALYSIS PART C C 350 IF(ISCRN.EQ.4)GO TO 20 C ABORT OR PREVIOUS SCREEN COMMAND C 360 IF(IFLG .EQ. 8) GOTO 365 NUERO=34 IF(IFLG .NE. 9) GOTO 400 C-----USER WANTS TO ABORT ? IF( .NOT. OKABT(LU)) GOTO 310 C-----YES, OPERATOR WANTS TO ABORT CALL TMGSC(0,0,0,2) C-----EXECUTE THE PREVIOUS SCREEN COMMAND 365 IF(.NOT. PSFLG) IPS=IFLD PSFLG=.TRUE. IF(ISCRN.EQ.4) GOTO (30,38,368),I C 368 IF(ISCRN.NE.4) STOP 4015 IF(IOFST .LE. IDECL) GOTO 370 IOFST=IOFST-2*ISZSC GOTO 10 370 IF(IMOTR.NE.1) GOTO 380 C-----GO TO PREVIOUS SCREEN (SCREEN#3, DEFINITION OF TUS) CALL TMGSC(5,0,0,0,3) C 380 IEND=-33 IOFST=0 GOTO 5 C C ERROR MESSAGE C 400 IFLD=IKK 410 IF( PSFLG ) GOTO 365 GOTO 440 420 IFLD=1 NUERO=-IEND IEND=0 440 CALL TMPGE(NUERO,IFLD) GOTO 220 450 CALL TMPGE(NUERO,IFLD,IPOB) GO TO 220 C C DUMMY CALL TO MAIN !! C 7777 CALL TMPGN END END$