--- rpl/lapack/lapack/zlartg.f 2011/11/21 20:43:17 1.8 +++ rpl/lapack/lapack/zlartg.f 2017/06/17 10:54:22 1.16 @@ -1,30 +1,30 @@ -*> \brief \b ZLARTG +*> \brief \b ZLARTG generates a plane rotation with real cosine and complex sine. * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLARTG + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLARTG + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLARTG( F, G, CS, SN, R ) -* +* * .. Scalar Arguments .. * DOUBLE PRECISION CS * COMPLEX*16 F, G, R, SN * .. -* +* * *> \par Purpose: * ============= @@ -80,12 +80,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date December 2016 * *> \ingroup complex16OTHERauxiliary * @@ -103,10 +103,10 @@ * ===================================================================== SUBROUTINE ZLARTG( F, G, CS, SN, R ) * -* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK auxiliary routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* December 2016 * * .. Scalar Arguments .. DOUBLE PRECISION CS @@ -130,7 +130,8 @@ * .. * .. External Functions .. DOUBLE PRECISION DLAMCH, DLAPY2 - EXTERNAL DLAMCH, DLAPY2 + LOGICAL DISNAN + EXTERNAL DLAMCH, DLAPY2, DISNAN * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, INT, LOG, @@ -139,26 +140,17 @@ * .. Statement Functions .. DOUBLE PRECISION ABS1, ABSSQ * .. -* .. Save statement .. -* SAVE FIRST, SAFMX2, SAFMIN, SAFMN2 -* .. -* .. Data statements .. -* DATA FIRST / .TRUE. / -* .. * .. Statement Function definitions .. ABS1( FF ) = MAX( ABS( DBLE( FF ) ), ABS( DIMAG( FF ) ) ) ABSSQ( FF ) = DBLE( FF )**2 + DIMAG( FF )**2 * .. * .. Executable Statements .. * -* IF( FIRST ) THEN - SAFMIN = DLAMCH( 'S' ) - EPS = DLAMCH( 'E' ) - SAFMN2 = DLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) / - $ LOG( DLAMCH( 'B' ) ) / TWO ) - SAFMX2 = ONE / SAFMN2 -* FIRST = .FALSE. -* END IF + SAFMIN = DLAMCH( 'S' ) + EPS = DLAMCH( 'E' ) + SAFMN2 = DLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) / + $ LOG( DLAMCH( 'B' ) ) / TWO ) + SAFMX2 = ONE / SAFMN2 SCALE = MAX( ABS1( F ), ABS1( G ) ) FS = F GS = G @@ -172,7 +164,7 @@ IF( SCALE.GE.SAFMX2 ) $ GO TO 10 ELSE IF( SCALE.LE.SAFMN2 ) THEN - IF( G.EQ.CZERO ) THEN + IF( G.EQ.CZERO.OR.DISNAN( ABS( G ) ) ) THEN CS = ONE SN = CZERO R = F