floraachy/OpenBLAS
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Import GotoBLAS2 1.13 BSD version codes.

Browse Source
This commit is contained in:
Xianyi Zhang
2011-01-24 14:54:24 +00:00
commit 342bbc3871
1685 changed files with 1382682 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

166
reference/srotmgf.f Normal file
View File

@@ -0,0 +1,166 @@
SUBROUTINE SROTMGF (SD1,SD2,SX1,SY1,SPARAM)
C
C CONSTRUCT THE MODIFIED GIVENS TRANSFORMATION MATRIX H WHICH ZEROS
C THE SECOND COMPONENT OF THE 2-VECTOR (SQRT(SD1)*SX1,SQRT(SD2)*
C SY2)**T.
C WITH SPARAM(1)=SFLAG, H HAS ONE OF THE FOLLOWING FORMS..
C
C SFLAG=-1.E0 SFLAG=0.E0 SFLAG=1.E0 SFLAG=-2.E0
C
C (SH11 SH12) (1.E0 SH12) (SH11 1.E0) (1.E0 0.E0)
C H=( ) ( ) ( ) ( )
C (SH21 SH22), (SH21 1.E0), (-1.E0 SH22), (0.E0 1.E0).
C LOCATIONS 2-4 OF SPARAM CONTAIN SH11,SH21,SH12, AND SH22
C RESPECTIVELY. (VALUES OF 1.E0, -1.E0, OR 0.E0 IMPLIED BY THE
C VALUE OF SPARAM(1) ARE NOT STORED IN SPARAM.)
C
C THE VALUES OF GAMSQ AND RGAMSQ SET IN THE DATA STATEMENT MAY BE
C INEXACT. THIS IS OK AS THEY ARE ONLY USED FOR TESTING THE SIZE
C OF SD1 AND SD2. ALL ACTUAL SCALING OF DATA IS DONE USING GAM.
C
DIMENSION SPARAM(5)
C
DATA ZERO,ONE,TWO /0.E0,1.E0,2.E0/
DATA GAM,GAMSQ,RGAMSQ/4096.E0,1.67772E7,5.96046E-8/
IF(.NOT. SD1 .LT. ZERO) GO TO 10
C GO ZERO-H-D-AND-SX1..
GO TO 60
10 CONTINUE
C CASE-SD1-NONNEGATIVE
SP2=SD2*SY1
IF(.NOT. SP2 .EQ. ZERO) GO TO 20
SFLAG=-TWO
GO TO 260
C REGULAR-CASE..
20 CONTINUE
SP1=SD1*SX1
SQ2=SP2*SY1
SQ1=SP1*SX1
C
IF(.NOT. ABS(SQ1) .GT. ABS(SQ2)) GO TO 40
SH21=-SY1/SX1
SH12=SP2/SP1
C
SU=ONE-SH12*SH21
C
IF(.NOT. SU .LE. ZERO) GO TO 30
C GO ZERO-H-D-AND-SX1..
GO TO 60
30 CONTINUE
SFLAG=ZERO
SD1=SD1/SU
SD2=SD2/SU
SX1=SX1*SU
C GO SCALE-CHECK..
GO TO 100
40 CONTINUE
IF(.NOT. SQ2 .LT. ZERO) GO TO 50
C GO ZERO-H-D-AND-SX1..
GO TO 60
50 CONTINUE
SFLAG=ONE
SH11=SP1/SP2
SH22=SX1/SY1
SU=ONE+SH11*SH22
STEMP=SD2/SU
SD2=SD1/SU
SD1=STEMP
SX1=SY1*SU
C GO SCALE-CHECK
GO TO 100
C PROCEDURE..ZERO-H-D-AND-SX1..
60 CONTINUE
SFLAG=-ONE
SH11=ZERO
SH12=ZERO
SH21=ZERO
SH22=ZERO
C
SD1=ZERO
SD2=ZERO
SX1=ZERO
C RETURN..
GO TO 220
C PROCEDURE..FIX-H..
70 CONTINUE
IF(.NOT. SFLAG .GE. ZERO) GO TO 90
C
IF(.NOT. SFLAG .EQ. ZERO) GO TO 80
SH11=ONE
SH22=ONE
SFLAG=-ONE
GO TO 90
80 CONTINUE
SH21=-ONE
SH12=ONE
SFLAG=-ONE
90 CONTINUE
GO TO IGO,(120,150,180,210)
C PROCEDURE..SCALE-CHECK
100 CONTINUE
110 CONTINUE
IF(.NOT. SD1 .LE. RGAMSQ) GO TO 130
IF(SD1 .EQ. ZERO) GO TO 160
ASSIGN 120 TO IGO
C FIX-H..
GO TO 70
120 CONTINUE
SD1=SD1*GAM**2
SX1=SX1/GAM
SH11=SH11/GAM
SH12=SH12/GAM
GO TO 110
130 CONTINUE
140 CONTINUE
IF(.NOT. SD1 .GE. GAMSQ) GO TO 160
ASSIGN 150 TO IGO
C FIX-H..
GO TO 70
150 CONTINUE
SD1=SD1/GAM**2
SX1=SX1*GAM
SH11=SH11*GAM
SH12=SH12*GAM
GO TO 140
160 CONTINUE
170 CONTINUE
IF(.NOT. ABS(SD2) .LE. RGAMSQ) GO TO 190
IF(SD2 .EQ. ZERO) GO TO 220
ASSIGN 180 TO IGO
C FIX-H..
GO TO 70
180 CONTINUE
SD2=SD2*GAM**2
SH21=SH21/GAM
SH22=SH22/GAM
GO TO 170
190 CONTINUE
200 CONTINUE
IF(.NOT. ABS(SD2) .GE. GAMSQ) GO TO 220
ASSIGN 210 TO IGO
C FIX-H..
GO TO 70
210 CONTINUE
SD2=SD2/GAM**2
SH21=SH21*GAM
SH22=SH22*GAM
GO TO 200
220 CONTINUE
IF(SFLAG)250,230,240
230 CONTINUE
SPARAM(3)=SH21
SPARAM(4)=SH12
GO TO 260
240 CONTINUE
SPARAM(2)=SH11
SPARAM(5)=SH22
GO TO 260
250 CONTINUE
SPARAM(2)=SH11
SPARAM(3)=SH21
SPARAM(4)=SH12
SPARAM(5)=SH22
260 CONTINUE
SPARAM(1)=SFLAG
RETURN
END