LAPACK  3.7.1
LAPACK: Linear Algebra PACKage

◆ zdrvls()

subroutine zdrvls ( 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,
double precision  THRESH,
logical  TSTERR,
complex*16, dimension( * )  A,
complex*16, dimension( * )  COPYA,
complex*16, dimension( * )  B,
complex*16, dimension( * )  COPYB,
complex*16, dimension( * )  C,
double precision, dimension( * )  S,
double precision, dimension( * )  COPYS,
integer  NOUT 
)

ZDRVLS

Purpose: 
 ZDRVLS tests the least squares driver routines ZGELS, ZGETSLS, ZGELSS, ZGELSY
 and ZGELSD.
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 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]TSTERR
          TSTERR is LOGICAL
          Flag that indicates whether error exits are to be tested.
[out]A
          A is COMPLEX*16 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*16 array, dimension (MMAX*NMAX)
[out]B
          B is COMPLEX*16 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*16 array, dimension (MMAX*NSMAX)
[out]C
          C is COMPLEX*16 array, dimension (MMAX*NSMAX)
[out]S
          S is DOUBLE PRECISION array, dimension
                      (min(MMAX,NMAX))
[out]COPYS
          COPYS is DOUBLE PRECISION 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 zdrvls.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  DOUBLE PRECISION thresh
204 * ..
205 * .. Array Arguments ..
206  LOGICAL dotype( * )
207  INTEGER mval( * ), nbval( * ), nsval( * ),
208  $ nval( * ), nxval( * )
209  DOUBLE PRECISION copys( * ), s( * )
210  COMPLEX*16 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  DOUBLE PRECISION one, zero
221  parameter( one = 1.0d+0, zero = 0.0d+0 )
222  COMPLEX*16 cone, czero
223  parameter( cone = ( 1.0d+0, 0.0d+0 ),
224  $ czero = ( 0.0d+0, 0.0d+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_zgels, lwork_zgetsls, lwork_zgelss,
235  $ lwork_zgelsy, lwork_zgelsd,
236  $ lrwork_zgelsy, lrwork_zgelss, lrwork_zgelsd
237  DOUBLE PRECISION eps, norma, normb, rcond
238 * ..
239 * .. Local Arrays ..
240  INTEGER iseed( 4 ), iseedy( 4 ), iwq
241  DOUBLE PRECISION result( ntests ), rwq
242  COMPLEX*16 wq
243 * ..
244 * .. Allocatable Arrays ..
245  COMPLEX*16, ALLOCATABLE :: work (:)
246  DOUBLE PRECISION, ALLOCATABLE :: rwork (:)
247  INTEGER, ALLOCATABLE :: iwork (:)
248 * ..
249 * .. External Functions ..
250  DOUBLE PRECISION dasum, dlamch, zqrt12, zqrt14, zqrt17
251  EXTERNAL dasum, dlamch, zqrt12, zqrt14, zqrt17
252 * ..
253 * .. External Subroutines ..
254  EXTERNAL alaerh, alahd, alasvm, daxpy, dlasrt, xlaenv,
255  $ zdscal, zerrls, zgels, zgelsd, zgelss,
256  $ zgelsy, zgemm, zlacpy, zlarnv, zqrt13, zqrt15,
257  $ zqrt16, zgetsls
258 * ..
259 * .. Intrinsic Functions ..
260  INTRINSIC dble, max, min, int, 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 ) = 'Zomplex 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 = dlamch( '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 zerrls( 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 * ZQRT14, ZQRT17 (two side cases), ZQRT15 and ZQRT12
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 ZGELS
364  CALL zgels( trans, m, n, nrhs, a, lda,
365  $ b, ldb, wq, -1, info )
366  lwork_zgels = int( wq )
367 * Compute workspace needed for ZGETSLS
368  CALL zgetsls( trans, m, n, nrhs, a, lda,
369  $ b, ldb, wq, -1, info )
370  lwork_zgetsls = int( wq )
371  ENDDO
372  END IF
373 * Compute workspace needed for ZGELSY
374  CALL zgelsy( m, n, nrhs, a, lda, b, ldb, iwq,
375  $ rcond, crank, wq, -1, rwork, info )
376  lwork_zgelsy = int( wq )
377  lrwork_zgelsy = 2*n
378 * Compute workspace needed for ZGELSS
379  CALL zgelss( m, n, nrhs, a, lda, b, ldb, s,
380  $ rcond, crank, wq, -1 , rwork,
381  $ info )
382  lwork_zgelss = int( wq )
383  lrwork_zgelss = 5*mnmin
384 * Compute workspace needed for ZGELSD
385  CALL zgelsd( m, n, nrhs, a, lda, b, ldb, s,
386  $ rcond, crank, wq, -1, rwq, iwq,
387  $ info )
388  lwork_zgelsd = int( wq )
389  lrwork_zgelsd = int( rwq )
390 * Compute LIWORK workspace needed for ZGELSY and ZGELSD
391  liwork = max( liwork, n, iwq )
392 * Compute LRWORK workspace needed for ZGELSY, ZGELSS and ZGELSD
393  lrwork = max( lrwork, lrwork_zgelsy,
394  $ lrwork_zgelss, lrwork_zgelsd )
395 * Compute LWORK workspace needed for all functions
396  lwork = max( lwork, lwork_zgels, lwork_zgetsls,
397  $ lwork_zgelsy, lwork_zgelss,
398  $ lwork_zgelsd )
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 ZGELS
434 *
435 * Generate a matrix of scaling type ISCALE
436 *
437  CALL zqrt13( 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 zlarnv( 2, iseed, ncols*nrhs,
460  $ work )
461  CALL zdscal( ncols*nrhs,
462  $ one / dble( ncols ), work,
463  $ 1 )
464  END IF
465  CALL zgemm( trans, 'No transpose', nrows,
466  $ nrhs, ncols, cone, copya, lda,
467  $ work, ldwork, czero, b, ldb )
468  CALL zlacpy( '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 zlacpy( 'Full', m, n, copya, lda,
475  $ a, lda )
476  CALL zlacpy( 'Full', nrows, nrhs,
477  $ copyb, ldb, b, ldb )
478  END IF
479  srnamt = 'ZGELS '
480  CALL zgels( trans, m, n, nrhs, a, lda, b,
481  $ ldb, work, lwork, info )
482 *
483  IF( info.NE.0 )
484  $ CALL alaerh( path, 'ZGELS ', 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 zlacpy( 'Full', nrows, nrhs,
494  $ copyb, ldb, c, ldb )
495  CALL zqrt16( 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 ) = zqrt17( 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 ) = zqrt14( 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 ZGETSLS
536 *
537 * Generate a matrix of scaling type ISCALE
538 *
539  CALL zqrt13( 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 zlarnv( 2, iseed, ncols*nrhs,
564  $ work )
565  CALL zscal( ncols*nrhs,
566  $ one / dble( ncols ), work,
567  $ 1 )
568  END IF
569  CALL zgemm( trans, 'No transpose', nrows,
570  $ nrhs, ncols, cone, copya, lda,
571  $ work, ldwork, czero, b, ldb )
572  CALL zlacpy( '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 zlacpy( 'Full', m, n, copya, lda,
579  $ a, lda )
580  CALL zlacpy( 'Full', nrows, nrhs,
581  $ copyb, ldb, b, ldb )
582  END IF
583  srnamt = 'ZGETSLS '
584  CALL zgetsls( trans, m, n, nrhs, a,
585  $ lda, b, ldb, work, lwork, info )
586  IF( info.NE.0 )
587  $ CALL alaerh( path, 'ZGETSLS ', 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 zlacpy( 'Full', nrows, nrhs,
597  $ copyb, ldb, c, ldb )
598  CALL zqrt16( 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 ) = zqrt17( 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 ) = zqrt14( 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 zqrt15( 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 ZGELSY
658 *
659 * ZGELSY: Compute the minimum-norm solution
660 * X to min( norm( A * X - B ) )
661 * using the rank-revealing orthogonal
662 * factorization.
663 *
664  CALL zlacpy( 'Full', m, n, copya, lda, a, lda )
665  CALL zlacpy( '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 = 'ZGELSY'
675  CALL zgelsy( 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, 'ZGELSY', 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 ) = zqrt12( 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 zlacpy( 'Full', m, nrhs, copyb, ldb, work,
695  $ ldwork )
696  CALL zqrt16( '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 ) = zqrt17( '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 ) = zqrt14( 'No transpose', m, n,
716  $ nrhs, copya, lda, b, ldb,
717  $ work, lwork )
718 *
719 * Test ZGELSS
720 *
721 * ZGELSS: Compute the minimum-norm solution
722 * X to min( norm( A * X - B ) )
723 * using the SVD.
724 *
725  CALL zlacpy( 'Full', m, n, copya, lda, a, lda )
726  CALL zlacpy( 'Full', m, nrhs, copyb, ldb, b,
727  $ ldb )
728  srnamt = 'ZGELSS'
729  CALL zgelss( 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, 'ZGELSS', 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 daxpy( mnmin, -one, copys, 1, s, 1 )
745  result( 7 ) = dasum( mnmin, s, 1 ) /
746  $ dasum( mnmin, copys, 1 ) /
747  $ ( eps*dble( mnmin ) )
748  ELSE
749  result( 7 ) = zero
750  END IF
751 *
752 * Test 8: Compute error in solution
753 *
754  CALL zlacpy( 'Full', m, nrhs, copyb, ldb, work,
755  $ ldwork )
756  CALL zqrt16( '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 ) = zqrt17( '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 ) = zqrt14( 'No transpose', m, n,
773  $ nrhs, copya, lda, b, ldb,
774  $ work, lwork )
775 *
776 * Test ZGELSD
777 *
778 * ZGELSD: 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 zlacpy( 'Full', m, n, copya, lda, a, lda )
785  CALL zlacpy( 'Full', m, nrhs, copyb, ldb, b,
786  $ ldb )
787 *
788  srnamt = 'ZGELSD'
789  CALL zgelsd( 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, 'ZGELSD', 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 daxpy( mnmin, -one, copys, 1, s, 1 )
801  result( 11 ) = dasum( mnmin, s, 1 ) /
802  $ dasum( mnmin, copys, 1 ) /
803  $ ( eps*dble( mnmin ) )
804  ELSE
805  result( 11 ) = zero
806  END IF
807 *
808 * Test 12: Compute error in solution
809 *
810  CALL zlacpy( 'Full', m, nrhs, copyb, ldb, work,
811  $ ldwork )
812  CALL zqrt16( '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 ) = zqrt17( '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 ) = zqrt14( '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( iwork )
867  DEALLOCATE( rwork )
868  RETURN
869 *
870 * End of ZDRVLS
871 *
dlamch
double precision function dlamch(CMACH)
DLAMCH
Definition: dlamch.f:65
alasvm
subroutine alasvm(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASVM
Definition: alasvm.f:75
alahd
subroutine alahd(IOUNIT, PATH)
ALAHD
Definition: alahd.f:107
zqrt15
subroutine zqrt15(SCALE, RKSEL, M, N, NRHS, A, LDA, B, LDB, S, RANK, NORMA, NORMB, ISEED, WORK, LWORK)
ZQRT15
Definition: zqrt15.f:151
zgels
subroutine zgels(TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK, INFO)
ZGELS solves overdetermined or underdetermined systems for GE matrices
Definition: zgels.f:184
alaerh
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
Definition: alaerh.f:149
zqrt14
double precision function zqrt14(TRANS, M, N, NRHS, A, LDA, X, LDX, WORK, LWORK)
ZQRT14
Definition: zqrt14.f:118
zlacpy
subroutine zlacpy(UPLO, M, N, A, LDA, B, LDB)
ZLACPY copies all or part of one two-dimensional array to another.
Definition: zlacpy.f:105
zgemm
subroutine zgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
ZGEMM
Definition: zgemm.f:189
daxpy
subroutine daxpy(N, DA, DX, INCX, DY, INCY)
DAXPY
Definition: daxpy.f:91
zqrt16
subroutine zqrt16(TRANS, M, N, NRHS, A, LDA, X, LDX, B, LDB, RWORK, RESID)
ZQRT16
Definition: zqrt16.f:135
xlaenv
subroutine xlaenv(ISPEC, NVALUE)
XLAENV
Definition: xlaenv.f:83
zqrt12
double precision function zqrt12(M, N, A, LDA, S, WORK, LWORK, RWORK)
ZQRT12
Definition: zqrt12.f:99
zgelsy
subroutine zgelsy(M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, WORK, LWORK, RWORK, INFO)
ZGELSY solves overdetermined or underdetermined systems for GE matrices
Definition: zgelsy.f:212
zgelsd
subroutine zgelsd(M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, WORK, LWORK, RWORK, IWORK, INFO)
ZGELSD computes the minimum-norm solution to a linear least squares problem for GE matrices ...
Definition: zgelsd.f:227
zqrt13
subroutine zqrt13(SCALE, M, N, A, LDA, NORMA, ISEED)
ZQRT13
Definition: zqrt13.f:93
dasum
double precision function dasum(N, DX, INCX)
DASUM
Definition: dasum.f:73
zerrls
subroutine zerrls(PATH, NUNIT)
ZERRLS
Definition: zerrls.f:57
zqrt17
double precision function zqrt17(TRANS, IRESID, M, N, NRHS, A, LDA, X, LDX, B, LDB, C, WORK, LWORK)
ZQRT17
Definition: zqrt17.f:152
dlasrt
subroutine dlasrt(ID, N, D, INFO)
DLASRT sorts numbers in increasing or decreasing order.
Definition: dlasrt.f:90
zdscal
subroutine zdscal(N, DA, ZX, INCX)
ZDSCAL
Definition: zdscal.f:80
zlarnv
subroutine zlarnv(IDIST, ISEED, N, X)
ZLARNV returns a vector of random numbers from a uniform or normal distribution.
Definition: zlarnv.f:101
zgetsls
subroutine zgetsls(TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK, INFO)
Definition: zgetsls.f:162
zscal
subroutine zscal(N, ZA, ZX, INCX)
ZSCAL
Definition: zscal.f:80
zgelss
subroutine zgelss(M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, WORK, LWORK, RWORK, INFO)
ZGELSS solves overdetermined or underdetermined systems for GE matrices
Definition: zgelss.f:180
Here is the call graph for this function:
Here is the caller graph for this function: