FTN4
      SUBROUTINE ZTMP, 92903-16510 REV.1913  790203 
C 
C 
C     NAME:   ZTMP
C     SOURCE: &ZTMP'    92903-18510 
C     BINARY: %ZTMP'    92903-16510    PART OF  %ZTMP  92903-16510
C 
C     PMGR:   FRANCOIS GAULLIER 
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     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: ZTMP IS THE MAIN T.U.S. OF THE  TMP
C                   (TRANSACTION MONITOR PROGRAM) 
C 
C 
C**********************************************  F. GAULLIER  (HPG)  ***
C 
C 
      INTEGER TSMG(3),OFLPO(3),STORAG(3),ERRFL,FORMN,SQUAL,FMGST
     .,DITMTP,DITMLN,DOBUPT,STATPT,EDITPT,STCNT,FLDCNT,DEFVA
     .,STATE,STATLN,OUTLEN,OBUF,OBUFPT,OBULN,OBULNX,FORWJN
     .,BKSQ,BKIN,BKJN,FAF,IMGFLG,FAFRTB,XRTB,ENDCHN,CALCBU
     .,IMGSTA(4),TEMPB(256),CRBUF,PRTBUF(13),LFLF(5)
     .,LOGHD(8),LOGACK(4),JTMLN,JTMTP,JOBUP,EQUIVX(3) 
     .,BUFULL,OUTBUF,OUTDEV,ERRBF(3),ZERO(2),COLCNT 
D    .,ITEMPX(25) 
C 
C***   DEFINE LOGICAL FLAGS 
C 
      LOGICAL BEGNFL,BKSFL,BKSIP,WAITC,CALCFL,CALCIP,DEFKB
     .       ,FORWIP,TEMPL,M14,DDSPV
D    .       ,QXY 
C 
C***   DEFINE LOGICAL FUNCTIONS 
C 
      LOGICAL INUM,FEDIT,VEDIT,VALCK,USFKV,CNVTI,ICNVT,CALCU,ENDBK
     .        ,BKSEN,DOBKS,ENDMQ,CMPW,ISNUL,ISBIT,KBINP,ONLPR 
     .        ,ISBTW,TMSIF,JULIB
C 
C 
C***   TRUE COMMON
C 
      COMMON ICOM00(5)
C 
C***   1ST COMMON BLOCK 
C 
      COMMON LU,ICTLB,ITYP,IST,ITL,IMAGEX(8),ISAVRT(6)
     .      ,IOMODL(3),ERRFL,EDITPT,IFC,IOMTMP(2),ITSN,ITSSTP,ITIM0(6)
     .      ,LITE1,LITE2,OUTDEV,INPDEV,ITSNAM(5),OUTLEN,OUTBUF(40)
C 
C***   2ND COMMON BLOCK 
C 
      COMMON NUQ,NMQ,STATPT,INDEX,OBULN,L1,L2,OBUF(250) 
C 
C***   3RD COMMON BLOCK 
C 
      COMMON FORMN,SQUAL,JNDEX,FMGST,STATLN,STATE(80) 
C 
      COMMON INPLEN,INPBUF(100) 
C 
      COMMON ITEMTP,ITEMLN,OBUFPT,DITMTP,DITMLN,DOBUPT
     .      ,CRBUF(40),FLDCNT,STCNT,DEFKB,COLCNT
     .      ,IERTN,ITT,KEYN,INLNGT,INPSTA,INPITL,IMAGPT 
     .      ,BEGNFL,BKSFL,BKIN,BKJN,BKSIP,BKSQ,FORWIP,FORWJN
     .      ,WAITC,BUFULL,ENDCHN,CALCFL,CALCIP,CALCBU(4),FAF,IMGFLG 
     .      ,IDBNUM,LSTCLC
C 
C***   4TH COMMON BLOCK 
C 
      COMMON IUSER(21)
C 
C***   5TH COMMON BLOCK 
C 
      COMMON FAFRTB(6),XRTB(6,20),IMGBUF(256) 
C 
C***   LAST COMMON WORD 
C 
      COMMON ICOMEN 
C 
      EQUIVALENCE (CALCBU,IMECD)
     .           ,(JTMTP,EQUIVX(1)),(JTMLN,EQUIVX(2)) 
     .           ,(JOBUP,EQUIVX(3)) 
     .           ,(ISTATS,ITSNAM(1)),(ITRNLG,ITSNAM(2)) 
     .           ,(ISFK1,ITSNAM(3)) 
      EQUIVALENCE (IFEATR,INPBUF(1))
     .           ,(LUOXXX,ICOM00(1))
C 
      DATA OBULNX/250/
      DATA TSMG/2HTS,2HMG,2H  / 
     .    ,OFLPO/2HOF,2HLP,2HO /
      DATA STORAG/2HST,2HOR,2HA / 
      DATA LITERR/100000B/,LITTCP/100400B/,ZERO/2*0/
      DATA PRTBUF/2*20015B,2H**,2H**,2H* ,2HT.,2H  ,2H  ,2H  ,2H *
     .,2H**,2H**,6440B/ 
      DATA LFLF/5*6440B/,ERRBF/2H--,2H  ,2H--/
      DATA LOGHD/2HTM,2HP ,2H  ,2H  ,2H  ,2H  ,2H  ,2H  / 
      DATA LOGACK/77407B,20007B,20007B,20007B/
C 
C-----EXPLANATION OF VARIABLE NAME: 
C     ----------------------------- 
C 
C     ITEMTP, ITEMLN, OBUFPT   )       ITEM CHARACTERISTIC, TYPE, LEN,
C     DITMTP, DITMLN, DOBUPT   )                   ADDR. IN 'OBUF'
C     JTMTP,  JTMLN,  JOBUP    )    (MUST BE CONSECUTIVES WORDS IN MEMORY)
C 
C     FLAGS:
C     ------
C 
C   ERRFL   INTEG.   ERROR FLAG   (0 = NO ERROR)
C   IMGFLG  INTEG.   IMAGE USE IN THIS TS   (0 = NO IMAGE)
C   BUFULL  INTEG.   OUTPUT BUFFER 'OBUF' OVERFLOW  (0 = NO OVERFLOW) 
C   FAF     INTEG.   FAF STATE  (0 = NO FAF STATE FOUND YET)
C                               (1 = FAF STATE HAS BEEN PASSED FORWARD) 
C                               (2 = FAF STATE HAS BEEN PASSED WHEN BACKSP.)
C   ENDCHN  INTEG.   END OF CHAIN IN CHAINED DBGET CALL 
C                               (32767 = NO END OF CHAIN REACHED YET) 
C                               (32766 = 1ST RECORD OF THE CHAIN READ FOR 
C                                        TOTAL PURPOSE) 
C                               (N = END OF CHAIN HAS BEEN REACHED AT LINE
C                                        INDEX = N-1) 
C 
C   BEGNFL  LOGIC.   FIRST TIME TS IS EXECUTED (TRUE = 1ST TIME)
C   BKSFL   LOGIC.   BACKSPACE IN THE TS  (TRUE = RECALL HAS BEEN USED) 
C   BKSIP   LOGIC.   BACKSPACE IN PROCESS (TRUE = RECALL WAS THE LAST ANSWER) 
C   FORWIP  LOGIC.   FORWARD ADVANCE IN THE TS (TRUE = SKIP TERMINAL I/O) 
C   WAITC   LOGIC.   WAIT FOR TS COMPLETE (TRUE = ACCEPT ONLY TRANS. COMPL.)
C   DEFKB   LOGIC.   CURRENT INPUT IS FROM KBD INSTEAD OF CARD. 
C                               (TRUE = DEFAULTED TO KBD) 
C 
C 
C     VARIABLES:
C     ----------
C 
C   INDEX   INTEG.   LINE INDEX, 1 FOR U-QUESTION, 1 FOR 1ST LINE OF M-QUES., 
C                                2 FOR 2ND LINE OF M-QUES., ....
C   JNDEX   INTEG.   COLUMN INDEX, 1 FOR 1ST U OR M-QUES., 2 FOR 2ND U OR 
C                                M-QUES., ... 
C   SQUAL   INTEG.   STATE QUALIFIER, 0 FOR SFK DEFINITON 
C                                     1 FOR U-QUESTION
C                                     2 FOR M-QUESTION
C                                     3 FOR STORAGE DEFINITION ...
C   BKIN    INTEG.   )   KEEP THE STATE WHERE RECALL FUNCTION HAS BEEN USED 
C   BKJN    INTEG.   )        FOR THE 1ST TIME (LINE INDEX, COLUMN INDEX, 
C   BKSQ    INTEG.   )        STATE QUALFIER) 
C   STCNT   INTEG.   COUNT STATE FROM THE BEGINNING OF A CARD INPUT TO BACK 
C                       THE 1ST QUESTION OF THE CARD WHEN ERROR IS DETECTED 
C   IDBNUM  INTEG.   DATA BASE IDENTIFIER, REQUIRED IN ALL TBXXX CALLS. 
C 
C-----I/O MODULE INTERFACE VARIABLES
C 
C     IFC --> THE FUNCTION CODE FOR CHOOSING THE I/O MODULE 
C                FUNCTION.  N.B.  IFC MUST BE 1,2,3,4, OR 5!
C 
C     LITE1 --> HI AND LO BYTES CONTAIN LOGICAL NUMBERS FOR 
C                  PROMPTING LIGHTS TO BE LIT. (QUEST. LIGTH - DISPLAY LIGHT) 
C 
C     LITE2 --> HI AND LO BYTES CONTAIN LOGICAL NUMBERS FOR 
C                  PROMPTING LIGHTS TO BE LIT. (ERROR LIGHT  - TR. COMP. LI)
C 
C     OUTDEV --> OUTPUT DEVICE WORD.  DESCRIBES THE DEVICE TO 
C                   WHICH OUTPUT FROM TMP WILL BE WRITTEN. BITS 
C                   15, 1, AND 0 ARE THE POWER FAIL, PRINTER AND
C                   DISPLAY BITS, RESPECTIVELY. 
C 
C     INPDEV --> INPUT DEVICE WORD.  HI BYTE CONTAINS THE INPUT 
C                  DESCRIPTION--LO BYTE CONTAINS THE INPUT DEVICE 
C                  DESCRIPTION. 
C 
C     ITSNAM --> TS#-SC BUFFER.  FOR IFC=1,2 -- THE FORMAT OF ITSNAM
C                   IS AS FOLLOWS:
C                                   WORD 1 = 100000B
C                                   WORD 2 IS NOT USED
C                                   WORD 3 IS NOT USED
C                                   WORD 4 = TS#
C                                   WORD 5 = SC 
C 
C                    FOR IFC=4, THE FORMAT IS AS FOLLOWS: 
C 
C                                   WORD 1 IS NOT USED
C                                   WORD 2 IS NOT USED
C                          ISFK1 -- WORD 3 = SFK DEFINITION WORD #1 
C                                              (FOR SFK'S 1-16) 
C                          ISFK2 -- WORD 4 = SFK DEFINITION WORD #2 
C                                              (FOR SFK'S 17-32)
C 
C                    FOR IFC=5, THE FORMAT IS AS FOLLOWS: 
C 
C                         ISTATS -- WORD 1 = I/O MODULE COMPLETION STATUS 
C                         ITRNLG -- WORD 2 = I/O MODULE TRANS. LOG
C                                   WORD 3 = SFK DEFINITION (1-16)
C                                   WORD 4 = SFK DEFINTION (17-32)
C                                   WORD 5 IS NOT USED
C 
C     OUTLEN --> LENGTH IN BYTES OF THE INFORMATION TO BE WRITTEN 
C                   TO THE TERMINAL (LENGTH IN BYTES OF INFO. IN 'OUTBUF')
C 
C     OUTBUF --> BUFFER OF INFORMATION TO BE WRITTEN TO TERMINAL. 
C 
C     INPLEN -- LENGTH IN BYTES OF INFORMATION EXPECTED IN 'INPBUF'.
C 
C     INPBUF -- BUFFER OF INFORMATION READ FROM THE DATA-CAPTURE TERMINAL.
C                  N.B.  FOR IFC=3, INPBUF(1) IS THE 'REQUIRED TERMINAL 
C                        FEATURES WORD'.  IT IS EQUIV'D 'IFEATR'. 
C 
C 
C 
C 
C-----DEFINE LOCAL FUNCTION 
C 
      IRS12(M0)=IAND(IALF2(M0),360B)/16 
      LIGHN(M1)=IRS12(STATE(M1))*256
      IRS8(M2)=IAND(IALF2(M2),377B) 
      ITML(M5)=IAND(STATE(M5),7760B)/16 
      ITMT(M8)=IAND(STATE(M8),17B)
      IPT(M6,M7)=IAND(STATE(M7+1),7777B)+(M6-1)*L2
      IMPT(M8)=OBULN-M8*6*IMGFLG
      ENDBK(M9)=BKSEN(BKSFL,FAF,SQUAL,INDEX,JNDEX,BKSQ,BKIN,BKJN) 
      KBINP(M10)=IAND(STATE(4),37B).EQ.0
      ICNVT(M11)=CNVTI(ITEMTP,TEMPB,INLNGT,INPBUF)
      ONLPR(M13)=.NOT. ISBIT(STATE(2),14) 
      VALCK(M14)=VEDIT(M14,ITEMTP,STATE(EDITPT),INPBUF,K) 
C 
C 
C-----SWAP JUST THE PROGRAM AREA
C 
      CALL EXEC(22,2) 
C 
C------DEFINE COMMON BLOCK STRUCTURE, 
C 
      CALL TMDFN(ICOM00,LU,NUQ,FORMN,IUSER,FAFRTB,ICOMEN) 
C 
C       FROM THIS POINT, THIS PROGRAM IS REACTIVATED
C         FOR EACH INTERACTIVE DEVICE. (COMMON BLOCK # 1
C         IS ENABLED) 
C 
C 
C     CHECK TERMINAL TYPE FOR THE PROMPT
C 
      IF(ITYP .NE. 3070)  CALL TMSAB(34)
C 
C#####################################################################
D     WRITE(LUOXXX,7339)LU,ICOM00 
D7339 FORMAT("  FOR LU="I2,", CB0:"5I7) 
C#####################################################################
C 
C-----OK, IT IS A DATA-CAPTURE TERMINAL, SET UP THE RIGTH 
C     I/O MODULE NAME.
C 
      IOMODL=2HIO+100000B 
      IOMODL(2)=2HM7
      CALL EXEC(13,LU,IEQT5)
      I=0 
      J=IAND(IEQT5,37400B)/256
      IF(J .EQ. 47B)  I=2H0 
      IF(J .EQ. 07B)  I=2H5 
      IF(I .EQ. 0)   CALL TMSAB(35) 
      IOMODL(3)=I 
C 
C  GET TS# [-SC]
C 
100   CONTINUE
      IFC=1 
      OUTLEN=0
      LITE1=0 
105   LITE2=0 
      CALL TMSUB(IOMODL)
      IF(IST.EQ.0)GO TO 300 
      CALL TMSAB(36)
220   CONTINUE
      IF(ERRFL.GT.1)ERRFL=1 
      ERRBF(2)=IASC(EDITPT) 
      IFC=1 
      IF(EDITPT.EQ.1)IFC=2
      LITE1=128 
      OUTLEN=6
      IF(EDITPT.EQ.0)OUTLEN=0 
      CALL MOVEW(ERRBF,OUTBUF,3)
      GO TO 105 
C 
C------INVOKE T-M SUBROUTINE "TSMG" TO OPEN THIS FORM 
C 
  300 ASSIGN 350 TO I 
      CALL TMCBE(I,FORMN) 
      SQUAL=10
      JNDEX=LU
      CALL MOVEW(ITSNAM,STATE,5)
DDD   CALL DMPZ(ICOM00,5,22HCB0 BEFORE TMSUB (300),-22) 
DDD   CALL DMPZ(LU,84,3HCB1,3)
DDD   CALL DMPZ(NUQ,257,3HCB2,3)
DDD   CALL DMPZ(FORMN,266,3HCB3,3)
DDD   CALL DMPZ(STATE,80,6H*STATE,6)
DDD   CALL DMPZ(IUSER,21,3HCB4,3) 
DDD   CALL DMPZ(FAFRTB,382,3HCB5,3) 
      CALL TMSUB(TSMG)
DDD   CALL DMPZ(ICOM00,5,22HCB0 AFTER  TMSUB (300),-22) 
DDD   CALL DMPZ(LU,84,3HCB1,3)
DDD   CALL DMPZ(NUQ,257,3HCB2,3)
DDD   CALL DMPZ(FORMN,266,3HCB3,3)
DDD   CALL DMPZ(STATE,80,6H*STATE,6)
DDD   CALL DMPZ(IUSER,21,3HCB4,3) 
DDD   CALL DMPZ(FAFRTB,382,3HCB5,3) 
      IF(FMGST .EQ. 0)  GOTO 2000 
C-----ERROR ! 
      IF(FMGST .EQ. -1)  EDITPT=0 
      IF(FMGST .EQ. -6)  EDITPT=1 
C-----DISABLE 3RD COMMON BLOCK
      CALL TMCBD(FORMN) 
  330 ERRFL=1 
      GOTO 220
C 
C-----COMMON BLOCK ENABLE HAS FAILED, ERROR # 40
C 
  340 CALL TMCBD(FORMN) 
  350 EDITPT=40 
      GOTO 330
C 
C-----RETURN FROM THE FORM PROCESSOR IS HERE: 
C 
  400 IF( ERRFL .EQ. 0 )  GOTO 100
      EDITPT=ERRFL
      GOTO 220
C 
C 
C***********************************************************************
C***********************************************************************
C 
C 
C     THIS PART OF CODE IS THE:  FORM PROCESSOR.
C     ==========================================
C 
C     THE FORM IS OPEN
C 
 2000 ASSIGN 4250 TO IERTN
      CALL NUL(ITIM0,6) 
      ITSN=FORMN
      ITSSTP=0
      CALL LOGEV(ICOM00(2),LU,0,0,ITSN,ITIM0) 
C-----ENABLE 2ND COMMON BLOCK 
      ASSIGN 340 TO I 
      CALL TMCBE(I,NUQ) 
C-----SET THE STOP-INHIBIT FLAG TO DISALLOW STOP OF THE TMP 
      ERRFL=20
      IF( TMSIF(1) )  GOTO 4233 
C-----INIT FORM PROCESSOR CONSTANTS 
      NUQ=IRS8(STATE(6))
      NMQ=IAND(STATE(6),377B) 
      L1=STATE(7) 
      L2=STATE(8) 
      ITT=STATE(10) 
      IFEATR=IAND(STATE(10),000777B)
C-----CHECK TERMINAL FEATURES 
      ERRFL =30 
      IFC=3 
      CALL TMSUB(IOMODL)
      IF(ISTATS.NE.0)GO TO 4233 
 2004 ASSIGN 4233 TO I
      ERRFL =40 
      IF( ISBIT(ITT,0) )  CALL TMCBE(I,IUSER) 
C-----INIT FORM PROCESSOR FLAGS & VARIABLES 
      IMGFLG=0
      IDBNUM=0
      BEGNFL=.TRUE. 
      ENDCHN=32767
      ERRFL=0 
      SQUAL=0 
      BUFULL=0
      STCNT=0 
C 
C-----CHECK IF IMAGE/1000 IS ACCESS FROM THIS TS
C 
      IF( .NOT. ISBIT(ITT,1) )  GOTO 2050 
      ASSIGN 4231 TO I
      ERRFL=40
      CALL TMCBE(I,FAFRTB)
      IMGFLG=1
      ERRFL=0 
      STATE(19)=0 
      CALL TBOPN(STATE(19),0,0,IMGSTA)
DDD   CALL DMPZ(ICOM00,5,15HCB0 AFTER TBOPN,-15)
DDD   CALL DMPZ(LU,84,3HCB1,3)
DDD   CALL DMPZ(NUQ,257,3HCB2,3)
DDD   CALL DMPZ(FORMN,265,3HCB3,3)
DDD   CALL DMPZ(IUSER,21,3HCB4,3) 
DDD   CALL DMPZ(FAFRTB,382,3HCB5,3) 
      IF(IMGSTA .NE. 0)  PAUSE 0120 
      IDBNUM=STATE(19)
 2020 DO 2025 I=1,20
 2025 XRTB(3,I)=32767 
      CALL TBULK(IDBNUM)
 2050 BKSFL =.FALSE.
      BKSIP =.FALSE.
      FORWIP=.FALSE.
      WAITC =.FALSE.
      CALCFL=.FALSE.
      CALCIP=.FALSE.
      DEFKB =.FALSE.
      IF(FAF .NE. 0)  FAF=1 
C 
C-----SETUP LINE INDEX FOR THE STATE
C 
 2100 INDEX=1 
      IF(SQUAL .NE. 1)  GOTO 2200 
C 
C-----SETUP SYSTEM PROVIDED DATA  (TR. ID - LU # - DATE - TIME) 
C 
      L=1 
      IF(.NOT. ISBIT(ITT,15) )  GOTO 2170 
      CALL JASC(FORMN,OBUF(L),-1,4) 
      L=L+2 
 2170 IF(.NOT. ISBIT(ITT,14) )  GOTO 2175 
      OBUF(L)=IASC(LU)
      L=L+1 
 2175 CALL EXEC(11,TEMPB,I) 
      IF  ( JULIB(TEMPB(5),I,N,J) ) 
     .               CALL TMPER(IERTN,49,FORMN,LU,107,0)
      IF(.NOT. ISBIT(ITT,13) )  GOTO 2180 
      OBUF(L)=IASC(I-1900)
      OBUF(L+1)=IASC(J) 
      OBUF(L+2)=IASC(N) 
      L=L+3 
 2180 IF(.NOT. ISBIT(ITT,12) )  GOTO 2185 
      OBUF(L)=IASC(TEMPB(4))
      OBUF(L+1)=IASC(TEMPB(3))
C 
C-----CHECK FOR ONLINE PRINTOUT -- IF SO, PRINT HEADER
C 
 2185 IF( .NOT. ISBIT(ITT,8) )  GOTO 2200 
      CALL CNUMD(FORMN,PRTBUF(7)) 
      CALL MOVEW(PRTBUF,OUTBUF,13)
      CALL BLANC(OUTBUF(14),20) 
      OUTBUF(18)=IASC(LU) 
      OUTBUF(20)=20015B 
      OUTBUF(22)=IASC(I-1900) 
      OUTBUF(23)=IASC(J)
      OUTBUF(24)=IASC(N)
      OUTBUF(27)=IASC(TEMPB(4)) 
      OUTBUF(28)=2H:
      CALL JASC(TEMPB(3),OUTBUF(28),-2,2) 
      OUTBUF(30)=6440B
      OUTLEN=60 
      INPLEN=0
      OUTDEV=2
      IFC=5 
      CALL TMSUB(IOMODL)
C 
C-----SETUP THE RIGHT STATE, (STATE QUAL., JNDEX AND INDEX) 
C 
 2200 JNDEX=1 
 2300 IF (SQUAL.EQ.0 .AND. JNDEX.EQ.INDEX+1) GOTO 2400
      IF (SQUAL.EQ.1 .AND. JNDEX.EQ.NUQ+1) GOTO 2400
      IF (SQUAL.EQ.2 .AND. JNDEX.EQ.NMQ+1) GOTO 2400
 2320 CONTINUE
DDD   CALL DMPZ(ICOM00,5,22HCB0 BEFORE TMSUB(2320),-22) 
DDD   CALL DMPZ(LU,84,3HCB1,3)
DDD   CALL DMPZ(NUQ,257,3HCB2,3)
DDD   CALL DMPZ(FORMN,266,3HCB3,3)
DDD   CALL DMPZ(STATE,80,6H*STATE,6)
DDD   CALL DMPZ(IUSER,21,3HCB4,3) 
DDD   CALL DMPZ(FAFRTB,382,3HCB5,3) 
      CALL TMSUB(TSMG)
DDD   CALL DMPZ(ICOM00,5,22HCB0 AFTER TMSUB (2320),-22) 
DDD   CALL DMPZ(LU,84,3HCB1,3)
DDD   CALL DMPZ(NUQ,257,3HCB2,3)
DDD   CALL DMPZ(FORMN,266,3HCB3,3)
DDD   CALL DMPZ(STATE,80,6H*STATE,6)
DDD   CALL DMPZ(IUSER,21,3HCB4,3) 
DDD   CALL DMPZ(FAFRTB,382,3HCB5,3) 
C-----CHECK STATUS OF FORM MANAGER
      IF(FMGST .EQ. 0)  GOTO 3000 
C-----ERROR #  -2 IS STATE WITH INDEX NOT DEFINED 
      CALL TMPER(IERTN,49,FORMN,LU,111,FMGST) 
 2400 SQUAL=SQUAL+1 
      GOTO (2100,2100,2500),SQUAL 
C-----M-QUESTION TYPE: START AT BEGINNING OF NEXT LINE
 2500 SQUAL=SQUAL-1 
      INDEX=INDEX+1 
      GOTO 2200 
C-----RETURN FROM  STATE PROCESSOR IS HERE
C     GOTO NEXT STATE.
 2600 JNDEX=JNDEX+1 
      STCNT=STCNT+1 
      GOTO 2300 
C 
C     THIS PART OF CODE IS THE:  STATE PROCESSOR. 
C     =========================================== 
C 
 3000 ITSSTP=JNDEX
      IF(SQUAL .EQ. 2)  ITSSTP=NUQ+ITSSTP+NMQ*(INDEX-1) 
      IF(SQUAL .NE. 0)  GOTO 3050 
C 
C=====STORE SFK DEFINITION INTO OUTPUT BUFFER AT THE END
C 
      IF(INDEX .NE. 1)  GOTO 3010 
C-----LEAVE ENOUGH ROOM FOR FILE STORAGE STATE DEFINITION ! 
      K=STATE(2)
      IF(K .LE. 25)  K=25 
      OBULN=OBULNX-K
      OUTLEN=OBULN
 3010 CALL MOVEW(STATE(2),OBUF(OUTLEN),STATLN-1)
      OUTLEN=OUTLEN+STATLN-1
      IF( .NOT. ISBIT(STATE,8) )  GOTO 3015 
      INDEX=INDEX+1 
      GOTO 2600 
C 
C  RESET THE DATACAPTURE TERMINAL AND ENABLE APPROPRIATE SFK'S
C 
 3015 IFC=4 
      CALL MOVEW(OBUF(OBULN+8),ISFK1,2) 
      CALL TMSUB(IOMODL)
      IFC=5 
C#################################################################
D     WRITE(LUOXXX,9820)LU
D9820 FORMAT(/," FORM LU#"I3,5X,"SFK DEFINITION:")
D     WRITE(LUOXXX,9821)(OBUF(I),I=OBULN,OBULNX)
D9821 FORMAT(8@8) 
D     WRITE(LUOXXX,9822)ITT,NUQ,NMQ,L1,L2 
D9822 FORMAT(" ITT="@7" NUQ="I4," NMQ="I4" LUQ="I5" LMQ="I5)
C#################################################################
      GOTO 2600 
C 
C-----STATE IS NOT 0   --->  EXECUTABLE STATE 
C 
 3050 IF(WAITC) GOTO 7000 
C-----RE-INIT VARIABLES 
      IF( SQUAL .EQ. 1 )   FAF=0
      IF( INDEX .EQ. 2 )   BUFULL=0 
      IF( .NOT. ISBIT(STATE,14) )  GOTO 3120
C 
C=====EXECUTE 'FAF' STATE (FIND IN AN IMAGE/1000 CHAIN) 
C 
C#####################################################################
D     WRITE(LUOXXX,9830)INDEX,BKSIP,BKSFL,FAF 
D    .,ENDCHN,(XRTB(3,I),I=1,20),FAFRTB,(STATE(I),I=1,STATLN) 
D9830 FORMAT(" /TMP: FAF STATE, INDEX="I4",  BKSIP="@7",   BKSFL="@7, 
D    .",   FAF="I3,/
D    ." /TMP: FAF STATE, ENDCHN="I6",  XRTB :"2(/9X,10I7),/ 
D    ." /TMP: FAF STATE, FAF RTB :   "6I7,/ 
D    ." /TMP: FAF STATE VECT.:"5(8@7,/,23X))
C#####################################################################
C-----CHECK FOR BACKSPACE IN PROCESS OVER A FAF STATE 
      IF( BKSIP )  GOTO 3060
C-----CHECK FOR THE FIRST TIME TO INITIALIZE THE RUN TABLE
      IF( FAF .NE. 0 )  GOTO 3070 
C-----THIS IS THE 1ST LINE OF M-QUESTION, 
C     RE-INIT FAF VARIABLE TO ACCESS THE DATA-BASE, RE-INIT 'FAFRTB'
C     WITH THE SHORTEST CHAIN INFORMATION.
      FAF=1 
      ENDCHN=32767
      K=32767 
      DO 3055 I=1,20
      IF( XRTB(3,I) .GE. K )  GOTO 3055 
      K=XRTB(3,I) 
      J=I 
 3055 CONTINUE
      IF(K .EQ. 32767) CALL TMPER(IERTN,49,FORMN,LU,119,0)
      CALL MOVEW(XRTB(1,J),FAFRTB,6)
      GOTO 3074 
C-----BACKSPACE IS IN PROCESS OVER THE FAF, SET FAF BACKSPACE FLAG
 3060 FAF=2 
C-----BACKSPACE TO PREVIOUS QUESTION, ALWAYS SUCCEED !
 3065 IF( DOBKS(SQUAL,JNDEX,INDEX,NUQ,NMQ) )  STOP 31 
      GOTO 2320 
C-----THIS IS NOT THE 1ST LINE OF M-QUESTION, 
C     IF 'TOTAL' IN PROGRESS SKIP FORWARD,
C     IF NO 'TOTAL', CHECK IF GOING FORWARD FROM A BACKSPACE OR NOT 
 3070 IF( ISBIT(STATE(2),13) )  GOTO 2600 
      IF( FAF .NE. 2 )  GOTO 3074 
C-----THIS IS FORWAR FROM A BACKSPACE, CHECK FOR END OF CHAIN CONDITION 
      IF(INDEX .LE. ENDCHN)  GOTO 2600
      GOTO 3078 
C-----RESTORE THE RUN TABLE WITH THE FAF RUN TABLE
 3074 CALL MOVEW(FAFRTB,ISAVRT,6) 
C-----CHECK RUN TABLE FOR END OF CHAIN CONDITION
 3076 IF(ISAVRT(5) .NE. 0)  GOTO 3080 
      IF(INDEX .EQ. 1)  GOTO 3079 
      ENDCHN=INDEX-1
 3078 WAITC=.TRUE.
      GOTO 3065 
C-----ERROR IF END OF CHAIN & INDEX=1  ---> RESTART SAME FORM 
 3079 ERRFL=1 
      GOTO 4560 
C-----ACCESS THE DATA BASE NOW, PERFORM THE CHAINED DBGET 
 3080 LOCKW=0 
      IF( ISBIT(STATE(2),15) )  LOCKW=100001B 
      CALL TBGET(IDBNUM,ISAVRT,1,IMGSTA,TEMPB,0,LOCKW)
      IF(IMGSTA.NE.400 .AND. IMGSTA.NE.401)  GOTO 3111
C-----IMAGE ERROR, RECORD IS LOCKED OR DEADLOCK SITUATION 
C     SET UP "E 50" AND BACKSPACE TO PREVIOUS QUESTION
      ERRFL=50
      GOTO 3065 
 3111 IF(IMGSTA .NE. 0)  CALL TMPER(IERTN,49,FORMN,LU,118,IMGSTA) 
C-----CHECK MATCH ITEM
      J=IGETB(STATE,4)
      IF(J .EQ. 0) GOTO 3118
      DO 3115 I=1,J 
      K=2*I+1 
      IF(.NOT.  CMPW(TEMPB(IGETB(STATE(K),1)),OBUF(STATE(K+1))
     .  ,IGETB(STATE(K),2)))  GOTO 3076 
 3115 CONTINUE
C-----GOOD ENTRY HAS BEEN GET, CHECK FOR TOTAL IN PROCESS ? 
 3118 IF( .NOT. ISBIT(STATE(2),13) )  GOTO 3119 
C-----DO THE SUM AND LOOP UNTIL END OF CHAIN
      K=2*J+3 
      IE=STATE(K) 
      K=K+1 
      DO 3810 I=1,IE
      JTMLN=ITML(K) 
      JTMTP=ITMT(K) 
      JOBUP=IPT(1,K)
C#####################################################################
D     WRITE(LUOXXX,9832)ENDCHN,K,I,IE,JTMTP,JTMLN,JOBUP 
D9832 FORMAT(" /TMP: FAF STATE SUM, ENDCHN="I6" K="I2" I="I2" IE="I2
D    .," ITM CHARAC="3I4) 
C#####################################################################
C 
C-----IF FIRST TIME THROUGH, RESET ACCUMULATOR
      IF(ENDCHN .NE. 32767)  GOTO 3805
      CALL CALCV(0,JTMTP,OBUF(JOBUP),0) 
 3805 CALL CALCV(1,JTMTP,OBUF(JOBUP),TEMPB(STATE(K+2))) 
D     CALL PRT(LUOXXX,LU,JTMTP,TEMPB(STATE(K+2)),0) 
      K=K+3 
 3810 CONTINUE
C-----RESET 1ST TIME THROUGH FLAG AND LOOP UNTIL END OF CHAIN 
      ENDCHN=32766
      IF(ISAVRT(5) .NE. 0)  GOTO 3080 
      GOTO 2600 
C-----FAF WITHOUT TOTAL, SAVE RUN TABLE, SAVE IMAGE BUFFER AND PROCEED
 3119 CALL MOVEW(ISAVRT,FAFRTB,6) 
      CALL MOVEW(ISAVRT,OBUF(IMPT(INDEX)),6)
      IF( ISBIT(STATE(2),14) )  CALL MOVEW(TEMPB,IMGBUF,250)
      IF(ISAVRT(5) .EQ. 0)  ENDCHN=INDEX
      GOTO 2600 
C 
C=====STANDARD  STATE PROCESSING  (U & M  QUESTIONS)
C 
 3120 ITEMTP=ITMT(2)
      DITMTP=-1 
      ITEMLN=ITML(2)
      DITMLN=0
      OBUFPT=IPT(INDEX,2) 
      DOBUPT=OBUFPT 
      STATPT=7
      OUTDEV=0
      OUTLEN=0
      INLNGT=0
C-----IF TITLE, ADJUST  STATPT
      IF( ISBIT(STATE(2),15) )  STATPT=STATPT+STATE(STATPT) 
      EDITPT=STATPT 
C-----SET LIGTH FOR CURRENT STATE 
      LITE1=LIGHN(3)
      LITE2=0 
C-----IF DISPLAY SET UP  EDIT POINTER 
      IF( .NOT. ISBIT(STATE,15) )  GOTO 3122
      EDITPT=EDITPT+7 
      IF( .NOT. ISBIT(STATE(STATPT+1),15) )  GOTO 3122
      L=STATE(STATPT+7)-1 
      CALL MOVEW(STATE(STATPT+8),OUTBUF,L)
      OUTLEN=1+2*L
      CALL PUTCA(OUTBUF,6400B,OUTLEN) 
      EDITPT=EDITPT+L+1 
C-----SET UP THE IMAGE EDIT POINTER 
 3122 TEMPL=VALCK(.TRUE.) 
      IMAGPT=K+EDITPT-1 
C-----CHECK FOR FORWARD ADVANCE, ASSUME NO ERROR & NO BKSIP 
      IF( FORWIP )  GOTO 3127 
C-----IF THERE IS AN ERROR, FORGET BACKSPACE IN PROCESS AND DISPLAY 
      IF(ERRFL .EQ. 0)  GOTO 3125 
      BKSIP=.FALSE. 
      GOTO 3200 
C-----CHECK FOR DISPLAY 
 3125 IF( (.NOT. ISBIT(STATE,15) ) .AND. BKSIP)  GOTO 3160
 3127 IF( .NOT. ISBIT(STATE,15) )  GOTO 3175
      DOBUPT=IPT(INDEX,STATPT+1)
      DITMTP=ITMT(STATPT+1) 
      DITMLN=ITML(STATPT+1) 
C-----IF RECALL IN PROGRESS, FORGET DISPLAY AND SHOW THE PREVIOUS ANSWER
      IF (BKSIP)  GOTO 3160 
      CALL PUTCA(LITE1,LIGHN(STATPT+2),2) 
C#####################################################################
D     WRITE(LUOXXX,9838)LU,JNDEX,INDEX,DITMTP,DITMLN,DOBUPT 
D    .,(STATE(I),I=STATPT,EDITPT-1) 
D9838 FORMAT(" /TMP: DISPLAY STATE FOR LU#"I2",  J="I2", I="I3, 
D    .", ITM CHARAC"3I4,/13X"VECTOR:"7@8,/20X,I8,10A2)
C#####################################################################
      IF( ISBIT(STATE(STATPT),15) )  GOTO 3130
      J=STATE(STATPT+3) 
      IF( .NOT. ISBIT(STATE(STATPT),12) )  GOTO 3129
C-----TOTAL HAS BEEN PROCESSED, CONTINUE TO PROCESS IT
      I=0 
      IF(INDEX .EQ. 1)  GOTO 3128 
      K=IPT(INDEX-1,STATPT+1) 
      CALL MVITM(OBUF(K),OBUF,DITMTP) 
      I=IPT(INDEX-1,STATPT+2) 
C-----IF NO QUESTION ON THE DISPLAY ITEM, FORGET ABOUT TOTAL
 3128 IF(J .EQ. 0)  GOTO 3145 
C-----QUESTION ON THE TOTAL DISPLAY ITEM EXIST, CONTINUE ACCUMULATION 
      K=IPT(INDEX,STATPT+2) 
      IF(K .LT. DOBUPT) I=K 
      IF( BUFULL .EQ. 0 )  GOTO 3135
      CALL MVITM(OBUF(IPT(BUFULL,STATPT+1)),OBUF,DITMTP)
      I=IPT(BUFULL,STATPT+2)
C-----IF QUESTION IS BEFORE DISPLAY DO TOTAL, ELSE SKIP THE 1ST TIME
 3135 IF(I .EQ. 0)  GOTO 3145 
C-----CONTINUE THE TOTAL OPERATION
      CALL CALCV(1,DITMTP,OBUF(DOBUPT),OBUF(I)) 
D     CALL PRT(LUOXXX,LU,DITMTP,OBUF(I),0)
      GOTO 3145 
 3129 IF( .NOT. ISBIT(STATE(STATPT),13) )  GOTO 3145
C-----THE DISPLAY IS FROM THE IMAGE DATA-BASE, MOVE VALUE ONLY
C     IF NO BACKSPACE HAS BEEN DONE OVER THE FAF
      IF(FAF .NE. 2)  CALL MVITM(IMGBUF(J),OBUF,DITMTP) 
      GOTO 3145 
C-----THE DISPLAY IS FROM A USER SUBROUTINE, INVOKE THE SUBROUTINE
 3130 INPSTA=STATPT+3 
      CALL SUBUF(FORMN,DITMTP,BKSFL,INDEX,INPSTA,IUSER) 
      CALL TMSUB(STATE(INPSTA)) 
      IF(IST .NE. 0)  CALL TMPER(IERTN,1,FORMN,LU,STATE(INPSTA),IST)
C-----FORMAT DISPLAY INFORMATION
 3145 CALL CNVTO(DITMTP,OBUF(DOBUPT),INPBUF,INLNGT) 
      IF(INLNGT .GT. 20) INLNGT=20
      IF( ISBIT(STATE(STATPT+1),14) )  GOTO 3168
      GOTO 3175 
C-----RECALL IS IN PROCESS, DISPLAY 'VALUE' INSTEAD OF 'DISPLAY'
C     IF ITEM TYPE=3 & A DISPLAY EXIST --> USE DISPLAY DURING BKS 
 3160 IF(ITEMTP.EQ.3 .AND. DITMLN.NE.0)  GOTO 3145
      CALL CNVTO(ITEMTP,OBUF(OBUFPT),INPBUF,INLNGT)