MINICERN/packlib/kernlib/kerngen/tcgen/setfmt.F

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.1.1.1  1996/02/15 17:49:49  mclareni
   6 * Kernlib
   7 *
   8 *
   9 #include "kerngen/pilot.h"
  10 #if !defined(CERNLIB_TCGEN)
  11       SUBROUTINE SETFMT (FMTLET,FMTNUM,NDIG,XX,NX)
  12 C
  13 C CERN PROGLIB# M224    SETFMT          .VERSION KERNFOR  4.08  840613
  14 C ORIG. 01/08/71
  15 C
  16       DIMENSION    XX(9)
  17       INTEGER      FMTLET,FMTNUM, FMTN(10),EE,EF
  18       DATA  FMTN   / 4H0   ,4H1   ,4H2   ,4H3   ,4H4   ,4H5   ,
  19      +                      4H6   ,4H7   ,4H8   ,4H9    /
  20       DATA  EE,EF  / 4HE   ,4HF    /
  21       DATA  VERYSM / 1.E-36 /
  22 C
  23 C
  24       XBIG= 0.
  25       MXV = MIN (NDIG,9)
  26       N   = 0
  27 C
  28       DO 9 J=1,NX
  29     9 XBIG =  MAX (ABS(XX(J)), XBIG)
  30 C
  31       IF (XBIG .EQ. 0.)      GO TO 24
  32       IF (XBIG .LT. VERYSM)  GO TO 21
  33 C
  34 C----      NINT = NO. OF DIGITS BEFORE THE DECIMAL POINT
  35 C--        N    = NO. OF DIGITS AFTER  THE DECIMAL POINT
  36 C--       -NINT = NO.OF ZEROES AFTER THE DECIMAL POINT, IF PURE FRACTION
  37 C
  38       NINT = INT (LOG10(XBIG)+100.) - 99
  39       IF  (NINT .GT. NDIG)  GO TO 21
  40       IF (-NINT .GT. MXV-2) GO TO 21
  41       MXV= MIN(9, MAX(0, NDIG-MAX(0,NINT)) )
  42       BIAS= .25*10.**(-MXV)
  43       TOL = BIAS+BIAS
  44 C
  45       DO 19 J=1,NX
  46       X = (ABS(XX(J))+BIAS) * 10.**N
  47 C
  48    12 IF (N .GE. MXV)  GO TO 24
  49       X = X - AINT(X)
  50       IF (X .LT. TOL)  GO TO 19
  51       TOL= 10.*TOL
  52       X  = 10.*X
  53       N  = N+1
  54       GO TO 12
  55    19 CONTINUE
  56       GO TO 24
  57 C
  58    21 FMTLET= EE
  59       N     = MIN(5, NDIG-5)
  60       GO TO 25
  61 C
  62    24 FMTLET= EF
  63    25 FMTNUM= FMTN(N+1)
  64       RETURN
  65 C
  66       END
  67 #endif