LAPACK  3.10.1
LAPACK: Linear Algebra PACKage

◆ 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:2650
lde
logical function lde(RI, RJ, LR)
Definition: dblat2.f:2942
lderes
logical function lderes(TYPE, UPLO, M, N, AA, AS, LDA)
Definition: dblat2.f:2972
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: