![]() ![]() | ![]() |
Mise à jour de Lapack vers la version 3.3.0.
1: SUBROUTINE DLARTGP( F, G, CS, SN, R ) 2: * 3: * Originally DLARTG 4: * -- LAPACK auxiliary routine (version 3.2) -- 5: * -- LAPACK is a software package provided by Univ. of Tennessee, -- 6: * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 7: * November 2006 8: * 9: * Adapted to DLARTGP 10: * July 2010 11: * 12: * .. Scalar Arguments .. 13: DOUBLE PRECISION CS, F, G, R, SN 14: * .. 15: * 16: * Purpose 17: * ======= 18: * 19: * DLARTGP generates a plane rotation so that 20: * 21: * [ CS SN ] . [ F ] = [ R ] where CS**2 + SN**2 = 1. 22: * [ -SN CS ] [ G ] [ 0 ] 23: * 24: * This is a slower, more accurate version of the Level 1 BLAS routine DROTG, 25: * with the following other differences: 26: * F and G are unchanged on return. 27: * If G=0, then CS=(+/-)1 and SN=0. 28: * If F=0 and (G .ne. 0), then CS=0 and SN=(+/-)1. 29: * 30: * The sign is chosen so that R >= 0. 31: * 32: * Arguments 33: * ========= 34: * 35: * F (input) DOUBLE PRECISION 36: * The first component of vector to be rotated. 37: * 38: * G (input) DOUBLE PRECISION 39: * The second component of vector to be rotated. 40: * 41: * CS (output) DOUBLE PRECISION 42: * The cosine of the rotation. 43: * 44: * SN (output) DOUBLE PRECISION 45: * The sine of the rotation. 46: * 47: * R (output) DOUBLE PRECISION 48: * The nonzero component of the rotated vector. 49: * 50: * This version has a few statements commented out for thread safety 51: * (machine parameters are computed on each entry). 10 feb 03, SJH. 52: * 53: * ===================================================================== 54: * 55: * .. Parameters .. 56: DOUBLE PRECISION ZERO 57: PARAMETER ( ZERO = 0.0D0 ) 58: DOUBLE PRECISION ONE 59: PARAMETER ( ONE = 1.0D0 ) 60: DOUBLE PRECISION TWO 61: PARAMETER ( TWO = 2.0D0 ) 62: * .. 63: * .. Local Scalars .. 64: * LOGICAL FIRST 65: INTEGER COUNT, I 66: DOUBLE PRECISION EPS, F1, G1, SAFMIN, SAFMN2, SAFMX2, SCALE 67: * .. 68: * .. External Functions .. 69: DOUBLE PRECISION DLAMCH 70: EXTERNAL DLAMCH 71: * .. 72: * .. Intrinsic Functions .. 73: INTRINSIC ABS, INT, LOG, MAX, SIGN, SQRT 74: * .. 75: * .. Save statement .. 76: * SAVE FIRST, SAFMX2, SAFMIN, SAFMN2 77: * .. 78: * .. Data statements .. 79: * DATA FIRST / .TRUE. / 80: * .. 81: * .. Executable Statements .. 82: * 83: * IF( FIRST ) THEN 84: SAFMIN = DLAMCH( 'S' ) 85: EPS = DLAMCH( 'E' ) 86: SAFMN2 = DLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) / 87: $ LOG( DLAMCH( 'B' ) ) / TWO ) 88: SAFMX2 = ONE / SAFMN2 89: * FIRST = .FALSE. 90: * END IF 91: IF( G.EQ.ZERO ) THEN 92: CS = SIGN( ONE, F ) 93: SN = ZERO 94: R = ABS( F ) 95: ELSE IF( F.EQ.ZERO ) THEN 96: CS = ZERO 97: SN = SIGN( ONE, G ) 98: R = ABS( G ) 99: ELSE 100: F1 = F 101: G1 = G 102: SCALE = MAX( ABS( F1 ), ABS( G1 ) ) 103: IF( SCALE.GE.SAFMX2 ) THEN 104: COUNT = 0 105: 10 CONTINUE 106: COUNT = COUNT + 1 107: F1 = F1*SAFMN2 108: G1 = G1*SAFMN2 109: SCALE = MAX( ABS( F1 ), ABS( G1 ) ) 110: IF( SCALE.GE.SAFMX2 ) 111: $ GO TO 10 112: R = SQRT( F1**2+G1**2 ) 113: CS = F1 / R 114: SN = G1 / R 115: DO 20 I = 1, COUNT 116: R = R*SAFMX2 117: 20 CONTINUE 118: ELSE IF( SCALE.LE.SAFMN2 ) THEN 119: COUNT = 0 120: 30 CONTINUE 121: COUNT = COUNT + 1 122: F1 = F1*SAFMX2 123: G1 = G1*SAFMX2 124: SCALE = MAX( ABS( F1 ), ABS( G1 ) ) 125: IF( SCALE.LE.SAFMN2 ) 126: $ GO TO 30 127: R = SQRT( F1**2+G1**2 ) 128: CS = F1 / R 129: SN = G1 / R 130: DO 40 I = 1, COUNT 131: R = R*SAFMN2 132: 40 CONTINUE 133: ELSE 134: R = SQRT( F1**2+G1**2 ) 135: CS = F1 / R 136: SN = G1 / R 137: END IF 138: IF( R.LT.ZERO ) THEN 139: CS = -CS 140: SN = -SN 141: R = -R 142: END IF 143: END IF 144: RETURN 145: * 146: * End of DLARTGP 147: * 148: END