#include "ESMF_LapackBlas.inc" !> \brief \b DLASQ5 ! ! =========== DOCUMENTATION =========== ! ! Online html documentation available at ! http://www.netlib.org/lapack/explore-html/ ! !> \htmlonly !> Download DLASQ5 + dependencies !> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlasq5.f"> !> [TGZ]</a> !> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlasq5.f"> !> [ZIP]</a> !> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlasq5.f"> !> [TXT]</a> !> \endhtmlonly ! ! Definition: ! =========== ! ! SUBROUTINE DLASQ5( I0, N0, Z, PP, TAU, DMIN, DMIN1, DMIN2, DN, ! DNM1, DNM2, IEEE ) ! ! .. Scalar Arguments .. ! LOGICAL IEEE ! INTEGER I0, N0, PP ! DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DNM1, DNM2, TAU ! .. ! .. Array Arguments .. ! DOUBLE PRECISION Z( * ) ! .. ! ! !> \par Purpose: ! ============= !> !> \verbatim !> !> DLASQ5 computes one dqds transform in ping-pong form, one !> version for IEEE machines another for non IEEE machines. !> \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[in] TAU !> \verbatim !> TAU is DOUBLE PRECISION !> This is the shift. !> \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 !> !> \param[in] IEEE !> \verbatim !> IEEE is LOGICAL !> Flag for IEEE or non IEEE arithmetic. !> \endverbatim ! ! Authors: ! ======== ! !> \author Univ. of Tennessee !> \author Univ. of California Berkeley !> \author Univ. of Colorado Denver !> \author NAG Ltd. ! !> \date November 2011 ! !> \ingroup auxOTHERcomputational ! ! ===================================================================== SUBROUTINE DLASQ5( I0, N0, Z, PP, TAU, DMIN, DMIN1, DMIN2, DN, & & DNM1, DNM2, IEEE ) ! ! -- LAPACK computational routine (version 3.4.0) -- ! -- LAPACK is a software package provided by Univ. of Tennessee, -- ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- ! November 2011 ! ! .. Scalar Arguments .. LOGICAL IEEE INTEGER I0, N0, PP DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DNM1, DNM2, TAU ! .. ! .. Array Arguments .. DOUBLE PRECISION Z( * ) ! .. ! ! ===================================================================== ! ! .. Parameter .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) ! .. ! .. Local Scalars .. INTEGER J4, J4P2 DOUBLE PRECISION D, EMIN, TEMP ! .. ! .. Intrinsic Functions .. INTRINSIC MIN ! .. ! .. Executable Statements .. ! IF( ( N0-I0-1 ).LE.0 ) & & RETURN ! J4 = 4*I0 + PP - 3 EMIN = Z( J4+4 ) D = Z( J4 ) - TAU DMIN = D DMIN1 = -Z( J4 ) ! IF( IEEE ) THEN ! ! Code for IEEE arithmetic. ! IF( PP.EQ.0 ) THEN DO 10 J4 = 4*I0, 4*( N0-3 ), 4 Z( J4-2 ) = D + Z( J4-1 ) TEMP = Z( J4+1 ) / Z( J4-2 ) D = D*TEMP - TAU DMIN = MIN( DMIN, D ) Z( J4 ) = Z( J4-1 )*TEMP EMIN = MIN( Z( J4 ), EMIN ) 10 CONTINUE ELSE DO 20 J4 = 4*I0, 4*( N0-3 ), 4 Z( J4-3 ) = D + Z( J4 ) TEMP = Z( J4+2 ) / Z( J4-3 ) D = D*TEMP - TAU DMIN = MIN( DMIN, D ) Z( J4-1 ) = Z( J4 )*TEMP EMIN = MIN( Z( J4-1 ), EMIN ) 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 ) Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) ) DNM1 = Z( J4P2+2 )*( DNM2 / Z( J4-2 ) ) - TAU DMIN = MIN( DMIN, DNM1 ) ! DMIN1 = DMIN J4 = J4 + 4 J4P2 = J4 + 2*PP - 1 Z( J4-2 ) = DNM1 + Z( J4P2 ) Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) ) DN = Z( J4P2+2 )*( DNM1 / Z( J4-2 ) ) - TAU DMIN = MIN( DMIN, DN ) ! ELSE ! ! Code for non IEEE arithmetic. ! IF( PP.EQ.0 ) THEN DO 30 J4 = 4*I0, 4*( N0-3 ), 4 Z( J4-2 ) = D + Z( J4-1 ) IF( D.LT.ZERO ) THEN RETURN ELSE Z( J4 ) = Z( J4+1 )*( Z( J4-1 ) / Z( J4-2 ) ) D = Z( J4+1 )*( D / Z( J4-2 ) ) - TAU END IF DMIN = MIN( DMIN, D ) EMIN = MIN( EMIN, Z( J4 ) ) 30 CONTINUE ELSE DO 40 J4 = 4*I0, 4*( N0-3 ), 4 Z( J4-3 ) = D + Z( J4 ) IF( D.LT.ZERO ) THEN RETURN ELSE Z( J4-1 ) = Z( J4+2 )*( Z( J4 ) / Z( J4-3 ) ) D = Z( J4+2 )*( D / Z( J4-3 ) ) - TAU END IF DMIN = MIN( DMIN, D ) EMIN = MIN( EMIN, Z( J4-1 ) ) 40 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( DNM2.LT.ZERO ) THEN RETURN ELSE Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) ) DNM1 = Z( J4P2+2 )*( DNM2 / Z( J4-2 ) ) - TAU END IF DMIN = MIN( DMIN, DNM1 ) ! DMIN1 = DMIN J4 = J4 + 4 J4P2 = J4 + 2*PP - 1 Z( J4-2 ) = DNM1 + Z( J4P2 ) IF( DNM1.LT.ZERO ) THEN RETURN ELSE Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) ) DN = Z( J4P2+2 )*( DNM1 / Z( J4-2 ) ) - TAU END IF DMIN = MIN( DMIN, DN ) ! END IF ! Z( J4+2 ) = DN Z( 4*N0-PP ) = EMIN RETURN ! ! End of DLASQ5 ! END