FTN4
      PROGRAM TGP5(5), 92903-16360 REV.1913  790131 1715
C 
C     SOURCE 92903-18360
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 
C      PRGMR : JEAN CHARLES MIARD (HPG) 
C 
C 
C*********************************************************************
C*                                                                   *
C*            THIS IS A SEGMENT OF THE TGP PROGRAM USED TO           *
C*   ANALYZE THE ANSWERS THE USER HAS GIVEN IN THE SCREENS 11,12     *
C*   AND 13 . 
C*            THE ANSWERS AFTER A CHECK ARE STORED IN JFORM.         *
C*                                                                   *
C*            THIS SEGMENT IS LOADED ONLY TO ANALYSE SCREEN ANSWERS  *
C*   INDIC IS NOT USED .                                             *
C*                                                                   *
C*       IF INDIC=-77 A HELP MESSAGE IS TO BE PRINTED                *
C*                                                                   *
C*                                                                   *
C*   WARNING !! : CARE MUST BE TAKEN * :                             *
C*                                                                   *
C*       PRINTED SCREEN # 11 CORRESPONDS IN THE CODE TO ISCRN=12     *
C*        ............... 12 ................................ 13     *
C*        ............... 13 ................................ 14     *
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 JNAM(3),ILNGT(4,3)
      DIMENSION JOUT(10),KNAM(3),LNAM(3)
      DIMENSION IHP20(5),IHP21(6) 
      DIMENSION IHP30(4),IHP31(5) 
      DIMENSION IHP40(4),IHP41(5) 
C 
      EQUIVALENCE (NOF,KFORM(531))
C 
      LOGICAL JPAR,RNUM,GETBK,OKABT,ISBIT,NAMCK 
C 
C  DATA VALUES :
C 
      DATA JNAM/2HTG,2HP3,2H  / 
      DATA KNAM/2HTG,2HP4,2H  / 
      DATA LNAM/2HTG,2HP1,2H  / 
      DATA IHP20/0,0,1,2,4/ 
      DATA IHP21/0,0,1,2,3,4/ 
      DATA IHP30/0,0,2,4/ 
      DATA IHP31/0,0,2,3,4/ 
      DATA IHP40/5,6,7,4/ 
      DATA IHP41/5,6,7,3,4/ 
      DATA ILNGT/22,28,24,30,46,52,48,54,47,53,49,55/ 
      DATA JBYTES/140/
      DATA JWORDS/70/ 
C 
C 
C*********************************************************************
C 
C  GET USER'S ANSWERS IN THE SCREEN 
C 
C*********************************************************************
C 
      IF(INDIC.EQ.-77) GO TO 3011 
C 
C 
C 
      ISTAT1=0
      ISTAT2=0
      ISTAT3=0
      ISTAT4=0
15    I=IAND(ITT,3B)+1
      J=ISCRN-11
      ITLOG=ILNGT(I,J)
      IF(GETBK(ILU,KFORM,ITLOG)) GO TO 17 
C-----SET ICARD=1, IF INPUT FROM CARD READER, 
C-----FURTHERMORE, SET IMCRD=1, IF INPUT FROM IMAGE CARD. 
      ICARD=0 
      IMCRD=0 
C-----INPUT FROM CARD?
      IF(IGET1(JFORM,5+(IQST-1)*JBYTES).EQ.1H )GO TO 18 
C-----YES, CARD INPUT.
      ICARD=1 
C-----IMAGE CARD INPUT? 
      IF(IGET1(JFORM,43+(IQST-1)*JBYTES).EQ.1HI) IMCRD=1
      GO TO 18
C 
C  ERROR IN GETTING ANSWERS REPRINT SCREEN
C 
17    IF(ISCRN.NE.14) CALL EXEC(8,JNAM) 
      CALL EXEC(8,KNAM) 
C 
C*********************************************************************
C 
C GO TO ANALYSE USER ANSWERS TO SCREEN # ISCRN
C 
C*********************************************************************
C 
18    I=ISCRN-11
      GO TO(1200,1300,1400) I 
C 
C*********************************************************************
C 
C  SCREEN # 11  (INTEGER EDITS) 
C 
C*********************************************************************
C 
C 
C  MAXIMUM VALUE *  CHECK INTEGER OR BLANK
C 
1200  NOF=1 
      IF(JPAR(KFORM,ITLOG,NOF,JOUT,6,IFLG,JVAL)) GO TO 3000 
      IFLG1=IFLG
      IF(IFLG.EQ.0)       GO TO 1201
      IF(IFLG.NE.1)       GO TO 1281
      XMAX=JVAL 
1201  CALL MOVCA(JOUT,1,JFORM,(49+(IQST-1)*JBYTES),6) 
C 
C  MINIMUM VALUE  * CHECK INTEGER OR BLANK * MAX > MIN *
C 
      NOF=NOF+1 
      IF(JPAR(KFORM,ITLOG,NOF,JOUT,6,IFLG,JVAL)) GO TO 3000 
      IFLG2=IFLG
      IF(IFLG.EQ.0)       GO TO 1202
      IF(IFLG.NE.1)       GO TO 1282
      XMIN=JVAL 
      IF(IFLG1.EQ.0)      GO TO 1202
      IF(XMIN.GE.XMAX)    GO TO 1283
1202  CALL MOVCA(JOUT,1,JFORM,(55+(IQST-1)*JBYTES),6) 
C 
C-----GET DEFAULT ANSWER
C 
      NOF=NOF+1 
      IF(JPAR(KFORM,ITLOG,NOF,JOUT,6,IFLG,JVAL)) GO TO 3000 
      XDEFLT=0
      IF(IFLG.EQ.0)       GO TO 1205
      IF(IFLG.NE.1)       GO TO 1284
      XDEFLT=JVAL 
1205  IF(IFLG1.EQ.0)      GO TO 1207
      IF(XDEFLT.LE.XMAX)  GO TO 1207
      IF(ISTAT1.EQ.1)     GO TO 1207
      ISTAT1=1
      GO TO 1285
1207  IF(IFLG2.EQ.0)      GO TO 1210
      IF(XDEFLT.GE.XMIN)  GO TO 1210
      IF(ISTAT2.EQ.1)     GO TO 1210
      ISTAT2=1
      GO TO 1285
1210  CALL MOVCA(JOUT,1,JFORM,(61+(IQST-1)*JBYTES),6) 
      GO TO 1430
C 
C  ERROR PROCESSING SCREEN 12 
C 
1184  CALL MES05(1,NOF) 
      GO TO 15
1280  CALL MES05(2,NOF) 
      GO TO 15
1281  CALL MES05(8,NOF) 
      GO TO 15
1282  CALL MES05(9,NOF) 
      GO TO 15
1283  NOF=NOF-1 
      CALL MES05(10,NOF)
      GO TO 15
C     "ILLEGAL CHARACTER INPUT" 
1284  CALL MES05(7,NOF) 
      GO TO 15
C     "WARNING : DEFAULT VALUE OUTSIDE OF LIMITS" 
1285  NOF=3 
      CALL WARN(0,0)
      GO TO 15
C 
C*********************************************************************
C 
C  SCREEN 12   ( REAL EDITS ) 
C 
C*********************************************************************
C 
C 
C  MAXIMUM VALUE  * MUST BE REAL *
C 
1300  NOF=1 
      XMAX=0
      XMIN=0
      XDEFLT=0
      IF(JPAR(KFORM,ITLOG,NOF,JOUT,14,IFLG,JVAL)) GO TO 3000
      IFLG3=IFLG
      IF(IFLG.EQ.0)       GO TO 1302
      IF(RNUM(JOUT,1,14,XMAX)) GO TO 1281 
      CALL CODE 
      READ(JOUT,*) XMAX 
