FTN,L 
C 
C 
C 
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: GSTAT
C      SOURCE: 92840 - 18050
C      RELOC:  92840 - 16001
C 
C 
C 
CC*********************************************************** 
C 
C SY2001 MAKES A MOD TO HANDLE A GSTAT(14) CALL WHEN SOFTWARE 
C TEXT IS ENABLED. GSTAT(14) INQUIRES ABOUT LDIR. 
C SY2001 ALSO ADDS NEW CALL OF GSTAT(17) TO INQUIRE IF SOFTWARE 
C TEXT IS CURRENTLY ON. 
C 
C**************************************************************** 
C 
      SUBROUTINE XGSTT(INN,IGCB,INDX,LOOP,
     1IARRY), 92840-16001 REV.2013 790904 
C 
      LOGICAL GSOFT                                                     SY2013
      INTEGER PNPOS,PENZ
      DIMENSION IARRY(2),IGTBL(20),ICODE(3),INDX(2) 
      DIMENSION IBUFR(4)
      DIMENSION VAR(4),VAR1(4)
C 
C     THIS ROUTINE IS RESPONSIBLE FOR RETURNING THE 
C  GRAPHICS PACKAGE STATUS INFORMATION TO THE USER. 
C 
      EQUIVALENCE (IBUFR,IB1),(IBUFR(2),IB2),(IBUFR(3),IB3) 
      EQUIVALENCE(IGTBL,PNPOS),(IGTBL(2),PENZ),(IGTBL(3),IG12)
      EQUIVALENCE(IGTBL(4),IV12),(IGTBL(5),IS12),(IGTBL(6),IAD) 
      EQUIVALENCE(IGTBL(7),IADP),(IGTBL(8),IPRG),(IGTBL(9),ICHR)
      EQUIVALENCE(IGTBL(10),IGDU),(IGTBL(11),IUNIT),(IGTBL(12),LINE)
      EQUIVALENCE(IGTBL(13),LORG),(IGTBL(14),LDIR),(IGTBL(15),IPDIR)
      EQUIVALENCE(IGTBL(16),N),(IGTBL(17),ISOFT)
      EQUIVALENCE (VAR,X1),(VAR(2),Y1),(VAR(3),X2)
      EQUIVALENCE (VAR(4),Y2),(VAR1,A),(VAR1(2),B),(VAR1(3),C)
      EQUIVALENCE (VAR1(4),D) 
C 
C 
C     THE FOLLOWING DATA ITEMS ARE POINTER INTO THE GRAPHICS CONTROL
C  BLOCK VIA THE GCB INTERFACE MODULE (GCBIM).
C     A NEGATIVE NUMBER INDICATES SOMETHING SPECIAL MUST BE DONE. 
C 
C 
      DATA IPXY/5003B/
      DATA PNPOS,PENZ/-3,-1/
      DATA IG12,IV12,IS12/-4,-5,-6/ 
      DATA IADP,IAD/-8,-9/
      DATA IPRG,ICHR/-10,  -7/
      DATA IGDU,IUNIT/2015B,-2/ 
      DATA LINE,LORG/  -11,425B/
      DATA LDIR,IPDIR/1026B,2023B/
C 
      DATA LDIR2/1043B/ 
      DATA ISOFT/-12/ 
C 
      DATA N/432B/
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     FIRST DETERMINE IF WE HAVE AN ERROR INDX<1 OR > 17               SY2013 
C     THEN IF NO ERROR COMPUTE POINTER INTO IGTBL TO GET
C GET THE CORRECT INDEX FOR THE GCB. IF THE POINTER IS
C NEGATIVE GO DO SOMETHING SPECIAL. 
C 
      J = 1 
      IF(LOOP)800,800,5 
5     DO 550 I = 1,LOOP 
      INTST = INDX(I) 
      IF(INTST.LE.0.OR.INTST.GT.17)GO TO 800
C 
C     NOW LOOP AROUND AN FILL IARRY WITH ALL THE DATA REQUESTED 
C 
      IPTR = IGTBL(INTST) 
      IF(IPTR.LT.0)GO TO 100
C**************************************************************SY2013 MOD 
C IF IPTR IS INQUIRING ABOUT LDIR, SEE IF SOFTWARE TEXT IS ENABLED. 
C IF SO, MODIFY IPTR TO RETURN THE SOFTWARE LDIR VALUE. 
C 
      IF ((IPTR .EQ. LDIR) .AND. (GSOFT(IGCB))) IPTR=LDIR2
C 
C*******************************************************END OF SY2013 MOD 
C 
C     DETERMINE THE NUMBER OF WORDS THAT WILL BE FILLED UP
C  IN IARRY.
C 
      NUM = IAND(IPTR,177400B)/400B 
      IPTR = IAND(IPTR,377B)
      CALL GCBIM(IPTR,1,IARRY(J),0,1) 
      GO TO 500 
C 
C     GET INFO FROM STATUS WORD 
C 
100   IPTR = -IPTR
      GO TO(110,120,130,140,140,140,150,160,160,125,165,175),IPTR       SY2013
110   ISTAT = 0 
      CALL GRSTS(1,200B,ISTAT)
      IARRY(J) = ISTAT/200B 
      NUM = 1 
      GO TO 500 
C 
C     UNITS MODE: 0=GDUS,1=UDUS,AND 3 = USER UNITS = GDUS 
C 
120   CALL GRSTS(1,1  ,ISTAT) 
      IARRY(J) = ISTAT
      NUM = 1 
      GO TO 500 
C 
C     PORG X,Y
C 
125   CALL GCBIM(17,1,IARRY(J),0,1) 
      NUM = 4 
      GO TO 500 
C 
C     PEN POSITION (X,Y)
C 
130   CALL OUTPT(1,IPXY,1)
      CALL GCBIM(16,1,IBUFR,3,1)
135   X1= IB1 
      Y1= IB2 
      NUM = 4 
      GO TO 200 
C 
C     G1,G2 OR V1,V2 OR S1,S2 
C 
140   IPTR = IPTR + 4 
      CALL GCBIM(IPTR,1,VAR,0,1)
      NUM = 8 
      GO TO 200 
C 
C     CHARACTER SIZE
C 
150   CALL GCBIM(7,1,VAR,0,1) 
      ICD = IADCD(D)
      CALL GCBIM(ICD,1,VAR1,0,1)
      X1 = X1/A 
      Y1 = Y1/C 
      NUM = 4 
      GO TO 300 
C 
C     A - D OR A' - D'
C 
160   IPTR = IPTR + 3 
      CALL GCBIM(IPTR,1,VAR,0,1)
      Y1 = Y1/X1
      Y2 = Y2/X2
      NUM = 8 
      GO TO 300 
165   CALL GCBIM(31,1,IBUFR,0,1)
      IARRY(J) = IBUFR
      NUM = 1 
      GO TO 500 
C********************************************************************** 
C SY2013 ADDS INQUIRY ABOUT WHETHER SOFTWARE TEXT IS ON.
C 
175   IARRY(J)=0
      IF (GSOFT(IGCB)) IARRY(J)=1 
      NUM=1 
      GO TO 500 
C 
C     CONVERT VALUES OF INTEREST TO CURRENT UNITS (UDUS OR GDUS)
C 
200   IPTR = IADCD(D) 
      CALL GCBIM(IPTR,1,VAR1,0,1) 
      X1 = (X1 - B)/A 
      Y1 = (Y1 - D)/C 
      X2 = (X2 - B)/A 
      Y2 = (Y2 - D)/C 
C 
C     NOW DO DE TRANSFER (TRICKERY AT ITS BEST) 
C 
300   CALL GCBIM(16,1,VAR,NUM,2)
      CALL GCBIM(16,1,IARRY(J),NUM,1) 
500   J= J + NUM
550   CONTINUE
C 
      RETURN
800   CALL PLTER(26,11) 
      RETURN
      END 
      END$
                                                                                                                                                                                                                              