MINICERN/mathlib/gen/f/balanc.F

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.1.1.1  1996/04/01 15:02:32  mclareni
   6 * Mathlib gen
   7 *
   8 *
   9 #include "gen/pilot.h"
  10       SUBROUTINE BALANC(NM,N,A,LOW,IGH,SCALE)
  11       INTEGER I,J,K,L,M,N,JJ,NM,IGH,LOW,IEXC
  12       REAL A(NM,N),SCALE(N)
  13       REAL C,F,G,R,S,B2,RADIX
  14       LOGICAL NOCONV
  15       RADIX = 2.
  16       B2 = RADIX * RADIX
  17       K = 1
  18       L = N
  19       GO TO 100
  20    20 SCALE(M) = J
  21       IF (J .EQ. M) GO TO 50
  22       DO 30 I = 1, L
  23          F = A(I,J)
  24          A(I,J) = A(I,M)
  25          A(I,M) = F
  26    30 CONTINUE
  27       DO 40 I = K, N
  28          F = A(J,I)
  29          A(J,I) = A(M,I)
  30          A(M,I) = F
  31    40 CONTINUE
  32    50 GO TO (80,130), IEXC
  33    80 IF (L .EQ. 1) GO TO 280
  34       L = L - 1
  35   100 DO 120 JJ = 1, L
  36          J = L + 1 - JJ
  37          DO 110 I = 1, L
  38             IF (I .EQ. J) GO TO 110
  39             IF (A(J,I) .NE. 0.0) GO TO 120
  40   110    CONTINUE
  41          M = L
  42          IEXC = 1
  43          GO TO 20
  44   120 CONTINUE
  45       GO TO 140
  46   130 K = K + 1
  47   140 DO 170 J = K, L
  48          DO 150 I = K, L
  49             IF (I .EQ. J) GO TO 150
  50             IF (A(I,J) .NE. 0.0) GO TO 170
  51   150    CONTINUE
  52          M = K
  53          IEXC = 2
  54          GO TO 20
  55   170 CONTINUE
  56       DO 180 I = K, L
  57   180 SCALE(I) = 1.0
  58   190 NOCONV = .FALSE.
  59       DO 270 I = K, L
  60          C = 0.0
  61          R = 0.0
  62          DO 200 J = K, L
  63             IF (J .EQ. I) GO TO 200
  64             C = C + ABS(A(J,I))
  65             R = R + ABS(A(I,J))
  66   200    CONTINUE
  67          G = R / RADIX
  68          F = 1.0
  69          S = C + R
  70   210    IF (C .GE. G) GO TO 220
  71          F = F * RADIX
  72          C = C * B2
  73          GO TO 210
  74   220    G = R * RADIX
  75   230    IF (C .LT. G) GO TO 240
  76          F = F / RADIX
  77          C = C / B2
  78          GO TO 230
  79   240    IF ((C + R) / F .GE. 0.95 * S) GO TO 270
  80          G = 1.0 / F
  81          SCALE(I) = SCALE(I) * F
  82          NOCONV = .TRUE.
  83          DO 250 J = K, N
  84   250    A(I,J) = A(I,J) * G
  85          DO 260 J = 1, L
  86   260    A(J,I) = A(J,I) * F
  87   270 CONTINUE
  88       IF (NOCONV) GO TO 190
  89   280 LOW = K
  90       IGH = L
  91       RETURN
  92       END