1302  CALL MOVCA(JOUT,1,JFORM,(49+(IQST-1)*JBYTES),14)
C 
C  MINIMUM VALUE  * MUST BE REAL . MAX > MIN *
C 
      NOF=NOF+1 
      IF(JPAR(KFORM,ITLOG,NOF,JOUT,14,IFLG,JVAL)) GO TO 3000
      IFLG4=IFLG
      IF(IFLG.EQ.0)       GO TO 1304
1303  IF(RNUM(JOUT,1,14,XMIN)) GO TO 1282 
      CALL CODE 
      READ(JOUT,*) XMIN 
      IF(IFLG3.EQ.0)      GO TO 1304
      IF(XMIN.GE.XMAX)    GO TO 1283
1304  CALL MOVCA(JOUT,1,JFORM,(63+(IQST-1)*JBYTES),14)
C 
C--GET DEFAULT ANSWER 
C 
      NOF=NOF+1 
      IF(JPAR(KFORM,ITLOG,NOF,JOUT,14,IFLG,JVAL)) GO TO 3000
      XDEFLT=0
      IF(IFLG.EQ.0) GO TO 1305
      IF(RNUM(JOUT,1,14,XDEFLT)) GO TO 1284 
      CALL CODE 
      READ(JOUT,*) XDEFLT 
1305  IF(IFLG3.EQ.0)      GO TO 1306
      IF(XDEFLT.LE.XMAX)  GO TO 1306
      IF(ISTAT3.EQ.1)     GO TO 1306
      ISTAT3=1
      GO TO 1285
1306  IF(IFLG4.EQ.0)      GO TO 1310
      IF(XDEFLT.GE.XMIN)  GO TO 1310
      IF(ISTAT4.EQ.1)     GO TO 1310
      ISTAT4=1
      GO TO 1285
1310  CALL MOVCA(JOUT,1,JFORM,(77+(IQST-1)*JBYTES),14)
      GO TO 1430
C 
C*********************************************************************
C 
C  SCREEN 13   (STRING EDITS) 
C 
C*********************************************************************
C 
C 
C  MAXIMUM STRING LENGTH  * INTEGER  1<= LENGTH <=126 * 
C  STRING LENGTH FOR DATA BASE ITEM CANNOT BE MODIFIED
C 
1400  NOF=1 
      IF(JPAR(KFORM,ITLOG,NOF,JOUT,3,IFLG,JVAL)) GO TO 3000 
      JVAL1=JVAL
      IF(IFLG.NE.1) GO TO 1480
      IF((JVAL.LT.1).OR.(JVAL.GT.126)) GO TO 1480 
      IF(IGET1(JFORM,1+(IQST-1)*JBYTES).NE.2HD ) GO TO 1402 
      IF(JFORM(25+(IQST-1)*JWORDS).NE.JVAL) GO TO 1488
1402  JFORM(25+(IQST-1)*JWORDS)=JVAL
      IF(LNCAR(JFORM,(72+(IQST-1)*JBYTES),20).GT.JVAL1)  GO TO 1486 
C 
C  STRING POSITIONING   * R OR L  DEFAULT IS L *
C 
1404  NOF=NOF+1 
      IF(JPAR(KFORM,ITLOG,NOF,JOUT,1,IFLG,JVAL)) GO TO 3000 
      IF(IFLG.EQ.0) JOUT(1)=2HL 
      IF((JOUT(1).NE.2HR ).AND.(JOUT(1).NE.2HL )) GO TO 1481
      ILR=JOUT
      CALL MOVCA(JOUT,1,JFORM,(51+(IQST-1)*JBYTES),1) 
C 
C  STRING MASK
C 
      NOF=NOF+1 
      IF(JPAR(KFORM,ITLOG,NOF,JOUT,20,IFLG,JVAL)) GO TO 3000
      IF(IFLG.EQ.0) GO TO 1408
      IL=LNCAR(JOUT,1,20) 
C    -LEFT OR RIGHT JUSTIFIED?
      IF(ILR.EQ.2HR ) GO TO 1406
C    -LEFT JUSTIFIED, THEREFORE, ERR IF LEADING BLANKS. 
      IF(IGET1(JOUT,1).EQ.1H ) GO TO 1478 
      IF(IL.GT.JVAL1) GO TO 1485
      GO TO 1408
C    -RIGHT JUSTIFIED, MASK MUST BE RIGHT JUSTIFIED.
1406  IF(IL.GT.JVAL1) GO TO 1485
      IF(IL.NE.JVAL1) GO TO 1479
1408  CALL MOVCA(JOUT,1,JFORM,(52+(IQST-1)*JBYTES),20)
C 
C-----GET DEFAULT ANSWER: 
C         1. CHECK DEFAULT ANS NOT LONGER THAN MAX STRING LENGTH
C         2. CHECK THAT MASK ISN'T LONGER THAN DEFAULT ANS. 
C 
      NOF=NOF+1 
      IF (JPAR(KFORM,ITLOG,NOF,JOUT,20,IFLG,JVAL)) GO TO 3000 
      IL=LNCAR(JOUT,1,20) 
      IF(IL.GT.JVAL1) GO TO 1486
      IF(LNCAR(JFORM,52+(IQST-1)*JBYTES,20).GT.JVAL1) GO TO 1485
      CALL MOVCA(JOUT,1,JFORM,(72+(IQST-1)*JBYTES),20)
      GO TO 1435
C 
C********************************************************************** 
C 
C  ARITHMETIC OPERATORS (SCREENS 11/12) 
C 
C********************************************************************** 
C 
C   CHECK ANSWER IS BLANK OR X . IF X CHECK ARITH OPERATORS HAVE BEEN 
C   DEFINED AS SFK'S
C 
1430  NOF=NOF+1 
      IF(JPAR(KFORM,ITLOG,NOF,JOUT,1,IFLG,JVAL)) GO TO 3000 
C-----IF CARD INPUT, ARITHMETIC OPERATIONS NOT ALLOWED. 
      IF(ICARD.EQ.0) GO TO 1431 
      IF(IFLG.NE.0) GO TO 1498
1431  IF((IFLG.NE.0).AND.(JOUT(1).NE.2HX )) GO TO 1184
      IF(IFLG.EQ.0) GO TO 1434
      DO 1432 I=1,11
      DO 1432 J=1,3,2 
      IF(IKEY(I,J).EQ.9) GO TO 1434 
1432  CONTINUE
      GO TO 1482
1434  IF(ISCRN.EQ.12) N=67
      IF(ISCRN.EQ.13) N=91
      CALL MOVCA(JOUT,1,JFORM,(N+(IQST-1)*JBYTES),1)
C 
C*********************************************************************
C 
C  NEXT ENTRY IN AN IMAGE CHAIN ? (TR. TYPE > 1)
C 
C*********************************************************************
C 
C  CHECK ANSWER IS BLANK OR X . IF X CHECK NEXT ENTRY HAS BEEN DEFINED
C  AND CHECK FIND IN DETAIL DATA SET DEFINED TOO .
C 
1435  IF(.NOT.ISBIT(ITT,1)) GO TO 1438
      NOF=NOF+1 
      IF(JPAR(KFORM,ITLOG,NOF,JOUT,1,IFLG,JVAL)) GO TO 3000 
C-----IF CARD INPUT, NEXT ENTRY IN AN IMAGE CHAIN IS NOT ALLOWED. 
      IF(ICARD.EQ.0) GO TO 14351
      IF(IFLG.NE.0) GO TO 1498
14351 IF((IFLG.NE.0).AND.(JOUT(1).NE.2HX )) GO TO 1184
      IF(IFLG.EQ.0) GO TO 1438
C-----'NEXT ENTRY' FOR ITEM TYPE S,I,R NOT ALLOWED. 
      IARG=IGET1(JFORM,1+(IQST-1)*JBYTES) 
      IF((IARG.EQ.2HS ).OR.(IARG.EQ.2HI ).OR.(IARG.EQ.2HR )) GO TO 1497 
      DO 1436 I=1,11
      DO 1436 J=1,3,2 
      IF(IKEY(I,J).EQ.12) GO TO 1437
1436  CONTINUE
      GO TO 1483
1437  IF(IMDT.EQ.0) GO TO 1487
      IF(IQST.LE.IUMAX) GO TO 1489
1438  IF(ISCRN.EQ.12) N=68
      IF(ISCRN.EQ.13) N=92
      IF(ISCRN.EQ.14) N=92
      CALL MOVCA(JOUT,1,JFORM,(N+(IQST-1)*JBYTES),1)
      IF(.NOT.ISBIT(ITT,1)) CALL BLAN(JFORM,N+(IQST-1)*JBYTES,1)
C 
C*********************************************************************
C 
C  USER EDIT SUBROUTINE (TR. TYPE 1/3 ONLY) 
C 
C*********************************************************************
C 
1440  IF(.NOT.ISBIT(ITT,0)) GO TO 1444
      NOF=NOF+1 
      IF(JPAR(KFORM,ITLOG,NOF,JOUT,5,IFLG,JVAL)) GO TO 3000 
      IF(IFLG.EQ.0) GO TO 1444
      IF(NAMCK(JOUT)) GO TO 1476
1444  IF(ISCRN.EQ.12) N=69
      IF(ISCRN.EQ.13) N=93
      IF(ISCRN.EQ.14) N=93
      CALL MOVCA(JOUT,1,JFORM,(N+(IQST-1)*JBYTES),5)
      IF(.NOT.ISBIT(ITT,0)) CALL BLAN(JFORM,N+(IQST-1)*JBYTES,5)
      GO TO 1630
C 
C  ERROR PROCESSING SCREENS(12/13/14) 
C 
C    -"ILLEGAL FILE NAME" 
1476  CALL MES05(28,NOF)
      GO TO 15
C    -"MASK MUST BE LEFT JUSTIFIED" 
1478  CALL MES05(26,NOF)
      GO TO 15
C    -"MASK MUST BE RIGHT JUSTIFIED"
1479  CALL MES05(27,NOF)
      GO TO 15
1480  CALL MES05(3,NOF) 
      GO TO 15
1481  CALL MES05(4,NOF) 
      GO TO 15
1482  CALL MES05(5,NOF) 
      GO TO 15
1483  CALL MES05(6,NOF) 
      GO TO 15
1485  CALL MES05(12,NOF)
      GO TO 15
1486  CALL MES05(13,NOF)
      GO TO 15
1487  CALL MES05(14,NOF)
      GO TO 15
1488  CALL MES05(11,NOF)
      GO TO 15
1489  CALL MES05(15,NOF)
      GO TO 15
C-----"TOO MANY CHARACTERS HAVE BEEN SPECIFIED FOR THIS CARD" 
1490  CALL MES05(16,1)
      GO TO 15
C-----"IMAGE CARD INPUT--USER WRITTEN MODULE REQUIRED"
1491  CALL MES05(17,NOF)
      GO TO 15
C-----"IMAGE CARD INPUT--STRING LENGTH MUST BE EVEN"
1492  CALL MES05(18,NOF)
      GO TO 15
C-----"IMAGE CARD INPUT--'R' IS ILLEGAL"
1493  CALL MES05(19,NOF)
      GO TO 15
C-----"IMAGE CARD INPUT--MASK NOT ALLOWED"
1494  CALL MES05(20,NOF)
      GO TO 15
C-----"IMAGE CARD INPUT--LIMIT CHECK NOT ALLOWED" 
1495  CALL MES05(21,NOF)
      GO TO 15
C-----"IMAGE CARD INPUT--NOT ALLOWED" 
1496  CALL MES05(22,NOF)
      GO TO 15
C-----"NOT ALLOWED" 
1497  CALL MES05(23,NOF)
      GO TO 15
C-----"NOT ALLOWED WITH CARD READER INPUT"
1498  CALL MES05(24,NOF)
      GO TO 15
C 
C-----BEFORE CALLING NEXT SCREEN, VERIFY THAT IF INPUT IS FROM CARD,
C     THE MAX LENGTH OF THE CARD HAS NOT BEEN EXCEEDED. 
C 
1630  INDEX=0 
      IBYTES=0
C 
C*********************************************************************
C 
C  CALL DISPLAY INFORMATION SCREEN OR PASS TO THE NEXT QUESTION ? 
C 
C*********************************************************************
C 
C  DISPLAY SCREEN * 
C 
1515  I=IGET1(JFORM,(2+(IQST-1)*JBYTES))
      IF(I.NE.2HX ) GO TO 1099
      ISCRN=16
      GO TO 1002
C 
C  NEXT QUESTION
C 
1099  IQST=IQST+1 
      IF(IQST.GT.(IUMAX+IMMAX)) GO TO 1632
      ISCRN=11
      GO TO 1000
1632  ISCRN=17
      GO TO 1002
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 MES05(7,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 
      ILST=0
      IF(ISCRN.NE.12) GO TO 3008
      IF(.NOT.ISBIT(ITT,1)) IMES=IHP20(NOF) 
      IF(ISBIT(ITT,1)) IMES=IHP21(NOF)
      IF((.NOT.ISBIT(ITT,0)).AND.(.NOT.ISBIT(ITT,1)).AND.(NOF.EQ.4))
     *   ILST=1 
      IF((ISBIT(ITT,1)).AND.(.NOT.ISBIT(ITT,0)).AND.(NOF.EQ.5)) ILST=1
      GO TO 3060
3008  IF(ISCRN.NE.13) GO TO 3009
      IF(.NOT.ISBIT(ITT,1)) IMES=IHP30(NOF) 
      IF(ISBIT(ITT,1)) IMES=IHP31(NOF)
      IF((.NOT.ISBIT(ITT,0)).AND.(.NOT.ISBIT(ITT,1)).AND.(NOF.EQ.3))
     *   ILST=1 
      IF((ISBIT(ITT,1)).AND.(.NOT.ISBIT(ITT,0)).AND.(NOF.EQ.4)) ILST=1
      GO TO 3060
3009  IF(.NOT.ISBIT(ITT,1)) IMES=IHP40(NOF) 
      IF(ISBIT(ITT,1)) IMES=IHP41(NOF)
      IF((ISBIT(ITT,1)).AND.(.NOT.ISBIT(ITT,0)).AND.(NOF.EQ.4)) ILST=1
3060  CALL HLP05(IMES,NOF,ILST) 
      GO TO 15
C 
C  IFLG=8 MEANS LAST SCREEN 
C 
3010  IF(IFLG.NE.8) GO TO 3040
      IF(IGET1(JFORM,(5+(IQST-1)*JBYTES)).EQ.1HX) GO TO 3013
        ISCRN=11
        CALL EXEC(8,JNAM) 
3013  ISCRN=91
      CALL EXEC(8,KNAM) 
C 
C  CALL NEXT SCREEN 
C 
1000  CALL EXEC(8,JNAM) 
1002  CALL EXEC(8,KNAM) 
C 
C  ABORT PROGRAM
C 
3040  IF(.NOT.(OKABT(ILU))) GO TO 17
      INDIC=99
      CALL EXEC(8,LNAM) 
C 
C  END OF SEGMENT 
C 
      CALL TGP
C 
C 
      END 
      END$