MINICERN/mathlib/gen/f/htribk.F

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.1.1.1  1996/04/01 15:02:36  mclareni
   6 * Mathlib gen
   7 *
   8 *
   9 #include "gen/pilot.h"
  10       SUBROUTINE HTRIBK(NM,N,AR,AI,TAU,M,ZR,ZI)
  11       INTEGER I,J,K,L,M,N,NM
  12       REAL AR(NM,N),AI(NM,N),TAU(2,N),ZR(NM,M),ZI(NM,M)
  13       REAL H,S,SI
  14       DO 50 K = 1, N
  15          DO 50 J = 1, M
  16             ZI(K,J) = - ZR(K,J) * TAU(2,K)
  17             ZR(K,J) = ZR(K,J) * TAU(1,K)
  18    50 CONTINUE
  19       IF (N .EQ. 1) GO TO 200
  20       DO 140 I = 2, N
  21          L = I - 1
  22          H = AI(I,I)
  23          IF (H .EQ. 0.0) GO TO 140
  24          DO 130 J = 1, M
  25             S = 0.0
  26             SI = 0.0
  27             DO 110 K = 1, L
  28                S = S + AR(I,K) * ZR(K,J) - AI(I,K) * ZI(K,J)
  29                SI = SI + AR(I,K) * ZI(K,J) + AI(I,K) * ZR(K,J)
  30   110       CONTINUE
  31             S = S / H
  32             SI = SI / H
  33             DO 120 K = 1, L
  34                ZR(K,J) = ZR(K,J) - S * AR(I,K) - SI * AI(I,K)
  35                ZI(K,J) = ZI(K,J) - SI * AR(I,K) + S * AI(I,K)
  36   120       CONTINUE
  37   130    CONTINUE
  38   140 CONTINUE
  39   200 RETURN
  40       END