MINICERN/mathlib/gen/f/tred1.F

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.1.1.1  1996/04/01 15:02:38  mclareni
   6 * Mathlib gen
   7 *
   8 *
   9 #include "gen/pilot.h"
  10       SUBROUTINE TRED1(NM,N,A,D,E,E2)
  11       INTEGER I,J,K,L,N,II,NM,JP1
  12       REAL A(NM,N),D(N),E(N),E2(N)
  13       REAL F,G,H,SCALE
  14       DO 100 I = 1, N
  15   100 D(I) = A(I,I)
  16       DO  300 II = 1, N
  17          I = N + 1 - II
  18          L = I - 1
  19          H = 0.0
  20          SCALE = 0.0
  21          IF (L .LT. 1) GO TO 130
  22          DO 120 K = 1, L
  23   120    SCALE = SCALE + ABS(A(I,K))
  24          IF (SCALE .NE. 0.0) GO TO 140
  25   130    E(I) = 0.0
  26          E2(I) = 0.0
  27          GO TO 290
  28   140    DO 150 K = 1, L
  29             A(I,K) = A(I,K) / SCALE
  30             H = H + A(I,K) * A(I,K)
  31   150    CONTINUE
  32          E2(I) = SCALE * SCALE * H
  33          F = A(I,L)
  34          G = -SIGN(SQRT(H),F)
  35          E(I) = SCALE * G
  36          H = H - F * G
  37          A(I,L) = F - G
  38          IF (L .EQ. 1) GO TO 270
  39          F = 0.0
  40          DO 240 J = 1, L
  41             G = 0.0
  42             DO 180 K = 1, J
  43   180       G = G + A(J,K) * A(I,K)
  44             JP1 = J + 1
  45             IF (L .LT. JP1) GO TO 220
  46             DO 200 K = JP1, L
  47   200       G = G + A(K,J) * A(I,K)
  48   220       E(J) = G / H
  49             F = F + E(J) * A(I,J)
  50   240    CONTINUE
  51          H = F / (H + H)
  52          DO 260 J = 1, L
  53             F = A(I,J)
  54             G = E(J) - H * F
  55             E(J) = G
  56             DO 260 K = 1, J
  57                A(J,K) = A(J,K) - F * E(K) - G * A(I,K)
  58   260    CONTINUE
  59   270    DO 280 K = 1, L
  60   280    A(I,K) = SCALE * A(I,K)
  61   290    H = D(I)
  62          D(I) = A(I,I)
  63          A(I,I) = H
  64   300 CONTINUE
  65       RETURN
  66       END