Mercurial > octave-nkf

annotate libcruft/ordered-qz/sexchqz.f @ 7793:96ba591be50f

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Add some more support for single precision to libcruft functions
author David Bateman <dbateman@free.fr>
date Sun, 11 May 2008 22:51:50 +0200
parents
children
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
rev   line source
7793
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
1 SUBROUTINE SEXCHQZ(NMAX, N, A, B, Z, L, LS1, LS2, EPS, FAIL)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
2 INTEGER NMAX, N, L, LS1, LS2
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
3 REAL A(NMAX,N), B(NMAX,N), Z(NMAX,N), EPS
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
4 LOGICAL FAIL
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
5 c modified july 9, 1998 a.s.hodel@eng.auburn.edu:
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
6 c calls to AMAX1 changed to call MAX instead.
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
7 c calls to giv changed to slartg (LAPACK); required new variable tempr
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
8 C*
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
9 C* GIVEN THE UPPER TRIANGULAR MATRIX B AND UPPER HESSENBERG MATRIX A
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
10 C* WITH CONSECUTIVE LS1XLS1 AND LS2XLS2 DIAGONAL BLOCKS (LS1,LS2.LE.2)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
11 C* STARTING AT ROW/COLUMN L, EXCHQZ PRODUCES EQUIVALENCE TRANSFORMA-
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
12 C* TIONS QT AND ZT THAT EXCHANGE THE BLOCKS ALONG WITH THEIR GENERALIZED
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
13 C* EIGENVALUES. EXCHQZ REQUIRES THE SUBROUTINES SROT (BLAS) AND GIV.
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
14 C* THE PARAMETERS IN THE CALLING SEQUENCE ARE (STARRED PARAMETERS ARE
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
15 C* ALTERED BY THE SUBROUTINE):
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
16 C*
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
17 C* NMAX THE FIRST DIMENSION OF A, B AND Z
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
18 C* N THE ORDER OF A, B AND Z
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
19 C* *A,*B THE MATRIX PAIR WHOSE BLOCKS ARE TO BE INTERCHANGED
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
20 C* *Z UPON RETURN THIS ARRAY IS MULTIPLIED BY THE COLUMN
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
21 C* TRANSFORMATION ZT.
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
22 C* L THE POSITION OF THE BLOCKS
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
23 C* LS1 THE SIZE OF THE FIRST BLOCK
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
24 C* LS2 THE SIZE OF THE SECOND BLOCK
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
25 C* EPS THE REQUIRED ABSOLUTE ACCURACY OF THE RESULT
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
26 C* *FAIL A LOGICAL VARIABLE WHICH IS FALSE ON A NORMAL RETURN,
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
27 C* TRUE OTHERWISE.
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
28 C*
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
29 INTEGER I, J, L1, L2, L3, LI, LJ, LL, IT1, IT2
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
30 REAL U(3,3), D, E, F, G, SA, SB, A11B11, A21B11,
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
31 * A12B22, B12B22,
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
32 * A22B22, AMMBMM, ANMBMM, AMNBNN, BMNBNN, ANNBNN, TEMPR
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
33 LOGICAL ALTB
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
34 FAIL = .FALSE.
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
35 L1 = L + 1
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
36 LL = LS1 + LS2
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
37 IF (LL.GT.2) GO TO 10
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
38 C*** INTERCHANGE 1X1 AND 1X1 BLOCKS VIA AN EQUIVALENCE
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
39 C*** TRANSFORMATION A:=Q*A*Z , B:=Q*B*Z
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
40 C*** WHERE Q AND Z ARE GIVENS ROTATIONS
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
41 F = MAX(ABS(A(L1,L1)),ABS(B(L1,L1)))
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
42 ALTB = .TRUE.
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
43 IF (ABS(A(L1,L1)).GE.F) ALTB = .FALSE.
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
44 SA = A(L1,L1)/F
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
45 SB = B(L1,L1)/F
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
46 F = SA*B(L,L) - SB*A(L,L)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
47 C* CONSTRUCT THE COLUMN TRANSFORMATION Z
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
48 G = SA*B(L,L1) - SB*A(L,L1)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
49 CALL SLARTG(F, G, D, E,TEMPR)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
50 CALL SROT(L1, A(1,L), 1, A(1,L1), 1, E, -D)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
51 CALL SROT(L1, B(1,L), 1, B(1,L1), 1, E, -D)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
52 CALL SROT(N, Z(1,L), 1, Z(1,L1), 1, E, -D)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
53 C* CONSTRUCT THE ROW TRANSFORMATION Q
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
54 IF (ALTB) CALL SLARTG(B(L,L), B(L1,L), D, E,TEMPR)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
55 IF (.NOT.ALTB) CALL SLARTG(A(L,L), A(L1,L), D, E,TEMPR)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
56 CALL SROT(N-L+1, A(L,L), NMAX, A(L1,L), NMAX, D, E)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
57 CALL SROT(N-L+1, B(L,L), NMAX, B(L1,L), NMAX, D, E)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
58 A(L1,L) = 0.
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
59 B(L1,L) = 0.
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
60 RETURN
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
61 C*** INTERCHANGE 1X1 AND 2X2 BLOCKS VIA AN EQUIVALENCE
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
62 C*** TRANSFORMATION A:=Q2*Q1*A*Z1*Z2 , B:=Q2*Q1*B*Z1*Z2
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
63 C*** WHERE EACH QI AND ZI IS A GIVENS ROTATION
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
64 10 L2 = L + 2
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
65 IF (LS1.EQ.2) GO TO 60
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
66 G = MAX(ABS(A(L,L)),ABS(B(L,L)))
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
67 ALTB = .TRUE.
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
68 IF (ABS(A(L,L)).LT.G) GO TO 20
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
69 ALTB = .FALSE.
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
70 CALL SLARTG(A(L1,L1), A(L2,L1), D, E,TEMPR)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
71 CALL SROT(N-L, A(L1,L1), NMAX, A(L2,L1), NMAX, D, E)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
72 CALL SROT(N-L, B(L1,L1), NMAX, B(L2,L1), NMAX, D, E)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
73 C** EVALUATE THE PENCIL AT THE EIGENVALUE CORRESPONDING
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
74 C** TO THE 1X1 BLOCK
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
75 20 SA = A(L,L)/G
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
76 SB = B(L,L)/G
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
77 DO 40 J=1,2
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
78 LJ = L + J
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
79 DO 30 I=1,3
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
80 LI = L + I - 1
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
81 U(I,J) = SA*B(LI,LJ) - SB*A(LI,LJ)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
82 30 CONTINUE
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
83 40 CONTINUE
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
84 CALL SLARTG(U(3,1), U(3,2), D, E,TEMPR)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
85 CALL SROT(3, U(1,1), 1, U(1,2), 1, E, -D)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
86 C* PERFORM THE ROW TRANSFORMATION Q1
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
87 CALL SLARTG(U(1,1), U(2,1), D, E,TEMPR)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
88 U(2,2) = -U(1,2)*E + U(2,2)*D
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
89 CALL SROT(N-L+1, A(L,L), NMAX, A(L1,L), NMAX, D, E)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
90 CALL SROT(N-L+1, B(L,L), NMAX, B(L1,L), NMAX, D, E)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
91 C* PERFORM THE COLUMN TRANSFORMATION Z1
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
92 IF (ALTB) CALL SLARTG(B(L1,L), B(L1,L1), D, E,TEMPR)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
93 IF (.NOT.ALTB) CALL SLARTG(A(L1,L), A(L1,L1), D, E,TEMPR)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
94 CALL SROT(L2, A(1,L), 1, A(1,L1), 1, E, -D)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
95 CALL SROT(L2, B(1,L), 1, B(1,L1), 1, E, -D)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
96 CALL SROT(N, Z(1,L), 1, Z(1,L1), 1, E, -D)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
97 C* PERFORM THE ROW TRANSFORMATION Q2
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
98 CALL SLARTG(U(2,2), U(3,2), D, E,TEMPR)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
99 CALL SROT(N-L+1, A(L1,L), NMAX, A(L2,L), NMAX, D, E)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
100 CALL SROT(N-L+1, B(L1,L), NMAX, B(L2,L), NMAX, D, E)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
101 C* PERFORM THE COLUMN TRANSFORMATION Z2
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
102 IF (ALTB) CALL SLARTG(B(L2,L1), B(L2,L2), D, E,TEMPR)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
103 IF (.NOT.ALTB) CALL SLARTG(A(L2,L1), A(L2,L2), D, E,TEMPR)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
104 CALL SROT(L2, A(1,L1), 1, A(1,L2), 1, E, -D)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
105 CALL SROT(L2, B(1,L1), 1, B(1,L2), 1, E, -D)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
106 CALL SROT(N, Z(1,L1), 1, Z(1,L2), 1, E, -D)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
107 IF (ALTB) GO TO 50
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
108 CALL SLARTG(B(L,L), B(L1,L), D, E,TEMPR)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
109 CALL SROT(N-L+1, A(L,L), NMAX, A(L1,L), NMAX, D, E)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
110 CALL SROT(N-L+1, B(L,L), NMAX, B(L1,L), NMAX, D, E)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
111 C* PUT THE NEGLECTABLE ELEMENTS EQUAL TO ZERO
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
112 50 A(L2,L) = 0.
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
113 A(L2,L1) = 0.
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
114 B(L1,L) = 0.
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
115 B(L2,L) = 0.
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
116 B(L2,L1) = 0.
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
117 RETURN
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
118 C*** INTERCHANGE 2X2 AND 1X1 BLOCKS VIA AN EQUIVALENCE
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
119 C*** TRANSFORMATION A:=Q2*Q1*A*Z1*Z2 , B:=Q2*Q1*B*Z1*Z2
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
120 C*** WHERE EACH QI AND ZI IS A GIVENS ROTATION
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
121 60 IF (LS2.EQ.2) GO TO 110
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
122 G = MAX(ABS(A(L2,L2)),ABS(B(L2,L2)))
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
123 ALTB = .TRUE.
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
124 IF (ABS(A(L2,L2)).LT.G) GO TO 70
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
125 ALTB = .FALSE.
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
126 CALL SLARTG(A(L,L), A(L1,L), D, E,TEMPR)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
127 CALL SROT(N-L+1, A(L,L), NMAX, A(L1,L), NMAX, D, E)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
128 CALL SROT(N-L+1, B(L,L), NMAX, B(L1,L), NMAX, D, E)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
129 C** EVALUATE THE PENCIL AT THE EIGENVALUE CORRESPONDING
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
130 C** TO THE 1X1 BLOCK
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
131 70 SA = A(L2,L2)/G
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
132 SB = B(L2,L2)/G
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
133 DO 90 I=1,2
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
134 LI = L + I - 1
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
135 DO 80 J=1,3
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
136 LJ = L + J - 1
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
137 U(I,J) = SA*B(LI,LJ) - SB*A(LI,LJ)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
138 80 CONTINUE
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
139 90 CONTINUE
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
140 CALL SLARTG(U(1,1), U(2,1), D, E,TEMPR)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
141 CALL SROT(3, U(1,1), 3, U(2,1), 3, D, E)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
142 C* PERFORM THE COLUMN TRANSFORMATION Z1
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
143 CALL SLARTG(U(2,2), U(2,3), D, E,TEMPR)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
144 U(1,2) = U(1,2)*E - U(1,3)*D
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
145 CALL SROT(L2, A(1,L1), 1, A(1,L2), 1, E, -D)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
146 CALL SROT(L2, B(1,L1), 1, B(1,L2), 1, E, -D)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
147 CALL SROT(N, Z(1,L1), 1, Z(1,L2), 1, E, -D)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
148 C* PERFORM THE ROW TRANSFORMATION Q1
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
149 IF (ALTB) CALL SLARTG(B(L1,L1), B(L2,L1), D, E,TEMPR)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
150 IF (.NOT.ALTB) CALL SLARTG(A(L1,L1), A(L2,L1), D, E,TEMPR)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
151 CALL SROT(N-L+1, A(L1,L), NMAX, A(L2,L), NMAX, D, E)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
152 CALL SROT(N-L+1, B(L1,L), NMAX, B(L2,L), NMAX, D, E)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
153 C* PERFORM THE COLUMN TRANSFORMATION Z2
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
154 CALL SLARTG(U(1,1), U(1,2), D, E,TEMPR)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
155 CALL SROT(L2, A(1,L), 1, A(1,L1), 1, E, -D)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
156 CALL SROT(L2, B(1,L), 1, B(1,L1), 1, E, -D)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
157 CALL SROT(N, Z(1,L), 1, Z(1,L1), 1, E, -D)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
158 C* PERFORM THE ROW TRANSFORMATION Q2
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
159 IF (ALTB) CALL SLARTG(B(L,L), B(L1,L), D, E,TEMPR)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
160 IF (.NOT.ALTB) CALL SLARTG(A(L,L), A(L1,L), D, E,TEMPR)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
161 CALL SROT(N-L+1, A(L,L), NMAX, A(L1,L), NMAX, D, E)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
162 CALL SROT(N-L+1, B(L,L), NMAX, B(L1,L), NMAX, D, E)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
163 IF (ALTB) GO TO 100
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
164 CALL SLARTG(B(L1,L1), B(L2,L1), D, E,TEMPR)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
165 CALL SROT(N-L, A(L1,L1), NMAX, A(L2,L1), NMAX, D, E)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
166 CALL SROT(N-L, B(L1,L1), NMAX, B(L2,L1), NMAX, D, E)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
167 C* PUT THE NEGLECTABLE ELEMENTS EQUAL TO ZERO
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
168 100 A(L1,L) = 0.
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
169 A(L2,L) = 0.
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
170 B(L1,L) = 0.
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
171 B(L2,1) = 0.
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
172 B(L2,L1) = 0.
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
173 RETURN
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
174 C*** INTERCHANGE 2X2 AND 2X2 BLOCKS VIA A SEQUENCE OF
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
175 C*** QZ-STEPS REALIZED BY THE EQUIVALENCE TRANSFORMATIONS
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
176 C*** A:=Q5*Q4*Q3*Q2*Q1*A*Z1*Z2*Z3*Z4*Z5
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
177 C*** B:=Q5*Q4*Q3*Q2*Q1*B*Z1*Z2*Z3*Z4*Z5
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
178 C*** WHERE EACH QI AND ZI IS A GIVENS ROTATION
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
179 110 L3 = L + 3
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
180 C* COMPUTE IMPLICIT SHIFT
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
181 AMMBMM = A(L,L)/B(L,L)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
182 ANMBMM = A(L1,L)/B(L,L)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
183 AMNBNN = A(L,L1)/B(L1,L1)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
184 ANNBNN = A(L1,L1)/B(L1,L1)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
185 BMNBNN = B(L,L1)/B(L1,L1)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
186 DO 130 IT1=1,3
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
187 U(1,1) = 1.
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
188 U(2,1) = 1.
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
189 U(3,1) = 1.
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
190 DO 120 IT2=1,10
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
191 C* PERFORM ROW TRANSFORMATIONS Q1 AND Q2
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
192 CALL SLARTG(U(2,1), U(3,1), D, E,TEMPR)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
193 CALL SROT(N-L+1, A(L1,L), NMAX, A(L2,L), NMAX, D, E)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
194 CALL SROT(N-L, B(L1,L1), NMAX, B(L2,L1), NMAX, D, E)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
195 U(2,1) = D*U(2,1) + E*U(3,1)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
196 CALL SLARTG(U(1,1), U(2,1), D, E,TEMPR)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
197 CALL SROT(N-L+1, A(L,L), NMAX, A(L1,L), NMAX, D, E)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
198 CALL SROT(N-L+1, B(L,L), NMAX, B(L1,L), NMAX, D, E)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
199 C* PERFORM COLUMN TRANSFORMATIONS Z1 AND Z2
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
200 CALL SLARTG(B(L2,L1), B(L2,L2), D, E,TEMPR)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
201 CALL SROT(L3, A(1,L1), 1, A(1,L2), 1, E, -D)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
202 CALL SROT(L2, B(1,L1), 1, B(1,L2), 1, E, -D)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
203 CALL SROT(N, Z(1,L1), 1, Z(1,L2), 1, E, -D)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
204 CALL SLARTG(B(L1,L), B(L1,L1), D, E,TEMPR)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
205 CALL SROT(L3, A(1,L), 1, A(1,L1), 1, E, -D)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
206 CALL SROT(L1, B(1,L), 1, B(1,L1), 1, E, -D)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
207 CALL SROT(N, Z(1,L), 1, Z(1,L1), 1, E, -D)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
208 C* PERFORM TRANSFORMATIONS Q3,Z3,Q4,Z4,Q5 AND Z5 IN
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
209 C* ORDER TO REDUCE THE PENCIL TO HESSENBERG FORM
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
210 CALL SLARTG(A(L2,L), A(L3,L), D, E,TEMPR)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
211 CALL SROT(N-L+1, A(L2,L), NMAX, A(L3,L), NMAX, D, E)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
212 CALL SROT(N-L1, B(L2,L2), NMAX, B(L3,L2), NMAX, D, E)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
213 CALL SLARTG(B(L3,L2), B(L3,L3), D, E,TEMPR)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
214 CALL SROT(L3, A(1,L2), 1, A(1,L3), 1, E, -D)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
215 CALL SROT(L3, B(1,L2), 1, B(1,L3), 1, E, -D)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
216 CALL SROT(N, Z(1,L2), 1, Z(1,L3), 1, E, -D)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
217 CALL SLARTG(A(L1,L), A(L2,L), D, E,TEMPR)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
218 CALL SROT(N-L+1, A(L1,L), NMAX, A(L2,L), NMAX, D, E)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
219 CALL SROT(N-L, B(L1,L1), NMAX, B(L2,L1), NMAX, D, E)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
220 CALL SLARTG(B(L2,L1), B(L2,L2), D, E,TEMPR)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
221 CALL SROT(L3, A(1,L1), 1, A(1,L2), 1, E, -D)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
222 CALL SROT(L2, B(1,L1), 1, B(1,L2), 1, E, -D)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
223 CALL SROT(N, Z(1,L1), 1, Z(1,L2), 1, E, -D)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
224 CALL SLARTG(A(L2,L1), A(L3,L1), D, E,TEMPR)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
225 CALL SROT(N-L, A(L2,L1), NMAX, A(L3,L1), NMAX, D, E)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
226 CALL SROT(N-L1, B(L2,L2), NMAX, B(L3,L2), NMAX, D, E)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
227 CALL SLARTG(B(L3,L2), B(L3,L3), D, E,TEMPR)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
228 CALL SROT(L3, A(1,L2), 1, A(1,L3), 1, E, -D)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
229 CALL SROT(L3, B(1,L2), 1, B(1,L3), 1, E, -D)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
230 CALL SROT(N, Z(1,L2), 1, Z(1,L3), 1, E, -D)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
231 C* TEST OF CONVERGENCE ON THE ELEMENT SEPARATING THE BLOCKS
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
232 IF (ABS(A(L2,L1)).LE.EPS) GO TO 140
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
233 C* COMPUTE A NEW SHIFT IN CASE OF NO CONVERGENCE
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
234 A11B11 = A(L,L)/B(L,L)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
235 A12B22 = A(L,L1)/B(L1,L1)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
236 A21B11 = A(L1,L)/B(L,L)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
237 A22B22 = A(L1,L1)/B(L1,L1)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
238 B12B22 = B(L,L1)/B(L1,L1)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
239 U(1,1) = ((AMMBMM-A11B11)*(ANNBNN-A11B11)-AMNBNN*
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
240 * ANMBMM+ANMBMM*BMNBNN*A11B11)/A21B11 + A12B22 - A11B11*B12B22
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
241 U(2,1) = (A22B22-A11B11) - A21B11*B12B22 - (AMMBMM-A11B11) -
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
242 * (ANNBNN-A11B11) + ANMBMM*BMNBNN
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
243 U(3,1) = A(L2,L1)/B(L1,L1)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
244 120 CONTINUE
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
245 130 CONTINUE
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
246 FAIL = .TRUE.
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
247 RETURN
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
248 C* PUT THE NEGLECTABLE ELEMENTS EQUAL TO ZERO IN
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
249 C* CASE OF CONVERGENCE
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
250 140 A(L2,L) = 0.
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
251 A(L2,L1) = 0.
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
252 A(L3,L) = 0.
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
253 A(L3,L1) = 0.
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
254 B(L1,L) = 0.
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
255 B(L2,L) = 0.
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
256 B(L2,L1) = 0.
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
257 B(L3,L) = 0.
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
258 B(L3,L1) = 0.
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
259 B(L3,L2) = 0.
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
260 RETURN
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
261 END