1      SUBROUTINE PROC (ND, BD, NM1, BM1, NM2, BM2, NA, AA, X, Y, M, A,
2     +   B, C, D, W, U)
3C***BEGIN PROLOGUE  PROC
4C***SUBSIDIARY
5C***PURPOSE  Subsidiary to CBLKTR
6C***LIBRARY   SLATEC
7C***TYPE      COMPLEX (PROD-S, PROC-C)
8C***AUTHOR  (UNKNOWN)
9C***DESCRIPTION
10C
11C PROC applies a sequence of matrix operations to the vector X and
12C  stores the result in Y.
13C BD,BM1,BM2 are arrays containing roots of certain B polynomials.
14C ND,NM1,NM2 are the lengths of the arrays BD,BM1,BM2 respectively.
15C AA         Array containing scalar multipliers of the vector X.
16C NA         is the length of the array AA.
17C X,Y        The matrix operations are applied to X and the result is Y.
18C A,B,C      are arrays which contain the tridiagonal matrix.
19C M          is the order of the matrix.
20C D,W,U      are working arrays.
21C IS         determines whether or not a change in sign is made.
22C
23C***SEE ALSO  CBLKTR
24C***ROUTINES CALLED  (NONE)
25C***REVISION HISTORY  (YYMMDD)
26C   801001  DATE WRITTEN
27C   890531  Changed all specific intrinsics to generic.  (WRB)
28C   891214  Prologue converted to Version 4.0 format.  (BAB)
29C   900402  Added TYPE section.  (WRB)
30C***END PROLOGUE  PROC
31C
32      DIMENSION       A(*)       ,B(*)       ,C(*)       ,X(*)       ,
33     1                Y(*)       ,D(*)       ,W(*)       ,BD(*)      ,
34     2                BM1(*)     ,BM2(*)     ,AA(*)      ,U(*)
35      COMPLEX         X          ,Y          ,A          ,B          ,
36     1                C          ,D          ,W          ,U          ,
37     2                DEN
38C***FIRST EXECUTABLE STATEMENT  PROC
39      DO 101 J=1,M
40         W(J) = X(J)
41         Y(J) = W(J)
42  101 CONTINUE
43      MM = M-1
44      ID = ND
45      IBR = 0
46      M1 = NM1
47      M2 = NM2
48      IA = NA
49  102 IF (IA) 105,105,103
50  103 RT = AA(IA)
51      IF (ND .EQ. 0) RT = -RT
52      IA = IA-1
53C
54C SCALAR MULTIPLICATION
55C
56      DO 104 J=1,M
57         Y(J) = RT*W(J)
58  104 CONTINUE
59  105 IF (ID) 125,125,106
60  106 RT = BD(ID)
61      ID = ID-1
62      IF (ID .EQ. 0) IBR = 1
63C
64C BEGIN SOLUTION TO SYSTEM
65C
66      D(M) = A(M)/(B(M)-RT)
67      W(M) = Y(M)/(B(M)-RT)
68      DO 107 J=2,MM
69         K = M-J
70         DEN = B(K+1)-RT-C(K+1)*D(K+2)
71         D(K+1) = A(K+1)/DEN
72         W(K+1) = (Y(K+1)-C(K+1)*W(K+2))/DEN
73  107 CONTINUE
74      DEN = B(1)-RT-C(1)*D(2)
75      W(1) = (1.,0.)
76      IF (ABS(DEN)) 108,109,108
77  108 W(1) = (Y(1)-C(1)*W(2))/DEN
78  109 DO 110 J=2,M
79         W(J) = W(J)-D(J)*W(J-1)
80  110 CONTINUE
81      IF (NA) 113,113,102
82  111 DO 112 J=1,M
83         Y(J) = W(J)
84  112 CONTINUE
85      IBR = 1
86      GO TO 102
87  113 IF (M1) 114,114,115
88  114 IF (M2) 111,111,120
89  115 IF (M2) 117,117,116
90  116 IF (ABS(BM1(M1))-ABS(BM2(M2))) 120,120,117
91  117 IF (IBR) 118,118,119
92  118 IF (ABS(BM1(M1)-BD(ID))-ABS(BM1(M1)-RT)) 111,119,119
93  119 RT = RT-BM1(M1)
94      M1 = M1-1
95      GO TO 123
96  120 IF (IBR) 121,121,122
97  121 IF (ABS(BM2(M2)-BD(ID))-ABS(BM2(M2)-RT)) 111,122,122
98  122 RT = RT-BM2(M2)
99      M2 = M2-1
100  123 DO 124 J=1,M
101         Y(J) = Y(J)+RT*W(J)
102  124 CONTINUE
103      GO TO 102
104  125 RETURN
105      END
106