MINICERN/mathlib/gen/f/cbal.F

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