drotmg(3f) - [BLAS:DOUBLE_BLAS_LEVEL1]
subroutine drotmg(dd1,dd2,dx1,dy1,dparam)
.. Scalar Arguments ..
double precision,intent(inout) :: dd1,dd2,dx1
double precision,intent(in) :: dy1
..
.. Array Arguments ..
double precision,intent(out) :: dparam(5)
..
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.
DD1
DD1 is DOUBLE PRECISION
DD2
DD2 is DOUBLE PRECISION
DX1
DX1 is DOUBLE PRECISION
DY1
DY1 is DOUBLE PRECISION
DPARAM
DPARAM is DOUBLE PRECISION array, dimension (5)
DPARAM(1)=DFLAG
DPARAM(2)=DH11
DPARAM(3)=DH21
DPARAM(4)=DH12
DPARAM(5)=DH22
date:November 2017
Online html documentation available at
http://www.netlib.org/lapack/explore-html/
| Type | Intent | Optional | Attributes | Name | ||
|---|---|---|---|---|---|---|
| double precision, | intent(inout) | :: | dd1 | |||
| double precision, | intent(inout) | :: | dd2 | |||
| double precision, | intent(inout) | :: | dx1 | |||
| double precision, | intent(in) | :: | dy1 | |||
| double precision, | intent(out) | :: | dparam(5) |
| Type | Visibility | Attributes | Name | Initial | |||
|---|---|---|---|---|---|---|---|
| double precision, | public | :: | dflag | ||||
| double precision, | public | :: | dh11 | ||||
| double precision, | public | :: | dh12 | ||||
| double precision, | public | :: | dh21 | ||||
| double precision, | public | :: | dh22 | ||||
| double precision, | public | :: | dp1 | ||||
| double precision, | public | :: | dp2 | ||||
| double precision, | public | :: | dq1 | ||||
| double precision, | public | :: | dq2 | ||||
| double precision, | public | :: | dtemp | ||||
| double precision, | public | :: | du | ||||
| doubleprecision, | public, | parameter | :: | gam | = | 4096.d0 | |
| doubleprecision, | public, | parameter | :: | gamsq | = | 16777216.d0 | |
| doubleprecision, | public, | parameter | :: | one | = | 1.0d0 | |
| doubleprecision, | public, | parameter | :: | rgamsq | = | 5.9604645d-8 | |
| doubleprecision, | public, | parameter | :: | two | = | 2.0d0 | |
| doubleprecision, | public, | parameter | :: | zero | = | 0.0d0 |
subroutine drotmg(dd1,dd2,dx1,dy1,dparam)
implicit none
!
! -- Reference BLAS level1 routine (version 3.8.0) --
! -- Reference BLAS is a software package provided by Univ. of Tennessee, --
! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
! November 2017
!
! .. Scalar Arguments ..
double precision,intent(inout) :: dd1,dd2,dx1
double precision,intent(in) :: dy1
! ..
! .. Array Arguments ..
double precision,intent(out) :: dparam(5)
! ..
!
! =====================================================================
!
! .. Local Scalars ..
double precision dflag,dh11,dh12,dh21,dh22,dp1,dp2,dq1,dq2,dtemp, du
! ..
! .. Intrinsic Functions ..
intrinsic dabs
! ..
! .. Data statements ..
!
doubleprecision,parameter :: zero=0.0d0
doubleprecision,parameter :: one=1.0d0
doubleprecision,parameter :: two=2.0d0
doubleprecision,parameter :: gam=4096.d0
doubleprecision,parameter :: gamsq=16777216.d0
doubleprecision,parameter :: rgamsq=5.9604645d-8
! ..
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
endif
! 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
else
! This code path if here for safety. We do not expect this
! condition to ever hold except in edge cases with rounding
! errors. See DOI: 10.1145/355841.355847
dflag = -one
dh11 = zero
dh12 = zero
dh21 = zero
dh22 = zero
!
dd1 = zero
dd2 = zero
dx1 = zero
endif
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
endif
endif
! PROCEDURE..SCALE-CHECK
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
endif
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
endif
enddo
endif
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
endif
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
endif
enddo
endif
endif
if (dflag.lt.zero) then
dparam(2) = dh11
dparam(3) = dh21
dparam(4) = dh12
dparam(5) = dh22
elseif (dflag.eq.zero) then
dparam(3) = dh21
dparam(4) = dh12
else
dparam(2) = dh11
dparam(5) = dh22
endif
dparam(1) = dflag
end subroutine drotmg