FTN4,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: GLEN1
C      SOURCE: 92840 - 18154
C      RELOC:  92840 - 16021
C 
C 
C 
CC*********************************************************** 
      SUBROUTINE GLEN1(IGCB,ITEXT,ISTRT,ITEXL,DELTX,DELTY,IDCB,IBUFR) 
     +,92840-16021 REV.2013 791107
C************************************************************ 
C GLEN1 RETURNS THE SOFTWARE LENGTH OF THE TEXT STRING
C IN ITEXT. 
C 
C ITEXT = BUFFER CONTAINING THE CHARACTER STRING. 
C ISTRT = INDEX OF FIRST CHARACTER IN THE SUBSTRING WHOSE 
C         LENGTH IS DESIRED.
C ITEXL = CHARACTER COUNT OF THE ENTIRE STRING THAT CONTAINS
C         THAT CONTAINS THE SUBSTRING.
C DELTX = RETURNED DELTA X THAT WOULD OCCUR IF ITEXT WERE OUTPUT
C         ACCORDING TO THE CURRENT CHARACTER SIZE, LDIR, ETC. 
C DELTY = RETURNED DELTA Y THAT WOULD OCCUR IF ITEXT WERE OUTPUT
C IDCB  = DCB THAT'S OPEN TO THE FONT FILE. 
C IBUFR = MINIMUM 128 WORD UTILITY BUFFER.
C 
C 11-07-79 THIS SUBR NOW CHECKS TO SEE WHETHER IT SHOULD PRINT OUT
C A GPS 13 ERROR WHEN AN ILLEGAL CHARACTER IS ENCOUNTERED.
C 
C IF IBUFR(1) .EQ. 100000B GLEN1 DOESNT PRINT OUT A GPS 13 ERROR
C************************************************************** 
      INTEGER IGCB(1),ITEXT(1),ITEXL,IDCB(1),IBUFR(1) 
      REAL DELTX,DELTY
      LOGICAL SKIP
C 
      REAL XMTRX(2,2) 
      INTEGER INFO(9) 
C*************************************************************
C 4-26-79 IMPLEMENT A STUB. 
C 
D     LU=LOGLU(IDUMY) 
D     WRITE(LU,1000)
D1000 FORMAT(/"GLEN1: ENTERING GLEN1.") 
C***********************************************************
C SET THE SKIP FLAG ACCORDING TO THE VALUE IN IBUFR(1)
C 
      SKIP=.FALSE.
      IF (IBUFR(1) .EQ. 100000B) SKIP = .TRUE.
C*************************************************************
C GET THE POSITIVE CHARACTER COUNT OF THE CHARACTERS IN ITEXT.
C 
      IF ((ISTRT .LE. 0) .OR. (ITEXL .LE. 0)) GO TO 8500
      ISTRC=ISTRT 
C************************************************************ 
C READ IN INFO FROM THE FONT FILE.
C 
      CALL READF(IDCB,IERR,INFO,9,LEN,1)
      IF (IERR .LT. 0) GO TO 8000 
C*********************************************************
C CALL GCALC TO CALCULATE THE TRANSFORMATION MATRIX.
C (NOTE: GCALC DESTROYS THE DATA IN IBUFR.) 
C (NOTE: IUNIT = 0 TO GET AN NDC XMTRX, 
C              = 1 TO GET A WC XMTRX) 
C 
      IUNIT=IADCD(IDUMY)-11 
      CALL GCALC(IGCB,XMTRX,INFO,IBUFR,IUNIT) 
C**************************************************************** 
C SEE IF THERE'S AN UNDERSCORE AS THE LAST CHARACTER. IF SO, IGNORE IT. 
C 
      CALL SGET(ITEXT,ISTRT+ITEXL-1,ICHAR)
      ITEXL2=ITEXL
      IF (ICHAR .EQ. 137B) ITEXL2=ITEXL2-1
C******************************************************** 
C IF YOU DON'T HAVE A WIDTH TABLE, JUMP DOWN BELOW AND JUST 
C USE THE STANDARD WIDTH. IF YOU DO HAVE A WIDTH TABLE, ADD 
C UP THE INDIVIDUAL WIDTHS FOR EACH CHARACTER.
C 
      ITBL=INFO(6)
      IF (ITBL .EQ. 0) GO TO 2000 
C*********************************************************
C ADD UP THE WIDTHS OF EACH INDIVIDUAL CHARACTER. 
C 
      IWIDE=0 
      IEND=ISTRC+ITEXL2-1 
      DO 1500 J=ISTRC,IEND
      CALL SGET(ITEXT,J,ICHAR)
      IF ((ICHAR .GE. INFO(7)) .AND.
     +(ICHAR .LE. INFO(8))) GO TO 1550
      ICHAR=INFO(9) 
      IF (SKIP) GO TO 1550
      CALL PLTER(13,IDUMY)
C************************************************************** 
C READ IN THE APPROPRIATE PART OF THE WIDTH TABLE.
C 
1550  CONTINUE
      IOFF=ICHAR-INFO(7)+1
      IREC1=IOFF/128
      INDEX=MOD(IOFF,128) 
C 
      CALL READF(IDCB,IERR,IBUFR,128,LEN,ITBL+IREC1)
      IF (IERR .LT. 0) GO TO 8000 
C 
      IWIDE=IWIDE+IBUFR(INDEX)
1500  CONTINUE
      GO TO 3000
C********************************************************** 
C NO WIDTH TABLE. USE STANDARD VALUES.
C 
2000  CONTINUE
      IWIDE=ITEXL2*INFO(4)
      GO TO 3000
C******************************************************** 
C IWIDE NOW CONTAINS THE TOTAL LENGTH OF THE CHARACTERS IN
C CHARACTER COORDINATES.
C MULTIPLY BY THE XMTRX VALUES TO 
C GET THE CURRENT UNIT VALUES TO RETURN TO THE USER.
C 
3000  CONTINUE
      XWIDE=FLOAT(IWIDE)
      DELTX=XMTRX(1,1)*XWIDE
      DELTY=XMTRX(2,1)*XWIDE
D     WRITE(LU,3005) DELTX,DELTY
D3005 FORMAT(/"GLEN1: DELTX AND DELTY = ",2F9.5)
      RETURN
C*********************************************************
C FMP ERROR POINT.
C 
8000  CONTINUE
      CALL PLTER(IERR-300,IDUMY)
      RETURN
C*********************************************************
C ITEXL OR ISTRT .LE. 0 
C 
8500  CONTINUE
      CALL PLTER(9,IDUMY) 
      RETURN
      END 
                              