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

◆ dchk1()

subroutine dchk1 ( character*7 sname,
double precision eps,
double precision thresh,
integer nout,
integer ntra,
logical trace,
logical rewi,
logical fatal,
integer nidim,
integer, dimension( nidim ) idim,
integer nalf,
double precision, dimension( nalf ) alf,
integer nbet,
double precision, dimension( nbet ) bet,
integer nmax,
double precision, dimension( nmax, nmax ) a,
double precision, dimension( nmax*nmax ) aa,
double precision, dimension( nmax*nmax ) as,
double precision, dimension( nmax, nmax ) b,
double precision, dimension( nmax*nmax ) bb,
double precision, dimension( nmax*nmax ) bs,
double precision, dimension( nmax, nmax ) c,
double precision, dimension( nmax*nmax ) cc,
double precision, dimension( nmax*nmax ) cs,
double precision, dimension( nmax ) ct,
double precision, dimension( nmax ) g )

Definition at line 399 of file dblat3.f.

402*
403* Tests DGEMM.
404*
405* Auxiliary routine for test program for Level 3 Blas.
406*
407* -- Written on 8-February-1989.
408* Jack Dongarra, Argonne National Laboratory.
409* Iain Duff, AERE Harwell.
410* Jeremy Du Croz, Numerical Algorithms Group Ltd.
411* Sven Hammarling, Numerical Algorithms Group Ltd.
412*
413* .. Parameters ..
414 DOUBLE PRECISION ZERO
415 parameter( zero = 0.0d0 )
416* .. Scalar Arguments ..
417 DOUBLE PRECISION EPS, THRESH
418 INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA
419 LOGICAL FATAL, REWI, TRACE
420 CHARACTER*7 SNAME
421* .. Array Arguments ..
422 DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
423 $ AS( NMAX*NMAX ), B( NMAX, NMAX ),
424 $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ),
425 $ C( NMAX, NMAX ), CC( NMAX*NMAX ),
426 $ CS( NMAX*NMAX ), CT( NMAX ), G( NMAX )
427 INTEGER IDIM( NIDIM )
428* .. Local Scalars ..
429 DOUBLE PRECISION ALPHA, ALS, BETA, BLS, ERR, ERRMAX
430 INTEGER I, IA, IB, ICA, ICB, IK, IM, IN, K, KS, LAA,
431 $ LBB, LCC, LDA, LDAS, LDB, LDBS, LDC, LDCS, M,
432 $ MA, MB, MS, N, NA, NARGS, NB, NC, NS
433 LOGICAL NULL, RESET, SAME, TRANA, TRANB
434 CHARACTER*1 TRANAS, TRANBS, TRANSA, TRANSB
435 CHARACTER*3 ICH
436* .. Local Arrays ..
437 LOGICAL ISAME( 13 )
438* .. External Functions ..
439 LOGICAL LDE, LDERES
440 EXTERNAL lde, lderes
441* .. External Subroutines ..
442 EXTERNAL dgemm, dmake, dmmch
443* .. Intrinsic Functions ..
444 INTRINSIC max
445* .. Scalars in Common ..
446 INTEGER INFOT, NOUTC
447 LOGICAL LERR, OK
448* .. Common blocks ..
449 COMMON /infoc/infot, noutc, ok, lerr
450* .. Data statements ..
451 DATA ich/'NTC'/
452* .. Executable Statements ..
453*
454 nargs = 13
455 nc = 0
456 reset = .true.
457 errmax = zero
458*
459 DO 110 im = 1, nidim
460 m = idim( im )
461*
462 DO 100 in = 1, nidim
463 n = idim( in )
464* Set LDC to 1 more than minimum value if room.
465 ldc = m
466 IF( ldc.LT.nmax )
467 $ ldc = ldc + 1
468* Skip tests if not enough room.
469 IF( ldc.GT.nmax )
470 $ GO TO 100
471 lcc = ldc*n
472 null = n.LE.0.OR.m.LE.0
473*
474 DO 90 ik = 1, nidim
475 k = idim( ik )
476*
477 DO 80 ica = 1, 3
478 transa = ich( ica: ica )
479 trana = transa.EQ.'T'.OR.transa.EQ.'C'
480*
481 IF( trana )THEN
482 ma = k
483 na = m
484 ELSE
485 ma = m
486 na = k
487 END IF
488* Set LDA to 1 more than minimum value if room.
489 lda = ma
490 IF( lda.LT.nmax )
491 $ lda = lda + 1
492* Skip tests if not enough room.
493 IF( lda.GT.nmax )
494 $ GO TO 80
495 laa = lda*na
496*
497* Generate the matrix A.
498*
499 CALL dmake( 'GE', ' ', ' ', ma, na, a, nmax, aa, lda,
500 $ reset, zero )
501*
502 DO 70 icb = 1, 3
503 transb = ich( icb: icb )
504 tranb = transb.EQ.'T'.OR.transb.EQ.'C'
505*
506 IF( tranb )THEN
507 mb = n
508 nb = k
509 ELSE
510 mb = k
511 nb = n
512 END IF
513* Set LDB to 1 more than minimum value if room.
514 ldb = mb
515 IF( ldb.LT.nmax )
516 $ ldb = ldb + 1
517* Skip tests if not enough room.
518 IF( ldb.GT.nmax )
519 $ GO TO 70
520 lbb = ldb*nb
521*
522* Generate the matrix B.
523*
524 CALL dmake( 'GE', ' ', ' ', mb, nb, b, nmax, bb,
525 $ ldb, reset, zero )
526*
527 DO 60 ia = 1, nalf
528 alpha = alf( ia )
529*
530 DO 50 ib = 1, nbet
531 beta = bet( ib )
532*
533* Generate the matrix C.
534*
535 CALL dmake( 'GE', ' ', ' ', m, n, c, nmax,
536 $ cc, ldc, reset, zero )
537*
538 nc = nc + 1
539*
540* Save every datum before calling the
541* subroutine.
542*
543 tranas = transa
544 tranbs = transb
545 ms = m
546 ns = n
547 ks = k
548 als = alpha
549 DO 10 i = 1, laa
550 as( i ) = aa( i )
551 10 CONTINUE
552 ldas = lda
553 DO 20 i = 1, lbb
554 bs( i ) = bb( i )
555 20 CONTINUE
556 ldbs = ldb
557 bls = beta
558 DO 30 i = 1, lcc
559 cs( i ) = cc( i )
560 30 CONTINUE
561 ldcs = ldc
562*
563* Call the subroutine.
564*
565 IF( trace )
566 $ WRITE( ntra, fmt = 9995 )nc, sname,
567 $ transa, transb, m, n, k, alpha, lda, ldb,
568 $ beta, ldc
569 IF( rewi )
570 $ rewind ntra
571 CALL dgemm( transa, transb, m, n, k, alpha,
572 $ aa, lda, bb, ldb, beta, cc, ldc )
573*
574* Check if error-exit was taken incorrectly.
575*
576 IF( .NOT.ok )THEN
577 WRITE( nout, fmt = 9994 )
578 fatal = .true.
579 GO TO 120
580 END IF
581*
582* See what data changed inside subroutines.
583*
584 isame( 1 ) = transa.EQ.tranas
585 isame( 2 ) = transb.EQ.tranbs
586 isame( 3 ) = ms.EQ.m
587 isame( 4 ) = ns.EQ.n
588 isame( 5 ) = ks.EQ.k
589 isame( 6 ) = als.EQ.alpha
590 isame( 7 ) = lde( as, aa, laa )
591 isame( 8 ) = ldas.EQ.lda
592 isame( 9 ) = lde( bs, bb, lbb )
593 isame( 10 ) = ldbs.EQ.ldb
594 isame( 11 ) = bls.EQ.beta
595 IF( null )THEN
596 isame( 12 ) = lde( cs, cc, lcc )
597 ELSE
598 isame( 12 ) = lderes( 'GE', ' ', m, n, cs,
599 $ cc, ldc )
600 END IF
601 isame( 13 ) = ldcs.EQ.ldc
602*
603* If data was incorrectly changed, report
604* and return.
605*
606 same = .true.
607 DO 40 i = 1, nargs
608 same = same.AND.isame( i )
609 IF( .NOT.isame( i ) )
610 $ WRITE( nout, fmt = 9998 )i
611 40 CONTINUE
612 IF( .NOT.same )THEN
613 fatal = .true.
614 GO TO 120
615 END IF
616*
617 IF( .NOT.null )THEN
618*
619* Check the result.
620*
621 CALL dmmch( transa, transb, m, n, k,
622 $ alpha, a, nmax, b, nmax, beta,
623 $ c, nmax, ct, g, cc, ldc, eps,
624 $ err, fatal, nout, .true. )
625 errmax = max( errmax, err )
626* If got really bad answer, report and
627* return.
628 IF( fatal )
629 $ GO TO 120
630 END IF
631*
632 50 CONTINUE
633*
634 60 CONTINUE
635*
636 70 CONTINUE
637*
638 80 CONTINUE
639*
640 90 CONTINUE
641*
642 100 CONTINUE
643*
644 110 CONTINUE
645*
646* Report result.
647*
648 IF( errmax.LT.thresh )THEN
649 WRITE( nout, fmt = 9999 )sname, nc
650 ELSE
651 WRITE( nout, fmt = 9997 )sname, nc, errmax
652 END IF
653 GO TO 130
654*
655 120 CONTINUE
656 WRITE( nout, fmt = 9996 )sname
657 WRITE( nout, fmt = 9995 )nc, sname, transa, transb, m, n, k,
658 $ alpha, lda, ldb, beta, ldc
659*
660 130 CONTINUE
661 RETURN
662*
663 9999 FORMAT( ' ', a6, ' PASSED THE COMPUTATIONAL TESTS (', i6, ' CALL',
664 $ 'S)' )
665 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', i2, ' WAS CH',
666 $ 'ANGED INCORRECTLY *******' )
667 9997 FORMAT( ' ', a6, ' COMPLETED THE COMPUTATIONAL TESTS (', i6, ' C',
668 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', f8.2,
669 $ ' - SUSPECT *******' )
670 9996 FORMAT( ' ******* ', a6, ' FAILED ON CALL NUMBER:' )
671 9995 FORMAT( 1x, i6, ': ', a6, '(''', a1, ''',''', a1, ''',',
672 $ 3( i3, ',' ), f4.1, ', A,', i3, ', B,', i3, ',', f4.1, ', ',
673 $ 'C,', i3, ').' )
674 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
675 $ '******' )
676*
677* End of DCHK1
678*
lde
logical function lde(ri, rj, lr)
Definition dblat2.f:2970
lderes
logical function lderes(type, uplo, m, n, aa, as, lda)
Definition dblat2.f:3000
dmake
subroutine dmake(type, uplo, diag, m, n, a, nmax, aa, lda, kl, ku, reset, transl)
Definition dblat2.f:2678
dmmch
subroutine dmmch(transa, transb, m, n, kk, alpha, a, lda, b, ldb, beta, c, ldc, ct, g, cc, ldcc, eps, err, fatal, nout, mv)
Definition dblat3.f:2594
dgemm
subroutine dgemm(transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
DGEMM
Definition dgemm.f:188
Here is the call graph for this function: