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: 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.2013 790904 
      DIMENSION IBUFR(2),IBUFL(2),IGCBF(12) 
      DIMENSION ICODE(2),IGTBL(35)
      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 5-26-79 THREE NEW LOGICAL PTRS ADDED INTO IGTBL.
C 1) ICHAR POINTS TO THE SOFTWARE WIDTH, AND HEIGHT.
C 2) ICSLN POINTS TO THE SOFTWARE SLANT.
C 3) ICDIR POINTS TO THE SOFTWARE LDIR. 
C 
C THE VALUES ARE STORED EXACTLY AS THE USER REQUESTED IN THE CSIZE CALL.
C 
      EQUIVALENCE (IGTBL(33),ICHAR),(IGTBL(34),ICSLN) 
      EQUIVALENCE (IGTBL(35),ICDIR) 
C 
C 
C     THIS IS THE GRAPHICS CONTROL BLOCK INTERFACE MODULE 
C THAT IS RESPONSIBLE FOR INTERFACING BETWEEN THE GCB 
C AND OTHER 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/
C***************************************************************
C 3 NEW PTRS ADDED 5-26-79 BY STEVE YOUNG.
C ICHAR IS 4 WORDS LONG (SOFTWARE CHAR WIDTH AND HEIGHT), POINTS TO 
C       WORD 185 IN THE GCB.
C ICSLN IS 2 WORDS LONG (SOFTWARE CHARACTER SLANT), POINTS TO 
C       WORD 189 IN THE GCB.
C ICDIR IS 2 WORDS LONG (SOFTWARE CHAR DIRECTION) AND POINTS TO 
C       WORD 191 IN THE GCB.
C 
      DATA ICHAR/2271B/ 
      DATA ICSLN/1275B/ 
      DATA ICDIR/1277B/ 
      IND = 0 
C 
C 
C 
      IF(ICODE.EQ.0)GO TO 5 
      IF(ICODE.EQ.99)CALL ABSAD(ICODE,0,IBUFR)
      ISTS = 0
      CALL PLTER(-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 
C 
CC*********************************************************** 
C 
      SUBROUTINE PLTER(IERCD,IRTN), 92840-16002 REV. 1913 790130
      INTEGER PRMER(8),PRM1,PRM2,PRM3,PRM4,PRM5,PRM6,PRM7,PRM8          EM1901
      INTEGER HDMSK(7),HDERR(7)                                         EM1901
      DIMENSION IBUFR(5),ICODE(2),MSG(14) 
      DIMENSION MEQT(4) 
      DIMENSION IERR(4)                                                 EM1913
      EQUIVALENCE (IBUFR,LUER),(MSG(4),MSG4),(MSG(5),MSG5)
      EQUIVALENCE (IBUFR(2),IB2),(MSG(6),MSG6),(MSG(7),MSG7)            EM1901
      EQUIVALENCE (MSG(8),MSG8),(PRMER,PRM1),(PRMER(2),PRM2)            EM1901
      EQUIVALENCE (PRMER(3),PRM3),(PRMER(4),PRM4),(PRMER(5),PRM5)       EM1901
      EQUIVALENCE (PRMER(6),PRM6),(PRMER(7),PRM7),(PRMER(8),PRM8)       EM1901
C 
C     THIS ROUTINE IS RESPONSIBLE FOR LETTING THE USER KNOW 
C  WHEN THERES BEEN A MESS UP.
C 
      DATA MSFLG/0/                                                     EM1901
      DATA MSG/2H  ,2HGP,2HS ,2H  ,2H  ,2H  ,2H  ,2H  ,2H  ,2H  ,2H  ,  EM1913
     1         2H  ,2H  ,2H  /                                          EM1913
      DATA MEQT/2400B,3400B,17400B,5000B/ 
      DATA PRMER/2H99,2H  ,2H6 ,2H  ,2H37,2H  ,2HFM,2HP /               EM1901
      DATA IEFMT/37/                                                    EM1901
      DATA ICODE/28,27/ 
      DATA HDERR/1,2,5,3/ 
      DATA HDMSK/0,0,0,0,0,0,0/ 
      DATA IERR/-97,40,199,4/                                           EM1913
C 
C 
C     HANDLE SPECIAL CODES NOT REQUIRING MESSAGE OUTPUT.  AN ATTEMPT    EM1913
C     IS BEING MADE HERE TO OPTIMIZE CODE FOR CALL PLTER(-98) BECAUSE   EM1913
C     IT IS CALLED SO OFTEN.  THEREFORE, CODE MAY NOT BE IDEALLY        EM1913
C     STRUCTURED AND A SMALL AMOUNT OF EXTRA CORE MAY BE SACRIFICED.    EM1913
C 
      IF (IERCD.EQ.-98) GO TO 900                                       EM1913
      IF (IERCD.EQ.-99) GO TO 900                                       EM1913
      IF (IERCD.EQ.6) GO TO 820                                         EM1913
C 
C FROM NOW ON, OUTPUT OF ERROR MESAGES IS INVOLVED.  THE MESSAGE        EM1913
C BUFFER IS REFRESHED AFTER EACH USE SO IT'S ALREADY SET UP.            EM1913
C                                                                       EM1913
C SET THE DEFAULT UNIT FOR LOGGING HARD ERRORS TO THE CURRENT CONSOLE,  EM1840
C THE VALUE RETURNED BY THE SYSTEM FUNCTION LOGLU                       EM1840
C 
      LUER = LOGLU(DUMMY)                                               EM1840
C 
C 
      IENAM = IERCD 
C 
C     CHECK ON HARD ERRORS 4 & 40  AND SPECIAL CALLS -97 & 199          EM1913
C 
2     DO 7 K =1,4 
      IF(IERCD.EQ.IERR(K))GO TO (1000,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 
C 
C  ERR CODES 40-94 INDICATE PARAMETER ERRORS IN SUBROUTINE              EM1901
      IF(IERCD.GT.39)GO TO 800
C 
C   IF IERCD IS LESS THAN -300, WE KNOW THAT WE HAVE AN FMP ERROR CODE  EM1913
      IF (IERCD.LT.-300) GO TO 400                                      EM1913
C 
      IMPY = MOD(IERCD,16)
      INDX = IERCD/16 + 2 
      IF(IMPY.NE.0) GO TO 60                                            EM1913
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 
99    ICHR = 0
      CALL CONVT(IENAM,MSG4,ICHR,1) 
      ICHR = ICHR + 6 
      J = ICHR/2 + 1
C 
C 
C 
C  SECTION 160 IS THE END PROCESSING FOR NORMAL, GPS 99, AND FMP ERRORS EM1901
160   CALL REIO(2,LUER,MSG,J)                                           EM1913
C 
C 
C REFRESH THE MESSAGE BUFFER, CLEANING IT OUT AFTER USE FOT NEXT TIME   EM1913
      DO 5 K=4,14                                                       EM1913
      MSG(K) = 20040B                                                   EM1913
 5    CONTINUE                                                          EM1913
C                                                                       EM1913
C                                                                       EM1913
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   WE HAVE AN FMP ERROR, SIGNALED BY THE NEGATIVE FMP ERROR CODE.      EM1913
C   PLTER IS PASSED (FMP ERROR CODE - 300) SO A -99 FMP ERROR WON'T     EM1913
C   BE CONFUSED WITH A -99 SPECIAL REQUEST CODE. THIS                   EM1913
C   TYPE OF ERROR WILL ALWAYS BE FIRM AND WILL BE LOGGED IN THE GCB AS  EM1901
C   ERROR 37. THE ERROR MESSAGE WILL LOOK LIKE GPS 37 FMP -XX.          EM1901
 400  MSG4=PRM5                                                         EM1901
      MSG5=PRM6                                                         EM1901
      MSG6=PRM7                                                         EM1901
      MSG7=PRM8                                                         EM1901
      ICHR=0                                                            EM1901
      IENAM=IENAM + 300                                                 EM1913
      CALL CONVT(IENAM,MSG8,ICHR,1)                                     EM1913
      ICHR=ICHR+14                                                      EM1901
      J=ICHR/2+1                                                        EM1901
      IENAM=IEFMT                                                       EM1901
      GO TO 160                                                         EM1901
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) 
C 
C                                WE WANT TO RETURN IF IRTN = 1,2,3,5.   EM1913
C                                ELSE CONTINUE.  THESE THREE TESTS      EM1913
C                                REPLACE THE COMMENTED OUT DO-LOOP      EM1913
C                                IN AN ATTEMPT TO OPTIMIZE EXECUTION    EM1913
      IF (IRTN.LE.0) GO TO 951                                          EM1913
      IF (IRTN.GT.5) GO TO 951                                          EM1913
      IF (IRTN.EQ.4) GO TO 951                                          EM1913
      RETURN                                                            EM1913
C 
C     DO 950 I=1,4
C     IF(IRTN.EQ.HDERR(I))RETURN
C950  CONTINUE
C 
 951  MSFLG = 0                                                         EM1913
      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 
 1000 IF(IRTN.GT.63.OR.IRTN.LT.0)GO TO 10010                            EM1913
      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
C     GO TO 10010                                                       EM1913
C 
C     REPORT ERROR 5 - ILLEGAL LU                                       EM1913
C 
10010 IENAM = 5 
      GO TO 99
      END 
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.1913 781218
      INTEGER STPLB 
      DIMENSION 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 GSWCH.                                         EM1913
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 GSWCH(0)                                                     EM1913
      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 GSWCH(0)                                                     EM1913
      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 GSWCH(0)                                                     EM1913
      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) 
      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 
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 
C     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$
                                                                                                                                                                                                                                                          