home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 10 / 10.iso / l / l292 / 1.ddi / LOTUS.FOR < prev    next >
Encoding:
Text File  |  1990-03-01  |  4.2 KB  |  162 lines
  1.  
  2.       SUBROUTINE LotusFileSave (datary, rowlabel,
  3.      +      collabel, numrow, numcol, filename)
  4.       INCLUDE 'STDHDR.FOR'
  5.       REAL datary(0:maxr, 0:maxc)
  6.       CHARACTER * 15 rowlabel(0:maxC), collabel(0:maxC)
  7.       CHARACTER * 80 tempstr
  8.       CHARACTER * 20 filename
  9.       CHARACTER * 18 exstr(-1:maxc), fstr, nstr
  10.       INTEGER i, j, tlen
  11.  
  12.       OPEN (3, FILE = filename, STATUS = 'UNKNOWN')
  13.  
  14.       DO i = -1, numcol
  15.         exstr(i) = '                 '
  16.       END DO
  17.       tempstr = '               '
  18.       DO i = 1, 18
  19.         fstr(i:i) = ' '
  20.         nstr(i:i) = ' '
  21.       END DO
  22.  
  23.       CALL LotusString(REAL(numcol+1), 0,nstr)
  24.       fstr = '(1X'
  25.       CALL LotusCat(fstr,nstr)
  26.       nstr = 'A18 )'
  27.       CALL LotusCat(fstr,nstr)
  28.  
  29.       exstr(-1) = '"  ", '
  30.       DO j = 0, numcol - 1
  31.         tempstr = '"'
  32.         CALL LotusCat(tempstr, collabel(j))
  33.         tlen = LEN_TRIM(tempstr) + 1
  34.         tempStr(tlen:tlen) = '"'
  35.         IF (j .LT. numcol - 1)  THEN
  36.           tlen = tlen + 1
  37.           tempStr(tlen:tlen) = ','
  38.         END IF
  39.         exstr(j) = tempstr
  40.       END DO
  41.       WRITE (3,fstr) (exstr(j), j = -1, numcol-1)
  42.  
  43.  
  44.       DO i = 0, numrow - 1
  45.         tempstr = '"'
  46.         CALL LotusCat(tempstr,rowlabel(i))
  47.         CALL LotusCat(tempstr, '",')
  48.         exstr(-1) = tempstr
  49.         DO j = 0, numcol - 1
  50.           CALL LotusString(datary(i,j), 4, tempstr)
  51.           IF (j .LT. numcol - 1)  THEN
  52.            tlen = LEN_TRIM(tempstr) + 1
  53.            tempStr(tlen:tlen) = ','
  54.           END IF
  55.           exstr(j) = tempstr
  56.         END DO
  57.        WRITE (3,fstr) (exstr(j), j = -1, numcol-1)
  58.       END DO
  59.       WRITE(3,*) CHAR(26)
  60.       CLOSE (3)
  61.       END
  62.  
  63.  
  64.       SUBROUTINE LotusString (r, digits, TheString)
  65.       REAL r, tempr
  66.       CHARACTER *80 TheString
  67.       INTEGER  exponent, digits,  behind, before
  68.       INTEGER  i, y, strLen, location
  69.       LOGICAL sign
  70.  
  71.       DO i= 1, 80
  72.         TheString(i:i) = ' '
  73.       END DO
  74.       location = 1
  75.       tempr = r
  76.       strLen = ABS(REAL(digits)) + 2    !!!  min. 2 characters sign, digit
  77.       IF (digits .NE. 0) THEN strLen = strLen + 1
  78.       IF (digits .LT. 0) THEN strLen = strLen + 4
  79.       IF (tempr .LT. 0)   sign = .TRUE.
  80.       tempr = ABS(tempr)
  81.  
  82.       IF (digits .GE. 0)
  83.      +   tempr = tempr + 0.5 * LotusExp(-digits) + 1.0E-14
  84.  
  85.       !!!  normalize downward, less than 10
  86.       exponent = 0
  87.       DO WHILE (tempr .GE. 10.0)
  88.         tempr = tempr / 10.0
  89.         exponent = exponent + 1
  90.       END DO
  91.       IF (digits .GE. 0) THEN
  92.         before = exponent
  93.       ELSE
  94.         before = 0
  95.       END IF
  96.       behind = ABS(digits)
  97.  
  98.       !!!  Write digits before the decimal-point
  99.       y = AINT(tempr)
  100.       TheString(location:location) = CHAR(y+48)
  101.       location = location + 1
  102.       tempr = tempr - REAL(y)
  103.       DO WHILE (before .GT. 0)
  104.         tempr = tempr * 10.0
  105.         y = AINT(tempr)
  106.         TheString(location:location) =  CHAR(y+48)
  107.         strindex = strindex + 1
  108.         location = location + 1
  109.         tempr = tempr - y
  110.         before = before - 1
  111.       END DO
  112.       IF (behind .NE. 0) THEN
  113.         TheString(location:location) = '.'
  114.         strindex = strindex + 1
  115.         location = location + 1
  116.       END IF
  117.  
  118.       !!!  write digits after the decimal-point
  119.       DO WHILE (behind .GT. 0)
  120.         tempr = tempr * 10.0
  121.         y = AINT(tempr)
  122.         TheString(location:location) = CHAR(y + 48)
  123.         strindex = strindex + 1
  124.         location = location + 1
  125.         tempr = tempr - REAL(y)
  126.         behind = behind - 1
  127.       END DO
  128.  
  129.       END !SUBROUTINE
  130.  
  131.  
  132.  
  133.       FUNCTION Lotusexp (e)
  134.       INTEGER  e, i
  135.       REAL x
  136.  
  137.       x = 1.0
  138.       IF (e .GT. 0) THEN
  139.         DO i = 1, e
  140.           x = x * 10.0
  141.         END DO
  142.       ELSE
  143.         DO i = 1, -e, -1
  144.           x = x / 10.0
  145.         END DO
  146.         Lotusexp = x
  147.       END IF
  148.       END !FUNCTION
  149.  
  150.  
  151.       SUBROUTINE Lotuscat( outstr, s)
  152.       CHARACTER * (*) outstr, s
  153.       INTEGER LenO, LenS, i
  154.       LenO = LEN_TRIM(outstr) + 1
  155.       LenS = LEN_TRIM(s)
  156.       DO i = 1, Lens
  157.         outstr(LenO:LenO) = s(i:i)
  158.         LenO = LenO + 1
  159.       END DO
  160.       END !SUBROUTINE
  161.  
  162.