FTN4 PROGRAM TGP8(5), 92903-16367 REV.1913 790126 1330 C C SOURCE 92903-18367 C 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 PRGMR : JEAN CHARLES MIARD (HPG) C C********************************************************************* C* * C* THIS IS A SEGMENT OF THE TGP PROGRAM * C* USED TO ANALYSE THE ANSWERS THE USER HAS GIVEN TO SCREENS 18, * C* 19 AND 20 . * C* * C* THE ANSWERS AFTER CHECKS ARE STORED IN LFORM AND ILIBR . * C* * C* IF : INDIC = 0 : NORMAL PATH ANALYSE SCREEN # ISCRN . * C* INDIC = 2 : RETURN FROM TGP10 AN ERROR HAS OCCURED ON * C* READING OR WRITING THE SPECS * C* INDIC =-77 : A HELP MESSAGE MUST BE PRINTED * C* * C* WARNING !! : CARE MUST BE TAKEN * : * C* * C* PRINTED SCREEN # 18 CORRESPONDS TO ISCRN = 19 * C* .............. 19 ................. 20 * C* .............. 20 ................. 21 * C* * C* * C********************************************************************* C C C DECLARATIONS COMMON VARIABLES ************* C COMMON ILU,ISCRN,IQST,ISKIP,INDIC COMMON IFORM(766) COMMON JFORM(1400) COMMON MFORM(16) COMMON LFORM(39) COMMON ITT COMMON IKEY(26,3) COMMON IUMAX,IMMAX COMMON IMODB COMMON ILITE(15) COMMON IMAI(45,5) COMMON IMFLG,IMAS,IMDT,IMKY COMMON KFORM(2704) COMMON ILIBR(61) COMMON NIMAG C C LOCAL VARIABLES ************** C DIMENSION IBUF(60),JOUT(15),ITGP4(3),ITGP1(3) DIMENSION IDCB(144),ITGP10(3),NFORM(3),ITGP3(3) DIMENSION ITGP0(3),IHP19(4),IHP20(4),IHP21(13) C EQUIVALENCE (NOF,KFORM(1059)) C LOGICAL JPAR,NAMCK,CMPW,GETBK,OKABT C C DATA ITGP4/2HTG,2HP4,2H / DATA ITGP10/2HTG,2HPI,2H0 / DATA ITGP1/2HTG,2HP1,2H / DATA ITGP3/2HTG,2HP3,2H / DATA ITGP0/2HTG,2HP0,2H / DATA IHP19/2,3,1,5/ DATA IHP20/0,2,3,5/ DATA IHP21/4,4,4,4,4,4,4,4,4,4,2,3,1/ C C C********************************************************************* C C IF INDIC=2 PRINT ERROR MESSAGE ON SCREEN (ISKIP=FMGR ISTAT) C C********************************************************************* C IF(INDIC.EQ.2) GO TO 400 IF(INDIC.EQ.-77) GO TO 3011 C C********************************************************************* C C INDIC=0 GET USER'S ANSWERS IN THE SCREEN C C********************************************************************** C 15 IF(ISCRN.EQ.19) ITLOG=51 IF(ISCRN.EQ.20) ITLOG=22 IF(ISCRN.EQ.21) ITLOG=114 IF(.NOT.(GETBK(ILU,IBUF,ITLOG))) GO TO 10 C C ERROR IN GETTING ANSWERS REPRINT SCREEN C 17 IF(ISCRN.NE.19) CALL EXEC(8,ITGP3) CALL EXEC(8,ITGP4) C C********************************************************************** C C GO TO ANALYSE ISCRN SCREEN C C********************************************************************** C 10 IF(ISCRN.EQ.20) GO TO 2000 IF(ISCRN.EQ.21) GO TO 2100 C C********************************************************************* C C SCREEN # 18 (TRANSACTION SPECS. STORAGE) C C********************************************************************* C C C FILE NAME C NOF=1 IF(JPAR(IBUF,ITLOG,NOF,JOUT,6,IFLG,JVAL)) GO TO 3000 IF(IFLG.EQ.0) GO TO 1983 IF(NAMCK(JOUT)) GO TO 1982 CALL MOVEW(JOUT,LFORM(16),3) C C CR # ? C NOF=NOF+1 IF(JPAR(IBUF,ITLOG,NOF,JOUT,6,IFLG,JVAL)) GO TO 3000 IF(IFLG.GT.1) GO TO 1984 IF(JVAL.EQ.-32768) GO TO 1984 CALL MOVEW(JOUT,LFORM(19),3) C C HEADER OF LIBRARY C NOF=NOF+1 IF(JPAR(IBUF,ITLOG,NOF,JOUT,30,IFLG,JVAL)) GO TO 3000 IFLG1=IFLG CALL MOVEW(JOUT,LFORM(22),15) C C C C LIST FILE NAME C NOF=NOF+1 IF(JPAR(IBUF,ITLOG,NOF,JOUT,6,IFLG,JVAL)) GO TO 3000 1800 IF(IFLG.NE.0) GO TO 1805 LILU=ILU GO TO 1810 1805 IF(OPEN(IDCB,ISTAT,JOUT).LT.0) GO TO 1807 IF(ISTAT.NE.0) GO TO 1808 LILU=IDCB(4) CALL CLOSE(IDCB) GO TO 1810 1808 IMES=14 CALL CLOSE(IDCB) GO TO 410 1807 IMES=0 IF(ISTAT.EQ.-6) IMES=9 IF(IMES.EQ.0) CALL JASC(ISTAT,NFORM,1,6) GO TO 410 1810 IF(ISCRN.EQ.20) GO TO 2015 CALL MOVEW(JOUT,LFORM(37),3) C C SET ISKIP TO LIST LU GO TO STORE AND LIST TRANSACTION SPEC . C INDIC=1 ISKIP=LILU CALL EXEC(8,ITGP10) C C C ERROR SECTION SCREEN 18 C 1980 CALL MES08(1,NOF) GO TO 15 1981 CALL MES08(2,NOF) GO TO 15 1982 CALL MES08(3,NOF) GO TO 15 1983 CALL MES08(4,NOF) GO TO 15 1984 CALL MES08(5,NOF) GO TO 15 C C*********************************************************************** C C ERRORS COMING FROM TGP10 (FMGR ERRORS) C C********************************************************************** C 400 IMES=0 IF(ISCRN.EQ.19) NOF=1 IF(ISCRN.EQ.20) NOF=2 IF(ISCRN.EQ.21) NOF=11 IF(ISKIP.EQ.10) IMES=16 IF(ISKIP.EQ.-6) IMES=9 IF(ISKIP.EQ.-2) IMES=10 IF(ISKIP.EQ.1) IMES=6 IF(ISKIP.EQ.5) IMES=17 IF(ISKIP.EQ.6) IMES=18 IF(ISKIP.EQ.8) IMES=12 IF(ISKIP.EQ.24) IMES=9 IF(ISKIP.EQ.26) IMES=9 IF(ISKIP.EQ.66) IMES=21 IF(ISKIP.EQ.77) IMES=22 IF(ISKIP.EQ.99) IMES=19 IF(IMES.NE.0) GO TO 410 CALL JASC(ISKIP,NFORM,1,6) IMES=11 410 ISKIP=0 412 CALL MES08(IMES,NOF,NFORM) INDIC=0 GO TO 15 C-----IF ERR IS -6, "LIBRARY COULD NOT BE FOUND" 414 IF(ISKIP.EQ.-6) ISKIP=66 GO TO 400 C C********************************************************************** C C SCREEN # 19 BUILD LIBRARY 1 OF 2 C C********************************************************************* C 2000 NOF=1 C C MODE OF OPERATION C IF(JPAR(IBUF,ITLOG,NOF,JOUT,1,IFLG,JVAL)) GO TO 3000 IF(JOUT.EQ.1HT) GO TO 3045 IF((JOUT.NE.1HC).AND.(JOUT.NE.1HE).AND.(JOUT.NE.1HL)) GO TO 2080 ILIBR=IALF2(JOUT) C C SOURCE LIBRARY C NOF=NOF+1 IF(JPAR(IBUF,ITLOG,NOF,JOUT,6,IFLG,JVAL)) GO TO 3000 IF(IFLG.EQ.0) GO TO 1983 IF(NAMCK(JOUT)) GO TO 1982 CALL MOVEW(JOUT,ILIBR(2),3) C C CR # C NOF=NOF+1 IF(JPAR(IBUF,ITLOG,NOF,JOUT,6,IFLG,JVAL)) GO TO 3000 IF(IFLG.GT.1) GO TO 1984 IF(JVAL.EQ.-32768) GO TO 1984 IF(OPEN(IDCB,ISKIP,ILIBR(2),1,0,JVAL).LT.0) GO TO 414 C-----IF CR WAS NOT SPECIFIED, GET IT NOW FROM IDCB IF(JVAL.NE.0) GO TO 2005 ICR=ICRLU(-IAND(IDCB,77B)) CALL JASC(ICR,ILIBR,9,6) 2005 IF((ISKIP.EQ.0).OR.(ISKIP.EQ.35)) GO TO 2010 NOF=NOF-1 IMES=14 GO TO 410 2010 CALL MOVEW(JOUT,ILIBR(5),3) CALL CLOSE(IDCB) C C LIST FILE NAME C NOF=NOF+1 IF(JPAR(IBUF,ITLOG,NOF,JOUT,6,IFLG,JVAL)) GO TO 3000 IF(ILIBR.EQ.2H L) GO TO 1800 IF(IFLG.NE.0) GO TO 2081 2015 CALL MOVEW(JOUT,ILIBR(8),3) C C IF REQUEST IS TO PRINT DIRECTORY SET ISKIP TO LIST LU C AND GO TO TGP10, OTHERWISE PRINT SCREEN 20 C IF(ILIBR.EQ.2H L) GO TO 2020 ISCRN=21 CALL EXEC(8,ITGP3) 2020 INDIC=2 ISKIP=LILU CALL EXEC(8,ITGP10) C C*********************************************************************** C C SCREEN # 20 BUILD LIBRARIES 2 OF 2 C C********************************************************************** C 2100 NOF=0 C C ID. OF SPECS TO BE COPIED OR EXCLUDED C DO 2110 I=1,10 NOF=NOF+1 IF(JPAR(IBUF,ITLOG,NOF,JOUT,6,IFLG,JVAL)) GO TO 3000 C-----IF NUMBER, CHECK RANGE 1-9999. IF(IFLG.EQ.0) GO TO 2105 IF(IFLG.NE.1) GO TO 2105 IF((JVAL.LT.1).OR.(JVAL.GT.9999)) GO TO 2083 2105 CALL MOVEW(JOUT,ILIBR(11+(I-1)*3),3) 2110 CONTINUE C C DESTINATION LIBRARY C NOF=NOF+1 IF(JPAR(IBUF,ITLOG,NOF,JOUT,6,IFLG,JVAL)) GO TO 3000 IF(IFLG.EQ.0) GO TO 1983 IF(NAMCK(JOUT)) GO TO 1982 IF(CMPW(ILIBR(2),JOUT,3)) GO TO 2082 CALL MOVEW(JOUT,ILIBR(41),3) C C CR # C NOF=NOF+1 IF(JPAR(IBUF,ITLOG,NOF,JOUT,6,IFLG,JVAL)) GO TO 3000 IF(IFLG.GT.1) GO TO 1984 IF(JVAL.EQ.-32768) GO TO 1984 CALL MOVEW(JOUT,ILIBR(44),3) C C HEADER C NOF=NOF+1 IF(JPAR(IBUF,ITLOG,NOF,JOUT,30,IFLG,JVAL1)) GO TO 3000 IF(OPEN(IDCB,ISKIP,ILIBR(41),1,0,JVAL).LT.0) GO TO 2118 IF(IFLG.EQ.0) GO TO 2115 IF(ISKIP.EQ.0) GO TO 2120 ISKIP=-2 GO TO 400 2115 IF((ISKIP.EQ.0).OR.(ISKIP.EQ.35)) GO TO 2120 NOF=NOF-2 IMES=14 GO TO 410 2118 IF((ISKIP.EQ.-6).AND.(IFLG.NE.0)) GO TO 2120 GO TO 414 2120 CALL MOVEW(JOUT,ILIBR(47),15) LILU=ILU GO TO 2020 C C ERROR MESSAGES SCREEN 19 AND 20 C 2080 CALL MES08(7,NOF) GO TO 15 2081 CALL MES08(8,NOF) GO TO 15 2082 CALL MES08(15,NOF) GO TO 15 C-----"ILLEGAL TRANSACTION SPECIFICATION #" 2083 CALL MES08(20,NOF) GO TO 15 C C C*********************************************************************** C C 2645 SOFT KEYS PROCESSING C C*********************************************************************** C C IFLG=5 MEANS NON PRINTABLE ASCII C 3000 IF(IFLG.EQ.4) IFLG=5 IF(IFLG.NE.5) GO TO 3005 CALL MES08(13,NOF) GO TO 15 C C IFLG=6 MEANS ILLEGAL PARSE C 3005 IF(IFLG.NE.6) GO TO 3007 STOP 500 C C IFLG=7 MEANS HELP C 3007 IF(IFLG.NE.7) GO TO 3010 INDIC=-77 GO TO 17 3011 INDIC=0 IF(ISCRN.EQ.19) IMES=IHP19(NOF) IF(ISCRN.EQ.20) IMES=IHP20(NOF) IF(ISCRN.EQ.21) IMES=IHP21(NOF) CALL HLP08(IMES,NOF) GO TO 15 C C IFLG=8 MEANS LAST SCREEN C 3010 IF(IFLG.NE.8) GO TO 3040 IF(ISCRN.NE.19) GO TO 3066 ISCRN=18 CALL EXEC(8,ITGP4) 3066 IF(ISCRN.NE.20) GO TO 3012 DO 3014 I=1,100 3014 IFORM(I)=2H ISCRN=3 CALL EXEC(8,ITGP0) 3012 ISCRN=20 CALL EXEC(8,ITGP3) C C ABORT PROGRAM C 3040 IF(.NOT.OKABT(ILU)) GO TO 17 INDIC=99 CALL EXEC(8,ITGP1) 3045 INDIC=99 CALL EXEC(8,ITGP1) C C END OF SEGMENT C CALL TGP C C END END$