LAPACK 3.12.1
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches

◆ cckcsd()

subroutine cckcsd ( integer nm,
integer, dimension( * ) mval,
integer, dimension( * ) pval,
integer, dimension( * ) qval,
integer nmats,
integer, dimension( 4 ) iseed,
real thresh,
integer mmax,
complex, dimension( * ) x,
complex, dimension( * ) xf,
complex, dimension( * ) u1,
complex, dimension( * ) u2,
complex, dimension( * ) v1t,
complex, dimension( * ) v2t,
real, dimension( * ) theta,
integer, dimension( * ) iwork,
complex, dimension( * ) work,
real, dimension( * ) rwork,
integer nin,
integer nout,
integer info )

CCKCSD

Purpose:
!>
!> CCKCSD tests CUNCSD:
!>        the CSD for an M-by-M unitary matrix X partitioned as
!>        [ X11 X12; X21 X22 ]. X11 is P-by-Q.
!>
Parameters
[in]NM
!>          NM is INTEGER
!>          The number of values of M contained in the vector MVAL.
!>
[in]MVAL
!>          MVAL is INTEGER array, dimension (NM)
!>          The values of the matrix row dimension M.
!>
[in]PVAL
!>          PVAL is INTEGER array, dimension (NM)
!>          The values of the matrix row dimension P.
!>
[in]QVAL
!>          QVAL is INTEGER array, dimension (NM)
!>          The values of the matrix column dimension Q.
!>
[in]NMATS
!>          NMATS is INTEGER
!>          The number of matrix types to be tested for each combination
!>          of matrix dimensions.  If NMATS >= NTYPES (the maximum
!>          number of matrix types), then all the different types are
!>          generated for testing.  If NMATS < NTYPES, another input line
!>          is read to get the numbers of the matrix types to be used.
!>
[in,out]ISEED
!>          ISEED is INTEGER array, dimension (4)
!>          On entry, the seed of the random number generator.  The array
!>          elements should be between 0 and 4095, otherwise they will be
!>          reduced mod 4096, and ISEED(4) must be odd.
!>          On exit, the next seed in the random number sequence after
!>          all the test matrices have been generated.
!>
[in]THRESH
!>          THRESH is REAL
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]MMAX
!>          MMAX is INTEGER
!>          The maximum value permitted for M, used in dimensioning the
!>          work arrays.
!>
[out]X
!>          X is COMPLEX array, dimension (MMAX*MMAX)
!>
[out]XF
!>          XF is COMPLEX array, dimension (MMAX*MMAX)
!>
[out]U1
!>          U1 is COMPLEX array, dimension (MMAX*MMAX)
!>
[out]U2
!>          U2 is COMPLEX array, dimension (MMAX*MMAX)
!>
[out]V1T
!>          V1T is COMPLEX array, dimension (MMAX*MMAX)
!>
[out]V2T
!>          V2T is COMPLEX array, dimension (MMAX*MMAX)
!>
[out]THETA
!>          THETA is REAL array, dimension (MMAX)
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (MMAX)
!>
[out]WORK
!>          WORK is COMPLEX array
!>
[out]RWORK
!>          RWORK is REAL array
!>
[in]NIN
!>          NIN is INTEGER
!>          The unit number for input.
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The unit number for output.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0 :  successful exit
!>          > 0 :  If CLAROR returns an error code, the absolute value
!>                 of it is returned.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 181 of file cckcsd.f.

184*
185* -- LAPACK test routine --
186* -- LAPACK is a software package provided by Univ. of Tennessee, --
187* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
188*
189* .. Scalar Arguments ..
190 INTEGER INFO, NIN, NM, NMATS, MMAX, NOUT
191 REAL THRESH
192* ..
193* .. Array Arguments ..
194 INTEGER ISEED( 4 ), IWORK( * ), MVAL( * ), PVAL( * ),
195 $ QVAL( * )
196 REAL RWORK( * ), THETA( * )
197 COMPLEX U1( * ), U2( * ), V1T( * ), V2T( * ),
198 $ WORK( * ), X( * ), XF( * )
199* ..
200*
201* =====================================================================
202*
203* .. Parameters ..
204 INTEGER NTESTS
205 parameter( ntests = 15 )
206 INTEGER NTYPES
207 parameter( ntypes = 4 )
208 REAL GAPDIGIT, ORTH, REALONE, REALZERO, TEN
209 parameter( gapdigit = 10.0e0, orth = 1.0e-4,
210 $ realone = 1.0e0, realzero = 0.0e0,
211 $ ten = 10.0e0 )
212 COMPLEX ONE, ZERO
213 parameter( one = (1.0e0,0.0e0), zero = (0.0e0,0.0e0) )
214 REAL PIOVER2
215 parameter( piover2 = 1.57079632679489661923132169163975144210e0 )
216* ..
217* .. Local Scalars ..
218 LOGICAL FIRSTT
219 CHARACTER*3 PATH
220 INTEGER I, IINFO, IM, IMAT, J, LDU1, LDU2, LDV1T,
221 $ LDV2T, LDX, LWORK, M, NFAIL, NRUN, NT, P, Q, R
222* ..
223* .. Local Arrays ..
224 LOGICAL DOTYPE( NTYPES )
225 REAL RESULT( NTESTS )
226* ..
227* .. External Subroutines ..
228 EXTERNAL alahdg, alareq, alasum, ccsdts, clacsg, claror,
229 $ claset, csrot
230* ..
231* .. Intrinsic Functions ..
232 INTRINSIC abs, min
233* ..
234* .. External Functions ..
235 REAL SLARAN, SLARND
236 EXTERNAL slaran, slarnd
237* ..
238* .. Executable Statements ..
239*
240* Initialize constants and the random number seed.
241*
242 path( 1: 3 ) = 'CSD'
243 info = 0
244 nrun = 0
245 nfail = 0
246 firstt = .true.
247 CALL alareq( path, nmats, dotype, ntypes, nin, nout )
248 ldx = mmax
249 ldu1 = mmax
250 ldu2 = mmax
251 ldv1t = mmax
252 ldv2t = mmax
253 lwork = mmax*mmax
254*
255* Do for each value of M in MVAL.
256*
257 DO 30 im = 1, nm
258 m = mval( im )
259 p = pval( im )
260 q = qval( im )
261*
262 DO 20 imat = 1, ntypes
263*
264* Do the tests only if DOTYPE( IMAT ) is true.
265*
266 IF( .NOT.dotype( imat ) )
267 $ GO TO 20
268*
269* Generate X
270*
271 IF( imat.EQ.1 ) THEN
272 CALL claror( 'L', 'I', m, m, x, ldx, iseed, work, iinfo )
273 IF( m .NE. 0 .AND. iinfo .NE. 0 ) THEN
274 WRITE( nout, fmt = 9999 ) m, iinfo
275 info = abs( iinfo )
276 GO TO 20
277 END IF
278 ELSE IF( imat.EQ.2 ) THEN
279 r = min( p, m-p, q, m-q )
280 DO i = 1, r
281 theta(i) = piover2 * slarnd( 1, iseed )
282 END DO
283 CALL clacsg( m, p, q, theta, iseed, x, ldx, work )
284 DO i = 1, m
285 DO j = 1, m
286 x(i+(j-1)*ldx) = x(i+(j-1)*ldx) +
287 $ orth*slarnd(2,iseed)
288 END DO
289 END DO
290 ELSE IF( imat.EQ.3 ) THEN
291 r = min( p, m-p, q, m-q )
292 DO i = 1, r+1
293 theta(i) = ten**(-slarnd(1,iseed)*gapdigit)
294 END DO
295 DO i = 2, r+1
296 theta(i) = theta(i-1) + theta(i)
297 END DO
298 DO i = 1, r
299 theta(i) = piover2 * theta(i) / theta(r+1)
300 END DO
301 CALL clacsg( m, p, q, theta, iseed, x, ldx, work )
302 ELSE
303 CALL claset( 'F', m, m, zero, one, x, ldx )
304 DO i = 1, m
305 j = int( slaran( iseed ) * m ) + 1
306 IF( j .NE. i ) THEN
307 CALL csrot( m, x(1+(i-1)*ldx), 1, x(1+(j-1)*ldx),
308 $ 1, realzero, realone )
309 END IF
310 END DO
311 END IF
312*
313 nt = 15
314*
315 CALL ccsdts( m, p, q, x, xf, ldx, u1, ldu1, u2, ldu2, v1t,
316 $ ldv1t, v2t, ldv2t, theta, iwork, work, lwork,
317 $ rwork, result )
318*
319* Print information about the tests that did not
320* pass the threshold.
321*
322 DO 10 i = 1, nt
323 IF( result( i ).GE.thresh ) THEN
324 IF( nfail.EQ.0 .AND. firstt ) THEN
325 firstt = .false.
326 CALL alahdg( nout, path )
327 END IF
328 WRITE( nout, fmt = 9998 )m, p, q, imat, i,
329 $ result( i )
330 nfail = nfail + 1
331 END IF
332 10 CONTINUE
333 nrun = nrun + nt
334 20 CONTINUE
335 30 CONTINUE
336*
337* Print a summary of the results.
338*
339 CALL alasum( path, nout, nfail, nrun, 0 )
340*
341 9999 FORMAT( ' CLAROR in CCKCSD: M = ', i5, ', INFO = ', i15 )
342 9998 FORMAT( ' M=', i4, ' P=', i4, ', Q=', i4, ', type ', i2,
343 $ ', test ', i2, ', ratio=', g13.6 )
344 RETURN
345*
346* End of CCKCSD
347*
alareq
subroutine alareq(path, nmats, dotype, ntypes, nin, nout)
ALAREQ
Definition alareq.f:90
alasum
subroutine alasum(type, nout, nfail, nrun, nerrs)
ALASUM
Definition alasum.f:73
alahdg
subroutine alahdg(iounit, path)
ALAHDG
Definition alahdg.f:62
clacsg
subroutine clacsg(m, p, q, theta, iseed, x, ldx, work)
Definition cckcsd.f:353
ccsdts
subroutine ccsdts(m, p, q, x, xf, ldx, u1, ldu1, u2, ldu2, v1t, ldv1t, v2t, ldv2t, theta, iwork, work, lwork, rwork, result)
CCSDTS
Definition ccsdts.f:229
claror
subroutine claror(side, init, m, n, a, lda, iseed, x, info)
CLAROR
Definition claror.f:158
claset
subroutine claset(uplo, m, n, alpha, beta, a, lda)
CLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values.
Definition claset.f:104
csrot
subroutine csrot(n, cx, incx, cy, incy, c, s)
CSROT
Definition csrot.f:98
slaran
real function slaran(iseed)
SLARAN
Definition slaran.f:67
slarnd
real function slarnd(idist, iseed)
SLARND
Definition slarnd.f:73
Here is the call graph for this function:
Here is the caller graph for this function: