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 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 
      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     CHECK TO SEE IF UNITS = GDUS
C 
C 
C     NOW DO DE CLIPPING. 
C     WRITE(6,2500)X,Y
C500  FORMAT(2X,2(X,F7.2))
C 
20    CALL  CLPNG(XOLD ,CLPTS,V5,IFLG)
C     WRITE(6,5500)CLP1,CLP2,CLP3,CLP4,XNEW,YNEW,XOLD,YOLD
C500  FORMAT("DRAW",2X,8(X,F5.2)) 
C     WRITE(6,7500)PORGX,PORGY,THETX,THETY
C500  FORMAT(2X,"PORGS",4(X,F7.2))
C 
22    IF(IFLG)600,25,600
C 
C     NOW DROP-PEN AND MAKE A MARK
C 
25    IB7 = GRIFX(CLP3) 
      IB8 = GRIFX(CLP4) 
      IB3 = GRIFX(CLP1) 
      IB4 = GRIFX(CLP2) 
      IF(CLP1.EQ.XOLD.AND.CLP2.EQ.YOLD)GO TO 27 
      CALL OUTPT(4,IBUFR,2) 
      GO TO 600 
27    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) 
      RETURN
      END 
      END$
                                                                                                                        