LAPACK 3.3.1
Linear Algebra PACKage

drotmg.f

Go to the documentation of this file.
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 *     ..
00055 *     .. Intrinsic Functions ..
00056       INTRINSIC DABS
00057 *     ..
00058 *     .. Data statements ..
00059 *
00060       DATA ZERO,ONE,TWO/0.D0,1.D0,2.D0/
00061       DATA GAM,GAMSQ,RGAMSQ/4096.D0,16777216.D0,5.9604645D-8/
00062 *     ..
00063 
00064       IF (DD1.LT.ZERO) THEN
00065 *        GO ZERO-H-D-AND-DX1..
00066          DFLAG = -ONE
00067          DH11 = ZERO
00068          DH12 = ZERO
00069          DH21 = ZERO
00070          DH22 = ZERO
00071 *
00072          DD1 = ZERO
00073          DD2 = ZERO
00074          DX1 = ZERO
00075       ELSE
00076 *        CASE-DD1-NONNEGATIVE
00077          DP2 = DD2*DY1
00078          IF (DP2.EQ.ZERO) THEN
00079             DFLAG = -TWO
00080             DPARAM(1) = DFLAG
00081             RETURN
00082          END IF 
00083 *        REGULAR-CASE..
00084          DP1 = DD1*DX1
00085          DQ2 = DP2*DY1
00086          DQ1 = DP1*DX1
00087 *
00088          IF (DABS(DQ1).GT.DABS(DQ2)) THEN
00089             DH21 = -DY1/DX1
00090             DH12 = DP2/DP1
00091 *
00092             DU = ONE - DH12*DH21
00093 *
00094            IF (DU.GT.ZERO) THEN
00095              DFLAG = ZERO
00096              DD1 = DD1/DU
00097              DD2 = DD2/DU
00098              DX1 = DX1*DU
00099            END IF
00100          ELSE
00101 
00102             IF (DQ2.LT.ZERO) THEN
00103 *              GO ZERO-H-D-AND-DX1..
00104                DFLAG = -ONE
00105                DH11 = ZERO
00106                DH12 = ZERO
00107                DH21 = ZERO
00108                DH22 = ZERO
00109 *
00110                DD1 = ZERO
00111                DD2 = ZERO
00112                DX1 = ZERO
00113             ELSE
00114                DFLAG = ONE
00115                DH11 = DP1/DP2
00116                DH22 = DX1/DY1
00117                DU = ONE + DH11*DH22
00118                DTEMP = DD2/DU
00119                DD2 = DD1/DU
00120                DD1 = DTEMP
00121                DX1 = DY1*DU
00122             END IF
00123          END IF
00124 
00125 *     PROCEDURE..SCALE-CHECK
00126          IF (DD1.NE.ZERO) THEN
00127             DO WHILE ((DD1.LE.RGAMSQ) .OR. (DD1.GE.GAMSQ))
00128                IF (DFLAG.EQ.ZERO) THEN
00129                   DH11 = ONE
00130                   DH22 = ONE
00131                   DFLAG = -ONE
00132                ELSE
00133                   DH21 = -ONE
00134                   DH12 = ONE
00135                   DFLAG = -ONE
00136                END IF
00137                IF (DD1.LE.RGAMSQ) THEN
00138                   DD1 = DD1*GAM**2
00139                   DX1 = DX1/GAM
00140                   DH11 = DH11/GAM
00141                   DH12 = DH12/GAM
00142                ELSE
00143                   DD1 = DD1/GAM**2
00144                   DX1 = DX1*GAM
00145                   DH11 = DH11*GAM
00146                   DH12 = DH12*GAM
00147                END IF
00148             ENDDO
00149          END IF
00150   
00151          IF (DD2.NE.ZERO) THEN
00152             DO WHILE ( (DABS(DD2).LE.RGAMSQ) .OR. (DABS(DD2).GE.GAMSQ) )
00153                IF (DFLAG.EQ.ZERO) THEN
00154                   DH11 = ONE
00155                   DH22 = ONE
00156                   DFLAG = -ONE
00157                ELSE
00158                   DH21 = -ONE
00159                   DH12 = ONE
00160                   DFLAG = -ONE
00161                END IF
00162                IF (DABS(DD2).LE.RGAMSQ) THEN
00163                   DD2 = DD2*GAM**2
00164                   DH21 = DH21/GAM
00165                   DH22 = DH22/GAM
00166                ELSE
00167                   DD2 = DD2/GAM**2
00168                   DH21 = DH21*GAM
00169                   DH22 = DH22*GAM
00170                END IF      
00171             END DO
00172          END IF
00173      
00174       END IF
00175 
00176       IF (DFLAG.LT.ZERO) THEN
00177          DPARAM(2) = DH11
00178          DPARAM(3) = DH21
00179          DPARAM(4) = DH12
00180          DPARAM(5) = DH22
00181       ELSE IF (DFLAG.EQ.ZERO) THEN
00182          DPARAM(3) = DH21
00183          DPARAM(4) = DH12 
00184       ELSE
00185          DPARAM(2) = DH11
00186          DPARAM(5) = DH22
00187       END IF
00188 
00189   260 CONTINUE
00190       DPARAM(1) = DFLAG
00191       RETURN
00192       END
00193       
00194      
00195      
00196      
 All Files Functions