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

◆ ichkamn()

subroutine ichkamn ( 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 18961 of file blacstest.f.

18964*
18965* .. Scalar Arguments ..
18966 CHARACTER*1 SCOPE
18967 INTEGER ICTXT, M, N, LDA, LDI, TESTNUM, MAXERR, NERR
18968* ..
18969* .. Array Arguments ..
18970 INTEGER RA(*), CA(*), ERRIBUF(6, MAXERR), ISEED(*)
18971 INTEGER A(LDA,*), ERRDBUF(2, MAXERR), VALS(*)
18972* ..
18973* .. External Functions ..
18974 INTEGER IBTMYPROC, IBTNPROCS, IBTSPNUM, IBTRAN, IBTABS
18975 EXTERNAL ibtmyproc, ibtnprocs, ibtspnum, ibtran
18976 EXTERNAL ibtabs
18977* ..
18978* .. External Subroutines ..
18979 EXTERNAL ibtspcoord
18980* ..
18981* .. Local Scalars ..
18982 LOGICAL ERROR
18983 INTEGER NPROCS, NNODES, NPROW, NPCOL, MYROW, MYCOL, RAMN, CAMN
18984 INTEGER IAMN, I, J, K, H, DEST, NODE
18985* ..
18986* .. Executable Statements ..
18987*
18988 nprocs = ibtnprocs()
18989 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
18990 dest = myrow*nprocs + mycol
18991*
18992* Set up seeds to match those used by each proc's genmat call
18993*
18994 IF( scope .EQ. 'R' ) THEN
18995 nnodes = npcol
18996 DO 10 i = 0, nnodes-1
18997 node = myrow * nprocs + i
18998 iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
18999 iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
19000 iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
19001 iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
19002 10 CONTINUE
19003 ELSE IF( scope .EQ. 'C' ) THEN
19004 nnodes = nprow
19005 DO 20 i = 0, nnodes-1
19006 node = i * nprocs + mycol
19007 iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
19008 iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
19009 iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
19010 iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
19011 20 CONTINUE
19012 ELSE
19013 nnodes = nprow * npcol
19014 DO 30 i = 0, nnodes-1
19015 node = (i / npcol) * nprocs + mod(i, npcol)
19016 iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
19017 iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
19018 iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
19019 iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
19020 30 CONTINUE
19021 END IF
19022*
19023 DO 100 j = 1, n
19024 DO 90 i = 1, m
19025 h = (j-1)*ldi + i
19026 vals(1) = ibtran( iseed )
19027 iamn = 1
19028 IF( nnodes .GT. 1 ) THEN
19029 DO 40 k = 1, nnodes-1
19030 vals(k+1) = ibtran( iseed(k*4+1) )
19031 IF( ibtabs( vals(k+1) ) .LT. ibtabs( vals(iamn) ) )
19032 $ iamn = k + 1
19033 40 CONTINUE
19034 END IF
19035*
19036* If BLACS have not returned same value we've chosen
19037*
19038 IF( a(i,j) .NE. vals(iamn) ) THEN
19039*
19040* If we have RA and CA arrays
19041*
19042 IF( ldi .NE. -1 ) THEN
19043*
19044* Any number having the same absolute value is a valid max
19045*
19046 k = ibtspnum( scope, ra(h), ca(h), npcol ) + 1
19047 IF( k.GT.0 .AND. k.LE.nnodes ) THEN
19048 error = ibtabs( vals(k) ).NE.ibtabs( vals(iamn) )
19049 IF( .NOT.error ) iamn = k
19050 ELSE
19051 error = .true.
19052 END IF
19053 ELSE
19054*
19055* Error if BLACS answer not same absolute value, or if it
19056* was not really in the numbers being compared
19057*
19058 error = ( ibtabs( a(i,j) ) .NE. ibtabs( vals(iamn) ) )
19059 IF( .NOT.error ) THEN
19060 DO 50 k = 1, nnodes
19061 IF( vals(k) .EQ. a(i,j) ) GOTO 60
19062 50 CONTINUE
19063 error = .true.
19064 60 CONTINUE
19065 ENDIF
19066 END IF
19067*
19068* If the value is in error
19069*
19070 IF( error ) THEN
19071 nerr = nerr + 1
19072 erribuf(1, nerr) = testnum
19073 erribuf(2, nerr) = nnodes
19074 erribuf(3, nerr) = dest
19075 erribuf(4, nerr) = i
19076 erribuf(5, nerr) = j
19077 erribuf(6, nerr) = 5
19078 errdbuf(1, nerr) = a(i,j)
19079 errdbuf(2, nerr) = vals(iamn)
19080 END IF
19081 END IF
19082*
19083* If they are defined, make sure coordinate entries are OK
19084*
19085 IF( ldi .NE. -1 ) THEN
19086 k = ibtspnum( scope, ra(h), ca(h), npcol ) + 1
19087 IF( k.NE.iamn ) THEN
19088*
19089* Make sure more than one proc doesn't have exact same value
19090* (and therefore there may be more than one valid coordinate
19091* for a single value)
19092*
19093 IF( k.GT.nnodes .OR. k.LT.1 ) THEN
19094 error = .true.
19095 ELSE
19096 error = ( vals(k) .NE. vals(iamn) )
19097 END IF
19098 IF( error ) THEN
19099 CALL ibtspcoord( scope, iamn-1, myrow, mycol,
19100 $ npcol, ramn, camn )
19101 IF( ramn .NE. ra(h) ) THEN
19102 nerr = nerr + 1
19103 erribuf(1, nerr) = testnum
19104 erribuf(2, nerr) = nnodes
19105 erribuf(3, nerr) = dest
19106 erribuf(4, nerr) = i
19107 erribuf(5, nerr) = j
19108 erribuf(6, nerr) = -5
19109 errdbuf(1, nerr) = ra(h)
19110 errdbuf(2, nerr) = ramn
19111 END IF
19112 IF( camn .NE. ca(h) ) THEN
19113 nerr = nerr + 1
19114 erribuf(1, nerr) = testnum
19115 erribuf(2, nerr) = nnodes
19116 erribuf(3, nerr) = dest
19117 erribuf(4, nerr) = i
19118 erribuf(5, nerr) = j
19119 erribuf(6, nerr) = -15
19120 errdbuf(1, nerr) = ca(h)
19121 errdbuf(2, nerr) = camn
19122 END IF
19123 END IF
19124 END IF
19125 END IF
19126 90 CONTINUE
19127 100 CONTINUE
19128*
19129 RETURN
19130*
19131* End of ICHKAMN
19132*
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: