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