FTN4
      SUBROUTINE ZTMP, 92080-16510 REV.2026  800606 
C 
C 
C     NAME:   ZTMP
C     SOURCE: &ZTMP'    92080-18510 
C     BINARY: %ZTMP'    92080-16510    PART OF  %ZTMP  92080-16510
C 
C     PMGR:   FRANCOIS GAULLIER 
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     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(10),TEMPB(512),CRBUF,PRTBUF(13),LFLF(5) 
     .,LOGHD(8),LOGACK(4),JTMLN,JTMTP,JOBUP,EQUIVX(3) 
     .,BUFULL,OUTBUF,OUTDEV,ERRBF(3),ZERO(2),COLCNT,TRMHR,TRMMN 
     .,TEMPTS,MAXDP(2),KMAX(2)
D    .,ITEMPX(25) 
C 
C***   DEFINE LOGICAL FLAGS 
C 
      LOGICAL BEGNFL,BKSFL,BKSIP,WAITC,CALCFL,CALCIP,DEFKB
     .       ,FORWIP,TEMPL,M14,DDSPV,HP3077,IFCRT 
     .       ,QXY 
D    .       ,QZZ 
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,MTCHT
C 
C 
C***   TRUE COMMON
C 
      COMMON ICOM00(5)
C 
C***   1ST COMMON BLOCK 
C 
      COMMON LU,ICTLB,ITYP,IST,ITL,IMAGEX(11),ISAVRT(7) 
     .      ,IOMODL(3),ERRFL,EDITPT,IFC,IOMTMP(2),ITSN,ITSSTP,ITIM0(6)
     .      ,LITE1,LITE2,LITE3,OUTDEV,INPDEV,ITSNAM(5),OUTLEN 
     .      ,OUTBUF(40),HP3077,WAITC,TRMHR,TRMMN,TEMPTS,IPAD(51)
C 
C     IMGSAV IS EQUIVALENCED TO THE LAST 3 WORDS OF IMAGEX AND ISAVRT.
C            IMGSAV(1)   - CURRENT DATA SET NO. 
C            IMGSAV(2-3) - CURRENT DATA RECORD NO. (DOUBLE WORD)
C            IMGSAV(4-10)- IMAGE RUN TABLE
      DIMENSION IMGSAV(10)
      EQUIVALENCE(IMGSAV(1),IMAGEX(9))
C 
C***   2ND COMMON BLOCK 
C 
      COMMON NUQ,NMQ,STATPT,INDEX,OBULN,L1,L2,OBUF(512) 
C 
C***   3RD COMMON BLOCK 
C 
      COMMON FORMN,SQUAL,JNDEX,FMGST,STATLN,STATE(90) 
C 
      COMMON INPLEN,INPBUF(100) 
C 
      COMMON ITEMTP,ITEMLN,OBUFPT,DITMTP,DITMLN,DOBUPT
     .      ,CRBUF(80),FLDCNT,STCNT,DEFKB,COLCNT
     .      ,IERTN,ITT0,ITT,KEYN,INLNGT,INPSTA,INPITL 
     .      ,IMAGPT,BKSFL,BKIN,BKJN,BKSIP,BKSQ,FORWIP,FORWJN
     .      ,BUFULL,ENDCHN,CALCFL,CALCIP,CALCBU(4),FAF,IMGFLG 
     .      ,IDBNUM,LSTCLC,KLUGE
C 
C***   4TH COMMON BLOCK 
C 
      COMMON IUSER(332) 
C 
C***   5TH COMMON BLOCK 
C 
      COMMON FAFRTB(10),XRTB(10,20),IMGBUF(512),I,J,K 
C 
C     FAFRTB(1-7) - HOLDS IMAGE RUN TABLE INFO THAT IS RETURNED WITH
C                   TBGET AND TBFND 
C     FAFRTB(8)   - HOLDS DATA SET NO. ASSOCIATED WITH  RUNTABLE
C 
C     XRTB(1-7,X) - HOLDS IMAGE RUNTABLE SET UP BY IMAGE EDIT OPERATIONS
C     XRTB(8-9,X) - HOLDS CHAIN LENGTH (DOUBLE WORD)
C     XRTB(10)    - HOLDS DATA SET NO. ASSOCIATED WITH RUNTABLE 
C 
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)) 
C     EQUIVALENCE (LUOXXX,ICOM00(1))
C 
      DATA LUOXXX/6/
      DATA OBULNX/512/
      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/3407B,15455B,2Hc0,42177B/,I32768/100000B/ 
C 
C THE FOLLOWING LINE INITIALIZES MAXDP TO THE MAXIMUM POS 32-BIT
C INTEGER VALUE, 2**31 - 1.  THIS METHOD IS USED BECAUSE THE 1805 
C FORTRAN COMPILER (WHAT A PIECE OF SHIT) DOES NOT SUPPORT D.P. 
C INTEGERS. 
C 
      DATA MAXDP/32767,-1/
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,2,1, AND 0 ARE THE POWER FAIL, CRT, PRINTER
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 
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*10*IMGFLG 
      ENDBK(M9)=BKSEN(BKSFL,FAF,SQUAL,INDEX,JNDEX,BKSQ,BKIN,BKJN) 
      KBINP(M10)=(IAND(STATE(4),37B).EQ.0 .OR.
     .            IAND(STATE(4),37B).EQ.31) 
      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-----SAVE INITIAL STATUS FOR LATER CHECKS, NOTE THAT ISTSAV IS 
C-----NOT IN COMMON.  THIS IS BECAUSE ITS VALUE IS NEVER CHANGED. 
      ISTSAV=IST
C 
C       FROM THIS POINT, THIS PROGRAM IS REACTIVATED
C         FOR EACH INTERACTIVE DEVICE. (COMMON BLOCK # 1
C         IS ENABLED) 
C 
C 
C     INITIALIZE TS#-SC BUFFER--STORE ASSIGNED TS# IN ANOTHER PLACE 
C           SO TMS WON'T GET UPSET
C 
      ITSNAM=I32768 
      DO 5 I=1,5
5     ITSNAM(I)=0 
      TEMPTS=ITYP 
C 
C#####################################################################
D     WRITE(LUOXXX,7339)LU,ICOM00 
D7339 FORMAT("  FOR LU="I2,", CB0:"5I7) 
C#####################################################################
C 
C-----SET UP THE RIGHT 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 --- MAKE SURE TERM HAS BEEN INITIALZED BEFORE PROCEEDING FURTHER. 
C 
90    KK=IEQCK(LU)
      IF(KK.EQ.2HAI .OR. KK.EQ.2HBI) GO TO 95 
      ASSIGN 92 TO IERTN
      CALL TMPER(IERTN,31,0,LU,LU,0)
92    CALL TMPZ(32767)
      GO TO 90
C 
C  RESET THE TERMINAL AND GET ITS STATUS
C 
95    HP3077=.FALSE.
      IFC=6 
      CALL TMSUB(IOMODL)
C 
C  AUTO-START OR SELECT?
C 
      IF(TEMPTS.EQ.10000)GO TO 100
C 
C  AUTO-START --- SET UP TS# AND DUMMY OUT SC 
C 
      ITSNAM(4)=TEMPTS
      ITSNAM(5)=I32768
      GO TO 300 
C 
C  GET TS# [-SC]
C 
100   CONTINUE
      HP3077=.FALSE.
      TEMPTS=10000
      OUTDEV=0
      IFC=1 
      OUTLEN=0
      LITE1=0 
105   LITE2=0 
      LITE3=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) 
      IF(TEMPTS.NE.10000)FORMN=TEMPTS 
      SQUAL=10
      JNDEX=LU
      CALL MOVEW(ITSNAM,STATE,5)
      CALL TMSUB(TSMG)
      IF(FMGST .EQ. 0)  GOTO 2000 
C 
C  CHECK FOR FATAL ERRORS 
C 
      IF(TEMPTS.NE.10000.AND.FMGST.NE.0)CALL TMPER(0,51,TEMPTS,LU,LU,0) 
C 
C-----ERROR ! (NON-FATAL) 
      IF(FMGST .EQ. -1)  EDITPT=0 
      IF(FMGST .EQ. -6)  EDITPT=1 
C 
C-----DISABLE 3RD COMMON BLOCK
C 
      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) 
      ITT0=STATE(9) 
      LITE3=IAND(STATE(13),17B) 
      ITT=STATE(10) 
      INPBUF=STATE(11)
C-----CHECK TERMINAL FEATURES 
      ERRFL =30 
      IFC=3 
      CALL TMSUB(IOMODL)
C################################################################## 
D     WRITE(LUOXXX,6789)ISTATS
D6789 FORMAT("/ZTMP:  AT FEATURE CHECK, ISTATS=",I5)
C################################################################## 
      IF(ISTATS.EQ.1.AND.HP3077)CALL TMPER(0,52,FORMN,LU,LU,0)
      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 
C 
C CREATE DATA BASE NAMR FROM DATA BASE NAME, SEC CODE, CR# STORED IN
C STATE(20) - (24)
C 
C     D.B. NAME MUST BE MOVED UP ONE WORD IN STATE FOR INAMR CALL.
C     STATE(19) MAY BE USED AS A SCRATCH WORD.
C 
      CALL MOVEW(STATE(20),STATE(19),3) 
C 
C     AN INAMR TYPE CODE MUST BE STORED IN STATE(22)
C 
      STATE(22)=27B 
      CALL BLANC(OUTBUF,11) 
      NCHRS=0 
C 
C     CREATE D.B. NAMR IN OUTBUF
C 
      CALL INAMR(STATE(19),OUTBUF(2),20,NCHRS)
C 
C OPEN IMAGE DATA BASE
C 
      CALL TBOPN(OUTBUF,0,0,IMGSTA) 
C 
C     SAVE TMS INTERNAL D.B.# RETURNED IN OUTBUF(1).
C     NOTE: THIS IS DIFFERENT FROM THE IMAGE INTERNAL D.B.# RETURNED
C           BY THE REGULAR DBOPN CALL.
C 
      IF(IMGSTA .NE. 0)  CALL TMPER(IERTN,49,FORMN,LU,120,IMGSTA) 
      IDBNUM=OUTBUF 
      KLUGE=0 
C 
C INITIALIZE CHAIN POINTER TO THE MAXIMUM 32-BIT INTEGER VALUE. 
C XRTB(2,) AND XRTB(3,) FORM A 32-BIT INTEGER WD. 
C 
 2020 DO 2025 I=1,20
         XRTB(2,I)=MAXDP(1) 
 2025    XRTB(3,I)=MAXDP(2) 
C 
C     UNLOCK ALL ENTRIES IN THE D.B. (TMS IMAGE CALL) 
C 
CREQ  CALL DMPTM(6,LU,50,14H TBULK AT 2050,14,1)
      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 
2150  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,TEMPB(5)) 
      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 
      IF(KLUGE.NE.0)GO TO 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 
      IX=2185 
C     WRITE(1,31789) IX,OUTLEN
      CALL TMSUB(IOMODL)
C 
C-----SETUP THE RIGHT STATE, (STATE QUAL., JNDEX AND INDEX) 
C 
 2200 JNDEX=1 
      KLUGE=0 
 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
D     WRITE(LUOXXX,9200)INDEX,JNDEX 
D9200 FORMAT("0***INDEX=",I5,"     JNDEX=",I5)
      CALL TMSUB(TSMG)
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 
C     WRITE(1,24009) SQUAL,OUTLEN 
C24009 FORMAT("***** ZTMP AFTER 2400 : SQUAL="I5", OUTLEN="I5)
      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
      IX=3010 
C     WRITE(1,31789) IX,OUTLEN
      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 
      IX=3015 
C     WRITE(1,31789) IX,OUTLEN
C#################################################################
D     WRITE(LUOXXX,9820)LU
D9820 FORMAT(/," FORM LU#"I3,5X,"SFK DEFINITION:")
D     WRITE(LUOXXX,9821)(OBUF(IX),IX=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( NUQ.EQ. 0 .AND. SQUAL.EQ.2)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 :   ",3I7/9X,7I7,/ 
D    ." /TMP: FAF STATE VECT.:"5(8@7,/,23X))
D     WRITE(LUOXXX,9210)JNDEX 
D9210 FORMAT(" ***JNDEX=",I7) 
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
C 
C     INITIALISE KMAX TO MAX 32-BIT INTEGER VALUE 
C 
      KMAX(1)=MAXDP(1)
      KMAX(2)=MAXDP(2)
      DO 3055 I=1,20
C 
C        NOTE: ICMPD RETURNS -1 FOR ARG1=ARG2, 0 FOR ARG1<ARG2, 
C              1 FOR ARG1>ARG2.  ARG1 & ARG2 BEING 32-BIT INTEGERS. 
C 
         IF(ICMPD(XRTB(2,I),KMAX).NE.0)GOTO 3055
            KMAX(1)=XRTB(2,I) 
            KMAX(2)=XRTB(3,I) 
            J=I 
3055  CONTINUE
      IF(ICMPD(KMAX,MAXDP).EQ.-1) CALL TMPER(IERTN,49,FORMN,LU,119,0) 
      CALL MOVEW(XRTB(1,J),FAFRTB,10) 
      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) )
     .              CALL TMPER(IERTN,49,FORMN,LU,121,SQUAL) 
      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,IMGSAV,10)
C-----CHECK RUN TABLE FOR END OF CHAIN CONDITION
C     THIS IS A 32-BIT INTEGER CHECK FOR 0 (KLUDGE).
 3076 CONTINUE
      IF(IOR(ISAVRT(5),ISAVRT(6)) .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(KEYN.EQ.12 .AND. ISBIT(STATE(2),15))LOCKW=100011B
      CALL TBGET(IDBNUM,FAFRTB(1),5,IMGSTA,2H@ ,TEMPB,0,LOCKW)
D     WRITE(LUOXXX,9220)IMGSAV
D9220 FORMAT(" 5**IMGSAV",3O8/10X,7O8)
D     WRITE(LUOXXX,9221)IMGSTA
D9221 FORMAT(1X,10I7) 
      IF(IMGSTA.NE.400 .AND. IMGSTA.NE.401)GO TO 3117 
C-----IMAGE ERROR, REC IS LOCKED OR DEADLOCK SITUATION
C     SET UP "E 50" AND BACKSPACE TO PREV QUES. 
         ERRFL=50 
         GO TO 3065 
3117  IF(IMGSTA .NE. 0)  CALL TMPER(IERTN,49,FORMN,LU,118,IMGSTA) 
C-----CHECK IF NEXT ENTRY (THIS MUST BE DONE BECAUSE SOMEONE
C-----DECIDED TO USE THIS SECTION OF CODE TO EXECUTE FAFS AND NEXT
C-----ENTRIES)
      IF(KEYN.EQ.12)GO TO 3121
C-----CHECK MATCH ITEM
      IF(.NOT.MTCHT(STATE,TEMPB,OBUF))GO TO 3076
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*IGETB(STATE,4)+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,IER) 
 3805    CALL CALCV(1,JTMTP,OBUF(JOBUP),TEMPB(STATE(K+2)),IER)
C        IF(IER.NE.0)GO TO 4731 
         IF(IER.NE.0)ERRFL=13 
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
C 
C     THE FOLLOWING IS A 32-BIT INTEGER CHECK 
C 
      IF(IOR(ISAVRT(5),ISAVRT(6)).NE. 0)  GOTO 3080 
      GOTO 2600 
C-----LOCK CURRENT RECORD IF NECESSARY (USE RE-READ)
3119  IF(.NOT.ISBIT(STATE(2),15))GO TO 3121 
         CALL TBGET(IDBNUM,FAFRTB(1),1,IMGSTA,2H@ ,TEMPB,0,100011B) 
         IF(IMGSTA.EQ.114)GO TO 3076
         IF(IMGSTA.NE.400 .AND. IMGSTA.NE.401)GO TO 3111
C--------IMAGE ERROR, RECORD IS LOCKED OR DEADLOCK SITUATION
C        SET UP "E 50" AND BACKSPACE TO PREV QUESTION 
            ERRFL=50
            GO TO 3065
3111     IF(IMGSTA.NE.0)CALL TMPER(IERTN,49,FORMN,LU,118,IMGSTA)
         IF(.NOT.MTCHT(STATE,TEMPB,OBUF))GO TO 3076 
C-----FAF WITHOUT TOTAL, SAVE RUN TABLE, SAVE IMAGE BUFFER AND PROCEED
3121  CALL MOVEW(IMGSAV,FAFRTB,10)
      CALL MOVEW(IMGSAV,OBUF(IMPT(INDEX)),10) 
      IF(ISBIT(STATE(2),14))CALL MOVEW(TEMPB,IMGBUF,IMGSTA(2))
C 
C     THE FOLLOWING IS A 32-BIT INTEGER CHECK FOR 0 
C 
      IF(IOR(ISAVRT(5),ISAVRT(6)) .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 LIGHT 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
      LO=799
C     WRITE(6,31229) LO,OUTLEN,FORWIP 
C31229 FORMAT(" LO="I3", OUTLEN="I3", FORWIP="@6) 
      CALL PUTCA(OUTBUF,6400B,OUTLEN) 
      EDITPT=EDITPT+L+1 
C-----SET UP THE IMAGE EDIT POINTER 
 3122 TEMPL=VALCK(.TRUE.) 
      IX=3122 
C     WRITE(1,31789) IX,OUTLEN
      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),IER) 
C     IF(IER.NE.0)GO TO 4731
      IF(IER.NE.0)ERRFL=13
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) 
C     WRITE(1,31310) (IUSER(IX),IX=1,10)
C31310 FORMAT("+++++ ZTMP : IUSER(1-10)="10@7)
C     WRITE(1,31309) STATE(INPSTA),STATE(INPSTA+1),STATE(INPSTA+2)
C31309 FORMAT("+++++ ZTMP : USER DISPLAY SUB="3A2)
      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
      GO TO 3168
31451 IF( ISBIT(STATE(STATPT+1),14) )  GOTO 3168
      IF( IFCRT(STATE,OUTDEV,ITT)   )  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 
C3160 WRITE(6,31609) ITEMTP,DITMLN,I,STATE(I) 
C31609 FORMAT(" LABEL 3160: ITEMTP="@6", DITMLN="@6", I="@6 
C    +       ", STATE(I)="@6) 
 3160 IF(ITEMTP.EQ.3 .AND. DITMLN.NE.0)  GOTO 3145
      CALL CNVTO(ITEMTP,OBUF(OBUFPT),INPBUF,INLNGT) 
C     WRITE(6,31610) INLNGT,(INPBUF(IXX),IXX=1,(INLNGT+1)/2)
C31610 FORMAT(" INLNGT="I3", INPBUF="15A2)
      IF(INLNGT .GT. 20)  INLNGT=20 
C 
C --- IF TS SPECIFIES PRT,CRT, OR ADS, MOVE DISPLAY ITEM TO OUTBUF
C 
      GO TO 3168
31611 IF(ISBIT(ITT,7)) GO TO 3168 
      IF(IFCRT(STATE,OUTDEV,ITT)) GO TO 3168
      IF( ONLPR(I) )  GOTO 3175 
C 
C-----ECHO ON THE PRINTER IS REQUESTED, MOVE MESSAGE INTO LPR BUFFER
C 
 3168 CALL MOVCA(INPBUF,1,OUTBUF,OUTLEN+1,INLNGT) 
C     WRITE(6,31689)
C31689 FORMAT(" LABEL : 3168")
      CALL JUSTF(OUTBUF,OUTLEN+1,INLNGT,1)
      OUTLEN=OUTLEN+1+INLNGT
      LO=892
C     WRITE(6,31229) LO,OUTLEN,FORWIP 
      CALL PUTCA(OUTBUF,6400B,OUTLEN) 
 3175 IF( FORWIP )  GOTO 6720 
      IF( .NOT. ISBIT(STATE(2),15) )  GOTO 3178 
      L=2*(STATE(7)-1)
      CALL MOVCA(STATE(8),1,OUTBUF,OUTLEN+1,L)
      OUTLEN=OUTLEN+1+L 
      LO=899
C     WRITE(6,31229) LO,OUTLEN,L
      CALL PUTCA(OUTBUF,6400B,OUTLEN) 
C-----IF PRINTER OUTPUT IS REQUIRED, OUTLEN IS NOT 0
 3178 IF(OUTLEN .EQ. 0)  GOTO 3180
      IX=3178 
C     WRITE(6,31789) IX,OUTLEN,ERRFL,INLNGT 
C31789 FORMAT(" **** ZTMP : X="I5", OUTLEN="I6", ERRFL="I6", INLNGT="I6)
      OUTLEN=OUTLEN-1 
      LO=908
C     WRITE(1,31229) LO,OUTLEN
C 
C --- IF RECALL IN PROGRESS, SHOW PREVIOUS ANSWER TO CRT OR PRT.
C 
      IF(BKSIP) GO TO 3179
C 
C-----IF NO TITLE, ONLY ONE WRITE IS NEEDED 
C 
      IF(OUTLEN .EQ. INLNGT)  GOTO 3200 
 3179 INPLEN=0
C --- PRINT TITLE(LABEL FOR QUES) TO CRT AND/OR PRINTER IF THEY EXIST.
      IF(IFCRT(STATE,OUTDEV,ITT)) CALL TMSUB(IOMODL)
      OUTDEV=2
      IF(ISBIT(STATE(6),1)) CALL TMSUB(IOMODL)
C 
C --- NOW CHECK IF DISPLAY HAS BEEN DONE HERE (TO ADS/CRT/PRT) DON'T
C     DO THEM AGAIN LATER ON (BY SETTING OUTLEN TO 0).
C 
      IF(IFCRT(STATE,OUTDEV,ITT)) GO TO 31791 
      IF(.NOT.ISBIT(STATE(6),1) ) GO TO 3180
31791 OUTDEV=0
      OUTLEN=0
      GO TO 3200
C-----SET OUTLEN AND OUTBUF FOR AN EVENTUAL DISPLAY 
 3180 OUTLEN=INLNGT 
      IX=3180 
C     WRITE(1,31789) IX,OUTLEN,ERRFL
      CALL MOVEW(INPBUF,OUTBUF,(OUTLEN+1)/2)
C-----CHECK FOR ERROR CONDITION AND REPORT ERROR IF ANY 
 3200 LITE2=IAND(LITE2,377B)
      IF( ERRFL .EQ. 0 )  GO TO 3220
C 
C?????????????????? 
C 
C  SAVE OUTPUT BUFFER IN INPUT BUFFER 
C   IN THE EVENT OF A RE-DISPLAY AFTER ERROR
C 
      CALL MOVEW(OUTLEN,INPBUF,41)
C 
C?????????????????? 
C 
C --- IF CRT, ECHO "ERROR" ONTO IT. 
C 
      IF(ISBIT(STATE(6),0)) GO TO 3201
C 
C-----ECHO "ERROR" ON THE PRINTER IF ONLINE PRINT-OUT IS SELECTED 
C 
      IF( ONLPR(I) )  GOTO 3202 
C 
 3201 CALL MOVEW(OBUF(OBULN+1),OUTBUF,6)
      CALL JUSTF(OUTBUF,1,12,1) 
      OUTLEN=12 
      OUTDEV=2
      INPLEN=0
C 
C --- ECHO "ERROR" ONTO CRT AND/OR PRINTER. 
C 
      IF(IFCRT(STATE,OUTDEV,ITT)) CALL TMSUB(IOMODL)
      OUTDEV=2
      IF(ISBIT(STATE(6),1)) CALL TMSUB(IOMODL)
      OUTDEV=0
C 
C-----SETUP ERROR MESSAGE FOR THE DISPLAY 
C 
 3202 CALL PUTCA(LITE2,LITERR,1)
C 
      ERRBF(2)=IASC(ERRFL)
C***  CALL DMPTM(6,ERRBF,3,ERRBF,6,1) 
      CALL MOVEW(ERRBF,OUTBUF,3)
C-----SETUP THE ERROR MESSAGE LENGTH FOR THE DISPLAY
      IF ( ERRFL .EQ. 1 )  OUTLEN=0 
      IF ( ERRFL .NE. 11)  GOTO 3205
      CALL BLANC(OUTBUF(4),6) 
      OUTBUF(5)=IASC(FLDCNT)
      OUTBUF(7)=IASC(COLCNT)
      OUTLEN=18 
      GOTO 3218 
 3205 IF ( ERRFL .EQ. 50)  GOTO 4210
      IF(ERRFL.EQ.13)OUTLEN=6 
 3218 ERRFL=0 
C 
C???????????????????
C 
C  RESTORE THE OUTPUT BUFFER
C 
      CALL MOVEW(INPBUF,OUTLEN,41)
C 
C???????????????????
C 
C-----SWITCH ON/OFF THE TC LIGHT FOR THE 1ST M-QUESTION 
 3220 I=2 
      IF(FAF .EQ. 0)  I=1 
      IF(SQUAL.EQ.2 .AND. INDEX.NE.1 .AND. JNDEX.EQ.I)
     *              CALL PUTCA(LITE2,LITTCP,2)
      IF(SQUAL.EQ.2.AND.INDEX.NE.1.AND.JNDEX.EQ.1)
     *     CALL PUTCA(LITE2,LITTCP,2) 
C 
C-----SWITCH THE LIGHT AND REQUEST INPUT
C 
 3230 INPDEV=STATE(4) 
      CALL SETBT(OUTDEV,0,1)
C 
C --- IF WAITING FOR TC, FORGET CARD READER OR INPUT SUBROUTINE.
C 
      IF(WAITC) GO TO 3265
C 
C --- IS INPUT FROM USER WRITTEN INPUT MODULE?
C 
C     WRITE(1,32301) STATE(4) 
C32301 FORMAT("STATE(4)="@6)
      IF(IAND(STATE(4),37B).NE.31) GO TO 3240 
C 
C --- YES. CALCULATE WHERE THE NAME OF THE SUBROUTINE IS (IMMEDIATELY 
C     AFTER THE DEFAULT VALUE). NAMPTR WILL BE SET TO POINT TO THE
C     NAME OF THE INPUT MODULE. 
C 
C     ITML2=ITML(2) 
C     WRITE(1,32306) NAMPTR,EDITPT,STATE(EDITPT),ITML2
C32306 FORMAT("NAMPTR="I5", EDITPT="I5", STATE(EDITPT)="I5
C    +       ", ITML(2)="I5)
      NAMPTR=EDITPT+IAND(STATE(EDITPT),377B)
C 
C --- IF DEFAULT VALUE EXISTS (DVF BIT), INCREMENT NAMPTR PAST IT.
C 
      IF(ISBIT(STATE(1),13)) GO TO 3231 
        ITML2=(ITML(2)+1)/2 
        IF(ITML2.GT.10) ITML2=10
        NAMPTR=NAMPTR+ITML2 
C 
C --- SET UP THE USER COMMON BLOCK & CALL THE INPUT MODULE. 
C 
 3231 CALL SUBUF(FORMN,ITEMTP,BKSFL,INDEX,STATPT,IUSER) 
C     WRITE(1,32302) STATE(NAMPTR),STATE(NAMPTR+1),STATE(NAMPTR+2)
C32302 FORMAT("STATE(NAMPTR)="3A2)
      CALL TMSUB(STATE(NAMPTR)) 
C     WRITE(1,32303) IST
C32303 FORMAT("IST="@6) 
      IF(IST.NE.0) CALL TMPER(IERTN,1,FORMN,LU,STATE(NAMPTR),IST) 
C 
C --- CK THAT USER TLOG MATCHES THE SPECIFIED ITEM LENGTH(ERR IF NOT).
C 
      IF(IUSER(12).GT.0) IUSER(12)=IUSER(12)+IUSER(12)
      IF(IUSER(12).LT.0) IUSER(12)=-IUSER(12) 
C --- STRING INPUT? 
      IF(ITEMTP.NE.0) GO TO 3232
         IBYTES = ITML(2) 
         IF(IUSER(12).GT.IBYTES) GO TO 3238 
         GO TO 3239 
C --- INTEGER INPUT?
3232  IF(ITEMTP.NE.1) GO TO 3233
         IBYTES=6 
         IF(IUSER(12).GT.6) GO TO 3238
         GO TO 3239 
C --- DEFAULT TO REAL INPUT.
3233  IBYTES=14 
      IF(IUSER(12).LE.14) GO TO 3239
C 
C --- REPORT ERROR -- INCORRECT INPUT LENGTH. 
C 
3238  CALL TMPER(IERTN,46,FORMN,LU,IBYTES,IUSER(12))
C3238  WRITE(1,32304) IBYTES,IUSER(12)
C32304 FORMAT("IBYTES="I3", IUSER(12)="I3)
C     CALL TMPER(IERTN,2,FORMN,LU,IBYTES,IUSER(12)) 
C 
C --- SET INPUT TO ENTER KEY & MOVE DATA FROM USER BUFFER TO INPUT BUFFER.
C 
3239  ISTATS=0
      ITRNLG=IUSER(12)
      CALL MOVCA(IUSER,25,INPBUF,1,IUSER(12)) 
C     WRITE(1,32305) ITRNLG,(IUSER(IXX),IXX=13,25)
C32305 FORMAT("ITRNLG="I3", IUSER(13-25)="13@7) 
C 
C --- JMP AHEAD IF KEYBOARD INPUT.
C 
 3240 IF( KBINP(I) )  GOTO 3270 
C 
C-----CARD READER INPUT, FIRST FIELD ?
C 
      IF( ISBIT(STATE(4),11) )  GOTO 3255 
C-----N TH FIELD ON A CARD, NOT 1ST  GET FROM CARD BUF. 
      IF ( DEFKB )  GOTO 3260 
C-----IF NOT DEFAULTED TO THE KEYBOARD, GET FROM BUFFER 
      IF ( .NOT. BKSIP )  GOTO 3280 
      FLDCNT=FLDCNT-1 
      GOTO 3270 
C-----IT IS 1ST FIELD OF A CARD, MUST CONFIGURE CARD-READER AND 
C     READ THE CARD 
3255  DEFKB=.FALSE. 
      FLDCNT=0
      STCNT=0 
      GOTO 3270 
C-----CARD INPUT DEFAULTED TO KEYBOARD, DISPLAY "-------------" 
 3260 IF (BKSIP)  GOTO 3270 
      CALL MOVEW(16H----------------,OUTBUF,8)
      OUTLEN=16 
 3265 INPDEV=0
 3270 BKSIP=.FALSE. 
      INPLEN=1
C***  CALL DMPTM(6,INPLEN,1,OUTBUF,20,0)
C#####################################################################
D     KN=IAND(INPDEV,37B) 
D     KL=2H.. 
D     IF(KN.EQ.0) KL=2HKB 
D     IF(KN.EQ.1) KL=2HB3 
D     IF(KN.EQ.2) KL=2HB5 
D     WRITE(LUOXXX,9840)LU,SQUAL,JNDEX,INDEX,WAITC,OUTLEN,INPLEN
D    .,LITE1,LITE2,KL 
D9840 FORMAT("'Z' LU#"I3"  I/O FOR STATE: SQ="I2", J="I2", I="I3, 
D    .,",   WAITC ="@7,/,6X"LEN(OUT="I2", INP="I4")"
D    .,2X"LITE1=",@6,", LITE2=",@6,3X"INP DEV="A2)
D     IF(OUTLEN.NE.0) WRITE(LUOXXX,9841)(OUTBUF(IX),IX=1,(OUTLEN+1)/2)
D9841 FORMAT(8@8) 
C#####################################################################
C 
C --- IF WAITING FOR TC & THIS TS IS A SELF-COMPLETING TS, DON'T GO TO
C     THE TERM. FOR TC BUT AUTOMATICALLY GENERATE IT. 
C 
      IF(WAITC .AND. ISBIT(ITT0,15)) GO TO 3272 
C 
C --- IF WAITING FOR TC, GO TO TERM FOR TC. 
C 
      IF(WAITC) GO TO 3271
C 
C --- IF INPUT WAS FROM USER INPUT SUBROUTINE, SKIP INPUT FROM TERMINAL.
C 
      IF(IAND(STATE(4),37B).EQ.31) GO TO 3275 
C 
C --- GET INPUT FROM TERMINAL.
C 
3271  CALL TMSUB(IOMODL)
      GO TO 3275
C 
C --- SINCE THIS IS A SELF-COMPLETING TS, GET THE TC OR CS KEY NUMBER 
C     FROM THE SFK STATE. 
C 
3272  DO 3273 N=1,10
         KEYBPT=OBULN+IGETB(OBUF(OBULN+10),N)-2 
         IF(.NOT.ISBIT(OBUF(KEYBPT),15)) GO TO 3273 
         IFCN=IAND(OBUF(KEYBPT),37400B)/256 
         IF(IFCN.EQ.1 .OR. IFCN.EQ.14) GO TO 3274 
3273  CONTINUE
C 
C --- FATAL ERROR IF TC OR CS NOT FOUND IN KEYS 1-10. 
C 
      STOP 3273 
C 
3274  ISTATS=N
      ITRNLG=0
      GO TO 3275
C 
3275  INPSTA=ISTATS 
      INPITL=ITRNLG 
C     WRITE(1,98419) INPSTA,INPITL
C98419 FORMAT("'Z' 3275 :INPSTA="@6," INPITL="@6) 
C#####################################################################
D     KN=IAND(INPDEV,37B) 
D     KL=2H.. 
D     IF(KN.EQ.0) KL=2HKB 
D     IF(KN.EQ.1) KL=2HB3 
D     IF(KN.EQ.2) KL=2HB5 
D     K2=(INPITL+1)/2 
D     IF(INPITL.GE.94) K2=48
D     WRITE(LUOXXX,9845)LU,KL,INPSTA,INPITL 
D9845 FORMAT(" FROM LU#"I3"  COMPLETION OF INP DEV="A2", STATUS ="@7, 
D    .", ITL ="I4)
D     IF(INPITL.NE.0) WRITE(LUOXXX,9846)(INPBUF(IX),IX=1,K2)
D9846 FORMAT(8@8) 
C#####################################################################
C 
C-----CHECK IF SRQ/ATTN KEY IS USED DURING INPUT
C 
3277  IF(INPSTA .EQ. 128)  GOTO 4100
C-----IF WAITING FOR 'COMPLETE TRANSACTION', FORGET CARD READER 
      IF( WAITC )  GOTO 3300
C-----CARD READER INPUT ? 
      IF( KBINP(I) )  GOTO 3300 
C-----PHYSICAL READ FROM CARD READER ?
      IF( DEFKB )  GOTO 3290
      CALL BLAN(INPBUF,INPITL+1,81-INPITL)
C#####################################################################
D     WRITE(LUOXXX,9848) INPITL,(INPBUF(KX),KX=1,43)
D9848 FORMAT("   CR BUFFER: INPITL=",I3,6(/8@8))
C#####################################################################
      CALL MOVEW(INPBUF,CRBUF,80) 
C-----MOVE THE FIELD FROM THE CARD READER BUFFER INTO THE INPUT BUFFER
 3280 INPSTA=0
      INPITL=IRS8(STATE(5)) 
      CALL MOVCA(CRBUF,IAND(STATE(5),377B),INPBUF,1,INPITL) 
C-----UPDATE CARD-BUFFER FIELD COUNTER
 3290 FLDCNT=FLDCNT+1 
C#####################################################################
D     KM=(INPITL+1)/2 
D     KL=IAND(STATE(5),377B)
D     WRITE(LUOXXX,9852)FLDCNT,KL,INPITL,INPSTA,ITEMTP,ITEMLN 
D    .,(INPBUF(K),K=1,KM) 
D9852 FORMAT(" FLD"I3" ON CARD, START COL="I3", ITL="I3", IST="@7,
D    .", ITEM: [TYPE="I1" LEN="I3"]",8(/8X,8@8))
C#####################################################################
C 
C-----ANALYSE ANSWER; PARSE INPUT BUFFER
C 
 3300 KEYN=INPSTA 
      IF(KEYN .EQ. 0)  GO TO 3600 
C-----CHECK KEY LEGALITY
      I=OBULN+7 
      IF(KEYN .GT. IAND(OBUF(I),77B))  GOTO 3515
C-----PREFIX KEY USED ? 
      IF(INPITL .EQ. 0)  GOTO 3510
      IF( IGETB(INPBUF,INPITL)-140B  .NE. 
     .        IAND(IALF2(OBUF(I)),370B)/10B)   GOTO 3510
      IF(KEYN .GT. 10)  GOTO 3517 
      INPITL=INPITL-1 
      KEYN=KEYN+IAND(OBUF(I),77B) 
 3510 KEYBPT=OBULN+IGETB(OBUF(OBULN+10),KEYN)-2 
      IF(KEYBPT .NE. OBULN-2)  GOTO 3520
 3515 INPITL=INPITL+1 
 3517 CALL PUTCA(INPBUF,1H ,INPITL) 
      GOTO 3550 
 3520 KEYN=OBUF(KEYBPT) 
C#####################################################################
D     KK=2HVL 
D     KN=2H 
D     IF(.NOT. ISBIT(KEYN,15)) GOTO 9566
D     KK=2HFC 
D     KN=IASC(IAND(IRS8(KEYN),77B)) 
D     KL=IAND(OBUF(KEYBPT),377B)
D     KL=(KL+1)/2 
D     CALL MOVEW(OBUF(KEYBPT+1),ITEMPX,KL)
D     GOTO 9564 
D9566 KL=IRS8(OBUF(KEYBPT)) 
D     CALL MOVCA(OBUF(KEYBPT),2,ITEMPX,1,KL)
D     KL=(KL+1)/2 
D9564 WRITE(LUOXXX,9567)KEYBPT,KEYN,KK,KN,(ITEMPX(IX),IX=1,KL)
D9567 FORMAT("  KEY ADDR:",I4",   KEY ASSIGNEMENT IS:"@8,"  IT IS A ",A2, 
D    .,X,A2,/,"  KEY LABEL OR VALUE: ",30A2)
C#####################################################################
C------FUNCTION OR VALUE ?
      IF( ISBIT(KEYN,15) )  GOTO 3600 
C-----IT IS A VALUE, STORE THE VALUE IN THE BUFFER
      IF( USFKV(OBUF(KEYBPT),INPBUF,INPITL) ) 
     .            CALL TMPER(IERTN,49,FORMN,LU,124,1) 
 3550 KEYN=0
C-----PARSE INPUT BUFFER FOR SFK AND/OR PROVIDE DEFAULT VALUE 
 3600 INLNGT=INPITL 
      K=INPITL
      IF(ISBTW(IAND(IRS8(KEYN),77B),5,9))GO TO 3601 
      CALL MOVEW(ZERO,OUTBUF,2) 
      IF(CALCFL)GO TO 3602
      DDSPV=DITMTP.EQ.ITEMTP
      IF(ITEMTP.EQ.1.OR.ITEMTP.EQ.2)GO TO 3605
      CALL BLANC(OUTBUF,10) 
      DDSPV=.FALSE. 
      GO TO 3605
3601  IF(.NOT.(CALCFL.AND.KEYN.EQ.0))GO TO 3610 
3602  DDSPV=.FALSE. 
      CALL MOVEW(CALCBU,OUTBUF,2) 
3605  CALL FMTXX(ITEMTP,.TRUE.,DDSPV ,OBUF(DOBUPT), 
     *          OUTBUF,INPBUF,INLNGT,TEMPB,OBUF(OBULN), 
     *          FORMN,LU,IERTN) 
      K=INLNGT
      GO TO 3611
3610  CALL FMTXX(ITEMTP,KBINP(I),ISBIT(STATE,13),OBUF(DOBUPT),
     .       STATE(EDITPT+IAND(STATE(EDITPT),377B)),INPBUF,INLNGT,
     .       TEMPB,OBUF(OBULN),FORMN,LU,IERTN)
3611  CONTINUE
C###################################################################### 
D     WRITE(LUOXXX,9568)ITEMTP,INLNGT,(TEMPB(IX),IX=1,(INLNGT+1)/2) 
D9568 FORMAT(" /TMP, AFTER FMTXX, ITEMTP = "I6," INPLEN=",I6, 
D    *       10(/,1X,35A2)) 
C#####################################################################
C-----ECHO THE INPUT ON THE PRINTER IF REQUESTED
C     WRITE(1,95689) STATE(2) 
C95689 FORMAT("ZTMP : 1085 STATE(2)="@6)
      IF( ONLPR(I) ) GOTO 3700
      I=1 
      CALL BLANC(OUTBUF,22) 
C-----IF A STRING HAS BEEN ENTERED BEFORE THE SFK, ECHO IT ALSO 
      IF(K.EQ.0 .AND. KEYN.NE.0)  GOTO 3650 
      J=INLNGT
      IF(J.GT.20)J=20 
      CALL MOVCA(TEMPB,1,OUTBUF,1,J)
      CALL JUSTF(OUTBUF,1,20,0) 
      IF(KEYN .EQ. 0)  GOTO 3640
      OUTBUF(11)=6400B
      I=22
 3650 CALL MOVCA(OBUF(KEYBPT+1),1,OUTBUF,I,IAND(OBUF(KEYBPT),377B)) 
      CALL JUSTF(OUTBUF,I,20,0) 
 3640 OUTLEN=20+I 
      INPLEN=0
      CALL MOVEW(TEMPB,INPBUF,100)
C --- ECHO TO PRINTER.
C     WRITE(1,36409)
C36409 FORMAT("ZTMP : 'ECHO TO PRINTER'") 
      OUTDEV=2
      CALL TMSUB(IOMODL)
      CALL MOVEW(INPBUF,TEMPB,100)
C 
C --- ENTER KEY?
C 
3700  IF(KEYN .EQ. 0)  GOTO 4000
C 
C-----IT IS A FUNCTION, EXECUTE THE FUNCTION EDIT 
      KEYN=IAND(IRS8(KEYN),177B)
C 
C#################################################################
D     WRITE(LUOXXX,9678)KEYN,EDITPT,STATE(EDITPT),STATE(EDITPT) 
D9678 FORMAT(" /TMP: AT FUNCTION EDIT:",/,
D    ."     KEYN( FOR FEDIT )=",I5," EDITPT=",I5," STATE(EDITPT)=", 
D    .@8," = ",I6,/)
C################################################################## 
      IF( FEDIT(KEYN,STATE(EDITPT)) )  GOTO 9000
      KEYN=IAND(KEYN,77B) 
