schkamx()

subroutine schkamx	(	character*1	scope,
		integer	ictxt,
		integer	m,
		integer	n,
		real, dimension(lda,*)	a,
		integer	lda,
		integer, dimension(*)	ra,
		integer, dimension(*)	ca,
		integer	ldi,
		integer	testnum,
		integer	maxerr,
		integer	nerr,
		integer, dimension(6, maxerr)	erribuf,
		real, dimension(2, maxerr)	errdbuf,
		integer, dimension(*)	iseed,
		real, dimension(*)	vals
	)

Definition at line 15867 of file blacstest.f.

*
*     .. Scalar Arguments ..
      CHARACTER*1 SCOPE
      INTEGER ICTXT, M, N, LDA, LDI, TESTNUM, MAXERR, NERR
*     ..
*     .. Array Arguments ..
      INTEGER RA(*), CA(*), ERRIBUF(6, MAXERR), ISEED(*)
      REAL A(LDA,*), ERRDBUF(2, MAXERR), VALS(*)
*     ..
*     .. External Functions ..
      INTEGER IBTMYPROC, IBTNPROCS, IBTSPNUM
      REAL SBTEPS, SBTABS
      REAL SBTRAN
      EXTERNAL ibtmyproc, ibtnprocs, ibtspnum, sbtran, sbteps, sbtabs
*     ..
*     .. External Subroutines ..
      EXTERNAL ibtspcoord
*     ..
*     .. Local Scalars ..
      LOGICAL ERROR
      INTEGER NPROCS, NNODES, NPROW, NPCOL, MYROW, MYCOL, RAMX, CAMX
      INTEGER IAMX, I, J, K, H, DEST, NODE
      REAL EPS
*     ..
*     .. Executable Statements ..
*
      nprocs = ibtnprocs()
      eps = sbteps()
      CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
      dest = myrow*nprocs + mycol
*
*     Set up seeds to match those used by each proc's genmat call
*
      IF( scope .EQ. 'R' ) THEN
         nnodes = npcol
         DO 10 i = 0, nnodes-1
            node = myrow * nprocs + i
            iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
            iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
            iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
            iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
   10    CONTINUE
      ELSE IF( scope .EQ. 'C' ) THEN
         nnodes = nprow
         DO 20 i = 0, nnodes-1
            node = i * nprocs + mycol
            iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
            iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
            iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
            iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
   20    CONTINUE
      ELSE
         nnodes = nprow * npcol
         DO 30 i = 0, nnodes-1
            node = (i / npcol) * nprocs + mod(i, npcol)
            iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
            iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
            iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
            iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
   30    CONTINUE
      END IF
*
      DO 100 j = 1, n
         DO 90 i = 1, m
            h = (j-1)*ldi + i
            vals(1) = sbtran( iseed )
            iamx = 1
            IF( nnodes .GT. 1 ) THEN
               DO 40 k = 1, nnodes-1
                  vals(k+1) =  sbtran( iseed(k*4+1) )
                  IF( sbtabs( vals(k+1) ) .GT. sbtabs( vals(iamx) ) )
     $               iamx = k + 1
   40          CONTINUE
            END IF
*
*           If BLACS have not returned same value we've chosen
*
            IF( a(i,j) .NE. vals(iamx) ) THEN
*
*              If we have RA and CA arrays
*
               IF( ldi .NE. -1 ) THEN
*
*                 Any number having the same absolute value is a valid max
*
                  k = ibtspnum( scope, ra(h), ca(h), npcol ) + 1
                  IF( k.GT.0 .AND. k.LE.nnodes ) THEN
                     error = sbtabs( vals(k) ).NE.sbtabs( vals(iamx) )
                     IF( .NOT.error ) iamx = k
                  ELSE
                     error = .true.
                  END IF
               ELSE
*
*                 Error if BLACS answer not same absolute value, or if it
*                 was not really in the numbers being compared
*
                  error = ( sbtabs( a(i,j) ) .NE. sbtabs( vals(iamx) ) )
                  IF( .NOT.error ) THEN
                     DO 50 k = 1, nnodes
                        IF( vals(k) .EQ. a(i,j) ) GOTO 60
   50                CONTINUE
                     error = .true.
   60                CONTINUE
                  ENDIF
               END IF
*
*              If the value is in error
*
               IF( error ) THEN
                  nerr = nerr + 1
                  erribuf(1, nerr) = testnum
                  erribuf(2, nerr) = nnodes
                  erribuf(3, nerr) = dest
                  erribuf(4, nerr) = i
                  erribuf(5, nerr) = j
                  erribuf(6, nerr) = 5
                  errdbuf(1, nerr) = a(i,j)
                  errdbuf(2, nerr) = vals(iamx)
               END IF
            END IF
*
*           If they are defined, make sure coordinate entries are OK
*
            IF( ldi .NE. -1 ) THEN
               k = ibtspnum( scope, ra(h), ca(h), npcol ) + 1
               IF( k.NE.iamx ) THEN
*
*                 Make sure more than one proc doesn't have exact same value
*                 (and therefore there may be more than one valid coordinate
*                 for a single value)
*
                  IF( k.GT.nnodes .OR. k.LT.1 ) THEN
                     error = .true.
                  ELSE
                     error = ( vals(k) .NE. vals(iamx) )
                  END IF
                  IF( error ) THEN
                     CALL ibtspcoord( scope, iamx-1, myrow, mycol,
     $                                npcol, ramx, camx )
                     IF( ramx .NE. ra(h) ) THEN
                        nerr = nerr + 1
                        erribuf(1, nerr) = testnum
                        erribuf(2, nerr) = nnodes
                        erribuf(3, nerr) = dest
                        erribuf(4, nerr) = i
                        erribuf(5, nerr) = j
                        erribuf(6, nerr) = -5
                        errdbuf(1, nerr) = ra(h)
                        errdbuf(2, nerr) = ramx
                     END IF
                     IF( camx .NE. ca(h) ) THEN
                        nerr = nerr + 1
                        erribuf(1, nerr) = testnum
                        erribuf(2, nerr) = nnodes
                        erribuf(3, nerr) = dest
                        erribuf(4, nerr) = i
                        erribuf(5, nerr) = j
                        erribuf(6, nerr) = -15
                        errdbuf(1, nerr) = ca(h)
                        errdbuf(2, nerr) = camx
                     END IF
                  END IF
               END IF
            END IF
   90    CONTINUE
  100 CONTINUE
*
      RETURN
*
*     End of SCHKAMX
*

Here is the call graph for this function:

Here is the caller graph for this function: