LAPACK  3.9.0
LAPACK: Linear Algebra PACKage

◆ 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 420 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 *
684 10003 FORMAT( ' ', a12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
685  $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
686  $ 'RATIO ', f8.2, ' - SUSPECT *******' )
687 10002 FORMAT( ' ', a12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
688  $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
689  $ 'RATIO ', f8.2, ' - SUSPECT *******' )
690 10001 FORMAT( ' ', a12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
691  $ ' (', i6, ' CALL', 'S)' )
692 10000 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 *
Here is the call graph for this function:
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:2511
lde
logical function lde(RI, RJ, LR)
Definition: dblat2.f:2945
dprcn1
subroutine dprcn1(NOUT, NC, SNAME, IORDER, TRANSA, TRANSB, M, N, K, ALPHA, LDA, LDB, BETA, LDC)
Definition: c_dblat3.f:708
dmake
subroutine dmake(TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL, KU, RESET, TRANSL)
Definition: dblat2.f:2653
lderes
logical function lderes(TYPE, UPLO, M, N, AA, AS, LDA)
Definition: dblat2.f:2975