C-----DISPATCH ON FUNCTION NUMBER 
C###############################################################
D     WRITE(LUOXXX,9234)KEYN
D9234 FORMAT(//,"AT FUNCTION DISPATCH, KEYN=",I5) 
C###############################################################
      GOTO (4500,4300,4400,4200,4700,4700,4700,4700,4700,9000,
     .5000,5100,5200,4500,9000),KEYN
C 
C-----FUNCTION'S PROCESSOR
C 
C-----ENTER KEY                                *****  FNB #  0  ********
 4000 IF(WAITC)  GOTO 9000
      IF(CALCFL)GO TO 4060
      IF(INPITL .NE. 0)  GOTO 6000
C-----ENTER KEY ONLY: DEFAULT VALUE OR SAME VALUE IF RECALL 
      IF(ENDBK(I))  GOTO 4450 
      GOTO 6100 
C-----ENTER KEY IN CALCULATOR MODE
 4060 IF(CALCIP)  GOTO 9000 
      CALCFL=.FALSE.
      GOTO 6000 
C-----SRQ  RESET THE TERMINAL                  *****  FNB # 128 ********
C     AND RESTART AT THE SAME POINT.
 4100 OUTDEV=100001B
C-----IF CARD READER INPUT, SWITCH TO KEYBOARD INPUT
      IF(KBINP(I))GO TO 3270
      LITE2=IAND(LITE2,377B)
      OUTLEN=0
      IF(INPDEV .EQ. 0) GOTO 3230 
      DEFKB=.TRUE.
      GOTO 3260 
C-----FNUM#4 "ABORT TRANSACTION"               *****  FNB #  4  ********
 4200 IF(INPITL .NE. 0)  GOTO 9000
C-----IF ON LINE OR OFF LINE PRINT OUT IS REQUESTED PRINT "----------"
 4210 IF(IAND(ITT,1400B).EQ.0)  GOTO 4250 
      CALL MOVEW(20H--------------------,OUTBUF,10) 
      CALL MOVEW(LFLF,OUTBUF(11),5) 
      OUTLEN=30 
      INPLEN=0
      OUTDEV=2
      LITE1=0 
      LITE2=0 
      CALL TMSUB(IOMODL)
      GOTO 4250 
 4231 IF( ISBIT(ITT,0) )  CALL TMCBD(IUSER) 
 4233 ITT=0 
C-----EXIT THIS TRANSACTION AND RETURN TO ASK  "TS#-SC ?" 
 4250 CONTINUE
CREQ  CALL DMPTM(6,LU,50,14H TBULK AT 4250,14,1)
      CALL TBULK(IDBNUM)
C-----RESET THE STOP-INHIBIT FLAG SO ONE CAN STOP TMP 
      CALL TMSIF
      SQUAL=11
      JNDEX=LU
C-----CLOSE THE TRANSACTION SPECIFICATION 
      CALL TMSUB(TSMG)
      ASSIGN 4275 TO K
      IF(FMGST .NE. 0)  CALL TMPER(K,49,FORMN,LU,131,FMGST) 
 4275 IF( ISBIT(ITT,0) )  CALL TMCBD(IUSER) 
      IF( ISBIT(ITT,1) )  CALL TMCBD(FAFRTB)
      CALL TMCBD(FORMN,NUQ) 
      GOTO 400
C-----FNUM#2 "RECALL"                          *****  FNB #  2  ********
 4300 IF(INPITL .NE. 0)  GOTO 9000
C     WRITE(6,43009) INPITL,CALCFL,STATE(4),BKSFL,WAITC 
C43009 FORMAT(" INPITL="@6", CALCFL="@6", STATE(4)="@6
C    +       ", BKSFL="@6", WAITC="@6)
      IF(CALCFL) GOTO 9000
      K=-1
C-----IF IN PLACE OF CARD READER INPUT, UPDATE CR POINTER 
      IF( KBINP(I) )  GOTO 4305 
      FLDCNT=FLDCNT-1 
 4305 IF(BKSFL)  GOTO 4310
      BKSQ=SQUAL
      BKIN=INDEX
      BKJN=JNDEX
 4310 FORWIP=.FALSE.
      BKSIP =.TRUE. 
      BKSFL =.TRUE. 
      IF(WAITC)  GOTO 4350
 4315 IF(SQUAL.EQ.0) CALL TMPER(IERTN,49,FORMN,LU,133,SQUAL)
      IF(DOBKS(SQUAL,JNDEX,INDEX,NUQ,NMQ) )  GOTO 4370
      STCNT=STCNT-1 
      K=K+1 
      IF(K .LT. 0)  GOTO 4315 
      GOTO 2320 
C     SPECIAL RECALL IF END HAS BEEN REACHED
 4350 WAITC=.FALSE. 
      BUFULL=0
      BKSQ=4
      GOTO 3120 
C-----ERROR DURING BACKSPACE, THE VERY FIRST STATE IS REACHED 
C     SET ERROR FLAG AND GO RE-GET THE STATE VECTOR 
 4370 ERRFL=1 
      GOTO 2320 
C-----FNUM#3 "SAME VALUE"                      *****  FNB #  3  ********
 4400 IF   ( WAITC )     GOTO 9000
      IF (INPITL .NE. 0) GOTO 9000
      IF   ( CALCFL )    GOTO 9000
      IF ( ENDBK(J) )  GOTO 4430
      I = IPT(INDEX-1,2)
      IF (INDEX .GT. 1)  GOTO 4435
      IF   ( BEGNFL )    GOTO 9000
 4430 I = OBUFPT
 4435 CALL MOVEW(OBUF(I),INPBUF,(ITEMLN+1)/2) 
C-----ECHO THE SAME VALUE ON PRINTER IF REQUIRED
 4450 IF( ONLPR(I) )  GOTO 6300 
      CALL BLANC(OUTBUF,10) 
      CALL CNVTO(ITEMTP,INPBUF,TEMPB,I) 
      CALL MOVEW(TEMPB,OUTBUF,(I+1)/2)
      CALL JUSTF(OUTBUF,1,20,0) 
      OUTLEN=20 
      OUTDEV=2
      INPLEN=0
      CALL TMSUB(IOMODL)
      GOTO 6300 
C-----FNUM#1 "TRANSACTION COMPLETE"            *****  FNB #  1  ********
4500  CONTINUE
      IF(INPITL .NE. 0)  GOTO 9000
      INPSTA=0
      IF(CALCFL)  GOTO 9000 
C-----CHECK THAT WE ARE AT THE END OF M-QUESTION
      I=INDEX 
      IF(WAITC)  GOTO 4510
      K=SQUAL 
      J=JNDEX 
      IF(DOBKS(K,J,I,NUQ,NMQ))  GOTO 9000 
      IF(FAF .EQ. 0)  GOTO 4505 
      IF(DOBKS(K,J,I,NUQ,NMQ))  GOTO 9000 
 4505 IF(ENDMQ(K,J,NUQ,NMQ))  GOTO 9000 
C 
C-----DATA ARE VALIDATED !
C     REDUCE THE SIZE OF THE COMMON BLOCK # 2 BEFORE THE
C     SUB-PROCESS LAUNCH, TO SAVE ROOM. 
C     EXECUTE LOGGING IF REQUIRED.
C     STORE DATA ON MEDIA USING THE TMSUB "STORA" & "STORB" 
C     BY A SUB-PROCESS LAUNCH.
C 
 4510 STATPT=FORMN
      INDEX=I 
      EDITPT=OBULN
C     I=INDEX+1 
C-----CALCULATE END OF DATA AND START OF IMAGE SAVE RUN TABLE ADDRESS 
C     J=IPT(I,2)
      J=(L2*INDEX)+1+L1 
      K=IMPT(INDEX) 
      ILL=K-J 
C     CALL DMPTM(6,I,3,8H I,J,K   ,8,0) 
C     CALL DMPTM(6,L1,2,8H L1,L2  ,8,0) 
      IF(ILL .LE. 0)  CALL TMPER(IERTN,49,FORMN,LU,125,ILL) 
      L=OBULN-K 
C-----MOVE DOWNWARD THE SAVE RUN TABLE DATA 
      CALL MOVEW(OBUF(K),OBUF(J),L) 
      OBULN=J+L 
C#####################################################################
D     WRITE(LUOXXX,8181)LU,OBULN
D8181 FORMAT(" LU ",I2," BEFORE FIRST TMCBL, OBULN = ",I5)
C#####################################################################
      CALL TMCBL(NUQ,OBULN+31)
C#####################################################################
D     WRITE(LUOXXX,8282)LU,OBULN
D8282 FORMAT(" LU ",I2," AFTER FIRST TMCBL,  OBULN = ",I5)
C#####################################################################
      OBUF(OBULN)=LU
      OBUF(OBULN+1)=ITT 
      OBUF(OBULN+2)=IDBNUM
C-----LOCK THE TRANS. SPEC. FOR THE STORAGE 
      SQUAL=12
      CALL TMSUB(TSMG)
      IF(FMGST .NE. 0) CALL TMPER(IERTN,49,FORMN,LU,122,FMGST)
C-----LOGGING OF THE DATA BUFFER IF NEEDED  === 
      IF( .NOT. ISBIT(ITT,2) )  GOTO 4520 
      CALL CNUMD(FORMN,LOGHD(3))
      CALL TMLOG(LOGHD,OBUF,L1+INDEX*L2)
C-----SAVE IST IN K FOR LATER USE 
      K=IST 
C-----CALL THE STORAGE MODULE 
 4520 CALL NUL(OBUF(OBULN+3),6) 
C 
C  BEFORE THE STORAGE -- UPDATE THE SYSTEM TIME WITH THE TERMINAL 
C      TIME IF THE READ WAS FROM A 3077 
C 
      IF(.NOT.HP3077)GO TO 4521 
      LLL=1 
      IF(ISBIT(ITT,15))LLL=LLL+2
      IF(ISBIT(ITT,14))LLL=LLL+1
      IF(ISBIT(ITT,13))LLL=LLL+3
      OBUF(LLL)=TRMHR 
      OBUF(LLL+1)=TRMMN 
4521  CALL LOGEV(ICOM00(2),LU,1000,0,ITSN,OBUF(OBULN+3))
C 
C --- LOGGING WITH IMAGE? 
C 
      IF(.NOT.ISBIT(ISTSAV,7)) GO TO 4522 
      IF(.NOT.ISBIT(ITT,1)) GO TO 4524
C 
C --- YES.  CALL STORAGE ROUTINE & WAIT FOR IT TO COMPLETE. 
C 
C     CALL DMPTM(6,LU,100,6H1CB 1 ,6,1) 
C     CALL DMPTM(6,NUQ,007,6H0CB 2 ,6,1)
C     CALL DMPTM(6,FORMN,200,6H0CB 3 ,6,1)
C     CALL DMPTM(6,IUSER,332,6H0CB 4 ,6,1)
C 
C          FIRST SAVE CB 2 IN CB 5 SO STORA CANNOT MODIFY IT
C 
      CALL MOVEW(NUQ,FAFRTB,OBULN+31) 
  
C 
C          CALL STORA 
C 
      CALL TMSUB(STORAG)
C 
C          RESTORE CB 2 TO WHAT IT WAS BEFORE THE TMSUB CALL
C 
      CALL MOVEW(FAFRTB,NUQ,OBULN+31) 
C 
C          "BEEP" IF LOGGING WAS SUCCESSFUL (STATUS SAVED IN K) 
C 
4524  IF(K.LT.0)GO TO 4525
      INPLEN = 0
      OUTDEV = 1
      IF(IOMODL(3) .NE. 2H5 )GO TO 45255
      CALL MOVEW(LOGACK,OUTBUF,4) 
      OUTLEN=8
      GO TO 45256 
45255 OUTBUF=LOGACK 
      OUTLEN=2
45256 CALL TMSUB(IOMODL)
C     CALL DMPTM(6,LU,100,6H1CB 1 ,6,1) 
C     CALL DMPTM(6,NUQ,007,6H0CB 2 ,6,1)
C     CALL DMPTM(6,FORMN,200,6H0CB 3 ,6,1)
C     CALL DMPTM(6,IUSER,332,6H0CB 4 ,6,1)
4525  IF(ISBIT(ITT,1)) GO TO 4523 
C 
C --- NO, NOT LOGGING.  CALL STORAGE ROUTINE BUT DON'T WAIT FOR 
C     IT TO COMPLETE, IE, JUST LAUNCH IT. 
C 
4522  CALL TMPRO(2,STORAG,NUQ)
C 
C-----EXECUTE THE OFF-LINE PRINT-OUT IF REQUIRED. 
C 
4523  IF( ISBIT(ITT,9) )  CALL TMSUB(OFLPO) 
C-----RESTORE VARIABLE, CB LENGTH AND CONTINUE
      OBULN=EDITPT
      CALL TMCBL(NUQ,OBULNX+7)
      BEGNFL=.FALSE.
      IF(INDEX .EQ. ENDCHN)  GOTO 4540
      IF(INDEX .GT. ENDCHN)  CALL TMPER(IERTN,49,FORMN,LU,141,INDEX)
C-----IF BUFFER FULL, RESTART AT BEGINNING OF M-QUESTION
      SQUAL=2 
      IF( BUFULL .NE. 0 )  GOTO 2050
C-----FNUM#14  "TC+ABORT"                      *****  FNB # 14  ********
4540  IF ( KEYN .EQ. 14 )  GOTO 4210
C-----THIS IS TRANSACTION COMPLETE ONLY, RESTART THE SAME TS
 4560 SQUAL=1 
      IX=4560 
C     WRITE(1,31789) IX,OUTLEN
      KLUGE=1 
      IF( ISBIT(ITT,1) )  GOTO 2020 
      GOTO 2050 
C-----COMPUTATION FUNCTIONS (CALCULATOR MODE)  *****  FNB # 5-9  *******
 4700 IF(WAITC)  GOTO 9000
      IF(ICNVT(I))GO TO 9000
      CALL MOVEW(INPBUF,CALCBU,2) 
4730  IF(CALCU(ITEMTP,KEYN,INPITL,CALCFL,CALCIP,CALCBU,LSTCLC)) 
     *                     GO TO 4731 
      GO TO 4732
C 
C  OVERFLOW ERR IN CALCULATOR MODE -- ISSUE --13-- ERROR
C 
4731  ERRFL=13
C***  CALL DMPTM(6,IMGSTA,10,10H 4731 ERR ,0,0) 
      GO TO 9100
C######################################################################## 
D9854 CALL MOVEW(CALCBU,R,2)
D     CALL MOVEW(CALCBU(3),S,2) 
D     WRITE(LUOXXX,9855)ITEMTP,KEYN,INPITL,INLNGT 
D    *,CALCFL,CALCIP,R,CALCBU(1),S,CALCBU(3)
D9855 FORMAT(/,3X,"/ZTMP:  ITEMTP=",I5,/,11X, 
D    *"KEYN=",I5,/,11X,"INPITL=",I5,/,11X,"INLNGT=",I5,/,11X, 
D    *"CALCFL=",L5,/
D    *11X,"CALCIP=",L5,/,18X,"CALCBU(1)=",F10.4,I10,/,18X,
D    *"CALCBU(3)=",F10.4,I10,/) 
C#######################################################################
C 
C  CALCULATION OK 
C 
4732  OUTLEN=0
      IF(KEYN.EQ.1)GO TO 3200 
C-----IT IS OK TO STORE INTO 'OUTBUF' BECAUSE IT IS ONLY INTEGER OR REAL
      CALL CNVTO(ITEMTP,CALCBU,OUTBUF,OUTLEN) 
      CALL JUSTF(OUTBUF,1,OUTLEN,1) 
      GO TO 3200
C-----FNUM # 11 "CONTINUE TO NEXT QUESTION"    *****  FNB #  11  *******
 5000 IF(WAITC)  GOTO 9000
      IF(INPITL .NE. 0)  GOTO 9000
      IF( .NOT. ISBIT(STATE,8) )  GOTO 6350 
C     THIS TS DELETE, IF NOT THE LAST QUESTION FORGET IMAGE EDIT
      IF( ISBIT(STATE(EDITPT),11) )  STATPT=STATPT+3
      IF( .NOT. ISBIT(STATE,9) )  GOTO 6600 
C     THIS IS THE LAST QUEST. OF A TS-DELETE-IMAGE, REMOVE THAT ENTRY 
C     FORM THE OUTPUT BUFFER
      IF(SQUAL .EQ. 1)  GOTO 3079 
C-----FNUM # 12 "NEXT ENTRY IN AN CHAIN"       *****  FNB #  12  *******
 5100 IF(WAITC)  GOTO 9000
      IF(INPITL .NE. 0)  GOTO 9000
      IF(SQUAL .EQ. 1)  GOTO 9000 
      INDEX=INDEX-1 
      JNDEX=NMQ 
      IF( .NOT. (ENDBK(I)) )  GOTO 2600 
      BKIN=BKIN-1 
      ENDCHN=ENDCHN-1 
      K=BKIN-INDEX
      IF(K .LE. 0)  GOTO 2600 
      ITO=L1+(INDEX*L2) 
      CALL MOVEW(OBUF(ITO+L2),OBUF(ITO),K*L2) 
      ITO=IMPT(BKIN)
      CALL MOVEW(OBUF(ITO-6),OBUF(ITO),-K*6)
      GOTO 2600 
C-----FNUM # 13 "DELETE ENTRY IN DATA BASE"    *****  FNB # 13  ********
 5200 IF(WAITC)  GOTO 9000
      IF(INPITL .NE. 0)  GOTO 9000
      FORWJN=NMQ
      IF(SQUAL .EQ. 1)  FORWJN=NUQ
      FORWIP=.TRUE. 
      GOTO 6350 
C 
C     EDIT SECTION. 
C     ============= 
C 
C 
C-----CLEAR RECALL FLAG "BKSFL" IF THIS STATE IS THE ONE
C     WERE THE RECALL HAS STARTED.
C    -CONVERT DATA. 
C    -EXECUTE THE STANDARD EDIT PROGRAM.
C    -EXECUTE THE IMAGE EDIT (IF NEEDED). 
C    -CALL THE USER EDIT PROGRAM (IF NEEDED). 
C    -STORE DATA IN OUTPUT BUFFER.
C    -CHECK IF THE OUTPUT BUFFER IS FULL. 
C 
 6000 IF ( ENDBK(I) )  GOTO 6100
C 
C-----CONVERT THE DATA INTO BINARY AND MOVE THEM INTO 'INPBUF'
C 
 6100 IF ( ICNVT(I) )  GOTO 9000
D     WRITE(LUOXXX,9859)
D9859 FORMAT(2X," /TMP: AFTER THE CNVTI:")
D     CALL PRT(LUOXXX,LU,ITEMTP,INPBUF,KEYN)
C 
C-----PERFORM VALUE EDIT
C 
 6300 IF ( VALCK(.FALSE.) )  GO TO 9000 
C 
C-----MOVE DATA INTO THE TERMINAL BUFFER 'OBUF' 
C 
 6350 CALL MVITM(INPBUF,OBUF,ITEMTP)
      STATPT=IMAGPT 
C 
      IF( .NOT. ISBIT(STATE(EDITPT),11) )  GOTO 6600
C 
C-----PERFORM IMAGE EDIT
C 
C     GET IMAGE EDIT CODE:
C         1 - KEYED DBGET ON EXISTING RECORD
C         2 - KEYED DBGET AND LOCK ON NON-EXISTING RECORD (FOR ADD) 
C         3 - KEYED DBGET AND LOCK FOR DELETE 
C         4 - DBFND 
C 
      IMECD=IAND(STATE(IMAGPT),17B) 
      LOCKW=0 
      IF(ISBIT(STATE(IMAGPT),13))  LOCKW=100011B
C-----IF FOR A DETAIL, SET THE NON-EXCLUSIVE LOCK BIT 
      IF ( IMECD.EQ.1 .AND. 
     .   .NOT. ISBIT(STATE(IMAGPT),14)) CALL SETBT(LOCKW,2,1) 
      K=STATE(IMAGPT+1) 
      I=IPT(INDEX,IMAGPT+1) 
C#####################################################################
D     WRITE(LUOXXX,9861)STATE(IMAGPT),IMECD,K,LOCKW,IMAGEX(7) 
D9861 FORMAT("  IMAGE EDIT:"@7,"  EDIT CD="I1" ITM#-DS#"@7, 
D    .",   LOCKW="@6" LOCKID="@7) 
C#####################################################################
C 
C     SET IRET TO RETURN NO DATA
C 
      IRET=0
      GOTO (6390,6400,6400,6550),IMECD
C 
C     IMAGE EDIT CODE 1, RETURN DATA ENTRY
C 
 6390 IRET=40040B 
C=====IMAGE EDIT # 1
 6400 CONTINUE
      CALL TBGET(IDBNUM,IGETB(K,2),7,IMGSTA,IRET,TEMPB,OBUF(I),LOCKW) 
D     WRITE(LUOXXX,9230)IMGSAV
D9230 FORMAT(" 7**ISAVRT",3O7/10X,7O8)
C#####################################################################
D     WRITE(LUOXXX,9862)IMECD,IMGSTA,IMAGEX(7),ISAVRT 
D9862 FORMAT("  AFTER DBCALL (EDIT DC="I1"), IMG STAT:"4I6,3X,
D    ."LOCKID="@7,/"               RUN TABLE:"7I6)
C#####################################################################
      IF(IMGSTA.NE.400 .AND. IMGSTA.NE.401)  GOTO 6408
 6405 ERRFL=50
      GOTO 9020 
 6408 ASSIGN 6409 TO IK 
      IF(IMGSTA.NE.0 .AND. IMGSTA.NE.107) 
     .     CALL TMPER(IK,49,FORMN,LU,180+IMECD,IMGSTA)
 6409 GOTO (6410,6450,6500),IMECD 
 6410 IF(IMGSTA .NE. 0)  GOTO 9000
      CALL MOVEW(TEMPB,IMGBUF,IMGSTA(2))
C-----IF UPDATE/DELETE IN THE MASTER, SAVE RTB FOR STORAGE STATE
      IF( ISBIT(STATE(IMAGPT),14) .AND. ISBIT(STATE(IMAGPT),13) .AND. 
     .    SQUAL.EQ.1) CALL MOVEW(IMGSAV,OBUF(IMPT(INDEX)),10) 
      GOTO 6590 
C=====IMAGE EDIT # 2
C     MAKE SURE THAT ITEM HAS NOT BEEN FOUND
 6450 IF(IMGSTA .EQ. 107)  GOTO 6590
C        IF ITEM HAS BEEN FOUND, THEN ERROR HAS OCCURRED
         IF(IMGSTA.NE.0)GO TO 9000
C           UNLOCK ITEM THAT HAS BEEN FOUND 
            CALL TBGET(IDBNUM,IGETB(K,2),7,IMGSTA,0,TEMPB,OBUF(I),
     .      100002B)
            GO TO 9000
C 
C=====IMAGE EDIT # 3
C     CHECK FOR EMPTY CHAIN SO THAT DELETE MAY BE EXECUTED
 6500 ASSIGN 6501 TO IK 
      IF(IMGSTA.NE.0) CALL TMPER(IK,49,FORMN,LU,183,IMGSTA) 
C 
C     GET NO. OF DETAIL DS. CHAINED TO MASTER 
C 
 6501 KKK=IMAGPT+3
      IF(STATE(KKK).LE.0)GO TO 6590 
         DO 6505 KK=1,STATE(KKK)
C 
C           IF TBFND FAILS WITH ERROR 156, THEN CHAIN FROM MASTER 
C           TO DETAIL IS EMPTY.  ALL DETAIL DATA SETS MUST BE CHECKED.
C 
            CALL TBFND(IDBNUM,IGETB(STATE(KK+KKK),2),1,IMGSTA,
     *                 IGETB(STATE(KK+KKK),1),OBUF(I))
            IF(IMGSTA.NE.156)GO TO 9000 
6505     CONTINUE 
      GOTO 6590 
C 
C=====IMAGE EDIT # 4
C 
6550  CONTINUE
      CALL TBFND(IDBNUM,IGETB(K,2),1,IMGSTA,IGETB(K,1),OBUF(I),LOCKW) 
C#####################################################################
D     WRITE(LUOXXX,9863)IMGSTA,IMAGEX(7),ISAVRT 
D9863 FORMAT("  AFTER DBFND  (EDIT CD=4), IMG STAT:"4I6,3X"LOCKID=",
D    .   @7,/"               RUN TABLE:"6I6)
C#####################################################################
      IF(IMGSTA.EQ.400 .OR. IMGSTA.EQ.401)  GOTO 6405 
      IF(IMGSTA .NE. 0)  GOTO 9000
C-----CHECK CHAIN LENGTH (32-BIT INTEGER CHECK FOR 0) 
      IF(IMGSTA(5)+IMGSTA(6) .EQ. 0)  GOTO 9000 
C-----SAVE THE RUN TABLE TO CHOOSE THE SHORTEST CHAIN LATER 
      CALL MOVEW(IMGSAV,XRTB(1,JNDEX),10) 
C 
C     SAVE CHAIN LENGTH (32-BIT INTEGER SAVE) 
C 
      XRTB(2,JNDEX)=IMGSTA(5) 
      XRTB(3,JNDEX)=IMGSTA(6) 
C 
C-----END OF IMAGE EDIT, PRESET STATE POINTER 'STATPT' FOR THE USER EDITR 
 6590 STATPT=STATPT+13
 6600 IF( .NOT. ISBIT(STATE(EDITPT),10) ) GOTO 6700 
C 
C-----CALL THE USER EDIT MODULE 
C 
C 
C  FIRST, RECALCULATE THE STATE POINTER 
C 
C     TO TAKE CARE OF A CHANGE IN THE TS WHEN BOTH IMAGE EDIT 
C 
C       AND USER EDITS ARE PRESENT IN THE SAME STATE
C 
      IF(ISBIT(STATE(EDITPT),10).AND.ISBIT(STATE(EDITPT),11)) 
     .           STATPT=STATPT+7
C 
C  SET UP THE USER COMMON BLOCK 
C 
      CALL SUBUF(FORMN,ITEMTP,BKSFL,INDEX,STATPT,IUSER) 
      CALL TMSUB(STATE(STATPT)) 
      IF(IST .NE. 0)  CALL TMPER(IERTN,2,FORMN,LU,STATE(STATPT),IST)
      IF(IUSER(10) .EQ. 0)  GOTO 6700 
C-----IF USER EDIT ON CARD INPUT, DO NOT USE USER BCKSP FLAG
      IF( .NOT. KBINP(I) )  GOTO 9000 
      ERRFL=1 
      K=IUSER(11) 
      IF(K .LT. 0)  GOTO 4305 
      GOTO 9000 
C 
C-----FORWARD SPACING IN THE TRANSACTION
C 
 6700 IF( .NOT. FORWIP )  GOTO 6800 
 6720 IF(ITEMTP.NE.3)  CALL TMPER(IERTN,49,FORMN,LU,171,ITEMTP) 
      IF(JNDEX .GE. FORWJN)  FORWIP=.FALSE. 
 6800 CONTINUE
C#########################################################
D     I=IPT(INDEX,2)
D     K=IMPT(INDEX) 
D     QZZ = ENDMQ(SQUAL,JNDEX,NUQ,NMQ)
D     WRITE(LUOXXX,9873)JNDEX,INDEX,I,OBUFPT,K,SQUAL,NUQ,NMQ,QZZ
D9873 FORMAT(" /TMP: END OF STATE J="I2", I="I3",  OBUFPT="2I7, 
D    .", OBIMPT="I7,/," SQUAL=",I7," NUQ/NMQ=",I5,"/",I5," ENDMQ=",L3)
D     CALL PRT(LUOXXX,LU,ITEMTP,OBUF(OBUFPT),KEYN)
C######################################################## 
      IF( NMQ .EQ. 0   .AND.
     . ( .NOT.  ENDMQ(SQUAL,JNDEX,NUQ,NMQ)) )  GOTO 7000
      IF(ENDMQ(SQUAL,JNDEX,NUQ,NMQ))  GOTO 2600 
C     CALL DMPTM(6,ITEMLN,2,10H ITEMLN,OB,10,0) 
C     CALL DMPTM(6,INDEX,4,10H INDEX,L2 ,10,0)
C 
C --- IF THIS IS 3077 OR AUTO-COMPLETE TS, THEN SET WAITC.
C 
      IF(HP3077 .OR. ISBIT(ITT0,15)) GO TO 7000 
C 
C --- THIS IS LAST M-QUES, SO IF INPUT WAS FROM USER WRITTEN DATA 
C     MODULE, THEN GO SET WAITC.
C 
      IF(IAND(STATE(4),37B).EQ.31) GO TO 7000 
C 
C 
      ITEMPL=OBUFPT+((ITEMLN+1)/2)
C************************************************** 
D     IKK = IMPT(INDEX+1) 
D     IJJ = ITEMPL +L2
D     WRITE(LUOXXX,6548)IJJ,IKK 
D6548 FORMAT (" /ZTMP: AT BUFFER FULL TEST: ",2I5)
C************************************************** 
      IF((ITEMPL+L2) .LT. IMPT(INDEX+1))  GOTO 2600 
      BUFULL=INDEX
      IF(SQUAL .NE. 2)  CALL TMPER(IERTN,49,FORMN,LU,190,SQUAL) 
      IF(ITEMPL .GT. IMPT(INDEX))  CALL TMPER(IERTN,49,FORMN, 
     +                                        LU,195,INDEX) 
C-----SET WAIT TRANSACTION COMPLETE FLAG !! 
 7000 WAITC=.TRUE.
      FORWIP=.FALSE.
C-----SWITCH ON LIGHT "TERMINATE TRANSACTION !" 
      CALL PUTCA(LITE2,LITTCP,2)
C-----SWITCH OFF THE QUESTION AND THE DISPLAY LIGHT AND CLEAR DSP 
      OUTDEV=0
      IF(JNDEX.NE.NMQ+1 .OR.  NMQ.EQ.0)LITE1=0
      OUTLEN=0
C******************************************** 
D     IJJ = ITEMPL + L2 
D     IKK = IMPT(INDEX+1) 
D     WRITE(LUOXXX,6548)IJJ,IKK 
D     WRITE(LUOXXX,6547)LITE1,LITE2 
D6547 FORMAT(" /ZTMP:GOING TO 3200 FOR MORE INPUT. LITE1/LITE2= ",2@7)
C******************************************** 
      GOTO 3200 
C 
C     E R R O R   S E C T I O N  !
C     ============================
C 
 9000 ERRFL=1 
 9020 FORWIP=.FALSE.
C-----IF FROM KEYBOARD INPUT, OUTPUT ERROR
C################################################################## 
D     QXY=KBINP(I)
D     WRITE(LUOXXX,9086)QXY 
D9086 FORMAT(//"IN ERROR SECTION -- CK. KBINP(I) -- EQUALS",L5) 
C################################################################## 
      IF( KBINP(I) )  GOTO 9100 
C-----IF DEFAULTED TO KEYBOARD, OUTPUT ERROR
C#################################################################
D     WRITE(LUOXXX,9087)DEFKB 
D9087 FORMAT(//"IN ERROR SECTION -- CK. DEFKB -- EQUALS",L5)
C#################################################################
      IF( DEFKB )  GOTO 9100
C-----ERROR IS FROM A FIELD ON A CARD, REPORT SEPCIAL ERROR MESSAGE 
C     AND BACKSPACE AT THE BEGINNING OF THE CARD
      ERRFL=11
      COLCNT=IAND(STATE(5),377B)
      IF(.NOT.ISBIT(STATE(4),15))COLCNT=(COLCNT+1)*2
      K=-STCNT
      IF(K .LT. 0)  GOTO 4305 
C-----SWITCH OF THE DISPLAY LIGHT 
 9100 LITE1=IAND(LITE1,177400B) 
      GOTO 3200 
C 
      END 
C#####################################################################
C 
C#####################################################################
D     SUBROUTINE PRT(LUOUT,LU,ITEMTP,IBUF,KEYN),PRINT FOR DEBUG  781013 
D     DIMENSION IBUF(1),ITEMTP(1) 
D     I=1 
D     ITEMLN=ITEMTP(2)
D     IF(ITEMTP .EQ. 0)  GOTO 9880
D     IF(ITEMTP .EQ. 1)  GOTO 9875
D     IF(ITEMTP .EQ. 3)  GOTO 9876
D     IF(ITEMTP .NE. 2)  GOTO 9885
D     CALL MOVEW(IBUF(I),X,2) 
D     WRITE(LUOUT,9877)LU,X 
D     GOTO 9885 
D9876 WRITE(LUOUT,9878)LU,KEYN
D     GOTO 9885 
D9875 WRITE(LUOUT,9872)LU,IBUF(I) 
D9877 FORMAT(" FROM LU#"I2" REAL:"F11.2)
D9878 FORMAT(" FROM LU#"I2" FUNCTION #"I3)
D9872 FORMAT(" FROM LU#"I2" INTEGER: "I7) 
D     GOTO 9885 
D9880 K=(ITEMLN+1)/2
D     WRITE(LUOUT,9882)LU,ITEMLN,(IBUF(JX),JX=I,I+K-1)
D9882 FORMAT(" FROM LU#"I2" STRING: LEN ="I4" BYTES,  VAL:" 
D    .,2(/,12X,32A2)) 
D9885 CONTINUE
D     RETURN
C#####################################################################
D     END 
      SUBROUTINE CALCV(ICOD,ITMTP,IACC,MEM,IER) 
     *, 92080-16510 REV.2026  800513
C 
      I=ICOD+1
      GOTO (100,200),I
C-----FUNCTION IS RESET 
  100 Y=0.
      GOTO 500
C-----FUNCTION IS ARITM. OPERATOR 
  200 CALL MOVEW(MEM,X,ITMTP) 
      CALL MOVEW(IACC,Y,ITMTP)
      IF(ITMTP .EQ. 2)  GOTO 210
      X=MEM 
      Y=IACC
C 
  210 CONTINUE
      Y=Y+X 
C 
C-----RETURN THE VALUE
  500 CALL MOVEW(Y,IACC,ITMTP)
      IER=0 
      IF(ITMTP .NE. 1)  RETURN
         IF(Y.LT.-32768. .OR. Y.GT.32767.)IER=1 
         IACC=Y 
         IF(Y.LT.-32768.)IACC=-32768
      RETURN
      END 
      SUBROUTINE MVITM(IBS,IBD,ITMT), 92080-16510 REV.2026  800513
C 
      DIMENSION IBD(1),ITMT(1)
C 
      CALL MOVEW(IBS,IBD(ITMT(3)),(ITMT(2)+1)/2)
      RETURN
      END 
      FUNCTION MTCHT(ISTATE,ITEMP,IOBUF), 92080-16510 REV.2026  800513
C 
C     THIS FUNCTION COMPARES DATA RETRIEVED BY A TBGET CALL WITH DATA 
C     INPUT BY THE DATACAP USER.  THE ITEMS TO BE COMPARED ARE SPECIFIED
C     IN ISTATE, WHICH CONTAINS THE FAF SPECIFICATIONS. 
C 
C          ISTATE - FAF STATE (OUTPUT BY TGP) 
C          ITEMP  - DATA FROM TBGET CALL
C          IOBUF  - DATA INPUT BY USER
C 
C     MTCHT - TRUE IF IMAGE DATA MATCHES USER DATA
C            - FALSE, OTHERWISE 
C 
      DIMENSION ISTATE(1),ITEMP(1),IOBUF(1) 
      LOGICAL MTCHT,CMPW
      MTCHT=.TRUE.
      J=IGETB(ISTATE,4) 
      IF(J.EQ.0)RETURN
      MTCHT=.FALSE. 
      DO 10 I=1,J 
         K=2*I+1
         IF(.NOT.CMPW(ITEMP(IGETB(ISTATE(K),1)),IOBUF(ISTATE(K+1))
     .     ,IGETB(ISTATE(K),2)))RETURN
10    CONTINUE
      MTCHT=.TRUE.
      RETURN
      END 
C 
C 
      FUNCTION IFCRT(ISTATE,IOUTDV,ITT), 92080-16510 REV.2026  800513 
C 
C     ISTATE  =  CURRENT ISTATE BEING EXECUTED. 
C 
C     IOUTDV =  OUTPUT DEVICE WORD. 
C 
C     THIS FUNCTION WILL DETERMINE IF THE CURRENT STATE BEING EXECUTED WILL 
C     BE GOING TO THE CRT OR ALPHA DISPLAY.  IF SO, IOUTDV (& ULTIMATELY, 
C     OUTDEV IN ZTMP) BIT 1 WILL BE SET AS WELL AS SOME 
C     OF BITS 13-14 AS FOLLOWS: 
C 
C     IOUTDV BIT 2  IF OUTPUT TO CRT
C                0 & 3 IF OUTPUT TO ALPHA DISPLAY 
C                13 IF SCROLLING
C                14 IF LARGE CHARACTER SET. 
C 
C     CALL:  IF(IFCRT(STATE,OUTDEV,ITT)) GO TO CRT ROUTINE
C 
C     RETURN: 
C 
C     IFCRT = .TRUE. IF TS CALLS FOR CRT OR ALPHA DISPLAY.
C                    IOUTDV WILL HAVE APPROPRIATE BITS SET. 
C           = .FALSE.  IF TS DOES NOT SPECIFY ADS NOR CRT.
C                      IOUTDV SET TO 0. 
C 
      DIMENSION ISTATE(1) 
      LOGICAL IFCRT,ISBIT 
      IFCRT=.FALSE. 
      IOUTDV=0
C 
C --- ALPHA DISPLAY?
C 
      IF(ISBIT(ITT,7)) GO TO 60 
C 
C --- EXIT 99 IF NO CRT REQUESTED BY THIS STATE.
C 
      IF(.NOT.ISBIT(ISTATE(6),0)) GO TO 99
      IOUTDV=4
      DO 50 I=14,15 
         IF(.NOT.ISBIT(ISTATE(6),I)) GO TO 50 
         J=I-1
         CALL SETBT(IOUTDV,J,1) 
 50   CONTINUE
      GO TO 77
C 
C --- ALPHA DISPLAY, SO SET BITS 0&3 (FOR DSP) & RETURN A TRUE CONDITION. 
C 
 60   IOUTDV=11B
C 
 77   IFCRT=.TRUE.
C99   WRITE(1,9999) ISTATE(6),IOUTDV,IFCRT
C9999 FORMAT(" IFCRT OF ZTMP, ISTATE(6)="@7", IOUTDV="@7", IFCRT="@7) 
99    RETURN
      END 
      END$