forked from lijiext/lammps
255 lines
6.7 KiB
FortranFixed
255 lines
6.7 KiB
FortranFixed
|
*> \brief \b DLASQ6 computes one dqd transform in ping-pong form. Used by sbdsqr and sstegr.
|
||
|
|
*
|
||
|
|
* =========== DOCUMENTATION ===========
|
||
|
|
*
|
||
|
|
* Online html documentation available at
|
||
|
|
* http://www.netlib.org/lapack/explore-html/
|
||
|
|
*
|
||
|
|
*> \htmlonly
|
||
|
|
*> Download DLASQ6 + dependencies
|
||
|
|
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlasq6.f">
|
||
|
|
*> [TGZ]</a>
|
||
|
|
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlasq6.f">
|
||
|
|
*> [ZIP]</a>
|
||
|
|
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlasq6.f">
|
||
|
|
*> [TXT]</a>
|
||
|
|
*> \endhtmlonly
|
||
|
|
*
|
||
|
|
* Definition:
|
||
|
|
* ===========
|
||
|
|
*
|
||
|
|
* SUBROUTINE DLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN,
|
||
|
|
* DNM1, DNM2 )
|
||
|
|
*
|
||
|
|
* .. Scalar Arguments ..
|
||
|
|
* INTEGER I0, N0, PP
|
||
|
|
* DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DNM1, DNM2
|
||
|
|
* ..
|
||
|
|
* .. Array Arguments ..
|
||
|
|
* DOUBLE PRECISION Z( * )
|
||
|
|
* ..
|
||
|
|
*
|
||
|
|
*
|
||
|
|
*> \par Purpose:
|
||
|
|
* =============
|
||
|
|
*>
|
||
|
|
*> \verbatim
|
||
|
|
*>
|
||
|
|
*> DLASQ6 computes one dqd (shift equal to zero) transform in
|
||
|
|
*> ping-pong form, with protection against underflow and overflow.
|
||
|
|
*> \endverbatim
|
||
|
|
*
|
||
|
|
* Arguments:
|
||
|
|
* ==========
|
||
|
|
*
|
||
|
|
*> \param[in] I0
|
||
|
|
*> \verbatim
|
||
|
|
*> I0 is INTEGER
|
||
|
|
*> First index.
|
||
|
|
*> \endverbatim
|
||
|
|
*>
|
||
|
|
*> \param[in] N0
|
||
|
|
*> \verbatim
|
||
|
|
*> N0 is INTEGER
|
||
|
|
*> Last index.
|
||
|
|
*> \endverbatim
|
||
|
|
*>
|
||
|
|
*> \param[in] Z
|
||
|
|
*> \verbatim
|
||
|
|
*> Z is DOUBLE PRECISION array, dimension ( 4*N )
|
||
|
|
*> Z holds the qd array. EMIN is stored in Z(4*N0) to avoid
|
||
|
|
*> an extra argument.
|
||
|
|
*> \endverbatim
|
||
|
|
*>
|
||
|
|
*> \param[in] PP
|
||
|
|
*> \verbatim
|
||
|
|
*> PP is INTEGER
|
||
|
|
*> PP=0 for ping, PP=1 for pong.
|
||
|
|
*> \endverbatim
|
||
|
|
*>
|
||
|
|
*> \param[out] DMIN
|
||
|
|
*> \verbatim
|
||
|
|
*> DMIN is DOUBLE PRECISION
|
||
|
|
*> Minimum value of d.
|
||
|
|
*> \endverbatim
|
||
|
|
*>
|
||
|
|
*> \param[out] DMIN1
|
||
|
|
*> \verbatim
|
||
|
|
*> DMIN1 is DOUBLE PRECISION
|
||
|
|
*> Minimum value of d, excluding D( N0 ).
|
||
|
|
*> \endverbatim
|
||
|
|
*>
|
||
|
|
*> \param[out] DMIN2
|
||
|
|
*> \verbatim
|
||
|
|
*> DMIN2 is DOUBLE PRECISION
|
||
|
|
*> Minimum value of d, excluding D( N0 ) and D( N0-1 ).
|
||
|
|
*> \endverbatim
|
||
|
|
*>
|
||
|
|
*> \param[out] DN
|
||
|
|
*> \verbatim
|
||
|
|
*> DN is DOUBLE PRECISION
|
||
|
|
*> d(N0), the last value of d.
|
||
|
|
*> \endverbatim
|
||
|
|
*>
|
||
|
|
*> \param[out] DNM1
|
||
|
|
*> \verbatim
|
||
|
|
*> DNM1 is DOUBLE PRECISION
|
||
|
|
*> d(N0-1).
|
||
|
|
*> \endverbatim
|
||
|
|
*>
|
||
|
|
*> \param[out] DNM2
|
||
|
|
*> \verbatim
|
||
|
|
*> DNM2 is DOUBLE PRECISION
|
||
|
|
*> d(N0-2).
|
||
|
|
*> \endverbatim
|
||
|
|
*
|
||
|
|
* Authors:
|
||
|
|
* ========
|
||
|
|
*
|
||
|
|
*> \author Univ. of Tennessee
|
||
|
|
*> \author Univ. of California Berkeley
|
||
|
|
*> \author Univ. of Colorado Denver
|
||
|
|
*> \author NAG Ltd.
|
||
|
|
*
|
||
|
|
*> \date September 2012
|
||
|
|
*
|
||
|
|
*> \ingroup auxOTHERcomputational
|
||
|
|
*
|
||
|
|
* =====================================================================
|
||
|
|
SUBROUTINE DLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN,
|
||
|
|
$ DNM1, DNM2 )
|
||
|
|
*
|
||
|
|
* -- LAPACK computational routine (version 3.4.2) --
|
||
|
|
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||
|
|
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||
|
|
* September 2012
|
||
|
|
*
|
||
|
|
* .. Scalar Arguments ..
|
||
|
|
INTEGER I0, N0, PP
|
||
|
|
DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DNM1, DNM2
|
||
|
|
* ..
|
||
|
|
* .. Array Arguments ..
|
||
|
|
DOUBLE PRECISION Z( * )
|
||
|
|
* ..
|
||
|
|
*
|
||
|
|
* =====================================================================
|
||
|
|
*
|
||
|
|
* .. Parameter ..
|
||
|
|
DOUBLE PRECISION ZERO
|
||
|
|
PARAMETER ( ZERO = 0.0D0 )
|
||
|
|
* ..
|
||
|
|
* .. Local Scalars ..
|
||
|
|
INTEGER J4, J4P2
|
||
|
|
DOUBLE PRECISION D, EMIN, SAFMIN, TEMP
|
||
|
|
* ..
|
||
|
|
* .. External Function ..
|
||
|
|
DOUBLE PRECISION DLAMCH
|
||
|
|
EXTERNAL DLAMCH
|
||
|
|
* ..
|
||
|
|
* .. Intrinsic Functions ..
|
||
|
|
INTRINSIC MIN
|
||
|
|
* ..
|
||
|
|
* .. Executable Statements ..
|
||
|
|
*
|
||
|
|
IF( ( N0-I0-1 ).LE.0 )
|
||
|
|
$ RETURN
|
||
|
|
*
|
||
|
|
SAFMIN = DLAMCH( 'Safe minimum' )
|
||
|
|
J4 = 4*I0 + PP - 3
|
||
|
|
EMIN = Z( J4+4 )
|
||
|
|
D = Z( J4 )
|
||
|
|
DMIN = D
|
||
|
|
*
|
||
|
|
IF( PP.EQ.0 ) THEN
|
||
|
|
DO 10 J4 = 4*I0, 4*( N0-3 ), 4
|
||
|
|
Z( J4-2 ) = D + Z( J4-1 )
|
||
|
|
IF( Z( J4-2 ).EQ.ZERO ) THEN
|
||
|
|
Z( J4 ) = ZERO
|
||
|
|
D = Z( J4+1 )
|
||
|
|
DMIN = D
|
||
|
|
EMIN = ZERO
|
||
|
|
ELSE IF( SAFMIN*Z( J4+1 ).LT.Z( J4-2 ) .AND.
|
||
|
|
$ SAFMIN*Z( J4-2 ).LT.Z( J4+1 ) ) THEN
|
||
|
|
TEMP = Z( J4+1 ) / Z( J4-2 )
|
||
|
|
Z( J4 ) = Z( J4-1 )*TEMP
|
||
|
|
D = D*TEMP
|
||
|
|
ELSE
|
||
|
|
Z( J4 ) = Z( J4+1 )*( Z( J4-1 ) / Z( J4-2 ) )
|
||
|
|
D = Z( J4+1 )*( D / Z( J4-2 ) )
|
||
|
|
END IF
|
||
|
|
DMIN = MIN( DMIN, D )
|
||
|
|
EMIN = MIN( EMIN, Z( J4 ) )
|
||
|
|
10 CONTINUE
|
||
|
|
ELSE
|
||
|
|
DO 20 J4 = 4*I0, 4*( N0-3 ), 4
|
||
|
|
Z( J4-3 ) = D + Z( J4 )
|
||
|
|
IF( Z( J4-3 ).EQ.ZERO ) THEN
|
||
|
|
Z( J4-1 ) = ZERO
|
||
|
|
D = Z( J4+2 )
|
||
|
|
DMIN = D
|
||
|
|
EMIN = ZERO
|
||
|
|
ELSE IF( SAFMIN*Z( J4+2 ).LT.Z( J4-3 ) .AND.
|
||
|
|
$ SAFMIN*Z( J4-3 ).LT.Z( J4+2 ) ) THEN
|
||
|
|
TEMP = Z( J4+2 ) / Z( J4-3 )
|
||
|
|
Z( J4-1 ) = Z( J4 )*TEMP
|
||
|
|
D = D*TEMP
|
||
|
|
ELSE
|
||
|
|
Z( J4-1 ) = Z( J4+2 )*( Z( J4 ) / Z( J4-3 ) )
|
||
|
|
D = Z( J4+2 )*( D / Z( J4-3 ) )
|
||
|
|
END IF
|
||
|
|
DMIN = MIN( DMIN, D )
|
||
|
|
EMIN = MIN( EMIN, Z( J4-1 ) )
|
||
|
|
20 CONTINUE
|
||
|
|
END IF
|
||
|
|
*
|
||
|
|
* Unroll last two steps.
|
||
|
|
*
|
||
|
|
DNM2 = D
|
||
|
|
DMIN2 = DMIN
|
||
|
|
J4 = 4*( N0-2 ) - PP
|
||
|
|
J4P2 = J4 + 2*PP - 1
|
||
|
|
Z( J4-2 ) = DNM2 + Z( J4P2 )
|
||
|
|
IF( Z( J4-2 ).EQ.ZERO ) THEN
|
||
|
|
Z( J4 ) = ZERO
|
||
|
|
DNM1 = Z( J4P2+2 )
|
||
|
|
DMIN = DNM1
|
||
|
|
EMIN = ZERO
|
||
|
|
ELSE IF( SAFMIN*Z( J4P2+2 ).LT.Z( J4-2 ) .AND.
|
||
|
|
$ SAFMIN*Z( J4-2 ).LT.Z( J4P2+2 ) ) THEN
|
||
|
|
TEMP = Z( J4P2+2 ) / Z( J4-2 )
|
||
|
|
Z( J4 ) = Z( J4P2 )*TEMP
|
||
|
|
DNM1 = DNM2*TEMP
|
||
|
|
ELSE
|
||
|
|
Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) )
|
||
|
|
DNM1 = Z( J4P2+2 )*( DNM2 / Z( J4-2 ) )
|
||
|
|
END IF
|
||
|
|
DMIN = MIN( DMIN, DNM1 )
|
||
|
|
*
|
||
|
|
DMIN1 = DMIN
|
||
|
|
J4 = J4 + 4
|
||
|
|
J4P2 = J4 + 2*PP - 1
|
||
|
|
Z( J4-2 ) = DNM1 + Z( J4P2 )
|
||
|
|
IF( Z( J4-2 ).EQ.ZERO ) THEN
|
||
|
|
Z( J4 ) = ZERO
|
||
|
|
DN = Z( J4P2+2 )
|
||
|
|
DMIN = DN
|
||
|
|
EMIN = ZERO
|
||
|
|
ELSE IF( SAFMIN*Z( J4P2+2 ).LT.Z( J4-2 ) .AND.
|
||
|
|
$ SAFMIN*Z( J4-2 ).LT.Z( J4P2+2 ) ) THEN
|
||
|
|
TEMP = Z( J4P2+2 ) / Z( J4-2 )
|
||
|
|
Z( J4 ) = Z( J4P2 )*TEMP
|
||
|
|
DN = DNM1*TEMP
|
||
|
|
ELSE
|
||
|
|
Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) )
|
||
|
|
DN = Z( J4P2+2 )*( DNM1 / Z( J4-2 ) )
|
||
|
|
END IF
|
||
|
|
DMIN = MIN( DMIN, DN )
|
||
|
|
*
|
||
|
|
Z( J4+2 ) = DN
|
||
|
|
Z( 4*N0-PP ) = EMIN
|
||
|
|
RETURN
|
||
|
|
*
|
||
|
|
* End of DLASQ6
|
||
|
|
*
|
||
|
|
END
|