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: SETUP
C      SOURCE: 92840 - 18006
C      RELOC:  92840 - 16001
C 
C 
C 
CC*********************************************************** 
C 
      SUBROUTINE SETUP(P1,P2,P3,P4,P5,P6, 
     1P7), 92840-16001 REV.2013 791211
C 
C     THIS IS THE AGL FUNCTIONAL FOR THE AGL COMMANDS PLOTR,
C  FLUSH,GCLR,AND GPON. THE RELATION TO THE STATEMENTS IN THE 
C  PROGRAM AND THESE COMMANDS IS AS FOLLOWS:
C     STATEMENT              COMMAND
C        10                   PLOTR 
C        20                   GPON
C        30                   GCLR
C 
C     THE STATEMENTS ARE GOTTEN TO BY THE CODE PASSED DOWN IN P1. 
C 
      INTEGER P0,P4,P5   ,ICMND(5) ,GICB,POINT,ERROR(9) 
      INTEGER P1,P2(2),P3,P6,READ,WRITE,ICODE(6)
      INTEGER GRIFX 
      INTEGER FLUSH,HOME,DEFLT,PORG,GCLR,ERMSK(2) 
      INTEGER GTPLT,GTCHR,ACTVE,RESET 
      INTEGER SPEND,CLEAR,CSIZE,TRNFR,GTMMU,PTEND                       EM1901
      DIMENSION VAR(17),IBUFR(12) 
      DIMENSION CHR(2)
      EQUIVALENCE (ICMND,FLUSH),(ICMND(2),DEFLT),(ICMND(3),HOME)
      EQUIVALENCE (IBUFR(2),IB2),(IBUFR(3),IB3),(IBUFR(4),IB4)
      EQUIVALENCE (IBUFR(5),IB5),(XLIN,IB5) 
      EQUIVALENCE (CHW,IBUFR(2)),(CHH,IBUFR(4)) 
      EQUIVALENCE (VAR,G1X),(VAR(2),G1Y,BP),(VAR(3),G2X)
      EQUIVALENCE (VAR(4),G2Y,DP) 
      EQUIVALENCE (AP,VAR),(CP,VAR(3)),(A,VAR(5)),(C,VAR(7))
      EQUIVALENCE (VAR(6),V6) 
      EQUIVALENCE (VAR(9),DXGDU),(VAR(10),DYGDU)
      EQUIVALENCE (VAR(11),PORGX),(VAR(12),PORGY),(VAR(13),PDIRX) 
      EQUIVALENCE (VAR(14),PDIRY) 
      EQUIVALENCE (VAR(15),XMU),(VAR(16),YMU),(VAR(17),XLDIR) 
      EQUIVALENCE (ICODE(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                     EM81840
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/ 
C 
C SY2013 CHANGED ERROR WORD 2 FROM 135577B TO 125577B 
C 
      DATA ERROR/-1,125577B,173006B,176B,0/                             SY2013
      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 GIC FOR THE 2608A                                                     EM1901
      DATA PTEND/3400B/                                                 EM1901
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 
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
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 FOR THE 2608A, SIGNAL THE PLOT IS OVER SO BUFFERS WILL BE CLEARED     EM1901
C OUT. THIS GIC NO-OPED BY NON 2608A DEVICES.                           EM1901
      CALL OUTPT(1,PTEND,2)                                             EM1901
C 
C     CLEAR GCB 
      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 GSWCH(0)  EM1913
C          CALL FROM SUBROUTINE(OUTPUT). CANNOT CHECK FOR BAD LU        EM1840
C          MATCH OR TOO 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 GSWCH(P3)                                                    EM1913
      CALL PLTER(-98,ISUSP) 
      IF(ISUSP.NE.0)RETURN
C 
      DO 112 K=1,5
112   P2(K) = 0 
      DO 114 K = 8,192
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) 
C 
C SY2013: 33 SETS THE SOFTWARE CHARACTER WIDTH AND HEIGHT(NDC UNITS)
C SY2013: 34 INITS THE CHAR SLANT TO 0.0 (GCBIM(34))
C SY2013: GCBIM(35) SETS THE SOFTWARE LDIR TO 0.0 
C 
      CHW=2.78*.7                                                       SY2013
      CHH=2.78                                                          SY2013
      CALL GCBIM(33,1,CHW,0,2)                                          SY2013
      CALL GCBIM(GICB,1,7,1,3)                                          SY2013
      CALL GCBIM(34,1,0.0,0,2)                                          SY2013
      CALL GCBIM(35,1,0.0,0,2)                                          SY2013
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$
                                                                                                                                                                                        