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