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

◆ dchk1()

subroutine dchk1 ( character*6  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 392 of file dblat3.f.

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