SCALAPACK 2.2.2
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches

◆ ichkamx()

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

Definition at line 15055 of file blacstest.f.

15058*
15059* .. Scalar Arguments ..
15060 CHARACTER*1 SCOPE
15061 INTEGER ICTXT, M, N, LDA, LDI, TESTNUM, MAXERR, NERR
15062* ..
15063* .. Array Arguments ..
15064 INTEGER RA(*), CA(*), ERRIBUF(6, MAXERR), ISEED(*)
15065 INTEGER A(LDA,*), ERRDBUF(2, MAXERR), VALS(*)
15066* ..
15067* .. External Functions ..
15068 INTEGER IBTMYPROC, IBTNPROCS, IBTSPNUM, IBTRAN, IBTABS
15069 EXTERNAL ibtmyproc, ibtnprocs, ibtspnum, ibtran
15070 EXTERNAL ibtabs
15071* ..
15072* .. External Subroutines ..
15073 EXTERNAL ibtspcoord
15074* ..
15075* .. Local Scalars ..
15076 LOGICAL ERROR
15077 INTEGER NPROCS, NNODES, NPROW, NPCOL, MYROW, MYCOL, RAMX, CAMX
15078 INTEGER IAMX, I, J, K, H, DEST, NODE
15079* ..
15080* .. Executable Statements ..
15081*
15082 nprocs = ibtnprocs()
15083 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
15084 dest = myrow*nprocs + mycol
15085*
15086* Set up seeds to match those used by each proc's genmat call
15087*
15088 IF( scope .EQ. 'R' ) THEN
15089 nnodes = npcol
15090 DO 10 i = 0, nnodes-1
15091 node = myrow * nprocs + i
15092 iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
15093 iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
15094 iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
15095 iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
15096 10 CONTINUE
15097 ELSE IF( scope .EQ. 'C' ) THEN
15098 nnodes = nprow
15099 DO 20 i = 0, nnodes-1
15100 node = i * nprocs + mycol
15101 iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
15102 iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
15103 iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
15104 iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
15105 20 CONTINUE
15106 ELSE
15107 nnodes = nprow * npcol
15108 DO 30 i = 0, nnodes-1
15109 node = (i / npcol) * nprocs + mod(i, npcol)
15110 iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
15111 iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
15112 iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
15113 iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
15114 30 CONTINUE
15115 END IF
15116*
15117 DO 100 j = 1, n
15118 DO 90 i = 1, m
15119 h = (j-1)*ldi + i
15120 vals(1) = ibtran( iseed )
15121 iamx = 1
15122 IF( nnodes .GT. 1 ) THEN
15123 DO 40 k = 1, nnodes-1
15124 vals(k+1) = ibtran( iseed(k*4+1) )
15125 IF( ibtabs( vals(k+1) ) .GT. ibtabs( vals(iamx) ) )
15126 $ iamx = k + 1
15127 40 CONTINUE
15128 END IF
15129*
15130* If BLACS have not returned same value we've chosen
15131*
15132 IF( a(i,j) .NE. vals(iamx) ) THEN
15133*
15134* If we have RA and CA arrays
15135*
15136 IF( ldi .NE. -1 ) THEN
15137*
15138* Any number having the same absolute value is a valid max
15139*
15140 k = ibtspnum( scope, ra(h), ca(h), npcol ) + 1
15141 IF( k.GT.0 .AND. k.LE.nnodes ) THEN
15142 error = ibtabs( vals(k) ).NE.ibtabs( vals(iamx) )
15143 IF( .NOT.error ) iamx = k
15144 ELSE
15145 error = .true.
15146 END IF
15147 ELSE
15148*
15149* Error if BLACS answer not same absolute value, or if it
15150* was not really in the numbers being compared
15151*
15152 error = ( ibtabs( a(i,j) ) .NE. ibtabs( vals(iamx) ) )
15153 IF( .NOT.error ) THEN
15154 DO 50 k = 1, nnodes
15155 IF( vals(k) .EQ. a(i,j) ) GOTO 60
15156 50 CONTINUE
15157 error = .true.
15158 60 CONTINUE
15159 ENDIF
15160 END IF
15161*
15162* If the value is in error
15163*
15164 IF( error ) THEN
15165 nerr = nerr + 1
15166 erribuf(1, nerr) = testnum
15167 erribuf(2, nerr) = nnodes
15168 erribuf(3, nerr) = dest
15169 erribuf(4, nerr) = i
15170 erribuf(5, nerr) = j
15171 erribuf(6, nerr) = 5
15172 errdbuf(1, nerr) = a(i,j)
15173 errdbuf(2, nerr) = vals(iamx)
15174 END IF
15175 END IF
15176*
15177* If they are defined, make sure coordinate entries are OK
15178*
15179 IF( ldi .NE. -1 ) THEN
15180 k = ibtspnum( scope, ra(h), ca(h), npcol ) + 1
15181 IF( k.NE.iamx ) THEN
15182*
15183* Make sure more than one proc doesn't have exact same value
15184* (and therefore there may be more than one valid coordinate
15185* for a single value)
15186*
15187 IF( k.GT.nnodes .OR. k.LT.1 ) THEN
15188 error = .true.
15189 ELSE
15190 error = ( vals(k) .NE. vals(iamx) )
15191 END IF
15192 IF( error ) THEN
15193 CALL ibtspcoord( scope, iamx-1, myrow, mycol,
15194 $ npcol, ramx, camx )
15195 IF( ramx .NE. ra(h) ) THEN
15196 nerr = nerr + 1
15197 erribuf(1, nerr) = testnum
15198 erribuf(2, nerr) = nnodes
15199 erribuf(3, nerr) = dest
15200 erribuf(4, nerr) = i
15201 erribuf(5, nerr) = j
15202 erribuf(6, nerr) = -5
15203 errdbuf(1, nerr) = ra(h)
15204 errdbuf(2, nerr) = ramx
15205 END IF
15206 IF( camx .NE. ca(h) ) THEN
15207 nerr = nerr + 1
15208 erribuf(1, nerr) = testnum
15209 erribuf(2, nerr) = nnodes
15210 erribuf(3, nerr) = dest
15211 erribuf(4, nerr) = i
15212 erribuf(5, nerr) = j
15213 erribuf(6, nerr) = -15
15214 errdbuf(1, nerr) = ca(h)
15215 errdbuf(2, nerr) = camx
15216 END IF
15217 END IF
15218 END IF
15219 END IF
15220 90 CONTINUE
15221 100 CONTINUE
15222*
15223 RETURN
15224*
15225* End of ICHKAMX
15226*
ibtspcoord
subroutine ibtspcoord(scope, pnum, myrow, mycol, npcol, prow, pcol)
Definition blacstest.f:14850
ibtran
integer function ibtran(iseed)
Definition blacstest.f:6486
ibtabs
integer function ibtabs(val)
Definition blacstest.f:12027
ibtspnum
integer function ibtspnum(scope, prow, pcol, npcol)
Definition blacstest.f:14870
ibtnprocs
integer function ibtnprocs()
Definition btprim.f:81
ibtmyproc
integer function ibtmyproc()
Definition btprim.f:47
Here is the call graph for this function:
Here is the caller graph for this function: