cckcsd.f File Reference

Go to the source code of this file.

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

Function/Subroutine Documentation

clacsg()

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

Definition at line 352 of file cckcsd.f.

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