sprinterrs()

subroutine sprinterrs	(	integer	outnum,
		integer	maxerr,
		integer	nerr,
		integer, dimension(6, maxerr)	erribuf,
		real, dimension(2, maxerr)	errdbuf,
		logical	counting,
		integer, dimension(*)	tfailed
	)

Definition at line 8210 of file blacstest.f.

*
*  -- BLACS tester (version 1.0) --
*  University of Tennessee
*  December 15, 1994
*
*
*     .. Scalar Arguments ..
      LOGICAL COUNTING
      INTEGER OUTNUM, MAXERR, NERR
*     ..
*     .. Array Arguments ..
      INTEGER ERRIBUF(6, MAXERR), TFAILED(*)
      REAL ERRDBUF(2, MAXERR)
*     ..
*
*  Purpose
*  =======
*  SPRINTERRS: Print errors that have been recorded
*
*  Arguments
*  =========
*  OUTNUM   (input) INTEGER
*           Device number for output.
*
*  MAXERR   (input) INTEGER
*           Max number of errors that can be stored in ERRIBUFF or
*           ERRSBUFF
*
*  NERR     (output) INTEGER
*           The number of errors that have been found.
*
*  ERRIBUF  (output) INTEGER array, dimension (6,MAXERRS)
*           Buffer in which to store integer error information.  It will
*           be built up in the following format for the call to TSEND.
*           All integer information is recorded in the following 6-tuple
*           {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured:
*             SRC = RSRC * NPROCS + CSRC
*             DEST = RDEST * NPROCS + CDEST
*             WHAT
*              = 1 : Error in pre-padding
*              = 2 : Error in post-padding
*              = 3 : Error in LDA-M gap
*              = 4 : Error in complementory triangle
*              ELSE: Error in matrix
*           If there are more errors than can fit in the error buffer,
*           the error number will indicate the actual number of errors
*           found, but the buffer will be truncated to the maximum
*           number of errors which can fit.
*
*  ERRDBUF  (output) @(doctype) array, dimension (2, MAXERRS)
*           Buffer in which to store error data information.
*           {Incorrect, Predicted}
*
*  TFAILED (input/ourput) INTEGER array, dimension NTESTS
*          Workspace used to keep track of which tests failed.
*          This array not accessed unless COUNTING is true.
*
*  ===================================================================
*
*     .. Parameters ..
      INTEGER ERR_PRE, ERR_POST, ERR_GAP, ERR_TRI, ERR_MAT
      parameter( err_pre = 1, err_post = 2, err_gap = 3, err_tri = 4 )
      parameter( err_mat = 5 )
*     ..
*     .. External Functions ..
      INTEGER IBTMYPROC, IBTNPROCS
      EXTERNAL ibtmyproc, ibtnprocs
*     ..
*     .. Local Scalars ..
      CHARACTER*1 MAT
      LOGICAL MATISINT
      INTEGER OLDTEST, NPROCS, PROW, PCOL, I, ERRTYPE
*     ..
*     .. Executable Statements ..
*
      IF( (ibtmyproc().NE.0) .OR. (nerr.LE.0) ) RETURN
      oldtest = -1
      nprocs = ibtnprocs()
      prow = erribuf(3,1) / nprocs
      pcol = mod( erribuf(3,1), nprocs )
      IF( nerr .GT. maxerr ) WRITE(outnum,13000)
*
      DO 20 i = 1, min( nerr, maxerr )
         IF( erribuf(1,i) .NE. oldtest ) THEN
            IF( oldtest .NE. -1 )
     $         WRITE(outnum,12000) prow, pcol, oldtest
            WRITE(outnum,*) '  '
            WRITE(outnum,1000) prow, pcol, erribuf(1,i)
            IF( counting ) tfailed( erribuf(1,i) ) = 1
            oldtest = erribuf(1, i)
         END IF
*
*        Print out error message depending on type of error
*
         errtype = erribuf(6, i)
         IF( errtype .LT. -10 ) THEN
            errtype = -errtype - 10
            mat = 'C'
            matisint = .true.
         ELSE IF( errtype .LT. 0 ) THEN
            errtype = -errtype
            mat = 'R'
            matisint = .true.
         ELSE
            matisint = .false.
         END IF
*
*        RA/CA arrays from MAX/MIN have different printing protocol
*
         IF( matisint ) THEN
            IF( erribuf(2, i) .EQ. -1 ) THEN
               WRITE(outnum,11000) erribuf(4,i), erribuf(5,i), mat,
     $            int( errdbuf(2,i) ), int( errdbuf(1,i) )
            ELSE IF( errtype .EQ. err_pre ) THEN
               WRITE(outnum,7000) erribuf(5,i), mat,
     $            int( errdbuf(2,i) ), int( errdbuf(1,i) )
            ELSE IF( errtype .EQ. err_post ) THEN
               WRITE(outnum,8000) erribuf(4,i), mat,
     $            int( errdbuf(2,i) ), int( errdbuf(1,i) )
            ELSE IF( errtype .EQ. err_gap ) THEN
               WRITE(outnum,9000) mat, erribuf(4,i), erribuf(5,i),
     $            int( errdbuf(2,i) ), int( errdbuf(1,i) )
            ELSE
               WRITE(outnum,10000) mat, erribuf(4,i), erribuf(5,i),
     $                             int( errdbuf(2,i) ),
     $                             int( errdbuf(1,i) )
            END IF
*
*        Have memory overwrites in matrix A
*
         ELSE
            IF( errtype .EQ. err_pre ) THEN
               WRITE(outnum,2000) erribuf(5,i), errdbuf(2,i),
     $                            errdbuf(1,i)
            ELSE IF( errtype .EQ. err_post ) THEN
               WRITE(outnum,3000) erribuf(4,i), errdbuf(2,i),
     $                            errdbuf(1,i)
            ELSE IF( errtype .EQ. err_gap ) THEN
               WRITE(outnum,4000) erribuf(4,i), erribuf(5,i),
     $                            errdbuf(2,i), errdbuf(1,i)
            ELSE IF( errtype .EQ. err_tri ) THEN
               WRITE(outnum,5000) erribuf(4,i), erribuf(5,i),
     $                            errdbuf(2,i), errdbuf(1,i)
            ELSE
               WRITE(outnum,6000) erribuf(4,i), erribuf(5,i),
     $                            errdbuf(2,i), errdbuf(1,i)
            END IF
         END IF
   20 CONTINUE
      WRITE(outnum,12000) prow, pcol, oldtest
*
 1000 FORMAT('PROCESS {',i4,',',i4,'} REPORTS ERRORS IN TEST#',i6,':')
 2000 FORMAT('   Buffer overwrite ',i4,
     $       ' elements before the start of A:',/,
     $       '   Expected=',g15.8,
     $       '; Received=',g15.8)
 3000 FORMAT('   Buffer overwrite ',i4,' elements after the end of A:',
     $       /,'   Expected=',g15.8,
     $       '; Received=',g15.8)
 4000 FORMAT('   LDA-M gap overwrite at postion (',i4,',',i4,'):',/,
     $       '   Expected=',g15.8,
     $       '; Received=',g15.8)
 5000 FORMAT('   Complementory triangle overwrite at A(',i4,',',i4,
     $       '):',/,'   Expected=',g15.8,
     $       '; Received=',g15.8)
 6000 FORMAT('   Invalid element at A(',i4,',',i4,'):',/,
     $       '   Expected=',g15.8,
     $       '; Received=',g15.8)
 7000 FORMAT('   Buffer overwrite ',i4,' elements before the start of ',
     $       a1,'A:',/,'   Expected=',i12,'; Received=',i12)
 8000 FORMAT('   Buffer overwrite ',i4,' elements after the end of ',
     $       a1,'A:',/,'   Expected=',i12,'; Received=',i12)
*
 9000 FORMAT('   LD',a1,'A-M gap overwrite at postion (',i4,',',i4,'):'
     $       ,/,'   Expected=',i12,'; Received=',i12)
*
10000 FORMAT('   Invalid element at ',a1,'A(',i4,',',i4,'):',/,
     $       '   Expected=',i12,'; Received=',i12)
11000 FORMAT('   Overwrite at position (',i4,',',i4,') of non-existent '
     $       ,a1,'A array.',/,'   Expected=',i12,'; Received=',i12)
12000 FORMAT('PROCESS {',i4,',',i4,'} DONE ERROR REPORT FOR TEST#',
     $       i6,'.')
13000 FORMAT('WARNING: There were more errors than could be recorded.',
     $       /,'Increase MEMELTS to get complete listing.')
      RETURN
*
*     End SPRINTERRS
*

Here is the caller graph for this function: