*-----------------------------------------------------------------------
*     USPACK REAL TO CHARACTER                       S. Sakai  90/03/16
*-----------------------------------------------------------------------
*     Copyright (C) 2000-2022 GFD Dennou Club. All rights reserved.
*-----------------------------------------------------------------------
      SUBROUTINE USCHVL(X, CHX)

      CHARACTER CHX*(*), CFMT*16, CVAL*16, CEXP*16, CEXP2*16, USGI*3
      REAL X
      LOGICAL LEXP, LCNTL, LSFNT, LCNTLZ

      CHARACTER CVAL2*16
      INTEGER NSPACE

      CALL SGLGET('LCNTL', LCNTL)
      LCNTLZ = LCNTL
      LCNTL = .TRUE.

      CALL SWLGET('LSYSFNT',LSFNT)
      CALL GLRGET('REPSL', PREC)
      NPREC = -LOG10(PREC)
      IF(NPREC.GT.8) NPREC = 8

      CFMT = '(E16.xE3)'
      WRITE(CFMT(6:6), '(I1)') NPREC
      WRITE(CVAL, CFMT) X

      CFMT = '(F11.x, TR1, I4)'
      WRITE(CFMT(6:6), '(I1)') NPREC
      READ (CVAL, CFMT) XX, NEXP

*------------------------ effective digits -----------------------------

      DO 10 N=11, 4, -1
        NDIG=N
        IF(CVAL(N:N).NE.'0') GOTO 20
   10 CONTINUE
   20 CONTINUE
      NDIG = NDIG - INDEX(CVAL, '.')

*----------------------------- mantissa --------------------------------

      NLOW = NEXP - NDIG + 1
      LEXP = NEXP.LE.-3 .OR. NLOW.GE.5

      IF(LEXP) THEN
        XX = XX*10
        NPREC = NDIG - 1
      ELSE
        XX = XX*1.D1**NEXP
        NPREC = -NLOW + 1
      ENDIF

      IF(NPREC.GE.1) THEN
        CFMT = '(SP, F16.x)'
        WRITE(CFMT(10:10), '(I1)')  NPREC
        WRITE(CVAL, CFMT) XX
      ELSE
        CFMT = '(SP, I16)'
        IX = NINT(XX)
        WRITE(CVAL, CFMT) IX
      ENDIF

      CALL CLADJ(CVAL)

*------------------------ For F2C --------------------------------------

      NSPACE=0
      DO 3 N=1,13
        IF (CVAL(N:N).NE.' ' .AND. CVAL(N:N).NE.'+'
     + .AND. CVAL(N:N).NE.'-' .AND. NSPACE.EQ.0) THEN
          NSPACE=N
        END IF
    3 CONTINUE
      IF (CVAL(NSPACE:NSPACE).EQ.'.')THEN
          CVAL2=CVAL(1:NSPACE-1)//'0'//CVAL(NSPACE:15)
          CVAL=CVAL2
      END IF

*-------------------------- characteristic -----------------------------

      IF(LEXP) THEN
        NEXP = NEXP - 1
        WRITE(CEXP2, '(I3)') NEXP
        CALL CLADJ(CEXP2)
        IF(LCNTL) THEN
              CEXP = USGI(194)//'10\^{'//CEXP2(1:LENC(CEXP2))
     +        //'}'
        ELSE
          CEXP = 'E'//CEXP2(1:LENC(CEXP2))
        END IF
      ELSE
        CEXP = ' '
      ENDIF

*-----------------------------------------------------------------------

      IF(LCNTL .AND. CVAL(2:3).EQ.'1 ' .AND. CEXP.NE.'  ') THEN
        IF(CEXP(1:3).EQ.USGI(194))THEN
          CHX = CVAL(1:1) // CEXP(4:16)
        ELSE
          CHX = CVAL(1:1) // CEXP(2:16)
        ENDIF
      ELSE
        CHX = CVAL(1:LENC(CVAL)) // CEXP
      ENDIF

      LCNTL = LCNTLZ

      RETURN
      END
