|
LAPACK 3.3.0
|
|
LAPACK 3.3.0
|
00001 SUBROUTINE SLARTG( F, G, CS, SN, R ) 00002 * 00003 * -- LAPACK auxiliary routine (version 3.2) -- 00004 * -- LAPACK is a software package provided by Univ. of Tennessee, -- 00005 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 00006 * November 2006 00007 * 00008 * .. Scalar Arguments .. 00009 REAL CS, F, G, R, SN 00010 * .. 00011 * 00012 * Purpose 00013 * ======= 00014 * 00015 * SLARTG generate a plane rotation so that 00016 * 00017 * [ CS SN ] . [ F ] = [ R ] where CS**2 + SN**2 = 1. 00018 * [ -SN CS ] [ G ] [ 0 ] 00019 * 00020 * This is a slower, more accurate version of the BLAS1 routine SROTG, 00021 * with the following other differences: 00022 * F and G are unchanged on return. 00023 * If G=0, then CS=1 and SN=0. 00024 * If F=0 and (G .ne. 0), then CS=0 and SN=1 without doing any 00025 * floating point operations (saves work in SBDSQR when 00026 * there are zeros on the diagonal). 00027 * 00028 * If F exceeds G in magnitude, CS will be positive. 00029 * 00030 * Arguments 00031 * ========= 00032 * 00033 * F (input) REAL 00034 * The first component of vector to be rotated. 00035 * 00036 * G (input) REAL 00037 * The second component of vector to be rotated. 00038 * 00039 * CS (output) REAL 00040 * The cosine of the rotation. 00041 * 00042 * SN (output) REAL 00043 * The sine of the rotation. 00044 * 00045 * R (output) REAL 00046 * The nonzero component of the rotated vector. 00047 * 00048 * This version has a few statements commented out for thread safety 00049 * (machine parameters are computed on each entry). 10 feb 03, SJH. 00050 * 00051 * ===================================================================== 00052 * 00053 * .. Parameters .. 00054 REAL ZERO 00055 PARAMETER ( ZERO = 0.0E0 ) 00056 REAL ONE 00057 PARAMETER ( ONE = 1.0E0 ) 00058 REAL TWO 00059 PARAMETER ( TWO = 2.0E0 ) 00060 * .. 00061 * .. Local Scalars .. 00062 * LOGICAL FIRST 00063 INTEGER COUNT, I 00064 REAL EPS, F1, G1, SAFMIN, SAFMN2, SAFMX2, SCALE 00065 * .. 00066 * .. External Functions .. 00067 REAL SLAMCH 00068 EXTERNAL SLAMCH 00069 * .. 00070 * .. Intrinsic Functions .. 00071 INTRINSIC ABS, INT, LOG, MAX, SQRT 00072 * .. 00073 * .. Save statement .. 00074 * SAVE FIRST, SAFMX2, SAFMIN, SAFMN2 00075 * .. 00076 * .. Data statements .. 00077 * DATA FIRST / .TRUE. / 00078 * .. 00079 * .. Executable Statements .. 00080 * 00081 * IF( FIRST ) THEN 00082 SAFMIN = SLAMCH( 'S' ) 00083 EPS = SLAMCH( 'E' ) 00084 SAFMN2 = SLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) / 00085 $ LOG( SLAMCH( 'B' ) ) / TWO ) 00086 SAFMX2 = ONE / SAFMN2 00087 * FIRST = .FALSE. 00088 * END IF 00089 IF( G.EQ.ZERO ) THEN 00090 CS = ONE 00091 SN = ZERO 00092 R = F 00093 ELSE IF( F.EQ.ZERO ) THEN 00094 CS = ZERO 00095 SN = ONE 00096 R = G 00097 ELSE 00098 F1 = F 00099 G1 = G 00100 SCALE = MAX( ABS( F1 ), ABS( G1 ) ) 00101 IF( SCALE.GE.SAFMX2 ) THEN 00102 COUNT = 0 00103 10 CONTINUE 00104 COUNT = COUNT + 1 00105 F1 = F1*SAFMN2 00106 G1 = G1*SAFMN2 00107 SCALE = MAX( ABS( F1 ), ABS( G1 ) ) 00108 IF( SCALE.GE.SAFMX2 ) 00109 $ GO TO 10 00110 R = SQRT( F1**2+G1**2 ) 00111 CS = F1 / R 00112 SN = G1 / R 00113 DO 20 I = 1, COUNT 00114 R = R*SAFMX2 00115 20 CONTINUE 00116 ELSE IF( SCALE.LE.SAFMN2 ) THEN 00117 COUNT = 0 00118 30 CONTINUE 00119 COUNT = COUNT + 1 00120 F1 = F1*SAFMX2 00121 G1 = G1*SAFMX2 00122 SCALE = MAX( ABS( F1 ), ABS( G1 ) ) 00123 IF( SCALE.LE.SAFMN2 ) 00124 $ GO TO 30 00125 R = SQRT( F1**2+G1**2 ) 00126 CS = F1 / R 00127 SN = G1 / R 00128 DO 40 I = 1, COUNT 00129 R = R*SAFMN2 00130 40 CONTINUE 00131 ELSE 00132 R = SQRT( F1**2+G1**2 ) 00133 CS = F1 / R 00134 SN = G1 / R 00135 END IF 00136 IF( ABS( F ).GT.ABS( G ) .AND. CS.LT.ZERO ) THEN 00137 CS = -CS 00138 SN = -SN 00139 R = -R 00140 END IF 00141 END IF 00142 RETURN 00143 * 00144 * End of SLARTG 00145 * 00146 END
1.7.3 
