FTN4
C     LIBRARY FOR TMP  (FTN4)   92903-18512 REV.1913  781101
C 
C 
C     NAME:   USFKV,DOBKS,ENDMQ,BKSEN,SUBUF,CCBYT 
C             FEDIT,VEDIT,CNVTI,CNVTO,CALCU 
C     SOURCE: &TMPLB    92903-18510 
C     BINARY: %TMPLB    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    FUNCTIONS: 
C   ----------- 
C                USFKV - STORE KEY VALUE IN THE I/O BUFFER
C                DOBKS - DO BACKSPACE (RECALL FUNCTION) 
C                ENDMQ - END OF TRANSACTION ALLOWED ON THIS STATE ? 
C                BKSEN - END OF BACKSPACE PROCEDURE ? 
C                SUBUF - SET UP BUFFER TO CALL USER EDIT MODULES
C                CCBYT - CONDITION CODE ON BYTE (NUMERIC-ALPHA-OTHER) 
C                FEDIT - FUNCTION EDIT
C                VEDIT - VALUE EDIT 
C                FMTXX - FORMAT INPUT BUFFER
C                CNVTI - CONVERT INPUT BUFFER  (ASCII --> BINARY) 
C                CNVTO - CONVERT OUTPUT BUFFER (BINARY --> ASCII) 
C                CALCU - ARITHMETIC FUNCTIONS 
C 
C 
C 
C 
C     THIS LIBRARY IS A PART OF THE:
C 
C                      DATA CAPTURE SOFTWARE
C                        ( D A T A C A P )
C 
C     ALL THOSE SUBROUTINES DO NOT USE THE TERMINAL MONITOR 
C     SOFTWARE (TMS). 
C 
C     THOSE MODULE ARE UTILITY SUBROUTINE USED BY  ZTMP 
C                   (TRANSACTION MONITOR PROGRAM) 
C 
C 
C**********************************************  F. GAULLIER  (HPG)  ***
C 
C 
C 
      LOGICAL FUNCTION USFKV(KEYVA,IB,I), 92903-16510 REV.1913  790104
C 
C   THIS SUBROUTINE STORE IN THE BUFFER "IB" THE VALUE OF THE SFK 
C     DEFINED IN "KEYVA". 
C     "I" INDICATE THE POSITION OF THE LAST CHARACTER IN "IB", (1ST IS 1) 
C     THE VALUE MUST BE STORED AT I+1, "I" WILL BE UPDATED
C     TO BE THE CHARACTER NUMBER OF THE LAST CHAR. OF THE KEY VALUE,
C     (IE AS IT WAS WHEN USFKV WAS CALLED)
C 
C 
      DIMENSION IB(1),KEYVA(1)
      LOGICAL ISBIT 
C 
      IRS8(M0)=IAND(IALF2(M0),377B) 
C 
      USFKV=.TRUE.
C-----IF IT IS NOT A VALUE, RETURN ERROR
      IF(ISBIT(KEYVA,15))  RETURN 
      L=IRS8(KEYVA) 
      IF(L .EQ. 0)  RETURN
      IF(I+L .GE. 127)  L=128-I 
      IF(L .LE. 0) RETURN 
      CALL MOVCA(KEYVA,2,IB,I+1,L)
      I=I+L 
      USFKV=.FALSE. 
      RETURN
      END 
      LOGICAL  FUNCTION DOBKS(ISQ,J,I,NUQ,NMQ), 92903-16510 REV.1805  77
     .0602
C 
C   THIS FUNCTION EXECUTE A BACKSPACE IN THE STATE TREE.
C     IN OTHERS WORDS IT SET THE "SQ", "INDEX" AND "INDEX-J" FOR
C     THE PREVIOUS STATE IN THE TRANSACTION.
C 
C 
      DOBKS=.TRUE.
      J=J-1 
      IF (J .NE. 0)  GOTO 100 
      J=1 
      IF (ISQ .EQ. 1)  RETURN 
      I=I-1 
      IF(NMQ .NE. 0)  J=NMQ 
      IF (I .NE. 0)  GOTO 100 
      I=1 
      J=1 
      IF (NUQ .EQ. 0)  RETURN 
      ISQ=1 
      J=NUQ 
  100 DOBKS=.FALSE. 
      RETURN
      END 
      LOGICAL  FUNCTION   ENDMQ(ISQ,J,NUQ,NMQ), 92903-16510 REV.1805  77
     .0602
