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

◆ sckcsd()

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

SCKCSD

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