LAPACK  3.6.1
LAPACK: Linear Algebra PACKage
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 398 of file dblat3.f.

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

Here is the call graph for this function: