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 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     INITIALIZE 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$
                                                                                                                                