root / src / blas / drotmg.f @ 4
Historique | Voir | Annoter | Télécharger (4,77 ko)
| 1 |
SUBROUTINE DROTMG(DD1,DD2,DX1,DY1,DPARAM) |
|---|---|
| 2 |
* .. Scalar Arguments .. |
| 3 |
DOUBLE PRECISION DD1,DD2,DX1,DY1 |
| 4 |
* .. |
| 5 |
* .. Array Arguments .. |
| 6 |
DOUBLE PRECISION DPARAM(5) |
| 7 |
* .. |
| 8 |
* |
| 9 |
* Purpose |
| 10 |
* ======= |
| 11 |
* |
| 12 |
* CONSTRUCT THE MODIFIED GIVENS TRANSFORMATION MATRIX H WHICH ZEROS |
| 13 |
* THE SECOND COMPONENT OF THE 2-VECTOR (DSQRT(DD1)*DX1,DSQRT(DD2)* |
| 14 |
* DY2)**T. |
| 15 |
* WITH DPARAM(1)=DFLAG, H HAS ONE OF THE FOLLOWING FORMS.. |
| 16 |
* |
| 17 |
* DFLAG=-1.D0 DFLAG=0.D0 DFLAG=1.D0 DFLAG=-2.D0 |
| 18 |
* |
| 19 |
* (DH11 DH12) (1.D0 DH12) (DH11 1.D0) (1.D0 0.D0) |
| 20 |
* H=( ) ( ) ( ) ( ) |
| 21 |
* (DH21 DH22), (DH21 1.D0), (-1.D0 DH22), (0.D0 1.D0). |
| 22 |
* LOCATIONS 2-4 OF DPARAM CONTAIN DH11, DH21, DH12, AND DH22 |
| 23 |
* RESPECTIVELY. (VALUES OF 1.D0, -1.D0, OR 0.D0 IMPLIED BY THE |
| 24 |
* VALUE OF DPARAM(1) ARE NOT STORED IN DPARAM.) |
| 25 |
* |
| 26 |
* THE VALUES OF GAMSQ AND RGAMSQ SET IN THE DATA STATEMENT MAY BE |
| 27 |
* INEXACT. THIS IS OK AS THEY ARE ONLY USED FOR TESTING THE SIZE |
| 28 |
* OF DD1 AND DD2. ALL ACTUAL SCALING OF DATA IS DONE USING GAM. |
| 29 |
* |
| 30 |
* |
| 31 |
* Arguments |
| 32 |
* ========= |
| 33 |
* |
| 34 |
* DD1 (input/output) DOUBLE PRECISION |
| 35 |
* |
| 36 |
* DD2 (input/output) DOUBLE PRECISION |
| 37 |
* |
| 38 |
* DX1 (input/output) DOUBLE PRECISION |
| 39 |
* |
| 40 |
* DY1 (input) DOUBLE PRECISION |
| 41 |
* |
| 42 |
* DPARAM (input/output) DOUBLE PRECISION array, dimension 5 |
| 43 |
* DPARAM(1)=DFLAG |
| 44 |
* DPARAM(2)=DH11 |
| 45 |
* DPARAM(3)=DH21 |
| 46 |
* DPARAM(4)=DH12 |
| 47 |
* DPARAM(5)=DH22 |
| 48 |
* |
| 49 |
* ===================================================================== |
| 50 |
* |
| 51 |
* .. Local Scalars .. |
| 52 |
DOUBLE PRECISION DFLAG,DH11,DH12,DH21,DH22,DP1,DP2,DQ1,DQ2,DTEMP, |
| 53 |
+ DU,GAM,GAMSQ,ONE,RGAMSQ,TWO,ZERO |
| 54 |
INTEGER IGO |
| 55 |
* .. |
| 56 |
* .. Intrinsic Functions .. |
| 57 |
INTRINSIC DABS |
| 58 |
* .. |
| 59 |
* .. Data statements .. |
| 60 |
* |
| 61 |
DATA ZERO,ONE,TWO/0.D0,1.D0,2.D0/ |
| 62 |
DATA GAM,GAMSQ,RGAMSQ/4096.D0,16777216.D0,5.9604645D-8/ |
| 63 |
* .. |
| 64 |
|
| 65 |
IF (.NOT.DD1.LT.ZERO) GO TO 10 |
| 66 |
* GO ZERO-H-D-AND-DX1.. |
| 67 |
GO TO 60 |
| 68 |
10 CONTINUE |
| 69 |
* CASE-DD1-NONNEGATIVE |
| 70 |
DP2 = DD2*DY1 |
| 71 |
IF (.NOT.DP2.EQ.ZERO) GO TO 20 |
| 72 |
DFLAG = -TWO |
| 73 |
GO TO 260 |
| 74 |
* REGULAR-CASE.. |
| 75 |
20 CONTINUE |
| 76 |
DP1 = DD1*DX1 |
| 77 |
DQ2 = DP2*DY1 |
| 78 |
DQ1 = DP1*DX1 |
| 79 |
* |
| 80 |
IF (.NOT.DABS(DQ1).GT.DABS(DQ2)) GO TO 40 |
| 81 |
DH21 = -DY1/DX1 |
| 82 |
DH12 = DP2/DP1 |
| 83 |
* |
| 84 |
DU = ONE - DH12*DH21 |
| 85 |
* |
| 86 |
IF (.NOT.DU.LE.ZERO) GO TO 30 |
| 87 |
* GO ZERO-H-D-AND-DX1.. |
| 88 |
GO TO 60 |
| 89 |
30 CONTINUE |
| 90 |
DFLAG = ZERO |
| 91 |
DD1 = DD1/DU |
| 92 |
DD2 = DD2/DU |
| 93 |
DX1 = DX1*DU |
| 94 |
* GO SCALE-CHECK.. |
| 95 |
GO TO 100 |
| 96 |
40 CONTINUE |
| 97 |
IF (.NOT.DQ2.LT.ZERO) GO TO 50 |
| 98 |
* GO ZERO-H-D-AND-DX1.. |
| 99 |
GO TO 60 |
| 100 |
50 CONTINUE |
| 101 |
DFLAG = ONE |
| 102 |
DH11 = DP1/DP2 |
| 103 |
DH22 = DX1/DY1 |
| 104 |
DU = ONE + DH11*DH22 |
| 105 |
DTEMP = DD2/DU |
| 106 |
DD2 = DD1/DU |
| 107 |
DD1 = DTEMP |
| 108 |
DX1 = DY1*DU |
| 109 |
* GO SCALE-CHECK |
| 110 |
GO TO 100 |
| 111 |
* PROCEDURE..ZERO-H-D-AND-DX1.. |
| 112 |
60 CONTINUE |
| 113 |
DFLAG = -ONE |
| 114 |
DH11 = ZERO |
| 115 |
DH12 = ZERO |
| 116 |
DH21 = ZERO |
| 117 |
DH22 = ZERO |
| 118 |
* |
| 119 |
DD1 = ZERO |
| 120 |
DD2 = ZERO |
| 121 |
DX1 = ZERO |
| 122 |
* RETURN.. |
| 123 |
GO TO 220 |
| 124 |
* PROCEDURE..FIX-H.. |
| 125 |
70 CONTINUE |
| 126 |
IF (.NOT.DFLAG.GE.ZERO) GO TO 90 |
| 127 |
* |
| 128 |
IF (.NOT.DFLAG.EQ.ZERO) GO TO 80 |
| 129 |
DH11 = ONE |
| 130 |
DH22 = ONE |
| 131 |
DFLAG = -ONE |
| 132 |
GO TO 90 |
| 133 |
80 CONTINUE |
| 134 |
DH21 = -ONE |
| 135 |
DH12 = ONE |
| 136 |
DFLAG = -ONE |
| 137 |
90 CONTINUE |
| 138 |
GO TO IGO(120,150,180,210) |
| 139 |
* PROCEDURE..SCALE-CHECK |
| 140 |
100 CONTINUE |
| 141 |
110 CONTINUE |
| 142 |
IF (.NOT.DD1.LE.RGAMSQ) GO TO 130 |
| 143 |
IF (DD1.EQ.ZERO) GO TO 160 |
| 144 |
ASSIGN 120 TO IGO |
| 145 |
* FIX-H.. |
| 146 |
GO TO 70 |
| 147 |
120 CONTINUE |
| 148 |
DD1 = DD1*GAM**2 |
| 149 |
DX1 = DX1/GAM |
| 150 |
DH11 = DH11/GAM |
| 151 |
DH12 = DH12/GAM |
| 152 |
GO TO 110 |
| 153 |
130 CONTINUE |
| 154 |
140 CONTINUE |
| 155 |
IF (.NOT.DD1.GE.GAMSQ) GO TO 160 |
| 156 |
ASSIGN 150 TO IGO |
| 157 |
* FIX-H.. |
| 158 |
GO TO 70 |
| 159 |
150 CONTINUE |
| 160 |
DD1 = DD1/GAM**2 |
| 161 |
DX1 = DX1*GAM |
| 162 |
DH11 = DH11*GAM |
| 163 |
DH12 = DH12*GAM |
| 164 |
GO TO 140 |
| 165 |
160 CONTINUE |
| 166 |
170 CONTINUE |
| 167 |
IF (.NOT.DABS(DD2).LE.RGAMSQ) GO TO 190 |
| 168 |
IF (DD2.EQ.ZERO) GO TO 220 |
| 169 |
ASSIGN 180 TO IGO |
| 170 |
* FIX-H.. |
| 171 |
GO TO 70 |
| 172 |
180 CONTINUE |
| 173 |
DD2 = DD2*GAM**2 |
| 174 |
DH21 = DH21/GAM |
| 175 |
DH22 = DH22/GAM |
| 176 |
GO TO 170 |
| 177 |
190 CONTINUE |
| 178 |
200 CONTINUE |
| 179 |
IF (.NOT.DABS(DD2).GE.GAMSQ) GO TO 220 |
| 180 |
ASSIGN 210 TO IGO |
| 181 |
* FIX-H.. |
| 182 |
GO TO 70 |
| 183 |
210 CONTINUE |
| 184 |
DD2 = DD2/GAM**2 |
| 185 |
DH21 = DH21*GAM |
| 186 |
DH22 = DH22*GAM |
| 187 |
GO TO 200 |
| 188 |
220 CONTINUE |
| 189 |
IF (DFLAG) 250,230,240 |
| 190 |
230 CONTINUE |
| 191 |
DPARAM(3) = DH21 |
| 192 |
DPARAM(4) = DH12 |
| 193 |
GO TO 260 |
| 194 |
240 CONTINUE |
| 195 |
DPARAM(2) = DH11 |
| 196 |
DPARAM(5) = DH22 |
| 197 |
GO TO 260 |
| 198 |
250 CONTINUE |
| 199 |
DPARAM(2) = DH11 |
| 200 |
DPARAM(3) = DH21 |
| 201 |
DPARAM(4) = DH12 |
| 202 |
DPARAM(5) = DH22 |
| 203 |
260 CONTINUE |
| 204 |
DPARAM(1) = DFLAG |
| 205 |
RETURN |
| 206 |
END |