PNDSD SOURCE ROOT SET VOLUME #1 1 NOV 78 22-2362 *P  ASMB,R,L * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: LIMIT INTFC MOD * SOURCE: 92840 - 18001 * RELOC: 92840 - 16001 * * * ************************************************************* * NAM LIMIT,7 92840-16001 REV.1819 780515 EXT XLMIT,.OPTN,PLTER ENT LIMIT * * THIS IS THE INTERFACE MODULE FOR THE LIMIT COMMAND. * SPC 3 * * SPC 3 LIMIT NOP LDA LIMIT JSB .OPTN GO GET PARAMETER ADDRESSES DEF RTN PADR DEF PARM PARAME DEF M6 DEF .1 DEF .5 NUMBER OF PARAMETERS DEF .0 NO OPTIONAL PARAMETERS DEF RETRN RTN JMP CHECK JMP ENTRY * * THIS PORTION OF CODE DETERMINES WHETHER OR NOT CALL IS * INTERACTIVE OR AN ERROR. * CHECK CPA M4 INTERACTIVE JMP *+2 YES JMP ERROR NOT ENOUGH PARAMETERS LDA .2 ADD OFFSET TO CODE FOR INTERACTIVE SELECTION STA INTCD LDA DFINT STA PARM ENTRY JSB XLMIT DEF END PARM BSS 6 END JMP RETRN,I * SPC 2 * * SPC 2 * * * SPC 3 * ERROR LDA PARM+1 STA IGCB JSB PLTER DEF RTNER DEF .43 IGCB NOP RTNER JMP RETRN,I * * CONSTANTS AND STORAGE * DFINT DEF INTCD INTCD NOP M6 DEC -6 M4 DEC -4 .0 OCT 0 .1 OCT 1 .2 OCT 2 .5 OCT 5 RETRN NOP .43 DEC 43 * END   92840-18002 1819 S C0122 LIMIT COMMAND              H0101 @FTN,L C C C CC************************************************************ 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. * CC************************************************************ C C C C NAME: LIMIT C SOURCE: 92840 - 18002 C RELOC: 92840 - 16001 C C C CC*********************************************************** C SUBROUTINE XLMIT(IND,IGCB,P1,P2,P3, 1P4), 92840-16001 REV. 1819 780515 INTEGER GICB,DIGTZ,GRIFX DIMENSION VAR(8),IBUFR(5),VAR1(4),CLPTS(4) EQUIVALENCE (VAR,XMM),(VAR(2),YMM),(VAR(3),V3),(VAR(4),V4) EQUIVALENCE (VAR(5),V5),(VAR(6),V6),(VAR(7),V7),(VAR(8),V8) EQUIVALENCE (VAR1,G1X),(VAR1(2),G1Y),(VAR1(3),G2X),(VAR1(4),G2Y) EQUIVALENCE (IBUFR(2),IB2),(IBUFR(4),IB4) EQUIVALENCE (IBUFR(3),IB3),(IBUFR(5),IB5) C C THIS IS THE MODULE FOR PROCESSING THE LIMIT COMMAND C DATA MMSIZ/25010B/ DATA MMU/6/ DATA GICB/16/ DATA IBUFR/26404B/ DATA DIGTZ/6003B/ DATA IG12/8/ DATA IHCLP/32001B/ C CCCC C THIS CALL ESTABLISHES AN ADDRESS LINK BETWEEN THE GRAPGHICS C PACKAGE AND THE CURRENT GCB AND ALSO CHECKS FOR A SUSPENDED GCB. C ISUSP= 0 CALL GCBIM(99,1,IGCB,ISUSP) IF(ISUSP.NE.0)RETURN IFLG = 0 GO TO(60,70),IND C 60 IF(P1.GE.P2.OR.P3.GE.P4)GO TO 800 C COMPUTE NEW HARD CLIP LIMITS H1,H2 C 65 CALL GCBIM(MMU,1,XMM,0,1) G1X = P1 G1Y = P3 G2X = P2 G2Y = P4 C C GET DISPLAY SURFACE SIZE C CALL OUTPT(1,MMSIZ,1) CALL GCBIM(16,1,V3,8,1) C C C SEE IF POINTS ARE OUTSIDE MECHANICAL LIMITS C IFLG = -1 CALL CLPNG(G1X,CLPTS,V3,IFLG) IF(IFLG.EQ.1)GO TO 820 C C C C NOW MAKE SURE ENDPOINTS AR'   E INSIDE MECHANICAL LIMITS C IF(G1X.LT.V3)G1X = V3 IF(G1Y.LT.V4)G1Y = V4 IF(G2X.GT.V5)G2X = V5 IF(G2Y.GT.V6)G2Y = V6 C C CONVERT FROM MM TO MUS C G1X = G1X * XMM G1Y = G1Y * YMM G2X = G2X * XMM G2Y = G2Y * YMM CALL GCBIM(IG12,1,G1X,0,2) GO TO 66 C C INTERACTIVE CALL TO LIMIT C 70 CALL OUTPT(1,DIGTZ,1) CALL GCBIM(GICB,1,IB2,2,1) CALL OUTPT(1,DIGTZ,1) CALL GCBIM(GICB,1,IB4,2,1) IF(IB2.GE.IB4.OR.IB3.GE.IB5)GO TO 800 DO 75 K = 1,4 75 VAR(K) = IBUFR(K+1) C C C SET H1 AND H2 INTO DEVICE C 130 CALL GCBIM(IG12,1,VAR,0,WRITE) 66 CALL GPON(IGCB,3) C C SEE IF USER REALLY BLEW IT C IF(G1X.EQ.V3.AND.G1Y.EQ.V4.AND.V5.EQ.G2X.AND.V6.EQ.G2Y)RETURN C C NOW CHECK ON HARD CLIPPING CAPABILITY OF DEVICE C IF IT CANNOT CLIP REDEFINED HARD CLIP LIMITS SET BIT 3 FOR CLIPPING C ALGORITHM. C C CALL OUTPT(1,IHCLP,1) CALL GCBIM(16,1,IBUFR,1,1) IF(IBUFR.EQ.0)CALL GRSTS(2,77767B,10B) RETURN 800 CALL PLTER(10) 810 RETURN 820 CALL PLTER(34) RETURN END END$ L   92840-18003 1819 S C0122 SETAR INTFC MOD              H0101   92840-18004 1819 S C0122 SETAR COMMAND              H0101 NFTN,L C C C CC************************************************************ 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. * CC************************************************************ C C C C NAME: SETAR C SOURCE: 92840 - 18004 C RELOC: 92840 - 16001 C C C CC*********************************************************** C SUBROUTINE XETAR(IND,IGCB,ASPCT), 92840-16001 REV.1819 780515 INTEGER GRIFX DIMENSION VAR(10),ICODE(3) DIMENSION IBUFR(5) EQUIVALENCE (VAR,DXGDU),(VAR(2),DYGDU),(AP,VAR(3)) EQUIVALENCE (BP,VAR(4)),(CP,VAR(5)),(DP,VAR(6)) EQUIVALENCE (G1X,VAR(7)),(G1Y,VAR(8)),(G2X,VAR(9)) EQUIVALENCE (G2Y,VAR(10)) DATA EPSLN/.0001/ DATA IGTCH/4404B/ DATA IHCLP/32001B/ C C THIS ROUTINE IS USED TO DETERMINE THE ASPECT RATIO OR C MORE SUCCINCTLY ADJUST THE GDU SPACE. C DATA ICODE/15B,11,8/ C AR = ASPCT C CCCC C THIS CALL ESTABLISHES AN ADDRESS LINK BETWEEN THE GRAPGHICS C PACKAGE AND THE CURRENT GCB AND ALSO CHECKS FOR A SUSPENDED GCB. C ISUSP= 0 CALL GCBIM(99,1,IGCB,ISUSP) IF(ISUSP.NE.0)RETURN C SET UP DEFAULT IF NECESSARY C IF(ASPCT.LE.0.)AR = 1. C C GET GDUS AND A' - D' C CALL GCBIM(ICODE,3,VAR,0,1) CALL OUTPT(1,IGTCH,1) CALL GCBIM(16,1,IBUFR,4,1) C C C C COMPUTE PRESENT ASPECT RATIO C 5 ARP = DXGDU/DYGDU C C SEE IF ASPECT RATIOS ARE EQUAL C XTEST = ABS(AR - ARP) IF(XTEST.LE.EPSLN)RETURN C C IS AR LONGER THAN IT IS HIGH OR VICE VERSA C IF(AR.LT.1.)GO TO 100 C C LONGER THAN HIGH AR > 1 C IF(ARP.GT.1.0.AND.AR.LT.ARP)GO TO 200 C C ADJUST GY C GO TO 300 C C HIGHER THA]  T IT IS WIDE C 100 IF(AR.GT.ARP.AND.ARP.LT.1.0)GO TO 300 C C ADJUST GX C 200 TMPAR = (( DXGDU - (DYGDU*AR))/2.) * AP G1X = G1X + TMPAR G2X = G2X - TMPAR C GO TO 400 C 300 TMPAR = (( DYGDU - ( DXGDU/AR))/2.) * CP G1Y = G1Y + TMPAR G2Y = G2Y - TMPAR 400 IF(ASPCT.LT.0)CALL PLTER(23,3) CALL GCBIM(8,1,G1X,0,2) C C CALL GPON(IGCB,3) C DETERMINE HARD CLIPPING CAPABILITY OF DEVICE C CALL OUTPT(1,IHCLP,1) CALL GCBIM(16,1,IBUFR,1,1) IF(IBUFR.EQ.0)CALL GRSTS(2,77767B,10B) C C RETURN END END$ ' 92840-18005 1819 S C0122 PLOTTER INTFC MOD              H0101 ASMB,R,L * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: PLOTR * SOURCE: 92840 - 18005 * RELOC: 92840 - 16001 * * * ************************************************************* * NAM PLOTR,7 92840-16001 REV. 1819 780515 * EXT SETUP,PLTER,INDCK EXT .OPTN ENT PLOTR,GPON,.PLTR * * THIS IS THE INTERFACE MODULE FOR THE AGL COMMANDS PLOTR * GPON * * SPC 3 * * CALLING SEQUENCE CALL PLOTR(ID,ACTION[,[,LUN,GCB],IOBUF,IOBL]) * * LUN AND GCB REQUIRED FOR ACTION = 1 AND 4 PLOTR NOP ISZ .PLTR SET FLAG FOR .OPTN LDA .40 STA ERCOD LDA PLOTR JSB .OPTN DEF *+8 DEF PARM DEF M8 # OF LOCATIONS IN PARM BUFFER DEF .1 DEF .4 FOUR REQUIRED PARAMETERS DEF .2 OPTIONAL PARAMETERS (IOBUF,IOBL) DEF DZER0 DEF RETRN USED TO SAVE RETURN ADDRESS JMP CKPRM LDB ACTON,I CPB .1 JMP ON CPB .4 JMP ON JMP CKPRM ON LDA IOBUF CHECK TO SEE IF IOBUF AND IOBL CPA DZER0 SEE IF DEFAULT ADDRESS WAS SUBSTITUTED JMP CHNG YES THEN IT MUST BE CHANGED JMP IBLCK CHECK ON IOBL LENGTH CHNG ADB M4 CHECK ON NUMBER OF PARAMTERS FOR PLOTR 1 OR 4 SZB JMP CHNG1 ACTION = 1 LDA DF1 CHANGE ACTION = 4 TO 1 STA ACTON JMP ERR8 CHNG1 LDA GCB I O BUFFER WILL LIVE IN GCB JSB INDCK INDIRECT CHECK STA B GCB(FWA) -> B ADA GCIO I O ADDRESS IN GCB ADB .5 6TH WORD OF GCB  OCT 14 .5 DEC 5 .0 OCT 0 .1 OCT 1 .2 OCT 2 .3 OCT 3 DZER0 DEF .0 DEF .0 DF2 DEF .2 FRMFD DEF .14 A EQU 0 M8 DEC -7 M20 DEC -20 .67 DEC 67 .PLTR NOP .8 DEC 8 .199 DEC 199 DF1 DEF .1 .40 DEC 40 M1 OCT -1 M99 DEC -99 M4 OCT -4 CNTR NOP RETRN NOP ERCOD NOP * END   92840-18006 1840 S C0122 &SETUP PLOTR OR GPON CMDS SRCE             H0101 C:DE(2),ICD2),(ICODE(3),ICD3),(ICODE(4),ICD4) EQUIVALENCE (ICODE(5),ICD5),(ICODE(6),ICD6) C C THE FOLLOWING DATA ASSIGNMENTS ARE THE FIRST WORDS IN THE GICB C THE GIC AND LENGTH. C C EM1840 C ERROR IS THE ERROR MASK. THE FIRST WORD ,PRESET TO -1, IS EM1840 C USED TO SPECIFY THE ERROR LOGGING LU. WORDS 2-5 ARE THE EM1840 C ACTUAL ERROR MASK, ASSOCIATED WITH ERRORS AS FOLLOWS: EM1840 C WORD 2 ERRORS 16 - 1 EM1840 C 3 32 - 17 EM1840 C 4 48 - 33 EM1840 C 5 64 - 49 EM81840 C IF THE BIT IS SET, THE ASSOCIATED ERROR IS A HARD ERROR EM1840 C DATA FLUSH/2000B/ DATA GICB/16/ DATA RESET/400B/ DATA DEFLT/1000B/ DATA IHARD/26404B/ DATA CLEAR/1400B/ DATA GCLR/1401B/ DATA HOME/2400B/ DATA GTPLT/4010B/ DATA INIT/22004B/ DATA GTCHR/4404B/ DATA CSIZE/7/ DATA ERROR/-1,135577B,173006B,16B,0/ EM1840 DATA LINE/23/ DATA ACTVE /20000B/ DATA SPEND/40000B/ DATA LFTPN/20400B/ DATA GTMMU/27004B/ DATA ICHW/10404B/ DATA ERMSK/28,27/ DATA READ/1/ DATA WRITE/2/ DATA TRNFR/3/ DATA PORG/14/ C C C IER1 = 0 ISUSP = 0 IERR = 0 C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C THIS PORTION OF CODE ADDED 5/12/78 TO CORRECT FOR FAULTY ERROR C MESSAGES REPORTED IN THE IGERR COMMAND WHEN IT IS CALLED AFTER C TWO SUCESSIVE PLOTR CALLS. C THIS CODE CORRECTS THE PROBLEM BY CLEARING OUT A TEMPORARY BUFFER C USED TO TRANSMIT DATA TO AND FROM THE GCB (GRAPHICS CONTROL BLOCK). C CCCCCCCCCCCCCCCCgCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C DO 2 I=1,12 2 IBUFR(I) = 0 C C SELECT AGL COMMAND C P0 = P1 P1 =IABS(P1) GO TO(10,20),P1 C C PLOTR C C C INITIALIZE GCB ADDRESS POINTER C 10 IF(P4.EQ.1.OR.P4.EQ.4)GO TO 110 C C 5 CALL GCBIM(99,1,P2,ISUSP) IF(ISUSP.NE.0)RETURN C C C CHECK ID ,THEN RESET DEVICE (ACTION = 0) C 100 CALL GCBIM(3,1,IBUFR,0,READ) IERR = 1 IF(P3.NE.IBUFR)GO TO 800 CALL OUTPT(3,ICMND,2) C C CLEAR GCB C CALL GCBIM(-99,1,P2) DO 109 K=1,128 109 P2(K) = 0 RETURN C C PLOTR IS ACTION = 1 (TURN ON DEVICE) C C C C SET THE LATEST ERROR CODE TO 0 AND ERROR LOGGING LU TO THE EM1840 C CURRENT CONSOLE BEFORE CALLING GCBIM FOR THE FIRST TIME EM1840 C NOTE THAT THIS IS THE ONLY TIME THAT HARDCODED INDICES TO EM1840 C THE GCB SHOULD BE USED. EM1840 C THIS IS THE ONLY PLACE WHERE THE GCB IS ACCESSED DIRECTLY EM1840 110 P2(2) = 0 P2(5) = LOGLU(DUMMY) EM1840 C C FIRST INITIALIZE FWA OF GCB POINTER (P2=GCB) CALL GCBIM(0,1,P2) C C SET WORD 1 OF ERROR TO THE CURRENT CONSOLE AND ENTER WITH EM1840 C ERROR MASK INTO GCB. THIS RESETTING OF LU IS REDUNDANT EM1840 C BUT SAFE EM1840 ERROR(1) = LOGLU(DUMMY) EM1840 CALL GCBIM(ERMSK,2,ERROR,0,WRITE) C C CHECK TO SEE IF THE LU NUMBER IS LEGAL EM1840 CALL PLTER(-97,P5) C C NON POSITIVE ID'S ARE NOT ALLOWED. CHECK HERE FOR THIS INPUT EM1840 C ERROR SO THE NEXT COMMAND WON'T BE CONFUSED WITH A SWTCH(0) EM1840 C CALL FROM SUBROUTINE(OUTPUT). CANNOT CHECK FOR BAD LU EM1840 C MATCH OR TOCO LARGE ID AT THIS TIME AS INFO IS NOT EM1840 C AVAILABLE AT THIS LEVEL. EM1840 IF(P3.LE.0)GO TO 799 EM1840 C C CHECK TO SEE IF LU AND ID MATCH EM1840 CALL SWTCH(P3) CALL PLTER(-98,ISUSP) IF(ISUSP.NE.0)RETURN C DO 112 K=1,5 112 P2(K) = 0 DO 114 K = 8,128 114 P2(K) = 0 ICODE = 25 IF(P4.EQ.4)P2(8) = 1000B IF(P0.LT.0)IB2 = 8 IBUFR = -99 C C SET BUFFERING BIT C IB3 = P5 IB4 = P3 CALL GCBIM(ICODE,1,IBUFR,0,WRITE) CALL GCBIM(ERMSK,2,ERROR,0,WRITE) C C INVOKE GPON(1) C GO TO 200 C C PLOTR IS ACTION = 2 (RE-ACTIVATE DEVICE) C20 CALL GCBIM(0,1,P2) C CALL PLTER(-98,ISUSP) C IF(ISUSP.EQ.15B.OR.ISUSP.EQ.0)GO TO 123 C RETURN C C CHECK FOR LEGAL ID AND RESET ERROR 13 IF ANY C C23 IERR = 9 C CALL GCBIM(3,1,IBUFR,0,READ) C IF(P3.NE.IBUFR)GO TO 800 C IF(ISUSP.EQ.15B)CALL PLTER(-99,ISUSP) C C GET STATUS FROM GCB AND MAKE SURE THIS IS A PREVIOUSLY C SUSPENDED GCB. C C IERR = 7 C CALL GRSTS(1,40000B,ISTAT) C IF(ISTAT.NE.SPEND)GO TO 800 C C RESET DEVICE TO ACTIVE C C CALL GRSTS(2,17777B,ACTVE) C C RETURN C C PLOTR IS ACTION = 3 (SUSPEND) C C30 IERR = 9 C CALL GCBIM(3,1,IBUFR,0,READ) C IF(P3.NE.IBUFR)GO TO 800 C CALL GRSTS(2,17777B,SPEND) C C RETURN C C GPON(P2), WHERE P2 = LEVEL (1-3) C 20 CALL GCBIM(99,1,P2,ISUSP) IF(ISUSP.NE.0)RETURN IF(P3.LT.1.OR.P3.GT.3)GO TO 830 GO TO(200,210,220),P3 C C GPON LEVEL = 1 C SET DEFAULTS C 200 CALL OUTPT(1,DEFLT,2) C C GPON LEVEL = 2 CLEAR DISPLAY,LIFT PEN AND HOME IT C GET HARD CLIP LIMITS G1 AND G2 AND STORE IN GCB C C 210 CALL OUTPT(1,GTPLT,1) CALL GCBIM(GICB,1,8,1,TRNFR) IBUFR = CLEAR  IB2 = LFTPN IB3 = HOME CALL OUTPT(3,IBUFR,2) C C C C C C GPON = LEVEL 3 RESET DEVICE AND COMPUTE TRANSFORMATION C CONSTANTS A' - D' WHERE A' ,C' = MU/GDU AND B',D' = OFFSETS. C C 220 CALL OUTPT(1,RESET,2) CALL GCBIM(8,1,G1X,0,1) DO 230 I= 9,10 230 CALL GCBIM(I,1,G1X,0,2) C C SET HARD CLIP LIMITS IN TO DEVICE C IBUFR = IHARD DO 233 I=2,5 233 IBUFR(I) = GRIFX(VAR(I-1)) CALL OUTPT(1,IBUFR,2) C C GET MU/MM C CALL OUTPT(1,GTMMU,1) CALL GCBIM(GICB,1,XMU,4,1) C C INITIALIZE STATUS WORD C CALL GRSTS(2,3000B,INIT) C C INITIALIZE CHARACTER SIZE INFO, (H,W), LORG AND LDIR(SLANT) C IBUFR = 0 IB2 = 0 IB3 = 0 IB4 = 1 XLIN = 0.0 CALL GCBIM(LINE,1,IBUFR,0,2) C C COMPUTE TRANSFORMATION CONSTANTS C DGX = G2X - G1X DGY = G2Y - G1Y DXMM = DGX/XMU DYMM = DGY/YMU DP = G1Y BP = G1X IF(DXMM.GE.DYMM)GO TO 235 DXGDU = 100.0 DYGDU = 100.0 * (DGY/DGX) GO TO 240 235 DYGDU = 100.0 DXGDU = 100.0* (DGX/DGY) 240 AP = DGX/DXGDU CP = DGY/DYGDU C C ESTABLISH CHARACTER SIZE INFO. C XS = 2.78 * .7 IBUFR = ICHW CHH = CP * 2.78 CHW = AP * XS CALL OUTPT(1,IBUFR,2) CALL GCBIM(7,1,CHW,0,2) CALL OUTPT(1,GTCHR,1) CALL GCBIM(GICB,1,7,1,3) C DO 242 I=1,4 242 VAR(I+4) = VAR(I) C C PORGX = 0. PORGY = 0. PDIRX = 1.0 PDIRY = 0. XLDIR = 0. DO 245 I = 1,4 245 ICODE(I) = 10 + I ICD5 = 6 ICD6 = 22 CALL GCBIM(ICODE,6,VAR, 0,WRITE) IF(P4.EQ.4.AND.P1.EQ.1)CALL GRSTS(2,77677B,1000B) RETURN C C C 799 IERR = 2 800 CALL PLTER(IERR,1) RETURN C C 830 CALL PLTER(67) RETURN END END$ $"$   ASMB,R,L * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: GCLR INTFC MODULE * SOURCE: 92840 - 18007 * RELOC: 92840 - 16001 * * * ************************************************************* * NAM GCLR,7 92840-16001 REV.1819 780515 * EXT .OPTN,XGCLR,PLTER ENT GCLR * * THIS IS THE INTERFACE MODULE FOR THE AGL COMMAND GCLR(DISTANCE) * GCLR NOP LDA GCLR JSB .OPTN DEF GCRTN DEF PARM DEF M3 DEF .1 DEF .1 ONE REQUIRED PARAMETER IGCB DEF .1 ONE DEFAULE FORM FEED DEF FRMFD DEF RETRN GCRTN JMP ERROR JSB XGCLR DEF END PARM BSS 3 END JMP RETRN,I * SPC 2 ERROR LDA PARM+1 STA IGCB JSB PLTER DEF RTNER DEF .45 IGCB NOP RTNER JMP RETRN,I * M3 DEC -3 .1 OCT 1 FRMFD DEF .14 .14 OCT 14 RETRN NOP .45 DEC 45 END "  92840-18008 1819 S C0122 GCLR COMMAND              H0101 FTN,L C C C CC************************************************************ 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. * CC************************************************************ C C C C NAME: GCLR COMMAND C SOURCE: 92840 - 18008 C RELOC: 92840 - 16001 C C C CC*********************************************************** C SUBROUTINE XGCLR(IND,IGCB,IP1), 92840-16001 REV.1819 780515 INTEGER GRIFX DIMENSION IBUFR(5),VAR(4) EQUIVALENCE(IBUFR(2),IB2) DATA IGCLR/1401B/ DATA IHARD/26404B/ DATA IHOME/1400B/ DATA ICLR/27401B/ DATA IPNUP/20400B/ C C THIS IS THE MODULE FOR THE AGL COMMAND GCLR(DISTANCE) C WHERE DISTANCE = PAGE ADVANCE OR FORM FEED FOR LINE PRINTERS C A NOP FOR GRPHIC DISPLAYS AND PEN UP FOR PLOTTERS. CV CCCC C THIS CALL ESTABLISHES AN ADDRESS LINK BETWEEN THE GRAPGHICS C PACKAGE AND THE CURRENT GCB AND ALSO CHECKS FOR A SUSPENDED GCB. C ISUSP= 0 CALL GCBIM(99,1,IGCB,ISUSP) IF(ISUSP.NE.0)RETURN IBUFR =IHOME C C SEE IF DEVICE CAN CLEAR C CALL OUTPT(1,ICLR,1) CALL GCBIM(16,1,IB2 ,1,1) IF(IB2 .EQ.0)GO TO 10 IBUFR = IGCLR IB2 = IP1 10 CALL OUTPT(1,IBUFR,2) CALL GCBIM(8,1,VAR,0,1) DO 20 I =2,5 IBUFR(I) = GRIFX(VAR(I-1)) 20 CONTINUE IBUFR = IHARD CALL OUTPT(1,IBUFR,2) RETURN END END$ SASMB,R,L * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: MARGIN * SOURCE: 92840 - 18009 * RELOC: 92840 - 16001 * * * ************************************************************* * NAM MARGN,7 92840-16001 REV.1819 780515 EXT .OPTN,XMARG,PLTER ENT MARGN * * THIS IS THE INTERFACE MODULE FOR THE AGL COMMAND MARGIN * MARGN NOP LDA MARGN JSB .OPTN DEF *+8 DEF PARM DEF M7 DEF .1 DEF .5 FOUR REQ'D PARAMETERS DEF .1 ONE OPTIONAL DEF DZER0 INDICATES CHARACTERS/1= GDU'S DEF RETRN JMP ERROR JSB XMARG DEF END PARM BSS 7 END JMP RETRN,I * ERROR LDA PARM+1 STA IGCB JSB PLTER DEF RTNER DEF .41 IGCB NOP RTNER JMP RETRN,I * DZER0 DEF .0 .1 OCT 1 .5 OCT 5 .41 DEC 41 M7 OCT -7 .0 OCT 0 RETRN NOP END F   92840-18010 1819 S C0122 MARGIN COMMAND              H0101 /   92840-18011 1819 S C0122 MSCAL COMMAND              H0101 .FTN,L C C C CC************************************************************ 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. * CC************************************************************ C C C C NAME: MSCALE C SOURCE: 92840 - 18011 C RELOC: 92840 - 16001 C C C CC*********************************************************** C SUBROUTINE XSCAL(IN,IGCB,P1,P2), 92840-16001 REV.1819 780515 DIMENSION VAR(8),ICODE(3) EQUIVALENCE (VAR,DXGDU),(VAR(2),DYGDU),(VAR(3),G1X) EQUIVALENCE (VAR(4),G1Y),(VAR(5),G2X),(VAR(6),G2Y) EQUIVALENCE (VAR(7),XMM),(VAR(8),YMM) EQUIVALENCE (ICODE,IGDU),(ICODE(2),IG12) EQUIVALENCE(ICODE(3),MMU) C C THIS IS THE FUNCTIONAL MODULE FOR THE AGL COMMAND MSCALE C WHICH DEFINES USER UNITS IN TERMS OF MILLIMETERS. C DATA IGDU/15B/ DATA IG12/8/ DATA MMU/6/ C CCCC C THIS CALL ESTABLISHES AN ADDRESS LINK BETWEEN THE GRAPGHICS C PACKAGE AND THE CURRENT GCB AND ALSO CHECKS FOR A SUSPENDED GCB. C ISUSP= 0 CALL GCBIM(99,1,IGCB,ISUSP) IF(ISUSP.NE.0)RETURN CALL GCBIM(ICODE,3,VAR,0,1) C C REDEFINE VIEWPORT SET HARD CLIP LIMITS = SOFT CLIP LIMITS C CALL VIEWP( IGCB,0.,DXGDU,0.,DYGDU) C C COMPUTE PARAMETERS FOR SCALE C XUU = (G2X - G1X)/XMM - P1 YUU = (G2Y - G1Y)/YMM - P2 XU1 = -P1 YU1 = -P2 CALL WINDW( IGCB,XU1,XUU,YU1,YUU) RETURN END END$    92840-18012 1840 S C0122 &CLPON CLPON OR SCPOF CMDS SRCE             H0101 <;C TURN OFF SOFT CLIPPING BY SETTING BIT 2 OF STATUS WORD = 0 EM1840 200 CALL GRSTS(2,77773B,0) C C IF THE CURRENT POSITION IS OUTSIDE SOFT CLIPPING BOUNDARIES, EM1840 C THE PHYSICAL PEN AND THE CP MAY NOT AGREE, SO MOVE THE EM1840 C PHYSICAL PEN TO AGREE WITH THE CP IN THIS CASE. EM1840 C SET THE INDICES TO THE GCB POINTER TABLE AND REQUEST THE DATA EM1840 C POINTER 18 IS TO THE LOGICAL PEN (I.E. CP) INDEX. FUNCTION EM1840 C IADCD RETURNS POINTER TO MU/NDC OR MU/WC TRANSFORMS, EM1840 C DEPENDING ON CURRENT MODE, GDU OR UDU. POINTER 10 IS TO EM1840 C THE SOFT CLIPPING BOUNDARIES INDEX. EM1840 ICODE(3)=10 EM1840 ICODE(2)=IADCD(DUMMY) EM1840 ICODE(1)=18 EM1840 CALL GCBIM(ICODE,3,TFORM,0,1) EM1840 C C CHECK TO SEE IF THE CURRENT PEN POSITION IS OUTSIDE THE SOFT EM1840 C CLIPPING BOUNDARIES. IF IT ISN'T THE PHYSICAL PEN POSITION EM1840 C SHOULD BE FINE AS IS, SO DO NOTHING MORE. EM1840 C C IF IT IS OUTSIDE, MAKE THE MOVE. EM1840 IF (CPX.LT.LOWRX) GO TO 300 EM1840 IF (CPX.GT.UPPRX) GO TO 300 EM1840 IF (CPY.LT.LOWRY) GO TO 300 EM1840 IF (CPY.GT.UPPRY) GO TO 300 EM1840 C C IT IS INSIDE SO NO MOVE IS NECESSARY EM1840 GO TO 500 EM1840 C C TRANSFORM FROM MACHINE UNITS TO NDC OR WC UNITS EM1840 300 XPHYS = (CPX-B)/A W   92840-18013 1819 S C0122 SHOW COMMAND              H0101 FTN,L C C C CC************************************************************ 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. * CC************************************************************ C C C C NAME: SHOW C SOURCE: 92840 - 18013 C RELOC: 92840 - 16001 C C C CC*********************************************************** C SUBROUTINE XSHOW(IN,IGCB,U3X,U4X,U3Y, 1U4Y), 92840-16001 REV.1819 780515 DIMENSION VAR(4) EQUIVALENCE (VAR,V1X) EQUIVALENCE (VAR(2),V1Y),(VAR(3),V2X),(VAR(4),V2Y) C C C THIS MODULE IS RESPONSIBLE FOR PROCESSING THE AGL COMMAND C SHOW. SHOW ISOTROPICALLY SCALES USER UNITS U3-U4, GETTING C THE BIGGEST POSSIBLE AREA IN THE REGION OF INTEREST (VIEWPORT) C ON WHICH TO MAP USER UNITS. ESSENTIALLY SHOW REDEFINES C USER UNITS U1-U2 AND DISCARDS U3-U4. C CCCC C THIS CALL ESTABLISHES AN ADDRESS LINK BETWEEN THE GRAPGHICS C PACKAGE AND THE CURRENT GCB AND ALSO CHECKS FOR A SUSPENDED GCB. C ISUSP= 0 CALL GCBIM(99,1,IGCB,ISUSP) IF(ISUSP.NE.0)RETURN C C C GET CURRENT SOFT CLIP LIMITS C ICODE = 9 CALL GCBIM(ICODE,1,VAR,0,1) C C LOOK FOR ERRORS C IF(U3X.EQ.U4X.OR.U3Y.EQ.U4Y)GO TO 800 C C COMPUTE THE DELTA X AND Y FOR THE USER UNITS TO DETERMINE C MINIMUM SIDE. C DXUDU = U4X - U3X DYUDU = U4Y - U3Y DXV = V2X - V1X DYV = V2Y - V1Y DX = ABS(DXV/DXUDU) DY = ABS( DYV/DYUDU ) C C NOW DETERMINE WHAT TO ASSIGN TO U1 - U2 C C U1X = U3X U2X = U4X U1Y = U3Y U2Y = U4Y C C 20 IF(DX.EQ.DY)GO TO 120 C C U3,U4 HIT TOP AND BOTTOM EDGES OF VIEW SURFACE C SO ADJUST U3X AND U4X TO OBTAIN MAXIMUM SQUARE. c   C 100 IF(DX.LT.DY)GO TO 110 TEMP= ( ( ((DXV * DYUDU)/DYV) - DXUDU )/2. ) C C SEE U3,U4 ARE REVERSED C U1X = U3X - TEMP U2X = U4X + TEMP GO TO 120 C C U3,U4 HIT LEFT AND RIGHT SIDES THERE ADJUST U3Y AND U4Y C 110 TEMP = ( (((DYV * DXUDU)/DXV) - DYUDU )/2. ) U1Y = U3Y - TEMP U2Y = U4Y + TEMP C C CALL WINDOW TO COMPUTE TRANSFORMATION CONSTANTS AND C TO ESTABLISH USER UNITS = UDUS C 120 CALL WINDW( IGCB,U1X,U2X,U1Y,U2Y) RETURN 800 CALL PLTER(16) END END$ ` ASMB,R,L * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: VIEWPE,VIEWPORT,CLIP * SOURCE: 92840 - 18014 * RELOC: 92840 - 16001 * * * ************************************************************* * NAM VIEWP,7 92840-16001 REV.1819 780515 EXT SCLNG,.OPTN,PLTER ENT CLIP ENT VIEWP * * THIS IS THE INTERFACE MODULE FOR THE GRAPHICS * SCALING COMMANDS. * SPC 3 * SPC 3 VIEWP NOP LDA .42 STA ERCOD LDA .1 LOC1 STA CODE CODE FOR VIEWPE LDA VIEWP JSB .OPTN GO GET PARAMETER ADDRESSES DEF RTN PADR DEF PARM PARAME DEF M6 DEF CODE DEF .5 NUMBER OF PARAMETERS DEF .0 NO OPTIONAL PARAMETERS DEF RETRN RTN JMP CHECK JMP ENTRY * * THIS PORTION OF CODE DETERMINES WHETHER OR NOT CALL IS * INTERACTIVE OR AN ERROR. * CHECK CPA M4 INTERACTIVE JMP *+2 YES JMP ERROR NOT ENOUGH PARAMETERS LDA CODE ADD OFFSET TO CODE FOR INTERACTIVE SELECTION ADA .2 STA INTCD LDA DFINT STA PARM ENTRY JSB SCLNG DEF END PARM BSS 6 END JMP RETRN,I * SPC 2 * * SPC 2 * CLIP NOP LDA CLIP STA VIEWP LDA .46 STA ERCOD LDA .2 JMP LOC1 * SPC 2 * * * SPC 3 * ERROR LDA PARM+1 STA IGCB JSB PLTER DEF RTNER DEF ERCOD IGCB NOP RTNER JMP RETRN,I * * CONSTANTS AND STORAGE * DFINT DEF INTCD INTCD NOP M6 DEC -6 M4 DEC -4 .0 OCT   0 .1 OCT 1 .2 OCT 2 .3 OCT 3 .4 OCT 4 .5 OCT 5 .6 OCT 6 CODE NOP ERCOD NOP .46 DEC 46 .42 DEC 42 RETRN NOP * END \ 92840-18015 1819 S C0122 VIEWP CLIP CMNDS              H0101 JO 0 GO TO 110 C C ERRORS C 800 CALL PLTER(IER2(INDX)) RETURN 810 CALL PLTER(IER3(INDX)) RETURN C END END$ E  92840-18016 1819 S C0122 WINDOW INTF MOD              H0101 \  92840-18017 1819 S C0122 WINDW COMMAND              H0101 T  92840-18018 1819 S C0122 L/AXES INTF MOD              H0101 <ASMB,R,L * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: AXES AND LAXES INTERFACE * SOURCE: 92840 - 18018 * RELOC: 92840 - 16001 * * * ************************************************************* * NAM AXES,7 92840-16001 REV.1819 780515 ENT AXES,LAXES EXT PLTER EXT .OPTN EXT AXELS * * THIS IS THE INTERFACE MODULE FOR AGL COMMANDS * AXES,LAXES,GRID,LGRID,FRAME,FXD * AXES NOP LDA .1 CODE = 1 STA CODE LDA AXES AX1 JSB .OPTN DEF RTN PADR DEF PARM DEF M9 DEF CODE DEF .1 IGCB PARAMETER DEF .7 SEVEN OPTIONAL PARAMETERS DEF DZER0 TOP OF LIST OF DEFAULTS DEF RETRN * RTN JMP ERROR JSB AXELS DEF END PARM BSS 9 END JMP RETRN,I * * LABELED AXES * LAXES NOP LDA .2 CODE = 2 STA CODE LDA LAXES JMP AX1 * * ERROR LDA PARM+1 STA IGCB JSB PLTER DEF RTNER DEF .62 IGCB NOP RTNER JMP RETRN,I * PARAMETERS AND CONSTANTS- DO NOT CHANGE ORDER * .0 DEC 0. DZER0 DEF .0 DEF .0 DEF .0 DEF .0 DF1 DEF D1 DEF D1 DEF D2 D1 DEC 1. CODE NOP .1 OCT 1 D2 DEC 2.0 .2 OCT 2 .7 OCT 7 DF2 DEF .2 M9 DEC -9 RETRN NOP .62 DEC 62 END   92840-18019 1819 S C0122 AXES LAXES CMNDS              H0101 ION CONSTANTS TO C USE. C ICD2 = 9 ICD3 = 11 CCCC C THIS CALL ESTABLISHES AN ADDRESS LINK BETWEEN THE GRAPGHICS C PACKAGE AND THE CURRENT GCB AND ALSO CHECKS FOR A SUSPENDED GCB. C ISUSP= 0 CALL GCBIM(99,1,IGCB,ISUSP) IF(ISUSP.NE.0)RETURN ICODE = IADCD(D) CALL GCBIM(ICODE,3,VAR,0,READ) C C CONVERT MUS TO CURRENT UNITS MODE UDUS OR GDUS C XEND = (XEND - B)/A YEND = (YEND - D)/C X1 = (X1 - B)/A Y1 = (Y1 - D)/C C C ABSOLUTIZE NECESSARY PARAMETERS C XP1 = P1 XP2 = P2 GO TO(10,20),IND 10 XP1 = ABS(P1) XP2 = ABS(P2) 20 XP5 = ABS(P5) XP6 = ABS(P6) XP7 = ABS(P7) C C GET LINE TYPE, LDIR AND LORG AND SAVE FOR RESET WHEN DONE C ICODE = LNTYP ICD2 = 30 CALL GCBIM(ICODE,2,IBUFR,0,1) C C NOW BEGIN TO DRAW THE AXES, FIRST THE X AXES AND TIC MARKS C THEN THE Y AXES AND TIC MARKS. C C C MOVE TO START C CALL MOVE(IGCB,X1,P4) BEGIN = X1 BEG2 = P4 TICSZ =(XP7 * CP)/C IF(XP1.NE.0.)GO TO 25 CALL LINE(IGCB,0) CALL DRAW(IGCB,XEND,Y1) GO TO 110 C C C INVOKE SUBROUTINE TO DRAW AXES FIRST THE X AXIS C AND THEN THE Y AXIS. C 25 CALL SUBAX(IND,BEGIN,Y1,YEND,XEND,TICSZ,P3,XP1,XP5,1,2,IGCB) 110 BEGIN = Y1 BEG2 = P3 TICSZ =(XP7 * AP)/A CALL MOVE(IGCB,P3,Y1) IF(XP2.NE.0.)GO TO 35 CALL LINE(IGCB,0) CALL DRAW(IGCB,X1,YEND) GO TO 45 35 CALL SUBAX(IND,BEGIN,X1,XEND,YEND,TICSZ,P4,XP2,XP6,2,1,IGCB) C C RESET LINE TYPE AND LDIR C 45 CALL LINE(IGCB,IBUFR,XLNTH) CALL LDIR(IGCB,THETA) CALL LORG(IGCB,LRG) CALL GCBIM(30,1,IERCD,0,2) RETURN END SUBROUTINE SUBAX(IND,BEGIN,ST1,ST2,ENDPT, 1TCSZ,ORG,P12,P56,I,J,IB), 92840-16001 REV.1819 780515 DIMENSION BEGIN(2),TICMK(2) INTEGER READ,WRITE,GRIFX 3250 C C 350 BEGIN = SAVBG C C RESET BEGINE BACK TO THE VALUE IT WAS BEFORE PROCESSING THE C ORIGIN C IT1 = GRIFX(BEGIN) IT2 = GRIFX(ORG) IF(TCNT.GT.P56.OR.IT1.GT.IT2)TCNT = TCNT - 1.0 IF(TCNT.EQ.P56.AND.IT1.EQ.IT2)TCNT = 1.0 IF(IT1.EQ.IT2) BEGIN = BEGIN + XP12 IORG = 1 C WRITE(6,7500)IT1,IT2,BEGIN,ORG,TCNT C500 FORMAT(2X," 350 ",2(X,I5),2X,4(X,F9.5)) C WRITE(6,7800)SAVBG C800 FORMAT(2X,F9.5) GO TO 250 C C C C END BJ  92840-18020 1819 S C0122 L/GRID INTF MODS              H0101 >4  92840-18021 1819 S C0122 GRID LGRID CMNDS              H0101 lFTN,L C C C CC************************************************************ 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. * CC************************************************************ C C C C NAME: GRID,LGRID C SOURCE: 92840 - 18021 C RELOC: 92840 - 16001 C C C CC*********************************************************** C SUBROUTINE GRIDS(IND,IGCB ,P1,P2,P3, 1P4,P5,P6,P7), 92840-16001 REV.1819 780515 DIMENSION VAR(15),BEGIN(2),IBUFR(6) DIMENSION ICODE(4) INTEGER READ,WRITE,EFLG EQUIVALENCE (VAR,A),(VAR(2),B),(VAR(3),C),(VAR(4),D) EQUIVALENCE (VAR(5),X1),(VAR(6),Y1) EQUIVALENCE (AP,VAR(9)),(BP,VAR(10)),(CP,VAR(11)),(DP,VAR(12)) EQUIVALENCE (VAR(7),XEND),(VAR(8),YEND) EQUIVALENCE (BEGIN(2),BEG2) EQUIVALENCE (ICODE(2),ICD2),(ICODE(3),ICD3) EQUIVALENCE (IBUFR(5),THETA),(XLNTH,IBUFR(2)) EQUIVALENCE (IBUFR(4),LRG),(ICODE(4),LNTYP) C DATA READ/1/ DATA LNTYP/23/ C C THIS IS THE AGL MODULE FOR AGL COMMANDS GRID AND LGRID. C THE PARAMETERS IN THE CALLING SEQUENCE HAVE THE FOLLOWING C MEANINGS FOR EACH AGL COMMAND: C C PARAMETER AGL COMMAND MEANING DEFAULT C P1 X-TIC SPACING 0-NO TICS C P2 " Y-TIC SPACING 0 C P3 " X-ORIGIN 0 C P4 " Y-ORIGIN 0. C P5 " X-MAJOR COUNT 1.0 C P6 " Y-MAJOR COUNT 1.0 C P7 CROSS SIZE 0(NO CROSS) C************************************************************* C C DETERMINE UNITS MODE AND WHICH TRANSFORMATION CONSTANTS TO C U SE. C CCCC C THIS CALL ESTABLISHES AN ADDRESS LINK BETWEEN THE GRAPGHICS C PACKAGE AND THE CURRENT GCB AND ALSO CHECKS FOR A SUSPENDED GCB. C ISUSP= 0 CALL GCBIM(99,1,IGCB,ISUSP) IF(ISUSP.NE.0)RETURN ICODE = IADCD(D) ICD2 = 9 ICD3 = 11 CALL GCBIM(ICODE,4,VAR,0,READ) CALL GCBIM(LNTYP,1,IBUFR,0,1) C C CONVERT MU TO GDUS FOR LABELLING C C C CLIP X(ORIGIN),Y(ORIGIN) USING EITHER S1,S2 OR V1,V2 AS LIMITS. C XEND = (XEND - B)/A YEND = (YEND - D)/C X1 = (X1 - B)/A Y1 = (Y1 - D)/C C C ABSOLUTIZE PARAMETERS C XP1 = P1 XP2 = P2 GO TO(10,20),IND 10 XP1 = ABS(P1) XP2 = ABS(P2) 20 XP5 = ABS(P5) XP6 = ABS(P6) XP7 = ABS(P7) C C NOW BEGIN TO DRAW THE AXES, FIRST THE X AXES AND TIC MARKS C THEN THE Y AXES AND TIC MARKS. C CALL MOVE(IGCB,X1,Y1) BEGIN = X1 BEG2 = Y1 TICSZ =(XP7 * CP)/C IF(XP1.NE.0.)GO TO 25 CALL LINE(IGCB,0) CALL DRAW(IGCB,XEND,Y1) GO TO 110 C C INVOKE SUBROUTINE TO DRAW AXES FIRST THE X AXIS C AND THEN THE Y AXIS. C 25 CALL SUBGD(IND,BEGIN,Y1,YEND,XEND,TICSZ,P3,XP1,XP5,1,2,IGCB) 110 BEGIN = Y1 BEG2 = X1 TICSZ =(XP7 * AP)/A CALL MOVE(IGCB,X1,Y1) IF(XP2.NE.0.)GO TO 35 CALL LINE(IGCB,0) CALL DRAW(IGCB,X1,YEND) GO TO 45 35 CALL SUBGD(IND,BEGIN,X1,XEND,YEND,TICSZ,P4,XP2,XP6,2,1,IGCB) C C RESET LDIR AND LINE TYPE C 45 CALL LINE (IGCB,IBUFR,XLNTH) CALL LORG(IGCB,LRG) CALL LDIR(IGCB,THETA) RETURN END SUBROUTINE SUBGD(IND,BEGIN,ST1,ST2,ENDPT,TCSZ,ORG,P12,P56, 1I,J,IB), 92840-16001 REV.1819 780515 DIMENSION BEGIN(2) INTEGER READ,WRITE,GRIFX C C C ST1 = Y1 OR X1 C ST2 = YEND,OR XEND C THIS SUBROUTINE IS RESPONSIBLE FOR DRAWING THE GRIDS FOR THE C GRID AND LGRID COMMANDS. C 8k IORG = 1 GO TO 250 C C CHECK TO SEE IF MAJOR TIC HAS ALREADY BEEN DONE C 310 SAVBG = BEGIN IORG = -1 BEGIN = ORG GO TO 250 C C C 350 BEGIN = SAVBG IT1 = GRIFX(BEGIN) IT2 = GRIFX(ORG) IF(TCNT.GT.P56.OR.IT1.GT.IT2)TCNT = TCNT - 1.0 IF(TCNT.EQ.P56.AND.IT1.LE.IT2)TCNT = 1.0 IF(IT1.EQ.IT2) BEGIN = BEGIN + XP12 IORG = 1 GO TO 250 C C END R  92840-18022 1819 S C0122 ABS PLT INT MOD              H0101 ASMB,R,L * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: PLOT * SOURCE: 92840 - 18022 * RELOC: 92840 - 16001 * * * ************************************************************* * NAM PLOT,7 92840-16001 REV.1819 780515 * * THIS MODULE IS THE INTERFACE FOR AGL COMMANDS * PLOT. * EXT PLOTA,.OPTN,PLTER ENT PLOT * * PLOT NOP LDA .1 PLT STA CODE LDA PLOT JSB .OPTN OPTIONAL PARAMETER PROCESSING SUBROUTINE DEF RTN PADR DEF PARM DEF M5 NUMBER OF ENTRIES TO CLEAR DEF CODE DEF .3 NUMBER OF PARAMETERS - # OF DEFAULTS DEF .1 NUMBER OF DEFAULTS DEF DF1 TOP OF LIST FOR DEFAULT VALUES DEF RETRN RTN JMP MESUP ERROR RETURN JSB PLOTA DEF END PARM BSS 5 END JMP RETRN,I MESUP LDA PARM+1 STA IGCB JSB PLTER DEF RTNER DEF .47 IGCB NOP RTNER JMP RETRN,I * * * CHARACTER PLOT * * * SPC 3 B EQU 1 .4 OCT 4 M5 DEC -5 .0 OCT 0 .1 OCT 1 .2 OCT 2 .3 OCT 3 .5 OCT 5 DF1 DEF .1 RETRN NOP A EQU 0 .47 DEC 47 CODE NOP * END   92840-18023 1819 S C0122 ABS PLOT CMND              H0101 #FTN,L C C C CC************************************************************ 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. * CC************************************************************ C C C C NAME: PLOT ABSOLUTE C SOURCE: 92840 - 18023 C RELOC: 92840 - 16001 C C C CC*********************************************************** C SUBROUTINE PLOTA(IND,IGCB,X,Y, 1PCNTL), 92840-16001 REV.1819 780515 INTEGER PCNTL,READ,WRITE,ICODE(2) C C C THIS IS THE FUNCTIONAL FOR THE AGL COMMANDS PLOT AND CPLOT C DATA READ/1/ DATA WRITE/2/ DATA ICHR/7/ DATA LDIR/22/ C IFLG = 0 ISTAT = 0 IST1 = 0 CCCC C THIS CALL ESTABLISHES AN ADDRESS LINK BETWEEN THE GRAPGHICS C PACKAGE AND THE CURRENT GCB AND ALSO CHECKS FOR A SUSPENDED GCB. C ISUSP= 0 CALL GCBIM(99,1,IGCB,ISUSP) IF(ISUSP.NE.0)RETURN C C INITIALIZE CODES FOR GCBIM C C WHERE 11 = TRANSFORMATION CONSTANTS C 9 = MAPPING ENDPOINTS V1,V2 C 18 = PREVIOUS X,Y C CALL GRSTS(1,200B,ISTAT) XNEW = X YNEW = Y C C C NOW ASCERTAIN FROM THE PEN-CONTROL PARAMETER (PCNTL) WHAT C ACTIONS TO TAKE. THE FOLLOWING MODES ARE DEFINED FOR THE C PEN CONTROL PARAMETER: C C EVEN = PEN UP C ODD = PEN DOWN C + = PEN CHANGE AFTER MOTION C - = PEN CHANGE BEFORE MOTION C 10 IPC = IAND( IABS(PCNTL),1) + 1 IF(PCNTL.LT.0)GO TO 100 C C GO TO BRANCH FOR < 0 OR > = 0 C GO TO(70,75),IPC C C EVEN C 70 IF(ISTAT.NE.0)GO TO 85 C C 80 CALL MOVE(IGCB,XNEW,YNEW) IF(PCNTL.GT.0.AND.IPC.EQ.2)CALL PENDN(IGCB) C RETURN C C ODD C 75 IF(ISTAT.EQ.0)GO TO 80 85 CALL DRA  92840-18024 1819 S C0122 ABS DRAW              H0101 FTN,L C C C CC************************************************************ 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. * CC************************************************************ C C C C NAME: ABSOLUTE DRAW C SOURCE: 92840 - 18024 C RELOC: 92840 - 16001 C C C CC*********************************************************** C SUBROUTINE XDRAW(IN,IGCB,X,Y), 92840-16001 REV.1819 780515 INTEGER GICB,DRPPN,READ,WRITE,PLTAB,GRIFX DIMENSION ICODE(3),VAR(12),IBUFR(8),CLPTS(4) EQUIVALENCE (A,VAR),(B,VAR(2)),(C,VAR(3)),(D,VAR(4)) EQUIVALENCE (V5,VAR(5)),(IBUFR,LFTPN),(IBUFR(2),PLTAB) EQUIVALENCE (ICODE(2),ICD2),(ICODE(3),ICD3) EQUIVALENCE (IBUFR(3),IB3),(IBUFR(4),IB4) EQUIVALENCE (IBUFR(5),DRPPN),(IBUFR(6),IB6) EQUIVALENCE (IBUFR(7),IB7),(IBUFR(8),IB8) EQUIVALENCE (VAR(9),XOLD),(VAR(10),YOLD) EQUIVALENCE (VAR(11),XNEW),(VAR(12),YNEW) EQUIVALENCE (CLPTS(3),CLP3),(CLPTS(4),CLP4) EQUIVALENCE (CLPTS,CLP1),(CLPTS(2),CLP2) C C C C THIS IS THE CORE MODULE FOR ABSOLUTE DRAWS C DATA READ/1/ DATA WRITE/2/ DATA LFTPN/20400B/ DATA GICB/16/ DATA DRPPN/21000B/ DATA PLTAB/21402B/ C IFLG = 0 ISTAT = 0 IB6 = PLTAB CCCC C THIS CALL ESTABLISHES AN ADDRESS LINK BETWEEN THE GRAPGHICS C PACKAGE AND THE CURRENT GCB AND ALSO CHECKS FOR A SUSPENDED GCB. C ISUSP= 0 CALL GCBIM(99,1,IGCB,ISUSP) IF(ISUSP.NE.0)RETURN C C INITIALIZE CODES FOR GCBIM C C WHERE 11 = TRANSFORMATION CONSTANTS C 9 = MAPPING ENDPOINTS V1,V2 C 18 = PREVIOUS X,Y C ICODE = IADCD(D) ICD2 = IS1V1(D) C C LOOK AT STATUS WORD TO DETERMINE UNITS (UDU OR GDU  ), AND C EXAMINE SAME WORD TO ASCERTAIN WHETHER OR NOT CLIPPING IS ON. C ICD3 = 18 CALL GCBIM(ICODE,3,VAR, 0,READ) C C C C COMPUTE NEW POINTS AND CLIP AWAY THE FAT C XNEW =(A* X + B) YNEW = C * Y + D C C WRITE(6,3000)X,Y C000 FORMAT(2X,2(X,F10.3)) C C C NOW DO DE CLIPPING. C 20 CALL CLPNG(XOLD, CLPTS,V5,IFLG) C WRITE(6,5500)XOLD,YOLD,XNEW,YNEW,CLP1,CLP2,CLP3,CLP4 C WRITE(6,1000)IFLG C000 FORMAT(2X,"IFLG = ",I4) C500 FORMAT("DRAW",2X,8(X,F5.2)) 22 IF(IFLG)600,100,600 C C NOW DROP-PEN AND MAKE A MARK C 100 IB3 = GRIFX(CLP1) IB4 = GRIFX(CLP2) IB7 = GRIFX(CLP3) IB8 = GRIFX(CLP4) IF(CLP1.EQ.XOLD.AND.CLP2.EQ.YOLD)GO TO 56 CALL OUTPT(4,IBUFR,2) GO TO 600 56 CALL OUTPT(2,DRPPN,2) C C SET STATUS WORD TO INDICATE PEN DOWN AND SET NEW POINTS C INTO GCB. 600 CALL GRSTS(2,67577B,10200B) CALL GCBIM(18,1,XNEW ,4,WRITE) IF(IFLG.EQ.1)CALL PLTER(20,8) C C CHECK FOR PREVIOUS CALL TO PORG (BIT 8=1) C IF NOT NEW POINTS BECOME ORIGIN FOR A RELATIVE CALL. C CALL GRSTS(1,400B,ISTAT) IF(ISTAT.NE.0)RETURN C C PORG(X,Y) C XNEW = X YNEW = Y CALL GCBIM(17, 1,XNEW,0,2) RETURN END END$ 92840-18025 1819 S C0122 ABS MOVE              H0101 ؆FTN,L C C C CC************************************************************ 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. * CC************************************************************ C C C C NAME: MOVE ABSOLUTE C SOURCE: 92840 - 18025 C RELOC: 92840 - 16001 C C C CC*********************************************************** C SUBROUTINE XMOVE(IN,IGCB,X,Y), 92840-16001 REV.1819 780515 INTEGER PLTAB,GRIFX DIMENSION CLPTS(4) DIMENSION IBUFR(4),VAR(12),ICODE(3) EQUIVALENCE (VAR,A),(VAR(2),B),(VAR(3),C),(VAR(4),D) EQUIVALENCE (IBUFR,LFTPN),(VAR(5),V5),(VAR(9),XOLD) EQUIVALENCE (VAR(11),XNEW),(VAR(12),YNEW) EQUIVALENCE (IBUFR(2),PLTAB),(IBUFR(3),IB3),(IBUFR(4),IB4) EQUIVALENCE (CLP3,CLPTS(3)),(CLP4,CLPTS(4)) EQUIVALENCE (ICODE(2),ICD2),(ICODE(3),ICD3) C DATA LFTPN/20400B/ DATA PLTAB/21402B/ C C THIS IS THE MODULE FOR PROCESSING ABSOLUTE MOVES. C ISTAT = 0 IFLG = 0 IST1 = 0 ICD3 = 18 C CCCC C THIS CALL ESTABLISHES AN ADDRESS LINK BETWEEN THE GRAPGHICS C PACKAGE AND THE CURRENT GCB AND ALSO CHECKS FOR A SUSPENDED GCB. C ISUSP= 0 CALL GCBIM(99,1,IGCB,ISUSP) IF(ISUSP.NE.0)RETURN ICODE = IADCD(D) ICD2 = IS1V1(D) CALL GCBIM(ICODE,3,VAR,0,1) C C COMPUTE NEW POINTS. C XNEW = (A * X) + B YNEW = (C * Y) + D C C CALL CLPNG(XOLD,CLPTS,V5,IFLG) IF(IFLG.NE.0)GO TO 20 10 IB3 = GRIFX(CLP3) IB4 = GRIFX(CLP4) CALL OUTPT(2,IBUFR,2) C C PUT NEW POINTS INTO GCB AND SET STATUS WORD = PENUP. C 20 CALL GCBIM(18,1,XNEW,4,2) CALL GRSTS(2,67577B,10000B) C C SET SOFT ERROR IF POINT OUTSIDE CLIPPING BOUNDARY C _   IF(IFLG.EQ.1)CALL PLTER(20,8) C C CHECK FOR PREVIOUS CALL TO PORG (BIT 8=1) C IF NOT NEW POINTS BECOME ORIGIN FOR A RELATIVE CALL. C CALL GRSTS(1,400B,ISTAT) IF(ISTAT.NE.0)RETURN C C PORG(X,Y) C XNEW = X YNEW = Y CALL GCBIM(17, 1,XNEW,0,2) RETURN END END$ T   92840-18026 1819 S C0122 PEN LINE INT MOD              H0101 81   ! 92840-18027 1819 S C0122 PEN & LINE CMNDS              H0101 3   AND A PREVIOUS LINE C TYPE HAS BEEN SELECTED DO NOTHING. C NUMPN = LOGICAL PENS, NUMPH = PHYSICAL PENS C IF(ISUSP.NE.0.AND.IB3.EQ.1)GO TO 17 IB2 = P1 CALL OUTPT(1,NUMPN,1) CALL GCBIM(16,1,IB4,0,1) IF(P1.NE.0.AND.IB3.EQ.1)IB2 = P1 -1 IF(P1.GT.IB4.AND.IB3.EQ.1)IB2 = MOD(IB2,IB4) + 1 IF(P1.GT.IB3.AND.IB3.GT.1)IB2 = MOD(P1,IB3) + 1 IBUFR = SELPN IF(P1.EQ.0)IBUFR = SELP0 CALL OUTPT(1,IBUFR,2) RETURN C 17 CALL GCBIM(31,1,IB2,1,1) GO TO 600 C C LINE TYPE - MAXIMUM OF 6 PREDEFINED LINE TYPES C 20 IERR = 21 IF(P1.GT.6.OR.P1.LT.0)GO TO 800 IB2 = P1 C C SEE IF WE USE DEFAULT LINE TYPE C CALL GCBIM(IADP,1,VAR,0,1) C C CONVERT GDUS TO MUS C C XLIN = VAR * P2 C IBUFR = LINT C C PUT LINE TYPE AND LENGTH INTO GCB C 25 CALL GCBIM(31,1,IB2,0,2) CALL GRSTS(2,73777B,4000B) 600 IBUFR = DFLIN CALL OUTPT(1,IBUFR,2) RETURN 800 CALL PLTER(IERR,40) IF(IERR.EQ.29)RETURN IB2 = 0 GO TO 25 END  " 92840-18028 1819 S C0122 PDIR LDIR IN MOD              H0101 ,: " 92840-18029 1819 S C0122 LDIR PDIR CMNDS              H0101 UFTN,L C C C CC************************************************************ 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. * CC************************************************************ C C C C NAME: LDIR,PDIR C SOURCE: 92840 - 18029 C RELOC: 92840 - 16001 C C C CC*********************************************************** C SUBROUTINE LPDIR(IND,IGCB,P1,P2), 92840-16001 REV.1819 780515 DIMENSION IBUFR(5),VAR(4) EQUIVALENCE (IBUFR(2),IB2,X),(IBUFR(4),Y) EQUIVALENCE(VAR,A),(VAR(2),B),(VAR(3),C),(VAR(4),D) DATA LDIR/7002B/ DATA LDIRT/22/ DATA IPDIR/19/ XTEST =2.**14 C C THIS ROUTINE IS RESPONSIBLE FOR PROCESSING THE AGL COMMANDS C LDIR (LABEL DIRECTION) AND PDIR (PLOT DIRECTION). C THE IND INDICATES WHETHER THE PARAMETER IS AN ANGLE(RADIANS) C OR X AND Y COMPONENTS. C C IND P1 P2 C 1 THETA - PDIR C 2 X COMP Y COMP " C 3 THETA - LDIR C 4 X Y " C CCCC C THIS CALL ESTABLISHES AN ADDRESS LINK BETWEEN THE GRAPGHICS C PACKAGE AND THE CURRENT GCB AND ALSO CHECKS FOR A SUSPENDED GCB. C ISUSP= 0 CALL GCBIM(99,1,IGCB,ISUSP) IF(ISUSP.NE.0)RETURN C CONVERT P1 P2 TO CURRENT UNITS C IBUFR = IADCD(D) CALL GCBIM(IBUFR,1,VAR,0,1) GO TO(5,50,5,50),IND 50 X = P1 * A Y = P2 * C 5 GO TO(10,20,30,40),IND C C CHECK FOR OVERFLOW C 10 XSC = P1/3.1414 XSIN = .5 * ABS(XSC + .5) XCOS = .5 * ABS(XSC) IF(XSIN.GT.XTEST.OR.XCOS.GT.XTEST)GO TO 800 IF(P1.GT.6.28)CALL PLTER(30) X = COS(P1) Y = SIN(P1) GO TO 25 C C USE GO  OD OLD PYTHAGOREAN THEOREM TO COMPUTE SIN AND COSINE C 20 DENOM = SQRT(X**2 + Y**2) IF(DENOM.EQ.0.)GO TO 25 X = X/DENOM Y = Y/DENOM 25 CALL GCBIM(IPDIR,1,X,0,2) RETURN C C PROCESSING FOR LDIR C C FIRST SEE IF X OR Y = 0 AND IF SO MUST DETERMINE C ANGLE BY SUREPTITIOUS MEANS. C C + Y=+ C + X=0 C + C + C + C + C X= - + C Y = 0 + C +++++++++++++++++++++++++++++++++++++++ Y=0,X=+ C + C + C + C + C + C + C + C + Y = - C + X = 0 C C 40 IF(X.EQ.0.0.OR.Y.EQ.0.)GO TO 45 X = ATAN(Y/X) GO TO 35 45 IF(X)60,75,70 60 X = 3.14 GO TO 35 70 X = 0. GO TO 35 75 X= 1.57 IF(Y.LT.0.)X = 4.71 GO TO 35 C C AT THIS POINT THEANGLE HAS BEEN DETERMINED C 30 X = P1 35 IF(ABS(X).LE.6.28)GO TO 36 CALL PLTER(30) X = AMOD(X,6.28) 36 IF(X.LT.0.)X= 6.28 - ABS(X) IF(X.EQ.6.28)X = 0.0 IBUFR = LDIR CALL OUTPT(1,IBUFR,2) CALL GCBIM(LDIRT,1,X,0,2) RETURN C 800 CALL PLTER(36) RETURN C END END$ { 92840-18030 1819 S C0122 LORG COMMAND              H0101 FTN,L C C C CC************************************************************ 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. * CC************************************************************ C C C C NAME: LABEL ORIGIN C SOURCE: 92840 - 18030 C RELOC: 92840 - 16001 C C C CC*********************************************************** C SUBROUTINE XLORG(INN,IGCB,MODE), 92840-16001 REV.1819 780515 DIMENSION IBUFR(2),LRBUF(2) EQUIVALENCE (IB2,IBUFR(2)),(LRBUF,L1),(LRBUF(2),L2) EQUIVALENCE (IBUFR,LRG) DATA LRG/6401B/ DATA LORNG/34002B/ DATA LARG/21/ C C THIS MODULE IS FOR THE AGL COMMAND LABLE ORIGIN (LORG) C CCCC C THIS CALL ESTABLISHES AN ADDRESS LINK BETWEEN THE GRAPGHICS C PACKAGE AND THE CURRENT GCB AND ALSO CHECKS FOR A SUSPENDED GCB. C ISUSP= 0 CALL GCBIM(99,1,IGCB,ISUSP) IF(ISUSP.NE.0)RETURN C C LORG RANGE C CALL OUTPT(1,LORNG,1) CALL GCBIM(16,1,LRBUF,2,1) C C SEE IF MODE IS: 0 = 0 C GO TO(70,75),IPC C C EVEN C 70 IF(ISTAT.NE.0)GO TO 85 C C SET BIT 4 OF STATUS FOR CALL TO MOVEI(IPLOT(X,Y,-2) C 80 CALL MOVER(IGCB,X,Y) IF(PCNTL.GT.0.AND.IPC.EQ.2)CALL PENDN(IGCB) C RETURN C C ODD C 75 IF(ISTAT.EQ.0)GO TO 80 85 CALL DRAWR(IGCB,X,Y) IF(PCNTL.GE.0.AND.ISTAT.NE.0.AND.IPC.EQ.1)CALL PENUP(IGCB) RETURN C C PCNT LT 0 C 100 GO TO(80,85),IPC END END$ #  #* 92840-18036 1819 S C0122 REL MOVE CMND              H0101 4FTN,L C C C CC************************************************************ 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. * CC************************************************************ C C C C NAME: MOVE RELOCATABLE C SOURCE: 92840 - 18036 C RELOC: 92840 - 16001 C C C CC*********************************************************** C SUBROUTINE XMOVR(IN,IGCB,X,Y), 92840-16001 REV.1819 780515 INTEGER LFTPN,READ,WRITE,PLTRL,PLTAB,GRIFX DIMENSION ICODE(5),VAR(16),IBUFR(8),CLPTS(4) EQUIVALENCE (A,VAR),(B,VAR(2)),(C,VAR(3)),(D,VAR(4)) EQUIVALENCE (V5,VAR(5)),(IBUFR,LFTPN),(IBUFR(2),PLTAB) EQUIVALENCE(IBUFR(3),IB3) EQUIVALENCE (IBUFR(4),IB4),(IBUFR(5),LIFT), (IBUFR(6),PLTRL) EQUIVALENCE (IBUFR(7),IB7),(IBUFR(8),IB8) EQUIVALENCE (ICODE(2),ICD2),(ICODE(3),ICD3),(ICODE(4),ICD4) EQUIVALENCE (ICODE(5),ICD5) EQUIVALENCE (VAR(15),XNEW),(VAR(16),YNEW) EQUIVALENCE (VAR( 9),THETX),(VAR(10),THETY) EQUIVALENCE (VAR(11),PORGX),(VAR(12),PORGY) EQUIVALENCE(CLPTS,CLP1),(CLPTS(2),CLP2) EQUIVALENCE (CLPTS(3),CLP3),(CLPTS(4),CLP4) EQUIVALENCE(VAR(13),XOLD),(VAR(14),YOLD) C C C C THIS IS THE CORE MODULE FOR RELATIVE MOVE C DATA READ/1/ DATA WRITE/2/ DATA LFTPN/20400B/ DATA LIFT/20400B/ DATA PLTAB/21402B/ DATA PLTRL/21402B/ C DATA ICD3,ICD4/19,17/ IFLG = 0 IST1 = 0 XNEW = 0. YNEW = 0. ISTAT = 0 ICD5 = 18 C CCCC C THIS CALL ESTABLISHES AN ADDRESS LINK BETWEEN THE GRAPGHICS C PACKAGE AND THE CURRENT GCB AND ALSO CHECKS FOR A SUSPENDED GCB. C ISUSP= 0 CALL GCBIM(99,1,IGCB,ISUSP) IF(ISUSP.NE.0)RETURN C C C INITIALIQMZE CODES FOR GCBIM C C WHERE 11 = TRANSFORMATION CONSTANTS C 9 = MAPPING ENDPOINTS V1,V2 C 17 = PLOT ORIGINS (PORGX AND PORGY) C 18 = PREVIOUS X,Y C 19 = COS(THETA),SIN(THETA) C ICODE = IADCD(D) ICD2 = IS1V1(D) C C LOOK AT STATUS WORD TO DETERMINE UNITS (UDU OR GDU), AND C EXAMINE SAME WORD TO ASCERTAIN WHETHER OR NOT CLIPPING IS ON. C CALL GCBIM(ICODE,5,VAR, 0,READ) C C C COMPUTE NEW POINTS BY FIRST DOING TRANSLATION AND C SCALING, AND SECOND PERFORMING THE ROTATION. C THE ROTATION PROCESS INVOLVES ROTATING A VECTOR ABOUT C THE SAME ORIGIN AS THE ORIGINAL AXES, (ANGLES ARE COUNTER- C CLOCKWISE). THE CONSTANTS COS(THETA) AND SIN(THETA) RESIDE C IN THE GCB AND ARE DETERMINED FROM PDIR(THETA). C THE OTHER THING THAT HAS TO BE DONE HERE IS TO COMPUTE C THE NEW ENDPOINTS AND CLIP(IF SOFT CLIPPING IS ON). C C C RE-ESTABLISH ORIGIN C PORGX = PORGX * A + B PORGY = PORGY * C + D IF(X.NE.0.)XNEW = A * X IF(Y.NE.0.)YNEW = C * Y XN = (XNEW * THETX) - (YNEW * THETY) YN = (XNEW * THETY) + (YNEW * THETX) XNEW = XN + PORGX YNEW = YN + PORGY C C C C WRITE(6,2500)X,Y C500 FORMAT(2X,2(X,F5.2)) C NOW DO DE CLIPPING. C 20 CALL CLPNG(XOLD ,CLPTS,V5,IFLG) C WRITE(6,5500)XOLD,YOLD,XNEW,YNEW,CLP1,CLP2,CLP3,CLP4 C500 FORMAT("DRAW",2X,8(X,F5.2)) C WRITE(6,7500)PORGX,PORGY C500 FORMAT(2X,"PORGS",2X,2(X,F7.2)) 22 IF(IFLG)600,25,600 C C NOW LIFT-PEN AND MOVE TO X,Y C 25 IB7 = GRIFX(CLP3) IB8 = GRIFX(CLP4) CALL OUTPT(2,LIFT,2) C C SET STATUS WORD TO INDICATE PEN UP AND SET NEW POINTS C INTO GCB. C 600 CALL GRSTS(2,67577B,10000B) CALL GCBIM(18,1,XNEW ,4,WRITE) IF(IFLG.EQ.1)CALL PLTER(20) RETURN END END$ h 92840-18037 1819 S C0122 REL DRAW CMND              H0101 FTN,L C C C CC************************************************************ 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. * CC************************************************************ C C C C NAME: DRAW RELOCATABLE C SOURCE: 92840 - 18037 C RELOC: 92840 - 16001 C C C CC*********************************************************** C SUBROUTINE XDRWR(IN,IGCB,X,Y), 92840-16001 REV.1819 780515 INTEGER DRPPN,READ,WRITE,PLTRL,GRIFX INTEGER PLTAB DIMENSION ICODE(5),VAR(16),IBUFR(8) ,CLPTS(4) EQUIVALENCE (A,VAR),(B,VAR(2)),(C,VAR(3)),(D,VAR(4)) EQUIVALENCE (V5,VAR(5)),(IBUFR,LFTPN),(IBUFR(2),PLTAB) EQUIVALENCE(IBUFR(3),IB3) EQUIVALENCE (IBUFR(4),IB4),(IBUFR(5),DRPPN),(IBUFR(6),PLTRL) EQUIVALENCE (IBUFR(7),IB7),(IBUFR(8),IB8) EQUIVALENCE (ICODE(2),ICD2),(ICODE(3),ICD3),(ICODE(4),ICD4) EQUIVALENCE (ICODE(5),ICD5) EQUIVALENCE (VAR(15),XNEW),(VAR(16),YNEW) EQUIVALENCE (VAR(9) ,THETX),(VAR(10),THETY) EQUIVALENCE (VAR(11),PORGX),(VAR(12),PORGY) EQUIVALENCE (CLPTS(3),CLP3),(CLPTS(4),CLP4) EQUIVALENCE (CLP1,CLPTS(1)),(CLP2,CLPTS(2)) EQUIVALENCE(VAR(13),XOLD),(VAR(14),YOLD) C C C C THIS IS THE CORE MODULE FOR RELATIVE DRAW C DATA READ/1/ DATA WRITE/2/ DATA DRPPN/21000B/ DATA LFTPN/20400B/ DATA PLTRL/21402B/ DATA PLTAB/21402B/ C DATA ICD3,ICD4/19,17/ IFLG = 0 ISTAT = 0 XNEW = 0. YNEW = 0. CCCC C THIS CALL ESTABLISHES AN ADDRESS LINK BETWEEN THE GRAPGHICS C PACKAGE AND THE CURRENT GCB AND ALSO CHECKS FOR A SUSPENDED GCB. C ISUSP= 0 CALL GCBIM(99,1,IGCB,ISUSP) IF(ISUSP.NE.0)RETURN C ICD5 = 18 C INITIALIZE  %- FTN,L C C C CC************************************************************ 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. * CC************************************************************ C C C C NAME: PEN DOWN C SOURCE: 92840 - 18038 C RELOC: 92840 - 16001 C C C CC*********************************************************** C SUBROUTINE XPNDN(IN,IGCB), 92840-16001 REV.1819 780515 INTEGER DRPPN DIMENSION VAR(8) DIMENSION CLPTS(4) EQUIVALENCE ( P1,VAR),( P2,VAR(2)),( P3,VAR(3)),( P4,VAR(4)) EQUIVALENCE (V1X,VAR(5)) C C CCCC C THIS CALL ESTABLISHES AN ADDRESS LINK BETWEEN THE GRAPGHICS C PACKAGE AND THE CURRENT GCB AND ALSO CHECKS FOR A SUSPENDED GCB. C ISUSP= 0 DRPPN = 21000B CALL GCBIM(99,1,IGCB,ISUSP) IF(ISUSP.NE.0)RETURN CALL GCBIM(18,1,VAR,0,1) P3 = P1 P4 = P2 ICODE = IS1V1(D) CALL GCBIM(ICODE,1,V1X,0,1) ICODE = 0 CALL CLPNG(P1,CLPTS,V1X,ICODE) IF(ICODE.NE.0)GO TO 10 CALL OUTPT(1,DRPPN,2) 10 CALL GRSTS(2,77577B,200B) RETURN END END$  &, 92840-18039 1819 S C0122 INCREMENTAL MOVE              H0101 AFTN,L C C C CC************************************************************ 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. * CC************************************************************ C C C C NAME: MOVE INCREMENTAL C SOURCE: 92840 - 18039 C RELOC: 92840 - 16001 C C C CC*********************************************************** C SUBROUTINE XMOVI(IN,IGCB,X,Y), 92840-16001 REV.1819 780515 INTEGER READ,WRITE,PLTIN,GRIFX DIMENSION ICODE(4),VAR(14),IBUFR(4),CLPTS(4) EQUIVALENCE (A,VAR),(B,VAR(2)),(C,VAR(3)),(D,VAR(4)) EQUIVALENCE (V5,VAR(5)),(IBUFR,LFTPN),(IBUFR(2),PLTIN) EQUIVALENCE (ICODE(2),ICD2),(ICODE(3),ICD3),(ICODE(4),ICD4) EQUIVALENCE (IBUFR(3),IB3),(IBUFR(4),IB4) EQUIVALENCE (VAR(11),XOLD),(VAR(12),YOLD) EQUIVALENCE (VAR(13),XNEW),(VAR(14),YNEW) EQUIVALENCE (VAR( 9),THETX),(VAR(10),THETY) EQUIVALENCE (CLPTS(3),CLP3),(CLPTS(4),CLP4) C C C C THIS IS THE CORE MODULE FOR INCREMENTAL MOVE C DATA READ/1/ DATA WRITE/2/ DATA LFTPN/20400B/ DATA PLTIN/21402B/ C DATA ICD3,ICD4/19,18/ IFLG = 0 IST1 = 0 ISTAT = 0 CCCC C THIS CALL ESTABLISHES AN ADDRESS LINK BETWEEN THE GRAPGHICS C PACKAGE AND THE CURRENT GCB AND ALSO CHECKS FOR A SUSPENDED GCB. C ISUSP= 0 CALL GCBIM(99,1,IGCB,ISUSP) IF(ISUSP.NE.0)RETURN C C INITIALIZE CODES FOR GCBIM C C WHERE 11 = TRANSFORMATION CONSTANTS C 9 = MAPPING ENDPOINTS V1,V2 C 18 = PREVIOUS X,Y C 19 = COS(THETA),SIN(THETA) C ICODE = IADCD(D) ICD2 = IS1V1(D) C C LOOK AT STATUS WORD TO DETERMINE UNITS (UDU OR GDU), AND C EXAMINE SAME WORD TO ASCERTAIN WHETHER OR NOT CLIPPING IS% ON. C CALL GCBIM(ICODE,4,VAR, 0,READ) C C C C COMPUTE NEW POINTS BY FIRST DOING TRANSLATION AND C SCALING, AND SECOND PERFORMING THE ROTATION. C THE ROTATION PROCESS INVOLVES ROTATING A VECTOR ABOUT C THE SAME ORIGIN AS THE ORIGINAL AXES, (ANGLES ARE COUNTER- C CLOCKWISE). THE CONSTANTS COS(THETA) AND SIN(THETA) RESIDE C IN THE GCB AND ARE DETERMINED FROM PDIR(THETA). C THE OTHER THING THAT HAS TO BE DONE HERE IS TO COMPUTE C THE NEW ENDPOINTS AND CLIP(IF SOFT CLIPPING IS ON). C C CALL GRSTS(1,10000B,ISUSP) XNEW = 0. YNEW = 0. IF(X.EQ.0.)GO TO 72 XNEW =(A* X) 72 IF(Y.EQ.0.)GO TO 75 YNEW = C * Y 75 XN = (XNEW * THETX) - (YNEW * THETY) YN = (XNEW * THETY) + (YNEW * THETX) IF(ISUSP.NE.0)GO TO 77 XN = XN + B YN = YN + D 77 XNEW = XN + XOLD YNEW = YN + YOLD C C C C NOW DO DE CLIPPING. C 20 CALL CLPNG(XOLD, CLPTS,V5,IFLG) C C DEBUGGING C CD WRITE(6,5500)XOLD,YOLD,XNEW,YNEW,CLP1,CLP2 CD00 FORMAT("MOVEI ",2X,8(X,F5.2)) CD WRITE(6,7500)X,Y CD00 FORMAT(2X," POINTS X,Y",2X,2(X,F5.2)) C 22 IF(IFLG)600,25,600 C C NOW DROP-PEN AND MAKE A MARK C 25 IB3 = GRIFX(CLP3) IB4 = GRIFX(CLP4) CALL OUTPT(2,IBUFR,2) C C SET STATUS WORD TO INDICATE PEN UP AND SET NEW POINTS C INTO GCB. 600 CALL GRSTS(2,67577B,10000B) CALL GCBIM(18,1,XNEW ,4,WRITE) IF(IFLG.EQ.1)CALL PLTER(20,11) C C CHECK FOR PREVIOUS CALL TO PORG (BIT 8=1) C IF NOT NEW POINTS BECOME ORIGIN FOR A RELATIVE CALL. C CALL GRSTS(1,400B,ISTAT) IF(ISTAT.NE.0)RETURN C C PORG(X,Y) C XNEW = X YNEW = Y CALL GCBIM(17, 1,XNEW,0,2) RETURN END END$ k  '/ 92840-18040 1819 S C0122 INCREMENTAL DRAW              H0101 XWFTN,L C C C CC************************************************************ 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. * CC************************************************************ C C C C NAME: DRAW INCREMENTAL C SOURCE: 92840 - 18040 C RELOC: 92840 - 16001 C C C CC*********************************************************** C SUBROUTINE XDRWI(IN,IGCB,X,Y), 92840-16001 REV.1819 780515 INTEGER DRPPN,READ,WRITE,PLTIN,GRIFX INTEGER PLTAB DIMENSION ICODE(4),VAR(14),IBUFR(8),CLPTS(4) EQUIVALENCE (A,VAR),(B,VAR(2)),(C,VAR(3)),(D,VAR(4)) EQUIVALENCE (V5,VAR(5)),(IBUFR,LFTPN),(IBUFR(2),PLTAB) EQUIVALENCE (IBUFR(5),DRPPN),(IBUFR(6),PLTIN),(IBUFR(7),IB7) EQUIVALENCE (IBUFR(8),IB8) EQUIVALENCE (ICODE(2),ICD2),(ICODE(3),ICD3),(ICODE(4),ICD4) EQUIVALENCE (IBUFR(3),IB3),(IBUFR(4),IB4) EQUIVALENCE (VAR(9),THETX),(VAR(10),THETY) EQUIVALENCE (VAR(11),XOLD ),(VAR(12),YOLD ) EQUIVALENCE (VAR(13),XNEW), (VAR(14),YNEW) EQUIVALENCE (CLPTS(3),CLP3),(CLPTS(4),CLP4) EQUIVALENCE (CLPTS,CLP1),(CLPTS(2),CLP2) C C C C THIS IS THE CORE MODULE FOR INCREMENTAL DRAW C DATA READ/1/ DATA WRITE/2/ DATA LFTPN/20400B/ DATA PLTAB/21402B/ DATA DRPPN/21000B/ DATA PLTIN/21402B/ C DATA ICD3,ICD4/19,18/ IFLG = 0 ISTAT = 0 CCCC C THIS CALL ESTABLISHES AN ADDRESS LINK BETWEEN THE GRAPGHICS C PACKAGE AND THE CURRENT GCB AND ALSO CHECKS FOR A SUSPENDED GCB. C ISUSP= 0 CALL GCBIM(99,1,IGCB,ISUSP) IF(ISUSP.NE.0)RETURN C C INITIALIZE CODES FOR GCBIM C C WHERE 11 = TRANSFORMATION CONSTANTS C 9 = MAPPING ENDPOINTS V1,V2 C 18 = PREVIOUS X,Y C  19 = COS(THETA),SIN(THETA) C ICODE = IADCD(D) ICD2 = IS1V1(D) C C LOOK AT STATUS WORD TO DETERMINE UNITS (UDU OR GDU), AND C EXAMINE SAME WORD TO ASCERTAIN WHETHER OR NOT CLIPPING IS ON. C CALL GCBIM(ICODE,4,VAR, 0,READ) C C C C COMPUTE NEW POINTS BY FIRST DOING TRANSLATION AND C SCALING, AND SECOND PERFORMING THE ROTATION. C THE ROTATION PROCESS INVOLVES ROTATING A VECTOR ABOUT C THE SAME ORIGIN AS THE ORIGINAL AXES, (ANGLES ARE COUNTER- C CLOCKWISE). THE CONSTANTS COS(THETA) AND SIN(THETA) RESIDE C IN THE GCB AND ARE DETERMINED FROM PDIR(THETA). C THE OTHER THING THAT HAS TO BE DONE HERE IS TO COMPUTE C THE NEW ENDPOINTS AND CLIP(IF SOFT CLIPPING IS ON). C C CALL GRSTS(1,10000B,ISUSP) XNEW = 0. YNEW = 0. IF(X.EQ.0.)GO TO 72 XNEW =(A* X) 72 IF(Y.EQ.0. )GO TO 75 YNEW = C * Y 75 XN = (XNEW * THETX) - (YNEW * THETY) YN = (XNEW * THETY) + (YNEW * THETX) C IF(ISUSP.NE.0)GO TO 77 XN = XN + B YN = YN + D 77 XNEW = XN + XOLD YNEW = YN + YOLD C C CHECK TO SEE IF UNITS = GDUS C C C NOW DO DE CLIPPING. C 20 CALL CLPNG(XOLD, CLPTS,V5,IFLG) C C DEBUGGING C C WRITE(6,5500)XOLD,YOLD,XNEW,YNEW,CLP1,CLP2,CLP3,CLP4 C500 FORMAT("DRAWI ",2X,8(X,F5.2)) C WRITE(6,7500)X,Y C500 FORMAT(2X,"POINTS X,Y ",2(X,F7.2)) C C WRITE(6,8500)IFLG C500 FORMAT(2X,"IFLG =",K6) C 22 IF(IFLG)600,25,600 C C NOW DROP-PEN AND MAKE A MARK C 25 IB3 = GRIFX(CLP1) IB4 = GRIFX(CLP2) IB7 = GRIFX(CLP3) IB8 = GRIFX(CLP4) IF(CLP1.EQ.XOLD.AND.CLP2.EQ.YOLD)GO TO 35 CALL OUTPT(4,IBUFR,2) GO TO 600 35 CALL OUTPT(2,DRPPN,2) C C SET STATUS WORD TO INDICATE PEN DOWN AND SET NEW POINTS C INTO GCB. 600 CALL GRSTS(2,67577B,10200B) CALL GCBIM(18,1,XNEW ,4,WRITE) IF(IFLG.EQ.1)CALL PLTER(20,11) C C CHECK FOR PREVIOUS CALL TO PORG  (BIT 8=1) C IF NOT NEW POINTS BECOME ORIGIN FOR A RELATIVE CALL. C CALL GRSTS(1,400B,ISTAT) IF(ISTAT.NE.0)RETURN C C PORG(X,Y) C XNEW = X YNEW = Y CALL GCBIM(17, 1,XNEW,0,2) RETURN END END$ > (0 FTN,L C C C CC************************************************************ 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. * CC************************************************************ C C C C NAME: PLOT ORIGIN (PORG) C SOURCE: 92840 - 18041 C RELOC: 92840 - 16001 C C C CC*********************************************************** C SUBROUTINE XPORG(IN,IGCB,X,Y), 92840-16001 REV.1819 780515 DIMENSION XY(2) EQUIVALENCE (XY(2),YX) DATA IPORG/17/ C CCCC C THIS CALL ESTABLISHES AN ADDRESS LINK BETWEEN THE GRAPGHICS C PACKAGE AND THE CURRENT GCB AND ALSO CHECKS FOR A SUSPENDED GCB. C ISUSP= 0 CALL GCBIM(99,1,IGCB,ISUSP) IF(ISUSP.NE.0)RETURN C SET BIT INDICATING PORG HAS BEEN CALLED C CALL GRSTS(2,77377B,400B) XY = X YX = Y CALL GCBIM(IPORG,1,XY,0,2) RETURN END END$  )/ 92840-18042 1819 S C0122 TRANSMIT COMND              H0101 -G *0  +1 92840-18044 1819 S C0122 INCREMENT PLOT              H0101 J-FTN,L C C C CC************************************************************ 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. * CC************************************************************ C C C C NAME: PLOT INCREMENTAL C SOURCE: 92840 - 18044 C RELOC: 92840 - 16001 C C C CC*********************************************************** C SUBROUTINE PLOTI(IND,IGCB,X,Y, 1PCNTL), 92840-16001 REV.1819 780515 INTEGER PCNTL,READ,WRITE C C C THIS IS THE FUNCTIONAL FOR THE AGL COMMAND IPLOT C DATA READ/1/ DATA WRITE/2/ C IFLG = 0 ISTAT = 0 IST1 = 0 CCCC C THIS CALL ESTABLISHES AN ADDRESS LINK BETWEEN THE GRAPGHICS C PACKAGE AND THE CURRENT GCB AND ALSO CHECKS FOR A SUSPENDED GCB. C ISUSP= 0 CALL GCBIM(99,1,IGCB,ISUSP) IF(ISUSP.NE.0)RETURN C C CALL GRSTS(1,200B,ISTAT) C C C NOW ASCERTAIN FROM THE PEN-CONTROL PARAMETER (PCNTL) WHAT C ACTIONS TO TAKE. THE FOLLOWING MODES ARE DEFINED FOR THE C PEN CONTROL PARAMETER: C C EVEN = PEN UP C ODD = PEN DOWN C + = PEN CHANGE AFTER MOTION C - = PEN CHANGE BEFORE MOTION C 10 IPC =IABS(PCNTL) IPC = IAND(IPC,1) + 1 IF(PCNTL.LT.0)GO TO 100 C C GO TO BRANCH FOR < 0 OR > = 0 C GO TO(70,75),IPC C C EVEN C 70 IF(ISTAT.NE.0)GO TO 85 C C 80 CALL MOVEI(IGCB,X,Y) IF(PCNTL.GT.0.AND.IPC.EQ.2)CALL PENDN(IGCB) C RETURN C C ODD C 75 IF(ISTAT.EQ.0)GO TO 80 85 CALL DRAWI(IGCB,X,Y) IF(PCNTL.GE.0.AND.ISTAT.NE.0.AND.IPC.EQ.1)CALL PENUP(IGCB) RETURN C C PCNT LT 0 C 100 GO TO(80,85),IPC END END$    ,3 92840-18045 1819 S C0122 CSIZE INTF MOD              H0101 $ASMB,R,L * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: CSIZE INTFC MOD * SOURCE: 92840 - 18045 * RELOC: 92840 - 16001 * * * ************************************************************* * NAM CSIZE,7 92840-16001 REV.1819 780515 EXT .OPTN,XSIZE EXT PLTER ENT CSIZE * * THIS IS THE INTERFACE MODULE FOR THE AGL COMMAND CSIZE * CSIZE NOP LDA CSIZE JSB .OPTN DEF RTN PADR DEF PARM DEF M5 DEF .2 DEF .1 ONE REQUIRED PARAMETER IGCB DEF .3 3 DEFAULTS ASPECT RATIO AND SLANT,HEIGHT DEF DZER0 TOP OF LIST FOR DEFAULTS DEF RETRN RTN JMP ERROR JSB XSIZE DEF END PARM BSS 5 END JMP RETRN,I SPC 2 DFLT DEC 2.78 .0 DEC 0. DZER0 DEF DFLT DEF .0 DEF .0 .3 DEC 3 .1 OCT 1 .2 OCT 2 M5 DEC -5 RETRN NOP ERROR LDA PARM+1 STA IGCB JSB PLTER DEF RTNER DEF .50 IGCB NOP RTNER JMP RETRN,I * .50 DEC 50 END g -3 FTN,L C C C CC************************************************************ 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. * CC************************************************************ C C C C NAME: CSIZE C SOURCE: 92840 - 18046 C RELOC: 92840 - 16001 C C C CC*********************************************************** C SUBROUTINE XSIZE(IND,IGCB,P1,P2,P3), 92840-16001 REV.1819 780515 DIMENSION VAR(4),IBUFR(5),ICHBF(9) EQUIVALENCE (IBUFR(2),CHRW,SLANT),(IBUFR(4),CHRH) EQUIVALENCE (ICHBF,CWMIN),(ICHBF(3),CHMIN) EQUIVALENCE (ICHBF(5),CWMAX),(ICHBF(7),CHMAX),(ICHBF(9),ICHB9) EQUIVALENCE (VAR,A),(VAR(3),C) DATA IADP/11/ DATA ICHW/10404B/ DATA ISLNT/7402B/ DATA ICHMM/33011B/ DATA ISLOF/10000B/ DATA ICHR/4404B/ DATA ICLSZ/4404B/ C C THIS IS THE FUNCTIONAL MODULE FOR THE AGL COMMAND CSIZE. C C THE PARAMETERS IN THE CALLING SEQUENCE HAVE THE FOLLOWING C MEANING C P1 = CHARACTER HEIGHT,P2= ASPECT RATIO,P3=SLANT C XCH = P1 IF(P1.EQ.0)XCH = 2.78 XCW =XCH * P2 IF(P2.EQ.0)XCW = .7 * XCH CCCC C THIS CALL ESTABLISHES AN ADDRESS LINK BETWEEN THE GRAPGHICS C PACKAGE AND THE CURRENT GCB. C ISUSP = 0 CALL GCBIM(99,1,IGCB,ISUSP) IF(ISUSP.NE.0)RETURN C C C RETRIEV CHARACTER SIZE INFORMATION FROM THE DEVICE SUBROUTINE. C CALL OUTPT(1,ICHMM,1) CALL GCBIM(16,1,ICHBF,9,1) C C TRANSFORM GDUS TO MUS AND COMPUTE CHARACTER WIDTH C WHICH IS EQUAL TO ASPECT RATIO * CHAR HEIGHT *MU/GDU C CALL GCBIM(IADP,1,VAR,0,1) CHRH =XCH * C CHRW = XCW * A C C NOW CHECK ON MIN AND MAX CHARACTER SIZES DEVICE WILL TOLERATE C IF(CHRH.LT.CHMIN)C5  HRH = CHMIN IF(CHRH.GT.CHMAX)CHRH = CHMAX IF(CHRW.LT.CWMIN)CHRW = CWMIN IF(CHRW.GT.CWMAX)CHRW = CWMAX C C CHECK TO MAKE SURE DEVICE CAN HANDLE NEGATIVE CSIZE C IF(P1.LT.0.0.AND.ICHB9.EQ.0)CALL PLTER(22) IF(P2.LT.0.0.AND.ICHB9.EQ.0)CALL PLTER(22) IBUFR = ICHW CALL OUTPT(1,IBUFR,2) CALL GCBIM(7,1,CHRW,0,2) CALL OUTPT(1,ICHR,1) CALL GCBIM(16,1,7,1,3) C C NOW FOR THE SLANT IF P3 = 0. SLANT OFF COMMAND IS EMITTED C IBUFR = ISLNT IF(P3.EQ.0.)IBUFR = ISLOF SLANT = P3 IF(ABS(P3).GT.6.28)SLANT = AMOD(P3,6.28) CALL OUTPT(1,IBUFR,2) C C NOW UPDATE GCB WITH NEW CHARACTER HEIGHT,WIDTH SLANT ETC. C RETURN END END$ ~  .5 92840-18047 1819 S C0122 DSIZE INTF MOD              H0101 "$ /5 92840-18048 1819 S C0122 DSIZE CMND              H0101 FTN,L C C C CC************************************************************ 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. * CC************************************************************ C C C C NAME: DSIZE C SOURCE: 92840 - 18048 C RELOC: 92840 - 16001 C C C CC*********************************************************** C SUBROUTINE XDSIZ(IND,IGCB,XGDU,YGDU, 1CHRHT,AR,XRES,YRES), 92840-16001 REV.1819 780515 DIMENSION VAR(8),ICODE(4) EQUIVALENCE (VAR,AP),(VAR(5),CHRW),(VAR(6),CHRH) EQUIVALENCE (VAR(7),DXGDU),(VAR(3),CP) EQUIVALENCE (VAR(8),DYGDU),(ICODE,IADP),(ICODE(2),ICHCD) EQUIVALENCE (ICODE(3),IGDU) C C THIS IS THE FUNCTIONAL MODULE FOR THE AGL COMMAND DSIZE, C GET SIZE RELATED INFORMATION ABOUT THE DEVICE. C WHERE XGDU,YGDU = G2 LIMITS IN GDUS C CHRHT = CHARACTER HEIGHT C AR = ASPECT RATIO C XRES,YRES = RESOLUTION IN GDUS C DATA IADP/11/ DATA ICHCD/7/ DATA IGDU/15B/ C C CCCC C THIS CALL ESTABLISHES AN ADDRESS LINK BETWEEN THE GRAPGHICS C PACKAGE AND THE CURRENT GCB AND ALSO CHECKS FOR A SUSPENDED GCB. C ISUSP= 0 CALL GCBIM(99,1,IGCB,ISUSP) IF(ISUSP.NE.0)RETURN C RETRIEVE MU/GDU CONSTANT, CHARATER H-W, AND PLOT SURFACE C LENGTH-WIDTH IN GDUS. C CALL GCBIM(ICODE,3,VAR,0,1) XGDU = DXGDU YGDU = DYGDU CHRHT = CHRH/CP AR = CHRW/CHRH XRES = 1.0/AP YRES = 1.0/CP RETURN END END$    07 92840-18049 1819 S C0122 DSTAT CMND              H0101 FTN,L C C C CC************************************************************ 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. * CC************************************************************ C C C C NAME: DEVICE STATUS (DSTAT) C SOURCE: 92840 - 18049 C RELOC: 92840 - 16001 C C C CC*********************************************************** C SUBROUTINE XDSTT(INN,IGCB,INDEX,INDIC, 1IARRY), 92840-16001 REV.1819 780515 DIMENSION INDEX(2),IARRY(2) DIMENSION ICAP(10) EQUIVALENCE (ICAP,ID),(ICAP(2),ICLR),(ICAP(3),NUMPN) EQUIVALENCE (ICAP(4),NCURS),(LORG,ICAP(5)) EQUIVALENCE (ICAP(6),ISLNT),(ICLIP,ICAP(7)),(LDIR,ICAP(8)) C C THIS IS THE COMMAND PROCESSOR FOR THE AGL COMMAND C DSTAT. THIS COMMAND INFORMS THE USER OF THE DEVICE C CAPABILITIES. C C CALLING SEQUENCE PARAMETERS: IGCB -GCB C INDEX - ARRAY CONTAINING INTEGER VALUES WHICH INDICATE C WHICH CAPABILITY IS OF INTEREST. C INDIC - NUMBER OF ENTRIES IN INDEX. C IARRY - RETURN BUFFER WHERE DATA IS TO GO. C C THE ARRAY ICAP CONTAINS THE GRAPHIC INTERPRETIVE CODES C NECESSARY TO RETRIEVE THE DATA FROM THE DEVICE OR DEVICE C SUBROUTINE. C DATA ID/ 3003B/ DATA ICLR/27401B/ DATA NUMPN/30001B/ DATA NCURS/30401B/ DATA LORG/31001B/ DATA ISLNT/31404B/ DATA ICLIP/32001B/ DATA MAXCP/8/ DATA LDIR/33403B/ C CCCC C THIS CALL ESTABLISHES AN ADDRESS LINK BETWEEN THE GRAPGHICS C PACKAGE AND THE CURRENT GCB AND ALSO CHECKS FOR A SUSPENDED GCB. C ISUSP= 0 CALL GCBIM(99,1,IGCB,ISUSP) IF(ISUSP.NE.0)RETURN J = 1 IF(INDIC)800,800,5 5 DO 500 I=1,INDIC INST = INDEX(I) IF(INST.LE.0.OR.INST.GT.>  MAXCP)GO TO 800 ITHNG = ICAP(INST) C C NUMBER OF ITEMS ASSOCIATED WITH GIC C NUM = IAND(ITHNG,377B) C C CALL DEV. SUB. TO GET DATA C CALL OUTPT(1,ITHNG,1) CALL GCBIM(16,1,IARRY(J),NUM,1) J = J + NUM 500 CONTINUE C RETURN C 800 CALL PLTER(27) RETURN END END$ U  18 92840-18050 1819 S C0122 GSTAT CMND              H0101 TWEEN THE GRAPGHICS C PACKAGE AND THE CURRENT GCB AND ALSO CHECKS FOR A SUSPENDED GCB. C ISUSP= 0 CALL GCBIM(99,1,IGCB,ISUSP) IF(ISUSP.NE.0)RETURN C FIRST DETERMINE IF WE HAVE AN ERROR INDX<1 OR > 16 C THEN IF NO ERROR COMPUTE POINTER INTO IGTBL TO GET C GET THE CORRECT INDEX FOR THE GCB. IF THE POINTER IS C NEGATIVE GO DO SOMETHING SPECIAL. C J = 1 IF(LOOP)800,800,5 5 DO 550 I = 1,LOOP INTST = INDX(I) IF(INTST.LE.0.OR.INTST.GT.16)GO TO 800 C C NOW LOOP AROUND AN FILL IARRY WITH ALL THE DATA REQUESTED C IPTR = IGTBL(INTST) IF(IPTR.LT.0)GO TO 100 C C DETERMINE THE NUMBER OF WORDS THAT WILL BE FILLED UP C IN IARRY. C NUM = IAND(IPTR,177400B)/400B IPTR = IAND(IPTR,377B) CALL GCBIM(IPTR,1,IARRY(J),0,1) GO TO 500 C C GET INFO FROM STATUS WORD C 100 IPTR = -IPTR GO TO(110,120,130,140,140,140,150,160,160,125,165),IPTR 110 ISTAT = 0 CALL GRSTS(1,200B,ISTAT) IARRY(J) = ISTAT/200B NUM = 1 GO TO 500 C C UNITS MODE: 0=GDUS,1=UDUS,AND 3 = USER UNITS = GDUS C 120 CALL GRSTS(1,1 ,ISTAT) IARRY(J) = ISTAT NUM = 1 GO TO 500 C C PORG X,Y C 125 CALL GCBIM(17,1,IARRY(J),0,1) NUM = 4 GO TO 500 C C PEN POSITION (X,Y) C 130 CALL OUTPT(1,IPXY,1) CALL GCBIM(16,1,IBUFR,3,1) 135 X1= IB1 Y1= IB2 NUM = 4 GO TO 200 C C G1,G2 OR V1,V2 OR S1,S2 C 140 IPTR = IPTR + 4 CALL GCBIM(IPTR,1,VAR,0,1) NUM = 8 GO TO 200 C C CHARACTER SIZE C 150 CALL GCBIM(7,1,VAR,0,1) ICD = IADCD(D) CALL GCBIM(ICD,1,VAR1,0,1) X1 = X1/A Y1 = Y1/C NUM = 4 GO TO 300 C C A - D OR A' - D' C 160 IPTR = IPTR + 3 CALL GCBIM(IPTR,1,VAR,0,1) Y1 = Y1/X1 Y2 = Y2/X2 NUM = 8 GO TO 300 165 CALL GCBIM(31,1,IBUFR,0,1) D 2: 92840-18051 1819 S C0122 GPMM CMND              H0101 FTN,L C C C CC************************************************************ 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. * CC************************************************************ C C C C NAME: GPMM C SOURCE: 92840 - 18051 C RELOC: 92840 - 16001 C C C CC*********************************************************** C REAL FUNCTION XPMM(IN,IGCB,GMM), 92840-16001 REV.1819 780515 DIMENSION VAR(6),ICODE(2) EQUIVALENCE (VAR,XMU),(VAR(3),AP),(ICODE,MUMM) EQUIVALENCE (ICODE(2),IADP) DATA MUMM/6/ DATA IADP/11/ C C GPMM CONVERTS MILLIMETERS TO GDU'S. THE EQUATION C FOR DOING THE CONVERSION IN UNITS FORM IS AS FOLLOWS: C C GDU'S = (MM * MU'S/MM * GDU/MU) C CCCC C THIS CALL ESTABLISHES AN ADDRESS LINK BETWEEN THE GRAPGHICS C PACKAGE AND THE CURRENT GCB AND ALSO CHECKS FOR A SUSPENDED GCB. C ISUSP= 0 CALL GCBIM(99,1,IGCB,ISUSP) IF(ISUSP.NE.0)RETURN C START - RETRIEVE CONSTANTS FROM GCB C CALL GCBIM(ICODE,2,VAR,0,1) XPMM = (GMM *XMU)/AP RETURN END END$ = 39 92840-18052 1819 S C0122 FRAME CMND              H0101    4; 92840-18053 1819 S C0122 LABEL INTF MOD              H0101 %ASMB,R,L * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: LABEL,LABON,LABOF * SOURCE: 92840 - 18053 * RELOC: 92840 - 16001 * * * ************************************************************* * NAM LABEL,7 92840-16001 REV.1819 780515 ENT LABEL EXT .OPTN,XLABL,PLTER * * THIS IS THE INTERFACE MODULE FOR THE AGL COMMANDS * LABEL AND LORG. * LABEL NOP LDA LABEL JSB .OPTN DEF RTN1 PADR DEF PARM DEF M5 DEF .1 CODE DEF .1 REQUIRED PARAMETERS DEF .1 ONE DEFAULT DEF DZER0 DEFAULT VALUE DEF RETRN RTN1 JMP ERROR ENTRY JSB XLABL DEF RTNER PARM BSS 5 END JSB PLTER ERROR LDA PARM+1 STA IGCB JSB PLTER DEF RTNER DEF .66 IGCB NOP RTNER JMP RETRN,I * * * DZER0 DEF .0 RETRN NOP .0 OCT 0 .1 OCT 1 .2 OCT 2 M5 DEC -5 .66 DEC 66 END z{ 5; 92840-18054 1819 S C0122 LBL LBN LBF CMNS              H0101 uFTN,L C C C CC************************************************************ 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. * CC************************************************************ C C C C NAME: LABEL,LABON,LABOF C SOURCE: 92840 - 18054 C RELOC: 92840 - 16001 C C C CC*********************************************************** C SUBROUTINE XLABL(IND,IGCB,IP1), 92840-16001 REV.1819 780515 DATA LABL/23000B/ C C THIS IS THE FUNCTIONAL MODULE FOR THE AGL COMMAND LABEL(MODE), C THE PARAMETER IP1 = MODE. C C C LABEL C CCCC C THIS CALL ESTABLISHES AN ADDRESS LINK BETWEEN THE GRAPGHICS C PACKAGE AND THE CURRENT GCB AND ALSO CHECKS FOR A SUSPENDED GCB. C ISUSP= 0 CALL GCBIM(99,1,IGCB,ISUSP) IF(ISUSP.NE.0)RETURN C 10 IF(IP1.LT.0.OR.IP1.GT.2)GO TO 810 IP =IABS(IP1)+ 1 GO TO (300,100,200),IP 100 CALL LABON(IGCB) RETURN 200 CALL LABOF(IGCB) RETURN C C SHORT LABEL C 300 CALL OUTPT(1,LABL,2) C C SET BIT 4 TO INDICATE SHORT LABEL C CALL GRSTS(2, 77757B,20B) 800 RETURN 810 CALL PLTER(31,IGCB) GO TO 300 END SUBROUTINE LABON(IGCB), 92840-16001 REV.1819 780515 INTEGER STLAB C C THIS ROUTINE IS RESPONSIBLE FOR PROCESSING THE AGL COMMANDS C LABON (LABEL ON) AND LABOF(LABLE OFF). C DATA STLAB/23400B/ C CCCC C THIS CALL ESTABLISHES AN ADDRESS LINK BETWEEN THE GRAPGHICS C PACKAGE AND THE CURRENT GCB AND ALSO CHECKS FOR A SUSPENDED GCB. C ISUSP= 0 CALL GCBIM(99,1,IGCB,ISUSP) IF(ISUSP.NE.0)RETURN CALL OUTPT(1,STLAB,2) C C SET BIT INDICATING LABEL MODE C CALL GRSTS(2,77677B,100B) RETURN END    SUBROUTINE LABOF(IGCB), 92840-16001 REV.1819 780515 INTEGER STPLB DATA STPLB/24000B/ C CCCC C THIS CALL ESTABLISHES AN ADDRESS LINK BETWEEN THE GRAPGHICS C PACKAGE AND THE CURRENT GCB AND ALSO CHECKS FOR A SUSPENDED GCB. C ISUSP= 0 CALL GCBIM(99,1,IGCB,ISUSP) IF(ISUSP.NE.0)RETURN CALL GRSTS(2,77677B,0) CALL OUTPT(1,STPLB,2) RETURN END END$ M  6= 92840-18055 1819 S C0122 SETUU SETGU              H0101 Y 7= 92840-18056 1819 S C0122 INTAC INTF MOD              H0101 /   8? 92840-18057 1819 S C0122 INTAC CMNDS              H0101 '  OR - GET CURSOR POSITION WITHOUT WAIT C 20 CALL OUTPT(1,CURSR,1) 25 CALL GCBIM(16,1,IBUFR,3,1) X = IBUFR Y = IB2 IZCRD = IB3 GO TO 15 C C DIGITIZE C 30 CALL OUTPT(1,DIGTZ,1) GO TO 25 C C POINTER C 40 X = XCORD * A + B Y = YCORD * C + D C C GET HARD CLIP ENDPOINTS C IBUFR = POSCR IB2 = GRIFX(X) IB3 = GRIFX(Y) CALL OUTPT(1,IBUFR,2) RETURN END END$   9@ 92840-18058 1819 S C0122 HRD ERR INTF MOD              H0101 TASMB,R,L * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: HARD ERROR * SOURCE: 92840 - 18058 * RELOC: 92840 - 16001 * * * ************************************************************* * NAM HDERR,7 92840-16001 REV.1819 780515 ENT HDERR EXT .OPTN,HERR EXT PLTER * * THIS IS THE INTERFACE MODULE FOR SETTING * HARD OR FIRM ERRORS * HDERR NOP LDA HDERR JSB .OPTN GO RETRIEVE PARAMETERS DEF RTN DEF PARM DEF M4 DEF .1 CODE DEF .2 REQUIRED PARAMETERS DEF .1 ONE OPTIONAL PARAMETER DEF DZERO DEF RETRN RTN JMP ERROR JSB HERR DEF END PARM BSS 4 END JMP RETRN,I * *PARAMETER ERROR * ERROR LDA PARM+1 STA IGCB JSB PLTER DEF ERTN DEF .57 IGCB NOP ERTN JMP RETRN,I .57 DEC 57 .2 OCT 2 * M4 DEC -4 RETRN NOP .1 OCT 1 DZERO DEF .0 .0 OCT 0 * END oo :@ FTN,L C C C CC************************************************************ 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. * CC************************************************************ C C C C NAME: HARD ERROR C SOURCE: 92840 - 18059 C RELOC: 92840 - 16001 C C C CC*********************************************************** C SUBROUTINE HERR(IND,IGCB,ICODE, 1IRANK), 92840-16001 REV.1819 780515 DIMENSION IEBUF(4) C C THIS PROCEDURE TAKES THE INTEGER VALUE IN ICODE AND INDEXES C INTO THE ERROR MASK BUFFER TO GET THE MASK WORD AND BIT OF C INTEREST. DEPENDING ON IRANK THE ERROR IS UPDATED TO EITHER C A HARD OR FIRM ERROR. C DATA MAXER/36/ DATA IERR/27/ C RETRIEVE ERROR MASK BUFFER AND CHECK FOR ERROR. C CCCC C THIS CALL ESTABLISHES AN ADDRESS LINK BETWEEN THE GRAPGHICS C PACKAGE AND THE CURRENT GCB AND ALSO CHECKS FOR A SUSPENDED GCB. C ISUSP= 0 CALL GCBIM(99,1,IGCB,ISUSP) IF(ISUSP.NE.0)RETURN CALL GCBIM(IERR,1,IEBUF,0,1) IF(ICODE.LE.0.OR.ICODE.GT.MAXER)GO TO 800 C C COMPUTE MASK BIT C IMPY = MOD(ICODE,16) INDX = ICODE/16 + 1 IF(IMPY)60,50,60 50 INDX = INDX -1 IMSK = 100000B GO TO 65 60 IMSK = 2**(IMPY -1) 65 IFIRM = INDX C C SEE IF THIS IS AN ELEVATION OR SET HARD ERROR C IF(IRANK.EQ.1)GO TO 100 ITST = IAND(IEBUF(IFIRM),IMSK) IF(ITST.NE.0)GO TO 100 C C MAKE FIRM C IEBUF(IFIRM) = IOR(IEBUF(IFIRM),IMSK) GO TO 200 100 IEBUF(INDX) = IOR(IEBUF(INDX),IMSK) 200 CALL GCBIM(IERR,1,IEBUF,0,2) RETURN 800 CALL PLTER(32) RETURN END END$ C D   ;B 92840-18060 1819 S C0122 LGERR INTF MOD              H0101 ,ASMB,R,L * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: LGERR INTFC MOD * SOURCE: 92840 - 18060 * RELOC: 92840 - 16001 * * * ************************************************************* * NAM LGERR,7 92840-16001 REV.1819 780515 ENT LGERR EXT .OPTN,XGERR,PLTER EXT PLTER * * THIS IS THE INTERFACE MODULE FOR THE ERROR HANDLING COMMAND * LGERR(LU). * LGERR NOP LDA LGERR LG1 JSB .OPTN DEF RTN DEF PARM DEF M3 DEF .1 DEF .1 IGCB REQUIRED PARAMETER DEF .1 DEF DF0 DEFAULT LU = 1 DEF RETRN RTN JMP ERROR JSB XGERR DEF END PARM BSS 3 END JMP RETRN,I * RETRN NOP M3 DEC -3 .1 DEC 1 .0 OCT 0 DF0 DEF .0 ERROR LDA PARM+1 STA IGCB JSB PLTER DEF RTNER DEF .61 IGCB NOP RTNER JMP RETRN,I .61 DEC 61 END  <B 92840-18061 1819 S C0122 IGERR CMND              H0101 FTN,L C C C CC************************************************************ 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. * CC************************************************************ C C C C NAME: IGERR C SOURCE: 92840 - 18061 C RELOC: 92840 - 16001 C C C CC*********************************************************** C INTEGER FUNCTION XIGER(IN,IGCB), 92840-16001 REV.1819 780515 DATA IERR/30/ C C REPORT THE MOST RECENT ERROR C CCCC C THIS CALL ESTABLISHES AN ADDRESS LINK BETWEEN THE GRAPGHICS C PACKAGE AND THE CURRENT GCB AND ALSO CHECKS FOR A SUSPENDED GCB. C ISUSP= 0 CALL GCBIM(99,1,IGCB,ISUSP) CALL PLTER(-98,ISUSP) IF(ISUSP.NE.0)GO TO 10 CALL GCBIM(IERR,1,XIGER,0,1) CALL GCBIM(IERR,1,0,1,2) RETURN 10 XIGER = ISUSP RETURN END END$ ` =C 92840-18062 1819 S C0122 LGERR COMMAND              H0101 6 >D 92840-18063 1819 S C0122 CHAR PLOT INTFC              H0101 D!ASMB,R,L * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: PLOT * SOURCE: 92840 - 18063 * RELOC: 92840 - 16001 * * * ************************************************************* * NAM CPLOT,7 92840-16001 REV.1819 780515 * * THIS MODULE IS THE INTERFACE FOR AGL COMMANDS * CPLOT. * EXT CHPLT,.OPTN,PLTER ENT CPLOT * * CPLOT NOP LDA .1 PLT STA CODE LDA CPLOT JSB .OPTN OPTIONAL PARAMETER PROCESSING SUBROUTINE DEF RTN PADR DEF PARM DEF M5 NUMBER OF ENTRIES TO CLEAR DEF CODE DEF .3 NUMBER OF PARAMETERS - # OF DEFAULTS DEF .1 NUMBER OF DEFAULTS DEF DF1 TOP OF LIST FOR DEFAULT VALUES DEF RETRN RTN JMP MESUP ERROR RETURN JSB CHPLT DEF END PARM BSS 5 END JMP RETRN,I MESUP LDA PARM+1 STA IGCB JSB PLTER DEF RTNER DEF .47 IGCB NOP RTNER JMP RETRN,I * * * * SPC 3 B EQU 1 .4 OCT 4 M5 DEC -5 .0 OCT 0 .1 OCT 1 .2 OCT 2 .3 OCT 3 .5 OCT 5 DF1 DEF .1 RETRN NOP A EQU 0 .47 DEC 51 CODE NOP * END Z ?E 92840-18064 1819 S C0122 CHAR PLOT CMND              H0101 FTN,L C C C CC************************************************************ 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. * CC************************************************************ C C C C NAME: CPLOT COMMAND C SOURCE: 92840 - 18064 C RELOC: 92840 - 16001 C C C CC*********************************************************** C SUBROUTINE CHPLT(IND,IGCB,XI,YI, 1IPCTL), 92840-16001 REV.1819 780515 DIMENSION VAR(7),ICODE(3),IBUFR(3) EQUIVALENCE (VAR,CHRW),(VAR(2),CHRH),(VAR(3),THETA) EQUIVALENCE(VAR(4),A),(VAR(6),C) EQUIVALENCE(ICODE,ICHR),(ICODE(2),LDIR),(ICODE(3),ICD3) EQUIVALENCE (IBUFR,IB1),(IBUFR(2),IB2),(VAR(5),B) EQUIVALENCE (VAR(7),D) C C THIS IS THE AGL MODULE FOR PROCESSING THE CHARACTER C PLOT COMMAND. IX = # CHARACTERS IN X DIRECTIONS C IY = # " " Y DIRECTION C DATA ICHR/7/ DATA IPXY/5003B/ DATA LDIR/22/ C CCCC C THIS CALL ESTABLISHES AN ADDRESS LINK BETWEEN THE GRAPGHICS C PACKAGE AND THE CURRENT GCB AND ALSO CHECKS FOR A SUSPENDED GCB. C ISUSP= 0 CALL GCBIM(99,1,IGCB,ISUSP) IF(ISUSP.NE.0)RETURN ICD3 = IADCD(D) CALL GCBIM(ICODE,3,VAR,0,1) C C C COMPUTE VALUES FOR X AND Y IN CURRENT UNIT MODE C XN = (XI * CHRW)/A YN = (YI * CHRH)/C C C TAKE INTO CONSIDERATION CURRENT LABEL DIRECTION C THETX = COS(THETA) THETY = SIN(THETA) X = XN * THETX - YN * THETY Y = XN * THETY + YN * THETX C C SET PDIR TO 0 AND SAVE CURRENT PDIR(THETA) C CALL GCBIM(19,1,VAR,0,1) CALL PDIR(IGCB,0.) C C CALL IPLOT TO DO THE PLOTTING C CALL IPLOT(IGCB,X,Y,IPCTL) CALL GCBIM(19,1,VAR,0,2) RETURN 7   END ׾  @G 92840-18065 1819 S C0122 MSCAL INTFC MOD              H0101 nASMB,R,L * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: MSCAL INTFC MOD * SOURCE: 92840 - 18065 * RELOC: 92840 - 16001 * * * ************************************************************* * NAM MSCAL,7 92840-16001 REV.1819 780515 * * THIS MODULE IS THE INTERFACE FOR AGL COMMANDS * MSCAL. * EXT XSCAL,.OPTN,PLTER ENT MSCAL * * MSCAL NOP LDA MSCAL JSB .OPTN OPTIONAL PARAMETER PROCESSING SUBROUTINE DEF RTN PADR DEF PARM DEF M4 NUMBER OF ENTRIES TO CLEAR DEF .1 DEF .3 NUMBER OF PARAMETERS - # OF DEFAULTS DEF .0 NUMBER OF DEFAULTS DEF DF1 TOP OF LIST FOR DEFAULT VALUES DEF RETRN RTN JMP MESUP ERROR RETURN JSB XSCAL DEF END PARM BSS 4 END JMP RETRN,I MESUP LDA PARM+1 STA IGCB JSB PLTER DEF RTNER DEF ERCOD IGCB NOP RTNER JMP RETRN,I * * * * SPC 3 B EQU 1 .4 OCT 4 M4 DEC -4 .0 OCT 0 .1 OCT 1 .2 OCT 2 .3 OCT 3 .5 OCT 5 DF1 DEF .1 RETRN NOP A EQU 0 ERCOD DEC 75 CODE NOP * END  AG 92840-18066 1819 S C0122 CLP ON OF INT MOD              H0101 xASMB,R,L * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: CLPON\CLPOF INTFC MOD * SOURCE: 92840 - 18066 * RELOC: 92840 - 16001 * * * ************************************************************* * NAM CLPON,7 92840-16001 REV 1819 780515 EXT .OPTN,PLTER,XCLPN ENT CLPON,CLPOF * * THIS IS THE INTERFACE MODULE FOR THE AGL COMMAND CLPON * * CLPON NOP LDA .1 STA CODE LDA .76 STA ERCOD LDA CLPON CLP JSB .OPTN DEF RTN DEF PARM DEF M2 DEF CODE DEF .1 ONE REQUIRED PARAMETER GCB DEF .0 NO OPTIONALS DEF RETRN RTN JMP ERROR JSB XCLPN DEF END PARM BSS 2 END JMP RETRN,I * CLPOF NOP LDA .2 STA CODE LDA .77 STA ERCOD LDA CLPOF JMP CLP * ERROR JSB PLTER DEF RTNER DEF ERCOD RTNER JMP RETRN,I * M2 OCT -2 RETRN NOP .77 DEC 77 .76 DEC 76 .2 OCT 2 ERCOD NOP CODE NOP .1 OCT 1 .0 OCT 0 END k BH 92840-18067 1819 S C0122 SHOW INTF MOD              H0101 *ASMB,R,L * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: SHOW * SOURCE: 92840 - 18067 * RELOC: 92840 - 16001 * * * ************************************************************* * NAM SHOW,7 92840-16001 REV.1819 780515 * * THIS MODULE IS THE INTERFACE FOR AGL COMMANDS * SHOW. * EXT XSHOW,.OPTN,PLTER ENT SHOW * * SHOW NOP LDA SHOW JSB .OPTN OPTIONAL PARAMETER PROCESSING SUBROUTINE DEF RTN PADR DEF PARM DEF M6 NUMBER OF ENTRIES TO CLEAR DEF .1 DEF .5 NUMBER OF PARAMETERS - # OF DEFAULTS DEF .0 NUMBER OF DEFAULTS DEF DF1 TOP OF LIST FOR DEFAULT VALUES DEF RETRN RTN JMP MESUP ERROR RETURN JSB XSHOW DEF END PARM BSS 6 END JMP RETRN,I MESUP LDA PARM+1 STA IGCB JSB PLTER DEF RTNER DEF ERCOD IGCB NOP RTNER JMP RETRN,I * * * * SPC 3 B EQU 1 .4 OCT 4 M6 DEC -6 .0 OCT 0 .1 OCT 1 .2 OCT 2 .3 OCT 3 .5 OCT 5 DF1 DEF .1 RETRN NOP A EQU 0 ERCOD DEC 78 CODE NOP * END / CI 92840-18068 1819 S C0122 DRAW INTFC MOD              H0101 NASMB,R,L * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: DRAW * SOURCE: 92840 - 18068 * RELOC: 92840 - 16001 * * * ************************************************************* * NAM DRAW,7 92840-16001 REV.1819 780515 * * THIS MODULE IS THE INTERFACE FOR AGL COMMANDS * DRAW. * EXT XDRAW,.OPTN,PLTER ENT DRAW * * DRAW NOP LDA DRAW JSB .OPTN OPTIONAL PARAMETER PROCESSING SUBROUTINE DEF RTN PADR DEF PARM DEF M4 NUMBER OF ENTRIES TO CLEAR DEF .1 DEF .3 NUMBER OF PARAMETERS - # OF DEFAULTS DEF .0 NUMBER OF DEFAULTS DEF DF1 TOP OF LIST FOR DEFAULT VALUES DEF RETRN RTN JMP MESUP ERROR RETURN JSB XDRAW DEF END PARM BSS 4 END JMP RETRN,I MESUP LDA PARM+1 STA IGCB JSB PLTER DEF RTNER DEF ERCOD IGCB NOP RTNER JMP RETRN,I * * * * SPC 3 B EQU 1 .4 OCT 4 M4 DEC -4 .0 OCT 0 .1 OCT 1 .2 OCT 2 .3 OCT 3 .5 OCT 5 DF1 DEF .1 RETRN NOP A EQU 0 ERCOD DEC 69 CODE NOP * END #92840-18069 1819 S C0122 MOVE INTFC MOD              H0101 9ASMB,R,L * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: MOVE * SOURCE: 92840 - 18069 * RELOC: 92840 - 16001 * * * ************************************************************* * NAM MOVE,7 92840-16001 REV.1819 780515 * * THIS MODULE IS THE INTERFACE FOR AGL COMMANDS * MOVE. * EXT XMOVE,.OPTN,PLTER ENT MOVE * * MOVE NOP LDA MOVE JSB .OPTN OPTIONAL PARAMETER PROCESSING SUBROUTINE DEF RTN PADR DEF PARM DEF M4 NUMBER OF ENTRIES TO CLEAR DEF .1 DEF .3 NUMBER OF PARAMETERS - # OF DEFAULTS DEF .0 NUMBER OF DEFAULTS DEF DF1 TOP OF LIST FOR DEFAULT VALUES DEF RETRN RTN JMP MESUP ERROR RETURN JSB XMOVE DEF END PARM BSS 4 END JMP RETRN,I MESUP LDA PARM+1 STA IGCB JSB PLTER DEF RTNER DEF ERCOD IGCB NOP RTNER JMP RETRN,I * * * * SPC 3 B EQU 1 .4 OCT 4 M4 DEC -4 .0 OCT 0 .1 OCT 1 .2 OCT 2 .3 OCT 3 .5 OCT 5 DF1 DEF .1 RETRN NOP A EQU 0 ERCOD DEC 70 CODE NOP * END  EK 92840-18070 1819 S C0122 DRAWI INTFC MOD              H0101 \ASMB,R,L * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: DRAWI * SOURCE: 92840 - 18070 * RELOC: 92840 - 16001 * * * ************************************************************* * NAM DRAWI,7 92840-16001 REV.1819 780515 * * THIS MODULE IS THE INTERFACE FOR AGL COMMANDS * DRAWI. * EXT XDRWI,.OPTN,PLTER ENT DRAWI * * DRAWI NOP LDA DRAWI JSB .OPTN OPTIONAL PARAMETER PROCESSING SUBROUTINE DEF RTN PADR DEF PARM DEF M4 NUMBER OF ENTRIES TO CLEAR DEF .1 DEF .3 NUMBER OF PARAMETERS - # OF DEFAULTS DEF .0 NUMBER OF DEFAULTS DEF DF1 TOP OF LIST FOR DEFAULT VALUES DEF RETRN RTN JMP MESUP ERROR RETURN JSB XDRWI DEF END PARM BSS 4 END JMP RETRN,I MESUP LDA PARM+1 STA IGCB JSB PLTER DEF RTNER DEF ERCOD IGCB NOP RTNER JMP RETRN,I * * * * SPC 3 B EQU 1 .4 OCT 4 M4 DEC -4 .0 OCT 0 .1 OCT 1 .2 OCT 2 .3 OCT 3 .5 OCT 5 DF1 DEF .1 RETRN NOP A EQU 0 ERCOD DEC 71 CODE NOP * END "} FL 92840-18071 1819 S C0122 MOVEI INTFC MOD              H0101 zASMB,R,L * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: MOVEI * SOURCE: 92840 - 18071 * RELOC: 92840 - 16001 * * * ************************************************************* * NAM MOVEI,7 92840-16001 REV.1819 780515 * * THIS MODULE IS THE INTERFACE FOR AGL COMMANDS * MOVEI. * EXT XMOVI,.OPTN,PLTER ENT MOVEI * * MOVEI NOP LDA MOVEI JSB .OPTN OPTIONAL PARAMETER PROCESSING SUBROUTINE DEF RTN PADR DEF PARM DEF M4 NUMBER OF ENTRIES TO CLEAR DEF .1 DEF .3 NUMBER OF PARAMETERS - # OF DEFAULTS DEF .0 NUMBER OF DEFAULTS DEF DF1 TOP OF LIST FOR DEFAULT VALUES DEF RETRN RTN JMP MESUP ERROR RETURN JSB XMOVI DEF END PARM BSS 4 END JMP RETRN,I MESUP LDA PARM+1 STA IGCB JSB PLTER DEF RTNER DEF ERCOD IGCB NOP RTNER JMP RETRN,I * * * * SPC 3 B EQU 1 .4 OCT 4 M4 DEC -4 .0 OCT 0 .1 OCT 1 .2 OCT 2 .3 OCT 3 .5 OCT 5 DF1 DEF .1 RETRN NOP A EQU 0 ERCOD DEC 72 CODE NOP * END  GM 92840-18072 1819 S C0122 DRAWR INTFC MOD              H0101 g HN 92840-18073 1819 S C0122 MOVER INTFC MOD.              H0101 ASMB,R,L * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: MOVER * SOURCE: 92840 - 18073 * RELOC: 92840 - 16001 * * * ************************************************************* * NAM MOVER,7 92840-16001 REV.1819 780515 * * THIS MODULE IS THE INTERFACE FOR AGL COMMANDS * MOVER. * EXT XMOVR,.OPTN,PLTER ENT MOVER * * MOVER NOP LDA MOVER JSB .OPTN OPTIONAL PARAMETER PROCESSING SUBROUTINE DEF RTN PADR DEF PARM DEF M4 NUMBER OF ENTRIES TO CLEAR DEF .1 DEF .3 NUMBER OF PARAMETERS - # OF DEFAULTS DEF .0 NUMBER OF DEFAULTS DEF DF1 TOP OF LIST FOR DEFAULT VALUES DEF RETRN RTN JMP MESUP ERROR RETURN JSB XMOVR DEF END PARM BSS 4 END JMP RETRN,I MESUP LDA PARM+1 STA IGCB JSB PLTER DEF RTNER DEF ERCOD IGCB NOP RTNER JMP RETRN,I * * * * SPC 3 B EQU 1 .4 OCT 4 M4 DEC -4 .0 OCT 0 .1 OCT 1 .2 OCT 2 .3 OCT 3 .5 OCT 5 DF1 DEF .1 RETRN NOP A EQU 0 ERCOD DEC 74 CODE NOP * END L IO 92840-18074 1819 S C0122 LORG INTFC MOD              H0101 < JP 92840-18075 1819 S C0122 FXD INTFC MOD              H0101 <ASMB,R,L * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: FXD INTFC MOD * SOURCE: 92840 - 18075 * RELOC: 92840 - 16001 * * * ************************************************************* * NAM FXD,7 92840-16001 REV.1819 780515 EXT .OPTN,PLTER,XFXD ENT FXD * * THIS IS THE INTERFACE MODULE FOR THE AGL COMMAND FXD * * FXD NOP LDA FXD JSB .OPTN DEF RTN DEF PARM DEF M3 DEF .1 DEF .2 TWO REQUIRED PARAMETERS DEF .0 NO OPTIONALS DEF RETRN RTN JMP ERROR JSB XFXD DEF END PARM BSS 3 END JMP RETRN,I * * ERROR JSB PLTER DEF RTNER DEF .80 RTNER JMP RETRN,I * M3 OCT -3 RETRN NOP .80 DEC 80 .2 OCT 2 .1 OCT 1 .0 OCT 0 END 8 KQ 92840-18076 1819 S C0122 PENUP INTFC MOD              H0101  LR 92840-18077 1819 S C0122 PENDN INTFC MOD              H0101 ASMB,R,L * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: * SOURCE: 92840 - 18077 * RELOC: 92840 - 16001 * * * ************************************************************* * NAM PENDN,7 92840-16001 REV 1819 780515 EXT .OPTN,PLTER,XPNDN ENT PENDN * * THIS IS THE INTERFACE MODULE FOR THE AGL COMMAND PENDN * * PENDN NOP LDA PENDN JSB .OPTN DEF RTN DEF PARM DEF M2 DEF .1 DEF .1 ONE REQUIRED PARAMETER GCB DEF .0 NO OPTIONALS DEF RETRN RTN JMP ERROR JSB XPNDN DEF END PARM BSS 2 END JMP RETRN,I * * ERROR JSB PLTER DEF RTNER DEF ERCOD RTNER JMP RETRN,I * M2 OCT -2 RETRN NOP ERCOD DEC 82 .1 OCT 1 .0 OCT 0 END  MS 92840-18078 1819 S C0122 PORG INTFC MOD              H0101 <ASMB,R,L * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: PORG * SOURCE: 92840 - 18078 * RELOC: 92840 - 16001 * * * ************************************************************* * NAM PORG,7 92840-16001 REV.1819 780515 * * THIS MODULE IS THE INTERFACE FOR AGL COMMANDS * PORG. * EXT XPORG,.OPTN,PLTER ENT PORG * * PORG NOP LDA PORG JSB .OPTN OPTIONAL PARAMETER PROCESSING SUBROUTINE DEF RTN PADR DEF PARM DEF M4 NUMBER OF ENTRIES TO CLEAR DEF .1 DEF .3 NUMBER OF PARAMETERS - # OF DEFAULTS DEF .0 NUMBER OF DEFAULTS DEF DF1 TOP OF LIST FOR DEFAULT VALUES DEF RETRN RTN JMP MESUP ERROR RETURN JSB XPORG DEF END PARM BSS 4 END JMP RETRN,I MESUP LDA PARM+1 STA IGCB JSB PLTER DEF RTNER DEF ERCOD IGCB NOP RTNER JMP RETRN,I * * * * SPC 3 B EQU 1 .4 OCT 4 M4 DEC -4 .0 OCT 0 .1 OCT 1 .2 OCT 2 .3 OCT 3 .5 OCT 5 DF1 DEF .1 RETRN NOP A EQU 0 ERCOD DEC 83 CODE NOP * END  NT 92840-18079 1819 S C0122 AGL NAM RCD              H0101 #ASMB,R,L NAM GPS78,7 92840-16001 REV.1819 780515 * * * SOURCE : 92840-18079 * END  OU 92840-18080 1840 S C0122 &GCBIM GRAPHICS CNTL BLK INTERFACE MOD SOURCE             H0101 fFTN,L C C C CC************************************************************ 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. * CC************************************************************ C C C C NAME: GCBIM (PART 2 GRAPHICS LINKAGE MODULE) C SOURCE: 92840 - 18080 C RELOC: 92840 - 16002 C C C CC*********************************************************** C SUBROUTINE GCBIM(ICODE,ICDL,IBUFR,IBUFL, 1IRW), 92840-16002 REV. 1819 780515 DIMENSION IBUFR(2),IBUFL(2),IGCBF(12) DIMENSION ICODE(2),IGTBL(32) INTEGER PNPOS,ERMSK,ERRLU,ERRCD C C MNEMONIC EQUIVALENCES BETWEEN VALUES IN THE IGTBL AND WHAT C THESE VALUES ARE SUPPOSED TO REPRESENT (E.G. VALUES V1 AND V2 C MNEMONIC EQUIVALENCE IV12). C C THE VALUES IN THE IGTBL CONTAIN THE GCB POINTER IN BITS 0-7 C AND THE LENGTH OF THE DATUM IN BITS 8-15. C C EQUIVALENCE (IGTBL,IGCBL),(IGTBL(2),LUN),(IGTBL(3),ID) EQUIVALENCE (IGTBL(4),IOBUF),(IGTBL(5),ISTAT),(IGTBL(6),MUMM) EQUIVALENCE (IGTBL(7),ICSZE),(IGTBL(8),IG12) EQUIVALENCE (IGTBL(9),IV12),(IGTBL(10),IS12),(IGTBL(11),IADP) EQUIVALENCE (IGTBL(12),IAD),(IGTBL(13),IGDU),(IGTBL(14),IPORG) EQUIVALENCE (IGTBL(15), LORG),(IGTBL(16),IGICB) EQUIVALENCE (IGTBL(17),IPRG), (IGTBL(18),ICLIP) EQUIVALENCE (IGTBL(19), IPDIR),(IGTBL(20),IPSCL) EQUIVALENCE (IGTBL(21),LRG),(IGTBL(22),LDIR) EQUIVALENCE(IGTBL(23),LINE) ,(IGTBL(24),PNPOS) EQUIVALENCE (IGTBL(25),LNTH),(IGTBL(26),N),(IGTBL(27),IUXY) EQUIVALENCE (IGTBL(28),ERRLU),(IGTBL(29),ERMSK),(IGTBL(30),ERRCD) EQUIVALENCE (IGTBL(31),LNTYP),(IGTBL(32),IOSAV) C C THIS IS THE GRAPHICS CONTROL BLOCK INTERFACE MODULE C THAT IS RESPONSIBLE FOR INTERFACING BETWEEN THE GCB C AND OTHE_R MODULES ON THE GRAPHICS PACKAGE. C C CALLING SEQUENCE: CALL GCBIM(ICODE,ICDL,IRW,IBUFR) C WHERE : ICODE = ARRAY OF CODES WHICH CORRESPOND TO C TO THE VARIABLE(S) OF INTEREST IN THE GCB. C ICODE >0 BUT NOT 99 -RETRIEVE OR STORE DATA INTO GCB. C ICODE = 0 - SAVE GCB ADDRESS AND SET 99 INTO FW OF GCB. C ICODE = -99 - CLEAR FIRST WORD OF GCB (PLOTR(0)) C ICODE = 99 - AGL COMMAND OTHER THAN PLOTR(1 OR 4). C CHECK FOR EXISTENCE OF 99 IN FIRST WORD AND C SAVE ADDRESS LOCALLY. ERROR IF 99 NOT IF FIRST C WORD. C C ICDL = LENGTH OF ICODE C IRW = 1(READ),2(WRITE),3(TRANSFER) C IBUFR= BUFFER TO BE FILLED OR EMPTIED C IBUFL= 0 IF LENGTH ASSOCIATED WITH GCB POINTER IS C TO BE USED. C NE.0 - IF LENGTH IN IBUFL IS TO BE USED. C NONZERO IBUFL IS USED FOR SUCH THINGS AS C IOBUF, GICB AND DEVICE SUBROUTINE SCRATCH AREA. C C C DATA LNTH /2001B/ DATA N/517B/ DATA IUXY/2120B/ DATA IGCBL/ 401B/ DATA LUN/ 403B/ DATA ID/ 404B/ DATA IOBUF/1006B/ DATA IOSAV/544B/ DATA ISTAT/ 410B/ DATA LNTYP/1511B/ DATA MUMM/ 2011B/ DATA ERRLU/405B/ DATA ERMSK/534B/ DATA ERRCD/402B/ DATA ICSZE/2015B/ DATA IG12/4021B/ DATA IV12/4031B/ DATA IS12/4041B/ DATA IADP/4051B/ DATA PNPOS/2117B/ DATA IAD/ 4061B/ DATA LINE/3111B/ DATA IGDU/2071B/ DATA IPORG/4101B/ DATA LORG/1514B/ DATA IGICB/ 530B/ DATA ICLIP/ 2075B/ DATA IPRG/2101B/ DATA IPDIR/2105B/ DATA IPSCL/1103B/ DATA LRG/514B/ DATA LDIR/1115B/ IND = 0 C C C IF(ICODE.EQ.0)GO TO 5 IF(ICODE.EQ.99)CALL ABSAD(ICODE,0,IBUFR) ISTS = 0 CALL PLTERs (-98,ISTS) IF(ISTS.EQ.0)GO TO 5 C C CALL ABSAD(8,1,ISTS ,1,IND) C IF(IND.LT.0)GO TO 4 C IND = IAND(ISTS , 40000B) C IF(IND.EQ.0)GO TO 5 C IF(IND.EQ.40000B)CALL PLTER(13) C IBUFL = 1 C RETURN C SEE IF A PLOTR(0) CALL OR PLOTR(1) C IF(ICODE.EQ.99)IBUFL = 1 RETURN C C 5 IF(ICODE.EQ.99)RETURN IF(ICODE)100,150,50 C C TRANSMIT DATA TO/FROM GCB C 50 J = 1 IF(IRW.EQ.3)GO TO 210 DO 200 I=1,ICDL ICD = ICODE(I) IPTR = IAND(IGTBL( ICD),377B) LNGTH = IBUFL IF(IBUFL)52,52,55 52 LNGTH = (IAND(IGTBL(ICD),177400B))/400B 55 CALL ABSAD(IPTR,IRW,IBUFR(J),LNGTH,IND) IF(IND)800,60,800 60 J = J + LNGTH 200 CONTINUE RETURN C C THIS PORTION OF CODE IS RESPONSIBLE FOR TRANSFERRING DATA C FROM ONE SECTION OF THE GCB TO ANOTHER. C 210 IPTR = IAND(IGTBL(ICODE),377B) CALL ABSAD(IPTR,1,IGCBF,10,IND) DO 220 I = 1,IBUFL ICD = IBUFR(I) IPTR = IAND(IGTBL(ICD),377B) LNGTH = (IAND(IGTBL(ICD),177400B))/400B CALL ABSAD(IPTR,2,IGCBF(J),LNGTH,IND) J= J +LNGTH 220 CONTINUE RETURN C C SAVE GCB ADDRESS C 150 CALL ABSAD(ICODE,IRW,IBUFR,LNGTH,IND) RETURN C C RE-INIT GCB C 100 CALL ABSAD(ICODE,0,IBUFR) RETURN C C ERROR GCB DOES NOT EXIST- C 800 RETURN END C C CC*********************************************************** C SUBROUTINE PLTER(IERCD,IRTN), 92840-16002 REV. 1840 780811 INTEGER PRMER(4),PRM1,PRM2,PRM3,PRM4,HDERR(7) INTEGER HDMSK(7) DIMENSION IBUFR(5),ICODE(2),MSG(14) DIMENSION MEQT(4) DIMENSION IERR(7) EQUIVALENCE (IBUFR,LUER),(MSG(4),MSG4),(MSG(5),MSG5) EQUIVALENCE (IBUFR(2),IB2) EQUIVALENCE (MSG(6),MSG6),(PRMER,PRM1),(PRMER(2),PRM2) EQUIVALENCE (PRMER(3),PRM3),(PRMER(4),PRM4) C C THIS ROUTINE IS RESPONSIBLE FOR LETTING THE USER KNOW :lC WHEN THERES BEEN A MESS UP. C DATA MSG/2H ,2HGP,2HS / DATA MEQT/2400B,3400B,17400B,5000B/ DATA PRMER/2H99,2H ,2H6 ,2H / DATA ICODE/28,27/ DATA HDERR/1,2,5,3/ DATA HDMSK/0,0,0,0,0,0,0/ DATA IERR/-99,-98 ,6,40,199,4/ C C REFRESH MESSAGE BUFFER C DO 5 K=4,12 MSG(K) = 20040B 5 CONTINUE C C SET THE DEFAULT UNIT FOR LOGGING HARD ERRORS TO THE CURRENT EM1840 C CONSOLE, THE VALUE RETURNED BY SYSTEM FUNCTION LOGLU EM1840 LUER = LOGLU(DUMMY) EM1840 C IENAM = IERCD IF(IERCD.NE.-97)GO TO 2 IF(IRTN.GT.63.OR.IRTN.LT.0)GO TO 10010 CALL EXEC(100015B,IRTN,IEQ5,IEQ4) GO TO 10010 C C MASK OUT DRIVER ID C 625 IEQ5 = IAND(IEQ5,37400B) DO 600 L=1,4 IF(IEQ5.EQ.MEQT(L))RETURN 600 CONTINUE GO TO 10010 C C C C CHECK ON HARD ERROR MODE C 2 DO 7 K =1,6 IF(IERCD.EQ.IERR(K))GO TO (900,900,820,800,840,99),K 7 CONTINUE C C MORE CHECKS C C C C GET LU# AND ERROR MASKS C IF(MSFLG.EQ.1.AND.IERCD.GT.39)GO TO 800 15 CALL ABSAD( 5,1,IBUFR,1,ICHR) C C IF LU FOR ERROR LOGGING STILL INITIALIZED AT -1, SET DEFAULT EM1840 C TO CURRENT CONSOLE BY CALLING SYSTEM FUNCTION LOGLU. EM1840 IF(LUER.EQ.-1)LUER = LOGLU(DUMMY) EM1840 C CALL ABSAD(80,1,IB2,4,ICHR) MSFLG = 0 IF(IERCD.GT.39)GO TO 800 IMPY = MOD(IERCD,16) INDX = IERCD/16 + 2 IF(IMPY)60,50,60 50 INDX = INDX - 1 IMSK = 100000B GO TO 65 60 IMSK = 2 **(IMPY -1) C C SEE WHAT TYPE OF ERROR HARD,SOFT OR FIRM C C FIRM?? C 65 ITST = IAND(IBUFR(INDX) ,IMSK) IF(ITST.EQ.0)GO TO 300 C C FIRM OR HARD ERROR THAT MUST BE REPORTED. C FIRST CONVERT ERROR CODE TO ASCII THEN OUTPUT TO ERROR C LOGGING DEVICE. C C N99 ICHR = 0 CALL CONVT(IENAM,MSG4,ICHR,1) ICHR = ICHR + 6 J = ICHR/2 + 1 C C C 160 CALL EXEC(2,LUER,MSG,J) C C FIRM ERROR OR SOFT UPDATE ERROR WORD IN GCB C IF MSGFLG = 1 OR IERCD = 40 DO NOT UPDATE GCB SINCE WE DON'T C HAVE ONE YET. IERCD = 40 IS FROM PLOTR PARAMETER ERROR C AND MSGFLG = 1 INDICATES A MISSING GCB FROM ONE OF THE C OTHER AGL COMMANDS. C 300 IF(MSFLG.EQ.1.OR.IENAM.EQ.40.OR.IENAM.EQ.4)GO TO 305 CALL ABSAD(2 ,2,IENAM,1,ICHR) 305 MSFLG = 0 RETURN C C PLOTR PARAMETER ERROR C 800 MSG4 = PRM1 MSG5 = PRM2 IF(MSFLG.EQ.0)GO TO 805 C C SET ERROR MESSAGE = GPS 99 C 802 MSG4 = PRM3 MSG5 = PRM4 805 J = 6 CALL GTNAM(IENAM,MSG6,J) GO TO 160 C C MISSING GCB C C C ERROR 6 C 820 MSFLG = 1 RETURN C C ERROR 199 FROM ABSAD PLOTR 0,2,3 MISSING GCB C 840 IENAM = 40 GO TO 802 C C IERCD = -98 OR -99. -98 INDICATES TO RETRIEVE RECENT ERROR C CODE AND REPORT A HARD ERROR. A -99 INDICATES TO REPORT C A HARD ERROR AND CLEAR ERROR CODE. C 900 CALL ABSAD(2,1,IRTN,1,ICHR) DO 950 I=1,4 IF(IRTN.EQ.HDERR(I))RETURN 950 CONTINUE MSFLG = 0 IRTN = 0 IF(IERCD.EQ.-98)RETURN C C CLEAR ERROR WORD IN GCB C CALL ABSAD(2,2,IRTN,1,ICHR) RETURN C C C 10010 IENAM = 5 GO TO 99 END C C CC*********************************************************** C SUBROUTINE CONVT(INTX,IABUF,ICHR,N), 92840-16002 REV. 1819 780515 DIMENSION IABUF(2),INTX(2),ICNV(4) DATA MINUS/55B/ DATA ICOMA/54B/ C C THIS ROUTINE CONVERTS N INTEGER VALUES IN "INTX" TO ASCII C AND PLACES IT IN "IABUF". THE FORMAT OF IABUF IF N=2 WHEN C FINISHED LOOKS LIKE: C WORD 1 D1X D2X C " 2 D3X D4X C " 3 D5X , C " 4 D1Y D2Y C " 5 D3Y  D4Y C " 6 D5Y C C WHERE D(I) = ASCII DIGIT C C C IF A NEGATIVE NUMBER IS ENTERRED D1 BECOMES A MINUS SIGN C AND THE OTHER DIGITS ARE MOVED DOWN ONE. SOME OF THESE WORDS C MAY NOT BE FILLED UPON RETURN THEREFORE PARAMETER "ICHR" TELLS C THE ACTUAL NUMBER OF CHARACTERS IN IABUF. C C INITIALIZE PARAMETERS C DO 100 K = 1,N IX = INTX(K) IF(INTX(K))5,7,7 5 IX = -IX C C CONVERT INT TO ASCII C 7 CALL CNUMD(IX,ICNV) IF(INTX(K))10,20,20 C C SEE IF A MINUS AND IF SO INSERT MINUS SIGN INTO IABUF(I) C 10 I = ICHR/2 + 1 CALL BYTE(ICHR ,MINUS,IABUF(I)) ICHR = ICHR+1 20 DO 50 J =1,3 C C PLACE EACH BYTE INTO IABUF C I= ICHR/2 + 1 IX = (IAND(ICNV(J) ,177400B))/400B IF(IX.EQ.40B)GO TO 40 CALL BYTE(ICHR ,IX,IABUF(I)) ICHR = ICHR + 1 I = ICHR/2 + 1 40 IX = IAND(ICNV(J) ,377B) IF(IX.EQ.40B)GO TO 50 CALL BYTE(ICHR ,IX,IABUF(I)) ICHR = ICHR + 1 50 CONTINUE I = ICHR/2 + 1 IF(K.EQ.N)RETURN CALL BYTE(ICHR,ICOMA,IABUF(I)) ICHR = ICHR + 1 I = ICHR/2 + 1 100 CONTINUE RETURN END C C CC*********************************************************** C SUBROUTINE BYTE(LR,IBYTE,IWRD), 92840-16002 REV. 1819 780515 DIMENSION MASK(2),MPY(2) DATA MASK/377B,177400B/ DATA MPY/400B,1/ C C C THIS ROUTINE IS RESPONSIBLE FOR PLACING A BYTE EITHER C IN THE LEFT OR RIGHT SIDE OF THE PARAMETER "IWRD". C THE PARAMETER LR INDICATES WHETHER IT IS THE RIGHT OR C LEFT SIDE. C LR = 1 LEFT SIDE C LR = 2 RIGHT SIDE C C THE PARAMETER LR IS INCREMENTED EACH TIME BY THE CALLING C PROGRAM. C L = IAND(LR,1) + 1 IB = IBYTE * MPY(L) IWRD = IOR(IAND(IWRD,MASK(L)),IB) RETURN END SUBROUTINE OUTPT(ICMND,IBUFR,IRW), 92840-16002 REV.1819 780515 INTEGER STPLB DIMENShION IBUFR(2) DATA IGICB/16/ DATA STPLB/24000B/ DATA IECHK/77400B/ C C THIS LITTLE ROUTINE IS RESPONSIBLE FOR SENDING C OUTPUT DATA TO THE GCB AND THEN INVOKING THE C DEVICE SUBROUTINE VIA SWTCH. C C MAKE DEVICE SUBROUTINE CHECKS IF NECESSARY C ISTAT = 0 CALL PLTER(-98,ISTAT) IF(ISTAT.NE.0)RETURN CALL GRSTS(1,2000B,ISTAT) IF(ISTAT.NE.0)GO TO 5 CALL GCBIM(IGICB,1,IECHK,1,2) CALL SWTCH(0) CALL GCBIM(IGICB,1,ISTAT,1,1) IF(ISTAT.NE.0)GO TO 150 CALL GRSTS(2,0,2000B) C CHECK ON LABEL MODE SITUATION. C ISTAT = 0 5 CALL GRSTS(1,100B,ISTAT) IF(ISTAT.EQ.0)GO TO 10 CALL GCBIM(IGICB,1,STPLB,1,2) CALL SWTCH(0) CALL PLTER(35) C C RESET BIT C CALL GRSTS(2,77677B,0) 10 INDX = 1 DO 100 I = 1,ICMND L = IAND(IBUFR(INDX),377B) + 1 IF(IRW.EQ.1)L=1 CALL GCBIM(IGICB,1,IBUFR(INDX),L,2) CALL SWTCH(0) INDX = INDX + L 100 CONTINUE RETURN 150 CALL PLTER(ISTAT) RETURN END C C CC*********************************************************** C SUBROUTINE GRSTS(ISET,MASK,NMASK), 92840-16002 REV.1819 780515 C C THIS ROUTINE IS RESPONSIBLE FOR SETTING AND UNSETTING C BITS IN THE GCB STATUS WORD, AND ALSO FOR SENDING C MASKED OUT PORTIONS OF THE STATUS WORD BACK TO THE C CALLER. C C THE PARAMETERS IN THE CALLING SEQUENCE HAVE THE FOLLOWING C MEANING: C ISET = 1 RETRIEVE DATA FROM STATUS WORD C = 2 SET BIT(S) IS STATUS WORD. C MASK IS THE PATTERN TO BE ANDED WITH THE STATUS WORD C NMASK- FOR ISET = 1 THIS WORD WILL CONTAIN THE RESULTANT C STATUS WORD ANDED WITH MASK. C FOR ISET = 2 THIS IS THE BIT PATTERN TO BE INCLUSIVE ORED C WITH THE RESULT OF (MASK.AND.STATUS). C ISTAT = 0 CALL PLTER(-98,ISTAT) IF(ISTAT.NE.0)RETURN CALL ABSAD(8,1,ISTAT,1,IND) o IST = IAND(ISTAT,MASK) GO TO(10,20),ISET 10 NMASK = IST RETURN C 20 ISTAT = IOR(IST,NMASK) CALL ABSAD(8,2,ISTAT,1,IND) RETURN END INTEGER FUNCTION IADCD(D), 92840-16002 REV.1819 780515 C THIS FUNCTION DETERMINES WHAT FLAVOR OF TRANSFORMATION C CONSTANTS TO USE: A' - D' = 11 MU/GDU C A - D = 12 MU/UDU C ISTAT = 0 IADCD =11 CALL GRSTS(1,1,ISTAT) IF(ISTAT.NE.0)IADCD = 12 RETURN END INTEGER FUNCTION IS1V1(D), 92840-16002 REV.1819 780515 C C THIS FUNTION DETERMINES WHETHER TO USE SOFT CLIP LIMITS C S1 - S2 OR HARD CLIP LIMITS G1-G2 C ISTAT = 0 IS1V1 = 8 CALL GRSTS(1,4,ISTAT) IF(ISTAT.NE.0)IS1V1 = 10 RETURN END SUBROUTINE PKBIN(INBUF,IOBUF,ICHR,NUM, 1N), 92840-16002 REV.1819 780515 DIMENSION INBUF(2),IOBUF(2) DIMENSION IMSK(3),ISHFT(3) DATA IMSK/70000B,1740B,37B/ DATA ISHFT/10000B,40B,1/ C C C THIS SUBROUTINE IS RESPONSIBLE FOR TAKING INTEGER VALUES C IN INBUF AND CONVERTING THEM TO INTO PACKED BINARY FORMAT C AND RETURNING THE VALUES IN IOBUF. C THE DIFFERENT FORMATS THAT ARE RETURNED IN IOBUF ARE IN C THE FOLLOWING FORMATS: C C INBUF IOBUF NUM C X,Y (0-1023) WD 1 BYT1\BYT2 1=ABSOLUTE C (HI-X,LO-X) C WD 2 BYT3\BYT4 C (HI-Y,LO-Y) C X,Y(-16-+15) WD 1 BYT1=X\BYT2=Y 2=SHORT INCREMENTAL C C X,Y(-16384 TO 16383) WD 1 BYT1\BYT2 3=LONG INCREMENTAL C (HI-DX,MID-DX) C WD 2 BYT3\BYT4 C (LO-DX,HI-DY) C WD 3 BYT5\BYT6 C (MID-DY,LO-DY) C C N = NUMBER OF PAIRS TO CONVERT K = 1 C C BRANCH TO APPROPRIATE PARSER C C GO TO (10,20,30),NUM C O C ABSOLUTE C 10 DO 100 J=1,N IBYTE =(IOR(IAND(INBUF(J),1740B), 2000B))/40B CALL BYTE(ICHR,IBYTE,IOBUF(K)) K = IAND(ICHR,1) + K ICHR = ICHR+1 IBYTE = IOR(IAND(INBUF(J),37B),40B) CALL BYTE(ICHR,IBYTE,IOBUF(K)) K = IAND(ICHR,1) + K ICHR = ICHR+1 100 CONTINUE RETURN C C SHORT INCREMENTAL C C0 LOOP = N/2 C JJ = 0 C DO 200 J=1,LOOP C DO 198 KK =1,2 C JJ = JJ+1 C IBYTE = IOR(IAND(INBUF(JJ),37B),40B) C CALL BYTE(ICHR,IBYTE,IOBUF(K)) C K = IAND(ICHR,1) + K C ICHR = ICHR + 1 C98 CONTINUE C00 CONTINUE C RETURN C C LONG INCREMENTAL C C0 DO 300 J=1,N C DO 400 I=1,3 C INB = INBUF(J) C IBYTE = IOR((IAND(IMSK(I),INB)/ISHFT(I)),40B) C IF(INB.LT.0.AND.I.EQ.1)IBYTE = IOR(IBYTE,30B) C CALL BYTE(ICHR,IBYTE,IOBUF(K)) C K = IAND(ICHR,1) + K C ICHR = ICHR + 1 C00 CONTINUE C00 CONTINUE C RETURN END C NAME: CLIPPING ALGORITHM C C C CC*********************************************************** C SUBROUTINE CLPNG(POINT,CLPTS,ENDPT, 1IFLG), 92840-16002 REV.1819 780515 INTEGER OC1,OC2,OCODE DIMENSION POINT(4),CLPTS(4) C C THIS IS THE CLIPPING ALGORITHM FOR THE C AGL GRAPHICS PACKAGE. THE PARAMETERS IN THE CALLING C SEQUENCE HAVE THE FOLLOWING MEANINGS: C C POINT - 4 WORD ARRAY WITH VECTOR ENDPOINT X(B),X(A) C CLPTS - 4 WORD ARRAY WHICH WILL CONTAIN THE RESULTS OF THE C COMPUTATIONS CONTAINED WITHIN. C ENDPT - DIAGONAL END POINTS FOR WINDOW OR VIEWPORT C IFLG - = 0 IF X(A) IS INSIDE BOUNDARY C = 1 " " " OUTSIDE C C DELTA = .5 IF(IFLG.LT.0)DELTA = 0. IND = IFLG IFLG = 0 C C C C MAKE TRIVIAL TEST TO SEE IF LINE IS INVISIBLE C C OC1 = OCODE(POINT,ENDPT,DELTA) OC2 = OCODE(POINT(3),ENDPT,DELTA) IF(IAND(OC1,OC2).EQ.0)GO TO 90 50 =IFLG = 1 IF(IND.LT.0)RETURN GO TO 200 C C LINE IS PARTIALLY VISIBLE OR COMPLETELY VISIBLE, THE C LINES OF CODE DETERMINE THIS. C 90 DO 95 I=1,4 CLPTS(I) = POINT(I) 95 CONTINUE IF(OC1.EQ.0)GO TO 100 CALL CLIPO(OC1,CLPTS(1),CLPTS(2),CLPTS(3),CLPTS(4),ENDPT) C C CLPTS 1 AND 2 NOW CONTAIN CLIPPED POINTS, NOW DEAL WITH C OTHER END-POINT. C 100 IF(OC2.EQ.0)GO TO 200 CALL CLIPO(OC2,CLPTS(3),CLPTS(4),CLPTS,CLPTS(2),ENDPT) IF(OC1.NE.0.OR .OC2.NE.0)GO TO 50 C C NOW SEE IF SOFT CLIPPING IS ON AND IF SO CUT OUT. IF HARD C CLIPPING IS IN FORCE ASCERTAIN WHETHER OR NOT THE HARD CLIP C LIMITS HAVE BEEN REDEFINED AND WHETHER OR NOT THE DEVICE CAN C HANDLE IT. IF THE DEVICE CAN DO ITS ON CLIPPING FOR REDEFINED C HARD CLIP LIMITS LET IT. C 200 ISTAT = 0 CALL GRSTS(1,4,ISTAT) IF(ISTAT.NE.0)RETURN CALL GRSTS(1,10B,ISTAT) IF(ISTAT.NE.0)RETURN C C LET DEVICE DO IT. C DO 250 I=1,4 CLPTS(I) = POINT(I) 250 CONTINUE IF(IFLG.EQ.1)CALL PLTER(20) IFLG= 0 RETURN END SUBROUTINE CLIPO(IOC,X1,Y1,X2,Y2, 1ENDPT), 92840-16002 REV.1819 780515 INTEGER OCODE DIMENSION ENDPT(4),XI(2),ENDXY(4) EQUIVALENCE (ENDXY,END1),(ENDXY(2),END2),(ENDXY(3),END3) EQUIVALENCE (ENDXY(4),END4) C C THIS ROUTINE PUSHES THE ENDPOINT X1,Y1 TOWARD THE C THE CLIPPING BOUNDARY IT IS HANGING OFF. C INDX = IOC DELTA = .5 C WRITE(6,500)(ENDPT(K),K=1,4) C00 FORMAT(2X,"ENDPOINTS =",4(X,F7.3)) C WRITE(6,1000)IOC,X1,Y1,X2,Y2 C000 FORMAT(2X,"OC,X1-Y2",2X,K6,4(X,F8.3)) C LOOP = 0 5 DX = X2 - X1 DY = Y2 - Y1 K = 1 SLOPE = DY/DX DO 7 L=1,4 7 ENDXY(L) = ENDPT(L) IF(INDX.GT.2)INDX = (INDX/4) + 2 GO TO(10,20,30,40),INDX C C PUSH TOWARD LEFT SIDE C 10 Y1 = Y1 + SLOPE * (ENDPT - X1) X1 = END1 GO TO 50 C nC PUSH TOWARD RIGHT SIDE C 20 XR = END3 Y1 = Y1 + SLOPE * (XR - X1) X1 = XR GO TO 50 C C PUSH TOWARD BOTTOM C 30 YB = END2 X1 = X1 + (1/SLOPE) * (YB - Y1) Y1 = YB K = 2 GO TO 50 C C PUSH DOWN ON TOP C 40 YT = END4 X1 = X1 + (1/SLOPE) * (YT - Y1) Y1 = YT C K = 2 C TEST FOR INNESS C 50 XI = X1 XI(2) = Y1 C WRITE(6,2000)X1,Y1 C000 FORMAT(2X,"CLIPPED POINTS X1,Y1",2(X,F7.3)) INDX = OCODE(XI,ENDPT,DELTA) IOC = INDX C WRITE(6,3000)INDX C000 FORMAT(2X,"ITST = ",K6) C LOOP = LOOP + 1 IF(LOOP.GT.10)RETURN IF(INDX.NE.0)GO TO 5 IOC = 0 RETURN C C TAKE CARE OF CORNER CASE C C00 IF(ABS(OVSLP - ABS(SLOPE)).GE.EPSI)RETURN C IOC = 0 C GO TO(610,620),K C10 Y1 = YEND C WRITE(6,2)Y1 C FORMAT(2X, "Y1 =",F7.2) C RETURN C20 X1 = XEND C WRITE(6,3)X1 C FORMAT(2X,"X1=",F7.2) C RETURN END INTEGER FUNCTION OCODE(POINT,ENDPT, 1DELTA), 92840-16002 REV.1819 780515 INTEGER GRIFX DIMENSION POINT(2),ENDPT(4) C C THIS LITTLE FUNTION IS RESPONSIBLE FOR COMPUTING C THE OUT CODES FOR THE CLIPPING ALGORITHM. C ICD1 = 0 ICD2 = 0 OCODE = 0 C C C WRITE(6,1200)IPT1,IPT2,POINT(1),POINT(2) C200 FORMAT(2X,2(X,I4),2X,2(X,F7.2)) C WRITE(6,1000)IEND1,IEND2,IEND3,IEND4 C000 FORMAT(2X,"IEND ",4(X,I3)) C C LOWER LEFT C IF(POINT(1).LT.(ENDPT(1) - DELTA)) ICD1 = 1 IF(POINT(2).LT.(ENDPT(2) - DELTA))ICD2 = 4 C C UPPER RIGHT C IF(POINT(1).GT.(ENDPT(3) + DELTA))ICD1 = 2 IF(POINT(2).GT.(ENDPT(4) + DELTA))ICD2 = 8 OCODE = ICD1 + ICD2 RETURN END END$ UHFBBH Pa 92840-18081 1819 S C0122 ABSOLUTE ADDR              H0101 (ASMB,R,L,C * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: ABSAD (PART 1 GRAPHICS LINKAGE MODULE) * SOURCE: 92840 - 18081 * RELOC: 92840 - 16001 * * * ************************************************************* * NAM ABSAD,7 92840-16002 REV.1819 780515 EXT .ENTR,PLTER,FLOAT,IFIX EXT .FLUN,..FCM,.IENT,BYTE EXT .PLTR,DPTR,GCBIM EXT ABS ENT ABSAD ENT DCTIM,EMULX,LNGTH,GIC,DCTAD ENT SWTCH,DCTXX,INDCK ENT .OPTN,INTX,FLTAS,GETID,GTNAM ENT GRIFX * * THIS IS THE ABSOLUTE ADDRESS ROUTINE FOR THE GRAPHICS * ITS RESPONSIBILITY IS TO SAVE THE FIRST WORD ADDRESS * OF THE GRAPHICS CONTROL BLOCK (GCB), AND TO TRANSMIT * DATA TO AND FROM THE GCB. THIS ROUTINE IS ALSO CAPABLE * OF TRANSFERRING DATA TO AND FROM OTHER BUFFERS WHOSE * ABSOLUTE ADDRESSES RESIDE IN THE GCB (E.G. IOBUF). * * CALLING SEQUENCE: * CALL ABSAD(IPTR,IRW,IBUFR,IBLNT,IND) * * WHERE: IPTR = 0 SAVE FWA OF GCB * >0 POINTER INTO BUFFER OF INTEREST * IRW = 1(READ),2(WRITE) * IBUFR = ADDRESS OF MSTERY BUFFER * IBLNT = IBUFR LENGTH * * IND = ERROR INDICATOR * ********************************************************* SKP SPC 3 IPTR NOP IRW NOP IBUFR NOP IBLNT NOP IND NOP ABSAD NOP JSB .ENTR DEF IPTR LDA IPTR,I POINTER INTO BUFFER SZA,RSS = 0? JMP INIT YES THEN GO INITIALIZE FWABF CPA M99 JMP CLR CLEAR GCB, PLOTR(0) CALL MAYBE CPA .99 JMP CHK TRGCB LDA FWABF GCB FWA XFER^ ADA IPTR,I COMPUTE FWA(BUFFER) + IPTR - 1 ADA M1 LDB IRW,I CPB .1 READ? JMP READ STA TO WRITE LDA IBUFR STA FROM JMP XFER1 READ STA FROM LDA IBUFR STA TO XFER1 LDA IBLNT,I CMA,INA STA ABCTR * * NOW TRANSFER DATA FROM > TO * XLOP LDA FROM,I STA TO,I ISZ TO ISZ FROM ISZ ABCTR JMP XLOP JMP ABSAD,I ALL DONE * * INITIALIZE FWABF * INIT LDA IBUFR STA FWABF INIT1 LDA M99 SAVE -99 INTO FWA OF GCB STA IBUFR,I JMP ABSAD,I * SPC 3 CLR LDA FWABF SZA,RSS JMP ERR CLA STA IBUFR,I STA FWABF JMP ABSAD,I * * CHECK TO MAKE SURE THAT BUFFER HAS BEEN INITIALIZED AND * SAVE CURRENT ADDRESS OF GCB. * CHK LDA IBUFR,I CPA M99 JMP CKON OK JMP ERR SOMETHING WRONG CKON LDA IBUFR SAVE ADDRESS STA FWABF JSB INDCK STA B ADA .7 STATUS WORD LDA A,I AND .1000 I/O BUFFERING FLAG SZA JMP AXIT LDA B ADA GCIO REINITIALIZE I/O BUFFERING POINTER ADB .5 STA B,I AXIT JMP ABSAD,I * ERR LDA IBUFR STA FWABF JSB PLTER DEF RTN DEF .199 DEF .100 RTN LDA M99 STA IND,I JMP ABSAD,I JMP ABSAD,I SKP SPC 3 * * GRAPHICS INTEGERIZING ROUTINE * NUMBR NOP GRIFX NOP JSB .ENTR DEF NUMBR DLD NUMBR,I JSB ABS DST ASAV JSB IFIX INTEGERIZE NOP STA ATEMP JSB FLOAT FLOAT IT DST SUBT DLD ASAV FSB SUBT NUMBER - FLOATED INTEGER FMP .10E1 FRACTIONAL VALUE * 10. DST SUBT DLD D5 FSB SUBT 5 - FRACTION * 10. SSA > 5 ISZ ATEMP SZA,RSS =5 ISZ ATEMP DLD NUMBR,I SEE IF NUMBER IS POSITIVE OR NEGATIVE SSA,RSS <0 JMP GREND LDA ATEMP CMA,INA JMP GRIFX,I GREND LDA ATEMP JMP GRIFX,I SKP SPC 3 *CONSTANTS AND TEMPORARY STORAGE * FWABF NOP TO NOP ASAV BSS 2 FROM NOP ABCTR NOP GCIO DEC 103 .1000 OCT 1000 .5 OCT 5 .99 DEC 99 M99 DEC -99 .100 DEC 100 * ATEMP NOP D5 DEC 5. .199 DEC 199 SKP * * * THIS MODULE IS PART OF THE INTERFACE BETWEEN USER * PROGRAMS AND THE AGL GRAPHICS PACKAGE. THIS PORTION * OF THE INTERFACE PROCESSES THE PARAMETER STRINGS BY * CHECKING FOR THE PRESENCE OF THE LEGAL NUMBER OF PARAMETERS * AND THE SETTING UP OF DEFAULT VALUES. * .OPTN NOP STA RETRN ADDRESS OF P+1 CLA STA MESS LDA PADR JSB INDCK STA PAD STA B LDA .PCNT JSB CLEAR LDA .OPTN P+1 RETURN ADDRESS JSB INDCK STA B LDA B,I STA .OPTN ADDRESS OF RETURN POINT INB ADDRESS OF PARAMETER BUFFER LDA B,I JSB INDCK STA TFBF FWA OF PARM BUFFER INB STB SAVB LDA B,I LDA A,I # OF WORDS IN PARM BUFFER LDB TFBF JSB CLEAR ISZ SAVB LDA SAVB,I STA TFBF,I CODE FOR AGL ROUTINE TO DETERMINE THE APPROPRIATE ISZ TFBF JMP ENTER PARMS BSS 10 BUFFER WHICH WILL CONTAIN PARAMETER ADDRESSES RETRN NOP RETURN ADDRESS TO CALLING ROUTINE ENTER JSB .ENTR GET ADDRESES FROM UP YONDER PADR DEF PARMS LDA .OPTN COMPUTE ADDRESS OF STORAGE FOR RETURN POINT JSB INDCK ADA M1 LDA A,I STA RTNAD ISZ SAVB BUMP TO P+3 (#OF PARAMETERS - #DEFAULTS) LDA SAVB,I LDA A,I LDB PAD SZA,RSS ARE THERE ANY PARAMETERS THAT ARE REQ'D JMP DF NO CMA,INA STA CNTR * * NOW CHECK FOR MISSING GCB PARAMETER & * LDA .PLTR SEE IF PLOTR CALL SZA JMP PLOOP LDA PARMS,I FW OF GCB CPA M99 JMP PLOOP JSB PLTER MISSING GCB WARN PLTER TO GET READY FOR ERROR 99 DEF RTNER DEF .6 DEF .PCNT RTNER JMP MESUP * * NOW CHECK FOR THE EXISTENCE OF PARAMETERS THAT SHOULD BE * THERE. * PLOOP LDA B,I B POINTS TO PARM BUFFER (DEFAULTS) SZA,RSS IS THERE A PARAMETER THERE? JMP MESUP NO THEN AN ERROR - REPORT IT. STA TFBF,I ISZ TFBF INB BUMP TO NEXT PARAMETER ADDRESS ISZ CNTR JMP PLOOP CONTINUE DF ISZ SAVB NOW CHECK OUT EXISTENCE OF DEFAULTS LDA SAVB,I SHOULD THERE BE ANY ANYHOW? LDA A,I SZA,RSS JMP EXIT NO -THEN EXIT STAGE LEFT CMA,INA STA CNTR GET #OF DEFAULTS COMPLEMENT AND SET IN COUNTER ISZ SAVB BUMP TO TOL FOR DEFAULTS LDA SAVB,I STA SAVB SAVE ADDRESS FOR TOL DLOOP LDA B,I SZA DID THE PERSON ABOVE SUPPLY A DEFAUL PARAM? JMP SKPDF YES SETDF LDA SAVB,I DEFAULT VALUE ADDRESS STA TFBF,I SET DEFAULT ADDRESSES INTO TFPRM BUFFER ISZ TFBF ISZ SAVB ISZ CNTR JMP SETDF JMP EXIT ALL DONE SKPDF ISZ SAVB STA TFBF,I ISZ TFBF INB BUMP POINTER TO USER PARAMETERS ISZ CNTR JMP DLOOP EXIT LDA RETRN STA RTNAD,I LDA CNTR LDB MESS ERROR? SZB,RSS ISZ .OPTN JMP .OPTN,I * * * SPC 3 CLEAR NOP STA CNTR CLA ENDLP STA B,I INB ISZ CNTR JMP ENDLP JMP CLEAR,I SPC 3 MESUP ISZ MESS P+1 RETURN ERROR JMP EXIT * * POSSIBLE GOOD GCB - NOW CHECK OUT IF THERE ARE HARD ERRORS * OTHER THAN TYPE 6 ERROR. * CKOUT STB TEMP JSB PLTER DEF CKRTN DEF M98 RETRIEVE ERROR DEF IERR CKRTjN LDA IERR CPA .6 TYPE 6? JMP *+2 SOME WORK TO DO JMP CKEXT JSB PLTER DEF CKRT2 DEF M99 CLEAR ERRORS DEF IERR CKRT2 LDB PARMS INB LDA IERR STA B,I MAY CRASH IF USER REALLY BLEW IT CKEXT LDB TEMP JMP PLOOP SKP SPC 3 * * PARAMETERS AND CONSTANTS * B EQU 1 SAVB NOP .PCNT DEC -10 ADCNT NOP TFBF NOP RTNAD NOP MESS NOP M98 DEC -98 PAD NOP IERR NOP * SKP * THIS IS THE MODULE USED TO CONNECT THE AGL FUNCTIONAL MODULE * TO THE CORRECT DEVICE SUBROUTINE. * IF FOR SOME REASON THE USER DID NOT FORMAT THE DUMMY TABLE (DTBL) * CORRECTLY OR THAT HE IS USING THE WRONG DEVICE ID, THEN AN ERROR * MESSAGE IS EMITTED. * * GET DEVICE ID NUMBER. * IDCK NOP SWTCH NOP JSB .ENTR DEF IDCK LDA IDCK,I SZA JMP RTG0 JUST CHECK OUT ID JSB GCBIM DEF RTG DEF .3 CODES FOR LUN AND ID. DEF .1 ONE VALUES DEF ID DEF .0 DEF .1 * SPC 3 * * GET THE DEVICE SUBROUTINE ADDRESS FROM THE DEVICE COMMAND TABLE. * * RTG LDA DP,I DUMMY TABLE POINTER SSA SEE IF DUMMY PUT NEGATIVE NUMBER JMP ERROR CLE,ERA #WORDS/2 LDB ID CMB,INB ADB A ID # > # ENTRIES IN TABLE SSB IF POSITIVE EVERYTHING OK JMP ERROR * * NOW COMPUTE ADDRESS FOR DEVICE SUBROUTINE AND DEVICE COMMAND * TABLE * LDA ID ADA M1 (ID # -1) > A ALS A*2 > A STA ID LDA DP JSB INDCK INDIRECT CHECK ADA .1 ADA ID ADDR(D.S) = ADDR(DPTR) + (ID-1)/2 LDB A,I DEVICE SUBROUTINE ADDRESS SZB,RSS SEE IF ZERO JMP ERROR STB DVGXX SAVE IT INA LDA A,I DEVICE COMMAND TABLE ADDRESS SZA,RSS SEE IF ZERO =s JMP ERROR JSB INDCK STA DCTXX LDA IDCK,I SZA,RSS JSB DVGXX,I SWEXT JMP SWTCH,I * * * ERROR JSB PLTER DEF *+2 DEF .2 JMP SWTCH,I * RTG0 STA ID JMP RTG * * SPC 3 INDCK NOP RSS LDA 0,I RAL,CLE,SLA,ERA JMP *-2 JMP INDCK,I * * DO NOT CHANGE POSITION OF CONSTANTS * .0 OCT 0 .1 OCT 1 .2 OCT 2 .3 OCT 3 .4 OCT 4 .6 OCT 6 .19 DEC 19 A EQU 0 ID NOP DCTXX NOP DP DEF DPTR DVGXX NOP OCT 3 SKP * THIS ROUTINE IS RESPONSIBLE FOR RETRIVING AND SAVING CERTAIN * INFORMATION NEEDED BY THE DEVICE SUBROUTINES. NAMELY: * * GIC = GRAPHIC INTERPRETIVE CODE * LNGTH = LENGTH OF GICB -1 * DCTAD = POINTER TO LOCATION IN COMMAND LINK TABLE (CLTBL(GIC)) * * DCTIM NOP JSB GCBIM GET GIC AND LENGTH DEF RTND DEF .16 GICB CODE DEF .1 ONE CODE DEF GICBL WHERE TO PUT IT DEF .1 DEF .1 READ RTND LDA GICBL AND LOBIT MASK OFF BITS 0-7 STA LNGTH LDA GICBL AND UPBIT BITS 8-15 ALF,ALF STA GIC LDA DCT JSB INDCK INDIRECT ADDRESS CHECK LDB A,I * * INB EMULATOR ADDRESS LDA B,I STA EMULX LDA GIC CPA .177 JMP DCTIM,I ADB GIC COMPUTE CLTBL(GIC) LDA B,I STA DCTAD JMP DCTIM,I * * DCT DEF DCTXX .16 DEC 16 GICBL NOP UPBIT OCT 177400 LOBIT OCT 377 LNGTH NOP GIC NOP DCTAD NOP EMULX NOP .177 OCT 177 * SKP * THIS ROUTINE IS RESPONSIBLE FOR RETRIEVING THE NAME OF THE * PROGRAM THAT HAS COMMITED A HARD ERROR. * BUFG NOP JL NOP GETID NOP JSB .ENTR DEF BUFG LDA BUFG SET UP ADDRESS COUNTER STA AGCTR LDA M3 WORD COUNTER STA IDCNT LDB XEQT ADDRESS OF ID SEGMENT FOR PROGRAM ADB IDNAM GOOP XLA B,I STA AGCTR,I INB ISZ AGCTR ISZ JL,I ISZ IDCNT JMP GOOP ADB M1 LDA B,I AND .1740 IOR .40 LDB AGCTR ADB M1 PUT LAST CHARACTER INTO BUFFER WITH BLANK STA B,I ISZ JL,I JMP GETID,I * XEQT EQU 1717B .1740 OCT 17400 .40 OCT 40 AGCTR NOP M3 OCT -3 IDNAM DEC 12 IDCNT NOP * SKP * * THIS ROUTINE IS RESPONSIBLE FOR RETRIEVING THE NAME OF AN * AGL COMMAND IN WHICH A MISSING PARAMETER ERROR WAS * DETECTED. * * THE PARAMETERS IN THE CALLING SEQUENCE HAVE THE FOLLOWING * MEANINGS: * ICD = ERROR CODE ASSOCIATED WITH THE COMMAND * MSBUF = BUFFER IN WHICH THE ASCII CHARACTERS FOR THE * COMMAND WILL BE PLACED. * JJ = WORD COUNTER (INCREMENTED FOR EACH WORD PLACED IN BUFFER). * SPC 3 ICD NOP MSBUF NOP JJ NOP GTNAM NOP JSB .ENTR DEF ICD GET PARAMETER ADDRESSES LDA ICD,I ADA M40 COMPUTE (ICD -40) -->A STA SAVE ALS A * 2 --> A ADA SAVE SAVE + A -->A STA SAVE LDA TOP TOP OF LIST FOR AGL COMMAND NAMES JSB INDCK INDIRECT ADDRESS CHECK ADA SAVE STA SAVE POINTER TO CORRECT STRING LDA MSBUF SET UP ADDRESS COUNTER STA AGCTR LDA M3 STA IDCNT NAMLP LDA SAVE,I STA AGCTR,I ISZ JJ,I ISZ AGCTR ISZ SAVE ISZ IDCNT JMP NAMLP JMP GTNAM,I * SPC 2 SAVE NOP M40 DEC -40 SKP * * ASCII STRINGS * TOP DEF *+1 N40 ASC 3,PLOTR N41 ASC 3,MARGIN N42 ASC 3,VIEWP N43 ASC 3,LIMIT N44 ASC 3,WINDW N45 ASC 3,GCLR N46 ASC 3,CLIP N47 ASC 3,PLOT N48 ASC 3,RPLOT N49 ASC 3,IPLOT N50 ASC 3,CSIZE N51 ASC 3,CPLOT N52 ASC 3,POINT N53 ASC 3,CURSOR N54 ASC 3,DIGTZ N55 ASC 3,WHERE =N56 ASC 3,DSIZE N57 ASC 3,HDERR N58 ASC 3,LDIR N59 ASC 3,PDIR N60 ASC 3, N61 ASC 3,LGERR N62 ASC 3,LAXES N63 ASC 3,LGRID N64 ASC 3,PEN N65 ASC 3,LINE N66 ASC 3,LABEL N67 ASC 3,GPON N68 ASC 3,SETAR N69 ASC 3,DRAW N70 ASC 3,MOVE N71 ASC 3,DRAWI N72 ASC 3,MOVEI N73 ASC 3,DRAWR N74 ASC 3,MOVER N75 ASC 3,MSCAL N76 ASC 3,CLPON N77 ASC 3,CLPOF N78 ASC 3,SHOW N79 ASC 3,LORG N80 ASC 3,FXD N81 ASC 3,PENUP N82 ASC 3,PENDN N83 ASC 3,PORG N84 ASC 3,XMIT N85 ASC 3,DSTAT N86 ASC 3,GSTAT N87 ASC 3,GPMM N88 ASC 3,FRAME N89 ASC 3,SETUU N90 ASC 3,SETGU N91 ASC 3,IGERR * * INDIRECT CHECK * SKP * * THIS ROUTINE TAKES AN ASCII STRING IN THE FOLLOWING FORMAT * * STRING (OCTAL ASCII VALUE) ACTUAL VALUE * 26461 -1 * 30464 14 * 20040 SPACE,SPACE * * AND STRIPS OFF THE ASCII FORMAT AND PLACES THE SIGN AND NUMERIC * IN THE FOLLOWING FORMAT: * QUANTITIES INTO A BUFFER IN THE FOLLOWING FORMAT. * * OUTPT WORD 1 = 4 * 2 = 1 * 3 = 1 * 4 = 55 = ASCII MINUS * * * A BYTE COUNTER IS INCREMENTED AND IS UPDATED EACH TIME * THIS ROUTINE IS CALLED. IF IN THE ABOVE EXAMPLE BYTE = 4 * UPON ENTERRING ROUTINE, UPON EXIT THE VALUE WOULD BE 8. * * THE DATA IN THE BUFFER SHOWN IS TAKEN AND CONVERTED TO OCTAL INTEGER * USING THE FOLLOWING ALGORITHM: * * INT = SUM((12BASE8)*I*IBUF(I+1), WHERE I = 0-4 AND IBUF IS THE BUFFER * DEFINED ABOVE. THE EXAMPLE ABOVE WOULD LOOK LIKE: * * 1 *(4) + 12 * (1) + 144 * (1) = 162BASE 8 = VALUE * * CALLING SEQUENCE: * * CALL INTX(INPUT,VALUE,BYTE) * * WHERE: INPUT = ASCII INPUT BUFFER * VALUE = INTEGER VALUE RETURNED * BYTE = BYTE COUNTER * * **************************************************************** * SKP SPC 3 INPUT NOP VALUE NOP BITE NOP INTX NOP JSB .ENTR DEF INPUT CLA STA SGNFL STA NUMF LDA BITE,I UPDATE POINTER INTO INPUT BUFFER CLE,ERA ADA INPUT STA INP LDB ADEND ADDRESS OF END OF BUFFER WHERE DATA IS TO GO MLOOP ADB N1 LDA BITE,I SEE IF THIS IS A RIGHT OR LEFT BITE SLA,RSS JMP EVEN LEFT BITE LDA INP,I AND LOMSK MASK OFF BITS 0-7 ISZ INP JMP CKLOP CHECK IT OUT EVEN LDA INP,I AND UPMSK MASK OFF BITS 8-15 ALF,ALF SHIFT TO BITS 0-7 CKLOP CPA PLUS PLUS SIGN? JMP STFLG GO SET SIGN FLAG CPA MINUS - SIGN JMP STFLG DO SAME ADA M60 GET RID OF ASCII STA TEMP SZA,RSS MUST BE A NUMBER OR SOME OTHER ASCII CHARACTER JMP CONT A NUMBER SSA A<0? JMP CKNUM YES CMA,INA ADA .11 SSA JMP CKNUM NOT A NUMBER CONT LDA SGNFL SEE IF SIGN FLAG HAS BEEN SET SZA,RSS JMP PTSGN GO INSERT SIGN THEN DIGIT ISZ NUMF LEGITIMATE NUMBER LDA NUMF CPA .6 MAKE SURE WE HAVEN'T GONE PAST 5 DIGITS JMP CONVT LDA TEMP STA B,I JMP LOOP * * PTSGN LDA PLUS DEFAULT SIGN STA B,I ADB N1 LDA TEMP STA B,I ISZ SGNFL ISZ NUMF JMP LOOP * * CKNUM LDA NUMF SZA JMP CONVT JMP LOOP * * * STFLG ISZ SGNFL STA B,I JMP LOOP SPC 3 LOOP ISZ BITE,I JMP MLOOP SKP SPC 3 * * THIS PORTION OF THE ROUTINE CONVERTS THE VALUES IN BUFR TO INTEGER. * THE B REGISTER AT THIS TIME POINTS TO THE FIRST VALU TO BE CONVERTED * IN BUFR. * CONVT CLA STA VALUE,I LDA NUMF CMA,INA STA CNTR SET UP COUNTER INB POINT B& TO FIRST NUMBER STB ADRPT LDA MPLR TOP OF LIST OF MULTIPLIER CONSTANTS STA MPADR ADDRESS COUNTER CLOOP CLB LDA ADRPT,I MPY MPADR,I C(BUFR) * MCON(I) STA TEMP ADA VALUE,I VALUE = VALUE + TEMP STA VALUE,I ISZ ADRPT ISZ MPADR ISZ CNTR JMP CLOOP LDA ADRPT,I SEE IF LAST WORD IS A MINUS CPA MINUS JMP COMP JMP INTX,I COMP LDA VALUE,I CMA,INA VALUE =-VALUE STA VALUE,I JMP INTX,I * * SKP * *TEMPORARY STORAGE AND CONSTANTS * LOMSK OCT 377 UPMSK OCT 177400 BUFR BSS 10 ADEND DEF * NUMF NOP CNTR NOP MPADR NOP MPLR DEF MCON MCON DEC 1 DEC 10 DEC 100 DEC 1000 DEC 10000 ADRPT NOP INP NOP M60 OCT -60 .11 DEC 9 SGNFL NOP N1 DEC -1 TEMP NOP M5 OCT -5 COUNT NOP * SKP * * THIS ROUTINE CONVERTS A FLOATING POINT VALUE CONTAINED * IN NUM TO ASCII AND STORES THE RESULT IN IOBUF. * THE RESULTING FLOATING POINT VALUE IS FORMATTED * ACCORDING TO F7.N FORMAT, WHERE N HAS BEEN SPECIFIED * THE FXD(N) COMMAND. * NUM NOP IOBUF NOP IBYTE NOP N NOP SKPBK NOP FLTAS NOP JSB .ENTR DEF NUM LDA N,I STA RIGHT LDA IBYTE,I CLE,ERA ADA IOBUF STA FLTAD CLA STA UNFLG UNDERFLOW FLAG STA SIGN SIGN FLAG 1= MINUS STA EXPFL STA IN RTNR LDA RIGHT COMPUTE 7-(N+1) NUMBER OF DIGITS TO LEFT OF DECIMAL INA POINT. ADA M7 STA LEFT DLD NUM,I NOW CHECK TO SEE IF NUMBER IS WITHIN A FEASIBLE RANGE FOR DST SAVOU STA SAVA FOR F7.N FORMAT. STB SAVBB SZA SEE IF NUM = 0 JMP CONT0 SZB,RSS JMP FLT0 NUM = 0.0 CONT0 SSA,RSS SEE IF NUMBER IS NEGATIVE AND IF SO INSERT A MINUS JMP CONTF SIGN INTO THE I/O BUFFER AND COMPLEMENS?T THE NUMBER ISZ SIGN SET SIGN FLAG TO INDICATE MINUS JSB ..FCM COMPLMENT DST SAVA DST SAVOU ISZ LEFT ONE LESS DIGIT TO LEFT OF DECIMAL POINT NOP LDA MINUS JSB PACK INSRT MINUS SIGN INTO IOBUF CONTF LDA RIGHT ROUND OFF CLE,ALS ADA RNDOF DLD A,I FAD SAVA NUMB + (.5) **N DST SAVA FCONT LDA RIGHT CPA .6 NOW CHECK FOR UNDERFLOW JMP SPLCS IF N=6 OR 7 WE HAVE A SPECIAL SITUATION CPA .7 JMP SPLCS LDA RIGHT COMPUTE (N*2) CLE,ALS STA FLTMP ADA UNFLW GET ADDRESS OF TOL OF UNDERFLOW CONSTANTS DLD A,I DST SUBT DLD SAVA FSB SUBT NOW SEE IF NUM CONSTANT SZA,RSS JMP OVER NUM = CONSTANT JMP REGLR REGULAR CASE -SO GO DO F7.N * * SPLCS LDA SIGN SZA JMP LOWER DLD .EM6 DST SUBT JMP CHECK LOWER DLD .EM5 DST SUBT CHECK DLD SAVA FSB SUBT SSA JMP SPEN1 UNDERFLOW DLD SAVA FSB D1 SSA,RSS JMP SPEND SZA JMP SPEND JMP OVER SPEND LDA MINUS JMP OVER+1 SPEN1 LDA PLUS JMP UNDER+1 * SKP SPC 3 * * FORMAT PORTION FOR REGULAR F7.N * SPC 2 REGLR ISZ RIGHT LDA RIGHT COMPLEMENT COUNTER FOR NUMBER OF DIGITS TO THE CMA,INA RIGHT OF THE DECIMAL POINT. STA RIGHT JSB EXTCT SEPERATE THE INTEGER PORTION OF THE NUMBER FROM THE LDB SAVBB FRACTIONAL, JSB .FLUN EXTRACT EXPONENT AND MANTISSA(A=EXP,B=MANTISSA)  SZA,RSS LOOK FOR 0 OR NEGATIVE EXPONENT JMP FRACT = 0 SSA JMP FRACT < 0 DLD SAVA REGLP ISZ IN COUNT THE NUMBER OF DIVISIONS FSB .10E1 MAKE NUMBER < 10.0 IF IT IS NOT ALREADY SSA JMP REG2 < 10.0 DLD SAVA DIVIDE BY TEN UTIL NUM IS < 10.0 FDV .10E1 DST SAVA JMP REGLP REG2 LDB IN CMB,INB STB IN REG3 JSB GCIN FIND GREATEST CONTAINED INTEGER (INTEGERIZE) ISZ LEFT JMP *+2 MORE DIGITS TO THE LEFT OF DECIMAL POINT JMP FRACT GO DO FRACTIONAL PART. ISZ IN NUMBER OF DIVIDES RUN OUT? JMP REG3 NO JMP FRACT * SKP SPC 3 * * FRACTIONAL PART OF CONVERSION * SPC 2 FRACT LDA EXPFL CHECK FOR EXPONENT NECESSITY LDB UNFLG SZA JMP OVER1 SZB JMP UNDR1 UNDERFLOW LDA DECPT JSB PACK INSERT DECIMAL POINT INTO IOBUF FRAC1 DLD FRAC GET FRACTIONAL PART OF NUMBER FMP .10E1 MAKE FRACTION > 1 DST SAVA FRLP ISZ RIGHT JMP *+2 JMP END JSB GCIN GET INTEGER AND INSERT INTO IOBUF JMP FRLP END LDA EXPFL SZA JMP UNDER JMP FLTAS,I * * * FORMAT 0 TO 0.XXX * SPC 2 FLT0 LDA RIGHT CMA,INA STA RIGHT LDA ASCN ASCII 0 JSB PACK LDA DECPT DECIMAL POINT JSB PACK LDA RIGHT SZA,RSS N=0 JMP FLTAS,I FLTLP LDA ASCN JSB PACK ISZ RIGHT JMP FLTLP JMP FLTAS,I * SPC 3 * * FIND GREATEST INTEGER AND INSERT INTO IOBUF * GCIN NOP DLD SAVA JSB .IENT GET GREATEST CONTAINED INTEGER NOP STA FLTMP ADA ASCN JSB PACK LDA FLTMP FLOAT INTEGER JSB FLOAT DST SUBT DLD SAVA COMPUTE NUM - FLTMP FSB SUBT FMP .10E1  DST SAVA JMP GCIN,I * SKP SPC 3 * PACK NOP STA NIBLE SAVE BYTE JSB BYTE DEF RTN1 DEF IBYTE,I DEF NIBLE DEF FLTAD,I RTN1 ISZ IBYTE,I LDA IBYTE,I CLE,ERA INCREMENT IOBUF ADDRESS ADA IOBUF STA FLTAD JMP PACK,I * NIBLE NOP SPC 3 * * PACK BYTES INTO TEMPORARY BUFFER * * * SEPERATE INTEGER AND FRACTION PART OF NUMBER * EXTCT NOP DLD SAVA JSB .IENT GET INTEGER NOP JSB FLOAT DST SUBT DLD SAVA FSB SUBT GET FRACTION DST FRAC JMP EXTCT,I * FRAC BSS 2 SKP SPC 3 * * THIS ROUTINE FORMATS NUMBERS WHICH HAVE BEEN FOUND TO OVER- * FLOW THE F7.N FORMAT. THE NUMBERS ARE REFORMATTED ACCORDING * TO E7.0 FORMAT. * * FORMATS= XXXE+XX OR -XXE+XX * SPC 2 OVER LDA PLUS STA SPSGN SAVE ASCII PLUS SIGN IS TEMPORARY STORAGE ISZ EXPFL FLAG INDICATING EXPONENT DLD .10E2 100.0 DST TMPA LDB .3 NUMBER OF DIGITS TO LEFT OF DECIMAL POINT LDA SIGN NOW DETERMINE WHICH E7.0 FORMAT TO USE SZA,RSS JMP OVER0 DLD .10E1 10.0 DST TMPA LDB .2 OVER0 CMB,INB STB LEFT JMP REGLR OVER1 CLA STA IN COUNTER FOR NUMBER OF DIVIDES DLD SAVOU DST SAVA OVRLP FSB TMPA NUMBER - CONSTANT SZA,RSS JMP EXCNT SSA JMP EXCN0 DLD SAVA FDV .10E1 DIVIDE UNTIL NUMBER IS WITHIN RANGE DST SAVA ISZ IN JMP OVRLP * EXCN0 LDA IN ADA M1 STA IN * * NOW STORE AWAY .E+-XX * EXCNT LDA E JSB PACK LDA SPSGN SIGN + - JSB PACK LDA IN CLB DIV .10E1 STB TMPA ADA ASCN JSB PACK LDA TMPA ADA ASCN JSB PACK JMP FLTAS,I SPC 3 * * THIS SECTION OF CODE DEALS WITH THE UNDERFLOW CASE WHERE * A NUMBER UNDERFLOWS THE F7.N FORMAT. THE RESULTING NUMBERS * ARE FORMATTED ACCORDING TO THE FOLLOWING FORMATS: * -XXE-XX * XXXE-XX * UNDER LDA MINUS STA SPSGN ISZ UNFLG DLD XXX5 DST SAVA ROUND OFF VALUE DLD D99 DST TMPA LDB .3 LDA SIGN + OR - SIGN SZA,RSS JMP UNDR0 USE XX.E-XX FORMAT DLD XX5 DST SAVA DLD .9 DST TMPA LDB .2 USE -X.E-XX FORMAT UNDR0 CMB,INB NUMBER OF CHARACTERS TO LEFT OF DECIMAL POINT STB LEFT CLA STA MPCNT DLD SAVOU FAD SAVA DST SAVA UNDLP ISZ MPCNT DLD SAVA MULTIPLY NUMBER UNTIL FMP .10E1 IT IS > CONSTANT 9 OR 99 DST SAVA FSB TMPA SSA < CONSTANT JMP UNDLP JMP REGLR SPC 2 UNDR1 LDA MPCNT STA IN JMP EXCNT SKP SPC 3 * * CONSTANTS AND TEMPORARY STORAGE * OVFLW DEF .10E6 RNDOF DEF D.5 UNFLW DEF D1 M1 OCT -1 M2 OCT -2 SAVA NOP SAVBB NOP SIGN NOP RIGHT NOP LEFT NOP M7 OCT -7 SUBT BSS 2 IN NOP BLANK OCT 40 FLTMP NOP ENFLG NOP .7 OCT 7 MINUS OCT 55 FLTAD NOP DECPT OCT 56 ASCN OCT 60 TMPA BSS 2 SAVOU BSS 2 PLUS OCT 53 E OCT 105 I1 OCT 1 EXPFL NOP SPSGN NOP .9 DEC 9. D99 DEC 99. MPCNT NOP UNFLG NOP .95 DEC .95 * * UNDERFLOW AND OVERFLOW CONSTANTS * .10E6 DEC 1000000.0 .10E5 DEC 100000.0 .10E4 DEC 10000.0 .10E3 DEC 1000.0 .10E2 DEC 100.0 .10E1 DEC 10.0 D1 DEC 1.0 DEC .1 DEC .01 DEC .001 DEC .0001 .EM5 DEC .00001 .EM6 DEC .000001 .26 DEC 26 D.5 DEC .5 DEC .05 XX5 DEC .005 XXX5 DEC .0005 DEC 5.E-5 DEC 5.E-6 DEC 5.E-7 DEC 5.E-8 * * END 1 QrZXTTZ Qe 92840-18083 1819 S C0122 2648A DEV. SUB              H0101 ASMB,R,L,C * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: DVG01 -2648A DEVICE SUBROUTINE * SOURCE: 92840 - 18083 * RELOC: 92840 - 16003 * * * ************************************************************* * NAM DVG01,7 92840-16003 REV.1819 780515 EXT EXEC,GCBIM,BYTE EXT EMULX EXT .IENT,FLOAT EXT EXEC EXT INDCK EXT INTX EXT DCTIM EXT CONVT EXT FLTAS EXT GRSTS EXT SMLAB EXT PKBIN EXT LNGTH,GIC,DCTAD ENT DVG01 * * THIS IS THE DEVICE SUBROUTINE FOR THE HP 2648A GRAPHICS * TERMINAL. THIS ROUTINE ALONG WITH DVR05 CONTROL THE * PICTURE DRAWING ON THE TERMINAL. * DVG01 NOP CLA INITIALIZE THE READ/WRITE FLAG AND BYTE COUNTER STA FIRST STA BUFLG STA FLTFG FLAG INDICATING FLOAT TO ASCII CONVERSION STA RWFLG COUNTER STA NUM STA NBYTE STA IBYTE STA SKPBK JSB DCTIM FILL UP GIC, LENGTH AND DEVICE COMMAND ADDR.(DCTAD) LDA GIC CPA .177 JMP ERRCK CHECK ON VALIDITY OF LU,ID,ETC LDA DCTAD SEE WHAT TYPE OF COMMAND THIS IS SSA EMULATOR? JMP EMULT YES SZA,RSS A NOP? JMP DVG01,I DO NOTHING A'TALL AND RETURN CONT LDB DCTAD A COMMAND ADDRESS LDA B,I SSA,RSS READ OR WRITE? JMP CONT0 READ ISZ RWFLG WRITE CMA,INA SET BYTE COUNT POSITIVE CONT0 STA NBYTE AND .1 COMPUTE NWORD = NBYTE/2 + REMAINDER STA NWORD STA ODFLG = 0 IF EVE&N, AND 1 IF ODD LDA NBYTE CLE,ERA NBYTE/2 ADA NWORD CMA,INA STA NWORD INB LDA B,I TERMINATOR SZA NOP? LDA A,I ADDRESS OF TERMINATOR STA TERM INB LDA B,I STA FIRST SAVE FIRST WORD OF COMMAND STRING STB DCTAD NOW POINT TO FIRST WORD OF COMMAND STRING JSB GTGLU CONT3 JSB BUFCK CHECK FOR I/O BUFFERING JSB SETUP XFER LDA DCTAD,I NOW TRANSFER COMMAND STRING TO THE I/O BUFFER STA ADCNT,I ISZ NWORD JMP CONT2 JMP XEND FINISHED CONT2 ISZ DCTAD ISZ ADCNT INCREMENT ADDRESS POINTERS JMP XFER CONTINUE XEND LDA ODFLG SZA,RSS ISZ ADCNT LDA RWFLG READ OR WRITE? SZA,RSS JMP READ JSB IGNOR SEE IF LENGTH ASSOCIATED WITH COMMAND IS TO BE IGNORED LDA LNGTH WRITE - NOW SEE IF ANY INTEGERS TO CONVERT TO ASCII SZA,RSS THIS IS LENGTH FROM GICB JMP XEND1 JSB CNVRT JMP FINI XEND1 LDA NBYTE NUMBER OF BYTES LDB .2 WRITE JSB OUTPT EXEC I/O JMP DVG01,I GO HOME BABY * * SKP SPC 3 * * PROCESS READ REQUEST. FIRST A WRITE MUST BE DONE TO * OUTPUT THE COMMAND CODE, AND THEN A READ MUST BE DONE TO * THE DEVICE INTO THE TALK MODE TO GET THE STATUS DATA. * READ NOP LDA NBYTE LDB .2 JSB OUTPT OUTPUT STATUS REQUEST COMMAND LDB .1 NOW PUT DEVICE INTO TALK MODE LDA .40 TO GET DATA JSB OUTPT LDA LNGTH SET TO CONVERT FROM ASCII TO INTEGER CMA,INA LDB FIRST CPB S3 GET CURSOR POSITION? ADA .1 STA LNTH CLA STA IBYTE LDA INX STA INTAD INTLP JSB INTX BEGIN TO CONVERT DATA DEF RTINT INTIO NOP INTAD NOP DEF IBYTE RTINT LDA FIRST CPA S5 JMP FIXIT GET PLOT URNITS CPA S7 GET CHAR. SIZE JMP FIXIT * CPA S1 * JMP DEVID ERROR CHECKING CONIN ISZ INTAD ISZ LNTH JMP INTLP CONTINUE JSB GCBIM TRANSFER DATA TO AGL DEF RTX DEF .16 GICB DEF .1 DEF INTX1 DEF LNGTH DEF .2 RTX LDA FIRST SEE IF THIS TO GET PLOT UNITS CPA S5 JMP G12CK TAKE CARE OF CASE WHERE GPON(2) CALL JMP DVG01,I * * CHECK TO SEE IF G1 G2 ALREADY INITIALIZED AND IF SO DO NOT CHANGE * G12CK JSB GCBIM DEF RG12 DEF .8 DEF .1 DEF INTX1 DEF .0 DEF .1 RG12 DLD INTX1 SEE IF G1X = 0 SZA,RSS SZB JMP LVG12 LEAVE IT AS IS DLD INTX1+4 SEE IF G2X =0 SZA,RSS SZB JMP LVG12 JMP DVG01,I LVG12 LDB DF8 SET OLD POINTS INTO GCB LDA INX JSB GB JMP DVG01,I * FIXIT LDA INTAD,I JSB FLOAT DST INTAD,I ISZ INTAD ISZ LNTH JMP CONIN SPC 3 CNVRT NOP LDA LNGTH INA STA LNTH JSB GB1 GO GET INTEGERS RTVRT LDA FLTFG IS THIS A FLOATING POINT SITUATION SZA NO THEN VAMOOSE JMP GLIDE GO GLIDE THE NUMBER INSTEAD OF FLOATING IT LDA FIRST GET FIRST CHR. OF CMD STRING AND DETERMINE AND MASK CHECK FOR A P(PLOT,IPLOT,RPLOT,DRAW,OR MOVE) CPA P JMP PACK GO DO SPECIAL DATA FORMATTING JMP CNVRT,I * PACK ISZ NUM LDA FIRST NOW LOOK AT SECOND CHR. OF CMND STRING TO AND .377 ASCERTAIN TYPE OF PLOT(ABSOLUTE,INCREMENTAL OR CPA I RELOCATABLE). JMP PKB ABSOLUTE * ISZ NUM * CPA J INCREMENTAL * JMP CHECK NOW WE MUST DETERMINE IF ITS SHORT INCREMENTAL * ISZ NUM OR LONG INCREMENTAL ( <-16 OR > +15) * JMP PKB RELOCATABLE *HECK LDA MIN2 SET UP TO EXAMINE X AND Y * STA TEMPK * LDB INX POINTER TO INTEGERS *HKLP INB * LDA B,I * SSA,RSS IS IT NEGATIVE? * JMP CHKP NO * ADA .16 * SZA,RSS =0? * JMP CONCK =-16 * SSA <-16 * JMP CHNG * JMP CONCK YES IT IS * *HKP ADA M15 >+15? * SZA,RSS * JMP PKB * SSA,RSS * JMP CHNG *ONCK ISZ TEMP * JMP CHKLP * * GO TO PACKING ROUTINE TO FORMAT X,Y FOR TERMINAL * PKB JSB PKBIN DEF RTPK DEF INTX2 X,Y DEF ADCNT,I I/O BUFFER DEF NBYTE DEF NUM DEF LNGTH RTPK JMP RTCON * *HNG ISZ NUM LONG INCREMENTAL - SO INSERT SMALL K * LDA NBYTE * ADA M1 * STA TEMP * JSB BYTE * DEF RTCHG * DEF TEMP * DEF K LONG INCREMENTAL * DEF FWADR,I *TCHG JMP PKB SKP * * * ERROR CHECKING FOR DEVICE SUBROUTINE = DEVICE COMMAND TABLE * LU = 2648 = DVR05 OR DVR07 * ERRCK JSB GCBIM DEF ERR0 DEF .2 DEF .3 DEF LUN DEF .0 DEF .1 ERR0 JSB SETUP LDA IOBUF STA IOB STA INTIO JSB EMULX,I INTERROGATE DEV. CMD.TABLE CPA .2648 JMP ERR1 OKAY LDA .3 JMP ERRPT REPORT ERROR ERR1 JSB IFTTY DEF *+2 DEF LUN LDA DTYPE CPA M2400 JMP ERR3 CPA M3400 DVR07? JMP ERR3 LDA .5 SOMETHIN SCREWED UP!! JMP ERRPT *RR2 LDA S1 INTERROGATE DEVICE FOR ID * STA FIRST * STA ADCNT,I * ISZ ADCNT * ISZ NBYTE * ISZ NBYTE * LDA Z * JSB TRBYT TERMINATOR * LDA .1 * STA LNGTH * JMP READ+1 * *EVID LDA INTX1 * CPA .2648 * JMP ERR3 OKDOKE = COPESETIC * LDA .5 * JMP ERRPT MESSED UP ERR3 CLA ERRPT STA INTX1 LDA INX LDB DF1 JSB GB JMP DVG01,I SKP SPC 3 * * PROCESS * * SPECIAL INTERNAL UTILITY ROUTINES * TRBYT NOP INSERT TERMINATOR INTO OUTPUT BUFFER STA BITE JSB BYTE DEF RTBYT DEF NBYTE DEF BITE DEF ADCNT,I RTBYT ISZ NBYTE JMP TRBYT,I * BITE NOP * * OUTPT NOP I/O TRANSFER ROUTINE STB RW CMA,INA STA IOCNT LDA LUN STA LUN1 JSB IFTTY FIND OUT WHATS OUT THERE DEF *+2 DEF LUN LDA DTYPE CPA M3400 DVR07 JMP OUT1 YES DO NOT SET BIT 10 (TRANSPARENT MODE FOR DVR05) LDA LUN LDB RW CPB .2 SEE IF READ REQUEST AND IF SO DO NOT SET BIT 10 IOR .200 STA LUN1 OUT1 JSB EXEC DEF RTOUT DEF RW DEF LUN1 IOB NOP DEF IOCNT RTOUT JMP OUTPT,I * .36 DEC 36 .38 DEC 38 LUN1 NOP * * * SKP SPC 3 * * MORE SPECIAL ROUTINES INVOKED THROUGHOUT THIS PROGRAM * SETUP NOP LDA ESCST ESC * STA IOBUF,I ISZ NBYTE BUMP BYTE COUNTER ISZ NBYTE LDA IOBUF INCREMENT IOBUF ADDRESS INA STA FWADR SAVE POINTER STA ADCNT JMP SETUP,I * * GET GRAPHICS LUN * GTGLU NOP JSB GCBIM DEF GTL DEF .2 DEF .3 DEF LUN DEF .0 DEF .1 LUN,IOBUF,IOBL GTL LDA IOBUF SET UP IO BUFFER ADDRESS POINTERS JSB INDCK STA IOBUF STA IOB STA INTIO JMP GTGLU,I * * THESE ARE COMMANDS WHERE THE LENGTH SPECIFICATION * ASSOCIATED WITH THE GIC IS IGNORED. * * IGNOR NOP LDA IGCNT STA NUM LDA IGCOD STA TEMP IGLOP LDA TEMP,I CPA FIRST JMP YES ISZ TEMP ISZ NUM JMP IGLOP JMP IGNOR,I YES CLA STA LNGTH IGNORE LENGTH FROM GICB JMP IGNOR,I * IGCNT DEC -3 IGCOD DEF *+1 OCT 66520 SLANT ON OCT 66517 SLANT OFF OCT 62150 CLEAR-IF CALLED FROM GCLR THERE WILL BE A 1 * SKP * * WRITE DATA TO GICB A= ADRRESS FROM WHENCE DATA IS TO COME * B = NUMBER OF WORDS * GB NOP STA ADDR STB NUMB JSB GCBIM DEF *+6 DEF .16 DEF .1 ADDR NOP NUMB NOP DEF .2 JMP GB,I * GB1 NOP JSB GCBIM RETRIEVE INTEGER VALUES TO BE CONVERTED DEF RTGB DEF .16 CODE FOR GICB DEF .1 DEF INTX1 WHERE TO PUT IT DEF LNTH DEF .1 READ IT MAN RTGB JMP GB1,I * * FINI JSB CONVT CONVERT FROM INTEGER TO ASCII DEF RTCON DEF INTX2 FROM HERE DEF IOB,I I/O BUFFER ADDRESS DEF NBYTE CURRENT NUMBER OF BYTES DEF LNGTH HOW MANY INTEGERS RTCON LDA NBYTE COMPUTE POINTER INTO I/O BUFFER CLE,ERA CALCULATE NBYTE/2 ADA IOBUF STA ADCNT ADDRESS POINTER LDA BUFLG I/O BUFFERING? SZA JMP BF3 YES LDA TERM JSB TRBYT INSERT TERMINATOR LDA NBYTE LDB .2 JSB OUTPT JMP DVG01,I * * * * ROUTINE TO DETERMINE IF THE SPECIFIED LU IS INTERACTIVE * CALLED AS FOLLOWS: * * IFLAG = IFTTY(LU) JSB IFTTY * DEF *+2 * DEF LU * * * * * IFTTY NOP ENTRY DLD IFTTY,I GET RETURN ADDRESS & LU# LDB B,I GET THE LU # STA IFTTY SAVE RETURN ADDRESS STB ANLU# AND LU # * JSB EXEC SEE IF THE LU IS INTERACTIVE DEF *+6 DEF D13I STATUS REQUEST DEF ANLU# THE LU WE WANT THE INFO ABOUT DEF YTEMP EQT WORD 5 PLACED HERE DEF DTYPE EQT WORD 4 PLACED HERE(NOT NEEDED) DEF ZTEMP SUB CHANNEL IN LOWER 5 BIT HERE * JMP ITSNT IT AIN'T EVEN AN LU !!!! LDA YTEMP GET EQT WORD 5 AND MEQT KEEP ONLY THE EQT TYPE FIELD  STA DTYPE JMP IFTTY,I ITSNT CLA SET NON INTERACTIVE FLAG JMP IFTTY,I * * D13I OCT 100015 M2400 OCT 2400 M37 OCT 37 M3400 OCT 3400 MEQT OCT 37400 ANLU# NOP DTYPE NOP YTEMP NOP ZTEMP NOP SKP SPC 3 * * EMULATORS * EMULT STA TEMP JSB GTGLU JSB BUFCK LDA TEMP CMA,INA STA B CLA STA NBYTE LDA EM0 FWA OF EMULATOR POINTERS JSB INDCK ADA B LDA A,I JMP A,I EMUL1 LDA SMLAB ESC*L JSB INDCK STA DCTAD FAKE OUT ISZ FLTFG JMP CONT * * CONVERT THE NUMBER FROM FLOAT(GLIDE) TO ASCII * GLIDE JSB FLTAS DEF RTGLD DEF INTX2 DEF IOBUF,I DEF NBYTE DEF FXDN DEF SKPBK RTGLD JSB UPDTE LDA CR CARRAIGE RETURN JSB TRBYT JSB UPDTE LDA LF LINE FEED JSB TRBYT LDA NBYTE LDB .2 JSB OUTPT JMP DVG01,I * * GET NUMBER OF PENS * EMUL2 LDA DF6 LDB DF1 JSB GB TRANSFER TO GICB JMP DVG01,I * * LINE TYPES * EMUL4 JSB SETUP LDA .4 STA LNTH JSB GB1 PICK UP GICB AND DATA- LINE TYPE AND LENGTH LDA M2 PUT DEVICE INTO DRAWING MODE STA ADCNT,I ISZ ADCNT ISZ NBYTE ISZ NBYTE LDA LB SMALL B JSB TRBYT LDA LT POINTER TO LINE TYPES JSB INDCK ADA INTX2 ADDR(LT) + LT# LDA A,I STA INTX2 DLD INTX2+1 LENGTH FDV D8 CALCULATE SCALE = LENGTH/8MUS JSB .IENT INTEGERIZE NOP LDB .1 SZA,RSS CHECK FOR 0 STB A STA INTX2+1 LDA .2 STA LNGTH LDA C TERMINATOR STA TERM JMP FINI * * LABEL DIRECTION - GICB LOOKS LIKE ( GIC/L),(ANGLE) * THE ANGLE IS IN FLOATING POINT. THE IDEA HERE IS TO * CONVERT THE A`NGLE INTO: * * 1 (0 DEGREES) IF ANGLE IS BETWEEN 315 DEG AND 45 DEG * 2 (90 DEGREES) " " " " 45 " " 135 " * 3 (180 DEGREES) " " " " 135 " " 225 " * 4 (270 " ) " " " " 225 " " 360 " * * EMUL5 JSB SETUP LDA .3 STA LNTH JSB GB1 GET GICB LDA M MAKE IOBUF = ESC*LITTLE "M" JSB TRBYT CLA,INA LDIR = 1 STA LDIR DLD INTX2 NOW SEE IF THETA = 0 DEGREES SZA JMP EML51 SZB,RSS JMP EM5FN IT 0 EML51 LDA DEGPT POINTER TO ANGLE CONSTANTS IN RADIANS(DEG/57.3) STA TEMP EM5LP DLD TEMP,I FSB INTX2 C(DEGPT) - ANGLE SSA,RSS JMP EM5FN ANGLE < C(DEGPT) ISZ TEMP ANGLE > C(DEGPT) ISZ TEMP ISZ LDIR LDA LDIR CHECK FOR 360 CPA .5 JMP *+2 JMP EM5LP CLA,INA STA LDIR EM5FN LDA LDIR STA INTX2 LDA .1 STA LNGTH SET UP FOR CONVERSION TO ASCII LDA BIGN STA TERM JMP FINI * * NECESSARY CONSTANTS * LDIR NOP BIGN OCT 116 DEGPT DEF *+1 DEC .785 45 DEGREES DEC 2.355 135 DEG DEC 3.925 225 DEG DEC 5.455 315 DEG DEC 6.28 360 DEG * SPC 3 * * CHARACTER SIZE * EMUL6 JSB SETUP LDA .5 STA LNTH JSB GB1 GET GICB AND DATA LDA M JSB TRBYT DLD INTX2+2 FDV D10 COMPUTE SIZE = HEIGHT/10MUS JSB .IENT INTEGERIZE NOP LDB .1 SZA,RSS CHECK FOR 0 STB A STA INTX2 STB LNGTH LDA BIGM STA TERM JMP FINI * * GET DISPLAY SURFACE SIZE IN MILLIMETERS * EMUL9 LDA MMSIZ LDB DF8 8 WORDS JSB GB GO PUT IN GICB JMP DVG01,I * MMSIZ DEF *+1 DEC 0. DEC 0. DEC 239.6 LENGTH DEC 120. WIDTH * * Q DEFAULT LINE TYPE * EML10 JSB SETUP LDA MODE2 SET MODE STA ADCNT,I ISZ ADCNT LDA ATERM TERMINATOR A STA ADCNT,I LDA .5 LDB .2 JSB OUTPT LDA .2 STA LNTH JSB GB1 GET THE CONTENTS OF GICB LDA DFLT ADDRESS TO TOL FOR LINE TYPE NUMBERS JSB INDCK ADA INTX2 NUMBER FROM AGL LDA A,I GET 2648 EQUIVALENCE STA INTX2 LDA INX TRANSFER DATA BACK TO GICB LDB DF4 JSB GB LDA LNTYP FAKE OUT STA DCTAD JMP CONT GO PROCESS * * GET MU/MM * EML11 LDA DFD3 LDB DF4 JSB GB JMP DVG01,I * * FLUSH I/O BUFFER * EML12 JMP DVG01,I * * DEVICE CLEARING CHARACTERISTICS (TRUE CLEAR BIT 4=1) * EML13 LDA DF4 LDB DF1 JSB GB JMP DVG01,I * * NUMBER OF PHYSICALLY DIFFERENT PENS * EML14 LDA DF1 ONE PEN LDB DF1 JSB GB JMP DVG01,I * * NUMBER OF CURSORS * EML15 JMP EML14 * * LORGABILITY * EML16 JMP EML14 * *MAXIMUM CHARACTER SLANT * EML17 LDA DSLNT LDB DF4 JSB GB JMP DVG01,I * * DEVICE HARD CLIPPING CAPABILITY * EML18 LDA DF0 LDB DF1 JSB GB JMP DVG01,I * SPC 2 * SPC 2 * * MIN/MAX CHARACTER SIZES * EML19 LDA MMCSZ LDB DF9 JSB GB JMP DVG01,I * * LABEL DIRECTION CAPABILITY * EML20 LDA LBLDR LDB DF3 JSB GB JMP DVG01,I * * DEVICE ID * EML21 LDA ID26 LDB DF3 JSB GB JMP DVG01,I * ID26 DEF *+1 ASC 3,2648A JMP DVG01,I * * LORG RANGE * EML22 LDA DFL1 LDB DF2 JSB GB JMP DVG01,I * DFL1 DEF *+1 OCT 1 DEC 9 SKP *CONSTANTS * * LINE TYPE EQUIVALENCY TABLE * DFLT DEF *+1 OCT 1 OCT 7 OCT 6 OCT 5 OCT 4 q DEC 11 DEC 10 * * LINE TYPE COMMAND * LNTYP DEF *+1 DEC -1 DEF BB OCT 66400 "M BB OCT 102 * *POINTERS CONSTANTS ETC FOR EMULATORS * EM0 DEF * DEF EMUL1 DEF EMUL2 NOP DEF EMUL4 DEF EMUL5 DEF EMUL6 NOP NOP DEF EMUL9 DEF EML10 DEF EML11 DEF EML12 DEF EML13 DEF EML14 DEF EML15 DEF EML16 DEF EML17 DEF EML18 DEF EML19 DEF EML20 DEF EML21 DEF EML22 * *LINE TYPES * LT DEF *+1 LT0 DEC 255 SOLID JACK!! LT1 DEC 170 DIMLY LIT LT2 DEC 224 DASHED LT3 DEC 254 LONG DASH LT4 DEC 235 CENTERLINE LT5 DEC 129 DOTS LT6 DEC 234 OPTIONAL C OCT 103 M OCT 155 D8 DEC 8.0 D10 DEC 10.0 BIGM OCT 115 LB OCT 142 "B M2 OCT 66462 "M2 LBLDR DEF *+1 OCT 1 DEC 1.57 * MMCSZ DEF *+1 DEC 7. DEC 10. DEC 56. DEC 80. OCT 0 * DF9 DEF .9 DF3 DEF .3 * SKP SPC 3 * * THIS PORTION OF THE DRIVER IS RESPONSIBLE FOR BUFFERING * PLOT COMMANDS (ESC*PX) SO THAT THE 2648A WILL OPERATE AT * ITS NORMAL VECTOR DRAWING SPEED. * BUFCK NOP JSB GRSTS CHECK STATUS TO SEE IF BUFFERING IS IN EFFECT DEF BFRTN DEF .1 GET STATUS DEF .1000 BIT 9 DEF BFTMP BFRTN LDA BFTMP SZA,RSS I/O BUFFERING? JMP BUFCK,I NO LDA LNGTH ALS STA BTEMP LDA DF1 JSB GB2 RETRIEVE CURRENT BUFFER LENGTH LDA RWFLG 0= READ,1= WRITE,3=EMULATOR CPA .1 JMP BF1 JMP EMPCK GO EMPTY BUFFER BF1 LDA FIRST SEE IF A PLOT COMMAND AND MASK CPA P JMP BF2 YES CONTINUE JMP EMPCK MODE CHANGE BF2 LDA GIC SEE IF "HOME PEN" CPA .5 JMP BUmoFCK,I YES GET OUT ISZ BUFLG SET FLAG TO INDICATE BUFFERING IN PROGRESS BF20 LDB BUFLN SEE IF CURRENT BUFFER LENGTH + NEW STUFF>IOBL STB NBYTE JSB UPDTE SZB IF ZERO STARTING A NEW STRING JMP BF2A JSB SETUP SET ESC* INTO I/O BUFFER LDA LP JSB TRBYT PREAMBLE PLOT COMMAND JSB UPDTE LDB NBYTE BF2A ADB .4 FOR GOOD MEASURE ADB BTEMP CLE,ERB CMB,INB ADB IOBL SSB JMP EMPCK FILLED TO THE TOP LDA FIRST EXTRACT SECOND BYTE OF PLOT COMMAND AND .377 IOR .32 INSURE LOWER CASE ASCII JSB TRBYT GO STORE IN IOBUF JSB UPDTE LDA LNGTH ANY INTEGERS TO CONVERT TO ASCII SZA,RSS JMP BF3 NO JSB CNVRT BF3 LDA NBYTE UPDATE BUFFER LENGTH STA BUFLN LDA DF2 JSB GB2 JMP DVG01,I * EMPCK LDB BUFLN SZB,RSS ANYTHING IN BUFFER JMP BUFCK,I NO-SO FORGET IT. LDA NBYTE STA BFTMP SAVE BYTE COUNT FOR NEW COMMAND. STB NBYTE JSB UPDTE LDA Z JSB TRBYT LDA NBYTE LDB .2 JSB OUTPT CLA STA BUFLN LDA BFTMP STA NBYTE LDA DF2 JSB GB2 LDA BUFLG SZA,RSS JMP BUFCK,I JMP BF20 * * RETRIEVE AND RESTORE CURRENT BUFFER BYTE COUNT * GB2 NOP STA GBRW JSB GCBIM DEF *+6 DEF .32 DEF .1 DEF BUFLN DEF .0 GBRW NOP JMP GB2,I * UPDTE NOP LDA NBYTE CLE,ERA ADA IOBUF STA ADCNT STA FWADR JMP UPDTE,I SKP SPC 3 * * CONSTANTS AND TEMPORARY STORAGE * A EQU 0 B EQU 1 NBYTE NOP TEMP NOP NWORD NOP BTEMP NOP LUN NOP IOBUF NOP IOBL NOP FXDN NOP FIRST NOP FWADR NOP INTX1 NOP INTX2 BSS 3 XMU NOP INTXX BSS 11 RW NOP IOGzHFBCNT NOP * DO NO CHANGE POSITION OF THESE CONSTANTS .0 OCT 0 .1 OCT 1 .2 OCT 2 .4 OCT 4 .26 DEC 26 .3 OCT 3 .16 DEC 16 .20 DEC 20 .200 OCT 2000 .77 OCT 77 .25 DEC 25 BFLSH OCT 2300 .1000 OCT 1000 S5 OCT 71465 S7 OCT 71467 S3 OCT 71463 .40 DEC 40 INX DEF INTX1 TERM NOP .377 OCT 377 .5 OCT 5 NUM NOP M16 DEC -16 M15 DEC -15 MASK OCT 177400 Z OCT 132 P OCT 70000 LP OCT 160 ESCST OCT 15452 ESC* I OCT 151 J OCT 152 ADCNT NOP IBYTE NOP RWFLG NOP ODFLG NOP LNTH NOP DF1 DEF .1 DF4 DEF .4 DF6 DEF .6 .6 OCT 6 .9 DEC 9 .137 OCT 137 S1 OCT 71461 CR OCT 15 LF OCT 12 DF2 DEF .2 .32 DEC 32 BUFLN NOP BFTMP NOP BUFLG NOP DFD3 DEF D3 D3 DEC 3. DEC 3. M1 OCT -1 MIN2 OCT -2 SKPBK NOP FLTFG NOP M4 OCT -4 K OCT 153 SMALL K DSLNT DEF .45DG .45DG DEC .785 DEC 0. DF0 DEF .0 DF8 DEF .8 .8 DEC 8 MODE2 OCT 66462 ATERM OCT 60400 .177 OCT 177 .2648 DEC 2648 END KH Rc 92840-18084 1819 S C0122 2648A CMND TABLE              H0101 ASMB,R,L * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: DCT01-2648A DEVICE COMMAND TABLE * SOURCE: 92840 - 18084 * RELOC: 92840 - 16003 * * * ************************************************************* * NAM DCT01 92840-16003 REV.1819 780515 ENT DCT01 ENT SMLAB * * THIS IS THE DEVICE COMMAND TABLE FOR THE 2648A GRAPHICS * TERMINAL. * ********************************************************** * * COMMAND LINK TABLE (CLTBL) * SPC 3 DCT01 NOP DEF EML01 DEF RESET NOP DO NOTHING DEF CLEAR DEC -12 XMIT DEF HOME HOME PEN DEC -21 NOP DEF PLTUN GET PLOT UNITS DEF PLTCH GET CHARACTER SIZE INFORMATION DEF PNLOC GET PEN LOCATION DEF CURSR GET CURSOR LOCATION DEF DIGIT DIGITIZE DEF LORG LABEL ORIGIN DEC -5 LABEL DIRECTION DEF SLNT1 SLANT ON DEF SLNT0 SLANT OFF DEC -6 CHARACTER SIZE DEF PORG PLOT ORIGIN DEC -7 DEC -8 DEF CRORG CURSOR ORIGIN DEF PNORG PEN = ORIGIN DEF DRWCR DRAW TO CURSOR NOP DEF SLPN0 SELECT PEN 0 DEF SLPN1 PEN= -1(ERASE) DEF SLPN3 PEN = -2 (COMPLEMENT) DEC -10 PEN 1-N DEC -2 GET # PENS DEC -3 DEC -10 DEFAULT LINE TYPE DEC -4 LINE TYPE WITH LENGTH DEF PENUP DEF PENDN DEF PLTAB PLOT ABSOLUTE DEF PLTRL PLOT RELOCATABLE DEF PLTIN PLOT INCREMENTAL SM)LAB DEF SHRTL SHORT LABEL DEF LGLAB START LONG LABEL DEF STPLB STOP LONG LABEL DEC -1 DEC -9 DEF CRABS POSITION CURSOR ABSOLUTE DEF CRREL " " RELATIVE NOP DEC -11 GET MU/MM DEC -13 DEVICE CLEARING CHARACTERISTICS DEC -14 # OF PHYSICALLY DIFFERENT PENS DEC -15 # OF CURSORS DEC -16 LORGABILITY DEC -17 MAX-CHAR SLANT DEC -18 HARD CLIPPING CAPABILITY NOP DEC -19 MIN/MAX CHARACTER SIZES DEC -20 LABEL DIRECTIONS DEC -22 LORG RANGE * * SPC 3 SKP SPC 3 * * ASCII COMMAND STRINGS * * FORMAT: WORD1 = NUMBER OF BYTES (N) WHERE * -N INDICATES A WRITE TO DEVICE * +N INDICATES A READ AFTER WRITE * WORD2 = NOP TERMINATOR WITHIN COMMAND STRING * DEF TERM - TERMINATOR AT ADDRESS TERM * WORD3 = FIRST WORD OF COMMAND STRING * ************************************************************** SPC 3 RESET DEC -2 NOP OCT 66522 "MR ("CHARACTER =LOWER CASE) * HOME DEC -6 NOP OCT 70141 "P"A OCT 64440 "I0 OCT 20132 0Z * PLTUN DEC 3 READ PLOT UNITS NOP OCT 71465 "S5 ASC 1,Z * PLTCH DEC 3 NOP OCT 71467 "S7 ASC 1,Z * PNLOC DEC 3 NOP OCT 71462 "S2 ASC 1,Z * CURSR DEC 3 NOP OCT 71463 "S3 ASC 1,Z * DIGIT DEC 3 NOP OCT 71464 ASC 1,Z * SLPN0 DEC -3 NOP OCT 66460 "M0 ASC 1,A SLPN1 DEC -3 NOP OCT 66461 "M1 ASC 1,A SLPN2 DEC -3 NOP OCT 66462 "M2 ASC 1,A SLPN3 DEC -3 NOP OCT 66463 "M3 ASC 1,A SLPN4 DEC -3 bD DEF B OCT 66462 "M 2 OCT 60400 "A * DEFLN DEC 1 DEF C OCT 66400 "M PENDN DEC -2 NOP OCT 70102 "PB * PENUP DEC -2 NOP OCT 70101 "PA * PLTAB DEC -2 DEF Z OCT 70151 "P"I * PLTRL DEC -2 DEF Z OCT 70154 "P"L * PLTIN DEC -2 DEF Z OCT 70152 * CLEAR DEC -3 NOP OCT 62150 "D"H ASC 1,A * SHRTL DEC -1 DEF BLANK OCT 66000 "L * LGLAB DEC -2 NOP OCT 62123 "DS * STPLB DEC -2 NOP OCT 62124 "DT * DRWCR DEC -2 NOP OCT 70103 "PC * LORG DEC -1 DEF Q OCT 66400 "M * SLNT1 DEC -2 NOP OCT 66517 "MO * SLNT0 DEC -2 NOP OCT 66520 "MP * PORG DEC -1 DEF J OCT 66400 * CRORG DEC -2 NOP OCT 66514 "ML * PNORG DEC -2 NOP OCT 66513 "MK * CRABS DEC -1 DEF O OCT 62000 * CRREL DEC -1 DEF P OCT 62000 * DEVID DEC 3 NOP OCT 71461 "S1 ASC 1,Z SPC 3 * * ERROR CHECKING * EML01 NOP LDA .2648 JMP EML01,I .2648 DEC 2648 * * TERMINATORS * A OCT 101 BLANK OCT 40 B OCT 102 C OCT 103 J OCT 112 O OCT 117 P OCT 120 S OCT 123 T OCT 124 Q OCT 121 Z OCT 132 * END ) S[ 92840-18085 1819 S C0122 7245 9872 D.SUB              H0101 ASMB,R,L * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: DEVICE SUBROUTINE FOR 9872 AND 7245 * SOURCE: 92840 - 18085 * RELOC: 92840 - 16004 * * * ************************************************************* * NAM DVG02,7 92840-16004 REV. 1819 780515 EXT EXEC,GCBIM,BYTE EXT .IENT EXT FLOAT EXT EMULX EXT INDCK EXT INTX EXT DCTIM EXT CONVT EXT LNGTH,GIC,DCTAD EXT GRSTS ENT DVG02 ENT DVG03 * * THIS IS THE DEVICE SUBROUTINE FOR THE HP 9872A HARD COPY * PLOTTER. THIS ROUTINE ALONG WITH DVR37 CONTROL THE * PICTURE DRAWING ON THE PLOTTER. * DVG03 EQU * DVG02 NOP CLA INITIALIZE THE READ/WRITE FLAG AND BYTE COUNTER STA RWFLG COUNTER STA FIN STA NBYTE STA IBYTE LDA SEMCL SEMICOLON - TERMINATOR STA TERM JSB DCTIM FILL UP GIC, LENGTH AND DEVICE COMMAND ADDR.(DCTAD) LDA GIC CPA .177 JMP ERRCK JSB SETUP CONT LDA DCTAD SEE WHAT TYPE OF COMMAND THIS IS SSA EMULATOR? JMP EMULT YES SZA,RSS A NOP? JMP DVG02,I DO NOTHING A'TALL AND RETURN LDB DCTAD A COMMAND ADDRESS LDA B,I SSA,RSS READ OR WRITE? JMP CONT0 READ ISZ RWFLG WRITE CMA,INA SET BYTE COUNT POSITIVE CONT0 STA NBYTE AND .1 COMPUTE NWORD = NBYTE/2 + REMAINDER STA NWORD STA ODFLG = 0 IF EVEN, AND 1 IF ODD LDA NBYTE CLE,ERA NBYTE/2 ADA NWORD CMA,INA vh STA NWORD INB LDA B,I LDA A,I TERMINATOR STA TERM INB LDA B,I STA FIRST SAVE FIRST WORD OF COMMAND STRING STB DCTAD NOW POINT TO FIRST WORD OF COMMAND STRING XFER LDA DCTAD,I NOW TRANSFER COMMAND STRING TO THE I/O BUFFER STA ADCNT,I ISZ NWORD JMP CONT2 JMP XEND FINISHED CONT2 ISZ DCTAD ISZ ADCNT INCREMENT ADDRESS POINTERS JMP XFER CONTINUE XEND LDA ODFLG SZA,RSS ISZ ADCNT LDA RWFLG READ OR WRITE? SZA,RSS JMP READ LDA LNGTH WRITE - NOW SEE IF ANY INTEGERS TO CONVERT TO ASCII SZA THIS IS LENGTH FROM GICB JMP CNVRT YES GO CVONVERT TO ASCII JSB TRBYT GO INSERT TERMINATOR LDA NBYTE NUMBER OF BYTES LDB .2 WRITE JSB OUTPT EXEC I/O JMP DVG02,I GO HOME BABY * * SPC 3 * * PROCESS READ REQUEST. FIRST A WRITE MUST BE DONE TO * OUTPUT THE COMMAND CODE, AND THEN A READ MUST BE DONE TO * THE DEVICE INTO THE TALK MODE TO GET THE STATUS DATA. * READ NOP JSB TRBYT FIRST INSERT TERMINATOR LDA NBYTE LDB .2 JSB OUTPT OUTPUT STATUS REQUEST COMMAND LDA M19 FILL BUFFER WITH BLANKS STA CNTR LDA IOBUF STA BACNT BLOOP LDA BLNK STA BACNT,I ISZ BACNT ISZ CNTR JMP BLOOP LDB .1 NOW PUT DEVICE INTO TALK MODE LDA .40 TO GET DATA JSB OUTPT JSB INTEG GO CONVERT FROM ASCII TO INTEGER JSB GB2 TRANSFER RESULTS TO GICB JMP DVG02,I SPC 3 CNVRT LDA LNGTH INA STA LNTH JSB GB1 RETRIVE INTEGER VALUES JMP FINI SKP * * SPECIAL INTERNAL UTILITY ROUTINES * SETUP NOP JSB GCBIM RETRIEVE IOBUF ADDRESS AND IOBL FROM THE GCB DEF CONT1 DEF .2 CODE IN IGTBL, FOR IOBUF,IOBgL,AND LUN DEF .3 TWO CODES DEF LUN DEF .0 THREE WORDS DEF .1 READ CONT1 LDA IOBUF JSB INDCK STA IOBUF STA IOB STA ADCNT INITIALIZE ADDRESS COUNTER STA INTIO * * NOW CHECK BIT 4 OF STATUS WORD TO SEE IF A SHORT LABEL WAS * PREVIOUSLY EMITTED - IF SO EMIT LABEL TERMINATOR AND RESET BIT 4 * JSB GRSTS DEF *+4 DEF .1 DEF BIT4 DEF TEMP LDA TEMP SZA,RSS BIT SET ? JMP SETUP,I NO LDA ETX TERMINATOR DECIMAL 3 STA IOBUF,I ISZ NBYTE LDA .1 LDB .2 JSB OUTPT JSB GRSTS RESET BIT 4 DEF *+4 DEF .2 DEF MASK4 DEF .0 CLA STA NBYTE LDA IOBUF STA ADCNT JMP SETUP,I * * CONVERT INCOMING DATA FROM ASCII TO INTEGER * INTEG NOP LDA LNGTH SET TO CONVERT FROM ASCII TO INTEGER CMA,INA STA LNTH CLA STA IBYTE LDA INX STA INTAD INTLP JSB INTX BEGIN TO CONVERT DATA DEF RTINT INTIO NOP INTAD NOP DEF IBYTE RTINT LDA FIRST SEE IF WE ARE RETRIEVING PLOT UNITS CPA OP JMP FIXIT YES CPA OF JMP FIXIT CONIN ISZ INTAD ISZ LNTH JMP INTLP CONTINUE JMP INTEG,I FIXIT LDA INTAD,I CONVERT INTEGER TO FLOATING POINT JSB FLOAT DST INTAD,I ISZ INTAD ISZ LNTH JMP CONIN CONTINUE * * TAKE VALUES PLACED IN INTX1(1) TO INTX1(LNGTH) AND TRANSFER * THIS DATA TO GICB. * GB2 NOP JSB GCBIM TRANSFER DATA TO AGL DEF RTX DEF .16 DEF .1 DEF INTX1 DEF LNGTH DEF .2 RTX JMP GB2,I * * RETRIEVE DATA FROM GICB AND PLACE IT IN INTX1(1) TO INTX1(LNTH) * GB1 NOP JSB GCBIM RETRIEVE INTEGER VALUES FROM DEF RTGB1 GCB DEF .16 GICB DEF .1  DEF INTX1 DEF LNTH DEF .1 RTGB1 JMP GB1,I * * FINI DOES THE FOLLOWING: * 1. CONVERTS INTEGERS TO ASCII * 2. TRANSFERS THIS ASCII TO THE DEVICE (VIA OUTPT). * 3. RETURNS TO CALLER * FIN NOP FINI JSB CONVT DEF RTCON DEF INTX2 FWA FOR INTEGERS TO BE CONVERTED DEF IOBUF,I I O BUFFER DEF NBYTE DEF LNGTH RTCON JSB TRBYT INSERT TERMINATOR LDA NBYTE LDB .2 JSB OUTPT LDA FIN SZA,RSS JMP DVG02,I JMP FIN,I * * EXIT DVG02 AND SET MODE TO LABEL IF NOT ALREADY SET * SKP SPC 3 * * TRBYT NOP INSERT TERMINATOR INTO OUTPUT BUFFER LDA TERM SEMI-COLON JSB PTBYT JMP TRBYT,I * PTBYT NOP STA BITE JSB UPDTE UPDATE ADDRESS COUNTER (ADCNT) JSB BYTE DEF RTBYT DEF NBYTE DEF BITE DEF ADCNT,I RTBYT ISZ NBYTE JSB UPDTE JMP PTBYT,I * * UPDTE NOP LDA NBYTE CLE,ERA ADA IOBUF STA ADCNT JMP UPDTE,I * * BITE NOP * OUTPT NOP I/O TRANSFER ROUTINE STB RW LDB TERM CPB .137 JMP *+2 INA CMA,INA STA IOCNT BYTE COUNTER FOR OUTPUT LDA .137 JSB PTBYT SUPRESS CRLF JSB EXEC DEF RTOUT DEF RW DEF LUN IOB NOP DEF IOCNT RTOUT JMP OUTPT,I * * * * * ERRCK JSB SETUP * JSB EXEC SEE IF THE LU IS INTERACTIVE DEF *+6 DEF D13I STATUS REQUEST DEF LUN THE LU WE WANT THE INFO ABOUT DEF YTEMP EQT WORD 5 PLACED HERE DEF DTYPE EQT WORD 4 PLACED HERE(NOT NEEDED) DEF ZTEMP SUB CHANNEL IN LOWER 5 BIT HERE * JMP ITSNT IT AIN'T EVEN AN LU !!!! LDA YTEMP GET EQT WORD 5 AND MEQT KEEP ONLY THE EQT TYPE FIELD LDB A AND SAVE IT LDA ZTEMP GET THE SUBCHANNEL BoITS AND M37 STA ZTEMP ADA B CONFIGURE B REGISTER RETURN WORD STA DTYPE CPB M1740 IF DVR 05 THEN JMP ERR1 DO ONE MORE CHECK FOR SUB CHANNEL ITSNT LDA .5 JMP ERRPT ERR1 JSB EMULX,I NOW ASK DEVICE COMMAND TABLE ABOUT ITSELF CPA .9872 JMP ERR2 CPA .7245 JMP ERR2 CPA .3 JMP ERR3 SOMETHING IS VERY WRONG CPA .5 JMP ERR3 LDA .3 JMP ERR3 ERR2 CLA ERR3 STA INTX1 LDA .1 STA LNGTH JSB GB2 LDA INTX1 SZA JMP DVG02,I JSB EXEC DEVICE CLEAR DEF *+3 DEF .3 DEF LUN JMP DVG02,I ERRPT LDA .5 JMP ERR3 * * .9872 DEC 9872 .7245 DEC 7245 .177 OCT 177 * * D13I OCT 100015 M1740 OCT 17400 M37 OCT 37 MEQT OCT 37400 ANLU# NOP DTYPE NOP YTEMP NOP ZTEMP NOP * * SPC 3 EMULT JSB EMULX,I JMP DVG02,I A EQU 0 B EQU 1 NBYTE NOP NWORD NOP LUN NOP IOBUF NOP IOBL NOP FXDN NOP FIRST NOP INTX1 NOP INTX2 NOP INTX3 NOP INTX4 NOP INTXX BSS 8 RW NOP IOCNT NOP * DO NO CHANGE POSITION OF THESE CONSTANTS .0 OCT 0 .1 OCT 1 .2 OCT 2 .4 OCT 4 .26 DEC 26 .3 OCT 3 .16 DEC 16 .20 DEC 20 .40 DEC 40 .5 OCT 5 INX DEF INTX1 INX1 DEF INTX4 .21 DEC 21 .7 DEC 7 TERM NOP ETX OCT 1400 BIT4 OCT 20 TEMP NOP MASK4 OCT 77757 SEMCL OCT 73 DF7 DEF .7 .600 OCT 6000 .137 OCT 137 ADCNT NOP IBYTE NOP RWFLG NOP ODFLG NOP LNTH NOP SKPBK NOP OP ASC 1,OP OF ASC 1,OF M19 DEC -19 BACNT NOP CNTR NOP BLNK OCT 20040 END  T ^ 92840-18086 1819 S C0122 9872 CMND TABLE              H0101 ASMB,R,L,C * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: 9872A- DEVICE COMMAND TABLE * SOURCE: 92840 - 18085 * RELOC: 92840 - 16005 * * * ************************************************************* * NAM DCT02,7 92840-16005 REV.1819 780515 ENT DCT02 * EXT EXEC,TAN,COS,SIN,FLOAT,.IENT EXT ABS EXT FLTAS EXT CONVT EXT LNGTH,GIC,DCTAD EXT GCBIM,INTX,BYTE,INDCK * THIS IS THE DEVICE COMMAND TABLE FOR THE 9872A HARD COPY * PLOTTER. * * * COMMAND LINK TABLE (CLTBL) * SPC 3 DCT02 NOP DEF EML02 DEF RESET RESET PLOTTER DEF DEFLT DEFAULT P1,P2 DEF CLEAR CLEAR SCREEN NOP FLUCH DEF HOME HOME PEN DEC -19 DEVICE ID NOP DEF PLTUN GET PLOT UNITS OCT -1 " (GET CHARACTER INFORMATION) DEF PNLOC GET PEN LOCATION DEF PNLOC CURSOR DEC -4 DIGITIZE NOP LORG DEC -7 LDIR DEC -8 SLANT ON DEF SLOFF SLANT OFF DEC -9 CHAR. SIZE DEC -13 SET RELATIVE ORIGIN BSS 6 NOPS DEF SELPN SELECT PEN 0(RETURN TO HOLDER) NOP PEN = -1 NOP PEN = -2 DEF SELPN PEN = 1-N DEC -5 GET NUMBER OF PENS DEC -6 DEFINE LINE TYPE DEC -10 LINE TYPE DEC -10 LINE TYPE WITH LENGTH DEF PENUP DEF PENDN DEF PLTAB DEC -2 PLOT RELOCATABLE DEF PLTIN DEF LGLAB SHORT ~LABEL DEF LGLAB LABEL MODE DEF STPLB LABEL MODE TERMINATOR DEC -3 FLT TO ASCII DEC -11 DISPLAY SURFACE SIZE IN MM NOP NOP DEC -24 SET P1,P2 DEC -12 GET MU/MM DEC -14 GET DEVICE CLEARING CHARACTERISTICS DEC -15 NUMBER OF PHYSICALLY DIFFERENT PENS DEC -20 # OF CURSORS DEC -16 LORGABILITY DEC -17 MAX. CHARACTER SLANT DEC -18 HARD CLIPPING CAPABILITY NOP DEC -21 DEC -22 DEC -23 * * * ASCII COMMAND STRINGS * SPC 3 RESET DEC -2 6 BYTES, WRITE DEF SEMCL ASC 1,DF COMMAND STRING * DEFLT DEC -5 DEF SEMCL ASC 3,IP;IW * CLEAR DEC -19 DEF SEMCL ASC 11,PU;IW;PA15720,10380 HOME DEC -16 DEF SEMCL ASC 8,PU;PA15720,10380 * PLTUN DEC 2 DEF SEMCL ASC 1,OP PNLOC DEC 2 DEF SEMCL ASC 1,OC * LNTYP DEC -2 DEF SEMCL ASC 1,LT * PENDN DEC -2 DEF SEMCL ASC 1,PD * PENUP DEC -2 DEF SEMCL ASC 1,PU * PLTAB DEC -2 DEF SEMCL PA ASC 1,PA * PLTIN DEC -2 PLOT INCREMENTAL DEF SEMCL ASC 1,PR * SELPN DEC -2 DEF SEMCL ASC 1,SP LGLAB DEC -2 DEF HT LB ASC 1,LB STPLB DEC -1 DEF HT OCT 1400 DECIMAL 3 * SLOFF DEC -2 DEF SEMCL ASC 1,SL STP12 DEC -2 DEF SEMCL ASC 1,IW * * SEMCL OCT 73 HT OCT 137 .3 OCT 3 * SKP * SPC 3 * * UTILITY ROUTINES FOR EMULATORS * SETUP NOP JSB GCBIM RETRIEVE IOBUF ADDRESS AND IOBL FROM THE GCB DEF CONT1 DEF .2 CODE IN IGTBL, FOR IOBUF,IOBL,AND LUN DEF .3 TWO CODES DEF LUN DEF .0 THREE WORDS DEF .1 READ CONT1 LDA IOBUF JSB INDCK STA IOBUF STA IOB STA ADKYCNT INITIALIZE ADDRESS COUNTER STA INTIO LDA SEMCL TERMINATOR STA TERM CLA STA NBYTE BYTE COUNTER STA IBYTE * JMP SETUP,I * * CONVERT INCOMING DATA FROM ASCII TO INTEGER * INTEG NOP LDA LNGTH SET TO CONVERT FROM ASCII TO INTEGER CMA,INA STA LNTH CLA STA IBYTE LDA INX STA INTAD INTLP JSB INTX BEGIN TO CONVERT DATA DEF RTINT INTIO NOP INTAD NOP DEF IBYTE RTINT LDA FIRST SEE IF WE ARE RETRIEVING PLOT UNITS CPA OP JMP FIXIT YES CONIN ISZ INTAD ISZ LNTH JMP INTLP CONTINUE JMP INTEG,I FIXIT LDA INTAD,I CONVERT INTEGER TO FLOATING POINT JSB FLOAT DST INTAD,I ISZ INTAD ISZ LNTH JMP CONIN CONTINUE * * TAKE VALUES PLACED IN INTX1(1) TO INTX1(LNGTH) AND TRANSFER * THIS DATA TO GICB. * GB2 NOP STA GCBCD JSB GCBIM TRANSFER DATA TO AGL DEF RTX DEF GCBCD DEF .1 DEF INTX1 DEF LNGTH DEF .2 RTX JMP GB2,I * * RETRIEVE DATA FROM GICB AND PLACE IT IN INTX1(1) TO INTX1(LNTH) * GB1 NOP STA GCBCD GCB POINTER JSB GCBIM RETRIEVE INTEGER VALUES FROM DEF RTGB1 GCB DEF GCBCD DEF .1 DEF INTX1 DEF LNTH DEF .1 RTGB1 JMP GB1,I * * FINI DOES THE FOLLOWING: * 1. CONVERTS INTEGERS TO ASCII * 2. TRANSFERS THIS ASCII TO THE DEVICE (VIA OUTPT). * 3. RETURNS TO CALLER * FIN NOP FINI JSB CONVT DEF RTCON DEF INTX2 FWA FOR INTEGERS TO BE CONVERTED DEF IOBUF,I I O BUFFER DEF NBYTE DEF LNGTH RTCON JSB TRBYT INSERT TERMINATOR LDA NBYTE LDB .2 JSB OUTPT JMP FIN,I * * EXIT DVG02 AND SET MODE TO LABEL IF NOT ALREADY SET * SPC 3 SPC 3 * * TRBYT NOP INSERT TERMINATOR INTO OUTPUT BUFFER9 LDA TERM SEMI-COLON JSB PTBYT JMP TRBYT,I * PTBYT NOP STA BITE JSB UPDTE UPDATE ADDRESS COUNTER (ADCNT) JSB BYTE DEF RTBYT DEF NBYTE DEF BITE DEF ADCNT,I RTBYT ISZ NBYTE JSB UPDTE JMP PTBYT,I * * UPDTE NOP LDA NBYTE CLE,ERA ADA IOBUF STA ADCNT JMP UPDTE,I * * BITE NOP * OUTPT NOP I/O TRANSFER ROUTINE CMA,INA STA IOCNT BYTE COUNTER FOR OUTPUT STB RW JSB EXEC DEF RTOUT DEF RW DEF LUN IOB NOP DEF IOCNT RTOUT JMP OUTPT,I * * SKP SPC 3 * * EMULATORS * EML02 NOP JSB SETUP GO GET IOBUF,IOBL,LUN AND FXD N LDA GIC CPA .177 JMP ERRCK LDA DCTAD EMULATOR NUMBER (NEGATIVE) CMA,INA STA B LDA EM0 TOP OF LIST OF EMULATORS AND OTHER THINGS. JSB INDCK GET RID OF INDIRECT BIT ADA B COMPUTE POINTER LDB LNGTH INB STB LNTH LDA A,I JMP A,I * EM0 DEF * DEF EMUL1 DEF EMUL2 DEF EMUL3 DEF EMUL4 DEF EMUL5 NOP DEFINE LINE TYPE DEF EMUL7 DEF EMUL8 DEF EMUL9 DEF EML10 DEF EML11 DEF EML12 DEF EML13 DEF EML14 DEF EML15 DEF EML16 DEF EML17 DEF EML18 DEF EML19 DEF EML20 DEF EML21 DEF EML22 DEF EML23 DEF EML24 * SKP SPC 2 * * CHARACTER SPACING INFORMATION * EMUL1 LDA .7 JSB GB1 GET CURRENT CHARACTER SIZE LDA .16 JSB GB2 JMP EML02,I * * * DEFAULT VALUES = WIDTH * 1.5 * 400 MU MM * HEIGHT * 2. * 400MU/MM * * CHRW DEC 171. CHRH DEC 300. CHW DEC 2.4 .004 * 600 DEC 4.0 .005 * 800 DEC 15720. DEC 10380. X OCT 0 D1.5 DEC 1.5 D2.0 DEC 2.0 SPC 3 * RELATIVE PLOTTING (RPLOT(X,Y) * EMUL2 LDA .32 GET PORGX,PORGY * JSB GB1 * LDA INTX1 * STA PORGX * LDA INTX2 * STA PORGY * LDA .16 NOW GET NEW POINTS * JSB GB1 * LDA PORGX COMPUTE PORG(X,Y) + NEWPOINTS * ADA INTX2 * STA INTX2 * LDA PORGY * ADA INTX3 * STA INTX3 * LDA PA * JSB WRDST INSERT PLOT ABSOLUTE COMMAND INTO IOBUF * JSB FIN CONVERT VALUES TO ASCII AND OUTPUT * JMP EML02,I * SPC 3 * * FLOAT TO ASCII * EMUL3 LDA .3 ETX STA TERM LDA LB JSB WRDST LDA .16 JSB GB1 JSB GLIDE JSB TRBYT LDA NBYTE LDB .2 JSB OUTPT JMP EML02,I * * * FLOAT TO ASCII CONVERSION * GLIDE NOP JSB FLTAS DEF RTGLD DEF INTX2 DEF IOBUF,I DEF NBYTE DEF FXDN F7.N DEF SKPBK RTGLD JMP GLIDE,I * * * * SPC 3 * * DIGITIZE * EMUL4 LDA DP DIGITIZE POINT -TURN ON ENTER LIGHT JSB PROUT EM4LP LDA OS OUTPUT STATUS JSB PROUT LDA .40 NOW CHECK STATUS WORD BIT 2 TO SEE IF POINT LDB .1 JSB OUTPT HAS BEEN ENTERRED LDA .1 STA LNGTH STA LNTH JSB INTEG CONVERT ASCII TO INTEGER LDA INTX1 AND .4 SZA JMP GETPT BIT 2 IS SET GO GET POINT JMP EM4LP CONTINUE LOOPING UNTIL WHATS -ITS ENTERS POINT GETPT LDA OD OUTPUT DIGITIZED POINT JSB PROUT LDA .40 LDB .1 JSB OUTPT LDA .3 STA LNGTH JSB INTEG LDA .16 JSB GB2 JMP EML02,I * PROUT NOP OUTPUT ASCII COMMAND IN THE A REGISTER JSB WRDST STORE WORD IN IOBUF JSB TRBYT LDA .3 LDB .2 JSB OUTPT CLA STA NBYTE LDA IOBUF x STA ADCNT JMP PROUT,I * * ASCII COMMANDS * OD ASC 1,OD OS ASC 1,OS DP ASC 1,DP * * NUMBER OF PENS SIMULATED OR OTHERWISE * EMUL5 LDA .4 FOUR PENS STA INTX1 LDA .16 JSB GB2 JMP EML02,I ** * LABEL DIRECTION * GICB = DEGREES- 9872 WANTS RUN,RISE * * EMUL7 LDA .3 STA FXDN SET UP FOR FLOAT TO ASCII CONVERSION LDA DI ABSOLUTE DIRECTION JSB WRDST LDA .16 JSB GB1 GO GET THETA DLD INTX2 DST INTX4 SAVE FOR RISE COMPUTATION JSB COS COMPUTE RUN NOP DST INTX2 JSB CLGCK EML71 JSB GLIDE CONVERT TO FLOATING POINT LDA COMA JSB PTBYT DLD INTX4 JSB SIN NOP COMPUTE RISE DST INTX2 JSB CLGCK EML72 JSB GLIDE JSB TRBYT INSERT TERMINATOR LDA NBYTE LDB .2 JSB OUTPT JMP EML02,I SPC 3 * * CLUGE BECAUSE OF PROBLEMS WITH 1.57 RADIANS (90 DEGREES) * CLGCK NOP JSB ABS FSB SMALL SSA,RSS JMP CLGCK,I DLD DBL0 DST INTX2 JMP CLGCK,I * SMALL DEC .0009 * * CHARACTER SLANT * EMUL8 LDA .3 STA FXDN SET UP FOR 3 CHARACTER TO RIGHT OF . LDA SL SLANT MNEMONIC JSB WRDST LDA .16 JSB GB1 GET ANGLE DLD INTX2 JSB TAN COMPUTE TAN(THETA) NOP DST INTX2 JSB GLIDE FLOAT TO ASCII JSB TRBYT LDA NBYTE LDB .2 JSB OUTPT JMP EML02,I * SL ASC 1,SL * * CHARACTER SIZE * GICB = WIDTH/HEIGHT * EMUL9 LDA .3 STA FXDN LDA .16 JSB GB1 DLD INTX4 GET HEIGHT AND SAVE DST TEMP LDA SI JSB WRDST DLD INTX2 WIDTH FDV CSIZW MU/CM/MU DST INTX2 JSB GLIDE LDA COMA JSB PTBYT DLD TEMP FDV CSIZH jd DST INTX2 JSB GLIDE JSB TRBYT LDB .2 LDA NBYTE JSB OUTPT JMP EML02,I * CSIZW DEC 600. MU/CM CSIZH DEC 800. SI ASC 1,SI * * LINE TYPES - GICB = LT#, * EML10 LDA .3 STA FXDN LDA .16 JSB GB1 GET DATA FROM GCB LDA LT LINE TYPE COMMAND JSB WRDST LDA INTX2 LT = 0 FOR SOLID SZA,RSS JMP FIN11 ADA LT0 GET LINE TYPE EQUIVALENCE FOR 9872 LDA A,I JSB PTBYT LDA LNGTH IS THERE A LENGTH SPECIFICATION CPA .1 JMP FIN12 FIN10 LDA INTX2 CPA .5 JMP FIN11 LDA INTX2 IOR .1 ADA PCLT0 STA TEMP ADDRESS OF PERCENT DIVIDER DLD INTX3 FDV TEMP,I DST INTX2 LDA COMA JSB PTBYT JSB GLIDE FLOAT TO ASCII FIN11 JSB TRBYT LDA NBYTE LDB .2 JSB OUTPT JMP EML02,I FIN12 LDA INTX2 IS LT = 1(DIM) CPA .1 JMP *+2 YES JMP FIN14 DLD D22 DST INTX3 JMP FIN10 CONTINUE * FIN14 LDA COMA JSB PTBYT SET DEFAULT LINE TYPE LENGTH BACK TO 4% LDA ASC4 JSB PTBYT JMP FIN11 * * LINE TYPES AND PERCENT VALUES * LT ASC 1,LT DI ASC 1,DI LT0 DEF * LT1 OCT 61 LT2 OCT 62 LT3 OCT 63 LT4 OCT 65 LT5 OCT 60 LT6 OCT 66 * * 1% VALUES OF LINE TYPE LENGTHS * PCLT0 DEF * PCLT1 DEC 45. DEC 60. DEC 135. DEC 180. BSS 2 DEC 180. * ASC4 OCT 64 D22 DEC 22.5 SPC 3 * GET DISPLAY SIZE IN MM * EML11 LDA SIZMM LENGTH LDB DF8 JSB GB JMP EML02,I * SIZMM DEF SZMM * SPC 3 * GET MACHINE UNIT/MM VALUES * EML12 LDA DF40 LDB DF4 JSB GB JMP EML02,I * * * SET RELATIVE ORIGIN * EML13 LDA .16 JSB GB1 LDA .32 IOSAV JSB GB2 JMP EML02,I * DEVICE CLEARING CAPABILITY * EML14 LDA DVCLR NO CLEAR LDB DF1 JSB GB JMP EML02,I * SPC 2 * PHYSICAL PENS * EML15 LDA DF4 LDB DF1 JSB GB JMP EML02,I * SPC 2 * * LORGABILITY - NONE * EML16 JMP EML14 SPC 2 * * MAX. CHAR SLANT * EML17 LDA CHSLT LDB DF4 JSB GB JMP EML02,I * SPC 2 * * DEVICE HARD CLIPPING CAPABILITY * EML18 LDA DF1 LDB DF1 JSB GB JMP EML02,I DF40 DEF D40 * SPC 2 * * DEVICE ID * EML19 LDA IDCD LDB DF3 JSB GB JMP EML02,I * * MIN/MAX CHARACTER SIZES * EML21 LDA DFCHR LDB DF9 JSB GB JMP EML02,I * DFCHR DEF CHW DF9 DEF .9 .9 DEC 9 * * LABEL DIRECTION INFO. FOR DSTAT OR WHOEVER * EML22 LDA LBLDR LDB DF3 JSB GB JMP EML02,I * LBLDR DEF *+1 OCT 2 DBL0 DEC 0. * IDCD DEF .987A .987A ASC 3,9872A * EML20 LDA DFL0 LDB DF1 JSB GB JMP EML02,I * * LORG RANGE * EML23 LDA DFL0 LDB DF2 JSB GB JMP EML02,I * DFL0 DEF DBL0 * * * SET HARD CLIP LIMITS * EML24 LDA .16 JSB GB1 GET LIMITS G1,G2 LDA IP SET SCALING POINTS P1,P2 JSB WRDST JSB FIN OUTPT CLA STA NBYTE LDA IOBUF STA ADCNT LDA IW SET WINDOW JSB WRDST JSB FIN JMP EML02,I * IP ASC 1,IP IW ASC 1,IW SPC 2 SKP GB NOP STA ADDR ADDRESS OF DATA STB NUM NUMBER OF DATA ITEMS JSB GCBIM DEF *+6 GB16 DEF .16 DEF .1 ADDR NOP NUM NOP DEF .2 JMP GB,I * * STORE A WORD INTO THE IOBUF * WRDST NOP STA ADCNT,I ISZ ADCNT ISZ NBYTE ISZ NBYTE JMP WRDST,I SKP * * * ERROR CHECKING * ERRCK JSxf640B EXEC DEF *+3 DEF .3 DEF LUN LDA OI OUTPUT IDENTITY FOR 7245 JSB WRDST JSB TRBYT LDA NBYTE LDB .2 JSB OUTPT CREATE AN ERROR CLA STA NBYTE LDA IOBUF STA ADCNT LDA OE OUTPUT ERROR JSB WRDST JSB TRBYT LDA NBYTE LDB .2 JSB OUTPT LDA .40 LDB .1 JSB OUTPT LDA .1 STA LNGTH JSB INTEG CONVERT TO INTEGER LDA INTX1 BIT ONE BETTER BE SET AND .1 SZA,RSS JMP ERRPT LDA .9872 JMP EML02,I ERRPT LDA .3 JMP EML02,I * OE ASC 1,OE OI ASC 1,OI .177 OCT 177 .9872 DEC 9872 M7 DEC -7 SPC 3 * * CONSTANTS AND TEMPORARY STORAGE * A EQU 0 B EQU 1 NBYTE NOP LUN NOP IOBUF NOP IOBL NOP FXDN NOP FIRST NOP INTX1 NOP INTX2 NOP INTX3 NOP INTX4 NOP PORGX BSS 2 PORGY BSS 2 INTXX BSS 4 RW NOP IOCNT NOP TEMP BSS 2 * DO NO CHANGE POSITION OF THESE CONSTANTS .0 OCT 0 .1 OCT 1 .2 OCT 2 .4 OCT 4 .26 DEC 26 .16 DEC 16 .32 DEC 32 .40 DEC 40 .5 OCT 5 INX DEF INTX1 .17 DEC 17 .21 DEC 21 .7 DEC 7 .137 OCT 137 TERM NOP DF7 DEF .7 .600 OCT 6000 PR ASC 1,PR SZMM DEC 0. DEC 0. .400 DEC 400. MACHINE LENGTH IN MM .285 DEC 285. MACHINE HEIGHT IN MM DF8 DEF .8 .8 DEC 8 DVCLR DEF .0 CHSLT DEF .155 .155 DEC 1.56 89 DEGREES DEC -1.56 COMA OCT 54 GCBCD NOP DF4 DEF .4 DF1 DEF .1 DF3 DEF .3 DF2 DEF .2 ADCNT NOP IBYTE NOP LNTH NOP SKPBK NOP .6 DEC 6 OP ASC 1,OP D40 DEC 40.0 DEC 40. END 6 U c 92840-18087 1819 S C0122 7245 CMND TABLE              H0101 ASMB,R,L,C * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: DCT03 - 7245A DEVICE COMMAND TABLE * SOURCE: 92840 - 18087 * RELOC: 92840 - 16006 * * * ************************************************************* * NAM DCT03,7 92840-16006 REV. 1819 780515 ENT DCT03 * EXT EXEC,TAN,COS,SIN,FLOAT EXT INDCK,INTX,GCBIM,BYTE EXT CONVT,FLTAS EXT LNGTH,GIC,DCTAD EXT .IENT * THIS IS THE DEVICE COMMAND AND EMULATOR MODULE FOR THE * 7245 PLOTTER/PRINTER. * DCT03 NOP DEF EML03 DEF RESET RESET DEVICE DEF DEFLT DEF PAGE FORM FEED NOP DEF HOME HOME PEN DEC -23 GET DEVICE ID NOP GET CAPABILITIES (NOT USED) DEF PLTUN GET PLOT UNITS P1 AND P2 OCT -1 GET CHARACTER SPACE SIZE INFORMATION DEF PNLOC GET PEN LOCATION DEF CRLOC GET CURSOR LOCATION OCT -2 DIGITIZE DEF LORG SET LABEL ORIGIN OCT -3 LABEL DIRECTION OCT -4 SLANT ON DEF SLOFF SLANT OFF OCT -5 SET CHARACTER SIZE OCT -6 SET RELATIVE ORIGIN(PORG) NOP SET PLOT DIRECTION NOP SET SCALE NOP SET ORIGIN = CURSOR NOP SET ORIGIN = PEN NOP DRAW TO CURSOR NOP SELECT CHARACTER SET NOP SELECT PEN 0 OCT -7 SELECT PEN -1 (ERASE) NOP SELECT PEN -2(COMPLEMENT) DEC -9 DEC -8 GET NUMBER OF PENS NOP DEFINE LINE TYPE(NOT USED) DEC -9 SELECT DEFAULT LINE TYPE DEC -9 DEFAULE LINE TYPE WITH LENGTH DEF PENUP PEN UP DEF PENDN PEN DOWN DEF PLTAB PLOT ABSOLUTE DEC -10 PLOT RELATIVE DEF PLTIN PLOT INCREMENTAL DEF SHTLB SHORT LABEL DEF STLAB START LONG LABEL DEF STPLB STOP LONG LABEL MODE DEC -11 FLOAT TO ASCII DEC -12 SURFACE SIZE IN MM DEF POSCR POSITION CURSOR NOP POSITION CURSOR RELATIVE DEC -22 SET P1,P2 DEF GTMUM GET MU/MM DEC -13 GET DEVICE CLEARING CHARACTERISTICS DEC -14 NUMBER OF PHYSICALLY DIFFERENT PENS DEC -18 NUMBER OF CURSORS DEC -15 LORG-ABILITY DEC -16 MAXIMUM CHARACTER SLANT DEC -17 DEVICE HARD CLIPPING CAPABILITY NOP FILE NAME DEC -19 DEC -20 DEC -21 * * ASCII COMMAND STRINGS FIRST WORD = NUMBER OF BYTES * SECOND WORD = TERMINATOR RESET DEC -2 2 BYTES, WRITE DEF SEMCL ASC 1,DF COMMAND STRING * DEFLT DEC -5 DEF SEMCL ASC 3,IP;IW * PAGE DEC -2 DEF SEMCL PG ASC 1,PG * HOME DEC -14 DEF SEMCL ASC 7,PU;PA200,11000 * ID DEC 2 DEF SEMCL OI ASC 1,OI * PLTUN DEC 2 DEF SEMCL OP ASC 1,OP PNLOC DEC 2 DEF SEMCL ASC 1,OA * CRLOC DEC 2 DEF SEMCL ASC 1,RC * LORG DEC -2 DEF SEMCL ASC 1,LO * LNTYP DEC -2 DEF SEMCL ASC 1,LT * PENDN DEC -2 DEF SEMCL ASC 1,PD * PENUP DEC -2 DEF SEMCL ASC 1,PU * PLTAB DEC -2 DEF SEMCL PA ASC 1,PA * PLTIN DEC -2 PLOT INCREMENTAL DEF SEMCL ASC 1,PR * SELPN DEC -2 DEF SEMCL ASC 1,LT STLAB DEC -2 DEF HT ASC 1,LB STPLB DEC -1 DEF HT OCT a1400 DECIMAL 3 * SLOFF DEC -2 DEF SEMCL ASC 1,SL STP12 DEC -2 DEF SEMCL IW ASC 1,IW * SHTLB DEC -2 DEF HT LB ASC 1,LB * GTMUM DEC 2 DEF SEMCL ASC 1,OF * POSCR DEC -2 DEF SEMCL ASC 1,PC * HT OCT 137 SKP * * SETUP NOP JSB GCBIM RETRIEVE IOBUF ADDRESS AND IOBL FROM THE GCB DEF CONT1 DEF .2 CODE IN IGTBL, FOR IOBUF,IOBL,AND LUN DEF .3 TWO CODES DEF LUN DEF .0 THREE WORDS DEF .1 READ CONT1 LDA IOBUF JSB INDCK STA IOBUF STA IOB STA ADCNT INITIALIZE ADDRESS COUNTER STA INTIO LDA SEMCL TERMINATOR STA TERM CLA STA NBYTE BYTE COUNTER STA IBYTE * JMP SETUP,I * * CONVERT INCOMING DATA FROM ASCII TO INTEGER * INTEG NOP LDA LNGTH SET TO CONVERT FROM ASCII TO INTEGER CMA,INA STA LNTH CLA STA IBYTE LDA INX STA INTAD INTLP JSB INTX BEGIN TO CONVERT DATA DEF RTINT INTIO NOP INTAD NOP DEF IBYTE RTINT LDA FIRST SEE IF WE ARE RETRIEVING PLOT UNITS CPA OP JMP FIXIT YES CONIN ISZ INTAD ISZ LNTH JMP INTLP CONTINUE JMP INTEG,I FIXIT LDA INTAD,I CONVERT INTEGER TO FLOATING POINT JSB FLOAT DST INTAD,I ISZ INTAD ISZ LNTH JMP CONIN CONTINUE * * TAKE VALUES PLACED IN INTX1(1) TO INTX1(LNGTH) AND TRANSFER * THIS DATA TO GICB. * GB2 NOP STA GCBCD JSB GCBIM TRANSFER DATA TO AGL DEF RTX DEF GCBCD DEF .1 DEF INTX1 DEF LNGTH DEF .2 RTX JMP GB2,I * * RETRIEVE DATA FROM GICB AND PLACE IT IN INTX1(1) TO INTX1(LNTH) * GB1 NOP STA GCBCD GCB POINTER JSB GCBIM RETRIEVE INTEGER VALUES FROM DEF RTGB1 GCB DEF GCBCD DEF .1  DEF INTX1 DEF LNTH DEF .1 RTGB1 JMP GB1,I * * FINI DOES THE FOLLOWING: * 1. CONVERTS INTEGERS TO ASCII * 2. TRANSFERS THIS ASCII TO THE DEVICE (VIA OUTPT). * 3. RETURNS TO CALLER * FIN NOP FINI JSB CONVT DEF RTCON DEF INTX2 FWA FOR INTEGERS TO BE CONVERTED DEF IOBUF,I I O BUFFER DEF NBYTE DEF LNGTH RTCON JSB TRBYT INSERT TERMINATOR LDA NBYTE LDB .2 JSB OUTPT JMP FIN,I * * SPC 3 SPC 3 * * TRBYT NOP INSERT TERMINATOR INTO OUTPUT BUFFER LDA TERM SEMI-COLON JSB PTBYT JMP TRBYT,I * PTBYT NOP STA BITE JSB UPDTE UPDATE ADDRESS COUNTER (ADCNT) JSB BYTE DEF RTBYT DEF NBYTE DEF BITE DEF ADCNT,I RTBYT ISZ NBYTE JSB UPDTE JMP PTBYT,I * * UPDTE NOP LDA NBYTE CLE,ERA ADA IOBUF STA ADCNT JMP UPDTE,I * * BITE NOP * OUTPT NOP I/O TRANSFER ROUTINE CMA,INA STA IOCNT BYTE COUNTER FOR OUTPUT STB RW JSB EXEC DEF RTOUT DEF RW DEF LUN IOB NOP DEF IOCNT RTOUT JMP OUTPT,I * * SKP SPC 3 * * EMULATORS * EML03 NOP JSB SETUP GO GET IOBUF,IOBL,LUN AND FXD N LDA GIC CPA .177 JMP ERRCK LDA DCTAD EMULATOR NUMBER (NEGATIVE) CMA,INA STA B LDA EM0 TOP OF LIST OF EMULATORS AND OTHER THINGS. JSB INDCK GET RID OF INDIRECT BIT ADA B COMPUTE POINTER LDB LNGTH INB STB LNTH LDA A,I JMP A,I * EM0 DEF * DEF EMUL1 DEF EMUL2 DEF EMUL3 DEF EMUL4 DEF EMUL5 DEF EMUL6 DEF EMUL7 DEF EMUL8 DEF EMUL9 DEF EML10 DEF EML11 DEF EML12 DEF EML13 DEF EML14 DEF EML15 DEˀF EML16 DEF EML17 DEF EML18 DEF EML19 DEF EML20 DEF EML21 DEF EML22 DEF EML23 * SKP SPC 2 * * CHARACTER SPACING INFORMATION * EMUL1 LDA .7 JSB GB1 GET CURRENT CHARACTER SIZE LDA .16 JSB GB2 JMP EML03,I * * DEFAULT VALUES = WIDTH * 1.5 * 400 MU MM * HEIGHT * 2. * 400MU/MM * * CHRW DEC 81. CHRH DEC 324. CHW DEC -7400. DEC -11000. DEC 7400. DEC 11000. OCT 1 D1.5 DEC 1.5 D2.0 DEC 2.0 SPC 3 * RELATIVE PLOTTING (RPLOT(X,Y) * EML10 LDA .32 GET PORGX,PORGY * JSB GB1 * LDA INTX1 * STA PORGX * LDA INTX2 * STA PORGY * LDA .16 NOW GET NEW POINTS * JSB GB1 * LDA PORGX COMPUTE PORG(X,Y) + NEWPOINTS * ADA INTX2 * STA INTX2 * LDA PORGY * ADA INTX3 * STA INTX3 * LDA PA * JSB WRDST INSERT PLOT ABSOLUTE COMMAND INTO IOBUF * JSB FIN CONVERT VALUES TO ASCII AND OUTPUT * JMP EML03,I * SPC 3 * * FLOAT TO ASCII * EML11 LDA .3 ETX STA TERM LDA LB JSB WRDST LDA .16 JSB GB1 JSB GLIDE JSB TRBYT LDA NBYTE LDB .2 JSB OUTPT JMP EML03,I * * * FLOAT TO ASCII CONVERSION * GLIDE NOP JSB FLTAS DEF RTGLD DEF INTX2 DEF IOBUF,I DEF NBYTE DEF FXDN F7.N DEF SKPBK RTGLD JMP GLIDE,I * * * * SPC 3 * * DIGITIZE * EMUL2 LDA DP DIGITIZE POINT -TURN ON ENTER LIGHT JSB PROUT EM4LP LDA OS OUTPUT STATUS JSB PROUT LDA .40 NOW CHECK STATUS WORD BIT 2 TO SEE IF POINT LDB .1 JSB OUTPT HAS BEEN ENTERRED LDA .1 STA LNGTH STA LNTH JSB INTEG CONVERT ASCII TO INTEGER LDA INTX1 AND .4 SZA JMP ^GETPT BIT 2 IS SET GO GET POINT JMP EM4LP CONTINUE LOOPING UNTIL WHATS -ITS ENTERS POINT GETPT LDA OD OUTPUT DIGITIZED POINT JSB PROUT LDA .40 LDB .1 JSB OUTPT LDA .3 STA LNGTH JSB INTEG LDA .16 JSB GB2 JMP EML03,I * PROUT NOP OUTPUT ASCII COMMAND IN THE A REGISTER JSB WRDST STORE WORD IN IOBUF JSB TRBYT LDA .3 LDB .2 JSB OUTPT CLA STA NBYTE LDA IOBUF STA ADCNT JMP PROUT,I * * ASCII COMMANDS * OD ASC 1,OD OS ASC 1,OS DP ASC 1,DP * * NUMBER OF PENS SIMULATED OR OTHERWISE * EMUL8 LDA .6 SIMULATED PENS (LINE TYPES) STA INTX1 LDA .16 JSB GB2 JMP EML03,I ** * LABEL DIRECTION * GICB = DEGREES- 9872 WANTS RUN,RISE * * EMUL3 LDA .3 STA FXDN SET UP FOR FLOAT TO ASCII CONVERSION LDA DI ABSOLUTE DIRECTION JSB WRDST LDA .16 JSB GB1 GO GET THETA DLD INTX2 DST INTX4 SAVE FOR RISE COMPUTATION JSB COS COMPUTE RUN NOP DST INTX2 EML71 JSB GLIDE CONVERT TO FLOATING POINT LDA COMA JSB PTBYT DLD INTX4 JSB SIN NOP COMPUTE RISE DST INTX2 EML72 JSB GLIDE JSB TRBYT INSERT TERMINATOR LDA NBYTE LDB .2 JSB OUTPT JMP EML03,I SPC 3 * * CHARACTER SLANT * EMUL4 LDA .3 STA FXDN SET UP FOR 3 CHARACTER TO RIGHT OF . LDA SL SLANT MNEMONIC JSB WRDST LDA .16 JSB GB1 GET ANGLE DLD INTX2 JSB TAN COMPUTE TAN(THETA) NOP DST INTX2 JSB GLIDE FLOAT TO ASCII JSB TRBYT LDA NBYTE LDB .2 JSB OUTPT JMP EML03,I * SL ASC 1,SL * * CHARACTER SIZE * GICB = WIDTH/HEIGHT * EMUL5 LDA .3 ST|A FXDN LDA .16 JSB GB1 DLD INTX4 GET HEIGHT AND SAVE DST TEMP LDA SI JSB WRDST DLD INTX2 WIDTH FDV CSIZW MU/CM/MU DST INTX2 JSB GLIDE LDA COMA JSB PTBYT DLD TEMP FDV CSIZH DST INTX2 JSB GLIDE JSB TRBYT LDB .2 LDA NBYTE JSB OUTPT JMP EML03,I * CSIZW DEC 600. MU/CM CSIZH DEC 800. SI ASC 1,SI * * LINE TYPES - GICB = LT#, * EMUL9 LDA .3 STA FXDN LDA .16 JSB GB1 GET DATA FROM GCB LDA LT LINE TYPE COMMAND JSB WRDST LDA INTX2 LT = 0 FOR SOLID SZA,RSS JMP FIN11 ADA LT0 GET LINE TYPE EQUIVALENCE FOR 9872 LDA A,I JSB PTBYT LDA LNGTH IS THERE A LENGTH SPECIFICATION CPA .1 JMP FIN12 FIN10 LDA INTX2 CPA .5 JMP FIN11 LDA INTX2 IOR .1 ADA PCLT0 STA TEMP ADDRESS OF PERCENT DIVIDER DLD INTX3 FDV TEMP,I DST INTX2 LDA COMA JSB PTBYT JSB GLIDE FLOAT TO ASCII FIN11 JSB TRBYT LDA NBYTE LDB .2 JSB OUTPT JMP EML03,I FIN12 LDA INTX2 IS LT = 1(DIM) CPA .1 JMP *+2 YES JMP FIN14 DLD D22 DST INTX3 JMP FIN10 CONTINUE * FIN14 LDA COMA JSB PTBYT SET DEFAULT LINE TYPE LENGTH BACK TO 4% LDA ASC4 JSB PTBYT JMP FIN11 * * LINE TYPES AND PERCENT VALUES * LT ASC 1,LT DI ASC 1,DI LT0 DEF * LT1 OCT 61 LT2 OCT 62 LT3 OCT 63 LT4 OCT 65 LT5 OCT 60 LT6 OCT 66 * * 1% VALUES OF LINE TYPE LENGTHS * PCLT0 DEF * PCLT1 DEC 45. DEC 60. DEC 135. DEC 180. BSS 2 DEC 180. * ASC4 OCT 64 D22 DEC 22.5 SPC 3 * GET DISPLAY SIZE IN MM * EML12 LDA SIZMM LENGTH LDB DF8 JSB GB  JMP EML03,I * SIZMM DEF SZMM * SPC 3 * * * SET RELATIVE ORIGIN * EMUL6 LDA .16 * JSB GB1 * LDA .32 IOSAV * JSB GB2 * JMP EML03,I SPC 2 * * ERASE PAGE ADVANCE * EMUL7 LDA PG JSB WRDST LDA ONE JSB WRDST LDB .2 LDA .4 JSB OUTPT JMP EML03,I * ONE OCT 30473 * DEVICE CLEARING CAPABILITY * EML13 LDA DVCLR NO CLEAR LDB DF1 JSB GB JMP EML03,I * SPC 2 * PHYSICAL PENS * EML14 LDA DF1 LDB DF1 JSB GB JMP EML03,I * SPC 2 * * LORGABILITY * EML15 JMP EML14 SPC 2 * * MAX. CHAR SLANT * EML16 LDA CHSLT LDB DF4 JSB GB JMP EML03,I * SPC 2 * * DEVICE HARD CLIPPING CAPABILITY * EML17 JMP EML14 * EML18 LDA DF0 LDB DF1 JSB GB JMP EML03,I * * MIN/MAX CHARACTER SIZES * EML19 LDA DFCHR LDB DF9 JSB GB JMP EML03,I * .9 DEC 9 DF9 DEF .9 DFCHR DEF CHW * * LABEL DIRECTION INFORMATION * EML20 LDA LBLDR LDB DF3 JSB GB JMP EML03,I * LBLDR DEF *+1 OCT 2 DEC 0. SPC 2 * * LORG RANGE * EML21 LDA DFL1 LDB DF2 JSB GB JMP EML03,I * DFL1 DEF *+1 OCT 1 DEC 9 * * EML22 LDA .16 JSB GB1 GET G1,G2 LDA IP JSB WRDST JSB FIN CLA STA NBYTE LDA IOBUF STA ADCNT LDA IW JSB WRDST JSB FIN JMP EML03,I * IP ASC 1,IP * EML23 LDA IDCD LDB DF3 JSB GB JMP EML03,I * IDCD DEF .724A .724A ASC 3,7245A SKP * * * ERROR CHECKING * ERRCK JSB EXEC SELECT DEVICE CLEAR DEF *+3 DEF .3 DEF LUN LDA OI SEN OUT ID AND SEE IF IT FLIES JSB WRDST JSB TRBYT LDA NBYTE LDB J.2 JSB OUTPT CLA STA NBYTE LDA IOBUF STA ADCNT LDA OE JSB WRDST JSB TRBYT LDA NBYTE LDB .2 JSB OUTPT LDA .40 NOW EXAMINE STATUS WORD LDB .1 JSB OUTPT LDA .1 STA LNGTH JSB INTEG CONVERT TO INTEGER LDA INTX1 CHECK BIT 1 AND .1 SZA JMP ERRPT GOT PROBLEMS LDA .7245 JMP EML03,I OKAY ERRPT LDA .3 JMP EML03,I * * OE ASC 1,OE .7245 DEC 7245 SKP GB NOP STA ADDR ADDRESS OF DATA STB NUM NUMBER OF DATA ITEMS JSB GCBIM DEF *+6 GB16 DEF .16 DEF .1 ADDR NOP NUM NOP DEF .2 JMP GB,I * * STORE A WORD INTO THE IOBUF * WRDST NOP STA ADCNT,I ISZ ADCNT ISZ NBYTE ISZ NBYTE JMP WRDST,I SKP SPC 3 * * CONSTANTS AND TEMPORARY STORAGE * A EQU 0 B EQU 1 NBYTE NOP LUN NOP IOBUF NOP IOBL NOP FXDN NOP FIRST NOP INTX1 NOP INTX2 NOP INTX3 NOP INTX4 NOP PORGX BSS 2 PORGY BSS 2 INTXX BSS 4 RW NOP IOCNT NOP TEMP BSS 2 * DO NO CHANGE POSITION OF THESE CONSTANTS .0 OCT 0 .1 OCT 1 .2 OCT 2 .4 OCT 4 .26 DEC 26 .16 DEC 16 .32 DEC 32 .3 OCT 3 SEMCL OCT 73 .20 DEC 20 .40 DEC 40 .5 OCT 5 INX1 DEF INTX4 INX DEF INTX1 .7 DEC 7 TERM NOP DF3 DEF .3 .600 OCT 6000 SZMM DEC 5. 200 * .025 DEC 5. -32,727* .025 DEC 180. .819 DEC 270. MACHINE HEIGHT IN MM (32767 * .025) DVCLR DEF .2 DF8 DEF .8 .8 DEC 8 CHSLT DEF .155 .155 DEC 1.56 89 DEGREES DEC -1.56 .03 OCT 1400 COMA OCT 54 M7 OCT -7 .177 OCT 177 GCBCD NOP DF4 DEF .4 DF2 DEF .2 DF1 DEF .1 DF0 DEF .0 ADCNT NOP IBYTE NOP LNTH NOP SKPBK NOP M1 OCT -1 .6 DEC 6 .13 DEC 13 END <:66< Ve 92840-18088 1840 S C0122 &DVG07 9874A DEVICE SUBRT. SRCE             H0101 ASMB,R,L,C * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: DEVICE SUBROUTINE FOR 9874 * SOURCE: 92840 - 18088 * RELOC: 92840 - 16007 * * * ************************************************************* * NAM DVG07,7 92840-16007 REV. 1840 780731 EXT EXEC,GCBIM,BYTE EXT .IENT EXT FLOAT EXT EMULX EXT INDCK EXT INTX EXT DCTIM EXT CONVT EXT LNGTH,GIC,DCTAD EXT GRSTS ENT DVG07 * * THIS IS THE DEVICE SUBROUTINE FOR THE HP 9874A DIGITIZER. * DVG07 NOP CLA INITIALIZE THE READ/WRITE FLAG AND BYTE COUNTER STA RWFLG COUNTER STA FIN STA NBYTE STA IBYTE LDA SEMCL SEMICOLON - TERMINATOR STA TERM JSB DCTIM FILL UP GIC, LENGTH AND DEVICE COMMAND LDA GIC ADDRESS (DCTAD) SKP CPA .177 JMP ERRCK JSB SETUP CONT LDA DCTAD SEE WHAT TYPE OF COMMAND THIS IS SSA EMULATOR? JMP EMULT YES SZA,RSS A NOP? JMP DVG07,I DO NOTHING A'TALL AND RETURN LDB DCTAD A COMMAND ADDRESS LDA B,I SSA,RSS READ OR WRITE? JMP CONT0 READ ISZ RWFLG WRITE CMA,INA SET BYTE COUNT POSITIVE CONT0 STA NBYTE AND .1 COMPUTE NWORD = NBYTE/2 + REMAINDER STA NWORD STA ODFLG = 0 IF EVEN, AND 1 IF ODD LDA NBYTE CLE,ERA NBYTE/2 ADA NWORD CMA,INA STA NWORD INB LDA B,I LDA A,I TERMINATOR STA TERM IN B LDA B,I STA FIRST SAVE FIRST WORD OF COMMAND STRING STB DCTAD NOW POINT TO FIRST WORD OF COMMAND STG XFER LDA DCTAD,I NOW TRANSFER COMMAND STG TO THE I/O BUFF STA ADCNT,I ISZ NWORD JMP CONT2 JMP XEND FINISHED CONT2 ISZ DCTAD ISZ ADCNT INCREMENT ADDRESS POINTERS JMP XFER CONTINUE XEND LDA ODFLG SZA,RSS ISZ ADCNT LDA RWFLG READ OR WRITE? SZA,RSS JMP READ LDA LNGTH WRITE - SEE IF ANY INTS TO CONVERT TO ASC SZA THIS IS LENGTH FROM GICB JMP CNVRT YES GO CONVERT TO ASCII JSB TRBYT GO INSERT TERMINATOR LDA NBYTE NUMBER OF BYTES LDB .2 WRITE JSB OUTPT EXEC I/O JMP DVG07,I GO HOME BABY SKP * * * * PROCESS READ REQUEST. FIRST A WRITE MUST BE DONE TO * OUTPUT THE COMMAND CODE, AND THEN A READ MUST BE DONE TO * THE DEVICE INTO THE TALK MODE TO GET THE STATUS DATA. * READ NOP JSB TRBYT FIRST INSERT TERMINATOR LDA NBYTE LDB .2 JSB OUTPT OUTPUT STATUS REQUEST COMMAND LDA M19 FILL BUFFER WITH BLANKS STA CNTR LDA IOBUF STA BACNT SPC 1 BLOOP LDA BLNK STA BACNT,I ISZ BACNT ISZ CNTR JMP BLOOP SPC 1 LDB .1 NOW PUT DEVICE INTO TALK MODE LDA .40 TO GET DATA JSB OUTPT JSB INTEG GO CONVERT FROM ASCII TO INTEGER JSB GB2 TRANSFER RESULTS TO GICB JMP DVG07,I SPC 1 CNVRT LDA LNGTH INA STA LNTH JSB GB1 RETRIVE INTEGER VALUES JMP FINI SKP * * SPECIAL INTERNAL UTILITY ROUTINES * SETUP NOP JSB GCBIM RETRIEVE IOBUF ADDRESS AND IOBL FROM THE GCB DEF CONT1 DEF .2 CODE IN IGTBL, FOR IOBUF,IOBL,AND LUN DEF .3 TWO CODES DEF LUN DEF .0 THREE WORDS y DEF .1 READ CONT1 LDA IOBUF JSB INDCK STA IOBUF STA IOB STA ADCNT INITIALIZE ADDRESS COUNTER STA INTIO * * NOW CHECK BIT 4 OF STATUS WORD TO SEE IF A SHORT LABEL WAS * PREVIOUSLY EMITTED - IF SO EMIT LABEL TERMINATOR AND RESET BIT 4 * JSB GRSTS DEF *+4 DEF .1 DEF BIT4 DEF TEMP LDA TEMP SZA,RSS BIT SET? JMP SETUP,I NO JSB GRSTS RESET BIT 4 DEF *+4 DEF .2 DEF MASK4 DEF .0 CLA STA NBYTE LDA IOBUF STA ADCNT JMP SETUP,I * * CONVERT INCOMING DATA FROM ASCII TO INTEGER * INTEG NOP LDA LNGTH SET TO CONVERT FROM ASCII TO INTEGER CMA,INA STA LNTH CLA STA IBYTE LDA INX STA INTAD INTLP JSB INTX BEGIN TO CONVERT DATA DEF RTINT INTIO NOP INTAD NOP DEF IBYTE RTINT LDA FIRST SEE IF WE ARE RETRIEVING PLOT UNITS CPA OP JMP FIXIT YES CPA OF JMP FIXIT CONIN ISZ INTAD ISZ LNTH JMP INTLP CONTINUE JMP INTEG,I FIXIT LDA INTAD,I CONVERT INTEGER TO FLOATING POINT JSB FLOAT DST INTAD,I ISZ INTAD ISZ LNTH JMP CONIN CONTINUE SKP * * TAKE VALUES PLACED IN INTX1(1) TO INTX1(LNGTH) AND TRANSFER * THIS DATA TO GICB. * GB2 NOP JSB GCBIM TRANSFER DATA TO AGL DEF RTX DEF .16 DEF .1 DEF INTX1 DEF LNGTH DEF .2 RTX JMP GB2,I * * RETRIEVE DATA FROM GICB AND PLACE IT IN INTX1(1) TO INTX1(LNTH) * GB1 NOP JSB GCBIM RETRIEVE INTEGER VALUES FROM DEF RTGB1 GCB DEF .16 GICB DEF .1 DEF INTX1 DEF LNTH DEF .1 RTGB1 JMP GB1,I * * FINI DOES THE FOLLOWING: * 1. CONVERTS INTEGERS TO ASCII * 2. TRANSFERS THIS ASCII TO THE DEVICE (VIA OUTPT). * 3. RETWeURNS TO CALLER * FIN NOP FINI JSB CONVT DEF RTCON DEF INTX2 FWA FOR INTEGERS TO BE CONVERTED DEF IOBUF,I I O BUFFER DEF NBYTE DEF LNGTH RTCON JSB TRBYT INSERT TERMINATOR LDA NBYTE LDB .2 JSB OUTPT LDA FIN SZA,RSS JMP DVG07,I JMP FIN,I SKP * * EXIT DVG07 AND SET MODE TO LABEL IF NOT ALREADY SET * * * TRBYT NOP INSERT TERMINATOR INTO OUTPUT BUFFER LDA TERM SEMI-COLON JSB PTBYT JMP TRBYT,I * PTBYT NOP STA BITE JSB UPDTE UPDATE ADDRESS COUNTER (ADCNT) JSB BYTE DEF RTBYT DEF NBYTE DEF BITE DEF ADCNT,I RTBYT ISZ NBYTE JSB UPDTE JMP PTBYT,I * * UPDTE NOP LDA NBYTE CLE,ERA ADA IOBUF STA ADCNT JMP UPDTE,I * * BITE NOP * OUTPT NOP I/O TRANSFER ROUTINE STB RW LDB TERM CPB .137 JMP *+2 INA CMA,INA STA IOCNT BYTE COUNTER FOR OUTPUT LDA .137 JSB PTBYT SUPRESS CRLF JSB EXEC DEF RTOUT DEF RW DEF LUN IOB NOP DEF IOCNT RTOUT JMP OUTPT,I SKP ERRCK JSB SETUP * JSB EXEC SEE IF THE LU IS INTERACTIVE DEF *+6 DEF D13I STATUS REQUEST DEF LUN THE LU WE WANT THE INFO ABOUT DEF YTEMP EQT WORD 5 PLACED HERE DEF DTYPE EQT WORD 4 PLACED HERE(NOT NEEDED) DEF ZTEMP SUB CHANNEL IN LOWER 5 BIT HERE * JMP ITSNT IT AIN'T EVEN AN LU !!!! LDA YTEMP GET EQT WORD 5 AND MEQT KEEP ONLY THE EQT TYPE FIELD LDB A AND SAVE IT LDA ZTEMP GET THE SUBCHANNEL BITS AND M37 STA ZTEMP ADA B CONFIGURE B REGISTER RETURN WORD STA DTYPE CPB M1740 IF DVR 05 THEN JMP ERR1 DO ONE MORE CHECK FOR SUB CHANNEL ITSNT LDA .5  JMP ERRPT ERR1 JSB EMULX,I NOW ASK DEVICE COMMAND TABLE ABOUT ITSELF CPA .9874 JMP ERR2 CPA .3 JMP ERR3 SOMETHING IS VERY WRONG CPA .5 JMP ERR3 LDA .3 JMP ERR3 ERR2 CLA ERR3 STA INTX1 LDA .1 STA LNGTH JSB GB2 LDA INTX1 SZA JMP DVG07,I JSB EXEC DEVICE CLEAR DEF *+3 DEF .3 DEF LUN JMP DVG07,I ERRPT LDA .5 JMP ERR3 SKP .9872 DEC 9872 .7245 DEC 7245 .9874 DEC 9874 .177 OCT 177 * * D13I OCT 100015 M1740 OCT 17400 M37 OCT 37 MEQT OCT 37400 ANLU# NOP DTYPE NOP YTEMP NOP ZTEMP NOP * * EMULT JSB EMULX,I JMP DVG07,I A EQU 0 B EQU 1 NBYTE NOP NWORD NOP LUN NOP IOBUF NOP IOBL NOP FXDN NOP FIRST NOP INTX1 NOP INTX2 NOP INTX3 NOP INTX4 NOP INTXX BSS 8 RW NOP IOCNT NOP * DO NO CHANGE POSITION OF THESE CONSTANTS .0 OCT 0 .1 OCT 1 .2 OCT 2 .4 OCT 4 .26 DEC 26 .3 OCT 3 .16 DEC 16 .20 DEC 20 .40 DEC 40 .5 OCT 5 INX DEF INTX1 INX1 DEF INTX4 .21 DEC 21 .7 DEC 7 TERM NOP ETX OCT 1400 BIT4 OCT 20 TEMP NOP MASK4 OCT 77757 SEMCL OCT 73 DF7 DEF .7 .600 OCT 6000 .137 OCT 137 ADCNT NOP IBYTE NOP RWFLG NOP ODFLG NOP LNTH NOP SKPBK NOP OP ASC 1,OP OF ASC 1,OF M19 DEC -19 BACNT NOP CNTR NOP BLNK OCT 20040 END y W a 92840-18089 1840 S C0122 &DCT07 9874A CMND TBLE SRC             H0101 ASMB,R,L,C * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: DCT07 - 9874A DEVICE COMMAND TABLE * SOURCE: 92840 - 18089 * RELOC: 92840 - 16007 * * * ************************************************************* * NAM DCT07,7 92840-16008 REV. 1840 780731 ENT DCT07 * EXT EXEC,FLOAT EXT INDCK,INTX,GCBIM,BYTE EXT CONVT,FLTAS EXT LNGTH,GIC,DCTAD * * THIS IS THE DEVICE COMMAND AND EMULATOR MODULE FOR THE * 9874A DIGITIZER. * DCT07 NOP DEF EML07 DEF RESET RESET DEVICE DEF DEFLT DEFAULT NOP FORM FEED NOP NOP HOME PEN DEC -1 GET DEVICE ID NOP GET CAPABILITIES DEF PLTUN GET PLOT UNITS P1 AND P2 NOP GET CHARACTER SPACE SIZE INFORMATION DEF CRLOC GET PEN LOCATION DEF CRLOC GET CURSOR LOCATION OCT -2 DIGITIZE NOP SET LABEL ORIGIN NOP SET LABEL DIRECTION NOP SLANT ON NOP SLANT OFF NOP SET CHARACTER SIZE NOP SET RELATIVEW ORIGIN (PORG) NOP SET PLOT DIRECTION NOP SET SCALE SKP NOP SET ORIGIN = CURSOR NOP SET ORIGIN = PEN NOP DRAW TO CURSOR NOP SELECT CHARACTER SIZE NOP SELECT PEN 0 NOP SELECT PEN -1 (ERASE) NOP SELECT PEN -2 (COMPLEMENT) NOP LINE TYPE NOP GET NUMBER OF PENS NOP DEFINEq LINE TYPE NOP SELECT DEFAULT LINE TYPE NOP DEFAULT LINE TYPE WITH LENGTH NOP PEN UP NOP PEN DOWN NOP PLOT ABSOLUTE NOP PLOT RELATIVE NOP PLOT INCREMENTAL NOP SHORT LABEL NOP START LONG LABEL NOP STOP LONG LABEL MODE DEC -3 FLOAT TO ASCII DEC -4 SURFACE SIZE IN MM NOP POSITION CURSOR NOP POSITION CURSOR RELATIVE DEC -5 SET P1,P2 DEF GTMUM GET MU/MM DEC -6 GET DEVICE CLEARING CHARACTERISTICS NOP NUMBER OF PHYSICALLY DIFFERENT PENS NOP NUMBER OFC CURSORS NOP LORGABILITY NOP MAXIMUM CHARACTER SLANT DEC -7 DEVICE HARD CLIPPING CAPABILITY NOP FILE NAME NOP NOP NOP SKP * * ASCII COMMAND STRINGS FIRST WORD = NUMBER OF BYTES * SECOND WORD = TERMINATOR * RESET DEC -5 5 BYTES, WRITE DEF SEMCL ASC 3,DF;SG COMMAND STRING * DEFLT DEC -20 DEF SEMCL ASC 10,IP0,0,17500,12600;IW * PLTUN DEC 2 DEF SEMCL OP ASC 1,OP * CRLOC DEC 2 DEF SEMCL ASC 1,OC * GTMUM DEC 2 DEF SEMCL ASC 1,OF SKP * * SETUP * SETUP NOP JSB GCBIM RETRIEVE IOBUF ADDRESS AND IOBL FROM THE GCB DEF CONT1 DEF .2 CODE IN IGTBL, FOR IOBUF,IOBL,AND LUN DEF .3 TWO CODES DEF LUN DEF .0 THREE WORDS DEF .1 READ CONT1 LDA IOBUF JSB INDCK STA IOBUF STA IOB STA ADCNT INITIALIZE ADDRESS COUNTER STA INTIO LDA SEMCL TERMINATOR STA TERM CLA STA NBYTE BYTE COUNTER STA IBYTE RTSET JMP SETUP,I * * INTEG -- CONVERT INCOMING DATA FROM ASCiCII TO INTEGER * INTEG NOP LDA LNGTH SET TO CONVERT FROM ASCII TO INTEGER CMA,INA STA LNTH CLA STA IBYTE LDA INX STA INTAD INTLP JSB INTX BEGIN TO CONVERT DATA DEF RTINT INTIO NOP INTAD NOP DEF IBYTE RTINT LDA FIRST SEE IF WE ARE RETRIEVING PLOT UNITS CPA OP JMP FIXIT YES CONIN ISZ INTAD ISZ LNTH JMP INTLP CONTINUE RTING JMP INTEG,I SKP * * FIXIT * FIXIT LDA INTAD,I CONVERT INTEGER TO FLOATING POINT JSB FLOAT DST INTAD,I ISZ INTAD ISZ LNTH JMP CONIN CONTINUE * * GB2 -- TAKE VALUES PLACED IN INTX1(1) TO INTX1(LNGTH) AND * TRANSFER THIS DATA TO GICB. * GB2 NOP STA GCBCD JSB GCBIM TRANSFER DATA TO AGL DEF RTGB2 DEF GCBCD DEF .1 DEF INTX1 DEF LNGTH DEF .2 RTGB2 JMP GB2,I * * GB1 -- RETRIEVE DATA FROM GICB AND PLACE IT IN INTX1(1) TO * INTX1(LNTH) * GB1 NOP STA GCBCD GCB POINTER JSB GCBIM RETRIEVE INTEGER VALUES FROM DEF RTGB1 GCB DEF GCBCD DEF .1 DEF INTX1 DEF LNTH DEF .1 RTGB1 JMP GB1,I * * FIN -- 1) CONVERTS INTEGERS TO ASCII * 2) TRANSFERS THIS ASCII TO THE DEVICE (VIA OUTPT). * 3) RETURNS TO CALLER * FIN NOP JSB CONVT DEF RTCON DEF INTX2 FWA FOR INTEGERS TO BE CONVERTED DEF IOBUF,I I O BUFFER DEF NBYTE DEF LNGTH RTCON JSB TRBYT INSERT TERMINATOR LDA NBYTE LDB .2 JSB OUTPT RTFIN JMP FIN,I SKP * * TRBYT * TRBYT NOP INSERT TERMINATOR INTO OUTPUT BUFFER LDA TERM SEMI-COLON JSB PTBYT RTTBT JMP TRBYT,I * * PTBYT * PTBYT NOP STA BITE JSB UPDTE UPDATE ADDRESS COUNTER (ADCNT) JSB BYTE DEF RTBYT DEF NBYTE DEF BITE DEF ADCNT,I RTBYT ISZ NBYTE JSB UPDTE RTPBT JMP PTBYT,I * BITE NOP * * UPDTE * UPDTE NOP LDA NBYTE CLE,ERA ADA IOBUF STA ADCNT RTUDT JMP UPDTE,I * * OUTPT * OUTPT NOP I/O TRANSFER ROUTINE STB RW LDB TERM CPB .137 CHECK IF SUPRESS CRLF ALREADY HERE JMP *+2 YES, DONT INCREMENT CONUT INA GOING TO ADD SUPRESS CMA,INA STA IOCNT COUNT OF TRANSFER IN CHARACTERS LDA .137 NEED SUPRESS JSB PTBYT STORE IT JSB EXEC DEF RTOUT DEF RW DEF LUN IOB NOP DEF IOCNT RTOUT JMP OUTPT,I SKP * * EMULATORS * EML07 NOP JSB SETUP GO GET IOBUF,IOBL,LUN AND FXD N LDA GIC CPA .177 JMP ERRCK LDA DCTAD EMULATOR NUMBER (NEGATIVE) CMA,INA STA B LDA EM0 TOP OF LIST OF EMULATORS AND OTHER THINGS. JSB INDCK GET RID OF INDIRECT BIT ADA B COMPUTE POINTER LDB LNGTH INB STB LNTH LDA A,I JMP A,I * * EM0 DEF * DEF EMUL1 DEF EMUL2 DEF EMUL3 DEF EMUL4 DEF EMUL5 DEF EMUL6 DEF EMUL7 * * EMULATOR #1 -- GET DEVICE ID * EMUL1 LDA IDCD LDB DF3 JSB GB JMP EML07,I * IDCD DEF .9874 .9874 ASC 3,9874A SKP * * EMULATOR #2 -- DIGITIZE * EMUL2 NOP EM4LP LDA OS OUTPUT STATUS JSB PROUT LDA .40 NOW CHECK STATUS WORD BIT 2 TO SEE IF POINT LDB .1 JSB OUTPT HAS BEEN ENTERRED LDA .1 STA LNGTH STA LNTH JSB INTEG CONVERT ASCII TO INTEGER LDA INTX1 AND .4 SZA JMP GETPT BIT 2 IS SET GO GET POINT JMP EM4LP CONTINUE LOOPING UNTIL WHATS -ITS ENTERS POINT GETPT LDA OD OUTPUT DIGITIZED POINT JSB PROUT V LDA .40 LDB .1 JSB OUTPT LDA .4 STA LNGTH JSB INTEG LDA .3 RESET LENGTH TO EXPECTED 3 PARAMETERS STA LNGTH LDA .16 JSB GB2 JMP EML07,I * * PROUT * PROUT NOP JSB WRDST JSB TRBYT LDA .3 LDB .2 JSB OUTPT CLA STA NBYTE LDA IOBUF STA ADCNT RTPRO JMP PROUT,I * OD ASC 1,OD OS ASC 1,OS SKP * * EMULATOR #3 -- FLOAT TO ASCII * EMUL3 LDA .3 ETX STA TERM LDA LB JSB WRDST LDA .16 JSB GB1 JSB GLIDE JSB TRBYT JSB NBYTE LDB .2 JSB OUTPT JMP EML07,I LB ASC 1,LB * * GLIDE -- FLOAT TO ASCII CONVERSION * GLIDE NOP JSB FLTAS DEF RTGLD DEF INTX2 DEF IOBUF,I DEF NBYTE DEF FXDN F7.N DEF SKPBK RTGLD JMP GLIDE,I * * EMULATOR #4 -- GET DISPLAY SIZE IN MM * EMUL4 LDA SIZMM LENGTH LDB DF8 JSB GB JMP EML07,I * SIZMM DEF SZMM * * EMULATOR #5 -- SET P1,P2 * EMUL5 LDA .16 JSB GB1 GET G1,G2 LDA IP JSB WRDST JSB FIN JMP EML07,I * IP ASC 1,IP SKP * * EMULATOR #6 -- DEVICE CLEARING CAPABILITY * EMUL6 LDA DVCLR NO CLEAR LDB DF1 JSB GB JMP EML07,I * * EMULATOR #7 -- DEVICE HARD CLIPPING CAPABILITY * EMUL7 LDA DF1 LDB DF1 JSB GB JMP EML07,I SKP * * ERROR CHECKING * ERRCK JSB EXEC SELECT DEVICE CLEAR DEF *+3 DEF .3 DEF LUN * LDA OE CLEAR OUT PENDING ERROR JSB WRDST JSB TRBYT LDA NBYTE LDB .2 JSB OUTPT LDA .40 LDB .1 JSB OUTPT CLA STA NBYTE LDA IOBUF STA ADCNT * LDA OI SEND OUT ID AND SEE IF IT FLIES JSB WRDSoqT JSB TRBYT LDA NBYTE LDB .2 JSB OUTPT CLA STA NBYTE LDA IOBUF STA ADCNT * LDA OE JSB WRDST JSB TRBYT LDA NBYTE LDB .2 JSB OUTPT LDA .40 NOW EXAMINE STATUS WORD LDB .1 JSB OUTPT LDA .1 STA LNGTH JSB INTEG CONVERT TO INTEGER LDA INTX1 CHECK BIT 1 AND .1 SZA JMP ERRPT GOT PROBLEMS CLA STA NBYTE REINITIALIZE BYTE COUNT LDA IOBUF STA ADCNT REINITIALIZE ADDR CTR TO TOP OF BUFFER SKP * LDA OI JSB WRDST JSB TRBYT LDA NBYTE LDB .2 JSB OUTPT LDA .40 LDB .1 JSB OUTPT LDA .1 STA LNGTH JSB INTEG LDA INTX1 JMP EML07,I OKAY ERRPT LDA .3 JMP EML07,I * OE ASC 1,OE OI ASC 1,OI * * GB * GB NOP STA ADDR ADDRESS OF DATA STB NUM NUMBER OF DATA ITEMS JSB GCBIM DEF *+6 GB16 DEF .16 DEF .1 ADDR NOP NUM NOP DEF .2 RTGB JMP GB,I * * WRDST -- STORE A WORD INTO THE IOBUF * WRDST NOP STA ADCNT,I ISZ ADCNT ISZ NBYTE ISZ NBYTE RTWRD JMP WRDST,I SKP * * CONSTANTS AND TEMPORARY STORAGE * A EQU 0 B EQU 1 NBYTE NOP LUN NOP IOBUF NOP IOBL NOP FXDN NOP FIRST NOP INTX1 NOP INTX2 NOP INTX3 NOP INTX4 NOP PORGX BSS 2 PORGY BSS 2 INTXX BSS 4 RW NOP IOCNT NOP TEMP BSS 2 * * DO NOT CHANGE POSITION OF THESE CONSTANTS * .0 OCT 0 .1 OCT 1 .2 OCT 2 .4 OCT 4 .26 DEC 26 .16 DEC 16 .32 DEC 32 .3 OCT 3 SEMCL OCT 73 .137 OCT 137 .20 DEC 20 .40 DEC 40 .5 OCT 5 INX1 DEF INTX4 INX DEF INTX1 .7 DEC 7 TERM NOP DF3 DEF .3 .600 OCT 6000 SZMM DEC 0. ORIGIN 0.,0. DEC 0. DEC 435. UPPER RIGHT 43%#*($5.,315. .315 DEC 315. DVCLR DEF .2 DF8 DEF .8 .8 DEC 8 CHSLT DEF .155 .155 DEC 1.56 89 DEGREES DEC -1.56 .03 OCT 1400 COMA OCT 54 M7 OCT -7 .177 OCT 177 GCBCD NOP DF4 DEF .4 DF2 DEF .2 DF1 DEF .1 DF0 DEF .0 ADCNT NOP IBYTE NOP LNTH NOP SKPBK NOP M1 OCT -1 .6 DEC 6 .13 DEC 13 END $%* X d 92840-18092 1840 S C0122 &DVG05 7221A DEVICE SUBRT SRC             H0101 ASMB,R,F,L,C * * * *************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * *************************************************************** * * * * * * * NAME: DVG05 * * SOURCE: 92840-18092 * * RELOC: 92840-16011 * * * * * * * *************************************************************** * NAM DVG05,7 92840-16011 REV.1840 780811 EXT EXEC,GCBIM EXT EMULX EXT FLTAS EXT EXEC EXT INTX EXT .IENT EXT GRSTS EXT DCTIM EXT LNGTH,GIC,DCTAD ENT DVG05 * * THIS IS THE DEVICE SUBROUTINE FOR THE HP 7221A GRAPHICS * PLOTTER. THIS ROUTINE ALONG WITH DVR05 CONTROL THE PICTURE * DRAWING ON THE PLOTTER. * * DVG05 NOP CLA INITIALIZE THE VARIOUS FLAGS STA RWFLG STA FGMBA FLAG MULTIPLE BYTE ANGLE 0=NOT FROM MBA 1=YES STA MBAOF FLAG TO SET BIT 16 OF MBN 0=NO SET 1=YES SET JSB DCTIM GET GIC LNGTH,DCTAD * * THIS IS WHERE WE NEED TO CHECK IF GIC = 177 IF SO * NEED TO DO A LOT OF INTITIALIZING * JSB BUFCK NEED TO CHECK IF BUFFERING IS IN EFFECT LDA GIC CHECK FOR INTIAL COMMAND CPA B177 IS IT THE FIRST ONE JMP INIT YES, CHECK THE SIGNON AND THEN EXIT FROM DRIVER LDA .1 READ REQUEST JSB GB32 GO AND READ THE GLOBALS JSB GBLUN GET THE LUN, BUFFER ADDRESS, AND BUFFER LENGTH LDA LPLCM CHECK TO SEE IF PREVIOUS COMMAND WAS LABELING CPA .N2 WAS IT LABELING?? JMP *+2 YES, PROCEED TO OUTPUT A ETX TO TURN OFF LABELING JMP CONTB NO, CONTINUE ON NORMALLY LDA .ETX POINTER TO ETX STA IOB LDA .8 NUMBER OF BYTES LDB .2 WRITE IT OUT JSB OUTPT LDA .N1 NEED TO RESET THE POINTER STA LPLCM FOR LAST PLOTTER COMMAND NON-DRAW CONTB LDA BUFFG NEED TO CHECK IF BUFFERING IS IN EFFECT SZA JMP CONTA YES, BUFFERING THUS WE DO NOT NEED TO PUB ESC.( IN CLA STA CBFCT CLEAR THE COMPUTER BUFFER FLAG LDA ESC. LOAD THE FWA OF THE ESC.( SEQUENCE LDB .3 THERE ARE THREE BYTES JSB TRANS STORE INTO THE BUFFER CONTA LDA DCTAD START CHECKING FOR TYPE OF COMMAND STRING SSA EMULATOR? JMP EMULT YES SZA,RSS A NOP? JMP EXIT1 YES, A NOP SO UPDATE GLOBAL AND EXIT CONT LDB DCTAD ACTUAL COMMAND ADDRESS LDA B,I READ LENGHT OF STRING SSA,RSS READ OR WRITE? JMP CONT0 READ,SET RWFLG=0 ISZ RWFLG WRITE,SET RWFLG=+1 CMA,INA SET BYTE COUNTER POSITVE CONT0 STA NBYTE STORE POSITIVE BYTE COUNTER LDA B INB LDA B,I LOAD THE INFORMATION TYPE STA TYPE LDA RWFLG SZA READ? JMP CONT1 NO, CONTINUE INB YES,NEED TO GET THE NEXT WORD LDA B,I YES, NEED TO LOAD THE INSTRUCTION TYPE FOR READS STA INTYP THIS IS THE LETTER OF THE REAL TIME COMMAND CONT1 INB GET FIRST WORD OF COMMAND STRING STB DCTAD NOW DCTAD POINTS TO THE FIRST COMMAND STRING STB CMDAD STORE AWAY THE COMMAVND STRING ADDRESS LDA TYPE IS TYPE=0 SZA,RSS JMP LITRT YES, GO TO LITERAL RETURN TO COMPUTER LDA CMDAD LOAD THE STARTING ADDRESS OF TRANSFER LDB NBYTE NUMBER OF BYTES TO TRANSFER CPB B340 NULL LENGTH COMMAND STRING JMP *+2 YES, DON'T TRANSFER ANYTHING JSB TRANS TRANSFER THE DATA LDA RWFLG SZA,RSS IS IT A READ CONT2 JSB RITE YES, TRANSMIT THE BUFFER CONT3 LDA RWFLG SZA,RSS IS IT A READ REQUEST JSB RDCHK YES, GO OFF AND READ THE INPUT LDA .N1 LAST COMMAND FLAG LDB TYPE SSB IS THERE ANY THING SPECIAL TO DO JMP EXIT NO, GO HOME SKP SPC 3 * * * SPECIAL MODE LDA .SPEC LOAD THE FWA OF THE SPECIAL CASES ADA B LOAD WHAT WAS IN TYPE TO FWA TO GET INDEX PROPERLY LDB A,I NEED TO LOAD THE POINTER TO THE ROUTINE JMP B,I GO TO THE PROPER ROUTINE NOW * * * * RESET SPECIAL #1 * RDVAR IS FILLED WITH * GX1,GY1,GX2,GY2 RESPECTIVELY * * NOW WE NEED TO LOAD ~W INTO THE BUFFER * * RESET LDA .RSET INSERT THE DEFAULTS (TILDE,UNDERSCORE) INIT LDB .4 4 BYTES LONG (TILDE,W) SET GRAPHIC LIMITS JSB TRANS TRANSFER THE DATA * * NOW PUT IN THE PARAMETERS FOR GRAPH LIMITS * LDA RWD1 CONVERT GX1,GY1 LDB RWD2 TO MBP STA GX1MU STORE GX1 LOWER LEFT AWAY STB GY1MU STORE GY1 AWAY JSB MBP LDA RWD3 CONVERT GX2,GY2 LDB RWD4 TO MBP STA GX2MU STORE GX2 UPPER RIGHT AWAY STA GY2MU STORE GY2 AWAY JSB MBP * LDA .RSET GET FWA OF THE RESET PREAMBLES ADA .2 GET THE TILDE,S FOR SCALING LDB .2 TWO BYTES LONG JSB TRANS GO AND PUT IT IN THE BUFFER * * LDA RWD1 A=GX2-GX1 CMA,INA ADA RWD3 SSA NEED ABSOLUTE VAbLUE OF (GX2-GX1) CMA,INA LDB RWD2 B=GY2-GY1 CMB,INB ADB RWD4 SSB NEED ABSOLUTE VALUE (GY2-GY1) CMB,INB JSB MBP CONVERT TO MBP LDA .RSET GET FWA OF THE RESET PREAMBLES ADA .3 LOOK FOR THE RESET/CHARACTER SIZE LDB .5 IT IS 5 BYTES LONG JSB TRANS GO AND PUT IT IN THE BUFFER LDA .N1 LOAD THE LAST PLOTTER COMMAND TO NON-DRAW JMP EXIT * * * NUMBER 8 * RESET P1,P2 * * GX1,GY1,GX2,GY2 IN RDVAR *NEED TO SEND BACK GX3-GX1, GY4-GY2 * AND UPDATE ~S UPDATE GLOBALS * * GTG12 LDA .RSET GET FWA OF THE ~S PREAMBLE ADA .2 MOVE POINTER TO THE ~S PART LDB .2 G1,G2 SCALLING JSB TRANS PUT (0,GX2-GX1 IN ADDR) LDA RWD1 LOAD THE GX1 LOWER LEFT COORDINATE STA GX1MU STORE IN GLOBAL VARIABLE FLT DST INTX1 PUT IT AWAY TO SEND BACK TO THE COMPUTER LDA RWD2 LOAD THE GY1 LOWER LEFT COORDINATE STA GY1MU GLOBAL FLT DST INTX3 PUT IN BUFFER LDA RWD3 LOAD THE GX2 UPPER RIGHT COORDINATE STA GX2MU GLOBAL FLT DST INTX5 PUT IN BUFFER LDA RWD4 LOAD THE GY2 UPPER RIGHT COORDINATE STA GY2MU GLOBAL FLT DST INTX7 PUT IN BUFFER LDA .RDBF THE BUFFER THE FLT PT NUMBERS ARE LDB .8 8 WORDS TO RETURN JSB GBRET LDB RWD2 B=GY2-GY1 CMB,INB ADB RWD4 SSB RWD4=ABS(GY2-GY1) CMB,INB LDA RWD1 A=GX2-GX1 CMA,INA ADA RWD3 SSA RWD3=ABS(GX2-GX1) CMA,INA JSB MBP PUT THE SCALING DATA AWAY LDA .N1 LAST PLOTTER COMMAND IS A NON-DRAW JMP EXIT RETURN SPC 3 * * * * NUMBER 10 AND 11 * * OUTPUT CURRENT PEN POSITION IN PU * * X,Y PEN STATUS IN RDVAR * * qRWD1=X POSITION IN MACHINE UNITS * RWD2=Y POSITION IN MACHINE UNITS * RWD3=PEN STATUS 0=UP;1=DOWN * * OUTCP LDB .3 NUMBER OF RETURN PARAMETERS LDA RDVAR FWA OF THE DATA JSB GBRET STORE IT IN THE GCBIM LDA .N1 ASSUME THEY SHOULD START OVER FOR LAST PLOT CMD JMP EXIT * * * * NUMBER 12 DIGITIZE * OUTPUT THE DIGITIZED PEN POSITION IN MU. * NEED TO CONVERT PU TO MU * SEND BACK THE RWD1=X POSITION IN MU. * RWD2=Y POSITION IN MU. * RWD3=PEN STATUS 0=UP 1=DOWN * * DIGIT LDA GX1MU LOAD THE GRAPHIC LIMIT X VALUE ADA RWD1 A = GX1MU + CURRENT X POSITION STA RWD1 * CONVERT THE MU LDA GY1MU VALUE TO PU BY OFFSETTING LL AMOUNT ADA RWD2 B = GX2MU + CURRENT Y POSITION STA RWD2 PUT THE Y PLOTTER UNIT VALUE AWAY LDA RDVAR GET THE FWA OF THE BUFFER TO BE TRANSFERED LDB .3 THREE LONG JSB GBRET SEND IT BACK TO THE GICB LDA .N1 ASSUME SHOULD START FOR LAST PLOTTER COMMAND JMP EXIT RETURN * * * * * NUMBER 15 * SET CHARACTER SLANT ON * NEED TO CONVERT TO MBA * * SLANT LDA .16 NEED TO GET THE SLANT ANGLE PARAMETER FROM GCBIM LDB .3 THERE ARE THREE WORDS TO GET JSB GBGET GET IT DLD SLANG LOAD IN 90 DEGREES IN RADIANS FSB INTX2 7221A SLANT = 90 DEGREES - AGL SLANT ANGLE JSB MBA LDA .N1 LAST PLOTTER COMMAND IS NOT-DRAW JMP EXIT * * NUMBER 17 * * CONVERT X,Y PARAMETER IN GCBIM TO MBP * FLOATING POINT PARAMETERS * MBPOT LDA .16 GET THE FLOATING POINT PARAMETERS LDB .5 THERE ARE FIVE WORDS JSB GBGET DLD INTX4 LOAD THE Y PORTION OF MBP JSB .IENT INTEGERIZE THE FLOATING POINT NUMBER NOP STA INTX1  STORE INTEGER VALUE AWAY DLD INTX2 LOAD THE Y PROTION OF MBP JSB .IENT INTEGERIZE THE FLOATING POINT NUMBER NOP LDB INTX1 JSB MBP CONVERT THE DATA LDA .N1 LAST PLOTTER COMMAND IS A NON-DRAW JMP EXIT RETURN * * * NUMBER 24 * * CONVERT X,Y PARAMETER IN GICBM MBP * * THIS IS THE INTEGER FORMAT * * MBPBN LDA .16 GET THE PARAMETERS FROM THE GIC LDB .3 THERE ARE TWO INTEGER FORMAT NUMBERS + THE HEADER JSB GBGET LDA INTX2 GET THE X VALUE LDB INTX3 GET THE Y VALUE JSB MBP CONVERT THE DATA TO MBP FORMAT LDA .N1 LAST PLOTTER COMMND IS A NON-DRAW JMP EXIT RETURN * * * * NUMBER 28 * SELECT PEN (1-N) * * SLPEN LDA .16 SELECT PEN (); GET THE DATA FROM GIC LDB .2 THERE IS THE HEADER AND THE PEN NUMBER JSB GBGET LDA INTX2 LOAD THE PEN NUMBER JSB SBN CONVERT TO BINARY SYNTAX LDA .N1 LAST PLOTTER COMMAND IS A NON-DRAW JMP EXIT RETURN * * * * NUMBER 31 AND 32 * * ENTER RWD1 = LINETYPE * NEED TO FIND OUT IF * LNGHT=1 IMPLIES DEFAULT LENGTH * LNGTH=2 IMPLIES SPECIFIED LENGTH * * DASHL LDA .16 GET PARAMETERS FROM GIC LDB .4 THERE ARE 4 WORDS HEADER,LINETYPE,FL PT LENGTH JSB GBGET LDB INTX2 LOAD THE LINE TYPE NUMBER IN ADB .LNTP ADD TO INDEX OF LINETYPES LDA B,I LOAD THE POINTER TO # OF BYTES LDB A,I NOW LOAD THE NUMBER OF BYTES IN INA INCREMENT OVER THE 1ST WORD OF INSTRUCTION STRING JSB TRANS GO AND TRANSMIT IT * * NOW CHECK FOR LINE TYPE * LDA INTX2 LOAD THE LINE TYPE AGAIN CPA .5 IS THE LINETYPE (DOTS AT END POINTS) JMP DASH0 YES, THE LENGTH IS ENCODED AREADY IN THE STRING CPA .0y IS THE LINE TYPE (SOLID LINES) JMP DASH0 YES, THE LENGTH IS NOT SENT OUT CPA .1 IS THE LINETYPE (DIME LINES) JMP DASH0 YES, THE LENGTH IS NOT SENT OUT LDA .460 LOAD THE DEFAULT LENGTH LDB GIC LOAD THE TYPE OF COMMAND CPB .31 IS A DASHLINE WITH DEFULT LENGTH JMP DASH1 YES, USE .460 AS THE DEFAULT LENGTH DLD INTX3 LOAD THE FLOATING POINT NUMBER IN A/B JSB .IENT INTEGERIZE NOP DASH1 JSB MBN CONVERT DATA DASH0 LDA .N1 LAST PLOTTER COMMAND IS A NON-DRAW JMP EXIT RETURN * * * * NUMBER 43 * POSITION CURSOR ABSOLUE WITH PEN UP * PEN = CURSOR ON THIS PLOTTER, THUS WE ONLY NEED TO * USE REGULAR MOVE; THIS ACTUAL USES THE MBPBN ROUTINE * * * MVCUR LDA .16 GET THE PARAMETERS FROM THE GIC LDB .3 THERE ARE TWO INTEGER FORMATS NUMBER +HEADER JSB GBGET LDA GX1MU LOAD THE OFFSET CMA,INA A = X PU - X OFFSET ADA INTX2 LDB GY1MU LOAD THE Y OFFSET CMB,INB B = Y PU - Y OFFSET ADB INTX3 JSB MBP CONVER THE DATA TO MBP FORMAT LDA .N1 LAST PLOTTER COMMAND IS A NON-DRAW JMP EXIT RETURN * * * * * * NUMBER 45 * USED TO SET THE GRAPHIC LIMITS G1 AND G2 * THE PARAMETERS ARE INTEGER FROM THE GIC * * * SG1G2 LDA .16 SET G1 AND G2; GET THE PARAMETERS LDB .5 FIVE WORDS INCLUDING HEADER JSB GBGET LDA INTX2 GET GX1 LDB INTX3 GET GY1 STA GX1MU STORE GLOBAL GX1 AWAY STB GY1MU STORE GLOBAL GY2 LOWER LEFT AWAY JSB MBP GO CONVERT THE LOWER LEFT HAND CORNER LDA INTX4 GET GX2 LDB INTX5 GET GY2 STA GX2MU STORE GLOBAL GX2 UPPER RIGHT AWAY STB GY2MU STORE GLOBAL GY2 JSB MBP GO CONVERT THE UPPER RIGHT HAND CORNER LDA .RSET NEED TO LOAD THE GRIDDING FACTOR ADA .2 THIS IS A TILDE,S INSTRUCTION LDB .2 THERE ARE TWO BYTES JSB TRANS LDA INTX2 NEED TO CALCULATE THE GRID RANGE CMA,INA A = ABS( GX2 - GX1) ADA INTX4 SSA MAKE SURE ITS A POSITIVE RANGE CMA,INA LDB INTX3 NEED TO CALCULATE THE Y COMPONENT CMB,INB B = ABS( GY2 - GY1) ADB INTX5 SSB MAKE SURE ITS A POSITIVE RANGE CMB,INB JSB MBP LDA .N1 LAST PLOTTER COMMAND IS A NON-DRAW JMP EXIT SKP SPC 3 * * A = EMULATOR # COMES IN AS A NEGATIVE NUMBER * * THIS IS USED TO FIND THE CORRECT EMULATOR TO EXECUTE * * EMULT CMA,INA THIS IS THE EMULATOR SECTION LDB EM0 FWA OF EMULATOR POINTERS ADA B NOW INDEX TO THE PROPER PLACE LDB A,I NEED TO LOAD THE POINTER TO THE ROUTINE JMP B,I JUMP TO THE PROPER ROUTINE SPC 3 * * * * NUMBER 4 * TRANSMIT I/O BUFFER * * ONLY NEED TO EMPTY THE BUFFER IF IT HAS ANYTHING * * XMIT JSB RITE GO AND EMPTY THE COMPUTER BUFFER LDA .N1 ASSUME SHOULD START FOR LAST PLOTTER COMMAND JMP EXIT * * * * * NUMBER 5 * HOME PEN * * GET THE UPPER RIGHT HARD CLIP REGION * * HOME LDA .P LOAD SMALL P IN BUFFER LDB .1 1 BYTE LONG JSB TRANS LDA GX1MU NEED TO CALCULATE THE RANGE CMA,INA A=ABS(GX2-GX1) ADA GX2MU SSA CMA,INA LDB GY1MU NEED TO CALUCLATE Y RANGE CMB,INB B=ABS(GY2-GY1) ADB GY2MU SSB CMB,INB JSB MBP CONVERT IT LDA .1 LAST PLOTTER COMMAND WAS A MOVE + PARAMETER JMP EXIT RETURN * * * NUMBER 5 * GET CHARACTER SPACING/WIDTH * * NEED TO GET OLD VALUE * * GTCHR JSB GCBIM CALL GCBIM(7,1,(),4,1) DEF *+6 DEF .7 { GET CHARACTER SPACING HEIGHT/WIDTH DEF .1 DEF INTX1 PUT INTO BUFFER LOCATION DEF .4 NEED TWO FLOATING POINT NUMBERS DEF .1 READ * * NOW CHECK FOR DEFAULTS * DLD INTX1 WIDTH SZA,RSS IS WIDTH = 0 SZB JMP EML1 NOT EQUAL 0, THUS USE GICB VALUES. DLD INTX3 CHECK THE HEIGHT SZA,RSS IS THE HEIGHT = 0 SZB JMP EML1 # = 0 THUS USE THESE VALUES DLD CHRW THUS WIDTH AND HEIGHT = 0 IMPLY DEFAULTS DST INTX1 STORE THE DEFAULT WIDTH DLD CHRH DST INTX3 STORE THE DEFAULT WIDTH EML1 LDA .RDBF LOCATION OF BUFFER LDB .4 FOUR ITEMS TO BE TRANSFERRED JSB GBRET TRANSFER TO GICB LDA .N1 ASSUME SHOULD START OVER FOR LAST PLOTTER CMD JMP EXIT RETURN CHRW DEC 125. CHARACTER WIDTH CHRH DEC 250. CHARACTER HEIGHT SPC 3 * * * * NUMBER 35 * PLOT ABSOLUTE * * CPENS = 0 IMPLIES UP * 1 IMPLIES DOWN * * LPLCM = -1 IMPLIES NON-MOVE OR NON-DRAW COMMAND * 1 IMPLIES DRAW AND MOVE WITH PARAMETERS * PLABS LDB CPENS PLOAT ABSOLUTE, LOAD COMPUTER PEN STATUS 0=UP,1=DN LDA BUFFG BUFFER FLAG 0=NO BUFFERING 1 = YES BUFFERING SZA,RSS IS THERE BUFFERING JMP PLAB3 NO,THUS WE NEED TO PUT IN THE MOVE OR DRAW IN CPB LPLCM YES, CHECK FOR REDUNDENT DRAWS, PEN AND LAST CMD = JMP PLAB2 YES, JUST NEED TO CONVERT DATA TO MBP FORM PLAB3 LDA .P NO, NEED TO INSERT P/Q SZB IS IT A DRAW OR A MOVE?? LDA .Q YES, USE DRAW LDB .1 1 BYTE LONG JSB TRANS INSERT COMMAND PLAB2 LDB LNGTH LOAD THE NUMBER OF PARAMETERS IN WORDS INB NEED TO ADD ONE FOR THE HEADER INFORMATION LDA .16 JSB GBGET GO AND GET THE PASSED PARAMETERS LDA .RDBF NEED TO SET-UP THE INDEX POINTER =OINA MOVE ONE PAST THE HEADER INFORMATION STA PLTCT PLOT ABSOLUTE POINTER LDB LNGTH NOW SET UP THE LOOP CONTROL COUNTER CMB,INB STB LNTH LENTH OF THE LOOP COUNTER PLAB1 LDA GX1MU NEED TO CALCULATE THE P.U. FROM M.U. CMA,INA X MU = X PU - X OFFSET(GX1) ADA PLTCT,I ISZ PLTCT MOVE POINTER TO THE LDB GY1MU NEED TO CALCULATE PU FROM MU CMB,INB Y MU = Y PU - Y OFFSET(GY1) ADB PLTCT,I ISZ PLTCT SET TO THE NEXT COORDINATE PAIR JSB MBP GO AND CONVERT LDA LNTH CHECK TO SEE IF WE HAVE ANY MORE PARAMETERS ADA .2 NOTE THIS IS A DO UNTIL STRUCTURE AND THUS STA LNTH ASSUME WE SHOULD GO THROUGH AT LEAST ONCE SSA ARE YES DONE?? JMP PLAB1 NO, DO THE NEXT PAIR LDA .1 YES, LOAD DRAW AS THE LAST PLOTTER COMMAND JMP EXIT RETURN SPC 3 * * * * NUMBER 38 AND 39 * SHORT AND LONG LABEL * * * * LABEL JSB CKANG LABEL MODE AND NEED TO CHECK THE PLOTTER ANGLE JSB RITE GO AND OUTPUT THE CURRENT BUFFER LDA .N2 LAST PLOTTER COMMAND IS A LABEL ON MODE STA LPLCM WILL BE USED AS FLAG IN READ NOT TO TURN OFF PLOTTER JSB RWAIT GO AND WAIT UNTIL THE PLOTTER BUFFER IS EMPTY LDA .LLAB IT IS A LONG LABEL STA IOB STORE AWAY FWA FOR OUTPUT LDA .5 NUMBER OF BYTES TO OUTPUT LDB .2 WRITE JSB OUTPT WRITE IT OUT TO THE PLOTTER INHIBIT CR/LF LDA .0 SINCE WE DON'T KNOW HOW MUCH THE USER WILL PUT INTO STA PBFLN PLOTTER BUFFER ASSUME THERE IS NO SPACE JMP EXIT1 BY PASS THE OUTPUT OF EXIT * * * NEED TO LOOK AT THIS ALOT MORE * * NUMBER 42 * FLOAT ASCII * * CONVT JSB CKANG NEED TO CHECK THE PLOTTER ANGLE JSB RITE NEED TO FLUSH OUT THE COMPUTER BUFFER SO WE CAN *  GUARANTEE THE ASCII LABEL WILL BE SENT CONTINOUS. LDA .LLAB CONVERT FLOATING POINT TO ASCII LDB .5 JSB TRANS TRANFER SHORT LABEL OVER LDA .16 NEED TO GET THE FLOATING POINT NUMBER LDB .3 1 WORD FOR HEADER + 2 WORDS FOR FLT PT NUMBER JSB GBGET GET NUMBER DLD INTX2 GET THE NUMBER AND PUT INTO THE SMALLER BUFFER DST RWD1 THIS WILL ALLOW FLOAT TO ASCII ROUTINE MORE SPACE LDA .0 LOAD THE BYTE COUNTER STA TEMP USE A TEMPORARY VARIABLE CAUTION JSB FLTAS FLOAT TO ASCII ROUTINE DEF RTFL RETURN POINT DEF RWD1 THE NUMBER TO BE CONVERTED (FROM BUFFER) DEF INTX1 THE CONVERTED ASCII NUMBER (TO BUFFER) DEF TEMP THE NUMBER OF BYTES DEF FXDN THE FLOATING POINT FRACTION REPRESENTATION DEF SKPBK USE FOR FUTURE ENHANCEMENTS RTFL LDA .RDBF POINTER TO THE ASCII NUMBER BUFFER LDB TEMP THE NUMBER OF BYTES TO TRANSFER JSB TRANS LDA DFETX POINTER TO THE B1400 WHICH IS A ETX. LDB .1 NEED ONLY ONE BYTE, THIS IS A TERMINATOR JSB TRANS FOR THE SHORT LABEL MODE LDA .N1 JMP EXIT * * * * CKANG NOP CHECK ANGLE OF PLOTTER COMPARED TO LABEL LDA .22 GET THE LABEL ANGLE LDB .2 TWO WORDS LONG; REPRESENTS A FLT PT NUMBER JSB GBGET LDA INTX1 GET THE ANGLE OF ROTATION CPA PANG1 DOES LABEL ANGLE = PLOTTER ANGLE JMP *+2 YES THE FIRST PART DOES GO CHECK 2 WORD JMP SLAN0 NO, GO AND SEND THE ANGLE TO THE PLOTTER LDB INTX2 GO AND CHECK THE SECOND WORD OF FLT PT # CPB PANG2 ARE THE TWO ANGLES EQUAL JMP CKAN1 YES, AND SKIP OUTPUTTING THE ANGLE TO PLOTTER SLAN0 LDA .WW WRITE OUT "WW"; SEND LABEL ANGLE LDB .2 TWO BYTE LONG JSB TRANS LOAD PRE-AMBLE DLD INTX1 LOAD AND CONVERT JSB MBA CO_NVERT TO MULTIBYTE ANGLE DLD INTX1 UPDATE GLOBAL DST PANG1 PLOTTER ANGLE CKAN1 JMP CKANG,I RETURN SPC 3 * * * NUMBER 2 * USED TO DEFAULT LL AND UR * * DFG12 LDA .520 NEED TO UPDATE THE GLOBALS STA GX1MU X LOWER LEFT LDA .1572 ACTUALLY LOADING IN 15720 STA GX2MU X UPPER RIGHT LDA .380 STA GY1MU Y LOWER LEFT LDA .1038 ACTUALLY LOADING IN 10380 STA GY2MU Y UPPER RIGHT LDA .N1 LAST PLOTTER COMMAND WAS NOT A DRAW JMP EXIT RETURN * * * * NUMBER 33 * PEN UP ROUTINE * NEED ONLY TO STORE THE GLOBAL AWAW * CPENS COMPUTER PEN STATUS 0=UP 1=DOWN PENUP CLA SET CPENS=0 IMPLES PEN UP STA CPENS LDA .0 MEANS THE LAST WAS A PEN-UP COMMAND JMP EXIT GO AND UPDATE THE GLOBALS * * * * NUMBER 34 * PEN DOWN ROUTINE * NEED TO ONLY SOTRE THE GLOBALS AWAY * CPENS COMPUTER PEN STATUS 0=UP 1=DOWN * PENDN LDA BUFFG CHECK TO SEE IF WE ARE BUFFERING SZA,RSS IF SO NEED TO CHECK PEN STATUS JMP PEND1 NO, SO GO AHEAD AND INSERT THE LOWER CASE Q LDA LPLCM YES, CHECK THE LAST PLOTTER COMMAND CPA .1 WAS IT A DRAW?? JMP PEND2 YES, DON'T OUTPUT THE LOWER CASE Q PEND1 LDA .Q POINTER TO THE LOWER CASE Q LDB .1 ONE BYTE LONG JSB TRANS OUTPUT IT TO THE BUFFER PEND2 LDA .1 LAST PLOTTER COMMAND STA CPENS COMPUTER PEN STATUS GLOBAL JMP EXIT FINISH IT UP SKP SPC 3 * * SPC 3 * * * * * ENTER A=FWA OF DATA TO INPUT * B=NUMBER OF BYTES * * CBFCT = EXACT NUMBER OF BYTES * CURRENTLY IN THE BUFFER * RANGE 0 TO N RANGE. * * * TRANS NOP x*TRANSFER THE ENTER BUFFER IN A TO IOBUFFER STB BYTES STORE THE NUMBER OF BYTES TO BE TRANSFERRED SZB,RSS ARE THERE ANY BYTES TO BE TRANSFERRED JMP TRANS,I NO, GO BACK STA TEMP7 STORE AWAY THE FWA POINTER JSB CBFCK CHECK THE BUFFER SPACE LDB TEMP7 GET THE FWA POINTER LDA CBFCT GET THE COMPUTER BUFFER COUNT ARS SHIFT THE NUMBER OF BYTES TO NUMBER OF WORDS TO ADA CBFAD THIS POINTS TO FIRST ENTRY STA TEMP9 PTR TO 1ST WORD WITH AVAILABLE SPACE LDA CBFCT IS THERE ODD NUMBER OF BYTES SLA IN THE IO BUFFER?? JMP TRAN3 YES, ODD NUMBER OF BYTES LDA BYTES SET UP THE LOOP COUNTER INA ROUND UP THE THE NEAREST WHOLE INTEGER ARS CMA,INA NEGATE THE LOOP COUNTER STA TLOOP TRAN2 LDA B,I NO, EVEN NUMBER OF BYTES THUS ITS EASY STA TEMP9,I STORE AWAY IN THE IO BUFFER INB INCREMENT THE FROM BUFFER AREA ISZ TEMP9 INCREMENT THE TO BUFFER AREA POINTER ISZ TLOOP ARE WE DONE? JMP TRAN2 NO, GO THRU AGAIN JMP TRAN6 YES, GO AND UPDATE THE GLOBALS TRAN3 LDA BYTES SET UP THE LOOP COUNTER CMA,INA NEGATE THE LOOP COUNTER STA TLOOP TRAN4 LDA B,I LOAD THE WORD FROM BUFFER ALF,ALF NEED THE HIGH BYTE AND LOBYT MASK OFF THE BYTE STA TEMP8 STORE HIBYTE INTO LOW BYTE OF TEMP8 LDA TEMP9,I GET THE TO BUFFER WORD AND MASK OFF HIGH BYTE AND HIBYT IOR TEMP8 STORE HIBYTE INTO LOW BYTE STA TEMP9,I STORE AWAY THE FIRST HALF OF FROM BUFFER WORD ISZ TEMP9 INCREMENT THE TO BUFFER POINTER ISZ TLOOP INDEX LOOP COUNTER JMP *+2 CONTINUE THE LOOP JMP TRAN6 DONE LDA B,I LOAD THE SECOND BYTE UP ALF,ALF MOVE THE HIGH BYTE TO LOW BYTE AND HIBYT GET THE HIGH BYTE STA TEMP9,I STORE AWAY THE HIGH BYTE;WITH LOW BYTE CLEAR INB MOVE TO THE NEXT WORD ISZ TLOOP ARE WE DONE? JMP TRAN4 NO GO THRU THE LOOP AGAIN TRAN6 LDA CBFCT UPDATE THE GLOBAL ADA BYTES STA CBFCT JMP TRANS,I RETURN SPC 3 * * * SPC 3 * * INTIALIZING ROUTINE * THIS IS DONE EVERYTIME THE SYSTEM DOES A RESET * WE NEED TO INIT THE VARIOUS GLOBAL VARIABLES * * * INIT CLA NEED TO INITIALIZE THE GLOBAL FOR DRIVER PACKAGE STA CBFCT UPDATE GLOBALS; COMPUTER BUFFER COUNT STA PANG1 PLOTTER ANGLE FOR CHAR/RELATIVE MOVES STA PANG2 SECOND PART OF THE FLOATING PT. ANGLE STA CPENS COMPUTER PEN STATUS STA GX1MU LOWER LEFT GRAPHIC LIMITS STA GX2MU UPPER RIGHT GRAPHIC LIMITS STA GY1MU LOWER LEFT STA GY2MU UPPER RIGHT LDA .38 NEED TO ASSUME THERE IS SOME SPACE INTIALLY STA PBFLN PLOTTER BUFFER LENGTH LDA .N1 LAST PLOTTER COMMAND IS A NON-DRAW STA LPLCM JSB GBLUN LDA ESC. LOAD THE FWA OF THE ESC.( SEQUENCE LDB .3 THREE BYTES TO TRANSFER JSB TRANS TRANSFER THE ESC SEQ TO THE COMPUTER BUFFER LDA .HAND NEED TO LOAD THE HANDSHAKING STUFF LDB .19 THERE ARE 19 BYTES JSB TRANS GO AND TRANSFER IT JSB EMULX,I INTERROGATE DEVICE COMMAND TABLE CPA .7221 RIGHT COMMAND TABLE?? JMP INIT3 YES, GO AND CHECK PROPER I/O DRIVER LDA .3 NO, REPORT ERROR JMP INIT5 INIT3 JSB IFTTY GO AND CHECK IF DVR05 DEF *+2 DEF LUN LDA DTYPE CPA B2400 IS IT DVR05? JMP INIT4 YES, EVERTHING IS OK LDA .5 NO, REPORT ERROR JMP INIT5 INIT4 CLA EVERYTHING IS OK RETURN A ZERO INIT5 STA INTX1 PUT THE RETURN VARIABLE IN BUFFER LDA .RDBF POINTER TO READ BUlCFFER LDB .1 ONE PARAMETER TO RETURN JSB GBRET RETURN SUBROUTINE LDA .N1 LOAD THE LAST PLOTTER COMMAND MEANS NON-DRAW JMP EXIT EXIT ROUTINE * * IFTTY NOP ENTRY POINT TO GET DRIVER NUMBER DLD IFTTY,I GET RETURN ADDRESS AND LUN STA IFTTY STORE THE RETURN ADDRESS LDA B,I GET THE LOGICAL UNIT NUMBER AND B77 MASK OFF THE TRANSPARENT BIT STA ANLU# SAVE LUN NUMBER JSB EXEC SEE IF THE LU IS INTERACTIVE DEF *+6 DEF D13I STATUS REQUEST DEF ANLU# THE LU WE WANT THE INFO ABOUT DEF YTEMP EQT WORD 5 PLACED HERE DEF DTYPE EQT WORD 4 PLACED HERE(NOT NEEDED) DEF ZTEMP SUB CHANNEL IN LOWER 5 BITS HERE * JMP ITSNT ERROR NOT VALID LUN NUMBER, SEND BACK ZERO LDA YTEMP GET EQT WORD 5 AND MEQT KEEP ONLY THE EQT TYPE FIELD STA DTYPE JMP IFTTY,I GO BACK ITSNT CLA SET NON-INTERACTIVE FLAG JMP IFTTY,I GO BACK * * D13I OCT 100015 EXEC #13., AND ERROR CHECK INVOKED .7221 DEC 7221 NAME OF PLOTTER B2400 OCT 2400 MASK FOR PROPER DRIVER NUMBER (5) MEQT OCT 37400 MASK OFF THE DRIVER NUMBER ANLU# NOP LUN NUMBER TO FIND INFO ABOUT DTYPE NOP TEMPORARY VARABLE YTEMP NOP ZTEMP NOP SPC 3 * * EXIT ROUTINE CHECK NEED TO STORE THE LAST PLOTTER CO * AND CHECK THE BUFFG BUFFER FLAG FOR RITE OR NOT * ALSO UPDATE THE GLOBAL VARIABLES IN GICB * * * A = NUMBER FOR LAST COMMAND * 0 = DRAW * 1 = MOVE * -1 = OTHER COMMANDS * * * CHECK FOR EXIT OUT OF THE ROUTINES EXIT STA LPLCM STORE LAST PLOTTER COMMAND LDA GIC XMIT GIC IF SO WE NEED TO FORCE A LOWER CASE CPA .4 Z IN THERE TO TERMINATE THE TOTAL SEQUENCE JMP EX%ITA PUT THE TERMINATOR IN AND SEND IT OFF LDA BUFFG BUFFER FLAG 0=NO BUFFERING; 1=YES BUFFERING SZA IS THERE BUFFERING JMP EXIT1 YES, DO NOT TRANSMIT THE BUFFER LDA CBFCT LOAD THE COMPUTER BUFFER COUNT CPA .3 CHECK TO SEE IF IT IS AN EMPTY BUFFER JMP EXIT1 YES, IT IS DON'T WRITE ANYTHING OUT EXITA LDA .Z NO, PUT IN TERMINATOR AND TRANSMIT THE BUFFER LDB .1 ONLY ONE LONG JSB TRANS TRANSMIT IT LDA .N1 NEED TO PUT IN NON-DRAW/NON-MOVE STA LPLCM PUT IT AWAW EXIT0 JSB RITE GO AND TRANSMIT THE COMPUTER BUFFER EXIT1 LDA .2 WRITE JSB GB32 UPDATE THE GLOBALS JMP DVG05,I RETURN, AND LET'S GO HOME SPC 3 * * * * * SPC 3 * * * RETURN VALUE IN BUFFER FLAG * BUFFG 0 = NO, BUFFERING * 1 = YES, BUFFERING * * THIS ROUTINE WILL GO AND GET THE BUFFERING STATUS * BUFCK NOP SEE IF BUFFERING IS IN EFFECT JSB GRSTS CHECK TO SEE IF BUFFERING DEF BUFRT IS IN EFFECT DEF .1 GET STATUS DEF B1000 GET BIT 9;BUFFERING STATUS BIT DEF BUFFG RETURN VALUE; 0 =NO; 1=YES; I/O BUFFERING BUFRT JMP BUFCK,I * * * * * * * IS USED TO CHECK FOR COMPUTER BUFFER FULL * * ENTER WITH B = NUMBER OF BYTES TO ADD TO COMPUTER BUFFER * CBFCK NOP CHECK FOR COMPUTER BUFFER FULL ADB .3 B=TOTAL OF COMPUTER BUFFER SPACE NEEDED ADB CBFCT 3 IS ADDED TO END FOR THE ESC . ) SEQUENCE CMB,INB ADD COMPUTER BUFFER COUNT ADB CBFLN B=CBFLN-(CBFCT+ADDITIONAL DATA) SSB IS THERE GOING TO BE ANY OVERFLOW JSB RITE YES; NEED TO OUTPUT THE DATA TO PLOTTER JMP CBFCK,I NO, RETURN * * * * * * * * * * * SPC 3 * * RITE NOP OUTPUT THE COMPUTER BU FFER TO THE PLOTTER LDA .3 NEED TO CHECK FOR AN EMPTY BUFFER CPA CBFCT THERE ARE ALWAYS AT LEAST THREE IN BUFFER JMP RITE,I RETURN JSB CKPSI NEED TO CHECK PLOTTER BUFFER SIZE JSB TRBYT NEED TO ADD TERMINATOR TO END;UPDATE CBFCT LDA CBFAD COMPUTER BUFFER ADDRESS STA IOB LOCATION OF BUFFER TO OUTPUT LDA CBFCT NUMBER OF BYTES LDB .2 WRITE JSB OUTPT LDA CBFCT UPDATE PLOTTER BUFFER LENGTH CMA,INA ADA PBFLN PBFLN=PBFLN-CBFCT STA PBFLN JSB GBLUN GET THE ACTUAL COMPUTER BUFFER ADDRESS LDA CBFAD LDB ESC.1 NEED TO INSERT THE ESC.( SEQUENCE IN I/O BUF STB A,I INA LDB ESC.2 STB A,I LDA .3 THIS IS THE STARTING COMPUTER BUFFER COUNT STA CBFCT RESET THE COMPUTER BUFFER COUNTER JMP RITE,I GO BACK * * * WANT TO MAKE THIS TRANSPARENT TO THE REST OF THE * SYSTEM ,WHICH WILL ENABLE THE ENQ/ACK HANDSHAKE * TO WORK BY TAKING THIS OUT. * * IS THRE ROOM IN THE PLOTTER * * CKPSI NOP CHECK PLOTTER SIZE CKPS LDA CBFCT CMA,INA COMPUTER BUFFER COUNT ADA PBFLN A=PLOTTER BUFFER LENGTH - COMPUTER BUFFER COUNTER SSA,RSS IS THERE ROOM IN THE PLOTTER JMP CKPSI,I YES, GO BACK * NO, NEED TO OUTPUT AS MUCH AS WE CAN, LESS ONE THEN * WE UPDATE THE PTR'S AND COUNTER AND LET THE CALLING * ROUTINE FINISH THE LAST WRITE TO THE DEVICE.. * * * NEED TO FIX THE NEXT ROUTINE UP HAVE A PROBLEM OF OUTPUTING * PARTIAL DATA ARRAY AMOUNT. * ALSO NEED TO UPDATE THE GLOBALS PBFLN,CBFCT,CBFAD * CKPS0 LDA PBFLN CKECK TO SEE IF WE NEED MORE ROOM IN PLOTTER CKPS2 ADA .N20 MAKE SURE THERE AT LEAST 20 BYTES AVAILABLE SSA,RSS IS THERE ANY ROOM JMP *+3 YES, OUTPUT IT JSB RDBFL NO, READ NEW BUFFER AVAILABLE LENGTH JMP CKPS NEED TO GO AND COMPARE AGAINST COMPUTER BUFFER LENGTH LDA CBFAD LOAD THE COMPUTER BUFFER LOCATION STA IOB THIS WILL BE USED AS OUTPUT POINTER LDA PBFLN NOW CHECK AMOUNT OF ROOM IN PLOTTER BUFFER ARS ROUND TO THE NEAREST WORD STA TEMP2 PLOTTER BUFFER LENGHT ROUNDED DOWN TO NEAREST WORD ADA CBFAD STORE AWAY THE TWO WORDS THAT WILL BE * PLACED REPLACED WITH THE ESC.) SEQUENCE LDB A,I STB OUT1 LDB TERM STB A,I PUT THE ESC.) SEQUENCE AT THE END INA LDB A,I STB OUT2 NOW WE HAVE PUT IT IN OUT1,OUT2 LDB TERM1 REST OF THE ESC.) SEQUENCE STB A,I LDA TEMP2 ALS CONVERT TO # OF BYTES FROM # OF WORDS ADA .4 A = NUMBER OF BYTES TO TRANSMIT LDB .2 WRITE JSB OUTPT OUTPUT THE DATA CLB NOW UP DATE THE PLOTTER BUFFER LENGTH STB PBFLN ALWAYS ASSUME THERE IS NO SPACE LEFT * IN REALITY IT SHOULD BE A ONE OR ZERO;TAKE WORSE CA LDA TEMP2 UPDATE THE GLOBALS ALS CONVERT TO NUMBER OF BYTES CMA,INA ADA CBFCT CBFCT = CBFCT - AMOUNT OF DATA SENT ADA .4 ROOM FOR THE PREAMBLE REMEMBER THERE IS A NULL THERE STA CBFCT NEEDED TO UPDATE THE COMPUTER BUFFER COUNT LDA TEMP2 ADA CBFAD THE START OF THE SEQUENCE ADA .N2 NEED TO ADD ESC.( SEQUENCE BACK IN BEGINNING STA CBFAD UPDATE COMPUTER BUFFER ADDRESS(LOCATION) LDB .N4 LOOP COUNTER STB TEMP2 LDB TBUF FWA OF THE ESC.( OUT1 OUT2 SEQUENCE BUFFER STB TEMP3 CKPS1 LDB TEMP3,I STORE THE PREAMBLE & RESTORE THE REPLACED DATA STB A,I ISZ TEMP3 INA ISZ TEMP2 JMP CKPS1 GO AND DO ANOTHER LOOP JMP CKPS WE ARE DONE GO BACK * * * VARIABLES FOR THIS ROUTINE)\ * * TBUF DEF ESC FWA OF THE ESC.( OUT1 OUT2 BUFFFER ESC OCT 33 ESCAPE CHARACTER (NULL,ESC) .LP OCT 027050 DOT LEFT PARAN (PERIOD,LEFT PARENTHESIS) OUT1 NOP TEMPORARY STORAGE OUT2 NOP TEMPORARY STORAGE TEMP2 NOP TEMPORARY STORAGE .ASKB DEF ASKB THE POINTER TO THE ESC.(ESC.B SEQUENCE ASKB OCT 15456 ESC . OCT 24033 ( ESC OCT 027102 . B * * * * * BE NICE IF THERE WAS A PAUSE HERE TO ALLOW TIME * FOR THE PLOTTER TO MUNCH ON DATA BEFORE ANOTHER IO * RDBFL NOP READ THE PLOTTER BUFFER SIZE ESC . B SEQUENCE LDA .ASKB POINTER TO THE ESC . B SEQUENCE STA IOB LOCATION OF THE BUFFER ESC.(ESC.B SEQUENCE LDA .1 NUMBER OF PARAMETERS TO CONVERT STA LEN THERE ARE ONE PARAMETER ON A BUFFER SIZE REQUEST JSB READ GO AND READ THE BUFFER SIZE LDA RWD1 LOAD THE NUMBER OF BYTES AVAILABLE IN THE BUFFER ADA .N40 NEED TO SUBSTRACT THE PREBUFFER IN 7221A STA PBFLN PLOTTER BUFFER LENGHT JMP RDBFL,I RETURN * * SKP SPC 3 * * READ THE GLOBAL VARIABLES * * GCBIM(32,1,(),?,1) * READ = 1 * WRITE = 2 * * GB32 NOP GCBIM(32,1,(),?,1) STA RW READ WRITE FLAG JSB GCBIM DEF *+6 DEF .32 GET GCBIM GLOBAL DATA DEF .1 ONE ITEM DEF CBFCT LOCATION OF BUFFER DEF .10 NUMBER OF ITEMS DEF RW READ/WRITE FLAG JMP GB32,I * * * * GET IOBUF ADDRESS PTR AND IOBL BLOCK LENGTH * GCBIM(2,1,(),2,1) * * * GBLUN NOP GET IOBUF ADDR, IOBL LENGTH, LUN JSB GCBIM DEF GBLRT DEF .2 NOTE WE ARE GOING TO READ ITEMS 2,4,26 DEF .3 NOTE THAT WE ARE GOING TO READ 3 GICBM ITEMS DEF LUN NOTE THAT LUN,CBFAD,CBFLN,FXDN MUST BE IN SEQUENCE DEF .0 TAKE THE DEFAULT FOR THE 3 ITEMS DEF .1 READ GBLRT LDA LUN ESTABLISH TRANSPARENT MODE IN DVR05 IOR B2000 SET BIT-10 FOR TRANSPARENT MODE IN DVR05 STA LUN LDA CBFLN LOAD THE COMPUTER BUFFER LENGHT ADA .N1 REDUCE THE SIZE BY ONE WORD ALS CONVERT WORDS TO BYTES STA CBFLN NOW BUFFER LENGTH IS IN BYTES JMP GBLUN,I RETURN * * * * ENTER A = GICBM # TO READ * B = NUMBER OF PARAMETERS * EXIT DATA IN INTX1 BUFFER * * * GBGET NOP GET DATA FROM THE GIC STA NUMB THE NUMBER OF GICB TO READ STB SIZE THE NUMBER OF PARAMETERS TO BE TRANSFERRED JSB GCBIM CALL GCBIM(NUMB,1,INTX1,2,SIZE) DEF *+6 DEF NUMB THE NUMBER OF GICB TO READ DEF .1 GET ONE SET DEF INTX1 LOCATION OF BUFFER DEF SIZE NUMBER OF PARAMETERS DEF .1 READ ONLY JMP GBGET,I * * GBRET NOP GRAPHIC CONTROL BLOCK RETURN STA ADDR A IS WHERE THE DATA IS AT STB NUMB B IS NUMBER OF WORDS TO SEND JSB GCBIM GCBIM(16,1,ADDR,NUMB,2) DEF *+6 DEF .16 DEF .1 ADDR NOP LOCATION OF THE BUFFER DEF NUMB NUMBER OF PARAMETERS DEF .2 WRITE JMP GBRET,I * ADD THE TERMINATOR TO THEN END * * TRBYT NOP NEED TO ADD TERMINATOR TO THE END LDB CBFCT LOAD THE COMPUTER BUFFER COUNT BRS SHIFT OVER TO MAKE IT WORDS ADB CBFAD WORD ADDRESS OF THE FIRST AVAILABLE BYTE STB TEMP9 LDA CBFCT SLA IS THE HOLE ON THE MSB OR LSBYTE OF THE AVAIL WORD JMP TRBY1 ITS ON THE LSBYTE OF THE WORD LDB TERM LOAD THE ESC PERIOD SEQUENCE IN DIRECTLY STB TEMP9,I STORE IT AWAY IN THE BUFFER ISZ TEMP9 MOVE UP THE POINTERS BY ONE LDB TERM1 LOAD THE RIGHT ) IN STB TEMP9,I PUT THE RIGHT ) IN JMP TRBY2 NOW UPDATE THE COUNTER TRBY1 LDA TEMP9,I LOAD THE LAST WORD OF THE CURRENT BUFFER AND HIBYT CLEAR OUT THE LOWER BYTE IOR B33 INSERT THE ESC CHARACTER STA TEMP9,I STORE IT AWAY ISZ TEMP9 INCREMENT THE POINTER LDA TERM2 LOAD THE PERIOD LEFT ) STA TEMP9,I UPDATE THE BUFFER ISZ TEMP9 MAKE ROOM FOR THE BACK SPACE CHARACTER LDA TERM3 LOAD THE CONTROL H IN STA TEMP9,I STORE IT TRBY2 LDA CBFCT NOW UPDATE THE COMPUTER BUFFER COUNTER ADA .4 WE PUT IN FOUR MORE (ESC, . , ), CONTROL H ) STA CBFCT JMP TRBYT,I WE ARE DONE AND RETURN * * OUTPUTS THE BUFFER WITH A NUMBER OF BYTES * ENTER WITH A= BYTE COUNT * B= READ = 1; WRITE = 2 * IOB= PTR TO THE START OF THE BUFFER TRANSFER AREA * LUN= LOGICAL UNIT NUMBER * * * OUTPT NOP CMA,INA STA IOCNT NEGATIVE VALUE OF BYTE COUNT STB RW READ/WRITE FLAG;1=READ;2=WRITE CPB .2 IS IT A WRITE REQUEST JMP OUTST YES, THUS DO NOT DELETE TRANSPARENT MODE LDA LUN NO, NEED TO MAKE NON-TRANSPARENT MODE AND B77 JUST MASK OFF THE LOGICAL UNIT NUMBER STA LUN OUTST JSB EXEC READ/WRITE EXEC ROUTINE DEF RTOUT RETURN ADDRESS DEF RW READ/WRITE FLAG DEF LUN LOGICAL UNIT NUMBER IOB NOP BUFFER LOCATION DEF IOCNT HOW MANY? RTOUT LDA LUN PUT TRANPARENT BIT BACK ON, IF ON DOESN'T MATTER IOR B2000 SET BIT-10 SO WHAT IF WE DO THIS UNNECCESARLY STA LUN IT TAKES CODE THE SAME AMOUNT OF CODE THE OTHERWAY JMP OUTPT,I RETURN SKP SPC 3 * * THIS IS USED TO SEE WHAT KIND OF READ IS NEEDED * * RDCHK NOP READ CHECK JSB RITE OUTPUT THE COMPUTER BUFFER LDA INTYP SSA,RSS ARE WE SUPPOSE TO WAIT? JSB RWsAIT YES, GO AND WAIT UNTIL THE BUFFER IS EMPTY * * NOW PERFOR IN THE ACTUAL REQUEST * RCONT LDB INTYP GET THE PROPER COMMAND SSB NEED THE ABOLUTE VALUE OF TYPE CMB,INB ADB ESCTB INDEX TO THE PROPER COMMAND LDA ESC.3 PUT IN PROPER CODE IN ESC. SEQUENCE AND HIBYT MASK OFF THE HIGH BYTE STA ESC.3 LDA B,I GET THE PROPER LETTER COMMAND AND LOBYT MASK OFF THE LETTER ONLY IOR ESC.3 STORE IT IN THE ESC SEQUENCE STA ESC.3 LDA B,I GET THE NUMBER OF PARAMETERS ALF,ALF ITS IN THE HIGH BYTE PUT IT IN THE LOW BYTE AND LOBYT MASK IT OFF STA LEN STORE IT AWAY AS NUMBER OF PARAMETERS IN READ LDA ESC. LOCATION OF ESC SEQUENCE STA IOB JSB READ JMP RDCHK,I * * * THIS ROUTINE IS USED TO READ THE PLOTTER BUFFER SIZE * WHICH MEANS TO WAIT UNTIL THE PLOTTER BUFFER IS COMPLETELY * EMPTY. * * RWAIT NOP READ BUFFER SIZE, BUT WAIT UNTIL IT'S EMPTY LDA ESC.3 NEED TO USE ESC.(ESC.L SEQUENCE AND HIBYT MASK OFF THE MOST SIGNIFICANT BYTE IOR .76 PUT IN A 'L' IN STA ESC.3 NOW ESC. HAS ESC.(ESC.L SEQUENCE IN IT LDA ESC. LOAD THE ESC SEQUENCE POINTER STA IOB PUT ESC SEQUENCE AS OUTPUT BUFFER LDA .1 ONE PARAMETER LONG STA LEN JSB READ GO GET BUFFER LENGHT LDA RWD1 BUFFER IS NOW EMPTY ADA .N40 NEED TO SUBSTRACT THE PREBUFFER IN 7221A STA PBFLN UPDATE THE GLOBAL VARIABLE JMP RWAIT,I RETURN * * * SKP * * * READ NEED TO PUT POINTER IN IOB FOR OUTPUT * COMMAND WITH ESC.( PRECEEDING. * * ASSUME 3 WORDS LONGS * * LEN = # PARAMETERS * * IOBUF SHOULD BE CLEAN * * PUT THE ANSWER IN RDVAR * * READ NOP , READ AN INQUIRY LDA .6 ASSUME 3 WORDS OF OUTPUT LDB .2 WRITE REQUEST JSB OUTPT LDB .SPAC NEED TO PUT SPACES IN THE BUFFER LDA .N15 SO THE FORMATTER MAY WORK CORRECTLY STA TEMP9 ASSUME 15 WORDS IN BUFFER LDA .RDBF THIS IS THE BUFFER FWA READ1 STB A,I PUT SPACES IN THE BUFFER INA ISZ TEMP9 INCREMENT POINTERS JMP READ1 CONTINUE ON LDA .RDBF READ BUFFER LOCATION STA IOB RESOTRE THE I/O BUFFER LDA .40 ONE LINE LENGTH LDB .1 READ JSB OUTPT LDA LPLCM LOAD LAST PLOTTER COMMAND CPA .N2 IS IT A LABEL ON MODE?? JMP READ,I YES, GO BACK HOME LDA .TERM NO, NEED TO TURN OFF THE PLOTTER STA IOB POINTS TO THE ESC . ) SEQUENCE (TERMINATOR) LDA .4 THREE BYTES LONG FOR THE TERMINATOR LDB .2 WRITE JSB OUTPT LDA LEN NOW CONVERT THE DATA SZA,RSS NO PARAMETER CONVERSION NECESSARY JMP READ,I RETURN CMA,INA STA LEN NEGATIVE # PARAMETER CLA STA IBYTE LDA .RDBF FROM I/O BUFFER STA INTIO LDA RDVAR STA INTAD PUT THE PARAMETER IN RDVAR INTLP JSB INTX DEF RTINT INTIO NOP FROM BUFFER INTAD NOP TO BUFFER DEF IBYTE COUNT OF WHICH CELL IN RDVAR RTINT ISZ INTAD ISZ LEN JMP INTLP JMP READ,I * SKP SPC 3 * * * LITERAL RETURN * ENTER GIC, LNGTH,DCTAD * * LITRT LDA CMDAD LITERAL RETURN; LOAD THE LOCATION OF LITERAL STRING LDB NBYTE LOAD THE NUMBER OF BYTES INB ROUND UP TO THE NEAREST WORD BOUNDARY BRS DIVIDE BY TWO TO GIVE WORDS JSB GBRET PUT INTO GCBIM(16,1,A,B,2) JMP EXIT1 UPDATE GLOBALS AND RETURN * * SKP SPC 3 * * THIS IS USED TO SEND DATA BACK TO THE GCBIM * * ENTER WITH DATA IN A * FORMAT *DDDDDD RANGE 0 TO 63 * * SBN NOP SINGLE BYTE NUMBER JSB CHECK CHECK FOR THE 6 BIT ON/OFF;AND STORE IT JMP SBN,I WE ARE FINISHED SPC 3 * * * ENTER WITH A = VALUE * * FORMAT 110NNNN 110NNNN 110NNNN * *NNNNNN *NNNNNN * *NNNNNN * * * MBN NOP MULTIPLE BYTE NUMBER STA DATAX STORE VALUE TO BE CONVERTED LDB FGMBA CHECK TO SEE IF FROM MBA ROUTINE CPB .1 IF SO NEED TO USE 3 BYTE ROUTINE JMP MBN3 YES, GO TO THREE BYTE ROUTINE AND B76K ELSE MBN SZA CHECK TO SEE HOW MANY BYTES JMP MBN3 NEED THREE BYTES LDA DATAX AND B1760 SZA JMP MBN2 NEED TWO BYTES MBN1 LDA DATAX THEN WE NEED ONE BYTE JSB HDCK ONE BYTE STORE OF HEAD VALUE IN I/O BUFFER JMP MBN,I DONE WITH ONE BYTE PARAMETER MBN2 LDA DATAX 2 BYTE PARAMETER ALF,ALF NEED BITS 9-6 TO 3-0 RAL,RAL JSB HDCK STORE HEAD VALUE IN I/O BUFFER JMP BLAST SKIP TO LAST BYTE OF MBP3 WHICH IS IDENTICAL MBN3 LDA DATAX THREE BYTE PARAMETER ALF NEED BIT 14-12 TO 2-0 LDB MBAOF CHECK TO SEE IF WE NEED TO SET BIT 16 SZB THIS IS FROM THE MBA ROUTINE IOR .8 SET BIT 4 IMPLIES ANGLES > 90 DEGREES. JSB HDCK STORE HEAD VALUE IN I/O BUFFER LDA DATAX SECOND BYTE OF MBN ALF,ALF MOVE BITS 11-6 TO 5-0 RAL,RAL JSB CHECK SPC 3 BLAST LDA DATAX LAST BYTE JSB CHECK JMP MBN,I GO BACK HOME SPC 3 * THIS IS USED TO CHECK TO SEE IF * BIT 7 IS TO BE COMPLEMENTED OR NOT * CHECK NOP SET UP 6/7 BIT OF BYTE AND B77 MASK OFF THE BITS 5-0  STA TEMP AND B40 MASK OFF THE BIT-6 SZA,RSS IS BIT 6=0 LDA .64 YES, SET BIT 7 OTHERWISE LEAVE BIT 6 SET IOR TEMP SET BIT 6 OR 7 ALF,ALF NEED TO MOVE TO HIBYTE TO OUTPUT ONE BYTE STA SINGL PUT IT INTO THE TEMPORARY BUFFER TO BE TRANSFERRED LDB .1 NOW SET UP THE PARAMETERS FOR JSB TRANS ROUTINE LDA .SING SET UP THE POINTER JSB TRANS JMP CHECK,I * SPC 3 * * * USED TO PUT IN HEADER FORMAT * FORMAT IS 110NNNN * * HDCK NOP HEADER CHECK FOR PARAMETER CONVERSION ROUTINES AND B17 MASK OFF THE 3-0 BITS IOR B140 NEED TO INSERT THE HEADING PREAMBLE ALF,ALF NEED TO MOVE TO HIBYTE TO GET OUTPUTTED STA SINGL STORE INTO THE TEMPORARY BUFFER TO BE TRANSFERRED LDB .1 1 BYTES LONG LDA .SING POINTER TO THE TEMPORARY BUFFER JSB TRANS TRANSFER THE DATA OVER JMP HDCK,I RETURN * * * SPC 3 * * MULTIPLE BYTE PARAMETERS * * FORMAT 110XXYY 110XXXX 110XXXX 110XXXX 110XXXX * *XYYYYY *XXXXYY *XXXXXX *XXXXXX * *YYYYYY *XYYYYY *XXXXYY * *YYYYYY *YYYYYY * *YYYYYY * * * MBP NOP MULTIPLE BYTE PARAMETERS STB DATAY STA DATAX IOR B CHECK TO FIND OUT WHICH MAGNITUDE IS LARGER STA TEMP AND B74K BITS 13-11 ANY ON? SZA JMP MBP5 YES, WE HAVE A 5 BYTE PARAMETER LDA TEMP AND B3400 BIT 10-8 ANY ON? SZA JMP MBP4 GO TO 5 BYTE PARAMETER LDA TEMP AND B340 BITS 7-5 ANY ON? SZA JMP MBP3 WE HAVE 3 BYTE PARAMETER LDA TEMP AND B34 BITS 4-2 ANY ON? SZA JMP MBP2 ~ TWO BYTE PARAMETER JMP MBP1 ELSE ONE BYTE PARAMETER * * * MBP5 LDA DATAX FIVE BYTE PARAMETER ALF MOVE THE BITS OVER TO GET LSB'S RAL,RAL 13-10 TO 3-0 BITS MOVEMENT JSB HDCK LDA DATAX SECOND BYTE ALF,ALF GET THE NEXT BYTE OF INFORMATION ALF MOVE BITS 904 TO 5-0 JSB CHECK LDA DATAY THIRD BYTE PARAMETER ALF SHIFT OVER TO GET THE Y BITS AND .3 MASK OFF WHAT WE NEED STA TEMP LDA DATAX THE SECOND HALF OF THE THRID BYTE AND B17 MOVE BITS 3-0 TO 5-2 RAL,RAL MOVE IT TO THE PROPER PLACE IN MBP IOR TEMP MERGE THE Y AND X BITS FOR BYTE 3 JSB CHECK LDA DATAY FOURTH BYTE ALF,ALF MOVE BITS 11-6 TO 5-0 RAL,RAL JSB CHECK LDA DATAY FIFTH BYTE JSB CHECK GO AND STORE IT JMP MBP,I * * * MBP4 LDA DATAX WE HAVE A FOUR BYTE MBP ALF,ALF SHIFT OVER BITS 10-7 TO 3-0 RAL JSB HDCK LDA DATAX SECOND BYTE RAR MOVE BITS 6-1 TO 5-0 JSB CHECK GO AND PUT IT IN LDA DATAX THIRD BYTE BYTE AND .1 MASK OFF THE ONE BIT WE NEED ALF,RAL MOVE BITS 0 TO BIT 5 STA TEMP STORE IT AWAY; NEED IT LATER TO MERGE WITH THE Y LDA DATAY ALF,ALF SHIFT BITS 10-6 TO 4-0 RAL,RAL AND B37 MASK OFF THE 5 BITS WE NEED IOR TEMP MERGE THE X AND Y TOGETHER JSB CHECK LDA DATAY FOURTH BYTE JSB CHECK STORE IT JMP MBP,I RETURN * * * MBP3 LDA DATAX 3 BYTE PARAMETER ALF,ALF MOVE THE BITS 7-4 TO 3-0 ALF JSB HDCK INSERT THE HEADER IN LDA DATAX SECOND BYTE AND B17 GET THE 4 BITS 3-0 TO 5-2 RAL,RAL SHIFT IT OVER FOR POSITIONING STA TEMP SAVE FOR MERGE LATER )LDA DATAY ALF,ALF MOVE 7-6 TO 1-0 RAL,RAL NEED TO SHIFT OVER 12 AND .3 NEED THE TWO Y BITS IOR TEMP MERGE THE X AND Y TOGETHER JSB CHECK LDA DATAY THRID BYTE JSB CHECK JMP MBP,I * * * MBP2 LDA DATAX GOING AFTER THE TWO BYTE PARAMETER RAR SHIFT BITS 4-1 TO 3-0 JSB HDCK LDA DATAX SECOND BYTE AND .1 ALF,RAL MOVE OVER TO POSITION 0 TO 5 STA TEMP LDA DATAY AND B37 NEED TO MASK OFF THE LAST 5 BITS OF Y IOR TEMP MERGE THE X AND Y TOGETHER JSB CHECK PUT IT AWAY JMP MBP,I * * * MBP1 LDA DATAX HAVE ONE BYTE MODE AND .3 MOVE BITS 1-0 TO 3-2 RAL,RAL MOVE THE 2 BITS TO PROPER PLACE STA TEMP LDA DATAY AND .3 MOVE BITS 1-0 TO 1-0 IOR TEMP MERGE THE X AND Y TOGETHER JSB HDCK NEED TO PUT THE HEADER INFO IN AND PUT INTO BUFFER JMP MBP,I * * * * * * * FOR MBA MULTIPLE BYTE ANGLE WE NEED TO HAVE * FLOATING POINT SO WE CAN CONVERT FROM * RADIANS TO DEGREES AND TO BINARY SYNTAX * NEED FOR THE 7221 * * 10430.03 * X RADIANS = D BINARY DEGREES * MBA NOP THIS IS MULTIPLE BYTE ANGLE FMP MBACT MULTIPLY BY THE 10430.03 CONSTANT DST TEMP8 THIS IS THE FLOATING REPRESENTATION OF MBA FSB B77.K NEED TO CHECK FOR ANGLES > 90 DEGREES FIX LDB .1 INDICATES OVERFLOW BITS OR > 90DEGREES SSA,RSS ARE WE OVER 90 DEGREES? JMP MBA1 YES, USE A AND B AS IS DLD TEMP8 NO, ANGLE IS <= 90 DEGREES FIX PUT IT IN THE FORM FOR MBN TO USE LDB .0 CLEAR OVERFLOW FLAG MBA1 STB MBAOF STORE OVERFLOW FLAG LDB .1 NEED TO SET FLAG FOR MBA SO MBN ROUTINE KNOWS IT STB FGMBA IS FRO7 M MBA TO DO THREE BYTE PART JSB MBN GO AND CONVERT IT SINCE ITS THE SAME AS MBN CLA RESET THE FLAG TO NOT-FROM MBA STA FGMBA STA MBAOF CLEAR THE OVERFLOW FLAG JMP MBA,I RETURN SKP SPC 3 * * * * * DATA VARIABLESL * .SING DEF SINGL USED FOR TEMPORARY BUFFER LOCATION IN CONVERSIONS SINGL NOP * * ESC. DEF ESC.1 ESC.1 OCT 015456 ESC . ESC.2 OCT 024033 (ESC ESC.3 OCT 027040 . BLANK SPC 3 .ETX DEF ETXNO USED TO POINT TO THE ETX TERMINATOR SEQUENCE ETXNO OCT 015456 ESC . OCT 024003 ( ETX OCT 015456 ESC . OCT 024410 ) BACK SPACE (CONTROL H) SPC 3 .TERM DEF TERM START OF TERMINATOR SEQUENCE TERM OCT 015456 ESC. TERM1 OCT 024410 ) CONTROL H TERM2 OCT 027051 PERIOD, ) TERM3 OCT 004000 CONTROL H, NULL SPC 3 HIBYT OCT 177600 MOST SIGNIFICANT BYTE LOBYT OCT 000377 LEAST SIGNIFICANT BYTE SPC 3 RDVAR DEF RWD1 THE PARAMETER FROM READ RWD1 BSS 1 RWD2 BSS 1 RWD3 BSS 1 RWD4 BSS 1 SPC 3 ESCTB DEF * START OF ESC SEQ TABLE OCT 001501 3 A; NUMBER OF PARAMETERS, LETTER OF OUTPUT COMMAND OCT 000502 1 B OCT 001503 3 C OCT 002104 4 D OCT 001505 3 E OCT 000506 1 F OCT 002107 4 G OCT 000110 0 H OCT 000111 0 I OCT 000112 0 J OCT 000113 0 K OCT 000514 1 L SPC 3 .RSET DEF RSET FOR RESET COMMAND RSET OCT 077121 TILDE P - DEFAULT LABEL FONT OCT 077127 TILDA W (W) SET GRAPHIC LIMITS OCT 077123 TILDA S (~S) SET GRIDDING OCT 077045 TILDA % (~%) SET CHARACTER SIZE OCT 063467 SMALL G7(g7) PARAMETER VALUES FOR (125,250) OCT 035000 COLON (: ) SPC 3 * * ETX,ESC.M10:17:10:13:ESC.J SEQUENCE * .HAND DEF HAND FWA FOR START HANDSHAKING HAND OCT 1433  TURN OFF TEXT MODE IF ON (ETX,ESC) OCT 027115 SET UP HANDSHAKE MODE (.,M) OCT 30460 WITH 10 MILLISECOND DELAY (1,0) OCT 35461 DC1 CHARACTER TRIGGER (SEMICOLON,1) OCT 33473 (7,SEMICOLON) OCT 30060 TRY NO ECHO BYPASS CHARACTER(0,0) OCT 35461 CR TERMINATOR FOR PLOTTER (SEMICOLON,1) OCT 31472 (3,:) OCT 15456 CANCEL ANY CURRENT REQUESTS (ESC,.) OCT 45000 (J,NULL) SPC 3 * * GLOBALS * CBFCT BSS 1 COMPUTER BUFFER COUNTER PBFLN BSS 1 PLOTTER BUFFER LENGTH LPLCM BSS 1 LAST PLOTTER COMMAND PANG1 BSS 1 PLOTTER ANGLE PANG2 BSS 1 PLOTTER ANGLE PART TWO (REAL NUMBER) CPENS BSS 1 PLOTTER PEN STATUS GX1MU BSS 1 GRAPHIC LIMIT X MIN GX2MU BSS 1 GRAPHIC LIMIT X MAX GY1MU BSS 1 GRAPHIC LIMIT Y MIN LENGTH GY2MU BSS 1 GRAPHIC LIMIT Y MAX * * * .LNTP DEF LNTP LINE TYPE REFERENCE LNTP DEF LNTP0 LINETYPE 0 SOLID LINES DEF LNTP1 1, DIME DEF LNTP2 2,SHORT DASH DEF LNTP3 3,LONG DASH DEF LNTP4 4,CENTER LINE DEF LNTP5 5,DOTS AT END POINT DEF LNTP6 6,DOUBLE CENTER LINE * * PATLN DEC 460.0 DEFAULT DASHLINE LENGTH * LNTP0 OCT 0 DEFAULT SOLID LINES LNTP1 OCT 5 LENGTH IN BYTES OCT 020101 SPACE, CAPITAL A DIM LINES OCT 020141 SPACE , LOWER CASE A OCT 022000 $ DOLLAR SIGN, NULL LNTP2 OCT 2 BYTES OCT 022505 PERCENT , CAPITAL E; SHORT DASH LNTP3 OCT 2 OCT 021501 POUND SIGN, CAPITAL A LONG DASH LNTP4 OCT 4 OCT 023501 SINGLE QUOTE MARK,CAPITAL A; CENTER LINE OCT 020501 EXCLAIMATION POINT,CAPITAL A LNTP5 DEC 8 NUMBER OF BYTES OCT 077122 TILDE R - VARIABLE DASH LINE FORMAT OCT 020101 SPACE ,CAPITAL A OCT 020143 SPACE ,SMALL C OCT 037477 QUESTION ,QeUESTION MARK LNTP6 OCT 6 OCT 020101 PERCENT ,CAPITAL A; DOUBLE CENTER LINES OCT 020501 EXCLAMATION,CAPITAL A OCT 020501 EXCLAMATION,CAPITAL A * A EQU 0 B EQU 1 BUFFG BSS 1 BUFFER FLAG NBYTE BSS 1 ABSOLUTE NUMBER OF BYTES IN CMD $ BYTES BSS 1 NUMBER OF BYTES IN CMD $ TYPE BSS 1 NUMBER OF BYTES IN CMD $ INTYP BSS 1 READ INSTRUCTION TYPE FOR READ REQUESTS * RW BSS 1 READ/WRITE FOR GCBIM FGMBA NOP MBA FLAG 0=NOT FROM MBA 1=YES FROM MBA ROUTINE MBAOF NOP MBA OVERFLOW FLAG 0=NO SET BIT-16 1=YES SET BIT-16 DFETX DEF B1400 POINTER TO THE 1400 OCTAL (ETX) * * .0 OCT 0 .1 OCT 1 .1038 DEC 10380 Y UPPER RIGHT DEFAULT LIMIT .10 DEC 10 .11 DEC 11 .1572 DEC 15720 X UPPER RIGHT DEFAULT LIMIT .16 DEC 16 .19 DEC 19 .2 OCT 2 READ LUN NUMBER ALSO KEEP NEXT TWO WORDS ALWAYS TOGETHER .4 OCT 4 READ CBFAD,CBFLN .26 DEC 26 READ THE AXIS FIX # FXDN .200 OCT 200 .SPAC OCT 20040 THIS IS SPACES IN BOTH BYTES FOR INPUT BUFFER CLEAR .22 DEC 22 .3 OCT 3 .380 DEC 380 Y LOWER LEFT DEFAULT LIMIT .31 DEC 31 .32 DEC 32 .38 DEC 38 .39 DEC 39 .40 DEC 40 .41 DEC 41 .64 DEC 64 .460 DEC 460 .5 OCT 5 .520 DEC 520 X LOWER LEFT DEFAULT LIMIT .6 OCT 6 .7 OCT 7 .76 DEC 76 A CAPITAL L .8 DEC 8 .N1 OCT -1 .N15 DEC -15 .N2 OCT -2 .N20 DEC -20 .N3 OCT -3 .N4 OCT -4 .N40 DEC -40 .N5 OCT -5 B1000 OCT 1000 B140 OCT 140 B1400 OCT 1400 ETX IS THE HIGH BYTE B17 OCT 17 B177 OCT 177 B1760 OCT 1760 B200 OCT 200 B2000 OCT 2000 B33 OCT 33 B34 OCT 34 B3400 OCT 3400 B340 OCT 340 B37 OCT 37 B40 OCT 40 B60 OCT 60 B6400 OCT 6400 CARRIAGE RETURN, FOR SHORT LABEL TERMINATOR B74K OCT 74000 B76K OCT 76000 B77 OCT 77 B77.K DEC 32767. THIS FOR MBA ROUTINE SPC 3 CMDAD BSS 1 CO,MMAND ADDRESS = DCTAD RWFLG BSS 1 =0 READ, -1 WRITE IOCNT BSS 1 I/O COUNTER FOR # BYTES TO BE TRANSFERRED TEMP BSS 1 TEMPORARY VARIABLE IN CONVERSIONS ROUTINES TEMP3 BSS 1 TEMPORARY STOREGE TEMP7 BSS 1 TEMPORARY STORAGE TEMP8 BSS 1 TEMPORAY STORAGE FOR TRANS TEMP9 BSS 1 TEMPORARY STORAGE FOR TRANS ROUTINE TLOOP BSS 1 LOOP COUNTER FOR TRANS ROUTINE PLTCT BSS 1 PLOT ABSOLUTE PARAMETER POINTER LNTH BSS 1 LENGHT OR NUMBER OF PARAMETERS .RDBF DEF INTX1 READ BUFFER LOCATION INTX1 BSS 1 INTX2 BSS 1 INTX3 BSS 1 INTX4 BSS 1 INTX5 BSS 1 INTX6 BSS 1 INTX7 BSS 1 INTX8 BSS 1 INTX9 BSS 11 NUMB BSS 1 NUMBER OF ITEMS SIZE BSS 1 NUMBER OF ITEMS LEN BSS 1 # OF PARAMETER TO CONVERT IN READ REQUEST * * * LUN BSS 1 LOGICAL UNIT NUMBER CBFAD BSS 1 COMPUTER BUFFER ADDRESS LOCATION CBFLN BSS 1 COMPUTER BUFFER LENGTH FXDN BSS 1 READ THE AXIS FORMAT NUMBER * * * .SPEC DEF * FWA FOR SPECIAL TABLES DEF RESET DEF GTG12 GET G1,G2 DEF OUTCP OUTPUT CURRENT POINT DEF DIGIT OUTPUT THE DIGITIZE POINT DEF SLANT OUTPUT THE SLANT FOR CHARACTERS DEF MBPOT MBP OUTPUT FLOATING POINT NUMBER DEF MBPBN MBP OUTPUT BINARY NUMBER DEF SLPEN SELECT PEN NUMBER DEF DASHL DASH LINE TYPE SELECTION DEF DASHL DASH LINE WITH PATTERN LENGTH SPECIFIED DEF MVCUR MOVE CURSOR NEED TO OUTPUT BINARY # IN MBP DEF SG1G2 SET G1,G2; GRAPHIC LIMITS DEF DFG12 DEFAULT G1 AND G2 DEF PENUP PEN-UP * * * EM0 DEF * FWA FOR EMULATOR TABLE DEF XMIT TRANSMIT I/O BUFFER DEF HOME HOME THE PEN DEF GTCHR GET CHARACTER DATA DEF PLABS PLOT ABSOLUTE DEF LABEL LABEL MODE DEF CONVT CONVERT TO ASCII DEF PENDN PEN DOWN SPC 3 .P DEF P P OCT 70000 SMALL P (LOWER CASE P) .Q DEF Q Q OCT 070400 SMALL Q (LOWER CASE Q) .Z DEF Z Z OCT 75000 SMALL Z (LOWER CASE) * AGCT DEC 1.0 CONVERSION RADIANS TO DEGREES TO MBA FORMAT .LLAB DEF LLAB LLAB OCT 077134 TILDE, BACKSLASH (,\) OCT 061576 ETX,TILDE DEFINES THE LABEL TERMINATOR OCT 023400 SINGLE TICK MARK, NULL - TURN LABEL MODE ON .SLAB DEF SLAB SHORT LABEL MODE SLAB OCT 077134 TILDE, BACK SLASH OCT 066576 CARRIAGE RETURN, TILDE OCT 023400 SINGEL TIC MARK, NULL SPC 3 * .WW DEF WW WW OCT 073567 SMALL WW (ABSOLUTE ROTATE) SKPBK NOP USED IN FLOAT TO ASCII ROUTINE * BUFFER EMPTY 1=NO,WAIT; 0 = YES, WAIT IBYTE BSS 1 INTX ROUTINE DATAX BSS 1 X VALUE USED IN CONVERSION ROUTINE DATAY BSS 1 Y VALUE USED IN CONVERSION ROUTINE * MBACT DEC 10430.03 FLOATING POINT ANGLE CONSTAND SLANG DEC 1.570795 FLOATING POINT OF 90 DEGREES USED IN SLANT ROUTINE END ^; Y$~ 92840-18093 1840 S C0122 &DCT05 7221A CMND TBLE SRC             H0101 ASMB,R,F,L,C * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * * * * NAME: DCT05 * * SOURCE: 92840-18093 * * RELOC: 92840-16011 * * * * * ************************************************************** * NAM DCT05,7 92840-16012 REV.1840 780811 ENT DCT05 * * THIS IS THE DEVICE COMMAND TABLE FOR THE 7221A PLOTTER * ************************************************************** * * COMMAND LINK TABLE (CLTBL) * * SPC 3 DCT05 NOP DEF INIT 0 THIS IS TO EMULATE THE NAME OF DEVICE DEF RESET 1 RESET DEVICE/EXCEPT P1,P2 DEF DFP12 2 DEFAULT P1/P2 DEC -2 3 FORM FEED/PAGE ADVANCE DEC -1 4 TRANSMIT I/O BUFFER DEC -2 5 HOME PEN DEF GETID 6 GET ID NOP 7 ????? DEF GTG12 8 GET G1,G2 IN P.U. DEC -3 9 GET CHARACTER SPACING/WIDTH DEF OUTCP 10 OUTPUT CURRENT PEN POSITION IN PU.] DEF OUTCP 11 OUTPUT CURRENT CURSOR POSITION IN PU. DEF DIGIT 12 DIGITIZE NOP 13 LABEL ORIGIN NOP 14 SET LABEL DIRECTION DEF CHRSL 15 SET CHARACTER SLANT ON DEF CHRSO 16 CHARACTER SLANT OFF DEF CHRSI 17O CHARACTER SIZE NOP 18 SET RELOCATABLE ORIGIN NOP 19 SET RELOCATABLE ANGLE NOP 20 SET RELOCATABLE SCALING NOP 21 SET ORIGIN = CURSOR NOP 22 SET ORIGIN = PEN POSITION NOP 23 DRAW TO CURSOR DEF CHRST 24 SELECT CHARACTER SET DEF PEN0 25 SELECT PEN 0 (PUT PEN AWAY) NOP 26 ERASE PEN NOP 27 COMPLEMENT PEN DEF PENN 28 SELECT PEN (1-N) DEF GETPN 29 GET # OF PENS NOP 30 DEFINE LINE TYPE DEF LNTY0 31 SELECT PREDEFINED LINETYPE WITH DEFAULT LENGTH DEF LNTYP 32 SELECT PREDEFINED LINETYPE, LENGTH DEF PENUP 33 PEN-UP DEC -7 34 PEN-DOWN ROUTINE DEC -4 35 PLOT ABSOLUTE NOP 36 PLOT RELOCATABLE NOP 37 PLOT INCREMENTAL DEC -5 38 SHORT LABEL DEC -5 39 LONG LABEL NOP 40 STOP LONG LABEL MODE DEC -6 41 CONVERT FLOATING TO ASCII AND OUTPUT DEF GETDS 42 GET DISPLAY SIZE DEF MCUR 43 POSITION CURSOR ABSOLUTE NOP 44 POSITION CURSOR RELATIVE DEF SG1G2 45 SET G1,G2 DEF GETMU 46 GET MU/MM DEF GETZE 47 GET DEVICE CLEAR CHARACTERISTICS DEF GETPN 48 GET # OF DIFFERENT PENS DEF GETZE 49 GET # OF DIFFERENT CURSORS DEF GETZE 50 GET LORG CAPABILITY DEF GETSL 51 GET MAX SLANT ANGLE DEF GET1 52 GET HARD CLIP CAPABILITY NOP 53 GET FILE NAME (USED FOR DISC IMAGE GRAPHICS) DEF GETCS 54 GET CHARACTER SIZE DEF GETLD 55 GET LABEL DIRECTION DEF GETLO 56 GET LABEL ORIGIN RANGE * HED ASCII COMMAND STRINGS * * ASCII COMMAND STRINGS FOR DEVICE COMMAND TABLE FOR 7221A * * FORMAT: WORD1 = NUMBER OF BYTES (N) * -(N) INDICATES A WRITE TO DEVICE * +(N)0 INDICATES A READ AFTER WRITE * * * WORD2 = INDICATES TYPE OF COMMAND * -1 INDICATES TRUE R/W TYPE (NO SPECIAL) * CONDITIONS TO WORRY ABOUT. * * >1 INDICATES NEED OF SOME SORT OF PARAMETER * CONVERSION. * * =0 INDICATES A LITERAL STRING IS RETURN * TO THE CALLING ROUTINE. * * * * WORD3 = FIRST WORD OF COMMAND STRING * OR IF READ MODE THEN WORD 3 IS THE READ * INSTRUCTION NUMBER, THEN WORD 4 IS THE * FIRST COMMAND STRING INSTRUCTION. * * SPC 3 INIT NOP THIS IS USED FOR INIT CYCLE NEED TO RETURN DEVICE NAME LDA .7221 THE DEVICE NAME JMP INIT,I GO HOME .7221 DEC 7221 * * * RESET DEC +36 RESET GIC: SETS UP HANDSHAKING&DEFAULTS DEC 1 NEED SOME SPECIAL HANDLING DEC 7 USED TO DENOTE OUTPUT OF THE GRAPHIC LIMIT COMMAND OCT 1433 TURN OFF TEXT MODE IF ONE (ETX, ESC) * HANDSHAKE MODE: ESC.M10;17;10;13: OCT 27115 SET UP HANDSHAKE MODE (.,M) OCT 30460 WITH 10 MILLISECOND DELAY (1,0) OCT 35461 DC1 CHARACTER TRIGGER( ,1) OCT 33473 (7,SEMICOLON) OCT 30073 NO ECHO BYPASS CHARACTER (0,SEMICOLON) OCT 030463 CR TERMINATOR FOR PLOTTER(1,3) OCT 035033 :,ESC START OF CLEAR ERRORS ESC . E OCT 027105 . E CLEAR ERRORS * OCT 15456 CLEAR OUT OUTPUT REQUESTS (ESC .J ) OCT 045176 J TILDE OCT 056143 BACK SLASH, ETX - DEFAULT LABEL TERMINATOR OCT 015456 ESC . - DEFAULT INDEPENDENT HANDSHAKE OCT 044072 H : OCT 077126 TILDE V - DEFAULT PEN VELOCITY OCT 077121 TILDE Q - DEFAULT DASH LINES SOLID OCT 077057 TILDE SLASH - DEFAULT SLANT OCT 073572 LOîWER CASE W, LOWER CASE Z - DEFAULT ROTATION,TERMINATOR * * DFP12 DEC -18 SET-UP DEFAULT P1,P2 DEC 13 YES, SPECIAL HANDLING UPDATE GLOBALS OCT 77127 SET-UP DEFAULT P1 AN P2 ( ~,W ) OCT 062104 LOWER-LEFT (520,380) (SMALL D,CAPITAL D) OCT 042474 UPPER-RIGHT (15720,10380) (E,<) OCT 067526 (SMALL LETTER O,V) OCT 021042 (QUOTE MARK, QUOTE MARK) OCT 046176 (L,TILDE) OCT 051556 SET UP DEFAULT SCALING (S,SMALL N) OCT 033102 UPPER-RIGHT VALUE (15200,10000) (G,B) OCT 056120 (BACK SLASH,P) * * * GETID DEC 6 GET THE GRAPHIC DEVICE ID DEC 0 JUST RETURN THE LITERAL STRING FOLLOWING DEC 0 NOTHING SPECIAL TO DO ASC 3,7221A RETURN THE ID * * * GTG12 OCT 340 GET G1, G2 IN PLOTTER UNITS DEC +2 NEED TO OFFSET G2 BY G1 AND PUT ZEROES IN G1 DEC +7 READ GX1,GY1,GX2,GY2 (ESC.G) * * * OUTCP OCT 340 OUTPUT THE CURRENT POINT DEC +3 NEED TO OFFSET POINT BY G1 AMOUNT DEC +3 OUTPUT THE CURRENT POINT (ESC.C) * * * DIGIT OCT 340 DIGITIZE DEC +4 DIGIT NEEDS ONLY LOAD IT INTO THE GICBM DEC +4 (ESC . D) * * * CHRSL DEC -2 LABEL SLANT ON WITH SPECIFIED ANGLE DEC +5 NEED TO CONVERT RADIANS TO MBA PARAMETERS ASC 1,~/ LABEL SLANT ON PREAMBLE (TILDE,BACKSLASH) * * * CHRSO DEC -2 LABEL SLANT OFF DEC -1 NO SPECIAL HANDLING ASC 1,~/ DEFAULT SLANT BACK TO ZERO (TILDE,BACKSLASH) * * * CHRSI DEC -2 SET CHARACTER SIZE DEC +6 NEED TO CONVERT X,Y TO MBP FORMAT ASC 1,~% LABEL SIZE PREAMBLE (TILDE,PERCENT SIGN) * * * CHRST DEC -2 SET CHARACTER SETS DEC +7 NEED TO CONVERT X,Y TO MBP FORMAT ASC 1,~P CHARACTER SET SELECT PREAMBLE (TILDE,P) * * PEN0 DEC -1 PUT THE PEN AWAY DEC -1 NO SPECIAL HANDLING ASC 1,v SELECT PEN 0 (LOWER CASE V) * * * PENN DEC -1 PICK PEN N DEC 8 NEED TO CONVERT TO SBN ASC 1,v PREAMBLE FOR PEN SELECT (LOWER CASE V) * * * GETPN DEC 2 RETURN THE NUMBER OF PENS DEC 0 DEC 0 OCT 4 THERE ARE FOUR PENS ON THE 7221A. * * * LNTY0 DEC -2 SELECT LINE TYPE DEC 9 NEED TO PICK SEND THE PROPER LINE TYPE ASC 1,~Q PREAMBLE FOR FIX DASH LINE TYPES (TILDE,Q) * * * LNTYP DEC -2 SELECT LINE TYPE DEC 10 NEED TO PICK THE PROPER LINE TYPE AND LENGTH ASC 1,~Q PREAMBLE FOR FIX DASH LINE TYPE (TILDE,Q) * * * PENUP DEC -1 PEN-UP DEC 14 NEED TO SET LOGICAL PEN POSITION ASC 1,p MOVE TO THE NEXT POINT * * * * * * *ETX DEC -1 STOP LONG LABEL MODE * DEC -1 NO SPECIAL HANDLING * OCT 1400 (ETX) * * * GETDS DEC 16 RETURN THE DISPLAY SIZE IN MM DEC 0 LITERAL RETURN TO COMPUTER DEC 0 NOTHING SPECIAL TO DO DEC 0.0 LOWER LEFT IN MM (XLL) DEC 0.0 (YLL) DEC 400. X HEIGHT IN MM(FLOATING POINT) DEC 280. Y HEIGHT IN MM (FLOATING POINT) * * * MCUR DEC -1 MOVE CURSOR DEC 11 NEED TO CONVERT X,Y TO MBP ASC 1,p ABSOLUTE MOVE (LOWER CASE P) * * * * SG1G2 DEC -2 SET G1,G2 DEC +12 NEED TO CONVERT X,Y IN MBP ASC 1,~W SET GRAPHIC LIMITS (TILDE,W) * * * GETMU DEC +8 RETURN THE MU/MM DEC 0 LITERAL RETURN TO COMPUTER DEC 0 NOTHING SPECIAL TO DO DEC 40. 40 MU/MM IN THE X DIRECTION DEC 40. 40 MU/MM IN THE Y DIRECTION * * * GETZE DEC +2 RETURN ZERO TO VARIOUS QUERIES. DEC 0 LITERAL RETURN TO COMPUTER DEC 0 NOTHING SPECIAL TO$" DO OCT 0 RETURN VALUE OF ZERO(IMPLIES NO CAPABILITIES) * * * GET1 DEC 2 RETURN ONE TO VARIOUS QUERIES. DEC 0 LITERAL RETURN TO THE COMPUTER DEC 0 NOTHING SPECIAL TO DO DEC 1 RETURN VALUE OF ONE(IMPLIES YES CAPABILITIES) * * * GETSL DEC +8 RETURN THE CHARACTER SLANT MAXIMUMS DEC 0 LITERAL RETURN TO COMPUTER DEC 0 NOTHING SPECIAL TO DO DEC 1.5060 THE POSITIVE AMOUNT OF SLANT FROM VERTICAL DEC -1.5060 THE NEGATIVE AMOUNT OF SLANT FROM VERTICAL * * * GETFN DEC +10 RETURN THE FILE NAME (NOP) DEC 0 LITERAL RETURN TO COMPUTER DEC 0 NOTHING SPECIAL TO DO OCT 0 OCT 0 OCT 0 OCT 0 OCT 0 * * * GETCS DEC 9 MIN/MAX CHARACTER SIZES IN MU DEC 0 LITERAL RETURN TO THE COMPUTER DEC 0 NOTHING SPECIAL TO DO DEC 1.0 X MIN IN MACHINE UNITS DEC 1.0 Y MIN IN MACHINE UNITS DEC 16000.0 X MAXIMUM IN MACHINE UNITS DEC 16000.0 Y MAXIMUM IN MACHINE UNITS OCT 0 0=NO NEGATIVE PARAMETERS ALLOWED LIKE 7245A * * * GETLD DEC 4 LABEL DIRECTION RANGE DEC 0 LITERAL RETURN TO THE COMPUTER DEC 0 NOTHING SPECIAL TO DO OCT 2 ALL ANGLES ARE ACCEPTED OCT 0 ALL ANGLES ARE ALLOW * * * GETLO DEC 4 LABEL ORIGIN RANGE DEC 0 LITERAL RETURN TO THE COMPUTER DEC 0 NOTHING SPECIAL TO DO OCT 0 NO LORG RANGE OCT 0 ONLY TYPEWRITER MODE AVAILABLE * * * * END W$ Z e 92840-18100 1819 S C0122 XMIT INTFC MOD              H0101 @ASMB,R,L * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: XMIT INTFC MOD * SOURCE: 92840 - 18100 * RELOC: 92840 - 16001 * * * ************************************************************* * NAM XMIT,7 92840-16001 REV 1819 780515 EXT .OPTN,PLTER,XXMIT ENT XMIT * * THIS IS THE INTERFACE MODULE FOR THE AGL COMMAND XMIT * * XMIT NOP LDA XMIT JSB .OPTN DEF RTN DEF PARM DEF M2 DEF .1 DEF .1 ONE REQUIRED PARAMETER GCB DEF .0 NO OPTIONALS DEF RETRN RTN JMP ERROR JSB XXMIT DEF END PARM BSS 2 END JMP RETRN,I * * ERROR JSB PLTER DEF RTNER DEF .84 RTNER JMP RETRN,I * M2 OCT -2 RETRN NOP .84 DEC 84 .1 OCT 1 .0 OCT 0 END dT [a 92840-18101 1819 S C0122 DSTAT INTFC MOD              H0101 {ASMB,R,L * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: DSTAT * SOURCE: 92840 - 18101 * RELOC: 92840 - 16001 * * * ************************************************************* * NAM DSTAT,7 92840-16001 REV.1819 780515 * * THIS MODULE IS THE INTERFACE FOR AGL COMMANDS * DSTAT. * EXT XDSTT,.OPTN,PLTER ENT DSTAT * * DSTAT NOP LDA DSTAT JSB .OPTN OPTIONAL PARAMETER PROCESSING SUBROUTINE DEF RTN PADR DEF PARM DEF M5 NUMBER OF ENTRIES TO CLEAR DEF .1 DEF .4 NUMBER OF PARAMETERS - # OF DEFAULTS DEF .0 NUMBER OF DEFAULTS DEF DF1 TOP OF LIST FOR DEFAULT VALUES DEF RETRN RTN JMP MESUP ERROR RETURN JSB XDSTT DEF END PARM BSS 5 END JMP RETRN,I MESUP LDA PARM+1 STA IGCB JSB PLTER DEF RTNER DEF ERCOD IGCB NOP RTNER JMP RETRN,I * * * * SPC 3 B EQU 1 .4 OCT 4 M5 DEC -5 .0 OCT 0 .1 OCT 1 .2 OCT 2 .3 OCT 3 .5 OCT 5 DF1 DEF .1 RETRN NOP A EQU 0 ERCOD DEC 85 CODE NOP * END 2y \b 92840-18102 1819 S C0122 GSTAT INTFC MOD              H0101 ASMB,R,L * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: GSTAT * SOURCE: 92840 - 18102 * RELOC: 92840 - 16001 * * * ************************************************************* * NAM GSTAT,7 92840-16001 REV.1819 780515 * * THIS MODULE IS THE INTERFACE FOR AGL COMMANDS * GSTAT. * EXT XGSTT,.OPTN,PLTER ENT GSTAT * * GSTAT NOP LDA GSTAT JSB .OPTN OPTIONAL PARAMETER PROCESSING SUBROUTINE DEF RTN PADR DEF PARM DEF M5 NUMBER OF ENTRIES TO CLEAR DEF .1 DEF .4 NUMBER OF PARAMETERS - # OF DEFAULTS DEF .0 NUMBER OF DEFAULTS DEF DF1 TOP OF LIST FOR DEFAULT VALUES DEF RETRN RTN JMP MESUP ERROR RETURN JSB XGSTT DEF END PARM BSS 5 END JMP RETRN,I MESUP LDA PARM+1 STA IGCB JSB PLTER DEF RTNER DEF ERCOD IGCB NOP RTNER JMP RETRN,I * * * * SPC 3 B EQU 1 .4 OCT 4 M5 DEC -5 .0 OCT 0 .1 OCT 1 .2 OCT 2 .3 OCT 3 .5 OCT 5 DF1 DEF .1 RETRN NOP A EQU 0 ERCOD DEC 86 CODE NOP * END < ]c 92840-18103 1819 S C0122 GPMM INTFC MOD              H0101 <ASMB,R,L * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: GPMM INTFC MOD * SOURCE: 92840 - 18103 * RELOC: 92840 - 16001 * * * ************************************************************* * NAM GPMM,7 92840-16001 REV.1819 780515 EXT .OPTN,PLTER,XPMM ENT GPMM * * THIS IS THE INTERFACE MODULE FOR THE AGL COMMAND GPMM * * GPMM NOP LDA GPMM JSB .OPTN DEF RTN DEF PARM DEF M3 DEF .1 DEF .2 TWO REQUIRED PARAMETERS DEF .0 NO OPTIONALS DEF RETRN RTN JMP ERROR JSB XPMM DEF END PARM BSS 3 END JMP RETRN,I * * ERROR JSB PLTER DEF RTNER DEF .87 RTNER JMP RETRN,I * M3 OCT -3 RETRN NOP .87 DEC 87 .2 OCT 2 .1 OCT 1 .0 OCT 0 END 'H ^d 92840-18104 1819 S C0122 FRAME INTFC MOD              H0101 ^ASMB,R,L * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: FRAME INTFC MOD * SOURCE: 92840 - 18104 * RELOC: 92840 - 16001 * * * ************************************************************* * NAM FRAME,7 92840-16001 REV.1819 780515 EXT .OPTN,PLTER,XFRME ENT FRAME * * THIS IS THE INTERFACE MODULE FOR THE AGL COMMAND FRAME * * FRAME NOP LDA FRAME JSB .OPTN DEF RTN DEF PARM DEF M2 DEF .1 DEF .1 ONE REQUIRED PARAMETER GCB DEF .0 NO OPTIONALS DEF RETRN RTN JMP ERROR JSB XFRME DEF END PARM BSS 2 END JMP RETRN,I * * ERROR JSB PLTER DEF RTNER DEF .88 RTNER JMP RETRN,I * M2 OCT -2 RETRN NOP .88 DEC 88 .1 OCT 1 .0 OCT 0 END  _e 92840-18105 1819 S C0122 SET G U INT MOD              H0101 ASMB,R,L * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: SETUU\SETGU INTFC MOD * SOURCE: 92840 - 18105 * RELOC: 92840 - 16001 * * * ************************************************************* * NAM SETUU,7 92840-16001 REV.1819 780515 EXT .OPTN,PLTER,XSETU ENT SETUU,SETGU * * THIS IS THE INTERFACE MODULE FOR THE AGL COMMAND SETUU * * SETUU NOP LDA .1 STA CODE LDA .89 STA ERCOD LDA SETUU SET JSB .OPTN DEF RTN DEF PARM DEF M2 DEF CODE DEF .1 ONE REQUIRED PARAMETER GCB DEF .0 NO OPTIONALS DEF RETRN RTN JMP ERROR JSB XSETU DEF END PARM BSS 2 END JMP RETRN,I * SETGU NOP LDA .2 STA CODE LDA .90 STA ERCOD LDA SETGU JMP SET * ERROR JSB PLTER DEF RTNER DEF ERCOD RTNER JMP RETRN,I * M2 OCT -2 RETRN NOP .89 DEC 89 .90 DEC 90 .2 OCT 2 ERCOD NOP CODE NOP .1 OCT 1 .0 OCT 0 END % `f 92840-18106 1819 S C0122 IGERR INTFC MOD              H0101 tASMB,R,L * * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * * NAME: IGERR INTFC MOD * SOURCE: 92840 - 18106 * RELOC: 92840 - 16001 * * * ************************************************************* * NAM IGERR,7 92840-16001 REV.1819 780515 ENT IGERR EXT .OPTN,XIGER,PLTER EXT PLTER * * THIS IS THE INTERFACE MODULE FOR THE ERROR HANDLING COMMAND * IGERR(LU). * IGERR NOP LDA IGERR LG1 JSB .OPTN DEF RTN DEF PARM DEF M2 DEF .1 DEF .1 IGCB REQUIRED PARAMETER DEF .0 DEF RETRN RTN JMP ERROR JSB XIGER DEF END PARM NOP ERMSG NOP END JMP RETRN,I * RETRN NOP M2 DEC -2 .1 DEC 1 .2 OCT 2 .0 OCT 0 DF1 DEF .1 ERROR LDA PARM+1 STA IGCB JSB PLTER DEF RTNER DEF .91 IGCB NOP RTNER LDA .6 JMP RETRN,I .91 DEC 91 .6 OCT 6 END c ag 92840-18136 1840 S C0122 &DLTBL DEV. LINK TBLE SRC.             H0101 ɶASMB,R,L * * * DEVICE LINK TABLE 92840-18136 * * NAM DLTBL EXT DVG01,DCT01,DVG02,DCT02,DVG03,DCT03 EXT DVG05,DCT05,DVG07,DCT07 * * DEVICE LINK TABLE FOR THE 2648A,7245A,9872A,7221A, AND THE 9874A. * ENT DPTR * DPTR DEC 10 NUMBER OF ENTRIES IN TABLE DEF DVG01 DEVICE SUBROUTINE FOR THE 2648A DEF DCT01 DEVICE COMMAND TABLE FOR THE 2648A DEF DVG02 DEVICE SUBROUTINE FOR THE 9872A DEF DCT02 DEVICE COMMAND TABLE FOR THE 9872A DEF DVG03 DEVICE SUBROUTINE FOR THE 7245A DEF DCT03 DEVICE COMMAND TABLE FOR THE 7245A DEF DVG05 DEVICE SUBROUTINE FOR THE 7221A DEF DCT05 DEVICE COMMAND TABLE FOR THE 7221A DEF DVG07 DEVICE SUBROUTINE FOR THE 9874A DEF DCT07 DEVICE COMMAND TABLE FOR THE 9874A END 9 bh 92840-18137 1819 S C0122 &GPSBM AGL B/M IBL.             H0101 m SAMPLE BRANCH AND MNEMONIC TABLE 92840-18137 BTBL,MTBL,TRFL,ID=A PLOTR(IVA,I,I,I), VL, OV=0, SZ=15, ENT=PLOTR, FIL=%GPS78 GPON(IVA,I), VL, OV=0, ENT=GPON, FIL=%GPS78 PLOT(IVA,R,R,I), VL, OV=0, ENT=PLOT, FIL=%GPS78 MOVE(IVA,R,R), OV=0, ENT=MOVE, FIL=%GPS78 DRAW(IVA ,R,R), OV=0, ENT=DRAW, FIL=%GPS78 LIMIT(IVA,R,R,R,R), VL, OV=0, ENT=LIMIT, FIL=%GPS78 SETAR(IVA,R), VL, OV=0, ENT=SETAR, FIL=%GPS78 MARGN(IVA,R,R,R,R,I), VL, OV=0, ENT=MARGN, FIL=%GPS78 MSCAL(IVA,R,R), OV=0, ENT=MSCAL, FIL=%GPS78 SHOW(IVA,R,R,R,R), OV=0, ENT=SHOW, FIL=%GPS78 VIEWP(IVA,R,R,R,R), VL, OV=0, ENT=VIEWP, FIL=%GPS78 WINDW(IVA,R,R,R,R), OV=0, ENT=WINDW, FIL=%GPS78 CLIP(IVA,R,R,R,R), VL, OV=0, ENT=CLIP, FIL=%GPS78 AXES(IVA,R,R,R,R,R,R,R), VL, OV=0, ENT=AXES, FIL=%GPS78 LAXES(IVA,R,R,R,R,R,R,R), VL, OV=0, ENT=LAXES, FIL=%GPS78 GRID(IVA,R,R,R,R,R,R,R), VL, OV=0, ENT=GRID, FIL=%GPS78 LGRID(IVA,R,R,R,R,R,R,R), VL, OV=0, ENT=LGRID, FIL=%GPS78 LINE(IVA,I), VL, OV=0, ENT=LINE, FIL=%GPS78 LDIR(IVA,R,R), VL, OV=0, ENT=LDIR, FIL=%GPS78 PDIR(IVA,R,R), VL, OV=0, ENT=PDIR, FIL=%GPS78 LORG(IVA,I), OV=0, ENT=LORG, FIL=%GPS78 LABAX, OV=0, ENT=LABAX, FIL=%GPS78 PENUP(IVA), OV=0, ENT=PENUP, FIL=%GPS78 PEN(IVA,I), OV=0, ENT=PEN, FIL=%GPS78 CPLOT(IVA,R,R,I), VL, OV=1, SZ=15, ENT=CPLOT, FIL=%GPS78 GCLR(IVA,I), VL, OV=1, ENT=GCLR, FIL=%GPS78 IPLOT(IVA,R,R,I), VL, OV=1, ENT=IPLOT, FIL=%GPS78 DRAWI(IVA,R,R),  OV=1, ENT=DRAWI, FIL=%GPS78 MOVEI(IVA,R,R), OV=1, ENT=MOVEI, FIL=%GPS78 FXD(IVA,I), OV=1, ENT=FXD, FIL=%GPS78 RPLOT(IVA,R,R,I), VL, OV=1, ENT=RPLOT, FIL=%GPS78 MOVER(IVA,R,R), OV=1, ENT=MOVER, FIL=%GPS78 DRAWR(IVA,R,R), OV=1, ENT=DRAWR, FIL=%GPS78 PENDN(IVA), OV=1, ENT=PENDN, FIL=%GPS78 PORG(IVA,R,R), OV=1, ENT=PORG, FIL=%GPS78 XMIT(IVA), OV=1, ENT=XMIT, FIL=%GPS78 CSIZE(IVA,R,R,R), VL, OV=1, ENT=CSIZE, FIL=%GPS78 DSIZE(IVA,RV,RV,RV,RV,RV,RV),VL, OV=1, ENT=DSIZE, FIL=%GPS78 DSTAT(IVA,IA,I,IVA), OV=1, ENT=DSTAT, FIL=%GPS78 GSTAT(IVA,IA,I,IVA), OV=1, ENT=GSTAT, FIL=%GPS78 GPMM(IVA,R), OV=1,REAL, ENT=GPMM, FIL=%GPS78 FRAME(IVA), OV=1, ENT=FRAME, FIL=%GPS78 LABEL(IVA,I), VL, OV=1, ENT=LABEL, FIL=%GPS78 LABON(IVA), OV=1, ENT=LABON, FIL=%GPS78 LABOF(IVA), OV=1, ENT=LABOF, FIL=%GPS78 SETUU(IVA), OV=1, ENT=SETUU, FIL=%GPS78 SETGU(IVA), OV=1, ENT=SETGU, FIL=%GPS78 CLPON(IVA), OV=1, ENT=CLPON, FIL=%GPS78 CLPOF(IVA), OV=1, ENT=CLPOF, FIL=%GPS78 WHERE(IVA,RV,RV,IV), VL, OV=1, ENT=WHERE, FIL=%GPS78 POINT(IVA,R,R,I), VL, OV=1, ENT=POINT, FIL=%GPS78 CURSR(IVA,RV,RV,IV), VL, OV=1, ENT=CURSR, FIL=%GPS78 DIGTZ(IVA,RV,RV,IV), VL, OV=1, ENT=DIGTZ, FIL=%GPS78 LGERR(IVA,I), VL, OV=1, ENT=LGERR, FIL=%GPS78 IGERR(IVA), OV=1, INTG, ENT=IGERR, FIL=%GPS78 HDERR(IVA,I), OV=1, ENT=HD ERR, FIL=%GPS78  ck 92900-18001 1814 S 0563 92900A DIAGNOSTIC              H0105 ASMB,A,B,L HP92900 SUBSYST. DIAG. (Y.L.HPG) 15\03\78 HED GENERAL OPERATING PROCEDURE ORG 0 SUP * GENERAL OPERATING PROCEDURE * * A. LOAD DIAGNOSTIC CONFIGURATOR AND SET IT UP. * B. LOAD DIAGNOSTIC MAIN PROGRAM * C. LOAD P-REG. WITH ADDRESS 100B. * D. LOAD S-REG. WITH SELECT CODE AND TRANSFER CLOCK * RATE IF NECESSARY. * E. PRESS RUN AND WAIT FOR HALT 102074. * F. LOAD SWITCH REGISTER * IF SET =: * 15 = HALT AT END OF EACH TEST * 14 = SUPRESS ERROR HALTS * 13 = LOOP ON LAST TEST * 12 = LOOP ON DIAGNOSTIC * (SUPPRESS ALL OPERATOR INTERVENTION) * 11 = SUPRESS ERROR MESSAGES * 10 = SUPRESS NON-ERROR MESSAGES * 9 = GO TO USER CONTROL SECTION AT END OF TEST * 8 = SUPPRESS OPERATOR INTERVENTION TESTS * 7 = ABORT CURRENT RUNNING TEST * 6 = RESERVED * 5 HP40280 SELECT CODE WITH P=100 * = HP03070 HPIB ADDRESS WITH P=2000 & NOT TEST16 * 0 HP03070 MAX LINK ADDRESS WITH P=2000 & TEST16 * * NOTE: STANDARD RUN SHOULD BE WITH SW. REG. = 0 * USER CONTROL WILL ASK FOR A 32 BIT WORD. * EACH BIT WILL = 1 TEST * * G. PRESS RUN. * H. RESTART - LOAD P-REG. WITH ADDRESS 2000B * I. RECONFIGURE IF TESTING I/O INTERFACE - LOAD ADDRESS 100B * * GENERAL COMPUTER HALTS * * 1020XX E OR H 000 TO 067 * 1060XX E OR H 100 TO 167 * 1030XX E OR H 200 TO 267 * 1070XX E OR H 300 TO 367 * * CONTROL PROGRAM HALT MESSAGES * * 102077 END OF DIAG (A = PASS COUNT) * 102076 END OF TEST (A = TEST #) * 102075 USER SELECTION REQUEST * u&102074 SELECT CODE INPUT COMPLETE * 102073 USER SELECT CODE ERROR * 102072 BAD HPIB ADDRESS ( 1< BIT 5-0 <36 ) * 102071 RESERVED * 102070 RESERVED * 106077 TRAP CELL HALT * HED PROGRAM ORGANIZATION CHART * ******************************************* * * CONFIGURATOR 100B * * * LINKAGE TABLE * * ******************************************* * * EXECUTIVE 130B * * * LINKAGE * * ******************************************* * * CONSTANTS 150B * * * AND * * * STORAGE * * ******************************************* * * 2000B * * * EXECUTIVE CONTROL * * * * * ******************************************* * * IF USED * * * BASIC I/O TESTS (TEST 00) * * * ZCEND * * ******************************************* * * TABLE OF TEST POINTERS * * * TABLE OF I/O INSTR POINTERS * * ******************************************* * * * * * * * * * * * * * * * * * MAIN DIAGNOSTICS (1-31) * * * * * * * * * * * * 3  * * * * * ******************************************* * * * * * * * * * * * * * * * * * * * * HED CONFIGURATOR LINKAGE TABLE A EQU 0 A REGISTER REFERENCE B EQU 1 B REGISTER REFERENCE SW EQU 1 SWITCH REGISTER REFERENCE INTP EQU 0 INTERRUPT CHANNEL REFERENCE * * ORG 100B * JMP CFIG,I GO TO CONFIGURATION SECTION FAIN BSS 1 FAST INPUT (PHOTO READER) SLOP BSS 1 SLOW OUTPUT (LIST) FAOP BSS 1 FAST OUTPUT (DUMP OR PUNCH) SLIN BSS 1 SLOW INPUT (KEYBOARD) FWAM DEF FWAA FIRST WORD OF AVBL. MEMORY LWAM BSS 1 LAST WORD OF AVBL. MEMORY BSS 1 NOT USED (MAG TAPE) OTMC BSS 1 1 MILL SEC TIME OUT COUNT BSS 4 SELECT CODES FOR I/O CPTO BSS 1 COMPUTER TYPE/OPTIONS USSC BSS 1 USER CARD TYPE AND SELECT CODE MEMO BSS 1 MEMORY SIZE AND TYPE ISWR BSS 1 INTERNAL SWITCH REGISTER TMRR BSS 1 1 MILL SEC TIMER SWRC BSS 1 CONFIGURATOR SWITCH CK PTR I2AS BSS 1 INTEGER TO ASCII CONVERSION O2AS BSS 1 OCTAL TO ASCII CONVERSION AS2N BSS 1 ASCII CONVERSION DSNL BSS 1 DIAGNOSTIC SERIAL NUMBER FMTR BSS 1 FORMATTER * * * CONTROL LINKAGE AND DATA REFERENCES * CFIG DEF ZCONF CONFIGURATION SECTION MSGC DEF ZMSGC MESSAGE WITH NO HALT MSGH DEF ZMSGH MESSAGE WITH HALT ERMS DEF ZERMS ERROR MESSAGE SWRT DEF ZSWRT SWITCH REGISTER CHECK ROUTINE TSTN OCT 0 CURRENT TEST NUMBER EXRT DEF ZEXRT RETURN TO CONTROL PROGRAM NOP RESERVED * * * * * * * * * * * * * HED EXECUTIVE CONTROL ORG 2000B ZSTEX CLC INTP,C TURN I/O SYSTEM OFF JSB MSGC,I DO CRLF DEF ZRTLF LDA HDMP GET INTRODUCTORY MESSAGE +( STA *+2 JSB MSGC,I OUT PUT IT NOP CLA CLEAR PASS STA ZEOLC COUNT LDB ZSW9 CHECK FOR USER SELECTION REQ JSB SWRT,I JMP ZUSR IT'S USERS CHOICE ZNUSR LDA STDA GET STANDARD TEST RUN LDB STDB * JMP ZEXC * ZUSR LDA ZSINA RETRIEVE PREVIOUS RUN LDB ZSINB HLT 75B WAIT FOR USER INPUT NOP NOP NOP ZEXC STA ZUINA SAVE STB ZUINB USER STA ZSINA INPUT STB ZSINB PROGRAM LDB ZSW9 CHECK IF SW9 IS DOWN JSB SWRT,I JMP ZUSR NO GO AND WAIT CCA SET TEST NUMBER STA TSTN =-1 CLA STA ZTSTA CLEAR TEST RUN FLAG * * * * * * * * * * * * * * * * SKP ZEXCL LDA ZUINA RESTORE A REG. LDB ZUINB RESTORE B REG. ERA,RAL ROTATE ERB FIRST ERA TEST BIT STA ZUINA SAVE POSITIONS STB ZUINB ISZ TSTN MOVE TEST UP ONE NOP ZXCL1 LDA TSTN ADA TSTP GET IT'S LDA A,I ADDRESS CPA Z.M1 IS IT END OF LIST JMP ZEOL YES LDB ZUINB SSB,RSS SHOULD IT BE RUN? JMP ZEXCL NO STA ZTSTA YES - SAVE TEST ADDRESS JSB ZITCH INITIALIZE TRAP CELL HALTS JSB ZTSTA,I GO DO TEST ZEXRT LDA TSTN DISPLAY TEST NUMBER IF HALTED LDB ZSW15 CHECK FOR HALT AT END OF TEST JSB SWRT,I HLT 76B YES WAIT FOR OPERATOR LDB ZSW9 CHECK FOR ABORT JSB SWRT,I JMP ZUSR YES LDB ZSW13 CHECK FOR LOOP ON ROUTINE JSB SWRT,I JMP ZXCL1 YES - LOOP JMP ZEXCL CONTINUE * ZEOL LDA ZTSTA CHECK IF ANY TESTS WERE RUN SZA,RSS ? JMP ZNUSR NO SO PICK UP STANDARD RUN LDA ZEOLC UP DATE PASS COUNT INdA STA ZEOLC CCE LDB ZPSCA GET PASS COUNT ADB Z.2 ADDRESS JSB O2AS,I CONVERT IT JSB MSGC,I CALL PRINT ROUTINE ZPSCA DEF ZPSC LDB ZSW12 CHECK FOR LOOP ON DIAG. JSB SWRT,I JMP *+3 YES LDA ZEOLC HLT 77B NO WAIT AND DISPLAY PASS COUNT LDA ZSINA RESTORE ORIGINAL LDB ZSINB PROGRAM JMP ZEXC DO IT ALL AGAIN * SKP * MESSAGE OUTPUT WITH OUT HALT * ZMSGC NOP ENTRY JSB ZMSG OUTPUT MESSAGE OCT 2000 SWITCH 10 CHECK JMP ZMSGC,I RETURN TO CALLER * * MESSAGE OUTPUT WITH HALT * ZMSGH NOP ENTRY JSB ZMSG OUTPUT MESSAGE OCT 2000 SWITCH 10 CHECK LDA ZHLT GET HALT CODE STA *+2 PUT IT IN PLACE LDA ZSAVA RESTORE A REGISTER NOP HALT FOR DISPLAY JMP ZMSGH,I RETURN TO CALLER * * ERROR MESSAGE WITH HALT * ZERMS NOP ENTRY JSB ZMSG OUTPUT MESSAGE OCT 4000 SWITCH 11 CHECK CLA LDB ZSW14 CHECK SWR BIT 14 TO SUPPRESS JSB SWRT,I HALT STA *+3 PUT HALT IN PLACE LDA ZSAVA RESTORE A & B LDB ZSAVB ZHLT NOP WAIT FOR OPERATOR JSB SHRTN EXAMINE S-REG BIT 7 LDA ZSAVA RESTORE A & B LDB ZSAVB JMP ZERMS,I RETURN TO CALLER * * * * * * * * * * * * * SKP * OUTPUT MESSAGE * ZMSG NOP STA ZSAVA SAVE A AND B REGISTERS STB ZSAVB LDB ZMSG,I GET SWITCH REGISTER BIT LDA ZMSG ADA Z.M2 DECREMENT RETURN ADDRESS STA ZMSG JSB SWRT,I CHECK TO SUPPRESS MESSAGE JMP ZMSG0 YES LDA ZMSG,I CHECK IF ERROR LDA A,I LDA A,I IF SO ALF,ALF AND Z.177 CPA ZA.E JSB ZCFTN CHECK TO OUTPUT TEST NUMBER sp LDA ZMSG,I NO RETRIEVE FORMAT LDB A,I ADDRESS CLA,CLE JSB FMTR,I ZMSG0 LDA ZMSG,I CONVERT HALT CODE LDB A,I FROM ASCII STRING CCA,CCE JSB AS2N,I STA ZN2AO SAVE RESULT AND Z.300 DECODE LDB ZH2 HALT CODE CPA Z.100 LDB ZH6 CPA Z.200 LDB ZH3 CPA Z.300 LDB ZH7 LDA ZN2AO GET HALT NUMBER AND Z.77 IOR B STA ZHLT SAVE IT ISZ ZMSG,I ADJUST RETURN POINTERS ISZ ZMSG ISZ ZMSG ISZ ZMSG LDA ZSAVA RESTORE A AND B REGISTERS LDB ZSAVB JMP ZMSG,I * * * * * * SKP ZCFTN NOP LDA TSTN GET TEST NUMBER CPA ZCFTT IS IT THE SAME ONE? JMP ZCFTN,I YES SKIP OUTPUT STA ZCFTT NO - THEN UPDATE IT JSB ZN2AO CONVERT IT STA ZTSTN PUT IT IN STRING CLA DO A CRLF JSB SLOP,I CLA,CLE INDICATE START OF FORMAT LDB ZTSTF JSB FMTR,I JMP ZCFTN,I RETURN * * ZSAVA NOP ZSAVB NOP ZEOLC NOP ZTSTA NOP ZSINA NOP ZSINB NOP ZUINA NOP ZUINB NOP ZBTMP NOP Z.2 OCT 2 Z.7 OCT 7 Z.10 OCT 10 Z.60 OCT 60 Z.77 OCT 77 Z.177 OCT 177 Z.M1 DEC -1 Z.M2 DEC -2 ZD100 DEC -100 ZIOM OCT 177700 ZSW15 OCT 100000 ZSW14 OCT 40000 ZSW13 OCT 20000 ZSW12 OCT 10000 ZS812 OCT 010400 ZSW9 OCT 1000 Z.100 OCT 100 Z.200 OCT 200 Z.300 OCT 300 ZH2 OCT 102000 ZH6 OCT 106000 ZH3 OCT 103000 ZH7 OCT 107000 ZCFTT DEC -1 ZTSTF DEF *+1 ASC 3,TEST ZTSTN ASC 2,XX// ZRTLF ASC 1,// ZPSC ASC 6,PASS XXXXXX/ ZA.E OCT 105 HED GENERAL ROUTINES * * ZN2AO NOP STA ZIOAD SAVE NUMBER AND Z.7 CONVERT FIRST IOR Z.60 NUMBER STA B SAVE IT LDA ZIOAD GET RAR,RAR SECOND RAR NUMBER AND Z.7 CONVERT )  IOR Z.60 IT ALF,ALF MOVE TO UPPER HALF IOR B ADD LOWER JMP ZN2AO,I AND RETURN * * * * SWITCH REGISTER CHECK * ZSWRT NOP STA ZN2AO SAVE A REGISTER LIA SW GET SWITCH REG. AND B MASK OUT BIT SZA,RSS IS IT UP? ISZ ZSWRT NO LDA ZN2AO RESTORE A REGISTER LIB SW LET B = SWITCH REGISTER JMP ZSWRT,I RETURN TO CALLER * * * * INITIALIZE TRAP CELL HALTS * ZITCH NOP LDA ZTSH GET STARTING TRAP CELL HALT LDB Z.2 GET FIRST TRAP CELL LOCATION ZTSHL STA B,I PUT IT IN PLACE CPB Z.77 AM I FINISHED JMP ZITCH,I YES INB NEXT ADDRESS JMP ZTSHL * ZTSH OCT 106077 * * * SKP * PUT JSB INSTRUCTION IN TRAP CELL * ZTCJI NOP LDB ZJSBI GET INSTRUCTION STB ZIOSC,I PUT IT IN TRAP CELL LDA ZTCJI,I GET LOCATION STA 3B SAVE IT FOR JSB INSTRUCTION ISZ ZTCJI ADJUST RETURN JMP ZTCJI,I RETURN TO CALLER * ZJSBI JSB 3B,I JSB INSTRUCTION * * * INITIALIZE SELECT CODE I/O INSTRUCTIONS * ZISC NOP STA ZIOSC SAVE SELECT CODE STB ZIOAD SAVE TABLE ADDRESS ZIOL LDB ZIOAD,I GET ADDRESS OF LOCATION CPB Z.M1 IS IT THE TERMINATOR JMP ZISC,I YES RETURN TO CALLER LDA B,I NO - GET CONTENTS AND ZIOM MASK OFF OLD SELECT CODE IOR ZIOSC ADD IN NEW SELECT CODE STA B,I RESTORE IT ISZ ZIOAD MOVE TO NEXT ADDRESS JMP ZIOL DO IT * ZIOSC NOP ZIOAD NOP * * * * SKP * CONFIGURATION SECTION * ZCONF CLC INTP,C TURN I/O SYSTEM OFF LIA SW GET SELECT CODE AND OPTIONS STA USSC SAVE THEM AND B0700 GET TRANSFER RATE CLOCK SZA,RSS IF 0, FORCE TO 200 KHZ LDA Z.200 LDB pKSTDTM GET STD TIMING CPA Z.100 IS IT 100 KHZ ? JMP ZMUL2 CPA Z.200 IS IT 200 KHZ ? JMP ZLETB CPA Z.300 IS IT 400 KHZ ? RSS JMP ZHL73 ZDIV2 BRS HALF TIMING ADB M2 LITTLE OVERHEAD COMP. RSS ZMUL2 BLS DOUBLE TIMING ZLETB STB TLTMG LDA USSC AND Z.77 ELIMINATE OPTIONS LDB A CMB,INB CHECK THAT SC > 7 ADB Z.7 SSB ? JMP *+3 OK GO ON ZHL73 HLT 73B NO JMP ZCONF TRY AGAIN LDB IOIP INITIALIZE TEST I/O JSB ZISC INSTRUCTIONS HLT 74B ALLOW OPERATOR TO CHANGE SWIT JMP ZSTEX GO TO EXEC CONTROL SECTION * * * * * * * * * * * * * * * * * * * * HED BASIC I/O TESTS CH EQU 10B * TST00 EQU * BASIO NOP LDB UTCMD BITS 8 & 12 OPTIONS ? JSB SWRT,I JMP BASIO,I LDA USSC GET CELL LOCATION AND Z.77 JSB ZBIO DO BASIC I/O JMP TST00,I * ZBIO NOP CLC INTP,C TURN OFF ALL I/O LDB ZBIOD INITIALIZE BASIC I/O JSB ZISC INSTRUCTIONS * * INTERRUPT FLAG CHECK * ZBIO1 STF INTP CLF INTP SFC INTP RSS JMP *+3 E000 JSB ERMS,I E000 CLF 0-SFC 0 ERROR DEF ZBE00 SFS INTP JMP *+3 E001 JSB ERMS,I E001 CLF 0-SFS 0 ERROR DEF ZBE01 STF INTP SFC INTP JMP *+4 CLF INTP TURN OFF INTS E002 JSB ERMS,I E002 STF 0-SFC 0 ERROR DEF ZBE02 SFS INTP JMP *+3 CLF INTP TURN OFF INTERRUPTS JMP ZBIO2 CLF INTP TURN OFF INTS E003 JSB ERMS,I E003 STF 0-SFS 0 ERROR DEF ZBE03 JMP ZBIO2 * ZBE00 ASC 12,E000 CLF 0-SFC 0 ERROR/ ZBE01 ASC 12,E001 CLF 0-SFS 0 ERROR/ ZBE02 ASC 12,E002 STF 0-SFC 0 ERROR/ ZBE03 ASC 12,E003 STF 0-SFS 0 ERROR/ * * SKP ; * CARD FLAG CHECK * ZBIO2 EQU * ZBS21 STF CH ZBS22 CLF CH ZBS23 SFC CH RSS JMP *+3 E005 JSB ERMS,I E005 CLF CH-SFC CH ERROR DEF ZBE05 ZBS24 SFS CH JMP *+3 E006 JSB ERMS,I E006 CLF CH-SFS CH ERROR DEF ZBE06 ZBS25 STF CH ZBS26 SFC CH JMP *+3 E007 JSB ERMS,I E007 STF CH-SFC CH ERROR DEF ZBE07 ZBS27 SFS CH RSS JMP ZBIO3 E010 JSB ERMS,I E010 STF CH-SFS CH ERROR DEF ZBE10 JMP ZBIO3 * ZBE05 ASC 13,E005 CLF CH-SFC CH ERROR/ ZBE06 ASC 13,E006 CLF CH-SFS CH ERROR/ ZBE07 ASC 13,E007 STF CH-SFC CH ERROR/ ZBE10 ASC 13,E010 STF CH-SFS CH ERROR/ * * * * * * * * * * * * * * * * * * * SKP * INTERRUPT CONTROL * ZBIO3 JSB ZTCJI SET JSB INSTRUCTION DEF ZB3E ZBS31 STF CH SET THE FLAG ZBS32 STC CH SET THE CONTROL STF INTP TURN I/O SYSTEM ON THEN CLF INTP TURN I/O SYSTEM OFF NOP GIVE IT A CHANCE TI INTERRUPT NOP ZBS33 CLF CH RESET CH FLAG JMP ZBIO4 * ZBE04 ASC 16,E004 CLF 0 DID NOT INHIBIT INT/ * ZB3E NOP CLF INTP TURN OFF INTS E004 JSB ERMS,I E004 DEF ZBE04 * * * * * * * * * * * * * * * * * * * * * * * * SKP * SELECT CODE SCREEN TEST * ZBIO4 LDB Z.10 START WITH LOWEST ADDRESS ZB40 LDA USSC GET SELECT CODE AND Z.77 CPB A IS IT THE CH? JMP Z.CLF+1 YES - SKIP TEST LDA Z.STF SET UP AND ZIOM IOR B STF INSTRUCTION STA Z.STF PUT IT IN PLACE LDA Z.CLF SET UP AND ZIOM IOR B CLF INSTRUCTION STA Z.CLF PUT IT IN LINE ZBS41 CLF CH CLEAR CHANNEL FLAG Z.STF STF CH EXECUTE STF CH INSTRUCTION ZBS42 SFC CH TEST CHANNEL FLAG JMP ZB41 Z.CLF CLF CH CLEAR TEST FLAG CPB Z.77 :<:6 IS TEST FINISHED? JMP ZBIO5 YES INB NO JMP ZB40 DO NEXT CHANNEL * ZBE11 ASC 14,E011 STF XX SET CARD FLAG// * ZB41 STB ZBTMP SAVE NUMBER LDA B CONVERT CH FOR MESSAGE JSB ZN2AO STA ZBE11+5 LDA ZBTMP RETRIEVE NUMBER E011 JSB ERMS,I E011 DEF ZBE11 * * * * * SKP ! <* CHECK INTERRUPT & HOLD OFF * ZBIO5 JSB ZTCJI DEF ZBI5 CLA SET UP STA ZBF5 FLAGS STA ZBI5 FOR TEST STA ZBTMP ZBS51 STC CH TURN ON ZBS52 STF CH CARD STF INTP AND INTERRUPTS STC 1 * STF 1 * CLC 1 * CLF 1 * NO INTERRUPT JMP *+1,I * SHOULD OCCURR DEF *+1 * HERE JSB *+1,I * DEF *+1 * ZBF5 NOP * ISZ ZBTMP INT. SHOULD BE HERE ISZ ZBTMP CLF INTP TURN I/O SYSTEM OFF LDA ZBI5 DID IT INTERRUPT? SZA JMP *+4 E014 JSB ERMS,I E014 NO INT DEF ZBE14 JMP ZBIO6 ABORT REST OF SECTION LDA ZBTMP CHECK FOR CORRECT INTERRUPT CPA Z.2 ? JMP *+3 E026 JSB ERMS,I E026 INT EXECUTION ERROR DEF ZBE26 ZBS53 CLF CH TURN OFF CH FLAG JMP ZBIO6 GO TO NEXT SECTION * ZBD5 DEF ZBF5-1 ZBD5A DEF ZBF5+1 * ZBE12 ASC 16,E012 INT DURING HOLD OFF INSTR/ ZBE13 ASC 12,E013 SECOND INT OCURRED/ ZBE14 ASC 06,E014 NO INT/ ZBE15 ASC 12,E015 INT RTN ADDR ERROR/ ZBE26 ASC 13,E026 INT EXECUTION ERROR/ * * * * SKP ZBI5 NOP CLF INTP TURN I/O SYSTEM OFF LDA ZBD5 CHECK TO SEE IF ALL CPA ZBF5 INSTRUCTION COMPLETED JMP *+3 YES E012 JSB ERMS,I E012 INT DURING HOLD OFF DEF ZBE12 LDA ZBD5A CHECK RETURN ADDRESS LDB CPTO IF 210X SSB ADD ONE INA CPA ZBI5 JMP ZBI5A E015 JSB ERMS,I E015 INT RTN ADDR ERROR DEF ZBE15 JMP ZBIO6 ZBI5A JSB ZTCJI SET SECOND INT TRAP DEF ZBT5 STF INTP TURN I/O SYSTEM ON JMP ZBI5,I CONTINUE TEST * * ZBT5 NOP CLF INTP TURN I/O SYSTEM OFF E013 JSB ERMS,I E013 SECOND INT OCURRED DEF ZBE13 * * * * * vSKP * CLC CH AND CLC 0 * ZBIO6 JSB ZTCJI SET JSB INSTRUCTION DEF ZBI61 ZBS61 STC CH SET CH CONTROL ZBS62 STF CH SET CH FLAG STF INTP TURN ON INTERRUPTS ZBS63 CLC CH CLEAR CH CONTROL NOP GIVE IT A CHANCE NOP CLF INTP TURN INTS OFF ZB60 JSB ZTCJI SET JSB INSTRUCTION DEF ZBI62 ZBS64 CLF CH CLEAR CH FLAG ZBS65 STC CH SET CH CONTROL ZBS66 STF CH SET CH FLAG STF INTP TURN ON INTS CLC INTP CLEAR I/O SYSTEM NOP GIVE IT A CHANCE NOP CLF INTP TURN OFF INTS JMP ZBIO7 * * ZBI61 NOP CLF INTP TURN OFF INTS E016 JSB ERMS,I E016 CLC CH ERROR DEF ZBE16 JMP ZB60 * ZBI62 NOP CLF INTP TURN OFF INTS E017 JSB ERMS,I E017 CLC 0 ERROR DEF ZBE17 JMP ZBIO7 * ZBE16 ASC 9,E016 CLC CH ERROR/ ZBE17 ASC 9,E017 CLC 0 ERROR/ * * * * * SKP * EXTERNAL & INTERNAL PRESET TEST * ZBIO7 LDB ZS812 CHECK TO SUPPRESS JSB SWRT,I ? JMP H025 YES - SKIP PRESET TEST H024 JSB MSGC,I TELL OPERATOR DEF ZBM24 PRESS PRESET * ZBS71 CLF CH CLEAR CH FLAG STF INTP TURN ON INTS JSB ZTCJI SET TRAP CELL JSB INSTRUCTION DEF ZBI70 HLT 24B WAIT FOR OPERATOR CLA,INA SET UP FLAGS FOR TESTS SFS INTP CHECK INTP FLAG CLA NOT SET SO CLEAR FLAG RAL MOVE TO NEXT FLAG CLF INTP TURN OFF ONTPS ZBS72 SFS CH CHECK CHANNEL FLAG INA NOT SET SO FLAG IT RAL MOVE TO NEXT FLAG LIB 0 CHECK I/O BUSS SZB SHOULD BE ZERO INA NOT SO FLAG IT RAL MOVE TO NEXT FLAG STF INTP CHECK CONTROL ON CARD NOP GIVE IT A CHANCE NOP CLF INTP TURN OFF INTPS Q* * SKP ZB70 SLA,RSS CHECK FOR ERRORS JMP *+3 E022 JSB ERMS,I E022 DID NOT CLEAR CONTROL DEF ZBE22 RAR SLA,RSS JMP *+3 E023 JSB ERMS,I E023 I/O LINES NOT CLEAR DEF ZBE23 RAR SLA,RSS JMP *+3 E020 JSB ERMS,I E020 FLAG NOT SET DEF ZBE20 RAR SLA,RSS JMP *+3 E021 JSB ERMS,I E021 DID NOT DIABLE INTS DEF ZBE21 H025 JSB MSGC,I TELL OPERATOR DEF ZBM25 BASIC I/O IS COMPLETE JMP ZBIO,I RETURN TO CALLER * ZBI70 NOP CONTROL FAILED CLF INTP TURN OFF INTPS INA JMP ZB70 * ZBE20 ASC 17,E020 PRESET(EXT) DID NOT SET FLAG/ ZBE21 ASC 19,E021 PRESET(INT) DID NOT DISABLE INTS/ ZBE22 ASC 20,E022 PRESET(EXT) DID NOT CLEAR CONTROL/ ZBE23 ASC 21,E023 PRESET(EXT) DID NOT CLEAR I-O LINES/ ZBM24 ASC 17,H024 PRESS PRESET (EXT&INT),RUN/ ZBM25 ASC 08,H025 BI-O COMP/ SKP ZBIOD DEF *+1 DEF ZBS21 DEF ZBS22 DEF ZBS23 DEF ZBS24 DEF ZBS25 DEF ZBS26 DEF ZBS27 DEF ZBS31 DEF ZBS32 DEF ZBS33 DEF ZBS41 DEF ZBS42 DEF ZBS51 DEF ZBS52 DEF ZBS53 DEF ZBS61 DEF ZBS62 DEF ZBS63 DEF ZBS64 DEF ZBS65 DEF ZBS66 DEF ZBS71 DEF ZBS72 DEC -1 * ZCEND EQU * * HED ***** DIAGNOSTIC DEFINITION ***** * * ORG 126B DSN OCT 104117 DIAGNOSTIC SERIAL NUMBER * * ORG 140B IOIP DEF IODP TSTP DEF TSTD HDMP DEF HDMS STDA OCT 007777 STD TESTS 0 TO 13 STDB OCT 000000 * * ORG 150B * LIGNA DEF LIGNE BGINA DEF BGINN BGYNA DEF BEGIN CONFA DEF CONFG SNDEA DEF SNDER INDXA DEF INDXT SNDNA DEF SNDNG TESTA DEF TESTR VERFA DEF VERFY BUZZA DEF BUZZZ TSTEA DEF TSTER DXTAD DEF DXTAB RETAD DEF RETAB BFBAS DEF BFTAB CODAD DEF CDTAB KBTAD DEF KBTAB FKTAD DEF FKTAB ORDRA DEF ORDRT ABORT DEF ZEXRT ADAT1 DEF DATA1 PRMSA DEF PRMES SFKAD DEF SFKTB DCFAD DEF DCFTB SRQAD DEF SRQTB SRTB1 DEF UNLSN SRTB2 DEF UNLSN+7 SRTB3 DEF RDSTB+1 RDSEQ DEF RDATA PRSEQ DEF PRATA * * HED ***** DATA ***** * * OCT07 OCT 000007 OCT35 OCT 000035 OC140 OCT 000140 OC160 OCT 000160 NOC37 OCT 177740 TILDA OCT 010176 CDGEN OCT 010131 BIT15 OCT 100000 BIT14 OCT 040000 BIT13 OCT 020000 BIT12 OCT 010000 BIT11 OCT 004000 BIT10 OCT 002000 BIT09 OCT 001000 BIT08 OCT 000400 BIT07 OCT 000200 BIT05 OCT 000040 BIT03 OCT 000010 NBT15 OCT 077777 BT154 OCT 140000 BT110 OCT 006000 NBIT7 OCT 177577 NB154 OCT 037777 BT910 OCT 003000 B3210 OCT 000017 B0346 OCT 000131 B5432 OCT 170000 B0777 OCT 000777 B7000 OCT 007000 B0700 OCT 000700 B6520 OCT 000145 BT520 OCT 000045 * MSA00 OCT 010573 RJE,CAD,HOLES,ASCII MSA01 OCT 010567 RJE,CAD,HOLES+MARKS,IMAGE MSA02 OCT 010572 RJE,NCL,HOLES,80 COL,ASCII MSA07 OCT 010552 RJD,NCL,HOLES,80 COL,ASCII MLAC2 OCT 010576 KEYBOARD MODE (2) SEC CMND SFTST OCT 010577 REMOTE SELF-TEST TRIGGER COMMAND * RBYTE OCT 000377 UTCMD OCT 010400 LSN34 OCT 010474 DCL OCT 010424 * @@ ASC 1,@@ @Q ASC 1,@Q H@ ASC 1,H@ * SKP * * P1000 DEC 1000 P250 DEC 250 P90 DEC 90 P63 DEC 63 P62 DEC 62 P40 DEC 40 P20 DEC 20 P18 DEC 18 P17 DEC 17 P14 DEC 14 P13 DEC 13 P11 DEC 11 P10 DEC 10 P9 DEC 9 P5 DEC 5 P4 DEC 4 P3 DEC 3 P2 DEC 2 M1000 DEC -1000 M121 DEC -121 M63 DEC -63 M62 DEC -62 M41 DEC -41 M40 DEC -40 M38 DEC -38 M28 DEC -28 M20 DEC -20 M16 DEC -16 M15 DEC -15 M14 DEC -14 M10 DEC -10 M2 DEC -2 TM15S DEC -3000 TLTMG DEC -16 CONTROLLER TIME OUT X 5 MS = STDTM DEC -16 STD TIME OUT FOR 200 KHZ CLOCK CAPA. OCT 000101 CAPB. OCT 000102 STDMK OCT 013000 SRPMK OCT 042100 SRQEX OCT 041000 * * SKP * DCFTB OCT 010537 UNTALK OCT 010477 UNLISTEN OCT 000000 INPUT TO WAIT SRQ IFC OCT 014000 IFC UTDAT OCT 010000 IFC BAR LSNXX OCT 010475 LISTEN DISPLAY OCT 010141 LIT FIRST LIGHT OCT 010143 AND SO ON ... OCT 010145 OCT 010147 OCT 010151 OCT 010153 SFKTB OCT 010155 OCT 010157 OCT 010161 OCT 010163 OCT 010165 OCT 010167 OCT 010171 OCT 010173 OCT 010175 UNLSN OCT 010477 UNLISTEN LSN36 OCT 010476 LISTEN ISP SPE OCT 010430 SERIAL POLL ENABLE TLK35 OCT 010535 TALKER KEYBOARD RDSTB OCT 000000 INPUT => TEST STATUS (BIT 6) UNTLK OCT 010537 UNTALK SPD OCT 010431 SERIAL POLL DISABLE OCT 014000 IFC TO CLEAR LEDS OCT 010000 NOT IFC OCT 010476 ISP LISTENER AGAIN LSN35 OCT 010475 LISTEN DISPLAY MSBYT NOP TERMINAL ADDR MS DIGIT LSBYT NOP " " LS DIGIT OCT 010012 LF TO RESET DISPLAY TLKXX OCT 010535 TALKER KEYBOARD DEC -1 * SRQTB EQU IFC * PRATA OCT 010537,010477 LSN33 OCT 010473 ASC 20,PRESS SRQ TO RESTART ASC 20,   ( NO  READER )   OCT 010012 DEC -1 * RDATA OCT 010537,010477,010473 ASC 20,  INPUT YOUR CARD   OCT 010012,010476 TLK34 OCT 010534,000000,010537,010012 DEC -1 * SKP * * CDTAB OCT 010060 0 OCT 010061 1 OCT 010062 2 OCT 010063 3 OCT 010064 4 OCT 010065 5 OCT 010066 6 OCT 010067 7 OCT 010070 8 OCT 010071 9 SPACE OCT 010040 SP OCT 010055 - D.PNT OCT 010056 . CAP.E OCT 010105 E DEL OCT 010177 DELETE CAP.A OCT 010101 A CAP.B OCT 010102 B CAP.C OCT 010103 C CAP.D OCT 010104 D LFCOD OCT 010012 LINE FEED M.1 DEC -1 KBTAB OCT 000060 0 KEY OCT 000061 1 " OCT 000062 2 " OCT 000063 3 " OCT 000064 4 "  OCT 000065 5 " OCT 000066 6 " OCT 000067 7 " OCT70 OCT 000070 8 " OCT 000071 9 " OCT 000056 . " OCT 000055 - " OCT 000177 DELETE KEY LF OCT 000012 ENTER KEY FKTAB OCT 000020 SFK CODES TABLE OCT21 OCT 000021 OCT 000022 OCT 000023 OCT 000024 OCT 000025 OCT 000026 OCT 000027 OCT30 OCT 000030 OCT31 OCT 000031 * * SKP * * ORDRT OCT 010141 OCT 010152 OCT 010143 OCT 010140 OCT 010145 OCT 010142 RL4ON OCT 010147 OCT 010144 OCT 010151 RL4OF OCT 010146 OCT 010163 OCT 010150 OCT 010161 OCT 010162 OCT 010157 OCT 010160 OCT 010155 OCT 010156 OCT 010153 OCT 010154 OCT 010165 OCT 010152 OCT 010167 OCT 010164 OCT 010171 OCT 010166 OCT 010173 OCT 010170 OCT 010175 OCT 010172 OCT 010163 NPL15 OCT 010174 OCT 010161 OCT 010162 OCT 010157 OCT 010160 OCT 010155 OCT 010156 OCT 010153 OCT 010154 * * SKP * * DATAD DEF DATAB DATAB REP 63 DATABASE FOR TST1 OCT 117777 OCT 137776 OCT 137775 OCT 137773 OCT 137767 OCT 137757 OCT 137737 OCT 137677 OCT 137577 OCT 137377 OCT 136777 OCT 135777 OCT 133777 OCT 117777 OCT 130000 OCT 114000 OCT 112000 OCT 111000 OCT 110400 OCT 110200 OCT 110100 OCT 110040 OCT 110020 OCT 110010 OCT 110004 OCT 110002 OCT 110001 OCT 110000 M1 DEC -1 NB750 OCT 177500 BIT50 OCT 000077 SC EQU 10B * / PAD CHAR IS "DLE" TO GIVE 010 FOR LEFT BYTE PRMES ASC 5,ERROR DEC -1 * * IMAGE CONTENT OF DIAGNOSTIC CARD #1 * DATA1 AS.C 14,??@@@ @P@H@D@B@A @P@H@D@B@A@ ASC 14,?_?/?7?;?=?>_?/?7?;?=?>?**UU ASC 12,**UU**UU**UU**UU**UU**UU * * HED ***** TABLES ***** * * TEMP0 BSS 1 TEMP1 BSS 1 TEMP2 BSS 1 TEMP3 BSS 1 TEMP4 BSS 1 COBAS BSS 1 SCPAD BSS 1 FOKAD BSS 1 WITNS BSS 1 * STBYT BSS 1 CNTR BSS 1 TIME BSS 1 DEBUT BSS 1 VARIA BSS 1 SCUTY BSS 1 BLINK BSS 1 * DXTAP BSS 1 DXTOK BSS 1 DXTAR BSS 1 RETAR BSS 1 RETAP BSS 1 RETOK BSS 1 * TRDXA EQU TEMP0 TERPT EQU TEMP1 BFPNT EQU TEMP2 CTBFA EQU TEMP3 CINAD EQU TEMP4 TRDXT EQU COBAS SQCER EQU SCPAD EOIND EQU FOKAD RDFLG EQU WITNS * LIGNE BSS 20 DXTAB BSS 64 RETAB BSS 64 ADDR3 EQU * * * ORG 10000B BFTAB BSS 1300 ADDR4 EQU * * ORG ADDR3 * * HED ***** SUBROUTINES FOR TESTS ***** * * INITIALIZATION SUBROUTINE * INITZ NOP LDA INITZ SAVE RTN ADDR STA INITS JMP STD35 FORCE HPIB ADDR TO 35 INITS NOP LIA SW GET S-REG AND BIT50 GET HPIB ADDRESS STA B SAVE SZB,RSS IF ZERO, FORCE TO 35 STD35 LDB OCT35 JSB HPIBC AND CONF ALL COMMAND BYTES LDA DXTAD CALCULATE TABLE POINTERS ADA P62 STA DXTAR ADDR OF LAST WORD IN DXTAB STA DXTOK INA STA DXTAP LIMIT INDEX FOR TABLE SCANNING LDA RETAD ADA P62 STA RETAR ADDR OF LAST WORD IN RETAB STA RETOK INA STA RETAP LIMIT INDEX FOR TABLE SCANNING LDB DXTAD CLEAR DXT SET BIT15 EXCEP ON LAST LDA BIT15 STDXT STA B,I STORE 100000 IN DXTAB INB CPB DXTAR RSS LAST WORD : BIT15 MUST BE CLEAR JMP STDXT NOT LAST WORD WRITE AGAIN CLA STA B,I LDB RETAD CLEAR RETAB CLA STRXT STA B,I STORE 0'S EVERY RETAB WORD INB CPB RETAP FINISHED ? JMP INITS,I YES END INITS SBR JMP STRXT NOD! * *SBR SEND IFC ALL ADDR * AIFCL NOP LDA IFC IFC = 014000 JSB SNDEA,I LDA BIT12 BIT12 = 010000 JSB SNDEA,I JMP AIFCL,I * * SKP * * *SBR SEND IFC TO ONE ADDR * OIFCL NOP LDA IFC IFC = 014000 JSB SNDNA,I LDA BIT12 BIT12 = 010000 JSB SNDNA,I JMP OIFCL,I * *SBR TO EXEC POLLING+OK BIT CHECK * INOUT NOP POLL ALL ADDRESS JSB SNDEA,I LDA BIT14 JSB TESTA,I JMP INOUT,I E0144 JSB ERMS,I ERROR: NO OK DEF MS144 JMP INOUT,I * *SBR TO CONFIGURE HPIB COMMANDS % S-REG 4-0 * HPIBC NOP CONFIGURE HPIB COMMAND BYTES LDA M2 VERIFY 1 < ADDRESS < 36 ADA B SSA JMP HPIBF ADDR NOT > 1 ADA M28 SSA,RSS JMP HPIBF ADDR NOT < 36 LDA TLK35 AND NOC37 IOR B STA TLK35 CONFIGURE TLK N STA TLKXX ADA M1 STA TLK34 CONFIGURE TLK N-1 LDA LSN35 AND NOC37 IOR B STA LSN35 CONFIGURE LSN N STA LSNXX ADA M1 STA LSN34 CONFIGURE LSN N-1 ADA M1 STA LSN33 CONFIGURE LSN N-2 JMP HPIBC,I HPIBF HLT 72B ADDRESS NOT LEGAL JMP INITS+1 CORRECT BIT 5-0 * * * SKP * *SBR CONF DISPLAY ALL ADDRS * ADSCF NOP LDA LSN35 LSN35 = 010475 JSB SNDEA,I JMP ADSCF,I * *SBR CONF ONE DISPLAY * ODSCF NOP LDA LSN35 LSN35 = 010475 JSB SNDNA,I JMP ODSCF,I * *SBR CONF ALL ISP S * AMCCF NOP LDA LSN36 LSN36 = 010476 JSB SNDEA,I JMP AMCCF,I * *SBR CONF ONE ISP * OMCCF NOP LDA LSN36 LSN36 = 010476 JSB SNDNA,I JMP OMCCF,I * *SBR CONF ONE KEYBOARD * OKBCF NOP LDA TLK35 TLK35 = 010535 JSB SNDNA,I JMP OKBCF,I * *SBR UNLISTEN ONE ADDR * OULSN NOP LDA UNWm640LSN UNLSN = 010477 JSB SNDNA,I JMP OULSN,I * *SBR UNTALK ONE ADDR * UNTAK NOP LDA UNTLK UNTLK=010537 JSB SNDNA,I JMP UNTAK,I * SKP #6* *SBR SEND LF ONE ADDR * OLFED NOP LDA LFCOD JSB SNDNA,I JMP OLFED,I * *SBR TIMING STD * WATNG NOP LDA P250 JSB TMRR,I JMP WATNG,I * *SBR WAIT FOR FLAG * WTFLG NOP STB SCPAD SAVE TIME COUNT LDA M40 PRESET BLINK FOR OVERFLOW STA BLINK WTF2 SFC SC TEST CONTROLLER FLAG JMP WTFLG,I SET, THEN RETURN LDA P5 .005 SEC WAIT JSB TMRR,I MAX LINK FLAG IS 70 MS ISZ BLINK JMP *+5 SOS C OVERFLOW GADJET STO LDA M40 STA BLINK JSB SHRTN MUST WE ABORT ?? ISZ SCPAD DID IT TIMED OUT ?? JMP WTF2 NO, NOT YET ISZ WTFLG YES, BUMP RTN ADDR JMP WTFLG,I MS142 ASC 16,E142 HARDWARE FAILURE OR NO KEY ASC 16,PRESSED WITHIN DELAY,PRESS RUN/ * CLRS7 NOP SBR TO CLEAR SW-REG BIT 7 LIA SW AND NBIT7 OTA SW JMP CLRS7,I * SHRTN NOP SBR TEST SW BIT7 ABORT OPTION LDB BIT07 JSB SWRT,I RSS JMP SHRTN,I IOD44 CLC SC,C JMP ABORT,I * SKP * *SBR PROGRAMM. WAIT * WAITR NOP STA TIME SAVE TIME COUNT LDA P1000 JSB TMRR,I SOS C STO ISZ TIME JMP *-5 JMP WAITR,I * *SBR DETECT IF LAST INPUT IS TERMINATOR * TSTLF NOP LDA RETOK,I AND RBYTE MASK ONLY DATA RBYTE CPA LF LF = 000012 JMP *+3 LF PRESENT JSB + 1 ISZ TSTLF JMP TSTLF,I LF ABSENT JSB + 2 LDA STBYT LF, THEN TEST EOI IF 3070B SLA,RSS JMP TSTLF,I NO, 3070A RETURN LDA RETOK,I AND BT910 CPA BT910 JMP TSTLF,I OK, RETURN E0155 JSB ERMS,I NO EOI WITH TERMINATOR DEF MS155 JMP TSTLF,I * MS155 ASC 20,E155 NO EOI SENT ALONG WITH TERMINATOR/ * *SBR TAKE COUNT OF FIRST OK * TACNT NOP LDA FOKAD FIRST OKq ADDR SZA,RSS STB FOKAD STORE IN FOKAD ONLY FIRST TIME CPB FOKAD IS IT SAME ADDRESS ?? JMP *+3 E0153 JSB ERMS,I NOT THE SAME !! DEF MS153 ISZ WITNS BUMP OK NUMBER NOP JMP TACNT,I * * SKP * ********************************* **** SBR SEND TEST TITLE **** ********************************* * MESGC NOP STANDARD FOR EACH TEST LDA MESGC,I GET MESSAGE ADDRESS STA *+5 ISZ MESGC BUMP RETURN ADDRESS JSB MSGC,I SEND CR-LF DEF ZRTLF JSB MSGC,I SEND TITLE NOP JSB MSGC,I SEND CR-LF DEF ZRTLF JSB CLRS7 CLEAR ABORT BIT IN S-REG. JMP MESGC,I * *************************************************** **** SRQ CLEAR FOR ALL TERMINALS ON LOOP **** *************************************************** * ADSRQ NOP SERIAL POLL SUBROUTINE IOD36 CLC SC LDB SRTB1 STB SCPAD LDA B,I JSB SNDEA,I ALF,SLA,ALF IF STATUS BYTE, SAVE IT JMP DDSR1 NO, SKIP ALF,ALF RESTORE GOOD PLACE STA TEMP2 TEMP. SAVE AND BT910 VERIFY VALDA FOR STBYT CPA BIT10 JMP DDSR2 OK, SKIP LDA TSTN IF TST 13,15,16 DON'T WORRY CPA P11 IF NO VALDA ON LINK ADDR 77 JMP DDSR2 CPA P13 JMP DDSR2 CPA P14 JMP DDSR2 E0135 JSB ERMS,I NO VALDA IN SERIAL POLL DEF MS135 ANSWER FROM 3070 DDSR2 LDA TEMP2 RESTORE DATA AND RBYTE STA STBYT SAVE STATUS BYTE DDSR1 LDB SCPAD INB CPB SRTB2 IS IT FINISHED ?? JMP ADSRQ,I JMP IOD36+2 * SKP * HCYES NOP RTN JSB+2 IF NOT 30HC LDA STBYT RTN JSB+1 IF 30HC SLA,RAR RSS SLA,RSS ISZ HCYES JMP HCYES,I * HCREL NOP RTN JSB+2 IF 30HC+RELAY JSB HCYES RTN JSB+1 IF NOT 30HC - RSS JMP HCREL,I RAR,SLA ISZ HCREL JMP HCREL,I * HED ***** 3070 DIAGN IO & TESTS TABLES ***** * * ORG ZCEND * * IODP EQU * DEF WTF2 DEF IOD14 DEF IOD15 DEF IOD16 DEF IOD17 DEF IOD18 DEF IOD19 DEF IOD20 DEF IOD21 DEF IOD22 DEF RECVE DEF IOD24 DEF IOD25 DEF IOD26 DEF PHINP DEF IOD29 DEF IOD30 DEF IOD31 DEF INP DEF IOD33 DEF IOD34 DEF IOD35 DEF IOD36 DEF IOD43 DEF IOD44 DEC -1 * SKP TSTD EQU * A-REG BIT DEF TST00 BASIC I\O TEST 0 DEF TST01 CONTROLLER TEST 1 DEF TST02 COMMUNICATION MODULE TEST 2 DEF TST03 SELF-TEST TEST 3 DEF TST04 GENERAL FUNCTIONS TEST 4 DEF TST05 ANNUNCIATOR LIGHTS TEST 5 DEF TST06 NUMERIC DISPLAY TEST 6 DEF TST07 NUMERIC KEYBOARD TEST 7 DEF TST10 SPECIAL FUNCTION KEYS TEST 8 DEF TST11 PRINTER TEST 9 DEF TST12 MULTIFONCTION READER TEST 10 DEF TST13 ADDRESS TEST 11 DEF TST14 CABLE QUALITY TEST 12 DEF TST15 EXTENDED CABLE/CONTROLLER TEST 13 DEF TST16 TOTAL INSTALLATION TEST 14 DEF TST17 SIGNATURE STIMULI GENERATION 15 DEC -1 HDMS EQU * ASC 18, START 92900B SUBSYSTEM DIAGNOSTIC// * * * * HED ***** CONTROLLER TEST ***** ORG 4000B * ************************************* **** CONTROLLER TEST (ALONE) **** ************************************* * TST01 EQU * CONTROLLER TEST CNTLR NOP ***************** LDB UTCMD JSB SWRT,I BITS 8 & 12 OPTIONS ? JMP kCNTLR,I H0027 JSB MESGC DEF MS027 H0030 JSB MSGH,I DEF MS030 WARNING ALL TERMINALS OFF IOD35 CLC SC STOPS EVENTUALLY THE CONTROLLER JSB INITS INIT SBR FOR TABLES & POINTERS CLA,INA NETAB STA TEMP1 SAVE ABS TABLE REF STA TEMP0 SAVE VAR TABLE REF CMA,INA MAKE NEGATIVE ADA DATAD CALCULATE POINTER ADA P90 IN DATA TABLE STA TEMP2 LDA M63 SET LIMIT FOR DATA TRANSFER STA CNTR LDB DXTAD BOUGL LDA TEMP2,I GET DATA CPA M1 TEST IF END JMP ENVO1 YES, END OF PATTERN STA B,I STORE IN DXTAB INB BUMP DEST ADDR ISZ TEMP2 BUMP SRCE ADDR ISZ CNTR DXTAB FULL(63 WORDS) ? JMP BOUGL NO, CONTINUE LDA P63 SET TEMP0 TO 63 STA TEMP0 LIMIT VAR TABLE REF IS 63 ENVO1 CCB ADB DXTAD PREPARE SENDING ADB TEMP0 FOR N TERMINALS LDA B,I REMOVE BIT15 IN LAST DXT WD AND NBT15 STA B,I ADB CAPA. SET LIMIT IN RETAB STB RETAP CLA IN ORDER TO USE ONLY DXTAB JSB SNDEA,I CALL IN\OUT ROUTINE LDA DXTAD STA TEMP3 LDB RETAD COMPARE NOW LOAD LDA B,I XOR TEMP3,I SZA SHOULD BE EQUAL JSB ERRO5 ALMOST ONE BIT CHANGED INB CPB RETAP EQUAL, IS IT LAST ? JMP CUITE YES ISZ TEMP3 JMP LOAD GO TO NEXT COMPARISON CUITE LDA TEMP1 ADJUST COUNTERS CPA P90 FOR NEW TABLE JMP NDT01 = INA # THEN INCREMENT JMP NETAB CONTINUE TEST ERRO5 NOP RAM CONTENT ERROR TREATMENT STB SCPAD LDB RETAD CMB,INB INB ADB SCPAD E0036 JSB ERMS,I DIFFERENCE INTO RAM CONTENT DEF MS036 LDB TEMP3,I LDA SCPAD,I E0037 JSB ERMS,I A- & B-REG CONTENTS OUTPUT DEF MS037 LDB SCPAD JMP ERRO5,I E0035 JSB ERMS,I BIT 15 SET ON LAST DXT WORD DEF MS035 JMP NDT01 E0034 JSB ERMS,I FLAG SH'D BE SET (OUTPUT) DEF MS034 JMP NDT01 E0032 JSB ERMS,I FLAG NOT SET AFTER DELAY DEF MS032 JMP NDT01 E0033 JSB ERMS,I FLAG SH'D BE SET (INPUT) DEF MS033 NDT01 NOP H0031 JSB MSGH,I DEF MS031 WARNING ONE TERMINAL ON NOW JMP CNTLR,I * MS027 ASC 12,TEST01 CONTROLLER TEST/ MS035 ASC 22,E035 BIT15 SET IN LAST TRANSFER TABLE WORD/ MS034 ASC 21,E034 FLAG NOT SET.SHOULD BE SET (OUTPUT)/ MS032 ASC 20,E032 FLAG NOT SET WITHIN REQUIRED TIME/ MS033 ASC 20,E033 FLAG NOT SET.SHOULD BE SET (INPUT)/ MS036 ASC 17,E036 DATA RECEIVED DIFFERENT FROM ASC 16,DATA SENT(B=RAM ADDR),PRESS RUN/ MS037 ASC 17,E037 DATA RECEIVED DIFFERENT FROM ASC 19,DATA SENT A=RECEIVED,B=SENT,PRESS RUN/ MS030 ASC 23,H030 TERMINALS ON LINK MUST BE OFF,PRESS RUN/ MS031 ASC 17,H031 END TEST 01:SET ONE TERMINAL ASC 17,ON WITH ADDR 77 OCTAL, PRESS RUN/ * * HED ***** ISP CHIP TEST ***** * ************************************* **** ISP CHIP TEST **** ************************************* * TST02 EQU * ISP CHIP TEST MOCOM NOP *************** H0040 JSB MESGC PRINT TEST TITLE DEF MS040 JSB INITS INIT SBR FOR TABLES & POINTERS JSB AIFCL IFC FOR ALL ADDRESSES JSB ADSRQ SERIAL POOL JSB ADSCF CONF DISPLAY ON ALL ADDRS LDA UTDAT INIT CURRENT INSTRUCTION REPET STA TEMP0 JSB SNDEA,I OUTPUT INSTRUCTION LDB M62 STB CNTR LDB RETAD LDA TEMP0 IOR BIT15 GO020 CPA B,I RSS JSB REPRT ERROR: REPORT TO OPERATOR INB ISZ CNTR JMP GO020 LDA TEMP0 IOR BIT14 CPA B,I RSS JSB REPRT ERROR: REPORT TO OPERATOR JSB SHRTN BIT07 OPTION TO END TEST ?? SOS C OViERFLOW GADJET STO CLA,CME EXECUTE AN INPUT JSB INOUT LDA TEMP0 PREPARE NEXT INSTRUCTION INA CPA IFC IS IT LAST INSTRUCTION ? RSS YES JMP REPET NO CLA LAST INPUT JSB INOUT NDT02 JMP MOCOM,I MS040 ASC 17,TEST02 COMMUNICATION MODULE TEST/ * * SKP * * * REPRT NOP STB TEMP2 SAVE DXTAB POINTER CMB,INB CALCULATE TERMINAL ADDR ADB RETAD INB E0140 JSB ERMS,I TELL ERROR ORIGIN DEF MS140 LDB TEMP2,I GET EXPECTED DATA E0141 JSB ERMS,I TELL ERROR DATA DEF MS141 A-REG RECEIVED DATA LDB TEMP2 RESTORE POINTER JMP REPRT,I * * * * HED ***** TERMINAL FUNCTIONS TEST ***** ******************************************* **** TERMINAL FUNCTIONS TEST **** ******************************************* * TST04 EQU * TERMINAL FUNCTIONS TEST TRMTS NOP ************************* LDB UTCMD JSB SWRT,I BITS 8 & 12 OPTIONS ? JMP TRMTS,I H0041 JSB MESGC PRINT TEST TITLE DEF MS041 LDA RSTAD SET RETURN POINT STA DEBUT FOR SNDNG SBR JSB INITS INIT SBR FOR TABLES & POINTERS JSB OIFCL IFC FOR ADDRESS 63 JSB ADSRQ JSB HCYES IF 30HC, JMP TO SRQ KEY TEST JMP H0047 JSB OKBCF CONF KEY BOARD ON ADDR63 H0042 JSB MSGH,I KB MUSTBE CONF & DISPLAY CLEAR DEF MS042 JSB OIFCL SEND IFC ON ADDR 63 H0043 JSB MSGH,I KB MUST BE DECONFIGURED DEF MS043 LDA CAP.E TRY TO WRITE JSB SNDNA,I ON DECONFIGURED DISPLAY JSB SNDNA,I JSB OLFED SEND A LINE FEED ON ADDR 63 H0044 JSB MSGH,I DISPLAY MUSTBE ALWAYS CLEAR DEF MS044 RSTAR JSB OMCCF CONF MOCOM ON ADDR 63 JSB OKBCF CONF KEY BOARD ONADDR 63 LDA LIGNA INIT LINE BUFFER POINTERS STA TEMP0 FOR CHARIACTERS INPUTTING ADA P17 STA TEMP1 NEWIN CLA READ A CHARACTER JSB SNDNA,I JSB TSTLF IS IT A LINE FEED ? JMP LFOCC OUI LDA RETOK,I STA TEMP0,I STORE THE CHARACTER LDA TEMP0 INCR LINE POINTER INA CPA TEMP1 IS IT LAST ? JMP LFOCC YES STA TEMP0 NO, THEN STORE POINTER JMP NEWIN LFOCC JSB UNTAK DECONF. KEYBOARD LDA LFCOD STA TEMP0,I STORE LINE TERMINATOR LDA TEMP0 ACTUALISE LINE LIMIT INA STA TEMP1 H0045 JSB MSGH,I DISPLAY MUSTBE ALWAYS CLEAR SKP * DEF MS045 JSB ODSCF CONF DISPLAY ON ADDR 63 LDA LIGNA INIT LINE POINTER IN ORDER STA TEMP0 TO OUTPUT LINE NOW NEWUT LDA TEMP0,I AND RBYTE IOR BIT12 JSB SNDNA,I LDA TEMP0 INC LINE POINTER INA CPA TEMP1 IS IT LAST TO BE OUTPUT JMP H0046 JMP NEWUT-1 H0046 JSB MSGH,I ORDER TO TYPE IN DEF MS046 CHARACTERS JSB AIFCL SEND IFC TO ALL ADDR JSB ODSCF CONF DISPLAY JSB OKBCF CONF KEYBOARD CLA JSB INDXA,I JSB SPEXC INPUT CHARACT WITH RSS DECONFIG COMMUN MODULE JMP *+3 SHD NOT RECEIVE ANYTHING E0051 JSB ERMS,I DEF MS051 ERROR CHARACT RECEIVED IOD34 CLC SC STOPS CONTROLLER'S WAIT JSB AIFCL SEND IFC H0047 JSB MSGH,I DEF MS047 ORDER TO PRESS SRQ CLA SET INPUT PHASE JSB INDXA,I JSB SPEXC JMP *+4 SRQ OK H0052 JSB ERMS,I DEF MS052 NO SRQ JMP IOD34 LDA DXTOK,I VERIFY BIT SRQ CPA SRQEX SRQEX = 041000 JMP H1052+2 OK FOR SRQ H1052 JSB ERMS,I DEF MS052 NO SRQ MESSAGE JSB ADSRQ GO & CLEAR SRQ ON TERMINAL LDA CAP.E IOR BIT13 INSERT IDLE BIT JSB INDXA,I JSB SPEXC JMP E0053 A JSB HCYES IF 30HC, TEST IF RELAY OPTION RSS JMP *+3 JSB HCREL JMP ANLIT,I H0054 JSB MESGC PRINT TEST TITLE DEF MS054 LDB UTCMD IF NO HLT OPTION, SKIP THIS JSB SWRT,I JMP *+3 H0055 JSB MSGH,I HLT TO PROMPT OPERATOR DEF MS055 JSB ODSCF CONF DISPLAY ON ADDR 63 LDA ORDRT LOAD FIRST CODE SNDLP JSB SNDNA,I LIT AN ANNUNC LIGHT JSB WATNG CCA PREPARE NEXT CODE ADA COBAS STA COBAS JSB SNDNA,I SPENT SAME ANNUNC LIGHT JSB WATNG JSB HCREL IF 30HC, STOP AFTER 4 FIRST JMP *+4 LDA COBAS CPA RL4OF JMP ENDLP YES, EXIT LOOP LDA COBAS GET INSTR CODE CPA TILDA COMPARE WITH LAST CODE JMP ENDLP YES CONTINUE ADA P3 PREPARE NEXT CODE STA COBAS JMP SNDLP ENDLP LDA ORDRT LIT ALL ANNUNC LIGHTS ALLIT STA COBAS JSB SNDNA,I LIT ONE LDA COBAS PREPARE NEXT CODE ADA P2 CPA DEL COMPARE WITH LAST CODE RSS JMP ALLIT JSB WATNG CCA SPENT AN ANNUNC LIGHT ADA ORDRT AND LIT IT AGAIN STA COBAS SENDG JSB SNDNA,I JSB WATNG JSB HCREL IF 30HC, STOP AFTER 4 FIRST JMP *+4 LDA COBAS CPA RL4ON JMP GO4XX YES, CLEAR NOW LDA COBAS PREPARE INA NEXT STA COBAS CODE CPA TILDA COMPARE WITH LAST CODE RSS JMP SENDG LDA STBYT IF 3070B USE TILDA SLA TO CLEAR ALL PROMPTING LIGTHS JMP GO4XX CCA NOW CLEAR ALL LIGHTS ADA ORDRT ALSPT STA COBAS JSB SNDNA,I CLEAR ONE LDA COBAS PREPARE ADA P2 NEXT CPA TILDA LAST ? CODE JMP ANLIT,I JMP ALSPT GO4XX LDA TILDA JSB SNDNA,I JMP ANLIT,I MS054 ASC 15:,TEST05 PROMPTING LIGHTS TEST/ MS055 ASC 21,H055 PRESS RUN, CHECK ACCORDING TO MANUAL/ * * * * HED ***** SUBROUTINES FOR TEST (FOLLOWING) ***** * ************************************ **** SBR TEST BYTE PRESENT **** ************************************ * TSTER NOP STA SCPAD LDB RETAD NEWTR LDA B,I AND RBYTE XOR SCPAD INB CPB RETAP JMP NEWT1 SZA JMP NEWTR E0154 JSB ERMS,I ERROR ON BYTE ORIGIN NT LST TERMINAL DEF MS154 JMP NEWTR NEWT1 SZA,RSS JMP TSTER,I JSB UNTAK UNTALK KEYBOARD ISZ TSTER LDA DEL PRINT OUT " EE " PATTERN JSB SNDNA,I LDA CAP.E JSB SNDNA,I JSB SNDNA,I CCA JSB WAITR LDA DEL JSB SNDNA,I JMP TSTER,I * * * * MS154 ASC 22,E154 DATA RECEIVED FROM UNEXPECTED ADDRESS/ * * * * HED STIMULI GENERATION TEST ****************************** **** SIG. ANAL. TEST **** ****************************** * * * * TST17 EQU * NOP JSB INITS STD INIT JSB CLRS7 CLEAR ABORT BIT LDA IFC OUTPUT IFC JSB SNDEA,I SIG01 LDA BIT12 OUTPUT 0 JSB SNDEA,I LDA LSN36 OUTPUT ATN 76 JSB SNDEA,I CLA INPUT FROM HPIB JSB SNDEA,I LDA IFC OUTPUT IFC JSB SNDEA,I JSB SHRTN MUST WE STOP ?? JMP SIG01 NO, CONTINUE * * HED ***** DISPLAY TEST ***** * *********************************** **** DISPLAY TEST **** *********************************** * ORG 6000B * TST06 EQU * DISPLAY TEST DPLAY NOP ************** JSB INITS STD INIT JSB AIFCL IFC TO ALL JSB ADSRQ SERIAL POLL JSB HCYES IF 30HC, REJECT JMP DPLAY,I H0056 JSB MESGC DEF MS056 LDB UTCMD JSB SWRT,I JMP *+3 H0057 JSB 9MSGH,I DEF MS057 JSB ODSCF CONF DISPLAY ON ADDR 63 LDA CODAD INIT POINTERS ADA P14 FOR STA TEMP0 CODES AND LDA M16 STA TEMP1 DIGITS LDA CDTAB+8 FULL 8 LINE OUTPUT JSB SNDNA,I ISZ TEMP1 JMP *-2 LDA M15 VARIABLE LENGTH LINE OUTPUT STA TEMP1 JSB WATNG JSB OLFED BUCL1 LDA TEMP1 STA TEMP2 LDA CDTAB+11 OUTPUT "-" N TIMES JSB SNDNA,I ISZ TEMP2 JMP *-2 LDA CDTAB+8 THEN OUTPUT 8 JSB SNDNA,I JSB WATNG LDA DEL CLEAR DISPLAY JSB SNDNA,I ISZ TEMP1 SHORTEN LINE LENGTH JMP BUCL1 LDA CDTAB+8 OUTPUT LAST 8 JSB SNDNA,I JSB WATNG JSB WATNG LDA DEL CLEAR DISPLAY AGAIN JSB SNDNA,I LDA M15 OUTPUT FULL "." LINE STA TEMP2 BUCL2 LDA D.PNT JSB SNDNA,I LDA SPACE JSB SNDNA,I ISZ TEMP2 JMP BUCL2 CCA JSB WAITR JSB OLFED SEND LINE FEED LDA CODAD BUCL3 STA TEMP1 OUTPUT ALL DISPLAYABLE CHARACTERS LDA TEMP1,I JSB SNDNA,I LDA TEMP1 INA CPA TEMP0 IS IT THE LAST ?? RSS JMP BUCL3 CCA JSB WAITR JSB OIFCL SEND IFC JSB ODSCF CONFIG DISPLAY JSB OULSN UNLISTEN DISPLAY LDB UTCMD JSB SWRT,I BITS 8 & 12 OPTIONS ? JMP NDT05 H0060 JSB MSGH,I DISPL MUSTBE CLEAR & REMAIN NOW DEF MS060 LDA CAP.E SEND A CHARACTER JSB SNDNA,I JSB OLFED AND A LINE FEED H0061 JSB MSGH,I DISPLAY MUST BE CLEAR END TEST DEF MS061 NDT05 JMP DPLAY,I MS056 ASC 11,TEST06 DISPLAY TEST/ MS057 ASC 21,H057 PRESS RUN, CHECK ACCORDING TO MANUAL/ MS060 ASC 15,H060 ENSURE DISPLAY IS CLEARED ASC 13, & STAYS CLEAR, PRESS RUN/ MS061 ASC 23,H061 IF DISPLAY NOT CLEAR: ERROR; PHFBRESS RUN/ * * * "H HED ***** KEYBOARD KEYS TEST ***** * ******************************** **** KEYBOARD TEST **** ******************************** * TST07 EQU * KEYBOARD TEST KBORD NOP *************** LDB UTCMD JSB SWRT,I BITS 8 & 12 OPTIONS ? JMP KBORD,I JSB INITS STD INIT JSB AIFCL IFC TO ALL JSB ADSRQ SERIAL POLL JSB HCYES IF 30HC, REJECT JMP KBORD,I H0062 JSB MESGC DEF MS062 H0063 JSB MSGH,I DEF MS063 LDA KBTAD INIT KB LIMIT POINTRS STA TEMP0 INIT KEY CODE POINTER ADA P14 STA TEMP1 RSS JSB UNTAK JSB ODSCF CONF DISPLAY ON ADDR 63 JSB OMCCF CONF COMM MODULE ON ADDR 63 TRYAG JSB INDIC PRINT OUT CHARACTER TO BE TYPED IN JSB OKBCF CONF KEYBOARD ON ADDR 63 CLA READ JSB SNDNA,I IT LDA TEMP0,I TEST THIS JSB TSTEA,I CHARACTER RSS GOOD JMP TRYAG-3 BAD => TRY AGAIN JSB BOUNC TEST ANTI-BOUNCING JSB UNTAK UNTALK KEYBOARD LDA TEMP0,I IOR BIT12 CPA CDTAB+12 IF "." SEND ONE MORE SPACE RSS JMP *+3 LDA SPACE JSB SNDNA,I LDA SPACE JSB SNDNA,I SEND TWO SPACES JSB SNDNA,I LDA TEMP0,I OUTPUT CHARACTER IOR BIT12 JUST RECEIVED JSB SNDNA,I JSB PNTSP JSB SNDNA,I JSB OLFED AND A LINE FEED LDA TEMP0 INC POINTER INA FOR KEY BOARD CODE INPUT CPA TEMP1 IS IT LAST ? JMP GO6XX YES GO TO END TEST STA TEMP0 CCA PREPARE LITTLE TIMING JSB WAITR JMP TRYAG GO6XX LDA STBYT IF 3070B, TEST MODE 2 SLA,RSS JMP KBORD,I LDA M2 SET PASS COUNTER TO STA TEMP2 TEST TWO TIMES MODE #2 GO163 JSB UNTAK OUTPUT UNTALK JSB ODSCF DISPLAY LISTENER U LDA DEL JSB SNDNA,I CLEAR DISPLAY JSB BUZZA,I PROMPT OPERATOR LDA MLAC2 CONN(2) SECONDARY CMD JSB SNDNA,I JSB OULSN OUTPUT UNLISTEN LDA M10 SET 10 SEC WAIT JSB WAITR TO ALLOW KEYBOARD INPUT LDA KBTAD SET TABLE POINTER STA TEMP0 JSB OMCCF CONF ISP BECAUSE OF UNL JSB OKBCF CONFIGURE KEYBOARD TO GET BUFFER RSS SKIP FIRST TIME GO165 ISZ TEMP0 BUMP POINTER CLA JSB SNDNA,I READ ONE CHARACTER AND RBYTE GET BYTE ONLY LDB TEMP0,I GET GOOD CHAR CPA B IS IT EXPECTED CHAR. ?? JMP GO165 YES, CONTINUE CPA LF NO,IS IT TERMINATOR THEN ?? JMP *+4 YES, GO FOR 2ND PASS OR END E0161 JSB ERMS,I NO, SEQUENCE ERROR OR ELSE DEF MS161 JMP GO163 RESTART ISZ TEMP2 BUMP PASS COUNTER JMP GO163 CONTINUE JSB AIFCL CLEAR JMP KBORD,I MS062 ASC 11,TEST07 KEYBOARD TEST/ MS063 ASC 21,H063 PRESS RUN, CHECK ACCORDING TO MANUAL/ * * HED ***** SPECIAL FUNCTION KEYS TEST ***** * ********************************************* **** SPECIAL FUNCTIONS KEYS TEST **** ********************************************* * TST10 EQU * SPECIAL FUNC KEYS TEST SFKEY NOP ************************ LDB UTCMD JSB SWRT,I BITS 8 & 12 OPTIONS ? JMP SFKEY,I JSB INITS STD INIT JSB AIFCL IFC TO ALL JSB ADSRQ SERIAL POLL JSB HCYES IF 30HC, REJECT JMP SFKEY,I H0064 JSB MESGC DEF MS064 H0065 JSB MSGH,I DEF MS065 LDA M2 SET PASS COUNTER STA CNTR GO07Y LDA CDGEN INIT CODE STA TEMP2 GENERATOR LDA FKTAD INIT POINTER FOR STA TEMP0 FUNCT KEY CODES ADA P9 LDB STBYT BUMP CODE ACCORDING TO A\B SLB INA STA TEMP1 RSS )JSB UNTAK JSB OMCCF CONF COMM MODULE JSB ODSCF CONF DISPLAY ON ADDR 63 TRYGN JSB SHOW LIT ANNUNC LIGHT=>SFK TO PRESS JSB OKBCF CONF KEYBOARD CLA READ FUNC KEY CODE TYPED JSB SNDNA,I LDA TEMP0,I COMPARE WITH JSB TSTEA,I CODE ORDER RSS OK JMP TRYGN-3 NOT OK LDA STBYT IF NOT 3070B & 2ND PASS SLA,RSS DON'T TEST TERMINATOR + EOI JMP GO07X LDA M2 CPA CNTR JMP GO07X CLA READ TERMINATOR JSB SNDNA,I JSB TSTLF TEST IF OK (LF+EOI) JMP *+3 YES, CONTINUE E0066 JSB ERMS,I NOT TERMINATOR TRANSMITTED DEF MS066 AFTER SKF CODE GO07X JSB BOUNC TEST ANTI-BOUNCING JSB UNTAK UNTALK KEYBOARD ISZ TEMP2 INC CODE GENERATOR LDA TEMP0 INC INA CODE CPA TEMP1 INDEX JMP *+3 LAST FUNC KEY STA TEMP0 NEXT FUNC KEY JMP TRYGN LDA STBYT IF 3070B TEST FOR 2ND PASS SLA,RSS JMP END07 LDA TILDA CLEAR LED JSB SNDNA,I WITH GENERAL CLEAR CODE ISZ CNTR 2ND PASS ?? JMP GO07Y JMP SFKEY,I RETURN NOW END07 LDA NPL15 CLEAR LED 15 JSB SNDNA,I JMP SFKEY,I MS064 ASC 18,TEST10 SPECIAL FUNCTION KEYS TEST/ MS065 ASC 21,H065 PRESS RUN, CHECK ACCORDING TO MANUAL/ MS066 ASC 20,E066 NOT TERMINATOR CODE SENT AFTER SFK/ * BOUNC NOP TEST KEYBOARD ANTI-BOUNCING CLA EXEC READ WITH COMPLETION JSB SNDEA,I AND BT910 GET VALDA+SRQ SZA,RSS SOMETHING GOOD ?? JMP BOUNC,I NO, RETURN E0067 JSB ERMS,I YES, TELL OPERATOR DEF MS067 JMP BOUNC,I RETURN NOW * MS067 ASC 16,E067 KEYBOARD ANTIBOUNCING FAIL/ * * HED ***** ADDRESS TEST ***** * ******************************* **** ADDRESS TEST **** ****************C0*************** * TST13 EQU * ADDRESS TEST ADRTS NOP ************** LDB UTCMD JSB SWRT,I BITS 8 & 12 OPTIONS ? JMP ADRTS,I H0120 JSB MESGC DEF MS120 JSB INITS INIT SBR FOR TABLES & POINTERS JSB AIFCL IFC FOR ALL JSB ADSRQ LDA ORDRA ADA P40 AND STA TEMP1 POINTER LIMIT JSB ADSCF CONF ALL DISPLAYS LDA BGINA SPECIFY RETURN ADDR STA DEBUT FOR VRIFY SBR H0121 JSB MSGH,I DEF MS121 SET HA YOU WANT TO TEST PRESS RUN JMP BGINN H0122 JSB SHRTN BIT7 OPTION TO END TEST ? JSB MSGH,I 1 OK : ADDR IN AREG SET HA YOU WANT DEF MS122 TO TEST PRESS RUN OR SET SREG BIT7 BGINN LDA ORDRA RESET POINTER STA TEMP0 LDA M121 STA TEMP2 INIT TDL COUNTER WITH -121 JSB INIWF INIT PROPER COUNTERS LDA LFCOD JSB SNDEA,I SEND A CHARACTER JSB VRIFY VERIFY OK NUMBER STA VARIA STORE OK ORIGIN JSB PRINT PRINT IT OUT BCLAG JSB INIWF INIT PROPER COUNTERS LDA TEMP0,I SEND A VARIABLE CHARACTER JSB SNDEA,I JSB VRIFY VERIFY OK NUMBER CPA VARIA COMPARE WITH FIRST ORIGIN JMP *+5 LDB VARIA E0123 JSB ERMS,I OK ADDR VART'N:A ACTUAL,B PREVIOUS DEF MS123 JMP BGINN PRESS RUN ISZ TEMP2 SAME ADDR THEN INCR TDL COUNTER JMP NWORD LDA M121 STA TEMP2 INIT TDL COUNTER LDA VARIA A REG = OK ADDR JMP H0122 GO & ASK FOR NEW ADDR TEST NWORD LDA TEMP0 INCR CHARACTER POINTER INA CPA TEMP1 IS IT LAST ? LDA ORDRA YES THEN RESET STA TEMP0 NO, THEN STORE BOTH CASES JMP BCLAG NDT13 JMP ADRTS,I MS120 ASC 11,TEST13 ADDRESS TEST/ MS121 ASC 13,H121 SET TERMINAL ADDRESS ASC 14,YOU WANT TO TEST,PRESS RUN/ MS122 ASC 12,H122 TEST OK(AREG=ADDR). ASC 16, CHANGE TERMINAL ADDR,PRESS RUN/ MS123 ASC 15,E123 TERMINAL ADDR VARIATION: ASC 16,A ACTUAL, B EXPECTED; PRESS RUN/ * HED ****** CABLE QUALITY TEST ****** * ************************************ **** CABLE QUALITY TEST **** ************************************ * TST14 EQU * CABLE QUALITY TEST TOTRS NOP ******************** LDB BIT12 JSB SWRT,I BIT12 OPTION ? JMP TOTRS,I JSB INITS STD INIT JSB AIFCL IFC TO ALL JSB ADSRQ SERIAL POLL JSB HCYES IF 30HC, REJECT JMP TOTRS,I H0124 JSB MESGC DEF MS124 LDA ORDRA INIT PHASE FOR THIS TEST STA TEMP0 ADA P40 STA TEMP1 CLA STA TEMP2 COUNTER FOR "NOT OK" STA TEMP3 COUNTER FOR TOTAL ERROR NUMBER LDA M1000 STA TEMP4 INIT RATE COUNTER LDA P63 STA VARIA OK ADDR MUST BE 63 (77 OCTAL) RESET JSB AIFCL SEND IFC TO ALL ADDRS JSB ADSCF CONF DISPLAY ON ALL ADDRS JSB CALCU PRINT OUT RETRANS RATE & CUMULATED ERROR LDB BIT08 JSB SWRT,I BIT8 OPTION ? JMP BEGIN H0125 JSB MSGH,I DEF MS125 SET HA 63 (77OCTAL) PRESS RUN * * BEGIN JSB INIWF INIT PROPER COUNTERS JSB SHRTN BIT7 OPTION TO END TEST ? ISZ TEMP4 INCR TDL COUNTER JMP *+5 LDA M1000 PRESET TDL COUNTER STA TEMP4 WITH -1000 JSB ADSCF CONF DISPLAY (IF TERM OFF) JSB CALCU PRINT OUT LAST RESULTS LDA TEMP0,I JSB SNDEA,I SEND NEW CHARACTER JSB VERFA,I VERIFY OK NUMBER CPA VARIA AND OK ORIGIN JMP *+5 LDB VARIA E0126 JSB ERMS,I OK ADDR VARIATION SHD BE 63 (77OCT) DEF MS126 ACTUAL IS IN AREG JMP RESET PRESS RUN LDA TEMP0 NO VARIATION PREPARE NEXT CODE CME,INA CPA TEMP1 IS IT LAST ? LDA ORDRA YES RESET NEEDED STA TEMP0 NO, STORE IN BOTH CAGSES JMP BEGIN NDT14 JMP TOTRS,I MS124 ASC 14,TEST14 CABLE QUALITY TEST/ MS125 ASC 13,H125 SET TERMINAL ADDRESS ASC 12,TO 77 OCTAL, PRESS RUN/ MS126 ASC 15,E126 TERMINAL ADDR VARIATION: ASC 16,A ACTUAL, B EXPECTED; PRESS RUN/ * * * * * HED ***** EXTENDED CABLE/CONTROLLER TEST ***** * ******************************************* **** CONTROLLER RESYNCHRO TEST **** ******************************************* * TST15 EQU * EXTEND CABLE\CONTROLLER TEST CINST NOP ****************************** LDB UTCMD JSB SWRT,I BITS 8 & 12 OPTIONS ? JMP CINST,I JSB INITS STD INIT JSB AIFCL IFC TO ALL JSB ADSRQ SERIAL POLL JSB HCYES IF 30HC, REJECT JMP CINST,I H0127 JSB MESGC DEF MS127 JSB ADSCF CONF DISPLAY ON ALL ADDRSS LDA CONFA SPECIFY RETURN ADDR STA DEBUT FOR VRIFY SBR H0130 JSB MSGH,I SET HA YOU WANT TO TEST PRESS RUN DEF MS130 CONFG JSB SHRTN BIT7 OPTION TO END TEST ? JSB AIFCL RESET ALL LINK TERMINALS JSB ADSCF CONF DISPLAY ON ALL ADDRSS JSB AMCCF CONF COMM MODULE ON ALL ADDRSS JSB INIWF INIT PROPER COUNTERS LDA LFCOD SEND A CHARACTER JSB SNDEA,I TO IDENTIFY OK ORIGIN JSB VRIFY VERIFY OK NUMBER & ORIGIN STA VARIA STORE OK ORIGIN STA TEMP0 STORE IT AGAIN CCA CALCULATE ADA TEMP0 OK ADDR ADA DXTAD IN STA DXTOK DXTAB CCA CALCULATE ADA TEMP0 OK ADDR ADA RETAD IN STA RETOK RETAB JSB PRINT PRINT OUT OK ORIGIN FOUNDED * * BCLAJ JSB INIWF INIT PROPER COUNTERS LDA LIGNA INIT LINE POINTERS STA TEMP0 ADA P17 STA TEMP1 JSB OKBCF CONF KBOARD ON ADDR. NWINP CLA READ A CHARACTER JSB SNDNA,I JSB TSTLF IS IT A LINE F >EED ? JMP LFDOC YES LDA RETOK,I NO STORE IT STA TEMP0,I LDA TEMP0 INCR INA LINE CPA TEMP1 LIMIT? POINTER JMP ENBUF YES TREAT IT STA TEMP0 NO STORE IT JMP NWINP ENBUF JSB UNTAK UNTALK KEYBOARD LDA LFCOD JSB SNDNA,I RSS LFDOC JSB UNTAK DECONF KEYBOARD LDA LFCOD STORE A LF STA TEMP0,I LDA TEMP0 INA ACTUALISE LINE LIMIT STA TEMP1 LDA LIGNA STA TEMP0 INIT LINE POINTER FOR NEW SEQUENCE NWOUT LDA TEMP0,I AND RBYTE TAKE ONLY DATA RBYTE IOR BIT12 CONF FOR OUTPUT JSB SNDNA,I & SEND IT LDA TEMP0 INCR INA LINE CPA TEMP1 LIMIT? POINTER JMP FOLOW YES STA TEMP0 NO, STORE IT JMP NWOUT FOLOW CCA LITTLE WAITING JSB WAITR JMP CONFG NEXT EXCHANGE NDT15 JMP CINST,I MS127 ASC 19,TEST15 EXTENDED CABLE\CONTROLLER TEST/ MS130 ASC 13,H130 SET TERMINAL ADDRESS ASC 12,(SEE MANUAL), PRESS RUN/ * * * * HED ***** SUBROUTINES FOR TEST (FOLLOWING) ***** * ********************************************** **** SBR SEND PATTERN ON ALL ADRESSES **** ********************************************** * SNDER NOP AND NB154 PURGE BITS 15 & 14 STA COBAS SAVE PATTERN IOD14 STC SC,C LDB DXTAD PREPARE OUTPUT BUCLA LDA B,I IOR COBAS MERGE PATTERN WITH BIT15 IOD15 SFC SC JMP *+3 E0136 JSB ERMS,I FLAG NOT SET DEF MS136 IOD16 OTA SC,C SSA,RSS IS IT LAST ? JMP *+3 INB JMP BUCLA IOD17 STC SC FORCE COMPLETION RESVE LDA TLTMG SET 70 MS TIME OUT FOR POLLING STA SCUTY SECUR LDA P5 START 5 MS TIMING JSB TMRR,I ISZ SCUTY JMP IOD18 E0137 JSB ERMS,I FLAG SLOW TO BE SET DEF MS137 JMP RESVE RESTART 70$ MS TIME OUT IOD18 SFS SC JMP SECUR LDB RETAD PREPARE INPUT BUFFER POINTER IOD19 LIA SC,C INPUT PHASE STA B,I INB CPB RETAP LAST INPUT ? RSS JMP CRL15 SSA,RSS LAST INPUT BIT15 MUST BE CLEAR JMP SNDER,I E0145 JSB ERMS,I BIT15 SET ON LAST WORD DEF MS145 JMP SNDER,I BIT 15 GOOD CRL15 SSA NOT LAST EXCHANGE BIT15 MUST BE SET JMP IOD19 E0146 JSB ERMS,I BIT15 CLEAR & NOT LAST EXCHANGE DEF MS146 JMP IOD19 SKP *SBR PRINT CHARACT TO PRESS * INDIC NOP LDA TEMP0,I IOR BIT12 CONF FOR OUTPUT JSB SNDNA,I CPA CDTAB+12 RSS JMP *+3 LDA SPACE JSB SNDNA,I LDA SPACE SPACE = 010040 JSB SNDNA,I JSB SNDNA,I JMP INDIC,I * *SBR SPEC FOR POINT * PNTSP NOP STA TEMP2 CPA CDTAB+12 RSS JMP PNTSP,I LDA SPACE JSB SNDNA,I LDA TEMP2 JMP PNTSP,I * *SBR OK COUNT * VRIFY NOP LDB RETAD CONTR LDA B,I AND BIT14 ISOLATE BIT14 CPA BIT14 IS IT PRESENT ? JSB TACNT INB CPB RETAP LAST WORD ? RSS JMP CONTR LDA RETAD CMA ADA FOKAD ADA P2 LDB WITNS SSB JMP NO.OK SZB,RSS JMP *+3 E0143 JSB ERMS,I 2 OR MORE OK ON TDL,1ST IN AREG(ADDR) DEF MS143 JMP VRIFY,I NO.OK CLA E1144 JSB ERMS,I NO OK ON TDLOOP DEF MS144 JMP DEBUT,I DEBUT FIXED IN CONCERNED TEST * *SBR RESET WITNS & FOKAD * INIWF NOP CCA STA WITNS CLA STA FOKAD JMP INIWF,I * *SBR PRINT TERMINAL ADDR * PRINT NOP LDA VARIA ARS,ARS ARS JSB CNVRN LDA VARIA JSB CNVRN LDA LFCOD JSB SNDEA,I JMP PRINT,I * *SBR CONVERSION + OUTPUT * CNVRN NOP AND OCT07 a OCT07 = 000007 IOR CDTAB CDTAB = 010060 JSB SNDEA,I JMP CNVRN,I * * *SBR PRINT RATE & CUMULATED RETRANSMISSION * CALCU NOP LDA TEMP2 ALF,ALF PLACE CORRECT BITS ARS JSB CNVRN LDA TEMP2 ALF,ALF RAL,RAL JSB CNVRN LDA TEMP2 RAR,RAR RAR JSB CNVRN LDA TEMP2 JSB CNVRN LDA SPACE LET SPACE BTWN TWO NUMBERS JSB SNDEA,I JSB SNDEA,I LDA TEMP3 ALF,ALF SAME AS FOR TEMP2 ARS JSB CNVRN LDA TEMP3 ALF,ALF RAL,RAL JSB CNVRN LDA TEMP3 RAR,RAR RAR JSB CNVRN LDA TEMP3 JSB CNVRN LDA LFCOD LFCOD = 010012 JSB SNDEA,I SEND LF TO END LINE CLA STA TEMP2 CLEAR TEMP2 TO CALC NEXT RATE JMP CALCU,I * *SBR LIT SFK TO PRESS * SHOW NOP LDB STBYT IF NOT 3070B & 2ND PASS SLB,RSS DON'T CONFIGURE SFK JMP GOX00 LDA M2 CPA CNTR JMP GOX00 LDA TEMP0,I CONFIGURE SFK TERMINATOR AND B3210 IOR OC160 IOR UTCMD JSB SNDNA,I GOX00 CLA,INA LDB STBYT ADJUST CODE FOR B\A VERSION SLB CCA ADA TEMP0,I ADA TEMP2 JSB SNDNA,I ADA P3 JSB SNDNA,I JMP SHOW,I SKP * ORG ADDR4 * *************************************************** **** SBR SEND ON ONE ADDRESS (DXTOK,RETOK) **** *************************************************** * SNDNG NOP AND NB154 STA COBAS SAVE PATTERN & STORE IT IOD20 STC SC,C INIT TDL LDB DXTAD INIT OUTPUT PHASE BOUCL LDA B,I CPB DXTOK IF ADDRESS, INCLUDE PATTERN IOR COBAS YES, DO IT IOD21 SFC SC JMP IOD22 E1136 JSB ERMS,I FLAG NOT SET DEF MS136 IOD22 OTA SC,C SSA,RSS LAST OUTPUT ? JMP WT1SC 3 INB JMP BOUCL WT1SC LDA COBAS AND BIT12 LAST I\O WAS INPUT OR OUTPUT ORDER ? LDB TM15S INPUT ORDER WAIT FLAG FOR 15 SEC CPA BIT12 LDB TLTMG OUTPUT ORDER: WAIT FLAG FOR .08 SEC JSB WTFLG JMP RECEP E0142 JSB ERMS,I FLAG NOT SET DEF MS142 JMP WT1SC RECEP LDB RETAD INIT INPUT PHASE RECVE SFC SC JMP IOD24 E1137 JSB ERMS,I FLAG SLOW TBE SET DEF MS137 * * IOD24 LIA SC,C STA B,I INB CPB RETAP LAST INPUT ? JMP NTB15 CTL15 SSA NOT LAST:BIT15 MUST BE SET JMP RECVE E1146 JSB ERMS,I BIT15 CLEAR & NOT LAST WORD DEF MS146 JMP RECVE NTB15 SSA,RSS LAST, BIT15 MUST BE CLEAR JMP ESCAP E1145 JSB ERMS,I BIT15 SET ON LAST WORD DEF MS145 ESCAP LDA BIT14 TEST PRESENCE OF OK BIT JSB TESTA,I JMP *+4 E0147 JSB ERMS,I OK ORIGIN CHANGED DEF MS147 JMP RETUR LDA COBAS AND BIT12 INPUT OR OUTPUT CPA BIT12 JMP NDSND OUTPUT, THEN RETURN FROM SBR LDA BIT10 INPUT THEN TEST IF VALDA JSB TESTA,I JMP NDSBR LDA BIT09 TEST IF SRQ (NO VALDA) JSB TESTA,I JMP E0150 JMP E0151 E0150 JSB ERMS,I SRQ OCCURED DEF MS150 JMP RETUR-1 E0151 JSB ERMS,I NEITHER VALDA NOR SRQ NOR STC SC DEF MS151 AND INTERRUPT OCCURED NDSBR LDA RETOK,I JMP SNDNG,I JSB ADSRQ RETUR LDA TSTN CPA P3 JMP DEBUT,I DEBUT FIXED IN TST04 CPA P11 JMP DEBUT,I DEBUT FIXED IN TST13 CPA P13 JMP DEBUT,I DEBUT FIXED IN TST15 NDSND LDA COBAS JMP SNDNG,I MS147 ASC 22,E147 TERMINAL ADDRESS VARIATION, PRESS RUN/ MS150 ASC 18,E150 SRQ DETECTED WHEN NOT EXPECTED/ MS151 ASC 12,E151 INVALID INTERRUPT/ MS152 ASC 14,E152 DATA & SERVICE REQUEST ASC 12,SIMULTANEOUSLY RECEIVED/ * * SKP * *SBR TEST 1 BIT * TESTR NOP STA SCPAD SAVE MASK OF TEST BIT LDB RETAD INIT RETAB READING NWTER LDA B,I AND SCPAD CPB RETOK ARE WE ON CONCERNED ADDRS JMP NWT1 YES WE ARE CPA SCPAD RSS JMP NWT2 E1153 JSB ERMS,I BIT PRESENT & NOT CONCERN ADDRESS DEF MS153 NWT2 INB CPB RETAP END OF READING ?? JMP TESTR,I JMP NWTER NO,CONTINUE NWT1 CPA SCPAD JMP NWT2 IF BIT PRESENT, RTN JSB +1 ISZ TESTR IF BIT ABSENT, RTN JSB +2 JMP NWT2 MS153 ASC 13,E153 ACK RECEIVED BUT NOT ASC 14,FROM PROPER ADDR, PRESS RUN/ * *SBR CONTROL # VRIFY * VERFY NOP LDB RETAD INIT READING OF RETAB RBCLG LDA B,I AND BIT14 ISOLATE BIT14 CPA BIT14 JSB TACNT BIT14 PRESENT INB CPB RETAP LAST WORD OF RETAB ? RSS YES JMP RBCLG NO LDA RETAD CALCULATE CMA ADDR OF ADA FOKAD TERMINAL ADA P2 RETURNING OK BIT LDB WITNS NUMBER OF OK ON TDL SSB JMP SPCHL NO OK ON TDL SZB,RSS ONE OK ? JMP VERFY,I E1143 JSB ERMS,I 2 OR MORE OK ON TDL 1ST IN AREG DEF MS143 JMP VERFY,I SPCHL CLA ISZ TEMP2 INCR FOR THE RATE ISZ TEMP3 INCR FOR TEMP3 JMP BGYNA,I * SKP * MS136 ASC 9,E136 FLAG NOT SET/ MS137 ASC 22,E137 FLAG NOT SET WITHIN THE REQUIRED TIME/ MS140 ASC 17,E140 DATA RECEIVED DIFFERENT FROM ASC 16,DATA SENT(B=ADDRESS),PRESS RUN/ MS141 ASC 17,E141 DATA RECEIVED DIFFERENT FROM ASC 17,DATA SENT:A=RCVD,B=SENT,PRESS RUN/ * TSEOI NOP SBR TO RECEIVE & TEST LF\EOI CLB TEST FIRST NO EOI YET CPB EOIND JMP *+3 OK, GET LAST BYTE NOW E0156 JSB ERMS,I ERROR: EOI YET RECEIVED DEF MS156 JSB READ CPA LF IS IT LF ?? JMP *+3 JSB ERMS,I HFB NOT LF RECEIVED DEF MS156 CLB,INB TEST EOI FLAG NOW CPB EOIND JMP TSEOI,I OK, RETURN JSB ERMS,I NO EOI WITH LF TERMINATOR DEF MS155 JMP TSEOI,I RETURN NOW * MS156 ASC 20,E156 EOI YET RECEIVED OR NO TERMINATOR/ * INPUT NOP CLA JSB SNDEA,I READ WITH FORCED COMPL JMP INPUT,I * READ NOP SBR TO READ ONE CHAR ON RDR JSB INPUT READ REQUEST STA TEMP0 SAVE DATA LDA BIT10 TEST IF VALID DATA JSB TESTA,I RSS GOOD, PROCESS JMP NOYET NO VALDA, OPERATOR WAIT ?? LDA TEMP0 GET DATA AGAIN AND BIT09 IS THERE EOI ?? SZA ISZ EOIND YES, BUMP FLAG ISZ RDFLG BUMP READER FLAG LDA TEMP0 GET DATA AGAIN AND RBYTE KEEP BYTE ONLY JMP READ,I NOYET CLA IF RDFLG=0, NO ERROR CPA RDFLG ONLY SLOW TO ACT OPERATOR!!! JMP READ+1 RESTART INPUT REQUEST E0157 JSB ERMS,I RDR SHOULD TALK MORE QUIKLY DEF MS157 JMP READ+1 TRY READ AGAIN * MS157 ASC 19,E157 READER SHOULD TALK MORE QUICKLY/ * DBLE NOP SBR TO READ TWO CHAR ON RDR JSB READ READ FIRST ALF,ALF SHIFT LBYTE STA TEMP2 SAVE TEMPORARY JSB READ READ SECOND IOR TEMP2 MERGE WITH FIRST JMP DBLE,I RETURN NOW * * SKP 8\H* * CFRDR NOP SBR TO CONF RDR TALKER CLA WITH MSA DEF AT JSB *+1 STA EOIND RESET EOI INDICATOR STA RDFLG RESET READER FLAG LDA LSN34 CONF READER LISTNER FIRST JSB SNDNA,I TO SEND READER MSA OPTION LDA CFRDR,I GET CODE ADDRESS LDA A,I GET CODE JSB SNDNA,I SEND IT JSB OMCCF AND CONFIGURE ISP !!! LDA TLK34 CONF RDR TALKER NOW JSB SNDNA,I ISZ CFRDR BUMP RETURN ADDRESS JMP CFRDR,I AND RETURN NOW * CFPRI NOP SBR TO CONF PRINTER LISTENER JSB INPUT READ TO TEST SRQ AND BT910 ISOLATE VALDA+SRQ SZA,RSS IS THERE SOMETHING GOOD ?? JMP *+3 E0160 JSB ERMS,I YES, SRQ ON !! (OR VALDA) DEF MS160 JSB ADSRQ EXEC SERIAL POLL LDA STBYT GET STATUS BYTE AND B6520 ISOLATE E-O-P PATTERN CPA BT520 IS IT ?? JMP CFPRN YES, NO PAPER LDA LSN33 CONF PRINTER NOW JSB SNDNA,I RSS CFPRN ISZ CFPRI BUMP RTN ADR JMP CFPRI,I AND RETURN * MS160 ASC 20,E160 SRQ OR VALDA SET WHEN NOT EXPECTED/ * BUZZZ NOP SBR TO MAKE BUZZ BUZZ BUZZ LDA OCT07 IOR UTDAT JSB SNDNA,I JMP BUZZZ,I * WRTDI NOP SBR TO TLK36,LSN35,DATA,UNLSN STA TEMP1 JSB UNTAK JSB ODSCF SET DISPLAY LISTENER LDA TEMP1 JSB SNDNA,I JSB OULSN JMP WRTDI,I * * HED **** PRINTER TEST **** * ****************************** **** PRINTER TEST **** ****************************** * TST11 EQU * PRINTER TEST PRNTR NOP ************** LDB UTCMD BITS 8 & 12 OPTIONS ? JSB SWRT,I JMP PRNTR,I YES, RETURN JSB INITS STANDARD INITIALIZATION JSB AIFCL JSB ADSRQ JSB HCYES IF 30HC, REJECT JMP PRNTR,I LDA STBYT GET STATUS BYTE RA\R,RAR IF NO PRINTER, REJECT !!! SLA,RSS JMP PRNTR,I NO PRINTER H0100 JSB MESGC SEND MESSAGE DEF MS100 LDA PRMSA PRINT ON DECONF PRINTER STA TEMP2 SAVE POINTER GO210 LDA TEMP2,I GET CHARACTER CPA M1 IS IT THE LAST ?? JMP GO211 YES, CONTINUE JSB SNDNA,I SEND IT ISZ TEMP2 BUMP POINTER JMP GO210 GO211 JSB MSGH,I REMOVE PAPER !!! DEF MS101 JSB CFPRI VERIFY E-O-P DETECTION RSS JMP *+3 OK, CONTINUE E0110 JSB ERMS,I NO E-O-P DEF MS110 H0102 JSB MSGH,I INSERT PAPER !!! DEF MS102 JSB CFPRI CONF PRINTER NOW JMP *+3 GOOD, CONTINUE E0111 JSB ERMS,I ALWAYS E-O-P PRESENT DEF MS111 LDA M20 START 20 CHAR DUMP STA CNTR LDA BIT05 GET FIRST PRINTABLE CHAR. GO212 STA TEMP1 SAVE CHARACTER IOR UTDAT INCLUDE UTPUT CODE JSB SNDNA,I SEND IT GO213 LDA TEMP1 GET CODE AGAIN INA SET NEW CPA OC140 TEST 64 CHAR HALT JMP GO214 YES ISZ CNTR BUMP 20\60 CHAR. HALT JMP GO212 CPA KBTAB+4 TEST FOR 1ST\3RD LINE MESSAGE JMP *+4 1ST LINE H0104 JSB MSGH,I DEF MS104 JMP *+3 H0103 JSB MSGH,I DEF MS103 LDA M41 SET COUNTER FOR 60 CHAR HALT STA CNTR JMP GO213 CONTINUE GO214 LDA LFCOD SEND TERMINATOR TO PRINT THE JSB SNDNA,I FOUR LAST CHARACTERS H0105 JSB MSGH,I >>> PRINTER : FOURTH LINE NOW <<< DEF MS105 LDA LFCOD TERMINATOR AGAIN JSB SNDNA,I TO SKIP A LINE H0106 JSB MSGH,I >>> PRINTER : FEED A LINE <<< DEF MS106 LDA CODAD SET POINTER TO SEND "DELETE" STA TEMP0 MERGED WITH DATA GO215 LDA TEMP0,I GET DATA CPA M1 IS IT TERMINATOR ?? JMP GO216 YES, EXIT LOOP JSB SNDNA,I SEND DATA ISZ TEMP0 BUMP POINTER M JMP GO215 CONTINUE GO216 JSB MSGH,I >>> PRINTER : ONLY "ABCD" <<< DEF MS107 LDA CAP.A TEST IF DCL ERASE BUFFER JSB SNDNA,I SEND CAP.A TO PRINTER JSB ADSRQ GET STBYT FOR BUSY BIT CHECK LDA STBYT AND BIT03 PRINTER BUSY ?? SZA JMP *+3 E1110 JSB ERMS,I NO BUSY BIT DEF MS110 JSB CFPRI CONF PRINTER AGAIN JMP *+3 E2111 JSB ERMS,I E-O-P DETECTED DEF MS111 LDA DCL CLEAR BUFFERS JSB SNDNA,I JSB ADSRQ GET STBYT AGAIN LDA STBYT AND BIT03 SZA,RSS BUFFER EMPTY==> NOT BUSY JMP *+3 E1111 JSB ERMS,I BUSY BIT SET DEF MS111 JSB CFPRI CONF PRINTER AGAIN JMP *+3 E3111 JSB ERMS,I E-O-P DETECTED DEF MS111 LDA LFCOD SEND TERMINATOR TO PRINT OUT JSB SNDNA,I THE BUFFER CONTENT ( EMPTY ) JSB ADSRQ GET STBYT AGAIN LDA STBYT AND BIT03 IS PRINTER BUSY ?? SZA JMP *+3 E2110 JSB ERMS,I PRINTER NOT BUSY DEF MS110 H1106 JSB MSGH,I >>> PRINTER : ONLY FEED A LINE <<< DEF MS106 JMP PRNTR,I RETURN NOW * HED **** READER TEST **** * ****************************** **** READER TEST **** ****************************** * TST12 EQU * READER TEST READR NOP ************* LDB UTCMD BITS 8 & 12 OPTIONS ? JSB SWRT,I JMP READR,I JSB INITS STANDARD INITIALIZATION JSB AIFCL JSB ADSRQ JSB HCYES IF 30HC, REJECT JMP READR,I LDA STBYT IF NO READER, REJECT !!! RAR SLA,RSS JMP READR,I H0112 JSB MESGC DEF MS112 * * READ CARD (#1) ****** ( TWO SUCCESSIVE READS ) ********************* * LDA M2 SET SEQUENCE COUNTER STA TEMP3 GO22E LDA CDTAB+1 WRITE CARD NBR TO READ JSB WRTDI JSB CFRDR CONFIGURE RDR TALKER WITH  DEF MSA01 CAD,HOLES+MARKS,IMAGE LDA M40 SET CHAR COUNT CARD (#1) STA CNTR LDA ADAT1 SET POINTER FOR ROM TO COMPARE STA TEMP1 CHARACTERS ON CARD (#1) GO220 JSB DBLE READ TWO CHARACTERS LDB TEMP1,I CPA B ARE THEY THE GOOD ONES ?? JMP *+2 YES, CONTINUE JSB RPORT NO, ERROR ISZ TEMP1 BUMP POINTER ISZ CNTR BUMP COUNTER JMP GO220 CONTINUE CCA TEST IF SECOND PASS CPA TEMP3 JMP GO22A YES GOTO TEST DCL LDA M38 PREPARE 76 @ READ STA CNTR GO221 JSB DBLE GET TWO CHAR LDB @@ CPA B ARE THEY THE EXPECTED ONES JMP *+2 JSB RPORT NO,ERROR ISZ CNTR IS IT FINISHED ?? JMP GO221 NO ! JSB DBLE GET THE # LAST CHAR LDB @Q CPA B ARE THEY EXPECTED ?? JMP *+2 YES JSB RPORT NO,ERROR JSB DBLE GET THE TWO LAST CHAR LDB H@ CPA B QH IS LF EQUIVALENT JMP *+2 SKIP IF OK JSB RPORT NO,ERROR JSB TSEOI IS THERE EOI NOW ?? ISZ TEMP3 BUMP SEQ COUNTER JMP GO22E * GO22A JSB UNTAK UNTALK READER LDA DCL SEND DEVICE CLEAR JSB SNDNA,I LDA TLK34 SET READER TALKER AGAIN JSB SNDNA,I JSB INPUT READ DATA TO TEST BUFFER CLEAR AND BT910 ISOLATE VALDA+EOI\SRQ SZA,RSS JMP *+3 E0114 JSB ERMS,I DCL DOESN'T CLEAR TERMINAL DEF MS114 * * READ CARD (#2) NOW !!!!!!! ( 2 SUCCESSIVE READS ) !!!!!!!!!!!!!!!! * GO22F LDA CDTAB+2 CARD NBR TO READ JSB WRTDI JSB CFRDR CONF RDR TALKER WITH DEF MSA02 NCL,HOLES,80 COL,ASCII LDA M1 SET SECOND PASS FLAG STA TEMP3 FOR CHAR SET CHANGE CLA SET FIRST CHAR TO GO222 STA TEMP1 RECOGNIZE ON CARD (#2) JSB READ GET THE CHARACTER 1 LDB TEMP1 CPA B IS IT GOOD ONE ?? JMP *+2 YES, CONTINUE JSB RPORT NO,ERROR LDA TEMP1 SET NEW CHAR AND INA TEST IF FINISHED CPA CAPB. "B" IS LAST CHAR RSS YES, SKIP JMP GO222 CONTINUE READ SEQU. JSB TSEOI IS THERE EOI NOW ?? ISZ TEMP3 TEST FINISHED ON CARD #2 ?? JMP GO22J YES LDA CDTAB+2 CARD NBR TO READ JSB WRTDI JSB CFRDR CONF RDR TALKER WITH DEF MSA02 CAD,HOLES ONLY,ASCII JMP GO222-1 * * TEST CARD REJECT DISABLE ***** ( ONE READ ) ************ * GO22J LDA CDTAB+11 PRINT CARD# TO INPUT JSB WRTDI LDA CDTAB+2 JSB WRTDI JSB CFRDR CONF RDR TALKER WITH DEF MSA07 RJD,NCL,80 COL,HOLES,ASCII LDA M14 SET SPACE COUNTER STA CNTR GO22C JSB READ GET DATA LDB BIT05 CPA B IS IT A SPACE JMP *+2 JSB RPORT NO,ERROR ISZ CNTR MORE SPACE ?? JMP GO22C YES LDA CAPA. SET FIRST CHAR GO22D STA TEMP1 JSB READ GET NEXT ON RDR LDB TEMP1 CPA B IS IT GOOD ONE ?? JMP *+2 JSB RPORT NO,ERROR CCA DECREMENT CODE ADA TEMP1 SSA,RSS EXIT IF NEG JMP GO22D LAST CHAR = 0B JSB TSEOI JMP READR,I * RPORT NOP READER ERROR REPORT E0113 JSB ERMS,I DEF MS113 A=RECEIVED, B=EXPECTED JMP RPORT,I * * HED **** SELF TEST TEST **** * ORG 14000B * ********************************* **** SELF-TEST TEST **** ********************************* * TST03 EQU * SELF-TEST TEST SELFT NOP **************** JSB INITS STD INIT JSB AIFCL JSB ADSRQ LDA STBYT IF NOT 3070B REJECT SLA,RSS JMP SELFT,I H0115 JSB MESGC PRINT TITLE DEF MS115 JS B ODSCF SET DISPLAY LISTENER LDA SFTST TRIGGER SELF-TEST REMOTE JSB SNDNA,I LDA M28 SET SELF-TEST TIME OUT STA TIME LDA TLK35 OUTPUT COMMAND IN ORDER TO JSB SNDEA,I BLOCK HPIB HANDSHAKE GO260 LDA TLK35 TRY TO OUTPUT COMMAND AGAIN JSB SNDEA,I IN ORDER TO KNOW SFTST END RAL TEST IF OK OR NOT OK SSA JMP GO261 OK, CONTINUE ISZ TIME DID 3070B TIMED OUT ?? JMP GO260 NO, NOT YET !! E0116 JSB ERMS,I YES, TIME OUT ON SELF-TEST DEF MS116 GO261 JSB ADSRQ EXEC SERIAL POLL LDA STBYT TEST GOOD STATUS AND B0346 GET BITS LDB OCT21 THIS IS STATUS FOR CONCERN BITS CPA B IS IT GOOD PATTERN JMP SELFT,I RETURN E0117 JSB ERMS,I NOT GOOD BITS IN STBYT DEF MS117 JMP SELFT,I * * HED ***** TOTAL INSTALLATION TEST ***** * ****************************************** **** TOTAL INSTALLATION TEST **** ****************************************** * TST16 EQU * GLOBAL INSTALLATION TEST WINST NOP ************************** LDB UTCMD JSB SWRT,I BITS 8 & 12 OPTIONS ? JMP WINST,I H0131 JSB MESGC DEF MS131 H0132 JSB MSGH,I X INPUT REQUEST DEF MS132 X FOR POLLING LIA SW X CYCLE LENGTH AND BIT50 X SZA,RSS X LDA P63 X CCB X ADA B X STA TEMP1 X JSB INITZ INITIATE DXTAB AND HPIB COMMANDS JSB AIFCL IFC FOR ALL JSB ADSRQ RUB OUT ANY SRQ PRESENT NOW JSB CAPTR FIX NEW POLLING LENGTH CLA START INPUT PHASE FOR SRQ JSB INDXT INIT ALL DXT WITH INPUT CODE CLA INITILIZE BUFFER LOCATION STA TERPT RESET TERMINAL POINTER IBFAD MPY P20 CALCULATE CURRENT ADA BFBAS BUFFER ADDRESS CLB RESET SQCER+STBYT+CINAD \ STB A,I INA STA B INA STORE CTBFA+2 = BFPNT STA B,I INTO CTBFA+1 (BFPNT ADDR) ADB P18 CCA STA B,I STORE TERMINATOR AT EACH BUFF END ISZ TERPT INCR TERMINAL POINTER LDA TERPT CPA P63 IS IT THE LAST ? RSS JMP IBFAD NO CONTINUE RSETT CLA YES STA TERPT RESET TERMINAL POINTER LDA DXTAD STA TRDXA RESET DXT POINTER JSB EXCHG EXEC TOUR DE LOOP * SKP ************************************ *** LOOP FOR DXT MANAGEMENT *** ************************************ * LKDXT LDA TERPT CALCULATE CURRENT BUFFER ADDRESS MPY P20 BASED ON TERMINAL # X 20 WORDS BUFFER ADA BFBAS PLUS BASE BUFFER ADDRESS OFFSET STA CTBFA SAVE IT IN CURRENT BUFF ADDRESS STA B SAVE FOR IMMEDIATE USE LDA B,I GET CINAD+SQCER+STBYT AND B5432 ISOLATE SQCER (BIT15-12) 0 INPUT STA SQCER 1 RDR, 2 SFK, 4 BFR, 8 SRQ LDA B,I GET CINAD+SQCER+STBYT AND B0777 ISOLATE CINAD (BIT 8-0) STA CINAD CURRENT INSTR. TABLE ADDR (MAX=777) LDA B,I GET CINAD+SQCER+STBYT AND B7000 ISOLATE STBYT (BIT 11-9) STA STBYT BIT9 A\B, BIT10 RDR, BIT11 TPR INB LDB B,I STB BFPNT SET BUFFER POINTER FOR DATA FROM TERMINAL LDA TRDXA,I STA TRDXT SET CURRENT DXT WORD AND BIT14 CPA BIT14 IS OK PRESENT ? RSS JMP NOMOD NO => NEW TOUR DE LOOP LDA TRDXT YES => GET STATUS AND STDMK GET BITS 12,10,9 CPA BIT09 SRQ ? JMP SRQCN YES PROCESS CPA BIT10 VALID INPUT ? JMP VLDIN YES PROCESS CPA BT910 VALID INPUT + EOI ? JMP VLDIN AND BIT12 OUTPUT PHASE ? SZA JMP UTBUF YES PROCESS NVINP LDA TRDXT SET DXT WORD IN INPUT CONFIG AN D BIT15 SAVE BIT 15 STA TRDXA,I RESTORE DXT WORD NOMOD LDB CTBFA LDA CINAD RESTORE CINAD+SQCER+STBYT IOR SQCER IOR STBYT STA B,I INB LDA BFPNT STA B,I RESTORE BFPNT LDA TRDXT LAST TERMINAL TO PROCESS ?? SSA,RSS JMP RSETT YES ISZ TERPT NO => INCR TERMINAL # ISZ TRDXA ACTUALISE TRDXA JMP LKDXT LOOP NEXT TERMINAL SKP * ********************************** **** GENERAL SUB-ROUTINES **** ********************************** * * EXCHG NOP IOD29 STC SC,C START LINK CONTROLLER LDB DXTAD OUT LDA B,I OUTPUT DXTAB ON CONTROLLER IOD30 OTA SC,C SSA,RSS LAST WORD ? JMP *+3 INB JMP OUT IOD31 SFC SC WAIT FLAG FROM CONTROLLER JMP INP-1 MAY BE LONG: NO STC SC LIA SW TEST BIT 7 TO ABORT TEST AND BIT07 SZA,RSS JMP IOD31 IOD43 CLC SC ABORT REQUESTED JMP NDT16 LDB DXTAD INP LIA SC,C INPUT DXTAB FROM CONTROLLER STA B,I SSA,RSS LAST WORD ? JMP EXCHG,I INB JMP INP * * CAPTR NOP CALCULATE POINTERS IN DXTAB LDA DXTAD BECAUSE VARIABLE POLLING ADA TEMP1 LENGTH STA DXTAR INA STA DXTAP JMP CAPTR,I * INDXT NOP SET DXT WITH CODE LDB DXTAD CPB DXTAR IS IT ALREADY THE LAST ? JMP LST YES IOR BIT15 SET BIT15 EXCEPTED ON LAST STAUR STA B,I INB CPB DXTAR IS IT THE LAST ? RSS JMP STAUR NO KEEP BIT15 SET LST AND NBT15 YES CLEAR BIT15 STA B,I JMP INDXT,I * SKP * ************************************* **** S R Q TREATMENT **** ************************************* * SRQCN LDA CINAD EXECUTE NEW INPUT IF SRQ IS SENT CPA SRTB3 WHEN STS BYT EXPECTED (SLOW O JMP NVINP LISTENERS ON HPIB) LDA BIT15 CHECK SQCER IS SET CPA SQCER IN SRQ PHASE JMP SRQTR YES STA SQCER NO, FORCE TO THIS PHASE LDA SRQAD NEED TO SET CINAD STA CINAD AT SRQ TABLE JMP SRQTR CONTINUE NORMAL WAY SRPTR LDA TRDXT SERIAL POLL TREATMENT AND OCT07 GET A\B TYPE+RDR\TPR OPTION ALF,ALF RAL STA STBYT AND SAVE IT LDA TRDXT GET DATA AGAIN AND SRPMK INPUT TO TEST BIT6 HERE CPA SRPMK JMP SRQTR CONTINUE WITH SRQTR E0134 JSB ERMS,I DON'T FIND OUT DEF MS134 SERIAL POLL RESPONSE SRQTR LDA TERPT CONFIGURE SRQ TABLE WITH INA TERMINAL LINK ADDRESS ARS,ARS IN ORDER TO OUTPUT IT ARS ON DISPLAY AND OCT07 IOR CDTAB STA MSBYT LDA TERPT INA AND OCT07 IOR CDTAB STA LSBYT LDA CINAD,I CPA M1 SRQ TREATMENT SEARCH TERMINATOR RSS PRESENT => RESET SRQ PHASE JMP UTAB1 CONTINUE OUTPUT RSRQP CLA SET INPUT PHASE STA SQCER RESET SEQUENCE POINTER STA CINAD RESET CURRENT INST ADDR LDA CTBFA RESET BUFFER POINTER ADA P2 STA BFPNT JMP NVINP GO TO INPUT PHASE * SKP * *************************************** **** VALID INPUT TREATMENT **** *************************************** * * VLDIN LDA SQCER VALID INPUT SEQUENCE CPA BIT15 SRQ SEQUENCE ? JMP SRPTR YES GO TO CPA BIT12 READER INPUT ? JMP REDER YES, PROCESS LDA TRDXT AND KBTAB DETECT SFK CODE CPA FKTAB JMP TRSFK GO & TREAT IT LDA TRDXT AND RBYTE ISOLATE ASCII FROM KEYBOARD IOR BIT12 CONFIG IT FOR BIT12 CPA DEL IF DEL\LF 2 FIRST CHAR JMP DELTR EXEC READER\PRINTER SEQU CPA LFnCOD DETECT LF CHARACTER JMP RSBFP HERE => RESET BFPNT ISZ CINAD BUMP DEL\LF DETECTOR DELRT LDB BFPNT INB GO & SEE AHEAD IF END OF BUFFER LDB B,I CPB M1 LIMIT ? JMP NVINP LIMIT NEW INPUT TO WAIT LF STA BFPNT,I SAVE DATA ISZ BFPNT JMP NVINP RSBFP LDB B0777 DETECT LF AFTER DEL CPB CINAD JMP SETRD STA BFPNT,I SAVE TERMINATOR LDA CTBFA RESET BUFFER POINTER INA ON LINE FEED ARRIVAL STA BFPNT LDA DCFAD SET CINAD TO DECONF AND SRQ TABLE STA CINAD LDA BIT14 SET OUTPUT BUFFER PHASE STA SQCER JMP UTBF1 * DELTR CLB IF DEL FIRST CHAR,SET CPB CINAD CINAD TO -1 RSS JMP DELRT LDB B0777 STB CINAD JMP DELRT * SKP * ******************************************************* **** OUTPUT BUFFER & DECONF ORDERS **** ******************************************************* * * * UTBUF LDA SQCER OUTPUT PHASE CPA BIT13 SFK OUTPUT ? JMP SFKPR YES GOTO CPA BIT15 SRQ OUTPUT ? JMP SRQTR YES GOTO CPA BIT12 IF RDR\TPR SEQ, CONTINUE JMP UTABL CPA BIT14 OUTPUT BUFFER ?? RSS JMP UNCNF >>> SHOULD NEVER OCCUR <<<<<<<<<<<<< UTBF1 LDB UNTLK PREPARE UNTALK KEYBOARD LDA CTBFA FOR FIRST OUTPUT INA CPA BFPNT FIRST OUTPUT ? RSS YES LDB BFPNT,I NO NORMAL OUTPUT UTBF2 LDA TRDXT AND BIT15 SAVE BIT15 IN DXT & ADD IOR B B CONTENT STA TRDXA,I STORE IN DXT FOR NEXT OUTPUT ISZ BFPNT INCR BUFFER POINTER CPB LFCOD IS IT TERMINBATOR ?? RSS JMP NOMOD LDA BIT15 STA SQCER JMP NOMOD * UNCNF LDA DCFAD SET DECONF TABLE AND SRQ WAIT STA CINAD LDA BIT15 SET TO SRQ PROCESS PHASE STA SQCER * UTABL LDA CINAD,I GET NEXT TABLE WORD CPA M1 SEARCH TERMINATOR JMP UNCNF REACHED => SET DECONF+SRQ WAIT UTAB1 LDA TRDXT PREPARE NEXT DXT WORD AND BIT15 IOR CINAD,I UTAB2 STA TRDXA,I ISZ CINAD INCR POINTER JMP NOMOD * * SKP * * * * **************************************** **** S F K CODE TREATMENT **** **************************************** * * * * * TRSFK CLB CONF CODE ACCORDING A\B LDA STBYT GET TYPE AND BIT09 SZA SKIP FOR A-VERSION CCB LDA TRDXT CONVERT SFK CODE AND B3210 TO ANNUNC LIGHTS ADA SFKAD CODE & SEND IT ADA B ADJUST WITH OPTION LDB A,I DIRECTLY TO THE LDA TRDXT TERMINAL AND BIT15 IOR B STA BFPNT,I LDA TRDXT AND BIT15 IOR UNTLK STA TRDXA,I LDA BIT13 SET SQCER TO SFK OUTPUT STA SQCER LDA OCT30 SET CINAD TO 30 STA CINAD JMP NOMOD SFK OUTPUT & CAUSES SFKPR LDA CINAD CPA OCT30 JMP SFDAT CPA OCT31 JMP SFTLK CLA PROGRAM TO EXECUTE STA SQCER INPUT AFTER BY SETTING JMP NVINP SQCER TO 0 * SFTLK LDA TRDXT AND BIT15 IOR TLK35 JMP UTAB2 SFDAT LDA BFPNT,I JMP UTAB2 * * SKP * ************************************** **** READER\PRINTER PROCESS **** ************************************** * * SETRD LDA BIT12 SET SEQU TO RDR\TPR STA SQCER LDA STBYT TEST IF: - 3070A AND BT110 - 3070B SZA,RSS - " + TPR JMP UNCNF - " + RDR\TPR LDB RDSEQ PRESET TO RDR\TPR CPA BIT11 LDB PRSEQ FORCE TO TPR ONLY STB CINAD JMP UTABL AND EXECUTE TABLE OUTPUT * * REDER LDA TR rNLHHN h@ 92900-18002 1840 S 0422 &DVA47 92900B SUBSYSTEM DRIVER             H0104 ASMB,Q,Z,C USE 'Z' FOR RTE-III/IV *ASMB,R,L,N USE 'Z' FOR RTE-II * IFN BEGIN RTE-II CODE NAM DVA47,0 92900-16002 REV.1840 780724 XIF * **** * IFZ BEGIN RTE-III CODE NAM DVA47,0 92900-16003 REV.1840 780724 XIF SPC 2 ENT IA47,CA47 EXT $ETEQ,$OPSY SUP PRESS EXTRA LISTING * SETEQ EQU $ETEQ SPC 3 * NAME: DVA47 HP 92900B SUBSYSTEM DRIVER * SOURCE TAPE: 92900-18002 780724 (RTE-II/III/IV/M) * BINARY TAPE: 92900-16002 (RTE-II) / 92900-16003 (RTE-III/IV) * LISTING: 92900-19002 780724 / 92900-19003 780724 * PGMR: F.G. - ( D.P. DVA47 REV-A ---> DVA47 REV-B ) * DATE: JULY 24 1978 - GRENOBLE - * MANUAL: 92900-90005 * SPC 4 **************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * **************************************************************** HED INITIATION SECTION. ******************************************************************** * INITIATION SECTION * ******************************************************************** SPC 1 IA47 NOP STA SELEC SAVE SELECT CODE OF CONTROLLER JSB SETIO CONFIGURE I/O INSTRUCTIONS LDB EQT13,I GET ADDRESS OF EQT16 STB EQT16 STORE IN TEMPORARY BUFFER INB COMPUTES ADDRESS OF EQT17 STB EQT17 STORE IN TEMPORARY BUFFER INB COMPUTES ADDRESS OF EQT18 STB EQT18 STORE IN TEMPORARY BUFFER SPC 1 LDB EQT12,I GET ADDRESS OF DUMMY EQT13 SZB,RSS IS IT EQUAL TO ZERO ? JMP SETP0 YES: IT COULD BE DUMMY EQT CPB D3 HAS THߊIS CONTROLLER ALREADY BEEN USED ? JMP SETP2 NO: GO TO INITIALIZE THIS LINK SETP0 ADB DM7 YES: COMPUTE PROBABLE DUMMY EQT6 ADDRESS LDA B,I GET DUMMY EQT6 CONTENT CPA M1 HAS THIS CONTROLLER ALREADY BEEN USED ? JMP SETP1 YES: SET UP LOCAL POINTERS SZA,RSS NO: IS EQT6 CONTENT UNALTERED ? JMP SETP2 YES: CONTROLLER HAS NOT BEEN USED JMP ILRQT DUMMY EQT WAS DESTROYED !!!!!!!!! SETP1 ADB D7 COMPUTE DUMMY EQT13 ADDRESS JSB SETP. SET UP LOCAL POINTERS JMP IA472 CONTINUE * SETP2 JSB INIT0 INITIALIZE THE CONTROLLER * IA472 LDA EQT17,I CLEAR OP-CODE/STEP-NUM/START BIT AND B277 STA EQT17,I AND B77 SZA,RSS IS TERM # 0 ? JMP POWF YES, MUST BE A POWER FAIL RECOVERY CALL. SPC 1 CLA CLEAR TLOG STA EQT10,I LDA EQT11 JSB SETTQ SET TEMPORARY TEQXX POINTER LDA EQT5,I RESET STATUS IN EQT5 AND LHALF STA EQT5,I SPC 1 * LDA .WSRQ CHECK IF THE TERMINAL IS ALREADY IA4.1 LDB A,I IN USE (I.E. LINKED IN ONE SZB,RSS QUEUE OF THE DRIVER) JMP IA4.2 IT IS THE END OF WAITING SRQ QUEUE CPB EQT11 IS IT THIS TERMINAL ? JMP IA4.6 YES, REMOVE IT FROM THE QUEUE LDA B NO: CONTINUE SCANNING JMP IA4.1 THIS QUEUE UNTIL END OF QUEUE SPC 1 IA4.2 LDA .COMQ NOW SEARCH IN COMPLETION QUEUE IA4.3 LDB A,I SZB,RSS JMP IA4.4 IT IS THE END OF COMPLETION QUEUE CPB EQT11 IS IT THIS TERMINAL ? JMP IA4.6 YES, REMOVE IT FROM THE QUEUE LDA B NO, CONTINUE SCANNING JMP IA4.3 THIS QUEUE UNTIL END OF QUEUE. * IA4.4 LDA .ACTQ NOW SEARCH IN ACTIVE QUEUE IA4.5 LDB A,I SZB,RSS END OF QUEUE ? JMP IA4.7 YES, END OF ACTIVE QUEUE CPB EQT11 NO, IS IT THIS TERMINAL ? JMP IA4.6 YES, REMOVE IT FROM THE QUEUE LDA B NO, CONTINUE SCANNING JMP IA4.65 THIS QUEUE UNTIL END OF QUEUE. * IA4.6 LDB B,I GET NEXT LINK IN THE LIST, STB A,I PUT IT IN PREVIOUS ONE TO CLA DEQUEUE THIS TERMINAL AND STA EQT11,I CLEAR THIS LINK WORD. SPC 1 IA4.7 LDA EQT6,I GET REQUEST WORD RAR SSA,SLA CONTROL REQUEST ? JMP I.CO YES, PROCESS CONTROL REQUEST SLA READ/WRITE 0/1 JMP I.WR PROCESS WRITE REQUEST JMP I.RD PROCESS READ REQUEST * SKP IA475 IOR EQT17,I MERGE OP-COD & STEP-NUM. IA476 STA EQT17,I IN BIT 15-8 OF EQT17. * * PUT THE NEW TERMINAL IN THE ACTIVE QUEUE. * LDA .ACTQ,I GET ACTIVE QUEUE HEAD LDB EQT11 AND INSERT THIS TERMINAL STA B,I AT THE BEGINING OF THE QUEUE STB .ACTQ,I ADA .COMQ,I IN THE COMPLETION QUEUE ? SZA,RSS IS SERIAL LINK ACTIVE ? JMP STRLO NO, START CONTROLLER * STCH1 STC 0 YES, INTERRUPT AFTER NEXT POLLING CYCLE IA479 CLA JMP IA47,I RETURN WITH A=0 CONTINUE SPC 2 IMMC LDA D4 IMMEDIATE COMPLETION CLB TRANSMISSION LOG = 0 JMP IA47,I EXIT. SKP ******************************************************************** * ERROR RETURN IN INITIATION SECTION * ******************************************************************** SPC 1 ILRQ LDB D5 ILLEGAL REQUEST, ERR CODE=5 ILRQ5 LDA EQT5,I SET ERR. CODE IN THE STATUS AND LHALF WORD, EQT5 BIT 7:0 IOR B AND SET BIT 15 OF TLOG WORD STA EQT5,I AS AN ERROR INDICATOR. LDA D3 SET COMPLETION CODE FOR SYSTEM CPB D5 IF IT WAS ILLEGAL REQUEST THEN LDA D4 SET COMPL. CODE TO ILL. REQ. LDB BIT15 JMP IA47,I * ILRQT LDB D4 BAD EQT CONFIGURATION JMP ILRQ5 EXIT WITH ERR. CODE=4 * ILRQ7 CLA THE CONTROLLER SEEMS TO BE DEAD STA .ACTQ,I OR NOT THERE, CLEAR ACTIVE QUEUE, STA .WSRQ,I CLEAR WAITING QUEUE [NAL INB COMPUTE EQT13 ADDRESS LDB B,I GET EQT16 ADDRESS LDA DTLKA GET DEFAULT TALKER ADDRESS STA B,I AND SET EQT16 INB COMPUTES EQT17 ADDRESS LDA TEMP1 GET TERMINAL NUMBER STA B,I AND PUT IT IN EQT17 INB COMPUTES EQT18 ADDRESS LDA B32 INITIALIZE EQT18 READER CTRL. WORD STA B,I AND STORE IN EQT18 INIT6 ISZ TEMP1 COMPUTE NEXT TERMINAL NUMBER JMP INIT3 GET NEXT EQT SPC 1 INIT5 LDA BIT13 SET THE "I WILL HANDLE POWER IOR B,I FAIL" BIT IN THE DUMMY EQT. IOR BIT12 SET "I WILL PROCESS T.O." BIT STA B,I IN EQT4 INB SET THE BUSY BIT IN THE LDA BIT15 DUMMY EQT5 TO PROCESS POWER IOR B,I FAIL FOR THE WHOLE LINK STA B,I SET EQT5 WORD FOR POWER FAIL * INB COMPUTE DUMMY EQT6 ADDRESS CCA SET THE "LINK ALREADY INITIALIZED" FLAG STA B,I IN THE EQT6 OF THE DUMMY EQT INB COMPUTE DUMMY EQT7 ADDRESS LDA DEFOT GET DEFAULT: 4 SECONDS WSRQ TIME OUT STA B,I AND PRESET DUMMY EQT7 ADB D5 COMPUTE DUMMY EQT12 ADDRESS JSB INIT7 VERIFY EQT EXTENSION LENGTH INB COMPUTE DUMMY EQT13 ADDRESS STB TEMP3 SAVE IT TO COPY IT IN TERMINAL EQT12 LDB B,I GET EQT16 ADDRESS INB COMPUTE EQT17 ADDRESS CLA A=0 STA B,I INITIALIZE TERMINAL NUMBER TO 0 * LDA INTAB VERIFY THAT THIS EQT ADA M6 IS REFERENCED BY THE INTERRUPT TABLE ADA SELEC LDA A,I ADA D12 POINT ON EQT13 CPA TEMP3 IS CONFIGURATION ALL RIGHT ? JMP INIT6 YES, GO AHEAD JMP ILRQT NO, MUST RECONFIGURE * DEFOT DEC -400 DEFAULT VALUE FOR TIME OUT SPC 3 INIT7 NOP SUBROUTINE TO CHECK EXTENSION LENGTH LDA B,I GET EQT12 WORD CONTENT CPA D3 IS IT A 3 WORD LENGTH EXTENSION ? RSS YES: RETURN JMP ILRQT NO: MUST RECONFIGURE JMP INIT7,I EVERYTHING IS O.K. SPC 3 *-------> DUMMY EQT12: ACTIVE QUEUE HEAD SPC 3 *-------> DUMMY EQT16: COMPLETION QUEUE HEAD SPC 3 *-------> DUMMY EQT18: WAITING QUEUE HEAD SKP ******************************************************************** * READ REQUEST INITIATION * ******************************************************************** SPC 1 I.RD JSB BFSET SET BUFF ADDR AND LENGTH TO EQT NOP ZERO LENGTH (ONLY LF ACCEPTED) JSB STREN SET REN BIT IN STATUS * JSB CLBT7 CLEAR BIT 7 AND KEEP IT STATUS * LDA EQT6,I GET REQUEST CODE AND BIT10 MASK OUT BIT 10 CPA BIT10 IS IT SET ? JMP I.WD YES: INITIALIZE A WRITE/READ * LDB EQT16,I NO: GET TRANSPARENT MODE FLAG IN BIT 15 LDA OPRDX TRANSPARENT MODE READ OP-CODE SSB TRANSPARENT MODE ? JMP IA475 YES: SET OP-CODE INTO EQT17 * JSB BADG? IS IT A CARD READER READ ? JMP I.RD2 NO, OR READER ABSENT: CONTINUE LDA OPCAR YES: GET OP-CODE/STEP NUMBER FOR O.M.R. JMP IA475 AND SET OP-CODE INTO EQT17 * I.RD2 LDA EQT6,I GET OPERATION CODE IOR TEMP1 RESTORE BIT 7 STATUS AND NBT9 ELIMINATE BIT 9 (NO CARD READER) STA EQT6,I FORCE EQT6 WORD: READ FROM KEYBOARD LDB EQT6,I GET REQUEST CONTROL WORD BLF,BLF AND ROTATE BIT:K INTO B0 LDA OPRD NORMAL MODE READ OP-CODE SLB BIT: K = 1 ? LDA OPRDK NORMAL MODE READ OP-CODE JMP IA475 AND SET OP-CODE INTO EQT SPC 2 STREN NOP GET STATE OF THE REN BIT LDA EQT17,I FROM EQT17 AND BIT7 AND PUT IT IN RAR STATUS WORD BIT6 LDB EQT5,I IOR B STA EQT5,I JMP STREN,I SPC 1 CLBT7 NOP CLEAR AND SAVE STATUS BIT 7 LDA EQT6,I GET REQUEST CODE AND BIT7 7MASK OUT BIT 7 STA TEMP1 SAVE IT TEMPORARILY LDA EQT6,I GET EQT6 REQUEST CODE AND NBT7 CLEAR BIT 7 STA EQT6,I RESTORE EQT6 REQUEST CODE JMP CLBT7,I RETURN SPC 2 SKP ******************************************************************** * WRITE/READ REQUEST INITIATION * ******************************************************************** SPC 1 I.WD LDA EQT8,I GET TOTAL BUFFER LENGTH JSB NGTIF COMPUTE TOTAL BYTE LENGTH (NEGATIVE) CMA,INA MAKE IT POSITIVE ADA DM4 SUBSTRACT FIRST TWO WORDS STA TEMP1 SAVE IT TEMPORARILY LDB EQT7,I GET ADDRESS OF FIRST WORD OF BUFFER LDA B,I GET OUTPUT BUFFER LENGTH SZA,RSS IS IT EQUAL TO ZERO ? JMP I.WD0 YES: REJECT THE CALL JSB NGTIF COMPUTE OUTPUT BYTE LENGTH (NEGATIVE) STA EQT10,I USE EQT10 AS AN OUTPUT BYTE COUNTER AND NBT0 MAKE IT ODD !!!! (MAY BE +1) ADA TEMP1 A=[TOTAL-4-ODD OUTPUT LGTH.] STA TEMP1 SAVE IT TEMPORARILY INB COMPUTE ADDRESS OF SECOND WORD OF BUFFER LDA B,I GET INPUT BUFFER LENGTH JSB NGTIF COMPUTE INPUT BYTE LENGTH (NEGATIVE) ADA TEMP1 A=[TOTAL-4-ODD OUTPUT LGTH.-INPUT LGTH.] LDB D1 PREPARE AN EVENTUAL ERROR CODE SSA IS IT POSITIVE ? I.WD0 JMP ILRQ REJECT THE CALL !!!!!!!! LDB EQT7,I GET FIRST WORD BUFFER ADDRESS LDA B GET FIRST WORD BUFFER ADDRESS ADA D2 COMPUTE FIRST WORD OUTPUT BUFFER ADDRESS CLE,ELA COMPUTE FIRST OUTPUT BYTE BUFFER ADDRESS STA EQT9,I USE EQT9 AS OUTPUT BUFFER BYTE POINTER JSB STREN SET REN BIT IN STATUS * LDA OPWCN GET OP-CODE/STEP # STARTING WORD LDB EQT16,I GET TRANSPARENT/NORMAL MODE OF READING SSB NORMAL OR TRANSPARENT ? LDA OPWCB TRANSPARENT: SKIP TWO FIRST STEPS JMP IA475 CONTINUE SPC 3 * OP-CODE/STEP NUMBER I NITIALIZATION TABLE SPC 1 * BIT 6 ALWAYS SET. (INDICATES COMING FROM INITIATOR) * OPRDK OCT 010100 OP-COD=1, STEP=0. OPRD OCT 010500 OP-COD=1, STEP=1. OPWR OCT 020100 OP-COD=2, STEP=0. OPPRI OCT 020500 OP-COD=2, STEP=1. (WRITE ON PRINTER) OPSP OCT 030100 OP-COD=3, STEP=0. OPREN OCT 040300 OP-COD=4, STEP=0, BIT REN. OPWSR OCT 050100 OP-COD=5, STEP=0. OPEOR OCT 070100 OP-COD=7, STEP=0. OPCAR OCT 100100 OP-COD=8, STEP=0. (BADGE CARD READER) OPRDX OCT 102500 OP-COD=8, STEP=5. (TRANSPARENT MODE READ) OPWRX OCT 110100 OP-COD=9, STEP=0. OPRDI OCT 120100 OP-COD=10, STEP=0. OPGSB OCT 130100 OP-COD=11, STEP=0. OPCSR OCT 140100 OP-COD=12, STEP=0. OPTSK OCT 150100 OP-COD=13,STEP=0. (SFK TERMINATOR) OPWCN OCT 160100 OP-COD=14,STEP=0. (WRITE COMMAND/READ NORMAL) OPWCB OCT 161100 OP-CODE=14,STEP=2. (WRITE COMMAND/READ TRANSPARENT) OPWTQ OCT 170100 OP-CODE=15,STEP=0. (CHECK SRQ PERIODICALLY) SKP ******************************************************************** * WRITE REQUEST INITIATION * ******************************************************************** SPC 1 I.WR JSB STREN SET REN BIT INTO STATUS WORD * JSB CLBT7 GET BIT 7 STATUS & CLEAR IT * LDB EQT6,I BLF,RBL ELB,BLF BIT:X -->E, BIT:M --> B0 SEZ STANDARD WRITE ? JMP I.WR4 NO, SPECIAL WRITE LDB EQT16,I GET TRANSPARENT MODE FLAG SSB TRANSPARENT MODE ? JMP I.WR6 YES LDA EQT6,I NO: NORMAL MODE IOR TEMP1 RESTORE BIT 7 STA EQT6,I IN CONTROL REQUEST WORD LDA OPWR GET OP-CODE/STEP NUMBER LDB TEQ18,I GET HARDWARE STATUS WORD SSB,RSS IS THERE A PRINTER ? JMP IA475 NO: WRITE ON DISPLAY LDB EQT6,I GET REQUEST CODE BLF MOVE BIT 9 IN BIT 13 RBL,RBL MOVE BIT 9 IN BIT 15 SSB IS IT A WRITE ON PRINTER ? LDA OPPRI YES: SKIP FIRST STEP i JMP IA475 NORMAL MODE * I.WR4 SLB,RSS SERIAL POLL REQUEST ? JMP I.SP YES I.WR6 LDA OPWRX NO, WRITE COMMAND BYTE REQUEST JMP IA475 * SPC 2 ******************************************************************** * SERVICE REQUEST ANALYSIS INITIATION (SERIAL POLL) * ******************************************************************** SPC 1 I.SP LDA EQT8,I GET BUFFER LENGTH SSA POSITIVE VALUE ? JMP ILRQ NO, ERROR ILLEGAL RQ. CMA,INA STA EQT10,I USE EQT10 AS A WORD COUNT LDA EQT7,I GET BUFFER ADDR. STA EQT9,I USE EQT9 AS A WORD POINTER LDA OPSP GET OPCOD JMP IA475 SKP ******************************************************************** * CONTROL REQUEST INITIATION * ******************************************************************** SPC 1 I.CO LDA TEQ6,I GET CONTROL WORD ALF,ALF RAL,RAL AND B37 ADA COFAD CHECK IF LDB COFED FUNCTION CODE CMB,INB IS ADB A WITHIN SSB TABLE JMP ILRQ NO, ERROR JMP A,I YES, JUMP TO PROPER ROUTINE SPC 1 ******************************************************************** * CLEAR REQUEST INITIATION * ******************************************************************** SPC 1 CL LDA M6 USE EQT9 AS A COUNTER FOR STA TEQ9,I BAD OK BIT LDA TEQ16,I PRESET NEXT AND BIT15 TALKER ADDRESS AND READ COMPLETION IOR DTLKA FLAG BUT KEEP CURRENT MODE. STA TEQ16,I LDA TEQ18,I GET EQT18 AND BT012 SAVE BITS 15, 14, & 13 IOR B32 INITIALIZE READER CONTROL WORD STA TEQ18,I CLEAR READER CONTROL WORD LDA TEQ17,I CLEAR OP-COD, STEP-NUM & REN BIT AND B77 IN EQT17 IOR BIT6 MERGE START BIT JMP IA476 * DTLKA OCT 35 DEFAULT NEXT TALKER B@
[B] ADB DM31 COMPARE TO 310 M.S. SSB TIME OUT < 310 M.S. ? LDA D31 YES: FORCE TIME OUT = 310 M.S. CMA,INA MAKE IT NEGATIVE JSB LOEQT GET DUMMY EQT7 ADDRESS STA B,I UPDATE DUMMY EQT7 VALUE * WTSR1 LDA OPWTQ OP-CODE FOR A WAIT FOR SRQ PERIODICALLY JMP IA475 INITIALIZE THE REQUEST SPC 2 ******************************************************************** * WAIT UNTIL SRQ RECEIVED * ******************************************************************** SPC 1 WSRQ LDA OPWSR GET OP CODE JMP IA475 SPC 2 ******************************************************************** * SET CARD/BADGE READER CONTROL WORD * ******************************************************************** SPC 1 CARSP LDA EQT7,I GET BADGE READER CONTROL WORD AND B37 MASK OUT SIGNIFICANT BITS SZA,RSS IS IT UNDEFINED ? JMP IMMC YES: DO NOT MODIFY CTRL. WORD STA TEMP1 SAVE CONTROL WORD TEMPORARILY LDA TEQ18,I GET EQT18 WORD AND OC37 CLEAR READER CONTROL WORD IOR TEMP1 MERGE WITH NEW ONE STA EQT18,I STORE THIS CONTROL WORD IN EQT18 JMP IMMC IMMEDIATE COMPLETION SPC 2 ******************************************************************** * SET TIME OUT VALUE * ******************************************************************** SPC 1 STO LDB EQT7,I GET NEW TIME OUT VALUE SSB,RSS IS IT POSITIVE ? CMB,INB YES: MAKE IT NEGATIVE STB EQT14,I UPDATE TIME OUT. JMP IMMC SPC 2 ******************************************************************** * SET IFC LINE TRUE THEN FALSE * ******************************************************************** SPC 1 IFC LDA OPIFC GET OP-CODE/STEP-NUMBER FOR IFC CONTROL JMP IA475 PROCESS THE REQUEST AFTER MERGING A IN EQT17 * OPIFC OCT 002100 OP-CODE=0, STEP=4. (SET/CLEAR IFC) SKP ******************************************************************** * ENABLE/DISABLE READ TERMINATION ON A SPECIAL FUNCTION KEY * ******************************************************************** SPC 1 TSFK LDB EQT7,I GET SFK CODE SSB MAKE IT POSITIVE CMB,INB CPB D1 TERMINATION ON SRQ ? JMP TSFK5 YES, GOTO PROCESS * ADB M2 NO, CHECK SOFT KEY NUMBER SSB SFK # > OR = TO 2 ? JMP ILRQ ILLEGAL REQUEST ADB M#SFK SSB,RSS SFK # < OR = TO 11 JMP ILRQ NO: ILLEGAL REQUEST CPB M1 IS IT SFK# 11 ? RSS YES: CHECK TERMINAL TYPE JMP TSFK4 NO: PROCESS IT * JSB AORB? IS IT A 3070B TERMINAL ? JMP ILRQ NO: ILLEGAL REQUEST JMP TSFK4 3070B: PROCESS SFK # 11. * TSFK5 LDA BIT11 SET BIT 11 IN A REGISTER LDB EQT7,I PROCESS THE KEY SSB ENABLE OR DISABLE ? JMP TSFK2 DISABLE IOR TEQ18,I MERGE BIT 11 TSFK1 STA TEQ18,I AND SAVE NEW EQT18 JMP IMMC IMMEDIATE COMPLETION TSFK2 LDA NBT11 KEEP ALL BITS EXCEPT BIT 11 AND TEQ18,I CLEAR BIT 11 OF EQT18 JMP TSFK1 DISABLE SFK # 11 * TSFK4 ADB TSFKT LDA B,I GET THE BIT AND LDB EQT7,I PROCESS SSB ENABLE OR DISABLE ? JMP TSFK8 DISABLE IO:R TEQ16,I ENABLE, SET THE BIT TSFK7 STA TEQ16,I AND SAVE NEW EQT16 JMP LSFK LOCAL PROGRAMMATION * TSFK8 CMA DISABLE, CLEAR THE BIT AND TEQ16,I JMP TSFK7 * LSFK JSB AORB? IS IT A MODEL 3070B ? JMP IMMC NO: IMMEDIATE COMPLETION LDA EQT7,I GET SOFT KEY NUMBER SSA POSITIVE ? CMA,INA NO: MAKE IT POSITIVE ADA M2 TRANSLATE TO THE RIGHT KEY LDB EQT7,I GET SFK FUNCTION SSB,RSS IS IT POSITIVE ? IOR BIT4 YES: MEANS SOFT KEY TERMINATOR STA EQT8,I SAVE THIS SECONDARY ADDRESS IN EQT8 LDA EQT8 GET EQT8 ADDRESS STA EQT9,I AND SAVE IT IN EQT9 FOR MERGING. LDA OPTSK GET OP-CODE/STEP NUMBER WORD JMP IA475 START A CONTINUATION SPC 2 ******************************************************************** * SET NORMAL OR TRANSPARENT MODE * ******************************************************************** SPC 1 NM CCB SET NORMAL MODE NM2 LDA BIT15 SSB,RSS NORMAL/TRANSPARENT MODE ? JMP NM3 TRANSPARENT MODE * CMA SET NORMAL MODE AND TEQ16,I IN EQT16 WORD NM4 STA TEQ16,I STORE NEW EQT16 JMP IMMC IMMEDIATE COMPLETION * NM3 IOR TEQ16,I SET TRANSPARENT MODE BIT JMP NM4 IN EQT16 WORD SPC 1 TM CLB SET TRANSPARENT MODE JMP NM2 HED CONTINUATION SECTION. ******************************************************************** * CONTINUATION SECTION * ******************************************************************** SPC 1 CA47 NOP JSB SETIO SPC 1 LDA EQT4,I IS IT A TIME OUT INTERRUPT ? ALF SSA DID THE DEVICE TIMED OUT ? JMP TO YES, PROCESS SPC 1 LDA EQT6,I GET EQT6 CONTENT CPA M1 IS IT THE CONTROLLER ONE ? RSS YES: PROCESS THE INTERRUPT y JMP CY47 NO: IGNORE THIS INTERRUPT !!! LDB EQT13 GET ADDRESS OF DUMMY EQT13 JSB SETP. SET UP LOCAL POINTERS LDB DXTAD USE B AS POINTER INTO DXT LIAC1 LIA 0,C READ DATA FROM CONTROLLER STA B,I STORE INFORMATION INTO DXT SSA,RSS WAS IT LAST WORD FROM CONTROLLER ? JMP GET.2 YES, PROCESS DATA SFS.1 SFS 0 IS FLAG SET ? JMP ERR0 NO - ABNORMAL, IGNORE THIS INTERRUPT. INB INCREMENT POINTER INTO DXT CPB DXT.D IS IT INSIDE THE DXT TABLE ? JMP ERR0 NO - ABNORMAL, ERROR RETURN !!!!!!! JMP LIAC1 LOOP IN DXT SPC 1 GET.2 IOR BIT15 MERGE BIT 15 TO BE ABLE TO ADD STA B,I NEW TERMINALS WITH GREATER ADDR. STB OLLAT SAVE PREVIOUS LAST TERMINAL # CLA CLEAR STA CULAT PREVIOUS CURRENT TERMINAL STA STCFL INTERRUPT AFTER NEXT POLLING CYCLE FLAG SPC 1 ******************************************************************** * * * GO ALONG THE QUEUE OF ACTIVE TERMINAL, * * AND TREAT DATA FROM DXT. * * * ******************************************************************** SPC 1 IFZ RSA GET MEM STATUS RAL,RAL AND STA DMSST SAVE IT LDA MAPUS SAVE ALSO CURRENT USER MAP IOR BIT15 TO MEMORY USA GET USER MAP CLA SET FLAG STA MAPFL TO NOT RESTORE USER MAP SJP TRD00 ENABLE SYSTEM MAP TRD00 EQU * XIF SKP LDA .ACTQ LDB A,I GET ACTIVE QUEUE HEAD SZB,RSS ACTIVE QUEUE EMPTY ? JMP CMPL0 ACTIVE QUEUE EMPTY: COMPLETION STA PTAQU SPC 1 TRD02 ADB D2 COMPUTES EQT13 ADDRESS LDB B,I GET EQT16 ADDRESS INB COMPUTES EQT17 ADDRESS (OPG-CODE/STEP #) STB TOFL SET UP "NO LONGER T.O." (EQT17 ADDRESS) LDA B,I GET EQT17 CONTENT AND B77 MASK OUT TERMINAL # ADA M1 OFFSET IT IN DXTAB ADA DXTAD STA CURWD SAVE CURRENT POINTER INTO DXT LDA A,I GET DATA FOR THAT TERMINAL STA DXTWD SAVE CURRENT DATA WORD FROM DXT SPC 1 LDA B,I CHECK IF COMING FROM INITIATOR SECTION AND B100 SZA JMP TRD09 YES SPC 1 LDA DXTWD IS THIS TERMINAL IN AND BIT13 IDLE STATE SZA ? JMP TRD04 YES,GOTO NEXT ONE. SPC 1 LDA B,I RECALL EQT17 AND LHALF ISOLATE OP-COD & STEP-NUM. CPA Y.CS# CHECK FOR SRQ PROCESSING ? JMP TRD03 YES, IGNORE DXT DATA CPA Y.SP# CHECK FOR SRQ (GENERAL CASE) ? JMP TRD03 YES, IGNORE DXT DATA CPA Y.WS# IS IT THE STEP # 2 OF A WTSRQ ? JMP TRD03 YES, IGNORE DXT DATA AND B170K ISOLATE OP-CODE. SZA,RSS CLEAR REQUEST IN PROGRESS ? JMP TRD03 YES, GO PROCESS IT. SPC 1 LDA DXTWD AND B13K CHECK IF SOMETHING TO DO : SZA COMPUTE BOOLEAN LDA BIT14 EQUATION: LDB A OK . ( INT + VALDA + CO1 ) LDA DXTWD AND BIT14 ISOLATE BIT OK AND B SZA,RSS ANY PROCESSING TO DO ? JMP TRD04 NO: GET NEXT TERMINAL DATA WORD. * LDA TOFL,I YES: GET OP-CODE/STEP NUMBER WORD AND B170K MASK OUT OP-CODE FIELD CPA B170K IS IT A WAIT FOR SRQ PERIODICALLY ? CCA,RSS YES: DO NOT RE-INIT TIME OUT CLOCK ! CLA NO: SET UP TIME OUT FLAG TO STA TOFL RE-INIT THE TIME OUT CLOCK. SKP TRD03 LDA PTAQU,I PROCESS THIS TERMINAL JSB SETTQ SET LOCAL TEMPORARY EQT SPC 1 IFZ LDB TEQ5 RTE-III CODE ONLY ADB DM4 LDB B,I GET DRIVER LINK WORD FROM EQT1 SSB,RSS IF SIGN BIT SET, LEAVE SYSTEM MAP SZSB,RSS IF NUL, LEAVE SYSTEM MAP JMP TRD37 LEAVE SYSTEM MAP * LDA B CHECK T FIELD IN CONTROL WORD INA LDA A,I GET CONTROL WORD RAL SSA T=1 OR 3 IF BIT15=1 JMP TRD37 T=1 OR 3, LEAVE SYSTEM MAP SLA,RSS JMP TRD32 T=0, GO SET USER MAP * LDA B T=2, GET ID WORD ADA D4 IN SYSTEM CALL LDA A,I SZA,RSS IS IT 0 JMP TRD37 YES, LEAVE SYSTEM MAP * TRD32 LDA B SET USER MAP ADA D2 LDA A,I GET USER BUFFER ADDR. FROM ID TMP WORD CCE,SSA WAS BUFFER MOVED IN SAM ? JMP TRD37 YES, LEAVE SYSTEM MAP * ISZ MAPFL NOW ACTUALLY SET USER MAP ! LDA B GET ID SEGMENT ADDR. JSB $XDMP CALL SYSTEM PROGRAM TO SET USER MAP SZA,RSS IS USER STILL IN PARTITION ? JMP TRD37 NO, USER MAP IS NOT NEEDED UJP TRD37 YES, ENABLE USER MAP TRD37 EQU * XIF SKP JSB GETNW GET NEW WORD TO OUTPUT RSS REQUEST COMPLETED FOR THIS TERMINAL ? JMP TRD05 YES TRD04 LDA CURWD NO, GET CURRENT TERMINAL POINTER LDB CULAT CMB,INB SUBTRACT LAST TERMINAL POINTER ADB A SSB,RSS IS THE CURRENT ONE GREATER ? STA CULAT YES, UPDATE CULAT. LDB PTAQU,I GET NEXT ENTRY IN ACTIVE QUEUE RSS TRD05 LDB PTAQU STB PTAQU SAVE NEW QUEUE POINTER VALUE * LDA CURWD,I SET BIT 15 TO INDICATE NOT IOR BIT15 THE LAST WORD OF DXT STA CURWD,I SPC 1 IFZ SJP TRD51 RE-ENABLE SYSTEM MAP TRD51 EQU * XIF SPC 1 LDA PTAQU RECALL QUEUE POINTER LDB A,I GET NEXT LINK SZB END OF QUEUE ? JMP TRD02 LOOP UNTIL END OF QUEUE. SPC 1 IFZ LDA MAPFL WAS USER MAP CHANGED SZA,RSS DURING THIS PROCESS ? JMP TRD54 NO, RESTORE DMS STATUS ONLY LDA MAPUS YES, RESTORE USER MAP USA TRD54 JRS DMSST TRD56 RESTORE DMS STATUS AND CONTINUE TRD56 EQU * XIF SPC 1 LDA .ACTQ,I IS THE ACTIVE SZA,RSS QUEUE EMPTY ? JMP CMPL3 YES, GO CHECK FOR COMPLETION JSB CMPQ1 NO, IS COMPLETION QUEUE LENGTH > 1 ? TRD07 ISZ STCFL YES, FORCE AN INTERRUPT NEXT POLLING CYCLE JSB SEND AND SEND DATA TO THE CONTROLLER JMP ERR3 CONTROLLER DOESN'T ANSWER, ERROR CONDITION * LDA .COMQ,I BEFORE EXIT CHECK COMPLETION QUEUE SZA ANY COMPLETION PENDING ? JMP CMPLP YES COMPLETE ONE REQUEST. * CY47 ISZ CA47 EXECUTE CONTINUATION EXIT JMP CA47,I RETURN AT (P+2) SKP PTAQU NOP B13K OCT 13000 BIT INT/VALDA/CO1 B170K OCT 170000 OLLAT NOP TOFL NOP SPC 1 IFZ DMSST NOP MAPUS DEF *+1 BSS 32 MAPFL NOP TO KNOW IF USER MAP HAS TO BE RESTORED EXT $XDMP XIF SPC 2 ******************************************************************** * * * COMING FROM THE INITIATOR VIA AN INTERRUPT. * * COMPLETE THE DXT IF NECESSARY AND GET THE WORD * * TO OUTPUT TO THE CONTROLLER. * * * ******************************************************************** SPC 1 TRD09 LDA OLLAT CHECK IF NEW TERMINAL ADDRESS LDB CURWD GREATER CMB,INB THAN CURRENT LAST ACTIVE TERMINAL ADB A ADDRESS SSB,RSS IS THE PREVIOUS ONE GREATER ? JMP TRD03 YES, PROCESS THE REQUEST. LDB IDLCD NO, SET INTERMEDIATE TERMINALS TRD11 INA IN IDLE SATE STA OLLAT UPDATE CURRENT LAST ACTIVE TERMINAL ADDRESS STB A,I CPA CURWD JMP TRD03 THEN PROCESS THE REQUEST JMP TRD11 SKP ******************************************************************** * * * ONE COMPLETION IS PENDING, * * DEQUEUE THE REQUEST AND EXIT THROUGH COMPLETION * * RETURN (P+1). * * * ******************************************************************** SPC 2 CMPL0 EQU * CMPL3 LDB DXTAD SET UP FOR A DUMMY STB CULAT POLLING CYCLE I.E. : LDA IDLCD ONLY ONE TERMINAL (ADDR=1), AND STA B,I THIS TERMINAL IS IN IDLE STATE. JSB CMPQ1 IS COMPLETION QUEUE LENGTH > 1 ? JMP TRD07 YES, START THE DUMMY POLLING CYCLE * LDA .COMQ,I COMPLETION QUEUE LENGTH = 0 OR 1 SZA = 0: COMMING FROM WAITING PROCESS JMP CMPLP = 1: DEQUEUE THIS TERMINAL CLC.6 CLC 0 STOP THE CONTROLLER JMP CY47 EXECUTE CONTINUATION EXIT * CMPLP LDB A,I TO GET THE FIRST TERMINAL STB .COMQ,I IN THE COMPLETION QUEUE CLB EXTRACT IT AND CLEAR STB A,I LINK WORD. ADA DM10 COMPUTE CURRENT EQT1 ADDRESS JSB SETEQ SET SYSTEM EQT TO THE COMPL. RETURN * LDB .ACTQ,I GET ACTIVE QUEUE HEAD LDA .COMQ,I GET COMPL. QUEUE HEAD ADB A SZB,RSS ARE BOTH A&C QUEUES EMPTY ? CLC.2 CLC 0 YES, STOP CONTROLLER * LDB EQT10,I GET TLOG / ERROR INDICATOR LDA EQT9,I GET COMPLETION CODE AND JMP CA47,I EXIT AT (P+1) COMPLETION. SKP ******************************************************************** * ERROR PROCESSING IN THE CONTINUATION SECTION * ******************************************************************** SPC 2 ERR0 EQU * ERROR IN LIA'S SEQUENCE: CLC.3 CLC 0 RESET THE CONTROLLER AND EXIT JMP CY47 IGNORING THE INTERRUPT. SPC 2 ERR3 EQU * ERROR IN OTA'S SEQUENCE: CLC.4 CLC 0 RESELT THE CONTROLLER LDA .ACTQ,I SET EQUIP. MALFUNCTION COMPL. CODE AND SZA,RSS EXIT USING ONE OF THE CURRENT REQUEST, LDA .COMQ,I IF THE ACTIVE QUEUE IS EMPTY USE COMPLETION SZA,RSS THE CONTROLLER IS FAULTY, SO ANY LDA .WSRQ,I IF THE COMPLETION IS EMPTY USE WAITING SZA,RSS ALL QUEUES ARE EMPTY ???? JMP CY47 IT IS NOT POSSIBLE !! ADA DM10 COMPUTE CURRENT EQT1 ADDRESS JSB SETEQ LDA EQT5,I SET ERR. CODE=3 IN THE STATUS AND AND LHALF IN THE IOR D3 STATUS STA EQT5,I WORDS, CLA,INA EQUIPMENT MALFUNCTION CODE IN A LDB BIT15 BIT 15 OF TLOG TO INDICATE ERROR JMP CA47,I SPC 2 CMPQ1 NOP TO CHECK IF THE COMPLETION QUEUE LDB .COMQ,I HAS MORE THAN ONE ELEMENT. SZB,RSS RETURN IS DONE AS FOLLOW: JMP CMPQ2 MORE THAN 1 ELEMENT --> P+1 LDB B,I OTHERWISE --> P+2 SZB,RSS CMPQ2 ISZ CMPQ1 RETURN (P+2) 0 OR 1 ELEMENT. JMP CMPQ1,I RETURN (P+1) MORE THAN ONE ELEMENT. SKP ******************************************************************** * * * S/P: GETNW PUT THE NEW WORD INTO THE DXT * * USING THE OP-COD & STEP-NUM * * * ******************************************************************** SPC 2 GETNW NOP GETN1 LDA TEQ17,I GET OP-COD & TERM# GETN2 ALF AND B17 ISOLATE OP-CODE SZA,RSS CLEAR REQUEST ? JSB C.CL0 YES, VERIFY OK BIT & INTERR. NEXT TIME ADA .OPCT OFFSET INTO OP-COD TABLE LDB A,I SAVE CONTENT IN B LDB B,I GET TABLE ADDR. LDA TEQ17,I AND NBT6 CLEAR COMING FROM INITIATOR FLAG STA TEQ17,I ALF,ALF AND B17 ISOLATE STEP-NUM ADB A OFFSET INTO STEP# TABLE LDA >TB@ E CPB BIT7 IS SRQ LINE TRUE ? JMP C.RD6 YES, COMPLETE IF ASCII & READR & SRQ ENBL. * LDA DXTWD NO SRQ, EXAMINE DATA AND B377 ISOLATE DATA PART SEZ ASCII READ REQUEST ? JMP C.RD3 NO, DON'T CHECK LF & RUB-OUT CODE. AND B177 ASCII REQUEST: CLEAR BIT 7 CPA LINF IS IT LINE-FEED ? JMP C.RDS YES CPA RUBUT IS IT DELETE CODE ? JMP C.RD9 YES, PROCESS IT LDB TEQ10,I IS BYTE COUNT SZB,RSS EXHAUSTED ? JMP SAMST YES, WAIT FOR THE LF SPC 1 C.RD3 EQU * LDB TEQ9,I STORE CHARAC. IN THE USER BUFFER. ISZ TEQ9,I BUMP BYTE POINTER CLE,ERB GET CHARACTER POINTER IN BUFFER SEZ,RSS SHIFT TO UPPER POSITION ALF,ALF STA TEMP1 SAVE CHARACTER LDA RHALF SEZ ADJUST MASK ACCORDING TO PARITY ALF,ALF AND B,I MASK WORD TO GET CHARACTER IOR TEMP1 MERGE WITH THE OTHER BYTE STA TEMP1 SAVE THE DATA WORD TEMPORARILY SEZ,CLE IS THERE TWO BYTES IN THE WORD ? * *-----IF READ A CARD IN IMAGE MODE, PROCESS DATA * JSB IMAGE IT IS A CARD READING OPERATION * *-----STANDARD READING PROCESS * STA B,I SAVE WORD IN USER BUFFER ISZ TEQ10,I BUMP BYTE COUNTER NOP 0 & NOT 0 ARE BOTH OK * LDB TEQ6,I GET REQUEST CONTROL WORD BLF,BLF RBL ASCII/BINARY --> B15 SSB,RSS ASCII REQUEST ? JMP C.RD7 YES, ASCII REQUEST CHECK SFK LDA DXTWD NO, BINARY REQUEST CHECK EOI AND EOI SZA,RSS IS EOI LINE TRUE ? JMP C.RD4 NO: CONTINUE LDA BIT4 YES: SET EOI BIT IN EQT5 JMP C.RDL EOI IS TRUE, COMPLETE. C.RD4 LDA TEQ16,I NOW CHECK TRANSPARENT MODE ELA TRANSPARENT MODE FLAG --> E LDA DXTWD ALF,ALF BIT ATN --> A0 SEZ,RSS TRANSPARENT MODE ENABLED ? JMP C.RD5 NO, NORMAL MODE OF OPERATION SLA,RSS YES, TRANSPARENT MODE, ATN LINE ? JMP C.RD5 ATN LINE NOT TRUE, CHECK FOR BUFFER FULL LDA BIT5 ATN LINE TRUE, COMPLETE THE REQUEST WITH JMP C.RDL STATUS BIT 5 = 1 * C.RD5 LDA TEQ10,I GET BYTE COUNTER SZA IS BUFFER FULL ? JMP SAMST NO, GET NEXT INPUT CHARACTER SSB YES, BUFFER IS FULL, BINARY REQUEST ? JMP C.RDS YES, BINARY RQ & BUFF. FULL --> COMPLETE SEZ,RSS NO, ASCII REQUEST, WHICH MODE ? JMP SAMST ASCII NORMAL MODE --> WAIT FOR LF LDA B17 ASCII TRANSPARENT MODE --> COMPLETE WITH JMP C.RDL STATUS EOR=15(10) * C.RD6 CLA,INA THE TIME OUT MUST NOT BE RESTARTED STA TOFL SET "NO RESTART T.O." FLAG JSB BADG? IS IT A CARD READ OPERATION ? RSS NO: CONTINUE AS USUAL CLE YES: SIMULATES ASCII READ MODE LDA TEQ18,I GET COMPLETION-ON-SRQ FLAG ALF SRQ SFK ----> BIT 15 SEZ,RSS ASCII REQUEST ? SSA,RSS YES, COMPLETION ON SRQ ENA BLED ? JMP SAMST NO, GET NEXT INPUT CHAR. LDA D1 ASCII REQUEST WITH COMPLETION ON SRQ JMP C.RDL ENABLED, COMPLETE WITH STATUS EOR=1 * C.RD7 LDA TEQ16,I AND SFKM SZA,RSS TERMINATION ON SFK ENABLED ? JMP C.RD4 NO LDA DXTWD YES, RECALL DXT WORD AND B177 ISOLATE CHARACTER ADA MSFK1 AND CHECK IF IT IS A SFK SSA OCTAL CODE < 20B ? JMP C.RD4 YES: NOT AN SFK ADA M#SFK OCTAL CODE > 31B ? SSA,RSS JMP C.RD4 YES: NOT AN SFK * ADA TSFKT INDEX IN BIT TABLE LDA A,I AND GET PROPER BIT AND TEQ16,I MASK OUT IN EQT16 SZA,RSS SET ? JMP C.RD4 NO, CONTINUE * LDA DXTWD YES: SET END-OF-RECORD INDICATOR IN STATUS AND B177 THE EOR BEING THE SFK NUMBER ADA MSFK1 ADA D2 CCB REMOVE SFK CODE ADB TEQ9,I FROM THE USER BUFFER STB TEQ9,I DECREMENT BYTE POINTER CCB ADB TEQ10,I STB TEQ10,I DECREMENT BYTE COUNTER SPC 1 C.RDL IOR TEQ5,I MERGE EOR INDICATOR IN STATUS WORD STA TEQ5,I AND STORE IT BACK. C.RDS LDB TEQ9,I GET BUFFER POINTER CLE,ERB COMPUTE WORD ADDRESS LDA B,I GET LAST CHARACTER * *-----PROCESS END OF READING OPERATION * AND LHALF KEEP UPPER HALF ONLY IOR B40 COMPLETE WITH SPACE IN LOWER SEZ IF NEEDED ? STA B,I YES JSB T.LOG COMPUTES THE T.LOG JMP NEWST SET TERMINAL IN NEXT STATE. SPC 1 C.RD9 JSB BFSET PROCESS CANCEL LINE NOP RESET POINTER & BYTE COUNT JMP SAMST LEAVE TERMINAL IN THE SAME STATE SPC 1 C.TES LDA TEQ6,I MODE OF READING AND BIT7 MASK OUT BIT 7 LDB TEQ17,I GET OP-CODE/STEP NUMBER SZA --- GET --- ? JMP C.TE1 YES: IS IT A 3070B ? C.TE0 ADB BIT10 NO: SKIP GET COMMAND STB TEQ17,I PREPARE THE FOLLOWING STEP JMP GETN1 GO TO NEXT STEP ˯* C.TE1 JSB AORB? IS IT A 3070B ? JMP C.TE0 CONTINUE JMP NEWST PROCESS NEXT STEP SPC 2 #SFK EQU 10 10 SPECIAL FUNCTION KEYS SFK1 EQU 20B M#SFK ABS -#SFK MSFK1 ABS -SFK1 * SFKM OCT 77740 MSLF OCT 10012 INT,LF ARROW OCT 10137 INT,'_' LINF OCT 12 LHALF OCT 177400 RHALF OCT 000377 SPC 2 ******************************************************************** * CONTINUATION OF A WRITE/READ REQUEST * ******************************************************************** SPC 1 C.HB0 LDB TEQ7,I GET USER BUFFER ADDRESS INB COMPUTE INPUT BUFFER LENGTH ADDRESS LDA B,I GET INPUT BUFFER LENGTH STA TEQ8,I UPDATE SYSTEM BUFFER LENGTH EQT JSB NGTIF COMPUTE BYTE LENGTH SZA IS IT ZERO ? JMP C.HB1 NO: CONTINUE PROCESSING LDA TEQ16,I YES: GET TERMINAL MODE OF OPERATION SSA NORMAL OR TRANSPARENT MODE ? JMP ENDST TRANSPARENT: COMPLETE JMP C.SP5 NORMAL: COMPLETE AFTER GETTING SRQ STATE. * C.HB1 STA TEQ10,I RESTORE BYTE COUNTER LDA TEQ9,I GET INPUT BYTE POINTER SLA POINTS AT UPPER BYTE ? ISZ TEQ9,I NO: INCREMENT IT LDA TEQ9,I GET INPUT BYTE POINTER RAR COMPUTE INPUT BUFFER ADDRESS STA TEQ7,I UPDATE SYSTEM BUFFER ADDRESS EQT LDA TEQ16,I YES: GET MODE OF OPERATION OF TERMINAL LDB OPRDX GET TRANSPARENT OP-CODE/STEP NUMBER SSA NORMAL OR TRANSPARENT ? JMP C.HB2 TRANSPARENT: PREPARE TRANSPARENT OP-CODE LDB OPRD NORMAL: GET NORMAL MODE READ OP-CODE JSB BADG? BADGE CARD READER OPERATION ? JMP C.HB2 NO: PREPARE NORMAL READ ON KEYBOARD LDB OPCAR YES: GET CARD READER OP-CODE * C.HB2 LDA TEQ17,I GET OP-CODE STEP NUMBER EQT17 AND RHALF CLEAR OP-CODE/STEP NUMBER IOR B MERGE WITH NEW OP-CODE/STEP NUMBER AND NBT6 CLEAR COMMING FROM INITIATOR BIT STA TEQ1S AND NBT7 CLEAR BIT 7 JMP C.W60 MERGE WITH ATN HP-IB LINE * *-----CONTINUE STANDARD PROCESS * C.W51 LDB TEQ6,I CHECK BIT:X & BIT:M BLF,RBL ELB,BLF SEZ,RSS CHECK BIT:X ? JMP C.W52 BIT:X=0, NORMAL WRITE C.W60 IOR ATN BIT:X=1, COMMAND MODE, MERGE ATN ISZ TEQ10,I BUMP BYTE COUNTER JMP HOLST NOT THE LAST CHAR. JMP INCST LAST CHAR., EXIT NEXT TIME * * C.W52 ISZ TEQ10,I BUMP BYTE COUNT JMP HOLST NOT THE LAST CHAR. OUTPUT IT SLB LAST CHAR., CHECK ASCII/BINARY MODE JMP C.W53 BINARY RECORD CPA ARROW ASCII RECORD, TEST THE LAST CHAR. JMP NEWST EXIT NOW WITHOUT SENDING THIS CHAR. JMP HOLST OUTPUT THE LAST CHAR. C.W53 IOR EOI BINARY RECORD, MERGE EOI WITH JMP INCST THE LAST CHAR., AND EXIT NEXT TIME. * C.W55 LDB TEQ6,I MUST BE NORMAL ASCII MODE. BLF,RBL ELB,BLF SLB BINARY RECORD ? JMP NEWST YES: DO NOT SEND A SEZ COMMAND MODE OR WRITE/READ ? JMP C.W57 YES: CHECK FOR WRITE/READ C.W56 LDA MSLF NO: ASCII WRITE JMP INCST OUTPUT LINE-FEED * C.W57 LDA TEQ17,I GET OP-CODE/STEP NUMBER AND B170K MASK OUT OP-CODE CPA OWRAK IS IT A WRITE/READ ? JMP C.W56 YES: ASCII, SEND A LINE-FEED JMP NEWST NO: COMMAND MODE. * * OWRAK OCT 160000 IDENTIFIER FOR WRITE/READ OP-CODE SPC 3 ******************************************************************** * CONTINUATION OF A CLEAR REQUEST * ******************************************************************** SPC 1 C.CL0 NOP ISZ STCFL SET TO INTERRUPT NEXT POLLING CYCLE LDB TEQ17,I CHECK IF COMMING FROM INITIATOR BLF,BLF ROTATE TO TEST RBL BIT 6 SSB COME FROM INITIATOR ? JMP C.CL0,I YES, RETURN LDA DXTWD NO, RECALL DXT WORD AND BIT14 MASK OUT TERMINAtL ACKNOWLEDGMENT SZA GOOD ANSWER ? CLA,RSS YES, EXIT WITH A=0 RSS BAD ANSWER, RETRY JMP C.CL0,I ISZ TEQ9,I MORE RETRIES ? JMP SAMST YES, RETRANSMIT SAME DATA LDA D3 NO, RETURN WITH LDB D2 A=3 AND STATUS ERR=2 SPC 1 C.ER0 STA TEQ9,I SET COMPLETION CODE LDA BIT15 SET BIT15 IN TLOG TO SIGNAL ERROR STA TEQ10,I C.ER1 LDA TEQ5,I MERGE IN STATUS THE STATUS ERR. CODE AND LHALF IOR B STA TEQ5,I LDB TEQ16,I GET THE TRANSPARENT MODE FLAG SSB IS TRANSPARENT MODE ENABLED ? JMP ENDST YES, DON'T SET THE SYSTEM ERROR JMP ENDSA NO, LET SYSTEM HANDLE THE ERROR. SKP ********************************************************************** * CONTINUATION OF SERIAL POLL. * ********************************************************************** SPC 1 C.SP LDA DXTWD RECALL DXT WORD ALF,RAL CHECK IF IT IS DATA SSA,RSS IS VALDA BIT SET ? JMP SAMST NO, IGNORE THIS WORD ALF ROTATE AGAIN TO POSITION BIT 6 SSA IS BIT 6 (DIO-7) SET ? JMP C.SP6 YES, THIS TERMINAL HAD AN SRQ PENDING * ISZ TEQ10,I END OF ADDR. TABLE ? JMP C.SP4 NO, CONTINUE. LDA B37 YES, GET ADDR=37B (MEANS NO ANSWER JMP C.SP7 TO THIS SERIAL POLL) AND COMPLETE. * C.SP4 ISZ TEQ9,I BUMP WORD POINTER LDA TEQ17,I CONTINUE ADA MST3 DECREMENT THE STEP-NUM. STA TEQ17,I TO LOOP ON LAST 2 STEPS JMP NEWST AND GO TO OUTPUT THE NEXT WORD. * C.SP6 LDA TEQ9,I THIS IS THE ADDR. OF THE STATION LDA A,I AND B37 C.SP7 IOR TEQ5,I MERGE IN STATUS STA TEQ5,I CLA CLEAR TLOG WORD STA TEQ10,I JMP NEWST COMPLETE AFTER SENDING SPD SPC 1 C.SP5 LDB Y.SP# GET SPECIAL OP-COD & STEP-NUM C.SP8 ISZ STCFL SET TO INTERRUPT NEXT POLLING CYCLE _ LDA TEQ17,I SET SPECIAL OP-COD & STEP-NUM TO AND RHALF BYPASS CHECKING OF THE BOOLEAN IOR B EXPRESSION AND DO ONE MORE STA TEQ17,I POLLING CYCLE TO CHECK THE JMP INPST SRQ LINE. * C.SP9 LDA DXTWD SINCE THE INTERRUPT HAS BEEN FORCED AND BIT14 CHECK THE TERMINAL ACKNOWLEDGEMENT SZA,RSS IS IT ALL RIGHT JMP NOCST NO, DON'T CHANGE DXT WORD, RETRANSMIT JSB SRQ? YES, CHECK SRQ, UPDATE STATUS BIT 7 JMP NEWST AND COMPLETE. * MST3 DEC -768 MINUS 3 STEP (3 * 256) STCFL NOP TEMP1 NOP SKP ******************************************************************** * CONTINUATION OF GET STATUS BYTE * ******************************************************************** SPC 1 C.GSB LDA DXTWD RECALL DXT WORD ALF,RAL IS IT DATA SSA,RSS BIT VALDA SET ? JMP SAMST NO, IGNORE THIS WORD LDA DXTWD RECALL DXT WORD AND RHALF ISOLATE STATUS BYTE IOR TEQ5,I AND PUT IT INTO THE SATUS STA TEQ5,I LDA TEQ9,I GET HP-IB STATION ADDRESS CPA D.LKA IS IT THE TERMINAL 3070 ? JSB HARDW YES: UPDATE HARDWARE TERMINAL STATUS EQT18 JMP NEWST AND COMPLETE. SPC 2 ******************************************************************** * CONTINUATION OF CHECK SRQ * ******************************************************************** SPC 1 C.CSR LDB Y.CS# GET SPECIAL OP-COD & STEP-NUM JMP C.SP8 AND SET IT INTO EQT17 SPC 1 C.CSS JSB SRQ? UPDATE STATUS WORD AND JMP NEWST EXIT. SPC 2 ******************************************************************** * CONTINUATION OF CHECK SRQ PERIODICALLY * ******************************************************************** SPC 1 C.WSQ LDB Y.WS# INTERRUPT AFTER NEXT POLLING CYCLE JMP C.SP8 IN ORDER TO GET THE TERMINAL STATUS SPC 1 C.WS0 JSB SRQ? CHECK SRQ LINE & UPDATE STATUS BIT 7 CPB BIT7 SRQ PRESENT ? RSS YES: GET STATUS BYTE JMP C.WS4 NO: PUT TERMINAL IN WAITING QUEUE LDA TEQ17,I GET OP-CODE/STEP NUMBER WORD AND B277 MASK OUT TERMINAL NUMBER AND REN BIT IOR OPGSB MERGE WITH GET STATUS BYTE OP-CODE AND NBT6 CLEAR COMMING FROM INITIATOR BIT STA TEQ17,I RESET OP-CODE/STEP NUMBER WORD LDA D.LKA GET DEFAULT TALKER ADDRESS STA TEQ9,I SET UP STATION TO BE POLLED JMP NEWST PROCESS THE GET STATUS BYTE * C.WS4 JSB LOEQT B = ADDRESS OF DUMMY EQT7 CLA A = 0 ADB D7 COMPUTE DUMMY EQT14 ADDRESS STA B,I CLEAR THIS TIME OUT !!!!!!! ADB DM7 COMPUTE ADDRESS OF DUMMY EQT7 LDA B,I GET TIME OUT VALUE ADB D8 COMPUTE EQT15 ADDRESS OF DUMMY EQT STA B,I RESTART THE DUMMY EQT TIME CLOCK * LDA TEQ17,I GET OP-CODE/STEP NUMBER WORD AND B277 MASK OUT TERMINAL NUMBER AND IOR OPWTQ MERGE OP-CODE WITH "COMMING FROM INIT." BIT STA TEQ17,I TO START AT THE BEGENNING LDA .WSRQ GET WAITING QUEUE HEAD ADDRESS JMP ENDSB RE-INSERT TERMINAL IN WAITING QUEUE SPC 2 ******************************************************************** * CONTINUATION OF WAIT UNTIL SRQ * ******************************************************************** SPC 1 C.WSR JSB SRQ? CHECK SRQ LINE & UPDATE STATUS BIT 7 CPB BIT7 SRQ PRESENT ? JMP NEWST YES, COMPLETE JMP SAMST NO, CONTINUE LOOPING. SPC 2 SRQ? NOP LDA DXTWD RECALL DXT WORD AND B13K ISOLATE CONTROL BIT CLB B WILL HOLD SRQ STATE CPA SRQ IS SRQ SET (VALDA=0 IF SRQ) ? LDB BIT7 YES, SET B REG. BIT 7 = 1 CPA B3000 IS EOI SET ? LDB BIT4 YES, SET B REG. BIT 4 = 1 LDA TEQ5,I SET BIT 7 OF STATUS IOR B IF SRQ LINAB@ 1023XX STA SFS.2 ADA B400 STA STCH1 1027XX STA STCH2 STA STCH3 IOR B1000 STA STC.1 1037XX XOR B200 STA LIAC1 1035XX ADA B100 STA OTA.1 1036XX XOR B5100 STA CLC.1 1067XX STA CLC.2 STA CLC.3 STA CLC.4 STA CLC.5 STA CLC.6 STOP THE CONTROLLER FOR WAITING QUEUE JMP SETIO,I * STF.0 STF 0 B5100 OCT 5100 SPC 2 SETTQ NOP SET TEMPORARY EQT TEQXX CPA TEQ11 IF ALREADY SET JMP SETTQ,I DON'T SET THEM AGAIN ADA =D-7 COMPUTES EQT4 ADDRESS STA TEQ4 COPY EQT4 ADDRESS INA STA TEQ5 COPY EQT5 ADDRESS INA STA TEQ6 COPY EQT6 ADDRESS INA STA TEQ7 COPY EQT7 ADDRESS INA STA TEQ8 COPY EQT8 ADDRESS INA STA TEQ9 COPY EQT9 ADDRESS INA STA TEQ10 COPY EQT10 ADDRESS INA STA TEQ11 COPY EQT11 ADDRESS INA STA TEQ12 COPY EQT12 ADDRESS ADA D2 STA TEQ14 COPY EQT14 ADDRESS INA STA TEQ15 COPY EQT15 ADDRESS ADA M2 COMPUTE EQT13 ADDRESS LDB A,I GET EQT16 ADDRESS STB TEQ16 COPY EQT16 ADDRESS INB STB TEQ17 COPY EQT17 ADDRESS INB STB TEQ18 COPY EQT18 ADDRESS JMP SETTQ,I SPC 3 AORB? NOP SUBROUTINE TO CHECK TERMINAL REVISION LDA TEQ18,I GET EQT18 WORD SSA IS IT A 3070A TERMINAL: ---> P+1 ISZ AORB? NO: RETURN IN ---> P+2 JMP AORB?,I RETURN SPC 3 HARDW NOP SUBROUTINE TO UPDATE HARDWARE TERMINAL STATUS LDA DXTWD RECALL DXT WORD ALF,RAL IS IT DATA SSA,RSS BIT VALDA SET ? JMP HARDW,I NO: IGNORE THIS WORD LDA DXTWD YES: RECALL DXT WORD AND D7 MASK OUT HARDWARE BITS RAR,RAR MOVE THESE BITS IN BITS RAR 15=PRINTER, 14=READER, 13=3070B STA B SAVE A REGISTER TEMPORARILLY LDA TEQ18,I GET EQT18 WORD AND STATU CLEAR HARDWARE STATUS BYTE IOR B MERGE WITH NEW STATUS STA TEQ18,I AND UPDATE HARDWARE STATUS WORD JMP HARDW,I RETURN * STATU OCT 17777 MASK TO CLEAR BITS 15, 14 & 13 SPC 3 NGTIF NOP SUBROUTINE TO COMPUTE BYTE LENGTH CMA,SSA,INA CONVERT TO NEGATIVE FORM ALS,SLA IF IT IS NOT CMA,INA ALREADY DONE JMP NGTIF,I RETURN SPC 1 T.LOG NOP COMPUTES THE T.LOG LDB TEQ8,I GET REQUESTED BUFFER LENGTH LDA TEQ10,I GET BYTE COUNT INA TO COMPUTE T.LOG SSB,RSS ARS CONVERT IT INTO WORD OR SSB CHARACTERS AS IT WAS REQUESTED, CMB AND SET IT POSITIVE. ADB A B=T.LOG STB TEQ10,I SAVE THIS T.LOG IN EQT10 JMP T.LOG,I RETURN SKP LOEQT NOP Ha GET EQT7 ADDRESS OF DUMMY EQT LDB TEQ12,I GET DUMMY EQT13 ADDRESS ADB DM6 COMPUTE DUMMY EQT7 ADDRESS JMP LOEQT,I RETURN SPC 2 SETP. NOP SET UP LOCAL POINTERS ADB M1 COMPUTE DUMMY EQT12 ADDRESS STB .ACTQ SET ADDRESS OF FIRST WORD OF ACTIVE QUEUE. INB COMPUTE DUMMY EQT13 ADDRESS LDB B,I COMPUTE DUMMY EQT16 ADDRESS STB .COMQ SET ADDRESS OF FIRST WORD OF COMPLETION QUEUE. ADB D2 COMPUTE DUMMY EQT18 ADDRESS STB .WSRQ SET ADDRESS OF FIRST WORD OF WAITING QUEUE. JMP SETP.,I RETURN SPC 1 SELEC NOP TEMPORARY BUFFER FOR SELECT CODE .ACTQ NOP .COMQ NOP .WSRQ NOP ADDRESS OF FIRST WORD OF WAITING QUEUE SKP ******************************************************************** * SPECIAL SUBROUTINE FOR BADGE CARD READER * ******************************************************************** SPC 2 BACA0 LDA TEQ18,I GET EQT18 WORD AND BIT3 MASK OUT BIT 3 SZA IMAGE MODE ? JMP BAC.0 NO: ASCII MODE LDA TEQ10,I YES: GET NUMBER OF BYTES TO READ SLA IS IT EVEN ? INA NO: DECREMENT IT !!!!!! STA TEQ10,I UPDATE BYTE COUNTER LDB TEQ8,I GET BUFFER LENGTH SSB IS IT BYTE LENGTH ? STA TEQ8,I YES: UPDATE PASSED LENGTH BAC.0 LDA TEQ18,I GET EQT18 WORD CONTENT AND B37 MASK OUT READER CONTROL WORD IOR COMD SET -/1/0/INT/ATN/SECONDARY COMMAND./ JMP INCST INCREMENT STEP-NUMBER FOR NEXT TIME. * COMD OCT 110540 1/0/INT/ATN/SECONDARY COMMAND./ SPC 1 BACA1 LDA TEQ16,I GET TRANSPARENT MODE FLAG IN BIT 15 SSA TRANSPARENT MODE ? JMP ENDST YES: COMPLETE IMMEDIATLY JMP NEWST NO: PROCESS NEXT STEP SPC 2 IMAGE NOP SUBROUTINE IMAGE/DEPACK JSB BADG? IS IT A CARD READING OPERATION ? RSS NO: RETURN IMMEDIATLY JMP IMAG1 YES:AN CHECK FOR IMAGE MODE IMAG0 LDA TEMP1 NO: RESTORE A REGISTER JMP IMAGE,I RETURN * IMAG1 LDA TEQ18,I GET IMAGE/ASCII MODE AND BIT3 OF READING SZA IMAGE MODE ? JMP IMAG0 NO: ASCII MODE * LDA TEMP1 GET THE DATA WORD ALF,ALF LOWER BYTE <---> UPPER BYTE AND B77 MASK OUT ROWS 3 ---> X R STA TEMP2 SAVE IT TEMPORARILY LDA TEMP1 GET THE DATA WORD AND B77 MASK OUT UPPER BYTE ALF,ALF LOWER BYTE <---> UPPER BYTE RAR,RAR MOVE BYTE IN RIGHT POSITION IOR TEMP2 BUILD THE IMAGE OF THE COLUMN JMP IMAGE,I RETURN SPC 2 BADG? NOP SUBROUTINE: IS IT A CARD READ ? LDA TEQ6,I GET OPERATION CODE AND BIT9 MASK OUT READER BIT 9 SZA,RSS IS IT A READ CARD OPERATION ? JMP BADG?,I NO: RETURN IN P+1 JSB CARD? YES: IS THERE A READER ? JMP BADG?,I NO: RETURN IN P+1 ISZ BADG? YES: INCREMENT RETURN ADDRESS JMP BADG?,I READER OPERATION ---> P+2 SPC 3 CARD? NOP SUBROUTINE TO CHECK READER/EQT STATUS LDA TEQ18,I GET EQT18 WORD RAL PUT READER BIT IN A REG. BIT 15 SSA READER HERE ? ISZ CARD? YES: RETURN IN P+2 JMP CARD?,I RETURN SPC 3 ******************************************************************* * SPECIAL SUBROUTINE FOR PRINTER * ******************************************************************* SPC 2 PRITR LDB TEQ17,I GET OP-CODE/STEP NUMBER ADB B400 INCREMENT STEP NUMBER LDA TEQ6,I GET REQUEST CODE AND BIT9 MASK OUT BIT 9 SZA,RSS WRITE ON PRINTER ? JMP PRIT0 NO: SKIP NEXT STEP * LDA TEQ18,I YES: GET HARDWARE STATUS SSA,RSS IS THERE A PRINTER PRIT0 ADB B400 NO: SKIP NEXT STEPS STB TEQ17,I PREPARE NEXT TASK JMP GETN1 CONTINUE HED TABLE, CONSTANTS & VARIABLE AREA. **********************&********************************************** * DATA DEFINITIONS (TABLES DEFINITION) * ******************************************************************** SPC 2 A EQU 0 B EQU 1 SPC 1 EQTA EQU 1650B EQT# EQU EQTA+1 INTAB EQU 1654B SPC 2 COFAD DEF *+1,I DEF CL 0 DEF EOR 1 DEF RENB 2 DEF RDI 3 DEF TC 4 DEF WTSRQ 5 CHECK SRQ PERIODICALLY DEF CARSP 6 SET EQT 19 WITH CARD READER CTRL. WORD DEF CKSRQ 7 DEF WSRQ 10 DEF GSB 11 DEF TSFK 12 DEF TM 13 DEF NM 14 DEF IFC 15 SET IFC LINE TRUE THEN FALSE DEF ILRQ 16 DEF ILRQ 17 DEF ILRQ 20 DEF ILRQ 21 DEF STO 22 COFED DEF * SPC 1 .OPCT DEF *+1 DEF X.CL (0) CLEAR REQUEST DEF X.RD (1) READ DEF X.WR (2) WRITE DEF X.SP (3) SERIAL POLL DEF X.REN (4) REMOTE ENABLE DEF X.WSR (5) WAIT UNTIL SRQ RECEIVED DEF X.TO (6) DEVICE HAS TIMED OUT DEF X.EOR (7) ISSUE END OF RECORD DEF X.RDX (8) TRANSPARENT MODE READ DEF X.WRX (9) TRANSPARENT MODE BINARY WRITE DEF X.RDS (10) REMOTE DISABLE DEF X.GSB (11) GET STATUS BYTE DEF X.CSR (12) CHECK ON SRQ DEF X.TSK (13) SFK TERMINATOR FOR 3070B DEF X.WCR (14) WRITE COMMAND/READ BINARY DEF X.WSQ (15) CHECK SRQ PERIODICALLY SKP * BIT15 = 0 S/P ADDR. * BIT15 = 1 DATA WORD, CHECK BIT 14-13 * BIT14-13=0 DON'T MERGE. * BIT14-13=1 MERGE TALK ADDR. (TEQ12[4:0]) * BIT14-13=2 MERGE WITH CONTENT OF TEQ9,I SPC 1 X.CL DEF *+1 CLEAR REQUEST CONTROL TABLE OCT 114000 0 -/1/0/INT/IFC/ OCT 110000 1 -/1/0/INT/ OCT 110424 2 -/0/0/INT/ATN/DCL/ DEF ENDST 3 -/0/END...  OCT 114000 4 -/1/0/INT/IFC/ OCT 110000 5 -/1/0/INT/ DEF ENDST 6 -/0/END... * X.RD DEF *+1 OCT 110475 0 -/1/0/INT/ATN/CONF-LST.DISPLAY./ OCT 110476 1 -/1/0/INT/ATN/CONF-LST.MOD-COM./ OCT 130500 2 -/1/1/INT/ATN/CONF-TAK./ DEF PUIST 3 -/0/PUT TERMINAL IN INPUT STATE./ DEF C.RD0 4 -/0/READ PROCESS./ OCT 110537 5 - /1/0/INT/ATN/UNCONF-TALK./ DEF C.TES 6 - /0/GET COMMAND ?./ OCT 110475 7 - /1/0/INT/ATN/CONF-LST.DISPLAY./ OCT 110576 8 - /1/0/INT/ATN/SECONDARY COMMAND GET./ OCT 110477 9 - /1/0/INT/ATN/UNLISTEN./ DEF C.SP5 10 -/0/GO TO CHECK SRQ ... * X.RDX DEF *+1 TRANSPARENT MODE READ OCT 110537 0 -/1/0/INT/ATN/UNTALK./ OCT 110474 1 -/0/1/INT/ATN/CONF-LST.READER./ DEF BACA0 2 -/0/CONFIGURE BADGE CARD READER./ OCT 110476 3 -/1/0/INT/CONF-LST.MOD-COM./ OCT 110534 4 -/1/0/INT/CONF-TLK.READER./ DEF PUIST 5 -/0/PUT TERMINAL IN INPUT STATE./ DEF C.RD0 6 -/0/READ PROCESS./ DEF BACA1 7 -/0/END... OR COMPLETE CARD READING. OCT 110537 8 -/1/0/INT/ATN/UNCONF-TALK./ DEF C.SP5 9 -/0/GO TO CHECK SRQ .../ * X.WR DEF *+1 WRITE CONTROL TABLE OCT 110475 0 -/1/0/INT/ATN/CONF-DISPLAY-LST./ OCT 110537 1 -/1/0/INT/ATN/UNCONF-TAK./ DEF PRITR 2 -/0/WRITE ON PRINTER OR DISPLAY ?./ OCT 110473 3 -/1/0/INT/ATN/LST-PRINTER./ DEF C.WR4 4 -/0/WRITE INITIALIZE/ DEF C.WR5 5 -/0/WRITE PROCESS./ DEF C.TES 6 -/0/GET COMMAND ?./ OCT 110475 7 -/1/0/INT/ATN/LST-DISPLAY./ OCT 110576 8 -/1/0/INT/ATN/SECONDARY COMMAND GET./ OCT 110477 9 -/1/0/INT/ATN/UNLISTEN./ DEF C.SP5 10 -/0/GO TO CHECK SRQ ... * X.WRX DEF *+1 TRANSPARENT/COMMAND MODE WRITE DEF C.WR4 0 -/0/WRITE INITIALIZE/ DEF C.WR5 1 -/0/WRITE PROCESS./ DEF ENDST 2 - 0/END .../ * X.SP DEF *+1 SERIAL POLL CONTROL TABLE OCT !110477 0 -/1/0/INT/ATN/UNLISTEN/ OCT 110537 1 -/1/0/INT/ATN/UNCONF-TAK./ OCT 110476 2 -/1/0/INT/ATN/CONF-LST.MOD-COM./ OCT 110430 3 -/1/0/INT/ATN/SPE/ OCT 150500 4 -/1/2/INT/ATN/CONF.TALK/ DEF PUIST 5 -/0/PUT TERMINAL IN INPUT/ DEF C.SP 6 -/0/SERIAL POLL LOOP PROCESS./ OCT 110537 7 -/1/0/INT/ATN/UNCONF-TAK./ OCT 110431 10-/1/0/INT/ATN/SPD/ DEF C.SP5 11-/0/PUT IN INPUT STATE, INTR NEXT TIME./ DEF C.SP9 12-/0/CHECK IF SRQ STILL THERE/ DEF ENDST 13-/0/END... * X.REN DEF *+1 ENABLE REMOTE CONTROL TABLE. OCT 112400 0 -/1/0/INT/REN/ATN/ DEF ENDST 1 -/0/END... * X.CSR DEF *+1 CHECK FOR SRQ OCT 110537 0 -/1/0/INT/ATN/UNCONF-TAK./ DEF C.CSR 1 -/0/PUT IN INPUT STATE, INTR. NEXT TIME./ DEF C.CSS 2 -/0/CHECK ON SRQ PROCESS./ DEF ENDST 3 -/0/END... * X.WSR DEF *+1 WAIT UNTIL SRQ CONTROL TABLE OCT 110537 0 -/1/0/INT/ATN/UNCONF-TAK./ DEF PUIST 1 -/0/PUT TERMINAL IN INPUT STATE./ DEF C.WSR 2 -/0/WAIT UNTIL SRQ PROCESS./ DEF ENDST 3 -/0/END... * X.EOR DEF *+1 ISSUE END OF RECORD OCT 111000 0 -/1/0/INT/EOI/ OCT 110000 1 -/1/0/INT/ DEF ENDST 2 -/0/END... * X.RDS DEF *+1 DISABLE REMOTE CONTROL TABLE OCT 110400 0 -/1/0/INT/ATN/ DEF ENDST 1 -/0/END... * X.TO DEF *+1 DEVICE HAS TIMED OUT DEF TO50 0 -/0/TIME OUT PROCESS./ DEF ENDST 1 -/0/END... * X.GSB DEF *+1 GET STATUS BYTE OCT 110477 0 -/1/0/INT/ATN/UNLISTEN/ OCT 110537 1 -/1/0/INT/ATN/UNCONF-TALK./ OCT 110476 2 -/1/0/INT/ATN/CONF-LST.MOD-COM./ OCT 110430 3 -/1/0/INT/ATN/SPE/ OCT 150500 4 -/1/2/INT/ATN/CONF.TALK/ DEF PUIST 5 -/0/PUT TERMINAL IN INPUT/ DEF C.GSB 6 -/0/GET STATUS BYTE PROCESS./ OCT 110537 7 -/1/0/INT/ATN/UNCONF-TAK./ OCT 110431 10-/1/0/INT/ATN/SPD/ DEF ENDST 13-/0/END... * X.TSK DEfF *+1 SET OR CLEAR SFK AS TERMINATOR (3070B) OCT 110475 0 -/1/0/INT/ATN/CONF-LST.DISPLAY./ OCT 150540 1 -/1/2/INT/ATN/SECONDARY COMMAND/. DEF ENDST 2 -/0/END... * X.WCR DEF *+1 WRITE/READ OCT 110537 0 -/1/0/INT/ATN/UNCONF-TALK./ OCT 110475 1 -/1/0/INT/ATN/CONF-LST.DISPLAY./ DEF C.WR5 2 - /0/WRITE PROCESS./ DEF C.HB0 3 - /0/PREPARE READ PROCESS./ DEF ENDST 4 - /0/END... * X.WSQ DEF *+1 WAIT SRQ PERIODICALLY OCT 110537 0 -/1/0/INT/ATN/UNCONF-TAK./ DEF C.WSQ 1 -/0/PROCESS THE REQUEST./ DEF C.WS0 2 -/0/CHECK TERMINAL ACK.& IDLE STATE./ DEF ENDST 3 -/0/END... * SKP DXTAD DEF *+1 DATA TRANSFERT TABLE. BSS 63 FOR 63 TERMINALS ON THE LINK DXT.D DEF * LIMIT POINTER FOR DXT TABLE SPC 1 * BIT TABLE FOR SFK TERMINATE A READ. * BIT5 OCT 40 BIT6 OCT 100 BIT7 OCT 200 BIT8 OCT 400 BIT9 OCT 1000 BIT10 OCT 2000 BIT11 OCT 4000 BIT12 OCT 10000 BIT13 OCT 20000 BIT14 OCT 40000 FOF SFK # 11 TSFKT DEF * INDEX IS NEGATIVE !!!! SPC 1 BIT15 OCT 100000 NBT7 OCT 177577 MASK TO CLEAR BIT 7 NBT9 OCT 176777 MASK TO CLEAR BIT 9 NBT11 OCT 173777 NBT15 OCT 77777 SPC 3 *---------------HP-IB CONTROL LINES SPC 1 INT EQU BIT12 ATN EQU BIT8 EOI EQU BIT9 SRQ EQU BIT9 REN EQU BIT10 SPC 3 Y.SP# OCT 035000 (OP-COD=3, STEP-NUM=12) Y.CS# OCT 141000 (OP-COD=12,STEP-NUM=2) Y.WS# OCT 171000 (OP-CODE=15,STEP-NUM=2) SPC 2 D1 DEC 1 M1 DEC -1 M2 DEC -2 B32 OCT 32 INITIALIZED CTRL. WORD FOR READER B37 EQU D31 B77 OCT 77 B100 EQU BIT6 B177 OCT 177 B377 OCT 377 MASK FOR BINARY READ OPERATIONS B200 EQU BIT7 B400 EQU BIT8 B1000 EQU BIT9 B40 EQU BIT5 SPACE CODE BIT3 EQU D8 MASK FOR BIT 3 RUBUT EQU B177 NBT0 EQU M2 MASK TO CLEAR BIT 0 SKP * SPC 2 * DEFINE EQT WORDS POINTERS * EQT1 EQU 1660B (EQT1) EQT4 EQB@ 1 = GET BYTE * => 2 = PUT BYTE * IBUF => BUFFER START ADDRESS. * INDEX => ITEM NUMBER TO BE ACCESSED (FIRST=1) * IVAL => INTEGER VALUE (RETURNED IF GET, * SUPPLIED IF PUT) * LENGRP => BYTE LENGTH (RANGES FROM 1 TO 16) * * * * * THIS ROUTINE STORES OR GETS A 'BYTE' IN OR OUT A BUFFER. * THE BYTE-LENGTH CAN BE FIXED TO ANY LENGTH BETWEEN * 1 AND 16.(LIMITS INCLUDED) * EXECUTION TIME IS LESS THAN 260 MICRO SECS (21MX) * * * PROGRAMMED: VAN DEN BOSSCHE MARC DEC 6-1-1977 * * HP BRUSSELS * * A EQU 0 B EQU 1 ARW DEF LOCAT MASK NOP NMASK NOP LOCAT NOP * * * RW NOP ABUF NOP INDEX NOP IVAL NOP GRPL NOP BITS NOP LDB ARW LDA =D-6 STA R1 L. LDA BITS,I ISZ BITS SSA,RSS JMP *+4 ELA,CLE,ERA LDA A,I JMP *-4 STA B,I INB ISZ R1 JMP L. LDA LOCAT STA BITS LDA GRPL,I AND =B17 IOR RRL STA *+3 CLA CCB DATA NOP STA MASK CMA STA NMASK CMA AND IVAL,I STA DATA LDA INDEX,I MPY GRPL,I DIV =D16 ADA =D-1    ADA ABUF STA LOCAT RRL RRL 16 SZA IOR RRL STA R1 STA R3 SZA XOR =B1000 STA R2 LDA RW,I CPA =D2 JMP WRITE DLD LOCAT,I R3 NOP AND MASK STA IVAL,I JMP BITS,I * WRITE DLD LOCAT,I R1 NOP AND NMASK IOR DATA R2 NOP DST LOCAT,I JMP BITS,I END $  pw 92903-18005 1805 S C0122 &BLAN              H0101 IASMB HED S/P BLAN (21MX ONLY) 24AUG77 P. SENANT NAM BLAN,7 . 92903-16001 REV.1805 770824 * * SOURCE 92903-18005 * SPC 2 ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** SPC 2 EXT .ENTR ENT BLAN SUP * * THIS PROGRAM FILLS A STRING WITH BLANKS * IBUF NOP IT NOP N NOP * BLAN NOP JSB .ENTR DEF IBUF CCA ADA N,I SSA JMP BLAN,I STA N LDB IBUF CLE,ELB ADB DM1 ADB IT,I LDA BL SBT INIT. FIRST CHARACTER LDA N SZA,RSS JMP BLAN,I CCA ADA 1 MBT N JMP BLAN,I * DM1 DEC -1 BL OCT 40 END e qw 92903-18006 1805 S C0122 &BLANC              H0101 lASMB HED S/P BLANC (21MX ONLY) PS 24/08/77 NAM BLANC,7 . 92903-16001 REV.1805 770824 * * SOURCE 92903-18006 * SPC 2 ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** SPC 2 EXT .ENTR ENT BLANC * * THIS ROUTINE BLANKS A BUFFER * BUF NOP NMOT NOP * BLANC NOP JSB .ENTR DEF BUF CCA ADA NMOT,I SSA JMP BLANC,I STA NMOT LDB BL STB BUF,I INIT. FIRST WORD SZA,RSS JMP BLANC,I LDA BUF STA 1 INB MVW NMOT JMP BLANC,I * BL OCT 20040 END O rx 92903-18007 1805 S C0122 &BRCKS              H0101 ~FTN4 LOGICAL FUNCTION BRCKS(IBUF .,L),. 92903-16001 REV.1805 780112 C C SOURCE 92903-18007 C C C C ************************************************************** C * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * C ************************************************************** C C C ************************************************************* C * * C * THIS FUNCTION CALCULATES THE CHECKSUM C * (FORMAT IS BINARY RELOCATBLE) * C * THE CHECKSUM IS STORED IN WORD 3 OF THE BUFFER AND * C * IS THE ARITHMETIC SUM OF WORD 2,4,5,6,7 ... L * C * * C ************************************************************* C C CALLING SEQUENCE: C C IF( BRCKS(IBUF,L)) GOTO .. [CHECKSUM WAS BAD] C C IN ANY RETURN (.FALSE. OR .TRUE.) THE GOOD CHECKSUM C IS STORED IN WORD 3 C DIMENSION IBUF(1) C BRCKS=.TRUE. IF(L.LE.3) RETURN ICK=IBUF(3) IBUF(3)=IBUF(2) DO 100 I=4,L 100 IBUF(3)=IBUF(3)+IBUF(I) BRCKS = .NOT. ICK.EQ.IBUF(3) RETURN END END$ v sy 92903-18008 1805 S C0122 &CMPB              H0101 |YASMB HED S/P CMPB P. SENANT (21MX ONLY) 25JUN77 NAM CMPB,7 . 92903-16001 REV.1805 770625 * * SOURCE 92903-18008 * SPC 2 ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** SPC 2 EXT .ENTR ENT CMPB SUP * BUF1 NOP IOF1 NOP BUF2 NOP IOF2 NOP LEN NOP * CMPB NOP JSB .ENTR DEF BUF1 LDA BUF1 CLE,ELA ADA DM1 ADA IOF1,I /FIRST STRING LDB BUF2 CLE,ELB ADB DM1 ADB IOF2,I /2ND STRING CBT LEN,I JMP *+4 CLA,RSS CLA JMP CMPB,I CCA JMP CMPB,I * DM1 DEC -1 END  tz 92903-18009 1805 S C0122 &CMPW              H0101 YASMB HED S/P CMPW 21MX ONLY 4SEPT76 P. SENANT NAM CMPW,7 . 92903-16001 REV.1805 760904 * * SOURCE 92903-18009 * SPC 2 ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** SPC 2 EXT .ENTR ENT CMPW SUP * * THIS S/P COMPARES TWO BUFFERS * * IF BUF1 = BUF2 THEN CMPW IS TRUE * IF BUF1 # BUF2 THEN CMPW IS FALSE * IB1 NOP IB2 NOP NN NOP * CMPW NOP JSB .ENTR DEF IB1 LDA IB1 LDB IB2 CMW NN,I JMP *+4 CLA,RSS CLA JMP CMPW,I CCA JMP CMPW,I END  u{ 92903-18010 1805 S C0122 &CRC16              H0101 hcASMB NAM CRC16,7 . 92903-16001 REV.1805 770718 * * SOURCE 92903-18010 * SPC 2 ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** SPC 2 * ********************************************************************** * * * THIS SUBROUTINE IS USED TO COMPUTE THE CRC-16 * * CHECKSUM OF A BUFFER * * * * CALLING PARAMETERS : * * * * IBUF : BUFFER * * IL : BUFFER LENGTH IN BYTES * * IWD : CHECKSUM WORD * * * ********************************************************************** * * ENT CRC16 EXT .ENTR * * GET CALLING PARAMETER ADDRESS * IBUF NOP BUFFER ADDRESS IL NOP BUFER LENGTH IN BYTES IWD NOP CHECKSUM WORD CRC16 NOP ENTRY POINT JSB .ENTR DEF IBUF * LDA IL,I GET # OF BYTES CMA,INA MAKE IT NEGATIVE SSA,RSS IS POSITIVE JMP CRC16,I YES ERROR ! STA COUNT OK STORE IN COUNTER LDB IBUF GET BUFFER ADDRESS CLE,ELB MULTIPLY BY TWO TO HAVE BYTE ADDRESS * LP1 LBT GET NEXT BYTE IN BUFFER STB IBUF SAVE ADDRESS OF NEXT BYTE LDB A <'   SWAP A AND B REGISTER LDA IWD,I GET OLD CHECKSUM WORD JSB EBCLC COMPUTE NEW CHECSUM STA IWD,I STORE IT LDB IBUF RESTORE B REGISTER ISZ COUNT INCREMENT COUNTER JMP LP1 NOT FINISHED GO TO NEXT BYTE JMP CRC16,I FINISHED RETURN * * SUBROUTINE TO COMPUTE CRC-16 CHECKSUM * EBCLC NOP ENTRY POINT XOR B SLA,RAR XOR POLY SLA,RAR XOR POLY SLA,RAR XOR POLY SLA,RAR XOR POLY SLA,RAR XOR POLY SLA,RAR XOR POLY SLA,RAR XOR POLY SLA,RAR XOR POLY JMP EBCLC,I RETURN * * DATA,CONSTANTS,STORAGE... * A EQU 0 B EQU 1 COUNT NOP POLY OCT 20001 * END CRC16  v} 92903-18011 1805 S C0122 &DORMT              H0101 ASMB HED PROGRAM STATUS: DORMANT ? (RTE-III/IV) F. GAULLIER 18/JUL/77 NAM DORMT,7 . 92903-16001 REV.1805 780112 * * SOURCE 92903-18011 * SPC 2 ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** SPC 2 * ********************************************************* * * THIS LOGICAL FUNCTION WILL BE ".TRUE." IF THE PROGRAM * * * IS ACTUALLY DORMANT [ CALL EXEC(6,0,0) ], OR UNLOADED * * * IF IT IS SCHEDULED, IN ANY WAITING LIST, OR HAS BEEN * * * COMPLETED WITH THE "SAVE SUSPENSION POINT" OPTION : * * * [ CALL EXEC(6,0,1) ], THE LOGICAL FUNCTION WILL BE : * * * ".FALSE". * * ********************************************************* SPC 2 * * CALLING SEQUENCE: * * IF ( DORMT(PNAME) ) GOTO .. [PROG. IS DORMANT] * * (.TRUE. = 100000B AND .FALSE. = 0) * SPC 2 ENT DORMT EXT .ENTR,IDGET * A EQU 0 B EQU 1 * *-----ENTRY POINT * ANAME BSS 1 DORMT NOP JSB .ENTR DEF ANAME ADDRESS OF BUFFER CONTAINING PRG. NAME * *-----GET I.D. SEGMENT ADDRESS * JSB IDGET DEF *+2 DEF ANAME,I PROGRAM NAME SZA,RSS IS PROGRAM LOADED ? JMP .TRUE NO * *-----VERIFY THAT PROGRAM IS FULLY DORMANT * LDB A GET PROGRAM I.D. SEGMEMT ADDRESS ADB P12 COMPUTE PROGRAM NAME ADDRESS IN I.D. STB IDBDR SAVE IT ADB P2 (B)=NAM5 ADDR OF MATCHED I.D. XLA B,I GET NAM5 AND AND P7 MASK IN PROGRAM TYPE. CPA P5 IS THIS A SEGMENT ? JMP .TRUE YE  S IT IS : EQUIVALENT TO DORMANT ADB N6 (B)=ADDR OF SUSPEND WORD XLA B,I POINT OF SUSPENSION ? SZA ZERO-CONTINUE JMP .FALS PROGRAM HAS A SUSPENSION POINT ADB P7 COMPUTE STATUS WORD ADDRESS XLA B,I GET STATUS WORD SZA DORMANT ? JMP .FALS PROGRAM IS NOT DORMANT ADB P2 COMPUTE TIME LIST WORD ADDRESS XLA B,I GET TIME LIST WORD AND BIT12 GET BIT 12 OF (TIME LIST ENTRY BIT) SZA PROGRAM IS IN THE TIME LIST ? JMP .FALS YES * *-----PROGRAM IS FULLY DORMANT * .TRUE CCA LOGICAL FUNCTION ".TRUE." JMP DORMT,I RETURN * *-----PROGRAM IS NOT FULLY DORMANT * .FALS CLA LOGICAL FUNCTION ".FALSE." JMP DORMT,I RETURN * *-----CONSTANTS * IDBDR BSS 1 NAM5 ADDRESS P2 DEC 2 P5 DEC 5 P7 DEC 7 P12 DEC 12 N6 DEC -6 BIT12 OCT 010000 * * * END `  w~ 92903-18012 1805 S C0122 &EBCD              H0101 mOASMB HED S/P EBCAS,ASEBC (15/10/75) P. SENANT NAM EBCD,7 . 92903-16001 REV.1805 751015 * * SOURCE 92903-18012 * SPC 2 ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** SPC 2 ENT EBCAS,ASEBC EXT .ENTR * * * CALL EBCAS (IA,LEN) * * WILL CONVERT BUFFER IA FROM IBM 8-LEVEL CODE TO ASCII, WHERE * LEN IS THE NUMBER OF WORDS TO BE CONVERTED. * * * CALL ASEBC (IA,LEN) * * WILL CONVERT BUFFER IA FROM ASCII TO IBM 8-LEVEL, WHERE * LEN IS THE NUMBER OF WORDS TO BE CONVERTED * * HED ASCII TO IBM 8-LEVEL CONVERSION IA NOP LEN NOP ASTOI NOP JSB .ENTR DEF IA * LDA BASE1 ADDRESS OF CONVERSION TABLE STA BASE WORKING POINTER DLD IA PARAMETER PICK-UP FOR GOGO * GOGO STA PTR WORKING BUFFER ADDRESS LDB 1,I ACTUAL PARAMETER CMB,INB NEGATIVE WORD COUNT STB CTR WORKING COUNTER * CLOOP LDA PTR,I PICK UP WORD JSB CCHAR CONVERT UPPER CHARACTER JSB CCHAR CONVERT LOWER CHARACTER STA PTR,I RETURN WORD TO BUFFER ISZ PTR NEXT WORD ISZ CTR DONE? JMP CLOOP NO, CONTINUE CONVERSION JMP ASTOI,I YES, RETURN * * CHARACTER CONVERSION * CCHAR NOP ALF,ALF POSITION NEXT CHARACTER STA TEMP SAVE OTHER HALF AND M77 LOOK AT SIX BITS ONLY ADA BASE BASE ADDRESS OF CONVERSION TABLE LDB 0,I CONVERTED CHARACTER LDA MLEFT MASK FOR OTHER CHARACTER AND TEMP SALVAGE OTHER CHARACTER INTACT IOR 1 INSERT NEW CHARAC[  TER JMP CCHAR,I RETURN * MLEFT OCT 177400 M77 OCT 77 TEMP BSS 1 * BASE DEF TAB1 BASE1 DEF TAB1 BASE2 DEF TAB2 CTR BSS 1 PTR BSS 1 HED IBM 8-LEVEL TO ASCII CONVERSION .IA NOP .LEN NOP ITOAS NOP JSB .ENTR DEF .IA * LDA BASE2 POINTER TO WORKING TABLE STA BASE WORKING POINTER LDA ITOAS RETURN ADDRESS STA ASTOI EXIT POINT * DLD .IA PARAMETER TRANSFER JMP GOGO SPC 3 SUP TAB1 OCT 174,301,302,303,304,305,306,307 OCT 310,311,321,322,323,324,325,326 OCT 327,330,331,342,343,344,345,346 OCT 347,350,351,132,101,112,156,114 OCT 100,117,177,173,133,154,320,175 OCT 115,135,134,116,153,140,113,141 OCT 360,361,362,363,364,365,366,367 OCT 370,371,172,136,114,176,156,157 SPC 2 TAB2 OCT 040,101,102,103,104,105,106,107 OCT 110,111,135,056,074,050,053,041 OCT 046,112,113,114,115,116,117,120 OCT 121,122,133,044,052,051,073,101 OCT 055,057,123,124,125,126,127,130 OCT 131,132,101,054,045,101,076,077 OCT 060,061,062,063,064,065,066,067 OCT 070,071,072,043,100,047,075,042 EBCAS EQU ITOAS ASEBC EQU ASTOI END BK  x 92903-18013 1805 S C0122 &IALF2              H0101 onASMB HED S/P IALF2 (15/10/75) F. GAULLIER NAM IALF2,7 . 92903-16001 REV.1805 760907 * * SOURCE 92903-18013 * SPC 2 ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** SPC 2 ENT IALF2 EXT .ENTR IADR NOP SWAP NOP JSB .ENTR DEF IADR LDA IADR,I ALF,ALF JMP SWAP,I IALF2 EQU SWAP END u y 92903-18014 1805 S C0122 &IASC              H0101 mcASMB HED S/P IASC . 15/10/75 P. SENANT NAM IASC,7 . 92903-16001 REV.1805 751015 * * SOURCE 92903-18014 * SPC 2 ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** SPC 2 EXT .ENTR ENT IASC * * INTEGER --> ASCII CONVERSION (2 DIGITS) * D10 DEC 10 O60 OCT 60 .N NOP IASC NOP JSB .ENTR DEF .N LDA .N,I CLB DIV D10 ADA O60 ADB O60 ALF,ALF ADA 1 JMP IASC,I END ge z 92903-18015 1805 S C0122 &ICRLU              H0101 yFTN4 INTEGER FUNCTION ICRLU(NUMB),. 92903-16001 REV.1805 780225 C C SOURCE 92903-18015 C C C C ************************************************************** C * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * C ************************************************************** C C C ************************************************************** C * * C * THIS FUNCTION RETURNS THE FOLLOWING VALUES: * C * * C * IF NUMB = -(DISC LU) -----> ICRLU = CARTRIDGE # * C * IF NUMB = CARTRIDGE # -----> ICRLU = DISC LU * C * IF NUMB = 0 -----> ICRLU = 1ST CARTRIDGE # * C * IF ANY ERROR (UNDEF..) -----> ICRLU = -1 (IF NOT MOUNTED) * C * ICRLU = -2 (IF CR LOCKED) * C * * C ************************************************************** C C DIMENSION IDCB(128),IREG(2) INTEGER AREG,BREG EQUIVALENCE (REG,IREG,AREG),(IREG(2),BREG) LOGICAL ISBTW C C-----IF NUMB NEGATIVE #, 1 < -(NUMB) < 64 ? C IF(NUMB.GE.0) GOTO 100 IF(ISBTW(-NUMB,2,63)) GOTO 300 C C-----GET TRACK # OF THE CARTRIDGES DIRECTORY TABLE C 100 REG=EXEC(1,2,IDCB,5,600,0) BREG=BREG-1 C C-----READ CARTRIDGES DIRECTORY TABLE C CALL EXEC(1,2,IDCB,128,BREG,0) IF(NUMB.GT.0) GOTO 400 IF(NUMB.NE.0) GOTO 150 ICRLU=IDCB(3) RETURN C C-----SEARCH A CARTRIDGE NUMBER C 150 DO 200 I=1,121,4 IF(IDCB(I).EQ.0) GOTO 300 IF(IDCB(I).NE.-NUMB) GOTO 200 IF(IDCB(I+3).NE.0) GOT+  O 350 ICRLU=IDCB(I+2) RETURN 200 CONTINUE C-----ERROR = -1, CARTRIDGE NOT MOUNTED 300 ICRLU=-1 RETURN C-----ERROR = -2, CARTRIDGE LOCKED 350 ICRLU=-2 RETURN C C-----SEARCH AN LU NUMBER C 400 DO 500 I=3,123,4 IF(IDCB(I-2).EQ.0) GOTO 300 IF(IDCB(I).NE.NUMB) GOTO 500 IF(IDCB(I+1).NE.0) GOTO 350 ICRLU=IDCB(I-2) RETURN 500 CONTINUE GOTO 300 END END$ \  { 92903-18016 1805 S C0122 &IDCLR              H0101 {ASMB HED CLEAR ID SEGMENT (RTE-IV ONLY) F. GAULLIER 06/JUL/77 NAM IDCLR,7 . 92903-16001 REV.1805 780228 * * SOURCE 92903-18016 * SPC 2 ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** SPC 2 * ******************************************************************** * * * * * THIS ROUTINE CHECKS THE STATUS OF THE PROGRAM, AND IF IT IS * * * DORMANT, DISC RESIDENT AND LOADED TEMPORARILY, THIS SUBROUTINE * * * DO A 'OF,PNAME,8' TO REMOVE IT FROM THE SYSTEM. * * * IF THE CONDITION ARE NOT OK, A STATUS IS RETURNED TO THE USER. * * * * * * ------------- FORTRAN CALL ------------------------------------- * * * * * * IF( IDCLR(NAME[,IERR]) ) GOTO [ NON-SUCCESSFULL OPERATION ] * * * * * * IERR IS AN ERROR FLAG RETURNED BY IDCLR SUBROUTINE. * * * * * * IERR VALUE DEFINED ERROR * * * ---------- ------------- * * * 0 EVERYTHING IS O.K. * * * -1 PROGRAM NOT LOADED * * * -2 PROGRAM NOT FULLY DORMANT * * * -3 PROGRAM IS RTE-IV SYSTEM * * * -4 PROGRAM IS LOADED PERMANENTLY  * * * -5 PROGRAM IS CORE RESIDENT * * * * * ******************************************************************** SPC 1 ENT IDCLR EXT .ENTR,DORMT,IDGET,MESSS * A EQU 0 B EQU 1 SUP * *-----ENTRY POINT * ANAME BSS 1 AIERR OCT 0 IDCLR NOP JSB .ENTR DEF ANAME ADDRESS OF BUFFER CONTAINING PRG. NAME * *-----GET I.D. SEGMENT ADDRESS * JSB IDGET DEF *+2 DEF ANAME,I PROGRAM NAME STA OFBUF+2 SAVE ID SEG ADDR TEMPORARILY * *-----VERIFY THAT PROGRAM IS LOADED * SZA IDGET RETURNED NUL I.D. SEGMENT ADDRESS ! JMP IDCL3 CONTINUE PROCESS CCA ERROR: IERR=-1 PROGRAM IS NOT LOADED ! RETUN STA AIERR,I RETURN ERROR CODE IF REQUIRED CLB CLEAR ADDRESS OF ERROR PARAMETER STB AIERR FOR THE NEXT TIME JMP IDCLR,I RETURN LOGICAL VALUE SPC 3 * *-----CHECK THAT PROGRAM IS FULLY DORMANT * IDCL3 JSB DORMT CHECK IF PROGRAM IS DORMANT DEF *+2 DEF ANAME,I PROGRAM NAME SZA,RSS FULLY DORMANT ? JMP ERR02 NO, ERROR -2 * *-----VERIFY PROGRAM IS NOT A SYSTEM ONE (LOADED AT GEN.) * LDA OFBUF+2 RECALL ID SEG ADDR ADA P14 (A)=NAM5 ADDRESS, "SS" BIT & PROG. TYPE STA B XLA B,I GET PROGRAM TYPE AND B17 ISOLATE TYPE SZA,RSS CORE RESIDENT ? JMP ERR05 YES, ERROR -5 CPA P1 CORE RESIDENT ? JMP ERR05 YES, ERROR -5 XLA B,I NO, GET NAM5 WORD AND "SS" BIT AND M20 ISOLATE "SS" BIT INB SZA,RSS SHORT OR LONG I.D. SEG ? ADB P7 LONG I.D. SEGMENT ADB P4 (B)=ADDRESS OF DISC WORD XLA B,I GET DISC WORD SSA TRACK ON AUXILIARY LU # 3 JMP IDCL5 YES: NOT SYSTEM PROGRAM \ | 92903-18018 1805 S C0122 &IGET1              H0101 fASMB HED ** S/P IGET1 (21MX ONLY) P. SENANT 10/10/75 NAM IGET1,7 . 92903-16001 REV.1805 760907 * * SOURCE 92903-18018 * SPC 2 ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** SPC 2 EXT .ENTR ENT IGET1 * * THIS PROGRAM GETS A BYTE IN A STRING * THE RETURNED WORD : - LEFT : THIS BYTE * - RIGHT : ONE BLANK * DM1 DEC -1 * .BUFF NOP BUFFER ADDRESS .N NOP REL. ADDR. OF BYTE * IGET1 NOP JSB .ENTR DEF .BUFF LDB .BUFF CLE,ELB ADB DM1 ADB .N,I LBT ALF,ALF IOR O40 JMP IGET1,I * O40 OCT 40 END ! } 92903-18019 1805 S C0122 &IGET2              H0101 gASMB HED S/P IGET2 (15/10/75) F. GAULLIER NAM IGET2,7 . 92903-16001 REV.1805 760907 * * SOURCE 92903-18019 * SPC 2 ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** SPC 2 EXT .ENTR ENT IGET2 * * THIS PROGRAM GETS 2 BYTES IN A STRING * .BUFF NOP BUFFER ADDRESS .N NOP REL. ADDRESS OF FIRST BYTE * IGET2 NOP JSB .ENTR DEF .BUFF CCB ADB .N,I CLE,ERB ADB .BUFF DLD 1,I SEZ RRL 8 JMP IGET2,I END 7 ~ 92903-18020 1805 S C0122 &IGETB              H0101 xASMB HED ** S/P IGETB (21MX ONLY) F. GAULLIER 07/SEP/77 NAM IGETB,7 . 92903-16001 REV.1805 760907 * * SOURCE 92903-18020 * SPC 2 ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** SPC 2 EXT .ENTR ENT IGETB * * THIS PROGRAM GETS A BYTE IN A STRING, RIGHT JUSTIFIED * THE RETURNED WORD : - RIGHT : THIS BYTE * - LEFT : ALL ZERO * DM1 DEC -1 * .BUFF NOP BUFFER ADDRESS .N NOP REL. ADDR. OF BYTE * IGETB NOP JSB .ENTR DEF .BUFF LDB .BUFF CLE,ELB ADB DM1 ADB .N,I LBT JMP IGETB,I * END %  92903-18021 1805 S C0122 &IMBED              H0101 xwFTN4 LOGICAL FUNCTION IMBED(IBUF,IBYT,LNBYT),. 92903-16001 REV.1805 78 .0517 C C C NAME: IMBED C SOURCE: &IMBED 92903-18021 C BINARY: %IMBED 92903-16001 PART OF %GPLB4 C C PMGR: FRANCOIS GAULLIER C C C C ************************************************************** C * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * C ************************************************************** C C C C **************************************************************** C * * C * THIS FUNCTION FAIL, (RETURN FALSE VALUE) IF NO BLANK * C * CHARACTER IS IMBEDED IN THE STRING STARTING AT BYTE: IBYT * C * INTO BUFFER: IBUF, THE STRING LENGTH BEING: LNBYT. * C * THE LEADING AND TRAILING BLANKS ARE IGNORED. * C * * C **************************************************************** C C DIMENSION IBUF(1) LOGICAL TEXT C TEXT=.FALSE. IMBED=.TRUE. C-----SET UP THE LOOP FOR (LN-1) BECAUSE INSIDE THE LOOP C I+1 IS USED !!! DO 100 I=IBYT,IBYT+LNBYT-2 K=IGET1(IBUF,I) IF(K .NE. 1H ) TEXT=.TRUE. IF(K.EQ.1H .AND. IGET1(IBUF,I+1).NE.1H .AND. TEXT) RETURN 100 CONTINUE IMBED=.FALSE. RETURN END END$   92903-18022 1805 S C0122 &INUM              H0101 fFTN4 LOGICAL FUNCTION INUM(IB,NCAR,NBCAR .,I),. 92903-16001 REV.1805 770114 C C SOURCE 92903-18022 C C C C ************************************************************** C * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * C ************************************************************** C C C ************************************************************* C * * C * INUM IS A LOGICAL FUNCTION TO CONVERT AN ASCII * C * BUFFER INTO AN INTEGER NUMBER. CHECKS ARE MADE AND * C * FUNCTION SUCCEED IF THE INPUT BUFFER IS NOT CORRECT. * C * * C * IF( INUM(IBUF,NCAR,NBCAR,I) ) GOTO ERROR * C * * C * WHERE: * C * IBUF BUFFER * C * NCAR NUMBER OF FIRST CHARACTER TO USE IN * C * THE BUFFER ( 1ST = 1) * C * NBCAR NUMBER OF CHARACTER TO BE USED * C * I INTEGER VARIABLE WHERE THE INTEGER * C * VALUE IS RETURNED. * C * * C ************************************************************* C IF(NBCAR .LE. 0) GOTO 600 INUM=.FALSE. I=0 ISIG=1 L=NBCAR JE=NCAR+NBCAR-1 DO 100 J=NCAR,JE K=IGET1(IB,J) IF(K .EQ. 1H-) GOTO 400 IF(K.EQ.1H+) GO TO 450 IF(K.NE.1H ) GO TO 500 L=L-1 100 CONTINUE RETURN C 400 ISIG=-1 450 J=J+1 L=L-1 50w   0 I=NUMD(IB,J,L) IF(I .LT. 0) GOTO 550 I=I*ISIG RETURN C 550 IF(ISIG .EQ. 1) GOTO 600 C SPECIAL CHECK FOR -32768 IF(IGET2(IB,J) .NE. 2H32) GOTO 600 IF(IGET2(IB,J+2) .NE. 2H76) GOTO 600 IF(IGET1(IB,J+4) .NE. 1H8) GOTO 600 I=-32768 RETURN C C ERROR RETURN ! C 600 INUM=.TRUE. I=0 RETURN END END$ O   92903-18023 1805 S C0122 &IRANG              H0101 yASMB HED S/P IRANG (21MX ONLY) 8/7/76 P. SENANT NAM IRANG,7 . 92903-16001 REV.1805 760708 * * SOURCE 92903-18023 * SPC 2 ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** SPC 2 EXT .ENTR ENT IRANG * * THIS SUBPROGRAM COMPARES TWO BUFFERS * BUF1=BUF2 : 0 * BUF1BUF2 : 1 * * BUF1 NOP BUF2 NOP NN NOP * IRANG NOP JSB .ENTR DEF BUF1 LDA BUF1 LDB BUF2 CMW NN,I JMP *+4 CCA,RSS CLA,INA JMP IRANG,I CLA JMP IRANG,I END O  92903-18024 1805 S C0122 &ISBIT              H0101 ASMB HED S/P ISBIT (15/10/75) F. GAULLIER NAM ISBIT,7 . 92903-16001 REV.1805 770708 * * SOURCE 92903-18024 * SPC 2 ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** SPC 2 EXT .ENTR ENT ISBIT * * "ISBIT" IS A LOGICAL FUNCTION * .FALSE. = THE BIT IS NOT SET * .TRUE. = THE BIT IS SET * J NOP WORD IB NOP BIT # (0 TO 15) * ISBIT NOP JSB .ENTR DEF J LDA J,I LDB IB,I ADB DM16 STB IB ELA ISZ IB JMP *-2 CLA ERA JMP ISBIT,I * DM16 DEC -16 END h  92903-18025 1805 S C0122 &ISBTW              H0101 ASMB HED S/P ISBTW (15/10/75) F. GAULLIER NAM ISBTW,7 . 92903-16001 REV.1805 760907 * * SOURCE 92903-18025 * SPC 2 ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** SPC 2 ENT ISBTW EXT .ENTR SPC 1 * LOGICAL FUNCTION ISBTW(I,MIN,MAX) * * ISBTW = 0 / .FALSE. (E=1) IF I IS INSIDE THE LIMITS. * (LIMITS INCLUDED.) * * THE SAME AS FTN4 STATEMENT: * * ISBTW = I.LT.MIN .OR. I.GT.MAX SPC 2 I NOP MIN NOP MAX NOP ISBTW NOP JSB .ENTR DEF I * LDA MIN,I CMA,INA ADA I,I STA 1 LDA I,I CMA,INA ADA MAX,I IOR 1 SSA CCA,CLE,RSS OUTSIDE LIMIT ---> .TRUE. E=0 CLA,CCE INSIDE LIMIT ---> .FALSE. / 0 E=1 JMP ISBTW,I END h  92903-18026 1805 S C0122 &ISCAN              H0101 ASMB HED S/P ISCAN 3/6/77 P. SENANT NAM ISCAN,7 . 92903-16001 REV.1805 770603 * * SOURCE 92903-18026 * SPC 2 ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** SPC 2 EXT .ENTR ENT ISCAN * * THIS ROUTINE IS ABLE TO SCAN A STRING UNTIL/WHILE A TEST BYTE * OCCURS. * * CALLING SEQUENCE: * * I = ISCAN (IBUF,IBEG,IBYTES,IFLAG) * * IBUF : BUFFER TO BE SCANNED * IBEG : STARTING BYTE OF SCANNING/ LAST POSITION SCANNED * IBYTES : LEFT = TERMINATOR * RIGHT = TEST BYTE * FLAG : 0 = UNTIL * 1 = WHILE * * THE A-REGISTER RETURNS A FLAG : 0 = TEST BYTE IS DETECTED * 1 = TERMINATOR IS DETECTED * BUF NOP IBEG NOP BYTES NOP FLAG NOP * ISCAN NOP JSB .ENTR DEF BUF * LDB BUF COMPUTE CLE,ELB STARTING ADB DM1 BYTE ADDRESS ADB IBEG,I OF STRING STB BUF AND SAVE IT * LDA FLAG,I KIND OF SCAN? SZA JMP WHILE SCAN WHILE * LDA BYTES,I SCAN UNTIL SFB JMP .TES1 TEST BYTE DETECTED .TERM EQU * TERMINATOR DETECTED LDA BUF CMA,INA ADB 0 STB IBEG,I RETURN LAST POSITION CCA I=-1/.TRUE. JMP ISCAN,I * .TES1 EQU * INB .TEST EQU * TEST BYTE FOUND LDA BUF CMA,INA ADB 0 STB IBEG,I RETURN LAST POSITION CLA JMP ISCAN,I I=0/.FALSE. * * WHILE EQU * SCAN WHILE LDA BYTES,I CLB RRL 8 SPL5  IT TEST & TERM. ALF,ALF STA TEST STB TERM LDB BUF LOOP LBT CPA TERM TERMINATOR ? JMP .TERM YES CPA TEST TEST BYTE ? JMP LOOP YES . CONTINUE JMP .TEST * * DM1 DEC -1 TERM NOP TEST NOP END ~   92903-18027 1805 S C0122 &ISNUL              H0101 ASMB HED S/P ISNUL (15/10/75) F. GAULLIER NAM ISNUL,7 . 92903-16001 REV.1805 760907 * * SOURCE 92903-18027 * SPC 2 ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** SPC 2 ENT ISNUL EXT .ENTR SPC 2 * IF(ISNUL(IBUF,# OF WORDS) ) GARBAGE IN BUFFER * ONLY NUL CHARACTERS FOUND IN THE BUFFER SPC 1 .B NOP .N NOP ISNUL NOP JSB .ENTR DEF .B * LDA .N,I CMA,INA CCE,SSA,RSS JMP ISNUL,I OK ! ---> .FALSE. E=1 STA .N LDB .B LOOP LDA 1,I INB CCE,SZA JMP NO ISZ .N JMP LOOP JMP ISNUL,I OK ! ---> .FALSE. / 0 E=1 * NO CCA,CLE ERROR ! ---> .TRUE. E=0 JMP ISNUL,I END [  92903-18029 1805 S C0122 &ISSPA              H0101 ASMB HED S/P ISSPA (21MX ONLY) 15/10/75 P. SENANT NAM ISSPA,7 . 92903-16001 REV.1805 760929 * * SOURCE 92903-18029 * SPC 2 ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** SPC 2 EXT .ENTR ENT ISSPA SPC 1 * IF(ISSPA(IBUF,1ST CHAR.,# OF BYTE) ) GARBAGE IN BUFFER * ONLY SPACES FOUND IN THE BUFFER SPC 1 DM1 DEC -1 * IBUF NOP IN NOP N NOP * ISSPA NOP JSB .ENTR DEF IBUF LDA N,I CMA,INA CCE,SSA,RSS JMP ISSPA,I OK ---> .FALSE. E=1 STA N LDB IBUF CLE,ELB ADB DM1 ADB IN,I LOOP LBT CPA O40 CLA,CCE,RSS JMP NON ISZ N JMP LOOP JMP ISSPA,I OK ! ---> .FALSE. / 0 E=1 NON ADB DM1 B=BYTE POINTER TO 1ST BAD CHAR. CCA,CLE ERROR ! ---> .TRUE. E=0 JMP ISSPA,I * O40 OCT 40 END D  92903-18030 1805 S C0122 &ISUPB              H0101 FTN4 INTEGER FUNCTION ISUPB(IBUF,LEN),. 92903-16001 REV.1805 770123 C C SOURCE 92903-18030 C C C C ************************************************************** C * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * C ************************************************************** C C C ********************************************** C * THIS FUNCTION CONTRACTS A CHARACTER STRING * C * CONTAINED IN A BUFFER WHOSE NAME IS GIVEN * C * IN FIRST PARAMETER. LENGTH OF THIS STRING * C * IS GIVEN IN THE SECOND PARAMETER. FUNCTION * C * RETURNS THE NEW LENGTH OF THE CONTRACTED * C * STRING. (ALL LENGTH ARE IN WORDS) * C ********************************************** C C REV. 770123 CORRECT A BUG ! FG C DIMENSION IBUF(1) C C LENC=2*LEN K=0 I=1 10 IF(IGET1(IBUF,I).EQ.1H ) GOTO 30 15 I=I+1 IF(I.LE.LENC) GOTO 10 CALL BLAN(IBUF,LENC+1,K) ISUPB=(LENC+1)/2 RETURN 30 J=I 40 K=K+1 J=J+1 IF(J.GT.LENC) GOTO 60 IF(IGET1(IBUF,J).EQ.1H ) GOTO 40 CALL MOVCA(IBUF,J,IBUF,I,LENC-J+1) 60 LENC=LENC+I-J GOTO 15 END END$ -  92903-18031 1805 S C0122 &JASC              H0101 jfFTN4 SUBROUTINE JASC(IVAL,IBUF,JBYT .,NBYTE),. 92903-16001 REV.1805 770721 C C SOURCE 92903-18031 C C C C ************************************************************** C * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * C ************************************************************** C C C********************************************************************* C* * C* THIS SUBROUTINE IS USED TO CONVERT ANY INTEGER * C* NUMBER (POSITIVE OR NEGATIVE) IN AN ASCII STRING . * C* * C* PARAMETERS : * C* * C* IVAL : INTEGER VALUE * C* IBUF : BUFFER TO STORE ASCII STRING * C* IBYT : FIRST BYTE # TO STORE STRING * C* IF IBYT IS NEGATIVE LEADING BLANKS IN * C* STRING ARE CHANGED TO ZEROS * C* NBYTE : # OF BYTES OF THE STRING * C* * C********************************************************************* C C DIMENSION IBUF(1),ITEMP(3) C IBYT=JBYT IF(JBYT.LT.0) IBYT=-JBYT IF((IBYT.LT.1).OR.(NBYTE.LT.1)) RETURN CALL BLAN(IBUF,IBYT,NBYTE) JVAL=IVAL IF(IVAL.LT.0) JVAL=-IVAL CALL CNUMD(JVAL,ITEMP) DO 100 I=1,6 IF(IGET1(ITEMP,I).NE.1H ) GO TO 200 100 CONTINUE 200 IF(IVAL.GE.0) GO TO 300 I=I-1 CALL PUTCA(ITE}u  MP,1H-,I) 300 IF(7-I.GT.NBYTE) RETURN CALL MOVCA(ITEMP,I,IBUF,IBYT+NBYTE-7+I,7-I) IF(JBYT.GT.0) RETURN DO 350 K=IBYT,IBYT+NBYTE-1 IF(IGET1(IBUF,K).EQ.1H ) CALL PUTCA(IBUF,1H0,K) 350 CONTINUE RETURN END END$ Y   92903-18032 1805 S C0122 &JULIA              H0101   92903-18033 1805 S C0122 &JULIB              H0101 FTN4 LOGICAL FUNCTION JULIB(JUDAY,IAN,JOUR .,MOIS),. 92903-16001 REV.1805 771104 C C SOURCE 92903-18033 C C C C ************************************************************** C * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * C ************************************************************** C C C C GIVE THE DAY AND MONTH NUMBER FROM THE DAY OF YEAR C C CALLING SEQUENCE: C C IF ( JULIB(JULDAY,YEAR,DAY,MONTH) ) GOTO .. ERROR C C JULDAY - DAY OF THE YEAR 1 TO 366 (JULIAN DAY) C YEAR - YEAR 0 TO 2999 C DAY - THE DAY OF THE MONTH WILL BE RETRUNED HERE C MONTH - THE MONTH WILL BE RETUNED YEAR C C DIMENSION IBUF(12) DATA IBUF/31,28,31,30,31,30,31,31,30,31,30,31/ JULIB=.TRUE. IBUF(2)=28 IF(IAN.LE.0) RETURN IF (IAN.EQ.1900.OR.IAN.EQ.2000) GO TO 50 K=(IAN/4)*4 IF(K.EQ.IAN)IBUF(2)=29 50 CONTINUE JDAY = JUDAY DO 20 I=1,12 IF (JDAY.LE.IBUF(I)) GO TO 30 JDAY = JDAY - IBUF(I) 20 CONTINUE RETURN C C DAY OF YEAR WAS OK, RETURN RESULT C 30 CONTINUE JULIB=.FALSE. JOUR = JDAY MOIS = I RETURN END END$ 0  92903-18034 1805 S C0122 &JUSTF              H0101 ASMB HED S/P JUSTF (21MX ONLY) F. GAULLIER 22/JUL/77 NAM JUSTF,7 . 92903-16001 REV.1805 770722 * * SOURCE 92903-18034 * SPC 2 ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** SPC 2 ENT JUSTF EXT .ENTR SUP * * THIS SUBROUTINE MAKES A STRING RIGHT OR LEFT-JUSTIFIED * * CALLING SEQUENCE: * * CALL JUSTF(IBUF,IBYT,NBYTE,ICNW) * * IBUF - BUFFER CONTAINING THE STRING TO BE JUSTIFIED * IBYT - STARTING BYTE NUMBER (1ST IS 1) * NBYTE - NUMBER OF BYTES TO BE SCANNED * ICNW - LEFT OR RIGHT JUSTIFY * = 0 ---> RIGHT JUSTIFY * NOT 0 ---> LEFT JUSTIFY * .IBUF NOP .IBEG NOP .ILEN NOP .FLAG NOP * JUSTF NOP JSB .ENTR DEF .IBUF LDA .ILEN,I CMA,INA STA COUNT /SAVE LENGTH OF STRING LDB .IBUF CLE,ELB ADB .IBEG,I ADB DM1 STB .IBUF /SAVE STARTING POSITION LDA 1 ADA DM1 ADA .ILEN,I STA LAST /SAVE END POSITION * LOOP1 EQU * LBT CPA BLANC RSS JMP SUIT ISZ COUNT JMP LOOP1 JMP JUSTF,I /ONLY BLANKS.. EXIT * SUIT EQU * ADB DM1 STB P1 /SAVE STARTING BYTE OF STRING LDB LAST * LOOP2 EQU * LBT CPA BLANC RSS JMP FIN /LAST SIGNIFICANT CHAR IS FOUND ADB DM2 ISZ COUNT JMP LOOP2 JMP JUSTF,I * FIN EQU * STB P2 /SAVE LAST SIGNIFICANT CHAR. + 1 * LDA .FLAG,I SZA,RSS JMP RIGHT /MUST BE   RIGHT JUSTIFIED * LDB .IBUF CPB P1 SOMETHING TO DO ? JMP JUSTF,I NO, RETURN LDA COUNT CMA,INA STA COUNT LDA P1 MBT COUNT /LEFT-JUSTIFIED LDA BLANC LOOP3 CPB P2 JMP JUSTF,I /DONE SBT /FILL WITH BLANKS JMP LOOP3 * * * RIGHT ADB DM1 CPB LAST SOMETHING TO DO ? JMP JUSTF,I NO, RETURN RSS YES, SWAP CHARACTERS RIGH1 LDB P2 LBT STA CHAR /SAVE CHARACTER ADB DM2 STB P2 INB LDA BLANC SBT /REPLACE WITH BLANK LDA CHAR LDB LAST SBT ADB DM2 STB LAST ISZ COUNT JMP RIGH1 JMP JUSTF,I * * RESERVATIONS * DM1 DEC -1 DM2 DEC -2 COUNT NOP CHAR NOP BLANC OCT 40 LAST NOP P1 NOP P2 NOP END h   92903-18035 1805 S C0122 &JPAR              H0101 TFTN4 LOGICAL FUNCTION JPAR(IBUFI,LNBYI,NOF,IBUFO,LNBYO,IFLG .,JVAL),. 92903-16001 REV.1805 780221 C C SOURCE 92903-18035 C C C C ************************************************************** C * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * C ************************************************************** C C C REV: 12/MAY/77 JCM C REV: 11/JAN/77 FG OR FOR MULTIPOINT TERMINAL C C C********************************************************************* C* * C* THIS IS A LOGICAL FUNCTION USED TO PARSE STRINGS. * C* MEANING OF PARAMETERS : * C* IBUFI = INPUT BUFFER * C* LNBYI = LENGTH OF INPUT BUFFER IN BYTES * C* NOF = SEQUENTIAL # OF FIELD TO FIND (FIRST IS 1) * C* IBUFO = OUTPUT BUFFER * C* LNBYO = LENGTH OF OUTPUT BUFFER IN BYTES * C* IFLG = RETURN FLAG * C* JVAL = INTEGER OR REAL VALUE OF IBUFI * C* * C* FIELD SEPARATOR IS = OCT 37 OR = OCT 36 * C* * C* THIS FUNCTION IS .FALSE. IF ALL IS O.K. - THE FIELD # NOF * C* HAS BEEN FOUND AND MOVED IN OUTPUT BUFFER AND : * C* * C* IFLG = 0 FIELD IS ONLY BLANKS * C* IFLG = 1 FIELD IS INTEGER POS OR NE JVAL=IN}TEGER * C* IFLG = 3 FIELD IS ASCII (FROM SPACE TO _) * C* * C* THIS FUNCTION IS .TRUE. IF : * C* * C* * C* -AN ILLEGAL CHARACTER (NON PRINTABLE OR LOWER CASE) * C* HAS BEEN FOUND (IFLG=5) * C* * C* -THERE IS AN ERROR : * C* NOF IS NEGATIVE OR NOT IN THE BUFFER RANGE * C* IN THIS CASE IFLG = 6 * C* * C* -A SPECIAL STRING HAS BEEN FOUND : * C* -INSERT IFLG=4 * C* -HELP IFLG=7 * C* -LAST SCREEN IFLG=8 * C* -ABORT PROGRAM IFLG=9 * C* * C********************************************************************* C C DECLARATIONS : C LOGICAL ISSPA,INUM DIMENSION IBUFI(1),IBUFO(1),JVAL(2) DATA IUS/17440B/,IRS/17040B/ C C INITIALISE BUFFER AND PARAMETERS C JPAR=.FALSE. IE=(LNBYO+1)/2 DO 3 I=1,IE 3 IBUFO(I)=2H C C FIND BEGINING OF FIELD # NOF C J=0 IFLG=6 IF(NOF.LE.0) GO TO 140 IF(NOF.EQ.1) GO TO 30 DO 20 I=1,NOF-1 10 IF(J.EQ.LNBYI) GO TO 140 J=J+1 N=IGET1(IBUFI,J) IF(N.NE.IUS .AND. N.NE.IRS) GOTO 10 20 CONTINUE C C MOVE CHARACTERS IN OUPUT BUFFER AND CHECK FOR NON PRINTABLE ASCII C 30 IFLG=3 DO 50 I=1,LNBYO 9@ J=J+1 M=IGET1(IBUFI,J) L=IAND(IALF2(M),377B) IF((L.LE.36B).OR.(L.GT.137B)) GO TO 130 50 CALL PUTCA(IBUFO,M,I) C C NORMAL RETURN . ONLY BLANKS ? C IF(ISSPA(IBUFO,1,LNBYO)) GO TO 60 IFLG=0 RETURN C C NORMAL RETURN . INTEGER ? C 60 IF(INUM(IBUFO,1,LNBYO,JVAL)) GO TO 120 IFLG=1 120 RETURN C C MISSING INTEGER NEGATIVE AND REAL CHECKS !!!!! C C C ERROR RETURN C 130 IFLG=5 IF(L.EQ.151B) IFLG=4 IF(L.EQ.150B) IFLG=7 IF(L.EQ.163B) IFLG=8 IF(L.EQ.141B) IFLG=9 140 JPAR=.TRUE. 145 RETURN END END$ C |  92903-18036 1805 S C0122 &KLCLS              H0101 ASMB HED FLUSH A CLASS I/O (RTE-III/IV) F. GAULLIER 15/APR/77 NAM KLCLS,7 . 92903-16001 REV.1805 780112 * * SOURCE 92903-18036 * SPC 2 ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** SPC 2 * * THIS ROUTINE DO A COMPLETE CLEAN UP OF A CLASS I/O * AND TERMINATE BY RELEASING THE CLASS. * WHEN SOME I/O DEVICE HAVE NOT COMPLETED THEIR OPERATIONS * A TIMEOUT OF 10 MSEC IS FORCED TO THESE PERIPHERALS IN * ORDER TO GET THE CLASS BUFFER AND RELEASE THE SAM. * * CALLING SEQUENCE: * * IF ( KLCLS(ICLAS) ) GOTO ERROR * ICLAS IS THE CLASS NUMBER * SPC 2 A EQU 0 B EQU 1 SUP PRESS EXTENDED LISTING SPC 1 EXT EXEC,$LIBR,$LIBX,.ENTR ENT KLCLS SPC 2 $OFF NOP JSB $LIBR OCT 0 PRIVILEDGE ROUTINE JMP $OFF,I SPC 1 $ON NOP JSB $LIBX EXIT FROM PRIVILEDGE ROUTINE DEF $ON SPC 2 .CL# NOP CLASS I/O WORD KLCLS NOP JSB .ENTR DEF .CL# * LDA .CL#,I AND MSK CLEAR BITS 15-14-13 SZA,RSS JMP OKRTN STA CLASW SAVE CLASS I/O WORD JSB EXEC DO A WRITE/READ CLASS I/O DEF *+8 DEF NAB20 WRITE/READ - NO ABORT DEF D0 DEF * DUMMY BUF DEF D1 DUMMY LEN DEF * DUMMY PARAMETERS DEF * DUMMY PARAMETERS DEF CLASW CLASS WORD JMP REL50 ERROR ! CHECK IT IS "IO 00" * LDA CLASW RECALL CLASS WORD IOR BIT15 SET "NO WAIT BIT" STA CLASS SPC 1 RELC3 JSB EXEC GET TO DE-ALLOCATE DEF *+5 DEF NAB21 GET CLASS - NO ABORT DEF CLASS CLASS WORD DEF TEMP DUMMY BUFFER DEF D1 JMP REL50 ERROR RETURN CHECK CODE SSA,RSS JMP RELC3 LOOP UNTIL END OF CLASS SPC 1 STA #RQ SAVE -(N-1) REQUEST IN QUEUE CMA,SZA,RSS # OF REQUEST IN QUEUE JMP OKRTN CLASS IS EMPTY, EXIT. SPC 1 LDA EQTA GO THROUGH ALL EQT TO FORCE A TO STA EQTPT ON ALL DEVICES WAITTING ON THIS CLASS LDA EQT# CMA,INA STA EQTCT SPC 1 REL20 XLA EQTPT,I GET EQT1 SZA,RSS EQT BUSY ? JMP REL24 NO, GOTO NEXT ONE SSA HLT INA GET 2ND WORD OF SAM BUFFER STA TEMP SPC 1 ********************************** PRIVILEDGE MODE JSB $OFF XLA TEMP,I GET WORD 2 RAL SSA,SLA,RSS T FIEL = 3 ? JMP REL22 NO, FORGET IT LDA TEMP YES, IT IS A CLASS REQUEST ADA D3 GO CHECK CLASS WORD XLA A,I GET CLASS WORD FROM SAM BUFFER AND MSK CPA CLASW BELONG TO THIS CLASS ? RSS YES, GO SET A TIME OUT JMP REL22 NO, SKIP SET TIME OUT CODE LDA EQTPT RECALL EQT1 ADA D14 CCB SET A TIMEOUT OF STB A,I 10 MSEC INTO EQT15 ISZ #RQ UPDATE # OF PENDING RQ (NEVER SKIP !!) REL22 JSB $ON ********************************** PRIVILEDGE MODE $END SPC 1 REL24 LDA #RQ RECALL -(N-1) REQUEST LEFT IN THE QUEUE CMA,SZA,RSS ALL PENDING REQUEST FOUNDED ? JMP REL30 YES, GO GET THEM * LDA EQTPT GOTO NEXT EQT ADA D15 STA EQTPT ISZ EQTCT MORE EQT ? JMP REL20 YES, CONTINUE * REL30 LDA =D-12000 NO, WAIT ABOUT ISZ A 30 MS ON XE JMP *-1 BEFORE JMP RELC3 GETTING CLASS REQUESTS SPC 2 REL50 CPA ASCIO CHECK THAT IT IS "IO 00" RSS JMP ERRTN v ERROR RETURN CPB ASC00 JMP OKRTN OK, RETURN TO USER ERRTN CCA ERROR RETURN JMP KLCLS,I SPC 1 OKRTN CLA EXIT WITH A = 0 JMP KLCLS,I SPC 3 NAB20 OCT 100024 NAB21 OCT 100025 ASCIO ASC 1,IO ASC00 ASC 1,00 EQTA EQU 1650B EQT# EQU EQTA+1 SPC 1 D0 DEC 0 D1 DEC 1 D3 DEC 3 D14 DEC 14 D15 DEC 15 BIT15 OCT 100000 MSK OCT 17777 CLASS EQU .CL# CLASW NOP TEMP EQU $ON #RQ NOP EQTPT NOP EQTCT NOP END   92903-18037 1805 S C0122 &LNCAR              H0101 {FTN4 FUNCTION LNCAR(IBUF,NCAR .,NBCAR),. 92903-16001 REV.1805 770712 C C SOURCE 92903-180037 C C C C ************************************************************** C * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * C ************************************************************** C C C********************************************************************* C* * C* THIS FUNCTION IS USED TO TO COMPUTE THE REAL LENGTH * C* OF A STRING EXCLUDING TRAILING BLANKS. * C* * C* PARAMETERS : * C* IBUF : INPUT BUFFER * STRING * C* NCAR : # OF THE FIRST CHAR TO USE IN * C* IBUF * C* NBCAR : # OF CHARACTERS TO BE USED IN * C* IBUF * C* * C********************************************************************* C C DIMENSION IBUF(1) LNCAR=NBCAR DO 100 I=1,NBCAR IF(IGET1(IBUF,NCAR+NBCAR-I).NE.1H ) GO TO 200 100 LNCAR=LNCAR-1 200 RETURN END END$   92903-18038 1805 S C0122 &LNGT              H0101 \ASMB HED S/P LNGT (LIKE LNGTH IN TCS B) P. SENANT NAM LNGT,7 . 92903-16001 REV.1805 740910 * * SOURCE 92903-18038 * SPC 2 ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** SPC 2 ENT LNGT EXT .ENTR ADDR NOP SIZE NOP LNGT NOP JSB .ENTR DEF ADDR CCB ADB ADDR ADB SIZE,I /CALCULATE LAST WORD OF ARRAY LDA SIZE,I CMA,INA /FORM NEG. COUNT STA SIZE LNGT1 LDA B,I CPA =B20040 /BLANKS? JMP LNGT2 /YES LDB SIZE /NO CMB,INB /CONVERT TO POSITIVE COUNT RBL /X2 FOR CHARACTERS AND =B377 CPA =B40 /LAST ONE A BLANK ADB =D-1 YES-DECREMENT COUNT STB A JMP LNGT,I /RETURN WITH ANSWER IN A LNGT2 EQU * ADB =D-1 BACK UP POINTER ISZ SIZE DONE? JMP LNGT1 /NO CLA /YES JMP LNGT,I A EQU 0 B EQU 1 END   92903-18039 1805 S C0122 &MADSP              H0101 ASMB HED RTE-IV LARGEST PARTITION EVER NAM MADSP,7 . 92903-16001 REV.1805 780226 * * SOURCE 92903-18039 * SPC 2 ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** SPC 2 EXT .ENTR,$DLP,$SDA,$PLP,$OPSY ENT MADSP SPC 2 * THIS SUBROUTINE RETURN THE 3 MAXIMUM ADDRESS SPACE * RETURN THE # OF PAGES, INCLUDED BASE PAGE. * * CALLING SEQUENCE: * CALL MADSP(IBUF) * IBUF(1) = MAXIMUM PROGRAM ADDRESS SPACE WITHOUT SYST. COMMMON * IBUF(2) = MAXIMUM PROGRAM ADDRESS SPACE WITH SYST. COMMON * IBUF(3) = MAXIMUM PROGRAM ADDRESS SPACE WITH TABLE AREA II * .BUF NOP MADSP NOP JSB .ENTR DEF .BUF * CLA SET ERROR INDICATOR STA .BUF,I * LDA $OPSY GET SYSTEM TYPE CPA DM9 RTE-IV ? RSS JMP MADSP,I NO, RETURN SPC 1 LDA $DLP GET TYPE IV WITHOUT SSGA ALF,ALF SET IT INTO NUMBER RAR,RAR OF PAGES CMA,INA AND COMPUTE PARTITION ADA D32 SIZE INA FOR BASE PAGE STA .BUF,I AND RETURN IT TO THE USER ISZ .BUF * LDA $SDA GET TYPE IV WITH SSGA CMA,INA COMPUTE NUMBER OF PAGE ADA D32 INA FOR BASE PAGE STA .BUF,I ISZ .BUF * LDA $PLP GET TYPE III ALF,ALF SET IT IN NUMBER OF PAGES RAR,RAR CMA,INA COMPUTE NUMBER OF PAGES ADA D32 INA FOR BASE PAGE STA .BUF,I JMP MADSP,I SPC 2 DM9 DEC -9 D32 DEC 32 END +    92903-18040 1805 S C0122 &MOVCA              H0101 wASMB HED ** S/P MOVCA (21MX ONLY) F. GAULLIER 07/SEP/77 NAM MOVCA,7 . 92903-16001 REV.1805 760907 * * SOURCE 92903-18040 * SPC 2 ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** SPC 2 EXT .ENTR ENT MOVCA SUP * * THIS PROGRAM MOVES A STRING * 21MX INSTRUCTIONS ARE USED * DM1 DEC -1 * .BUF1 NOP .N1 NOP .BUF2 NOP .N2 NOP .NC NOP * MOVCA NOP JSB .ENTR DEF .BUF1 * LDA .BUF1 CLE,ELA ADA DM1 ADA .N1,I LDB .BUF2 CLE,ELB ADB DM1 ADB .N2,I MBT .NC,I JMP MOVCA,I END   92903-18041 1805 S C0122 &MOVCX              H0101 xASMB NAM MOVCX,7 . 92903-16001 REV.1805 770512 * * SOURCE 92903-18041 * SPC 2 ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** SPC 2 ********************************************************************** * * * THIS SUBROUTINE MOVES CHARACTERS FROM A * * SOURCE BUFFER TO A DESTINATION BUFFER . SEVERAL FIELDS MAY BE * * MOVED IN ONE CALL . THESE FIELDS MUST BE CONTIGUOUS IN THE * * SOURCE BUFFER . * * * * THE CALLING SEQUENCE IS : * * * * JSB MOVCX * * DEF *+6 * * DEF BUFS SOURCE BUFFER ADDRESS * * DEF SOF SOURCE CHARACTER OFFSET ADDRESS (TABLE)* * DEF BUFD DEST. BUFFER ADDRESS (TABLE)* * DEF OFSET OFFSET IN BYTE ADDED TO SOURCE OFFSET * * DEF DBLEN DEST. BUFFER LENGTH (IN BYTE) * * (USED ONLY FOR CONVERSION) * * * * THREE TABLES ARE NECESSARY IN THE CALLING PROGRAM : * * * * 1)- TABLE OF THE OFFSETS IN THE SOURCE BUFFER : IF N FIELDS * * ARE TO BE MOVED :  * * SOF DEC SOF1 SOURCE OFFSET OF FIELD # 1 * * DEC SOF2 SOURCE OFFSET OF FIELD # 2 * * . * * . * * DEC SOFN SOURCE OFFSET OF FIELD # N * * DEC SOF(N+1)SOURCE OFFSET OF FIELD # N+1 * * DEC -1 END OF TABLE * * * * 2)- TABLE OF THE DESTINATIONS BUFFERS ADDRESSES : * * BUFD DEF BUFD1 DEST. BUFFER ADDRESS FOR FIELD # 1 * * DEF BUFD2,I DEST. BUFFER ADDRESS FOR FIELD # 2 * * . * * . * * DEF BUFDP,I DEST. BUFFER ADDRESS FOR FIELD # P * * DEF BUFDQ,I DEST. BUFFER ADDRESS FOR FIELD # Q * * . * * . * * DEF BUFDN DEST. BUFFER ADDRESS FOR FIELD # N * * * * 3)- TABLE OF THE DESTINATIONS BUFFERS LENGTH : * * THIS TABLE IS USED ONLY WHEN INTEGER CONVERSION ARE * * REQUIRED, THIS IS INDICATED BY AN INDIRECT ADDRESS IN * * THE TABLE 2 : DESTINATIONS BUFFERS ADDRESSES. * * THIS TABLE HAS NOT THE SAME LENGTH THAN TABLE 1 AND 2, * * THIS TABLE SHOULD HAVE AN ENTRY ONLY WHEN IT IS NECESSARY. * * * * DBLEN DEC DBL2 DEST. BUFFER LENGTH FOR FIELD # 2 * * . | * * DEC DBLP DEST. BUFFER LENGTH FOR FIELD # P * * DEC DBLQ DEST. BUFFER LENGTH FOR FIELD # Q * * * ********************************************************************** * * ENT MOVCX EXT .ENTR,MOVCA,JASC * * GET ADDRESSES OF CALLING PARAMETERS : * .P1 NOP SOURCE BUFF. .P2 NOP SOURCE CHAR. OFFSET .P3 NOP DEST. BUFFER .P4 NOP DEST. OFFSET .P5 NOP QUESTION # MOVCX NOP ENTRY POINT JSB .ENTR DEF .P1 * * COMPUTE # OF CHARACTERS TO MOVE FOR THIS FIELD * L1 LDA .P2 SOURCE CHAR. OFFSET ADDRESS INA INCREMENT ADDRESS LDB A,I GET NEXT SOURCE CHAR. OFFSET CPB .D1 -1 ? END OF TABLE ? JMP MOVCX,I YES RETURN ! LDA .P2,I NO COMPUTE CMA,INA FIELD LENGTH ADB A TO MOVE. STB LNGTH STORE IT * * COMPUTE SOURCE CHAR. OFFSET . * LDB .P2,I GET OFFSET ADB .P4,I TRUE CHAR. OFFSET FOR THIS FIELD STB SOF STORE IT * * CHECK FOR INTEGER CONVERSION * LDA .P3,I GET DEST. BUFF ADD STA DEBAD SET IT TO MOVCA CALL SSA,RSS INTEGER CONVERSION REQUIRED ? JMP L4 NO, DO THE MOVE * ELA,CLE,ERA YES, CLEAR BIT15 STA DEBA. LDA LNGTH ERA DLD D1 SEZ SWP DST BUF+1 CLA INIT BINARY WORD TO NUL STA TEMP JSB MOVCA TRANSFERT BINARY DATA DEF *+6 INTO A WORD TO DO DEF .P1,I THE CONVERSION DEF SOF DEF TEMP OUTPUT BUFFER (I HOPE THAT DEF BUF+1 SOURCE LENGTH IS NOT MORE THAN 2 CHAR.) DEF BUF+2 FORCE LENGTH IN BYTE * JSB JASC DO THE CONVERSION DEF *+5 DEF TEMP DEF BUF INTO A TEMPORARY BUFFEXR DEF D1 DEF D6 * LDA BUF+2 LDB ASC. SET SPACE IF IT IS ZERO CPA ASC.0 STB BUF+2 * LDA .P5,I GET DESTINATION LENGTH IN BYTE CMA,INA COMPUTE OFSET IN THE TEMPORARY BUFFER ADA D7 STA TEMP * JSB MOVCA MOVE BYTE IN DESTINATION BUFFER DEF *+6 DEF BUF DEF TEMP OFFSET IN TEMPORARY BUFFER DEBA. NOP DESTINATION ADDR DEF D1 DEF .P5,I # OF CHAR. TO MOVE ISZ .P5 BUMP POINTER IN DEST. LEN TABLE JMP L6 * * MOVE CHARACTERS ! * L4 JSB MOVCA DEF *+6 DEF .P1,I SOURCE BUFF ADDRESS DEF SOF SOURCE OFFSET DEBAD NOP DEST BUFF ADDRESS DEF D1 DEST OFFSET DEF LNGTH # OF CHAR. TO MOVE * * INCREMENT ADDRESSES FOR NEXT MOVE * L6 ISZ .P2 SOURCE OFFSET ISZ .P3 DEST BUFFER JMP L1 GO TO NEXT MOVE * * DATA AND STORAGE * A EQU 0 D1 DEC 1 D2 DEC 2 D6 DEC 6 D7 DEC 7 .D1 DEC -1 ASC. ASC 1, ASC.0 ASC 1, 0 LNGTH NOP # OF CHARS TO MOVE BUF BSS 3 TEMP EQU DEBAD SOF EQU BUF END .  92903-18042 1805 S C0122 &MOVEW              H0101 {ASMB HED S/P MOVEW (15/10/75) F. GAULLIER NAM MOVEW,7 . 92903-16001 REV.1805 760907 * * SOURCE 92903-18042 * SPC 2 ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** SPC 2 EXT .ENTR,&MVW ENT MOVEW * * THIS PROGRAM MOVES AN ARRAY * * CALL MOVEW(IBUFS,IBUFD,# WORDS) * AINI NOP AFINI NOP NMO NOP MOVEW NOP JSB .ENTR DEF AINI * LDA NMO,I STA NM * LDA AINI LDB AFINI JSB &MVW NM NOP * JMP MOVEW,I END !  92903-18043 1805 S C0122 &NAMCK              H0101 lASMB NAM NAMCK,7 . 92903-16001 REV.1805 770712 * * SOURCE 92903-18043 * * SPC 2 ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** SPC 2 * * SUBROUTINE USED TO CALL NAM.. ROUTINE FROM A * FORTRAN PROGRAM * * ENT NAMCK EXT NAM..,.ENTR * NAME NOP NAMCK NOP JSB .ENTR DEF NAME JSB NAM.. DEF *+2 DEF NAME,I SZA CCA JMP NAMCK,I END   92903-18044 1805 S C0122 &NUL              H0101 ^dASMB HED S/P NUL (15/10/75) F. GAULLIER NAM NUL,7 . 92903-16001 REV.1805 760907 * * SOURCE 92903-18044 * SPC 2 ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** SPC 2 ENT NUL EXT .ENTR,&REMP SPC 2 P BSS 2 NUL NOP JSB .ENTR DEF P * LDB P+1,I CMB,INB STB N LDA P CLB JSB REMPL N NOP JMP NUL,I * REMPL EQU &REMP END t  92903-18045 1805 S C0122 &NUMD              H0101 eASMB HED NUMD/ISNUM (21MX ONLY) F. GAULLIER 07/SEP/77 NAM NUMD,7 . 92903-16001 REV.1805 770907 * * SOURCE 92903-18045 * SPC 2 ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** SPC 2 EXT .ENTR ENT NUMD,ISNUM SUP * * "NUMD" CONVERTS A NUMERIC STRING IN BINARY (INTEGER ONLY) * IF THE STRING IS NOT NUMERIC , -1 IS RETURNED * IF AN OVERFLOW (32767) IS DETECTED, * THEN "-1" IS RETURNED * * "ISNUM" IS A LOGICAL FUNCTION WHICH IS ABLE TO TEST * IF A STRING IS NUMERIC. * .FALSE. / 0 (E=0) : NUMERIC * .TRUE. (E=1) : NOT NUMERIC * BLAN OCT 40 MASK OCT 377 DM10 DEC -10 OM12 EQU DM10 TEMP NOP MEM NOP SPFL NOP OM60 OCT -60 D10 DEC 10 DM1 DEC -1 SPC 2 NUMD NOP LDA NUMD CCB SP. STA SP STB SPFL JMP SP+1 * ISNUM NOP LDA ISNUM CLB,INB JMP SP. SPC 1 .BUFF NOP ADRESSE BUFFER .N1 NOP NUMERO 1ER CARACTERE .NC NOP NOMBRE DE CARACTERES SP NOP JSB .ENTR DEF .BUFF * LDA .NC,I CMA,INA CCE,SSA,RSS JMP SP,I OK ! ---> .FALSE. E=1 STA .NC CLA STA TEMP LDB .BUFF CLE,ELB ADB DM1 ADB .N1,I * LOOP1 LBT CPA BLAN RSS JMP TEST2 ISZ .NC JMP LOOP1 CLA,CCE OK ! ---> .FALSE. / 0 E=1 JMP SP,I * LOOP2 LDB .N1 LBT TEST2 STA MEM STB .N1 ADA OM60 SSA JMP TE3 LDB OM12 ADB 0 SS  B NUMERIQUE ? JMP TE4 OUI TE3 LDA MEM JMP TEST3 NON , TEST SI BLANC TE4 STA MEM LDA TEMP MPY D10 SSA OVERFLOW ? JSB ER. YES CCE,SZB OVERFLOW ? JSB ER. ADA MEM SOC MPY HAS CLEARED THE O JSB ER. STA TEMP NON , OK ISZ .NC JMP LOOP2 JMP SP,I OK ! ---> .FALSE. E=1 * TEST3 LDB .N1 RSS LOOP3 LBT CPA BLAN CCE,RSS JMP ERR NI NUMERIQUE NI BLANC, ERREUR ! ISZ .NC JMP LOOP3 LDA TEMP JMP SP,I OK! ---> .FALSE. E=1 SPC 1 ER. NOP LDA SPFL SSA,RSS IS NUMD ROUTINE ? JMP ER.,I NO, CONTINUE. LDB .N1 ERR ADB DM1 B=BYTE POINTER TO FIRST BAD CHAR. CCA,CLE ERROR ! ---> .TRUE. E=0 JMP SP,I END V   92903-18046 1805 S C0122 &PRTSZ              H0101 ASMB HED RTE-III/IV PARTITION SIZE RETREIVE SUBROUTINE NAM PRTSZ,7 . 92903-16001 REV.1805 780112 * * SOURCE 92903-18046 * SPC 2 ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** SPC 2 * DATE: 22/APR/77 * NAME: PRTSZ * SOURCE: &PRTSZ * RELOC: %PRTSZ * PGMR: DANIEL POT HPG * REV: 12/JAN/78 MOD FOR RTE-IV FG SPC 2 * ************************************** * * THIS SUBROUTINE RETURNS THE SIZES * * * OF THE TEN BIGGEST PARTITIONS USED * * * BY THE CURRENTLY RUNNING SYSTEM. * * * IT RETURN ALSO THE NUMBER OF PART. * * ************************************** SPC 2 * CALLING SEQUENCE: * * DIMENSION IBUF(10) * INTEGER PRTSZ * .. * * NBPART = PRTSZ(IBUF) * * IBUF(10) = THE LARGEST PARTITION SIZE OF THE SYSTEM. * * IF NOT RET-III OR RTE-IV RETURN ZERO FOR # OF PRT * AND PRT SIZE. SPC 2 ENT PRTSZ EXT .ENTR SUP EXT $MATA,$OPSY,$MNP SPC 2 TEMP NOP NBPRT NOP TOTAL NUMBER OF PARTITION LASTD NOP NINTH ADRESS OF OUTPUT BUFFER LLSTD NOP TENTH ADRESS OF OUTPUT BUFFER PONTR NOP POINTER OF THE OUTPUT BUFFER CONT NOP LOOP COUNTER MATPT NOP $MATA POINTER SPC 1 ADBUF NOP PRTSZ NOP JSB .ENTR DEF ADBUF RETURN BUFFER ADRESS * LDA ADBUF ADA =D8 STA LASTD INITIALISES LASTD INA STA LLSTD IMNITIALISES LLSTD LDA =D-10 STA CONT CLA STA NBPRT INIT NUMBER OF PARTITION LDB ADBUF STvDA 1,I INB ISZ CONT JMP *-3 CLEARS OUTPUT BUFFER * * * LDB $OPSY GET SYSTEM NUMBER CPB =D-9 RTE-IV ? JMP RTE4 YES. CPB =D-1 RTE-III ? RSS YES JMP EXIT RETURN, ERROR !! * LDB $MATA RTE-III, GET THE MAT ADDRESS ADB =D-1 LDA 1,I GET THE NUMBER OF MAT ENTRY LDB =D6 RTE-III MAT ENTRY LENGTH JMP PRTS3 * RTE4 LDA $MNP RTE-IV, GET THE NUMBER OF MAT ENTRY LDB =D7 RTE-IV MAT ENTRY LENGTH * PRTS3 STA NBPRT STB TEMP SAVE MAT ENTRY LENGTH CMA,INA STA CONT NUMBER OF PARTITIONS * LDB $MATA LOOP STB MATPT XLA 1,I SSA JMP NEXT ADB =D4 XLA 1,I AND =B1777 INA STA ADBUF,I JSB TRI LDB MATPT NEXT ADB TEMP GO TO NEXT ENTRY ISZ CONT JMP LOOP EXIT LDA NBPRT RECALL NUMBER OF PARTITION JMP PRTSZ,I SPC 2 TRI NOP LDA ADBUF GET FIRST OUTPUT BUFFER ADRESS STA PONTR INITIALISES POINTER TRI1 DLD PONTR,I GET FIRST AND SECOND PARTITION SIZE CMA,INA CALCULATES: -(PARTITION SIZE) ADA 1 CALCULATES PRT#2-PRT#1 SZA,RSS JMP TRI2 SSA,RSS PARTITIONS SIZES MUST BE REVERSED JMP TRI2 RIGHT ORDER: CONTINUE SWP LDB PONTR,I DST PONTR,I LDA PONTR CPA ADBUF JMP TRI2 CCA ADA PONTR STA PONTR RESTORE PREVIOUS OUTPUT BUFFER ADRESS WORD JMP TRI1 RE-BEGIN THE CLASSING OPERATION TRI2 ISZ PONTR LDA PONTR GET OUTPUT BUFFER ADRESS CPA LLSTD COMPARE TO LAST OUTPUT BUFFER ADRESS WORD JMP TRI,I CLASSING OPERATION IS FINISHED JMP TRI1 CONTINUE CLASSING OPEARTION END PRTSZ F   92903-18047 1805 S C0122 &PUTCA              H0101 ASMB HED S/P PUTCA (21MX ONLY) 15/10/75 P. SENANT NAM PUTCA,7 . 92903-16001 REV.1805 760907 * * SOURCE 92903-18047 * SPC 2 ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** SPC 2 EXT .ENTR ENT PUTCA * * THIS PROGRAM PUTS ONE BYTE IN A STRING * 21MX INSTRUCTIONS ARE USED * * DM1 DEC -1 * .BUFF NOP .CAR NOP CARACTERE A INTRODUIRE .N NOP NUM REL. DU CARAC. DS .BUFF * PUTCA NOP JSB .ENTR DEF .BUFF LDA .CAR,I ALF,ALF LDB .BUFF CLE,ELB ADB DM1 ADB .N,I SBT JMP PUTCA,I END   92903-18048 1805 S C0122 &RASC              H0101 qoASMB HED . "RASC" REAL --> ASCII TOM HIRATA 5/JUN/78 NAM RASC,7 . 92903-16001 REV.1805 780605 * * SOURCE 92903-18048 * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * EXT .FLUN,.CFER,.XPAK,IFIX,FLOAT,.ENTR ENT RASC SUP * ** ** THIS FORTRAN CALLABLE ROUTINE DOES THE CONVERSION FROM ** FLOATING POINT TO ASCII. ** CALLING SEQUENCE : ** CALL RASC(VAL,IBUF,ICH,NFLD,ID) ** VAL = FLOATING POINT NUMBER ** IBUF = BUFFER WHERE ASCII HAS TO BE STORED ** ICH = STARTING CHARACTER IN IBUF ** NFLD = FIELD LENGTH (W FIELD) ** ID = FRACTION LENGTH (D FIELD) ** (IF D = -1 : NO DECIMAL POINT IS PRINTED) ** THE CONVERSION IS DONE IN FW.D FORMAT. ** ** ** NOTE: THIS PROGRAM WAS ORIGINALLY WRITTEN BY WIM ROELANDTS (HP ** BRUSSELS, AUG'76). IN ORDER TO INCREASE THE ACCURACY OF ** THE CONVERSION FROM REAL TO ASCII, THE MAJORITY OF THE CODE ** WAS REPLACED BY THE FORMATTER CONVERSION ROUTINES OBTAINED ** FROM BILL GIBBONS, DATA SYSTEMS. THESE MODIFICATIONS WERE ** DONE BY TOM HIRATA (DATA SYSTEMS, JUN'78). * * ADX NOP BUF NOP ICH NOP W NOP D NOP RASC NOP JSB .ENTR DEF ADX * ** SET POINTER AND COUNTERS * LDA BUF MAKE POINTER CLE,ELA ADA ICH,I ADD OFFSET ADA MIN1 STA PIOB SAVE POINTER STA PIOB$ SAVE IT FOR ERROR RETURN. LDA W,I SET FIELD LENGTH SZA ZERO OR SSA NEGATIF ? JMP ERR YES, ERROR CMA,INA NEGA'TIF STA WS STA WS$ SAVE IT FOR ERROR RETURN. LDA D,I GET D LENGTH STA SAVED SAVE D LENGTH CMA SET TO -D-1 SSA,RSS POS ? SZA,RSS BUT NOT ZERO ? RSS JMP ERR YES, ERROR STA DS LDA MIN5 INIT CONSTANTS FOR FMTR STA TEMP7 ROUTINES. LDA ....2 STA TYPE STA LENTH CLA STA ALL9S CLEAR ALL 9'S FLAG & STA RNFLG ROUND-OFF FLAG. STA ZERO CLEAR ZERO FLAG. LDA MIN9 SET WHICH DIGIT STA DGCTR TO USE FOR ROUNDING OFF. STA SGCNT SIGNIFICANT DIGITS CTR. * ** TEST FOR ZERO * DLD ADX,I GET THE NUMBER SZA 1ST WORD ZERO? JMP CON0 NO, IT ISN'T ZERO. SZB,RSS 2ND WORD ZERO? ISZ ZERO YES, SET ZERO FLAG. * ** SET BLANK COUNTER * CON0 LDA DS MAKE : CMA ADA WS W-D-1 CMA STA BCNT AS INITIAL BLANK COUNTER * JSB OUTPT GO CONVERT THE REAL NO. WITH FMT ROUTINE. LDA EXPON SUBTRACT EXPONENT FROM THE BLANK STA SAVEX (SAVE IT) SSA COUNTER (BCNT) ONLY IF IT IS POSITIVE. JMP CON1 CMA,INA NEGATE IT ADA BCNT STA BCNT CON1 LDB BCNT LDA SIGN -1 IF NEGATIV STA SAVES SAVE THE SIGN. ADB A SSB NEG ? JMP BUCKS YES, FIELD OVERFLOW CMB,INB NEGATE IT STB BCNT SAVE NEG BLANK CTR * STB BCNTX SAVE THESE CONSTANTS FOR LDA WS THE ROUND-OFF ROUTINE. STA WSX SZB,RSS ANY BLANKS? JMP CON4 NO BLANKS, GO OUTPUT THE NUMBER. * CON5 LDA B40 GET A BLANK JSB STOCH SAVE IN OUTPUT BUFFER ISZ BCNT BUMP COUNTER JMP CON5 LOOP CON4 ISZ SIGN OUTPUT A MINUS ? JMP CON4A NO, CONTINUE LDA B55 YES, DO IT >U JSB STOCH CON4A LDB WS GET FIELD LENGTH LDA B56 GET PERIOD READY CPB DS EQUAL ? JMP CON7 YES, OUTPUT THE PERIOD JSB GETDG LDB RNFLG HAS THE ROUND-OFF SZB DIGIT BEEN REACHED YET? JMP CON4B YES, OUTPUT ONLY ZEROES. CPA ....9 IS IT A 9? RSS YES ISZ ALL9S NO, SET THE NO 9 FLAG. ISZ DGCTR INCREMENT THE ROUND-OFF CTR UNTIL JMP CON4C THE ROUND-OFF DIGIT IS REACHED. STA RNDSV THE ROUND-OFF DIGIT HAS BEEN REACHED, ISZ RNFLG SAVE IT & SET THE ROUND-OFF FLAG. LDA PIOB GET THE ROUND-OFF NO.'S ADDRESS STA PIOBX & SAVE IT. LDA WS ADJUST THE NEG FIELD CMA,INA WIDTH CTR TO IGNORE THE ADA WSX ZEROES THAT WILL STA WSX BE PUT OUT. CON4B CLA OUTPUT A ZERO. CON4C ADA B60 MAKE ASCII CON6 JSB STOCH AND STORE JMP CON4A * CON7 LDB EXPON NEG EXPONENT MEANS THE SSB,RSS NO. IS IN (0,1) JMP CON6 NO. IS NOT IN (0,1) JSB STOCH STORE DECIMAL PT. CON8 LDA B60 GET "0" READY JSB STOCH STORE THE "0" ISZ EXPON DONE? JMP CON8 NO, STORE ANOTHER "0" JMP CON4A YES, GO TO MAIN LOOP. BUCKS LDA B44 GET $ JSB STOCH TO OUTPUT BUFFER JMP BUCKS UNTIL IT IS FULL * ** ERROR SERVICE * ERR LDA A$$ STA BUF,I JMP RASC,I TERMINATE A$$ ASC 1,$$ * ERR$ LDA B44 GET $ LDB PIOB$ GET FIELD ADDRS. ERR$$ SBT STORE $ ISZ WS$ DONE? JMP ERR$$ NO. JMP RASC,I YES, EXIT RASC. * ** SUBROUTINES * * ** SUBROUTINE TO STORE A CHARACTER IN THE BUFFER * STOCH NOP LDB PIOB GET POINTER SBT STORE THE BYTE ISZ PIOB BUMP POINTER ISZ WS BUMP FIELD LENGTH COUNTER JMP STOCH,I AND RETURNۖ * LDA SAVED GET ORIGINAL D FIELD LENGTH. INA,SZA WAS IT -1? JMP STCH5 NO, CONTINUE TO ROUND-OFF ROUTINE. LDA ZERO GET ZERO FLAG. SZA ORIG NO. ZERO? JMP STCH3 YES,GO RETURN "0". CCA DETERMINE IF ORIG NO .GE. 1 ADA SAVEX BY TESTING ITS EXPON SSA,RSS FOR > 0? JMP STCH5 YES, GO TO ROUND-OFF RTN. ISZ SAVES ORIG NO POSITIVE? JMP STCH3 YES, GO RETURN "0". STB HOLDB NO, SAVE B-REG(ADDRS PTR) DLD ADX,I GET ORIG NO SZB,RSS 2ND WORD 0? JMP STCH1 YES, CHECK 1ST WORD. LDB HOLDB NO, RESTORE ADDRS TO B JMP STCH3 & GO STORE "0". STCH1 LDB HOLDB RESTORE ADDRS TO B. CPA B100K 1ST WORD=100000B? JMP STCH2 YES, RETURN "-1". JMP STCH3 NO, RETURN "0". STCH2 LDA B61 GET "1" READY. RSS STCH3 LDA B60 GET "0" READY. ADB MIN1 STORE "0" OR "1" INTO OUTPUT SBT BUFFER. CPA B60 WAS "0" STORED? JMP RASC,I YES, EXIT. ADB MIN2 NO, MUST BACK UP PTR LDA B55 & STORE MINUS SBT SIGN BEFORE JMP RASC,I EXITING. * STCH5 LDA RNFLG GET THE ROUND-OFF FLAG. SZA WAS ROUND-OFF NUMBER REACHED? JMP RND0 YES, ROUND-OFF VALUES ARE ALREADY SET. * STB PIOBX NO, SET UP VALUES SO THAT JSB GETDG ROUND-OFF WILL BE DONE STA RNDSV TO THE LAST DIGIT. RND0 LDA RNDSV GET THE ROUND-OFF DIGIT. ADA MIN5 DIGIT TO CHECK FOR ROUND-OFF. SSA EXIT IF IT IS < 5 OTHERWISE GO JMP RASC,I INTO THE ROUND-OFF ROUTINE. * LDA BCNTX SZA WAS THE BLANK COUNTER 0? JMP RND1 NO. LDA ALL9S YES. ERROR EXIT IF ALL DIGITS WERE SZA,RSS 9'S BECAUSE IT ISN'T POSSIBLE JMP ERR$ TO ROUND OFF. * RND1 CCB N BACK UP THE OUTPUT BYTE PTR. ADB PIOBX STB PIOBX ISZ WSX BUMP FIELD LENGTH COUNTER. RSS JMP ERR SOMETHING'S WRONG. LBT GET LAST BYTE(DIGIT). LDB PIOBX RESTORE B TO CORRECT ADDRESS. CPA B56 DECIMAL PT? JMP RND1 YES, SKIP IT. CPA B40 SPACE? JMP RND3 MUST INSERT A "1". CPA B55 MINUS SIGN? JMP RND3 MUST INSERT A "1". WRONG. INA ROUND DIGIT UP BY ADDING 1 TO IT. CPA B72 WAS IT A 9? JMP RND4 YES. RND2 SBT NO, STORE IT BACK & JMP RASC,I WE'RE DONE. * RND3 STA HOLDA SAVE THE CHARACTER. LDA B61 SBT STORE A "1" LDA MIN2 ADB A LDA HOLDA RESTORE THE CHARACTER & JMP RND2 GO STORE IT. * RND4 LDA B60 MAKE IT 0 & SBT STORE IT BACK. JMP RND1 GOT BACK 1 MORE DIGIT. * ** DATA * A EQU 0 B EQU 1 * PIOB NOP DS NOP BCNT NOP * * * B40 OCT 40 B44 OCT 44 B55 OCT 55 B56 OCT 56 B60 OCT 60 B61 OCT 61 B72 OCT 72 B100K OCT 100000 ALL9S BSS 1 FLG, WILL BE NON-ZERO IF ANY NON-9 ENCOUNTERED WSX BSS 1 HOLD FIELD WIDTH CTR FOR ROUND-OFF ROUTINE BCNTX BSS 1 HOLD BLANK CTR FOR ROUND-OFF ROUTINE RNFLG BSS 1 ROUND-OFF FLAG(1=ROUND-OFF MAY BE NECESSARY) RNDSV BSS 1 SAVE NINTH DIGIT FOR ROUND-OFF ROUTINE. DGCTR BSS 1 COUNTS NO. OF DIGITS PIOBX BSS 1 SAVES ADDRS+1 OF LAST SIGNIFICANT DIGIT. HOLDA BSS 1 TEMP HOLD OF A-REG. HOLDB BSS 1 TEMP HOLD OF B-REG. PIOB$ BSS 1 SAVES INITIAL FIELD PTR ADDRS FOR ERR$ WS$ BSS 1 SAVES INITIAL FIELD LENGTH FOR ERR$ ZERO BSS 1 =1 IF INPUT NO. IS ZERO. SAVED BSS 1 SAVES THE FRACTION LENGTH (D FIELD) SAVES BSS 1 SAVES SIGN OF ORIG NO. SAVEX BSS 1 SAVES THE EXPONENT RETURNED FROM OUTPT. WS BSS 1 FIELD WIDTH. * SPC 4 * CONSTANTS. * ....1 DEC 1 ....2 DEC 2 ....4 DEC 4 ....5 DEC 5 ....9 DEC 9 MIN9 DEC -9 MIN5 DEC -5 MIN4 DEC -4 MIN2 DEC -2 MIN1 DEC -1 * * ADDRESS CONSTANTS AND SHIFT INSTRUCTIONS. * AMANT DEF MANT MULTZ DEF MULT DIVDZ DEF DIVD RRR16 RRR 16 RRL16 RRL 16 * * TEMPS. * MULTA BSS 1 MULTB BSS 1 MULTC BSS 1 MULTD BSS 1 DIVDA EQU MULTA DIVDB EQU MULTB DIVDC EQU MULTC DIVDD EQU MULTD DIVDE BSS 1 DIVDF BSS 1 PTENA BSS 1 PTENB BSS 1 TEMP2 BSS 1 TEMP3 BSS 1 TEMP7 BSS 1 TEMP8 BSS 1 * * LOCALS. * TYPE BSS 1 TYPE. LENTH BSS 1 LENGTH. EXPON BSS 1 DECIMAL EXPONENT. MANT BSS 5 MANTISSA EXP BSS 1 BINARY EXPONENT. MANTP BSS 1 POINTER FWA USED MANTISSA. MANTL BSS 1 POINTER LWA USED MANTISSA RND BSS 1 ROUNDING DIGIT. SGCNT BSS 1 SIGNIFICANT DIGIT COUNT. SIGN BSS 1 SIGN * * ROUTINE TO EXECUTE SHIFT INSTRUCTIONS. * XEQ NOP NOP JMP XEQ,I SKP * NORML - MANTISSA NORMALIZATION. * THE MANTISSA AND EXPONENT ARE ADJUSTED SO THAT THEY * CONTAIN A NORMALIZED VALUE. IT IS ASSUMED THAT THE * INITIAL STATE IS NOT UNNORMLIZED BY MORE THAN 31 BITS. NORML NOP LDB MANT SEE IF NORMALIZED. LDA MANT+1 ASL 1 SOC JMP NORML,I YES, DONE. ASL 15 NO, SEE IF WORD SHIFT. SOC JMP NORM1 NO. SZB,RSS YES, IS SECOND WORD ZERO TOO ? JMP NORM2 YES, IS ZERO. STB MANT NO, DO WORD SHIFT. LDB MANT+2 STB MANT+1 LDB MANT+3 STB MANT+2 LDB MANT+4 STB MANT+3 LDA EXP ADJUST EXPONENT ADA =D-16 STA EXP NORM1 LDA MANT DETERMINE BIT SHIFT. JSB FLOAT B = 30 - 2*SHIFT BRS B = 15-SHIFT ADB =D-15 B = -SHIFT LDA B SAVE SHIFT COUNT CMA,INA,SZA,RSS A = SHIFT. IS IT ZERO ? JMP NORML,I YES, DONE. ADB EXP ADJUST EXPONENT. STB EXP IOR RRL16 SET UP SHIFT. STA XEQ+1 LDA MANT BIT NORMALIZE. LDB MANT+1 JSB XEQ STA MANT LDA MANT+1 LDB MANT+2 JSB XEQ STA MANT+1 LDA MANT+2 LDB MANT+3 JSB XEQ STA MANT+2 LDA MANT+3 CLB JSB XEQ STA MANT+3 JMP NORML,I EXIT. NORM2 STB EXP ZERO, SET EXPONENT ZERO TOO. JMP NORML,I SKP * PTEN - SCALE NUMBER BY A POWER OF TEN. * * PTEN MULTIPLIES THE VALUE IN (MANT...MANT2) AND (EXP) * BY 10**(A). NO CHECK IS MADE FOR OVERFLOW/UNDERFLOW. * * CALLING SEQUENCE: * LDA POWER * JSB PTEN SPC 2 PTEN NOP LDB AMANT SET UP MANTISSA POINTERS. STB MANTP LDB TYPE SZB CPB ....1 ADB ....2 IF TYPE<2, USE EXTRA WORD. ADB MIN1 # WORDS PRECISION TO USE - 1 ADB MANTP LWA USED MANTISSA STB MANTL SZA,RSS IF N=0, LEAVE ALONE. JMP PTEN,I SSA,RSS N>0 ? JMP PTEN1 YES. CMA,INA NO, TAKE IABS(N) STA PTENA LDA ....2 RIGHT SHIFT MANTISSA TWO BITS. JSB RSN LDB DIVDZ SET "DIVIDE" JMP PTEN2 PTEN1 LDB MULTZ SET "MULTIPLY" STA PTENA PTENA = IABS(N) PTEN2 STB PTENB PTENB = ADDR MULT OR DIVD PTEN3 LDA PTENA A=N ADA =D-6 N-6 CLE,SSA N<6 ? (E=0 FOR MULT) JMP PTEN4 YES, GO DO LAST ONE. STA PTENA NO, MULT/DIV BY 10**6 LDA PWR1A+10 LDB PWR1A+11 JSB PTENB,I JMP PTEN3 TRY AGAIN. PTEN4 ADA ....5 A = N-1 RAL,CLE,SLA N=0 ? JMP PTEN5 YES, GO NORMALIZE. ADA PWR10 GET POWER OF TEN. (E=0 FOR MULT.) DLD A,I JSB PTENB,I GO MPY DIV USING IT. PTEN5 LDB MANT NORMALIZE. ASL 1 SOC THERE ? JMP PTEN,I YES. JSB LSONE NO, LEFT SHIFT. JMP PTEN5 AND TRY AGAIN. SKP * POWER OF TEN TABLE. FIRST PART IS (10**I)/2 * FOR I=1,2,3. SECOND SECTION IS IDENTICAL TO 2-WORD * FLOATING EXCEPT THE SECOND WORD HAS BEEN RIGHT * SHIFTED ONE BIT. VALUES ARE 1O**I FOR I=1,6. SPC 2 PWR10 DEF PWR1A BASE ADDRESS. DEC 5 DEC 50 DEC 500 PWR1A DEC 20480,4 10**1 DEC 25600,7 10**2 DEC 32000,10 10**3 DEC 20000,14 10**4 DEC 25000,17 10**5 DEC 31250,20 10**6 SPC 3 * INDIG - ADD INPUT DIGITS TO NUMBER. * * INDIG TAKES 1-4 INPUT DIGITS AND COMBINES THEM WITH THE * RUNNING MANTISSA TO FORM A NEW MANTISSA. THE NEW * MANTISSA IS NOT NORMALIZED AND THE EXPONENT IS INCREASED * BY 16. * * CALLING SEQUENCE: * * * LDA <(10**I)/2, I = # DIGITS> * JSB INDIG SPC 2 INDIG NOP LDB =D-16 MAKE ROOM. CMB,CCE,INB B=16. JSB MULT LDB MANTL ADD DIGIT(S) ISZ MANTL LDA B,I CLE ADA TEMP2 STA B,I CCA,SEZ,RSS CARRY ? JMP INDIG,I NO, DONE. INDI1 ADB A PROPOGATE IT. ISZ B,I JMP INDIG,I JMP INDI1 SKP * GETDG - EXTRACT DIGITS FOR OUTPUT. * * GETDG EXTRACTS DIGITS FROM THE MANTISSA AND RETURNS THEM * FOR OUTPUT PURPOSES. ONLY (SGCNT) DIGITS WILL BE RETURNED, * ANY AFTER THAT ARE 0 OR 9 AS REQUIRED TO PRODUCE THE CORRECT * ROUNDING. LESS PRECISION IS USED AS DIGITS ARE GENERATED. SPC 2 GETDG NOP CLA LDB ZERO GET THE ZERO FLAG. SZB EXIT IF THE NO. OhIS ZERO. JMP GETDG,I LDA SGCNT TOO MANY DIGITS ? CLE,SSA,RSS JMP NOSIG YES, SEND ROUNDING DIGIT. ISZ TEMP7 ANY DIGITS LEFT ? JMP GETD1 YES, GET ONE. LDA =D5000 NO, GENERATE 4 MORE. JSB MULT ISZ MANTP THEY'RE IN THE NEXT WORD. LDA MIN4 STA TEMP7 GETD1 LDA TEMP7 A = - # DIGITS IN WORD. ADA GETDA GET POWER OF TEN FOR EXTRACTING DIGIT. STA TEMP8 LDA MANTP,I DIGITS. CLB DIV TEMP8,I A = NEW DIGIT, B = REST. STB MANTP,I ISZ SGCNT IS THIS FIRST AFTER LAST VALID DIGIT ? JMP GETDG,I NO. LDB ....9 YES. IF .GE. 5, RETURN NINES NOW. ADA MIN5 SSA CLB ELSE RETURN ZEROES. STB RND NOSIG LDA RND RETURN ROUNDING DIGIT (0 OR 9) JMP GETDG,I SPC 2 DEC 1000 DEC 100 DEC 10 DEC 1 GETDA DEF * SKP * RSN - RIGHT SHIFT MANTISSA BY N BITS, N IN [1,15]. * * RSN RIGHT SHIFTS THE MANTISSA BY (A) BITS AND * ADJUSTS THE EXPONENT ACCORDINGLY. BITS SHIFTED * OFF ARE LOST. ZERO BITS ARE SHIFTED IN. * * CALLING SEQUENCE: * LDA N A = SHIFT COUNT. * JSB RSN SPC 1 RSN NOP LDB A ADJUST EXPONENT. ADB EXP STB EXP IOR RRR16 SET UP SHIFT INSTRUCTION. STA XEQ+1 LDA MANT+2 SHIFT. LDB MANT+3 JSB XEQ STB MANT+3 LDA MANT+1 LDB MANT+2 JSB XEQ STB MANT+2 LDA MANT LDB MANT+1 JSB XEQ STB MANT+1 CLA LDB MANT JSB XEQ STB MANT JMP RSN,I EXIT SKP * LSONE - LEFT SHIFT MANTISSA ONE BIT. * * LSONE LEFT SHIFTS THE MANTISSA BY ONE BIT AND ADJUSTS * THE EXPONENT ACCORDINGLY. THE LAST BIT BECOMES ZERO. * * CALLING SEQUENCE: * * JSB LSONE SPC 1 ) LSONE NOP LDA MANT+3 SHIFT. CLE,ELA STA MANT+3 LDA MANT+2 ELA STA MANT+2 LDA MANT+1 ELA STA MANT+1 LDA MANT ELA STA MANT CCA ADJUST EXP ADA EXP STA EXP JMP LSONE,I SPC 4 * .XCOM - COMPLEMENT MANTISSA. SINCE WE HAVE MORE PRECISION * THAN WE NEED, IT IS ONLY A COMPLEMENT, NOT A NEGATE. SPC 2 .XCOM NOP LDA MANT COMPLEMENT MANTISSA. CMA STA MANT LDA MANT+1 CMA STA MANT+1 LDA MANT+2 CMA STA MANT+2 LDA MANT+3 CMA STA MANT+3 JMP .XCOM,I SKP * MULT - MULTIPLY THE MANTISSA BY A SCALAR. * * MULT MULTIPLIES THE MANTISSA BY A 15-BIT SCALAR AND ADJUSTS THE * EXPONENT. THE RESULT IS AS IF AN INTEGER MULTIPLY OF THE MANTISSA * AND SCALAR WERE DONE FOLLOWED BY A RIGHT SHIFT 15. THE RESULT * WILL NOT OVERFLOW BUT IT MAY BECOME UNNORMALIZED. * * CALLING SEQUENCE: * * CLE/CCE LAST WORD FLAG. * LDA SCALAR MULTIPLIER. * LDB N EXPONENT ADJUSTMENT. * JSB MULT * * WHERE E=1 INDICATES THAT THE LAST WORD OF THE CURRENT * MANTISSA IS ZERO. (INPUT CONVERSION). FOR THIS * CASE, THE EXPONENT ADJUSTMENT MUST NOT CARRY OUT. SPC 2 MULT NOP STA MULTA SAVE MULTIPLIER. RAL AND 2*MULTIPLIER. STA MULTD CME E=0 IFF INPUT ADB EXP ADJUST EXPONENT STB EXP LDB MANTL CURRENT WORD ADDR SEZ,RSS INPUT ? JMP MULT3 YES, SKIP FIRST MPY STB MULTB RAR RESTORE MULTIPLIER. MPY B,I ASL 1 JMP MULT2 MULT1 LDA MULTA MULTIPLIER. MPY B,I * CURRENT WORD. CLE,ELA ALIGN. ELB,CLE ADA MULTC,I ADD LOWER TO CURRENT + 1 STA MUILTC,I SEZ PROPOGATE CARRY. INB MULT2 LDA MULTB,I CORRECT FOR BIT 15. SSA ADB MULTD STB MULTB,I LDB MULTB SEE IF DONE. MULT3 CPB MANTP I.E., IS CURRENT WORD THE START ? JMP MULT,I YES, DONE. STB MULTC NO, UPDATE POINTERS. ADB MIN1 STB MULTB JMP MULT1 AND LOOP. SKP * DIVD - DIVIDE MANTISSA BY A SCALAR. * * DIVD DIVIDES THE MANTISSA BY A SCALAR AND ADJUSTS THE * EXPONENT ACCORDINGLY. THE EFFECT IS AS IF THE TWO WERE * INTEGERS AND THE DIVIDE WERE DONE, KEEPING 15 FRACTION * BITS, FOLLOWED BY A LEFT SHIFT 15. * OVERFLOW CAN OCCUR ONLY IF THE MANTISSA IS NORMALIZED * OR THE DIVISOR IS LESS THAN 2**14. * * CALLING SEQUENCE: * * LDA SCALAR 15-BIT DIVISOR. * LDB N EXPONENT ADJUSTMENT. * JSB DIVD SPC 4 DIVD NOP STA DIVDA SAVE DIVISOR. ARS SAVE DIVISOR/2. STA DIVDD CMB,INB CORRECT EXPONENT. ADB EXP STB EXP LDA MANTP SET UP POINTERS. STA DIVDB STA DIVDC LDB A,I B = FIRST WORD. CMA,INA -MANTP ADA MANTL MANTL-MANTP = # WDS - 1 CMA - # WDS STA DIVDE CLA BITS 15,14 FIRST WORD = 0 JMP DIVD2 DIVD1 ISZ DIVDB CLA SAVE BIT 15 (IN E). ELA,ELA CMB FORM REM - DIVISOR/2 ADB DIVDD CMB,CLE,SSB POS ? ADB DIVDD NO, RESTORE REM & SET E. CME SAVE BIT 14 (IN E). ERA,RAR DIVD2 STA DIVDF SAVE BITS 15,14. ISZ DIVDC LDA DIVDC,I A = NEXT WORD (LOW) DIV DIVDA DIVIDE. CLE,ERA SHIFT RIGHT, SAVE BIT 0 AS BIT 15. IOR DIVDF ADD PREV BITS 15,14. STA DIVDB,I ISZ DIVDE DONE ? JMP DIVD1 NO, LOOP. JMP DIVD,I YES, EXI9T. SKP * OUTPT - SCALE NUMBER FOR OUTPUT. * * OUTPT COPIES A VARIABLE TO BE NUMERICALLY OUTPUT, PUTTING * IT IN A STANDARD FORMAT (4 WORD MANTISSA, SEPARATE EXPONENT). * THEN IT MULTIPLIES OR DIVIDES THE NUMBER BY A POWER OF TEN * TO THAT IT IS IN [1000,10000). THE BINARY POINT IS PLACED * AFTER THE FIRST WORD SO THE FIRST 4 DIGITS ARE IN THAT WORD. * THE VALUE OF N S.T. (ORIGINAL #) * (10**(-N)) IS IN [.1,1) * IS STORED IN EXPON, I.E. NUMBER * 10**EXPON = ORIG NUMBER. * THE FOLLOWING APPROXIMATION IS USED: * * LOG10(X*(2**N)) = [((N*19729)/128)+((X*(2**15))*617)/(2**16)-290]/512 * * WHERE X IS IN [0.5,1). THE ERROR IS ALWAYS POSITIVE. SPC 2 * SET W & D, COPY NUMBER AND CONVERT IT. * OUTPT NOP JSB .CFER COPY 4 WORDS. DEF MANT DEF ADX,I LDA TYPE WHAT TYPE IS IT ? ADA MIN2 SSA,INA,RSS JMP OUTPB FLOATING. * * INTEGER. * SZA,RSS INTEGER. 1 OR 2-WORD. JMP OUTPC 2-WORD. LDA MANT 1-WORD. FLOAT IT. JSB FLOAT STA MANT SET UP AS IF 2-WORD FLOATING. STB MANT+1 CLA JMP OUTPB OUTPC STA MANT+2 2-WORD. FLOAT TO 3-WD FLOATING. LDA =D31 JSB .XPAK DEF MANT CLA,INA SET UP AS IF 3-WORD FLOATING. * * FLOATING. * OUTPB ADA AMANT FORM ADDR LAST WORD STA TEMP3 LDB A,I UNPACK THAT WORD. JSB .FLUN STB TEMP3,I STA EXP SKP * REMEMBER SIGN, TAKE ABS VALUE, CHECK FOR ZERO. * LDA MANT SET SIGN. SSA CCB,RSS CLB STB SIGN SZA,RSS ZERO ? JMP OUTPT,I YES, DON'T SCALE. SSA NEGATIVE ? JSB .XCOM YES, TAKE ABS VALUE. JSB NORML NORMALIZE. * * SCALE TO [1000,10000). * LDA EXP FORM N*19729 v(NLHMPY =D19729 ASR 7 (N*19729)/128 STA TEMP3 LDA MANT X*(2**15) MPY =D617 B = ((X*(2**15))*617)/(2**16) ADB TEMP3 + (N*19729)/128 ADB =D222 -290+512 ASR 9 B = FLOOR(LOG10(NUMBER))+1 STB EXPON = N. CMB,INB DIVIDE NUMBER BY 10**(N-4) ADB ....4 LDA B JSB PTEN LDA MANT GET INTEGER PART. LDB EXP RBL JSB IFIX ADA =D-1000 IS IT < 1000 ? SSA,RSS JMP OUTPA NO, O.K. LDA PWR1A YES, MULTIPLY BY TEN. LDB PWR1A+1 CLE SET NON-INPUT MODE. JSB MULT CCA DECREMENT EXPONENT. ADA EXPON STA EXPON OUTPA LDA EXP ADJUST EXP TO +15 ADA =D-15 CMA,INA JSB RSN LDA AMANT RESET TO HIGHER ACCURACY. ADA LENTH FOR DIGIT PRODUCTION. STA MANTL JMP OUTPT,I EXIT. END !-N  92903-18049 1805 S C0122 &RNUM              H0101 qFTN4 LOGICAL FUNCTION RNUM(IBUF,NCAR,NBCAR .,RESUT),. 92903-16001 REV.1805 780522 C C SOURCE 92903-18049 C C C C ************************************************************** C * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * C ************************************************************** C C C********************************************************************* C* * C* RNUM IS A LOGICAL FUNCTION USED TO CONVERT AN ASCII * C* BUFFER INTO A REAL NUMBER. CHECKS ARE PERFORMED AND FUNCTION * C* SUCCEEDS IF THE INPUT BUFFER IS NOT CORRECT . * C* * C* IF(RNUM(IBUF,NCAR,NBCAR,RESUT)) GO TO ERROR * C* * C* WHERE : * C* IBUF : INPUT BUFFER * C* NCAR : NUMBER OF THE FIRST CHARACTER TO USE IN * C* THE INPUT BUFFER (FIRST IS 1) * C* NBCAR : NUMBER OF CHARACTERS TO BE USED * C* RESUT : REAL VARIABLE WHERE REAL VALUE IS * C* RETURNED * C* * C********************************************************************* C C LOGICAL FLAGF,FLAGE,ISSPA,ISBTW,INUM DOUBLE PRECISION RESU C C FLAGF TO INDIC IF FIRST PART OF NUMBER ANALYZED C FLAGE " " IF SIGN ANALYZED C RNUM=.FALSE. RESU=0. IBL=0 IBL1=0 C C  BLANKS ONLY ? C IF(ISSPA(IBUF,NCAR,NBCAR)) GOTO 2 RETURN C C ANALYSE BUFFER C 2 CONTINUE FLAGF=.FALSE. FLAGE=.FALSE. NB2=NBCAR+NCAR-1 ISIGN=1 K=1 DO 1 I=NCAR,NB2 JNUM=-1 ICOM=IGET1(IBUF,I) IF(ICOM.NE.1H ) GO TO 6 IF(FLAGF) GO TO 35 IF(IBL.EQ.1) IBL1=1 GO TO 1 35 IBL=1 GO TO 1 6 IF(FLAGE) GOTO 7 FLAGE=.TRUE. IF(ICOM.EQ.1H+) GOTO 1 IF(ICOM.NE.1H-) GOTO 7 ISIGN=-1 GOTO 1 7 CONTINUE IF(.NOT.ISBTW(ICOM,1H0,1H9))JNUM=ICOM/256-60B IF(FLAGF) GOTO 10 IF(ICOM.EQ.1H.) GOTO 4 IF(ICOM.EQ.1HE) GOTO 30 IF(JNUM.EQ.-1) GO TO 50 IBL=1 RESU=RESU*10+JNUM GOTO 1 4 CONTINUE FLAGF=.TRUE. IF(IBL1.EQ.1) GO TO 50 IBL=0 GOTO 1 10 CONTINUE IF((JNUM.EQ.-1).AND.(ICOM.NE.1HE)) GO TO 50 IF(ICOM.EQ.1HE) GOTO 30 IF(IBL.EQ.1) GO TO 50 RESU=RESU+DBLE(FLOAT(JNUM))/(10.**K) K=K+1 GOTO 1 30 CONTINUE J=I+1 IJ=NB2-I IF(IJ.LE.0) GO TO 50 IF(INUM(IBUF,J,IJ,IRESU)) GO TO 50 C-----NORMALIZE BEFORE CHECKING EXPONENT. 40 IF(RESU.EQ.0) GO TO 49 IF(RESU.EQ.1.) GO TO 46 IF(RESU.GT.1.) GO TO 44 C-----MOVE DECIMAL PT TO RIGHT 42 IF(RESU.GE.1) GO TO 46 RESU=RESU*10. IRESU=IRESU-1 GO TO 42 C-----MOVE DECIMAL PT TO LEFT 44 IF((RESU.GE.1.).AND.(RESU.LT.10.)) GO TO 46 RESU=RESU/10. IRESU=IRESU+1 GO TO 44 C-----MANITSSA NORMALIZED TO DECIMAL FRACTION BETWEEN 1 & 10 46 IF(IRESU.NE.38) GO TO 48 IF(RESU.GT.1.) GO TO 50 GO TO 49 48 IF(IRESU.NE.-38) GO TO 49 IF(RESU.LT.1.) GO TO 50 49 IF((IRESU.LT.-38).OR.(IRESU.GT.38)) GO TO 50 IF(RESU.EQ.0) RESU=1 IF(IRESU.LT.0) GOTO 20 RESU=ISIGN*RESU*10.**IRESU GOTO 21 20 CONTINUE RESU=ISIGN*RESU/10.**(-IRESU) GOTO 21 1 CONTINUE 21 RESU=RESU*ISIGN RESUT=RESU RETURN C C ERROR RETURN C 50 RNUM=.TRUE. RETURN END END$   92903-18050 1805 S C0122 &SETBT              H0101 lASMB HED S/P SETBT (08/JUL/77) F. GAULLIER NAM SETBT,7 . 92903-16001 REV.1805 770708 * * SOURCE 92903-18050 * SPC 2 ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** SPC 2 EXT .ENTR ENT SETBT * * SET OR CLEAR ONE BIT IN A WORD * I NOP WORD N NOP BIT # (MODULO 16) K NOP BIT VALUE (ODD OR EVEN) * SETBT NOP JSB .ENTR DEF I CCA,CLE LDB N,I CMB STB N SAVE MINUS BIT # (-17 TO -1) ELA SET UP MASK INTO A REG. ISZ N JMP *-2 AND I,I CLEAR BIT N STA N LDA K,I AND DEC1 CLE,RSS ELA ISZ 1 JMP *-2 IOR N STA I,I JMP SETBT,I * DEC1 DEC 1 END 6  92903-18100 1805 S C0122 &TMSLB              H0101 ASMB NAM TMSLB,0 92903-16100 REV.1805 780530 SPC 3 ********************************************************************** * * * NAME: TMSLB TMS LIBRARY HEADER * * SOURCE: &TMSLB 92903-18100 * * BINARY: %TMSLB ----NONE--- HEADER OF %TMSLB 92903-16100 * * * * PGMR: FRANCOIS GAULLIER * * * ********************************************************************** SPC 2 * ************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * ************************************************************** SPC 3 END )  92903-18102 1805 S C0422 &TMSYS              H0104 ASMB HED . T M S H E A R T NAM TMSYS,7 92903-16100 REV.1805 780530 SPC 3 ********************************************************************** * * * NAME: TMSYS HEART OF TMS * * SOURCE: &TMSYS 92903-18102 * * BINARY: %TMSYS ----NONE--- PART OF %TMSLB 92903-16100 * * * * PGMR: FRANCOIS GAULLIER * * * ********************************************************************** SPC 2 * ************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * ************************************************************** SPC 3 ENT TMSYS,.MGT0 EXT COR.A,.MGTG,.MGTR,#REQU,DRTEQ EXT EXEC,LURQ,$CVT3,$LIBR,$LIBX EXT .ENTR,$TIME,IDGET,KLCLS,PNAME,RMPAR EXT DORMT,.UPIO,MESSS,.LURQ SPC 1 A EQU 0 B EQU 1 SUP SKP .PARA NOP PRG PARAMETERS ADDR PNX00 NOP DEFINE THE STARTING PROCESS PNXXX NOP DEFINE THE INITIAL PROCESS LUXXX NOP DEFINE THE LU FOR THE INITIAL PROCESS .TMLU NOP .TMTP NOP .TMSB NOP .TMPR NOP .TMSL NOP ADDR OF TMS LINK NAME .TMST NOP ADDR OF TMS TIMER NAME IMAGE NOP IMAGE PARAMETERS TMSYS NOP TMS ENTRY POINT. JSB .ENTR DEF .PARA * LDB .PARA,I SAVE THE FIVE PARAMETERS JSB RMPAR INTO BUF TO SEND THEM INTO SAM DEF *+2 AS/ THE INITIAL CB0 DEF BUF * LDA BUF RECALL FIRST PARAM (LU) SZA,RSS DEFAULT LU IS 1 INA STA BUF STA LU SET CONSOLE LU SPC 1 * JSB .DBUG CALL DBUG: INTERNAL USE ONLY !!!!!!!!!!!!!!!!!!!!! * EXT .DBUG CALL DBUG: INTERNAL USE ONLY !!!!!!!!!!!!!!!!!!!!! SPC 1 JSB EXEC SWAP THE WHOLE AREA DEF *+3 DEF D22 DEF D3 SWAP THE ENTIRE PARTITION SPC 1 JSB PNAME RETREIVE TMS-APPLICATION NAME DEF *+2 .APLN DEF APLNM SAVE NAME HERE LDA O72 ":" IOR APLNM+2 STA APLNM+2 SET ":" AFTER PORG. NAME SPC 1 LDA XEQT GET ID SEGMENT ADDR JSB COR.A GET FWA STA FWA CMA,INA LDB BGLWA GET BACKGROUND LWA ADA AVMEM CHECK IF PROGRAM RUN FOR./BACK. PARTITION SSA,RSS FOREGROUND ? LDB AVMEM YES, USE FOREGROUND LWA ADB DM1 YES, LOST TWO WORDS ! (MMGT PB) !! LDA FWA B=LWA CMA,INA ADA B COMPUTE AVAILABLE MEMORY SIZE STA LENA * JSB .MGTR FWA NOP FWA OF BUFFER LENA NOP # OF WORDS JMP .MGTG INITIALISE MEMORY MANAGEMENT SYSTEM * .MGT0 EQU * MEMORY MNGT SYSTEM IS READY. SPC 2 LDB .TMLU SET UP TO CALL LURQ ADB DM1 TO LOCK ALL INTERACTIVE DEVICE STB STA33 SET # OF INTER. DEVICES ADDR. ADB D2 STB STA31 SET LU'S BUFFER STB STKLN SAVE LU'S ADDR. TO DO THE UPIO LDA STA33,I RECALL NUMBER OF LU'S CMA,INA AND STA #LU SET UP LU COUNTER * STA26 LDA STKLN,I GET LU JSB .UPIO TRY TO UP THE DEVICE IF DOWN JMP LULAB ERROR RETURN, ABORT TMS WITH ERROR # 1 ISZ STKLN BUMP LU ADDR. ISZ #LU BUMP LU COUNTER JMP STA26 AND LOOP UNTIL THE END * JSB LURQ LOCK ALL INTERCATIVE DEVICE DEF u_B IDSG? * LDA .TMPR,I CHECK PROGRAM CONTAINING CMA,INA USER CODE (A = - # OF PRG) * STA43 STA TEMP ADA .TMPR,I COMPUTE INDEX INTO PRG TABLE ALS,ALS (MPY D4) INA ADA .TMPR GO INTO PRG TABLE JSB IDSG? LDA TEMP RECALL INDEX INA,SZA END OF TABLE ? JMP STA43 NO, CONTINUE UNTIL END SPC 2 * ALLOCATE STACK TABLE AND ALL STACKS SPC 1 LDB .TMLU ALLOCATE STACK FOR EACH LU'S. LDA B,I GET STACK LENGTH STA STKLN ADB =D-2 LDA B,I GET TOTAL # OF LU STA #LU AND SAVE LOCALY CMA,INA STA TEMP USE AS COUNTER SPC 1 JSB .MGTG ALLOCATE MEMORY FOR STACK TABLE #LU NOP TABLE LENGTH JMP .ER02 ERROR, NOT ENOUGH MEMORY JMP .ER02 ERROR, NOT ENOUGH MEMORY ADA DM1 OK, A=TABLE ADDR, DO -1 TO USE X REG STA .STKT INIT STACK TABLE ADDR. SPC 1 LDY D1 STAR4 JSB .MGTG ALLOCATE MEMORY FOR EACH STACK STKLN NOP STACK LENGTH .ER02 JSB ERRAB NOT ENOUGH MEMORY TO ALLOCATE JMP *-1 ALL STACKS: ERROR # 01 --> ABORT !!! SAY .STKT,I SAVE ADDR. OF STACK IN STACK TABLE ISY NEXT ENTRY IN STACK TABLE LDB BIT15 SET IN FIRST WORD STB A,I STACK NOT ACTIVE ADA =D10 CLEAR LINK WORD CLB STB A,I ISZ TEMP MORE LU ? JMP STAR4 YES, ALLOCATE AN OTHER STACK SPC 2 * ALLOCATE ALL NEEDED CLASS I/O SPC 1 JSB WRI/O SAVE PRG. SCHEDULE PARAM INTO CB0 (STKPT MUST=100001) LDA CLASS RECALL CLASS I/O WORD FOR CB0 IOR BIT13 SET "DO NOT DEALLOCATE CLASS" BIT STA CLAS0 AND SET CLASS I/O TO BE USED FOR CB0 CLA,INA RESET I/O BUF LENGTH STA WRI/L * CLA RESET CLASS WORD STA CLASS TO ALLOCATE A NEW CLASS FOR THE kJSB WRI/O TMS-FMP CALL, LENGTH OF BUFFER IS ONE LDA CLASS TO INDICATE THAT THE DIRECTORY IS EMPTY IOR BIT13 SET "DO NOT DEALLOCATE CLASS" BIT STA FMPCL SET THE TMS-FMT CLASS I/O WORD * JSB GTCLW GET A CLASS I/O WORD STA MCLAS SET MAIN CLASS I/O JSB GTCLW GET A CLASS I/O WORD STA ICLAS INIT INTERNAL CLASS I/O JSB GTCLW GET ANOTHER CLASS I/O WORD STA CLASS INIT EXTERNAL CLASS I/O IOR =B40000 SAVE BUFFER CLASS STA CLASG SPC 2 * INITIATE ALL TMS-SYSTEM PROGRAM: TMSL/TMST/TMSIM SPC 1 LDA .TMSL SCHEDULE TMS LINK PRG. STA SCHFL SET SCHEDULE FLAG "WITH WAIT" JSB SCHUP HLT 11B PROGRAM MISSING !!! * LDA .TMST SCHEDULE TMS TIMER PRG. JSB SCHUP HLT 12B PROGRAM MISSING !!! * CLA OPEN DATA BASE REQUEST JSB IMRQT SCHEDULE TMS-IMAGE-MODULE PROGRAM JMP STAR6 NO IMAGE DATA BASE IN THIS APPLICATION JMP STA52 RETURN OK CONTINUE CLB ERROR RETURN, SET IMAGE SUBROUTINE # STA55 STA BUF SET IMAGE ERROR CODE STB BUF+1 SET IMAGE SUBROUTINE # .ER21 JSB ERRAB AND PROCESS IMAGE ERROR (NEVER COME BACK) SPC 1 STA52 STB IMCLS SAVE CLASS RETURNED BY TMS-IMAGE-MODULE LDA TEMP2 RECALL THE DATA-BASE CRC AND STA IMCRC SAVE IT DLD TEMP3 RECALL MAXIMUM ITEM & ENTRY LENGTH DST MIELN AND SAVE IT TO PASSE TO TMLIM LDA IMRQ2 SET TMS-IMAGE-MODULE PROGRAM NAME LDB .IMPR INTO THE BUFFER SEND TO TMLIB/TMLIM MVW D3 SPC 2 * INTERNAL INITIALISATION PHASE IS COMPLETED: * START UP PROCESSES, THE INITIAL & ALL * INTERCATIVE PROCESSES. SPC 1 STAR6 CCA SET ABORT TMS WHEN ERROR FLAG STA NOABT CLA SET SCHEDULE FLAG "NO-WAIT" STA SCHFL *  LDA PNXXX,I GET NAME ADDR OF THE INITIAL-PROCESS SZA INITIAL-PROCESS ? JMP ISPRL YES, SET IT UP STAR8 JSB STIPR NO, START ALL INTERACTIVE PROCESSES SPC 1 JMP IDLE HED . CONSTANT, VARIABLE AND UTILITIES FOR THE START-UP PHASE IOPTN OCT 140001 LU LOCK/NO WAIT/NO ABORT O200 OCT 200 O77 OCT 77 O72 OCT 72 O100 OCT 100 O377 OCT 377 O400 OCT 400 LBYTE OCT 177400 O114C OCT 11400 BIT13 OCT 20000 UNBMS ASC 5, EQ,XX,UN UNBUFFERED THE LOG DEVICE SPC 2 IDSG? NOP STA IDSG3 SAVE PROGRAM NAME ADDR JSB IDGET CHECK IF IDSEG IS THERE DEF *+2 IDSG3 NOP PNAME SZA,RSS IDSEG HERE ? JMP IDSG6 NO, ERROR * JSB DORMT PROGRAM DORMANT ? DEF *+2 DEF IDSG3,I PROGRAM NAME ADDR. SSA DORMANT ? JMP IDSG?,I YES, RETURN * LDA IDSG3 NO, DO AN 'OF,PNAME,1' LDB .IDS8 TO MAKE IT DORMANT MVW D3 MOVE PROG. NAME INTO THE BUFFER JSB MESSS CALL SYSTEM PROCESSOR MESSAGE DEF *+3 DEF IDS8 MESSAGE BUFFER DEF D12 MESSAGE LENGTH JMP IDSG?,I AND RETURN * IDSG6 LDA IDSG3 NO, PUT PNAME IN MESSAGE LDB .MS04 MVW D3 LDA IDSG7 MVW =D4 LDA .MS0 JSB OUTM OUTPUT "TMS 00 PNAME MISSING" JMP ABT3 EXIT. * IDSG7 DEF *+1 ASC 4,MISSING .IDS8 DEF IDS8+2 IDS8 ASC 6, OF,XXXXXX,1 SPC 2 IMRQT NOP DST IMBF SET IMAGE REQUEST CODE LDB IMAGE,I RECALL TMS-IMAGE-MODULE PROG. NAME CPB =B20040 IMAGE DEFINED ? JMP IMRQT,I NO, RETURN P+1: IMAGE NOT DEFINED ISZ IMRQT LDA IMAGE SET UP BUFFER TO SEND TO LDB .IMF4 TMS-IMAGE-MODULE PROGRAM MVW =D7 WITH THE DBNAM/LEVEL WORD/SEC. CODE STA IMRQ2 JSB EXEC SCHEDULE TMS-IMAGE-MODULE DEF *+10 DEF NAB23 QUEUE SCHEDULE WITH WAIT\ & NO-ABORT IMRQ2 NOP PROGRAM NAME DEF LU 1ST PARAM DEF * DEF * DEF * DEF * DEF IMBF BUFFER PASSES USING STRING PASSING DEF D11 BUFFER LENGTH JMP IMRQ5 ERROR RETURN (PROGRAM NOT LOADED) JSB RMPAR RETURN OK, GET PARAMETERS FROM TMS-IMAGE-MODULE DEF *+2 DEF TEMP DLD TEMP SZA IMAGE REQUEST OK ? IMRQ3 ISZ IMRQT NO, ERROR RETURN P+3: IMAGE ERROR JMP IMRQT,I * IMRQ5 CLA,INA PROGRAM NOT LOADED = ERROR # 1 JMP IMRQ3 * .IMPR DEF IMPRG IMBF BSS 11 .IMF4 DEF IMBF+4 IMCRC NOP HOLD DATA-BASE CRC SPC 2 OPLOG NOP 'OPEN' THE LOGG DEVICE ISZ REEL# BUMP MAG-TAPE REEL NUMBER OPLO3 LDA LULOG I.E.: CHECK THAT THE DEVICE IS READY AND OK IOR O400 SET 'REWIND' FUNCTION CODE STA TEMP IOR O200 SET 'DYNAMIC STATUS' FUNCTION CODE STA TEMP1 * JSB EXEC DO A DYNAMIC STATUS DEF *+3 TO CHECK THAT THE DEVICE IS ON LINE DEF D3 DEF TEMP1 SLA DEVICE ON LINE ? JMP OPLO6 NO, REPORT ERROR * JSB EXEC DO THE REWIND DEF *+3 DEF D3 CONTROL RQ DEF TEMP * OPLO5 JSB EXEC DO THE DYNAMIC STATUS DEF *+3 DEF D3 CONTROL RQ DEF TEMP1 STA TEMP SAVE STATUS AND O100 ISOLATE TAPE AT LOAD POINT BIT SZA,RSS TAPE AT LOAD POINT ? JMP OPLO5 NO, WAIT UNTIL TAPE AT LOAD POINT LDA TEMP YES, RECALL STATUS AND O377 AND ISOLATE STATUS TO CHECK WRITE ENABLE ... CPA O100 STATUS OK ? JMP OPLO8 YES, WRITE TAPE HEADER AND EXIT * CLA,RSS REPORT "NO WRITE RING" ERROR OPLO6 CLA,INA REPORT "DEVICE OFF LINE" ERROR JSB LOGER REPORT ERROR AND WAIT FOR ACK. JMP OPLO3 CHECK EVERY THING AGAIN * OPLO8 LDB OPLO4 INIT HEADER BUFFER LDA D16 STA B,I SET RECORD LENGTH INB STB OPLO9 SET ADDR. FOR TIME STAMP ADB D5 LEAVE ROOM FOR TIME STB OPLO9+1 SET ADDR. FOR YEAR INB LDA REEL# SET MAG-TAPE REEL NUMBER STA B,I INB LDA .LOGH MOVE HEADER INTO THE BUFFER MVW D8 * JSB EXEC GET TIME STAMP FROM THE SYSTEM DEF *+4 DEF D11 OPLO9 BSS 2 BUFFER ADDR * JSB EXEC WRITE ON THE MAG-TAPE DEF *+5 THE MAG-TAPE LOGGING HEADER DEF D2 WRITE DEF LULOG LU OPLO4 DEF BUF+10 BUFFER DEF D16 BUFFER LENGTH JMP OPLOG,I * REEL# DEC 0 LOGGING MAG-TAPE REEL NUMBER .LOGH DEF *+1 ASC 5,TMS LOGG. APLNM BSS 3 D16 DEC 16 SPC 2 CLLOG NOP 'CLOSE' THE LOGG DEVICE LDA LULOG RECALL LOGG LU ADA O100 WRITE AN EOF AND REWIND STANDBY STA TEMP ADA O400 STA TEMP1 JSB EXEC WRITE EOF DEF *+3 DEF D3 DEF TEMP JSB EXEC REWIND STANDBY DEF *+3 DEF D3 DEF TEMP1 JMP CLLOG,I SPC 2 STIPR NOP START ALL INTERACTIVE PROCESSES LDA STKPT SAVE STACK POINTER STA STIP4 CLA STA SCODE SUBROUTINE CODE=0 FOR START TMS STA SPR80 CLEAR CALL TO THIS ROUTINE (ONLY ONCE) STA STAR8 " " " " STA .PAR5+4 INIT DEFAULT LOCK ID WORD (INIT CB1(7)) * LDX DM1 LAX .TMLU,I GET # OF INTERACTIVE DEVICES CAX STIP2 LBX .STKT,I JSB INSTK INITIALIZE STACK JSB WRI/O START UP THE PROCESS DSX MORE INTERACTIVE DEVICES ? JMP STIP2 YES, CONTINUE LDA STIP4 NO, RESTORE STACK POINTER STA STKPT AND EXIT. JMP STIPR,I * STIP4 NOP .STKT NOP ADDR OF STACK TABLE ADDR - 1 (USAGE OF X) SPC 2 ILRQ STA TEMP L NOP HLT 20B HED -- IDLE LOOP -- EXITZ JSB WRI/O QUEUE UP THIS PROCESS SPC 2 IDLE RSS FLAG TO SCAN/NOT SCAN THE EXT. EVENT WAIT QUEUE JMP IDLEZ LDB .EXTW,I SCAN THE EXTERNAL EVENT WAIT QUEUE SZB,RSS QUEUE EMPTY ? JMP IDLEZ YES, SUSPEND TMSYS ON THE CLASS I/O GET !! * LDB .EXTW NO, GET QUEUE HEAD IDLEQ STB EXTWP SAVE QUEUE POINTER LDB B,I GO AHEAD IN THE QUEUE SZB,RSS END OF QUEUE ? JMP IDLEY YES, SET IDLE LOOP TIMING ADB =D-9 NO, SET B=STACK POINTER LDA B,I A=S REG. LDA A,I A=SUBROUTINE ADDR JSB A,I TRY TO RESTART THE PROCESS LDB EXTWP,I GET NEXT ELEMENT OF THE QUEUE JMP IDLEQ AND LOOP UNTIL END. SPC 1 IDLEZ JSB EXEC CLASS I/O GET DEF *+7 DEF D21 DEF CLASG SAVE BUFFER .BUF DEF BUF DEF D4 DEF STKPT GET BACK STACK ADDR DEF SCODE GET BACK SUBROUTINE CODE SSA HLT 22B STA TEMP SAVE STATUS OF THE LAST OPERATION SPC 2 LDA SCODE GET SUBROUTINE CODE SSA SPECIAL OPERATION FROM TMSB ? HLT 24B YES, PROCESS !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ADA C.TAB NO, INDEX IN TABLE JMP A,I AND JMP TO RIGHT CODE SPC 2 * EXTERNAL EVENTS WAIT QUEUE PROCESS AND * IDLE LOOP TIMING. SPC 1 IDLEY CLA DO NOT SCAN THE EXT. EVENTS WAIT QUEUE STA IDLE IF WAITING ON THE IDLE LOOP TIMING LDA .DSTK GET DUMMY STACK ADDR STA STKPT TO SET STACK POINTER LDA PAUCD AND SIMULATE A PAUZ REQUEST STA SCODE FOR THAT DUMMY STACK. LDA =D100 PAUSE FOR 1.00 SECONDS STA .PAR1 JMP PAUS EXECUTE PAUSE CODE SPC 1 IDLEX LDA .RSS RETURN FORM THE TIMER, STA IDLE RESTORE THE SCANNING OF THE EXT. EVENT JMP IDLE% WAIT QUEUE SPC 1 * DUMMY STACK USED FOR IDLE LOOP TIMING. SPC 1 .DSTK DEF *+1 DUMMY STACK ADDR * DEF *+12 DUMMY S REG. DEF *+10 DUMMY Q REG. EXTWP NOP QUEUE POINTER .EXTW DEF *+1 EXTERNAL EVENT WAIT QUEUE HEAD OCT 0 O40K OCT 40000 PAUCD DEC 12 BSS 4 TEMP1/TEMP4 ON THE STACK OCT 40002 VERY 1ST TMS SUB. # (SPECIAL WITH BIT14) SPC 2 DEXTW NOP DEQUEUE FROM EXTERNAL EVENT WAIT QUEUE STB STKPT B MUST = STACK POINTER ADB =D9 TO ACCESS THE LINK WORD LDA B,I GET NEXT LINK IN THE QUEUE STA EXTWP,I TO REPLACE THE CURRENT ENTRY CLA STA B,I CLEAR LINK WORD IN THE STACK JMP DEXTW,I SPC 2 IDL00 JSB RELBU RELEASE THE BUFFER CLASS AND FORGET JMP IDLE (THOSE CALL NEVER RETURN TO TMLIB) SPC 1 IDL02 JSB RELBU RELEASE THE BUFFER CLASS AND IDL03 JSB SETST SAVE STATUS & TLOG INTO CB1 WORD 4&5 JMP EXIT4 AND RETURN TO 'TMLIB' SPC 1 IDL04 JSB RELBU RELEASE THE BUFFER CLASS AND CLA RESET STATUS & TLOG CLB JMP IDL03 SPC 1 IDL06 JSB RELBU RELEASE THE BUFFER CLASS AND JMP EXIT4 RETURN TO 'TMLIB' WITHOUT UPDATING STATUS. HED TMS RETURN TO USER PROGRAM (RETURN INTO 'TMLIB') EXIT3 CCA SET REQUEUE FLAG STA RQU? AND RETURN TO TMLIB SPC 1 EXIT4 CCA STA SRFLG SET SEND MAIL-BOX FLAG DLD STKPT,I DST S SET S & Q REGISTER * INB LDA B,I STA RTRNA SET RETURN ADDR ADB Q.LN0 STB TEMP ADDR. OF 1ST LOCAL COM. BL. ADDR. STB CBAPT TO USE AFTER RE-SCHEDULE CMB,INB ADB S BRS DIV. BY 2 CMB,INB STB TEMP1 MINUS # OF DEFINED COMMON BLOCK STB #DFCB TO USE AFTER RE-SCHEDULE SPC 1 LDA Q,I RECALL TMS SUBROUTINE NUMBER CLE CLEAR BIT15 B7AND ELA,CLE,ELA SAVE BIT14 INTO E RAR,RAR SEZ SPECIAL RETURN ? JMP SEXIT YES, SPECIAL RETURN PROCESSING MPY D5 NO, RETURN TO TMLIB ADA .TMSB RETREIVE PRG NAME STA .EPAO INIT 'ENTRY POINT ADDR OF SUB' ADDR ADA DM1 TO GET PROGRAM NAME ADDR LDA A,I GET PROGRAM NAME ADDR STA PNADR SET IT TO THE SCHEDULE RQ LDB RTRNA GET RETURN ADDR SZB FIRST TIME ENTRY ? JMP EXIT6 NO, SKIP CALCULATION OF LOCAL SUB # ADA D3 YES, COMPUTE LOCAL SUB # LDA A,I CMA,INA INA ADA .EPAO DIV D5 B IS ALREADY CLEARED CMA,INA MAKE IT NEGATIVE FOR THE FIRST ENTRY STA RTRNA SET RTN ADDR TO NEG. LOCAL SUB # SPC 1 EXIT6 LDA .EPAO,I GET 'ENTRY POINT ADDR OF SUB' STA EPAOS * LDA LEN00 SET CB0 LENGTH IF IT IS DEFINED LDB Q,I INSIDE THIS TMS SUBROUTINE SSB,RSS CB0 DEFINED ? CLA NO, CB0 LEN = 0 STA LEN0 SET CB0 LEN * LDA STKPT ADA D7 MOVE FUNCTION PARAMETERS LDB .FPAR FROM THE STACK INTO THE BUFFER SEND MVW #FPAR TO TMLIB. (3 FUNCTION PARAMETERS) LDA TEMP MVW D10 MOVE CB'S DEFINTION SPC 1 JSB SRCB SEND ALL NEEDED CB'S SPC 1 LDA RQU? RECALL REQU FLAG SZA,RSS REQU NEEDED ? JMP EXIT8 NO, CONTINUE * JSB #REQU YES, REQUEUE THE PENDING BUFFER DEF *+3 FROM THE TMS EXTERNAL CLASS I/O DEF CLASS TO THE TMS INTERNAL CLASS I/O DEF ICLAS SZA REQUEUE OK ? HLT 25B !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! CLA RESET THE REQUEUE FLAG STA RQU? SPC 2 EXIT8 LDA PNADR RECALL PROGRAM NAME ADDR JSB SCHUP SHEDULE PROGRAM (USER PARTITION) HLT 30B ERROR RETURN !!!!!!!!!!!!!!!!!!!fEHFB!!!!!!!!!!!!!!!!!!!!!! SPC 1 CLA STA SRFLG SET RECEIVE MAIL-BOX FLAG * LDA ICLAS SWAP THE MAIN & THE INTERNAL LDB MCLAS CLASS I/O WORD STA MCLAS STB ICLAS * JSB MAILB SUSPEND TMSYS ON THE CLASS I/O GET DEF LCLAS ABS PARLN SPC 2 ************************************************************************** SPC 2 LDA ICLAS SWAP BACK THE MAIN & THE INTERNAL rH LDB MCLAS CLASS I/O WORD STA MCLAS STB ICLAS SPC 1 LDA SCOD. RESTORE SCODE STA SCODE CPA ABTFL ERROR IN TM-LIBRARY ? JMP TMLER YES, PROCESS IT SPC 1 LDB Q SAVE RETURN ADDRESS INB INTO THE STACK LDA RTRN. STA B,I LDA LCLAS GET LOCAL CLASS I/O SZA,RSS PROGRAM SUSPENDED ON CLASS I/O JMP SAV25 NO, CONTINUE * IOR BIT15 YES, SET BIT 15 TO DIFFERENTIATE FROM PNAME CPA PNADR,I FIRST TIME ? JMP SAV25 NO, CONTINUE STA TEMP YES, SAVE IT TEMPORARILY JSB IDGET RETREIVE ID SEG ADDR DEF *+2 DEF PNADR,I RETURN WITH A = IDSEG ADDR LDB TEMP RECALL LOCAL CLASS I/O STB PNADR,I AND REPLACE PNAME WITH CLASS I/O WORD ISZ PNADR SAVE IDSEG ADDR IN PLACE OF PNAME STA PNADR,I 3RD AND 4TH CHAR. SPC 1 SAV25 CCA SET 'NO ABORT FLAG' FALSE STA NOABT I.E.: ERRORS WILL ABORT TM SPC 1 LDA CBAPT SET UP TO RECEIVE ALL NEEDED CB'S LDB #DFCB DST TEMP USING THE ROUTINE SRCB JSB SRCB * SAV40 CLA SET 'MEMORY SUSPEND FLAG' STA MSUFL I.E.: PROCESS WILL BE SUSPENDED LDA SCODE RECALL SUBROUTINE CODE ADA I.TAB JMP A,I SPC 1 RQU? OCT 0 REQUEUE FLAG (NOT 0 IF REQUEUE IS NEEDED) SPC 3 * SPECIAL RETURN INSIDE TMSYS INSTEAD OF * RETURNING TO TMLIB. SPC 1 SEXIT ADA .SEXI INDEX INTO RETURN TABLE JMP A,I AND GO EXECUTE THE PROPER STATEMENT SPC 1 .SEXI DEF *+1,I SPECIAL RETURN TABLE DEF SPR80 0 RETURN FROM AN AUXILIARY PROCESS DEF .ER07 1 RETURN FROM AN INTERACTIVE PROCESS --> ERROR DEF IDLEX 2 IDLE LOOP TIMING RETURN SPC 2 .ER07 JSB ERRAB ERROR # 7: RETURN FROM AN INTERACTIVE PROCESS SPC 4 SRCB NOP LDA TEMP1 MINUS # OF DEFINED CB'S SZA,RSS IF 0 CB TO RECEIVE THEN SKIP JMP SRCB,I RECEPTION CODE ISZ TEMP LOCAL CB LENGTH POINTER LDA STKPT ADA D2 STA PT ACTUAL CB ADDRESS POINTER SPC 1 SRCB0 LDB TEMP,I GET LOCAL CB LENGTH SSB ENABLE ? JMP SRCB7 NO, NOT ENABLE LDA PT,I YES, GET ACTUAL CB ADDR. SZA,RSS ALLOCATED ? HLT 32B NO, ERROR !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DST SRCB2 JSB MAILB RECEIVE COMMON BLOCK DATA SRCB2 BSS 2 * SRCB7 ISZ PT ISZ TEMP ISZ TEMP ISZ TEMP1 MORE COM. BL. DEFINED ? JMP SRCB0 YES, LOOP JMP SRCB,I SPC 1 CBAPT NOP LOCAL CB ADDR POINTER PNADR NOP PROGRAM NAME ADDR SPC 4 STKPA LDA ..PA1 SAVE THE 3 FUNCTION PARAMETERS LDB STKPT INTO THE STACK ADB D7 MVW #FPAR JMP IDLE AND GO TO IDLE LOOP. * D7 DEC 7 D10 DEC 10 .FPAR DEF FPARM ..PA1 DEF .PAR1 HED START-UP TMS PROCESSES START JSB RELBU DLD STKPT,I INIT S & Q REGISTERS DST S * ISZ B,I SET VERY 1ST TUS# FOR INTER. PROCESS * LDA PNX00 MOUVE STARTING PROCESS NAME LDB ..PA1 IN PLACE OF PARAMETERS TO MVW D3 SIMULATE A TM SUBROUTINE CALL. JMP SPR88 SPC 4 * * RESTART THE PROCESS AFTER * A MEMORY SUSPEND OPERATION. SPC 1 MSU50 JSB RELBU DLD STKPT,I RESTART PROCESS DST S LDB ..PA1 RESTORE CALLING SEQUENCE MVW D10 AT THE TIME OF THE MEM. SUSP. LDA STKPT ADA D8 RETREIVE SUBROUTINE CODE OF LDA A,I SUSPENDED OPERATION STA SCODE AND JMP SAV40 RESTART FROM THE SUSP. POINT HED WRITE/READ AND LOGGING REQUEST WRRQ JSB RELBU RELEASE OUTPUT BUFFER LDB STKPT RECALL STACK POINTER ADB D8 RETREIVE FUNCTION PARAMATERS STB 1 WRRQ3 SET READ BUFFER LENGTH INB TO GET USER SUPPLIED CTL BIT LDA B,I GET CTL BIT ADB DM7 TO GET CB1 ADDR. LDB B,I GET CB1 ADDR. INB SZA,RSS USER SUPPLY THE CTL BIT ? LDA B,I NO, GET THE STANDARD ONE AND =B177400 ISOLATE CTL BITS RAR,RAR POSITION CTL BIT ADB DM1 TO RETREIVE LU IOR B,I MERGE WITH LU STA TEMP SAVE CONTROL WORD JSB EXEC DO THE READ REQUEST DEF *+10 DEF D17 READ REQUEST DEF TEMP LU DEF * BUFFER ADDR. WRRQ3 NOP BUFFER LENGTH DEF STKPT 1ST PARAM (STACK POINTER) DEF D1 2ND PARAM (SCODE FOR READ RQ) DEF CLASS CLASS I/O WORD DEF * PLACE HOLDER DEF RNLCK BYPASS THE LU-LOCK CHECK JMP IDLE RETURN SPC 1 D17 DEC 17 DM7 DEC -7 SPC 2 LOGRT LDA TEMP RECALL HARDWARE STATUS OF THE LOGGING WRITE AND O40 IS IT END OF SZA,RSS THE LOGGING TAPE ? JMP IDL02 NO, IT IS OK, RELEASE BUF. AND RETURN TO 'TMLIB' * JSB CLLOG YES, BUT LAST WRITE IS OK, CLOSE THE LOGG LDA D2 REPORT "END OF TAPE" ERROR JSB LOGER JSB OPLOG 'OPEN' THE NEW LOGG TAPE JMP IDL02 RELEASE THE BUF. & RETURN TO 'TMLIB' * O40 OCT 40 D65 DEC 65 HED IMAGE REQUEST IMULK LDX #LU BEFORE UNLCK, CHECK THAT LOCKID IS NOT USE SPC 1 IMUL2 LAX .STKT,I A=STACK POINTER LDB A,I GET S VALUE SSB STACK ACTIVE ? JMP IMUL7 NO, FORGET IT ADA D2 ADDR. OF ACTUAL CB1 ADDR LDB A,I RETREIVE CB1 ADDR. (0 IF NOT ALLOCATED) ADB D6 ADDR. OF CB1(7) (LOCK ID WORD) ADA D6 PRESET A TO GET LOCK ID FROM STACK CPB D6 CB1 ALLOCATED ? LDB A NO, THEN THE LOCK ID IS STILL ON THE STACK ADA D2 PRESET A TO EXAMINE z ERROR, RELEASE BUFFER JMP .ER21 AND ABORT TMS. HED COMMON-BLOCK ENABLE/DISABLE PROCESS CBENB LDA .PAR1 SET UP MEMORY SUSP. FLAG STA MSUFL AS REQUESTED BY THE USER LDA ..PA2 JSB MEMOK CHECK THAT THERE IS ENOUGH MEMORY LDA ..PA2 OK, PERFORM THE FUNCTION STA TEMP1 * CBEN3 LDA TEMP1,I GET PARAMETER SZA,RSS PARAMETER DEFINED ? JMP EXITZ NO, RETURN TO THE OTHER PROG. JSB GECB# YES, GET CB # JSB COM.E ENABLE & ALLOCATE THIS CB HLT 43B MEMORY SUSPEND RETURN SZA,RSS ALLOCATED DONE ? .ER05 JSB ERRAB NO, LOCAL CB LENGTH =0 ---> ABORT TMS ISZ TEMP1 GET NEXT PARAMETER JMP CBEN3 SPC 1 CBDES LDA ..PA1 STA TEMP1 * CBDE3 LDA TEMP1,I GET PARAMETER SZA,RSS PARAMETER DEFINED ? JMP CBDE5 NO, RETURN MEMORY AND EXIT JSB GECB# YES, GET CB # JSB COM.D DISABLE CB ISZ TEMP1 GET NEXT PARAMETER JMP CBDE3 * CBDE5 JSB CLECO RETURN FREE MEMORY TO MMGT JMP EXITZ EXIT SPC 1 CBLEN LDA .PAR1 CHANGE CB LENGTH JSB GECB# RETREIVE CB # JSB COM.U INIT A,B & Y SZA .ER19 JSB ERRAB ALREADY ALLOCATED SSB,RSS JMP .ER19 ALREADY ENABLED ELB,CLE,ERB CLEAR BIT 15 CMB MAKE OLD LENGTH NEGATIVE - 1 LDA .PAR2 GET NEW LENGTH SSA LEGAL ? .ER20 JSB ERRAB NO, ERROR !! SZA,RSS YES, DO MORE CHECK JMP .ER20 IT IS BAD ADB A NEW LEN - OLD LEN CCE,SSB,RSS NEW LENGTH OK ? JMP .ER20 NO, ERROR ALS,ERA YES, SET NEW LENGTH STA TEMP,I IN THE STACK JMP EXIT4 AND RETURN. HED TM SUBROUTINE CALL/EXIT PROCESS SBCAL LDB STKPT CHECK FOR STACK OVERFLOW CMB,INB ADB S ADB =D24 (ALWAYS 11 EXTRA FREE WORDS ON STACK) CMB,INB ADB STKLN T SSB STACK OVERFLOW ? .ER12 JSB ERRAB YES, ERROR ALWAYS ABORT !! LDB S NO, STACK THE SUBROUTINE BUSINESS LDA Q COMPUTE DELTA Q CMA,INA ADA S CMA (-X-1) ROOM FOR DELTA Q STA B,I SAVE MINUS DELTA Q IN THE STACK INB STB TEMP SAVE NEW Q REGISTER VALUE SPC 1 LDB ..PA1 RECALL TM-SUBROUTINE NAME/# ADDR JSB GTSU# GET TM-SUB # (A=TMSUB # ON EXIT) JMP SBCER ERROR RETURN (A = ERR#) LDB TEMP SET B REG TO ACCESS THE STACK STA B,I SAVE TMSUB # INTO THE STACK INB CLA CLEAR THE STACK ADB Q.LN0 B CONTAIN THE NEW S REG VALU LDX Q$LN0 USE X REG AS COUNTER TO CLEAR THE STACK SAX B,I CLEAR /RTN ADDR/ ISX JMP *-3 LDA TEMP GET NEW Q REG. VALUE SWP DST STKPT,I SAVE NEW S & Q REGISTER JMP EXITZ JMP EXIT4 = DO NOT LEAVE THIS PROCESS SPC 1 SBCER LDB D10 NO ABORT PROCESSING STB SCODE SET RETURN SUBROUTINE CODE CMA,INA SET STATUS WITH NEG. ERROR CODE JMP SBRT3 AND EXIT WITH TM-SUB RETURN CODE SPC 2 SBRTN JSB DSTAK AJUST THE STACK JSB CLECO DE-ALLOCATE ALL NECESSARY CB CLA SET STATUS TO OK SBRT3 CLB CLEAR TLOG AND JSB SETST STORE STAT. & TLOG IN CB1 WORD 4 & 5 JMP EXITZ JMP EXIT4 = DO NOT LEAVE THIS PROCESS SPC 3 GTSU# NOP GET TMS-SUB # (B=ADDR OF NAME/#) LDA B,I CHECK FOR THE "NO ABORT" BIT RAL,CLE,SLA,ERA CLEAR AND CHECK BIT 15 STA NOABT SET NOABT FLAG, IF NECESSARY STA B,I AND STORE BACK THE FIRST PARAMETER ADA =D-256 IS THE SUBROUTINE DEFINED SSA BY NAME ? JMP GTSU2 NO, IT IS THE SUBROUTINE # LDA .TMSB,I YES, SUBROUTINE CALL BY NAME STA TEMP1 SAVE # OF SUBROUTINE CMA,INA STA TEMP2 USE AS COUNTER STB TEMP4 SAVE B REG. * GTSU5 LDA TEMP2 ADA TEMP1 STA TEMP3 ALS,ALS MPY BY 4 ADA TEMP3 THEN IT IS MPY D5 INA ADA .TMSB LDB TEMP4 ADDR. OF ASKED FOR SUB. NAME CMW D3 JMP GTSU7 IT IS THIS ONE NOP LESS THAN ISZ TEMP2 GREATER THAN, MORE TM SUBROUTINE ? JMP GTSU5 YES, LOOP UNTIL END .ER10 JSB ERROR NO, SUBROUTINE NAME NOT FOUND JMP GTSU#,I NO ABORT PROCESSING * GTSU7 LDA TEMP3 INA A IS THE SUB # LDB TEMP4 RESTORE B REG STA B,I AND STORE TMS-SUB # IN PLACE OF NAME * GTSU2 LDA B,I IT IS THE SUBROUTINE # SZA,RSS JMP GTSUE ILLEGAL SUB # CMA,INA CHECK THE LEGALITY ADA .TMSB,I SSA IS IT LEGAL ? JMP GTSUE NO, ILLEGAL SUBROUTINE # LDA B,I YES, GET SUB # ISZ GTSU# RETURN OK JMP GTSU#,I SPC 1 .ER11 EQU * GTSUE JSB ERROR ILLEGAL TMS-SUB NUMBER JMP GTSU#,I IF NO-ABORT RETURN IN ERROR RETURN SKP DFINE LDA RQCNT THIS CALL MUST HAVE AT LEAST ADA =D-3 TREE PARAMETERS SSA OK ? .ER09 JSB ERRAB NO, ERROR --> ABORT TMS LDA Q,I RECALL TMS-SUBR. # IN ORDER AND =B37777 TO SET UP 'EPAOS', CLEAR BIT 14 & 15 MPY D5 ADA .TMSB A=ADDR OF 'EPAOS' LDB .PAR5+5 RECALL 'ENTRY POINT ADDR. OF SUBROUTINE' STB A,I FROM 'TMLIB' BUFFER TO SAVE IT. LDA Q CHECK THAT ADA Q.LN0 COMMON IS NOT ALREADY DEFINED INA CPA S COMMON ALREADY DEFINED ? .RSS RSS NO CONTINUE .ER14 JSB ERRAB YES, 2ND TMDFN IN SAME TMSUB --> ABORT TMS LDX =D-2 SET UP LOAD INDEX LDY D0 SET UP STORE INDEX LBX .PAR3 * DFIN1 SBY BUF SAVE COMMON BLOCK DEFINITION CMB,INB IN A TEMPORARY BUFFER STB A  ISX NOP FORGET THE SKIP !! LBX .PAR3 GET NEXT PARAMETER SZB,RSS JMP DFIN2 ADA B COMPUTE CB LENGTH AND SSA .ER08 JSB ERRAB ERROR IN CB DEFINTION --> ABORT TMS IOR BIT15 SET BIT 15 (NOT ENABLE) ISY SAY BUF STORE LEN ISY JMP DFIN1 * DFIN2 LDA BUF+1 TRUE COMMON LENGTH RAL,CLE,ERA ALWAYS ENABLE SZA,RSS IS TRUE CB DEFINED IN THIS TM-SUBROUTINE ? JMP DFIN3 NO, NO TRUE COMMON IN THIS TM-SUBROUTINE LDB LEN00 YES, IS TRUE COMMON SZB,RSS ALREADY DEFINED ? STA LEN00 NO, INIT LEN0 CPA LEN00 YES, IT MUST HAVE THE RSS THE SAME LENGTH THAT THE FIRST ONE .ER04 JSB ERRAB NO, ERROR ---> ABORT TMS LDA Q,I SET CB0 DEFINED FLAG IOR BIT15 BY MERGING BIT15 WITH THE STA Q,I TMS SUBROUTINE # IN THE STACK * DFIN3 CXA RECALL # OF CB'S ALS MULTIPLY BY 2 TO COMPUTE LEN IN STACK STA TEMP ADA S A IS THE NEW S REGISTER STA STKPT,I SAVE NEW S IN THE STACK * LDA .BUF2 NOW PUSH CB DEFINITION ONTO LDB S THE STACK MVW TEMP * LDA STKPT INA NOW ENABLE AUTOMATICALLY STA PT ALL PREVIOUSLY ALLOCATED CB * DFIN5 LAX PT,I GET ACTUAL CB ADDR SZA,RSS ALLOCATED ? JMP DFIN6 NO STX COMB# YES, ENABLE IT JSB COM.E NO PHYSICAL CALL TO MMGT (NO MEM-SUSP PB) HLT 45B MEMORY SUSPEND RETURN !! DFIN6 DSX MORE COMMON BLOCK JMP DFIN5 YES, CONTINUE * ISZ PT LDA PT,I IS FIRST COMMON BLOCK SZA CURRENTLY ALLOCATED ? JMP EXIT4 YES, EXIT SPC 1 LDB DFNCD NO, ALLOCATE CB # 1 STB SCODE SET SPECIAL OP-CODE FOR MEM. SUSP. DFN10 LDA STKPT ADA =D7 LDX A,I RESTORE X TO GcET LU & TYPE LATER INA LDB A,I RECALL LOCK ID WORD STB TEMP1 CLA,INA ENABLE THE FIRST COMMON BLOCK STA COMB# JSB COM.E JMP DFN15 MEMORY SUSPEND RETURN !! SZA,RSS ALLOCATED DONE ? .ER03 JSB ERRAB NO CB1 IN THE 1ST TMSUB. OF A PROCESS LBX .TMLU,I GET LU STB A,I AND SAVE IT IN 1ST WORD OF THE CB#1 INA LDB =B2000 READ-WRITE CONTROL BITS STB A,I READ CTL=400B, WRITE CTL=0B INA LBX .TMTP,I STB A,I SET DEVICE TYPE LDB TEMP,I RECALL CB1 LENGTH ADB =D-3 TREE FIRST WORDS ARE ALREADY SET UP SSB CB1 LENGTH < 3 JMP .ER03 YES, ERROR SZB,RSS JMP .ER03 CBX USE X REG AS A COUNTER CLB INIT THE CB1 TO 0 SBX A,I DSX JMP *-3 LDB TEMP,I RECALL CB1 LENGTH ADB =D-7 SSB LEN > 7 JMP DFN11 NO ADA =D4 YES, SET LOCK ID WORD LDB TEMP1 INTO STB A,I CB1(7) SSB IMAGE DATA-BASE DEFINED ? JMP DFN11 NO, CONTINUE LDB IMCRC YES, SET DATA-BASE CRC INTO INA CB1, NEXT WORD AFTER LOCKID STB A,I DFN11 LDA DFNS# RESET THE SUBROUTINE CODE STA SCODE JMP EXIT4 SPC 1 * MEMORY SUSPEND PROCESSING. SPC 1 DFN15 LDA TEMP,I GET CB1 LENGTH LDB STKPT AND PUT IT IN THE STACK ADB =D7 IN PLACE OF NEEDED MEMORY LENGTH ADA =D3 TO REQUEST 3 EXTRA WORDS STA B,I JMP MSU10 AND PUT IN MEMORY SUSPEND. * DFNCD DEC 22 D9 DEC 9 DFNS# EQU D9 SPC 1 Q.LN0 DEC 1 Q$LN0 DEC -1 .BUF2 DEF BUF+2 HED TMS PAUSE PROCESS PAUS JSB STIME SAVE CURRENT TIME. LDA STKPT ADA D7 STA TEMP ROOM TO STORE FUTURE TIME VALUE ADA D2 STA TEMP3 LINK ADDR LDA .PAR1 GEeT TIME OF THE PAUSE SSA .ER18 JSB ERRAB MUST BE POSITIVE SZA,RSS JMP EXITZ ALLOWS OTHERS PROCESS TO RUN CLB DST X DLD TTIME JSB DADD ADD TO CURRENT ONE DST TEMP,I AND SAVE FINAL TIME IN STACK JSB DCMX COMPLEMENTE IT DST X AND SAVE IT * LDB .PAUZ GET PAUSE QUEUE HEAD RSS PAUS3 LDB TEMP2 LDA B,I SZA,RSS END OF QUEUE ? JMP PAUS4 YES, ADD NEW ENTRY HERE STB TEMP4 STA TEMP2 ADA =D-2 TO GET TIME IN THIS STACK DLD A,I GET TIME IN STACK JSB DADD COMPARE THE TWO TIME SSB COMPARE ? JMP PAUS3 STACK IN QUEUE < NEW STACK --> LOOP SZB HLT 50B LDB TEMP4 S.I.Q > N.S ---> QUEUE NEW STACK HERE LDA B,I GET NEXT LINK PAUS4 STA TEMP3,I SET IN NEW STACK LDA TEMP3 AND SET NEW STACK STA B,I IN THE QUEUE LDA .PAR1 CPB .PAUZ DID WE CHANGE THE QUEUE HEAD ? JMP PAUS8 YES, MUST REQUEST ANOTHER TIME JMP IDLEZ NO, DO NOT CHANGE TIME REQUESTD TO TIMER SPC 2 PAUS0 JSB RELBU TIMER IS BACK HERE, RELEASE THE BUFFER PAUS5 LDA .PAUZ,I AND PROCESS THE PAUSE QUEUE SZA,RSS JMP IDLEZ (HLT) ?????????????????????????????????????????? LDB A,I GET NEXT LINK STB .PAUZ,I ADA =D-9 STA STKPT RE-INIT STACK POINTER LDA PAUCD RE-INIT PAUSE SUBROUTINE CODE STA SCODE SZB,RSS PAUSE QUEUE EMPTY ? JMP EXIT4 YES, RETURN TO TMS LIBRARY NOW JSB WRI/O NO, RE-QUEUE A GOOD BUFFER JSB STIME AND RESTART THE TIMER FOR THE QUEUE HEAD LDB .PAUZ,I GET THE FIRST ONE IN ADB =D-2 THE QUEUE TO SCHEDULE DLD B,I GET FINAL TIME JSB DADD FINAL TIME - CURRENT TIME SSB JMP PAUS5 TOO LATE, PROCESS IT IMMETIALLY SZB  HLT 52B PAUS8 CMA,INA INDICATE ABSOLUTE OFFSET SSA,RSS JMP PAUS5 TOO LATE, PROCESS IT IMMEDIATELY STA STIME * JSB EXEC PUT "TMST" IN THE TIME LIST DEF *+6 DEF D12 TIMED EXECUTION (INITIAL OFFSET) DEF .TMST,I PROGRAM NAME DEF D1 RESOLUTION CODE ( 1/100 SEC) DEF D0 EXECUTION MULT. (ONLY ONCE) DEF STIME INITIAL TIME OFFSET JMP IDLEZ GOTO IDLE LOOP * D12 DEC 12 SPC 1 STIME NOP LDB .TIME XLA B,I GET CURRENT TIME FROM THE SYSTEM MAP INB XLB B,I DST TTIME JSB DCMX DST X JMP STIME,I * .TIME DEF $TIME+0 TTIME BSS 2 SPC 2 DADD NOP A,B PLUS X,X+1 CLE ADA X ADD LEAST SIGNIFICANT BITS CLO SEZ,CLE INB PROPAGATE CARRY OUT ADB X+1 ADD MOST SIGNIFICANT BITS SOC OVERFLOW ? HLT 53B JMP DADD,I SPC 1 DCMX NOP TWO'COMPLEMENT OF A,B CMA ONE' COMPLEMEMT CMB DST X CLA,INA AND THEN ADD ONE. CLB JSB DADD JMP DCMX,I X BSS 2 SPC 2 .PAUZ DEF *+1 PAUSE QUEUE HEAD OCT 0 SPC 1 HED TMS SUB-PROCESS LAUNCHING PROCESS ISPRL LDB LUXXX,I INITIAL-PROCESS LAUNCHING SZB,RSS LU DEFINED ? LDB LU NO, GET CONSOLE LU STB .PAR1 LDB ..PA2 LDA PNXXX INITIAL PROCESS NAME ADDR MVW D3 JMP SPR01 SPC 2 SPR00 JSB RELBU PROCESS LAUNCH FROM 'TMSL', RELEASE BUFFER LDA .BUF AND GET PARAMETERS PASSE BY LDB ..PA1 'TMSL' TO MOVE THEM MVW D4 INTO THE RIGTH BUFFER SPR01 CLA,CCE STA .PAR5 NO CB ARE PASSED TO THE PROCESS STA .PAR5+1 STA .PAR5+2 STA .PAR5+3 STA STKPT NO STACK EXIST RIGHT NOW LDA .PAR2 SET THE NO ABORT BIT IN RAL,ERA hHFB THE TM-SUBROUTINE NAME STA .PAR2 SPC 1 SPRL CCA SET SUBPRO-QUEUE FLAG TO 'QUEUE UP' STA SPRQF LDA .PAR1 RECALL LU (BIT15 --> DO NOT QUEUE SUBPRO.) RAL,CLE,SLA,ERA CLEAR BIT15 AND STA SPRQF SET SUBPRO-QUEUE FLAG TO 'DO NOT QUEUE' STA SPRLU SAVE LU LDB ..PA2 RECALL TMSUB NAME/# ADDR JSB GTSU# RECALL TMSUB # IN A REG. & .PAR2 CMA,INA,RSS ILLEGAL NAME OR # RETURN CLA RETURN OK NHADA =D4 STA TEMP1 * SPR15 LDA TEMP1,I GET LOCAL CB ADDR FROM SZA,RSS THE CALLING SEQUENCE, CB HERE ? JMP SPR20 NO, IT IS THE END OF LIST JSB GECB# YES, SET COMB# = CB NUMBER JSB COM.U INIT A, B & Y SZA,RSS ALLOCATED ? JMP SPR18 NO, GOTO NEXT ONE SSB YES, ENABLED ? JMP SPR18 NO, GOTO NEXT ONE STB TEMP3 SAVE LOCAL CB LEN FOR MOVE ADB =D3 REQUEST THREE EXTRA WORD FROM MMGT STB *+2 JSB .MGTG ALLOCATE MEMORY NOP REQUESTED LEN JMP .ER13 HLT 55B MEMORY SUSPEND ???????????????????????????????????? STB A,I SAVE ACTUAL SIZE OF BLOCK INA CLB NO PREVIOUS CB ADDR STB A,I ADA D2 STA TEMP1,I SAVE ACTUAL CB ADDR LDB A THIS IS THE TO ADDR LAY STKPT,I GET ACTUAL CB ADDR OF ORIGINAL CB MVW TEMP3 MOVE FROM ORIGINAL TO THE NEW ONE SPR16 ISZ TEMP1 BUMP POINTER INTO CALLING SEQUENCE JMP SPR15 AND LOOP UNTIL END OF LIST * SPR18 CLA SET ACTUAL CB ADDR TO ZERO STA TEMP1,I JMP SPR16 SPC 1 SPR20 LBX .STKT,I GET STACK POINTER LDA B,I SSA,RSS IS THIS LU FREE ? JMP SPR70 NO, GO TO QUEUE THIS REQUEST JSB INSTK YES, INITIALIZE STACK LAX .TMLU,I GET AUXILIARY LU STA TEMP,I AND SAVE IT INTO THE STACK AT S+1 LDB STKPT INIT B JSB LRQ TRY TO LOCK LU JMP SPR85 LOCK WAS SUCCESSFULL, START SON PROCESS SPC 1 LDA SPRQF LOCK HAS FAILED, RECALL QUEUE FLAG SSA QUEUED REQUEST ? JMP SPR22 YES, INSERT REQUEST INTO EXTER. EVENTS QUEUE LDA BIT15 NO, RETURN STATUS TO CALLING PROCESS AND STA STKPT,I DO NOT START SON PROCESS. FREE STACK AGAIN LDA SPRLU RESTORE STACK POINTER STA STKPT SPR21 CCA RETURN STAT.=-1 TO CALLITNG PROCESS, TO CLB INDICATE THAT THE 'TMPRO' RQ IS NEITHER JSB SETST EXECUTED OR QUEUED. LDA STKPT PROCESS LAUNCH FROM SZA,RSS INSIDE ? JMP STAR8 NO, OK * LDX D4 YES, MUST RELEASE ALL ALLOCATED CB LDA ..PA1 ADA D3 STA TEMP2 * SPR61 LAX TEMP2,I CB HERE ? SZA,RSS CB HERE ? JMP SPR64 NO, NO CB HERE GO TO NEXT ONE ADA =D-3 YES, RETREIVE LENGTH LDB A,I TO RELEASE THE MEMORY DST SPR63 JSB .MGTR RETURN MEMORY SPR63 BSS 2 SPR64 DSX MORE CB'S JMP SPR61 YES, LOOP JMP STAR8 NO, EXIT SPC 1 SPR22 ADB =D9 LDA .EXTW,I SET UP TO QUEUE ON THE STA B,I EXTERNAL EVENT WAIT QUEUE STB .EXTW,I LDA .LRQX SET SUBROUTINE ADR INTO THE STACK STA S,I AT S LOCATION INB UPDATE B AND QUEUE THE REQUEST JMP SPR72 SPC 2 * THE LU IS BUSY OR LOCK BY AN OTHER RTE PROGRAM * QUEUE THIS REQUEST IN THE WAITING QUEUE OF * THIS AUXILIARY LU. (REQUEST A 11 WORDS BLOCK TO * MMGT TO SAVE ALL INFORMATIONS) * SPR70 ADB D10 UPDATE B LDA SPRQF AUTOMATIC QUEUE FEATURE SSA,RSS REQUESTED ? JMP SPR21 NO, RETURN STATUS TO CALLING PROCESS SPR72 LDA B,I SZA,RSS JMP SPR75 END OF LIST STA B CONTINUE UNTIL END OF LIST JMP SPR72 * SPR75 STB TEMP1 SAVE ADDR OF LAST ELEMENT IN JSB .MGTG THE QUEUE D11 DEC 11 REQUEST 11 WORDS TO MMGT HLT 56B JMP SPR77 MEMORY SUSPEND RETURN !! STB A,I SAVE ACTUAL BLOCK LENGTH INA STA TEMP1,I LINK THIS BLOCK IN THE LIST CLB STB 0,I END OF LIST INA STX A,I SAVE INDEX TO TMLU TABLE INA LDB A TO ADDR LDA ..PA2 MVW =D8 SAVE ADDR OF CB ,CTO BE PASSED TO JMP IDLE THE SUB-PROCESS, RETURN SPC 1 SPR77 LDA STKPT THIS PROCESS MUST HAVE BEEN SZA LAUNCHED FROM OUTSIDE, IS IT ? HLT 60B NO !!!!!!!!!!!!!!!!!!!!!!!! LDA =D18 SET UP SPECIAL STA SCODE SUBROUTINE CODE LDA D4 AND QUEUE UP AGAIN STA WRI/L THIS EXTERNAL REQUEST IN THE JSB WRI/O CLASS I/O QUEUE CLA,INA (THIS WILL LOAD THE SYSTEM A LOT STA WRI/L BUT WHAT CAN WE DO ?) JMP IDLE SPC 2 * PREVIOUS PROCESS HAS COMPLETED, * START THE FIRST ONE OF THE WAITING QUEUE * (USE THE 11 WORDS BLOCK AND REALESE THIS BLOCK) SPC 1 SPR80 JSB STIPR START INTERAC. PROCESS (CLEARED WHEN DONE) LDA STKPT END OF SUB-PROCESS ADA D10 CHECK IF SOMETHING IS LDB A,I WAITING FOR THIS LU SZB,RSS WAITING QUEUE EMPTY ? JMP SPR93 YES, UNLOCK LU AND SET IT INACTIVE STB TEMP1 SAVE ADD+1 OF THIS BLOCK LDB B,I AND LINK THE NEXT ONE STB A,I IN PLACE OF THIS ONE. * LDA TEMP1 INA RESTORE INDEX IN TMLU TABLE LDX A,I * INA RESTORE ALL PARAMETERS LDB ..PA2 MVW =D8 * LDA TEMP1 RETURN THIS BLOCK OF MEMORY ADA DM1 TO MMGT LDB A,I GET ACTUAL LENGTH DST SPR82 JSB .MGTR RETURN MEMORY SPR82 BSS 2 LDB STKPT RESTORE B REGISTER JSB INSTK RE-INIT STACK SPC 1 SPR85 LDX D4 SETS CB TO BE PASSED TO THE LDA STKPT SUB-PROCESS, IN THE STACK NOW ADA D2 WITH THE Q VALUE OF THE NEXT STEP ! STA TEMP1 LDA ..PA1 ADA D3 STA TEMP2 * SPR86 LAX TEMP2,I CB TO PASS ? SZA,RSS JMP SPR87 NO CB HERE, CONTINUE SAX TEMP1,I THERE IS ONE, SET ADDR IN STACK LDB TEMP ADA DM1 STB A,I SET NEXT Q VALUEY IN CB SPR87 DSX MORE CB ? JMP SPR86 YES, CONTINUE SPC 1 LDA .PAR2 RECALL T.U.S. NUMBER TO SIMULATE STA .PAR1 A 'TMSUB' CALL NOW. SPR88 LDA =D8 STA SCODE SIMULATE TM SUB CALL JMP SBCAL SPC 2 * PREVIOUS PROCESS HAS COMPLETED, * AND NO REQUEST IS QUEUING FOR THAT LU * SET THIS LU INACTIVE AND UNLOCK IT (RTE LU UNLOCK) * SPC 1 SPR93 LDB BIT15 SET LU INACTIVE STB STKPT,I ADA DM3 TO RECALL TEMP1 FROM STACK STA SPR95 TO UNLCK THE AUXILIARY LU JSB LURQ DEF *+4 DEF O40K UNLOCK LU SPR95 NOP LU ADDR. DEF D1 UNLOCK ONLY ONE LU HLT 62B ERROR RETURN SZA UNLOCK OK ? HLT 63B JMP IDLE AND RETURN TO IDLE LOOP SPC 3 INSTK NOP INITIALIZE STACK ROUTINE STB STKPT LDY =D9 CLEAR THE FIRST 9 WORDS OF STACK CLA SAY B,I DSY JMP *-3 DLD S0 ADA STKPT ABSOLUTE S VALUE ADB STKPT ABSOLUTE Q VALUE DST S DST STKPT,I SET S & Q INITIAL VALUE INA STA TEMP SAVE NEXT Q VALUE LDA BIT14 SET BIT14 THAT INDICATE STACK FOR STA B,I AUXILIARY LU (SPECIAL RTN CD=0) ADB DM3 LDA .PAR5+4 SAVE LOCK ID WORD INTO STA B,I THE STACK TO INIT CB1(7) LATER. LDA IMPRG IMAGE DATA-BASE SZA DEFINED ? JMP INST8 YES, CONTINUE CCA NO, SET LOCKID=-1 TO SIGNAL NO STA B,I DATA-BASE IS DEFINED INST8 ADB DM1 SAVE X REG INTO STX B,I THE STACK TO INIT CB1(1) & CB1(3) JMP INSTK,I TO ENABLE AND INIT CB1 SPC 2 .LRQX DEF *+1 NOP SUBROUTINE ENTRY POINT JSB LRQ RSS OK, RESTART THE PROCESS JMP .LRQX+1,I LOCK FAIL, RETURN JSB DEXTW DEQUEUE FROM EXTERNAL EVENT WAIT QUEUE JMP SPR8g0 AND RESTART THE PROCESS SPC 1 LRQ NOP LDA B,I A = S REG. INA STA LRQ3 SET LU ADDR. JSB LURQ LU LOCK DEF *+4 DEF IOPTN LRQ3 NOP LU DEF D1 # OF LU HLT 64B ERROR RETURN SZA LOCK DONE ? ISZ LRQ NO, RETURN P+2 JMP LRQ,I YES, RETRUN P+1 SPC 2 ..PA2 DEF .PAR2 BIT14 EQU O40K SPRQF NOP SON PROCESS QUEUE REQUEST FLAG SPRLU NOP SON PROCESS LU HED TMS SCHEDULE NON-TMS PROGRAM PROCESS SCHPR LDA ..PA1 ADA D2 SKIP PROGRAM NAME STA TEMP1 USE AS POINTER TO ACCESS USER PARAM * CCA STA SRFLG SET SEND MAIL BOX FLAG * LDA ICLAS SAVE TMS-INTERNAL CLASS WORD STA SCHPZ CLA STA ICLAS INIT ICLAS TO ALLOCATE A CLASS WORD STA RTRNA INIT LENGTH OF 1ST CB SEND * SCH02 ISZ TEMP1 SCH03 LDA TEMP1,I GET PARAM SZA,RSS END OF LIST ? JMP SCH20 YES, JSB GECB# NO, SET COMB# = CB NUMBER JSB COM.U AND INIT A, B & Y SZA,RSS ALLOCATED ? JMP SCH02 NO, FORGET IT SSB YES, ENABLED ? JMP SCH02 NO, FORGET IT DST SCH15 YES, SET MAILB PARAM SCH05 ISZ TEMP1 GET LENGTH OF NEXT CB LDA TEMP1,I CLB SZA,RSS END OF LIST ? JMP SCH07 YES, SEND THE CURRENT ONE JSB GECB# NO, TRY TO GET LENGTH JSB COM.U SZA,RSS ALLOCATED ? JMP SCH05 NO, FORGET IT SSB YES, ENABLED ? JMP SCH05 NO, FORGET IT SCH07 STB TEMP YES, SAVE LENGTH OF NEXT CB LDB SCH15+1 RECALL LENGTH OF CURRENT CB LDA RTRNA RTRNA ALREADY SZA,RSS INIATILIZED ? STB RTRNA NO, SET 1ST CB LEN SEND LDA TEMP RECALL NEXT CB LENGTH JSB MAILB AND SEND CURRENT CB SCH15 BSS 2 JMP SCH03 LOOP UNTIL END S37 DEF MS3+7 ERR. ASC 2,ERR ASC@ ASC 1, @ HED TERMINAL-MONITOR ERROR CONDITION PROCESS .ERR DEC 22 TOTAL NUMBER OF ERRORS NOP 1 INTERAC. LU'S DOWN OR LOCKED DEF .ER02+1 2 NOT ENOUGH MEM FOR STACK ALLOCATION DEF .ER03+1 3 NO OR BAD CB1 IN 1ST TUS OF A PROCESS DEF .ER04+1 4 TRUE COMMON HAS NOT THE SAME LENGTH DEF .ER05+1 5 ENABLE CB WITH LENGTH = 0 DEF .ER06+1 6 ENABLE CB FOR THE 2ND TIME DEF .ER07+1 7 'RETURN' IN AN INTERAC. PROCESS DEF .ER08+1 8 CB DEFINTION ERROR DEF .ER09+1 9 'TMDFN' HAS LESS THAN 3 PARAMETERS DEF .ER10+1 10 T.U.S. NAME NOT FOUND DEF .ER11+1 11 ILLEGAL T.U.S. NUMBER DEF .ER12+1 12 STACK OVERFLOW ('TMSUB' CALL) --> ABT DEF .ER13+1 13 CB LENGTH > EVER AVAILABLE MEMORY DEF .ER14+1 14 2ND 'TMDFN' IN A T.U.S. --> ABT DEF .ER15+1 15 BAD CB IN 'TMCBE/D' (LEN=0 OR 1ST CB) DEF .ER16+1 16 DISABLE A NO-ALLOCATED CB DEF .ER17+1 17 DISABLE A NO-ENABLE CB DEF .ER18+1 18 TIME IN 'TMPZ' REQUEST IS NOT LEGAL DEF .ER19+1 19 CHANGE CB LEN OF AN ENABLED CB DEF .ER20+1 20 NEW CB LEN IN 'TMCBL' IS NOT LEGAL .IMER DEF .ER21+1 21 RESERVED FOR IMAGE ERROR DEF .ER22+1 22 SCHEDULE A NON-TMS PRG NOT LOADED NOP 23 INTERNAL TMS ERROR (LOGIQUE/TABLE) NOP (TMLIB#4) 24 TMS USER CALL HAS MORE THAN 9 PARAM. NOP (TMLIB#5) 25 'TMDFN' NOT 1ST CALL IN A T.U.S. NOP (TMLIB#6) 26 CB1 DISABLE DURING AN I/O CALL NOP (TMLIB#7) 27 CB1 DISABLE/TOO SMALL FOR 'TBXXX' CALL NOP 28 RESERVED FOR LOGGING ERROR SPC 1 IMERC ABS .IMER-.ERR SPC 3 ERRAB NOP ERROR PROCESS FOR FATALS ERRORS CCA STA NOABT SET ABORT FLAG LDA ERRAB STA ERROR JMP ERROR+1 SPC 1 ERROR NOP LDX .ERR ERR02 LAX .ERR CPA ERROR IS IT THIS ERROR ? JMP ERR03 DSX ENk5D OF TABLE ? JMP ERR02 NO, CONTINUE HLT 65B YES, ERROR IN ERROR !!! ???????????? SPC 1 ERR03 CXA STA ERR# SAVE ERROR # LDB NOABT CHECK TO ABORT SSB,RSS ABORT ALLOWED ? JMP ERROR,I NO ABORT ! RETURN TO CALLER ERR JSB ERRPR PRINT ERROR MESSAGE JMP ABT00 CLEAN UP AND EXIT. SPC 2 ERRPR NOP FORMAT AND PRINT ERROR MESSAGES LDA ERR# CLB DIV D10 CONVERT IT INTO ASCII SZA,RSS ADA =B-20 ADA =B60 ADB =B60 ALF,ALF ADA B STA MS0+2 LDA ERR# RECALL ERROR NUMBER CPA IMERC IS IT AN IMAGE ERROR ? RSS YES JMP ERR04 NO, CONTINUE * LDA BUF+1 RECALL TMS-IMAGE SUBROUTINE CODE MPY D3 ADA .IMGT INDEX IN IMAGE NAME TABLE LDB .MS04 AND MOVE TMS-IMAGE SUBROUTINE MVW D3 NAME INTO OUTPUT BUFFER LDA BUF RECALL IMAGE STATUS CCE DECIMAL CONVERSION JMP ERR05 SPC 1 ERR04 JSB GPNAD LDB .MS04 MVW D3 INA LDA A,I GET EPAOS CMA,INA SZA IS IT DEFINED ? ADA XSUSP YES, COMPUTE RELATIVE ADDR IN THE TM-SUBROUTINE CLE IN ABORT MESSAGE (OCTAL VALUE) ERR05 JSB $CVTX * LDB .MS08 MVW D3 ADB =D-3 CLE,ELB ERR07 LBT CPA =B40 RSS JMP ERR08 IOR =B20 ADB DM1 SBT JMP ERR07 ERR08 LDA ASC@ STA MS0+7 LDA ERR# RECALL ERROR NUMBER CPA IMERC IS IT AN IMAGE ERROR ? RSS YES JMP ERR09 NO, CONTINUE DLD ERR. DST MS0+7 SET "ERR " INTO OUTPUT BUFFER ERR09 LDA .MS0 * JSB OUTM OUTPUT "TMS XX TMSUB @123456" JMP ERRPR,I SPC 1 OUTM NOP STA OUTM3 SET MESSAGE ADDR JSB EXEC DEF *+5 DEF D2 DEF LU OUTM3 NOP  DEF D11 JMP OUTM,I SPC 1 OUTLF NOP JSB EXEC OUTPUT ONE SPACE DEF *+5 DEF D2 DEF LU DEF MS0+3 DEF DM1 ONLY ONE BYTE JMP OUTLF,I SPC 2 LULAB LDA ASC01 SET ERROR # 1 STA .LGMS+3 INTO THE ERROR MESSAGE LDA D3 SET 'DOWN OR LOCKED' ERROR MESSAGE JSB LOGER SPC 2 LOGER NOP ERROR DUE TO LOGGING DEVICE CPA LGERX SAME ERROR THAT LAST TIME ? JMP LGE30 YES, CHECK IF THE PRINT IS REQUIRED STA LGERX NO, SAVE ERROR CODE LGE15 MPY D7 ADA .LGE0 INDEX INTO ERROR MESSAGES LDB .LGM4 MVW D7 AND MOVE THE RIGHT MESSAGE LDA .LGMS RECALL MESSAGE ADDR JSB OUTM AND PRINT OUT "TMS 28 XXXXXXX " * LDA LGERX RECALL ERROR # CPA D3 FATAL ERROR ? JMP ABT3 YES, ABORT THE TMS APPLICATION CPA D2 MAG-TAPE FULL ? JMP LGE40 YES, WAIT FOR OPERATOR INPUT * LDA =D-120 INIT COUNTER STA LGERZ LGE20 JSB EXEC SUSPEND THE PROGRAM DEF *+6 FOR .25 SEC DEF D12 TIMED EXECUTION (INITIAL OFFSET) DEF D0 PROGRAM NAME DEF D1 RESOLUTION CODE ( 1/100 SEC) DEF D0 EXECUTION MULT. (ONLY ONCE) DEF DM25 WAIT 0.25 SEC JMP LOGER,I AND RETURN TO CHECK IF CONDITION CHANGE * LGE30 ISZ LGERZ END OF 30 SEC. JMP LGE20 NO, WAIT MORE JMP LGE15 YES, RE-ISSUE THE MESSAGE * LGE40 LDA LU SET UP BINARY READ IOR O100 STA TEMP JSB EXEC WAIT FOR ACKNOWLEGEMENT DEF *+5 DEF D1 DEF TEMP DEF TEMP1 DEF DM1 READ ONLY ONE CHARACTER JSB OUTLF JMP LOGER,I RETURN * .LGE0 DEF *+1 ASC 7,WRITE RING ! ASC 7,OFF LINE ! ASC 7,END OF TAPE. _ ASC 7,DOWN OR LOCKED * .LGMS DEF *+1 ASC 11,TMS 28 XXXXXXXXXXXXXX ASC01 ASC 1,01 * LGERX DEC -1 LGERZ NOP .LGM4 DEF .LGMS+5 DM25 DEC -25 SPC 2 ERR# NOP * .MS0 DEF MS0 .MS04 DEF MS0+4 .MS08 DEF MS0+8 SPC 1 .IMGT DEF *+1 ASC 12,DBOPN DBCLS TBGET TBFND ASC 12,TBPUT TBUPD TBDEL TBINF ASC 3,TBULK SPC 2 TMLER LDA .PAR1 RECALL ERROR # ADA =D20 SET IT TO ACTUAL TMS ERROR # STA ERR# JMP ERR GOTO ERROR PROCESSING SPC 4 ABTX LDA .MS3 JMP TMAB8 OUTPUT "TMS OPERATOR ABORT ! " * .MS3 DEF MS3 HED TERMINAL-MONITOR ABORT PROCESSING ABT00 CLA,INA SET SCHEDULE FLAG "WITH WAIT" STA SCHFL SPC 2 LDA IMAGE,I RECALL TMS-IMAGE-MODULE PROGRAM NAME CPA =B20040 IMAGE USED ? JMP ABT50 NO, SKIP IMAGE THINGS * LDA IMERC IMAGE IS USED, SET THE IMAGE ERROR STA ERR# JUST IN CASE CLA,INA INIT INDEX INTO BUF STA ABT21 TO,KEEP TRACK OF THE LOCKID RELEASED. * LDA ABT.1 SET UP ADDR. ROUTINE TO UNLOCK STA .IMU2 ALL RECORDS OWN BY THIS TMS LDA ABT.4 APPLICATION. STA .IMU4 JMP IMULK GO RETREIVE ALL LOCKID'S USED SPC 1 ABT.1 DEF *+1 ABT10 NOP LDB B,I GET THE LOCKID WORD SZB,RSS LOCKID WORD HERE ? JMP ABT10,I NO, CONTINUE STB TEMP YES, SAVE IT LDY ABT21 SET UP Y INDEX REG. ABT13 DSY END OF BUFFER ? RSS NO, CHECK IF THE LOCKID IS ALREADY IN BUF JMP ABT15 YES, THIS IS A NEW LOCKID, DO THE UNLOCK LBY BUF+1 RECALL LOCKID ALREADY RELEASED CPB TEMP IS IT THE SAME ? JMP ABT10,I YES, ALREADY RELEASED, FORGET IT JMP ABT13 NO, CONTINUE UP TO THE END OF BUF * ABT15 STA ABT22 SAVE A REGISTER STX ABT23 SAVE X REGISTER ISZ ABT21 BUMP BUF INDEX LDA ABT21 AND ADD THIS NEW LOCKID CPA =D47 BUF OVERFLOW ? JMP ABT.4,I YES, FORGET ALL THE UNLOCK AD(HFBA .BUF NO, SAVE THE NEW LOCKID LDB TEMP INTO BUF AND STB A,I JSB IMULO RELEASE THIS LOCKID JMP ABT17 RETURN OK DST BUF ERROR RETURN, SET UP ERROR CODES JSB ERRPR PRINT THE ERROR MESSAGE ABT17 LDA ABT22 RESTORE A REG. LDX ABT23 RESTORE X REG. JMP ABT10,I AND SEARCH THE NEXT LOCKID USED * ABT21 NOP ABT22 NOP ABT23 NOP SPC 1 ABT.4 DEF *+1 CLA,INA CLOSE DATA BASE REQUEST JSB IMRQT HLT 66B NO IMAGE DATA BASE DEFINED !!!!!!!!!!!!!!!!!!!!!!! H LDA $CVTX INA,SZA JMP STPP5 LOOP UNTIL END JMP STPPR,I * ABTCD DEC 17 SPC 3 $CVTX NOP CONVERSION PROGRAM STA $CVTY ERA STA $CVTZ JSB $OFF LDA $CVTY LDB $CVTZ CLE SSB CCE JSB $CVT3 STA $CVTY JSB $ON LDA $CVTY JMP $CVTX,I * $CVTY NOP $CVTZ NOP SPC 1 $OFF NOP JSB $LIBR OCT 0 PRIVILEDGE ROUTINE JMP $OFF,I SPC 1 $ON NOP JSB $LIBX EXIT FROM PRIVILEDGE ROUTINE DEF $ON SPC 2 RECLS NOP RELEASE ALL TMS CLASS I/O SPC 1 LDA MCLAS RELEASE MAIN CLASS I/O JSB KLCLX SPC 1 LDA ICLAS RELEASE INTERNAL CLASS I/O JSB KLCLX SPC 1 LDA CLASS RELEASE EXTERNAL CLASS I/O JSB KLCLX SPC 1 LDA CLAS0 RELEASE TRUE COMMON CLASS I/O JSB KLCLX SPC 1 LDA FMPCL RELEASE TMS-FMP CLASS I/O JSB KLCLX SPC 1 JMP RECLS,I SPC 2 KLCLX NOP STA KLCL3 JSB KLCLS DEF *+2 DEF KLCL3 SZA HLT 73B JMP KLCLX,I * KLCL3 NOP HED UTILITY SUBROUTINE * ENABLE COMMON ROUTINE: * ---------------------- SPC 1 * MUST INITIALIZE BEFORE CALL: COMB# STKPT Q SPC 1 * ATTENTION ! DESTROYED TEMP & REGITER ARE: * ----------- * TEMP Y (INDEX REG.) A B SPC 2 COM.U NOP COMMON BLOCK ENABLE/DISABLE UTILITY LDB COMB# GET BLOCK # BLS ADB Q ADB Q.LN0 STB TEMP POINTER TO LOCAL CB LENGTH LDY COMB# ISY LAY STKPT,I GET ACTUAL COM. BLOCK ADDR. LDB B,I GET LOCAL COM. BL. LENGTH JMP COM.U,I SPC 1 COM.E NOP ENABLE ONE COMMON BLOCK JSB COM.U CPB BIT15 DOES LOCAL CB EXIST ? JMP CO4.E NO, EXIT WITOUT ALLOCATION SZA,RSS ALLOCATED ? ? SSB,RSS NO, IS IT ALREADY ENABLE ? JMP CO2.E IT IS ALLOCATED OR ALREADY ENABLE CO1.E RBL,CLE,ERB NO, INDICATE COM. BL. ENABLE STB TEMP,I AND STORE BACK IN THE STACK ADB =D3 REQUEST TREE EXTRA WORD FROM MEM. MGT. STB *+2 JSB .MGTG NOP REQUESTED LENGTH .ER13 JSB ERRAB MORE THAN EVER AVAILABLE --> ABORT TMS JMP COM.E,I PUT IN MEMORY SUSPEND RETURN (P+1) !! STB A,I SAVE ACTUAL SIZE OF THE BLOCK IN 1ST WORD INA AND START USING FROM WORD # 3 LBY STKPT,I GET PREVIOUS ACTUAL CB ADDR STB A,I INA LDB Q STB A,I SAVE CURRENT Q VALUE INA SAY STKPT,I SAVE ACTUAL COM. ADDR, INDICATE ALLOCATED CO9.E ISZ COM.E RETURN OK (P+2) JMP COM.E,I * CO2.E SSB,RSS ALREADY ENABLE ? JMP CO5.E YES, IT MUST BE A LOCAL ENABLE RBL,CLE,ERB STB TEMP,I INDICATE CB ENABLED CMB,INB CAY SAVE A ADA =D-3 VERIFY NEW LOCAL LENGTH LDA A,I GET ACTUAL SIZE ADA =D-3 SUBTRACT THE 3 EXTRA WORDS ADB A ACTUAL SIZE - LOCAL SIZE SSB ACTUAL GREATER ? STA TEMP,I NO, CHANGE LOCAL SIZE TO ACTUAL SIZE CYA YES, RESTORE A TO ACTUAL COMMON ADDR JMP CO9.E SPC 1 CO4.E CLA INDICATE NO ALLOCATION DONE JMP CO9.E * CO5.E ADA =D-1 LOCAL ENABLE PROCESS LDA A,I CPA Q SECOND ENABLE IN THE SAME ROUTINE ? .ER06 JSB ERRAB YES, ERROR # 6 --> ABORT TMS JMP CO1.E NO, ALLOCATE THE CB * COMB# NOP SPC 3 MEMOK NOP A REG = FIRST CB ADDR STA TEMP1 USE IT AS POINTER * LDA =D12 INIT MEMORY NEEDED (+12) IS FOR STA TEMP3 THE 11 WORDS BLOCK (SUB-PRO LAUNCH) CLB IN CASE OF NO CB DEFINED * MEMO3 LDA TEMP1,I SZA,RSS JMP MEMO6 END OF CALLING SEQUENCE: NO mMORE CB'S JSB GECB# RETREIVE CB # JSB COM.U INIT A,B AND Y REG. RBL,CLE,ERB CLEAR BIT 15 ADB =D3 ADB TEMP3 ADD TO MEMORY NEEDED STB TEMP3 ISZ TEMP1 GET NEXT CB IN THE CALLING SEQUENCE JMP MEMO3 * MEMO6 SZB,RSS CB DEFINED ? JMP MEMOK,I NO, RETURN LDA STKPT YES, SAVE REQUIRED MEMORY SIZE ADA =D7 IN THE STACK STB A,I STB MSU03 SET REQUESTED LEN JSB .MGTG REQUEST MEMORY FROM MMGT MSU03 NOP REQUESTED LENGTH JMP .ER13 MORE THAN EVER AVAILABLE --> ABORT TMS JMP MSU10 MORE THAN NOW AVAILABLE --> MEM. SUSP. DST MSU05 OK, MEMORY IS AVAILABLE, SET TO JSB .MGTR RELEASE THE MEMORY MSU05 BSS 2 JMP MEMOK,I RETURN TO PERFORM THE FUNCTION. SPC 2 MSU10 LDA MSUFL RECALL MEMORY SUSP. FLAG SZA SUSPEND OK ? JMP MSU20 NO, DO NOT SUSPEND THE PROCESS LDB STKPT YES, SUSPEND CURRENT PROCESS ADB =D8 SET CURRENT SUBROUTINE CODE IN LDA SCODE THE STACK STA B,I INB STB TEMP SAVE ADDR OF THE LINK WORD * LDB .MSUP MEMORY SUSPEND QUEUE HEAD MSU12 LDA B,I SZA,RSS JMP MSU14 END OF QUEUE LDB A LOOP UNTIL JMP MSU12 END OF QUEUE IS REACHED * MSU14 STA TEMP,I SET END OF QUEUE IN THE NEW LINK LDA TEMP AND LINK STA B,I NEW STACK IN THE QUEUE. * LDA ..PA1 SAVE CALLING SEQUENCE PARAMETERS LDB S IN THE STACK MVW D10 THERE IS ALWAYS 10 EXTRA FREE WORDS JMP IDLE ON THE STACK ! GOTO IDLE LOOP SPC 1 MSUCD DEC 21 MSUFL NOP MEMORY SUSPEND FLAG (0 --> SUSP.) .MSUP DEF *+1 MEMORY SUSPEND QUEUE HEAD OCT 0 SPC 2 MSU20 LDB Q DO NOT SUSPEND THAT PROCESS, RETURN INB TO THE PROCESS AT THE SPECIAL STA B,I RETURN ADDR. PROVIDED /^IN THE JMP EXITZ CALLING SEQUENCE. SPC 3 COM.D NOP JSB COM.U SZA,RSS ALLOCATED ? .ER16 JSB ERRAB NO, NOT ALLOCATED, ERROR !! SSB YES, ENABLE ? .ER17 JSB ERRAB NO, NOT ENABLED, ERROR !! * ADA DM1 LDB =B77777 SET A LARGE Q VALUE STB A,I TO RETURN MEMORY WITH CLECO ROUTINE ADA DM1 LDB A,I CHECK FOR RECURSIVE ENABLE CCE,SZB RECURSIVELY ENABLED ? JMP COM.D,I YES, SO LEAVE THIS CB ENABLED LDB TEMP,I NO, INDICATE THAT CB IS RBL,ERB NOW DISABLED. STB TEMP,I JMP COM.D,I RETURN SPC 3 DSTAK NOP DE-STACK ONE LEVEL LDA Q ADA DM1 A IS THE NEW S REGISTER LDB A,I GET MINUS DELTA Q ADB Q B IS THE NEW Q REGISTER DST STKPT,I SAVE S & Q REGISTER IN THE STACK DST S SET NEW S & Q VALUE JMP DSTAK,I SPC 2 CLECO NOP CLEAR ALL NEEDED COMMON BLOCK LDB STKPT RELATED TO THE STATE OF INB THE STACK. STB PT INB POINTER TO ACTUAL ADDR. OF CB1 LDA B,I GET CB1 ADDR LDA A,I GET LU ASSOCIATED WITH THAT STACK ADB =D5 STA B,I AND SAVE IT INTO THE STACK (INTO TEMP1) LDX =D5 CCA INIT MAX LEN AVAILABLE STA TEMP * CLEC3 LAX PT,I GET ACTUAL CB ADDR. SZA,RSS CB ALLOCATED ? JMP CLEC7 NO, CHECK NEXT ONE ADA DM1 YES, CHECK IF DE-ALLOCATED LDB A,I IS NEEDED, GET Q AT TIME CMB,INB OF ALLOCATED ADB Q Q NOW - Q AT ALLOC. TIME SSB,RSS DEALLOCATED NEEDED ? JMP CLEC7 NO, CHECK NEXT ONE ADA DM1 YES, RESOLVE RECURSIVE ALLOCATION LDB A,I GET ACTUAL CB ADDR. OF PREVIOUS LEVEL SBX PT,I AND PUT IT IN THE STACK ADA DM1 LDB A,I GET LENGTH OF THIS BLOCK FROM MMGT o DST CLEC5 JSB .MGTR RELEASE THIS BUFFER, GIVE IT BACK CLEC5 BSS 2 TO THE MEMORY MANAGEMENT SYSTEM STB TEMP SAVE MAX LEN AVAILABLE JMP CLEC3 CHECK AGAIN FOR THE NEW CB ADDR. * CLEC7 DSX MORE COMMON BLOCK JMP CLEC3 YES, CONTINUE SPC 1 LDA TEMP MEMORY HAS BEEN RELEASED ? CPA DM1 JMP CLECO,I NO MEMORY RETURNED. SPC 1 LDB .MSUP TRY TO RESTART SOME PROCESSES * CLEC8 LDA B,I SZA,RSS END OF MEMORY SUSPEND QUEUE ? JMP CLECO,I YES, EXIT STB TEMP1 SAVE QUEUE POINTER STA B ADA =D-2 TO GET REQUESTED LEN LDA A,I A = PROCESS REQUESTED MEMORY LEN ADA TEMP ENOUGH AVAILABLE ? SSA,RSS JMP CLEC8 NO, TRY ANOTHER PROCESS * STA TEMP AJUST FREE MEMORY LEN LDA B,I DEQUEUE THIS PROCESS STA TEMP1,I BY LINKING NEXT ONE CLA STA B,I CLEAR LINK WORD IN THIS STACK LDA SCODE SAVE CURRENT PROCESS SUBROUTINE CODE STA TEMP2 LDA STKPT AND SAVE CURRENT PROCESS STACK ADDR STA TEMP3 LDA MSUCD SET MEMORY SUSPEND SUBROUTINE CODE STA SCODE ADB =D-9 STB STKPT JSB WRI/O REQUEUE THIS PROCESS TO RESTART IT LDA TEMP2 RESTORE CURRENT PROCESS PARAMETERS STA SCODE (SUBROUTINE CODE AND STACK POINTER) LDA TEMP3 STA STKPT LDB TEMP1 RESTORE MEMORY SUSPEND QUEUE POINTER JMP CLEC8 AND LOOP UNTIL END OF QUEUE SPC 3 GECB# NOP GET CB# FROM LOCAL CB ADDR. IN A REG STA TEMP2 LOCAL CB ADDR LDA =D2 NEVER CB # 1 STA COMB# LDA Q ADA D3 ADA Q.LN0 GEC3# LDB A,I CPB TEMP2 IS THIS CB ? JMP GEC5# YES, CHECK LENGTH ADA =D2 NO, BUMP POINTER GEC4# ISZ COMB# AND TRY NEXT ONE CPA S END OF STACK RICHED ? .ER15 JSB ERRAB YE'S, UNKNOWN OR ILLEGAL CB ADR, ERROR !! JMP GEC3# NO, CONTINUE * GEC5# INA VERIFY THAT LENGTH IS LDB A,I NOT NUL CPB BIT15 IS LENGTH NUL ? INA,RSS YES, TRY TO FIND AN OTHER CB JMP GECB#,I NO, IT IS THIS ONE JMP GEC4# TRY TO FIND AN OTHER SPC 3 RELBU NOP RELEASE BUFFER CLASS JSB EXEC DEF *+8 DEF D21 DEF CLASS DEF BUF DEF D10 DEF TEMP DEF TEMP1 DEF TEMP2 SSA HLT 74B JMP RELBU,I SPC 2 SETST NOP SAVE STATUS & TLOG INTO CB1 WORD 4 & 5 CAX SAVE A IN X REG. LDA STKPT NO, SETUP TO SAVE STATUS & TLOG SZA,RSS STACK DEFINED ? JMP SETST,I NO, FORGET IT ADA =D2 IN THE FIRST COMMON BLOCK LDA A,I GET COMMON ADDR SZA,RSS CB1 ALLOCATED ? JMP SETST,I NO, FORGET IT XAX YES, RESTORE STATUS INTO A REG. AND SAX 3B STORE STATUS SBX 4B STORE TLOG JMP SETST,I SPC 2 WRI/O NOP EXECUTE A WRITE/READ CLASS I/O JSB EXEC DEF *+8 DEF D20 WRITE/READ DEF D0 DUMMY LU DEF BUF DUMMY BUFFER DEF WRI/L DUMMY LENGTH DEF STKPT STACK ADDRESS DEF SCODE SUBROUTINE CODE DEF CLASS CLASS WORD JMP WRI/O,I * WRI/L DEC 5 SPC 2 GTCLW NOP GET A CLASS I/O WORD FROM SYSTEM LDA CLASS SAVE THE CLASS WORD STA TEMP3 CLA INIT TO ZERO TO GET ONE CLASS STA CLASS JSB WRI/O DO A WRITE/READ REQUEST LDA CLASS RECALL THE CLASS WORD IOR BIT13 AND MERGE BIT 13 TO NOT DEALLOCATE STA CLASS THE CLASS NUMBER. JSB RELBU RELEASE THE BUFFER CLASS LDA CLASS A REG. IS THE NEW CLASS NUMBER LDB TEMP3 RESTORE WORD "CLASS" STB CLASS JMP GTCLW,I RETU-RN WITH A=CLASS I/O WORD SPC 2 SCHUP NOP SCHEDULE A USER PROGRAM (GROUPING OF TMSUB) STA SCHU7 SAVE PARTITION NAME ADDR STA SRFLG SET SEND MAIL BOX FLAG LDB SCHFL RECALL SCHEDULE FLAG (0 --> NO-WAIT) LDA A,I GET FIRST 2 CHAR. OF THE NAME OR SSA,RSS CLASS WORD, CLASS WORD ? JMP SCHU3 NO, GO SCHEDULE PROGRAM AND =B17777 YES, CLEAR BIT 15 OF CLASS WORD SZB,RSS WAIT / NO WAIT ? STB SCHU7 NO WAIT, CLEAR THE FLAG LDB ICLAS PUT LOCAL CLASS WORD INSTEAD OF STA ICLAS TMS INTERNAL CLASS WORD STB SCHRQ SAVE TEMPORARILY INTERNAL CLASS WORD * JSB MAILB DEF SCODE #PARG ABS PARLG * LDA SCHRQ RESTORE TMS INTERNAL CLASS WORD STA ICLAS LDA SCHU7 WAIT / NO-WAIT REQUEST ? SZA,RSS JMP SCHU8 NO WAIT REQUEST, RETURN IMMEDIATLY * ISZ SCHU7 REQUEST WITH WAIT OPTION SCHU5 LDA SCHU7,I VERIFY THAT PROGRAM IS NOW 'DORMANT' ADA =D15 XLA A,I GET STATUS AND =B17 ISOLATE STATUS SZA,RSS DORMANT ? JMP SCHU8 YES, RETURN JSB EXEC NO, SUSPEND THIS PROGRAM TO DEF *+6 ALLOW THE OTHER ONE RUNNING DEF D12 TIMED EXECUTION (INITIAL OFFSET) DEF D0 PROGRAM NAME DEF D1 RESOLUTION CODE ( 1/100 SEC) DEF D0 EXECUTION MULT. (ONLY ONCE) DEF DM50 WAIT 0.5 SEC JMP SCHU5 AND GO CHECK THE STATUS AGAIN SPC 1 SCHU3 LDA NAB24 GET NO WAIT - NO ABORT CODE SZB REQUEST WITH WAIT ? LDA NAB23 YES, GET WAIT - NO ABORT CODE STA SCHRQ JSB EXEC SCHEDULE REQUEST DEF *+10 DEF SCHRQ QUEUE SCHEDULE - NO ABORT SCHU7 NOP PROGRAM NAME DEF LU LU USED TO START UP THE TMS APPLICATION DEF CLASS TMS EXTERNAL CLASS I/O WORD DEF MCLAS MAIN CLASS I/O WORD ^& DEF ICLAS TMS INTERNAL CLASS I/O WORD DEF CLAS0 TMS CLASS I/O WORD USED FOR CB0 DEF SCODE BUFFER SEND TO PROGRAM DEF #PARG BUFFER LENGTH JMP SCHUP,I ERROR RETURN SCHU8 ISZ SCHUP AND RETURN OK TO USER JMP SCHUP,I * SCHRQ NOP SCHFL NOP NAB23 OCT 100027 NAB24 OCT 100030 DM50 DEC -50 SPC 4 MAILB NOP SEND/RECEIVE MAIL-BOX TO/FROM TMLIB DST PARM1 LDA MAILB,I CALLING SEQUENCE: JSB MAILB STA MAIL2 ----------------- DEF BUFF BUF ADDR ISZ MAILB DEC 10 BUF LENGTH LDA SRFLG SZA SEND OR RECEIVE ? JMP MAIL5 SEND MAIL BOX JSB EXEC DEF *+7 DEF D21 CLASS I/O GET DEF ICLAS INTERNAL CLASS I/O WORD MAIL2 NOP DEF MAILB,I BUFFER LENGTH DEF PARM1 DEF PARM2 SSA HLT 75B ISZ MAILB AJUST RETURN ADDR DLD PARM1 JMP MAILB,I * MAIL5 JSB EXEC DEF *+8 DEF D20 WRITE/READ CLASS I/O CALL DEF D0 DUMMY LU DEF MAIL2,I BUFFER ADDR DEF MAILB,I BUFFER LENGTH DEF PARM1 DEF PARM2 DEF ICLAS INTERNAL CLASS I/O WORD SZA WAS IT OK HLT 76B ISZ MAILB AJUST RETURN ADDR JMP MAILB,I SPC 1 SRFLG NOP SEND/RECEIVE FLAG FOR MAIL-BOX SEND/RECEI. ROUTINE HED CONSTANTS & VARIABLES PARM1 NOP PARM2 NOP * .EPAO NOP PT NOP CLASG NOP S NOP DO NOT DISTURB NEXT WORDS Q NOP S0 DEC 12,11 (INITIAL S & Q RELATIVE VALUE) NOABT NOP LEN00 DEC 0 INITIAL TRUE COMMON LENGTH TEMP NOP DO NOT DISTURB TEMP1 NOP TEMP2 NOP TEMP3 NOP TEMP4 NOP SPC 2 I.TAB DEF *+1,I DEF ILRQ 0 DEF STKPA 1 READ: STACK PARAMETERS DEF IDLE 2 DEF IDLE 3 DEF ILRQ 4 DEF ILRQ 5 DEF CBENڔB 6 CB ENABLE DEF CBDES 7 CB DISABLE DEF SBCAL 8 DEF DFINE 9 DEF SBRTN 10 DEF STKPA 11 WRITE-READ: STACK PARAMETERS DEF PAUS 12 PAUS REQUEST DEF SPRL 13 SUB-PROCESS LAUNCHING DEF CBLEN 14 CHANGE CB LENGTH DEF SCHPR 15 SCHEDULE A NON-TMS PRG DEF ILRQ 16 UNLCK-IMAGE FUNCTION (NEVER COME HERE) DEF TMAB 17 ABORT TMS (RQ FROM TMLIB) DEF ILRQ 18 PROCESS LAUNCH FROM 'TMSL' (NEVER RETURN) DEF ILRQ 19 TIMER INTERRUPT (NEVER RETURN) DEF ILRQ 20 DEF ILRQ 21 MEMORY SUSPEND OPERATION DEF DFN10 22 SPECIAL -DEFIN CB'S- OPCODE DEF STKPA 23 IMAGE REQUEST STACK PARAMETERS ADDR DEF IDLE 24 LOGGING REQUEST SPC 1 C.TAB DEF *+1,I DEF START 0 START: START UP INITIALS PROCESSES DEF EXIT3 1 READ, REQUEUE THE BUFFER & RETURN TO USER DEF IDL02 2 WRITE, RELEASE THE BUFFER & RETURN TO USER DEF IDL02 3 CNTL, RELEASE THE BUFFER & RETURN TO USER DEF IDL00 4 BUF. WRITE, RELEASE BUFFER & FORGET DEF IDL00 5 BUF. CNTL, RELEASE BUFFER & FORGET DEF IDL04 6 CB ENABLE, RELEASE DUMMY BUF. & RETURN TO USER DEF IDL04 7 CB DISABLE, RELEASE DUMMY BUF. & RETURN TO USER DEF IDL06 8 SB CALL, RELEASE DUMMY BUF. & RETURN TO USER DEF IDL04 9 CB DEF., RELEASE DUMMY BUF. & RETURN TO USER DEF IDL06 10 SB RTN, RELEASE DUMMY BUF. & RETURN TO USER DEF WRRQ 11 WRITE-READ, DO THE READ DEF IDL04 12 PAUSE, RELEASE DUMMY BUF. & RETURN TO USER DEF IDL06 13 SUB-PROCESS DEF ILRQ 14 CHANGE CB LENGTH DEF IDL04 15 SCHEDULE A NON-TMS PRG DEF IMULK 16 UNLCK-IMAGE FUNCTION DEF ABTX 17 ABORT TMS (RQ FORM 'TMSL') DEF SPR00 18 PROCESS LAUNCH FROM 'TMSL' DEF PAUS0 19 TIMER INTERRUPT DEF ILRQ 20 STOP TMGS (RQ FROM 'TMSL') DEF MSU50 21 MEMORY SUSPEND OPERATION DEF ILRQ 22 SPECIAL DEFINE OPCODE DEF IMRTN 23 IMAGE REQUEST RETURN DEF LOGRT 24 LOGGING REQUEST COMPLETED SPC 2 DM3 DEC -3 DM2 DEC -2 DM1 DEC -1 D0 DEC 0 D1 DEC 1 D2 DEC 2 D3 DEC 3 D4 DEC 4 D5 DEC 5 D6 DEC 6 D20 DEC 20 D21 DEC 21 D22 DEC 22 * BIT15 OCT 100000 HED *** BUFFER EXCHANGED BETWEEN TMLIB & TMSYS *** * BUFFER RECEIVED FROM TMLIB * IDENTIFY THE TMS REQUEST THAT MUST BE EXECUTED SPC 1 LCLAS NOP CLASS I/O USED BY THE PRG. TO SUSP. ITSELF .PAR1 NOP USER PARAMETERS VALUE ARE RECIEVED HERE .PAR2 NOP .PAR3 NOP .PAR4 NOP .PAR5 NOP BSS 10 RQCNT NOP XSUSP NOP SCOD. NOP SUBROUTINE CODE RETURNED BY TMLIB RTRN. NOP RETURN ADDR IN THE USER PARTITION SPC 1 PARLN EQU RTRN.-LCLAS+1 SPC 2 * BUFFERS SEND BY TMSYS TO TMLIB * DEFINE ALL CLASS I/O WORD TO BE USED, * DEFINE THE CB LOCAL ADDR & LENGTH, * AND GIVE SOME USEFUL INFORMATION TOO SPC 1 * 5 PARAMETERS SEND AS PRG PARAMETERS SPC 1 LU NOP LU USED TO START THE TMS APPLICATION CLASS NOP TMS EXTERNAL CLASS I/O WORD MCLAS NOP TMS MAIN CLASS I/O WORD ICLAS NOP TMS INTERNAL CLASS I/O WORD CLAS0 NOP TMS CB0 SPECIAL CLASS I/O WORD SPC 2 * BUFFER PASSES USING THE STRING PASSING FEATURE SPC 1 SCODE OCT 0 TMS INTERNAL SUBR. CODE SEND BACK TO COMPLETE THE RQ FMPCL NOP TMS-FMP CLASS I/O WORD LEN0 NOP CURRENT CB0 LENGTH #DFCB NOP MINUS # OF DEFINED CB'S EPAOS NOP 'ENTRY POINT ADDR OF SUBROUTINE' RTRNA NOP RETURN ADDR / ABORT CODE RNLCK NOP RN# USED BY LURQ IMPRG OCT 0 IMAGE MODULE PROGRAM NAME BSS 2 HFBIMCLS OCT 0 TMS-IMAGE INTERNAL CLASS I/O WORD MIELN BSS 2 MAXIMUM ITEM & ENTRY LENGTH (TMS-IMAGE WORDS) STKPT OCT 100001 STACK POINTER LULOG DEC 0 LU OF THE LOGGING DEVICE FPARM BSS 3 FUNCTION PARAMETERS (3 WORDS) BUF BSS 50 SPC 1 PARLG EQU BUF+10-SCODE #FPAR EQU D3 SKP UNS SPC 3 XEQT EQU 1717B AVMEM EQU 1751B BGLWA EQU 1777B * ORG * END PH 7 92903-18103 1805 S C0122 &.UPIO              H0101 sASMB HED . UP I/O DEVICE IF LU OR EQT IS DOWN NAM .UPIO,7 92903-16100 REV.1805 780526 SPC 3 ********************************************************************** * * * NAME: .UPIO UP AN I/O DEVICE * * SOURCE: &.UPIO 92903-18103 * * BINARY: %.UPIO ----NONE--- PART OF %TMSLB 92903-16100 * * * * PGMR: FRANCOIS GAULLIER * * * ********************************************************************** SPC 2 * ************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * ************************************************************** SPC 3 ENT .UPIO EXT DRTEQ,MESSS * A EQU 0 B EQU 1 SUP SPC 2 * THIS SUBROUTINE DO A "UP,EQT#" IF THE LU OR * THE EQT IS DOWN. * * CALLING SEQUENCE: * LDA LU# * JSB .UPIO * JMP ERROR ERROR RETURN (ILLEGAL LU OR CAN'T UP DEVICE) * NORMAL RETURN * A = EQT # * B = STATUS (EQT5 CONTENT) SPC 3 .UPIO NOP STA TEMP SAVE LU STA TEMP1 SET FIRST TIME FLAG UPIO2 JSB DRTEQ GET EQT # DEF *+2 DEF TEMP LU AND =B77 STA TEMP2 SAVE EQT # SZB,RSS LU DEFINED ? JMP .UPIO,I NO, ERROR RETURN IN P+1 SSB LU OK ? JMP .UPIO,I NO, ERROR RETURN IN P+1 ADB =D4 YES, LU IS OK, CHECK IF EQT IS DOWN    LDA B,I GET EQT WORD#5 STA TEMP2+1 SAVE IT AND =B140000 ISOLATE BIT 15-14 CPA =B40000 EQT DOWN ? JMP UPIO3 YES, TRY TO UP IT CCA NO, CHECK IF THE LU IS DOWN ADA TEMP INDEX INTO DRT ADA DRT ADA LUMAX TO GET DRT WORD#2 LDA A,I GET DRT WORD#2 SSA LU DOWN ? JMP UPIO3 YES, TRY TO UP THE EQT ISZ .UPIO NO, RETURN OK (P+2) DLD TEMP2 SET A&B JMP .UPIO,I * UPIO3 LDA TEMP1 FIRST TIME THROUGH SZA,RSS ? JMP .UPIO,I NO, ERROR RETURN P+1 CLA YES, SET SECOND TIME FLAG STA TEMP1 LDA TEMP2 RECALL EQT # CLB AND PUT IT INTO DIV =D10 ASCII STRING ALF,ALF ADA B ADA =A00 STA UPIOM+2 JSB MESSS CALL SYSTEM PROCESSOR DEF *+3 DEF UPIOM MESSAGE BUFFER DEF D6 MESSAGE LENGTH JMP UPIO2 CHECK IF OK SPC 2 D6 DEC 6 UPIOM ASC 3, UP,XX TEMP NOP TEMP1 NOP TEMP2 BSS 2 SPC 1 DRT EQU 1652B LUMAX EQU 1653B END @   92903-18104 1805 S C0122 &.LURQ              H0101 zASMB HED . SET UP WORD TO BYPASS THE LU LOCK NAM .LURQ,7 92903-16100 REV.1805 780422 SPC 3 ********************************************************************** * * * NAME: .LURQ BYPASS LU LOCK * * SOURCE: &.LURQ 92903-18104 * * BINARY: %.LURQ ----NONE--- PART OF %TMSLB 92903-16100 * * * * PGMR: FRANCOIS GAULLIER * * * ********************************************************************** SPC 2 * ************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * ************************************************************** SPC 3 ********************************************************************** * * * ASSEMBLER CALLING SEQUENCE: * * * * LDA LU A=LU * * JSB .LURQ REQUEST BYPASS LULOCK WORD * * RETURN A=BYPASS LULOCK WORD (TO BE USED IN 9TH PARAM. * * OF EXEC CALL) * * OR A=0 IF THE LU IS NOT LOCKED. * * * * FORTRAN CALLING SEQUENCE: * * o  92903-18105 1805 S C0122 &MMGT              H0101 ZASMB HED . TMS MEMORY MANAGEMENT SOFTWARE NAM MMGT,7 92903-16100 REV.1805 770128 SPC 3 ********************************************************************** * * * NAME: MMGT TMS MEMORY MANAGEMENT * * SOURCE: &MMGT 92903-18105 * * BINARY: %MMGT ----NONE--- PART OF %TMSLB 92903-16100 * * * * PGMR: G.A.A. * * * ********************************************************************** SPC 3 * *************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1975. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * * * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT* * * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * *************************************************************** SPC 3 ENT .MGTG,.MGTR EXT .MGT0 * * PROGRAMMER: G.A. ANZINGER HP AMD 1 MAY 70 BCS * 24 JUN 74 RTE * F. GAULLIER 20 JUN 76 TMS SKP * REQUESTS MAY BE MADE TO ALLOCATE AND RELEASE BUFFERS * FROM THE MEMORY AVAILABLE AFTER LOADING. * * 1. ALLOCATE: CALLING SEQUENCE - * (P) JSB .MGTG * (P+1) (# OF WORDS NEEDED) * (P+2) -RETURN NO MEMORY EVER (A)=-1, (B)=MAX EVER * (P+3) -RETURN NO MEMORY NOW (A)=0, (B)=MAX NOW * (P+4) -RETURN OK (A)=ADDR , (B)=SIZE OR SIZE+1 * * 2. RELEASE BUFFER TO AVAILABLE MEMORY * (P) JSB .MGTR * (P+1) (FWA OF BUFFER) * (P+2) (# OF WORDS RETURNED) * (P+3) -RETURN- (B)=MAX NOW 1'S COMPLEMENT  * * IF A REQUEST FOR A BUFFER OF LENGTH X CANNOT BE FILLED * DURING A GIVEN CALL, RETURN IS MADE WITH: * (A) = 0 * * IF, WHEN BUFFER REQUESTED, - (AVMEM) - SHOWS INSUFFICIENT CORE * AVAILABLE TO CONTAIN A BUFFER OF THE LENGTH REQUESTED, * THEN RETURN IS MADE WITH: * (A) = -1 * (B) = MAXIMUM LENGTH BUFFER THAT THE PROGRAM MAY ALLOCATE. * * TO FIND OUT HOW LARGE A BUFFER MAY BE ALLOCATED, USE THE CALL * * JSB .MGTG * DEC 32767 * * TO INITIATE THIS PROGRAM, GIVE AVAILABLE MEMORY USING * ENTRY .MGTR AND THEN EXECUTE * JMP .MGTG TO INITIALIZE THE SYSTEM * RETURN IS DONE BY EXTERNAL .MGT0 * * BLOCKS OF MEMORY AVAILABLE FOR OUTPUT BUFFERING ARE LINKED THROUGH * THE FIRST TWO WORDS OF EACH BLOCK - * WORD1 - LENGTH OF BLOCK * WORD2 - ADDRESS OF NEXT BLOCK (OR 77777 IF THIS IS LAST BLOCK) * * THE ALLOCATOR 'TRANSFERS' THE UPPER END OF A BLOCK TO IOC AND * SHORTENS THE LENGTH OF THE BLOCK BY THE AMOUNT 'TRANSFERRED' * * * REGISTERS ARE NOT PRESERVED * SKP .MGTG JMP ALCIN INIT (FROM $STRT, RETURNS TO .MGT0) LDA .MGTG,I GET THE LENGTH OF THE REQUEST STA ADX AND SAVE IT LDB A ADA AVMEM ENOUGH MEMORY NOW SSA TO HONOR THE REQUEST? JMP .A1 YES, GO ALLOCATE. ADB MAXEV SSB,RSS WHAT ABOUT LATER? JMP ERETN NEVER! ISZ .MGTG MAYBE, BUT NOT NOW. REJ CLA,CLE,RSS A=0, E=0 NOT NOW ERETN CCA,CLE A=-1,E=0 NOT EVER JMP SETB RETURN * .A1 ISZ .MGTG TRY AN ALLOCATION CCA SET CORE AVAIL. NOW TO 0 STA ALCIN LDB PNTRA START THE SEARCH LOOP WITH .A2 STB BAD SET LAST BUFFER ADDRESS CLE,INB STEP TO THE NEXT ADDRESS LDB B,I GET THE NEXT SEGMENT ADDRESS CPB M7 IF 77777 THEN END OF LIST AND NO JMP NOMOR MEMORY SO REJECT LDA B,I CHECK TO SEE IF THIS IS THE ADA ALCIN LARGEST LENGTH SO FAR LDA B,I GET THE LENGTH CMA,SEZ SET NEG(-1) AND IF STA ALCIN LARGEST SO FAR SAVE ADA ADX WILL IT SATISFY THE REQUEST? CMA,SSA IF ZERO OR NEGATIVE USE IT JMP .A2 ELSE GO TRY NEXT ONE ADA DM2 IS BLOCK AT LEAST 2 WORDS CCE,SSA LARGER THAN REQUEST? JMP .A4 NO-ALLOCATE WHOLE BLOCK ADA D2 (A)=LENGTH(I)-L(X) STA B,I SET NEW L(I) ADA B (A)=BUFFER ADDRESS JMP SETA RETURN TO USER * .A4 LDA B,I ALLOCATE ENTIRE BLOCK. STA ADX SET BUFFER LENGTH STB A BUFFER ADDRESS TO A CCE,INB SET E FOR ACCEPTED RETURN LDB B,I GET THE POINTER TO THE NEXT BLOCK ISZ BAD STEP TO POINTER ADDRESS IN LAST STB BAD,I BLOCK AND SET THE POINTER SETA ISZ .MGTG SETB LDB MAXEV SET B FOR REJECT SZA,RSS IF JUST FOR NOW RESET TO MAX LDB AVMEM AVAILABLE NOW CMB,SEZ SET POSITIVE AND IF REQUEST LDB ADX SATISFIED SET TO LENGTH ISZ .MGTG STEP RETURN ADDRESS JMP .MGTG,I AND RETURN * NOMOR LDA ALCIN PICK UP MAX LEFT DURING SEARCH STA AVMEM UPDATE MAX AVAILABLE NOW JMP REJ NOW RETURN * * .MGTR NOP ENTRY POINT FOR BUFFER RETURN LDA .MGTR,I (A) = FWA RETURN BUFFER (ADX) STA ADX CMA,INA SET NEG AND STA SAVA SAVE ISZ .MGTR LDA .MGTR,I # OF WORDS RETURNED (X) ADA DM2 SSA <2? JMP RETNR BUFFER TO SMALL - IGNORE LDA PNTRA GET THE STARTING POINTER .R11 STA BAD BAD _ AAD INA LDB A,I AAD _ NEXTBUFAD STB A A _ PNTR ADB SAVA AAD -ADX CMB,SSB,INB,SZB ADXB-AAD>=0? RSS SKIP IF FOUND JMP .R11 ELSE CONTINUE * * * LDB BAD GET LOWER BUFFER ADDRESS CPB PNTRA IF LOCAT POINTER JMP .R3 ASSUME NO OVERLAP ADB B,I ADD LENGTH AND ADB SAVA SUBTRACT THE NEW BLOCK ADDRESS CMB,SSB,INB,RSS IF NEG NO OVERLAP SO JMP .R3 JUMP ADB .MGTR,I ELSE COMPUTE NEW LENGTH ADB BAD,I NOW HAVE NEW +OLD-OVERLAP .R4 STB BAD,I SET LENGTH ;CHECK FOR HIGH OVER- ADB BAD LAP COMPUTE END OF BLOCK CMB,CLE,INB AND SUBTRACT FROM THE HIGH BLOCK ADB A A HAS HIGH BLOCK ADDRESS SEZ,CLE,SZB IF RESULT POSITIVE JMP .R5 JUMP ADB A,I ADD OLD UPPER LENGTH ADB BAD,I CURRENT LENGTH STB BAD,I NEW+OLD-OVERLAP CLE,INA GET POINTER AND BRING LDA A,I DOWN TO NEW BLOCK .R5 LDB BAD,I SAVE MAX LENGTH THIS RETURN ISZ BAD STEP TO POINTER ADRRESS STA BAD,I SET THE POINTER LDA AVMEM CHECK TOO SEE IF THIS LENGTH ADA B ADD CURRENT MAX CMB,SEZ,CLE SET NEG; NEW MAX? STB AVMEM YES; SET IT RETNR ISZ .MGTR LDB AVMEM EXIT WITH B=MAX NOW IN 1'S COMPLEMENT JMP .MGTR,I AND RETURN. * .R3 ISZ BAD NO LOW OVERLAP SET NEW BLOCK LDB ADX ADDRESS IN LOW BLOCK STB BAD,I TO LINK THE BLOCKS STB BAD SET POINTER FOR HIGH BLOCK CHECK LDB .MGTR,I SET B TO THE LENGTH OF RETURN JMP .R4 CHECK FOR HIGH OVERLAP * * * PNTRA DEF AVMEM DUMMY BLOCK ADDRESS(DON'T MESS!) AVMEM OCT -1 DUMMY BLOCK LENGTH (NOT USED) OCT 77777 DUMMY BLOCK END (DON'T MESS!) BAD NOP SAVA NOP M7 OCT 77777 DM2 OCT -2 D2 OCT 2 ADX NOP * ALCIN LDA AVMEM INITIALIZATION CODE MAXEV STA * MAX SIZE BLOCK EVER AVAILABLE JMP .MGT0 JMP TO NEXT STARTUP ROUTINE * A EQU 0 B EQU 1 * BSS 0 LENGTH OF PROGRAM * END   92903-18106 1805 S C0222 &TMLIB              H0102 ASMB HED . T M S L I B R A R Y NAM TMLIB,7 92903-16100 REV.1805 780526 SPC 3 ********************************************************************** * * * NAME: TMLIB TMS LIBRARY * * ENT: TMDFN,TMCBE,TMCBD,TMCBL,TMRD,TMWR,TMBWR,TMCTL,TMBCT * * TMWRD,TMCWR,TMSUB,TMSAB,TMPZ,TMPRO,TMSOP,TMLOG * * SOURCE: &TMLIB 92903-18106 * * BINARY: %TMLIB ----NONE--- PART OF %TMSLB 92903-16100 * * * * PGMR: FRANCOIS GAULLIER * * * ********************************************************************** SPC 2 * ************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * ************************************************************** SPC 3 ENT TMDFN,TMCBE,TMCBD,TMCBL ENT TMRD,TMWR,TMBWR,TMCTL,TMBCT,TMWRD,TMCWR ENT TMSUB,TMSAB,TMPZ,TMPRO,TMSCH,TMSOP,TMLOG ENT $TML0,$TML5,$TML7,$TML8 EXT .ENTR,EXEC,&MVW,KLCLS,PNAME,RMPAR SPC 1 A EQU 0 B EQU 1 SUP HED *** DATA RECEIVED BY TMLIB, FROM TMSYS. *** * SPC 2 * FIVE PARAMETERS OF THE PROGRAM SPC 1 LU NOP LU USED TO START THE APPLICATION (TMSOP) CLASS NOP TMS EXTERNAL CLASS I/O WORD MCLAS NOP TMS MAIN CLASS I/O WORD ICLAS NOP TMS INTERNAL CLASS I/O WORD CLAS0 NOP TMS CB0 SPECIAL CLASS I/O WORD SPC 2 * ʿ BUFFER PASSES USING THE STRING PASSING FEATURE SPC 1 SCODZ NOP TMS INTERNAL SUBROUTINE CODE FMPCL NOP FMP-TMS CLASS I/O WORD LEN0 NOP LENGTH OF THE CB0 (0 MEANS NO CB0) #DFCB NOP MINUS # OF DEFINED CB'S EPAOS NOP 'ENTRY POINT ADDR. OF SUBROUTINE' RTRN NOP RETURN ADDR./ABORT CODE RNLCK NOP RN USED BY LU-LOCK ROUTINE IMPRG BSS 3 TMS-IMAGE-MODULE PROGRAM NAME IMCLS NOP CLASS GIVEN BY TMS-IMAGE-MODULE PROGRAM MIELN BSS 2 MAXIMUM ITEM & ENTRY LENGTH (TMS-IMAGE WORDS) STKPT NOP STACK POINTER (PARAM#1 OF REQUEST ON: CLASS) * LULOG NOP LU OF LOG DEVICE (MT) * FPAR1 NOP THREE WORDS USED BY THE TMS FUNCTION FPAR2 NOP FPAR3 NOP * .COM1 NOP ADDRESSES AND LENGTH OF ALL CB'S .LEN1 NOP .COM2 NOP .LEN2 NOP .COM3 NOP .LEN3 NOP .COM4 NOP .LEN4 NOP .COM5 NOP .LEN5 NOP SPC 1 PARLG EQU .LEN5+1-SCODZ HED T-M LIBRARY <---> T-M SOFTWARE COMMUNICATION MODULE EXIT2 CLA DEFAULT VALUE IS 0 LDA .PAR1,I STA .PAR1 SET 1ST PARAMETER VALUE EXIT3 CCB STB SRFLG SET SEND MAIL BOX FLAG SPC 1 LDB LEN0 TRUE COMMON SZB,RSS DEFINED ? JMP EXIT5 NO, SKIP JSB GACB0 GET CB0 ADDR STB EXIT4 JSB EXEC YES, SAVE TRUE COMMON. DEF *+8 DEF D20 WRITE/READ CLASS I/O DEF D0 DUMMY LU EXIT4 NOP BUFFER ADDR DEF LEN0 BUFFER LENGTH DEF D1 BIT0 MEANS CB0 ENABLED DEF TEMP DEF CLAS0 CLASS I/O WORD SZA WAS IT OK JMP ERR01 NO, ABORT TMS WITH INTERNAL ERROR 01 SPC 1 EXIT5 JSB SRCB SEND ALL NECESSARY CB SPC 1 EXIT6 LDA SWFLG LOCAL CLASS I/O SZA,RSS NEEDED ? JMP EXIT7 NO LDA LCLAS LOCAL CLASS I/O SZA,RSS ALREADY ALLOCATED ? JSB GTCLW NO, GET ONE CLASS pI/O WORD STA LCLAS STORE IT BACK * EXIT7 LDA MCLAS SWAP THE MAIN & THE INTERNAL LDB ICLAS CLASS I/O WORD STA ICLAS STB MCLAS JSB MAILB RESTART TMSYS BY SENDING THIS MAIL-BOX DEF LCLAS SEND SUBROUTINE SPECIFIC PARAMETER ABS PARLN LDA MCLAS SWAP BACK THE MAIN & INTERNAL LDB ICLAS CLASS I/O WORD STA ICLAS STB MCLAS SPC 1 LDB SWFLG PROGRAM MUST ALLOW SWAPPING SZB,RSS JMP EXIT9 NO, GO TERMINATE 'SERIALLY REUSABLE' SPC 1 LDB LCLAS SWAP THE LOCAL & INTERNAL CLASS I/O STB ICLAS TO USE MAILB SUBROUTINE STA LCLAS * CLA STA SRFLG SET MAIL BOX RECEIVE FLAG * JSB MAILB SUSPEND THIS PROGRAM (--> STATE =3) DEF SCODZ WITH THE GET COMMON DESCRIPTOR #PARG ABS PARLG * LDA ICLAS RESTORE BOTH THE LOCAL AND THE INTERNAL LDB LCLAS CLASS I/O, BY SWAPPING THEM AGAIN STA LCLAS STB ICLAS * JMP RSTR4 SPC 1 EXIT9 JSB EXEC COMPLETE THIS PROGRAM DEF *+4 SERIALLY REUSABLE DEF D6 .D0 DEF D0 DEF DM1 SPC 1 **************************************************************** SPC 1 $TML0 JSB RMPAR TM SYSTEM RETURN TO USER PROGRAM DEF *+2 SAVE PARAMETER DEF LU SPC 2 * JSB .DBUG CALL DBUG: INTERNAL USE ONLY !!!!!!!!!!!!!!!!!!!!! * EXT .DBUG CALL DBUG: INTERNAL USE ONLY !!!!!!!!!!!!!!!!!!!!! SPC 2 JSB EXEC GET STRING REQUEST DEF *+5 DEF D14 GET STRING DEF D1 DEF SCODZ BUFFER ADDR DEF #PARG BUFFER LENGTH SZA STRING GET SUCCED ? JMP ILSHR NO, PRINT ERROR MESSAGE CPB #PARG GET RIGHT LENGTH ? RSS YES JMP ILSHR NO, PRINT ERROR MESSAGE * LDA XEQT GET PRIMARY ENTRY POINT ADA D7 FROM ID SEGMENT XLA A,I  ADA D2 SKIP THE JMP & NOP ADA A,I TO SKIP ALL DEF'S INA TO ACCESS THE SWAP FLAG LDA A,I GET SWAP FLAG STA SWFLG SAVE SWAPPING FLAG * CLA STA SRFLG SET MAIL BOX RECEIVE FLAG SPC 1 RSTR4 LDA SCODZ RECALL SUBROUTINE CODE STA SCODE TO SET IT LOCALLY CPA A.RU RUN COMMAND ? JMP ILSHR YES, PRINT ERROR MESSAGE CPA A.ON ON COMMAND ? JMP ILSHR YES, PRINT ERROR COMMAND CPA ABTCD ABORT TMS REQUEST ? JMP RSTR5 YES, DO NOT CHECK MCLAS * LDA MCLAS CHECK IF IT IS A GOOD REQUEST SZA,RSS MAIN CLASS I/O DEFINED ? JMP ILSHR NO, PRINT ERROR MESSAGE SPC 1 RSTR5 JSB SRCB NO, RECEIVE ALL ENABLE COMMON BLOCK DATA * LDB .DCB1 GET DUMMY CB1 ADDR LDA #DFCB GET # OF DEFINED CB'S SZA,RSS CB DEFINED ? JMP RSTR7 NO, USE DUMMY CB1 LDA .LEN1 RECALL CB1 LOCAL LENGTH SSA CB1 ENABLED ? RSTR7 STB .COM1 NO, USE DUMMY CB1 * LDB .SBRT SETUP THE RETURN ADDR. (EPAOS=0 IF STB EPAOS,I NOT DEFINED ) SPC 1 LDA SCODE RECALL SUBROUTINE CODE ADA C.TAB INDEX IN TABLE JMP A,I SPC 1 .DCB1 DEF DCB1 .SBRT DEF TMRTN ABTCD DEC 17 ABORT CODE (TERMINATE THIS PROGRAM) A.RU ASC 1,RU A.ON ASC 1,ON * DCB1 BSS 6 DUMMY CB1 SKP ILSHR LDA LU SET UP LU SZA,RSS INA STA LU JSB PNAME RETREIVE PROGRAM NAME DEF *+2 FROM IDSEG DEF MES+1 TO MOVE IT INTO ERROR MESSAGE LDA MES+3 REPLACE 6TH BYTE WITH IOR A: THE ":" (WAS ALREADY A SPACE) STA MES+3 JSB EXEC OUTPUT DEF *+5 " /XXXXX: ILLEGAL SHEDULE REQUEST ! " DEF D2 DEF LU DEF MES DEF D18 * LDA MCLAS CHECK IF THE TMS APPLICATION SZA IS RUNNI}NG ? JMP EXIT9 YES, DO NOT TERMINATE ! JMP ABORT NO, TERMINATE PROGRAM * MES ASC 4, /XXXXX: ASC 14, ILLEGAL SCHEDULE REQUEST ! A: OCT 72 D0 DEC 0 D1 DEC 1 D2 DEC 2 DM1 DEC -1 D7 DEC 7 HED TERMINAL-MONITOR LIBRARY EXIT TO USER PROGRAM RTN90 CCA,RSS SET CB INDIC. FLAG TO SET STATUS RTN92 CLA SET CB INDIC. FLAG TO NOT SET STATUS STA CBINF SET CB INDICATOR FLAG * LDA LEN0 IS TRUE COMMON (CB0) SZA,RSS DEFINED ? JMP RTN96 NO, SKIP RESTORE JSB GACB0 GET CB0 ADDR STB RTN93 JSB EXEC RESTORE TRUE COMMON DEF *+6 DEF D21 CLASS I/O GET DEF CLAS0 CLASS I/O WORD RTN93 NOP DEF LEN0 DEF TEMP CB INDICATOR UPDATE WORD SSA JMP ERR01 ABORT TMS WITH ERROR 01 LDA CBIND MERGE CB INDICATOR FOR CB0 IOR TEMP INTO CBIND STA CBIND SPC 1 RTN96 ISZ CBINF DOES CB INDIC. NEED TO BE STORE ? JMP RTN99 NO, EXIT LDA .COM1 YES, STORE IT IN USER STATUS WORD ADA D3 A IS THE STATUS ADDR LDB CBIND RECALL CB INDICATOR STB A,I AND STORE IT IN PLACE OF STATUS SPC 1 RTN99 LDA .COM1,I SAVE CB1(1) IN CASE OF USER STA SAV01 DESTROY IT LDA .COM1 SET A & B REG. TO ADA D3 THE STATUS & TLOG DLD 0,I JMP RTRN,I EXIT TO CALLING PROGRAM ! SPC 2 D21 DEC 21 CBINF NOP SWFLG NOP SWAP FLAG SAV01 NOP HOLD CB1(1) WHILE USER IS EXECUTING SKP * ABORT TMS APPLICATION: * TERMINATE THIS PROGRAM WITHOUT ANY OPTION * TO MAKE IT ACTUALLY DORMANT. SPC 1 ABT LDB .CLS CHECK IF CLOSE FMP FILE REQUESTED LDA FMPCL RECALL FMP CLASS I/O WORD SZB CLOSE REQUESTED ? JSB B,I YES, GO DO THE CLOSE SPC 1 ABORT JSB KLCLS RELEASE THE LOCAHL CLASS I/O DEF *+2 IF ANY DEF LCLAS * LDA .D0 STA .D0+1 SUPPRESS TERMINATE OPTION JMP EXIT9 AND TERMINATE PROGRAM. SPC 2 IMEXT LDB ..PA1 SAVE IMAGE PARAMETERS ADDR INTO MVW PARL STANDARD PARAMETERS LOCATION JMP EXIT3 SAVE CB'S AND GO TO TMSYS SPC 2 DM3 DEC -3 DM10 DEC -10 HED GENERAL TRANSFERT PARAMETER GETPA NOP LDB GETPA ADB DM3 LDB B,I STB RTRN. ADB DM1 STB XSUSP STA SCODE SET UP TMS INTERNAL SUBROUTINE CODE LDX PAR# CLA CLEAR FUTUR PARAMETERS ADRESSES SAX .PAR1-1 TO KNOW HOW MANY PARAMETERS ARE DSX PASSED JMP *-3 JMP RTRN.+1 HED *** DATA SEND BY TMLIB, TO TMSYS. *** * SPC 2 * BUFFER PASSES USING A MAIL BOX SPC 1 LCLAS OCT 0 LOCAL CLASS I/O WORD USED TO SUSP. ITSELF .PAR1 NOP USER PARAMETERS ADDR. ARE SET UP .PAR2 NOP HERE BY .ENTR .PAR3 NOP .PAR4 NOP .PAR5 NOP BSS 10 RQCNT NOP XSUSP NOP SCODE NOP SUBROUTINE CODE TO BE SEND TO TMSYS RTRN. NOP RETURN ADDR. TO BE SEND TO TMSYS SPC 1 PARLN EQU RTRN.-LCLAS+1 SPC 3 JSB .ENTR GET PARAMETERS ADDRESS ..PA1 DEF .PAR1 (HOPE IT IS MICRO-CODED) * CLA STA RQCNT TO BE SURE THAT THE LOOP WILL END LDX D0 GETP7 LAX .PAR1 SZA,RSS PARAMETER HERE ? JMP GETP8 NO, END OF LIST REACHED ISX YES, INCREMENT X REG JMP GETP7 AND LOOP * GETP8 CXA SAVE # OF PARAMETERS STA RQCNT ADA DM10 NEVER MORE THAN 9 PARAMETERS SSA,RSS JMP ERR04 ABORT TMS WITH INTERNAL ERROR 04 LDA SCODE IF IT IS NOT SZA COMMON BLOCK DEFINITION CALL CPA D9 JMP GETP9 IT IS, EXIT LDA #DFCB IT IS NOT, SO AT LEAST SZA,RSS ONE CB MUST BE DEFINED JM%P ERR05 ABORT TMS WITH INTERNAL ERROR 05 * GETP9 LDA SAV01 RESTORE CB1(1) STA .COM1,I JMP GETPA,I SPC 1 PAR#. EQU RQCNT-.PAR1 PAR# ABS PAR#. PARL. EQU RTRN.-.PAR1+1 PARL ABS PARL. HED TERMINAL-MONITOR READ/WRITE REQUEST REQUEST TMRD NOP CLA,INA SUBROUTINE CODE=1 FOR READ JSB GETPA GO GET PARAMETER * LDX D17 EXEC I/O CODE FOR READ READ3 JSB CB1? CB1 DEFINED ? LDA .PAR1 A=BUFF. ADDR. LDB .PAR2,I B=BUFF. LEN. STB .PAR2 SAVE BUFFER LENGTH FOR THE GET LATER JSB GI/O EXECUTE I/O JMP EXIT3 * D17 DEC 17 SPC 2 READ5 JSB EXEC THE PHYSICAL I/O IS DONE DEF *+5 RETURN FROM PRG: TMSYS IS HERE. DEF D21 CLASS I/O GET TO GET THE INPUT BUFFER DEF ICLAS INTERNAL CLASS I/O WORD DEF FPAR1,I USER BUFFER ADDR. (SAVED & RETURNED BY TMSYS) DEF FPAR2 USER BUFFER LEN. (SAVED & RETURNED BY TMSYS) SSA WAS IT OK ? JMP ERR02 ABORT TMS WITH INTERNAL ERROR 02 * JSB SVST SAVE STATUS & TLOG. JMP RTN92 RESTORE TRUE COMMON SPC 2 TMWR NOP LDA D2 SUBROUTINE CODE=2 FOR WRITE JSB GETPA * LDX D18 JMP READ3 * D18 DEC 18 SPC 2 TMBWR NOP BUFFERED WRITE I.E.: DO NOT LDA D4 SUBROUTINE CODE=4 FOR BUFFERED WRITE JSB GETPA JSB CB1? CB1 DEFINED ? * LDX D18 EXECUTE THE BUFFERED WRITE LDA .PAR1 LDB .PAR2,I JSB GI/O TMBW6 LDA RTRN. RETURN OF BUFFERED CALL, I.E.: STA RTRN RETURN DIRECTLY TO THE USER (SETUP RTRN ADDR) JMP RTN99 AND RETURN WITHOUT RESTORING TRUE COMMON * D4 DEC 4 HED TERMINAL-MONITOR WRITE-READ-REQUEST REQUEST TMWRD NOP LDA D11 SUBROUTINE CODE=11 FOR WRITE/READ JSB GETPA * LDA .PAR1 GET WRITE BUFFER ADDR. LDB .PAR3 GET READ BUFFER ADDR. AND SAl0.*VE STB .PAR1 IT INTO 1ST PARAM FOR LATER USE LDB .PAR5 GET OPTIONAL (RD/WR CTL BITS) ADDR STB .PAR3 AND SAVE IT IN 3RD PARAM FOR GI/O LDB .PAR2,I GET WRITE BUF LENGTH LDX D18 WRITE REQUEST JSB GI/O PERFORM THE WRITE PART OF THE REQUEST * CLA LDA .PAR4,I GET READ BUF LENGTH AND SAVE STA .PAR2 IT INTO 2ND PARAM FOR TMSYS CLA LDA .PAR3,I GET WR/RD CTL BITS STA .PAR3 AND SAVE INTO 3RD PARAM FOR TMSYS * JMP EXIT3 EXIT TO TMSYS * D11 DEC 11 SPC 2 TMCWR NOP CLASS I/O WRITE/READ REQUEST FROM TMS !! CLA,INA SAME AS A READ REQUEST JSB GETPA * LDX D20 EXEC I/O CODE FOR WRITE/READ RQ JMP READ3 * D20 DEC 20 HED TERMINAL-MONITOR CONTROL REQUEST REQUEST TMCTL NOP LDA D3 SUBROUTINE CODE=3 FOR CONTROL JSB GETPA 0 JSB CB1? CB1 DEFINED ? * JSB CTL JMP EXIT3 * D3 DEC 3 SPC 2 TMBCT NOP LDA D5 SUBROUTINE IS 5 FOR BUFFERED CTL JSB GETPA JSB CB1? CB1 DEFINED ? * JSB CTL JMP TMBW6 RETURN FROM A TMS BUFFERED REQUEST * D5 DEC 5 SPC 1 CTL NOP CLA DEFAULT IS ZERO LDA .PAR1,I GET FUNCTION CODE ALF,ALF RAR,RAR IOR .COM1,I STA I/OLU CLA VALUE IS 0 IF NOT SUPPLIED LDA .PAR2,I STA .PAR2 JSB EXEC EXECUTE THE CLASS I/O CONTROL DEF *+10 DEF D19 CLASS I/O CONTROL REQUEST DEF I/OLU LU DEF .PAR2 PARAMETER DEF CLASS CLASS I/O WORD DEF STKPT 1ST PARAMETER DEF SCODE 2ND PARAMETER DEF * PLACE HOLDER !! DEF * PLACE HOLDER !! DEF RNLCK BYPASS LU-LOCK CHECK SZA WAS IT OK ? JMP ERR02 ABORT TMS WITH INTERNAL ERROR 02 JMP CTL,I * D19 DEC 19 SPC 1 CB1? NOP CHECK THAT CB1 IS DEFINED LDA .LEN1 RECALL CB1 LOCAL LENGTH SSA CB1 DEFINED ? JMP ERR06 NO, USER IS NOT ABLE TO DO I/O CALL JMP CB1?,I YES, CONTINUE HED TERMINAL-MONITOR LOG ON REQUEST TMSOP NOP TMS OPERATOR CALL ENTRY POINT CLA JSB GETPA RETRIEVE CALLING PARAMETERS * LDA .PAR2,I IOR LU MERGE WITH LU STA CTL SAVE LOCALLY * JSB EXEC READ/WRITE CALL DEF *+10 DEF .PAR1,I CODE DEF CTL LU DEF .PAR3,I BUFFER ADDR DEF .PAR4,I BUFFER LENGTH DEF * PLACE HOLDER !! DEF * PLACE HOLDER !! DEF * PLACE HOLDER !! DEF * PLACE HOLDER !! DEF RNLCK BYPASS LU-LOCK CHECK JSB SVST SAVE STATUS & TLOG JMP RTRN.,I RETURN TO USER SPC 3 SVST NOػP LDX D3 INDEX INTO 1ST CB SAX .COM1,I TO STORE STATUS ISX AND TO WORD 5 SBX .COM1,I TO STORE TANSMISSION LOG JMP SVST,I HED TERMINAL-MONITOR PROCESS/PROGRAM LAUNCHING REQUEST TMPRO NOP LDA D13 SUBROUTINE CODE=13 FOR LAUNCH PROCESS JSB GETPA * LDA ..PA1 MOUVE END OF PARAMETERS ADA D2 TO HAVE ROOM TO PUT LDB A THE PROCESS NAME (TM SUBROUTINE NAME) ADB D2 JSB &MVW DM4 DEC -4 * LDA .PAR2 NOW MOUVE TM SUBROUTINE NAME LDB ..PA1 INB MVW D3 JMP EXIT2 GET LU# AND EXIT * D13 DEC 13 SPC 3 TMSCH NOP LDA D15 CODE=15 FOR PROGRAM SCHEDULE JSB GETPA * LDA ..PA1 MOVE LAST PARAM TO INA HAVE ROOM FOR PROGRAM NAME LDB A ADB D2 DESTINATION ADDR JSB &MVW DM6 DEC -6 LDA .PAR1 LDB ..PA1 MOVE PROGRAM NAME MVW D3 JMP EXIT3 * D15 DEC 15 HED TERMINAL-MONITOR C.B. ENABLE/DISABLE REQUEST TMCBE NOP LDA D6 SUBROUTINE CODE=6 FOR CB ENABLE JSB GETPA JMP EXIT2 GET THE VALUE OF THE FIRST PARAMETER * D6 DEC 6 SPC 3 TMCBD NOP LDA D7 SUBROUTINE CODE=7 FOR CB DISABLE JSB GETPA JMP EXIT3 SPC 4 TMCBL NOP LDA D14 SUBROUTINE CODE=14 FOR CB LENGTH CHANGE JSB GETPA * CLA DEFAULT VALUE IS ZERO LDA .PAR2,I STA .PAR2 SET SECOND PARAMETER VALUE JMP EXIT3 * D14 DEC 14 HED TERMINAL-MONITOR LOGGING REQUEST TMLOG NOP LDA D24 SUBROUTINE CODE=24 FOR LOGGING JSB GETPA * LDA LULOG GET LU OF LOGGING DEVICE SZA LOG DEVICE DEFINED ? JMP TMLO1 YES, GO TO LOG CLB NO, RETURN STATUS=-1 TO THE USER CCA AND RETURN IMMEDIATLY JSB SVST SET TMS-STATUS & TLOG JMP TMBW6 Y AND RETURN SPC 1 TMLO1 JSB CB1? START LOGGING, IS CB1 DEFINED * ??????????????????? CHECK FOR MEMORY PROTECT FENCE !!! LDA .PAR2 RECALL USER DATA BUFFER ADDR. ADA DM16 AND COMPUTE THE ACTUAL BUFFER ADDR. STA TEMP SAVE BUFFER ADDR LDB TMLO8 SAVE USER VALUE TO RESTORE THEM MVW D16 AT THE END * LDB TEMP SET UP THE FIRST 16 WORDS OF THE LDA .PAR3,I LOGGING RECORD ADA D16 SET RECORD LENGTH STA B,I INB STB TMLO5 SET ADDR. FOR TIME STAMP ADB D5 LEAVE ROOM FOR TIME STAMP STB TMLO5+1 SET ADDR. FOR YEAR INB STB TEMP1 SAVE LU ADDR. LDA .COM1,I SET INTERACTIVE LU INTO STA B,I THE LOGGING RECORD INB LDA .PAR1 AND MOVE THE USER HEADER MVW D8 * JSB EXEC GET TIME STAMP FROM THE SYSTEM DEF *+4 DEF D11 TMLO5 BSS 2 BUFFER ADDR * LDA LULOG RECALL LOGGING LU STA .COM1,I AND STORE IT IN PLACE OF TERMINAL LU LDA .D1 SET CTL BIT (BINARY RQ) STA .PAR3 * LDA TEMP A=BUFF. ADDR. LDB A,I B=BUFF. LENGTH LDX D18 X=EXEC RQ JSB GI/O PERFORM THE WRITE * LDA TEMP1,I RESTORE INTERACTIVE LU INTO STA .COM1,I THE FIRST COMMON BLOCK LDA TMLO8 RESTORE THE USER BUFFER LDB TEMP IN FRONT OF THE DATA BUFFER MVW D16 * JMP EXIT3 AND EXIT SPC 1 DM16 DEC -16 D16 DEC 16 D8 DEC 8 D24 DEC 24 TEMP NOP TEMP1 NOP TMLO8 DEF *+1 BSS 16 .D1 DEF D1 HED TERMINAL-MONITOR SUBROUTINE REQUEST TMSUB NOP CALL AN EXTERNAL SUBROUTINE LDA D8 SUBROUTINE CODE=8 FOR T-M SUB. CALL JSB GETPA * LDA .PAR1 LDB ..PA1 MVW D3 GET PARAMETER JMP EXIT3 SPC 1 SBCAL LDA XEQT GET FROM ID SEGMENT ADA D7 THE PRIMARY ENTRY POINT XLA A,I ADA D2 SKIP THE JMP & THE NOP STA TEMP LDB A,I GET THE LOCAL # OF SUB. LDA RTRN GET THE WANTED SUB # ADA B LOCAL # - WANTED # SSA IS IT OK ? JMP ERR03 ABORT TMS WITH INTERNAL ERROR 03 LDA RTRN CMA,INA MAKE IT POSITIVE CAX LAX TEMP,I GET SUBROUTINE ENTRY POINT ADDR RSS LDA A,I PEEL OFF INDIRECT BIT RAL,CLE,SLA,ERA JMP *-2 STA EPAOS JSB A,I AND CALL THE SUBROUTINE DEF *+1 TO BE COMPATIBLE WITH .ENTR CONVENTION * TMRTN LDA D10 SUBROUTINE CODE=10 FOR TMSUB RETURN STA SCODE NO PARAMETERS TO GET JMP EXIT3 SPC 1 TMDFN NOP JSB TMDF3 CHECK THAT RTRN IS STILL NEGATIVE JSB GETPA * CLA STA LEN0 NO TRUE COMMON DEFINED YET LDA EPAOS SAVE ENTRY POINT ADDR. STA .PAR5+5 OF SUB. TO SEND TO TMSYS JMP EXIT3 SPC 1 TMDF3 NOP THIS IS TO BE SURE THAT LDA RTRN THIS CALL IS THE FIRST OF THE SUBROUTINE SSA,RSS STILL NEGATIVE ? JMP ERR05 ABORT TMS WITH INTERNAL ERROR 05 LDA D9 YES, ALLRIGHT JMP TMDF3,I SUBROUTINE CODE=9 FOR CB DEFINITION SPC 1 D9 DEC 9 D10 DEC 10 HED TERMINAL-MONITOR PAUSE/STOP REQUEST TMPZ NOP LDA D12 SUBROUTINE CODE=12 FOR PAUSE REQUEST JSB GETPA JMP EXIT2 * D12 DEC 12 SPC 3 TMSAB NOP LDA ABTCD SUBROUTINE CODE=17 FOR TMS ABORT JSB GETPA CLA,INA ABORT TMS IS FROM 'TMLIB' STA .PAR2 JMP EXIT2 HED UTILITY SUBROUTINES, CONSTANTS AND VARIABLES ILRQ STA TEMP JMP ERR03 ABORT TMS WITH INTERNAL ERROR 03 SPC 3 ERR01 HLT 11B CB0 CLASS I/O ERROR ERR02 HLT 12B RN / CLASS I/O ERROR ERR03 LDA D3 INTERNAL LOGIQUE / TABLE INCONSISTENCY JMP ERROR ERR04 LDA D4 GETPA: USER CALL WITH MORE THAN 9 PARAM. JMP ERROR ERR05 LDA D5 TMDFN: NOT 1ST CALL/2ND CALL (USER ERROR) JMP ERROR ERR06 LDA D6 CB1 IS NOT DEFINED FOR AN I/O REQUEST JMP ERROR * D7 USED BY IMAGE * $TML8 EQU * ERROR STA .PAR1 SET ERROR # LDB ABTFL SET ERROR FLAG INSTEAD OF SUBROUTINE CODE STB SCODE SCODE TO BE SEND CCA SET SEND FLAG STA SRFLG JMP EXIT6 * ABTFL OCT 125252 SPC 2 * TMS-FMP REQUEST HAS BEEN DONE, SAVE * ADDRESS OF THE CLOSE ROUTINE TO CLOSE FILES * WHEN TMS STOP. SPC 1 $TML7 NOP STA .CLS SAVE CLOSE ROUTINE ADDR. LDA FMPCL RECALL FMP CLASS I/O WORD JMP $TML7,I AND RETURN TO FMP-TMS SUBROUTINE SPC 1 .CLS OCT 0 SKP MAILB NOP SEND/RECEIVE MAIL-BOX TO/FROM TMSYS DST PARM1 LDA MAILB,I CALLING SEQUENCE: JSB MAILB STA MAIL2 ----------------- DEF BUFF BUF ADDR ISZ MAILB DEC 10 BUF LENGTH LDA SRFLG SZA SEND OR RECEIVE ? JMP MAIL5 SEND MAIL BOX JSB EXEC DEF *+7 DEF D21 CLASS I/O GET DEF ICLAS INTERNAL CLASS I/O WORD MAIL2 NOP DEF MAILB,I BUFFER LENGTH DEF PARM1 DEF PARM1+1 SSA HLT ISZ MAILB AJUST RETURN ADDR DLD PARM1 JMP MAILB,I * MAIL5 JSB EXEC DEF *+8 DEF D20 WRITE/READ CLASS I/O CALL DEF D0 DUMMY LU DEF MAIL2,I BUFFER ADDR DEF MAILB,I BUFFER LENGTH DEF PARM1 DEF PARM1+1 DEF ICLAS INTERNAL CLASS I/O WORD SZA WAS IT OK HLT ISZ MAILB AJUST RETURN ADDR JMP MAILB,I SPC 1 SRFLG NOP SEND/RECEIVE FLAG FOR MAIL-BOX SEND/RECEI. ROUTINE PARM1 BSS 2 SPC 3 SRCB NOP X SEND/RECEIVE ALL NECESSARY COMMON BLOCK CLA RESET CB INDICATOR LDB IMPRG IS IMAGE SZB USED ? IOR BIT6 YES, SET BIT 6 LDB LULOG IS LOGGING SZB USED ? IOR BIT7 YES, SET BIT 7 STA CBIND LDA #DFCB GET MINUS OF DEFINED CB'S SZA,RSS DEFINED CB'S ? JMP SRCB,I NO, RETURN STA TEMP1 YES, SET UP COUNTER LDB D2 INIT CB# WORD (SET BIT TO CORRESPONDING STB CB# CB #) LDA @.LN1 SCR01 LDB A,I GET LOCAL COM. BL. LENGTH SSB BLOCK ENABLE ? JMP SCR05 NO, CHECK NEXT ONE ADA DM1 YES, GET THE LOCAL COM. BL. LENGTH ADDR. IOR BIT15 SET INDIRECT BIT DST SCR02 JSB MAILB SCR02 BSS 2 LDA CBIND UPDATE CB INDICATOR IOR CB# STA CBIND LDA SCR02 RAL,CLE,ERA CLEAR BIT 15 INA SCR05 ADA D2 BUMP POINTER TO COM. BL. LIST LDB CB# SET NEXT BIT IN CB# WORD RBL STB CB# ISZ TEMP1 MORE DEFINED COM. BL. ? JMP SCR01 YES, LOOP UNTIL FINISHED JMP SRCB,I * CB# NOP CBIND NOP @.LN1 DEF .LEN1 BIT6 OCT 100 BIT7 OCT 200 BIT15 OCT 100000 SPC 2 GI/O NOP STA I/OB BUFFER STB I/OL LENGTH STX I/OC EXEC I/O CODE * LDB .COM1 XBX GET READ-WRITE CONTROL BIT LAX 1 GET 2ND WORD OF COMMON BLOCK # 1 SLB READ OR WRITE ? ALF,ALF READ LDB .PAR3 FUNCTION CODE SUPPLIED BY SZB THE USER FOR THIS CALL ? LDA B,I YES, GET IT AND RHALF NO, KEEP THE STANDARD ONE ALF,ALF RAR,RAR IOR .COM1,I MERGE WITH LU STA I/OLU * JSB EXEC DEF *+10 DEF I/OC EXEC CODE DEF I/OLU CONTROL WORD I/OB NOP BUFFER DEF I/OL LENGTH DEF STKPT 1ST PARAMETER DEF SCODE 2ND PARAMETER DEF CLASS CLASS I/O WORD DEF * PLACE HOLDER !! DEF RNLCK BYPASS LU-LOCK CHECK SZA WAS IT OK ? JMP ERR02 ABORT TMS WITH INTERNAL ERROR 02 JMP GI/O,I SPC 1 RHALF OCT 377 I/OC NOP I/OL NOP I/OLU NOP SPC 2 GACB0 NOP GET CB0 ADDR JSB CB1? CB1 MUST BE ENABLE LDB LEN0 RECALL CB0 LENGTH CMB,INB AND ADB .COM1 ADD TO CB1 ADDR TO HAVE CB0 ADDR. JMP GACB0,I EXIT WITH ADDR IN B REG. SPC 3 GTCLW NOP ALLOCATED A CLASS I/O CLA WHEN OWNER CLASS I/O WILL BE RELEASE STA GTCLX THIS SUBROUTINE WILL BE REPLACED JSB EXEC BY THE SYSTEM ROUTINE. DEF *+5 THE CLASS MUST BE OWNED BY THE CALLING PROGRAM DEF D19 SO THE ABORT PROCEDURE WILL BE EASIER DEF D0 I.E.: THE PROGRAM WILL BE ABORTED DEF * AND HOPFULLY THE CLASS I/O RELEASED. DEF GTCLX LDA GTCLX IOR B20K SET BIT13 'DO NOT DEALLOACATE CLASS' STA GTCLX JSB EXEC DEF *+5 DEF D21 DEF GTCLX DEF * DEF D0 LDA GTCLX JMP GTCLW,I * GTCLX NOP B20K OCT 20000 SPC 3 $TML5 DEF *+1 TABLE OF ADDR. GET BY TMLIM WHEN NEEDED DEF IMEXT ADDR OF RETURN POINT INTO TMLIB FROM TMLIM DEF IMPRG ADDR OF THE TMS-IMAGE-MODULE PROGRAM NAME DEF FPAR1 ADDR OF THE FIRST FUNCTION PARAMETER DEF CLASS ADDR OF THE TMS EXTERNAL CLASS I/O WORD DEF ICLAS ADDR OF THE TMS INTERNAL CLASS I/O WORD SKP C.TAB DEF *+1,I DEF ILRQ 0 START TMS (NEVER IN TMS-SUBROUTINE) DEF READ5 1 STANDARD READ DEF RTN92 2 STANDARD WRITE DEF RTN92 3 CONTROL DEF ILRQ 4 BUF. WRITE (NEVER COME BACK) DEF ILRQ 5 BUF. CTL (NEVER COME BACK) DEF RTN90 6 CB 0.*ENABLE DEF RTN90 7 CB DISABLE DEF SBCAL 8 TM SUB. CALL DEF RTN90 9 DEFINE COMMON IN A TM SUB. DEF RTN92 10 RETURN FROM A TM SUB DEF READ5 11 WRITE/READ DEF RTN92 12 PAUSE DEF RTN92 13 PROCESS LAUNCHING DEF RTN92 14 CHANGE CB LENGTH DEF RTN92 15 SCHEDULE NON TMS PROGRAM DEF ILRQ 16 UNLCK-IMAGE FUNCTION (NEVER COME TO TMLIB) DEF ABT 17 ABORT TMS APPL. (TERMINATE THIS PRG.) DEF ILRQ 18 PROCESS LAUNCHING BY TMSL DEF ILRQ 19 TMS-TIMER INTERRUPT DEF ILRQ 20 STOP TMS APPL. (NEVER COME TO TMLIB) DEF ILRQ 21 MEMORY SUSPEND (NEVER COME TO TMLIB) DEF ILRQ 22 MEMORY SUSPEND (NEVER COME TO TMLIB) DEF RTN92 23 IMAGE REQUEST DEF RTN92 24 LOGGING REQUEST REP 5 DEF ILRQ SPC 2 XEQT EQU 1717B SPC 2 UNS ORG * DEFINE LAST LOCATION END +0  92903-18107 1805 S C0122 &TMFMP              H0101 ASMB HED . TMS-FMP CALL SAVE AND RESTORE DCB NAM TMFMP,7 92903-16100 REV.1805 780421 SPC 3 ********************************************************************** * * * NAME: TMFMP TMS-FMP CALL * * ENT: TDCBS,TDCBR,TDCBC * * SOURCE: &TMFMP 92903-18107 * * BINARY: %TMFMP ----NONE--- PART OF %TMSLB 92903-16100 * * * * PGMR: FRANCOIS GAULLIER * * * ********************************************************************** SPC 2 * ************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * ************************************************************** SPC 3 ENT TDCBS,TDCBR,TDCBC EXT $TML7,.ENTR,WRITF,CLOSE,EXEC * A EQU 0 B EQU 1 SUP SKP * THIS CODE PROVIDES TWO SUBROUTINES TO SAVE AND RESTORE * THE DCB BUFFER USED BY THE FMP CALLS. * * WHEN THE FILE HAS BEEN SUCCESSFULY OPEN OR CREATED, THE * USER SAVES THE DCB INTO SAM USING 'TDCBS', THE NEXT TIME THE USER * WANTS TO ACCESS THAT FILE HE RESTORES THE DCB USING 'TDCBR' * * * TDCBS - RECORD FILE NAME IN THE DIRECTORY IF A NEW FILE * AND SAVE CORRESPONDING DCB IF DCB IS OPEN. * TDCBR - RESTORE THE DCB CORRESPONDING TO THE FILE NAME * TDCBC - CLOSE THE FILE CORRESPONDING TO THE FILE NAME * * CALLING SEQUENCE: * ------------------- * * #& IF ( TDCBS(FNAME,IDCB [,IERR] ) ) GOTO ERROR * * FNAME - FILE NAME INFORMATION (5 WORDS LONG) * FNAME[1:3] ASCII FILE NAME * FNAME[4:4] FILE SECURITY CODE * FNAME[5:5] CARTRIDGE REFERENCE NUMBER * * IDCB - DCB BUFFER SET UP BY OPEN OR CREAT FMP CALL * DCB SIZE IS ASSUMED TO BE 144 WORDS. * * IERR - OPTIONAL PARAMETER WHERE THE ERROR CODE * IS RETURNED. * = -1 THE FILE IS ALREADY IN THE DIRECTORY, * THE DCB IS ALREADY SAVED. * = -2 THE FILE IS NOT IN THE DIRECTORY, THE * DCB IS NOT OPEN, NOTHING HAS BEEN SAVED. * = -3 DIRECTORY OVERFLOW (MORE THAN 20 FILES) * * * IF( TDCBR(FNAME,IDCB) ) GOTO ERROR * * FNAME - FILE NAME, AS IN TDCBS CALL * * IDCB - BUFFER WHERE THE DCB WILL BE RETURNED * DCB SIZE IS ASSUMED TO BE 144 WORDS. * * ERROR RETURN IF TRY TO RESTORE THE DCB OF A FILE THAT HAS * NOT BEEN SAVED. * * * IF( TDCBC(FNAME) ) GOTO ERROR * * FNAME - FILE NAME AS IN TDCBS CALL * * ERROR RETURN IF TRY TO CLOSE A DCB OF A FILE THAT HAS NOT * BEEN SAVED, OR FROM A DIFFERENT PROGRAM THAT THE ONE USED * TO OPEN THE FILE. SKP TDCBC NOP CLOSE ONE FILE LDB *-1 LDA .DCB SET LOCAL DCB ADDR STA .IDCB LDA DM2 JMP TDCB. SPC 2 TDCBS NOP DCB SAVE ENTRY POINT LDB *-1 LDA D2 JMP TDCB. SPC 2 TDCBR NOP DCB RESTORE ENTRY POINT LDB *-1 CLA,INA TDCB. STA FLAG SET REQUEST TYPE FLAG STB TDCB SET RETURN ADDR JMP TDCB+1 GO EXECUTE .ENTR * DM2 DEC -2 FLAG NOP SPC 3 .NAME NOP ADDR OF FILE NAME (5 WORDS LONG) .IDCB NOP ADDR OF THE DCB .IER DEC 0 TDCB NOP DUMMY ENTRY POINT JSB .ENTR GET PARAMETERS ADDR DEF .NAME * LDA .CLS CLOSE ROUTINE ADDR JSB $TML7 PASS IT TO 'TMLIB' AND SPC 1 TDCB3 STA CLASS GET FORM TMLIB THE TMS-FMP CLASS I/O CCE READ IN THE FILE DIRECTORY JSB SAMIO FROM SAM .DIRB DEF DIRBU BUFFER ADDR D105 DEC 105 BUFFER LENGTH CPB D1 DIRECTORY LENGTH = 1 ? CLB YES, SET IT TO ZERO STB DIRLN AND SAVE DIRECTORY LENGTH * LDA .DIRB SET UP END OF DIRECTORY ADDR ADA DIRLN STA .DIRE SPC 1 LDA FLAG RECALL REQUEST FLAG CPA DM1 CLOSE ALL FILES REQUEST ? JMP RSTSV YES, DO NOT SEARCH INTO THE DIRECTORY SPC 1 LDA .DIRB SEARCH INTO THE DIRECTORY FOR THE FILE NAME ADD02 STA DIRPT SAVE DIRECTORY POINTER CPA .DIRE END OF DIRECTORY ? JMP ADD20 YES, IT IS A NEW FILE LDB .NAME SEARCH INTO THE DIRECTORY CMW D5 COMPARE WORD ? JMP RSTSV YES, FOUND IT NOP NO, CONTINUE SEARCHING LDA DIRPT RECALL POINTER ADA DETL AND GOTO NEXT ENTRY JMP ADD02 TO LOOP UNTIL THE END SPC 2 ADD20 LDA FLAG THE FILE IS NOT FOUND, RECALL RQ FLAG CPA D2 SAVE REQUEST ? RSS YES, SAVE IF DCB IS OPEN JMP ERR NO, NOT SAVE RQ, MUST BE IN THE DIRECTORY * LDA .IDCB CHECK IF THE DCB IS OPEN ADA D9 ACCESS OPEN FLAG LDA A,I CPA XEQT DCB OPEN ? RSS YES, SAVE THAT FILE JMP ERR02 NO, RETURN DCB NOT OPEN ERROR * LDA DIRLN ADDITION OF A NEW FILE INTO THE DIRECTORY CPA D105 DIRECTORY FULL ? JMP ERR03 YES, RETURN DIRECTORY FULL ERROR LDB DIRPT NO, INSERT IT LDA .NAME AT THE END OF THE DIRECTORY MVW D5 STB CLWPT CLA INIT CLASS I/O WORD TO ZERO STA B,I INB LDA XEQT AND SAVE ID SEGMENT ADDR OF THE STA B,I PROGRAM THAT HAS DEFINED THE DCB (FOR THE CLOSE) * LDA DIRLN UPDATE DIRECTORY LENGTH ADA DETL STA DIRLN * LDA CLWPT,I RECALL CLASS I/O WORD JMP SAV AND GO TO SAVE THE DCB SPC 1 DIRPT NOP CLWPT NOP XEQPT NOP D1 DEC 1 D2 DEC 2 NBT13 OCT 157777 DETL DEC 7 DIRECTORY ENTRY LENGTH DMETL DEC -7 DM1 DEC -1 DM3 DEC -3 SPC 2 RSTSV LDA DIRPT ADA D5 SET THE CLASS WORD POINTER STA CLWPT INA SET THE IDSEG POINTER STA XEQPT CMA CHECK LEGALITY OF THE FILE NUMBER ADA .DIRE SSA FILE NUMBER OK ? JMP ERR NO, RETURN ERROR LDA CLWPT,I GET THE CLASS I/O WORD LDB FLAG RECALL REQUEST FLAG CPB D2 SAVE REQUEST ? JMP SAV YES, GOTO SAVE THE DCB SSA,RSS NO, IT IS RST/CLS, CLASS OK ? JMP CLS75 NO, GO CHECK FOR CLOSE REQUEST * RAL,CLE,ERA CLEAR BIT 15 OF CLASS WORD SSB,RSS RESTORE REQUEST ? JMP RST10 YES, GOTO RESTORE DCB AND NBT13 NO, IT IS CLOSE, RELEASE THE CLASS LDB XEQT AND VERIFY THAT IT IS THE GOOD PROGRAM CPB XEQPT,I TO PERFORM THE CLOSE, OK ? JMP RST10 YES, GO RESTORE THE DCB JMP CLS78 NO, TRY TO CLOSE THE NEXT FILE * RST10 STA CLWPT,I STORE BACK THE CLASS WORD, WITH BIT15=0 LDB .IDCB TO INDICATE "DCB RESTORED" STB RST13 SET DCB ADDR CCE READ FROM SAM JSB SAMIO RST13 NOP BUFFER ADDR DEC 144 BUFFER LENGTH * LDA .IDCB MODIFIED DCB WORDS THAT MUST ADA D9 BE MODIFIED LDB XEQT a STB A,I ADA D3 LDB A,I ADB .IDCB ADD NEW STARTING ADDR ADB PARM1 AND SUBSTRACT THE OLD ONE STB A,I TO GET THE NEW ABSOLUTE POINTER * LDA FLAG RECALL REQUEST FLAG CPA DM1 IS IT CLOSE ALL FILE REQUEST ? JMP CLS40 YES, CONTINUE CPA DM2 IS IT CLOSE ONE FILE ? JMP CLS45 YES, GO CLOSE THE FILE JMP OKRTN NO, IT WAS A RESTORE, RETURN OK SPC 2 SAV SSA DCB ALREADY SAVED ? JMP ERR YES, RETURN ERROR TO CALLER * LDB .IDCB SET BUFFER ADDR STB SAV13 CMB,INB SAVE ALSO INTO SAM THE CURRENT STB PARM1 DCB ADDRESS CLE WRITE BUFFER TO SAM JSB SAMIO SAV13 NOP BUFFER ADDR DEC 144 BUFFER LENGTH LDA TEMP1 RECALL THE CLASS WORD IOR =B120000 MERGE BIT15 TO INDICATE -DCB SAVED- STA CLWPT,I AND BIT13 TO NOT DEALLOCATE THE CLASS * LDA .IDCB MODIFIED DCB WORD TO ADA D9 "FREE" THAT DCB, SO IF IT IS CLB RE-USED, THE SAVE FILE WILL NOT STB A,I BE CLOSED. JMP OKRTN SPC 2 * SAVE DIRECTORY BUFFER INTO SAM AND * RETURN TO THE USER THE STATUS. * ERR03 LDA DM3 RETURN 'DIRECTORY FULL' ERROR CODE JMP RTRN * ERR02 LDA DM2 RETURN 'DCB NOT OPEN' ERROR CODE JMP RTRN * OKRTN CLA,RSS RETURN 'SUCCESFUL OPERATION' STATUS * ERR CCA ERROR RETURN (VALUE= .TRUE.) * RTRN STA RTNVA SPC 1 LDA DIRLN SAVE BACK DIRECTORY INTO SAM SZA,RSS AJUST DIRECTORY LENGTH CLA,INA BEFORE THE WRITE/READ CALL STA DIRLN CLE SEND DIRECTORY TO SAM LDA CLASS GET CLASS I/O WORD JSB SAMIO DEF DIRBU DIRECTORY BUFFER DIRLN NOP DIRECTORY LENGTH SPC 1 LDA RTNVA RECALL RETURN VALUE STA .IER,I SET ERROR ,CODE CLB RESET ERROR ADDR STB .IER FOR THE NEXT TIME (OPTIONAL PARAM) JMP TDCB,I AND RETURN * RTNVA NOP HED CLOSE ALL FILES RECORDED IN THE DIRECTORY .CLS DEF *+1 NOP CLOSE ALL FILE ROUTINE ENTRY POINT LDB *-1 RECALL RETURN ADDR. STB TDCB SET UP RETURN ADDR. CCB SET FLAG FOR CLOSE ALL FILES REQUEST STB FLAG LDB .DCB SET LOCAL DCB BUFFER STB .IDCB LDB .DIRB INITIALIZE DIRECTORY POINTER STB DIRPT JMP TDCB3 GO GET DIRECTORY FROM SAM * CLS40 JSB WRITF DCB HAS BEEN RESTORED DEF *+5 WRITE AN EOF DEF .IDCB,I DCB ADDR DEF TEMP ERR CODE RETURNED HERE DEF * BUFFER ADDR DEF DM1 WRITE EOF SSA FMP CALL OK ? HLT 10B NO, ERROR !!!!!!!!!!!!!!!!!!!!!!!!! CLS45 JSB CLOSE YES, CLOSE THE FILE DEF *+2 DEF .IDCB,I DCB ADDR SSA FMP CALL OK ? HLT 11B NO, ERROR !!!!!!!!!!!!!!!!!!!!!!!!! * LDA DIRPT THE FILE HAS BEEN CLOSE, DELETE ADA DETL THE CORRESPONDING ENTRY FROM THE DIRECTORY LDB .DIRE COMPUTE LENGTH TO MOVE CMB,INB ADB A IN ORDER TO SUPPRESS THAT ENTRY CMB,INB STB TEMP SAVE WORD COUNT SZB,RSS MOVE NEEDED ? JMP CLS42 NO, SKIP THE MOVE LDB A GET FORM ADDR ADB DMETL SET TO ADDR MVW TEMP AND REPACK THE DIRECTORY CLS42 LDA DIRLN UPDATE DIRECTORY LENGTH ADA DMETL AS WELL STA DIRLN LDA .DIRE UPDATE ALSO END OF DIRECTORY ADA DMETL STA .DIRE * LDB FLAG RECALL REQUEST FLAG CPB DM2 WAS IT CLOSE ONE FILE REQUEST ? JMP OKRTN YES, RETURN * JMP RSTSV TRY TO CLOSE NEXT FILE IN THE DIRECTORY SPC 1 CLS75 CPB DM1 IS IT CLOSE ALL FILES REQUEST ? RSS z*($ YES, CONTINUE JMP ERR NO, ERROR RETURN * CLS78 LDA DIRPT GO TO NEXT FILE IN THE DIRECTORY ADA DETL STA DIRPT JMP RSTSV HED UTUILITY SUBROUTINE SAMIO NOP WRITE/READ DIRECTORY TO/FROM SAM CLB B=LU SEZ A=CLASS I/O, IF GET REQUEST SWAP A&B SWP DST TEMP1 AND SAVE CLASS I/O AND LU LDA D20 SET UP REQUEST CODE (20 FOR WRITE/READ) SEZ IF GET REQUEST INA SET UP GET RCODE (21) STA TEMP LDA SAMIO,I GET BUFFER ADDR STA SAMI3 AND SET BUFFER ADDR ISZ SAMIO PREPARE FOR BUFFER LENGTH * JSB EXEC WRITE/READ OR GET REQUEST DEF *+8 DEF TEMP RQ DEF TEMP1+1 LU OR CLASS SAMI3 NOP BUFFER ADDR. DEF SAMIO,I BUFFER LENGTH DEF PARM1 DEF PARM2 DEF TEMP1 CLASS OR 3RD PARAM * ISZ SAMIO AJUST RETURN ADDR SSA EXEC CALL OK ? HLT JMP SAMIO,I RETURN SPC 1 CLASS NOP PARM1 NOP PARM2 NOP TEMP NOP TEMP1 BSS 2 * .DCB DEF *+1 BSS 144 DIRBU BSS 105 (15 FILES MAX) .DIRE NOP SPC 1 D20 DEC 20 D9 DEC 9 D3 DEC 3 D5 DEC 5 SPC 2 XEQT EQU 1717B SPC 1 UNS ORG * DEFINE LAST LOCATION END *  92903-18108 1805 S C0122 &$TTMS              H0101 qASMB HED . *** T M S T I M E R *** NAM $TTMS,7 92903-16100 REV.1805 780313 SPC 3 ********************************************************************** * * * NAME: $TTMS TMS TIMER * * SOURCE: &$TTMS 92903-18108 * * BINARY: %$TTMS ----NONE--- PART OF %TMSLB 92903-16100 * * * * PGMR: FRANCOIS GAULLIER * * * ********************************************************************** SPC 2 * ************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * ************************************************************** SPC 3 EXT RMPAR,EXEC,PNAME ENT $TTMS SUP SPC 3 * THIS PROGRAM IS A PART OF THE TERMINAL MONITOR SOFTWARE (TMS), * IT IS USED BY TMS TO PROVIDE A TIMER. WHEN TMSYS NEEDS A TIME * INTERVAL, IT PUT THAT PROGRAM IN THE TIME LIST FOR THE PERIOD OF * TIME, AND WHEN 'TTMS' IS SCHEDULE FROM THE TIME LIST, IT RETURN * A MAIL BOX TO 'TMSYS' TO SIGNAL THAT THE TIME IS PASSED. SPC 4 LU NOP ECLAS OCT 0 EXTERNAL CLASS I O WORD ABTCD DEC 17 ABORT CODE TIMCD DEC 19 TMS TIMER CODE MES ASC 13, /XXXXX: ILLEGAL SCHEDULE ASC 5,REQUEST ! .MES1 DEF MES+1 IP BSS 5 IB BSS 14 IBLEN DEC -28 * SCODE EQU IB STKPT EQU IB+13 SPC 2 $TTMS JSB RMPAR RETREIVE PRG PARAMETERS DEF *+2 DEF IP * LDA IP INIT LU WIѝTH PARAM 1 STA LU * CMA,INA IF(LU<3 OR LU>63) LU=1 ADA D3 CMA STA L.001 LDA LU CMA,INA ADA D63 IOR L.001 LDB D1 GET DEFAULT LU SSA OK ? STB LU NO, SET DEFAULT LU SPC 1 JSB EXEC GET STRING REQUEST DEF *+5 DEF D14 STRING RQ DEF D1 GET DEF IB BUFFER DEF IBLEN BUFFER LENGTH SZA GET OK ? JMP TTM70 NO, CHECK IF FROM TIME LIST LDA SCODE YES, CHECK REQUEST CODE SZA,RSS INITIALIZATION ? JMP TTM50 YES, GO INIT CPA ABTCD IS IT ABORT ? JMP TTM60 YES, TERMINATE PROGRAM JMP TTM90 IF NOT REPORT ERROR SKP * TMSYS INITIALISE THIS PROGRAM: * SAVE LOCALLY THE CLASS I/O WORD, AND * TERMINATE WITH 'SAVE SUSP. POINT' OPTION. * TTM50 LDA STKPT RECALL STKPT CPA =B100001 IS IT OK ? RSS YES CONTINUE JMP TTM90 NO, REPORT ERROR LDA ECLAS VERIFY THAT THE CLASS IS NOT SZA ALREADY DEFINED JMP TTM80 THE CLASS WAS DEFINED ! ERROR LDA IP+1 RECALL 2ND PARAM STA ECLAS TO INIT THE CLASS I/O WORD JMP TTM95 AND TERMINATE 'SAVE SUS. PT' IF OK SPC 2 * TMSYS STOP THE APPLICATION: * TERMINATE THIS PROGRAM WITHOUT ANY OPTION. * TTM60 LDA IP+1 TMSYS REQUEST TO STOP APPL., CHECK CPA ECLAS IF CLASS STILL OK ? RSS YES, TERMINATE WITH NO OPTION JMP TTM90 NO,REPORT ERROR SPC 1 JSB EXEC TERMINATE PROGRAM DEF *+6 DEF D6 DEF D0 CURRENT PRG DEF D0 NO OPTION DEF D0 P1 DEF DM2 P2 SPC 3 * SHEDULE WITHOUT STRING PASSING: * MUST BE FROM THE TIME LIST ! * TTM70 LDA IP+1 , NO STRING PASSES, CHECK FROM CPA DM2 TIME LIST ? RSS YES, CONTINUE JMP TTM90 NO, REPORT ERROR LDA ECLAS NOW CHECK IF CLASS WORD SZA,RSS STILL OK ? JMP TTM99 NO, TERMINATE PROGRAM FOR EVER SPC 1 JSB EXEC SEND INFO TO TMSYS DEF *+8 DEF NAB20 WRITE/READ NO ABORT DEF D0 DEF IP DEF D1 BUFFER LEN DEF D0 DEF TIMCD DEF ECLAS CLASS WORD JMP TTM80 ERROR RETURN !! SPC 1 TTM75 JSB EXEC TERMINATE PROGRAM DEF *+6 WITH 'SAVE SUSPENSION POINT' OPTION DEF D6 DEF D0 DEF D1 DEF D0 DEF DM2 SPC 1 ********************************************************************* SPC 1 JMP $TTMS RESTART FORM BEGINING HED ERROR PROCESSING TTM80 CLA RESET THE CLASS I/O WORD STA ECLAS * TTM90 LDA .MES1 REPORT ERROR STA T.001 JSB PNAME DEF *+2 T.001 DEF T.001,I LDA MES+3 MERGE THE ":" IOR A: STA MES+3 JSB EXEC PRINT ERROR MESSAGE DEF *+5 DEF D2 DEF LU DEF MES DEF D18 * TTM95 LDA ECLAS TERMINATE PROGRAM WITH CURRENT OPTION SZA CALL I/O WORD DEFINED ? JMP TTM75 YES, TERMINATE 'SAVE SUSP. PT.' SPC 1 TTM99 CLA RESET THE CLASS I/O WORD STA ECLAS IN CASE OF PROGRAM BEING CORE RESIDENT JSB EXEC DEF *+2 DEF D6 SPC 2 A: OCT 72 ":" L.001 NOP NAB20 OCT 100024 * DM2 DEC -2 D0 DEC 0 D1 DEC 1 D2 DEC 2 D3 DEC 3 D6 DEC 6 D14 DEC 14 D18 DEC 18 D63 DEC 63 END f  92903-18109 1805 S C0122 &$LTMS              H0101 qASMB HED . *** T M S L I N K *** NAM $LTMS,7 92903-16100 REV.1805 780313 SPC 3 ********************************************************************** * * * NAME: $LTMS TMS LINK * * SOURCE: &$LTMS 92903-18109 * * BINARY: %$LTMS ----NONE--- PART OF %TMSLB 92903-16100 * * * * PGMR: FRANCOIS GAULLIER * * * ********************************************************************** SPC 2 * ************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * ************************************************************** SKP * SPC 3 * * * THIS PROGRAM IS A PART OF THE TERMINAL MONITOR SOFTWARE (TMS), * IT IS USE TO INTERACT WITH THE TMS FROM A EXTERNAL DEVICE. * USING TMSL, ONE CAN LAUNCH A PROCESS ON A GIVEN DEVICE, * STOP OR ABORT THE TMS APPLICATION. * * *RU,TMSL [, [LU] [,T.U.S NAME] ] * * WHERE: * LU IS THE LOGICAL UNIT ON WHICH THE PROCESS 'T.U.S. NAME' * WILL BE LAUNCH. * THE LU MAY BE OMITTED, IN WHICH CASE THE CURRENT ONE * WILL BE USED. * IF LU=98 OR LU=99, THE TMS APPLICATION IS STOPPED OR * ABORTED. * * TUS NAM TMS-USER-SUBROUTINE NAME THAT WILL BE LAUNCH ON * THE LOGICAL UNIT LU. * IF OMITTED THE FOLLOWING PROMPT IS GIVEN UON THE * DEVICE: * "T.U.S. NAME [,LU ] ? " * AND TMSL WAIT FOR THE ANSWER. * * NOTE: * IF THERE IS NO STRING PASSING (I.E.: SHEDULE FROM A PROGRAM * WITHOUT GIVING A STRING TO BE PASSED), THE FIVE PARAMETERS ARE * CHECKED. * OR * P1 IS 98 OR 99 P1 IS LU * P2,P3,P4 D'ONT CARE P2,P3,P4 IS THE T.U.S. * P5 MUST BE -1 P5 MUST BE -2 * * *********************************************** F. GAULLIER (HPG) *** SPC 3 ENT $LTMS EXT RMPAR,EXEC,PNAME,$PARS,REIO SUP SPC 2 LU NOP LUI NOP LU + ECHO BIT ECLAS OCT 0 EXTERNAL CLASS I O WORD ABTCD DEC 17 ABORT CODE STPCD DEC 20 TMS STOP CODE LNKCD DEC 18 TMS-LINK CODE MES ASC 13, /XXXXX: ILLEGAL SCHEDULE ASC 5,REQUEST ! MESA ASC 11,T.U.S. NAME [,LU] ? _ .MES1 DEF MES+1 IP BSS 33 IB BSS 14 IBLEN DEC -28 * SCODE EQU IB STKPT EQU IB+13 SPC 2 $LTMS JSB RMPAR RETREIVE PRG PARAMETERS DEF *+2 DEF IP * LDA IP INIT LU WITH PARAM 1 STA LU * CMA,INA IF(LU<3 OR LU>63) LU=1 ADA D3 CMA STA L.001 LDA LU CMA,INA ADA D63 IOR L.001 LDB D1 GET DEFAULT LU SSA OK ? STB LU NO, SET DEFAULT LU * LDA .D1 INIT SPECIAL FLAG STA .NAME SPC 1 JSB EXEC GET STRING REQUEST DEF *+5 DEF D14 STRING RQ .D1 DEF D1 GET DEF IB BUFFER DEF IBLEN BUFFER LENGTH SZA GET OK ? JMP LTM70 NO, CHECK IF FROM TIME LIST LDA SCODE YES, CHECK REQUEST CODE SZA,RSS INITIALIZATION ? JMP LTM50 YES, GO INIT CPA ABTCD IS IT ABORT ? JMP LTM60 YES, TERMINATE PROGRAM SPC 2 * NOT FROM TMSYS, MUST BE FROM * USER REQUEST "RU,...." * LDA ECLAS CHECK THAT CLASS STILL OK SZA,RSS OK ? JMP LTM90 IF NOT, REPORT ERROR SPC 1 LDA .IP12 SET POINTER STA .NAME LDA .IP8 STA .LU JMP PARSE GO PARSE BUFFER SPC 1 * REQUEST T.U.S AND LU * LTM10 JSB EXEC PRINT "T.U.S. NAME [,LU] ?" DEF *+5 DEF D2 DEF LU DEF MESA DEF DM21 * LDA LU IOR =B400 STA LUI LU + ECHO JSB REIO READ THE ANSWER DEF *+5 BUT BE SWAPPABLE DEF D1 DEF LUI .IB DEF IB DEF IBLEN SZB,RSS INPUT ? JMP LTM95 NO, TERMINATE THE PROGRAM * LDA .IP SET POINTER STA .NAME LDA .IP4 STA .LU * PARSE LDA .IB RECALL BUFFER ADR JSB $PARS AND DO THE PARSE .IP DEF IP STORE RESULT * DLD .LU,I GET TYPE & DATA CPA D1 NUMBER DEFINE ? JMP LTM14 YES, KEEP IT SZA LU DEFAULTED ? JMP LTM90 NO, REPORT ERROR LDB LU YES, GET DEFAULT LU * LTM14 CPB D99 IS IT ABORT REQUEST ? JMP LTM40 YES, GO DO IT CPB D98 IS IT STOP REQUEST ? JMP LTM41 YES, GO DO IT LDA .NAME,I RECALL NAME TYPE CPA DM1 SPECIAL ERROR FLAG ? JMP LTM90 YES, REPORT ERROR CPA DM2 SPECIAL FLAG ? JMP LTM27 YES, LAUNCH THE T.U.S. CPA D2 IS TUS NAME ASCII ? RSS YES, SEND REQUEST TO TMSYS JMP LTM10 NO, ASK AGAIN STB IP SET LU FOR THE LAUNCH LDA .NAME INA GET ADDR OF NAME LDB .IP1 AND MOVE NAME INTO IP MVW D3 LTM27 LDA LNKCD GET TMS-LINK CODE SPC 1 LTM30 STA TEMP SET TMS-CODE NUMBER LDA ECLAS LAST CHECK THAT THE CLASS SZA,RSS IS STILL OK JMP LTM80 CLASS NOT DEFINED ! ERROR JSB EXEC SEND INFO TO TMSYS DEF *+8 DEF NAB20 WRITE/READ NO ABORT DEF D0 DEF IP DEF D4 BUFFER LEN DEF D0 DEF TEMP TMS-CODE NUMBER DEF ECLAS CLASS WORD JMP LTM80 ERROR RETURN !! SPC 1 LTM38 JSB EXEC TERMINATE PROGRAM DEF *+9 WITH 'SAVE SUSPENSION POINT' OPTION DEF D6 DEF D0 CURRENT PROGRAM DEF D1 'SAVE SUSP. POINT' OPTION DEF D0 1ST PARAM DEF D0 1ND PARAM DEF D0 3RD PARAM DEF D0 4TH PARAM DEF D0 5TH PARAM SPC 1 ********************************************************************* SPC 1 JMP $LTMS RESTART FORM BEGINING SPC 3 * OPERATOR REQUEST TO ABORT/STOP THE * TMS APPLICATION * LTM40 CLA STA IP+1 LDA ABTCD GET ABORT CODE JMP LTM30 AND SEND REQUEST TO TMSYS SPC 1 LTM41 LDA STPCD GET STOP CODE JMP LTM30 AND SEND REQUEST TO TMSYS SKP * TMSYS INITIALISE THIS PROGRAM: * SAVE LOCALLY THE CLASS I/O WORD, AND * TERMINATE WITH 'SAVE SUSP. POINT' OPTION. * LTM50 LDA STKPT RECALL STKPT CPA =B100001 IS IT OK ? RSS YES CONTINUE JMP LTM90 NO, REPORT ERROR LDA ECLAS VERIFY THAT THE CLASS IS SZA NOT ALREADY DEFINED JMP LTM80 THE CLASS WAS DEFINED ! ERROR LDA IP+1 RECALL 2ND PARAM STA ECLAS TO INIT THE CLASS I/O WORD JMP LTM95 AND TERMINATE 'SAVE SUS. PT' IF OK SPC 2 * TMSYS STOP THE APPLICATION: * TERMINATE THIS PROGRAM WITHOUT ANY OPTION. * LTM60 LDA IP+1 TMSYS REQUEST TO STOP APPL., CHECK CPA ECLAS IF CLASS STILL OK ? JMP LTM99 YES, TERMINATE W8ITH NO OPTION JMP LTM90 NO,REPORT ERROR SPC 3 * SHEDULE WITHOUT STRING PASSING: * LTM70 LDA .IP4 NO STRING PASSES, CHECK FROM STA .NAME 'ETMSP', SET SPECIAL ERROR FLAG LDB IP RECALL FIRST PARAM. LDA IP+4 RECALL 5TH PARAM. SZA,RSS NOT DEFINED ? JMP LTM10 YES, ASK TUS & LU SSA,RSS SPECIAL REQUEST FLAG ? JMP LTM90 NO, REPORT ERROR JMP LTM14 YES, TRY TO DO THE REQUEST HED ERROR PROCESSING LTM80 CLA RESET THE CLASS I/O WORD STA ECLAS LDA .NAME,I RECALL FLAG CPA DM1 SPECIAL SOP/ABORT RQ ? JMP LTM95 YES, TMS ALREADY STOPPED * LTM90 LDA .MES1 REPORT ERROR STA T.001 JSB PNAME DEF *+2 T.001 DEF T.001,I LDA MES+3 MERGE THE ":" IOR A: STA MES+3 JSB EXEC PRINT ERROR MESSAGE DEF *+5 DEF D2 DEF LU DEF MES DEF D18 * LTM95 LDA ECLAS TERMINATE PROGRAM WITH CURRENT OPTION SZA CALL I/O WORD DEFINED ? JMP LTM38 YES, TERMINATE 'SAVE SUSP. PT.' SPC 1 LTM99 CLA RESET THE CLASS I/O WORD STA ECLAS IN CASE OF PROGRAM BEING CORE RESIDENT JSB EXEC DEF *+2 DEF D6 SKP A: OCT 72 ":" L.001 NOP TEMP NOP NAB20 OCT 100024 * .IP1 DEF IP+1 .IP4 DEF IP+4 .IP8 DEF IP+8 .IP12 DEF IP+12 .LU NOP .NAME NOP DM21 DEC -21 DM2 DEC -2 DM1 DEC -1 D0 DEC 0 D1 DEC 1 D2 DEC 2 D3 DEC 3 D4 DEC 4 D6 DEC 6 D14 DEC 14 D18 DEC 18 D63 DEC 63 D98 DEC 98 D99 DEC 99 END I  92903-18110 1805 S C0122 &TMLIM              H0101 |ASMB HED . T M S - I M A G E L I B R A R Y NAM TMLIM,7 92903-16100 REV.1805 780331 SPC 3 ********************************************************************** * * * NAME: TMLIM TMS-IMAGE CALL * * ENT: TBGET,TBDEL,TBPUT,TBFND,TBUPD,TBULK * * SOURCE: &TMLIM 92903-18110 * * BINARY: %TMLIM ----NONE--- PART OF %TMSLB 92903-16100 * * * * PGMR: FRANCOIS GAULLIER * * * ********************************************************************** SPC 2 * ************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * ************************************************************** SPC 3 ENT TBGET,TBDEL,TBPUT,TBFND,TBUPD,TBULK EXT $TML5,$TML8 EXT .ENTR,EXEC SPC 1 A EQU 0 B EQU 1 SUP HED TERMINAL-MONITOR DBGET REQUEST TBGET NOP LDA D2 SUBROUTINE CODE=2 FOR READ JSB GETPA GO GET PARAMETER SPC 1 CLB SET UP IARG LENGTH LDA .PAR2,I RECALL MODE ADA DM3 IF MODE 1 & 2 NO IARG SSA,RSS LDB MITML IT IS MODE 3 OR 4, GET MAX ITEM LEN STB TEMP * LDB .PAR6 LOCK WORD ADDR JSB GETLW GET LOCK WORD LDA .SAVR MOVE SAVE RUN TABLE BUFFER MVW D8 LDA .PAR2,I GET MODE STA B,I INB LDA .PAR1 MOVE DATA SET NAME MVW D3 LDA .PAR5 MOVE IARG MVW TEMP ADB M.BUF COMPUTE MAIL BOX LENGTH STB BUFLN SET MAIL BOX LENGTH * LDA .PAR3 STATUS USER ADDR LDB .PAR4 USER BUFFER ADDR TBGE8 JSB SENDI GIVE PARAM. ADDR. TO TMLIB & GOTO TMLIB TO SUSP. SPC 1 JSB RECMB RESTORE PARM ADDR & RECEIVE MAIL BOX LDA BUF+1 RECALL TMS-IMAGE-RQ-COD LDB D4 IMAGE STATUS LENGTH ADA DM4 SUBSTRACT 4 FORM IMRQC SSA,RSS DBGET OR DBFND CALL ? CLB,INB NO, IMAGE STATUS LENGTH IS 1 STB TEMP SET IMAGE STATUS LENGTH * LDA .RCBU STORE VALUE INTO USER BUFFER LDB .SAVR RESTORE SAVE RUN TABLE BUFFER MVW D8 LDB .PAR2 STORE IMAGE STATUS IN USER BUFFER MVW TEMP LDB .PAR2,I RECALL IMAGE STATUS SZB WAS IT OK ? JMP .PAR1,I NO, DO NOT STORE ENTRY INTO USER BUF. LDB .PAR3 STORE ENTRY (DATA RECORD + MEDIA RECORD) SZB,RSS USER BUFFER ADDR DEFINED ? JMP .PAR1,I NO, RETURN IMMEDIATELY INA SKIP WORD COUNT MVW RCBUF+12 USE ENTRY LENGTH JMP .PAR1,I RETURN TO USER CODE * D8 DEC 8 DM4 DEC -4 .RCBU DEF RCBUF HED TMS-IMAGE TBULK REQUEST TBULK NOP LDA D8 JSB GETPA SPC 1 LDA .SAVR,I GET LOCK ID WORD SZA,RSS ID DEFINED ? JMP RTRN,I NO, FORGET THE CALL STA BUF YES, SEND IT TO TMSYS * CLA RETURN NO ID WORD STA .SAVR,I TO THE USER * JSB EXEC SEND BUFFER TO TMSYS (USING EXTERNAL CLASS) DEF *+8 DEF D20 CLASS I/O WRITE/READ DEF D0 DUMMY LU DEF BUF BUFFER SEND DEF D1 BUFFER LENGTH DEF STKPT 1ST PARAM. (STACK POINTER) DEF ULKCD 2ND PARAM. (TMS INTERNAL SUBR. CODE) DEF ECLAS TMS EXTERNAL CLASS I/O WORD JMP RTRN,I * D1 DEC 1 D20 DEC 20 SPC 2 IMSCD EQSU 23 ULKCD DEC 16 HED TMS-IMAGE DBFND REQUEST TBFND NOP LDA D3 JSB GETPA SPC 1 LDB .PAR5 LOCK WORD ADDR JSB GETLW GET LOCK WORD LDA .SAVR MOVE SAVE RUN TABLE BUFFER MVW D8 LDA .PAR2 MOVE DATA SET NAME MVW D3 LDA .PAR3 MOVE KEY ITEM NAME (IPATH) MVW D3 LDA .PAR4 MOVE KEY ITEM VALUE (IARG) MVW MITML ADB M.BUF STB BUFLN SET MAIL BOX LENGTH * LDA .PAR1 USER BUFFER ADDR FOR STATUS CLB NO BUFFER ADDR (DBGET COMPATIBLE) JMP TBGE8 USE DBGET CODE TO FINISH SPC 2 * DO NOT DISTURB NEXT LOCATION !!! * IMCLS NOP IMAGE CLASS I/O WORD MITML DEC 50 MAXIMUM ITEM LENGTH IN WORD (DEFAULT) MENTL DEC 256 MAXIMUM ENTRY LENGTH IN WORD (DEFAULT) * MBUFL DEC 271 MAXIMUM BUF LEN RETURNED BY TMS-IMAGE-MODULE HED TMS-IMAGE DBPUT/DBUPD/DBDEL REQUEST TBPUT NOP LDA D4 JSB GETPA SPC 1 LDB .D2 FORCE SPECIAL LOCK WORD TO UNLCK JSB GETLW GET UNLOCK REQUEST ONLY LDA .SAVR,I GET LOCK WORD ID STA B,I INB TBPU5 LDA .PAR1 MOVE DATA SET NAME MVW D3 LDA .PAR3,I GET NUMBER OF DEFINED ITEM # INA FOR WORD COUNT STA TEMP LDA .PAR3 MOVE ITEM # DEFINTION ARRAY (INBR) MVW TEMP LDA .PAR4 MOVE ITEMS VALUE (IVALU) MVW MENTL TBUP8 ADB M.BUF COMPUTE BUFFER LENGTH STB BUFLN SET BUFFER LENGTH * LDA .PAR2 SAVE USER STATUS ADDR CLB JSB SENDI SAVE PARAM ADDR & SEND MAIL BOX SPC 1 JSB RECMB RESTORE PARAM ADDR & RECEIVE MAIL BOX LDA RCBUF RECALL IMAGE STATUS STA .PAR2,I AND STORE IT INTO USER BUFFER JMP .PAR1,I RETURN TO USER SPC 2 TBUPD NOP LDA D5 JSB GETPA SPC 1 LDB .D2 FORCE SPECIAL LOCK WORD TO UNLCK JSB GETLW GET UNLOCK REQUEST ONLY LDA .SAVR MOVE SAVE RUN TABLE BUFFER MVW D8 JMP TBPU5 FINISHES LIKE DBPUT CALL SPC 2 TBDEL NOP LDA D6 JSB GETPA SPC 1 LDB .D2 FORCE SPECIAL LOCK WORD TO UNLCK JSB GETLW GET UNLOCK REQUEST ONLY LDA .SAVR MOVE SAVE RUN TABLE AREA MVW D8 LDA .PAR1 MOVE DATA SET NAME MVW D3 JMP TBUP8 * .D2 DEF D2 HED GENERAL TRANSFERT PARAMETER ADDRESS ROUTINE GETPA NOP LDB GETPA ADB DM3 LDB B,I STB RTRN ADB DM1 STB XSUSP STA IMRQC SET UP IMAGE-REQUEST-CODE LDX PAR# CLA CLEAR FUTUR PARAMETERS ADRESSES SAX .PAR1-1 TO KNOW HOW MANY PARAMETERS ARE DSX PASSED JMP *-3 JMP RTRN+1 SPC 1 .PAR1 NOP .PAR2 NOP .PAR3 NOP .PAR4 NOP .PAR5 NOP .PAR6 NOP BSS 9 RQCNT NOP XSUSP NOP ABS IMSCD TMS INTERNAL SUBROUTINE CODE FOR IMAGE RQ RTRN NOP JSB .ENTR GET PARAMETERS ADDRESS ..PA1 DEF .PAR1 (HOPE IT IS MICRO-CODED) * CLA STA RQCNT TO BE SURE THAT THE LOOP WILL END LDX D0 GETP7 LAX .PAR1 SZA,RSS PARAMETER HERE ? JMP GETP8 NO, END OF LIST REACHED ISX YES, INCREMENT X REG JMP GETP7 AND LOOP * GETP8 CXA SAVE # OF PARAMETERS STA RQCNT ADA DM10 NEVER MORE THAN 9 PARAMETERS SSA,RSS HLT JSB CONF RECONFIGURE PT ADDR JMP ERM10 DATA-BASE IS NOT OPEN JMP GETPA,I SPC 1 PAR#. EQU RQCNT-.PAR1 PAR# ABS PAR#. * D0 DEC 0 DM1 DEC -1 DM3 DEC -3 DM10 DEC -10 HED UTILITY SUBROUTINE GETLW NOP SET LOCK WORD AND INIT BUFFER POINTER CLA DEFAULT VALUE IS ZERO LDA B,I GET LOCK WORD VALUE LDB .BUF INIT B REG = BUFFER WORD POINTER STA B,I STORE LOCK WORD INTO BUFFER INB BUSMP POINTER BUFFER JMP GETLW,I SPC 3 SENDI NOP SAVE USER PARAMETERS ADDR AND STA .PAR2 SEND THE BUFFER TO IMAGE MODULE STB .PAR3 THEN EXIT USING TMLIB. LDA RTRN SAVE RETURN ADDR IN USER CODE STA .PAR1 LDA BUFLN ADJUST BUFFER LENGTH ADA D4 STA BUFLN * JSB EXEC CALL TMS-IMAGE-MODULE PROGRAM DEF *+10 DEF NAB24 QUEUE SCHEDULE - NO WAIT - NO ABORT DEF .IMPG,I PROGRAM NAME DEF * DEF * DEF * DEF * DEF * DEF IMRQC BUFFER TO PASSED USING STRING PASSING DEF BUFLN BUFFER LENGTH HLT 10B ERROR RETURN * LDA SENDI GET RETURN ADDR STA RTRN AND SET TMS RETURN ADDR. INTO TMLIM LDA ..PA1 SET A REG = ADDR OF PARAM. AREA JMP .EXIT,I AND GOTO TMLIB ---> TMSYS SPC 3 RECMB NOP RESTORE PARAM ADDR & RECEIVE MAIL BOX JSB CONF RECONFIGURE LOCAL TABLE ADDR HLT 10B DATA-BASE IS NOT OPEN LDA .PARX RESTORE TMS FUNCTION PARAMETERS LDB ..PA1 TO GET BACK USER PARAMETERS ADDR MVW D3 * JSB EXEC GET THE BUFFER FROM TMS-IMAGE-MODULE DEF *+7 DEF NAB21 CLASS I/O GET WITH NO-ABORT DEF .ICLA,I CLASS I/O WORD (TMS INTERNAL CLASS) .BUF DEF BUF BUFFER DEF MBUFL BUFFER LENGTH DEF PARM1 DEF PARM2 HLT 10B ERROR RETURN * LDA PARM1 CHECK THAT CORRECT PARAMETERS CPA STKPT HAVE BEEN RETURNED BY THE RSS TMS-IMAGE-MODULE PROGRAM. HLT LDA PARM2 CPA STKPT+1 RSS HLT * JMP RECMB,I SPC 1 NAB21 OCT 100025 NAB24 OCT 100030 BUFLN NOP SKP CONF NOP LDA $TML5 RSS LDA A,I RAL,CLE,SLA,ERA PEEL OFF INDIRECT BIT JMP *-2 LDB .TBL MVW D5 * LDA .IMPG ADDR OF TMS-IMAGE PROGRAM LD}B A,I SZB,RSS IMAGE INITIALIZED ? JMP CONF,I NO, (RETURN P+1) ERROR IMAGE # 10 ADA D3 LDB .IMCL MOVE LOCALLY THE CLASS I/O WORD AND MVW D3 THE MAXIMUM ITEM & ENTRY LENGTH LDB A,I GET STACK POINTER STB STKPT SET STACK POINTER * LDA .PARX GET ADDR OF THE THREE FUNCTION PARAMETERS ADA D3 LDB A,I GET CB1 ADDR ADB D6 STB .SAVR SAVE ADR OF THE SAVE RUN TABLE AREA INA LDA A,I GET CB1 LENGTH SSA ENABLED ? JMP ERM07 CB1 NOT ENABLED: ERROR 07 ADA DM14 YES, LENGTH MUST BE AT LEAST 14 SSA LENGTH OK ? JMP ERM07 CB1 TOO SMALL: ERROR 07 * LDA .ECLA,I GET TMS EXTERNAL CLASS I/O STA ECLAS LDA .BUF CMA,INA STA M.BUF MINUS ADDR OF BUF ISZ CONF RETURN P+2 OK JMP CONF,I * DM14 DEC -14 SPC 1 .IMCL DEF IMCLS * .TBL DEF *+1 .EXIT NOP ADDR TO EXIT INTO TMLIB .IMPG NOP ADDR OF TMS-IMAGE-MODULE PROGRAM NAME .PARX NOP FUNCTION PARAMETERS ADDR. IN TMLIB .ECLA NOP TMS EXTERNAL CLASS I/O WORD ADDR .ICLA NOP TMS INTERNAL CLASS I/O WORD ADDR SPC 1 .SAVR NOP ADDR OF LOCK ID WORD M.BUF NOP MINUS ADDR OF BUF SKP ERM10 LDA D398 DATA BASE NOT OPEN LDB IMRQC RECALL SUBROUTINE CODE CPB D2 DBGET ? STA .PAR3,I YES, STORE STATUS CPB D3 DBFND ? STA .PAR1,I YES, STORE STATUS CPB D4 DBPUT ? STA .PAR2,I YES, STORE STATUS CPB D5 DBUPD ? STA .PAR2,I YES, STORE STATUS CPB D6 DBDEL ? STA .PAR2,I YES, STORE STATUS JMP RTRN,I AND RETURN ERROR CODE TO THE USER * ERM07 LDA D7 CB1 NOT ENABLED OR TOO SMALL JMP $TML8 SPC 3 D2 DEC 2 D3 DEC 3 D4 DEC 4 D5 DEC 5 D6 DEC 6 D7 *($ DEC 7 D398 DEC 398 SPC 1 TEMP NOP PARM1 NOP PARM2 NOP SPC 2 * BUFFER SEND FORM TMLIM TO TMSIM SPC 1 IMRQC NOP IMAGE REQUEST CODE ECLAS NOP TMS EXTERNAL CLASS I/O WORD STKPT NOP PARAMETER THAT MUST BE SEND BACK WITH ANSWER ABS IMSCD (STACK POINTER/TMS INTERNAL SUBROUTINE CODE) BUF BSS 389 (1+1+3+128+256 TO SEND DBPUT) SPC 1 RCBUF EQU BUF+2 SPC 2 UNS * ORG * DEFINE LAST LOCATION END "*  92903-18111 1805 S C0322 &$ITMS              H0103 tASMB HED . ** T M S - I M A G E - M O D U L E ** NAM $ITMS,7 92903-16100 REV.1805 780525 SPC 3 ********************************************************************** * * * NAME: $ITMS TMS-IMAGE MODULE * * SOURCE: &$ITMS 92903-18111 * * BINARY: %$ITMS ----NONE--- PART OF %TMSLB 92903-16100 * * * * PGMR: FRANCOIS GAULLIER * * * ********************************************************************** SPC 2 * ************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * ************************************************************** SPC 3 ENT $ITMS SPC 1 EXT RMPAR,PNAME,EXEC,CNUMD,PRTN,KLCLS EXT $PARS,DBCRC EXT DBINT,DBOPN,DBCLS,DBUPD,DBDEL EXT DBPUT,DBFND,DBINF,DBGET,DBLCK EXT HASH SPC 1 A EQU 0 B EQU 1 SUP SPC 4 $ITMS STA LOCTB SAVE LOCK TABLE ADDR STA LOCTE AND INIT LOCK TABLE POINTERS STB PROTB STB PROTE LDB A,I RECALL B REG VALUE JSB RMPAR AND RETREIVE PARAMETER DEF *+2 DEF P1 SPC 1 JSB EXEC SWAP THE WHOLE AREA DEF *+3 DEF D22 DEF D3 SWAP THE ENTIRE PARTITION SPC 2 * JSB .DBUG CALL DBUG: INTERNAL USE ONLY !!!!!!!!!!!!!!!!!!!!! * EXT .DBUG CALL DBUG: INTERNAL USE ONLY !!!!!!!!!!!!!!!!!!!!! SPC 2 JSB PNAME GET PROGRAM NAME DEF *+2 .ILIS DEF ILIST+1 SKP * SHEDULE REQUEST ACCEPTED BY THIS PROGRAM: * =========================================== * * * - IF NO STRING IS PASSES: * * * THE 4TH PARAMETER IS CHECKED, IF = -1 THEN THE PROGRAM TRY TO * GET A REQUEST BUFFER ON SPECIAL CLASS ALLOCATED BY THIS PROGRAM * AND RETURNED TO USER ON THE DBOPN CALL. IF THE GET FAIL THE * PROGRAM TERMINATES FOR EVER IF IT WAS DORMANT, OR WITH 'SAVE * SUSPENSION POINT' OPTION IF IT WAS IN THAT STATE. * * IF THE 4TH PARAMATER IS NOT -1, THEN IT IS ASSUMED TO BE A * CLASS I/O WORD AND A CLASS I/O GET IS EXECUTED ON THAT CLASS. * * IF THE GET FAIL, A ERROR MESSAGE IS PRINTED ON THE SYSTEM * CONSOLE AND THE PROGRAM TERMINATES WITH THE CURRENT OPTION. * * IF THE GET SUCCEED, THE FIRST WORD OF THE BUFFER IS ASSUMED * TO BE THE REQUEST CODE. IF IT IS LEGAL (0 =< RQ =<8), THE * REQUEST IS PERFORMED, ELSE THE ERROR MESSAGE IS PRINTED ON * THE SYSTEM CONSOLE AND THE PROGRAM TERMINATES WITH THE * CURRENT OPTION. * * * - IF A STRING IS PASSES: * * * THE FIRST WORD OF THE STRING IS ASSUMED TO BE THE REQUEST CODE * IF IT IS LEGAL (BETWEEN 0 & 8) THE REQUEST IS PERFORMED. * IF THE REQUEST CODE IS NOT LEGAL, THE STRING IS CHECKED AGAINST * ",,1" OPTAIN FROM THE FOLLOWING RTE/FMGR COMMAND "RU,TMSIM,,,1" * * IF THE STRING DOES NOT MATCHE, A MESSAGE IS PRINTED ON THE * TERMINAL USED TO SHEDULE THE PROGRAM, AND THE PROGRAM * TERMINATES WITH THE CURRENT OPTION. * * IF THE STRING MATCHES, AND THE DATA-BASE IS CLOSE, THE * FOLLOWING MESSAGE IS PRINTED: * NO DATA-BASE CURRENTLY OPEN. * * IF THE STRING MATCHES, AND A DATA-BASE IS STILL OPEN, THE * USER IS PROMPTED WITH THE FOLLOWING: * DATA-BASE= * LEVEL WORD= * C SEC-CODE= * IF THE USER ANSWER CORRECTLY, THE DATA-BASE IS CLOSED IMMEDIATLY * REGARDLESS OF ANY LOCKING CONSIDERATION, AND THE PROGRAM * TERMINATES FOR EVER. (NO SAVE SUSP. OPTION) * * THIS PROCEDURE SHOULD BE USE ONLY IN CASE OF EMMERGENCY !! * * * THE ERROR MESSAGE PRINTED ON THE TERMAINL IS THE FOLLOWING: * * /XXXXX : ILLEGAL SCHEDULE REQUEST ! SKP * FATAL ERROR # MEANING * * 1 [DBOPN] TMSIM COPY MISSING, NOT LOADED (DONE * LOCALLY BY TMLIM) * 2 [DBOPN] LEVEL ACCESS WORD IS NOT THE GREATER ONE * 3 [DBOPN] USE OF THIS PROGRAM TO ACCES AN OTHER DATA-BASE * 500 THE PROGRAM HAS NOT BEEN INITAILIZED * (NO DBOPN REQUEST) * 399 UPDATE A FILE NOT SAVED IN THE AUTOMATIC * SAVED RUN TABLE. SPC 2 * NEW IMAGE STATUS MEANING * * 397 [IMG-STAT] LOCK TABLE OVERFLOW. * 398 [IMG-STAT] IMAGE TBXXX CALL WITH NO DATA-BASE DEFINED IN THE * TMS APPLICATION. (DONE LOCALY IN TMLIM) * 400 [IMG-STAT] ERROR RETURNED WHEN PROCESS SHOULD BE SUSPENDED * AND THE 'NO WAIT' OPTION HAS BEEN SPECIFIED * 401 [IMG-STAT] DEADLOCK ERROR ! * 403 [IMG-STAT] UNLOCK RECORD LOCKED BY AN OTHER PROCESS * 404 [IMG-STAT] UNLOCK RECORD WITHOUT HAVING A LOCKID (NEVER * REQUEST ANY LOCK) * 405 [IMG-STAT] DBPUT IN A MASTER WITHOUT HAVING LOCK THE ENTRY * IN ADVANCE SKP * MAXIMUM VALUE CONSIDERATION * =========================== * * - IMAGE MAXIMUM VALUE: * * MAXIMUM NUMBER OF DATA-SET PER DATA-BASE : 50 * MAXIMUM NUMBER OF ITEM PER DATA-BASE : 255 * MAXIMUM NUMBER OF ITEM PER DATA-SET ENTRY : 127 * * MAXIMUM ENTRY LENGTH (MEDIA+DATA) : 256 WORDS * MAXIMUM ITEM LENGTH : 63 WORDS * * * - TMS-IMAGE COMMUNICATION MAXIMUM BUFFER LENGTH: * * MAXIMUM BUFFER LENGTH RECEIVED BY THIS PROGRAM IS * FOR A DBPUT CALL : 4+1+1+3+128+256 = 393 = RBULN * WHERE 4,1,1,3 ARE TMS INTERNAL BUFFER * 128 IS INBR (MAX # OF ITEM/DATA-SET + 1) * AND 256 IS IVALUE (MAX ENTRY LENGTH) * * MAXIMUM BUFFER LENGTH SEND BY THIS PROGRAM IS * FOR A DBGET CALL : 2+8+4+1+256 = 271 = SBULN * WHERE 2,8,4,1 ARE TMS INTERNAL BUFFER * AND 256 IS THE ENTRY VALUE (MAX ENTRY LENGTH) * * ANY BUFFER RETURNED BY DBINF SHOULD BE SMALLER THAN THAT. SKP LDA LOCTB GET FWA OF BUFFER LDB PROTB GET LWA OF BUFFER CMB,INB ADB LOCTB COMPUTE LENGTH STA PT SAVE FWA CLA STA PT,I ISZ PT CLEAR THE BUFFER INB,SZB JMP *-3 SPC 1 * ALLOCATE A CLASS I/O WORD, PASSES IT BACK TO THE * CALLER, SO WHEN THE CALLER NEED TO REQUEST THAT PROGRAM * IT CAN USE A SCHEDULE REQUEST OR IF THE PROGRAM IS NOT * DORMANT IT CAN SEND A MAIL BOX USING THIS CLASS I/O * IN ORDER TO NOT SUSPEND ITSELF. * JSB GTCLW ALLOCATE A CLASS I/O STA CLASS SAVE THE CALSS I/O WORD * JMP DEB05 SPC 3 ILSHR LDA P1 SET UP LU SZA,RSS ILSH3 CLA,INA STA P1 LDA .ILIS SET PROGRAM NAME IN THE MESSAGE LDB .MES1 MVW D3 JSB EXEC OUTPUT DEF *+5 "ILLEGAL SHEDULE REQUEST ! " DEF D2 DEF P1 DEF MES DEF D18 LDA ACTIV GET ACTIVE FLAG SZA,RSS PROGRAM ACTIVE ? JSB ABORT NO, TERMINATE PROGRAM JMP EXIT9 YES, SAVE SUSPENSION POINT * MES ASC 5, /XXXXX : ASC 13,ILLEGAL SCHEDULE REQUEST ! D18 DEC 18 D14 DEC 14 D8 DEC 8 .MES1 DEF MES+1 D22 DEC 22 D7 DEC 7 * I ILIST DEC 1 BSS 3 * SBULN DEC 271 MAX BUF LEN TO SEND RBULN DEF 393 MAX BUF LEN TO RECEIVE * ISTAT BSS 10 * CLASS NOP * SPC 1 P1 BSS 3 PARAMETERS GET BY RMPAR CLAS# OCT 0 P4 MAY BE THE CLASS I/O WORD NOP HED T-M LIBRARY <---> TMS-IMAGE MODULE COMMUNICATION EXIT5 ADA D2 ADJUST MAIL BOX LENGTH CLB STB ERCOD NO FATAL ERROR REPORTED LDB SCODE RETURN THE TMS-IMSGE-RQ-CODE STB ERCOD+1 TO THE CALLER SPC 1 EXIT6 STA LTEM SET MAIL BOX LENGTH * LDA CLAS# RELEASE CLASS I/O IF NOT ALREADY DONE JSB KLCLX LDA ECLAS RECALL CLASS I/O THAT SHOULD BE USED STA CLAS# TO SEND THE RESULT LDA PARM SET UP OPTIONAL CLASS I/0 PARAMETERS LDB PARM+1 WITH THOSE SUPPLIED BY THE USER JSB PSAM SEND ANSWER TO THE USER USING HIS CLASS I/O DEF ERCOD BUFFER ADDR LTEM NOP BUFFER LENGTH SPC 1 EXIT3 LDA RSTAR,I GET RESTART QUEUE HEAD SZA,RSS SOMETHING TO RESTART ? JMP EXIT4 NO, EXIT RAL,CLE,ERA YES, CLEAR BIT 15 LDB A,I REMOVE THAT PROCESS FROM THE STB RSTAR,I RESTART QUEUE CLB STB A,I CLEAR LINK WORD IN THE PROCESS DIRECTORY INA LDB A,I RECALL CLASS I/O STB CLAS# SET CLASS I/O WORD CLB STB A,I CLEAR CALL I/O IN THE PROCESS DIRECTORY LDA CLAS# SET CLASS I/O WORD IN A REG. JMP DEB15 AND RESTART PROGRAM SPC 1 EXIT4 LDA CLASS TRY TO GET A REQUEST ON THE SPECIAL CLASS JSB GSAM GET NO-WAIT & NO-ABORT SSA,RSS SOMETHING GET ? JMP DEB20 YES, GO PROCESS REQUEST * RTNFL OCT 0 RETURN FLAG (NOP/RSS) TO RTN PARAM TO CALLER JMP EXIT9 IF NOP; EXIT WITHOUT 'PRTN' * SPCLF RSS CLEARED ONLY WHEN SPECIAL CLOSE JMP SPCLS REQUEST IS REQUESTED, RETURN TO SPECIAL PROCESS _* JSB PRTN SEND RETURN PARAMETERS TO CALLER DEF *+2 DEF RTPAR RETURN PARAMETRS BUFFER * EXIT9 JSB EXEC COMPLETE THIS PROGRAM DEF *+4 SAVING SUSPENSION POINT. DEF D6 .D0 DEF D0 DEF D1 SPC 1 **************************************************************** SPC 1 JSB RMPAR RETREIVE SCHEDULE PARAMETERS DEF *+2 DEF P1 SAVE PARAMETER * DEB05 CLA SET RETURN FLAG TO NOT USE 'PRTN' STA RTNFL SPC 1 JSB EXEC GET STRING REQUEST DEF *+5 DEF D14 DEF D1 .SCOD DEF SCODE BUFFER ADDR DEF RBULN BUFFER LENGTH DST PARM1 SAVE STATUS & LENGTH SZA,RSS STRING GET SUCCED ? JMP DEB18 YES, GO PROCESS REQUEST * LDA CLAS# NO STRING, CHECK FOR A MAIL BOX CPA DM1 WANTS TO GET FROM THE SPECIAL CLASS ? JMP EXIT4 YES, GO DO THE GET SZA,RSS CLASS I/O DEFINED ? JMP ILSH3 NO, PRINT 'ILLEGAL SCHEDULE REQUEST' DEB15 AND =B17777 YES, RELEASE BUFFER ON THE NEXT GET IOR B20K BUT DO NOT DEALLOCATE THE CLASS I/O JSB GSAM GET NO-WAIT & NO-ABORT SSA SOMETHING GET ? JMP ILSH3 NO, PRINT MESSAGE AND EXIT JMP DEB25 YES, PROCESS THE REQUEST SPC 2 DEB18 BLS SET TLOG IN CHARACTERS LDA .SCOD BUFFER ADDR JSB $PARS PARSE THE BUFFER DEF BTEMP AND STORE RESULTE INTO BTEMP * LDA BTEMP+1 RECALL FIRST PARAM VALUE CPA ARU IS IT A "RU, .... " COMMAND ? JMP SPCL3 YES, CHECK FOR EMERGENCY PROCEDURE SPC 1 DEB20 CLA NO CLASS I/O IS DEFINE IN THAT WORD STA CLAS# SPC 2 DEB25 LDA SCODE GET REQUEST CODE SSA NEGATIVE ? JMP ILSH3 YES, ERROR ADA =D-9 GREATER THAN 9 SSA,RSS JMP ILSH3 YES, ERROR LDA SCODE NO, RECALL SUBROUTINE CODE LDB ACTIV RECALL ACTIVE FLAG SZB DATA BASE OPEN ? JMP DEB30 YES, CONTINUE SZA NO, OPEN REQUEST ? JMP ER500 NO, REJECT THIS CALL SPC 1 DEB30 ADA C.TAB INDEX IN TABLE JMP A,I HED EMERGENCY CLOSE PROCEDURE SPCL3 LDA BTEMP+8 VERIFY THAT THE 1ST PARAM SZA IS NOT DEFINED JMP ILSH3 ERROR ! LDA BTEMP+12 VERIFY THAT THE 2ND PARAM SZA IS NOT DEFINED JMP ILSHR ERROR ! LDA BTEMP+16 VERIFY THAT THE 3RD PARAM ADA BTEMP+17 IS "1" CPA D2 COMPARE TYPE+VALUE RSS OK, DO SPECIAL CLOSE REQUEST JMP ILSHR SPC 1 LDA P1 RECALL LU SZA,RSS CLA,INA STA P1 SAVE LU IOR =B400 STA P1+1 SAVE LU FOR INPUT SPC 1 LDA ACTIV DATA-BASE OPEN SZA,RSS OPEN ? JMP SPCL9 NO, REPORT ERROR SPC 1 SPCL5 JSB EXEC PRINT "DATA-BASE=" DEF *+5 DEF D2 DEF P1 LU DEF MSDB BUFFER DEF D7 JSB SPCL0 READ AND PARSE ANSWER CPB D2 ASCII ? RSS YES, OK JMP SPCL5 NO, TRY AGAIN LDB .DBNM CHECK IF CORRECT CMW D3 JMP SPCL6 OK, ASK LEVEL WORD NOP DO NOT COMPARE JMP ILSHR REJECT THE SHEDULE REQUEST * SPCL6 JSB EXEC PRINT "LEVEL =" DEF *+5 DEF D2 DEF P1 DEF MSLE DEF D5 JSB SPCL0 READ AND PARSE ANSWER SZB,RSS NUL ? LDA .SP YES, TAKE DEFAULT ASCII VALUE SZB CPB D2 ASCII ? RSS YES, OK JMP SPCL6 NO, TRY AGAIN LDB .DBN3 CHECK IF CORRECT CMW D3 JMP SPCL7 OK, ASK LEVEL WORD NOP DO NOT COMPARE JMP ILSHR REJECT THE SHEDULE REQUEST * SPCL7 JSB EXEC PRINT "SEC.-CODE=" DEF *+5 DEF D2 DEF P1 LU DEF MSSC BUFFER DEF D7 JSB SPCL0 READ AND PARSE ANSWER SZB NUL ? CPB D1 NUMERIC ? RSS YES, OK JMP SPCL7 NO, TRY AGAIN LDB A,I CHECK IF CORRECT CPB DBNAM+6 RSS JMP ILSHR REJECT THE SHEDULE REQUEST * CLA,INA SET SCODE FOR DBCLOSE STA SCODE CLA SET SPECIAL CLOSE FLAG STA SPCLF TO RETURN AFTER THE CLOSE JMP XDBC0 * SPCLS LDA .DBNM MOVE DATA-BASE NAME INTO THE MESSAGE LDB .MS9X MVW D3 LDA RTPAR RECALL DBCLOSE IMAGE STATUS SZA,RSS OK ? JMP SPCL8 YES, PRINT MESSAGE SSA NO, PRINT ERROR MESSAGE CMA,INA STA TEMP JSB CNUMD DEF *+3 DEF TEMP DEF MS9+16 LDA .MS8 LDB .MS9Y MVW D8 SPCL8 JSB EXEC PRINT "DATA-BASE XXXXXX SUCCESSFULLY CLOSE" DEF *+5 DEF D2 DEF P1 DEF MS9 DEF D20 JMP EXIT9 SPC 1 SPCL9 JSB EXEC PRINT "NO DATA-BASE CURRENTLY OPEN" DEF *+5 DEF D2 DEF P1 DEF MS7 DEF D16 JSB ABORT TERMINATE PROGRAM JMP EXIT9 SPC 1 MSDB ASC 7, DATA-BASE = _ MSLE ASC 5, LEVEL = _ MSSC ASC 7, SEC.-CODE = _ MS9 ASC 20, DATA-BASE: XXXXXX SUCCESSFULLY CLOSED. MS7 ASC 16, NO DATA-BASE CURRENTLY OPEN ! .MS8 DEF *+1 ASC 8,; CLOSE ERROR : .SP DEF *+1 ASC 3, .MS9Y DEF MS9+9 .MS9X DEF MS9+6 ARU ASC 1,RU .DBN3 DEF DBNAM+3 D16 DEC 16 SPC 1 SPCL0 NOP JSB EXEC READ ANSWER DEF *+5 DEF D1 DEF P1+1 .BUF DEF BUF DEF DM7 LDA .BUF RECALL BUFFER ADDR JSB $PARS PARSE BUFFER DEF BTEMP OUTPUT BUFFER LDA .BTE1 ADDR. OF DATA LDB BTEMP TYPE OF DATA JMP SPCL0,I * .BTE1 DEF BTEMP+1 DM7 DEC -7 HED IMAGE / INTERNAL ERROR]E PROCESSING ERR? NOP FOR INTERNAL IMAGE RQ, CHECK STATUS LDA ISTAT RECALL IMAGE STATUS JSB .ERR? JMP ERR?,I SPC 2 * FATAL ERROR PROCESSING ---> ABORT CALLER * .ERR? NOP SZA,RSS OK ? JMP .ERR?,I YES, CONTINUE EROR JSB CHECK !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! LDB SCODE SZB,RSS OPEN REQUEST ? JMP RTPRG YES, USE SPECIAL RETURN WITH 'PRTN' CPB D1 CLOSE REQUEST ? JMP RTPRG CPB D8 TBULK REQUEST ? JMP RTPRG DST ERCOD SET UP ERROR CODE & REQUEST CODE LDA D2 SET BUFFER LENGTH JMP EXIT6 AND GO SEND THE ANSWER TO THE CALLER SPC 1 ER500 JSB ABORT TERMINATE THE PROGRAM LDA =D500 DATA-BASE HAS NOT BEEN OPENED JMP EROR SPC 2 * IMAGE ERROR PROCESSING ---> THE ERROR NUMBER * IS RETURNED TO THE USER, IN PLACE OF * THE IMAGE STATUS. * SIMST LDB SCODE SET IMAGE STATUS ADB S.TAB A REG = ERROR CODE JMP B,I JUMP TO RIGHT CODE SPC 1 SIMS1 STA BTEMP+8 SET IMAGE STATUS JSB CHECK !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! JMP XDBF3 AND RETURN * SIMS2 STA BTEMP SET IMAGE STATUS JSB CHECK !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! JMP XDBP5 AND RETURN SPC 1 S.TAB DEF *+1,I DEF ILRQ DBOPN DEF ILRQ DBCLS DEF SIMS1 DBGET DEF SIMS1 DBFND DEF SIMS2 DBPUT DEF SIMS2 DBUPD DEF SIMS2 DBDEL DEF ILRQ DBINF DEF ILRQ TBULK SPC 2 * TERMINATE THIS PROGRAM WITHOUT ANY OPTION * TO MAKE IT ACTUALLY DORMANT. SPC 1 ABORT NOP LDA .D0 STA .D0+1 SUPPRESS TERMINATE OPTION JMP ABORT,I AND TERMINATE PROGRAM. SPC 1 RSTAR DEF *+1 RESTART PROCESS QUEUE d:<:6 OCT 0 SPC 1 ACTIV OCT 0 # OF OPEN/CLOSE REQUEST HED DBOPN PROCESSOR * * INPUT BUFFER FORMAT: * * HEADR (4) RQ/CLASS#/PARM1/PARM2 * BUF[1:3] (3) DATA-BASE NAME * BUF[4:6] (3) LEVEL ACCESS WORD * BUF[7] (1) SECURITY CODE SPC 1 * RETURN VALUE USING 'PRTN' SUBROUTINE: * * RTPAR[1] (1) 0 / ERROR CODE * RTPAR[2] (1) TMS-SUBROUTINE CODE IF ERROR SPC 1 XDBOP LDA CLAS# RELEASE MAIL BOX & CLASS JSB KLCLX * LDA ACTIV GET ACTIVE FLAG SZA IS IT THE FIRST ENTRY ? JMP XDBO4 NO, CHECK THAT IT IS THE SAME DATA BASE SPC 1 LDA .BUF SAVE DATA-BASE NAME & LEVEL WORD LDB .DBNM & SECURITY CODE MVW D7 SPC 1 JSB DBINT INITIALIZE RUN TABLE AREA DEF *+5 DEF BUF DATA BASE NAME DEF BUF+6 SECURITY CODE < DEF ILIST LIST OF PROGRAM DEF ISTAT JSB ERR? OK ? SPC 1 JSB DBOPN OPEN THE DATA BASE DEF *+6 DEF BUF DATA BASE NAME DEF BUF+3 LEVEL ACCESS WORD DEF BUF+6 SECURITY CODE DEF D2 MODE DEF ISTAT STATUS JSB ERR? OK ? LDA ISTAT+1 RECALL LEVEL ACCESS CPA =D15 IS IT THE HIGHEST LEVEL ? JMP XDBO2 YES, GO LOCK THE DATA BASE LDA D2 NO, DBOPN ERR#2: BAD LEVEL ACCESS WORD JMP EROR PASSES ERROR BACK TO CALLING PRG & TERMINATE SPC 1 XDBO2 JSB DBLCK LOCK THE WHOLE DATA BASE DEF *+3 DEF D2 LOCK WITHOUT WAIT DEF ISTAT JSB ERR? SUCCESFUL LOCK ? * JSB DBCRC CALCULATE THE DATA-BASE CRC DEF *+6 AND RETURN MAXIMUM VALUE DEF BUF DATA BASE NAME DEF RTPAR+2 CRC DEF RTPAR+3 MAX ITEM LENGTH DEF RTPAR+4 MAX ENTRY LENGTH DEF ISTAT STATUS JSB ERR? OK ? * OKOPN ISZ ACTIV BUMP ACTIVE FLAG LDB CLASS RETURN SPECIAL CLASS# TO CALLER OKRTN CLA RETURN GOOD SATUS SPC 1 RTPRG DST RTPAR SAVE RETURN PARAMETERS LDA .RSS AND SET THE RETURN FLAG TO STA RTNFL USE 'PRTN' SUBROUTINE JMP EXIT3 RETURN SPC 2 XDBO4 LDA .BUF CHECK THAT NAME, LEVEL WORD AND SC LDB .DBNM ARE THE SAME CMW D7 JMP OKOPN OK, SAME DATA-BASE NOP NOT THE SAME LDA D3 DBOPN ERR#3: OPEN AN OTHER DATA BASE JMP EROR SPC 1 RTPAR BSS 5 .RSS RSS .DBNM DEF DBNAM DBNAM ASC 6,...... OCT 0 HED DBCLS PROCESSOR * * INPUT BUFFER FORMAT: * * HEADR (4) RQ/CLASS#/PARM1/PARM2 SPC 1 * RETURN VALUE USING 'PRTN' SUBROUTINE: * * RTPAR[1] (1) 0 / ERROR CODE * RTPAR[2] (1) TMS-SUBROUTINE CODE IF ERROR SPC 1 XDBC֩L LDA CLAS# RELEASE MAIL BOX & CLASS I/O JSB KLCLX * CCA DECREMENT ACTIVE FLAG ADA ACTIV STA ACTIV SZA LAST DBCLS REQUEST ? JMP OKRTN NO, FORGET THE REQUEST SPC 1 XDBC0 JSB ABORT SET UP TO TERMINATE PROGRAM * JSB DBCLS CLOSE THE DATA BASE DEF *+3 DEF D0 CLOSE ALL FILES DEF ISTAT SPC 1 LDA CLASS RELEASE THE CLASS I/O JSB KLCLX CLA STA CLASS SPC 1 LDB PROTB RELEASE CLASS I/O USED TO SUSPEND XDBC3 CPB PROTE PROCESSES: END OF DIRECTORY ? JMP XDBC8 YES, TERMINATE THE PROGRAM * ADB DM1 LDA B,I GET CLASS I/O WORD ADB DM2 BUMP POINTER SZA,RSS CLASS HERE ? JMP XDBC3 NO, SKIP RELEASE STB TEMP SAVE POINTER JSB KLCLX YES, DEALLOCATE THE CLASS LDB TEMP AND CONTINUE JMP XDBC3 SPC 1 XDBC8 CLA THE RESTART QUEUE IS EMPTY ! STA RSTAR,I JSB ERR? WAS DBCLS OK ? JMP OKRTN YES, RETURN HED TBULK PROCESSOR * * INPUT BUFFER FORMAT: * * SCODE (1) TMS-SUBROUTINE CODE * ECLAS (1) LOCKID WORD SPC 1 * RETURN VALUE USING 'PRTN' SUBROUTINE: * * RTPAR[1] (1) 0 / ERROR CODE * RTPAR[2] (1) TMS-SUBROUTINE CODE IF ERROR SPC 1 XTBUL LDA CLAS# RELEASE MAIL BOX & CLASS I/O JSB KLCLX * LDA D2 FORCE LOCKW TO UNLOCK REQUEST LDB ECLAS GET THE LOCKID WORD DST LOCKW AND STORE THEM WHERE THEY USE TO BE * JSB SPIDD ACCESS PROCESS ID DIRECTORY HLT 10B !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! SPC 1 LDA PIDPT,I RECALL # OF RECORDS LOCKED BY RAL,CLE,ERA THIS PROCESS STA PIDPT,I AND CLEAR BIT 15 (BIT X) SZA,RSS ANY RECORD OWNED ? JMP OKRTN g NO, RETURN LDA LOCTB YES, SEARCH ALL THOSE ENTRY IN THE LOCK TABLE * XTBU3 STA PT SET POINTER FOR UNLCK ROUTINE CPA LOCTE END OF LOCK TABLE ? HLT 12B YES, ERROR LDA PT,I GET ENTRY FROM THE LOCK TABLE ALF,ALF AND =B377 ISOLATE PIDX CPA PIDX ENTRY BELONG TO THIS PROCESS ? JSB UNLCK YES, RELEASE ENTRY LDA PIDPT,I RECALL # OF RECORD LOCKED SZA,RSS ALL RELEASED ? JMP OKRTN YES, RETURN LDA PT NO, CONTINUE ADA D2 BUMP POINTER JMP XTBU3 HED DBGET PROCESSOR * * INPUT BUFFER FORMAT: * * HEADR (4) RQ/CLASS#/PARM1/PARM2 * BUF[1] (1) LOCK WORD * BUF[2:9] (8) LOCK ID AND SAVE RUN TABLE * BUF[10] (1) DBGET MODE * BUF[11:13] (3) DATA SET NAME * BUF[14:X] (N) IARG SPC 1 * OUTPUT BUFFER FORMAT: * * ERCOD (2) ERROR CODE/SUB # (TMS INTERNAL) * BTEMP[1:8] (8) LOCK ID AND SAVE RUN TABLE * BTEMP[9:12] (4) IMAGE STATUS * BTEMP[13] (1) ENTRY LENGTH * BTEMP[14:X] (N) DATA RETREIVED (ENTRY VALUE) SPC 1 XDBGE LDA .BF10 GET DATA SET NAME JSB DSNUM ---> DATA SET NUMBER (INTO DS#) * LDA BUF+9 RECALL MODE ADA =D-3 SSA TYPE 1 OR 2 ? JSB RSTRT YES, RESTORE RUN TABLE NOP SPC 1 JSB DBGET READ FORM DATA BASE DEF *+6 DEF DS# DATA SET NAME .BF09 DEF BUF+9 MODE DEF BTEMP+8 STATUS RETURNED HERE DEF BTEMP+13 BUFFER DEF BUF+13 IARG LDA BTEMP+8 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! JSB CHECK !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! * JSB SAVRT SAVE RUN TABLE SPC 1 LDA BUF+9 RECALLr DBGET MODE JSB LOCK LOCK/UNLCK ENTRY AS REQUESTED SPC 1 LDA ENTLN RECALL ENTRY LENGTH STA BTEMP+12 TO SEND IT XDBG9 ADA D13 SPC 1 LDB LCKID PASSES BACK THE LOCK-ID WORD STB BTEMP (= TO PROC. INDEX DIRECTORY: PID) SPC 1 JMP EXIT5 AND RETURN SPC 1 .BF10 DEF BUF+10 D13 DEC 13 HED DBFND PROCESSOR * * INPUT BUFFER FORMAT: * * HEADR (4) RQ/CLASS#/PARM1/PARM2 * BUF[1] (1) LOCK WORD * BUF[2:9] (8) LOCK ID AND SAVE RUN TABLE * BUF[10:12] (3) DATA SET NAME * BUF[13:15] (3) KEY ITEM NAME * BUF[16:X] (N) KEY ITEM VALUE SPC 2 * OUTPUT BUFFER FORMAT: * * ERCOD (2) ERROR CODE/SUB # (TMS INTERNAL) * BTEMP[1:8] (8) LOCK ID AND SAVE RUN TABLE * BTEMP[9:12] (4) IMAGE STATUS SPC 2 XDBFN LDA .BF09 GET DATA SET NAME JSB DSNUM ---> DATA SET NUMBER * JSB DBFND SET UP THE CHAIN DEF *+5 DEF BTEMP+8 STATUS DEF DS# DATA SET NAME DEF BUF+12 KEY ITEM NAME DEF BUF+15 KEY ITEM VALUE LDA BTEMP+8 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! JSB CHECK !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! * JSB SAVRT SAVE RUN TABLE SPC 1 CLA SET MODE=0 FOR DBFND REQUEST JSB LOCK LOCK/UNLOCK ENTRY AS REQUESTED SPC 1 XDBF3 CCA TO AJUST BUFFER LENGTH JMP XDBG9 HED DBPUT PROCESSOR * * INPUT BUFFER FORMAT: * * HEADR (4) RQ/CLASS#/PARM1/PARM2 * BUF[1] (1) LOCK WORD * BUF[2] (1) LOCK ID WORD * BUF[3:5] (3) DATA SET NAME * BUF[6:X] (N) INBR * BUF[Y:Z] (M) IVALUE SPC 2 * OUTPUT BMUFFER FORMAT: * * ERCOD (2) ERROR CODE/SUB # (TMS INTERNAL) * BTEMP[1] (1) IMAGE STATUS SPC 2 XDBPU LDA .BF02 GET DATA SET NAME JSB DSNUM ---> DATA SET NUMBER * LDA BUF+5 RECALL # OF ITEM INA ADA .BF05 STA XDBP3 SET IVALU ADDR SPC 1 LDA D5 SET MODE=5 FOR DBPUT REQUEST JSB LOCK UNLOCK REQUEST AS REQUESTED SPC 1 JSB DBPUT STORE DATA INTO THE DATA BASE DEF *+6 DEF DS# DATA SET NAME DEF BTEMP STATUS .BF05 DEF BUF+5 INBR XDBP3 NOP IVALU DEF BTEMP+1 TEMPORARY BUFFER LDA BTEMP !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! JSB CHECK !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! * XDBP5 CLA,INA MAIL BOX LENGTH JMP EXIT5 RETURN SPC 1 .BF02 DEF BUF+2 HED DBUPD PROCESSOR * * INPUT BUFFER FORMAT: * * HEADR (4) RQ/CLASS#/PARM1/PARM2 * BUF[1] (1) LOCK WORD * BUF[2:9] (8) LOCK ID AND SAVE RUN TABLE * BUF[10:12] (3) DATA SET NAME * BUF[13:X] (N) INBR * BUF[Y:Z] (M) IVALUE SPC 2 * OUTPUT BUFFER FORMAT: * * ERCOD (2) ERROR CODE/SUB # (TMS INTERNAL) * BTEMP[1] (1) IMAGE STATUS SPC 2 XDBUP LDA .BF09 GET DATA SET NAME JSB DSNUM ---> DATA SET NUMBER * JSB RSTRT RESTORE RUN TABLE JMP XDBU7 WRONG DATA SET ---> ERROR # 399 SPC 1 LDA D6 SET MODE=6 FOR DBUPD JSB LOCK UNLOCK ENTRY AS REQUESTED SPC 1 LDA BUF+12 RECALL # OF ITEM INA ADA .BF12 STA XDBU3 SET IVALU ADDR * JSB DBUPD UPDATE ITEM VALUE IN AN ENTRY DEF *+6 DEF DS# DATA SET NAME DEF BTEMP STATUS .BF12 DEF BUF+12 INBR XDBU3 NOP IVALU DEF BTEMP+1 TEMPORARY BUFFER USED BY IMAGE LDA BTEMP !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! JSB CHECK !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! * JMP XDBP5 TERMINATE LIKE DBPUT SPC 3 XDBU7 LDA =D399 BAD RUN TABLE SAVED JMP EROR ERROR # 399 HED DBDEL PROCESSOR * * INPUT BUFFER FORMAT: * * HEADR (4) RQ/CLASS#/PARM1/PARM2 * BUF[1] (1) LOCK WORD * BUF[2:9] (8) LOCK ID AND SAVE RUN TABLE * BUF[10:12] (3) DATA SET NAME SPC 2 * OUTPUT BUFFER FORMAT: * * ERCOD (2) ERROR CODE/SUB # (TMS INTERNAL) * BTEMP[1] (1) IMAGE STATUS SPC 2 XDBDE LDA .BF09 GET DATA SET NAME JSB DSNUM ---> DATA SET NUMBER * JSB RSTRT RESTORE RUN TABLE JMP XDBU7 WRONG DATA SET ---> ERROR#399 SPC 1 LDA D6 SET MODE=6 FOR DBDEL JSB LOCK UNLOCK ENTRY AS REQUESTED SPC 1 JSB DBDEL DELETE ENTRY IN A DATA SET DEF *+3 DEF DS# DATA SET NAME DEF BTEMP STATUS LDA BTEMP !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! JSB CHECK !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! * JMP XDBP5 RETURN TO USER PROGRAM HED !!! XDBIN NOP HLT 20B SPC 1 ILRQ STA TEMP NOP HLT 22B SPC 2 CHECK NOP !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! LIB 1 NOP SSB !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! JMP CHECK,I SZA,RSS JMP CHECK,I LDB SCODE CPB D2 JMP CHEC1 CPB D3 JMP CHEC1 JMP CHEC3 CHEC1 CPA =D107 JMP CHECK,I * CHEC3 STA CHEC9 JSB CNUMD DEF *+3 DEF SCODE DEF CHMS+4 JSB CNUMD DEF *+3 DEF CHEC9 DEF CHMS+9 JSB IEXEC DEF *+5 DEF D2 DEF D1 DEF CHMS DEF D12 LDA CHEC9 JMP CHECK,I * CHEC9 NOP D12 DEC 12 CHMS ASC 12, DB CODEXXXXXX ERRXXXXXX HED UTILITY SUBROUTINE DSNUM NOP FIND DATA SET NUMBER STA DSNU3 LDA A,I GET FIRST CHAR. OR NUM. STA ISTAT+1 ADA DM256 IS IT ALREADY SSA A NUMBER ? JMP DSNU7 YES, SKIP THE DBINF JSB DBINF DATA SET NAME ---> DATA SET # DEF *+5 DEF S TYPE DEF D5 MODE DSNU3 NOP DATA SET NAME DEF ISTAT STATUS JSB ERR? OK ? DSNU7 LDA ISTAT+1 STA DS# SET DATA SET NUMBER JSB DBINF DS# ---> TYPE/CAPACITY/ENTRY LENGTH DEF *+5 DEF S TYPE DEF D2 MODE DEF DS# DATA SET NUMBER DEF ISTAT STATUS JSB ERR? OK ? LDA .IST4 MOVE INFO LDB .DSTP MVW D3 JMP DSNUM,I * .IST4 DEF ISTAT+4 .DSTP DEF DSTYP DS# NOP DATA SET NUMBER DSTYP NOP DATA SET TYPE (ASCII) CAPAC NOP CAPACITY OF THE DATA SET ENTLN NOP ENTRY LENGTH ITEM# NOP KEY ITEM NUMBER ITMLN NOP ITEM LENGTH SPC 1 KYITM NOP RETREIVE KEY ITEM CHARACTERITICS JSB DBINF DS# ---> KEY ITEM # DEF *+5 DEF I TYPE DEF D3 MODE DEF DS# DATA SET NUMBER DEF ISTAT STATUS JSB ERR? OK LDA ISTAT+1 GET NUMBER OF KEY ITEM CPA D1 MUST BE ONLY ONE RSS SINCE THAT ROUTINE IS ONLY CALLED HLT 30B FOR MASTER DATA SET LDA ISTAT+2 GET KEY ITEM # JSB GITLN GET ITEM LEN JMP KYITM,I SPC 1 GIT#L NOP GET ITEM # & LEN FROM ITEM NAME STA GTM#3 SET ITEM NAME ADDR LDA A,I GET FIRST CHAR. OR NUM. STA ISTAT+1 ADA DM256 IS IT ALREADY SSA A NUMBER ? JMP GTM#7 YES, SKIP THE DBINF JSB DBINF ITEM NAME ---> ITEM # DEF *+5 DEF I TYPE DEF D5 MODE GTM#3 NOP ITEM NAME DEF ISTAT STATUS JSB ERR? OK ? GTM#7 LDA ISTAT+1 GET ITEM # JSB GITLN RETREIVE ITEM LENGTH JMP GIT#L,I * DM256 DEC -256 SPC 1 GITLN NOP GET ITEM LENGTH STA ITEM# SAVE ITEM # JSB DBINF ITEM # ---> ITEM LENGTH DEF *+5 DEF I TYPE DEF D2 MODE DEF ITEM# ITEM NUMBER DEF ISTAT STATUS JSB ERR? OK ? LDA ISTAT+6 GET ITEM LENGTH STA ITMLN JMP GITLN,I SPC 2 SAVRT NOP SAVE RUN TABLE INFORMATION JSB DBINF SAVE RUN TABLE DEF *+5 DEF S TYPE DEF D6 MODE DEF DS# DATA SET NUMBER DEF BTEMP+2 BUFFER LDA BTEMP+2 RECALL STATUS JSB .ERR? OK ? * LDA DS# SAVE DATA-SET # STA BTEMP+2 JMP SAVRT,I SPC 1 RSTRT NOP RESTORE RUN TABLE LDA BUF+3 RECALL DATA SET # SAVED CPA DS# SAME DATA SET ? CLB,RSS YES, RESTORE RUN TABLE JMP RSTRT,I NO, EXIT * STB BUF+3 JSB DBINF RESTORE THE RUN TABLE DEF *+5 DEF R TYPE: RESTORE RUN TABLE DEF D6 MODE DEF DS# DATA SET NUMBER DEF BUF+3 BUFFER LDA BUF+3 RECALL STATUS JSB .ERR? OK ? LDA DS# RESTORE INITIAL MAIL BOX BUFFER STA BUF+3 FOR LOCK ALGORITM ! ISZ RSTRT RETURN OK (P+2) JMP RSTRT,I SPC 1 S ASC 1,S R ASC 1,R I ASC 1,I D. OCT 104 SPC 2 PSAM NOP PUT MAIL BOX INTO SAM DST PARM1 SET PARAMETERS LDA PSAM,I GET BUFFER ADDR STA PSAM2 ISZ PSAM JSB EXEC CALL I/O WRITE@/READ DEF *+8 DEF D20 WRITE/READ REQUEST DEF D0 DUMMY LU PSAM2 NOP BUFFER ADDR DEF PSAM,I BUFFER LENGTH DEF PARM1 DEF PARM2 DEF CLAS# CALL I/O WORD SZA HLT 40B ISZ PSAM SET RETURN ADDR JMP PSAM,I SPC 2 GSAM NOP IOR BIT15 SET NO-WAIT BIT STA TEMP JSB EXEC CLASS I/O GET DEF *+7 DEF NAB21 GET NO-ABORT DEF TEMP CLASS I/O WORD DEF SCODE BUFFER ADDR DEF RBULN BUFFER LENGTH DEF PARM1 DEF PARM2 CCA ABORT RETURN, NOTHING HAS BEEN GET JMP GSAM,I RETURN OK * NAB21 OCT 100025 SPC 2 GTCLW NOP ALLOCATED A CLASS I/O CLA WHEN OWNER CLASS I/O WILL BE RELEASE STA GTCLX THIS SUBROUTINE WILL BE REPLACED JSB EXEC BY THE SYSTEM ROUTINE. DEF *+5 THE CLASS MUST BE OWNED BY THE CALLING PROGRAM DEF D19 SO THE ABORT PROCEDURE WILL BE EASIER DEF D0 I.E.: THE PROGRAM WILL BE ABORTED DEF * AND HOPFULLY THE CLASS I/O RELEASED. DEF GTCLX LDA GTCLX IOR B20K SET BIT13 'DO NOT DEALLOACATE' STA GTCLX JSB EXEC DEF *+5 DEF D21 DEF GTCLX DEF * DEF D0 LDA GTCLX JMP GTCLW,I * GTCLX NOP B20K OCT 20000 D19 DEC 19 SPC 1 KLCLX NOP STA KLCL3 SAVE CLASS I/O WORD JSB KLCLS RELEASE THE CLASS DEF *+2 DEF KLCL3 SZA OK ? HLT 50B JMP KLCLX,I * KLCL3 NOP HED *** LOCKING MEGHANISM *** * FORMAT OF THE BUFFER USED IS AS FOLLOW: * SPC 2 * * 15 9 8 7 6 0 * ADDRESS ******************************** * L * PIDX * * DS # *<--- LOCTB (PT) * ! O * B<:6RECORD # * * ! C ******************************** * ! K --->* PIDX *W * DS # * [W] BIT IS THE * ! ! * RECORD # * 'SOMEONE WAITING' * ! T ! ******************************** * ! A ! * .... .... * FREE ENTRY * ! B ! * 0 * * ! + L ! ******************************** * ! E ! * .... .... * * ! ! * .... .... * * ! ! ******************************** * ! ! * *<--- LOCTE * ! ! * * * ! ! . . * \ ! / ! . . * \!/ ! * . ! * ! * ! . . * P ! * *<--- PROTE <* R ! ******************************** * O ! *1* LINK IN RESTART QUEUE * PROCESS IN * C ! * CLASS I/O WORD * RESTART QUEUE * E ! *X* # OF RECORDS LOCKED * * S ! ******************************** * S ----+ POINTER TO LOCK TABLE * PROCESS WAITING * * CLASS I/O WORD * ON A RECORD * D *X* # OF RECORDS LOCKED * * I ******************************** * R * 0 * * E * 0 * * C *X* # OF RECORDS LOCKED *<--- PROTB (PIDPT) * T ******************************** * O * R X FLAG SET WHEN PID IS ALLOCATED * Y AND CLEAR WHEN PID IS DEALLOACTED * * SPC 2 * PIDX IS THE PROCESS ID INDEX IN PROCESS DIRECTORY * * PIDPT IS THE PROCESS ID POINTER INTO THE PROCESS DIRECTORY SKP * LOCK PERFORM ALL LOCKING/UNLOCKING FUNCTION * * CALLING SEQUENCE: * LDA MODE (IDENTIFY IMAGE FUNCTION PERFORMED) * JSB LOCK * RETURN ONLY IF FUNCTION IS CORRECTLY PERFORMED. * * IF AN ERROR IS FOUND OR IF THE PROCESS NEED TO BE SUSPENDED * EXIT IS DONE DIRECTLY. (NO RETURN TO CALLING PRG) SPC 1 LOCK NOP STA LOCKM SAVE MODE * LDA LOCKW GET FUNCTION TO BE PERFORMED AND D3 MASK BIT 0 & 1 - LOCK & UNLCK BIT SZA,RSS ANY FUNCTION REQUESTED ? JMP LOCK,I NO, RETURN TO CALLER SPC 1 JSB SPIDD ACCESS PROCESS ID DIRECTORY RSS PID WAS NOT DEFINED, AND UNLOCK IS REQUESTED ! JMP LCK20 PID IS OK, CONTINUE THE LOCKING/UNLOCKING PROCESS SPC 1 LDA LOCKM LOCKID WAS NOT DEFINED, CHECK THOE RQ CPA D5 DBPUT ? RSS YES, CHECK THE FILE TYPE JMP LCKE4 NO, IMAGE ERROR # 404 LDA DSTYP IT IS A PUT, RECALL THE DATA-SET TYPE CPA D. PUT IN A DETAIL DATA-SET ? JMP LOCK,I YES, IT IS OK, FORGET THE UNLOCK JMP LCKE5 NO, PUT IN A MASTER, THE ENTRY MUST HAVE BEEN LOCKED SPC 1 LCK20 CLA INIT ITEM LENGTH TO ZERO STA ITMLN USED ONLY IN CASE OF SUSPEND * LDB BTEMP+8 RECALL USER'S CALL IMAGE STATUS LDA LOCKM RECALL MODE CPA D4 KEYED READ ? JMP LCK40 YES, PERFORM KEYED CALL LOCK CPA D5 NO, DBPUT REQUEST ? JMP LCK50 YES, CPA D6 NO, DBUPD/DBDEL REQUEST ? JMP LCK50 YES SZB IMAGE ERROR ? JMP LOCK,I YES, FORGET THE LOCK SZA,RSS DBFND CALL ? JMP LCK13 YES, LOCK NEXT RECORD ONLY LDB BTEMP+9 NO, LOCK CURRENT RECORD STB REC# JSB LKX00 ACCESS LOCK TABLE LDA LOCKM RECALL MODE CPA D1 CHAIN READ REQUEST JMP LCK15 YES, LOCK NEXT RECORD IN CHAIN JMP LOCK,I NO, EXIT * LCK13 LDA .BF12 RECALL ITEM NAME ADDR TO RETREIVE JSB GIT#L ITEM LENGTH (USED IN CASE OF SUSP.) LCK15 LDB BTEMP+11 LOCK NEXT RECORD IN CHAIN SZB END OF CHAIN ? JMP LCK57 NO, LOCK THE RECORD JMP LOCK,I YES, RETURN SPC 1 LCK40 LDA .BF13 GET KEY VALUE ADDR SZB,RSS USER'S IMAGE STATUS OK ? JMP LCK51 YES, PROCESS LOCK CPB =D107 NO, IS IT ENTRY NOT THERE ? JMP LCK51 YES, PROCESS LOCK IN ADVANCE JMP LOCK,I NO, FORGET THE LOCK SPC 1 LCK50 LDB DSTYP GET THE DATA-SET TYPE CPB D. DETAIL DATA-SET ? JMP LCK60 YES, CHECK IMAGE CALL LDB BUF+7 NO, MASTER DATA SET, RECALL PRIMARY REC # CPA D6 DBPUT REQUEST ? JMP LCK57 NO, DBUPD/DBDEL RQ, RE C# WAS IN THE SAVED RUN TBL LDA XDBP3 YES, COMPUTE THE REC# FROM THE KEY VALUE LCK51 STA LCK53 SET KEY VALU ADDR FOR HASHING ROUTINE JSB KYITM RETREIVE KEY ITEM CHARACTERISTIC JSB HASH RETREIVE RECORD NUMBER OF DEF *+3 PRIMARY ENTRY FOR THAT KEY VALUE LCK53 NOP KEY ITEM VALUE DEF ITMLN KEY ITEM LENGTH CLB DIV CAPAC DIVIDE BY FILE SIZE INB STB BTEMP+6 SAVE REC# IN PLACE OF REC# OF FOOT IN SAVED RUN TBL LCK57 STB REC# RECORD NUMBER OF PRIMARY ENTRY JSB LKX00 ACCESS LOCK TABLE JMP LOCK,I AND RETURN SPC 1 LCK60 LDB BUF+4 DETAIL DATA SET, RECALL REC # FROM SAVED RUN TBL CPA D6 DBPUT REQUEST ? JMP LCK57 NO, PERFORM THE LOCK JMP LOCK,I YES, EXIT SPC 2 * ACCESS OF THE LOCK TABLE, AND UPDATE OF THE * LOCK TABLE TO REFLECT THE LOCK/UNLOCK FUNCTION. * * PRIOR CALLING THIS FUNCTION, SET UP THE FOLLOWING: * PIDPT, REC#, DS#, PIDX SPC 1 LKX00 NOP * JSB SLTBL SEARCH IN LOCK TABLE JMP LKX50 RECORD IS NOT LOCKED JMP LKX70 RECORD IS LOCKED LDA LOCKW RECORD IS LOCKED BY THE CALLING PROCESS * AND D3 ISOLATE LOCK/UNLCK BITS CPA D3 IS IT UNLCK-LOCK REQUEST ? JMP LKX00,I YES, LEAVE IT AS IT IS RAR,SLA UNLOCK REQUESTED ? RSS YES JMP LKX00,I NO, RETURN TO CALLER * JSB UNLCK YES, PERFORM THE UNLOCK FUNCTION JMP LKX00,I AND EXIT SPC 1 * ADD AN ENTRY IN THE LOCK TABLE. * LKX50 LDA LOCKW RECALL LOCK WORD SLA,RSS LOCK REQUESTED ? JMP LKX00,I NO, RETURN TO CALLER LDA PIDX YES, ADD AN ENTRY IN THE LOCK TABLE ALF,ALF IOR DS# MERGE PID INDEX WITH DATA SET # LDB PTHOL GET ADDR OF LAST EMPTY ENTRY STA B,I TO STO:RE IT INTO THE TABLE INB LDA REC# SAVE ALSO RECORD NUMBER STA B,I INTO THE TABLE INB LDA PTHOL WAS IT AT THE CPA LOCTE END OF THE LOCK TABLE ? STB LOCTE YES, UPDATE END OF LOCK TABLE ISZ PIDPT,I INCREMENT # OF RECORD LOCKED JMP LKX00,I AND RETURN TO CALLER SPC 2 * SUSPEND CALLING PROCESS IF IT IS A LOCK REQUEST * WITH WAIT OPTION AND NO DEADLOCK OCCURS. * LKX70 LDB LOCKW RECALL LOCK WORD RBR,SLB,RBL UNLOCK REQUESTED ? JMP LCKE3 YES, ERROR # 403 LDA =D400 NO WAIT ERROR = 400 SSB NO WAIT REQUEST ? JMP SIMST YES, RETURN ERROR# 400 TO USER IN IMAGE ST * LDA PT,I RETREIVE IF THERE IS A DEADLOCK CONDITION LKX72 ALF,ALF ISOLATE OWNER OF THE RECORD AND =B377 CPA PIDX IS OWNER IS THE CALLING PROCESS ? (ALWAYS FAIL 1ST TIME) JMP LCKE1 YES, DEADLOCK CONDITION, ERROR # 401 CMA,INA NO, CHECK IF THE OWNER IS SUSPENDED INA MPY D3 RETREIVE POINTER ON A RECORD FROM ADA PROTB THE PROCESS ID DIRECTORY ADA DM2 TO ACCESS POINTER LDB A,I GET POINTER TO RECORD LOCK TABLE LDA B,I GET RECORD OWNER-DS# FROM LOCK TABLE SZB,RSS PROCESS SUSPENDED ? JMP LKX74 NO, PROCEED WITH THE SUSPEND SSB,RSS CHECK IF IN RESTART QUEUE, IF YES SKIP JMP LKX72 NOT RST. QUEUE, IT IS SUSP., TRACK DOWN ONE MORE * LKX74 LDA ITMLN RECALL ITEM LENGTH TO SAVE ADA D19 INTO SAM THE EXACT LENGTH (19+ITEMLN) STA LKX77 SET BUFFER LEN JSB PSAM SEND BUFFER INTO SAM DEF SCODE BUFFER ADDR LKX77 NOP BUFFER LENGTH * LDA CLAS# OK, SUSPEND THE CALLING PROCESS LDB PIDPT SAVE CLASS I/O INTO THE PID DIRECTORY ADB DM1 STA B,I ADB DM1 UPDATE POINTER LDA PT  AND SAVE POINTER TO RECORD LOCK TABLE STA B,I INTO THE DIRECTORY LDA PT,I RECALL THE RECORD LOCK ENTRY IOR =B200 TO SET 'SOMEONE IS WAITING' BIT STA PT,I JMP EXIT3 EXIT WITHOUT DOING THE IMAGE CALL SPC 2 LCKE3 LDA =D403 ERROR # 403, UNLCK REC. LOCKED BY AN OTHER JMP SIMST GO SET IMAGE STATUS * LCKE4 LDA =D404 ERROR # 404, UNLCK REC. WITHOUT A LOCK ID JMP SIMST GO SET IMAGE STATUS * LCKE5 LDA =D405 ERROR # 405, PUT IN A MASTER WITHOUT LOCK ID JMP SIMST * LCKE1 LDA =D401 DEADLOCK ERROR = 401 JMP SIMST GO SET IMAGE STATUS SPC 1 REC# NOP .BF13 DEF BUF+13 SPC 3 * UNLOCK: CLEAR AN ENTRY IN THE LOCK TABLE * OR RESTART A WAITING PROCESS AND GIVE THAT * ENTRY TO THIS WAITING PROCESS. * * THE ADDRESS OF THE ENTRY CLEARED OR PASSED IS IN PT * UNLCK NOP LDA PT,I RECALL THE ENTRY FROM THE LOCK TABLE AND =B200 ISOLATE 'SOMEONE IS WAITING' BIT SZA,RSS SOMEONE WAITING ? JMP UNLC8 NO, CLEAR ENTRY * CLA YES, SEARCH WHICH ONE IS WAITING STA TEMP INIT # OF WAITERS COUNTER LDA PROTB SEARCH IN DIRECTORY UNLC4 CPA PROTE END OF DIRECTORY ? JMP UNLC5 YES, GOTO CLEAR ENTRY ADA DM2 TO GET POINTER FROM THE DIRECTORY LDB A,I GET POINTER TO LOCK TABLE ADA DM1 BUMP POINTER IN THE DIRECTORY CPB PT IS IT ONE OF THE WAITERS ? RSS YES JMP UNLC4 NO, LOOP UNTIL END STA TEMP1 SAVE DIRECTORY ADDR OF THE WAITER ISZ TEMP COUNT THE # OF WAITER JMP UNLC4 AND LOOP UNTIL END SPC 1 * GIVE THE ENTRY TO ONE OF THE WAITERS AND * RESTART IT. * UNLC5 LDA TEMP GET # OF WAITERS SZA,RSS MUST BE AT LEAST ONE HLT 65B !!!!!!!!'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ISZ TEMP1 ADDR OF THE POINTER TO LOCK TABLE LDB RSTAR GET RESTART QUEUE HEAD ULC52 LDA B,I GET NEXT ELEMENT OF THE QUEUE SZA,RSS END OF QUEUE ? JMP ULC54 YES, ADD THE NEW ONE RAL,CLE,ERA NO, CLEAR BIT 15 AND LDB A GO GET NEXT ONE JMP ULC52 * ULC54 STA TEMP1,I SET NEW END OF QUEUE LDA TEMP1 SET BIT15 IN THE ADDR TO INDICATE IOR BIT15 LINK INTO THE RESTART QUEUE INSTEAD OF STA B,I POINTER TO LOCK TABLE. LDB TEMP1 RECALL ADDR INTO THE PROCESS DIRECTORY ADB D2 TO ACCESS THE # OF RECORD LOCKED ISZ B,I INCREMENT # OF RECORDS LOCKED JSB SPIDX COMPUTE THE PIDX OF THE WAITER ALF,ALF ROTATE IT INTO UPPER BYTE STA TEMP1 AND SAVE IT LDA PT,I GIVE THIS RECORD TO THE WAITER AND =B377 CLEAR OLD PIDX IOR TEMP1 AND PUT THE NEW ONE LDB TEMP RECALL # OF WAITERS CPB D1 ONLY ONE WAITERS ? AND =B177577 YES, CLEAR BIT [W] STA PT,I AND STORE IT BACK JMP UNLC9 SPC 1 * DELETE AN ENTRY IN THE LOCK TABLE. * UNLC8 LDB PT CLEAR THE ENTRY IN THE LOCK TABLE STA B,I INB STA B,I * UNLC9 LDA PIDPT,I ADA DM1 DECREMENT # OF RECORD OWNED BY THE STA PIDPT,I CURRENT PROCESS JMP UNLCK,I AND EXIT SPC 5 * SEARCH IN THE PROCESS ID DIRECTORY * * CALLING SEQUENCE: * JSB SPIDD * RETURN P+1 - UNLOCK REQUEST AND NO LOCK ID IS DEFINED !! * RETURN P+2 - OLD OR NEW PID * * ON RETURN P+2, PIDPT & PIDX ARE SET UP SPC 1 SPIDD NOP SEARCH IN PROCESS ID DIRECTORY LDA LCKID RECALL PID FORM USER BUFFER STA PIDX SET PID SZA IS PID DEFINED ? JMP SPID4 YES, SETUP PIDPT LDA LOCKW NO, RECALL LOCK WORD RAR,SLA UNLOCK REQUEST ? JMP SPIDD,I YES, ERROR * LDB PROTB GET START OF PROCESS ID DIRECTORY SPID2 CPB PROTE END OF DIRECTORY ? JMP SPID3 YES, SETUP NEW PID LDA B,I GET # OF RECORD LOCKED SZA,RSS PID FREE HERE ? JMP SPID3 YES ADB DM3 NO, GO TO NEXT ENTRY JMP SPID2 CONTINUE * SPID3 STB PIDPT INIT PIDPT JSB SPIDX COMPUTE PIDX STA PIDX SET PID (FIRST IS ONE) STA LCKID SET IT THERE IN CASE OF SUSPEND LDB PIDPT RESTORE B TO LDA BIT15 INIT THE PROCESS ID DIRECTORY STA B,I SET # OF REC. LCK ADB DM1 CLA STA B,I SET CLASS I/O WORD ADB DM1 STA B,I SET POINTER TO LCK TABLE LDA PIDPT WAS IT A NEW PID CPA PROTE ADDED AT THE END ? RSS YES, UPDATE END OF DIRECTORY JMP SPID5 NO, RETURN OK ADB DM1 YES, UPDATE B AND STB PROTE SET NEW END OF PROCESS ID DIREC. JSB PACK PACK LOCK TABLE IF NECESSARY JMP SPID5 AND RETURN OK * SPID4 STA BTEMP RETURN PID TO THE USER CMA,INA CALCULATE THE PID POINTER INA MPY D3 ADA PROTB STA PIDPT SET PID POINTER SPID5 ISZ SPIDD JMP SPIDD,I AND RETURN OK SPC 3 SPIDX NOP CMB,INB ADB PROTB COMPUTE CLA DIRECTORY INDEX SWP DIV D3 INA JMP SPIDX,I EXIT WITH A=PIDX SPC 2 * SEARCH IN RECORD LOCK TABLE * * CALLING SEQUENCE: * PRIOR CALLING THIS FUNCTION, SET UP THE FOLLOWING: * REC#, DS#, PIDX * JSB SLTBL * RETURN P+1 - RECORD NOT LOCKED * RETURN P+2 - RECORD IS LOCKED BY AN OTHER PROCESS * RETURN P+3 - RECORD IS LOCKED BY THE CALLING PROCESS * * ON RETURN P+2 & P+3, THE ADDRESS OF THE ENTRY ACCESSED ݌ * IS SAVED INTO PT, AND THE ADDRESS OF * THE LAST EMPTY ENTRY IN THE LOCK TABLE * IS SAVED INTO PTHOL SPC 2 SLTBL NOP SEARCH IN LOCK TABLE LDA REC# CHECK THAT REC# IS NEVER NUL (0) SZA,RSS HLT 67B LDA LOCTE INIT LAST EMPTY ENTRY IN LOCK TABLE STA PTHOL WITH THE END OF TABLE LDA LOCTB GET FIRST ADDR OF LOCK TABLE * SLTL2 STA PT CPA LOCTE END OF LOCK TABLE ? JMP SLTBL,I YES, EXIT P+1 (RECORD IS FREE) DLD PT,I GET LOCK ENTRY CPB REC# IS IT THE SAME RECORD RSS YES, JMP SLTL4 NO, GO GET NEXT RECORD AND =B77 MASK OUT DATA SET # CPA DS# IS IT THE SAME DATA-SET ? RSS YES JMP SLTL4 NO, GO GET NEXT ENTRY LDA PT,I RECALL FIRST WORD OF THE LOCK ENTRY ALF,ALF AND ISOLATE THE PID AND =B377 CPA PIDX RECORD OWNED BY THE SAME PROCESS ? ISZ SLTBL YES, EXIT P+3 (RECORD BELONG TO CALLING PROCESS) ISZ SLTBL NO, EXIT P+2 (RECORD LOCKED BY SOMEONE ELSE) JMP SLTBL,I * SLTL4 LDA PT GO TO NEXT ENTRY SZB,RSS IS THAT ENTRY EMPTY ? STA PTHOL YES, UPDATE LAST EMPTY ENTRY IN THE LOCK TABLE ADA D2 JMP SLTL2 CONTINUE SPC 2 PIDPT NOP PID DIRECTORY POINTER PIDX NOP PID DIRECTORY INDEX PT NOP PTHOL NOP LAST EMPTY ENTRY IN THE LOCK TABLE * LOCTB NOP FWA OF LOCK TABLE LOCTE NOP LWA OF LOCK TABLE PROTB NOP FWA OF DIRECTORY (DIRECTORY IS BACKWARD) PROTE NOP LWA OF DIRECTORY LOCKM NOP SPC 3 * THIS PROGRAM PACKS THE LOCK TABLE SPC 1 PACK NOP LDB LOCTE CHECK IF PACK IS NEEDED ADB D6 CMB,INB ADB PROTE SSB,RSS NEEDED ? JMP PACK,I NO, RETURN IMM؂EDIATELY * LDA LOCTB YES, GET START ADDR OF LOCK TABLE STA PACKA INIT FROM POINTER STA PACKB INIT TO POINTER * PACK2 LDA PACKA CHECK FOR END OF TABLE CPA LOCTE END OF TABLE ? JMP PACK8 YES DLD PACKA,I GET AN ENTRY SZA,RSS ENTRY HERE ? JMP PACK4 NO, ENTRY EMPTY PACK3 DST PACKB,I YES, STORE IT BACK AND =B200 MASK OUT SOMEONE IS WAITING BIT SZA,RSS IS SOMEONE WAITING ? JMP PACK7 NO, FORGET DIRECTORY BUSINESS * LDA PROTB YES, UPDATE DIRECTORY CONTENT PACK6 CPA PROTE TO REFLECT THE CHANGE JMP PACK7 IT IS THE END OF DIRECTORY ADA DM2 TO GET LOCK TABLE POINTER LDB A,I GET POINTER ADA DM1 CPB PACKA DIRECTORY REFERS TO THE MODIFIED ONE ? INA,RSS YES, MODIFY DIRECTORY JMP PACK6 NO, CONTINUE LDB PACKB SET NEW POINTER VALUE STB A,I INTO THE DIRECTORY ADA DM1 JMP PACK6 CONTINUE * PACK7 ISZ PACKA BUMP POINTERS TO LOCK TABLE ISZ PACKA ISZ PACKB ISZ PACKB JMP PACK2 AND LOOP UNTIL END OF LOCK TABLE * PACK4 ISZ PACKA SKIP THE EMPTY SPACE ISZ PACKA LDA PACKA CHECK FOR END OF TABLE CPA LOCTE END OF LOCK TABLE ? JMP PACK8 YES DLD PACKA,I GET ENTRY SZA,RSS ENTRY EMPTY ? JMP PACK4 YES, LOOP ON EMPTY ENTRY JMP PACK3 NO, STORE ENTRY AND UPDATE DIRECTORY SPC 1 PACK8 LDA PACKB SET UP NEW END OF LOCK TABLE CPA LOCTE ONE HOLE FOUND ? JMP PACK9 NO FATAL ERROR STA LOCTE YES, SET NEW END OF LOCK TABLE JMP PACK,I * PACK9 LDA =D397 ERROR LOCK TABLE OVERFLOW JMP SIMST GO SET IMAGE STATUS SPC 1 PACKA NOP PACKB NOP HED CONSTANTS & VARAIBLES DM3 DEC -3 DM2 DEC -2 DM1 DEC -1 D0 DEC 0 D1 DEC 1 D2 DEC 2 D3 DEC 3 D4 5<:6DEC 4 D5 DEC 5 D6 DEC 6 D20 DEC 20 D21 DEC 21 * BIT15 OCT 100000 SPC 1 TEMP NOP TEMP1 NOP PARM1 NOP PARM2 NOP SPC 1 C.TAB DEF *+1,I DEF XDBOP 0 - DBOPN DEF XDBCL 1 - DBCLS DEF XDBGE 2 - DBGET DEF XDBFN 3 - DBFND DEF XDBPU 4 - DBPUT DEF XDBUP 5 - DBUPD DEF XDBDE 6 - DBDEL DEF XDBIN 7 - DBINF DEF XTBUL 8 - TBULK HED BUFFERS USE TO COMMUNICATE WITH THE USER PROGRAM * DO NOT DISTURB NEXT LOCATIONS * SCODE NOP BUFFER USED TO GET THE REQUEST ECLAS NOP PARM BSS 2 BUF BSS 389 (1+1+2+389=393) SPC 3 ERCOD BSS 2 BUFFER USED TO SEND THE ANSWER BTEMP BSS 269 (2+269=271) SPC 2 LOCKW EQU BUF LCKID EQU BUF+1 SPC 3 UNS * ORG * DEFINE LAST LOCATION END YQ< $ 92903-18112 1805 S C0122 &DBCRC              H0101 |qFTN4 SUBROUTINE DBCRC(NAME,JCRC,JTMLN,JENLN .,ISTAT),92903-16100 REV.1805 780210 C C C NAME: DBCRC C SOURCE: &DBCRC 92903-18112 C BINARY: %DBCRC ----NONE--- PART OF %TMSLB 92903-16100 C C PRMG: FRANCOIS GAULLIER HPG C C C ************************************************************** C * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * C ************************************************************** C C C ********************************************************************* C * * C * THIS SUBROUTINE RETURN THE DATA-BASE-CRC AND THE * C * MAXIMUM ENTRY & ITEM LENGTH. * C * * C * CALLING PARAMETERS : * C * * C * NAME : 3 WORDS LONG BUFFER * DATA BASE NAME * C * ICRC : CRC IS RETURN HERE * C * ITMLN : MAXIMUM ITEM LENGTH IS RETURN HERE (WORDS) * C * ENTLN : MAXIMUM ENTRY LENGTH IS RETURN HERE (WORDS) * C * ISTAT : IF 0 SUCCESFULL OPERATION * C * NOT 0 IMAGE ERROR IN ISTAT * C * * C * THE DATA-BASE-CRC IDENTIFY EXACTLY A SCHEMA, ATTACHED TO * C * A TRANSACTION SPECIFICATION, IT ALLOWS TO CHECK IF THE SCHEMA * C * HAS BEEN CHANGED. THE CAPACITY, THE WRITE/READ LEVEL CAN BE * C * CHANGED WHITOUT ANY PROBLEM. r * C * * C * THE MAXIMUM CARACTERISTIQUE ARE ASSUMED AS FOLLOW: * C * * C * MAXIMUM NUMBER OF DATA-SET / DATA BASE : 50 * C * MAXIMUM NUMBER OF ITEM / DATA BASE : 255 * C * MAXIMUM NUMBER OF ITEM / ENTRY : 127 * C * * C * MAXIMUM ENTRY LENGTH (MEDIA+DATA) 256 WORDS * C * MAXIMUM ITEM LENGTH 63 WORDS * C * * C ********************************************************************* C C DIMENSION IBUF(12) C C INITIALISE C ICRC=0 MITMLN=0 MENTLN=0 CALL CRC16(NAME,6,ICRC) C C COMPUTE ITEM CHECSUM C DO 100 I=1,255 CALL DBINF(2HI ,2,I,IBUF) IF(IBUF.EQ.125) GO TO 110 IF(IBUF.NE.0) GO TO 3000 IF(IBUF(7) .GT. MITMLN) MITMLN=IBUF(7) CALL MOVEW(IBUF(2),IBUF(1),8) CALL MOVEW(IBUF(6),IBUF(5),3) CALL CRC16(IBUF,14,ICRC) 100 CONTINUE 110 NIT=I-1 C C DATA SETS AND LINK CHECKSUM WORD C DO 200 I=1,50 CALL DBINF(2HS ,2,I,IBUF) IF(IBUF.EQ.100) GO TO 230 IF(IBUF.NE.0) GO TO 3000 IF(IBUF(7) .GT. MENTLN) MENTLN=IBUF(7) CALL MOVEW(IBUF(2),IBUF(1),6) IBUF(5)=IBUF(6) IBUF(4)=IAND(IBUF(4),377B) CALL CRC16(IBUF,10,ICRC) C-----IF MASTER DATA SET, SAVE ALSO THE PATH DEFINITION IF(IBUF(4).EQ.104B) GO TO 200 CALL DBINF(2HS ,4,I,IBUF) IF(IBUF.NE.0) GO TO 3000 CALL CRC16(IBUF(3),4*IBUF(2),ICRC) 200 CONTINUE C C RETURN RESULT TO THE USER C 230 JCRC=ICRC JTMLN=MITMLN JENLN=MENTLN ISTAT=0 GO TO 3010 C 3000 ISTAT=IBUF 3010 RETURN END l END$   92903-18113 1805 S C0122 &ETMSP              H0101 FTN4 SUBROUTINE ETMSP(IPAR1,IPAR2),92903-16100 REV.1805 771212 C C C NAME: ETMSP C SOURCE: &ETMSP 92903-18113 C BINARY: %ETMSP ----NONE--- PART OF %TMSLB 92903-16100 C C PRMG: FRANCOIS GAULLIER HPG C C C ************************************************************** C * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * C ************************************************************** C C C ********************************************* C * CALL ETMSP(IPAR1,IPAR2) * C * * C * IPAR1: BUFFER CONTAINING NAME OF THE * C * APPLICATION TO ABORT. * C * IPAR2: TYPE OF ABORT: SOFT OR HARD. * C * - 98 OR <0 --> SOFT STOP, * C * TIME=5MN IF 98 OR -IPAR2 IF <0 * C * - ANY OTHER VALUE --> HARD STOP * C * * C * THIS CALL WILL STOP THE TMS APPLICATION * C * IF RUNNING. * C * IF NOT RUNNING, NOTHING HAPPENS. * C ********************************************* C C DIMENSION NAME(3) LOGICAL DORMT DATA NAME/2HL ,2H ,2H / C CALL MOVCA(IPAR1,1,NAME,2,4) IF(IDGET(NAME).EQ.0) RETURN IF(IDGET(IPAR1).EQ.0) RETURN J=98 K=5 IF(IPAR2.EQ.98) GOTO 5 K=-IPAR2 IF(K .GT. 0) GOTO 5 J=99 5 CALL EXEC(23,NAME,J,K,0,0,-1) 10 IF( DORMT(IPAR1) ) RETURN CALL EXEC(12,0,1,0,-50) GOTO 10 END END$     92903-18201 1805 S C0122 &DCMON              H0101 zFTN4 PROGRAM DCMON(3,50),92903-16200 REV.1805 780522 C C C NAME: DCMON DATACAP MONITOR PROGRAM C SOURCE: &DCMON 92903-18201 C BINARY: %DCMON ----NONE--- PART OF RDCMON 92903-16200 C C PGMR: DANIEL POT/FRANCOIS GAULLIER HPG C C C ************************************************************** C * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * C ************************************************************** C C C **************************************************************** C * * C * THIS PROGRAM IS SCHEDULED EACH TIME ONE OF THE F2, F3, F5 * C * F6, F7 OR F8 SOFT KEY ON THE 2645/2648 CRT TERMINAL IS * C * USED. * C * THOSE SOFT KEY ARE LOADED LIKE THIS BY 'DCMON' IN THE * C * SUBROUTINE 'DCSFK'. * C * THIS PROGRAM IS ALSO SCHEDULED EACH TIME ONE THE DATACAP * C * PROGRAM (I.E.: TGP, TMPGN, TMP ) TERMINATES IN ORDER TO * C * RESTORE THE SOFT KEY FOR THE NEXT TASK THAT THE USER WILL * C * REQUEST. * C * * C * INTEGER DCMON, DATA DCMON/2HDC,2HMO,2HN / * C * CALL EXEC(100030B,DCMON,LU) * C * GOTO XXX DCMON IS NO RP'ED * C * RETURN OK: DCMON HAS BEEN SCHEDULED. * C * * C * :RU,DCMON,,P1 * C * k * C * P1 FUNCTION PARAMETER * C * * C * P1 = 0 -------> LOAD SOFT KEY AND PRINT * C * THEIR FUNCTIONS. * C * P1 = 1 -------> RU,TMPX * C * P1 = 2 -------> RU,LTMPX,,TSE * C * P1 = 3 -------> CALL ETMSP(TMPX,99) * C * P1 = 4 -------> TMP COPY STATUS * C * P1 = 5 -------> ABORT ALL TMP COPIES * C * * C * TMP COPY NUMBER X WILL BE ASKED ON THE CRT, AND THE * C * REQUESTED WILL BE PERFORMED. * C * * C **************************************************************** C C DIMENSION IPARM(5),IMESA(30),TMPX(3),LTMPX(3),PARM(4) DIMENSION TSE(3),COMAD(35),ON(2),CRLF(2),RETUN(13),EROR(8) DIMENSION BADCH(16),BUSY(19),BUSI(16),NOVA(17),MBUFR(50) DIMENSION IDCB(144),NAME(3),IDZVG(18),ITRO(2) DIMENSION NUMO(6),IREG(2),DRCTY(128),IPOB(3),IBORT(33) INTEGER TMPX,PARM,TSE,COMAD,ON,CRLF,RETUN,EROR,BADCH INTEGER BUSY,BUSI,OPEN,READF,AREG,BREG,DRCTY EQUIVALENCE (REG,IREG,AREG),(IREG(2),BREG) LOGICAL ISBTW C C-----FIXED CHARACTER STRINGS C C-----PROGRAM NAMES C DATA TMPX/2HTM,2HP ,2H / DATA TSE/2HTS,2HE ,2H / DATA LTMPX/2HLT,2HMP,2H / DATA MAXCOP/3/ DATA ON/2HON,2H, / DATA ICRTG/0/ DATA IDZVG/2H;;,2H;;,2H;;,2H;;,2H;;,2H;;,2H;;,2H;;,2H;;,2H;;, .2H;;,2H;;,2H;;,2H;;,2H;;,2H;;,2H;;,2H;;/ DATA NUMO/15446B,62116B,20040B,20033B,23144B,40040B/ DATA ITRO/20016B,20017B/ C C-----FORMAT MODE OFF, MEMORY UNLOCK, BLOCK MODE OFF, UNLOCK KEYBOARD C-----HOME UP CURSOR, CLEAR DISPLAY, REVERSE VIDEO C-----" TMP COPY # : ", NORMAL VIDEO, 2*BACKSPACE, INHIBIT C DATA IMESA/15530B,15555B,15446B,65460B,41040B,15542B,15510B, .15512B,15446B,62102B,2H T,2HMP,2H C, .2HOP,2HY ,2H# ,2H: ,20040B,15446B,62100B,15504B,15504B,15504B, .20137B/ DATA IBORT/15530B,15555B,15446B,65460B,41040B,15542B,15510B, .15512B,15446B,62102B,40B, .2HO.,2HK ,2HTO,2H S,2HTO,2HP ,2HAL,2HL ,2HTM,2HP ,2H? ,2H(Y, .2H/N,2H) ,2H: ,20040B,15446B,62100B,15504B,15504B,15504B, .20137B/ DATA CRLF/6412B,6412B/ DATA RETUN/6412B,6412B,20040B,2HPR,2HES,2HS ,15446B,62113B, .2HRE,2HTU,2HRN,15446B,62100B/ DATA EROR/15446B,62103B,2HER,2HRO,2HR!,15446B, .62100B,20040B/ DATA BADCH/2HBa,2Hd ,2Han,2Hsw,2Her,2H. ,15510B,15446B, .60453B,30464B,41537B,15510B,15446B,60453B,31461B,41537B/ DATA BUSY/2HTh,2He ,2HTM,2HP ,2Hco,2Hpy,2H #,2H ,2H ,2His, .2H a,2Hlr,2Hea,2Hdy,2H s,2Hta,2Hrt,2Hed,2H. / DATA BUSI/2HTh,2He ,2HTM,2HP ,2Hco,2Hpy,2H #,2H ,2H ,2His, .2H s,2Hhu,2Ht ,2Hdo,2Hwn,2H. / DATA NOVA/2HTh,2He ,2HTM,2HP ,2Hco,2Hpy,2H #,2H ,2H ,2His, .2H n,2Hot,2H d,2Hef,2Hin,2Hed,2H. / DATA NAME/2H&T,2HMP,2H / C OPN(JERR)=OPEN(IDCB,JERR,NAME,1,0,ICRTG) RED(JERR)=READF(IDCB,JERR,COMAD,35,LEN) C C-----GET TERMINAL LOGICAL UNIT # AND FUNCTION C 6000 CALL RMPAR(IPARM) LUCRT=IPARM(1) IF(ISBTW(LUCRT,4,63)) LUCRT=1 CALL EXEC(3,2200B+LUCRT,0) IFONC=IPARM(2) IF(.NOT.ISBTW(IFONC,1,3)) GOTO 20 IF(IFONC.EQ.4) GOTO 3010 IF(IFONC.EQ.5) GOTO 7000 GOTO 10 C C-----GIVES STATUS OF TMP COPY C 3010 CALL DCSFK(LUCRT,1) REG=EXEC(1,2,IBFR,5,600,0) BREG=BREG-1 CALL EXEC(1,2,DRCTY,128,BREG,0) DO 3000 I=1,MAXCOP CALL BLAN(MBUFR,1,100) K=4 II=I+60B CALL MOVCA(II,2,NUMO,6,1) CALL MOVCA(NUMMB,1,LTMPX,5,1) CALL MOVCA(INOMB,1,BUSY,16,1) CALL MOVCA(INOMB,1,BUSI,16,1) CALL MOVCA(INOMB,1,NOVA,16,1) IADRS=IDGET(TMPX) IF(IFONC.EQ.3) GOTO 2005 IF(IADRS.EQ.0) GOTO 30 ISTUS=IAND(IGET(IADRS+15),17B) IF(ISTUS.EQ.0.AND.IFONC.EQ.1) GOTO 30 IF(ISTUS.NE.0.AND.IFONC.EQ.2) GOTO 30 CALL BLAN(COMAD,1,60) CALL MOVEW(EROR,COMAD,8) IF(IFONC.EQ.1) CALL MOVEW(BUSY,COMAD(9),19) IF(IFONC.EQ.2) CALL MOVEW(BUSI,COMAD(9),16) CALL DCSFK(LUCRT,0) CALL EXEC(2,LUCRT,COMAD,30) GOTO 9999 C C-----ABORT TMP COPY IF RUNNING C 2005 CALL ETMSP(TMPX,99) GOTO 10 C C-----SET PARAMETERS AND SCHEDULE CALLED PROGRAM C 30 IF(IADRS.NE.0) GOTO 35 CALL MOVEW(EROR,COMAD,8) CALL MOVEW(NOVA,COMAD(9),17) CALL DCSFK(LUCRT,0) CALL EXEC(2,LUCRT,COMAD,25) GOTO 9999 C C C 35 CALL BLAN(COMAD,1,40) CALL MOVEW(ON,COMAD,2) COMAD(6)=2H, COMAD(7)=IASC(LUCRT) C C-----PREPARE TO SCHEDULE TMP C IF(IFONC.NE.1) GOTO 40 CALL MOVEW(TMPX,COMAD(3),2) GOTO 100 40 CALL MOVEW(LTMPX,COMAD(3),3) COMAD(8)=2H, C C-----PREPARE TO SCHEDULE LTMP,,TSE C CALL MOVEW(TSE,COMAD(9),3) GOTO 100 C C-----ABORT ALL TMP COPIES C 7000 CALL EXEC(2,LUCRT,IBORT,33) 7030 CALL REIO(1,LUCRT+500B,INOMB,-1) CALL MOVEW(CRLF,COMAD,2) COMAD(3)=15512B CALL EXEC(2,LUCRT,COMAD,3) IF(IGETB(INOMB,1).EQ.131B) GOTO 7040 IF(IGETB(INOMB,1).EQ.116B) GOTO 10 CALL MOVEW(EROR,COMAD,8) CALL MOVEW(BADCH,COMAD(9),16) CALL PUTCA(COMAD,1HL,38) CALL EXEC(2,LUCRT,COMAD,24) GOTO 7030 7040 INOMB=60B DO 7100 I=1,MAXCOP INOMB=INOMB+1 CALL MOVCA(INOMB,2,TMPX,4,1) CALL ETMSP(TMPX,99) 7100 CONTINUE GOTO 10 C C-----EXECUTION OF THE SCHEDULE C 100 LENGH=ISUPB(COMAD,20) I=MESSS(COMAD,2*LENGH) IF(I.EQ.0) G$"OTO 150 CALL DCSFK(LUCRT,0) CALL EXEC(2,LUCRT,COMAD,-LENGH) C C-----WAIT UNTIL THE CRT LU IS LOCK AND THEN COMPLETE C DO NOT WAIT MORE THAN 1 MINUTE IN ANY CASE. C 150 K=0 160 CALL EXEC(12,0,2,0,-1) K=K+1 IF(LURQW(LUCRT) .NE. 0) GOTO 9999 IF(K .LT. 60) GOTO 160 C C-----END OF PROGRAM: SAVE CONTEXT ( CARTRIDGE # ) C 9999 IF(ICRTG.EQ.0) GOTO 8888 CALL EXEC(6,0,1) GOTO 6000 8888 END END$ נ$  92903-18202 1805 S C0122 &DCSFK              H0101 rASMB HED . D C M O N S C R E E N D A T A NAM DCSFK,7 92903-16200 REV.1805 780530 * * * NAME: DCSFK SCREEN DATA * SOURCE: &DCSFK 92903-18202 * BINARY: %DCSFK ----NONE--- PART OF %DCMON 92903-16200 * * PGMR: FRANCOIS GAULLIER SPC 2 * ************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * ************************************************************** SPC 2 ENT DCSFK EXT .ENTR,EXEC SPC 1 A EQU 0 B EQU 1 SUP SPC 3 .LU NOP .FLAG NOP DCSFK NOP JSB .ENTR DEF .LU SPC 1 LDA .FLAG,I RECALL FUNCTION SZA,RSS PRINT SCREEN 0 ? JMP SCRN0 YES, PRINT SFK MAP CPA D1 STATUS HEADER ? JMP SCRN1 YES, PRINT STATUS HEADER CPA D2 END OF THE SCREEN ? JMP SCRN2 YES, PRINT END OF THE SCREEN JMP DCSFK,I NO, FORGET THE REQUEST SPC 2 SCRN0 LDA .DSC0 LDB LNG00 JMP SCRNX * .DSC0 DEF DSCR0 SPC 1 SCRN1 LDA .DSC1 LDB LNG01 JMP SCRNX * .DSC1 DEF DSCR1 SPC 1 SCRN2 LDA .DSC2 LDB LNG02 JMP SCRNX * .DSC2 DEF DSCR2 SPC 2 SCRNX STA SCRNY STB TEMP * JSB EXEC OUPUT THE SCREEN DEF *+5 DEF D2 DEF .LU,I SCRNY NOP DEF TEMP * JMP DCSFK,I * D1 DEC 1 D2 DEC 2 TEMP NOP HED . D C M O N SCREEN DATA DSCR0 EQU * BYT 33,143 LOCK KEYBOARD BYT 33,130,33,155 FMT MODE OFF, UNLCK MEMORY BYT 33,46,153,60,102,0 BLOCK MODE OFF * * SET HARDWARE SWITCH * BYT 33,46 ASC \10,s0a0b0c1d0e0f1g1h0j0 BYT 113,0 * * SET SOFT KEY * BYT 33,46 * SFK 1 - RU,TGP,,0,0,0,0 ASC 12,f1k2a015LRU,TGP,,0,0,0,0 BYT 33,46 * SFK 2 - RU,DCMON,,1,0 ASC 11,f2k2a013LRU,DCMON,,1,0 BYT 33,46 * SFK 3 - RU,DCMON,,2,0 ASC 11,f3k2a013LRU,DCMON,,2,0 BYT 33,46 * SFK 4 - RU,TMPGN,,0,0,0,0 ASC 13,f4k2a017LRU,TMPGN,,0,0,0,0 BYT 33,46 * SFK 5 - RU,DCMON,,0,0 ASC 11,f5k2a013LRU,DCMON,,0,0 BYT 33,46 * SFK 6 - RU,DCMON,,4,0 ASC 11,f6k2a013LRU,DCMON,,4,0 BYT 33,46 * SFK 7 - RU,DCMON,,5,0 ASC 11,f7k2a013LRU,DCMON,,5,0 BYT 33,46 * SFK 8 - RU,DCMON,,3,0 ASC 11,f8k2a013LRU,DCMON,,3,0 * BYT 33,110,33,112 HOME UP, CLEAR DISPLAY * * LINE # : 1 * BYT 33,46,144,106 ASC 6,DATACAP/1000 BYT 33,46,144,102 ASC 1, I BYT 123,0 BYT 33,46,144,103 ASC 3, READY BYT 33,46,144,102 ASC 2, !! BYT 33,46,144,100 ASC 13, SOFT KEY ASSIGNMENTS BYT 15,12 * * LINE # : 2 * BYT 15,12 * * LINE # : 3 * BYT 33,51,102,16 BYT 33,46,141,53,61,64,103,0 POSITION CURSOR - 15 ASC 22,R,,,,,,,,,,,TR,,,,,,,,,,,TR,,,,,,,,,,,TR,,,, ASC 4,,,,,,,,T BYT 15,12 * * LINE # : 4 * BYT 33,46,141,53,61,64,103,0 POSITION CURSOR - 15 BYT 33,51,102,16 ASC 1,. BYT 17,40 ASC 4, START BYT 40,16 ASC 1,.. BYT 40,17 ASC 5, START a BYT 16,56 ASC 1,. BYT 17,40 ASC 4, START BYT 16,40 ASC 1,.. BYT 17,40 ASC 5, START BYT 16,56 BYT 15,12 * * LINE # : 5 * BYT 33,46,141,53,61,64,103,0 POSITION CURSOR - 15 BYT 33,51,102,16 ASC 2,. BYT 40,17 ASC 3,TGP BYT 40,16 P ASC 1,.. BYT 40,17 ASC 5,TMP copy BYT 16,56 ASC 2,. BYT 40,17 ASC 3,TSE BYT 40,16 ASC 2,.. BYT 40,17 ASC 4,TMPGN BYT 16,56 BYT 15,12 * * LINE # : 6 * BYT 33,46,141,53,61,64,103,0 POSITION CURSOR - 15 BYT 33,51,102,16 BYT 56,0 BYT 33,46,144,112 ASC 2, BYT 17,146 ASC 3,1 BYT 33,46,144,100,16,56 BYT 56,0 BYT 33,46,144,112 ASC 2, BYT 40,17 ASC 3,f2 BYT 33,46,144,100,16,56 BYT 56,0 BYT 33,46,144,112,17,40 ASC 5, f3 BYT 33,46,144,100,16,56 BYT 56,0 BYT 33,46,144,112,17,40 ASC 5, f4 BYT 33,46,144,100,16,56 BYT 15,12 * * LINE # : 7 * BYT 33,46,141,53,61,64,103,0 POSITION CURSOR - 15 BYT 33,51,102,16 BYT 56,17 ASC 5,Transactio BYT 156,16 ASC 1,.. BYT 17,124 ASC 5,ransaction BYT 16,56 BYT 56,17 ASC 5,Trans. Set BYT 40,16 ASC 1,.. BYT 17,124 ASC 5,rans. Mon. BYT 16,56 BYT 15,12 * * LINE # : 8 * BYT 33,46,141,53,61,64,103,0 POSITION CURSOR - 15 BYT 33,51,102,16 BYT 56,17 ASC 5, Generator BYT 40,16 ASC 1,.. BYT 17,40 ASC 5, Monitor BYT 16,56 BYT 56,17 ASC 5, Editor BYT 40,16 ASC 1,.. BYT 17,40 ASC 5,Generator BYT 16,56 BYT 15,12 * * LINE # : 9 * BYT 33,46,141,53,61,64,103,0 POSITION CURSOR - 15 BYT 33,51,102,16 ASC 22,F,,,,,,,,,,,GF,,,,,,,,,,,GF,,,,,,,,,,,GF,,,, ASC 4,,,,,,,,G BYT 15,12 * * LINE # : 10 * BYT 33,51,102,16 BYT 33,46,141,53,61,64,103,0 POSITION CURSOR - 15 ASC 22,R,,,,,,,,,,,TR,,,,,,,,,,,TR,,,,,,,,,,,TR,,,, ASC  4,,,,,,,,T BYT 15,12 * * LINE # : 11 * BYT 33,46,141,53,61,64,103,0 POSITION CURSOR - 15 BYT 33,51,102,16 ASC 1,. BYT 17,40 ASC 3,RECALL BYT 40,16 ASC 2, .. BYT 40,17 ASC 4, TMP's BYT 40,16 ASC 2, .. BYT 40,17 ASC 4,STOP all BYT 16,40 ASC 1,.. BYT 40,17 ASC 4, STOP a BYT 40,16 ASC 1, . BYT 15,12 * * LINE # : 12 * BYT 33,46,141,53,61,64,103,0 POSITION CURSOR - 15 BYT 33,51,102,16 BYT 56,17 ASC 4, KEYS MA BYT 120,16 ASC 2, .. BYT 17,40 ASC 4, STATUS BYT 40,16 ASC 2, .. BYT 17,124 ASC 4,MP copie BYT 163,16 ASC 1,.. BYT 40,17 ASC 5,TMP copy BYT 16,56 BYT 15,12 * * LINE # : 13 * BYT 33,46,141,53,61,64,103,0 POSITION CURSOR - 15 BYT 33,51,102,16 BYT 56,0 BYT 33,46,144,112 ASC 2, BYT 17,146 ASC 3,5 BYT 33,46,144,100,16,56 BYT 56,0 BYT 33,46,144,112 ASC 2, BYT 40,17 ASC 3,f6 BYT 33,46,144,100,16,56 BYT 56,0 BYT 33,46,144,112,17,40 ASC 5, f7 BYT 33,46,144,100,16,56 BYT 56,0 BYT 33,46,144,112,17,40 ASC 5, f8 BYT 33,46,144,100,16,56 BYT 15,12 * * LINE # : 14 * BYT 33,46,141,53,61,64,103,0 POSITION CURSOR - 15 BYT 33,51,102,16 ASC 1,. BYT 33,46,141,53,61,60,103,0 POSITION CURSOR - 27 ASC 1,.. BYT 33,46,141,53,61,61,103,0 POSITION CURSOR - 40 ASC 1,.. BYT 33,46,141,53,61,61,103,0 POSITION CURSOR - 53 ASC 1,.. BYT 17,124 ASC 5,ransaction BYT 16,56 BYT 15,12 * * LINE # : 15 * BYT 33,46,141,53,61,64,103,0 POSITION CURSOR - 15 BYT 33,51,10Y2,16 ASC 1,. BYT 33,46,141,53,61,60,103,0 POSITION CURSOR - 27 ASC 1,.. BYT 40,17 ASC 3, BYT 40,16 ASC 3, .. BYT 17,40 ASC 3, BYT 16,40 ASC 2, .. BYT 40,17 ASC 5, Monitor BYT 16,56 BYT 15,12 * * LINE # : 16 * BYT 33,46,141,53,61,64,103,0 POSITION CURSOR - 15 BYT 33,51,102,16 ASC 22,F,,,,,,,,,,,GF,,,,,,,,,,,GF,,,,,,,,,,,GF,,,, ASC 4,,,,,,,,G DSCR2 BYT 15,12 * * LINE # : 17 * BYT 15,12 * * LINE # : 18 * BYT 33,51,102,16 ASC 22,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ASC 18,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, * BYT 33,154 MEMORY LOCK BYT 33,142 UNLOCK KEYBOARD SPC 1 LNG00 ABS *-DSCR0 LNG02 ABS *-1-DSCR2 HED . DATACAP STATUS SCREEN HEADER DSCR1 EQU * BYT 33,143 LOCK KEYBOARD BYT 33,130,33,155 FMT MODE OFF, UNLCK MEMORY BYT 33,46,153,60,102,0 BLOCK MODE OFF * BYT 33,110,33,112 HOME UP, CLEAR DISPLAY * * LINE # : 1 * BYT 40,0 BYT 33,46,144,112 ASC 7, DATACAP/1000 BYT 40,0 BYT 33,46,144,113 ASC 3,STATUS BYT 15,12 * * LINE # : 2 * BYT 15,12 * * LINE # : 3 * BYT 33,51,102,16 ASC 22,r,,,,,,,7,,,,,,,,,,,7,,,,,,,,,,,,,7,,,,,,,,, ASC 13,,,7,,,,,,,,,,,7,,,,,,,,,,, BYT 124,0 BYT 15,12 * * LINE # : 4 * BYT 33,51,102,16 BYT 56,17 ASC 3, TMP BYT 40,16 ASC 1,. BYT 17,103 ASC 4,artridge BYT 40,16 ASC 1,. BYT 33,46,141,53,61,62,103,0 POSITION CURSOR - 35 ASC 1,. BYT 33,46,141,53,61,60,103,0 POSITION CURSOR - 47 ASC 1,. BYT 33,46,141,53,61,60,103,0 POSITION CURSOR - 59 ASC 1,. BYT 33,46,141,53,61,60,103,0 POSITION CURSORN&$" - 71 BYT 56,0 BYT 15,12 * * LINE # : 5 * BYT 33,51,102,16 BYT 56,17 ASC 3, copy# BYT 40,16 ASC 1,. BYT 17,40 ASC 4,number BYT 40,16 BYT 56,17 ASC 6, Data base BYT 40,16 BYT 56,17 ASC 5, Defined BYT 40,16 BYT 56,17 ASC 5, Ready BYT 40,16 BYT 56,17 ASC 5, Running BYT 40,16 BYT 56,0 BYT 15,12 * * LINE # : 6 * BYT 33,51,102,16 ASC 22,f,,,,,,,8,,,,,,,,,,,8,,,,,,,,,,,,,8,,,,,,,,, ASC 13,,,8,,,,,,,,,,,8,,,,,,,,,,, BYT 107,0 BYT 15,12 * * LINE # : 7 * BYT 15,12 * LNG01 ABS *-DSCR1 END Z$  92903-18203 1805 S C0122 *TYPE0 TR FILE CREATES TYPE 0 FILES             H0101 sg:** :** *TYPE0 (HP 92903-18203 REV.1805 780601) :** :** CREATES TYPE 0 FILES ON LU=2 OR LU=3 AS DEFINED IN *DATCA :** :** IF THE USER WANTS TO CREATE THOSE FILES FOR DIFERENTS LU'S :** EDIT THE TRANSFER FILE TO CHANGE THE CREATE COMMAND. :** :PU,MT::7G :PU,LP::7G :PU,LCTU::7G :PU,RCTU::7G :CA,6:P,0 :CR,RCTU::7G,5,BO,BO,EO,BI :CR,LCTU::7G,4,BO,BO,EO,BI :CR,MT::7G,8,BO,BO,EO,BI :CR,LP::7G,6,WR,FS,PA,AS :IF,6P,NE,0,1 :: :AN, :DP, UNABLE TO CREATE TYPE 0 FILE ON LU=,8G :: }  92903-18204 1805 S C0122 *DATCA TR FILE TO INSTALL DATACAP            H0101 :SV,4,9,IH :** :** *DATCA (HP 92903-18204 REV.1805 780602) :** :** LOADS ALL DATACAP PROGRAMS, AND SAVES THEM ON LU=2 IF REQUIRED. :** :** IF THE USER WANTS TO SAVE PROGRAM ON LU=3, EDIT THE :** TRANSFER FILE TO CHANGE THE NEXT LINE TO: :CA,8,3 :CA,8,2 :CA,7,8G,*,-1 :LL,0G :IF,1G,EQ,,1 :IF,1G,NE,0,14 :AN, :AN,. :AN,. PLEASE ENTER THE FOLLOWING COMMAND: :AN,. :AN,. TR,*DATCA::CR,CR#,LIST LU,LOAD FLAG :AN,. :AN,. WHERE CR IS THE CARTRIDGE WHERE '*DATCA' RESIDES. :AN,. CR# IS THE CARTRIDGE WHERE DATACAP'S MODULES RESIDE. :AN,. LOAD FLAG IS 0 TO LOAD PROGRAMS TEMPORARILY AND :AN,. NOT 0 TO SAVE PROGRAMS AS TYPE 6 FILES. :AN,. :AN, :SV,9G,,IH :: :AN, :AN, **************************************************************** :AN, * * :AN, * C R E A T I O N O F T Y P E 0 F I L E S * :AN, * * :AN, **************************************************************** :AN, :CA,6:P,0 ::*TYPE0::1G :IF,6P,NE,0,-24 :CA,6,2G :IF,6G,EQ,,1 :IF,6G,NE,0,1 :CA,6,0G :IF,3G,NE,,1 :CA,3,0 :AN, :IF,3G,NE,0,2 :DP, FROM CR=,1G, LIST LU=,6G, PROGRAM LOADED TEMPORARILY ! :IF,,EQ,,1 :DP, FROM CR=,1G, LIST LU=,6G, PROGRAMS SAVED ONTO TYPE 6 FILES. :AN, :AN, :AN, :AN, :AN, **************************************************************** :AN, * * :AN, * L O A D I N G O F D C M O N * :AN, * * :AN, **************************************************************** :AN, :OF,DCMON :RU,LOADR,,%DCMON::1G,6G :IF,10G,EQ,DCMON,8 :AN, :AN, LOADER HAS FAILED: :AN, 'DCMON' IS NOT READY ! :AN, :AN, DATACAP IS NOT READY, MUST RE-RUN THE TRANFER FILE *DATCA :AN, :SV,9G,,IH :: :AN, :AN, LOADER COMPLETED, 'DCMON' IS SAVED AS TYPE 6 FILE. :AN, :PU,DCMON::7G :CA,6:P,0 :SP,DCMON::7G :IF,6P,EQ,0,3 :AN, :DP, UNABLE TO SAVE PROGRAM 'DCMON', NO ROOM ON LU=,8G :IF,,EQ,,-16 :OF,DCMON :RP,DCMON :AN, :AN, **************************************************************** :AN, * * :AN, * L O A D I N G O F T M P G N * :AN, * * :AN, **************************************************************** :AN, :OF,TMPGN :OF,TMPG0 :OF,TMPG1 :OF,TMPG2 :OF,TMPG3 :OF,TMPG4 :OF,TMPG5 :RU,LOADR,>TMPGN::1G,,6G,SS,,,15 :IF,10G,EQ,TMPGN,8 :AN, :AN, LOADER HAS FAILED: :AN, 'TMPGN' IS NOT READY ! :AN, :AN, DATACAP IS NOT READY, MUST RE-RUN THE TRANSFER FILE *DATCA :AN, :SV,9G,,IH :: :IF,3G,EQ,0,39 :AN, :AN, LOADER COMPLETED, 'TMPGN' IS SAVED AS TYPE 6 FILES. :AN, :PU,TMPGN::7G :PU,TMPG0::7G :PU,TMPG1::7G :PU,TMPG2::7G :PU,TMPG3::7G :PU,TMPG4::7G :PU,TMPG5::7G :CA,6:P,0 :SP,TMPGN::7G :SP,TMPG0::7G :SP,TMPG1::7G :SP,TMPG2::7G :SP,TMPG3::7G :SP,TMPG4::7G :SP,TMPG5::7G :IF,6P,EQ,0,3 :AN, :DP, UNABLE TO SAVE PROGAM 'TMPGN', NO ROOM ON LU=,8G :IF,,EQ,,-29 :OF,TMPGN :OF,TMPG0 :OF,TMPG1 :OF,TMPG2 :OF,TMPG3 :OF,TMPG4 :OF,TMPG5 :PU,/TMPGN::7G :PU,\TMPGN::7G :CA,6:P,0 :ST,/TMPGN::1G,/TMPGN::7G :ST,\TMPGN::1G,\TMPGN::7G :IF,6P,EQ,0,3 :AN, :DP, UNABLE TO RESTORE FILES: /TMPGN & \TMPGN, NO ROOM ON LU=,8G :IF,,EQ,,-45 ::/TMPGN::7G :AN, :AN, **************************************************************** :AN, * * :AN, * L O A D I N G O F T G P * :AN, * * :AN, **************************************************************** :AN, :OF,TGP :OF,TGP0 :OF,TGP1 :OF,TGP2 :OF,TGP3 :OF,TGP4 :OF,TGP5 :OF,TG P6 :OF,TGP7 :OF,TGP8 :OF,TGP9 :OF,TGPI0 :OF,TGPI1 :OF,TGPI2 :OF,TGPI3 :RU,LOADR,>TGP::1G,,6G,SS,,,15 :IF,10G,EQ,TGP,8 :AN, :AN, LOADER HAS FAILED: :AN, 'TGP' IS NOT READY ! :AN, :AN, DATACAP IS NOT READY, MUST RE-RUN THE TRANSFER FILE *DATCA :AN, :SV,9G,,IH :: :IF,3G,EQ,0,63 :AN, :AN, LOADER COMPLETED 'TGP' IS SAVED AS TYPE 6 FILES. :AN, :PU,TGP::7G :PU,TGP0::7G :PU,TGP1::7G :PU,TGP2::7G :PU,TGP3::7G :PU,TGP4::7G :PU,TGP5::7G :PU,TGP6::7G :PU,TGP7::7G :PU,TGP8::7G :PU,TGP9::7G :PU,TGPI0::7G :PU,TGPI1::7G :PU,TGPI2::7G :PU,TGPI3::7G :CA,6:P,0 :SP,TGP::7G :SP,TGP0::7G :SP,TGP1::7G :SP,TGP2::7G :SP,TGP3::7G :SP,TGP4::7G :SP,TGP5::7G :SP,TGP6::7G :SP,TGP7::7G :SP,TGP8::7G :SP,TGP9::7G :SP,TGPI0::7G :SP,TGPI1::7G :SP,TGPI2::7G :SP,TGPI3::7G :IF,6P,EQ,0,3 :AN, :DP, UNABLE TO SAVE PROGRAM 'TGP', NO ROOM ON LU=,8G :IF,,EQ,,-45 :OF,TGP :OF,TGP0 :OF,TGP1 :OF,TGP2 :OF,TGP3 :OF,TGP4 :OF,TGP5 :OF,TGP6 :OF,TGP7 :OF,TGP8 :OF,TGP9 :OF,TGPI0 :OF,TGPI1 :OF,TGPI2 :OF,TGPI3 :PU,/TGP::7G :PU,\TGP::7G :CA,6:P,0 :ST,/TGP::1G,/TGP::7G :ST,\TGP::1G,\TGP::7G :IF,6P,EQ,0,3 :AN, :DP, UNABLE TO RESTORE FILES: /TGP & \TGP, NO ROOM ON LU=,8G :IF,,EQ,,-69 ::/TGP::7G :AN, :AN, DATACAP  IS  READY !! :AN,  :RU,DCMON,0G,0,0,0,0 :SV,9G,,IH :  92903-18300 1805 S C0122 &TGPLB              H0101 {ASMB,R NAM TGPLB,7 92903-12300 REV.1805 780511 END   92903-18304 1805 S C0122 &FILAB              H0101 vzFTN4 SUBROUTINE FILAB(IL,IP,IF,IFORM), 92903-16304 REV.1805 770727 C C SOURCE 92903-18304 C C C C ************************************************************** C * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * C ************************************************************** C C C C********************************************************************* C* * C* THIS SUBROUTINE INCLUDE THE FUNCTION LABEL IN THE TABLE * C* USED TO DEFINE THE SFK'S (SCREENS 6/7) IF THIS LABEL IS LEFT * C* EMPTY BY THE USER * C* PARAMETERS : * C* IL : LINE # IN THE TABLE * C* IP : 0 IF NON PREFIXED * C* 1 IF PREFIXED * C* IF : FUNCTION # * C* * C********************************************************************* C C C **** DECLARATIONS ******* C DIMENSION IFORM(1),ILAB(13,6) C DATA ILAB/2HTR,2H.C,2HOM,2HPL,2HET,2HE , C2H ,2H R,2HEC,2HAL,2HL ,2H , C2H S,2HAM,2HE ,2HVA,2HLU,2HE , C2HAB,2HOR,2HT/,2HSE,2HLE,2HCT, C2H ,2H ,2HAD,2HD ,2H ,2H+ , C2H S,2HUB,2HTR,2HAC,2HT ,2H- , C2H M,2HUL,2HTI,2HPL,2HY ,2H* , C2H ,2HDI,2HVI,2HDE,2H ,2H/ , C2H ,2H E,2HQU,2HAL,2H ,2H= , C2H ,2H P,2HRE,2HFI,2HX ,2H , C2H ,2HCO,2HNT,2HIN,2HUE,2H , C2H N,2HEX,2HT ,2HEN,2HTR,2HY , C2HDE,2HLE,2HTE,2H E,2HNT,2HRY/ C NCAR=108+(IL-1)*33+IP*330    CALL MOVCA(ILAB,1+(IF-1)*12,IFORM,NCAR,12) RETURN END END$ Ɂ   92903-18305 1805 S C0122 &ERFLG              H0101 xFTN4 C C SUBROUTINE ERFLG(N,IMAI,IMKY,IMFLG,IMAS,IMDT), 92903-16305 REV.180 C5 770722 C C SOURCE 92903-18305 C C C C ************************************************************** C * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * C ************************************************************** C C C C********************************************************************* C* * C* THIS SUBROUTINE IS USED TO RESET THE * C* IMAGE FLAGS IMFLG,IMAS,IMDT,IMKY WHEN THE USER ERASE AN * C* OPERATION PREVIOUSLY DEFINED * C* * C********************************************************************* C* C DIMENSION IMAI(45,5) C C ERASE IMAI ARRAY AFTER LINE N C DO 100 I=N,45 DO 100 K=1,5 100 IMAI(I,K)=0 C C CHECK IF OPERATIONS STILL EXIST IN IMAI C DO 120 I=1,N L=IAND(IMAI(I,3),377B) K=IAND(IMAI(I,2),7) IF((K.EQ.0).AND.(L.EQ.IMAS).AND.(IMAS.NE.0)) IFDM=1 IF((K.EQ.0).AND.(L.EQ.IMDT).AND.(IMDT.NE.0)) IFDT=1 IF(K.EQ.1) IUP=1 IF(K.EQ.2) IAD=1 IF(K.EQ.3) ICK=1 IF(K.EQ.4) IDE=1 IF(K.EQ.5) IDI=1 120 CONTINUE IF((IFDM.EQ.1).OR.(IFDT.EQ.1)) L=1 IF((IAD+IDE+IUP).GT.0) K=1 I=IAD+L*2+IDE*4+IUP*8+ICK*16+IDI*32+K*100000B IMFLG=IAND(IMFLG,I) IF(IFDM.EQ.0) IMAS=0 IF(IFDT.EQ.0) IMDT=0 IF((IFDM+IFDT).EQ.0) IMKY=0 RETURN END END$ "    92903-18306 1805 S C0122 &ERLIT              H0101 FTN4 C C SUBROUTINE ERLIT(ILITE,N), 92903-16306 REV.1805 770722 C* C SOURCE 92903-18306 C* C C C ************************************************************** C * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * C ************************************************************** C C C********************************************************************* C* * C* THIS SUBROUTINE RESETS THE ILITE BUFFER USED FOR * C* THE LIGHTS ASSIGNEMENTS. * C* * C* PARAMETERS : * C* * C* ILITE : BUFFER TO RESET * C* N : IF > 0 RESET BEFORE A QUESTION * C* IF < 0 RESET BEFORE A DISPLAY * C* * C* IF N > 0 AND ABS(ILITE(I))>=N THEN ILITE(I)=0 * C* * C* IF N < 0 AND ABS(ILITE(I))>(-N) OR ILITE(I)=N THEN * C* ILITE(I)=0 * C* * C********************************************************************* C* C* DIMENSION ILITE(1) C DO 100 I=1,15 M=ILITE(I) IF(M.EQ.-99) GO TO 100 IF(M.LT.0) M=-M IF(N.LT.0) GO TO 110 IF(M.GE.N) GO TO 120 GO TO 100 110 IF(ILITE(I).EQ.N) GO TO 120 IF(M.GT.-N) GO TO 120    GO TO 100 120 ILITE(I)=0 100 CONTINUE C RETURN END END$   92903-18307 1805 S C0122 &LIGHT              H0101 FTN4 SUBROUTINE LIGHT(IQ,JVAL,JOUT,ISTAT,JFORM,ILITE), 92903-16307 REV. C1805 770803 C C SOURCE 92903-18307 C C C C ************************************************************** C * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * C ************************************************************** C C C C C PRGMR :JEAN CHARLES MIARD C C********************************************************************* C* * C* THIS SUBROUTINE IS USED TO MANAGE 3070 LIGHTS ALLOC * C* -ATION . * C* -FIRST IT RELEASES THE OLD LIGHT TAKEN BY THIS * C* QUESTION OR DISPLAY IF ANY (COME BACK MODE). * C* -IF THE ANSWER TO LIGHT # ? WAS A BLANK IT TAKES THE * C* NEXT AVAILABLE LIGHT # (IF ANY) * C* -IF THE ANSWER TO LIGHT # ? WAS A NUMBER IT CHECKS * C* THAT THE LIGHT CORRESPONDING TO THE NUMBER IS NOT * C* ALREADY TAKEN BY ANOTHER QUESTION OR DISPLAY. IN * C* THIS CASE IN A FIRST PASS (ISTAT=0) IT WILL CAUSE * C* A WARNING MESSAGE TO BE PRINTED,IN A SECOND PASS * C* (ISTAT=1) IT WILL ACCEPT THE NUMBER * C* -IF ALL OK THE LIGHT # IS STORED * C* * C* PARAMETERS: * C* -IQ : QUESTION # POSITIVE FOR QUESTION * C* NEGATIVE FOR DISPLAY * C* -JVAL : LIGHT # DESIRED (BINARY) " * C* -JOUT : ANSWER TO QUESTION LIGHT # ? (ASCII) * C* -ISTAT: STATUS : * C* - WHEN CALLING : * C* 0 NO WARNING ALREADY DONE * C* 1 WARNING ALREADY DONE * C* - WHEN RETURNING : * C* 0 OK JOB DONE * C* -1 NO MORE LIGHTS AVAILABLE * C* -2 ISSUE A WARNING * C* * C* - JFORM :SOURCE BUFFER (LABELS) * C* - ILITE :LIGHT BUFFER ALLOCATION * C* * C********************************************************************* C C C DECLARATIONS ************ C DIMENSION JFORM(1),ILITE(1) C LOGICAL CMPW C C ************************************************************* C * * C * DESRIPTION OF ILITE BUFFER : * C * * C * ILITE(I) : I IS LIGHT # * C * * C * IF ILITE(I) = 0 : LIGHT IS AVAILABLE . * C * < 0 : LIGHT IS AN INDICATOR LIGHT * C * (DISPLAY) -ILIGHT(I) IS QUESTION # * C * TO WHICH BELONG THE LIGHT . * C * > 0 : LIGHT IS A PROMPTING LIGHT * C * (QUESTION) ILIGHT(I) IS QUESTION # * C * TO WHICH BELONG THE L4 IGHT . * C * = -99 : LIGHT OCCUPIED BY SYSTEM * C * * C ************************************************************* C C C RELEASE OLD LIGHT # C DO 5000 I=1,15 IF(ILITE(I).EQ.IQ) GO TO 5002 5000 CONTINUE GO TO 5010 5002 DO 5006 J=1,20 IF(J.EQ.IQ) GO TO 5003 IL=NUMD(JFORM,(1+(J-1)*98),2) IF(IL.EQ.I) GO TO 5008 5003 IF(J.EQ.-IQ) GO TO 5006 IL=NUMD(JFORM,(69+(J-1)*98),2) IF(IL.EQ.I) GO TO 5009 5006 CONTINUE ILITE(I)=0 GO TO 5010 5008 ILITE(I)=J GO TO 5010 5009 ILITE(I)=-J C C USER WANTS NEXT AVAILABLE LIGHT C 5010 IF(JOUT.NE.2H ) GO TO 5016 DO 5012 I=1,15 IF(ILITE(I).EQ.0) GO TO 5014 5012 CONTINUE ISTAT=-1 RETURN 5014 ILITE(I)=IQ JOUT=IASC(I) GO TO 5036 C C USER WANTS A SPECIFIC LIGHT # C 5016 IF(ILITE(JVAL).EQ.0) GO TO 5034 IF(IQ.LT.0) GO TO 5020 N2=374+(IQ-1)*6 IF(ILITE(JVAL).LT.0) GO TO 5018 N1=374+(ILITE(JVAL)-1)*6 IF(ISTAT.EQ.1) GO TO 5036 GO TO 5024 5018 N1=36+(-ILITE(JVAL)-1)*49 IF(ISTAT.EQ.1) GO TO 5036 GO TO 5024 5020 N2=36+(-IQ-1)*49 IF(ILITE(JVAL).LT.0) GO TO 5022 N1=374+(ILITE(JVAL)-1)*6 IF(ISTAT.EQ.1) GO TO 5036 GO TO 5024 5022 N1=36+(-ILITE(JVAL)-1)*49 IF(ISTAT.EQ.1) GO TO 5036 5024 ISTAT=-2 RETURN 5034 ILITE(JVAL)=IQ 5036 IF(IQ.GT.0) N1=1+(IQ-1)*98 IF(IQ.LT.0) N1=69+(-IQ-1)*98 CALL MOVCA(JOUT,1,JFORM,N1,2) ISTAT=0 RETURN END END$ t[  92903-18308 1805 S C0122 &WARNG              H0101 ASMB,R NAM WARN,7 92903-16308 REV.1805 770722 * * SOURCE 92903-18308 * SPC 2 ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** SPC 2 SUP * ********************************************************************** * * * THIS SUBROUTINE IS USED TO WRITE ON LINE 24 * * OF A SCREEN A WARNING MESSAGE WHICH SAYS TO THE USER THAT THE * * 3070 LIGHT HE WANTS TO USE IS ALREADY TAKEN BY AN OTHER * * QUESTION OR DISPLAY. * * THIS SUBROUTINE IS CALLED WITH TWO PARAMETERS * * +IQST IF THE LABEL TO PRINT IS A QUESTION LABEL * * -IQST IF THE LABEL TO PRINT IS AN INDICATOR LABEL * * SECOND PARAMETER USED ONLY FOR QUESTION LABEL IS NOF * * (# OF THE FIELD IN THE SCREEN) * * * ********************************************************************** * ENT WARN EXT EXEC EXT .ENTR EXT MOVCA EXT &REMP COM ILU,ISCRN,IQST,ISKIP,INDIC COM IFORM(494) COM JFORM(980) NLAB NOP CALLING PARAMETER NOF NOP FIELD # WARN NOP ENTRY POINT JSB .ENTR SUBR. TO GET DEF NLAB PARAM. ADDRESS LDA ABUF1 FILL TAB BUFFER LDB NUL WITH BLANKS JSB &REMP DEC -9 LDA NOF,I GET # OF TABS CMA,INA TO INCLUDE ISZ A IN BUFFER . IS 0 ? RSS NO Q JMP WARN3 YES STA LN1 LDA ABUF1 MOVE TABS IN LDB TAB BUFFER JSB &REMP LN1 NOP WARN3 LDA NLAB,I GET QUESTION # SSA POSITIVE? JMP WARN1 NO INDICATOR LABEL ADA .D1 YES QUESTION LABEL MPY D.12 COMPUTE LABEL ADA D.747 OFFSET IN IFORM STA SOQST STORE IT JSB MOVCA NOW MOVE DEF *+6 LABEL DEF IFORM IN OUTPUT BUFFER DEF SOQST OFFSET DEF TLAB DEST BUFFER DEF D.1 DEST OFFSET DEF D.12 MOVE LENGTH JMP WARN2 WARN1 CMA,INA MAKE QUESTION POSITIVE ADA .D1 COMPUTE LABEL MPY D.98 OFFSET IN JFORM ADA D.71 STA SOQST STORE IT JSB MOVCA NOW MOVE DEF *+6 LABEL IN OUTPUT BUFFER DEF JFORM SORCE BUFFER DEF SOQST SOURCE OFFSET DEF TLAB DEST BUFFER DEF D.1 DEST OFFSET DEF D.12 MOVE LENGTH WARN2 JSB EXEC WRITE MESSAGE DEF *+5 RETURN POINT DEF D.2 CODE EXEC DEF ILU CONTROL WORD DEF BUF BUFFER LOCATION DEF ILBUF BUFFER LENGTH JMP WARN,I RETURN TO CALLING PROGRAM * * MESSAGE DATA : * BUF BYT 33,130,33,46,141,62,63,162,60,103,33,112,40,0 BYT 33,46,144,103 ASC 7,WARNING ONLY : BYT 33,46,144,100 ASC 16, Light already used with label TLAB ASC 6, BYT 33,127 FORMAT ON BUF1 BSS 9 TAB BUFFER BYT 33,142 KEYBOARD ENABLE EBUF BYT 0,137 * * DATA, CONSTANTS,STORAGE.... * A EQU 0 ABUF1 DEF BUF1 NUL BYT 0,0 TAB BYT 33,111 .D1 DEC -1 D.1 DEC 1 D.2 DEC 2 D.12 DEC 12 D.71 DEC 71 D.98 DEC 98 D.747 DEC 747 SOQST NOP STBUF EQU BUF LTBUF EQU EBUF ILBUF ABS LTBUF-STBUF+1 * END WARN a   92903-18309 1805 S C0122 &SPLT              H0101 eFTN4 SUBROUTINE SPLT(N1,IPNTR,KFORM,ISQ), 92903-16309 REV.1805 770722 C C SOURCE 92903-18309 C C C C ************************************************************** C * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * C ************************************************************** C C C C********************************************************************** C* * C* THIS SUBROUTINE IS USED BY FORMG PROGRAM TO SPLIT * C* THE DUMMY STATES FOR SFK (SQ=0) AND STORAGE IN SEVERAL STATES * C* WITH A MAXIMUM LENGTH OF 39 WORDS. * C* * C* CALLING PARAMETERS : * C* N1 : # OF THE WORD IN THE BUFFER WHERE STARTS * C* THE STATE * C* IPNTR : STATE LENGTH * C* KFORM : FORM BUFFER * C* ISQ : STATE QUALIFIER * C* * C********************************************************************** C C DIMENSION KFORM(1) C C N2 IS CURRENT STATE INDEX C N2=1 C 6000 IF(IPNTR.LE.39) GO TO 6020 IF(N2.EQ.1) GO TO 6010 CALL MOVEW(KFORM(N1),KFORM(N1+2),-IPNTR) IPNTR=IPNTR+2 6010 KFORM(N1)=N1+39 IF(N2.EQ.1) KFORM(N1+1)=KFORM(N1+1)+200B+N2+ISQ*32 IF(N2.NE.1) KFORM(N1+1)=200B+N2+ISQ*32 N1=N1+39 IPNTR=IPNTR-39 N2=N2+1 GO TO 6000 6020 IF(N2.EQ.1) GO TO 6030    CALL MOVEW(KFORM(N1),KFORM(N1+2),-IPNTR) IPNTR=IPNTR+2 6030 KFORM(N1)=N1+IPNTR IF(N2.EQ.1) KFORM(N1+1)=KFORM(N1+1)+N2+ISQ*32 IF(N2.NE.1) KFORM(N1+1)=N2+ISQ*32 N1=N1+IPNTR RETURN END END$ x   92903-18310 1805 S C0122 &FNCT              H0101 PFTN4 SUBROUTINE FNCT(N3,IY,KFORM,IFN,IX), 92903-16310 REV.1805 770722 C C SOURCE 92903-18310 C C C C ************************************************************** C * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * C ************************************************************** C C C C********************************************************************* C* * C* THIS SUBROUTINE IS USED TO INCLUDE A NEW * C* FUNCTION IN KFORM FUNCTION EDIT BUFFER . * C* IT IS USED BY FORM5 AND CALLED WITH THE * C* FOLLOWING PARAMETERS : * C* N3 : CURRENT LINE IN KFORM * C* IY : # OF FUNCTIONS ALREADY ACCEPTED * C* KFORM : BUFFER * C* IFN : FUNCTION # TO ADD * C* IX : START WORD ADDRESS OF EDIT SPECIF IN KFORM * C* * C* PARAMETERS N3,IY ARE UPDATED * C* * C********************************************************************* C DIMENSION KFORM(1) IF(IY.EQ.0) N3=N3+1 IF(IAND(IY,1).EQ.0) GO TO 100 KFORM(N3)=IFN*256 GO TO 200 100 KFORM(N3)=IOR(KFORM(N3),IFN) N3=N3+1 200 IY=IY+1 KFORM(IX)=IOR(KFORM(IX),100000B) RETURN END END$ et    92903-18311 1805 S C0122 &DUPL TGP SEGM 10 SUBR SRC             H0101 ASMB,R NAM DUPL,7 92903-16311 REV.1805 770722 * * SOURCE 92903-18311 * SPC 2 ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** SPC 2 SUP *********************************************************************** * THIS SUBROUTINE IS USED TO PRINT ON THE * * TERMINAL A SCREEN TO ASK THE THE USER A NEW IDENTIFICATION * * FOR A FORM . * * * *********************************************************************** * * * * ENT DUPL EXT EXEC EXT .ENTR EXT MOVCX COM ILU * NBUF NOP ADDRESS OF DATA BUFFER DUPL NOP ENTRY POINT JSB .ENTR DEF NBUF * JSB MOVCX MOVE DATA IN SCREEN DEF *+6 DEF NBUF,I SOURCE DATA BUFFER DEF SOF30 TABLE OF OFFSETS IN SOURCE BUFFER DEF BD30 TABLE OF DEST. BUFFER ADDRESS DEF D.0 DEST OFFSET DEF DBL30 * JSB EXEC WRITE SCREEN DEF *+5 DEF D.2 DEF ILU DEF BSC30 DEF ILS30 * JMP DUPL,I * * * DATA SCREEN * * * * LINE # : 1 * BSC30 BYT 33,46,153,61,102 SET BLOCK MODE BYT 33,130,33,110,33,112,33,143 BYT 33,46,141,53,61,63,103,0 POSITION CURSOR - 14 ASC 22,CHANGE TRANSACTION SPECIFICATION IDENTIFICAT ASC 1,IO BYT 116,0 BYT 15,12 * * LINE # : 2 * BYT 15,12 * * LINE # : 3 * c BYT 15,12 * * LINE # : 4 * ASC 22, A transaction specification with the fo ASC 15,llowing identification already BYT 15,12 * * LINE # : 5 * ASC 20, exists on the destination library : BYT 15,12 * * LINE # : 6 * BYT 15,12 * * LINE # : 7 * BYT 33,46,141,53,61,63,103,0 POSITION CURSOR - 14 ASC 2,Name BYT 33,46,141,53,61,63,103,0 POSITION CURSOR - 31 ASC 3,Number BYT 33,46,141,53,61,63,103,0 POSITION CURSOR - 50 ASC 6,Security cod BYT 145,0 BYT 15,12 * * LINE # : 8 * BYT 33,46,141,53,61,62,103,0 POSITION CURSOR - 13 BYT 33,46,144,102 T3000 ASC 3, BYT 33,46,144,100 BYT 33,46,141,53,61,63,103,0 POSITION CURSOR - 32 BYT 33,46,144,102 T3001 ASC 2, BYT 33,46,144,100 BYT 33,46,141,53,61,67,103,0 POSITION CURSOR - 53 BYT 33,46,144,102 T3002 ASC 3, BYT 15,12 * * LINE # : 9 * BYT 15,12 * * LINE # : 10 * BYT 15,12 * * LINE # : 11 * ASC 22, Since two specifications with the same ASC 15,name or number cannot be store BYT 144,0 BYT 15,12 * * LINE # : 12 * ASC 22, on a library the identification of the ASC 14,transaction being copied mus BYT 164,0 BYT 15,12 * * LINE # : 13 * ASC 8, be changed BYT 72,0 BYT 15,12 * * LINE # : 14 * BYT 15,12 * * LINE # : 15 * BYT 33,46,141,53,61,63,103,0 POSITION CURSOR - 14 ASC 2,Name BYT 33,46,141,53,61,63,103,0 POSITION CURSOR - 31 ASC 3,Number BYT 33,46,141,53,61,63,103,0 POSITION CURSOR - 50 ASC 6,Security cod BYT 145,0 BYT 15,12 * * LINE # : 16 * BYT 33,46,141,53,61,62,103,0 POSITION CURSOR - 13 BYT 33,46,144,102,33,133 T3003 ASC 31+ , BYT 33,135,33,46,144,100 BYT 33,46,141,53,61,63,103,0 POSITION CURSOR - 32 BYT 33,46,144,102,33,133 T3004 ASC 2, BYT 33,135,33,46,144,100 BYT 33,46,141,53,61,67,103,0 POSITION CURSOR - 53 BYT 33,46,144,102,33,133 T3005 ASC 3, BYT 33,135,33,46,144,100 BYT 15,12 * * LINE # : 17 * BYT 33,142,33,127 ESC30 BYT 0,137 * STAD EQU BSC30 LTAD EQU ESC30 ILS30 ABS LTAD-STAD+1 DBL30 NOP D.2 DEC 2 D.0 DEC 0 * BD30 DEF T3000 DEF T3001 DEF T3002 DEF T3003 DEF T3004 DEF T3005 * SOF30 DEC 1,7,11,17,23,27,33,-1 * END DUPL   92903-18312 1805 S C0122 &TSRD TGP SEGM 10 SUBR SRC             H0101 ״FTN4 LOGICAL FUNCTION TSRD(MEDIA,INDIC,ISTAT,NFORM,KBIN,KSCE,IBUF,IHD), . 92903-16312 REV.1805 780501 C C SOURCE 92903-18312 C C C C ************************************************************** C * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * C ************************************************************** C C C C PROGRAMMER *JCM* HPG C********************************************************************* C* * C* THIS LOGICAL FUNCTION READS A TRANSACTION SPECIFICA- * C* TION STORED ON A GIVEN MEDIA AND TRANSFER ITS CONTENTS IN A BU- * C* FFER SPECIFIED BY THE USER . * C* * C* A TRUE VALUE IS RETURNED IF THE READ OPERATION FAILS * C* A FALSE VALUE IS RETURNED IF THE READ SUCCEEDS * C* * C* DEFINITION OF PARAMETERS : * C* * C* MEDIA(4) : IS A 4 WORDS LONG BUFFER DEFINES THE MEDIA WHERE * C* THE TRANS. SPECS. ARE STORED : * C* -IF A DISC FILE THE FIRST 3 WORDS ARE FILE NAME * C* AND THE FOURTH CR# (0 IF NOT GIVEN) * C* IF MEDIA(1) IS > 0 AN OPEN/REWIND OF THE MEDIA * C* IS PERFORMED * C* IF MEDIA(1) IS < 0 NO OPEN/NO REWIND * C* * C* INDIC : IS A 1 WORD LONG VARIABLE TO SPECIFY WHAT OPERATION * C* IS TO BE PERFORMED : * C* INDIC=0 : READ ONLY HEADER OF LIBRARY * C* =1 : DO NOT READ SPECS ONLY FIND THEM FIRST * C* 10 WORDS OF BINARY SPECS ARE STORED IN * C* KBIN * C* =2 : READ BINARY + SOURCE SPECS * C* =3 : CLOSE MEDIA * C* >3 : READ BINARY SPECS + FIRST 10 WORDS OF * C* SOURCE SPECS IF THE SPECS LENGTH ARE * C* LESS THAN INDIC * C* * C* ISTAT : IS A 1 WORD LONG VARIABLE TO RETURN THE STATUS OF * C* THE PERFORMED OPERATION : * C* ISTAT=0 : NO ERROR * C* =1 : GARBAGE TAPE * C* =2 : SPECS NOT FOUND * C* =3 : OVERFLOW (INDIC>3 ONLY) * C* =4 : ILLEGAL PARAMETER * C* =5 : ERROR IN LOCKING TYPE 0 LU * C* =6 : ERROR IN UNLOCKING TYPE 0 LU * C* =7 : SPECS SECURITY CODE DOESN'T MATCH * C* <0 : FMGR ERROR * C* * C* NFORM : IS A 5 WORD LONG BUFFER TO DEFINE THE SPEC TO READ * C* THE FIRST 3 WORDS CONTAINS THE SPECS NAME IF NO NAME* C* NFORM(1)=-1 * C* NFORM(4)=SPECS # IF -1 NO SPEC # SPECIFIED * C* NFORM(5)=SPECS SECURITY CODE =100000B IF NO SC * C* W THE SPEC FIND MUST HAVE THE SAME NAME OR # AS * C* SPECIFIED * C* IF NFORM(1) AND NFORM(4) ARE EQUAL TO -1 THE FIRST * C* SPECS FOUND WILL BE READ * C* * C* KBIN : ADDRESS OF STORAGE BUFFER FOR BINARY SPECS * C* IF INDIC=1 KBIN(11) MUST BE DECLARED * C* * C* KSCE : ADDRESS OF STORAGE BUFFER FOR SOURCE SPECS * C* IF INDIC>3 OR INDIC=1 KSCE(11) MUST BE DECLARED * C* * C* IBUF : 144 WORDS LONG BUFFER (IDCB BUFFER) * C* * C* IHD : 15 WORDS LONG BUFFER FOR LIBRARY HEADER * C* THE LIBRARY HEADER IS TRANSMITED ONLY IF INDIC=1 * C* OR 2. * C* * C********************************************************************* C* C* C* INTEGER OPEN LOGICAL IRW,IST,CMPW,READF,RWNDF DIMENSION MEDIA(1),NFORM(1),KBIN(1),KSCE(1),IBUF(1),IREG(2) DIMENSION IHD(1) C EQUIVALENCE (REG,IREG) C C INITIALISE LOGICAL FLAGS C C IRW : IF TRUE MUST REWIND C IST : IF FALSE MUST STORE C TSRD=.FALSE. IRW=.FALSE. IST=.TRUE. C C CHECK CALLING PARAMETERS C IF((MEDIA.NE.0).AND.(INDIC.GE.0)) GO TO 100 ISTAT=4 GO TO 900 C C IF SPEC NAME AND # ARE NOT SPECIFIED STORE FIRST SPEC FOUND C 100 IF((NFORM.EQ.-1).AND.(NFORM(4).EQ.-1)) IST=.FALSE. C C REWIND AND OPEN ? C IF(MEDIA.GT.0) IRW=.TRUE. ISAV=MEDIA IF(MEDIA.LT.0) MEDIA=-MEDIA C GO TO 500 C "BC C NORMAL RETURN C 270 ISTAT=0 MEDIA=ISAV RETURN C C C ERROR RETURN C 900 TSRD=.TRUE. MEDIA=ISAV RETURN C C C IF INDIC=3 CLOSE FILE C 500 IF(INDIC.NE.3) GO TO 510 JLU=0 IF(IBUF(3).EQ.0) JLU=IAND(77B,IBUF(4)) CALL CLOSE(IBUF) IF(JLU.EQ.0) GO TO 270 C-----REWIND CALL EXEC(3,400B+JLU) IF(LURQ(100000B,JLU,1).EQ.0) GO TO 270 C-----ERROR, UNABLE TO UNLOCK ANYTHING. ISTAT=6 GO TO 900 C C REWIND /OPEN FILE ? C 510 IF(.NOT.(IRW)) GO TO 525 IF(OPEN(IBUF,ISTAT,MEDIA,0,0,MEDIA(4)).LT.0) GO TO 900 C C IF FILE OPENED CHECK FILE TYPE (0 OR 35) C IF(ISTAT.EQ.35) GO TO 523 IF(ISTAT.EQ.0) GO TO 512 C C-----GO TO ERROR RETURN. C ISTAT=1 GO TO 900 C C-----TYPE 0 FILE. C C-----GET LU NO. C 512 JLU=IAND(377B,IBUF(4)) C C-----LOCK IT W/O WAIT. C IF(LURQ(100001B,JLU,1).EQ.0) GO TO 523 C C-----ERROR, UNABLE TO LOCK IT, CLOSE IT, THEN EXIT. CALL CLOSE(IBUF) C ISTAT=5 GO TO 900 C C REWIND C 523 IF(RWNDF(IBUF,ISTAT)) GO TO 900 C C READ LIBRARY HEADER C IF(READF(IBUF,ISTAT,KBIN,16,LEN)) GO TO 900 IF(LEN.NE.-1) GO TO 524 ISTAT=2 GO TO 900 524 IF(LEN.EQ.15) GO TO 527 ISTAT=1 GO TO 900 527 IF(INDIC.GT.2) GO TO 525 CALL MOVEW(KBIN,IHD,15) IF(INDIC.EQ.0) GO TO 270 C C C READ FIRST RECORD C 525 IF(READF(IBUF,ISTAT,KBIN,11,LEN)) GO TO 900 C C END OF FILE ? C 530 IF(LEN.NE.-1) GO TO 540 ISTAT=2 GO TO 900 C 540 IF(LEN.EQ.10) GO TO 550 ISTAT=1 GO TO 900 C C IF INDIC > 3 CHECK IF SUFFICIENT SPACE C 550 IF(INDIC.LT.4) GO TO 560 IF(KBIN.LE.INDIC) GO TO 560 ISTAT=3 GO TO 900 C C CHECK IF NAME AND # MATCHES C 560 IF(CMPW(KBIN(2),NFORM,3)) IST=.FALSE. IF(KBIN(5).EQ.NFORM(4)) IST=.FALSE. IF(IST) GO TO 562 IF(NFORM(5).EQ.100000B) GO TO 562 IF(KBIN(6).EQ.NFORM(5)) GO TO 562 ISTAT=7 GO TO 900 C 562 K=(KBIN-10)/127 IR=(KBIN-10)-K*127 C C READ BINARY SPECS C L=128 IF(INDIC.EQ.1) L=1 DO 600 I=1,K+1 IF((I.EQ.K+1).AND.(IR.EQ.0)) GO TO 610 IOF=11+(I-1)*127 IF(INDIC.EQ.1) IOF=11 IF(READF(IBUF,ISTAT,KBIN(IOF),L,LEN)) GO TO 900 580 IF(L.EQ.1) GO TO 600 ILX=127 IF(I.EQ.K+1) ILX=IR IF(LEN.EQ.ILX) GO TO 600 ISTAT=1 GO TO 900 600 CONTINUE C C READ SOURCE SPECS C 610 L=128 IF((INDIC.EQ.1).OR.(INDIC.GT.3)) L=10 DO 700 I=1,15 IF((I.GT.1).AND.(L.EQ.10)) L=1 IOF=1+(I-1)*127 IF(L.EQ.1) IOF=11 IF((INDIC.EQ.2).AND.(I.EQ.1)) IOF=128 IF(READF(IBUF,ISTAT,KSCE(IOF),L,LEN)) GO TO 900 620 IF(L.NE.128) GO TO 622 ILX=127 IF(I.EQ.15) ILX=37 IF(LEN.EQ.ILX) GO TO 622 ISTAT=1 GO TO 900 622 IF((INDIC.NE.2).OR.(I.NE.1)) GO TO 700 CALL MOVEW(KSCE(128),KSCE,6) CALL MOVEW(KSCE(148),KSCE(21),107) 700 CONTINUE C C SPECS FOUND ? C IF(IST) GO TO 525 C GO TO 270 C C C END END$ M  92903-18313 1805 S C0122 &TSWR TGP SEGM 10 SUBR SRC             H0101 FTN4 LOGICAL FUNCTION TSWR(MEDIA,INDIC,ISTAT,KBIN,KSCE,IBUF,IHD), 92903 C-16313 REV.1805 780503 C C SOURCE 92903-18313 C C C C ************************************************************** C * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * C ************************************************************** C C C C PROGRAMMER *JCM* HPG C********************************************************************* C* * C* THIS LOGICAL FUNCTION WRITES A TRANSACTION SPECIFICA- * C* TION ON A GIVEN MEDIA SPECIFIED BY THE USER . * C* * C* A TRUE VALUE IS RETURNED IF THE WRITE OPERATION FAILS * C* A FALSE VALUE IS RETURNED IF THE WRITE SUCCEEDS * C* * C* DEFINITION OF PARAMETERS : * C* * C* MEDIA(4) : IS A 4 WORDS LONG BUFFER DEFINES THE MEDIA WHERE * C* THE TRANS. SPECS. MUST BE STORED : * C* -IF A DISC FILE THE FIRST 3 WORDS ARE FILE NAME * C* AND THE FOURTH CR# (0 IF NOT GIVEN) * C* IF MEDIA(1) IS > 0 AN OPEN/REWIND OF THE MEDIA * C* IS PERFORMED * C* IF MEDIA(1) IS < 0 NO OPEN/NO REWIND * C* * C* INDIC : IS A 1 WORD LONG VARIABLE TO SPECIFY WHAT OPERATION * C* IS TO BE PERFORMED : t * C* INDIC=0 : A NEW MEDIA IS USED (IF DISC FILE * C* CREATE FILE) * C* =1 : OLD MEDIA * WRITE THE SPECS AT CURRENT * C* POSITION IN FILE * C* =2 : OLD MEDIA * PERFORM A BACKSPACE BEFORE * C* WRITING THE SPECS * C* =3 : CLOSE MEDIA * WRITE EOF * C* =4 : CREATE NEW MEDIA ,WRITE HEADER * C* * C* ISTAT : IS A 1 WORD LONG VARIABLE TO RETURN THE STATUS OF * C* THE PERFORMED OPERATION : * C* ISTAT=0 : NO ERROR * C* =1 : FILE TYPE IS NOT GOOD * C* =2 : EOF FOUND * C* =4 : ILLEGAL PARAMETER * C* =5 : ERROR IN LOCKING TYPE 0 LU * C* =6 : ERROR IN UNLOCKING TYPE 0 LU * C* <0 : FMGR ERROR * C* * C* * C* KBIN : ADDRESS OF STORAGE BUFFER FOR BINARY SPECS * C* * C* KSCE : ADDRESS OF STORAGE BUFFER FOR SOURCE SPECS * C* * C* IBUF : 144 WORDS LONG BUFFER (IDCB BUFFER) * C* * C* IHD : 15 WORDS LONG BUFFER CONTAINING THE LIBRARY HEADER * C* WRITTEN ON THE MEDIA ONLY IF INDIC=0 * C* ik * C********************************************************************* C* C* C* INTEGER CREATE,OPEN LOGICAL IRW,WRITF,POSNT,RWNDF,POST DIMENSION MEDIA(1),KBIN(1),KSCE(1),IBUF(1),ISIZE(2),IHD(1) C C C INITIALISE LOGICAL FLAGS C C IRW : IF TRUE MUST REWIND C TSWR=.FALSE. IRW=.FALSE. K=(KBIN-10)/127 IR=(KBIN-10)-127*K C C C CHECK CALLING PARAMETERS C IF((MEDIA.NE.0).AND.(INDIC.GE.0)) GO TO 100 ISTAT=4 GO TO 900 C C REWIND AND OPEN ? C 100 IF(MEDIA.GT.0) IRW=.TRUE. ISAV=MEDIA IF(MEDIA.LT.0) MEDIA=-MEDIA C GO TO 500 C C NORMAL RETURN C 270 ISTAT=0 MEDIA=ISAV RETURN C C C ERROR RETURN C 900 TSWR=.TRUE. MEDIA=ISAV RETURN C C C IF INDIC=3 CLOSE FILE C 500 IF(INDIC.NE.3) GO TO 505 IF(WRITF(IBUF,ISTAT,IHD,-1)) GO TO 900 JLU=0 C-----TYPE 0 FILE? IF(IBUF(3).EQ.0) JLU=IAND(77B,IBUF(4)) CALL CLOSE(IBUF) IF(JLU.EQ.0) GO TO 270 C-----TYPE 0 FILE C-----REWIND, STANDBY CALL EXEC(3,500B+JLU) C-----UNLOCK IT BEFORE EXITING IF(LURQ(100000B,JLU,1).EQ.0) GO TO 270 C-----ERROR, UNABLE TO UNLOCK IT. ISTAT=6 GO TO 900 C C IF INDIC=0 CREATE DISC FILE C 505 IF((INDIC.NE.0).AND.(INDIC.NE.4)) GO TO 510 IF(OPEN(IBUF,ISTAT,MEDIA,0,0,MEDIA(4)).LT.0) GO TO 508 IF(ISTAT.NE.0) GO TO 506 C-----TYPE 0 FILE? IF(IBUF(3).EQ.0) GO TO 517 506 ISTAT=-2 GO TO 900 508 IF(ISTAT.NE.-6) GO TO 506 ISIZE=128 IF(CREAT(IBUF,ISTAT,MEDIA,ISIZE,35,0,MEDIA(4)).LT.0) GO TO 900 C C OPEN/REWIND ? C 510 IF(.NOT.(IRW)) GO TO 520 IF(OPEN(IBUF,ISTAT,MEDIA,0,0,MEDIA(4)).LT.0) GO TO 900 C-----TYPE 0 FILE? IF(ISTAT.EQ.35) GO TO 519 IF(ISTAT.EQ.0) GO TO 517 ISTAT=1 GO TO 900 C C-----TYPE 0 FILE, GET LU NO. C 517 JLU=IAND(377B,IBUF(4)) C-----LOCK IT W/O WAIT. IF(LURQ(100001B,JLU,1).EQ.0) GO TO 519 C-----ERROR, UNABLE TO LOCK IT. C-----CLOSE IT BEFORE EXITING CALL CLOSE(IBUF) ISTAT=5 GO TO 900 C 519 IF(RWNDF(IBUF,ISTAT)) GO TO 900 C C BACKSPACE ? C 520 IF((INDIC.NE.0).AND.(INDIC.NE.4)) GO TO 525 IF(WRITF(IBUF,ISTAT,IHD,15)) GO TO 900 IF(INDIC.EQ.4) GO TO 270 525 IF(INDIC.NE.2) GO TO 530 IF(POSNT(IBUF,ISTAT,-1)) GO TO 900 C C WRITE FIRST RECORD C 530 IF(WRITF(IBUF,ISTAT,KBIN,10)) GO TO 900 C C WRITE BINARY SPECS C 540 L=127 DO 560 I=1,K+1 IF((I.EQ.K+1).AND.(IR.EQ.0)) GO TO 570 IF(I.EQ.K+1) L=IR IF(WRITF(IBUF,ISTAT,KBIN(11+(I-1)*127),L)) GO TO 900 560 CONTINUE C C WRITE SOURCE SPECS C 570 L=127 DO 600 I=1,15 IF(I.EQ.15) L=37 IF(WRITF(IBUF,ISTAT,KSCE(1+(I-1)*127),L)) GO TO 900 600 CONTINUE C GO TO 270 C END END$ î  92903-18314 1805 S C0122 &ILIN              H0101 YFTN4 FUNCTION ILIN(IMAI,ITN,IOP), 92903-16314 REV.1805 770722 * * SOURCE 92903-18314 * C C C ************************************************************** C * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * C ************************************************************** C C C C*************************************************************** C* * C* THIS FUNCTION IS USED TO FIND AN ENTRY * C* IN THE IMAI ARRAY WHICH ITEM# MATCHES A GIVEN # (ITN) AND * C* WHICH OPERATION CODE MATCHES A GIVEN OPERATION CODE (IOP) * C* * C* IF THE ENTRY IS FOUND THE LINE #OF THE ARRAY * C* IS RETURNED OTHERWISE IF NOT FOUND -1 IS RETURNED * C* * C*************************************************************** C* C* DIMENSION IMAI(45,5) DO 100 I=1,45 K=IAND(IMAI(I,1),377B) L=IAND(IMAI(I,2),7) IF((K.EQ.ITN).AND.(L.EQ.IOP)) GO TO 120 100 CONTINUE I=-1 120 ILIN=I RETURN END END$ Y  92903-18315 1805 S C0122 &ITEQU              H0101 FTN4 SUBROUTINE ITEQU(ITN,KBUF), 92903-16315 REV.1805 770722 C C SOURCE 92903-18315 C C C C ************************************************************** C * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * C ************************************************************** C C C C********************************************************************* C* * C* THIS SUBROUTINE IS USED TO SEARCH ALL THE KEY * C* ITEMS # WHICH CORRESPONDS TO THE SAME KEY IN AN IMAGE DATA * C* BASE * C* ITN IS THE KEY ITEM # IN THE DATA SET * C* KBUF IS A 5 WORDS LONG BUFFER CONTAINING THE * C* ITEM #'S EQUIVALENTS * C* * C* IF AN ERROR IS DETECTED KBUF(1)=-1 ON RETURN * C* * C********************************************************************* C DIMENSION KBUF(1),IBUF(12) C C C INITIALISE KBUF C DO 100 I=1,5 100 KBUF(I)=0 C C PERFORM CHECKS - ITEM IS A KEY C CALL DBINF(2HI ,2,ITN,IBUF) IF(IBUF.NE.0) GO TO 130 IF(IAND(IBUF(5),177400B).EQ.0) GO TO 130 CALL DBINF(2HS ,2,IBUF(9),IBUF) IF(IBUF.NE.0) GO TO 130 C C CHECKS OK NOW BUILD KBUF C J=1 IF(IGET1(IBUF,10).NE.1HD) GO TO 110 C C SEARCH MASTER KEY ITEM # LINKED C CALL DBINF(2HS ,4,ITN,IBUF) IF(IBUF.NE.0) GO TO 130 IF(IBUF(2).EQ.0) GO TO 125 KBUF(J)=IBUF(4) J=J+1 IBUF=IBU)  F(4) GO TO 115 C C SEARCH IN DETAIL D.S LINKED C 110 IBUF=ITN 115 CALL DBINF(2HS ,4,IBUF,IBUF) IF(IBUF.NE.0) GO TO 130 IF(IBUF(2).EQ.0) GO TO 125 DO 120 I=1,IBUF(2) IF(IBUF(2*I+2).EQ.ITN) GO TO 120 KBUF(J)=IBUF(2*I+2) J=J+1 120 CONTINUE C C NORMAL RETURN C 125 RETURN C C ERROR RETURN C 130 KBUF=-1 RETURN C END END$   92903-18317 1805 S C0122 &FSTAR TGP SEGM 13 SUBR SRC             H0101 FTN4 SUBROUTINE FSTAR(IBUF), 92903-16317 REV.1805 770722 C C SOURCE 92903-18317 C C C C ************************************************************** C * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * C ************************************************************** C C C C********************************************************************* C* * C* THIS SUBROUTINE IS USED TO RESET THE IBUF BUFFER * C* USED TO PRINT THE 3070 LABEL PLATE * C* * C********************************************************************* C DIMENSION IBUF(1) DO 100 I=1,38 100 IBUF(I)=2H IBUF(1)=2H* IBUF(8)=2H * IBUF(16)=2H* IBUF(23)=2H * IBUF(31)=2H* IBUF(38)=2H * RETURN END END$ >  92903-18318 1805 S C0122 &FILK TGP SEGM 13 SUBR SRC             H0101 ݠFTN4 SUBROUTINE FILK(K,N,IP,IBUF,IFORM), 92903-16318 REV.1805 770722 C C SOURCE 92903-18318 C C C C ************************************************************** C * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * C ************************************************************** C C C C********************************************************************* C* * C* THIS SUBROUTINE IS USED TO INSERT THE 3070 SFK'S * C* LABELS INTO THE IBUF BUFFER USEDFOR THE LINE PRINTOUT * C* * C* PARAMETERS : * C* K IS SFK # * C* N IS CHAR OFFSET IN IBUF N<0 MOVE USER TEXT * C* N>0 MOVE SFK LABEL * C* IP = 0 NON PREFIXED KEY * C* = 1 PREFIXED KEY * C* IBUF BUFFER USED TO PRINT LABEL * C* IFORM BUFFER WHERE ARE STORED LABELS * C* * C* * C********************************************************************* C DIMENSION IBUF(1),IFORM(1) IGETB(IF)=IAND(IALF2(IGET1(IFORM,IF)),377B) DO 100 I=1,10 IOF=87+(330*IP)+(I-1)*33 IK=0 IM=1 IN=IGETB(IOF+1) IF(IN.EQ.40B) GO TO 110 IM=10 IK=IN-48 110 IN=IGETB(IOF) IF(IN.EQ.40B) GO TO 120 IK=(IN-48)*IM+IK 120 M  IF(IK.NE.K) GO TO 100 IF(N.GT.0) CALL MOVCA(IFORM,IOF+21,IBUF,N,12) IF(N.LT.0) CALL MOVCA(IFORM,IOF+2,IBUF,-N,16) GO TO 200 100 CONTINUE 200 RETURN C 5000 STOP 3354 END END$ DO 100 I=1,38 100 IBUF(I)=2H IBUF(1)=2H* IBUF(8)=2H * IBUF(16)=2H* IBUF(23)=2H * IBUF(31)=2H* IBUF(38)=2H * RETURN END END$ I   92903-18319 1805 S C0122 /TGP TR FILE TO RP TGP             H0101 w:SV,3,9,IH :** :** /TGP (HP 92903-18319 REV.1805 780601) :** :RP,TGP::-2 :RP,TGP0::-2 :RP,TGP1::-2 :RP,TGP2::-2 :RP,TGP3::-2 :RP,TGP4::-2 :RP,TGP5::-2 :RP,TGP6::-2 :RP,TGP7::-2 :RP,TGP8::-2 :RP,TGP9::-2 :RP,TGPI0::-2 :RP,TGPI1::-2 :RP,TGPI2::-2 :RP,TGPI3::-2 :SV,9G,,IH   92903-18320 1805 S C0122 \TGP TR FILE TO OF TGP             H0101 u:SV,3,9,IH :** :** \TGP (HP 92903-18320 REV.1805 780601) :** :RP,,TGP::-2 :RP,,TGP0::-2 :RP,,TGP1::-2 :RP,,TGP2::-2 :RP,,TGP3::-2 :RP,,TGP4::-2 :RP,,TGP5::-2 :RP,,TGP6::-2 :RP,,TGP7::-2 :RP,,TGP8::-2 :RP,,TGP9::-2 :RP,,TGPI0::-2 :RP,,TGPI1::-2 :RP,,TGPI2::-2 :RP,,TGPI3::-2 :SV,9G,,IH H  92903-18321 1805 S C0122 >TGP TGP LOADR COMMAND FILE             H0101 3* * >TGP (HP 92903-18321 REV.1805 780601) * RE,%TGP SE,%TGPLB RE,%TGP0 SE,%TGPLB RE,%TGP1 SE,%TGPLB RE,%TGP2 SE,%TGPLB RE,%TGP3 SE,%TGPLB RE,%TGP4 SE,%TGPLB RE,%TGP5 SE,%TGPLB RE,%TGP6 SE,%TGPLB RE,%TGP7 SE,%TGPLB RE,%TGP8 SE,%TGPLB RE,%TGP9 SE,%TGPLB RE,%TGP10 SE,%TGPLB RE,%TGP11 SE,%TGPLB RE,%TGP12 SE,%TGPLB RE,%TGP13 SE,%TGPLB   92903-18350 1805 S C0122 &TGP              H0101 OoFTN4 PROGRAM TGP(3), 92903-16350 REV.1805 7803133 C C SOURCE 92903-18350 C C C ************************************************************** C * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * C ************************************************************** C C C C PRGMR : JEAN CHARLES MIARD (HPG) C C********************************************************************* C* * C* THIS IS THE MAIN MODULE OF THE TGP PROGRAM . * C* TGP IS USED TO BUILD A TRANSACTION SPECIFICATION THRU AN INTER- * C* ACTIVE DIALOG WITH THE USER . * C* THIS DIALOG APPEARS AS A SUCCESSION OF SCREEN MASKS * C* DISPLAYED ON THE TERMINAL ON WHICH THE USER MUST FILL IN THE * C* ANSWERS TO THE QUESTIONS. * C* THE TRANSACTION SPECIFICATION CREATED OR MODIFIED WILL * C* BE USED BY THE TMP PROGRAM TO DRIVE THE TRANSACTION ON THE 3070 * C* TERMINALS . * C* TGP CONSISTS OF ONE SHORT MAIN AND 14 SEGMENTS TGP0 * C* TO TGP13 . A COMMON ZONE IS USED TO PASS THE INFORMATION BETWEEN * C* SEGMENTS . * C* FOLLOWING IS THE MEANING OF THE COMMON VARIABLES : * C* * C* ILU : TERMINAL INTERACTIVE LU. * C* ISCRN : ACTUAL SCREEN #. * C* IQST : ACTUAL QUESTION # . * C* ISKIP : GENERAL PURPOSE VARIABLE . * C* INDIC : GENERAL PURP'OSE VARIABLE USED TO TELL A SEGMENT * C* WHEN SCHEDULED WHAT TASK IT MUST PERFORM . * C* IFORM : BUFFER TO STORE IN ASCII FORMAT THE ANSWERS TO * C* SCREENS 3,4,6,7,8 AND 9 . * C* JFORM : BUFFER TO STORE IN ASCII FORMAT THE ANSWERS TO * C* SCREENS 10,11,12,13,14,15 . * C* MFORM : BUFFER TO STORE IN ASCII FORMAT THE ANSWERS TO * C* SCREEN 16 . * C* LFORM : BUFFER TO STORE IN ASCII FORMAT THE ANSWERS TO * C* SCREENS 17 AND 18 . * C* ITT : TRANSACTION TYPE (SEE ERS) * C* IKEY : BUFFER TO STORE IN BINARY THE MEANING OF THE SFK'S * C* FOR MORE DETAILS SEE TGP2 . * C* IUMAX : # OF U QUESTIONS IN THIS TRANSACTION * C* IMMAX : # OF M QUESTIONS IN THIS TRANSACTION * C* IMODB : = 0 MEANS 3070A VERSION OF TGP . * C* = 1 MEANS 3070B VERSION OF TGP . * C* ILITE : BUFFER TO ALLOCATE THE PROMPTING LIGHTS # . FOR MORE * C* DETAILS SEE LIGHT SUBROUTINE . * C* IMAI : BUFFER TO STORE THE IMAGE INFORMATION . FOR MORE * C* DETAILS SEE TGP12 . * C* IMFLG : IMAGE FLAG SEE TGP12 * C* IMAS : MASTER DATA SET # ON WHICH A FIND HAS BEEN REQUESTED * C* IMDT : DETAIL DATA SET # ON WHICH A FIND HAS BEEN REQUESTED * C* IMKY : MASTER KEY ITEM # FOR A FIND . * C* KFORM : BUFFER TO STORE THE TRANSACTION SPECIFICATION IN * C* BINARY . (USED BY TMP) * C* ILIBR : BUFFER TO STORE IN ASCII FORMAT THE ANSWERS TO * C* SCREENS 19 AND 20 . 6 * C* NIMAG : = 0 IMAGE VERSION OF TGP * C* = 1 NON IMAGE VERSION OF TGP * C* * C* SCREENS 0,1,2 AND 5 ARE EXPLANATION SCREENS . * C* * C* WARNING !! : THE ORIGINAL SCREEN # 8 DO NOT EXIST ANY MORE SO * C* IN THE CODE WE ALWAYS SKIP FROM SCREEN 7 TO 9 BUT * C* ON THE SCREENS PRINTED FOR THE USER SCREEN # 8 * C* EXIST . SO PRINTED SCREEN # 8 IS IN REALITY SCREEN * C* # 9 IN THE CODE , SCREEN # 9 IS IN THE CODE SCREEN * C* # 10 AND SO ON . * C* * C* * C* THE ONLY TASK PERFORMED BY THE MAIN IS TO GET THE * C* TERMINAL INTERACTIVE LU , INITIALISE SOME VARIABLES AND CALL * C* SEGMENT TGP0 TO PRINT SCREEN # 0 . * C* * C* TO SCHEDULE THE 3070A VERSION OF TGP EXECUTE : * C* * C* * ON,TGP * C* * C* FOR THE 3070B VERSION : *ON,TGP,,1 * C* * C********************************************************************* C C C **** DECLARATIONS COMMON VARIABLES ******** C COMMON ILU,ISCRN,IQST,ISKIP,INDIC COMMON IFORM(494) COMMON JFORM(980) COMMON MFORM(16) COMMON LFORM(39) COMMON ITT COMMON IKEY(11,3) COMMON IUMAX,IMMAX COMMON IMODB }^ COMMON ILITE(15) COMMON IMAI(45,5) COMMON IMFLG,IMAS,IMDT,IMKY COMMON KFORM(1065) COMMON ILIBR(61) COMMON NIMAG C C LOCAL VRIABLES ********** C DIMENSION INAME(3) C DATA INAME/2HTG,2HP0,2H / C C GET INTERACTIVE LU C CALL RMPAR(ILITE) ILU=ILITE(1) IF(ILU.EQ.0) ILU=1 C C-----LOCK ILU WITH WAIT. C CALL LURQ(1,ILU,1) C C INITIALISE IFORM TO BLANK C C WARNING ***** IMAGE VERSION OF TGP ********* C C IMODB=ILITE(2) C C-----ALWAYS MAKE IMODB=1 TO FORCE THE 3070B VERSION OF 'TGP' C IMODB=1 NIMAG=0 ISKIP=2H DO 10 I=1,22 10 IFORM(I)=2H C C CALL SCREEN # 0 C ISCRN=0 IQST=1 INDIC=0 CALL EXEC(8,INAME) C C FOR IMAGE VERSION OF TGP LOAD RUN TABLE . C CALL AIRUN C END END$ v  92903-18351 1805 S C0222 &TGPOA              H0102 ASMB,R NAM TGP0,5 92903-16351 REV.1805 780410 * * SOURCE 92903-18351 * SPC 2 ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** SPC 2 SUP HED * -TGP0- * * PRGMR : JEAN CHARLES MIARD (HPG) * ********************************************************************** * * * THIS IS A SEGMENT OF THE TGP PROGRAM USED TO WRITE ON * * THE 2640/2645 DISPLAY THE SCREEN MASKS USED TO COLLECT INFORMA- * * TION TO BUILD A TRANSACTION SPECIFICATION . * * * * TGP0 PRINTS SCREEN 0 THRU 7 ACCORDING ISCRN VALUE AND * * THEN LOAD THE REQUIRED SEGMENT TO ANALYSE THE USER'S ANSWERS . * * BEFORE PRINTING THE SCREENS TGP0 INCLUDES IN THEM * * THE OLD ANSWERS STORED IN IFORM (COME BACK MODE OR MODIFY) * * SOME SCREENS ARE DYNAMIC AND ONLY PARTS OF THE TOTAL * * SCREEN ARE PRINTED . * * * * IF INDIC = -77 THE SCREEN IS TO BE PRINTED WITHOUT ERASING * * THE DISPLAY BEFORE (HELP MESSAGE) * * * ********************************************************************** * * * ENT TGP0 ENTRY POINT EXT EXEC EXT TGP MAIN PROGRAM EXT MOVCX SUBR. MOVES ANSWERS IN UNPRO. FIELDS EXT &MVW MOVES WORDS * * DECLARATIONS COMMON VARIABLE[WS ***************** * COM ILU,ISCRN,IQST,ISKIP,INDIC COM IFORM(494) ANSWER STORAGE COM JFORM(980) ANSWER STORAGE COM MFORM(16) ANSWER STORAGE COM LFORM(39) ANSWER STORAGE COM ITT TRANS. TYPE COM IKEY(33) COM IUMAX #OF U QUESTIONS COM IMMAX #OF M QUESTIONS COM IMODB (0/1) 3070A/3070B COM ILITE(15) COM IMAI(225) IMAGE INFO STORAGE COM IMFLG,IMAS,IMDT,IMKY COM KFORM(1065) COM ILIBR(61) COM NIMAG * * *FIND SCREEN # TO DISPLAY * TGP0 LDA INDIC GET INDICATOR CPA .D77 IS IT PRINT FOR HELP RSS YES JMP CONT NO JUMP CLA STA CL01 STA CL02 STA CL03 STA CL04 STA CL05 STA CL06 STA CL07 CONT LDA ASCR ADA ISCRN JMP 0,I * * TABLE OF ADDRESS FO R SCREENS * ASCR DEF *+1,I DEF SCR0 DEF SCR1 DEF SCR2 DEF SCR3 DEF SCR4 DEF SCR5 DEF SCR6 DEF SCR6 DEF SCR8 * * * DATA SECTION * D.0 DEC 0 D.2 DEC 2 D.8 DEC 8 .D77 DEC -77 * ************************************************************************ * * SCREEN # 0 SCREEN SHOWING THE SOFT KEYS ASSIGNEMENT * ************************************************************************ * * SCR0 JSB EXEC WRITE EXEC CALL DEF *+5 RETURN POINT DEF D.2 CODE EXEC DEF ILU CONTROL WORD DEF BSCR0 BUF. LOCATION DEF ILSC0 BUF.LENGTH JMP CANS GO TO LOAD SEGMENT TO ANALYSE ANSWERS * * DATA SCREEN 0 * BSCR0 BYT 33,130 FORMAT OFF BYT 33,155 MEMORY UNLOCK BYT 33,110 HOME UP CURSOR CL01 BYT 33,112 CLEAR DISPLAY BYT 33,46 SET 2645 SWITCHES ASC 10,s0a0b0c1d0e0f1g1h0j0 BYT 113,0 BYT 33,46,153,61,102 SET BLOCK MODE * * SET 2645 SOFT KEYS * BYT 33,46,146,61,141,61,153,61,114,11 NEXT FIELD BYT 33,46,146,61,141,62,153,62,114,33,151 PREVIOUS FIELD BYT 33,46,146,61,141,63,153,61,114,40 NOT ASSIGNED BYT 33,46,146,62,141,64,153,61,114,141 ABORT BYT 33,46,146,61,141,65,153,64,114,33,110,33,144 NEXT SCREEN BYT 33,46,146,61,141,66,153,65,114,163,33,110,33,144 PREVIOUS BYT 33,46,146,61,141,67,153,65,114,150,33,110,33,144 HELP BYT 33,46,146,61,141,70,153,65,114,151,33,110,33,144 INSERT * * LINE # : 1 * BYT 33,133 ASC 1, BYT 33,135 BYT 33,46,141,53,61,70,103,0 POSITION CURSOR - 21 BYT 33,46,144,106 ASC 19, TRANSACTION GENERATOR PROGRAM READY ! BYT 40,0 BYT 15,12 * * LINE # : 2 * BYT 15,12 * * LINE # : 3 * BYT 33,46,141,53,61,60,103,0 POSITION CURSOR - 11 ASC 22,Please, set in place the following label on ASC 9,the soft keys pad. BYT 15,12 * * LINE # : 4 * BYT 15,12 * * LINE # : 5 * BYT 33,51,102,16 BYT 33,46,141,53,61,64,103,0 POSITION CURSOR - 15 ASC 22,R,,,,,,,,,,,TR,,,,,,,,,,,TR,,,,,,,,,,,TR,,,, ASC 4,,,,,,,,T BYT 15,12 * * LINE # : 6 * BYT 33,46,141,53,61,64,103,0 POSITION CURSOR - 15 BYT 33,51,102,16 BYT 56,17 ASC 5,Next Field BYT 40,16 ASC 1,.. BYT 40,17 ASC 5, Previous BYT 16,56 ASC 1,. BYT 17,40 BYT 33,46,141,53,60,70,103,0 POSITION CURSOR - 52 BYT 16,40 ASC 1,.. BYT 17,40 ASC 5, Abort BYT 16,56 BYT 15,12 * * LINE # : 7 * BYT 33,46,141,53,61,64,103,0 POSITION CURSOR - 15 BYT 33,51,102,16 BYT 56,0 BYT 33,46,144,112 ASC 2, BYT 17,146 ASC 3,1 BYT 33,46,144,100,16,56 BYT 56,0 BYT 33,46,144,112 ASC 2, BYT 40,17 ASC 3,f2 BYT 33,46,144,100,16,56 BYT 56,0 BYT 33,46,144,112,17,40 ASC 5, f3 BYT 33,46,144,100,16,56 BYT 56,0 BYT 33,46,144,112,17,40 ASC 5, f4 BYT 33,46,144,100,16,56 BYT 15,12 * * LINE # : 8 * BYT 33,46,141,53,61,64,103,0 POSITION CURSOR - 15 BYT 33,51,102,16 BYT 56,17 ASC 5, (TAB) BYT 40,16 ASC 1,.. BYT 17,40 ASC 5, Field BYT 16,56 ASC 2,. BYT 17,40 ASC 3, BYT 40,16 ASC 1,.. BYT 17,40 ASC 5, Program BYT 16,56 BYT 15,12 * * LINE # : 9 * BYT 33,46,141,53,61,64,103,0 POSITION CURSOR - 15 BYT 33,51,102,16 ASC 22,F,,,,,,,,,,,GF,,,,,,,,,,,GF,,,,,,,,,,,GF,,,, ASC 4,,,,,,,,G BYT 15,12 * * LINE # : 10 * BYT 33,51,102,16 BYT 33,46,141,53,61,64,103,0 POSITION CURSOR - 15 ASC 22,R,,,,,,,,,,,TR,,,,,,,,,,,TR,,,,,,,,,,,TR,,,, ASC 4,,,,,,,,T BYT 15,12 * * LINE # : 11 * BYT 33,46,141,53,61,64,103,0 POSITION CURSOR - 15 BYT 33,51,102,16 BYT 56,17 ASC 5,Next Scree BYT 156,16 ASC 1,.. BYT 40,17 ASC 4, Previou BYT 163,16 ASC 2, .. BYT 17,40 ASC 4, Help BYT 16,40 ASC 1,.. BYT 40,17 ASC 4, Insert BYT 40,16 ASC 1, . BYT 15,12 * * LINE # : 12 * BYT 33,46,141,53,61,64,103,0 POSITION CURSOR - 15 BYT 33,51,102,16 BYT 56,0 BYT 33,46,144,112 ASC 2, BYT 17,146 ASC 3,5 BYT 33,46,144,100,16,56 BYT 56,0 BYT 33,46,144,112 ASC 2, BYT 40,17 ASC 3,f6 BYT 33,46,144,100,16,56 BYT 56,0 BYT 33,46,144,112,17,40 ASC 5, f7 BYT 33,46,144,100,16,56 BYT 56,0 BYT 33,46,144,112,17,40  ASC 5, f8 BYT 33,46,144,100,16,56 BYT 15,12 * * LINE # : 13 * BYT 33,46,141,53,61,64,103,0 POSITION CURSOR - 15 BYT 33,51,102,16 BYT 56,17 ASC 5, (ENTER) BYT 40,16 ASC 1,.. BYT 40,17 ASC 4, Screen BYT 40,16 ASC 2, .. BYT 17,40 BYT 33,46,141,53,60,71,103,0 POSITION CURSOR - 53 BYT 16,56 BYT 56,17 ASC 5,a Question BYT 40,16 BYT 56,0 BYT 15,12 * * LINE # : 14 * BYT 33,46,141,53,61,64,103,0 POSITION CURSOR - 15 BYT 33,51,102,16 ASC 22,F,,,,,,,,,,,GF,,,,,,,,,,,GF,,,,,,,,,,,GF,,,, ASC 4,,,,,,,,G BYT 15,12 * * LINE # : 15 * BYT 15,12 * * LINE # : 16 * BYT 15,12 * * LINE # : 17 * BYT 15,12 * * LINE # : 18 * ASC 22, - During execution of this program, onc ASC 15,e all correct answers have bee BYT 156,0 BYT 15,12 * * LINE # : 19 * ASC 22, provided for a given screen, press th ASC 15,e NEXT SCREEN key to continue. BYT 15,12 * * LINE # : 20 * BYT 15,12 * * LINE # : 21 * BYT 15,12 * * LINE # : 22 * BYT 33,46,141,53,64,70,103,0 POSITION CURSOR - 49 BYT 33,46,144,112 ASC 3, Press BYT 40,0 BYT 33,46,144,113 ASC 5,NEXT SCREE BYT 116,0 BYT 33,46,144,112 ASC 2, key BYT 40,0 ESCR0 BYT 15,12 * STAD0 EQU BSCR0 STARTING ADDRESS DATA SCREEN 0 LTAD0 EQU ESCR0 LAST ADDRESS DATA SCREEN 0 ILSC0 ABS LTAD0-STAD0+1 DATA SCREEN 0 LENGTH * ************************************************************************ * * SCREEN # 1 ESPLANATORY SCREEN INTRODUCTION TO TGP * ************************************************************************* * * SCR1 JSB EXEC WRITE SCREEN DEF *+5 RETURN POINT  DEF D.2 CODE EXEC DEF ILU CONTROL WORD DEF BSCR1 BUF. LOCATION DEF ILSC1 BUF. LENGTH JMP CANS LOAD SEGMENT TO ANALYSE USERS ANSWER * * DATA SCREEN # 1 * * * LINE # : 1 * BSCR1 BYT 33,130 FORMAT OFF BYT 33,110 HOME UP CURSOR CL02 BYT 33,112 CLEAR DISPLAY BYT 33,133 ASC 1, BYT 33,135 BYT 33,46,141,53,61,64,103,0 POSITION CURSOR - 17 ASC 21,Screen # 1 TRANSACTION GENERATION OVERVIEW BYT 15,12 * * LINE # : 2 * BYT 15,12 * * LINE # : 3 * ASC 22, A typical printed paper form, identified b ASC 17,y a name, asks some questions only BYT 15,12 * * LINE # : 4 * ASC 22, once and others repeatedly. Similarly, onc ASC 16,e a transaction has been accesse BYT 144,0 BYT 15,12 * * LINE # : 5 * ASC 22, on the HP3070 by number and security code, ASC 17, the same two types of questions BYT 15,12 * * LINE # : 6 * ASC 7, can be asked BYT 072,0 BYT 15,12 * * LINE # : 7 * BYT 15,12 * * LINE # : 8 * ASC 22, We define the questions to be answered o ASC 6,nly once as BYT 33,46,144,104 ASC 5,U-question BYT 163,0 BYT 33,46,144,100 ASC 4, (Unique BYT 51,0 BYT 15,12 * * LINE # : 9 * ASC 22, and the questions asked more than once a ASC 1,s BYT 33,46,144,104 ASC 5,M-question BYT 163,0 BYT 33,46,144,100 ASC 6, (Multiple). BYT 15,12 * * LINE # : 10 * BYT 15,12 * * LINE # : 11 * ASC 7,For example : BYT 33,46,141,53,60,70,103,0 POSITION CURSOR - 23 ASC 5,Paper Form BYT 33,46,141,53,61,71,103,0 POSITION CURSOR - 52 ASC 9,HP3070 Transaction BYT 15,12 * * LINE # : ]12 * ASC 3, BYT 40,0 BYT 33,51,102,16 ASC 20,R,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, BYT 124,0 BYT 15,12 * * LINE # : 13 * ASC 3, BYT 40,0 BYT 33,51,102,16 BYT 56,17 ASC 19, ICORD: INTER-COMPANY ORDER BYT 40,16 BYT 56,0 BYT 15,12 * * LINE # : 14 * ASC 3, BYT 40,0 BYT 33,51,102,16 BYT 56,17 BYT 33,46,141,53,63,71,103,0 POSITION CURSOR - 48 BYT 16,56 BYT 40,17 ASC 3, Name BYT 33,46,141,53,61,60,103,0 POSITION CURSOR - 66 ASC 2,ICOR BYT 104,0 BYT 15,12 * * LINE # : 15 * ASC 3, BYT 40,0 BYT 33,51,102,16 ASC 1,. BYT 33,46,144,112,17,117 ASC 3,rder # BYT 40,0 BYT 33,46,144,100 BYT 72,0 BYT 33,46,144,104 ASC 4, 69324 BYT 33,46,144,100 BYT 33,46,141,53,62,61,103,0 POSITION CURSOR - 48 BYT 16,56 BYT 40,17 ASC 4, Number BYT 33,46,141,53,60,70,103,0 POSITION CURSOR - 66 BYT 63,0 BYT 15,12 * * LINE # : 16 * ASC 3, BYT 40,0 BYT 33,51,102,16 ASC 1,. BYT 33,46,141,53,63,70,103,0 POSITION CURSOR - 48 BYT 56,17 ASC 10, Security 223 BYT 64,0 BYT 15,12 * * LINE # : 17 * ASC 3, BYT 40,0 BYT 33,51,102,16 ASC 1,. BYT 33,46,144,112,17,104 ASC 6,elivery date BYT 33,46,144,100 ASC 1, : BYT 33,46,144,104 ASC 4, 06-01-7 BYT 67,0 BYT 33,46,144,100 BYT 33,46,141,53,61,60,103,0 POSITION CURSOR - 44 BYT 16,40 ASC 2, . BYT 40,17 BYT 15,12 * * LINE # : 18 * ASC 3, BYT 40,0 BYT 33,51,102,16 ASC 20,. R,,,,,,,,7,,,,,,,,,,,,,7,,,,,,,,,,,T BYT 56,0 BYT 15,12 3* * LINE # : 19 * ASC 3, BYT 40,0 BYT 33,51,102,16 ASC 2,. . BYT 33,46,144,112 BYT 40,17 ASC 3,Part # BYT 40,0 BYT 33,46,144,100,16,56 BYT 40,0 BYT 33,46,144,112,17,121 ASC 5,ty ordered BYT 40,0 BYT 33,46,144,100,16,56 BYT 33,46,144,112,17,125 ASC 5,nit price BYT 33,46,144,100,16,56 ASC 2, . BYT 40,17 ASC 11,U-questions Order # BYT 77,0 BYT 15,12 * * LINE # : 20 * ASC 3, BYT 40,0 BYT 33,51,102,16 ASC 22,. 5,,,,,,,,/,,,,,,,,,,,,,/,,,,,,,,,,,6 . ASC 7,,,,,,,,,,,, BYT 17,104 ASC 7,elivery date ? * * LINE # : 21 * ASC 3, BYT 40,0 BYT 33,51,102,16 ASC 2,. . BYT 17,63 ASC 3,24-445 BYT 16,40 ASC 2,. BYT 40,17 ASC 4,253 BYT 40,16 ASC 1,. BYT 40,17 ASC 3,125.00 BYT 16,40 ASC 2, . BYT 56,0 BYT 15,12 * * LINE # : 22 * ASC 3, BYT 40,0 BYT 33,51,102,16 ASC 2,. . BYT 17,61 ASC 3,42-215 BYT 40,16 ASC 1,. BYT 40,17 ASC 5, 1245 BYT 40,16 ASC 2,. BYT 17,63 ASC 2,5.50 BYT 16,40 ASC 3, . . BYT 40,17 ASC 11, M-questions Part # BYT 77,0 BYT 15,12 * * LINE # : 23 * ASC 3, BYT 40,0 BYT 33,51,102,16 ASC 3,. . BYT 40,17 ASC 2,. BYT 40,16 ASC 3,. BYT 17,40 ASC 3,. BYT 40,16 ASC 2,. BYT 40,17 ASC 1, . BYT 16,40 ASC 11, . . ,,,,,,,,,,, BYT 17,40 ASC 7, Qty ordered ? BYT 15,12 * * LINE # : 24 * ASC 3, BYT 40,0 BYT 33,51,102,16 ASC 3,. . BYT 40,17 F ASC 2,. BYT 40,16 ASC 3,. BYT 40,17 ASC 3,. BYT 40,16 ASC 3,. BYT 17,56 BYT 16,40 ASC 4, . . BYT 33,46,141,53,61,64,103,0 POSITION CURSOR - 64 BYT 17,40 ASC 6, Unit price ESCR1 BYT 77,137 * STAD1 EQU BSCR1 LTAD1 EQU ESCR1 ILSC1 ABS LTAD1-STAD1+1 * * ************************************************************************* * * SCREEN # 2 INDICATIVE SCREEN TGP INTRODUCTION * ************************************************************************* * * SCR2 JSB EXEC WRITE EXEC CALL DEF *+5 RETURN POINT DEF D.2 CODE EXEC DEF ILU CONTROL WORD DEF BSCR2 BUFFER LOCATION DEF ILSC2 BUFFER LENGTH JMP CANS LOAD SEGMENT TO ANALYSE USER ANSWERS * * DATA SCREEN # 2 * * * LINE # : 1 * BSCR2 BYT 33,130 FORMAT OFF BYT 33,110 HOME UP CL03 BYT 33,112 CLEAR DISPLAY BYT 33,133 ASC 1, BYT 33,135 BYT 33,46,141,53,61,65,103,0 POSITION CURSOR - 18 ASC 21,Screen # 2 TRANSACTION GENERATION OVERVIEW BYT 15,12 * * LINE # : 2 * BYT 15,12 * * LINE # : 3 * ASC 4, The BYT 33,46,144,104 ASC 14,TRANSACTION GENERATOR PROGRA BYT 115,0 BYT 33,46,144,100 ASC 18, permits you to interactively create BYT 15,12 * * LINE # : 4 * ASC 15, Transaction Specifications ASC 22, and store them in a LIBRARY for later use. BYT 15,12 * * LINE # : 5 * ASC 3, A BYT 33,46,144,104 ASC 12,TRANSACTION SPECIFICATIO BYT 116,0 BYT 33,46,144,100 ASC 22, contains the characteristics of a transacti ASC 1,on BYT 15,12 * * LINE # : 6 * ASC 22, to be run on the HP3070 terminals by the ASC 1, BYT 33,46,144,104 ASC 13,TRANSACTION MON\ITOR PROGRA BYT 115,0 BYT 33,46,144,100 BYT 56,0 BYT 15,12 * * LINE # : 7 * BYT 15,12 * * LINE # : 8 * BYT 40,0 BYT 33,51,102,16 ASC 1,R, BYT 40,17 ASC 22,To create a Transaction Specification you ne ASC 6,ed to define BYT 40,16 ASC 9,,,,,,,,,,,,,,,,,,, BYT 124,0 * * LINE # : 9 * BYT 40,0 BYT 33,51,102,16 ASC 1,. BYT 33,46,141,53,67,66,103,0 POSITION CURSOR - 80 BYT 56,0 * * LINE # : 10 * BYT 40,0 BYT 33,51,102,16 ASC 2,. BYT 40,17 ASC 22,1 - An identification of the transaction by ASC 8,name and number. BYT 33,46,141,53,61,62,103,0 POSITION CURSOR - 79 BYT 16,40 BYT 56,0 * * LINE # : 11 * BYT 40,0 BYT 33,51,102,16 ASC 1,. BYT 33,46,141,53,67,66,103,0 POSITION CURSOR - 80 BYT 56,0 * * LINE # : 12 * BYT 40,0 BYT 33,51,102,16 BYT 56,17 ASC 22, 2 - The values and functions assigned to ASC 16, the special function keys. BYT 16,40 BYT 56,0 * * LINE # : 13 * BYT 40,0 BYT 33,51,102,16 ASC 1,. BYT 33,46,141,53,67,66,103,0 POSITION CURSOR - 80 BYT 56,0 * * LINE # : 14 * BYT 40,0 BYT 33,51,102,16 BYT 56,17 ASC 22, 3 - The questions to be asked and for ea ASC 7,ch question : BYT 33,46,141,53,61,70,103,0 POSITION CURSOR - 79 BYT 16,40 BYT 56,0 * * LINE # : 15 * BYT 33,51,102,16 ASC 1, . BYT 17,40 BYT 33,46,141,53,60,70,103,0 POSITION CURSOR - 12 ASC 19,The prompting light to be switched on. BYT 33,46,141,53,62,71,103,0 POSITION CURSOR - 79 BYT 16,40 BYT 56,0 * * LINE # : 16 * BYT 33,51,102,16 ASC 1, . BYT 33,46,141,53,60,71,103,0 POSITION CURSOR - 12 BYT 17,124 ASC 22,he definition of the answers you are prepare ASC 6,d to accept. BYT 33,46,141,53,61,60,103,0 POSITION CURSOR - 79 BYT 16,40 BYT 56,0 * * LINE # : 17 * BYT 40,0 BYT 33,51,102,16 ASC 1,. BYT 33,46,141,53,60,70,103,0 POSITION CURSOR - 12 BYT 17,124 ASC 22,he information (if any) to be displayed alon ASC 11,g with the question. BYT 16,40 BYT 56,0 * * LINE # : 18 * BYT 33,51,102,16 ASC 1, . BYT 33,46,141,53,67,67,103,0 POSITION CURSOR - 80 BYT 56,0 * * LINE # : 19 * BYT 40,0 BYT 33,51,102,16 ASC 2,. BYT 40,17 ASC 22,4 - What system information should be stored ASC 14, along with the data. BYT 40,16 BYT 56,0 * * LINE # : 20 * BYT 40,0 BYT 33,51,102,16 ASC 1,. BYT 33,46,141,53,67,66,103,0 POSITION CURSOR - 80 BYT 56,0 * * LINE # : 21 * BYT 33,51,102,16 ASC 3, . BYT 17,65 ASC 22, - The storage device required for the data. BYT 33,46,141,53,62,70,103,0 POSITION CURSOR - 80 BYT 16,56 * * LINE # : 22 * BYT 40,0 BYT 33,51,102,16 ASC 1,. BYT 33,46,141,53,67,66,103,0 POSITION CURSOR - 80 BYT 56,0 * * LINE # : 23 * BYT 40,0 BYT 33,51,102,16 ASC 2,. BYT 40,17 ASC 22,6 - The Transaction Specification Library to ASC 14, be used. BYT 40,16 BYT 56,0 * * LINE # : 24 * BYT 40,0 BYT 33,51,102,16 ASC 22,F,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ASC 17,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, BYT 107,0 ESCR2 BYT 0,137 STAD2 EQU BSCR2 LTAD2 EQU ESCR2 ILSC2 ABS LTAD2-STAD2+1 * ************************************************************************* * * SCREEN # 3 MODE OF OPERATION * ************************************************************************* * SCR3 JSB MOVCX MOVE ANSWERS IN UNPROTECTED FIELDS DEF *+6 DEF IFORM DEF SOF3 TABLE OF CHAR. OFFSETS IN IFORM DEF BD3 TABLE OF BUFFER DEST. ADDRESS IN SCREEN DEF D.0 DEF DBL01 JSB EXEC WRITE EXEC CALL DEF *+5 RETURN POINT DEF D.2 CODE EXEC DEF ILU CONTROL WORD DEF BSCR3 BUFFER LOCATION DEF ILSC3 BUFFER LENGTH JMP CANS LOAD SEGMENT TO ANALYSE USER'S ANSWERS * * DATA SCREEN 3 * * * LINE # : 1 * BSCR3 BYT 33,130 FORMAT OFF BYT 33,110 HOME UP CL04 BYT 33,112 CLEAR DISPLAY BYT 33,46,141,53,61,70,103,0 POSITION CURSOR - 19 ASC 21,Screen # 3 : TRANSACTION GENERATOR PROGRA BYT 115,0 BYT 15,12 * * LINE # : 2 * BYT 15,12 * * LINE # : 3 * ASC 17, - Select your mode of operation: BYT 15,12 * * LINE # : 4 * ASC 3, BYT 33,46,144,104 BYT 103,0 BYT 33,46,144,100 ASC 19,reate a new Transaction Specification BYT 33,46,141,53,61,60,103,0 POSITION CURSOR - 56 BYT 51,0 BYT 15,12 * * LINE # : 5 * ASC 3, BYT 33,46,144,104 BYT 115,0 BYT 33,46,144,100 ASC 22,odify an existing Transaction Specification ASC 13, ) .................. BYT 33,46,144,102,33,133 T0300 BYT 40,0 BYT 33,135,33,46,144,100 BYT 15,12 * * LINE # : 6 * ASC 3, BYT 33,46,144,104 BYT 114,0 BYT 33,46,144,100 ASC 22,ist an existing Transaction Specification ASC 2, BYT 51,0 BYT 15,12 * * LINE # : 7 * ASC 3, BYT 33,46,144,104 BYT 102,0 BYT 33,46,144,100 ASC 20,uild Transaction Specification Libraries BYT 33,46,141,53,60,70,103,0 POSITION CURSOR - 56 BYT 51,0 BYT 15,12 * * LINE # : 8 * BYT 15,12 * * LINE # : 9 * BYT 33,51,102,16 ASC 1,R, BYT 54,17 ASC 15, For Modify or List operations BYT 40,16 ASC 22,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ASC 1,,T * * LINE # : 10 * BYT 33,51,102,16 BYT 56,17 ASC 22, - Enter the Transaction Specification NAME ASC 14,or NUMBER ............... BYT 33,46,144,102,33,133 T0301 ASC 3, BYT 33,135,33,46,144,100,16,56 * * LINE # : 11 * BYT 33,51,102,16 BYT 56,17 ASC 22, and the Transaction Specification SECURI ASC 14,TY CODE .................. BYT 33,46,144,112,33,133 T0302 ASC 3, BYT 33,135,33,46,144,100,16,56 * * LINE # : 12 * BYT 33,51,102,16 BYT 56,17 ASC 22, - Enter the LIBRARY NAME: disc file or d ASC 11,evice (LCTU, RCTU, MT) BYT 33,46,141,53,61,62,103,0 POSITION CURSOR - 80 BYT 16,56 * * LINE # : 13 * BYT 33,51,102,16 BYT 56,17 ASC 22, on which the specification is to be found ASC 14, ......................... BYT 33,46,144,102,33,133 T0303 ASC 3, BYT 33,135,33,46,144,100,16,56 * * LINE # : 14 * BYT 33,51,102,16 ASC 1,. BYT 33,46,141,53,67,67,103,0 POSITION CURSOR - 80 BYT 56,0 * * LINE # : 15 * BYT 33,51,102,16 BYT 56,17 ASC 13, - If the library is on: BYT 33,46,141,53,65,62,103,0 POSITION CURSOR - 80 BYT 16,56 * * LINE # : 16 * BYT 33,51,102,16 BYT 56,17 ASC 19, A minicartridge or a magnetic tape, BYT 40,0 BYT 33,46,144,104 ASC 5,load devic BYT 145,0 BYT 33,46,144,100 ASC 1,. BYT 33,46,141,53,62,66,103,0 POSITION CURSOR - 80 BYT 16,56 * TRN * LINE # : 17 * BYT 33,51,102,16 BYT 56,17 ASC 22, A disc, give the CARTRIDGE REFERENCE numb ASC 14,er (Optional) ............ BYT 33,46,144,102,33,133 T0304 ASC 3, BYT 33,135,33,46,144,100,16,56 * * LINE # : 18 * BYT 33,51,102,16 ASC 22,F,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ASC 18,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,G * * LINE # : 19 * BYT 15,12 * * LINE # : 20 * BYT 33,51,102,16 ASC 1,R, BYT 54,17 ASC 13, For List operations only T BYT 16,54 ASC 22,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ASC 3,,,,,,T * * LINE # : 21 * BYT 33,51,102,16 BYT 56,17 ASC 22, - FILE NAME of list device (LP, default is ASC 14, this terminal) .......... BYT 33,46,144,102,33,133 T0305 ASC 3, BYT 33,135,33,46,144,100,16,56 * * LINE # : 22 * BYT 33,51,102,16 ASC 22,F,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ASC 18,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,G * * LINE # : 23 * ESCR3 BYT 15,12 * * STAD3 EQU BSCR3 LTAD3 EQU ESCR3 ILSC3 ABS LTAD3-STAD3+1 TXX NOP * * TABLE OF OFFSETS IN IFORM FOR SCREEN 3 * SOF3 DEC 13,14,15,21,27,33,39,45,-1 * * TABLE OF DEST BUFFERS SCREEN 3 * BD3 DEF T0300 DEF TXX DEF T0301 DEF T0302 DEF T0303 DEF T0304 DEF T0305 * DBL01 NOP * *********************************************************************** * * SCREEN # 4 TRANSACTION SPEC IDENTIFICATION AND TRANS. TYPE * ********************************************************************** * SCR4 JSB MOVCX MOVE ANSWERS FROM IFORM IN SCREEN BUFFER DEF *+6 DEF IFORM SOURCE BUFFER DEF SOF4 TABLE OF OFSSETS IN IFORM FOR SCREEN # 4 DEF BD4 TABLE OF DEST.BUFFERS DEF D.0 DEST. OFFSET DEF DBL01 * LDA IL40 MINIMUM SCREEN LENGTH LDB IMODB GET TERMINAL TYPE SZB IS 3070A LDA IL41 NO 3070B GET NEW SCREEN LENGTH STA ILSC4 STORE IT * JSB EXEC WRITE EXEC CALL DEF *+5 RETURN POINT DEF D.2 CODE EXEC DEF ILU CONTROL WORD DEF BSCR4 BUFFER LOCATION DEF ILSC4 BUFFER LENGTH JMP CANS LOAD SEGMENT TO ANALYSE USERS ANSWERS * * DATA SCREEN # 4 * * * LINE # : 1 * BSCR4 BYT 33,130 FORMAT OFF BYT 33,110 HOME UP CURSOR CL05 BYT 33,112 CLEAR DISPLAY BYT 33,46,141,53,61,64,103,0 POSITION CURSOR - 15 ASC 22,Screen # 4 TRANSACTION SPECIFICATION IDENTIF ASC 3,ICATIO BYT 116,0 BYT 15,12 * * LINE # : 2 * BYT 15,12 * * LINE # : 3 * ASC 22,***WARNING*** Returning to the previous scre ASC 16,en will initiate all fields. BYT 15,12 * * LINE # : 4 * BYT 15,12 * * LINE # : 5 * ASC 20, - Enter the Transaction Specification BYT 15,12 * * LINE # : 6 * BYT 15,12 * * LINE # : 7 * BYT 33,46,141,53,61,67,103,0 POSITION CURSOR - 18 ASC 2,Name BYT 33,46,141,53,61,61,103,0 POSITION CURSOR - 33 ASC 3,Number BYT 33,46,141,53,60,71,103,0 POSITION CURSOR - 48 ASC 6,Security cod BYT 145,0 BYT 15,12 * * LINE # : 8 * BYT 33,46,141,53,61,66,103,0 POSITION CURSOR - 17 BYT 33,46,144,102,33,133 T0400 ASC 3, BYT 33,135,33,46,144,100 BYT 33,46,141,53,61,61,103,0 POSITION CURSOR - 34 BYT 33,46,144,102,33,133 T0401 ASC 2, BYT 33,135,33,46,144,100 BYT 33,46,141,53,61,63,103,0 POSITION CURSOR - 51 BYT 33,46,144,102,33,133 T0402 ASC 3, BYT 33,135,33,46,144,100 BYT 15,12 * * LINE # : 9 * BYT 15,12 * * LINE # : 10 * BYT 15,12 * * LINE # : 11 * BYT 15,12 * * LINE # : 12 * ASC 21, - Enter X if this Transaction is to uti ASC 15,lize logging ................. BYT 40,0 BYT 33,46,144,102,33,133 T4021 BYT 40,0 BYT 33,135,33,46,144,100 BYT 15,12 * * LINE # : 13 * BYT 15,12 * * LINE # : 14 * ASC 22, - Enter X if "user written modules" are t ASC 14,o be accessed .............. BYT 40,0 BYT 33,46,144,102,33,133 T0403 BYT 40,0 BYT 33,135,33,46,144,100 BYT 15,12 * 0* LINE # : 15 * BYT 15,12 * * LINE # : 16 * BYT 15,12 * * LINE # : 17 * BYT 33,51,102,16 ASC 1,R, BYT 54,17 ASC 22, If this Transaction Specification defines a ASC 15,ccesses to an IMAGE data base BYT 16,54 ASC 1,,T * * LINE # : 18 * BYT 33,51,102,16 BYT 56,17 ASC 2, BYT 40,16 BYT 33,46,141,53,67,63,103,0 POSITION CURSOR - 80 BYT 56,0 * * LINE # : 19 * BYT 33,51,102,16 BYT 56,17 ASC 22, - Enter the data base name ............. ASC 12,....................... BYT 33,46,144,102,33,133 T0404 ASC 2, BYT 40,0 BYT 33,135,33,46,144,100 ASC 2, BYT 40,16 BYT 56,0 * * LINE # : 20 * BYT 33,51,102,16 BYT 56,17 ASC 22, - Enter the data base security code ..... ASC 12,....................... BYT 33,46,144,112,33,133 T0405 ASC 2, BYT 40,0 BYT 33,135,33,46,144,100 ASC 2, BYT 40,16 BYT 56,0 * * LINE # : 21 * BYT 33,51,102,16 BYT 56,17 BYT 33,46,141,53,67,70,103,0 POSITION CURSOR - 80 BYT 16,56 * * LINE # : 22 * BYT 33,51,102,16 ASC 22,F,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ASC 18,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,G * * LINE # : 23 * ESCR4 BYT 15,12 * * B.41 BYT 33,46,141,71,162,63,103,0 ASC 25,- Enter X to echo all inputs and outputs on the HP ASC 10,3070B printer ..... BYT 33,46,144,102,33,133 T0406 BYT 40,33 BYT 135,33,46,144 E.41 BYT 100,40 STAD4 EQU BSCR4 LTAD4 EQU ESCR4 LT41 EQU E.41 IL40 ABS LTAD4-STAD4+1 IL41 ABS LT41-STAD4+1 ILSC4 NOP * * TABLE OF OFFSETS IN IFORM FOR SCREEN # 4 * SOF4 DEC 57,63,67,73,74,75,80,81,86,87,-1 * * TABLE OF ADDRESSES OF DEST. BUFFER SCREEN # 4 * BD4 DEF T0400 DEF T0401 DEF T040F2 DEF T0403 DEF T4021 DEF T0404 DEF TXX DEF T0405 DEF T0406 * ************************************************************************ * * SCREEN # 5 INDICATIVE SCREEN TO EXPLAIN SFK ASSIGNEMENT * ************************************************************************ * * SCR5 JSB EXEC WRITE EXEC CALL DEF *+5 RETURN POINT DEF D.2 CODE EXEC DEF ILU CONTROL WORD DEF BSCR5 BUFFER LOCATION DEF ILSC5 BUFFER LENGTH JMP CANS LOAD SEGMENT TO ANALYSE USERS ANSWERS * * DATA SCREEN # 5 * * * LINE # : 1 * BSCR5 BYT 33,130 FORMAT OFF BYT 33,110 HOME UP CURSOR CL06 BYT 33,112 CLEAR DISPLAY BYT 33,133 ASC 1, BYT 33,135 ASC 12, Screen # 5 HP3070 BYT 33,46,144,104 BYT 123,0 BYT 33,46,144,100 ASC 3,PECIAL BYT 40,0 BYT 33,46,144,104 BYT 106,0 BYT 33,46,144,100 ASC 4,UNCTION BYT 33,46,144,104 BYT 113,0 BYT 33,46,144,100 ASC 1,EY ASC 14,S (SFK) ASSIGNMENT OVERVIEW BYT 15,12 * * LINE # : 2 * BYT 15,12 * * LINE # : 3 * ASC 22,1-Each HP3070 SFK is identified by number fr ASC 18,om 1 (RESET) to 11 (10 for HP3070A). * * LINE # : 4 * BYT 15,12 * * LINE # : 5 * ASC 22,2-A PREFIX key may be defined which enables ASC 16,you to give two meanings to each BYT 15,12 * * LINE # : 6 * ASC 22, assignable key (except the PREFIX key itse ASC 2,lf). BYT 15,12 * * LINE # : 7 * BYT 15,12 * * LINE # : 8 * ASC 22,3-The next two screens define the meaning of ASC 16, the keys. The first one defines BYT 15,12 * * LINE # : 9 * ASC 22, the non-prefixed key assignments, the seco ASC 16,nd defines the prefixed keyӂ BYT 15,12 * * LINE # : 10 * ASC 22, assignments (it appears only if the PREFIX ASC 12, key has been defined). BYT 15,12 * * LINE # : 11 * BYT 15,12 * * LINE # : 12 * ASC 22,4-Keys 2 to 11 may be assigned a VALUE or a ASC 18,FUNCTION (Key # 1 is not assignable) * * LINE # : 13 * BYT 33,51,102,16 ASC 22,R,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,_,,,, ASC 18,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,T * * LINE # : 14 * BYT 33,51,102,16 BYT 56,17 ASC 12, To define a key as a BYT 33,46,144,104 ASC 4,VALUE ke BYT 171,0 BYT 33,46,144,100 ASC 2, BYT 40,16 BYT 51,17 ASC 12, To define a key as a BYT 33,46,144,104 ASC 6,FUNCTION key BYT 33,46,144,100 ASC 1, BYT 40,16 BYT 56,0 * * LINE # : 15 * BYT 33,51,102,16 ASC 22,5,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,},,,, ASC 18,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,6 * * LINE # : 16 * BYT 33,51,102,16 BYT 56,17 BYT 33,46,141,53,62,60,103,0 POSITION CURSOR - 22 ASC 14,- Give the key number in the BYT 40,0 BYT 33,46,144,102 ASC 1,K# BYT 33,46,144,100 ASC 4, field BYT 16,40 BYT 33,46,141,53,61,70,103,0 POSITION CURSOR - 80 BYT 56,0 * * LINE # : 17 * BYT 33,51,102,16 BYT 56,17 ASC 10, - Fill in the field BYT 40,0 BYT 33,46,144,102 ASC 4,KEY VALU BYT 105,0 BYT 33,46,144,100 ASC 4, with BYT 16,51 BYT 40,17 ASC 10,- Fill in the field BYT 33,46,144,102 ASC 1,FN BYT 33,46,144,100 ASC 8, BYT 16,56 * * LINE # : 18 * BYT 33,51,102,16 BYT 56,17 ASC 15, the value to be generated. BYT 33,46,141,53,60,70,103,0 POSITION  CURSOR - 40 BYT 16,51 BYT 17,40 ASC 19, with the related function mnemonic. BYT 16,56 * * LINE # : 19 * BYT 33,51,102,16 BYT 56,17 ASC 10, - Fill in the field BYT 40,0 BYT 33,46,144,102 BYT 103,0 BYT 33,46,144,100 ASC 8, with an X if BYT 16,51 BYT 17,40 ASC 19,- Function keys are automatically BYT 16,56 * * LINE # : 20 * BYT 33,51,102,16 BYT 56,17 ASC 19, input is to complete when the key BYT 16,51 BYT 17,40 ASC 19, declared as input terminator keys. BYT 16,56 * * LINE # : 21 * BYT 33,51,102,16 ASC 2,. BYT 17,151 ASC 5,s pressed. BYT 33,46,141,53,62,64,103,0 POSITION CURSOR - 40 BYT 16,51 BYT 33,46,141,53,63,71,103,0 POSITION CURSOR - 80 BYT 56,0 * * LINE # : 22 * BYT 33,51,102,16 BYT 56,17 ASC 10, - Fill in the field BYT 40,0 BYT 33,46,144,102 ASC 4,SFK LABE BYT 114,0 BYT 33,46,144,100 ASC 22, with the text to appear on the HP3070 label ASC 2,. BYT 16,56 * * LINE # : 23 * BYT 33,51,102,16 ASC 22,F,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ASC 18,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,G * * LINE # : 24 * ESCR5 BYT 15,12 * STAD5 EQU BSCR5 LTAD5 EQU ESCR5 ILSC5 ABS LTAD5-STAD5+1 * ************************************************************************ * * SCREEN # 6 & 7 SFK ASSIGNEMENT * ************************************************************************ * SCR6 LDA ILS6 GET BASE SCREEN LENGTH STA ILSC6 STORE IT LDA ISCRN GET SCREEN # CPA D.7 SCREEN 7 ? JMP SCR7 YES JSB MOVCX SCREEN 6 * MOVE ANSWERS DEF *+6 IN UNPROT. FIELDS DEF IFORM ANSWER STORAGE DEF SOF6 TABLE OF C\HAR. OFFSETS IN IFORM DEF BD6 TABLE OF BUFFER DEST. ADDRESSES DEF D.0 DEST OFFSET DEF DBL01 QUESTION # LDA S6 GET "6" STA T60 STORE IN TITLE LDA ASPEC MOVE "(NON PREFIXED)" LDB AT61 IN THE TITLE JSB &MVW OF THE DEC 7 SCREEN LDA ILSC6 GET SCREEN LENGTH ADA ILS63 UPDATE LENGTH FOR SCREEN 6 STA ILSC6 RESTORE IT JMP SCR61 * SCR7 JSB MOVCX SCREEN 7 * MOVE ANSWERS DEF *+6 IN UNPROT. FIELDS DEF IFORM ANSWER STORAGE DEF SOF7 TABLE OF CHARS OFFSETS IN IFORM DEF BD6 TABLE OF BUFF. DEST ADDRESSES DEF D.0 DEST. OFFSET DEF DBL01 QUESTION # LDA S7 LOAD "7" STA T60 STORE IN TITLE LDA APREF MOVE "(PREFIXED)" LDB AT61 IN THE TITLE JSB &MVW OF THE DEC 5 SCREEN * SCR61 LDA IMODB GET TERMINAL TYPE SZA 3070B ? JMP SCR63 YES JUMP * LDA ILS62 3070A STA LN60 STORE LENGTH TO MOVE STA LN61 .................... ADA ILSC6 UPDATE LENGTH STA ILSC6 RSTORE LENGTH * LDA ISCRN GET SCREEN # CPA D.7 7 ? JMP SCR62 YES LDA AB.62 NO,MOVE FROM LDB AB.61 TO JSB &MVW LN60 NOP MOVE LENGTH JMP WRIT6 WRITE SCREEN SCR62 LDA AB.62 MOVE FROM LDB AB.63 TO JSB &MVW LN61 NOP MOVE LENGTH JMP WRIT6 WRITE SCREEN * * MODEL 3070B * SCR63 LDA ILS64 GET LENGTH TO ADD TO SCREEN STA LN62 STORE ADA ILSC6 UPDATE SCREEN STA ILSC6 LENGTH LDA RLF INCLUDE EXTRA RETURN LINE FEED STA T62 IN SCREEN LDA ISCRN GET SCREEN # CPA D.6 IS 6 ? JMP WRIT6 YES JUMP LDA AB.61 ITS 7,MOVE FROM LDB AB.63 TOi JSB &MVW LN62 NOP MOVE LENGTH WRIT6 JSB EXEC WRITE EXEC CALL DEF *+5 RETURN POINT DEF D.2 CODE EXEC DEF ILU CONTROL WORD DEF BSCR6 BUFFER LOCATION DEF ILSC6 BUFFER LENGTH JMP CANS LOAD SEGMENT TO ANALYSE USERS ANSWER * SPEC ASC 7,(NON-PREFIXED) PREF ASC 5,(PREFIXED) APREF DEF PREF ASPEC DEF SPEC AT61 DEF T61 S6 ASC 1,6 S7 ASC 1,7 RLF BYT 15,12 D.7 DEC 7 D.6 DEC 6 AB.63 DEF B.63 AB.61 DEF B.61 AB.62 DEF B.62 * * DATA SCREEN # 6 & 7 * * * LINE # : 1 * BSCR6 BYT 33,130 FORMAT OFF BYT 33,110 HOME UP CL07 BYT 33,112 CLEAR DISPLAY ASC 8, Screen # T60 ASC 1, ASC 13, HP3070 SPECIAL FUNCTION K ASC 8,EYS ASSIGNMENT T61 ASC 7, BYT 15,12 * * LINE # : 2 * BYT 15,12 * * LINE # : 3 * BYT 15,12 * * LINE # : 4 * BYT 15,12 * * LINE # : 5 * BYT 15,12 * * LINE # : 6 * BYT 15,12 * * LINE # : 7 * BYT 15,12 * * LINE # : 8 * BYT 33,46,141,53,65,60,103,0 POSITION CURSOR - 51 BYT 33,46,144,104 ASC 10,Assignable functions BYT 15,12 * * LINE # : 9 * ASC 1, BYT 40,0 BYT 33,51,102,16 ASC 20,R,,7,,,,,,,,,,,,,,,,7,,7,7,,,,,,,,,,,,T BYT 40,17 BYT 15,12 * * LINE # : 10 * ASC 1, BYT 40,0 BYT 33,51,102,16 BYT 56,0 BYT 33,46,144,102,17,113 BYT 43,0 BYT 33,46,144,100,16,56 BYT 33,46,144,102,17,40 ASC 7, KEY VALUE BYT 40,0 BYT 33,46,144,100,16,56 BYT 33,46,144,102,17,106 BYT 116,0 BYT 33,46,144,100,16,56 BYT 33,46,144,102,17,103 BYT 33,46,144,100,16,56 BYT 33,46,144,102,17,40 ASC 5, SFK LABEL BYT 40,0 BYT 33,46,144,100,16,56 BYT 17,40 ASC 7 1,TC ASC 10, Transaction COMPLET BYT 105,0 BYT 15,12 * * LINE # : 11 * ASC 1, BYT 40,0 BYT 33,51,102,16 ASC 20,5,,8,,,,,,,,,,,,,,,,8,,8,8,,,,,,,,,,,,6 BYT 17,122 ASC 12,C RECALL previous answer BYT 15,12 * * LINE # : 12 * ASC 1, BYT 40,0 BYT 33,51,102,16 BYT 56,0 BYT 33,46,144,106,17,33,133,0 T0600 ASC 1, BYT 33,135,33,46,144,100 BYT 40,0 BYT 33,46,144,106,33,133 T0601 ASC 8, BYT 33,135,33,46,144,100 BYT 40,0 BYT 33,46,144,106,33,133 T0602 ASC 1, BYT 33,135,33,46,144,100 BYT 40,0 BYT 33,46,144,106,33,133 T0603 BYT 40,0 BYT 33,135,33,46,144,100 BYT 40,0 BYT 33,46,144,106,33,133 T0604 ASC 6, BYT 33,135,33,46,144,100,16,56 BYT 17,40 ASC 18,SV SAME VALUE as previously answered BYT 15,12 * * LINE # : 13 * BYT 33,51,102,16 ASC 2, . BYT 33,46,144,106,17,33,133,0 T0605 ASC 1, BYT 33,135,33,46,144,100 BYT 40,0 BYT 33,46,144,106,33,133 T0606 ASC 8, BYT 33,135,33,46,144,100 BYT 40,0 BYT 33,46,144,106,33,133 T0607 ASC 1, BYT 33,135,33,46,144,100 BYT 40,0 BYT 33,46,144,106,33,133 T0608 BYT 40,0 BYT 33,135,33,46,144,100 BYT 40,0 BYT 33,46,144,106,33,133 T0609 ASC 6, BYT 33,135,33,46,144,100,16,56 BYT 17,40 ASC 14,AB ABORT/SELECT transaction BYT 15,12 * * LINE # : 14 * BYT 40,0 BYT 33,51,102,16 ASC 1, BYT 56,0 BYT 33,46,144,106,17,33,133,0 T0610 ASC 1, BYT 33,135,33,46,144,100 BYT 40,0 BYT 33,46,144,106,33,133 T0611 ASC 8, BYT 33,135,33,46,144,100 BYT 40,0 BYT 33,46,144,106,33,133 T0612 ASC 1, BYT 33,135,33,46,144,100 BYT 40,0 BYT 33,46,144,106,33,133 T0613 BYT 40,0 BYT 33,135,33,46,144,100 BYT 40,0 BYT 33,46,144,106,33,133 T0614 ASC 6, BYT 33,135,33,46,144,100,16,56 BYT 17,40 ASC 12,AD Arithmetic ADD + BYT 15,12 * * LINE # : 15 * BYT 40,0 BYT 33,51,102,16 ASC 1, BYT 56,0 BYT 33,46,144,106,17,33,133,0 T0615 ASC 1, BYT 33,135,33,46,144,100 BYT 40,0 BYT 33,46,144,106,33,133 T0616 ASC 8, BYT 33,135,33,46,144,100 BYT 40,0 BYT 33,46,144,106,33,133 T0617 ASC 1, BYT 33,135,33,46,144,100 BYT 40,0 BYT 33,46,144,106,33,133 T0618 BYT 40,0 BYT 33,135,33,46,144,100 BYT 40,0 BYT 33,46,144,106,33,133 T0619 ASC 6, BYT 33,135,33,46,144,100,16,56 BYT 17,40 ASC 12,SU Arithmetic SUBTRACT - BYT 15,12 * * LINE # : 16 * BYT 33,51,102,16 ASC 1, BYT 17,40 BYT 16,56 BYT 33,46,144,106,17,33,133,0 T0620 ASC 1, BYT 33,135,33,46,144,100 BYT 40,0 BYT 33,46,144,106,33,133 T0621 ASC 8, BYT 33,135,33,46,144,100 BYT 40,0 BYT 33,46,144,106,33,133 T0622 ASC 1, BYT 33,135,33,46,144,100 BYT 40,0 BYT 33,46,144,106,33,133 T0623 BYT 40,0 BYT 33,135,33,46,144,100 BYT 40,0 BYT 33,46,144,106,33,133 T0624 ASC 6, BYT 33,135,33,46,144,100,16,56 BYT 17,40 ASC 12,MP Arithmetic MULTIPLY X BYT 15,12 * * LINE # : 17 * BYT 33,51,102,16 ASC 2, . BYT 33,46,144,106,17,33,133,0 T0625 ASC 1, BYT 33,135,33,46,144,100 BYT 40,0 BYT 33,46,144,106,33,133 T0626 ASC 8, BYT 33,135,33,46,144,100 BYT 40,0 BYT 33,46,144,106,33,133 T0627 ASC 1, BYT 33,135,33,46,144,100 BYT 40,0 BYT 33,46,144,106,33,133 T0628 BYT 40,0 BYT 33,135,33,46,144,100 BYT 40,0 BYT 33,46,144,106,33,133 T0629 ASC 6, BYT 33,135,33,46,144,100,16,56 BYT 17,40 ASC 12,DV Arithmetic DIVIDE / BYT 15,12 * * LINE # : 18 * ASC 1, BYT 40,0 BYT 33,51,102,16 BYT 56,0 BYT 33,46,144,106,17,33,133,0 T0630 ASC 1, BYT 33,135,33,46,144,100 BYT 40,0 BYT 33,46,144,106,33,133 T0631 ASC 8, BYT 33,135,33,46,144,100 BYT 40,0 BYT 33,46,144,106,33,133 T0632 ASC 1, BYT 33,135,33,46,144,100 BYT 40,0 BYT 33,46,144,106,33,133 T0633 BYT 40,0 BYT 33,135,33,46,144,100 BYT 40,0 BYT 33,46,144,106,33,133 T0634 ASC 6, BYT 33,135,33,46,144,100,16,56 BYT 17,40 ASC 12,EQ Arithmetic EQUAL = BYT 15,12 * * LINE # : 19 * BYT 33,51,102,16 BYT 40,17 ASC 1, BYT 16,56 BYT 33,46,144,106,17,33,133,0 T0635 ASC 1, BYT 33,135,33,46,144,100 BYT 40,0 BYT 33,46,144,106,33,133 T0636 ASC 8, BYT 33,135,33,46,144,100 BYT 40,0 BYT 33,46,144,106,33,133 T0637 ASC 1, BYT 33,135,33,46,144,100 BYT 40,0 BYT 33,46,144,106,33,133 T0638 BYT 40,0 BYT 33,135,33,46,144,100 BYT 40,0 BYT 33,46,144,106,33,133 T0639 ASC 6, BYT 33,135,33,46,144,100,16,56 BYT 17,40 ASC 4,PR PREFI BYT 130,0 BYT 15,12 * * LINE # : 20 * ASC 1, BYT 40,0 BYT 33,51,102,16 BYT 56,0 BYT 33,46,144,106,17,33,133,0 T0640 ASC 1, BYT 33,135,33,46,144,100 BYT 40,0 BYT 33,46,144,106,33,133 T0641 ASC 8, BYT 33,135,33,46,144,100 BYT 40,0 BYT 33,46,144,106,33,133 T0642 ASC 1, BYT 33,135,33,46,144,100 BYT 40,0 BYT 33,46,144,106,33,133 T0643 BYT 40,0 BYT 33,135,33,46,144,100 BYT 40,0 BYT 33,46,144,106,33,133 T0644 ASC 6, BYT 33,135,33,46,144,100,16,56 BYT 17,40 ASC 16,CN CONTINUE to the next question 'BYT 15,12 * * LINE # : 21 * BYT 33,46,141,53,64,63,103,0 BYT 33,46,144,100,17,116 ASC 15,X NEXT ENTRY in an IMAGE chain BYT 15,12 * * LINE # : 22 * BYT 33,46,141,53,64,63,103,17 POSITION CURSOR - 44 ASC 14,DE DELETE ENTRY in data base ESCR6 BYT 15,12 * B.63 BYT 33,46,141,62,162,60,103,0 ASC 22, -Listed below is the DEFAULT set of SFK ASC 06,assignments. BYT 15,12 * * LINE # : 4 * BYT 15,12 * * LINE # : 5 * ASC 22, -If you want to change any SFK assignmen ASC 16,ts, replace the fields with the BYT 15,12 * * LINE # : 6 * ASC 22, desired function information (as explai ASC 13,ned in the previous screen E.63 ASC 1,). * * B.61 BYT 33,46,141,62,60,162,60,103 ASC 1, BYT 40,0 BYT 33,51,102,16 BYT 56,0 BYT 33,46,144,106,17,33,133,0 T0645 ASC 1, BYT 33,135,33,46,144,100 BYT 40,0 BYT 33,46,144,106,33,133 T0646 ASC 8, BYT 33,135,33,46,144,100 BYT 40,0 BYT 33,46,144,106,33,133 T0647 ASC 1, BYT 33,135,33,46,144,100 BYT 40,0 BYT 33,46,144,106,33,133 T0648 BYT 40,0 BYT 33,135,33,46,144,100 BYT 40,0 BYT 33,46,144,106,33,133 T0649 ASC 6, BYT 33,135,33,46,144,100,16,56 E.61 BYT 17,40 * * B.62 BYT 33,46,141,62,60,162,60,103 T62 BYT 0,0 ASC 1, BYT 40,0 BYT 33,51,102,16 ASC 20,F,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,G E.62 BYT 17,0 * STAD6 EQU BSCR6 LTAD6 EQU ESCR6 STA63 EQU B.63 LTA63 EQU E.63 STA61 EQU B.61 LTA61 EQU E.61 STA62 EQU B.62 LTA62 EQU E.62 ILSC6 NOP ILS6 ABS LTAD6-STAD6+1 ILS63 ABS LTA63-STA63+1 ILS62 ABS LTA62-STA62+1 ILS64 ABS LTA62-STA61+1 * * TABLE OF OFFSETS IN IFORM SCREEN # 6 * SOF6 DEC 87,89,105,107,108 DEC 120,122,138,140,141 DEC 153,155,171,173,174 DEC 186,188,204,206,207 f DEC 219,221,237,239,240 DEC 252,254,270,272,273 DEC 285,287,303,305,306 DEC 318,320,336,338,339 DEC 351,353,369,371,372 DEC 384,386,402,404,405 DEC 417,-1 * * TABLE OF THE OFFSETS IN IFORM SCREEN # 7 * SOF7 DEC 417,419,435,437,438 DEC 450,452,468,470,471 DEC 483,485,501,503,504 DEC 516,518,534,536,537 DEC 549,551,567,569,570 DEC 582,584,600,602,603 DEC 615,617,633,635,636 DEC 648,650,666,668,669 DEC 681,683,699,701,702 DEC 714,716,732,734,735 DEC 747,-1 * * * * TABLE OF DEST. BUFFERS SCREEN 6 & 7 * BD6 DEF T0600 DEF T0601 DEF T0602 DEF T0603 DEF T0604 DEF T0605 DEF T0606 DEF T0607 DEF T0608 DEF T0609 DEF T0610 DEF T0611 DEF T0612 DEF T0613 DEF T0614 DEF T0615 DEF T0616 DEF T0617 DEF T0618 DEF T0619 DEF T0620 DEF T0621 DEF T0622 DEF T0623 DEF T0624 DEF T0625 DEF T0626 DEF T0627 DEF T0628 DEF T0629 DEF T0630 DEF T0631 DEF T0632 DEF T0633 DEF T0634 DEF T0635 DEF T0636 DEF T0637 DEF T0638 DEF T0639 DEF T0640 DEF T0641 DEF T0642 DEF T0643 DEF T0644 DEF T0645 DEF T0646 DEF T0647 DEF T0648 DEF T0649 * ********************************************************************** * * SCREEN # 8 DOES NOT EXIST!!!!!!!!!!!!!!!!!!!!!!!!! * ********************************************************************** * * SCR8 NOP * *********************************************************************** * * NOW CALL ANSWER ANALYZE SEGMENT * *********************************************************************** * CANS JSB EXEC SEND FORMAT ON DEF *+5 $TRN DEF D.2 DEF ILU DEF BENP DEF D.2 LDA ISCRN GET SCREEN # ADA .D6 SCREEN # < 6 SSA,RSS JMP CANS1 JSB EXEC SEGMENT LOAD EXEC CALL DEF *+3 RETURN POINT DEF D.8 CODE EXEC DEF ANS SEGMENT NAME * CANS1 JSB EXEC SEGMENT LOAD EXEC CALL DEF *+3 DEF D.8 DEF ANS1 * * DATA SECTION * D.3 DEC 3 .D6 DEC -6 ANS ASC 3,TGP1 SEGMENT NAME TO LOAD ANS1 ASC 3,TGP2 BENP BYT 33,127,0,137 FORMAT ON * * * END SEGMENT * END TGP0 hT ! 92903-18352 1805 S C0122 &TGP1              H0101 boFTN4 PROGRAM TGP1(5), 92903-16352 REV.1805 780515 C C SOURCE 92903-18352 C C C C ************************************************************** C * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * C ************************************************************** C C C PRGMR : JEAN CHARLES MIARD (HPG) C C********************************************************************* C* * C* THIS IS A SEGMENT OF THE TGP PROGRAM USED TO * C* ANALYZE THE ANSWERS THE USER HAS GIVEN IN THE SCREENS 0,1,2 * C* 3,4 AND 5 . * C* THE ANSWERS AFTER A CHECK ARE STORED IN IFORM. * C* * C* * C* FOLLOWING ARE THE DIFFERENT WAYS TO EXECUTE THIS * C* SEGMENT ACCORDING TO INDIC VALUE : * C* * C* INDIC = 0 : NORMAL PATH . ANALYSE ISCRN SCREEN ANSWERS . * C* OR COMING FROM TGP11 AN ERROR HAS OCCURED IN * C* OPENING THE DATA BASE REGET SCREEN #3 * C* = 1 : WHEN COMING FROM TGP10 . A TRANSACTION SPEC * C* HAS BEEN READ (MODE L OR M) BUT AN ERROR * C* OCURED DURING READ . ISKIP CONTAINS ERROR CODE * C* SET INDIC TO 4 AND REPRINT SCREEN # 3 . * C* = 2 : WHEN COMING FROM TGP11 . A DATA BASE HAS BEEN * C* SUCCESSFULLY OPENED GO TO PRINT SCREEN # 5 . * C* = 3 : WHEN COMING FROM TGP10 . A TRANSACTION SPEC * C* HAS BEEN SUCCESFULLY READ . * C* = 4 : SEE INDIC=1 AFTER PRINTING SCREEN 3 THE ISKIP * C* ERROR MESSAGE IS PRINTED . * C* =-77 A HELP MESSAGE MUST BE PRINTED * C* = 99 ABORT TGP * C* * C* * C* * C********************************************************************* C C C ****** DECLARATIONS COMMON VARIABLES ********* C COMMON ILU,ISCRN,IQST,ISKIP,INDIC COMMON IFORM(494) COMMON JFORM(980) COMMON MFORM(16) COMMON LFORM(39) COMMON ITT COMMON IKEY(11,3) COMMON IUMAX,IMMAX COMMON IMODB COMMON ILITE(15) COMMON IMAI(45,5) COMMON IMFLG,IMAS,IMDT,IMKY COMMON KFORM(1065) COMMON ILIBR(61) COMMON NIMAG C C LOCAL VARIABLES ********** C DIMENSION INAM(3),JNAM(3),KNAM(3),LNAM(3) DIMENSION JOUT(10),IFN(9),MNAM(3),NNAM(3) DIMENSION IHP3(6),IHP4(6),IHP41(7),IRSET(8) DIMENSION NOMON(10) C EQUIVALENCE(NOF,KFORM(531)) C LOGICAL JPAR,ISBTW,GETBK,OKABT C C DATA VALUES : C DATA INAM/2HTG,2HP0,2H / DATA JNAM/2HTG,2HPI,2H0 / DATA KNAM/2HTG,2HPI,2H1 / DATA LNAM/2HTG,2HPI,2H3 / DATA NNAM/2HTG,2HP3,2H / DATA MNAM/2HDC,2HMO,2HN / DATA IFN/4,2,3,1,5,6,7,8,9/ DATA IHP3/0,2,7,3,4,5/ DATA IHP4/1,6,7,8,9,10/ DATA IHP41/1,6,7,0,8,9,10/ DATA IRSET/15530B,15555B,15446B,2Hk0,2HB ,15542B,15510B,15512B/ DATA NOMON/2H'D,2HCM,2HON,2H' ,2HNO,2HT ,2HPR,2HES,2HEN,2HT / C C********************************************************************* C C ACCORDING TO INDIC VALUE GO TO THE REQUIRED PORTION OF TGP1 C C********************************************************************* IF(INDIC.NE.1) GO TO 20 INDIC=0 GO TO 227 20 IF(INDIC.NE.2) GO TO 25 INDIC=0 GO TO 526 25 IF(INDIC.NE.3) GO TO 30 INDIC=0 GO TO 222 30 IF(INDIC.NE.4) GO TO 35 INDIC=0 GO TO 230 35 IF(INDIC.NE.-77) GO TO 40 INDIC=0 GO TO 3062 40 IF(INDIC.EQ.99) GO TO 990 C C C********************************************************************* C C INDIC = 0 GET THE ANSWERS IN THE SCREEN C C********************************************************************* C 15 IF(ISBTW(ISCRN,3,4)) ITLOG=2 IF(ISCRN.EQ.3) ITLOG=36 IF(ISCRN.EQ.4) ITLOG=36 IF((ISCRN.EQ.4).AND.(IMODB.EQ.0)) ITLOG=34 IF(.NOT.(GETBK(ILU,KFORM,ITLOG))) GO TO 10 C C ERROR IN GETTING ANSWERS REPRINT SCREEN C 17 CALL EXEC(8,INAM) C C********************************************************************* C C GO TO ANALYSE USER ANSWERS TO SCREEN # ISCRN C C********************************************************************* C 10 GO TO (100,400,200,500,600) ISCRN C C********************************************************************* C C SCREEN # 0 ANSWERS (EXPLANATORY SCREEN) C C********************************************************************* C 100 IF(ISCRN.EQ.1) GO TO 300 NOF=1 IF(JPAR(KFORM,ITLOG,NOF,JOUT,2,IFLG,JVAL)) GO TO 3000 ISCRN=1 GO TO 1000 C C********************************************************************* C C SCREEN # 3 ANSWERS (MODE OF OPERATION) C C********************************************************************* C C MODE OF OPERATION C 200 NOF=1 IF(JPAR(KFORM,ITLOG,NOF,JOUT,1,IFLG,JVAL)) GO TO 3000 JVAL1=-1 IF(JOUT.EQ.2HC ) JVAL1=1 IF(JOUT.EQ.2HM ) JVAL1=2 IF(JOUT.EQ.2HL ) JVAL1=3 IF(JOUT.EQ.2HB ) JVAL1=4 IF(JVAL1.EQ.-1) GO TO 250 CALL MOVCA(JOUT,1,IFORM,13,1) IF(JVAL1.EQ.1) IUMAX=0 IF(JVAL1.EQ.1) IMMAX=0 C C TRANSACTION SPEC NAME OR # C NOF=NOF+1 IF(JPAR(KFORM,ITLOG,NOF,JOUT,6,IFLG,JVAL)) GO TO 3000 IF((ISBTW(JVAL1,2,3)).AND.(IFLG.NE.0)) GO TO 260 IF(.NOT.(ISBTW(JVAL1,2,3)).AND.(IFLG.EQ.0)) GO TO 580 IF(IFLG.EQ.0) GO TO 207 IF(IFLG.NE.1) GO TO 205 IF((JVAL.LT.1).OR.(JVAL.GT.9999)) GO TO 550 GO TO 207 205 IF(ISBTW(IGET1(JOUT,1),1HA,1HZ)) GO TO 265 207 CALL MOVEW(JOUT,IFORM(8),3) C C TRANSACTION SPEC SECURITY CODE C NOF=NOF+1 IF(JPAR(KFORM,ITLOG,NOF,JOUT,6,IFLG,JVAL)) GO TO 3000 IF((ISBTW(JVAL1,2,3)).AND.(IFLG.NE.0)) GO TO 260 IF(.NOT.(ISBTW(JVAL1,2,3)).AND.(IFLG.GT.1)) GO TO 555 IF(JVAL.EQ.-32768) GO TO 555 CALL MOVEW(JOUT,IFORM(11),3) C C FILE NAME C NOF=NOF+1 IF(JPAR(KFORM,ITLOG,NOF,JOUT,6,IFLG,JVAL)) GO TO 3000 IF((ISBTW(JVAL1,2,3)).AND.(IFLG.NE.0)) GO TO 260 IF(.NOT.(ISBTW(JVAL1,2,3)).AND.(IFLG.EQ.0)) GO TO 262 CALL MOVEW(JOUT,IFORM(14),3) C C CARTRIDGE # C NOF=NOF+1 IF(JPAR(KFORM,ITLOG,NOF,JOUT,6,IFLG,JVAL)) GO TO 3000 IF(ISBTW(JVAL1,2,3).AND.(IFLG.NE.0)) GO TO 260 IF(IFLG.GT.1) GO TO 264 IF(JVAL.EQ.-32768) GO TO 264 CALL MOVEW(JOUT,IFORM(17),3) C C LIST FILE NAME C NOF=NOF+1 IF(JPAR(KFORM,ITLOG,NOF,JOUT,6,IFLG,JVAL)) GO TO 3000 IF((JVAL1.NE.3).AND.(IFLG.NE.0)) GO TO 260 IF(JVAL1.NE.3) GO TO 209 C C DEFAULT LIST FILE IS INTERACTIVE LU C IF(IFLG.NE.0) GO TO 210 ISKIP=ILU GO TO 209 C C A LIST FILE NAME HAS BEEN GIVEN CHECK FILE EXIST ,IS TYPE 0 C GET THE LU # IN THE IDCB . C 210 IF(OPEN(KFORM,ISTAT,JOUT).LT.0) GO TO 212 IF(ISTAT.NE.0) GO TO 211 ISKIP=KFORM(4) CALL CLOSE(KFORM) GO TO 209 C C FILE TYPE IS NOT 0 C 211 IMES=4 CALL CLOSE(KFORM) GO TO 232 C C ERROR IN OPENING THE FILE C 212 IMES=0 IF(ISTAT.EQ.-6) IMES=20 IF(IMES.EQ.0) CALL JASC(ISTAT,JOUT,1,6) GO TO 232 C 209 CALL MOVEW(JOUT,IFORM(20),3) C C IF MODE OF OPERATION IS "B" PRINT SCREEN 19 C IF(JVAL1.NE.4) GO TO 199 CALL BLANC(ILIBR,61) ISCRN=20 INDIC=0 CALL EXEC(8,NNAM) C C IF MODE OF OPERATION IS "L" OR "M" GO TO READ FORM C 199 IF(JVAL1.GT.1) GO TO 225 C C HERE POINT OF RETURN FORM TGP10 IF MODE OF OP. WAS L OR M C TRANS. SPEC HAS BEEN READ C 222 JVAL=IGET1(IFORM,13) C C IF MODE OF OPERATION IS "L" GO TO PRINT SPECS C IF((JVAL.EQ.2HM ).OR.(JVAL.EQ.2HC )) GO TO 223 INDIC=4278 CALL EXEC(8,LNAM) C C IF MODE OF OPERATION IS "C" OR "M" INITIALISE BUFFERS C 223 CALL NUL(ILITE,15) CALL NUL(IMAI,225) IMFLG=0 IMAS=0 IMDT=0 IMKY=0 CALL NUL(IKEY,33) ILITE(5)=-99 ILITE(10)=-99 ILITE(15)=-99 KFORM(1060)=0 C C INITIALISE SOURCE BUFFERS ONLY FOR CREATE C CALL BLANC(ILIBR,61) IF(JVAL.NE.2HC ) GO TO 224 INDIC=0 DO 706 I=21,494 706 IFORM(I)=2H CALL BLANC(JFORM,980) CALL BLANC(LFORM,39) CALL BLANC(MFORM,16) DO 714 I=1,20 714 JFORM(46+(I-1)*49)=0 C C INITIALISE SFK'S TO THE DEFAULT SET C C KEY # C IFORM(44)=2H2 IFORM(60)=2H 3 IFORM(77)=2H4 IFORM(93)=2H 5 IFORM(110)=2H6 IFORM(126)=2H 7 IFORM(143)=2H8 IFORM(159)=2H 9 IFORM(176)=2H10 C C FUNCTION # AND TERMINATOR C IFORM(53)=2HAB IFORM(54)=2HX IFORM(69)=2H R IFORM(70)=2HCX IFORM(86)=2HSV IFORM(87)=2HX IFORM(102)=2H T IFORM(103)=2HCX IFORM(119)=2HAD IFORM(120)=2HX IFORM(135)=2H S IFORM(136)=2HUX IFORM(152)=2HMP IFORM(153)=2HX IFORM(168)=2H D IFORM(169)=2HVX IFORM(̢185)=2HEQ IFORM(186)=2HX C C SFK'S LABELS C DO 720 I=1,9 CALL FILAB(I,0,IFN(I),IFORM) 720 CONTINUE C C CALL NEXT SCREEN C 224 ISCRN=4 GO TO 1000 C C GO TO READ FORM C 225 CALL EXEC(8,JNAM) C C RETURN FROM TGP10 AN ERROR HAS OCCURED IN READING SPEC REPRINT C SCREEN 3 SET INDIC TO 4 TO PRINT LATER THE ERROR . C 227 ISCRN=3 INDIC=4 CALL EXEC(8,INAM) C C ERRORS ON READING FORM C 230 IMES=0 IF(ISKIP.EQ.1) IMES=15 IF(ISKIP.EQ.2) IMES=16 IF(ISKIP.EQ.5) IMES=17 IF(ISKIP.EQ.6) IMES=18 IF(ISKIP.EQ.-6) IMES=20 IF(ISKIP.EQ.7) IMES=21 NOF=2 IF((IMES.NE.15).AND.(IMES.NE.17)) GO TO 231 NOF=4 231 IF(IMES.EQ.20) NOF=4 IF(IMES.EQ.21) NOF=3 IF(IMES.NE.0) GO TO 232 IMES=19 CALL JASC(ISKIP,JOUT,1,6) 232 CALL MES01(IMES,NOF,JOUT) GO TO 15 C C ERROR PROCESSING SCREEN # 3 C 250 CALL MES01(1,NOF) GO TO 15 260 CALL MES01(10,NOF) GO TO 15 261 CALL MES01(11,NOF) GO TO 15 262 CALL MES01(12,NOF) GO TO 15 263 CALL MES01(13,NOF-1) GO TO 15 264 CALL MES01(14,NOF) GO TO 15 265 CALL MES01(22,NOF) GO TO 15 C C********************************************************************* C C SCREEN # 1 ANSWERS (EXPLANATORY SCREEN) C C********************************************************************* C 300 NOF=1 IF(JPAR(KFORM,ITLOG,NOF,JOUT,2,IFLG,JVAL)) GO TO 3000 ISCRN=2 GO TO 1000 C C********************************************************************* C C SCREEN # 2 ANSWERS (EXPLANATORY SCREEN) C C********************************************************************** C 400 NOF=1 IF(JPAR(KFORM,ITLOG,NOF,JOUT,2,IFLG,JVAL)) GO TO 3000 ISCRN=3 GO TO 1000 C C********************************************************************* C C SCREEN # 4 ANSWERS (TRANS. IDENTIFICATION AND TYPE)] C C********************************************************************** C C C SPECS NAME C 500 NOF=1 IF(JPAR(KFORM,ITLOG,NOF,JOUT,6,IFLG,JVAL)) GO TO 3000 IF(IFLG.EQ.0) GO TO 580 IF(ISBTW(IGET1(JOUT,1),1HA,1HZ)) GO TO 265 CALL MOVEW(JOUT,IFORM(29),3) C C SPECS NUMBER C NOF=NOF+1 IF(JPAR(KFORM,ITLOG,NOF,JOUT,4,IFLG,JVAL)) GO TO 3000 IF(IFLG.EQ.0) GO TO 550 IF(IFLG.NE.1) GO TO 550 IF((JVAL.LT.1).OR.(JVAL.GT.9999)) GO TO 550 502 CALL MOVEW(JOUT,IFORM(32),2) C C SPECS SECURITY CODE C NOF=NOF+1 IF(JPAR(KFORM,ITLOG,NOF,JOUT,6,IFLG,JVAL)) GO TO 3000 IF(IFLG.GT.1) GO TO 555 IF(JVAL.EQ.-32768) GO TO 555 CALL MOVEW(JOUT,IFORM(34),3) ITT=0 C C ECHO ON PRINTER ? (3070B ONLY) C IF(IMODB.EQ.1) GO TO 505 CALL PUTCA(IFORM,1H ,86) GO TO 510 505 NOF=NOF+1 IF(JPAR(KFORM,ITLOG,NOF,JOUT,1,IFLG,JVAL)) GO TO 3000 IF((IFLG.NE.0).AND.(JOUT(1).NE.2HX )) GO TO 585 CALL MOVCA(JOUT,1,IFORM,86,1) C C-----LOGGING? C 510 NOF=NOF+1 IF(JPAR(KFORM,ITLOG,NOF,JOUT,1,IFLG,JVAL)) GO TO 3000 IF((IFLG.NE.0).AND.(JOUT(1).NE.2HX )) GO TO 585 CALL MOVCA(JOUT,1,IFORM,74,1) C C USER WRITTEN MODULES ? C 520 NOF=NOF+1 IF(JPAR(KFORM,ITLOG,NOF,JOUT,1,IFLG,JVAL)) GO TO 3000 IF((IFLG.NE.0).AND.(JOUT(1).NE.2HX )) GO TO 585 IF(JOUT(1).EQ.2HX ) ITT=ITT+1 CALL MOVCA(JOUT,1,IFORM,73,1) C C DATA BASE NAME C NOF=NOF+1 IF(JPAR(KFORM,ITLOG,NOF,JOUT,5,IFLG,JVAL)) GO TO 3000 IF((IFLG.NE.0).AND.(NIMAG.EQ.1)) GO TO 586 IF(IFLG.NE.0) ITT=ITT+2 CALL MOVCA(JOUT,1,IFORM,75,5) IFORM(40)=IAND(IFORM(40),177400B) IFORM(40)=IFORM(40)+40B C C DATA BASE SECURITY CODE C NOF=NOF+1 IF(JPAR(KFORM,ITLOG,NOF,JOUT,5,IFLG,JVAL)) GO TO 3000 IF(IFLG.EQ.0) GO TO 525 IF(IFLG.NE.1) GO TO 570 IF(JVAL.LT.1) GO TO 570 525 IF((ITT.GT.1).AND.(IFLG.NE.1)) GO TO 570 IF((ITT.LT.2).AND.(IFLG.NE.0)) GO TO 260 CALL MOVCA(JOUT,1,IFORM,81,5) C C IF DATA BASE ACESSED GO TO TGP11 TO OPEN IT ISKIP=D.B. SEC. CODE C IF(ITT.LT.2) GO TO 526 ISKIP=JVAL INDIC=0 CALL EXEC(8,KNAM) C C RETURN FROM TGP11 : DATA BASE SUCCESFULY OPENED C C C PRINT SCREEN # 5 C 526 ISCRN=5 GO TO 1000 C C SCREEN # 4 ERROR PROCESSING C 550 CALL MES01(2,NOF) GO TO 15 555 CALL MES01(3,NOF) GO TO 15 570 CALL MES01(6,NOF) GO TO 15 580 CALL MES01(7,NOF) GO TO 15 585 CALL MES01(9,NOF) GO TO 15 586 CALL MES01(5,NOF) GO TO 15 C C********************************************************************* C C SCREEN # 5 ANSWERS (EXPLANATORY SCREEN) C C********************************************************************* C 600 NOF=1 IF(JPAR(KFORM,ITLOG,NOF,JOUT,2,IFLG,JVAL)) GO TO 3000 ISCRN=6 GO TO 1000 C C*********************************************************************** C C CALL NEXT SCREEN C 1000 CALL EXEC(8,INAM) C C********************************************************************* C C C********************************************************************* C C 2645 SOFT FUNCTION KEY PROCESSING C C********************************************************************* C C IFLG=5 MEANS NON PRINTABLE ASCII C 3000 IF(IFLG.EQ.4) IFLG=5 IF(IFLG.NE.5) GO TO 3007 CALL MES01(8,NOF) GO TO 15 C C IFLG=6 MEANS ILLEGAL PARSE C 3005 IF(IFLG.NE.6) GO TO 3007 STOP 500 C C IFLG=7 MEANS HELP C 3007 IF(IFLG.NE.7) GO TO 3010 IF((ISCRN.GT.2).AND.(ISCRN.NE.5)) GO TO 3061 3006 JOUT=20040B JOUT(2)=15542B CALL EXEC(2,ILU,JOUT,2) GO TO 15 3061 INDIC=-77 GO TO 17 3062 IF(ISCRN.EQ.4) GO TO 3050 IMES=IHP3(NOF) GO TO 3060 3050 IMES=IHP4(NOF) IF(IMODB.EQ.1) I5640MES=IHP41(NOF) 3060 CALL HLP01(IMES,NOF) GO TO 15 C C IFLG=8 MEANS LAST SCREEN C 3010 IF(IFLG.NE.8) GO TO 3017 IF(ISCRN.EQ.0) GO TO 3015 ISCRN=ISCRN-1 3015 GO TO 1000 C C-----ABORT KEY PRESSED? C 3017 IF(OKABT(ILU)) GO TO 990 C-----NO, RESCHEDULE TGP0. CALL EXEC(8,INAM) C-----YES, ABORT PROGRAM C-----WAS A DATA BASE USED? 990 IF(ITT.LT.2) GO TO 992 C-----YES, (IE, TRANS. TYPE 2 OR 3) CLOSE DATA BASE CALL DBCLS(0,ISTAT) C-----RESET TERMINAL. 992 CALL EXEC(2,ILU,IRSET,8) C-----RE-SCHEDULE 'DCMON' CALL EXEC(100000B+24,MNAM,ILU) GO TO 995 993 GO TO 999 C-----"DCMON NOT PRESENT" 995 CALL EXEC(2,ILU,NOMON,10) GO TO 999 C-----END OF SEGMENT 996 CALL TGP 999 END END$ =6  92903-18353 1805 S C0122 &MES01              H0101 `|ASMB,R NAM MES01,7 92903-16353 REV.1805 780518 * * SOURCE 92903-18353 * SPC 2 ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** SPC 2 SUP * ********************************************************************** * * * THIS SUBROUTINE IS CALLED BY THE SEGMENT ANSWR * * OF THE FORMG PROGRAM TO WRITE AN ERROR MESSAGE ON THE TERMINAL. * * THE ERROR MESSAGE IS PRINTED ON LINE 24 OF THE * * SCREEN AND THE CURSOR IS MOVED TO THE WRONG FIELD. * * THIS SUBROUTINE IS CALLED WITH TWO PARAMETERS : * * * * - PAR#1 = ERROR MESSAGE # TO OUTPUT * * - PAR#2 = WRONG FIELD # ON THE SCREEN * * * ********************************************************************** * * ENT MES01 ENTRY POINT EXT EXEC EXT .ENTR EXT &REMP EXT &MVW COM ILU TERM. LU * * GET CALLING PARAMETERS AND INITIALISE * NMESS NOP FIRST PARM. ADDRESS NOF NOP SECD. PARM. ADDRESS NIER NOP MES01 NOP ENTRY POINT JSB .ENTR SUBR. TO GET DEF NMESS PARM. ADDRESS LDA BUFAD INITIALIZE LDB SPACE ERROR MESSAGE JSB &REMP BUFFER DEC -35 TO BLANK LDA BUFA1 INITIALIZE LDB NULL TAB BUFFER JSB &REMP TO NULL DEC -50 * * MOVE ERROR MESSAGE IN OUTPUT BUFFER * LDA NIER LDB ANMES JSB &MVW DEC 3 LDA NMESS,I GET ERROR MESSAGE # ADA AMES0 COMPUTE MESSAGE LDB A,I ADDRESS STB P1 STORE IT CMB,INB MINUS STARTING ADDRESS STB IST OF MESSAGE IN IST INA COMPUTE NEXT MESSAGE LDA A,I STARTING ADDRESS ADA IST COMPUTE MESSAGE LENGTH STA P2 STORE IT LDA P1 BUFFER SOURCE ADDRESS LDB BUFAD BUFFER DEST ADDRESS JSB &MVW MOVE WORDS P2 NOP BUFFER LENGTH * * INCLUDE # OF NECESSARY TABS * LDA NOF,I GET WRONG FIELD # CMA,INA MAKE IT NEG. ISZ A INCREMENT: IS FIRST FIELD ? RSS NO JMP WRIT YES OUTPUT BUFFER STA P3 STORE NEG. # OF TABS LDA BUFA1 TAB BUFFER ADDRESS LDB TAB TAB JSB &REMP INCLUDE TABS P3 NOP IN BUFFER * * WRITE MESSAGE * WRIT JSB EXEC WRITE EXEC CALL DEF *+5 RETURN POINT DEF D.2 CODE EXEC DEF ILU CONTROL WORD DEF BUF BUFFER LOCATION DEF ILN BUFFER LENGTH * * RETURN TO CALLING PROGRAM * JMP MES01,I * * BUFFER DATA * BUF BYT 33,130,33,46,141,62,62,162,60,103 FORMAT OFF:POS.CURSOR BYT 33,112,15,12,40,0 CLEAR DISP CR,LF BYT 33,46,144,103 INVERSE VIDEO BLINKING ASC 2,ERRO BYT 122,33,46,144,100 END ENHANCEMENT ASC 2, : BUFER BSS 35 MESSAGE BUFFER BYT 33,127,33,110 FORMAT ON * HOME CURSOR BUF1 BSS 50 TAB BUFFER BYT 33,142 KEYBOARD ENABLE EBUF BYT 0,137 SUPPRESS , * * STORAGE , CONSTANTS .. * BUFAD DEF BUFER BUFF. ADDRESS BUFA1 DEF BUF1 TAB BUFFER ADDRESS ANMES DEF INMES A EQU 0 A REGISTER STAD EQU BUF BUFFER STARTING ADDRESS LTAD EQU EBUF BUFFER LAST ADDRESS IST NOP P1  NOP SOURCE ADDRESS BUFFER ADDRESS ILN ABS LTAD-STAD+1 BUFFER LENGTH SPACE BYT 40,40 NULL BYT 0,0 TAB BYT 33,111 D.2 DEC 2 * * MESSAGE ADDRESS * AMES0 DEF AMES1-1 AMES1 DEF MES1 DEF MES2 DEF MES3 DEF MES4 DEF MES5 DEF MES6 DEF MES7 DEF MES8 DEF MES9 DEF MES10 DEF MES11 DEF MES12 DEF MES13 DEF MES14 DEF MES15 DEF MES16 DEF MES17 DEF MES18 DEF MES19 DEF MES20 DEF MES21 DEF MES22 DEF MES23 * * MESSAGE STORAGE * MES1 ASC 13,Illegal mode of operation MES2 ASC 18,Illegal transaction specification # MES3 ASC 24,Illegal transaction specification security code MES4 ASC 9,Illegal file type MES5 ASC 21,This version of TGP does not support IMAGE MES6 ASC 22,Data base security code illegal or not given MES7 ASC 23,Transaction specification name or # not given MES8 ASC 12,Illegal character input MES9 ASC 12,Field must be blank or X MES10 ASC 10,Field must be blank MES11 ASC 10,Illegal logical unit MES12 ASC 12,File name must be given MES13 ASC 9,No file name given MES14 ASC 12,Illegal cartridge number MES15 ASC 23,No transaction specification on the selected m ASC 2,edia MES16 ASC 18,Transaction specification not found MES17 ASC 13,Unable to lock type 0 file MES18 ASC 14,Unable to unlock type 0 file MES19 ASC 10,System error : FMGR INMES ASC 3, MES20 ASC 13,Library could not be found MES21 ASC 10,Wrong security code MES22 ASC 19,Illegal transaction specification name MES23 ASC 1,-1 * * END MES01 M  92903-18354 1805 S C0122 &HLP01              H0101 htASMB,R NAM HLP01,7 92903-16354 REV.1805 770809 * * SOURCE 92903-18354 * SPC 2 ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** SPC 2 SUP * ********************************************************************** * * * THIS SUBROUTINE IS USED TO PRINT A HELP MESSAGE * * ON LINES 23 AND 24 OF THE TGP SCREENS * * THE CURSOR IS POSITIONEDAT THE FIELD WHERE THE * * HELP SOFT KEY WAS PRESSED. * * THIS SUBROUTINE IS CALLED WITH TWO PARAMETERS : * * * * - PAR#1 = HELP MESSAGE # TO OUTPUT * * - PAR#2 = HELP FIELD # ON THE SCREEN * * * ********************************************************************** * * ENT HLP01 ENTRY POINT EXT EXEC EXT .ENTR EXT &REMP EXT &MVW COM ILU TERM. LU * * GET CALLING PARAMETERS * NMESS NOP FIRST PARM. ADDRESS NOF NOP SECD. PARM. ADDRESS HLP01 NOP ENTRY POINT JSB .ENTR SUBR. TO GET DEF NMESS PARM. ADDRESS * * * MOVE HELP MESSAGE IN OUTPUT BUFFER * LDA NMESS,I GET ERROR MESSAGE # SZA,RSS IS 0 ? JMP HPLC YES NO MESSAGE ADA AMES0 COMPUTE MESSAGE LDB A,I ADDRESS STB P1 STORE IT CMB,INB MINUS STARTING ADD>ERESS STB IST OF MESSAGE IN IST INA COMPUTE NEXT MESSAGE LDA A,I STARTING ADDRESS ADA IST COMPUTE MESSAGE LENGTH STA P2 STORE IT LDA P1 BUFFER SOURCE ADDRESS LDB BUFAD BUFFER DEST ADDRESS JSB &MVW MOVE WORDS P2 NOP BUFFER LENGTH * LDB BUFAD COMPUTE CURRENT ADB P2 ADDRESS IN OUTPUT BUFFER * LDA BUF1 INCLUDE FORMAT ON STA B,I IN OUTPUT BUFFER INB INCREMENT ADDRESS IN OUT. BUFFER * LDA D.10 COMPUTE OUTPUT BUFFER LENGTH ADA P2 STA ILN STORE IT JMP HPLB * HPLC LDA D.10 STA ILN LDB BUFAD LDA BUF1 STA B,I INB * * NOW INCLUDE TABS IN BUFFER * HPLB LDA NOF,I GET HELP FIELD # CPA D.1 IS 1 ? JMP HLPA YES NO TABS ADA .D1 DECREMENT STA P5 STORE # OF FIELD ADA ILN INCREMENT OUTPUT BUFFER STA ILN LENGTH LDA P5 GET FIELD # CMA,INA MAKE IT NEG STA P4 LDA B STB P2 SAVE B LDB TAB JSB &REMP MOVE TABS IN BUFFER P4 NOP * LDB P2 RESTORE B LDA P5 INCREMENT ADDRESS IN ADB A * HLPA LDA BUFA2 JSB &MVW INCLUDE KEY ENABLE DEC 3 IN BUFFER * JSB EXEC WRITE MESSAGE DEF *+5 DEF D.2 DEF ILU DEF BUF DEF ILN * JMP HLP01,I * * * BUFFER DATA * BUF BYT 33,130,33,46,141,62,62,162,60,103 FORMAT OFF:POS.CURSOR BYT 33,112 CLEAR DISPLAY BUFER BSS 140 MESSAGE BUFFER * * STORAGE , CONSTANTS .. * BUFAD DEF BUFER BUFF. ADDRESS BUFA2 DEF BUF2 A EQU 0 A REGISTER B EQU 1 B REGISTER IST NOP P1 NOP SOURCE ADDRESS BUFFER ADDRESS P5 NOP ILN NOP BUFFER LENGTH TAB BYT 7C33,111 BUF1 BYT 33,127 FORMAT ON BUF2 BYT 0,0,0,33,142,137 ERASE h ,KEY.ENABLE .D1 DEC -1 D.10 DEC 10 D.1 DEC 1 D.2 DEC 2 * * MESSAGE ADDRESS * AMES0 DEF AMES1-1 AMES1 DEF MES1 DEF MES2 DEF MES3 DEF MES4 DEF MES5 DEF MES6 DEF MES7 DEF MES8 DEF MES9 DEF MES10 DEF MES11 * * MESSAGE STORAGE * MES1 BYT 33,46,144,112 ASC 22, Name (maximum of 6 alphanumeric characters) ASC 18, : It uniquely identifies each BYT 33,46,144,112 ASC 14, transaction specification. BYT 33,46,141,53,65,62,103,0 POSITION CURSOR - 81 * MES2 BYT 33,46,144,112 ASC 22, The name (6 alphanumeric characters) or num ASC 18,ber (from 0 to 9999) uniquely BYT 33,46,144,112 ASC 20, identify each transaction specification BYT 33,46,141,53,64,60,103,0 POSITION CURSOR - 81 * MES3 BYT 33,46,144,112 ASC 22, The Disc File name is composed of 6 printab ASC 18,le alphanumeric characters starting * BYT 33,46,144,112 ASC 15, with an alphabetic character. BYT 33,46,141,53,65,60,103,0 POSITION CURSOR - 81 * MES4 BYT 33,46,144,112 ASC 22, Each disc cartridge in an RTE system is ide ASC 18,ntified by a Cartridge Reference # * BYT 33,46,144,112 ASC 17, assigned by the system operator. BYT 33,46,141,53,64,66,103,0 POSITION CURSOR - 81 * MES5 BYT 33,46,144,112 ASC 22, File name of an output device selected amon ASC 18,g those defined when installing * BYT 33,46,144,112 ASC 4, DATACAP BYT 33,46,141,53,67,62,103,0 POSITION CURSOR - 81 * MES6 BYT 33,46,144,112 ASC 22, Number (0=, * * STORAGE , CONSTANTS .. * BUFAD DEF BUFER BUFF. ADDRESS BUFA1 DEF BUF1 TAB BUFFER ADDRESS A EQU 0 A REGISTER STAD EQU BUF BUFFER STARTING ADDRESS LTAD EQU EBUF BUFFER LAST ADDRESS IST NOP P1 NOP SOURCE ADDRESS BUFFER ADDRESS ILN ABS LTAD-STAD+1 BUFFER LENGTH SPACE BY& T 40,40 NULL BYT 0,0 TAB BYT 33,111 D.2 DEC 2 * * MESSAGE ADDRESS * AMES0 DEF AMES1-1 AMES1 DEF MES1 DEF MES2 DEF MES3 DEF MES4 DEF MES5 DEF MES6 DEF MES7 DEF MES8 DEF MES9 DEF MES10 DEF MES11 DEF MES12 DEF MES13 DEF MES14 DEF MES15 DEF MES16 DEF MES17 DEF MES18 DEF MES19 DEF MES20 DEF MES21 DEF MES22 DEF MES23 * * MESSAGE STORAGE * MES1 ASC 12,Illegal character input MES2 ASC 8,Key # not given MES3 ASC 9,Illegal key number MES4 ASC 10,Key already assigned MES5 ASC 18,PREFIX key cannot be assigned twice MES6 ASC 23,A key cannot be assigned a value and a functio ASC 8,n simultaneously MES7 ASC 21,No value or function assigned to this key MES8 ASC 8,Unknown function MES9 ASC 23,Illegal function for this type of transaction MES10 ASC 13,Function already selected MES11 ASC 15,This key cannot be terminator MES12 ASC 12,Field must be blank or X MES13 ASC 19,This key cannot be terminator any more MES14 ASC 14,This key must be terminator MES15 ASC 21,TRANSACTION COMPLETE function not defined MES16 ASC 13,EQUAL function not defined MES17 ASC 20,Attempt to define more than 20 questions MES18 ASC 13,Questions not in sequence MES19 ASC 12,Must define questions MES20 ASC 10,Field must be blank MES21 ASC 18,ABORT / SELECT function not defined MES22 ASC 21,No Arithmetic function defined with EQUAL MES23 ASC 1,-1 * * END MES02   92903-18357 1805 S C0122 &HLP02              H0101 kuASMB,R NAM HLP02,7 92903-16357 REV.1805 770809 * * SOURCE 92903-18357 * SPC 2 ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** SPC 2 SUP * ********************************************************************** * * * THIS SUBROUTINE IS USED TO PRINT A HELP MESSAGE * * ON LINES 23 AND 24 OF THE TGP SCREENS * * THE CURSOR IS POSITIONEDAT THE FIELD WHERE THE * * HELP SOFT KEY WAS PRESSED. * * THIS SUBROUTINE IS CALLED WITH TWO PARAMETERS : * * * * - PAR#1 = HELP MESSAGE # TO OUTPUT * * - PAR#2 = HELP FIELD # ON THE SCREEN * * * ********************************************************************** * * ENT HLP02 ENTRY POINT EXT EXEC EXT .ENTR EXT &REMP EXT &MVW COM ILU TERM. LU * * GET CALLING PARAMETERS * NMESS NOP FIRST PARM. ADDRESS NOF NOP SECD. PARM. ADDRESS HLP02 NOP ENTRY POINT JSB .ENTR SUBR. TO GET DEF NMESS PARM. ADDRESS * * * MOVE HELP MESSAGE IN OUTPUT BUFFER * LDA NMESS,I GET ERROR MESSAGE # SZA,RSS IS 0 ? JMP HLPC YES NO MESSAGE ADA AMES0 COMPUTE MESSAGE LDB A,I ADDRESS STB P1 STORE IT CMB,INB MINUS STARTING ADDEGRESS STB IST OF MESSAGE IN IST INA COMPUTE NEXT MESSAGE LDA A,I STARTING ADDRESS ADA IST COMPUTE MESSAGE LENGTH STA P2 STORE IT LDA P1 BUFFER SOURCE ADDRESS LDB BUFAD BUFFER DEST ADDRESS JSB &MVW MOVE WORDS P2 NOP BUFFER LENGTH * LDB BUFAD COMPUTE CURRENT ADB P2 ADDRESS IN OUTPUT BUFFER * LDA BUF1 INCLUDE FORMAT ON STA B,I IN OUTPUT BUFFER INB INCREMENT ADDRESS IN OUT. BUFFER * LDA D.10 COMPUTE OUTPUT BUFFER LENGTH ADA P2 STA ILN STORE IT JMP HLPB * HLPC LDA D.10 STA ILN LDB BUFAD LDA BUF1 STA B,I INB * * NOW INCLUDE TABS IN BUFFER * HLPB LDA NOF,I GET HELP FIELD # CPA D.1 IS 1 ? JMP HLPA YES NO TABS ADA .D1 DECREMENT STA P5 STORE # OF FIELD ADA ILN INCREMENT OUTPUT BUFFER STA ILN LENGTH LDA P5 GET FIELD # CMA,INA MAKE IT NEG STA P4 LDA B STB P2 SORE B LDB TAB JSB &REMP MOVE TABS IN BUFFER P4 NOP * LDB P2 RESTORE B LDA P5 INCREMENT ADDRESS IN ADB A * HLPA LDA BUFA2 JSB &MVW INCLUDE KEY ENABLE DEC 3 IN BUFFER * JSB EXEC WRITE MESSAGE DEF *+5 DEF D.2 DEF ILU DEF BUF DEF ILN * JMP HLP02,I * * * BUFFER DATA * BUF BYT 33,130,33,46,141,62,62,162,60,103 FORMAT OFF:POS.CURSOR BYT 33,112 CLEAR DISPLAY BUFER BSS 140 MESSAGE BUFFER * * STORAGE , CONSTANTS .. * BUFAD DEF BUFER BUFF. ADDRESS BUFA2 DEF BUF2 A EQU 0 A REGISTER B EQU 1 B REGISTER IST NOP P1 NOP SOURCE ADDRESS BUFFER ADDRESS P5 NOP ILN NOP BUFFER LENGTH TAB BYT @E 33,111 BUF1 BYT 33,127 FORMAT ON BUF2 BYT 0,0,0,33,142,137 ERASE h ,KEY. ENABLE .D1 DEC -1 D.10 DEC 10 D.1 DEC 1 D.2 DEC 2 * * MESSAGE ADDRESS * AMES0 DEF AMES1-1 AMES1 DEF MES1 * * MESSAGE STORAGE * MES1 ASC 1,CC * * END HLP02   92903-18358 1805 S C0222 &TGP3A              H0102 kASMB,R NAM TGP3,5 92903-16358 REV.1805 780426 * * SOURCE 92903-18358 * SPC 2 ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** SPC 2 HED * -TGP3- SUP * * PRGMR : JEAN CHARLES MIARD (HPG) * ********************************************************************** * * * * * THIS IS A SEGMENT OF THE TGP PROGRAM USED TO WRITE ON * * THE 2640/2645 DISPLAY THE SCREEN MASKS USED TO COLLECT INFORMA- * * TION TO BUILD A TRANSACTION SPECIFICATION . * * * * TGP3 PRINT SCREENS 8,9,10,11,12,19 AND 20 ACCORDING TO * * ISCRN VALUE AND THEN LOADS THE REQUIRED SEGMENT TO ANALYSE THE * * USER'S ANSWERS . * * BEFORE PRINTING THE SCREENS TGP3 INCLUDES IN THEM THE OLD * * ANSWERS STORED IN IFORM,JFORM AND ILIBR . * * SOME SCREENS ARE DYNAMIC AND ONLY PARTS OF THE TOTAL * * SCREEN ARE PRINTED . * * * * IF INDIC=-77 THE SCREEN IS TO BE PRINTED WITHOUT ERASING * * THE DISPLAY BEFORE (HELP MESSAGE) . * * * * * * WARNING !! * : CARE MUST BE TAKEN : * * 6 * * PRINTED SCREEN # 8 CORRESPONDS TO ISCRN = 9 * ............ 9 .................... 10 * * ............ 10 .................... 11 * * ............ 11 .................... 12 * * ............ 12 .................... 13 * * ............ 19 .................... 20 * * ............ 20 .................... 21 * * * ********************************************************************** * * * * ENT TGP3 ENTRY POINT EXT EXEC EXT TGP MAIN PROGRAM EXT MOVCA SUBR. MOVES CHARS. EXT MOVCX SUBR. MOVES ANSWERS IN UNPRO. FIELDS EXT &REMP EXT &MVW MOVES WORDS * * DECLARATIONS COMMON VARIABLES ********* * COM ILU,ISCRN,IQST,ISKIP,INDIC COM IFORM(494) ANSWER STORAGE COM JFORM(980) ANSWER STORAGE COM MFORM(16) COM LFORM(39) ANSWER STORAGE COM ITT TRANS TYPE COM IKEY(33) COM IUMAX # OF U QUESTIONS COM IMMAX #OF M QUESTIONS COM IMODB (0/1) 3070A/3070B COM ILITE(15) COM IMAI(225) COM IMFLG,IMAS,IMDT,IMKY COM KFORM(1065) COM ILIBR(61) COM NIMAG * TGP3 LDA INDIC GET INDICATOR CPA .D77 IS IT PRINT FOR HELP ? RSS YES JMP CONT NO JUMP CLA STA CL01 STA CL02 STA CL03 STA CL04 STA CL05 CONT LDA IQST LOAD QUESTION # ADA .D1 DECREMENT MPY D.98 MULT. PER # OF CHARS PER QUESTION STA D.OFF STORE IT * *FIND SCREEN # TO DISPLAY * LDA ISCRN GET SCREEN # CPA D.20 IS SCREEN 19 ? JMP SCR20 YES CPA D.21 IS SCREEN 20 ? JMP SCR21 YES ADA .D9 ADA ASCR JMP A,I * * TABLE OF ADDRESS FOR SCREENS * ASCR DEF *+1,I DEF SCR9 DEF SCR9 DEF SCR11 DEF SCR12 DEF SCR12 * * * DATA SECTION * A EQU 0 D.0 DEC 0 D.1 DEC 1 D.2 DEC 2 D.6 DEC 6 D.8 DEC 8 .D9 DEC -9 .D77 DEC -77 D.10 DEC 10 D.12 DEC 12 D.13 DEC 13 D.20 DEC 20 D.21 DEC 21 D.747 DEC 747 D.57 DEC 57 D.98 DEC 98 DBL09 NOP D.OFF NOP * ********************************************************************** * * SCREEN # 8 AND 9 LABELS FOR U AND M QUESTIONS * ********************************************************************** * * SCR9 LDA ISCRN GET SCREEN # CPA D.10 IS 10 ? JMP SCR10 YES ! LDA IUMAX GET # OF U QUESTIONS INA INCREMENT STA LNU9 TABLE OF OFFSETS LENGTH LDA ASO10 CONSTRUCT TABLE OF CHAR OFFSETS LDB ASO9 JSB &MVW MOVE OFFSETS IN TABLE LOCATION LNU9 NOP TABLE LENGTH LDA ASO9 INSERT ADA IUMAX MINUS 1 INA AT THE LDB .D1 END OF STB A,I TABLE. JMP SCR91 SCR10 LDA MQ MOVE "M" STA T9 IN TITLE LDA S10 MOVE "10" STA T91 IN TITLE LDA IMMAX NUMBER OF M QUESTIONS INA INCREMENT STA LNM9 TABLE OF OFFSETS LENGTH LDA ASO10 ADA IUMAX CONSTRUCT TABLE OF OFFSSETS LDB ASO9 SCREEN # 10 JSB &MVW LNM9 NOP TABLE LENGTH LDA ASO9 ADA IMMAX INSERT MINUS 1 INA AT THE END LDB .D1 OF THE TABLE STB A,I SCR91 JSB MOVCA MOVE DEF *+6 FORM NAME DEF IFORM FROM ANSWER STORAGE DEF D.57 DEF T10 TO SCREEN TITLE DEF D.1 DEF D.6 MOVE LENGTH LDA IUMAX # OF U QUESTIONS LDB ISCRN SCREEN #  CPB D.10 IS 10 ? LDA IMMAX YES GET # OF M QUESTIONS SZA,RSS IS IT 0 ? JMP WRIT9 YES ! JSB MOVCX NO MOVE ANSWERS IN UNPROTECTED FIELDS DEF *+6 DEF IFORM ANSWER STORAGE DEF SOF9 TABLE OF OFFSETS IN IFORM DEF BD9 TABLE OF BUFF DEST ADDRESSES DEF D.0 DEST OFFSET DEF DBL09 WRIT9 JSB EXEC WRITE EXEC CALL DEF *+5 RETURN POINT DEF D.2 CODE EXEC DEF ILU CONTROL WORD DEF BSCR9 BUF. LOCATION DEF ILSC9 BUF.LENGTH JMP CANS LOAD SEGMENT TO ANALYSE USER'S ANSWERS * * DATA SECTION * .D1 DEC -1 ASO9 DEF SOF9 TABLE OF OFFSETS ADDRESS ASO10 DEF SOF10 TABLE OF OFFSETS ADDRESS AUQ DEF UQ ADDRESS OF "U" AMQ DEF MQ ADDRESS OF "M" UQ ASC 1,U- MQ ASC 1,M- S10 ASC 1,9 AT9 DEF T9 * * TABLE OF OFFSETS FOR SCREEN # 8 & 9 * SOF9 BSS 22 REAL TABLE SOF10 DEC 747 TABLE OF ALL THE QUESTIONS (U & M) DEC 759 DEC 771 DEC 783 DEC 795 DEC 807 DEC 819 DEC 831 DEC 843 DEC 855 DEC 867 DEC 879 DEC 891 DEC 903 DEC 915 DEC 927 DEC 939 DEC 951 DEC 963 DEC 975 DEC 987 DEC -1 * * TABLE OF BUFFER DEST ADDRESSES * BD9 DEF T0900 DEF T0901 DEF T0902 DEF T0903 DEF T0904 DEF T0905 DEF T0906 DEF T0907 DEF T0908 DEF T0909 DEF T0910 DEF T0911 DEF T0912 DEF T0913 DEF T0914 DEF T0915 DEF T0916 DEF T0917 DEF T0918 DEF T0919 * * DATA SCREEN 8 AND 9 * * * LINE # : 1 * BSCR9 BYT 33,130 FORMAT OFF BYT 33,110 HOME UP CL01 BYT 33,112 CLEAR DISPLAY ASC 6, Screen # T91 ASC 1,8 BYT 40,0 BYT 33,46,144,112 # T9 ASC 5,U-QUESTION BYT 123,0 BYT 33,46,144,100 ASC 22, TO BE DEFINED IN THE TRANSACTION SPECIFICAT ASC 2,ION BYT 33,46,144,104 T10 ASC 3, * * LINE # : 2 * BYT 33,46,141,53,61,65,103,0 POSITION CURSOR - 16 BYT 33,51,102,16 ASC 7,R,,,,,,,,,,,,T BYT 33,46,141,53,62,70,103,0 POSITION CURSOR - 58 ASC 7,R,,,,,,,,,,,,T BYT 15,12 * * LINE # : 3 * ASC 7, Question 1 BYT 40,0 BYT 33,51,102,16 BYT 56,0 BYT 33,46,144,102,17,33,133,0 T0900 ASC 6, BYT 33,135,33,46,144,100,16,56 BYT 17,40 BYT 33,46,141,53,61,66,103,0 POSITION CURSOR - 47 ASC 5,Question 2 BYT 40,16 BYT 56,0 BYT 33,46,144,102,17,33,133,0 T0901 ASC 6, BYT 33,135,33,46,144,100,16,56 BYT 15,12 * * LINE # : 4 * BYT 33,46,141,53,61,65,103,0 POSITION CURSOR - 16 BYT 33,51,102,16 ASC 7,5,,,,,,,,,,,,6 BYT 33,46,141,53,62,70,103,0 POSITION CURSOR - 58 ASC 7,5,,,,,,,,,,,,6 BYT 15,12 * * LINE # : 5 * BYT 33,46,141,53,61,63,103,0 POSITION CURSOR - 14 ASC 1,3 BYT 33,51,102,16 BYT 56,0 BYT 33,46,144,102,17,33,133,0 T0902 ASC 6, BYT 33,135,33,46,144,100,16,56 BYT 17,40 BYT 33,46,141,53,62,65,103,0 POSITION CURSOR - 56 ASC 1,4 BYT 16,56 BYT 33,46,144,102,17,33,133,0 T0903 ASC 6, BYT 33,135,33,46,144,100,16,56 BYT 15,12 * * LINE # : 6 * BYT 33,46,141,53,61,65,103,0 POSITION CURSOR - 16 BYT 33,51,102,16 ASC 7,5,,,,,,,,,,,,6 BYT 33,46,141,53,62,70,103,0 POSITION CURSOR - 58 ASC 7,5,,,,,,,,,,,,6 BYT 15,12 * * LINE # : 7 * BYT 33,46,141,53,61,63,103,0 POSITION CURSOR - 14 ASC 1,5 BYT 33,51,102,16 BYT 56,0 BYT 33,46,144,102,17,33,133,0 T0904 ASC 6, BYT 33,135,33,46,144,100,16,56 BYT 17,40 BYT 33,46,141,53,62,65,103,0 POSITION CURSOR - 56 ASC 1,6 BYT 16,56 BYT 33,46,144,102,17,33,133,0 T0905 ASC 6, BYT 33,135,33,46,144,100,16,56 BYT 15,12 * * LINE # : 8 * BYT 33,46,141,53,61,65,103,0 POSITION CURSOR - 16 BYT 33,51,102,16 ASC 7,5,,,,,,,,,,,,6 BYT 33,46,141,53,62,70,103,0 POSITION CURSOR - 58 ASC 7,5,,,,,,,,,,,,6 BYT 15,12 * * LINE # : 9 * BYT 33,46,141,53,61,63,103,0 POSITION CURSOR - 14 ASC 1,7 BYT 33,51,102,16 BYT 56,0 BYT 33,46,144,102,17,33,133,0 T0906 ASC 6, BYT 33,135,33,46,144,100,16,56 BYT 17,40 BYT 33,46,141,53,62,65,103,0 POSITION CURSOR - 56 ASC 1,8 BYT 16,56 BYT 33,46,144,102,17,33,133,0 T0907 ASC 6, BYT 33,135,33,46,144,100,16,56 BYT 15,12 * * LINE # : 10 * BYT 33,46,141,53,61,65,103,0 POSITION CURSOR - 16 BYT 33,51,102,16 ASC 7,5,,,,,,,,,,,,6 BYT 33,46,141,53,62,70,103,0 POSITION CURSOR - 58 ASC 7,5,,,,,,,,,,,,6 BYT 15,12 * * LINE # : 11 * BYT 33,46,141,53,61,63,103,0 POSITION CURSOR - 14 BYT 71,0 BYT 33,51,102,16 ASC 1, . BYT 33,46,144,102,17,33,133,0 T0908 ASC 6, BYT 33,135,33,46,144,100,16,56 BYT 17,40 BYT 33,46,141,53,62,64,103,0 POSITION CURSOR - 55 ASC 1,10 BYT 40,16 BYT 56,0 BYT 33,46,144,102,17,33,133,0 T0909 ASC 6, BYT 33,135,33,46,144,100,16,56 BYT 15,12 * * LINE # : 12 * BYT 33,46,141,53,61,65,103,0 POSITION CURSOR - 16 BYT 33,51,102,16 ASC 7,5,,,,,,,,,,,,6 BYT 33,46,141,53,62,70,103,0 POSITION CURSOR - 58 ASC 7,5,,,,,,,,,,,,6 BYT 15,12 * * LINE # : 13 * BYT 33,46,141,53,61,62,103,0 POSITION CURSOR - 13 ASC 1,11 BYT 40,0 BYT 33,51,102,16 BYT 56,0 BYT 33,46,144,102,17,33,133,0 T0910 ASC 6, BYT 33,135,33,46,144,100,16,56 BYT 17,40 BYT 33,46,141,53,62,64,103,0 POSITION CURSOR - 55 ASC 1,12 BYT 40,16 BYT 56,0 BYT 33,46,144,102,17,33,133,0 T0911 ASC 6, BYT 33,135,33,46,144,100,16,56 BYT 15,12 * * LINE # : 14 * BYT 33,46,141,53,61,65,103,0 POSITION CURSOR - 16 BYT 33,51,102,16 ASC 7,5,,,,,,,,,,,,6 BYT 33,46,141,53,62,70,103,0 POSITION CURSOR - 58 ASC 7,5,,,,,,,,,,,,6 BYT 15,12 * * LINE # : 15 * BYT 33,46,141,53,61,62,103,0 POSITION CURSOR - 13 ASC 1,13 BYT 40,0 BYT 33,51,102,16 BYT 56,0 BYT 33,46,144,102,17,33,133,0 T0912 ASC 6, BYT 33,135,33,46,144,100,16,56 BYT 17,40 BYT 33,46,141,53,62,64,103,0 POSITION CURSOR - 55 ASC 1,14 BYT 40,16 BYT 56,0 BYT 33,46,144,102,17,33,133,0 T0913 ASC 6, BYT 33,135,33,46,144,100,16,56 BYT 15,12 * * LINE # : 16 * BYT 33,46,141,53,61,65,103,0 POSITION CURSOR - 16 BYT 33,51,102,16 ASC 7,5,,,,,,,,,,,,6 BYT 33,46,141,53,62,70,103,0 POSITION CURSOR - 58 ASC 7,5,,,,,,,,,,,,6 BYT 15,12 * * LINE # : 17 * BYT 33,46,141,53,61,62,103,0 POSITION CURSOR - 13 ASC 1,15 BYT 40,0 BYT 33,51,102,16 BYT 56,0 BYT 33,46,144,102,17,33,133,0 T0914 ASC 6, BYT 33,135,33,46,144,100,16,56 BYT 17,40 BYT 33,46,141,53,62,64,103,0 POSITION CURSOR - 55 ASC 1,16 BYT 40,16 BYT 56,0 BYT 33,46,144,102,17,33,133,0 T0915 ASC 6, BYT 33,135,33,46,144,100,16,56 BYT 15,12 * * LINE # : 18 * BYT 33,46,141,53,61,65,103,0 POSITION CURSOR - 16 BYT 33,51,102,16 ASC 7,5,,,,,,,,,,,,6 T, BYT 33,46,141,53,62,70,103,0 POSITION CURSOR - 58 ASC 7,5,,,,,,,,,,,,6 BYT 15,12 * * LINE # : 19 * BYT 33,46,141,53,61,62,103,0 POSITION CURSOR - 13 ASC 1,17 BYT 40,0 BYT 33,51,102,16 BYT 56,0 BYT 33,46,144,102,17,33,133,0 T0916 ASC 6, BYT 33,135,33,46,144,100,16,56 BYT 17,40 BYT 33,46,141,53,62,64,103,0 POSITION CURSOR - 55 ASC 1,18 BYT 40,16 BYT 56,0 BYT 33,46,144,102,17,33,133,0 T0917 ASC 6, BYT 33,135,33,46,144,100,16,56 BYT 15,12 * * LINE # : 20 * BYT 33,46,141,53,61,65,103,0 POSITION CURSOR - 16 BYT 33,51,102,16 ASC 7,5,,,,,,,,,,,,6 BYT 33,46,141,53,62,70,103,0 POSITION CURSOR - 58 ASC 7,5,,,,,,,,,,,,6 BYT 15,12 * * LINE # : 21 * BYT 33,46,141,53,61,62,103,0 POSITION CURSOR - 13 ASC 1,19 BYT 40,0 BYT 33,51,102,16 BYT 56,0 BYT 33,46,144,102,17,33,133,0 T0918 ASC 6, BYT 33,135,33,46,144,100,16,56 BYT 17,40 BYT 33,46,141,53,62,64,103,0 POSITION CURSOR - 55 ASC 1,20 BYT 40,16 BYT 56,0 BYT 33,46,144,102,17,33,133,0 T0919 ASC 6, BYT 33,135,33,46,144,100,16,56 BYT 15,12 * * LINE # : 22 * BYT 33,46,141,53,61,65,103,0 POSITION CURSOR - 16 BYT 33,51,102,16 ASC 7,F,,,,,,,,,,,,G BYT 33,46,141,53,62,70,103,0 POSITION CURSOR - 58 ASC 7,F,,,,,,,,,,,,G ESCR9 BYT 15,12 STAD9 EQU BSCR9 LTAD9 EQU ESCR9 ILSC9 ABS LTAD9-STAD9+1 * ************************************************************************* * * SCREEN # 10 : QUESTION SPECIFICATIONS * ************************************************************************ * SCR11 LDA IQST QUESTION # ADA .D1 DECREMENT MPY D.12 QUEST. NAME LENGTH ADA D.747 COMPUTE CHAR. OFFSET OF STA SOQST QUEST. NAMAE IN IFORM AND SAVE JSB MOVCA MOVE QUESTION DEF *+6 NAME FROM DEF IFORM ANSWER STORAGE DEF SOQST SOURCE OFFSET DEF T11 TO DEST. BUFFER DEF D.1 DEST OFFSET DEF D.12 # OF CHARS TO MOVE * JSB MOVCX MOVE ANSWERS IN UNPROT. FIELDS DEF *+6 DEF JFORM ANSWER STORAGE DEF SOF11 TABLE OF SOURCE CHAR. OFFSETS DEF BD11 TABLE OF DEST. BUFFERS DEF D.OFF DEST OFFSET DEF DBL09 QUESTION # * * IF 3070A CHANGE ADDRESSES IN SCREEN * LDA IMODB GET TERMINAL TYPE SZA 3070A ? JMP SC115 NO LDA L112 STA T112 LDA L113 STA T113 LDA AT110 LDB NUL JSB &REMP DEC 4 * * SC115 LDA ITT GET TR.TYPE SZA,RSS IF 0 OR 1 ERASE JMP SC110 CERTAIN NUMBER OF CR/LF CPA D.1 JMP SC113 TR. TYPE 1 JMP SC114 TR. TYPE 2 OR 3 SC110 LDA AT110 TR. TYPE 0 LDB NUL JSB &REMP DEC 4 SC113 LDA AT111 TR. TYPE 0 OR 1 LDB NUL JSB &REMP DEC 3 * SC114 LDA IL110 NOW COMPUTE SCREEN LENGTH LDB ITT TRANSACTION TYPE SZB,RSS IS 0 ? JMP SC111 YES LDA IL111 LENGTH FOR TR. TYPE 1 CPB D.1 TR. TYPE 1 ? JMP SC111 YES ! LDA IL112 LENGTH FOR TR. TYPE 2 OR 3 SC111 LDB IMODB GET TERMINAL TYPE SZB 3070B ? ADA IL113 YES ADD LENGTH OF QST FOR CARD READER STA ILS11 STORE SCREEN LENGTH * SZB,RSS NOW MOVE BUFFER OF QSTS FOR 3070B JMP WRT11 3070A NO MOVE LDA T117X GET CARD READER QUESTIONS BITS AND LMASK FROM LEFT BYTE OF T117X. MASK LEFT BYTE. CPA B20K ASCII SPACE? JMP NONE YES AND LMSK2 MASK OFF BITS 15 & 14 (IE, A/I) SZA,RSS ANY OTHER CARD SPECS SET? - JMP NONE NO, DON'T DISPLAY IF OTHERS NOT SET. LDA T117X YES, REGET CDR SPEC BITS. RAL LDB HI SLA BIT 7 SET? JMP S1171 YES LDB HA NO SSA,RSS BIT 6 SET? LDB B20K NO S1171 STB T1171 SET TO 'A' OR 'I' OR ' ' RAL,RAL LDB HM SLA BIT 5 SET? JMP S1172 YES LDB HH NO SSA,RSS BIT 4 SET? LDB B20K NO S1172 STB T1172 SET TO 'H' OR 'M' OR ' ' RAL,RAL LDB HCA SLA BIT 3 SET? JMP S1173 YES LDB HCO NO SSA,RSS BIT 2 SET? LDB BLANK NO S1173 STB T1174 SET TO 'CA' OR 'CO' OR ' ' CPB BLANK WAS BIT 2 OR 3 SET? RSS NO, CONTINUE. JMP NONE YES, EXIT THIS ROUTINE. RAL,RAL LDB H40 SLA BIT 1 SET? JMP S1174 YES LDB H80 NO SSA,RSS BIT 0 SET? LDB BLANK NO S1174 STB T1174 SET TO '80' OR '40' OR ' ' NONE LDA IL113 BUFFER LENGTH TO MOVE STA LN111 STORE STA LN112 AGAIN ! LDB ITT TR. TYPE SZB IS 0 ? JMP SC112 NO ! LDA AB113 YES MOVE FROM LDB AB111 TO JSB &MVW LN111 NOP MOVE LENGTH (WORDS) JMP WRT11 SC112 LDB ITT TR. TYPE CPB D.1 IS 1 ? RSS YES JUMP JMP WRT11 NO LDA AB113 TR TYPE 1 MOVE BUFFER FROM LDB AB112 TO JSB &MVW LN112 NOP MOVE LENGTH * WRT11 JSB EXEC WRITE SCREEN NOW ! DEF *+5 RETURN POINT DEF D.2 CODE EXEC DEF ILU CONTROL WORD DEF BSC11 BUFFER LOCATION DEF ILS11 BUFFER LENGTH JMP CANS LOAD SEGMENT TO ANALYSE USERS ANSWER * * TABLE OF OFFSETS * SOQST NOP QUESTION NAME OFFSET SOF11 DEC 1 TABLE OF OFFSETS IN JFORM ` DEC 3,4,5,6,7,23,24,30,31,-1 * * TABLE OF DEST BUFFER ADDRESSES * BD11 DEF T1102 DEF T1107 DEF T117X DEF T1100 DEF T1103 DEF T1101 DEF T1104 DEF T1105 DEF T1106 * T117X NOP BUFFER FOR CARD READER QUESTIONS HI OCT 44400 'I' HA OCT 40400 'A' HM OCT 46400 'M' HH OCT 44000 'H' HCO ASC 1,CO 'CO' HCA ASC 1,CA 'CA' H40 ASC 1,40 '40' H80 ASC 1,80 '80' B20K OCT 20000 BLANK ASC 1, LMASK OCT 177400 LMSK2 OCT 37400 * * DATA SCREEN # 10 * * * LINE # : 1 * BSC11 BYT 33,130 FORMAT OFF BYT 33,110 HOME UP CL02 BYT 33,112 CLEAR DISPLAY BYT 33,46,141,53,60,70,103,0 POSITION CURSOR - 09 ASC 22,Screen # 10 DETAILED SPECIFICATIONS OF QUEST ASC 2,ION BYT 33,46,144,104 T11 ASC 6, BYT 15,12 * * LINE # : 2 * BYT 15,12 * * LINE # : 3 * ASC 19, - Enter the type of answer expected : BYT 15,12 * * LINE # : 4 * ASC 2, BYT 33,46,144,104 BYT 123,0 BYT 33,46,144,100 ASC 3,tring, BYT 40,0 BYT 33,46,144,104 BYT 111,0 BYT 33,46,144,100 ASC 7,nteger number, BYT 40,0 BYT 33,46,144,104 BYT 122,0 BYT 33,46,144,100 ASC 6,eal number, BYT 33,46,144,104 BYT 106,0 BYT 33,46,144,100 ASC 7,unction only, BYT 33,46,144,104 BYT 104,0 BYT 33,46,144,100 ASC 10,ata base item ...... BYT 40,0 BYT 33,46,144,102,33,133 T1100 BYT 40,0 BYT 33,135,33,46,144,100 BYT 15,12 * * LINE # : 5 * BYT 15,12 * * LINE # : 6 * BYT 15,12 * * LINE # : 7 * BYT 15,12 * * LINE # : 8 * BYT 15,12 * * LINE # : 9 * BYT 15,12 * * LINE # : 10 * T110 BYT 15,12 * * [ LINE # : 11 * BYT 15,12 * * LINE # : 12 * BYT 15,12 * * LINE # : 13 * BYT 15,12 * * LINE # : 14 * ASC 22, - Define the default answer (if not the dis ASC 9,played value) .... BYT 40,0 BYT 33,46,144,102,33,133 T1101 ASC 8, BYT 33,135,33,46,144,100 BYT 15,12 * * LINE # : 15 * BYT 15,12 * * LINE # : 16 * BYT 15,12 * * LINE # : 17 * BYT 15,12 * * LINE # : 18 * BYT 15,12 * * LINE # : 19 * T111 BYT 15,12 * * LINE # : 20 * BYT 15,12 * * LINE # : 21 * BYT 15,12 * * LINE # : 22 * ASC 22, - Enter the prompting light number to be sw ASC 16,itched on (optional) ........... BYT 40,0 BYT 33,46,144,102,33,133 T1102 ASC 1, BYT 33,135,33,46,144,100 ESC11 BYT 15,12 * * * LINE # : 10 * B.111 BYT 33,46 T112 BYT 141,71,162,60,103,0 BYT 33,51,102,16 ASC 4,R,,,,,,, BYT 54,17 ASC 22, If a value is to be displayed with the ques ASC 7,tion, enter X BYT 33,46,144,102,33,133 T1103 BYT 40,0 BYT 33,135,33,46,144,100 BYT 40,16 ASC 5,,,,,,,,,,, BYT 124,0 * * LINE # : 11 * BYT 33,51,102,16 BYT 56,17 ASC 22, If this value is to be used as default ans ASC 16,wer, enter X ................... BYT 40,0 BYT 33,46,144,102,33,133 T1104 BYT 40,0 BYT 33,135,33,46,144,100,16,56 * * LINE # : 12 * BYT 33,51,102,16 ASC 22,F,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ASC 18,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,G * * LINE # : 13 * E.111 BYT 15,12 * * * LINE # : 16 * B.112 BYT 33,46,141,61 T113 BYT 65,162,60,103 BYT 33,51,102,16 ASC 3,R,,,,, BYT 54,17 ASC 22, If the answer is used for an operation on a ASC 9,n IMAGE data baseNLH BYT 16,54 ASC 5,,,,,,,,,,T * * LINE # : 17 * BYT 33,51,102,16 BYT 56,17 ASC 22,- Enter the item name ..................... ASC 14,........................... BYT 33,46,144,102,33,133 T1105 ASC 3, BYT 33,135,33,46,144,100,16,56 * * LINE # : 18 * BYT 33,51,102,16 BYT 56,17 ASC 21,- Enter the appropriate operation letter : BYT 33,46,141,53,63,66,103,0 POSITION CURSOR - 80 1N BYT 16,56 * * LINE # : 19 * BYT 33,51,102,16 BYT 56,17 ASC 1, BYT 40,0 BYT 33,46,144,104 BYT 106,0 BYT 33,46,144,100 ASC 7,ind an entry, BYT 33,46,144,104 BYT 125,0 BYT 33,46,144,100 ASC 8,pdate an entry, BYT 33,46,144,104 BYT 101,0 BYT 33,46,144,100 ASC 6,dd an entry, BYT 40,0 BYT 33,46,144,104 BYT 103,0 BYT 33,46,144,100 ASC 13,heck for existence ...... BYT 40,0 BYT 33,46,144,102,33,133 T1106 BYT 40,0 BYT 33,135,33,46,144,100,16,56 * * LINE # : 20 * BYT 33,51,102,16 ASC 22,F,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ASC 18,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,g * * LINE # : 21 * E.112 BYT 15,12 * * * LINE # : 6 * B.113 BYT 33,46,141,65,162,60,103,0 BYT 33,51,102,16 ASC 4,R,,,,,,, BYT 40,17 ASC 19,If the answer is from a card, enter X BYT 33,46,144,102,33,133 T1107 BYT 40,0 BYT 33,135,33,46,144,100 BYT 33,46,141,53,61,103,0 ASC 13,; If a new card, specify: BYT 33,135,33,46,144,100 BYT 40,16 ASC 1,,, BYT 54,124,0 * * LINE # : 7 * BYT 33,51,102,16 BYT 56,17 ASC 1, BYT 33,46,144,104 BYT 101,0 BYT 33,46,144,100 ASC 2,scii BYT 57,0 BYT 33,46,144,104 BYT 111,0 BYT 33,46,144,100 ASC 2,mage BYT 40,0 BYT 33,46,144,102,33,133 T1171 BYT 40,0 BYT 33,135,33,46,144,100 ASC 1,, BYT 33,46,144,104 BYT 110,0 BYT 33,46,144,100 ASC 2,oles BYT 57,0 BYT 33,46,144,104 BYT 115,0 BYT 33,46,144,100 ASC 2,arks BYT 40,0 BYT 33,46,144,102,33,133 T1172 BYT 40,0 BYT 33,135,33,46,144,100 BYT 54,0 ASC 5, no clock BYT 33,46,144,104 ASC 1,80 BYT 33,46,144,100 BYT 57,0 BYT 33,46,144,104 ASC 1,40 BYT 33,46,144,100 ASC 2, or BYT 33,46,144,104 BYT 103,0 BYT 33,46,144,100 ASC 2,lock BYT 40,0 BYT 33,46,144,104 BYT 117,0 BYT 33,46,144,100 ASC 1,n/ BYT 33,46,144,104 BYT 103,0 BYT 33,46,144,100 ASC 2,lock BYT 40,0 BYT 33,46,144,104 BYT 101,0 BYT 33,46,144,100 ASC 5,fter data BYT 33,46,144,102,33,133 T1174 ASC 1, BYT 33,135,33,46,144,100,16,56 * * LINE # : 8 * BYT 33,51,102,16 ASC 22,F,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ASC 18,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,G * * LINE # : 9 * E.113 BYT 15,12 * * STA11 EQU BSC11 LTA11 EQU ESC11 LT111 EQU E.111 LT112 EQU E.112 ST113 EQU B.113 LT113 EQU E.113 IL110 ABS LTA11-STA11+1 IL111 ABS LT111-STA11+1 IL112 ABS LT112-STA11+1 IL113 ABS LT113-ST113+1 ILS11 NOP AB111 DEF B.111 AB112 DEF B.112 AB113 DEF B.113 AT110 DEF T110 AT111 DEF T111 NUL BYT 0,0 L112 BYT 141,65 L113 BYT 61,162 * * SCREENS 11 AND 12 EDIT FOR INTEGERS AND REALS * SCR12 LDA IQST QUESTION # ADA .D1 DECREMENT MPY D.12 QUEST. NAME LENGTH ADA D.747 COMPUTE CHAR. OFFSET OF STA SOQST QUEST NAME IN IFORM AND SAVE JSB MOVCA MOVE QUESTION DEF *+6 NAME FROM DEF IFORM ANSWER STORAGE DEF SOQST SOURCE OFFSET DEF T12 TO DEST BUFFER DEF D.1 DEST OFFSET DEF D.12 MOVE LENGTH * LDA ISCRN GET SCREEN # CPA D.13 IS 13 ? JMP SCR13 YES JUMP JSB MOVCX MOVE ANSWERS IN UNPROTECTED FIELDS DEF *+6 OF SCREEN 12 DEF JFORM ANSWER STORAGE DEF SOF12 SOURCE CHAR OFFSET TABLE DEF BD12 BUFFER DEST TABLE DEF D.OFF DEST OTFFSET DEF DBL09 QUESTION # * * MOVE SCREEN 11 AT THE RIGHT PLACE * LDA IL123 MOVE LENGTH STA LN121 STORE IT STA LN122 AGAIN LDA ITT TR. TYPE SZA IS 0 ? JMP SC122 NO LDA AB123 YES MOVE FROM LDB AB121 TO JSB &MVW LN121 NOP MOVE LENGTH JMP SC125 SC122 CPA D.1 TR. TYPE IS 1 ? RSS YES JMP SC128 NO LDA IL126 MOVE LENGTH STA LN126 STORE IT LDA AB122 MOVE FROM LDB AB121 TO JSB &MVW LN126 NOP MOVE LENGTH JMP SC125 SC128 CPA D.2 IS 2 ? RSS YES JMP SC125 NO JUMP LDA AB123 MOVE FROM LDB AB122 TO JSB &MVW LN122 NOP MOVE LENGTH JMP SC125 * * MOVE SCREEN 12 AT THE RIGHT PLACE * SCR13 LDA SC3 STA T121 STORE 3 IN SCREEN # JSB MOVCX FIRST MOVE ANSWERS IN UNPROTECTED FIELDS DEF *+6 DEF JFORM ANSWER STORAGE DEF SOF13 SOURCE CHAR OFFSET TABLE DEF BD13 DEST BUFFER TABLE DEF D.OFF DEST OFFSET DEF DBL09 QUESTION # * LDA IL124 MOVE LENGTH STA LN123 STORE IT STA LN124 AGAIN STA LN125 AGAIN STA LN128 AGAIN LDA ITT TR. TYPE SZA IS 0 ? JMP SC123 NO LDA AB124 YES MOVE FROM LDB AB121 TO JSB &MVW LN123 NOP MOVE LENGTH JMP SC125 SC123 CPA D.1 TR TYPE IS 1 ? RSS YES JMP SC129 NO LDA AB124 TR TYPE 1 . MOVE FROM LDB AB123 TO JSB &MVW LN128 NOP MOVE LENGTH LDA IL125 COMPUTE MOVE LENGTH ADA IL124 STA LN127 STORE IT LDA AB122 MOVE FROM LDB AB121 TO JSB &MVW LN127 NOP MOVE LENGTH JMP SC125 SC129 CPA D.2 TR. TYPE IS 2 ? RSS YES JMP SC124 NO LDA AB124 MOVE FROM LDB AB122 TO JSB &MVW LN124 NOP MOVE LENGTH JMP SC125 SC124 LDA AB124 MOVE FROM LDB AB123 TO JSB &MVW LN125 NOP MOVE LENGTH * * NOW COMPUTE SCREEN LENGTH * SC125 LDA IL120 MINIMUM LENGTH LDB ITT TR. TYPE SZB,RSS IS 0 ? JMP SC126 YES CPB D.1 IS 1 ? RSS YES JMP SC130 NO ADA IL125 TR TYPE 1 JMP SC126 SC130 LDA IL121 NO LENGTH FOR TR.TYPE 2 CPB D.2 TR. TYPE 2 ? JMP SC126 YES LDA IL122 NO GET LENGTH FOR TR. TYPE 3 SC126 LDB ISCRN NOW ADD LENGTH PARTICULAR TO SCREEN CPB D.13 IS SCREEN 12 JMP SC127 YES ADA IL123 NO IS 12 RSS SKIP SC127 ADA IL124 SCREEN 12 STA ILS12 STORE LENGTH * JSB EXEC WRITE SCREEN NOW DEF *+5 RETURN POINT DEF D.2 CODE EXEC DEF ILU CONTROL WORD DEF BSC12 BUFFER LOCATION DEF ILS12 BUFFER LENGTH JMP CANS LOAD SEGMENT TO ANALYSE USERS ANWERS * * TABLE OF OFFSETS FOR SCREEN 11 * SSED EQU 31 STARTING CHAR OFFSET SOF12 ABS SSED ABS SSED+6 ABS SSED+12 ABS SSED+14 ABS SSED+15 ABS SSED+16 ABS SSED+21 DEC -1 * * TABLE OF OFFSETS FOR SCREEN 12 * SOF13 ABS SSED ABS SSED+14 ABS SSED+28 ABS SSED+29 ABS SSED+30 ABS SSED+35 DEC -1 * * BUFFER DEST. ADDRESSES TABLE FOR SCREEN 11 * BD12 DEF T1203 DEF T1204 DEF T1205 DEF T1200 DEF T1201 DEF T1202 * * BUFFER DEST. ADDRESSES TABLE FOR SCREEN 12 * BD13 DEF T1300 DEF T1301 DEF T1200 DEF T1201 DEF T1202 * * DATA SCREENS 11 AND 12 * * * LINE # : 1 * BSC1/2 BYT 33,130 FORMAT OFF BYT 33,110 HOME UP CL03 BYT 33,112 CLEAR DISPLAY ASC 6, Screen # 1 T121 ASC 1,1 ASC 15, VALIDATION SPECIFICATION FOR ASC 11,THE ANSWER TO QUESTION BYT 40,0 BYT 33,46,144,104 T12 ASC 6, * * LINE # : 12 * BYT 33,46,141,61,61,162,60,103 ASC 1, BYT 33,51,102,16 ASC 2,R,, BYT 17,0 ASC 22,Enter X if the following functions may be us ASC 12,ed during this question BYT 16,40 ASC 2,,,,T BYT 15,12 * * LINE # : 13 * ASC 1, BYT 33,51,102,16 ASC 1,. BYT 33,46,141,53,67,64,103,0 POSITION CURSOR - 79 BYT 56,0 BYT 15,12 * * LINE # : 14 * ASC 1, BYT 33,51,102,16 BYT 56,17 ASC 22, Arithmetic operators (+, -, X, /, = ) . ASC 15,............................. BYT 33,46,144,102,33,133 T1200 BYT 40,0 BYT 33,135,33,46,144,100,16,56 BYT 15,12 * * LINE # : 15 * ASC 1, BYT 33,51,102,16 BYT 56,17 BYT 33,46,141,53,67,65,103,0 POSITION CURSOR - 79 BYT 16,56 BYT 15,12 * * LINE # : 16 * ASC 1, BYT 33,51,102,16 BYT 56,17 BYT 33,46,141,53,67,63,103,0 POSITION CURSOR - 79 ASC 1, BYT 16,56 BYT 15,12 * * LINE # : 17 * ASC 1, BYT 33,51,102,16 ASC 22,F,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ASC 16,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, BYT 107,0 ESC12 BYT 15,12 * * * * LINE # : 16 * B.121 BYT 33,46,141,61,65,162,67,103 ASC 19,NEXT ENTRY in an IMAGE chain ........ ASC 16,............................... BYT 33,120,33,120,33,120,33,120,33,120,33,120 BYT 33,46,144,102,33,133 T1201 BYT 40,0 BYT 33,135,33,46,144,100 BYT 33,51,102,16 BYT 56,0 E.121 BYT 15,12 * * * LINE # : 19 * B.122 BYT 33,46,141,61,70,162,60,103 ASC 1, BYT 33,51,102,16 ASC 10,R,,,,,,,,,,,,,,,,,,, BYT 17,40 ASC 15,User written module definition BYT 40,16 ASC 12,,,,,,,,,,,,,,,,,,,,,,,,, BYT 124,0 BYT 15,12 * * LINE # : 20 * ASC 1, BYT 33,51,102,16 BYT 56,17 ASC 22, - If an additional validation is to be perf ASC 10,ormed on the value, BYT 33,46,141,53,61,61,103,0 POSITION CURSOR - 79 BYT 16,56 BYT 15,12 * * LINE # : 21 * ASC 1, BYT 33,51,102,16 BYT 56,17 ASC 22, enter the name of the appropriate user wr ASC 12,itten validation module BYT 40,40 BYT 33,46,144,102,33,133 T1202 ASC 2, BYT 40,0 BYT 33,135,33,46,144,100,16,56 BYT 15,12 * * LINE # : 22 * ASC 1, BYT 33,51,102,16 ASC 22,F,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ASC 16,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, E.122 BYT 107,0 * * * LINE # : 4 * B.123 BYT 33,46,141,63,162,60,103,0 ASC 22, - Enter upper limit for the answer (-327 ASC 14,68 =< U.L <= 32767) ...... BYT 33,46,144,102,33,133 T1203 ASC 3, BYT 33,135,33,46,144,100 BYT 15,12 * * LINE # : 5 * BYT 15,12 * * LINE # : 6 * ASC 22, - Enter lower limit for the answer (-327 ASC 14,68 =< L.L <= 32767) ...... BYT 33,46,144,102,33,133 T1204 ASC 3, BYT 33,135,33,46,144,100 BYT 15,12 * * LINE # : 7 * BYT 15,12 * * LINE # : 8 * ASC 22, - If the answer is to be a multiple of a ASC 9, number ( modulo ) BYT 54,0 BYT 15,12 * * LINE # : 9 * ASC 22, enter the modulo number (1=< M <= 99) ASC 16, .............................. BYT 33,46,144,102,33,133 T1205 ASC 1, BYT 33,135,33,46,144,100 E.123 BYT 15,12 * * * LINE # : 3 * B.124 BYT 33,46,141,62,162,64,63,103 ASC 1,38 BYT 33,46,141,53,61,63,103,0 POSITION CURSOR - 59 ASC 1,38 BYT 15,12 * * LINE # : 4 * ASC 22, - Enter upper limit for the answer (-10 ASC 10, =< U.L <= +10 ) BYT 33,46,144,102,33,133 T1300 ASC 7, BYT 33,135,33,46,144,100 BYT 15,12 * * LINE # : 5 * BYT 15,12 * * LINE # : 6 * BYT 33,46,141,53,64,63,103,0 POSITION CURSOR - 44 ASC 1,38 BYT 33,46,141,53,61,63,103,0 POSITION CURSOR - 59 ASC 1,38 BYT 15,12 * * LINE # : 7 * ASC 22, - Enter lower limit for the answer (-10 ASC 10, =< L.L <= +10 ) BYT 33,46,144,102,33,133 T1301 ASC 7, BYT 33,135,33,46,144,100 E.124 BYT 15,12 * STA12 EQU BSC12 LTA12 EQU ESC12 LT121 EQU E.121 ST122 EQU B.122 LT122 EQU E.122 ST123 EQU B.123 LT123 EQU E.123 ST124 EQU B.124 LT124 EQU E.124 IL120 ABS LTA12-STA12+1 IL121 ABS LT121-STA12+1 IL122 ABS LT122-STA12+1 IL123 ABS LT123-ST123+1 IL124 ABS LT124-ST124+1 IL125 ABS LT122-ST122+1 IL126 ABS LT123-ST122+1 ILS12 NOP SC3 ASC 1,2 AB121 DEF B.121 AB122 DEF B.122 AB123 DEF B.123 AB124 DEF B.124 * ************************************************************************ * * SCREEN # 19 BUILDING LIBRARIES 1 OF 2 * *********************************************************************** * * SCR20 JSB MOVCX MOVE ANSWERS IN UNPROTECTED FIELDS DEF *+6 DEF ILIBR SOURCE BUFFER DEF SOF20 TABLE OF SOURCE OFFSSETS DEF BD20 TABLE OF DEST. ADDRESS DEF D.0 DEST OFFSET DEF DBL09 NOP JSB EXEC WRITE SCREEN NOW DEF *+5 DEF D.2 DEF ILU DEF BSC20 DEF ILS20 JMP CANS LOAD SEGMENT TO ANALYSE USERS ANSWERS * * DATA SCREEN 19 * * * LINE # : 1 * BSC20 BYT 33,130 FORMAT OFF ` BYT 33,110 HOME UP CL04 BYT 33,112 CLEAR DISPLAY ASC 22, Screen # 19 BUILDING A LIBRARY OF TRANSAC ASC 14,TION SPECIFICATIONS (1 of 2 BYT 51,0 BYT 15,12 * * LINE # : 2 * BYT 15,12 * * LINE # : 3 * BYT 15,12 * * LINE # : 4 * ASC 18, - Select your mode of operation : BYT 15,12 * * LINE # : 5 * BYT 33,46,141,53,60,70,103,0 POSITION CURSOR - 09 BYT 33,46,144,104 BYT 103,0 BYT 33,46,144,100 ASC 22,opy source Transaction Specifications to des ASC 8,tination ) BYT 15,12 * * LINE # : 6 * BYT 33,46,141,53,60,70,103,0 POSITION CURSOR - 09 BYT 33,46,144,104 BYT 105,0 BYT 33,46,144,100 ASC 22,xclude source Transaction Specifications fro ASC 12,m destination ) ....... BYT 40,0 BYT 33,46,144,102,33,133 T2000 BYT 40,0 BYT 33,135,33,46,144,100 BYT 15,12 * * LINE # : 7 * BYT 33,46,141,53,60,70,103,0 POSITION CURSOR - 09 BYT 33,46,144,104 BYT 114,0 BYT 33,46,144,100 ASC 20,ist the directory of the source library BYT 33,46,141,53,61,71,103,0 POSITION CURSOR - 69 BYT 51,0 BYT 15,12 * * LINE # : 8 * BYT 33,46,141,53,60,70,103,0 BYT 33,46,144,104 BYT 124,0 BYT 33,46,144,100 ASC 4,erminate BYT 33,46,141,53,65,61,103,0 BYT 51,0 BYT 15,12 * * LINE # : 9 * BYT 15,12 * * LINE # : 10 * BYT 33,51,102,16 ASC 11,r,,,,,,,,,,,,,,,,,,,,, BYT 54,17 ASC 17, Definition of the source library BYT 16,54 ASC 11,,,,,,,,,,,,,,,,,,,,,,t * * LINE # : 11 * BYT 33,51,102,16 ASC 1,. BYT 33,46,141,53,67,67,103,0 POSITION CURSOR - 80 BYT 56,0 * * LINE # : 12 * BYT 33,51,102,16 BYT 56,17 AS#C 22, - Enter the LIBRARY NAME: disc file or ASC 14,device (MT, LCTU, RCTU) ... BYT 33,46,144,102,33,133 T2001 ASC 3, BYT 33,135,33,46,144,100,16,56 * * LINE # : 13 * BYT 33,51,102,16 BYT 56,17 ASC 13, - If the library is on: BYT 33,46,141,53,65,62,103,0 POSITION CURSOR - 80 BYT 16,56 * * LINE # : 14 * BYT 33,51,102,16 BYT 56,17 ASC 20, A minicartridge or a magnetic tape, BYT 33,46,144,104 ASC 6,load device. BYT 33,46,144,100 BYT 33,46,141,53,62,66,103,0 POSITION CURSOR - 80 BYT 16,56 * * LINE # : 15 * BYT 33,51,102,16 BYT 56,17 ASC 22, A disc, give the CARTRIDGE REFERENCE num ASC 14,ber (optional) ............ BYT 33,46,144,102,33,133 T2002 ASC 3, BYT 33,135,33,46,144,100,16,56 * * LINE # : 16 * BYT 33,51,102,16 ASC 1,. BYT 33,46,141,53,67,67,103,0 POSITION CURSOR - 80 BYT 56,0 * * LINE # : 17 * BYT 33,51,102,16 ASC 22,f,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ASC 18,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,G * * LINE # : 18 * BYT 15,12 * * LINE # : 19 * BYT 33,51,102,16 ASC 1,R, BYT 17,40 ASC 12,To List a directory onlyst only BYT 40,16 ASC 26,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,t * * LINE # : 20 * BYT 33,51,102,16 BYT 56,17 ASC 22, - FILE NAME of the list device (LP, defaul ASC 14,t is this terminal) ....... BYT 33,46,144,102,33,133 T2003 ASC 3, BYT 33,135,33,46,144,100,16,56 * * LINE # : 21 * BYT 33,51,102,16 ASC 22,f,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ASC 18,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,g * * LINE # : 22 * ESC20 BYT 15,12 * STA20 EQU BSC20 LTA20 EQU ESC20 ILS20 ABS LTA20-STA20+1 * SOF20 DEC 2,3,9,15,21,-1 * BD20 DEF T2000 DEF T2001 DEF T2002 DEF T2003 * *********************************************************************** * * SCREEN 20 BUILDING LIBRARIES 2 OF 2 * *********************************************************************** * * SCR21 JSB MOVCX MOVE ANSWERS IN DEF *+6 UNPROTECTED FIELDS DEF ILIBR SOURCE BUFFER DEF SOF21 SOURCE OFFSETS DEF BD21 DEST ADDRESS DEF D.0 DEST OFFSET DEF DBL09 NOP LDA IL210 MINIMUM SCREEN LENGTH LDB ILIBR PUT C OR E INTO B REG CPB E.CHK (B)= E?, IF NOT SKIP LDA IL211 NEW SCREEN LENGTH STA ILS21 JSB EXEC WRITE SCREEN NOW DEF *+5 DEF D.2 DEF ILU DEF BSC21 DEF ILS21 JMP CANS LOAD SEGMENT TO ANALYSE USERS ANSWERS * * DATA SCREEN 20 * * * LINE # : 1 * BSC21 BYT 33,130 FORMAT OFF BYT 33,110 HOME UP CL05 BYT 33,112 CLEAR DISPLAY ASC 22, Screen # 20 BUILDING A LIBRARY OF TRANSAC ASC 14,TION SPECIFICATIONS (2 of 2 BYT 51,0 BYT 15,12 * * LINE # : 2 * BYT 15,12 * * LINE # : 3 * BYT 15,12 * * LINE # : 4 * ASC 22, - Define the source Transaction Specifica ASC 16,tions to be copied to BYT 15,12 * * LINE # : 5 * ASC 15, the destination library. BYT 15,12 * * LINE # : 6 * BYT 15,12 * * LINE # : 7 * BYT 40,0 BYT 33,46,144,102,33,133 T2100 ASC 3, BYT 33,135,33,46,144,100 ASC 1, BYT 33,46,144,102,33,133 T2101 ASC 3, BYT 33,135,33,46,144,100 ASC 1, BYT 33,46,144,102,33,133 T2102 ASC 3, BYT 33,135,33,46,144,100 ASC 1, BYT 33,46,144,102,33,133 T2103 ASC 3, BYT 33,135,33,46,144,100 ASC 1, BYT 33,46,144,102,33,133 T2104 ASC 3, g: BYT 33,135,33,46,144,100 ASC 1, BYT 33,46,144,102,33,133 T2105 ASC 3, BYT 33,135,33,46,144,100 ASC 1, BYT 33,46,144,102,33,133 T2106 ASC 3, BYT 33,135,33,46,144,100 ASC 1, BYT 33,46,144,102,33,133 T2107 ASC 3, BYT 33,135,33,46,144,100 ASC 1, BYT 33,46,144,102,33,133 T2108 ASC 3, BYT 33,135,33,46,144,100 ASC 1, BYT 33,46,144,102,33,133 T2109 ASC 3, BYT 33,135,33,46,144,100 BYT 15,12 * * LINE # : 8 * ASC 9, (name or number) BYT 15,12 * * LINE # : 9 * BYT 15,12 * * LINE # : 10 * BYT 33,51,102,16 ASC 10,R,,,,,,,,,,,,,,,,,, BYT 17,40 ASC 19,Definition of the destination library BYT 16,54 ASC 10,,,,,,,,,,,,,,,,,,,,t * * LINE # : 11 * BYT 33,51,102,16 ASC 1,. BYT 33,46,141,53,67,67,103,0 POSITION CURSOR - 80 BYT 56,0 * * LINE # : 12 * BYT 33,51,102,16 BYT 56,17 ASC 22, - Enter the LIBRARY NAME: disc file or ASC 14,device (MT, LCTU, RCTU) ... BYT 33,46,144,102,33,133 T2110 ASC 3, BYT 33,135,33,46,144,100,16,56 * * LINE # : 13 * BYT 33,51,102,16 BYT 56,17 ASC 13, - If the library is on: BYT 33,46,141,53,65,62,103,0 POSITION CURSOR - 80 BYT 16,56 * * LINE # : 14 * BYT 33,51,102,16 BYT 56,17 ASC 20, A minicartridge or a magnetic tape, BYT 33,46,144,104 ASC 6,load device. BYT 33,46,144,100 BYT 33,46,141,53,62,66,103,0 POSITION CURSOR - 80 BYT 16,56 * * LINE # : 15 * BYT 33,51,102,16 BYT 56,17 ASC 22, A disc, give the CARTRIDGE REFERENCE num ASC 14,ber (optional) ............ BYT 33,46,144,102,33,133 T2111 ASC 3, BYT 33,135,33,46,144,100,16,56 * * LINE # : 16 * BYT 33,51,102,16 t ASC 1,. BYT 33,46,141,53,67,67,103,0 POSITION CURSOR - 80 BYT 56,0 * * LINE # : 17 * BYT 33,51,102,16 BYT 56,17 ASC 22, - If the library is to be created, ASC 11, BYT 33,46,141,53,61,62,103,0 POSITION CURSOR - 80 BYT 16,56 * * LINE # : 18 * BYT 33,51,102,16 BYT 56,17 ASC 22, specify a descriptive HEADER ............ ASC 2,... BYT 33,46,144,102,33,133 T2112 ASC 15, BYT 33,135,33,46,144,100,16,56 * * LINE # : 19 * BYT 33,51,102,16 ASC 1,. BYT 33,46,141,53,67,67,103,0 POSITION CURSOR - 80 BYT 56,0 * * LINE # : 20 * BYT 33,51,102,16 ASC 22,f,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ASC 18,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,G * * LINE # : 21 * ESC21 BYT 15,12 B.211 BYT 33,46,141,63,162,65,66,103 ASC 7,excluded from E.211 BYT 40,0 * STA21 EQU BSC21 LTA21 EQU ESC21 LT211 EQU E.211 IL210 ABS LTA21-STA21+1 IL211 ABS LT211-STA21+1 * ILS21 NOP * SOF21 DEC 21,27,33,39,45,51,57,63,69,75,81,87,93,123,-1 * BD21 DEF T2100 DEF T2101 DEF T2102 DEF T2103 DEF T2104 DEF T2105 DEF T2106 DEF T2107 DEF T2108 DEF T2109 DEF T2110 DEF T2111 DEF T2112 * ************************************************************************ * * NOW CALL ANSWER ANALYZE SEGMENT * ************************************************************************ * * CANS JSB EXEC SEND FORMAT ON DEF *+5 DEF D.2 DEF ILU DEF BENP DEF D.2 LDA ISCRN GET SCREEN # CPA D.11 IS 11 ? JMP CANS3 YES ADA .D11 IS IT > 10 SSA,RSS JMP CANS1 YES JSB EXEC NO LOAD SEGMENT ANSWR DEF *+3 RETURN POINT DEF D.8 CODE EXEC DEF ANS SEGMENT NAME CANS1 LDA NLHISCRN GET SCREEN # ADA .D15 IS IT > 15 SSA,RSS JMP CANS2 YES JSB EXEC DEF *+3 DEF D.8 DEF ANS1 CANS2 LDA ISCRN GET SCREEN # ADA .D19 IS IT > 19 ? SSA,RSS JMP CANS4 YES JSB EXEC DEF *+3 DEF D.8 DEF ANS2 CANS3 JSB EXEC DEF *+3 DEF D.8 DEF ANS3 CANS4 JSB EXEC DEF *+3 DEF D.8 DEF ANS4 * * DATA SECTION * ANS ASC 3,TGP2 SEGMENT NAME TO LOAD ANS1 ASC 3,TGP5 ANS2 ASC 3,TGP6 ANS3 ASC 3,TGP9 ANS4 ASC 3,TGP8 .D11 DEC -11 .D19 DEC -19 .D15 DEC -15 D.11 DEC 11 E.CHK OCT 020105 BENP BYT 33,127,0,137 FORMAT ON * * * END SEGMENT * END TGP3 cN  92903-18359 1840 S C0222 &TGP4A TGP SEGM. 04 SRC.             H0102 oASMB,R NAM TGP4,5 92903-16359 REV.1840 780815 HED * -TGP4- * * SOURCE 92903-18359 * SPC 2 ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** SPC 2 HED * -TGP4- SUP * * PRGMR : JEAN CHARLES MIARD(HPG) * * ********************************************************************** * * * * * THIS IS A SEGMENT OF THE TGP PROGRAM USED TO WRITE ON * * THE 2640/2645 DISPLAY THE SCREEN MASKS USED TO COLLECT INFORMA- * * TION TO BUILD A TRANSACTION SPECIFICATION . * * * * TGP4 PRINT SCREENS 13,14,15,16,17 AND 18 ACCORDING TO * * ISCRN VALUE AND THEN LOADS THE REQUIRED SEGMENT TO ANALYSE THE * * USER'S ANSWERS . * * * * BEFORE PRINTING THE SCREENS TGP4 INCLUDES IN THEM THE OLD * * ANSWERS STORED IN JFORM,MFORM AND LFORM . * * SOME SCREENS ARE DYNAMIC AND ONLY PARTS OF THE TOTAL * * SCREEN ARE PRINTED . * * * * IF INDIC=-77 THE SCREEN IS TO BE PRINTED WITHOUT ERASING * * THE DISPLAY BEFORE (HELP MESSAGE) * * * * [ * * WARNING !! * : CARE MUST BE TAKEN : * * * * PRINTED SCREEN # 13 CORRESPONDS TO ISCRN = 14 * * ............. 14 ................. 15 * * ............. 15 ................. 16 * * ............. 16 ................. 17 * * ............. 17 ................. 18 * * ............. 18 ................. 19 * * * ********************************************************************** * * * ENT TGP4 ENTRY POINT EXT EXEC EXT TGP MAIN PROGRAM EXT MOVCA SUBR. MOVES CHARS. EXT MOVCX SUBR. MOVES ANSWERS IN UNPRO. FIELDS EXT &MVW MOVES WORDS * * DECLARATIONS COMMON VARIABLES ************** * COM ILU,ISCRN,IQST,ISKIP,INDIC COM IFORM(494) ANSWER STORAGE COM JFORM(980) ANSWER STORAGE COM MFORM(16) ANSWER STORAGE COM LFORM(39) ANSWER STORAGE COM ITT TRANS TYPE COM IKEY(33) COM IUMAX # OF U QUESTIONS COM IMMAX #OF M QUESTIONS COM IMODB (0/1) 3070A/3070B COM ILITE(15) COM IMAI(225) IMAGE INFO STORAGE COM IMFLG,IMAS,IMDT,IMKY COM KFORM(1065) COM ILIBR(61) COM NIMAG * * TGP4 LDA INDIC GET INDICATOR CPA .D77 IS IT PRINT FOR HELP ? RSS YES JMP CONT NO JUMP CLA STA CL01 STA CL02 STA CL03 STA CL04 STA CL05 STA CL06 CONT LDA IQST GET QUESTION # ADA .D1 DECREMENT MPY D.98 MULT PER # OF CHAR. PER QUESTION STA D.OFF STORE DEST. OFFSET * ****************************************************************N******** * *FIND SCREEN # TO DISPLAY * ************************************************************************ * * LDA ISCRN GET SCREEN # ADA .D14 ADA ASCR JMP A,I * * TABLE OF ADDRESS FOR SCREENS * ASCR DEF *+1,I DEF SCR14 DEF SCR15 DEF SCR16 DEF SCR17 DEF SCR18 DEF SCR19 * * * DATA SECTION * A EQU 0 D.0 DEC 0 .D1 DEC -1 D.1 DEC 1 D.2 DEC 2 D.3 DEC 3 D.6 DEC 6 D.8 DEC 8 D.9 DEC 9 D.10 DEC 10 D.12 DEC 12 D.13 DEC 13 D.747 DEC 747 D.57 DEC 57 .D14 DEC -14 .D77 DEC -77 D.98 DEC 98 D.OFF NOP DBL15 NOP * ************************************************************************ * * SCREEN # 13 EDIT SPECIFICATIONS FOR STRINGS * ************************************************************************ * SCR14 LDA IQST QUESTION # ADA .D1 DECREMENT MPY D.12 QYESTION LABEL LENGTH ADA D.747 INITIAL OFFSET STA SOQST OFFSET OF QUESTION LABEL IN IFORM JSB MOVCA MOVE QUESTION LABEL IN TITLE OF SCREEN DEF *+6 DEF IFORM ANSWER STORAGE DEF SOQST TITLE CHAR. OFFSET DEF T14 BUFFER IN SCREEN DEF D.1 DEST OFFSET DEF D.12 MOVE LENGTH * JSB MOVCX MOVE ANSWERS IN UNPROT. FIELDS DEF *+6 DEF JFORM MOVE FROM ANSWER STORAGE DEF SOF14 TABLE OF OFFSETS IN JFORM DEF BD14 BUFFER DEST. ADDRESS TABLE DEF D.OFF DEST OFFSET DEF DBL14 QUESTION # * LDA IL140 SCREEN LENGTH FOR TR. TYPE 0 LDB ITT TR. TYPE SZB,RSS IS 0 ? JMP WRT14 YES CPB D.1 TR TYPE IS 1 ? RSS YES SKIP JMP SC141 NO JMP LDA IL142 LENGTH OF PART BUFFER FOR TR,TYPE 1 STA LN141 STORE IT LDA AB142 MOVE FROM LDB AB141 TO JSB &MVW LN141 NOP MOVEa LENGTH LDA IL140 COMPUTE SCREEN LENGTH ADA IL142 FOR TR. TYPE 1 JMP WRT14 SC141 ADA IL141 TR. TYPE 2 OR 3 ADD LENGTH OF BUFF FOR TR.TYPE 2\3 CPB D.2 TR.TYPE 2 ? RSS YES ADA IL142 NO TR TYPE 3 WRT14 STA ILS14 STORE SCREEN LENGTH JSB EXEC NOW WRITE SCREEN 13 DEF *+5 RETURN POINT DEF D.2 CODE EXEC DEF ILU CONTOL WORD DEF BSC14 BUFFER LOCATION DEF ILS14 BUF.LENGTH JMP CANS LOAD SEGMENT TO ANLYSE USER'S ANSWERS * * TABLE OF OFFSETS FOR SCREEN 13 * SSED EQU 31 SOF14 ABS SSED ABS SSED+2 ABS SSED+3 ABS SSED+19 ABS SSED+20 ABS SSED+21 ABS SSED+26 DEC -1 * * TABLE OF DEST BUFFER ADDRESSES FOR SCREEN 13 * BD14 DEF T1400,I DEF T1401 DEF T1402 DEF TYYY DEF T1403 DEF T1404 * DBL14 DEC 3 TYYY NOP * * DATA SCREEN 13 * * * * LINE # : 1 * BSC14 BYT 33,130 FORMAT OFF BYT 33,110 HOME UP CL01 BYT 33,112 CLEAR DISPLAY ASC 22, Screen # 13 VALIDATION SPECIFICATIONS FOR ASC 11,THE ANSWER TO QUESTION BYT 40,0 BYT 33,46,144,104 T14 ASC 6, BYT 33,46,144,100 BYT 15,12 * * LINE # : 2 * BYT 15,12 * * LINE # : 3 * ASC 22, - Enter the maximum length of the string ASC 16, (<127) ....................... BYT 33,46,144,102,33,133 T1400 ASC 1, BYT 40,0 BYT 33,135,33,46,144,100 BYT 15,12 * * LINE # : 4 * ASC 22, - Specify the position of the string in ASC 9,the output buffer, BYT 15,12 * * LINE # : 5 * BYT 33,46,141,53,61,61,103,0 POSITION CURSOR - 12 BYT 33,46,144,104 BYT 122,0 BYT 33,46,144,100 ASC 10,ight positioning or BYT 33,46,144,104 BYT 114,0 BYT 33,46,144,100 ASnC 22,eft positioning (default).................. BYT 33,46,144,102,33,133 T1401 BYT 40,0 BYT 33,135,33,46,144,100 BYT 15,12 * * LINE # : 6 * BYT 15,12 * * LINE # : 7 * ASC 22, - Specify the mask to be applied to the ASC 11,answer by filling each BYT 15,12 * * LINE # : 8 * ASC 22, character position with one of the fol ASC 9,lowing characters BYT 72,0 BYT 15,12 * * LINE # : 9 * ASC 3, BYT 40,0 BYT 33,46,144,104 BYT 101,0 BYT 33,46,144,100 ASC 22, to specify an alphabetic character in this ASC 4,position BYT 15,12 * * LINE # : 10 * ASC 3, BYT 40,0 BYT 33,46,144,104 BYT 71,0 BYT 33,46,144,100 ASC 22, to specify a numeric character in this posi ASC 2,tion BYT 15,12 * * LINE # : 11 * ASC 3, BYT 40,0 BYT 33,46,144,104 BYT 130,0 BYT 33,46,144,100 ASC 22, to specify any ASCII character in this posi ASC 2,tion BYT 15,12 * * LINE # : 12 * ASC 4, any BYT 40,0 BYT 33,46,144,104 ASC 4,characte BYT 162,0 BYT 33,46,144,100 ASC 22, other than A,9,X will specify itself BYT 33,46,144,102,33,133 T1402 ASC 8, BYT 33,135,33,46,144,100 ESC14 BYT 15,12 * * B.141 BYT 15,12 * * LINE # : 14 * ASC 1, BYT 33,51,102,16 ASC 1,R, BYT 54,17 ASC 22, Enter X if the following function may be us ASC 12,ed during this question BYT 16,54 ASC 2,,,,, BYT 124,0 BYT 15,12 * * LINE # : 15 * ASC 1, BYT 33,51,102,16 ASC 1,. BYT 33,46,141,53,67,64,103,0 POSITION CURSOR - 79 BYT 56,0 BYT 15,12 * * LINE # : 16 * ASC 1, BYT 33,51,102,16 BYOhT 56,17 ASC 22, NEXT ENTRY in an IMAGE chain .......... ASC 15,............................. BYT 33,46,144,102,33,133 T1403 BYT 40,0 BYT 33,135,33,46,144,100,16,56 BYT 15,12 * * LINE # : 17 * ASC 1, BYT 33,51,102,16 ASC 22,F,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ASC 16,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, BYT 107,0 E.141 BYT 15,12 * * B.142 BYT 15,12 * * LINE # : 19 * ASC 1, BYT 33,51,102,16 ASC 10,R,,,,,,,,,,,,,,,,,,, BYT 17,40 ASC 10,User written modules BYT 40,16 ASC 17,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, BYT 124,0 BYT 15,12 * * LINE # : 20 * ASC 1, BYT 33,51,102,16 ASC 1,. BYT 17,55 ASC 22, If an additional validation is to be perfor ASC 9,med on the value, BYT 33,46,141,53,61,61,103,0 POSITION CURSOR - 79 BYT 16,56 BYT 15,12 * * LINE # : 21 * ASC 1, BYT 33,51,102,16 BYT 56,17 ASC 22, enter the name of the appropriate user wr ASC 12,itten validation module BYT 40,40 BYT 33,46,144,102,33,133 T1404 ASC 2, BYT 40,0 BYT 33,135,33,46,144,100 BYT 16,56 BYT 15,12 * * LINE # : 22 * ASC 1, BYT 33,51,102,16 ASC 22,F,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ASC 16,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, BYT 107,0 E.142 BYT 15,12 * ILS14 NOP STA14 EQU BSC14 LTA14 EQU ESC14 ST141 EQU B.141 LT141 EQU E.141 ST142 EQU B.142 LT142 EQU E.142 IL140 ABS LTA14-STA14+1 IL141 ABS LT141-ST141+1 IL142 ABS LT142-ST142+1 AB141 DEF B.141 AB142 DEF B.142 SOQST NOP CHAR OFFSET * ************************************************************************* * SCREEN # 14 EDIT FOR FUNCTION ONLY ANSWER TYPE * ************************************************************************* * ҿSCR15 LDA IQST QUESTION # ADA .D1 DECREMENT MPY D.12 QUEST. LABEL LENGTH ADA D.747 BASE OFFSET STA SOQST STORE OFFSET JSB MOVCA MOVE QUESTION LABEL IN SCREEN TITLE DEF *+6 DEF IFORM ANSWER STORAGE DEF SOQST CHAR. OFFSET IN IFORM DEF T15 DEST. BUFFER DEF D.1 DEST OFFSET DEF D.12 MOVE LENGTH * JSB MOVCX MOVE ANSWERS IN UNPROT. FIELDS DEF *+6 DEF JFORM ANSWER STORAGE DEF SOF15 TABLE OF CHAR.OFFSETS IN JFORM DEF BD15 TABLE OF BUFFER DEST. ADDRESS DEF D.OFF DEST.OFFSET DEF DBL15 QUESTION # * LDA IL150 GET SCREEN LENGTH FOR TR. TYPE 1 LDB ITT GET TR. TYPE CPB D.1 IS 1 ? RSS YES LDA IL151 NO GET SCREEN LENGTH FOR TR. TYPE 2 AND 3 STA ILS15 STORE SCREEN LENGTH JSB EXEC WRITE SCREEN 14 DEF *+5 RETURN POINT DEF D.2 CODE EXEC DEF ILU CONTROL WORD DEF BSC15 BUFFER LOCATION DEF ILS15 BUFFER LENGTH JMP CANS LOAD SEGMENT TO ANALYSE USER' S ANSWERS * * TABLE OF OFFSETS SCREEN # 14 * SOF15 ABS SSED ABS SSED+1 ABS SSED+2 ABS SSED+3 DEC -1 * * BUFFER DEST ADDRESS TABLE SCREEN 14 * BD15 DEF T1500 DEF T1501 DEF T1502 * * DATA SCREEN 14 * * * LINE # : 1 * BSC15 BYT 33,130 FORMAT OFF BYT 33,110 HOME UP CL02 BYT 33,112 CLEAR DISPLAY ASC 22, Screen # 14 VALIDATION SPECIFICATIONS FOR ASC 11,THE ANSWER TO QUESTION BYT 40,0 BYT 33,46,144,104 T15 ASC 6, BYT 15,12 * * LINE # : 2 * BYT 15,12 * * LINE # : 3 * BYT 15,12 * * LINE # : 4 * ASC 22, The only valid answers to the question a ASC 7,re functions : BYT 15,12 * * LINE # : 5 *  BYT 15,12 * * LINE # : 6 * BYT 33,46,141,53,60,70,103,0 POSITION CURSOR - 09 ASC 22,The functions ABORT, SAME VALUE, RECALL and ASC 11,RESET/START are valid BYT 15,12 * * LINE # : 7 * BYT 33,46,141,53,60,70,103,0 POSITION CURSOR - 09 ASC 22,answers to the question. They must have been ASC 11, defined in the SFK BYT 15,12 * * LINE # : 8 * BYT 33,46,141,53,60,70,103,0 POSITION CURSOR - 09 ASC 11,ASSIGNMENT SCREEN(S). BYT 15,12 * * LINE # : 9 * BYT 15,12 * * LINE # : 10 * BYT 15,12 * * LINE # : 11 * BYT 33,46,141,53,60,70,103,0 POSITION CURSOR - 09 ASC 22,Enter X where appropriate if some of the fol ASC 12,lowing functions are als BYT 157,0 BYT 15,12 * * LINE # : 12 * BYT 33,46,141,53,60,70,103,0 POSITION CURSOR - 09 ASC 18,to be valid answers to the question. BYT 15,12 * * LINE # : 13 * BYT 15,12 * * LINE # : 14 * BYT 15,12 * * LINE # : 15 * BYT 33,46,141,53,61,64,103,0 POSITION CURSOR - 15 ASC 22,CONTINUE to the next question ............. ASC 3,..... BYT 33,46,144,102,33,133 T1500 BYT 40,0 BYT 33,135,33,46,144,100 ESC15 BYT 15,12 * * B.151 BYT 15,12 * * LINE # : 17 * BYT 33,46,141,53,61,64,103,0 POSITION CURSOR - 15 ASC 22,NEXT ENTRY in an IMAGE chain ............. ASC 3,..... BYT 33,46,144,102,33,133 T1501 BYT 40,0 BYT 33,135,33,46,144,100 BYT 15,12 * * LINE # : 18 * BYT 15,12 * * LINE # : 19 * BYT 33,46,141,53,61,64,103,0 POSITION CURSOR - 15 ASC 22,DELETE ENTRY in data base ............. ASC 3,..... BYT 33,46,144,102,33,133 T1502 BYT 40,0 BYT 33,135,33,46,144,100 E.151 BYT 15,12 * * ILS15 NOP STA15 EQU BSC15 J LTA15 EQU ESC15 LT151 EQU E.151 IL150 ABS LTA15-STA15+1 IL151 ABS LT151-STA15+1 * ************************************************************************* * * SCREEN 15 : DISPLAY INFORMATION * ************************************************************************* * * SCR16 LDA IQST GET QUESTION # ADA .D1 DECREMENT MPY D.12 QUESTION LABEL CHAR LENGTH ADA D.747 BASE OFFSET STA SOQST STORE QUESTION LABEL OFFSET JSB MOVCA MOVE QUESTION LABEL IN SCREEN TITLE DEF *+6 DEF IFORM ANSWER STORAGE DEF SOQST SOURCE OFFSET DEF T16 DEST BUFFER DEF D.1 DEST OFFSET DEF D.12 MOVE LENGTH * JSB MOVCX MOVE ANSEWRS IN UNPROT. FIELDS DEF *+6 DEF JFORM ANSWER STORAGE DEF SOF16 TABLE OF OFFSETS IN JFORM SCREEN 15 DEF BD16 TABLE OF DEST BUFFER ADDRESS DEF D.OFF DEST OFFSET DEF DBL16 QUESTION # * LDA T1603 GET THE TYPE OF VALUE TO DISPLAY FIELD & SEE AND LMASK IF IT IS BLANK. IF SO, MAKE SURE THE LENGTH FIELD CPA BLNK0 IS ALSO BLANKED OUT. RSS BLANK. JMP SC16A NOT BLANK. STA T1604+1 STORE ASCII BLANKS INTO THE LDA BLANK THREE BYTES OF THE LENGTH STA T1604 UNPROTECTED FIELD. * SC16A LDA IL160 INITIALISE SCREEN LENGTH STA ILS16 LDA IL163 INITIALISE MOVE LENGTH STA LN163 STA LN164 LDA ITT GET TR. TYPE SLA IS 2 ? JMP SC160 NO ITS 1 OR 3 LDA IL162 YES MOVE LENGTH STA LN162 ADA ILS16 UPDATE SCREEN LENGTH STA ILS16 LDA A.162 MOVE FROM LDB A.161 TO JSB &MVW LN162 NOP MOVE LENGTH JMP SC162 SC160 LDA IL161 TR. TYPE 1 OR 3 ADA ILS16 UPDATE SCREEN LENGTH STA ILS16 LDA ITT GET TR. TYPE CPA D.1 Ǵ IS 1? JMP SC161 YES LDA IL162 ITS 3 ! UPDATE ADA ILS16 SCREEN LENGTH STA ILS16 * * NOW CHECK IF 3070B ? * LDA IMODB GET TERMINAL TYPE SZA,RSS JMP WRT16 3070A JMP SC163 3070B SC161 LDA IMODB GET TERMINAL TYPE SZA,RSS JMP WRT16 3070A LDA A.163 MOVE FROM LDB A.162 TO JSB &MVW LN163 NOP MOVE LENGTH JMP SC163 SC162 LDA IMODB GET TERMINAL TYPE SZA,RSS JMP WRT16 3070A LDA A.163 3070B MOVE FROM LDB A.161 TO ADB IL162 JSB &MVW LN164 NOP MOVE LENGTH * SC163 LDA IL163 3070B UPDATE SCREEN LENGTH ADA ILS16 STA ILS16 * WRT16 JSB EXEC WRITE SCREEN 15 DEF *+5 RETURN POINT DEF D.2 CODE EXEC DEF ILU CONTROL WORD DEF BSC16 BUFFER LOCATION DEF ILS16 BUFFER LENGTH JMP CANS LOAD SEGMENT TO ANALYSE USER'S ANSWERS * * TABLE OF CHAR. OFFSETS IN JFORM SCREEN 15 * SSDSP EQU 69 SOF16 ABS SSDSP ABS SSDSP+2 ABS SSDSP+14 ABS SSDSP+20 ABS SSDSP+21 ABS SSDSP+22 ABS SSDSP+24 ABS SSDSP+29 DEC -1 * * TABLE OF BUFFER DEST ADDRESS SCREEN 15 * BD16 DEF T1600 DEF T1601 DEF T1605 DEF T1606 DEF T1603 DEF T1604,I DEF T1602 * DBL16 DEC 3 LMASK OCT 177400 BLNK0 OCT 20000 BLANK ASC 1, * * * DATA SCREEN 15 * * * LINE # : 1 * BSC16 BYT 33,130 FORMAT OFF BYT 33,110 HOME UP CL03 BYT 33,112 CLEAR DISPLAY ASC 22, Screen # 15 INFORMATION TO BE DISPLAYE ASC 10,D WITH THE QUESTION BYT 33,46,144,104 T16 ASC 6, BYT 15,12 * * LINE # : 2 * BYT 15,12 * * LINE # : 3 * ASC 22, - Specify the number of the prompting li ASC 9,ght which givesRHFBT 111,0 BYT 33,46,144,100 ASC 5,nteger or BYT 33,46,144,104 BYT 122,0 BYT 33,46,144,100 ASC 7,eal number)... BYT 40,0 BYT 33,46,144,102,33,133 T1603 BYT 40,0 BYT 33,135,33,46,144,100,16,56 BYT 15,12 * * LINE # : 16 * BYT 40,0 BYT 33,51,102,16 BYT 56,17 ASC 22, - If a string, specify its maximum length ASC 14, ........................... ќH BYT 40,0 BYT 33,46,144,112,33,133 T1604 ASC 1, BYT 40,0 BYT 33,135,33,46,144,100,16,56 BYT 15,12 * * LINE # : 17 * BYT 40,0 BYT 33,51,102,16 ASC 22,F,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ASC 17,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,G BYT 15,12 * * LINE # : 18 * E.161 BYT 15,12 * * * LINE # : 19 * B.162 BYT 40,0 BYT 33,51,102,16 ASC 2,R,,, BYT 54,17 ASC 22, If the value to display is to be retrieved ASC 12,from an IMAGE data base BYT 16,54 ASC 2,,,,T BYT 15,12 * * LINE # : 20 * BYT 40,0 BYT 33,51,102,16 ASC 1,. BYT 33,46,141,53,67,65,103,0 POSITION CURSOR - 79 BYT 56,0 BYT 15,12 * * LINE # : 21 * BYT 40,0 BYT 33,51,102,16 BYT 56,17 ASC 22, - Give the item name of the value which is ASC 13, to be displayed ........ BYT 33,46,144,102,33,133 T1605 ASC 3, BYT 33,135,33,46,144,100,16,56 BYT 15,12 * * LINE # : 22 * BYT 40,0 BYT 33,51,102,16 ASC 22,F,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ASC 17,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,G E.162 BYT 15,12 * * * LINE # : 9 * B.163 BYT 33,46,141,70,162,60,103,0 ASC 22, - Enter X to echo the value and subseque ASC 16,nt input on the HP3070B printer BYT 40,0 BYT 33,46,144,102,33,133 T1606 BYT 40,0 BYT 33,135,33,46,144,100 E.163 BYT 15,12 * * STA16 EQU BSC16 LTA16 EQU ESC16 S.161 EQU B.161 L.161 EQU E.161 S.162 EQU B.162 L.162 EQU E.162 S.163 EQU B.163 L.163 EQU E.163 ILS16 NOP IL160 ABS LTA16-STA16+1 IL161 ABS L.161-S.161+1 IL162 ABS L.162-S.162+1 IL163 ABS L.163-S.163+1 A.161 DEF B.161 A.162 DEF B.162 A.163 DEF B.163 * ************************************************************************** * * SCREEN 16 SYSTEM ADDED INFORMATION * iE ************************************************************************** * * SCR17 JSB MOVCX MOVE ANSWERS IN UNPROTECTED FIELDS DEF *+6 DEF MFORM ANSWER STORAGE DEF SOF17 TABLE OF OFFSETS IN MFORM DEF BD17 TABLE OF ADDRESSES IN THE SCREEN DEF D.0 DEF DBL15 JSB MOVCA MOVE FORM NAME IN TITLE DEF *+6 DEF IFORM DEF D.57 DEF T17 DEF D.1 DEF D.6 * LDA IMFLG GET IMAGE FLAG SSA IMAGE STORAGE ? JMP SC170 YES LDA IL170 ADJUST STA ILS17 SCREEN JMP WRT17 LENGTH SC170 LDA IL171 STA ILS17 WRT17 JSB EXEC WRITE SCREEN DEF *+5 DEF D.2 DEF ILU DEF BSC17 DEF ILS17 JMP CANS LOAD SEGMENT TO ANALYSE USER'S ANSWERS * * TABLE OF CHAR OFFSETS SCREEN 16 * SOF17 DEC 1,2,3,4,5,11,17,23,29,30,31,32,33,-1 * * TABLE OF ADDRESSES IN SCREEN * BD17 DEF T1700 DEF T1701 DEF T1702 DEF T1703 DEF L1700 DEF L1702 DEF L1704 DEF L1706 DEF L1701 DEF L1703 DEF L1705 DEF L1707 * * DATA SCREEN 16 * * * LINE # : 1 * BSC17 BYT 33,130 FORMAT OFF BYT 33,110 HOME UP CL04 BYT 33,112 CLEAR DISPLAY ASC 22, Screen # 16 INFORMATION TO BE ADDED BY THE ASC 13, SYSTEM TO THE TRANSACTION BYT 40,0 BYT 33,46,144,104 T17 ASC 3, BYT 15,12 * * LINE # : 2 * BYT 15,12 * * LINE # : 3 * ASC 22, - Certain "identification" and "time st ASC 17,amp" information can be stored BYT 15,12 * * LINE # : 4 * ASC 22, along with the data collected by this ASC 7, transaction. BYT 15,12 * * LINE # : 5 * BYT 15,12 * * LINE # : 6 * BYT 15,12 * * LINE # : 7 * BYT 33,46,14F1,53,61,65,103,0 POSITION CURSOR - 16 BYT 33,51,102,16 ASC 2,R,, BYT 17,105 ASC 3,nter X BYT 16,40 ASC 2,,,,T BYT 15,12 * * LINE # : 8 * BYT 33,46,141,53,61,65,103,0 POSITION CURSOR - 16 BYT 33,51,102,16 BYT 56,17 ASC 7, to select BYT 16,56 BYT 15,12 * * LINE # : 9 * BYT 33,46,141,53,61,65,103,0 POSITION CURSOR - 16 BYT 33,51,102,16 ASC 1,. BYT 33,46,141,53,61,63,103,0 POSITION CURSOR - 31 BYT 56,0 BYT 15,12 * * LINE # : 10 * BYT 33,46,141,53,61,65,103,0 POSITION CURSOR - 16 BYT 33,51,102,16 BYT 56,17 BYT 33,46,141,53,61,64,103,0 POSITION CURSOR - 31 BYT 16,56 BYT 15,12 * * LINE # : 11 * BYT 33,46,141,53,61,65,103,0 POSITION CURSOR - 16 BYT 33,51,102,16 BYT 56,17 BYT 33,46,141,53,61,63,103,0 POSITION CURSOR - 30 BYT 16,40 BYT 56,0 BYT 15,12 * * LINE # : 12 * ASC 7,Transaction BYT 40,0 BYT 33,51,102,16 ASC 1,. BYT 33,46,141,53,61,63,103,0 POSITION CURSOR - 31 BYT 56,0 BYT 15,12 * * LINE # : 13 * ASC 7,identification BYT 33,51,102,16 ASC 1, . BYT 17,56 ASC 2,.... BYT 40,0 BYT 33,46,144,102,33,133 T1700 BYT 40,0 BYT 33,135,33,46,144,100 ASC 3, BYT 40,16 BYT 56,0 BYT 15,12 * * LINE # : 14 * BYT 33,46,141,53,61,64,103,0 POSITION CURSOR - 15 BYT 33,51,102,16 ASC 1, . BYT 33,46,141,53,61,64,103,0 POSITION CURSOR - 31 BYT 56,0 BYT 15,12 * * LINE # : 15 * ASC 7,Terminal # BYT 33,51,102,16 ASC 1, . BYT 17,56 ASC 2,.... BYT 40,0 BYT 33,46,144,102,33,133 T1701 BYT 40,0 BYT 33,135,33,46,144,100 ASC 3,  BYT 40,16 BYT 56,0 BYT 15,12 * * LINE # : 16 * BYT 33,46,141,53,61,64,103,0 POSITION CURSOR - 15 BYT 33,51,102,16 ASC 1, . BYT 33,46,141,53,61,64,103,0 POSITION CURSOR - 31 BYT 56,0 BYT 15,12 * * LINE # : 17 * ASC 2,Date BYT 33,46,141,53,61,60,103,0 POSITION CURSOR - 15 BYT 33,51,102,16 ASC 1, . BYT 17,56 ASC 2,.... BYT 40,0 BYT 33,46,144,102,33,133 T1702 BYT 40,0 BYT 33,135,33,46,144,100 ASC 3, BYT 40,16 BYT 56,0 BYT 15,12 * * LINE # : 18 * BYT 33,46,141,53,61,64,103,0 POSITION CURSOR - 15 BYT 33,51,102,16 ASC 1, . BYT 33,46,141,53,61,64,103,0 POSITION CURSOR - 31 BYT 56,0 BYT 15,12 * * LINE # : 19 * ASC 7,Time of day BYT 33,51,102,16 ASC 1, . BYT 17,56 ASC 2,.... BYT 40,0 BYT 33,46,144,102,33,133 T1703 BYT 40,0 BYT 33,135,33,46,144,100 ASC 3, BYT 40,16 BYT 56,0 BYT 15,12 * * LINE # : 20 * BYT 33,46,141,53,61,64,103,0 POSITION CURSOR - 15 BYT 33,51,102,16 ASC 8, F,,,,,,,,,,,,,, BYT 107,0 ESC17 BYT 15,12 * * * LINE # : 7 * BYT 33,46,141,66,162,63,63,103 BYT 33,51,102,16 ASC 2,R,,, BYT 54,17 ASC 16, Complete only if the informatio BYT 156,16 ASC 4, ,,,,,,T BYT 15,12 * * LINE # : 8 * BYT 33,46,141,53,63,63,103,0 POSITION CURSOR - 34 BYT 33,51,102,16 BYT 56,17 ASC 18, is to be stored in a data base BYT 33,46,141,53,60,70,103,0 POSITION CURSOR - 79 BYT 16,56 BYT 15,12 * * LINE # : 9 * BYT 33,46,141,53,63,63,103,0 POSITION CURSOR - 34 BYT 33,51,102,16 ASC 1,. BYT 33,46,141,53,64,63,103,0 POSITION CURSOR - 79 BYT 6"BYT 40,0 BYT 33,135,33,46,144,100 BYT 33,46,141,53,61,60,103,0 POSITION CURSOR - 79 BYT 16,56 BYT 15,12 * * LINE # : 16 * BYT 33,46,141,53,63,63,103,0 POSITION CURSOR - 34 BYT 33,51,102,16 BYT 56,17 BYT 33,46,141,53,64,64,103,0 POSITION CURSOR - 79 BYT 16,56 BYT 15,12 * * LINE # : 17 * BYT 33,46,141,53,63,63,103,0 POSITION CURSOR - 34 BYT 33,51,102,16 BYT 56,17 ASC 2, BYT 40,0 BYT 33,46,144,102,33,133 L1704 ASC 3, BYT 33,135,33,46,144,100 BYT 33,46,141,53,62,62,103,0 POSITION CURSOR - 68 BYT 33,46,144,102,33,133 L1705 BYT 40,0 BYT 33,135,33,46,144,100 BYT 33,46,141,53,61,60,103,0 POSITION CURSOR - 79 BYT 16,56 BYT 15,12 * * LINE # : 18 * BYT 33,46,141,53,63,61,103,0 POSITION CURSOR - 32 BYT 33,51,102,16 ASC 1, BYT 56,17 BYT 33,46,141,53,64,64,103,0 POSITION CURSOR - 79 BYT 16,56 BYT 15,12 * * LINE # : 19 * BYT 33,46,141,53,63,63,103,0 POSITION CURSOR - 34 BYT 33,51,102,16 BYT 56,17 ASC 2, BYT 40,0 BYT 33,46,144,102,33,133 L1706 ASC 3, BYT 33,135,33,46,144,100 BYT 33,46,141,53,62,62,103,0 POSITION CURSOR - 68 BYT 33,46,144,102,33,133 L1707 BYT 40,0 BYT 33,135,33,46,144,100 BYT 33,46,141,53,61,60,103,0 POSITION CURSOR - 79 BYT 16,56 BYT 15,12 * * LINE # : 20 * BYT 33,46,141,53,63,63,103,0 POSITION CURSOR - 34 BYT 33,51,102,16 ASC 22,F,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ASC 1,,G E.170 BYT 15,12 * STA17 EQU BSC17 LTA17 EQU ESC17 LT170 EQU E.170 IL170 ABS LTA17-STA17+1 IL171 ABS LT170-STA17+1 ILS17 NOP * * ********************************************************************** * * SCREEN 17 : DATA STORAGE SPECIFICATIONS * *********************************************************************** * * SCR18 JSB MOVCX MOVE ANSWERS DEF *+6 IN UNPROTECTED FIELDS DEF LFORM ANSWER STORAGE DEF SOF18 TABLE OF OFFSETS IN LFORM DEF BD18 TABLE OF BUFFER DEST. ADDRESS DEF D.0 DEF DBL15 * JSB MOVCA MOVE FORM NAME IN TITLE DEF *+6 DEF IFORM DEF D.57 DEF T18 DEF D.1 DEF D.6 * LDA ITT GET TR,TYPE SLA ADJUST SCREEN LENGTH JMP SC180 LDA IL180 TR.TYPE 0 OR 2 STA ILS18 JMP WRT18 SC180 LDA IL181 TR.TYPE 1 OR 3 STA ILS18 * WRT18 JSB EXEC WRITE SCREEN DEF *+5 RETURN POINT DEF D.2 CODE EXEC DEF ILU CONTROL WORD DEF BSC18 BUFFER LOCATION DEF ILS18 BUFFER LENGTH JMP CANS LOAD SEGMENT TO ANALYSE USER'S ANSWER * * DATA SCREEN 17 * * * LINE # : 1 * BSC18 BYT 33,130 FORMAT OFF BYT 33,110 HOME UP CL05 BYT 33,112 CLEAR DISPLAY ASC 19, Screen # 17 DATA STORAGE DEFINITI ASC 11,ON FOR THE TRANSACTION BYT 40,0 BYT 33,46,144,104 T18 ASC 3,xxxxxx BYT 15,12 * * LINE # : 2 * BYT 15,12 * * LINE # : 3 * BYT 33,46,141,53,61,62,103,0 POSITION CURSOR - 13 ASC 22,Some or all of the following media may be se ASC 3,lected BYT 56,0 BYT 15,12 * * LINE # : 4 * BYT 15,12 * * LINE # : 5 * BYT 33,51,102,16 ASC 5,R,,,,,,,,, BYT 54,17 ASC 22, If the collected data is to be stored on a ASC 7,magnetic tape BYT 16 ASC 5,,,,,,,,,,, BYT 124,0 * * LINE # : 6 * BYT 33,51,102,16 BYT 56,17 BYT 33,46,141,53,67,70,103,0 POSITION CURSOR - 80 BYT 16,56 * * LINE # : 7 * BYT 33,51,102,16 BYT 56,17  ASC 22, - Enter the FILE NAME of the selected devi ASC 14,ce ........................ BYT 33,46,144,102,33,133 T1800 ASC 3, BYT 33,135,33,46,144,100,16,56 * * LINE # : 8 * BYT 33,51,102,16 ASC 22,F,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ASC 18,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,G * * LINE # : 9 * BYT 15,12 * * LINE # : 10 * BYT 33,51,102,16 ASC 4,R,,,,,,, BYT 17,40 ASC 22,If the collected data is to be stored on a s ASC 8,erial disc file BYT 16,54 ASC 5,,,,,,,,,,T * * LINE # : 11 * BYT 33,51,102,16 ASC 1,. BYT 33,46,141,53,67,67,103,0 POSITION CURSOR - 80 BYT 56,0 * * LINE # : 12 * BYT 33,51,102,16 ASC 1,. BYT 40,17 ASC 22,- Enter the disc FILE NAME ................. ASC 13,......................... BYT 33,46,144,102,33,133 T1801 ASC 3, BYT 33,135,33,46,144,100,16,56 * * LINE # : 13 * BYT 33,51,102,16 ASC 1,. BYT 40,17 ASC 22, and the CARTRIDGE NUMBER (default is first ASC 13, cartridge mounted) ..... BYT 33,46,144,112,33,133 T1802 ASC 3, BYT 33,135,33,46,144,100,16,56 * * LINE # : 14 * BYT 33,51,102,16 ASC 1,. BYT 33,46,141,53,67,67,103,0 POSITION CURSOR - 80 BYT 56,0 * * LINE # : 15 * BYT 33,51,102,16 ASC 1,. BYT 40,17 ASC 22,- Enter the file SECURITY CODE (default is n ASC 13,one) .................... BYT 33,46,144,102,33,133 T1803 ASC 3, BYT 33,135,33,46,144,100,16,56 * * LINE # : 16 * BYT 33,51,102,16 ASC 22,F,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ASC 18,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,G * * LINE # : 17 * ESC18 BYT 15,12 * * LINE # : 18 * BYT 33,51,102,16 ASC 1,R, BYT 54,17 ASC 22, If the collected data is to be handled by a ASC 14, user written storage module BYT 40,16 ASC 2,,,,T * * LINE # : 19 * BYT 33,51,102,16 ASC 1,. BYT 33,46,141,53,67,67,103,0 POSITION CURSOR - 80 BYT 56,0 * * LINE # : 20 * BYT 33,51,102,16 BYT 56,17 ASC 22, - Specify the storage module name ....... ASC 14,............................ BYT 40,0 BYT 33,46,144,102,33,133 T1804 ASC 2, BYT 40,0 BYT 33,135,33,46,144,100,16,56 * * LINE # : 21 * BYT 33,51,102,16 ASC 22,F,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ASC 18,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,G * * LINE # : 22 * E.180 BYT 15,12 * * STA18 EQU BSC18 LTA18 EQU ESC18 LT180 EQU E.180 IL180 ABS LTA18-STA18+1 IL181 ABS LT180-STA18+1 ILS18 NOP * * TABLE OF OFFSETS FOR SCREEN 17 * * * SOF18 DEC 1,7,13,19,25,30,-1 * * TABLE OF BUFFER DEST. ADDRESS SCREEN 17 * BD18 DEF T1800 DEF T1801 DEF T1802 DEF T1803 DEF T1804 * ********************************************************************** * * SCREEN 18 TRANSACTION SPECS STORAGE * ********************************************************************** * * SCR19 JSB MOVCX MOVE ANSWERS IN DEF *+6 UNPROTECTED FIELDS DEF LFORM ANSWER STORAGE DEF SOF19 TABLE OF OFFSETS SCREEN 17 DEF BD19 BUFFER DEST ADDRESS TABLE DEF D.0 DEF DBL15 * JSB MOVCA MOVE FORM NAME IN TITLE DEF *+6 DEF IFORM DEF D.57 DEF T19 DEF D.1 DEF D.6 * JSB EXEC WRITE SCREEN DEF *+5 RETURN POINT DEF D.2 CODE EXEC DEF ILU CONTROL WORD DEF BSC19 BUFFER LOCATION DEF ILS19 BUFFER LENGTH JMP CANS LOAD SEGMENT TO ANALYSE USER'S ANSWERS * * DATA SCREEN 18 * * * LINE # :H 1 * * * LINE # : 1 * BSC19 BYT 33,130 FORMAT OFF BYT 33,110 HOME UP CL06 BYT 33,112 CLEAR DISPLAY ASC 22, Screen # 18 DESTINATION LIBRARY FOR THE ASC 13,TRANSACTION SPECIFICATION BYT 33,46,144,104 T19 ASC 3, BYT 15,12 * * LINE # : 2 * BYT 15,12 * * LINE # : 3 * BYT 15,12 * * LINE # : 4 * BYT 33,51,102,16 ASC 10,R,,,,,,,,,,,,,,,,,,, BYT 54,17 ASC 13, Definition of the destina ASC 7,tion library BYT 16,54 ASC 9,,,,,,,,,,,,,,,,,,T * * LINE # : 5 * BYT 33,51,102,16 ASC 1,. BYT 33,46,141,53,67,67,103,0 POSITION CURSOR - 80 BYT 56,0 * * LINE # : 6 * BYT 33,51,102,16 BYT 56,17 ASC 22, - Enter the LIBRARY NAME: disc file or ASC 14,device (MT, LCTU, RCTU) ... BYT 33,46,144,102,33,133 T1900 ASC 3, BYT 33,135,33,46,144,100,16,56 * * LINE # : 7 * BYT 33,51,102,16 BYT 56,17 ASC 13, - If the library is on: BYT 33,46,141,53,65,62,103,0 POSITION CURSOR - 80 BYT 16,56 * * LINE # : 8 * BYT 33,51,102,16 BYT 56,17 ASC 20, A minicartridge or a magnetic tape, BYT 33,46,144,104 ASC 5,load devic BYT 145,0 BYT 33,46,144,100 ASC 1,. BYT 33,46,141,53,62,65,103,0 POSITION CURSOR - 80 BYT 16,56 * * LINE # : 9 * BYT 33,51,102,16 BYT 56,17 ASC 22, A disc, give the CARTRIDGE REFERENCE num ASC 14,ber (Optional) ........... BYT 33,46,144,102,33,133 T1901 ASC 3, BYT 33,135,33,46,144,100,16,56 * * LINE # : 10 * BYT 33,51,102,16 ASC 1,. BYT 33,46,141,53,67,67,103,0 POSITION CURSOR - 80 BYT 56,0 * * LINE # : 11 * BYT 33,51,102,16 BYT 56,17 ASC 22, - If the library is to be created, PHFB SSA,RSS JMP CANS1 YES JSB EXEC NO LOAD SEGMENT TGP5 DEF *+3 RETURN POINT DEF D.8 CODE EXEC DEF ANS SEGMENT NAME CANS1 JSB EXEC SCREEN # > 10 LOAD SEGMENT ANSW1 DEF *+3 RETURN POINT DEF D.8 CODE EXEC DEF ANS1 SEGMENT NAME CANS2 JSB EXEC CALL DEF *+3 SEGMENT DEF D.8 TGP8 DEF ANS2 * * DATA SECTION * BENP BYT 33,127,0,137 FORMAT ON ANS ASC 3,TGP5 SEGMENT NAME TO LOAD ANS1 ASC 3,TGP6 SEGMENT NAME TO LOAD ANS2 ASC 3,TGP8 .D15 DEC -15 D.19 DEC 19 * * * END SEGMENT * END TGP4 N H  92903-18360 1805 S C0122 &TGP5              H0101 dpFTN4 PROGRAM TGP5(5), 92903-16360 REV.1805 780512 C C SOURCE 92903-18360 C C C C ************************************************************** C * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * C ************************************************************** C C C C C C PRGMR : JEAN CHARLES MIARD (HPG) C C C********************************************************************* C* * C* THIS IS A SEGMENT OF THE TGP PROGRAM USED TO * C* ANALYZE THE ANSWERS THE USER HAS GIVEN IN THE SCREENS 11,12 * C* AND 13 . C* THE ANSWERS AFTER A CHECK ARE STORED IN JFORM. * C* * C* THIS SEGMENT IS LOADED ONLY TO ANALYSE SCREEN ANSWERS * C* INDIC IS NOT USED . * C* * C* IF INDIC=-77 A HELP MESSAGE IS TO BE PRINTED * C* * C* * C* WARNING !! : CARE MUST BE TAKEN * : * C* * C* PRINTED SCREEN # 11 CORRESPONDS IN THE CODE TO ISCRN=12 * C* ............... 12 ................................ 13 * C* ............... 13 ................................ 14 * C* * C********************************************************************* C C C DECLARATIONS COMMON VARIABLES **************** C O COMMON ILU,ISCRN,IQST,ISKIP,INDIC COMMON IFORM(494) COMMON JFORM(980) COMMON MFORM(16) COMMON LFORM(39) COMMON ITT COMMON IKEY(11,3) COMMON IUMAX,IMMAX COMMON IMODB COMMON ILITE(15) COMMON IMAI(45,5) COMMON IMFLG,IMAS,IMDT,IMKY COMMON KFORM(1065) COMMON ILIBR(61) COMMON NIMAG C C LOCAL VARIABLES ********************* C DIMENSION JNAM(3),ILNGT(4,3) DIMENSION JOUT(10),KNAM(3),LNAM(3) DIMENSION IHP20(5),IHP21(6) DIMENSION IHP30(4),IHP31(5) DIMENSION IHP40(4),IHP41(5) C EQUIVALENCE (NOF,KFORM(531)) C LOGICAL JPAR,RNUM,GETBK,OKABT,ISBIT C C DATA VALUES : C DATA JNAM/2HTG,2HP3,2H / DATA KNAM/2HTG,2HP4,2H / DATA LNAM/2HTG,2HP1,2H / DATA IHP20/0,0,1,2,4/ DATA IHP21/0,0,1,2,3,4/ DATA IHP30/0,0,2,4/ DATA IHP31/0,0,2,3,4/ DATA IHP40/5,6,7,4/ DATA IHP41/5,6,7,3,4/ DATA ILNGT/18,24,20,26,31,37,33,39,22,28,24,30/ DATA IQLN/98/ C C C********************************************************************* C C GET USER'S ANSWERS IN THE SCREEN C C********************************************************************* C IF(INDIC.EQ.-77) GO TO 3011 C C C 15 I=ITT+1 J=ISCRN-11 ITLOG=ILNGT(I,J) IF(GETBK(ILU,KFORM,ITLOG)) GO TO 17 C-----SET ICARD=1, IF INPUT FROM CARD READER, C-----FURTHERMORE, SET IMCRD=1, IF INPUT FROM IMAGE CARD. ICARD=0 IMCRD=0 C-----INPUT FROM CARD? IF(IGET1(JFORM,3+(IQST-1)*98).NE.1HX) GO TO 18 C-----YES, CARD INPUT. ICARD=1 C-----IMAGE CARD INPUT? IF(ISBIT(JFORM(2+(IQST-1)*49),7)) IMCRD=1 GO TO 18 C C ERROR IN GETTING ANSWERS REPRINT SCREEN C 17 IF(ISCRN.NE.14) CALL EXEC(8,JNAM) CALL EXEC(8,KNAM) C C********************************************************************* C C GO TO ANALYSE USER ANSWERS TO SCREEN # ISC0RN C C********************************************************************* C 18 I=ISCRN-11 GO TO(1200,1300,1400) I C C********************************************************************* C C SCREEN # 11 (INTEGER EDITS) C C********************************************************************* C C C MAXIMUM VALUE * CHECK INTEGER OR BLANK C 1200 NOF=1 IF(JPAR(KFORM,ITLOG,NOF,JOUT,6,IFLG,JVAL)) GO TO 3000 IF(IFLG.GT.1) GO TO 1281 IFLG1=IFLG XMAX=JVAL CALL MOVCA(JOUT,1,JFORM,(31+(IQST-1)*IQLN),6) C C MINIMUM VALUE * CHECK INTEGER OR BLANK * MAX > MIN * C NOF=NOF+1 IF(JPAR(KFORM,ITLOG,NOF,JOUT,6,IFLG,JVAL)) GO TO 3000 IF(IFLG.GT.1) GO TO 1282 IFLG2=IFLG XMIN=JVAL IF((IFLG1.EQ.0).OR.(IFLG.EQ.0)) GO TO 1202 IF(XMIN.GE.XMAX) GO TO 1283 1202 CALL MOVCA(JOUT,1,JFORM,(37+(IQST-1)*IQLN),6) C C MODULO * CHECK POSITIVE INTEGER * MIN <= MOD <= MAX C NOF=NOF+1 IF(JPAR(KFORM,ITLOG,NOF,JOUT,2,IFLG,JVAL)) GO TO 3000 IF(IFLG.GT.1) GO TO 1280 IF((IFLG.EQ.1).AND.(JVAL.LT.1)) GO TO 1280 XMOD=JVAL IF((IFLG1.NE.0).AND.(XMOD.GT.XMAX)) GO TO 1280 IF((IFLG2.NE.0).AND.(XMOD.LT.XMIN)) GO TO 1280 CALL MOVCA(JOUT,1,JFORM,(43+(IQST-1)*IQLN),2) GO TO 1430 C C ERROR PROCESSING SCREEN 12 C 1184 CALL MES05(1,NOF) GO TO 15 1280 CALL MES05(2,NOF) GO TO 15 1281 CALL MES05(8,NOF) GO TO 15 1282 CALL MES05(9,NOF) GO TO 15 1283 NOF=NOF-1 CALL MES05(10,NOF) GO TO 15 C C********************************************************************* C C SCREEN 12 ( REAL EDITS ) C C********************************************************************* C C C MAXIMUM VALUE * MUST BE REAL * C 1300 NOF=1 IF(JPAR(KFORM,ITLOG,NOF,JOUT,14,IFLG,JVAL)) GO TO 3000 IFLG1=IFLG IF(RNUM(JOUT,1,14,XMAX)) GO TO 1281 C-----IF IMAGE CARD INPUT, LIMIT CHECK NZOT ALLOWED. IF(IMCRD.EQ.0) GO TO 1302 IF(IFLG.NE.0) GO TO 1495 1302 CALL MOVCA(JOUT,1,JFORM,(31+(IQST-1)*IQLN),14) C C MINIMUM VALUE * MUST BE REAL . MAX > MIN * C NOF=NOF+1 IF(JPAR(KFORM,ITLOG,NOF,JOUT,14,IFLG,JVAL)) GO TO 3000 C-----IF IMAGE CARD INPUT, LIMIT CHECK NOT ALLOWED. IF(IMCRD.EQ.0) GO TO 1303 IF(IFLG.NE.0) GO TO 1495 1303 IF(RNUM(JOUT,1,14,XMIN)) GO TO 1282 IF((IFLG.EQ.0).OR.(IFLG1.EQ.0)) GO TO 1304 IF(XMIN.GE.XMAX) GO TO 1283 1304 CALL MOVCA(JOUT,1,JFORM,(45+(IQST-1)*IQLN),14) GO TO 1430 C C********************************************************************* C C SCREEN 13 (STRING EDITS) C C********************************************************************* C C C MAXIMUM STRING LENGTH * INTEGER 1<= LENGTH <=126 * C STRING LENGTH FOR DATA BASE ITEM CANNOT BE MODIFIED C CHECK DEFAULT VALUE NOT LONGER THAN MAX STRING LENGTH C 1400 NOF=1 IF(JPAR(KFORM,ITLOG,NOF,JOUT,3,IFLG,JVAL)) GO TO 3000 JVAL1=JVAL IF(IFLG.NE.1) GO TO 1480 IF((JVAL.LT.1).OR.(JVAL.GT.126)) GO TO 1480 IF(IGET1(JFORM,5+(IQST-1)*98).NE.2HD ) GO TO 1402 IF(JFORM(16+(IQST-1)*49).NE.JVAL) GO TO 1488 1402 JFORM(16+(IQST-1)*49)=JVAL IF(LNCAR(JFORM,(7+(IQST-1)*IQLN),16).GT.JVAL1) GO TO 1486 C-----IMAGE CARD INPUT? IF(IMCRD.EQ.0) GO TO 1404 C-----YES. STRING LENGTH MUST BE AN EVEN NUMBER. IF(ISBIT(JVAL,0)) GO TO 1492 C C STRING POSITIONING * R OR L DEFAULT IS L * C 1404 NOF=NOF+1 IF(JPAR(KFORM,ITLOG,NOF,JOUT,1,IFLG,JVAL)) GO TO 3000 IF(IFLG.EQ.0) JOUT(1)=2HL IF((JOUT(1).NE.2HR ).AND.(JOUT(1).NE.2HL )) GO TO 1481 C-----IF IMAGE CARD INPUT, STRING POSITION MUST NOT BE 'R'. IF(IMCRD.EQ.0) GO TO 1406 IF(JOUT(1).EQ.2HR ) GO TO 1493 1406 CALL MOVCA(JOUT,1,JFORM,(33+(IQST-1)*IQLN),1) C C STRING MASK * CHECK MASK LENGTH NOT LONGER THAN MAX STRING LENGTH * C NOF=NOF+1 IF(JPAR(KF`ORM,ITLOG,NOF,JOUT,16,IFLG,JVAL)) GO TO 3000 IF(LNCAR(JOUT,1,16).GT.JVAL1) GO TO 1485 C-----IF IMAGE CARD INPUT, MASK NOT ALLOWED. IF(IMCRD.EQ.0) GO TO 1408 IF(IFLG.NE.0) GO TO 1494 1408 CALL MOVCA(JOUT,1,JFORM,(34+(IQST-1)*IQLN),16) GO TO 1435 C C********************************************************************** C C ARITHMETIC OPERATORS (SCREENS 11/12) C C********************************************************************** C C CHECK ANSWER IS BLANK OR X . IF X CHECK ARITH OPERATORS HAVE BEEN C DEFINED AS SFK'S C 1430 NOF=NOF+1 IF(JPAR(KFORM,ITLOG,NOF,JOUT,1,IFLG,JVAL)) GO TO 3000 C-----IF CARD INPUT, ARITHMETIC OPERATIONS NOT ALLOWED. IF(ICARD.EQ.0) GO TO 1431 IF(IFLG.NE.0) GO TO 1498 1431 IF((IFLG.NE.0).AND.(JOUT(1).NE.2HX )) GO TO 1184 IF(IFLG.EQ.0) GO TO 1434 DO 1432 I=1,11 DO 1432 J=1,3,2 IF(IKEY(I,J).EQ.9) GO TO 1434 1432 CONTINUE GO TO 1482 1434 IF(ISCRN.EQ.12) N=45 IF(ISCRN.EQ.13) N=59 IF(ISCRN.EQ.14) N=50 CALL MOVCA(JOUT,1,JFORM,(N+(IQST-1)*IQLN),1) C C********************************************************************* C C NEXT ENTRY IN AN IMAGE CHAIN ? (TR. TYPE > 1) C C********************************************************************* C C CHECK ANSWER IS BLANK OR X . IF X CHECK NEXT ENTRY HAS BEEN DEFINED C AND CHECK FIND IN DETAIL DATA SET DEFINED TOO . C 1435 IF(ITT.LT.2) GO TO 1438 NOF=NOF+1 IF(JPAR(KFORM,ITLOG,NOF,JOUT,1,IFLG,JVAL)) GO TO 3000 C-----IF CARD INPUT, NEXT ENTRY IN AN IMAGE CHAIN IS NOT ALLOWED. IF(ICARD.EQ.0) GO TO 14351 IF(IFLG.NE.0) GO TO 1498 14351 IF((IFLG.NE.0).AND.(JOUT(1).NE.2HX )) GO TO 1184 IF(IFLG.EQ.0) GO TO 1438 C-----'NEXT ENTRY' FOR ITEM TYPE S,I,R NOT ALLOWED. IARG=IGET1(JFORM,5+(IQST-1)*98) IF((IARG.EQ.2HS ).OR.(IARG.EQ.2HI ).OR.(IARG.EQ.2HR )) GO TO 1497 DO 1436 I=1,11 DO 1436 J=1,3,2 IF(IKEY(I,J).EQ.12) GO TO 1437 1436 CONTINUE GO TO 1483 1437 IF(IMDT.EQ.0) GO TO 1487 IF(IQST.LE.IUMAX) GO TO 1489 1438 IF(ISCRN.EQ.12) N=46 IF(ISCRN.EQ.13) N=60 IF(ISCRN.EQ.14) N=51 CALL MOVCA(JOUT,1,JFORM,(N+(IQST-1)*IQLN),1) IF(ITT.LT.2) CALL BLAN(JFORM,N+(IQST-1)*98,1) C C********************************************************************* C C USER EDIT SUBROUTINE (TR. TYPE 1/3 ONLY) C C********************************************************************* C 1440 IF((ITT.EQ.0).OR.(ITT.EQ.2)) GO TO 1444 NOF=NOF+1 IF(JPAR(KFORM,ITLOG,NOF,JOUT,5,IFLG,JVAL)) GO TO 3000 C-----IF IMAGE CARD INPUT THAT IS STRING OR REAL (IE,NOT INTEGER) C THEN USER WRITTEN MODULE REQUIRED. IF(IMCRD.EQ.0) GO TO 1444 IF(JFORM(34+(IQST-1)*49).EQ.1) GO TO 1444 IF(IFLG.EQ.0) GO TO 1491 1444 IF(ISCRN.EQ.12) N=47 IF(ISCRN.EQ.13) N=61 IF(ISCRN.EQ.14) N=52 CALL MOVCA(JOUT,1,JFORM,(N+(IQST-1)*IQLN),5) IF((ITT.EQ.0).OR.(ITT.EQ.2)) CALL BLAN(JFORM,N+(IQST-1)*98,5) GO TO 1630 C C ERROR PROCESSING SCREENS(12/13/14) C 1480 CALL MES05(3,NOF) GO TO 15 1481 CALL MES05(4,NOF) GO TO 15 1482 CALL MES05(5,NOF) GO TO 15 1483 CALL MES05(6,NOF) GO TO 15 1485 CALL MES05(12,NOF) GO TO 15 1486 CALL MES05(13,NOF) GO TO 15 1487 CALL MES05(14,NOF) GO TO 15 1488 CALL MES05(11,NOF) GO TO 15 1489 CALL MES05(15,NOF) GO TO 15 C-----"TOO MANY CHARACTERS HAVE BEEN SPECIFIED FOR THIS CARD" 1490 CALL MES05(16,1) GO TO 15 C-----"IMAGE CARD INPUT--USER WRITTEN MODULE REQUIRED" 1491 CALL MES05(17,NOF) GO TO 15 C-----"IMAGE CARD INPUT--STRING LENGTH MUST BE EVEN" 1492 CALL MES05(18,NOF) GO TO 15 C-----"IMAGE CARD INPUT--'R' IS ILLEGAL" 1493 CALL MES05(19,NOF) GO TO 15 C-----"IMAGE CARD INPUT--MASK NOT ALLOWED" 1494 CALL MES05(20,NOF) GO TO 15 C-----"IMAGE CARD INPUT--LIMIT CHECK NOT ALLOWED" 1495 CALL MES05(21,NOF) GO TO 15 C-----"IMAGE CARD INPUT--NOT ALLOWED" 1496 CALL MES05(22,NOF) GO TO 15 C-----"NOT ALLOWED" 1497 CALL MES05(23,NOF) GO TO 15 C-----"NOT ALLOWED WITH CARD READER INPUT" 1498 CALL MES05(24,NOF) GO TO 15 C C-----BEFORE CALLING NEXT SCREEN, VERIFY THAT IF INPUT IS FROM CARD, C THE MAX LENGTH OF THE CARD HAS NOT BEEN EXCEEDED. C 1630 INDEX=0 IBYTES=0 C-----GET NEXT RECORD FROM JFORM. 1004 INDEX=INDEX+1 C-----DONE? IF(INDEX.GT.IQST) GO TO 1515 C-----INPUT FROM CARD? IF(IGET1(JFORM,3+(INDEX-1)*98).NE.2HX ) GO TO 1004 C-----YES, IS IT A NEW CARD? INEW=IAND(JFORM(2+(INDEX-1)*49),77B) IF(INEW.EQ.0) GO TO 1006 C-----YES, NEW CARD, INIT CARD COL. CTR. & 80/40 FLAG. IBYTES=0 I40=0 C-----40 COLUMN CARD? IF(ISBIT(JFORM(2+(INDEX-1)*49),1)) I40=1 C-----ITEM TYPE 0 (STRING OR DATA ITEM)? 1006 JFM34=JFORM(34+(INDEX-1)*49) IF(JFM34.NE.0) GO TO 1008 LENGTH=JFORM(16+(INDEX-1)*49) GO TO 1012 C-----ITEM TYPE 1 (INTEGER)? 1008 IF(JFM34.NE.1) GO TO 1010 LENGTH=6 IF(ISBIT(JFORM(2+(INDEX-1)*49),7)) LENGTH=2 GO TO 1012 C-----ITEM TYPE 2 (REAL)? 1010 IF(JFM34.NE.2) GO TO 1004 LENGTH=14 IF(ISBIT(JFORM(2+(INDEX-1)*49),7)) LENGTH=4 C-----ACCUMULATE TOTAL FOR THIS CARD. 1012 IBYTES=IBYTES+LENGTH C-----40 COLUMN CARD? IF(I40.EQ.1) GO TO 1014 C-----NO, ASSUME 80. IF > 80 GO TO ERR. IF(IBYTES.GT.80) GO TO 1077 GO TO 1004 C-----IF > 40 GO TO ERR. 1014 IF(IBYTES.GT.40) GO TO 1077 GO TO 1004 C-----ERR RETURN, CARD OVERFLOW, PRINT ERROR MSG. 1077 GO TO 1490 C C********************************************************************* C C CALL DISPLAY INFORMATION SCREEN OR PASS TO THE NEXT QUESTION ? C C********************************************************************* C C DISPLAY SCREEN * C 1515 I=IGET1(JFORM,(6+(IQST-1)*IQLN)) IF(I.NE.2HX ) GO TO 1099 IS &CRN=16 GO TO 1002 C C NEXT QUESTION C 1099 IQST=IQST+1 IF(IQST.GT.(IUMAX+IMMAX)) GO TO 1632 ISCRN=11 GO TO 1000 1632 ISCRN=17 GO TO 1002 C C C********************************************************************* C C 2645 SOFT KEYS PROCESSING C C********************************************************************* C C IFLG=5 MEANS NON PRINTABLE ASCII C 3000 IF(IFLG.EQ.4) IFLG=5 IF(IFLG.NE.5) GO TO 3005 CALL MES05(7,NOF) GO TO 15 C C IFLG=6 MEANS ILLEGAL PARSE C 3005 IF(IFLG.NE.6) GO TO 3007 STOP 500 C C IFLG=7 MEANS HELP C 3007 IF(IFLG.NE.7) GO TO 3010 INDIC=-77 GO TO 17 3011 INDIC=0 ILST=0 IF(ISCRN.NE.12) GO TO 3008 IF(ITT.LT.2) IMES=IHP20(NOF) IF(ITT.GT.1) IMES=IHP21(NOF) IF((ITT.EQ.0).AND.(NOF.EQ.4)) ILST=1 IF((ITT.EQ.2).AND.(NOF.EQ.5)) ILST=1 GO TO 3060 3008 IF(ISCRN.NE.13) GO TO 3009 IF(ITT.LT.2) IMES=IHP30(NOF) IF(ITT.GT.1) IMES=IHP31(NOF) IF((ITT.EQ.0).AND.(NOF.EQ.3)) ILST=1 IF((ITT.EQ.2).AND.(NOF.EQ.4)) ILST=1 GO TO 3060 3009 IF(ITT.LT.2) IMES=IHP40(NOF) IF(ITT.GT.1) IMES=IHP41(NOF) IF((ITT.EQ.2).AND.(NOF.EQ.4)) ILST=1 3060 CALL HLP05(IMES,NOF,ILST) GO TO 15 C C IFLG=8 MEANS LAST SCREEN C 3010 IF(IFLG.NE.8) GO TO 3040 IF(ISCRN.NE.11) GO TO 3020 IF(IQST.NE.1) GO TO 3012 ISCRN=10 GO TO 3016 3012 IQST=IQST-1 I=IGET1(JFORM,(6+(IQST-1)*IQLN),1) IF(I.NE.2HX ) GO TO 3014 ISCRN=16 GO TO 3016 3014 I=JFORM(34+(IQST-1)*(IQLN/2)) IF(I.EQ.3) ISCRN=15 IF(I.EQ.0) ISCRN=14 IF(I.EQ.2) ISCRN=13 IF(I.EQ.1) ISCRN=12 3016 IF(ISCRN.GT.13) GO TO 1002 GO TO 1000 3020 IF((ISCRN.LT.12).OR.(ISCRN.GT.15)) GO TO 3022 ISCRN=11 GO TO 3016 3022 IF(ISCRN.EQ.16) GO TO 3014 IF(ISCRN.EQ.17) GO TO 3012 ISCRN=ISCRN-1 GO TO 3016 C C CALL NEXT SCR640EEN C 1000 CALL EXEC(8,JNAM) 1002 CALL EXEC(8,KNAM) C C ABORT PROGRAM C 3040 IF(.NOT.(OKABT(ILU))) GO TO 17 INDIC=99 CALL EXEC(8,LNAM) C C END OF SEGMENT C CALL TGP C C END END$ 9+6  92903-18361 1805 S C0122 &MES05              H0101 ^ASMB,R NAM MES05,7 92903-16361 REV.1805 780501 * * SOURCE 92903-18361 * SPC 2 ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** SPC 2 SUP * ********************************************************************** * * * THIS SUBROUTINE IS CALLED BY THE SEGMENT ANSW1 * * OF THE FORMG PROGRAM TO WRITE AN ERROR MESSAGE ON THE TERMINAL. * * THE ERROR MESSAGE IS PRINTED ON LINE 24 OF THE * * SCREEN AND THE CURSOR IS MOVED TO THE WRONG FIELD. * * THIS SUBROUTINE IS CALLED WITH TWO PARAMETERS : * * * * - PAR#1 = ERROR MESSAGE # TO OUTPUT * * - PAR#2 = WRONG FIELD # ON THE SCREEN * * * ********************************************************************** * * ENT MES05 ENTRY POINT EXT EXEC EXT .ENTR EXT &REMP EXT &MVW COM ILU TERM. LU * * GET CALLING PARAMETERS AND INITIALISE * NMESS NOP FIRST PARM. ADDRESS NOF NOP SECD. PARM. ADDRESS MES05 NOP ENTRY POINT JSB .ENTR SUBR. TO GET DEF NMESS PARM. ADDRESS LDA BUFAD INITIALIZE LDB SPACE ERROR MESSAGE JSB &REMP BUFFER DEC -35 TO BLANK LDA BUFA1 INITIALIZE LDB NULL TAB BUFFER JSB &REMP TO NULL DEC -50 * * MOVE ERROR MESSAGE IN OUTPUT BUFFER * c LDA NMESS,I GET ERROR MESSAGE # ADA AMES0 COMPUTE MESSAGE LDB A,I ADDRESS STB P1 STORE IT CMB,INB MINUS STARTING ADDRESS STB IST OF MESSAGE IN IST INA COMPUTE NEXT MESSAGE LDA A,I STARTING ADDRESS ADA IST COMPUTE MESSAGE LENGTH STA P2 STORE IT LDA P1 BUFFER SOURCE ADDRESS LDB BUFAD BUFFER DEST ADDRESS JSB &MVW MOVE WORDS P2 NOP BUFFER LENGTH * * INCLUDE # OF NECESSARY TABS * LDA NOF,I GET WRONG FIELD # CMA,INA MAKE IT NEG. ISZ A INCREMENT: IS FIRST FIELD ? RSS NO JMP WRIT YES OUTPUT BUFFER STA P3 STORE NEG. # OF TABS LDA BUFA1 TAB BUFFER ADDRESS LDB TAB TAB JSB &REMP INCLUDE TABS P3 NOP IN BUFFER * * WRITE MESSAGE * WRIT JSB EXEC WRITE EXEC CALL DEF *+5 RETURN POINT DEF D.2 CODE EXEC DEF ILU CONTROL WORD DEF BUF BUFFER LOCATION DEF ILN BUFFER LENGTH * * RETURN TO CALLING PROGRAM * JMP MES05,I * * BUFFER DATA * BUF BYT 33,130,33,46,141,62,62,162,60,103 FORMAT OFF:POS.CURSOR BYT 33,112,15,12,40,0 CLEAR DISP CR,LF BYT 33,46,144,103 INVERSE VIDEO BLINKING ASC 2,ERRO BYT 122,33,46,144,100 END ENHANCEMENT ASC 2, : BUFER BSS 35 MESSAGE BUFFER BYT 33,127,33,110 FORMAT ON * HOME CURSOR BUF1 BSS 50 TAB BUFFER BYT 33,142 KEYBOARD ENABLE EBUF BYT 0,137 SUPPRESS , * * STORAGE , CONSTANTS .. * BUFAD DEF BUFER BUFF. ADDRESS BUFA1 DEF BUF1 TAB BUFFER ADDRESS A EQU 0 A REGISTER STAD EQU BUF BUFFER STARTING ADDRESS LTAD EQU EBUF BUFFER LAST ADDRESS IST NOP P1 NOP SOURCE ADDRESS BUFFER ADDRESS ILN ABS LTAD-STAD+1 BUFFER LENGTH SPACE BYT r40,40 NULL BYT 0,0 TAB BYT 33,111 D.2 DEC 2 * * MESSAGE ADDRESS * AMES0 DEF AMES1-1 AMES1 DEF MES1 DEF MES2 DEF MES3 DEF MES4 DEF MES5 DEF MES6 DEF MES7 DEF MES8 DEF MES9 DEF MES10 DEF MES11 DEF MES12 DEF MES13 DEF MES14 DEF MES15 DEF MES16 DEF MES17 DEF MES18 DEF MES19 DEF MES20 DEF MES21 DEF MES22 DEF MES23 DEF MES24 DEF MES25 * * MESSAGE STORAGE * MES1 ASC 12,Field must be blank or X MES2 ASC 11,Illegal modulo number MES3 ASC 11,Illegal string length MES4 ASC 10,Answer R,L or blank MES5 ASC 22,Arithmetic functions have not been selected MES6 ASC 19,No key assigned to NEXT ENTRY function MES7 ASC 12,Illegal character input MES8 ASC 10,Illegal upper limit MES9 ASC 10,Illegal lower limit MES10 ASC 22,Upper limit must be greater than lower limit MES11 ASC 23,The answer type being D the maximum string len ASC 11,gth cannot be modified MES12 ASC 23,Mask length greater than maximum string length MES13 ASC 23,Default string defined in previous screen too ASC 2,long MES14 ASC 23,To use NEXT ENTRY a find in a detail data set ASC 11,must have been defined MES15 ASC 22,NEXT ENTRY cannot be defined in a U question MES16 ASC 23,Too many characters have been specified for th ASC 4,is card MES17 ASC 23,Image card input--user written module required MES18 ASC 22,Image card input--string length must be even MES19 ASC 16,Image card input--'R' is illegal MES20 ASC 17,Image card input--mask not allowed MES21 ASC 21,Image card input--limit check not allowed MES22 ASC 15,Image card input--not allowed MES23 ASC 6,Not allowed MES24 ASC 17,Not allowed with card reader input MES25 ASC 1,-1 * * END MES05   92903-18362 1805 S C0122 &HLP05              H0101 fyASMB,R NAM HLP05,7 92903-16362 REV.1805 770810 * * SOURCE 92903-18362 * SPC 2 ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** SPC 2 SUP * ********************************************************************** * * * THIS SUBROUTINE IS USED TO PRINT A HELP MESSAGE * * ON LINES 23 AND 24 OF THE TGP SCREENS * * THE CURSOR IS POSITIONEDAT THE FIELD WHERE THE * * HELP SOFT KEY WAS PRESSED. * * THIS SUBROUTINE IS CALLED WITH TWO PARAMETERS : * * * * - PAR#1 = HELP MESSAGE # TO OUTPUT * * - PAR#2 = HELP FIELD # ON THE SCREEN * * * ********************************************************************** * * ENT HLP05 ENTRY POINT EXT EXEC EXT .ENTR EXT &REMP EXT &MVW COM ILU TERM. LU * * GET CALLING PARAMETERS * NMESS NOP FIRST PARM. ADDRESS NOF NOP SECD. PARM. ADDRESS ILST NOP THIRD PARAM ADDRESS HLP05 NOP ENTRY POINT JSB .ENTR SUBR. TO GET DEF NMESS PARM. ADDRESS * * * MOVE HELP MESSAGE IN OUTPUT BUFFER * LDA NMESS,I GET ERROR MESSAGE # SZA,RSS IS 0 ? JMP HLPC YES NO MESSAGE ADA AMES0 COMPUTE MESSAGE LDB A,I ADDRESS STB P1 STORE IT CMB,INB MINUS STARTING ADDRESS STB IST OF MESSAGE IN IST INA COMPUTE NEXT MESSAGE LDA A,I STARTING ADDRESS ADA IST COMPUTE MESSAGE LENGTH STA P2 STORE IT LDA P1 BUFFER SOURCE ADDRESS LDB BUFAD BUFFER DEST ADDRESS JSB &MVW MOVE WORDS P2 NOP BUFFER LENGTH * LDB BUFAD COMPUTE CURRENT ADB P2 ADDRESS IN OUTPUT BUFFER * LDA BUF1 INCLUDE FORMAT ON STA B,I IN OUTPUT BUFFER INB INCREMENT ADDRESS IN OUT. BUFFER * LDA D.10 COMPUTE OUTPUT BUFFER LENGTH ADA P2 STA ILN STORE IT JMP HLPB * HLPC LDA D.10 STA ILN LDB BUFAD LDA BUF1 STA B,I INB * * NOW INCLUDE TABS IN BUFFER * HLPB LDA NOF,I GET HELP FIELD # CPA D.1 IS 1 ? JMP HLPA YES NO TABS ADA .D1 DECREMENT STA P5 STORE # OF FIELD ADA ILN INCREMENT OUTPUT BUFFER STA ILN LENGTH LDA P5 GET FIELD # CMA,INA MAKE IT NEG STA P4 LDA B STB P2 SORE B LDB TAB JSB &REMP MOVE TABS IN BUFFER P4 NOP * LDB P2 RESTORE B LDA P5 INCREMENT ADDRESS IN ADB A * HLPA LDA ILST,I IS LAST FIELD IN SCREEN ? SZA JMP HPLD NO LDA BUFA2 YES RSS SKIP HPLD LDA BUFA3 JSB &MVW INCLUDE KEY ENABLE DEC 3 IN BUFFER * JSB EXEC WRITE MESSAGE DEF *+5 DEF D.2 DEF ILU DEF BUF DEF ILN * JMP HLP05,I * * * BUFFER DATA * BUF BYT 33,130,33,46,141,62,62,162,60,103 FORMAT OFF:POS.CURSOR BYT 33,112 CLEAR DISPLAY BUFER BSS 140 MESSAGE BUFFER * * STORAGE , CONSTANTS .. * BUFAD DEF BUFER BUFF. ADDRESS BUFA2 DEF BUF2 BUFA3 DEF BUF3 A EQU 0 A REGISTER B EQU 1 B REGISTER IST NOP P1 NOP SOURCE ADDRESS BUFFER ADDRESS P5 NOP ILN NOP BUFFER LENGTH TAB BYT 33,111 BUF1 BYT 33,127 FORMAT ON BUF2 BYT 0,0,0,33,142,137 ERASE h,KEY. ENABLE BUF3 BYT 0,0,33,142,0,137 CLEAR DISP,KEY. ENABLE .D1 DEC -1 D.10 DEC 10 D.1 DEC 1 D.2 DEC 2 * * MESSAGE ADDRESS * AMES0 DEF AMES1-1 AMES1 DEF MES1 DEF MES2 DEF MES3 DEF MES4 DEF MES5 DEF MES6 DEF MES7 DEF MES8 * * MESSAGE STORAGE * * MES1 BYT 33,46,144,112 ASC 22, When the value is entered on the HP3070 ter ASC 18,minals it is subsequently divided by BYT 33,46,144,112 ASC 22, the modulo number(if any) : An error occurs ASC 18, if the remainder is not zero. * MES2 BYT 33,46,144,112 ASC 22, Aritmetic operations may be performed local ASC 18,ly before entering the answer if the BYT 33,46,144,112 ASC 22, arithmetic operators are defined and enable ASC 10,d for this question. BYT 33,46,141,53,61,66,103,0 POSITION CURSOR - 81 * MES3 BYT 33,46,144,112 ASC 22, When the NEXT ENTRY key is pressed as answe ASC 18,r to the question the current entry BYT 33,46,144,112 ASC 22, in the chain is ignored and the next entry ASC 6,is fetched. BYT 33,46,141,53,62,64,103,0 POSITION CURSOR - 81 * MES4 BYT 33,46,144,112 ASC 22, This is the name of the user written valida ASC 18,tion subroutine to which the answer BYT 33,46,144,112 ASC 22, to the question is passed by the Transactio ASC 9,n Monitor Program. BYT 33,46,141,53,61,70,103,0 POSITION CURSOR - 81 * MES5 BYT 33,46,144,112 ASC 22, The maximum string length accepted is 126. ASC 18,This field is automatically filled BYT 33,46,144,112 ASC 22, by the program if the answ er is related to ASC 9,a data base item. BYT 33,46,141,53,61,70,103,0 POSITION CURSOR - 81 * MES6 BYT 33,46,144,112 ASC 22, As on a punched card a string may be positi ASC 18,onned on the storage media at the BYT 33,46,144,112 ASC 22, beginning (L) or at the end (R) of the fiel ASC 9,d reserved for it. BYT 33,46,141,53,61,70,103,0 POSITION CURSOR - 81 * MES7 BYT 33,46,144,112 ASC 22, For example if the mask is 99-999A the answ ASC 18,er must be 2 digits followed by - BYT 33,46,144,112 ASC 22, followed by 3 digits followed by an alphabe ASC 7,tic character. BYT 33,46,141,53,62,62,103,0 POSITION CURSOR - 81 * MES8 ASC 1,-1 * * * END HLP05   92903-18363 1805 S C0122 &TGP6              H0101 hpFTN4 PROGRAM TGP6(5), 92903-16363 REV.1805 780512 C C SOURCE 92903-18363 C C C C ************************************************************** C * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * C ************************************************************** C C C C C C PRGMR : JEAN CHARLES MIARD (HPG) C C********************************************************************* C* * C* THIS IS A SEGMENT OF THE TGP PROGRAM USED TO * C* ANALYZE THE ANSWERS THE USER HAS GIVEN IN THE SCREENS 14,15 * C* 16 AND 17 . * C* THE ANSWERS AFTER A CHECK ARE STORED IN JFORM , * C* MFORM AND LFORM . * C* * C* FOLLOWING ARE THE DIFFERENT WAYS TO EXECUTE THIS * C* SEGMENT ACCORDING TO INDIC VALUE : * C* * C* INDIC = 0 : NORMAL PATH . ANALYSE ISCRN SCREEN ANSWERS . * C* OR COMING FROM TGP12 AN ERROR HAS OCCURED IN * C* IMAGE PROCESSING ( DISPLAY, DELETE,SYSTEM * C* ADDED INFO,IMAGE EDITS) . * C* = 2 : RETURN FROM TGP12 . SYSTEM ADDED INFO TO * C* BE INCLUDED IN IMAGE DATA BASE HAS BEEN * C* SUCCESSFULY PROCESSED . * C* = 4 : RETURN FROM TGP12 . IMAGE DELETE OPERATION * C* SUCCESSFULLY PROCESSED . * C* Kg = 5 : RETURN FROM TGP12 . IMAGE DISPLAY SUCCESS- * C* FULLY PROCESSED . * C* = 8 : ERR RETURN FROM TGP7 WHILE COMPILING INTO KFORM * C =-77 : A HELP MESSAGE MUST BE PRINTED * C* * C* WARNING !! : CARE MUST BE TAKEN * : * C* * C* PRINTED SCREEN # 14 CORRESPONDS TO ISCRN = 15 * C* ............... 15 .................... 16 * C* ............... 16 .................... 17 * C* ............... 17 ..................... 18 * C* * C********************************************************************* C C C DECLARATIONS COMMON VARIABLES ************** C COMMON ILU,ISCRN,IQST,ISKIP,INDIC COMMON IFORM(494) COMMON JFORM(980) COMMON MFORM(16) COMMON LFORM(39) COMMON ITT COMMON IKEY(11,3) COMMON IUMAX,IMMAX COMMON IMODB COMMON ILITE(15) COMMON IMAI(45,5) COMMON IMFLG,IMAS,IMDT,IMKY COMMON KFORM(1065) COMMON ILIBR(61) COMMON NIMAG C C LOCAL VARIABLES ************** C DIMENSION JNAM(3),ILNGT(4,4) DIMENSION JOUT(10),KNAM(3),LNAM(3),INAM(3),NNAM(3) DIMENSION IHP5(3),IHP60(3),IHP61(6),IHB60(4),IHB61(7),IHP7(3) DIMENSION IHP8(5),IBUF(12) C LOGICAL JPAR,ISBIT,NAMCK,GETBK,OKABT C EQUIVALENCE(JOUT,KFORM(1000)) EQUIVALENCE(NOF,KFORM(1015)),(IFLG,KFORM(1016)) EQUIVALENCE(IFLG1,KFORM(1017)),(IFLG2,KFORM(1018)) EQUIVALENCE(JVAL3,KFORM(1019)),(JVAL4,KFORM(1020)) EQUIVALENCE(ISTAT,KFORM(1021)),(JOUT1,KFORM(1022)) C C DATA VALUES : C DATA IQLN/98/ DATA JNAM/2HTG,2HP3,2H / DATA KNAM/2HTG,2HP4,'2H / DATA LNAM/2HTG,2HP7,2H / DATA INAM/2HTG,2HPI,2H2 / DATA NNAM/2HTG,2HP1 ,2H / DATA IHP5/1,14,2/ DATA IHP60/3,4,7/ DATA IHP61/3,4,5,0,6,7/ DATA IHB60/3,4,0,7/ DATA IHB61/3,4,0,5,0,6,7/ DATA IHP7/0,8,0/ DATA IHP8/10,10,11,12,13/ DATA ILNGT/0,1,5,5,0,27,22,34,7,7,7,7,27,33,27,33/ C C********************************************************************* C C ACCORDING TO INDIC VALUE GO TO THE REQUIRED PORTION OF TGP6 C C********************************************************************* C IF(INDIC.EQ.4) GO TO 1512 IF(INDIC.EQ.5) GO TO 1640 IF(INDIC.EQ.2) GO TO 1925 IF(INDIC.EQ.7) PAUSE 0606 C-----ERR RETURN FROM TGP7 IF(INDIC.EQ.8) GO TO 1775 IF(INDIC.EQ.-77) GO TO 3011 C C********************************************************************* C C INDIC = 0 GET THE ANSWERS IN THE SCREEN C C********************************************************************* C ISTAT=0 15 I=ITT+1 J=ISCRN-14 ITLOG=ILNGT(I,J) IF((ISCRN.EQ.16).AND.(IMODB.EQ.1)) ITLOG=ITLOG+2 IF((ISCRN.NE.17).OR.(ITT.LT.2)) GO TO 12 IF(IAND(IMFLG,100000B).EQ.100000B) ITLOG=43 12 IF(.NOT.(GETBK(ILU,KFORM,ITLOG))) GO TO 10 C C ERROR IN GETTING ANSWERS REPRINT SCREEN C 17 CALL EXEC(8,KNAM) C C********************************************************************* C C GO TO ANALYSE USER ANSWERS TO SCREEN # ISCRN C C********************************************************************* C 10 I=ISCRN-14 GO TO(1500,1600,1900,1700) I C C*********************************************************************** C C SCREEN 14 "FUNCTON ONLY EDITS" C C********************************************************************** C C C C RESET IMAGE FLAGS AND BUFFERS C 1500 NOF=1 N=2*IQST-1 CALL ERFLG(N,IMAI,IMKY,IMFLG,IMAS,IMDT) C C CONTINUE TO THE NEXT QUESTION * CHECK ANSWER IS BLANK OR X , IF C X CHECK CONTINUE IS DEFINED C 1501 IF(JPAR(KFORM,ITLOG,NOF,JOUT,1,IFLG,JVAL)) GO TO 3000 IF((IFLG.NE.0).AND.(JOUT(1).NE.2HX )) GO TO 1184 IFLG1=IFLG IF(IFLG.EQ.0) GO TO 1504 I=IGET1(JFORM,(6+(IQST-1)*IQLN)) IF(I.EQ.2H ) GO TO 1586 DO 1502 I=1,11 DO 1502 J=1,3,2 IF(IKEY(I,J).EQ.11) GO TO 1504 1502 CONTINUE GO TO 1584 1504 CALL MOVCA(JOUT,1,JFORM,(31+(IQST-1)*IQLN),1) C C NEXT ENTRY IN AN IMAGE CHAIN (TR.TYPE 2 AND 3) * CHECK ANSWER IS C BLANK OR X , IF X NEXT ENTRY MUST BE DEFINED AND A FIND IN A DETAIL C DATA SET MUST BE DEFINED . C IF(ITT.GT.1) GO TO 1505 CALL BLAN(JFORM,32+(IQST-1)*98,2) GO TO 1515 1505 NOF=NOF+1 IF(JPAR(KFORM,ITLOG,NOF,JOUT,1,IFLG,JVAL)) GO TO 3000 IFLG2=IFLG IF((IFLG.NE.0).AND.(JOUT(1).NE.2HX )) GO TO 1184 IF(IFLG.EQ.0) GO TO 1508 DO 1506 I=1,11 DO 1506 J=1,3,2 IF(IKEY(I,J).EQ.12) GO TO 1507 1506 CONTINUE GO TO 1483 1507 IF(IMDT.EQ.0) GO TO 1484 IF(IQST.LE.IUMAX) GO TO 1487 1508 CALL MOVCA(JOUT,1,JFORM,(32+(IQST-1)*IQLN),1) C C DELETE ENTRY IN DATA BASE (TR,TYPE 2 OR 3 ONLY) C CHECK ANSWER IS BLANK OR X , IF X CHECK DELETE IS DEFINED C AND GO TO TGP12 TO PROCESS THE IMAGE DELETE C NOF=NOF+1 IF(JPAR(KFORM,ITLOG,NOF,JOUT,1,IFLG,JVAL)) GO TO 3000 IF((IFLG.NE.0).AND.(JOUT(1).NE.2HX )) GO TO 1184 IF(IFLG.EQ.0) GO TO 1512 DO 1510 I=1,11 DO 1510 J=1,3,2 IF(IKEY(I,J).EQ.13) GO TO 1511 1510 CONTINUE GO TO 1585 C C GO TO TGP12 TO PROCESS IMAGE DELETE C 1511 IMAI(N,2)=4 INDIC=0 CALL EXEC(8,INAM) C C HERE RETURN FROM TGP12 (DELETE PROCEESED SUCCESFULLY) C 1512 INDIC=0 CALL MOVCA(JOUT,1,JFORM,(33+(IQST-1)*98),1) C C********************************************************************* C C CALL DISPLAY INFORMATION SCREEN ? (SCREENS 11 OR 12 OR 13 OR 14) C OR PROCESS NEXT QUE`STION C C********************************************************************* C C 1515 IF(IFLG1.NE.0) GO TO 1518 IF(ITT.LT.2) GO TO 1486 IF((IFLG.EQ.0).AND.(IFLG2.EQ.0)) GO TO 1486 1518 I=IGET1(JFORM,(6+(IQST-1)*98)) IF(I.NE.2HX ) GO TO 1630 ISCRN=16 GO TO 1002 C C ERROR PROCESSING SCREEN 14 C 1584 CALL MES06(8,NOF) GO TO 15 1585 CALL MES06(9,NOF) GO TO 15 1586 CALL MES06(13,NOF) GO TO 15 1180 CALL MES06(1,NOF) GO TO 15 1181 CALL MES06(2,NOF) GO TO 15 1182 CALL MES06(3,NOF) GO TO 15 1183 CALL MES06(4,NOF) GO TO 15 1184 CALL MES06(5,NOF) GO TO 15 1480 CALL MES06(6,NOF) GO TO 15 1483 CALL MES06(7,NOF) GO TO 15 1484 CALL MES06(24,NOF) GO TO 15 1485 CALL MES06(25,NOF) GO TO 15 1486 CALL MES06(26,NOF) GO TO 15 1487 CALL MES06(19,NOF) GO TO 15 C C********************************************************************* C C SCREEN 15 DISPLAYED INFORMATION C C********************************************************************* C C INDICATOR LIGHT # (CHECK LIGTH # IS LEGAL AND NOT ASSIGNED TO SYSTEM C SAVE LIGHT # IN COMMON (EQUIVALENCE) C C FIRST RESET ILITE BUFFER C 1600 NOF=1 CALL ERLIT(ILITE,-IQST) IF(JPAR(KFORM,ITLOG,NOF,JOUT,2,IFLG,JVAL)) GO TO 3000 JVAL3=JVAL JOUT1=JOUT(1) IF(IFLG.GT.1) GO TO 1180 IF(IFLG.EQ.0) GO TO 1609 IF((JVAL.LT.1).OR.(JVAL.GT.15)) GO TO 1182 IF(ILITE(JVAL).EQ.-99) GO TO 1183 C C INDICATOR LABEL C 1609 NOF=NOF+1 IF(JPAR(KFORM,ITLOG,NOF,JOUT,12,IFLG,JVAL)) GO TO 3000 CALL MOVCA(JOUT,1,JFORM,(71+(IQST-1)*IQLN),12) C C PRINT DISPLAYED VALUE ? (3070B ONLY) C IF(IMODB.EQ.1) GO TO 1608 CALL BLAN(JFORM,89+(IQST-1)*98,1) GO TO 1610 1608 NOF=NOF+1 IF(JPAR(KFORM,ITLOG,NOF,JOUT,1,IFLG,JVAL)) GO TO 3000 IF((IFLG.NE.0).AND.(JOUT(1).NE.2HX )) GO TO 1184 "_ CALL MOVCA(JOUT,1,JFORM,(89+(IQST-1)*IQLN),1) C C USER WRITTEN DISPLAY MODULES (TR.TYPE 1 OR 3 ONLY) C C NAME OF DISPLAY PROGRAM C 1610 IF(ITT.NE.2) GO TO 1611 CALL BLAN(JFORM,93+(IQST-1)*98,5) CALL BLAN(JFORM,90+(IQST-1)*98,1) JFORM(46+(IQST-1)*49)=0 GO TO 1620 1611 NOF=NOF+1 IF(JPAR(KFORM,ITLOG,NOF,JOUT,5,IFLG,JVAL)) GO TO 3000 IF((ITT.EQ.1).AND.(IFLG.EQ.0)) GO TO 1685 IFLG1=IFLG CALL MOVCA(JOUT,1,JFORM,(93+(IQST-1)*IQLN),5) C C DISPLAYED ITEM TYPE (TR.TYPE 1 OR 3 ONLY) C NOF=NOF+1 IF(JPAR(KFORM,ITLOG,NOF,JOUT,1,IFLG,JVAL)) GO TO 3000 IF((IFLG1.NE.0).AND.(IFLG.EQ.0)) GO TO 1684 IF((IFLG1.EQ.0).AND.(IFLG.NE.0)) GO TO 1681 JVAL=-1 IF(IFLG.EQ.0) GO TO 1612 IF(JOUT.EQ.2HS ) JVAL=0 IF(JOUT.EQ.2HI ) JVAL=1 IF(JOUT.EQ.2HR ) JVAL=2 IF(JVAL.EQ.-1) GO TO 1680 C C CHECK DEFAULT =DISPLAY VALUES ARE OF SAME TYPE C IFL1=0 IF(IGET1(JFORM,23+(IQST-1)*98).NE.2HX ) GO TO 1612 JVAL1=JFORM(34+(IQST-1)*49) IF(JVAL1.EQ.3) GO TO 1612 IF(JVAL.NE.JVAL1) GO TO 1688 IF(JVAL.EQ.0) IFL1=1 1612 JVAL1=JVAL CALL MOVCA(JOUT,1,JFORM,(90+(IQST-1)*IQLN),1) C C STRING LENGTH (TR TYPE 1 OR 3 ONLY ) C NOF=NOF+1 IF(JPAR(KFORM,ITLOG,NOF,JOUT,3,IFLG,JVAL)) GO TO 3000 IF(IFLG.GT.1) GO TO 1480 IF((JVAL1.NE.0).AND.(IFLG.NE.0)) GO TO 1681 IF((JVAL1.EQ.0).AND.(IFLG.EQ.0)) GO TO 1480 IF(IFLG.EQ.0) JVAL=0 IF(IFLG.EQ.0) GO TO 1616 IF(IFL1.EQ.0) GO TO 1615 IF(JFORM(16+(IQST-1)*49).NE.JVAL) GO TO 1689 1615 IF((JVAL.LT.1).OR.(JVAL.GT.126)) GO TO 1480 1616 JFORM(46+(IQST-1)*49)=JVAL C C IMAGE ITEM NAME ( TR. TYPE 2 OR 3 ONLY) C 1620 IF(ITT.NE.1) GO TO 1621 CALL BLAN(JFORM,83+(IQST-1)*98,6) GO TO 1631 1621 NOF=NOF+1 IF(JPAR(KFORM,ITLOG,NOF,JOUT,6,IFLG,JVAL)) GO TO 3000 IF((ITT.EQ.2).AND.(IFLG.EQ.0)) GO TO 1683  IF(ITT.NE.3) GO TO 1617 IF((IFLG.NE.0).AND.(IFLG1.NE.0)) GO TO 1686 IF((IFLG.EQ.0).AND.(IFLG1.EQ.0)) GO TO 1687 1617 CALL MOVCA(JOUT,1,JFORM,(83+(IQST-1)*IQLN),6) C C C CALL TGP12 TO PROCESS IMAGE DISPLAY C 1631 IF((IFLG1.NE.0).AND.(ITT.NE.2)) GO TO 1650 IMAI(2*IQST,2)=5 INDIC=0 CALL EXEC(8,INAM) C C RETURN FROM TGP12 . IMAGE DISPLAY SUCCESSFULLY PROCESSED C C CHECK IF DISPLAYED VALUE=DEFAULT VALUE : C -ITEMS ARE OF SAME TYPE C -STRINGS OF SAME LENGTH C 1640 INDIC=0 IF(IGET1(JFORM,23+(IQST-1)*98).NE.2HX ) GO TO 1642 IX=JFORM(34+(IQST-1)*49) IF(IX.EQ.3) GO TO 1650 IY=IAND(IMAI(2*IQST,2),30000B)/4096 IF(IX.NE.IY) GO TO 1688 IF(IX.NE.0) GO TO 1650 IF(IAND(IMAI(2*IQST,4),377B).NE.JFORM(16+(IQST-1)*49)) GO TO 1689 C-----IS THIS A DISPLAY ITEM? 1642 IF(IGET1(JFORM,6+(IQST-1)*98).NE.2HX ) GO TO 1650 C-----YES, STORE THE IMAGE ITEM LENGTH. JFORM(46+(IQST-1)*49)=IAND(IMAI(2*IQST,4),377B) C C ASSIGN LIGHT # NOW FOR THIS DISPLAY IF LIGHT ALREADY USED C ISSUE A WARNING . C 1650 CONTINUE 1654 IQ=-IQST IF(ISTAT.EQ.0) GO TO 1632 IF(JVAL3.NE.JVAL4) ISTAT=0 1632 CALL LIGHT(IQ,JVAL3,JOUT1,ISTAT,JFORM,ILITE) IF(ISTAT.EQ.0) GO TO 1630 IF(ISTAT.EQ.-1) GO TO 1181 CALL WARN(ILITE(JVAL3),1) ISTAT=1 JVAL4=JVAL3 GO TO 15 C C*********************************************************************** C C GO TO PROCESS NEXT QUESTION C C*********************************************************************** C 1630 IQST=IQST+1 IF(IQST.GT.(IUMAX+IMMAX)) GO TO 1634 ISCRN=11 GO TO 1000 1634 ISCRN=17 GO TO 1002 C C ERROR PROCESSING SCREEN 15 C 1680 CALL MES06(10,NOF) GO TO 15 1681 CALL MES06(11,NOF) GO TO 15 1683 CALL MES06(27,NOF) GO TO 15 1684 CALL MES06(28,NOF) GO TO 15 1685 CALL MES06(29,NOF) GO TO 15 1686 CALL MES06(33,3+IMODB) GO TO 15 1687 CALL MES06(34,3+IMODB) GO TO 15 1688 CALL MES06(14,NOF) GO TO 15 1689 CALL MES06(16,NOF) GO TO 15 C C*********************************************************************** C C SCREEN 16 ( SYSTEM ADDED INFORMATION ) C C********************************************************************** C 1900 NOF=1 DO 1920 I=1,4 C C X IF NEEDED C IF(JPAR(KFORM,ITLOG,NOF,JOUT,1,IFLG,JVAL)) GO TO 3000 IF((JOUT.NE.2H ).AND.(JOUT.NE.2HX )) GO TO 1184 IFLG1=IFLG NOF=NOF+1 CALL MOVCA(JOUT,1,MFORM,I,1) C C IMAGE ITEM NAME (ONLY IF IMAGE STORAGE) C IF(ISBIT(IMFLG,15)) GO TO 1908 CALL BLAN(MFORM,6*I-1,6) CALL BLAN(MFORM,28+I,1) GO TO 1920 1908 IF(JPAR(KFORM,ITLOG,NOF,JOUT,6,IFLG,JVAL)) GO TO 3000 IF((IFLG.NE.0).AND.(IFLG1.EQ.0)) GO TO 1681 IFLG2=IFLG NOF=NOF+1 CALL MOVCA(JOUT,1,MFORM,(6*I-1),6) C C IMAGE OPERATION CODE U OR A C IF(JPAR(KFORM,ITLOG,NOF,JOUT,1,IFLG,JVAL)) GO TO 3000 IF((IFLG.NE.0).AND.(IFLG2.EQ.0)) GO TO 1681 IF((IFLG.EQ.0).AND.(IFLG2.NE.0)) GO TO 1980 IF(IFLG.EQ.0) GO TO 1910 IF((JOUT(1).NE.2HA ).AND.(JOUT(1).NE.2HU )) GO TO 1980 1910 NOF=NOF+1 CALL MOVCA(JOUT,1,MFORM,(28+I),1) 1920 CONTINUE C C IF STORAGE IMAGE CALL TGP12 FOR IMAGE PROCESSING C IF(.NOT.(ISBIT(IMFLG,15))) GO TO 1930 INDIC=-8 CALL EXEC(8,INAM) C C RETURN FROM TGP12 (INFORMATION SUCCESSFULLY PROCESSED) C 1925 INDIC=0 C C CALL SCREEN 17 C 1930 ISCRN=18 GO TO 1002 C C ERROR SECTION SCREEN 16 C 1980 CALL MES06(30,NOF) GO TO 15 C C************************************************************************ C C SCREEN 17 (DATA STORAGE DEFINITION) C C************************************************************************ C C FILE NAME # 1 C 1700 NOF=1 IF(JPAR(KFORM,ITLOG,NOF,JOUT,6,IFLG,JVAL)) GO 0TO 3000 IFLG1=IFLG IF(IFLG.EQ.0) GO TO 1702 IF(NAMCK(JOUT)) GO TO 1788 IFLG1=1 1702 CALL MOVEW(JOUT,LFORM,3) C C FILE NAME # 2 C NOF=NOF+1 IF(JPAR(KFORM,ITLOG,NOF,JOUT,6,IFLG,JVAL)) GO TO 3000 IFLG2=IFLG IF(IFLG.EQ.0) GO TO 1704 IF(NAMCK(JOUT)) GO TO 1788 IFLG2=1 1704 CALL MOVEW(JOUT,LFORM(4),3) C C C CR # ? C NOF=NOF+1 IF(JPAR(KFORM,ITLOG,NOF,JOUT,6,IFLG,JVAL)) GO TO 3000 IF((IFLG.NE.0).AND.(IFLG2.EQ.0)) GO TO 1782 IF(IFLG.GT.1) GO TO 1783 IF(JVAL.EQ.-32768) GO TO 1783 CALL MOVEW(JOUT,LFORM(7),3) C C FILE SECURITY CODE C NOF=NOF+1 IF(JPAR(KFORM,ITLOG,NOF,JOUT,6,IFLG,JVAL)) GO TO 3000 IF((IFLG.NE.0).AND.(IFLG2.EQ.0)) GO TO 1781 IF(IFLG.GT.1) GO TO 1787 IF(JVAL.EQ.-32768) GO TO 1783 CALL MOVEW(JOUT,LFORM(10),3) C C STORAGE PROGRAM ? C IF((ITT.EQ.0).OR.(ITT.EQ.2)) GO TO 1710 NOF=NOF+1 IF(JPAR(KFORM,ITLOG,NOF,JOUT,5,IFLG,JVAL)) GO TO 3000 IF(IFLG.EQ.0) GO TO 1712 IFLG=1 1712 CALL MOVCA(JOUT,1,LFORM,25,5) 1710 IF((IFLG+IFLG1+IFLG2.EQ.0).AND.(ITT.LT.2)) GO TO 1786 IF((ITT.EQ.0).OR.(ITT.EQ.2)) CALL BLAN(LFORM,25,5) C C IF TR TYPE >1 INSERT IMAGE EDITS C 1715 IF(ITT.LT.2) GO TO 1720 C C********************************************************************** C C B U I L D I M A G E E D I T S . C C********************************************************************** C C GENERATES IMAGE EDIT FOR ADD OPERATION ONLY FOR KEY ITEMS C IF(.NOT.(ISBIT(IMFLG,0))) GO TO 1300 C IADDS=0 DO 1200 I=1,45 K=IAND(IMAI(I,2),7) IF(K.NE.2) GO TO 1200 C-----THIS IS A ADD, KEY ITEM ? IF(.NOT.(ISBIT(IMAI(I,2),3))) GO TO 1200 C-----YES, IT IS A KEY ITEM, MASTER/DETAIL DATA SET ? IF(.NOT.(ISBIT(IMAI(I,2),15))) GO TO 1150 C C ADD IN A MASTER DATA SET: C GENERATE (IMAGE EDIT CODE=2 + LOCK) FOR THE KEY ITEM C IMAI(I,2)=IOR(IMAI(I,2),2200B) IMAI(I,3)=IOR(IMAI(I,3),IALF2(IMAI(I,3))) GO TO 1200 C C ADD IN DETAIL DATA SET: C RETREIVE THE MASTER DATA SET INVOLVE TO GENERATE CORRECT EDIT C 1150 K=IAND(IMAI(I,1),377B) IADDS=1 C-----RETREIVE MASTER DS# FROM THE KEY ITEM # CALL DBINF(2HS ,4,K,IBUF) IF(IBUF.NE.0) PAUSE 0653 N=IBUF(3) C-----RETREIVE MASTER DATA SET CHARACTERISTICS CALL DBINF(2HS ,2,N,IBUF) IF(IBUF.NE.0) PAUSE 0653 C-----IF AUTOMATIC MASTER, FORGET IMAGE EDIT IF(IGET1(IBUF,10).EQ.1HA) GO TO 1200 C C MASTER IS MANUAL, IF NO ADD IS DEFINED ON THIS MASTER DATA SET C GENERATE (IMAGE EDIT CODE=1 + LOCK) FOR KEY ITEM, C IF ADD IS DEFINED, DO NOT MODIFY THE IMAGE EDIT C DO 1160 J=1,45 K1=IAND(IMAI(J,3),377B) IF(K1.NE.N) GO TO 1160 K2=IAND(IMAI(J,2),7) IF(K2.EQ.2) GO TO 1200 1160 CONTINUE C-----NO ADD ON THIS MASTER DS, GENERATE (CD=1 + LRB) C THE ITEM IN THE MASTER IMAI(I,2)=IOR(IMAI(I,2),2100B) IMAI(I,3)=IOR(IMAI(I,3),IALF2(N)) 1200 CONTINUE C C IMAGE FIND EDITS C C EDIT ONLY ON FIRST ITEM FIND (KEY) C 1300 IF(.NOT.(ISBIT(IMFLG,1))) GO TO 1380 DO 1310 I=1,40 K=IAND(IMAI(I,2),7) IF((K.EQ.0).AND.(IMAI(I,1).NE.0)) GO TO 1320 1310 CONTINUE STOP 70 C C FIND IN MASTER C CODE EDIT 1 + LOCK IF UPDATE, DELETE OR ADD IN ANY DETAIL C 1320 IF(IMDT.NE.0) GO TO 1330 IMAI(I,2)=IOR(IMAI(I,2),100B) M=IAND(IMFLG,14B)+IADDS IF(M.NE.0) IMAI(I,2)=IOR(IMAI(I,2),2000B) IMAI(I,3)=IOR(IMAI(I,3),IALF2(IMAI(I,3))) GO TO 1370 C C DETAIL SEARCH WITH NO MASTER INVOLVED C C CODE EDIT 4 + LOCK C C FLAG MASTER KEY ITEM C 1330 IF(IMAS.NE.0) GO TO 1340 IMAI(I,2)=IOR(IMAI(I,2),2420B) IMAI(I,3)=IOR(IMAI(I,3),IALF2(IMDT)) IMAI(I,1)=IOR(IMAI(I,1),IALF2(IMAI(I,1))) GO\ TO 1365 C C DETAIL SEARCH WITH MASTER DATA SET INVOLVED C C CODE EDIT 4 + LOCK C 1340 IMAI(I,2)=IOR(IMAI(I,2),2420B) IMAI(I,3)=IOR(IMAI(I,3),IALF2(IMDT)) C C SEARCH DETAIL DATA SET KEY ITEM RELATED TO THIS MASTER C C K IS MASTER DATA SET KEY ITEM # C K=IAND(IMAI(I,1),377B) CALL DBINF(2HS ,4,K,IBUF) IF(IBUF.NE.0) PAUSE 0653 DO 1350 J=1,IBUF(2) IF(IBUF(2*J+1).EQ.IMDT) GO TO 1360 1350 CONTINUE STOP 71 1360 IMAI(I,1)=IOR(IMAI(I,1),IALF2(IBUF(2*J+2))) C C FOR OTHER KEY ITEMS FIND EDIT 4+LOCK C 1365 DO 1368 J=I+1,40 K=IAND(IMAI(J,2),7) IF((K.NE.0).OR.(IMAI(J,1).EQ.0)) GO TO 1368 IF(.NOT.(ISBIT(IMAI(J,2),3))) GO TO 1368 IMAI(J,2)=IOR(IMAI(J,2),2400B) IMAI(J,3)=IOR(IMAI(J,3),IALF2(IMDT)) IMAI(J,1)=IOR(IMAI(J,1),IALF2(IMAI(J,1))) 1368 CONTINUE C C SET RESTORE RUN TABLE FLAG C IMAI(2*IUMAX-1,2)=IOR(IMAI(2*IUMAX-1,2),40B) C C SET FAF BUFFER FLAG C K=2*(IUMAX+1)-1 IMAI(K,2)=IOR(IMAI(K,2),1000B) C C DELETE EDITS C C ONLY IF DELETE IN MASTER DATA SET = CODE EDIT 3 + LOCK C C 1370 IF(.NOT.(ISBIT(IMFLG,2))) GO TO 1380 IF(IMDT.NE.0) GO TO 1380 DO 1378 I=1,40 K=IAND(IMAI(I,2),7) IF(K.NE.4) GO TO 1378 IMAI(I,2)=IOR(IMAI(I,2),2300B) IMAI(I,3)=IOR(IMAI(I,3),IALF2(IMAS)) C C MEDIA RECORD LENGTH C J=255 DO 1372 L=1,255 CALL DBINF(2HI ,2,L,IBUF) IF(IBUF.EQ.125) GO TO 1375 IF(IBUF.NE.0) PAUSE 0653 IF(IBUF(9).NE.IMAS) GO TO 1372 IF(IBUF(8).LT.J) J=IBUF(8) 1372 CONTINUE 1375 IMAI(I,1)=IOR(IMAI(I,1),IALF2(J-1)) 1378 CONTINUE C C SET/CLEAR LOCK BIT IN IMAGE EDIT: C IF NO ADD, DELETE OR UPDATE CLEAR THE LOCK BIT. C IF ADD IN ONE DETAIL, SET LOCK BIT FOR ALL CHECK EXISTENCE. C ALL THE OTHER CASE SHOULD BE OK. C C THE ALGORITHM ON THE LOCK BIT IS NOT QUITE RIGHT NOW, AND SOMETIMES C THE LOCK BIT MAY BE SET + WHEN IT IS NOT NECESSARY, BUT IF IT NEEDS TO C BE THERE, IT WILL ALWAYS BE SET. !!! C 1380 IF(ISBIT(IMFLG,15)) GOTO 1383 DO 1381 I=1,40,2 1381 CALL SETBT(IMAI(I,2),10,0) GOTO 1390 C C ADD, DELETE OR UPDATE ARE DEFINED: ADD IN A DETAIL ? C 1383 IF(IADDS.EQ.0) GOTO 1390 C-----ADD IN A DETAIL IS DEFINED, SET LOCK BIT FOR ALL C CHECK EXISTENCE DO 1388 I=1,40,2 IF(IAND(IMAI(I,2),7).EQ.3) CALL SETBT(IMAI(I,2),10,1) 1388 CONTINUE C C-----THE FOLLOWING ROUTINE DETERMINES WHICH FAF, FIND, OR CHECK EXIS- C TENCE A DISPLAY COMES FROM & SETS THE DSP BIT IN IMAI(N,2). C 1390 DO 1397 IG=2,(IUMAX+IMMAX)*2,2 K=IG IF(IMAI(K,1).EQ.0) GO TO 1397 NDSET=IAND(IMAI(K,3),377B) 1391 K=K-2 C-----DONE SEARCHING BACKWARDS FOR DISPLAY, FIND, OR CHECK EXISTENCE IN IMAI? IF(K.LT.1) PAUSE 0657 C-----FAF? IF(K.NE.2*IUMAX) GO TO 1394 C-----SEARCH FORWARD FOR A FIND IN A DETAIL DURING U-QUESTION DO 1392 KK=1,K,2 IF(IMAI(KK,1).EQ.0) GO TO 1392 IF(IAND(IMAI(KK,2),140007B).EQ.0) GO TO 1393 1392 CONTINUE GO TO 1394 1393 K=KK+1 IF(NDSET.EQ.IAND(IMAI(K-1,3),377B)) GO TO 1396 C-----CHECK EXISTENCE OR FIND IN A MASTER? 1394 IF(IMAI(K-1,1).EQ.0) GO TO 1391 KK=IAND(IMAI(K-1,2),7) IF(KK.EQ.3) GO TO 1395 IF(KK.NE.0) GO TO 1391 IF(.NOT.ISBIT(IMAI(K-1,2),15)) GO TO 1391 1395 IF(NDSET.NE.IAND(IMAI(K-1,3),377B)) GO TO 1391 1396 CALL SETBT(IMAI(K-1,2),11,1) 1397 CONTINUE C C C END OF IMAGE EDITS C 1720 INDIC=0 C C CALL TGP7 FOR TRANSACTION SPECIFICATION COMPLILATION C CALL EXEC(8,LNAM) C C ERROR SECTION SCREEN 17 C C C-----ERR RETURN FROM TGP7: DATA STORAGE EXCEEDED 250 WORDS. C "DATA STORAGE EXCEEDS MAXIMUM CAPAICTY" 1775 CALL MES06(35,1) INDIC=0 GO TO 15 1780 CALL MES06(15,NOF) GO TO 15 1781 NOF=NOF-1 1782 CALL MES06(17,NOF-1) GO TO 15 1783 CALL MES06(18,NOF) GO TO 15 17r 86 CALL MES06(22,1) GO TO 15 1787 CALL MES06(32,NOF) GO TO 15 1788 CALL MES06(25,NOF) GO TO 15 C C*********************************************************************** C C 2645 SOFT KEYS PROCESSING C C********************************************************************** C C IFLG=5 MEANS NON PRINTABLE ASCII C 3000 IF(IFLG.EQ.4) IFLG=5 IF(IFLG.NE.5) GO TO 3005 CALL MES06(12,NOF) GO TO 15 C C IFLG=6 MEANS ILLEGAL PARSE C 3005 IF(IFLG.NE.6) GO TO 3007 STOP 500 C C IFLG=7 MEANS HELP C 3007 IF(IFLG.NE.7) GO TO 3010 INDIC=-77 GO TO 17 3011 INDIC=0 ILST=0 IF(ISCRN.NE.15) GO TO 3008 IMES=IHP5(NOF) IF(NOF.EQ.3) ILST=1 GO TO 3060 3008 IF(ISCRN.NE.16) GO TO 3050 IF(IMODB.EQ.1) GO TO 3009 IF(ITT.EQ.2) IMES=IHP60(NOF) IF(ITT.NE.2) IMES=IHP61(NOF) GO TO 3060 3009 IF(ITT.EQ.2) IMES=IHB60(NOF) IF(ITT.NE.2) IMES=IHB61(NOF) GO TO 3060 3050 IF(ISCRN.NE.17) GO TO 3052 IF(ISBIT(IMFLG,15)) GO TO 3051 IMES=0 IF(NOF.EQ.5) ILST=1 GO TO 3060 3051 IF(NOF.LT.4) IX=NOF IF(NOF.GT.3) IX=NOF-((NOF/3)*3) IF(IX.EQ.0) IX=3 IMES=IHP7(IX) IF(NOF.EQ.15) ILST=1 GO TO 3060 3052 IMES=IHP8(NOF) 3060 CALL HLP06(IMES,NOF,ILST) GO TO 15 C C IFLG=8 MEANS LAST SCREEN C 3010 IF(IFLG.NE.8) GO TO 3040 IF(ISCRN.NE.11) GO TO 3020 IF(IQST.NE.1) GO TO 3012 ISCRN=10 GO TO 3016 3012 IQST=IQST-1 I=IGET1(JFORM,(6+(IQST-1)*IQLN),1) IF(I.NE.2HX ) GO TO 3014 ISCRN=16 GO TO 3016 3014 I=JFORM(34+(IQST-1)*(IQLN/2)) IF(I.EQ.3) ISCRN=15 IF(I.EQ.0) ISCRN=14 IF(I.EQ.2) ISCRN=13 IF(I.EQ.1) ISCRN=12 3016 IF(ISCRN.GT.13) GO TO 1002 GO TO 1000 3020 IF((ISCRN.LT.12).OR.(ISCRN.GT.15)) GO TO 3022 ISCRN=11 GO TO 3016 3022 IF(ISCRN.EQ.16) GO TO 3014 IF(ISCRN.EQ.17) GO TO 3012ړTRN ISCRN=ISCRN-1 GO TO 3016 C C CALL NEXT SCREEN C 1000 CALL EXEC(8,JNAM) 1002 CALL EXEC(8,KNAM) C C ABORT PROGRAM C 3040 IF(.NOT.(OKABT(ILU))) GO TO 17 INDIC=99 CALL EXEC(8,NNAM) C C END OF SEGMENT C CALL TGP C C END END$ p[T  92903-18364 1805 S C0122 &MES06              H0101 aASMB,R NAM MES06,7 92903-16364 REV.1805 780501 * * SOURCE 92903-18364 * SPC 2 ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** SPC 2 SUP * ********************************************************************** * * * THIS SUBROUTINE IS CALLED BY THE SEGMENT ANSW1 * * OF THE FORMG PROGRAM TO WRITE AN ERROR MESSAGE ON THE TERMINAL. * * THE ERROR MESSAGE IS PRINTED ON LINE 24 OF THE * * SCREEN AND THE CURSOR IS MOVED TO THE WRONG FIELD. * * THIS SUBROUTINE IS CALLED WITH TWO PARAMETERS : * * * * - PAR#1 = ERROR MESSAGE # TO OUTPUT * * - PAR#2 = WRONG FIELD # ON THE SCREEN * * * ********************************************************************** * * ENT MES06 ENTRY POINT EXT EXEC EXT .ENTR EXT &REMP EXT &MVW COM ILU TERM. LU * * GET CALLING PARAMETERS AND INITIALISE * NMESS NOP FIRST PARM. ADDRESS NOF NOP SECD. PARM. ADDRESS MES06 NOP ENTRY POINT JSB .ENTR SUBR. TO GET DEF NMESS PARM. ADDRESS LDA BUFAD INITIALIZE LDB SPACE ERROR MESSAGE JSB &REMP BUFFER DEC -35 TO BLANK LDA BUFA1 INITIALIZE LDB NULL TAB BUFFER JSB &REMP TO NULL DEC -50 * * MOVE ERROR MESSAGE IN OUTPUT BUFFER * f LDA NMESS,I GET ERROR MESSAGE # ADA AMES0 COMPUTE MESSAGE LDB A,I ADDRESS STB P1 STORE IT CMB,INB MINUS STARTING ADDRESS STB IST OF MESSAGE IN IST INA COMPUTE NEXT MESSAGE LDA A,I STARTING ADDRESS ADA IST COMPUTE MESSAGE LENGTH STA P2 STORE IT LDA P1 BUFFER SOURCE ADDRESS LDB BUFAD BUFFER DEST ADDRESS JSB &MVW MOVE WORDS P2 NOP BUFFER LENGTH * * INCLUDE # OF NECESSARY TABS * LDA NOF,I GET WRONG FIELD # CMA,INA MAKE IT NEG. ISZ A INCREMENT: IS FIRST FIELD ? RSS NO JMP WRIT YES OUTPUT BUFFER STA P3 STORE NEG. # OF TABS LDA BUFA1 TAB BUFFER ADDRESS LDB TAB TAB JSB &REMP INCLUDE TABS P3 NOP IN BUFFER * * WRITE MESSAGE * WRIT JSB EXEC WRITE EXEC CALL DEF *+5 RETURN POINT DEF D.2 CODE EXEC DEF ILU CONTROL WORD DEF BUF BUFFER LOCATION DEF ILN BUFFER LENGTH * * RETURN TO CALLING PROGRAM * JMP MES06,I * * BUFFER DATA * BUF BYT 33,130,33,46,141,62,62,162,60,103 FORMAT OFF:POS.CURSOR BYT 33,112,15,12,40,0 BYT 33,46,144,103 INVERSE VIDEO BLINKING ASC 2,ERRO BYT 122,33,46,144,100 END ENHANCEMENT ASC 2, : BUFER BSS 35 MESSAGE BUFFER BYT 33,127,33,110 FORMAT ON * HOME CURSOR BUF1 BSS 50 TAB BUFFER BYT 33,142 KEYBOARD ENABLE EBUF BYT 0,137 SUPPRESS , * * STORAGE , CONSTANTS .. * BUFAD DEF BUFER BUFF. ADDRESS BUFA1 DEF BUF1 TAB BUFFER ADDRESS A EQU 0 A REGISTER STAD EQU BUF BUFFER STARTING ADDRESS LTAD EQU EBUF BUFFER LAST ADDRESS IST NOP P1 NOP SOURCE ADDRESS BUFFER ADDRESS ILN ABS LTAD-STAD+1 BUFFER LENGTH SPACE BYT 40,40 NULL BYT 0,0 TAB BYT 33,111 D.2 DEC 2 * * MESSAGE ADDRESS * AMES0 DEF AMES1-1 AMES1 DEF MES1 DEF MES2 DEF MES3 DEF MES4 DEF MES5 DEF MES6 DEF MES7 DEF MES8 DEF MES9 DEF MES10 DEF MES11 DEF MES12 DEF MES13 DEF MES14 DEF MES15 DEF MES16 DEF MES17 DEF MES18 DEF MES19 DEF MES20 DEF MES21 DEF MES22 DEF MES23 DEF MES24 DEF MES25 DEF MES26 DEF MES27 DEF MES28 DEF MES29 DEF MES30 DEF MES31 DEF MES32 DEF MES33 DEF MES34 DEF MES35 DEF MES36 * * MESSAGE STORAGE * MES1 ASC 15,Field must be blank or integer MES2 ASC 12,No more lights available MES3 ASC 10,Illegal light number MES4 ASC 13,Light reserved for system MES5 ASC 12,Field must be blank or X MES6 ASC 11,Illegal string length MES7 ASC 19,No key assigned to NEXT ENTRY function MES8 ASC 18,No key assigned to CONTINUE function MES9 ASC 20,No key assigned to DELETE ENTRY function MES10 ASC 13,Illegal display value type MES11 ASC 10,Field must be blank MES12 ASC 12,Illegal character input MES13 ASC 23,CONTINUE not allowed since no display defined ASC 9,for this question MES14 ASC 23,The displayed value (default value)and the ans ASC 12,wer must be of same type MES15 ASC 14,Illegal Logical Unit number MES16 ASC 23,Displayed value and answer max string length m ASC 6,ust be equal MES17 ASC 9,Missing file name MES18 ASC 12,Illegal cartridge number MES19 ASC 22,NEXT ENTRY cannot be defined in a U question MES20 ASC 1,XX MES21 ASC 1,XX MES22 ASC 17,No media defined for data storage MES23 ASC 1, MES24 ASC 23,To use NEXT ENTRY a find in a detail data set ASC 11,must have been defined MES25 ASC 9,Illegal file name MES26 ASC 11,Must define a function MES27 ASC 13,Missing display item name MES28 ASC 13,Missing display item type MES29 ASC 14,Missing display program name MES30 ASC 9,Unknown operation MES31 ASC 1,XX MES32 ASC 13,Illegal file security code MES33 ASC 14,Display value defined twice MES34 ASC 16,Missing display value definition MES35 ASC 19,Data Storage exceeds maximum capacity MES36 ASC 1,-1 * * END MES06 b  92903-18365 1805 S C0122 &HLP06              H0101 izASMB,R NAM HLP06,7 92903-16365 REV.1805 770810 * * SOURCE 92903-18365 * SPC 2 ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** SPC 2 SUP * ********************************************************************** * * * THIS SUBROUTINE IS USED TO PRINT A HELP MESSAGE * * ON LINES 23 AND 24 OF THE TGP SCREENS * * THE CURSOR IS POSITIONEDAT THE FIELD WHERE THE * * HELP SOFT KEY WAS PRESSED. * * THIS SUBROUTINE IS CALLED WITH TWO PARAMETERS : * * * * - PAR#1 = HELP MESSAGE # TO OUTPUT * * - PAR#2 = HELP FIELD # ON THE SCREEN * * * ********************************************************************** * * ENT HLP06 ENTRY POINT EXT EXEC EXT .ENTR EXT &REMP EXT &MVW COM ILU TERM. LU * * GET CALLING PARAMETERS * NMESS NOP FIRST PARM. ADDRESS NOF NOP SECD. PARM. ADDRESS ILST NOP THIRD PARAM ADDRESS HLP06 NOP ENTRY POINT JSB .ENTR SUBR. TO GET DEF NMESS PARM. ADDRESS * * * MOVE HELP MESSAGE IN OUTPUT BUFFER * LDA NMESS,I GET ERROR MESSAGE # SZA,RSS IS 0 ? JMP HLPC YES NO MESSAGE ADA AMES0 COMPUTE MESSAGE LDB A,I ADDRESS STB P1 STORE IT BUFF. ADDRESS BUFA2 DEF BUF2 BUFA3 DEF BUF3 A EQU 0 A REGISTER B EQU 1 B REGISTER IST NOP P1 NOP SOURCE ADDRESS BUFFER ADDRESS P5 NOP ILN NOP BUFFER LENGTH TAB BYT 33,111 BUF1 BYT 33,127 FORMAT ON BUF2 BYT 0,0,0,33,142,137 ERASE h,KEY. ENABLE BUF3 BYT 0,0,33,142,0,137 CLEAR DISP,KEY ENABLE .D1 DEC -1 D.10 DEC 10 D.1 DEC 1 D.2 DEC 2 * * MESSAGE ADDRESS * AMES0 DEF AMES1-1 AMES1 DEF MES1 DEF MES2 DEF MES3 DEF MES4 DEF MES5 DEF MES6 DEF MES7 DEF MES8 DEF MES9 DEF MES10 DEF MES11 DEF MES12 DEF MES13 DEF MES14 DEF MES15 * * MESSAGE STORAGE * * MES1 BYT 33,46,144,112 ASC 22, If CONTINUE is selected, pressing that key ASC 18,on the HP3070 during the transaction BYT 33,46,144,112 ASC 19, causes the next question to be asked. BYT 33,46,141,53,64,62,103,0 POSITION CURSOR - 81 * MES2 BYT 33,46,144,112 ASC 22, If DELETE is selected, pressing that key on ASC 18, the HP3070 during the transaction BYT 33,46,144,112 ASC 22, causes the current data base entry to be de ASC 18,leted at the end of the transaction. * MES3 BYT 33,46,144,112 ASC 22, If not specified indicator lights are assig ASC 18,ned in numerical order (lights 5,10 BYT 33,46,144,112 ASC 18, and 15 are reserved to the system). BYT 33,46,141,53,64,64,103,0 POSITION CURSOR - 81 * MES4 BYT 33,46,144,112 ASC 22, This text is used only on the HP3070 label ASC 18,printout given at the end of the BYT 33,46,144,112 ASC 22, definition of this transaction specificatio ASC 2,n . BYT 33,46,141,53,63,62,103,0 POSITION CURSOR - 81 * MES5 BYT 33,46,144,112 ASC 22, This is the name of the user written subrou ASC 18,tine required to pass the vZalue to BYT 33,46,144,112 ASC 22, be displayed for this question to the Trans ASC 12,action Monitor Program. BYT 33,46,141,53,61,62,103,0 POSITION CURSOR - 81 * MES6 BYT 33,46,144,112 ASC 20, Maximum string length accepted is 126. BYT 33,46,141,53,64,60,103,0 POSITION CURSOR - 81 BYT 33,46,144,112 BYT 33,46,141,53,70,60,103,0 POSITION CURSOR - 81 * MES7 BYT 33,46,144,112 ASC 22, If the value to display is to be retrieved ASC 18,from a data base item, its name in BYT 33,46,144,112 ASC 18, the data base schema must be given. BYT 33,46,141,53,64,64,103,0 POSITION CURSOR - 81 * MES8 BYT 33,46,144,112 ASC 22, If this information is to be stored directl ASC 18,y into a data base item, its name in * BYT 33,46,144,112 ASC 18, the data base schema must be given. BYT 33,46,141,53,64,64,103,0 POSITION CURSOR - 81 * MES9 BYT 33,46,144,112 ASC 22, Each device in an RTE system is identified ASC 18,by a Logical Unit number assigned by BYT 33,46,144,112 ASC 22, the system operator at system generation ti ASC 2,me . BYT 33,46,141,53,63,62,103,0 POSITION CURSOR - 81 * MES10 BYT 33,46,144,112 ASC 22, The disc file name is composed of 6 printab ASC 18,le alphanumeric characters starting BYT 33,46,144,112 ASC 15, with an alphabetic character. BYT 33,46,141,53,65,60,103,0 POSITION CURSOR - 81 * MES11 BYT 33,46,144,112 ASC 22, Each disc cartridge in an RTE system is ide ASC 18,ntified by a Cartridge Reference # BYT 33,46,144,112 ASC 17, assigned by the system operator. BYT 33,46,141,53,64,66,103,0 POSITION CURSOR - 81 * MES12 BYT 33,46,144,112 ASC 22, The file security code is a user selected n ASC 18,umber (-32768=, * * STORAGE , CONSTANTS .. * BUFAD DEF BUFER BUFF. ADDRESS BUFA1 DEF BUF1 TAB BUFFER ADDRESS ANMES DEF INMES A EQU 0 A REGISTER STAD EQU BUF BUFFER STARTING AD) DRESS LTAD EQU EBUF BUFFER LAST ADDRESS IST NOP P1 NOP SOURCE ADDRESS BUFFER ADDRESS ILN ABS LTAD-STAD+1 BUFFER LENGTH SPACE BYT 40,40 NULL BYT 0,0 TAB BYT 33,111 D.2 DEC 2 * * MESSAGE ADDRESS * AMES0 DEF AMES1-1 AMES1 DEF MES1 DEF MES2 DEF MES3 DEF MES4 DEF MES5 DEF MES6 DEF MES7 DEF MES8 DEF MES9 DEF MES01 DEF MES11 DEF MES12 DEF MES13 DEF MES14 DEF MES15 DEF MES16 DEF MES17 DEF MES18 DEF MES19 DEF MES20 DEF MES21 DEF MES22 DEF MES23 * * MESSAGE STORAGE * MES1 ASC 12,Field must be blank or X MES2 ASC 10,Illegal logical unit MES3 ASC 9,Illegal file name MES4 ASC 9,Missing file name MES5 ASC 12,Illegal cartridge number MES6 ASC 23,No transaction specification on the selected m ASC 2,edia MES7 ASC 18,Missing or illegal mode of operation MES8 ASC 10,Field must be blank MES9 ASC 23,File or Cr# not found or no room or no header MES01 ASC 10,Duplicate file name MES11 ASC 10,System error : FMGR INMES ASC 3, MES12 ASC 23,Trans. specification with same ID already stor ASC 10,ed on selected media MES13 ASC 12,Illegal character input MES14 ASC 9,Illegal file type MES15 ASC 24,Source and destination library must be different MES16 ASC 23,Attempt to store more than 25 specifications i ASC 6,n a library MES17 ASC 10,Unable to lock file MES18 ASC 11,Unable to unlock file MES19 ASC 20,DISASTER: CR filled up--Xfer incomplete MES20 ASC 18,Illegal transaction specification # MES21 ASC 13,Library could not be found MES22 ASC 4,CR full MES23 ASC 1,-1 * * END MES08 vs  92903-18369 1805 S C0122 &HLP08              H0101 m|ASMB,R NAM HLP08,7 92903-16369 REV.1805 770810 * * SOURCE 92903-18369 * SPC 2 ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** SPC 2 SUP * ********************************************************************** * * * THIS SUBROUTINE IS USED TO PRINT A HELP MESSAGE * * ON LINES 23 AND 24 OF THE TGP SCREENS * * THE CURSOR IS POSITIONEDAT THE FIELD WHERE THE * * HELP SOFT KEY WAS PRESSED. * * THIS SUBROUTINE IS CALLED WITH TWO PARAMETERS : * * * * - PAR#1 = HELP MESSAGE # TO OUTPUT * * - PAR#2 = HELP FIELD # ON THE SCREEN * * * ********************************************************************** * * ENT HLP08 ENTRY POINT EXT EXEC EXT .ENTR EXT &REMP EXT &MVW COM ILU TERM. LU * * GET CALLING PARAMETERS * NMESS NOP FIRST PARM. ADDRESS NOF NOP SECD. PARM. ADDRESS HLP08 NOP ENTRY POINT JSB .ENTR SUBR. TO GET DEF NMESS PARM. ADDRESS * * * MOVE HELP MESSAGE IN OUTPUT BUFFER * LDA NMESS,I GET ERROR MESSAGE # SZA,RSS IS 0 ? JMP HLPC YES NO MESSAGE ADA AMES0 COMPUTE MESSAGE LDB A,I ADDRESS STB P1 STORE IT CMB,INB MINUS STARTING ADDRE(SS STB IST OF MESSAGE IN IST INA COMPUTE NEXT MESSAGE LDA A,I STARTING ADDRESS ADA IST COMPUTE MESSAGE LENGTH STA P2 STORE IT LDA P1 BUFFER SOURCE ADDRESS LDB BUFAD BUFFER DEST ADDRESS JSB &MVW MOVE WORDS P2 NOP BUFFER LENGTH * LDB BUFAD COMPUTE CURRENT ADB P2 ADDRESS IN OUTPUT BUFFER * LDA BUF1 INCLUDE FORMAT ON STA B,I IN OUTPUT BUFFER INB INCREMENT ADDRESS IN OUT. BUFFER * LDA D.10 COMPUTE OUTPUT BUFFER LENGTH ADA P2 STA ILN STORE IT JMP HLPB * HLPC LDA D.10 STA ILN LDB BUFAD LDA BUF1 STA B,I INB * * NOW INCLUDE TABS IN BUFFER * HLPB LDA NOF,I GET HELP FIELD # CPA D.1 IS 1 ? JMP HLPA YES NO TABS ADA .D1 DECREMENT STA P5 STORE # OF FIELD ADA ILN INCREMENT OUTPUT BUFFER STA ILN LENGTH LDA P5 GET FIELD # CMA,INA MAKE IT NEG STA P4 LDA B STB P2 SORE B LDB TAB JSB &REMP MOVE TABS IN BUFFER P4 NOP * LDB P2 RESTORE B LDA P5 INCREMENT ADDRESS IN ADB A * HLPA LDA BUFA2 JSB &MVW INCLUDE KEY ENABLE DEC 3 IN BUFFER * JSB EXEC WRITE MESSAGE DEF *+5 DEF D.2 DEF ILU DEF BUF DEF ILN * JMP HLP08,I * * * BUFFER DATA * BUF BYT 33,130,33,46,141,62,62,162,60,103 FORMAT OFF:POS.CURSOR BYT 33,112 CLEAR DISPLAY BUFER BSS 140 MESSAGE BUFFER * * STORAGE , CONSTANTS .. * BUFAD DEF BUFER BUFF. ADDRESS BUFA2 DEF BUF2 A EQU 0 A REGISTER B EQU 1 B REGISTER IST NOP P1 NOP SOURCE ADDRESS BUFFER ADDRESS P5 NOP ILN NOP BUFFER LENGTH TAB BYT 33'3 ,111 BUF1 BYT 33,127 FORMAT ON BUF2 BYT 0,0,0,33,142,137 ERASE h,KEY. ENABLE .D1 DEC -1 D.10 DEC 10 D.1 DEC 1 D.2 DEC 2 * * MESSAGE ADDRESS * AMES0 DEF AMES1-1 AMES1 DEF MES1 DEF MES2 DEF MES3 DEF MES4 DEF MES5 DEF MES6 * * MESSAGE STORAGE * * MES1 BYT 33,46,144,112 ASC 22, If given, the header identifies the new lib ASC 18,rary of transaction specifications BYT 33,46,144,112 ASC 22, to be created otherwise an existing library ASC 6, is assumed BYT 33,46,141,53,62,64,103,0 POSITION CURSOR - 81 * * MES2 BYT 33,46,144,112 ASC 22, The disc file name is composed of 6 printab ASC 18,le alphanumeric characters starting BYT 33,46,144,112 ASC 15, with an alphabetic character. BYT 33,46,141,53,65,60,103,0 POSITION CURSOR - 81 * MES3 BYT 33,46,144,112 ASC 22, Each disc cartridge in an RTE system is ide ASC 18,ntified by a Cartridge Reference # BYT 33,46,144,112 ASC 17, assigned by the system operator. BYT 33,46,141,53,64,66,103,0 POSITION CURSOR - 81 * * * * MES4 BYT 33,46,144,112 ASC 22, The name (6 alphanumeric characters) or num ASC 18,ber (from 0 to 9999) uniquely BYT 33,46,144,112 ASC 20, identify each transaction specification BYT 33,46,141,53,64,60,103,0 POSITION CURSOR - 81 * * MES5 BYT 33,46,144,112 ASC 22, File name of an output device selected amon ASC 18,g those defined when installing * BYT 33,46,144,112 ASC 4, DATACAP BYT 33,46,141,53,67,62,103,0 POSITION CURSOR - 81 * MES6 ASC 1,-1 * END HLP08   92903-18370 1840 S C0122 &TGP9 TGP SEGM 09 SRC             H0101 'FTN4 PROGRAM TGP9(5), 92903-16370 REV.1840 780804 C C SOURCE 92903-18370 C C C C ************************************************************** C * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * C ************************************************************** C C C C C PRGMR : JEAN CHARLES MIARD (HPG) C C********************************************************************* C* * C* THIS IS A SEGMENT OF THE TGP PROGRAM USED TO * C* ANALYZE THE ANSWERS THE USER HAS GIVEN IN THE SCREEN # 10 . * C* THE ANSWERS AFTER A CHECK ARE STORED IN JFORM. * C* * C* IF : INDIC = 0 : ANALYSE SCREEN # 10 . NORMAL PATH . * C* OR AN ERROR HAS BEEN DETECTED IN TGP12 * C* (IMAGE PROCESSING) * C* 3 : RETURN FROM TGP12 IMAGE OPERATION (ADD, * C* UPDATE, CHECK EXISTENCE,FIND HAS BEEN * C* SUCCESSFULLY PROCESSED . * C* -77 : A HELP MESSAGE MUST BE PRINTED * C* * C* WARNING !! * PRINTED SCREEN 10 CORRESPONDS TO ISCRN = 11 * C* * C********************************************************************* C C C DECLARATIONS COMMON VARIABLES *********** C COMMON ILU,ISCRN,IQST,ISKIP,INDIC COMMON IFORM(494) COMMON JFORM(980) COMMON MFORM(16) COMMON LFORM(39) COMMON ITT COMMON IKEÀY(11,3) COMMON IUMAX,IMMAX COMMON IMODB COMMON ILITE(15) COMMON IMAI(45,5) COMMON IMFLG,IMAS,IMDT,IMKY COMMON KFORM(1065) COMMON ILIBR(61) COMMON NIMAG C C LOCAL VARIABLES ********************* C DIMENSION JNAM(3) DIMENSION JOUT(10),KNAM(3),LNAM(3),INAM(3) DIMENSION IHP0(3),IHP1(5),IHP2(7),IHPB0(5),IHPB1(7),IHPB2(9) LOGICAL JPAR,RNUM,ISBIT,GETBK,OKABT C EQUIVALENCE(JVAL1,KFORM(1000)),(JVAL3,KFORM(1001)) EQUIVALENCE(JVAL4,KFORM(1002)) EQUIVALENCE(IFLG2,KFORM(1003)),(ISTAT,KFORM(1004)) EQUIVALENCE(JOUT1,KFORM(1005)),(NOF,KFORM(1006)) C C DATA VALUES : C DATA IQLN/98/ DATA JNAM/2HTG,2HP3,2H / DATA KNAM/2HTG,2HP4,2H / DATA LNAM/2HTG,2HPI,2H2 / DATA INAM/2HTG,2HP1,2H / DATA IHP0/1,4,6/ DATA IHP1/1,2,3,4,6/ DATA IHP2/1,2,3,4,5,0,6/ DATA IHPB0/1,0,0,4,6/ DATA IHPB1/1,0,0,2,3,4,6/ DATA IHPB2/1,0,0,2,3,4,5,0,6/ C C********************************************************************* C C IF INDIC = 3 IMAGE PROCESSING SUCCESSFULL C C********************************************************************* C IF(INDIC.EQ.3) GO TO 1132 IF(INDIC.EQ.-77) GO TO 3011 C C*********************************************************************** C C GET USER'S ANSWERS !!! C C*********************************************************************** C ISTAT=0 15 IF(ITT.EQ.0) ITLOG=21 IF(ITT.EQ.1) ITLOG=25 IF(ITT.GT.1) ITLOG=34 C-----INCREASE ITLOG IF 3070B IF(IMODB.EQ.1) ITLOG=ITLOG+9 IF(.NOT.(GETBK(ILU,KFORM,ITLOG))) GO TO 1100 C C ERROR IN GETTING ANSWERS REPRINT SCREEN C 17 CALL EXEC(8,JNAM) C C********************************************************************** C C SCREEN # 10 (QUESTION SPECIFICATIONS) C C********************************************************************** C C C RESET THE BUFFER ,FOR DATA SET # TO ADD (KFORM(1060) TO KFORM(1065) C RESET IMAI BUFFER C RESET ILITE BUFFER C 1100 N=2*IQST-1 CALL ERFLG(N,IMAI,IMKY,IMFLG,IMAS,IMDT) CALL ERLIT(ILITE,IQST) IF(KFORM(1060).EQ.0) GO TO 410 DO 200 I=1,KFORM(1060) DO 100 J=1,N IOP=IAND(IMAI(J,2),7) NDS=IAND(IMAI(J,3),377B) IF((IOP.EQ.2).AND.(NDS.EQ.KFORM(1060+I))) GO TO 200 100 CONTINUE KFORM(1060+I)=0 200 CONTINUE C I=1 320 IF(KFORM(1060+I).NE.0) GO TO 400 IF(I.EQ.KFORM(1060)) GO TO 350 CALL MOVEW(KFORM(1061+I),KFORM(1060+I),KFORM(1060)-I) 350 KFORM(1060)=KFORM(1060)-1 400 I=I+1 IF(I.LE.KFORM(1060)) GO TO 320 C C ANSWER TYPE C 410 NOF=1 IF(JPAR(KFORM,ITLOG,NOF,JOUT,1,IFLG,JVAL)) GO TO 3000 JVAL1=-1 IF(JOUT.EQ.2HS ) JVAL1=0 IF(JOUT.EQ.2HI ) JVAL1=1 IF(JOUT.EQ.2HR ) JVAL1=2 IF(JOUT.EQ.2HF ) JVAL1=3 IF(JOUT.EQ.2HD ) JVAL1=4 IF(JVAL1.EQ.-1) GO TO 1185 IF((JVAL1.EQ.3).AND.(ITT.LT.1)) GO TO 1192 IF((JVAL1.EQ.4).AND.(ITT.LT.2)) GO TO 1193 IF(ISBIT(IMFLG,2).AND.(JVAL1.NE.3)) GO TO 1175 CALL MOVCA(JOUT,1,JFORM,(5+(IQST-1)*IQLN),1) JSAVE=JVAL1 C C INPUT FROM CARD READER ? (3070B ONLY) C IF(IMODB.EQ.1) GO TO 1112 JFORM(2+(IQST-1)*49)=2H GO TO 1117 1112 NOF=NOF+1 IF(JPAR(KFORM,ITLOG,NOF,JOUT,1,IFLG,JVAL)) GO TO 3000 IFLG1=IFLG IF((IFLG.NE.0).AND.(JOUT(1).NE.2HX )) GO TO 1184 C-----IF FUNCTION, CARD READER CANNOT BE SELECTED AS INPUT DEVICE. IF((JVAL1.EQ.3).AND.(JOUT.EQ.2HX )) GO TO 1205 CALL MOVCA(JOUT,1,JFORM,(3+(IQST-1)*IQLN),1) C C-----ASCII/IMAGE? C IARG=0 NOF=NOF+1 IF(JPAR(KFORM,ITLOG,NOF,JOUT,1,IFLG,JVAL)) GO TO 3000 IFLG5=IFLG IF((IFLG1.EQ.0).AND.(JOUT(1).NE.2H )) GO TO 1189 IF((IFLG1.EQ.0).AND.(JOUT(1).EQ.2H )) GO TO 11121 IF(IFLG5.EQ.0) GO TO 11121  IF((JOUT(1).NE.2HA ).AND.(JOUT(1).NE.2HI )) GO TO 1177 IF(JOUT(1).EQ.2HA ) IARG=IOR(IARG,100B) IF(JOUT(1).EQ.2HI ) IARG=IOR(IARG,200B) C C-----HOLES/MARKS? C 11121 NOF=NOF+1 IF(JPAR(KFORM,ITLOG,NOF,JOUT,1,IFLG,JVAL)) GO TO 3000 IF((IFLG1.EQ.0).AND.(JOUT(1).NE.2H )) GO TO 1189 IF((IFLG1.EQ.0).AND.(JOUT(1).EQ.2H )) GO TO 11123 IF((IFLG5.EQ.0).AND.(JOUT(1).EQ.2H )) GO TO 11123 IF((IFLG5.EQ.0).AND.(JOUT(1).NE.2H )) GO TO 1201 IF((JOUT(1).NE.2HH ).AND.(JOUT(1).NE.2HM )) GO TO 1178 IF(JOUT(1).EQ.2HH ) IARG=IOR(IARG,20B) IF(JOUT(1).EQ.2HM ) IARG=IOR(IARG,40B) C C-----80/40/CO/CA? C 11123 NOF=NOF+1 IF(JPAR(KFORM,ITLOG,NOF,JOUT,2,IFLG,JVAL)) GO TO 3000 IF((IFLG1.EQ.0).AND.(JOUT(1).NE.2H )) GO TO 1189 IF((IFLG1.EQ.0).AND.(JOUT(1).EQ.2H )) GO TO 11124 IF((IFLG5.EQ.0).AND.(JOUT(1).EQ.2H )) GO TO 11124 IF((IFLG5.EQ.0).AND.(JOUT(1).NE.2H )) GO TO 1201 J=JOUT(1) IF((J.NE.2H80).AND.(J.NE.2H40).AND.(J.NE.2HCO).AND.(J.NE.2HCA)) GO C TO 1200 IF(JOUT(1).EQ.2H80) IARG=IOR(IARG,1B) IF(JOUT(1).EQ.2H40) IARG=IOR(IARG,2B) IF(JOUT(1).EQ.2HCO) IARG=IOR(IARG,4B) IF(JOUT(1).EQ.2HCA) IARG=IOR(IARG,10B) C C-----CHECK FOR ILLEGAL COMBINATIONS. C J=IARG IF((J.EQ.122B).OR.(J.EQ.141B).OR.(J.EQ.222B).OR.(J.EQ.241B)) GO TO C 1179 C C-----IF CARD INPUT, NEW CARD SPECS MUST HAVE BEEN PREVIOUSLY DEFINED C C-----SKIP IF NOT CARD INPUT. 11124 IF(IFLG1.EQ.0) GO TO 11127 C-----SKIP IF NEW CARD. IF(IARG.NE.0) GO TO 11125 C C-----THE FOLLOWING ROUTINE SEARCHES BACKWARDS THRU JFORM LOOKING FOR C A PREVIOUSLY DEFINED CARD SPECS. IF NONE ARE FOUND, IT IS AN ERROR. C WHEN CARD SPECS ARE FOUND, A CHECK IS MADE TO DETERMINE IF THE ORIG- C INAL QUESTION IS AN M-QUES. IF SO, ITS CARD SPECS MUST NOT BE DEFINED C ON A U-QUES. C MQSTCT=IQST-1 DO 10024IF J=IQST-1,1,-1 C-----INPUT FROM CARD READER? IF(IGET1(JFORM,3+(J-1)*98).NE.1HX) GO TO 10024 C-----YES, GOTO 10025 WHEN CARD SPECS ARE FOUND. IF(IAND(JFORM(2+(J-1)*49),77B).NE.0) GO TO 10025 10024 CONTINUE C-----ERROR "CARD SPECS NOT PREVIOUSLY DEFINED" GO TO 1203 C-----GOTO 10026 IF THIS IS A U-QUES. 10025 IF(IQST.LE.IUMAX) GO TO 10026 C-----M-QUES. ERR (1206) IF SPECS ARE ON A U-QUES. IF(J.LE.IUMAX) GO TO 1206 C-----EVERYTHING IS OK, SET ASCII OR IMAGE BITS 10026 IF(ISBIT(JFORM(2+(J-1)*49),6)) IARG=IOR(IARG,100B) IF(ISBIT(JFORM(2+(J-1)*49),7)) IARG=IOR(IARG,200B) C C-----IF CARD IMAGE INPUT, USER WRITTEN MODULE IS REQUIRED. C 11125 IF(.NOT.ISBIT(IARG,7)) GO TO 11127 C-----INTEGER INPUT DOES NOT REQUIRE USER WRITTEN MODULE. IF(IGET1(JFORM,5+(IQST-1)*98).EQ.2HI ) GO TO 11127 IF(IGET1(IFORM,73).NE.2HX ) GO TO 1202 C C-----NOW STORE THE ABOVE CARD READER ANSWERS IN LOWER BYTE JFORM(2+49N) C 11127 CALL MOVCA(IARG,2,JFORM,(4+(IQST-1)*IQLN),1) C C C IS THERE A DISPLAY ? (TR. TYPE > 0 ONLY) C 1117 IF(ITT.NE.0) GO TO 1113 CALL PUTCA(JFORM,1H ,6+(IQST-1)*98) GO TO 1119 1113 NOF=NOF+1 IF(JPAR(KFORM,ITLOG,NOF,JOUT,1,IFLG,JVAL)) GO TO 3000 IF((IFLG.NE.0).AND.(JOUT(1).NE.2HX )) GO TO 1184 IFLG1=IFLG IF(IFLG.NE.0) GO TO 1116 DO 1115 I=35+(IQST-1)*49,49+(IQST-1)*49 1115 JFORM(I)=2H JFORM(46+(IQST-1)*49)=0 1116 IF(IFLG.EQ.0) GO TO 1118 IF(ITT.NE.2) GO TO 1118 C-----FIND PREVIOUSLY DEFINED? IF(ISBIT(IMFLG,1)) GO TO 1118 C-----OR CHECK EXISTENCE PREVIOUSLY DEFINED? IF(.NOT.ISBIT(IMFLG,4)) GO TO 1197 1118 CALL MOVCA(JOUT,1,JFORM,(6+(IQST-1)*IQLN),1) C C DEFAULT =DISPLAYED VALUE ? C NOF=NOF+1 IF(JPAR(KFORM,ITLOG,NOF,JOUT,1,IFLG,JVAL)) GO TO 3000 IF((IFLG.NE.0).AND.(JOUT.NE.2HX )) GO TO 1184 IF((IFLG1.EQ.0).AND.(IFLG.NE.0)) GO TO 1187 IF((JVAL1.EQ.3).AND.(JOUT.EQ.2HX )) GO TO 1199 IFLG4=IFLG 2 CALL MOVCA(JOUT,1,JFORM,23+(IQST-1)*IQLN,1) C C DEFAULT VALUE C C CHECK FIRST IF IITEM TYPE IS F ,A DISPLAY IS DEFINED C 1119 IF((JVAL1.EQ.3).AND.(IGET1(JFORM,6+(IQST-1)*98).NE.2HX )) GO CTO 1176 NOF=NOF+1 IF(JPAR(KFORM,ITLOG,NOF,JOUT,16,IFLG,JVAL)) GO TO 3000 IF((IFLG4.NE.0).AND.(IFLG.NE.0)) GO TO 1186 IFLG2=IFLG CALL MOVCA(JOUT,1,JFORM,(7+(IQST-1)*IQLN),16) C C ITEM NAME ASSOCIATED WITH ANSWER (TR.TYPE > 1 ONLY) C IF(ITT.GT.1) GO TO 1124 CALL BLAN(JFORM,24+(IQST-1)*98,7) GO TO 1125 1124 NOF=NOF+1 IF(JPAR(KFORM,ITLOG,NOF,JOUT,6,IFLG,JVAL)) GO TO 3000 IFLG3=IFLG IF((JVAL1.NE.4).AND.(IFLG.NE.0)) GO TO 1195 CALL MOVCA(JOUT,1,JFORM,(24+(IQST-1)*IQLN),6) C C IMAGE OPERATION (TR TYPE 2 OR 3 ONLY) C N=2*IQST-1 NOF=NOF+1 IF(JPAR(KFORM,ITLOG,NOF,JOUT,1,IFLG,JVAL)) GO TO 3000 IF((IFLG3.NE.0).AND.(IFLG.EQ.0)) GO TO 1198 IF((IFLG3.EQ.0).AND.(IFLG.NE.0)) GO TO 1196 IF(IFLG.EQ.0) GO TO 1130 JVAL=-1 IF(JOUT.EQ.2HF ) JVAL=0 IF(JOUT.EQ.2HU ) JVAL=1 IF(JOUT.EQ.2HA ) JVAL=2 IF(JOUT.EQ.2HC ) JVAL=3 IF(JVAL.EQ.-1) GO TO 1188 C-----IF IMAGE CARD INPUT, 'F' & 'C' NOT ALLOWED. C-----CARD INPUT? IF(IGET1(JFORM,3+(IQST-1)*98).NE.1HX) GO TO 1130 C-----YES. IMAGE CARD INPUT? IF(.NOT.ISBIT(JFORM(2+(IQST-1)*49),7)) GO TO 1130 IF((JVAL.EQ.0).OR.(JVAL.EQ.3)) GO TO 1204 1130 CALL MOVCA(JOUT,1,JFORM,(30+(IQST-1)*IQLN),1) C C PROMPTING LIGHT # C 1125 NOF=NOF+1 IF(JPAR(KFORM,ITLOG,NOF,JOUT,2,IFLG,JVAL3)) GO TO 3000 JOUT1=JOUT(1) IF(IFLG.GT.1) GO TO 1180 IF(IFLG.EQ.0) GO TO 1127 IF((JVAL3.LT.1).OR.(JVAL3.GT.15)) GO TO 1182 IF(ILITE(JVAL3).EQ.-99) GO TO 1183 C C IMAGE OPERATION CALL TGP12 SEGMENT C 1127 IF(JVAL1.NE.4) GO TO 1134 IMAI(N,2)=JVAL INDIC=0 CALL EXEC(8,LNAM) C C*************************g*********************************************** C C RETURN FROM TGP12 IMAGE OPERATION SUCCESFULL C C************************************************************************ C 1132 N=2*IQST-1 INDIC=0 JVAL1=IAND(IMAI(N,2),30000B)/4096 IF(JVAL1.EQ.0) JFORM(16+(IQST-1)*49)=IAND(IMAI(N,4),377B) C C CHECK DEFAULT VALUE FOR COMPATIBILITY WITH ANSWER TYPE C 1134 IF(IFLG2.EQ.0) GO TO 1101 IF((JVAL1.EQ.1).AND.(IFLG2.NE.1)) GO TO 1190 IF((JVAL1.EQ.3).AND.(IFLG2.NE.0)) GO TO 1191 IF(JVAL1.NE.2) GO TO 1101 IF(RNUM(JFORM,(7+(IQST-1)*98),14,XMAX)) GO TO 1194 C C PROMPTING LIGHT : STORE NOW C 1101 IF(ISTAT.EQ.0) GO TO 1102 IF(JVAL3.NE.JVAL4) ISTAT=0 1102 IQ=IQST CALL LIGHT(IQ,JVAL3,JOUT1,ISTAT,JFORM,ILITE) IF(ISTAT.EQ.0) GO TO 1170 IF(ISTAT.EQ.-1) GO TO 1181 NOF1=5 IF(IMODB.EQ.1) GO TO 1103 IF(ITT.EQ.0) NOF1=3 IF(ITT.GT.1) NOF1=7 GO TO 1104 1103 IF(ITT.EQ.1) NOF1=9 IF(ITT.GT.1) NOF1=11 1104 CALL WARN(ILITE(JVAL3),NOF1) ISTAT=1 JVAL4=JVAL3 GO TO 15 C C NOW CALL EDIT SCREEN C 1170 N1=34+(IQST-1)*49 IF((JFORM(N1).EQ.2H ).OR.(JFORM(N1).EQ.JVAL1)) GO TO 1168 DO 1166 I=16+(IQST-1)*49,N1 1166 JFORM(I)=2H 1168 JFORM(N1)=JVAL1 IF((JVAL1.EQ.0).AND.(IMAI(N,4).NE.0)) JFORM(16+(IQST-1)*49)= CIAND(IMAI(N,4),377B) IF(JVAL1.EQ.1) ISCRN=12 IF(JVAL1.EQ.2) ISCRN=13 IF(JVAL1.EQ.0) ISCRN=14 IF(JVAL1.EQ.3) ISCRN=15 N=16+(IQST-1)*49 IF((ISCRN.EQ.14).AND.(JFORM(N).EQ.2H )) JFORM(N)=0 IF(ISCRN.GT.13) GO TO 1002 GO TO 1000 C C ERROR PROCESSING SCREEN 11 C 1180 CALL MES09(1,NOF) GO TO 15 1181 CALL MES09(2,NOF) GO TO 15 1182 CALL MES09(3,NOF) GO TO 15 1183 CALL MES09(4,NOF) GO TO 15 1184 CALL MES09(5,NOF) GO TO 15 1185 CALL MES09(6,NOF) GO TO 15 1186 NOF=NOF-1 CALL MES09(7,NOF)  GO TO 15 1187 CALL MES09(8,NOF) GO TO 15 1188 CALL MES09(9,NOF) GO TO 15 1189 CALL MES09(11,NOF) GO TO 15 1190 NOF=2 IF(ITT.GT.0) NOF=4 CALL MES09(12,NOF+2*IMODB) GO TO 15 1199 GO TO 1169 1191 NOF=2 IF(ITT.GT.0) NOF=4 NOF=NOF+2*IMODB 1169 CALL MES09(13,NOF) GO TO 15 1192 CALL MES09(14,NOF) GO TO 15 1193 CALL MES09(15,NOF) GO TO 15 1194 NOF=2 IF(ITT.GT.0) NOF=4 CALL MES09(16,NOF+2*IMODB) GO TO 15 1195 CALL MES09(17,1) GO TO 15 1196 CALL MES09(18,NOF-1) GO TO 15 1197 CALL MES09(19,NOF) GO TO 15 1198 CALL MES09(20,NOF) GO TO 15 1175 CALL MES09(21,1) GO TO 15 1176 CALL MES09(22,1) GO TO 15 C-----"FIELD MUST BE 'A' OR 'I'" 1177 CALL MES09(23,NOF) GO TO 15 C-----"FIELD MUST BE 'H' OR 'M'" 1178 CALL MES09(24,NOF) GO TO 15 C-----"ILLEGAL COMBINATION, PLEASE RE-SPECIFY" 1179 CALL MES09(25,NOF) GO TO 15 C-----"FIELD MUST BE '80' OR '40' OR 'CO' OR 'CA'" 1200 CALL MES09(26,NOF) GO TO 15 C-----"FIELD MUST BE BLANK" 1201 CALL MES09(27,NOF) GO TO 15 C-----"USER WRITTEN MODULE REQUIRED FOR IMAGE CARD INPUT" 1202 NOF=NOF-2 CALL MES09(29,NOF) GO TO 15 C-----"CARD SPECS HAVE NOT YET BEEN DEFINED" 1203 NOF=NOF-2 CALL MES09(28,NOF) GO TO 15 C-----"IF IMAGE CARD INPUT--'F' & 'C' NOT ALLOWED" 1204 CALL MES09(30,NOF) GO TO 15 C-----"CARD READER CANNOT BE SELECTED" 1205 CALL MES09(31,NOF) GO TO 15 C-----"AN M-QUES CANNOT HAVE ITS CARD SPECS DEFINED FROM A U-QUES" 1206 CALL MES09(32,3) GO TO 15 C C C********************************************************************* C C 2645 SOFT KEYS PROCESSING C C********************************************************************* C C IFLG=5 MEANS NON PRINTABLE ASCII C 3000 IF(IFLG.EQ.4) IFLG=5 IF(IFLG.NE.5) GO TO 3005 CALL MES09(10,NOF) GO TO 15 C C IFLG=6406 MEANS ILLEGAL PARSE C 3005 IF(IFLG.NE.6) GO TO 3007 STOP 500 C C IFLG=7 MEANS HELP C 3007 IF(IFLG.NE.7) GO TO 3010 INDIC=-77 GO TO 17 3011 INDIC=0 IF(IMODB.EQ.1) GO TO 3008 IF(ITT.EQ.0) IMES=IHP0(NOF) IF(ITT.EQ.1) IMES=IHP1(NOF) IF(ITT.GT.1) IMES=IHP2(NOF) GO TO 3009 3008 IF(ITT.EQ.0) IMES=IHPB0(NOF) IF(ITT.EQ.1) IMES=IHPB1(NOF) IF(ITT.GT.1) IMES=IHPB2(NOF) 3009 CALL HLP09(IMES,NOF) GO TO 15 C C IFLG=8 MEANS LAST SCREEN C 3010 IF(IFLG.NE.8) GO TO 3040 IF(ISCRN.NE.11) GO TO 3020 IF(IQST.NE.1) GO TO 3012 ISCRN=10 GO TO 3016 3012 IQST=IQST-1 I=IGET1(JFORM,(6+(IQST-1)*IQLN),1) IF(I.NE.2HX ) GO TO 3014 ISCRN=16 GO TO 3016 3014 I=JFORM(34+(IQST-1)*(IQLN/2)) IF(I.EQ.3) ISCRN=15 IF(I.EQ.0) ISCRN=14 IF(I.EQ.2) ISCRN=13 IF(I.EQ.1) ISCRN=12 3016 IF(ISCRN.GT.13) GO TO 1002 GO TO 1000 3020 IF((ISCRN.LT.12).OR.(ISCRN.GT.15)) GO TO 3022 ISCRN=11 GO TO 3016 3022 IF(ISCRN.EQ.16) GO TO 3014 IF(ISCRN.EQ.17) GO TO 3012 ISCRN=ISCRN-1 GO TO 3016 C C CALL NEXT SCREEN C 1000 CALL EXEC(8,JNAM) 1002 CALL EXEC(8,KNAM) C C ABORT PROGRAM C 3040 IF(.NOT.(OKABT(ILU))) GO TO 17 INDIC=99 CALL EXEC(8,INAM) C C END OF SEGMENT C CALL TGP C C END END$ 6  92903-18371 1805 S C0122 &MES09 TGP SEGM 09 SUBR REL             H0101 ASMB,R NAM MES09,7 92903-16371 REV.1805 780511 * * SOURCE 92903-18371 * SPC 2 ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** SPC 2 SUP * ********************************************************************** * * * THIS SUBROUTINE IS CALLED BY THE SEGMENT ANSW1 * * OF THE FORMG PROGRAM TO WRITE AN ERROR MESSAGE ON THE TERMINAL. * * THE ERROR MESSAGE IS PRINTED ON LINE 24 OF THE * * SCREEN AND THE CURSOR IS MOVED TO THE WRONG FIELD. * * THIS SUBROUTINE IS CALLED WITH TWO PARAMETERS : * * * * - PAR#1 = ERROR MESSAGE # TO OUTPUT * * - PAR#2 = WRONG FIELD # ON THE SCREEN * * * ********************************************************************** * * ENT MES09 ENTRY POINT EXT EXEC EXT .ENTR EXT &REMP EXT &MVW COM ILU TERM. LU * * GET CALLING PARAMETERS AND INITIALISE * NMESS NOP FIRST PARM. ADDRESS NOF NOP SECD. PARM. ADDRESS MES09 NOP ENTRY POINT JSB .ENTR SUBR. TO GET DEF NMESS PARM. ADDRESS LDA BUFAD INITIALIZE LDB SPACE ERROR MESSAGE JSB &REMP BUFFER DEC -35 TO BLANK LDA BUFA1 INITIALIZE LDB NULL TAB BUFFER JSB &REMP TO NULL DEC -50 * * MOVE ERROR MESSAGE IN OUTPUT BUFFER * d LDA NMESS,I GET ERROR MESSAGE # ADA AMES0 COMPUTE MESSAGE LDB A,I ADDRESS STB P1 STORE IT CMB,INB MINUS STARTING ADDRESS STB IST OF MESSAGE IN IST INA COMPUTE NEXT MESSAGE LDA A,I STARTING ADDRESS ADA IST COMPUTE MESSAGE LENGTH STA P2 STORE IT LDA P1 BUFFER SOURCE ADDRESS LDB BUFAD BUFFER DEST ADDRESS JSB &MVW MOVE WORDS P2 NOP BUFFER LENGTH * * INCLUDE # OF NECESSARY TABS * LDA NOF,I GET WRONG FIELD # CMA,INA MAKE IT NEG. ISZ A INCREMENT: IS FIRST FIELD ? RSS NO JMP WRIT YES OUTPUT BUFFER STA P3 STORE NEG. # OF TABS LDA BUFA1 TAB BUFFER ADDRESS LDB TAB TAB JSB &REMP INCLUDE TABS P3 NOP IN BUFFER * * WRITE MESSAGE * WRIT JSB EXEC WRITE EXEC CALL DEF *+5 RETURN POINT DEF D.2 CODE EXEC DEF ILU CONTROL WORD DEF BUF BUFFER LOCATION DEF ILN BUFFER LENGTH * * RETURN TO CALLING PROGRAM * JMP MES09,I * * BUFFER DATA * BUF BYT 33,130,33,46,141,62,62,162,60,103 FORMAT OFF:POS.CURSOR BYT 33,112,15,12,40,0 CLEAR DISP,CR,LF BYT 33,46,144,103 INVERSE VIDEO BLINKING ASC 2,ERRO BYT 122,33,46,144,100 END ENHANCEMENT ASC 2, : BUFER BSS 35 MESSAGE BUFFER BYT 33,127,33,110 FORMAT ON * HOME CURSOR BUF1 BSS 50 TAB BUFFER BYT 33,142 KEYBOARD ENABLE EBUF BYT 0,137 SUPPRESS , * * STORAGE , CONSTANTS .. * BUFAD DEF BUFER BUFF. ADDRESS BUFA1 DEF BUF1 TAB BUFFER ADDRESS A EQU 0 A REGISTER STAD EQU BUF BUFFER STARTING ADDRESS LTAD EQU EBUF BUFFER LAST ADDRESS IST NOP P1 NOP SOURCE ADDRESS BUFFER ADDRESS ILN ABS LTAD-STAD+1 BUFFER LENGTH SPACE BYT 40,40 NULL BYT 0,0 TAB BYT 33,111 D.2 DEC 2 * * MESSAGE ADDRESS * AMES0 DEF AMES1-1 AMES1 DEF MES1 DEF MES2 DEF MES3 DEF MES4 DEF MES5 DEF MES6 DEF MES7 DEF MES8 DEF MES9 DEF MES10 DEF MES11 DEF MES12 DEF MES13 DEF MES14 DEF MES15 DEF MES16 DEF MES17 DEF MES18 DEF MES19 DEF MES20 DEF MES21 DEF MES22 DEF MES23 DEF MES24 DEF MES25 DEF MES26 DEF MES27 DEF MES28 DEF MES29 DEF MES30 DEF MES31 DEF MES32 DEF MES33 * * MESSAGE STORAGE * MES1 ASC 15,Field must be blank or integer MES2 ASC 12,No more lights available MES3 ASC 10,Illegal light number MES4 ASC 13,Light reserved for system MES5 ASC 12,Field must be blank or X MES6 ASC 10,Illegal answer type MES7 ASC 23,Only one kind of default value may be selected MES8 ASC 23,No display has been defined for this question MES9 ASC 12,Illegal IMAGE operation MES10 ASC 12,Illegal character input MES11 ASC 20,Card reader not selected as input device MES12 ASC 15,Default value must be integer MES13 ASC 20,No default value allowed for a "function ASC 9, only" answer type MES14 ASC 20,"function only" answer type illegal with ASC 11, this transaction type MES15 ASC 23,Illegal answer type since no data base has bee ASC 5,n selected MES16 ASC 13,Default value must be real MES17 ASC 11,Answer type must be D MES18 ASC 9,Missing item name MES19 ASC 23,A find or check existence must be previously d ASC 9,efined for display MES20 ASC 12,Missing IMAGE operation MES21 ASC 24,Answer type must be F since delete operation was ASC 10, previously defined MES22 ASC 24,A display must be defined when answer type is F MES23 ASC 12,Field must be 'A' or 'I' MES24 ASC 12,Field must be 'H' or 'M' MES25 ASC 19,Illegal combination, please re-specBify MES26 ASC 21,Field must be '80' or '40' or 'CO' or 'CA' MES27 ASC 10,Field must be blank MES28 ASC 18,Card specs have not yet been defined MES29 ASC 23,User written module required for Image card in ASC 2,put MES30 ASC 21,If image card input--'F' & 'C' not allowed MES31 ASC 15,Card reader cannot be selected MES32 ASC 23,An M-Ques cannot have its card specs defined f ASC 6,rom a U-Ques MES33 ASC 1,-1 * * END MES09 ~\  92903-18372 1805 S C0122 &HLP09 TGP SEGM 09 SUBR SRC             H0101 ASMB,R NAM HLP09,7 92903-16372 REV.1805 770810 * * SOURCE 92903-18372 * SPC 2 ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** SPC 2 SUP * ********************************************************************** * * * THIS SUBROUTINE IS USED TO PRINT A HELP MESSAGE * * ON LINES 23 AND 24 OF THE TGP SCREENS * * THE CURSOR IS POSITIONEDAT THE FIELD WHERE THE * * HELP SOFT KEY WAS PRESSED. * * THIS SUBROUTINE IS CALLED WITH TWO PARAMETERS : * * * * - PAR#1 = HELP MESSAGE # TO OUTPUT * * - PAR#2 = HELP FIELD # ON THE SCREEN * * * ********************************************************************** * * ENT HLP09 ENTRY POINT EXT EXEC EXT .ENTR EXT &REMP EXT &MVW COM ILU TERM. LU * * GET CALLING PARAMETERS * NMESS NOP FIRST PARM. ADDRESS NOF NOP SECD. PARM. ADDRESS HLP09 NOP ENTRY POINT JSB .ENTR SUBR. TO GET DEF NMESS PARM. ADDRESS * * * MOVE HELP MESSAGE IN OUTPUT BUFFER * LDA NMESS,I GET ERROR MESSAGE # SZA,RSS IS 0 ? JMP HLPC YES NO MESSAGE ADA AMES0 COMPUTE MESSAGE LDB A,I ADDRESS STB P1 STORE IT CMB,INB MINUS STARTING ADDRE"SS STB IST OF MESSAGE IN IST INA COMPUTE NEXT MESSAGE LDA A,I STARTING ADDRESS ADA IST COMPUTE MESSAGE LENGTH STA P2 STORE IT LDA P1 BUFFER SOURCE ADDRESS LDB BUFAD BUFFER DEST ADDRESS JSB &MVW MOVE WORDS P2 NOP BUFFER LENGTH * LDB BUFAD COMPUTE CURRENT ADB P2 ADDRESS IN OUTPUT BUFFER * LDA BUF1 INCLUDE FORMAT ON STA B,I IN OUTPUT BUFFER INB INCREMENT ADDRESS IN OUT. BUFFER * LDA D.10 COMPUTE OUTPUT BUFFER LENGTH ADA P2 STA ILN STORE IT JMP HLPB * HLPC LDA D.10 STA ILN LDB BUFAD LDA BUF1 STA B,I INB * * NOW INCLUDE TABS IN BUFFER * HLPB LDA NOF,I GET HELP FIELD # CPA D.1 IS 1 ? JMP HLPA YES NO TABS ADA .D1 DECREMENT STA P5 STORE # OF FIELD ADA ILN INCREMENT OUTPUT BUFFER STA ILN LENGTH LDA P5 GET FIELD # CMA,INA MAKE IT NEG STA P4 LDA B STB P2 SORE B LDB TAB JSB &REMP MOVE TABS IN BUFFER P4 NOP * LDB P2 RESTORE B LDA P5 INCREMENT ADDRESS IN ADB A * HLPA LDA BUFA2 JSB &MVW INCLUDE KEY ENABLE DEC 3 IN BUFFER * JSB EXEC WRITE MESSAGE DEF *+5 DEF D.2 DEF ILU DEF BUF DEF ILN * JMP HLP09,I * * * BUFFER DATA * BUF BYT 33,130,33,46,141,62,62,162,60,103 FORMAT OFF:POS.CURSOR BYT 33,112 CLEAR DISPLAY BUFER BSS 140 MESSAGE BUFFER * * STORAGE , CONSTANTS .. * BUFAD DEF BUFER BUFF. ADDRESS BUFA2 DEF BUF2 A EQU 0 A REGISTER B EQU 1 B REGISTER IST NOP P1 NOP SOURCE ADDRESS BUFFER ADDRESS P5 NOP ILN NOP BUFFER LENGTH TAB BYT 33(3,111 BUF1 BYT 33,127 FORMAT ON BUF2 BYT 0,0,0,33,142,137 ERASE h ,KEY.ENABLE .D1 DEC -1 D.10 DEC 10 D.1 DEC 1 D.2 DEC 2 * * MESSAGE ADDRESS * AMES0 DEF AMES1-1 AMES1 DEF MES1 DEF MES2 DEF MES3 DEF MES4 DEF MES5 DEF MES6 DEF MES7 * * MESSAGE STORAGE * * MES1 BYT 33,46,144,112 ASC 22, A function only answer allows only CONTINUE ASC 18,, DELETE or NEXT ENTRY keys as an- BYT 33,46,144,112 ASC 12, swers to the question. BYT 33,46,141,53,65,66,103,0 POSITION CURSOR - 81 * MES2 BYT 33,46,144,112 ASC 22, A value may be displayed when asking a ques ASC 18,tion to help the HP3070 user answer BYT 33,46,144,112 ASC 8, that question. BYT 33,46,141,53,66,64,103,0 POSITION CURSOR - 81 * MES3 BYT 33,46,144,112 ASC 22, The displayed value may be taken as the def ASC 18,ault answer when the ENTER key is BYT 33,46,144,112 ASC 22, pressed on the HP3070 as answer to the ques ASC 3,tion. BYT 33,46,141,53,63,60,103,0 POSITION CURSOR - 81 * MES4 BYT 33,46,144,112 ASC 22, The default value is the value taken as ans ASC 18,wer when the ENTER key is pressed on BYT 33,46,144,112 ASC 19, the HP3070 as answer to the question. BYT 33,46,141,53,64,62,103,0 POSITION CURSOR - 81 * MES5 BYT 33,46,144,112 ASC 22, If the value entered is for a data base ite ASC 18,m, its name in the data base schema BYT 33,46,144,112 ASC 10, must be given here. BYT 33,46,141,53,66,60,103,0 POSITION CURSOR - 81 * MES6 BYT 33,46,144,112 ASC 22, If not specified prompting lights are assig ASC 18,ned in numerical order (lights 5,10 BYT 33,46,144,112 ASC 18, and 15 are reserved for the system). BYT 33,46,141,53,64,64,103,0 POSITION CURSOR - 81 * MES7 ASC 1,-1 * * END HLP09   92903-18373 1805 S C0122 &TGP10 TGP SEGM 10 SRC             H0101 =FTN4 PROGRAM TGPI0(5), 92903-16373 REV.1805 780525 C C SOURCE 92903-18373 C C C C ************************************************************** C * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * C ************************************************************** C C C C PRGMR : JEAN CHARLES MIARD (HPG) C C********************************************************************* C* * C* THIS IS A SEGMENT OF THE TGP PROGRAM USED TO READ OR * C* WRITE TRANSACTION SPECS. IT IS ALSO USED TO MANIPULATE LIBRARIES * C* OF TRANSACTION SPECS (ADD,DELETE AND PRINT DIRECTORIES) . * C* * C* ACCORDING TO THE VALUE OF INDIC AND ISCRN DIFFERENT * C* PORTIONS OF CODE ARE EXECUTED : * C* * C* IF : INDIC = 1 : REQUEST TO WRITE A TRANSACTION SPEC ON A * C* LIBRARY (OLD OR NEW) . COMING FROM SCREEN * C* # 18 AND TGP8 . * C* INDIC = 2 : REQUEST TO BUILD TRANSACTION SPEC LIBRARY * C* ADD. DELETE OR PRINT DIRECTORY . COMING FROM * C* SCREENS 19 OR 20 AND TGP8 . * C* ISCRN = 3 : REQUEST TO READ A TRANSACTION SPEC ON A * C* LIBRARY TO MODIFY IT OR PRINT IT . * C* COMING FROM SCREEN # 3 AND TGP1 . * C* * C********************************************************************* C C C C DECLARXATIONS COMMON VARIABLES ************** C COMMON ILU,ISCRN,IQST,ISKIP,INDIC COMMON IFORM(494) COMMON JFORM(980) COMMON MFORM(16) COMMON LFORM(39) COMMON ITT COMMON IKEY(11,3) COMMON IUMAX,IMMAX COMMON IMODB COMMON ILITE(15) COMMON IMAI(45,5) COMMON IMFLG,IMAS,IMDT,IMKY COMMON KFORM(1065) COMMON ILIBR(61) COMMON NIMAG C C LOCAL VARIABLES ***************** C DIMENSION INAM(3),JNAM(3),KNAM(3),IBUF(46),LNAM(3),JOUT(3) DIMENSION MEDIS(4),NFORM(5),IDCB(288),IHD(15) DIMENSION MEDID(4),IDEN(125),IPRES(22) DIMENSION INIT(9),IWR(4),IRD(4),ITR(17),IBON(3) DIMENSION IBD(11),ISC(8),IDT(8),ILH(9),IOK(14),ILF1(4) DIMENSION IDI(13),INA(2),INM(3),ISCO(7),ICOP(33) DIMENSION IDSAVE(5),MEDSAV(4) C LOGICAL TSRD,TSWR,ISSPA,INUM,CMPW,JPAR,ISBTW,GETBK,OKABT C C DATA VALUES *************** C DATA INAM/2HTG,2HP1,2H / DATA JNAM/2HTG,2HP4,2H / DATA KNAM/2HTG,2HPI,2H3 / DATA LNAM/2HTG,2HP3,2H / C C INIT IS FORMAT OFF,BLOCK MODE OFF,ENABLE KEYBD,HOME UP,CLEAR C DISPLAY,INVERSE VIDEO ON C DATA INIT/15530B,15446B,65460B,41040B,15542B,15510B, C15512B,15446B,62102B/ DATA IWR/2HWR,2HIT,2HIN,2HG / DATA IRD/2HRE,2HAD,2HIN,2HG / DATA ITR/2HTR,2HAN,2HSA,2HCT,2HIO,2HN ,2HSP,2HEC,2HIF,2HIC, C2HAT,2HIO,2HNS,15446B,62100B,6412B,5012B/ DATA IBON/15446B,65461B,41040B/ DATA IBD/2HBU,2HIL,2HDI,2HNG,2H L,2HIB,2HRA,2HRI,2HES,2H O,2HF / DATA ISC/5012B,15B,2H ,2H ,2H S,2HOU,2HRC,2HE / DATA IDT/5012B,15B,2HDE,2HST,2HIN,2HAT,2HIO,2HN / DATA IOK/15446B,62102B,2H O,2HK ,2H? ,2H(Y,2H/N,2H) ,2H , C15446B,62100B,15504B,15504B,137B/ DATA ILF1/15501B,15501B,15501B,15512B/ DATA IDI/2H ,2HDI,2HRE,2HCT,2HOR,2HY ,2HOF,2H L,2HIB,2HRA,2HRY, C2H :,2H / DATA INA/2HNA,2HME/ DATA INM/2HNU,2HMB,2HER/ DATA ISCO/2HSE,2pHHCU,2HRI,2HTY,2H C,2HOD,2HE / DATA ILH/2HLI,2HBR,2HAR,2HY ,2HHE,2HAD,2HER,2H :,2H / DATA IPRES/15542B,6412B,6412B, .15446B,62112B,2HPr,2Hes,2Hs ,15446B,62113B,2HNE,2HXT,2H S,2HCR, .2HEE,2HN ,15446B,62112B,2Hke,74433B,23144B,40040B/ DATA ICOP/5012B,15B,2HTR,2HAN,2HSA,2HCT,2HIO,2HN ,2HSP,2HEC,2HIF, C2HIC,2HAT,2HIO,2HNS,2H C,2HOP,2HIE,2HD ,2HON,2H T,2HHE,2H D, C2HES,2HTI,2HNA,2HTI,2HON,2H L,2HIB,2HRA,2HRY,5012B/ DATA ILFX/15B/ C C*********************************************************************** C C GO TO THE REQUIRED PORTION OF TGP10 . C C*********************************************************************** C IF(ISCRN.EQ.3) GO TO 500 IF(INDIC.EQ.1) GO TO 200 IF(INDIC.EQ.2) GO TO 1000 C C********************************************************************** C C INDIC = 1 WRITE TRANSACTION SPEC ON LIBRARY . C C*********************************************************************** C C OUTPUT MESSAGE C 200 CALL MOVEW(INIT,IBUF,9) CALL MOVEW(IWR,IBUF(10),4) CALL MOVEW(ITR,IBUF(14),17) CALL EXEC(2,ILU,IBUF,30) C C DEFINE MEDIA ON WHICH TRANSACTION SPEC IS TO BE WRITTEN C FILE NAME / CR # . C CALL MOVEW(LFORM(16),MEDID,3) IF(INUM(LFORM,37,6,MEDID(4))) GO TO 5000 C-----SAVE "MEDID" CALL MOVEW(MEDID,MEDSAV,4) NFORM=-1 NFORM(4)=-1 NFORM(5)=100000B C C IF LIBRARY IS NOT CREATED BUT ALREADY EXITS READ LIBRARY FIRST C OTHERWISE CREATE LIBRARY . C IF(.NOT.ISSPA(LFORM,43,30)) GO TO 1040 CALL MOVEW(LFORM(22),IHD,15) GO TO 1120 C C********************************************************************** C C INDIC = 2 BUILD LIBRARY OF TRANSACTION SPECS . C C********************************************************************* C C C PUT CONSOLE IN CHAR. MODE ,SEND MESSAGE C 1000 CALL MOVEW(INIT,IBUF,9) CALL MOVEW(IBD,IBUF(10),11) CALL MOVEW(ITR,IBUF(21),17) CALL EXEC(2,ILU,IBUF,37) IF(IANS.EQ.-1) GO TO 1135 C C DEFINE SOURCE LIBRARY MEDIA (FILE NAME AND CR #) C SET NFORM TO READ FIRST SEQUENTIAL TRANSCACTION SPEC NO SEC. CODE C CALL MOVEW(ILIBR(2),MEDIS,3) IF(INUM(ILIBR,9,6,MEDIS(4))) GO TO 5000 NFORM=-1 NFORM(4)=-1 NFORM(5)=100000B C C OPEN AND READ SOURCE LIBRARY HEADER C IF(TSRD(MEDIS,0,ISTAT,NFORM,KFORM,IFORM,IDCB,IHD)) GO TO 8000 C-----IF CR WAS NOT SPECIFIED, GET IT NOW FROM IDCB IF(MEDIS(4).NE.0) GO TO 1005 ICR=ICRLU(-IAND(IDCB,77B)) CALL JASC(ICR,ILIBR,9,6) C C IF MODE OF OPERATION IS NOT "L" PRINT SOURCE LIBRARY HEADER C AND ASK IF OK ? C 1005 IF(ILIBR.EQ.2H L) GO TO 1075 CALL MOVEW(ISC,IBUF,8) CALL MOVEW(ILH,IBUF(9),9) CALL MOVEW(IHD,IBUF(18),15) CALL MOVEW(IOK,IBUF(33),14) 1010 CALL EXEC(2,ILU,IBUF,46) C C ASK THE USER IF THIS IS THE GOOD LIBRARY ? C CALL REIO(1,500B+ILU,IANS,-1) IF(IGET1(IANS,1).EQ.1HY) GO TO 1030 IF(IGET1(IANS,1).EQ.1HN) GO TO 1020 C C ANSWER IS NOT "Y" OR "N" ASK QUESTION AGAIN C CALL EXEC(2,ILU,ILF1,4) GO TO 1010 C C ANSWER IS "N" PRINT SCREEN 19 ,CLOSE SOURCE LIBRARY,SET BLOCK MODE C 1020 CALL EXEC(2,ILU,IBON,3) ISCRN=20 INDIC=0 1025 IF(TSRD(MEDIS,3,ISTAT,NFORM,KFORM,IFORM,IDCB,IHD)) GO TO 8000 CALL EXEC(8,LNAM) C C ANSWER IS "Y" DEFINE DESTINATION LIBRARY (FILE NAME AND CR #) C SET NFORM TO READ FIRST SEQUENTIAL TRANSACTION SPEC NO SEC. CODE C 1030 CALL EXEC(2,ILU,ILFX,1) CALL MOVEW(ILIBR(41),MEDID,3) C-----SAVE "MEDID" CALL MOVEW(MEDID,MEDSAV,4) IF(INUM(ILIBR,87,6,MEDID(4))) GO TO 5000 NFORM=-1 NFORM(4)=-1 NFORM(5)=100000B C C DESTINATION LIBRARY MUST BE CREATED ? C IF(ISSPA(ILIBR,93,30)) GO TO 1110 C C************************************************************************ C C DESTINATION LIBRARY ALREADY EXIST READ IT C C*******=**************************************************************** C C C OPEN DESTINATION LIBRARY AND READ HEADER C 1040 IF(TSRD(MEDID,0,ISTAT,NFORM,IBUF,IFORM,IDCB(145),IHD)) GO TO 1042 C-----IF CR WAS NOT SPECIFIED, GET IT NOW FROM IDCB IF(MEDID(4).NE.0) GO TO 1045 ICR=ICRLU(-IAND(IDCB(145),77B)) IF(INDIC.EQ.1) GO TO 1041 CALL JASC(ICR,ILIBR,87,6) GO TO 1045 1041 CALL JASC(ICR,LFORM,37,6) GO TO 1045 1042 ISKIP=ISTAT C-----IF ERR=-6: "LIBRARY COULD NOT BE FOUND" IF(ISKIP.EQ.-6) ISKIP=66 GO TO 8005 C C IF MODE OF OPERATION IS NOT "L" OUTPUT DEST. LIBRARY HEADER C 1045 IF(ILIBR.EQ.2H L) GO TO 1075 CALL MOVEW(IDT,IBUF,8) CALL MOVEW(ILH,IBUF(9),9) CALL MOVEW(IHD,IBUF(18),15) CALL MOVEW(IOK,IBUF(33),14) 1050 CALL EXEC(2,ILU,IBUF,46) C C ASK USER IF DEST. LIBR. IS GOOD ? C CALL REIO(1,500B+ILU,IANS,-1) IF(IGET1(IANS,1).EQ.1HY) GO TO 1080 IF(IGET1(IANS,1).EQ.1HN) GO TO 1060 C C ANSWER IS NOT "Y" OR "N" ASK QUESTION AGAIN C CALL EXEC(2,ILU,ILF1,4) GO TO 1050 C C ANSWER IS "N", SET BLOCK MODE PRINT RIGHT SCREEN,CLOSE DEST. LIBR C 1060 INDIC=0 CALL EXEC(2,ILU,IBON,3) IF(TSRD(MEDID,3,ISTAT,NFORM,IBUF,IFORM,IDCB(145),IHD)) GOTO 9000 IF(ISCRN.EQ.19) CALL EXEC(8,JNAM) ISCRN=21 GO TO 1025 C C FOR PRINT DIRECTORY USE SOURCE LIBRARY TO BE READ C 1075 M=1 DO 1076 I=1,4 1076 MEDID(I)=MEDIS(I) GO TO 1082 C C************************************************************************ C C READ LIBRARY AN SAVE ID'S C C************************************************************************* C 1080 CALL EXEC(2,ILU,ILFX,1) M=145 1082 IFX=0 MEDID=-MEDID 1090 IF(TSRD(MEDID,1,ISTAT,NFORM,IBUF,IBUF(11),IDCB(M),IHD)) GO TO 1100 IFX=IFX+1 CALL MOVEW(IBUF(2),IDEN(1+(IFX-1)*5),5) C-----SAVE LAST READ TS IN CASE CR FILLS UP WHEN C WRITING 1ST TS+ TO THIS LIBRARY. CALL MOVEW(IBUF(2),IDSAVE,5) GO TO 1090 1100 IF(ISTAT.EQ.2) GO TO 1105 IF(M.EQ.1) GO TO 8000 GO TO 9000 1105 IF(ILIBR.EQ.2H L) GO TO 7000 IFIRST=1 IF(IFX.EQ.25) GO TO 6000 GO TO 1130 C C*********************************************************************** C C DESTINATION LIBRARY MUST BE CREATED ,WRITE HEADER C C*********************************************************************** C C 1110 CALL MOVEW(ILIBR(47),IHD,15) 1120 IF(TSWR(MEDID,4,ISTAT,KFORM,IFORM,IDCB(145),IHD)) GO TO 9005 C-----IF CR WAS NOT SPECIFIED, GET IT NOW FROM IDCB IF(MEDID(4).NE.0) GO TO 1122 ICR=ICRLU(-IAND(IDCB(145),77B)) IF(INDIC.EQ.1) GO TO 1121 CALL JASC(ICR,ILIBR,87,6) GO TO 1122 1121 CALL JASC(ICR,LFORM,37,6) 1122 IFX=0 MEDID=-MEDID C C********************************************************************** C C READ FROM SOURCE LIBRARY C C********************************************************************* C 1130 IF(INDIC.EQ.1) GO TO 1150 MEDIS=-MEDIS CALL EXEC(2,ILU,ICOP,33) IANS=-1 GO TO 7009 1131 IANS=0 1132 IF(TSRD(MEDIS,2,ISTAT,NFORM,KFORM,IFORM,IDCB,IHD)) GO TO 1210 C C C IF BUILDING LIBRARY CHECK IF FORM IS TO COPY OR EXCLUDE C 1150 IF(INDIC.EQ.1) GO TO 1135 DO 1160 I=1,10 C IF(.NOT.ISSPA(ILIBR,21+(I-1)*6,6)) GO TO 1185 IF(INUM(ILIBR,21+(I-1)*6,6,IANS)) GO TO 1170 IF(IANS.EQ.KFORM(5)) GO TO 1180 GO TO 1160 1170 IF(CMPW(KFORM(2),ILIBR(11+(I-1)*3),3)) GO TO 1180 1160 CONTINUE IF(ILIBR.EQ.2H C) GO TO 1132 GO TO 1135 1180 IF(ILIBR.EQ.2H E) GO TO 1132 GO TO 1135 1185 IF(ILIBR.EQ.2H E) GO TO 1135 GO TO 1132 C C CHECK FOR DUPLICATE ID C 1135 IANS=0 IF(IFX.EQ.0) GO TO 1190 DO 1140 I=1,IFX IF(CMPW(KFORM(2),IDEN(1+(I-1)*5),3)) GO TO 4000 IF(KFORM(5).EQ.IDEN(4+(I-1)*5)) GO TO 4000 1140 CONTINUE C C CHECK NO MORE3; THAN 25 SPECS IN A LIBRARY C 1190 IF(IFX.EQ.25) GO TO 6000 IFX=IFX+1 C C********************************************************************* C C WRITE SPECS ON DEST. LIBRARY C C******************************************************************** C 1200 IANS=1 IF(IFIRST.EQ.1) IANS=2 IF(INDIC.EQ.1) GO TO 1208 DO 1201 I=1,23 1201 IBUF(I)=2H CALL MOVEW(KFORM(2),IBUF(4),3) CALL CNUMD(KFORM(5),IBUF(11)) CALL JASC(KFORM(6),IBUF,37,6) 1208 IF(TSWR(MEDID,IANS,ISTAT,KFORM,IFORM,IDCB(145),IHD)) GO TO 1209 IF(INDIC.EQ.1) GO TO 1215 C-----PRINT THE TS JUST WRITTEN ONTO THE INTERACTIVE TERMINAL CALL EXEC(2,ILU,IBUF,23) IFIRST=0 CALL MOVEW(KFORM(2),IDEN(1+(IFX-1)*5),5) C-----SAVE LAST WRITTEN TS NAME, NO., & SECURITY CODE IN CASE OF WRITE ERROR. CALL MOVEW(KFORM(2),IDSAVE,5) GO TO 1132 C-----IF CR FILLED UP, TAKE CORRECTIVE ACTION. 1209 IF(ISTAT.NE.-6) GO TO 9000 C-----CR FILLED UP. CALL MOVEW(MEDSAV,MEDID,4) ISTATX=ISTAT C-----THE FOLLOWING LOOP STARTS AT THE BEGINNING OF THE DEST. LIB. & C READS FORWARD UNTIL FINDING THE LAST KNOWN GOOD TS, THEN WRITES C AN EOF. NFORM(1)=-1 NFORM(4)=-1 NFORM(5)=100000B C-----OPEN & READ HEADER. IF(TSRD(MEDID,0,ISTAT,NFORM,KFORM,IFORM,IDCB(145),IHD)) GO TO 9000 MEDID=-MEDID C-----READ FORWARD UNTIL FINDING DESIRED TS. 12090 IF(TSRD(MEDID,1,ISTAT,NFORM,KFORM,IFORM,IDCB(145),IHD)) GO TO 9000 IF(.NOT.CMPW(KFORM(2),IDSAVE,5)) GO TO 12090 C-----FOUND IT. IF(TSWR(MEDID,3,ISTAT,KFORM,IFORM,IDCB(145),IHD)) GO TO 9000 ISTAT=ISTATX GO TO 9010 C C NO MORE SPECS ON SOURCE LIBRARY C 1210 IF(ISTAT.NE.2) GO TO 8000 C C********************************************************************* C C CLOSE SOURCE AND DESTINATION LIBRARIES C C********************************************************************* C CALL EXEC(2,ILU,IPRES,22) CALL REIO(/1,ILU,IANS,-1) 1214 IF(TSRD(MEDIS,3,ISTAT,NFORM,KFORM,IFORM,IDCB,IHD)) GO TO 8000 1215 IF(TSWR(MEDID,3,ISTAT,KFORM,IFORM,IDCB(145),IHD)) GO TO 9000 IF(INDIC.EQ.99) CALL EXEC(8,INAM) IF(INDIC.EQ.1) CALL EXEC(8,KNAM) INDIC=0 ILIBR=2H CALL EXEC(2,ILU,IBON,3) ISCRN=20 CALL EXEC(8,LNAM) C C************************************************************************ C C PRINT DIRECTORY C C*********************************************************************** C C C FORMAT MEDIA ,PRINT HEADER C 7000 CALL EXEC(3,1100B+ISKIP,-1) CALL EXEC(3,1100B+ISKIP,2) CALL BLANC(IBUF,6) CALL MOVEW(IDI,IBUF(7),13) CALL MOVEW(ILIBR(2),IBUF(20),3) CALL MOVEW(6H (CR =,IBUF(23),3) CALL MOVEW(ILIBR(5),IBUF(26),3) IBUF(29)=2H) CALL EXEC(2,ISKIP,IBUF,29) CALL EXEC(3,1100B+ISKIP,1) CALL BLANC(IBUF,10) CALL MOVEW(IHD,IBUF(11),15) CALL EXEC(2,ISKIP,IBUF,25) CALL EXEC(3,1100B+ISKIP,2) C C PRINT TITLES " NAME, #, SEC. CODE " C 7009 DO 7010 I=1,25 7010 IBUF(I)=2H CALL MOVEW(INA,IBUF(4),2) CALL MOVEW(INM,IBUF(11),3) CALL MOVEW(ISCO,IBUF(19),7) CALL EXEC(2,ISKIP,IBUF,25) CALL EXEC(3,1100B+ISKIP,2) IF(IANS.EQ.-1) GO TO 1131 C C C PRINT DIRECTORY LINE PER LINE C DO 7050 I=1,IFX DO 7015 J=1,23 7015 IBUF(J)=2H CALL MOVEW(IDEN(1+(I-1)*5),IBUF(4),3) CALL CNUMD(IDEN(4+(I-1)*5),IBUF(11)) CALL JASC(IDEN(5+(I-1)*5),IBUF,37,6) CALL EXEC(2,ISKIP,IBUF,23) 7050 CONTINUE IF(ISKIP.NE.ILU) GO TO 1020 CALL EXEC(2,ILU,IPRES,22) CALL REIO(1,ILU,IANS,-1) GO TO 1020 C C********************************************************************* C C ERROR SECTION C C C********************************************************************* C 5000 STOP 5000 C C ERROR MORE 25 SPECS TO BE STORED C 6000 ISKIP=10 ISCRN=21 IFæ(INDIC.EQ.1) ISCRN=19 GO TO 8003 C C FMGR ERRORS FROM SOURCE LIBRARY C 8000 ISCRN=20 8002 ISKIP=ISTAT 8003 IF(INDIC.EQ.1) GO TO 8004 IF(TSRD(MEDIS,3,IANS,NFORM,KFORM,IFORM,IDCB,IHD)) GO TO 5000 8004 IF(ILIBR.EQ.2H L) GO TO 8005 IF(TSWR(MEDID,3,IANS,KFORM,IFORM,IDCB(145),IHD)) GO TO 5000 8005 INDIC=2 CALL EXEC(2,ILU,IBON,3) IF(ISCRN.EQ.19) CALL EXEC(8,JNAM) CALL EXEC(8,LNAM) C C FMGR DEST. LIBRARY ERROR C 9000 ISCRN=21 IF(INDIC.EQ.1)ISCRN=19 GO TO 8002 C-----ERROR OCCURRED WHEN ATTEMPTING TO CREATE A NEW LIBRARY. 9005 ISCRN=21 IF(INDIC.EQ.1) ISCRN=19 ISKIP=ISTAT C-----IF ERR=-2 (DUPLICATE FILE NAME) CLOSE THE FILE. IF(ISTAT.NE.-2) GO TO 9007 IF(TSRD(MEDID,3,ISTAT,KFORM,IBUF,IFORM,IDCB(145),IHD)) GO TO 8005 GO TO 8005 C-----IF ERR=-6: CR IS FULL, CLOSE SOURCE LIBRARY BEFORE EXITING 9007 IF(ISTAT.NE.-6) GO TO 8005 IF(TSRD(MEDIS,3,IANS,NFORM,KFORM,IFORM,IDCB,IHD)) GO TO 8005 GO TO 8005 C-----CR FILLED UP WHILE WRITING A TS TO A LIBRARY 9010 IF(INDIC.EQ.2) GO TO 9015 C-----INDIC=1 MEANS CR FILLED UP WHILE WRITING TS ONTO A C LIBRARY (OLD OR NEW) FROM SCR 18 ISCRN=19 ISKIP=77 GO TO 8005 C-----INDIC=2 MEANS CR FILLED UP WHILE WRITING FROM 1 LIB TO ANOTHER, C CLOSE SOURCE LIBRARY BEFORE EXITING 9015 IF(TSRD(MEDIS,3,IANS,NFORM,KFORM,IFORM,IDCB,IHD)) GO TO 8005 ISCRN=21 ISKIP=99 GO TO 8005 C C********************************************************************** C C A DUPLICATE ID HAS BEEN FOUND C C********************************************************************** C C PREPARE BUFFER TO BE PASSED TO DUPL SUBROUTINE C 4000 CALL MOVEW(IDEN(1+(I-1)*5),IBUF,3) CALL MOVEW(KFORM(2),IBUF(9),3) CALL CNUMD(IDEN(4+(I-1)*5),IBUF(40)) CALL MOVEW(IBUF(41),IBUF(4),2) CALL CNUMD(KFORM(5),IBUF(40)) CALL MOVEW(IBUF(41),IBUF(12),2) CALL JASC(IDEN(5+(I-1)*5),IB7AUF,11,6) CALL JASC(KFORM(6),IBUF,27,6) C C NOW PRINT SCREEN TO ASK NEW ID C CALL DUPL(IBUF) C C GET ANSWER C 4010 IF(GETBK(ILU,IBUF,18)) GO TO 4000 C C ANALYSE SCREEN * NEW NAME C NOF=1 IF(JPAR(IBUF,18,NOF,JOUT,6,IFLG,JVAL)) GO TO 3000 IF(ISBTW(IGET1(JOUT,1),1HA,1HZ)) GO TO 4100 CALL MOVEW(JOUT,KFORM(2),3) CALL MOVEW(JOUT,IFORM(29),3) C C NEW NUMBER C NOF=NOF+1 IF(JPAR(IBUF,18,NOF,JOUT,4,IFLG,JVAL)) GO TO 3000 IF(IFLG.EQ.0) GO TO 4110 IF(IFLG.NE.1) GO TO 4110 IF((JVAL.LT.1).OR.(JVAL.GT.9999)) GO TO 4110 IF(JVAL.LT.0) GO TO 4110 CALL MOVEW(JOUT,IFORM(32),2) KFORM(5)=JVAL C C NEW SECURITY CODE C NOF=NOF+1 IF(JPAR(IBUF,18,NOF,JOUT,6,IFLG,JVAL)) GO TO 3000 IF(IFLG.GT.1) GO TO 4120 CALL MOVEW(JOUT,IFORM(34),3) KFORM(6)=JVAL C IANS=-1 GO TO 1000 C C ERROR SECTION C 3000 IF(IFLG.NE.9) GO TO 4130 IF(.NOT.OKABT(ILU)) GO TO 4000 IF(INDIC.EQ.2) GO TO 3002 INDIC=99 GO TO 1215 3002 INDIC=99 GO TO 1214 C 4100 CALL MES10(1,NOF) GO TO 4010 4110 CALL MES10(2,NOF) GO TO 4010 4120 CALL MES10(3,NOF) GO TO 4010 4130 CALL MES10(4,NOF) GO TO 4010 C C C********************************************************************** C C C READ TRANSACTION SPEC . C C********************************************************************** C C C OUTPUT MESSAGE C 500 CALL MOVEW(INIT,IBUF,9) CALL MOVEW(IRD,IBUF(10),4) CALL MOVEW(ITR,IBUF(14),17) CALL EXEC(2,ILU,IBUF,30) C C DEFINE MEDIA (FILE NAME AND CR #) C C CALL MOVEW(IFORM(14),MEDIS,3) IF(INUM(IFORM,33,6,MEDIS(4))) GO TO 5000 C C DEFINE TRANSACTION SPEC. NAME AND SECURITY CODE C 530 IF(INUM(IFORM,15,6,NFORM(4))) GO TO 532 NFORM=-1 GO TO 534 532 CALL MOVEW(IFORM(8),NFORM,3) NFORM(4)=-1 534 O=B@, * * STORAGE , CONSTANTS .. * BUFAD DEF BUFER BUFF. ADDRESS BUFA1 DEF BUF1 TAB BUFFER ADDRESS A EQU 0 A REGISTER STAD EQU BUF BUFFER STARTING ADDRESS LTAD EQU EBUF BUFFER LAST ADDRESS IST NOP P1 NOP SOURCE ADDRESS BUFFER ADDRESS ILN ABS LTAD-STAD+1 BUFFER LENGTH SPACE BYT :' 40,40 NULL BYT 0,0 TAB BYT 33,111 D.2 DEC 2 * * MESSAGE ADDRESS * AMES0 DEF AMES1-1 AMES1 DEF MES1 DEF MES2 DEF MES3 DEF MES4 DEF MES5 * * MESSAGE STORAGE * MES1 ASC 12,Missing or illegal name MES2 ASC 13,Missing or illegal number MES3 ASC 11,Illegal security code MES4 ASC 12,Illegal input character MES5 ASC 1,-1 * END MES10 |  92903-18375 1805 S C0122 &TGP11 TGP SEGM 11 SRC             H0101 >FTN4 PROGRAM TGPI1(5), 92903-16375 REV.1805 780505 C C SOURCE 92903-18375 C C C C ************************************************************** C * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * C ************************************************************** C C C C C PRGMR : JEAN CHARLES MIARD (HPG) C C C*********************************************************************** C* * C* THIS IS A SEGMENT OF THE TGP PROGRAM USED * C* TO INTERFACE TGP WITH THE IMAGE DATA BASE . DIFFERENT TASKS * C* ARE PERFORMED BY TGP11 ACCORDING TO INDIC VALUE : * C* * C* IF : INDIC = -1 : REQUEST FROM TGP1 TO CLOSE THE DATA BASE . * C* THEN TGP IS FINISHED . * C* INDIC = -2 : REQUEST FROM TGP13 TO PRINT THE LISTING OF * C* THE IMAGE OPERATIONS DEFINED FOR THE CURRENT * C* TRANSACTION SPEC. * C* INDIC = -3 : REQUEST FROM TGP7 TO PROCESS THE IMAGE ADD * C* STORAGE OF THE STORAGE STATE . * C* INDIC = 0 : REQUEST FROM TGP1 TO OPEN THE DATA BASE * C* DECLARED BY THE USER IN SCREEN 4 . * C* * C* * C*********************************************************************** C C C DECLARATIONS COMMON VARIABLES *********** C COMMON ILU,ISCRN,IQST,ISKIP,INDIC COMMON IFORM(494") COMMON JFORM(980) COMMON MFORM(16) COMMON LFORM(39) COMMON ITT COMMON IKEY(11,3) COMMON IUMAX,IMMAX COMMON IMODB COMMON ILITE(15) COMMON IMAI(45,5) COMMON IMFLG,IMAS,IMDT,IMKY COMMON KFORM(1065) COMMON ILIBR(61) COMMON NIMAG C C************ LOCAL ARRAYS************* C DIMENSION ILIST(46),ILEVL(3),INAM(3),IER(3),ISTAT(2) DIMENSION JIM(13),JSTAR(13),JDEL(15),JUP(3),JAD(3),JITM(4) DIMENSION IMSTA(6),IBUF(12),JNAM(3),KBUF(5),IER1(3) DIMENSION LNAM(3),KNAM(3),JOP(17) C LOGICAL ISBIT,INUM C C *********** DATA ASSIGNEMENTS ***************** C DATA ILIST/2H ,2HTG,2HP ,2H ,2HTG,2HP0,2H ,2HTG,2HP1,2H C,2HTG,2HP2,2H ,2HTG,2HP3,2H ,2HTG,2HP4,2H ,2HTG,2HP5,2H C,2HTG,2HP6,2H ,2HTG,2HP7,2H ,2HTG,2HP8,2H ,2HTG,2HP9,2H C,2HTG,2HP1,2H0 ,2HTG,2HP1,2H1 ,2HTG,2HP1,2H2 ,2HTG,2HP1,2H3 / DATA ILEVL/2H ,2H ,2H / DATA INAM/2HTG,2HP1,2H / DATA JNAM/2HTG,2HP7,2H / DATA LNAM/2HTG,2HP6,2H / DATA KNAM/2HTG,2HPI,2H3 / DATA JIM/2HIM,2HAG,2HE ,2HOP,2HER,2HAT,2HIO,2HNS,2H D,2HEF, C2HIN,2HED,2H :/ DATA JSTAR/2H**,2H**,2H**,2H**,2H**,2H**,2H**,2H**,2H**,2H**, C2H**,2H**,2H**/ DATA JDEL/2H- ,2HDE,2HLE,2HTE,2H E,2HNT,2HRY,2H I,2HN ,2HDA, C2HTA,2H S,2HET,2H :,2H / DATA JUP/2HUP,2HDA,2HTE/ DATA JAD/2H A,2HDD,2H / DATA JITM/2H I,2HTE,2HMS,2H :/ DATA JOP/2H ,2H* ,2HER,2HRO,2HR ,2HIN,2H O,2HPE,2HNI,2HNG,2H T, C2HHE,2H D,2HAT,2HA ,2HBA,2HSE/ C C********************************************************************* C C GO TO PERFORM THE REQUIRED PROCESSING C C********************************************************************* C IF(INDIC.EQ.-1) GO TO 900 IF(INDIC.EQ.-2) GO TO 6000 IF(INDIC.EQ.-3) GO TO 500 C C********************************************************************* C C INDIC = 0 : V0REQUEST TO OPEN THE DATA BASE C C********************************************************************* C C ISKIP CONTAINS THE DATA BASE SECURITY CODE C 100 ILIST(1)=15 CALL DBINT(IFORM(38),ISKIP,ILIST,ISTAT) IF(ISTAT.NE.0) GO TO 3000 CALL DBOPN(IFORM(38),ILEVL,ISKIP,1,ISTAT) IF(ISTAT.NE.0) GO TO 3000 C C THE DATA BASE IS SUCCESSFULY OPENED RETURN TO TGP1 SEGMENT C INDIC=2 135 CALL EXEC(8,INAM) C C*********************************************************************** C C INDIC = -3 ADD STORAGE PROCESSING C C*********************************************************************** C C 500 INDIC=0 N3=ISKIP DO 510 I=1,6 510 IMSTA(I)=KFORM(1059+I) C C*********************************************************************** C C ADD IN MASTER DATA SETS C C*********************************************************************** C C I IS POINTER IN IMSTA C IX IS SECOND WORD OF BUFFER ADD C IY IS # OF ITEMS PER ADD OPERATION C DO 530 I=1,IMSTA CALL DBINF(2HS ,2,IMSTA(I+1),IBUF) IF(IBUF.NE.0) GO TO 3000 IF(IGET1(IBUF,10).NE.1HM) GO TO 530 C C A BUFFER FOR AN ADD IN A MASTER DATA SET MUST BE CREATED C C STORAGE CODE,IMAGE STORAGE CODE,FOT FLAG,AND DATA SET TO ADD C C KFORM(N3)=52001B KFORM(N3)=IOR(KFORM(N3),IMSTA(I+1)*16) IX=N3+1 N3=N3+2 C C GET THE KEY ITEM OF THIS MASTER DATA SET C STORED IN IBUF(3) C IKFLG IS FLAG SET IF KEY ITEM IS FOUND IN THE FORM C CALL DBINF(2HI ,3,IMSTA(I+1),IBUF) IF(IBUF.NE.0) GO TO 3000 C C NOW SEARCH ITEMS FOR THIS ADD C IY=0 IKFLG=0 DO 520 J=1,45 C C K IS DATA SET TO WHICH ITEM BELONG C K=IAND(IMAI(J,3),377B) IF((K.NE.IMSTA(I+1)).OR.(IAND(IMAI(J,2),7).NE.2)) GO TO 520 C C K IS ITEM # C IY=IY+1 K=IAND(IMAI(J,1),377B) IF(K.EQ.IBUF(3)) IKFLG=1 KFORM(N3)=IALF2((IAND(IMAI(J,4),377B)/2))  KFORM(N3)=IOR(KFORM(N3),K) N3=N3+1 KFORM(N3)=IMAI(J,5) N3=N3+1 520 CONTINUE C C IF IKFLG=0 KEY ITEM NOT DEFINED FOR THIS ADD C IF(IKFLG.NE.0) GO TO 525 ITN=IBUF(3) GO TO 2900 525 KFORM(IX)=IY 530 CONTINUE C C********************************************************************* C C NOW PROCESS ADD IN DETAIL DATA SETS C C********************************************************************* C C C I IS POINTER IN IMSTA C IX POINTS TO SECOND WORD OF BUFFER C IY IS # OF ITEMS PER ADD OPERATION C C C FIRST ISOLATE DETAIL SET TO ADD C DO 800 I=1,IMSTA CALL DBINF(2HS ,2,IMSTA(I+1),IBUF) IF(IBUF.NE.0) GO TO 3000 IF(IGET1(IBUF,10).NE.1HD) GO TO 800 C C A DATA SET IS ISOLATED C FOT IS INITIALIZED TO 1 C FOT=1 C C INCLUDE STORAGE CODE,IMAGE STORAGE CODE C DATA SET # TO ADD C KFORM(N3)=50001B KFORM(N3)=IOR(KFORM(N3),IMSTA(I+1)*16) IX=N3+1 N3=N3+2 IY=0 C C SEARCH KEY ITEMS # OF THIS DATA SET C STORE THEM IN IBUF C CALL DBINF(2HI ,3,IMSTA(I+1),IBUF) IF(IBUF.NE.0) GO TO 3000 C C SEARCH KEY ITEMS IN FORM C J IS POINTER IN IBUF C ALL KEYS MUST BE DEFINED IN THE FORM BY THEIR NAME IN THE C DATA SET TO ADD OR WITH A LINKED NAME AND THEY MUST BE ASSOCIATED C IN PRIORITY ORDER WITH - AN ADD OPERATION C - A DISPLAY OPERATION C DO 600 J=1,IBUF(2) IOP=2 540 ITN=IBUF(J+2) K=ILIN(IMAI,ITN,IOP) IF(K.NE.-1) GO TO 560 CALL ITEQU(ITN,KBUF) DO 550 L=1,5 IF(KBUF(L).EQ.0) GO TO 550 K=ILIN(IMAI,KBUF(L),IOP) IF(K.NE.-1) GO TO 560 550 CONTINUE IF(IOP.EQ.2) GO TO 551 IF(IOP.EQ.5) GO TO 552 IF(IOP.EQ.0) GO TO 553 GO TO 2900 551 IOP=5 GO TO 540 552 IOP=0 GO TO 540 C-----DO IT FOR CHECK EXISTENCE. 553 IOP=3 GO TO 540 C C A KEY ITEM FOR ADD IS FOUNrCD ON LINE K OF IMAI C 560 IF((K.GT.2*IUMAX).AND.(K.LT.41)) IFOT=0 IY=IY+1 KFORM(N3)=IALF2((IAND(IMAI(K,4),377B)/2)) KFORM(N3)=IOR(KFORM(N3),ITN) N3=N3+1 KFORM(N3)=IMAI(K,5) N3=N3+1 600 CONTINUE C C NOW INCLUDE NON KEY ITEMS FOR THIS ADD C DO 620 J=1,45 K=IAND(IMAI(J,3),377B) IOP=IAND(IMAI(J,2),7) IF((K.NE.IMSTA(I+1)).OR.(IOP.NE.2)) GO TO 620 IF(ISBIT(IMAI(J,2),3)) GO TO 620 IF((J.GT.2*IUMAX).AND.(J.LT.41)) IFOT=0 IY=IY+1 KFORM(N3)=IALF2((IAND(IMAI(J,4),377B)/2)) KFORM(N3)=IOR(KFORM(N3),IAND(IMAI(J,1),377B)) N3=N3+1 KFORM(N3)=IMAI(J,5) N3=N3+1 620 CONTINUE KFORM(IX)=IY KFORM(IX-1)=IOR(KFORM(IX-1),IFOT*2000B) 800 CONTINUE C C RETURN TO TGP7 C INDIC=2 ISKIP=N3 CALL EXEC(8,JNAM) C C************************************************************************ C C ERROR PROCESSING C C*********************************************************************** C C MISSING KEY ITEM FOR ADD C 2900 CALL DBINF(2HI ,2,ITN,IBUF) IF(IBUF.NE.0) GO TO 3000 CALL MOVEW(IBUF(2),IER,3) CALL DBINF(2HS ,2,IMSTA(I+1),IBUF) IF(IBUF.NE.0) GO TO 3000 CALL MOVEW(IBUF(2),IER1,3) CALL MES11(5,1,IER,IER1) INDIC=0 CALL EXEC(8,LNAM) C C ERROR PROCESSING DATA BASE OPEN C 3000 IMES=0 INDIC=0 NOF=6+IMODB IF(ISTAT.EQ.6) IMES=2 IF(ISTAT.EQ.129) IMES=3 IF(ISTAT.NE.117) GO TO 3010 NOF=7+IMODB IMES=1 C C A SPECIAL MESSAGE EXISTS C 3010 IF(IMES.EQ.0) GO TO 3020 CALL MES11(IMES,NOF) GO TO 135 C C A GENERAL PRINT MESSAGE FOR IMAGE MUST BE PRINTED C IER CONTAINS THE ASCII CODE OF THE ERROR # C 3020 CALL CNUMD(ISTAT,IER) CALL MES11(4,NOF,IER) GO TO 135 C 5000 STOP 5000 C C*********************************************************************** C C INDIC = -2 PRINT LISTING OF IMAGE OPERATIONS : C C*********************************************************************** C C IF MODE OF OPERATION IS L OPEN THE DATA BASE C 6000 IF(IGET1(IFORM,13).NE.1HL) GO TO 6005 IF(INUM(IFORM,81,5,N)) GO TO 5000 ILIST(1)=15 CALL DBINT(IFORM(38),N,ILIST,ISTAT) IF(ISTAT.NE.0) GO TO 6004 CALL DBOPN(IFORM(38),ILEVL,N,1,ISTAT) IF(ISTAT.EQ.0) GO TO 6005 6004 CALL EXEC(2,ISKIP,JOP,17) GO TO 6100 C C PRINT HEADER C C 6005 CALL BLANC(ILIST,15) CALL EXEC(3,1100B+ISKIP,1) CALL MOVEW(JIM,ILIST(3),13) CALL EXEC(2,ISKIP,ILIST,15) CALL BLANC(ILIST,15) CALL MOVEW(JSTAR,ILIST(3),13) CALL EXEC(2,ISKIP,ILIST,15) CALL EXEC(3,1100B+ISKIP,1) C C FIND STORAGE STATE C I=11 DO 6010 K=1,100 I=KFORM(I) IF(IAND(KFORM(I+1),140B).EQ.140B) GO TO 6020 6010 CONTINUE STOP 6010 C C FIND IMAGE STORAGE C 6020 L=KFORM(I) I=I+2 DO 6030 J=1,4 M=IAND(KFORM(I),170000B)/4096 IF(M.EQ.5) GO TO 6040 IF(M.LT.4) I=I+6 IF(M.EQ.4) I=I+4 6030 CONTINUE STOP 6030 C C PRINT INFORMATION C C OPERATION AND DATA SET C 6040 N=IAND(KFORM(I),17B) IF(N.EQ.0) GO TO 6100 M=IAND(KFORM(I),1760B)/16 CALL BLANC(ILIST,23) CALL MOVEW(JDEL,ILIST(6),15) IF(N.EQ.1) CALL MOVEW(JAD,ILIST(7),3) IF(N.EQ.2) CALL MOVEW(JUP,ILIST(7),3) CALL DBINF(2HS ,2,M,IBUF) IF(IBUF.NE.0) STOP 6041 CALL MOVEW(IBUF(2),ILIST(21),3) CALL EXEC(2,ISKIP,ILIST,23) IF(N.EQ.3) GO TO 6100 C C ITEMS TO BE ADDED OR UPDATED C CALL EXEC(3,1100B+ISKIP,1) CALL BLANC(ILIST,23) CALL MOVEW(JITM,ILIST(16),4) I=I+1 IF(I.NE.L) GO TO 6050 L=KFORM(I) I=I+2 6050 M=KFORM(I) DO 6080 K=1,M I=I+1 IF(I.NE.L) GO TO 6070 L=KFORM(I) I=I+2 6070 N=IAND(KFO=*($RM(I),377B) CALL DBINF(2HI ,2,N,IBUF) IF(IBUF.NE.0) STOP 6070 CALL MOVEW(IBUF(2),ILIST(21),3) CALL EXEC(2,ISKIP,ILIST,23) CALL BLANC(ILIST,23) I=I+1 IF(I.NE.L) GO TO 6080 L=KFORM(I) I=I+2 6080 CONTINUE C C NEXT IMAGE OPERATION C I=I+1 IF(I.NE.L) GO TO 6090 L=KFORM(I) I=I+2 6090 CALL EXEC(3,1100B+ISKIP,1) GO TO 6040 C C RETURN TO TGP13 C 6100 INDIC=-1 CALL EXEC(8,KNAM) C C************************************************************************ C C INDIC = -1 CLOSE DATA BASE C C*********************************************************************** C 900 CALL DBCLS(0,ISTAT) 999 END END$ *  92903-18376 1805 S C0122 &MES11 TGP SEGM 11 SUBR SRC             H0101 ASMB,R NAM MES11,7 92903-16376 REV.1805 780511 * * SOURCE 92903-18376 * SPC 2 ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** SPC 2 SUP * ********************************************************************** * * * THIS SUBROUTINE IS CALLED BY THE SEGMENT ANSWR * * OF THE FORMG PROGRAM TO WRITE AN ERROR MESSAGE ON THE TERMINAL. * * THE ERROR MESSAGE IS PRINTED ON LINE 24 OF THE * * SCREEN AND THE CURSOR IS MOVED TO THE WRONG FIELD. * * THIS SUBROUTINE IS CALLED WITH TWO PARAMETERS : * * * * - PAR#1 = ERROR MESSAGE # TO OUTPUT * * - PAR#2 = WRONG FIELD # ON THE SCREEN * * * ********************************************************************** * * ENT MES11 ENTRY POINT EXT EXEC EXT .ENTR EXT &REMP EXT &MVW COM ILU TERM. LU * * GET CALLING PARAMETERS AND INITIALISE * NMESS NOP FIRST PARM. ADDRESS NOF NOP SECD. PARM. ADDRESS NIER NOP THIRD PARAM ADDRESS NIER1 NOP FOURTH ........... MES11 NOP ENTRY POINT JSB .ENTR SUBR. TO GET DEF NMESS PARM. ADDRESS LDA BUFAD INITIALIZE LDB SPACE ERROR MESSAGE JSB &REMP BUFFER DEC -35 TO BLANK LDA BUFA1 INITIALIZE LDB NULL TAB BUFFER JSB  &REMP TO NULL DEC -50 * * MOVE ERROR MESSAGE IN OUTPUT BUFFER * LDA NIER GET ERROR # IMAGE ADDRESS LDB ANMES GET ADDRESS OF DEST BUFFER JSB &MVW DEC 3 LDA NIER LDB ANMS1 JSB &MVW DEC 3 LDA NIER1 LDB ANMS2 JSB &MVW DEC 3 * LDA NMESS,I GET ERROR MESSAGE # ADA AMES0 COMPUTE MESSAGE LDB A,I ADDRESS STB P1 STORE IT CMB,INB MINUS STARTING ADDRESS STB IST OF MESSAGE IN IST INA COMPUTE NEXT MESSAGE LDA A,I STARTING ADDRESS ADA IST COMPUTE MESSAGE LENGTH STA P2 STORE IT LDA P1 BUFFER SOURCE ADDRESS LDB BUFAD BUFFER DEST ADDRESS JSB &MVW MOVE WORDS P2 NOP BUFFER LENGTH * * INCLUDE # OF NECESSARY TABS * LDA NOF,I GET WRONG FIELD # CMA,INA MAKE IT NEG. ISZ A INCREMENT: IS FIRST FIELD ? RSS NO JMP WRIT YES OUTPUT BUFFER STA P3 STORE NEG. # OF TABS LDA BUFA1 TAB BUFFER ADDRESS LDB TAB TAB JSB &REMP INCLUDE TABS P3 NOP IN BUFFER * * WRITE MESSAGE * WRIT JSB EXEC WRITE EXEC CALL DEF *+5 RETURN POINT DEF D.2 CODE EXEC DEF ILU CONTROL WORD DEF BUF BUFFER LOCATION DEF ILN BUFFER LENGTH * * RETURN TO CALLING PROGRAM * JMP MES11,I * * BUFFER DATA * BUF BYT 33,130,33,46,141,62,62,162,60,103 FORMAT OFF:POS.CURSOR BYT 33,112,15,12,40,0 BYT 33,46,144,103 INVERSE VIDEO BLINKING ASC 2,ERRO BYT 122,33,46,144,100 END ENHANCEMENT ASC 2, : BUFER BSS 35 MESSAGE BUFFER BYT 33,127,33,110 FORMAT ON * HOME CURSOR BUF1 BSS 50 TAB BUFFER BYT 33,142 KEYBOARD ENABLE EBUF BYT 0,137 SUPPRESS , * * STORAGE , CO+ NSTANTS .. * BUFAD DEF BUFER BUFF. ADDRESS BUFA1 DEF BUF1 TAB BUFFER ADDRESS ANMES DEF INMES IMAGE ERROR # ADDRESS ANMS1 DEF INMS1 ANMS2 DEF INMS2 A EQU 0 A REGISTER STAD EQU BUF BUFFER STARTING ADDRESS LTAD EQU EBUF BUFFER LAST ADDRESS IST NOP P1 NOP SOURCE ADDRESS BUFFER ADDRESS ILN ABS LTAD-STAD+1 BUFFER LENGTH SPACE BYT 40,40 NULL BYT 0,0 TAB BYT 33,111 D.2 DEC 2 * * MESSAGE ADDRESS * AMES0 DEF AMES1-1 AMES1 DEF MES1 DEF MES2 DEF MES3 DEF MES4 DEF MES5 DEF MES6 * * MESSAGE STORAGE * MES1 ASC 15,Wrong data base security code MES2 ASC 10,Data base not found MES3 ASC 8,Data base locked MES4 ASC 7,IMAGE error # INMES BSS 3 MES5 ASC 4,Key item BYT 40,0 INMS1 BSS 3 ASC 22, must be defined to add an entry in data set BYT 40,0 INMS2 BSS 3 MES6 ASC 1,-1 * * END MES11   92903-18377 1805 S C0122 &TGP12 TGP SEGM 12 SRC             H0101 ?FTN4 PROGRAM TGPI2(5), 92903-16377 REV.1805 780519 C C SOURCE 92903-18377 C C C C ************************************************************** C * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * C ************************************************************** C C C C C PRGMR : JEAN CHARLES MIARD (HPG) C C********************************************************************* C* * C* THIS IS A SEGMENT OF THE TGP PROGRAM USED TO INTERFACE * C* TGP WITH IMAGE . ACCORDING TO INDIC VALUE DIFFERENT TASKS ARE * C* EXECUTED : * C* * C* IF : INDIC = 0 : COMPILATION OF IMAGE INFORMATION AT THE * C* QUESTION LEVEL . THE RESULTS OF THIS COMPIL- * C* ATION ARE STORED IN THE IMAI BUFFER . * C* REQUEST FROM TGP9 FOR ADD,FIND,UPDATE AND * C* CHECK EXISTENCE OPERATIONS . * C* REQUEST FROM TGP6 FOR DELETE AND DISPLAY * C* OPERATIONS . * C* INDIC = -8 : PROCESS SYSTEM ADDED INFORMATION . REQUEST * C* FROM TGP6 . * C* * C********************************************************************* C C C DECLARATIONS COMMON VARIABLES ************** C COMMON ILU,ISCRN,IQST,ISKIP,INDIC COMMON IFORM(494) COMMON JFORM(980) COMMON MFORM(16) COMMON LFORM(39) COMMON ITT COEMMON IKEY(11,3) COMMON IUMAX,IMMAX COMMON IMODB COMMON ILITE(15) COMMON IMAI(45,5) COMMON IMFLG,IMAS,IMDT,IMKY COMMON KFORM(1065) COMMON ILIBR(61) COMMON NIMAG C C LOCAL VARIABLES ************* C DIMENSION INAME(3),IBUF(12),ID(3),IER(3),JNAME(3),KBUF(5) C LOGICAL ISBIT,ISSPA C DATA INAME/2HTG,2HP9,2H / DATA JNAME/2HTG,2HP6,2H / C C*********************************************************************** C C GO TO THE REQUIRED PORTION OF TGP12 C C********************************************************************** C C IF(INDIC.EQ.-1) PAUSE 1203 IF(INDIC.EQ.-6) PAUSE 1204 IF(INDIC.EQ.0) GO TO 95 C C********************************************************************* C C INDIC = -8 SYSTEM ADDED INFORMATION PROCESSING C C********************************************************************* C C IX IS ITEM COUNT 1/5 C IX=1 INDIC=2 80 IF(IGET1(MFORM,IX).NE.1HX) GO TO 3030 IF(.NOT.(ISSPA(MFORM,6*IX-1,6))) GO TO 3030 N=40+IX CALL MOVCA(MFORM,6*IX-1,ID,1,6) IMAI(N,2)=1 IF(IGET1(MFORM,28+IX).EQ.1HA) IMAI(N,2)=2 GO TO 110 C C************************************************************************ C C INDIC = 0 IMAGE COMPILATION AT THE QUESTION LEVEL C C************************************************************************ C C C C N IS A POINTER TO THE CURRENT LINE IN IMAI C C ID CONTAINS THE ITEM NAME C C C C************************************************************************ C C GET ITEM AND DATA SET CHARACTERISTICS AND STORE IN IMAI BUFFER C C************************************************************************ C C 95 IF(ISCRN.EQ.16) GO TO 100 N=2*IQST-1 CALL MOVCA(JFORM,(24+(IQST-1)*98),ID,1,6) IF(ISCRN.EQ.15) GO TO 120 GO TO 110 100 CALL MOVCA(JFORM,(83+(IQST-1)*98),ID,1,6) N=2*IQST C C NOW FILL IN THE IMAI LINE C C C GET DATA ITEM NUMBER C 110 IMODE=5 ITYPE=2HI CALL DBINF(ITYPE,IMODE,ID,IBUF) IF(IBUF.NE.0) GO TO 3000 IMAI(N,1)=IBUF(2) C C GET DATA ITEM CHARACTERISTICS C IMODE=2 CALL DBINF(ITYPE,IMODE,IMAI(N,1),IBUF) IF(IBUF.NE.0) GO TO 3000 C C CHECK THAT ITEM TO STORE TRANSACTION HEADER INFO (DATE,TIME..) C HAS A GOOD FORMAT C IF(ISCRN.NE.17) GO TO 118 IF(IGET1(IBUF,10).NE.2HU ) GO TO 115 IF((IX.EQ.2).AND.(IBUF(7).NE.1)) GO TO 115 IF((IX.EQ.3).AND.(IBUF(7).NE.3)) GO TO 115 IF((IX.NE.1).AND.(IX.NE.4)) GO TO 118 IF(IBUF(7).EQ.2) GO TO 118 115 IMES=24 GO TO 3010 C C SEARCH TYPE C 118 I=IBUF(5) I=IALF2(IAND(I,177400B)) IF(I.EQ.1) IMAI(N,2)=IOR(IMAI(N,2),10B) C C ITEM TYPE C IBUF(5)=IAND(IBUF(5),377B) IF(IBUF(5).EQ.111B) IMAI(N,2)=IOR(IMAI(N,2),10000B) IF(IBUF(5).EQ.122B) IMAI(N,2)=IOR(IMAI(N,2),20000B) C C ITEM LENGTH ,ITEM OFFSET C IMAI(N,4)=IBUF(7)*2 IMAI(N,4)=IOR(IMAI(N,4),IBUF(8)*256) C C DATA SET TO WHICH ITEM BELONG C IMAI(N,3)=IBUF(9) NDS=IBUF(9) C C GET DATA SET CHARACTERISTICS C ITYPE=2HS CALL DBINF(ITYPE,IMODE,IMAI(N,3),IBUF) IF(IBUF.NE.0) GO TO 3000 C C DATA SET TYPE C IBUF(5)=IAND(IBUF(5),377B) IF(IBUF(5).EQ.115B) IMAI(N,2)=IOR(IMAI(N,2),100000B) IF(IBUF(5).EQ.101B) IMAI(N,2)=IOR(IMAI(N,2),140000B) C C-----IF SCR 16, ADD TO MSTR IS ILLEGAL IF(ISCRN.NE.17) GO TO 120 C-----ADD? IF(IAND(IMAI(N,2),7).NE.2) GO TO 120 C-----ERROR IF ADD TO MSTR IF(.NOT.ISBIT(IMAI(N,2),15)) GO TO 120 C-----"ADD TO MSTR NOT ALLOWED" IMES=33 GO TO 3010 C C C IMAGE FUNCTION ? C C 120 I=IAND(IMAI(N,2),7B) C C********************************************************************* C C IMAGE OPERATION IS ADD FIRST CHECKS ONLY C C********************************************************************** C C CHECK IF OPERATION IS ADD THAT NO EQUIVALENT KEY ITEM HAS BEEN C DEFINED FOR AN OTHER ADD C IF(I.NE.2) GO TO 180 IF(.NOT.(ISBIT(IMAI(N,2),3))) GO TO 160 CALL ITEQU(IMAI(N,1),KBUF) IF(KBUF.NE.-1) GO TO 130 STOP 432 130 DO 140 J=1,5 IF(KBUF(J).EQ.0) GO TO 140 K=ILIN(IMAI,KBUF(J),2) IF(K.NE.-1) GO TO 150 140 CONTINUE GO TO 160 150 CALL DBINF(2HI ,2,KBUF(J),IBUF) IF(IBUF.NE.0) GO TO 3000 CALL MOVEW(IBUF(2),IER,3) IMES=22 GO TO 3010 C C C BUILD BUFFER TO CONTAIN DATA SET # TO ADD C KFORM(1060) IS # OF DATA SETS C .........1......1ST DATA SET # C . . C KFORM(1065) IS 5TH DATA SET # C C CHECK THAT NO MORE THAN 5 IMAGE OPERATIONS ARE DEFINED C 160 K=IAND(IMAI(N,3),377B) IF(KFORM(1060).NE.0) GO TO 165 KFORM(1060)=1 KFORM(1061)=K GO TO 180 165 DO 170 J=1,KFORM(1060) IF(KFORM(1060+J).EQ.K) GO TO 180 170 CONTINUE J=0 IF(IAND(IMFLG,14B).NE.0) J=1 IF(J+KFORM(1060).LT.5) GO TO 175 IMES=21 GO TO 3010 175 KFORM(1060)=KFORM(1060)+1 KFORM(1060+KFORM(1060))=K C C C******************************************************************* C C DISPATCH IMAGE OPERATIONS C C******************************************************************** C 180 IF(I.EQ.3) GO TO 200 IF(I.EQ.0) GO TO 300 IF(I.EQ.2) GO TO 450 GO TO 500 C C******************************************************************** C C--IMAGE FUNCTION IS CHECK AGAINST DATA BASE (IE, CHECK EXISTENCE) C C******************************************************************** C C-----1ST TEST, CE ONLY ALLOWED IN MASTER (NOT IN DETAIL) 200 IF(ISBIT(IMAI(N,2),15)) GO TO 201 C-----"CHECK EXISTENCE ONLY ALLOWED IN MASTER DS" IMES=30 GO TO 3010 C C PREREQUISITE KEY ITEM, NO FIND OR STORAGE ON SAME DATA-SET C C-----CHECK EXISTENCE IS INCOMPATIBLE WITH FIND IN SAME DATA SET C C-----IS THERE A FIND PREVIOUSLY DEFINED? 201 IF(.NOT.ISBIT(IMFLG,1)) GO TO 204 K=-1 C-----DONE SEARCHING IMAI FOR A FIND? 202 K=K+2 IF(K.GT.N) GO TO 204 C-----FIND? IF(IMAI(K,1).EQ.0) GOTO 202 IF(IAND(IMAI(K,2),7B).NE.0) GO TO 202 C-----FOUND ONE, NOW SEE IF IT IS IN SAME DATA SET. IF(NDS.NE.IAND(IMAI(K,3),377B)) GO TO 202 C-----"CHECK EXISTENCE INCOMPATIBLE WITH FIND IN SAME DATA SET" IMES=28 GO TO 3010 C C-----CHECK EXISTENCE IS INCOMPATIBLE WITH ADD IN SAME DS. C 204 IF(.NOT.ISBIT(IMFLG,0)) GO TO 210 K=-1 206 K=K+2 C-----DONE SEARCHING IMAI FOR ADD? IF(K.GT.N) GO TO 210 C-----ADD? IF(IAND(IMAI(K,2),7B).NE.2) GO TO 206 C-----YES, NOW SEE IF CE & ADD ARE IN SAME DS. IF(NDS.NE.IAND(IMAI(K,3),377B)) GO TO 206 C-----"CHECK EXISTENCE INCOMPATIBLE WITH ADD IN SAME DS" IMES=1 GO TO 3010 C 210 IF(ISBIT(IMAI(N,2),3)) GO TO 215 IMES=2 GO TO 3010 C C CREATE IMAGE EDITS FOR CHECK AGAINST DATA BASE C C ITEM BELONGS TO A MASTER . EDIT CODE 1 C 215 IF(.NOT.(ISBIT(IMAI(N,2),15))) GO TO 220 IMAI(N,2)=IOR(IMAI(N,2),100B) GO TO 230 C C ITEM BELONGS TO A DETAIL DATA SET . CODE EDIT 4 C 220 IMAI(N,2)=IOR(IMAI(N,2),400B) IMAI(N,1)=IOR(IMAI(N,1),IMAI(N,1)*256) 230 IMAI(N,3)=IOR(IMAI(N,3),IMAI(N,3)*256) INDIC=3 C C SET CHECK FLAG C IMFLG=IOR(IMFLG,20B) GO TO 3030 C C*********************************************************************** C C IMAGE FUNCTION IS FIND C C********************************************************************** C C FIND MUST BE U QUESTION C 300 IF(IQST.LE.IUMAX) GO TO 302 IMES=5 GO TO 3010 C-----IS THERE A CHECK EXISTENCE PREVIOUSLY DEFINED? 302 IF(.NOT.ISBIT(IMFLG,4)) GO TO 305 C-----SEARCH IMAI FOR CHECK EXISTENCE. K=-1 C-----DONE SEARCHING IMAI FOR CHECK EXISTENCE? 303 K=K+2 IF(K.GT.N) GO TO 305 C-----CHECK EXISTENCE? IF(IAND(IMAI(K,2),7B).NE.3) GO TO 303 C-----FOUND ONE, NOW SEE IF IT IS IN SAME DATA SET AS THE FIND. IF(NDS.NE.IAND(IMAI(K,3),377B)) GO TO 303 C-----"FIND INCOMPATIBLE WITH CHECK EXISTENCE IN SAME DATA SET" IMES=29 GO TO 3010 C C NO DELETE,UPDATE BEFORE FIND C 305 N1=IAND(IMFLG,14B) IF(N1.EQ.0) GO TO 310 IMES=14 GO TO 3010 C C THE FOLLOWING SECTION APPLIES IF THE ITEM BELONGS TO A DETAIL D.S. C 310 IF(ISBIT(IMAI(N,2),15)) GO TO 360 C C FIRST QUESTION ASSOCIATED WITH FIND MUST BE KEY ITEM C IF((IMAS.NE.0).OR.(IMDT.NE.0)) GO TO 315 IF(ISBIT(IMAI(N,2),3)) GO TO 315 IMES=7 GO TO 3010 C C IS THERE ALREADY A FIND IN A MASTER D.S. IF YES CHECK MASTER C AND DETAIL ARE LINKED C C GET KEY ITEM# OF MASTER C 315 IF(IMAS.EQ.0) GO TO 330 C=====DO NOT ALLOW FIND IN A MASTER/DETAIL COMBINATION !!! GOTO 335 C CALL DBINF(2HI ,3,IMAS,IBUF) C IF(IBUF.NE.0) GO TO 3000 C C GET LINKED DATA SET # TO MASTER C C CALL DBINF(2HS ,4,IBUF(3),IBUF) C IF(IBUF.NE.0) GO TO 3000 C C DO 320 I=1,IBUF(2) C IF(IBUF(2*I+1).EQ.NDS) GO TO 330 C320 CONTINUE C GOTO 335 C C ALREADY FIND IN DETAIL ? C IF YES CHECK ITEM BELONGS TO THAT DATA SET C 330 IF(IMDT.EQ.0) GO TO 340 IF(IMDT.EQ.NDS) GO TO 340 335 IMES=6 GO TO 3010 C 340 IMDT=NDS C C SET IMKY (KEY ITEM TO DRIVE THE FIND IN THE DETAIL D.S.) C IF(.NOT.(ISBIT(IMAI(N,2),3))) GO TO 350 IF(IMKY.EQ.0) IMKY=IAND(IMAI(N,1),377B) 350 GO TO 410 C C C THIS SECTION APPLIES TO FIND IF THE ITEM BELONGS TO A MASTER C DATA SET C C C CHECK THAT THERE IS NO FIND OPERATIONS IN OTHER MASTER DATA SETS C AND THAT ITEM IS KEY ITEM C C 360 IF(ISBIT(IMAI(N,2),3)) GO TO 370 IMES=9 GO TO 3010 370 IF(IMAS.EQ.0) GO TO 380 IMES=6 [>GO TO 3010 C C CHECK THAT NO FIND IN DETAIL D.S IS DEFINED C 380 IF(IMDT.EQ.0) GO TO 400 IMES=6 GO TO 3010 C 400 IMAS=NDS C C END OF FIND PROCESSING SET FIND FLAG C 410 IMFLG=IOR(IMFLG,2) INDIC=3 GO TO 3030 C C C*********************************************************************** C C IMAGE OPERATION IS ADD C C********************************************************************** C C C CHECK THAT : - NO ADD IN AUTOMATIC MASTER DATA SET C - ITEM TO ADD IN A MASTER MUST BE U QUESTION C - CHECK AGAINST DATA BASE IS NOT ON SAME DATA-SET C - NO DELETE IS DEFINED C C-----ADD INCOMPATIBLE WITH CHECK EXISTENCE IN THE SAME DATA SET C 450 K=-1 452 K=K+2 C-----DONE SEARCHING IMAI? IF(K.GT.N) GO TO 458 C-----CHECK EXISTENCE? IF(IAND(IMAI(K,2),7).NE.3) GO TO 452 C-----YES, NOW SEE IF IT IS IN SAME DATA SET. IF(IAND(IMAI(N,3),377B).NE.IAND(IMAI(K,3),377B)) GO TO 452 C-----ERR "CHECK EXISTENCE INCOMPATIBLE WITH ADD/UPDATE/DELETE IN SAME DS" IMES=1 GO TO 3010 458 IF(.NOT.(ISBIT(IMFLG,2))) GO TO 460 IMES=23 GO TO 3010 460 IF(.NOT.(ISBIT(IMAI(N,2),15))) GO TO 480 IF(.NOT.(ISBIT(IMAI(N,2),14))) GO TO 470 IMES=11 GO TO 3010 470 IF((IQST.LE.IUMAX).OR.(ISCRN.EQ.17)) GO TO 480 IMES=12 GO TO 3010 C C C C IF ITEM TO ADD BELONG TO "TRANSACTION HEADER" (ISCRN=17) CHECK : C - ITEM IS NOT KEY IN MASTER D.S. C - IF ITEM IS KEY IN DETAIL D.S. MASTER MUST BE AUTOMATIC C 480 IF(ISCRN.NE.17) GO TO 487 IF(.NOT.(ISBIT(IMAI(N,2),3))) GO TO 487 IF(.NOT.(ISBIT(IMAI(N,2),15))) GO TO 483 IMES=19 GO TO 3010 C 483 K=IAND(IMAI(N,1),377B) CALL DBINF(2HS ,4,K,IBUF) IF(IBUF.NE.0) GO TO 3000 CALL DBINF(2HS ,2,IBUF(3),IBUF) IF(IBUF.NE.0) GO TO 3000 IF(IGET1(IBUF,10).EQ.1HA) GO TO 487 IMES=20  GO TO 3010 C C END OF ADD PROCESSING SET ADD AND IMAGE STORAGE FLAG C 487 IMFLG=IOR(IMFLG,100001B) INDIC=3 GO TO 3030 C C*********************************************************************** C C IMAGE OPERATION IS DISPLAY,UPDATE OR DELETE (5,1,4) C C************************************************************************ C C C VERIFY FIND OR CHECK AGAINST DATA BASE IS ALREADY DEFINED C 500 IF(ISBIT(IMFLG,1)) GO TO 510 C-----DISPLAY? IF(I.EQ.5) GO TO 502 C-----"A FIND MUST HAVE BEEN PREVIOUSLY DEFINED" IMES=13 GO TO 3010 C-----FUNCTION IS DISPLAY, VERIFY THAT A CHECK EXISTENCE HAS BEEN DEFINED. 502 IF(ISBIT(IMFLG,4)) GO TO 510 C-----"A FIND OR CHECK EXISTENCE MUST HAVE PREVIOUSLY BEEN DEFINED" IMES=26 GO TO 3010 C-----IF NOT DISPLAY, GO TO DELETE OR UPDATE ROUTINE. 510 IF(I.NE.5) GO TO 513 C C C C************************************************************************ C C IMAGE OPERATION IS DISPLAY C C************************************************************************ C C-----"DISPLAY FROM DETAIL DATA-SET MUST BE DURING M-QUESTION" IMES=32 IF(.NOT.ISBIT(IMAI(N,2),15) .AND. IQST.LE.IUMAX) GOTO 3010 C C-----DETERMINE IF A FIND OR CHECK EXISTENCE HAS ALREADY BEEN DEFINED C FOR THIS DATA SET, AND WHICH ONE IT IS. C IF ANOTHER DISPLAY HAS BEEN PREVIOUSLY DEFINED, THIS DISPLAY MUST C BE FROM THE SAME DATA SET. IF NOT, IT CANNOT BE DONE. C K=N KL=0 551 K=K-2 C-----DONE SEARCHING BACKWARDS FOR DISPLAY, FIND, OR CHECK EXISTENCE IN C IMAI? IF NO FIND OR CHECK EXISTENCE IS FOUND, PRINT ERROR MESSAGE. C-----"A FIND OR CHECK EXISTENCE MUST BE PREVIOUSLY DEFINED FOR THIS ITEM" IMES=26 IF(K.LT.1) GO TO 3010 C-----FAF? IF(K.NE.2*IUMAX) GO TO 555 C-----SEARCH FORWARD FOR A FIND IN A DETAIL DURING U-QUESTION C BIT 9 IN IMAI(N,2) MAY NOT BE SET YET. DO 5531 KK=1,K,2 IF(IMAI(KK,1).EQ.0) GOa TO 5531 IF(IAND(IMAI(KK,2),140007B).EQ.0) GO TO 5532 5531 CONTINUE GO TO 555 5532 KL=1 IF(NDS.EQ.IAND(IMAI(KK,3),377B)) GO TO 556 C-----CHECK EXISTENCE OR FIND IN A MASTER? 555 IF(IMAI(K-1,1).EQ.0) GO TO 5555 KK=IAND(IMAI(K-1,2),7) IF(KK.EQ.3) GO TO 5553 IF(KK.NE.0) GO TO 5555 IF(.NOT.ISBIT(IMAI(K-1,2),15)) GO TO 5555 5553 KL=1 IF(NDS.EQ.IAND(IMAI(K-1,3),377B)) GO TO 556 C-----DISPLAY? 5555 IF(IMAI(K,1).EQ.0) GO TO 551 IF(IAND(IMAI(K,2),7).NE.5) GO TO 551 IF(IAND(IMAI(K,3),377B).EQ.NDS) GO TO 556 C-----NO, "DISPLAY FROM ANOTHER DATA SET ALREADY DEFINED" IMES=31 C-----IF CHECK/FIND FOUND BEFORE THE DISPLAY, PRINT C "A FIND OR CHECK EXISTENCE MUST BE PREVIOUSLY DEFINED FOR THIS ITEM" IF(KL.EQ.1) IMES=26 GO TO 3010 C C-----NOW SET THE DISPLAY FLAG. C 556 IMFLG=IOR(IMFLG,40B) 557 INDIC=5 GO TO 3030 C C*********************************************************************** C C IMAGE OPERATION IS DELETE OR UPDATE C C********************************************************************** C C-----UPDATE INCOMPATIBLE WITH CHECK EXISTENCE IN THE SAME DS. C 513 IF(I.EQ.4) GO TO 600 IF((NDS.EQ.IMAS).OR.(NDS.EQ.IMDT)) GO TO 520 C-----"ITEM DOES NOT BELONG TO THE ENTRY ISOLATED BY A FIND" IMES=15 GO TO 3010 C C IF FIND IN MASTER AND DETAIL LINKED ITEM MUST BELONG C TO DETAIL DATA SET C 520 IF(.NOT.((NDS.EQ.IMAS).AND.(IMDT.NE.0))) GO TO 530 IMES=15 GO TO 3010 C C FOR UPDATE IF : C ITEM BELONGS TO A MASTER DATA SET IT MUST BE U QUESTION (UPDATE ONLY) C ..................DETAIL.....................M......... C 530 IF(NDS.NE.IMAS) GO TO 540 IF((IQST.LE.IUMAX).OR.(ISCRN.EQ.17)) GO TO 600 IMES=17 GO TO 3010 540 IF((IQST.GT.IUMAX).OR.(ISCRN.EQ.17)) GO TO 600 IMES=18 GO TO 3010 600 K=1 C-----DONE SEARCHING FOR UPATE? 6010 IF(K.GT.N) GO TO 6020 C-----CHECK DEXISTENCE? IF(IAND(IMAI(K,2),7B).EQ.3) GO TO 6012 GO TO 6013 C-----YES, NOW SEE IF IT IS IN SAME DATA SET. 6012 IF(NDS.EQ.IAND(IMAI(K,3),377B)) GO TO 6014 6013 K=K+2 GO TO 6010 C-----ERR "CHECK EXISTENCE INCOMPATIBLE WITH UPDATE IN SAME DATA SET" 6014 IMES=1 GO TO 3010 C C-----DELETE INCOMPATIBLE WITH CHECK EXISTENCE IN SAME DATA SET. C C-----DELETE? C 6020 IF(I.NE.4) GO TO 603 C-----YES, 1ST FIND DS# OF FIND. K=1 C-----DONE SEARCHING FOR THE 'FIND'? 6021 IF(K.GE.N) GO TO 603 IF(IMAI(K,1).EQ.0) GOTO 60215 C-----FIND? IF(IAND(IMAI(K,2),7B).EQ.0) GO TO 6022 60215 K=K+2 GO TO 6021 C-----FOUND A 'FIND', SAVE DS# 6022 IDSNO=IAND(IMAI(K,3),377B) C-----SEARCH FOR ALL CHECK EXISTENCES & TEST FOR SAME DS# K=1 C-----DONE SEARCHING FOR ALL CHECK EXISTENCES? 6023 IF(K.GT.N) GO TO 603 C-----CHECK EXISTENCE? IF(IAND(IMAI(K,2),7B).NE.3) GO TO 6024 C-----YES, NOW SEE IF SAME DS# AS FIND. IF(IDSNO.EQ.IAND(IMAI(K,3),377B)) GO TO 6025 C-----DONE? 6024 K=K+2 GO TO 6023 C-----ERR "CHECK EXISTENCE INCOMPATIBLE WITH DELETE IN SAME DATA SET" 6025 IMES=1 GO TO 3010 C C VERIFY THAT CHECK AGAINST DATA BASE IS NOT ON SAME DATA-SET C 603 IF(IAND(IMAI(N,2),140000B).NE.140000B) GO TO 605 IMES=25 GO TO 3010 C C************************************************************************ C C IMAGE OPERATION IS DELETE C C************************************************************************ C C CHECK THAT DELETE IN MASTER D.S. IS U QUESTION C .....................DETAIL.........M.......... C CHECK THAT NO UPDATE OR ADD IS DEFINED C CHECK THAT NO MORE THAN 5 IMAGE OPERATIONS ARE DEFINED C 605 IF(KFORM(1060).NE.5) GO TO 611 IMES=21 GO TO 3010 611 IF(I.NE.4) GO TO 650 IF(.NOT.(ISBIT(IMFLG,0))) GO TO 613 IMES=23 GO TO 3010 613 IX=IMDT IF(IX.EQ.0) IX=IMAS CALL DBINF(2HS ,2,IX,IBUF) f IF(IBUF.NE.0) GO TO 3000 IF(IGET1(IBUF,10).NE.1HA) GO TO 614 IMES=25 GO TO 3010 614 IF(IMDT.NE.0) GO TO 612 IF(IQST.LE.IUMAX) GO TO 618 IMES=17 GO TO 3010 612 IF(IQST.GT.IUMAX) GO TO 618 IMES=18 GO TO 3010 C 618 IF(.NOT.(ISBIT(IMFLG,3))) GO TO 620 IMES=8 GO TO 3010 C C END OF DELETE PROCESSING SET DELETE AND IMAGE STORAGE FLAG C 620 IMFLG=IOR(IMFLG,100004B) INDIC=4 GO TO 3030 C C************************************************************************ C C IMAGE OPERATION IS UPDATE C C************************************************************************* C C CHECK NO DELETE IS DEFINED C C 650 IF(.NOT.(ISBIT(IMFLG,2))) GO TO 655 IMES=8 GO TO 3010 655 IF(.NOT.(ISBIT(IMAI(N,2),3))) GO TO 660 IMES=16 GO TO 3010 C C SET UPDATE AND IMAGE STORAGE FLAGS C 660 IMFLG=IOR(IMFLG,100010B) INDIC=3 GO TO 3030 C C********************************************************************** C C INDIC = -6 BUILD IMAGE EDITS C C********************************************************************** C C IMAGE ADD EDITS C C NO EDITS ON NON KEY ITEMS C C K IS IMAGE OPERATION # C 1100 IF(.NOT.(ISBIT(IMFLG,0))) GO TO 1300 DO 1200 I=1,45 K=IAND(IMAI(I,2),7) IF(K.NE.2) GO TO 1200 IF(.NOT.(ISBIT(IMAI(I,2),3))) GO TO 1200 IF(.NOT.(ISBIT(IMAI(I,2),15))) GO TO 1210 C C MASTER DATA SETS C C KEY ITEM : CODE EDIT 2 + LOCK C IMAI(I,2)=IOR(IMAI(I,2),2200B) IMAI(I,3)=IOR(IMAI(I,3),IALF2(IMAI(I,3))) GO TO 1200 C C ADD IN DETAIL DATA SET C K IS IMAGE ITEM # C 1210 K=IAND(IMAI(I,1),377B) C C GET MASTER DATA SET # STORE IT IN N C CALL DBINF(2HS ,4,K,IBUF) IF(IBUF.NE.0) GO TO 3000 N=IBUF(3) C C GET MASTER DATA SET CHARACTERISTICS C CALL DBINF(2HS ,2,N,IBUF) IF(IBUF.NE.0) GO TO 3000 C C IF MAO9STER IS AUTOMATIC NO CHECK C IF(IGET1(IBUF,10).EQ.1HA) GO TO 1200 C C IF MASTER IS MANUAL AND NO ADD IS DEFINED IN IT C CODE EDIT 1 + LOCK C DO 1230 J=1,45 K1=IAND(IMAI(J,3),377B) IF(K1.NE.N) GO TO 1230 K2=IAND(IMAI(J,2),7) IF(K2.EQ.2) GO TO 1200 1230 CONTINUE IMAI(I,2)=IOR(IMAI(I,2),2100B) IMAI(I,3)=IOR(IMAI(I,3),IALF2(N)) 1200 CONTINUE C C IMAGE FIND EDITS C C EDIT ONLY ON FIRST ITEM FIND (KEY) C 1300 IF(.NOT.(ISBIT(IMFLG,1))) GO TO 1600 M=IAND(IMFLG,14B) DO 1310 I=1,40 K=IAND(IMAI(I,2),7) IF((K.EQ.0).AND.(IMAI(I,1).NE.0)) GO TO 1320 1310 CONTINUE STOP 70 C C FIND IN MASTER C CODE EDIT 1 + LOCK IF UPDATE OR DELETE C 1320 IF(IMDT.NE.0) GO TO 1330 IMAI(I,2)=IOR(IMAI(I,2),100B) IF(M.NE.0) IMAI(I,2)=IOR(IMAI(I,2),2000B) IMAI(I,3)=IOR(IMAI(I,3),IALF2(IMAI(I,3))) GO TO 1500 C C DETAIL SEARCH WITH NO MASTER INVOLVED C C CODE EDIT 4 + LOCK C C FLAG MASTER KEY ITEM C 1330 IF(IMAS.NE.0) GO TO 1340 IMAI(I,2)=IOR(IMAI(I,2),2420B) IMAI(I,3)=IOR(IMAI(I,3),IALF2(IMDT)) IMAI(I,1)=IOR(IMAI(I,1),IALF2(IMAI(I,1))) GO TO 1400 C C DETAIL SEARCH WITH MASTER DATA SET INVOLVED C C CODE EDIT 4 + LOCK C 1340 IMAI(I,2)=IOR(IMAI(I,2),2420B) IMAI(I,3)=IOR(IMAI(I,3),IALF2(IMDT)) C C SEARCH DETAIL DATA SET KEY ITEM RELATED TO THIS MASTER C C K IS MASTER DATA SET KEY ITEM # C K=IAND(IMAI(I,1),377B) CALL DBINF(2HS ,4,K,IBUF) IF(IBUF.NE.0) GO TO 3000 DO 1350 J=1,IBUF(2) IF(IBUF(2*J+1).EQ.IMDT) GO TO 1360 1350 CONTINUE STOP 71 1360 IMAI(I,1)=IOR(IMAI(I,1),IALF2(IBUF(2*J+2))) C C FOR OTHER KEY ITEMS FIND EDIT 4+LOCK C 1400 DO 1404 J=I+1,40 K=IAND(IMAI(J,2),7) IF((K.NE.0).OR.(IMAI(J,1).EQ.0)) GO TO 1404 IF(.NOT.(ISBIT(IMAI(J,2),3))) GO TO 1404 IMAI(J,2)=IOR(IMAI(J,2),2400B) IMAI(J,3)=IOR(IMAI(J,3),IALFk2(IMDT)) IMAI(J,1)=IOR(IMAI(J,1),IALF2(IMAI(J,1))) 1404 CONTINUE C C SET RESTORE RUN TABLE FLAG C IMAI(2*IUMAX-1,2)=IOR(IMAI(2*IUMAX-1,2),40B) C C SET FAF BUFFER FLAG C K=2*(IUMAX+1)-1 IMAI(K,2)=IOR(IMAI(K,2),1000B) C C DELETE EDITS C C ONLY IF DELETE IN MASTER DATA SET = CODE EDIT 3 + LOCK C C 1500 IF(.NOT.(ISBIT(IMFLG,2))) GO TO 1600 IF(IMDT.NE.0) GO TO 1600 DO 1510 I=1,40 K=IAND(IMAI(I,2),7) IF(K.NE.4) GO TO 1510 IMAI(I,2)=IOR(IMAI(I,2),2300B) IMAI(I,3)=IOR(IMAI(I,3),IALF2(IMAS)) C C MEDIA RECORD LENGTH C J=255 DO 1505 L=1,255 CALL DBINF(2HI ,2,L,IBUF) IF(IBUF.EQ.125) GO TO 1506 IF(IBUF.NE.0) GO TO 3000 IF(IBUF(9).NE.IMAS) GO TO 1505 IF(IBUF(8).LT.J) J=IBUF(8) 1505 CONTINUE 1506 IMAI(I,1)=IOR(IMAI(I,1),IALF2(J-1)) 1510 CONTINUE C C C END OF IMAGE EDITS C 1600 INDIC=7 GO TO 3035 C C********************************************************************** C C ERROR SECTION C C********************************************************************* C C 3000 IMES=0 3010 NOF=4+5*IMODB IF(ISCRN.EQ.15) NOF=3 IF(ISCRN.EQ.17) NOF=3*IX-1 IF(ISCRN.NE.16) GO TO 3012 NOF=3 IF(ITT.EQ.3) NOF=NOF+3 NOF=NOF+IMODB 3012 INDIC=0 DO 3015 I=1,5 3015 IMAI(N,I)=0 IF(IBUF.EQ.125) IMES=3 IF(IMES.NE.0) GO TO 3020 CALL CNUMD(IBUF,IER) CALL MES12(4,NOF,IER) GO TO 3030 3020 IF(IMES.NE.22) GO TO 3021 CALL MES12(22,NOF,IER) GO TO 3030 3021 CALL MES12(IMES,NOF) C C************************************************************************ C C RETURN TO CALLING SEGMENT C C************************************************************************ C 3030 IF((ISCRN.NE.17).OR.(INDIC.EQ.0)) GO TO 3035 IX=IX+1 IF(IX.LE.4) GO TO 80 INDIC=2 3035 IF(ISCRN.EQ.11) GO TO 3040 CALL EXEC(8,JNAME)TRN 3040 CALL EXEC(8,INAME) C C END !!!! C CALL TGP END END$ T  92903-18378 1805 S C0122 &MES12 TGP SEGM 12 SUBR SRC             H0101 ASMB,R NAM MES12,7 92903-16378 REV.1805 780519 * * SOURCE 92903-18378 * SPC 2 ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** SPC 2 HED * -MES12- SUP * ********************************************************************** * * * THIS SUBROUTINE IS CALLED BY THE SEGMENT ANSWR * * OF THE FORMG PROGRAM TO WRITE AN ERROR MESSAGE ON THE TERMINAL. * * THE ERROR MESSAGE IS PRINTED ON LINE 24 OF THE * * SCREEN AND THE CURSOR IS MOVED TO THE WRONG FIELD. * * THIS SUBROUTINE IS CALLED WITH TWO PARAMETERS : * * * * - PAR#1 = ERROR MESSAGE # TO OUTPUT * * - PAR#2 = WRONG FIELD # ON THE SCREEN * * * ********************************************************************** * * ENT MES12 ENTRY POINT EXT EXEC EXT .ENTR EXT &REMP EXT &MVW COM ILU TERM. LU * * GET CALLING PARAMETERS AND INITIALISE * NMESS NOP FIRST PARM. ADDRESS NOF NOP SECD. PARM. ADDRESS NIER NOP THIRD PARAM ADDRESS MES12 NOP ENTRY POINT JSB .ENTR SUBR. TO GET DEF NMESS PARM. ADDRESS LDA BUFAD INITIALIZE LDB SPACE ERROR MESSAGE JSB &REMP BUFFER DEC -35 TO BLANK LDA BUFA1 INITIALIZE LDB NULL TAB BUFFER JSB &R۷EMP TO NULL DEC -50 * * MOVE ERROR MESSAGE IN OUTPUT BUFFER * LDA NIER GET ERROR # IMAGE ADDRESS LDB ANMES GET ADDRESS OF DEST BUFFER JSB &MVW DEC 3 LDA NIER LDB ANMS1 JSB &MVW DEC 3 * LDA NMESS,I GET ERROR MESSAGE # ADA AMES0 COMPUTE MESSAGE LDB A,I ADDRESS STB P1 STORE IT CMB,INB MINUS STARTING ADDRESS STB IST OF MESSAGE IN IST INA COMPUTE NEXT MESSAGE LDA A,I STARTING ADDRESS ADA IST COMPUTE MESSAGE LENGTH STA P2 STORE IT LDA P1 BUFFER SOURCE ADDRESS LDB BUFAD BUFFER DEST ADDRESS JSB &MVW MOVE WORDS P2 NOP BUFFER LENGTH * * INCLUDE # OF NECESSARY TABS * LDA NOF,I GET WRONG FIELD # CMA,INA MAKE IT NEG. ISZ A INCREMENT: IS FIRST FIELD ? RSS NO JMP WRIT YES OUTPUT BUFFER STA P3 STORE NEG. # OF TABS LDA BUFA1 TAB BUFFER ADDRESS LDB TAB TAB JSB &REMP INCLUDE TABS P3 NOP IN BUFFER * * WRITE MESSAGE * WRIT JSB EXEC WRITE EXEC CALL DEF *+5 RETURN POINT DEF D.2 CODE EXEC DEF ILU CONTROL WORD DEF BUF BUFFER LOCATION DEF ILN BUFFER LENGTH * * RETURN TO CALLING PROGRAM * JMP MES12,I * * BUFFER DATA * BUF BYT 33,130,33,46,141,62,62,162,60,103 FORMAT OFF:POS.CURSOR BYT 33,112,15,12,40,0 CLEAR DISP CR,LF BYT 33,46,144,103 INVERSE VIDEO BLINKING ASC 2,ERRO BYT 122,33,46,144,100 END ENHANCEMENT ASC 2, : BUFER BSS 35 MESSAGE BUFFER BYT 33,127,33,110 FORMAT ON * HOME CURSOR BUF1 BSS 50 TAB BUFFER BYT 33,142 KEYBOARD ENABLE EBUF BYT 0,137 SUPPRESS , * * STORAGE , CONSTANTS .. * BUFAD DEF BUFER BUFF. ADDRESS  BUFA1 DEF BUF1 TAB BUFFER ADDRESS ANMES DEF INMES IMAGE ERROR # ADDRESS ANMS1 DEF INMS1 A EQU 0 A REGISTER STAD EQU BUF BUFFER STARTING ADDRESS LTAD EQU EBUF BUFFER LAST ADDRESS IST NOP P1 NOP SOURCE ADDRESS BUFFER ADDRESS ILN ABS LTAD-STAD+1 BUFFER LENGTH SPACE BYT 40,40 NULL BYT 0,0 TAB BYT 33,111 D.2 DEC 2 * * MESSAGE ADDRESS * AMES0 DEF AMES1-1 AMES1 DEF MES1 DEF MES2 DEF MES3 DEF MES4 DEF MES5 DEF MES6 DEF MES7 DEF MES8 DEF MES9 DEF MES10 DEF MES11 DEF TES12 DEF MES13 DEF MES14 DEF MES15 DEF MES16 DEF MES17 DEF MES18 DEF MES19 DEF MES20 DEF MES21 DEF MES22 DEF MES23 DEF MES24 DEF MES25 DEF MES26 DEF MES27 DEF MES28 DEF MES29 DEF MES30 DEF MES31 DEF MES32 DEF MES33 DEF MES34 * * MESSAGE STORAGE * MES1 ASC 23,Check existence incompatible with add update o ASC 12,r delete in the same DS MES2 ASC 12,Item must be a key item MES3 ASC 9,Invalid item name MES4 ASC 7,IMAGE error # INMES BSS 3 MES5 ASC 19,A find must be defined by a U question MES6 ASC 21,A find may be defined on one data set only MES7 ASC 23,First question defining a find in a detail set ASC 12, must ask for a key item MES8 ASC 23,Update and delete incompatible in the same tra ASC 4,nsaction MES9 ASC 23,Find item in a master data set must be a key i ASC 2,tem MES10 ASC 21,Check against data base defined previously MES11 ASC 21,Cannot add in automatic master data set TES12 ASC 23,Item to add in a master data set must be defin ASC 8,ed by U questions MES13 ASC 20,A find must have been defined previously MES14 ASC 23,Find must be completely defined before update ASC 5,or display MES15 ASC 23,Item does not belong to the; entry isolated by ASC 4,the Find MES16 ASC 14,A key item cannot be updated MES17 ASC 23,This operation in a master set must be associa ASC 11,ted with a U question MES18 ASC 23,This operation in a detail set must be associa ASC 11,ted with a M question MES19 ASC 23,For Add system provided information cannot be ASC 12,key item in a Master Set MES20 ASC 23,Key item to add in a detail set : linked maste ASC 10,r must be automatic MES21 ASC 22,No more than 5 IMAGE data set modifications ASC 7,can be defined MES22 ASC 20,Key item already defined under the name INMS1 BSS 3 ASC 11, for an add operation MES23 ASC 23,Add and delete incompatible in the same transa ASC 3,ction MES24 ASC 23,Item has not the required type or length to st ASC 10,ore this information MES25 ASC 23,Cannot update or delete in automatic master da ASC 3,ta set MES26 ASC 23,A find or check existence must be previously d ASC 10,efined on this item MES27 ASC 23,Item does not belong to the entry isolated by ASC 10,the check existence MES28 ASC 23,Check Existence incompatible with Find in same ASC 5, Data Set MES29 ASC 23,Find incompatible with Check Existence in same ASC 5, Data Set MES30 ASC 21,CHECK EXISTENCE only allowed in Master DS MES31 ASC 23,This item must belong to the same data set as ASC 12,the last item Displayed MES32 ASC 22,A display from a detail data set must be fro ASC 8,m an M-question MES33 ASC 12,ADD to Mstr not allowed MES34 ASC 1,-1 * * END MES12 J  92903-18379 1840 S C0122 &TGP13 TGP SEGM 13 SRC             H0101 ;FTN4 PROGRAM TGPI3(5), 92903-16379 REV.1840 780804 C C SOURCE 92903-18379 C C C C ************************************************************** C * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * C ************************************************************** C C C C PRGMR : JEAN CHARLES MIARD (HPG) C C C********************************************************************* C* * C* THIS IS A SEGMENT OF THE TGP PROGRAM USED TO * C* PRINT THE TRANSACTION SPECIFICATIONS ON THE LIST DEVICE . * C* THE 3070 LABEL ATTACHED TO THE TRANSACTION DEFINED IS ALSO * C* PRINTED . * C* * C* IF INDIC = -1 : RETURN FROM TGP11 THE IMAGE OPERATIONS * C* HAVE BEEN LISTED . * C* IF INDIC = 4278 : REQUEST TO LIST A TRANSACTION SPEC COMING * C* FROM TGP1 * C* * C********************************************************************* C C C DECLARATIONS COMMON VARIABLES ************* C COMMON ILU,ISCRN,IQST,ISKIP,INDIC COMMON IFORM(494) COMMON JFORM(980) COMMON MFORM(16) COMMON LFORM(39) COMMON ITT COMMON IKEY(11,3) COMMON IUMAX,IMMAX COMMON IMODB COMMON ILITE(15) COMMON IMAI(45,5) COMMON IMFLG,IMAS,IMDT,IMKY COMMON KFORM(1065) COMMON ILIBR(61) COMMON NIMAG C C LOCAL VARIABLES **************** C DIMENSION IBUF(38),JLIlfT1(6),JLIT4(6),JLIT5(6),IK1(6) DIMENSION IRSET(3),IKBD(4),IRED(4),ISTRG(4),IINT(4),IREAL(4) DIMENSION IFUN(4),INAM(3),JFUN(11),JAR(10),JCO(4),JDE(3) DIMENSION JNE(5),JDV(8),JDI(8),JEX(8),JNX(10),JCE(11),JCN(11) DIMENSION JID(9),JTE(6),JDA(3),JTI(7),JNAM(3),IPRES(27) DIMENSION ICRBF(3),ITIME(5) C LOGICAL ISSPA,ISBIT,JULIB C C C DATA VALUES ************* C DATA JLIT1/2HSP,2HEC,2H#-,2H[S,2HC],2H ?/ DATA JLIT4/2HCO,2HMP,2HLE,2HTE,2H T,2HR./ DATA JLIT5/2H ,2HER,2HRO,2HR ,2H! ,2H / DATA IK1/2H ,2H R,2HES,2HET,2H ,2H / DATA IRSET/2HRE,2HSE,2HT / DATA IKBD/2HKE,2HYB,2HOA,2HRD/ DATA IRED/2HRE,2HAD,2HER,2H / DATA ISTRG/2HST,2HRI,2HNG,2H / DATA IINT/2HIN,2HTE,2HGE,2HR / DATA IREAL/2HRE,2HAL,2H ,2H / DATA IFUN/2HFU,2HNC,2HTI,2HON/ DATA INAM/2HTG,2HP1,2H / DATA JFUN/2H F,2HUN,2HCT,2HIO,2HNS,2H A,2HCC,2HEP,2HTE,2HD ,2H: / DATA JAR/2HAR,2HIT,2HHM,2HET,2HIC,2H O,2HPE,2HRA,2HTO,2HRS/ DATA JCO/2HCO,2HNT,2HIN,2HUE/ DATA JDE/2HDE,2HLE,2HTE/ DATA JNE/2HNE,2HXT,2H E,2HNT,2HRY/ DATA JDV/2HDE,2HFA,2HUL,2HT ,2HVA,2HLU,2HE ,2H: / DATA JDI/2HDI,2HSP,2HLA,2HYE,2HD ,2HVA,2HLU,2HE / DATA JEX/2HCH,2HEC,2HK ,2HEX,2HIS,2HTE,2HNC,2HE / DATA JNX/2HCH,2HEC,2HK ,2HNO,2HN ,2HEX,2HIS,2HTE,2HNC,2HE / DATA JCE/2HCH,2HEC,2HK ,2HAL,2HL ,2HCH,2HAI,2HNS,2H E,2HMP,2HTY/ DATA JCN/2HCH,2HEC,2HK ,2HCH,2HAI,2HN ,2HNO,2HN ,2HEM,2HPT,2HY / DATA JID/2HTR,2HAN,2HSA,2HCT,2HIO,2HN ,2HID,2H. ,2H: / DATA JTE/2HTE,2HRM,2HIN,2HAL,2H #,2H :/ DATA JDA/2HDA,2HTE,2H :/ DATA JTI/2HTI,2HME,2H O,2HF ,2HDA,2HY ,2H: / DATA JNAM/2HTG,2HPI,2H1 / DATA IPRES/15530B,15555B,15446B,65460B, C41040B, 15542B,6412B,6412B,15446B,62112B,2HPr,2Hes,2Hs ,15446B, C62113B,2HNE,2HXT,2H S,2HCR,2HEE,2HN ,15446B,62112B,2Hke,74433B, C23144B,40040B/ DATA ICRBF/2H ,2H ,2H / C C C*********************************************************************** C C GET LIST LU AND IF INDIC = -1 GO TO FINISH LISTING C C************************************************************************ C LU=ISKIP C-----IF LIST LU IS NOT DEFAULT TERMINAL, LOCK IT. IF(LU.EQ.ILU) GO TO 49 C-----1ST UNLOCK ALL LOCKED LU'S CALL LURQ(100000B,LU,1) C-----NOW LOCK THE LIST LU CALL LURQ(1,LU,1) 49 IF(INDIC.EQ.-1) GO TO 470 C C*********************************************************************** C C WRITE 3070 LABEL PLATE C C********************************************************************** C C LABEL HEADER C IAB=41040B CALL EXEC(3,1100B+LU,-1) C-----GO TO 55 IF THE LIST REQUEST IS FROM TGP1. 50 IF(INDIC.EQ.4278) GO TO 55 WRITE(LU,1005) IAB,(IFORM(K),K=29,31),(IFORM(K),K=32,33) .,(LFORM(K),K=16,21) GO TO 60 C-----GET FILE NAME & CR# FROM IFORM(14) INSTEAD OF LFORM(16). 55 WRITE(LU,1005) IAB,(IFORM(K),K=29,31),(IFORM(K),K=32,33) .,(IFORM(K),K=14,19) C C WRITE LIGHT LABEL C 60 DO 100 I=1,3 WRITE(LU,1000) WRITE(LU,1001) WRITE(LU,1002) WRITE(LU,1001) WRITE(LU,1001) CALL FSTAR(IBUF) C C INSERT LIGHT LABELS C K IS LIGHT # , N IS POSITION (CHAR) OF LABEL IN IBUF C DO 105 J=1,5 K=(I-1)*5+J N=3+(J-1)*15 IF(K.EQ.10) CALL MOVCA(JLIT4,1,IBUF,N,12) IF(K.EQ.15) CALL MOVCA(JLIT1,1,IBUF,N,12) IF(K.EQ.5) CALL MOVCA(JLIT5,1,IBUF,N,12) IF((ILITE(K).EQ.0).OR.(ILITE(K).EQ.-99)) GO TO 105 IF(ILITE(K).GT.0) CALL MOVCA(IFORM,747+(ILITE(K)-1)*12,IBUF,N,12) IF(ILITE(K).LT.0) CALL MOVCA(JFORM,71+(-ILITE(K)-1)*98,IBUF,N,12) 105 CONTINUE WRITE(LU,1007) IBUF WRITE(LU,1001) 100 CONTINUE C C WRITE SFK LABELS C DO 120 I=1,2 WRITE(LU,1000) WRITE(LU,1001) WRITE(LU,1003) WRITE(LU,1003) WRITE(LU,1001) CALL FSTAR(IBUF) C C INS;ERT PREFIXED LABELS C DO 130 J=1,5 K=(I-1)*5+J+IMODB N=3+(J-1)*15 IF(IKEY(K,3).EQ.0) GO TO 130 CALL FILK(K,N,1,IBUF,IFORM) 130 CONTINUE WRITE(LU,1007) IBUF WRITE(LU,1001) CALL FSTAR(IBUF) C C INSERT NORMAL KEYS LABELS C DO 140 J=1,5 K=(I-1)*5+J+IMODB N=3+(J-1)*15 IF(K.NE.1) GO TO 145 CALL MOVCA(IK1,1,IBUF,N,12) GO TO 140 145 IF(IKEY(K,1).EQ.0) GO TO 140 CALL FILK(K,N,0,IBUF,IFORM) 140 CONTINUE WRITE(LU,1007) IBUF WRITE(LU,1001) 120 CONTINUE C C END OF LABEL PRINTOUT C WRITE(LU,1000) C-----HAS 3070A LABEL ALREADY BEEN PRINTED? IF(IMODB.EQ.0) GO TO 155 C-----IF A 3070B IS MANDATORY, DON'T PRINT THE 3070A LABEL. IMODB=0 IAB=40440B IF(ISBIT(KFORM(10),15)) GO TO 150 IF(ISBIT(KFORM(10),14)) GO TO 150 IF(ISBIT(KFORM(10),12)) GO TO 150 C-----3070B IS NOT MANDATORY, SO GO BACK & PRINT 3070A LABEL. WRITE(LU,1004) GO TO 50 C-----PRINT MESSAGE THAT SAYS 3070B IS MANDATORY & 3070A CANNOT BE USED. C 150 WRITE(LU,1004) WRITE(LU,1008) IF(ISBIT(KFORM(10),15)) WRITE(LU,1009) IF(ISBIT(KFORM(10),14)) WRITE(LU,1010) IF(ISBIT(KFORM(10),12)) WRITE(LU,1011) WRITE(LU,1012) 155 IMODB=1 WRITE(LU,1004) GO TO 200 C FORMATS C 1000 FORMAT(X,76("*")) 1001 FORMAT(X,5("*",14X),"*") 1002 FORMAT(X,5("*",6X,"[]",6X),"*") 1003 FORMAT(X,5("*",X,12("="),X),"*") 1004 FORMAT("1") 1005 FORMAT(//,2X"HP3070",1A2,"LABEL PRINTOUT FOR TRANSACTION", C" SPECIFICATION : ",3A2," / ",2A2,// C16X"FROM TRANSACTION SPECIFICATION LIBRARY : " C,3A2" (CR =",3A2")"///) 1007 FORMAT(X,38A2) 1008 FORMAT(///,5X,"THIS TRANSACTION USES FEATURES AVAILABLE", C" ONLY ON THE HP3070B, IE,",//) 1009 FORMAT(10X,"CARD READER") 1010 FORMAT(10X,"PRINTER") 1011 FORMAT(10X,"REQUIRED FUNCTIONS ON SFK #11") 1012 FORMAT(//,5X,"THEREFORE NO HP3070A LABEL MODEL IS PROVIDED") C C********************************************************************* C C NOW WRITE SPECIFICATIONS C C********************************************************************* C C NAME ,#, SC,DATA BASE NAME C 200 WRITE(LU,2000) WRITE(LU,2024) C-----GET SYSTEM DATE & PRINT IT. CALL EXEC(11,ITIME,IYEAR) IF(JULIB(ITIME(5),IYEAR,IDAY,IMNTH)) GO TO 202 WRITE(LU,20241) IMNTH,IDAY,IYEAR C C-----GO TO 203 IF THE LIST REQUEST IS FROM TGP1. 202 IF(INDIC.EQ.4278) GO TO 203 WRITE(LU,2010)(LFORM(I),I=16,21) GO TO 204 C-----GET FILE NAME & CR# FROM IFORM(14) INSTEAD OF LFORM(16) 203 WRITE(LU,2010) (IFORM(I),I=14,19) 204 WRITE(LU,2001) (IFORM(I),I=29,31) WRITE(LU,2002) (IFORM(I),I=32,33) WRITE(LU,2003) (IFORM(I),I=34,36) C-----LOGGING? IF (IGET1(IFORM,74).EQ.1HX) WRITE(LU,2004) IF(ITT.GT.1) WRITE(LU,2042) (IFORM(I),I=38,40) C C*********************************************************************** C C WRITE SFK ASSIGNEMENTS C C********************************************************************** C WRITE(LU,2005) WRITE(LU,2006) WRITE(LU,2007) DO 210 I=1,10+IMODB DO 215 J=1,38 215 IBUF(J)=2H C C KEY # C IBUF(2)=IASC(I) C C NORMAL KEYS ASSIGNEMENT : IF FUNCTION PRINT LABEL C IF STRING PRINT VALUE C IF(I.NE.1) GO TO 220 CALL MOVEW(IRSET,IBUF(8),3) GO TO 240 C 220 IF(IKEY(I,1).EQ.0) GO TO 230 IF(IKEY(I,1).LT.0) GO TO 225 CALL FILK(I,15,0,IBUF,IFORM) GO TO 230 225 CALL PUTCA(IBUF,1H",12) CALL PUTCA(IBUF,1H",29) CALL FILK(I,-13,0,IBUF,IFORM) C C PREFIXED KEYS ASSIGNEMENT C 230 IF(IKEY(I,3).EQ.0) GO TO 238 IF(IKEY(I,3).LT.0) GO TO 235 CALL FILK(I,42,1,IBUF,IFORM) GO TO 238 235 CALL PUTCA(IBUF,1H",39) CALL PUTCA(IBUF,1H",56) CALL FILK(I,-40,1,IBUF,IFORM) C C TERjpMINATOR ? C 238 IF(IKEY(I,2).EQ.0) IBUF(35)=2HNO IF(IKEY(I,2).EQ.1) IBUF(35)=2HYE C 240 WRITE(LU,1007) IBUF C 210 CONTINUE GO TO 300 C C FORMATS C 2000 FORMAT(//,30X,"TRANSACTION SPECIFICATION DOCUMENTATION") 2024 FORMAT(29X,41"*",///) 20241 FORMAT(40X,"SYSTEM DATE : ",I2,"-",I2,"-",I4) 2010 FORMAT(40X,"FROM LIBRARY : ",3A2" (CR ="3A2")",/) 2001 FORMAT(40X,"NAME",10X,": ",3A2) 2002 FORMAT(40X,"NUMBER",8X,": ",2A2) 2003 FORMAT(40X,"SECURITY CODE : ",3A2,/) 2004 FORMAT(40X,"LOGGING REQD : YES") 2005 FORMAT(4X,"SPECIAL FUNCTION KEYS ASSIGNMENT :") 2006 FORMAT(4X,34("*"),/) 2007 FORMAT(2X,"KEY#",4X,"NORMAL VALUE/FUNCTION",5X, C"PREFIXED VALUE/FUNCTION",4X,"TERMINATOR ?",/) C C********************************************************************* C C WRITE QUESTION SPECIFICATIONS C C********************************************************************* C 300 DO 400 I=1,IUMAX+IMMAX MC=(I-1)*98 MW=(I-1)*49 C C HEADER FOR U QUESTIONS C IF((I.NE.1).OR.(IUMAX.EQ.0)) GO TO 310 J=2HU WRITE(LU,2008) IUMAX,J WRITE(LU,2009) C C HEADER FOR M QUESTIONS C 310 IF(I.NE.IUMAX+1) GO TO 320 J=2HM WRITE(LU,2008) IMMAX,J WRITE(LU,2009) C C PRINT QUESTION LABEL C 320 WRITE(LU,2011) (IFORM(373+(I-1)*6+K),K=1,6) WRITE(LU,2033) C C DISPLAYED INFORMATION C IF(IGET1(JFORM,6+MC).NE.1HX) GO TO 324 C C DISPLAY LABEL C WRITE(LU,2034)(JFORM(MW+35+K),K=1,6) C C INDICATOR LIGHT # C WRITE(LU,2035) JFORM(MW+35) C C ITEM TYPE C K=IGET1(JFORM,90+MC) IF(K.EQ.1HS) J=0 IF(K.EQ.1HI) J=1 IF(K.EQ.1HR) J=2 IF(K.NE.1H ) GO TO 321 J=IAND(IMAI(2*I,2),30000B)/4096 321 IF(J.EQ.0) CALL MOVEW(ISTRG,IBUF,4) IF(J.EQ.1) CALL MOVEW(IINT,IBUF,4) IF(J.EQ.2) CALL MOVEW(IREAL,IBUF,4) IF(J.EQ.0) WRITE(LU,2040) (IBUF(K),K=1,4),JFORM(46+MW) IF(J.NE.0) WRITE(Lb U,2039) (IBUF(K),K=1,4) C C DISPLAY MODULE C IF(ISSPA(JFORM,93+MC,5)) WRITE(LU,2036) (JFORM(46+MW+K),K=1,3) C C IMAGE NAME C IF(ISSPA(JFORM,83+MC,6)) WRITE(LU,2037) (JFORM(41+MW+K),K=1,3) C C PRINT DISPLAY C IF(IMODB.EQ.0) GO TO 322 J=2HNO IF(IGET1(JFORM,89+MC).EQ.1HX) J=2HYE WRITE(LU,2038) J C C DISPLAYED DATA OFFSET IN OUTPUT BUFFER C 322 WRITE(LU,2045) IMAI(2*I,5) C C ANSWER SPECIFICATIONS C C C IF 3070B INPUT FROM READER ? C 324 WRITE(LU,2041) IF(IMODB.EQ.0) GO TO 330 IF(IGET1(JFORM,3+MC).NE.1HX) GO TO 325 WRITE(LU,2012) IRED C-----NEW CARD? IF(IAND(JFORM(MW+2),77B).EQ.0) GO TO 330 C-----YES. DISPLAY NEW CARD SPECS. C GET CARD READER SPECS FROM JFORM(MW+2) LOWER BYTE C BIT C 0 80 COL. C 1 40 COL. C 2 CLOCK ON DATA C 3 CLOCK AFTER DATA C 4 HOLES C 5 MARKS C 6 ASCII C 7 IMAGE C IF(ISBIT(JFORM(MW+2),0)) ICRBF(3)=2H80 IF(ISBIT(JFORM(MW+2),1)) ICRBF(3)=2H40 IF(ISBIT(JFORM(MW+2),2)) ICRBF(3)=2HCO IF(ISBIT(JFORM(MW+2),3)) ICRBF(3)=2HCA IF(ISBIT(JFORM(MW+2),4)) ICRBF(2)=2HH. IF(ISBIT(JFORM(MW+2),5)) ICRBF(2)=2HM. IF(ISBIT(JFORM(MW+2),6)) ICRBF(1)=2HA. IF(ISBIT(JFORM(MW+2),7)) ICRBF(1)=2HI. WRITE(LU,2013) (ICRBF(ICR),ICR=1,3) GO TO 330 325 WRITE(LU,2012) IKBD C C LIGHT # C 330 WRITE(LU,2035) JFORM(1+MW) C C PRINT ITEM TYPE C J=JFORM(34+MW) IF(J.EQ.0) CALL MOVEW(ISTRG,IBUF,4) IF(J.EQ.1) CALL MOVEW(IINT,IBUF,4) IF(J.EQ.2) CALL MOVEW(IREAL,IBUF,4) IF(J.EQ.3) CALL MOVEW(IFUN,IBUF,4) IF(J.EQ.0) WRITE(LU,2040) (IBUF(K),K=1,4),JFORM(16+MW) IF(J.NE.0) WRITE(LU,2039) (IBUF(K),K=1,4) C C IMAGE ITEM NAME , FUNCTION C IF(.NOT.ISSPA(JFORM,24+MC,6)) GO TO 332 CALL MOVCA(JFORM,24+MC,IBUF,1,6) L=IALF2(JFORM(15+MW)) WRITE(LU,2043) (IBUF(K),K=1,3),L C C IMAGE EDITS ҧC 332 L=IAND(IMAI(2*I-1,2),700B)/64 IF(L.EQ.0) GO TO 335 DO 333 K=1,11 333 IBUF(K)=2H IF(L.EQ.1) CALL MOVEW(JEX,IBUF,8) IF(L.EQ.2) CALL MOVEW(JNX,IBUF,10) IF(L.EQ.3) CALL MOVEW(JCE,IBUF,11) IF(L.EQ.4) CALL MOVEW(JCN,IBUF,11) WRITE(LU,2047) (IBUF(K),K=1,11) C C STANDARD EDITS C 335 IF(J.EQ.3) GO TO 350 C C STRINGS C IF(J.NE.0) GO TO 340 IBUF(1)=IAND(JFORM(17+MW),177400B) IBUF(1)=IOR(IBUF(1),40B) WRITE(LU,2019) IBUF(1) CALL MOVCA(JFORM,34+MC,IBUF,1,16) IF(ISSPA(IBUF,1,16)) WRITE(LU,2020) (IBUF(K),K=1,8) GO TO 350 C C INTEGERS C 340 IF(J.NE.1) GO TO 342 IF(ISSPA(JFORM,31+MC,6)) WRITE(LU,2021) (JFORM(15+MW+K),K=1,3) IF(ISSPA(JFORM,37+MC,6)) WRITE(LU,2022) (JFORM(18+MW+K),K=1,3) IF(ISSPA(JFORM,43+MC,2)) WRITE(LU,2023) JFORM(22+MW) GO TO 350 C C REALS C 342 IF(ISSPA(JFORM,31+MC,14)) WRITE(LU,2021) (JFORM(15+MW+K),K=1,7) IF(ISSPA(JFORM,45+MC,14)) WRITE(LU,2022) (JFORM(22+MW+K),K=1,7) C C FUNCTIONS ACCEPTED C 350 DO 351 K=1,29 351 IBUF(K)=2H CALL MOVEW(JFUN,IBUF(9),11) C C ARITH OPERATORS C IF((J.NE.1).AND.(J.NE.2)) GO TO 360 IF(J.EQ.1) K=45 IF(J.EQ.2) K=59 IF(IGET1(JFORM,K+MC).NE.1HX) GO TO 360 CALL MOVEW(JAR,IBUF(20),10) WRITE(LU,2027) (IBUF(K),K=1,29) DO 352 K=1,29 352 IBUF(K)=2H C C NEXT ENTRY C 360 IF(J.EQ.0) K=51 IF(J.EQ.1) K=46 IF(J.EQ.2) K=60 IF(J.EQ.3) K=32 IF(IGET1(JFORM,K+MC).NE.1HX) GO TO 365 CALL MOVEW(JNE,IBUF(20),5) WRITE(LU,2027) (IBUF(K),K=1,29) DO 361 K=1,29 361 IBUF(K)=2H C C CONTINUE C 365 IF(J.NE.3) GO TO 370 IF(IGET1(JFORM,31+MC).NE.1HX) GO TO 367 CALL MOVEW(JCO,IBUF(20),4) WRITE(LU,2027) (IBUF(K),K=1,29) DO 366 K=1,29 366 IBUF(K)=2H C C DELETE C 367 IF(IGET1(JFORM,33+MC).NE.1HX) GO TO 370 CALL MOVEW(JDE,IBUF(20),3) WRITE(LU,2027) (IBUF(K),K=1,29) DO 368 K=1,29 368 IBUF(K)=2H C C USER EDIT MODULE C 370 IF(J.EQ.3) GO TO 380 IBUF(3)=2H IF(J.EQ.0) K=52 IF(J.EQ.1) K=47 IF(J.EQ.2) K=61 CALL MOVCA(JFORM,K+MC,IBUF,1,5) IF(ISSPA(IBUF,1,5)) WRITE(LU,2044) (IBUF(K),K=1,3) C C DEFAULT VALUE C DO 371 K=1,29 371 IBUF(K)=2H CALL MOVEW(JDV,IBUF(12),8) IF(IGET1(JFORM,23+MC).EQ.1HX) GO TO 375 IF(ISSPA(JFORM,7+MC,18)) GO TO 372 IF(J.NE.0) IBUF(21)=2H0 GO TO 376 372 CALL MOVEW(JFORM(4+MW),IBUF(20),8) GO TO 376 375 CALL MOVEW(JDI,IBUF(20),8) 376 WRITE(LU,2027) (IBUF(K),K=1,29) C C DATA OFFSET IN OUTPUT BUFFER C 380 IF(J.EQ.3) GO TO 385 WRITE(LU,2045) IMAI(2*I-1,5) C C LENGTH OF STORAGE FOR A U OR M QUESTIONS SEQUENCE C 385 IF((I.NE.IUMAX).OR.(IUMAX.EQ.0)) GO TO 390 J=2HU WRITE(LU,2046) J,KFORM(8) GO TO 400 390 IF((I.NE.IUMAX+IMMAX).OR.(IMMAX.EQ.0)) GO TO 400 J=2HM WRITE(LU,2046) J,KFORM(9) C 400 CONTINUE C C************************************************************************ C C DATA ADDED BY THE SYSTEM : C C************************************************************************ C C IF(.NOT.ISSPA(MFORM,1,4)) GO TO 450 WRITE(LU,2050) WRITE(LU,2051) DO 440 I=1,4 IF(IGET1(MFORM,I).NE.1HX) GO TO 440 DO 405 K=1,9 405 IBUF(K)=2H IF(I.EQ.1) CALL MOVEW(JID,IBUF,9) IF(I.EQ.2) CALL MOVEW(JTE,IBUF,6) IF(I.EQ.3) CALL MOVEW(JDA,IBUF,3) IF(I.EQ.4) CALL MOVEW(JTI,IBUF,7) WRITE(LU,2052) (IBUF(K),K=1,9) WRITE(LU,2045) IMAI(40+I,5) IF(.NOT.ISSPA(MFORM,5+(I-1)*6,6)) GO TO 440 L=MFORM(16) IF(I.LE.2) L=MFORM(15) IF((I.EQ.2).OR.(I.EQ.4)) L=IALF2(L) WRITE(LU,2043) (MFORM(K),K=3+(I-1)*3,5+(I-1)*3),L 440 CONTINUE C C********************************************************************** C C DATA STORAGE DEFINITION C C********************************************************************* C 450 WRITE(LU,2053) WRITE(LU,2054) C C FILE NAME # 1 C IF(ISSPA(LFORM,1,6)) WRITE(LU,2055) (LFORM(K),K=1,3) C C FILE NAME # 2 C IF(.NOT.ISSPA(LFORM,7,6)) GO TO 460 WRITE(LU,2055) (LFORM(K),K=4,6) IF(ISSPA(LFORM,13,6)) WRITE(LU,2056) (LFORM(K),K=7,9) IF(ISSPA(LFORM,19,6)) WRITE(LU,2057) (LFORM(K),K=10,12) C C USER STORAGE MODULE C 460 IF(ISSPA(LFORM,25,5)) WRITE(LU,2058) (LFORM(K),K=13,15) C C IF IMAGE OPERATIONS GO TO TGP11 TO PRINT THEM C IF(IAND(IMFLG,100000B).EQ.0) GO TO 470 INDIC=-2 CALL EXEC(8,JNAM) C C RETURN FROM TGP11 C 470 WRITE(LU,2059) KFORM(1) C C*********************************************************************** C C IF LIST LU = TERMINAL LU ASK USER TO CONTINUE AND TERMINATE TGP C C*********************************************************************** C C IF(LU.NE.ILU) GO TO 480 CALL EXEC(2,ILU,IPRES,27) CALL REIO(1,ILU,IANS,-1) GO TO 485 480 CALL EXEC(3,1100B+LU,-1) 485 INDIC=99 CALL EXEC(8,INAM) C C C C********************************************************************* C C FORMATS C C********************************************************************* C 2008 FORMAT(//,4X,I2,2X,A2,"QUESTIONS : ") 2009 FORMAT(4X,17("*")) 2011 FORMAT(//,6X,"QUESTION LABEL : ",6A2) 2012 FORMAT(30X,"INPUT : ",4A2) 2013 FORMAT(27X,"NEW CARD : ",3A2) 2019 FORMAT(24X,"POSITIONING : ",A2) 2020 FORMAT(31X,"MASK : ",8A2) 2021 FORMAT(24X,"UPPER LIMIT : ",7A2) 2022 FORMAT(24X,"LOWER LIMIT : ",7A2) 2023 FORMAT(23X,"MODULO CHECK : ",A2) 2033 FORMAT(6X,30"-",/) 2034 FORMAT(/,10X,"- DISPLAYED INFORMATION : ",6A2) 2035 FORMAT(28X,"LIGHT # : ",A2) 2036 FORMAT(21X,"DISPLAY MODULE : ",3A2) 2037 FORMAT(20X,"IMAGE ITEM NAME : ",3A2) 2038 FORMAT(24X,"PRINT VALUE : ",A2) B@<2039 FORMAT(31X,"TYPE : ",4A2) 2040 FORMAT(31X,"TYPE : ",4A2,"(LENGTH = ",I3,")") 2041 FORMAT(/,10X,"- ANSWER DEFINITION :") 2027 FORMAT(29A2) 2042 FORMAT(38X,"IMAGE DATA BASE : ",3A2,/) 2043 FORMAT(20X,"IMAGE ITEM NAME : ",3A2,2X,"(FUNCTION : ",A1,")") 2044 FORMAT(24X,"EDIT MODULE : ",3A2) 2045 FORMAT(14X,"DATA OFFSET IN BUFFER : ",I4) 2046 FORMAT(//,6X,"* LENGTH OF STORAGE FOR A ",A2,"QUESTIONS ", C"SEQUENCE : ",I4,/) 2047 FORMAT(15X,"IMAGE EDIT GENERATED : ",11A2) 2050 FORMAT(/,4X,"INFORMATION ADDED BY THE SYSTEM :") 2051 FORMAT(4X,33"*") 2052 FORMAT(/,13X,"- ",9A2) 2053 FORMAT(/,4X,"DATA COLLECTED STORAGE :") 2054 FORMAT(4X,24"*") 2055 FORMAT(/,26X,"FILE NAME : ",3A2) 2056 FORMAT(31X,"CR # : ",3A2) 2057 FORMAT(26X,"SEC. CODE : ",3A2) 2058 FORMAT(/,21X,"STORAGE MODULE : ",3A2) 2059 FORMAT(//,6X,"* TRANSACTION SPECIFICATION LENGTH : ",I4," WORDS") C C CALL TGP END END$ B  92903-18380 1805 S C0122 &TGP1H TGP SEGM 01 HDR SRC             H0101 yASMB,R NAM TGP1H,7 92903-12301 REV.1805 780511 END   92903-18381 1805 S C0122 &TGP2H TGP SEGM 02 HDR SRC             H0101 yASMB,R NAM TGP2H,7 92903-12302 REV.1805 780511 END (  92903-18382 1805 S C0122 &TGP5H TGP SEGM 05 HDR SRC             H0101 yASMB,R NAM TGP5H,7 92903-12303 REV.1805 780511 END   92903-18383 1805 S C0122 &TGP6H TGP SEGM 06 HDR SRC             H0101 yASMB,R NAM TGP6H,7 92903-12304 REV.1805 780511 END   92903-18384 1805 S C0122 &TGP7H TGP SEGM 07 HDR SRC             H0101 yASMB,R NAM TGP7H,7 92903-12311 REV.1805 780511 END   92903-18385 1805 S C0122 &TGP8H TGP SEGM 08 HDR SRC             H0101 yASMB,R NAM TGP8H,7 92903-12305 REV.1805 780511 END   92903-18386 1840 S C0122 &TGP9H TGP SEGM 09 HDR SRC             H0101 tASMB,R NAM TGP9H,7 92903-12306 REV.1840 780811 END   92903-18387 1805 S C0122 &TG10H TGP SEGM 10 HDR SRC             H0101 [ASMB,R NAM TG10H,7 92903-12307 REV.1805 780511 END   92903-18388 1805 S C0122 &TG11H TGP SEGM 11 HDR SRC             H0101 [ASMB,R NAM TG11H,7 92903-12308 REV.1805 780511 END   92903-18389 1805 S C0122 &TG12H TGP SEGM 12 HDR SRC             H0101 [ASMB,R NAM TG12H,7 92903-12309 REV.1805 780511 END   92903-18390 1840 S C0122 &TG13H TGP SEGM 13 HDR SRC             H0101 WASMB,R NAM TG13H,7 92903-12310 REV.1840 780811 END   92903-18400 1805 S C0122 &TMGLB              H0101 ASMB HED . T M G L B H E A D E R NAM TMGLB,0 92903-12400 REV.1805 780517 * * NAME: TMGLB HEADER OF THE LIBRARY * SOURCE: &TMGLB::4 92903-18400 * BINARY: %TMGLB::4 92903-12400 HEADER OF TMGLB * * PMGR: FRANCOIS GAULLIER SPC 2 END g  92903-18401 1805 S C0222 &TMGCR              H0102 {FTN4 SUBROUTINE TMGCR(IERFL),92903-16401 REV.1805 780420 C C C NAME: TMGCR,HDR,EXTNL,DBL,MONAM,FLHND,MRLOC,NBTUS,STUSP C SOURCE: &TMGCR 92903-18401 C RELOC: %TMGCR 92903-16401 PART OF RTMGLB C C C C ************************************************************** C * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * C ************************************************************** C C C PGMR: DANIEL POT/FRANCOIS GAULLIER HPG C C C C *************************************** C * THIS ROUTINE CREATES ALL RELOCATA- * C * TABLE AND TRANSFER FILES ASSOCIAT- * C * TED TO AN APPLICATION. * C * THIS ROUTINE IS COMMON TO TMPGN AND * C * TMSGN PROGRAMS. * C *************************************** C C C IERFL ERROR FLAG RETURN BY THE COMPILER: C =0 RETURN OK, LOAD ALL PROGRAMS. C =3 FATAL ERROR, WAIT ACKNOWLEDGMENT FROM OPERATOR C AND TERMINATE. C =-1 FATAL ERROR, NO ROOM ON CARTRIDGE, WRITE MESSAGE AND C AND TERMINATE. C C C NCRTH(2400) ERROR FLAG C NCRTH(2399) RETURN ADDR IN CASE OF CR FULL C NCRTH(2398) TMSLB EXISTENCE FLAG C C C IRQFLG(1) : MAIN PROGRAM C IRQFLG(2) : TMST-TMSL-TMSIM C IRQFLG(3) : USER PARTITION # 1 C IRQFLG(I) : USER PARTITION # (I-2) C C COMMON LU,LUPRT,NCRTH(2400),IRLOC(70),ITRSF(20),IRQFLG(30) C DIMENSION IASMB(6),IMESA(23),IEROR(10) C LOGICAL STUSP,DORMT C DATA IMESA/15530B,15555B,15446B,2Hk0,2HB ,15510B,15512B,15542B .,2H ,15446B,2HdC,2HCR,2HEA,2HTI,2HON,2H P,2HHA,2HSE,15446B .,2Hd@,6412B,5012B,15554B/ DATA IEROR/6R412B,6412B,15446B,2HdC,2HER,2HRO,51033B,2H&d .,2H@ ,2H: / C C-----INIT INTERNAL COMPILER ERROR FLAG [NCRTH(2400)] C INIT ERROR ADDRESS RETURN INTO NCRTH(2399) C NCRTH(2400)=0 ASSIGN 5200 TO I NCRTH(2399)=I CALL EXEC(2,LU,IMESA,23) C C------STOP THE TMS APPLICATION ! C CALL MOVEW(NCRTH(5),ITRSF,2) ITRSF(3)=2H CALL LURQ(100000B,0,0) CALL ETMSP(ITRSF,99) CALL LURQ(1,LU,1) C C CHECK EXISTANCE OF %TMSLB (INIT FLAG NCRTH(2398) ) C CALL FLHND(0,2HCK) C IF(IRQFLG.EQ.0) GOTO 1000 C C **************************************************************** C * * C * * C * TMS-MAIN PROGRAM GENERATION * C * * C * GENERATES FILES: %XXXX - /XXXX * C * * C * * C **************************************************************** C CALL FLHND(2H ,2HOP) C C MAIN PROGRAM GENERATION (%XXXX) C IREFC=47B KREFC=IREFC-3 JREFC=NCRTH(4)-NCRTH(2)+KREFC LTMSAD=21B NTUS=NBTUS(NCRTH) NUPT=NBUPT(NCRTH) C CALL HDR(2H ,JREFC+6+5*NTUS+4*NUPT) C CALL EXTNL(2H ) C CALL DBL(0,2HIN) CALL DBL(76016B,2HMR) CALL DBL(16001B,2HX ) CALL DBL(16B,2HR ) CALL DBL(16B,2HR ) IF(STUSP(NCRTH(24),J,K)) STOP 3050 J=JREFC+J*5 CALL DBL(J,2HR ) IF(STUSP(NCRTH(28),J,K)) GOTO 30 J=JREFC+J*5 GO TO 40 30 J=KREFC 40 CALL DBL(J,2HR ) CALL DBL(17B,2HR ) C SET UP THE 'DEF .TMLU' CALL DBL(IREFC,2HR ) C SET UP THE 'DEF .TMTP' CALL DBL(((NCRTH(4)-NCRTH(t2))/2)+IREFC,2HR ) ITMSB=(NCRTH(4)-NCRTH(2))+IREFC+1 CALL DBL(ITMSB,2HR ) C SET UP THE 'DEF .TMPR' CALL DBL(5*NTUS+ITMSB+1,2HR ) C SET UP: 'DEF TMSL' , 'DEF TMST' AND 'DEF IMAGE' CALL DBL(LTMSAD,2HR ) CALL DBL(LTMSAD+3,2HR ) CALL DBL(LTMSAD+6,2HR ) CALL DBL(0,2H ) C SET UP INITIAL PROCESS LU & LOGGING LU CALL DBL(NCRTH(31),2H ) CALL DBL(NCRTH(21),2H ) C SET UP 'TMSL' AND 'TMST' PROGRAM NAME IASMB(3)=2H CALL MOVCA(NCRTH,9,IASMB,2,4) CALL PUTCA(IASMB,1HL,1) CALL MONAM(IASMB) CALL PUTCA(IASMB,1HT,1) CALL MONAM(IASMB) C SET UP IMAGE THINGS CALL MONAM(NCRTH(32)) CALL MONAM(NCRTH(35)) CALL DBL(NCRTH(38),2H ) CALL MONAM(NCRTH(39)) C SET UP 'TERMINATION PROGRAM NAME' & CONSTANT 0 CALL MONAM(NCRTH(42)) CALL DBL(0,2H ) C C LOGICAL UNITS / TYPES C CALL DBL((NCRTH(4)-NCRTH(2))/2,2H ) CALL DBL((NCRTH(3)-NCRTH(2))/2,2H ) CALL DBL(NCRTH(27),2H ) DO 400 J=NCRTH(2),NCRTH(4)-2,2 CALL DBL(NCRTH(J),2H ) 400 CONTINUE DO 410 J=NCRTH(2),NCRTH(4)-2,2 CALL DBL(NCRTH(J+1),2H ) 410 CONTINUE C C TOTAL NUMBER OF TMSUB C CALL DBL(NTUS,2H ) C C SUBROUTINES C NN=-1 J=NCRTH(4) 700 K=NCRTH(J) IF(J.EQ.(NCRTH+1)) GOTO 730 L=J+3 NN=NN+1 DO 710 M=1,K-J-5,3 LLL=L IF(IAND(NCRTH(LLL),100000B).NE.0) GOTO 705 CALL MONAM(NCRTH(LLL)) MMM=(NTUS*5)+(NCRTH(4)-NCRTH(2))+IREFC+2 CALL DBL(MMM+(NN*4)+1,2HR ) CALL DBL(0,2H ) L=L+3 710 CONTINUE 705 J=K GOTO 700 C C NUMBER OF PROGRAMS C 730 CALL DBL(NUPT,2H ) C C PROGRAMS C ICHAR=2HA J=NCRTH(4) 760 IF(J.EQ.(NCRTH+1)) GOTO 780 K=NCRTH(J) KDX=2390 CALL MOVEW(NCRTH(5),NCRTH(KDX),2) NCRTH(KDX+2)=ICHAR CALL ISUPB(NCRTH(KDX),3) CALL MONAM(NCRTH(KDX)) IF(STUSP(NCRTH(J+3),L,M)) STOP 3052 L=JREFC+L*5 CALL DBL(L,2HR ) J=K ICHAR=ICHAR+400B GOTO 760 780 CALL DBL(0,2HND) C C END RECORD C CALL FLHND(0,2HCS) C IRQFLG=1 IF(NCRTH(2398) .GE. 0) IRQFLG=100001B C 1000 IF(IRQFLG(2).EQ.0) GOTO 2000 C C **************************************************************** C * * C * * C * TMS-MAIN MODULES GENERATION * C * * C * GENERATES FILES: %TXXXX - /TXXXX * C * %LXXXX - /LXXXX * C * %IMAG. - /IMAG. * C * AS NEEDED. * C * * C * * C **************************************************************** C C IRQFLG(2)=0 DO 1500 I=1,3 C IF(I .EQ. 3) GOTO 1100 C K=2HT IF(I .EQ. 2) K=2HL IASMB=K CALL MOVEW(NCRTH(5),IASMB(2),2) CALL ISUPB(IASMB,3) IF(IDGET(IASMB) .NE. 0) GOTO 1500 J=1 GOTO 1200 C 1100 K=2HI IF(NCRTH(39) .EQ. 2H ) GOTO 1500 IF(.NOT. DORMT(NCRTH(39)) ) GOTO 1500 J=6 C 1200 CALL FLHND(K,2HOP) C CALL HDR(K,J) C CALL EXTNL(K) C C PROGRAM GENERATION C CALL DBL(0,2HIN) IF(K .NE. 2HI ) GOTO 1250 C CALL DBL(0,2HC ) CALL DBL(NCRTH(49)-1,2HC ) CALL DBL(076000B,2HMC) CALL DBL(104200B,2H ) CALL DBL(0,2HR ) 1250 CALL DBL(026001B,2HX ) CALL DBL(0,2HND) C C END RECORD C J=0 IF(I .EQ. 3) J=2 CALL FLHND(J,2HCS) C CALL SETBT(IRQFLG(2),I,1) C 1500 CONTINUE C SET BIT 15 IF LOADER MUST USE COMMAND FILE '/?APLT' IF(IRQFLG(2).NE.0 .AND. NCRTH(2398).GE.0) . CALL SETBT(IRQFLG(2),15,1) C C **************************************************************** C * * C * * C * TMS-USER PARTITION GENERATION * C * * C * GENERATES FILES: %XXXXN - /XXXXN * C * AS NEEDED * C * * C * * C **************************************************************** C 2000 DO 2900 I=1,NUPT IF(IRQFLG(I+2).EQ.0) GOTO 2900 C CALL FLHND((2H @)+I,2HOP) C J=IUPPT(I,N) C CALL HDR((2H @)+I,4+N) C CALL EXTNL((2H @)+I) C C PROGRAM GENERATION (%XXXXN) C CALL DBL(0,2HIN) CALL DBL(0,2H ) CALL DBL(026001B,2HX ) CALL DBL(N,2H ) N=2 K=NCRTH(J) DO 2030 L=J+3,K-3,3 IF(IAND(NCRTH(L),100000B).NE.0) GOTO 2040 CALL DBL(N,2HX ) 2030 N=N+1 C C SWAPPING OPTION C 2040 ISWP=0 IF(IAND(NCRTH(J+2),100000B).NE.0) ISWP=1 CALL DBL(ISWP,2H ) C C WRITE LAST PROGRAM RECORD C CALL DBL(0,2HND) C C END RECORD C CALL FLHND(0,2HCS) C 2900 CONTINUE C C C CREATION PHASE IS COMPLETED, WRITE MESS. ON CRT IF NEEDED C AND RETURN. C C IERFL=0 IF(NCRTH(2400).EQ.0) RETURN CALL MOVEW(IEROR,IRLOC,10) CALL MOVEW(26HLoading impossible due to ,IRLOC(11),13) CALL MOVEW(18Hprevious error ! ,IRLOC(24),9) CALL EXEC(2,LU,IRLOC,32) IE&RFL=3 C-----CLEAR LOADING REQUEST FLAG 5100 DO 5112 I=1,28 5112 IRQFLG(I)=0 RETURN C C NO ROOM ON CARTRIDGE !! C 5200 IERFL=-1 GOTO 5100 C C-----END OF COMPILER------------------------- C END SUBROUTINE HDR(IPARM,LEN),92903-16401 REV.1805 780420 C C C ******************************************* C * * C * THIS SUBROUTINE GENERATES THE BINARY * C * NAM RECORD OF ALL PROGRAMS. * C * * C * CALL HDR(P1,P2) * C * * C * P1 - DEFINE THE PROGRAM (MAIN, USER * C * PARTITION, LINK, TIMER OR IMAGE) * C * P2 - TOTAL LENGTH OF THE MODULE * C * * C ******************************************* C C COMMON LU,LUPRT,NCRTH(2400),IRLOC(70),ITRSF(20) C C INITIALISATION C CALL NUL(IRLOC,70) IRLOC(2)=20000B CALL MOVEW(NCRTH(5),IRLOC(4),2) IRLOC(6)=IPARM IRLOC(7)=LEN IRLOC(10)=3 IF(IPARM .EQ. 2H ) GOTO 30 IF(IPARM .NE. 2HI ) GOTO 50 C C-----SET UP HEADER FOR TMS IMAGE MODULE C CALL MOVEW(NCRTH(39),IRLOC(4),3) IRLOC(9)=NCRTH(49) IRLOC(11)=60 CALL MOVEW(6HIMAG. ,IRLOC(18),3) GOTO 40 C C-----SET UP HEADER FOR TMS LINK & TIMER MODULE C 50 IF(IPARM.NE.2HT .AND. IPARM.NE.2HL ) GOTO 100 IRLOC(4)=IPARM CALL MOVEW(NCRTH(5),IRLOC(5),2) IRLOC(11)=10 IF(IPARM .EQ. 2HL ) IRLOC(11)=70 CALL MOVEW(6HTIMER ,IRLOC(18),3) IF(IPARM .EQ. 2HL ) CALL MOVEW(6HLINK ,IRLOC(18),3) GOTO 40 C C-----SET UP HEADER FOR USER PARTITION C 100 CALL MOVEW(6HUPT.. ,IRLOC(18),3) K=IAND(IPARM,177B)-100B J=IASC(K) CALL MOVCA(J,1,IRLOC,38,2) J=IUPPT(K,N) IRLOC(11)=65 C-----DETERMINE COMMON SIZE AN!1D CHECK THAT ALL FILES EXIST IMAXI=0 K=NCRTH(J) DO 25 I=J+3,K-3,3 CALL FLHND(I,2HMX) IF(IMAXI.LT.ITRSF(9)) IMAXI=ITRSF(9) 25 CONTINUE IRLOC(9)=IMAXI GOTO 40 C C-----SETUP HEADER FOR MAIN PROGRAM C 30 CALL MOVEW(6HMAIN ,IRLOC(18),3) IRLOC(11)=65 C C-----MOVE THE COMMENT AREA C 40 CALL ISUPB(IRLOC(4),3) CALL MOVEW(NCRTH(7),IRLOC(21),10) IRLOC(31)=2H CALL MOVEW(NCRTH(17),IRLOC(32),4) C C-----WRITE HEADER IN THE RELOCATABLE FILE C CALL FLHND(35,2HWR) RETURN END SUBROUTINE EXTNL(IPARM),92903-16401 REV.1805 780211 C C C C **************************************** C * * C * THIS SUBROUTINE GENERATES THE EXTER- * C * NAL RECORD OF THE MAIN PROGRAM AND * C * PROGRAMS ASSOCIATED TO AN APPLICATION* C * * C * CALL EXTNL(P1) * C * * C * P1 = IDENTIFIES THE MODULE TO BE * C * GENERATED. * C * * C **************************************** C C C COMMON LU,LUPRT,NCRTH(2400),IRLOC(70) C DIMENSION NAME(3) C CALL MOVEW(NCRTH(5),NAME,2) NAME(3)=IPARM C IF(IPARM .NE. 2H ) GOTO 200 C C GENERATE MAIN PROGRAM EXTERNAL : 'TMSYS' C CALL MOVEW(6HTMSYS ,IRLOC(4),3) GOTO 250 C 200 K=IAND(IPARM,177400B)/256 IF(K .EQ. 40B) GOTO 300 C C GENERATE LINK, TIMER OR IMAGE MODULE EXTERNAL C '$LTMS' OR '$TTMS' OR '$ITMS' C IRLOC(4)=IOR(22000B,K) CALL MOVEW(4HTMS ,IRLOC(5),2) IF(IPARM .EQ. 2HI ) GOTO 220 NAME=IPARM CALL MOVEW(NCRTH(5),NAME(2),2) GOTO 250 220 CALL MOVEW(NCRTH(39),NAME,3) 250 IRLOC(6)=IAND(IRLOC(6),77400B)+1 ASSIGN 800 TO IRTRN I=7 CALL MRLOC(NAME,0,0)0.* GOTO 700 C C GENERATE USER PARTITION EXTERNAL : '$TML0' AND C ALL THE TUS. C 300 CALL MOVEW(6H$TML0 ,IRLOC(4),3) IRLOC(6)=IAND(IRLOC(6),077400B)+1 C C TRANSFERT FILE GENERATION C CALL MRLOC(NAME,0,0) C SETUP FOR 'EXT TMSB' GENERATION J=IUPPT(IAND(IPARM,177B)-100B,N) L=2 I=7 C C GENERATE BINARY & TRANSFERT FILE AT THE SAME TIME C ASSIGN 500 TO IRTRN K=NCRTH(J) DO 500 N=J+3,K-3,3 M=IAND(NCRTH(N),100000B) CALL MRLOC(NCRTH(N),M,0) IF(M .NE. 0) GOTO 500 CALL MOVEW(NCRTH(N),IRLOC(I),3) IRLOC(I+2)=IAND(IRLOC(I+2),077400B)+L L=L+1 I=I+3 IF(I.GE.59) GOTO 700 500 CONTINUE ASSIGN 800 TO IRTRN C C OUTPUT EXTERNAL RECORD C 700 IRLOC(2)=100000B+(I-4)/3 CALL FLHND(I-1,2HWR) I=4 GOTO IRTRN C C OUTPUT "SE,%TMSLB" INTO THE COMMAND FILE IF NEEDED C 800 CALL MRLOC(6H%TMSLB,1,NCRTH(2398)) RETURN END SUBROUTINE DBL(INSTR,JTYP),92903-16401 REV.1805 780211 C C C ********************************************* C * THIS SUBROUTINE GENERATES RELOCATABLE DBL * C * RECORDS AND WRITE THEM INTO AN %XXXX DISC * (:0C * FILE. * C * * C * CALL DBL(P1,P2) * C * * C * P1 = INSTRUCTION WORD * C * P2 = TYPE OF INSTRUCTION * C * * C * P2 BINARY FUNCTION * C * * C * IN INITIALISATION * C * ND END RECORD * C * SPACE 000 ABSOLUTE * C * MR 101 MEMORY REF., PROG. * C * MC 101 MEMORY REF., COMM. * C * X 100 EXTERNAL REF. * C * R 001 PROG. RELOC. * C * C 011 COMM. RELOC. * C * * C ********************************************* C C COMMON LU,LUPRT,NCRTH(2400),IRLOC(70) C C IADSS=CURRENT ADDR. IN RELOC MODULE (SIMULATE P REG.) C INBIW=NUMBER OF INSTRUCTION WORD C IRCPT=IRLOC POINTER C ITYPT=TYPE WORD POINTER C ICURT=DBL PROGRAM STATUS ( 1 = CURRENT RECORD ) C IOVFW=OVERFLOW INDEX C INBFD=NUMBER OF INSTRUCTIONS/FIELD C IFWFG=FIRST INSTRUCTION WORD FLAG C ITYPE=JTYP IF(ITYPE.EQ.2HND) GOTO 200 IF(ITYPE.NE.2HIN) GOTO 10 C C FLAG INITIALISATION FOR CURRENT DBL C ICURT=0 IADSS=0 RETURN C C POINTERS AND RECORD INITIALISATION C 10 IF(ICURT.EQ.1) GOTO 20 CALL NUL(IRLOC,70) INBIW=0 IFGTP=0 INBFD=0 IRCPT=6 ITYPT=5 IRLOC(ITYPT)=0 IRLOC(4)=IADSS ICURT=1 IOVFW=0 IFWFG=0 ILSTW=0 C C MEMORY REFERENCE INSTRUCTION,RELOCATABLE ADRESS C 20 MR=0 IF(ITYPE.EQ.2HMR) GOTO 30 MR=2 IF(ITYPE.NE.2HMC) GOTO 40 30 IOVFW=1 IF(IRCPT.GE.59) GOTO 120 IOVFW=0 IRLOC(IRCPT)=IOR(IAND(INSTR,176000B),MR) IRLOC(IRCPT+1)=IAND(INSTR,1777B) IRCPT=IRCPT+1 ITYPE=5B GOTO 100 C C EXTERNAL REFERENCE INSTRUCTION C 40 IF(ITYPE.NE.2HX ) GOTO 50 ITYPE=4B GOTO 58 C C RELOCATBLE INSTRUCTION C 50 IF(ITYPE.NE.2HR ) GOTO 55 ITYPE=1B GOTO 58 C C COMMON RELOCATABLE C 55 IF(ITYPE.NE.2HC ) GOTO 60 ITYPE=3 58 IRLOC(IRCPT)=INSTR GOTO 100 C C ABSOLUTE INSTRUCTION C 60 IF(ITYPE.NE.2H ) STOP 3055 IRLOC(IRCPT)=INSTR ITYPE=0B C C TYPE WORD GENERATION C 100 ICST=2 IF(INBFD.EQ.4) GOTO 115 DO 110 JJ=1,4-INBFD ICST=ICST*8 110 CONTINUE 115 IF(IFWFG.NE.0) GOTO 117 IFWFG=1 IFGTP=0 IF(ITYPE.GE.4) IFGTP=1 ITYPE=IAND(ITYPE,3) 117 ITYPE=ITYPE*ICST IF(IFGTP.EQ.1) ITYPE=IOR(ITYPE,100000B) IFGTP=0 IRLOC(ITYPT)=IOR(IRLOC(ITYPT),ITYPE) C C POINTER MAINTENANCE C IRCPT=IRCPT+1 INBIW=INBIW+1 INBFD=INBFD+1 ILSTW=0 C C WORDS CHECK C IOVFW=0 IF(INBFD.NE.5) GOTO 130 120 ITYPT=IRCPT INBFD=0 IRLOC(ITYPT)=0 IRCPT=IRCPT+1 IFWFG=0 ILSTW=1 C 130 IF(IRCPT.GE.61) GOTO 200 IF(IOVFW.EQ.1) GOTO 10 GOTO 320 C C TERMINATE A RECORD C 200 IF(ITYPE.NE.2HND.AND.ICURT.EQ.0) STOP 3060 IF(ICURT.EQ.0) GOTO 350 IF(ILSTW.EQ.1) IRCPT=IRCPT-1 IRLOC(2)=060100B+INBIW ICURT=0 CALL FLHND(IRCPT-1,2HWR) IF(IOVFW.EQ.1) GOTO 10 C 320 IADSS=IADSS+1 350 RETURN END SUBROUTINE MONAM(IBUF),92903-16401 REV.1805 780109 C C C **************************************** C * * C * THIS SUBROUTINE GENERATES THE PSEUDO * C * RELOCATABLE RECORD ASSOCIATED TO A * C * NApME. * C * * C * CALL MONAM(IBUF) * C * * C * IBUF IS THE NAME BUFFER * C * * C **************************************** C DIMENSION IBUF(1) C C DO 100 L=1,3 100 CALL DBL(IBUF(L),2H ) RETURN END SUBROUTINE FLHND(IPP1,IFNCT),92903-16401 REV.1805 780321 C C C ****************************************************************** C * * C * THIS SUBROUTINE HANDLES ALL FILES ACCESS. * C * * C * CALL FLHND(P1,P2) * C * * C * P1 = PARAMETER FOR NAME OR LENGTH * C * P2 = FUNCTION * C * * C * P2 FUNCTION * C * ---- ---------- * C * * C * OP OPEN OR CREATE FILE, P1 = LAST CHAR. OF FILE * C * NAME, SPACE OR X (FORMAT 2H.. ) * C * WR/WT WRITE IN THE FILE, 'IRLOC' INTO BINARY FILE * C * AND 'ITRSF' INTO TRANSFERT FILE. * C * COMPUTE CHECKSUM FOR BINARY RECORD AND * C * SUPPRESS SPACE ON SOURCE RECORD. * C * P1=RECORD LENGTH * C * CS CLOSE FILES, WRITE END RECORD ON BINARY FILE * C * OR 'END ' ON TRANSFERT FILE AND THEN CLOSE. * C * MX CHECK IF FILE AT NCRTH(P1) EXIST, AND IF * C * IT EXIST AND IS NOT A LIBRARY FILE, RETURN * C * THE COMMON SIZE INTO ITRSF(9) * C * CK CHECK EXISTANCE OF LIBRARY %TMSLB * C * * C ****************************************************************** C C C NCRTH(2398) IS USED AS EXISTENCE FLAG, THE CONVENTION C IS AS FOLLOW. C FLG < 0 FILE DOES NOT EXIST C FLG = 0 FILE EXIST ON THE DEFINED CARTRIDGE C FLG > 0 FILE EXIST ON THE SYSTEM (DON'T KNOW WERE) C C NCRTH(2398) FLAG FOR %TMSLB (TMS LIBRARY) C C NCRTH(2400) ERROR FLAG = 0 IF NO ERROR FOUND. C C COMMON LU,LUPRT,NCRTH(2400),IRLOC(70),ITRSF(20),IRQFLG(30) C DIMENSION NAME(3),IDCB(144),JDCB(144),KDCB(144) DIMENSION NAMR(3),NAMS(3) C INTEGER OPEN LOGICAL CMPB,CREAT,READF,WRITF C C OPEN OR CREATION OF RELOCATABLE AND TRANSFERT FILE C IF(IFNCT.NE.2HOP) GOTO 20 C====================================> FUNCTION: OPEN/CREATE ISIZ=2 NAMR=2H% CALL MOVCA(NCRTH,9,NAMR,2,4) CALL MOVCA(IPP1,2,NAMR,6,1) IF(IPP1 .EQ. 2HI ) CALL MOVCA(NCRTH,77,NAMR,2,5) IF(IPP1.NE.2HL .AND. IPP1.NE.2HT ) GOTO 6 CALL MOVCA(IPP1,1,NAMR,2,1) CALL MOVEW(NCRTH(5),NAMR(2),2) ISIZ=1 6 CALL ISUPB(NAMR,3) IF(OPEN(IDCB,IERR,NAMR,1,NCRTH(22),NCRTH(23)).EQ.05) GOTO 10 IF(IERR.NE.-006) GOTO 2990 IF(IPP1 .EQ. 2H ) ISIZ=3 IF(CREAT(IDCB,IERR,NAMR,ISIZ,5,NCRTH(22),NCRTH(23))) GOTO 2990 C C TRANSFER FILE OPENING/CREATION C 10 CALL MOVEW(NAMR,NAMS,3) CALL PUTCA(NAMS,1H/,1) IF(OPEN(JDCB,IERR,NAMS,1,NCRTH(22),NCRTH(23)).EQ.4) RETURN IF(IERR.NE.-6) GOTO 2991 IF(IPPXF1 .NE. 2H ) ISIZ=1 IF(CREAT(JDCB,IERR,NAMS,ISIZ,4,NCRTH(22),NCRTH(23))) GOTO 2991 RETURN C C WRITE OPERATION INTO RELOCATABLE FILE C 20 IF(IFNCT.NE.2HWR) GOTO 30 C====================================> FUNCTION: WRITE BINARY RECORD IRLOC=IPP1*256 CALL BRCKS(IRLOC,IPP1) IF(WRITF(IDCB,IERR,IRLOC,IPP1)) GOTO 2990 RETURN C C WRITE OPERATION INTO TRANSFERT FILE C 30 IF(IFNCT.NE.2HWT) GOTO 40 C====================================> FUNCTION: WRITE SOURCE RECORD IF(WRITF(JDCB,IERR,ITRSF,ISUPB(ITRSF,IPP1))) GOTO 2991 CALL BLAN(ITRSF,1,39) RETURN C C C CLOSE OPERATION (BOTH RELOC AND TRANSFER FILES) C 40 IF(IFNCT.NE.2HCS) GOTO 50 C====================================> FUNCTION: CLOSE IRLOC=1024 IRLOC(2)=120000B+1 IRLOC(4)=IPP1 IRLOC(3)=IRLOC(2)+IRLOC(4) IF(WRITF(IDCB,IERR,IRLOC,4)) GOTO 2990 CALL CLOSE(IDCB) C CALL MOVEW(4HEND ,ITRSF,2) IF(WRITF(JDCB,IERR,ITRSF,2)) GOTO 2991 CALL CLOSE(JDCB) RETURN C C READ TMS-RELOCATABLE FILES FOR COMMON MAX. C CHECK TMS-SUBROUTINE AND LIBRARY FILES C 50 IF(IFNCT.NE.2HMX) GOTO 400 C====================================> FUNCTION: GET COMMON SIZE ASSIGN 150 TO LABER J=IPP1 ITRSF(9)=0 NAME=2H% K=IAND(NCRTH(J),100000B) CALL MOVCA(NCRTH,(2*J)-1,NAME,2,5) IF(K.NE.0) CALL MOVCA(NCRTH,(2*J)-1,NAME,1,6) IF(OPEN(KDCB,IERR,NAME,1,NCRTH(22),NCRTH(23)).NE.5) GOTO 3000 IF(K.NE.0) GOTO 135 IF(READF(KDCB,IERR,ITRSF,20,LEN)) GOTO 2994 IERR=-99 ASSIGN 135 TO LABER IF( .NOT. CMPB(NAME,2,ITRSF,7,5)) GOTO 3000 IERR=-98 IF(ITRSF(9) .EQ. 0) GOTO 3000 135 CALL CLOSE(KDCB) 150 RETURN C C CHECK EXISTANCE OF %TMSLB C 400 IF(IFNCT .NE. 2HCK) STOP 3065 C====================================> FUNCTION: CHECK %TMSLB IF(NCRTH(2398) .LT. 0) RETURN CALL MOVEW(6H%TM$SLB,NAME,3) ASSIGN 460 TO IRTN C 410 ISC=NCRTH(22) ICR=NCRTH(23) K=0 LABER=IRTN 420 IF(OPEN(KDCB,IERR,NAME,1,ISC,ICR) .EQ. 5) GOTO IRTN K=-1 IF(IERR .EQ. -7) GOTO 3000 IF(IERR .NE. -6) GOTO 2994 IF(ICR .EQ. 0) GOTO IRTN ISC=0 ICR=0 K=1 GOTO 420 C 460 IF(K.GE.0) CALL CLOSE(KDCB) NCRTH(2398)=K RETURN C C ERROR MESSAGE PRINT-OUT C 2990 CALL MOVEW(NAMR,NAME,3) GOTO 2994 2991 CALL MOVEW(NAMS,NAME,3) 2994 LABER=NCRTH(2399) NCRTH(2380)=IERR IERR=-100 CALL CLOSE(IDCB) CALL CLOSE(JDCB) CALL CLOSE(KDCB) C 3000 NCRTH(2400)=1 CALL MOVEW(8H File : ,NCRTH(2373),4) CALL MOVEW(NAME,NCRTH(2377),3) KK=ISUPB(NCRTH(2377),3) IF(IERR .EQ. -100) GOTO LABER KK=KK+2377 CALL BLANC(NCRTH(2392),3) IF(IERR.EQ.-6) . CALL MOVEW(30H is NOT on the cartridge ,NCRTH(KK),15) IF(IERR.EQ.-99) . CALL MOVEW(30H has a TUS with an other name ,NCRTH(KK),15) IF(IERR.EQ.-98) . CALL MOVEW(30H has a TUS with no common ,NCRTH(KK),15) IF(IERR.EQ.-7) . CALL MOVEW(30H has a wrong security code ,NCRTH(KK),15) IF(IERR.GT.0) . CALL MOVEW(30H has a wrong file type ,NCRTH(KK),15) CALL EXEC(2,LU,NCRTH(2373),22) GOTO LABER END SUBROUTINE MRLOC(NAME,LBFLG,IFLG),92903-16401 REV.1805 780109 C C *************************************************** C * THIS SUBROUTINE GENERATES LINE INTO THE COMMAND * C * FILE FOR THE LOADR. * C * * C * NAME - FILE NAME * C * LBFLG - FLAG USED TO GEN. RE, .. OR SE, .. * C * 0 ---> RE,%NAME (ADD '%' SIGN) * C * NOT 0 ---> SE,NAME * C * IFLG - FLAG USED TO GENERATE THE SECOD:CR# * C * < 0 ---> DO NOT GEN. ANY RECORD * C * = 0 ---> FULL NAMR (NAME:SC:CR#) * C * > 0 ---> STRIP NAMR (NAME::) * C * * C *************************************************** C C COMMON LU,LUPRT,NCRTH(2400),IRLOC(70),ITRSF(20) C IF(IFLG .LT. 0) RETURN C CALL BLAN(ITRSF,1,26) CALL MOVEW(4HRE,%,ITRSF,2) IF(LBFLG.NE.0) CALL MOVEW(4HSE, ,ITRSF,2) CALL MOVEW(NAME,ITRSF(3),3) L=5 IF(IFLG .NE. 0) GOTO 1000 L=13 IF(NCRTH(22) .EQ. 0) GOTO 500 ITRSF(6)=2H: CALL JASC(NCRTH(22),ITRSF,13,6) 500 IF(NCRTH(23) .EQ. 0) GOTO 1000 ITRSF(6)=2H: ITRSF(10)=2H: CALL JASC(NCRTH(23),ITRSF,21,6) 1000 CALL FLHND(L,2HWT) RETURN END FUNCTION NBTUS(NCRTH),92903-16401 REV.1805 770729 C C C C ****************************************** C * THIS FUNCTION RETURNS THE NUMBER OF * C * TMS-SUBROUTINES ENTERING IN AN * C * APPLICATION. * C ****************************************** C C DIMENSION NCRTH(1) C C C THIS SUBROUTINE CALCULATES THE NUMBER OF TMS-SUBROUTINES C M=0 J=NCRTH(4) 100 K=NCRTH(J) DO 150 L=J+3,K-3,3 IF(IAND(NCRTH(L),100000B).NE.0) GOTO 200 M=M+1 150 CONTINUE 200 J=K IF(J.NE.(NCRTH+1)) GOTO 100 NBTUS=M RETURN END LOGICAL FUNCTION STUSP(NAME,ITUS, .IUPT),92903-16401 REV.1805 771215 C C ****************************************************************** C * * C * SEARCH A TMS-USER-SUBROUTINE INTO THE PACKED FORMT OF NCRTH * C * * C * IF(STUSP(NAME,TUS#,UPT#)) GOTO .. (TUS NOT FOUNDED) * C * 40.* * C * NAME - NAME OF THE TMS-USER-SUBROUTINE (3 WORDS ASCII) * C * TUS# - RETURN THE TUS NUMBER IF FOUND (1ST IS 1) * C * UPT# - RETURN THE USER PARTITION NUMBER IF FOUND (1ST IS 1)* C * * C * NOTE: IF NOT FOUND, TUS# AND UPT# WILL BE DESTROYED * C * ----- * C * * C ****************************************************************** C C COMMON LU,LUPRT,NCRTH(2400) DIMENSION NAME(1) C LOGICAL CMPW C I=NCRTH(4) STUSP=.FALSE. ITUS=1 IUPT=1 10 DO 40 J=I+3,NCRTH(I)-3,3 IF(IAND(NCRTH(J),100000B).NE.0) GOTO 50 IF(CMPW(NAME,NCRTH(J),3)) RETURN 40 ITUS=ITUS+1 C 50 I=NCRTH(I) IUPT=IUPT+1 IF(I .NE. NCRTH+1) GOTO 10 C C TUS NOT FOUND C STUSP=.TRUE. RETURN END END$ 0  92903-18402 1805 S C0122 &TMGLD              H0101 FTN4 SUBROUTINE TMGLD(IERFL),92903-16402 REV.1805 780517 C C C NAME: TMGLD,BIDLD,IUPPT C SOURCE: &TMGLD 92903-18402 C RELOC: %TMGLD 92903-16402 PART OF RTMGLB C C C C ************************************************************** C * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * C ************************************************************** C C C PGMR: FRANCOIS GAULLIER HPG C C C C ************************************************** C * * C * THIS SUBROUTINE LOAD ALL PROGRAMS OF A TMS * C * APPLICATION ACCORDING TO THE USER REQUEST * C * [IMOTR(2)] AND THE LOADING REQUEST FLAG * C * SET BY OTHERS TMSGN MODULE [IRQFLG(1:30)] * C * * C ************************************************** C C IERFL IS AN ERROR FLAG C = 0 OK, NO ERROR C = -2 ERROR OCCURED, REPORT IT TO OPERATOR C C COMMON LU,LUPRT,NCRTH(2400),IRLOC(70),ITRSF(20),IRQFLG(30) COMMON IMOTR(9) C DIMENSION IREG(2),LOADR(3),ILODP(23) C INTEGER AREG,BREG LOGICAL ISBIT,IDCLR EQUIVALENCE (REG,IREG,AREG),(IREG(2),BREG) EQUIVALENCE (IRLO2,IRLOC(2)) C DATA LOADR/2HLO,2HAD,2HR / DATA ILODP/15530B,15555B,15446B,2Hk0,2HB ,15510B,15512B,15542B .,2H ,15446B,2HdC,2HLO,2HAD,2HIN,2HG ,2HPH,2HAS,2HE ,15446B .,2Hd@,6412B,5012B,15554B/ C IERFL=0 C C LOADING TO PERFORM ? C IF(IMOTR(2) .LE. 1) GOTO 1100 ISTYP=IMOTR(5) C C-----IF LOADER LIST ON CRT, UNLOCK THE CRT C IF(LUPRT .EQ. LU) CALL LURQ(0,LU,1) C C-----LOADING OPERATION C CAyLL EXEC(2,LU,ILODP,23) CALL EXEC(3,1100B+LUPRT,-1) CALL BLANC(ITRSF(4),8) IF(NCRTH(22) .EQ. 0) GOTO 120 NCRTH(4)=2H: CALL JASC(NCRTH(22),ITRSF,9,6) 120 IF(NCRTH(23) .EQ. 0) GOTO 150 ITRSF(4)=2H: ITRSF(8)=2H: CALL JASC(NCRTH(23),ITRSF,17,6) 150 IF(IRQFLG(2) .EQ. 0) GOTO 1000 C C LOAD %TMSL - %TMST - %TMSIN C ITRSF=2H%T C IF BIT 15 SET INTO RQFLAG, USE COMMAND FILE IF( ISBIT(IRQFLG(2),15) ) ITRSF=2H/T CALL MOVEW(NCRTH(5),ITRSF(2),2) ASSIGN 400 TO LDRTN K=0 J=2378 CALL NUL(NCRTH(J),2) C DO 400 I=1,3 IF( .NOT. ISBIT(IRQFLG(2),I) ) GOTO 400 IF(I .EQ. 2) CALL PUTCA(ITRSF,1HL,2) IF(I .NE. 3) GOTO 2000 CALL MOVCA(NCRTH,77,ITRSF,2,5) J=47 K=1 GOTO 2000 400 CONTINUE C 1000 ITRSF=2H% IF( ISBIT(IRQFLG,15) ) ITRSF=2H/ ITRSF(3)=2H CALL MOVCA(NCRTH,9,ITRSF,2,4) IF(IRQFLG .EQ. 0) GOTO 1020 C C LOAD MAIN PROGRAM C ASSIGN 1020 TO LDRTN K=1 J=45 GOTO 2000 C C LOAD USER PARTITION C 1020 I=3 IDEX=NCRTH(4) CALL PUTCA(ITRSF,1H/,1) CALL PUTCA(ITRSF,1HA,6) ASSIGN 1040 TO LDRTN K=0 1030 IF(IRQFLG(I) .EQ. 0) GOTO 1040 J=IUPPT(I-2,N)+1 GOTO 2000 1040 ITRSF(3)=ITRSF(3)+1 I=I+1 IDEX=NCRTH(IDEX) IF(IDEX.NE.NCRTH+1) GOTO 1030 C C LOADING PHASE IS COMPLETED, IF CRT HAS BEEN UNLOCKED, RE-LOCK IT C 1090 IF(LU .EQ. LUPRT) CALL LURQ(1,LU,1) C C CLEAR LOADING REQUEST FLAG C 1100 DO 1150 I=1,28 1150 IRQFLG(I)=0 RETURN C C CALL THE LOADER AND CHECK RESULT C 2000 IRLOC=2H IF(IMOTR(2).NE.2 .AND. IMOTR(2).NE.5) GOTO 2200 IRLOC(4)=2H CALL MOVCA(ITRSF,2,IRLO2,1,5) CALL ISUPB(IRLO2,3) IF( .NOT. IDCLR(IRLO2,IERR) ) GOTO 2050 IF(IERR .EQ. -1) GOTO 2200 CALL MOVEW(4HDUPL,IRLOC(4),2) 8 GOTO 2500 2050 CALL MOVEW(10H ABORTED ,IRLOC(5),5) IF(LUPRT .EQ. 1) GOTO 2200 CALL EXEC(2,LUPRT,IRLOC,9) CALL EXEC(2,LUPRT,IRLOC,-1) C 2200 CALL BIDLD(ITRSF,K,NCRTH(J),IRLO2,L) CALL EXEC(2,LUPRT,IRLOC,L+1) CALL EXEC(2,LUPRT,IRLOC,-1) CALL EXEC(23,LOADR,LUPRT,0,0,0,0,IRLO2,L) CALL RMPAR(IRLOC) IMOTR(5)=ISTYP IF(IRLOC .GT. 0) GOTO LDRTN 2500 IERFL=-2 GOTO 1090 END SUBROUTINE BIDLD(NAME,ISSGA,ISIZ,IBUF .,L),92903-16402 REV.1805 771211 C C BUILD "RU,LOADR . . . . " STATEMENT C C NAME - NAMR = NAME:SC:CR (11 WORDS) C IF 1ST CHAR=% ---> INPUT FILE C ELSE IT IS A COMMAND FILE. C ISSGA- SSGA FLAG C IF=0 ---> DO NOT ACCESS SSGA C ELSE ACCESS SSGA C ISIZ - ARRAY OF DIMENSION = 2 C 1ST WORD = PARTITION SIZE C 2ND WORD = PARTITION NUMBER C IBUF - ARRAY (AT LEAST 29 WORDS) C USED TO RETURN THE STRING C L - INTEGER VARIABLE C RETURN THE LENGTH OF THE STRING GENERARTED C C COMMON LU,LUPRT,NCRTH(2400),IDUMMY(120),IMOTR(9) C C IMOTR(2) LOADING OPTION BG/RT RP/PE/TE C IMOTR(3) LOADING LIST (0 ---> NO LIST) C IMOTR(5) SYSTEM TYPE ($OPSY) RTE-IV = -9 C DIMENSION ISIZ(1),IBUF(1) C CALL MOVEW(8HRU,LOADR,IBUF,4) CALL MOVEW(NAME,IBUF(6),11) C-----SET COMMAND OR INPUT FILE IBUF(5)=2H, IBUF(17)=2H,, IF(IGET1(NAME,1) .NE. 1H% ) GOTO 50 IBUF(5)=2H,, IBUF(17)=2H, C-----SET LIST LU 50 CALL JASC(LUPRT,IBUF,35,2) CALL MOVEW(22H, BG , , ,IBUF(19),11) I=2*IMOTR(2)-3 IF(I.LT.7) GOTO 60 IBUF(20)=2HRT I=I-6 60 CALL MOVCA(6H RPPE,I,IBUF,41,2) C-----OVERRIDE BG/RT WITH LB IF RTE-IV IF(IMOTR(5) .EQ. -9) IBUF(20)=2HLB C-----SET COMMON ID IF(ISSGA .NE. 0) IBUF(22)=2HSS C-----SET LIST OPTION  IF(IMOTR(3) .EQ. 0) IBUF(24)=2HNL C-----SET PARTITION NUMBER CALL JASC(IAND(ISIZ(2),377B),IBUF,51,4) IF(IBUF(27).EQ.2H 0) IBUF(27)=2H C-----SET PARTITION SIZE IF(ISIZ.EQ.0) GOTO 80 IBUF(28)=2H, CALL JASC(ISIZ,IBUF,57,2) 80 L=ISUPB(IBUF,29) RETURN END INTEGER FUNCTION IUPPT(IUPT,NTUS),92903-16402 REV.1805 770729 C C C C ****************************************************************** C * * C * THIS FUNCTION RETURNS THE POINTER INTO NCRTH FOR A GIVEN USER * C * USER PARTITION, IT REURN ALSO THE NUMBER OF TUS IN THAT USER * C * PARTITION. * C * * C * * C * IPT = IUPPT(UPT#,NTUS) * C * * C ****************************************************************** C C C COMMON LU,LUPRT,NCRTH(2400) C J=NCRTH(4) M=1 100 K=NCRTH(J) IF(J.EQ.NCRTH+1) STOP 3043 IF(M.EQ.IUPT) GOTO 200 J=K M=M+1 GOTO 100 200 N=0 DO 300 L=J+3,K-3,3 IF(IAND(NCRTH(L),100000B).NE.0) GOTO 400 300 N=N+1 400 IUPPT=J NTUS=N RETURN END END$   92903-18403 1805 S C0122 &TMGPU              H0101 FTN4 SUBROUTINE TMGPU(IMAG,MAIN,M,N),92903-16403 REV.1805 780421 C C C NAME: TMGPU,KLPRG C SOURCE: &TMGPU 92903-18403 C RELOC: %TMGPU 92903-16403 PART OF RTMGLB C C C C ************************************************************** C * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * C ************************************************************** C C C PGMR: FRANCOIS GAULLIER HPG C C C **************************************************************** C * * C * THIS SUBROUTINE PURGE AND CLEAR ID-SEGMENT OF ALL * C * REQUESTED PROGRAM. * C * * C * CALL TMGPU(IMAG,MAIN,M,N) * C * IMAG - .TRUE. IF IMAGE MODULE NEED TO REMOVED (FILES * C * PURGED AND IDSEG CLEARED) * C * MAIN - .TRUE. IF MAIN MODULES NEED TO BE REMOVED (FILES * C * PURGED AND IDSEG CLEARED) * C * M - NUMBER OF THE FIRST USER PARTITION TO REMOVE * C * M - NUMBER OF THE LAST USER PARTITION TO REMOVE * C * * C **************************************************************** C C COMMON LU,LUPRT,NCRTH(2400),IRLOC(70) C DIMENSION NAME(3),IPUG(22) C LOGICAL DODO,IMAG,MAIN C DATA IPUG/15530B,15555B,15446B,2Hk0,2HB ,15510B,15512B,15542B .,2H ,15446B,2HdC,2HPU,2HRG,2HE ,2HPH,2HAS,2HE ,15446B,2Hd@ .,6412B,5012B,15554B/ C IF (MAIN) CALL EXEC(2,LU,IPUG,22)s CALL BLANC(IRLOC,40) C C-----STOP THE TMS APPLICATION C CALL MOVEW(NCRTH(5),NAME,2) NAME(3)=2H CALL LURQ(100000B,0,0) CALL ETMSP(NAME,99) CALL LURQ(1,LU,1) C C-----IF LIST LU IS NOT THE CRT, LOCK THE LIST LU C CALL LCKLL(LU,LUPRT,500) C C-----WRITE HEADER ON LIST DEVICE C CALL EXEC(3,1100B+LUPRT,-1) CALL EXEC(2,LUPRT,IRLOC,-1) CALL EXEC(2,LUPRT,IRLOC,-1) CALL MOVEW(12HFILES PURGED,IRLOC(7),6) CALL MOVEW(16HPROGRAMS REMOVED,IRLOC(26),8) CALL EXEC(2,LUPRT,IRLOC,33) CALL EXEC(2,LUPRT,IRLOC,-1) CALL EXEC(2,LUPRT,IRLOC,-1) C C-----GET RID OF USER PARTITION C DO 100 I=N,M,-1 NAME(3)=2H @+I CALL KLPRG(NAME,1) 100 CONTINUE C C-----GET RID OF TMS-IMAGE MODULE C IF (IMAG) CALL KLPRG(NCRTH(39),1) C C-----GET RID OF TMST, TMSL AND TMS MAIN C IF( .NOT. MAIN) GOTO 500 NAME=2HL NAME(3)=2H CALL MOVCA(NCRTH,9,NAME,2,4) CALL KLPRG(NAME,1) CALL PUTCA(NAME,1HT,1) CALL KLPRG(NAME,1) CALL MOVEW(NCRTH(5),NAME,2) NAME(3)=2H CALL KLPRG(NAME,1) C C-----PURGE FILE &XXXX C CALL KLPRG(NAME,2) C C-----END OF PURGE------------------------- C 500 CALL EXEC(3,1100B+LUPRT,-1) C C-----IF LIST LU HAS BEEN LOCKED, UNLOCK IT IF(LUPRT .NE. LU) CALL LURQ(0,LUPRT,1) RETURN END SUBROUTINE KLPRG(NAME,IFLG),92903-16403 REV.1805 780225 C C C ****************************************************************** C * * C * THIS SUBROUTINE PURGE AND REMOVE ID SEGMENT FOR ONE PROGRAM. * C * * C * CALL KLPRG(NAME,IFLG) * C * * C * NAME - NAME OF THE PROGRAM TO BE REMOVED, l * C * ILFG - FUNCTION * C * * C * IFLG FUNCTION * C * ---- ---------- * C * * C * 0 PURGE FILES "%NAME" AND "NAME" * C * 1 PURGE FILES "%NAME","/NAME" AND "NAME" * C * 2 PURGE FILES "&NAME" AND DO NOT * C * CLEAR THE ID-SEGMENT NAME. * C * * C ****************************************************************** C C COMMON LU,LUPRT,NCRTH(2400),IRLOC(70) C DIMENSION IREG(2),NAME(1),IDCB(144),NOM(4) C INTEGER AREG,BREG LOGICAL PURGE,IDCLR,PRINT C EQUIVALENCE (REG,AREG,IREG),(IREG(2),BREG) C CALL BLANC(IRLOC,32) PRINT=.FALSE. J=4 C C SET UP FILE NAME C NOM=2H% CALL MOVEW(NAME,NOM(2),3) CALL ISUPB(NOM,4) CALL MOVEW(NCRTH(22),AREG,2) ASSIGN 50 TO IRTN IF(IFLG .NE. 2) GOTO 1000 CALL PUTCA(NOM,1H&,1) ASSIGN 200 TO IRTN GOTO 1000 50 IF(IFLG .EQ. 0) GOTO 60 CALL PUTCA(NOM,1H/,1) ASSIGN 60 TO IRTN GOTO 1000 60 CALL PUTCA(NOM,1H ,1) AREG=0 BREG=2 CALL ISUPB(NOM,3) ASSIGN 70 TO IRTN GOTO 1000 70 J=28 ASSIGN 200 TO IRTN IF( .NOT. IDCLR(NOM,IERR)) GOTO 1100 IF(IERR .EQ. -1) GOTO IRTN GOTO 1050 C 200 IF (PRINT) CALL EXEC(2,LUPRT,IRLOC,J-3) RETURN C C PURGE PROCESS C 1000 IF( .NOT. PURGE(IDCB,IERR,NOM,AREG,BREG)) GOTO 1100 IF(IERR .EQ. -6) GOTO IRTN 1050 IRLOC(J-1)=2H < IRLOC(J+3)=2H> IF(IERR .EQ. -7) IRLOC(J+4)=2HSC IF(IERR .EQ. -2) IRLOC(J+4)=2HDO IF(IERR .EQ. -3) IRLOC(J+4)=2HSY IF(IERR .EQ. -4) IRLOC(J+4)=2HPE IF(IERR .EQ. -5) IRLOC(J+4)=2HCR 1100 CALL MOVEW(NOM,IRLOC(J),3) CALL ISUPB(IRLOC(J),4) IF(J.NE.4 .AND. J.NE.28) IRLOC(J-2)=2H - PRINT=.TRUE. J=J+7 GOTO IRTN END END$ z  92903-18404 1805 S C0122 &TMGL5              H0101 vFTN4 C C C NAME: CTILU,LOOLU,DPILU,DUPLU,LCKLU,TMPRS,DUPNA,CTRAC C SOURCE: &TMGL5 92903-18404 C BINARY: %TMGL5 92903-16404 PART OF RTMGL1 C C C C ************************************************************** C * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * C ************************************************************** C C C PGMR: DANIEL POT/FRANCOIS GAULLIER HPG C C SUBROUTINE CTILU,92903-16404 REV.1805 780109 C C C THIS SUBROUTINE TRANSLATES NCRTH(45) INTO NCRTH(2000) C IN ORDER TO BE DISPLAYABLE ON SCREEN NUMBER 1. C C COMMON LU,LUPRT,NCRTH(2400) C IREFC=50 ILUGH=128 CALL NUL(NCRTH(2000),192) K=IREFC J=2000 DO 10 I=IREFC,IREFC+ILUGH-4,2 IF(NCRTH(I+1).EQ.NCRTH(I+3).AND.NCRTH(I+2).EQ.(NCRTH(I))+1) .GOTO 10 NCRTH(J)=NCRTH(K) NCRTH(J+1)=NCRTH(I) IF(NCRTH(J+1).EQ.NCRTH(J)) NCRTH(J+1)=0 NCRTH(J+2)=NCRTH(K+1) K=I+2 J=J+3 10 CONTINUE RETURN END LOGICAL FUNCTION LOOLU(IADS,ILUB,IPTR,NUERO .,IBUFR),92903-16404 REV.1805 780109 C C FUNCTION TO FIND DUPLICATE LUS C C FUNCTION IS FALSE IF THE LU TO BE CHECKED (ILUB) IS NOT C ALREADY AN INTERACTIVE OR AUXILIARY DEVICE. C COMMON LU,LUPRT,NCRTH(2400) DIMENSION IBUFR(1) C C C IADS=WORD NCRTH ADRESS C ILUB=LU# TO CHECK C IPTR=FIELD POINTER C NUERO=RETURNED ERROR MESSAGE NUMBER C IBUFR=CURRENT BUFFER C C IREFC=50 ILUGH=128 ITRU=0 NUERO=0 ITOP=IREFC+ILUGH LOOLU=.FALSE. DO 10 I=IREFC,ITOP-2,2 IF(NCRTH(I).EQ.ILUB) ITRU=1 10 CONTINUE IF(ITRU.EQ.0) GOTO 15 @%NUERO=12 GOTO 40 15 IF(IADS.EQ.ITOP) GOTO 25 DO 20 I=ITOP,IADS-2,2 IF(NCRTH(I).EQ.ILUB) ITRU=1 20 CONTINUE 25 IF(IPTR.EQ.1) GOTO 35 DO 30 I=1,IPTR-2,2 IF(IBUFR(I).EQ.ILUB) ITRU=1 30 CONTINUE 35 IF(ITRU.EQ.0.AND.IBUFR(I+1).EQ.-1) NUERO=11 IF(ITRU.EQ.1.AND.IBUFR(I+1).NE.-1) NUERO=8 40 IF(NUERO.NE.0) LOOLU=.TRUE. RETURN END SUBROUTINE DPILU,92903-16404 REV.1805 770802 C C C THIS SUBROUTINE DEPACK THE INTERACTIVE LU BUFFER IN NCRTH(200) C AND THEN TRANSLATES NCRTH(2000) INTO NCRTH(50), ITS FINAL C PLACE. C USED ONLY FOR THE INTERCATIVE LU PROCESS. C ------------ C C COMMON LU,LUPRT,NCRTH(2400) DIMENSION IDPAK(260) C IREFC=50 ILUGH=128 ILEGH=260 C C DEPACK NCRTH(2000) INTO IDPAK(1) C TYPE TO DELETE ZEROED C CALL NUL(IDPAK,ILEGH) J=1 DO 30 I=2000,2000+192-3,3 IF(NCRTH(I).EQ.0) GOTO 35 IF(NCRTH(I+1).EQ.0) GOTO 20 L=J M=NCRTH(I) IED=J+(NCRTH(I+1)-NCRTH(I))*2 DO 10 N=L,IED,2 IDPAK(N)=M IDPAK(N+1)=NCRTH(I+2) IF(IDPAK(N+1).EQ.-1) IDPAK(N+1)=0 M=M+1 J=J+2 10 CONTINUE GOTO 30 20 IDPAK(J)=NCRTH(I) IDPAK(J+1)=NCRTH(I+2) IF(IDPAK(J+1).EQ.-1) IDPAK(J+1)=0 J=J+2 30 CONTINUE C C LU# ORDERED IN INCREASING ORDER C 35 CALL ITRIC(IDPAK,ILEGH,1) C C TYPE WITH SAME LU# ORDERED IN INCREASING ORDER C J=2 DO 50 I=1,ILEGH+1-4,2 IF(IDPAK(I).EQ.IDPAK(I+2)) GOTO 50 IF(I-J.GE.1) GOTO 40 J=I+3 GOTO 50 40 CALL ITRIC(IDPAK(J-1),(I-J)+3,2) J=I+3 50 CONTINUE IF(IDPAK(I-2).NE.IDPAK(I)) GOTO 55 CALL ITRIC(IDPAK(I-2),4,2) C C ELIMINATE LU# IF FIRST OF TWO ONE IS "0" TYPE C 55 K=1 60 IF(IDPAK(K+1).NE.0) GOTO 70 IF(IDPAK(K).EQ.IDPAK(K+2)) GOTO 65 IDPAK(K)=0 8 GOTO 70 65 IDPAK(K)=0 IDPAK(K+2)=0 K=K+2 IF(K.EQ.ILEGH-3) GOTO 90 70 K=K+2 IF(K.EQ.ILEGH-3) GOTO 100 80 GOTO 60 90 IF(IDPAK(K+3).EQ.0) IDPAK(K+2)=0 GOTO 120 100 IF(IDPAK(K+1).NE.0) GOTO 90 IF(IDPAK(K).EQ.IDPAK(K+2)) GOTO 105 IDPAK(K)=0 GOTO 90 105 IDPAK(K)=0 IDPAK(K+2)=0 GOTO 120 C C STORE RESULT IN NCRTH(IREFC) C 120 CALL ISPRZ(IDPAK,ILEGH,LEN) CALL NUL(NCRTH(IREFC),ILUGH) CALL MOVEW(IDPAK,NCRTH(IREFC),LEN) RETURN END SUBROUTINE DUPLU(IBUF,LEN,IFILD,LUER),92903-16404 REV.1805 780304 C C C THIS SUBROUTINE LOOK FOR DUPLICATE INTERACTIVE LU# C IFILD = RETURNED FIELD NUMBER C LUER = DEFECTIVE LU# (ASCII) C LUER= [] : LUS #*[] * C * IPOS = 2 ----> #[*] * C * IPOS = 3 ----> [#*] * C * IPOS = 4 ----> [#]* * C * IPOS = 5 ----> []#* * C * IPOS = 6 ----> #[]* * C +-----------------------+ C C CHECK LINE: I AGAINST ALL PREVIOUS LINES C DO 10 K=1,I-3,3 IPOS=0 ITR1=0 ITR2=0 ITR3=0 ITR4=0 IF(IBUF(I+1).EQ.0) IBUF(I+1)=IBUF(I) IF(IBUF(K+1).EQ.0) IBUF(K+1)=IBUF(K) C C-----* [ ] ? is ITR1 C IF(IBUF(I+1).LT.IBUF(K)) ITR1=1 C C-----[ * ] ? ITR2 C IF(.NOT.ISBTW(IBUF(I+1),IBUF(K),IBUF(K+1))) ITR2=1 C C-----[ # ] ? ITR3 C IF(.NOT.ISBTW(IBUF(I),IBUF(K),IBUF(K+1))) ITR3=1 C C-----[ ] # ? ITR4 C IF(IBUF(I).GT.IBUF(K+1)) ITR4=1 C C LOOK FOR FIRST LU# INCLUDED, IF REQUIRED C IF(ITR2.EQ.1) CALL LCKLU(K,I+1,K+1,IBUF,LUER) IF(ITR3.EQ.1) CALL LCKLU(K,I,K+1,IBUF,LUER) C C CALCULATES IPOS C IF(ITR1.EQ.1.AND.ITR3+ITR4.EQ.0) IPOS=1 IF(ITR2.EQ.1.AND.ITR3+ITR4.EQ.0) IPOS=2 IF(ITR2.EQ.1.AND.ITR3.EQ.1) IPOS=3 IF(ITR3.EQ.1.AND.ITR1+ITR2.EQ.0) IPOS=4 IF(ITR4.EQ.1.AND.ITR1+ITR2.EQ.0) IPOS=5 IF(ITR1+ITR2.EQ.0.AND.ITR3+ITR4.EQ.0) IPOS=6 IF(IPOS.EQ.0) STOP 6001 C C VERIFY CORRECT DEFINITION C IF(IBUF(I+2).EQ.-1.AND.IBUF(K+2).NE.-1) GOTO 7 C C NO DELETE IS INVOLVE IN THE CURRENT LINE I C CHECK FOR DUPLICATE LU'S C IF(IPOS.EQ.2) GOTO 30 IF(IPOS.EQ.4) GOTO 40 IF(IPOS.EQ.3) GOTO 40 IF(IPOS.EQ.6) GOTO 20 LUER=0 GOTO 10 C C A DELETE IS REQUESTED IN THE CURRENT LINE C IF LU FOUND THEN GO TO NEXT LINE I C 7 IF(IPOS .EQ. 3) GOTO 100 C-----DELETE BUT THE LU IS NOT YET FOUND, CONTINUE 10 CONTINUE C-----IF DELETE, THE LU HAS NEVER BEEN FOUNDED, ERROR ! IF(IBUF(I+2) .EQ.-1) GOTO 50 C C CHECK LINE I AGAINST NEXT ONE C 90 IFILD=IFILD+3 LUER=0 C C LINE I HAS BEEN CHECK AGAINST ALL PREVIOUS LINE, C GO TO NEXT LINE I C 100 CONTINUE LUER=0 RETURN C 20 LUER=2H[] RETURN C C DUPLICATE LU'S (THE 'TO' LU IS DUPLICATED) C 30 IFILD=IFILD+1 40 RETURN C C ERROR "UNDEFINED LU" USED IN CASE OF DELETE C 50 IF(IPOS.EQ.4) IFILD=IFILD+1 LUER=-1 RETURN END SUBROUTINE LCKLU(IBRN1,IBRN2,IBRN3,IBUF .,LUER),92903-16404 REV.1805 770802 C C C THIS SѨUBROUTINE SEARCH FOR THE LU : IBUF(IBRN2) C WHITCH IS BETWEEN IBUF(IBRN1),IBUF(IBRN3) C C DIMENSION IBUF(1),NUMB(3) C LUER=2H99 LUTST=IBUF(IBRN1) DO 20 I=1,IBUF(IBRN3)-IBUF(IBRN1)+1 IF(IBUF(IBRN2).NE.LUTST) GOTO 10 CALL CNUMD(LUTST,NUMB) LUER=NUMB(3) RETURN 10 LUTST=LUTST+1 20 CONTINUE RETURN END LOGICAL FUNCTION TMPRS(IOFST,LENGH,ISUPT,IEND .,IFILD),92903-16404 REV.1805 780517 C C C ***************************************************************** C * * C * THIS LOGICAL FUNCTION PROCESS SCREEN # 3. THIS FUNCTION * C * WORKS ON THE UNPACKED FORM OF NCRTH. * C * -------- * C * * C * IF( TMPRS(IOFST,LENGH,IUPT,IEND,IFILD) ) GOTO ERROR * C * * C * IOFST - OFSET IN BYTE INTO NCRTH (USED BY 'MOVCX' * C * TO DISPLAY THE SCREEN.) * C * IF = 0 ---> INIT LOCAL VARIABLE & RETURN * C * LENGH - LENGH OF THE INPUT (T LOG) * C * IUPTN - FIRST U.P.T. TO BE DISPLAYED. * C * IEND - RETURN PARAMETERS (END INDICATOR OR ERROR * C * NUMBER.) * C * IFILD - FIELD ERROR ON THE SCREEN OF THE ERROR * C * * C * IF IOFST IS NOT 0, THE CURRENT SCREEN IS ANALYSED, AND TMPRS * C * RETURN THE NEXT STEP TO EXECUTE USING IEND & IFILD * C * * C * IF A SCREEN IS NOT FULL AND NO ERROR IS FOUND, IT IS CONSI- * C * DERED THE LAST FOR THAT U.P.T. AND TMPRS SWITCH TO THE NEXT * C * U.P.T. * C * IF A SCREEN IS FULL AND NO ERROR IS FOUND, TMPRS GENERATES * C * AN EXTENSION FOR THAT U.P.T. AND CONTINUE. * C * IF A SCREEN IS EMPTY, TMPRS RETURN THE END INDICATOR = 1 TO * C * INDICATE END OF U.P.T. DEFINITION PROCESSING. * C * * C ***************************************************************** C C C VALUE RETURNED BY IEND C C - END INDICATOR: 0 - CONTINUE CURRENT PROCESS (DISPLAY C THE SCREEN) C 1 - END OF CURRENT PROCESS C 2 - ABORT THE PROGRAM C 3 - GO TO PREVIOUS SCREEN C C - ERROR VALUE: 13 - PARTITION REQUIREMENT TOO BIG C 14 - ILLEGAL PARTITION NUMBER C 15 - DUPLICATE T.U.S. C 16 - NO T.U.S. DEFINED AT ALL C 17 - TOO MANY T.U.S., LIBRARY OR U.P.T. C 18 - ILLEGAL NAME FOR T.U.S. OR LIBRARY C 19 - SWAPPING OPTION ANSWER MUST BE 'X' C 20 - NO LIBRARY ALLOWED IF NO T.U.S. DEFINED C 34 - ILLEGAL CHARACTER C C COMMON LU,LUPRT,NCRTH(2100),IEXFL,IPTR,NBSCR,IFSCR,ILAST COMMON IFLG(29),IPRVS(29),IBUFR(62),ITEMP(3),ITOSC COMMON IXXXXX(171) COMMON IRLOC(90) C LOGICAL JPAR,KPAR,IMBED,DUPNA,CMPB,OKABT,FSCRN,ISSPA LOGICAL PSFLG,INSFLG,IEXFL C C C ILAST - POINT ON THE LAST SCREEN OF THE LAST PROGRAM, C WHICH IS NOT ALWAYS THE LAST PHYSICAL BUFFER IN C NCRTH. C KPAR(IP1,IP2)=JPAR(IRLOC,LENGH,I,ITEMP,IP1,IFLG(I),IP2) FSCRN(IP3)=IAND(NCRTH(IPTR+1),77600B).NE.256 .AND. . IAND(NCRTH(IPTR+1),77600B).NE.0 C TMPRS=.FALSE. INTMS=62 ILPRG=118 ILGMX=1607 IREFC=50 ILUGH=128 ISTAR=((IREFC+2*ILUGH)*2)-2 IEXFL=.FALSE. IF(IOFST.NE.0) GOTO 20 C C FIRST TIME TMPRS IS CALLED C IEND=0 NBSCR=1 IFSCR=1 ILAST=NCRTH+1-INTMS IOFST=ISTAR IPTR=(ISTAR+2)/2 ITOSC=1+(ILAST-IPTR)/INTMS C-----SEARCH THE RIGHT UPT # 13 I=IAND(NCRTH(IPTR+2),177B) IF(I .GE. ISUPT) GOTO 148 C-----SEARCH THE FIRST SCREEN OF THE RIGHT UPT IN THE CHAIN 15 J=IAND(NCRTH(IPTR+1),100000B) NBSCR=NBSCR+1 IFSCR=IFSCR+1 IF(NCRTH(IPTR) .EQ. NCRTH+1) GOTO 165 IPTR=NCRTH(IPTR) IOFST=(2*IPTR)-2 IF(J .EQ. 0) GOTO 15 GOTO 13 C C PROCESS A SCREEN # 3 (DEFINITION OF T.U.S.) C 20 CALL NUL(IBUFR,INTMS) PSFLG=.FALSE. INSFLG=.FALSE. IEND=0 C C T.U.S. / LIBRARY ACQUISITION C NUERO=18 J=5 K=7 DO 30 I=1,23 IF(I .EQ. 21) J=6 CALL BLANC(ITEMP,3) IF( KPAR(J,IJK) ) GOTO 200 IF(IFLG(I).NE.0 .AND. IFLG(I).NE.3) GOTO 400 IF( IMBED(ITEMP,1,J) ) GOTO 400 CALL ISUPB(ITEMP,3) CALL MOVCA(ITEMP,1,IBUFR,K,J) 28 K=K+J 30 CONTINUE C C PARTITION SIZE ACQUISITION (ONLY IF LENGH IS OK) C I=24 IF( KPAR(2,IBUFR(2)) ) GOTO 198 NUERO=13 IF(IFLG(I).NE.0 .AND. IFLG(I).NE.1) GOTO 400 IF(IBUFR(2) .GE. 30) GOTO 400 C C PARTITION NUMBER ACQUISITION (ONLY IF LENGH IS OK) C 40 I=25 IF( KPAR(2,IBUFR(3)) ) GOTO 198 NUERO=14 IF(IFLG(I).NE.0 .AND. IFLG(I).NE.1) GOTO 400 IF(IBUFR(3) .GT. 63) GOTO 400 IBUFR(3)=(256*IBUFR(3)) C C SWAPPING BIT (ONLY IF LENGH IS OK) C 50 I=26 ITEMP=2H IF( KPAR(1,IJK) ) GOTO 198 NUERO=19 IF(IFLG(I).NE.0 .AND. IFLG(I).NE.3) GOTO` 400 IF(ITEMP.EQ.2HX ) IBUFR(3)=IOR(IBUFR(3),100000B) C-----THE ENTIRE SCREEN HAS BEEN CHECK, FUNCTION ? 80 IF( INSFLG ) GOTO 380 IF( PSFLG ) GOTO 135 C C NO SPECIAL FUNCTION, EMPTY SCREEN ? C DO 110 I=1,23 IF(IFLG(I).NE.0) GOTO 130 110 CONTINUE C C YES, IT IS AN EMPTY SCREEN, IT IS THE END OF T.U.S. DEFINITION C IF(NCRTH(IPTR) .NE. NCRTH+1) GOTO 132 C-----IF AN EXTENSION SCREEN, GO GET A NEW UPT IF( FSCRN(I) ) GOTO 165 NUERO=16 IF(IOFST .EQ. ISTAR) GOTO 398 CALL NUL(NCRTH(IPTR),INTMS) NCRTH=NCRTH-INTMS IEND=1 GOTO 149 C C SET UP TO GO TO A NEXT SCREEN (EXTENSION OR NEW UPT) C (SUPPRESS BLANK FIELD IN THAT SCREEN) C 130 CALL CTRAC(IBUFR,K) C-----NO LIBRARY ALLOWED IF NO T.U.S. DEFINED NUERO=20 IF(IGET2(IBUFR,7).EQ.2H .AND. ISSPA(IBUFR,107,18) ) GOTO 398 C-----STORE DATA BACK INTO NCRTH 132 CALL MOVEW(IBUFR(4),NCRTH(IPTR+3),INTMS-3) C-----CHECK FOR DUPLICATE T.U.S. NUERO=15 IF( .NOT. DUPNA(IPTR,I) ) GOTO 400 C-----KEEP TRACK OF WHERE THE DATA ARE SAVED FOR "PREVIOUS SCREEN" KEY IPRVS(NBSCR)=IOFST IF(NBSCR .LT. 26) NBSCR=NBSCR+1 C C FIRST SCREEN FOR A UPT ? C 135 IF( FSCRN(I) ) GOTO 140 C-----YES, 1ST SCREEN, SET UP PARTITION SIZE AND PARTITION NUMBER NCRTH(IPTR+1)=IBUFR(2)+IAND(NCRTH(IPTR+1),177600B) NCRTH(IPTR+2)=IBUFR(3)+IAND(NCRTH(IPTR+2),177B) C C PREVIOUS SCREEN REQUESTED ? C 140 IF( PSFLG ) GOTO 350 C-----NO PREVIOUS SCREEN, LAST SCREEN OF A UPT ? IF(IAND(NCRTH(IPTR+1),100000B).NE.0) GOTO 150 C C SET UP FOR NEXT SCREEN, ADVANCE POINTER ON THE CHAIN C TO SET OFSET AND POINTER FOR NEXT TIME C 145 IOFST=(2*NCRTH(IPTR))-2 147 IPTR=(IOFST+2)/2 148 IEXFL=FSCRN(I) 149 CONTINUE C##################################################################### D KKK=NCRTH(4) D KKL=NCRTH+1 D KKM=2H1S D IF(FSCRN(I)) KKM=2HEX D ! WRITE(6,8987)KKL,ILAST,KKM,KKK,IPTR D8987 FORMAT(2/," TMPRS PRINT-OUT: NCRTH+1 ="I5", ILAST ="I5 D .", IT IS A "A2"T SCREEN,",/,19X, D ."ARRAY FROM",I5"(10) TO"I5"(10) IS:") D DO 8984 KKL=KKK,IPTR,62 D KKM=IAND(NCRTH(KKL+2),177B) D KKN=2HLS D IF(IAND(NCRTH(KKL+1),100000B).EQ.0) KKN=2HEX D WRITE(6,8988)KKN,KKM,KKL,(NCRTH(I),I=KKL,KKL+61) D8988 FORMAT(X,A2"T OF UPT #"I3,3X, D ." ADDR ="I5,": VAL ="I5,2@10,/" ["30A2,/" ",29A2"]") D8984 CONTINUE C##################################################################### RETURN C C IT IS THE LAST SCREEN OF A UPT, SCREEN FULL ? C 150 IF(IGET2(IBUFR,102).NE.2H .OR.IGET2(IBUFR,119).NE.2H ) .GOTO 170 C-----IT IS THE LAST SCREEN OF A UPT, END OF CHAIN ? IF(NCRTH(IPTR).NE.NCRTH+1) GOTO 145 C C IT IS THE END OF THE CHAIN, START A NEW PROGRAM IF ENOUGH ROOM C 165 IF(ITOSC .LT. 26) GOTO 190 167 NUERO=17 GOTO 398 C C THIS SCREEN IS FULL, TRY TO DO AN EXTENSION C 170 IF(ITOSC .GE. 25) GOTO 167 C-----SET UP THE EXTENSION SCREEN IF(IPTR.NE.ILAST) GOTO 183 C-----THE EXTENSION IS ON THE LAST UPT ILAST=NCRTH+1 NCRTH(NCRTH+1)=NCRTH+1+INTMS GOTO 184 C-----THE EXTENSION IS IN THE MIDDLE, SET UP TWO LINK 183 NCRTH(ILAST)=NCRTH(ILAST)+INTMS NCRTH(NCRTH+1)=NCRTH(IPTR) 184 NCRTH(IPTR)=NCRTH+1 NCRTH(IPTR+1)=IAND(NCRTH(IPTR+1),77777B) IF(IAND(NCRTH(IPTR+1),77600B).EQ.0) NCRTH(IPTR+1)= .NCRTH(IPTR+1)+256 NCRTH(NCRTH+2)=IOR(NCRTH(IPTR+1)+256,100000B) NCRTH(NCRTH+3)=NCRTH(IPTR+2) GOTO 195 C C SET UP FOR A NEW U.P.T. C 190 ILAST=NCRTH+1 NCRTH(NCRTH+1)=NCRTH+1+INTMS NCRTH(NCRTH+2)=100000B NCRTH(NCRTH+3)=IAND(NCRTH(IPTR+2),177B)+1 195 CALL BLAN(NCRTH,2*(NCRTH+1)+5,ILPRG) NCRTH=NCRTH+INTMS ITOSC=ITOSC+1 GOTO 145 C C SPECIAL CASE: END OF BUFFER, INSERT, PREVIOUS OR ABORT ? C 198 IF(IFLG(I) .EQ. 6) GOTO 80 C-----SPECIAL CHARACTER, CHECK IT 200 IF(IFLG(I).NE.9) GOTO 205 IF(.NOT.OKABT(LU)) RETURN C-----OPERATOR ASK TO ABORT, DO THE ABORT RETURN ! IEND=2 RETURN C C INSERT OR PREVIOUS ? C 205 IF(IFLG(I).EQ.8) GOTO 300 C-----INSERT FUNCTION ? NUERO=34 IF(IFLG(I).NE.4) GOTO 400 IF(I .GE. 21) GOTO 400 IF(.NOT. INSFLG) INSFLD=I INSFLG=.TRUE. GOTO 310 C 300 IF(.NOT. PSFLG) IFILD=I PSFLG=.TRUE. 310 IF(I.GT.23) GOTO 325 CALL MOVCA(NCRTH,IOFST+K,IBUFR,K,J) GOTO 28 325 IF(I.NE.24) GOTO 330 IBUFR(2)=NCRTH(IPTR+1) GOTO 40 330 IBUFR(3)=NCRTH(IPTR+2) IF(I.EQ.25) GOTO 50 GOTO 80 C C EXECUTE THE PREVIOUS SCREEN FUNCTION C 350 IF(NBSCR .EQ. IFSCR) GOTO 360 NBSCR=NBSCR-1 CALL MOVEW(IBUFR(4),NCRTH(IPTR+3),INTMS-3) IOFST=IPRVS(NBSCR) GOTO 147 360 IEND=3 RETURN C C EXECUTE THE INSERT A T.U.S. FUNCTION C 380 CALL CTRAC(IBUFR,INSFLD) I=INSFLD NUERO=34 IF(IGET2(IBUFR,102).NE.2H ) GOTO 400 IF(INSFLD.EQ.20) GOTO 400 KK=97 DO 385 IJ=INSFLD,19 CALL MOVCA(IBUFR,KK,ITEMP,1,5) CALL MOVCA(ITEMP,1,IBUFR,KK+5,5) CALL BLAN(IBUFR,KK,5) 385 KK=KK-5 CALL MOVEW(IBUFR(4),NCRTH(IPTR+3),INTMS-3) RETURN C C ERROR PROCESSING C 398 I=1 400 IFILD=I IEND=NUERO TMPRS=.TRUE. GOTO 148 END LOGICAL FUNCTION DUPNA(IPTR,IIII),92903-16404 REV.1805 780109 C C FUNCTION TO FIND DUPLICATE TMS-SUBROUTINE NAME C C FUNCTION IS TRUE IF ALL THE 20 TMS-SUBROUTINE NAME C (STARTING AT ADDR=IPTR) ARE ALL UNIQUE. C FUNCTION IS FALSE IF THERE IS DUPLICATE NAME C (III IS THE ADDR OF THE DUPLICATE ONE, THE SECOND ONE) C C C THIS SUBROUTINE WORKS ON THE UNPACKED FORMAT OF NCRTH C ---------- C C COMMON LU,LUPRT,NCRTH(2400) LOGICAL CMPBB@< C INTMS=62 C DUPNA=.TRUE. IIII=1 DO 40 K=(2*(IPTR+3))-1,(2*(IPTR+3))-1+95,5 I=NCRTH(4) 10 DO 20 J=(2*(I+3))-1,(2*(I+3))-1+95,5 IF(IGET2(NCRTH,K).EQ.2H ) GOTO 35 IF(IGET2(NCRTH,J).EQ.2H ) GOTO 20 IF(J.EQ.K) GOTO 35 IF(CMPB(NCRTH,J,NCRTH,K,5)) GOTO 50 20 CONTINUE 30 I=NCRTH(I) IF(I.EQ.IPTR+INTMS) GOTO 35 GOTO 10 35 IIII=IIII+1 40 CONTINUE GOTO 60 50 DUPNA=.FALSE. 60 RETURN END SUBROUTINE CTRAC(IBUFR,KKKK),92903-16404 REV.1805 770802 C C C THIS SUBROUTINE CONTRACTS THE TMS-SUBROUTINES C INSIDE A SCREEN (ELIMINATING EMPTY FIELDS). C C THE FIELD NUMBER IN KKKK IS UPDATED TO REFLECT THE CHANGE. C C DIMENSION IBUFR(62) C KK=7 IFILD=1 DO 200 II=1,19 IF(IGET2(IBUFR,KK).NE.2H ) GOTO 100 CALL MOVCA(IBUFR,KK+5,IBUFR,KK,95-(KK-7)) IF(IFILD.LT.KKKK) KKKK=KKKK-1 CALL BLAN(IBUFR,102,5) KK=KK-5 100 KK=KK+5 IFILD=IFILD+1 200 CONTINUE KK=107 DO 400 II=1,2 IF(IGET2(IBUFR,KK).NE.2H ) GOTO 300 CALL MOVCA(IBUFR,KK+6,IBUFR,KK,12-(KK-107)) CALL BLAN(IBUFR,119,6) KK=KK-6 300 KK=KK+6 400 CONTINUE RETURN END END$ B  92903-18405 1805 S C0122 &TMGLO              H0101 FTN4 C C C NAME: DEPAK,REPAK,CLSLU,ISPRZ,ITRIC,NBUPT C SOURCE: &TMGL0 92903-18405 C BINARY: %TMGL0 92903-16405 PART OF RTMGL1 C C C C ************************************************************** C * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * C ************************************************************** C C C PGMR: DANIEL POT HPG C C SUBROUTINE DEPAK,92903-16405 REV.1805 780109 C C C ************************************************** C * THIS SUBROUTINE READS ON DISC "&XXXX" TYPE 31 * C * FILE AND STORES IT IN NCRTH(2400) TABLE. THEN * C * IT DEPACKS IT BY EXTENDING INTERACTIVE AND AU- * C * XILIARY LU UP TO 64 AND GENERATING PARTITIONS * C * INCLUDING 20 TMS-SUBROUTINES AND 3 LIBRARIES * C * EACH OF THEM. ( EXTENSIONS WILL BE GENERATED). * C ************************************************** C C C C FORMAT OF THE DEPACKED PARTITIONS HEADER C C ************************************************ C * N E X T P A R T I T I O N A D R E S S * C ************************************************ C * BIT EQT.* EXTENSION# * PARTITION SIZE * C ************************************************ C * BIT SWP.* PARTITION # * PROGRAM NUMBER * C ************************************************ C COMMON LU,LUPRT,NCRTH(2490) C C OFFSET CONSTANTS C IREFC=50 IOFST=2400-NCRTH ILUGH=128 INTMS=62 ILPRG=118 ILGMX=1917 C C TRANSLATION INSIDE NCRTH TABLE C CALL MOVEW(NCRTH,NCRTH(IOFST+1),-NCRTH) NCRTH(1+IOFST)=NCRTH(1+IOFST)+IOFST DO 10 I=2,4 NCRTH(I+IOFST)=NCRTH(I)+IOFST 10 CONTINUE J=NCRTH(4+IOFS_T) 20 IF(J.EQ.(NCRTH(1+IOFST)+1)) GOTO 30 NCRTH(J)=NCRTH(J)+IOFST J=NCRTH(J) GOTO 20 C C INTERACTIVE LU# AND TYPES DILATATION C 30 INBLU=NCRTH(3)-NCRTH(2) INDLU=NCRTH(3) CALL NUL(NCRTH(INDLU),(2*ILUGH)-INBLU) C C AUXILIARY LU# AND TYPES DILATATION C INBLU=NCRTH(4)-NCRTH(3) INDLU=IREFC+ILUGH INSLU=NCRTH(3)+IOFST CALL MOVEW(NCRTH(INSLU),NCRTH(INDLU),INBLU) C C NEW HEADER ADRESSES C NCRTH=ILGMX NCRTH(2)=IREFC NCRTH(3)=NCRTH(2)+ILUGH NCRTH(4)=NCRTH(3)+ILUGH C C PARAMETERS INITIALISATION C MM=0 J=NCRTH(4+IOFST) NCRTH(2486)=NCRTH(1+IOFST)+1 JJ=NCRTH(4) KK=JJ+INTMS 40 IF(J.EQ.NCRTH(2486)) GOTO 300 K=NCRTH(J) L=J+3 MM=MM+1 NCRTH(2487)=NCRTH(J+1) NCRTH(2488)=NCRTH(J+2) C C CALCULATES NUMBER OF TMS AND LIBRARIES C INBTS=(K-J-3)/3 INBLB=0 DO 60 NL=J+3,K-3,3 IF(IAND(NCRTH(NL),100000B).NE.0) GOTO 70 60 CONTINUE GOTO 75 70 INBTS=(NL-J-3)/3 INBLB=(K-NL)/3 75 IF(INBLB/3.GE.INBTS/20) INBXT=INBLB/3 IF(INBLB/3.LT.INBTS/20) INBXT=INBTS/20 C C PROGRAMS AND LIBRARIES GENERATION C IX=INBXT 150 LL=(2*(JJ+3))-1 CALL BLAN(NCRTH,LL,ILPRG) DO 80 IT=L,L+57,3 IF(INBTS.EQ.0) GOTO 85 CALL MOVCA(NCRTH,((2*IT)-1),NCRTH,LL,5) INBTS=INBTS-1 LL=LL+5 80 CONTINUE L=L+60 85 NN=KK-9 DO 90 IL=NL,NL+6,3 IF(INBLB.EQ.0) GOTO 95 CALL MOVEW(NCRTH(IL),NCRTH(NN),3) NCRTH(NN)=IAND(NCRTH(NN),77777B) INBLB=INBLB-1 NN=NN+3 90 CONTINUE NL=NL+9 95 ISWP=0 IF(IAND(NCRTH(2488),100000B).NE.0) ISWP=1 NCRTH(2488)=IAND(NCRTH(2488),77777B) NCRTH(JJ+2)=(256*NCRTH(2488))+MM IF(ISWP.EQ.1) NCRTH(JJ+2)=IOR(NCRTH(JJ+2),100000B) IF(INBXT.EQ.0) INBXT=IX-1 NCRTH(JJ+1)=(256*(INBXT-IX+1))+NCRTH(2487) NCRTH(JJ)=KK JJ=KK KK=KK+INTMS IF(KK.GE.IT-3) STOP 7000 IF(JJ.EQ.NCRTH+1) STOP 7001 IX=IX-1 IF(IX.NE.-1) GOTO 150 NCRTH(JJ-INTMS+1)=IOR(NCRTH(JJ-INTMS+1),100000B) C C CONTINUED C J=K GOTO 40 300 NCRTH=JJ-1 RETURN END SUBROUTINE REPAK,92903-16405 REV.1805 780516 C C C C *********************************************** C * THIS SUBROUTINE REPAKS THE NCRTH TABLE PRE- * C * VIOUSLY DEPACKED BY DEPAK SUBROUTINE AND * C * MODIFIED BY THE INTERACTIVE PROCESS, IN OR- * C * TO RE-BUILD THE "&XXXX" FILE FORMAT. * C *********************************************** C C C COMMON LU,LUPRT,NCRTH(2490) DIMENSION IBUFR(72) C IREFC=50 ILUGH=128 KREFC=IREFC+2*ILUGH INTMS=62 ILPRG=118 ILGMX=1917 C C LU AREA C C##################################################################### C C PRINT-OUT TUS AREA ! C D KKK=NCRTH(4) D KKN=NCRTH+1 D WRITE(6,8971)KKN D8971 FORMAT(2/," REPACK PRINT-OUT: NCRTH+1 ="I5) D KKL=KKK D8973 WRITE(6,8974)KKL,NCRTH(KKL) D8974 FORMAT(20X"ADDR:"I5" CONTENT:"I5) D KKL=NCRTH(KKL) D IF(KKL .NE. 0) GOTO 8973 D DO 8978 KKL=KKK,KKN,62 D KKO=IAND(NCRTH(KKL+2),177B) D KKM=2HLS D IF(IAND(NCRTH(KKL+1),100000B).EQ.0) KKM=2HEX D WRITE(6,8976)KKM,KKO,KKL,(NCRTH(II),II=KKL,KKL+61) D8976 FORMAT(10X,A2"T OF UPT #"I3,3X, D ." ADDR ="I5,": VAL ="I5,2@10,/,10X," ["30A2,/,10X," ",29A2"]") D8978 CONTINUE C##################################################################### CALL ISPRZ(NCRTH(IREFC),ILUGH,NLE) NCRTH(3)=IREFC+NLE CALL ITRIC(NCRTH(IREFC),ILUGH,2) CALL CLSLU(NCRTH(IREFC),ILUGH) CALL ISPRZ(NCRTH(IREFC+ILUGH),ILUGH,NLE) CALL ITRIC(NCRTH(IREFC+ILUGH),ILUGH,2) CALL CLSLU(NCRTH(IREFC+ILUGH),ILUGH) CALL MOVEW(NCRTH(IREFC+ILUGH),NCRTH(NCRTH(3)),NLE) NCRTH(4)=NCRTH(3)+NLE C C PROGRAM EXTENSIONS GROUPING AND CLASSING C 11 DO 14 I=KREFC+2,ILGMX-(2*INTMS)+2,INTMS IPRGA=(IAND(NCRTH(I),177B)) IPRGB=(IAND(NCRTH(I+INTMS),177B)) IF(IPRGA.EQ.0 .AND. IPRGB.EQ.0) GOTO 15 IF(IPRGA.EQ.0) GOTO 12 IF(IPRGA.LE.IPRGB) GOTO 14 IF(IPRGB.EQ.0) GOTO 14 12 CALL MOVEW(NCRTH(I-2),IBUFR,INTMS) CALL MOVEW(NCRTH(I-2+INTMS),NCRTH(I-2),INTMS) CALL MOVEW(IBUFR,NCRTH(I-2+INTMS),INTMS) GOTO 11 14 CONTINUE C C TRANSFER TMS & LIBRARY AT THE NCRTH BOTTOM C 15 CONTINUE C##################################################################### C C RE-PRINT-OUT TUS AREA ! C D KKN=NCRTH+1 D WRITE(6,8981)KKN D8981 FORMAT(2/," REPACK PRINT-OUT: (AFTER SORTING) NCRTH+1 ="I5) D KKL=KKK D8983 WRITE(6,8984)KKL,NCRTH(KKL) D8984 FORMAT(20X"ADDR:"I5" CONTENT:"I5) D KKL=NCRTH(KKL) D IF(KKL .NE. 0) GOTO 8983 D DO 8988 KKL=KKK,KKN,62 D KKO=IAND(NCRTH(KKL+2),177B) D KKM=2HLS D IF(IAND(NCRTH(KKL+1),100000B).EQ.0) KKM=2HEX D WRITE(6,8976)KKM,KKO,KKL,(NCRTH(II),II=KKL,KKL+61) D8988 CONTINUE C##################################################################### CALL MOVEW(NCRTH(KREFC),NCRTH(KREFC+260),-1613) NCRTH=NCRTH+260 C C RESTORE NCRTH LINK C DO 18 I=KREFC+260,NCRTH+1-INTMS,INTMS NCRTH(I)=I+INTMS 18 CONTINUE C C PROGRAMS C J=KREFC+260 JJ=NCRTH(4) 20 LL=JJ L=J IEXTN=0 IF(J.EQ.NCRTH+1) GOTO 100 IF(IAND(NCRTH(J+1),77600B).NE.0) IEXTN=1 C C SAVE LIBRARIES & HEADERS OF CURRENT PROGRAM C CALL BLAN(NCRTH,4359,600) I=2180 LLLL=L 200 CALL MOVEW(NCRTH(LLLL),NCRTH(I),3) I=I+3 LLLL=LLLL+INTMS-9 CALL MOVEW(NCRTH(LLLL),NCRTH(I),9) K=LLLL+9 IF(IAND(NCRTH(LLLL-INTMS+10),100000B).NE.0) GOTO 25 LLLL=LLLL+9 I=I+9 IF(I.GE.2475) STOPGx 7002 GOTO 200 C C TMS-SUBROUTINES C 25 DO 30 I=(2*(J+3))-1,(2*(J+3))-1+96,5 IF(IGET1(NCRTH,I).NE.1H ) GOTO 27 IF(IEXTN.NE.1) GOTO 40 GOTO 31 27 CALL MOVCA(NCRTH,I,NCRTH,(2*(JJ+3))-1,5) CALL PUTCA(NCRTH,1H ,(2*(JJ+3))+4) JJ=JJ+3 IF(JJ+3.GE.((I+1)/2)-3) STOP 7003 30 CONTINUE 31 IF(IAND(NCRTH(J+1),100000B).NE.0) GOTO 40 J=NCRTH(J) IF(J.EQ.NCRTH+1) GOTO 40 GOTO 25 C C LIBRARIES C 40 J=2180 L=J 45 DO 50 I=J+3,J+3+6,3 IF(NCRTH(I).NE.2H ) GOTO 70 IF(IEXTN.NE.1) GOTO 60 GOTO 51 70 CALL MOVEW(NCRTH(I),NCRTH(JJ+3),3) NCRTH(JJ+3)=IOR(NCRTH(JJ+3),100000B) JJ=JJ+3 IF(JJ+3.GE.K) STOP 7004 50 CONTINUE 51 IF(IAND(NCRTH(J+1),100000B).NE.0) GOTO 60 IF(NCRTH(J).EQ.NCRTH+1) GOTO 60 J=J+12 GOTO 45 C C PROCESS HEADER AND THEN GO TO NEXT PROGRAM C 60 JJ=JJ+3 IF(JJ+3.GE.K) STOP 7005 NCRTH(LL)=JJ NCRTH(LL+1)=IAND(NCRTH(J+1),177B) C C SWAPPING BIT C ISWP=0 IF(IAND(NCRTH(L+2),100000B).NE.0) ISWP=1 NCRTH(LL+2)=(IAND(NCRTH(L+2),77600B))/256 IF(ISWP.EQ.1) NCRTH(LL+2)=IOR(NCRTH(LL+2),100000B) J=K C C IS IT A TRUE PROGRAM ? C IF(JJ.NE.LL+3) GOTO 700 JJ=JJ-3 700 IF(J.NE.NCRTH+1) GOTO 20 100 NCRTH=JJ-1 C RETURN END SUBROUTINE CLSLU(IBUF,LEN),92903-16405 REV.1805 780109 C C C C ******************************************** C * THIS SUBROUTINE LOOKS FOR LU# OF THE SA- * C * ME TYPE IN AN ALREADY ORDERED AREA, THEN * C * CLASS THEM IN AN INCREASING ORDER. * C * * C * CALL CLSLU(P1,P2) * C * * C * P1 = NAME(I) OF THE AREA TO PROCESS * C * I POINTS AT THE FIRST LU# * C * P2 = LENGTH OF THIS AREA * C h ******************************************** C C C COMMON LU,LUPRT,NCRTH(2400) DIMENSION IBUF(1) C C J=1 DO 10 I=2,LEN-2,2 IF(IBUF(I).EQ.IBUF(I+2)) GOTO 10 IF(I-J.GE.3) GOTO 20 J=I+1 GOTO 10 20 CALL ITRIC(IBUF(J),I-J+1,1) J=I+1 10 CONTINUE RETURN END SUBROUTINE ISPRZ(IBUF,LEN,NLE),92903-16405 REV.1805 780109 C C C ******************************************* C * THIS SUBROUTINE ELIMINATES ALL THE LU# * C * WHICH ARE EQUAL TO "00" IN THE PRECISED * C * AREA. * C * * C * CALL ISPRZ(P1,P2,P3) * C * * C * P1 = NAME(I) OF THE AREA TO PROCESS * C * I POINTS AT THE THE FIRST LU# * C * P2 = WORD LENGTH OF THE AREA * C * P3 = WORD LENGTH AFTER COMPRESSION * C ******************************************* C C C COMMON LU,LUPRT,NCRTH(2400) DIMENSION IBUF(1) C C NLE=LEN K=0 I=1 10 IF(IBUF(I).EQ.0) GOTO 40 20 I=I+2 IF(I.LE.NLE-1) GOTO 10 30 DO 35 L=NLE+1,NLE+K IBUF(L)=32767 35 CONTINUE RETURN 40 J=I KK=0 50 KK=KK+2 J=J+2 IF(J.GT.NLE-1) GOTO 60 IF(IBUF(J).EQ.0) GOTO 50 CALL MOVEW(IBUF(J),IBUF(I),NLE-J+1) 60 NLE=NLE-KK K=K+KK GOTO 20 END SUBROUTINE ITRIC(IBUF,LEN,IORG),92903-16405 REV.1805 780109 C C C C *********************************************** C * THIS SUBROUTINE CLASS IN AN INCREASING OR- * C * DER THE LU-TYPE NCRTH AREA. * C * * C * CALL ITRIC(P1,P2,P3) * C * * C * P1 = NAME(I) OF THE AREA TO PROCESS * C * 5*($ I POINTS AT THE FIRST LU# * C * P2 = LENGTH OF THE AREA TO BE ORDERED * C * P3 = FUNCTION: 1 ORDERS LU# * C * 2 ORDERS TYPE * C *********************************************** C C C COMMON LU,LUPRT,NCRTH(2400) DIMENSION IBUF(1) C C C DO 20 I=IORG,LEN+IORG-4,2 10 IF(IBUF(I).LE.IBUF(I+2)) GOTO 20 ITLU=IBUF(I-IORG+1) ITYP=IBUF(I-IORG+2) IBUF(I-IORG+1)=IBUF(I-IORG+3) IBUF(I-IORG+2)=IBUF(I-IORG+4) IBUF(I-IORG+3)=ITLU IBUF(I-IORG+4)=ITYP IF(I.EQ.IORG) GOTO 20 I=I-2 GOTO 10 20 CONTINUE RETURN END FUNCTION NBUPT(NCRTH),92903-16405 REV.1805 780104 C C ************************************************* C * THIS FUNCTION RETURN THE NUMBER OF USER * C * PARTITION ENTERING IN AN APPLICATION. * C ************************************************* C C NOTE: THIS SUBROUTINE WORKS ON THE PACKED FORMAT OF NCRTH C ----- ------ C C DIMENSION NCRTH(1) C M=0 J=NCRTH(4) 100 K=NCRTH(J) M=M+1 J=K IF(K .NE. NCRTH+1) GOTO 100 NBUPT=M RETURN END END$ h*   92903-18406 1805 S C0122 &TMGSC              H0101 ASMB HED . TMSGN MODULE ** SEGMENT CALLER ** NAM TMGSC,7 92903-16406 REV.1805 780124 SPC 2 * ************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * ************************************************************** SPC 2 ********************************************************************** * * * NAME: TMGSC SEMENT CALLER * * SOURCE: &TMGSC 92903-18406 * * BINARY: %TMGSC 92903-16406 PART OF RTMGL1 * * * * PGMR: FRANCOIS GAULLIER * * * ********************************************************************** SPC 3 * ************************************************** * * * * * * * * CALL SEGMENT DEFINE BY THE NAME OF THE * * * 4TH FIRST CHARACTERS OF THE MAIN, THE 6TH * * * BEING A NUMBER DEFINED IN THE CALLING * * * SEQUENCE. * * * * * * CALLING SEQUENCE: * * * * * * CALL TMGSC(SEG#,IP1,IP2,IP3,IP4,IP5) * * * * * * WHERE: * * * SEG# - SEGMENT NUMBER TO BE LOADED * * * Y IP1 - FIRST PARAMETERS PASSED TO THE * * * SEGMENT USING A COMMON BUFER * * * INSTEAD OF RMPAR (RTE-M COMP.) * * * IP2 THRU IP5 ARE 2ND TO 5TH PARAMETERS * * * SAME AS THE 1ST PARAM. * * * * * * * * ************************************************** * * * COM LU(2),NCRTH(2400),DUMMY(138) COM PARAM(5) SPC 2 EXT PNAME,EXEC,.ENTR ENT TMGSC * SUP SPC 2 TMGSC NOP ENTRY POINT LDA .D0 SET DEFAULT PARAMETERS ADDR. TO STA N ADDRESS OF VALU 0 STA I STA J STA K STA L STA M LDA TMGSC RECALL ENTRY ADDR STA TMGS. TO USE .ENTR TO RETREIVE PARAMETERS JMP TMGS.+1 * .D0 DEF D0 D0 DEC 0 SPC 2 N NOP SEGMENT NUMBER ADDR I NOP 1 ST PARAM J NOP 2 ND PARAM K NOP 3 RD PARAM L NOP 4 TH PARAM M NOP 5 TH PARAM TMGS. NOP ENTRY POINT JSB .ENTR DEF N * JSB PNAME RETREIVE PROGRAM NAME DEF *+2 DEF NAME * LDA NAME+1 GET 3RD AND 4TH LETTER AND =B177400 MASK OUT 4TH (COPY # IN RTE-IV) IOR =B107 RESTORE 4TH LETTER WITH "G" STA NAME+1 * LDA N,I RECALL SEGMENT NUMBER (DEFAULT IS 0) ADA =B60 CONVERT IT INTO ASCII ALF,ALF PUT IT IN LEFT BYTE IOR =B40 MERGE WITH SPACE STA NAME+2 AND STORE IT AS 5TH-6TH CHAR OF NAME * LDA I,I STORE SEGMENT PARAMETERS INTO STA PARAM THE COMMON BUFFER LDA J,I STA PARAM+1 LDA K,I STA PARAM+2 LDA L,I STA PARAM+3 LDA M,I STA PARAM+4 * JSB EXEC SEGMENT CALL REQUEST DEF *+8 DEF D8 + SEGMENT LOAD DEF NAME SEGMENT NAME DEF I,I 1 ST PARAM DEF J,I 2 ND PARAM DEF K,I 3 RD PARAM DEF L,I 4 TH PARAM DEF M,I 5 TH PARAM SPC 2 D8 DEC 8 NAME BSS 3 END +>  92903-18407 1805 S C0122 &OKABT              H0101 }FTN4 LOGICAL FUNCTION OKABT(LU),92903-16407 REV.1805 770712 C C C C ************************************************************** C * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * C ************************************************************** C C C C NAME: OKABT C SOURCE: &OKABT 92903-18407 C SOURCE: %OKABT 92903-16407 PART OF RTMGLB1 C C PRMG: FRANCOIS GAULLIER HPG C C C C ******************************** C * THIS FUNCTION PRINTS ON LU: * C * " O.K. TO ABORT? .. (Y/N) " * C * * C * FORTRAN CALL: * C * * C * --IF(OKABT(LU)) GOTO "YES" * C * --GOTO "NO" * C ******************************** C C DIMENSION IMESA(29),IBLOK(3) DATA IMESA/15530B,15555B,15446B,2Hk0,2HB ,15510B,15512B,15542B .,15446B,2HdB,2H O,2H.K,2H. ,2HTO,2H A,2HBO,2HRT,2H ?,2H : .,2H ,2H (,2HY/,2HN),20033B,2H&d,40033B,2H&a,2H-8,2HC_/ DATA IBLOK/15446B,2Hk1,2HB / C OKABT=.TRUE. CALL EXEC(2,LU,IMESA,29) CALL REIO(1,LU+500B,IBUF,-1) C-----RESTORE BLOCK MODE CALL EXEC(2,LU,IBLOK,3) IF(IGET1(IBUF,1).EQ.1HY) RETURN OKABT=.FALSE. RETURN END END$ G  92903-18408 1805 S C0122 &GETBK              H0101 xASMB HED . GET A DATA FROM A 2645/2648 IN BLOCK MODE NAM GETBK,7 92903-16408 REV.1805 780127 SPC 2 * ************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * ************************************************************** SPC 2 ********************************************************************** * * * NAME: GETBK * * SOURCE: &GETBK 92903-18408 * * BINARY: %GETBK 92903-16408 PART OF RTMGL1 * * * * PGMR: FRANCOIS GAULLIER * * * ********************************************************************** SPC 3 * ********************************************************* * * THIS SUBROUTINE RESETS THE 2645 TERMINAL IN CASE OF * * * POWER FAIL OR WRONG MANIPULATION OF OPERATOR AND GET * * * A BLOCK OF DATA FROM 264X TERMINAL. * * ********************************************************* SPC 2 ENT GETBK EXT EXEC,.ENTR SUP SPC 2 UNLK BYT 33,142,137,40 LOCK BYT 33,143 LENH BSS 1 ICLAS BSS 1 CLASS I/O WORD DUMY NOP STATU OCT 000004 STATUS WORD I/0 MASK ABORT OCT 60400 ABORT CHARACTER MASK OCT 177400 DEC1 DEC 1 DEC2 DEC 2 DEC17 DEC 17 DEC21 DEC 21 NEGA2 DEC -2 NEGA3 DEC -3 * * * LU BSS 1 LU # ADDRESS IBUF BSS 1 BUFFER ADDRESS NBYTE BSS 1 LENGRTH ADDRESS GETBK NOP G JSB .ENTR DEF LU * LDA NBYTE,I CMA ASK ONE EXTRA WORD, TO STA LENH CHECK THE LENGTH LATER * *-----UNLOCK THE KEYBOARD * JSB EXEC DEF *+5 DEF DEC2 DEF LU,I DEF UNLK DEF NEGA3 * *-----GET A CLASS I/O WORD * INPUT CLA STA ICLAS SET CLASS WORD TO GET A CLASS # * JSB EXEC DEF *+8 DEF DEC17 DEF LU,I DEF IBUF,I DEF LENH DEF DUMY DEF DUMY DEF ICLAS * *-----IS CLASS I/O # AVAILABLE ? * SZA A CLASS # HAS BEEN PROVIDED JMP INPUT ASK AGAIN FOR A CLASS # * *-----IS INPUT COMPLETED ? * JSB EXEC DEF *+5 DEF DEC21 DEF ICLAS DEF IBUF,I DEF LENH * *-----CHECK FOR TIME OUT * AND STATU SZA JMP EROR * *-----CHECK FOR ABORT * CPB DEC1 JMP ABOR JMP RIGH ABOR LDA IBUF,I AND MASK CPA ABORT JMP RETUR * *-----CHECK RIGHT LENGTH * RIGH CPB NBYTE,I JMP RETUR * *-----ERROR ! * EROR JSB EXEC DEF *+5 DEF DEC2 DEF LU,I DEF ZONE DEF ILG00 * *-----FUNCTION: .TRUE. * CCA JMP GETBK,I * *-----LOCK THE KEYBOARD * RETUR JSB EXEC DEF *+5 DEF DEC2 DEF LU,I DEF LOCK DEF NEGA2 * *-----FUNCTION: .FALSE. * CLA JMP GETBK,I * *-----RESET BUFFER OF THE 2645 TERMINAL * ZONE BYT 33,143 LOCK KEYBOARD BYT 33,155,33,130 UNLOCK MEMORY, FORMAT MODE OFF BYT 33,110,33,112 HOME UP CS. CLEAR DISPLAY * BYT 33,46 ASC 10,s0a0b0c1d0e0f1g1h0j0 BYT 113,00 * BYT 40,33,46,153,61,102 SET BLOCK MODE BYT 33,46,146,61,141,61,153,61,114,11 NEXT FIELD BYT 33,46,146,61,141,62,153,62,114,33,151,40 PREVIOUS FIELD BYT 33,46,146,61,141,63,153,61,114  ,40 NOT USED BYT 33,46,146,62,141,64,153,61,114,141 ABORT BYT 33,46,146,61,141,65,153,64,114,33,110,33,144,40 NEXT SCREEN BYT 33,46,146,61,141,66,153,65,114,163,33,110,33,144 PREV.SCREEN BYT 33,46,146,61,141,67,153,65,114,150,33,110,33,144 HELP BYT 33,46,146,61,141,70,153,65,114,151,33,110,33,144 INSERT * BYT 33,110,33,112 HOME UP CURSOR, CLEAR DISPLAY END00 EQU *-1 STR00 EQU ZONE ILG00 ABS END00-STR00+1 END !  92903-18409 1805 S C0122 &LCKLL              H0101 FTN4 SUBROUTINE LCKLL(LU,LUL,ITIM),92903-16409 REV.1805 780320 C C C C ************************************************************** C * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * C ************************************************************** C C C C NAME: LCKLL C SOURCE: &LCKLL 92903-18409 C SOURCE: %LCKLL 92903-16409 PART OF RTMGL1 C C PRMG: FRANCOIS GAULLIER C C C ***************************************************************** C * * C * THIS SUBROUTINE TRY TO LOCK THE LIST DEVICE LUL, IF * C * IT IS NOT THE SAME LU THAN LU. * C * IF THE DEVICE IS ALREADY LOCK, THE CALLING PROGRAM * C * IS SUSPENDED (PUT IN THE TIME LIST) FOR ITIM SECONDS * C * BEFORE AN OTHER LOCK ATTEMPT IS TRY, AND SO ON UNTIL * C * THE LOCK SUCCED. * C * * C ***************************************************************** C C DIMENSION MES(10) C DATA MES/6412B,2H W,2HAI,2HTI,2HNG,2H F,2HOR,2H L,2HU / C IF (LU .EQ. LUL) RETURN C C-----TRY TO LOCK THE LIST LU C J=0 20 I=LURQ(100001B,LUL,1) IF(I .EQ. 0) RETURN C C-----LOCK HAS FAIL, REPORT "WAITING FOR LU XX" AND C TRY AGAIN IN ITIM MS C IF(J .NE. 0) GOTO 30 MES(10)=IASC(LUL) CALL EXEC(2,LU,MES,10) J=1 C-----WAIT ITIM MS 30 CALL EXEC(12,0,1,0,-ITIM/10) GOTO 20 END s    92903-18410 1805 S C0122 /TMPGN TR FILE TO RP TMPGN             H0101 :SV,3,9,IH :** :** /TMPGN (HP 92903-18410 REV.1805 780601) :** :RP,TMPGN::-2 :RP,TMPG0::-2 :RP,TMPG1::-2 :RP,TMPG2::-2 :RP,TMPG3::-2 :RP,TMPG4::-2 :RP,TMPG5::-2 :SV,9G,,IH c\  92903-18411 1805 S C0122 &TMGL1              H0101 sASMB HED . T M G L 1 H E A D E R NAM TMGL1,0 92903-12401 REV.1805 780602 * * NAME: TMGL1 HEADER OF THE LIBRARY * SOURCE: &TMGL1::4 92903-18411 * BINARY: %TMGL1::4 92903-12401 HEADER OF TMGL1 * * PMGR: FRANCOIS GAULLIER SPC 2 END 2  92903-18412 1805 S C0122 >TMPGN TMPGN LOADR COMMAND FILE             H0101 * * >TMPGN (HP 92903-18412 REV.1805 780601) * RE,%TMPGN SE,%TMGLB SE,%TMGL1 RE,%TMPG0 SE,%TMGLB SE,%TMGL1 RE,%TMPG1 SE,%TMGLB SE,%TMGL1 RE,%TMPG2 SE,%TMGLB SE,%TMGL1 RE,%TMPG3 SE,%TMGLB SE,%TMGL1 RE,%TMPG4 SE,%TMGLB SE,%TMGL1 RE,%TMPG5 SE,%TMGLB SE,%TMGL1 }  92903-18413 1805 S C0122 \TMPGN TR FILE TO OF TMPGN             H0101 %:SV,3,9,IH :** :** \TMPGN (HP 92903-18413 REV.1805 780601) :** :RP,,TMPGN::-2 :RP,,TMPG0::-2 :RP,,TMPG1::-2 :RP,,TMPG2::-2 :RP,,TMPG3::-2 :RP,,TMPG4::-2 :RP,,TMPG5::-2 :SV,9G,,IH   92903-18420 1805 S C0122 &TMPGE              H0101 }ASMB HED . T M P G N ERROR MESSAGES NAM TMPGE,7 92903-16420 REV.1805 780517 SPC 2 * ************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * ************************************************************** SPC 2 ENT TMPGE EXT EXEC,.ENTR,&REMP,&MVW SUP SPC 3 ********************************************************************** * * * NAME: TMPGE TMPGN ERROR MESSAGES MODULE * * SOURCE: &TMPGE 92903-18420 * * BINARY: %TMPGE 92903-16420 PART OF %TMGL1 * * * * PGMR: FRANCOIS GAULLIER * * * ********************************************************************** SPC 3 * ********************************************************** * * THIS SUBROUTINE IS CALLED BY THE SEGMENTS OF " TMPGN " * * * PROGRAM TO WRITE AN ERROR MESSAGE ON THE SCREEN OF THE * * * TERMINAL. THE ERROR MESSAGE IS PRINTED ON LINE 24 OF * * * THE SCREEN AND THE CURSOR IS MOVED TO THE WRONG FIELD. * * * * * * PARAMETERS: P1 = ERROR MESSAGE # TO OUTPUT * * * P2 = WRONG FIELD # ON THE SCREEN * * * P3 = ASCII STRING TO ADD TO TEXT * * ********************************************************** SPC 2 COM ILU TERM. LU SPC 2 * GET CALLING PARAMETERS AND INITIALISE * NM;ESS NOP FIRST PARM. ADDRESS NOF NOP SECD. PARM. ADDRESS LUDU DEF * DEFECTIVE LOGICAL UNIT TMPGE NOP ENTRY POINT JSB .ENTR SUBR. TO GET DEF NMESS PARM. ADDRESS LDA ILU GET TERM LU STA ICNWD STORE IT IN CNWD LDA BUFAD INITIALIZE LDB SPACE ERROR MESSAGE JSB &REMP BUFFER DEC -35 TO BLANK LDA BUFA1 INITIALIZE LDB NULL TAB BUFFER JSB &REMP TO NULL DEC -50 * * MOVE ERROR MESSAGE IN OUTPUT BUFFER * DLD LUDU,I GET DEFECTIVE LU NUMBER STA BELU STORE IT IN THE ERROR MESSAGE STA CELU STORE IT IN THE ERROR MESSAGE STA DELU STORE IT IN THE ERROR MESSAGE DST IMGER STORE IMAGE ERROR # IN ERROR MESSAGE LDA NMESS,I GET ERROR MESSAGE # ADA AMES0 COMPUTE MESSAGE LDB A,I ADDRESS STB P1 STORE IT CMB,INB MINUS STARTING ADDRESS STB IST OF MESSAGE IN IST INA COMPUTE NEXT MESSAGE LDA A,I STARTING ADDRESS ADA IST COMPUTE MESSAGE LENGTH STA P2 STORE IT LDA P1 BUFFER SOURCE ADDRESS LDB BUFAD BUFFER DEST ADDRESS JSB &MVW MOVE WORDS P2 NOP BUFFER LENGTH * * INCLUDE # OF NECESSARY TABS * LDA NOF,I GET WRONG FIELD # CMA,INA MAKE IT NEG. ISZ A INCREMENT: IS FIRST FIELD ? RSS NO JMP WRIT YES OUTPUT BUFFER STA P3 STORE NEG. # OF TABS LDA BUFA1 TAB BUFFER ADDRESS LDB TAB TAB JSB &REMP INCLUDE TABS P3 NOP IN BUFFER * * WRITE MESSAGE * WRIT JSB EXEC WRITE EXEC CALL DEF *+5 RETURN POINT DEF D.2 CODE EXEC DEF ICNWD CONTROL WORD DEF BUF BUFFER LOCATION DEF ILN BUFFER LENGTH * * RETURN TO CALLIRNG PROGRAM * JMP TMPGE,I * * BUFFER DATA * BUF BYT 33,130,33,46,141,62,63,162,61,103 FORMAT OFF:POS.CURSOR BYT 33,46,144,103 INVERSE VIDEO BLINKING ASC 2,ERRO BYT 122,33,46,144,100 END ENHANCEMENT ASC 2, : BUFER BSS 35 MESSAGE BUFFER BYT 33,127,33,110 FORMAT ON * HOME CURSOR BUF1 BSS 50 TAB BUFFER BYT 33,142 KEYBOARD ENABLE EBUF BYT 0,137 SUPPRESS , * * STORAGE , CONSTANTS .. * BUFAD DEF BUFER BUFF. ADDRESS BUFA1 DEF BUF1 TAB BUFFER ADDRESS A EQU 0 A REGISTER STAD EQU BUF BUFFER STARTING ADDRESS LTAD EQU EBUF BUFFER LAST ADDRESS IST NOP ICNWD NOP CONTROL WORD P1 NOP SOURCE ADDRESS BUFFER ADDRESS ILN ABS LTAD-STAD+1 BUFFER LENGTH SPACE BYT 40,40 NULL BYT 0,0 TAB BYT 33,111 D.2 DEC 2 * * MESSAGE ADDRESS * AMES0 DEF AMES1-1 AMES1 DEF MES1 UNCKNOWN MODE OF OPERATION DEF MES2 ILLEGAL NUMBER DEF MES3 ILLEGAL LOGICAL UNIT NUMBER DEF MES4 SPECIFIED TMP COPY DOES NOT EXIST DEF MES5 ILLEGAL CARTRIDGE NUMBER DEF MES6 BAD SECURITY CODE DEF MES7 INVALID TMP COPY NUMBER DEF MES8 DUPLICATE LU NUMBER: DEF MES9 THE LOGGING LU MUST BE A MAG TAPE DEF MES10 "FROM" LU # MUST BE SPECIFIED DEF MES11 UNDEFINED LOGICAL UNIT NUMBER DEF MES12 LU# : XX DOES NOT CORRESPOND TO A HP3070 DEF MES13 PARTITION REQUIREMENT TOO BIG DEF MES14 NON EXISTENT PARTITION NUMBER DEF MES15 DUPLICATE MODULE NAME DEF MES16 INCOMPLETE SCREEN DEF MES17 MEMORY OVERFLOW, NEED ROOM DEF MES18 ILLEGAL NAME DEF MES19 ANSWER X ! DEF MES20 MUST DEFINE 1 TUS/UPT AT LEAST DEF MES21 * DEF MES22 * DEF MES23 * DEF MES24 * DEF MES25 NO BUFFER SPACE FOR IMAGE DEF MES26 DATA] BASE IS LOCKED ! DEF MES27 DATA BASE DOES NOT EXIST ! DEF MES28 NOT THE HIGHEST ACCESS LEVEL WORD ! DEF MES29 WRONG DATA BASE SECURITY CODE DEF MES30 IMAGE ERROR : XXXX DEF MES31 * DEF MES32 * DEF MES33 PREVIOUS SCREEN IS ILLEGAL DEF MES34 BAD CHARACTER, TRY AGAIN DEF MES35 CR NOT MOUNTED OR LOCKED DEF MES36 SPECIFIED TMP COPY DOES NOT ACCESS A DATA BASE DEF MES37 * DEF MES38 SPECIFIED TMP COPY HAS BEEN CORRUPTED ! DEF MES39 INCONSISTENT DATA BASE DEFINITION DEF MES40 UNDEFINED DATA BASE DEF MES41 "TO" LU# MUST BE GREATER THAN "FROM" LU # DEF MES42 * DEF MES43 AT LEAST ONE HP3070 MUST BE SPECIFIED DEF MES44 LU # MUST BE BETWEEN 1 AND XX DEF MES45 *************************************** * * MESSAGE STORAGE * MES1 ASC 13,Unknown mode of operation. MES2 ASC 10,Illegal number ! MES3 ASC 09,Illegal LU number MES4 ASC 17,Specified TMP copy does not exist. MES5 ASC 13,Illegal cartridge number. MES6 ASC 09,Bad security code. MES7 ASC 13,Invalid TMP copy number. MES8 ASC 11,Duplicate LU number: BELU NOP MES9 ASC 24,The logging LU # must be a mag tape device MES10 ASC 15,"FROM" LU # must be specified. MES11 ASC 15,Undefined Logical unit number. MES12 ASC 03,LU #: CELU NOP ASC 17, does not correspond to an HP3070. MES13 ASC 15,Partition requirement too big. MES14 ASC 15,Non existent partition number. MES15 ASC 22,This module is already defined, either as a ASC 11,System or user module. MES16 ASC 09,Incomplete screen. MES17 ASC 20,Too many prog. unit or too many user wri ASC 7,tten modules. MES18 ASC 08,Illegal format ! MES19 ASC 5,Answer X ! MES20 ASC 20,If a library is defined, at least one us ASC 13,er module must be defined. MES21 ASC 1, MES22 ASC 1, MES23 ASC 1, MES24 ASC 1, MES25 ASC 21,Can't use IMA GE, increase TMPGN partition ASC 7, size to 15KW. MES26 ASC 13,The data base is locked ! MES27 ASC 15,The data base does not exist ! MES28 ASC 24,This is not the highest level access word ! MES29 ASC 10,Wrong security code MES30 ASC 7,IMAGE error # IMGER BSS 2 ASC 19,, Please consult image documentation. MES31 ASC 1, MES32 ASC 1, MES33 ASC 19,"Previous Screen" Key is not allowed ! MES34 ASC 13,Bad character, try again. MES35 ASC 23,This Cartridge is not mounted or is locked ! MES36 ASC 24,Specified TMP copy does not access a data base. MES37 ASC 1, MES38 ASC 23,Specified TMP copy has been handled by another ASC 11, program than TMPGN ! MES39 ASC 17,Inconsistent data base definition. MES40 ASC 10,Undefined data base. MES41 ASC 22,"TO" LU # must be greater than "FROM" LU #. MES42 ASC 1, MES43 ASC 22,At least one HP3070 LU # must be specified. MES44 ASC 14,LU # must be between: 1 and DELU NOP MES45 ASC 1,-1 * * * END F   92903-18451 1805 S C0122 &TMPGN              H0101 ~FTN4 PROGRAM TMPGN(3),92903-16451 REV.1805 780530 C C C NAME: TMPGN C SOURCE: &TMPGN 92903-18451 C RELOC: %TMPGN 92903-16451 C C PGMR: DANIEL POT / FRANCOIS GAULLIER HPG C C C ************************************************************** C * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * C ************************************************************** C C C ************************************************************** C * * C * THIS IS THE MAIN PROGRAM OF TMPGN * C * (TRANSACTION MONITOR PROGRAM GENERATOR) * C * * C * THIS PROGRAM HAS 6 SEGMENTS (TMPG0 - TMPG1 - TMPG2 - * C * TMPG3 - TMPG4 - TMPG5) * C * * C ************************************************************** C C C C ************************************************************** C * * C * RU,TMPGN [,LU [,P2 [,P3 [,P4 ]]]] * C * * C * LU - 2645 2648 LOGICAL UNIT * C * P2 - LOADER OPTION: * C * = 0 ---> LBRP * C * = 1 ---> LB * C * = 2 ---> NO CREATION, NO LOADING * C * = 3 ---> NO LOADING * C * P3 - LISTING LU, DEFAULTEE  D TO CRT * C * P4 - SEARCH %TMSLB FLAG: * C * = 0 ---> DO NOT SEARCH FOR %TMSLB * C * = 1 ---> SEARCH FOR %TMSLB * C * * C ************************************************************** C COMMON LU,LUPRT,NCRTH(2400),IRLOC(70),ITRSF(20),IRQFLG(30) COMMON IMOTR(9),IVASC0(9),IPARAM(5) C C SAVE LOGICAL UNIT OF THE CALLING TERMINAL C CALL RMPAR(IPARAM) LU=IPARAM(1) IF(LU.LT.6 .OR. LU.GE.64) LU=1 C-----LOCK THE CRT TERMINAL TO PROTECT THE SCREEN CALL LURQ(1,LU,1) LUPRT=LU IF(IPARAM(3) .NE. 0) LUPRT=IPARAM(3) C-----INIT FLAG DO 10 I=1,30 10 IRQFLG(I)=0 C-----INIT SYSTEM TYPE IMOTR(5)=0 C-----INIT VALUE TO DISPLAY SCREEN#0 IVASC0(1)=0 IVASC0(2)=1 IVASC0(3)=0 C-----SET UP LOADER PARAMETER J=3 K=IPARAM(2) IF(K.EQ.1) J=2 IF(K.EQ.2) J=1 IF(K.EQ.3) J=0 IMOTR(2)=J IMOTR(3)=1 C-----SET SEARCH %TMSLB FLAG IMOTR(4)=0 IF(IPARAM(4) .EQ. 0) IMOTR(4)=-1 C-----CALL KEY-MAP AND THEN MENU (SCREEN # 8) CALL TMGSC(3,8) C END END$ qn   92903-18452 1805 S C0122 &TMPGO              H0101 FTN4 PROGRAM TMPG0(5),92903-16452 REV.1805 780515 C C C C ************************************************************** C * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * C ************************************************************** C C C C DATE: 29/JUL/77 C NAME: TMPG0 C SOURCE: &TMPG0 C RELOC: %TMPG0 C PGMR: DANIEL POT / FRANCOIS GAULLIER HPG C C C ************************************************************* C * * C * THIS IS THE FIRST SEGMENT OF TMPGN * C * * C * THIS SEGMENT IS CALL TO ANALYSE THE ANSWER TO THE * C * MENU SCREEN OR AT THE END OF EACH TASK TO REQUEST * C * THE NEXT ONE. * C * THIS SEGMENT TAKES CARE ALSO OF ALL FATAL ERRORS. * C * * C ************************************************************* C C C STOP USED: 4 - 5 - 7 - 10 - 11 - 13 - 14 - 15 - 16 - 17 - 20 C ---------- C C C IRQFLG(30) = NCRTH COMMON STATUS : 0 IF EMPTY, 1 IF FULL C IRQFLG(29) = NUMBER OF PRG WHEN THE DEPACK IS PERFORMED C C COMMON LU,LUPRT,NCRTH(2400),IRLOC(70),ITRSF(20),IRQFLG(30) COMMON IMOTR(9),IVASC0(9),IPARAM(5) C C DIMENSION NAME(3),IBUFF(9),IREG(2),IDCB(144),FNAME(3) DIMENSION ITEMP(3),IRSET(8),IPRES(26) C INTEGER FNAME,OPEN,PURGE,AREG,BREG,FTYPE EQUIVALENCE (REG,IREG,AREG),(IREG(2),BREG) EQUIVALENCE (ISCRN,IPARAM(1)),(IOFST,IPARAM(2)) . ,(IEND,IPARAM(3)),(IJOB,IPARAM(4)) C LOGIhCAL JPAR,KPAR,ISBTW,OKABT,GETBK,OKABT,CMPB LOGICAL READF,WRITF,CREAT,RWNDF C DATA IRSET/15530B,15555B,15446B,2Hk0,2HB ,15542B,15510B,15512B/ DATA IPRES/15542B,6412B,6412B,15446B,2Ha+,2H47,2HC ,15446B .,2HdJ,2HPr,2Hes,2Hs ,15446B,2HdK,2HNE,2HXT,2H S,2HCR,2HEE .,2HN ,15446B,2HdJ,2Hke,74433B,2H&d,2H@ / DATA FNAME/2H& ,2H ,2H / DATA FTYPE/31/,LENSC0/10/ DATA MAXCOP/3/ C KPAR(IP1,IP2,IP3)=JPAR(IRLOC,LENSC0,IDXX,IP1,IP2,IFLG,IP3) C C-----TERMINATE TMPGN ? C IF(IEND .EQ. 2) GOTO 9900 C C-----SYSTEM TYPE OK ? (RTE-III OR RTE-IV ONLY) C IF(IMOTR(5).NE.-9) GOTO 9900 C C JOB ? C IF(IJOB.EQ.2) GOTO 300 IF(IJOB.EQ.4) GOTO 270 C C-----GET A BLOCK OF DATA C 10 IF(ISCRN .NE. 0) STOP 0004 C-----IF GET FAIL, RE-ISSUE THE SCREEN (MENU) IF( GETBK(LU,IRLOC,LENSC0) ) GOTO 198 C C IMOTR(1) = FUNCTION C IMOTR(2) = LOAD OPTION C IMOTR(3) = MAP C IMOTR(4) = SEARCH %TMSLB FLAG C IMOTR(5) = SYSTEM TYPE ($OPSY) RTE-III=-1, RTE-IV=-9 C IMOTR(6) = APPLICATION NAME C IMOTR(8) = SECURITY CODE (ALWAYS 0) C IMOTR(9) = CARTRIDGE # C C-----ANALYSE USER'S ANSWER C IMOTR=0 IMOTR(6)=2HTM CALL NUL(IMOTR(7),3) CALL MOVEW(IVASC0,IBUFF,9) IEND=0 C C FUNCTION SELECTED C IDXX=1 IF(KPAR(ITEMP,1,JVAL)) GOTO 195 NERR=1 IF(IFLG.NE.3) GOTO 20 IMOTR=0 IF(ITEMP .EQ. 2HC ) IMOTR=1 IF(ITEMP .EQ. 2HU ) IMOTR=2 IF(ITEMP .EQ. 2HD ) IMOTR=4 IF(ITEMP .EQ. 2HL ) IMOTR=6 IF(ITEMP .EQ. 2HK ) IMOTR=7 IF(IMOTR .NE. 0) GOTO 30 GOTO 20 C-----SPECIAL ERROR RETURN WHEN FILE IS OPENED 18 CALL CLOSE(IDCB) 20 CALL TMPGE(NERR,IDXX) GOTO 10 C C TMP COPY NUMBER C 30 IDXX=2 IF(KPAR(K,1,JVAL)) GOTO 195 NERR=7 IF(IFLG.NE.1 .OR. ISBTW(JVAL,1,MAXCOP)) GOTO 20 IMOTR(7)=2HP0+JVAL IBUFF(2)=JVAL GOTO 50 C C-----INITIALIZE NCRTH IN PACKED FORMAT WITH BLANK OR 0 C 35 NERR=4 IF(IMOTR .NE. 1) GOTO 20 C C========================================= SPECIAL TMPGN C C SET UP SYSTEM MODULE: ZTMP, TSE, STORA, STORB, TSMG C INTO 2 USER PARTITION C C UPT 1: ZTMP, TSE, STORA, STORB C NO PARTITION SIZE, NO PARTITION ASSIG., SWAPPING FLAG. C REQUIRED PARTITION SIZE = 22K WORDS C C UPT 2: TSMG C PARTITION SIZE, NO PARTITION ASSIG., SWAPPING FLAG C C IREFC=50 K=6 C C-----FIXED PART INITIALISATION C NCRTH(2)=IREFC NCRTH(3)=NCRTH(2)+2 NCRTH(4)=NCRTH(3)+K CALL MOVEW(IMOTR(6),NCRTH(5),2) CALL MOVEW(20HTRANS. MON. REV.1805,NCRTH(7),10) CALL MOVEW(8H780415 ,NCRTH(17),4) CALL NUL(NCRTH(21),2) NCRTH(23)=IMOTR(9) CALL MOVEW(14HZTMP TSE ,NCRTH(24),7) NCRTH(27)=80 NCRTH(31)=0 CALL BLANC(NCRTH(32),13) NCRTH(38)=0 CALL NUL(NCRTH(45),5) C C INTERACTIVE AND AUXILIARY LU C NCRTH(50)=00 NCRTH(51)=3070 NCRTH(52)=LU NCRTH(53)=2645 NCRTH(54)=2 NCRTH(55)=7905 NCRTH(56)=3 NCRTH(57)=7905 C C-----PROGRAMS C I=NCRTH(4) NCRTH(I+1)=0 NCRTH(I+2)=100000B CALL MOVEW(24HZTMP TSE STORA STORB ,NCRTH(I+3),12) NCRTH(I)=I+15 I=NCRTH(I) NCRTH(I)=I+6 NCRTH(I+1)=0 NCRTH(I+2)=100000B CALL MOVEW(6HTSMG ,NCRTH(I+3),3) NCRTH(I)=I+6 NCRTH=NCRTH(I)-1 C C========================================= END SPECIAL TMPGN C IRQFLG(30)=0 GOTO 87 C C-----APPLICATION NAME GIVEN, SAVE IT AND GET CR # (SC=0) C 50 CALL MOVCA(IMOTR,11,FNAME,2,4) IDXX=3 IF(KPAR(ITEMP,6,IMOTR(9))) GOTO 195 IF(IFLG .EQ. 0) GOTO 55 NERR=5 IF(IFLG .NE. 3) GOTO 52 IF(ISUPB(ITEMP,3) .NE. 1) GOTO 20 IMOTR(9)=ITEMP  GOTO 54 52 IF(IFLG.NE.1) GOTO 20 IF(IMOTR(9) .EQ. 100000B) GOTO 20 C C-----CARTRIDGE MOUNTED ? C 54 NERR=35 IF(ICRLU(IMOTR(9)) .LT. 0) GOTO 20 C C-----NCRTH IS EMPTY, SO OPEN DISC FILE (UPDATE MODE) C 55 IBUFF(3)=IMOTR(9) IDXX=2 IF(OPEN(IDCB,IERR,FNAME,3,IMOTR(8),IMOTR(9)).GE.0) GOTO 65 NERR=4 C-----IF FILE DOESNT EXIT, INIT NCRTH IF(IERR.EQ.-6) GOTO 35 NERR=6 IF(IERR.EQ.-7) GOTO 20 STOP 0005 C C-----FILE &APLT ALREADY EXIST, CHECK IF IT IS A GOOD ONE C 65 NERR=38 IF(IERR .NE. FTYPE) GOTO 18 C C-----READ FILE INTO NCRTH C I=1 80 IF(READF(IDCB,IERR,NCRTH(I),200,LEN)) STOP 0007 I=I+LEN IF(LEN .NE. -1) GOTO 80 C C-----CHECK THAT THE FILE IS OK C IF(NCRTH .NE. I) GOTO 18 IF(NCRTH(23) .EQ. 0) NCRTH(23)=ICRLU(-IAND(IDCB,77B)) IF(IMOTR(9) .LE. 0) IMOTR(9)=NCRTH(23) IF(NCRTH(23) .NE. IMOTR(9)) GOTO 18 C C-----OK, WRITE IT BACK TO CHECK NOW THE SECURITY CODE C IF(RWNDF(IDCB,IERR)) STOP 0010 NERR=6 I=NCRTH/128 LEN=128 IF(I.EQ.0) LEN=NCRTH IF( .NOT. WRITF(IDCB,IERR,NCRTH,LEN) ) GOTO 85 IF(IERR.EQ.-7) GOTO 18 CALL CLOSE(IDCB) STOP 0011 85 CALL CLOSE(IDCB) IRQFLG(30)=1 C-----INIT FLAG TO NOT PREPARE AND NOT LOAD ANY PROGRAM 87 DO 88 I=1,28 88 IRQFLG(I)=0 C GOTO 200 C C-----ILLEGAL CHARATER ? C 195 NERR=34 IF(IFLG .NE. 9) GOTO 20 C C-----USER WANTS TO ABORT ? C 197 IF(OKABT(LU)) GOTO 9900 C C-----IT IS NOT ABORT REQUEST, RE-ISSUE THE MENU (SCREEN # 0) C 198 CALL TMGSC(3) C C========================================================= C C C-----PROCESS THE REQUESTED FUNCTION C 200 CALL MOVEW(IBUFF,IVASC0,9) C C-----SET-UP SEGMENTS' PARAMETERS C ISEGNB=5 IRQ=0 IJOB=0 C C ***** LIST ? C IF(IMOTR .EQ. 6) GOTO 278 C C ***** PURGE ? z C IF(IMOTR .NE. 7) GOTO 210 CALL NUL(IVASC0(6),3) CALL MOVCA(4H ,1,IVASC0,8,4) IEND=3 GOTO 238 C C ***** MODIFY LU ? C 210 IF(IMOTR .EQ. 2) GOTO 225 C C ***** MODIFY / CREATE REQUEST ? C IF(IMOTR .NE. 1) GOTO 215 K=2 213 DO 218 I=K,28 218 IRQFLG(I)=1 GOTO 225 C C ***** DEFINE USER WRITTEN MODULES ? C 215 ISEGNB=5 IF(IMOTR .NE. 4) GOTO 220 IJOB=3 K=5 GOTO 213 C C ***** MODIFY MAIN PROGRAM ? C 220 IF(IMOTR .NE. 3) GOTO 230 225 IRQFLG=1 IRQFLG(29)=NBUPT(NCRTH) CALL DEPAK C-----EDITING PROCESSING, CALL SEG # 5 OR 4, C (LU & PRG. OR DATA-BASE & MAIN / RELOAD SOME PARTITION) 228 CALL TMGSC(ISEGNB,0,0,0,IJOB) C C ***** PREPARE AND LOAD ALL THE APPLICATION ? C 230 IF(IMOTR .NE. 5) STOP 0013 DO 232 I=1,28 232 IRQFLG(I)=1 C-----CALL PREP. MODULE C (STOP THE APPLT., PREP. FILES AND LOAD AS REQUESTED) 235 IF(IMOTR(2) .EQ. 1) GOTO 900 IRQ=1 238 CALL TMGSC(2,IRQ,0,IEND,4) C C-----RETURN FROM THE COMPILER, THE LISTING, THE PURGE OR C THE LOAD OPERATION. C 270 IF(IEND .EQ. -1) GOTO 420 IF(IEND .EQ. -2) GOTO 280 IF(IEND .EQ. 1) GOTO 900 IF(IEND .NE. 0) GOTO 450 C-----PREP. WAS OK, LOAD PROGRAMS. IRQ=1 278 CALL TMGSC(1,IRQ,0,0,4) C-----LOAD HAS FAIL, STOP TMPGN OPERATION 280 CALL ISUPB(ITRSF,3) CALL MOVEW(IRLOC(4),IRLOC(9),2) CALL MOVEW(16H Loading ERROR ,IRLOC,8) CALL MOVEW(16H, Program ,IRLOC(11),8) CALL MOVCA(ITRSF,2,IRLOC(16),1,5) CALL MOVEW(22H has not been loaded. ,IRLOC(19),11) IRLOC(30)=6412B CALL BLANC(IRLOC(31),8) GOTO 440 C C-----RETURN FROM THE INTERACTIVE EDITING PROCESSING, C FUNCTION MUST BE 1, 2 OR 3 AND IEND=1 TO BE THE END C (REPACK, WRITE THE FILE AND LOAD IF NEEDED) C 300 IF(IMOTR .GT. 4 .OR. IEND .NE. 1R) STOP 0014 CALL REPAK CALL MOVCA(NCRTH,9,FNAME,2,4) C C========================================= SPECIAL TMPGN C C SETUP PARTITION SIZE FOR ALL SYSTEM MODULE C C MAIN = 6 + 1.2 * NUMBER OF 3070 C CALL MADSP(ITEMP) N=(NCRTH(3)-NCRTH(2))/2 X=6.+1.2*FLOAT(N) I=IFIX(X)+1 IF(I .GT. ITEMP(2)) I=ITEMP(2) NCRTH(45)=I C C TMP.B = .150 * NUMBER OF TRANS. SPEC. C X=8.+.15*25. I=NCRTH(NCRTH(4)) NCRTH(I+1)=IFIX(X)+1 C C IMAGE = 12 + LOCK TABLE + ROOT FILE + IMAGE DCB C IF(NCRTH(39) .EQ. 2H ) GOTO 302 C-----ROOT FILE + IMAGE DCB = 4000 NCRTH(47)=(12288.+FLOAT(NCRTH(49))+4000.)/1000 C C-----REINIT THE CRT AUXILIARY LU TO THE CRT USED BY TMPGN C 302 NCRTH(NCRTH(3))=LU C C========================================= END SPECIAL TMPGN C IF(OPEN(IDCB,IERR,FNAME,1,NCRTH(22),NCRTH(23)).EQ.31) GOTO 303 IF(IERR.NE.-006) STOP 0015 IF(CREAT(IDCB,IERR,FNAME,2,FTYPE,NCRTH(22),NCRTH(23))) GOTO 400 303 I=NCRTH/128 IF(I.EQ.0) GOTO 309 DO 307 K=1,I IF(WRITF(IDCB,IERR,NCRTH((128*K)-127),128)) STOP 0016 307 CONTINUE 309 LEN=(NCRTH)-(128*I) IF(WRITF(IDCB,IERR,NCRTH((128*(I+1))-127),LEN)) STOP 0017 IF(WRITF(IDCB,IERR,NCRTH,-1)) STOP 0020 CALL CLOSE(IDCB) C-----RE-INIT SCREEN DATA & IMOTR WITH &XXXX:SC:CR FROM NCRTH CALL MOVCA(NCRTH,9,IVASC0,8,4) CALL MOVCA(NCRTH,43,IVASC0,12,2) CALL MOVCA(NCRTH,45,IVASC0,14,2) IMOTR(6)=NCRTH(5) IMOTR(7)=NCRTH(6) IMOTR(8)=NCRTH(22) IMOTR(9)=NCRTH(23) IRQFLG(30)=1 IF(IMOTR.NE.1 .AND. IMOTR.NE.4) GOTO 316 C-----IF THE NUMBER OF PROGRAM HAS DECREASE, CLEAN UP UNUSED MODULE IF(IRQFLG(29) .EQ. 0) GOTO 316 IF(IRQFLG(29) .LE. NBUPT(NCRTH)) GOTO 316 CALL MOVEW(IRSET,IRLOC,8) CALL MOVEW(26H Clean up unused modules. ,IRLOC(9),13) CALL EXEC(2,LU,IRLOC,21) IRQ=2 V IEND=4 GOTO 238 316 IRQFLG(29)=NBUPT(NCRTH) C-----ANY PROGRAM TO PREPARE AND LOAD ? DO 320 I=1,28 IF(IRQFLG(I) .NE. 0) GOTO 235 320 CONTINUE C-----GO BACK TO SCREEN # 0 (MENU) GOTO 900 C C-----NO ROOM ON THE CARTRIDGE !! C 400 CALL MOVEW(FNAME,IRLOC(24),3) CALL MOVEW(IRSET,IRLOC,8) GOTO 430 420 CALL MOVEW(NCRTH(2373),IRLOC(20),7) CALL BLANC(IRLOC,7) IRLOC(8)=6412B IF(NCRTH(2380) .EQ. -6) GOTO 430 C C-----FATAL FMP ERROR DURING CREATION PHASE C CALL MOVEW(22H Illegal file type on,IRLOC(9),11) IF(NCRTH(2380) .GT. 0) GOTO 427 CALL MOVEW(22H FMP ERROR # XXXXXX on,IRLOC(9),11) CALL JASC(NCRTH(2380),IRLOC(15),1,7) 427 CALL MOVEW(22H !! ,IRLOC(27),11) GOTO 438 430 IRQFLG(30)=0 CALL MOVEW(14H NO ROOM on CR,IRLOC(9),7) CALL CNUMD(NCRTH(23),IRLOC(16)) CALL MOVEW(10H , file: ,IRLOC(19),5) CALL MOVEW(22H has not been created.,IRLOC(27),11) 438 IRLOC(38)=6412B 440 IRLOC(39)=6412B CALL MOVEW(30H generation is NOT completed, ,IRLOC(40),15) CALL MOVEW(32Hcorrective action MUST be taken.,IRLOC(55),16) CALL EXEC(2,LU,IRLOC,70) IEND=0 C-----WAIT ACKNOWLEDGMENT FROM THE OPERATOR 450 CALL EXEC(2,LU,IPRES,26) REG= EXEC(1,LU,I,1) IF(IEND .EQ. 4) GOTO 316 IF(BREG.EQ.1 .AND. IGET1(I,1).EQ.60440B) GOTO 197 GOTO 900 C C END TMPGN C 900 CONTINUE 9900 CALL MOVEW(IRSET,IRLOC,8) CALL MOVEW(14H /TMPGN: $END ,IRLOC(9),7) CALL PNAME(IRLOC(10)) IRLOC(12)=IOR(IRLOC(12),72B) CALL EXEC(2,LU,IRLOC,8) C-----TRY TO SCHEDULE 'DCMON', ATTENTION TO ABORT RETURN CALL EXEC(100000B+24,6HDCMON ,LU,0,0,0,0) GOTO 9920 9918 GOTO 9950 C-----DCMON NOT LOADED, PRINT "/TMPGN: $END" 9920 CALL EXEC(2,LU,IRLOC(9),7) C C-----RELEASE TRACKS C 9950 CALL EXEC(5,-1) C C-----TERMINATE PROGRAM C CALL EXEC(6) C h0.*DUMMY CALL TO MAIN !! CALL TMPGN END END$ od0   92903-18453 1805 S C0122 &TMPG1              H0101 FTN4 PROGRAM TMPG1(5),92903-16453 REV.1805 780419 C C C C ************************************************************** C * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * C ************************************************************** C C C C NAME: TMPG1 C SOURCE: &TMPG1 92903-18453 C BINARY %TMPG1 92903-16453 C C PGMR: DANIEL POT/FRANCOIS GAULLIER HPG C C C ****************************************** C * THIS PROGRAM ALLOWS USER EITHER TO * C * LIST ALL FILES OF AN APPLICATION * C * OR TO LOAD ALL PROGRAMS ASSOCIATED * C * TO THIS APPLICATION. * C * * C * IF P1 = 0 FUNCTION LIST * C * IF P1 = 1 FUNCTION LOAD * C ****************************************** C C C STOP USED: 1000 C ---------- C C NOTE: WORKS ON PACKED FORM OF NCRTH C ------ C C COMMON LU,LUPRT,NCRTH(2400),IRLOC(70),ITRSF(20),IRQFLG(30) COMMON IMOTR(18),IPARAM(5) C DIMENSION IBUF(350),NUMB(40),ILIS(20) C EQUIVALENCE (IRQ,IPARAM),(IJOB,IPARAM(4)) EQUIVALENCE (NCRT5,NCRTH(5)) C DATA ILIS/15530B,15555B,15446B,2Hk0,2HB ,15542B,15510B,15512B .,2H ,15446B,2HdC,2HLI,2HST,2HIN,2HG ,15446B,2Hd@,6412B .,5012B,15554B/ DATA ICH/83/ C IF(IRQ.EQ.1) GOTO 2000 IF(IRQ.NE.0) STOP 1000 C C ********************* C * LISTING OPERATION * C ********************* C C CALL EXEC(2,LU,ILIS,20) C C-----IF LIST DEVICE IS NOT CRT, LOCK IT C CALL LCKLL(LU,LUPRT,500) CALL EXEC(3,1100B+LUPRT,-1) IAPLN=IGET1(NCRTH,12) NWRITE(LUPRT,100)(IAPLN),(NCRTH(I),I=7,20) WRITE(LUPRT,110)(NCRTH(23)) WRITE(LUPRT,240) IF(NCRTH(21) .NE. 0) WRITE(LUPRT,130)NCRTH(21) IF(NCRTH(21) .EQ. 0) WRITE(LUPRT,135) IF(NCRTH(32).NE.2H ) WRITE(LUPRT,140)(NCRTH(I),I=32,38) IF(NCRTH(32).EQ.2H ) WRITE(LUPRT,270) WRITE(LUPRT,240) J=(NCRTH(3)-NCRTH(2))/2 WRITE(LUPRT,160) J J=J/7 K=NCRTH(2) IF(J.EQ.0) GOTO 401 C C PRINT 3070 LU'S C 408 DO 400 I=1,J WRITE(LUPRT,170)(NCRTH(L),L=K,K+12,2) K=K+14 400 CONTINUE IF(K.EQ.NCRTH(3)) GOTO 402 401 WRITE(LUPRT,170)(NCRTH(L),L=K,(NCRTH(3)-2),2) 402 J=(NCRTH(4)-NCRTH(3))/2 WRITE(LUPRT,240) C C USER'S MODULES PROGRAMS C CALL BLANC(IBUF,350) CALL PUTCA(IBUF,1H&,3) CALL MOVCA(NCRTH,9,IBUF,4,4) CALL PUTCA(IBUF,1H%,13) CALL MOVCA(NCRTH,9,IBUF,14,4) CALL PUTCA(IBUF,1H/,23) CALL MOVCA(NCRTH,9,IBUF,24,4) IBUF(17)=2H%T CALL MOVEW(NCRT5,IBUF(18),2) IBUF(22)=2H/T CALL MOVEW(NCRT5,IBUF(23),2) CALL MOVEW(IBUF(17),IBUF(27),10) CALL PUTCA(IBUF,1HL,54) CALL PUTCA(IBUF,1HL,64) ICH=73 C-----SET UP IMAGE MODULE IF ANY IF(NCRTH(32) .EQ. 2H ) GOTO 630 CALL PUTCA(IBUF,1H%,ICH) CALL MOVCA(NCRTH,77,IBUF,ICH+1,5) CALL MOVEW(IBUF(37),IBUF(42),5) CALL PUTCA(IBUF,1H/,83) ICH=ICH+20 630 IUPT=0 ITUS=0 J=NCRTH(4) C C-----LOOP ON EACH USER PARTITION C 640 I=NCRTH(J) K=J J=((I-J-3)/18)+1 IF( I-K-3 .EQ. 18*(J-1) ) J=J-1 IF(IUPT .GE. 2) WRITE(LUPRT,240) C-----WRITE PROGRAM NUMBER, SWAP OPTION ... M=IUPT-1 IF(IUPT .GE. 2) WRITE(LUPRT,200) M C-----WRITE LOADER OPTION IF(IUPT .GE. 2) WRITE(LUPRT,240) CALL PUTCA(IBUF,1H%,20*IUPT+ICH) CALL PUTCA(IBUF,1H/,20*IUPT+ICH+10) CALL MOVCA(NCRTH,9,IBUF,20*IUPT+ICH+1,4) CALL MOVCA(NCRTH,9,IBUF,20R*IUPT+ICH+11,4) CALL PUTCA(IBUF,1HA+IUPT*256,20*IUPT+ICH+5) CALL PUTCA(IBUF,1HA+IUPT*256,20*IUPT+ICH+15) CALL ISUPB(IBUF((20*IUPT+ICH+1)/2),3) CALL ISUPB(IBUF((20*IUPT+ICH+11)/2),3) K=K+3 LINE=0 690 L=K CALL BLAN(NUMB,1,79) M=(2*(L-(K-3))/3) 695 CALL MOVEW(6H LB: ,NUMB(M),3) IF(IAND(NCRTH(L),100000B).NE.0) GOTO 698 ITUS=ITUS+1 NUMB(M+2)=2H - CALL JASC(ITUS,NUMB(M+1),-1,3) 698 NUMB(M+3)=IAND(NCRTH(L),77777B) CALL MOVEW(NCRTH(L+1),NUMB(M+4),2) L=L+3 M=M+6 IF(L.EQ.I) GOTO 699 IF(L.NE.K+18) GOTO 695 699 IF(IUPT .GE. 2) CALL EXEC(2,LUPRT,NUMB,38) K=K+18 LINE=LINE+1 IF(LINE.NE.J) GOTO 690 J=I IUPT=IUPT+1 IF(J .NE. NCRTH+1) GOTO 640 C C-----PRINT " NO USER MODULES " IF # OF PART. = 2 C IF(IUPT .EQ. 2) WRITE(LUPRT,250) C C-----WRITE DIRECTORY (ALL FILES CREATED BY TMSGN) C WRITE(LUPRT,240) WRITE(LUPRT,230) J=1 DO 80 I=1,1+(20*(IUPT+1)+ICH)/80 CALL EXEC(2,LUPRT,IBUF(J),39) 80 J=J+40 C CALL EXEC(3,1100B+LUPRT,-1) C C-----IF LIST DEVICE IS NOT CRT, UNLOCK THE LIST DEVICE C IF(LU .NE. LUPRT) CALL LURQ(0,LUPRT,1) GO TO 3100 C C FORMATS USED BY LISTG C 100 FORMAT(/,3X,"TRANSACTION MONITOR PROGRAM #: "1A1,3X,10A2,2X, .4A2) 120 FORMAT(/,3X,"NO USER'S MODULES") 110 FORMAT(/,3X,"ON CARTRIDGE # "I6) 130 FORMAT(/,3X,"LOGGING ON MAGNETIC TAPE LU :"I3) 135 FORMAT(/,3X,"NO LOGGING") 140 FORMAT(/,3X,"DATA BASE NAME: "3A2", LEVEL ACCESS WORD: "3A2, .", SEC. CODE: "I6) 160 FORMAT(/,3X,"NUMBER OF 3070 TERMINALS: "I2) 170 FORMAT(/,3X,"LU : "I2,6(7X,I2)) 200 FORMAT(/,3X,"USER MODULES PROGRAM UNIT #: "I2,2X) 220 FORMAT(3X,6(5A2,2X)) 230 FORMAT(//,3X"FILES CREATED BY TMPGN:",/) 240 FORMAT(5X) 250 FORMAT(/,3X,"NO USER MODULES.") 270 FORMAT(/,3X,"NO DATA BASE") C C C C========================================================================== C C ******************** C * LOAD OPERATION * C ******************** C C 2000 CALL TMGLD(IEND) C-----IF LOAD OPERATION HAS FAILED, REPORT ERROR TO OPERATOR IF(IEND .LT. 0) GOTO 3120 C C LISTING OR LOADING PHASE IS FINISH, C WRITE MESSAGE ON CRT IF NEEDED & EXIT C 3100 IF(LU .NE. LUPRT) GOTO 3300 IEND=3 3120 CALL TMGSC(0,0,0,IEND,IJOB) C C-----ACKNOWLEDGMENT NOT NEEDED, TERMINATE TMPGN C 3300 CALL TMGSC(0,0,0,2) C C DUMMY CALL TO MAIN !! C CALL TMPGN END END$ l%  92903-18454 1805 S C0122 &TMPG2              H0101 FTN4 PROGRAM TMPG2(5),92903-16454 REV.1805 780322 C C C C ************************************************************** C * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * C ************************************************************** C C C C NAME: TMPG2 C SOURCE: &TMPG2 92903-18454 C BINARY:%TMPG2 92903-16454 C C PGMR: FRANCOIS GAULLIER HPG C C C ****************************************** C * THIS PROGRAM ALLOWS USER EITHER TO * C * CREATE ALL FILES OF AN APPLICATION * C * OR TO PURGE ONLY UNUSED OR ALL FILES * C * ASSOCIATED TO THIS APPLICATION. * C * * C * IF P1 = 0 FUNCTION PURGE ALL * C * IF P1 = 1 FUNCTION CREATE * C * IF P1 = 2 FUNCTION PURGE UNUSED * C * FILES. * C ****************************************** C C C STOP USED: 2000 C ---------- C C NOTE: WORKS ON PACKED FORM OF NCRTH C ------ C C COMMON LU,LUPRT,NCRTH(2400),IRLOC(70),ITRSF(20),IRQFLG(30) COMMON IMOTR(18),IRQ(2),IEND,IJOB C LOGICAL FLAG C IF(IRQ.EQ.0) GOTO 2000 IF(IRQ.EQ.2) GOTO 2500 IF(IRQ.NE.1) STOP 2000 C C ************************ C * PREPARTION OPERATION * C ************************ C C-----INIT SEARCH %TMSLB FLAG C NCRTH(2398)=IMOTR(4) CALL TMGCR(IEND) GOTO 3000 C C ******************** C * PURGE OPERARTION * C ******************** C 2000 FLAG=IGET1(NCRTH,12) .EQ. IGET1(NCRTH,81) CALL TMGPU(FLAG,.TRUE.,1,NBUPT(NCRTH)) C-----IF LIST OF PURGE ON AN OTHER LU, TERMINATE TMPGN&   IF(LU .NE. LUPRT) CALL TMGSC(0,0,0,2) IEND=3 GOTO 3000 C C-----PURGE UNUSED MODULE ONLY C 2500 I=LUPRT LUPRT=LU CALL TMGPU(.FALSE.,.FALSE.,NBUPT(NCRTH)+1,IRQFLG(29)) LUPRT=I C C PREPARATION OR PURGE IS FINISH C WRITE MESSAGE ON CRT IF NEEDED AND EXIT. C 3000 CALL TMGSC(0,0,0,IEND,IJOB) C C DUMMY CALL TO MAIN !! C CALL TMPGN END END$ 3Y   92903-18455 1805 S C0222 &TMG3A              H0102 oASMB HED . TMPG3 ** TMPGN SCREENS DATA ** NAM TMPG3,5 92903-16455 REV.1805 780515 SUP * SPC 2 * ************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * ************************************************************** SPC 2 * * NAME: TMPG3 * SOURCE: &TMPG3 92903-18455 * BINARY: %TMPG3 92903-16455 * * PGMR: D. POT / F. GAULLIER HPG * * * ********************************************** * * THIS SEGMENT OF TMPGN PROGRAM IS USED TO * * * WRITE ON THE 2640/44/45 DISPLAY TERMINALS * * * THE SCREEN MASKS ALLOWING THE INTERACTIVE * * * DEFINITION OF AN APPLICATION. * * * * * * CALL SCREN(P1,P2) * * * * * * P1 = SCREEN # TO DISPLAY * * * P2 = OFFSET IN BYTE ADDED TO THE SOUR- * * * CE OFFSET. * * ********************************************** SPC 2 EXT TMPGN,TMGSC,EXEC,$OPSY,MOVCX,GETBK SPC 1 COM LU,LUPRT,NCRTH(2400) COM IRLOC(70),ITRSF(20) COM DUMMY(30),IMOTR(9),IMAGE(9) COM IPARM(5) SCR#-OFSET-END FLG-JOB# SPC 3 TMPG3 JSB CLDPY CLEARS DISPLAY * * FIND SCREEN TO DISPLAY * LDA IPARM LOAD SCREEN NUMBER ADA ADDRS ADD OFFSET ADRESS JMP 0,I JUMPS TO THIS ADRESS SPC 2 * * SCREEN IS DISPLAYED, RETURN TO THE RIGHT SEGMENT * RTRN STA CLDPY SET SEGMENT # JSB TMGSC GOTO NEXT SEGMENT DEF *+7 DEF CLDPY SEG # DEF IPARM 1ST PARAM DEF IPARP_M+1 2ND PARAM DEF IPARM+2 3RD PARAM DEF IPARM+3 4TH PARAM DEF IPARM+4 5TH PARAM SPC 2 * * SCREEN ADRESSES * ADDRS DEF *+1,I DEF SCR00 SCREEN # 0 DEF SCR01 SCREEN # 1 DEF SCRXX ILLEGAL ! DEF SCR03 SCREEN # 3 DEF SCR04 SCREEN # 4 DEF SCRXX ILLEGAL ! DEF SCRXX ILLEGAL ! DEF SCRXX ILLEGAL ! DEF SCR08 SCREEN # 8 DEF SCRXX ILLEGAL SCREEN # DEF SCRXX ILLEGAL SCREEN # DEF SCRXX ILLEGAL SCREEN # DEF SCRXX ILLEGAL SCREEN # SPC 1 SCRXX HLT 33B !!! SPC 1 * DISPLAY INITIALISATION * - DISABLE KEYBOARD * - MEMORY UNLCK * - SET BLOCK MODE KEY * - FORMAT MODE OFF * - HOME UP CURSOR * - CLEAR DISPLAY * CLDPY NOP JSB EXEC WRITE EXEC CALL DEF *+5 RETURN POINT DEF D2 WRITE CODE DEF LU CONTROL WORD DEF BINIT BUFFER TO WRITE DEF BLGNH BUFFER LENGTH JMP CLDPY,I RETURN * * DATA FOR INITIALISATION OF TERMINAL * BINIT BYT 33,143 DISABLE KEYBOARD BYT 33,155 MEMORY UNLCK BYT 40,33 ASC 2,&k1B SET BLOCK MODE KEY BYT 33,130 FORMAT MODE OFF BYT 33,110 HOME UP CURSOR BYT 33,112 CLEAR DISPLAY BLGNH DEC 8 SPC 1 D2 DEC 2 D5 DEC 5 DM9 DEC -9 HED TMPGN SCREEN # 0 - MENU D0 DEC 0 SPC 2 * * SCREEN NUMBER: 0 * * SCR00 LDA $OPSY GET SYSTEM TYPE CPA DM9 RTE-IV ? JMP SCR0A YES, OK JMP SCR0Z NO, SYSTEM IS NOT GOOD !!! * SCR0A STA IMOTR+4 SAVE SYSTEM TYPE IN COMMON IMOTR(5) * JSB MOVCX DEF *+6 DEF IMAGE DEF SOF00 DEF DOF00 DEF D0 DEF DBL00 * JSB EXEC DEF *+5 DEF D2 DEF LU DEF ZAT00 DEF LNG00 * SCR0Z CLA GO TO SEGMENT # 0 JMP RTRN SPC 3 ZAT00 BYT 33,110,33,112 * * LINE # : 1 * BYT 33,46,141,53,61,66,103,0 POSITION CURSOR - 17 ASC 18,TRANSACTION MONITOR PROGRAM GENERATO BYT 122,0 BYT 15,12 * * LINE # : 2 * BYT 15,12 * * LINE # : 3 * ASC 22, - You may have a maximum of three differen ASC 08,t copies of the BYT 33,46,144,104 BYT 124,0 BYT 33,46,144,100 ASC 5,ransaction BYT 40,0 BYT 33,46,144,104 BYT 115,0 BYT 33,46,144,100 ASC 3,onitor BYT 15,12 * * LINE # : 4 * ASC 2, BYT 33,46,144,104 BYT 120,0 BYT 33,46,144,100 ASC 22,rogram. ( Each copy is identified by a numbe ASC 13,r between one and three ). BYT 15,12 * * LINE # : 5 * BYT 15,12 * * LINE # : 6 * ASC 22, - Once they have been configured, all copi ASC 17,es of TMP may be simultaneously BYT 15,12 * * LINE # : 7 * ASC 22, activated ( providing no HP3070 terminal ASC 17, is refered to by more than one BYT 15,12 * * LINE # : 8 * ASC 11, active TMP copy ). BYT 15,12 * * LINE # : 9 * BYT 15,12 * * LINE # : 10 * BYT 33,51,102,16 ASC 22,R,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ASC 18,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,T * * LINE # : 11 * BYT 33,51,102,16 BYT 56,17 ASC 17, - Select your mode of operation: BYT 33,46,141,53,64,64,103,0 POSITION CURSOR - 80 BYT 16,56 * * LINE # : 12 * BYT 33,51,102,16 BYT 56,17 ASC 2, BYT 40,0 BYT 33,46,144,104 BYT 103,0 BYT 33,46,144,100 ASC 13,reate or modify a TMP copy BYT 33,46,141,53,63,65,103,0 POSITION CURSOR - 69 ASC 1,) BYT 33,46,141,53,60,71,103,0 POSITION CUkRSOR - 80 BYT 16,56 * * LINE # : 13 * BYT 33,51,102,16 BYT 56,17 ASC 2, BYT 40,0 BYT 33,46,144,104 BYT 125,0 BYT 33,46,144,100 ASC 22,pdate the HP3070 terminals configuration in ASC 9,a TMP copy ) BYT 33,46,141,53,61,60,103,0 POSITION CURSOR - 80 BYT 16,56 * * LINE # : 14 * BYT 33,51,102,16 BYT 56,17 ASC 2, BYT 40,0 BYT 33,46,144,104 BYT 104,0 BYT 33,46,144,100 ASC 22,efine the user written modules added to a TM ASC 3,P copy BYT 33,46,141,53,61,61,103,0 POSITION CURSOR - 69 ASC 5,) ....... BYT 33,46,144,102,33,133 T0000 BYT 40,0 BYT 33,135,33,46,144,100,16,56 * * LINE # : 15 * BYT 33,51,102,16 BYT 56,17 ASC 2, BYT 40,0 BYT 33,46,144,104 BYT 114,0 BYT 33,46,144,100 ASC 16,ist specifications of a TMP copy BYT 33,46,141,53,62,71,103,0 POSITION CURSOR - 69 ASC 1,) BYT 33,46,141,53,60,71,103,0 POSITION CURSOR - 80 BYT 16,56 * * LINE # : 16 * BYT 33,51,102,16 BYT 56,17 ASC 2, BYT 40,0 BYT 33,46,144,104 BYT 113,0 BYT 33,46,144,100 ASC 22,ill a TMP copy (purge disc files related to ASC 9,this TMP copy) ) BYT 33,46,141,53,61,60,103,0 POSITION CURSOR - 80 BYT 16,56 * * LINE # : 17 * BYT 33,51,102,16 BYT 56,17 BYT 33,46,141,53,67,70,103,0 POSITION CURSOR - 80 BYT 16,56 * * LINE # : 18 * BYT 33,51,102,16 BYT 56,17 ASC 22, - Enter the TMP copy number .............. ASC 16,................................ BYT 40,0 BYT 33,46,144,102,33,133 T0001 BYT 40,0 BYT 33,135,33,46,144,100,16,56 * * LINE # : 19 * BYT 33,51,102,16 ASC 1,. BYT 17,40 BYT 33,46,IZ141,53,67,66,103,0 POSITION CURSOR - 80 BYT 16,56 * * LINE # : 20 * BYT 33,51,102,16 BYT 56,17 ASC 22, - Specify the disc cartridge reference numb ASC 12,er on which the TMP copy BYT 33,46,141,53,61,60,103,0 POSITION CURSOR - 80 BYT 16,56 * * LINE # : 21 * BYT 33,51,102,16 BYT 56,17 ASC 22, is to be created or found (default is fir ASC 14,st cartridge mounted) ..... BYT 33,46,144,102,33,133 T0002 ASC 3, BYT 33,135,33,46,144,100,16,56 * * LINE # : 22 * BYT 33,51,102,16 ASC 22,F,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ASC 18,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,G * * LINE # : 23 * BYT 15,12 * * LINE # : 24 * BYT 40,33,127,137 FORMAT MODE ON,SUP., SPC 1 LNG00 ABS *-ZAT00 SPC 2 * * SOURCE CHARACTER OFFSET ADRESS * SOF00 DEC 0001 DEC 0003 DEC 0005 DEC 0007 DEC -1 * * DESTINATION BUFFER ADRESS * DOF00 DEF T0000,I DEF T0001,I DEF T0002,I * * FORMAT OF NUMERIC DATA * DBL00 DEC 1 DEC 1 DEC 6 HED TMPGN SCREEN # 1 - 3070 LU'S CHAX BYT 130,00 VIDE BYT 40,00 PLIN BYT 61,00 BCHAR DEF T0102 ADTIF OCT 62 BKHAR DEF T0123+62B B377 OCT 377 SPACE ASC 1, SPC 2 SCR01 JSB MOVCX DEF *+6 DEF NCRTH DEF SOF01 DEF DOF01 DEF IPARM+1 DEF DBL01 * LDB BCHAR GET FIRST "X" CHARACTER ADRESS SC11X LDA 1,I GET THE CORRESPONDING VALUE CPA PLIN COMPARE TO "1" ASCII ? JMP SC14X YES, IT SHOULD BE "-1", SET "X" LDA VIDE NO, IT SHOULD BE "3070", STORE SPACE RSS STORE VALUE SC14X LDA CHAX GET "X" VALUE STA 1,I STORE VALUE ADB ADTIF CALCULATES NEXT ADRESS TO BE PROCESSED CPB BKHAR COMPARE TO THE LAST ADRESS RSS END OF CORRECTION JMP SC11X CONTINUE * JSB TMP# ADD TMP COPY NUMBER STA U0100 IN THE SCREEN * JSB EXEC DEF *+5 DEF D2 DEF LU DEF ZAT01 DEF LNG01 LDA D5 RETURN TO SEG # 5 (LU ANALYSIS) JMP RTRN SPC 2 TMP# NOP FORMAT TMP COPY NUMBER LDA NCRTH+5 RECALL LAST CHAR. OF APPLICATION NAME AND B377 MASK OUT THE LAST CHAR. (TMP #) IOR SPACE MERGE SPACE ON THE LEFT BYTE JMP TMP#,I AND RETURN WITH RESULT IN A REG. SPC 3 * * LINE # : 1 * ZAT01 BYT 33,110,33,112,15,12 * * LINE # : 2 * BYT 33,46,141,53,61,60,103,0 POSITION CURSOR - 10 ASC 20,HP3070 TERMINAL CONFIGURATION DEFINITION ASC 7, FOR TMP COPY U0100 ASC 1, TMP COPY NUMBER IS STORE HERE BYT 15,12 * * LINE # : 3 * BYT 15,12 * * LINE # : 4 * ASC 22, - Enter the logical unit numbers (LU#) of ASC 13,the HP3070 terminals to be BYT 15,12 * * LINE # : 5 * ASC 22, added to or deleted from this copy of th ASC 3,e TMP. BYT 15,12 * * LINE # : 6 * ASC 22, - If some terminals have been assigned con ASC 15,secutive logical unit numbers, BYT 15,12 * * LINE # : 7 * ASC 22, enter the first LU# of the sequence in t ASC 15,he FROM field and the last LU# BYT 15,12 * * LINE # : 8 * ASC 18, of the sequence in the TO field. BYT 15,12 * * LINE # : 9 * ASC 22, - All other terminal LU#'s should be enter ASC 10,ed in the FROM field BYT 56,0 BYT 15,12 * * LINE # : 10 * BYT 33,46,141,53,61,60,103,0 POSITION CURSOR - 11 BYT 33,51,102,16 ASC 22,R,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,T ASC 8,R,,,,,,,,,,,,,,T BYT 15,12 * * LINE # : 11 * BYT 33,46,141,53,61,60,103,0 POSITION )CURSOR - 11 BYT 33,51,102,16 BYT 56,17 ASC 5, FROM BYT 33,46,141,53,62,61,103,0 POSITION CURSOR - 43 ASC 4,TO BYT 40,16 ASC 2,. . BYT 17,40 ASC 6, Enter X to BYT 40,16 BYT 56,0 BYT 15,12 * * LINE # : 12 * BYT 33,46,141,53,61,60,103,0 POSITION CURSOR - 11 BYT 33,51,102,16 BYT 56,17 ASC 8, Logical Unit # BYT 33,46,141,53,60,71,103,0 POSITION CURSOR - 37 ASC 7,Logical Unit # BYT 40,16 ASC 2,. . BYT 17,40 ASC 6, delete BYT 40,16 BYT 56,0 BYT 15,12 * * LINE # : 13 * BYT 33,46,141,53,61,60,103,0 POSITION CURSOR - 11 BYT 33,51,102,16 BYT 56,17 BYT 33,46,141,53,64,60,103,0 POSITION CURSOR - 52 BYT 16,56 ASC 1, BYT 56,17 BYT 33,46,141,53,61,64,103,0 POSITION CURSOR - 70 BYT 16,56 BYT 15,12 * * LINE # : 14 * BYT 33,46,141,53,61,60,103,0 POSITION CURSOR - 11 BYT 33,51,102,16 BYT 56,17 ASC 3, BYT 33,46,144,106,33,133 T0100 ASC 1, BYT 33,135,33,46,144,100 BYT 33,46,141,53,62,63,103,0 POSITION CURSOR - 43 BYT 33,46,144,106,33,133 T0101 ASC 1, BYT 33,135,33,46,144,100 ASC 3, BYT 40,16 ASC 2,. . BYT 17,40 ASC 3, BYT 33,46,144,106,33,133 T0102 BYT 40,0 BYT 33,135,33,46,144,100 ASC 3, BYT 16,56 BYT 15,12 * * LINE # : 15 * BYT 33,46,141,53,61,60,103,0 POSITION CURSOR - 11 BYT 33,51,102,16 BYT 56,17 ASC 3, BYT 33,46,144,106,33,133 T0103 ASC 1, BYT 33,135,33,46,144,100 BYT 33,46,141,53,62,63,103,0 POSITION CURSOR - 43 BYT 33,46,144,106,33,133 T0104 ASC 1, BYT 33,135,33,46,144,100 ASC 3, BYT 40,16 ASC 2,. . BYT 17,40 &ASC 3, BYT 33,46,144,106,33,133 T0105 BYT 40,0 BYT 33,135,33,46,144,100 ASC 3, BYT 16,56 BYT 15,12 * * LINE # : 16 * BYT 33,46,141,53,61,60,103,0 POSITION CURSOR - 11 BYT 33,51,102,16 BYT 56,17 ASC 3, BYT 33,46,144,106,33,133 T0106 ASC 1, BYT 33,135,33,46,144,100 BYT 33,46,141,53,62,63,103,0 POSITION CURSOR - 43 BYT 33,46,144,106,33,133 T0107 ASC 1, BYT 33,135,33,46,144,100 ASC 3, BYT 40,16 ASC 2,. . BYT 17,40 ASC 3, BYT 33,46,144,106,33,133 T0108 BYT 40,0 BYT 33,135,33,46,144,100 ASC 3, BYT 16,56 BYT 15,12 * * LINE # : 17 * BYT 33,46,141,53,61,60,103,0 POSITION CURSOR - 11 BYT 33,51,102,16 BYT 56,17 ASC 3, BYT 33,46,144,106,33,133 T0109 ASC 1, BYT 33,135,33,46,144,100 BYT 33,46,141,53,62,63,103,0 POSITION CURSOR - 43 BYT 33,46,144,106,33,133 T0110 ASC 1, BYT 33,135,33,46,144,100 ASC 3, BYT 40,16 ASC 2,. . BYT 17,40 ASC 3, BYT 33,46,144,106,33,133 T0111 BYT 40,0 BYT 33,135,33,46,144,100 ASC 3, BYT 16,56 BYT 15,12 * * LINE # : 18 * BYT 33,46,141,53,61,60,103,0 POSITION CURSOR - 11 BYT 33,51,102,16 BYT 56,17 ASC 3, BYT 33,46,144,106,33,133 T0112 ASC 1, BYT 33,135,33,46,144,100 BYT 33,46,141,53,62,63,103,0 POSITION CURSOR - 43 BYT 33,46,144,106,33,133 T0113 ASC 1, BYT 33,135,33,46,144,100 ASC 3, BYT 40,16 ASC 2,. . BYT 17,40 ASC 3, BYT 33,46,144,106,33,133 T0114 BYT 40,0 BYT 33,135,33,46,144,100 ASC 3, BYT 16,56 BYT 15,12 * * LINE # : 19 * BYT 33,46,141,53,61,60,103,0 POSITION CURSOR - 11 BYT 33,51,102,16 BYT 56,17 ASC 3, BYT 33,46,144,106,33,133 T0115 ASC 1, BYT 33,135,33,46,144,100 BYT 33,46,141,53,62,63,103,0 POSITION CURSOR - 43 BYT 33,46,144,106,33,133 T0116 ASC 1, BYT 33,135,33,46,144,100 ASC 3, BYT 40,16 ASC 2,. . BYT 17,40 ASC 3, BYT 33,46,144,106,33,133 T0117 BYT 40,0 BYT 33,135,33,46,144,100 ASC 3, BYT 16,56 BYT 15,12 * * LINE # : 20 * BYT 33,46,141,53,61,60,103,0 POSITION CURSOR - 11 BYT 33,51,102,16 BYT 56,17 ASC 3, BYT 33,46,144,106,33,133 T0118 ASC 1, BYT 33,135,33,46,144,100 BYT 33,46,141,53,62,63,103,0 POSITION CURSOR - 43 BYT 33,46,144,106,33,133 T0119 ASC 1, BYT 33,135,33,46,144,100 ASC 3, BYT 40,16 ASC 2,. . BYT 17,40 ASC 3, BYT 33,46,144,106,33,133 T0120 BYT 40,0 BYT 33,135,33,46,144,100 ASC 3, BYT 16,56 BYT 15,12 * * LINE # : 21 * BYT 33,46,141,53,61,60,103,0 POSITION CURSOR - 11 BYT 33,51,102,16 BYT 56,17 ASC 3, BYT 33,46,144,106,33,133 T0121 ASC 1, BYT 33,135,33,46,144,100 BYT 33,46,141,53,62,63,103,0 POSITION CURSOR - 43 BYT 33,46,144,106,33,133 T0122 ASC 1, BYT 33,135,33,46,144,100 ASC 3, BYT 40,16 ASC 2,. . BYT 17,40 ASC 3, BYT 33,46,144,106,33,133 T0123 BYT 40,0 BYT 33,135,33,46,144,100 ASC 3, BYT 16,56 BYT 15,12 * * LINE # : 22 * BYT 33,46,141,53,61,60,103,0 POSITION CURSOR - 11 BYT 33,51,102,16 BYT 56,17 ASC 3, ASC 1, BYT 33,46,141,53,62,63,103,0 POSITION CURSOR - 43 ASC 1, ASC 3, BYT 40,16 ASC 2,. . BYT 17,40 ASC 3, BYT 40,0 ASC 3, BYT 16,56 BYT 15,12 * * LINE # : 23 *  BYT 33,46,141,53,61,60,103,0 POSITION CURSOR - 11 BYT 33,51,102,16 ASC 22,F,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,G ASC 8,F,,,,,,,,,,,,,,G BYT 15,12 * * LINE # : 24 * * BYT 40,33,127,137 FORMAT MODE ON,SUP. , SPC 1 LNG01 ABS *-ZAT01 SPC 2 * * SOURCE CHARACTER OFFSET ADRESS * SOF01 DEC 1 DEC 3 DEC 5 DEC 7 DEC 9 DEC 11 DEC 13 DEC 15 DEC 17 DEC 19 DEC 21 DEC 23 DEC 25 DEC 27 DEC 29 DEC 31 DEC 33 DEC 35 DEC 37 DEC 39 DEC 41 DEC 43 DEC 45 DEC 47 DEC 49 DEC -1 * * DESTINATION BUFFER ADRESS * DOF01 DEF T0100,I DEF T0101,I DEF T0102,I DEF T0103,I DEF T0104,I DEF T0105,I DEF T0106,I DEF T0107,I DEF T0108,I DEF T0109,I DEF T0110,I DEF T0111,I DEF T0112,I DEF T0113,I DEF T0114,I DEF T0115,I DEF T0116,I DEF T0117,I DEF T0118,I DEF T0119,I DEF T0120,I DEF T0121,I DEF T0122,I DEF T0123,I * * FORMAT OF NUMERIC DATA * DBL01 DEC 2 DEC 2 DEC 1 DEC 2 DEC 2 DEC 1 DEC 2 DEC 2 DEC 1 DEC 2 DEC 2 DEC 1 DEC 2 DEC 2 DEC 1 DEC 2 DEC 2 DEC 1 DEC 2 DEC 2 DEC 1 DEC 2 DEC 2 DEC 1 HED TMPGN SCREEN # 3 - USER MODULE DEFINITION * * SCREEN NUMBER: 3 * BDDRS BSS 1 MOINS ASC 1, - MASK OCT 77777 MUSK OCT 077600 CUPTN DEC -2 (DEC -2) SWAPP BSS 1 EXTNS BSS 1 SPC 2 SCR03 LDB IPARM+1 ADB D2 BRS ADB .NCRT STB BDDRS SAVE ADRESS OF EXTENSION NUMBER LDA 1,I STA EXTNS SAVE EXTENSION BIT AND MASK B@< STA 1,I CLEAR EXTENSION BIT FOR 'MOVCX' INB LDA 1,I STA SWAPP SAVE UPT # AND SWAP BIT AND MASK ADA CUPTN CHANGE UPT # !!! STA 1,I CLEAR BIT 15 FOR MOVCX JSB TMP# GET TMP COPY NUMBER STA U0300 AND STORE IT * JSB MOVCX DEF *+6 .NCRT DEF NCRTH DEF SOF03 DEF DOF03 DEF IPARM+1 DEF DBL03 * LDA BDDRS,I AND MUSK {1B LDB SPACE GET SPACE SZA EXTENSION NUMBER ? LDB MOINS YES, GET "-" STB U0001 SET GOOD WORD BETWEEN UPT# & EXTENSION # * LDB BDDRS LDA EXTNS RECALL EXTENSION WORD STA 1,I AND RESTORE TI INB LDA SWAPP RECALL UPT# AND SWAP BIT STA 1,I AND RESTORE IT * JSB EXEC DEF *+5 DEF D2 DEF LU DEF ZAT03 DEF LNG03 * LDA D5 RETURN TO SEG # 5 (T.U.S ANALYSIS) JMP RTRN SPC 2 * * LINE # : 1 * ZAT03 BYT 33,110,33,112 * * LINE # : 2 * * * LINE # : 3 * BYT 33,46,141,53,61,66,103,0 POSITION CURSOR - 17 ASC 22,ADDITION OF USER WRITTEN MODULES TO TMP COPY U0300 BYT 40,40 BYT 15,12 * * LINE # : 4 * BYT 15,12 * * LINE # : 5 * ASC 22, - The user written modules which are to be ASC 16, used when executing transaction BYT 15,12 * * LINE # : 6 * ASC 22, specifications under control of this cop ASC 15,y of TMP must be entered here. BYT 15,12 * * LINE # : 7 * ASC 22, They should be grouped into program unit ASC 14,s by the user in such a way BYT 15,12 * * LINE # : 8 * ASC 22, that memory partition usage will be opti ASC 16,mized. Any subroutine libraries BYT 15,12 * * LINE # : 9 * ASC 22, used by these modules must be specified ASC 7,at this time. BYT 15,12 * * LINE # : 10 * BYT 33,46,141,53,65,66,103,0 POSITION CURSOR - 57 BYT 33,51,102,16 ASC 11,R,,,,,,,,,,,,,,,,,,,,T BYT 15,12 * * LINE # : 11 * BYT 33,51,102,16 ASC 22,R,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ASC 6,,,,,,,,,,,,, BYT 66,17 ASC 07,PROGRAM UNIT# U0000 ASC 1, U0001 ASC 1, U0002 ASC 1, BYT 16,65 ASC 1,,T * * 4yLINE # : 12 * BYT 33,51,102,16 BYT 56,17 ASC 22, - Enter the name of the modules grouped in ASC 5,this unit: BYT 40,16 ASC 12,F,,,,,,,,,,,,,,,,,,,,G . * * LINE # : 13 * BYT 33,51,102,16 ASC 1,. BYT 33,46,141,53,67,67,103,0 POSITION CURSOR - 80 BYT 56,0 * * LINE # : 14 * BYT 33,51,102,16 BYT 56,17 ASC 3, BYT 33,46,144,102,33,133 T0300 ASC 2, BYT 40,0 BYT 33,135,33,46,144,100 BYT 33,46,141,53,61,60,103,0 POSITION CURSOR - 23 BYT 33,46,144,102,33,133 T0301 ASC 2, BYT 40,0 BYT 33,135,33,46,144,100 BYT 33,46,141,53,61,60,103,0 POSITION CURSOR - 38 BYT 33,46,144,102,33,133 T0302 ASC 2, BYT 40,0 BYT 33,135,33,46,144,100 BYT 33,46,141,53,61,60,103,0 POSITION CURSOR - 53 BYT 33,46,144,102,33,133 T0303 ASC 2, BYT 40,0 BYT 33,135,33,46,144,100 BYT 33,46,141,53,61,60,103,0 POSITION CURSOR - 68 BYT 33,46,144,102,33,133 T0304 ASC 2, BYT 40,0 BYT 33,135,33,46,144,100 ASC 3, BYT 40,16 BYT 56,0 * * LINE # : 15 * BYT 33,51,102,16 ASC 1,. BYT 33,46,141,53,67,67,103,0 POSITION CURSOR - 80 BYT 56,0 * * LINE # : 16 * BYT 33,51,102,16 BYT 56,17 ASC 3, BYT 33,46,144,102,33,133 T0305 ASC 2, BYT 40,0 BYT 33,135,33,46,144,100 BYT 33,46,141,53,61,60,103,0 POSITION CURSOR - 23 BYT 33,46,144,102,33,133 T0306 ASC 2, BYT 40,0 BYT 33,135,33,46,144,100 BYT 33,46,141,53,61,60,103,0 POSITION CURSOR - 38 BYT 33,46,144,102,33,133 T0307 ASC 2, BYT 40,0 BYT 33,135,33,46,144,100 BYT 33,46,141,53,61,60,103,0 POSITION CURSOR - 53 BYT 33,46,144,102,33,133 T0308 ASC 2, BYT 40,0 BYT 33,135,33,46,144,100 BYT 33,46,141,53,61,60,103,0 POSITION PCURSOR - 68 BYT 33,46,144,102,33,133 T0309 ASC 2, BYT 40,0 BYT 33,135,33,46,144,100 ASC 3, BYT 40,16 BYT 56,0 * * LINE # : 17 * BYT 33,51,102,16 ASC 1,. BYT 33,46,141,53,67,67,103,0 POSITION CURSOR - 80 BYT 56,0 * * LINE # : 18 * BYT 33,51,102,16 BYT 56,17 ASC 3, BYT 33,46,144,102,33,133 T0310 ASC 2, BYT 40,0 BYT 33,135,33,46,144,100 BYT 33,46,141,53,61,60,103,0 POSITION CURSOR - 23 BYT 33,46,144,102,33,133 T0311 ASC 2, BYT 40,0 BYT 33,135,33,46,144,100 BYT 33,46,141,53,61,60,103,0 POSITION CURSOR - 38 BYT 33,46,144,102,33,133 T0312 ASC 2, BYT 40,0 BYT 33,135,33,46,144,100 BYT 33,46,141,53,61,60,103,0 POSITION CURSOR - 53 BYT 33,46,144,102,33,133 T0313 ASC 2, BYT 40,0 BYT 33,135,33,46,144,100 BYT 33,46,141,53,61,60,103,0 POSITION CURSOR - 68 BYT 33,46,144,102,33,133 T0314 ASC 2, BYT 40,0 BYT 33,135,33,46,144,100 ASC 3, BYT 40,16 BYT 56,0 * * LINE # : 19 * BYT 33,51,102,16 ASC 1,. BYT 33,46,141,53,67,67,103,0 POSITION CURSOR - 80 BYT 56,0 * * LINE # : 20 * BYT 33,51,102,16 BYT 56,17 ASC 3, BYT 33,46,144,102,33,133 T0315 ASC 2, BYT 40,0 BYT 33,135,33,46,144,100 BYT 33,46,141,53,61,60,103,0 POSITION CURSOR - 23 BYT 33,46,144,102,33,133 T0316 ASC 2, BYT 40,0 BYT 33,135,33,46,144,100 BYT 33,46,141,53,61,60,103,0 POSITION CURSOR - 38 BYT 33,46,144,102,33,133 T0317 ASC 2, BYT 40,0 BYT 33,135,33,46,144,100 BYT 33,46,141,53,61,60,103,0 POSITION CURSOR - 53 BYT 33,46,144,102,33,133 T0318 ASC 2, BYT 40,0 BYT 33,135,33,46,144,100 BYT 33,46,141,53,61,60,103,0 POSITION CURSOR - 68 BYT 33,46,144,102,33,1033 T0319 ASC 2, BYT 40,0 BYT 33,135,33,46,144,100 ASC 3, BYT 40,16 BYT 56,0 * * LINE # : 21 * BYT 33,51,102,16 ASC 1,. BYT 33,46,141,53,67,67,103,0 POSITION CURSOR - 80 BYT 56,0 * * LINE # : 22 * BYT 33,51,102,16 BYT 56,17 ASC 22, - Enter the name of the subroutine librarie ASC 13,s used by these modules: BYT 33,46,141,53,70,103 POSITION CURSOR - 80 BYT 16,56 * * LINE # : 23 * BYT 33,51,102,16 ASC 1,. BYT 33,46,141,53,67,67,103,0 POSITION CURSOR - 80 BYT 56,0 * * LINE # : 24 * BYT 33,51,102,16 BYT 56,17 ASC 3, BYT 33,46,144,102,33,133 T0320 ASC 3, BYT 33,135,33,46,144,100 BYT 33,46,141,53,60,71,103,0 POSITION CURSOR - 23 BYT 33,46,144,102,33,133 T0321 ASC 3, BYT 33,135,33,46,144,100 BYT 33,46,141,53,60,71,103,0 POSITION CURSOR - 38 BYT 33,46,144,102,33,133 T0322 ASC 3, BYT 33,135,33,46,144,100 BYT 33,46,141,53,63,66,103,0 POSITION CURSOR - 80 BYT 16,56 BYT 33,51,102,16 ASC 22,F,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ASC 18,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,G BYT 17,00 * * BYT 40,33,127,137 SPC 1 LNG03 ABS *-ZAT03 SPC 2 * * SOURCE CHARACTER OFFSET ADRESS * SOF03 DEC 3 DEC 6 DEC 7 DEC 12 DEC 17 DEC 22 DEC 27 DEC 32 DEC 37 DEC 42 DEC 47 DEC 52 DEC 57 DEC 62 DEC 67 DEC 72 DEC 77 DEC 82 DEC 87 DEC 92 DEC 97 DEC 102 DEC 107 DEC 113 DEC 119 DEC 125 DEC -1 * * DESTINATION BUFFER ADRESS * DOF03 DEF U0002,I DEF U0000,I DEF T0300 DEF T0301 DEF T0302 DEF T0303 DEF T0304 DEF T0305 DEF T0@306 DEF T0307 DEF T0308 DEF T0309 DEF T0310 DEF T0311 DEF T0312 DEF T0313 DEF T0314 DEF T0315 DEF T0316 DEF T0317 DEF T0318 DEF T0319 DEF T0320 DEF T0321 DEF T0322 * * FORMAT OF NUMERIC DATA * DBL03 DEC 2 DEC 2 HED TMPGN SCREEN # 4 - DATA-BASE DEFINITION D4 DEC 4 SPC 2 SCR04 JSB MOVCX DEF *+6 DEF IRLOC DEF SOF04 DEF DOF04 DEF D0 DEF DBL04 * JSB TMP# RECALL TMP COPY NUMBER STA U0400 AND STORE IT IN THE SCREEN * JSB EXEC DEF *+5 DEF D2 DEF LU DEF ZAT04 DEF LNG04 LDA D4 RETURN TO SEG # 4 (IMAGE ANALYSIS) JMP RTRN SPC 2 * * LINE # : 1 * ZAT04 BYT 33,110,33,112 * ASC 22, DEFINITION OF THE LOGGING UNIT AND IMAGE ASC 15,DATA BASE ACCESSED BY TMP COPY U0400 BYT 40,40 BYT 15,12 * * LINE # : 2 * BYT 15,12 * * LINE # : 3 * ASC 22, - LU # of the mag tape allocated to loggin ASC 9,g (if any) ....... BYT 40,0 BYT 33,46,144,102,33,133 T0404 ASC 1, BYT 33,135,33,46,144,100 BYT 15,12 * * LINE # : 4 * BYT 15,12 * * LINE # : 5 * ASC 22, - Each executing copy of TMP may access on ASC 16,e and only one IMAGE data base. BYT 15,12 * * LINE # : 6 * ASC 22, - The same data base may be accessed simul ASC 18,taneously by different copies of TMP * * LINE # : 7 * ASC 22, - The information on the data base is prov ASC 16,ided by the IMAGE software when BYT 15,12 * * LINE # : 8 * ASC 22, the data base is created. (Refer to appr ASC 18,opriate data base schema listing.) BYT 15,12 * * LINE # : 9 * BYT 33,51,102,16 ASC 5, R,,, BYT 40,17 ASC 22,Definition of the data base to be accessed b ASC 7,y this TMP cop BYT 171,16 ASC 2, ,,T BYT 15,12 * * LINE # : 10 * BYT 33,51,102,16 ASC 4, . BYT 33,46,141,53,66,65,103,0 POSITION CURSOR - 74 BYT 56,0 BYT 15,12 * * LINE # : 11 * BYT 33,51,102,16 ASC 3, BYT 56,17 ASC 22, Data base name .................... ASC 4,........ BYT 40,0 BYT 33,46,144,102,33,133 T0400 ASC 2, BYT 40,0 BYT 33,135,33,46,144,100 BYT 33,46,141,53,60,70,103,0 POSITION CURSOR - 74 BYT 16,56 BYT 15,12 * * LINE # : 13 * BYT 33,51,102,16 ASC 4, . BYT 33,46,141,53,66,65,103,0 POSITION CURSOR - 74 BYT 56,0 BYT 15,12 * * LINE # : 14 * BYT 33,51,102,16 ASC 3, BYT 56,17 ASC 22, Data base highest level access word ASC 4,....... BYT 33,46,144,102,33,133 T0401 ASC 3, BYT 33,135,33,46,144,100 BYT 33,46,141,53,60,70,103,0 POSITION CURSOR - 74 BYT 16,56 BYT 15,12 * * LINE # : 15 * BYT 33,51,102,16 ASC 4, . BYT 33,46,141,53,66,65,103,0 POSITION CURSOR - 74 BYT 56,0 BYT 15,12 * * LINE # : 16 * BYT 33,51,102,16 ASC 3, BYT 56,17 ASC 22, Data base security code ............. ASC 4,........ BYT 40,0 BYT 33,46,144,102,33,133 T0402 ASC 2, BYT 40,0 BYT 33,135,33,46,144,100 BYT 33,46,141,53,60,70,103,0 POSITION CURSOR - 74 BYT 16,56 BYT 15,12 * * LINE # : 17 * ASC 3, BYT 33,51,102,16 ASC 22,F,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ASC 12,,,,,,,,,,,,,,,,,,,,,,,,G BYT 15,12 * * LINE # : 18 * ASC 3, BYT 33,51,102,16 ASC 4,R,,,,,,, BY!T 17,40 ASC 22,If access is to be shared with other TMP cop ASC 2,ies BYT 16,54 ASC 5,,,,,,,,,,t BYT 15,12 * * LINE # : 20 * BYT 33,51,102,16 ASC 4, . BYT 33,46,141,53,66,65,103,0 POSITION CURSOR - 74 BYT 56,0 BYT 15,12 * * LINE # : 21 * ASC 3, BYT 33,51,102,16 BYT 56,17 ASC 22, Enter the number of one of the TMP co ASC 5,pies which BYT 33,46,141,53,61,62,103,0 POSITION CURSOR - 74 BYT 16,56 BYT 15,12 * * LINE # : 22 * ASC 3, BYT 33,51,102,16 BYT 56,17 ASC 22, accesses the same data base ......... ASC 6,............ BYT 40,0 BYT 33,46,144,102,33,133 T0403 BYT 40,0 BYT 33,135,33,46,144,100 BYT 33,46,141,53,60,70,103,0 POSITION CURSOR - 74 BYT 16,56 BYT 15,12 * * LINE # : 23 * BYT 33,51,102,16 ASC 22, F,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ASC 15,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,G * * LINE # : 24 * BYT 40,33,127,137 SPC 1 LNG04 ABS *-ZAT04 SPC 2 * * SOURCE CHARACTER OFFSET * SOF04 DEC 1 DEC 3 DEC 8 DEC 14 DEC 16 DEC 17 DEC -1 * * DESTINATION BUFFER ADRESS * DOF04 DEF T0404,I DEF T0400 DEF T0401 DEF T0402,I DEF T0403 * * FORMAT OF NUMERIC DATA * DBL04 DEC 2 DEC 5 HED TMPGN SCREEN # 8 - SOFT-KEY MAP (DO NOT RETURN) MASK8 OCT 177 ABORT OCT 141 LOWER CASE "A" (ABORT REQUEST CODE) B40 OCT 40 SPC 2 SCR08 JSB EXEC DEF *+5 DEF D2 DEF LU DEF ZAT08 DEF LNG08 * CLA STA NCRTH * JSB GETBK DEF *+4 DEF LU DEF NCRTH DEF D2 * SZA READ OK ? JMP TMPG3 NO, RE-ISSUE THE SAME SCREEN * LDA NCRTH ALF,ALF ٧ AND MASK8 CPA B40 IS IT SPACE ? JMP SC82X YES GOTO SCREEN # 0 CPA ABORT IS IT ABORT REQUEST RSS YES, JUMP TO ABORT TMPGN JMP TMPG3 NO, RE-ISSUE THE KEY MAP. * LDA D2 SET ABORT FLAG STA IPARM+2 JMP SCR0Z AND RETURN TO SEG#0 (MONITOR) SPC 1 SC82X CLA SET SCREEN # TO 0 STA IPARM JMP TMPG3 AND START FROM BEGINNING SPC 2 ZAT08 BYT 33,46 ASC 10,s0a0b0c1d0e0f1g1h0j0 BYT 113,00 * * SET UP SOFT KEY ON THE 2645/2648 TERMINAL * BYT 33,46,146,61,141,61,153,61,114,11 NEXT FIELD BYT 33,46,146,61,141,62,153,62,114,33,151,40 PREVIOUS FIELD BYT 33,46,146,61,141,63,153,61,114,40 NOT USED BYT 33,46,146,62,141,64,153,61,114,141 ABORT BYT 33,46,146,61,141,65,153,64,114,33,110,33,144,40 NEXT SCREEN BYT 33,46,146,61,141,66,153,65,114,163,33,110,33,144 PREV.SCREEN BYT 33,46,146,61,141,67,153,61,114,40 NOT USED BYT 33,46,146,61,141,70,153,65,114,151,33,110,33,144 INSERT * BYT 33,110,33,112 HOME UP CURSOR, CLEAR DISPLAY * * LINE # : 1 * BYT 33,133 ASC 1, BYT 33,135 BYT 33,46,141,53,61,64,103,0 POSITION CURSOR - 17 BYT 33,46,144,106 ASC 22, TRANSACTION MONITOR PROGRAM GENERATOR READY ASC 1, ! BYT 15,12 * * LINE # : 2 * BYT 15,12 * * LINE # : 3 * BYT 33,46,141,53,61,60,103,0 POSITION CURSOR - 11 ASC 22,Please, set in place the following label on ASC 9,the soft keys pad. BYT 15,12 * * LINE # : 4 * BYT 15,12 * * LINE # : 5 * BYT 33,51,102,16 BYT 33,46,141,53,61,64,103,0 POSITION CURSOR - 15 ASC 22,R,,,,,,,,,,,TR,,,,,,,,,,,TR,,,,,,,,,,,TR,,,, ASC 4,,,,,,,,T BYT 15,12 * * LINE # : 6 * BYT 33,46,141,53,61,64,103,0 POSITION CURSOR - 15 BYT 33,51,102,16 BYT 56,17 ASC 5,Next Field BYT 40,16 ASC 1,.. BYT 40,17 ASC 5, Previous BYT 16,56 ASC 1,. BYT 17,40 BYT 33,46,141,53,60,70,103,0 POSITION CURSOR - 52 BYT 16,40 ASC 1,.. BYT 17,40 ASC 5, Abort BYT 16,56 BYT 15,12 * * LINE # : 7 * BYT 33,46,141,53,61,64,103,0 POSITION CURSOR - 15 BYT 33,51,102,16 BYT 56,0 BYT 33,46,144,112 ASC 2, BYT 17,146 ASC 3,1 BYT 33,46,144,100,16,56 BYT 56,0 BYT 33,46,144,112 ASC 2, BYT 40,17 ASC 3,f2 BYT 33,46,144,100,16,56 BYT 56,0 BYT 33,46,144,112,17,40 ASC 5, f3 BYT 33,46,144,100,16,56 BYT 56,0 BYT 33,46,144,112,17,40 ASC 5, f4 BYT 33,46,144,100,16,56 BYT 15,12 * * LINE # : 8 * BYT 33,46,141,53,61,64,103,0 POSITION CURSOR - 15 BYT 33,51,102,16 BYT 56,17 ASC 5, (TAB) BYT 40,16 ASC 1,.. BYT 17,40 ASC 5, Field BYT 16,56 ASC 2,. BYT 17,40 ASC 3, BYT 40,16 ASC 1,.. BYT 17,40 ASC 5, Program BYT 16,56 BYT 15,12 * * LINE # : 9 * BYT 33,46,141,53,61,64,103,0 POSITION CURSOR - 15 BYT 33,51,102,16 ASC 22,F,,,,,,,,,,,GF,,,,,,,,,,,GF,,,,,,,,,,,GF,,,, ASC 4,,,,,,,,G BYT 15,12 * * LINE # : 10 * BYT 33,51,102,16 BYT 33,46,141,53,61,64,103,0 POSITION CURSOR - 15 ASC 22,R,,,,,,,,,,,TR,,,,,,,,,,,TR,,,,,,,,,,,TR,,,, ASC 4,,,,,,,,T BYT 15,12 * * LINE # : 11 * BYT 33,46,141,53,61,64,103,0 POSITION CURSOR - 15 BYT 33,51,102,16 BYT 56,17 ASC 5,Next Scree BYT 156,16 ASC 1,.. BYT 40,17 ASC 4, Previou  BYT 163,16 ASC 2, .. BYT 17,40 BYT 33,46,141,53,60,70,103,0 POSITION CURSOR - 52 BYT 16,40 ASC 2,.. BYT 17,111 ASC 3,nsert BYT 141,16 ASC 1, . BYT 15,12 * * LINE # : 12 * BYT 33,46,141,53,61,64,103,0 POSITION CURSOR - 15 BYT 33,51,102,16 BYT 56,0 BYT 33,46,144,112 ASC 2, BYT 17,146 ASC 3,5 BYT 33,46,144,100,16,56 BYT 56,0 BYT 33,46,144,112 ASC 2, BYT 40,17 ASC 3,f6 BYT 33,46,144,100,16,56 BYT 56,0 BYT 33,46,144,112,17,40 ASC 5, f7 BYT 33,46,144,100,16,56 BYT 56,0 BYT 33,46,144,112,17,40 ASC 5, f8 BYT 33,46,144,100,16,56 BYT 15,12 * * LINE # : 13 * BYT 33,46,141,53,61,64,103,0 POSITION CURSOR - 15 BYT 33,51,102,16 BYT 56,17 ASC 5, (ENTER) BYT 40,16 ASC 1,.. BYT 40,17 ASC 4, Screen BYT 40,16 ASC 2, .. BYT 17,40 BYT 33,46,141,53,60,71,103,0 POSITION CURSOR - 53 BYT 16,56 BYT 56,17 ASC 5,User Modul BYT 145,16 BYT 56,0 BYT 15,12 * * LINE # : 14 * BYT 33,46,141,53,61,64,103,0 POSITION CURSOR - 15 BYT 33,51,102,16 ASC 22,F,,,,,,,,,,,GF,,,,,,,,,,,GF,,,,,,,,,,,GF,,,, ASC 4,,,,,,,,G BYT 15,12 * * LINE # : 15 * BYT 15,12 * * LINE # : 16 * BYT 15,12 * * LINE # : 17 * BYT 15,12 * * LINE # : 18 * ASC 22, - During execution of this program, onc ASC 15,e all correct answers have bee BYT 156,0 BYT 15,12 * * LINE # : 19 * ASC 22, provided for a given screen, press th ASC 15,e NEXT SCREEN key to continue. BYT 15,12 * * LINE # : 20 * BYT 15,12 * * LINE # : 21 * BYB@, SPC 1 LNG08 ABS *-ZAT08 SPC 2 END TMPG3 A+B # 92903-18456 1805 S C0122 &TMPG4              H0101 FTN4 PROGRAM TMPG4(5),92903-16456 REV.1805 780517 C C C C ************************************************************** C * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * C ************************************************************** C C C C NAME: TMPG4 C SOURCE: &TMPG4 92903-18456 C RELOC: %TMPG4 92903-16456 C C PGMR: DANIEL POT/FRANCOIS GAULLIER HPG C C *********************************************** C * THIS PROGRAM HANDLES SCREEN # 4 AND 5 * C * THROUGH AN INTERACTIVE PROCESS. * C *********************************************** C C STOP USED: 4000 - 4010 C ---------- C C C IJOB = 2 THE SCREEN HAS BEEN PRINT, READ AND ANALYSE ANSWER C IJOB = DO IMAGE & MAIN PROG DEFINITION C C IEND = 0 : CURRENT INTERACTIVE PROCESS C IEND = 1 : END OF INTERACTIVE PROCESS C IEND = 2 : ABORT TMPGN PROGRAM C IEND = 3 : PREVIOUS FAMILY SCREEN C COMMON LU,LUPRT,NCRTH(2400),IRLOC(70),ITRSF(20),IRQFLG(30) COMMON IMOTR(18),ISCRN,IOFST,IEND,IJOB C DIMENSION NAME(3),IPOB(3),IDCB(144),IBUFR(30) DIMENSION IAPLT(3),KBUFR(44),LNFLD(5) C LOGICAL JPAR,KPAR,CMPW,PSFLG,GETBK,OKABT,STUSP LOGICAL IMBED,ISBTW INTEGER OPEN,PURGE C DATA IAPLT/2H&T,2HMP,2H /,LNFLD/2,5,6/ DATA MAXCOP/3/ C KPAR(IX1,IX2,IX3)=JPAR(IRLOC,LENGH,I,IX1,IX2,IFLG,IX3) C C C JOB ? C IF(IJOB.EQ.2) GOTO 220 IF(IJOB.NE.0) STOP 4000 C C ***************************************************************** C * * C * DATA-BASE DEFINITION: * C * " * C ***************************************************************** C C DISPLAY SCREEN # 4 C 10 ISCRN=4 IRLOC=NCRTH(21) CALL MOVEW(NCRTH(32),IRLOC(2),3) CALL MOVCA(NCRTH(35),1,IRLOC,8,8) CALL PUTCA(IRLOC,1H ,16) I=IGET1(NCRTH,81) IF(I .EQ. 1H ) GOTO 210 IF(I .EQ. IGET1(NCRTH,12)) GOTO 210 C-----IT IS FROM AN OTHER COPY CALL NUL(IRLOC(7),2) CALL BLAN(IRLOC,3,11) CALL PUTCA(IRLOC,I,16) GOTO 210 C C PROCESS SCREEN # 4 C 20 PSFLG=.FALSE. C C LOGGING LU ANALYSIS C 22 I=1 J=29 IPOB=0 IF( KPAR(IBUFR,2,IPOB) ) GOTO 200 IF(IFLG .EQ. 0) GOTO 24 NUERO=2 IF(IFLG .NE. 1) GOTO 400 NUERO=44 IF(ISBTW(IPOB,1,IGET(1653B)) ) GOTO 400 NUERO=9 IEQT=IAND(IGET(IGET(1652B)+IPOB-1),77B) IF(IEQT .EQ. 0) GOTO 400 IF(IAND(IGET(IGET(1650B)+((IEQT-1)*15)+4),37400B)/256 . .NE. 23B) GOTO 400 24 NCRTH(21)=IPOB C C DATA BASE NAME & LEVEL ACCESS WORD ANALYSIS C 28 I=I+1 IF(I .GE. 4) GOTO 36 J=J+3 26 IF( KPAR(IBUFR,LNFLD(I),IPOB) ) GOTO 200 NUERO=18 IF( .NOT. (IFLG.EQ.0.OR.IFLG.EQ.3) ) GOTO 400 IF(IMBED(IBUFR,1,LNFLD(I))) GOTO 400 CALL ISUPB(IBUFR,3) 31 NUERO=39 IF(NCRTH(32).EQ.2H .AND.I.NE.2.AND.IFLG.NE.0) GOTO 400 CALL MOVEW(IBUFR,NCRTH(J),3) GOTO 28 C C DATA BASE SECURITY CODE C 36 IBUFR=0 IF( KPAR(IPOB,5,IBUFR) ) GOTO 200 NUERO=6 IF( .NOT. (IFLG.EQ.0.OR.IFLG.EQ.1) ) GOTO 400 IF(NCRTH(32).EQ.2H .AND. IFLG.NE.0) GOTO 31 IF(IBUFR .LT. 0) GOTO 400 NCRTH(38)=IBUFR C C USE AN OTHER COPY ? C 42 I=5 ICOPY=IGET1(NCRTH,12) IF( KPAR(IPOB,1,ICOPY) ) GOTO 200 IF(IFLG .NE. 0) GOTO 95 IF(NCRTH(32) .EQ. 2H ) GOTO 100 C C THE DATA BASE IS DEFIN?ED BY NAME,... OPEN IT C TO VERIFY SECURITY CODE AND HIGHEST LEVEL ACCESS WORD C CALL DBINT(NCRTH(32),NCRTH(38),0,IPOB) IF(IPOB .NE. 0) GOTO 78 CALL MOVEW(NCRTH(35),KBUFR,3) CALL DBOPN(NCRTH(32),KBUFR,NCRTH(38),1,IPOB) IF(IPOB .NE. 0) GOTO 75 IF(IPOB(2) .NE. 15) IPOB=10000 75 CALL DBCLS(0,ISTAT) IF(IPOB .EQ. 0) GOTO 82 78 IFLD=2 NUERO=0 IF(IPOB .EQ. 128) NUERO=25 IF(IPOB .EQ. 129) NUERO=26 IF(IPOB .EQ. 119) NUERO=27 IF(IPOB .EQ. 116) NUERO=27 IF(IPOB .EQ. 6) NUERO=27 IF(NUERO .NE. 0) GOTO 410 IFLD=3 IF(IPOB .EQ. 10000) NUERO=28 IF(NUERO .NE. 0) GOTO 410 IFLD=4 IF(IPOB .EQ. 117) NUERO=29 IF(NUERO .NE. 0) GOTO 410 CALL JASC(IPOB,IDCB,1,6) CALL TMPGE(30,2,IDCB(2)) GOTO 220 82 IF(ISTAT .EQ. 0) GOTO 100 IPOB=ISTAT GOTO 78 C C THE DATA BASE IS FROM AN OTHER TMP COPY C 95 NUERO=7 IF(IFLG.NE.1 .OR. ISBTW(ICOPY,1,MAXCOP)) GOTO 400 NUERO=39 IF(NCRTH(32).NE.2H ) GOTO 400 ICOPY=(ICOPY+60B)*256+40B IF(ICOPY .EQ. IGET1(NCRTH,12)) GOTO 400 CALL PUTCA(IAPLT,ICOPY,5) C C LOOK FOR TMS-IMAGE PROGRAM NAME IN THE OTHER APPLICATION C IF(OPEN(IDCB,IERR,IAPLT,1,NCRTH(22),NCRTH(23)).EQ.31) GOTO 97 CALL CLOSE(IDCB) IF(OPEN(IDCB,IERR,IAPLT,1,0,0).EQ.31) GOTO 97 CALL CLOSE(IDCB) NUERO=4 GOTO 400 97 IF(READF(IDCB,IERR,KBUFR,42,LEN).LT.0) STOP 5000 CALL CLOSE(IDCB) NUERO=36 IF(KBUFR(32).EQ.2H ) GOTO 400 NUERO=38 IF(.NOT. CMPW(KBUFR(39),4HITMP,2) ) GOTO 400 ICOPY=IGET1(KBUFR(41),1) CALL MOVEW(KBUFR(32),NCRTH(32),7) C C IMAGE DEFINED FOR THE CURRENT TMP COPY ? C 100 CALL BLANC(NCRTH(39),3) CALL NUL(NCRTH(47),3) IF(NCRTH(32) .EQ. 2H ) GOTO 150 CALL MOVEW(6HITMP ,NCRTH(39),3) CALL PUTCA(NCRTH,ICOPY,8}1) C-----SET LOCK TABLE SIZE NCRTH(49)=4096 150 IF( PSFLG ) GOTO 215 C-----END OF INTERACTIVE PROCESS, RETURN TO MONITOR (SEG# 0) CALL TMGSC(0,0,0,1,2) C C C PRINT SCREEN C 210 CALL TMGSC(3,ISCRN,IOFST,IEND,2) C C READ FROM THE 2645 TERMINAL C 220 LENGH=0 IF(ISCRN.EQ.4) LENGH=23 IF(LENGH.EQ.0) STOP 4010 C IF(.NOT.GETBK(LU,IRLOC,LENGH)) GOTO 300 C C RE-DISPATCH AFTER AN HARD ERROR, RE-ISSUE THE SCREEN C 310 IF(ISCRN.EQ.4) GOTO 10 C C DISPATCH TO SCREEN ANALYSIS PART C 300 IF(ISCRN.EQ.4) GOTO 22 C C ABORT OR PREVIOUS SCREEN COMMAND C 200 IF(IFLG .EQ. 8) GOTO 212 NUERO=34 IF(IFLG .NE. 9) GOTO 400 C-----USER WANTS TO ABORT ? IF( .NOT. OKABT(LU)) GOTO 310 C-----YES, OPERATOR WANTS TO ABORT CALL TMGSC(0,0,0,2) C-----EXECUTE THE PREVIOUS SCREEN COMMAND 212 IF(.NOT. PSFLG) IPS=IFLD PSFLG=.TRUE. IF(ISCRN.EQ.4) GOTO (28,28,28,42,215),I C 215 IF(ISCRN.NE.4) GOTO 10 IF(IMOTR.NE.1) GOTO 240 C-----GO TO PREVIOUS SCREEN (SCREEN#3, DEFINITION OF TUS) CALL TMGSC(5,0,0,0,3) C 240 NUERO=34 IFLD=IPS GOTO 440 C C ERROR MESSAGE C 400 IFLD=I 410 IF( PSFLG ) GOTO 212 440 CALL TMPGE(NUERO,IFLD,IASC(IGET(1653B))) GOTO 220 C C DUMMY CALL TO MAIN !! C 7777 CALL TMPGN END END$ @J  92903-18457 1805 S C0122 &TMPG5              H0101 FTN4 PROGRAM TMPG5(5),92903-16457 REV.1805 780515 C C C C ************************************************************** C * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * C ************************************************************** C C C C NAME: TMPG5,ILPRS C SOURCE: &TMPG5 92903-18457 C BINARY: %TMPG5 92903-16457 C C PGMR: DANIEL POT/FRANCOIS GAULLIER HPG C C C *********************************************** C * THIS PROGRAM HANDLES INTERACTIVE AND AUXI- * C * LIARY LOGICAL UNITS THROUGH AN INTERACTIVE * C * PROCESS. * C *********************************************** C C STOP USED: 5000 - 5002 - 5003 C ---------- C C IJOB = 2 SCREEN HAS BEEN PRINT, READ AND ANALYSE C IJOB = 3 DO ALL T.U.S. DEFINITION INTO USER PARTITION C IJOB = 0 DO ALL (LU INT. & AUX. AND T.U.S.) DEFINITION C C IEND = 0 : CURRENT INTERACTIVE PROCESS C IEND = 1 : END OF INTERACTIVE PROCESS C IEND = 2 : ABORT TMPGN PROGRAM C IEND = 3 : PREVIOUS FAMILY SCREEN C COMMON LU,LUPRT,NCRTH(2100),IEXFL,IPTR,IXXXX(298) COMMON IRLOC(90),IRQFLG(30),IMOTR(9),IVASC0(9),IPARAM(5) C LOGICAL GETBK,TMPRS LOGICAL IEXFL C EQUIVALENCE (ISCRN,IPARAM(1)),(IOFST,IPARAM(2)) ., (IEND,IPARAM(3)),(IJOB,IPARAM(4)) C C CURRENT JOB ON PROCESS C IF(IJOB.EQ.2) GOTO 90 IF(IJOB.EQ.3) GOTO 40 IF(IJOB.NE.0) STOP 5000 C C INTERACTIVE LOGICAL UNIT (HP 3070 DEVICE) C 10 ISCRN=1 CALL ILPRS(IOFST,IEND) IF(IEND.EQ.3) GOTO 65 IF(IEND.NE.1) GOTO 60 IOFST=0 C IF(IMOTR .NE. 1) GOTO 75 C C TMS-SUBROUTINES AND LIBR1ARIES (USER WRITTEN MODULES) C 40 ISCRN=3 IF( TMPRS(IOFST,LENGH,3,IEND,IFLD) ) GOTO 85 IF(IEND.EQ.1) GOTO 100 IF(IEND.NE.3) GOTO 60 C-----PREVIOUS SCREEN OK ? IF(IMOTR .NE. 1) GOTO 65 IOFST=0 GOTO 10 C C RETURN FROM ILPRS, TMPRS C 60 IF(IEND.EQ.0) GOTO 70 IF(IEND.EQ.2.OR.IEND.EQ.1) GOTO 80 STOP 5002 C C PREVIOUS SCREEN NEED TO ACTUALLY CHANGE THE SCREEN, C IF NOT ALLOWED, RE-ISSUE THE SAME ONE AND PRINT ERROR ! C 65 IEND=-33 C C INTERACTIVE PROCESS, PRINT THE SCREEN. C 70 CALL TMGSC(3,ISCRN,IOFST,IEND,2) C C END OF INTERACTIVE PROCESS, ABORT OR PARTIAL PROCESS C 75 IEND=1 80 CALL TMGSC(0,0,0,IEND,IJOB) C C ERROR PROCESSING: C 84 IEND=-IEND IFLD=1 85 CALL TMPGE(IEND,IFLD) C C SET UP INPUT LENGTH C 90 LENGH=0 IF(IEND .LT. 0) GOTO 84 IF(ISCRN.EQ.1) LENGH=63 IF(ISCRN.EQ.3) LENGH=140 IF(LENGH.EQ.0) STOP 5003 C C WAIT FOR INPUT FROM THE 2645 C 95 IF(GETBK(LU,IRLOC,LENGH)) GOTO 70 C C DISPATCH TO ANALYSIS CODE C IF(ISCRN .EQ. 1) GOTO 10 IF(ISCRN .EQ. 3) GOTO 40 C C INTERACTIVE PROCESS: CONTINUED WITH IMAGE & MAIN DEFINITION C 100 IF(IMOTR .NE. 1) GOTO 75 ISCRN=0 IOFST=0 IJOB=0 CALL TMGSC(4,ISCRN,IOFST,IEND,IJOB) C C DUMMY CALL TO MAIN !! C CALL TMPGN END SUBROUTINE ILPRS(IOFST,IEND),92903-16457 REV.1805 780515 C C C *************************************************** C * * C * THIS SUBROUTINE PROCESS SCREEN NUMBER 1 CONTENT * C * BEFORE TRANLATING IT IN TABLE "NCRTH". * C * * C * IF IOFST=0 : INITIALISATION TAKE PLACE * C * * C * IF IOFST#0 : PENDING SCREEN IS PROCESSED AND A * ] C * MESSAGE CAN BE SENT TO POINT AT AN ERROR. * C * * C * WHEN A SCREEN IS RECEIVED, UNCOMPLETELY FILLED, * C * AND IS GOOD, IT IS CONSIDERED AS THE LAST ONE * C * OF THE SCREEN NUMBER ONE FAMILY AND NCRTH(2000) * C * IS DECONTRACTED IN THE STANDARD FORMAT INTO THE * C * NCRTH(45) INITIAL TABLE AND IEND IS SET TO "1". * C * IF ABORT KEY WAS DEPRESSED IEND IS SET TO "2". * C * IF PREVIOUS SCREEN KEY WAS USED, TO GO BACK * C * BEFORE THIS SCREEN, IEND IS SET TO "3" * C * * C *************************************************** C COMMON LU,LUPRT,NCRTH(2400),IRLOC(70) DIMENSION NAME(3),IBUFR(192),IPOB(3) LOGICAL JPAR,ISBTW,OKABT,GETBK C C IDECL=3998 ISZSC=48 ILONG=64 IREFC=50 ILUGH=128 IF(IOFST.NE.0) GOTO 30 C C FIRST TIME ILPRS IS CALLED C IEND=0 CALL CTILU IOFST=IDECL CALL NUL(IBUFR,24) RETURN C C INTERACTIVE LU# PHASE IS PROCESSING C 30 CALL NUL(IBUFR,24) IFIN=0 IPRVS=0 C C ACQUISITION C DO 90 I=1,(ISZSC/2)-2,3 J=I IF(JPAR(IRLOC,ILONG,I,IPOB,2,IFLG,IBUFR(I))) GOTO 200 IFLG1=IFLG IBUFR(I+1)=0 IF(JPAR(IRLOC,ILONG,I+1,IPOB,2,IFLG,IBUFR(I+1))) GOTO 200 IFLG2=IFLG IBUFR(I+2)=2H IF(JPAR(IRLOC,ILONG,I+2,IBUFR(I+2),1,IFLG,IPOB)) GOTO 200 IFLG3=IFLG IF(IFLG1+IFLG2+IFLG3.NE.0) GOTO 35 C C CHECK FOR PREVIOUS SCREEN OR ABORT COMMAND C IBUFR(I)=0 IBUFR(I+1)=0 IBUFR(I+2)=2H IF(J.NE.(ISZSC/2)-2) J=J+3 DO 33 II=J,(ISZSC/2)-2,3 IF(JPAR(IRLOC,ILONG,II,IPOB,2,IFLG,IBUFR(II))) GOTO 34 IF(JPAR(IRLOC,ILONG,II+1,IPOB,2,IFLG,IBUFR(II+1))) GOTO 34 IBUFR(II+2)=2H IF(JPAR(IRLOC,ILONG,II+2,IBUFR(II+2),1,IFLG,IPOB)) GOTO 34 33 CONTINUE C IF(I.NE.1.OR.IOFST.NE.IDECL) GOTO 3033 J=1 CALL TMPGE(43,J) GOTO 110 3033 IFIN=1 CALL NUL(IBUFR(J),24-J) CALL MOVEW(IBUFR,NCRTH((IOFST+2)/2),ISZSC/2) IOFST=IOFST+ISZSC GOTO 92 C C ABORT OR PREVIOUS SCREEN ( WITH INPUT ) C 34 IPRVS=0 IF(IFLG.NE.8) GOTO 330 CALL NUL(IBUFR(J),24-J) IPRVS=1 GOTO 92 C C CHECK DEFINED LU, 1],1,21B) C C-----READ 'TS# [ -SC ]' FROM INTERACTIVE TERMINAL C ITT=1 150 CALL TMRD(TEMPB,-12) EDITPT=0 ERRFL=1 K=LIGNUM LIGNUM=IAND(IST,17B)-1 IF( ISBIT(IST,7) ) GOTO 100 C-----TIME-OUT RETURN IS COMPLETION CODE = 1 IF(LIGNUM .EQ. 0) GOTO 50 IF(LIGNUM.GT.0 .AND. ITL.NE.0) GOTO 220 IF(LIGNUM.GT.0) GOTO 300 IF(ITL .EQ. 0) GOTO 200 LIGNUM=K IF (ITT .EQ. 0) GOTO 190 DO 170 ITT=1,ITL IF(IGET1(TEMPB,ITT) .EQ. 1H-) GOTO 175 170 CONTINUE 175 IF( INUM(TEMPB,1,ITT-1,LIGNUM) ) GOTO 220 IF( ISBTW(LIGNUM,0,9999) ) GOTO 220 IF(ITT-1 .GE. ITL) GOTO 300 190 IF( INUM(TEMPB,ITT+1,ITL-ITT,EDITPT) ) GOTO 220 GOTO 300 C C-----PRINT LU/ERROR ON THE TERMINAL C 200 EDITPT=LU ERRFL=0 220 CALL CNUMD(EDITPT,TEMPB) TEMPB=LIGHT(LITERR,ERRFL) IF(ERRFL .NE. 0)7 TEMPB(2)=2HE L=3 IF(EDITPT .EQ. 0) L=1 IF( XERPRT(I) ) L=1 CALL TMBCT(0) CALL TMBWR(2H=_,1,21B) CALL TMWR(TEMPB,L) IF(EDITPT .NE. 1) GOTO 105 C C-----SETUP TO READ SECURITY CODE ONLY (WITHOUT ECHO) C UNL DISPLAY, LISN MOD-COM & TALKER KEYBOARD C CALL TMBWR(4H?>] ,-3,21B) ITT=0 GOTO 150 C C------INVOKE T-M SUBROUTINE "TSMG" TO OPEN THIS FORM C 300 ASSIGN 350 TO I CALL TMCBE(I,FORMN) SQUAL=10 FORMN=LIGNUM STATE=EDITPT CALL TMSUB(TSMG) 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 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 C CALL LOGEV(ICOM00(2),LU,0,0,FORMN,0,0) C-----ENABLE 2ND COMMON BLOCK ASSIGN 340 TO I CALL TMCBE(I,NUQ) C-----RESET THE HP 3070 CALL TMBCT(0) CALL TMBCT(22B) CALL TMCTL(14B) C-----INIT FORM PROCESSOR CONSTANTS IOBUF(2)=2H!! NUQ=IRS8(STATE(6)) NMQ=IAND(STATE(6),377B) L1=STATE(7) L2=STATE(8) ITT=STATE(9) ERRFL=1 C-----CHECK FOR SFK11/CARD-READER/PRINTER USE EDITPT=10 IF( .NOT. ISBIT(ITT,12) ) GOTO 2001 IF( .NOT. ISBIT(ITYP,0) ) GOTO 4233 2001 IF( .NOT. ISBIT(ITT,15) ) GOTO 2003 IF( .NOT. ISBIT(ITYP,2) ) GOTO 4233 2003 IF( .NOT. ISBIT(ITT,14) ) GOTO 2004 IF( .NOT. ISBIT(ITYP,1) ) GOTO 4233 C SET UP PRINTER CALL CNUMD(FORMN,PRTBUF(6)) c CALL TMWR(PRTBUF,12,10B) CALL TMBWR(2H? ,-1,21B) 2004 ASSIGN 4233 TO I EDITPT=40 IF( ISBIT(ITT,0) ) CALL TMCBE(I,IUSER) ASSIGN 4231 TO I IF( ISBIT(ITT,1) ) CALL TMCBE(I,IMGBUF) C-----INIT FORM PROCESSOR VARIABLES BEGNFL=.TRUE. ENDCHN=32500 ERRFL=0 SQUAL=0 FAF=0 FAFFL=0 STCNT=0 PRTALL=ISBIT(ITT,4) GOTO 2007 2005 SQUAL=1 CALL TBULK 2007 BKSFL=.FALSE. BKSIP=.FALSE. FORWIP=.FALSE. WAITC=.FALSE. CALCFL=.FALSE. CALCIP=.FALSE. BUFULL=.FALSE. DEFKB=.FALSE. IF(FAF .EQ. 2) FAF=1 2100 INDEX=1 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 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,11,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 CONTINUE IF(SQUAL .NE. 0) GOTO 3100 C C=====STORE SFK DEFINITION INTO OUTPUT BUFFER C IF(INDEX .NE. 1) GOTO 3010 C-----LEAVE ENOUGH ROOM FOR FILE STORAGE STATE DEFINITION ! K=IRS8(STATE)+1 IF(K .LE. 20) K=20 OBULN=OBULNX-K OUTLEN=OBULN 3010 CALL MOVEW(STATE(2),OBUF(OUTLEN),STATLN-1) OUTLEN=OUTLEN+STATLN-1 IF( .NOT. ISBIT(STATE,7) ) GOTO 3015 INDEX=INDEX+1 GOTO 2600 C-----ENABLED ALL NEEDED SFK'S 3015 DO 3020 I=1,11 IF( .NOT. ISBIT(OBUF(OBULN),I-1) ) GOTO 30020 CALL TMBCT(10,I) 3020 CONTINUE 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,PRTALL D9822 FORMAT(" ITT="@7" NUQ="I4," NMQ="I4" LUQ="I5" LMQ="I5, D ." PRTALL="@7) C################################################################# GOTO 2600 C C-----STATE IS NOT 0 ---> EXECUTABLE STATE C 3100 IF(WAITC) GOTO 7000 C CHECK 'FAF' FLAG IF( .NOT. ISBIT(STATE,14) ) GOTO 3120 C C=====EXECUTE 'FAF' STATE (FIND IN AN IMAGE/1000 CHAIN) C C RESTORE RUN TABLE CALL MOVEW(RTB,ISAVRT,6) C################################################################## D WRITE(LUOXXX,9830)BKSIP,BKSFL,FAF,INDEX,ISAVRT D9830 FORMAT(" BKSIP="@8," BKSFL="@8," FAF="I2,3X"INDEX="I4,/ D .," RUN TABLE :",6I6) C#################################################################### IF(IGETB(STATE,4) .NE. ISAVRT) CALL TMPER(IERTN,49,FORMN,LU,13,0) IF( .NOT. BKSIP) GOTO 3103 FAF=2 GOTO 3107 3103 IF( .NOT. (BKSFL .AND. FAF.EQ.2) ) GOTO 3105 IF(INDEX .LE. ENDCHN) GOTO 2600 GOTO 3102 C CHECK RUN TABLE FOR END OF CHAIN CONDITION 3105 IF(ISAVRT(5) .NE. 0) GOTO 3109 IF(INDEX .EQ. 1) GOTO 3106 ENDCHN=INDEX-1 3102 WAITC=.TRUE. GOTO 3107 C ERROR IF END OF CHAIN & INDEX=1 ---> RESTART SAME FORM 3106 ERRFL=1 OUTLEN=3 GOTO 2005 3107 IF(DOBKS(SQUAL,JNDEX,INDEX,NUQ,NMQ) ) STOP 31 GOTO 2320 3109 LOCKW=0 IF( ISBIT(STATE(2),15) ) LOCKW=100001B CALL TBGET(IGETB(STATE,4),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 IOBUF(4)=2HE IOBUF(5)=IASC(50) OUTLEN=5 CIF( XERPRT(I) ) OUTLEN=3 ERRFL=1 GOTO 3107 3111 IF(IMGSTA .NE. 0) CALL TMPER(IERTN,49,FORMN,LU,18,IMGSTA) C SAVE RUN TABLE CALL MOVEW(ISAVRT,RTB,6) C-----CHECK MATCH ITEM J=(STATLN-2)/2 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 3105 3115 CONTINUE 3118 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=4 EDITPT=STATPT C-----IF DISPLAY SET UP EDIT POINTER IF( .NOT. ISBIT(STATE,15) ) GOTO 3122 EDITPT=EDITPT+5 IF( ISBIT(STATE(STATPT),15) ) EDITPT=EDITPT-2 3122 PRTON=PRTALL C-----CHECK FOR FORWARD ADVANCE, ASSUME NO ERROR & NO BKSIP IF( FORWIP ) GOTO 3127 C-----SWITCH OFF LIGHTS OF PREVIOUS STATE C SWITCH ON LIGHTS OF CURRENT STATE IOBUF=IOBUF(2)-401B LIGNUM=LIGHN(3) CALL PUTCA(IOBUF,LIGHT(LIGNUM,1),3) LENW=0 C-----IF THERE IS AN ERROR, FORGET THE DISPLAY IF(ERRFL .EQ. 0) GOTO 3125 BKSIP=.FALSE. GOTO 3180 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) DITMTP=ITMT(STATPT) DITMLN=ITML(STATPT) IF( ISBIT(STATE(STATPT),14) ) PRTON=.TRUE. C-----IS RECALL IN PROCESS NOW IF (BKSIP) GOTO 3160 C-----RETREIVE DATA TO BE DISPLAYED LIGNUM=LIGHN(STATPT+1) IF(BKSFL .AND. FAF.EQ.2) GOTO 3145 IF( .NOT. ISBIT(STATE(STATPT),15) ) GOTO 3130 C-----THE DISPLAY IS FROM THE IMAGE DATA-BASE, MOVE VALUE CALL MOVEW(IMGBUF(STATE(STATPT+2)),OBUF(DOBUPT),DITMLN/2) . GOTO 3145 3130 STATPT=STATPT+2 CALL SUBUF(FORMN,DITMTP,BKSFL,INDEX,STATPT,IUSER) CALL TMSUB(STATE(STATPT)) IF(IST .NE. 0) CALL TMPER(IERTN,1,FORMN,LU,STATE(STATPT),IST) C-----FORMAT DISPLAY INFORMATION 3145 CALL FMTO(DITMTP,OBUF(DOBUPT),IOBUF(4),LENW) 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 3170 CALL FMTO(ITEMTP,OBUF(OBUFPT),IOBUF(4),LENW) 3175 IF( FORWIP ) GOTO 6720 OUTLEN=3+LENW 3180 CALL PUTCA(IOBUF,LIGHT(LIGNUM,1),4) C-----SWITCH ON/OFF THE ERROR LIGHT 3200 IOBUF(3)=LIGHT(LITERR,ERRFL) ERRFL=0 C C-----OUTPUT THE MESSAGE AND REQUEST INPUT C 3250 INPDEV=24B C-----IF WAITING FOR 'TRANSACTION COMPLETE', FORGET CARD READER IF( WAITC ) GOTO 3270 IF( KBINP(I) ) GOTO 3270 C-----CARD READER INPUT, FIRST FIELD ? IF( ISBIT(STATE,10) ) 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 C BUT SWITCH OFF PROMPTING LIGHT IF (BKSIP) GOTO 3254 IOBUF(4)=IOBUF IOBUF(5)=LIGHT(LITERR,0) CALL TMWR(IOBUF(4),2) ITL=CRITL(ITEMTP,CRIMG(I)) IF(CRBUPT+ITL.GT.81) CALL TMPER(IERTN,49,FORMN,LU,21,CRBUPT) CALL MOVCA(CRBUF,CRBUPT,IOBUF(OUTLEN+1),1,ITL) INPDEV=0 IST=0 GOTO 3290 3254 CRBUPT=CRBUPT-ITL FLDCNT=FLDCNT-1 GOTO 3270 C-----IT IS 1ST FIELD OF A CARD, MUST CONFIGURE CARD-READER AND C READ THE CARD 3255 CALL TMBCT(6,IOR(IRS12(STATE(2)),20B)) INPDEV=31B DEFKB=.FALSE. CRBUPT=1 FLDCNT=0 STCNT=0 GOTO 3270 C-----CARD INPUT DEFAULTED TO KEYBOARD, DISPLAY "-------------" 3260 IF (BKSIP) GOTO 3270 CALL MOVEW(16H----------------,IOBUF(4),8) OUTLEN=11 C-----DO THE PHYSICAL WRITE/READ C C BUFFER FORMA2YT IS AS FOLLOW C C OUTLEN OUTPUT LENGTH (MAX LEN=14 WORDS) C INPLEN INPUT LENGTH (-16 OR -82) C IOBUF(1) SET LIGHT OFF C IOBUF(2) SET LIGHT ON C IOBUF(3) SET ERROR LIGHT C IOBUF(4) \ C ... \ C ... . OUTPUT MESSAGE C ... / C IOBUF(OUTLEN) / C IOBUF(OUTLEN+1) INPUT BUFFER (MAX LEN=41 WORDS) C ... C 3270 BKSIP=.FALSE. INPLEN=-82 IF(INPDEV .EQ. 24B) INPLEN=-16 IF(OUTLEN .GT. 14) OUTLEN=14 C##################################################################### D KL=2HKB D IF(INPDEV.EQ.31B) KL=2HCR D KM=2H D IF(CRIMG(I)) KM=2HIM D KN=2HFF D IF(PRTON) KN=2HN D WRITE(LUOXXX,9840)LU,JNDEX,INDEX,OUTLEN,INPLEN,KL,KM,KN D .,WAITC D9840 FORMAT(/," FROM LU#"I3" I/O FOR STATE: J="I2", I="I3, D ./,6X"LEN(OUT="I2", INP="I4") INP DEV="2A2," PRINTER IS O"A2, D ." WAITC ="@7) C##################################################################### C CALL LOGEV(ICOM00(2),LU,2,2*OUTLEN,FORMN,NUQ,INDEX) IF( PRTON ) CALL TMBWR(2H; ,-1,21B) CALL TMCWR(OUTLEN,2+OUTLEN-INPLEN/2,INPDEV) IF( PRTON ) CALL TMBWR(2H? ,-1,21B) C CALL LOGEV(ICOM00(2),LU,3,ITL,FORMN,NUQ,INDEX) C##################################################################### D K=OUTLEN+1 D K2=K-1+(ITL+1)/2 D IF(ITL.GE.94) K2=K+47 D KL=2HKB D IF(INPDEV.EQ.31B) KL=2HCR D KM=2H D IF(CRIMG(I)) KM=2HIM D WRITE(LUOXXX,9845)LU,KL,KM,IST,ITL,(IOBUF(I),I=K,K2) D9845 FORMAT(" FROM LU#"I3" COMPLETION OF INP DEV="2A2", STATUS ="@7, D .", ITL ="I4,6(/8@8)) C##################################################################### 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(INPDEV .NE. 31B) GOTO 3290 K=ITL/2 CALL BLAN(IOBUF(OUTLEN+1),ITL,81-ITL) IF( CRIMG(I) ) CALL NUL(IOBUF(OUTLEN+1+K),40-K) C##################################################################### D WRITE(LUOXXX,9848)(IOBUF(K),K=OUTLEN+1,OUTLEN+43) D9848 FORMAT(" CR BUFFER:",6(/8@8)) C##################################################################### CALL MOVEW(IOBUF(OUTLEN+1),CRBUF,40) ITL=CRITL(ITEMTP,CRIMG(I)) C-----UPDATE CARD-BUFFER POINTER AND SET DUMMY TLOG 3290 CRBUPT=CRBUPT+CRITL(ITEMTP,CRIMG(I)) FLDCNT=FLDCNT+1 C##################################################################### D KL=2HA) D IF(CRIMG(I)) KL=2HI) D KM=(ITL+1)/2 D WRITE(LUOXXX,9852)FLDCNT,KL,ITL,IST,ITEMTP,ITEMLN D .,(IOBUF(K),K=OUTLEN+1,OUTLEN+KM) D9852 FORMAT(" FLD"I3" ON CARD ("A2", ITL="I3", IST="@7", ITEM: [TYPE=" D .I1" LEN="I3"]",8(/8X,8@8)) C##################################################################### C C-----ANALYSE ANSWER; PARSE INPUT BUFFER C 3300 KEYN=IAND(IST,17B)+1 GOTO (4000,4100,3500),KEYN C-----PREFIX KEY USED ? 3500 IF(ITL .EQ. 0) GOTO 3510 IF( IGETB(IOBUF(OUTLEN+1),ITL)-SFKX .NE. IRS12(OBUF(OBULN)) ) . GOTO 3510 ITL=ITL-1 KEYN=KEYN+10 3510 KEYN=IGETB(OBUF(OBULN),KEYN) IF(KEYN .EQ. 0) GOTO 9000 C------FUNCTION OR STRING ? IF( .NOT. ISBIT(KEYN,7) ) GOTO 4600 C-----FUNCTION: PERFORM FUNCTION EDIT IF( FEDIT(KEYN,STATE(EDITPT)) ) GOTO 9000 KEYN=IAND(KEYN,77B) C-----DISPATCH ON FUNCTION NUMBER GOTO (4500,4300,4400,4200,4700,4700,4700,4700,4700,9000, .5000,5100,5200,9000),KEYN C C-----FUNCTION'S PROCESSOR C C-----ENTER KEY ************************* 4000 IF(WAITC) GOTO 9000 IF(CALCFL) GOTO 4060 IF(ITL .NE. 0) GOTO 6000 C-----ENTER KEY ONLY: DEFAULT VALUE OR SAME VALUE IF RECALL IF(ENDBK(BKSFL)) GOTO 6300 GOTO 6100 C-----ENTER KEY IN CALCULATOR MODE 4060 IF(CALUuCIP) GOTO 9000 CALCFL=.FALSE. IF(ITL .NE. 0) GOTO 6000 IF(ENDBK(BKSFL)) GOTO 6300 GOTO 6300 C-----SRQ RESET THE TERMINAL ************************* C AND RESTART AT THE SAME POINT. 4100 CALL TMCTL(11B,35B) DO 4110 I=1,11 IF(.NOT. ISBIT(OBUF(OBULN),I-1) ) GOTO 4110 CALL TMBCT(10,I) 4110 CONTINUE C-----IF CARD READER INPUT, SWITCH TO KEYBOARD INPUT IF( KBINP(I) ) GOTO 3250 DEFKB=.TRUE. INPDEV=24B GOTO 3260 C-----FNUM#4 "ABORT TRANSACTION" ************************* 4200 IF(ITL .NE. 0) GOTO 9000 IF( .NOT. ISBIT(ITT,14) ) GOTO 4250 CALL TMBWR(2H; ,-1,21B) CALL TMWR(LFLF,3) GOTO 4250 4231 IF( ISBIT(ITT,0) ) CALL TMCBD(IUSER) 4233 ITT=0 C EXIT THIS FORM AND RETURN TO ASK "FORM # ?" 4250 CALL TBULK SQUAL=11 C CLOSE THE FORM CALL TMSUB(TSMG) ASSIGN 4275 TO K IF(FMGST .NE. 0) CALL TMPER(K,49,FORMN,LU,31,0) 4275 IF( ISBIT(ITT,0) ) CALL TMCBD(IUSER) IF( ISBIT(ITT,1) ) CALL TMCBD(IMGBUF) CALL TMCBD(FORMN,NUQ) CALL TMBCT(13B) IF( ERRFL .EQ. 0) GOTO 100 GOTO 220 C-----FNUM#2 "RECALL" ************************* 4300 IF(ITL .NE. 0) GOTO 9000 IF(CALCFL) GOTO 9000 K=-1 C-----IF IN PLACE OF CARD READER INPUT, UPDATE CR POINTER IF( KBINP(I) ) GOTO 4305 CRBUPT=CRBUPT-CRITL(ITEMTP,CRIMG(I)) FLDCNT=FLDCNT-1 4305 IF(BKSFL) GOTO 4310 BKSQ=SQUAL BKIN=INDEX BKJN=JNDEX 4310 IF(SQUAL .EQ. 0) CALL TMPER(IERTN,49,FORMN,LU,33,0) IF(WAITC) GOTO 4350 IF(DOBKS(SQUAL,JNDEX,INDEX,NUQ,NMQ) ) GOTO 4370 STCNT=STCNT-1 FORWIP=.FALSE. BKSIP=.TRUE. BKSFL=.TRUE. K=K+1 IF(K .LT. 0) GOTO 4310 GOTO 2320 C SPECIAL RECALL IF END HAS BEEN REACHED 4350 WAITC=.FALSE. BUFULL=.FALSE. BKSQ=4 BKSIP=.TRUE. BKSFo=L=.TRUE. GOTO 3100 C-----ERROR DURING BACKSPACE, THE VERY FIRST STATE IS REACHED C SET ERROR FLAG AND GO RE-GET THE STATE VECTOR 4370 ERRFL=1 OUTLEN=3 GOTO 2320 C-----FNUM#3 "SAME VALUE" ************************* 4400 IF(WAITC) GOTO 9000 IF(ITL .NE. 0) GOTO 9000 IF(CALCFL) GOTO 9000 IF(ENDBK(BKSFL)) GOTO 6300 IF(INDEX .GT. 1) GOTO 4430 IF(BEGNFL) GOTO 9000 GOTO 6300 4430 I=IPT(INDEX-1,2) CALL MOVEW(OBUF(I),OBUF(OBUFPT),(ITEMLN+1)/2) GOTO 6300 C-----FNUM#1 "TRANSACTION COMPLETE" ************************* 4500 IF(ITL .NE. 0) GOTO 9000 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 EXECUTE LOGGING IF REQUIRED C STORE DATA ON MEDIA USING THE TMSUB "STORA" C 4510 KEYN=FORMN INDEX=I CALL MOVEW(OBUF(OBULN),ITEMTP,2) OBUF(OBULN)=LU OBUF(OBULN+1)=ITT C LOCK THE TRANS. SPEC. FOR THE STORAGE SQUAL=12 CALL TMSUB(TSMG) C-----LOGGING OF THE DATA BUFFER IF NEEDED === IF( .NOT. ISBIT(ITT,13) ) GOTO 4520 CALL CNUMD(FORMN,LOGHD(3)) CALL TMLOG(LOGHD,OBUF,L1+INDEX*L2) IF(IST .LT. 0) GOTO 4520 CALL TMBWR(LOGACK,4) C-----CALL THE STORAGE MODULE 4520 CONTINUE C CALL LOGEV(ICOM00(2),LU,1000,0,FORMN,0,0) CALL TMPRO(2,STORAG,NUQ) CALL MOVEW(ITEMTP,OBUF(OBULN),2) C-----RESTART THE SAME FORM IF( .NOT. ISBIT(ITT,14) ) GOTO 4530 CALL TMBWR(2H? ,-1,21B) CALL TMWR(20H====================,10,10B) 4530 BEGNFL=.FALSE. IF(INDEX .EQ. ENDCHN) GOTO 2005 IF(INDEX .GT. ENDCHN) CALL TMPER(IERTN,49,FORMN,LU,41,0) IF(.NOT. BUFjNLHULL) GOTO 2005 C RESTART AT BEGINNING OF M-QUESTION SQUAL=2 GOTO 2007 C-----SFK HAS A STRING VALUE (TERMINATOR SFK) ************************* 4600 IF(WAITC) GOTO 9000 IF(CALCFL) GOTO 9000 ITL=ITL+1 IF ( USFKV(KEYN,IOBUF(OUTLEN+1),ITL,OBUF(OBULN)) ) GOTO 9000 GOTO 6000 C-----COMPUTATION FUNCTIONS (CALCULATOR MODE) ************************* 4700 IF(WAITC) GOTO 9000 IF(ITL .EQ. 0) GOTO 4725 IF ( FMTIN(I) ) GOTO 9000 GOTO 4730 4725 CALL NUL(OBUF(OBUFPT),ITEMLN/2) IF(.NOT. CALCFL) CALL MOVEW(OBUF(DOBUPT),CALCBU(4),2) 4730 IF(CALCU(ITEMTP,DITMTP,KEYN,ITL,OBUF(OBUFPT),CALCBU)) GOTO 9000 GOTO(8000,3170),KEYN sONC-----FNUM # 11 "CONTINUE TO NEXT QUESTION" ************************* 5000 IF(WAITC) GOTO 9000 IF(ITL .NE. 0) GOTO 9000 TEMPL=VALCK(.TRUE.) STATPT=STATPT+EDITPT-1 IF( .NOT. ISBIT(STATE,8) ) GOTO 6370 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 3106 C-----FNUM # 12 "NEXT ENTRY IN AN CHAIN" ************************* 5100 IF(WAITC) GOTO 9000 IF(ITL .NE. 0) GOTO 9000 IF(SQUAL .EQ. 1) GOTO 9000 INDEX=INDEX-1 JNDEX=NMQ IF( .NOT. (ENDBK(BKSFL)) ) 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=OBULN-(BKIN*6) CALL MOVEW(OBUF(ITO-6),OBUF(ITO),-K*6) GOTO 2600 C-----FNUM # 13 "DELETE ENTRY IN DATA BASE" ************************* 5200 IF(WAITC) GOTO 9000 IF(ITL .NE. 0) GOTO 9000 FORWJN=NMQ IF(SQUAL .EQ. 1) FORWJN=NUQ FORWIP=.TRUE. TEMPL=VALCK(.TRUE.) GOTO 6350 C C EDIT AND STORE 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(BKSFL)) GOTO 6100 6100 IF ( FMTIN(I) ) GOTO 9000 C C-----PERFORM VALUE EDIT C 6300 IF ( VALCK(CRIMG(I)) ) GOTO 9000 6350 STATPT=STATPT+EDITPT-1 6370 IF( .NOT. ISBIT(STATE(EDITPT),11) ) GOTO 6600 IF( CRIMG(I) ) GOTO 6590 C C-----PERFORM IMAGE EDIT C IMEC;D=IAND(STATE(STATPT),17B) LOCKW=0 IF(ISBIT(STATE(STATPT),13)) LOCKW=100001B K=STATE(STATPT+1) I=IPT(INDEX,STATPT+1) C##################################################################### D WRITE(LUOXXX,9861)STATE(STATPT),IMECD,K,LOCKW,LOCKID(1) D9861 FORMAT(" IMAGE EDIT:"@7," EDIT CD="I1" ITM#-DS#"@7, D .", LOCKW="@6" LOCKID="I2) C##################################################################### GOTO (6400,6400,6400,6550),IMECD C=====IMAGE EDIT # 1 6400 CALL TBGET(IGETB(K,2),4,IMGSTA,TEMPB,OBUF(I),LOCKW) C##################################################################### D WRITE(LUOXXX,9862)IMECD,IMGSTA,LOCKID(1),ISAVRT D9862 FORMAT(" AFTER DBCALL (EDIT DC="I1"), IMG STAT:"4I6,3X, D ."LOCKID="I2,/" RUN TABLE:"6I6) C##################################################################### IF(IMGSTA.NE.400 .AND. IMGSTA.NE.401) GOTO 6408 6405 ERRFL=50 GOTO 9010 6408 GOTO (6410,6450,6500),IMECD 6410 IF(IMGSTA .NE. 0) GOTO 9000 IF( ISBIT(STATE(STATPT),12) ) CALL MOVEW(TEMPB,IMGBUF,250) IF( .NOT. ISBIT(STATE(STATPT),14) ) GOTO 6590 CALL MOVEW(TEMPB,IMGBUF,250) FAFFL=1 CALL MOVEW(ISAVRT,OBUF(IMPT(INDEX)),6) GOTO 6590 C=====IMAGE EDIT # 2 6450 IF(IMGSTA .NE. 107) GOTO 9000 GOTO 6590 C=====IMAGE EDIT # 3 6500 IF(ISNUL(TEMPB(4),IGETB(STATE(STATPT+1),1)-3)) GOTO 9000 GOTO 6590 C=====IMAGE EDIT # 4 6550 CALL TBFND(IMGSTA,IGETB(K,2),IGETB(K,1),OBUF(I),LOCKW) C##################################################################### D WRITE(LUOXXX,9863)IMGSTA,LOCKID(1),ISAVRT D9863 FORMAT(" AFTER DBFND (EDIT CD=4), IMG STAT:"4I6,3X"LOCKID=", D . I2,/" RUN TABLE:"6I6) C##################################################################### IF(IMGSTA.EQ.400 .OR. IMGSTA.EQ.401) GOTO 6405 IF(IMGSTA .NE. 0) GOTO 9000 C CHECK CHAIN LENGTH IF(ISAVRT(3) .EQ. 0) GOTO 9000 IF( ISBIT(STATE(STATPT),15) ) CALL MOVEW(ISAVRT,RTB,6) 6590 STATPT=STATPT+3 6600 IF( .NOT. ISBIT(STATE(EDITPT),10) ) GOTO 6700 C C-----CALL THE USER EDIT MODULE 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 OUTLEN=3 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,71,ITEMTP) IF(JNDEX .GE. FORWJN) FORWIP=.FALSE. 6800 CONTINUE C######################################################### D I=IPT(INDEX,2) D K=IMPT(INDEX) D WRITE(LUOXXX,9873)I,OBUFPT,K D9873 FORMAT(" OBUFPT="2I7,3X"OBIMPT="I7) 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(OBUF(I),X,2) D WRITE(LUOXXX,9877)LU,X D GOTO 9885 D9876 WRITE(LUOXXX,9878)LU,KEYN D GOTO 9885 D9875 WRITE(LUOXXX,9872)LU,OBUF(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(LUOXXX,9882)LU,ITEMLN,(OBUF(J),J=I,I+K-1) D9882 FORMAT(" FROM LU#"I2" STRING: LEN ="I4" BYTES, VAL:" D .,2(/,12X,32A2)) D9885 CONTINUE C######################################################## C-----RESTORE RUN TABLE FOR MAIN KEY ITEM IF( .NOT. ISBIT(STATE,12) ) GOTO 6900 CALL MOVEW(RTB,ISAVRT,6) ENDCHN=32500 FAF=1 FAFFL=1 6900 IF( NMQ .EQ. 0 .AND. . ( .NOT. ENDMQ(SQUAL,JNDEX,NUQ,NMQ)) ) GOTO 7000 IF(ENDMQ(SQUAL,JNDEX,NUQ,NMQ)) GOTO 2600 IF(OBUFPT+((ITEMLN+1)/2)+L2+10 .LT. IMPT(INDEX)) GOTO 2600 BUFULL=.TRUE. IF(SQUAL .NE. 2) CALL TMPER(IERTN,49,FORMN,LU,81,0) C-----SET WAIT TRANSACTION COMPLETE FLAG !! 7000 WAITC=.TRUE. PRTON=.FALSE. FORWIP=.FALSE. IOBUF=IOBUF(2)-401B C-----SWITCH ON LIGHT "TERMINATE TRANSACTION !" IOBUF(2)=LIGHT(LITTCP,1) 8000 OUTLEN=3 GOTO 3200 C C E R R O R S E C T I O N ! C ============================ C 9000 ERRFL=1 FORWIP=.FALSE. OUTLEN=3 9010 IF(ERRFL .LE. 1) GOTO 9020 C-----FORMAT ERROR NUMBER REPORT "E XX" IOBUF(4)=2HE IOBUF(5)=IASC(ERRFL) ERRFL=1 OUTLEN=5 IF( XERPRT(I) ) OUTLEN=3 C-----IF FROM KEYBOARD INPUT, OUTPUT ERROR 9020 IF(INPDEV .EQ. 24B) GOTO 9200 C-----IF NOT CARD READER INPUT, REPORT ERROR IF( KBINP(I) ) GOTO 9200 C-----ERROR IS FROM A FIELD ON A CARD, REPORT SEPCIAL ERROR MESSAGE C PRINT "E 11 -- FLD# . COLUMN# " AND BACKSPACE AT THE BEGINNING C OF THE CARD. CALL MOVEW(16HE 11 -- F# . C# ,IOBUF(4),8) IOBUF(8)=IASC(FLDCNT) CALL MOVCA(IASC(CRBUPT-ITL),1,IOBUF,20,2) CALL PUTCA(IOBUF,5000B,22) OUTLEN=11 IF( XERPRT(I) ) OUTLEN=3 K=-STCNT IF(K .LT. 0) GOTO 4305 C-----IN CASE OF ERROR, SWITCH OFF THE DISPLAY LIGHT 9200 K=IOBUF(2) IOBUF=K-401B CALL PUTCA(IOBUF(2),IGET1(K,1),2) GOTO 3200 C END C LIBRARY FOR TMP (FTN4) 92903-18510 REV.1805 780401 C C C NAME: USFKV,DOBKS,ENDMQ,BKSEN,SUBUF,CCBYT,CRITL C FEDIT,VEDIT,FMTI,FMTO,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 CRITL - DETERMINE FIELD LENGTH ON A CARD INPUT C FEDIT - FUNCTION EDIT C VEDIT - VALUE EDIT C FMTI - FORMATTER INPUT (ASCII --> BINARY) C FMTO - FORMATTER OUTPUT (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(FNUM,IB,I,KEYVA), 92903-16510 REV.1805 77 .0602 C C THIS SUBROUTINE STORE IN THE BUFFER "IB" THE VALUE OF C THE SFK NUMBER "FNUM". VALUE OF SFK IS GET FROM BUFFER "KEYVA" C "FNUM" IS THE KEY NUMBER (SEE USFK SUBROUTINE) C "I" INDICATE WHERE THE VALUE MUST BE STORE IN "IB", IT IS C THE CHARACTER NUMBER. (1ST IS 1 -ONE-). "I" WILL BE UPDATED C TO BE THE CHARACTER NUMBER OF THE LAST CHAR. OF THE KEY VALUE, C (IE LAST USEFULL CHARACTER NUMBER IN "IB") C C DIMENSION IB(1),KEYVA(1) INTEGER FNUM LOGICAL ISBIT C USFKV=.TRUE. IF(FNUM .EQ. 0) RETURN IF( ISBIT(FNUM,7) ) RETURN L=KEYVA(FNUM)  IF(L .EQ. 0) RETURN IF(I+L .GE. 100) L=101-I IF(L .LE. 0) RETURN CALL MOVCA(KEYVA,2*FNUM+1,IB,I,L) I=I+L-1 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,ISQ,I,J,ISQ0,I0,J0), 92903-16510 REV. .1805 770602 C C THIS FUNCTION INDICATE IF THE TRANSACTION IS STILL C IN BACKSPACE MODE OR NOT. C C BKSEN IS .TRUE. IF INSIDE A BACKSPACE (IF BACKSPACE MODE) C LOGICAL BKSFL C IF(.NOT. BKSFL) GOTO 10 IF(ISQ.GE.ISQ0 .AND. I.GE.I0 .AND. J.GE.J0) BKSFL=.FALSE. 10 BKSEN=BKSFL RETURN END SUBROUTINE SUBUF(ITSN,ITMTP,BKSFL,I,K,IUSER), 92903-16510 REV.1805 . 780307 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(BKSߋQ .EQ. 1) IUSER(8)=0 J=K+4 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 INTEGER FUNCTION CRITL(ITMT,CRIMG), 92903-16510 REV.1805 780524 C C THIS FUNCTION RETURN THE LENGTH OF A FLD ON C A CARD, DEPENDING ON THE TYPE OF THE ITEM AND C ON THE TYPE OF CARD READ (IMAGE VS ASCII) C C FIELD LENGTH C ITEM TYPE ASCII IMAGE C C 0 (STRING) ITEM LENGTH ITEM LENGTH C 1 (INTEGER) 6 2 C 2 (REAL) 14 4 C DIMENSION ITMT(1) LOGICAL CRIMG CRITL=ITMT(2) IF(ITMT .EQ. 0) RETURN IF( CRIMG ) GOTO 100 IF(ITMT .EQ. 1) CRITL=6 IF(ITMT .EQ. 2) CRITL=14 RETURN 100 CRITL=2*ITMT 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)=IAND(IALF2(IGET1(EDITB,M)),377B) C FEDIT=.FALSE. IF( .NOT. ISBIT(FNUM,6) ) RETURN C-----CHECK FLAG 'FEF' IF( .NOT. ISBIT(EDITB,15) ) GOTO 200 IE=IGETX(3) K=IAND(FNUM,77B) C DO 100 I=1,IE IF(K .EQ. IGETX(I+3)) RETURN 100 CONTINUE 200 FEDIT=.TRUE. RETURN END LOGICAL FUNCTION VEDIT(ITMTP,CRIMG,IST,IBUF,IEDPT), 92903-16510 RE .V.1805 780524 C C***** STANDARD VALUE EDIT C =================== C INTEGER CCBYT LOGICAL ISBIT,CRIMG 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=2 C-----SKIP FUNCTION EDIT SPEC. (IF ANY) IF( ISBIT(IST,15) ) . IEDPT=IEDPT + (2+IAND(IALF2(IGET1(IST,3)),377B))/2 C GOTO (110,210,310,410),ITMTP1 C C-----STRING C 110 IF( CRIMG ) 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( CRIMG ) 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 C MAXIMUM CHECK IF(X .GT. FLOAT(IST(IEDPT))) GOTO 9000 IEDPT=IEDPT+1 215 IF( .NOT. ISBIT(IST,13) ) GOTO 217 C MINIMUM CHECK IF(X .LT. FLOAT(IST(IEDPT))) GOTO 9000 IEDPT=IEDPT+1 217 IF( .NOT. ISBIT(IST,12) ) GOTO 8000 C MODULO CHECK IF(MOD(IBUF,IST(IEDPT)) .NE. 0) GOTO 9000 IEDPT=IEDPT+1 GOTO 8000 C C-----REAL C 310 CALL MOVEW(IBUF,X,2) C-----REAL EDIT IF( .NOT. ISBIT(IST,14) ) GOTO 315 IF( CRIMG ) 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( CRIMG ) 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 LOGICAL FUNCTION FMTI(ITMTP,CRIMG,ISTAT,ISTED,IBS,ITLG .,IBD,IDVPT,KEYVA), 92903-16510 REV.1805 780524 C C***** FORMAT INPUT BUFFER (ASCII ---> BINARY) C ======================================== C DIMENSION ISTED(1),IBS(1),IBD(1),ITMTP(1) INTEGER SFKX,SFK0,SFK99 LOGICAL USFKV,INUM,RNUM,ISBTW,ISBIT,CRIMG C DATA SFKX/16B/,SFK0/2/,SFK99/11/ C IRS8(M0)=IAND(IALF2(M0),377B) IRS12(M2)=IAND(IALF2(M2),360B)/16 C IF(ITMTP .EQ. 3) GOTO 9000 C FMTI=.FALSE. ITMTP1=ITMTP+1 ITMLC=ITMTP(2) ITMLW=(ITMLC+1)/2 C-----IF INPUT IS CARD IMAGE, MOVE INTO DESTINATION BUFFER C AND RETURN IF( .NOT. CRIMG ) GOTO 3 CALL MOVEW(IBS,IBD,ITMLW) RETURN C C-----SET POINTER TO DEFAULT VALUE C 3 IPTDV=1+IAND(ISTED,377B) IF(ITLG .NE. 0) GOTO 10 C C-----TAKE THE DEFAULT VALUE C IF( ISBIT(ISTAT,13) ) GOTO 5 CALL MOVEW(ISTED(IPTDV),IBD,ITMLW) IF(.NOT. (ITMTP.EQ.0 .AND. ITMLC.GT.16) ) RETURN ITLG=16 GOTO 150 C-----THE DEFAULT VALUE IS THE DISPLAYED VALUE 5 CALL MOVEW(IBD(IDVPT),IBD,ITMLW) RETURN C C-----TAKE THE VALUE ENTERED BY THE OPERATOR C 10 CONTINUE C-----PROCESS THE NO TERMINATOR SFK'S C SEARCH IN THE BUFFER IPK=IRS12(KEYVA) C JS=1 20 IF(JS .GT. ITLG) GOTO 60 JD=JS K=IGETB(IBS,JS)-SFKX IF(ISBTW(K,SFK0,SFK99)) GOTO 40 C-----PREFIX KEY ? IF(K .NE. IPK) GOTO 30 C-----PROCESS PREFIX KEY 25 JS=JS+1 IF(JS .GT. ITLG) GOTO 9000 L=IGETB(IBS,JS)-SFKX IF(ISBTW(L,SFK0,SFK99)) GOTO 9000 IF(L .EQ. IPK) GOTO 25 K=L+10> C-----GET KEY VALUE 30 K=IGETB(KEYVA,K+1) L=(JS+1)/2 CALL MOVEW(IBS(L),IBS(L+10),-((ITLG-JS)/2+3)) C INSERT KEY VALUE IN THE BUFFER IF( USFKV(K,IBS,JD,KEYVA) ) GOTO 9000 ITLG=ITLG+JD-JS C MOVE BACK END OF BUFFER RIGHT AFTER KEY VALUE CALL MOVCA(IBS,JS+21,IBS,JD+1,ITLG-JD+1) 40 JS=JD+1 GOTO 20 C 60 CONTINUE C GOTO (100,200,300),ITMTP1 C C-----STRING C 100 IF(ITLG .GT. ITMLC) GOTO 9000 CALL MOVEW(IBS,IBD,ITMLW) 150 K=2*ITMLW-ITLG IF(K.GT.0) CALL BLAN(IBD,ITLG+1,K) 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 FMTI=.TRUE. RETURN END SUBROUTINE FMTO(ITMTP,IBS,IBD,L), 92903-16510 REV.1805 780524 C C***** FORMAT OUTPUT BUFFER (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. 10) L=10 CALL MOVEW(IBS,IBD,L) GOTO 8000 C-----INTEGER 2200 CALL JASC(IBS,IBD,1,12) L=6 GOTO 8000 C-----REAL 2300 IBD(8)=2H CALL RASC(IBS,IBD,1,15,2) IF(IBD .EQ. 2H$$) CALL MOVEW(16HEEEEEEEEEEEE.EE ,IBD,8) L=8 GOTO 8000 C-----FUNCTION ONLY 2600 IBD=2H L=1 8000 RETURN END LOGICAL FUNCTION CALCU(ITMTP,DITMTP,FNUM,ITL,N, .TEMP), 92903-16510 REV.1805 780522 C C THIS PROGRAM SIMULATES A DESK CALCULATOR C IT USE THE NON-POSTFIXE NOTATION. C C INTEGER DITMTP,FNUM,TEMP(1),TEMPA(5) LOGICAL ISNUL,CALCFL,CALCIP EQUIVALENCE (TEMPA,CALCFL),(TEMPA(2),CALCIP) EQUIVALENCE (TEMPA(3),LAST),(TEMPA(4),Y) C CALL MOVEW:(TEMP,TEMPA,5) IF(CALCFL) GOTO 1500 C-----SET CALCULATOR MODE CALCFL=.TRUE. LAST=1 C IF THE SAME TYPE AS BEEN DISPLAYED JUST BEFORE C TAKE THE DISPLAYED VALUE TO START CALCULATION IF(DITMTP .NE. ITMTP) GOTO 1000 IF(ITMTP .EQ. 1) Y=TEMPA(4) GOTO 1500 1000 Y=0. 1500 CALCIP=.TRUE. CALL MOVEW(N,X,ITMTP) IF(ITMTP.EQ.1) X=N C C-----DISPATCH TO PROPER SECTION C 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. LAST=J 4500 CALL MOVEW(TEMPA,TEMP,5) CALL MOVEW(X,N,ITMTP) C-----CHECK FOR INTEGER OVERFLOW IF(ITMTP .EQ. 2) RETURN N=X IF(X .GE. -32768. .AND. X .LE. 32767.) RETURN CALCU=.TRUE. RETURN END SUBROUTINE TMPER(IERTN,IERNB,ITSNB,LU . ,IP1,IP2), 92903-16510 REV.1805 780525 C C C NAME: TMPER ERROR DURING TMP C SOURCE: &TMPER 92903-18510 C BINARY: %TMPER 92903-16510 PART OF %ZTMP 92903-16510 C C PMGR: FRANCOIS GAULLIER C C C **********C**************************************************** C * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * C ************************************************************** C C C THIS SUBROUTINE PRINTOUT THE FOLLOWING MESSAGE: C C MEMORY UNLOCK/FORMAT MODE OFF/BLOCK MODE OFF/CLEAR DISPLAY/RC/LF C C ERROR : TMP XX ZZZZZZZZZZZZZZZZZZZZZZZZZZZZZ COPY#1,TS=1234,LU=12 C C WHERE ZZZZZZZZZZZZZZZZZZZZZZZZZZZZZ IS THE FOLLOWING: C C MISSING USER WRITTEN SUBROUTINE: XXXXXX C OR DATA SET # XX IS FULL C OR DISC FILE: XXXXXX ON CR YYYYY, IS FULL C OR INTERNAL ERROR: XXXXXX**YYYYYY C C C DIMENSION MES(55),IWAIT(10) C DATA MES/15555B,15530B,15446B,2Hk0,2HB ,15512B,6412B, . 15446B,2HdC,2HER,2HRO,51033B,2H&d,2H@ ,2H: , . 2HTM,2HP ,38*2H / DATA IWAIT/10*15500B/ C CALL BLANC(MES(18),25) MES(18)=IASC(IERNB) C-----MISSING USER WRITTEN SUBROUTINE IF( IERNB.NE.1 .AND. IERNB.NE.2 .AND. IERNB.NE.53 ) GOTO 100 IF(IP2 .NE. -10) GOTO 80 CALL MOVEW(34HMissing user written subroutine: ,MES(20),17) CALL MOVEW(IP1,MES(37),3) GOTO 1000 80 MES(18)=IASC(IERNB+10) CALL MOVEW(30HInternal Error: ** ,MES(20),15) CALL MOVEW(IP1,MES(28),3) CALL CNUMO(IP2,MES(32)) GOTO 1000 C-----OUT OF SPACE DURING STORAGE 100 IF( IERNB.NE.25 .AND. IERNB.NE.65 ) GOTO 120 CALL MOVEW(22HData Set #xxxx is full,MES(20),11) CALL JASC(IP1,MES(25),1,4) GOTO 1000 120 IF( IERNB.NE.26 .AND. IERNB.NE.66 ) GOTO 140 CALL MOVEW(34HDisc file: xxxxxx on CRxxxxxx, is,MES(20),17) CALL MOVEW(6H full ,MES(37),3) CALL MOVEW(IP1,MES(26),3) CALL JASC(IP2,MES(32wNLH),1,6) GOTO 1000 140 IF( IERNB.NE.27 .AND. IERNB.NE.67 ) GOTO 160 CALL MOVEW(28HStorage device LU xx is full,MES(20),14) MES(29)=IASC(IP1) GOTO 1000 C-----INTERNAL ERROR 160 CALL MOVEW(30HInternal Error: ** ,MES(20),15) CALL JASC(IP1,MES(28),1,6) CALL JASC(IP2,MES(32),1,6) C C ADD TMP COPY #, TS# AND 3070 LU C 1000 CALL PNAME(MES(42)) CALL MOVCA(6HCopy# ,1,MES(41),1,5) CALL CNUMD(ITSNB,MES(45)) CALL MOVEW(4H,TS=,MES(44),2) CALL MOVEW(4H,LU=,MES(48),2) MES(50)=IASC(LU) K=51 CALL MOVEW(IWAIT,MES(K),3) K=K+3 MES(K)=6412B IF(IERNB .LT. 50) K=K-1 CALL TMSOP(2,0,MES,K) IF(IERNB .GE. 50) CALL TMSAB(33) K=IERTN GOTO K 9999 RETURN END END$ N  + 92903-18521 1805 S C0122 &TSE'              H0101 eaFTN4 SUBROUTINE TSE, 92903-16520 REV.1805 780522 C C C NAME: TSE C SOURCE: &TSE' 92903-18521 C RELOC: %TSE' ----NONE--- PART OF %TSE 92903-16520 C C PGMR: DANIEL POT/FRANCOIS GAULLIER HPG 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: TSE IS A T.U.S. OF THE TMP C (TRANSACTION MONITOR PROGRAM) C C C TSE = TRANSACTION SET EDITOR C C TSE ALLOWS THE OPERATOR TO CHANGE OR TO LIST THE MIX OF C TRANSACTION SPECS. USED BY TMP, THROUGH AN INTERACTIVE C DIALOG. C THE OPERATOR CAN REMOVE OR ADD A TRANSACTION SPEC. AND C LIST THE DIRECTORY OR THE CONTENT OF A SPECIFIC TRANSAC- C TION SPECIFICATION. C C********************************************** F. GAULLIER (HPG) *** C C DIMENSION INPUT(70),ISTRG(3),IPOB(3) INTEGER TSMG(3),FORMN,SQUAL,J,FMGST,STATE(38),STATLN,TITLE(63) .,DCMON(3),RESET(8),RETUN(25),PROCS(23),OROR(9),STATU(122) C C-----NO TRUE COMMON C C-----1ST COMMON BLOCK C COMMON LU,ICTLB,ITYP,IST,ITL,ICRST,LOCKID(2) C C-----NO 2ND COMMON BLOCK C C-----3ND COMMON BLOCK C COMMON FORMN,SQUAL,J,FMGST,STATE,STATLN,MBUFR(9),L C C-----LAST COMMON WORD C COMMON ICOMEN C LOGICAL ISSLA,ISBTW,ISSPA,ISNUL,CMPW,CMPB,IPAR LOGICAL OCTCV,ISNUM,ERFL,JPAR,IMBED,KPAR C C-----DATA DEFINITIONS C 3 DATA LENSC/29/ DATA TSMG/2HTS,2HMG,2H / DATA DCMON/2HDC,2HMO,2HN / C C-----DATA DEFINITION FOR LISTING OPERATION C DATA RESET/15530B,15555B,15446B,2Hk0,2HB ,15542B,15510B,15512B/ DATA RETUN/6412B,6412B,15446B,60453B,32067B,41440B,15446B, .62112B,2HPr,2Hes,2Hs ,15446B,62113B,2HNE,2HXT,2H S,2HCR,2HEE, .2HN ,15446B,62112B,2Hke,74433B,23144B,40040B/ DATA PROCS/15446B,62102B,2HRE,2HAD,2HIN,2HG ,2HTR,2HAN,2HSA, .2HCT,2HIO,2HN ,2HSP,2HEC,2HIF,2HIC,2HAT,2HIO,2HN ,15446B, .62100B,6412B,6412B/ DATA OROR/6412B,6412B,20040B,2HCL,2HOS,2HE ,2HER,2HRO,2HR / DATA TITLE/6412B,15446B,60453B,30466B,41440B, .2HT ,2HR ,2HA ,2HN ,2HS ,2HA ,2HC ,2HT ,2HI ,2HO ,2HN ,2H , .2HS ,2HE ,2HT ,2H ,2HE ,2HD ,2HI ,2HT ,2HO ,2HR ,6412B,6412B, .15446B,60453B,31460B,41400B,2HDI,2HRE,2HCT,2HOR,2HY ,2HLI,2HST, .6412B,6412B,15446B,60453B,31063B,41440B,2HNA,2HME,2H ,2H ,2H , .2H ,2H ,2HNU,2HMB,2HER,2H ,2H ,2H ,2H ,2HSC,2H ,6412B/ DATA STATU/15446B,60453B,30470B,41400B, .2H S,2HTA,2HTU,2HS ,2HOF,2H T, .2HRA,2HNS,2HAC,2HTI,2HON,2H S,2HPE,2HCI,2HFI,2HCA,2HTI,2HON, .20000B,2H ,2H ,2H ,6412B,6412B,6412B,6412B,6412B,20040B, .20040B,2H T,2HRA,2HNS,2HAC, .2HTI,2HON,2H N,2HUM,2HBE,2HR: ,2H ,2H ,2H ,20040B,2HSE,2HCU, .2HRI,2HTY,2H C,2HOD,2HE:,2H ,2H ,2H ,20040B,6412B,20040B, .20040B, .20000B, .2HTH,2HIS,2H T,2HRA,2HNS,2HAC,2HTI,2HON,2H H,2HAS,2H ,2H , .20000B, .2HU-,2HQU,2HES,2HTI,2HON,2H T,2HYP,2HE ,2HAN,2HD ,2H ,2H , .46400B, .2H-Q,2HUE,2HST,2HIO,2HN ,2HTY,2HPE,6412B,20040B,20040B,2H T, .2HHI,2HS ,2HTR,2HAN,2HSA,2HCT,2HIO,2HN ,2HIS,2H U,2HSE,2HD , .2HNO,2HW ,2HBY,2H ,2H ,20040B,2HUS,2HER,2HS.,6412B,6412B/ C KPAR(IFILD,ILONG)=JPAR(INPUT,LENSC,IFILD,ISTRG,ILONG,IFLAG,INOMB) IGETB(IJBUF,JJJ)=IAND(IALF2(IGET1(IJBUF,JJJ)),177B) C C-----DEFINE COMMON BLOCK STRUCTURE C CALL T!PMDFN(LU,LU,FORMN,FORMN,ICOMEN) C C-----CHECK TERMINAL TYPE AND INHIBIT ECHO C IF(ITYP .NE. 2645) RETURN ICTLB=0 C C-----ENABLE 3RD COMMON BLOCK C CALL TMCBE(0,FORMN) C C-----INITIALISE SCREEN CONTENT C CALL PUTCA(MBUFR,1H ,1) CALL BLAN(MBUFR,2,6) CALL MOVCA(0,1,MBUFR,8,2) CALL BLAN(MBUFR,10,6) CALL MOVCA(0,1,MBUFR,16,2) C C-----PRINT INTERACTIVE SCREEN ON THE CRT C 1 CALL TSESC(MBUFR) C C-----GET OPERATOR ANSWERS C 10 CALL TMRD(INPUT,-LENSC-1) IF(ITL.EQ.1 .AND. IGET1(INPUT,1).EQ.60440B) GOTO 18 IF(ITL .NE. LENSC) GOTO 1 C C-----PROCESS RECEIVED BLOCK-MODE BUFFER C C-----GET SELECTED FUNCTION C 18 IFD=1 IF(KPAR(IFD,1)) GOTO 20 IERNB=22 IF(IFLAG.EQ.0) GOTO 30 IERNB=14 IF(IFLAG.NE.3) GOTO 30 IH=IGET1(ISTRG,1) IF(IH.EQ.1HT) GOTO 40 SQUAL=0 STATE=0 IF(IH.EQ.1HL) SQUAL=-3 IF(IH.EQ.1HA) SQUAL=-2 IF(IH.EQ.1HD) SQUAL=-1 IF(IH.EQ.1HP) SQUAL=-4 IF(IH.EQ.1HS) SQUAL=10 IERNB=16 IF(SQUAL.EQ.0) GOTO 30 CALL MOVCA(ISTRG,1,MBUFR,1,1) IF(SQUAL.EQ.-4) GOTO 4000 C C-----SET UP FOR LOAD TRANSACTION SPECIFICATIONS C STATE(5)=-1 STATE(8)=-1 STATE(9)=100000B IF(SQUAL.EQ.-3) GOTO 7115 C C-----GET TRANSACTION NUMBER & SECURITY CODE C IFD=2 IF(KPAR(IFD,6)) GOTO 20 IERNB=8 IF(IFLAG.NE.1) GOTO 30 IERNB=19 IF(ISBTW(INOMB,1,9999)) GOTO 30 STATE(5)=-1 STATE(8)=INOMB FORMN=INOMB CALL CNUMD(INOMB,IPOB) IF(IPOB(3) .EQ. 2H 0) IPOB(3)=2H CALL MOVCA(IPOB,1,MBUFR,2,6) C C-----GET TRANSACTION SECURITY CODE C IFD=3 IF(KPAR(IFD,6)) GOTO 20 IERNB=17 IF(IFLAG.EQ.3.OR.IFLAG.EQ.2) GOTO 30 IF(IFLAG.EQ.0) INOMB=0 IF(INOMB.EQ.100000B) GOTO 30 STATE(9)=INOMB CALL MOVCA(INOMB,1,MBUFR,8,2) IF(SQUAL.EQ.10) STATE=INOMB IF(SQUAL.EQ.10.OR.SQUAL.EQ.-1) GOTO 4000 C C-----GET DISC FILE NAME C 7115 IFD=4 CALL BLAN(ISTRG,1,6) IF(KPAR(IFD,6)) GOTO 20 IERNB=15 IF(IFLAG.EQ.1.OR.IFLAG.EQ.2) GOTO 30 IERNB=22 IF(IFLAG.EQ.0) GOTO 30 IERNB=14 IF(IMBED(ISTRG,1,6)) GOTO 30 7160 CALL MOVEW(ISTRG,STATE,3) CALL MOVCA(ISTRG,1,MBUFR,10,6) IF(STATE.EQ.2H ) GOTO 4000 C C GET CARTRIDGE NUMBER C IFD=5 IF(KPAR(IFD,6)) GOTO 20 IERNB=17 IF(IFLAG.EQ.2.OR.IFLAG.EQ.3) GOTO 30 IF(IFLAG.EQ.0) INOMB=0 IF(INOMB.EQ.100000B) GOTO 30 STATE(4)=INOMB CALL MOVCA(STATE,7,MBUFR,16,2) GOTO 4000 C C-----CHECK FOR ABORT KEY C 20 IF(IFLAG.EQ.9) GOTO 40 IERNB=14 GOTO 30 C C-----ERROR MESSAGE OUTPUT C 30 CALL TSEOR(IERNB,IFD) GOTO 10 C C-----RETURN PROCESS C 40 CALL TMWR(RESET,8) CALL EXEC(100030B,DCMON,LU) GOTO 48 C-----AFTER DCMON SCHEDULE, WAIT 1 SECOND TO AVOID THE FMGR PROMPT C ON THE CRT BEFORE THE DCMON SCREEN. (PROVIDING THAT DCMON HAS C A HIGHER PRIORITY THAN FMGR) 42 CALL TMPZ(100) 48 RETURN C C-----CALL THE TRANSACTION SPEC. MANAGEMENT SUBROUTINE C 4000 CALL MOVEW(RESET,INPUT,8) CALL MOVEW(PROCS,INPUT(9),23) K=8 IF(SQUAL.EQ.-3 .OR. SQUAL.EQ.-2) K=31 CALL TMWR(INPUT,K) C-----PASSES IMAGE CRC & FLAGS TO "TSMG" CALL MOVEW(LOCKID,STATE(10),2) CALL TMSUB(TSMG) C C-----CHECK REQUEST TYPE/STATUS C IF(SQUAL .EQ. -3) GOTO 4020 IF(FMGST .NE. 0) GOTO 5000 IF(SQUAL.EQ.-4 .OR. SQUAL.EQ.10) GOTO 100 C C-----PRINT T.S. # ADDED OR DELETED C 4020 L=11 IF(STATE(L+1) .EQ. -30000) GOTO 295 4030 L=L+1 K=STATE(L) IF(K .EQ. -30000) GOTO 290 CALL MOVEW(14H Tr. Spec. # ,INPUT,7) CALL CNUMD(K,INPUT(8)) IF(FMGST.NE.0 .AND. STATE(L+1).EQ.-30000) GOTO 4050 CA LL MOVEW(12H succesfully,INPUT(11),6) CALL MOVEW(10H added. ,INPUT(17),5) IF(SQUAL.EQ.-1) CALL MOVEW(10H deleted. ,INPUT(17),5) I=21 4035 CALL TMWR(INPUT,I) GOTO 4030 C-----ERROR HAS OCCURS ON THAT TRANSACTION SPEC. 4050 CALL MOVEW(INPUT,INPUT(3),-10) INPUT(1)=6412B INPUT(2)=6412B CALL MOVEW(22H has not been added. ,INPUT(13),11) INPUT(24)=6412B CALL TMBWR(INPUT,24) CALL TSEOR(-FMGST,0) I=1 CALL MOVEW(30H Load operation is abo,INPUT(I),15) CALL MOVEW(20Hrted !! ,INPUT(I+15),10) I=I+24 FMGST=-18 GOTO 4035 C C-----TSMG ERROR MESSAGE C 5000 IERNB=-FMGST CALL TSESC(MBUFR) IFD=2 GOTO (30,30,5030,30,30,5060,5070,30,5300,5300,5300,5300,5300, .5200,5200,5300),IERNB C-----TRANSACTION ALREADY IN THE WORKING SET 5030 IF(SQUAL.EQ.-3) IFD=1 GOTO 30 C-----INTERNAL ERROR (TSMG OR CLOSE MEDIA) !! 5200 IERNB=IERNB+6 GOTO 5300 C-----BAD SECURITY CODE 5060 IFD=3 GOTO 30 C-----ILLEGAL MEDIA 5070 IFD=4 GOTO 30 C-----ANY OTHER ERROR (CURSOR ON THE FIRST FIELD) 5300 IFD=1 GOTO 30 C C C ******************** C * LISTING FUNCTION * ===================== C ******************** C C 100 CALL TMWR(RESET,8) IF(SQUAL.EQ.10) GOTO 300 C C-----DIRECTORY LIST ********************* C CALL TMWR(TITLE,63) CALL BLANC(INPUT,40) 220 IF(STATLN .EQ. 0) GOTO 250 DO 230 L=1,STATLN K=L*5-3 CALL MOVEW(STATE(K),INPUT(13),3) CALL JASC(STATE(K+3),INPUT,38,6) CALL JASC(STATE(K+4),INPUT,50,6) CALL TMWR(INPUT,30) 230 CONTINUE C STATE=STATE+STATLN CALL TMSUB(TSMG) IF(FMGST .NE. 0) GOTO 5000 GOTO 220 C 250 CALL BLANC(INPUT,40) INPUT=6412B INPUT(2)=6412B CALL JASC(STATE,INPUT,21,6) CALL MOVEW(8H ENTRIES,$"INPUT(14),4) IF(STATE .EQ. 0) CALL MOVEW(14H NO ENTRY,INPUT(11),7) IF(STATE .EQ. 1) CALL MOVEW(14H 1 ENTRY,INPUT(11),7) CALL MOVEW(18H IN THE DIRECTORY ,INPUT(18),9) CALL TMWR(INPUT,26) C C-----END OF LISTING OPERATION: WAIT FOR OPERATOR C 290 CALL TMWR(RETUN,25) CALL TMRD(INPUT,1) IF(ITL.EQ.1 .AND. IGET1(INPUT,1).EQ.60440B) GOTO 40 295 IF(FMGST .NE. 0) GOTO 5000 GOTO 1 C C-----LIST A TRANSACTION SPECIFICATIONS ********************* C 300 K=IAND(STATE(20)-1,377B) K1=STATE(6)/256 K2=IAND(STATE(6),377B) CALL TMWR(TITLE,29) CALL MOVEW(STATE,STATU(24),3) CALL JASC(STATE(4),STATU,88,6) CALL JASC(STATE(5),STATU,110,6) CALL JASC(K1,STATU,146,3) CALL JASC(K2,STATU,171,3) CALL JASC(K,STATU,230,4) CALL TMWR(STATU,122) C C-----CLOSE THE TRANSACTION IN THE WORKING SET C SQUAL=11 CALL TMSUB(TSMG) IF(FMGST.EQ.0) GOTO 290 CALL TMWR(OROR,9) GOTO 290 END END$ g$   92903-18522 1805 S C0122 &TSELB              H0101 ASMB HED . *** T S E SCREEN DATA *** NAM TSELB,7 92903-16520 REV.1805 780517 SPC 3 ********************************************************************** * * * NAME: TSELB TSE SCREEN DATA & ERROR MESSAGES * * SOURCE: &TSELB 92903-18522 * * BINARY: %TSELB ----NONE--- PART OF %TSE 92903-16520 * * * * PGMR: FRANCOIS GAULLIER * * * ********************************************************************** SPC 2 * ************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * ************************************************************** SPC 3 * ********************************************************* * * THIS SUBROUTINE IS USED BY THE T S E TMS-SUBROUTINE * * * TO DISPLAY A SCREEN MASK ON THE CRT. * * * * * * FORTRAN CALL : CALL TSESC(MBUFR) * * * * * ********************************************************* SPC 2 ENT TSESC,TSEOR EXT .ENTR,MOVCX,TMBWR,&MVW,&REMP SUP A EQU 0 B EQU 1 SKP GOFST DEC 00 GLOBAL SOURCE MBUFR OFFSET SPC 2 .MBFR BSS 1 ADDRESS OF THE MBUFR TO MOVE IN ISCRN TSESC NOP ENTRY POINT JSB .ENTR GET CALLING PARAMETERS DEF .MBFR ADRESS OF FIRST PARAMETER * x * MOVE MBUFR IN THE VARIABLE ZONE AREA * JSB MOVCX DEF *+6 DEF .MBFR,I ADDRESS OF FIRST MBUFR WORD DEF SOFST ADDRESS OF SOURCE OFSET TABLE DEF DOFST ADDRESS OF DESTINATION TABLE DEF GOFST ADDRESS OF GLOBAL SOURCE OFSET DEF FOMAT ADDRESS OF NUMERIC FORMAT TABLE * * PRINT THE SCREEN * JSB TMBWR USE TMS BUFFERED CALL TO NOT DEF *+3 BE SUSPENDED IN THIS SUBROUTINE DEF ZONE DEF LENGH * * RETURN TO CALLING PROGRAM * JMP TSESC,I * * SCREEN TO DISPLAY * * ZONE BYT 33,143,33,130 LOCK KEYBOARD, FORMAT MODE OFF BYT 33,155 MEMORY UNLOCK BYT 33,110,33,112 HOME UP, CLEAR DISPLAY * BYT 33,46 ASC 10,s0a0b0c1d0e0f1g1h0j0 SET 2645A INTERNAL JUMPERS BYT 113,00 * BYT 40,33,46,153,61,102 SET BLOCK MODE ON * * SOFT KEY ASSIGNMENTS * * KEY # 1 : NEXT FIELD * KEY # 2 : PREVIOUS FIELD * KEY # 4 : ABORT T S E PROGRAM * KEY # 5 : NEXT SCREEN * * BYT 33,46,146,61,141,61,153,61,114,11 NEXT FIELD BYT 33,46,146,61,141,62,153,62,114,33,151,40 PREVIOUS FIELD BYT 33,46,146,61,141,63,153,61,114,40 NOT USED BYT 33,46,146,62,141,64,153,61,114,141 ABORT BYT 33,46,146,61,141,65,153,64,114,33,110,33,144,40 NEXT SCREEN BYT 33,46,146,61,141,66,153,61,114,40 NOT USED BYT 33,46,146,61,141,67,153,61,114,40 NOT USED BYT 33,46,146,61,141,70,153,61,114,40 NOT USED * * LINE # : 1 * BYT 33,46,141,53,62,65,103,0 POSITION CURSOR - 26 ASC 11,TRANSACTION SET EDITOR BYT 15,12 * * LINE # : 2 * BYT 15,12 * * LINE # : 3 * ASC 17, - Select your mode of operation BYT 72,0 BYT 15,12 * * LINE # : 4 * ASC 3, BYT 33,46,144,104 BYT 114,0 BYT 33,46,144,100 ASC 20',oad a TS LIBRARY into the Working Set ASC 11, ) BYT 15,12 * * LINE # : 5 * ASC 3, BYT 33,46,144,104 BYT 101,0 BYT 33,46,144,100 ASC 22,dd a Transaction Specification to the Workin ASC 8,g Set BYT 51,0 BYT 15,12 * * LINE # : 6 * ASC 3, BYT 33,46,144,104 BYT 104,0 BYT 33,46,144,100 ASC 22,elete a Transaction Specification from the W ASC 13,orking Set ) ...... BYT 33,46,144,102,33,133 T0000 BYT 40,0 BYT 33,135,33,46,144,100 BYT 15,12 * * LINE # : 7 * ASC 3, BYT 33,46,144,104 BYT 120,0 BYT 33,46,144,100 ASC 20,rint a directory list of the Working Set BYT 33,46,141,53,62,60,103,0 POSITION CURSOR - 68 BYT 51,0 BYT 15,12 * * LINE # : 8 * ASC 3, BYT 33,46,144,104 BYT 123,0 BYT 33,46,144,100 ASC 22,tatus of a Transaction Specification in the ASC 6,Working Set BYT 33,46,141,53,64,103,0 POSITION CURSOR - 68 BYT 51,0 BYT 15,12 * * LINE # : 9 * ASC 3, BYT 33,46,144,104 BYT 124,0 BYT 33,46,144,100 ASC 22,erminate the Transaction Set Editor program BYT 33,46,141,53,61,66,103,0 POSITION CURSOR - 68 BYT 51,0 BYT 15,12 * * LINE # : 10 * BYT 15,12 * * LINE # : 11 * BYT 33,51,102,16 ASC 1,R, BYT 54,17 ASC 19, For Add, Delete or Status operations BYT 16,54 ASC 19,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,T * * LINE # : 12 * BYT 33,51,102,16 BYT 56,17 ASC 22, - Enter the Transaction specification NUMBE ASC 13,R ....................... BYT 40,0 BYT 33,46,144,102,33,133 T0001 ASC 3, BYT 33,135,33,46,144,100 BYT 40,16 BYT 56,0 * * LINE # : 13 *  BYT 33,51,102,16 BYT 56,17 ASC 22, and the transaction specification SECURI ASC 13,TY CODE ................. BYT 40,0 BYT 33,46,144,112,33,133 T0002 ASC 3, BYT 33,135,33,46,144,100 BYT 40,16 BYT 56,0 * * LINE # : 14 * BYT 33,51,102,16 ASC 22,F,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ASC 18,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,G * * LINE # : 15 * BYT 15,12 * * LINE # : 16 * BYT 33,51,102,16 ASC 1,R, BYT 54,17 ASC 14, For Load or Add operations BYT 16,54 ASC 22,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ASC 2,,,,T * * LINE # : 17 * BYT 33,51,102,16 BYT 56,17 ASC 22, - Enter the LIBRARY NAME: disc file or d ASC 10,evice (MT,LCTU,RCTU) BYT 33,46,141,53,61,66,103,0 POSITION CURSOR - 80 BYT 16,56 * * LINE # : 18 * BYT 33,51,102,16 BYT 56,17 ASC 22, on which the Transaction Specification is ASC 13, to be found ............. BYT 40,0 BYT 33,46,144,102,33,133 T0003 ASC 3, BYT 33,135,33,46,144,100 BYT 40,16 BYT 56,0 * * LINE # : 19 * BYT 33,51,102,16 BYT 56,17 ASC 12, - If the library is on: BYT 00,16 BYT 33,46,141,53,65,64,103,0 POSITION CURSOR - 80 BYT 56,0 * * LINE # : 20 * BYT 33,51,102,16 BYT 56,17 ASC 19, A minicartridge or a magnetic tape, BYT 40,0 BYT 33,46,144,104 ASC 6,load device. BYT 33,46,144,100 BYT 33,46,141,53,62,67,103,0 POSITION CURSOR - 80 BYT 16,56 * * LINE # : 21 * BYT 33,51,102,16 BYT 56,17 ASC 22, A disc, give the CARTRIDGE REFERENCE NUMB ASC 13,ER (Optional) ............ BYT 40,0 BYT 33,46,144,102,33,133 T0004 ASC 3, BYT 33,135,33,46,144,100 BYT 40,16 2 BYT 56,0 * * LINE # : 22 * BYT 33,51,102,16 ASC 22,F,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ASC 18,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,G * * LINE # : 23 * BYT 15,12 * * LINE # : 24 * BYT 33,142 UNLOCK THE KEYBOARD BYT 40,33,127,137 FORMAT MODE ON, SUP , * * * ENDSC EQU *-1 STRSC EQU ZONE LENGH ABS ENDSC-STRSC+1 * * SOURCE CHARACTER OFFSET TABLE * SOFST DEC 1 DEC 2 DEC 8 DEC 10 DEC 16 DEC 18 DEC -1 * * DESTINATION ISCRN ADDRESSES TABLE * DOFST DEF T0000 DEF T0001 DEF T0002,I DEF T0003 DEF T0004,I * * FORMAT OF NUMERIC DATA * FOMAT DEC 6 DEC 6 HED . *** T S E ERROR MESSAGE PRINTOUT *** * ********************************************************* * * * * * THIS SUBROUTINE IS USED BY THE T S E TMS-SUBROUTINE * * * TO DISPLAY AN ERROR MESSAGE AT THE BOTTOM OF THE CRT * * * THIS PROGRAM LEAVE THE TERMINAL IN BLOCK MODE, FORMAT * * * ON. * * * * * * FORTRAN CALL : CALL TSEOR(P1,P2) * * * P1 = ERROR MESSAGE NUMBER * * * P2 = WRONG FIELD ADRESS * * * IF = 0, THEN THE MESSAGE IS * * * PRINTED WHERE THE CURSOR IS AND * * * THE FORMAT MODE IS NOT RESORED. * * * * * ********************************************************* SPC 3 TAB BYT 33,111 DM1 DEC -1 NEGATIVE CONSTANT DM5 DEC -5 .MESA DEF MESSA ADDRESS OF THE AREA TO FILL IN LENBU NOP LENGTH OF ERROR MESSAGE TO BE DISPLAYED .FINL DEF ffFINLX ADDRESS OF LAST WORDS TO DUMP SPC 2 .NUBS BSS 1 MESSAGE NUMBER ADDDRESS .FILD BSS 1 WRONG FIELD NUMBER ADDDRESS TSEOR NOP ENTRY POINT JSB .ENTR GET CALLING PARAMETERS DEF .NUBS ADRESS OF FIRST PARAMETER * * MOVE ERROR MESSAGE IN OUTPUT BUFFER * LDA .NUBS,I GET ERROR MESSAGE NUMBER ADA AMES0 COMPUTE APPROPRIATE LDB A,I MESSAGE ADDRESS STB .ADRS STORE IT INA COMPUTE NEXT MESSAGE LDA A,I STARTING ADDRESS CMB,INB MINUS STARTING ADDRESS ADA B COMPUTE MESSAGE LENGTH STA MESLG SAVE IT LDA .ADRS BUFFER SOURCE ADDRESS LDB .MESA BUFFER DESTINATION ADDRESS JSB &MVW MOVE WORDS IN THE MESSA BUFFER MESLG BSS 1 MESSAGE LENGTH * LDA .FILD,I RECALL THE FIELD NUMBER SZA,RSS IS IT SPECAIL CASE ? JMP TSER3 YES, SKIP CODE TO SET UP FORMAT MODE * * INCLUDE FORMAT MODE ON, HOME UP CURSOR CTRL. CHAR. * LDA MESSB GET CONTROL CHARACTER STA B,I COPY IT IN MESSAGE BUFFER INB NEXT MESSA BUFFER ADDRESS STB MESLG SAVE MESSA BUFFER ADDRESS * * INCLUDE NUMBER OF NECESSARY TABS * LDA .FILD,I GET ERROR FIELD NUMBER ADA DM1 TRANSLATE FIELD # (FROM 0) CMA,INA # TABS NEGATIVE STA TBNUB SAVE # OF TABS SZA,RSS IF 0 : NO TABS CHARACTERS JMP SUITE JUMP TO END OF PREPARATION LDA B GET NEXT MESSA BUFFER ADDRESS LDB TAB GET TAB CHARACTER JSB &REMP INCLUDE TABS IN THE MESSA BUFFER TBNUB NOP NEGATIVE NUMBER OF TABS TO INCLUDE * * INCLUDE LAST CONTROL CHARACTERS * SUITE LDB TBNUB GET NEGATIVE NUMBER OF TABS CMB,INB MAKE IT POSITIVE ADB MESLG COMPUTE NEXT MESSA BUFFER ADDRESS LDA .FINL GET CONTROL CHARACTER ADDRESS JSB &MVW MOVE CONTROL CHARACTERS DEC 2 2 CONTROL WORDS * * CALCULATES FINAL MESSA BUFFER LENGTH * TSER3 LDA .BUFR GET STARTING BUFFER ADDRESS CMA,INA MAKE IT NEGATIVE ADA B COMPUTE FINAL STRING LENGTH STA LENBU STORE IT ADA DM5 SET UP SPECAIL LENGTH STA TBNUB WITH NO TAB CHARACTERS * LDA .FILD,I RECALL FIELD NUMBER SZA,RSS SPECIAL CASE ? JMP TSER5 YES, DO SPECAIL WRITE. * * PRINT ERROR MESSAGE USING TMS BUFFERED CALL * JSB TMBWR DEF *+3 .BUFR DEF BUFFR ADDRESS OF THE ERROR MESSAGE DEF LENBU * * RETURN TO CALLING PROGRAM * JMP TSEOR,I RETURN * * WRITE THE MESSAGE WHERE THE CURSOR IS * TSER5 JSB TMBWR DEF *+3 DEF BUFFR+5 DEF TBNUB JMP TSEOR,I * .ADRS EQU TBNUB * * * * BUFFER DATA AREA * BUFFR BYT 33,130,33,46,141,62,63,162,61,103 FORMAT OFF:POS.CURSOR BYT 33,112,33,46,144,103 CLEAR LINE, INVERSE VIDEO BLINKING ASC 2,ERRO BYT 122,33,46,144,100,00 END ENHANCEMENT ASC 2, : MESSA BSS 50 MESSAGE BUFFER * MESSB BYT 33,127 FORMAT MODE ON FINLX BYT 33,142 KEYBOARD ENABLE BYT 0,137 SUPPRESS , * * MESSAGE ADDRESS * AMES0 DEF AMES1-1 AMES1 DEF MES1 TS NOT FOUND IN THE WORKING SET DEF MES2 NO ROOM LEFT FOR TRANSACTION ADDITION ! DEF MES3 TS ALREADY IN THE WORKING SET DEF MES4 TRANSACTION NOT FOUND ON MEDIA ! DEF MES5 DELETE IMPOSSIBLE,TRANSACTION IN USE ! DEF MES6 BAD SECURITY CODE ! DEF MES7 ILLEGAL MEDIA ! DEF MES8 TS MUST BE DEFINED BY NUMBER DEF MES9 BAD IMAGE DATA-BASE DEF MES10 BAD FILE FOR THE STORAGE DEF MES11 BAD LU FOR THE STORAGE DEF MES12 TOO MANY DISC FILE FOR THAT TMP COPY DEF MES13 LOGGING IS REQUIRED ! DEF MES14 ILLEGAL CHARACTER, TRY AGAIN ! DEF MES15 THIS FIELD MUST BE AN ASCII STRING ! DEF MES16 THIS FUNCTION DOES NOT EXIST ! DEF MES17 THIS FIELD MUST BE AN NUMBER ! DEF MES18 LOAD ABORTED DUE TO ERRORS DEF MES19 TRANSACTION # MUST BE BEETWEN 0 AND 9999 ! DEF MES20 CLOSE MEDIA ERROR ! DEF MES21 INTERNAL 'FOMGT' ERROR !!! DEF MES22 AN ANSWER IS EXPECTED ! DEF MES23 ***************************************** * * MESSAGE STORAGE * MES1 ASC 23,Transaction specification not found in the wor ASC 05,king set ! MES2 ASC 21,No room left for transaction specification ASC 06, addition ! MES3 ASC 22,Transaction Specification already in the wor ASC 07,king set ! MES4 ASC 22,Transaction specification not found in libra ASC 2,ry ! MES5 ASC 22,Delete impossible, transaction specification ASC 06, is in use ! MES6 ASC 09,Bad security code. MES7 ASC 11,Illegal T.S. library ! MES8 ASC 23,Transaction Specification must be identified b ASC 07,y a number ! MES9 ASC 22,This T.S. and this TMP copy does not access ASC 10,the same Data-Base ! MES10 ASC 23,Unable to access or create the storage disc fi ASC 02,le ! MES11 ASC 23,The storage device is Illegal, Write-protected ASC 09,, Locked or Down ! MES12 ASC 23,This TMP copy accesses more than 15 storage di ASC 05,sc files ! MES13 ASC 22,This T.S. requires a TMP copy with Logging ! MES14 ASC 15,Illegal character, try again. MES15 ASC 18,This field must be an ASCII string ! MES16 ASC 15,This function does not exist ! MES17 ASC 15,This field must be a number ! MES18 ASC 23,Load operation has been aborted due to errors ASC 2,! MES19 ASC 22,Transaction specification # must be betwen ASC 06,1 and 9999 ! MES20 ASC 18,Internal close media error !!! **** MES21 ASC 15,Internal 'TSMG' error !!! **** MES22 ASC 12,An answer is expected ! MES23 ASC 1,-1 SPC 2 Q640END 6   92903-18531 1805 S C0222 &TSMG'              H0102 rASMB HED TRANSACTION SPECIFICATION MEMORY MANAGEMENT SUBROUTINE NAM TSMG,7 92903-16530 REV.1805 780601 SPC 2 * NAME: TSMG TS MEM. MANAGEMENT MODULE * SOURCE: &TSMG' 92903-18531 * BINARY: %TSMG' ----NONE--- PART OF %TSMG 92903-16530 * * PGMR: FRANCOIS GAULLIER SPC 2 * ************************************************************** * * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * * ************************************************************** SKP * * THIS PROGRAM IS A PART OF THE: * * DATA CAPTURE SOFTWARE * ( D A T A C A P ) * * IT USES FEATURES OF THE TERMINAL MONITOR SOFTWARE (TMS). * * THIS MODULE: TSMG IS A T.U.S. OF THE TMP * (TRANSACTION MONITOR PROGRAM) * * TSMG MANAGE THE MEMORY (ALLOCATION/DEALLOACTION) FOR * ALL THE TRANSATION SPECIFICATIONS (THE WORKING SET) * OF A TMP COPY. TSMG ALSO RETURN A STATE OF A TRANSACTION * SPECIFICATION WHEN 'ZTMP' NEED IT. * * * PARAMETERS ARE IN THE 2ND COMMON BLOCK: * * TSNUM T.S. NUMBER * SQUAL STATE QUALIFIER * J STATE INDEX * ERRCD STATUS RETURNED TO CALLING PROGRAM * STATE(38) BUFFER TO RETURN THE STATE PARAMETERS * STLEN STATE LENGTH RETURNED TO THE USER * * SQUAL = -1 DELETE A TRANS. SPEC. FROM THE WORKING SET * -2 ADD A TRANS. SPEC. TO THE WORKING SET * MEDIA(4) IS DEFINED IN STATE[1:4] * TSNUM(5) IS DEFINED IN STATE[5:9] * IMAGE FLAG & CRC ARE IN STATE[10:11] * -3 LOAD ALL TRANS. SPEC. CONTAINED ON THE MEDIA *  -4 GET DIRECTORY FOR LISTING PURPOSE * STATE(1) IS THE FIRST ENTRY NUMBER RETURNED * 0 SEARCH FOR STATE WITH QUALIFIER = 0 * 1 " " " " 1 * 2 " " " " 2 * 10 OPEN A T.S. (SECURITY CODE IN STATE(1) ) * 11 CLOSE A T.S. * 12 OPEN A T.S. FOR THE STORAGE * 13 CLOSE A T.S. FOR THE STORAGE * * ERRCD = 0 OPERATION SUCCESFULLY EXECUTED * NOT 0 DEFINE THE TYPE OF THE ERROR. * * *********************************************** F. GAULLIER (HPG) *** * HED WORKING STORAGE DESCRIPTIONS * * *********************** * ADDRESS --------->* * * ! * * * ! F ! * * * ! O ! * * * ! R ! * TR. SP. A * * ! M ! * * * ! ! * * * ! ! * * * ! + S ! * * * ! P ! *********************** * ! E ! ------>* * * ! C ! ! * * * ! I ! ! * * * ! F ! ! * TR. SP. C * * \ ! / I ! ! * * * \!/ C ! ! * * * . A ! ! * * * T ! ! *********************** * I ! ! --->* * * O ! ! ! * * * N ! ! ! * * * S ! ! ! * TR. SP. B * * ! ! ! * * * ! ! ! * * * ! ! ! * * * ! ! ! *********************** * ! ! ! * ! *<----- FWA * ! ! ! * ! * * ! ! ! * \!/ * * ! ! ! * . * * ! ! ! * * * ! ! ! * AVAILABLE * LENWS = LWA - FWA + 1 * ! ! ! * SPACE * * ! ! ! * * * ! ! ! * . * * ! ! ! * /!\ * * ! ! ! * ! * * ! ! ! * ! *<----- LWA * ! ! ! *********************** * D ! ! ! * "IN USE" COUNTER * * I ! ! ----+ POINTER TO T.S. B * * R ! ! * T.S. # OF T.S. B * * E ! ! *********************** * C ! ! * "IN USE" COUNTER * * T ! -------+ POINTER TO T.S. C * * O ! * T.S. # OF T.S. C * * R ! *********************** * Y ! * "IN USE" COUNTER * * ----------+ POINTER TO T.S. A * * * T.S. # OF T.S. A * * *********************** * <----- .DIRE * HED TRANSACTION SPECIFICATIONS MANAGEMENT SUBROUTINE ENT TSMG EXT .ENTR,&MVW,EXEC,TMDFN,TDCBS EXT TSRD,COR.A,OPEN,CREAT,CLOSE,.LURQ * A EQU 0 B EQU 1 SUP SPC 2 COM TSNUM,SQUAL,J,ERRCD,STATE(38),STLEN COM .COM. SPC 3 TSMG NOP JSB .ENTR DEF TSMG SPC 2 RSS JMP TSMG0 CLA STA *-3 CLEAR FIRST TIME FLAG * JSB EXEC DEF *+3 DEF D22 DEF D3 SWAP THE WHOLE PARTITION SPC 1 LDA XEQT GET ID SEG ADDR JSB COR.A GET FWA STA FWA CMA,INA LDB BGLWA GET BACKGROUND LWA ADA AVMEM CHECK IF PROGRAM RUN IN FORGR./BACKGR. SSA,RSS FOREGROUND ? LDB AVMEM YES, USE FORGROUND LWA ADB DM2 LDA FWA B=LWA CMA,INA INA STB .DIRE ADB DM1 STB LWA ADA B STA LENWS SPC 2 TSMG0 JSB TMDFN LINK WITH TMS DEF *+6 DEF TSNUM NO CB # 0 DEF TSNUM NO CB # 1 DEF TSNUM NO CB # 2 DEF TSNUM CB # 3 DEF .COM. CB END STA STATU SAVE DB & LOG FLAG SPC 2 CCB SET 'MEDIA OPEN FLAG' TO STB MDOPN MEDIA IS CLOSE * LDA SQUAL GET THE STATE QUALIFIER SSA IS IT TO ACCESS OR ADD/DELETE OPERATION JMP CHANG ADD / DELETE OPERATIONS ALF,RAL IT IS A STATE QUALIFIER IOR J MERGE WITH STATE INDEX STA TEMP2 * LDA TSNUM SEARCH IN DIRECTORY JSB DIREC JMP NOTIN TRANSACTION NOT PRESENT, ERROR = -1 * LDA SQUAL RECALL STATE QUALIFIER CPA D10 JMP TSOPN TSOPNA TRANSACTION CPA D11 JMP TSCLS TSCLS A TRANSACTION CPA D12 OPEN FOR STORAGE ? JMP OPENS CPA D13 CLOSE FOR STORAGE JMP CLOSS YES SPC 2 LDX PTFOM NOW, SEARCH A SPECIFIC STATE DSX LDB LENB1 INB NEXST STB A LBX B,I GO TO NEXT LINK SZB,RSS END OF TRANSACTION ? JMP NOSQ YES, STATE & INDEX NOT FOUND. STA TEMP1 INA LAX A,I GET SQ & J AND =B177 CPA TEMP2 IS IT THIS STATE ? RSS YES, RETURN STATE PARAMETERS TO USER JMP NEXST NO, LOOP UNTIL END OF TRANSACTION SPC 1 ISZ TEMP1 SET UP TO MOUVE THE STATE PARAMETERS LDA TEMP1 IN STATE ARRAY CMA,INA ADA B STA STLEN WORD COUNT FOR THE STATE ADA =D-39 SSA,RSS JMP INTER INTERNAL ERROR !! CCA ADA TEMP1 ADA PTFOM ABSOLUTE ADDR OF THIS STATE LDB .STAT TO ADDR MVW STLEN JMP EXIOK RETURN WITH GOOD STATUS SPC 2 NOSQ JMP WSOVF ERROR = -2 SPC 2 XEQT EQU 1717B AVMEM EQU 1751B BGLWA EQU 1777B HED OPEN / CLOSE A TRANSACTION SPECIFICATIONS SC? NOP LDA PTFOM ACCESS THE SECURITY CODE ADA D5 LDA A,I GET SECURITY CODE SZA,RSS DEFINED ? JMP SC?,I NO, NO CHECK TO PERFORM CPA STATE YES, CHECK WITH THE USER GIVEN ONE JMP SC?,I OK, SC COMPARE JMP BADSC SECURITY CODE NOT GOOD !! (ERROR = -8) SPC 1 TSOPN JSB SC? CHECK SECURITY CODE ISZ B,I BUMP "IN USE" COUNTER (FROM DIREC RETURN) LDA B,I RETURN "IN USE" COUNTER TO STA STATE+19 THE USER IN STATE(20) LDA PTFOM RETURN ALSO THE TRANSACTION INA SPECIFICATIONS HEADER LDB .STAT MVW LENB1 JMP EXIOK RETURN WITH GOOD STATUS * LENB1 DEC 10 SPC 4 TSCLS CCA DECREMENT THE CLOS2 ADA B,I "IN USE" COUNTER, STA B,I B WAS SET BY DIREC SUBROUTINE !! JMP EXIOK RETURN WITH GOOD STATUS * OPENS LDA =B400 (+1) ON LEFT BYTE JMP CLOS2 CLOSS LDA =B177400 (-1) ON LEFT BYTE JMP CLOS2 SPC 2 TEMP1 NOP TEMP2 NOP D5 DEC 5 D10 DEC 10 D11 DEC 11 D12 DEC 12 D13 DEC 13 DM2 DEC -2 HED LOAD / ADD TRANSACTION SPECIFICATIONS PROCESS CHANG LDB .ST12 GET ADDR OF STATE(12) STB PTSTA AND SAVE IT LDB =D-30000 INIT END OF BUFFER STB PTSTA,I * CPA =D-1 SPECIAL REQUEST JMP DEL DELETE A TRANSACTION SPEC. CPA =D-4 JMP DIR GET DIRECTORY REQUEST CPA =D-3 JMP LD00 LOAD ALL TRANSACTION SPEC SPC 2 LDA STATE+7 ADD A TRANSACTION: RECALL TRANSACTION # SSA TRANSACTION CALLED BY ]NUMBER ? JMP LD00 NO, GO TO LOAD IT JSB DIREC YES, CHECK THAT THIS TRANSACTION # RSS IS NOT ALREADY IN: RETURN OK JMP ALIN T.S. ALREADY LOADED, REJECT THE REQUEST SPC 3 * DETAILS OF THE LOAD-A-TRANSACTION-SPECIFICATIONS LIBRARY SPC 1 * 1) READ IN TRANSACTION SPECIFICATIONS USING TSRD PROGRAM * OPTION: MAXIMUM BUFFER LENGTH FOR BINARY RECORD * REWIND MEDIA * 2) SET MEDIA DESCRIPTOR TO NOT REWIND IT NEXT TIME * 3) CHECK IF THIS TRANSACTION NUMBER IS NOT ALREADY IN THE * TRANSACTION SPEC. LIBRARY * 4) IF TRANSACTION IMAGE, VERIFY THAT TMP ACCESS THE SAME * IMAGE DATA BASE * 5) IF THE TRANSACTION REQUIRED LOGGING, VERIFY THAT THE TMP * HAS A LOGGING CAPABILITY. * 6) CHECK STORAGE FILE DEFINITION, AND MODIFY STORAGE DEFINITION * AS REQUIRED. * 7) ADD A DIRECTORY ENTRY IN THE TRANSACTION DIRECTORY * 8) UPDATE POINTER TO AVAILABLE SPACE * ( FWA , LWA , LENWS ) * 9) IF NOT THE END-OF-FILE GOTO STEP 1. * 10) RETURN GOOD STATUS TO THE CALLING PROGRAM. SPC 3 LD00 LDA LENWS GET FREE SPACE LEN ADA =D-20 SECURITY ! SSA JMP WSOVF WORKING SET OVERFLOW STA INDIC SPC 1 JSB TSRD READ THE TRANSACTION SPECIFICATION DEF *+9 .STAT DEF STATE MEDIA DEF INDIC MAXIMUM LENGTH DEF IST STATUS RETURNED HERE DEF STATE+4 T.S. NAME DEF FWA,I BUFFER ADDR FOR BINARY DEF SOUBU BUFFER ADDR FOR SOURCE (11 WORDS ONLY) DEF IDCB IDCB BUFFER DEF * * CLB SET 'MEDIA OPEN FLAG' TO STB MDOPN MEDIA IS OPEN. SPC 1 LDA IST RECALL STATUS SZA JMP ER ERROR ! LDA STATE RECALL FIRST WORD OF MEDIA SSA,RSS AND MAKE IT NEGATIVE TO NOT CMA,INA OPEN OR REWIND THE MEDIA STA STATE * :*($ LDA FWA ADA D4 LDA A,I STA FNUM SET T.S. # STA PTSTA,I RETURN T.S. # TO TSE PROGRAM ISZ PTSTA BUMP POINTER NO OVERFLOW CHECK !!! LDB =D-30000 STB PTSTA,I SET END OF BUFFER JSB DIREC IS IT ALREADY IN THE LIBRARY RSS JMP ALIN YES, REJECT THIS ONE SPC 1 * CHECK THE DATA-BASE LEGALITY * LDA FWA ACCESS THE TRANSACTION TYPE ADA LENB1 ADA DM1 LDB A,I GET TRANSACTION TYPE STB TEMP1 SAVE TRANSACTION TYPE * ADA DM1 RETREIVE STORAGE LENGTH OF U & M QUESTION LDB A,I STORAGE LENGTH FOR M-QUESTION ADA DM1 ADB A,I ADD THE STORAGE LENGTH FOR U-QUESTION STB LNU&M SAVE STORAGE LENGTH FOR U&M-QUESTION * LDB TEMP1 RECALL TRANSACTION TYPE RBR,SLB TRANSACTION USE A DATA-BASE ? RSS JMP LD030 NO, DO NOT CHECK LEGALITY LDA STATU GET IMAGE DEFINED FLAG ALF,ALF RAL SSA,RSS TMP COPY ACCESS IMAGE ? JMP BADDB NO, REJECT THE TRANSACTION LDA STATE+10 GET DATA-BASE CRC CPA SOUBU+3 COMPARE WITH THE TS RSS YES, OK JMP BADDB NO, REJECT THE TRANSACTION SPC 1 LD030 LDA TEMP1 NOW VERIFY LOGGING DEVICE IF NEEDED RAL,RAL SSA,RSS TRANSACTION REQUIRES LOGGING ? JMP LD032 NO, CONTINUE LDA STATU YES, VERIFY THAT THE TMP HAS A LOGGING ALF,ALF (BIT 7 OF THIS WORD) SSA,RSS TMP HAS LOGGING ? -* JMP LOGER NO, REJECT THE TRANSACTION SPC 1 LD032 LDX FWA NOW CHECK VALIDITY OF STORAGE DSX SPECIFICATION. LDB LENB1 SEARCH STORAGE STATE IN THE INB THE TRANSACTION SPECIFICATION LD035 STB A LBX B,I GOTO NEXT STATE SZB,RSS END OF T.S. ? JMP LD090 NO STORAGE STATE ! STA TEMP1 INA LAX A,I GET STATE QUALIFIER AND INDEX AND =B177 ISOLATE SQ & J CPA =B141 STORAGE STATE (SQ=3,J=1) ? RSS YES, GO CHECK IT JMP LD035 NO, GOTO NEXT STATE * CXA RECALL STARTING ADDR. OF THE TS ADA TEMP1 ADD OFSET IN THE TS ADA D2 SKIP FORWARD POINTER & ... LD040 STA TEMP2 AND SAVE POINTER LDA TEMP2,I GET STORAGE CODE AND ALF AND =B17 ISOLATE IT SZA,RSS END OF STORAGE SATE ? JMP LD090 YES CPA D1 STORAGE CODE = 1 JMP LD050 YES, CHECK FILE NAME CPA D3 STORAGE CODE = 3 JMP LD050 YES, CHECK FILE NAME JMP LD090 FILE STORAGE DEFINITION IS COMPLETED SPC 1 LD050 LDA TEMP2 SET UP FILE NAME, SC, CR ADDR INA STA LD053 FILE NAME ADDR. ADA D3 STA LD056 CR# ADDR. INA STA LD055 SC ADDR. LDA .FDCB RESET OPEN FLAG ADA D9 CLB STB A,I * LD052 JSB TDCBS TRY TO SAVE THE DCB DEF *+3 LD053 NOP FILE NAME ADDR. .FDCB DEF FDCB DCB ADDR. INA BUMP RETURN ERROR CODE SSA,RSS SUCCESFUL OR ALREADY SAVED ? JMP LD080 YES, SET UP STORAGE CODE AND CONTINUE CPA DM2 DIRECTORY FULL ? JMP TOOFL YES, REJECT TRANSACTION AND REPORT ERROR * JSB OPEN THIS IS A NEW FILE, DEF *+8 TRY TO OPEN IT DEF FDCB DCB DEF TEMP ERROR CODE (FILE TYPE) DEF LD053,I FILE NAME DEF kD0 EXCLUSIVE OPEN LD055 NOP SECURITY CODE LD056 NOP CARTRIDGE REF # DEF D144 DCB SIZE SZA,RSS TYPE 0 FILE ? JMP LD060 YES, SPECIAL PROCESSING * CPA D55 DISC FILE OK ? JMP LD052 YES, SAVE DCB AND CONTINUE CPA DM6 FILE DOES NOT EXIST ? JMP LD070 YES, GO TO CREAT IT JMP LD066 FILE IS LOCKED OR BAD, CLOSE AND RETURN ERROR * LD060 LDA =B20000 IT IS A FILE TYPE 0 STA TEMP2,I CHANGE THE STORAGE CODE TO 2 LDA FDCB+3 GET THE LU AND B77 MASK LU STA LD053,I AND SAVE IT IN PLACE OF FILE NAME JSB .LURQ GET THE 'BYPASS LU LOCK' WORD SZA LU LOCKED ? JMP LD065 YES, REJECT TS AND REPORT ERROR * LDA LD053,I RECALL LU IOR B600 SET UP DYNAMIC STATUS REQUEST STA TEMP3 JSB EXEC DO THE DYNAMIC STATUS REQUEST DEF *+3 TO SET UP AN UP-TO-DATE STATUS DEF D3 CONTROL REQUEST DEF TEMP3 CONWD = LU+600B * JSB EXEC GET STATUS DEF *+6 DEF D13 STATUS REQUEST DEF LD053,I LU DEF TEMP3 STAT 1 DEF TEMP4 STAT 2 DEF TEMP5 STAT 3 * LDA TEMP5 RECALL LU STATUS SSA LU DOWN ? JMP LD065 YES, REJECT TS AND REPORT ERROR LDA TEMP3 RECALL EQT WORD # 5 AND =B140000 ISOLATE DN BITS CPA =B40000 EQT DOWN ? JMP LD065 YES, REJECT TS AND REPORT ERROR LDA TEMP3 AND =B76 ISOLATE STATUS BITS (WRITE ENABLE & ERROR) SZA ANYTHINGS WRONG ? JMP LD065 YES, REPORT BAD LU ERROR LDA TEMP3 NO, CHECK DEVICE TYPE ALF,ALF GET FROM EQT5 THE DVR TYPE AND B77 MASK DVR TYPE CPA B23 MAG-TAPE ? JMP LD066 YES, OK * LD065 LDA =D30000 REPORT BAD LU ERROR STA TEMP BUT CLOSE THE FILE FIRST * LD06N6 JSB CLOSE CLOSE THE FILE DEF *+2 BECAUSE IT IS TYPE 0 OR A BAD FILE DEF FDCB SSA CLOSE OK ? JMP BADST NO, REJECT TS AND REPORT ERROR LDA TEMP RECALL FILE TYPE/OPEN ERRCD SZA,RSS WAS IT OK ? JMP LD087 YES, GO TO NEXT STORAGE CODE CPA =D30000 BAD LU ERROR ? JMP BADLU YES, JMP BADST NO, BAD STORAGE FILE SPC 1 LD070 JSB CREAT TRY TO CREATE THE FILE DEF *+9 DEF FDCB DCB DEF TEMP ERROR CODE DEF LD053,I FILE NAME DEF D128 NUMBER OF BLOCK DEF D55 FILE TYPE DEF LD055,I SC DEF LD056,I CR DEF D144 DCB SIZE SSA CREATE OK ? JMP BADST NO, REJECT THAT TRANSACTION SPEC. * JMP LD052 YES, GO SAVE DCB AND CONTINUE SPC 1 LD080 LDA =B10000 CHANGE THE STORAGE CODE TO 1 STA TEMP2,I SPC 1 LD087 LDA TEMP2 GO TO NEXT STORAGE CODE ADA D6 JMP LD040 LOOP UNTIL END OF STORAGE STATE SPC 2 LD090 LDB FWA UPDATE WORKING STORAGE POINTER LDY LWA AND DIRECTORY. ADB FWA,I ADD T.S. LENGTH LDA FNUM RECALL T.S. # SAY 0B PUT T.S. # IN DIRECTORY DSY LDA FWA RECALL ADDRESS OF THE T.S. IN BUFFER SAY 0B PUT T.S. ADDR IN DIRECTORY DSY CLA SAY 0B CLEAR "IN USE" COUNTER DSY EXIT2 STB FWA SAVE NEW START OF WORKING STORAGE STY LWA SAVE NEW END OF WORKING STORAGE CMB,INB ADB LWA COMPUTE NEW LENGTH OF THE WORKING STORAGE INB STB LENWS SAVE NEW LENGTH OF WORKING STORAGE LDA SQUAL CPA =D-3 IS IT THE LOAD REQUEST ? JMP LD00 YES, CONTINUE TO ADD TRANSACTION SPEC. CPA =D-1 IS IT THE DELETE REQUEST ? JMP EXIOK YES, EXIT * CLSMD JSB CLMED CLOSE MEDIA JMP CLSER CLOSE MEDIA ERROR RETUWRN JMP EXIOK * TEMP3 NOP TEMP4 NOP TEMP5 NOP LNU&M NOP SPC 2 CLMED NOP CLOSE THE MEDIA IF IT WAS OPEN LDA MDOPN RECALL MEDIA OPEN FLAG SZA OPEN ? JMP CLME7 NO, DON'T CLOSE IT JSB TSRD YES, CLOSE THE MEDIA DEF *+9 DEF STATE MEDIA DEF D3 CLOSE REQUEST DEF IST STATUS RETURNED HERE DEF * DUMMY DEF SOUBU DUMMY BIN BUFFER DEF SOUBU DUMMY SOURCE BUFFER DEF IDCB IDCB BUFFER DEF * HEADER INFO (NEVER RETURNED) CCB CLEAR 'MEDIA OPEN FLAG' STB MDOPN * LDA IST RECALL STATUS SZA,RSS CLME7 ISZ CLMED YES, RETURN P+2 JMP CLMED,I * MDOPN NOP OPEN MEDIA FLAG SPC 1 EXIOK CLA RETURN GOOD STATUS TO CALLING PROGRAM. EXIT STA ERRCD JSB CLMED CLOSE MEDIA IF NECESSARY NOP ERROR RETURN JMP TSMG,I SPC 1 * * TSRD (TRANSACTION SPECIFICATION LIBRARY READ) ERROR * ER CPA D2 END OF FILE ? JMP EOF CPA D3 WS OVERFLOW ? JMP WSOVF CPA D7 SECURITY CODE ERROR ? JMP BADSC CPA D4 ILLEGAL PARAMETERS ? JMP INTER YES, INTERNAL ERROR JMP BADMD ILLEGAL MEDIA SPC 2 FWA DEF WS FWA OF AVAILABLE SPACE LWA DEF .WSE-1 LWA OF AVAILABLE SPACE LENWS ABS .WSE-WS (LWA - FWA + 1) AVAILABLE SPACE LENGTH .DIRE DEF .WSE END OF DIRECTORY ADDR + 1 SPC 3 FNUM NOP INDIC NOP IST NOP STATU NOP SOUBU BSS 11 IDCB BSS 144 .ST12 DEF STATE+11 PTSTA NOP FDCB BSS 144 D144 DEC 144 * B600 OCT 600 B77 OCT 77 B23 OCT 23 D0 DEC 0 D1 DEC 1 D2 DEC 2 D3 DEC 3 D4 DEC 4 D6 DEC 6 D7 DEC 7 D9 DEC 9 D55 DEC 55 D128 DEC 128 DM6 DEC -6 HED DELETE A TRANSACTION SPECIFICATIONS PROCESS * DETAILS OF THE DELETE-A-TRANSACTION-SPECIFICATIONS OPERATION SPC 1 * 1) CHECK THAT THIS T.S. IS IN THE WORKING SET * 2) CHECK SECURITY CODE * 3) SUPPRESS THE ENTRY IN THE T.S. DIRECTORY * 4) REPACK THE WORKING SET MEMORY TO SUPPRESS THIS T.S. * AND RETREIVE THE MEMORY SPACE * 5) UPDATE IN ALL NEEDED DIRECTORY ENTRY THE POINTER TO * THE T.S. TO REFLECT THE CHANGE * 6) UPDATE POINTER TO AVAILABLE SPACE * ( FWA , LWA , LENWS ) * 7) RETURN GOOD STATUS TO THE CALLING PROGRAM. SPC 3 DEL LDA STATE+7 CPA DM1 T.S. DEFINED BY NUMBER ? JMP MUST# NO, DELETE MUST BE DONE BY T.S. NUMBER STA PTSTA,I YES, RETURN TS # TO TSE PROGRAM ISZ PTSTA TO PRINT IT ON THE CRT LDB =D-30000 SET END OF BUFFER FLAG STB PTSTA,I JSB DIREC SEARCH IN DIRECTORY JMP NOTIN T.S. NOT FOUND SZA T.S. FOUND, IS IT "IN USE" ? JMP INUS YES, NO DELETE ALLOWED. CMB,INB SETUP TO REPACK THE DIRECTORY ADB LWA INB NEGATIVE WORD COUNT STB DEL3 LDA STATE+8 STA STATE JSB SC? CHECK SECURITY CODE * SZB,RSS IS THAT THE LAST T.S. IN ? JMP DEL9 YES, SPECIAL AND EASY CASE SPC 1 LDA LWA INA LDB A ADB D3 SET FROM & TO ADDR JSB &MVW MOUVE WORD BACKWORD DEL3 NOP INA LDA A,I GET ADDR OF NEXT T.S. (FROM ADDR) INB SAVE FIRST ADDR. OF T.S. POINTER STB DIREC TO NOT UPDATE. LDB PTFOM,I GET OLD T.S. LENGTH CMB,INB STB TEMP AND SAVE NEG LENGTH LDB A COMPUTE LENGTH TO MOUVE CMB,INB ADB FWA STB DEL3 LDB PTFOM GET TO ADDR MVW DEL3 REPACK T.S. BUFFER * LDB LWA NOW UPDATE T.S. POINTER WORD IN THE ADB D2 DIRECTORY DEL5 ADB D3 CPB DIREC END OF UPDATE FIELD ? JMP DEL7  YES, GOTO FINISH THE DELETE PROCESS LDA B,I NO, UPDATE POINTER ADA TEMP SUSTRACTING THE DELETE T.S. LEN STA B,I JMP DEL5 LOOP UNTIL END OF UPDATE FIELD SPC 1 DEL7 LDB TEMP ADB FWA COMPUTE NEW FWA DEL8 LDY LWA ADY D3 COMPUTE NEW LWA JMP EXIT2 AND RETURN TO CALLER * DEL9 LDB PTFOM THIS IS THE NEW FWA JMP DEL8 RETURN HED GET TRANSACTION SPECIFICATIONS DIRECTORY PROCESS DIR LDA =D-6 TRANSFERT ONLY 6 DIRECTORY ENTRIES AT STA TEMP1 A TIME. * LDA STATE RECALL THE FIRST ENTRY NUMBER MPY D3 TO COMPUTE THE DIRECTORY POINTER ADA LWA INA STA TEMP SAVE THE INITIAL DIRECTORY POINTER LDB .STAT INITIALISE THE TO POINTER INB SKIP THE FIRST WORD SPC 1 DIR03 CPA .DIRE END OF DIRECTORY ? JMP DIR05 YES, RETURN INA NO, BUMP DIRECTORY POINTER STA TEMP2 AND SAVE IT LDA A,I GET TRANS. SPEC. ADDR INA SKIP TS LENGTH MVW D5 AND MOVE TS NAME, NUMBER & SC LDA TEMP2 RESTORE DIRECTORY POINTER ADA D2 ISZ TEMP1 TRANSFERT MORE ENTRY ? JMP DIR03 YES, CONTINUE * DIR05 LDB TEMP NO, COMPUTE THE NUMBER OF ENTRY CMB,INB TRANSFERED AND RETURN ADA B CLB DIV D3 BACK INTO NUMBER OF ENTRY SZB JMP INTER STA STLEN SET THE NUMBER OF ENTRY TRANSFERED JMP EXIOK AND RETURN HED UTILTY VARIABLES & CONSTANTS AREA DIREC NOP SEARCH IN T.S. DIRECTORY STA TEMP LDB LWA BEGIN OF DIRECTORY - 1 DIRE3 INB CPB .DIRE END OF DIRECTORY ? JMP DIREC,I YES, T.S. NOT FOUND. ADB D2 LDA B,I GET T.S. # FROM DIRECTORY CPA TEMP IS IT THIS T.S. ? RSS JMP DIRE3 NO, LOOP UNTIL END OF DIRECTORY ADB DM1 LDA B,I .*($ STA PTFOM SAVE POINTER TO T.S. ADB DM1 LDA B,I EXIT WITH A = "IN USE" COUNTER ISZ DIREC RETURN T.S. FOUND JMP DIREC,I * TEMP NOP PTFOM NOP SPC 2 NOTIN CCA,RSS RETURN "T.S. NOT IN " STATUS TO CALLER SPC 1 WSOVF LDA =D-2 RETURN "WS OVERFLOW" STATUS TO CALLER JMP EXIT SPC 1 ALIN LDA =D-3 RETURN "T.S. ALREADY IN" STATUS TO CALLER JMP EXIT SPC 1 EOF LDA =D-4 RETURN "T.S. NOT ON TAPE" STATUS TO CALLER LDB SQUAL CPB =D-3 IS IT LOAD REQUEST JMP CLSMD YES, CLOSE MEDIA AND RETURN JMP EXIT SPC 1 INUS LDA =D-5 RETURN "T.S. IN USE" STATUS TO CALLER JMP EXIT SPC 1 MUST# LDA =D-8 RETURN "MUST BE T.S. #" STATUS TO CALLER JMP EXIT SPC 1 BADSC LDA =D-6 RETURN "BAD SC" STATUS TO CALLER JMP EXIT SPC 1 BADMD LDA =D-7 RETURN "ILLEGAL MEDIA " STATUS TO CALLER JMP EXIT SPC 1 BADDB LDA =D-9 RETURN "BAD DATA-BASE" STATUS TO CALLER JMP EXIT SPC 1 BADST LDA =D-10 RETURN "BAD FILE" STATUS TO CALLER JMP EXIT SPC 1 BADLU LDA =D-11 RETURN "BAD LU" STATUS TO CALLER JMP EXIT SPC 1 TOOFL LDA =D-12 RETURN "TOO MANY DISC FILE FOR STORAGE" STATUS JMP EXIT SPC 1 LOGER LDA =D-13 RETURN "LOGGING IS REQUIRED" STATUS JMP EXIT SPC 1 CLSER LDA =D-14 RETURN "CLOSE MEDIA ERROR" TO CALLER JMP EXIT SPC 1 INTER LDA =D-15 RETURN "INTERNAL ERROR" STATUS TO CALLER JMP EXIT SPC 3 DM1 DEC -1 D22 DEC 22 SPC 3 UNS WS BSS 1 .WSE EQU * END g* # 92903-18540 1805 S C0122 &STORA              H0101 FTN4 SUBROUTINE STORA, 92903-16540 REV.1805 780507 C C C NAME: STORA STORAGE MODULE # 1 C SOURCE: &STORA 92903-18540 C BINARY: %STORA 92903-16540 THIS IS %STORA C C PGMR: 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: STORA IS A T.U.S. OF THE TMP C (TRANSACTION MONITOR PROGRAM) C C C STORA = 1ST STORAGE MODULE (IMAGE STORAGE) C C THIS TMS-SUBROUTINE IS THE STORAGE MODULE OF DACORS C IT ACTUALLY STORE INTO AN IMAGE/1000 DATA BASE AND SCHEDULE THE C NON TMS PROGRAM TO STORE ON SEQUENTIAL FILES (MINI CARTRIDGED, C MAG TAPE OR DISC FILE) OR TO EXECUTE THE USER WRITTEN STORAGE C MODULE. C C********************************************** F. GAULLIER (HPG) *** C C INTEGER TSMG(3),STORB(3),FORMN,SQUAL,FMGST .,STATE,STATLN,OBUF,OBULN,OBULNX .,DSN,INBR(50),IVALU(200),IMSTST,IMGSTA(6) C C *** DEFINE FLAGS LOGICAL FOT C *** DEFINE LOGICAL FUNCTIONS LOGICAL ISBIT,JULIB C C*** TRUE COMMON C COMMON ICOM00(5) C*** 1ST COMMON BLOCK COMMON LU,ICTLB,ITYP,IST,ITL,ICRST,LOCKID(2),ISAVRT(6) COMMON J,INDEX C*** 2ND COMMON BLOCK COMMON NUQ,NMQ,ITSNUM,INDEXM,OBULN,L1,L2,OBUF(250) C*** 3RD COMMON BLOCK COMMON FORMN,SQUAL,JNDEX,FMGST,STATE(38),STATLN C C*** 4TH COMMON BLOCK C COMMON IMSTST(230),IMSTPT C C*** LAST COMMON WORD C COMMON ICOMEN C DATA TSMG/2HTS,2HMG,2H / DATA STORB/2HST,2HOR,2HB / C C-----DEFINE LOCAL FUNCTION C IRS12(M0)=IAND(IALF2(M0),360B)/16 C C C-----SWAP JUST THE PROGRAM AREA C CALL EXEC(22,2) C C------DEFINE COMMON BLOCK STRUCTURE, C C CALL TMDFN(ICOM00,LU,NUQ,FORMN,IMSTST,ICOMEN) CALL TMDFN(LU,LU,NUQ,FORMN,IMSTST,ICOMEN) C IF(LU.NE.2 .OR. ITYP.NE.7905) RETURN C CALL TMCBE(0,FORMN) FORMN=ITSNUM C C-----GET STORAGE STATE FROM FORM-MMGT ROUTINE C 20 SQUAL=3 JNDEX=1 INDEX=1 25 CALL TMSUB(TSMG) IF(FMGST .NE. 0) GOTO 8010 C C-----IF LAST STORAGE STATE GET, UNLCK THE TS C IF( ISBIT(STATE,7) ) GOTO 28 SQUAL=13 CALL TMSUB(TSMG) IF(FMGST .NE. 0) GOTO 8020 C 28 J=2 IF(JNDEX .NE. 1) GOTO 55 C-----SETUP SPECIAL STORAGE ITEM (TR. ID - LU # - DATE - TIME) L=1 IF(.NOT. ISBIT(STATE,11) ) GOTO 100 CALL JASC(ITSNUM,OBUF(L),-1,4) L=L+2 100 IF(.NOT. ISBIT(STATE,10) ) GOTO 110 OBUF(L)=IASC(OBUF(OBULN)) L=L+1 110 CALL EXEC(11,INBR,IVALU) IF(.NOT. ISBIT(STATE,9) ) GOTO 120 OBUF(L)=IASC(IVALU-1900) IF( JULIB(INBR(5),IVALU,N,I) ) GOTO 8040 OBUF(L+1)=IASC(I) OBUF(L+2)=IASC(N) L=L+3 120 IF(.NOT. ISBIT(STATE,8) ) GOTO 130 OBUF(L)=IASC(INBR(4)) OBUF(L+1)=IASC(INBR(3)) C-----SET UP BUFFER FOR 'STORB' ROUTINE 130 CALL MOVEW(STATE(2),OBUF(OBULN+2),19) 30 K=IRS12(STATE(J))+1 GOTO (5000,35,40,8050,50,55),K C-----STORAGE ON FILE (USE OF TMS-FMP CALL) 35 CONTINUE C-----STORAGE ON DEVICE DEFINED BY LU 40 J=J+6 GOTO 30 C-----STORAGE FROM A USER WRITTEN PROGRAM 50 J=J+4 GOTO 30 C-----STORAGE IN AN IMAGE/1000 DATA-BASE 55 IF(J.EQ.2 .AND. JNDEX.EQ.1) OBUF(OBULN+2)=0 IF(JNDEX .EQ. 1) CALL TMC^BE(0,IMSTST) CALL MOVEW(STATE(J),IMSTST(INDEX),STATLN-J+1) INDEX=INDEX+STATLN-J+1 JNDEX=JNDEX+1 IF( ISBIT(STATE,7) ) GOTO 25 C C############################################################ D WRITE(50,9875)(IMSTST(I),I=1,INDEX-1) D WRITE(50,9876)INDEXM D9875 FORMAT(8@8) D9876 FORMAT(" INDEX MAXIMUM: "I6,2/) C######################################################## C INDEX=0 500 IF(INDEX .EQ. INDEXM) GOTO 5000 INDEX=INDEX+1 IMSTPT=1 700 IMSC=IAND(IMSTST(IMSTPT),17B) IF(IMSC .EQ. 0) GOTO 500 DSN=IAND(IMSTST(IMSTPT),176B)/16 FOT = ISBIT(IMSTST(IMSTPT),10) K=IMSTST(IMSTPT+1) GOTO (1000,1000,3000),IMSC C C-----ADD/UPDATE OPERATION C 1000 INBR=K IMSTPT=IMSTPT+2 IMBUPT=1 DO 1050 I=1,K INBR(I+1)=IGETB(IMSTST(IMSTPT),2) L=IGETB(IMSTST(IMSTPT),1) IMSTPT=IMSTPT+1 IOBUPT=IMSTST(IMSTPT) IMSTPT=IMSTPT+1 J=INDEX IF(IOBUPT .LE. L1) J=1 CALL MOVEW(OBUF(IOBUPT+(J-1)*L2),IVALU(IMBUPT),L) IMBUPT=IMBUPT+L 1050 CONTINUE C################################################################## D WRITE(50,6754)INDEX,IMSC,FOT,K,ISAVRT D .,(INBR(I),I=1,15),(IVALU(I),I=1,40) D6754 FORMAT(" INDEX="I6,5X"CODE:"I2/" FOT="@8,/," N ITEM=",I5, D .,/6I10,/,15I5,/,5(8@8,/),/) C################################################################## IF(INDEX.NE.1 .AND. FOT) GOTO 700 IF(IMSC .EQ. 2) GOTO 2000 C-----EXECUTE THE ADD (PUT IN THE DATA-BASE) CALL TBPUT(DSN,IMGSTA,INBR,IVALU) IF(IMGSTA .EQ. 0) GOTO 700 IF(IMGSTA.EQ.105 .OR. IMGSTA.EQ.106) GOTO 8200 GOTO 8070 C-----EXECUTE THE UPDATE (UPDATE IN THE DATA-BASE) 2000 CALL MOVEW(OBUF(OBULN-6*INDEX),ISAVRT,6) CALL TBUPD(DSN,IMGSTA,INBR,IVALU) IF(IMGSTA .EQ. 0) GOTO 700 GOTO 8075 C C-----DELETE OPERATION C 3000 IMSTPT=IMSTPT+1 IF(INDEX.NE.1 .AND. FOT) GOTOG 700 CALL MOVEW(OBUF(OBULN-6*INDEX),ISAVRT,6) C###################################################################### D WRITE(50,7677)INDEX,DSN,ISAVRT D7677 FORMAT(" INDEX="I6,5X"DELETE DSN ="I3,/,6I10) C#################################################################### CALL TBDEL(DSN,IMGSTA) IF(IMGSTA .EQ. 0) GOTO 700 GOTO 8080 C C-----LAUNCH PROCESS 'STORB' IF NEEDED C 5000 OBULN=OBULN+2 C CALL LOGEV(ICOM00(2),OBUF(OBULN-2),2000,0,ITSNUM,0,0) IF(IRS12(OBUF(OBULN)) .EQ. 0) RETURN CALL TMPRO(3,STORB,NUQ) RETURN C C-----FATAL ERROR PROCESSING C 8010 IERR=501 GOTO 8500 8020 IERR=502 GOTO 8500 8040 IERR=503 GOTO 8500 8050 IERR=505 GOTO 8500 8070 IERR=520 GOTO 8550 8075 IERR=521 GOTO 8550 8080 IERR=522 GOTO 8550 C-----DATA SET IS FULL ! (IF LOGGING IS USED, WARNING 25 ONLY) 8200 IERNB=65 IF( ISBIT(OBUF(OBULN+1),13) ) IERNB=25 ASSIGN 700 TO IERTN CALL TMPER(IERTN,IERNB,ITSNUM,OBUF(OBULN),DSN,0) C-----INTERNAL ERROR ! 8500 IMGSTA=0 8550 CALL TMPER(0,99,ITSNUM,OBUF(OBULN),IERR,IMGSTA) RETURN END END$ j  92903-18550 1805 S C0122 &STORB              H0101 FTN4 SUBROUTINE STORB, 92903-16550 REV.1805 780524 C C C NAME: STORB STORAGE MODULE # 2 C SOURCE: &STORB 92903-18550 C BINARY: %STORB 92903-16550 THIS IS %STORB 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 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: STORB IS A T.U.S. OF THE TMP C (TRANSACTION MONITOR PROGRAM) C C C STORB = 2ND STORAGE MODULE (FILE ACCESS & USER STO.) C C********************************************** F. GAULLIER (HPG) *** C C C DIMENSION IBUF(250),IDCB(144),IREG(2) INTEGER DATA,AREG,BREG EQUIVALENCE (REG,IREG(1),AREG),(BREG,IREG(2)) C *** LOGICAL FUNCTION LOGICAL WRITF,POST,TDCBS,TDCBR,ISBIT C C*** TRUE COMMON C COMMON ICOM00(5) C C*** 1ST COMMON BLOCK C COMMON LU,ICTLB,ITYP,IST,ITL,ICRST,LOCKID(2),M,LUTERM,ITSN . ,ITT C C*** 2ND COMMON BLOCK C COMMON NUQ,NMQ,J,INDEXM,K,LUQ,LMQ,DATA(250) C C*** LAST COMMON WORD C COMMON ICOMEN C C-----DEFINE LOCAL FUNCTION C IRS12(M0)=IAND(IALF2(M0),360B)/16 IRS8(M2)=IAND(IALF2(M2),377B) C C------DEFINE COMMON BLOCK STRUCTURE, C C CALL TMDFN(ICOM00,LU,NUQ,ICOMEN) CALL TMDFN(LU,LU,NUQ,ICOMEN) C IF(LU.NE.3 .OR. ITYP.NE.7905) RETURN C M=K LUTERM=DATA(M-2) ITT=DATA(M-1) ITSN=J C C 30 K=IRS12(DATA(M))+1 M=M+1 GOTO (999,40,45,40,90,999),K C-----WRITE ON DISC FILE 40 IER1=701 IF( TDCBR(DATA(M),IDCB) ) GOTO 720 GOTO 50 C-----IF LU, DO LULOCK AND BACKSPACE ONE EOF 45 AREG=LURQ(100001B,DATA(M),1) IF(AREG .EQ. 0) GOTO 47 CALL TMPZ(50) GOTO 45 47 REG=EXEC(3,1400B+DATA(M)) C C-----FORMAT THE BUFFER FOR THE STORAGE C 50 CALL MOVEW(DATA,IBUF,LUQ) J=0 570 IF(J .EQ. INDEXM) GOTO 70 J=J+1 CALL MOVEW(DATA(LUQ+1+(J-1)*LMQ),IBUF(LUQ+1),LMQ) C-----IF STORAGE ON LU, USE EXEC CALL INSTEAD OF FMP CALL IF( K .EQ. 3 ) GOTO 60 ASSIGN 66 TO IERTN IF( WRITF(IDCB,IER2,IBUF,LUQ+LMQ) ) GOTO 700 GOTO 66 60 REG=EXEC(2,DATA(M),IBUF,LUQ+LMQ) C-----------CHECK FOR DEVICE FUL ???????????? !!!!!!!!!!!!!!!!! 66 IF(MOD(J,3) .NE. 0) GOTO 570 CALL TMPZ GOTO 570 C C-----THE DATA BUFFER IS EXAUSTED, GOTO NEXT STORAGE MEDIA C 70 IF( K .EQ. 3 ) GOTO 75 ASSIGN 73 TO IERTN IF( POST(IDCB,IER2) ) GOTO 700 73 IER1=702 IF( TDCBS(DATA(M),IDCB) ) GOTO 720 GOTO 80 C-----IF LU, WRITE EOF AND UNLOCK THE LU 75 REG=EXEC(3,100B+DATA(M)) C----------CHECK FOR DEVICE FULL ?????????????? !!!!!!!!!!!!!!! CALL LURQ(0,DATA(M),1) 80 M=M+5 GOTO 30 C C-----STORAGE FROM A USER WRITTEN SUBROUTINE C 90 DATA(M)=IOR(DATA(M),100000B) CALL TMSUB(DATA(M)) IF(IST .NE. 0) CALL TMPER(0,53,ITSN,LUTERM,DATA(M),IST) M=M+3 GOTO 30 C C-----FATAL ERROR PROCESSING C C C-----CR FULL WHEN WRITTING A DISC FILE ! (IF LOGGING IS USED, C WARNING 26 ONLY) 700 IER1=703 IF(IER2 .NE. -6) GOTO 703 IERNB=66 IF( ISBIT(ITT,13) ) IERNB=26 IF(IERNB .EQ. 26) GOTO 707 703 IF( TDCBS(DATA(M),IDCB) ) GOTO 720 IF(IER2 .NE. -6) GOTO 720 707 CALL TMPER(IERTN,IERNB,ITSN,LUTERM,DATA(M),DATA(M+3)) C-----ERROR DURING TMS-FMP DCB SA  VE ROUTINE 720 CALL TMPER(0,99,ITSN,LUTERM,IER1,IER2) C C EXIT C 999 CONTINUE C CALL LOGEV(ICOM00(2),LUTERM,3000,0,ITSN,0,0) RETURN END END$ q   93500-18001 1616 S 0122 SCANI DVR DVB66 SOURCE              H0101 _ASMB,R,L,C NAM DVB66,0 93500-16001 REV. CODE 1616 2-1-78 ENT IB66,CB66 * IFN *IMPORTANT NOTE THIS DRIVER HAS BEEN TESTED AS FAR AS *POSSIBLE AT THIS TIME BUT CANNOT BE GUARANTIED *IN BCD MODE OF OPERATION. IT IS PRESENTLY SET FOR BIN *OPERATION.FOR BCD ASEMBLE WITH "N" OPTION. XIF * * * THIS DRIVER IS DESIGNED TO OPERATE A SCANIVALVE * MSS OR SSS PRESSURE SCANNER WITH THESE * CONFIGURATIONS: * 1. 48 OR 64 CHANNELS WITH HOMES ON CHANNEL 1 * AND (HIGHEST CHANNEL/2)+1. * 2. 48 OR 64 CHANNELS WITH SINGLE HOME ON HIGHEST CHANNEL. * * I/O CARD: 12597A 8-BIT DUPLEX REGISTER * MODIFIED FOR OPEN COLLECTOR OPERATION. * * SCANIVALE I/O KIT FOR HP COMPUTERS IS REQUIRED. * * THE FORTRAN CALL TO DVB66 IS: * CALL EXEC (2,LU,ISVCH,1) * WHERE: 2 = WRITE CALL * LU = LOGICAL UNIT * ISVCH = SCANIVALVE CHANNEL * 1 = NUMBER OF CHANNELS (1 MAX) * * THE STATUS (EQT 5) IS SET TO 1 WHEN THE * SCANIVALVE WILL NOT STEP AFTER THREE OR FOUR * TRIES OR CAN NOT FIND THE REQUESTED * CHANNEL AFTER 200 INTERRUPTS OR THREE TIMEOUTS * * THE TIME OUT VALUE WILL BE USED TO DELAY THE * FINAL DRIVER COMPLETION SO THAT THE SCANIVALVE * TRANSDUCERS MAY SETTLE. FOUR SECONDS ARE USED FOR * THE TIME OUT VALUE FOR DETECTION OF * EQUIPTMENT MALFUNCTION. * * DURING RTGEN, CONFIGURE THE DRIVER TO THE * PARTICULAR SCANIVALVE MODEL BY SETTING DRT BITS * 11 AND 12 (SUBCHANNEL BITS). ENTER A "(LU),X" * RESPONSE WHERE X=: * 0= SINGLE HOME, 48 CHANNELS * 1= DUAL HOME, 48 CHANNELS * 2= SINGLE HOME, 64 CHANNELS * 3= DUAL HOME, 64 CHANNELS ** * INITIATION SECTION * IB66 NOP STA B STORE SELECT CODE LDA EQT6,I LOAD REQUEST CODE AND =D3 MASK CPA =D2 REQUEST CODE = 2? RSS JMP IERR NO LDA EQT7,I LOAD NEW CHANNEL LDA A,I GET VALUE IFN STיB EQT13,I TEMP STORAGE FOR B REG JSB BCD2 CONVERT BCD TO BIN LDB EQT13,I RESTORE B REG XIF STA NCHAN SAVE SSA,RSS NEGATIVE VALUE? SZA,RSS EQUAL ZERO? JMP IERR YES ERROR EXIT LDA B RESTORE SELECT CODE JSB SETIO CONFIGURE I/O INSTRUCTIONS LDA EQT5,I GET STATUS AND =B177400 MASK OUT STATUS TO CLEAR STA EQT5,I RESTORE EQT WITH CLEAR STATUS LIA1 LIA 0 GET PRESENT CHANNEL IFN JSB BCD2 CONVERT BCD TO BIN XIF CPA NCHAN NEW CHAN EQUAL PRES CHAN? JMP IMMED YES, EXIT STA PCHAN SAVE PRESENT CHANNEL LDA EQT4,I GET TIME OUT EQT IOR =B10000 SET DVR HANDLE T.O. BIT STA EQT4,I RESTORE EQT CLB STB EQT10,I SET FIRST INTERRUPT NON-BIT JSB MOVE SUBROUTINE CONTROLLS SCANIVALVE CLA DEVICE ACTIVATED SIGNAL TO RTE STA EQT9,I CLEAR EQT JMP IB66,I RETURN FROM DRIVER * IERR CLA,INA ERROR SIGNAL TO RTE JMP IB66,I RETURN * IMMED LDA =D4 IMMEDIATE COMPLETION SIGNAL TO RTE CLB,INB TRANSMISSION LOG =1 JMP IB66,I RETURN * * COMPLETION SECTION * CB66 NOP ENTRY POINT LDB EQT1,I CHECK FOR SPURIOUS INTERRUPT SZB,RSS EQUAL ZERO THEREFORE SPURIOUS? JMP SPURI YES, EXIT JSB SETIO CONFIGURE I/O INSTRUCTIONS LDB EQT10,I SZB FIRST INTERRUPT? JMP PREVI NO CLB,INB SET BIT STB EQT10,I STORE FIRST INTERRUPT BIT LIA2 LIA 0 GET PRESENT CHAN IFN JSB BCD2 CONVERT BCD TO BIN XIF STA EQT11,I STORE STA PCHAN STORE LDA =D-200 SET INTERRUPT COUNTER STA EQT12,I STORE LDA =D-4 SET NO STEP COUNTER STA EQT13,I STORE STA EQT9,I STORE LDA EQT4,I GET T.O. BIT EQT AND =B4000 MASK OUT REST OF BITS SZA TIME OUT INTERRUPT? JMP TOINC YES,INCREMENT COUNTERS NCXPC LDA EQT7,I NO,GET NCHAN LDA A,I GET VALUE IFN JSB BCD2 CONVERT BCD TO BIN XIF STA NCHAN STORE VALUE CPA PCHAN NEW CHAN= PRESENT CHAN? RSS SKIP NEXT INSTRUCTION JMP MOVE1 NO, ACTIVATE SCANIVALVE LDA EQT14,I GET SETTLING T.O. VALUE SZA,RSS T.O.=0? JMP FIN YES, EXIT LDA EQT14,I NO, SET SETTLING T.O. STA EQT15,I INTO CLOCK CLA,INA SET SET SETTLING T.O. BIT STA EQT9,I STORE CONT ISZ CB66 INC ADDRESS FOR CONT RETURN JMP CB66,I CONTINUATION EXIT * SPURI CLB STB EQT15,I RESET T.O. JMP CONT CONTINUATION RETURN PREVI LDA EQT9,I GET SETTLING T.O. BIT CPA =B1 SETTLING T.O. SET? JMP FIN YES, EXIT TOINC LDA EQT4,I GET T.O. INT EQT AND =B4000 MASK TO GET T.O. INT BIT SZA,RSS ZERO? I.E. NO T.O. INT JMP CTRIN YES, CHECK OTHER ERROR CTRS LDA EQT5,I NO, CHECK STC RESET BIT AND =B10 MASK BIT SZA,RSS ZERO, I.E. NOT STC RESET? JMP RESET YES, SET STC RESET LDA EQT5,I NO, CLEAR RESET BIT AND =B177400 STA EQT5,I RESTORE EQT ISZ EQT9,I NO, INC ERROR CTR RSS YES, BYPASS ERROR EXIT JMP ERREX ERROR EXIT LDA EQT4,I GET T.O. EQT AND =B173777 REMOVE T.O. INTERRUPT BIT STA EQT4,I RESTORE EQT CTRIN ISZ EQT12,I INC INTERRUPT CTR RSS NOT ZERO, SKIP NEXT INSTRUCTION JMP ERREX ZERO, ERROR EXIT LIA3 LIA 0 GET PRESENT CHAN IFN JSB BCD2 CONVERT BCD TO BIN XIF CPA EQT11,I SAME AS ORIGINAL PRESENT CHAN? ISZ EQT13,I YES, INC NO STEP CTR RSS NOT ZERO, SKIP NEXT INSTRUCTION ̀ JMP ERREX ZERO, ERROR EXIT STA PCHAN SAVE PRESENT CHANNEL JMP NCXPC GO CHECK CHANNELS * MOVE1 JSB MOVE JMP CONT CONTINUATION EXIT * FIN LDA EQT4,I GET T.O. EQT AND =B173777 CLEAR T.O. INT BIT STA EQT4,I LDA EQT5,I GET STATUS EQT AND =B177400 CLEAR STATUS BITS STA EQT5,I RESTORE EQT CLA NORMAL COMPLETION SIGNAL TO RTE STA EQT9,I CLEAR EQT STA EQT10,I CLEAR EQT CLB,INB SET TRANSMISSION LOG CLC1 CLC 0 TURN OFF INTERRUPT JMP CB66,I COMPLETION RETURN * ERREX LDA EQT5,I GET STATUS EQT AND =B177400 CLEAR STATUS IOR =B1 SET ERROR STATUS STA EQT5,I RESTORE EQT CLA,INA ERROR SIGNAL TO RTE CLB NO TRANSMISSION STB EQT9,I CLEAR EQT STB EQT10,I CLEAR EQT JMP CLC1 ERROR COMPLETION EXIT * RESET LDA EQT5,I GET EQT IOR =B10 SET STC RESET BIT STA EQT5,I RESTORE EQT LDA =D-50 SET T.O.=.5 SEC STA EQT15,I SET T.O. COUNTER LDA EQT4,I AND =B173777 CLEAR T.O. INT BIT STA EQT4,I RESTORE CLC2 CLC 0 RESET STC JMP CONT EXIT * * SUBROUTINES * SETIO NOP IOR LIA COMBINE LIA WITH I/O SC STA LIA1 STORE IN INSTRUCTION LOC STA LIA2 STA LIA3 ADA =B100 FORM OTA INSTRUCTION STA OTA1 STORE IN INSTRUCTION LOC ADA =B1100 FORM STC,C INSTRUCTION STA STCC1 STORE IN INSTRUCTION LOC ADA =B3000 FORM CLC INSTRUCTION STA CLC1 STORE IN INSTRUCTION LOC STA CLC2 JMP SETIO,I RETURN * MOVE NOP ENTRY POINT LDA EQT4,I LOAD SUBCHANNEL AND =B200 ISOLATE LDB =D48 LOAD 48CHANNEL HOME SZA 48 VALUE HOME? ADB =D16 NO,ADD 16 STB HO|ME2 YES,STORE LDA EQT4,I LOAD SUBCHANNEL AND =B100 ISOLATE NUMBER OF HOMES BIT SZA,RSS SINGLE HOME? JMP NC.PC YES,CHECK IF NCHAN>PCHAN RBR COMPUTE DUAL HOME BIT INB STB HOME1 LDB NCHAN LDA PCHAN CMA,INA CMB,INB ADA HOME1 SET UP SECTION I CHECK ADB HOME1 SET UP SECTION I CHECK SSA,RSS IF SECTION I THEN PCHAN POS SSB,RSS IF SECTION I THEN NCHAN POS JMP NC.PC BOTH POSITIVE! CHECK NC>PC ADA HOME2 SET UP SECTON II CHECK ADB HOME2 SET UP SECTION II CHECK SSA,RSS IF SECTION II THEN PCHAN POS SSB IF SECTION II THEN NCHAN POS JMP HOME NO, JUMP HOME NC.PC LDB NCHAN GET NEW CHANNEL CPB HOME2 GO TO HOME2? JMP HOME YES LDA PCHAN NO, GET PRESENT CHANNEL CPA HOME2 AT HOME AND PCHAN NOT=NCHAN? JMP STEP YES,STEP SO NCHAN>PCHAN CMB,INB ADB PCHAN SSB,RSS IS NCHAN>PCHAN JMP HOME NO STEP CLA YES,LOAD STEP COMMAND JMP OTA1 BYPASS HOME COMMAND HOME CLA,INA LOAD HOME COMMAND OTA1 OTA 0 OUT PUT TO IO CARD LDA =D-400 ADD 4 SECONDS FOR MALFUNCTION STA EQT15,I AND SET CLOCK STCC1 STC 0,C OUTPUT TO SCANI JMP MOVE,I RETURN * IFN BCD2 NOP ENTRY POINT. SUBROUTINE CLB CONVERTS TWO BCD DIGITS RRR 4 IN A REG TO BIN INTEGER AND =B17 IN A REG BLF RAL ADB A RAL,RAL ADA B JMP BCD2,I XIF * * SYSTEM BASE PAGE COMMUNICATION AREA * . EQU 1650B EQT1 EQU .+8 EQT4 EQU .+11 CONFIGURATION BITS ADDRESS EQT5 EQU .+12 EQT6 EQU .+13 EQT7 EQU .+14 NEW CHAN ADDRESS EQT9 EQU .+16 SETTLING T.O. BIT EQT10 EQU .+17 MULTIPLE INTERRUPT BIY)$"T ADD EQT11 EQU .+18 INITIAL PRES CHAN ADD EQT12 EQU .+81 MAXIMUM INTERRUPT COUNTER EQT13 EQU .+82 NO STEP COUNTER ADDRESS EQT14 EQU .+83 TIMEOUT RESET VALUE EQT15 EQU .+84 TIME OUT CLOCK * * CONSTANTS * A EQU 0 B EQU 1 * NCHAN NOP PCHAN NOP HOME1 NOP HOME2 NOP LIA LIA 0 SUP END ҡ$   93500-18002 1616 S 0122 SCAN VERIFICATION SV              H0101 oFTN4,B,L PROGRAM SV C THIS PROGRAM VERIFIES PROPER OPERATION OF A 48 OR 64 C CHANNEL MSS/SSS SCANIVALVE PRESSURE SCANNER IN A C RTE OPERATING SYSTEM. C C TESTS PERFORMED C C 1. AUTO TEST: SCANIVALVE STEPS FROM HIGHEST CHANNEL C TO CHANNEL 1 C 2. MANUAL TEST: UP TO 64 CHANNELS MAY BE SELECTED C AND THE SCANIVALVE WILL STEP OR C HOME TO EACH OF THE SELECTED CHANNELS. C C TEST PARAMETERS: C 1. ENTRY PARAMETERS ARE PASSED WITH A "RU" OR C "ON" OPERATOR REQUESTS. FOR EXAMPLE: C C RU,SV,LU,LX,NC C C WHERE LU= CONSOLE LU NUMBER C LX= SCANIVALVE LU NUMBER C NC= NUMBER SCANIVALVE CHANNELS C C 2. OPERATING PARAMETERS ARE PASSED IN RESPONSE C TO THE "ENTER PARAMETERS" REQUEST.THEY ARE: C C AUTO TEST =AT C MANUAL TEST =MT C LOOP PRESENT TEST 10 TIMES =LT C SUPPRESS DATA PRINTOUT =SD C C DIMENSION ISVCH(64),ICV(3),ICS(4),ICX(3) C,IPRAM(5) EQUIVALENCE (LU,IPRAM(1)) DATA ICS/2HAT,2HMT,2HLT,2HSD/ C CALL RMPAR(IPRAM) 2 IF(ICX(4).EQ.1) GO TO 3 WRITE(LU,1000) 3 DO 4 J=1,3 ICV(J)=0 4 ICX(J)=0 WRITE(LU,1001) READ(LU,1002)(ICV(J),J=1,3) DO 5 I=1,3 IF(ICV(I).EQ.ICS(1)) ICX(1)=0 IF(ICV(I).EQ.ICS(2)) ICX(1)=1 IF(ICV(I).EQ.ICS(3)) ICX(2)=1 5 IF(ICV(I).EQ.ICS(4)) ICX(3)=1 IC=0 IF(ICX(1).EQ.1) GO TO 20 10 WRITE(LU,1003) ICHAN=IPRAM(3) GO TO 30 20 WRITE(LU,1004) READ(LU,*) ICHAN WRITE(LU,1005) READ(LU,*) (ISVCH(JA),JA=1,ICHAN) 30 DO 34 I=1,ICHAN IF(ICX(1).EQ.1) GO TO 32 ISVCH(I)= ICHAN+1-I 32 CALL EXEC(2+100000B,IPRAM(2),ISVCH(I),1) GO TO 40 33 IF(ICX(3).EQ.1) GO TO 34 IF(IC.GE.1) GO TO 52 WRITE(LU,1006) GO TO 54 5  2 WRITE(LU,1007) 54 IC=IC+1 IF(IC.LT.64) GO TO 34 IC=0 34 CONTINUE 36 IF(ICX(2).EQ.0) GO TO 38 ICX(2)=ICX(2)+1 WRITE(LU,1008) IC=O IF(ICX(2).LT.11) GO TO 30 38 WRITE(LU,1009) GO TO 100 40 WRITE(LU,1010) 1000 FORMAT(20X"SCANIVALVE VERIFICATION TEST"// 1"TEST OPTIONS"//3X"AT=AUTO TEST"/3X, 1"MT=MANUAL TEST"/3X"LT=LOOP TEST 10 TIMES"/3X 1"SD=SUPPRESS DATA PRINTOUT"/) C 1001 FORMAT(X,"ENTER PARAMETERS _") 1002 FORMAT(R2,2(X,R2)) 1003 FORMAT(X,"AUTO TEST") 1004 FORMAT(X,"MANUAL TEST"/X"#OF CHANNELS" 1" TO BE SCANNED? _") 1005 FORMAT(X,"CHANNEL #'S _") 1006 FORMAT(X,"S_") 1007 FORMAT("S_") 1008 FORMAT(" ") 1009 FORMAT(/,X,"END OF TEST") 1010 FORMAT(X,"SCANIVALVE DRIVER HAS REJECTED CALL") 100 END END$ g