LAPACK  3.7.1
LAPACK: Linear Algebra PACKage

◆ cdrvls()

subroutine cdrvls ( logical, dimension( * )  DOTYPE,
integer  NM,
integer, dimension( * )  MVAL,
integer  NN,
integer, dimension( * )  NVAL,
integer  NNS,
integer, dimension( * )  NSVAL,
integer  NNB,
integer, dimension( * )  NBVAL,
integer, dimension( * )  NXVAL,
real  THRESH,
logical  TSTERR,
complex, dimension( * )  A,
complex, dimension( * )  COPYA,
complex, dimension( * )  B,
complex, dimension( * )  COPYB,
complex, dimension( * )  C,
real, dimension( * )  S,
real, dimension( * )  COPYS,
integer  NOUT 
)

CDRVLS

Purpose: 
 CDRVLS tests the least squares driver routines CGELS, CGETSLS, CGELSS, CGELSY
 and CGELSD.
Parameters
[in]DOTYPE
          DOTYPE is LOGICAL array, dimension (NTYPES)
          The matrix types to be used for testing.  Matrices of type j
          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
          The matrix of type j is generated as follows:
          j=1: A = U*D*V where U and V are random unitary matrices
               and D has random entries (> 0.1) taken from a uniform
               distribution (0,1). A is full rank.
          j=2: The same of 1, but A is scaled up.
          j=3: The same of 1, but A is scaled down.
          j=4: A = U*D*V where U and V are random unitary matrices
               and D has 3*min(M,N)/4 random entries (> 0.1) taken
               from a uniform distribution (0,1) and the remaining
               entries set to 0. A is rank-deficient.
          j=5: The same of 4, but A is scaled up.
          j=6: The same of 5, but A is scaled down.
[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]NN
          NN is INTEGER
          The number of values of N contained in the vector NVAL.
[in]NVAL
          NVAL is INTEGER array, dimension (NN)
          The values of the matrix column dimension N.
[in]NNB
          NNB is INTEGER
          The number of values of NB and NX contained in the
          vectors NBVAL and NXVAL.  The blocking parameters are used
          in pairs (NB,NX).
[in]NBVAL
          NBVAL is INTEGER array, dimension (NNB)
          The values of the blocksize NB.
[in]NXVAL
          NXVAL is INTEGER array, dimension (NNB)
          The values of the crossover point NX.
[in]NNS
          NNS is INTEGER
          The number of values of NRHS contained in the vector NSVAL.
[in]NSVAL
          NSVAL is INTEGER array, dimension (NNS)
          The values of the number of right hand sides NRHS.
[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]TSTERR
          TSTERR is LOGICAL
          Flag that indicates whether error exits are to be tested.
[out]A
          A is COMPLEX array, dimension (MMAX*NMAX)
          where MMAX is the maximum value of M in MVAL and NMAX is the
          maximum value of N in NVAL.
[out]COPYA
          COPYA is COMPLEX array, dimension (MMAX*NMAX)
[out]B
          B is COMPLEX array, dimension (MMAX*NSMAX)
          where MMAX is the maximum value of M in MVAL and NSMAX is the
          maximum value of NRHS in NSVAL.
[out]COPYB
          COPYB is COMPLEX array, dimension (MMAX*NSMAX)
[out]C
          C is COMPLEX array, dimension (MMAX*NSMAX)
[out]S
          S is REAL array, dimension
                      (min(MMAX,NMAX))
[out]COPYS
          COPYS is REAL array, dimension
                      (min(MMAX,NMAX))
[in]NOUT
          NOUT is INTEGER
          The unit number for output.
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Date
June 2017

Definition at line 194 of file cdrvls.f.

194 *
195 * -- LAPACK test routine (version 3.7.1) --
196 * -- LAPACK is a software package provided by Univ. of Tennessee, --
197 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
198 * June 2017
199 *
200 * .. Scalar Arguments ..
201  LOGICAL tsterr
202  INTEGER nm, nn, nnb, nns, nout
203  REAL thresh
204 * ..
205 * .. Array Arguments ..
206  LOGICAL dotype( * )
207  INTEGER mval( * ), nbval( * ), nsval( * ),
208  $ nval( * ), nxval( * )
209  REAL copys( * ), s( * )
210  COMPLEX a( * ), b( * ), c( * ), copya( * ), copyb( * )
211 * ..
212 *
213 * =====================================================================
214 *
215 * .. Parameters ..
216  INTEGER ntests
217  parameter( ntests = 16 )
218  INTEGER smlsiz
219  parameter( smlsiz = 25 )
220  REAL one, zero
221  parameter( one = 1.0e+0, zero = 0.0e+0 )
222  COMPLEX cone, czero
223  parameter( cone = ( 1.0e+0, 0.0e+0 ),
224  $ czero = ( 0.0e+0, 0.0e+0 ) )
225 * ..
226 * .. Local Scalars ..
227  CHARACTER trans
228  CHARACTER*3 path
229  INTEGER crank, i, im, imb, in, inb, info, ins, irank,
230  $ iscale, itran, itype, j, k, lda, ldb, ldwork,
231  $ lwlsy, lwork, m, mnmin, n, nb, ncols, nerrs,
232  $ nfail, nrhs, nrows, nrun, rank, mb,
233  $ mmax, nmax, nsmax, liwork, lrwork,
234  $ lwork_cgels, lwork_cgetsls, lwork_cgelss,
235  $ lwork_cgelsy, lwork_cgelsd,
236  $ lrwork_cgelsy, lrwork_cgelss, lrwork_cgelsd
237  REAL eps, norma, normb, rcond
238 * ..
239 * .. Local Arrays ..
240  INTEGER iseed( 4 ), iseedy( 4 ), iwq
241  REAL result( ntests ), rwq
242  COMPLEX wq
243 * ..
244 * .. Allocatable Arrays ..
245  COMPLEX, ALLOCATABLE :: work (:)
246  REAL, ALLOCATABLE :: rwork (:)
247  INTEGER, ALLOCATABLE :: iwork (:)
248 * ..
249 * .. External Functions ..
250  REAL cqrt12, cqrt14, cqrt17, sasum, slamch
251  EXTERNAL cqrt12, cqrt14, cqrt17, sasum, slamch
252 * ..
253 * .. External Subroutines ..
254  EXTERNAL alaerh, alahd, alasvm, cerrls, cgels, cgelsd,
255  $ cgelss, cgelsy, cgemm, cgetsls, clacpy,
256  $ clarnv, cqrt13, cqrt15, cqrt16, csscal,
257  $ saxpy, xlaenv
258 * ..
259 * .. Intrinsic Functions ..
260  INTRINSIC max, min, int, REAL, sqrt
261 * ..
262 * .. Scalars in Common ..
263  LOGICAL lerr, ok
264  CHARACTER*32 srnamt
265  INTEGER infot, iounit
266 * ..
267 * .. Common blocks ..
268  COMMON / infoc / infot, iounit, ok, lerr
269  COMMON / srnamc / srnamt
270 * ..
271 * .. Data statements ..
272  DATA iseedy / 1988, 1989, 1990, 1991 /
273 * ..
274 * .. Executable Statements ..
275 *
276 * Initialize constants and the random number seed.
277 *
278  path( 1: 1 ) = 'Complex precision'
279  path( 2: 3 ) = 'LS'
280  nrun = 0
281  nfail = 0
282  nerrs = 0
283  DO 10 i = 1, 4
284  iseed( i ) = iseedy( i )
285  10 CONTINUE
286  eps = slamch( 'Epsilon' )
287 *
288 * Threshold for rank estimation
289 *
290  rcond = sqrt( eps ) - ( sqrt( eps )-eps ) / 2
291 *
292 * Test the error exits
293 *
294  CALL xlaenv( 9, smlsiz )
295  IF( tsterr )
296  $ CALL cerrls( path, nout )
297 *
298 * Print the header if NM = 0 or NN = 0 and THRESH = 0.
299 *
300  IF( ( nm.EQ.0 .OR. nn.EQ.0 ) .AND. thresh.EQ.zero )
301  $ CALL alahd( nout, path )
302  infot = 0
303 *
304 * Compute maximal workspace needed for all routines
305 *
306  nmax = 0
307  mmax = 0
308  nsmax = 0
309  DO i = 1, nm
310  IF ( mval( i ).GT.mmax ) THEN
311  mmax = mval( i )
312  END IF
313  ENDDO
314  DO i = 1, nn
315  IF ( nval( i ).GT.nmax ) THEN
316  nmax = nval( i )
317  END IF
318  ENDDO
319  DO i = 1, nns
320  IF ( nsval( i ).GT.nsmax ) THEN
321  nsmax = nsval( i )
322  END IF
323  ENDDO
324  m = mmax
325  n = nmax
326  nrhs = nsmax
327  mnmin = max( min( m, n ), 1 )
328 *
329 * Compute workspace needed for routines
330 * CQRT14, CQRT17 (two side cases), CQRT15 and CQRT12
331 *
332  lwork = max( 1, ( m+n )*nrhs,
333  $ ( n+nrhs )*( m+2 ), ( m+nrhs )*( n+2 ),
334  $ max( m+mnmin, nrhs*mnmin,2*n+m ),
335  $ max( m*n+4*mnmin+max(m,n), m*n+2*mnmin+4*n ) )
336  lrwork = 1
337  liwork = 1
338 *
339 * Iterate through all test cases and compute necessary workspace
340 * sizes for ?GELS, ?GETSLS, ?GELSY, ?GELSS and ?GELSD routines.
341 *
342  DO im = 1, nm
343  m = mval( im )
344  lda = max( 1, m )
345  DO in = 1, nn
346  n = nval( in )
347  mnmin = max(min( m, n ),1)
348  ldb = max( 1, m, n )
349  DO ins = 1, nns
350  nrhs = nsval( ins )
351  DO irank = 1, 2
352  DO iscale = 1, 3
353  itype = ( irank-1 )*3 + iscale
354  IF( dotype( itype ) ) THEN
355  IF( irank.EQ.1 ) THEN
356  DO itran = 1, 2
357  IF( itran.EQ.1 ) THEN
358  trans = 'N'
359  ELSE
360  trans = 'C'
361  END IF
362 *
363 * Compute workspace needed for CGELS
364  CALL cgels( trans, m, n, nrhs, a, lda,
365  $ b, ldb, wq, -1, info )
366  lwork_cgels = int( wq )
367 * Compute workspace needed for CGETSLS
368  CALL cgetsls( trans, m, n, nrhs, a, lda,
369  $ b, ldb, wq, -1, info )
370  lwork_cgetsls = int( wq )
371  ENDDO
372  END IF
373 * Compute workspace needed for CGELSY
374  CALL cgelsy( m, n, nrhs, a, lda, b, ldb,
375  $ iwq, rcond, crank, wq, -1, rwork,
376  $ info )
377  lwork_cgelsy = int( wq )
378  lrwork_cgelsy = 2*n
379 * Compute workspace needed for CGELSS
380  CALL cgelss( m, n, nrhs, a, lda, b, ldb, s,
381  $ rcond, crank, wq, -1, rwork, info )
382  lwork_cgelss = int( wq )
383  lrwork_cgelss = 5*mnmin
384 * Compute workspace needed for CGELSD
385  CALL cgelsd( m, n, nrhs, a, lda, b, ldb, s,
386  $ rcond, crank, wq, -1, rwq, iwq,
387  $ info )
388  lwork_cgelsd = int( wq )
389  lrwork_cgelsd = int( rwq )
390 * Compute LIWORK workspace needed for CGELSY and CGELSD
391  liwork = max( liwork, n, iwq )
392 * Compute LRWORK workspace needed for CGELSY, CGELSS and CGELSD
393  lrwork = max( lrwork, lrwork_cgelsy,
394  $ lrwork_cgelss, lrwork_cgelsd )
395 * Compute LWORK workspace needed for all functions
396  lwork = max( lwork, lwork_cgels, lwork_cgetsls,
397  $ lwork_cgelsy, lwork_cgelss,
398  $ lwork_cgelsd )
399  END IF
400  ENDDO
401  ENDDO
402  ENDDO
403  ENDDO
404  ENDDO
405 *
406  lwlsy = lwork
407 *
408  ALLOCATE( work( lwork ) )
409  ALLOCATE( iwork( liwork ) )
410  ALLOCATE( rwork( lrwork ) )
411 *
412  DO 140 im = 1, nm
413  m = mval( im )
414  lda = max( 1, m )
415 *
416  DO 130 in = 1, nn
417  n = nval( in )
418  mnmin = max(min( m, n ),1)
419  ldb = max( 1, m, n )
420  mb = (mnmin+1)
421 *
422  DO 120 ins = 1, nns
423  nrhs = nsval( ins )
424 *
425  DO 110 irank = 1, 2
426  DO 100 iscale = 1, 3
427  itype = ( irank-1 )*3 + iscale
428  IF( .NOT.dotype( itype ) )
429  $ GO TO 100
430 *
431  IF( irank.EQ.1 ) THEN
432 *
433 * Test CGELS
434 *
435 * Generate a matrix of scaling type ISCALE
436 *
437  CALL cqrt13( iscale, m, n, copya, lda, norma,
438  $ iseed )
439  DO 40 inb = 1, nnb
440  nb = nbval( inb )
441  CALL xlaenv( 1, nb )
442  CALL xlaenv( 3, nxval( inb ) )
443 *
444  DO 30 itran = 1, 2
445  IF( itran.EQ.1 ) THEN
446  trans = 'N'
447  nrows = m
448  ncols = n
449  ELSE
450  trans = 'C'
451  nrows = n
452  ncols = m
453  END IF
454  ldwork = max( 1, ncols )
455 *
456 * Set up a consistent rhs
457 *
458  IF( ncols.GT.0 ) THEN
459  CALL clarnv( 2, iseed, ncols*nrhs,
460  $ work )
461  CALL csscal( ncols*nrhs,
462  $ one / REAL( NCOLS ), work,
463  $ 1 )
464  END IF
465  CALL cgemm( trans, 'No transpose', nrows,
466  $ nrhs, ncols, cone, copya, lda,
467  $ work, ldwork, czero, b, ldb )
468  CALL clacpy( 'Full', nrows, nrhs, b, ldb,
469  $ copyb, ldb )
470 *
471 * Solve LS or overdetermined system
472 *
473  IF( m.GT.0 .AND. n.GT.0 ) THEN
474  CALL clacpy( 'Full', m, n, copya, lda,
475  $ a, lda )
476  CALL clacpy( 'Full', nrows, nrhs,
477  $ copyb, ldb, b, ldb )
478  END IF
479  srnamt = 'CGELS '
480  CALL cgels( trans, m, n, nrhs, a, lda, b,
481  $ ldb, work, lwork, info )
482 *
483  IF( info.NE.0 )
484  $ CALL alaerh( path, 'CGELS ', info, 0,
485  $ trans, m, n, nrhs, -1, nb,
486  $ itype, nfail, nerrs,
487  $ nout )
488 *
489 * Check correctness of results
490 *
491  ldwork = max( 1, nrows )
492  IF( nrows.GT.0 .AND. nrhs.GT.0 )
493  $ CALL clacpy( 'Full', nrows, nrhs,
494  $ copyb, ldb, c, ldb )
495  CALL cqrt16( trans, m, n, nrhs, copya,
496  $ lda, b, ldb, c, ldb, rwork,
497  $ result( 1 ) )
498 *
499  IF( ( itran.EQ.1 .AND. m.GE.n ) .OR.
500  $ ( itran.EQ.2 .AND. m.LT.n ) ) THEN
501 *
502 * Solving LS system
503 *
504  result( 2 ) = cqrt17( trans, 1, m, n,
505  $ nrhs, copya, lda, b, ldb,
506  $ copyb, ldb, c, work,
507  $ lwork )
508  ELSE
509 *
510 * Solving overdetermined system
511 *
512  result( 2 ) = cqrt14( trans, m, n,
513  $ nrhs, copya, lda, b, ldb,
514  $ work, lwork )
515  END IF
516 *
517 * Print information about the tests that
518 * did not pass the threshold.
519 *
520  DO 20 k = 1, 2
521  IF( result( k ).GE.thresh ) THEN
522  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
523  $ CALL alahd( nout, path )
524  WRITE( nout, fmt = 9999 )trans, m,
525  $ n, nrhs, nb, itype, k,
526  $ result( k )
527  nfail = nfail + 1
528  END IF
529  20 CONTINUE
530  nrun = nrun + 2
531  30 CONTINUE
532  40 CONTINUE
533 *
534 *
535 * Test CGETSLS
536 *
537 * Generate a matrix of scaling type ISCALE
538 *
539  CALL cqrt13( iscale, m, n, copya, lda, norma,
540  $ iseed )
541  DO 65 inb = 1, nnb
542  mb = nbval( inb )
543  CALL xlaenv( 1, mb )
544  DO 62 imb = 1, nnb
545  nb = nbval( imb )
546  CALL xlaenv( 2, nb )
547 *
548  DO 60 itran = 1, 2
549  IF( itran.EQ.1 ) THEN
550  trans = 'N'
551  nrows = m
552  ncols = n
553  ELSE
554  trans = 'C'
555  nrows = n
556  ncols = m
557  END IF
558  ldwork = max( 1, ncols )
559 *
560 * Set up a consistent rhs
561 *
562  IF( ncols.GT.0 ) THEN
563  CALL clarnv( 2, iseed, ncols*nrhs,
564  $ work )
565  CALL cscal( ncols*nrhs,
566  $ one / REAL( NCOLS ), work,
567  $ 1 )
568  END IF
569  CALL cgemm( trans, 'No transpose', nrows,
570  $ nrhs, ncols, cone, copya, lda,
571  $ work, ldwork, czero, b, ldb )
572  CALL clacpy( 'Full', nrows, nrhs, b, ldb,
573  $ copyb, ldb )
574 *
575 * Solve LS or overdetermined system
576 *
577  IF( m.GT.0 .AND. n.GT.0 ) THEN
578  CALL clacpy( 'Full', m, n, copya, lda,
579  $ a, lda )
580  CALL clacpy( 'Full', nrows, nrhs,
581  $ copyb, ldb, b, ldb )
582  END IF
583  srnamt = 'CGETSLS '
584  CALL cgetsls( trans, m, n, nrhs, a,
585  $ lda, b, ldb, work, lwork, info )
586  IF( info.NE.0 )
587  $ CALL alaerh( path, 'CGETSLS ', info, 0,
588  $ trans, m, n, nrhs, -1, nb,
589  $ itype, nfail, nerrs,
590  $ nout )
591 *
592 * Check correctness of results
593 *
594  ldwork = max( 1, nrows )
595  IF( nrows.GT.0 .AND. nrhs.GT.0 )
596  $ CALL clacpy( 'Full', nrows, nrhs,
597  $ copyb, ldb, c, ldb )
598  CALL cqrt16( trans, m, n, nrhs, copya,
599  $ lda, b, ldb, c, ldb, work,
600  $ result( 15 ) )
601 *
602  IF( ( itran.EQ.1 .AND. m.GE.n ) .OR.
603  $ ( itran.EQ.2 .AND. m.LT.n ) ) THEN
604 *
605 * Solving LS system
606 *
607  result( 16 ) = cqrt17( trans, 1, m, n,
608  $ nrhs, copya, lda, b, ldb,
609  $ copyb, ldb, c, work,
610  $ lwork )
611  ELSE
612 *
613 * Solving overdetermined system
614 *
615  result( 16 ) = cqrt14( trans, m, n,
616  $ nrhs, copya, lda, b, ldb,
617  $ work, lwork )
618  END IF
619 *
620 * Print information about the tests that
621 * did not pass the threshold.
622 *
623  DO 50 k = 15, 16
624  IF( result( k ).GE.thresh ) THEN
625  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
626  $ CALL alahd( nout, path )
627  WRITE( nout, fmt = 9997 )trans, m,
628  $ n, nrhs, mb, nb, itype, k,
629  $ result( k )
630  nfail = nfail + 1
631  END IF
632  50 CONTINUE
633  nrun = nrun + 2
634  60 CONTINUE
635  62 CONTINUE
636  65 CONTINUE
637  END IF
638 *
639 * Generate a matrix of scaling type ISCALE and rank
640 * type IRANK.
641 *
642  CALL cqrt15( iscale, irank, m, n, nrhs, copya, lda,
643  $ copyb, ldb, copys, rank, norma, normb,
644  $ iseed, work, lwork )
645 *
646 * workspace used: MAX(M+MIN(M,N),NRHS*MIN(M,N),2*N+M)
647 *
648  ldwork = max( 1, m )
649 *
650 * Loop for testing different block sizes.
651 *
652  DO 90 inb = 1, nnb
653  nb = nbval( inb )
654  CALL xlaenv( 1, nb )
655  CALL xlaenv( 3, nxval( inb ) )
656 *
657 * Test CGELSY
658 *
659 * CGELSY: Compute the minimum-norm solution
660 * X to min( norm( A * X - B ) )
661 * using the rank-revealing orthogonal
662 * factorization.
663 *
664  CALL clacpy( 'Full', m, n, copya, lda, a, lda )
665  CALL clacpy( 'Full', m, nrhs, copyb, ldb, b,
666  $ ldb )
667 *
668 * Initialize vector IWORK.
669 *
670  DO 70 j = 1, n
671  iwork( j ) = 0
672  70 CONTINUE
673 *
674  srnamt = 'CGELSY'
675  CALL cgelsy( m, n, nrhs, a, lda, b, ldb, iwork,
676  $ rcond, crank, work, lwlsy, rwork,
677  $ info )
678  IF( info.NE.0 )
679  $ CALL alaerh( path, 'CGELSY', info, 0, ' ', m,
680  $ n, nrhs, -1, nb, itype, nfail,
681  $ nerrs, nout )
682 *
683 * workspace used: 2*MNMIN+NB*NB+NB*MAX(N,NRHS)
684 *
685 * Test 3: Compute relative error in svd
686 * workspace: M*N + 4*MIN(M,N) + MAX(M,N)
687 *
688  result( 3 ) = cqrt12( crank, crank, a, lda,
689  $ copys, work, lwork, rwork )
690 *
691 * Test 4: Compute error in solution
692 * workspace: M*NRHS + M
693 *
694  CALL clacpy( 'Full', m, nrhs, copyb, ldb, work,
695  $ ldwork )
696  CALL cqrt16( 'No transpose', m, n, nrhs, copya,
697  $ lda, b, ldb, work, ldwork, rwork,
698  $ result( 4 ) )
699 *
700 * Test 5: Check norm of r'*A
701 * workspace: NRHS*(M+N)
702 *
703  result( 5 ) = zero
704  IF( m.GT.crank )
705  $ result( 5 ) = cqrt17( 'No transpose', 1, m,
706  $ n, nrhs, copya, lda, b, ldb,
707  $ copyb, ldb, c, work, lwork )
708 *
709 * Test 6: Check if x is in the rowspace of A
710 * workspace: (M+NRHS)*(N+2)
711 *
712  result( 6 ) = zero
713 *
714  IF( n.GT.crank )
715  $ result( 6 ) = cqrt14( 'No transpose', m, n,
716  $ nrhs, copya, lda, b, ldb,
717  $ work, lwork )
718 *
719 * Test CGELSS
720 *
721 * CGELSS: Compute the minimum-norm solution
722 * X to min( norm( A * X - B ) )
723 * using the SVD.
724 *
725  CALL clacpy( 'Full', m, n, copya, lda, a, lda )
726  CALL clacpy( 'Full', m, nrhs, copyb, ldb, b,
727  $ ldb )
728  srnamt = 'CGELSS'
729  CALL cgelss( m, n, nrhs, a, lda, b, ldb, s,
730  $ rcond, crank, work, lwork, rwork,
731  $ info )
732 *
733  IF( info.NE.0 )
734  $ CALL alaerh( path, 'CGELSS', info, 0, ' ', m,
735  $ n, nrhs, -1, nb, itype, nfail,
736  $ nerrs, nout )
737 *
738 * workspace used: 3*min(m,n) +
739 * max(2*min(m,n),nrhs,max(m,n))
740 *
741 * Test 7: Compute relative error in svd
742 *
743  IF( rank.GT.0 ) THEN
744  CALL saxpy( mnmin, -one, copys, 1, s, 1 )
745  result( 7 ) = sasum( mnmin, s, 1 ) /
746  $ sasum( mnmin, copys, 1 ) /
747  $ ( eps*REAL( MNMIN ) )
748  ELSE
749  result( 7 ) = zero
750  END IF
751 *
752 * Test 8: Compute error in solution
753 *
754  CALL clacpy( 'Full', m, nrhs, copyb, ldb, work,
755  $ ldwork )
756  CALL cqrt16( 'No transpose', m, n, nrhs, copya,
757  $ lda, b, ldb, work, ldwork, rwork,
758  $ result( 8 ) )
759 *
760 * Test 9: Check norm of r'*A
761 *
762  result( 9 ) = zero
763  IF( m.GT.crank )
764  $ result( 9 ) = cqrt17( 'No transpose', 1, m,
765  $ n, nrhs, copya, lda, b, ldb,
766  $ copyb, ldb, c, work, lwork )
767 *
768 * Test 10: Check if x is in the rowspace of A
769 *
770  result( 10 ) = zero
771  IF( n.GT.crank )
772  $ result( 10 ) = cqrt14( 'No transpose', m, n,
773  $ nrhs, copya, lda, b, ldb,
774  $ work, lwork )
775 *
776 * Test CGELSD
777 *
778 * CGELSD: Compute the minimum-norm solution X
779 * to min( norm( A * X - B ) ) using a
780 * divide and conquer SVD.
781 *
782  CALL xlaenv( 9, 25 )
783 *
784  CALL clacpy( 'Full', m, n, copya, lda, a, lda )
785  CALL clacpy( 'Full', m, nrhs, copyb, ldb, b,
786  $ ldb )
787 *
788  srnamt = 'CGELSD'
789  CALL cgelsd( m, n, nrhs, a, lda, b, ldb, s,
790  $ rcond, crank, work, lwork, rwork,
791  $ iwork, info )
792  IF( info.NE.0 )
793  $ CALL alaerh( path, 'CGELSD', info, 0, ' ', m,
794  $ n, nrhs, -1, nb, itype, nfail,
795  $ nerrs, nout )
796 *
797 * Test 11: Compute relative error in svd
798 *
799  IF( rank.GT.0 ) THEN
800  CALL saxpy( mnmin, -one, copys, 1, s, 1 )
801  result( 11 ) = sasum( mnmin, s, 1 ) /
802  $ sasum( mnmin, copys, 1 ) /
803  $ ( eps*REAL( MNMIN ) )
804  ELSE
805  result( 11 ) = zero
806  END IF
807 *
808 * Test 12: Compute error in solution
809 *
810  CALL clacpy( 'Full', m, nrhs, copyb, ldb, work,
811  $ ldwork )
812  CALL cqrt16( 'No transpose', m, n, nrhs, copya,
813  $ lda, b, ldb, work, ldwork, rwork,
814  $ result( 12 ) )
815 *
816 * Test 13: Check norm of r'*A
817 *
818  result( 13 ) = zero
819  IF( m.GT.crank )
820  $ result( 13 ) = cqrt17( 'No transpose', 1, m,
821  $ n, nrhs, copya, lda, b, ldb,
822  $ copyb, ldb, c, work, lwork )
823 *
824 * Test 14: Check if x is in the rowspace of A
825 *
826  result( 14 ) = zero
827  IF( n.GT.crank )
828  $ result( 14 ) = cqrt14( 'No transpose', m, n,
829  $ nrhs, copya, lda, b, ldb,
830  $ work, lwork )
831 *
832 * Print information about the tests that did not
833 * pass the threshold.
834 *
835  DO 80 k = 3, 14
836  IF( result( k ).GE.thresh ) THEN
837  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
838  $ CALL alahd( nout, path )
839  WRITE( nout, fmt = 9998 )m, n, nrhs, nb,
840  $ itype, k, result( k )
841  nfail = nfail + 1
842  END IF
843  80 CONTINUE
844  nrun = nrun + 12
845 *
846  90 CONTINUE
847  100 CONTINUE
848  110 CONTINUE
849  120 CONTINUE
850  130 CONTINUE
851  140 CONTINUE
852 *
853 * Print a summary of the results.
854 *
855  CALL alasvm( path, nout, nfail, nrun, nerrs )
856 *
857  9999 FORMAT( ' TRANS=''', a1, ''', M=', i5, ', N=', i5, ', NRHS=', i4,
858  $ ', NB=', i4, ', type', i2, ', test(', i2, ')=', g12.5 )
859  9998 FORMAT( ' M=', i5, ', N=', i5, ', NRHS=', i4, ', NB=', i4,
860  $ ', type', i2, ', test(', i2, ')=', g12.5 )
861  9997 FORMAT( ' TRANS=''', a1,' M=', i5, ', N=', i5, ', NRHS=', i4,
862  $ ', MB=', i4,', NB=', i4,', type', i2,
863  $ ', test(', i2, ')=', g12.5 )
864 *
865  DEALLOCATE( work )
866  DEALLOCATE( rwork )
867  DEALLOCATE( iwork )
868  RETURN
869 *
870 * End of CDRVLS
871 *
alasvm
subroutine alasvm(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASVM
Definition: alasvm.f:75
alahd
subroutine alahd(IOUNIT, PATH)
ALAHD
Definition: alahd.f:107
cgelsy
subroutine cgelsy(M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, WORK, LWORK, RWORK, INFO)
CGELSY solves overdetermined or underdetermined systems for GE matrices
Definition: cgelsy.f:212
cgels
subroutine cgels(TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK, INFO)
CGELS solves overdetermined or underdetermined systems for GE matrices
Definition: cgels.f:184
cqrt14
real function cqrt14(TRANS, M, N, NRHS, A, LDA, X, LDX, WORK, LWORK)
CQRT14
Definition: cqrt14.f:118
alaerh
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
Definition: alaerh.f:149
cgetsls
subroutine cgetsls(TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK, INFO)
Definition: cgetsls.f:162
cqrt13
subroutine cqrt13(SCALE, M, N, A, LDA, NORMA, ISEED)
CQRT13
Definition: cqrt13.f:93
cqrt12
real function cqrt12(M, N, A, LDA, S, WORK, LWORK, RWORK)
CQRT12
Definition: cqrt12.f:99
cqrt16
subroutine cqrt16(TRANS, M, N, NRHS, A, LDA, X, LDX, B, LDB, RWORK, RESID)
CQRT16
Definition: cqrt16.f:135
clarnv
subroutine clarnv(IDIST, ISEED, N, X)
CLARNV returns a vector of random numbers from a uniform or normal distribution.
Definition: clarnv.f:101
cgelss
subroutine cgelss(M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, WORK, LWORK, RWORK, INFO)
CGELSS solves overdetermined or underdetermined systems for GE matrices
Definition: cgelss.f:180
xlaenv
subroutine xlaenv(ISPEC, NVALUE)
XLAENV
Definition: xlaenv.f:83
cscal
subroutine cscal(N, CA, CX, INCX)
CSCAL
Definition: cscal.f:80
sasum
real function sasum(N, SX, INCX)
SASUM
Definition: sasum.f:74
saxpy
subroutine saxpy(N, SA, SX, INCX, SY, INCY)
SAXPY
Definition: saxpy.f:91
slamch
real function slamch(CMACH)
SLAMCH
Definition: slamch.f:69
clacpy
subroutine clacpy(UPLO, M, N, A, LDA, B, LDB)
CLACPY copies all or part of one two-dimensional array to another.
Definition: clacpy.f:105
cgelsd
subroutine cgelsd(M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, WORK, LWORK, RWORK, IWORK, INFO)
CGELSD computes the minimum-norm solution to a linear least squares problem for GE matrices ...
Definition: cgelsd.f:227
cerrls
subroutine cerrls(PATH, NUNIT)
CERRLS
Definition: cerrls.f:57
cqrt15
subroutine cqrt15(SCALE, RKSEL, M, N, NRHS, A, LDA, B, LDB, S, RANK, NORMA, NORMB, ISEED, WORK, LWORK)
CQRT15
Definition: cqrt15.f:151
cgemm
subroutine cgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
CGEMM
Definition: cgemm.f:189
csscal
subroutine csscal(N, SA, CX, INCX)
CSSCAL
Definition: csscal.f:80
cqrt17
real function cqrt17(TRANS, IRESID, M, N, NRHS, A, LDA, X, LDX, B, LDB, C, WORK, LWORK)
CQRT17
Definition: cqrt17.f:152
Here is the call graph for this function:
Here is the caller graph for this function: