sckcsd.f File Reference

Go to the source code of this file.

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

Function/Subroutine Documentation

slacsg()

subroutine slacsg	(	integer	m,
		integer	p,
		integer	q,
		real, dimension( * )	theta,
		integer, dimension( 4 )	iseed,
		real, dimension( ldx, * )	x,
		integer	ldx,
		real, dimension( * )	work )

Definition at line 349 of file sckcsd.f.

      IMPLICIT NONE
*
      INTEGER            LDX, M, P, Q
      INTEGER            ISEED( 4 )
      REAL               THETA( * )
      REAL               WORK( * ), X( LDX, * )
*
      REAL               ONE, ZERO
      parameter( one = 1.0e0, zero = 0.0e0 )
*
      INTEGER            I, INFO, R
*
      r = min( p, m-p, q, m-q )
*
      CALL slaset( '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 slaror( 'Left', 'No init', p, m, x, ldx, iseed, work, info )
      CALL slaror( 'Left', 'No init', m-p, m, x(p+1,1), ldx,
     $             iseed, work, info )
      CALL slaror( 'Right', 'No init', m, q, x, ldx, iseed,
     $             work, info )
      CALL slaror( 'Right', 'No init', m, m-q,
     $             x(1,q+1), ldx, iseed, work, info )
*