MINICERN/mathlib/gen/f/tred2.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 TRED2(NM,N,A,D,E,Z)
  11       INTEGER I,J,K,L,N,II,NM,JP1
  12       REAL A(NM,N),D(N),E(N),Z(NM,N)
  13       REAL F,G,H,HH,SCALE
  14       DO 100 I = 1, N
  15          DO 100 J = 1, I
  16             Z(I,J) = A(I,J)
  17   100 CONTINUE
  18       IF (N .EQ. 1) GO TO 320
  19       DO 300 II = 2, N
  20          I = N + 2 - II
  21          L = I - 1
  22          H = 0.0
  23          SCALE = 0.0
  24          IF (L .LT. 2) GO TO 130
  25          DO 120 K = 1, L
  26   120    SCALE = SCALE + ABS(Z(I,K))
  27          IF (SCALE .NE. 0.0) GO TO 140
  28   130    E(I) = Z(I,L)
  29          GO TO 290
  30   140    DO 150 K = 1, L
  31             Z(I,K) = Z(I,K) / SCALE
  32             H = H + Z(I,K) * Z(I,K)
  33   150    CONTINUE
  34          F = Z(I,L)
  35          G = -SIGN(SQRT(H),F)
  36          E(I) = SCALE * G
  37          H = H - F * G
  38          Z(I,L) = F - G
  39          F = 0.0
  40          DO 240 J = 1, L
  41             Z(J,I) = Z(I,J) / (SCALE * H)
  42             G = 0.0
  43             DO 180 K = 1, J
  44   180       G = G + Z(J,K) * Z(I,K)
  45             JP1 = J + 1
  46             IF (L .LT. JP1) GO TO 220
  47             DO 200 K = JP1, L
  48   200       G = G + Z(K,J) * Z(I,K)
  49   220       E(J) = G / H
  50             F = F + E(J) * Z(I,J)
  51   240    CONTINUE
  52          HH = F / (H + H)
  53          DO 260 J = 1, L
  54             F = Z(I,J)
  55             G = E(J) - HH * F
  56             E(J) = G
  57             DO 260 K = 1, J
  58                Z(J,K) = Z(J,K) - F * E(K) - G * Z(I,K)
  59   260    CONTINUE
  60          DO 280 K = 1, L
  61   280    Z(I,K) = SCALE * Z(I,K)
  62   290    D(I) = H
  63   300 CONTINUE
  64   320 D(1) = 0.0
  65       E(1) = 0.0
  66       DO 500 I = 1, N
  67          L = I - 1
  68          IF (D(I) .EQ. 0.0) GO TO 380
  69          DO 360 J = 1, L
  70             G = 0.0
  71             DO 340 K = 1, L
  72   340       G = G + Z(I,K) * Z(K,J)
  73             DO 360 K = 1, L
  74                Z(K,J) = Z(K,J) - G * Z(K,I)
  75   360    CONTINUE
  76   380    D(I) = Z(I,I)
  77          Z(I,I) = 1.0
  78          IF (L .LT. 1) GO TO 500
  79          DO 400 J = 1, L
  80             Z(I,J) = 0.0
  81             Z(J,I) = 0.0
  82   400    CONTINUE
  83   500 CONTINUE
  84       RETURN
  85       END