srotmg(3f) - [BLAS:SINGLE_BLAS_LEVEL1] Generate a modified Given's rotation.
subroutine srotmg(sd1,sd2,sx1,sy1,sparam)
.. Scalar Arguments ..
real,intent(inout) :: sd1,sd2,sx1
real,intent(in) :: sy1
..
.. Array Arguments ..
real,intent(out) :: sparam(5)
..
Construct the modified Givens Transformation Matrix H which zeros
the second component of the 2-vector
(sqrt(sd1)*sx1,sqrt(sd2)*>sy2)**t.
with sparam(1)=sflag, H has one of the following forms..
SFLAG=-1.E0 SFLAG=0.E0 SFLAG=1.E0 SFLAG=-2.E0
(SH11 SH12) (1.E0 SH12) (SH11 1.E0) (1.E0 0.E0)
H=( ) ( ) ( ) ( )
(SH21 SH22), (SH21 1.E0), (-1.E0 SH22), (0.E0 1.E0).
locations 2-4 of SPARAM contain SH11,SH21,SH12, and SH22
respectively. (values of 1.e0, -1.e0, or 0.e0 implied by the value
of SPARAM(1) are not stored in SPARAM.)
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
SD1 and SD2. All actual scaling of data is done using GAM.
SD1
SD1 is REAL
SD2
SD2 is REAL
SX1
SX1 is REAL
SY1
SY1 is REAL
SPARAM
SPARAM is REAL array, dimension (5)
SPARAM(1)=SFLAG
SPARAM(2)=SH11
SPARAM(3)=SH21
SPARAM(4)=SH12
SPARAM(5)=SH22
date:November 2017
Online html documentation available at
http://www.netlib.org/lapack/explore-html/
| Type | Intent | Optional | Attributes | Name | ||
|---|---|---|---|---|---|---|
| real, | intent(inout) | :: | sd1 | |||
| real, | intent(inout) | :: | sd2 | |||
| real, | intent(inout) | :: | sx1 | |||
| real, | intent(in) | :: | sy1 | |||
| real, | intent(out) | :: | sparam(5) |
| Type | Visibility | Attributes | Name | Initial | |||
|---|---|---|---|---|---|---|---|
| real, | public, | parameter | :: | gam | = | 4096.e0 | |
| real, | public, | parameter | :: | gamsq | = | 1.67772e7 | |
| real, | public, | parameter | :: | one | = | 1.0e0 | |
| real, | public, | parameter | :: | rgamsq | = | 5.96046e-8 | |
| real, | public | :: | sflag | ||||
| real, | public | :: | sh11 | ||||
| real, | public | :: | sh12 | ||||
| real, | public | :: | sh21 | ||||
| real, | public | :: | sh22 | ||||
| real, | public | :: | sp1 | ||||
| real, | public | :: | sp2 | ||||
| real, | public | :: | sq1 | ||||
| real, | public | :: | sq2 | ||||
| real, | public | :: | stemp | ||||
| real, | public | :: | su | ||||
| real, | public, | parameter | :: | two | = | 2.0e0 | |
| real, | public, | parameter | :: | zero | = | 0.0e0 |
subroutine srotmg(sd1,sd2,sx1,sy1,sparam)
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 ..
real,intent(inout) :: sd1,sd2,sx1
real,intent(in) :: sy1
! ..
! .. Array Arguments ..
real,intent(out) :: sparam(5)
! ..
! =====================================================================
!
! .. Local Scalars ..
real sflag,sh11,sh12,sh21,sh22,sp1,sp2,sq1, sq2,stemp,su
! ..
! .. Intrinsic Functions ..
intrinsic abs
! ..
! .. Data statements ..
real,parameter :: zero=0.0e0
real,parameter :: one=1.0e0
real,parameter :: two=2.0e0
!
real,parameter :: gam=4096.e0
real,parameter :: gamsq=1.67772e7
real,parameter :: rgamsq=5.96046e-8
! ..
if (sd1.lt.zero) then
! GO ZERO-H-D-AND-SX1..
sflag = -one
sh11 = zero
sh12 = zero
sh21 = zero
sh22 = zero
!
sd1 = zero
sd2 = zero
sx1 = zero
else
! CASE-SD1-NONNEGATIVE
sp2 = sd2*sy1
if (sp2.eq.zero) then
sflag = -two
sparam(1) = sflag
return
endif
! REGULAR-CASE..
sp1 = sd1*sx1
sq2 = sp2*sy1
sq1 = sp1*sx1
!
if (abs(sq1).gt.abs(sq2)) then
sh21 = -sy1/sx1
sh12 = sp2/sp1
!
su = one - sh12*sh21
!
if (su.gt.zero) then
sflag = zero
sd1 = sd1/su
sd2 = sd2/su
sx1 = sx1*su
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
sflag = -one
sh11 = zero
sh12 = zero
sh21 = zero
sh22 = zero
!
sd1 = zero
sd2 = zero
sx1 = zero
endif
else
if (sq2.lt.zero) then
! GO ZERO-H-D-AND-SX1..
sflag = -one
sh11 = zero
sh12 = zero
sh21 = zero
sh22 = zero
!
sd1 = zero
sd2 = zero
sx1 = zero
else
sflag = one
sh11 = sp1/sp2
sh22 = sx1/sy1
su = one + sh11*sh22
stemp = sd2/su
sd2 = sd1/su
sd1 = stemp
sx1 = sy1*su
endif
endif
! PROCEDURE..SCALE-CHECK
if (sd1.ne.zero) then
do while ((sd1.le.rgamsq) .or. (sd1.ge.gamsq))
if (sflag.eq.zero) then
sh11 = one
sh22 = one
sflag = -one
else
sh21 = -one
sh12 = one
sflag = -one
endif
if (sd1.le.rgamsq) then
sd1 = sd1*gam**2
sx1 = sx1/gam
sh11 = sh11/gam
sh12 = sh12/gam
else
sd1 = sd1/gam**2
sx1 = sx1*gam
sh11 = sh11*gam
sh12 = sh12*gam
endif
enddo
endif
if (sd2.ne.zero) then
do while ( (abs(sd2).le.rgamsq) .or. (abs(sd2).ge.gamsq) )
if (sflag.eq.zero) then
sh11 = one
sh22 = one
sflag = -one
else
sh21 = -one
sh12 = one
sflag = -one
endif
if (abs(sd2).le.rgamsq) then
sd2 = sd2*gam**2
sh21 = sh21/gam
sh22 = sh22/gam
else
sd2 = sd2/gam**2
sh21 = sh21*gam
sh22 = sh22*gam
endif
enddo
endif
endif
if (sflag.lt.zero) then
sparam(2) = sh11
sparam(3) = sh21
sparam(4) = sh12
sparam(5) = sh22
elseif (sflag.eq.zero) then
sparam(3) = sh21
sparam(4) = sh12
else
sparam(2) = sh11
sparam(5) = sh22
endif
sparam(1) = sflag
end subroutine srotmg