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

◆ dchk1()

subroutine dchk1 ( character*13 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,
integer iorder )

Definition at line 433 of file c_dblat3.f.

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