dckcsd.f File Reference

Go to the source code of this file.

Functions/Subroutines
subroutine	dckcsd (nm, mval, pval, qval, nmats, iseed, thresh, mmax, x, xf, u1, u2, v1t, v2t, theta, iwork, work, rwork, nin, nout, info)
	DCKCSD
subroutine	dlacsg (m, p, q, theta, iseed, x, ldx, work)

Function/Subroutine Documentation

dlacsg()

subroutine dlacsg	(	integer	m,
		integer	p,
		integer	q,
		double precision, dimension( * )	theta,
		integer, dimension( 4 )	iseed,
		double precision, dimension( ldx, * )	x,
		integer	ldx,
		double precision, dimension( * )	work )

Definition at line 350 of file dckcsd.f.

      IMPLICIT NONE
*
      INTEGER            LDX, M, P, Q
      INTEGER            ISEED( 4 )
      DOUBLE PRECISION   THETA( * )
      DOUBLE PRECISION   WORK( * ), X( LDX, * )
*
      DOUBLE PRECISION   ONE, ZERO
      parameter( one = 1.0d0, zero = 0.0d0 )
*
      INTEGER            I, INFO, R
*
      r = min( p, m-p, q, m-q )
*
      CALL dlaset( 'Full', m, m, zero, zero, x, ldx )
*
      DO i = 1, min(p,q)-r
         x(i,i) = one
      END DO
      DO i = 1, r
         x(min(p,q)-r+i,min(p,q)-r+i) = cos(theta(i))
      END DO
      DO i = 1, min(p,m-q)-r
         x(p-i+1,m-i+1) = -one
      END DO
      DO i = 1, r
         x(p-(min(p,m-q)-r)+1-i,m-(min(p,m-q)-r)+1-i) =
     $      -sin(theta(r-i+1))
      END DO
      DO i = 1, min(m-p,q)-r
         x(m-i+1,q-i+1) = one
      END DO
      DO i = 1, r
         x(m-(min(m-p,q)-r)+1-i,q-(min(m-p,q)-r)+1-i) =
     $      sin(theta(r-i+1))
      END DO
      DO i = 1, min(m-p,m-q)-r
         x(p+i,q+i) = one
      END DO
      DO i = 1, r
         x(p+(min(m-p,m-q)-r)+i,q+(min(m-p,m-q)-r)+i) =
     $      cos(theta(i))
      END DO
      CALL dlaror( 'Left', 'No init', p, m, x, ldx, iseed, work, info )
      CALL dlaror( 'Left', 'No init', m-p, m, x(p+1,1), ldx,
     $             iseed, work, info )
      CALL dlaror( 'Right', 'No init', m, q, x, ldx, iseed,
     $             work, info )
      CALL dlaror( 'Right', 'No init', m, m-q,
     $             x(1,q+1), ldx, iseed, work, info )
*