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

◆ dckcsd()

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

DCKCSD

Purpose:
!>
!> DCKCSD tests DORCSD:
!>        the CSD for an M-by-M orthogonal 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 DOUBLE PRECISION
!>          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 DOUBLE PRECISION array, dimension (MMAX*MMAX)
!>
[out]XF
!>          XF is DOUBLE PRECISION array, dimension (MMAX*MMAX)
!>
[out]U1
!>          U1 is DOUBLE PRECISION array, dimension (MMAX*MMAX)
!>
[out]U2
!>          U2 is DOUBLE PRECISION array, dimension (MMAX*MMAX)
!>
[out]V1T
!>          V1T is DOUBLE PRECISION array, dimension (MMAX*MMAX)
!>
[out]V2T
!>          V2T is DOUBLE PRECISION array, dimension (MMAX*MMAX)
!>
[out]THETA
!>          THETA is DOUBLE PRECISION array, dimension (MMAX)
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (MMAX)
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION 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 DLAROR 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 dckcsd.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 DOUBLE PRECISION THRESH
192* ..
193* .. Array Arguments ..
194 INTEGER ISEED( 4 ), IWORK( * ), MVAL( * ), PVAL( * ),
195 $ QVAL( * )
196 DOUBLE PRECISION RWORK( * ), THETA( * )
197 DOUBLE PRECISION 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 DOUBLE PRECISION GAPDIGIT, ONE, ORTH, TEN, ZERO
209 parameter( gapdigit = 18.0d0, one = 1.0d0,
210 $ orth = 1.0d-12,
211 $ ten = 10.0d0, zero = 0.0d0 )
212 DOUBLE PRECISION PIOVER2
213 parameter( piover2 = 1.57079632679489661923132169163975144210d0 )
214* ..
215* .. Local Scalars ..
216 LOGICAL FIRSTT
217 CHARACTER*3 PATH
218 INTEGER I, IINFO, IM, IMAT, J, LDU1, LDU2, LDV1T,
219 $ LDV2T, LDX, LWORK, M, NFAIL, NRUN, NT, P, Q, R
220* ..
221* .. Local Arrays ..
222 LOGICAL DOTYPE( NTYPES )
223 DOUBLE PRECISION RESULT( NTESTS )
224* ..
225* .. External Subroutines ..
226 EXTERNAL alahdg, alareq, alasum, dcsdts, dlacsg, dlaror,
227 $ dlaset, drot
228* ..
229* .. Intrinsic Functions ..
230 INTRINSIC abs, min
231* ..
232* .. External Functions ..
233 DOUBLE PRECISION DLARAN, DLARND
234 EXTERNAL dlaran, dlarnd
235* ..
236* .. Executable Statements ..
237*
238* Initialize constants and the random number seed.
239*
240 path( 1: 3 ) = 'CSD'
241 info = 0
242 nrun = 0
243 nfail = 0
244 firstt = .true.
245 CALL alareq( path, nmats, dotype, ntypes, nin, nout )
246 ldx = mmax
247 ldu1 = mmax
248 ldu2 = mmax
249 ldv1t = mmax
250 ldv2t = mmax
251 lwork = mmax*mmax
252*
253* Do for each value of M in MVAL.
254*
255 DO 30 im = 1, nm
256 m = mval( im )
257 p = pval( im )
258 q = qval( im )
259*
260 DO 20 imat = 1, ntypes
261*
262* Do the tests only if DOTYPE( IMAT ) is true.
263*
264 IF( .NOT.dotype( imat ) )
265 $ GO TO 20
266*
267* Generate X
268*
269 IF( imat.EQ.1 ) THEN
270 CALL dlaror( 'L', 'I', m, m, x, ldx, iseed, work, iinfo )
271 IF( m .NE. 0 .AND. iinfo .NE. 0 ) THEN
272 WRITE( nout, fmt = 9999 ) m, iinfo
273 info = abs( iinfo )
274 GO TO 20
275 END IF
276 ELSE IF( imat.EQ.2 ) THEN
277 r = min( p, m-p, q, m-q )
278 DO i = 1, r
279 theta(i) = piover2 * dlarnd( 1, iseed )
280 END DO
281 CALL dlacsg( m, p, q, theta, iseed, x, ldx, work )
282 DO i = 1, m
283 DO j = 1, m
284 x(i+(j-1)*ldx) = x(i+(j-1)*ldx) +
285 $ orth*dlarnd(2,iseed)
286 END DO
287 END DO
288 ELSE IF( imat.EQ.3 ) THEN
289 r = min( p, m-p, q, m-q )
290 DO i = 1, r+1
291 theta(i) = ten**(-dlarnd(1,iseed)*gapdigit)
292 END DO
293 DO i = 2, r+1
294 theta(i) = theta(i-1) + theta(i)
295 END DO
296 DO i = 1, r
297 theta(i) = piover2 * theta(i) / theta(r+1)
298 END DO
299 CALL dlacsg( m, p, q, theta, iseed, x, ldx, work )
300 ELSE
301 CALL dlaset( 'F', m, m, zero, one, x, ldx )
302 DO i = 1, m
303 j = int( dlaran( iseed ) * m ) + 1
304 IF( j .NE. i ) THEN
305 CALL drot( m, x(1+(i-1)*ldx), 1, x(1+(j-1)*ldx), 1,
306 $ zero, one )
307 END IF
308 END DO
309 END IF
310*
311 nt = 15
312*
313 CALL dcsdts( m, p, q, x, xf, ldx, u1, ldu1, u2, ldu2, v1t,
314 $ ldv1t, v2t, ldv2t, theta, iwork, work, lwork,
315 $ rwork, result )
316*
317* Print information about the tests that did not
318* pass the threshold.
319*
320 DO 10 i = 1, nt
321 IF( result( i ).GE.thresh ) THEN
322 IF( nfail.EQ.0 .AND. firstt ) THEN
323 firstt = .false.
324 CALL alahdg( nout, path )
325 END IF
326 WRITE( nout, fmt = 9998 )m, p, q, imat, i,
327 $ result( i )
328 nfail = nfail + 1
329 END IF
330 10 CONTINUE
331 nrun = nrun + nt
332 20 CONTINUE
333 30 CONTINUE
334*
335* Print a summary of the results.
336*
337 CALL alasum( path, nout, nfail, nrun, 0 )
338*
339 9999 FORMAT( ' DLAROR in DCKCSD: M = ', i5, ', INFO = ', i15 )
340 9998 FORMAT( ' M=', i4, ' P=', i4, ', Q=', i4, ', type ', i2,
341 $ ', test ', i2, ', ratio=', g13.6 )
342 RETURN
343*
344* End of DCKCSD
345*
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
dlacsg
subroutine dlacsg(m, p, q, theta, iseed, x, ldx, work)
Definition dckcsd.f:351
dcsdts
subroutine dcsdts(m, p, q, x, xf, ldx, u1, ldu1, u2, ldu2, v1t, ldv1t, v2t, ldv2t, theta, iwork, work, lwork, rwork, result)
DCSDTS
Definition dcsdts.f:229
dlaran
double precision function dlaran(iseed)
DLARAN
Definition dlaran.f:67
dlarnd
double precision function dlarnd(idist, iseed)
DLARND
Definition dlarnd.f:73
dlaror
subroutine dlaror(side, init, m, n, a, lda, iseed, x, info)
DLAROR
Definition dlaror.f:146
dlaset
subroutine dlaset(uplo, m, n, alpha, beta, a, lda)
DLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values.
Definition dlaset.f:108
drot
subroutine drot(n, dx, incx, dy, incy, c, s)
DROT
Definition drot.f:92
Here is the call graph for this function:
Here is the caller graph for this function: