--- rpl/lapack/blas/drotmg.f 2010/08/07 13:22:09 1.5 +++ rpl/lapack/blas/drotmg.f 2012/12/14 14:22:02 1.11 @@ -1,57 +1,112 @@ - SUBROUTINE DROTMG(DD1,DD2,DX1,DY1,DPARAM) -* .. Scalar Arguments .. - DOUBLE PRECISION DD1,DD2,DX1,DY1 -* .. -* .. Array Arguments .. - DOUBLE PRECISION DPARAM(5) -* .. +*> \brief \b DROTMG * -* Purpose -* ======= +* =========== DOCUMENTATION =========== * -* CONSTRUCT THE MODIFIED GIVENS TRANSFORMATION MATRIX H WHICH ZEROS -* THE SECOND COMPONENT OF THE 2-VECTOR (DSQRT(DD1)*DX1,DSQRT(DD2)* -* DY2)**T. -* WITH DPARAM(1)=DFLAG, H HAS ONE OF THE FOLLOWING FORMS.. +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * -* DFLAG=-1.D0 DFLAG=0.D0 DFLAG=1.D0 DFLAG=-2.D0 +* Definition: +* =========== +* +* SUBROUTINE DROTMG(DD1,DD2,DX1,DY1,DPARAM) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION DD1,DD2,DX1,DY1 +* .. +* .. Array Arguments .. +* DOUBLE PRECISION DPARAM(5) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CONSTRUCT THE MODIFIED GIVENS TRANSFORMATION MATRIX H WHICH ZEROS +*> THE SECOND COMPONENT OF THE 2-VECTOR (DSQRT(DD1)*DX1,DSQRT(DD2)*> DY2)**T. +*> WITH DPARAM(1)=DFLAG, H HAS ONE OF THE FOLLOWING FORMS.. +*> +*> DFLAG=-1.D0 DFLAG=0.D0 DFLAG=1.D0 DFLAG=-2.D0 +*> +*> (DH11 DH12) (1.D0 DH12) (DH11 1.D0) (1.D0 0.D0) +*> H=( ) ( ) ( ) ( ) +*> (DH21 DH22), (DH21 1.D0), (-1.D0 DH22), (0.D0 1.D0). +*> LOCATIONS 2-4 OF DPARAM CONTAIN DH11, DH21, DH12, AND DH22 +*> RESPECTIVELY. (VALUES OF 1.D0, -1.D0, OR 0.D0 IMPLIED BY THE +*> VALUE OF DPARAM(1) ARE NOT STORED IN DPARAM.) +*> +*> THE VALUES OF GAMSQ AND RGAMSQ SET IN THE DATA STATEMENT MAY BE +*> INEXACT. THIS IS OK AS THEY ARE ONLY USED FOR TESTING THE SIZE +*> OF DD1 AND DD2. ALL ACTUAL SCALING OF DATA IS DONE USING GAM. +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in,out] DD1 +*> \verbatim +*> DD1 is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[in,out] DD2 +*> \verbatim +*> DD2 is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[in,out] DX1 +*> \verbatim +*> DX1 is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[in] DY1 +*> \verbatim +*> DY1 is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[in,out] DPARAM +*> \verbatim +*> DPARAM is DOUBLE PRECISION array, dimension 5 +*> DPARAM(1)=DFLAG +*> DPARAM(2)=DH11 +*> DPARAM(3)=DH21 +*> DPARAM(4)=DH12 +*> DPARAM(5)=DH22 +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -* (DH11 DH12) (1.D0 DH12) (DH11 1.D0) (1.D0 0.D0) -* H=( ) ( ) ( ) ( ) -* (DH21 DH22), (DH21 1.D0), (-1.D0 DH22), (0.D0 1.D0). -* LOCATIONS 2-4 OF DPARAM CONTAIN DH11, DH21, DH12, AND DH22 -* RESPECTIVELY. (VALUES OF 1.D0, -1.D0, OR 0.D0 IMPLIED BY THE -* VALUE OF DPARAM(1) ARE NOT STORED IN DPARAM.) +*> \date November 2011 * -* THE VALUES OF GAMSQ AND RGAMSQ SET IN THE DATA STATEMENT MAY BE -* INEXACT. THIS IS OK AS THEY ARE ONLY USED FOR TESTING THE SIZE -* OF DD1 AND DD2. ALL ACTUAL SCALING OF DATA IS DONE USING GAM. +*> \ingroup double_blas_level1 * +* ===================================================================== + SUBROUTINE DROTMG(DD1,DD2,DX1,DY1,DPARAM) * -* Arguments -* ========= -* -* DD1 (input/output) DOUBLE PRECISION -* -* DD2 (input/output) DOUBLE PRECISION -* -* DX1 (input/output) DOUBLE PRECISION -* -* DY1 (input) DOUBLE PRECISION +* -- Reference BLAS level1 routine (version 3.4.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 * -* DPARAM (input/output) DOUBLE PRECISION array, dimension 5 -* DPARAM(1)=DFLAG -* DPARAM(2)=DH11 -* DPARAM(3)=DH21 -* DPARAM(4)=DH12 -* DPARAM(5)=DH22 +* .. Scalar Arguments .. + DOUBLE PRECISION DD1,DD2,DX1,DY1 +* .. +* .. Array Arguments .. + DOUBLE PRECISION DPARAM(5) +* .. * * ===================================================================== * * .. Local Scalars .. DOUBLE PRECISION DFLAG,DH11,DH12,DH21,DH22,DP1,DP2,DQ1,DQ2,DTEMP, - + DU,GAM,GAMSQ,ONE,RGAMSQ,TWO,ZERO - INTEGER IGO + $ DU,GAM,GAMSQ,ONE,RGAMSQ,TWO,ZERO * .. * .. Intrinsic Functions .. INTRINSIC DABS @@ -62,152 +117,135 @@ DATA GAM,GAMSQ,RGAMSQ/4096.D0,16777216.D0,5.9604645D-8/ * .. - IF (.NOT.DD1.LT.ZERO) GO TO 10 -* GO ZERO-H-D-AND-DX1.. - GO TO 60 - 10 CONTINUE -* CASE-DD1-NONNEGATIVE - DP2 = DD2*DY1 - IF (.NOT.DP2.EQ.ZERO) GO TO 20 - DFLAG = -TWO - GO TO 260 - 20 CONTINUE -* REGULAR-CASE.. - DP1 = DD1*DX1 - DQ2 = DP2*DY1 - DQ1 = DP1*DX1 -* - IF (.NOT.DABS(DQ1).GT.DABS(DQ2)) GO TO 40 - DH21 = -DY1/DX1 - DH12 = DP2/DP1 -* - DU = ONE - DH12*DH21 -* - IF (.NOT.DU.LE.ZERO) GO TO 30 -* GO ZERO-H-D-AND-DX1.. - GO TO 60 - 30 CONTINUE - DFLAG = ZERO - DD1 = DD1/DU - DD2 = DD2/DU - DX1 = DX1*DU -* GO SCALE-CHECK.. - GO TO 100 - 40 CONTINUE - IF (.NOT.DQ2.LT.ZERO) GO TO 50 -* GO ZERO-H-D-AND-DX1.. - GO TO 60 - 50 CONTINUE - DFLAG = ONE - DH11 = DP1/DP2 - DH22 = DX1/DY1 - DU = ONE + DH11*DH22 - DTEMP = DD2/DU - DD2 = DD1/DU - DD1 = DTEMP - DX1 = DY1*DU -* GO SCALE-CHECK - GO TO 100 - 60 CONTINUE -* PROCEDURE..ZERO-H-D-AND-DX1.. - DFLAG = -ONE - DH11 = ZERO - DH12 = ZERO - DH21 = ZERO - DH22 = ZERO -* - DD1 = ZERO - DD2 = ZERO - DX1 = ZERO -* RETURN.. - GO TO 220 - 70 CONTINUE -* PROCEDURE..FIX-H.. - IF (.NOT.DFLAG.GE.ZERO) GO TO 90 -* - IF (.NOT.DFLAG.EQ.ZERO) GO TO 80 - DH11 = ONE - DH22 = ONE - DFLAG = -ONE - GO TO 90 - 80 CONTINUE - DH21 = -ONE - DH12 = ONE - DFLAG = -ONE - 90 CONTINUE - GO TO (150,180,210) IGO - GO TO 120 - 100 CONTINUE + IF (DD1.LT.ZERO) THEN +* GO ZERO-H-D-AND-DX1.. + DFLAG = -ONE + DH11 = ZERO + DH12 = ZERO + DH21 = ZERO + DH22 = ZERO +* + DD1 = ZERO + DD2 = ZERO + DX1 = ZERO + ELSE +* CASE-DD1-NONNEGATIVE + DP2 = DD2*DY1 + IF (DP2.EQ.ZERO) THEN + DFLAG = -TWO + DPARAM(1) = DFLAG + RETURN + END IF +* REGULAR-CASE.. + DP1 = DD1*DX1 + DQ2 = DP2*DY1 + DQ1 = DP1*DX1 +* + IF (DABS(DQ1).GT.DABS(DQ2)) THEN + DH21 = -DY1/DX1 + DH12 = DP2/DP1 +* + DU = ONE - DH12*DH21 +* + IF (DU.GT.ZERO) THEN + DFLAG = ZERO + DD1 = DD1/DU + DD2 = DD2/DU + DX1 = DX1*DU + END IF + ELSE + + IF (DQ2.LT.ZERO) THEN +* GO ZERO-H-D-AND-DX1.. + DFLAG = -ONE + DH11 = ZERO + DH12 = ZERO + DH21 = ZERO + DH22 = ZERO +* + DD1 = ZERO + DD2 = ZERO + DX1 = ZERO + ELSE + DFLAG = ONE + DH11 = DP1/DP2 + DH22 = DX1/DY1 + DU = ONE + DH11*DH22 + DTEMP = DD2/DU + DD2 = DD1/DU + DD1 = DTEMP + DX1 = DY1*DU + END IF + END IF + * PROCEDURE..SCALE-CHECK - 110 CONTINUE - IF (.NOT.DD1.LE.RGAMSQ) GO TO 130 - IF (DD1.EQ.ZERO) GO TO 160 - IGO = 0 -* FIX-H.. - GO TO 70 - 120 CONTINUE - DD1 = DD1*GAM**2 - DX1 = DX1/GAM - DH11 = DH11/GAM - DH12 = DH12/GAM - GO TO 110 - 130 CONTINUE - 140 CONTINUE - IF (.NOT.DD1.GE.GAMSQ) GO TO 160 - IGO = 1 -* FIX-H.. - GO TO 70 - 150 CONTINUE - DD1 = DD1/GAM**2 - DX1 = DX1*GAM - DH11 = DH11*GAM - DH12 = DH12*GAM - GO TO 140 - 160 CONTINUE - 170 CONTINUE - IF (.NOT.DABS(DD2).LE.RGAMSQ) GO TO 190 - IF (DD2.EQ.ZERO) GO TO 220 - IGO = 2 -* FIX-H.. - GO TO 70 - 180 CONTINUE - DD2 = DD2*GAM**2 - DH21 = DH21/GAM - DH22 = DH22/GAM - GO TO 170 - 190 CONTINUE - 200 CONTINUE - IF (.NOT.DABS(DD2).GE.GAMSQ) GO TO 220 - IGO = 3 -* FIX-H.. - GO TO 70 - 210 CONTINUE - DD2 = DD2/GAM**2 - DH21 = DH21*GAM - DH22 = DH22*GAM - GO TO 200 - 220 CONTINUE + IF (DD1.NE.ZERO) THEN + DO WHILE ((DD1.LE.RGAMSQ) .OR. (DD1.GE.GAMSQ)) + IF (DFLAG.EQ.ZERO) THEN + DH11 = ONE + DH22 = ONE + DFLAG = -ONE + ELSE + DH21 = -ONE + DH12 = ONE + DFLAG = -ONE + END IF + IF (DD1.LE.RGAMSQ) THEN + DD1 = DD1*GAM**2 + DX1 = DX1/GAM + DH11 = DH11/GAM + DH12 = DH12/GAM + ELSE + DD1 = DD1/GAM**2 + DX1 = DX1*GAM + DH11 = DH11*GAM + DH12 = DH12*GAM + END IF + ENDDO + END IF + + IF (DD2.NE.ZERO) THEN + DO WHILE ( (DABS(DD2).LE.RGAMSQ) .OR. (DABS(DD2).GE.GAMSQ) ) + IF (DFLAG.EQ.ZERO) THEN + DH11 = ONE + DH22 = ONE + DFLAG = -ONE + ELSE + DH21 = -ONE + DH12 = ONE + DFLAG = -ONE + END IF + IF (DABS(DD2).LE.RGAMSQ) THEN + DD2 = DD2*GAM**2 + DH21 = DH21/GAM + DH22 = DH22/GAM + ELSE + DD2 = DD2/GAM**2 + DH21 = DH21*GAM + DH22 = DH22*GAM + END IF + END DO + END IF + + END IF + IF (DFLAG.LT.ZERO) THEN - GO TO 250 + DPARAM(2) = DH11 + DPARAM(3) = DH21 + DPARAM(4) = DH12 + DPARAM(5) = DH22 ELSE IF (DFLAG.EQ.ZERO) THEN - GO TO 230 + DPARAM(3) = DH21 + DPARAM(4) = DH12 ELSE - GO TO 240 + DPARAM(2) = DH11 + DPARAM(5) = DH22 END IF - 230 CONTINUE - DPARAM(3) = DH21 - DPARAM(4) = DH12 - GO TO 260 - 240 CONTINUE - DPARAM(2) = DH11 - DPARAM(5) = DH22 - GO TO 260 - 250 CONTINUE - DPARAM(2) = DH11 - DPARAM(3) = DH21 - DPARAM(4) = DH12 - DPARAM(5) = DH22 - 260 CONTINUE + DPARAM(1) = DFLAG RETURN END + + + +