![]() |
LAPACK
3.4.1
LAPACK: Linear Algebra PACKage
|
00001 *> \brief \b DROTMG 00002 * 00003 * =========== DOCUMENTATION =========== 00004 * 00005 * Online html documentation available at 00006 * http://www.netlib.org/lapack/explore-html/ 00007 * 00008 * Definition: 00009 * =========== 00010 * 00011 * SUBROUTINE DROTMG(DD1,DD2,DX1,DY1,DPARAM) 00012 * 00013 * .. Scalar Arguments .. 00014 * DOUBLE PRECISION DD1,DD2,DX1,DY1 00015 * .. 00016 * .. Array Arguments .. 00017 * DOUBLE PRECISION DPARAM(5) 00018 * .. 00019 * 00020 * 00021 *> \par Purpose: 00022 * ============= 00023 *> 00024 *> \verbatim 00025 *> 00026 *> CONSTRUCT THE MODIFIED GIVENS TRANSFORMATION MATRIX H WHICH ZEROS 00027 *> THE SECOND COMPONENT OF THE 2-VECTOR (DSQRT(DD1)*DX1,DSQRT(DD2)*> DY2)**T. 00028 *> WITH DPARAM(1)=DFLAG, H HAS ONE OF THE FOLLOWING FORMS.. 00029 *> 00030 *> DFLAG=-1.D0 DFLAG=0.D0 DFLAG=1.D0 DFLAG=-2.D0 00031 *> 00032 *> (DH11 DH12) (1.D0 DH12) (DH11 1.D0) (1.D0 0.D0) 00033 *> H=( ) ( ) ( ) ( ) 00034 *> (DH21 DH22), (DH21 1.D0), (-1.D0 DH22), (0.D0 1.D0). 00035 *> LOCATIONS 2-4 OF DPARAM CONTAIN DH11, DH21, DH12, AND DH22 00036 *> RESPECTIVELY. (VALUES OF 1.D0, -1.D0, OR 0.D0 IMPLIED BY THE 00037 *> VALUE OF DPARAM(1) ARE NOT STORED IN DPARAM.) 00038 *> 00039 *> THE VALUES OF GAMSQ AND RGAMSQ SET IN THE DATA STATEMENT MAY BE 00040 *> INEXACT. THIS IS OK AS THEY ARE ONLY USED FOR TESTING THE SIZE 00041 *> OF DD1 AND DD2. ALL ACTUAL SCALING OF DATA IS DONE USING GAM. 00042 *> 00043 *> \endverbatim 00044 * 00045 * Arguments: 00046 * ========== 00047 * 00048 *> \param[in,out] DD1 00049 *> \verbatim 00050 *> DD1 is DOUBLE PRECISION 00051 *> \endverbatim 00052 *> 00053 *> \param[in,out] DD2 00054 *> \verbatim 00055 *> DD2 is DOUBLE PRECISION 00056 *> \endverbatim 00057 *> 00058 *> \param[in,out] DX1 00059 *> \verbatim 00060 *> DX1 is DOUBLE PRECISION 00061 *> \endverbatim 00062 *> 00063 *> \param[in] DY1 00064 *> \verbatim 00065 *> DY1 is DOUBLE PRECISION 00066 *> \endverbatim 00067 *> 00068 *> \param[in,out] DPARAM 00069 *> \verbatim 00070 *> DPARAM is DOUBLE PRECISION array, dimension 5 00071 *> DPARAM(1)=DFLAG 00072 *> DPARAM(2)=DH11 00073 *> DPARAM(3)=DH21 00074 *> DPARAM(4)=DH12 00075 *> DPARAM(5)=DH22 00076 *> \endverbatim 00077 * 00078 * Authors: 00079 * ======== 00080 * 00081 *> \author Univ. of Tennessee 00082 *> \author Univ. of California Berkeley 00083 *> \author Univ. of Colorado Denver 00084 *> \author NAG Ltd. 00085 * 00086 *> \date November 2011 00087 * 00088 *> \ingroup double_blas_level1 00089 * 00090 * ===================================================================== 00091 SUBROUTINE DROTMG(DD1,DD2,DX1,DY1,DPARAM) 00092 * 00093 * -- Reference BLAS level1 routine (version 3.4.0) -- 00094 * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- 00095 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 00096 * November 2011 00097 * 00098 * .. Scalar Arguments .. 00099 DOUBLE PRECISION DD1,DD2,DX1,DY1 00100 * .. 00101 * .. Array Arguments .. 00102 DOUBLE PRECISION DPARAM(5) 00103 * .. 00104 * 00105 * ===================================================================== 00106 * 00107 * .. Local Scalars .. 00108 DOUBLE PRECISION DFLAG,DH11,DH12,DH21,DH22,DP1,DP2,DQ1,DQ2,DTEMP, 00109 $ DU,GAM,GAMSQ,ONE,RGAMSQ,TWO,ZERO 00110 * .. 00111 * .. Intrinsic Functions .. 00112 INTRINSIC DABS 00113 * .. 00114 * .. Data statements .. 00115 * 00116 DATA ZERO,ONE,TWO/0.D0,1.D0,2.D0/ 00117 DATA GAM,GAMSQ,RGAMSQ/4096.D0,16777216.D0,5.9604645D-8/ 00118 * .. 00119 00120 IF (DD1.LT.ZERO) THEN 00121 * GO ZERO-H-D-AND-DX1.. 00122 DFLAG = -ONE 00123 DH11 = ZERO 00124 DH12 = ZERO 00125 DH21 = ZERO 00126 DH22 = ZERO 00127 * 00128 DD1 = ZERO 00129 DD2 = ZERO 00130 DX1 = ZERO 00131 ELSE 00132 * CASE-DD1-NONNEGATIVE 00133 DP2 = DD2*DY1 00134 IF (DP2.EQ.ZERO) THEN 00135 DFLAG = -TWO 00136 DPARAM(1) = DFLAG 00137 RETURN 00138 END IF 00139 * REGULAR-CASE.. 00140 DP1 = DD1*DX1 00141 DQ2 = DP2*DY1 00142 DQ1 = DP1*DX1 00143 * 00144 IF (DABS(DQ1).GT.DABS(DQ2)) THEN 00145 DH21 = -DY1/DX1 00146 DH12 = DP2/DP1 00147 * 00148 DU = ONE - DH12*DH21 00149 * 00150 IF (DU.GT.ZERO) THEN 00151 DFLAG = ZERO 00152 DD1 = DD1/DU 00153 DD2 = DD2/DU 00154 DX1 = DX1*DU 00155 END IF 00156 ELSE 00157 00158 IF (DQ2.LT.ZERO) THEN 00159 * GO ZERO-H-D-AND-DX1.. 00160 DFLAG = -ONE 00161 DH11 = ZERO 00162 DH12 = ZERO 00163 DH21 = ZERO 00164 DH22 = ZERO 00165 * 00166 DD1 = ZERO 00167 DD2 = ZERO 00168 DX1 = ZERO 00169 ELSE 00170 DFLAG = ONE 00171 DH11 = DP1/DP2 00172 DH22 = DX1/DY1 00173 DU = ONE + DH11*DH22 00174 DTEMP = DD2/DU 00175 DD2 = DD1/DU 00176 DD1 = DTEMP 00177 DX1 = DY1*DU 00178 END IF 00179 END IF 00180 00181 * PROCEDURE..SCALE-CHECK 00182 IF (DD1.NE.ZERO) THEN 00183 DO WHILE ((DD1.LE.RGAMSQ) .OR. (DD1.GE.GAMSQ)) 00184 IF (DFLAG.EQ.ZERO) THEN 00185 DH11 = ONE 00186 DH22 = ONE 00187 DFLAG = -ONE 00188 ELSE 00189 DH21 = -ONE 00190 DH12 = ONE 00191 DFLAG = -ONE 00192 END IF 00193 IF (DD1.LE.RGAMSQ) THEN 00194 DD1 = DD1*GAM**2 00195 DX1 = DX1/GAM 00196 DH11 = DH11/GAM 00197 DH12 = DH12/GAM 00198 ELSE 00199 DD1 = DD1/GAM**2 00200 DX1 = DX1*GAM 00201 DH11 = DH11*GAM 00202 DH12 = DH12*GAM 00203 END IF 00204 ENDDO 00205 END IF 00206 00207 IF (DD2.NE.ZERO) THEN 00208 DO WHILE ( (DABS(DD2).LE.RGAMSQ) .OR. (DABS(DD2).GE.GAMSQ) ) 00209 IF (DFLAG.EQ.ZERO) THEN 00210 DH11 = ONE 00211 DH22 = ONE 00212 DFLAG = -ONE 00213 ELSE 00214 DH21 = -ONE 00215 DH12 = ONE 00216 DFLAG = -ONE 00217 END IF 00218 IF (DABS(DD2).LE.RGAMSQ) THEN 00219 DD2 = DD2*GAM**2 00220 DH21 = DH21/GAM 00221 DH22 = DH22/GAM 00222 ELSE 00223 DD2 = DD2/GAM**2 00224 DH21 = DH21*GAM 00225 DH22 = DH22*GAM 00226 END IF 00227 END DO 00228 END IF 00229 00230 END IF 00231 00232 IF (DFLAG.LT.ZERO) THEN 00233 DPARAM(2) = DH11 00234 DPARAM(3) = DH21 00235 DPARAM(4) = DH12 00236 DPARAM(5) = DH22 00237 ELSE IF (DFLAG.EQ.ZERO) THEN 00238 DPARAM(3) = DH21 00239 DPARAM(4) = DH12 00240 ELSE 00241 DPARAM(2) = DH11 00242 DPARAM(5) = DH22 00243 END IF 00244 00245 DPARAM(1) = DFLAG 00246 RETURN 00247 END 00248 00249 00250 00251