rpl/lapack/lapack/dlansp.f - diff

Return to dlansp.f CVS log

Up to [local] / rpl / lapack / lapack

Diff for /rpl/lapack/lapack/dlansp.f between versions 1.11 and 1.18

version 1.11, 2012/12/14 12:30:23	version 1.18, 2020/05/21 21:45:59
Line 2	Line 2
*	*
* =========== DOCUMENTATION ===========	* =========== DOCUMENTATION ===========
*	*
* Online html documentation available at	* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/	* http://www.netlib.org/lapack/explore-html/
*	*
*> \htmlonly	*> \htmlonly
*> Download DLANSP + dependencies	*> Download DLANSP + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlansp.f">	*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlansp.f">
*> [TGZ]</a>	*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlansp.f">	*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlansp.f">
*> [ZIP]</a>	*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlansp.f">	*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlansp.f">
*> [TXT]</a>	*> [TXT]</a>
*> \endhtmlonly	*> \endhtmlonly
*	*
* Definition:	* Definition:
* ===========	* ===========
*	*
* DOUBLE PRECISION FUNCTION DLANSP( NORM, UPLO, N, AP, WORK )	* DOUBLE PRECISION FUNCTION DLANSP( NORM, UPLO, N, AP, WORK )
*	*
* .. Scalar Arguments ..	* .. Scalar Arguments ..
* CHARACTER NORM, UPLO	* CHARACTER NORM, UPLO
* INTEGER N	* INTEGER N
Line 27	Line 27
* .. Array Arguments ..	* .. Array Arguments ..
* DOUBLE PRECISION AP( * ), WORK( * )	* DOUBLE PRECISION AP( * ), WORK( * )
* ..	* ..
*	*
*	*
*> \par Purpose:	*> \par Purpose:
* =============	* =============
Line 102	Line 102
* Authors:	* Authors:
* ========	* ========
*	*
*> \author Univ. of Tennessee	*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley	*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver	*> \author Univ. of Colorado Denver
*> \author NAG Ltd.	*> \author NAG Ltd.
*	*
*> \date September 2012	*> \date December 2016
*	*
*> \ingroup doubleOTHERauxiliary	*> \ingroup doubleOTHERauxiliary
*	*
* =====================================================================	* =====================================================================
DOUBLE PRECISION FUNCTION DLANSP( NORM, UPLO, N, AP, WORK )	DOUBLE PRECISION FUNCTION DLANSP( NORM, UPLO, N, AP, WORK )
*	*
* -- LAPACK auxiliary routine (version 3.4.2) --	* -- LAPACK auxiliary routine (version 3.7.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --	* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--	* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* September 2012	* December 2016
*	*
	IMPLICIT NONE
* .. Scalar Arguments ..	* .. Scalar Arguments ..
CHARACTER NORM, UPLO	CHARACTER NORM, UPLO
INTEGER N	INTEGER N
Line 135	Line 136
* ..	* ..
* .. Local Scalars ..	* .. Local Scalars ..
INTEGER I, J, K	INTEGER I, J, K
DOUBLE PRECISION ABSA, SCALE, SUM, VALUE	DOUBLE PRECISION ABSA, SUM, VALUE
* ..	* ..
* .. External Subroutines ..	* .. Local Arrays ..
EXTERNAL DLASSQ	DOUBLE PRECISION SSQ( 2 ), COLSSQ( 2 )
* ..	* ..
* .. External Functions ..	* .. External Functions ..
LOGICAL LSAME, DISNAN	LOGICAL LSAME, DISNAN
EXTERNAL LSAME, DISNAN	EXTERNAL LSAME, DISNAN
* ..	* ..
	* .. External Subroutines ..
	EXTERNAL DLASSQ, DCOMBSSQ
	* ..
* .. Intrinsic Functions ..	* .. Intrinsic Functions ..
INTRINSIC ABS, SQRT	INTRINSIC ABS, SQRT
* ..	* ..
Line 217	Line 221
ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN	ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
*	*
* Find normF(A).	* Find normF(A).
	* SSQ(1) is scale
	* SSQ(2) is sum-of-squares
	* For better accuracy, sum each column separately.
	*
	SSQ( 1 ) = ZERO
	SSQ( 2 ) = ONE
	*
	* Sum off-diagonals
*	*
SCALE = ZERO
SUM = ONE
K = 2	K = 2
IF( LSAME( UPLO, 'U' ) ) THEN	IF( LSAME( UPLO, 'U' ) ) THEN
DO 110 J = 2, N	DO 110 J = 2, N
CALL DLASSQ( J-1, AP( K ), 1, SCALE, SUM )	COLSSQ( 1 ) = ZERO
	COLSSQ( 2 ) = ONE
	CALL DLASSQ( J-1, AP( K ), 1, COLSSQ( 1 ), COLSSQ( 2 ) )
	CALL DCOMBSSQ( SSQ, COLSSQ )
K = K + J	K = K + J
110 CONTINUE	110 CONTINUE
ELSE	ELSE
DO 120 J = 1, N - 1	DO 120 J = 1, N - 1
CALL DLASSQ( N-J, AP( K ), 1, SCALE, SUM )	COLSSQ( 1 ) = ZERO
	COLSSQ( 2 ) = ONE
	CALL DLASSQ( N-J, AP( K ), 1, COLSSQ( 1 ), COLSSQ( 2 ) )
	CALL DCOMBSSQ( SSQ, COLSSQ )
K = K + N - J + 1	K = K + N - J + 1
120 CONTINUE	120 CONTINUE
END IF	END IF
SUM = 2*SUM	SSQ( 2 ) = 2*SSQ( 2 )
	*
	* Sum diagonal
	*
K = 1	K = 1
	COLSSQ( 1 ) = ZERO
	COLSSQ( 2 ) = ONE
DO 130 I = 1, N	DO 130 I = 1, N
IF( AP( K ).NE.ZERO ) THEN	IF( AP( K ).NE.ZERO ) THEN
ABSA = ABS( AP( K ) )	ABSA = ABS( AP( K ) )
IF( SCALE.LT.ABSA ) THEN	IF( COLSSQ( 1 ).LT.ABSA ) THEN
SUM = ONE + SUM( SCALE / ABSA )*2	COLSSQ( 2 ) = ONE + COLSSQ(2)( COLSSQ(1) / ABSA )*2
SCALE = ABSA	COLSSQ( 1 ) = ABSA
ELSE	ELSE
SUM = SUM + ( ABSA / SCALE )**2	COLSSQ( 2 ) = COLSSQ( 2 ) + ( ABSA / COLSSQ( 1 ) )**2
END IF	END IF
END IF	END IF
IF( LSAME( UPLO, 'U' ) ) THEN	IF( LSAME( UPLO, 'U' ) ) THEN
Line 250	Line 271
K = K + N - I + 1	K = K + N - I + 1
END IF	END IF
130 CONTINUE	130 CONTINUE
VALUE = SCALE*SQRT( SUM )	CALL DCOMBSSQ( SSQ, COLSSQ )
	VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) )
END IF	END IF
*	*
DLANSP = VALUE	DLANSP = VALUE

CVSweb interface <joel.bertrand@systella.fr>

Removed from v.1.11
changed lines
	Added in v.1.18