Annotation of rpl/lapack/blas/drotmg.f, revision 1.5

1.1       bertrand    1:       SUBROUTINE DROTMG(DD1,DD2,DX1,DY1,DPARAM)
                      2: *     .. Scalar Arguments ..
                      3:       DOUBLE PRECISION DD1,DD2,DX1,DY1
                      4: *     ..
                      5: *     .. Array Arguments ..
                      6:       DOUBLE PRECISION DPARAM(5)
                      7: *     ..
                      8: *
                      9: *  Purpose
                     10: *  =======
                     11: *
                     12: *     CONSTRUCT THE MODIFIED GIVENS TRANSFORMATION MATRIX H WHICH ZEROS
                     13: *     THE SECOND COMPONENT OF THE 2-VECTOR  (DSQRT(DD1)*DX1,DSQRT(DD2)*
                     14: *     DY2)**T.
                     15: *     WITH DPARAM(1)=DFLAG, H HAS ONE OF THE FOLLOWING FORMS..
                     16: *
                     17: *     DFLAG=-1.D0     DFLAG=0.D0        DFLAG=1.D0     DFLAG=-2.D0
                     18: *
                     19: *       (DH11  DH12)    (1.D0  DH12)    (DH11  1.D0)    (1.D0  0.D0)
                     20: *     H=(          )    (          )    (          )    (          )
                     21: *       (DH21  DH22),   (DH21  1.D0),   (-1.D0 DH22),   (0.D0  1.D0).
                     22: *     LOCATIONS 2-4 OF DPARAM CONTAIN DH11, DH21, DH12, AND DH22
                     23: *     RESPECTIVELY. (VALUES OF 1.D0, -1.D0, OR 0.D0 IMPLIED BY THE
                     24: *     VALUE OF DPARAM(1) ARE NOT STORED IN DPARAM.)
                     25: *
                     26: *     THE VALUES OF GAMSQ AND RGAMSQ SET IN THE DATA STATEMENT MAY BE
                     27: *     INEXACT.  THIS IS OK AS THEY ARE ONLY USED FOR TESTING THE SIZE
                     28: *     OF DD1 AND DD2.  ALL ACTUAL SCALING OF DATA IS DONE USING GAM.
                     29: *
                     30: *
                     31: *  Arguments
                     32: *  =========
                     33: *
                     34: *  DD1    (input/output) DOUBLE PRECISION
                     35: *
1.4       bertrand   36: *  DD2    (input/output) DOUBLE PRECISION
1.1       bertrand   37: *
1.4       bertrand   38: *  DX1    (input/output) DOUBLE PRECISION
1.1       bertrand   39: *
                     40: *  DY1    (input) DOUBLE PRECISION
                     41: *
                     42: *  DPARAM (input/output)  DOUBLE PRECISION array, dimension 5
                     43: *     DPARAM(1)=DFLAG
                     44: *     DPARAM(2)=DH11
                     45: *     DPARAM(3)=DH21
                     46: *     DPARAM(4)=DH12
                     47: *     DPARAM(5)=DH22
                     48: *
                     49: *  =====================================================================
                     50: *
                     51: *     .. Local Scalars ..
                     52:       DOUBLE PRECISION DFLAG,DH11,DH12,DH21,DH22,DP1,DP2,DQ1,DQ2,DTEMP,
                     53:      +                 DU,GAM,GAMSQ,ONE,RGAMSQ,TWO,ZERO
                     54:       INTEGER IGO
                     55: *     ..
                     56: *     .. Intrinsic Functions ..
                     57:       INTRINSIC DABS
                     58: *     ..
                     59: *     .. Data statements ..
                     60: *
                     61:       DATA ZERO,ONE,TWO/0.D0,1.D0,2.D0/
                     62:       DATA GAM,GAMSQ,RGAMSQ/4096.D0,16777216.D0,5.9604645D-8/
                     63: *     ..
                     64: 
                     65:       IF (.NOT.DD1.LT.ZERO) GO TO 10
                     66: *       GO ZERO-H-D-AND-DX1..
                     67:       GO TO 60
                     68:    10 CONTINUE
                     69: *     CASE-DD1-NONNEGATIVE
                     70:       DP2 = DD2*DY1
                     71:       IF (.NOT.DP2.EQ.ZERO) GO TO 20
                     72:       DFLAG = -TWO
                     73:       GO TO 260
1.4       bertrand   74:    20 CONTINUE
1.1       bertrand   75: *     REGULAR-CASE..
                     76:       DP1 = DD1*DX1
                     77:       DQ2 = DP2*DY1
                     78:       DQ1 = DP1*DX1
                     79: *
                     80:       IF (.NOT.DABS(DQ1).GT.DABS(DQ2)) GO TO 40
                     81:       DH21 = -DY1/DX1
                     82:       DH12 = DP2/DP1
                     83: *
                     84:       DU = ONE - DH12*DH21
                     85: *
                     86:       IF (.NOT.DU.LE.ZERO) GO TO 30
                     87: *         GO ZERO-H-D-AND-DX1..
                     88:       GO TO 60
                     89:    30 CONTINUE
                     90:       DFLAG = ZERO
                     91:       DD1 = DD1/DU
                     92:       DD2 = DD2/DU
                     93:       DX1 = DX1*DU
                     94: *         GO SCALE-CHECK..
                     95:       GO TO 100
                     96:    40 CONTINUE
                     97:       IF (.NOT.DQ2.LT.ZERO) GO TO 50
                     98: *         GO ZERO-H-D-AND-DX1..
                     99:       GO TO 60
                    100:    50 CONTINUE
                    101:       DFLAG = ONE
                    102:       DH11 = DP1/DP2
                    103:       DH22 = DX1/DY1
                    104:       DU = ONE + DH11*DH22
                    105:       DTEMP = DD2/DU
                    106:       DD2 = DD1/DU
                    107:       DD1 = DTEMP
                    108:       DX1 = DY1*DU
                    109: *         GO SCALE-CHECK
                    110:       GO TO 100
1.4       bertrand  111:    60 CONTINUE
1.1       bertrand  112: *     PROCEDURE..ZERO-H-D-AND-DX1..
                    113:       DFLAG = -ONE
                    114:       DH11 = ZERO
                    115:       DH12 = ZERO
                    116:       DH21 = ZERO
                    117:       DH22 = ZERO
                    118: *
                    119:       DD1 = ZERO
                    120:       DD2 = ZERO
                    121:       DX1 = ZERO
                    122: *         RETURN..
                    123:       GO TO 220
1.4       bertrand  124:    70 CONTINUE
1.1       bertrand  125: *     PROCEDURE..FIX-H..
                    126:       IF (.NOT.DFLAG.GE.ZERO) GO TO 90
                    127: *
                    128:       IF (.NOT.DFLAG.EQ.ZERO) GO TO 80
                    129:       DH11 = ONE
                    130:       DH22 = ONE
                    131:       DFLAG = -ONE
                    132:       GO TO 90
                    133:    80 CONTINUE
                    134:       DH21 = -ONE
                    135:       DH12 = ONE
                    136:       DFLAG = -ONE
                    137:    90 CONTINUE
1.4       bertrand  138:       GO TO (150,180,210) IGO
                    139:       GO TO 120
                    140:   100 CONTINUE
1.1       bertrand  141: *     PROCEDURE..SCALE-CHECK
                    142:   110 CONTINUE
                    143:       IF (.NOT.DD1.LE.RGAMSQ) GO TO 130
                    144:       IF (DD1.EQ.ZERO) GO TO 160
1.4       bertrand  145:       IGO = 0
1.1       bertrand  146: *              FIX-H..
                    147:       GO TO 70
                    148:   120 CONTINUE
                    149:       DD1 = DD1*GAM**2
                    150:       DX1 = DX1/GAM
                    151:       DH11 = DH11/GAM
                    152:       DH12 = DH12/GAM
                    153:       GO TO 110
                    154:   130 CONTINUE
                    155:   140 CONTINUE
                    156:       IF (.NOT.DD1.GE.GAMSQ) GO TO 160
1.4       bertrand  157:       IGO = 1
1.1       bertrand  158: *              FIX-H..
                    159:       GO TO 70
                    160:   150 CONTINUE
                    161:       DD1 = DD1/GAM**2
                    162:       DX1 = DX1*GAM
                    163:       DH11 = DH11*GAM
                    164:       DH12 = DH12*GAM
                    165:       GO TO 140
                    166:   160 CONTINUE
                    167:   170 CONTINUE
                    168:       IF (.NOT.DABS(DD2).LE.RGAMSQ) GO TO 190
                    169:       IF (DD2.EQ.ZERO) GO TO 220
1.4       bertrand  170:       IGO = 2
1.1       bertrand  171: *              FIX-H..
                    172:       GO TO 70
                    173:   180 CONTINUE
                    174:       DD2 = DD2*GAM**2
                    175:       DH21 = DH21/GAM
                    176:       DH22 = DH22/GAM
                    177:       GO TO 170
                    178:   190 CONTINUE
                    179:   200 CONTINUE
                    180:       IF (.NOT.DABS(DD2).GE.GAMSQ) GO TO 220
1.4       bertrand  181:       IGO = 3
1.1       bertrand  182: *              FIX-H..
                    183:       GO TO 70
                    184:   210 CONTINUE
                    185:       DD2 = DD2/GAM**2
                    186:       DH21 = DH21*GAM
                    187:       DH22 = DH22*GAM
                    188:       GO TO 200
                    189:   220 CONTINUE
1.4       bertrand  190:       IF (DFLAG.LT.ZERO) THEN
                    191:          GO TO 250
                    192:       ELSE IF (DFLAG.EQ.ZERO) THEN
                    193:          GO TO 230 
                    194:       ELSE
                    195:          GO TO 240
                    196:       END IF
1.1       bertrand  197:   230 CONTINUE
                    198:       DPARAM(3) = DH21
                    199:       DPARAM(4) = DH12
                    200:       GO TO 260
                    201:   240 CONTINUE
                    202:       DPARAM(2) = DH11
                    203:       DPARAM(5) = DH22
                    204:       GO TO 260
                    205:   250 CONTINUE
                    206:       DPARAM(2) = DH11
                    207:       DPARAM(3) = DH21
                    208:       DPARAM(4) = DH12
                    209:       DPARAM(5) = DH22
                    210:   260 CONTINUE
                    211:       DPARAM(1) = DFLAG
                    212:       RETURN
                    213:       END

CVSweb interface <joel.bertrand@systella.fr>