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