416
  417
  418
  419
  420
  421
  422
  423
  424
  425
  426
  427
  428      COMPLEX*16         ZERO
  429      parameter( zero = ( 0.0d0, 0.0d0 ) )
  430      DOUBLE PRECISION   RZERO
  431      parameter( rzero = 0.0d0 )
  432
  433      DOUBLE PRECISION   EPS, THRESH
  434      INTEGER            NALF, NBET, NIDIM, NMAX, NOUT, NTRA
  435      LOGICAL            FATAL, REWI, TRACE
  436      CHARACTER*7        SNAME
  437
  438      COMPLEX*16         A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
  439     $                   AS( NMAX*NMAX ), B( NMAX, NMAX ),
  440     $                   BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ),
  441     $                   C( NMAX, NMAX ), CC( NMAX*NMAX ),
  442     $                   CS( NMAX*NMAX ), CT( NMAX )
  443      DOUBLE PRECISION   G( NMAX )
  444      INTEGER            IDIM( NIDIM )
  445
  446      COMPLEX*16         ALPHA, ALS, BETA, BLS
  447      DOUBLE PRECISION   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
  455      LOGICAL            ISAME( 13 )
  456
  457      LOGICAL            LZE, LZERES
  459
  461
  462      INTRINSIC          max
  463
  464      INTEGER            INFOT, NOUTC
  465      LOGICAL            LERR, OK
  466
  467      COMMON             /infoc/infot, noutc, ok, lerr
  468
  469      DATA               ich/'NTC'/
  470
  471
  472      nargs = 13
  473      nc = 0
  474      reset = .true.
  475      errmax = rzero
  476
  477      DO 110 im = 1, nidim
  478         m = idim( im )
  479
  480         DO 100 in = 1, nidim
  481            n = idim( in )
  482
  483            ldc = m
  484            IF( ldc.LT.nmax )
  485     $         ldc = ldc + 1
  486
  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
  507                  lda = ma
  508                  IF( lda.LT.nmax )
  509     $               lda = lda + 1
  510
  511                  IF( lda.GT.nmax )
  512     $               GO TO 80
  513                  laa = lda*na
  514
  515
  516
  517                  CALL zmake( 
'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
  532                     ldb = mb
  533                     IF( ldb.LT.nmax )
  534     $                  ldb = ldb + 1
  535
  536                     IF( ldb.GT.nmax )
  537     $                  GO TO 70
  538                     lbb = ldb*nb
  539
  540
  541
  542                     CALL zmake( 
'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
  552
  553                           CALL zmake( 
'GE', 
' ', 
' ', m, n, c, nmax,
 
  554     $                                 cc, ldc, reset, zero )
  555
  556                           nc = nc + 1
  557
  558
  559
  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
  582
  583                           IF( trace )
  584     $                        WRITE( ntra, fmt = 9995 )nc, sname,
  585     $                        transa, transb, m, n, k, alpha, lda, ldb,
  586     $                        beta, ldc
  587                           IF( rewi )
  588     $                        rewind ntra
  589                           CALL zgemm( transa, transb, m, n, k, alpha,
 
  590     $                                 aa, lda, bb, ldb, beta, cc, ldc )
  591
  592
  593
  594                           IF( .NOT.ok )THEN
  595                              WRITE( nout, fmt = 9994 )
  596                              fatal = .true.
  597                              GO TO 120
  598                           END IF
  599
  600
  601
  602                           isame( 1 ) = transa.EQ.tranas
  603                           isame( 2 ) = transb.EQ.tranbs
  604                           isame( 3 ) = ms.EQ.m
  605                           isame( 4 ) = ns.EQ.n
  606                           isame( 5 ) = ks.EQ.k
  607                           isame( 6 ) = als.EQ.alpha
  608                           isame( 7 ) = 
lze( as, aa, laa )
 
  609                           isame( 8 ) = ldas.EQ.lda
  610                           isame( 9 ) = 
lze( bs, bb, lbb )
 
  611                           isame( 10 ) = ldbs.EQ.ldb
  612                           isame( 11 ) = bls.EQ.beta
  613                           IF( null )THEN
  614                              isame( 12 ) = 
lze( cs, cc, lcc )
 
  615                           ELSE
  616                              isame( 12 ) = 
lzeres( 
'GE', 
' ', m, n, cs,
 
  617     $                                      cc, ldc )
  618                           END IF
  619                           isame( 13 ) = ldcs.EQ.ldc
  620
  621
  622
  623
  624                           same = .true.
  625                           DO 40 i = 1, nargs
  626                              same = same.AND.isame( i )
  627                              IF( .NOT.isame( i ) )
  628     $                           WRITE( nout, fmt = 9998 )i
  629   40                      CONTINUE
  630                           IF( .NOT.same )THEN
  631                              fatal = .true.
  632                              GO TO 120
  633                           END IF
  634
  635                           IF( .NOT.null )THEN
  636
  637
  638
  639                              CALL zmmch( transa, transb, m, n, k,
 
  640     $                                    alpha, a, nmax, b, nmax, beta,
  641     $                                    c, nmax, ct, g, cc, ldc, eps,
  642     $                                    err, fatal, nout, .true. )
  643                              errmax = max( errmax, err )
  644
  645
  646                              IF( fatal )
  647     $                           GO TO 120
  648                           END IF
  649
  650   50                   CONTINUE
  651
  652   60                CONTINUE
  653
  654   70             CONTINUE
  655
  656   80          CONTINUE
  657
  658   90       CONTINUE
  659
  660  100    CONTINUE
  661
  662  110 CONTINUE
  663
  664
  665
  666      IF( errmax.LT.thresh )THEN
  667         WRITE( nout, fmt = 9999 )sname, nc
  668      ELSE
  669         WRITE( nout, fmt = 9997 )sname, nc, errmax
  670      END IF
  671      GO TO 130
  672
  673  120 CONTINUE
  674      WRITE( nout, fmt = 9996 )sname
  675      WRITE( nout, fmt = 9995 )nc, sname, transa, transb, m, n, k,
  676     $   alpha, lda, ldb, beta, ldc
  677
  678  130 CONTINUE
  679      RETURN
  680
  681 9999 FORMAT( ' ', a6, ' PASSED THE COMPUTATIONAL TESTS (', i6, ' CALL',
  682     $      'S)' )
  683 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', i2, ' WAS CH',
  684     $      'ANGED INCORRECTLY *******' )
  685 9997 FORMAT( ' ', a6, ' COMPLETED THE COMPUTATIONAL TESTS (', i6, ' C',
  686     $      'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', f8.2,
  687     $      ' - SUSPECT *******' )
  688 9996 FORMAT( ' ******* ', a6, ' FAILED ON CALL NUMBER:' )
  689 9995 FORMAT( 1x, i6, ': ', a6, '(''', a1, ''',''', a1, ''',',
  690     $      3( i3, ',' ), '(', f4.1, ',', f4.1, '), A,', i3, ', B,', i3,
  691     $      ',(', f4.1, ',', f4.1, '), C,', i3, ').' )
  692 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
  693     $      '******' )
  694
  695
  696
subroutine zgemm(transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
ZGEMM
logical function lze(ri, rj, lr)
logical function lzeres(type, uplo, m, n, aa, as, lda)
subroutine zmake(type, uplo, diag, m, n, a, nmax, aa, lda, kl, ku, reset, transl)
subroutine zmmch(transa, transb, m, n, kk, alpha, a, lda, b, ldb, beta, c, ldc, ct, g, cc, ldcc, eps, err, fatal, nout, mv)