FTN4 PROGRAM TMPG4(5),92903-16456 REV.1913 790122 C C C NAME: TMPG4 C SOURCE: &TMPG4 92903-18456 C RELOC: %TMPG4 92903-16456 C C PGMR: DANIEL POT/FRANCOIS GAULLIER HPG C C C ************************************************************** C * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. 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 C-----LABEL COMMON # 1 GENERAL INFORMATION C COMMON /TMGC1/LU,LUPRT,LUOUT,ISYTP,ISCRN,IOFST,IEND,IJOB C C-----LABEL COMMON # 2 FLAGS C COMMON /TMGC2/ITMFL,IRQFLG(30),IMOTR(9) C C C-----LABEL COMMON # 3 BUFFER AREA C COMMON /TMGC3/IREFC,ILUGH,INTMS,ILPRG,IDECL,ILGMX,NBPRO . ,NCRTH(1) C C C-----LABEL COMMON # 4 I/O BUFFER (MAX SIZE = 100 WORDS) C COMMON /TMGC4/IOBUF C DIMENSION NAME(3),IPOB(3),IBUFR(30) DIMENSION KBUFR(44),LNFLD(5) C LOGICAL JPAR,KPAR,CMPW,PSFLG,GETBK,OKABT,STUSP LOGICAL IMBED,ISBTW,CMPW INTEGER OPEN,PURGE C DATA LNFLD/5,6,5/,IBFSZ/15/ D DATA LUOXXX/40/ C KPAR(IX1,IX2,IX3)=JPAR(IOBUF,LENGH,I,IX1,IX2,IFLG,IX3) C C C JOB ? C ISZSC=20 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) 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 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) 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)) 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 & LEVEL ACCESS WORD ANALYSIS C 25 IF( KPAR(IBUFR,LNFLD(I),IPOB) ) GOTO 360 NUERO=18 IF( .NOT. (IFLG.EQ.0.OR.IFLG.EQ.3) ) GOTO 400 IF(IMBED(IBUFR,1,LNFLD(I))) GOTO 400 CALL ISUPB(IBUFR,3) NUERO=39 IF(NCRTH(J).EQ.2H .AND.I.NE.1.AND.IFLG.NE.0) GOTO 400 CALL MOVEW(IBUFR,NCRTH(L),3) 30 I=I+1 L=L+3 IF(I .LT. 3) GOTO 25 C C DATA BASE SECURITY CODE C IBUFR=0 IF( KPAR(IPOB,5,IBUFR) ) GOTO 360 NUERO=6 IF( .NOT. (IFLG.EQ.0.OR.IFLG.EQ.1) ) GOTO 400 NUERO=39 IF(NCRTH(J).EQ.2H .AND. IFLG.NE.0) GOTO 400 IF(IBUFR .LT. 0) GOTO 400 NCRTH(J+6)=IBUFR 40 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 I=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 AND HIGHEST LEVEL ACCESS WORD C 70 CALL DBINT(NCRTH(J),NCRTH(J+6),0,IPOB) IF(IPOB .NE. 0) GOTO 78 CALL MOVEW(NCRTH(J+3),KBUFR,3) CALL DBOPN(NCRTH(J),KBUFR,NCRTH(J+6),1,IPOB) IF(IPOB .NE. 0) GOTO 75 IF(IPOB(2) .NE. 15) IPOB=10000 75 CALL DBCLS(0,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=2 IF(IPOB .EQ. 10000) NUERO=28 IF(NUERO .NE. 0) GOTO 410 IFLD=3 IF(IPOB .EQ. 117) NUERO=29 IF(NUERO .NE. 0) GOTO 410 CALL JASC(IPOB,IBUFR,1,6) CALL TMPGE(30,2,IBUFR(2)) GOTO 220 82 IPOB=ISTAT IF(IPOB .NE. 0) GOTO 78 C C-----IMAGE DEFINITION OK, SET THE PROGRAM NAME 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=18 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 10 STOP 4012 C C DISPATCH TO SCREEN ANALYSIS PART C 350 IF(ISCRN.EQ.4) GOTO 20 C 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,30,40),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=I 410 IF( PSFLG ) GOTO 365 GOTO 440 420 IFLD=1 NUERO=-IEND IEND=0 440 CALL TMPGE(NUERO,IFLD) GOTO 220 C C DUMMY CALL TO MAIN !! C 7777 CALL TMPGN END END$