C 
C   THIS FUNCTION INDICATES IF THIS STATE CAN BE THE LAST OF
C     THE TRANSACTION:
C     (LAST U-QUESTION IF NO M-QUESTION  OR 
C     LAST M-QUESTION OF THE M-QUESTION SEQUENCE) 
C 
C 
      ENDMQ = .NOT. (  (ISQ.EQ.2 .AND. J.EQ.NMQ)  .OR.
     . ( NMQ.EQ.0 .AND. ISQ.EQ.1 .AND. J.EQ.NUQ) )
      RETURN
      END 
      LOGICAL FUNCTION BKSEN(BKSFL,FAF,ISQ,I,J,ISQ0,I0,J0), 92903-16510 
     .REV.1913  781101
C 
C   THIS FUNCTION INDICATE IF THE TRANSACTION IS STILL
C     IN BACKSPACE MODE OR NOT. 
C 
C   IT ALSO RESET THE BACKSPACE FLAG IF THE FORWARD SPACING GO
C     OVER THE STACK THAT REQUEST THE BACKSPACE THE 1ST TIME. 
C     THE FLAG RESETED ARE: 'BKSFL' & 'FAF' 
C 
C     BKSEN  IS  .TRUE.  IF INSIDE A BACKSPACE (IF BACKSPACE MODE)
C 
      LOGICAL BKSFL 
      INTEGER FAF 
C 
      IF(.NOT. BKSFL)  GOTO 10
      IF(ISQ.GE.ISQ0 .AND. I.GE.I0 .AND. J.GE.J0) BKSFL=.FALSE. 
  10  BKSEN=BKSFL 
      IF( .NOT. BKSFL .AND. FAF.EQ.2 )  FAF=1 
      RETURN
      END 
      SUBROUTINE SUBUF(ITSN,ITMTP,BKSFL,I,K,IUSER), 92903-16510 REV.1913
     .  790123
C 
C     THIS SUBROUTINE SETUP THE USER BUFFER BEFORE CALLING
C     THE USER DISPLAY OR EDIT MODULE 
C 
      DIMENSION ITSN(1),IUSER(1)
C 
      CALL MOVEW(ITSN,IUSER,3)
      CALL MOVEW(ITMTP,IUSER(4),3)
      CALL MOVEW(BKSFL,IUSER(7),3)
      IUSER(2)=I
      IF(ITSN(2) .EQ. 1)  IUSER(2)=0
      IF(BKSQ .EQ. 1)  IUSER(8)=0 
      J=K+5 
C-----SET THE NO-ABORT BIT IN THE USER MODULE NAME
      ITSN(J)=IOR(ITSN(J),100000B)
      RETURN
      END 
      INTEGER FUNCTION CCBYT(IB,I,J), 92903-16510 REV.1805  770602
C 
C   THIS FUNCTION RETURN THE CONDITION CODE (CC) OF THE BYTE
C     NUMBER "I" IN THE BUFFER "IB", THE BYTE IS RETURNED IN "J". 
C 
C     CC = 0   NUMERIC   0  -->  9
C     CC = 1   ALPHA     A  -->  Z  (UPPER CASE ONLY) 
C     CC = -1  OTHERS 
C 
C 
      LOGICAL ISBTW 
C 
      J=IGET1(IB,I) 
      K=J/256 
      CCBYT=0 
      IF( .NOT.  ISBTW(K,60B,71B) )  RETURN 
      CCBYT=-1
      IF(ISBTW(K,101B,132B)) RETURN 
      CCBYT=1 
      RETURN
      END 
      LOGICAL FUNCTION FEDIT(FNUM,EDITB), 92903-16510 REV.1805  780524
C 
C*****              STANDARD FUNCTION EDITING 
C                   ========================= 
C 
      INTEGER FNUM,EDITB(1) 
      LOGICAL ISBIT 
C 
      IGETX(M)=IGETB(EDITB,M) 
C 
      FEDIT=.FALSE. 
      IF( .NOT. ISBIT(FNUM,6) )  RETURN 
C-----CHECK FLAG 'FEF'
      IF( .NOT. ISBIT(EDITB,15) )  GOTO 200 
      IE=IGETX(7) 
      K=IAND(FNUM,77B)
C 
      DO 100 I=1,IE 
      IF(K .EQ. IGETX(I+7))  RETURN 
  100 CONTINUE
  200 FEDIT=.TRUE.
      RETURN
      END 
      LOGICAL FUNCTION VEDIT(BYPASS,ITMTP,IST,IBUF,IEDPT), 92903-16510 R
     .EV.1913  790104 
C 
C*****              STANDARD VALUE EDIT 
C                   =================== 
C 
      INTEGER CCBYT 
      LOGICAL ISBIT,BYPASS
      DIMENSION IST(1),IBUF(1),ITMTP(1) 
C 
      ITMTP1=ITMTP+1
      ITMLC=ITMTP(2)
      ITMLW=(ITMLC+1)/2 
C-----SET POINTER TO EDIT SPEC. 
      IEDPT=4 
C-----SKIP FUNCTION EDIT SPEC. (IF ANY) 
      IF( ISBIT(IST,15) ) 
     .  IEDPT=IEDPT + (2+IGETB(IST(IEDPT),1))/2 
C 
      GOTO (110,210,310,410),ITMTP1 
C 
C-----STRING
C 
  110 IF( BYPASS )  GOTO 140
      K=1 
      IF( ISBIT(IST,14) )  K=0
      CALL JUSTF(IBUF,1,ITMLC,K)
C-----NOW USE THE EDIT MASK 
  140 IF( .NOT. ISBIT(IST,13) )  GOTO 8000
      IE=ITMLC
      IF(IE .GE. 16)  IE=16 
      IF( BYPASS )  GOTO 160
      DO 150 I=1,IE 
      J=IGET1(IST(IEDPT),I) 
      IF(J .EQ. 1HX)  GOTO 150
      K=CCBYT(IBUF,I,L) 
      IF(J.EQ.1H9 .AND. K.EQ.0)  GOTO 150 
      IF(J.EQ.1HA .AND. K.EQ.1)  GOTO 150 
      IF(L .NE. J)  GOTO 9000 
  150 CONTINUE
  160 IEDPT=IEDPT+(IE+1)/2
      GOTO 8000 
C 
C-----INTEGER 
C 
  210 X=IBUF
C-----INTEGER EDIT
      IF( .NOT. ISBIT(IST,14) )  GOTO 215 
      IF( BYPASS )  GOTO 213
C     MAXIMUM CHECK 
      IF(X .GT. FLOAT(IST(IEDPT)))  GOTO 9000 
  213 IEDPT=IEDPT+1 
  215 IF( .NOT. ISBIT(IST,13) )  GOTO 217 
      IF( BYPASS )  GOTO 216
C     MINIMUM CHECK 
      IF(X .LT. FLOAT(IST(IEDPT)))  GOTO 9000 
  216 IEDPT=IEDPT+1 
  217 GOTO 8000 
C 
C-----REAL
C 
  310 CALL MOVEW(IBUF,X,2)
C-----REAL EDIT 
      IF( .NOT. ISBIT(IST,14) )  GOTO 315 
      IF( BYPASS )  GOTO 313
C     MAXIMUM CHECK 
      CALL MOVEW(IST(IEDPT),Y,2)
      IF(X .GT. Y)  GOTO 9000 
  313 IEDPT=IEDPT+2 
  315 IF( .NOT. ISBIT(IST,13) )  GOTO 317 
      IF( BYPASS )  GOTO 316
C     MINIMUM CHECK 
      CALL MOVEW(IST(IEDPT),Y,2)
      IF(X .LT. Y)  GOTO 9000 
  316 IEDPT=IEDPT+2 
  317 GOTO 8000 
C 
C-----FUNCTION ONLY ITEM
C 
  410 GOTO 9000 
C 
C-----RETURN A SUCCESFULL CONDITION 
C 
 8000 VEDIT=.FALSE. 
      RETURN
C 
C-----ERROR RETURN
C 
 9000 VEDIT=.TRUE.
      RETURN
      END 
      SUBROUTINE FMTXX(ITMTP,KBINP,DDSPV,DSPBF,DEFVA,IBS,LENBT
     .,IBD,KEYVA), 92903-16510 REV.1913  790108 
C 
C*****              FORMAT INPUT BUFFER  (DEFAULT VALUE & SFK VALUE)
C                   ================================================
C 
      INTEGER DEFVA(1),IBS(1),IBD(1),ITMTP(1),DSPBF(1),KEYVA(1) 
     .       ,SFKOFS,SFK0,SFK99,PREFIX
      LOGICAL USFKV,INUM,RNUM,ISBTW,ISBIT,KBINP,DDSPV 
C 
C     KBINP IS TRUE IF INPUT WAS FROM KEYBOARD
C     DDSPV IS TRUE IF DEFAULT VALUE IS THE DISPLAY VALUE 
C 
      DATA SFKOFS/140B/,SFK0/1/,SFK99/26/ 
C 
      IRS8(M0)=IAND(IALF2(M0),377B) 
      IRS11(M3)=IAND(IALF2(M3),370B)/10B
      IRS12(M2)=IAND(IALF2(M2),360B)/20B
C 
      ITMLB=ITMTP(2)
      ITMLW=(ITMLB+1)/2 
C-----IF INPUT IS NOT FROM KEYBOARD, PASSES INPUT BUFFER
      IF( KBINP )  GOTO 3 
      CALL MOVEW(IBS,IBD,(LENBT+1)/2) 
      GOTO 60 
C 
    3 IF(LENBT .NE. 0)  GOTO 10 
C 
C-----TAKE THE DEFAULT VALUE
C 
      IF( DDSPV )  GOTO 5 
      CALL CNVTO(ITMTP,DEFVA,IBD,LENBT) 
      IF(LENBT .GT. 20)  LENBT=20 
      GOTO 60 
C-----THE DEFAULT VALUE IS THE DISPLAYED VALUE
    5 CALL CNVTO(ITMTP,DSPBF,IBD,LENBT) 
      GOTO 60 
C 
C-----TAKE THE VALUE ENTERED BY THE OPERATOR
C 
C-----SEARCH FOR SFK, AND REPLACE THE SFK BY ITS VALUE
C 
   10 PREFIX=IRS11(KEYVA(8))
      LSTSFK=IAND(KEYVA(8),77B) 
C 
      JS=0
      JD=0
   20 JS=JS+1 
      IF(JS .GT. LENBT)  GOTO 50
      K=IGETB(IBS,JS)-SFKOFS
      IF(ISBTW(K,SFK0,SFK99))  GOTO 40
      IF(ISBTW(K,SFK0,LSTSFK))  GOTO 35 
C-----PREFIX KEY ?
      IF(K .NE. PREFIX)  GOTO 30
C-----PROCESS PREFIX KEY
   25 JS=JS+1 
      IF(JS .GT. LENBT)  GOTO 50
      K=IGETB(IBS,JS)-SFKOFS
      IF(K .EQ. PREFIX)  GOTO 25
      IF(ISBTW(K,SFK0,LSTSFK))  GOTO 35 
      IF(K .GT. 10)  GOTO 30
      K=K+LSTSFK
C-----GET KEY VALUE 
   30 IPT=IGETB(KEYVA(11),K)-1
      IF(IPT .EQ. -1)  GOTO 35
C-----INSERT KEY VALUE IN THE BUFFER
      IF( USFKV(KEYVA(IPT),IBD,JD) )  PAUSE 57
      GOTO 20 
C-----THE KEY IS NOT DEFINED, REPLACE IT BY SPACE 
   35 JD=JD+1 
      CALL PUTCA(IBD,1H ,JD)
      GOTO 20 
   40 JD=JD+1 
      CALL PUTCA(IBD,IGET1(IBS,JS),JD)
      GOTO 20 
C-----THE BUFFER HAS BEEN SCANNED, SET THE NEW LENGHT 
   50 LENBT=JD
C 
C-----THE SFK PROCESSING IS DONE, CHECK FOR STRING
C 
   60 IF(ITMTP .NE. 0)  RETURN
C 
C-----IT IS A STRING, COMPLETE WITH TRAILING SPACE IF NEDDED
C 
      K=2*ITMLW-LENBT 
      IF(K.LE.0)  RETURN
      CALL BLAN(IBD,LENBT+1,K)
      LENBT=ITMLB 
      RETURN
      END 
      LOGICAL FUNCTION CNVTI(ITMTP,IBS,ITLG,IBD), 92903-16510 REV.1913
     .790104
C 
C*****              CONVERTION FOR INPUT  (ASCII ---> BINARY) 
C                   ========================================= 
C 
      DIMENSION IBS(1),IBD(1),ITMTP(1)
      LOGICAL INUM,RNUM,ISBTW 
C 
      IRS8(M0)=IAND(IALF2(M0),377B) 
      IRS12(M2)=IAND(IALF2(M2),360B)/16 
C 
      CNVTI=.FALSE. 
      ITMTP1=ITMTP+1
      ITMLC=ITMTP(2)
      ITMLW=(ITMLC+1)/2 
C 
      GOTO (100,200,300,9000),ITMTP1
C 
C-----STRING
C 
  100 IF(ITLG .GT. ITMLC)  GOTO 9000
      CALL MOVEW(IBS,IBD,ITMLW) 
      RETURN
C 
C-----INTEGER 
C 
  200 IF(INUM(IBS,1,ITLG,IBD))  GOTO 9000 
      RETURN
C 
C-----REAL
C 
  300 IF(RNUM(IBS,1,ITLG,IBD))  GOTO 9000 
      RETURN
C 
C-----ERROR RETURN
C 
 9000 CNVTI=.TRUE.
      RETURN
      END 
      SUBROUTINE CNVTO(ITMTP,IBS,IBD,L), 92903-16510 REV.1913  790118 
C 
C*****              CONVERTION FOR OUTPUT  (BINARY ---> ASCII)
C                   ==========================================
C 
      DIMENSION IBS(1),IBD(1),ITMTP(1)
C 
      ITMTP1=ITMTP+1
      ITMLC=ITMTP(2)
C 
C-----CONVERSION FROM BINARY TO ASCII  (WRITE)
      GOTO (2100,2200,2300,2600),ITMTP1 
C-----STRING
 2100 L=(ITMLC+1)/2 
      IF(L .GT. 64)  L=64 
      CALL MOVEW(IBS,IBD,L) 
      L=ITMLC 
      GOTO 8000 
C-----INTEGER 
 2200 CALL JASC(IBS,IBD,1,12) 
      L=12
      GOTO 8000 
C-----REAL
 2300 IBD(8)=2H 
      CALL RASC(IBS,IBD,1,15,2) 
      IF(IBD .EQ. 2H$$)  CALL MOVEW(16H--12--          ,IBD,8)
      L=16
      GOTO 8000 
C-----FUNCTION ONLY 
 2600 IBD=2H
      L=2 
 8000 RETURN
      END 
      LOGICAL FUNCTION CALCU(ITMTP,FNUM,ITL,CALCFL,CALCIP,CALCBU,LAST)
     ., 92903-16510 REV.1913  780203
C 
C     THIS PROGRAM SIMULATES A DESK CALCULATOR
C     IT USE THE NON-POSTFIXE NOTATION. 
C 
C 
      INTEGER DITMTP,FNUM,CALCBU(1),TEMP(4) 
      LOGICAL ISNUL,CALCFL,CALCIP 
      EQUIVALENCE (TEMP,N),(TEMP(3),Y)
C 
      CALL MOVEW(CALCBU,TEMP,4) 
      IF(CALCFL) GOTO 1500
C-----SET CALCULATOR MODE 
      CALCFL=.TRUE. 
      LAST=1
      Y=0.
1500  CALL MOVEW(N,X,ITMTP) 
      IF(ITMTP.EQ.1)  X=N 
      IF(CALCIP)GO TO 1600
      CALCIP=.TRUE. 
      Y=X 
C 
C-----DISPATCH TO PROPER SECTION
C 
1600  FNUM=FNUM-4 
      GOTO (2100,2300,2500,2800,2700),FNUM
C 
C-----DISPATCH FOR THE  2ND LEVEL.
C 
 1800 GOTO (2710,2510,2310,2110,2810),LAST
C 
C-----ERROR RETURN
C 
 1900 CONTINUE
      CALCU=.TRUE.
      GOTO 4500 
C 
C 
C-----PROCESS  FUNCTION "+" 
 2100 ASSIGN 4000 TO LABEL
      J=4 
      GOTO 1800 
 2110 Y=Y+X 
      GOTO LABEL
C-----PROCESS  FUNCTION "-" 
 2300 ASSIGN 4000 TO LABEL
      J=3 
      GOTO 1800 
 2310 Y=Y-X 
      GOTO LABEL
C-----PROCESS  FUNCTION "*" 
 2500 ASSIGN 4000 TO LABEL
      J=2 
      GOTO 1800 
 2510 Y=Y*X 
      GOTO LABEL
C-----PROCESS  FUNCTION "/" 
 2800 ASSIGN 4000 TO LABEL
      J=5 
      GOTO 1800 
 2810 IF(.NOT. ISNUL(X,ITMTP))  GOTO 1900 
      Y=Y/X 
      GOTO LABEL
C-----PROCESS  FUNCTION "=" 
 2700 ASSIGN 2720 TO LABEL
      J=1 
      GOTO 1800 
 2710 IF(ITL .NE. 0)  Y=X 
      GOTO LABEL
 2720 X=Y 
      FNUM=2
      CALCIP=.FALSE.
      GOTO 4100 
C 
C-----RETURN
C 
 4000 FNUM=1
 4100 CALCU=.FALSE. 
4500  CALL MOVEW(X,N,ITMTP) 
      LAST=J
C-----CHECK FOR INTEGER OVERFLOW
      IF(ITMTP .EQ. 2)  GO TO 5000
      N=X 
      IF(X .GE. -32768.  .AND.  X .LE. 32767.)  GO TO 5000
      CALCU=.TRUE.
5000  CALL MOVEW(TEMP,CALCBU,4) 
      RETURN
      END 
      END$