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

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: *
                     36: *  DD2    (input/output) DOUBLE PRECISION 
                     37: *
                     38: *  DX1    (input/output) DOUBLE PRECISION 
                     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
                     74: *     REGULAR-CASE..
                     75:    20 CONTINUE
                     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
                    111: *     PROCEDURE..ZERO-H-D-AND-DX1..
                    112:    60 CONTINUE
                    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
                    124: *     PROCEDURE..FIX-H..
                    125:    70 CONTINUE
                    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
                    138:       GO TO IGO(120,150,180,210)
                    139: *     PROCEDURE..SCALE-CHECK
                    140:   100 CONTINUE
                    141:   110 CONTINUE
                    142:       IF (.NOT.DD1.LE.RGAMSQ) GO TO 130
                    143:       IF (DD1.EQ.ZERO) GO TO 160
                    144:       ASSIGN 120 TO IGO
                    145: *              FIX-H..
                    146:       GO TO 70
                    147:   120 CONTINUE
                    148:       DD1 = DD1*GAM**2
                    149:       DX1 = DX1/GAM
                    150:       DH11 = DH11/GAM
                    151:       DH12 = DH12/GAM
                    152:       GO TO 110
                    153:   130 CONTINUE
                    154:   140 CONTINUE
                    155:       IF (.NOT.DD1.GE.GAMSQ) GO TO 160
                    156:       ASSIGN 150 TO IGO
                    157: *              FIX-H..
                    158:       GO TO 70
                    159:   150 CONTINUE
                    160:       DD1 = DD1/GAM**2
                    161:       DX1 = DX1*GAM
                    162:       DH11 = DH11*GAM
                    163:       DH12 = DH12*GAM
                    164:       GO TO 140
                    165:   160 CONTINUE
                    166:   170 CONTINUE
                    167:       IF (.NOT.DABS(DD2).LE.RGAMSQ) GO TO 190
                    168:       IF (DD2.EQ.ZERO) GO TO 220
                    169:       ASSIGN 180 TO IGO
                    170: *              FIX-H..
                    171:       GO TO 70
                    172:   180 CONTINUE
                    173:       DD2 = DD2*GAM**2
                    174:       DH21 = DH21/GAM
                    175:       DH22 = DH22/GAM
                    176:       GO TO 170
                    177:   190 CONTINUE
                    178:   200 CONTINUE
                    179:       IF (.NOT.DABS(DD2).GE.GAMSQ) GO TO 220
                    180:       ASSIGN 210 TO IGO
                    181: *              FIX-H..
                    182:       GO TO 70
                    183:   210 CONTINUE
                    184:       DD2 = DD2/GAM**2
                    185:       DH21 = DH21*GAM
                    186:       DH22 = DH22*GAM
                    187:       GO TO 200
                    188:   220 CONTINUE
                    189:       IF (DFLAG) 250,230,240
                    190:   230 CONTINUE
                    191:       DPARAM(3) = DH21
                    192:       DPARAM(4) = DH12
                    193:       GO TO 260
                    194:   240 CONTINUE
                    195:       DPARAM(2) = DH11
                    196:       DPARAM(5) = DH22
                    197:       GO TO 260
                    198:   250 CONTINUE
                    199:       DPARAM(2) = DH11
                    200:       DPARAM(3) = DH21
                    201:       DPARAM(4) = DH12
                    202:       DPARAM(5) = DH22
                    203:   260 CONTINUE
                    204:       DPARAM(1) = DFLAG
                    205:       RETURN
                    206:       END

CVSweb interface <joel.bertrand@systella.fr>