![]() |
LAPACK
3.4.1
LAPACK: Linear Algebra PACKage
|
00001 *> \brief \b SROTMG 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 SROTMG(SD1,SD2,SX1,SY1,SPARAM) 00012 * 00013 * .. Scalar Arguments .. 00014 * REAL SD1,SD2,SX1,SY1 00015 * .. 00016 * .. Array Arguments .. 00017 * REAL SPARAM(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 (SQRT(SD1)*SX1,SQRT(SD2)*> SY2)**T. 00028 *> WITH SPARAM(1)=SFLAG, H HAS ONE OF THE FOLLOWING FORMS.. 00029 *> 00030 *> SFLAG=-1.E0 SFLAG=0.E0 SFLAG=1.E0 SFLAG=-2.E0 00031 *> 00032 *> (SH11 SH12) (1.E0 SH12) (SH11 1.E0) (1.E0 0.E0) 00033 *> H=( ) ( ) ( ) ( ) 00034 *> (SH21 SH22), (SH21 1.E0), (-1.E0 SH22), (0.E0 1.E0). 00035 *> LOCATIONS 2-4 OF SPARAM CONTAIN SH11,SH21,SH12, AND SH22 00036 *> RESPECTIVELY. (VALUES OF 1.E0, -1.E0, OR 0.E0 IMPLIED BY THE 00037 *> VALUE OF SPARAM(1) ARE NOT STORED IN SPARAM.) 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 SD1 AND SD2. ALL ACTUAL SCALING OF DATA IS DONE USING GAM. 00042 *> 00043 *> \endverbatim 00044 * 00045 * Arguments: 00046 * ========== 00047 * 00048 *> \param[in,out] SD1 00049 *> \verbatim 00050 *> SD1 is REAL 00051 *> \endverbatim 00052 *> 00053 *> \param[in,out] SD2 00054 *> \verbatim 00055 *> SD2 is REAL 00056 *> \endverbatim 00057 *> 00058 *> \param[in,out] SX1 00059 *> \verbatim 00060 *> SX1 is REAL 00061 *> \endverbatim 00062 *> 00063 *> \param[in] SY1 00064 *> \verbatim 00065 *> SY1 is REAL 00066 *> \endverbatim 00067 *> 00068 *> \param[in,out] SPARAM 00069 *> \verbatim 00070 *> SPARAM is REAL array, dimension 5 00071 *> SPARAM(1)=SFLAG 00072 *> SPARAM(2)=SH11 00073 *> SPARAM(3)=SH21 00074 *> SPARAM(4)=SH12 00075 *> SPARAM(5)=SH22 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 single_blas_level1 00089 * 00090 * ===================================================================== 00091 SUBROUTINE SROTMG(SD1,SD2,SX1,SY1,SPARAM) 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 REAL SD1,SD2,SX1,SY1 00100 * .. 00101 * .. Array Arguments .. 00102 REAL SPARAM(5) 00103 * .. 00104 * 00105 * ===================================================================== 00106 * 00107 * .. Local Scalars .. 00108 REAL GAM,GAMSQ,ONE,RGAMSQ,SFLAG,SH11,SH12,SH21,SH22,SP1,SP2,SQ1, 00109 $ SQ2,STEMP,SU,TWO,ZERO 00110 * .. 00111 * .. Intrinsic Functions .. 00112 INTRINSIC ABS 00113 * .. 00114 * .. Data statements .. 00115 * 00116 DATA ZERO,ONE,TWO/0.E0,1.E0,2.E0/ 00117 DATA GAM,GAMSQ,RGAMSQ/4096.E0,1.67772E7,5.96046E-8/ 00118 * .. 00119 00120 IF (SD1.LT.ZERO) THEN 00121 * GO ZERO-H-D-AND-SX1.. 00122 SFLAG = -ONE 00123 SH11 = ZERO 00124 SH12 = ZERO 00125 SH21 = ZERO 00126 SH22 = ZERO 00127 * 00128 SD1 = ZERO 00129 SD2 = ZERO 00130 SX1 = ZERO 00131 ELSE 00132 * CASE-SD1-NONNEGATIVE 00133 SP2 = SD2*SY1 00134 IF (SP2.EQ.ZERO) THEN 00135 SFLAG = -TWO 00136 SPARAM(1) = SFLAG 00137 RETURN 00138 END IF 00139 * REGULAR-CASE.. 00140 SP1 = SD1*SX1 00141 SQ2 = SP2*SY1 00142 SQ1 = SP1*SX1 00143 * 00144 IF (ABS(SQ1).GT.ABS(SQ2)) THEN 00145 SH21 = -SY1/SX1 00146 SH12 = SP2/SP1 00147 * 00148 SU = ONE - SH12*SH21 00149 * 00150 IF (SU.GT.ZERO) THEN 00151 SFLAG = ZERO 00152 SD1 = SD1/SU 00153 SD2 = SD2/SU 00154 SX1 = SX1*SU 00155 END IF 00156 ELSE 00157 00158 IF (SQ2.LT.ZERO) THEN 00159 * GO ZERO-H-D-AND-SX1.. 00160 SFLAG = -ONE 00161 SH11 = ZERO 00162 SH12 = ZERO 00163 SH21 = ZERO 00164 SH22 = ZERO 00165 * 00166 SD1 = ZERO 00167 SD2 = ZERO 00168 SX1 = ZERO 00169 ELSE 00170 SFLAG = ONE 00171 SH11 = SP1/SP2 00172 SH22 = SX1/SY1 00173 SU = ONE + SH11*SH22 00174 STEMP = SD2/SU 00175 SD2 = SD1/SU 00176 SD1 = STEMP 00177 SX1 = SY1*SU 00178 END IF 00179 END IF 00180 00181 * PROCESURE..SCALE-CHECK 00182 IF (SD1.NE.ZERO) THEN 00183 DO WHILE ((SD1.LE.RGAMSQ) .OR. (SD1.GE.GAMSQ)) 00184 IF (SFLAG.EQ.ZERO) THEN 00185 SH11 = ONE 00186 SH22 = ONE 00187 SFLAG = -ONE 00188 ELSE 00189 SH21 = -ONE 00190 SH12 = ONE 00191 SFLAG = -ONE 00192 END IF 00193 IF (SD1.LE.RGAMSQ) THEN 00194 SD1 = SD1*GAM**2 00195 SX1 = SX1/GAM 00196 SH11 = SH11/GAM 00197 SH12 = SH12/GAM 00198 ELSE 00199 SD1 = SD1/GAM**2 00200 SX1 = SX1*GAM 00201 SH11 = SH11*GAM 00202 SH12 = SH12*GAM 00203 END IF 00204 ENDDO 00205 END IF 00206 00207 IF (SD2.NE.ZERO) THEN 00208 DO WHILE ( (ABS(SD2).LE.RGAMSQ) .OR. (ABS(SD2).GE.GAMSQ) ) 00209 IF (SFLAG.EQ.ZERO) THEN 00210 SH11 = ONE 00211 SH22 = ONE 00212 SFLAG = -ONE 00213 ELSE 00214 SH21 = -ONE 00215 SH12 = ONE 00216 SFLAG = -ONE 00217 END IF 00218 IF (ABS(SD2).LE.RGAMSQ) THEN 00219 SD2 = SD2*GAM**2 00220 SH21 = SH21/GAM 00221 SH22 = SH22/GAM 00222 ELSE 00223 SD2 = SD2/GAM**2 00224 SH21 = SH21*GAM 00225 SH22 = SH22*GAM 00226 END IF 00227 END DO 00228 END IF 00229 00230 END IF 00231 00232 IF (SFLAG.LT.ZERO) THEN 00233 SPARAM(2) = SH11 00234 SPARAM(3) = SH21 00235 SPARAM(4) = SH12 00236 SPARAM(5) = SH22 00237 ELSE IF (SFLAG.EQ.ZERO) THEN 00238 SPARAM(3) = SH21 00239 SPARAM(4) = SH12 00240 ELSE 00241 SPARAM(2) = SH11 00242 SPARAM(5) = SH22 00243 END IF 00244 00245 SPARAM(1) = SFLAG 00246 RETURN 00247 END 00248 00249 00250 00251