df/deb/drotmg_8f_source.html

00001       SUBROUTINE DROTMG(DD1,DD2,DX1,DY1,DPARAM)
00002 *     .. Scalar Arguments ..
00003       DOUBLE PRECISION DD1,DD2,DX1,DY1
00004 *     ..
00005 *     .. Array Arguments ..
00006       DOUBLE PRECISION DPARAM(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  (DSQRT(DD1)*DX1,DSQRT(DD2)*
00014 *     DY2)**T.
00015 *     WITH DPARAM(1)=DFLAG, H HAS ONE OF THE FOLLOWING FORMS..
00016 *
00017 *     DFLAG=-1.D0     DFLAG=0.D0        DFLAG=1.D0     DFLAG=-2.D0
00018 *
00019 *       (DH11  DH12)    (1.D0  DH12)    (DH11  1.D0)    (1.D0  0.D0)
00020 *     H=(          )    (          )    (          )    (          )
00021 *       (DH21  DH22),   (DH21  1.D0),   (-1.D0 DH22),   (0.D0  1.D0).
00022 *     LOCATIONS 2-4 OF DPARAM CONTAIN DH11, DH21, DH12, AND DH22
00023 *     RESPECTIVELY. (VALUES OF 1.D0, -1.D0, OR 0.D0 IMPLIED BY THE
00024 *     VALUE OF DPARAM(1) ARE NOT STORED IN DPARAM.)
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 DD1 AND DD2.  ALL ACTUAL SCALING OF DATA IS DONE USING GAM.
00029 *
00030 *
00031 *  Arguments
00032 *  =========
00033 *
00034 *  DD1    (input/output) DOUBLE PRECISION
00035 *
00036 *  DD2    (input/output) DOUBLE PRECISION
00037 *
00038 *  DX1    (input/output) DOUBLE PRECISION
00039 *
00040 *  DY1    (input) DOUBLE PRECISION
00041 *
00042 *  DPARAM (input/output)  DOUBLE PRECISION array, dimension 5
00043 *     DPARAM(1)=DFLAG
00044 *     DPARAM(2)=DH11
00045 *     DPARAM(3)=DH21
00046 *     DPARAM(4)=DH12
00047 *     DPARAM(5)=DH22
00048 *
00049 *  =====================================================================
00050 *
00051 *     .. Local Scalars ..
00052       DOUBLE PRECISION DFLAG,DH11,DH12,DH21,DH22,DP1,DP2,DQ1,DQ2,DTEMP,
00053      +                 DU,GAM,GAMSQ,ONE,RGAMSQ,TWO,ZERO
00054       INTEGER IGO
00055 *     ..
00056 *     .. Intrinsic Functions ..
00057       INTRINSIC DABS
00058 *     ..
00059 *     .. Data statements ..
00060 *
00061       DATA ZERO,ONE,TWO/0.D0,1.D0,2.D0/
00062       DATA GAM,GAMSQ,RGAMSQ/4096.D0,16777216.D0,5.9604645D-8/
00063 *     ..
00064
00065       IF (.NOT.DD1.LT.ZERO) GO TO 10
00066 *       GO ZERO-H-D-AND-DX1..
00067       GO TO 60
00068    10 CONTINUE
00069 *     CASE-DD1-NONNEGATIVE
00070       DP2 = DD2*DY1
00071       IF (.NOT.DP2.EQ.ZERO) GO TO 20
00072       DFLAG = -TWO
00073       GO TO 260
00074    20 CONTINUE
00075 *     REGULAR-CASE..
00076       DP1 = DD1*DX1
00077       DQ2 = DP2*DY1
00078       DQ1 = DP1*DX1
00079 *
00080       IF (.NOT.DABS(DQ1).GT.DABS(DQ2)) GO TO 40
00081       DH21 = -DY1/DX1
00082       DH12 = DP2/DP1
00083 *
00084       DU = ONE - DH12*DH21
00085 *
00086       IF (.NOT.DU.LE.ZERO) GO TO 30
00087 *         GO ZERO-H-D-AND-DX1..
00088       GO TO 60
00089    30 CONTINUE
00090       DFLAG = ZERO
00091       DD1 = DD1/DU
00092       DD2 = DD2/DU
00093       DX1 = DX1*DU
00094 *         GO SCALE-CHECK..
00095       GO TO 100
00096    40 CONTINUE
00097       IF (.NOT.DQ2.LT.ZERO) GO TO 50
00098 *         GO ZERO-H-D-AND-DX1..
00099       GO TO 60
00100    50 CONTINUE
00101       DFLAG = ONE
00102       DH11 = DP1/DP2
00103       DH22 = DX1/DY1
00104       DU = ONE + DH11*DH22
00105       DTEMP = DD2/DU
00106       DD2 = DD1/DU
00107       DD1 = DTEMP
00108       DX1 = DY1*DU
00109 *         GO SCALE-CHECK
00110       GO TO 100
00111    60 CONTINUE
00112 *     PROCEDURE..ZERO-H-D-AND-DX1..
00113       DFLAG = -ONE
00114       DH11 = ZERO
00115       DH12 = ZERO
00116       DH21 = ZERO
00117       DH22 = ZERO
00118 *
00119       DD1 = ZERO
00120       DD2 = ZERO
00121       DX1 = ZERO
00122 *         RETURN..
00123       GO TO 220
00124    70 CONTINUE
00125 *     PROCEDURE..FIX-H..
00126       IF (.NOT.DFLAG.GE.ZERO) GO TO 90
00127 *
00128       IF (.NOT.DFLAG.EQ.ZERO) GO TO 80
00129       DH11 = ONE
00130       DH22 = ONE
00131       DFLAG = -ONE
00132       GO TO 90
00133    80 CONTINUE
00134       DH21 = -ONE
00135       DH12 = ONE
00136       DFLAG = -ONE
00137    90 CONTINUE
00138       GO TO (150,180,210) IGO
00139       GO TO 120
00140   100 CONTINUE
00141 *     PROCEDURE..SCALE-CHECK
00142   110 CONTINUE
00143       IF (.NOT.DD1.LE.RGAMSQ) GO TO 130
00144       IF (DD1.EQ.ZERO) GO TO 160
00145       IGO = 0
00146 *              FIX-H..
00147       GO TO 70
00148   120 CONTINUE
00149       DD1 = DD1*GAM**2
00150       DX1 = DX1/GAM
00151       DH11 = DH11/GAM
00152       DH12 = DH12/GAM
00153       GO TO 110
00154   130 CONTINUE
00155   140 CONTINUE
00156       IF (.NOT.DD1.GE.GAMSQ) GO TO 160
00157       IGO = 1
00158 *              FIX-H..
00159       GO TO 70
00160   150 CONTINUE
00161       DD1 = DD1/GAM**2
00162       DX1 = DX1*GAM
00163       DH11 = DH11*GAM
00164       DH12 = DH12*GAM
00165       GO TO 140
00166   160 CONTINUE
00167   170 CONTINUE
00168       IF (.NOT.DABS(DD2).LE.RGAMSQ) GO TO 190
00169       IF (DD2.EQ.ZERO) GO TO 220
00170       IGO = 2
00171 *              FIX-H..
00172       GO TO 70
00173   180 CONTINUE
00174       DD2 = DD2*GAM**2
00175       DH21 = DH21/GAM
00176       DH22 = DH22/GAM
00177       GO TO 170
00178   190 CONTINUE
00179   200 CONTINUE
00180       IF (.NOT.DABS(DD2).GE.GAMSQ) GO TO 220
00181       IGO = 3
00182 *              FIX-H..
00183       GO TO 70
00184   210 CONTINUE
00185       DD2 = DD2/GAM**2
00186       DH21 = DH21*GAM
00187       DH22 = DH22*GAM
00188       GO TO 200
00189   220 CONTINUE
00190       IF (DFLAG.LT.ZERO) THEN
00191          GO TO 250
00192       ELSE IF (DFLAG.EQ.ZERO) THEN
00193          GO TO 230
00194       ELSE
00195          GO TO 240
00196       END IF
00197   230 CONTINUE
00198       DPARAM(3) = DH21
00199       DPARAM(4) = DH12
00200       GO TO 260
00201   240 CONTINUE
00202       DPARAM(2) = DH11
00203       DPARAM(5) = DH22
00204       GO TO 260
00205   250 CONTINUE
00206       DPARAM(2) = DH11
00207       DPARAM(3) = DH21
00208       DPARAM(4) = DH12
00209       DPARAM(5) = DH22
00210   260 CONTINUE
00211       DPARAM(1) = DFLAG
00212       RETURN
00213       END