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