169 lines
4.6 KiB
Fortran
169 lines
4.6 KiB
Fortran
SUBROUTINE DROTMGF (DD1,DD2,DX1,DY1,DPARAM)
|
|
C
|
|
C CONSTRUCT THE MODIFIED GIVENS TRANSFORMATION MATRIX H WHICH ZEROS
|
|
C THE SECOND COMPONENT OF THE 2-VECTOR (DSQRT(DD1)*DX1,DSQRT(DD2)*
|
|
C DY2)**T.
|
|
C WITH DPARAM(1)=DFLAG, H HAS ONE OF THE FOLLOWING FORMS..
|
|
C
|
|
C DFLAG=-1.D0 DFLAG=0.D0 DFLAG=1.D0 DFLAG=-2.D0
|
|
C
|
|
C (DH11 DH12) (1.D0 DH12) (DH11 1.D0) (1.D0 0.D0)
|
|
C H=( ) ( ) ( ) ( )
|
|
C (DH21 DH22), (DH21 1.D0), (-1.D0 DH22), (0.D0 1.D0).
|
|
C LOCATIONS 2-4 OF DPARAM CONTAIN DH11, DH21, DH12, AND DH22
|
|
C RESPECTIVELY. (VALUES OF 1.D0, -1.D0, OR 0.D0 IMPLIED BY THE
|
|
C VALUE OF DPARAM(1) ARE NOT STORED IN DPARAM.)
|
|
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 DD1 AND DD2. ALL ACTUAL SCALING OF DATA IS DONE USING GAM.
|
|
C
|
|
DOUBLE PRECISION GAM,ONE,RGAMSQ,DD2,DH11,DH21,DPARAM,DP2,
|
|
1 DQ2,DU,DY1,ZERO,GAMSQ,DD1,DFLAG,DH12,DH22,DP1,DQ1,
|
|
2 DTEMP,DX1,TWO
|
|
DIMENSION DPARAM(5)
|
|
C
|
|
DATA ZERO,ONE,TWO /0.D0,1.D0,2.D0/
|
|
DATA GAM,GAMSQ,RGAMSQ/4096.D0,16777216.D0,5.9604645D-8/
|
|
IF(.NOT. DD1 .LT. ZERO) GO TO 10
|
|
C GO ZERO-H-D-AND-DX1..
|
|
GO TO 60
|
|
10 CONTINUE
|
|
C CASE-DD1-NONNEGATIVE
|
|
DP2=DD2*DY1
|
|
IF(.NOT. DP2 .EQ. ZERO) GO TO 20
|
|
DFLAG=-TWO
|
|
GO TO 260
|
|
C REGULAR-CASE..
|
|
20 CONTINUE
|
|
DP1=DD1*DX1
|
|
DQ2=DP2*DY1
|
|
DQ1=DP1*DX1
|
|
C
|
|
IF(.NOT. DABS(DQ1) .GT. DABS(DQ2)) GO TO 40
|
|
DH21=-DY1/DX1
|
|
DH12=DP2/DP1
|
|
C
|
|
DU=ONE-DH12*DH21
|
|
C
|
|
IF(.NOT. DU .LE. ZERO) GO TO 30
|
|
C GO ZERO-H-D-AND-DX1..
|
|
GO TO 60
|
|
30 CONTINUE
|
|
DFLAG=ZERO
|
|
DD1=DD1/DU
|
|
DD2=DD2/DU
|
|
DX1=DX1*DU
|
|
C GO SCALE-CHECK..
|
|
GO TO 100
|
|
40 CONTINUE
|
|
IF(.NOT. DQ2 .LT. ZERO) GO TO 50
|
|
C 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
|
|
C GO SCALE-CHECK
|
|
GO TO 100
|
|
C PROCEDURE..ZERO-H-D-AND-DX1..
|
|
60 CONTINUE
|
|
DFLAG=-ONE
|
|
DH11=ZERO
|
|
DH12=ZERO
|
|
DH21=ZERO
|
|
DH22=ZERO
|
|
C
|
|
DD1=ZERO
|
|
DD2=ZERO
|
|
DX1=ZERO
|
|
C RETURN..
|
|
GO TO 220
|
|
C PROCEDURE..FIX-H..
|
|
70 CONTINUE
|
|
IF(.NOT. DFLAG .GE. ZERO) GO TO 90
|
|
C
|
|
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 IGO,(120,150,180,210)
|
|
C PROCEDURE..SCALE-CHECK
|
|
100 CONTINUE
|
|
110 CONTINUE
|
|
IF(.NOT. DD1 .LE. RGAMSQ) GO TO 130
|
|
IF(DD1 .EQ. ZERO) GO TO 160
|
|
ASSIGN 120 TO IGO
|
|
C 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
|
|
ASSIGN 150 TO IGO
|
|
C 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
|
|
ASSIGN 180 TO IGO
|
|
C 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
|
|
ASSIGN 210 TO IGO
|
|
C FIX-H..
|
|
GO TO 70
|
|
210 CONTINUE
|
|
DD2=DD2/GAM**2
|
|
DH21=DH21*GAM
|
|
DH22=DH22*GAM
|
|
GO TO 200
|
|
220 CONTINUE
|
|
IF(DFLAG)250,230,240
|
|
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
|