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:  SETAR 
C      SOURCE: 92840 - 18004
C      RELOC:  92840 - 16001
C 
C      MODIFIED BY DJS  1/16/80       
C 
CC*********************************************************** 
C 
      SUBROUTINE XETAR(IND,IGCB,ASPCT), 92840-16001 REV.2013 800116 
C     INTEGER GRIFX                                                     DS2013
      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)) 
C     DATA EPSLN/.0001/                                                 DS2013
C     DATA IGTCH/4404B/                                                 DS2013
      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.GT.0.) GO TO 50                                          EM1901
      AR=1                                                              EM1901
      CALL PLTER(23)                                                    EM1901
C 
C     GET GDUS AND A' - D'
C 
 50   CALL GCBIM(ICODE,3,VAR,0,1)                                       EM1901
C     CALL OUTPT(1,IGTCH,1)                                             DS2013
C     CALL GCBIM(16,1,IBUFR,4,1)                                        DS2013
C 
C 
C 
C     COMPUTE PRESENT ASPECT RATIO
C 
5     ARP = DXGDU/DYGDU 
C 
C     SEE IF ASPECT RATIOS ARE EQUAL
C 
C     XTEST = ABS(AR - ARP)                                             DS2013
C     IF(XTEST.LE.EPSLN)RETURN                                          DS2013
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 THAT 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  CALL GCBIM(8,1,G1X,0,2)                                           EM1901
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$
                                                                                                                                                                                                                                                          