*DECK D1MPYQ
SUBROUTINE D1MPYQ (M, N, A, LDA, V, W)
C***BEGIN PROLOGUE D1MPYQ
C***SUBSIDIARY
C***PURPOSE Subsidiary to DNSQ and DNSQE
C***LIBRARY SLATEC
C***TYPE DOUBLE PRECISION (R1MPYQ-S, D1MPYQ-D)
C***AUTHOR (UNKNOWN)
C***DESCRIPTION
C
C Given an M by N matrix A, this subroutine computes A*Q where
C Q is the product of 2*(N - 1) transformations
C
C GV(N-1)*...*GV(1)*GW(1)*...*GW(N-1)
C
C and GV(I), GW(I) are Givens rotations in the (I,N) plane which
C eliminate elements in the I-th and N-th planes, respectively.
C Q itself is not given, rather the information to recover the
C GV, GW rotations is supplied.
C
C The SUBROUTINE statement is
C
C SUBROUTINE D1MPYQ(M,N,A,LDA,V,W)
C
C where
C
C M is a positive integer input variable set to the number
C of rows of A.
C
C N IS a positive integer input variable set to the number
C of columns of A.
C
C A is an M by N array. On input A must contain the matrix
C to be postmultiplied by the orthogonal matrix Q
C described above. On output A*Q has replaced A.
C
C LDA is a positive integer input variable not less than M
C which specifies the leading dimension of the array A.
C
C V is an input array of length N. V(I) must contain the
C information necessary to recover the Givens rotation GV(I)
C described above.
C
C W is an input array of length N. W(I) must contain the
C information necessary to recover the Givens rotation GW(I)
C described above.
C
C***SEE ALSO DNSQ, DNSQE
C***ROUTINES CALLED (NONE)
C***REVISION HISTORY (YYMMDD)
C 800301 DATE WRITTEN
C 890531 Changed all specific intrinsics to generic. (WRB)
C 890831 Modified array declarations. (WRB)
C 891214 Prologue converted to Version 4.0 format. (BAB)
C 900326 Removed duplicate information from DESCRIPTION section.
C (WRB)
C 900328 Added TYPE section. (WRB)
C***END PROLOGUE D1MPYQ
INTEGER I, J, LDA, M, N, NM1, NMJ
DOUBLE PRECISION A(LDA,*), COS, ONE, SIN, TEMP, V(*), W(*)
SAVE ONE
DATA ONE /1.0D0/
C
C APPLY THE FIRST SET OF GIVENS ROTATIONS TO A.
C
C***FIRST EXECUTABLE STATEMENT D1MPYQ
NM1 = N - 1
IF (NM1 .LT. 1) GO TO 50
DO 20 NMJ = 1, NM1
J = N - NMJ
IF (ABS(V(J)) .GT. ONE) COS = ONE/V(J)
IF (ABS(V(J)) .GT. ONE) SIN = SQRT(ONE-COS**2)
IF (ABS(V(J)) .LE. ONE) SIN = V(J)
IF (ABS(V(J)) .LE. ONE) COS = SQRT(ONE-SIN**2)
DO 10 I = 1, M
TEMP = COS*A(I,J) - SIN*A(I,N)
A(I,N) = SIN*A(I,J) + COS*A(I,N)
A(I,J) = TEMP
10 CONTINUE
20 CONTINUE
C
C APPLY THE SECOND SET OF GIVENS ROTATIONS TO A.
C
DO 40 J = 1, NM1
IF (ABS(W(J)) .GT. ONE) COS = ONE/W(J)
IF (ABS(W(J)) .GT. ONE) SIN = SQRT(ONE-COS**2)
IF (ABS(W(J)) .LE. ONE) SIN = W(J)
IF (ABS(W(J)) .LE. ONE) COS = SQRT(ONE-SIN**2)
DO 30 I = 1, M
TEMP = COS*A(I,J) + SIN*A(I,N)
A(I,N) = -SIN*A(I,J) + COS*A(I,N)
A(I,J) = TEMP
30 CONTINUE
40 CONTINUE
50 CONTINUE
RETURN
C
C LAST CARD OF SUBROUTINE D1MPYQ.
C
END