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