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

◆ dchk1()

subroutine dchk1 ( character*12  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 417 of file c_dblat3.f.

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