auxtest()

subroutine auxtest	(	integer	outnum,
		integer, dimension(memlen)	mem,
		integer	memlen
	)

Definition at line 680 of file blacstest.f.

*
*     .. Scalar Arguments ..
      INTEGER OUTNUM, MEMLEN
*     ..
*     .. Array Arguments ..
      INTEGER MEM(MEMLEN)
*     ..
*     .. External Functions ..
      LOGICAL  ALLPASS
      INTEGER  IBTMYPROC, IBTMSGID, BLACS_PNUM
      DOUBLE PRECISION DWALLTIME00
      EXTERNAL allpass, ibtmyproc, ibtmsgid, blacs_pnum
      EXTERNAL dwalltime00
*     ..
*     .. External Subroutines ..
      EXTERNAL blacs_pinfo, blacs_gridinit, blacs_gridmap
      EXTERNAL blacs_freebuff, blacs_gridexit, blacs_abort
      EXTERNAL blacs_gridinfo, blacs_pcoord, blacs_barrier
      EXTERNAL blacs_set
*     ..
*     .. Local Scalars ..
      LOGICAL AUXPASSED, PASSED, IPRINT
      INTEGER NPROCS, NPROW, NPCOL, MYROW, MYCOL, CTXT, CTXT2, LDA
      INTEGER I, J, K
      DOUBLE PRECISION DTIME, DEPS
*     ..
*     .. Local Arrays ..
      DOUBLE PRECISION START(2), STST(2), KEEP(2)
*     ..
*     .. Executable Statements ..
*
      iprint = ( ibtmyproc() .EQ. 0 )
      IF( iprint ) THEN
         WRITE(outnum,*) '  '
         WRITE(outnum,1000)
         WRITE(outnum,*) '  '
      END IF
      CALL blacs_pinfo( i, nprocs )
      IF( nprocs .LT. 2 ) THEN
         IF( iprint )
     $      WRITE(outnum,*) 'NOT ENOUGH PROCESSES TO PERFORM AUXTESTS'
         RETURN
      END IF
*
*     Make sure BLACS_PNUM and BLACS_PCOORD are inverses of each other
*
      IF( iprint ) THEN
         WRITE(outnum,*) ' '
         WRITE(outnum,*) 'RUNNING BLACS_PNUM/BLACS_PCOORD TEST'
      END IF
      passed = .true.
      nprocs = nprocs - mod(nprocs,2)
      CALL blacs_get( 0, 0, ctxt )
      CALL blacs_gridinit( ctxt, 'r', 1, nprocs )
      CALL blacs_gridinfo( ctxt, nprow, npcol, myrow, mycol )
      IF( myrow.GE.nprow .OR. mycol.GE.npcol ) GOTO 100
      DO 10 i = 1, nprocs
         k = blacs_pnum( ctxt, 0, i-1 )
         CALL blacs_pcoord( ctxt,  blacs_pnum( ctxt, 0, i-1 ), j, k )
         IF( passed ) passed = ( j.EQ.0 .AND. k.EQ.i-1 )
   10 CONTINUE
      k = 1
      IF( passed ) k = 0
      CALL igsum2d( ctxt, 'a', ' ', 1, 1, k, 1, -1, 0 )
      passed = ( k .EQ. 0 )
      auxpassed = passed
      IF( iprint ) THEN
         IF( passed ) THEN
            WRITE(outnum,*) 'PASSED  BLACS_PNUM/BLACS_PCOORD TEST'
         ELSE
            WRITE(outnum,*) 'FAILED  BLACS_PNUM/BLACS_PCOORD TEST'
         END IF
         WRITE(outnum,*) '  '
      END IF
*
*     Test to see if DGSUM2D is repeatable when repeatability flag is set
*     Skip test if DGSUM2D is repeatable when repeatability flag is not set
*     NOTE: do not change the EPS calculation loop; it is figured in this
*           strange way so that it ports across platforms
*
      IF( iprint ) WRITE(outnum,*) 'RUNNING REPEATABLE SUM TEST'
      j = 0
   12 CONTINUE
      passed = .true.
      start(1) = 1.0d0
   15 CONTINUE
         deps = start(1)
         start(1) = start(1) / 2.0d0
         stst(1) = 1.0d0 + start(1)
      IF (stst(1) .NE. 1.0d0) GOTO 15
*
      start(1) = deps / dble(npcol-1)
      IF (mycol .EQ. 3) start(1) = 1.0d0
      start(2) = 7.00005d0 * npcol
      stst(1) = start(1)
      stst(2) = start(2)
      CALL blacs_set(ctxt, 15, j)
      CALL dgsum2d(ctxt, 'a', 'f', 2, 1, stst, 2, -1, 0)
      keep(1) = stst(1)
      keep(2) = stst(2)
      DO 30 i = 1, 3
*
*        Have a different guy waste time so he enters combine last
*
         IF (mycol .EQ. i) THEN
             dtime = dwalltime00()
   20        CONTINUE
             IF (dwalltime00() - dtime .LT. 2.0d0) GOTO 20
         END IF
         stst(1) = start(1)
         stst(2) = start(2)
         CALL dgsum2d(ctxt, 'a', 'f', 2, 1, stst, 2, -1, 0)
         IF ( (keep(1).NE.stst(1)) .OR. (keep(2).NE.stst(2)) )
     $      passed = .false.
   30 CONTINUE
      k = 1
      IF (passed) k = 0
      CALL igsum2d( ctxt, 'a', ' ', 1, 1, k, 1, -1, 0 )
      passed = (k .EQ. 0)
      IF (j .EQ. 0) THEN
         IF (.NOT.passed) THEN
            j = 1
            GOTO 12
         ELSE IF( iprint ) THEN
            WRITE(outnum,*) 'SKIPPED REPEATABLE SUM TEST'
            WRITE(outnum,*) ' '
         END IF
      END IF
*
      IF (j .EQ. 1) THEN
         auxpassed = auxpassed .AND. passed
         IF( iprint ) THEN
            IF( passed ) THEN
               WRITE(outnum,*) 'PASSED  REPEATABLE SUM TEST'
            ELSE
               WRITE(outnum,*) 'FAILED  REPEATABLE SUM TEST'
            END IF
            WRITE(outnum,*) ' '
         END IF
      END IF
*
*     Test BLACS_GRIDMAP: force a column major ordering, starting at an
*     arbitrary processor
*
      passed = .true.
      IF( iprint ) WRITE(outnum,*) 'RUNNING BLACS_GRIDMAP TEST'
      nprow = 2
      npcol = nprocs / nprow
      DO 40 i = 0, nprocs-1
         mem(i+1) = blacs_pnum( ctxt, 0, mod(i+npcol, nprocs) )
   40 CONTINUE
      CALL blacs_get( ctxt, 10, ctxt2 )
      CALL blacs_gridmap( ctxt2, mem, nprow, nprow, npcol )
      CALL blacs_gridinfo( ctxt2, nprow, npcol, myrow, mycol )
      passed = ( nprow.EQ.2 .AND. npcol.EQ.nprocs/2 )
*
*     Fan in pids for final check: Note we assume SD/RV working
*
      IF( passed ) THEN
         k = blacs_pnum( ctxt2, myrow, mycol )
         IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
            DO 60 j = 0, npcol-1
               DO 50 i = 0, nprow-1
                  IF( i.NE.0 .OR. j.NE.0 )
     $               CALL igerv2d( ctxt2, 1, 1, k, 1, i, j )
                  IF ( passed )
     $               passed = ( k .EQ. blacs_pnum(ctxt2, i, j) )
   50          CONTINUE
   60       CONTINUE
         ELSE
            CALL igesd2d( ctxt2, 1, 1, k, 1, 0, 0 )
         END IF
      END IF
      k = 1
      IF ( passed ) k = 0
      CALL igsum2d( ctxt, 'a', ' ', 1, 1, k, 1, -1, 0 )
      passed = ( k .EQ. 0 )
      auxpassed = auxpassed .AND. passed
      IF( iprint ) THEN
         IF( passed ) THEN
            WRITE(outnum,*) 'PASSED  BLACS_GRIDMAP TEST'
         ELSE
            WRITE(outnum,*) 'FAILED  BLACS_GRIDMAP TEST'
         END IF
         WRITE(outnum,*) ' '
      END IF
*
      IF( iprint ) WRITE(outnum,*) 'CALL BLACS_FREEBUFF'
      CALL blacs_freebuff( ctxt, 0 )
      CALL blacs_freebuff( ctxt, 1 )
      j = 0
      CALL igsum2d( ctxt2, 'All', ' ', 1, 1, j, 1, -1, mycol )
      IF( iprint ) THEN
         WRITE(outnum,*) 'DONE BLACS_FREEBUFF'
         WRITE(outnum,*) ' '
      END IF
*
*     Make sure barriers don't interfere with each other
*
      IF( iprint ) WRITE(outnum,*) 'CALL BARRIER'
      CALL blacs_barrier(ctxt2, 'A')
      CALL blacs_barrier(ctxt2, 'R')
      CALL blacs_barrier(ctxt2, 'C')
      CALL blacs_barrier(ctxt2, 'R')
      CALL blacs_barrier(ctxt2, 'A')
      CALL blacs_barrier(ctxt2, 'C')
      CALL blacs_barrier(ctxt2, 'C')
      CALL blacs_barrier(ctxt2, 'R')
      CALL blacs_barrier(ctxt2, 'A')
      j = 0
      CALL igsum2d( ctxt2, 'All', ' ', 1, 1, j, 1, -1, mycol )
      IF( iprint ) THEN
         WRITE(outnum,*) 'DONE BARRIER'
         WRITE(outnum,*) ' '
      END IF
*
*     Ensure contiguous sends are locally-blocking
*
      IF( iprint ) THEN
         WRITE(outnum,*) 'The following tests will hang if your BLACS'//
     $                   ' are not locally blocking:'
         WRITE(outnum,*) 'RUNNING LOCALLY-BLOCKING CONTIGUOUS SEND TEST'
      END IF
      k = min( memlen, 50000 )
*
*     Initialize send buffer
*
      DO 70 j = 1, k
         mem(j) = 1
   70 CONTINUE
*
      IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
         CALL igesd2d( ctxt2, k, 1, mem, k, nprow-1, npcol-1 )
         CALL igesd2d( ctxt2, k, 1, mem, k, nprow-1, npcol-1 )
         CALL igesd2d( ctxt2, k, 1, mem, k, nprow-1, npcol-1 )
         CALL igerv2d( ctxt2, k, 1, mem, k, nprow-1, npcol-1 )
         CALL igerv2d( ctxt2, k, 1, mem, k, nprow-1, npcol-1 )
         CALL igerv2d( ctxt2, k, 1, mem, k, nprow-1, npcol-1 )
      ELSE IF( myrow.EQ.nprow-1 .AND. mycol.EQ.npcol-1 ) THEN
         CALL igesd2d( ctxt2, k, 1, mem, k, 0, 0 )
         CALL igesd2d( ctxt2, k, 1, mem, k, 0, 0 )
         CALL igesd2d( ctxt2, k, 1, mem, k, 0, 0 )
         CALL igerv2d( ctxt2, k, 1, mem, k, 0, 0 )
         CALL igerv2d( ctxt2, k, 1, mem, k, 0, 0 )
         CALL igerv2d( ctxt2, k, 1, mem, k, 0, 0 )
      END IF
      j = 0
      CALL igsum2d( ctxt2, 'All', ' ', 1, 1, j, 1, -1, mycol )
      IF( iprint )
     $   WRITE(outnum,*) 'PASSED  LOCALLY-BLOCKING CONTIGUOUS SEND TEST'
*
*     Ensure non-contiguous sends are locally-blocking
*
      j = 4
      lda = k / j
      i = max( 2, lda / 4 )
      IF( iprint )
     $   WRITE(outnum,*) 'RUNNING LOCALLY-BLOCKING NON-CONTIGUOUS '//
     $                   'SEND TEST'
      IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
         CALL igesd2d( ctxt2, i, j, mem, lda, nprow-1, npcol-1 )
         CALL igesd2d( ctxt2, i, j, mem, lda, nprow-1, npcol-1 )
         CALL igesd2d( ctxt2, i, j, mem, lda, nprow-1, npcol-1 )
         CALL igerv2d( ctxt2, i, j, mem, lda, nprow-1, npcol-1 )
         CALL igerv2d( ctxt2, i, j, mem, lda, nprow-1, npcol-1 )
         CALL igerv2d( ctxt2, i, j, mem, lda, nprow-1, npcol-1 )
      ELSE IF( myrow.EQ.nprow-1 .AND. mycol.EQ.npcol-1 ) THEN
         CALL igesd2d( ctxt2, i, j, mem, lda, 0, 0 )
         CALL igesd2d( ctxt2, i, j, mem, lda, 0, 0 )
         CALL igesd2d( ctxt2, i, j, mem, lda, 0, 0 )
         CALL igerv2d( ctxt2, i, j, mem, lda, 0, 0 )
         CALL igerv2d( ctxt2, i, j, mem, lda, 0, 0 )
         CALL igerv2d( ctxt2, i, j, mem, lda, 0, 0 )
      END IF
      CALL igsum2d( ctxt2, 'All', ' ', 1, 1, j, 1, -1, mycol )
      IF( iprint ) THEN
         WRITE(outnum,*)'PASSED  LOCALLY-BLOCKING NON-CONTIGUOUS '//
     $                  'SEND TEST'
         WRITE(outnum,*) '  '
      END IF
*
*     Note that we already tested the message ID setting/getting in
*     first call to IBTMSGID()
*
      IF( iprint ) WRITE(outnum,*) 'RUNNING BLACS_SET/BLACS_GET TESTS'
      j = 0
      CALL blacs_set( ctxt2, 11, 3 )
      CALL blacs_set( ctxt2, 12, 2 )
      CALL blacs_get( ctxt2, 12, i )
      CALL blacs_get( ctxt2, 11, k )
      IF( k.NE.3 ) j = j + 1
      IF( i.NE.2 ) j = j + 1
      CALL blacs_set( ctxt2, 13, 3 )
      CALL blacs_set( ctxt2, 14, 2 )
      CALL blacs_get( ctxt2, 14, i )
      CALL blacs_get( ctxt2, 13, k )
      IF( k.NE.3 ) j = j + 1
      IF( i.NE.2 ) j = j + 1
*
*     See if anyone had error, and print result
*
      CALL igsum2d( ctxt2, 'All', ' ', 1, 1, j, 1, -1, mycol )
      passed = (j .EQ. 0)
      auxpassed = auxpassed .AND. passed
      IF( iprint ) THEN
         IF( passed ) THEN
            WRITE(outnum,*) 'PASSED  BLACS_SET/BLACS_GET TESTS'
         ELSE
            WRITE(outnum,*) 'FAILED  BLACS_SET/BLACS_GET TESTS'
         END IF
         WRITE(outnum,*) ' '
      END IF
*
      IF( iprint ) WRITE(outnum,*) 'CALL BLACS_GRIDEXIT'
      CALL blacs_gridexit(ctxt)
      CALL blacs_gridexit(ctxt2)
      IF( iprint ) THEN
         WRITE(outnum,*) 'DONE BLACS_GRIDEXIT'
         WRITE(outnum,*) '  '
      END IF
*
  100 CONTINUE
*
      passed = allpass(auxpassed)
      IF( iprint ) THEN
         WRITE(outnum,*) 'The final auxiliary test is for BLACS_ABORT.'
         WRITE(outnum,*) 'Immediately after this message, all '//
     $                   'processes should be killed.'
         WRITE(outnum,*) 'If processes survive the call, your BLACS_'//
     $                   'ABORT is incorrect.'
      END IF
      CALL blacs_pinfo( i, nprocs )
      CALL blacs_get( 0, 0, ctxt )
      CALL blacs_gridinit( ctxt, 'r', 1, nprocs )
      CALL blacs_barrier(ctxt, 'A')
      CALL blacs_gridinfo( ctxt, nprow, npcol, myrow, mycol )
*
*     Test BLACS_ABORT
*
      IF( myrow.EQ.nprow/2 .AND. mycol.EQ.npcol/2 ) THEN
         CALL blacs_abort( ctxt, -1 )
*
*     Other procs try to cause a hang: should be killed by BLACS_ABORT
*
      ELSE
         i = 1
110      CONTINUE
            i = i + 3
            i = i - 2
            i = i - 1
         IF( i.EQ.1 ) GOTO 110
      end if
*
 1000 FORMAT('AUXILIARY TESTS: BEGIN.')
      RETURN

Here is the caller graph for this function: