#include "ESMF_LapackBlas.inc" !> \brief \b DLASQ6 ! ! =========== 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 November 2011 ! !> \ingroup auxOTHERcomputational ! ! ===================================================================== SUBROUTINE DLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN, & & DNM1, DNM2 ) ! ! -- 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 .. 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