dd/d48/srotmg_8f_source.html

00001       SUBROUTINE SROTMG(SD1,SD2,SX1,SY1,SPARAM)
00002 *     .. Scalar Arguments ..
00003       REAL SD1,SD2,SX1,SY1
00004 *     ..
00005 *     .. Array Arguments ..
00006       REAL SPARAM(5)
00007 *     ..
00008 *
00009 *  Purpose
00010 *  =======
00011 *
00012 *     CONSTRUCT THE MODIFIED GIVENS TRANSFORMATION MATRIX H WHICH ZEROS
00013 *     THE SECOND COMPONENT OF THE 2-VECTOR  (SQRT(SD1)*SX1,SQRT(SD2)*
00014 *     SY2)**T.
00015 *     WITH SPARAM(1)=SFLAG, H HAS ONE OF THE FOLLOWING FORMS..
00016 *
00017 *     SFLAG=-1.E0     SFLAG=0.E0        SFLAG=1.E0     SFLAG=-2.E0
00018 *
00019 *       (SH11  SH12)    (1.E0  SH12)    (SH11  1.E0)    (1.E0  0.E0)
00020 *     H=(          )    (          )    (          )    (          )
00021 *       (SH21  SH22),   (SH21  1.E0),   (-1.E0 SH22),   (0.E0  1.E0).
00022 *     LOCATIONS 2-4 OF SPARAM CONTAIN SH11,SH21,SH12, AND SH22
00023 *     RESPECTIVELY. (VALUES OF 1.E0, -1.E0, OR 0.E0 IMPLIED BY THE
00024 *     VALUE OF SPARAM(1) ARE NOT STORED IN SPARAM.)
00025 *
00026 *     THE VALUES OF GAMSQ AND RGAMSQ SET IN THE DATA STATEMENT MAY BE
00027 *     INEXACT.  THIS IS OK AS THEY ARE ONLY USED FOR TESTING THE SIZE
00028 *     OF SD1 AND SD2.  ALL ACTUAL SCALING OF DATA IS DONE USING GAM.
00029 *
00030 *
00031 *  Arguments
00032 *  =========
00033 *
00034 *
00035 *  SD1    (input/output) REAL
00036 *
00037 *  SD2    (input/output) REAL
00038 *
00039 *  SX1    (input/output) REAL
00040 *
00041 *  SY1    (input) REAL
00042 *
00043 *
00044 *  SPARAM (input/output)  REAL array, dimension 5
00045 *     SPARAM(1)=SFLAG
00046 *     SPARAM(2)=SH11
00047 *     SPARAM(3)=SH21
00048 *     SPARAM(4)=SH12
00049 *     SPARAM(5)=SH22
00050 *
00051 *  =====================================================================
00052 *
00053 *     .. Local Scalars ..
00054       REAL GAM,GAMSQ,ONE,RGAMSQ,SFLAG,SH11,SH12,SH21,SH22,SP1,SP2,SQ1,
00055      +     SQ2,STEMP,SU,TWO,ZERO
00056       INTEGER IGO
00057 *     ..
00058 *     .. Intrinsic Functions ..
00059       INTRINSIC ABS
00060 *     ..
00061 *     .. Data statements ..
00062 *
00063       DATA ZERO,ONE,TWO/0.E0,1.E0,2.E0/
00064       DATA GAM,GAMSQ,RGAMSQ/4096.E0,1.67772E7,5.96046E-8/
00065 *     ..
00066
00067       IF (.NOT.SD1.LT.ZERO) GO TO 10
00068 *       GO ZERO-H-D-AND-SX1..
00069       GO TO 60
00070    10 CONTINUE
00071 *     CASE-SD1-NONNEGATIVE
00072       SP2 = SD2*SY1
00073       IF (.NOT.SP2.EQ.ZERO) GO TO 20
00074       SFLAG = -TWO
00075       GO TO 260
00076    20 CONTINUE
00077 *     REGULAR-CASE..
00078       SP1 = SD1*SX1
00079       SQ2 = SP2*SY1
00080       SQ1 = SP1*SX1
00081 *
00082       IF (.NOT.ABS(SQ1).GT.ABS(SQ2)) GO TO 40
00083       SH21 = -SY1/SX1
00084       SH12 = SP2/SP1
00085 *
00086       SU = ONE - SH12*SH21
00087 *
00088       IF (.NOT.SU.LE.ZERO) GO TO 30
00089 *         GO ZERO-H-D-AND-SX1..
00090       GO TO 60
00091    30 CONTINUE
00092       SFLAG = ZERO
00093       SD1 = SD1/SU
00094       SD2 = SD2/SU
00095       SX1 = SX1*SU
00096 *         GO SCALE-CHECK..
00097       GO TO 100
00098    40 CONTINUE
00099       IF (.NOT.SQ2.LT.ZERO) GO TO 50
00100 *         GO ZERO-H-D-AND-SX1..
00101       GO TO 60
00102    50 CONTINUE
00103       SFLAG = ONE
00104       SH11 = SP1/SP2
00105       SH22 = SX1/SY1
00106       SU = ONE + SH11*SH22
00107       STEMP = SD2/SU
00108       SD2 = SD1/SU
00109       SD1 = STEMP
00110       SX1 = SY1*SU
00111 *         GO SCALE-CHECK
00112       GO TO 100
00113    60 CONTINUE
00114 *     PROCEDURE..ZERO-H-D-AND-SX1..
00115       SFLAG = -ONE
00116       SH11 = ZERO
00117       SH12 = ZERO
00118       SH21 = ZERO
00119       SH22 = ZERO
00120 *
00121       SD1 = ZERO
00122       SD2 = ZERO
00123       SX1 = ZERO
00124 *         RETURN..
00125       GO TO 220
00126    70 CONTINUE
00127 *     PROCEDURE..FIX-H..
00128       IF (.NOT.SFLAG.GE.ZERO) GO TO 90
00129 *
00130       IF (.NOT.SFLAG.EQ.ZERO) GO TO 80
00131       SH11 = ONE
00132       SH22 = ONE
00133       SFLAG = -ONE
00134       GO TO 90
00135    80 CONTINUE
00136       SH21 = -ONE
00137       SH12 = ONE
00138       SFLAG = -ONE
00139    90 CONTINUE
00140       GO TO (150,180,210) IGO
00141       GO TO 120
00142   100 CONTINUE
00143 *     PROCEDURE..SCALE-CHECK
00144   110 CONTINUE
00145       IF (.NOT.SD1.LE.RGAMSQ) GO TO 130
00146       IF (SD1.EQ.ZERO) GO TO 160
00147       IGO = 0
00148 *              FIX-H..
00149       GO TO 70
00150   120 CONTINUE
00151       SD1 = SD1*GAM**2
00152       SX1 = SX1/GAM
00153       SH11 = SH11/GAM
00154       SH12 = SH12/GAM
00155       GO TO 110
00156   130 CONTINUE
00157   140 CONTINUE
00158       IF (.NOT.SD1.GE.GAMSQ) GO TO 160
00159       IGO = 1
00160 *              FIX-H..
00161       GO TO 70
00162   150 CONTINUE
00163       SD1 = SD1/GAM**2
00164       SX1 = SX1*GAM
00165       SH11 = SH11*GAM
00166       SH12 = SH12*GAM
00167       GO TO 140
00168   160 CONTINUE
00169   170 CONTINUE
00170       IF (.NOT.ABS(SD2).LE.RGAMSQ) GO TO 190
00171       IF (SD2.EQ.ZERO) GO TO 220
00172       IGO = 2
00173 *              FIX-H..
00174       GO TO 70
00175   180 CONTINUE
00176       SD2 = SD2*GAM**2
00177       SH21 = SH21/GAM
00178       SH22 = SH22/GAM
00179       GO TO 170
00180   190 CONTINUE
00181   200 CONTINUE
00182       IF (.NOT.ABS(SD2).GE.GAMSQ) GO TO 220
00183       IGO = 3
00184 *              FIX-H..
00185       GO TO 70
00186   210 CONTINUE
00187       SD2 = SD2/GAM**2
00188       SH21 = SH21*GAM
00189       SH22 = SH22*GAM
00190       GO TO 200
00191   220 CONTINUE
00192       IF (SFLAG.LT.ZERO) THEN
00193          GO TO 250
00194       ELSE IF (SFLAG.EQ.ZERO) THEN
00195          GO TO 230
00196       ELSE
00197          GO TO 240
00198       END IF
00199   230 CONTINUE
00200       SPARAM(3) = SH21
00201       SPARAM(4) = SH12
00202       GO TO 260
00203   240 CONTINUE
00204       SPARAM(2) = SH11
00205       SPARAM(5) = SH22
00206       GO TO 260
00207   250 CONTINUE
00208       SPARAM(2) = SH11
00209       SPARAM(3) = SH21
00210       SPARAM(4) = SH12
00211       SPARAM(5) = SH22
00212   260 CONTINUE
00213       SPARAM(1) = SFLAG
00214       RETURN
00215       END