ScaLAPACK 2.1  2.1
ScaLAPACK: Scalable Linear Algebra PACKage
blacstest.f
Go to the documentation of this file.
1  PROGRAM blacstest
2 *
3 * -- BLACS tester (version 1.0) --
4 * University of Tennessee
5 * December 15, 1994
6 *
7 * Purpose
8 * =======
9 * This is the driver for the BLACS test suite.
10 *
11 * Arguments
12 * =========
13 * None. Input is done via the data files indicated below.
14 *
15 * Input Files
16 * ===========
17 * The following input files must reside in the current working
18 * directory:
19 *
20 * bt.dat -- input parameters for the test run as a whole
21 * sdrv.dat -- input parameters for point-to-point testing
22 * bsbr.dat -- input parameters for broadcast testing
23 * comb.dat -- input parameters for combine testing
24 *
25 * Output Files
26 * ============
27 * Test results are generated and sent to output file as
28 * specified by the user in bt.dat.
29 *
30 * ===================================================================
31 *
32 * .. Parameters ..
33  INTEGER cmemsiz, memelts
34  parameter( memelts = 250000 )
35  parameter( cmemsiz = 10000 )
36 * ..
37 * .. External Functions ..
38  LOGICAL allpass
39  INTEGER ibtmsgid, ibtsizeof
40  REAL sbteps
41  DOUBLE PRECISION dbteps
42  EXTERNAL allpass, ibtmsgid, sbteps, dbteps, ibtsizeof
43 * ..
44 * .. External Subroutines ..
45  EXTERNAL blacs_pinfo, btsetup, rdbtin
46 * ..
47 * .. Local Scalars ..
48  INTEGER i, iam, nnodes, verb, outnum, memlen, nprec, isize, dsize
49  LOGICAL testsdrv, testbsbr, testcomb, testaux
50 * ..
51 * .. Local Arrays ..
52  CHARACTER*1 cmem(cmemsiz), prec(9)
53  INTEGER iprec(9), itmp(2)
54  DOUBLE PRECISION mem(memelts)
55 * ..
56 * .. Executable Statements ..
57 *
58  isize = ibtsizeof('I')
59  dsize = ibtsizeof('D')
60 *
61 * Get initial process information, and initialize message IDs
62 *
63  CALL blacs_pinfo( iam, nnodes )
64  itmp(1) = ibtmsgid()
65 *
66 * Call BLACS_GRIDINIT so BLACS set up some system stuff: should
67 * make it possible for the user to print, read input files, etc.
68 *
69  IF( nnodes .GT. 0 ) THEN
70  CALL blacs_get( 0, 0, itmp )
71  CALL blacs_gridinit(itmp, 'c', 1, nnodes)
72  CALL blacs_gridexit(itmp)
73  END IF
74 *
75 * Read in what tests to do
76 *
77  IF( iam .EQ. 0 )
78  $ CALL rdbtin( testsdrv, testbsbr, testcomb, testaux, nprec,
79  $ prec, verb, outnum )
80 *
81  memlen = (memelts * dsize) / isize
82 *
83 * Get process info for communication, and create virtual machine
84 * if necessary
85 *
86  CALL btsetup( mem, memlen, cmem, cmemsiz, outnum, testsdrv,
87  $ testbsbr, testcomb, testaux, iam, nnodes )
88 *
89 * Send out RDBTIN information
90 *
91  IF( iam .EQ. 0 ) THEN
92 *
93 * Store test info in back of precision array
94 *
95  itmp(1) = nprec
96  itmp(2) = verb
97  CALL btsend( 3, 2, itmp, -1, ibtmsgid() )
98  DO 10 i = 1, 9
99  iprec(i) = 0
100  10 CONTINUE
101  DO 20 i = 1, nprec
102  IF( prec(i) .EQ. 'I' ) THEN
103  iprec(i) = 1
104  ELSE IF( prec(i) .EQ. 'S' ) THEN
105  iprec(i) = 2
106  ELSE IF( prec(i) .EQ. 'D' ) THEN
107  iprec(i) = 3
108  ELSE IF( prec(i) .EQ. 'C' ) THEN
109  iprec(i) = 4
110  ELSE IF( prec(i) .EQ. 'Z' ) THEN
111  iprec(i) = 5
112  END IF
113  20 CONTINUE
114  IF( testsdrv ) iprec(6) = 1
115  IF( testbsbr ) iprec(7) = 1
116  IF( testcomb ) iprec(8) = 1
117  IF( testaux ) iprec(9) = 1
118  CALL btsend( 3, 9, iprec, -1, ibtmsgid()+1 )
119  ELSE
120  CALL btrecv( 3, 2, itmp, 0, ibtmsgid() )
121  nprec = itmp(1)
122  verb = itmp(2)
123  CALL btrecv( 3, 9, iprec, 0, ibtmsgid()+1 )
124  DO 30 i = 1, nprec
125  IF( iprec(i) .EQ. 1 ) THEN
126  prec(i) = 'I'
127  ELSE IF( iprec(i) .EQ. 2 ) THEN
128  prec(i) = 'S'
129  ELSE IF( iprec(i) .EQ. 3 ) THEN
130  prec(i) = 'D'
131  ELSE IF( iprec(i) .EQ. 4 ) THEN
132  prec(i) = 'C'
133  ELSE IF( iprec(i) .EQ. 5 ) THEN
134  prec(i) = 'Z'
135  END IF
136  30 CONTINUE
137  testsdrv = ( iprec(6) .EQ. 1 )
138  testbsbr = ( iprec(7) .EQ. 1 )
139  testcomb = ( iprec(8) .EQ. 1 )
140  testaux = ( iprec(9) .EQ. 1 )
141  ENDIF
142 *
143  IF( testsdrv .OR. testbsbr .OR. testcomb .OR. testaux ) THEN
144 *
145 * Find maximal machine epsilon for single and double precision
146 *
147  itmp(1) = int( sbteps() )
148  itmp(1) = int( dbteps() )
149 *
150  CALL runtests( mem, memlen, cmem, cmemsiz, prec, nprec, outnum,
151  $ verb, testsdrv, testbsbr, testcomb, testaux )
152 *
153  END IF
154 *
155  IF( iam .EQ. 0 ) THEN
156  WRITE(outnum,*) ' '
157  WRITE(outnum,1000)
158  WRITE(outnum,1000)
159  IF( allpass(.true.) ) THEN
160  WRITE(outnum,2000) 'NO'
161  ELSE
162  WRITE(outnum,2000) ' '
163  END IF
164  WRITE(outnum,1000)
165  WRITE(outnum,1000)
166  IF( outnum.NE.0 .AND. outnum.NE.6 ) CLOSE(outnum)
167  ENDIF
168 *
169  CALL blacs_exit(0)
170  1000 FORMAT('=======================================')
171  2000 FORMAT('THERE WERE ',a2,' FAILURES IN THIS TEST RUN')
172  stop
173 *
174 * End BLACSTESTER
175 *
176  END
177 *
178  SUBROUTINE runtests( MEM, MEMLEN, CMEM, CMEMLEN, PREC, NPREC,
179  $ OUTNUM, VERB, TESTSDRV, TESTBSBR, TESTCOMB,
180  $ TESTAUX )
181 *
182 * .. Scalar Arguments ..
183  INTEGER MEMLEN, CMEMLEN, NPREC, OUTNUM, VERB, IAM, NNODES
184  LOGICAL TESTSDRV, TESTBSBR, TESTCOMB, TESTAUX
185 * ..
186 * .. Array Arguments ..
187  CHARACTER*1 CMEM(CMEMLEN), PREC(NPREC)
188  INTEGER MEM(MEMLEN)
189 * ..
190 * .. External Functions ..
191  INTEGER IBTNPROCS, IBTMYPROC, IBTMSGID, IBTSIZEOF, SAFEINDEX
192  EXTERNAL IBTNPROCS, IBTMYPROC, IBTMSGID, IBTSIZEOF, SAFEINDEX
193 * ..
194 * .. External Subroutines ..
195  EXTERNAL csdrvtest, dsdrvtest, isdrvtest, ssdrvtest, zsdrvtest
196  EXTERNAL cbsbrtest, dbsbrtest, ibsbrtest, sbsbrtest, zbsbrtest
197  EXTERNAL isumtest, ssumtest, dsumtest, csumtest, zsumtest
198  EXTERNAL iamxtest, samxtest, damxtest, camxtest, zamxtest
199  EXTERNAL iamntest, samntest, damntest, camntest, zamntest
200  EXTERNAL auxtest, btsend, btrecv, btinfo
201 * ..
202 * .. Local Scalars ..
203  INTEGER NSCOPE, NOP, NTOP, NSHAPE, NMAT, NSRC, NDEST, NGRID
204  INTEGER TREP, TCOH, OPPTR, SCOPEPTR, TOPPTR, UPLOPTR, DIAGPTR
205  INTEGER MPTR, NPTR, LDSPTR, LDDPTR, LDIPTR
206  INTEGER RSRCPTR, CSRCPTR, RDESTPTR, CDESTPTR, PPTR, QPTR
207  INTEGER ISEEDPTR, RAPTR, CAPTR, CTXTPTR, WORKPTR, WORKLEN
208  INTEGER MEMUSED, CMEMUSED, I, J, K
209  INTEGER ISIZE, SSIZE, DSIZE, CSIZE, ZSIZE
210 * ..
211 * .. Local Arrays ..
212  INTEGER ITMP(4)
213 * ..
214 * .. Executable Statements ..
215 *
216  iam = ibtmyproc()
217  nnodes = ibtnprocs()
218  isize = ibtsizeof('I')
219  ssize = ibtsizeof('S')
220  dsize = ibtsizeof('D')
221  csize = ibtsizeof('C')
222  zsize = ibtsizeof('Z')
223 *
224  IF( iam.EQ.0 ) THEN
225  CALL blacs_get( 0, 2, i )
226  WRITE(outnum,3000)
227  WRITE(outnum,3000)
228  WRITE(outnum,2000) i
229  WRITE(outnum,3000)
230  WRITE(outnum,3000)
231  END IF
232 *
233  IF( testaux ) THEN
234 *
235 * Each process will make sure that BLACS_PINFO returns
236 * the same value as BLACS_SETUP, and send a packet
237 * to node 0 saying whether it was.
238 *
239  CALL blacs_pinfo( itmp(1), itmp(3) )
240  CALL blacs_setup( itmp(2), itmp(4) )
241  IF( iam .EQ. 0 ) THEN
242  DO 35 i = 0, nnodes-1
243  IF( i .NE. 0 )
244  $ CALL btrecv( 3, 4, itmp, i, ibtmsgid()+2 )
245  IF( itmp(1) .NE. itmp(2) )
246  $ WRITE( outnum, 1000 ) itmp(1), itmp(2)
247  IF( (itmp(3).NE.itmp(4)) .OR. (itmp(3).NE.nnodes) )
248  $ WRITE( outnum, 1000 ) itmp(3), itmp(4), nnodes
249  35 CONTINUE
250  ELSE
251  CALL btsend( 3, 4, itmp, 0, ibtmsgid()+2 )
252  ENDIF
253  ENDIF
254 *
255 * Run point-to-point tests as appropriate
256 *
257  IF( testsdrv ) THEN
258 *
259 * Get test info
260 *
261  CALL btinfo( 'SDRV', memused, mem, memlen, cmemused, cmem,
262  $ cmemlen, outnum, nop, nscope, trep, tcoh, ntop,
263  $ nshape, nmat, nsrc, ngrid, opptr, scopeptr,
264  $ topptr, uploptr, diagptr, mptr, nptr, ldsptr,
265  $ lddptr, ldiptr, rsrcptr, csrcptr, rdestptr,
266  $ cdestptr, pptr, qptr )
267 *
268 * iseedptr used as tests passed/failed array, so it must
269 * be of size NTESTS -- It's not used unless VERB < 2
270 *
271  ctxtptr = memused + 1
272  iseedptr = ctxtptr + ngrid
273  memused = iseedptr - 1
274  IF( verb .LT. 2 )
275  $ memused = memused + nshape * nmat * nsrc * ngrid
276 *
277  CALL makegrids( mem(ctxtptr), outnum, ngrid, mem(pptr),
278  $ mem(qptr) )
279 *
280 * Call individual tests as appropriate.
281 *
282  DO 10 i = 1, nprec
283  IF( prec(i) .EQ. 'I' ) THEN
284 *
285  workptr = safeindex(memused + 1, isize, isize)
286  worklen = ( dsize * (memlen - workptr + 1) ) / isize
287  CALL isdrvtest(outnum, verb, nshape, cmem(uploptr),
288  $ cmem(diagptr), nmat, mem(mptr),
289  $ mem(nptr), mem(ldsptr), mem(lddptr),
290  $ nsrc, mem(rsrcptr), mem(csrcptr),
291  $ mem(rdestptr), mem(cdestptr),
292  $ ngrid, mem(ctxtptr), mem(pptr), mem(qptr),
293  $ mem(iseedptr), mem(workptr), worklen)
294 *
295  ELSE IF( prec(i) .EQ. 'S' ) THEN
296 *
297  workptr = safeindex(memused + 1, isize, ssize)
298  worklen = ( dsize * (memlen - workptr + 1) ) / ssize
299  CALL ssdrvtest(outnum, verb, nshape, cmem(uploptr),
300  $ cmem(diagptr), nmat, mem(mptr),
301  $ mem(nptr), mem(ldsptr), mem(lddptr),
302  $ nsrc, mem(rsrcptr), mem(csrcptr),
303  $ mem(rdestptr), mem(cdestptr),
304  $ ngrid, mem(ctxtptr), mem(pptr), mem(qptr),
305  $ mem(iseedptr), mem(workptr), worklen)
306 *
307  ELSE IF( prec(i) .EQ. 'D' ) THEN
308 *
309  workptr = safeindex(memused + 1, isize, dsize)
310  worklen = ( dsize * (memlen - workptr + 1) ) / dsize
311  CALL dsdrvtest(outnum, verb, nshape, cmem(uploptr),
312  $ cmem(diagptr), nmat, mem(mptr),
313  $ mem(nptr), mem(ldsptr), mem(lddptr),
314  $ nsrc, mem(rsrcptr), mem(csrcptr),
315  $ mem(rdestptr), mem(cdestptr),
316  $ ngrid, mem(ctxtptr), mem(pptr), mem(qptr),
317  $ mem(iseedptr), mem(workptr), worklen)
318 *
319  ELSE IF( prec(i) .EQ. 'C' ) THEN
320 *
321  workptr = safeindex(memused + 1, isize, csize)
322  worklen = ( dsize * (memlen - workptr + 1) ) / csize
323  CALL csdrvtest(outnum, verb, nshape, cmem(uploptr),
324  $ cmem(diagptr), nmat, mem(mptr),
325  $ mem(nptr), mem(ldsptr), mem(lddptr),
326  $ nsrc, mem(rsrcptr), mem(csrcptr),
327  $ mem(rdestptr), mem(cdestptr),
328  $ ngrid, mem(ctxtptr), mem(pptr), mem(qptr),
329  $ mem(iseedptr), mem(workptr), worklen)
330 *
331  ELSE IF( prec(i) .EQ. 'Z' ) THEN
332 *
333  workptr = safeindex(memused + 1, isize, zsize)
334  worklen = ( dsize * (memlen - workptr + 1) ) / zsize
335  CALL zsdrvtest(outnum, verb, nshape, cmem(uploptr),
336  $ cmem(diagptr), nmat, mem(mptr),
337  $ mem(nptr), mem(ldsptr), mem(lddptr),
338  $ nsrc, mem(rsrcptr), mem(csrcptr),
339  $ mem(rdestptr), mem(cdestptr),
340  $ ngrid, mem(ctxtptr), mem(pptr), mem(qptr),
341  $ mem(iseedptr), mem(workptr), worklen)
342  END IF
343  10 CONTINUE
344  CALL freegrids( ngrid, mem(ctxtptr) )
345  END IF
346 *
347  IF( testbsbr ) THEN
348 *
349 * Get test info
350 *
351  CALL btinfo( 'BSBR', memused, mem, memlen, cmemused, cmem,
352  $ cmemlen, outnum, nop, nscope, trep, tcoh, ntop,
353  $ nshape, nmat, nsrc, ngrid, opptr, scopeptr,
354  $ topptr, uploptr, diagptr, mptr, nptr, ldsptr,
355  $ lddptr, ldiptr, rsrcptr, csrcptr, rdestptr,
356  $ cdestptr, pptr, qptr )
357 *
358 * iseedptr used as tests passed/failed array, so it must
359 * be of size NTESTS -- It's not used unless VERB < 2
360 *
361  ctxtptr = memused + 1
362  iseedptr = ctxtptr + ngrid
363  memused = iseedptr - 1
364  IF( verb .LT. 2 )
365  $ memused = memused + nscope*ntop*nshape*nmat*nsrc*ngrid
366 *
367  CALL makegrids( mem(ctxtptr), outnum, ngrid, mem(pptr),
368  $ mem(qptr) )
369 *
370 * Call individual tests as appropriate.
371 *
372  DO 20 i = 1, nprec
373  IF( prec(i) .EQ. 'I' ) THEN
374 *
375  workptr = safeindex(memused + 1, isize, isize)
376  worklen = ( dsize * (memlen - workptr + 1) ) / isize
377  CALL ibsbrtest(outnum, verb, nscope, cmem(scopeptr),
378  $ ntop, cmem(topptr), nshape, cmem(uploptr),
379  $ cmem(diagptr), nmat, mem(mptr),
380  $ mem(nptr), mem(ldsptr), mem(lddptr),
381  $ nsrc, mem(rsrcptr), mem(csrcptr),
382  $ ngrid, mem(ctxtptr), mem(pptr), mem(qptr),
383  $ mem(iseedptr), mem(workptr), worklen)
384 *
385  ELSE IF( prec(i) .EQ. 'S' ) THEN
386 *
387  workptr = safeindex(memused + 1, isize, ssize)
388  worklen = ( dsize * (memlen - workptr + 1) ) / ssize
389  CALL sbsbrtest(outnum, verb, nscope, cmem(scopeptr),
390  $ ntop, cmem(topptr), nshape, cmem(uploptr),
391  $ cmem(diagptr), nmat, mem(mptr),
392  $ mem(nptr), mem(ldsptr), mem(lddptr),
393  $ nsrc, mem(rsrcptr), mem(csrcptr),
394  $ ngrid, mem(ctxtptr), mem(pptr), mem(qptr),
395  $ mem(iseedptr), mem(workptr), worklen)
396 *
397  ELSE IF( prec(i) .EQ. 'D' ) THEN
398 *
399  workptr = safeindex(memused + 1, isize, dsize)
400  worklen = ( dsize * (memlen - workptr + 1) ) / dsize
401  CALL dbsbrtest(outnum, verb, nscope, cmem(scopeptr),
402  $ ntop, cmem(topptr), nshape, cmem(uploptr),
403  $ cmem(diagptr), nmat, mem(mptr),
404  $ mem(nptr), mem(ldsptr), mem(lddptr),
405  $ nsrc, mem(rsrcptr), mem(csrcptr),
406  $ ngrid, mem(ctxtptr), mem(pptr), mem(qptr),
407  $ mem(iseedptr), mem(workptr), worklen)
408 *
409  ELSE IF( prec(i) .EQ. 'C' ) THEN
410 *
411  workptr = safeindex(memused + 1, isize, csize)
412  worklen = ( dsize * (memlen - workptr + 1) ) / csize
413  CALL cbsbrtest(outnum, verb, nscope, cmem(scopeptr),
414  $ ntop, cmem(topptr), nshape, cmem(uploptr),
415  $ cmem(diagptr), nmat, mem(mptr),
416  $ mem(nptr), mem(ldsptr), mem(lddptr),
417  $ nsrc, mem(rsrcptr), mem(csrcptr),
418  $ ngrid, mem(ctxtptr), mem(pptr), mem(qptr),
419  $ mem(iseedptr), mem(workptr), worklen)
420 *
421  ELSE IF( prec(i) .EQ. 'Z' ) THEN
422 *
423  workptr = safeindex(memused + 1, isize, zsize)
424  worklen = ( dsize * (memlen - workptr + 1) ) / zsize
425  CALL zbsbrtest(outnum, verb, nscope, cmem(scopeptr),
426  $ ntop, cmem(topptr), nshape, cmem(uploptr),
427  $ cmem(diagptr), nmat, mem(mptr),
428  $ mem(nptr), mem(ldsptr), mem(lddptr),
429  $ nsrc, mem(rsrcptr), mem(csrcptr),
430  $ ngrid, mem(ctxtptr), mem(pptr), mem(qptr),
431  $ mem(iseedptr), mem(workptr), worklen)
432 *
433  END IF
434 *
435  20 CONTINUE
436  CALL freegrids( ngrid, mem(ctxtptr) )
437  END IF
438  IF( testcomb ) THEN
439 *
440 * Get test info
441 *
442  CALL btinfo( 'COMB', memused, mem, memlen, cmemused, cmem,
443  $ cmemlen, outnum, nop, nscope, trep, tcoh, ntop,
444  $ nshape, nmat, ndest, ngrid, opptr, scopeptr,
445  $ topptr, uploptr, diagptr, mptr, nptr, ldsptr,
446  $ lddptr, ldiptr, rsrcptr, csrcptr, rdestptr,
447  $ cdestptr, pptr, qptr )
448  ctxtptr = memused + 1
449  memused = ctxtptr + ngrid - 1
450 *
451 * Find space required by RA and CA arrays
452 *
453  k = 0
454  DO 40 j = 0, nop-1
455  IF( cmem(opptr+j).EQ.'>' .OR. cmem(opptr+j).EQ.'<' ) THEN
456  DO 30 i = 0, nmat
457 *
458 * NOTE: here we assume ipre+ipost = 4*M
459 *
460  k = max0( k, 4*mem(mptr+i) )
461  IF ( mem(ldiptr+i) .NE. -1 )
462  $ k = max0( k, mem(nptr+i)*mem(ldiptr+i) +
463  $ 4*mem(mptr+i) )
464  30 CONTINUE
465  END IF
466  40 CONTINUE
467  raptr = memused + 1
468  captr = raptr + k
469 *
470 * iseed array also used as tests passed/failed array, so it must
471 * be of size MAX( 4*NNODES, NTESTS )
472 *
473  iseedptr = captr + k
474  i = 0
475  IF( verb.LT.2 ) i = nscope * ntop * nmat * ndest * ngrid
476  memused = iseedptr + max( 4*nnodes, i )
477 *
478  CALL makegrids( mem(ctxtptr), outnum, ngrid, mem(pptr),
479  $ mem(qptr) )
480 *
481 * Call individual tests as appropriate.
482 *
483  DO 60 i = 1, nprec
484  DO 50 j = 0, nop-1
485  IF( prec(i) .EQ. 'I' ) THEN
486  workptr = safeindex(memused, isize, isize)
487  worklen = ( dsize * (memlen - workptr + 1) ) / isize
488  IF( cmem(opptr+j) .EQ. '+' ) THEN
489  CALL isumtest(outnum, verb, trep, tcoh, nscope,
490  $ cmem(scopeptr), ntop, cmem(topptr),
491  $ nmat, mem(mptr), mem(nptr),
492  $ mem(ldsptr), mem(lddptr), ndest,
493  $ mem(rdestptr), mem(cdestptr), ngrid,
494  $ mem(ctxtptr), mem(pptr), mem(qptr),
495  $ mem(iseedptr), mem(workptr),
496  $ worklen)
497  ELSE IF( cmem(opptr+j) .EQ. '>' ) THEN
498  CALL iamxtest(outnum, verb, trep, tcoh, nscope,
499  $ cmem(scopeptr), ntop, cmem(topptr),
500  $ nmat, mem(mptr), mem(nptr),
501  $ mem(ldsptr), mem(lddptr),
502  $ mem(ldiptr), ndest, mem(rdestptr),
503  $ mem(cdestptr), ngrid, mem(ctxtptr),
504  $ mem(pptr), mem(qptr), mem(iseedptr),
505  $ mem(raptr), mem(captr), k,
506  $ mem(workptr), worklen)
507  ELSE IF( cmem(opptr+j) .EQ. '<' ) THEN
508  CALL iamntest(outnum, verb, trep, tcoh, nscope,
509  $ cmem(scopeptr), ntop, cmem(topptr),
510  $ nmat, mem(mptr), mem(nptr),
511  $ mem(ldsptr), mem(lddptr),
512  $ mem(ldiptr), ndest, mem(rdestptr),
513  $ mem(cdestptr), ngrid, mem(ctxtptr),
514  $ mem(pptr), mem(qptr), mem(iseedptr),
515  $ mem(raptr), mem(captr), k,
516  $ mem(workptr), worklen)
517  END IF
518  ELSE IF( prec(i) .EQ. 'S' ) THEN
519  workptr = safeindex(memused, isize, ssize)
520  worklen = ( dsize * (memlen - workptr + 1) ) / ssize
521  IF( cmem(opptr+j) .EQ. '+' ) THEN
522  CALL ssumtest(outnum, verb, trep, tcoh, nscope,
523  $ cmem(scopeptr), ntop, cmem(topptr),
524  $ nmat, mem(mptr), mem(nptr),
525  $ mem(ldsptr), mem(lddptr), ndest,
526  $ mem(rdestptr), mem(cdestptr), ngrid,
527  $ mem(ctxtptr), mem(pptr), mem(qptr),
528  $ mem(iseedptr), mem(workptr),
529  $ worklen)
530  ELSE IF( cmem(opptr+j) .EQ. '>' ) THEN
531  CALL samxtest(outnum, verb, trep, tcoh, nscope,
532  $ cmem(scopeptr), ntop, cmem(topptr),
533  $ nmat, mem(mptr), mem(nptr),
534  $ mem(ldsptr), mem(lddptr),
535  $ mem(ldiptr), ndest, mem(rdestptr),
536  $ mem(cdestptr), ngrid, mem(ctxtptr),
537  $ mem(pptr), mem(qptr), mem(iseedptr),
538  $ mem(raptr), mem(captr), k,
539  $ mem(workptr), worklen)
540  ELSE IF( cmem(opptr+j) .EQ. '<' ) THEN
541  CALL samntest(outnum, verb, trep, tcoh, nscope,
542  $ cmem(scopeptr), ntop, cmem(topptr),
543  $ nmat, mem(mptr), mem(nptr),
544  $ mem(ldsptr), mem(lddptr),
545  $ mem(ldiptr), ndest, mem(rdestptr),
546  $ mem(cdestptr), ngrid, mem(ctxtptr),
547  $ mem(pptr), mem(qptr), mem(iseedptr),
548  $ mem(raptr), mem(captr), k,
549  $ mem(workptr), worklen)
550  END IF
551  ELSE IF( prec(i) .EQ. 'C' ) THEN
552  workptr = safeindex(memused, isize, csize)
553  worklen = ( dsize * (memlen - workptr + 1) ) / csize
554  IF( cmem(opptr+j) .EQ. '+' ) THEN
555  CALL csumtest(outnum, verb, trep, tcoh, nscope,
556  $ cmem(scopeptr), ntop, cmem(topptr),
557  $ nmat, mem(mptr), mem(nptr),
558  $ mem(ldsptr), mem(lddptr), ndest,
559  $ mem(rdestptr), mem(cdestptr), ngrid,
560  $ mem(ctxtptr), mem(pptr), mem(qptr),
561  $ mem(iseedptr), mem(workptr),
562  $ worklen)
563  ELSE IF( cmem(opptr+j) .EQ. '>' ) THEN
564  CALL camxtest(outnum, verb, trep, tcoh, nscope,
565  $ cmem(scopeptr), ntop, cmem(topptr),
566  $ nmat, mem(mptr), mem(nptr),
567  $ mem(ldsptr), mem(lddptr),
568  $ mem(ldiptr), ndest, mem(rdestptr),
569  $ mem(cdestptr), ngrid, mem(ctxtptr),
570  $ mem(pptr), mem(qptr), mem(iseedptr),
571  $ mem(raptr), mem(captr), k,
572  $ mem(workptr), worklen)
573  ELSE IF( cmem(opptr+j) .EQ. '<' ) THEN
574  CALL camntest(outnum, verb, trep, tcoh, nscope,
575  $ cmem(scopeptr), ntop, cmem(topptr),
576  $ nmat, mem(mptr), mem(nptr),
577  $ mem(ldsptr), mem(lddptr),
578  $ mem(ldiptr), ndest, mem(rdestptr),
579  $ mem(cdestptr), ngrid, mem(ctxtptr),
580  $ mem(pptr), mem(qptr), mem(iseedptr),
581  $ mem(raptr), mem(captr), k,
582  $ mem(workptr), worklen)
583  END IF
584  ELSE IF( prec(i) .EQ. 'Z' ) THEN
585  workptr = safeindex(memused, isize, zsize)
586  worklen = ( dsize * (memlen - workptr + 1) ) / zsize
587  IF( cmem(opptr+j) .EQ. '+' ) THEN
588  CALL zsumtest(outnum, verb, trep, tcoh, nscope,
589  $ cmem(scopeptr), ntop, cmem(topptr),
590  $ nmat, mem(mptr), mem(nptr),
591  $ mem(ldsptr), mem(lddptr), ndest,
592  $ mem(rdestptr), mem(cdestptr), ngrid,
593  $ mem(ctxtptr), mem(pptr), mem(qptr),
594  $ mem(iseedptr), mem(workptr),
595  $ worklen)
596  ELSE IF( cmem(opptr+j) .EQ. '>' ) THEN
597  CALL zamxtest(outnum, verb, trep, tcoh, nscope,
598  $ cmem(scopeptr), ntop, cmem(topptr),
599  $ nmat, mem(mptr), mem(nptr),
600  $ mem(ldsptr), mem(lddptr),
601  $ mem(ldiptr), ndest, mem(rdestptr),
602  $ mem(cdestptr), ngrid, mem(ctxtptr),
603  $ mem(pptr), mem(qptr), mem(iseedptr),
604  $ mem(raptr), mem(captr), k,
605  $ mem(workptr), worklen)
606  ELSE IF( cmem(opptr+j) .EQ. '<' ) THEN
607  CALL zamntest(outnum, verb, trep, tcoh, nscope,
608  $ cmem(scopeptr), ntop, cmem(topptr),
609  $ nmat, mem(mptr), mem(nptr),
610  $ mem(ldsptr), mem(lddptr),
611  $ mem(ldiptr), ndest, mem(rdestptr),
612  $ mem(cdestptr), ngrid, mem(ctxtptr),
613  $ mem(pptr), mem(qptr), mem(iseedptr),
614  $ mem(raptr), mem(captr), k,
615  $ mem(workptr), worklen)
616  END IF
617  END IF
618  50 CONTINUE
619  60 CONTINUE
620  CALL freegrids( ngrid, mem(ctxtptr) )
621  END IF
622 *
623  IF( testaux ) THEN
624  CALL auxtest( outnum, mem, memlen )
625  END IF
626 *
627  1000 FORMAT('AUXILIARY ERROR - IAM MISMATCH: BLACS_PINFO RETURNED',i4,
628  $ /,' BLACS_SETUP RETURNED',i4,'.')
629  1500 FORMAT('AUXILIARY ERROR - NPROC MISMATCH: BLACS_PINFO RETURNED',
630  $ i4,/,' BLACS_SETUP RETURNED',i4,', TESTER THINKS',i4,'.')
631  2000 FORMAT('BEGINNING BLACS TESTING, BLACS DEBUG LEVEL =',i2)
632  3000 FORMAT('==============================================')
633  RETURN
634 *
635 * End of RUNTESTS
636 *
637  END
638 *
639  SUBROUTINE makegrids( CONTEXTS, OUTNUM, NGRIDS, P, Q )
640  INTEGER NGRIDS, OUTNUM
641  INTEGER CONTEXTS(NGRIDS), P(NGRIDS), Q(NGRIDS)
642  INTEGER IBTMYPROC
643  EXTERNAL ibtmyproc
644  INTEGER NPROW, NPCOL, MYROW, MYCOL, I
645 *
646  DO 10 i = 1, ngrids
647  CALL blacs_get( 0, 0, contexts(i) )
648  CALL blacs_gridinit( contexts(i), 'r', p(i), q(i) )
649  10 CONTINUE
650 *
651  DO 20 i = 1, ngrids
652  CALL blacs_gridinfo( contexts(i), nprow, npcol, myrow, mycol )
653  IF( nprow .GT. 0 ) THEN
654  IF( nprow.NE.p(i) .OR. npcol.NE.q(i) ) THEN
655  IF( ibtmyproc() .NE. 0 ) outnum = 6
656  WRITE(outnum,1000) i
657  IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE(outnum)
658  CALL blacs_abort( contexts(i), -1 )
659  END IF
660  END IF
661  20 CONTINUE
662 *
663  1000 FORMAT('Grid creation error trying to create grid #',i3)
664  RETURN
665  END
666 *
667  SUBROUTINE freegrids( NGRIDS, CONTEXTS )
668  INTEGER NGRIDS
669  INTEGER CONTEXTS(NGRIDS)
670  INTEGER I, NPROW, NPCOL, MYROW, MYCOL
671 *
672  DO 10 i = 1, ngrids
673  CALL blacs_gridinfo( contexts(i), nprow, npcol, myrow, mycol )
674  IF( myrow.LT.nprow .AND. mycol.LT.npcol )
675  $ CALL blacs_gridexit( contexts(i) )
676  10 CONTINUE
677  RETURN
678  END
679 *
680  SUBROUTINE auxtest( OUTNUM, MEM, MEMLEN )
681 *
682 * .. Scalar Arguments ..
683  INTEGER OUTNUM, MEMLEN
684 * ..
685 * .. Array Arguments ..
686  INTEGER MEM(MEMLEN)
687 * ..
688 * .. External Functions ..
689  LOGICAL ALLPASS
690  INTEGER IBTMYPROC, IBTMSGID, BLACS_PNUM
691  DOUBLE PRECISION DWALLTIME00
692  EXTERNAL allpass, ibtmyproc, ibtmsgid, blacs_pnum
693  EXTERNAL dwalltime00
694 * ..
695 * .. External Subroutines ..
696  EXTERNAL blacs_pinfo, blacs_gridinit, blacs_gridmap
697  EXTERNAL blacs_freebuff, blacs_gridexit, blacs_abort
698  EXTERNAL blacs_gridinfo, blacs_pcoord, blacs_barrier
699  EXTERNAL blacs_set
700 * ..
701 * .. Local Scalars ..
702  LOGICAL AUXPASSED, PASSED, IPRINT
703  INTEGER NPROCS, NPROW, NPCOL, MYROW, MYCOL, CTXT, CTXT2, LDA
704  INTEGER I, J, K
705  DOUBLE PRECISION DTIME, DEPS
706 * ..
707 * .. Local Arrays ..
708  DOUBLE PRECISION START(2), STST(2), KEEP(2)
709 * ..
710 * .. Executable Statements ..
711 *
712  iprint = ( ibtmyproc() .EQ. 0 )
713  IF( iprint ) THEN
714  WRITE(outnum,*) ' '
715  WRITE(outnum,1000)
716  WRITE(outnum,*) ' '
717  END IF
718  CALL blacs_pinfo( i, nprocs )
719  IF( nprocs .LT. 2 ) THEN
720  IF( iprint )
721  $ WRITE(outnum,*) 'NOT ENOUGH PROCESSES TO PERFORM AUXTESTS'
722  RETURN
723  END IF
724 *
725 * Make sure BLACS_PNUM and BLACS_PCOORD are inverses of each other
726 *
727  IF( iprint ) THEN
728  WRITE(outnum,*) ' '
729  WRITE(outnum,*) 'RUNNING BLACS_PNUM/BLACS_PCOORD TEST'
730  END IF
731  passed = .true.
732  nprocs = nprocs - mod(nprocs,2)
733  CALL blacs_get( 0, 0, ctxt )
734  CALL blacs_gridinit( ctxt, 'r', 1, nprocs )
735  CALL blacs_gridinfo( ctxt, nprow, npcol, myrow, mycol )
736  IF( myrow.GE.nprow .OR. mycol.GE.npcol ) GOTO 100
737  DO 10 i = 1, nprocs
738  k = blacs_pnum( ctxt, 0, i-1 )
739  CALL blacs_pcoord( ctxt, blacs_pnum( ctxt, 0, i-1 ), j, k )
740  IF( passed ) passed = ( j.EQ.0 .AND. k.EQ.i-1 )
741  10 CONTINUE
742  k = 1
743  IF( passed ) k = 0
744  CALL igsum2d( ctxt, 'a', ' ', 1, 1, k, 1, -1, 0 )
745  passed = ( k .EQ. 0 )
746  auxpassed = passed
747  IF( iprint ) THEN
748  IF( passed ) THEN
749  WRITE(outnum,*) 'PASSED BLACS_PNUM/BLACS_PCOORD TEST'
750  ELSE
751  WRITE(outnum,*) 'FAILED BLACS_PNUM/BLACS_PCOORD TEST'
752  END IF
753  WRITE(outnum,*) ' '
754  END IF
755 *
756 * Test to see if DGSUM2D is repeatable when repeatability flag is set
757 * Skip test if DGSUM2D is repeatable when repeatability flag is not set
758 * NOTE: do not change the EPS calculation loop; it is figured in this
759 * strange way so that it ports across platforms
760 *
761  IF( iprint ) WRITE(outnum,*) 'RUNNING REPEATABLE SUM TEST'
762  j = 0
763  12 CONTINUE
764  passed = .true.
765  start(1) = 1.0d0
766  15 CONTINUE
767  deps = start(1)
768  start(1) = start(1) / 2.0d0
769  stst(1) = 1.0d0 + start(1)
770  IF (stst(1) .NE. 1.0d0) GOTO 15
771 *
772  start(1) = deps / dble(npcol-1)
773  IF (mycol .EQ. 3) start(1) = 1.0d0
774  start(2) = 7.00005d0 * npcol
775  stst(1) = start(1)
776  stst(2) = start(2)
777  CALL blacs_set(ctxt, 15, j)
778  CALL dgsum2d(ctxt, 'a', 'f', 2, 1, stst, 2, -1, 0)
779  keep(1) = stst(1)
780  keep(2) = stst(2)
781  DO 30 i = 1, 3
782 *
783 * Have a different guy waste time so he enters combine last
784 *
785  IF (mycol .EQ. i) THEN
786  dtime = dwalltime00()
787  20 CONTINUE
788  IF (dwalltime00() - dtime .LT. 2.0d0) GOTO 20
789  END IF
790  stst(1) = start(1)
791  stst(2) = start(2)
792  CALL dgsum2d(ctxt, 'a', 'f', 2, 1, stst, 2, -1, 0)
793  IF ( (keep(1).NE.stst(1)) .OR. (keep(2).NE.stst(2)) )
794  $ passed = .false.
795  30 CONTINUE
796  k = 1
797  IF (passed) k = 0
798  CALL igsum2d( ctxt, 'a', ' ', 1, 1, k, 1, -1, 0 )
799  passed = (k .EQ. 0)
800  IF (j .EQ. 0) THEN
801  IF (.NOT.passed) THEN
802  j = 1
803  GOTO 12
804  ELSE IF( iprint ) THEN
805  WRITE(outnum,*) 'SKIPPED REPEATABLE SUM TEST'
806  WRITE(outnum,*) ' '
807  END IF
808  END IF
809 *
810  IF (j .EQ. 1) THEN
811  auxpassed = auxpassed .AND. passed
812  IF( iprint ) THEN
813  IF( passed ) THEN
814  WRITE(outnum,*) 'PASSED REPEATABLE SUM TEST'
815  ELSE
816  WRITE(outnum,*) 'FAILED REPEATABLE SUM TEST'
817  END IF
818  WRITE(outnum,*) ' '
819  END IF
820  END IF
821 *
822 * Test BLACS_GRIDMAP: force a column major ordering, starting at an
823 * arbitrary processor
824 *
825  passed = .true.
826  IF( iprint ) WRITE(outnum,*) 'RUNNING BLACS_GRIDMAP TEST'
827  nprow = 2
828  npcol = nprocs / nprow
829  DO 40 i = 0, nprocs-1
830  mem(i+1) = blacs_pnum( ctxt, 0, mod(i+npcol, nprocs) )
831  40 CONTINUE
832  CALL blacs_get( ctxt, 10, ctxt2 )
833  CALL blacs_gridmap( ctxt2, mem, nprow, nprow, npcol )
834  CALL blacs_gridinfo( ctxt2, nprow, npcol, myrow, mycol )
835  passed = ( nprow.EQ.2 .AND. npcol.EQ.nprocs/2 )
836 *
837 * Fan in pids for final check: Note we assume SD/RV working
838 *
839  IF( passed ) THEN
840  k = blacs_pnum( ctxt2, myrow, mycol )
841  IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
842  DO 60 j = 0, npcol-1
843  DO 50 i = 0, nprow-1
844  IF( i.NE.0 .OR. j.NE.0 )
845  $ CALL igerv2d( ctxt2, 1, 1, k, 1, i, j )
846  IF ( passed )
847  $ passed = ( k .EQ. blacs_pnum(ctxt2, i, j) )
848  50 CONTINUE
849  60 CONTINUE
850  ELSE
851  CALL igesd2d( ctxt2, 1, 1, k, 1, 0, 0 )
852  END IF
853  END IF
854  k = 1
855  IF ( passed ) k = 0
856  CALL igsum2d( ctxt, 'a', ' ', 1, 1, k, 1, -1, 0 )
857  passed = ( k .EQ. 0 )
858  auxpassed = auxpassed .AND. passed
859  IF( iprint ) THEN
860  IF( passed ) THEN
861  WRITE(outnum,*) 'PASSED BLACS_GRIDMAP TEST'
862  ELSE
863  WRITE(outnum,*) 'FAILED BLACS_GRIDMAP TEST'
864  END IF
865  WRITE(outnum,*) ' '
866  END IF
867 *
868  IF( iprint ) WRITE(outnum,*) 'CALL BLACS_FREEBUFF'
869  CALL blacs_freebuff( ctxt, 0 )
870  CALL blacs_freebuff( ctxt, 1 )
871  j = 0
872  CALL igsum2d( ctxt2, 'All', ' ', 1, 1, j, 1, -1, mycol )
873  IF( iprint ) THEN
874  WRITE(outnum,*) 'DONE BLACS_FREEBUFF'
875  WRITE(outnum,*) ' '
876  END IF
877 *
878 * Make sure barriers don't interfere with each other
879 *
880  IF( iprint ) WRITE(outnum,*) 'CALL BARRIER'
881  CALL blacs_barrier(ctxt2, 'A')
882  CALL blacs_barrier(ctxt2, 'R')
883  CALL blacs_barrier(ctxt2, 'C')
884  CALL blacs_barrier(ctxt2, 'R')
885  CALL blacs_barrier(ctxt2, 'A')
886  CALL blacs_barrier(ctxt2, 'C')
887  CALL blacs_barrier(ctxt2, 'C')
888  CALL blacs_barrier(ctxt2, 'R')
889  CALL blacs_barrier(ctxt2, 'A')
890  j = 0
891  CALL igsum2d( ctxt2, 'All', ' ', 1, 1, j, 1, -1, mycol )
892  IF( iprint ) THEN
893  WRITE(outnum,*) 'DONE BARRIER'
894  WRITE(outnum,*) ' '
895  END IF
896 *
897 * Ensure contiguous sends are locally-blocking
898 *
899  IF( iprint ) THEN
900  WRITE(outnum,*) 'The following tests will hang if your BLACS'//
901  $ ' are not locally blocking:'
902  WRITE(outnum,*) 'RUNNING LOCALLY-BLOCKING CONTIGUOUS SEND TEST'
903  END IF
904  k = min( memlen, 50000 )
905 *
906 * Initialize send buffer
907 *
908  DO 70 j = 1, k
909  mem(j) = 1
910  70 CONTINUE
911 *
912  IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
913  CALL igesd2d( ctxt2, k, 1, mem, k, nprow-1, npcol-1 )
914  CALL igesd2d( ctxt2, k, 1, mem, k, nprow-1, npcol-1 )
915  CALL igesd2d( ctxt2, k, 1, mem, k, nprow-1, npcol-1 )
916  CALL igerv2d( ctxt2, k, 1, mem, k, nprow-1, npcol-1 )
917  CALL igerv2d( ctxt2, k, 1, mem, k, nprow-1, npcol-1 )
918  CALL igerv2d( ctxt2, k, 1, mem, k, nprow-1, npcol-1 )
919  ELSE IF( myrow.EQ.nprow-1 .AND. mycol.EQ.npcol-1 ) THEN
920  CALL igesd2d( ctxt2, k, 1, mem, k, 0, 0 )
921  CALL igesd2d( ctxt2, k, 1, mem, k, 0, 0 )
922  CALL igesd2d( ctxt2, k, 1, mem, k, 0, 0 )
923  CALL igerv2d( ctxt2, k, 1, mem, k, 0, 0 )
924  CALL igerv2d( ctxt2, k, 1, mem, k, 0, 0 )
925  CALL igerv2d( ctxt2, k, 1, mem, k, 0, 0 )
926  END IF
927  j = 0
928  CALL igsum2d( ctxt2, 'All', ' ', 1, 1, j, 1, -1, mycol )
929  IF( iprint )
930  $ WRITE(outnum,*) 'PASSED LOCALLY-BLOCKING CONTIGUOUS SEND TEST'
931 *
932 * Ensure non-contiguous sends are locally-blocking
933 *
934  j = 4
935  lda = k / j
936  i = max( 2, lda / 4 )
937  IF( iprint )
938  $ WRITE(outnum,*) 'RUNNING LOCALLY-BLOCKING NON-CONTIGUOUS '//
939  $ 'SEND TEST'
940  IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
941  CALL igesd2d( ctxt2, i, j, mem, lda, nprow-1, npcol-1 )
942  CALL igesd2d( ctxt2, i, j, mem, lda, nprow-1, npcol-1 )
943  CALL igesd2d( ctxt2, i, j, mem, lda, nprow-1, npcol-1 )
944  CALL igerv2d( ctxt2, i, j, mem, lda, nprow-1, npcol-1 )
945  CALL igerv2d( ctxt2, i, j, mem, lda, nprow-1, npcol-1 )
946  CALL igerv2d( ctxt2, i, j, mem, lda, nprow-1, npcol-1 )
947  ELSE IF( myrow.EQ.nprow-1 .AND. mycol.EQ.npcol-1 ) THEN
948  CALL igesd2d( ctxt2, i, j, mem, lda, 0, 0 )
949  CALL igesd2d( ctxt2, i, j, mem, lda, 0, 0 )
950  CALL igesd2d( ctxt2, i, j, mem, lda, 0, 0 )
951  CALL igerv2d( ctxt2, i, j, mem, lda, 0, 0 )
952  CALL igerv2d( ctxt2, i, j, mem, lda, 0, 0 )
953  CALL igerv2d( ctxt2, i, j, mem, lda, 0, 0 )
954  END IF
955  CALL igsum2d( ctxt2, 'All', ' ', 1, 1, j, 1, -1, mycol )
956  IF( iprint ) THEN
957  WRITE(outnum,*)'PASSED LOCALLY-BLOCKING NON-CONTIGUOUS '//
958  $ 'SEND TEST'
959  WRITE(outnum,*) ' '
960  END IF
961 *
962 * Note that we already tested the message ID setting/getting in
963 * first call to IBTMSGID()
964 *
965  IF( iprint ) WRITE(outnum,*) 'RUNNING BLACS_SET/BLACS_GET TESTS'
966  j = 0
967  CALL blacs_set( ctxt2, 11, 3 )
968  CALL blacs_set( ctxt2, 12, 2 )
969  CALL blacs_get( ctxt2, 12, i )
970  CALL blacs_get( ctxt2, 11, k )
971  IF( k.NE.3 ) j = j + 1
972  IF( i.NE.2 ) j = j + 1
973  CALL blacs_set( ctxt2, 13, 3 )
974  CALL blacs_set( ctxt2, 14, 2 )
975  CALL blacs_get( ctxt2, 14, i )
976  CALL blacs_get( ctxt2, 13, k )
977  IF( k.NE.3 ) j = j + 1
978  IF( i.NE.2 ) j = j + 1
979 *
980 * See if anyone had error, and print result
981 *
982  CALL igsum2d( ctxt2, 'All', ' ', 1, 1, j, 1, -1, mycol )
983  passed = (j .EQ. 0)
984  auxpassed = auxpassed .AND. passed
985  IF( iprint ) THEN
986  IF( passed ) THEN
987  WRITE(outnum,*) 'PASSED BLACS_SET/BLACS_GET TESTS'
988  ELSE
989  WRITE(outnum,*) 'FAILED BLACS_SET/BLACS_GET TESTS'
990  END IF
991  WRITE(outnum,*) ' '
992  END IF
993 *
994  IF( iprint ) WRITE(outnum,*) 'CALL BLACS_GRIDEXIT'
995  CALL blacs_gridexit(ctxt)
996  CALL blacs_gridexit(ctxt2)
997  IF( iprint ) THEN
998  WRITE(outnum,*) 'DONE BLACS_GRIDEXIT'
999  WRITE(outnum,*) ' '
1000  END IF
1001 *
1002  100 CONTINUE
1003 *
1004  passed = allpass(auxpassed)
1005  IF( iprint ) THEN
1006  WRITE(outnum,*) 'The final auxiliary test is for BLACS_ABORT.'
1007  WRITE(outnum,*) 'Immediately after this message, all '//
1008  $ 'processes should be killed.'
1009  WRITE(outnum,*) 'If processes survive the call, your BLACS_'//
1010  $ 'ABORT is incorrect.'
1011  END IF
1012  CALL blacs_pinfo( i, nprocs )
1013  CALL blacs_get( 0, 0, ctxt )
1014  CALL blacs_gridinit( ctxt, 'r', 1, nprocs )
1015  CALL blacs_barrier(ctxt, 'A')
1016  CALL blacs_gridinfo( ctxt, nprow, npcol, myrow, mycol )
1017 *
1018 * Test BLACS_ABORT
1019 *
1020  IF( myrow.EQ.nprow/2 .AND. mycol.EQ.npcol/2 ) THEN
1021  CALL blacs_abort( ctxt, -1 )
1022 *
1023 * Other procs try to cause a hang: should be killed by BLACS_ABORT
1024 *
1025  ELSE
1026  i = 1
1027 110 CONTINUE
1028  i = i + 3
1029  i = i - 2
1030  i = i - 1
1031  IF( i.EQ.1 ) GOTO 110
1032  end if
1033 *
1034  1000 FORMAT('AUXILIARY TESTS: BEGIN.')
1035  RETURN
1036  END
1037 *
1038  SUBROUTINE bttranschar(TRANSTO, N, CMEM, IMEM)
1039  CHARACTER TRANSTO
1040  INTEGER N
1041  CHARACTER*1 CMEM(N)
1042  INTEGER IMEM(N)
1043  INTEGER I
1044 *
1045  IF( transto .EQ. 'I' ) THEN
1046  DO 10 i = 1, n
1047  imem(i) = ichar( cmem(i) )
1048  10 CONTINUE
1049  ELSE
1050  DO 20 i = 1, n
1051  cmem(i) = char( imem(i) )
1052  20 CONTINUE
1053  END IF
1054  RETURN
1055  END
1056 *
1057  SUBROUTINE btinfo( TEST, MEMUSED, MEM, MEMLEN, CMEMUSED, CMEM,
1058  $ CMEMLEN, OUTNUM, NOP, NSCOPE, TREP, TCOH, NTOP,
1059  $ NSHAPE, NMAT, NSRC, NGRID, OPPTR, SCOPEPTR,
1060  $ TOPPTR, UPLOPTR, DIAGPTR, MPTR, NPTR, LDSPTR,
1061  $ LDDPTR, LDIPTR, RSRCPTR, CSRCPTR, RDESTPTR,
1062  $ CDESTPTR, PPTR, QPTR )
1063 *
1064 * .. Scalar Arguments ..
1065  CHARACTER*1 TEST
1066  INTEGER CDESTPTR, CMEMLEN, CMEMUSED, CSRCPTR, DIAGPTR, LDDPTR,
1067  $ LDIPTR, LDSPTR, MEMLEN, MEMUSED, MPTR, NGRID, NMAT, NOP,
1068  $ NPTR, NSCOPE, NSHAPE, NSRC, NTOP, OPPTR, OUTNUM, PPTR,
1069  $ QPTR, RDESTPTR, RSRCPTR, SCOPEPTR, TCOH, TOPPTR, TREP,
1070  $ UPLOPTR
1071 * ..
1072 * .. Array Arguments ..
1073  CHARACTER*1 CMEM(CMEMLEN)
1074  INTEGER MEM(MEMLEN)
1075 * ..
1076 * .. External Functions ..
1077  INTEGER IBTMYPROC, IBTMSGID, IBTSIZEOF
1078  EXTERNAL IBTMYPROC, IBTMSGID, IBTSIZEOF
1079 * ..
1080 * .. Local Scalars ..
1081  INTEGER IAM, ISIZE, DSIZE
1082 * ..
1083 * .. Local Arrays ..
1084  INTEGER ITMP(2)
1085 * ..
1086 * .. Executable Statements ..
1087 *
1088  iam = ibtmyproc()
1089  IF( iam .EQ. 0 ) THEN
1090  IF( test .EQ. 'S' ) THEN
1091  CALL rdsdrv( memused, mem, memlen, cmemused, cmem, cmemlen,
1092  $ outnum )
1093  ELSE IF( test .EQ. 'B' ) THEN
1094  CALL rdbsbr( memused, mem, memlen, cmemused, cmem, cmemlen,
1095  $ outnum )
1096  ELSE
1097  CALL rdcomb( memused, mem, memlen, cmemused, cmem, cmemlen,
1098  $ outnum )
1099  END IF
1100  itmp(1) = memused
1101  itmp(2) = cmemused
1102  CALL btsend( 3, 2, itmp, -1, ibtmsgid()+3 )
1103  IF( memlen .GE. memused + cmemused ) THEN
1104  CALL bttranschar( 'I', cmemused, cmem, mem(memused+1) )
1105  ELSE
1106  isize = ibtsizeof('I')
1107  dsize = ibtsizeof('D')
1108  WRITE(outnum,1000) ( (memused+cmemused)*isize + dsize-1 )
1109  $ / dsize
1110  CALL blacs_abort(-1, -1)
1111  END IF
1112  CALL btsend( 3, memused+cmemused, mem, -1, ibtmsgid()+4 )
1113  ELSE
1114  CALL btrecv( 3, 2, itmp, 0, ibtmsgid()+3 )
1115  memused = itmp(1)
1116  cmemused = itmp(2)
1117  IF( memlen .GE. memused + cmemused ) THEN
1118  CALL btrecv( 3, memused+cmemused, mem, 0, ibtmsgid()+4 )
1119  CALL bttranschar( 'C', cmemused, cmem, mem(memused+1) )
1120  ELSE
1121  isize = ibtsizeof('I')
1122  dsize = ibtsizeof('D')
1123  WRITE(outnum,1000) ( (memused+cmemused)*isize + dsize-1 )
1124  $ / dsize
1125  CALL blacs_abort(-1, -1)
1126  END IF
1127  END IF
1128  CALL btunpack( test, mem, memused, nop, nscope, trep, tcoh, ntop,
1129  $ nshape, nmat, nsrc, ngrid, opptr, scopeptr, topptr,
1130  $ uploptr, diagptr, mptr, nptr, ldsptr, lddptr,
1131  $ ldiptr, rsrcptr, csrcptr, rdestptr, cdestptr, pptr,
1132  $ qptr)
1133 *
1134  1000 FORMAT('MEM array too short to pack CMEM; increase to at least',
1135  $ i7)
1136 *
1137  RETURN
1138 *
1139 * End BTINFO
1140 *
1141  END
1142 *
1143  SUBROUTINE rdbtin( TESTSDRV, TESTBSBR, TESTCOMB, TESTAUX, NPREC,
1144  $ PREC, VERB, OUTNUM )
1145 *
1146 * -- BLACS tester (version 1.0) --
1147 * University of Tennessee
1148 * December 15, 1994
1149 *
1150 *
1151 * .. Scalar Arguments ..
1152  LOGICAL TESTSDRV, TESTBSBR, TESTCOMB, TESTAUX
1153  INTEGER NPREC, OUTNUM, VERB
1154 * ..
1155 * .. Array Arguments ..
1156  CHARACTER*1 PREC(*)
1157 * ..
1158 *
1159 * Purpose
1160 * =======
1161 * RDBTIN: Read and process the top-level input file BT.dat.
1162 *
1163 * Arguments
1164 * =========
1165 * TESTSDRV (output) LOGICAL
1166 * Run any point-to-point tests?
1167 *
1168 * TESTBSBR (output) LOGICAL
1169 * Run any broadcast tests?
1170 *
1171 * TESTCOMB (output) LOGICAL
1172 * Run any combine-operation tests (e.g. MAX)
1173 *
1174 * TESTAUX (output) LOGICAL
1175 * Run any auxiliary tests?
1176 *
1177 * NPREC (output) INTEGER
1178 * Number of different precisions to test. (up to 5, as determined
1179 * by the parameter PRECMAX down in the code.)
1180 *
1181 * PREC (output) CHARACTER*1 array, dimension 5
1182 * Prefix letter of each precision to test, from the set
1183 * {'C', 'D', 'I', 'S', 'Z'}
1184 *
1185 * VERB (output) INTEGER
1186 * Output verbosity for this test run.
1187 * 0 = Print only "BEGIN [SDRV/BSBR/COMB]", followed by PASSED
1188 * or FAILED message
1189 * 1 = Same as 0, but also prints out header explaining all tests
1190 * to be run.
1191 * 2 = Prints out info before and after every individual test.
1192 *
1193 * OUTNUM (output) INTEGER
1194 * Unit number for output file.
1195 * ======================================================================
1196 *
1197 *
1198 * .. Parameters ..
1199  INTEGER PRECMAX, VERBMAX, IN
1200  PARAMETER ( PRECMAX = 5, verbmax = 2, in = 11 )
1201 * ..
1202 * .. Local Scalars ..
1203  INTEGER I
1204  CHARACTER*1 CH
1205  LOGICAL READERROR
1206 * ..
1207 * .. Local Arrays ..
1208  CHARACTER*80 HEADER, OUTNAME
1209 * ..
1210 * .. External Functions ..
1211  LOGICAL LSAME
1212  EXTERNAL lsame
1213 * ..
1214 * .. Executable Statements
1215 *
1216 * Open and read the file blacstest.dat. Expected format is
1217 * -----
1218 * 'One line of free text intended as a comment for each test run'
1219 * integer Unit number of output file
1220 * string Name of output file (ignored if unit = 6)
1221 * {'T'|'F'} Run any point to point tests?
1222 * {'T'|'F'} Run any broadcast tests?
1223 * {'T'|'F'} Run any combine-operator tests?
1224 * {'T'|'F'} Run the auxiliary tests?
1225 * integer Number of precisions to test - up to 99
1226 * array of CHAR*1's Specific precisions to test
1227 * integer Output verb (1-n, n=most verbose)
1228 * integer Number of nodes required by largest test case
1229 * -----
1230 * Note that the comments to the right of each line are present
1231 * in the sample blacstest.dat file included with this
1232 * distribution, but they are not required.
1233 *
1234 * The array of CHAR*1's is expected to have length equal to the
1235 * integer in the previous line - if it is shorter, problems may
1236 * occur later; if it is longer, the trailing elements will just
1237 * be ignored. The verb is expected to be an integer
1238 * between 1 and n inclusive and will be set to 1 if outside
1239 * this range.
1240 *
1241 * Only process 0 should be calling this routine
1242 *
1243  readerror = .false.
1244  OPEN( unit = in, file = 'bt.dat', status = 'OLD' )
1245  READ(in, *) header
1246  READ(in, *) outnum
1247  READ(in, *) outname
1248 *
1249 * Open and prepare output file
1250 *
1251  IF( outnum.NE.6 .AND. outnum.NE.0 )
1252  $ OPEN( unit = outnum, file = outname, status = 'UNKNOWN' )
1253  WRITE(outnum, *) header
1254 *
1255 * Determine which tests to run
1256 *
1257  READ(in, *) ch
1258  IF( lsame(ch, 'T') ) THEN
1259  testsdrv = .true.
1260  ELSE IF( lsame(ch, 'F') ) THEN
1261  testsdrv = .false.
1262  ELSE
1263  WRITE(outnum, 1000) 'SDRV', ch
1264  readerror = .true.
1265  END IF
1266 *
1267  READ(in, *) ch
1268  IF( lsame(ch, 'T') ) THEN
1269  testbsbr = .true.
1270  ELSE IF(lsame( ch, 'F') ) THEN
1271  testbsbr = .false.
1272  ELSE
1273  WRITE(outnum, 1000) 'BSBR', ch
1274  readerror = .true.
1275  END IF
1276 *
1277  READ(in, *) ch
1278  IF( lsame(ch, 'T') ) THEN
1279  testcomb = .true.
1280  ELSE IF( lsame(ch, 'F') ) THEN
1281  testcomb = .false.
1282  ELSE
1283  WRITE(outnum, 1000) 'COMB', ch
1284  readerror = .true.
1285  END IF
1286 *
1287  READ(in, *) ch
1288  IF( lsame(ch, 'T') ) THEN
1289  testaux = .true.
1290  ELSE IF( lsame(ch, 'F') ) THEN
1291  testaux = .false.
1292  ELSE
1293  WRITE(outnum, 1000) 'AUX ', ch
1294  readerror = .true.
1295  END IF
1296 *
1297 * Get # of precisions, and precisions to test
1298 *
1299  READ(in, *) nprec
1300  IF( nprec .LT. 0 ) THEN
1301  nprec = 0
1302  ELSE IF( nprec. gt. precmax ) THEN
1303  WRITE(outnum, 2000) nprec, precmax, precmax
1304  nprec = precmax
1305  END IF
1306 *
1307  READ(in, *) ( prec(i), i = 1, nprec )
1308  DO 100 i = 1, nprec
1309  IF( lsame(prec(i), 'C') ) THEN
1310  prec(i) = 'C'
1311  ELSE IF( lsame(prec(i), 'D') ) THEN
1312  prec(i) = 'D'
1313  ELSE IF( lsame(prec(i), 'I') ) THEN
1314  prec(i) = 'I'
1315  ELSE IF( lsame(prec(i), 'S') ) THEN
1316  prec(i) = 'S'
1317  ELSE IF( lsame(prec(i), 'Z') ) THEN
1318  prec(i) = 'Z'
1319  ELSE
1320  WRITE(outnum, 3000) prec(i)
1321  readerror = .true.
1322  END IF
1323  100 CONTINUE
1324 *
1325  READ(in, *) verb
1326 *
1327  IF( verb .GT. verbmax ) THEN
1328  WRITE(outnum, 4000) verb, verbmax, verbmax
1329  verb = verbmax
1330  ELSE IF( verb .LT. 0 ) THEN
1331  WRITE(outnum, 5000) verb
1332  verb = 0
1333  END IF
1334 *
1335 * Abort if there was a fatal error
1336 *
1337  IF( readerror ) THEN
1338  WRITE(outnum, 6000)
1339  IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE( outnum )
1340  stop
1341  END IF
1342 *
1343  1000 FORMAT( 'INVALID CHARACTER FOR ',a4,' TESTS ''', a1,
1344  $ ''' (EXPECTED T/F)' )
1345  2000 FORMAT( 'NUMBER OF PRECISIONS ', i6, ' GREATER THAN ', i6,
1346  $ ' - SETTING TO ', i6, '.')
1347  3000 FORMAT( 'UNRECOGNIZABLE PRECISION ENTRY ''', a1,
1348  $ ''' - EXPECTED ''C'', ''D'', ''I'', ''S'', OR ''Z''.')
1349  4000 FORMAT( 'VERBOSITY ', i4, ' GREATER THAN ',i4,
1350  $ ' - SETTING TO ',i4,'.')
1351  5000 FORMAT( 'VERBOSITY ', i4, ' LESS THAN 0 - SETTING TO 0' )
1352  6000 FORMAT( 'FATAL INPUT FILE ERROR - ABORTING RUN.' )
1353 *
1354  RETURN
1355 *
1356 * End of RDBTIN
1357 *
1358  END
1359 *
1360  INTEGER FUNCTION ibtmsgid()
1361 *
1362 * -- BLACS tester (version 1.0) --
1363 * University of Tennessee
1364 * December 15, 1994
1365 *
1366 *
1367 * PURPOSE
1368 * =======
1369 * IBTMSGID : returns a ID for tester communication.
1370 *
1371  INTEGER minid
1372  INTEGER itmp(2)
1373  SAVE minid
1374  data minid /-1/
1375 *
1376 * On first call, reserve 1st 1000 IDs for tester use
1377 *
1378  if (minid .EQ. -1) then
1379  CALL blacs_get( -1, 1, itmp )
1380  minid = itmp(1)
1381  itmp(1) = itmp(1) + 1000
1382  CALL blacs_set( -1, 1, itmp )
1383  END IF
1384 *
1385 * return the minimum allowable ID
1386 *
1387  ibtmsgid = minid
1388 *
1389  RETURN
1390  END
1391 *
1392  SUBROUTINE btunpack(TEST, MEM, MEMLEN, NOP, NSCOPE, TREP, TCOH,
1393  $ NTOP, NSHAPE, NMAT, NSRC, NGRID, OPPTR,
1394  $ SCOPEPTR, TOPPTR, UPLOPTR, DIAGPTR, MPTR,
1395  $ NPTR, LDSPTR, LDDPTR, LDIPTR, RSRCPTR,
1396  $ CSRCPTR, RDESTPTR, CDESTPTR, PPTR, QPTR)
1397 *
1398 * -- BLACS tester (version 1.0) --
1399 * University of Tennessee
1400 * December 15, 1994
1401 *
1402 *
1403 * .. Scalar Arguments ..
1404  CHARACTER*1 TEST
1405  INTEGER CDESTPTR, CSRCPTR, DIAGPTR, LDDPTR, LDIPTR, LDSPTR,
1406  $ MEMLEN, MPTR, NGRID, NMAT, NOP, NPTR, NSCOPE, NSHAPE,
1407  $ NSRC, NTOP, OPPTR, PPTR, QPTR, RDESTPTR, RSRCPTR,
1408  $ SCOPEPTR, TCOH, TOPPTR, TREP, UPLOPTR
1409 * ..
1410 * .. Array Arguments ..
1411  INTEGER MEM(MEMLEN)
1412 * ..
1413 *
1414 * Purpose
1415 * =======
1416 * BTUNPACK: Figure pointers into MEM where the various input values
1417 * are stored.
1418 *
1419 * Arguments
1420 * =========
1421 * TEST (input) CHARACTER*1
1422 * The test we're unpacking for:
1423 * = 'S' : SDRV test
1424 * = 'B' : BSBR test
1425 * = 'C' : Combine test
1426 *
1427 * MEM (input) INTEGER array of dimension MEMLEN
1428 * Memory containing values and number of items.
1429 *
1430 * MEMLEN (input/output) INTEGER
1431 * The number of elements that are used in MEM.
1432 *
1433 * .
1434 * .
1435 * .
1436 *
1437 * =====================================================================
1438 *
1439 * .. Local Scalars ..
1440  INTEGER NDEST, NLDI
1441 * ..
1442 * .. Executable Statements ..
1443 *
1444 * Test is SDRV
1445 *
1446  IF( TEST .EQ. 'S' ) THEN
1447  NOP = 0
1448  nshape = mem(memlen-3)
1449  nscope = 0
1450  trep = 0
1451  tcoh = 0
1452  ntop = 0
1453  nmat = mem(memlen-2)
1454  nldi = 0
1455  nsrc = mem(memlen-1)
1456  ndest = nsrc
1457  ngrid = mem(memlen)
1458  memlen = memlen - 3
1459 *
1460 * Test is BSBR
1461 *
1462  ELSE IF ( test .EQ. 'B' ) THEN
1463  nop = 0
1464  nscope = mem(memlen-5)
1465  trep = 0
1466  tcoh = 0
1467  ntop = mem(memlen-4)
1468  nshape = mem(memlen-3)
1469  nmat = mem(memlen-2)
1470  nldi = 0
1471  nsrc = mem(memlen-1)
1472  ndest = 0
1473  ngrid = mem(memlen)
1474  memlen = memlen - 5
1475 *
1476 * Test is COMB
1477 *
1478  ELSE
1479  nop = mem(memlen-7)
1480  nscope = mem(memlen-6)
1481  trep = mem(memlen-5)
1482  tcoh = mem(memlen-4)
1483  ntop = mem(memlen-3)
1484  nshape = 0
1485  nmat = mem(memlen-2)
1486  nldi = nmat
1487  nsrc = 0
1488  ndest = mem(memlen-1)
1489  ngrid = mem(memlen)
1490  memlen = memlen - 6
1491  END IF
1492  opptr = 1
1493  scopeptr = opptr + nop
1494  topptr = scopeptr + nscope
1495  uploptr = topptr + ntop
1496  diagptr = uploptr + nshape
1497  mptr = 1
1498  nptr = mptr + nmat
1499  ldsptr = nptr + nmat
1500  lddptr = ldsptr + nmat
1501  ldiptr = lddptr + nmat
1502  rsrcptr = ldiptr + nldi
1503  csrcptr = rsrcptr + nsrc
1504  rdestptr = csrcptr + nsrc
1505  cdestptr = rdestptr + ndest
1506  pptr = cdestptr + ndest
1507  qptr = pptr + ngrid
1508  IF( nsrc .EQ. 0 ) nsrc = ndest
1509 *
1510  RETURN
1511 *
1512 * End of BTUNPACK
1513 *
1514  END
1515 *
1516  INTEGER FUNCTION safeindex(INDX, SIZE1, SIZE2)
1517 *
1518 * .. Scalar Arguments ..
1519  INTEGER indx, size1, size2
1520 * ..
1521 *
1522 * If you have an array with elements of SIZE1 bytes, of which you
1523 * have used INDX-1 elements, returns the index necessary to keep it
1524 * on a SIZE2 boundary (assuming it was SIZE2 aligned in the first place).
1525 *
1526 * .. Local scalars ..
1527  INTEGER i
1528 * ..
1529 * .. Executable Statements ..
1530 *
1531 * Take into account that Fortran starts arrays at 1, not 0
1532 *
1533  i = indx - 1
1534  10 CONTINUE
1535  IF( mod(i*size1, size2) .EQ. 0 ) GOTO 20
1536  i = i + 1
1537  GOTO 10
1538  20 CONTINUE
1539 *
1540  safeindex = i + 1
1541 *
1542  RETURN
1543  END
1544 *
1545 *
1546  SUBROUTINE rdsdrv( MEMUSED, MEM, MEMLEN, CMEMUSED, CMEM, CMEMLEN,
1547  $ OUTNUM )
1548 *
1549 * -- BLACS tester (version 1.0) --
1550 * University of Tennessee
1551 * December 15, 1994
1552 *
1553 *
1554 * .. Scalar Arguments ..
1555  INTEGER MEMUSED, MEMLEN, CMEMUSED, CMEMLEN, OUTNUM
1556 * ..
1557 * .. Array Arguments ..
1558  CHARACTER*1 CMEM(CMEMLEN)
1559  INTEGER MEM(MEMLEN)
1560 * ..
1561 *
1562 * Purpose
1563 * =======
1564 * RDSDRV: Read and process the input file SDRV.dat.
1565 *
1566 * Arguments
1567 * =========
1568 * MEMUSED (output) INTEGER
1569 * Number of elements in MEM that this subroutine ends up using.
1570 *
1571 * MEM (output) INTEGER array of dimension memlen
1572 * On output, holds information read in from sdrv.dat.
1573 *
1574 * MEMLEN (input) INTEGER
1575 * Number of elements of MEM that this subroutine
1576 * may safely write into.
1577 *
1578 * CMEMUSED (output) INTEGER
1579 * Number of elements in CMEM that this subroutine ends up using.
1580 *
1581 * CMEM (output) CHARACTER*1 array of dimension cmemlen
1582 * On output, holds the values for UPLO and DIAG.
1583 *
1584 * CMEMLEN (input) INTEGER
1585 * Number of elements of CMEM that this subroutine
1586 * may safely write into.
1587 *
1588 * OUTNUM (input) INTEGER
1589 * Unit number of the output file.
1590 *
1591 * =================================================================
1592 *
1593 * .. Parameters ..
1594  INTEGER SDIN
1595  PARAMETER( SDIN = 12 )
1596 * ..
1597 * .. External Functions ..
1598  logical lsame
1599  EXTERNAL lsame
1600 * ..
1601 * .. Local Scalars ..
1602  INTEGER NSHAPE, NMAT, NSRC, NGRID, I, J
1603  INTEGER UPLOPTR, DIAGPTR, MPTR, NPTR, LDSPTR, LDDPTR, RSRCPTR
1604  INTEGER CSRCPTR, RDESTPTR, CDESTPTR, PPTR, QPTR
1605 * ..
1606 * .. Executable Statements
1607 *
1608 * Open and read the file sdrv.dat. The expected format is
1609 * below.
1610 *
1611 *------
1612 *integer number of shapes of the matrix
1613 *array of CHAR*1's UPLO
1614 *array of CHAR*1's DIAG: unit diagonal or not?
1615 *integer number of nmat
1616 *array of integers M: number of rows in matrix
1617 *array of integers N: number of columns in matrix
1618 *integer LDA: leading dimension on source proc
1619 *integer LDA: leading dimension on dest proc
1620 *integer number of source/dest pairs
1621 *array of integers RSRC: process row of message source
1622 *array of integers CSRC: process column of msg. src.
1623 *array of integers RDEST: process row of msg. dest.
1624 *array of integers CDEST: process column of msg. dest.
1625 *integer Number of grids
1626 *array of integers NPROW: number of rows in process grid
1627 *array of integers NPCOL: number of col's in proc. grid
1628 *------
1629 * note: UPLO stands for 'upper or lower trapezoidal or general
1630 * rectangular.'
1631 * note: the text descriptions as shown above are present in
1632 * the sample sdrv.dat included with this distribution,
1633 * but are not required.
1634 *
1635 * Read input file
1636 *
1637  memused = 1
1638  cmemused = 1
1639  OPEN(unit = sdin, file = 'sdrv.dat', status = 'OLD')
1640 *
1641 * Read in number of shapes, and values of UPLO and DIAG
1642 *
1643  READ(sdin, *) nshape
1644  uploptr = cmemused
1645  diagptr = uploptr + nshape
1646  cmemused = diagptr + nshape
1647  IF ( cmemused .GT. cmemlen ) THEN
1648  WRITE(outnum, 1000) cmemlen, nshape, 'MATRIX SHAPES.'
1649  IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE(outnum)
1650  stop
1651  ELSE IF( nshape .LT. 1 ) THEN
1652  WRITE(outnum, 2000) 'MATRIX SHAPE.'
1653  IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE(outnum)
1654  stop
1655  END IF
1656 *
1657 * Read in, upcase, and fatal error if UPLO/DIAG not recognized
1658 *
1659  READ(sdin, *) ( cmem(uploptr+i), i = 0, nshape-1 )
1660  DO 30 i = 0, nshape-1
1661  IF( lsame(cmem(uploptr+i), 'G') ) THEN
1662  cmem(uploptr+i) = 'G'
1663  ELSE IF( lsame(cmem(uploptr+i), 'U') ) THEN
1664  cmem(uploptr+i) = 'U'
1665  ELSE IF( lsame(cmem(uploptr+i), 'L') ) THEN
1666  cmem(uploptr+i) = 'L'
1667  ELSE
1668  WRITE(outnum, 3000) 'UPLO ', cmem(uploptr+i)
1669  IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE(outnum)
1670  stop
1671  END IF
1672  30 CONTINUE
1673 *
1674  READ(sdin, *) ( cmem(diagptr+i), i = 0, nshape-1 )
1675  DO 40 i = 0, nshape-1
1676  IF( cmem(uploptr+i) .NE. 'G' ) THEN
1677  IF( lsame(cmem(diagptr+i), 'U') ) THEN
1678  cmem( diagptr+i ) = 'U'
1679  ELSE IF( lsame(cmem(diagptr+i), 'N') ) THEN
1680  cmem(diagptr+i) = 'N'
1681  ELSE
1682  WRITE(outnum, 3000) 'DIAG ', cmem(diagptr+i)
1683  IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE(outnum)
1684  stop
1685  END IF
1686  END IF
1687  40 CONTINUE
1688 *
1689 * Read in number of matrices, and values for M, N, LDASRC, and LDADEST
1690 *
1691  READ(sdin, *) nmat
1692  mptr = memused
1693  nptr = mptr + nmat
1694  ldsptr = nptr + nmat
1695  lddptr = ldsptr + nmat
1696  memused = lddptr + nmat
1697  IF( memused .GT. memlen ) THEN
1698  WRITE(outnum, 1000) memlen, nmat, 'MATRICES.'
1699  IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE(outnum)
1700  stop
1701  ELSE IF( nmat .LT. 1 ) THEN
1702  WRITE(outnum, 2000) 'MATRIX.'
1703  IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE(outnum)
1704  stop
1705  END IF
1706  READ(sdin, *) ( mem( mptr+i ), i = 0, nmat-1 )
1707  READ(sdin, *) ( mem( nptr+i ), i = 0, nmat-1 )
1708  READ(sdin, *) ( mem( ldsptr+i ), i = 0, nmat-1 )
1709  READ(sdin, *) ( mem( lddptr+i ), i = 0, nmat-1 )
1710 *
1711 * Make sure matrix values are legal
1712 *
1713  CALL chkmatdat( outnum, 'SDRV.dat', .false., nmat, mem(mptr),
1714  $ mem(nptr), mem(ldsptr), mem(lddptr), mem(lddptr) )
1715 *
1716 * Read in number of src/dest pairs, and values of src/dest
1717 *
1718  READ(sdin, *) nsrc
1719  rsrcptr = memused
1720  csrcptr = rsrcptr + nsrc
1721  rdestptr = csrcptr + nsrc
1722  cdestptr = rdestptr + nsrc
1723  memused = cdestptr + nsrc
1724  IF( memused .GT. memlen ) THEN
1725  WRITE(outnum, 1000) memlen, nmat, 'SRC/DEST.'
1726  IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE(outnum)
1727  stop
1728  ELSE IF( nsrc .LT. 1 ) THEN
1729  WRITE(outnum, 2000) 'SRC/DEST.'
1730  IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE(outnum)
1731  stop
1732  END IF
1733  READ(sdin, *) ( mem(rsrcptr+i), i = 0, nsrc-1 )
1734  READ(sdin, *) ( mem(csrcptr+i), i = 0, nsrc-1 )
1735  READ(sdin, *) ( mem(rdestptr+i), i = 0, nsrc-1 )
1736  READ(sdin, *) ( mem(cdestptr+i), i = 0, nsrc-1 )
1737 *
1738 * Read in number of grids pairs, and values of P (process rows) and
1739 * Q (process columns)
1740 *
1741  READ(sdin, *) ngrid
1742  pptr = memused
1743  qptr = pptr + ngrid
1744  memused = qptr + ngrid
1745  IF( memused .GT. memlen ) THEN
1746  WRITE(outnum, 1000) memlen, ngrid, 'PROCESS GRIDS.'
1747  IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE(outnum)
1748  stop
1749  ELSE IF( ngrid .LT. 1 ) THEN
1750  WRITE(outnum, 2000) 'PROCESS GRID'
1751  IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE( outnum )
1752  stop
1753  END IF
1754 *
1755  READ(sdin, *) ( mem(pptr+i), i = 0, ngrid-1 )
1756  READ(sdin, *) ( mem(qptr+i), i = 0, ngrid-1 )
1757  IF( sdin .NE. 6 .AND. sdin .NE. 0 ) CLOSE( sdin )
1758 *
1759 * Fatal error if we've got an illegal grid
1760 *
1761  DO 70 j = 0, ngrid-1
1762  IF( mem(pptr+j).LT.1 .OR. mem(qptr+j).LT.1 ) THEN
1763  WRITE(outnum, 4000) mem(pptr+j), mem(qptr+j)
1764  IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE(outnum)
1765  stop
1766  END IF
1767  70 CONTINUE
1768 *
1769 * Prepare output variables
1770 *
1771  mem(memused) = nshape
1772  mem(memused+1) = nmat
1773  mem(memused+2) = nsrc
1774  mem(memused+3) = ngrid
1775  memused = memused + 3
1776  cmemused = cmemused - 1
1777 *
1778  1000 FORMAT('Mem too short (',i4,') to handle',i4,' ',a20)
1779  2000 FORMAT('Must have at least one ',a20)
1780  3000 FORMAT('UNRECOGNIZABLE ',a5,' ''', a1, '''.')
1781  4000 FORMAT('Illegal process grid: {',i3,',',i3,'}.')
1782 *
1783  RETURN
1784 *
1785 * End of RDSDRV.
1786 *
1787  END
1788 *
1789  SUBROUTINE chkmatdat( NOUT, INFILE, TSTFLAG, NMAT, M0, N0,
1790  $ LDAS0, LDAD0, LDI0 )
1791 *
1792 * -- BLACS tester (version 1.0) --
1793 * University of Tennessee
1794 * December 15, 1994
1795 *
1796 *
1797 * .. Scalar Arguments ..
1798  LOGICAL TSTFLAG
1799  INTEGER NOUT, NMAT
1800 * ..
1801 * .. Array Arguments ..
1802  CHARACTER*8 INFILE
1803  INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT), LDI0(NMAT)
1804 * ..
1805 * Purpose
1806 * =======
1807 * CHKMATDAT: Checks that matrix data is correct.
1808 *
1809 * Arguments
1810 * =========
1811 * NOUT (input) INTEGER
1812 * The device number to write output to.
1813 *
1814 * INFILE (input) CHARACTER*8
1815 * The name of the input file where matrix values came from.
1816 *
1817 * TSTFLAG (input) LOGICAL
1818 * Whether to test RCFLAG (LDI) values or not.
1819 *
1820 * NMAT (input) INTEGER
1821 * The number of matrices to be tested.
1822 *
1823 * M0 (input) INTEGER array of dimension (NMAT)
1824 * Values of M to be tested.
1825 *
1826 * M0 (input) INTEGER array of dimension (NMAT)
1827 * Values of M to be tested.
1828 *
1829 * N0 (input) INTEGER array of dimension (NMAT)
1830 * Values of N to be tested.
1831 *
1832 * LDAS0 (input) INTEGER array of dimension (NMAT)
1833 * Values of LDAS (leading dimension of A on source process)
1834 * to be tested.
1835 *
1836 * LDAD0 (input) INTEGER array of dimension (NMAT)
1837 * Values of LDAD (leading dimension of A on destination
1838 * process) to be tested.
1839 *
1840 * ====================================================================
1841 *
1842 * .. Local Scalars ..
1843  LOGICAL MATOK
1844  INTEGER I
1845 * ..
1846 * .. Executable Statements ..
1847  MATOK = .true.
1848  DO 10 i = 1, nmat
1849  IF( m0(i) .LT. 0 ) THEN
1850  WRITE(nout,1000) infile, 'M', m0(i)
1851  matok = .false.
1852  ELSE IF( n0(i) .LT. 0 ) THEN
1853  WRITE(nout,1000) infile, 'N', n0(i)
1854  matok = .false.
1855  ELSE IF( ldas0(i) .LT. m0(i) ) THEN
1856  WRITE(nout,2000) infile, 'LDASRC', ldas0(i), m0(i)
1857  matok = .false.
1858  ELSE IF( ldad0(i) .LT. m0(i) ) THEN
1859  WRITE(nout,2000) infile, 'LDADST', ldad0(i), m0(i)
1860  matok = .false.
1861  ELSE IF( tstflag ) THEN
1862  IF( (ldi0(i).LT.m0(i)) .AND. (ldi0(i).NE.-1) ) THEN
1863  WRITE(nout,2000) infile, 'RCFLAG', ldi0(i), m0(i)
1864  matok = .false.
1865  END IF
1866  END IF
1867  10 CONTINUE
1868 *
1869  IF( .NOT.matok ) THEN
1870  IF( nout .NE. 6 .AND. nout .NE. 0 ) CLOSE(nout)
1871  CALL blacs_abort(-1, 1)
1872  END IF
1873 *
1874  1000 FORMAT(a8,' INPUT ERROR: Illegal ',a1,'; value=',i6,'.')
1875  2000 FORMAT(a8,' INPUT ERROR: Illegal ',a6,'; value=',i6,', but M=',i6)
1876 *
1877  RETURN
1878  END
1879 *
1880  LOGICAL FUNCTION allpass( THISTEST )
1881 *
1882 * -- BLACS tester (version 1.0) --
1883 * University of Tennessee
1884 * December 15, 1994
1885 *
1886 *
1887 * .. Scalar Arguments ..
1888  LOGICAL thistest
1889 * ..
1890 * Purpose
1891 * =======
1892 * ALLPASS: Returns whether all tests have passed so far.
1893 *
1894 * =====================================================================
1895 *
1896 * .. Local Scalars ..
1897  LOGICAL passhist
1898 * ..
1899 * .. Save Statement ..
1900  SAVE passhist
1901 * ..
1902 * .. Data Statements ..
1903  DATA passhist /.true./
1904 * ..
1905 * .. Executable Statements ..
1906  passhist = (passhist .AND. thistest)
1907  allpass = passhist
1908 *
1909  RETURN
1910  END
1911 *
1912  SUBROUTINE rdbsbr( MEMUSED, MEM, MEMLEN, CMEMUSED, CMEM, CMEMLEN,
1913  $ OUTNUM )
1914 *
1915 * -- BLACS tester (version 1.0) --
1916 * University of Tennessee
1917 * December 15, 1994
1918 *
1919 *
1920 * .. Scalar Arguments ..
1921  INTEGER MEMUSED, MEMLEN, CMEMUSED, CMEMLEN, OUTNUM
1922 * ..
1923 * .. Array Arguments ..
1924  CHARACTER*1 CMEM(CMEMLEN)
1925  INTEGER MEM(MEMLEN)
1926 * ..
1927 *
1928 * Purpose
1929 * =======
1930 * RDBSBR: Read and process the input file BSBR.dat.
1931 *
1932 * Arguments
1933 * =========
1934 * MEMUSED (output) INTEGER
1935 * Number of elements in MEM that this subroutine ends up using.
1936 *
1937 * MEM (output) INTEGER array of dimension memlen
1938 * On output, holds information read in from sdrv.dat.
1939 *
1940 * MEMLEN (input) INTEGER
1941 * Number of elements of MEM that this subroutine
1942 * may safely write into.
1943 *
1944 * CMEMUSED (output) INTEGER
1945 * Number of elements in CMEM that this subroutine ends up using.
1946 *
1947 * CMEM (output) CHARACTER*1 array of dimension cmemlen
1948 * On output, holds the values for UPLO and DIAG.
1949 *
1950 * CMEMLEN (input) INTEGER
1951 * Number of elements of CMEM that this subroutine
1952 * may safely write into.
1953 *
1954 * OUTNUM (input) INTEGER
1955 * Unit number of the output file.
1956 *
1957 * =================================================================
1958 *
1959 * .. Parameters ..
1960  INTEGER SDIN
1961  PARAMETER( SDIN = 12 )
1962 * ..
1963 * .. External Functions ..
1964  logical lsame
1965  EXTERNAL lsame
1966 * ..
1967 * .. Local Scalars ..
1968  INTEGER NSCOPE, NTOP, NSHAPE, NMAT, NSRC, NGRID, I, J
1969  INTEGER SCOPEPTR, TOPPTR, UPLOPTR, DIAGPTR, MPTR, NPTR
1970  INTEGER LDSPTR, LDDPTR, RSRCPTR, CSRCPTR, PPTR, QPTR
1971 * ..
1972 * .. Executable Statements
1973 *
1974 * Open and read the file bsbr.dat. The expected format is
1975 * below.
1976 *
1977 *------
1978 *integer Number of scopes
1979 *array of CHAR*1's Values for Scopes
1980 *integer Number of topologies
1981 *array of CHAR*1's Values for TOP
1982 *integer number of shapes of the matrix
1983 *array of CHAR*1's UPLO
1984 *array of CHAR*1's DIAG: unit diagonal or not?
1985 *integer number of nmat
1986 *array of integers M: number of rows in matrix
1987 *array of integers N: number of columns in matrix
1988 *integer LDA: leading dimension on source proc
1989 *integer LDA: leading dimension on dest proc
1990 *integer number of source/dest pairs
1991 *array of integers RSRC: process row of message source
1992 *array of integers CSRC: process column of msg. src.
1993 *integer Number of grids
1994 *array of integers NPROW: number of rows in process grid
1995 *array of integers NPCOL: number of col's in proc. grid
1996 *------
1997 * note: UPLO stands for 'upper or lower trapezoidal or general
1998 * rectangular.'
1999 * note: the text descriptions as shown above are present in
2000 * the sample bsbr.dat included with this distribution,
2001 * but are not required.
2002 *
2003 * Read input file
2004 *
2005  memused = 1
2006  cmemused = 1
2007  OPEN(unit = sdin, file = 'bsbr.dat', status = 'OLD')
2008 *
2009 * Read in scopes and topologies
2010 *
2011  READ(sdin, *) nscope
2012  scopeptr = cmemused
2013  cmemused = scopeptr + nscope
2014  IF ( cmemused .GT. cmemlen ) THEN
2015  WRITE(outnum, 1000) cmemlen, nscope, 'SCOPES.'
2016  IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE(outnum)
2017  stop
2018  ELSE IF( nscope .LT. 1 ) THEN
2019  WRITE(outnum, 2000) 'SCOPE.'
2020  IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE(outnum)
2021  stop
2022  END IF
2023 *
2024  READ(sdin, *) ( cmem(scopeptr+i), i = 0, nscope-1 )
2025  DO 20 i = 0, nscope-1
2026  IF( lsame(cmem(scopeptr+i), 'R') ) THEN
2027  cmem(scopeptr+i) = 'R'
2028  ELSE IF( lsame(cmem(scopeptr+i), 'C') ) THEN
2029  cmem(scopeptr+i) = 'C'
2030  ELSE IF( lsame(cmem(scopeptr+i), 'A') ) THEN
2031  cmem(scopeptr+i) = 'A'
2032  ELSE
2033  WRITE(outnum, 3000) 'SCOPE', cmem(scopeptr+i)
2034  IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE(outnum)
2035  stop
2036  END IF
2037  20 CONTINUE
2038 *
2039  READ(sdin, *) ntop
2040  topptr = cmemused
2041  cmemused = topptr + ntop
2042  IF ( cmemused .GT. cmemlen ) THEN
2043  WRITE(outnum, 1000) cmemlen, ntop, 'TOPOLOGIES.'
2044  IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE(outnum)
2045  stop
2046  ELSE IF( ntop .LT. 1 ) THEN
2047  WRITE(outnum, 2000) 'TOPOLOGY.'
2048  IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE(outnum)
2049  stop
2050  END IF
2051  READ(sdin, *) ( cmem(topptr+i), i = 0, ntop-1 )
2052 *
2053 *
2054 * Read in number of shapes, and values of UPLO and DIAG
2055 *
2056  READ(sdin, *) nshape
2057  uploptr = cmemused
2058  diagptr = uploptr + nshape
2059  cmemused = diagptr + nshape
2060  IF ( cmemused .GT. cmemlen ) THEN
2061  WRITE(outnum, 1000) cmemlen, nshape, 'MATRIX SHAPES.'
2062  IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE(outnum)
2063  stop
2064  ELSE IF( nshape .LT. 1 ) THEN
2065  WRITE(outnum, 2000) 'MATRIX SHAPE.'
2066  IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE(outnum)
2067  stop
2068  END IF
2069 *
2070 * Read in, upcase, and fatal error if UPLO/DIAG not recognized
2071 *
2072  READ(sdin, *) ( cmem(uploptr+i), i = 0, nshape-1 )
2073  DO 30 i = 0, nshape-1
2074  IF( lsame(cmem(uploptr+i), 'G') ) THEN
2075  cmem(uploptr+i) = 'G'
2076  ELSE IF( lsame(cmem(uploptr+i), 'U') ) THEN
2077  cmem(uploptr+i) = 'U'
2078  ELSE IF( lsame(cmem(uploptr+i), 'L') ) THEN
2079  cmem(uploptr+i) = 'L'
2080  ELSE
2081  WRITE(outnum, 3000) 'UPLO ', cmem(uploptr+i)
2082  IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE(outnum)
2083  stop
2084  END IF
2085  30 CONTINUE
2086 *
2087  READ(sdin, *) ( cmem(diagptr+i), i = 0, nshape-1 )
2088  DO 40 i = 0, nshape-1
2089  IF( cmem(uploptr+i) .NE. 'G' ) THEN
2090  IF( lsame(cmem(diagptr+i), 'U') ) THEN
2091  cmem( diagptr+i ) = 'U'
2092  ELSE IF( lsame(cmem(diagptr+i), 'N') ) THEN
2093  cmem(diagptr+i) = 'N'
2094  ELSE
2095  WRITE(outnum, 3000) 'DIAG ', cmem(diagptr+i)
2096  IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE(outnum)
2097  stop
2098  END IF
2099  END IF
2100  40 CONTINUE
2101 *
2102 * Read in number of matrices, and values for M, N, LDASRC, and LDADEST
2103 *
2104  READ(sdin, *) nmat
2105  mptr = memused
2106  nptr = mptr + nmat
2107  ldsptr = nptr + nmat
2108  lddptr = ldsptr + nmat
2109  memused = lddptr + nmat
2110  IF( memused .GT. memlen ) THEN
2111  WRITE(outnum, 1000) memlen, nmat, 'MATRICES.'
2112  IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE(outnum)
2113  stop
2114  ELSE IF( nmat .LT. 1 ) THEN
2115  WRITE(outnum, 2000) 'MATRIX.'
2116  IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE(outnum)
2117  stop
2118  END IF
2119  READ(sdin, *) ( mem( mptr+i ), i = 0, nmat-1 )
2120  READ(sdin, *) ( mem( nptr+i ), i = 0, nmat-1 )
2121  READ(sdin, *) ( mem( ldsptr+i ), i = 0, nmat-1 )
2122  READ(sdin, *) ( mem( lddptr+i ), i = 0, nmat-1 )
2123 *
2124 * Make sure matrix values are legal
2125 *
2126  CALL chkmatdat( outnum, 'BSBR.dat', .false., nmat, mem(mptr),
2127  $ mem(nptr), mem(ldsptr), mem(lddptr), mem(lddptr) )
2128 *
2129 * Read in number of src pairs, and values of src
2130 *
2131  READ(sdin, *) nsrc
2132  rsrcptr = memused
2133  csrcptr = rsrcptr + nsrc
2134  memused = csrcptr + nsrc
2135  IF( memused .GT. memlen ) THEN
2136  WRITE(outnum, 1000) memlen, nmat, 'SRC.'
2137  IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE(outnum)
2138  stop
2139  ELSE IF( nsrc .LT. 1 ) THEN
2140  WRITE(outnum, 2000) 'SRC.'
2141  IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE(outnum)
2142  stop
2143  END IF
2144  READ(sdin, *) ( mem(rsrcptr+i), i = 0, nsrc-1 )
2145  READ(sdin, *) ( mem(csrcptr+i), i = 0, nsrc-1 )
2146 *
2147 * Read in number of grids pairs, and values of P (process rows) and
2148 * Q (process columns)
2149 *
2150  READ(sdin, *) ngrid
2151  pptr = memused
2152  qptr = pptr + ngrid
2153  memused = qptr + ngrid
2154  IF( memused .GT. memlen ) THEN
2155  WRITE(outnum, 1000) memlen, ngrid, 'PROCESS GRIDS.'
2156  IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE(outnum)
2157  stop
2158  ELSE IF( ngrid .LT. 1 ) THEN
2159  WRITE(outnum, 2000) 'PROCESS GRID'
2160  IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE( outnum )
2161  stop
2162  END IF
2163 *
2164  READ(sdin, *) ( mem(pptr+i), i = 0, ngrid-1 )
2165  READ(sdin, *) ( mem(qptr+i), i = 0, ngrid-1 )
2166  IF( sdin .NE. 6 .AND. sdin .NE. 0 ) CLOSE( sdin )
2167 *
2168 * Fatal error if we've got an illegal grid
2169 *
2170  DO 70 j = 0, ngrid-1
2171  IF( mem(pptr+j).LT.1 .OR. mem(qptr+j).LT.1 ) THEN
2172  WRITE(outnum, 4000) mem(pptr+j), mem(qptr+j)
2173  IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE(outnum)
2174  stop
2175  END IF
2176  70 CONTINUE
2177 *
2178 * Prepare output variables
2179 *
2180  mem(memused) = nscope
2181  mem(memused+1) = ntop
2182  mem(memused+2) = nshape
2183  mem(memused+3) = nmat
2184  mem(memused+4) = nsrc
2185  mem(memused+5) = ngrid
2186  memused = memused + 5
2187  cmemused = cmemused - 1
2188 *
2189  1000 FORMAT('Mem too short (',i4,') to handle',i4,' ',a20)
2190  2000 FORMAT('Must have at least one ',a20)
2191  3000 FORMAT('UNRECOGNIZABLE ',a5,' ''', a1, '''.')
2192  4000 FORMAT('Illegal process grid: {',i3,',',i3,'}.')
2193 *
2194  RETURN
2195 *
2196 * End of RDBSBR.
2197 *
2198  END
2199 *
2200 *
2201  SUBROUTINE isdrvtest( OUTNUM, VERB, NSHAPE, UPLO0, DIAG0,
2202  $ NMAT, M0, N0, LDAS0, LDAD0, NSRC, RSRC0,
2203  $ CSRC0, RDEST0, CDEST0, NGRID, CONTEXT0,
2204  $ P0, Q0, TFAIL, MEM, MEMLEN )
2205 *
2206 * -- BLACS tester (version 1.0) --
2207 * University of Tennessee
2208 * December 15, 1994
2209 *
2210 *
2211 * .. Scalar Arguments ..
2212  INTEGER OUTNUM, VERB, NSHAPE, NMAT, NSRC, NGRID, MEMLEN
2213 * ..
2214 * .. Array Arguments ..
2215  CHARACTER*1 UPLO0(NSHAPE), DIAG0(NSHAPE)
2216  INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT)
2217  INTEGER RSRC0(NSRC), CSRC0(NSRC), RDEST0(NSRC), CDEST0(NSRC)
2218  INTEGER CONTEXT0(NGRID), P0(NGRID), Q0(NGRID), TFAIL(*)
2219  INTEGER MEM(MEMLEN)
2220 * ..
2221 *
2222 * Purpose
2223 * =======
2224 * ITESTSDRV: Test integer send/recv
2225 *
2226 * Arguments
2227 * =========
2228 * OUTNUM (input) INTEGER
2229 * The device number to write output to.
2230 *
2231 * VERB (input) INTEGER
2232 * The level of verbosity (how much printing to do).
2233 *
2234 * NSHAPE (input) INTEGER
2235 * The number of matrix shapes to be tested.
2236 *
2237 * UPLO0 (input) CHARACTER*1 array of dimension (NSHAPE)
2238 * Values of UPLO to be tested.
2239 *
2240 * DIAG0 (input) CHARACTER*1 array of dimension (NSHAPE)
2241 * Values of DIAG to be tested.
2242 *
2243 * NMAT (input) INTEGER
2244 * The number of matrices to be tested.
2245 *
2246 * M0 (input) INTEGER array of dimension (NMAT)
2247 * Values of M to be tested.
2248 *
2249 * M0 (input) INTEGER array of dimension (NMAT)
2250 * Values of M to be tested.
2251 *
2252 * N0 (input) INTEGER array of dimension (NMAT)
2253 * Values of N to be tested.
2254 *
2255 * LDAS0 (input) INTEGER array of dimension (NMAT)
2256 * Values of LDAS (leading dimension of A on source process)
2257 * to be tested.
2258 *
2259 * LDAD0 (input) INTEGER array of dimension (NMAT)
2260 * Values of LDAD (leading dimension of A on destination
2261 * process) to be tested.
2262 * NSRC (input) INTEGER
2263 * The number of sources to be tested.
2264 *
2265 * RSRC0 (input) INTEGER array of dimension (NDEST)
2266 * Values of RSRC (row coordinate of source) to be tested.
2267 *
2268 * CSRC0 (input) INTEGER array of dimension (NDEST)
2269 * Values of CSRC (column coordinate of source) to be tested.
2270 *
2271 * RDEST0 (input) INTEGER array of dimension (NNSRC)
2272 * Values of RDEST (row coordinate of destination) to be
2273 * tested.
2274 *
2275 * CDEST0 (input) INTEGER array of dimension (NNSRC)
2276 * Values of CDEST (column coordinate of destination) to be
2277 * tested.
2278 *
2279 * NGRID (input) INTEGER
2280 * The number of process grids to be tested.
2281 *
2282 * CONTEXT0 (input) INTEGER array of dimension (NGRID)
2283 * The BLACS context handles corresponding to the grids.
2284 *
2285 * P0 (input) INTEGER array of dimension (NGRID)
2286 * Values of P (number of process rows, NPROW).
2287 *
2288 * Q0 (input) INTEGER array of dimension (NGRID)
2289 * Values of Q (number of process columns, NPCOL).
2290 *
2291 * TFAIL (workspace) INTEGER array of dimension (NTESTS)
2292 * If VERB < 2, serves to indicate which tests fail. This
2293 * requires workspace of NTESTS (number of tests performed).
2294 *
2295 * MEM (workspace) INTEGER array of dimension (MEMLEN)
2296 * Used for all other workspaces, including the matrix A,
2297 * and its pre and post padding.
2298 *
2299 * MEMLEN (input) INTEGER
2300 * The length, in elements, of MEM.
2301 *
2302 * =====================================================================
2303 *
2304 * .. External Functions ..
2305  LOGICAL ALLPASS
2306  INTEGER IBTMYPROC, IBTSIZEOF
2307  EXTERNAL ALLPASS, IBTMYPROC, IBTSIZEOF
2308 * ..
2309 * .. External Subroutines ..
2310  EXTERNAL BLACS_GRIDINFO
2311  EXTERNAL ITRSD2D, IGESD2D, ITRRV2D, IGERV2D
2312  EXTERNAL IINITMAT, ICHKMAT, ICHKPAD, IBTCHECKIN
2313 * ..
2314 * .. Local Scalars ..
2315  CHARACTER*1 UPLO, DIAG
2316  LOGICAL TESTOK
2317  INTEGER IAM, I, K, IGR, ISH, IMA, ISO, MYROW, MYCOL, IPRE, IPOST
2318  INTEGER M, N, NPROW, NPCOL, RSRC, CSRC, RDEST, CDEST
2319  INTEGER NERR, NSKIP, NFAIL, TESTNUM, CONTEXT, MAXERR, LDASRC
2320  INTEGER LDADST, ERRDPTR, APTR, ERRIPTR, ISIZE
2321  INTEGER SCHECKVAL, RCHECKVAL
2322 * ..
2323 * .. Executable Statements ..
2324 *
2325  scheckval = -1
2326  rcheckval = -2
2327 *
2328  iam = ibtmyproc()
2329  isize = ibtsizeof('I')
2330  isize = ibtsizeof('I')
2331 *
2332 * Verify file parameters
2333 *
2334  IF( iam .EQ. 0 ) THEN
2335  WRITE(outnum, *) ' '
2336  WRITE(outnum, *) ' '
2337  WRITE(outnum, 1000 )
2338  IF( verb .GT. 0 ) THEN
2339  WRITE(outnum,*) ' '
2340  WRITE(outnum, 2000) 'NSHAPE:', nshape
2341  WRITE(outnum, 3000) ' UPLO :', ( uplo0(i), i = 1, nshape )
2342  WRITE(outnum, 3000) ' DIAG :', ( diag0(i), i = 1, nshape )
2343  WRITE(outnum, 2000) 'NMAT :', nmat
2344  WRITE(outnum, 2000) ' M :', ( m0(i), i = 1, nmat )
2345  WRITE(outnum, 2000) ' N :', ( n0(i), i = 1, nmat )
2346  WRITE(outnum, 2000) ' LDAS :', ( ldas0(i), i = 1, nmat )
2347  WRITE(outnum, 2000) ' LDAD :', ( ldad0(i), i = 1, nmat )
2348  WRITE(outnum, 2000) 'NSRC :', nsrc
2349  WRITE(outnum, 2000) ' RSRC :',( rsrc0(i), i = 1, nsrc )
2350  WRITE(outnum, 2000) ' CSRC :',( csrc0(i), i = 1, nsrc )
2351  WRITE(outnum, 2000) ' RDEST:',( rdest0(i), i = 1, nsrc )
2352  WRITE(outnum, 2000) ' CDEST:',( cdest0(i), i = 1, nsrc )
2353  WRITE(outnum, 2000) 'NGRIDS:', ngrid
2354  WRITE(outnum, 2000) ' P :', ( p0(i), i = 1, ngrid )
2355  WRITE(outnum, 2000) ' Q :', ( q0(i), i = 1, ngrid )
2356  WRITE(outnum, 2000) 'VERB :', verb
2357  WRITE(outnum,*) ' '
2358  END IF
2359  IF( verb .GT. 1 ) THEN
2360  WRITE(outnum,5000)
2361  WRITE(outnum,6000)
2362  END IF
2363  END IF
2364 *
2365 * Find biggest matrix, so we know where to stick error info
2366 *
2367  i = 0
2368  DO 10 ima = 1, nmat
2369  k = n0(ima) * max0( ldas0(ima), ldad0(ima) ) + 4 * m0(ima)
2370  IF( k .GT. i ) i = k
2371  10 CONTINUE
2372  maxerr = ( isize * (memlen-i) ) / ( isize*2 + isize*6 )
2373  IF( maxerr .LT. 1 ) THEN
2374  WRITE(outnum,*) 'ERROR: Not enough memory to run SDRV tests.'
2375  CALL blacs_abort(-1, 1)
2376  END IF
2377  errdptr = i + 1
2378  erriptr = errdptr + maxerr
2379  nerr = 0
2380  testnum = 0
2381  nfail = 0
2382  nskip = 0
2383 *
2384 * Loop over grids of matrix
2385 *
2386  DO 110 igr = 1, ngrid
2387 *
2388  context = context0(igr)
2389  CALL blacs_gridinfo( context, nprow, npcol, myrow, mycol )
2390 *
2391  DO 80 ish = 1, nshape
2392  uplo = uplo0(ish)
2393  diag = diag0(ish)
2394 *
2395  DO 70 ima = 1, nmat
2396  m = m0(ima)
2397  n = n0(ima)
2398  ldasrc = ldas0(ima)
2399  ldadst = ldad0(ima)
2400 *
2401  DO 60 iso = 1, nsrc
2402  testnum = testnum + 1
2403  rsrc = rsrc0(iso)
2404  csrc = csrc0(iso)
2405  IF( rsrc.GE.p0(igr) .OR. csrc.GE.q0(igr) ) THEN
2406  nskip = nskip + 1
2407  GOTO 60
2408  END IF
2409  rdest = rdest0(iso)
2410  cdest = cdest0(iso)
2411  IF( rdest.GE.p0(igr) .OR. cdest.GE.q0(igr) ) THEN
2412  nskip = nskip + 1
2413  GOTO 60
2414  END IF
2415 *
2416  IF( verb .GT. 1 ) THEN
2417  IF( iam .EQ. 0 ) THEN
2418  WRITE(outnum, 7000) testnum, 'RUNNING',
2419  $ uplo, diag, m, n,
2420  $ ldasrc, ldadst, rsrc, csrc,
2421  $ rdest, cdest, nprow, npcol
2422  END IF
2423  END IF
2424 *
2425  testok = .true.
2426  ipre = 2 * m
2427  ipost = ipre
2428  aptr = ipre + 1
2429 *
2430 * source process generates matrix and sends it
2431 *
2432  IF( myrow .EQ. rsrc .AND. mycol .EQ. csrc ) THEN
2433  CALL iinitmat( uplo, diag, m, n, mem, ldasrc,
2434  $ ipre, ipost, scheckval, testnum,
2435  $ myrow, mycol )
2436 *
2437  IF( uplo .EQ. 'U' .OR. uplo .EQ. 'L' ) THEN
2438  CALL itrsd2d( context, uplo, diag, m, n,
2439  $ mem(aptr), ldasrc, rdest, cdest )
2440  ELSE
2441  CALL igesd2d( context, m, n, mem(aptr),
2442  $ ldasrc, rdest, cdest )
2443  END IF
2444  END IF
2445 *
2446  IF( myrow .EQ. rdest .AND. mycol .EQ. cdest ) THEN
2447 *
2448 * Pad entire matrix area
2449 *
2450  DO 50 k = 1, ipre+ipost+ldadst*n
2451  mem(k) = rcheckval
2452  50 CONTINUE
2453 *
2454 * Receive matrix
2455 *
2456  IF( uplo .EQ. 'U' .OR. uplo .EQ. 'L' ) THEN
2457  CALL itrrv2d( context, uplo, diag, m, n,
2458  $ mem(aptr), ldadst, rsrc, csrc )
2459  ELSE
2460  CALL igerv2d( context, m, n, mem(aptr),
2461  $ ldadst, rsrc, csrc )
2462  END IF
2463 *
2464 * Check for errors in matrix or padding
2465 *
2466  i = nerr
2467  CALL ichkmat( uplo, diag, m, n, mem(aptr), ldadst,
2468  $ rsrc, csrc, myrow, mycol, testnum, maxerr,
2469  $ nerr, mem(erriptr), mem(errdptr) )
2470 *
2471  CALL ichkpad( uplo, diag, m, n, mem, ldadst,
2472  $ rsrc, csrc, myrow, mycol, ipre, ipost,
2473  $ rcheckval, testnum, maxerr, nerr,
2474  $ mem(erriptr), mem(errdptr) )
2475  testok = i .EQ. nerr
2476  END IF
2477 *
2478  IF( verb .GT. 1 ) THEN
2479  i = nerr
2480  CALL ibtcheckin( 0, outnum, maxerr, nerr,
2481  $ mem(erriptr), mem(errdptr),
2482  $ tfail )
2483  IF( iam .EQ. 0 ) THEN
2484  IF( testok .AND. i.EQ.nerr ) THEN
2485  WRITE(outnum, 7000) testnum, 'PASSED ',
2486  $ uplo, diag, m, n, ldasrc, ldadst,
2487  $ rsrc, csrc, rdest, cdest, nprow, npcol
2488  ELSE
2489  nfail = nfail + 1
2490  WRITE(outnum, 7000) testnum, 'FAILED ',
2491  $ uplo, diag, m, n, ldasrc, ldadst,
2492  $ rsrc, csrc, rdest, cdest, nprow, npcol
2493  ENDIF
2494  END IF
2495 *
2496 * Once we've printed out errors, can re-use buf space
2497 *
2498  nerr = 0
2499  END IF
2500  60 CONTINUE
2501  70 CONTINUE
2502  80 CONTINUE
2503  110 CONTINUE
2504 *
2505  IF( verb .LT. 2 ) THEN
2506  nfail = testnum
2507  CALL ibtcheckin( nfail, outnum, maxerr, nerr, mem(erriptr),
2508  $ mem(errdptr), tfail )
2509  END IF
2510  IF( iam .EQ. 0 ) THEN
2511  IF( verb .GT. 1 ) WRITE(outnum,*) ' '
2512  IF( nfail+nskip .EQ. 0 ) THEN
2513  WRITE(outnum, 8000 ) testnum
2514  ELSE
2515  WRITE(outnum, 9000 ) testnum, testnum-nskip-nfail,
2516  $ nskip, nfail
2517  END IF
2518  END IF
2519 *
2520 * Log whether their were any failures
2521 *
2522  testok = allpass( (nfail.EQ.0) )
2523 *
2524  1000 FORMAT('INTEGER SDRV TESTS: BEGIN.' )
2525  2000 FORMAT(1x,a7,3x,10i6)
2526  3000 FORMAT(1x,a7,3x,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,
2527  $ 5x,a1,5x,a1)
2528  5000 FORMAT(' TEST# STATUS UPLO DIA M N LDAS LDAD RSRC ',
2529  $ 'CSRC RDEST CDEST P Q')
2530  6000 FORMAT(' ----- ------- ---- --- ----- ----- ----- ----- ---- ',
2531  $ '---- ----- ----- ---- ----')
2532  7000 FORMAT(i6,1x,a7,4x,a1,3x,a1,4i6,2i5,2i6,2i5)
2533  8000 FORMAT('INTEGER SDRV TESTS: PASSED ALL',
2534  $ i5, ' TESTS.')
2535  9000 FORMAT('INTEGER SDRV TESTS:',i5,' TESTS;',i5,' PASSED,',
2536  $ i5,' SKIPPED,',i5,' FAILED.')
2537 *
2538  RETURN
2539 *
2540 * End of ISDRVTEST.
2541 *
2542  END
2543 *
2544 *
2545  SUBROUTINE ssdrvtest( OUTNUM, VERB, NSHAPE, UPLO0, DIAG0,
2546  $ NMAT, M0, N0, LDAS0, LDAD0, NSRC, RSRC0,
2547  $ CSRC0, RDEST0, CDEST0, NGRID, CONTEXT0,
2548  $ P0, Q0, TFAIL, MEM, MEMLEN )
2549 *
2550 * -- BLACS tester (version 1.0) --
2551 * University of Tennessee
2552 * December 15, 1994
2553 *
2554 *
2555 * .. Scalar Arguments ..
2556  INTEGER OUTNUM, VERB, NSHAPE, NMAT, NSRC, NGRID, MEMLEN
2557 * ..
2558 * .. Array Arguments ..
2559  CHARACTER*1 UPLO0(NSHAPE), DIAG0(NSHAPE)
2560  INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT)
2561  INTEGER RSRC0(NSRC), CSRC0(NSRC), RDEST0(NSRC), CDEST0(NSRC)
2562  INTEGER CONTEXT0(NGRID), P0(NGRID), Q0(NGRID), TFAIL(*)
2563  REAL MEM(MEMLEN)
2564 * ..
2565 *
2566 * Purpose
2567 * =======
2568 * STESTSDRV: Test real send/recv
2569 *
2570 * Arguments
2571 * =========
2572 * OUTNUM (input) INTEGER
2573 * The device number to write output to.
2574 *
2575 * VERB (input) INTEGER
2576 * The level of verbosity (how much printing to do).
2577 *
2578 * NSHAPE (input) INTEGER
2579 * The number of matrix shapes to be tested.
2580 *
2581 * UPLO0 (input) CHARACTER*1 array of dimension (NSHAPE)
2582 * Values of UPLO to be tested.
2583 *
2584 * DIAG0 (input) CHARACTER*1 array of dimension (NSHAPE)
2585 * Values of DIAG to be tested.
2586 *
2587 * NMAT (input) INTEGER
2588 * The number of matrices to be tested.
2589 *
2590 * M0 (input) INTEGER array of dimension (NMAT)
2591 * Values of M to be tested.
2592 *
2593 * M0 (input) INTEGER array of dimension (NMAT)
2594 * Values of M to be tested.
2595 *
2596 * N0 (input) INTEGER array of dimension (NMAT)
2597 * Values of N to be tested.
2598 *
2599 * LDAS0 (input) INTEGER array of dimension (NMAT)
2600 * Values of LDAS (leading dimension of A on source process)
2601 * to be tested.
2602 *
2603 * LDAD0 (input) INTEGER array of dimension (NMAT)
2604 * Values of LDAD (leading dimension of A on destination
2605 * process) to be tested.
2606 * NSRC (input) INTEGER
2607 * The number of sources to be tested.
2608 *
2609 * RSRC0 (input) INTEGER array of dimension (NDEST)
2610 * Values of RSRC (row coordinate of source) to be tested.
2611 *
2612 * CSRC0 (input) INTEGER array of dimension (NDEST)
2613 * Values of CSRC (column coordinate of source) to be tested.
2614 *
2615 * RDEST0 (input) INTEGER array of dimension (NNSRC)
2616 * Values of RDEST (row coordinate of destination) to be
2617 * tested.
2618 *
2619 * CDEST0 (input) INTEGER array of dimension (NNSRC)
2620 * Values of CDEST (column coordinate of destination) to be
2621 * tested.
2622 *
2623 * NGRID (input) INTEGER
2624 * The number of process grids to be tested.
2625 *
2626 * CONTEXT0 (input) INTEGER array of dimension (NGRID)
2627 * The BLACS context handles corresponding to the grids.
2628 *
2629 * P0 (input) INTEGER array of dimension (NGRID)
2630 * Values of P (number of process rows, NPROW).
2631 *
2632 * Q0 (input) INTEGER array of dimension (NGRID)
2633 * Values of Q (number of process columns, NPCOL).
2634 *
2635 * TFAIL (workspace) INTEGER array of dimension (NTESTS)
2636 * If VERB < 2, serves to indicate which tests fail. This
2637 * requires workspace of NTESTS (number of tests performed).
2638 *
2639 * MEM (workspace) REAL array of dimension (MEMLEN)
2640 * Used for all other workspaces, including the matrix A,
2641 * and its pre and post padding.
2642 *
2643 * MEMLEN (input) INTEGER
2644 * The length, in elements, of MEM.
2645 *
2646 * =====================================================================
2647 *
2648 * .. External Functions ..
2649  LOGICAL ALLPASS
2650  INTEGER IBTMYPROC, IBTSIZEOF
2651  EXTERNAL ALLPASS, IBTMYPROC, IBTSIZEOF
2652 * ..
2653 * .. External Subroutines ..
2654  EXTERNAL BLACS_GRIDINFO
2655  EXTERNAL STRSD2D, SGESD2D, STRRV2D, SGERV2D
2656  EXTERNAL SINITMAT, SCHKMAT, SCHKPAD, SBTCHECKIN
2657 * ..
2658 * .. Local Scalars ..
2659  CHARACTER*1 UPLO, DIAG
2660  LOGICAL TESTOK
2661  INTEGER IAM, I, K, IGR, ISH, IMA, ISO, MYROW, MYCOL, IPRE, IPOST
2662  INTEGER M, N, NPROW, NPCOL, RSRC, CSRC, RDEST, CDEST
2663  INTEGER NERR, NSKIP, NFAIL, TESTNUM, CONTEXT, MAXERR, LDASRC
2664  INTEGER LDADST, ERRDPTR, APTR, ERRIPTR, ISIZE, SSIZE
2665  REAL SCHECKVAL, RCHECKVAL
2666 * ..
2667 * .. Executable Statements ..
2668 *
2669  SCHECKVAL = -0.01e0
2670  rcheckval = -0.02e0
2671 *
2672  iam = ibtmyproc()
2673  isize = ibtsizeof('I')
2674  ssize = ibtsizeof('S')
2675 *
2676 * Verify file parameters
2677 *
2678  IF( iam .EQ. 0 ) THEN
2679  WRITE(outnum, *) ' '
2680  WRITE(outnum, *) ' '
2681  WRITE(outnum, 1000 )
2682  IF( verb .GT. 0 ) THEN
2683  WRITE(outnum,*) ' '
2684  WRITE(outnum, 2000) 'NSHAPE:', nshape
2685  WRITE(outnum, 3000) ' UPLO :', ( uplo0(i), i = 1, nshape )
2686  WRITE(outnum, 3000) ' DIAG :', ( diag0(i), i = 1, nshape )
2687  WRITE(outnum, 2000) 'NMAT :', nmat
2688  WRITE(outnum, 2000) ' M :', ( m0(i), i = 1, nmat )
2689  WRITE(outnum, 2000) ' N :', ( n0(i), i = 1, nmat )
2690  WRITE(outnum, 2000) ' LDAS :', ( ldas0(i), i = 1, nmat )
2691  WRITE(outnum, 2000) ' LDAD :', ( ldad0(i), i = 1, nmat )
2692  WRITE(outnum, 2000) 'NSRC :', nsrc
2693  WRITE(outnum, 2000) ' RSRC :',( rsrc0(i), i = 1, nsrc )
2694  WRITE(outnum, 2000) ' CSRC :',( csrc0(i), i = 1, nsrc )
2695  WRITE(outnum, 2000) ' RDEST:',( rdest0(i), i = 1, nsrc )
2696  WRITE(outnum, 2000) ' CDEST:',( cdest0(i), i = 1, nsrc )
2697  WRITE(outnum, 2000) 'NGRIDS:', ngrid
2698  WRITE(outnum, 2000) ' P :', ( p0(i), i = 1, ngrid )
2699  WRITE(outnum, 2000) ' Q :', ( q0(i), i = 1, ngrid )
2700  WRITE(outnum, 2000) 'VERB :', verb
2701  WRITE(outnum,*) ' '
2702  END IF
2703  IF( verb .GT. 1 ) THEN
2704  WRITE(outnum,5000)
2705  WRITE(outnum,6000)
2706  END IF
2707  END IF
2708 *
2709 * Find biggest matrix, so we know where to stick error info
2710 *
2711  i = 0
2712  DO 10 ima = 1, nmat
2713  k = n0(ima) * max0( ldas0(ima), ldad0(ima) ) + 4 * m0(ima)
2714  IF( k .GT. i ) i = k
2715  10 CONTINUE
2716  maxerr = ( ssize * (memlen-i) ) / ( ssize*2 + isize*6 )
2717  IF( maxerr .LT. 1 ) THEN
2718  WRITE(outnum,*) 'ERROR: Not enough memory to run SDRV tests.'
2719  CALL blacs_abort(-1, 1)
2720  END IF
2721  errdptr = i + 1
2722  erriptr = errdptr + maxerr
2723  nerr = 0
2724  testnum = 0
2725  nfail = 0
2726  nskip = 0
2727 *
2728 * Loop over grids of matrix
2729 *
2730  DO 110 igr = 1, ngrid
2731 *
2732  context = context0(igr)
2733  CALL blacs_gridinfo( context, nprow, npcol, myrow, mycol )
2734 *
2735  DO 80 ish = 1, nshape
2736  uplo = uplo0(ish)
2737  diag = diag0(ish)
2738 *
2739  DO 70 ima = 1, nmat
2740  m = m0(ima)
2741  n = n0(ima)
2742  ldasrc = ldas0(ima)
2743  ldadst = ldad0(ima)
2744 *
2745  DO 60 iso = 1, nsrc
2746  testnum = testnum + 1
2747  rsrc = rsrc0(iso)
2748  csrc = csrc0(iso)
2749  IF( rsrc.GE.p0(igr) .OR. csrc.GE.q0(igr) ) THEN
2750  nskip = nskip + 1
2751  GOTO 60
2752  END IF
2753  rdest = rdest0(iso)
2754  cdest = cdest0(iso)
2755  IF( rdest.GE.p0(igr) .OR. cdest.GE.q0(igr) ) THEN
2756  nskip = nskip + 1
2757  GOTO 60
2758  END IF
2759 *
2760  IF( verb .GT. 1 ) THEN
2761  IF( iam .EQ. 0 ) THEN
2762  WRITE(outnum, 7000) testnum, 'RUNNING',
2763  $ uplo, diag, m, n,
2764  $ ldasrc, ldadst, rsrc, csrc,
2765  $ rdest, cdest, nprow, npcol
2766  END IF
2767  END IF
2768 *
2769  testok = .true.
2770  ipre = 2 * m
2771  ipost = ipre
2772  aptr = ipre + 1
2773 *
2774 * source process generates matrix and sends it
2775 *
2776  IF( myrow .EQ. rsrc .AND. mycol .EQ. csrc ) THEN
2777  CALL sinitmat( uplo, diag, m, n, mem, ldasrc,
2778  $ ipre, ipost, scheckval, testnum,
2779  $ myrow, mycol )
2780 *
2781  IF( uplo .EQ. 'U' .OR. uplo .EQ. 'L' ) THEN
2782  CALL strsd2d( context, uplo, diag, m, n,
2783  $ mem(aptr), ldasrc, rdest, cdest )
2784  ELSE
2785  CALL sgesd2d( context, m, n, mem(aptr),
2786  $ ldasrc, rdest, cdest )
2787  END IF
2788  END IF
2789 *
2790  IF( myrow .EQ. rdest .AND. mycol .EQ. cdest ) THEN
2791 *
2792 * Pad entire matrix area
2793 *
2794  DO 50 k = 1, ipre+ipost+ldadst*n
2795  mem(k) = rcheckval
2796  50 CONTINUE
2797 *
2798 * Receive matrix
2799 *
2800  IF( uplo .EQ. 'U' .OR. uplo .EQ. 'L' ) THEN
2801  CALL strrv2d( context, uplo, diag, m, n,
2802  $ mem(aptr), ldadst, rsrc, csrc )
2803  ELSE
2804  CALL sgerv2d( context, m, n, mem(aptr),
2805  $ ldadst, rsrc, csrc )
2806  END IF
2807 *
2808 * Check for errors in matrix or padding
2809 *
2810  i = nerr
2811  CALL schkmat( uplo, diag, m, n, mem(aptr), ldadst,
2812  $ rsrc, csrc, myrow, mycol, testnum, maxerr,
2813  $ nerr, mem(erriptr), mem(errdptr) )
2814 *
2815  CALL schkpad( uplo, diag, m, n, mem, ldadst,
2816  $ rsrc, csrc, myrow, mycol, ipre, ipost,
2817  $ rcheckval, testnum, maxerr, nerr,
2818  $ mem(erriptr), mem(errdptr) )
2819  testok = i .EQ. nerr
2820  END IF
2821 *
2822  IF( verb .GT. 1 ) THEN
2823  i = nerr
2824  CALL sbtcheckin( 0, outnum, maxerr, nerr,
2825  $ mem(erriptr), mem(errdptr),
2826  $ tfail )
2827  IF( iam .EQ. 0 ) THEN
2828  IF( testok .AND. i.EQ.nerr ) THEN
2829  WRITE(outnum, 7000) testnum, 'PASSED ',
2830  $ uplo, diag, m, n, ldasrc, ldadst,
2831  $ rsrc, csrc, rdest, cdest, nprow, npcol
2832  ELSE
2833  nfail = nfail + 1
2834  WRITE(outnum, 7000) testnum, 'FAILED ',
2835  $ uplo, diag, m, n, ldasrc, ldadst,
2836  $ rsrc, csrc, rdest, cdest, nprow, npcol
2837  ENDIF
2838  END IF
2839 *
2840 * Once we've printed out errors, can re-use buf space
2841 *
2842  nerr = 0
2843  END IF
2844  60 CONTINUE
2845  70 CONTINUE
2846  80 CONTINUE
2847  110 CONTINUE
2848 *
2849  IF( verb .LT. 2 ) THEN
2850  nfail = testnum
2851  CALL sbtcheckin( nfail, outnum, maxerr, nerr, mem(erriptr),
2852  $ mem(errdptr), tfail )
2853  END IF
2854  IF( iam .EQ. 0 ) THEN
2855  IF( verb .GT. 1 ) WRITE(outnum,*) ' '
2856  IF( nfail+nskip .EQ. 0 ) THEN
2857  WRITE(outnum, 8000 ) testnum
2858  ELSE
2859  WRITE(outnum, 9000 ) testnum, testnum-nskip-nfail,
2860  $ nskip, nfail
2861  END IF
2862  END IF
2863 *
2864 * Log whether their were any failures
2865 *
2866  testok = allpass( (nfail.EQ.0) )
2867 *
2868  1000 FORMAT('REAL SDRV TESTS: BEGIN.' )
2869  2000 FORMAT(1x,a7,3x,10i6)
2870  3000 FORMAT(1x,a7,3x,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,
2871  $ 5x,a1,5x,a1)
2872  5000 FORMAT(' TEST# STATUS UPLO DIA M N LDAS LDAD RSRC ',
2873  $ 'CSRC RDEST CDEST P Q')
2874  6000 FORMAT(' ----- ------- ---- --- ----- ----- ----- ----- ---- ',
2875  $ '---- ----- ----- ---- ----')
2876  7000 FORMAT(i6,1x,a7,4x,a1,3x,a1,4i6,2i5,2i6,2i5)
2877  8000 FORMAT('REAL SDRV TESTS: PASSED ALL',
2878  $ i5, ' TESTS.')
2879  9000 FORMAT('REAL SDRV TESTS:',i5,' TESTS;',i5,' PASSED,',
2880  $ i5,' SKIPPED,',i5,' FAILED.')
2881 *
2882  RETURN
2883 *
2884 * End of SSDRVTEST.
2885 *
2886  END
2887 *
2888 *
2889  SUBROUTINE dsdrvtest( OUTNUM, VERB, NSHAPE, UPLO0, DIAG0,
2890  $ NMAT, M0, N0, LDAS0, LDAD0, NSRC, RSRC0,
2891  $ CSRC0, RDEST0, CDEST0, NGRID, CONTEXT0,
2892  $ P0, Q0, TFAIL, MEM, MEMLEN )
2893 *
2894 * -- BLACS tester (version 1.0) --
2895 * University of Tennessee
2896 * December 15, 1994
2897 *
2898 *
2899 * .. Scalar Arguments ..
2900  INTEGER OUTNUM, VERB, NSHAPE, NMAT, NSRC, NGRID, MEMLEN
2901 * ..
2902 * .. Array Arguments ..
2903  CHARACTER*1 UPLO0(NSHAPE), DIAG0(NSHAPE)
2904  INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT)
2905  INTEGER RSRC0(NSRC), CSRC0(NSRC), RDEST0(NSRC), CDEST0(NSRC)
2906  INTEGER CONTEXT0(NGRID), P0(NGRID), Q0(NGRID), TFAIL(*)
2907  DOUBLE PRECISION MEM(MEMLEN)
2908 * ..
2909 *
2910 * Purpose
2911 * =======
2912 * DTESTSDRV: Test double precision send/recv
2913 *
2914 * Arguments
2915 * =========
2916 * OUTNUM (input) INTEGER
2917 * The device number to write output to.
2918 *
2919 * VERB (input) INTEGER
2920 * The level of verbosity (how much printing to do).
2921 *
2922 * NSHAPE (input) INTEGER
2923 * The number of matrix shapes to be tested.
2924 *
2925 * UPLO0 (input) CHARACTER*1 array of dimension (NSHAPE)
2926 * Values of UPLO to be tested.
2927 *
2928 * DIAG0 (input) CHARACTER*1 array of dimension (NSHAPE)
2929 * Values of DIAG to be tested.
2930 *
2931 * NMAT (input) INTEGER
2932 * The number of matrices to be tested.
2933 *
2934 * M0 (input) INTEGER array of dimension (NMAT)
2935 * Values of M to be tested.
2936 *
2937 * M0 (input) INTEGER array of dimension (NMAT)
2938 * Values of M to be tested.
2939 *
2940 * N0 (input) INTEGER array of dimension (NMAT)
2941 * Values of N to be tested.
2942 *
2943 * LDAS0 (input) INTEGER array of dimension (NMAT)
2944 * Values of LDAS (leading dimension of A on source process)
2945 * to be tested.
2946 *
2947 * LDAD0 (input) INTEGER array of dimension (NMAT)
2948 * Values of LDAD (leading dimension of A on destination
2949 * process) to be tested.
2950 * NSRC (input) INTEGER
2951 * The number of sources to be tested.
2952 *
2953 * RSRC0 (input) INTEGER array of dimension (NDEST)
2954 * Values of RSRC (row coordinate of source) to be tested.
2955 *
2956 * CSRC0 (input) INTEGER array of dimension (NDEST)
2957 * Values of CSRC (column coordinate of source) to be tested.
2958 *
2959 * RDEST0 (input) INTEGER array of dimension (NNSRC)
2960 * Values of RDEST (row coordinate of destination) to be
2961 * tested.
2962 *
2963 * CDEST0 (input) INTEGER array of dimension (NNSRC)
2964 * Values of CDEST (column coordinate of destination) to be
2965 * tested.
2966 *
2967 * NGRID (input) INTEGER
2968 * The number of process grids to be tested.
2969 *
2970 * CONTEXT0 (input) INTEGER array of dimension (NGRID)
2971 * The BLACS context handles corresponding to the grids.
2972 *
2973 * P0 (input) INTEGER array of dimension (NGRID)
2974 * Values of P (number of process rows, NPROW).
2975 *
2976 * Q0 (input) INTEGER array of dimension (NGRID)
2977 * Values of Q (number of process columns, NPCOL).
2978 *
2979 * TFAIL (workspace) INTEGER array of dimension (NTESTS)
2980 * If VERB < 2, serves to indicate which tests fail. This
2981 * requires workspace of NTESTS (number of tests performed).
2982 *
2983 * MEM (workspace) DOUBLE PRECISION array of dimension (MEMLEN)
2984 * Used for all other workspaces, including the matrix A,
2985 * and its pre and post padding.
2986 *
2987 * MEMLEN (input) INTEGER
2988 * The length, in elements, of MEM.
2989 *
2990 * =====================================================================
2991 *
2992 * .. External Functions ..
2993  LOGICAL ALLPASS
2994  INTEGER IBTMYPROC, IBTSIZEOF
2995  EXTERNAL ALLPASS, IBTMYPROC, IBTSIZEOF
2996 * ..
2997 * .. External Subroutines ..
2998  EXTERNAL BLACS_GRIDINFO
2999  EXTERNAL DTRSD2D, DGESD2D, DTRRV2D, DGERV2D
3000  EXTERNAL DINITMAT, DCHKMAT, DCHKPAD, DBTCHECKIN
3001 * ..
3002 * .. Local Scalars ..
3003  CHARACTER*1 UPLO, DIAG
3004  LOGICAL TESTOK
3005  INTEGER IAM, I, K, IGR, ISH, IMA, ISO, MYROW, MYCOL, IPRE, IPOST
3006  INTEGER M, N, NPROW, NPCOL, RSRC, CSRC, RDEST, CDEST
3007  INTEGER NERR, NSKIP, NFAIL, TESTNUM, CONTEXT, MAXERR, LDASRC
3008  INTEGER LDADST, ERRDPTR, APTR, ERRIPTR, ISIZE, DSIZE
3009  DOUBLE PRECISION SCHECKVAL, RCHECKVAL
3010 * ..
3011 * .. Executable Statements ..
3012 *
3013  SCHECKVAL = -0.01d0
3014  rcheckval = -0.02d0
3015 *
3016  iam = ibtmyproc()
3017  isize = ibtsizeof('I')
3018  dsize = ibtsizeof('D')
3019 *
3020 * Verify file parameters
3021 *
3022  IF( iam .EQ. 0 ) THEN
3023  WRITE(outnum, *) ' '
3024  WRITE(outnum, *) ' '
3025  WRITE(outnum, 1000 )
3026  IF( verb .GT. 0 ) THEN
3027  WRITE(outnum,*) ' '
3028  WRITE(outnum, 2000) 'NSHAPE:', nshape
3029  WRITE(outnum, 3000) ' UPLO :', ( uplo0(i), i = 1, nshape )
3030  WRITE(outnum, 3000) ' DIAG :', ( diag0(i), i = 1, nshape )
3031  WRITE(outnum, 2000) 'NMAT :', nmat
3032  WRITE(outnum, 2000) ' M :', ( m0(i), i = 1, nmat )
3033  WRITE(outnum, 2000) ' N :', ( n0(i), i = 1, nmat )
3034  WRITE(outnum, 2000) ' LDAS :', ( ldas0(i), i = 1, nmat )
3035  WRITE(outnum, 2000) ' LDAD :', ( ldad0(i), i = 1, nmat )
3036  WRITE(outnum, 2000) 'NSRC :', nsrc
3037  WRITE(outnum, 2000) ' RSRC :',( rsrc0(i), i = 1, nsrc )
3038  WRITE(outnum, 2000) ' CSRC :',( csrc0(i), i = 1, nsrc )
3039  WRITE(outnum, 2000) ' RDEST:',( rdest0(i), i = 1, nsrc )
3040  WRITE(outnum, 2000) ' CDEST:',( cdest0(i), i = 1, nsrc )
3041  WRITE(outnum, 2000) 'NGRIDS:', ngrid
3042  WRITE(outnum, 2000) ' P :', ( p0(i), i = 1, ngrid )
3043  WRITE(outnum, 2000) ' Q :', ( q0(i), i = 1, ngrid )
3044  WRITE(outnum, 2000) 'VERB :', verb
3045  WRITE(outnum,*) ' '
3046  END IF
3047  IF( verb .GT. 1 ) THEN
3048  WRITE(outnum,5000)
3049  WRITE(outnum,6000)
3050  END IF
3051  END IF
3052 *
3053 * Find biggest matrix, so we know where to stick error info
3054 *
3055  i = 0
3056  DO 10 ima = 1, nmat
3057  k = n0(ima) * max0( ldas0(ima), ldad0(ima) ) + 4 * m0(ima)
3058  IF( k .GT. i ) i = k
3059  10 CONTINUE
3060  maxerr = ( dsize * (memlen-i) ) / ( dsize*2 + isize*6 )
3061  IF( maxerr .LT. 1 ) THEN
3062  WRITE(outnum,*) 'ERROR: Not enough memory to run SDRV tests.'
3063  CALL blacs_abort(-1, 1)
3064  END IF
3065  errdptr = i + 1
3066  erriptr = errdptr + maxerr
3067  nerr = 0
3068  testnum = 0
3069  nfail = 0
3070  nskip = 0
3071 *
3072 * Loop over grids of matrix
3073 *
3074  DO 110 igr = 1, ngrid
3075 *
3076  context = context0(igr)
3077  CALL blacs_gridinfo( context, nprow, npcol, myrow, mycol )
3078 *
3079  DO 80 ish = 1, nshape
3080  uplo = uplo0(ish)
3081  diag = diag0(ish)
3082 *
3083  DO 70 ima = 1, nmat
3084  m = m0(ima)
3085  n = n0(ima)
3086  ldasrc = ldas0(ima)
3087  ldadst = ldad0(ima)
3088 *
3089  DO 60 iso = 1, nsrc
3090  testnum = testnum + 1
3091  rsrc = rsrc0(iso)
3092  csrc = csrc0(iso)
3093  IF( rsrc.GE.p0(igr) .OR. csrc.GE.q0(igr) ) THEN
3094  nskip = nskip + 1
3095  GOTO 60
3096  END IF
3097  rdest = rdest0(iso)
3098  cdest = cdest0(iso)
3099  IF( rdest.GE.p0(igr) .OR. cdest.GE.q0(igr) ) THEN
3100  nskip = nskip + 1
3101  GOTO 60
3102  END IF
3103 *
3104  IF( verb .GT. 1 ) THEN
3105  IF( iam .EQ. 0 ) THEN
3106  WRITE(outnum, 7000) testnum, 'RUNNING',
3107  $ uplo, diag, m, n,
3108  $ ldasrc, ldadst, rsrc, csrc,
3109  $ rdest, cdest, nprow, npcol
3110  END IF
3111  END IF
3112 *
3113  testok = .true.
3114  ipre = 2 * m
3115  ipost = ipre
3116  aptr = ipre + 1
3117 *
3118 * source process generates matrix and sends it
3119 *
3120  IF( myrow .EQ. rsrc .AND. mycol .EQ. csrc ) THEN
3121  CALL dinitmat( uplo, diag, m, n, mem, ldasrc,
3122  $ ipre, ipost, scheckval, testnum,
3123  $ myrow, mycol )
3124 *
3125  IF( uplo .EQ. 'U' .OR. uplo .EQ. 'L' ) THEN
3126  CALL dtrsd2d( context, uplo, diag, m, n,
3127  $ mem(aptr), ldasrc, rdest, cdest )
3128  ELSE
3129  CALL dgesd2d( context, m, n, mem(aptr),
3130  $ ldasrc, rdest, cdest )
3131  END IF
3132  END IF
3133 *
3134  IF( myrow .EQ. rdest .AND. mycol .EQ. cdest ) THEN
3135 *
3136 * Pad entire matrix area
3137 *
3138  DO 50 k = 1, ipre+ipost+ldadst*n
3139  mem(k) = rcheckval
3140  50 CONTINUE
3141 *
3142 * Receive matrix
3143 *
3144  IF( uplo .EQ. 'U' .OR. uplo .EQ. 'L' ) THEN
3145  CALL dtrrv2d( context, uplo, diag, m, n,
3146  $ mem(aptr), ldadst, rsrc, csrc )
3147  ELSE
3148  CALL dgerv2d( context, m, n, mem(aptr),
3149  $ ldadst, rsrc, csrc )
3150  END IF
3151 *
3152 * Check for errors in matrix or padding
3153 *
3154  i = nerr
3155  CALL dchkmat( uplo, diag, m, n, mem(aptr), ldadst,
3156  $ rsrc, csrc, myrow, mycol, testnum, maxerr,
3157  $ nerr, mem(erriptr), mem(errdptr) )
3158 *
3159  CALL dchkpad( uplo, diag, m, n, mem, ldadst,
3160  $ rsrc, csrc, myrow, mycol, ipre, ipost,
3161  $ rcheckval, testnum, maxerr, nerr,
3162  $ mem(erriptr), mem(errdptr) )
3163  testok = i .EQ. nerr
3164  END IF
3165 *
3166  IF( verb .GT. 1 ) THEN
3167  i = nerr
3168  CALL dbtcheckin( 0, outnum, maxerr, nerr,
3169  $ mem(erriptr), mem(errdptr),
3170  $ tfail )
3171  IF( iam .EQ. 0 ) THEN
3172  IF( testok .AND. i.EQ.nerr ) THEN
3173  WRITE(outnum, 7000) testnum, 'PASSED ',
3174  $ uplo, diag, m, n, ldasrc, ldadst,
3175  $ rsrc, csrc, rdest, cdest, nprow, npcol
3176  ELSE
3177  nfail = nfail + 1
3178  WRITE(outnum, 7000) testnum, 'FAILED ',
3179  $ uplo, diag, m, n, ldasrc, ldadst,
3180  $ rsrc, csrc, rdest, cdest, nprow, npcol
3181  ENDIF
3182  END IF
3183 *
3184 * Once we've printed out errors, can re-use buf space
3185 *
3186  nerr = 0
3187  END IF
3188  60 CONTINUE
3189  70 CONTINUE
3190  80 CONTINUE
3191  110 CONTINUE
3192 *
3193  IF( verb .LT. 2 ) THEN
3194  nfail = testnum
3195  CALL dbtcheckin( nfail, outnum, maxerr, nerr, mem(erriptr),
3196  $ mem(errdptr), tfail )
3197  END IF
3198  IF( iam .EQ. 0 ) THEN
3199  IF( verb .GT. 1 ) WRITE(outnum,*) ' '
3200  IF( nfail+nskip .EQ. 0 ) THEN
3201  WRITE(outnum, 8000 ) testnum
3202  ELSE
3203  WRITE(outnum, 9000 ) testnum, testnum-nskip-nfail,
3204  $ nskip, nfail
3205  END IF
3206  END IF
3207 *
3208 * Log whether their were any failures
3209 *
3210  testok = allpass( (nfail.EQ.0) )
3211 *
3212  1000 FORMAT('DOUBLE PRECISION SDRV TESTS: BEGIN.' )
3213  2000 FORMAT(1x,a7,3x,10i6)
3214  3000 FORMAT(1x,a7,3x,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,
3215  $ 5x,a1,5x,a1)
3216  5000 FORMAT(' TEST# STATUS UPLO DIA M N LDAS LDAD RSRC ',
3217  $ 'CSRC RDEST CDEST P Q')
3218  6000 FORMAT(' ----- ------- ---- --- ----- ----- ----- ----- ---- ',
3219  $ '---- ----- ----- ---- ----')
3220  7000 FORMAT(i6,1x,a7,4x,a1,3x,a1,4i6,2i5,2i6,2i5)
3221  8000 FORMAT('DOUBLE PRECISION SDRV TESTS: PASSED ALL',
3222  $ i5, ' TESTS.')
3223  9000 FORMAT('DOUBLE PRECISION SDRV TESTS:',i5,' TESTS;',i5,' PASSED,',
3224  $ i5,' SKIPPED,',i5,' FAILED.')
3225 *
3226  RETURN
3227 *
3228 * End of DSDRVTEST.
3229 *
3230  END
3231 *
3232 *
3233  SUBROUTINE csdrvtest( OUTNUM, VERB, NSHAPE, UPLO0, DIAG0,
3234  $ NMAT, M0, N0, LDAS0, LDAD0, NSRC, RSRC0,
3235  $ CSRC0, RDEST0, CDEST0, NGRID, CONTEXT0,
3236  $ P0, Q0, TFAIL, MEM, MEMLEN )
3237 *
3238 * -- BLACS tester (version 1.0) --
3239 * University of Tennessee
3240 * December 15, 1994
3241 *
3242 *
3243 * .. Scalar Arguments ..
3244  INTEGER OUTNUM, VERB, NSHAPE, NMAT, NSRC, NGRID, MEMLEN
3245 * ..
3246 * .. Array Arguments ..
3247  CHARACTER*1 UPLO0(NSHAPE), DIAG0(NSHAPE)
3248  INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT)
3249  INTEGER RSRC0(NSRC), CSRC0(NSRC), RDEST0(NSRC), CDEST0(NSRC)
3250  INTEGER CONTEXT0(NGRID), P0(NGRID), Q0(NGRID), TFAIL(*)
3251  COMPLEX MEM(MEMLEN)
3252 * ..
3253 *
3254 * Purpose
3255 * =======
3256 * CTESTSDRV: Test complex send/recv
3257 *
3258 * Arguments
3259 * =========
3260 * OUTNUM (input) INTEGER
3261 * The device number to write output to.
3262 *
3263 * VERB (input) INTEGER
3264 * The level of verbosity (how much printing to do).
3265 *
3266 * NSHAPE (input) INTEGER
3267 * The number of matrix shapes to be tested.
3268 *
3269 * UPLO0 (input) CHARACTER*1 array of dimension (NSHAPE)
3270 * Values of UPLO to be tested.
3271 *
3272 * DIAG0 (input) CHARACTER*1 array of dimension (NSHAPE)
3273 * Values of DIAG to be tested.
3274 *
3275 * NMAT (input) INTEGER
3276 * The number of matrices to be tested.
3277 *
3278 * M0 (input) INTEGER array of dimension (NMAT)
3279 * Values of M to be tested.
3280 *
3281 * M0 (input) INTEGER array of dimension (NMAT)
3282 * Values of M to be tested.
3283 *
3284 * N0 (input) INTEGER array of dimension (NMAT)
3285 * Values of N to be tested.
3286 *
3287 * LDAS0 (input) INTEGER array of dimension (NMAT)
3288 * Values of LDAS (leading dimension of A on source process)
3289 * to be tested.
3290 *
3291 * LDAD0 (input) INTEGER array of dimension (NMAT)
3292 * Values of LDAD (leading dimension of A on destination
3293 * process) to be tested.
3294 * NSRC (input) INTEGER
3295 * The number of sources to be tested.
3296 *
3297 * RSRC0 (input) INTEGER array of dimension (NDEST)
3298 * Values of RSRC (row coordinate of source) to be tested.
3299 *
3300 * CSRC0 (input) INTEGER array of dimension (NDEST)
3301 * Values of CSRC (column coordinate of source) to be tested.
3302 *
3303 * RDEST0 (input) INTEGER array of dimension (NNSRC)
3304 * Values of RDEST (row coordinate of destination) to be
3305 * tested.
3306 *
3307 * CDEST0 (input) INTEGER array of dimension (NNSRC)
3308 * Values of CDEST (column coordinate of destination) to be
3309 * tested.
3310 *
3311 * NGRID (input) INTEGER
3312 * The number of process grids to be tested.
3313 *
3314 * CONTEXT0 (input) INTEGER array of dimension (NGRID)
3315 * The BLACS context handles corresponding to the grids.
3316 *
3317 * P0 (input) INTEGER array of dimension (NGRID)
3318 * Values of P (number of process rows, NPROW).
3319 *
3320 * Q0 (input) INTEGER array of dimension (NGRID)
3321 * Values of Q (number of process columns, NPCOL).
3322 *
3323 * TFAIL (workspace) INTEGER array of dimension (NTESTS)
3324 * If VERB < 2, serves to indicate which tests fail. This
3325 * requires workspace of NTESTS (number of tests performed).
3326 *
3327 * MEM (workspace) COMPLEX array of dimension (MEMLEN)
3328 * Used for all other workspaces, including the matrix A,
3329 * and its pre and post padding.
3330 *
3331 * MEMLEN (input) INTEGER
3332 * The length, in elements, of MEM.
3333 *
3334 * =====================================================================
3335 *
3336 * .. External Functions ..
3337  LOGICAL ALLPASS
3338  INTEGER IBTMYPROC, IBTSIZEOF
3339  EXTERNAL ALLPASS, IBTMYPROC, IBTSIZEOF
3340 * ..
3341 * .. External Subroutines ..
3342  EXTERNAL BLACS_GRIDINFO
3343  EXTERNAL CTRSD2D, CGESD2D, CTRRV2D, CGERV2D
3344  EXTERNAL CINITMAT, CCHKMAT, CCHKPAD, CBTCHECKIN
3345 * ..
3346 * .. Local Scalars ..
3347  CHARACTER*1 UPLO, DIAG
3348  LOGICAL TESTOK
3349  INTEGER IAM, I, K, IGR, ISH, IMA, ISO, MYROW, MYCOL, IPRE, IPOST
3350  INTEGER M, N, NPROW, NPCOL, RSRC, CSRC, RDEST, CDEST
3351  INTEGER NERR, NSKIP, NFAIL, TESTNUM, CONTEXT, MAXERR, LDASRC
3352  INTEGER LDADST, ERRDPTR, APTR, ERRIPTR, ISIZE, CSIZE
3353  COMPLEX SCHECKVAL, RCHECKVAL
3354 * ..
3355 * .. Executable Statements ..
3356 *
3357  SCHECKVAL = cmplx( -0.01, -0.01 )
3358  rcheckval = cmplx( -0.02, -0.02 )
3359 *
3360  iam = ibtmyproc()
3361  isize = ibtsizeof('I')
3362  csize = ibtsizeof('C')
3363 *
3364 * Verify file parameters
3365 *
3366  IF( iam .EQ. 0 ) THEN
3367  WRITE(outnum, *) ' '
3368  WRITE(outnum, *) ' '
3369  WRITE(outnum, 1000 )
3370  IF( verb .GT. 0 ) THEN
3371  WRITE(outnum,*) ' '
3372  WRITE(outnum, 2000) 'NSHAPE:', nshape
3373  WRITE(outnum, 3000) ' UPLO :', ( uplo0(i), i = 1, nshape )
3374  WRITE(outnum, 3000) ' DIAG :', ( diag0(i), i = 1, nshape )
3375  WRITE(outnum, 2000) 'NMAT :', nmat
3376  WRITE(outnum, 2000) ' M :', ( m0(i), i = 1, nmat )
3377  WRITE(outnum, 2000) ' N :', ( n0(i), i = 1, nmat )
3378  WRITE(outnum, 2000) ' LDAS :', ( ldas0(i), i = 1, nmat )
3379  WRITE(outnum, 2000) ' LDAD :', ( ldad0(i), i = 1, nmat )
3380  WRITE(outnum, 2000) 'NSRC :', nsrc
3381  WRITE(outnum, 2000) ' RSRC :',( rsrc0(i), i = 1, nsrc )
3382  WRITE(outnum, 2000) ' CSRC :',( csrc0(i), i = 1, nsrc )
3383  WRITE(outnum, 2000) ' RDEST:',( rdest0(i), i = 1, nsrc )
3384  WRITE(outnum, 2000) ' CDEST:',( cdest0(i), i = 1, nsrc )
3385  WRITE(outnum, 2000) 'NGRIDS:', ngrid
3386  WRITE(outnum, 2000) ' P :', ( p0(i), i = 1, ngrid )
3387  WRITE(outnum, 2000) ' Q :', ( q0(i), i = 1, ngrid )
3388  WRITE(outnum, 2000) 'VERB :', verb
3389  WRITE(outnum,*) ' '
3390  END IF
3391  IF( verb .GT. 1 ) THEN
3392  WRITE(outnum,5000)
3393  WRITE(outnum,6000)
3394  END IF
3395  END IF
3396 *
3397 * Find biggest matrix, so we know where to stick error info
3398 *
3399  i = 0
3400  DO 10 ima = 1, nmat
3401  k = n0(ima) * max0( ldas0(ima), ldad0(ima) ) + 4 * m0(ima)
3402  IF( k .GT. i ) i = k
3403  10 CONTINUE
3404  maxerr = ( csize * (memlen-i) ) / ( csize*2 + isize*6 )
3405  IF( maxerr .LT. 1 ) THEN
3406  WRITE(outnum,*) 'ERROR: Not enough memory to run SDRV tests.'
3407  CALL blacs_abort(-1, 1)
3408  END IF
3409  errdptr = i + 1
3410  erriptr = errdptr + maxerr
3411  nerr = 0
3412  testnum = 0
3413  nfail = 0
3414  nskip = 0
3415 *
3416 * Loop over grids of matrix
3417 *
3418  DO 110 igr = 1, ngrid
3419 *
3420  context = context0(igr)
3421  CALL blacs_gridinfo( context, nprow, npcol, myrow, mycol )
3422 *
3423  DO 80 ish = 1, nshape
3424  uplo = uplo0(ish)
3425  diag = diag0(ish)
3426 *
3427  DO 70 ima = 1, nmat
3428  m = m0(ima)
3429  n = n0(ima)
3430  ldasrc = ldas0(ima)
3431  ldadst = ldad0(ima)
3432 *
3433  DO 60 iso = 1, nsrc
3434  testnum = testnum + 1
3435  rsrc = rsrc0(iso)
3436  csrc = csrc0(iso)
3437  IF( rsrc.GE.p0(igr) .OR. csrc.GE.q0(igr) ) THEN
3438  nskip = nskip + 1
3439  GOTO 60
3440  END IF
3441  rdest = rdest0(iso)
3442  cdest = cdest0(iso)
3443  IF( rdest.GE.p0(igr) .OR. cdest.GE.q0(igr) ) THEN
3444  nskip = nskip + 1
3445  GOTO 60
3446  END IF
3447 *
3448  IF( verb .GT. 1 ) THEN
3449  IF( iam .EQ. 0 ) THEN
3450  WRITE(outnum, 7000) testnum, 'RUNNING',
3451  $ uplo, diag, m, n,
3452  $ ldasrc, ldadst, rsrc, csrc,
3453  $ rdest, cdest, nprow, npcol
3454  END IF
3455  END IF
3456 *
3457  testok = .true.
3458  ipre = 2 * m
3459  ipost = ipre
3460  aptr = ipre + 1
3461 *
3462 * source process generates matrix and sends it
3463 *
3464  IF( myrow .EQ. rsrc .AND. mycol .EQ. csrc ) THEN
3465  CALL cinitmat( uplo, diag, m, n, mem, ldasrc,
3466  $ ipre, ipost, scheckval, testnum,
3467  $ myrow, mycol )
3468 *
3469  IF( uplo .EQ. 'U' .OR. uplo .EQ. 'L' ) THEN
3470  CALL ctrsd2d( context, uplo, diag, m, n,
3471  $ mem(aptr), ldasrc, rdest, cdest )
3472  ELSE
3473  CALL cgesd2d( context, m, n, mem(aptr),
3474  $ ldasrc, rdest, cdest )
3475  END IF
3476  END IF
3477 *
3478  IF( myrow .EQ. rdest .AND. mycol .EQ. cdest ) THEN
3479 *
3480 * Pad entire matrix area
3481 *
3482  DO 50 k = 1, ipre+ipost+ldadst*n
3483  mem(k) = rcheckval
3484  50 CONTINUE
3485 *
3486 * Receive matrix
3487 *
3488  IF( uplo .EQ. 'U' .OR. uplo .EQ. 'L' ) THEN
3489  CALL ctrrv2d( context, uplo, diag, m, n,
3490  $ mem(aptr), ldadst, rsrc, csrc )
3491  ELSE
3492  CALL cgerv2d( context, m, n, mem(aptr),
3493  $ ldadst, rsrc, csrc )
3494  END IF
3495 *
3496 * Check for errors in matrix or padding
3497 *
3498  i = nerr
3499  CALL cchkmat( uplo, diag, m, n, mem(aptr), ldadst,
3500  $ rsrc, csrc, myrow, mycol, testnum, maxerr,
3501  $ nerr, mem(erriptr), mem(errdptr) )
3502 *
3503  CALL cchkpad( uplo, diag, m, n, mem, ldadst,
3504  $ rsrc, csrc, myrow, mycol, ipre, ipost,
3505  $ rcheckval, testnum, maxerr, nerr,
3506  $ mem(erriptr), mem(errdptr) )
3507  testok = i .EQ. nerr
3508  END IF
3509 *
3510  IF( verb .GT. 1 ) THEN
3511  i = nerr
3512  CALL cbtcheckin( 0, outnum, maxerr, nerr,
3513  $ mem(erriptr), mem(errdptr),
3514  $ tfail )
3515  IF( iam .EQ. 0 ) THEN
3516  IF( testok .AND. i.EQ.nerr ) THEN
3517  WRITE(outnum, 7000) testnum, 'PASSED ',
3518  $ uplo, diag, m, n, ldasrc, ldadst,
3519  $ rsrc, csrc, rdest, cdest, nprow, npcol
3520  ELSE
3521  nfail = nfail + 1
3522  WRITE(outnum, 7000) testnum, 'FAILED ',
3523  $ uplo, diag, m, n, ldasrc, ldadst,
3524  $ rsrc, csrc, rdest, cdest, nprow, npcol
3525  ENDIF
3526  END IF
3527 *
3528 * Once we've printed out errors, can re-use buf space
3529 *
3530  nerr = 0
3531  END IF
3532  60 CONTINUE
3533  70 CONTINUE
3534  80 CONTINUE
3535  110 CONTINUE
3536 *
3537  IF( verb .LT. 2 ) THEN
3538  nfail = testnum
3539  CALL cbtcheckin( nfail, outnum, maxerr, nerr, mem(erriptr),
3540  $ mem(errdptr), tfail )
3541  END IF
3542  IF( iam .EQ. 0 ) THEN
3543  IF( verb .GT. 1 ) WRITE(outnum,*) ' '
3544  IF( nfail+nskip .EQ. 0 ) THEN
3545  WRITE(outnum, 8000 ) testnum
3546  ELSE
3547  WRITE(outnum, 9000 ) testnum, testnum-nskip-nfail,
3548  $ nskip, nfail
3549  END IF
3550  END IF
3551 *
3552 * Log whether their were any failures
3553 *
3554  testok = allpass( (nfail.EQ.0) )
3555 *
3556  1000 FORMAT('COMPLEX SDRV TESTS: BEGIN.' )
3557  2000 FORMAT(1x,a7,3x,10i6)
3558  3000 FORMAT(1x,a7,3x,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,
3559  $ 5x,a1,5x,a1)
3560  5000 FORMAT(' TEST# STATUS UPLO DIA M N LDAS LDAD RSRC ',
3561  $ 'CSRC RDEST CDEST P Q')
3562  6000 FORMAT(' ----- ------- ---- --- ----- ----- ----- ----- ---- ',
3563  $ '---- ----- ----- ---- ----')
3564  7000 FORMAT(i6,1x,a7,4x,a1,3x,a1,4i6,2i5,2i6,2i5)
3565  8000 FORMAT('COMPLEX SDRV TESTS: PASSED ALL',
3566  $ i5, ' TESTS.')
3567  9000 FORMAT('COMPLEX SDRV TESTS:',i5,' TESTS;',i5,' PASSED,',
3568  $ i5,' SKIPPED,',i5,' FAILED.')
3569 *
3570  RETURN
3571 *
3572 * End of CSDRVTEST.
3573 *
3574  END
3575 *
3576 *
3577  SUBROUTINE zsdrvtest( OUTNUM, VERB, NSHAPE, UPLO0, DIAG0,
3578  $ NMAT, M0, N0, LDAS0, LDAD0, NSRC, RSRC0,
3579  $ CSRC0, RDEST0, CDEST0, NGRID, CONTEXT0,
3580  $ P0, Q0, TFAIL, MEM, MEMLEN )
3581 *
3582 * -- BLACS tester (version 1.0) --
3583 * University of Tennessee
3584 * December 15, 1994
3585 *
3586 *
3587 * .. Scalar Arguments ..
3588  INTEGER OUTNUM, VERB, NSHAPE, NMAT, NSRC, NGRID, MEMLEN
3589 * ..
3590 * .. Array Arguments ..
3591  CHARACTER*1 UPLO0(NSHAPE), DIAG0(NSHAPE)
3592  INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT)
3593  INTEGER RSRC0(NSRC), CSRC0(NSRC), RDEST0(NSRC), CDEST0(NSRC)
3594  INTEGER CONTEXT0(NGRID), P0(NGRID), Q0(NGRID), TFAIL(*)
3595  DOUBLE COMPLEX MEM(MEMLEN)
3596 * ..
3597 *
3598 * Purpose
3599 * =======
3600 * ZTESTSDRV: Test double complex send/recv
3601 *
3602 * Arguments
3603 * =========
3604 * OUTNUM (input) INTEGER
3605 * The device number to write output to.
3606 *
3607 * VERB (input) INTEGER
3608 * The level of verbosity (how much printing to do).
3609 *
3610 * NSHAPE (input) INTEGER
3611 * The number of matrix shapes to be tested.
3612 *
3613 * UPLO0 (input) CHARACTER*1 array of dimension (NSHAPE)
3614 * Values of UPLO to be tested.
3615 *
3616 * DIAG0 (input) CHARACTER*1 array of dimension (NSHAPE)
3617 * Values of DIAG to be tested.
3618 *
3619 * NMAT (input) INTEGER
3620 * The number of matrices to be tested.
3621 *
3622 * M0 (input) INTEGER array of dimension (NMAT)
3623 * Values of M to be tested.
3624 *
3625 * M0 (input) INTEGER array of dimension (NMAT)
3626 * Values of M to be tested.
3627 *
3628 * N0 (input) INTEGER array of dimension (NMAT)
3629 * Values of N to be tested.
3630 *
3631 * LDAS0 (input) INTEGER array of dimension (NMAT)
3632 * Values of LDAS (leading dimension of A on source process)
3633 * to be tested.
3634 *
3635 * LDAD0 (input) INTEGER array of dimension (NMAT)
3636 * Values of LDAD (leading dimension of A on destination
3637 * process) to be tested.
3638 * NSRC (input) INTEGER
3639 * The number of sources to be tested.
3640 *
3641 * RSRC0 (input) INTEGER array of dimension (NDEST)
3642 * Values of RSRC (row coordinate of source) to be tested.
3643 *
3644 * CSRC0 (input) INTEGER array of dimension (NDEST)
3645 * Values of CSRC (column coordinate of source) to be tested.
3646 *
3647 * RDEST0 (input) INTEGER array of dimension (NNSRC)
3648 * Values of RDEST (row coordinate of destination) to be
3649 * tested.
3650 *
3651 * CDEST0 (input) INTEGER array of dimension (NNSRC)
3652 * Values of CDEST (column coordinate of destination) to be
3653 * tested.
3654 *
3655 * NGRID (input) INTEGER
3656 * The number of process grids to be tested.
3657 *
3658 * CONTEXT0 (input) INTEGER array of dimension (NGRID)
3659 * The BLACS context handles corresponding to the grids.
3660 *
3661 * P0 (input) INTEGER array of dimension (NGRID)
3662 * Values of P (number of process rows, NPROW).
3663 *
3664 * Q0 (input) INTEGER array of dimension (NGRID)
3665 * Values of Q (number of process columns, NPCOL).
3666 *
3667 * TFAIL (workspace) INTEGER array of dimension (NTESTS)
3668 * If VERB < 2, serves to indicate which tests fail. This
3669 * requires workspace of NTESTS (number of tests performed).
3670 *
3671 * MEM (workspace) DOUBLE COMPLEX array of dimension (MEMLEN)
3672 * Used for all other workspaces, including the matrix A,
3673 * and its pre and post padding.
3674 *
3675 * MEMLEN (input) INTEGER
3676 * The length, in elements, of MEM.
3677 *
3678 * =====================================================================
3679 *
3680 * .. External Functions ..
3681  LOGICAL ALLPASS
3682  INTEGER IBTMYPROC, IBTSIZEOF
3683  EXTERNAL ALLPASS, IBTMYPROC, IBTSIZEOF
3684 * ..
3685 * .. External Subroutines ..
3686  EXTERNAL BLACS_GRIDINFO
3687  EXTERNAL ZTRSD2D, ZGESD2D, ZTRRV2D, ZGERV2D
3688  EXTERNAL ZINITMAT, ZCHKMAT, ZCHKPAD, ZBTCHECKIN
3689 * ..
3690 * .. Local Scalars ..
3691  CHARACTER*1 UPLO, DIAG
3692  LOGICAL TESTOK
3693  INTEGER IAM, I, K, IGR, ISH, IMA, ISO, MYROW, MYCOL, IPRE, IPOST
3694  INTEGER M, N, NPROW, NPCOL, RSRC, CSRC, RDEST, CDEST
3695  INTEGER NERR, NSKIP, NFAIL, TESTNUM, CONTEXT, MAXERR, LDASRC
3696  INTEGER LDADST, ERRDPTR, APTR, ERRIPTR, ISIZE, ZSIZE
3697  DOUBLE COMPLEX SCHECKVAL, RCHECKVAL
3698 * ..
3699 * .. Executable Statements ..
3700 *
3701  SCHECKVAL = dcmplx( -0.01d0, -0.01d0 )
3702  rcheckval = dcmplx( -0.02d0, -0.02d0 )
3703 *
3704  iam = ibtmyproc()
3705  isize = ibtsizeof('I')
3706  zsize = ibtsizeof('Z')
3707 *
3708 * Verify file parameters
3709 *
3710  IF( iam .EQ. 0 ) THEN
3711  WRITE(outnum, *) ' '
3712  WRITE(outnum, *) ' '
3713  WRITE(outnum, 1000 )
3714  IF( verb .GT. 0 ) THEN
3715  WRITE(outnum,*) ' '
3716  WRITE(outnum, 2000) 'NSHAPE:', nshape
3717  WRITE(outnum, 3000) ' UPLO :', ( uplo0(i), i = 1, nshape )
3718  WRITE(outnum, 3000) ' DIAG :', ( diag0(i), i = 1, nshape )
3719  WRITE(outnum, 2000) 'NMAT :', nmat
3720  WRITE(outnum, 2000) ' M :', ( m0(i), i = 1, nmat )
3721  WRITE(outnum, 2000) ' N :', ( n0(i), i = 1, nmat )
3722  WRITE(outnum, 2000) ' LDAS :', ( ldas0(i), i = 1, nmat )
3723  WRITE(outnum, 2000) ' LDAD :', ( ldad0(i), i = 1, nmat )
3724  WRITE(outnum, 2000) 'NSRC :', nsrc
3725  WRITE(outnum, 2000) ' RSRC :',( rsrc0(i), i = 1, nsrc )
3726  WRITE(outnum, 2000) ' CSRC :',( csrc0(i), i = 1, nsrc )
3727  WRITE(outnum, 2000) ' RDEST:',( rdest0(i), i = 1, nsrc )
3728  WRITE(outnum, 2000) ' CDEST:',( cdest0(i), i = 1, nsrc )
3729  WRITE(outnum, 2000) 'NGRIDS:', ngrid
3730  WRITE(outnum, 2000) ' P :', ( p0(i), i = 1, ngrid )
3731  WRITE(outnum, 2000) ' Q :', ( q0(i), i = 1, ngrid )
3732  WRITE(outnum, 2000) 'VERB :', verb
3733  WRITE(outnum,*) ' '
3734  END IF
3735  IF( verb .GT. 1 ) THEN
3736  WRITE(outnum,5000)
3737  WRITE(outnum,6000)
3738  END IF
3739  END IF
3740 *
3741 * Find biggest matrix, so we know where to stick error info
3742 *
3743  i = 0
3744  DO 10 ima = 1, nmat
3745  k = n0(ima) * max0( ldas0(ima), ldad0(ima) ) + 4 * m0(ima)
3746  IF( k .GT. i ) i = k
3747  10 CONTINUE
3748  maxerr = ( zsize * (memlen-i) ) / ( zsize*2 + isize*6 )
3749  IF( maxerr .LT. 1 ) THEN
3750  WRITE(outnum,*) 'ERROR: Not enough memory to run SDRV tests.'
3751  CALL blacs_abort(-1, 1)
3752  END IF
3753  errdptr = i + 1
3754  erriptr = errdptr + maxerr
3755  nerr = 0
3756  testnum = 0
3757  nfail = 0
3758  nskip = 0
3759 *
3760 * Loop over grids of matrix
3761 *
3762  DO 110 igr = 1, ngrid
3763 *
3764  context = context0(igr)
3765  CALL blacs_gridinfo( context, nprow, npcol, myrow, mycol )
3766 *
3767  DO 80 ish = 1, nshape
3768  uplo = uplo0(ish)
3769  diag = diag0(ish)
3770 *
3771  DO 70 ima = 1, nmat
3772  m = m0(ima)
3773  n = n0(ima)
3774  ldasrc = ldas0(ima)
3775  ldadst = ldad0(ima)
3776 *
3777  DO 60 iso = 1, nsrc
3778  testnum = testnum + 1
3779  rsrc = rsrc0(iso)
3780  csrc = csrc0(iso)
3781  IF( rsrc.GE.p0(igr) .OR. csrc.GE.q0(igr) ) THEN
3782  nskip = nskip + 1
3783  GOTO 60
3784  END IF
3785  rdest = rdest0(iso)
3786  cdest = cdest0(iso)
3787  IF( rdest.GE.p0(igr) .OR. cdest.GE.q0(igr) ) THEN
3788  nskip = nskip + 1
3789  GOTO 60
3790  END IF
3791 *
3792  IF( verb .GT. 1 ) THEN
3793  IF( iam .EQ. 0 ) THEN
3794  WRITE(outnum, 7000) testnum, 'RUNNING',
3795  $ uplo, diag, m, n,
3796  $ ldasrc, ldadst, rsrc, csrc,
3797  $ rdest, cdest, nprow, npcol
3798  END IF
3799  END IF
3800 *
3801  testok = .true.
3802  ipre = 2 * m
3803  ipost = ipre
3804  aptr = ipre + 1
3805 *
3806 * source process generates matrix and sends it
3807 *
3808  IF( myrow .EQ. rsrc .AND. mycol .EQ. csrc ) THEN
3809  CALL zinitmat( uplo, diag, m, n, mem, ldasrc,
3810  $ ipre, ipost, scheckval, testnum,
3811  $ myrow, mycol )
3812 *
3813  IF( uplo .EQ. 'U' .OR. uplo .EQ. 'L' ) THEN
3814  CALL ztrsd2d( context, uplo, diag, m, n,
3815  $ mem(aptr), ldasrc, rdest, cdest )
3816  ELSE
3817  CALL zgesd2d( context, m, n, mem(aptr),
3818  $ ldasrc, rdest, cdest )
3819  END IF
3820  END IF
3821 *
3822  IF( myrow .EQ. rdest .AND. mycol .EQ. cdest ) THEN
3823 *
3824 * Pad entire matrix area
3825 *
3826  DO 50 k = 1, ipre+ipost+ldadst*n
3827  mem(k) = rcheckval
3828  50 CONTINUE
3829 *
3830 * Receive matrix
3831 *
3832  IF( uplo .EQ. 'U' .OR. uplo .EQ. 'L' ) THEN
3833  CALL ztrrv2d( context, uplo, diag, m, n,
3834  $ mem(aptr), ldadst, rsrc, csrc )
3835  ELSE
3836  CALL zgerv2d( context, m, n, mem(aptr),
3837  $ ldadst, rsrc, csrc )
3838  END IF
3839 *
3840 * Check for errors in matrix or padding
3841 *
3842  i = nerr
3843  CALL zchkmat( uplo, diag, m, n, mem(aptr), ldadst,
3844  $ rsrc, csrc, myrow, mycol, testnum, maxerr,
3845  $ nerr, mem(erriptr), mem(errdptr) )
3846 *
3847  CALL zchkpad( uplo, diag, m, n, mem, ldadst,
3848  $ rsrc, csrc, myrow, mycol, ipre, ipost,
3849  $ rcheckval, testnum, maxerr, nerr,
3850  $ mem(erriptr), mem(errdptr) )
3851  testok = i .EQ. nerr
3852  END IF
3853 *
3854  IF( verb .GT. 1 ) THEN
3855  i = nerr
3856  CALL zbtcheckin( 0, outnum, maxerr, nerr,
3857  $ mem(erriptr), mem(errdptr),
3858  $ tfail )
3859  IF( iam .EQ. 0 ) THEN
3860  IF( testok .AND. i.EQ.nerr ) THEN
3861  WRITE(outnum, 7000) testnum, 'PASSED ',
3862  $ uplo, diag, m, n, ldasrc, ldadst,
3863  $ rsrc, csrc, rdest, cdest, nprow, npcol
3864  ELSE
3865  nfail = nfail + 1
3866  WRITE(outnum, 7000) testnum, 'FAILED ',
3867  $ uplo, diag, m, n, ldasrc, ldadst,
3868  $ rsrc, csrc, rdest, cdest, nprow, npcol
3869  ENDIF
3870  END IF
3871 *
3872 * Once we've printed out errors, can re-use buf space
3873 *
3874  nerr = 0
3875  END IF
3876  60 CONTINUE
3877  70 CONTINUE
3878  80 CONTINUE
3879  110 CONTINUE
3880 *
3881  IF( verb .LT. 2 ) THEN
3882  nfail = testnum
3883  CALL zbtcheckin( nfail, outnum, maxerr, nerr, mem(erriptr),
3884  $ mem(errdptr), tfail )
3885  END IF
3886  IF( iam .EQ. 0 ) THEN
3887  IF( verb .GT. 1 ) WRITE(outnum,*) ' '
3888  IF( nfail+nskip .EQ. 0 ) THEN
3889  WRITE(outnum, 8000 ) testnum
3890  ELSE
3891  WRITE(outnum, 9000 ) testnum, testnum-nskip-nfail,
3892  $ nskip, nfail
3893  END IF
3894  END IF
3895 *
3896 * Log whether their were any failures
3897 *
3898  testok = allpass( (nfail.EQ.0) )
3899 *
3900  1000 FORMAT('DOUBLE COMPLEX SDRV TESTS: BEGIN.' )
3901  2000 FORMAT(1x,a7,3x,10i6)
3902  3000 FORMAT(1x,a7,3x,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,
3903  $ 5x,a1,5x,a1)
3904  5000 FORMAT(' TEST# STATUS UPLO DIA M N LDAS LDAD RSRC ',
3905  $ 'CSRC RDEST CDEST P Q')
3906  6000 FORMAT(' ----- ------- ---- --- ----- ----- ----- ----- ---- ',
3907  $ '---- ----- ----- ---- ----')
3908  7000 FORMAT(i6,1x,a7,4x,a1,3x,a1,4i6,2i5,2i6,2i5)
3909  8000 FORMAT('DOUBLE COMPLEX SDRV TESTS: PASSED ALL',
3910  $ i5, ' TESTS.')
3911  9000 FORMAT('DOUBLE COMPLEX SDRV TESTS:',i5,' TESTS;',i5,' PASSED,',
3912  $ i5,' SKIPPED,',i5,' FAILED.')
3913 *
3914  RETURN
3915 *
3916 * End of ZSDRVTEST.
3917 *
3918  END
3919 *
3920 *
3921  SUBROUTINE ibsbrtest( OUTNUM, VERB, NSCOPE, SCOPE0, NTOP, TOP0,
3922  $ NSHAPE, UPLO0, DIAG0, NMAT, M0, N0, LDAS0,
3923  $ LDAD0, NSRC, RSRC0, CSRC0, NGRID, CONTEXT0,
3924  $ P0, Q0, TFAIL, MEM, MEMLEN )
3925 *
3926 * -- BLACS tester (version 1.0) --
3927 * University of Tennessee
3928 * December 15, 1994
3929 *
3930 *
3931 * .. Scalar Arguments ..
3932  INTEGER OUTNUM, VERB, NSCOPE, NTOP, NSHAPE, NMAT, NSRC, NGRID
3933  INTEGER MEMLEN
3934 * ..
3935 * .. Array Arguments ..
3936  CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP)
3937  CHARACTER*1 UPLO0(NSHAPE), DIAG0(NSHAPE)
3938  INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT)
3939  INTEGER RSRC0(NSRC), CSRC0(NSRC), CONTEXT0(NGRID)
3940  INTEGER P0(NGRID), Q0(NGRID), TFAIL(*)
3941  INTEGER MEM(MEMLEN)
3942 * ..
3943 *
3944 * Purpose
3945 * =======
3946 * ITESTBSBR: Test integer broadcast
3947 *
3948 * Arguments
3949 * =========
3950 * OUTNUM (input) INTEGER
3951 * The device number to write output to.
3952 *
3953 * VERB (input) INTEGER
3954 * The level of verbosity (how much printing to do).
3955 *
3956 * NSCOPE (input) INTEGER
3957 * The number of scopes to be tested.
3958 *
3959 * SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE)
3960 * Values of the scopes to be tested.
3961 *
3962 * NTOP (input) INTEGER
3963 * The number of topologies to be tested.
3964 *
3965 * TOP0 (input) CHARACTER*1 array of dimension (NTOP)
3966 * Values of the topologies to be tested.
3967 *
3968 * NSHAPE (input) INTEGER
3969 * The number of matrix shapes to be tested.
3970 *
3971 * UPLO0 (input) CHARACTER*1 array of dimension (NSHAPE)
3972 * Values of UPLO to be tested.
3973 *
3974 * DIAG0 (input) CHARACTER*1 array of dimension (NSHAPE)
3975 * Values of DIAG to be tested.
3976 *
3977 * NMAT (input) INTEGER
3978 * The number of matrices to be tested.
3979 *
3980 * M0 (input) INTEGER array of dimension (NMAT)
3981 * Values of M to be tested.
3982 *
3983 * M0 (input) INTEGER array of dimension (NMAT)
3984 * Values of M to be tested.
3985 *
3986 * N0 (input) INTEGER array of dimension (NMAT)
3987 * Values of N to be tested.
3988 *
3989 * LDAS0 (input) INTEGER array of dimension (NMAT)
3990 * Values of LDAS (leading dimension of A on source process)
3991 * to be tested.
3992 *
3993 * LDAD0 (input) INTEGER array of dimension (NMAT)
3994 * Values of LDAD (leading dimension of A on destination
3995 * process) to be tested.
3996 * NSRC (input) INTEGER
3997 * The number of sources to be tested.
3998 *
3999 * RSRC0 (input) INTEGER array of dimension (NDEST)
4000 * Values of RSRC (row coordinate of source) to be tested.
4001 *
4002 * CSRC0 (input) INTEGER array of dimension (NDEST)
4003 * Values of CSRC (column coordinate of source) to be tested.
4004 *
4005 * NGRID (input) INTEGER
4006 * The number of process grids to be tested.
4007 *
4008 * CONTEXT0 (input) INTEGER array of dimension (NGRID)
4009 * The BLACS context handles corresponding to the grids.
4010 *
4011 * P0 (input) INTEGER array of dimension (NGRID)
4012 * Values of P (number of process rows, NPROW).
4013 *
4014 * Q0 (input) INTEGER array of dimension (NGRID)
4015 * Values of Q (number of process columns, NPCOL).
4016 *
4017 * TFAIL (workspace) INTEGER array of dimension (NTESTS)
4018 * If VERB < 2, serves to indicate which tests fail. This
4019 * requires workspace of NTESTS (number of tests performed).
4020 *
4021 * MEM (workspace) INTEGER array of dimension (MEMLEN)
4022 * Used for all other workspaces, including the matrix A,
4023 * and its pre and post padding.
4024 *
4025 * MEMLEN (input) INTEGER
4026 * The length, in elements, of MEM.
4027 *
4028 * =====================================================================
4029 *
4030 * .. External Functions ..
4031  LOGICAL ALLPASS, LSAME
4032  INTEGER IBTMYPROC, IBTSIZEOF
4033  EXTERNAL ALLPASS, LSAME, IBTMYPROC, IBTSIZEOF
4034 * ..
4035 * .. External Subroutines ..
4036  EXTERNAL BLACS_GRIDINFO
4037  EXTERNAL ITRBS2D, IGEBS2D, ITRBR2D, IGEBR2D
4038  EXTERNAL IINITMAT, ICHKMAT, ICHKPAD, IBTCHECKIN
4039 * ..
4040 * .. Local Scalars ..
4041  CHARACTER*1 SCOPE, TOP, UPLO, DIAG
4042  LOGICAL TESTOK, INGRID
4043  INTEGER IAM, I, K, J, IGR, ISH, IMA, ISO, ISC, ITO
4044  INTEGER M, N, NPROW, NPCOL, MYROW, MYCOL, RSRC, CSRC
4045  INTEGER ISTART, ISTOP, IPRE, IPOST, SETWHAT
4046  INTEGER NERR, NSKIP, NFAIL, TESTNUM, CONTEXT, MAXERR, LDASRC
4047  INTEGER LDADST, ERRDPTR, APTR, ERRIPTR, ISIZE
4048  INTEGER SCHECKVAL, RCHECKVAL
4049 * ..
4050 * .. Executable Statements ..
4051 *
4052  SCHECKVAL = -1
4053  rcheckval = -2
4054 *
4055  iam = ibtmyproc()
4056  isize = ibtsizeof('I')
4057  isize = ibtsizeof('I')
4058 *
4059 * Verify file parameters
4060 *
4061  IF( iam .EQ. 0 ) THEN
4062  WRITE(outnum, *) ' '
4063  WRITE(outnum, *) ' '
4064  WRITE(outnum, 1000 )
4065  IF( verb .GT. 0 ) THEN
4066  WRITE(outnum,*) ' '
4067  WRITE(outnum, 2000) 'NSCOPE:', nscope
4068  WRITE(outnum, 3000) ' SCOPE:', ( scope0(i), i = 1, nscope )
4069  WRITE(outnum, 2000) 'NTOP :', ntop
4070  WRITE(outnum, 3000) ' TOP :', ( top0(i), i = 1, ntop )
4071  WRITE(outnum, 2000) 'NSHAPE:', nshape
4072  WRITE(outnum, 3000) ' UPLO :', ( uplo0(i), i = 1, nshape )
4073  WRITE(outnum, 3000) ' DIAG :', ( diag0(i), i = 1, nshape )
4074  WRITE(outnum, 2000) 'NMAT :', nmat
4075  WRITE(outnum, 2000) ' M :', ( m0(i), i = 1, nmat )
4076  WRITE(outnum, 2000) ' N :', ( n0(i), i = 1, nmat )
4077  WRITE(outnum, 2000) ' LDAS :', ( ldas0(i), i = 1, nmat )
4078  WRITE(outnum, 2000) ' LDAD :', ( ldad0(i), i = 1, nmat )
4079  WRITE(outnum, 2000) 'NSRC :', nsrc
4080  WRITE(outnum, 2000) ' RSRC :',( rsrc0(i), i = 1, nsrc )
4081  WRITE(outnum, 2000) ' CSRC :',( csrc0(i), i = 1, nsrc )
4082  WRITE(outnum, 2000) 'NGRIDS:', ngrid
4083  WRITE(outnum, 2000) ' P :', ( p0(i), i = 1, ngrid )
4084  WRITE(outnum, 2000) ' Q :', ( q0(i), i = 1, ngrid )
4085  WRITE(outnum, 2000) 'VERB :', verb
4086  WRITE(outnum,*) ' '
4087  END IF
4088  IF( verb .GT. 1 ) THEN
4089  WRITE(outnum,5000)
4090  WRITE(outnum,6000)
4091  END IF
4092  END IF
4093 *
4094 * Find biggest matrix, so we know where to stick error info
4095 *
4096  i = 0
4097  DO 10 ima = 1, nmat
4098  k = n0(ima) * max0( ldas0(ima), ldad0(ima) ) + 4 * m0(ima)
4099  IF( k .GT. i ) i = k
4100  10 CONTINUE
4101  maxerr = ( isize * (memlen-i) ) / ( isize*2 + isize*6 )
4102  IF( maxerr .LT. 1 ) THEN
4103  WRITE(outnum,*) 'ERROR: Not enough memory to run BSBR tests.'
4104  CALL blacs_abort(-1, 1)
4105  END IF
4106  errdptr = i + 1
4107  erriptr = errdptr + maxerr
4108  nerr = 0
4109  testnum = 0
4110  nfail = 0
4111  nskip = 0
4112 *
4113 * Loop over grids of matrix
4114 *
4115  DO 110 igr = 1, ngrid
4116 *
4117  context = context0(igr)
4118  CALL blacs_gridinfo( context, nprow, npcol, myrow, mycol )
4119 *
4120  ingrid = ( nprow .GT. 0 )
4121 *
4122  DO 100 isc = 1, nscope
4123  scope = scope0(isc)
4124  DO 90 ito = 1, ntop
4125  top = top0(ito)
4126 *
4127 * If testing multipath ('M') or general tree ('T'),
4128 * need to loop over calls to BLACS_SET
4129 *
4130  IF( lsame(top, 'M') ) THEN
4131  setwhat = 11
4132  IF( scope .EQ. 'R' ) THEN
4133  istart = -(npcol - 1)
4134  istop = -istart
4135  ELSE IF (scope .EQ. 'C') THEN
4136  istart = -(nprow - 1)
4137  istop = -istart
4138  ELSE
4139  istart = -(nprow*npcol - 1)
4140  istop = -istart
4141  ENDIF
4142  ELSE IF( lsame(top, 'T') ) THEN
4143  setwhat = 12
4144  istart = 1
4145  IF( scope .EQ. 'R' ) THEN
4146  istop = npcol - 1
4147  ELSE IF (scope .EQ. 'C') THEN
4148  istop = nprow - 1
4149  ELSE
4150  istop = nprow*npcol - 1
4151  ENDIF
4152  ELSE
4153  setwhat = 0
4154  istart = 1
4155  istop = 1
4156  ENDIF
4157  DO 80 ish = 1, nshape
4158  uplo = uplo0(ish)
4159  diag = diag0(ish)
4160 *
4161  DO 70 ima = 1, nmat
4162  m = m0(ima)
4163  n = n0(ima)
4164  ldasrc = ldas0(ima)
4165  ldadst = ldad0(ima)
4166 *
4167  DO 60 iso = 1, nsrc
4168  testnum = testnum + 1
4169  rsrc = rsrc0(iso)
4170  csrc = csrc0(iso)
4171  IF( rsrc.GE.p0(igr) .OR. csrc.GE.q0(igr) ) THEN
4172  nskip = nskip + 1
4173  GOTO 60
4174  END IF
4175  IF( verb .GT. 1 ) THEN
4176  IF( iam .EQ. 0 ) THEN
4177  WRITE(outnum, 7000)
4178  $ testnum, 'RUNNING',scope, top, uplo, diag,
4179  $ m, n, ldasrc, ldadst, rsrc, csrc,
4180  $ nprow, npcol
4181  END IF
4182  END IF
4183 *
4184  testok = .true.
4185  ipre = 2 * m
4186  ipost = ipre
4187  aptr = ipre + 1
4188 *
4189 * If I am in scope
4190 *
4191  IF( (myrow.EQ.rsrc .AND. scope.EQ.'R') .OR.
4192  $ (mycol.EQ.csrc .AND. scope.EQ.'C') .OR.
4193  $ (scope .EQ. 'A') ) THEN
4194 *
4195 * source process generates matrix and sends it
4196 *
4197  IF( myrow.EQ.rsrc .AND. mycol.EQ.csrc ) THEN
4198  CALL iinitmat(uplo, diag, m, n, mem,
4199  $ ldasrc, ipre, ipost,
4200  $ scheckval, testnum,
4201  $ myrow, mycol )
4202 *
4203  DO 20 j = istart, istop
4204  IF( j.EQ.0 ) GOTO 20
4205  IF( setwhat.NE.0 )
4206  $ CALL blacs_set(context, setwhat, j)
4207  IF( uplo.EQ.'U' .OR. uplo.EQ.'L' ) THEN
4208  CALL itrbs2d(context, scope, top,
4209  $ uplo, diag, m, n,
4210  $ mem(aptr), ldasrc )
4211  ELSE
4212  CALL igebs2d(context, scope, top,
4213  $ m, n, mem(aptr),
4214  $ ldasrc )
4215  END IF
4216  20 CONTINUE
4217 *
4218 * Destination processes
4219 *
4220  ELSE IF( ingrid ) THEN
4221  DO 40 j = istart, istop
4222  IF( j.EQ.0 ) GOTO 40
4223  IF( setwhat.NE.0 )
4224  $ CALL blacs_set(context, setwhat, j)
4225 *
4226 * Pad entire matrix area
4227 *
4228  DO 30 k = 1, ipre+ipost+ldadst*n
4229  mem(k) = rcheckval
4230  30 CONTINUE
4231 *
4232 * Receive matrix
4233 *
4234  IF( uplo.EQ.'U' .OR. uplo.EQ.'L' ) THEN
4235  CALL itrbr2d(context, scope, top,
4236  $ uplo, diag, m, n,
4237  $ mem(aptr), ldadst,
4238  $ rsrc, csrc)
4239  ELSE
4240  CALL igebr2d(context, scope, top,
4241  $ m, n, mem(aptr),
4242  $ ldadst, rsrc, csrc)
4243  END IF
4244 *
4245 * Check for errors in matrix or padding
4246 *
4247  i = nerr
4248  CALL ichkmat(uplo, diag, m, n,
4249  $ mem(aptr), ldadst, rsrc, csrc,
4250  $ myrow, mycol, testnum, maxerr,
4251  $ nerr, mem(erriptr),
4252  $ mem(errdptr))
4253 *
4254  CALL ichkpad(uplo, diag, m, n, mem,
4255  $ ldadst, rsrc, csrc, myrow,
4256  $ mycol, ipre, ipost, rcheckval,
4257  $ testnum, maxerr, nerr,
4258  $ mem(erriptr), mem(errdptr))
4259  40 CONTINUE
4260  testok = ( i .EQ. nerr )
4261  END IF
4262  END IF
4263 *
4264  IF( verb .GT. 1 ) THEN
4265  i = nerr
4266  CALL ibtcheckin(0, outnum, maxerr, nerr,
4267  $ mem(erriptr), mem(errdptr),
4268  $ tfail)
4269  IF( iam .EQ. 0 ) THEN
4270  testok = ( testok .AND. (i.EQ.nerr) )
4271  IF( testok ) THEN
4272  WRITE(outnum,7000)testnum,'PASSED ',
4273  $ scope, top, uplo, diag, m, n,
4274  $ ldasrc, ldadst, rsrc, csrc,
4275  $ nprow, npcol
4276  ELSE
4277  nfail = nfail + 1
4278  WRITE(outnum,7000)testnum,'FAILED ',
4279  $ scope, top, uplo, diag, m, n,
4280  $ ldasrc, ldadst, rsrc, csrc,
4281  $ nprow, npcol
4282  END IF
4283  END IF
4284 *
4285 * Once we've printed out errors, can re-use buf space
4286 *
4287  nerr = 0
4288  END IF
4289  60 CONTINUE
4290  70 CONTINUE
4291  80 CONTINUE
4292  90 CONTINUE
4293  100 CONTINUE
4294  110 CONTINUE
4295 *
4296  IF( verb .LT. 2 ) THEN
4297  nfail = testnum
4298  CALL ibtcheckin( nfail, outnum, maxerr, nerr, mem(erriptr),
4299  $ mem(errdptr), tfail )
4300  END IF
4301  IF( iam .EQ. 0 ) THEN
4302  IF( verb .GT. 1 ) WRITE(outnum,*) ' '
4303  IF( nfail+nskip .EQ. 0 ) THEN
4304  WRITE(outnum, 8000 ) testnum
4305  ELSE
4306  WRITE(outnum, 9000 ) testnum, testnum-nskip-nfail,
4307  $ nskip, nfail
4308  END IF
4309  END IF
4310 *
4311 * Log whether their were any failures
4312 *
4313  testok = allpass( (nfail.EQ.0) )
4314 *
4315  1000 FORMAT('INTEGER BSBR TESTS: BEGIN.' )
4316  2000 FORMAT(1x,a7,3x,10i6)
4317  3000 FORMAT(1x,a7,3x,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,
4318  $ 5x,a1,5x,a1)
4319  5000 FORMAT(' TEST# STATUS SCOPE TOP UPLO DIAG M N LDAS ',
4320  $ ' LDAD RSRC CSRC P Q')
4321  6000 FORMAT(' ----- ------- ----- --- ---- ---- ----- ----- ----- ',
4322  $ '----- ---- ---- ---- ----')
4323  7000 FORMAT(i6,1x,a7,5x,a1,3x,a1,2(4x,a1), 4i6, 4i5)
4324  8000 FORMAT('INTEGER BSBR TESTS: PASSED ALL',
4325  $ i5, ' TESTS.')
4326  9000 FORMAT('INTEGER BSBR TESTS:',i5,' TESTS;',i5,' PASSED,',
4327  $ i5,' SKIPPED,',i5,' FAILED.')
4328 *
4329  RETURN
4330 *
4331 * End of IBSBRTEST.
4332 *
4333  END
4334 *
4335 *
4336  SUBROUTINE sbsbrtest( OUTNUM, VERB, NSCOPE, SCOPE0, NTOP, TOP0,
4337  $ NSHAPE, UPLO0, DIAG0, NMAT, M0, N0, LDAS0,
4338  $ LDAD0, NSRC, RSRC0, CSRC0, NGRID, CONTEXT0,
4339  $ P0, Q0, TFAIL, MEM, MEMLEN )
4340 *
4341 * -- BLACS tester (version 1.0) --
4342 * University of Tennessee
4343 * December 15, 1994
4344 *
4345 *
4346 * .. Scalar Arguments ..
4347  INTEGER OUTNUM, VERB, NSCOPE, NTOP, NSHAPE, NMAT, NSRC, NGRID
4348  INTEGER MEMLEN
4349 * ..
4350 * .. Array Arguments ..
4351  CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP)
4352  CHARACTER*1 UPLO0(NSHAPE), DIAG0(NSHAPE)
4353  INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT)
4354  INTEGER RSRC0(NSRC), CSRC0(NSRC), CONTEXT0(NGRID)
4355  INTEGER P0(NGRID), Q0(NGRID), TFAIL(*)
4356  REAL MEM(MEMLEN)
4357 * ..
4358 *
4359 * Purpose
4360 * =======
4361 * STESTBSBR: Test real broadcast
4362 *
4363 * Arguments
4364 * =========
4365 * OUTNUM (input) INTEGER
4366 * The device number to write output to.
4367 *
4368 * VERB (input) INTEGER
4369 * The level of verbosity (how much printing to do).
4370 *
4371 * NSCOPE (input) INTEGER
4372 * The number of scopes to be tested.
4373 *
4374 * SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE)
4375 * Values of the scopes to be tested.
4376 *
4377 * NTOP (input) INTEGER
4378 * The number of topologies to be tested.
4379 *
4380 * TOP0 (input) CHARACTER*1 array of dimension (NTOP)
4381 * Values of the topologies to be tested.
4382 *
4383 * NSHAPE (input) INTEGER
4384 * The number of matrix shapes to be tested.
4385 *
4386 * UPLO0 (input) CHARACTER*1 array of dimension (NSHAPE)
4387 * Values of UPLO to be tested.
4388 *
4389 * DIAG0 (input) CHARACTER*1 array of dimension (NSHAPE)
4390 * Values of DIAG to be tested.
4391 *
4392 * NMAT (input) INTEGER
4393 * The number of matrices to be tested.
4394 *
4395 * M0 (input) INTEGER array of dimension (NMAT)
4396 * Values of M to be tested.
4397 *
4398 * M0 (input) INTEGER array of dimension (NMAT)
4399 * Values of M to be tested.
4400 *
4401 * N0 (input) INTEGER array of dimension (NMAT)
4402 * Values of N to be tested.
4403 *
4404 * LDAS0 (input) INTEGER array of dimension (NMAT)
4405 * Values of LDAS (leading dimension of A on source process)
4406 * to be tested.
4407 *
4408 * LDAD0 (input) INTEGER array of dimension (NMAT)
4409 * Values of LDAD (leading dimension of A on destination
4410 * process) to be tested.
4411 * NSRC (input) INTEGER
4412 * The number of sources to be tested.
4413 *
4414 * RSRC0 (input) INTEGER array of dimension (NDEST)
4415 * Values of RSRC (row coordinate of source) to be tested.
4416 *
4417 * CSRC0 (input) INTEGER array of dimension (NDEST)
4418 * Values of CSRC (column coordinate of source) to be tested.
4419 *
4420 * NGRID (input) INTEGER
4421 * The number of process grids to be tested.
4422 *
4423 * CONTEXT0 (input) INTEGER array of dimension (NGRID)
4424 * The BLACS context handles corresponding to the grids.
4425 *
4426 * P0 (input) INTEGER array of dimension (NGRID)
4427 * Values of P (number of process rows, NPROW).
4428 *
4429 * Q0 (input) INTEGER array of dimension (NGRID)
4430 * Values of Q (number of process columns, NPCOL).
4431 *
4432 * TFAIL (workspace) INTEGER array of dimension (NTESTS)
4433 * If VERB < 2, serves to indicate which tests fail. This
4434 * requires workspace of NTESTS (number of tests performed).
4435 *
4436 * MEM (workspace) REAL array of dimension (MEMLEN)
4437 * Used for all other workspaces, including the matrix A,
4438 * and its pre and post padding.
4439 *
4440 * MEMLEN (input) INTEGER
4441 * The length, in elements, of MEM.
4442 *
4443 * =====================================================================
4444 *
4445 * .. External Functions ..
4446  LOGICAL ALLPASS, LSAME
4447  INTEGER IBTMYPROC, IBTSIZEOF
4448  EXTERNAL ALLPASS, LSAME, IBTMYPROC, IBTSIZEOF
4449 * ..
4450 * .. External Subroutines ..
4451  EXTERNAL BLACS_GRIDINFO
4452  EXTERNAL STRBS2D, SGEBS2D, STRBR2D, SGEBR2D
4453  EXTERNAL SINITMAT, SCHKMAT, SCHKPAD, SBTCHECKIN
4454 * ..
4455 * .. Local Scalars ..
4456  CHARACTER*1 SCOPE, TOP, UPLO, DIAG
4457  LOGICAL TESTOK, INGRID
4458  INTEGER IAM, I, K, J, IGR, ISH, IMA, ISO, ISC, ITO
4459  INTEGER M, N, NPROW, NPCOL, MYROW, MYCOL, RSRC, CSRC
4460  INTEGER ISTART, ISTOP, IPRE, IPOST, SETWHAT
4461  INTEGER NERR, NSKIP, NFAIL, TESTNUM, CONTEXT, MAXERR, LDASRC
4462  INTEGER LDADST, ERRDPTR, APTR, ERRIPTR, ISIZE, SSIZE
4463  REAL SCHECKVAL, RCHECKVAL
4464 * ..
4465 * .. Executable Statements ..
4466 *
4467  SCHECKVAL = -0.01e0
4468  rcheckval = -0.02e0
4469 *
4470  iam = ibtmyproc()
4471  isize = ibtsizeof('I')
4472  ssize = ibtsizeof('S')
4473 *
4474 * Verify file parameters
4475 *
4476  IF( iam .EQ. 0 ) THEN
4477  WRITE(outnum, *) ' '
4478  WRITE(outnum, *) ' '
4479  WRITE(outnum, 1000 )
4480  IF( verb .GT. 0 ) THEN
4481  WRITE(outnum,*) ' '
4482  WRITE(outnum, 2000) 'NSCOPE:', nscope
4483  WRITE(outnum, 3000) ' SCOPE:', ( scope0(i), i = 1, nscope )
4484  WRITE(outnum, 2000) 'NTOP :', ntop
4485  WRITE(outnum, 3000) ' TOP :', ( top0(i), i = 1, ntop )
4486  WRITE(outnum, 2000) 'NSHAPE:', nshape
4487  WRITE(outnum, 3000) ' UPLO :', ( uplo0(i), i = 1, nshape )
4488  WRITE(outnum, 3000) ' DIAG :', ( diag0(i), i = 1, nshape )
4489  WRITE(outnum, 2000) 'NMAT :', nmat
4490  WRITE(outnum, 2000) ' M :', ( m0(i), i = 1, nmat )
4491  WRITE(outnum, 2000) ' N :', ( n0(i), i = 1, nmat )
4492  WRITE(outnum, 2000) ' LDAS :', ( ldas0(i), i = 1, nmat )
4493  WRITE(outnum, 2000) ' LDAD :', ( ldad0(i), i = 1, nmat )
4494  WRITE(outnum, 2000) 'NSRC :', nsrc
4495  WRITE(outnum, 2000) ' RSRC :',( rsrc0(i), i = 1, nsrc )
4496  WRITE(outnum, 2000) ' CSRC :',( csrc0(i), i = 1, nsrc )
4497  WRITE(outnum, 2000) 'NGRIDS:', ngrid
4498  WRITE(outnum, 2000) ' P :', ( p0(i), i = 1, ngrid )
4499  WRITE(outnum, 2000) ' Q :', ( q0(i), i = 1, ngrid )
4500  WRITE(outnum, 2000) 'VERB :', verb
4501  WRITE(outnum,*) ' '
4502  END IF
4503  IF( verb .GT. 1 ) THEN
4504  WRITE(outnum,5000)
4505  WRITE(outnum,6000)
4506  END IF
4507  END IF
4508 *
4509 * Find biggest matrix, so we know where to stick error info
4510 *
4511  i = 0
4512  DO 10 ima = 1, nmat
4513  k = n0(ima) * max0( ldas0(ima), ldad0(ima) ) + 4 * m0(ima)
4514  IF( k .GT. i ) i = k
4515  10 CONTINUE
4516  maxerr = ( ssize * (memlen-i) ) / ( ssize*2 + isize*6 )
4517  IF( maxerr .LT. 1 ) THEN
4518  WRITE(outnum,*) 'ERROR: Not enough memory to run BSBR tests.'
4519  CALL blacs_abort(-1, 1)
4520  END IF
4521  errdptr = i + 1
4522  erriptr = errdptr + maxerr
4523  nerr = 0
4524  testnum = 0
4525  nfail = 0
4526  nskip = 0
4527 *
4528 * Loop over grids of matrix
4529 *
4530  DO 110 igr = 1, ngrid
4531 *
4532  context = context0(igr)
4533  CALL blacs_gridinfo( context, nprow, npcol, myrow, mycol )
4534 *
4535  ingrid = ( nprow .GT. 0 )
4536 *
4537  DO 100 isc = 1, nscope
4538  scope = scope0(isc)
4539  DO 90 ito = 1, ntop
4540  top = top0(ito)
4541 *
4542 * If testing multipath ('M') or general tree ('T'),
4543 * need to loop over calls to BLACS_SET
4544 *
4545  IF( lsame(top, 'M') ) THEN
4546  setwhat = 11
4547  IF( scope .EQ. 'R' ) THEN
4548  istart = -(npcol - 1)
4549  istop = -istart
4550  ELSE IF (scope .EQ. 'C') THEN
4551  istart = -(nprow - 1)
4552  istop = -istart
4553  ELSE
4554  istart = -(nprow*npcol - 1)
4555  istop = -istart
4556  ENDIF
4557  ELSE IF( lsame(top, 'T') ) THEN
4558  setwhat = 12
4559  istart = 1
4560  IF( scope .EQ. 'R' ) THEN
4561  istop = npcol - 1
4562  ELSE IF (scope .EQ. 'C') THEN
4563  istop = nprow - 1
4564  ELSE
4565  istop = nprow*npcol - 1
4566  ENDIF
4567  ELSE
4568  setwhat = 0
4569  istart = 1
4570  istop = 1
4571  ENDIF
4572  DO 80 ish = 1, nshape
4573  uplo = uplo0(ish)
4574  diag = diag0(ish)
4575 *
4576  DO 70 ima = 1, nmat
4577  m = m0(ima)
4578  n = n0(ima)
4579  ldasrc = ldas0(ima)
4580  ldadst = ldad0(ima)
4581 *
4582  DO 60 iso = 1, nsrc
4583  testnum = testnum + 1
4584  rsrc = rsrc0(iso)
4585  csrc = csrc0(iso)
4586  IF( rsrc.GE.p0(igr) .OR. csrc.GE.q0(igr) ) THEN
4587  nskip = nskip + 1
4588  GOTO 60
4589  END IF
4590  IF( verb .GT. 1 ) THEN
4591  IF( iam .EQ. 0 ) THEN
4592  WRITE(outnum, 7000)
4593  $ testnum, 'RUNNING',scope, top, uplo, diag,
4594  $ m, n, ldasrc, ldadst, rsrc, csrc,
4595  $ nprow, npcol
4596  END IF
4597  END IF
4598 *
4599  testok = .true.
4600  ipre = 2 * m
4601  ipost = ipre
4602  aptr = ipre + 1
4603 *
4604 * If I am in scope
4605 *
4606  IF( (myrow.EQ.rsrc .AND. scope.EQ.'R') .OR.
4607  $ (mycol.EQ.csrc .AND. scope.EQ.'C') .OR.
4608  $ (scope .EQ. 'A') ) THEN
4609 *
4610 * source process generates matrix and sends it
4611 *
4612  IF( myrow.EQ.rsrc .AND. mycol.EQ.csrc ) THEN
4613  CALL sinitmat(uplo, diag, m, n, mem,
4614  $ ldasrc, ipre, ipost,
4615  $ scheckval, testnum,
4616  $ myrow, mycol )
4617 *
4618  DO 20 j = istart, istop
4619  IF( j.EQ.0 ) GOTO 20
4620  IF( setwhat.NE.0 )
4621  $ CALL blacs_set(context, setwhat, j)
4622  IF( uplo.EQ.'U' .OR. uplo.EQ.'L' ) THEN
4623  CALL strbs2d(context, scope, top,
4624  $ uplo, diag, m, n,
4625  $ mem(aptr), ldasrc )
4626  ELSE
4627  CALL sgebs2d(context, scope, top,
4628  $ m, n, mem(aptr),
4629  $ ldasrc )
4630  END IF
4631  20 CONTINUE
4632 *
4633 * Destination processes
4634 *
4635  ELSE IF( ingrid ) THEN
4636  DO 40 j = istart, istop
4637  IF( j.EQ.0 ) GOTO 40
4638  IF( setwhat.NE.0 )
4639  $ CALL blacs_set(context, setwhat, j)
4640 *
4641 * Pad entire matrix area
4642 *
4643  DO 30 k = 1, ipre+ipost+ldadst*n
4644  mem(k) = rcheckval
4645  30 CONTINUE
4646 *
4647 * Receive matrix
4648 *
4649  IF( uplo.EQ.'U' .OR. uplo.EQ.'L' ) THEN
4650  CALL strbr2d(context, scope, top,
4651  $ uplo, diag, m, n,
4652  $ mem(aptr), ldadst,
4653  $ rsrc, csrc)
4654  ELSE
4655  CALL sgebr2d(context, scope, top,
4656  $ m, n, mem(aptr),
4657  $ ldadst, rsrc, csrc)
4658  END IF
4659 *
4660 * Check for errors in matrix or padding
4661 *
4662  i = nerr
4663  CALL schkmat(uplo, diag, m, n,
4664  $ mem(aptr), ldadst, rsrc, csrc,
4665  $ myrow, mycol, testnum, maxerr,
4666  $ nerr, mem(erriptr),
4667  $ mem(errdptr))
4668 *
4669  CALL schkpad(uplo, diag, m, n, mem,
4670  $ ldadst, rsrc, csrc, myrow,
4671  $ mycol, ipre, ipost, rcheckval,
4672  $ testnum, maxerr, nerr,
4673  $ mem(erriptr), mem(errdptr))
4674  40 CONTINUE
4675  testok = ( i .EQ. nerr )
4676  END IF
4677  END IF
4678 *
4679  IF( verb .GT. 1 ) THEN
4680  i = nerr
4681  CALL sbtcheckin(0, outnum, maxerr, nerr,
4682  $ mem(erriptr), mem(errdptr),
4683  $ tfail)
4684  IF( iam .EQ. 0 ) THEN
4685  testok = ( testok .AND. (i.EQ.nerr) )
4686  IF( testok ) THEN
4687  WRITE(outnum,7000)testnum,'PASSED ',
4688  $ scope, top, uplo, diag, m, n,
4689  $ ldasrc, ldadst, rsrc, csrc,
4690  $ nprow, npcol
4691  ELSE
4692  nfail = nfail + 1
4693  WRITE(outnum,7000)testnum,'FAILED ',
4694  $ scope, top, uplo, diag, m, n,
4695  $ ldasrc, ldadst, rsrc, csrc,
4696  $ nprow, npcol
4697  END IF
4698  END IF
4699 *
4700 * Once we've printed out errors, can re-use buf space
4701 *
4702  nerr = 0
4703  END IF
4704  60 CONTINUE
4705  70 CONTINUE
4706  80 CONTINUE
4707  90 CONTINUE
4708  100 CONTINUE
4709  110 CONTINUE
4710 *
4711  IF( verb .LT. 2 ) THEN
4712  nfail = testnum
4713  CALL sbtcheckin( nfail, outnum, maxerr, nerr, mem(erriptr),
4714  $ mem(errdptr), tfail )
4715  END IF
4716  IF( iam .EQ. 0 ) THEN
4717  IF( verb .GT. 1 ) WRITE(outnum,*) ' '
4718  IF( nfail+nskip .EQ. 0 ) THEN
4719  WRITE(outnum, 8000 ) testnum
4720  ELSE
4721  WRITE(outnum, 9000 ) testnum, testnum-nskip-nfail,
4722  $ nskip, nfail
4723  END IF
4724  END IF
4725 *
4726 * Log whether their were any failures
4727 *
4728  testok = allpass( (nfail.EQ.0) )
4729 *
4730  1000 FORMAT('REAL BSBR TESTS: BEGIN.' )
4731  2000 FORMAT(1x,a7,3x,10i6)
4732  3000 FORMAT(1x,a7,3x,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,
4733  $ 5x,a1,5x,a1)
4734  5000 FORMAT(' TEST# STATUS SCOPE TOP UPLO DIAG M N LDAS ',
4735  $ ' LDAD RSRC CSRC P Q')
4736  6000 FORMAT(' ----- ------- ----- --- ---- ---- ----- ----- ----- ',
4737  $ '----- ---- ---- ---- ----')
4738  7000 FORMAT(i6,1x,a7,5x,a1,3x,a1,2(4x,a1), 4i6, 4i5)
4739  8000 FORMAT('REAL BSBR TESTS: PASSED ALL',
4740  $ i5, ' TESTS.')
4741  9000 FORMAT('REAL BSBR TESTS:',i5,' TESTS;',i5,' PASSED,',
4742  $ i5,' SKIPPED,',i5,' FAILED.')
4743 *
4744  RETURN
4745 *
4746 * End of SBSBRTEST.
4747 *
4748  END
4749 *
4750 *
4751  SUBROUTINE dbsbrtest( OUTNUM, VERB, NSCOPE, SCOPE0, NTOP, TOP0,
4752  $ NSHAPE, UPLO0, DIAG0, NMAT, M0, N0, LDAS0,
4753  $ LDAD0, NSRC, RSRC0, CSRC0, NGRID, CONTEXT0,
4754  $ P0, Q0, TFAIL, MEM, MEMLEN )
4755 *
4756 * -- BLACS tester (version 1.0) --
4757 * University of Tennessee
4758 * December 15, 1994
4759 *
4760 *
4761 * .. Scalar Arguments ..
4762  INTEGER OUTNUM, VERB, NSCOPE, NTOP, NSHAPE, NMAT, NSRC, NGRID
4763  INTEGER MEMLEN
4764 * ..
4765 * .. Array Arguments ..
4766  CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP)
4767  CHARACTER*1 UPLO0(NSHAPE), DIAG0(NSHAPE)
4768  INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT)
4769  INTEGER RSRC0(NSRC), CSRC0(NSRC), CONTEXT0(NGRID)
4770  INTEGER P0(NGRID), Q0(NGRID), TFAIL(*)
4771  DOUBLE PRECISION MEM(MEMLEN)
4772 * ..
4773 *
4774 * Purpose
4775 * =======
4776 * DTESTBSBR: Test double precision broadcast
4777 *
4778 * Arguments
4779 * =========
4780 * OUTNUM (input) INTEGER
4781 * The device number to write output to.
4782 *
4783 * VERB (input) INTEGER
4784 * The level of verbosity (how much printing to do).
4785 *
4786 * NSCOPE (input) INTEGER
4787 * The number of scopes to be tested.
4788 *
4789 * SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE)
4790 * Values of the scopes to be tested.
4791 *
4792 * NTOP (input) INTEGER
4793 * The number of topologies to be tested.
4794 *
4795 * TOP0 (input) CHARACTER*1 array of dimension (NTOP)
4796 * Values of the topologies to be tested.
4797 *
4798 * NSHAPE (input) INTEGER
4799 * The number of matrix shapes to be tested.
4800 *
4801 * UPLO0 (input) CHARACTER*1 array of dimension (NSHAPE)
4802 * Values of UPLO to be tested.
4803 *
4804 * DIAG0 (input) CHARACTER*1 array of dimension (NSHAPE)
4805 * Values of DIAG to be tested.
4806 *
4807 * NMAT (input) INTEGER
4808 * The number of matrices to be tested.
4809 *
4810 * M0 (input) INTEGER array of dimension (NMAT)
4811 * Values of M to be tested.
4812 *
4813 * M0 (input) INTEGER array of dimension (NMAT)
4814 * Values of M to be tested.
4815 *
4816 * N0 (input) INTEGER array of dimension (NMAT)
4817 * Values of N to be tested.
4818 *
4819 * LDAS0 (input) INTEGER array of dimension (NMAT)
4820 * Values of LDAS (leading dimension of A on source process)
4821 * to be tested.
4822 *
4823 * LDAD0 (input) INTEGER array of dimension (NMAT)
4824 * Values of LDAD (leading dimension of A on destination
4825 * process) to be tested.
4826 * NSRC (input) INTEGER
4827 * The number of sources to be tested.
4828 *
4829 * RSRC0 (input) INTEGER array of dimension (NDEST)
4830 * Values of RSRC (row coordinate of source) to be tested.
4831 *
4832 * CSRC0 (input) INTEGER array of dimension (NDEST)
4833 * Values of CSRC (column coordinate of source) to be tested.
4834 *
4835 * NGRID (input) INTEGER
4836 * The number of process grids to be tested.
4837 *
4838 * CONTEXT0 (input) INTEGER array of dimension (NGRID)
4839 * The BLACS context handles corresponding to the grids.
4840 *
4841 * P0 (input) INTEGER array of dimension (NGRID)
4842 * Values of P (number of process rows, NPROW).
4843 *
4844 * Q0 (input) INTEGER array of dimension (NGRID)
4845 * Values of Q (number of process columns, NPCOL).
4846 *
4847 * TFAIL (workspace) INTEGER array of dimension (NTESTS)
4848 * If VERB < 2, serves to indicate which tests fail. This
4849 * requires workspace of NTESTS (number of tests performed).
4850 *
4851 * MEM (workspace) DOUBLE PRECISION array of dimension (MEMLEN)
4852 * Used for all other workspaces, including the matrix A,
4853 * and its pre and post padding.
4854 *
4855 * MEMLEN (input) INTEGER
4856 * The length, in elements, of MEM.
4857 *
4858 * =====================================================================
4859 *
4860 * .. External Functions ..
4861  LOGICAL ALLPASS, LSAME
4862  INTEGER IBTMYPROC, IBTSIZEOF
4863  EXTERNAL ALLPASS, LSAME, IBTMYPROC, IBTSIZEOF
4864 * ..
4865 * .. External Subroutines ..
4866  EXTERNAL BLACS_GRIDINFO
4867  EXTERNAL DTRBS2D, DGEBS2D, DTRBR2D, DGEBR2D
4868  EXTERNAL DINITMAT, DCHKMAT, DCHKPAD, DBTCHECKIN
4869 * ..
4870 * .. Local Scalars ..
4871  CHARACTER*1 SCOPE, TOP, UPLO, DIAG
4872  LOGICAL TESTOK, INGRID
4873  INTEGER IAM, I, K, J, IGR, ISH, IMA, ISO, ISC, ITO
4874  INTEGER M, N, NPROW, NPCOL, MYROW, MYCOL, RSRC, CSRC
4875  INTEGER ISTART, ISTOP, IPRE, IPOST, SETWHAT
4876  INTEGER NERR, NSKIP, NFAIL, TESTNUM, CONTEXT, MAXERR, LDASRC
4877  INTEGER LDADST, ERRDPTR, APTR, ERRIPTR, ISIZE, DSIZE
4878  DOUBLE PRECISION SCHECKVAL, RCHECKVAL
4879 * ..
4880 * .. Executable Statements ..
4881 *
4882  SCHECKVAL = -0.01d0
4883  rcheckval = -0.02d0
4884 *
4885  iam = ibtmyproc()
4886  isize = ibtsizeof('I')
4887  dsize = ibtsizeof('D')
4888 *
4889 * Verify file parameters
4890 *
4891  IF( iam .EQ. 0 ) THEN
4892  WRITE(outnum, *) ' '
4893  WRITE(outnum, *) ' '
4894  WRITE(outnum, 1000 )
4895  IF( verb .GT. 0 ) THEN
4896  WRITE(outnum,*) ' '
4897  WRITE(outnum, 2000) 'NSCOPE:', nscope
4898  WRITE(outnum, 3000) ' SCOPE:', ( scope0(i), i = 1, nscope )
4899  WRITE(outnum, 2000) 'NTOP :', ntop
4900  WRITE(outnum, 3000) ' TOP :', ( top0(i), i = 1, ntop )
4901  WRITE(outnum, 2000) 'NSHAPE:', nshape
4902  WRITE(outnum, 3000) ' UPLO :', ( uplo0(i), i = 1, nshape )
4903  WRITE(outnum, 3000) ' DIAG :', ( diag0(i), i = 1, nshape )
4904  WRITE(outnum, 2000) 'NMAT :', nmat
4905  WRITE(outnum, 2000) ' M :', ( m0(i), i = 1, nmat )
4906  WRITE(outnum, 2000) ' N :', ( n0(i), i = 1, nmat )
4907  WRITE(outnum, 2000) ' LDAS :', ( ldas0(i), i = 1, nmat )
4908  WRITE(outnum, 2000) ' LDAD :', ( ldad0(i), i = 1, nmat )
4909  WRITE(outnum, 2000) 'NSRC :', nsrc
4910  WRITE(outnum, 2000) ' RSRC :',( rsrc0(i), i = 1, nsrc )
4911  WRITE(outnum, 2000) ' CSRC :',( csrc0(i), i = 1, nsrc )
4912  WRITE(outnum, 2000) 'NGRIDS:', ngrid
4913  WRITE(outnum, 2000) ' P :', ( p0(i), i = 1, ngrid )
4914  WRITE(outnum, 2000) ' Q :', ( q0(i), i = 1, ngrid )
4915  WRITE(outnum, 2000) 'VERB :', verb
4916  WRITE(outnum,*) ' '
4917  END IF
4918  IF( verb .GT. 1 ) THEN
4919  WRITE(outnum,5000)
4920  WRITE(outnum,6000)
4921  END IF
4922  END IF
4923 *
4924 * Find biggest matrix, so we know where to stick error info
4925 *
4926  i = 0
4927  DO 10 ima = 1, nmat
4928  k = n0(ima) * max0( ldas0(ima), ldad0(ima) ) + 4 * m0(ima)
4929  IF( k .GT. i ) i = k
4930  10 CONTINUE
4931  maxerr = ( dsize * (memlen-i) ) / ( dsize*2 + isize*6 )
4932  IF( maxerr .LT. 1 ) THEN
4933  WRITE(outnum,*) 'ERROR: Not enough memory to run BSBR tests.'
4934  CALL blacs_abort(-1, 1)
4935  END IF
4936  errdptr = i + 1
4937  erriptr = errdptr + maxerr
4938  nerr = 0
4939  testnum = 0
4940  nfail = 0
4941  nskip = 0
4942 *
4943 * Loop over grids of matrix
4944 *
4945  DO 110 igr = 1, ngrid
4946 *
4947  context = context0(igr)
4948  CALL blacs_gridinfo( context, nprow, npcol, myrow, mycol )
4949 *
4950  ingrid = ( nprow .GT. 0 )
4951 *
4952  DO 100 isc = 1, nscope
4953  scope = scope0(isc)
4954  DO 90 ito = 1, ntop
4955  top = top0(ito)
4956 *
4957 * If testing multipath ('M') or general tree ('T'),
4958 * need to loop over calls to BLACS_SET
4959 *
4960  IF( lsame(top, 'M') ) THEN
4961  setwhat = 11
4962  IF( scope .EQ. 'R' ) THEN
4963  istart = -(npcol - 1)
4964  istop = -istart
4965  ELSE IF (scope .EQ. 'C') THEN
4966  istart = -(nprow - 1)
4967  istop = -istart
4968  ELSE
4969  istart = -(nprow*npcol - 1)
4970  istop = -istart
4971  ENDIF
4972  ELSE IF( lsame(top, 'T') ) THEN
4973  setwhat = 12
4974  istart = 1
4975  IF( scope .EQ. 'R' ) THEN
4976  istop = npcol - 1
4977  ELSE IF (scope .EQ. 'C') THEN
4978  istop = nprow - 1
4979  ELSE
4980  istop = nprow*npcol - 1
4981  ENDIF
4982  ELSE
4983  setwhat = 0
4984  istart = 1
4985  istop = 1
4986  ENDIF
4987  DO 80 ish = 1, nshape
4988  uplo = uplo0(ish)
4989  diag = diag0(ish)
4990 *
4991  DO 70 ima = 1, nmat
4992  m = m0(ima)
4993  n = n0(ima)
4994  ldasrc = ldas0(ima)
4995  ldadst = ldad0(ima)
4996 *
4997  DO 60 iso = 1, nsrc
4998  testnum = testnum + 1
4999  rsrc = rsrc0(iso)
5000  csrc = csrc0(iso)
5001  IF( rsrc.GE.p0(igr) .OR. csrc.GE.q0(igr) ) THEN
5002  nskip = nskip + 1
5003  GOTO 60
5004  END IF
5005  IF( verb .GT. 1 ) THEN
5006  IF( iam .EQ. 0 ) THEN
5007  WRITE(outnum, 7000)
5008  $ testnum, 'RUNNING',scope, top, uplo, diag,
5009  $ m, n, ldasrc, ldadst, rsrc, csrc,
5010  $ nprow, npcol
5011  END IF
5012  END IF
5013 *
5014  testok = .true.
5015  ipre = 2 * m
5016  ipost = ipre
5017  aptr = ipre + 1
5018 *
5019 * If I am in scope
5020 *
5021  IF( (myrow.EQ.rsrc .AND. scope.EQ.'R') .OR.
5022  $ (mycol.EQ.csrc .AND. scope.EQ.'C') .OR.
5023  $ (scope .EQ. 'A') ) THEN
5024 *
5025 * source process generates matrix and sends it
5026 *
5027  IF( myrow.EQ.rsrc .AND. mycol.EQ.csrc ) THEN
5028  CALL dinitmat(uplo, diag, m, n, mem,
5029  $ ldasrc, ipre, ipost,
5030  $ scheckval, testnum,
5031  $ myrow, mycol )
5032 *
5033  DO 20 j = istart, istop
5034  IF( j.EQ.0 ) GOTO 20
5035  IF( setwhat.NE.0 )
5036  $ CALL blacs_set(context, setwhat, j)
5037  IF( uplo.EQ.'U' .OR. uplo.EQ.'L' ) THEN
5038  CALL dtrbs2d(context, scope, top,
5039  $ uplo, diag, m, n,
5040  $ mem(aptr), ldasrc )
5041  ELSE
5042  CALL dgebs2d(context, scope, top,
5043  $ m, n, mem(aptr),
5044  $ ldasrc )
5045  END IF
5046  20 CONTINUE
5047 *
5048 * Destination processes
5049 *
5050  ELSE IF( ingrid ) THEN
5051  DO 40 j = istart, istop
5052  IF( j.EQ.0 ) GOTO 40
5053  IF( setwhat.NE.0 )
5054  $ CALL blacs_set(context, setwhat, j)
5055 *
5056 * Pad entire matrix area
5057 *
5058  DO 30 k = 1, ipre+ipost+ldadst*n
5059  mem(k) = rcheckval
5060  30 CONTINUE
5061 *
5062 * Receive matrix
5063 *
5064  IF( uplo.EQ.'U' .OR. uplo.EQ.'L' ) THEN
5065  CALL dtrbr2d(context, scope, top,
5066  $ uplo, diag, m, n,
5067  $ mem(aptr), ldadst,
5068  $ rsrc, csrc)
5069  ELSE
5070  CALL dgebr2d(context, scope, top,
5071  $ m, n, mem(aptr),
5072  $ ldadst, rsrc, csrc)
5073  END IF
5074 *
5075 * Check for errors in matrix or padding
5076 *
5077  i = nerr
5078  CALL dchkmat(uplo, diag, m, n,
5079  $ mem(aptr), ldadst, rsrc, csrc,
5080  $ myrow, mycol, testnum, maxerr,
5081  $ nerr, mem(erriptr),
5082  $ mem(errdptr))
5083 *
5084  CALL dchkpad(uplo, diag, m, n, mem,
5085  $ ldadst, rsrc, csrc, myrow,
5086  $ mycol, ipre, ipost, rcheckval,
5087  $ testnum, maxerr, nerr,
5088  $ mem(erriptr), mem(errdptr))
5089  40 CONTINUE
5090  testok = ( i .EQ. nerr )
5091  END IF
5092  END IF
5093 *
5094  IF( verb .GT. 1 ) THEN
5095  i = nerr
5096  CALL dbtcheckin(0, outnum, maxerr, nerr,
5097  $ mem(erriptr), mem(errdptr),
5098  $ tfail)
5099  IF( iam .EQ. 0 ) THEN
5100  testok = ( testok .AND. (i.EQ.nerr) )
5101  IF( testok ) THEN
5102  WRITE(outnum,7000)testnum,'PASSED ',
5103  $ scope, top, uplo, diag, m, n,
5104  $ ldasrc, ldadst, rsrc, csrc,
5105  $ nprow, npcol
5106  ELSE
5107  nfail = nfail + 1
5108  WRITE(outnum,7000)testnum,'FAILED ',
5109  $ scope, top, uplo, diag, m, n,
5110  $ ldasrc, ldadst, rsrc, csrc,
5111  $ nprow, npcol
5112  END IF
5113  END IF
5114 *
5115 * Once we've printed out errors, can re-use buf space
5116 *
5117  nerr = 0
5118  END IF
5119  60 CONTINUE
5120  70 CONTINUE
5121  80 CONTINUE
5122  90 CONTINUE
5123  100 CONTINUE
5124  110 CONTINUE
5125 *
5126  IF( verb .LT. 2 ) THEN
5127  nfail = testnum
5128  CALL dbtcheckin( nfail, outnum, maxerr, nerr, mem(erriptr),
5129  $ mem(errdptr), tfail )
5130  END IF
5131  IF( iam .EQ. 0 ) THEN
5132  IF( verb .GT. 1 ) WRITE(outnum,*) ' '
5133  IF( nfail+nskip .EQ. 0 ) THEN
5134  WRITE(outnum, 8000 ) testnum
5135  ELSE
5136  WRITE(outnum, 9000 ) testnum, testnum-nskip-nfail,
5137  $ nskip, nfail
5138  END IF
5139  END IF
5140 *
5141 * Log whether their were any failures
5142 *
5143  testok = allpass( (nfail.EQ.0) )
5144 *
5145  1000 FORMAT('DOUBLE PRECISION BSBR TESTS: BEGIN.' )
5146  2000 FORMAT(1x,a7,3x,10i6)
5147  3000 FORMAT(1x,a7,3x,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,
5148  $ 5x,a1,5x,a1)
5149  5000 FORMAT(' TEST# STATUS SCOPE TOP UPLO DIAG M N LDAS ',
5150  $ ' LDAD RSRC CSRC P Q')
5151  6000 FORMAT(' ----- ------- ----- --- ---- ---- ----- ----- ----- ',
5152  $ '----- ---- ---- ---- ----')
5153  7000 FORMAT(i6,1x,a7,5x,a1,3x,a1,2(4x,a1), 4i6, 4i5)
5154  8000 FORMAT('DOUBLE PRECISION BSBR TESTS: PASSED ALL',
5155  $ i5, ' TESTS.')
5156  9000 FORMAT('DOUBLE PRECISION BSBR TESTS:',i5,' TESTS;',i5,' PASSED,',
5157  $ i5,' SKIPPED,',i5,' FAILED.')
5158 *
5159  RETURN
5160 *
5161 * End of DBSBRTEST.
5162 *
5163  END
5164 *
5165 *
5166  SUBROUTINE cbsbrtest( OUTNUM, VERB, NSCOPE, SCOPE0, NTOP, TOP0,
5167  $ NSHAPE, UPLO0, DIAG0, NMAT, M0, N0, LDAS0,
5168  $ LDAD0, NSRC, RSRC0, CSRC0, NGRID, CONTEXT0,
5169  $ P0, Q0, TFAIL, MEM, MEMLEN )
5170 *
5171 * -- BLACS tester (version 1.0) --
5172 * University of Tennessee
5173 * December 15, 1994
5174 *
5175 *
5176 * .. Scalar Arguments ..
5177  INTEGER OUTNUM, VERB, NSCOPE, NTOP, NSHAPE, NMAT, NSRC, NGRID
5178  INTEGER MEMLEN
5179 * ..
5180 * .. Array Arguments ..
5181  CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP)
5182  CHARACTER*1 UPLO0(NSHAPE), DIAG0(NSHAPE)
5183  INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT)
5184  INTEGER RSRC0(NSRC), CSRC0(NSRC), CONTEXT0(NGRID)
5185  INTEGER P0(NGRID), Q0(NGRID), TFAIL(*)
5186  COMPLEX MEM(MEMLEN)
5187 * ..
5188 *
5189 * Purpose
5190 * =======
5191 * CTESTBSBR: Test complex broadcast
5192 *
5193 * Arguments
5194 * =========
5195 * OUTNUM (input) INTEGER
5196 * The device number to write output to.
5197 *
5198 * VERB (input) INTEGER
5199 * The level of verbosity (how much printing to do).
5200 *
5201 * NSCOPE (input) INTEGER
5202 * The number of scopes to be tested.
5203 *
5204 * SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE)
5205 * Values of the scopes to be tested.
5206 *
5207 * NTOP (input) INTEGER
5208 * The number of topologies to be tested.
5209 *
5210 * TOP0 (input) CHARACTER*1 array of dimension (NTOP)
5211 * Values of the topologies to be tested.
5212 *
5213 * NSHAPE (input) INTEGER
5214 * The number of matrix shapes to be tested.
5215 *
5216 * UPLO0 (input) CHARACTER*1 array of dimension (NSHAPE)
5217 * Values of UPLO to be tested.
5218 *
5219 * DIAG0 (input) CHARACTER*1 array of dimension (NSHAPE)
5220 * Values of DIAG to be tested.
5221 *
5222 * NMAT (input) INTEGER
5223 * The number of matrices to be tested.
5224 *
5225 * M0 (input) INTEGER array of dimension (NMAT)
5226 * Values of M to be tested.
5227 *
5228 * M0 (input) INTEGER array of dimension (NMAT)
5229 * Values of M to be tested.
5230 *
5231 * N0 (input) INTEGER array of dimension (NMAT)
5232 * Values of N to be tested.
5233 *
5234 * LDAS0 (input) INTEGER array of dimension (NMAT)
5235 * Values of LDAS (leading dimension of A on source process)
5236 * to be tested.
5237 *
5238 * LDAD0 (input) INTEGER array of dimension (NMAT)
5239 * Values of LDAD (leading dimension of A on destination
5240 * process) to be tested.
5241 * NSRC (input) INTEGER
5242 * The number of sources to be tested.
5243 *
5244 * RSRC0 (input) INTEGER array of dimension (NDEST)
5245 * Values of RSRC (row coordinate of source) to be tested.
5246 *
5247 * CSRC0 (input) INTEGER array of dimension (NDEST)
5248 * Values of CSRC (column coordinate of source) to be tested.
5249 *
5250 * NGRID (input) INTEGER
5251 * The number of process grids to be tested.
5252 *
5253 * CONTEXT0 (input) INTEGER array of dimension (NGRID)
5254 * The BLACS context handles corresponding to the grids.
5255 *
5256 * P0 (input) INTEGER array of dimension (NGRID)
5257 * Values of P (number of process rows, NPROW).
5258 *
5259 * Q0 (input) INTEGER array of dimension (NGRID)
5260 * Values of Q (number of process columns, NPCOL).
5261 *
5262 * TFAIL (workspace) INTEGER array of dimension (NTESTS)
5263 * If VERB < 2, serves to indicate which tests fail. This
5264 * requires workspace of NTESTS (number of tests performed).
5265 *
5266 * MEM (workspace) COMPLEX array of dimension (MEMLEN)
5267 * Used for all other workspaces, including the matrix A,
5268 * and its pre and post padding.
5269 *
5270 * MEMLEN (input) INTEGER
5271 * The length, in elements, of MEM.
5272 *
5273 * =====================================================================
5274 *
5275 * .. External Functions ..
5276  LOGICAL ALLPASS, LSAME
5277  INTEGER IBTMYPROC, IBTSIZEOF
5278  EXTERNAL ALLPASS, LSAME, IBTMYPROC, IBTSIZEOF
5279 * ..
5280 * .. External Subroutines ..
5281  EXTERNAL BLACS_GRIDINFO
5282  EXTERNAL CTRBS2D, CGEBS2D, CTRBR2D, CGEBR2D
5283  EXTERNAL CINITMAT, CCHKMAT, CCHKPAD, CBTCHECKIN
5284 * ..
5285 * .. Local Scalars ..
5286  CHARACTER*1 SCOPE, TOP, UPLO, DIAG
5287  LOGICAL TESTOK, INGRID
5288  INTEGER IAM, I, K, J, IGR, ISH, IMA, ISO, ISC, ITO
5289  INTEGER M, N, NPROW, NPCOL, MYROW, MYCOL, RSRC, CSRC
5290  INTEGER ISTART, ISTOP, IPRE, IPOST, SETWHAT
5291  INTEGER NERR, NSKIP, NFAIL, TESTNUM, CONTEXT, MAXERR, LDASRC
5292  INTEGER LDADST, ERRDPTR, APTR, ERRIPTR, ISIZE, CSIZE
5293  COMPLEX SCHECKVAL, RCHECKVAL
5294 * ..
5295 * .. Executable Statements ..
5296 *
5297  SCHECKVAL = cmplx( -0.01, -0.01 )
5298  rcheckval = cmplx( -0.02, -0.02 )
5299 *
5300  iam = ibtmyproc()
5301  isize = ibtsizeof('I')
5302  csize = ibtsizeof('C')
5303 *
5304 * Verify file parameters
5305 *
5306  IF( iam .EQ. 0 ) THEN
5307  WRITE(outnum, *) ' '
5308  WRITE(outnum, *) ' '
5309  WRITE(outnum, 1000 )
5310  IF( verb .GT. 0 ) THEN
5311  WRITE(outnum,*) ' '
5312  WRITE(outnum, 2000) 'NSCOPE:', nscope
5313  WRITE(outnum, 3000) ' SCOPE:', ( scope0(i), i = 1, nscope )
5314  WRITE(outnum, 2000) 'NTOP :', ntop
5315  WRITE(outnum, 3000) ' TOP :', ( top0(i), i = 1, ntop )
5316  WRITE(outnum, 2000) 'NSHAPE:', nshape
5317  WRITE(outnum, 3000) ' UPLO :', ( uplo0(i), i = 1, nshape )
5318  WRITE(outnum, 3000) ' DIAG :', ( diag0(i), i = 1, nshape )
5319  WRITE(outnum, 2000) 'NMAT :', nmat
5320  WRITE(outnum, 2000) ' M :', ( m0(i), i = 1, nmat )
5321  WRITE(outnum, 2000) ' N :', ( n0(i), i = 1, nmat )
5322  WRITE(outnum, 2000) ' LDAS :', ( ldas0(i), i = 1, nmat )
5323  WRITE(outnum, 2000) ' LDAD :', ( ldad0(i), i = 1, nmat )
5324  WRITE(outnum, 2000) 'NSRC :', nsrc
5325  WRITE(outnum, 2000) ' RSRC :',( rsrc0(i), i = 1, nsrc )
5326  WRITE(outnum, 2000) ' CSRC :',( csrc0(i), i = 1, nsrc )
5327  WRITE(outnum, 2000) 'NGRIDS:', ngrid
5328  WRITE(outnum, 2000) ' P :', ( p0(i), i = 1, ngrid )
5329  WRITE(outnum, 2000) ' Q :', ( q0(i), i = 1, ngrid )
5330  WRITE(outnum, 2000) 'VERB :', verb
5331  WRITE(outnum,*) ' '
5332  END IF
5333  IF( verb .GT. 1 ) THEN
5334  WRITE(outnum,5000)
5335  WRITE(outnum,6000)
5336  END IF
5337  END IF
5338 *
5339 * Find biggest matrix, so we know where to stick error info
5340 *
5341  i = 0
5342  DO 10 ima = 1, nmat
5343  k = n0(ima) * max0( ldas0(ima), ldad0(ima) ) + 4 * m0(ima)
5344  IF( k .GT. i ) i = k
5345  10 CONTINUE
5346  maxerr = ( csize * (memlen-i) ) / ( csize*2 + isize*6 )
5347  IF( maxerr .LT. 1 ) THEN
5348  WRITE(outnum,*) 'ERROR: Not enough memory to run BSBR tests.'
5349  CALL blacs_abort(-1, 1)
5350  END IF
5351  errdptr = i + 1
5352  erriptr = errdptr + maxerr
5353  nerr = 0
5354  testnum = 0
5355  nfail = 0
5356  nskip = 0
5357 *
5358 * Loop over grids of matrix
5359 *
5360  DO 110 igr = 1, ngrid
5361 *
5362  context = context0(igr)
5363  CALL blacs_gridinfo( context, nprow, npcol, myrow, mycol )
5364 *
5365  ingrid = ( nprow .GT. 0 )
5366 *
5367  DO 100 isc = 1, nscope
5368  scope = scope0(isc)
5369  DO 90 ito = 1, ntop
5370  top = top0(ito)
5371 *
5372 * If testing multipath ('M') or general tree ('T'),
5373 * need to loop over calls to BLACS_SET
5374 *
5375  IF( lsame(top, 'M') ) THEN
5376  setwhat = 11
5377  IF( scope .EQ. 'R' ) THEN
5378  istart = -(npcol - 1)
5379  istop = -istart
5380  ELSE IF (scope .EQ. 'C') THEN
5381  istart = -(nprow - 1)
5382  istop = -istart
5383  ELSE
5384  istart = -(nprow*npcol - 1)
5385  istop = -istart
5386  ENDIF
5387  ELSE IF( lsame(top, 'T') ) THEN
5388  setwhat = 12
5389  istart = 1
5390  IF( scope .EQ. 'R' ) THEN
5391  istop = npcol - 1
5392  ELSE IF (scope .EQ. 'C') THEN
5393  istop = nprow - 1
5394  ELSE
5395  istop = nprow*npcol - 1
5396  ENDIF
5397  ELSE
5398  setwhat = 0
5399  istart = 1
5400  istop = 1
5401  ENDIF
5402  DO 80 ish = 1, nshape
5403  uplo = uplo0(ish)
5404  diag = diag0(ish)
5405 *
5406  DO 70 ima = 1, nmat
5407  m = m0(ima)
5408  n = n0(ima)
5409  ldasrc = ldas0(ima)
5410  ldadst = ldad0(ima)
5411 *
5412  DO 60 iso = 1, nsrc
5413  testnum = testnum + 1
5414  rsrc = rsrc0(iso)
5415  csrc = csrc0(iso)
5416  IF( rsrc.GE.p0(igr) .OR. csrc.GE.q0(igr) ) THEN
5417  nskip = nskip + 1
5418  GOTO 60
5419  END IF
5420  IF( verb .GT. 1 ) THEN
5421  IF( iam .EQ. 0 ) THEN
5422  WRITE(outnum, 7000)
5423  $ testnum, 'RUNNING',scope, top, uplo, diag,
5424  $ m, n, ldasrc, ldadst, rsrc, csrc,
5425  $ nprow, npcol
5426  END IF
5427  END IF
5428 *
5429  testok = .true.
5430  ipre = 2 * m
5431  ipost = ipre
5432  aptr = ipre + 1
5433 *
5434 * If I am in scope
5435 *
5436  IF( (myrow.EQ.rsrc .AND. scope.EQ.'R') .OR.
5437  $ (mycol.EQ.csrc .AND. scope.EQ.'C') .OR.
5438  $ (scope .EQ. 'A') ) THEN
5439 *
5440 * source process generates matrix and sends it
5441 *
5442  IF( myrow.EQ.rsrc .AND. mycol.EQ.csrc ) THEN
5443  CALL cinitmat(uplo, diag, m, n, mem,
5444  $ ldasrc, ipre, ipost,
5445  $ scheckval, testnum,
5446  $ myrow, mycol )
5447 *
5448  DO 20 j = istart, istop
5449  IF( j.EQ.0 ) GOTO 20
5450  IF( setwhat.NE.0 )
5451  $ CALL blacs_set(context, setwhat, j)
5452  IF( uplo.EQ.'U' .OR. uplo.EQ.'L' ) THEN
5453  CALL ctrbs2d(context, scope, top,
5454  $ uplo, diag, m, n,
5455  $ mem(aptr), ldasrc )
5456  ELSE
5457  CALL cgebs2d(context, scope, top,
5458  $ m, n, mem(aptr),
5459  $ ldasrc )
5460  END IF
5461  20 CONTINUE
5462 *
5463 * Destination processes
5464 *
5465  ELSE IF( ingrid ) THEN
5466  DO 40 j = istart, istop
5467  IF( j.EQ.0 ) GOTO 40
5468  IF( setwhat.NE.0 )
5469  $ CALL blacs_set(context, setwhat, j)
5470 *
5471 * Pad entire matrix area
5472 *
5473  DO 30 k = 1, ipre+ipost+ldadst*n
5474  mem(k) = rcheckval
5475  30 CONTINUE
5476 *
5477 * Receive matrix
5478 *
5479  IF( uplo.EQ.'U' .OR. uplo.EQ.'L' ) THEN
5480  CALL ctrbr2d(context, scope, top,
5481  $ uplo, diag, m, n,
5482  $ mem(aptr), ldadst,
5483  $ rsrc, csrc)
5484  ELSE
5485  CALL cgebr2d(context, scope, top,
5486  $ m, n, mem(aptr),
5487  $ ldadst, rsrc, csrc)
5488  END IF
5489 *
5490 * Check for errors in matrix or padding
5491 *
5492  i = nerr
5493  CALL cchkmat(uplo, diag, m, n,
5494  $ mem(aptr), ldadst, rsrc, csrc,
5495  $ myrow, mycol, testnum, maxerr,
5496  $ nerr, mem(erriptr),
5497  $ mem(errdptr))
5498 *
5499  CALL cchkpad(uplo, diag, m, n, mem,
5500  $ ldadst, rsrc, csrc, myrow,
5501  $ mycol, ipre, ipost, rcheckval,
5502  $ testnum, maxerr, nerr,
5503  $ mem(erriptr), mem(errdptr))
5504  40 CONTINUE
5505  testok = ( i .EQ. nerr )
5506  END IF
5507  END IF
5508 *
5509  IF( verb .GT. 1 ) THEN
5510  i = nerr
5511  CALL cbtcheckin(0, outnum, maxerr, nerr,
5512  $ mem(erriptr), mem(errdptr),
5513  $ tfail)
5514  IF( iam .EQ. 0 ) THEN
5515  testok = ( testok .AND. (i.EQ.nerr) )
5516  IF( testok ) THEN
5517  WRITE(outnum,7000)testnum,'PASSED ',
5518  $ scope, top, uplo, diag, m, n,
5519  $ ldasrc, ldadst, rsrc, csrc,
5520  $ nprow, npcol
5521  ELSE
5522  nfail = nfail + 1
5523  WRITE(outnum,7000)testnum,'FAILED ',
5524  $ scope, top, uplo, diag, m, n,
5525  $ ldasrc, ldadst, rsrc, csrc,
5526  $ nprow, npcol
5527  END IF
5528  END IF
5529 *
5530 * Once we've printed out errors, can re-use buf space
5531 *
5532  nerr = 0
5533  END IF
5534  60 CONTINUE
5535  70 CONTINUE
5536  80 CONTINUE
5537  90 CONTINUE
5538  100 CONTINUE
5539  110 CONTINUE
5540 *
5541  IF( verb .LT. 2 ) THEN
5542  nfail = testnum
5543  CALL cbtcheckin( nfail, outnum, maxerr, nerr, mem(erriptr),
5544  $ mem(errdptr), tfail )
5545  END IF
5546  IF( iam .EQ. 0 ) THEN
5547  IF( verb .GT. 1 ) WRITE(outnum,*) ' '
5548  IF( nfail+nskip .EQ. 0 ) THEN
5549  WRITE(outnum, 8000 ) testnum
5550  ELSE
5551  WRITE(outnum, 9000 ) testnum, testnum-nskip-nfail,
5552  $ nskip, nfail
5553  END IF
5554  END IF
5555 *
5556 * Log whether their were any failures
5557 *
5558  testok = allpass( (nfail.EQ.0) )
5559 *
5560  1000 FORMAT('COMPLEX BSBR TESTS: BEGIN.' )
5561  2000 FORMAT(1x,a7,3x,10i6)
5562  3000 FORMAT(1x,a7,3x,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,
5563  $ 5x,a1,5x,a1)
5564  5000 FORMAT(' TEST# STATUS SCOPE TOP UPLO DIAG M N LDAS ',
5565  $ ' LDAD RSRC CSRC P Q')
5566  6000 FORMAT(' ----- ------- ----- --- ---- ---- ----- ----- ----- ',
5567  $ '----- ---- ---- ---- ----')
5568  7000 FORMAT(i6,1x,a7,5x,a1,3x,a1,2(4x,a1), 4i6, 4i5)
5569  8000 FORMAT('COMPLEX BSBR TESTS: PASSED ALL',
5570  $ i5, ' TESTS.')
5571  9000 FORMAT('COMPLEX BSBR TESTS:',i5,' TESTS;',i5,' PASSED,',
5572  $ i5,' SKIPPED,',i5,' FAILED.')
5573 *
5574  RETURN
5575 *
5576 * End of CBSBRTEST.
5577 *
5578  END
5579 *
5580 *
5581  SUBROUTINE zbsbrtest( OUTNUM, VERB, NSCOPE, SCOPE0, NTOP, TOP0,
5582  $ NSHAPE, UPLO0, DIAG0, NMAT, M0, N0, LDAS0,
5583  $ LDAD0, NSRC, RSRC0, CSRC0, NGRID, CONTEXT0,
5584  $ P0, Q0, TFAIL, MEM, MEMLEN )
5585 *
5586 * -- BLACS tester (version 1.0) --
5587 * University of Tennessee
5588 * December 15, 1994
5589 *
5590 *
5591 * .. Scalar Arguments ..
5592  INTEGER OUTNUM, VERB, NSCOPE, NTOP, NSHAPE, NMAT, NSRC, NGRID
5593  INTEGER MEMLEN
5594 * ..
5595 * .. Array Arguments ..
5596  CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP)
5597  CHARACTER*1 UPLO0(NSHAPE), DIAG0(NSHAPE)
5598  INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT)
5599  INTEGER RSRC0(NSRC), CSRC0(NSRC), CONTEXT0(NGRID)
5600  INTEGER P0(NGRID), Q0(NGRID), TFAIL(*)
5601  DOUBLE COMPLEX MEM(MEMLEN)
5602 * ..
5603 *
5604 * Purpose
5605 * =======
5606 * ZTESTBSBR: Test double complex broadcast
5607 *
5608 * Arguments
5609 * =========
5610 * OUTNUM (input) INTEGER
5611 * The device number to write output to.
5612 *
5613 * VERB (input) INTEGER
5614 * The level of verbosity (how much printing to do).
5615 *
5616 * NSCOPE (input) INTEGER
5617 * The number of scopes to be tested.
5618 *
5619 * SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE)
5620 * Values of the scopes to be tested.
5621 *
5622 * NTOP (input) INTEGER
5623 * The number of topologies to be tested.
5624 *
5625 * TOP0 (input) CHARACTER*1 array of dimension (NTOP)
5626 * Values of the topologies to be tested.
5627 *
5628 * NSHAPE (input) INTEGER
5629 * The number of matrix shapes to be tested.
5630 *
5631 * UPLO0 (input) CHARACTER*1 array of dimension (NSHAPE)
5632 * Values of UPLO to be tested.
5633 *
5634 * DIAG0 (input) CHARACTER*1 array of dimension (NSHAPE)
5635 * Values of DIAG to be tested.
5636 *
5637 * NMAT (input) INTEGER
5638 * The number of matrices to be tested.
5639 *
5640 * M0 (input) INTEGER array of dimension (NMAT)
5641 * Values of M to be tested.
5642 *
5643 * M0 (input) INTEGER array of dimension (NMAT)
5644 * Values of M to be tested.
5645 *
5646 * N0 (input) INTEGER array of dimension (NMAT)
5647 * Values of N to be tested.
5648 *
5649 * LDAS0 (input) INTEGER array of dimension (NMAT)
5650 * Values of LDAS (leading dimension of A on source process)
5651 * to be tested.
5652 *
5653 * LDAD0 (input) INTEGER array of dimension (NMAT)
5654 * Values of LDAD (leading dimension of A on destination
5655 * process) to be tested.
5656 * NSRC (input) INTEGER
5657 * The number of sources to be tested.
5658 *
5659 * RSRC0 (input) INTEGER array of dimension (NDEST)
5660 * Values of RSRC (row coordinate of source) to be tested.
5661 *
5662 * CSRC0 (input) INTEGER array of dimension (NDEST)
5663 * Values of CSRC (column coordinate of source) to be tested.
5664 *
5665 * NGRID (input) INTEGER
5666 * The number of process grids to be tested.
5667 *
5668 * CONTEXT0 (input) INTEGER array of dimension (NGRID)
5669 * The BLACS context handles corresponding to the grids.
5670 *
5671 * P0 (input) INTEGER array of dimension (NGRID)
5672 * Values of P (number of process rows, NPROW).
5673 *
5674 * Q0 (input) INTEGER array of dimension (NGRID)
5675 * Values of Q (number of process columns, NPCOL).
5676 *
5677 * TFAIL (workspace) INTEGER array of dimension (NTESTS)
5678 * If VERB < 2, serves to indicate which tests fail. This
5679 * requires workspace of NTESTS (number of tests performed).
5680 *
5681 * MEM (workspace) DOUBLE COMPLEX array of dimension (MEMLEN)
5682 * Used for all other workspaces, including the matrix A,
5683 * and its pre and post padding.
5684 *
5685 * MEMLEN (input) INTEGER
5686 * The length, in elements, of MEM.
5687 *
5688 * =====================================================================
5689 *
5690 * .. External Functions ..
5691  LOGICAL ALLPASS, LSAME
5692  INTEGER IBTMYPROC, IBTSIZEOF
5693  EXTERNAL ALLPASS, LSAME, IBTMYPROC, IBTSIZEOF
5694 * ..
5695 * .. External Subroutines ..
5696  EXTERNAL BLACS_GRIDINFO
5697  EXTERNAL ZTRBS2D, ZGEBS2D, ZTRBR2D, ZGEBR2D
5698  EXTERNAL ZINITMAT, ZCHKMAT, ZCHKPAD, ZBTCHECKIN
5699 * ..
5700 * .. Local Scalars ..
5701  CHARACTER*1 SCOPE, TOP, UPLO, DIAG
5702  LOGICAL TESTOK, INGRID
5703  INTEGER IAM, I, K, J, IGR, ISH, IMA, ISO, ISC, ITO
5704  INTEGER M, N, NPROW, NPCOL, MYROW, MYCOL, RSRC, CSRC
5705  INTEGER ISTART, ISTOP, IPRE, IPOST, SETWHAT
5706  INTEGER NERR, NSKIP, NFAIL, TESTNUM, CONTEXT, MAXERR, LDASRC
5707  INTEGER LDADST, ERRDPTR, APTR, ERRIPTR, ISIZE, ZSIZE
5708  DOUBLE COMPLEX SCHECKVAL, RCHECKVAL
5709 * ..
5710 * .. Executable Statements ..
5711 *
5712  SCHECKVAL = dcmplx( -0.01d0, -0.01d0 )
5713  rcheckval = dcmplx( -0.02d0, -0.02d0 )
5714 *
5715  iam = ibtmyproc()
5716  isize = ibtsizeof('I')
5717  zsize = ibtsizeof('Z')
5718 *
5719 * Verify file parameters
5720 *
5721  IF( iam .EQ. 0 ) THEN
5722  WRITE(outnum, *) ' '
5723  WRITE(outnum, *) ' '
5724  WRITE(outnum, 1000 )
5725  IF( verb .GT. 0 ) THEN
5726  WRITE(outnum,*) ' '
5727  WRITE(outnum, 2000) 'NSCOPE:', nscope
5728  WRITE(outnum, 3000) ' SCOPE:', ( scope0(i), i = 1, nscope )
5729  WRITE(outnum, 2000) 'NTOP :', ntop
5730  WRITE(outnum, 3000) ' TOP :', ( top0(i), i = 1, ntop )
5731  WRITE(outnum, 2000) 'NSHAPE:', nshape
5732  WRITE(outnum, 3000) ' UPLO :', ( uplo0(i), i = 1, nshape )
5733  WRITE(outnum, 3000) ' DIAG :', ( diag0(i), i = 1, nshape )
5734  WRITE(outnum, 2000) 'NMAT :', nmat
5735  WRITE(outnum, 2000) ' M :', ( m0(i), i = 1, nmat )
5736  WRITE(outnum, 2000) ' N :', ( n0(i), i = 1, nmat )
5737  WRITE(outnum, 2000) ' LDAS :', ( ldas0(i), i = 1, nmat )
5738  WRITE(outnum, 2000) ' LDAD :', ( ldad0(i), i = 1, nmat )
5739  WRITE(outnum, 2000) 'NSRC :', nsrc
5740  WRITE(outnum, 2000) ' RSRC :',( rsrc0(i), i = 1, nsrc )
5741  WRITE(outnum, 2000) ' CSRC :',( csrc0(i), i = 1, nsrc )
5742  WRITE(outnum, 2000) 'NGRIDS:', ngrid
5743  WRITE(outnum, 2000) ' P :', ( p0(i), i = 1, ngrid )
5744  WRITE(outnum, 2000) ' Q :', ( q0(i), i = 1, ngrid )
5745  WRITE(outnum, 2000) 'VERB :', verb
5746  WRITE(outnum,*) ' '
5747  END IF
5748  IF( verb .GT. 1 ) THEN
5749  WRITE(outnum,5000)
5750  WRITE(outnum,6000)
5751  END IF
5752  END IF
5753 *
5754 * Find biggest matrix, so we know where to stick error info
5755 *
5756  i = 0
5757  DO 10 ima = 1, nmat
5758  k = n0(ima) * max0( ldas0(ima), ldad0(ima) ) + 4 * m0(ima)
5759  IF( k .GT. i ) i = k
5760  10 CONTINUE
5761  maxerr = ( zsize * (memlen-i) ) / ( zsize*2 + isize*6 )
5762  IF( maxerr .LT. 1 ) THEN
5763  WRITE(outnum,*) 'ERROR: Not enough memory to run BSBR tests.'
5764  CALL blacs_abort(-1, 1)
5765  END IF
5766  errdptr = i + 1
5767  erriptr = errdptr + maxerr
5768  nerr = 0
5769  testnum = 0
5770  nfail = 0
5771  nskip = 0
5772 *
5773 * Loop over grids of matrix
5774 *
5775  DO 110 igr = 1, ngrid
5776 *
5777  context = context0(igr)
5778  CALL blacs_gridinfo( context, nprow, npcol, myrow, mycol )
5779 *
5780  ingrid = ( nprow .GT. 0 )
5781 *
5782  DO 100 isc = 1, nscope
5783  scope = scope0(isc)
5784  DO 90 ito = 1, ntop
5785  top = top0(ito)
5786 *
5787 * If testing multipath ('M') or general tree ('T'),
5788 * need to loop over calls to BLACS_SET
5789 *
5790  IF( lsame(top, 'M') ) THEN
5791  setwhat = 11
5792  IF( scope .EQ. 'R' ) THEN
5793  istart = -(npcol - 1)
5794  istop = -istart
5795  ELSE IF (scope .EQ. 'C') THEN
5796  istart = -(nprow - 1)
5797  istop = -istart
5798  ELSE
5799  istart = -(nprow*npcol - 1)
5800  istop = -istart
5801  ENDIF
5802  ELSE IF( lsame(top, 'T') ) THEN
5803  setwhat = 12
5804  istart = 1
5805  IF( scope .EQ. 'R' ) THEN
5806  istop = npcol - 1
5807  ELSE IF (scope .EQ. 'C') THEN
5808  istop = nprow - 1
5809  ELSE
5810  istop = nprow*npcol - 1
5811  ENDIF
5812  ELSE
5813  setwhat = 0
5814  istart = 1
5815  istop = 1
5816  ENDIF
5817  DO 80 ish = 1, nshape
5818  uplo = uplo0(ish)
5819  diag = diag0(ish)
5820 *
5821  DO 70 ima = 1, nmat
5822  m = m0(ima)
5823  n = n0(ima)
5824  ldasrc = ldas0(ima)
5825  ldadst = ldad0(ima)
5826 *
5827  DO 60 iso = 1, nsrc
5828  testnum = testnum + 1
5829  rsrc = rsrc0(iso)
5830  csrc = csrc0(iso)
5831  IF( rsrc.GE.p0(igr) .OR. csrc.GE.q0(igr) ) THEN
5832  nskip = nskip + 1
5833  GOTO 60
5834  END IF
5835  IF( verb .GT. 1 ) THEN
5836  IF( iam .EQ. 0 ) THEN
5837  WRITE(outnum, 7000)
5838  $ testnum, 'RUNNING',scope, top, uplo, diag,
5839  $ m, n, ldasrc, ldadst, rsrc, csrc,
5840  $ nprow, npcol
5841  END IF
5842  END IF
5843 *
5844  testok = .true.
5845  ipre = 2 * m
5846  ipost = ipre
5847  aptr = ipre + 1
5848 *
5849 * If I am in scope
5850 *
5851  IF( (myrow.EQ.rsrc .AND. scope.EQ.'R') .OR.
5852  $ (mycol.EQ.csrc .AND. scope.EQ.'C') .OR.
5853  $ (scope .EQ. 'A') ) THEN
5854 *
5855 * source process generates matrix and sends it
5856 *
5857  IF( myrow.EQ.rsrc .AND. mycol.EQ.csrc ) THEN
5858  CALL zinitmat(uplo, diag, m, n, mem,
5859  $ ldasrc, ipre, ipost,
5860  $ scheckval, testnum,
5861  $ myrow, mycol )
5862 *
5863  DO 20 j = istart, istop
5864  IF( j.EQ.0 ) GOTO 20
5865  IF( setwhat.NE.0 )
5866  $ CALL blacs_set(context, setwhat, j)
5867  IF( uplo.EQ.'U' .OR. uplo.EQ.'L' ) THEN
5868  CALL ztrbs2d(context, scope, top,
5869  $ uplo, diag, m, n,
5870  $ mem(aptr), ldasrc )
5871  ELSE
5872  CALL zgebs2d(context, scope, top,
5873  $ m, n, mem(aptr),
5874  $ ldasrc )
5875  END IF
5876  20 CONTINUE
5877 *
5878 * Destination processes
5879 *
5880  ELSE IF( ingrid ) THEN
5881  DO 40 j = istart, istop
5882  IF( j.EQ.0 ) GOTO 40
5883  IF( setwhat.NE.0 )
5884  $ CALL blacs_set(context, setwhat, j)
5885 *
5886 * Pad entire matrix area
5887 *
5888  DO 30 k = 1, ipre+ipost+ldadst*n
5889  mem(k) = rcheckval
5890  30 CONTINUE
5891 *
5892 * Receive matrix
5893 *
5894  IF( uplo.EQ.'U' .OR. uplo.EQ.'L' ) THEN
5895  CALL ztrbr2d(context, scope, top,
5896  $ uplo, diag, m, n,
5897  $ mem(aptr), ldadst,
5898  $ rsrc, csrc)
5899  ELSE
5900  CALL zgebr2d(context, scope, top,
5901  $ m, n, mem(aptr),
5902  $ ldadst, rsrc, csrc)
5903  END IF
5904 *
5905 * Check for errors in matrix or padding
5906 *
5907  i = nerr
5908  CALL zchkmat(uplo, diag, m, n,
5909  $ mem(aptr), ldadst, rsrc, csrc,
5910  $ myrow, mycol, testnum, maxerr,
5911  $ nerr, mem(erriptr),
5912  $ mem(errdptr))
5913 *
5914  CALL zchkpad(uplo, diag, m, n, mem,
5915  $ ldadst, rsrc, csrc, myrow,
5916  $ mycol, ipre, ipost, rcheckval,
5917  $ testnum, maxerr, nerr,
5918  $ mem(erriptr), mem(errdptr))
5919  40 CONTINUE
5920  testok = ( i .EQ. nerr )
5921  END IF
5922  END IF
5923 *
5924  IF( verb .GT. 1 ) THEN
5925  i = nerr
5926  CALL zbtcheckin(0, outnum, maxerr, nerr,
5927  $ mem(erriptr), mem(errdptr),
5928  $ tfail)
5929  IF( iam .EQ. 0 ) THEN
5930  testok = ( testok .AND. (i.EQ.nerr) )
5931  IF( testok ) THEN
5932  WRITE(outnum,7000)testnum,'PASSED ',
5933  $ scope, top, uplo, diag, m, n,
5934  $ ldasrc, ldadst, rsrc, csrc,
5935  $ nprow, npcol
5936  ELSE
5937  nfail = nfail + 1
5938  WRITE(outnum,7000)testnum,'FAILED ',
5939  $ scope, top, uplo, diag, m, n,
5940  $ ldasrc, ldadst, rsrc, csrc,
5941  $ nprow, npcol
5942  END IF
5943  END IF
5944 *
5945 * Once we've printed out errors, can re-use buf space
5946 *
5947  nerr = 0
5948  END IF
5949  60 CONTINUE
5950  70 CONTINUE
5951  80 CONTINUE
5952  90 CONTINUE
5953  100 CONTINUE
5954  110 CONTINUE
5955 *
5956  IF( verb .LT. 2 ) THEN
5957  nfail = testnum
5958  CALL zbtcheckin( nfail, outnum, maxerr, nerr, mem(erriptr),
5959  $ mem(errdptr), tfail )
5960  END IF
5961  IF( iam .EQ. 0 ) THEN
5962  IF( verb .GT. 1 ) WRITE(outnum,*) ' '
5963  IF( nfail+nskip .EQ. 0 ) THEN
5964  WRITE(outnum, 8000 ) testnum
5965  ELSE
5966  WRITE(outnum, 9000 ) testnum, testnum-nskip-nfail,
5967  $ nskip, nfail
5968  END IF
5969  END IF
5970 *
5971 * Log whether their were any failures
5972 *
5973  testok = allpass( (nfail.EQ.0) )
5974 *
5975  1000 FORMAT('DOUBLE COMPLEX BSBR TESTS: BEGIN.' )
5976  2000 FORMAT(1x,a7,3x,10i6)
5977  3000 FORMAT(1x,a7,3x,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,
5978  $ 5x,a1,5x,a1)
5979  5000 FORMAT(' TEST# STATUS SCOPE TOP UPLO DIAG M N LDAS ',
5980  $ ' LDAD RSRC CSRC P Q')
5981  6000 FORMAT(' ----- ------- ----- --- ---- ---- ----- ----- ----- ',
5982  $ '----- ---- ---- ---- ----')
5983  7000 FORMAT(i6,1x,a7,5x,a1,3x,a1,2(4x,a1), 4i6, 4i5)
5984  8000 FORMAT('DOUBLE COMPLEX BSBR TESTS: PASSED ALL',
5985  $ i5, ' TESTS.')
5986  9000 FORMAT('DOUBLE COMPLEX BSBR TESTS:',i5,' TESTS;',i5,' PASSED,',
5987  $ i5,' SKIPPED,',i5,' FAILED.')
5988 *
5989  RETURN
5990 *
5991 * End of ZBSBRTEST.
5992 *
5993  END
5994 *
5995 *
5996  SUBROUTINE rdcomb( MEMUSED, MEM, MEMLEN, CMEMUSED, CMEM, CMEMLEN,
5997  $ OUTNUM )
5998 *
5999 * -- BLACS tester (version 1.0) --
6000 * University of Tennessee
6001 * December 15, 1994
6002 *
6003 *
6004 * .. Scalar Arguments ..
6005  INTEGER MEMUSED, MEMLEN, CMEMUSED, CMEMLEN, OUTNUM
6006 * ..
6007 * .. Array Arguments ..
6008  CHARACTER*1 CMEM(CMEMLEN)
6009  INTEGER MEM(MEMLEN)
6010 * ..
6011 *
6012 * Purpose
6013 * =======
6014 * RDCOMB: Read and process the input file COMB.dat.
6015 *
6016 * Arguments
6017 * =========
6018 * MEMUSED (output) INTEGER
6019 * Number of elements in MEM that this subroutine ends up using.
6020 *
6021 * MEM (output) INTEGER array of dimension memlen
6022 * On output, holds information read in from sdrv.dat.
6023 *
6024 * MEMLEN (input) INTEGER
6025 * Number of elements of MEM that this subroutine
6026 * may safely write into.
6027 *
6028 * CMEMUSED (output) INTEGER
6029 * Number of elements in CMEM that this subroutine ends up using.
6030 *
6031 * CMEM (output) CHARACTER*1 array of dimension cmemlen
6032 * On output, holds the values for UPLO and DIAG.
6033 *
6034 * CMEMLEN (input) INTEGER
6035 * Number of elements of CMEM that this subroutine
6036 * may safely write into.
6037 *
6038 * OUTNUM (input) INTEGER
6039 * Unit number of the output file.
6040 *
6041 * =================================================================
6042 *
6043 * .. Parameters ..
6044  INTEGER SDIN
6045  PARAMETER( SDIN = 12 )
6046 * ..
6047 * .. External Functions ..
6048  logical lsame
6049  EXTERNAL lsame
6050 * ..
6051 * .. Local Scalars ..
6052  INTEGER TOPSREPEAT, TOPSCOHRNT, NOPS, NSCOPE, NTOP, NMAT, NDEST
6053  INTEGER NGRID, I, J, OPPTR, SCOPEPTR, TOPPTR, MPTR, NPTR
6054  INTEGER LDSPTR, LDDPTR, LDIPTR, RDESTPTR, CDESTPTR, PPTR, QPTR
6055 * ..
6056 * .. Executable Statements
6057 *
6058 * Open and read the file comb.dat. The expected format is
6059 * below.
6060 *
6061 *------
6062 *integer Number of operations
6063 *array of CHAR*1's OPs: '+', '>', '<'
6064 *integer Number of scopes
6065 *array of CHAR*1's Values for Scopes
6066 *HAR*1 Repeatability flag ('R', 'N', 'B')
6067 *HAR*1 Coherency flag ('C', 'N', 'B')
6068 *integer Number of topologies
6069 *array of CHAR*1's Values for TOP
6070 *integer number of nmat
6071 *array of integers M: number of rows in matrix
6072 *array of integers N: number of columns in matrix
6073 *integer LDA: leading dimension on source proc
6074 *integer LDA: leading dimension on dest proc
6075 *integer number of source/dest pairs
6076 *array of integers RDEST: process row of msg. dest.
6077 *array of integers CDEST: process column of msg. dest.
6078 *integer Number of grids
6079 *array of integers NPROW: number of rows in process grid
6080 *array of integers NPCOL: number of col's in proc. grid
6081 *------
6082 * note: the text descriptions as shown above are present in
6083 * the sample comb.dat included with this distribution,
6084 * but are not required.
6085 *
6086 * Read input file
6087 *
6088  memused = 1
6089  cmemused = 1
6090  OPEN(unit = sdin, file = 'comb.dat', status = 'OLD')
6091 *
6092 * Get what operations to test (+, >, <)
6093 *
6094  READ(sdin, *) nops
6095  opptr = cmemused
6096  cmemused = opptr + nops
6097  IF ( cmemused .GT. cmemlen ) THEN
6098  WRITE(outnum, 1000) cmemlen, nops, 'OPERATIONS.'
6099  IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE(outnum)
6100  stop
6101  ELSE IF( nops .LT. 1 ) THEN
6102  WRITE(outnum, 2000) 'OPERATIONS.'
6103  IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE(outnum)
6104  stop
6105  END IF
6106 *
6107  READ(sdin, *) ( cmem(opptr+i), i = 0, nops-1 )
6108  DO 10 i = 0, nops-1
6109  IF( (cmem(opptr+i).NE.'+') .AND. (cmem(opptr+i).NE.'>') .AND.
6110  $ (cmem(opptr+i).NE.'<') ) THEN
6111  WRITE(outnum,5000) cmem(opptr+i)
6112  IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE(outnum)
6113  stop
6114  END IF
6115  10 CONTINUE
6116 *
6117 * Read in scopes and topologies
6118 *
6119  READ(sdin, *) nscope
6120  scopeptr = cmemused
6121  cmemused = scopeptr + nscope
6122  IF ( cmemused .GT. cmemlen ) THEN
6123  WRITE(outnum, 1000) cmemlen, nscope, 'SCOPES.'
6124  IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE(outnum)
6125  stop
6126  ELSE IF( nscope .LT. 1 ) THEN
6127  WRITE(outnum, 2000) 'SCOPE.'
6128  IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE(outnum)
6129  stop
6130  END IF
6131 *
6132  READ(sdin, *) ( cmem(scopeptr+i), i = 0, nscope-1 )
6133  DO 20 i = 0, nscope-1
6134  IF( lsame(cmem(scopeptr+i), 'R') ) THEN
6135  cmem(scopeptr+i) = 'R'
6136  ELSE IF( lsame(cmem(scopeptr+i), 'C') ) THEN
6137  cmem(scopeptr+i) = 'C'
6138  ELSE IF( lsame(cmem(scopeptr+i), 'A') ) THEN
6139  cmem(scopeptr+i) = 'A'
6140  ELSE
6141  WRITE(outnum, 3000) 'SCOPE', cmem(scopeptr+i)
6142  IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE(outnum)
6143  stop
6144  END IF
6145  20 CONTINUE
6146 *
6147  READ(sdin, *) topsrepeat
6148  READ(sdin, *) topscohrnt
6149 *
6150  READ(sdin, *) ntop
6151  topptr = cmemused
6152  cmemused = topptr + ntop
6153  IF ( cmemused .GT. cmemlen ) THEN
6154  WRITE(outnum, 1000) cmemlen, ntop, 'TOPOLOGIES.'
6155  IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE(outnum)
6156  stop
6157  ELSE IF( ntop .LT. 1 ) THEN
6158  WRITE(outnum, 2000) 'TOPOLOGY.'
6159  IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE(outnum)
6160  stop
6161  END IF
6162  READ(sdin, *) ( cmem(topptr+i), i = 0, ntop-1 )
6163 *
6164 *
6165 * Read in number of matrices, and values for M, N, LDASRC, and LDADEST
6166 *
6167  READ(sdin, *) nmat
6168  mptr = memused
6169  nptr = mptr + nmat
6170  ldsptr = nptr + nmat
6171  lddptr = ldsptr + nmat
6172  ldiptr = lddptr + nmat
6173  memused = ldiptr + nmat
6174  IF( memused .GT. memlen ) THEN
6175  WRITE(outnum, 1000) memlen, nmat, 'MATRICES.'
6176  IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE(outnum)
6177  stop
6178  ELSE IF( nmat .LT. 1 ) THEN
6179  WRITE(outnum, 2000) 'MATRIX.'
6180  IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE(outnum)
6181  stop
6182  END IF
6183  READ(sdin, *) ( mem( mptr+i ), i = 0, nmat-1 )
6184  READ(sdin, *) ( mem( nptr+i ), i = 0, nmat-1 )
6185  READ(sdin, *) ( mem( ldsptr+i ), i = 0, nmat-1 )
6186  READ(sdin, *) ( mem( lddptr+i ), i = 0, nmat-1 )
6187  READ(sdin, *) ( mem( ldiptr+i ), i = 0, nmat-1 )
6188 *
6189 * Make sure matrix values are legal
6190 *
6191  CALL chkmatdat( outnum, 'COMB.dat', .true., nmat, mem(mptr),
6192  $ mem(nptr), mem(ldsptr), mem(lddptr), mem(ldiptr) )
6193 *
6194 * Read in number of dest pairs, and values of dest
6195 *
6196  READ(sdin, *) ndest
6197  rdestptr = memused
6198  cdestptr = rdestptr + ndest
6199  memused = cdestptr + ndest
6200  IF( memused .GT. memlen ) THEN
6201  WRITE(outnum, 1000) memlen, nmat, 'DEST.'
6202  IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE(outnum)
6203  stop
6204  ELSE IF( ndest .LT. 1 ) THEN
6205  WRITE(outnum, 2000) 'DEST.'
6206  IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE(outnum)
6207  stop
6208  END IF
6209  READ(sdin, *) ( mem(rdestptr+i), i = 0, ndest-1 )
6210  READ(sdin, *) ( mem(cdestptr+i), i = 0, ndest-1 )
6211 *
6212 * Read in number of grids pairs, and values of P (process rows) and
6213 * Q (process columns)
6214 *
6215  READ(sdin, *) ngrid
6216  pptr = memused
6217  qptr = pptr + ngrid
6218  memused = qptr + ngrid
6219  IF( memused .GT. memlen ) THEN
6220  WRITE(outnum, 1000) memlen, ngrid, 'PROCESS GRIDS.'
6221  IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE(outnum)
6222  stop
6223  ELSE IF( ngrid .LT. 1 ) THEN
6224  WRITE(outnum, 2000) 'PROCESS GRID'
6225  IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE( outnum )
6226  stop
6227  END IF
6228 *
6229  READ(sdin, *) ( mem(pptr+i), i = 0, ngrid-1 )
6230  READ(sdin, *) ( mem(qptr+i), i = 0, ngrid-1 )
6231  IF( sdin .NE. 6 .AND. sdin .NE. 0 ) CLOSE( sdin )
6232 *
6233 * Fatal error if we've got an illegal grid
6234 *
6235  DO 70 j = 0, ngrid-1
6236  IF( mem(pptr+j).LT.1 .OR. mem(qptr+j).LT.1 ) THEN
6237  WRITE(outnum, 4000) mem(pptr+j), mem(qptr+j)
6238  IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE(outnum)
6239  stop
6240  END IF
6241  70 CONTINUE
6242 *
6243 * Prepare output variables
6244 *
6245  mem(memused) = nops
6246  mem(memused+1) = nscope
6247  mem(memused+2) = topsrepeat
6248  mem(memused+3) = topscohrnt
6249  mem(memused+4) = ntop
6250  mem(memused+5) = nmat
6251  mem(memused+6) = ndest
6252  mem(memused+7) = ngrid
6253  memused = memused + 7
6254  cmemused = cmemused - 1
6255 *
6256  1000 FORMAT('Mem too short (',i4,') to handle',i4,' ',a20)
6257  2000 FORMAT('Must have at least one ',a20)
6258  3000 FORMAT('UNRECOGNIZABLE ',a5,' ''', a1, '''.')
6259  4000 FORMAT('Illegal process grid: {',i3,',',i3,'}.')
6260  5000 FORMAT('Illegal OP value ''',a1,''':, expected ''+'' (SUM),',
6261  $ ' ''>'' (MAX), or ''<'' (MIN).')
6262 *
6263  RETURN
6264 *
6265 * End of RDCOMB.
6266 *
6267  END
6268 *
6269 *
6270  SUBROUTINE ibtcheckin( NFTESTS, OUTNUM, MAXERR, NERR, IERR,
6271  $ IVAL, TFAILED )
6272  INTEGER NFTESTS, OUTNUM, MAXERR, NERR
6273  INTEGER IERR(*), TFAILED(*)
6274  INTEGER IVAL(*)
6275 *
6276 * Purpose
6277 * =======
6278 * IBTCHECKIN: Process 0 receives error report from all processes.
6279 *
6280 * Arguments
6281 * =========
6282 * NFTESTS (input/output) INTEGER
6283 * if NFTESTS is <= 0 upon entry, NFTESTS is not written to.
6284 * Otherwise, on entry it specifies the total number of tests
6285 * run, and on exit it is the number of tests which failed.
6286 *
6287 * OUTNUM (input) INTEGER
6288 * Device number for output.
6289 *
6290 * MAXERR (input) INTEGER
6291 * Max number of errors that can be stored in ERRIBUFF or
6292 * ERRIBUFF
6293 *
6294 * NERR (output) INTEGER
6295 * The number of errors that have been found.
6296 *
6297 * ERRIBUF (output) INTEGER array, dimension (6,MAXERRS)
6298 * Buffer in which to store integer error information. It will
6299 * be built up in the following format for the call to TSEND.
6300 * All integer information is recorded in the following 6-tuple
6301 * {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured:
6302 * SRC = RSRC * NPROCS + CSRC
6303 * DEST = RDEST * NPROCS + CDEST
6304 * WHAT
6305 * = 1 : Error in pre-padding
6306 * = 2 : Error in post-padding
6307 * = 3 : Error in LDA-M gap
6308 * = 4 : Error in complementory triangle
6309 * ELSE: Error in matrix
6310 * If there are more errors than can fit in the error buffer,
6311 * the error number will indicate the actual number of errors
6312 * found, but the buffer will be truncated to the maximum
6313 * number of errors which can fit.
6314 *
6315 * ERRDBUF (output) @(doctype) array, dimension (2, MAXERRS)
6316 * Buffer in which to store error data information.
6317 * {Incorrect, Predicted}
6318 *
6319 * TFAILED (workspace) INTEGER array, dimension NFTESTS
6320 * Workspace used to keep track of which tests failed.
6321 * If input of NFTESTS < 1, this array not accessed.
6322 *
6323 * ===================================================================
6324 *
6325 * .. External Functions ..
6326  INTEGER IBTMYPROC, IBTNPROCS, IBTMSGID
6327  EXTERNAL IBTMYPROC, IBTNPROCS, IBTMSGID
6328 * ..
6329 * .. Local Scalars ..
6330  LOGICAL COUNTING
6331  INTEGER K, NERR2, IAM, NPROCS, NTESTS
6332 *
6333 * Proc 0 collects error info from everyone
6334 *
6335  IAM = ibtmyproc()
6336  nprocs = ibtnprocs()
6337 *
6338  IF( iam .EQ. 0 ) THEN
6339 *
6340 * If we are finding out how many failed tests there are, initialize
6341 * the total number of tests (NTESTS), and zero the test failed array
6342 *
6343  counting = nftests .GT. 0
6344  IF( counting ) THEN
6345  ntests = nftests
6346  DO 10 k = 1, ntests
6347  tfailed(k) = 0
6348  10 CONTINUE
6349  END IF
6350 *
6351  CALL iprinterrs(outnum, maxerr, nerr, ierr, ival, counting,
6352  $ tfailed)
6353 *
6354  DO 20 k = 1, nprocs-1
6355  CALL btsend(3, 0, k, k, ibtmsgid()+50)
6356  CALL btrecv(3, 1, nerr2, k, ibtmsgid()+50)
6357  IF( nerr2 .GT. 0 ) THEN
6358  nerr = nerr + nerr2
6359  CALL btrecv(3, nerr2*6, ierr, k, ibtmsgid()+51)
6360  CALL btrecv(3, nerr2*2, ival, k, ibtmsgid()+51)
6361  CALL iprinterrs(outnum, maxerr, nerr2, ierr, ival,
6362  $ counting, tfailed)
6363  END IF
6364  20 CONTINUE
6365 *
6366 * Count up number of tests that failed
6367 *
6368  IF( counting ) THEN
6369  nftests = 0
6370  DO 30 k = 1, ntests
6371  nftests = nftests + tfailed(k)
6372  30 CONTINUE
6373  END IF
6374 *
6375 * Send my error info to proc 0
6376 *
6377  ELSE
6378  CALL btrecv(3, 0, k, 0, ibtmsgid()+50)
6379  CALL btsend(3, 1, nerr, 0, ibtmsgid()+50)
6380  IF( nerr .GT. 0 ) THEN
6381  CALL btsend(3, nerr*6, ierr, 0, ibtmsgid()+51)
6382  CALL btsend(3, nerr*2, ival, 0, ibtmsgid()+51)
6383  END IF
6384  ENDIF
6385 *
6386  RETURN
6387 *
6388 * End of IBTCHECKIN
6389 *
6390  END
6391 *
6392  SUBROUTINE iinitmat(UPLO, DIAG, M, N, MEM, LDA, IPRE, IPOST,
6393  $ CHECKVAL, TESTNUM, MYROW, MYCOL)
6394  CHARACTER*1 UPLO, DIAG
6395  INTEGER M, N, LDA, IPRE, IPOST, TESTNUM, MYROW, MYCOL
6396  INTEGER CHECKVAL
6397  INTEGER MEM(*)
6398 *
6399 * .. External Subroutines ..
6400  EXTERNAL igenmat, ipadmat
6401 * ..
6402 * .. Executable Statements ..
6403 *
6404  CALL igenmat( m, n, mem(ipre+1), lda, testnum, myrow, mycol )
6405  CALL ipadmat( uplo, diag, m, n, mem, lda, ipre, ipost, checkval )
6406 *
6407  RETURN
6408  END
6409 *
6410  SUBROUTINE igenmat( M, N, A, LDA, TESTNUM, MYROW, MYCOL )
6411 *
6412 * -- BLACS tester (version 1.0) --
6413 * University of Tennessee
6414 * December 15, 1994
6415 *
6416 *
6417 * .. Scalar Arguments ..
6418  INTEGER M, N, LDA, TESTNUM, MYROW, MYCOL
6419 * ..
6420 * .. Array Arguments ..
6421  INTEGER A(LDA,N)
6422 * ..
6423 *
6424 * Purpose
6425 * =======
6426 * IGENMAT: Generates an M-by-N matrix filled with random elements.
6427 *
6428 * Arguments
6429 * =========
6430 * M (input) INTEGER
6431 * The number of rows of the matrix A. M >= 0.
6432 *
6433 * N (input) INTEGER
6434 * The number of columns of the matrix A. N >= 0.
6435 *
6436 * A (output) @up@(doctype) array, dimension (LDA,N)
6437 * The m by n matrix A. Fortran77 (column-major) storage
6438 * assumed.
6439 *
6440 * LDA (input) INTEGER
6441 * The leading dimension of the array A. LDA >= max(1, M).
6442 *
6443 * TESTNUM (input) INTEGER
6444 * Unique number for this test case, used as a basis for
6445 * the random seeds.
6446 *
6447 * ====================================================================
6448 *
6449 * .. External Functions ..
6450  INTEGER IBTNPROCS
6451  INTEGER IBTRAN
6452  EXTERNAL ibtran, ibtnprocs
6453 * ..
6454 * .. Local Scalars ..
6455  INTEGER I, J, NPROCS, SRC
6456 * ..
6457 * .. Local Arrays ..
6458  INTEGER ISEED(4)
6459 * ..
6460 * .. Executable Statements ..
6461 *
6462 * ISEED's four values must be positive integers less than 4096,
6463 * fourth one has to be odd. (see _LARND). Use some goofy
6464 * functions to come up with seed values which together should
6465 * be unique.
6466 *
6467  nprocs = ibtnprocs()
6468  src = myrow * nprocs + mycol
6469  iseed(1) = mod( 1002 + testnum*5 + src*3, 4096 )
6470  iseed(2) = mod( 2027 + testnum*7 + src, 4096 )
6471  iseed(3) = mod( 1234 + testnum + src*3, 4096 )
6472  iseed(4) = mod( 4311 + testnum*10 + src*2, 4096 )
6473 *
6474  DO 10 j = 1, n
6475  DO 10 i = 1, m
6476  a(i, j) = ibtran( iseed )
6477  10 CONTINUE
6478 *
6479  RETURN
6480 *
6481 * End of IGENMAT.
6482 *
6483  END
6484 *
6485  INTEGER FUNCTION ibtran(ISEED)
6486  INTEGER iseed(*)
6487 *
6488 * .. External Functions ..
6489  DOUBLE PRECISION dlarnd
6490  EXTERNAL dlarnd
6491 * ..
6492 * .. Local Scalars ..
6493  DOUBLE PRECISION dval
6494 * ..
6495 * .. Executable Statements ..
6496 *
6497  dval = 1.0d6 * dlarnd(2, iseed)
6498  ibtran = int(dval)
6499 *
6500  RETURN
6501 *
6502 * End of Ibtran
6503 *
6504  END
6505 *
6506  SUBROUTINE ipadmat( UPLO, DIAG, M, N, MEM, LDA, IPRE, IPOST,
6507  $ CHECKVAL )
6508 *
6509 * -- BLACS tester (version 1.0) --
6510 * University of Tennessee
6511 * December 15, 1994
6512 *
6513 * .. Scalar Arguments ..
6514  CHARACTER*1 UPLO, DIAG
6515  INTEGER M, N, LDA, IPRE, IPOST
6516  INTEGER CHECKVAL
6517 * ..
6518 * .. Array Arguments ..
6519  INTEGER MEM( * )
6520 * ..
6521 *
6522 * Purpose
6523 * =======
6524 *
6525 * IPADMAT: Pad Matrix.
6526 * This routines surrounds a matrix with a guardzone initialized to the
6527 * value CHECKVAL. There are three distinct guardzones:
6528 * - A contiguous zone of size IPRE immediately before the start
6529 * of the matrix.
6530 * - A contiguous zone of size IPOST immedately after the end of the
6531 * matrix.
6532 * - Interstitial zones within each column of the matrix, in the
6533 * elements A( M+1:LDA, J ).
6534 *
6535 * Arguments
6536 * =========
6537 * UPLO (input) CHARACTER*1
6538 * Is the matrix A 'U'pper or 'L'ower trapezoidal, or 'G'eneral
6539 * rectangular?
6540 *
6541 * DIAG (input) CHARACTER*1
6542 * For trapezoidal matrices, is the main diagonal included
6543 * ('N') or not ('U')?
6544 *
6545 * M (input) INTEGER
6546 * The number of rows of the matrix A. M >= 0.
6547 *
6548 * N (input) INTEGER
6549 * The number of columns of the matrix A. N >= 0.
6550 *
6551 * MEM (output) integer array, dimension (IPRE+IPOST+LDA*N)
6552 * The address IPRE elements ahead of the matrix A you want to
6553 * pad, which is then of dimension (LDA,N).
6554 *
6555 * IPRE (input) INTEGER
6556 * The size of the guard zone ahead of the matrix A.
6557 *
6558 * IPOST (input) INTEGER
6559 * The size of the guard zone behind the matrix A.
6560 *
6561 * CHECKVAL (input) integer
6562 * The value to insert into the guard zones.
6563 *
6564 * ====================================================================
6565 *
6566 * .. Local Scalars ..
6567  INTEGER I, J, K
6568 * ..
6569 * .. Executable Statements ..
6570 *
6571 * Put check buffer in front of A
6572 *
6573  IF( ipre .GT. 0 ) THEN
6574  DO 10 i = 1, ipre
6575  mem( i ) = checkval
6576  10 CONTINUE
6577  END IF
6578 *
6579 * Put check buffer in back of A
6580 *
6581  IF( ipost .GT. 0 ) THEN
6582  j = ipre + lda*n + 1
6583  DO 20 i = j, j+ipost-1
6584  mem( i ) = checkval
6585  20 CONTINUE
6586  END IF
6587 *
6588 * Put check buffer in all (LDA-M) gaps
6589 *
6590  IF( lda .GT. m ) THEN
6591  k = ipre + m + 1
6592  DO 40 j = 1, n
6593  DO 30 i = k, k+lda-m-1
6594  mem( i ) = checkval
6595  30 CONTINUE
6596  k = k + lda
6597  40 CONTINUE
6598  END IF
6599 *
6600 * If the matrix is upper or lower trapezoidal, calculate the
6601 * additional triangular area which needs to be padded, Each
6602 * element referred to is in the Ith row and the Jth column.
6603 *
6604  IF( uplo .EQ. 'U' ) THEN
6605  IF( m .LE. n ) THEN
6606  IF( diag .EQ. 'U' ) THEN
6607  DO 41 i = 1, m
6608  DO 42 j = 1, i
6609  k = ipre + i + (j-1)*lda
6610  mem( k ) = checkval
6611  42 CONTINUE
6612  41 CONTINUE
6613  ELSE
6614  DO 43 i = 2, m
6615  DO 44 j = 1, i-1
6616  k = ipre + i + (j-1)*lda
6617  mem( k ) = checkval
6618  44 CONTINUE
6619  43 CONTINUE
6620  END IF
6621  ELSE
6622  IF( diag .EQ. 'U' ) THEN
6623  DO 45 i = m-n+1, m
6624  DO 46 j = 1, i-(m-n)
6625  k = ipre + i + (j-1)*lda
6626  mem( k ) = checkval
6627  46 CONTINUE
6628  45 CONTINUE
6629  ELSE
6630  DO 47 i = m-n+2, m
6631  DO 48 j = 1, i-(m-n)-1
6632  k = ipre + i + (j-1)*lda
6633  mem( k ) = checkval
6634  48 CONTINUE
6635  47 CONTINUE
6636  END IF
6637  END IF
6638  ELSE IF( uplo .EQ. 'L' ) THEN
6639  IF( m .LE. n ) THEN
6640  IF( diag .EQ. 'U' ) THEN
6641  DO 49 i = 1, m
6642  DO 50 j = n-m+i, n
6643  k = ipre + i + (j-1)*lda
6644  mem( k ) = checkval
6645  50 CONTINUE
6646  49 CONTINUE
6647  ELSE
6648  DO 51 i = 1, m-1
6649  DO 52 j = n-m+i+1, n
6650  k = ipre + i + (j-1)*lda
6651  mem( k ) = checkval
6652  52 CONTINUE
6653  51 CONTINUE
6654  END IF
6655  ELSE
6656  IF( uplo .EQ. 'U' ) THEN
6657  DO 53 i = 1, n
6658  DO 54 j = i, n
6659  k = ipre + i + (j-1)*lda
6660  mem( k ) = checkval
6661  54 CONTINUE
6662  53 CONTINUE
6663  ELSE
6664  DO 55 i = 1, n-1
6665  DO 56 j = i+1, n
6666  k = ipre + i + (j-1)*lda
6667  mem( k ) = checkval
6668  56 CONTINUE
6669  55 CONTINUE
6670  END IF
6671  END IF
6672  END IF
6673 *
6674 * End of IPADMAT.
6675 *
6676  RETURN
6677  END
6678 *
6679  SUBROUTINE ichkpad( UPLO, DIAG, M, N, MEM, LDA, RSRC, CSRC,
6680  $ MYROW, MYCOL, IPRE, IPOST, CHECKVAL,
6681  $ TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF )
6682 *
6683 * -- BLACS tester (version 1.0) --
6684 * University of Tennessee
6685 * December 15, 1994
6686 *
6687 *
6688 * .. Scalar Arguments ..
6689  CHARACTER*1 UPLO, DIAG
6690  INTEGER M, N, LDA, RSRC, CSRC, MYROW, MYCOL, IPRE, IPOST
6691  INTEGER TESTNUM, MAXERR, NERR
6692  INTEGER CHECKVAL
6693 * ..
6694 * .. Array Arguments ..
6695  INTEGER ERRIBUF(6, MAXERR)
6696  INTEGER MEM(*), ERRDBUF(2, MAXERR)
6697 * ..
6698 *
6699 * Purpose
6700 * =======
6701 * ICHKPAD: Check padding put in by PADMAT.
6702 * Checks that padding around target matrix has not been overwritten
6703 * by the previous point-to-point or broadcast send.
6704 *
6705 * Arguments
6706 * =========
6707 * UPLO (input) CHARACTER*1
6708 * Is the matrix A 'U'pper or 'L'ower trapezoidal, or 'G'eneral
6709 * rectangular?
6710 *
6711 * DIAG (input) CHARACTER*1
6712 * For trapezoidal matrices, is the main diagonal included
6713 * ('N') or not ('U')?
6714 *
6715 * M (input) INTEGER
6716 * The number of rows of the matrix A. M >= 0.
6717 *
6718 * N (input) INTEGER
6719 * The number of columns of the matrix A. N >= 0.
6720 *
6721 * MEM (input) integer array, dimension(IPRE+IPOST+LDA*N).
6722 * Memory location IPRE elements in front of the matrix A.
6723 *
6724 * LDA (input) INTEGER
6725 * The leading dimension of the array A. LDA >= max(1, M).
6726 *
6727 * RSRC (input) INTEGER
6728 * The process row of the source of the matrix.
6729 *
6730 * CSRC (input) INTEGER
6731 * The process column of the source of the matrix.
6732 *
6733 * MYROW (input) INTEGER
6734 * Row of this process in the process grid.
6735 *
6736 * MYCOL (input) INTEGER
6737 * Column of this process in the process grid.
6738 *
6739 * IPRE (input) INTEGER
6740 * The size of the guard zone before the start of A.
6741 *
6742 * IPOST (input) INTEGER
6743 * The size of guard zone after A.
6744 *
6745 * CHECKVAL (input) integer
6746 * The value to pad matrix with.
6747 *
6748 * TESTNUM (input) INTEGER
6749 * The number of the test being checked.
6750 *
6751 * MAXERR (input) INTEGER
6752 * Max number of errors that can be stored in ERRIBUFF or
6753 * ERRIBUFF
6754 *
6755 * NERR (output) INTEGER
6756 * The number of errors that have been found.
6757 *
6758 * ERRIBUF (output) INTEGER array, dimension (6,MAXERRS)
6759 * Buffer in which to store integer error information. It will
6760 * be built up in the following format for the call to TSEND.
6761 * All integer information is recorded in the following 6-tuple
6762 * {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured:
6763 * SRC = RSRC * NPROCS + CSRC
6764 * DEST = RDEST * NPROCS + CDEST
6765 * WHAT
6766 * = 1 : Error in pre-padding
6767 * = 2 : Error in post-padding
6768 * = 3 : Error in LDA-M gap
6769 * = 4 : Error in complementory triangle
6770 * ELSE: Error in matrix
6771 * If there are more errors than can fit in the error buffer,
6772 * the error number will indicate the actual number of errors
6773 * found, but the buffer will be truncated to the maximum
6774 * number of errors which can fit.
6775 *
6776 * ERRDBUF (output) @(doctype) array, dimension (2, MAXERRS)
6777 * Buffer in which to store error data information.
6778 * {Incorrect, Predicted}
6779 *
6780 * ===================================================================
6781 *
6782 * .. Parameters ..
6783  INTEGER ERR_PRE, ERR_POST, ERR_GAP, ERR_TRI, ERR_MAT
6784  PARAMETER( ERR_PRE = 1, err_post = 2, err_gap = 3, err_tri = 4 )
6785  parameter( err_mat = 5 )
6786 * ..
6787 * .. External Functions ..
6788  INTEGER IBTNPROCS
6789  EXTERNAL IBTNPROCS
6790 * ..
6791 * .. Local Scalars ..
6792  LOGICAL ISTRAP
6793  INTEGER I, J, K, IRST, IRND, ICST, ICND, SRC, DEST
6794  INTEGER NPROCS
6795 * ..
6796 * .. Executable Statements ..
6797 *
6798  NPROCS = ibtnprocs()
6799  src = rsrc * nprocs + csrc
6800  dest = myrow * nprocs + mycol
6801 *
6802 * Check buffer in front of A
6803 *
6804  IF( ipre .GT. 0 ) THEN
6805  DO 10 i = 1, ipre
6806  IF( mem(i) .NE. checkval ) THEN
6807  nerr = nerr + 1
6808  IF( nerr .LE. maxerr ) THEN
6809  erribuf(1, nerr) = testnum
6810  erribuf(2, nerr) = src
6811  erribuf(3, nerr) = dest
6812  erribuf(4, nerr) = i
6813  erribuf(5, nerr) = ipre - i + 1
6814  erribuf(6, nerr) = err_pre
6815  errdbuf(1, nerr) = mem(i)
6816  errdbuf(2, nerr) = checkval
6817  END IF
6818  END IF
6819  10 CONTINUE
6820  END IF
6821 *
6822 * Check buffer behind A
6823 *
6824  IF( ipost .GT. 0 ) THEN
6825  j = ipre + lda*n + 1
6826  DO 20 i = j, j+ipost-1
6827  IF( mem(i) .NE. checkval ) THEN
6828  nerr = nerr + 1
6829  IF( nerr .LE. maxerr ) THEN
6830  erribuf(1, nerr) = testnum
6831  erribuf(2, nerr) = src
6832  erribuf(3, nerr) = dest
6833  erribuf(4, nerr) = i - j + 1
6834  erribuf(5, nerr) = j
6835  erribuf(6, nerr) = err_post
6836  errdbuf(1, nerr) = mem(i)
6837  errdbuf(2, nerr) = checkval
6838  END IF
6839  END IF
6840  20 CONTINUE
6841  END IF
6842 *
6843 * Check all (LDA-M) gaps
6844 *
6845  IF( lda .GT. m ) THEN
6846  DO 40 j = 1, n
6847  DO 30 i = m+1, lda
6848  k = ipre + (j-1)*lda + i
6849  IF( mem(k) .NE. checkval) THEN
6850  nerr = nerr + 1
6851  IF( nerr .LE. maxerr ) THEN
6852  erribuf(1, nerr) = testnum
6853  erribuf(2, nerr) = src
6854  erribuf(3, nerr) = dest
6855  erribuf(4, nerr) = i
6856  erribuf(5, nerr) = j
6857  erribuf(6, nerr) = err_gap
6858  errdbuf(1, nerr) = mem(k)
6859  errdbuf(2, nerr) = checkval
6860  END IF
6861  END IF
6862  30 CONTINUE
6863  40 CONTINUE
6864  END IF
6865 *
6866 * Determine limits of trapezoidal matrix
6867 *
6868  istrap = .false.
6869  IF( uplo .EQ. 'U' ) THEN
6870  istrap = .true.
6871  IF( m .LE. n ) THEN
6872  irst = 2
6873  irnd = m
6874  icst = 1
6875  icnd = m - 1
6876  ELSEIF( m .GT. n ) THEN
6877  irst = ( m-n ) + 2
6878  irnd = m
6879  icst = 1
6880  icnd = n - 1
6881  ENDIF
6882  IF( diag .EQ. 'U' ) THEN
6883  irst = irst - 1
6884  icnd = icnd + 1
6885  ENDIF
6886  ELSE IF( uplo .EQ. 'L' ) THEN
6887  istrap = .true.
6888  IF( m .LE. n ) THEN
6889  irst = 1
6890  irnd = 1
6891  icst = ( n-m ) + 2
6892  icnd = n
6893  ELSEIF( m .GT. n ) THEN
6894  irst = 1
6895  irnd = 1
6896  icst = 2
6897  icnd = n
6898  ENDIF
6899  IF( diag .EQ. 'U' ) THEN
6900  icst = icst - 1
6901  ENDIF
6902  ENDIF
6903 *
6904 * Check elements and report any errors
6905 *
6906  IF( istrap ) THEN
6907  DO 100 j = icst, icnd
6908  DO 105 i = irst, irnd
6909  IF( mem( ipre + (j-1)*lda + i ) .NE. checkval ) THEN
6910  nerr = nerr + 1
6911  IF( nerr .LE. maxerr ) THEN
6912  erribuf(1, nerr) = testnum
6913  erribuf(2, nerr) = src
6914  erribuf(3, nerr) = dest
6915  erribuf(4, nerr) = i
6916  erribuf(5, nerr) = j
6917  erribuf(6, nerr) = err_tri
6918  errdbuf(1, nerr) = mem( ipre + (j-1)*lda + i )
6919  errdbuf(2, nerr) = checkval
6920  END IF
6921  END IF
6922  105 CONTINUE
6923 *
6924 * Update the limits to allow filling in padding
6925 *
6926  IF( uplo .EQ. 'U' ) THEN
6927  irst = irst + 1
6928  ELSE
6929  irnd = irnd + 1
6930  ENDIF
6931  100 CONTINUE
6932  END IF
6933 *
6934  RETURN
6935 *
6936 * End of ICHKPAD.
6937 *
6938  END
6939 *
6940  SUBROUTINE ichkmat( UPLO, DIAG, M, N, A, LDA, RSRC, CSRC,
6941  $ MYROW, MYCOL, TESTNUM, MAXERR, NERR,
6942  $ ERRIBUF, ERRDBUF )
6943 *
6944 * -- BLACS tester (version 1.0) --
6945 * University of Tennessee
6946 * December 15, 1994
6947 *
6948 *
6949 * .. Scalar Arguments ..
6950  CHARACTER*1 UPLO, DIAG
6951  INTEGER M, N, LDA, RSRC, CSRC, MYROW, MYCOL, TESTNUM
6952  INTEGER MAXERR, NERR
6953 * ..
6954 * .. Array Arguments ..
6955  INTEGER ERRIBUF(6, MAXERR)
6956  INTEGER A(LDA,N), ERRDBUF(2, MAXERR)
6957 * ..
6958 *
6959 * Purpose
6960 * =======
6961 * iCHKMAT: Check matrix to see whether there were any transmission
6962 * errors.
6963 *
6964 * Arguments
6965 * =========
6966 * UPLO (input) CHARACTER*1
6967 * Is the matrix A 'U'pper or 'L'ower trapezoidal, or 'G'eneral
6968 * rectangular?
6969 *
6970 * DIAG (input) CHARACTER*1
6971 * For trapezoidal matrices, is the main diagonal included
6972 * ('N') or not ('U')?
6973 *
6974 * M (input) INTEGER
6975 * The number of rows of the matrix A. M >= 0.
6976 *
6977 * N (input) INTEGER
6978 * The number of columns of the matrix A. N >= 0.
6979 *
6980 * A (input) @up@(doctype) array, dimension (LDA,N)
6981 * The m by n matrix A. Fortran77 (column-major) storage
6982 * assumed.
6983 *
6984 * LDA (input) INTEGER
6985 * The leading dimension of the array A. LDA >= max(1, M).
6986 *
6987 * RSRC (input) INTEGER
6988 * The process row of the source of the matrix.
6989 *
6990 * CSRC (input) INTEGER
6991 * The process column of the source of the matrix.
6992 *
6993 * MYROW (input) INTEGER
6994 * Row of this process in the process grid.
6995 *
6996 * MYCOL (input) INTEGER
6997 * Column of this process in the process grid.
6998 *
6999 *
7000 * TESTNUM (input) INTEGER
7001 * The number of the test being checked.
7002 *
7003 * MAXERR (input) INTEGER
7004 * Max number of errors that can be stored in ERRIBUFF or
7005 * ERRIBUFF
7006 *
7007 * NERR (output) INTEGER
7008 * The number of errors that have been found.
7009 *
7010 * ERRIBUF (output) INTEGER array, dimension (6,MAXERRS)
7011 * Buffer in which to store integer error information. It will
7012 * be built up in the following format for the call to TSEND.
7013 * All integer information is recorded in the following 6-tuple
7014 * {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured:
7015 * SRC = RSRC * NPROCS + CSRC
7016 * DEST = RDEST * NPROCS + CDEST
7017 * WHAT
7018 * = 1 : Error in pre-padding
7019 * = 2 : Error in post-padding
7020 * = 3 : Error in LDA-M gap
7021 * = 4 : Error in complementory triangle
7022 * ELSE: Error in matrix
7023 * If there are more errors than can fit in the error buffer,
7024 * the error number will indicate the actual number of errors
7025 * found, but the buffer will be truncated to the maximum
7026 * number of errors which can fit.
7027 *
7028 * ERRDBUF (output) @(doctype) array, dimension (2, MAXERRS)
7029 * Buffer in which to store error data information.
7030 * {Incorrect, Predicted}
7031 *
7032 * ===================================================================
7033 *
7034 * .. Local Scalars ..
7035  INTEGER I, J, NPROCS, SRC, DEST
7036  LOGICAL USEIT
7037  INTEGER COMPVAL
7038 * ..
7039 * .. Local Arrays ..
7040  INTEGER ISEED(4)
7041 * ..
7042 * .. External Functions ..
7043  INTEGER IBTNPROCS
7044  INTEGER IBTRAN
7045  EXTERNAL IBTRAN, IBTNPROCS
7046 * ..
7047 * .. Executable Statements ..
7048 *
7049  NPROCS = ibtnprocs()
7050  src = rsrc * nprocs + csrc
7051  dest = myrow * nprocs + mycol
7052 *
7053 * Initialize ISEED with the same values as used in IGENMAT.
7054 *
7055  iseed(1) = mod( 1002 + testnum*5 + src*3, 4096 )
7056  iseed(2) = mod( 2027 + testnum*7 + src, 4096 )
7057  iseed(3) = mod( 1234 + testnum + src*3, 4096 )
7058  iseed(4) = mod( 4311 + testnum*10 + src*2, 4096 )
7059 *
7060 * Generate the elements randomly with the same method used in GENMAT.
7061 * Note that for trapezoidal matrices, we generate all elements in the
7062 * enclosing rectangle and then ignore the complementary triangle.
7063 *
7064  DO 100 j = 1, n
7065  DO 105 i = 1, m
7066  compval = ibtran( iseed )
7067 *
7068 * Now determine whether we actually need this value. The
7069 * strategy is to chop out the proper triangle based on what
7070 * particular kind of trapezoidal matrix we're dealing with.
7071 *
7072  useit = .true.
7073  IF( uplo .EQ. 'U' ) THEN
7074  IF( m .LE. n ) THEN
7075  IF( diag .EQ. 'U' ) THEN
7076  IF( i .GE. j ) THEN
7077  useit = .false.
7078  END IF
7079  ELSE
7080  IF( i .GT. j ) THEN
7081  useit = .false.
7082  END IF
7083  END IF
7084  ELSE
7085  IF( diag .EQ. 'U' ) THEN
7086  IF( i .GE. m-n+j ) THEN
7087  useit = .false.
7088  END IF
7089  ELSE
7090  IF( i .GT. m-n+j ) THEN
7091  useit = .false.
7092  END IF
7093  END IF
7094  END IF
7095  ELSE IF( uplo .EQ. 'L' ) THEN
7096  IF( m .LE. n ) THEN
7097  IF( diag .EQ. 'U' ) THEN
7098  IF( j. ge. i+(n-m) ) THEN
7099  useit = .false.
7100  END IF
7101  ELSE
7102  IF( j .GT. i+(n-m) ) THEN
7103  useit = .false.
7104  END IF
7105  END IF
7106  ELSE
7107  IF( diag .EQ. 'U' ) THEN
7108  IF( j .GE. i ) THEN
7109  useit = .false.
7110  END IF
7111  ELSE
7112  IF( j .GT. i ) THEN
7113  useit = .false.
7114  END IF
7115  END IF
7116  END IF
7117  END IF
7118 *
7119 * Compare the generated value to the one that's in the
7120 * received matrix. If they don't match, tack another
7121 * error record onto what's already there.
7122 *
7123  IF( useit ) THEN
7124  IF( a(i,j) .NE. compval ) THEN
7125  nerr = nerr + 1
7126  IF( nerr .LE. maxerr ) THEN
7127  erribuf(1, nerr) = testnum
7128  erribuf(2, nerr) = src
7129  erribuf(3, nerr) = dest
7130  erribuf(4, nerr) = i
7131  erribuf(5, nerr) = j
7132  erribuf(6, nerr) = 5
7133  errdbuf(1, nerr) = a(i, j)
7134  errdbuf(2, nerr) = compval
7135  END IF
7136  END IF
7137  END IF
7138  105 CONTINUE
7139  100 CONTINUE
7140  RETURN
7141 *
7142 * End of ICHKMAT.
7143 *
7144  END
7145 *
7146  SUBROUTINE iprinterrs( OUTNUM, MAXERR, NERR,
7147  $ ERRIBUF, ERRDBUF, COUNTING, TFAILED )
7148 *
7149 * -- BLACS tester (version 1.0) --
7150 * University of Tennessee
7151 * December 15, 1994
7152 *
7153 *
7154 * .. Scalar Arguments ..
7155  LOGICAL COUNTING
7156  INTEGER OUTNUM, MAXERR, NERR
7157 * ..
7158 * .. Array Arguments ..
7159  INTEGER ERRIBUF(6, MAXERR), TFAILED(*)
7160  INTEGER ERRDBUF(2, MAXERR)
7161 * ..
7162 *
7163 * Purpose
7164 * =======
7165 * IPRINTERRS: Print errors that have been recorded
7166 *
7167 * Arguments
7168 * =========
7169 * OUTNUM (input) INTEGER
7170 * Device number for output.
7171 *
7172 * MAXERR (input) INTEGER
7173 * Max number of errors that can be stored in ERRIBUFF or
7174 * ERRIBUFF
7175 *
7176 * NERR (output) INTEGER
7177 * The number of errors that have been found.
7178 *
7179 * ERRIBUF (output) INTEGER array, dimension (6,MAXERRS)
7180 * Buffer in which to store integer error information. It will
7181 * be built up in the following format for the call to TSEND.
7182 * All integer information is recorded in the following 6-tuple
7183 * {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured:
7184 * SRC = RSRC * NPROCS + CSRC
7185 * DEST = RDEST * NPROCS + CDEST
7186 * WHAT
7187 * = 1 : Error in pre-padding
7188 * = 2 : Error in post-padding
7189 * = 3 : Error in LDA-M gap
7190 * = 4 : Error in complementory triangle
7191 * ELSE: Error in matrix
7192 * If there are more errors than can fit in the error buffer,
7193 * the error number will indicate the actual number of errors
7194 * found, but the buffer will be truncated to the maximum
7195 * number of errors which can fit.
7196 *
7197 * ERRDBUF (output) @(doctype) array, dimension (2, MAXERRS)
7198 * Buffer in which to store error data information.
7199 * {Incorrect, Predicted}
7200 *
7201 * TFAILED (input/ourput) INTEGER array, dimension NTESTS
7202 * Workspace used to keep track of which tests failed.
7203 * This array not accessed unless COUNTING is true.
7204 *
7205 * ===================================================================
7206 *
7207 * .. Parameters ..
7208  INTEGER ERR_PRE, ERR_POST, ERR_GAP, ERR_TRI, ERR_MAT
7209  parameter( err_pre = 1, err_post = 2, err_gap = 3, err_tri = 4 )
7210  parameter( err_mat = 5 )
7211 * ..
7212 * .. External Functions ..
7213  INTEGER IBTMYPROC, IBTNPROCS
7214  EXTERNAL ibtmyproc, ibtnprocs
7215 * ..
7216 * .. Local Scalars ..
7217  CHARACTER*1 MAT
7218  LOGICAL MATISINT
7219  INTEGER OLDTEST, NPROCS, PROW, PCOL, I, ERRTYPE
7220 * ..
7221 * .. Executable Statements ..
7222 *
7223  IF( (IBTMYPROC().NE.0) .OR. (NERR.LE.0) ) RETURN
7224  OLDTEST = -1
7225  nprocs = ibtnprocs()
7226  prow = erribuf(3,1) / nprocs
7227  pcol = mod( erribuf(3,1), nprocs )
7228  IF( nerr .GT. maxerr ) WRITE(outnum,13000)
7229 *
7230  DO 20 i = 1, min( nerr, maxerr )
7231  IF( erribuf(1,i) .NE. oldtest ) THEN
7232  IF( oldtest .NE. -1 )
7233  $ WRITE(outnum,12000) prow, pcol, oldtest
7234  WRITE(outnum,*) ' '
7235  WRITE(outnum,1000) prow, pcol, erribuf(1,i)
7236  IF( counting ) tfailed( erribuf(1,i) ) = 1
7237  oldtest = erribuf(1, i)
7238  END IF
7239 *
7240 * Print out error message depending on type of error
7241 *
7242  errtype = erribuf(6, i)
7243  IF( errtype .LT. -10 ) THEN
7244  errtype = -errtype - 10
7245  mat = 'C'
7246  matisint = .true.
7247  ELSE IF( errtype .LT. 0 ) THEN
7248  errtype = -errtype
7249  mat = 'R'
7250  matisint = .true.
7251  ELSE
7252  matisint = .false.
7253  END IF
7254 *
7255 * RA/CA arrays from MAX/MIN have different printing protocol
7256 *
7257  IF( matisint ) THEN
7258  IF( erribuf(2, i) .EQ. -1 ) THEN
7259  WRITE(outnum,11000) erribuf(4,i), erribuf(5,i), mat,
7260  $ int( errdbuf(2,i) ), int( errdbuf(1,i) )
7261  ELSE IF( errtype .EQ. err_pre ) THEN
7262  WRITE(outnum,7000) erribuf(5,i), mat,
7263  $ int( errdbuf(2,i) ), int( errdbuf(1,i) )
7264  ELSE IF( errtype .EQ. err_post ) THEN
7265  WRITE(outnum,8000) erribuf(4,i), mat,
7266  $ int( errdbuf(2,i) ), int( errdbuf(1,i) )
7267  ELSE IF( errtype .EQ. err_gap ) THEN
7268  WRITE(outnum,9000) mat, erribuf(4,i), erribuf(5,i),
7269  $ int( errdbuf(2,i) ), int( errdbuf(1,i) )
7270  ELSE
7271  WRITE(outnum,10000) mat, erribuf(4,i), erribuf(5,i),
7272  $ int( errdbuf(2,i) ),
7273  $ int( errdbuf(1,i) )
7274  END IF
7275 *
7276 * Have memory overwrites in matrix A
7277 *
7278  ELSE
7279  IF( errtype .EQ. err_pre ) THEN
7280  WRITE(outnum,2000) erribuf(5,i), errdbuf(2,i),
7281  $ errdbuf(1,i)
7282  ELSE IF( errtype .EQ. err_post ) THEN
7283  WRITE(outnum,3000) erribuf(4,i), errdbuf(2,i),
7284  $ errdbuf(1,i)
7285  ELSE IF( errtype .EQ. err_gap ) THEN
7286  WRITE(outnum,4000) erribuf(4,i), erribuf(5,i),
7287  $ errdbuf(2,i), errdbuf(1,i)
7288  ELSE IF( errtype .EQ. err_tri ) THEN
7289  WRITE(outnum,5000) erribuf(4,i), erribuf(5,i),
7290  $ errdbuf(2,i), errdbuf(1,i)
7291  ELSE
7292  WRITE(outnum,6000) erribuf(4,i), erribuf(5,i),
7293  $ errdbuf(2,i), errdbuf(1,i)
7294  END IF
7295  END IF
7296  20 CONTINUE
7297  WRITE(outnum,12000) prow, pcol, oldtest
7298 *
7299  1000 FORMAT('PROCESS {',i4,',',i4,'} REPORTS ERRORS IN TEST#',i6,':')
7300  2000 FORMAT(' Buffer overwrite ',i4,
7301  $ ' elements before the start of A:',/,
7302  $ ' Expected=',i12,
7303  $ '; Received=',i12)
7304  3000 FORMAT(' Buffer overwrite ',i4,' elements after the end of A:',
7305  $ /,' Expected=',i12,
7306  $ '; Received=',i12)
7307  4000 FORMAT(' LDA-M gap overwrite at postion (',i4,',',i4,'):',/,
7308  $ ' Expected=',i12,
7309  $ '; Received=',i12)
7310  5000 FORMAT(' Complementory triangle overwrite at A(',i4,',',i4,
7311  $ '):',/,' Expected=',i12,
7312  $ '; Received=',i12)
7313  6000 FORMAT(' Invalid element at A(',i4,',',i4,'):',/,
7314  $ ' Expected=',i12,
7315  $ '; Received=',i12)
7316  7000 FORMAT(' Buffer overwrite ',i4,' elements before the start of ',
7317  $ a1,'A:',/,' Expected=',i12,'; Received=',i12)
7318  8000 FORMAT(' Buffer overwrite ',i4,' elements after the end of ',
7319  $ a1,'A:',/,' Expected=',i12,'; Received=',i12)
7320 *
7321  9000 FORMAT(' LD',a1,'A-M gap overwrite at postion (',i4,',',i4,'):'
7322  $ ,/,' Expected=',i12,'; Received=',i12)
7323 *
7324 10000 FORMAT(' Invalid element at ',a1,'A(',i4,',',i4,'):',/,
7325  $ ' Expected=',i12,'; Received=',i12)
7326 11000 FORMAT(' Overwrite at position (',i4,',',i4,') of non-existent '
7327  $ ,a1,'A array.',/,' Expected=',i12,'; Received=',i12)
7328 12000 FORMAT('PROCESS {',i4,',',i4,'} DONE ERROR REPORT FOR TEST#',
7329  $ i6,'.')
7330 13000 FORMAT('WARNING: There were more errors than could be recorded.',
7331  $ /,'Increase MEMELTS to get complete listing.')
7332  RETURN
7333 *
7334 * End IPRINTERRS
7335 *
7336  END
7337 *
7338 *
7339  SUBROUTINE sbtcheckin( NFTESTS, OUTNUM, MAXERR, NERR, IERR,
7340  $ SVAL, TFAILED )
7341  INTEGER NFTESTS, OUTNUM, MAXERR, NERR
7342  INTEGER IERR(*), TFAILED(*)
7343  REAL SVAL(*)
7344 *
7345 * Purpose
7346 * =======
7347 * SBTCHECKIN: Process 0 receives error report from all processes.
7348 *
7349 * Arguments
7350 * =========
7351 * NFTESTS (input/output) INTEGER
7352 * if NFTESTS is <= 0 upon entry, NFTESTS is not written to.
7353 * Otherwise, on entry it specifies the total number of tests
7354 * run, and on exit it is the number of tests which failed.
7355 *
7356 * OUTNUM (input) INTEGER
7357 * Device number for output.
7358 *
7359 * MAXERR (input) INTEGER
7360 * Max number of errors that can be stored in ERRIBUFF or
7361 * ERRSBUFF
7362 *
7363 * NERR (output) INTEGER
7364 * The number of errors that have been found.
7365 *
7366 * ERRIBUF (output) INTEGER array, dimension (6,MAXERRS)
7367 * Buffer in which to store integer error information. It will
7368 * be built up in the following format for the call to TSEND.
7369 * All integer information is recorded in the following 6-tuple
7370 * {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured:
7371 * SRC = RSRC * NPROCS + CSRC
7372 * DEST = RDEST * NPROCS + CDEST
7373 * WHAT
7374 * = 1 : Error in pre-padding
7375 * = 2 : Error in post-padding
7376 * = 3 : Error in LDA-M gap
7377 * = 4 : Error in complementory triangle
7378 * ELSE: Error in matrix
7379 * If there are more errors than can fit in the error buffer,
7380 * the error number will indicate the actual number of errors
7381 * found, but the buffer will be truncated to the maximum
7382 * number of errors which can fit.
7383 *
7384 * ERRDBUF (output) @(doctype) array, dimension (2, MAXERRS)
7385 * Buffer in which to store error data information.
7386 * {Incorrect, Predicted}
7387 *
7388 * TFAILED (workspace) INTEGER array, dimension NFTESTS
7389 * Workspace used to keep track of which tests failed.
7390 * If input of NFTESTS < 1, this array not accessed.
7391 *
7392 * ===================================================================
7393 *
7394 * .. External Functions ..
7395  INTEGER IBTMYPROC, IBTNPROCS, IBTMSGID
7396  EXTERNAL ibtmyproc, ibtnprocs, ibtmsgid
7397 * ..
7398 * .. Local Scalars ..
7399  LOGICAL COUNTING
7400  INTEGER K, NERR2, IAM, NPROCS, NTESTS
7401 *
7402 * Proc 0 collects error info from everyone
7403 *
7404  IAM = ibtmyproc()
7405  nprocs = ibtnprocs()
7406 *
7407  IF( iam .EQ. 0 ) THEN
7408 *
7409 * If we are finding out how many failed tests there are, initialize
7410 * the total number of tests (NTESTS), and zero the test failed array
7411 *
7412  counting = nftests .GT. 0
7413  IF( counting ) THEN
7414  ntests = nftests
7415  DO 10 k = 1, ntests
7416  tfailed(k) = 0
7417  10 CONTINUE
7418  END IF
7419 *
7420  CALL sprinterrs(outnum, maxerr, nerr, ierr, sval, counting,
7421  $ tfailed)
7422 *
7423  DO 20 k = 1, nprocs-1
7424  CALL btsend(3, 0, k, k, ibtmsgid()+50)
7425  CALL btrecv(3, 1, nerr2, k, ibtmsgid()+50)
7426  IF( nerr2 .GT. 0 ) THEN
7427  nerr = nerr + nerr2
7428  CALL btrecv(3, nerr2*6, ierr, k, ibtmsgid()+51)
7429  CALL btrecv(4, nerr2*2, sval, k, ibtmsgid()+51)
7430  CALL sprinterrs(outnum, maxerr, nerr2, ierr, sval,
7431  $ counting, tfailed)
7432  END IF
7433  20 CONTINUE
7434 *
7435 * Count up number of tests that failed
7436 *
7437  IF( counting ) THEN
7438  nftests = 0
7439  DO 30 k = 1, ntests
7440  nftests = nftests + tfailed(k)
7441  30 CONTINUE
7442  END IF
7443 *
7444 * Send my error info to proc 0
7445 *
7446  ELSE
7447  CALL btrecv(3, 0, k, 0, ibtmsgid()+50)
7448  CALL btsend(3, 1, nerr, 0, ibtmsgid()+50)
7449  IF( nerr .GT. 0 ) THEN
7450  CALL btsend(3, nerr*6, ierr, 0, ibtmsgid()+51)
7451  CALL btsend(4, nerr*2, sval, 0, ibtmsgid()+51)
7452  END IF
7453  ENDIF
7454 *
7455  RETURN
7456 *
7457 * End of SBTCHECKIN
7458 *
7459  END
7460 *
7461  SUBROUTINE sinitmat(UPLO, DIAG, M, N, MEM, LDA, IPRE, IPOST,
7462  $ CHECKVAL, TESTNUM, MYROW, MYCOL)
7463  CHARACTER*1 UPLO, DIAG
7464  INTEGER M, N, LDA, IPRE, IPOST, TESTNUM, MYROW, MYCOL
7465  REAL CHECKVAL
7466  REAL MEM(*)
7467 *
7468 * .. External Subroutines ..
7469  EXTERNAL sgenmat, spadmat
7470 * ..
7471 * .. Executable Statements ..
7472 *
7473  CALL sgenmat( m, n, mem(ipre+1), lda, testnum, myrow, mycol )
7474  CALL spadmat( uplo, diag, m, n, mem, lda, ipre, ipost, checkval )
7475 *
7476  RETURN
7477  END
7478 *
7479  SUBROUTINE sgenmat( M, N, A, LDA, TESTNUM, MYROW, MYCOL )
7480 *
7481 * -- BLACS tester (version 1.0) --
7482 * University of Tennessee
7483 * December 15, 1994
7484 *
7485 *
7486 * .. Scalar Arguments ..
7487  INTEGER M, N, LDA, TESTNUM, MYROW, MYCOL
7488 * ..
7489 * .. Array Arguments ..
7490  REAL A(LDA,N)
7491 * ..
7492 *
7493 * Purpose
7494 * =======
7495 * SGENMAT: Generates an M-by-N matrix filled with random elements.
7496 *
7497 * Arguments
7498 * =========
7499 * M (input) INTEGER
7500 * The number of rows of the matrix A. M >= 0.
7501 *
7502 * N (input) INTEGER
7503 * The number of columns of the matrix A. N >= 0.
7504 *
7505 * A (output) @up@(doctype) array, dimension (LDA,N)
7506 * The m by n matrix A. Fortran77 (column-major) storage
7507 * assumed.
7508 *
7509 * LDA (input) INTEGER
7510 * The leading dimension of the array A. LDA >= max(1, M).
7511 *
7512 * TESTNUM (input) INTEGER
7513 * Unique number for this test case, used as a basis for
7514 * the random seeds.
7515 *
7516 * ====================================================================
7517 *
7518 * .. External Functions ..
7519  INTEGER IBTNPROCS
7520  REAL SBTRAN
7521  EXTERNAL sbtran, ibtnprocs
7522 * ..
7523 * .. Local Scalars ..
7524  INTEGER I, J, NPROCS, SRC
7525 * ..
7526 * .. Local Arrays ..
7527  INTEGER ISEED(4)
7528 * ..
7529 * .. Executable Statements ..
7530 *
7531 * ISEED's four values must be positive integers less than 4096,
7532 * fourth one has to be odd. (see _LARND). Use some goofy
7533 * functions to come up with seed values which together should
7534 * be unique.
7535 *
7536  nprocs = ibtnprocs()
7537  src = myrow * nprocs + mycol
7538  iseed(1) = mod( 1002 + testnum*5 + src*3, 4096 )
7539  iseed(2) = mod( 2027 + testnum*7 + src, 4096 )
7540  iseed(3) = mod( 1234 + testnum + src*3, 4096 )
7541  iseed(4) = mod( 4311 + testnum*10 + src*2, 4096 )
7542 *
7543  DO 10 j = 1, n
7544  DO 10 i = 1, m
7545  a(i, j) = sbtran( iseed )
7546  10 CONTINUE
7547 *
7548  RETURN
7549 *
7550 * End of SGENMAT.
7551 *
7552  END
7553 *
7554  REAL FUNCTION SBTRAN(ISEED)
7555  INTEGER iseed(*)
7556 *
7557 * .. External Functions ..
7558  DOUBLE PRECISION dlarnd
7559  EXTERNAL dlarnd
7560 * .. Executable Statements ..
7561 *
7562  sbtran = real( dlarnd(2, iseed) )
7563 *
7564  RETURN
7565 *
7566 * End of Sbtran
7567 *
7568  END
7569 *
7570  SUBROUTINE spadmat( UPLO, DIAG, M, N, MEM, LDA, IPRE, IPOST,
7571  $ CHECKVAL )
7572 *
7573 * -- BLACS tester (version 1.0) --
7574 * University of Tennessee
7575 * December 15, 1994
7576 *
7577 * .. Scalar Arguments ..
7578  CHARACTER*1 UPLO, DIAG
7579  INTEGER M, N, LDA, IPRE, IPOST
7580  REAL CHECKVAL
7581 * ..
7582 * .. Array Arguments ..
7583  REAL MEM( * )
7584 * ..
7585 *
7586 * Purpose
7587 * =======
7588 *
7589 * SPADMAT: Pad Matrix.
7590 * This routines surrounds a matrix with a guardzone initialized to the
7591 * value CHECKVAL. There are three distinct guardzones:
7592 * - A contiguous zone of size IPRE immediately before the start
7593 * of the matrix.
7594 * - A contiguous zone of size IPOST immedately after the end of the
7595 * matrix.
7596 * - Interstitial zones within each column of the matrix, in the
7597 * elements A( M+1:LDA, J ).
7598 *
7599 * Arguments
7600 * =========
7601 * UPLO (input) CHARACTER*1
7602 * Is the matrix A 'U'pper or 'L'ower trapezoidal, or 'G'eneral
7603 * rectangular?
7604 *
7605 * DIAG (input) CHARACTER*1
7606 * For trapezoidal matrices, is the main diagonal included
7607 * ('N') or not ('U')?
7608 *
7609 * M (input) INTEGER
7610 * The number of rows of the matrix A. M >= 0.
7611 *
7612 * N (input) INTEGER
7613 * The number of columns of the matrix A. N >= 0.
7614 *
7615 * MEM (output) real array, dimension (IPRE+IPOST+LDA*N)
7616 * The address IPRE elements ahead of the matrix A you want to
7617 * pad, which is then of dimension (LDA,N).
7618 *
7619 * IPRE (input) INTEGER
7620 * The size of the guard zone ahead of the matrix A.
7621 *
7622 * IPOST (input) INTEGER
7623 * The size of the guard zone behind the matrix A.
7624 *
7625 * CHECKVAL (input) real
7626 * The value to insert into the guard zones.
7627 *
7628 * ====================================================================
7629 *
7630 * .. Local Scalars ..
7631  INTEGER I, J, K
7632 * ..
7633 * .. Executable Statements ..
7634 *
7635 * Put check buffer in front of A
7636 *
7637  IF( ipre .GT. 0 ) THEN
7638  DO 10 i = 1, ipre
7639  mem( i ) = checkval
7640  10 CONTINUE
7641  END IF
7642 *
7643 * Put check buffer in back of A
7644 *
7645  IF( ipost .GT. 0 ) THEN
7646  j = ipre + lda*n + 1
7647  DO 20 i = j, j+ipost-1
7648  mem( i ) = checkval
7649  20 CONTINUE
7650  END IF
7651 *
7652 * Put check buffer in all (LDA-M) gaps
7653 *
7654  IF( lda .GT. m ) THEN
7655  k = ipre + m + 1
7656  DO 40 j = 1, n
7657  DO 30 i = k, k+lda-m-1
7658  mem( i ) = checkval
7659  30 CONTINUE
7660  k = k + lda
7661  40 CONTINUE
7662  END IF
7663 *
7664 * If the matrix is upper or lower trapezoidal, calculate the
7665 * additional triangular area which needs to be padded, Each
7666 * element referred to is in the Ith row and the Jth column.
7667 *
7668  IF( uplo .EQ. 'U' ) THEN
7669  IF( m .LE. n ) THEN
7670  IF( diag .EQ. 'U' ) THEN
7671  DO 41 i = 1, m
7672  DO 42 j = 1, i
7673  k = ipre + i + (j-1)*lda
7674  mem( k ) = checkval
7675  42 CONTINUE
7676  41 CONTINUE
7677  ELSE
7678  DO 43 i = 2, m
7679  DO 44 j = 1, i-1
7680  k = ipre + i + (j-1)*lda
7681  mem( k ) = checkval
7682  44 CONTINUE
7683  43 CONTINUE
7684  END IF
7685  ELSE
7686  IF( diag .EQ. 'U' ) THEN
7687  DO 45 i = m-n+1, m
7688  DO 46 j = 1, i-(m-n)
7689  k = ipre + i + (j-1)*lda
7690  mem( k ) = checkval
7691  46 CONTINUE
7692  45 CONTINUE
7693  ELSE
7694  DO 47 i = m-n+2, m
7695  DO 48 j = 1, i-(m-n)-1
7696  k = ipre + i + (j-1)*lda
7697  mem( k ) = checkval
7698  48 CONTINUE
7699  47 CONTINUE
7700  END IF
7701  END IF
7702  ELSE IF( uplo .EQ. 'L' ) THEN
7703  IF( m .LE. n ) THEN
7704  IF( diag .EQ. 'U' ) THEN
7705  DO 49 i = 1, m
7706  DO 50 j = n-m+i, n
7707  k = ipre + i + (j-1)*lda
7708  mem( k ) = checkval
7709  50 CONTINUE
7710  49 CONTINUE
7711  ELSE
7712  DO 51 i = 1, m-1
7713  DO 52 j = n-m+i+1, n
7714  k = ipre + i + (j-1)*lda
7715  mem( k ) = checkval
7716  52 CONTINUE
7717  51 CONTINUE
7718  END IF
7719  ELSE
7720  IF( uplo .EQ. 'U' ) THEN
7721  DO 53 i = 1, n
7722  DO 54 j = i, n
7723  k = ipre + i + (j-1)*lda
7724  mem( k ) = checkval
7725  54 CONTINUE
7726  53 CONTINUE
7727  ELSE
7728  DO 55 i = 1, n-1
7729  DO 56 j = i+1, n
7730  k = ipre + i + (j-1)*lda
7731  mem( k ) = checkval
7732  56 CONTINUE
7733  55 CONTINUE
7734  END IF
7735  END IF
7736  END IF
7737 *
7738 * End of SPADMAT.
7739 *
7740  RETURN
7741  END
7742 *
7743  SUBROUTINE schkpad( UPLO, DIAG, M, N, MEM, LDA, RSRC, CSRC,
7744  $ MYROW, MYCOL, IPRE, IPOST, CHECKVAL,
7745  $ TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF )
7746 *
7747 * -- BLACS tester (version 1.0) --
7748 * University of Tennessee
7749 * December 15, 1994
7750 *
7751 *
7752 * .. Scalar Arguments ..
7753  CHARACTER*1 UPLO, DIAG
7754  INTEGER M, N, LDA, RSRC, CSRC, MYROW, MYCOL, IPRE, IPOST
7755  INTEGER TESTNUM, MAXERR, NERR
7756  REAL CHECKVAL
7757 * ..
7758 * .. Array Arguments ..
7759  INTEGER ERRIBUF(6, MAXERR)
7760  REAL MEM(*), ERRDBUF(2, MAXERR)
7761 * ..
7762 *
7763 * Purpose
7764 * =======
7765 * SCHKPAD: Check padding put in by PADMAT.
7766 * Checks that padding around target matrix has not been overwritten
7767 * by the previous point-to-point or broadcast send.
7768 *
7769 * Arguments
7770 * =========
7771 * UPLO (input) CHARACTER*1
7772 * Is the matrix A 'U'pper or 'L'ower trapezoidal, or 'G'eneral
7773 * rectangular?
7774 *
7775 * DIAG (input) CHARACTER*1
7776 * For trapezoidal matrices, is the main diagonal included
7777 * ('N') or not ('U')?
7778 *
7779 * M (input) INTEGER
7780 * The number of rows of the matrix A. M >= 0.
7781 *
7782 * N (input) INTEGER
7783 * The number of columns of the matrix A. N >= 0.
7784 *
7785 * MEM (input) real array, dimension(IPRE+IPOST+LDA*N).
7786 * Memory location IPRE elements in front of the matrix A.
7787 *
7788 * LDA (input) INTEGER
7789 * The leading dimension of the array A. LDA >= max(1, M).
7790 *
7791 * RSRC (input) INTEGER
7792 * The process row of the source of the matrix.
7793 *
7794 * CSRC (input) INTEGER
7795 * The process column of the source of the matrix.
7796 *
7797 * MYROW (input) INTEGER
7798 * Row of this process in the process grid.
7799 *
7800 * MYCOL (input) INTEGER
7801 * Column of this process in the process grid.
7802 *
7803 * IPRE (input) INTEGER
7804 * The size of the guard zone before the start of A.
7805 *
7806 * IPOST (input) INTEGER
7807 * The size of guard zone after A.
7808 *
7809 * CHECKVAL (input) real
7810 * The value to pad matrix with.
7811 *
7812 * TESTNUM (input) INTEGER
7813 * The number of the test being checked.
7814 *
7815 * MAXERR (input) INTEGER
7816 * Max number of errors that can be stored in ERRIBUFF or
7817 * ERRSBUFF
7818 *
7819 * NERR (output) INTEGER
7820 * The number of errors that have been found.
7821 *
7822 * ERRIBUF (output) INTEGER array, dimension (6,MAXERRS)
7823 * Buffer in which to store integer error information. It will
7824 * be built up in the following format for the call to TSEND.
7825 * All integer information is recorded in the following 6-tuple
7826 * {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured:
7827 * SRC = RSRC * NPROCS + CSRC
7828 * DEST = RDEST * NPROCS + CDEST
7829 * WHAT
7830 * = 1 : Error in pre-padding
7831 * = 2 : Error in post-padding
7832 * = 3 : Error in LDA-M gap
7833 * = 4 : Error in complementory triangle
7834 * ELSE: Error in matrix
7835 * If there are more errors than can fit in the error buffer,
7836 * the error number will indicate the actual number of errors
7837 * found, but the buffer will be truncated to the maximum
7838 * number of errors which can fit.
7839 *
7840 * ERRDBUF (output) @(doctype) array, dimension (2, MAXERRS)
7841 * Buffer in which to store error data information.
7842 * {Incorrect, Predicted}
7843 *
7844 * ===================================================================
7845 *
7846 * .. Parameters ..
7847  INTEGER ERR_PRE, ERR_POST, ERR_GAP, ERR_TRI, ERR_MAT
7848  PARAMETER( ERR_PRE = 1, err_post = 2, err_gap = 3, err_tri = 4 )
7849  parameter( err_mat = 5 )
7850 * ..
7851 * .. External Functions ..
7852  INTEGER IBTNPROCS
7853  EXTERNAL IBTNPROCS
7854 * ..
7855 * .. Local Scalars ..
7856  LOGICAL ISTRAP
7857  INTEGER I, J, K, IRST, IRND, ICST, ICND, SRC, DEST
7858  INTEGER NPROCS
7859 * ..
7860 * .. Executable Statements ..
7861 *
7862  NPROCS = ibtnprocs()
7863  src = rsrc * nprocs + csrc
7864  dest = myrow * nprocs + mycol
7865 *
7866 * Check buffer in front of A
7867 *
7868  IF( ipre .GT. 0 ) THEN
7869  DO 10 i = 1, ipre
7870  IF( mem(i) .NE. checkval ) THEN
7871  nerr = nerr + 1
7872  IF( nerr .LE. maxerr ) THEN
7873  erribuf(1, nerr) = testnum
7874  erribuf(2, nerr) = src
7875  erribuf(3, nerr) = dest
7876  erribuf(4, nerr) = i
7877  erribuf(5, nerr) = ipre - i + 1
7878  erribuf(6, nerr) = err_pre
7879  errdbuf(1, nerr) = mem(i)
7880  errdbuf(2, nerr) = checkval
7881  END IF
7882  END IF
7883  10 CONTINUE
7884  END IF
7885 *
7886 * Check buffer behind A
7887 *
7888  IF( ipost .GT. 0 ) THEN
7889  j = ipre + lda*n + 1
7890  DO 20 i = j, j+ipost-1
7891  IF( mem(i) .NE. checkval ) THEN
7892  nerr = nerr + 1
7893  IF( nerr .LE. maxerr ) THEN
7894  erribuf(1, nerr) = testnum
7895  erribuf(2, nerr) = src
7896  erribuf(3, nerr) = dest
7897  erribuf(4, nerr) = i - j + 1
7898  erribuf(5, nerr) = j
7899  erribuf(6, nerr) = err_post
7900  errdbuf(1, nerr) = mem(i)
7901  errdbuf(2, nerr) = checkval
7902  END IF
7903  END IF
7904  20 CONTINUE
7905  END IF
7906 *
7907 * Check all (LDA-M) gaps
7908 *
7909  IF( lda .GT. m ) THEN
7910  DO 40 j = 1, n
7911  DO 30 i = m+1, lda
7912  k = ipre + (j-1)*lda + i
7913  IF( mem(k) .NE. checkval) THEN
7914  nerr = nerr + 1
7915  IF( nerr .LE. maxerr ) THEN
7916  erribuf(1, nerr) = testnum
7917  erribuf(2, nerr) = src
7918  erribuf(3, nerr) = dest
7919  erribuf(4, nerr) = i
7920  erribuf(5, nerr) = j
7921  erribuf(6, nerr) = err_gap
7922  errdbuf(1, nerr) = mem(k)
7923  errdbuf(2, nerr) = checkval
7924  END IF
7925  END IF
7926  30 CONTINUE
7927  40 CONTINUE
7928  END IF
7929 *
7930 * Determine limits of trapezoidal matrix
7931 *
7932  istrap = .false.
7933  IF( uplo .EQ. 'U' ) THEN
7934  istrap = .true.
7935  IF( m .LE. n ) THEN
7936  irst = 2
7937  irnd = m
7938  icst = 1
7939  icnd = m - 1
7940  ELSEIF( m .GT. n ) THEN
7941  irst = ( m-n ) + 2
7942  irnd = m
7943  icst = 1
7944  icnd = n - 1
7945  ENDIF
7946  IF( diag .EQ. 'U' ) THEN
7947  irst = irst - 1
7948  icnd = icnd + 1
7949  ENDIF
7950  ELSE IF( uplo .EQ. 'L' ) THEN
7951  istrap = .true.
7952  IF( m .LE. n ) THEN
7953  irst = 1
7954  irnd = 1
7955  icst = ( n-m ) + 2
7956  icnd = n
7957  ELSEIF( m .GT. n ) THEN
7958  irst = 1
7959  irnd = 1
7960  icst = 2
7961  icnd = n
7962  ENDIF
7963  IF( diag .EQ. 'U' ) THEN
7964  icst = icst - 1
7965  ENDIF
7966  ENDIF
7967 *
7968 * Check elements and report any errors
7969 *
7970  IF( istrap ) THEN
7971  DO 100 j = icst, icnd
7972  DO 105 i = irst, irnd
7973  IF( mem( ipre + (j-1)*lda + i ) .NE. checkval ) THEN
7974  nerr = nerr + 1
7975  IF( nerr .LE. maxerr ) THEN
7976  erribuf(1, nerr) = testnum
7977  erribuf(2, nerr) = src
7978  erribuf(3, nerr) = dest
7979  erribuf(4, nerr) = i
7980  erribuf(5, nerr) = j
7981  erribuf(6, nerr) = err_tri
7982  errdbuf(1, nerr) = mem( ipre + (j-1)*lda + i )
7983  errdbuf(2, nerr) = checkval
7984  END IF
7985  END IF
7986  105 CONTINUE
7987 *
7988 * Update the limits to allow filling in padding
7989 *
7990  IF( uplo .EQ. 'U' ) THEN
7991  irst = irst + 1
7992  ELSE
7993  irnd = irnd + 1
7994  ENDIF
7995  100 CONTINUE
7996  END IF
7997 *
7998  RETURN
7999 *
8000 * End of SCHKPAD.
8001 *
8002  END
8003 *
8004  SUBROUTINE schkmat( UPLO, DIAG, M, N, A, LDA, RSRC, CSRC,
8005  $ MYROW, MYCOL, TESTNUM, MAXERR, NERR,
8006  $ ERRIBUF, ERRDBUF )
8007 *
8008 * -- BLACS tester (version 1.0) --
8009 * University of Tennessee
8010 * December 15, 1994
8011 *
8012 *
8013 * .. Scalar Arguments ..
8014  CHARACTER*1 UPLO, DIAG
8015  INTEGER M, N, LDA, RSRC, CSRC, MYROW, MYCOL, TESTNUM
8016  INTEGER MAXERR, NERR
8017 * ..
8018 * .. Array Arguments ..
8019  INTEGER ERRIBUF(6, MAXERR)
8020  REAL A(LDA,N), ERRDBUF(2, MAXERR)
8021 * ..
8022 *
8023 * Purpose
8024 * =======
8025 * sCHKMAT: Check matrix to see whether there were any transmission
8026 * errors.
8027 *
8028 * Arguments
8029 * =========
8030 * UPLO (input) CHARACTER*1
8031 * Is the matrix A 'U'pper or 'L'ower trapezoidal, or 'G'eneral
8032 * rectangular?
8033 *
8034 * DIAG (input) CHARACTER*1
8035 * For trapezoidal matrices, is the main diagonal included
8036 * ('N') or not ('U')?
8037 *
8038 * M (input) INTEGER
8039 * The number of rows of the matrix A. M >= 0.
8040 *
8041 * N (input) INTEGER
8042 * The number of columns of the matrix A. N >= 0.
8043 *
8044 * A (input) @up@(doctype) array, dimension (LDA,N)
8045 * The m by n matrix A. Fortran77 (column-major) storage
8046 * assumed.
8047 *
8048 * LDA (input) INTEGER
8049 * The leading dimension of the array A. LDA >= max(1, M).
8050 *
8051 * RSRC (input) INTEGER
8052 * The process row of the source of the matrix.
8053 *
8054 * CSRC (input) INTEGER
8055 * The process column of the source of the matrix.
8056 *
8057 * MYROW (input) INTEGER
8058 * Row of this process in the process grid.
8059 *
8060 * MYCOL (input) INTEGER
8061 * Column of this process in the process grid.
8062 *
8063 *
8064 * TESTNUM (input) INTEGER
8065 * The number of the test being checked.
8066 *
8067 * MAXERR (input) INTEGER
8068 * Max number of errors that can be stored in ERRIBUFF or
8069 * ERRSBUFF
8070 *
8071 * NERR (output) INTEGER
8072 * The number of errors that have been found.
8073 *
8074 * ERRIBUF (output) INTEGER array, dimension (6,MAXERRS)
8075 * Buffer in which to store integer error information. It will
8076 * be built up in the following format for the call to TSEND.
8077 * All integer information is recorded in the following 6-tuple
8078 * {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured:
8079 * SRC = RSRC * NPROCS + CSRC
8080 * DEST = RDEST * NPROCS + CDEST
8081 * WHAT
8082 * = 1 : Error in pre-padding
8083 * = 2 : Error in post-padding
8084 * = 3 : Error in LDA-M gap
8085 * = 4 : Error in complementory triangle
8086 * ELSE: Error in matrix
8087 * If there are more errors than can fit in the error buffer,
8088 * the error number will indicate the actual number of errors
8089 * found, but the buffer will be truncated to the maximum
8090 * number of errors which can fit.
8091 *
8092 * ERRDBUF (output) @(doctype) array, dimension (2, MAXERRS)
8093 * Buffer in which to store error data information.
8094 * {Incorrect, Predicted}
8095 *
8096 * ===================================================================
8097 *
8098 * .. Local Scalars ..
8099  INTEGER I, J, NPROCS, SRC, DEST
8100  LOGICAL USEIT
8101  REAL COMPVAL
8102 * ..
8103 * .. Local Arrays ..
8104  INTEGER ISEED(4)
8105 * ..
8106 * .. External Functions ..
8107  INTEGER IBTNPROCS
8108  REAL SBTRAN
8109  EXTERNAL SBTRAN, IBTNPROCS
8110 * ..
8111 * .. Executable Statements ..
8112 *
8113  NPROCS = ibtnprocs()
8114  src = rsrc * nprocs + csrc
8115  dest = myrow * nprocs + mycol
8116 *
8117 * Initialize ISEED with the same values as used in SGENMAT.
8118 *
8119  iseed(1) = mod( 1002 + testnum*5 + src*3, 4096 )
8120  iseed(2) = mod( 2027 + testnum*7 + src, 4096 )
8121  iseed(3) = mod( 1234 + testnum + src*3, 4096 )
8122  iseed(4) = mod( 4311 + testnum*10 + src*2, 4096 )
8123 *
8124 * Generate the elements randomly with the same method used in GENMAT.
8125 * Note that for trapezoidal matrices, we generate all elements in the
8126 * enclosing rectangle and then ignore the complementary triangle.
8127 *
8128  DO 100 j = 1, n
8129  DO 105 i = 1, m
8130  compval = sbtran( iseed )
8131 *
8132 * Now determine whether we actually need this value. The
8133 * strategy is to chop out the proper triangle based on what
8134 * particular kind of trapezoidal matrix we're dealing with.
8135 *
8136  useit = .true.
8137  IF( uplo .EQ. 'U' ) THEN
8138  IF( m .LE. n ) THEN
8139  IF( diag .EQ. 'U' ) THEN
8140  IF( i .GE. j ) THEN
8141  useit = .false.
8142  END IF
8143  ELSE
8144  IF( i .GT. j ) THEN
8145  useit = .false.
8146  END IF
8147  END IF
8148  ELSE
8149  IF( diag .EQ. 'U' ) THEN
8150  IF( i .GE. m-n+j ) THEN
8151  useit = .false.
8152  END IF
8153  ELSE
8154  IF( i .GT. m-n+j ) THEN
8155  useit = .false.
8156  END IF
8157  END IF
8158  END IF
8159  ELSE IF( uplo .EQ. 'L' ) THEN
8160  IF( m .LE. n ) THEN
8161  IF( diag .EQ. 'U' ) THEN
8162  IF( j. ge. i+(n-m) ) THEN
8163  useit = .false.
8164  END IF
8165  ELSE
8166  IF( j .GT. i+(n-m) ) THEN
8167  useit = .false.
8168  END IF
8169  END IF
8170  ELSE
8171  IF( diag .EQ. 'U' ) THEN
8172  IF( j .GE. i ) THEN
8173  useit = .false.
8174  END IF
8175  ELSE
8176  IF( j .GT. i ) THEN
8177  useit = .false.
8178  END IF
8179  END IF
8180  END IF
8181  END IF
8182 *
8183 * Compare the generated value to the one that's in the
8184 * received matrix. If they don't match, tack another
8185 * error record onto what's already there.
8186 *
8187  IF( useit ) THEN
8188  IF( a(i,j) .NE. compval ) THEN
8189  nerr = nerr + 1
8190  IF( nerr .LE. maxerr ) THEN
8191  erribuf(1, nerr) = testnum
8192  erribuf(2, nerr) = src
8193  erribuf(3, nerr) = dest
8194  erribuf(4, nerr) = i
8195  erribuf(5, nerr) = j
8196  erribuf(6, nerr) = 5
8197  errdbuf(1, nerr) = a(i, j)
8198  errdbuf(2, nerr) = compval
8199  END IF
8200  END IF
8201  END IF
8202  105 CONTINUE
8203  100 CONTINUE
8204  RETURN
8205 *
8206 * End of SCHKMAT.
8207 *
8208  END
8209 *
8210  SUBROUTINE sprinterrs( OUTNUM, MAXERR, NERR,
8211  $ ERRIBUF, ERRDBUF, COUNTING, TFAILED )
8212 *
8213 * -- BLACS tester (version 1.0) --
8214 * University of Tennessee
8215 * December 15, 1994
8216 *
8217 *
8218 * .. Scalar Arguments ..
8219  LOGICAL COUNTING
8220  INTEGER OUTNUM, MAXERR, NERR
8221 * ..
8222 * .. Array Arguments ..
8223  INTEGER ERRIBUF(6, MAXERR), TFAILED(*)
8224  REAL ERRDBUF(2, MAXERR)
8225 * ..
8226 *
8227 * Purpose
8228 * =======
8229 * SPRINTERRS: Print errors that have been recorded
8230 *
8231 * Arguments
8232 * =========
8233 * OUTNUM (input) INTEGER
8234 * Device number for output.
8235 *
8236 * MAXERR (input) INTEGER
8237 * Max number of errors that can be stored in ERRIBUFF or
8238 * ERRSBUFF
8239 *
8240 * NERR (output) INTEGER
8241 * The number of errors that have been found.
8242 *
8243 * ERRIBUF (output) INTEGER array, dimension (6,MAXERRS)
8244 * Buffer in which to store integer error information. It will
8245 * be built up in the following format for the call to TSEND.
8246 * All integer information is recorded in the following 6-tuple
8247 * {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured:
8248 * SRC = RSRC * NPROCS + CSRC
8249 * DEST = RDEST * NPROCS + CDEST
8250 * WHAT
8251 * = 1 : Error in pre-padding
8252 * = 2 : Error in post-padding
8253 * = 3 : Error in LDA-M gap
8254 * = 4 : Error in complementory triangle
8255 * ELSE: Error in matrix
8256 * If there are more errors than can fit in the error buffer,
8257 * the error number will indicate the actual number of errors
8258 * found, but the buffer will be truncated to the maximum
8259 * number of errors which can fit.
8260 *
8261 * ERRDBUF (output) @(doctype) array, dimension (2, MAXERRS)
8262 * Buffer in which to store error data information.
8263 * {Incorrect, Predicted}
8264 *
8265 * TFAILED (input/ourput) INTEGER array, dimension NTESTS
8266 * Workspace used to keep track of which tests failed.
8267 * This array not accessed unless COUNTING is true.
8268 *
8269 * ===================================================================
8270 *
8271 * .. Parameters ..
8272  INTEGER ERR_PRE, ERR_POST, ERR_GAP, ERR_TRI, ERR_MAT
8273  PARAMETER( ERR_PRE = 1, err_post = 2, err_gap = 3, err_tri = 4 )
8274  parameter( err_mat = 5 )
8275 * ..
8276 * .. External Functions ..
8277  INTEGER IBTMYPROC, IBTNPROCS
8278  EXTERNAL IBTMYPROC, IBTNPROCS
8279 * ..
8280 * .. Local Scalars ..
8281  CHARACTER*1 MAT
8282  LOGICAL MATISINT
8283  INTEGER OLDTEST, NPROCS, PROW, PCOL, I, ERRTYPE
8284 * ..
8285 * .. Executable Statements ..
8286 *
8287  IF( (ibtmyproc().NE.0) .OR. (nerr.LE.0) ) RETURN
8288  oldtest = -1
8289  nprocs = ibtnprocs()
8290  prow = erribuf(3,1) / nprocs
8291  pcol = mod( erribuf(3,1), nprocs )
8292  IF( nerr .GT. maxerr ) WRITE(outnum,13000)
8293 *
8294  DO 20 i = 1, min( nerr, maxerr )
8295  IF( erribuf(1,i) .NE. oldtest ) THEN
8296  IF( oldtest .NE. -1 )
8297  $ WRITE(outnum,12000) prow, pcol, oldtest
8298  WRITE(outnum,*) ' '
8299  WRITE(outnum,1000) prow, pcol, erribuf(1,i)
8300  IF( counting ) tfailed( erribuf(1,i) ) = 1
8301  oldtest = erribuf(1, i)
8302  END IF
8303 *
8304 * Print out error message depending on type of error
8305 *
8306  errtype = erribuf(6, i)
8307  IF( errtype .LT. -10 ) THEN
8308  errtype = -errtype - 10
8309  mat = 'C'
8310  matisint = .true.
8311  ELSE IF( errtype .LT. 0 ) THEN
8312  errtype = -errtype
8313  mat = 'R'
8314  matisint = .true.
8315  ELSE
8316  matisint = .false.
8317  END IF
8318 *
8319 * RA/CA arrays from MAX/MIN have different printing protocol
8320 *
8321  IF( matisint ) THEN
8322  IF( erribuf(2, i) .EQ. -1 ) THEN
8323  WRITE(outnum,11000) erribuf(4,i), erribuf(5,i), mat,
8324  $ int( errdbuf(2,i) ), int( errdbuf(1,i) )
8325  ELSE IF( errtype .EQ. err_pre ) THEN
8326  WRITE(outnum,7000) erribuf(5,i), mat,
8327  $ int( errdbuf(2,i) ), int( errdbuf(1,i) )
8328  ELSE IF( errtype .EQ. err_post ) THEN
8329  WRITE(outnum,8000) erribuf(4,i), mat,
8330  $ int( errdbuf(2,i) ), int( errdbuf(1,i) )
8331  ELSE IF( errtype .EQ. err_gap ) THEN
8332  WRITE(outnum,9000) mat, erribuf(4,i), erribuf(5,i),
8333  $ int( errdbuf(2,i) ), int( errdbuf(1,i) )
8334  ELSE
8335  WRITE(outnum,10000) mat, erribuf(4,i), erribuf(5,i),
8336  $ int( errdbuf(2,i) ),
8337  $ int( errdbuf(1,i) )
8338  END IF
8339 *
8340 * Have memory overwrites in matrix A
8341 *
8342  ELSE
8343  IF( errtype .EQ. err_pre ) THEN
8344  WRITE(outnum,2000) erribuf(5,i), errdbuf(2,i),
8345  $ errdbuf(1,i)
8346  ELSE IF( errtype .EQ. err_post ) THEN
8347  WRITE(outnum,3000) erribuf(4,i), errdbuf(2,i),
8348  $ errdbuf(1,i)
8349  ELSE IF( errtype .EQ. err_gap ) THEN
8350  WRITE(outnum,4000) erribuf(4,i), erribuf(5,i),
8351  $ errdbuf(2,i), errdbuf(1,i)
8352  ELSE IF( errtype .EQ. err_tri ) THEN
8353  WRITE(outnum,5000) erribuf(4,i), erribuf(5,i),
8354  $ errdbuf(2,i), errdbuf(1,i)
8355  ELSE
8356  WRITE(outnum,6000) erribuf(4,i), erribuf(5,i),
8357  $ errdbuf(2,i), errdbuf(1,i)
8358  END IF
8359  END IF
8360  20 CONTINUE
8361  WRITE(outnum,12000) prow, pcol, oldtest
8362 *
8363  1000 FORMAT('PROCESS {',i4,',',i4,'} REPORTS ERRORS IN TEST#',i6,':')
8364  2000 FORMAT(' Buffer overwrite ',i4,
8365  $ ' elements before the start of A:',/,
8366  $ ' Expected=',g15.8,
8367  $ '; Received=',g15.8)
8368  3000 FORMAT(' Buffer overwrite ',i4,' elements after the end of A:',
8369  $ /,' Expected=',g15.8,
8370  $ '; Received=',g15.8)
8371  4000 FORMAT(' LDA-M gap overwrite at postion (',i4,',',i4,'):',/,
8372  $ ' Expected=',g15.8,
8373  $ '; Received=',g15.8)
8374  5000 FORMAT(' Complementory triangle overwrite at A(',i4,',',i4,
8375  $ '):',/,' Expected=',g15.8,
8376  $ '; Received=',g15.8)
8377  6000 FORMAT(' Invalid element at A(',i4,',',i4,'):',/,
8378  $ ' Expected=',g15.8,
8379  $ '; Received=',g15.8)
8380  7000 FORMAT(' Buffer overwrite ',i4,' elements before the start of ',
8381  $ a1,'A:',/,' Expected=',i12,'; Received=',i12)
8382  8000 FORMAT(' Buffer overwrite ',i4,' elements after the end of ',
8383  $ a1,'A:',/,' Expected=',i12,'; Received=',i12)
8384 *
8385  9000 FORMAT(' LD',a1,'A-M gap overwrite at postion (',i4,',',i4,'):'
8386  $ ,/,' Expected=',i12,'; Received=',i12)
8387 *
8388 10000 FORMAT(' Invalid element at ',a1,'A(',i4,',',i4,'):',/,
8389  $ ' Expected=',i12,'; Received=',i12)
8390 11000 FORMAT(' Overwrite at position (',i4,',',i4,') of non-existent '
8391  $ ,a1,'A array.',/,' Expected=',i12,'; Received=',i12)
8392 12000 FORMAT('PROCESS {',i4,',',i4,'} DONE ERROR REPORT FOR TEST#',
8393  $ i6,'.')
8394 13000 FORMAT('WARNING: There were more errors than could be recorded.',
8395  $ /,'Increase MEMELTS to get complete listing.')
8396  RETURN
8397 *
8398 * End SPRINTERRS
8399 *
8400  END
8401 *
8402 *
8403  SUBROUTINE dbtcheckin( NFTESTS, OUTNUM, MAXERR, NERR, IERR,
8404  $ DVAL, TFAILED )
8405  INTEGER NFTESTS, OUTNUM, MAXERR, NERR
8406  INTEGER IERR(*), TFAILED(*)
8407  DOUBLE PRECISION DVAL(*)
8408 *
8409 * Purpose
8410 * =======
8411 * DBTCHECKIN: Process 0 receives error report from all processes.
8412 *
8413 * Arguments
8414 * =========
8415 * NFTESTS (input/output) INTEGER
8416 * if NFTESTS is <= 0 upon entry, NFTESTS is not written to.
8417 * Otherwise, on entry it specifies the total number of tests
8418 * run, and on exit it is the number of tests which failed.
8419 *
8420 * OUTNUM (input) INTEGER
8421 * Device number for output.
8422 *
8423 * MAXERR (input) INTEGER
8424 * Max number of errors that can be stored in ERRIBUFF or
8425 * ERRDBUFF
8426 *
8427 * NERR (output) INTEGER
8428 * The number of errors that have been found.
8429 *
8430 * ERRIBUF (output) INTEGER array, dimension (6,MAXERRS)
8431 * Buffer in which to store integer error information. It will
8432 * be built up in the following format for the call to TSEND.
8433 * All integer information is recorded in the following 6-tuple
8434 * {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured:
8435 * SRC = RSRC * NPROCS + CSRC
8436 * DEST = RDEST * NPROCS + CDEST
8437 * WHAT
8438 * = 1 : Error in pre-padding
8439 * = 2 : Error in post-padding
8440 * = 3 : Error in LDA-M gap
8441 * = 4 : Error in complementory triangle
8442 * ELSE: Error in matrix
8443 * If there are more errors than can fit in the error buffer,
8444 * the error number will indicate the actual number of errors
8445 * found, but the buffer will be truncated to the maximum
8446 * number of errors which can fit.
8447 *
8448 * ERRDBUF (output) @(doctype) array, dimension (2, MAXERRS)
8449 * Buffer in which to store error data information.
8450 * {Incorrect, Predicted}
8451 *
8452 * TFAILED (workspace) INTEGER array, dimension NFTESTS
8453 * Workspace used to keep track of which tests failed.
8454 * If input of NFTESTS < 1, this array not accessed.
8455 *
8456 * ===================================================================
8457 *
8458 * .. External Functions ..
8459  INTEGER IBTMYPROC, IBTNPROCS, IBTMSGID
8460  EXTERNAL IBTMYPROC, IBTNPROCS, IBTMSGID
8461 * ..
8462 * .. Local Scalars ..
8463  LOGICAL COUNTING
8464  INTEGER K, NERR2, IAM, NPROCS, NTESTS
8465 *
8466 * Proc 0 collects error info from everyone
8467 *
8468  iam = ibtmyproc()
8469  nprocs = ibtnprocs()
8470 *
8471  IF( iam .EQ. 0 ) THEN
8472 *
8473 * If we are finding out how many failed tests there are, initialize
8474 * the total number of tests (NTESTS), and zero the test failed array
8475 *
8476  counting = nftests .GT. 0
8477  IF( counting ) THEN
8478  ntests = nftests
8479  DO 10 k = 1, ntests
8480  tfailed(k) = 0
8481  10 CONTINUE
8482  END IF
8483 *
8484  CALL dprinterrs(outnum, maxerr, nerr, ierr, dval, counting,
8485  $ tfailed)
8486 *
8487  DO 20 k = 1, nprocs-1
8488  CALL btsend(3, 0, k, k, ibtmsgid()+50)
8489  CALL btrecv(3, 1, nerr2, k, ibtmsgid()+50)
8490  IF( nerr2 .GT. 0 ) THEN
8491  nerr = nerr + nerr2
8492  CALL btrecv(3, nerr2*6, ierr, k, ibtmsgid()+51)
8493  CALL btrecv(6, nerr2*2, dval, k, ibtmsgid()+51)
8494  CALL dprinterrs(outnum, maxerr, nerr2, ierr, dval,
8495  $ counting, tfailed)
8496  END IF
8497  20 CONTINUE
8498 *
8499 * Count up number of tests that failed
8500 *
8501  IF( counting ) THEN
8502  nftests = 0
8503  DO 30 k = 1, ntests
8504  nftests = nftests + tfailed(k)
8505  30 CONTINUE
8506  END IF
8507 *
8508 * Send my error info to proc 0
8509 *
8510  ELSE
8511  CALL btrecv(3, 0, k, 0, ibtmsgid()+50)
8512  CALL btsend(3, 1, nerr, 0, ibtmsgid()+50)
8513  IF( nerr .GT. 0 ) THEN
8514  CALL btsend(3, nerr*6, ierr, 0, ibtmsgid()+51)
8515  CALL btsend(6, nerr*2, dval, 0, ibtmsgid()+51)
8516  END IF
8517  ENDIF
8518 *
8519  RETURN
8520 *
8521 * End of DBTCHECKIN
8522 *
8523  END
8524 *
8525  SUBROUTINE dinitmat(UPLO, DIAG, M, N, MEM, LDA, IPRE, IPOST,
8526  $ CHECKVAL, TESTNUM, MYROW, MYCOL)
8527  CHARACTER*1 UPLO, DIAG
8528  INTEGER M, N, LDA, IPRE, IPOST, TESTNUM, MYROW, MYCOL
8529  DOUBLE PRECISION CHECKVAL
8530  DOUBLE PRECISION MEM(*)
8531 *
8532 * .. External Subroutines ..
8533  EXTERNAL dgenmat, dpadmat
8534 * ..
8535 * .. Executable Statements ..
8536 *
8537  CALL dgenmat( m, n, mem(ipre+1), lda, testnum, myrow, mycol )
8538  CALL dpadmat( uplo, diag, m, n, mem, lda, ipre, ipost, checkval )
8539 *
8540  RETURN
8541  END
8542 *
8543  SUBROUTINE dgenmat( M, N, A, LDA, TESTNUM, MYROW, MYCOL )
8544 *
8545 * -- BLACS tester (version 1.0) --
8546 * University of Tennessee
8547 * December 15, 1994
8548 *
8549 *
8550 * .. Scalar Arguments ..
8551  INTEGER M, N, LDA, TESTNUM, MYROW, MYCOL
8552 * ..
8553 * .. Array Arguments ..
8554  DOUBLE PRECISION A(LDA,N)
8555 * ..
8556 *
8557 * Purpose
8558 * =======
8559 * DGENMAT: Generates an M-by-N matrix filled with random elements.
8560 *
8561 * Arguments
8562 * =========
8563 * M (input) INTEGER
8564 * The number of rows of the matrix A. M >= 0.
8565 *
8566 * N (input) INTEGER
8567 * The number of columns of the matrix A. N >= 0.
8568 *
8569 * A (output) @up@(doctype) array, dimension (LDA,N)
8570 * The m by n matrix A. Fortran77 (column-major) storage
8571 * assumed.
8572 *
8573 * LDA (input) INTEGER
8574 * The leading dimension of the array A. LDA >= max(1, M).
8575 *
8576 * TESTNUM (input) INTEGER
8577 * Unique number for this test case, used as a basis for
8578 * the random seeds.
8579 *
8580 * ====================================================================
8581 *
8582 * .. External Functions ..
8583  INTEGER IBTNPROCS
8584  DOUBLE PRECISION DBTRAN
8585  EXTERNAL DBTRAN, IBTNPROCS
8586 * ..
8587 * .. Local Scalars ..
8588  INTEGER I, J, NPROCS, SRC
8589 * ..
8590 * .. Local Arrays ..
8591  INTEGER ISEED(4)
8592 * ..
8593 * .. Executable Statements ..
8594 *
8595 * ISEED's four values must be positive integers less than 4096,
8596 * fourth one has to be odd. (see _LARND). Use some goofy
8597 * functions to come up with seed values which together should
8598 * be unique.
8599 *
8600  nprocs = ibtnprocs()
8601  src = myrow * nprocs + mycol
8602  iseed(1) = mod( 1002 + testnum*5 + src*3, 4096 )
8603  iseed(2) = mod( 2027 + testnum*7 + src, 4096 )
8604  iseed(3) = mod( 1234 + testnum + src*3, 4096 )
8605  iseed(4) = mod( 4311 + testnum*10 + src*2, 4096 )
8606 *
8607  DO 10 j = 1, n
8608  DO 10 i = 1, m
8609  a(i, j) = dbtran( iseed )
8610  10 CONTINUE
8611 *
8612  RETURN
8613 *
8614 * End of DGENMAT.
8615 *
8616  END
8617 *
8618  DOUBLE PRECISION FUNCTION dbtran(ISEED)
8619  INTEGER iseed(*)
8620 *
8621 * .. External Functions ..
8622  DOUBLE PRECISION dlarnd
8623  EXTERNAL dlarnd
8624 * .. Executable Statements ..
8625 *
8626  dbtran = dlarnd(2, iseed)
8627 *
8628  RETURN
8629 *
8630 * End of Dbtran
8631 *
8632  END
8633 *
8634  SUBROUTINE dpadmat( UPLO, DIAG, M, N, MEM, LDA, IPRE, IPOST,
8635  $ CHECKVAL )
8636 *
8637 * -- BLACS tester (version 1.0) --
8638 * University of Tennessee
8639 * December 15, 1994
8640 *
8641 * .. Scalar Arguments ..
8642  CHARACTER*1 UPLO, DIAG
8643  INTEGER M, N, LDA, IPRE, IPOST
8644  DOUBLE PRECISION CHECKVAL
8645 * ..
8646 * .. Array Arguments ..
8647  DOUBLE PRECISION MEM( * )
8648 * ..
8649 *
8650 * Purpose
8651 * =======
8652 *
8653 * DPADMAT: Pad Matrix.
8654 * This routines surrounds a matrix with a guardzone initialized to the
8655 * value CHECKVAL. There are three distinct guardzones:
8656 * - A contiguous zone of size IPRE immediately before the start
8657 * of the matrix.
8658 * - A contiguous zone of size IPOST immedately after the end of the
8659 * matrix.
8660 * - Interstitial zones within each column of the matrix, in the
8661 * elements A( M+1:LDA, J ).
8662 *
8663 * Arguments
8664 * =========
8665 * UPLO (input) CHARACTER*1
8666 * Is the matrix A 'U'pper or 'L'ower trapezoidal, or 'G'eneral
8667 * rectangular?
8668 *
8669 * DIAG (input) CHARACTER*1
8670 * For trapezoidal matrices, is the main diagonal included
8671 * ('N') or not ('U')?
8672 *
8673 * M (input) INTEGER
8674 * The number of rows of the matrix A. M >= 0.
8675 *
8676 * N (input) INTEGER
8677 * The number of columns of the matrix A. N >= 0.
8678 *
8679 * MEM (output) double precision array, dimension (IPRE+IPOST+LDA*N)
8680 * The address IPRE elements ahead of the matrix A you want to
8681 * pad, which is then of dimension (LDA,N).
8682 *
8683 * IPRE (input) INTEGER
8684 * The size of the guard zone ahead of the matrix A.
8685 *
8686 * IPOST (input) INTEGER
8687 * The size of the guard zone behind the matrix A.
8688 *
8689 * CHECKVAL (input) double precision
8690 * The value to insert into the guard zones.
8691 *
8692 * ====================================================================
8693 *
8694 * .. Local Scalars ..
8695  INTEGER I, J, K
8696 * ..
8697 * .. Executable Statements ..
8698 *
8699 * Put check buffer in front of A
8700 *
8701  IF( ipre .GT. 0 ) THEN
8702  DO 10 i = 1, ipre
8703  mem( i ) = checkval
8704  10 CONTINUE
8705  END IF
8706 *
8707 * Put check buffer in back of A
8708 *
8709  IF( ipost .GT. 0 ) THEN
8710  j = ipre + lda*n + 1
8711  DO 20 i = j, j+ipost-1
8712  mem( i ) = checkval
8713  20 CONTINUE
8714  END IF
8715 *
8716 * Put check buffer in all (LDA-M) gaps
8717 *
8718  IF( lda .GT. m ) THEN
8719  k = ipre + m + 1
8720  DO 40 j = 1, n
8721  DO 30 i = k, k+lda-m-1
8722  mem( i ) = checkval
8723  30 CONTINUE
8724  k = k + lda
8725  40 CONTINUE
8726  END IF
8727 *
8728 * If the matrix is upper or lower trapezoidal, calculate the
8729 * additional triangular area which needs to be padded, Each
8730 * element referred to is in the Ith row and the Jth column.
8731 *
8732  IF( uplo .EQ. 'U' ) THEN
8733  IF( m .LE. n ) THEN
8734  IF( diag .EQ. 'U' ) THEN
8735  DO 41 i = 1, m
8736  DO 42 j = 1, i
8737  k = ipre + i + (j-1)*lda
8738  mem( k ) = checkval
8739  42 CONTINUE
8740  41 CONTINUE
8741  ELSE
8742  DO 43 i = 2, m
8743  DO 44 j = 1, i-1
8744  k = ipre + i + (j-1)*lda
8745  mem( k ) = checkval
8746  44 CONTINUE
8747  43 CONTINUE
8748  END IF
8749  ELSE
8750  IF( diag .EQ. 'U' ) THEN
8751  DO 45 i = m-n+1, m
8752  DO 46 j = 1, i-(m-n)
8753  k = ipre + i + (j-1)*lda
8754  mem( k ) = checkval
8755  46 CONTINUE
8756  45 CONTINUE
8757  ELSE
8758  DO 47 i = m-n+2, m
8759  DO 48 j = 1, i-(m-n)-1
8760  k = ipre + i + (j-1)*lda
8761  mem( k ) = checkval
8762  48 CONTINUE
8763  47 CONTINUE
8764  END IF
8765  END IF
8766  ELSE IF( uplo .EQ. 'L' ) THEN
8767  IF( m .LE. n ) THEN
8768  IF( diag .EQ. 'U' ) THEN
8769  DO 49 i = 1, m
8770  DO 50 j = n-m+i, n
8771  k = ipre + i + (j-1)*lda
8772  mem( k ) = checkval
8773  50 CONTINUE
8774  49 CONTINUE
8775  ELSE
8776  DO 51 i = 1, m-1
8777  DO 52 j = n-m+i+1, n
8778  k = ipre + i + (j-1)*lda
8779  mem( k ) = checkval
8780  52 CONTINUE
8781  51 CONTINUE
8782  END IF
8783  ELSE
8784  IF( uplo .EQ. 'U' ) THEN
8785  DO 53 i = 1, n
8786  DO 54 j = i, n
8787  k = ipre + i + (j-1)*lda
8788  mem( k ) = checkval
8789  54 CONTINUE
8790  53 CONTINUE
8791  ELSE
8792  DO 55 i = 1, n-1
8793  DO 56 j = i+1, n
8794  k = ipre + i + (j-1)*lda
8795  mem( k ) = checkval
8796  56 CONTINUE
8797  55 CONTINUE
8798  END IF
8799  END IF
8800  END IF
8801 *
8802 * End of DPADMAT.
8803 *
8804  RETURN
8805  END
8806 *
8807  SUBROUTINE dchkpad( UPLO, DIAG, M, N, MEM, LDA, RSRC, CSRC,
8808  $ MYROW, MYCOL, IPRE, IPOST, CHECKVAL,
8809  $ TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF )
8810 *
8811 * -- BLACS tester (version 1.0) --
8812 * University of Tennessee
8813 * December 15, 1994
8814 *
8815 *
8816 * .. Scalar Arguments ..
8817  CHARACTER*1 UPLO, DIAG
8818  INTEGER M, N, LDA, RSRC, CSRC, MYROW, MYCOL, IPRE, IPOST
8819  INTEGER TESTNUM, MAXERR, NERR
8820  DOUBLE PRECISION CHECKVAL
8821 * ..
8822 * .. Array Arguments ..
8823  INTEGER ERRIBUF(6, MAXERR)
8824  DOUBLE PRECISION MEM(*), ERRDBUF(2, MAXERR)
8825 * ..
8826 *
8827 * Purpose
8828 * =======
8829 * DCHKPAD: Check padding put in by PADMAT.
8830 * Checks that padding around target matrix has not been overwritten
8831 * by the previous point-to-point or broadcast send.
8832 *
8833 * Arguments
8834 * =========
8835 * UPLO (input) CHARACTER*1
8836 * Is the matrix A 'U'pper or 'L'ower trapezoidal, or 'G'eneral
8837 * rectangular?
8838 *
8839 * DIAG (input) CHARACTER*1
8840 * For trapezoidal matrices, is the main diagonal included
8841 * ('N') or not ('U')?
8842 *
8843 * M (input) INTEGER
8844 * The number of rows of the matrix A. M >= 0.
8845 *
8846 * N (input) INTEGER
8847 * The number of columns of the matrix A. N >= 0.
8848 *
8849 * MEM (input) double precision array, dimension(IPRE+IPOST+LDA*N).
8850 * Memory location IPRE elements in front of the matrix A.
8851 *
8852 * LDA (input) INTEGER
8853 * The leading dimension of the array A. LDA >= max(1, M).
8854 *
8855 * RSRC (input) INTEGER
8856 * The process row of the source of the matrix.
8857 *
8858 * CSRC (input) INTEGER
8859 * The process column of the source of the matrix.
8860 *
8861 * MYROW (input) INTEGER
8862 * Row of this process in the process grid.
8863 *
8864 * MYCOL (input) INTEGER
8865 * Column of this process in the process grid.
8866 *
8867 * IPRE (input) INTEGER
8868 * The size of the guard zone before the start of A.
8869 *
8870 * IPOST (input) INTEGER
8871 * The size of guard zone after A.
8872 *
8873 * CHECKVAL (input) double precision
8874 * The value to pad matrix with.
8875 *
8876 * TESTNUM (input) INTEGER
8877 * The number of the test being checked.
8878 *
8879 * MAXERR (input) INTEGER
8880 * Max number of errors that can be stored in ERRIBUFF or
8881 * ERRDBUFF
8882 *
8883 * NERR (output) INTEGER
8884 * The number of errors that have been found.
8885 *
8886 * ERRIBUF (output) INTEGER array, dimension (6,MAXERRS)
8887 * Buffer in which to store integer error information. It will
8888 * be built up in the following format for the call to TSEND.
8889 * All integer information is recorded in the following 6-tuple
8890 * {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured:
8891 * SRC = RSRC * NPROCS + CSRC
8892 * DEST = RDEST * NPROCS + CDEST
8893 * WHAT
8894 * = 1 : Error in pre-padding
8895 * = 2 : Error in post-padding
8896 * = 3 : Error in LDA-M gap
8897 * = 4 : Error in complementory triangle
8898 * ELSE: Error in matrix
8899 * If there are more errors than can fit in the error buffer,
8900 * the error number will indicate the actual number of errors
8901 * found, but the buffer will be truncated to the maximum
8902 * number of errors which can fit.
8903 *
8904 * ERRDBUF (output) @(doctype) array, dimension (2, MAXERRS)
8905 * Buffer in which to store error data information.
8906 * {Incorrect, Predicted}
8907 *
8908 * ===================================================================
8909 *
8910 * .. Parameters ..
8911  INTEGER ERR_PRE, ERR_POST, ERR_GAP, ERR_TRI, ERR_MAT
8912  PARAMETER( ERR_PRE = 1, err_post = 2, err_gap = 3, err_tri = 4 )
8913  parameter( err_mat = 5 )
8914 * ..
8915 * .. External Functions ..
8916  INTEGER IBTNPROCS
8917  EXTERNAL IBTNPROCS
8918 * ..
8919 * .. Local Scalars ..
8920  LOGICAL ISTRAP
8921  INTEGER I, J, K, IRST, IRND, ICST, ICND, SRC, DEST
8922  INTEGER NPROCS
8923 * ..
8924 * .. Executable Statements ..
8925 *
8926  NPROCS = ibtnprocs()
8927  src = rsrc * nprocs + csrc
8928  dest = myrow * nprocs + mycol
8929 *
8930 * Check buffer in front of A
8931 *
8932  IF( ipre .GT. 0 ) THEN
8933  DO 10 i = 1, ipre
8934  IF( mem(i) .NE. checkval ) THEN
8935  nerr = nerr + 1
8936  IF( nerr .LE. maxerr ) THEN
8937  erribuf(1, nerr) = testnum
8938  erribuf(2, nerr) = src
8939  erribuf(3, nerr) = dest
8940  erribuf(4, nerr) = i
8941  erribuf(5, nerr) = ipre - i + 1
8942  erribuf(6, nerr) = err_pre
8943  errdbuf(1, nerr) = mem(i)
8944  errdbuf(2, nerr) = checkval
8945  END IF
8946  END IF
8947  10 CONTINUE
8948  END IF
8949 *
8950 * Check buffer behind A
8951 *
8952  IF( ipost .GT. 0 ) THEN
8953  j = ipre + lda*n + 1
8954  DO 20 i = j, j+ipost-1
8955  IF( mem(i) .NE. checkval ) THEN
8956  nerr = nerr + 1
8957  IF( nerr .LE. maxerr ) THEN
8958  erribuf(1, nerr) = testnum
8959  erribuf(2, nerr) = src
8960  erribuf(3, nerr) = dest
8961  erribuf(4, nerr) = i - j + 1
8962  erribuf(5, nerr) = j
8963  erribuf(6, nerr) = err_post
8964  errdbuf(1, nerr) = mem(i)
8965  errdbuf(2, nerr) = checkval
8966  END IF
8967  END IF
8968  20 CONTINUE
8969  END IF
8970 *
8971 * Check all (LDA-M) gaps
8972 *
8973  IF( lda .GT. m ) THEN
8974  DO 40 j = 1, n
8975  DO 30 i = m+1, lda
8976  k = ipre + (j-1)*lda + i
8977  IF( mem(k) .NE. checkval) THEN
8978  nerr = nerr + 1
8979  IF( nerr .LE. maxerr ) THEN
8980  erribuf(1, nerr) = testnum
8981  erribuf(2, nerr) = src
8982  erribuf(3, nerr) = dest
8983  erribuf(4, nerr) = i
8984  erribuf(5, nerr) = j
8985  erribuf(6, nerr) = err_gap
8986  errdbuf(1, nerr) = mem(k)
8987  errdbuf(2, nerr) = checkval
8988  END IF
8989  END IF
8990  30 CONTINUE
8991  40 CONTINUE
8992  END IF
8993 *
8994 * Determine limits of trapezoidal matrix
8995 *
8996  istrap = .false.
8997  IF( uplo .EQ. 'U' ) THEN
8998  istrap = .true.
8999  IF( m .LE. n ) THEN
9000  irst = 2
9001  irnd = m
9002  icst = 1
9003  icnd = m - 1
9004  ELSEIF( m .GT. n ) THEN
9005  irst = ( m-n ) + 2
9006  irnd = m
9007  icst = 1
9008  icnd = n - 1
9009  ENDIF
9010  IF( diag .EQ. 'U' ) THEN
9011  irst = irst - 1
9012  icnd = icnd + 1
9013  ENDIF
9014  ELSE IF( uplo .EQ. 'L' ) THEN
9015  istrap = .true.
9016  IF( m .LE. n ) THEN
9017  irst = 1
9018  irnd = 1
9019  icst = ( n-m ) + 2
9020  icnd = n
9021  ELSEIF( m .GT. n ) THEN
9022  irst = 1
9023  irnd = 1
9024  icst = 2
9025  icnd = n
9026  ENDIF
9027  IF( diag .EQ. 'U' ) THEN
9028  icst = icst - 1
9029  ENDIF
9030  ENDIF
9031 *
9032 * Check elements and report any errors
9033 *
9034  IF( istrap ) THEN
9035  DO 100 j = icst, icnd
9036  DO 105 i = irst, irnd
9037  IF( mem( ipre + (j-1)*lda + i ) .NE. checkval ) THEN
9038  nerr = nerr + 1
9039  IF( nerr .LE. maxerr ) THEN
9040  erribuf(1, nerr) = testnum
9041  erribuf(2, nerr) = src
9042  erribuf(3, nerr) = dest
9043  erribuf(4, nerr) = i
9044  erribuf(5, nerr) = j
9045  erribuf(6, nerr) = err_tri
9046  errdbuf(1, nerr) = mem( ipre + (j-1)*lda + i )
9047  errdbuf(2, nerr) = checkval
9048  END IF
9049  END IF
9050  105 CONTINUE
9051 *
9052 * Update the limits to allow filling in padding
9053 *
9054  IF( uplo .EQ. 'U' ) THEN
9055  irst = irst + 1
9056  ELSE
9057  irnd = irnd + 1
9058  ENDIF
9059  100 CONTINUE
9060  END IF
9061 *
9062  RETURN
9063 *
9064 * End of DCHKPAD.
9065 *
9066  END
9067 *
9068  SUBROUTINE dchkmat( UPLO, DIAG, M, N, A, LDA, RSRC, CSRC,
9069  $ MYROW, MYCOL, TESTNUM, MAXERR, NERR,
9070  $ ERRIBUF, ERRDBUF )
9071 *
9072 * -- BLACS tester (version 1.0) --
9073 * University of Tennessee
9074 * December 15, 1994
9075 *
9076 *
9077 * .. Scalar Arguments ..
9078  CHARACTER*1 UPLO, DIAG
9079  INTEGER M, N, LDA, RSRC, CSRC, MYROW, MYCOL, TESTNUM
9080  INTEGER MAXERR, NERR
9081 * ..
9082 * .. Array Arguments ..
9083  INTEGER ERRIBUF(6, MAXERR)
9084  DOUBLE PRECISION A(LDA,N), ERRDBUF(2, MAXERR)
9085 * ..
9086 *
9087 * Purpose
9088 * =======
9089 * dCHKMAT: Check matrix to see whether there were any transmission
9090 * errors.
9091 *
9092 * Arguments
9093 * =========
9094 * UPLO (input) CHARACTER*1
9095 * Is the matrix A 'U'pper or 'L'ower trapezoidal, or 'G'eneral
9096 * rectangular?
9097 *
9098 * DIAG (input) CHARACTER*1
9099 * For trapezoidal matrices, is the main diagonal included
9100 * ('N') or not ('U')?
9101 *
9102 * M (input) INTEGER
9103 * The number of rows of the matrix A. M >= 0.
9104 *
9105 * N (input) INTEGER
9106 * The number of columns of the matrix A. N >= 0.
9107 *
9108 * A (input) @up@(doctype) array, dimension (LDA,N)
9109 * The m by n matrix A. Fortran77 (column-major) storage
9110 * assumed.
9111 *
9112 * LDA (input) INTEGER
9113 * The leading dimension of the array A. LDA >= max(1, M).
9114 *
9115 * RSRC (input) INTEGER
9116 * The process row of the source of the matrix.
9117 *
9118 * CSRC (input) INTEGER
9119 * The process column of the source of the matrix.
9120 *
9121 * MYROW (input) INTEGER
9122 * Row of this process in the process grid.
9123 *
9124 * MYCOL (input) INTEGER
9125 * Column of this process in the process grid.
9126 *
9127 *
9128 * TESTNUM (input) INTEGER
9129 * The number of the test being checked.
9130 *
9131 * MAXERR (input) INTEGER
9132 * Max number of errors that can be stored in ERRIBUFF or
9133 * ERRDBUFF
9134 *
9135 * NERR (output) INTEGER
9136 * The number of errors that have been found.
9137 *
9138 * ERRIBUF (output) INTEGER array, dimension (6,MAXERRS)
9139 * Buffer in which to store integer error information. It will
9140 * be built up in the following format for the call to TSEND.
9141 * All integer information is recorded in the following 6-tuple
9142 * {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured:
9143 * SRC = RSRC * NPROCS + CSRC
9144 * DEST = RDEST * NPROCS + CDEST
9145 * WHAT
9146 * = 1 : Error in pre-padding
9147 * = 2 : Error in post-padding
9148 * = 3 : Error in LDA-M gap
9149 * = 4 : Error in complementory triangle
9150 * ELSE: Error in matrix
9151 * If there are more errors than can fit in the error buffer,
9152 * the error number will indicate the actual number of errors
9153 * found, but the buffer will be truncated to the maximum
9154 * number of errors which can fit.
9155 *
9156 * ERRDBUF (output) @(doctype) array, dimension (2, MAXERRS)
9157 * Buffer in which to store error data information.
9158 * {Incorrect, Predicted}
9159 *
9160 * ===================================================================
9161 *
9162 * .. Local Scalars ..
9163  INTEGER I, J, NPROCS, SRC, DEST
9164  LOGICAL USEIT
9165  DOUBLE PRECISION COMPVAL
9166 * ..
9167 * .. Local Arrays ..
9168  INTEGER ISEED(4)
9169 * ..
9170 * .. External Functions ..
9171  INTEGER IBTNPROCS
9172  DOUBLE PRECISION DBTRAN
9173  EXTERNAL DBTRAN, IBTNPROCS
9174 * ..
9175 * .. Executable Statements ..
9176 *
9177  NPROCS = ibtnprocs()
9178  src = rsrc * nprocs + csrc
9179  dest = myrow * nprocs + mycol
9180 *
9181 * Initialize ISEED with the same values as used in DGENMAT.
9182 *
9183  iseed(1) = mod( 1002 + testnum*5 + src*3, 4096 )
9184  iseed(2) = mod( 2027 + testnum*7 + src, 4096 )
9185  iseed(3) = mod( 1234 + testnum + src*3, 4096 )
9186  iseed(4) = mod( 4311 + testnum*10 + src*2, 4096 )
9187 *
9188 * Generate the elements randomly with the same method used in GENMAT.
9189 * Note that for trapezoidal matrices, we generate all elements in the
9190 * enclosing rectangle and then ignore the complementary triangle.
9191 *
9192  DO 100 j = 1, n
9193  DO 105 i = 1, m
9194  compval = dbtran( iseed )
9195 *
9196 * Now determine whether we actually need this value. The
9197 * strategy is to chop out the proper triangle based on what
9198 * particular kind of trapezoidal matrix we're dealing with.
9199 *
9200  useit = .true.
9201  IF( uplo .EQ. 'U' ) THEN
9202  IF( m .LE. n ) THEN
9203  IF( diag .EQ. 'U' ) THEN
9204  IF( i .GE. j ) THEN
9205  useit = .false.
9206  END IF
9207  ELSE
9208  IF( i .GT. j ) THEN
9209  useit = .false.
9210  END IF
9211  END IF
9212  ELSE
9213  IF( diag .EQ. 'U' ) THEN
9214  IF( i .GE. m-n+j ) THEN
9215  useit = .false.
9216  END IF
9217  ELSE
9218  IF( i .GT. m-n+j ) THEN
9219  useit = .false.
9220  END IF
9221  END IF
9222  END IF
9223  ELSE IF( uplo .EQ. 'L' ) THEN
9224  IF( m .LE. n ) THEN
9225  IF( diag .EQ. 'U' ) THEN
9226  IF( j. ge. i+(n-m) ) THEN
9227  useit = .false.
9228  END IF
9229  ELSE
9230  IF( j .GT. i+(n-m) ) THEN
9231  useit = .false.
9232  END IF
9233  END IF
9234  ELSE
9235  IF( diag .EQ. 'U' ) THEN
9236  IF( j .GE. i ) THEN
9237  useit = .false.
9238  END IF
9239  ELSE
9240  IF( j .GT. i ) THEN
9241  useit = .false.
9242  END IF
9243  END IF
9244  END IF
9245  END IF
9246 *
9247 * Compare the generated value to the one that's in the
9248 * received matrix. If they don't match, tack another
9249 * error record onto what's already there.
9250 *
9251  IF( useit ) THEN
9252  IF( a(i,j) .NE. compval ) THEN
9253  nerr = nerr + 1
9254  IF( nerr .LE. maxerr ) THEN
9255  erribuf(1, nerr) = testnum
9256  erribuf(2, nerr) = src
9257  erribuf(3, nerr) = dest
9258  erribuf(4, nerr) = i
9259  erribuf(5, nerr) = j
9260  erribuf(6, nerr) = 5
9261  errdbuf(1, nerr) = a(i, j)
9262  errdbuf(2, nerr) = compval
9263  END IF
9264  END IF
9265  END IF
9266  105 CONTINUE
9267  100 CONTINUE
9268  RETURN
9269 *
9270 * End of DCHKMAT.
9271 *
9272  END
9273 *
9274  SUBROUTINE dprinterrs( OUTNUM, MAXERR, NERR,
9275  $ ERRIBUF, ERRDBUF, COUNTING, TFAILED )
9276 *
9277 * -- BLACS tester (version 1.0) --
9278 * University of Tennessee
9279 * December 15, 1994
9280 *
9281 *
9282 * .. Scalar Arguments ..
9283  LOGICAL COUNTING
9284  INTEGER OUTNUM, MAXERR, NERR
9285 * ..
9286 * .. Array Arguments ..
9287  INTEGER ERRIBUF(6, MAXERR), TFAILED(*)
9288  DOUBLE PRECISION ERRDBUF(2, MAXERR)
9289 * ..
9290 *
9291 * Purpose
9292 * =======
9293 * DPRINTERRS: Print errors that have been recorded
9294 *
9295 * Arguments
9296 * =========
9297 * OUTNUM (input) INTEGER
9298 * Device number for output.
9299 *
9300 * MAXERR (input) INTEGER
9301 * Max number of errors that can be stored in ERRIBUFF or
9302 * ERRDBUFF
9303 *
9304 * NERR (output) INTEGER
9305 * The number of errors that have been found.
9306 *
9307 * ERRIBUF (output) INTEGER array, dimension (6,MAXERRS)
9308 * Buffer in which to store integer error information. It will
9309 * be built up in the following format for the call to TSEND.
9310 * All integer information is recorded in the following 6-tuple
9311 * {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured:
9312 * SRC = RSRC * NPROCS + CSRC
9313 * DEST = RDEST * NPROCS + CDEST
9314 * WHAT
9315 * = 1 : Error in pre-padding
9316 * = 2 : Error in post-padding
9317 * = 3 : Error in LDA-M gap
9318 * = 4 : Error in complementory triangle
9319 * ELSE: Error in matrix
9320 * If there are more errors than can fit in the error buffer,
9321 * the error number will indicate the actual number of errors
9322 * found, but the buffer will be truncated to the maximum
9323 * number of errors which can fit.
9324 *
9325 * ERRDBUF (output) @(doctype) array, dimension (2, MAXERRS)
9326 * Buffer in which to store error data information.
9327 * {Incorrect, Predicted}
9328 *
9329 * TFAILED (input/ourput) INTEGER array, dimension NTESTS
9330 * Workspace used to keep track of which tests failed.
9331 * This array not accessed unless COUNTING is true.
9332 *
9333 * ===================================================================
9334 *
9335 * .. Parameters ..
9336  INTEGER ERR_PRE, ERR_POST, ERR_GAP, ERR_TRI, ERR_MAT
9337  parameter( err_pre = 1, err_post = 2, err_gap = 3, err_tri = 4 )
9338  parameter( err_mat = 5 )
9339 * ..
9340 * .. External Functions ..
9341  INTEGER IBTMYPROC, IBTNPROCS
9342  EXTERNAL ibtmyproc, ibtnprocs
9343 * ..
9344 * .. Local Scalars ..
9345  CHARACTER*1 MAT
9346  LOGICAL MATISINT
9347  INTEGER OLDTEST, NPROCS, PROW, PCOL, I, ERRTYPE
9348 * ..
9349 * .. Executable Statements ..
9350 *
9351  IF( (IBTMYPROC().NE.0) .OR. (NERR.LE.0) ) RETURN
9352  OLDTEST = -1
9353  nprocs = ibtnprocs()
9354  prow = erribuf(3,1) / nprocs
9355  pcol = mod( erribuf(3,1), nprocs )
9356  IF( nerr .GT. maxerr ) WRITE(outnum,13000)
9357 *
9358  DO 20 i = 1, min( nerr, maxerr )
9359  IF( erribuf(1,i) .NE. oldtest ) THEN
9360  IF( oldtest .NE. -1 )
9361  $ WRITE(outnum,12000) prow, pcol, oldtest
9362  WRITE(outnum,*) ' '
9363  WRITE(outnum,1000) prow, pcol, erribuf(1,i)
9364  IF( counting ) tfailed( erribuf(1,i) ) = 1
9365  oldtest = erribuf(1, i)
9366  END IF
9367 *
9368 * Print out error message depending on type of error
9369 *
9370  errtype = erribuf(6, i)
9371  IF( errtype .LT. -10 ) THEN
9372  errtype = -errtype - 10
9373  mat = 'C'
9374  matisint = .true.
9375  ELSE IF( errtype .LT. 0 ) THEN
9376  errtype = -errtype
9377  mat = 'R'
9378  matisint = .true.
9379  ELSE
9380  matisint = .false.
9381  END IF
9382 *
9383 * RA/CA arrays from MAX/MIN have different printing protocol
9384 *
9385  IF( matisint ) THEN
9386  IF( erribuf(2, i) .EQ. -1 ) THEN
9387  WRITE(outnum,11000) erribuf(4,i), erribuf(5,i), mat,
9388  $ int( errdbuf(2,i) ), int( errdbuf(1,i) )
9389  ELSE IF( errtype .EQ. err_pre ) THEN
9390  WRITE(outnum,7000) erribuf(5,i), mat,
9391  $ int( errdbuf(2,i) ), int( errdbuf(1,i) )
9392  ELSE IF( errtype .EQ. err_post ) THEN
9393  WRITE(outnum,8000) erribuf(4,i), mat,
9394  $ int( errdbuf(2,i) ), int( errdbuf(1,i) )
9395  ELSE IF( errtype .EQ. err_gap ) THEN
9396  WRITE(outnum,9000) mat, erribuf(4,i), erribuf(5,i),
9397  $ int( errdbuf(2,i) ), int( errdbuf(1,i) )
9398  ELSE
9399  WRITE(outnum,10000) mat, erribuf(4,i), erribuf(5,i),
9400  $ int( errdbuf(2,i) ),
9401  $ int( errdbuf(1,i) )
9402  END IF
9403 *
9404 * Have memory overwrites in matrix A
9405 *
9406  ELSE
9407  IF( errtype .EQ. err_pre ) THEN
9408  WRITE(outnum,2000) erribuf(5,i), errdbuf(2,i),
9409  $ errdbuf(1,i)
9410  ELSE IF( errtype .EQ. err_post ) THEN
9411  WRITE(outnum,3000) erribuf(4,i), errdbuf(2,i),
9412  $ errdbuf(1,i)
9413  ELSE IF( errtype .EQ. err_gap ) THEN
9414  WRITE(outnum,4000) erribuf(4,i), erribuf(5,i),
9415  $ errdbuf(2,i), errdbuf(1,i)
9416  ELSE IF( errtype .EQ. err_tri ) THEN
9417  WRITE(outnum,5000) erribuf(4,i), erribuf(5,i),
9418  $ errdbuf(2,i), errdbuf(1,i)
9419  ELSE
9420  WRITE(outnum,6000) erribuf(4,i), erribuf(5,i),
9421  $ errdbuf(2,i), errdbuf(1,i)
9422  END IF
9423  END IF
9424  20 CONTINUE
9425  WRITE(outnum,12000) prow, pcol, oldtest
9426 *
9427  1000 FORMAT('PROCESS {',i4,',',i4,'} REPORTS ERRORS IN TEST#',i6,':')
9428  2000 FORMAT(' Buffer overwrite ',i4,
9429  $ ' elements before the start of A:',/,
9430  $ ' Expected=',g22.15,
9431  $ '; Received=',g22.15)
9432  3000 FORMAT(' Buffer overwrite ',i4,' elements after the end of A:',
9433  $ /,' Expected=',g22.15,
9434  $ '; Received=',g22.15)
9435  4000 FORMAT(' LDA-M gap overwrite at postion (',i4,',',i4,'):',/,
9436  $ ' Expected=',g22.15,
9437  $ '; Received=',g22.15)
9438  5000 FORMAT(' Complementory triangle overwrite at A(',i4,',',i4,
9439  $ '):',/,' Expected=',g22.15,
9440  $ '; Received=',g22.15)
9441  6000 FORMAT(' Invalid element at A(',i4,',',i4,'):',/,
9442  $ ' Expected=',g22.15,
9443  $ '; Received=',g22.15)
9444  7000 FORMAT(' Buffer overwrite ',i4,' elements before the start of ',
9445  $ a1,'A:',/,' Expected=',i12,'; Received=',i12)
9446  8000 FORMAT(' Buffer overwrite ',i4,' elements after the end of ',
9447  $ a1,'A:',/,' Expected=',i12,'; Received=',i12)
9448 *
9449  9000 FORMAT(' LD',a1,'A-M gap overwrite at postion (',i4,',',i4,'):'
9450  $ ,/,' Expected=',i12,'; Received=',i12)
9451 *
9452 10000 FORMAT(' Invalid element at ',a1,'A(',i4,',',i4,'):',/,
9453  $ ' Expected=',i12,'; Received=',i12)
9454 11000 FORMAT(' Overwrite at position (',i4,',',i4,') of non-existent '
9455  $ ,a1,'A array.',/,' Expected=',i12,'; Received=',i12)
9456 12000 FORMAT('PROCESS {',i4,',',i4,'} DONE ERROR REPORT FOR TEST#',
9457  $ i6,'.')
9458 13000 FORMAT('WARNING: There were more errors than could be recorded.',
9459  $ /,'Increase MEMELTS to get complete listing.')
9460  RETURN
9461 *
9462 * End DPRINTERRS
9463 *
9464  END
9465 *
9466 *
9467  SUBROUTINE cbtcheckin( NFTESTS, OUTNUM, MAXERR, NERR, IERR,
9468  $ CVAL, TFAILED )
9469  INTEGER NFTESTS, OUTNUM, MAXERR, NERR
9470  INTEGER IERR(*), TFAILED(*)
9471  COMPLEX CVAL(*)
9472 *
9473 * Purpose
9474 * =======
9475 * CBTCHECKIN: Process 0 receives error report from all processes.
9476 *
9477 * Arguments
9478 * =========
9479 * NFTESTS (input/output) INTEGER
9480 * if NFTESTS is <= 0 upon entry, NFTESTS is not written to.
9481 * Otherwise, on entry it specifies the total number of tests
9482 * run, and on exit it is the number of tests which failed.
9483 *
9484 * OUTNUM (input) INTEGER
9485 * Device number for output.
9486 *
9487 * MAXERR (input) INTEGER
9488 * Max number of errors that can be stored in ERRIBUFF or
9489 * ERRCBUFF
9490 *
9491 * NERR (output) INTEGER
9492 * The number of errors that have been found.
9493 *
9494 * ERRIBUF (output) INTEGER array, dimension (6,MAXERRS)
9495 * Buffer in which to store integer error information. It will
9496 * be built up in the following format for the call to TSEND.
9497 * All integer information is recorded in the following 6-tuple
9498 * {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured:
9499 * SRC = RSRC * NPROCS + CSRC
9500 * DEST = RDEST * NPROCS + CDEST
9501 * WHAT
9502 * = 1 : Error in pre-padding
9503 * = 2 : Error in post-padding
9504 * = 3 : Error in LDA-M gap
9505 * = 4 : Error in complementory triangle
9506 * ELSE: Error in matrix
9507 * If there are more errors than can fit in the error buffer,
9508 * the error number will indicate the actual number of errors
9509 * found, but the buffer will be truncated to the maximum
9510 * number of errors which can fit.
9511 *
9512 * ERRDBUF (output) @(doctype) array, dimension (2, MAXERRS)
9513 * Buffer in which to store error data information.
9514 * {Incorrect, Predicted}
9515 *
9516 * TFAILED (workspace) INTEGER array, dimension NFTESTS
9517 * Workspace used to keep track of which tests failed.
9518 * If input of NFTESTS < 1, this array not accessed.
9519 *
9520 * ===================================================================
9521 *
9522 * .. External Functions ..
9523  INTEGER IBTMYPROC, IBTNPROCS, IBTMSGID
9524  EXTERNAL IBTMYPROC, IBTNPROCS, IBTMSGID
9525 * ..
9526 * .. Local Scalars ..
9527  LOGICAL COUNTING
9528  INTEGER K, NERR2, IAM, NPROCS, NTESTS
9529 *
9530 * Proc 0 collects error info from everyone
9531 *
9532  iam = ibtmyproc()
9533  nprocs = ibtnprocs()
9534 *
9535  IF( iam .EQ. 0 ) THEN
9536 *
9537 * If we are finding out how many failed tests there are, initialize
9538 * the total number of tests (NTESTS), and zero the test failed array
9539 *
9540  counting = nftests .GT. 0
9541  IF( counting ) THEN
9542  ntests = nftests
9543  DO 10 k = 1, ntests
9544  tfailed(k) = 0
9545  10 CONTINUE
9546  END IF
9547 *
9548  CALL cprinterrs(outnum, maxerr, nerr, ierr, cval, counting,
9549  $ tfailed)
9550 *
9551  DO 20 k = 1, nprocs-1
9552  CALL btsend(3, 0, k, k, ibtmsgid()+50)
9553  CALL btrecv(3, 1, nerr2, k, ibtmsgid()+50)
9554  IF( nerr2 .GT. 0 ) THEN
9555  nerr = nerr + nerr2
9556  CALL btrecv(3, nerr2*6, ierr, k, ibtmsgid()+51)
9557  CALL btrecv(5, nerr2*2, cval, k, ibtmsgid()+51)
9558  CALL cprinterrs(outnum, maxerr, nerr2, ierr, cval,
9559  $ counting, tfailed)
9560  END IF
9561  20 CONTINUE
9562 *
9563 * Count up number of tests that failed
9564 *
9565  IF( counting ) THEN
9566  nftests = 0
9567  DO 30 k = 1, ntests
9568  nftests = nftests + tfailed(k)
9569  30 CONTINUE
9570  END IF
9571 *
9572 * Send my error info to proc 0
9573 *
9574  ELSE
9575  CALL btrecv(3, 0, k, 0, ibtmsgid()+50)
9576  CALL btsend(3, 1, nerr, 0, ibtmsgid()+50)
9577  IF( nerr .GT. 0 ) THEN
9578  CALL btsend(3, nerr*6, ierr, 0, ibtmsgid()+51)
9579  CALL btsend(5, nerr*2, cval, 0, ibtmsgid()+51)
9580  END IF
9581  ENDIF
9582 *
9583  RETURN
9584 *
9585 * End of CBTCHECKIN
9586 *
9587  END
9588 *
9589  SUBROUTINE cinitmat(UPLO, DIAG, M, N, MEM, LDA, IPRE, IPOST,
9590  $ CHECKVAL, TESTNUM, MYROW, MYCOL)
9591  CHARACTER*1 UPLO, DIAG
9592  INTEGER M, N, LDA, IPRE, IPOST, TESTNUM, MYROW, MYCOL
9593  COMPLEX CHECKVAL
9594  COMPLEX MEM(*)
9595 *
9596 * .. External Subroutines ..
9597  EXTERNAL cgenmat, cpadmat
9598 * ..
9599 * .. Executable Statements ..
9600 *
9601  CALL cgenmat( m, n, mem(ipre+1), lda, testnum, myrow, mycol )
9602  CALL cpadmat( uplo, diag, m, n, mem, lda, ipre, ipost, checkval )
9603 *
9604  RETURN
9605  END
9606 *
9607  SUBROUTINE cgenmat( M, N, A, LDA, TESTNUM, MYROW, MYCOL )
9608 *
9609 * -- BLACS tester (version 1.0) --
9610 * University of Tennessee
9611 * December 15, 1994
9612 *
9613 *
9614 * .. Scalar Arguments ..
9615  INTEGER M, N, LDA, TESTNUM, MYROW, MYCOL
9616 * ..
9617 * .. Array Arguments ..
9618  COMPLEX A(LDA,N)
9619 * ..
9620 *
9621 * Purpose
9622 * =======
9623 * CGENMAT: Generates an M-by-N matrix filled with random elements.
9624 *
9625 * Arguments
9626 * =========
9627 * M (input) INTEGER
9628 * The number of rows of the matrix A. M >= 0.
9629 *
9630 * N (input) INTEGER
9631 * The number of columns of the matrix A. N >= 0.
9632 *
9633 * A (output) @up@(doctype) array, dimension (LDA,N)
9634 * The m by n matrix A. Fortran77 (column-major) storage
9635 * assumed.
9636 *
9637 * LDA (input) INTEGER
9638 * The leading dimension of the array A. LDA >= max(1, M).
9639 *
9640 * TESTNUM (input) INTEGER
9641 * Unique number for this test case, used as a basis for
9642 * the random seeds.
9643 *
9644 * ====================================================================
9645 *
9646 * .. External Functions ..
9647  INTEGER IBTNPROCS
9648  COMPLEX CBTRAN
9649  EXTERNAL cbtran, ibtnprocs
9650 * ..
9651 * .. Local Scalars ..
9652  INTEGER I, J, NPROCS, SRC
9653 * ..
9654 * .. Local Arrays ..
9655  INTEGER ISEED(4)
9656 * ..
9657 * .. Executable Statements ..
9658 *
9659 * ISEED's four values must be positive integers less than 4096,
9660 * fourth one has to be odd. (see _LARND). Use some goofy
9661 * functions to come up with seed values which together should
9662 * be unique.
9663 *
9664  nprocs = ibtnprocs()
9665  src = myrow * nprocs + mycol
9666  iseed(1) = mod( 1002 + testnum*5 + src*3, 4096 )
9667  iseed(2) = mod( 2027 + testnum*7 + src, 4096 )
9668  iseed(3) = mod( 1234 + testnum + src*3, 4096 )
9669  iseed(4) = mod( 4311 + testnum*10 + src*2, 4096 )
9670 *
9671  DO 10 j = 1, n
9672  DO 10 i = 1, m
9673  a(i, j) = cbtran( iseed )
9674  10 CONTINUE
9675 *
9676  RETURN
9677 *
9678 * End of CGENMAT.
9679 *
9680  END
9681 *
9682  COMPLEX FUNCTION cbtran(ISEED)
9683  INTEGER iseed(*)
9684 *
9685 * .. External Functions ..
9686  DOUBLE COMPLEX zlarnd
9687  EXTERNAL zlarnd
9688  cbtran = cmplx( zlarnd(2, iseed) )
9689 *
9690  RETURN
9691 *
9692 * End of Cbtran
9693 *
9694  END
9695 *
9696  SUBROUTINE cpadmat( UPLO, DIAG, M, N, MEM, LDA, IPRE, IPOST,
9697  $ CHECKVAL )
9698 *
9699 * -- BLACS tester (version 1.0) --
9700 * University of Tennessee
9701 * December 15, 1994
9702 *
9703 * .. Scalar Arguments ..
9704  CHARACTER*1 UPLO, DIAG
9705  INTEGER M, N, LDA, IPRE, IPOST
9706  COMPLEX CHECKVAL
9707 * ..
9708 * .. Array Arguments ..
9709  COMPLEX MEM( * )
9710 * ..
9711 *
9712 * Purpose
9713 * =======
9714 *
9715 * CPADMAT: Pad Matrix.
9716 * This routines surrounds a matrix with a guardzone initialized to the
9717 * value CHECKVAL. There are three distinct guardzones:
9718 * - A contiguous zone of size IPRE immediately before the start
9719 * of the matrix.
9720 * - A contiguous zone of size IPOST immedately after the end of the
9721 * matrix.
9722 * - Interstitial zones within each column of the matrix, in the
9723 * elements A( M+1:LDA, J ).
9724 *
9725 * Arguments
9726 * =========
9727 * UPLO (input) CHARACTER*1
9728 * Is the matrix A 'U'pper or 'L'ower trapezoidal, or 'G'eneral
9729 * rectangular?
9730 *
9731 * DIAG (input) CHARACTER*1
9732 * For trapezoidal matrices, is the main diagonal included
9733 * ('N') or not ('U')?
9734 *
9735 * M (input) INTEGER
9736 * The number of rows of the matrix A. M >= 0.
9737 *
9738 * N (input) INTEGER
9739 * The number of columns of the matrix A. N >= 0.
9740 *
9741 * MEM (output) complex array, dimension (IPRE+IPOST+LDA*N)
9742 * The address IPRE elements ahead of the matrix A you want to
9743 * pad, which is then of dimension (LDA,N).
9744 *
9745 * IPRE (input) INTEGER
9746 * The size of the guard zone ahead of the matrix A.
9747 *
9748 * IPOST (input) INTEGER
9749 * The size of the guard zone behind the matrix A.
9750 *
9751 * CHECKVAL (input) complex
9752 * The value to insert into the guard zones.
9753 *
9754 * ====================================================================
9755 *
9756 * .. Local Scalars ..
9757  INTEGER I, J, K
9758 * ..
9759 * .. Executable Statements ..
9760 *
9761 * Put check buffer in front of A
9762 *
9763  IF( ipre .GT. 0 ) THEN
9764  DO 10 i = 1, ipre
9765  mem( i ) = checkval
9766  10 CONTINUE
9767  END IF
9768 *
9769 * Put check buffer in back of A
9770 *
9771  IF( ipost .GT. 0 ) THEN
9772  j = ipre + lda*n + 1
9773  DO 20 i = j, j+ipost-1
9774  mem( i ) = checkval
9775  20 CONTINUE
9776  END IF
9777 *
9778 * Put check buffer in all (LDA-M) gaps
9779 *
9780  IF( lda .GT. m ) THEN
9781  k = ipre + m + 1
9782  DO 40 j = 1, n
9783  DO 30 i = k, k+lda-m-1
9784  mem( i ) = checkval
9785  30 CONTINUE
9786  k = k + lda
9787  40 CONTINUE
9788  END IF
9789 *
9790 * If the matrix is upper or lower trapezoidal, calculate the
9791 * additional triangular area which needs to be padded, Each
9792 * element referred to is in the Ith row and the Jth column.
9793 *
9794  IF( uplo .EQ. 'U' ) THEN
9795  IF( m .LE. n ) THEN
9796  IF( diag .EQ. 'U' ) THEN
9797  DO 41 i = 1, m
9798  DO 42 j = 1, i
9799  k = ipre + i + (j-1)*lda
9800  mem( k ) = checkval
9801  42 CONTINUE
9802  41 CONTINUE
9803  ELSE
9804  DO 43 i = 2, m
9805  DO 44 j = 1, i-1
9806  k = ipre + i + (j-1)*lda
9807  mem( k ) = checkval
9808  44 CONTINUE
9809  43 CONTINUE
9810  END IF
9811  ELSE
9812  IF( diag .EQ. 'U' ) THEN
9813  DO 45 i = m-n+1, m
9814  DO 46 j = 1, i-(m-n)
9815  k = ipre + i + (j-1)*lda
9816  mem( k ) = checkval
9817  46 CONTINUE
9818  45 CONTINUE
9819  ELSE
9820  DO 47 i = m-n+2, m
9821  DO 48 j = 1, i-(m-n)-1
9822  k = ipre + i + (j-1)*lda
9823  mem( k ) = checkval
9824  48 CONTINUE
9825  47 CONTINUE
9826  END IF
9827  END IF
9828  ELSE IF( uplo .EQ. 'L' ) THEN
9829  IF( m .LE. n ) THEN
9830  IF( diag .EQ. 'U' ) THEN
9831  DO 49 i = 1, m
9832  DO 50 j = n-m+i, n
9833  k = ipre + i + (j-1)*lda
9834  mem( k ) = checkval
9835  50 CONTINUE
9836  49 CONTINUE
9837  ELSE
9838  DO 51 i = 1, m-1
9839  DO 52 j = n-m+i+1, n
9840  k = ipre + i + (j-1)*lda
9841  mem( k ) = checkval
9842  52 CONTINUE
9843  51 CONTINUE
9844  END IF
9845  ELSE
9846  IF( uplo .EQ. 'U' ) THEN
9847  DO 53 i = 1, n
9848  DO 54 j = i, n
9849  k = ipre + i + (j-1)*lda
9850  mem( k ) = checkval
9851  54 CONTINUE
9852  53 CONTINUE
9853  ELSE
9854  DO 55 i = 1, n-1
9855  DO 56 j = i+1, n
9856  k = ipre + i + (j-1)*lda
9857  mem( k ) = checkval
9858  56 CONTINUE
9859  55 CONTINUE
9860  END IF
9861  END IF
9862  END IF
9863 *
9864 * End of CPADMAT.
9865 *
9866  RETURN
9867  END
9868 *
9869  SUBROUTINE cchkpad( UPLO, DIAG, M, N, MEM, LDA, RSRC, CSRC,
9870  $ MYROW, MYCOL, IPRE, IPOST, CHECKVAL,
9871  $ TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF )
9872 *
9873 * -- BLACS tester (version 1.0) --
9874 * University of Tennessee
9875 * December 15, 1994
9876 *
9877 *
9878 * .. Scalar Arguments ..
9879  CHARACTER*1 UPLO, DIAG
9880  INTEGER M, N, LDA, RSRC, CSRC, MYROW, MYCOL, IPRE, IPOST
9881  INTEGER TESTNUM, MAXERR, NERR
9882  COMPLEX CHECKVAL
9883 * ..
9884 * .. Array Arguments ..
9885  INTEGER ERRIBUF(6, MAXERR)
9886  COMPLEX MEM(*), ERRDBUF(2, MAXERR)
9887 * ..
9888 *
9889 * Purpose
9890 * =======
9891 * CCHKPAD: Check padding put in by PADMAT.
9892 * Checks that padding around target matrix has not been overwritten
9893 * by the previous point-to-point or broadcast send.
9894 *
9895 * Arguments
9896 * =========
9897 * UPLO (input) CHARACTER*1
9898 * Is the matrix A 'U'pper or 'L'ower trapezoidal, or 'G'eneral
9899 * rectangular?
9900 *
9901 * DIAG (input) CHARACTER*1
9902 * For trapezoidal matrices, is the main diagonal included
9903 * ('N') or not ('U')?
9904 *
9905 * M (input) INTEGER
9906 * The number of rows of the matrix A. M >= 0.
9907 *
9908 * N (input) INTEGER
9909 * The number of columns of the matrix A. N >= 0.
9910 *
9911 * MEM (input) complex array, dimension(IPRE+IPOST+LDA*N).
9912 * Memory location IPRE elements in front of the matrix A.
9913 *
9914 * LDA (input) INTEGER
9915 * The leading dimension of the array A. LDA >= max(1, M).
9916 *
9917 * RSRC (input) INTEGER
9918 * The process row of the source of the matrix.
9919 *
9920 * CSRC (input) INTEGER
9921 * The process column of the source of the matrix.
9922 *
9923 * MYROW (input) INTEGER
9924 * Row of this process in the process grid.
9925 *
9926 * MYCOL (input) INTEGER
9927 * Column of this process in the process grid.
9928 *
9929 * IPRE (input) INTEGER
9930 * The size of the guard zone before the start of A.
9931 *
9932 * IPOST (input) INTEGER
9933 * The size of guard zone after A.
9934 *
9935 * CHECKVAL (input) complex
9936 * The value to pad matrix with.
9937 *
9938 * TESTNUM (input) INTEGER
9939 * The number of the test being checked.
9940 *
9941 * MAXERR (input) INTEGER
9942 * Max number of errors that can be stored in ERRIBUFF or
9943 * ERRCBUFF
9944 *
9945 * NERR (output) INTEGER
9946 * The number of errors that have been found.
9947 *
9948 * ERRIBUF (output) INTEGER array, dimension (6,MAXERRS)
9949 * Buffer in which to store integer error information. It will
9950 * be built up in the following format for the call to TSEND.
9951 * All integer information is recorded in the following 6-tuple
9952 * {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured:
9953 * SRC = RSRC * NPROCS + CSRC
9954 * DEST = RDEST * NPROCS + CDEST
9955 * WHAT
9956 * = 1 : Error in pre-padding
9957 * = 2 : Error in post-padding
9958 * = 3 : Error in LDA-M gap
9959 * = 4 : Error in complementory triangle
9960 * ELSE: Error in matrix
9961 * If there are more errors than can fit in the error buffer,
9962 * the error number will indicate the actual number of errors
9963 * found, but the buffer will be truncated to the maximum
9964 * number of errors which can fit.
9965 *
9966 * ERRDBUF (output) @(doctype) array, dimension (2, MAXERRS)
9967 * Buffer in which to store error data information.
9968 * {Incorrect, Predicted}
9969 *
9970 * ===================================================================
9971 *
9972 * .. Parameters ..
9973  INTEGER ERR_PRE, ERR_POST, ERR_GAP, ERR_TRI, ERR_MAT
9974  PARAMETER( ERR_PRE = 1, err_post = 2, err_gap = 3, err_tri = 4 )
9975  parameter( err_mat = 5 )
9976 * ..
9977 * .. External Functions ..
9978  INTEGER IBTNPROCS
9979  EXTERNAL IBTNPROCS
9980 * ..
9981 * .. Local Scalars ..
9982  LOGICAL ISTRAP
9983  INTEGER I, J, K, IRST, IRND, ICST, ICND, SRC, DEST
9984  INTEGER NPROCS
9985 * ..
9986 * .. Executable Statements ..
9987 *
9988  NPROCS = ibtnprocs()
9989  src = rsrc * nprocs + csrc
9990  dest = myrow * nprocs + mycol
9991 *
9992 * Check buffer in front of A
9993 *
9994  IF( ipre .GT. 0 ) THEN
9995  DO 10 i = 1, ipre
9996  IF( mem(i) .NE. checkval ) THEN
9997  nerr = nerr + 1
9998  IF( nerr .LE. maxerr ) THEN
9999  erribuf(1, nerr) = testnum
10000  erribuf(2, nerr) = src
10001  erribuf(3, nerr) = dest
10002  erribuf(4, nerr) = i
10003  erribuf(5, nerr) = ipre - i + 1
10004  erribuf(6, nerr) = err_pre
10005  errdbuf(1, nerr) = mem(i)
10006  errdbuf(2, nerr) = checkval
10007  END IF
10008  END IF
10009  10 CONTINUE
10010  END IF
10011 *
10012 * Check buffer behind A
10013 *
10014  IF( ipost .GT. 0 ) THEN
10015  j = ipre + lda*n + 1
10016  DO 20 i = j, j+ipost-1
10017  IF( mem(i) .NE. checkval ) THEN
10018  nerr = nerr + 1
10019  IF( nerr .LE. maxerr ) THEN
10020  erribuf(1, nerr) = testnum
10021  erribuf(2, nerr) = src
10022  erribuf(3, nerr) = dest
10023  erribuf(4, nerr) = i - j + 1
10024  erribuf(5, nerr) = j
10025  erribuf(6, nerr) = err_post
10026  errdbuf(1, nerr) = mem(i)
10027  errdbuf(2, nerr) = checkval
10028  END IF
10029  END IF
10030  20 CONTINUE
10031  END IF
10032 *
10033 * Check all (LDA-M) gaps
10034 *
10035  IF( lda .GT. m ) THEN
10036  DO 40 j = 1, n
10037  DO 30 i = m+1, lda
10038  k = ipre + (j-1)*lda + i
10039  IF( mem(k) .NE. checkval) THEN
10040  nerr = nerr + 1
10041  IF( nerr .LE. maxerr ) THEN
10042  erribuf(1, nerr) = testnum
10043  erribuf(2, nerr) = src
10044  erribuf(3, nerr) = dest
10045  erribuf(4, nerr) = i
10046  erribuf(5, nerr) = j
10047  erribuf(6, nerr) = err_gap
10048  errdbuf(1, nerr) = mem(k)
10049  errdbuf(2, nerr) = checkval
10050  END IF
10051  END IF
10052  30 CONTINUE
10053  40 CONTINUE
10054  END IF
10055 *
10056 * Determine limits of trapezoidal matrix
10057 *
10058  istrap = .false.
10059  IF( uplo .EQ. 'U' ) THEN
10060  istrap = .true.
10061  IF( m .LE. n ) THEN
10062  irst = 2
10063  irnd = m
10064  icst = 1
10065  icnd = m - 1
10066  ELSEIF( m .GT. n ) THEN
10067  irst = ( m-n ) + 2
10068  irnd = m
10069  icst = 1
10070  icnd = n - 1
10071  ENDIF
10072  IF( diag .EQ. 'U' ) THEN
10073  irst = irst - 1
10074  icnd = icnd + 1
10075  ENDIF
10076  ELSE IF( uplo .EQ. 'L' ) THEN
10077  istrap = .true.
10078  IF( m .LE. n ) THEN
10079  irst = 1
10080  irnd = 1
10081  icst = ( n-m ) + 2
10082  icnd = n
10083  ELSEIF( m .GT. n ) THEN
10084  irst = 1
10085  irnd = 1
10086  icst = 2
10087  icnd = n
10088  ENDIF
10089  IF( diag .EQ. 'U' ) THEN
10090  icst = icst - 1
10091  ENDIF
10092  ENDIF
10093 *
10094 * Check elements and report any errors
10095 *
10096  IF( istrap ) THEN
10097  DO 100 j = icst, icnd
10098  DO 105 i = irst, irnd
10099  IF( mem( ipre + (j-1)*lda + i ) .NE. checkval ) THEN
10100  nerr = nerr + 1
10101  IF( nerr .LE. maxerr ) THEN
10102  erribuf(1, nerr) = testnum
10103  erribuf(2, nerr) = src
10104  erribuf(3, nerr) = dest
10105  erribuf(4, nerr) = i
10106  erribuf(5, nerr) = j
10107  erribuf(6, nerr) = err_tri
10108  errdbuf(1, nerr) = mem( ipre + (j-1)*lda + i )
10109  errdbuf(2, nerr) = checkval
10110  END IF
10111  END IF
10112  105 CONTINUE
10113 *
10114 * Update the limits to allow filling in padding
10115 *
10116  IF( uplo .EQ. 'U' ) THEN
10117  irst = irst + 1
10118  ELSE
10119  irnd = irnd + 1
10120  ENDIF
10121  100 CONTINUE
10122  END IF
10123 *
10124  RETURN
10125 *
10126 * End of CCHKPAD.
10127 *
10128  END
10129 *
10130  SUBROUTINE cchkmat( UPLO, DIAG, M, N, A, LDA, RSRC, CSRC,
10131  $ MYROW, MYCOL, TESTNUM, MAXERR, NERR,
10132  $ ERRIBUF, ERRDBUF )
10133 *
10134 * -- BLACS tester (version 1.0) --
10135 * University of Tennessee
10136 * December 15, 1994
10137 *
10138 *
10139 * .. Scalar Arguments ..
10140  CHARACTER*1 UPLO, DIAG
10141  INTEGER M, N, LDA, RSRC, CSRC, MYROW, MYCOL, TESTNUM
10142  INTEGER MAXERR, NERR
10143 * ..
10144 * .. Array Arguments ..
10145  INTEGER ERRIBUF(6, MAXERR)
10146  COMPLEX A(LDA,N), ERRDBUF(2, MAXERR)
10147 * ..
10148 *
10149 * Purpose
10150 * =======
10151 * cCHKMAT: Check matrix to see whether there were any transmission
10152 * errors.
10153 *
10154 * Arguments
10155 * =========
10156 * UPLO (input) CHARACTER*1
10157 * Is the matrix A 'U'pper or 'L'ower trapezoidal, or 'G'eneral
10158 * rectangular?
10159 *
10160 * DIAG (input) CHARACTER*1
10161 * For trapezoidal matrices, is the main diagonal included
10162 * ('N') or not ('U')?
10163 *
10164 * M (input) INTEGER
10165 * The number of rows of the matrix A. M >= 0.
10166 *
10167 * N (input) INTEGER
10168 * The number of columns of the matrix A. N >= 0.
10169 *
10170 * A (input) @up@(doctype) array, dimension (LDA,N)
10171 * The m by n matrix A. Fortran77 (column-major) storage
10172 * assumed.
10173 *
10174 * LDA (input) INTEGER
10175 * The leading dimension of the array A. LDA >= max(1, M).
10176 *
10177 * RSRC (input) INTEGER
10178 * The process row of the source of the matrix.
10179 *
10180 * CSRC (input) INTEGER
10181 * The process column of the source of the matrix.
10182 *
10183 * MYROW (input) INTEGER
10184 * Row of this process in the process grid.
10185 *
10186 * MYCOL (input) INTEGER
10187 * Column of this process in the process grid.
10188 *
10189 *
10190 * TESTNUM (input) INTEGER
10191 * The number of the test being checked.
10192 *
10193 * MAXERR (input) INTEGER
10194 * Max number of errors that can be stored in ERRIBUFF or
10195 * ERRCBUFF
10196 *
10197 * NERR (output) INTEGER
10198 * The number of errors that have been found.
10199 *
10200 * ERRIBUF (output) INTEGER array, dimension (6,MAXERRS)
10201 * Buffer in which to store integer error information. It will
10202 * be built up in the following format for the call to TSEND.
10203 * All integer information is recorded in the following 6-tuple
10204 * {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured:
10205 * SRC = RSRC * NPROCS + CSRC
10206 * DEST = RDEST * NPROCS + CDEST
10207 * WHAT
10208 * = 1 : Error in pre-padding
10209 * = 2 : Error in post-padding
10210 * = 3 : Error in LDA-M gap
10211 * = 4 : Error in complementory triangle
10212 * ELSE: Error in matrix
10213 * If there are more errors than can fit in the error buffer,
10214 * the error number will indicate the actual number of errors
10215 * found, but the buffer will be truncated to the maximum
10216 * number of errors which can fit.
10217 *
10218 * ERRDBUF (output) @(doctype) array, dimension (2, MAXERRS)
10219 * Buffer in which to store error data information.
10220 * {Incorrect, Predicted}
10221 *
10222 * ===================================================================
10223 *
10224 * .. Local Scalars ..
10225  INTEGER I, J, NPROCS, SRC, DEST
10226  LOGICAL USEIT
10227  COMPLEX COMPVAL
10228 * ..
10229 * .. Local Arrays ..
10230  INTEGER ISEED(4)
10231 * ..
10232 * .. External Functions ..
10233  INTEGER IBTNPROCS
10234  COMPLEX CBTRAN
10235  EXTERNAL CBTRAN, IBTNPROCS
10236 * ..
10237 * .. Executable Statements ..
10238 *
10239  NPROCS = ibtnprocs()
10240  src = rsrc * nprocs + csrc
10241  dest = myrow * nprocs + mycol
10242 *
10243 * Initialize ISEED with the same values as used in CGENMAT.
10244 *
10245  iseed(1) = mod( 1002 + testnum*5 + src*3, 4096 )
10246  iseed(2) = mod( 2027 + testnum*7 + src, 4096 )
10247  iseed(3) = mod( 1234 + testnum + src*3, 4096 )
10248  iseed(4) = mod( 4311 + testnum*10 + src*2, 4096 )
10249 *
10250 * Generate the elements randomly with the same method used in GENMAT.
10251 * Note that for trapezoidal matrices, we generate all elements in the
10252 * enclosing rectangle and then ignore the complementary triangle.
10253 *
10254  DO 100 j = 1, n
10255  DO 105 i = 1, m
10256  compval = cbtran( iseed )
10257 *
10258 * Now determine whether we actually need this value. The
10259 * strategy is to chop out the proper triangle based on what
10260 * particular kind of trapezoidal matrix we're dealing with.
10261 *
10262  useit = .true.
10263  IF( uplo .EQ. 'U' ) THEN
10264  IF( m .LE. n ) THEN
10265  IF( diag .EQ. 'U' ) THEN
10266  IF( i .GE. j ) THEN
10267  useit = .false.
10268  END IF
10269  ELSE
10270  IF( i .GT. j ) THEN
10271  useit = .false.
10272  END IF
10273  END IF
10274  ELSE
10275  IF( diag .EQ. 'U' ) THEN
10276  IF( i .GE. m-n+j ) THEN
10277  useit = .false.
10278  END IF
10279  ELSE
10280  IF( i .GT. m-n+j ) THEN
10281  useit = .false.
10282  END IF
10283  END IF
10284  END IF
10285  ELSE IF( uplo .EQ. 'L' ) THEN
10286  IF( m .LE. n ) THEN
10287  IF( diag .EQ. 'U' ) THEN
10288  IF( j. ge. i+(n-m) ) THEN
10289  useit = .false.
10290  END IF
10291  ELSE
10292  IF( j .GT. i+(n-m) ) THEN
10293  useit = .false.
10294  END IF
10295  END IF
10296  ELSE
10297  IF( diag .EQ. 'U' ) THEN
10298  IF( j .GE. i ) THEN
10299  useit = .false.
10300  END IF
10301  ELSE
10302  IF( j .GT. i ) THEN
10303  useit = .false.
10304  END IF
10305  END IF
10306  END IF
10307  END IF
10308 *
10309 * Compare the generated value to the one that's in the
10310 * received matrix. If they don't match, tack another
10311 * error record onto what's already there.
10312 *
10313  IF( useit ) THEN
10314  IF( a(i,j) .NE. compval ) THEN
10315  nerr = nerr + 1
10316  IF( nerr .LE. maxerr ) THEN
10317  erribuf(1, nerr) = testnum
10318  erribuf(2, nerr) = src
10319  erribuf(3, nerr) = dest
10320  erribuf(4, nerr) = i
10321  erribuf(5, nerr) = j
10322  erribuf(6, nerr) = 5
10323  errdbuf(1, nerr) = a(i, j)
10324  errdbuf(2, nerr) = compval
10325  END IF
10326  END IF
10327  END IF
10328  105 CONTINUE
10329  100 CONTINUE
10330  RETURN
10331 *
10332 * End of CCHKMAT.
10333 *
10334  END
10335 *
10336  SUBROUTINE cprinterrs( OUTNUM, MAXERR, NERR,
10337  $ ERRIBUF, ERRDBUF, COUNTING, TFAILED )
10338 *
10339 * -- BLACS tester (version 1.0) --
10340 * University of Tennessee
10341 * December 15, 1994
10342 *
10343 *
10344 * .. Scalar Arguments ..
10345  LOGICAL COUNTING
10346  INTEGER OUTNUM, MAXERR, NERR
10347 * ..
10348 * .. Array Arguments ..
10349  INTEGER ERRIBUF(6, MAXERR), TFAILED(*)
10350  COMPLEX ERRDBUF(2, MAXERR)
10351 * ..
10352 *
10353 * Purpose
10354 * =======
10355 * CPRINTERRS: Print errors that have been recorded
10356 *
10357 * Arguments
10358 * =========
10359 * OUTNUM (input) INTEGER
10360 * Device number for output.
10361 *
10362 * MAXERR (input) INTEGER
10363 * Max number of errors that can be stored in ERRIBUFF or
10364 * ERRCBUFF
10365 *
10366 * NERR (output) INTEGER
10367 * The number of errors that have been found.
10368 *
10369 * ERRIBUF (output) INTEGER array, dimension (6,MAXERRS)
10370 * Buffer in which to store integer error information. It will
10371 * be built up in the following format for the call to TSEND.
10372 * All integer information is recorded in the following 6-tuple
10373 * {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured:
10374 * SRC = RSRC * NPROCS + CSRC
10375 * DEST = RDEST * NPROCS + CDEST
10376 * WHAT
10377 * = 1 : Error in pre-padding
10378 * = 2 : Error in post-padding
10379 * = 3 : Error in LDA-M gap
10380 * = 4 : Error in complementory triangle
10381 * ELSE: Error in matrix
10382 * If there are more errors than can fit in the error buffer,
10383 * the error number will indicate the actual number of errors
10384 * found, but the buffer will be truncated to the maximum
10385 * number of errors which can fit.
10386 *
10387 * ERRDBUF (output) @(doctype) array, dimension (2, MAXERRS)
10388 * Buffer in which to store error data information.
10389 * {Incorrect, Predicted}
10390 *
10391 * TFAILED (input/ourput) INTEGER array, dimension NTESTS
10392 * Workspace used to keep track of which tests failed.
10393 * This array not accessed unless COUNTING is true.
10394 *
10395 * ===================================================================
10396 *
10397 * .. Parameters ..
10398  INTEGER ERR_PRE, ERR_POST, ERR_GAP, ERR_TRI, ERR_MAT
10399  parameter( err_pre = 1, err_post = 2, err_gap = 3, err_tri = 4 )
10400  parameter( err_mat = 5 )
10401 * ..
10402 * .. External Functions ..
10403  INTEGER IBTMYPROC, IBTNPROCS
10404  EXTERNAL ibtmyproc, ibtnprocs
10405 * ..
10406 * .. Local Scalars ..
10407  CHARACTER*1 MAT
10408  LOGICAL MATISINT
10409  INTEGER OLDTEST, NPROCS, PROW, PCOL, I, ERRTYPE
10410 * ..
10411 * .. Executable Statements ..
10412 *
10413  IF( (ibtmyproc().NE.0) .OR. (nerr.LE.0) ) RETURN
10414  oldtest = -1
10415  nprocs = ibtnprocs()
10416  prow = erribuf(3,1) / nprocs
10417  pcol = mod( erribuf(3,1), nprocs )
10418  IF( nerr .GT. maxerr ) WRITE(outnum,13000)
10419 *
10420  DO 20 i = 1, min( nerr, maxerr )
10421  IF( erribuf(1,i) .NE. oldtest ) THEN
10422  IF( oldtest .NE. -1 )
10423  $ WRITE(outnum,12000) prow, pcol, oldtest
10424  WRITE(outnum,*) ' '
10425  WRITE(outnum,1000) prow, pcol, erribuf(1,i)
10426  IF( counting ) tfailed( erribuf(1,i) ) = 1
10427  oldtest = erribuf(1, i)
10428  END IF
10429 *
10430 * Print out error message depending on type of error
10431 *
10432  errtype = erribuf(6, i)
10433  IF( errtype .LT. -10 ) THEN
10434  errtype = -errtype - 10
10435  mat = 'C'
10436  matisint = .true.
10437  ELSE IF( errtype .LT. 0 ) THEN
10438  errtype = -errtype
10439  mat = 'R'
10440  matisint = .true.
10441  ELSE
10442  matisint = .false.
10443  END IF
10444 *
10445 * RA/CA arrays from MAX/MIN have different printing protocol
10446 *
10447  IF( matisint ) THEN
10448  IF( erribuf(2, i) .EQ. -1 ) THEN
10449  WRITE(outnum,11000) erribuf(4,i), erribuf(5,i), mat,
10450  $ int( errdbuf(2,i) ), int( errdbuf(1,i) )
10451  ELSE IF( errtype .EQ. err_pre ) THEN
10452  WRITE(outnum,7000) erribuf(5,i), mat,
10453  $ int( errdbuf(2,i) ), int( errdbuf(1,i) )
10454  ELSE IF( errtype .EQ. err_post ) THEN
10455  WRITE(outnum,8000) erribuf(4,i), mat,
10456  $ int( errdbuf(2,i) ), int( errdbuf(1,i) )
10457  ELSE IF( errtype .EQ. err_gap ) THEN
10458  WRITE(outnum,9000) mat, erribuf(4,i), erribuf(5,i),
10459  $ int( errdbuf(2,i) ), int( errdbuf(1,i) )
10460  ELSE
10461  WRITE(outnum,10000) mat, erribuf(4,i), erribuf(5,i),
10462  $ int( errdbuf(2,i) ),
10463  $ int( errdbuf(1,i) )
10464  END IF
10465 *
10466 * Have memory overwrites in matrix A
10467 *
10468  ELSE
10469  IF( errtype .EQ. err_pre ) THEN
10470  WRITE(outnum,2000) erribuf(5,i),
10471  $ real( errdbuf(2,i) ), aimag( errdbuf(2,i) ),
10472  $ real( errdbuf(1,i) ), aimag( errdbuf(1,i) )
10473  ELSE IF( errtype .EQ. err_post ) THEN
10474  WRITE(outnum,3000) erribuf(4,i),
10475  $ real( errdbuf(2,i) ), aimag( errdbuf(2,i) ),
10476  $ real( errdbuf(1,i) ), aimag( errdbuf(1,i) )
10477  ELSE IF( errtype .EQ. err_gap ) THEN
10478  WRITE(outnum,4000)
10479  $ erribuf(4,i), erribuf(5,i),
10480  $ real( errdbuf(2,i) ), aimag( errdbuf(2,i) ),
10481  $ real( errdbuf(1,i) ), aimag( errdbuf(1,i) )
10482  ELSE IF( errtype .EQ. err_tri ) THEN
10483  WRITE(outnum,5000) erribuf(4,i), erribuf(5,i),
10484  $ real( errdbuf(2,i) ), aimag( errdbuf(2,i) ),
10485  $ real( errdbuf(1,i) ), aimag( errdbuf(1,i) )
10486  ELSE
10487  WRITE(outnum,6000) erribuf(4,i), erribuf(5,i),
10488  $ real( errdbuf(2,i) ), aimag( errdbuf(2,i) ),
10489  $ real( errdbuf(1,i) ), aimag( errdbuf(1,i) )
10490  END IF
10491  END IF
10492  20 CONTINUE
10493  WRITE(outnum,12000) prow, pcol, oldtest
10494 *
10495  1000 FORMAT('PROCESS {',i4,',',i4,'} REPORTS ERRORS IN TEST#',i6,':')
10496  2000 FORMAT(' Buffer overwrite ',i4,
10497  $ ' elements before the start of A:',/,
10498  $ ' Expected=','[',g15.8,',',g15.8,']',
10499  $ '; Received=','[',g15.8,',',g15.8,']')
10500  3000 FORMAT(' Buffer overwrite ',i4,' elements after the end of A:',
10501  $ /,' Expected=','[',g15.8,',',g15.8,']',
10502  $ '; Received=','[',g15.8,',',g15.8,']')
10503  4000 FORMAT(' LDA-M gap overwrite at postion (',i4,',',i4,'):',/,
10504  $ ' Expected=','[',g15.8,',',g15.8,']',
10505  $ '; Received=','[',g15.8,',',g15.8,']')
10506  5000 FORMAT(' Complementory triangle overwrite at A(',i4,',',i4,
10507  $ '):',/,' Expected=','[',g15.8,',',g15.8,']',
10508  $ '; Received=','[',g15.8,',',g15.8,']')
10509  6000 FORMAT(' Invalid element at A(',i4,',',i4,'):',/,
10510  $ ' Expected=','[',g15.8,',',g15.8,']',
10511  $ '; Received=','[',g15.8,',',g15.8,']')
10512  7000 FORMAT(' Buffer overwrite ',i4,' elements before the start of ',
10513  $ a1,'A:',/,' Expected=',i12,'; Received=',i12)
10514  8000 FORMAT(' Buffer overwrite ',i4,' elements after the end of ',
10515  $ a1,'A:',/,' Expected=',i12,'; Received=',i12)
10516 *
10517  9000 FORMAT(' LD',a1,'A-M gap overwrite at postion (',i4,',',i4,'):'
10518  $ ,/,' Expected=',i12,'; Received=',i12)
10519 *
10520 10000 FORMAT(' Invalid element at ',a1,'A(',i4,',',i4,'):',/,
10521  $ ' Expected=',i12,'; Received=',i12)
10522 11000 FORMAT(' Overwrite at position (',i4,',',i4,') of non-existent '
10523  $ ,a1,'A array.',/,' Expected=',i12,'; Received=',i12)
10524 12000 FORMAT('PROCESS {',i4,',',i4,'} DONE ERROR REPORT FOR TEST#',
10525  $ i6,'.')
10526 13000 FORMAT('WARNING: There were more errors than could be recorded.',
10527  $ /,'Increase MEMELTS to get complete listing.')
10528  RETURN
10529 *
10530 * End CPRINTERRS
10531 *
10532  END
10533 *
10534 *
10535  SUBROUTINE zbtcheckin( NFTESTS, OUTNUM, MAXERR, NERR, IERR,
10536  $ ZVAL, TFAILED )
10537  INTEGER NFTESTS, OUTNUM, MAXERR, NERR
10538  INTEGER IERR(*), TFAILED(*)
10539  DOUBLE COMPLEX ZVAL(*)
10540 *
10541 * Purpose
10542 * =======
10543 * ZBTCHECKIN: Process 0 receives error report from all processes.
10544 *
10545 * Arguments
10546 * =========
10547 * NFTESTS (input/output) INTEGER
10548 * if NFTESTS is <= 0 upon entry, NFTESTS is not written to.
10549 * Otherwise, on entry it specifies the total number of tests
10550 * run, and on exit it is the number of tests which failed.
10551 *
10552 * OUTNUM (input) INTEGER
10553 * Device number for output.
10554 *
10555 * MAXERR (input) INTEGER
10556 * Max number of errors that can be stored in ERRIBUFF or
10557 * ERRZBUFF
10558 *
10559 * NERR (output) INTEGER
10560 * The number of errors that have been found.
10561 *
10562 * ERRIBUF (output) INTEGER array, dimension (6,MAXERRS)
10563 * Buffer in which to store integer error information. It will
10564 * be built up in the following format for the call to TSEND.
10565 * All integer information is recorded in the following 6-tuple
10566 * {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured:
10567 * SRC = RSRC * NPROCS + CSRC
10568 * DEST = RDEST * NPROCS + CDEST
10569 * WHAT
10570 * = 1 : Error in pre-padding
10571 * = 2 : Error in post-padding
10572 * = 3 : Error in LDA-M gap
10573 * = 4 : Error in complementory triangle
10574 * ELSE: Error in matrix
10575 * If there are more errors than can fit in the error buffer,
10576 * the error number will indicate the actual number of errors
10577 * found, but the buffer will be truncated to the maximum
10578 * number of errors which can fit.
10579 *
10580 * ERRDBUF (output) @(doctype) array, dimension (2, MAXERRS)
10581 * Buffer in which to store error data information.
10582 * {Incorrect, Predicted}
10583 *
10584 * TFAILED (workspace) INTEGER array, dimension NFTESTS
10585 * Workspace used to keep track of which tests failed.
10586 * If input of NFTESTS < 1, this array not accessed.
10587 *
10588 * ===================================================================
10589 *
10590 * .. External Functions ..
10591  INTEGER IBTMYPROC, IBTNPROCS, IBTMSGID
10592  EXTERNAL IBTMYPROC, IBTNPROCS, IBTMSGID
10593 * ..
10594 * .. Local Scalars ..
10595  LOGICAL COUNTING
10596  INTEGER K, NERR2, IAM, NPROCS, NTESTS
10597 *
10598 * Proc 0 collects error info from everyone
10599 *
10600  iam = ibtmyproc()
10601  nprocs = ibtnprocs()
10602 *
10603  IF( iam .EQ. 0 ) THEN
10604 *
10605 * If we are finding out how many failed tests there are, initialize
10606 * the total number of tests (NTESTS), and zero the test failed array
10607 *
10608  counting = nftests .GT. 0
10609  IF( counting ) THEN
10610  ntests = nftests
10611  DO 10 k = 1, ntests
10612  tfailed(k) = 0
10613  10 CONTINUE
10614  END IF
10615 *
10616  CALL zprinterrs(outnum, maxerr, nerr, ierr, zval, counting,
10617  $ tfailed)
10618 *
10619  DO 20 k = 1, nprocs-1
10620  CALL btsend(3, 0, k, k, ibtmsgid()+50)
10621  CALL btrecv(3, 1, nerr2, k, ibtmsgid()+50)
10622  IF( nerr2 .GT. 0 ) THEN
10623  nerr = nerr + nerr2
10624  CALL btrecv(3, nerr2*6, ierr, k, ibtmsgid()+51)
10625  CALL btrecv(7, nerr2*2, zval, k, ibtmsgid()+51)
10626  CALL zprinterrs(outnum, maxerr, nerr2, ierr, zval,
10627  $ counting, tfailed)
10628  END IF
10629  20 CONTINUE
10630 *
10631 * Count up number of tests that failed
10632 *
10633  IF( counting ) THEN
10634  nftests = 0
10635  DO 30 k = 1, ntests
10636  nftests = nftests + tfailed(k)
10637  30 CONTINUE
10638  END IF
10639 *
10640 * Send my error info to proc 0
10641 *
10642  ELSE
10643  CALL btrecv(3, 0, k, 0, ibtmsgid()+50)
10644  CALL btsend(3, 1, nerr, 0, ibtmsgid()+50)
10645  IF( nerr .GT. 0 ) THEN
10646  CALL btsend(3, nerr*6, ierr, 0, ibtmsgid()+51)
10647  CALL btsend(7, nerr*2, zval, 0, ibtmsgid()+51)
10648  END IF
10649  ENDIF
10650 *
10651  RETURN
10652 *
10653 * End of ZBTCHECKIN
10654 *
10655  END
10656 *
10657  SUBROUTINE zinitmat(UPLO, DIAG, M, N, MEM, LDA, IPRE, IPOST,
10658  $ CHECKVAL, TESTNUM, MYROW, MYCOL)
10659  CHARACTER*1 UPLO, DIAG
10660  INTEGER M, N, LDA, IPRE, IPOST, TESTNUM, MYROW, MYCOL
10661  DOUBLE COMPLEX CHECKVAL
10662  DOUBLE COMPLEX MEM(*)
10663 *
10664 * .. External Subroutines ..
10665  EXTERNAL ZGENMAT, ZPADMAT
10666 * ..
10667 * .. Executable Statements ..
10668 *
10669  CALL ZGENMAT( M, N, MEM(IPRE+1), LDA, TESTNUM, MYROW, MYCOL )
10670  CALL ZPADMAT( UPLO, DIAG, M, N, MEM, LDA, IPRE, IPOST, CHECKVAL )
10671 *
10672  RETURN
10673  END
10674 *
10675  SUBROUTINE zgenmat( M, N, A, LDA, TESTNUM, MYROW, MYCOL )
10676 *
10677 * -- BLACS tester (version 1.0) --
10678 * University of Tennessee
10679 * December 15, 1994
10680 *
10681 *
10682 * .. Scalar Arguments ..
10683  INTEGER M, N, LDA, TESTNUM, MYROW, MYCOL
10684 * ..
10685 * .. Array Arguments ..
10686  DOUBLE COMPLEX A(LDA,N)
10687 * ..
10688 *
10689 * Purpose
10690 * =======
10691 * ZGENMAT: Generates an M-by-N matrix filled with random elements.
10692 *
10693 * Arguments
10694 * =========
10695 * M (input) INTEGER
10696 * The number of rows of the matrix A. M >= 0.
10697 *
10698 * N (input) INTEGER
10699 * The number of columns of the matrix A. N >= 0.
10700 *
10701 * A (output) @up@(doctype) array, dimension (LDA,N)
10702 * The m by n matrix A. Fortran77 (column-major) storage
10703 * assumed.
10704 *
10705 * LDA (input) INTEGER
10706 * The leading dimension of the array A. LDA >= max(1, M).
10707 *
10708 * TESTNUM (input) INTEGER
10709 * Unique number for this test case, used as a basis for
10710 * the random seeds.
10711 *
10712 * ====================================================================
10713 *
10714 * .. External Functions ..
10715  INTEGER IBTNPROCS
10716  DOUBLE COMPLEX ZBTRAN
10717  EXTERNAL zbtran, ibtnprocs
10718 * ..
10719 * .. Local Scalars ..
10720  INTEGER I, J, NPROCS, SRC
10721 * ..
10722 * .. Local Arrays ..
10723  INTEGER ISEED(4)
10724 * ..
10725 * .. Executable Statements ..
10726 *
10727 * ISEED's four values must be positive integers less than 4096,
10728 * fourth one has to be odd. (see _LARND). Use some goofy
10729 * functions to come up with seed values which together should
10730 * be unique.
10731 *
10732  nprocs = ibtnprocs()
10733  src = myrow * nprocs + mycol
10734  iseed(1) = mod( 1002 + testnum*5 + src*3, 4096 )
10735  iseed(2) = mod( 2027 + testnum*7 + src, 4096 )
10736  iseed(3) = mod( 1234 + testnum + src*3, 4096 )
10737  iseed(4) = mod( 4311 + testnum*10 + src*2, 4096 )
10738 *
10739  DO 10 j = 1, n
10740  DO 10 i = 1, m
10741  a(i, j) = zbtran( iseed )
10742  10 CONTINUE
10743 *
10744  RETURN
10745 *
10746 * End of ZGENMAT.
10747 *
10748  END
10749 *
10750  DOUBLE COMPLEX FUNCTION zbtran(ISEED)
10751  INTEGER iseed(*)
10752 *
10753 * .. External Functions ..
10754  DOUBLE COMPLEX zlarnd
10755  EXTERNAL zlarnd
10756  zbtran = zlarnd(2, iseed)
10757 *
10758  RETURN
10759 *
10760 * End of Zbtran
10761 *
10762  END
10763 *
10764  SUBROUTINE zpadmat( UPLO, DIAG, M, N, MEM, LDA, IPRE, IPOST,
10765  $ CHECKVAL )
10766 *
10767 * -- BLACS tester (version 1.0) --
10768 * University of Tennessee
10769 * December 15, 1994
10770 *
10771 * .. Scalar Arguments ..
10772  CHARACTER*1 UPLO, DIAG
10773  INTEGER M, N, LDA, IPRE, IPOST
10774  DOUBLE COMPLEX CHECKVAL
10775 * ..
10776 * .. Array Arguments ..
10777  DOUBLE COMPLEX MEM( * )
10778 * ..
10779 *
10780 * Purpose
10781 * =======
10782 *
10783 * ZPADMAT: Pad Matrix.
10784 * This routines surrounds a matrix with a guardzone initialized to the
10785 * value CHECKVAL. There are three distinct guardzones:
10786 * - A contiguous zone of size IPRE immediately before the start
10787 * of the matrix.
10788 * - A contiguous zone of size IPOST immedately after the end of the
10789 * matrix.
10790 * - Interstitial zones within each column of the matrix, in the
10791 * elements A( M+1:LDA, J ).
10792 *
10793 * Arguments
10794 * =========
10795 * UPLO (input) CHARACTER*1
10796 * Is the matrix A 'U'pper or 'L'ower trapezoidal, or 'G'eneral
10797 * rectangular?
10798 *
10799 * DIAG (input) CHARACTER*1
10800 * For trapezoidal matrices, is the main diagonal included
10801 * ('N') or not ('U')?
10802 *
10803 * M (input) INTEGER
10804 * The number of rows of the matrix A. M >= 0.
10805 *
10806 * N (input) INTEGER
10807 * The number of columns of the matrix A. N >= 0.
10808 *
10809 * MEM (output) double complex array, dimension (IPRE+IPOST+LDA*N)
10810 * The address IPRE elements ahead of the matrix A you want to
10811 * pad, which is then of dimension (LDA,N).
10812 *
10813 * IPRE (input) INTEGER
10814 * The size of the guard zone ahead of the matrix A.
10815 *
10816 * IPOST (input) INTEGER
10817 * The size of the guard zone behind the matrix A.
10818 *
10819 * CHECKVAL (input) double complex
10820 * The value to insert into the guard zones.
10821 *
10822 * ====================================================================
10823 *
10824 * .. Local Scalars ..
10825  INTEGER I, J, K
10826 * ..
10827 * .. Executable Statements ..
10828 *
10829 * Put check buffer in front of A
10830 *
10831  IF( ipre .GT. 0 ) THEN
10832  DO 10 i = 1, ipre
10833  mem( i ) = checkval
10834  10 CONTINUE
10835  END IF
10836 *
10837 * Put check buffer in back of A
10838 *
10839  IF( ipost .GT. 0 ) THEN
10840  j = ipre + lda*n + 1
10841  DO 20 i = j, j+ipost-1
10842  mem( i ) = checkval
10843  20 CONTINUE
10844  END IF
10845 *
10846 * Put check buffer in all (LDA-M) gaps
10847 *
10848  IF( lda .GT. m ) THEN
10849  k = ipre + m + 1
10850  DO 40 j = 1, n
10851  DO 30 i = k, k+lda-m-1
10852  mem( i ) = checkval
10853  30 CONTINUE
10854  k = k + lda
10855  40 CONTINUE
10856  END IF
10857 *
10858 * If the matrix is upper or lower trapezoidal, calculate the
10859 * additional triangular area which needs to be padded, Each
10860 * element referred to is in the Ith row and the Jth column.
10861 *
10862  IF( uplo .EQ. 'U' ) THEN
10863  IF( m .LE. n ) THEN
10864  IF( diag .EQ. 'U' ) THEN
10865  DO 41 i = 1, m
10866  DO 42 j = 1, i
10867  k = ipre + i + (j-1)*lda
10868  mem( k ) = checkval
10869  42 CONTINUE
10870  41 CONTINUE
10871  ELSE
10872  DO 43 i = 2, m
10873  DO 44 j = 1, i-1
10874  k = ipre + i + (j-1)*lda
10875  mem( k ) = checkval
10876  44 CONTINUE
10877  43 CONTINUE
10878  END IF
10879  ELSE
10880  IF( diag .EQ. 'U' ) THEN
10881  DO 45 i = m-n+1, m
10882  DO 46 j = 1, i-(m-n)
10883  k = ipre + i + (j-1)*lda
10884  mem( k ) = checkval
10885  46 CONTINUE
10886  45 CONTINUE
10887  ELSE
10888  DO 47 i = m-n+2, m
10889  DO 48 j = 1, i-(m-n)-1
10890  k = ipre + i + (j-1)*lda
10891  mem( k ) = checkval
10892  48 CONTINUE
10893  47 CONTINUE
10894  END IF
10895  END IF
10896  ELSE IF( uplo .EQ. 'L' ) THEN
10897  IF( m .LE. n ) THEN
10898  IF( diag .EQ. 'U' ) THEN
10899  DO 49 i = 1, m
10900  DO 50 j = n-m+i, n
10901  k = ipre + i + (j-1)*lda
10902  mem( k ) = checkval
10903  50 CONTINUE
10904  49 CONTINUE
10905  ELSE
10906  DO 51 i = 1, m-1
10907  DO 52 j = n-m+i+1, n
10908  k = ipre + i + (j-1)*lda
10909  mem( k ) = checkval
10910  52 CONTINUE
10911  51 CONTINUE
10912  END IF
10913  ELSE
10914  IF( uplo .EQ. 'U' ) THEN
10915  DO 53 i = 1, n
10916  DO 54 j = i, n
10917  k = ipre + i + (j-1)*lda
10918  mem( k ) = checkval
10919  54 CONTINUE
10920  53 CONTINUE
10921  ELSE
10922  DO 55 i = 1, n-1
10923  DO 56 j = i+1, n
10924  k = ipre + i + (j-1)*lda
10925  mem( k ) = checkval
10926  56 CONTINUE
10927  55 CONTINUE
10928  END IF
10929  END IF
10930  END IF
10931 *
10932 * End of ZPADMAT.
10933 *
10934  RETURN
10935  END
10936 *
10937  SUBROUTINE zchkpad( UPLO, DIAG, M, N, MEM, LDA, RSRC, CSRC,
10938  $ MYROW, MYCOL, IPRE, IPOST, CHECKVAL,
10939  $ TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF )
10940 *
10941 * -- BLACS tester (version 1.0) --
10942 * University of Tennessee
10943 * December 15, 1994
10944 *
10945 *
10946 * .. Scalar Arguments ..
10947  CHARACTER*1 UPLO, DIAG
10948  INTEGER M, N, LDA, RSRC, CSRC, MYROW, MYCOL, IPRE, IPOST
10949  INTEGER TESTNUM, MAXERR, NERR
10950  DOUBLE COMPLEX CHECKVAL
10951 * ..
10952 * .. Array Arguments ..
10953  INTEGER ERRIBUF(6, MAXERR)
10954  DOUBLE COMPLEX MEM(*), ERRDBUF(2, MAXERR)
10955 * ..
10956 *
10957 * Purpose
10958 * =======
10959 * ZCHKPAD: Check padding put in by PADMAT.
10960 * Checks that padding around target matrix has not been overwritten
10961 * by the previous point-to-point or broadcast send.
10962 *
10963 * Arguments
10964 * =========
10965 * UPLO (input) CHARACTER*1
10966 * Is the matrix A 'U'pper or 'L'ower trapezoidal, or 'G'eneral
10967 * rectangular?
10968 *
10969 * DIAG (input) CHARACTER*1
10970 * For trapezoidal matrices, is the main diagonal included
10971 * ('N') or not ('U')?
10972 *
10973 * M (input) INTEGER
10974 * The number of rows of the matrix A. M >= 0.
10975 *
10976 * N (input) INTEGER
10977 * The number of columns of the matrix A. N >= 0.
10978 *
10979 * MEM (input) double complex array, dimension(IPRE+IPOST+LDA*N).
10980 * Memory location IPRE elements in front of the matrix A.
10981 *
10982 * LDA (input) INTEGER
10983 * The leading dimension of the array A. LDA >= max(1, M).
10984 *
10985 * RSRC (input) INTEGER
10986 * The process row of the source of the matrix.
10987 *
10988 * CSRC (input) INTEGER
10989 * The process column of the source of the matrix.
10990 *
10991 * MYROW (input) INTEGER
10992 * Row of this process in the process grid.
10993 *
10994 * MYCOL (input) INTEGER
10995 * Column of this process in the process grid.
10996 *
10997 * IPRE (input) INTEGER
10998 * The size of the guard zone before the start of A.
10999 *
11000 * IPOST (input) INTEGER
11001 * The size of guard zone after A.
11002 *
11003 * CHECKVAL (input) double complex
11004 * The value to pad matrix with.
11005 *
11006 * TESTNUM (input) INTEGER
11007 * The number of the test being checked.
11008 *
11009 * MAXERR (input) INTEGER
11010 * Max number of errors that can be stored in ERRIBUFF or
11011 * ERRZBUFF
11012 *
11013 * NERR (output) INTEGER
11014 * The number of errors that have been found.
11015 *
11016 * ERRIBUF (output) INTEGER array, dimension (6,MAXERRS)
11017 * Buffer in which to store integer error information. It will
11018 * be built up in the following format for the call to TSEND.
11019 * All integer information is recorded in the following 6-tuple
11020 * {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured:
11021 * SRC = RSRC * NPROCS + CSRC
11022 * DEST = RDEST * NPROCS + CDEST
11023 * WHAT
11024 * = 1 : Error in pre-padding
11025 * = 2 : Error in post-padding
11026 * = 3 : Error in LDA-M gap
11027 * = 4 : Error in complementory triangle
11028 * ELSE: Error in matrix
11029 * If there are more errors than can fit in the error buffer,
11030 * the error number will indicate the actual number of errors
11031 * found, but the buffer will be truncated to the maximum
11032 * number of errors which can fit.
11033 *
11034 * ERRDBUF (output) @(doctype) array, dimension (2, MAXERRS)
11035 * Buffer in which to store error data information.
11036 * {Incorrect, Predicted}
11037 *
11038 * ===================================================================
11039 *
11040 * .. Parameters ..
11041  INTEGER ERR_PRE, ERR_POST, ERR_GAP, ERR_TRI, ERR_MAT
11042  PARAMETER( ERR_PRE = 1, err_post = 2, err_gap = 3, err_tri = 4 )
11043  parameter( err_mat = 5 )
11044 * ..
11045 * .. External Functions ..
11046  INTEGER IBTNPROCS
11047  EXTERNAL IBTNPROCS
11048 * ..
11049 * .. Local Scalars ..
11050  LOGICAL ISTRAP
11051  INTEGER I, J, K, IRST, IRND, ICST, ICND, SRC, DEST
11052  INTEGER NPROCS
11053 * ..
11054 * .. Executable Statements ..
11055 *
11056  NPROCS = ibtnprocs()
11057  src = rsrc * nprocs + csrc
11058  dest = myrow * nprocs + mycol
11059 *
11060 * Check buffer in front of A
11061 *
11062  IF( ipre .GT. 0 ) THEN
11063  DO 10 i = 1, ipre
11064  IF( mem(i) .NE. checkval ) THEN
11065  nerr = nerr + 1
11066  IF( nerr .LE. maxerr ) THEN
11067  erribuf(1, nerr) = testnum
11068  erribuf(2, nerr) = src
11069  erribuf(3, nerr) = dest
11070  erribuf(4, nerr) = i
11071  erribuf(5, nerr) = ipre - i + 1
11072  erribuf(6, nerr) = err_pre
11073  errdbuf(1, nerr) = mem(i)
11074  errdbuf(2, nerr) = checkval
11075  END IF
11076  END IF
11077  10 CONTINUE
11078  END IF
11079 *
11080 * Check buffer behind A
11081 *
11082  IF( ipost .GT. 0 ) THEN
11083  j = ipre + lda*n + 1
11084  DO 20 i = j, j+ipost-1
11085  IF( mem(i) .NE. checkval ) THEN
11086  nerr = nerr + 1
11087  IF( nerr .LE. maxerr ) THEN
11088  erribuf(1, nerr) = testnum
11089  erribuf(2, nerr) = src
11090  erribuf(3, nerr) = dest
11091  erribuf(4, nerr) = i - j + 1
11092  erribuf(5, nerr) = j
11093  erribuf(6, nerr) = err_post
11094  errdbuf(1, nerr) = mem(i)
11095  errdbuf(2, nerr) = checkval
11096  END IF
11097  END IF
11098  20 CONTINUE
11099  END IF
11100 *
11101 * Check all (LDA-M) gaps
11102 *
11103  IF( lda .GT. m ) THEN
11104  DO 40 j = 1, n
11105  DO 30 i = m+1, lda
11106  k = ipre + (j-1)*lda + i
11107  IF( mem(k) .NE. checkval) THEN
11108  nerr = nerr + 1
11109  IF( nerr .LE. maxerr ) THEN
11110  erribuf(1, nerr) = testnum
11111  erribuf(2, nerr) = src
11112  erribuf(3, nerr) = dest
11113  erribuf(4, nerr) = i
11114  erribuf(5, nerr) = j
11115  erribuf(6, nerr) = err_gap
11116  errdbuf(1, nerr) = mem(k)
11117  errdbuf(2, nerr) = checkval
11118  END IF
11119  END IF
11120  30 CONTINUE
11121  40 CONTINUE
11122  END IF
11123 *
11124 * Determine limits of trapezoidal matrix
11125 *
11126  istrap = .false.
11127  IF( uplo .EQ. 'U' ) THEN
11128  istrap = .true.
11129  IF( m .LE. n ) THEN
11130  irst = 2
11131  irnd = m
11132  icst = 1
11133  icnd = m - 1
11134  ELSEIF( m .GT. n ) THEN
11135  irst = ( m-n ) + 2
11136  irnd = m
11137  icst = 1
11138  icnd = n - 1
11139  ENDIF
11140  IF( diag .EQ. 'U' ) THEN
11141  irst = irst - 1
11142  icnd = icnd + 1
11143  ENDIF
11144  ELSE IF( uplo .EQ. 'L' ) THEN
11145  istrap = .true.
11146  IF( m .LE. n ) THEN
11147  irst = 1
11148  irnd = 1
11149  icst = ( n-m ) + 2
11150  icnd = n
11151  ELSEIF( m .GT. n ) THEN
11152  irst = 1
11153  irnd = 1
11154  icst = 2
11155  icnd = n
11156  ENDIF
11157  IF( diag .EQ. 'U' ) THEN
11158  icst = icst - 1
11159  ENDIF
11160  ENDIF
11161 *
11162 * Check elements and report any errors
11163 *
11164  IF( istrap ) THEN
11165  DO 100 j = icst, icnd
11166  DO 105 i = irst, irnd
11167  IF( mem( ipre + (j-1)*lda + i ) .NE. checkval ) THEN
11168  nerr = nerr + 1
11169  IF( nerr .LE. maxerr ) THEN
11170  erribuf(1, nerr) = testnum
11171  erribuf(2, nerr) = src
11172  erribuf(3, nerr) = dest
11173  erribuf(4, nerr) = i
11174  erribuf(5, nerr) = j
11175  erribuf(6, nerr) = err_tri
11176  errdbuf(1, nerr) = mem( ipre + (j-1)*lda + i )
11177  errdbuf(2, nerr) = checkval
11178  END IF
11179  END IF
11180  105 CONTINUE
11181 *
11182 * Update the limits to allow filling in padding
11183 *
11184  IF( uplo .EQ. 'U' ) THEN
11185  irst = irst + 1
11186  ELSE
11187  irnd = irnd + 1
11188  ENDIF
11189  100 CONTINUE
11190  END IF
11191 *
11192  RETURN
11193 *
11194 * End of ZCHKPAD.
11195 *
11196  END
11197 *
11198  SUBROUTINE zchkmat( UPLO, DIAG, M, N, A, LDA, RSRC, CSRC,
11199  $ MYROW, MYCOL, TESTNUM, MAXERR, NERR,
11200  $ ERRIBUF, ERRDBUF )
11201 *
11202 * -- BLACS tester (version 1.0) --
11203 * University of Tennessee
11204 * December 15, 1994
11205 *
11206 *
11207 * .. Scalar Arguments ..
11208  CHARACTER*1 UPLO, DIAG
11209  INTEGER M, N, LDA, RSRC, CSRC, MYROW, MYCOL, TESTNUM
11210  INTEGER MAXERR, NERR
11211 * ..
11212 * .. Array Arguments ..
11213  INTEGER ERRIBUF(6, MAXERR)
11214  DOUBLE COMPLEX A(LDA,N), ERRDBUF(2, MAXERR)
11215 * ..
11216 *
11217 * Purpose
11218 * =======
11219 * zCHKMAT: Check matrix to see whether there were any transmission
11220 * errors.
11221 *
11222 * Arguments
11223 * =========
11224 * UPLO (input) CHARACTER*1
11225 * Is the matrix A 'U'pper or 'L'ower trapezoidal, or 'G'eneral
11226 * rectangular?
11227 *
11228 * DIAG (input) CHARACTER*1
11229 * For trapezoidal matrices, is the main diagonal included
11230 * ('N') or not ('U')?
11231 *
11232 * M (input) INTEGER
11233 * The number of rows of the matrix A. M >= 0.
11234 *
11235 * N (input) INTEGER
11236 * The number of columns of the matrix A. N >= 0.
11237 *
11238 * A (input) @up@(doctype) array, dimension (LDA,N)
11239 * The m by n matrix A. Fortran77 (column-major) storage
11240 * assumed.
11241 *
11242 * LDA (input) INTEGER
11243 * The leading dimension of the array A. LDA >= max(1, M).
11244 *
11245 * RSRC (input) INTEGER
11246 * The process row of the source of the matrix.
11247 *
11248 * CSRC (input) INTEGER
11249 * The process column of the source of the matrix.
11250 *
11251 * MYROW (input) INTEGER
11252 * Row of this process in the process grid.
11253 *
11254 * MYCOL (input) INTEGER
11255 * Column of this process in the process grid.
11256 *
11257 *
11258 * TESTNUM (input) INTEGER
11259 * The number of the test being checked.
11260 *
11261 * MAXERR (input) INTEGER
11262 * Max number of errors that can be stored in ERRIBUFF or
11263 * ERRZBUFF
11264 *
11265 * NERR (output) INTEGER
11266 * The number of errors that have been found.
11267 *
11268 * ERRIBUF (output) INTEGER array, dimension (6,MAXERRS)
11269 * Buffer in which to store integer error information. It will
11270 * be built up in the following format for the call to TSEND.
11271 * All integer information is recorded in the following 6-tuple
11272 * {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured:
11273 * SRC = RSRC * NPROCS + CSRC
11274 * DEST = RDEST * NPROCS + CDEST
11275 * WHAT
11276 * = 1 : Error in pre-padding
11277 * = 2 : Error in post-padding
11278 * = 3 : Error in LDA-M gap
11279 * = 4 : Error in complementory triangle
11280 * ELSE: Error in matrix
11281 * If there are more errors than can fit in the error buffer,
11282 * the error number will indicate the actual number of errors
11283 * found, but the buffer will be truncated to the maximum
11284 * number of errors which can fit.
11285 *
11286 * ERRDBUF (output) @(doctype) array, dimension (2, MAXERRS)
11287 * Buffer in which to store error data information.
11288 * {Incorrect, Predicted}
11289 *
11290 * ===================================================================
11291 *
11292 * .. Local Scalars ..
11293  INTEGER I, J, NPROCS, SRC, DEST
11294  LOGICAL USEIT
11295  DOUBLE COMPLEX COMPVAL
11296 * ..
11297 * .. Local Arrays ..
11298  INTEGER ISEED(4)
11299 * ..
11300 * .. External Functions ..
11301  INTEGER IBTNPROCS
11302  DOUBLE COMPLEX ZBTRAN
11303  EXTERNAL ZBTRAN, IBTNPROCS
11304 * ..
11305 * .. Executable Statements ..
11306 *
11307  NPROCS = ibtnprocs()
11308  src = rsrc * nprocs + csrc
11309  dest = myrow * nprocs + mycol
11310 *
11311 * Initialize ISEED with the same values as used in ZGENMAT.
11312 *
11313  iseed(1) = mod( 1002 + testnum*5 + src*3, 4096 )
11314  iseed(2) = mod( 2027 + testnum*7 + src, 4096 )
11315  iseed(3) = mod( 1234 + testnum + src*3, 4096 )
11316  iseed(4) = mod( 4311 + testnum*10 + src*2, 4096 )
11317 *
11318 * Generate the elements randomly with the same method used in GENMAT.
11319 * Note that for trapezoidal matrices, we generate all elements in the
11320 * enclosing rectangle and then ignore the complementary triangle.
11321 *
11322  DO 100 j = 1, n
11323  DO 105 i = 1, m
11324  compval = zbtran( iseed )
11325 *
11326 * Now determine whether we actually need this value. The
11327 * strategy is to chop out the proper triangle based on what
11328 * particular kind of trapezoidal matrix we're dealing with.
11329 *
11330  useit = .true.
11331  IF( uplo .EQ. 'U' ) THEN
11332  IF( m .LE. n ) THEN
11333  IF( diag .EQ. 'U' ) THEN
11334  IF( i .GE. j ) THEN
11335  useit = .false.
11336  END IF
11337  ELSE
11338  IF( i .GT. j ) THEN
11339  useit = .false.
11340  END IF
11341  END IF
11342  ELSE
11343  IF( diag .EQ. 'U' ) THEN
11344  IF( i .GE. m-n+j ) THEN
11345  useit = .false.
11346  END IF
11347  ELSE
11348  IF( i .GT. m-n+j ) THEN
11349  useit = .false.
11350  END IF
11351  END IF
11352  END IF
11353  ELSE IF( uplo .EQ. 'L' ) THEN
11354  IF( m .LE. n ) THEN
11355  IF( diag .EQ. 'U' ) THEN
11356  IF( j. ge. i+(n-m) ) THEN
11357  useit = .false.
11358  END IF
11359  ELSE
11360  IF( j .GT. i+(n-m) ) THEN
11361  useit = .false.
11362  END IF
11363  END IF
11364  ELSE
11365  IF( diag .EQ. 'U' ) THEN
11366  IF( j .GE. i ) THEN
11367  useit = .false.
11368  END IF
11369  ELSE
11370  IF( j .GT. i ) THEN
11371  useit = .false.
11372  END IF
11373  END IF
11374  END IF
11375  END IF
11376 *
11377 * Compare the generated value to the one that's in the
11378 * received matrix. If they don't match, tack another
11379 * error record onto what's already there.
11380 *
11381  IF( useit ) THEN
11382  IF( a(i,j) .NE. compval ) THEN
11383  nerr = nerr + 1
11384  IF( nerr .LE. maxerr ) THEN
11385  erribuf(1, nerr) = testnum
11386  erribuf(2, nerr) = src
11387  erribuf(3, nerr) = dest
11388  erribuf(4, nerr) = i
11389  erribuf(5, nerr) = j
11390  erribuf(6, nerr) = 5
11391  errdbuf(1, nerr) = a(i, j)
11392  errdbuf(2, nerr) = compval
11393  END IF
11394  END IF
11395  END IF
11396  105 CONTINUE
11397  100 CONTINUE
11398  RETURN
11399 *
11400 * End of ZCHKMAT.
11401 *
11402  END
11403 *
11404  SUBROUTINE zprinterrs( OUTNUM, MAXERR, NERR,
11405  $ ERRIBUF, ERRDBUF, COUNTING, TFAILED )
11406 *
11407 * -- BLACS tester (version 1.0) --
11408 * University of Tennessee
11409 * December 15, 1994
11410 *
11411 *
11412 * .. Scalar Arguments ..
11413  LOGICAL COUNTING
11414  INTEGER OUTNUM, MAXERR, NERR
11415 * ..
11416 * .. Array Arguments ..
11417  INTEGER ERRIBUF(6, MAXERR), TFAILED(*)
11418  DOUBLE COMPLEX ERRDBUF(2, MAXERR)
11419 * ..
11420 *
11421 * Purpose
11422 * =======
11423 * ZPRINTERRS: Print errors that have been recorded
11424 *
11425 * Arguments
11426 * =========
11427 * OUTNUM (input) INTEGER
11428 * Device number for output.
11429 *
11430 * MAXERR (input) INTEGER
11431 * Max number of errors that can be stored in ERRIBUFF or
11432 * ERRZBUFF
11433 *
11434 * NERR (output) INTEGER
11435 * The number of errors that have been found.
11436 *
11437 * ERRIBUF (output) INTEGER array, dimension (6,MAXERRS)
11438 * Buffer in which to store integer error information. It will
11439 * be built up in the following format for the call to TSEND.
11440 * All integer information is recorded in the following 6-tuple
11441 * {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured:
11442 * SRC = RSRC * NPROCS + CSRC
11443 * DEST = RDEST * NPROCS + CDEST
11444 * WHAT
11445 * = 1 : Error in pre-padding
11446 * = 2 : Error in post-padding
11447 * = 3 : Error in LDA-M gap
11448 * = 4 : Error in complementory triangle
11449 * ELSE: Error in matrix
11450 * If there are more errors than can fit in the error buffer,
11451 * the error number will indicate the actual number of errors
11452 * found, but the buffer will be truncated to the maximum
11453 * number of errors which can fit.
11454 *
11455 * ERRDBUF (output) @(doctype) array, dimension (2, MAXERRS)
11456 * Buffer in which to store error data information.
11457 * {Incorrect, Predicted}
11458 *
11459 * TFAILED (input/ourput) INTEGER array, dimension NTESTS
11460 * Workspace used to keep track of which tests failed.
11461 * This array not accessed unless COUNTING is true.
11462 *
11463 * ===================================================================
11464 *
11465 * .. Parameters ..
11466  INTEGER ERR_PRE, ERR_POST, ERR_GAP, ERR_TRI, ERR_MAT
11467  parameter( err_pre = 1, err_post = 2, err_gap = 3, err_tri = 4 )
11468  parameter( err_mat = 5 )
11469 * ..
11470 * .. External Functions ..
11471  INTEGER IBTMYPROC, IBTNPROCS
11472  EXTERNAL ibtmyproc, ibtnprocs
11473 * ..
11474 * .. Local Scalars ..
11475  CHARACTER*1 MAT
11476  LOGICAL MATISINT
11477  INTEGER OLDTEST, NPROCS, PROW, PCOL, I, ERRTYPE
11478 * ..
11479 * .. Executable Statements ..
11480 *
11481  IF( (ibtmyproc().NE.0) .OR. (nerr.LE.0) ) RETURN
11482  oldtest = -1
11483  nprocs = ibtnprocs()
11484  prow = erribuf(3,1) / nprocs
11485  pcol = mod( erribuf(3,1), nprocs )
11486  IF( nerr .GT. maxerr ) WRITE(outnum,13000)
11487 *
11488  DO 20 i = 1, min( nerr, maxerr )
11489  IF( erribuf(1,i) .NE. oldtest ) THEN
11490  IF( oldtest .NE. -1 )
11491  $ WRITE(outnum,12000) prow, pcol, oldtest
11492  WRITE(outnum,*) ' '
11493  WRITE(outnum,1000) prow, pcol, erribuf(1,i)
11494  IF( counting ) tfailed( erribuf(1,i) ) = 1
11495  oldtest = erribuf(1, i)
11496  END IF
11497 *
11498 * Print out error message depending on type of error
11499 *
11500  errtype = erribuf(6, i)
11501  IF( errtype .LT. -10 ) THEN
11502  errtype = -errtype - 10
11503  mat = 'C'
11504  matisint = .true.
11505  ELSE IF( errtype .LT. 0 ) THEN
11506  errtype = -errtype
11507  mat = 'R'
11508  matisint = .true.
11509  ELSE
11510  matisint = .false.
11511  END IF
11512 *
11513 * RA/CA arrays from MAX/MIN have different printing protocol
11514 *
11515  IF( matisint ) THEN
11516  IF( erribuf(2, i) .EQ. -1 ) THEN
11517  WRITE(outnum,11000) erribuf(4,i), erribuf(5,i), mat,
11518  $ int( errdbuf(2,i) ), int( errdbuf(1,i) )
11519  ELSE IF( errtype .EQ. err_pre ) THEN
11520  WRITE(outnum,7000) erribuf(5,i), mat,
11521  $ int( errdbuf(2,i) ), int( errdbuf(1,i) )
11522  ELSE IF( errtype .EQ. err_post ) THEN
11523  WRITE(outnum,8000) erribuf(4,i), mat,
11524  $ int( errdbuf(2,i) ), int( errdbuf(1,i) )
11525  ELSE IF( errtype .EQ. err_gap ) THEN
11526  WRITE(outnum,9000) mat, erribuf(4,i), erribuf(5,i),
11527  $ int( errdbuf(2,i) ), int( errdbuf(1,i) )
11528  ELSE
11529  WRITE(outnum,10000) mat, erribuf(4,i), erribuf(5,i),
11530  $ int( errdbuf(2,i) ),
11531  $ int( errdbuf(1,i) )
11532  END IF
11533 *
11534 * Have memory overwrites in matrix A
11535 *
11536  ELSE
11537  IF( errtype .EQ. err_pre ) THEN
11538  WRITE(outnum,2000) erribuf(5,i),
11539  $ real( errdbuf(2,i) ), dimag( errdbuf(2,i) ),
11540  $ real( errdbuf(1,i) ), dimag( errdbuf(1,i) )
11541  ELSE IF( errtype .EQ. err_post ) THEN
11542  WRITE(outnum,3000) erribuf(4,i),
11543  $ real( errdbuf(2,i) ), dimag( errdbuf(2,i) ),
11544  $ real( errdbuf(1,i) ), dimag( errdbuf(1,i) )
11545  ELSE IF( errtype .EQ. err_gap ) THEN
11546  WRITE(outnum,4000)
11547  $ erribuf(4,i), erribuf(5,i),
11548  $ real( errdbuf(2,i) ), dimag( errdbuf(2,i) ),
11549  $ real( errdbuf(1,i) ), dimag( errdbuf(1,i) )
11550  ELSE IF( errtype .EQ. err_tri ) THEN
11551  WRITE(outnum,5000) erribuf(4,i), erribuf(5,i),
11552  $ real( errdbuf(2,i) ), dimag( errdbuf(2,i) ),
11553  $ real( errdbuf(1,i) ), dimag( errdbuf(1,i) )
11554  ELSE
11555  WRITE(outnum,6000) erribuf(4,i), erribuf(5,i),
11556  $ real( errdbuf(2,i) ), dimag( errdbuf(2,i) ),
11557  $ real( errdbuf(1,i) ), dimag( errdbuf(1,i) )
11558  END IF
11559  END IF
11560  20 CONTINUE
11561  WRITE(outnum,12000) prow, pcol, oldtest
11562 *
11563  1000 FORMAT('PROCESS {',i4,',',i4,'} REPORTS ERRORS IN TEST#',i6,':')
11564  2000 FORMAT(' Buffer overwrite ',i4,
11565  $ ' elements before the start of A:',/,
11566  $ ' Expected=','[',g22.15,',',g22.15,']',
11567  $ '; Received=','[',g22.15,',',g22.15,']')
11568  3000 FORMAT(' Buffer overwrite ',i4,' elements after the end of A:',
11569  $ /,' Expected=','[',g22.15,',',g22.15,']',
11570  $ '; Received=','[',g22.15,',',g22.15,']')
11571  4000 FORMAT(' LDA-M gap overwrite at postion (',i4,',',i4,'):',/,
11572  $ ' Expected=','[',g22.15,',',g22.15,']',
11573  $ '; Received=','[',g22.15,',',g22.15,']')
11574  5000 FORMAT(' Complementory triangle overwrite at A(',i4,',',i4,
11575  $ '):',/,' Expected=','[',g22.15,',',g22.15,']',
11576  $ '; Received=','[',g22.15,',',g22.15,']')
11577  6000 FORMAT(' Invalid element at A(',i4,',',i4,'):',/,
11578  $ ' Expected=','[',g22.15,',',g22.15,']',
11579  $ '; Received=','[',g22.15,',',g22.15,']')
11580  7000 FORMAT(' Buffer overwrite ',i4,' elements before the start of ',
11581  $ a1,'A:',/,' Expected=',i12,'; Received=',i12)
11582  8000 FORMAT(' Buffer overwrite ',i4,' elements after the end of ',
11583  $ a1,'A:',/,' Expected=',i12,'; Received=',i12)
11584 *
11585  9000 FORMAT(' LD',a1,'A-M gap overwrite at postion (',i4,',',i4,'):'
11586  $ ,/,' Expected=',i12,'; Received=',i12)
11587 *
11588 10000 FORMAT(' Invalid element at ',a1,'A(',i4,',',i4,'):',/,
11589  $ ' Expected=',i12,'; Received=',i12)
11590 11000 FORMAT(' Overwrite at position (',i4,',',i4,') of non-existent '
11591  $ ,a1,'A array.',/,' Expected=',i12,'; Received=',i12)
11592 12000 FORMAT('PROCESS {',i4,',',i4,'} DONE ERROR REPORT FOR TEST#',
11593  $ i6,'.')
11594 13000 FORMAT('WARNING: There were more errors than could be recorded.',
11595  $ /,'Increase MEMELTS to get complete listing.')
11596  RETURN
11597 *
11598 * End ZPRINTERRS
11599 *
11600  END
11601 *
11602 *
11603  SUBROUTINE isumtest( OUTNUM, VERB, TOPSREPEAT, TOPSCOHRNT, NSCOPE,
11604  $ SCOPE0, NTOP, TOP0, NMAT, M0, N0, LDAS0,
11605  $ LDAD0, NDEST, RDEST0, CDEST0, NGRID,
11606  $ CONTEXT0, P0, Q0, ISEED, MEM, MEMLEN )
11607 *
11608 * -- BLACS tester (version 1.0) --
11609 * University of Tennessee
11610 * December 15, 1994
11611 *
11612 *
11613 * .. Scalar Arguments ..
11614  INTEGER MEMLEN, NDEST, NGRID, NMAT, NSCOPE, NTOP, OUTNUM,
11615  $ topscohrnt, topsrepeat, verb
11616 * ..
11617 * .. Array Arguments ..
11618  CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP)
11619  INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT)
11620  INTEGER RDEST0(NDEST), CDEST0(NDEST), CONTEXT0(NGRID)
11621  INTEGER P0(NGRID), Q0(NGRID), ISEED(*)
11622  INTEGER MEM(MEMLEN)
11623 * ..
11624 *
11625 * Purpose
11626 * =======
11627 * ITESTSUM: Test integer SUM COMBINE
11628 *
11629 * Arguments
11630 * =========
11631 * OUTNUM (input) INTEGER
11632 * The device number to write output to.
11633 *
11634 * VERB (input) INTEGER
11635 * The level of verbosity (how much printing to do).
11636 *
11637 * NSCOPE (input) INTEGER
11638 * The number of scopes to be tested.
11639 *
11640 * SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE)
11641 * Values of the scopes to be tested.
11642 *
11643 * NTOP (input) INTEGER
11644 * The number of topologies to be tested.
11645 *
11646 * TOP0 (input) CHARACTER*1 array of dimension (NTOP)
11647 * Values of the topologies to be tested.
11648 *
11649 * NMAT (input) INTEGER
11650 * The number of matrices to be tested.
11651 *
11652 * M0 (input) INTEGER array of dimension (NMAT)
11653 * Values of M to be tested.
11654 *
11655 * M0 (input) INTEGER array of dimension (NMAT)
11656 * Values of M to be tested.
11657 *
11658 * N0 (input) INTEGER array of dimension (NMAT)
11659 * Values of N to be tested.
11660 *
11661 * LDAS0 (input) INTEGER array of dimension (NMAT)
11662 * Values of LDAS (leading dimension of A on source process)
11663 * to be tested.
11664 *
11665 * LDAD0 (input) INTEGER array of dimension (NMAT)
11666 * Values of LDAD (leading dimension of A on destination
11667 * process) to be tested.
11668 * NDEST (input) INTEGER
11669 * The number of destinations to be tested.
11670 *
11671 * RDEST0 (input) INTEGER array of dimension (NNDEST)
11672 * Values of RDEST (row coordinate of destination) to be
11673 * tested.
11674 *
11675 * CDEST0 (input) INTEGER array of dimension (NNDEST)
11676 * Values of CDEST (column coordinate of destination) to be
11677 * tested.
11678 *
11679 * NGRID (input) INTEGER
11680 * The number of process grids to be tested.
11681 *
11682 * CONTEXT0 (input) INTEGER array of dimension (NGRID)
11683 * The BLACS context handles corresponding to the grids.
11684 *
11685 * P0 (input) INTEGER array of dimension (NGRID)
11686 * Values of P (number of process rows, NPROW).
11687 *
11688 * Q0 (input) INTEGER array of dimension (NGRID)
11689 * Values of Q (number of process columns, NPCOL).
11690 *
11691 * ISEED (workspace) INTEGER array of dimension ( MAX(NPROCS, NTESTS) )
11692 * Workspace used to hold each process's random number SEED.
11693 * This requires NPROCS (number of processor) elements.
11694 * If VERB < 2, this workspace also serves to indicate which
11695 * tests fail. This requires workspace of NTESTS
11696 * (number of tests performed).
11697 *
11698 * MEM (workspace) INTEGER array of dimension (MEMLEN)
11699 * Used for all other workspaces, including the matrix A,
11700 * and its pre and post padding.
11701 *
11702 * MEMLEN (input) INTEGER
11703 * The length, in elements, of MEM.
11704 *
11705 * =====================================================================
11706 *
11707 * .. External Functions ..
11708  LOGICAL ALLPASS, LSAME
11709  INTEGER IBTMYPROC, IBTNPROCS, IBTSIZEOF
11710  EXTERNAL allpass, lsame, ibtmyproc, ibtnprocs, ibtsizeof
11711 * ..
11712 * .. External Subroutines ..
11713  EXTERNAL blacs_gridinfo, igsum2d
11714  EXTERNAL iinitmat, ichkpad, ibtcheckin
11715 * ..
11716 * .. Local Scalars ..
11717  CHARACTER*1 SCOPE, TOP
11718  LOGICAL INGRID, TESTOK, ALLRCV
11719  INTEGER APTR, CDEST, CDEST2, CONTEXT, ERRDPTR, ERRIPTR, I, IAM,
11720  $ IDE, IGR, IMA, IPAD, IPOST, IPRE, ISC, ISIZE, ISTART,
11721  $ ISTOP, ITC, ITC1, ITC2, ITO, ITR, ITR1, ITR2, J, K, LDA,
11722  $ LDADST, LDASRC, M, MAXERR, MYCOL, MYROW, N, NERR, NFAIL,
11723  $ NPCOL, NPROW, NSKIP, PREAPTR, RDEST, RDEST2, SETWHAT,
11724  $ TESTNUM
11725  INTEGER CHECKVAL
11726 * ..
11727 * .. Executable Statements ..
11728 *
11729 * Choose padding value, and make it unique
11730 *
11731  CHECKVAL = -911
11732  iam = ibtmyproc()
11733  checkval = iam * checkval
11734  isize = ibtsizeof('I')
11735 *
11736 * Verify file parameters
11737 *
11738  IF( iam .EQ. 0 ) THEN
11739  WRITE(outnum, *) ' '
11740  WRITE(outnum, *) ' '
11741  WRITE(outnum, 1000 )
11742  IF( verb .GT. 0 ) THEN
11743  WRITE(outnum,*) ' '
11744  WRITE(outnum, 2000) 'NSCOPE:', nscope
11745  WRITE(outnum, 3000) ' SCOPE:', ( scope0(i), i = 1, nscope )
11746  WRITE(outnum, 2000) 'TReps :', topsrepeat
11747  WRITE(outnum, 2000) 'TCohr :', topscohrnt
11748  WRITE(outnum, 2000) 'NTOP :', ntop
11749  WRITE(outnum, 3000) ' TOP :', ( top0(i), i = 1, ntop )
11750  WRITE(outnum, 2000) 'NMAT :', nmat
11751  WRITE(outnum, 2000) ' M :', ( m0(i), i = 1, nmat )
11752  WRITE(outnum, 2000) ' N :', ( n0(i), i = 1, nmat )
11753  WRITE(outnum, 2000) ' LDAS :', ( ldas0(i), i = 1, nmat )
11754  WRITE(outnum, 2000) ' LDAD :', ( ldad0(i), i = 1, nmat )
11755  WRITE(outnum, 2000) 'NDEST :', ndest
11756  WRITE(outnum, 2000) ' RDEST:',( rdest0(i), i = 1, ndest )
11757  WRITE(outnum, 2000) ' CDEST:',( cdest0(i), i = 1, ndest )
11758  WRITE(outnum, 2000) 'NGRIDS:', ngrid
11759  WRITE(outnum, 2000) ' P :', ( p0(i), i = 1, ngrid )
11760  WRITE(outnum, 2000) ' Q :', ( q0(i), i = 1, ngrid )
11761  WRITE(outnum, 2000) 'VERB :', verb
11762  WRITE(outnum,*) ' '
11763  END IF
11764  IF( verb .GT. 1 ) THEN
11765  WRITE(outnum,4000)
11766  WRITE(outnum,5000)
11767  END IF
11768  END IF
11769  IF (topsrepeat.EQ.0) THEN
11770  itr1 = 0
11771  itr2 = 0
11772  ELSE IF (topsrepeat.EQ.1) THEN
11773  itr1 = 1
11774  itr2 = 1
11775  ELSE
11776  itr1 = 0
11777  itr2 = 1
11778  END IF
11779 *
11780 * Find biggest matrix, so we know where to stick error info
11781 *
11782  i = 0
11783  DO 10 ima = 1, nmat
11784  ipad = 4 * m0(ima)
11785  k = n0(ima) * max0( ldas0(ima), ldad0(ima) ) + ipad
11786  IF( k .GT. i ) i = k
11787  10 CONTINUE
11788  maxerr = ( isize * (memlen-i) ) / ( isize*2 + isize*6 )
11789  IF( maxerr .LT. 1 ) THEN
11790  WRITE(outnum,*) 'ERROR: Not enough memory to run SUM tests.'
11791  CALL blacs_abort(-1, 1)
11792  END IF
11793  errdptr = i + 1
11794  erriptr = errdptr + maxerr
11795  nerr = 0
11796  testnum = 0
11797  nfail = 0
11798  nskip = 0
11799 *
11800 * Loop over grids of matrix
11801 *
11802  DO 90 igr = 1, ngrid
11803 *
11804 * allocate process grid for the next batch of tests
11805 *
11806  context = context0(igr)
11807  CALL blacs_gridinfo( context, nprow, npcol, myrow, mycol )
11808  ingrid = ( (myrow.LT.nprow) .AND. (mycol.LT.npcol) )
11809 *
11810  DO 80 isc = 1, nscope
11811  scope = scope0(isc)
11812  DO 70 ito = 1, ntop
11813  top = top0(ito)
11814 *
11815 * If testing multiring ('M') or general tree ('T'), need to
11816 * loop over calls to BLACS_SET to do full test
11817 *
11818  IF( lsame(top, 'M') ) THEN
11819  setwhat = 13
11820  IF( scope .EQ. 'R' ) THEN
11821  istart = -(npcol - 1)
11822  istop = -istart
11823  ELSE IF (scope .EQ. 'C') THEN
11824  istart = -(nprow - 1)
11825  istop = -istart
11826  ELSE
11827  istart = -(nprow*npcol - 1)
11828  istop = -istart
11829  ENDIF
11830  ELSE IF( lsame(top, 'T') ) THEN
11831  setwhat = 14
11832  istart = 1
11833  IF( scope .EQ. 'R' ) THEN
11834  istop = npcol - 1
11835  ELSE IF (scope .EQ. 'C') THEN
11836  istop = nprow - 1
11837  ELSE
11838  istop = nprow*npcol - 1
11839  ENDIF
11840  ELSE
11841  setwhat = 0
11842  istart = 1
11843  istop = 1
11844  ENDIF
11845  DO 60 ima = 1, nmat
11846  m = m0(ima)
11847  n = n0(ima)
11848  ldasrc = ldas0(ima)
11849  ldadst = ldad0(ima)
11850  ipre = 2 * m
11851  ipost = ipre
11852  preaptr = 1
11853  aptr = preaptr + ipre
11854 *
11855  DO 50 ide = 1, ndest
11856  testnum = testnum + 1
11857  rdest2 = rdest0(ide)
11858  cdest2 = cdest0(ide)
11859 *
11860 * If everyone gets the answer, create some bogus rdest/cdest
11861 * so IF's are easier
11862 *
11863  allrcv = ( (rdest2.EQ.-1) .OR. (cdest2.EQ.-1) )
11864  IF( allrcv ) THEN
11865  rdest = nprow - 1
11866  cdest = npcol - 1
11867  IF (topscohrnt.EQ.0) THEN
11868  itr1 = 0
11869  itr2 = 0
11870  ELSE IF (topscohrnt.EQ.1) THEN
11871  itr1 = 1
11872  itr2 = 1
11873  ELSE
11874  itr1 = 0
11875  itr2 = 1
11876  END IF
11877  ELSE
11878  rdest = rdest2
11879  cdest = cdest2
11880  itc1 = 0
11881  itc2 = 0
11882  END IF
11883  IF( rdest.GE.p0(igr) .OR. cdest.GE.q0(igr) ) THEN
11884  nskip = nskip + 1
11885  GOTO 50
11886  END IF
11887 *
11888  IF( myrow.EQ.rdest .AND. mycol.EQ.cdest ) THEN
11889  lda = ldadst
11890  ELSE
11891  lda = ldasrc
11892  END IF
11893  IF( verb .GT. 1 ) THEN
11894  IF( iam .EQ. 0 ) THEN
11895  WRITE(outnum, 6000)
11896  $ testnum, 'RUNNING', scope, top, m, n,
11897  $ ldasrc, ldadst, rdest2, cdest2,
11898  $ nprow, npcol
11899  END IF
11900  END IF
11901 *
11902 * If I am in scope
11903 *
11904  testok = .true.
11905  IF( ingrid ) THEN
11906  IF( (myrow.EQ.rdest .AND. scope.EQ.'R') .OR.
11907  $ (mycol.EQ.cdest .AND. scope.EQ.'C') .OR.
11908  $ (scope .EQ. 'A') ) THEN
11909 *
11910  k = nerr
11911  DO 40 itr = itr1, itr2
11912  CALL blacs_set(context, 15, itr)
11913  DO 35 itc = itc1, itc2
11914  CALL blacs_set(context, 16, itc)
11915  DO 30 j = istart, istop
11916  IF( j.EQ.0) GOTO 30
11917  IF( setwhat.NE.0 )
11918  $ CALL blacs_set(context, setwhat, j)
11919 *
11920 *
11921 * generate and pad matrix A
11922 *
11923  CALL iinitmat('G','-', m, n, mem(preaptr),
11924  $ lda, ipre, ipost,
11925  $ checkval, testnum,
11926  $ myrow, mycol )
11927 *
11928  CALL igsum2d(context, scope, top, m, n,
11929  $ mem(aptr), lda, rdest2,
11930  $ cdest2)
11931 *
11932 * If I've got the answer, check for errors in
11933 * matrix or padding
11934 *
11935  IF( (myrow.EQ.rdest .AND. mycol.EQ.cdest)
11936  $ .OR. allrcv ) THEN
11937  CALL ichkpad('G','-', m, n,
11938  $ mem(preaptr), lda, rdest,
11939  $ cdest, myrow, mycol,
11940  $ ipre, ipost, checkval,
11941  $ testnum, maxerr, nerr,
11942  $ mem(erriptr),mem(errdptr))
11943  CALL ichksum(scope, context, m, n,
11944  $ mem(aptr), lda,
11945  $ testnum, maxerr, nerr,
11946  $ mem(erriptr),mem(errdptr),
11947  $ iseed)
11948  END IF
11949  30 CONTINUE
11950  CALL blacs_set(context, 16, 0)
11951  35 CONTINUE
11952  CALL blacs_set(context, 15, 0)
11953  40 CONTINUE
11954  testok = ( k .EQ. nerr )
11955  END IF
11956  END IF
11957 *
11958  IF( verb .GT. 1 ) THEN
11959  i = nerr
11960  CALL ibtcheckin(0, outnum, maxerr, nerr,
11961  $ mem(erriptr), mem(errdptr), iseed)
11962  IF( iam .EQ. 0 ) THEN
11963  IF( testok .AND. nerr.EQ.i ) THEN
11964  WRITE(outnum,6000)testnum,'PASSED ',
11965  $ scope, top, m, n, ldasrc,
11966  $ ldadst, rdest2, cdest2,
11967  $ nprow, npcol
11968  ELSE
11969  nfail = nfail + 1
11970  WRITE(outnum,6000)testnum,'FAILED ',
11971  $ scope, top, m, n, ldasrc,
11972  $ ldadst, rdest2, cdest2,
11973  $ nprow, npcol
11974  END IF
11975  END IF
11976 *
11977 * Once we've printed out errors, can re-use buf space
11978 *
11979  nerr = 0
11980  END IF
11981  50 CONTINUE
11982  60 CONTINUE
11983  70 CONTINUE
11984  80 CONTINUE
11985  90 CONTINUE
11986 *
11987  IF( verb .LT. 2 ) THEN
11988  nfail = testnum
11989  CALL ibtcheckin( nfail, outnum, maxerr, nerr, mem(erriptr),
11990  $ mem(errdptr), iseed )
11991  END IF
11992  IF( iam .EQ. 0 ) THEN
11993  IF( verb .GT. 1 ) WRITE(outnum,*) ' '
11994  IF( nfail+nskip .EQ. 0 ) THEN
11995  WRITE(outnum, 7000 ) testnum
11996  ELSE
11997  WRITE(outnum, 8000 ) testnum, testnum-nskip-nfail,
11998  $ nskip, nfail
11999  END IF
12000  END IF
12001 *
12002 * Log whether their were any failures
12003 *
12004  testok = allpass( (nfail.EQ.0) )
12005 *
12006  1000 FORMAT('INTEGER SUM TESTS: BEGIN.' )
12007  2000 FORMAT(1x,a7,3x,10i6)
12008  3000 FORMAT(1x,a7,3x,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,
12009  $ 5x,a1,5x,a1)
12010  4000 FORMAT(' TEST# STATUS SCOPE TOP M N LDAS LDAD ',
12011  $ 'RDEST CDEST P Q')
12012  5000 FORMAT(' ----- ------- ----- --- ----- ----- ----- ----- ',
12013  $ '----- ----- ---- ----')
12014  6000 FORMAT(i6,1x,a7,5x,a1,3x,a1,6i6,2i5)
12015  7000 FORMAT('INTEGER SUM TESTS: PASSED ALL',
12016  $ i5, ' TESTS.')
12017  8000 FORMAT('INTEGER SUM TESTS:',i5,' TESTS;',i5,' PASSED,',
12018  $ i5,' SKIPPED,',i5,' FAILED.')
12019 *
12020  RETURN
12021 *
12022 * End of ITESTSUM.
12023 *
12024  END
12025 *
12026  INTEGER FUNCTION ibtabs(VAL)
12027  INTEGER val
12028  ibtabs = abs(val)
12029  RETURN
12030  END
12031 *
12032  SUBROUTINE ichksum( SCOPE, ICTXT, M, N, A, LDA, TESTNUM, MAXERR,
12033  $ NERR, ERRIBUF, ERRDBUF, ISEED )
12034 *
12035 * .. Scalar Arguments ..
12036  CHARACTER*1 SCOPE
12037  INTEGER ICTXT, M, N, LDA, TESTNUM, MAXERR, NERR
12038 * ..
12039 * .. Array Arguments ..
12040  INTEGER ERRIBUF(6, MAXERR), ISEED(*)
12041  INTEGER A(LDA,*), ERRDBUF(2, MAXERR)
12042 * ..
12043 * .. External Functions ..
12044  INTEGER IBTMYPROC, IBTNPROCS
12045  INTEGER IBTRAN
12046  EXTERNAL ibtmyproc, ibtnprocs, ibtran
12047 * ..
12048 * .. Local Scalars ..
12049  INTEGER NPROCS, NPROW, NPCOL, MYROW, MYCOL, NODE, NNODES, DEST
12050  INTEGER I, J, K
12051  INTEGER ANS
12052 * ..
12053 * .. Executable Statements ..
12054 *
12055  nprocs = ibtnprocs()
12056  CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
12057  dest = myrow*nprocs + mycol
12058 *
12059 * Set up seeds to match those used by each proc's genmat call
12060 *
12061  IF( scope .EQ. 'R' ) THEN
12062  nnodes = npcol
12063  DO 10 i = 0, nnodes-1
12064  node = myrow * nprocs + i
12065  iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
12066  iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
12067  iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
12068  iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
12069  10 CONTINUE
12070  ELSE IF( scope .EQ. 'C' ) THEN
12071  nnodes = nprow
12072  DO 20 i = 0, nnodes-1
12073  node = i * nprocs + mycol
12074  iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
12075  iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
12076  iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
12077  iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
12078  20 CONTINUE
12079  ELSE
12080  nnodes = nprow * npcol
12081  DO 30 i = 0, nnodes-1
12082  node = (i / npcol) * nprocs + mod(i, npcol)
12083  iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
12084  iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
12085  iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
12086  iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
12087  30 CONTINUE
12088  END IF
12089 *
12090  DO 100 j = 1, n
12091  DO 90 i = 1, m
12092  ans = 0
12093  DO 40 k = 0, nnodes-1
12094  ans = ans + ibtran( iseed(k*4+1) )
12095  40 CONTINUE
12096 *
12097 * The error bound is figured by
12098 * 2 * eps * (nnodes-1) * max(|max element|, |ans|).
12099 * The 2 allows for errors in the distributed _AND_ local result.
12100 * The eps is machine epsilon. The number of floating point adds
12101 * is (nnodes - 1). We use the fact that 0.5 is the maximum element
12102 * in order to save ourselves some computation.
12103 *
12104  IF( ans .NE. a(i,j) ) THEN
12105  nerr = nerr + 1
12106  IF( nerr .LE. maxerr ) THEN
12107  erribuf(1, nerr) = testnum
12108  erribuf(2, nerr) = nnodes
12109  erribuf(3, nerr) = dest
12110  erribuf(4, nerr) = i
12111  erribuf(5, nerr) = j
12112  erribuf(6, nerr) = 5
12113  errdbuf(1, nerr) = a(i,j)
12114  errdbuf(2, nerr) = ans
12115  END IF
12116  END IF
12117  90 CONTINUE
12118  100 CONTINUE
12119 *
12120  RETURN
12121 *
12122 * End of ICHKSUM
12123 *
12124  END
12125 *
12126 *
12127  SUBROUTINE ssumtest( OUTNUM, VERB, TOPSREPEAT, TOPSCOHRNT, NSCOPE,
12128  $ SCOPE0, NTOP, TOP0, NMAT, M0, N0, LDAS0,
12129  $ LDAD0, NDEST, RDEST0, CDEST0, NGRID,
12130  $ CONTEXT0, P0, Q0, ISEED, MEM, MEMLEN )
12131 *
12132 * -- BLACS tester (version 1.0) --
12133 * University of Tennessee
12134 * December 15, 1994
12135 *
12136 *
12137 * .. Scalar Arguments ..
12138  INTEGER MEMLEN, NDEST, NGRID, NMAT, NSCOPE, NTOP, OUTNUM,
12139  $ topscohrnt, topsrepeat, verb
12140 * ..
12141 * .. Array Arguments ..
12142  CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP)
12143  INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT)
12144  INTEGER RDEST0(NDEST), CDEST0(NDEST), CONTEXT0(NGRID)
12145  INTEGER P0(NGRID), Q0(NGRID), ISEED(*)
12146  REAL MEM(MEMLEN)
12147 * ..
12148 *
12149 * Purpose
12150 * =======
12151 * STESTSUM: Test real SUM COMBINE
12152 *
12153 * Arguments
12154 * =========
12155 * OUTNUM (input) INTEGER
12156 * The device number to write output to.
12157 *
12158 * VERB (input) INTEGER
12159 * The level of verbosity (how much printing to do).
12160 *
12161 * NSCOPE (input) INTEGER
12162 * The number of scopes to be tested.
12163 *
12164 * SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE)
12165 * Values of the scopes to be tested.
12166 *
12167 * NTOP (input) INTEGER
12168 * The number of topologies to be tested.
12169 *
12170 * TOP0 (input) CHARACTER*1 array of dimension (NTOP)
12171 * Values of the topologies to be tested.
12172 *
12173 * NMAT (input) INTEGER
12174 * The number of matrices to be tested.
12175 *
12176 * M0 (input) INTEGER array of dimension (NMAT)
12177 * Values of M to be tested.
12178 *
12179 * M0 (input) INTEGER array of dimension (NMAT)
12180 * Values of M to be tested.
12181 *
12182 * N0 (input) INTEGER array of dimension (NMAT)
12183 * Values of N to be tested.
12184 *
12185 * LDAS0 (input) INTEGER array of dimension (NMAT)
12186 * Values of LDAS (leading dimension of A on source process)
12187 * to be tested.
12188 *
12189 * LDAD0 (input) INTEGER array of dimension (NMAT)
12190 * Values of LDAD (leading dimension of A on destination
12191 * process) to be tested.
12192 * NDEST (input) INTEGER
12193 * The number of destinations to be tested.
12194 *
12195 * RDEST0 (input) INTEGER array of dimension (NNDEST)
12196 * Values of RDEST (row coordinate of destination) to be
12197 * tested.
12198 *
12199 * CDEST0 (input) INTEGER array of dimension (NNDEST)
12200 * Values of CDEST (column coordinate of destination) to be
12201 * tested.
12202 *
12203 * NGRID (input) INTEGER
12204 * The number of process grids to be tested.
12205 *
12206 * CONTEXT0 (input) INTEGER array of dimension (NGRID)
12207 * The BLACS context handles corresponding to the grids.
12208 *
12209 * P0 (input) INTEGER array of dimension (NGRID)
12210 * Values of P (number of process rows, NPROW).
12211 *
12212 * Q0 (input) INTEGER array of dimension (NGRID)
12213 * Values of Q (number of process columns, NPCOL).
12214 *
12215 * ISEED (workspace) INTEGER array of dimension ( MAX(NPROCS, NTESTS) )
12216 * Workspace used to hold each process's random number SEED.
12217 * This requires NPROCS (number of processor) elements.
12218 * If VERB < 2, this workspace also serves to indicate which
12219 * tests fail. This requires workspace of NTESTS
12220 * (number of tests performed).
12221 *
12222 * MEM (workspace) REAL array of dimension (MEMLEN)
12223 * Used for all other workspaces, including the matrix A,
12224 * and its pre and post padding.
12225 *
12226 * MEMLEN (input) INTEGER
12227 * The length, in elements, of MEM.
12228 *
12229 * =====================================================================
12230 *
12231 * .. External Functions ..
12232  LOGICAL ALLPASS, LSAME
12233  INTEGER IBTMYPROC, IBTNPROCS, IBTSIZEOF
12234  EXTERNAL ALLPASS, LSAME, IBTMYPROC, IBTNPROCS, IBTSIZEOF
12235 * ..
12236 * .. External Subroutines ..
12237  EXTERNAL blacs_gridinfo, sgsum2d
12238  EXTERNAL sinitmat, schkpad, sbtcheckin
12239 * ..
12240 * .. Local Scalars ..
12241  CHARACTER*1 SCOPE, TOP
12242  LOGICAL INGRID, TESTOK, ALLRCV
12243  INTEGER APTR, CDEST, CDEST2, CONTEXT, ERRDPTR, ERRIPTR, I, IAM,
12244  $ IDE, IGR, IMA, IPAD, IPOST, IPRE, ISC, ISIZE, ISTART,
12245  $ ISTOP, ITC, ITC1, ITC2, ITO, ITR, ITR1, ITR2, J, K, LDA,
12246  $ LDADST, LDASRC, M, MAXERR, MYCOL, MYROW, N, NERR, NFAIL,
12247  $ NPCOL, NPROW, NSKIP, PREAPTR, RDEST, RDEST2, SETWHAT,
12248  $ SSIZE, TESTNUM
12249  REAL CHECKVAL
12250 * ..
12251 * .. Executable Statements ..
12252 *
12253 * Choose padding value, and make it unique
12254 *
12255  CHECKVAL = -0.61e0
12256  iam = ibtmyproc()
12257  checkval = iam * checkval
12258  isize = ibtsizeof('I')
12259  ssize = ibtsizeof('S')
12260 *
12261 * Verify file parameters
12262 *
12263  IF( iam .EQ. 0 ) THEN
12264  WRITE(outnum, *) ' '
12265  WRITE(outnum, *) ' '
12266  WRITE(outnum, 1000 )
12267  IF( verb .GT. 0 ) THEN
12268  WRITE(outnum,*) ' '
12269  WRITE(outnum, 2000) 'NSCOPE:', nscope
12270  WRITE(outnum, 3000) ' SCOPE:', ( scope0(i), i = 1, nscope )
12271  WRITE(outnum, 2000) 'TReps :', topsrepeat
12272  WRITE(outnum, 2000) 'TCohr :', topscohrnt
12273  WRITE(outnum, 2000) 'NTOP :', ntop
12274  WRITE(outnum, 3000) ' TOP :', ( top0(i), i = 1, ntop )
12275  WRITE(outnum, 2000) 'NMAT :', nmat
12276  WRITE(outnum, 2000) ' M :', ( m0(i), i = 1, nmat )
12277  WRITE(outnum, 2000) ' N :', ( n0(i), i = 1, nmat )
12278  WRITE(outnum, 2000) ' LDAS :', ( ldas0(i), i = 1, nmat )
12279  WRITE(outnum, 2000) ' LDAD :', ( ldad0(i), i = 1, nmat )
12280  WRITE(outnum, 2000) 'NDEST :', ndest
12281  WRITE(outnum, 2000) ' RDEST:',( rdest0(i), i = 1, ndest )
12282  WRITE(outnum, 2000) ' CDEST:',( cdest0(i), i = 1, ndest )
12283  WRITE(outnum, 2000) 'NGRIDS:', ngrid
12284  WRITE(outnum, 2000) ' P :', ( p0(i), i = 1, ngrid )
12285  WRITE(outnum, 2000) ' Q :', ( q0(i), i = 1, ngrid )
12286  WRITE(outnum, 2000) 'VERB :', verb
12287  WRITE(outnum,*) ' '
12288  END IF
12289  IF( verb .GT. 1 ) THEN
12290  WRITE(outnum,4000)
12291  WRITE(outnum,5000)
12292  END IF
12293  END IF
12294  IF (topsrepeat.EQ.0) THEN
12295  itr1 = 0
12296  itr2 = 0
12297  ELSE IF (topsrepeat.EQ.1) THEN
12298  itr1 = 1
12299  itr2 = 1
12300  ELSE
12301  itr1 = 0
12302  itr2 = 1
12303  END IF
12304 *
12305 * Find biggest matrix, so we know where to stick error info
12306 *
12307  i = 0
12308  DO 10 ima = 1, nmat
12309  ipad = 4 * m0(ima)
12310  k = n0(ima) * max0( ldas0(ima), ldad0(ima) ) + ipad
12311  IF( k .GT. i ) i = k
12312  10 CONTINUE
12313  maxerr = ( ssize * (memlen-i) ) / ( ssize*2 + isize*6 )
12314  IF( maxerr .LT. 1 ) THEN
12315  WRITE(outnum,*) 'ERROR: Not enough memory to run SUM tests.'
12316  CALL blacs_abort(-1, 1)
12317  END IF
12318  errdptr = i + 1
12319  erriptr = errdptr + maxerr
12320  nerr = 0
12321  testnum = 0
12322  nfail = 0
12323  nskip = 0
12324 *
12325 * Loop over grids of matrix
12326 *
12327  DO 90 igr = 1, ngrid
12328 *
12329 * allocate process grid for the next batch of tests
12330 *
12331  context = context0(igr)
12332  CALL blacs_gridinfo( context, nprow, npcol, myrow, mycol )
12333  ingrid = ( (myrow.LT.nprow) .AND. (mycol.LT.npcol) )
12334 *
12335  DO 80 isc = 1, nscope
12336  scope = scope0(isc)
12337  DO 70 ito = 1, ntop
12338  top = top0(ito)
12339 *
12340 * If testing multiring ('M') or general tree ('T'), need to
12341 * loop over calls to BLACS_SET to do full test
12342 *
12343  IF( lsame(top, 'M') ) THEN
12344  setwhat = 13
12345  IF( scope .EQ. 'R' ) THEN
12346  istart = -(npcol - 1)
12347  istop = -istart
12348  ELSE IF (scope .EQ. 'C') THEN
12349  istart = -(nprow - 1)
12350  istop = -istart
12351  ELSE
12352  istart = -(nprow*npcol - 1)
12353  istop = -istart
12354  ENDIF
12355  ELSE IF( lsame(top, 'T') ) THEN
12356  setwhat = 14
12357  istart = 1
12358  IF( scope .EQ. 'R' ) THEN
12359  istop = npcol - 1
12360  ELSE IF (scope .EQ. 'C') THEN
12361  istop = nprow - 1
12362  ELSE
12363  istop = nprow*npcol - 1
12364  ENDIF
12365  ELSE
12366  setwhat = 0
12367  istart = 1
12368  istop = 1
12369  ENDIF
12370  DO 60 ima = 1, nmat
12371  m = m0(ima)
12372  n = n0(ima)
12373  ldasrc = ldas0(ima)
12374  ldadst = ldad0(ima)
12375  ipre = 2 * m
12376  ipost = ipre
12377  preaptr = 1
12378  aptr = preaptr + ipre
12379 *
12380  DO 50 ide = 1, ndest
12381  testnum = testnum + 1
12382  rdest2 = rdest0(ide)
12383  cdest2 = cdest0(ide)
12384 *
12385 * If everyone gets the answer, create some bogus rdest/cdest
12386 * so IF's are easier
12387 *
12388  allrcv = ( (rdest2.EQ.-1) .OR. (cdest2.EQ.-1) )
12389  IF( allrcv ) THEN
12390  rdest = nprow - 1
12391  cdest = npcol - 1
12392  IF (topscohrnt.EQ.0) THEN
12393  itr1 = 0
12394  itr2 = 0
12395  ELSE IF (topscohrnt.EQ.1) THEN
12396  itr1 = 1
12397  itr2 = 1
12398  ELSE
12399  itr1 = 0
12400  itr2 = 1
12401  END IF
12402  ELSE
12403  rdest = rdest2
12404  cdest = cdest2
12405  itc1 = 0
12406  itc2 = 0
12407  END IF
12408  IF( rdest.GE.p0(igr) .OR. cdest.GE.q0(igr) ) THEN
12409  nskip = nskip + 1
12410  GOTO 50
12411  END IF
12412 *
12413  IF( myrow.EQ.rdest .AND. mycol.EQ.cdest ) THEN
12414  lda = ldadst
12415  ELSE
12416  lda = ldasrc
12417  END IF
12418  IF( verb .GT. 1 ) THEN
12419  IF( iam .EQ. 0 ) THEN
12420  WRITE(outnum, 6000)
12421  $ testnum, 'RUNNING', scope, top, m, n,
12422  $ ldasrc, ldadst, rdest2, cdest2,
12423  $ nprow, npcol
12424  END IF
12425  END IF
12426 *
12427 * If I am in scope
12428 *
12429  testok = .true.
12430  IF( ingrid ) THEN
12431  IF( (myrow.EQ.rdest .AND. scope.EQ.'R') .OR.
12432  $ (mycol.EQ.cdest .AND. scope.EQ.'C') .OR.
12433  $ (scope .EQ. 'A') ) THEN
12434 *
12435  k = nerr
12436  DO 40 itr = itr1, itr2
12437  CALL blacs_set(context, 15, itr)
12438  DO 35 itc = itc1, itc2
12439  CALL blacs_set(context, 16, itc)
12440  DO 30 j = istart, istop
12441  IF( j.EQ.0) GOTO 30
12442  IF( setwhat.NE.0 )
12443  $ CALL blacs_set(context, setwhat, j)
12444 *
12445 *
12446 * generate and pad matrix A
12447 *
12448  CALL sinitmat('G','-', m, n, mem(preaptr),
12449  $ lda, ipre, ipost,
12450  $ checkval, testnum,
12451  $ myrow, mycol )
12452 *
12453  CALL sgsum2d(context, scope, top, m, n,
12454  $ mem(aptr), lda, rdest2,
12455  $ cdest2)
12456 *
12457 * If I've got the answer, check for errors in
12458 * matrix or padding
12459 *
12460  IF( (myrow.EQ.rdest .AND. mycol.EQ.cdest)
12461  $ .OR. allrcv ) THEN
12462  CALL schkpad('G','-', m, n,
12463  $ mem(preaptr), lda, rdest,
12464  $ cdest, myrow, mycol,
12465  $ ipre, ipost, checkval,
12466  $ testnum, maxerr, nerr,
12467  $ mem(erriptr),mem(errdptr))
12468  CALL schksum(scope, context, m, n,
12469  $ mem(aptr), lda,
12470  $ testnum, maxerr, nerr,
12471  $ mem(erriptr),mem(errdptr),
12472  $ iseed)
12473  END IF
12474  30 CONTINUE
12475  CALL blacs_set(context, 16, 0)
12476  35 CONTINUE
12477  CALL blacs_set(context, 15, 0)
12478  40 CONTINUE
12479  testok = ( k .EQ. nerr )
12480  END IF
12481  END IF
12482 *
12483  IF( verb .GT. 1 ) THEN
12484  i = nerr
12485  CALL sbtcheckin(0, outnum, maxerr, nerr,
12486  $ mem(erriptr), mem(errdptr), iseed)
12487  IF( iam .EQ. 0 ) THEN
12488  IF( testok .AND. nerr.EQ.i ) THEN
12489  WRITE(outnum,6000)testnum,'PASSED ',
12490  $ scope, top, m, n, ldasrc,
12491  $ ldadst, rdest2, cdest2,
12492  $ nprow, npcol
12493  ELSE
12494  nfail = nfail + 1
12495  WRITE(outnum,6000)testnum,'FAILED ',
12496  $ scope, top, m, n, ldasrc,
12497  $ ldadst, rdest2, cdest2,
12498  $ nprow, npcol
12499  END IF
12500  END IF
12501 *
12502 * Once we've printed out errors, can re-use buf space
12503 *
12504  nerr = 0
12505  END IF
12506  50 CONTINUE
12507  60 CONTINUE
12508  70 CONTINUE
12509  80 CONTINUE
12510  90 CONTINUE
12511 *
12512  IF( verb .LT. 2 ) THEN
12513  nfail = testnum
12514  CALL sbtcheckin( nfail, outnum, maxerr, nerr, mem(erriptr),
12515  $ mem(errdptr), iseed )
12516  END IF
12517  IF( iam .EQ. 0 ) THEN
12518  IF( verb .GT. 1 ) WRITE(outnum,*) ' '
12519  IF( nfail+nskip .EQ. 0 ) THEN
12520  WRITE(outnum, 7000 ) testnum
12521  ELSE
12522  WRITE(outnum, 8000 ) testnum, testnum-nskip-nfail,
12523  $ nskip, nfail
12524  END IF
12525  END IF
12526 *
12527 * Log whether their were any failures
12528 *
12529  testok = allpass( (nfail.EQ.0) )
12530 *
12531  1000 FORMAT('REAL SUM TESTS: BEGIN.' )
12532  2000 FORMAT(1x,a7,3x,10i6)
12533  3000 FORMAT(1x,a7,3x,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,
12534  $ 5x,a1,5x,a1)
12535  4000 FORMAT(' TEST# STATUS SCOPE TOP M N LDAS LDAD ',
12536  $ 'RDEST CDEST P Q')
12537  5000 FORMAT(' ----- ------- ----- --- ----- ----- ----- ----- ',
12538  $ '----- ----- ---- ----')
12539  6000 FORMAT(i6,1x,a7,5x,a1,3x,a1,6i6,2i5)
12540  7000 FORMAT('REAL SUM TESTS: PASSED ALL',
12541  $ i5, ' TESTS.')
12542  8000 FORMAT('REAL SUM TESTS:',i5,' TESTS;',i5,' PASSED,',
12543  $ i5,' SKIPPED,',i5,' FAILED.')
12544 *
12545  RETURN
12546 *
12547 * End of STESTSUM.
12548 *
12549  END
12550 *
12551  REAL FUNCTION SBTABS(VAL)
12552  REAL val
12553  sbtabs = abs(val)
12554  RETURN
12555  END
12556 *
12557  REAL function sbteps()
12558 *
12559 * .. External Functions ..
12560  INTEGER ibtmyproc, ibtnprocs, ibtmsgid
12561  REAL slamch
12562  EXTERNAL ibtmyproc, ibtnprocs, ibtmsgid, slamch
12563 * ..
12564 * .. Local Scalars ..
12565  INTEGER i, iam, nnodes
12566  REAL eps, eps2
12567  SAVE eps
12568  DATA eps /-22.0e0/
12569 * ..
12570 * .. Executable Statements ..
12571 *
12572 * First time called, must get max epsilon possessed by any
12573 * participating process
12574 *
12575  IF( eps .EQ. -22.0e0 ) THEN
12576  iam = ibtmyproc()
12577  nnodes = ibtnprocs()
12578  eps = slamch('epsilon')
12579  IF( iam .EQ. 0 ) THEN
12580  IF( nnodes .GT. 1 ) THEN
12581  DO 10 i = 1, nnodes-1
12582  CALL btrecv( 4, 1, eps2, i, ibtmsgid()+20 )
12583  IF( eps .LT. eps2 ) eps = eps2
12584  10 CONTINUE
12585  END IF
12586  CALL btsend( 4, 1, eps, -1, ibtmsgid()+20 )
12587  ELSE
12588  CALL btsend( 4, 1, eps, 0, ibtmsgid()+20 )
12589  CALL btrecv( 4, 1, eps, 0, ibtmsgid()+20 )
12590  ENDIF
12591  END IF
12592  sbteps = eps
12593  RETURN
12594 *
12595 * End SBTEPS
12596 *
12597  END
12598 *
12599  SUBROUTINE schksum( SCOPE, ICTXT, M, N, A, LDA, TESTNUM, MAXERR,
12600  $ NERR, ERRIBUF, ERRDBUF, ISEED )
12601 *
12602 * .. Scalar Arguments ..
12603  CHARACTER*1 SCOPE
12604  INTEGER ICTXT, M, N, LDA, TESTNUM, MAXERR, NERR
12605 * ..
12606 * .. Array Arguments ..
12607  INTEGER ERRIBUF(6, MAXERR), ISEED(*)
12608  REAL A(LDA,*), ERRDBUF(2, MAXERR)
12609 * ..
12610 * .. External Functions ..
12611  INTEGER IBTMYPROC, IBTNPROCS
12612  REAL SBTEPS
12613  REAL SBTRAN
12614  EXTERNAL ibtmyproc, ibtnprocs, sbteps, sbtran
12615 * ..
12616 * .. Local Scalars ..
12617  INTEGER NPROCS, NPROW, NPCOL, MYROW, MYCOL, NODE, NNODES, DEST
12618  INTEGER I, J, K
12619  REAL ANS, EPS, ERRBND, POSNUM, NEGNUM, TMP
12620 * ..
12621 * .. Executable Statements ..
12622 *
12623  nprocs = ibtnprocs()
12624  eps = sbteps()
12625  CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
12626  dest = myrow*nprocs + mycol
12627 *
12628 * Set up seeds to match those used by each proc's genmat call
12629 *
12630  IF( scope .EQ. 'R' ) THEN
12631  nnodes = npcol
12632  DO 10 i = 0, nnodes-1
12633  node = myrow * nprocs + i
12634  iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
12635  iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
12636  iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
12637  iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
12638  10 CONTINUE
12639  ELSE IF( scope .EQ. 'C' ) THEN
12640  nnodes = nprow
12641  DO 20 i = 0, nnodes-1
12642  node = i * nprocs + mycol
12643  iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
12644  iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
12645  iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
12646  iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
12647  20 CONTINUE
12648  ELSE
12649  nnodes = nprow * npcol
12650  DO 30 i = 0, nnodes-1
12651  node = (i / npcol) * nprocs + mod(i, npcol)
12652  iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
12653  iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
12654  iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
12655  iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
12656  30 CONTINUE
12657  END IF
12658 *
12659  DO 100 j = 1, n
12660  DO 90 i = 1, m
12661  ans = 0
12662  posnum = 0
12663  negnum = 0
12664  DO 40 k = 0, nnodes-1
12665  tmp = sbtran( iseed(k*4+1) )
12666  IF( tmp .LT. 0 ) THEN
12667  negnum = negnum + tmp
12668  ELSE
12669  posnum = posnum + tmp
12670  END IF
12671  ans = ans + tmp
12672  40 CONTINUE
12673 *
12674 * The error bound is figured by
12675 * 2 * eps * (nnodes-1) * max(|max element|, |ans|).
12676 * The 2 allows for errors in the distributed _AND_ local result.
12677 * The eps is machine epsilon. The number of floating point adds
12678 * is (nnodes - 1). We use the fact that 0.5 is the maximum element
12679 * in order to save ourselves some computation.
12680 *
12681  errbnd = 2 * eps * nnodes * max( posnum, -negnum )
12682  IF( abs( ans - a(i,j) ) .GT. errbnd ) THEN
12683  nerr = nerr + 1
12684  IF( nerr .LE. maxerr ) THEN
12685  erribuf(1, nerr) = testnum
12686  erribuf(2, nerr) = nnodes
12687  erribuf(3, nerr) = dest
12688  erribuf(4, nerr) = i
12689  erribuf(5, nerr) = j
12690  erribuf(6, nerr) = 5
12691  errdbuf(1, nerr) = a(i,j)
12692  errdbuf(2, nerr) = ans
12693  END IF
12694  END IF
12695  90 CONTINUE
12696  100 CONTINUE
12697 *
12698  RETURN
12699 *
12700 * End of SCHKSUM
12701 *
12702  END
12703 *
12704 *
12705  SUBROUTINE dsumtest( OUTNUM, VERB, TOPSREPEAT, TOPSCOHRNT, NSCOPE,
12706  $ SCOPE0, NTOP, TOP0, NMAT, M0, N0, LDAS0,
12707  $ LDAD0, NDEST, RDEST0, CDEST0, NGRID,
12708  $ CONTEXT0, P0, Q0, ISEED, MEM, MEMLEN )
12709 *
12710 * -- BLACS tester (version 1.0) --
12711 * University of Tennessee
12712 * December 15, 1994
12713 *
12714 *
12715 * .. Scalar Arguments ..
12716  INTEGER MEMLEN, NDEST, NGRID, NMAT, NSCOPE, NTOP, OUTNUM,
12717  $ TOPSCOHRNT, TOPSREPEAT, VERB
12718 * ..
12719 * .. Array Arguments ..
12720  CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP)
12721  INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT)
12722  INTEGER RDEST0(NDEST), CDEST0(NDEST), CONTEXT0(NGRID)
12723  INTEGER P0(NGRID), Q0(NGRID), ISEED(*)
12724  DOUBLE PRECISION MEM(MEMLEN)
12725 * ..
12726 *
12727 * Purpose
12728 * =======
12729 * DTESTSUM: Test double precision SUM COMBINE
12730 *
12731 * Arguments
12732 * =========
12733 * OUTNUM (input) INTEGER
12734 * The device number to write output to.
12735 *
12736 * VERB (input) INTEGER
12737 * The level of verbosity (how much printing to do).
12738 *
12739 * NSCOPE (input) INTEGER
12740 * The number of scopes to be tested.
12741 *
12742 * SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE)
12743 * Values of the scopes to be tested.
12744 *
12745 * NTOP (input) INTEGER
12746 * The number of topologies to be tested.
12747 *
12748 * TOP0 (input) CHARACTER*1 array of dimension (NTOP)
12749 * Values of the topologies to be tested.
12750 *
12751 * NMAT (input) INTEGER
12752 * The number of matrices to be tested.
12753 *
12754 * M0 (input) INTEGER array of dimension (NMAT)
12755 * Values of M to be tested.
12756 *
12757 * M0 (input) INTEGER array of dimension (NMAT)
12758 * Values of M to be tested.
12759 *
12760 * N0 (input) INTEGER array of dimension (NMAT)
12761 * Values of N to be tested.
12762 *
12763 * LDAS0 (input) INTEGER array of dimension (NMAT)
12764 * Values of LDAS (leading dimension of A on source process)
12765 * to be tested.
12766 *
12767 * LDAD0 (input) INTEGER array of dimension (NMAT)
12768 * Values of LDAD (leading dimension of A on destination
12769 * process) to be tested.
12770 * NDEST (input) INTEGER
12771 * The number of destinations to be tested.
12772 *
12773 * RDEST0 (input) INTEGER array of dimension (NNDEST)
12774 * Values of RDEST (row coordinate of destination) to be
12775 * tested.
12776 *
12777 * CDEST0 (input) INTEGER array of dimension (NNDEST)
12778 * Values of CDEST (column coordinate of destination) to be
12779 * tested.
12780 *
12781 * NGRID (input) INTEGER
12782 * The number of process grids to be tested.
12783 *
12784 * CONTEXT0 (input) INTEGER array of dimension (NGRID)
12785 * The BLACS context handles corresponding to the grids.
12786 *
12787 * P0 (input) INTEGER array of dimension (NGRID)
12788 * Values of P (number of process rows, NPROW).
12789 *
12790 * Q0 (input) INTEGER array of dimension (NGRID)
12791 * Values of Q (number of process columns, NPCOL).
12792 *
12793 * ISEED (workspace) INTEGER array of dimension ( MAX(NPROCS, NTESTS) )
12794 * Workspace used to hold each process's random number SEED.
12795 * This requires NPROCS (number of processor) elements.
12796 * If VERB < 2, this workspace also serves to indicate which
12797 * tests fail. This requires workspace of NTESTS
12798 * (number of tests performed).
12799 *
12800 * MEM (workspace) DOUBLE PRECISION array of dimension (MEMLEN)
12801 * Used for all other workspaces, including the matrix A,
12802 * and its pre and post padding.
12803 *
12804 * MEMLEN (input) INTEGER
12805 * The length, in elements, of MEM.
12806 *
12807 * =====================================================================
12808 *
12809 * .. External Functions ..
12810  LOGICAL ALLPASS, LSAME
12811  INTEGER IBTMYPROC, IBTNPROCS, IBTSIZEOF
12812  EXTERNAL ALLPASS, LSAME, IBTMYPROC, IBTNPROCS, IBTSIZEOF
12813 * ..
12814 * .. External Subroutines ..
12815  EXTERNAL blacs_gridinfo, dgsum2d
12816  EXTERNAL dinitmat, dchkpad, dbtcheckin
12817 * ..
12818 * .. Local Scalars ..
12819  CHARACTER*1 SCOPE, TOP
12820  LOGICAL INGRID, TESTOK, ALLRCV
12821  INTEGER APTR, CDEST, CDEST2, CONTEXT, DSIZE, ERRDPTR, ERRIPTR, I,
12822  $ IAM, IDE, IGR, IMA, IPAD, IPOST, IPRE, ISC, ISIZE, ISTART,
12823  $ ISTOP, ITC, ITC1, ITC2, ITO, ITR, ITR1, ITR2, J, K, LDA,
12824  $ LDADST, LDASRC, M, MAXERR, MYCOL, MYROW, N, NERR, NFAIL,
12825  $ NPCOL, NPROW, NSKIP, PREAPTR, RDEST, RDEST2, SETWHAT,
12826  $ TESTNUM
12827  DOUBLE PRECISION CHECKVAL
12828 * ..
12829 * .. Executable Statements ..
12830 *
12831 * Choose padding value, and make it unique
12832 *
12833  CHECKVAL = -0.81d0
12834  iam = ibtmyproc()
12835  checkval = iam * checkval
12836  isize = ibtsizeof('I')
12837  dsize = ibtsizeof('D')
12838 *
12839 * Verify file parameters
12840 *
12841  IF( iam .EQ. 0 ) THEN
12842  WRITE(outnum, *) ' '
12843  WRITE(outnum, *) ' '
12844  WRITE(outnum, 1000 )
12845  IF( verb .GT. 0 ) THEN
12846  WRITE(outnum,*) ' '
12847  WRITE(outnum, 2000) 'NSCOPE:', nscope
12848  WRITE(outnum, 3000) ' SCOPE:', ( scope0(i), i = 1, nscope )
12849  WRITE(outnum, 2000) 'TReps :', topsrepeat
12850  WRITE(outnum, 2000) 'TCohr :', topscohrnt
12851  WRITE(outnum, 2000) 'NTOP :', ntop
12852  WRITE(outnum, 3000) ' TOP :', ( top0(i), i = 1, ntop )
12853  WRITE(outnum, 2000) 'NMAT :', nmat
12854  WRITE(outnum, 2000) ' M :', ( m0(i), i = 1, nmat )
12855  WRITE(outnum, 2000) ' N :', ( n0(i), i = 1, nmat )
12856  WRITE(outnum, 2000) ' LDAS :', ( ldas0(i), i = 1, nmat )
12857  WRITE(outnum, 2000) ' LDAD :', ( ldad0(i), i = 1, nmat )
12858  WRITE(outnum, 2000) 'NDEST :', ndest
12859  WRITE(outnum, 2000) ' RDEST:',( rdest0(i), i = 1, ndest )
12860  WRITE(outnum, 2000) ' CDEST:',( cdest0(i), i = 1, ndest )
12861  WRITE(outnum, 2000) 'NGRIDS:', ngrid
12862  WRITE(outnum, 2000) ' P :', ( p0(i), i = 1, ngrid )
12863  WRITE(outnum, 2000) ' Q :', ( q0(i), i = 1, ngrid )
12864  WRITE(outnum, 2000) 'VERB :', verb
12865  WRITE(outnum,*) ' '
12866  END IF
12867  IF( verb .GT. 1 ) THEN
12868  WRITE(outnum,4000)
12869  WRITE(outnum,5000)
12870  END IF
12871  END IF
12872  IF (topsrepeat.EQ.0) THEN
12873  itr1 = 0
12874  itr2 = 0
12875  ELSE IF (topsrepeat.EQ.1) THEN
12876  itr1 = 1
12877  itr2 = 1
12878  ELSE
12879  itr1 = 0
12880  itr2 = 1
12881  END IF
12882 *
12883 * Find biggest matrix, so we know where to stick error info
12884 *
12885  i = 0
12886  DO 10 ima = 1, nmat
12887  ipad = 4 * m0(ima)
12888  k = n0(ima) * max0( ldas0(ima), ldad0(ima) ) + ipad
12889  IF( k .GT. i ) i = k
12890  10 CONTINUE
12891  maxerr = ( dsize * (memlen-i) ) / ( dsize*2 + isize*6 )
12892  IF( maxerr .LT. 1 ) THEN
12893  WRITE(outnum,*) 'ERROR: Not enough memory to run SUM tests.'
12894  CALL blacs_abort(-1, 1)
12895  END IF
12896  errdptr = i + 1
12897  erriptr = errdptr + maxerr
12898  nerr = 0
12899  testnum = 0
12900  nfail = 0
12901  nskip = 0
12902 *
12903 * Loop over grids of matrix
12904 *
12905  DO 90 igr = 1, ngrid
12906 *
12907 * allocate process grid for the next batch of tests
12908 *
12909  context = context0(igr)
12910  CALL blacs_gridinfo( context, nprow, npcol, myrow, mycol )
12911  ingrid = ( (myrow.LT.nprow) .AND. (mycol.LT.npcol) )
12912 *
12913  DO 80 isc = 1, nscope
12914  scope = scope0(isc)
12915  DO 70 ito = 1, ntop
12916  top = top0(ito)
12917 *
12918 * If testing multiring ('M') or general tree ('T'), need to
12919 * loop over calls to BLACS_SET to do full test
12920 *
12921  IF( lsame(top, 'M') ) THEN
12922  setwhat = 13
12923  IF( scope .EQ. 'R' ) THEN
12924  istart = -(npcol - 1)
12925  istop = -istart
12926  ELSE IF (scope .EQ. 'C') THEN
12927  istart = -(nprow - 1)
12928  istop = -istart
12929  ELSE
12930  istart = -(nprow*npcol - 1)
12931  istop = -istart
12932  ENDIF
12933  ELSE IF( lsame(top, 'T') ) THEN
12934  setwhat = 14
12935  istart = 1
12936  IF( scope .EQ. 'R' ) THEN
12937  istop = npcol - 1
12938  ELSE IF (scope .EQ. 'C') THEN
12939  istop = nprow - 1
12940  ELSE
12941  istop = nprow*npcol - 1
12942  ENDIF
12943  ELSE
12944  setwhat = 0
12945  istart = 1
12946  istop = 1
12947  ENDIF
12948  DO 60 ima = 1, nmat
12949  m = m0(ima)
12950  n = n0(ima)
12951  ldasrc = ldas0(ima)
12952  ldadst = ldad0(ima)
12953  ipre = 2 * m
12954  ipost = ipre
12955  preaptr = 1
12956  aptr = preaptr + ipre
12957 *
12958  DO 50 ide = 1, ndest
12959  testnum = testnum + 1
12960  rdest2 = rdest0(ide)
12961  cdest2 = cdest0(ide)
12962 *
12963 * If everyone gets the answer, create some bogus rdest/cdest
12964 * so IF's are easier
12965 *
12966  allrcv = ( (rdest2.EQ.-1) .OR. (cdest2.EQ.-1) )
12967  IF( allrcv ) THEN
12968  rdest = nprow - 1
12969  cdest = npcol - 1
12970  IF (topscohrnt.EQ.0) THEN
12971  itr1 = 0
12972  itr2 = 0
12973  ELSE IF (topscohrnt.EQ.1) THEN
12974  itr1 = 1
12975  itr2 = 1
12976  ELSE
12977  itr1 = 0
12978  itr2 = 1
12979  END IF
12980  ELSE
12981  rdest = rdest2
12982  cdest = cdest2
12983  itc1 = 0
12984  itc2 = 0
12985  END IF
12986  IF( rdest.GE.p0(igr) .OR. cdest.GE.q0(igr) ) THEN
12987  nskip = nskip + 1
12988  GOTO 50
12989  END IF
12990 *
12991  IF( myrow.EQ.rdest .AND. mycol.EQ.cdest ) THEN
12992  lda = ldadst
12993  ELSE
12994  lda = ldasrc
12995  END IF
12996  IF( verb .GT. 1 ) THEN
12997  IF( iam .EQ. 0 ) THEN
12998  WRITE(outnum, 6000)
12999  $ testnum, 'RUNNING', scope, top, m, n,
13000  $ ldasrc, ldadst, rdest2, cdest2,
13001  $ nprow, npcol
13002  END IF
13003  END IF
13004 *
13005 * If I am in scope
13006 *
13007  testok = .true.
13008  IF( ingrid ) THEN
13009  IF( (myrow.EQ.rdest .AND. scope.EQ.'R') .OR.
13010  $ (mycol.EQ.cdest .AND. scope.EQ.'C') .OR.
13011  $ (scope .EQ. 'A') ) THEN
13012 *
13013  k = nerr
13014  DO 40 itr = itr1, itr2
13015  CALL blacs_set(context, 15, itr)
13016  DO 35 itc = itc1, itc2
13017  CALL blacs_set(context, 16, itc)
13018  DO 30 j = istart, istop
13019  IF( j.EQ.0) GOTO 30
13020  IF( setwhat.NE.0 )
13021  $ CALL blacs_set(context, setwhat, j)
13022 *
13023 *
13024 * generate and pad matrix A
13025 *
13026  CALL dinitmat('G','-', m, n, mem(preaptr),
13027  $ lda, ipre, ipost,
13028  $ checkval, testnum,
13029  $ myrow, mycol )
13030 *
13031  CALL dgsum2d(context, scope, top, m, n,
13032  $ mem(aptr), lda, rdest2,
13033  $ cdest2)
13034 *
13035 * If I've got the answer, check for errors in
13036 * matrix or padding
13037 *
13038  IF( (myrow.EQ.rdest .AND. mycol.EQ.cdest)
13039  $ .OR. allrcv ) THEN
13040  CALL dchkpad('G','-', m, n,
13041  $ mem(preaptr), lda, rdest,
13042  $ cdest, myrow, mycol,
13043  $ ipre, ipost, checkval,
13044  $ testnum, maxerr, nerr,
13045  $ mem(erriptr),mem(errdptr))
13046  CALL dchksum(scope, context, m, n,
13047  $ mem(aptr), lda,
13048  $ testnum, maxerr, nerr,
13049  $ mem(erriptr),mem(errdptr),
13050  $ iseed)
13051  END IF
13052  30 CONTINUE
13053  CALL blacs_set(context, 16, 0)
13054  35 CONTINUE
13055  CALL blacs_set(context, 15, 0)
13056  40 CONTINUE
13057  testok = ( k .EQ. nerr )
13058  END IF
13059  END IF
13060 *
13061  IF( verb .GT. 1 ) THEN
13062  i = nerr
13063  CALL dbtcheckin(0, outnum, maxerr, nerr,
13064  $ mem(erriptr), mem(errdptr), iseed)
13065  IF( iam .EQ. 0 ) THEN
13066  IF( testok .AND. nerr.EQ.i ) THEN
13067  WRITE(outnum,6000)testnum,'PASSED ',
13068  $ scope, top, m, n, ldasrc,
13069  $ ldadst, rdest2, cdest2,
13070  $ nprow, npcol
13071  ELSE
13072  nfail = nfail + 1
13073  WRITE(outnum,6000)testnum,'FAILED ',
13074  $ scope, top, m, n, ldasrc,
13075  $ ldadst, rdest2, cdest2,
13076  $ nprow, npcol
13077  END IF
13078  END IF
13079 *
13080 * Once we've printed out errors, can re-use buf space
13081 *
13082  nerr = 0
13083  END IF
13084  50 CONTINUE
13085  60 CONTINUE
13086  70 CONTINUE
13087  80 CONTINUE
13088  90 CONTINUE
13089 *
13090  IF( verb .LT. 2 ) THEN
13091  nfail = testnum
13092  CALL dbtcheckin( nfail, outnum, maxerr, nerr, mem(erriptr),
13093  $ mem(errdptr), iseed )
13094  END IF
13095  IF( iam .EQ. 0 ) THEN
13096  IF( verb .GT. 1 ) WRITE(outnum,*) ' '
13097  IF( nfail+nskip .EQ. 0 ) THEN
13098  WRITE(outnum, 7000 ) testnum
13099  ELSE
13100  WRITE(outnum, 8000 ) testnum, testnum-nskip-nfail,
13101  $ nskip, nfail
13102  END IF
13103  END IF
13104 *
13105 * Log whether their were any failures
13106 *
13107  testok = allpass( (nfail.EQ.0) )
13108 *
13109  1000 FORMAT('DOUBLE PRECISION SUM TESTS: BEGIN.' )
13110  2000 FORMAT(1x,a7,3x,10i6)
13111  3000 FORMAT(1x,a7,3x,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,
13112  $ 5x,a1,5x,a1)
13113  4000 FORMAT(' TEST# STATUS SCOPE TOP M N LDAS LDAD ',
13114  $ 'RDEST CDEST P Q')
13115  5000 FORMAT(' ----- ------- ----- --- ----- ----- ----- ----- ',
13116  $ '----- ----- ---- ----')
13117  6000 FORMAT(i6,1x,a7,5x,a1,3x,a1,6i6,2i5)
13118  7000 FORMAT('DOUBLE PRECISION SUM TESTS: PASSED ALL',
13119  $ i5, ' TESTS.')
13120  8000 FORMAT('DOUBLE PRECISION SUM TESTS:',i5,' TESTS;',i5,' PASSED,',
13121  $ i5,' SKIPPED,',i5,' FAILED.')
13122 *
13123  RETURN
13124 *
13125 * End of DTESTSUM.
13126 *
13127  END
13128 *
13129  DOUBLE PRECISION FUNCTION dbtabs(VAL)
13130  DOUBLE PRECISION val
13131  dbtabs = abs(val)
13132  RETURN
13133  END
13134 *
13135  DOUBLE PRECISION FUNCTION dbteps()
13136 *
13137 * .. External Functions ..
13138  INTEGER ibtmyproc, ibtnprocs, ibtmsgid
13139  DOUBLE PRECISION dlamch
13140  EXTERNAL ibtmyproc, ibtnprocs, ibtmsgid, dlamch
13141 * ..
13142 * .. Local Scalars ..
13143  INTEGER i, iam, nnodes
13144  DOUBLE PRECISION eps, eps2
13145  SAVE eps
13146  data eps /-22.0d0/
13147 * ..
13148 * .. Executable Statements ..
13149 *
13150 * First time called, must get max epsilon possessed by any
13151 * participating process
13152 *
13153  IF( eps .EQ. -22.0d0 ) THEN
13154  iam = ibtmyproc()
13155  nnodes = ibtnprocs()
13156  eps = dlamch('epsilon')
13157  IF( iam .EQ. 0 ) THEN
13158  IF( nnodes .GT. 1 ) THEN
13159  DO 10 i = 1, nnodes-1
13160  CALL btrecv( 6, 1, eps2, i, ibtmsgid()+20 )
13161  IF( eps .LT. eps2 ) eps = eps2
13162  10 CONTINUE
13163  END IF
13164  CALL btsend( 6, 1, eps, -1, ibtmsgid()+20 )
13165  ELSE
13166  CALL btsend( 6, 1, eps, 0, ibtmsgid()+20 )
13167  CALL btrecv( 6, 1, eps, 0, ibtmsgid()+20 )
13168  ENDIF
13169  END IF
13170  dbteps = eps
13171  RETURN
13172 *
13173 * End DBTEPS
13174 *
13175  END
13176 *
13177  SUBROUTINE dchksum( SCOPE, ICTXT, M, N, A, LDA, TESTNUM, MAXERR,
13178  $ NERR, ERRIBUF, ERRDBUF, ISEED )
13179 *
13180 * .. Scalar Arguments ..
13181  CHARACTER*1 SCOPE
13182  INTEGER ICTXT, M, N, LDA, TESTNUM, MAXERR, NERR
13183 * ..
13184 * .. Array Arguments ..
13185  INTEGER ERRIBUF(6, MAXERR), ISEED(*)
13186  DOUBLE PRECISION A(LDA,*), ERRDBUF(2, MAXERR)
13187 * ..
13188 * .. External Functions ..
13189  INTEGER IBTMYPROC, IBTNPROCS
13190  DOUBLE PRECISION DBTEPS
13191  DOUBLE PRECISION DBTRAN
13192  EXTERNAL ibtmyproc, ibtnprocs, dbteps, dbtran
13193 * ..
13194 * .. Local Scalars ..
13195  INTEGER NPROCS, NPROW, NPCOL, MYROW, MYCOL, NODE, NNODES, DEST
13196  INTEGER I, J, K
13197  DOUBLE PRECISION ANS, EPS, ERRBND, POSNUM, NEGNUM, TMP
13198 * ..
13199 * .. Executable Statements ..
13200 *
13201  nprocs = ibtnprocs()
13202  eps = dbteps()
13203  CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
13204  dest = myrow*nprocs + mycol
13205 *
13206 * Set up seeds to match those used by each proc's genmat call
13207 *
13208  IF( scope .EQ. 'R' ) THEN
13209  nnodes = npcol
13210  DO 10 i = 0, nnodes-1
13211  node = myrow * nprocs + i
13212  iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
13213  iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
13214  iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
13215  iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
13216  10 CONTINUE
13217  ELSE IF( scope .EQ. 'C' ) THEN
13218  nnodes = nprow
13219  DO 20 i = 0, nnodes-1
13220  node = i * nprocs + mycol
13221  iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
13222  iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
13223  iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
13224  iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
13225  20 CONTINUE
13226  ELSE
13227  nnodes = nprow * npcol
13228  DO 30 i = 0, nnodes-1
13229  node = (i / npcol) * nprocs + mod(i, npcol)
13230  iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
13231  iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
13232  iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
13233  iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
13234  30 CONTINUE
13235  END IF
13236 *
13237  DO 100 j = 1, n
13238  DO 90 i = 1, m
13239  ans = 0
13240  posnum = 0
13241  negnum = 0
13242  DO 40 k = 0, nnodes-1
13243  tmp = dbtran( iseed(k*4+1) )
13244  IF( tmp .LT. 0 ) THEN
13245  negnum = negnum + tmp
13246  ELSE
13247  posnum = posnum + tmp
13248  END IF
13249  ans = ans + tmp
13250  40 CONTINUE
13251 *
13252 * The error bound is figured by
13253 * 2 * eps * (nnodes-1) * max(|max element|, |ans|).
13254 * The 2 allows for errors in the distributed _AND_ local result.
13255 * The eps is machine epsilon. The number of floating point adds
13256 * is (nnodes - 1). We use the fact that 0.5 is the maximum element
13257 * in order to save ourselves some computation.
13258 *
13259  errbnd = 2 * eps * nnodes * max( posnum, -negnum )
13260  IF( abs( ans - a(i,j) ) .GT. errbnd ) THEN
13261  nerr = nerr + 1
13262  IF( nerr .LE. maxerr ) THEN
13263  erribuf(1, nerr) = testnum
13264  erribuf(2, nerr) = nnodes
13265  erribuf(3, nerr) = dest
13266  erribuf(4, nerr) = i
13267  erribuf(5, nerr) = j
13268  erribuf(6, nerr) = 5
13269  errdbuf(1, nerr) = a(i,j)
13270  errdbuf(2, nerr) = ans
13271  END IF
13272  END IF
13273  90 CONTINUE
13274  100 CONTINUE
13275 *
13276  RETURN
13277 *
13278 * End of DCHKSUM
13279 *
13280  END
13281 *
13282 *
13283  SUBROUTINE csumtest( OUTNUM, VERB, TOPSREPEAT, TOPSCOHRNT, NSCOPE,
13284  $ SCOPE0, NTOP, TOP0, NMAT, M0, N0, LDAS0,
13285  $ LDAD0, NDEST, RDEST0, CDEST0, NGRID,
13286  $ CONTEXT0, P0, Q0, ISEED, MEM, MEMLEN )
13287 *
13288 * -- BLACS tester (version 1.0) --
13289 * University of Tennessee
13290 * December 15, 1994
13291 *
13292 *
13293 * .. Scalar Arguments ..
13294  INTEGER MEMLEN, NDEST, NGRID, NMAT, NSCOPE, NTOP, OUTNUM,
13295  $ TOPSCOHRNT, TOPSREPEAT, VERB
13296 * ..
13297 * .. Array Arguments ..
13298  CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP)
13299  INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT)
13300  INTEGER RDEST0(NDEST), CDEST0(NDEST), CONTEXT0(NGRID)
13301  INTEGER P0(NGRID), Q0(NGRID), ISEED(*)
13302  COMPLEX MEM(MEMLEN)
13303 * ..
13304 *
13305 * Purpose
13306 * =======
13307 * CTESTSUM: Test complex SUM COMBINE
13308 *
13309 * Arguments
13310 * =========
13311 * OUTNUM (input) INTEGER
13312 * The device number to write output to.
13313 *
13314 * VERB (input) INTEGER
13315 * The level of verbosity (how much printing to do).
13316 *
13317 * NSCOPE (input) INTEGER
13318 * The number of scopes to be tested.
13319 *
13320 * SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE)
13321 * Values of the scopes to be tested.
13322 *
13323 * NTOP (input) INTEGER
13324 * The number of topologies to be tested.
13325 *
13326 * TOP0 (input) CHARACTER*1 array of dimension (NTOP)
13327 * Values of the topologies to be tested.
13328 *
13329 * NMAT (input) INTEGER
13330 * The number of matrices to be tested.
13331 *
13332 * M0 (input) INTEGER array of dimension (NMAT)
13333 * Values of M to be tested.
13334 *
13335 * M0 (input) INTEGER array of dimension (NMAT)
13336 * Values of M to be tested.
13337 *
13338 * N0 (input) INTEGER array of dimension (NMAT)
13339 * Values of N to be tested.
13340 *
13341 * LDAS0 (input) INTEGER array of dimension (NMAT)
13342 * Values of LDAS (leading dimension of A on source process)
13343 * to be tested.
13344 *
13345 * LDAD0 (input) INTEGER array of dimension (NMAT)
13346 * Values of LDAD (leading dimension of A on destination
13347 * process) to be tested.
13348 * NDEST (input) INTEGER
13349 * The number of destinations to be tested.
13350 *
13351 * RDEST0 (input) INTEGER array of dimension (NNDEST)
13352 * Values of RDEST (row coordinate of destination) to be
13353 * tested.
13354 *
13355 * CDEST0 (input) INTEGER array of dimension (NNDEST)
13356 * Values of CDEST (column coordinate of destination) to be
13357 * tested.
13358 *
13359 * NGRID (input) INTEGER
13360 * The number of process grids to be tested.
13361 *
13362 * CONTEXT0 (input) INTEGER array of dimension (NGRID)
13363 * The BLACS context handles corresponding to the grids.
13364 *
13365 * P0 (input) INTEGER array of dimension (NGRID)
13366 * Values of P (number of process rows, NPROW).
13367 *
13368 * Q0 (input) INTEGER array of dimension (NGRID)
13369 * Values of Q (number of process columns, NPCOL).
13370 *
13371 * ISEED (workspace) INTEGER array of dimension ( MAX(NPROCS, NTESTS) )
13372 * Workspace used to hold each process's random number SEED.
13373 * This requires NPROCS (number of processor) elements.
13374 * If VERB < 2, this workspace also serves to indicate which
13375 * tests fail. This requires workspace of NTESTS
13376 * (number of tests performed).
13377 *
13378 * MEM (workspace) COMPLEX array of dimension (MEMLEN)
13379 * Used for all other workspaces, including the matrix A,
13380 * and its pre and post padding.
13381 *
13382 * MEMLEN (input) INTEGER
13383 * The length, in elements, of MEM.
13384 *
13385 * =====================================================================
13386 *
13387 * .. External Functions ..
13388  LOGICAL ALLPASS, LSAME
13389  INTEGER IBTMYPROC, IBTNPROCS, IBTSIZEOF
13390  EXTERNAL ALLPASS, LSAME, IBTMYPROC, IBTNPROCS, IBTSIZEOF
13391 * ..
13392 * .. External Subroutines ..
13393  EXTERNAL BLACS_GRIDINFO, CGSUM2D
13394  EXTERNAL CINITMAT, CCHKPAD, CBTCHECKIN
13395 * ..
13396 * .. Local Scalars ..
13397  CHARACTER*1 SCOPE, TOP
13398  LOGICAL INGRID, TESTOK, ALLRCV
13399  INTEGER APTR, CDEST, CDEST2, CONTEXT, CSIZE, ERRDPTR, ERRIPTR, I,
13400  $ iam, ide, igr, ima, ipad, ipost, ipre, isc, isize, istart,
13401  $ istop, itc, itc1, itc2, ito, itr, itr1, itr2, j, k, lda,
13402  $ ldadst, ldasrc, m, maxerr, mycol, myrow, n, nerr, nfail,
13403  $ npcol, nprow, nskip, preaptr, rdest, rdest2, setwhat,
13404  $ testnum
13405  COMPLEX CHECKVAL
13406 * ..
13407 * .. Executable Statements ..
13408 *
13409 * Choose padding value, and make it unique
13410 *
13411  CHECKVAL = cmplx( -0.91e0, -0.71e0 )
13412  iam = ibtmyproc()
13413  checkval = iam * checkval
13414  isize = ibtsizeof('I')
13415  csize = ibtsizeof('C')
13416 *
13417 * Verify file parameters
13418 *
13419  IF( iam .EQ. 0 ) THEN
13420  WRITE(outnum, *) ' '
13421  WRITE(outnum, *) ' '
13422  WRITE(outnum, 1000 )
13423  IF( verb .GT. 0 ) THEN
13424  WRITE(outnum,*) ' '
13425  WRITE(outnum, 2000) 'NSCOPE:', nscope
13426  WRITE(outnum, 3000) ' SCOPE:', ( scope0(i), i = 1, nscope )
13427  WRITE(outnum, 2000) 'TReps :', topsrepeat
13428  WRITE(outnum, 2000) 'TCohr :', topscohrnt
13429  WRITE(outnum, 2000) 'NTOP :', ntop
13430  WRITE(outnum, 3000) ' TOP :', ( top0(i), i = 1, ntop )
13431  WRITE(outnum, 2000) 'NMAT :', nmat
13432  WRITE(outnum, 2000) ' M :', ( m0(i), i = 1, nmat )
13433  WRITE(outnum, 2000) ' N :', ( n0(i), i = 1, nmat )
13434  WRITE(outnum, 2000) ' LDAS :', ( ldas0(i), i = 1, nmat )
13435  WRITE(outnum, 2000) ' LDAD :', ( ldad0(i), i = 1, nmat )
13436  WRITE(outnum, 2000) 'NDEST :', ndest
13437  WRITE(outnum, 2000) ' RDEST:',( rdest0(i), i = 1, ndest )
13438  WRITE(outnum, 2000) ' CDEST:',( cdest0(i), i = 1, ndest )
13439  WRITE(outnum, 2000) 'NGRIDS:', ngrid
13440  WRITE(outnum, 2000) ' P :', ( p0(i), i = 1, ngrid )
13441  WRITE(outnum, 2000) ' Q :', ( q0(i), i = 1, ngrid )
13442  WRITE(outnum, 2000) 'VERB :', verb
13443  WRITE(outnum,*) ' '
13444  END IF
13445  IF( verb .GT. 1 ) THEN
13446  WRITE(outnum,4000)
13447  WRITE(outnum,5000)
13448  END IF
13449  END IF
13450  IF (topsrepeat.EQ.0) THEN
13451  itr1 = 0
13452  itr2 = 0
13453  ELSE IF (topsrepeat.EQ.1) THEN
13454  itr1 = 1
13455  itr2 = 1
13456  ELSE
13457  itr1 = 0
13458  itr2 = 1
13459  END IF
13460 *
13461 * Find biggest matrix, so we know where to stick error info
13462 *
13463  i = 0
13464  DO 10 ima = 1, nmat
13465  ipad = 4 * m0(ima)
13466  k = n0(ima) * max0( ldas0(ima), ldad0(ima) ) + ipad
13467  IF( k .GT. i ) i = k
13468  10 CONTINUE
13469  maxerr = ( csize * (memlen-i) ) / ( csize*2 + isize*6 )
13470  IF( maxerr .LT. 1 ) THEN
13471  WRITE(outnum,*) 'ERROR: Not enough memory to run SUM tests.'
13472  CALL blacs_abort(-1, 1)
13473  END IF
13474  errdptr = i + 1
13475  erriptr = errdptr + maxerr
13476  nerr = 0
13477  testnum = 0
13478  nfail = 0
13479  nskip = 0
13480 *
13481 * Loop over grids of matrix
13482 *
13483  DO 90 igr = 1, ngrid
13484 *
13485 * allocate process grid for the next batch of tests
13486 *
13487  context = context0(igr)
13488  CALL blacs_gridinfo( context, nprow, npcol, myrow, mycol )
13489  ingrid = ( (myrow.LT.nprow) .AND. (mycol.LT.npcol) )
13490 *
13491  DO 80 isc = 1, nscope
13492  scope = scope0(isc)
13493  DO 70 ito = 1, ntop
13494  top = top0(ito)
13495 *
13496 * If testing multiring ('M') or general tree ('T'), need to
13497 * loop over calls to BLACS_SET to do full test
13498 *
13499  IF( lsame(top, 'M') ) THEN
13500  setwhat = 13
13501  IF( scope .EQ. 'R' ) THEN
13502  istart = -(npcol - 1)
13503  istop = -istart
13504  ELSE IF (scope .EQ. 'C') THEN
13505  istart = -(nprow - 1)
13506  istop = -istart
13507  ELSE
13508  istart = -(nprow*npcol - 1)
13509  istop = -istart
13510  ENDIF
13511  ELSE IF( lsame(top, 'T') ) THEN
13512  setwhat = 14
13513  istart = 1
13514  IF( scope .EQ. 'R' ) THEN
13515  istop = npcol - 1
13516  ELSE IF (scope .EQ. 'C') THEN
13517  istop = nprow - 1
13518  ELSE
13519  istop = nprow*npcol - 1
13520  ENDIF
13521  ELSE
13522  setwhat = 0
13523  istart = 1
13524  istop = 1
13525  ENDIF
13526  DO 60 ima = 1, nmat
13527  m = m0(ima)
13528  n = n0(ima)
13529  ldasrc = ldas0(ima)
13530  ldadst = ldad0(ima)
13531  ipre = 2 * m
13532  ipost = ipre
13533  preaptr = 1
13534  aptr = preaptr + ipre
13535 *
13536  DO 50 ide = 1, ndest
13537  testnum = testnum + 1
13538  rdest2 = rdest0(ide)
13539  cdest2 = cdest0(ide)
13540 *
13541 * If everyone gets the answer, create some bogus rdest/cdest
13542 * so IF's are easier
13543 *
13544  allrcv = ( (rdest2.EQ.-1) .OR. (cdest2.EQ.-1) )
13545  IF( allrcv ) THEN
13546  rdest = nprow - 1
13547  cdest = npcol - 1
13548  IF (topscohrnt.EQ.0) THEN
13549  itr1 = 0
13550  itr2 = 0
13551  ELSE IF (topscohrnt.EQ.1) THEN
13552  itr1 = 1
13553  itr2 = 1
13554  ELSE
13555  itr1 = 0
13556  itr2 = 1
13557  END IF
13558  ELSE
13559  rdest = rdest2
13560  cdest = cdest2
13561  itc1 = 0
13562  itc2 = 0
13563  END IF
13564  IF( rdest.GE.p0(igr) .OR. cdest.GE.q0(igr) ) THEN
13565  nskip = nskip + 1
13566  GOTO 50
13567  END IF
13568 *
13569  IF( myrow.EQ.rdest .AND. mycol.EQ.cdest ) THEN
13570  lda = ldadst
13571  ELSE
13572  lda = ldasrc
13573  END IF
13574  IF( verb .GT. 1 ) THEN
13575  IF( iam .EQ. 0 ) THEN
13576  WRITE(outnum, 6000)
13577  $ testnum, 'RUNNING', scope, top, m, n,
13578  $ ldasrc, ldadst, rdest2, cdest2,
13579  $ nprow, npcol
13580  END IF
13581  END IF
13582 *
13583 * If I am in scope
13584 *
13585  testok = .true.
13586  IF( ingrid ) THEN
13587  IF( (myrow.EQ.rdest .AND. scope.EQ.'R') .OR.
13588  $ (mycol.EQ.cdest .AND. scope.EQ.'C') .OR.
13589  $ (scope .EQ. 'A') ) THEN
13590 *
13591  k = nerr
13592  DO 40 itr = itr1, itr2
13593  CALL blacs_set(context, 15, itr)
13594  DO 35 itc = itc1, itc2
13595  CALL blacs_set(context, 16, itc)
13596  DO 30 j = istart, istop
13597  IF( j.EQ.0) GOTO 30
13598  IF( setwhat.NE.0 )
13599  $ CALL blacs_set(context, setwhat, j)
13600 *
13601 *
13602 * generate and pad matrix A
13603 *
13604  CALL cinitmat('G','-', m, n, mem(preaptr),
13605  $ lda, ipre, ipost,
13606  $ checkval, testnum,
13607  $ myrow, mycol )
13608 *
13609  CALL cgsum2d(context, scope, top, m, n,
13610  $ mem(aptr), lda, rdest2,
13611  $ cdest2)
13612 *
13613 * If I've got the answer, check for errors in
13614 * matrix or padding
13615 *
13616  IF( (myrow.EQ.rdest .AND. mycol.EQ.cdest)
13617  $ .OR. allrcv ) THEN
13618  CALL cchkpad('G','-', m, n,
13619  $ mem(preaptr), lda, rdest,
13620  $ cdest, myrow, mycol,
13621  $ ipre, ipost, checkval,
13622  $ testnum, maxerr, nerr,
13623  $ mem(erriptr),mem(errdptr))
13624  CALL cchksum(scope, context, m, n,
13625  $ mem(aptr), lda,
13626  $ testnum, maxerr, nerr,
13627  $ mem(erriptr),mem(errdptr),
13628  $ iseed)
13629  END IF
13630  30 CONTINUE
13631  CALL blacs_set(context, 16, 0)
13632  35 CONTINUE
13633  CALL blacs_set(context, 15, 0)
13634  40 CONTINUE
13635  testok = ( k .EQ. nerr )
13636  END IF
13637  END IF
13638 *
13639  IF( verb .GT. 1 ) THEN
13640  i = nerr
13641  CALL cbtcheckin(0, outnum, maxerr, nerr,
13642  $ mem(erriptr), mem(errdptr), iseed)
13643  IF( iam .EQ. 0 ) THEN
13644  IF( testok .AND. nerr.EQ.i ) THEN
13645  WRITE(outnum,6000)testnum,'PASSED ',
13646  $ scope, top, m, n, ldasrc,
13647  $ ldadst, rdest2, cdest2,
13648  $ nprow, npcol
13649  ELSE
13650  nfail = nfail + 1
13651  WRITE(outnum,6000)testnum,'FAILED ',
13652  $ scope, top, m, n, ldasrc,
13653  $ ldadst, rdest2, cdest2,
13654  $ nprow, npcol
13655  END IF
13656  END IF
13657 *
13658 * Once we've printed out errors, can re-use buf space
13659 *
13660  nerr = 0
13661  END IF
13662  50 CONTINUE
13663  60 CONTINUE
13664  70 CONTINUE
13665  80 CONTINUE
13666  90 CONTINUE
13667 *
13668  IF( verb .LT. 2 ) THEN
13669  nfail = testnum
13670  CALL cbtcheckin( nfail, outnum, maxerr, nerr, mem(erriptr),
13671  $ mem(errdptr), iseed )
13672  END IF
13673  IF( iam .EQ. 0 ) THEN
13674  IF( verb .GT. 1 ) WRITE(outnum,*) ' '
13675  IF( nfail+nskip .EQ. 0 ) THEN
13676  WRITE(outnum, 7000 ) testnum
13677  ELSE
13678  WRITE(outnum, 8000 ) testnum, testnum-nskip-nfail,
13679  $ nskip, nfail
13680  END IF
13681  END IF
13682 *
13683 * Log whether their were any failures
13684 *
13685  testok = allpass( (nfail.EQ.0) )
13686 *
13687  1000 FORMAT('COMPLEX SUM TESTS: BEGIN.' )
13688  2000 FORMAT(1x,a7,3x,10i6)
13689  3000 FORMAT(1x,a7,3x,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,
13690  $ 5x,a1,5x,a1)
13691  4000 FORMAT(' TEST# STATUS SCOPE TOP M N LDAS LDAD ',
13692  $ 'RDEST CDEST P Q')
13693  5000 FORMAT(' ----- ------- ----- --- ----- ----- ----- ----- ',
13694  $ '----- ----- ---- ----')
13695  6000 FORMAT(i6,1x,a7,5x,a1,3x,a1,6i6,2i5)
13696  7000 FORMAT('COMPLEX SUM TESTS: PASSED ALL',
13697  $ i5, ' TESTS.')
13698  8000 FORMAT('COMPLEX SUM TESTS:',i5,' TESTS;',i5,' PASSED,',
13699  $ i5,' SKIPPED,',i5,' FAILED.')
13700 *
13701  RETURN
13702 *
13703 * End of CTESTSUM.
13704 *
13705  END
13706 *
13707  REAL FUNCTION CBTABS(VAL)
13708  COMPLEX val
13709  cbtabs = abs( real(val) ) + abs( aimag(val) )
13710  RETURN
13711  END
13712 *
13713  SUBROUTINE cchksum( SCOPE, ICTXT, M, N, A, LDA, TESTNUM, MAXERR,
13714  $ NERR, ERRIBUF, ERRDBUF, ISEED )
13715 *
13716 * .. Scalar Arguments ..
13717  CHARACTER*1 SCOPE
13718  INTEGER ICTXT, M, N, LDA, TESTNUM, MAXERR, NERR
13719 * ..
13720 * .. Array Arguments ..
13721  INTEGER ERRIBUF(6, MAXERR), ISEED(*)
13722  COMPLEX A(LDA,*), ERRDBUF(2, MAXERR)
13723 * ..
13724 * .. External Functions ..
13725  INTEGER IBTMYPROC, IBTNPROCS
13726  REAL SBTEPS
13727  COMPLEX CBTRAN
13728  EXTERNAL IBTMYPROC, IBTNPROCS, SBTEPS, CBTRAN
13729 * ..
13730 * .. Local Scalars ..
13731  LOGICAL NUMOK
13732  INTEGER NPROCS, NPROW, NPCOL, MYROW, MYCOL, NODE, NNODES, DEST
13733  INTEGER I, J, K
13734  COMPLEX ANS, TMP
13735  REAL EPS, ERRBND, RPOSNUM, RNEGNUM, IPOSNUM, INEGNUM
13736 * ..
13737 * .. Executable Statements ..
13738 *
13739  nprocs = ibtnprocs()
13740  eps = sbteps()
13741  CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
13742  dest = myrow*nprocs + mycol
13743 *
13744 * Set up seeds to match those used by each proc's genmat call
13745 *
13746  IF( scope .EQ. 'R' ) THEN
13747  nnodes = npcol
13748  DO 10 i = 0, nnodes-1
13749  node = myrow * nprocs + i
13750  iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
13751  iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
13752  iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
13753  iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
13754  10 CONTINUE
13755  ELSE IF( scope .EQ. 'C' ) THEN
13756  nnodes = nprow
13757  DO 20 i = 0, nnodes-1
13758  node = i * nprocs + mycol
13759  iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
13760  iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
13761  iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
13762  iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
13763  20 CONTINUE
13764  ELSE
13765  nnodes = nprow * npcol
13766  DO 30 i = 0, nnodes-1
13767  node = (i / npcol) * nprocs + mod(i, npcol)
13768  iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
13769  iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
13770  iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
13771  iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
13772  30 CONTINUE
13773  END IF
13774 *
13775  DO 100 j = 1, n
13776  DO 90 i = 1, m
13777  ans = 0
13778  rposnum = 0
13779  rnegnum = 0
13780  iposnum = 0
13781  inegnum = 0
13782  DO 40 k = 0, nnodes-1
13783  tmp = cbtran( iseed(k*4+1) )
13784  IF( real( tmp ) .LT. 0 ) THEN
13785  rnegnum = rnegnum + real( tmp )
13786  ELSE
13787  rposnum = rposnum + real( tmp )
13788  END IF
13789  IF( aimag( tmp ) .LT. 0 ) THEN
13790  inegnum = inegnum + aimag( tmp )
13791  ELSE
13792  iposnum = iposnum + aimag( tmp )
13793  END IF
13794  ans = ans + tmp
13795  40 CONTINUE
13796 *
13797 * The error bound is figured by
13798 * 2 * eps * (nnodes-1) * max(|max element|, |ans|).
13799 * The 2 allows for errors in the distributed _AND_ local result.
13800 * The eps is machine epsilon. The number of floating point adds
13801 * is (nnodes - 1). We use the fact that 0.5 is the maximum element
13802 * in order to save ourselves some computation.
13803 *
13804  tmp = ans - a(i,j)
13805  errbnd = 2 * eps * nnodes * max( rposnum, -rnegnum )
13806  numok = ( real(tmp) .LE. errbnd )
13807  errbnd = 2 * eps * nnodes * max( iposnum, -inegnum )
13808  numok = numok .AND. ( aimag(tmp) .LE. errbnd )
13809  IF( .NOT.numok ) THEN
13810  nerr = nerr + 1
13811  IF( nerr .LE. maxerr ) THEN
13812  erribuf(1, nerr) = testnum
13813  erribuf(2, nerr) = nnodes
13814  erribuf(3, nerr) = dest
13815  erribuf(4, nerr) = i
13816  erribuf(5, nerr) = j
13817  erribuf(6, nerr) = 5
13818  errdbuf(1, nerr) = a(i,j)
13819  errdbuf(2, nerr) = ans
13820  END IF
13821  END IF
13822  90 CONTINUE
13823  100 CONTINUE
13824 *
13825  RETURN
13826 *
13827 * End of CCHKSUM
13828 *
13829  END
13830 *
13831 *
13832  SUBROUTINE zsumtest( OUTNUM, VERB, TOPSREPEAT, TOPSCOHRNT, NSCOPE,
13833  $ SCOPE0, NTOP, TOP0, NMAT, M0, N0, LDAS0,
13834  $ LDAD0, NDEST, RDEST0, CDEST0, NGRID,
13835  $ CONTEXT0, P0, Q0, ISEED, MEM, MEMLEN )
13836 *
13837 * -- BLACS tester (version 1.0) --
13838 * University of Tennessee
13839 * December 15, 1994
13840 *
13841 *
13842 * .. Scalar Arguments ..
13843  INTEGER MEMLEN, NDEST, NGRID, NMAT, NSCOPE, NTOP, OUTNUM,
13844  $ topscohrnt, topsrepeat, verb
13845 * ..
13846 * .. Array Arguments ..
13847  CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP)
13848  INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT)
13849  INTEGER RDEST0(NDEST), CDEST0(NDEST), CONTEXT0(NGRID)
13850  INTEGER P0(NGRID), Q0(NGRID), ISEED(*)
13851  DOUBLE COMPLEX MEM(MEMLEN)
13852 * ..
13853 *
13854 * Purpose
13855 * =======
13856 * ZTESTSUM: Test double complex SUM COMBINE
13857 *
13858 * Arguments
13859 * =========
13860 * OUTNUM (input) INTEGER
13861 * The device number to write output to.
13862 *
13863 * VERB (input) INTEGER
13864 * The level of verbosity (how much printing to do).
13865 *
13866 * NSCOPE (input) INTEGER
13867 * The number of scopes to be tested.
13868 *
13869 * SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE)
13870 * Values of the scopes to be tested.
13871 *
13872 * NTOP (input) INTEGER
13873 * The number of topologies to be tested.
13874 *
13875 * TOP0 (input) CHARACTER*1 array of dimension (NTOP)
13876 * Values of the topologies to be tested.
13877 *
13878 * NMAT (input) INTEGER
13879 * The number of matrices to be tested.
13880 *
13881 * M0 (input) INTEGER array of dimension (NMAT)
13882 * Values of M to be tested.
13883 *
13884 * M0 (input) INTEGER array of dimension (NMAT)
13885 * Values of M to be tested.
13886 *
13887 * N0 (input) INTEGER array of dimension (NMAT)
13888 * Values of N to be tested.
13889 *
13890 * LDAS0 (input) INTEGER array of dimension (NMAT)
13891 * Values of LDAS (leading dimension of A on source process)
13892 * to be tested.
13893 *
13894 * LDAD0 (input) INTEGER array of dimension (NMAT)
13895 * Values of LDAD (leading dimension of A on destination
13896 * process) to be tested.
13897 * NDEST (input) INTEGER
13898 * The number of destinations to be tested.
13899 *
13900 * RDEST0 (input) INTEGER array of dimension (NNDEST)
13901 * Values of RDEST (row coordinate of destination) to be
13902 * tested.
13903 *
13904 * CDEST0 (input) INTEGER array of dimension (NNDEST)
13905 * Values of CDEST (column coordinate of destination) to be
13906 * tested.
13907 *
13908 * NGRID (input) INTEGER
13909 * The number of process grids to be tested.
13910 *
13911 * CONTEXT0 (input) INTEGER array of dimension (NGRID)
13912 * The BLACS context handles corresponding to the grids.
13913 *
13914 * P0 (input) INTEGER array of dimension (NGRID)
13915 * Values of P (number of process rows, NPROW).
13916 *
13917 * Q0 (input) INTEGER array of dimension (NGRID)
13918 * Values of Q (number of process columns, NPCOL).
13919 *
13920 * ISEED (workspace) INTEGER array of dimension ( MAX(NPROCS, NTESTS) )
13921 * Workspace used to hold each process's random number SEED.
13922 * This requires NPROCS (number of processor) elements.
13923 * If VERB < 2, this workspace also serves to indicate which
13924 * tests fail. This requires workspace of NTESTS
13925 * (number of tests performed).
13926 *
13927 * MEM (workspace) DOUBLE COMPLEX array of dimension (MEMLEN)
13928 * Used for all other workspaces, including the matrix A,
13929 * and its pre and post padding.
13930 *
13931 * MEMLEN (input) INTEGER
13932 * The length, in elements, of MEM.
13933 *
13934 * =====================================================================
13935 *
13936 * .. External Functions ..
13937  LOGICAL ALLPASS, LSAME
13938  INTEGER IBTMYPROC, IBTNPROCS, IBTSIZEOF
13939  EXTERNAL ALLPASS, LSAME, IBTMYPROC, IBTNPROCS, IBTSIZEOF
13940 * ..
13941 * .. External Subroutines ..
13942  EXTERNAL BLACS_GRIDINFO, ZGSUM2D
13943  EXTERNAL ZINITMAT, ZCHKPAD, ZBTCHECKIN
13944 * ..
13945 * .. Local Scalars ..
13946  CHARACTER*1 SCOPE, TOP
13947  LOGICAL INGRID, TESTOK, ALLRCV
13948  INTEGER APTR, CDEST, CDEST2, CONTEXT, ERRDPTR, ERRIPTR, I, IAM,
13949  $ IDE, IGR, IMA, IPAD, IPOST, IPRE, ISC, ISIZE, ISTART,
13950  $ ISTOP, ITC, ITC1, ITC2, ITO, ITR, ITR1, ITR2, J, K, LDA,
13951  $ LDADST, LDASRC, M, MAXERR, MYCOL, MYROW, N, NERR, NFAIL,
13952  $ npcol, nprow, nskip, preaptr, rdest, rdest2, setwhat,
13953  $ testnum, zsize
13954  DOUBLE COMPLEX CHECKVAL
13955 * ..
13956 * .. Executable Statements ..
13957 *
13958 * Choose padding value, and make it unique
13959 *
13960  checkval = dcmplx( -9.11d0, -9.21d0 )
13961  iam = ibtmyproc()
13962  checkval = iam * checkval
13963  isize = ibtsizeof('I')
13964  zsize = ibtsizeof('Z')
13965 *
13966 * Verify file parameters
13967 *
13968  IF( iam .EQ. 0 ) THEN
13969  WRITE(outnum, *) ' '
13970  WRITE(outnum, *) ' '
13971  WRITE(outnum, 1000 )
13972  IF( verb .GT. 0 ) THEN
13973  WRITE(outnum,*) ' '
13974  WRITE(outnum, 2000) 'NSCOPE:', nscope
13975  WRITE(outnum, 3000) ' SCOPE:', ( scope0(i), i = 1, nscope )
13976  WRITE(outnum, 2000) 'TReps :', topsrepeat
13977  WRITE(outnum, 2000) 'TCohr :', topscohrnt
13978  WRITE(outnum, 2000) 'NTOP :', ntop
13979  WRITE(outnum, 3000) ' TOP :', ( top0(i), i = 1, ntop )
13980  WRITE(outnum, 2000) 'NMAT :', nmat
13981  WRITE(outnum, 2000) ' M :', ( m0(i), i = 1, nmat )
13982  WRITE(outnum, 2000) ' N :', ( n0(i), i = 1, nmat )
13983  WRITE(outnum, 2000) ' LDAS :', ( ldas0(i), i = 1, nmat )
13984  WRITE(outnum, 2000) ' LDAD :', ( ldad0(i), i = 1, nmat )
13985  WRITE(outnum, 2000) 'NDEST :', ndest
13986  WRITE(outnum, 2000) ' RDEST:',( rdest0(i), i = 1, ndest )
13987  WRITE(outnum, 2000) ' CDEST:',( cdest0(i), i = 1, ndest )
13988  WRITE(outnum, 2000) 'NGRIDS:', ngrid
13989  WRITE(outnum, 2000) ' P :', ( p0(i), i = 1, ngrid )
13990  WRITE(outnum, 2000) ' Q :', ( q0(i), i = 1, ngrid )
13991  WRITE(outnum, 2000) 'VERB :', verb
13992  WRITE(outnum,*) ' '
13993  END IF
13994  IF( verb .GT. 1 ) THEN
13995  WRITE(outnum,4000)
13996  WRITE(outnum,5000)
13997  END IF
13998  END IF
13999  IF (topsrepeat.EQ.0) THEN
14000  itr1 = 0
14001  itr2 = 0
14002  ELSE IF (topsrepeat.EQ.1) THEN
14003  itr1 = 1
14004  itr2 = 1
14005  ELSE
14006  itr1 = 0
14007  itr2 = 1
14008  END IF
14009 *
14010 * Find biggest matrix, so we know where to stick error info
14011 *
14012  i = 0
14013  DO 10 ima = 1, nmat
14014  ipad = 4 * m0(ima)
14015  k = n0(ima) * max0( ldas0(ima), ldad0(ima) ) + ipad
14016  IF( k .GT. i ) i = k
14017  10 CONTINUE
14018  maxerr = ( zsize * (memlen-i) ) / ( zsize*2 + isize*6 )
14019  IF( maxerr .LT. 1 ) THEN
14020  WRITE(outnum,*) 'ERROR: Not enough memory to run SUM tests.'
14021  CALL blacs_abort(-1, 1)
14022  END IF
14023  errdptr = i + 1
14024  erriptr = errdptr + maxerr
14025  nerr = 0
14026  testnum = 0
14027  nfail = 0
14028  nskip = 0
14029 *
14030 * Loop over grids of matrix
14031 *
14032  DO 90 igr = 1, ngrid
14033 *
14034 * allocate process grid for the next batch of tests
14035 *
14036  context = context0(igr)
14037  CALL blacs_gridinfo( context, nprow, npcol, myrow, mycol )
14038  ingrid = ( (myrow.LT.nprow) .AND. (mycol.LT.npcol) )
14039 *
14040  DO 80 isc = 1, nscope
14041  scope = scope0(isc)
14042  DO 70 ito = 1, ntop
14043  top = top0(ito)
14044 *
14045 * If testing multiring ('M') or general tree ('T'), need to
14046 * loop over calls to BLACS_SET to do full test
14047 *
14048  IF( lsame(top, 'M') ) THEN
14049  setwhat = 13
14050  IF( scope .EQ. 'R' ) THEN
14051  istart = -(npcol - 1)
14052  istop = -istart
14053  ELSE IF (scope .EQ. 'C') THEN
14054  istart = -(nprow - 1)
14055  istop = -istart
14056  ELSE
14057  istart = -(nprow*npcol - 1)
14058  istop = -istart
14059  ENDIF
14060  ELSE IF( lsame(top, 'T') ) THEN
14061  setwhat = 14
14062  istart = 1
14063  IF( scope .EQ. 'R' ) THEN
14064  istop = npcol - 1
14065  ELSE IF (scope .EQ. 'C') THEN
14066  istop = nprow - 1
14067  ELSE
14068  istop = nprow*npcol - 1
14069  ENDIF
14070  ELSE
14071  setwhat = 0
14072  istart = 1
14073  istop = 1
14074  ENDIF
14075  DO 60 ima = 1, nmat
14076  m = m0(ima)
14077  n = n0(ima)
14078  ldasrc = ldas0(ima)
14079  ldadst = ldad0(ima)
14080  ipre = 2 * m
14081  ipost = ipre
14082  preaptr = 1
14083  aptr = preaptr + ipre
14084 *
14085  DO 50 ide = 1, ndest
14086  testnum = testnum + 1
14087  rdest2 = rdest0(ide)
14088  cdest2 = cdest0(ide)
14089 *
14090 * If everyone gets the answer, create some bogus rdest/cdest
14091 * so IF's are easier
14092 *
14093  allrcv = ( (rdest2.EQ.-1) .OR. (cdest2.EQ.-1) )
14094  IF( allrcv ) THEN
14095  rdest = nprow - 1
14096  cdest = npcol - 1
14097  IF (topscohrnt.EQ.0) THEN
14098  itr1 = 0
14099  itr2 = 0
14100  ELSE IF (topscohrnt.EQ.1) THEN
14101  itr1 = 1
14102  itr2 = 1
14103  ELSE
14104  itr1 = 0
14105  itr2 = 1
14106  END IF
14107  ELSE
14108  rdest = rdest2
14109  cdest = cdest2
14110  itc1 = 0
14111  itc2 = 0
14112  END IF
14113  IF( rdest.GE.p0(igr) .OR. cdest.GE.q0(igr) ) THEN
14114  nskip = nskip + 1
14115  GOTO 50
14116  END IF
14117 *
14118  IF( myrow.EQ.rdest .AND. mycol.EQ.cdest ) THEN
14119  lda = ldadst
14120  ELSE
14121  lda = ldasrc
14122  END IF
14123  IF( verb .GT. 1 ) THEN
14124  IF( iam .EQ. 0 ) THEN
14125  WRITE(outnum, 6000)
14126  $ testnum, 'RUNNING', scope, top, m, n,
14127  $ ldasrc, ldadst, rdest2, cdest2,
14128  $ nprow, npcol
14129  END IF
14130  END IF
14131 *
14132 * If I am in scope
14133 *
14134  testok = .true.
14135  IF( ingrid ) THEN
14136  IF( (myrow.EQ.rdest .AND. scope.EQ.'R') .OR.
14137  $ (mycol.EQ.cdest .AND. scope.EQ.'C') .OR.
14138  $ (scope .EQ. 'A') ) THEN
14139 *
14140  k = nerr
14141  DO 40 itr = itr1, itr2
14142  CALL blacs_set(context, 15, itr)
14143  DO 35 itc = itc1, itc2
14144  CALL blacs_set(context, 16, itc)
14145  DO 30 j = istart, istop
14146  IF( j.EQ.0) GOTO 30
14147  IF( setwhat.NE.0 )
14148  $ CALL blacs_set(context, setwhat, j)
14149 *
14150 *
14151 * generate and pad matrix A
14152 *
14153  CALL zinitmat('G','-', m, n, mem(preaptr),
14154  $ lda, ipre, ipost,
14155  $ checkval, testnum,
14156  $ myrow, mycol )
14157 *
14158  CALL zgsum2d(context, scope, top, m, n,
14159  $ mem(aptr), lda, rdest2,
14160  $ cdest2)
14161 *
14162 * If I've got the answer, check for errors in
14163 * matrix or padding
14164 *
14165  IF( (myrow.EQ.rdest .AND. mycol.EQ.cdest)
14166  $ .OR. allrcv ) THEN
14167  CALL zchkpad('G','-', m, n,
14168  $ mem(preaptr), lda, rdest,
14169  $ cdest, myrow, mycol,
14170  $ ipre, ipost, checkval,
14171  $ testnum, maxerr, nerr,
14172  $ mem(erriptr),mem(errdptr))
14173  CALL zchksum(scope, context, m, n,
14174  $ mem(aptr), lda,
14175  $ testnum, maxerr, nerr,
14176  $ mem(erriptr),mem(errdptr),
14177  $ iseed)
14178  END IF
14179  30 CONTINUE
14180  CALL blacs_set(context, 16, 0)
14181  35 CONTINUE
14182  CALL blacs_set(context, 15, 0)
14183  40 CONTINUE
14184  testok = ( k .EQ. nerr )
14185  END IF
14186  END IF
14187 *
14188  IF( verb .GT. 1 ) THEN
14189  i = nerr
14190  CALL zbtcheckin(0, outnum, maxerr, nerr,
14191  $ mem(erriptr), mem(errdptr), iseed)
14192  IF( iam .EQ. 0 ) THEN
14193  IF( testok .AND. nerr.EQ.i ) THEN
14194  WRITE(outnum,6000)testnum,'PASSED ',
14195  $ scope, top, m, n, ldasrc,
14196  $ ldadst, rdest2, cdest2,
14197  $ nprow, npcol
14198  ELSE
14199  nfail = nfail + 1
14200  WRITE(outnum,6000)testnum,'FAILED ',
14201  $ scope, top, m, n, ldasrc,
14202  $ ldadst, rdest2, cdest2,
14203  $ nprow, npcol
14204  END IF
14205  END IF
14206 *
14207 * Once we've printed out errors, can re-use buf space
14208 *
14209  nerr = 0
14210  END IF
14211  50 CONTINUE
14212  60 CONTINUE
14213  70 CONTINUE
14214  80 CONTINUE
14215  90 CONTINUE
14216 *
14217  IF( verb .LT. 2 ) THEN
14218  nfail = testnum
14219  CALL zbtcheckin( nfail, outnum, maxerr, nerr, mem(erriptr),
14220  $ mem(errdptr), iseed )
14221  END IF
14222  IF( iam .EQ. 0 ) THEN
14223  IF( verb .GT. 1 ) WRITE(outnum,*) ' '
14224  IF( nfail+nskip .EQ. 0 ) THEN
14225  WRITE(outnum, 7000 ) testnum
14226  ELSE
14227  WRITE(outnum, 8000 ) testnum, testnum-nskip-nfail,
14228  $ nskip, nfail
14229  END IF
14230  END IF
14231 *
14232 * Log whether their were any failures
14233 *
14234  testok = allpass( (nfail.EQ.0) )
14235 *
14236  1000 FORMAT('DOUBLE COMPLEX SUM TESTS: BEGIN.' )
14237  2000 FORMAT(1x,a7,3x,10i6)
14238  3000 FORMAT(1x,a7,3x,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,
14239  $ 5x,a1,5x,a1)
14240  4000 FORMAT(' TEST# STATUS SCOPE TOP M N LDAS LDAD ',
14241  $ 'RDEST CDEST P Q')
14242  5000 FORMAT(' ----- ------- ----- --- ----- ----- ----- ----- ',
14243  $ '----- ----- ---- ----')
14244  6000 FORMAT(i6,1x,a7,5x,a1,3x,a1,6i6,2i5)
14245  7000 FORMAT('DOUBLE COMPLEX SUM TESTS: PASSED ALL',
14246  $ i5, ' TESTS.')
14247  8000 FORMAT('DOUBLE COMPLEX SUM TESTS:',i5,' TESTS;',i5,' PASSED,',
14248  $ i5,' SKIPPED,',i5,' FAILED.')
14249 *
14250  RETURN
14251 *
14252 * End of ZTESTSUM.
14253 *
14254  END
14255 *
14256  DOUBLE PRECISION FUNCTION zbtabs(VAL)
14257  DOUBLE COMPLEX val
14258  zbtabs = abs( dble(val) ) + abs( dimag(val) )
14259  RETURN
14260  END
14261 *
14262  SUBROUTINE zchksum( SCOPE, ICTXT, M, N, A, LDA, TESTNUM, MAXERR,
14263  $ NERR, ERRIBUF, ERRDBUF, ISEED )
14264 *
14265 * .. Scalar Arguments ..
14266  CHARACTER*1 SCOPE
14267  INTEGER ICTXT, M, N, LDA, TESTNUM, MAXERR, NERR
14268 * ..
14269 * .. Array Arguments ..
14270  INTEGER ERRIBUF(6, MAXERR), ISEED(*)
14271  DOUBLE COMPLEX A(LDA,*), ERRDBUF(2, MAXERR)
14272 * ..
14273 * .. External Functions ..
14274  INTEGER IBTMYPROC, IBTNPROCS
14275  DOUBLE PRECISION DBTEPS
14276  DOUBLE COMPLEX ZBTRAN
14277  EXTERNAL IBTMYPROC, IBTNPROCS, DBTEPS, ZBTRAN
14278 * ..
14279 * .. Local Scalars ..
14280  LOGICAL NUMOK
14281  INTEGER NPROCS, NPROW, NPCOL, MYROW, MYCOL, NODE, NNODES, DEST
14282  INTEGER I, J, K
14283  DOUBLE COMPLEX ANS, TMP
14284  DOUBLE PRECISION EPS, ERRBND, RPOSNUM, RNEGNUM, IPOSNUM, INEGNUM
14285 * ..
14286 * .. Executable Statements ..
14287 *
14288  nprocs = ibtnprocs()
14289  eps = dbteps()
14290  CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
14291  dest = myrow*nprocs + mycol
14292 *
14293 * Set up seeds to match those used by each proc's genmat call
14294 *
14295  IF( scope .EQ. 'R' ) THEN
14296  nnodes = npcol
14297  DO 10 i = 0, nnodes-1
14298  node = myrow * nprocs + i
14299  iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
14300  iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
14301  iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
14302  iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
14303  10 CONTINUE
14304  ELSE IF( scope .EQ. 'C' ) THEN
14305  nnodes = nprow
14306  DO 20 i = 0, nnodes-1
14307  node = i * nprocs + mycol
14308  iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
14309  iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
14310  iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
14311  iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
14312  20 CONTINUE
14313  ELSE
14314  nnodes = nprow * npcol
14315  DO 30 i = 0, nnodes-1
14316  node = (i / npcol) * nprocs + mod(i, npcol)
14317  iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
14318  iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
14319  iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
14320  iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
14321  30 CONTINUE
14322  END IF
14323 *
14324  DO 100 j = 1, n
14325  DO 90 i = 1, m
14326  ans = 0
14327  rposnum = 0
14328  rnegnum = 0
14329  iposnum = 0
14330  inegnum = 0
14331  DO 40 k = 0, nnodes-1
14332  tmp = zbtran( iseed(k*4+1) )
14333  IF( dble( tmp ) .LT. 0 ) THEN
14334  rnegnum = rnegnum + dble( tmp )
14335  ELSE
14336  rposnum = rposnum + dble( tmp )
14337  END IF
14338  IF( dimag( tmp ) .LT. 0 ) THEN
14339  inegnum = inegnum + dimag( tmp )
14340  ELSE
14341  iposnum = iposnum + dimag( tmp )
14342  END IF
14343  ans = ans + tmp
14344  40 CONTINUE
14345 *
14346 * The error bound is figured by
14347 * 2 * eps * (nnodes-1) * max(|max element|, |ans|).
14348 * The 2 allows for errors in the distributed _AND_ local result.
14349 * The eps is machine epsilon. The number of floating point adds
14350 * is (nnodes - 1). We use the fact that 0.5 is the maximum element
14351 * in order to save ourselves some computation.
14352 *
14353  tmp = ans - a(i,j)
14354  errbnd = 2 * eps * nnodes * max( rposnum, -rnegnum )
14355  numok = ( dble(tmp) .LE. errbnd )
14356  errbnd = 2 * eps * nnodes * max( iposnum, -inegnum )
14357  numok = numok .AND. ( dimag(tmp) .LE. errbnd )
14358  IF( .NOT.numok ) THEN
14359  nerr = nerr + 1
14360  IF( nerr .LE. maxerr ) THEN
14361  erribuf(1, nerr) = testnum
14362  erribuf(2, nerr) = nnodes
14363  erribuf(3, nerr) = dest
14364  erribuf(4, nerr) = i
14365  erribuf(5, nerr) = j
14366  erribuf(6, nerr) = 5
14367  errdbuf(1, nerr) = a(i,j)
14368  errdbuf(2, nerr) = ans
14369  END IF
14370  END IF
14371  90 CONTINUE
14372  100 CONTINUE
14373 *
14374  RETURN
14375 *
14376 * End of ZCHKSUM
14377 *
14378  END
14379 *
14380 *
14381  SUBROUTINE iamxtest( OUTNUM, VERB, TOPSREPEAT, TOPSCOHRNT, NSCOPE,
14382  $ SCOPE0, NTOP, TOP0, NMAT, M0, N0, LDAS0,
14383  $ LDAD0, LDI0, NDEST, RDEST0, CDEST0, NGRID,
14384  $ CONTEXT0, P0, Q0, ISEED, RMEM, CMEM, RCLEN,
14385  $ MEM, MEMLEN )
14386 *
14387 * -- BLACS tester (version 1.0) --
14388 * University of Tennessee
14389 * December 15, 1994
14390 *
14391 *
14392 * .. Scalar Arguments ..
14393  INTEGER MEMLEN, NDEST, NGRID, NMAT, NSCOPE, NTOP, OUTNUM, RCLEN,
14394  $ topscohrnt, topsrepeat, verb
14395 * ..
14396 * .. Array Arguments ..
14397  CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP)
14398  INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT), LDI0(NMAT)
14399  INTEGER RDEST0(NDEST), CDEST0(NDEST), CONTEXT0(NGRID)
14400  INTEGER P0(NGRID), Q0(NGRID), ISEED(*), RMEM(RCLEN), CMEM(RCLEN)
14401  INTEGER MEM(MEMLEN)
14402 * ..
14403 *
14404 * Purpose
14405 * =======
14406 * ITESTAMX: Test integer AMX COMBINE
14407 *
14408 * Arguments
14409 * =========
14410 * OUTNUM (input) INTEGER
14411 * The device number to write output to.
14412 *
14413 * VERB (input) INTEGER
14414 * The level of verbosity (how much printing to do).
14415 *
14416 * NSCOPE (input) INTEGER
14417 * The number of scopes to be tested.
14418 *
14419 * SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE)
14420 * Values of the scopes to be tested.
14421 *
14422 * NTOP (input) INTEGER
14423 * The number of topologies to be tested.
14424 *
14425 * TOP0 (input) CHARACTER*1 array of dimension (NTOP)
14426 * Values of the topologies to be tested.
14427 *
14428 * NMAT (input) INTEGER
14429 * The number of matrices to be tested.
14430 *
14431 * M0 (input) INTEGER array of dimension (NMAT)
14432 * Values of M to be tested.
14433 *
14434 * M0 (input) INTEGER array of dimension (NMAT)
14435 * Values of M to be tested.
14436 *
14437 * N0 (input) INTEGER array of dimension (NMAT)
14438 * Values of N to be tested.
14439 *
14440 * LDAS0 (input) INTEGER array of dimension (NMAT)
14441 * Values of LDAS (leading dimension of A on source process)
14442 * to be tested.
14443 *
14444 * LDAD0 (input) INTEGER array of dimension (NMAT)
14445 * Values of LDAD (leading dimension of A on destination
14446 * process) to be tested.
14447 * LDI0 (input) INTEGER array of dimension (NMAT)
14448 * Values of LDI (leading dimension of RA/CA) to be tested.
14449 * If LDI == -1, these RA/CA should not be accessed.
14450 *
14451 * NDEST (input) INTEGER
14452 * The number of destinations to be tested.
14453 *
14454 * RDEST0 (input) INTEGER array of dimension (NNDEST)
14455 * Values of RDEST (row coordinate of destination) to be
14456 * tested.
14457 *
14458 * CDEST0 (input) INTEGER array of dimension (NNDEST)
14459 * Values of CDEST (column coordinate of destination) to be
14460 * tested.
14461 *
14462 * NGRID (input) INTEGER
14463 * The number of process grids to be tested.
14464 *
14465 * CONTEXT0 (input) INTEGER array of dimension (NGRID)
14466 * The BLACS context handles corresponding to the grids.
14467 *
14468 * P0 (input) INTEGER array of dimension (NGRID)
14469 * Values of P (number of process rows, NPROW).
14470 *
14471 * Q0 (input) INTEGER array of dimension (NGRID)
14472 * Values of Q (number of process columns, NPCOL).
14473 *
14474 * ISEED (workspace) INTEGER array of dimension ( MAX(NPROCS, NTESTS) )
14475 * Workspace used to hold each process's random number SEED.
14476 * This requires NPROCS (number of processor) elements.
14477 * If VERB < 2, this workspace also serves to indicate which
14478 * tests fail. This requires workspace of NTESTS
14479 * (number of tests performed).
14480 *
14481 * RMEM (workspace) INTEGER array of dimension (RCLEN)
14482 * Used for all RA arrays, and their pre and post padding.
14483 *
14484 * CMEM (workspace) INTEGER array of dimension (RCLEN)
14485 * Used for all CA arrays, and their pre and post padding.
14486 *
14487 * RCLEN (input) INTEGER
14488 * The length, in elements, of RMEM and CMEM.
14489 *
14490 * MEM (workspace) INTEGER array of dimension (MEMLEN)
14491 * Used for all other workspaces, including the matrix A,
14492 * and its pre and post padding.
14493 *
14494 * MEMLEN (input) INTEGER
14495 * The length, in elements, of MEM.
14496 *
14497 * =====================================================================
14498 *
14499 * .. External Functions ..
14500  LOGICAL ALLPASS, LSAME
14501  INTEGER IBTMYPROC, IBTNPROCS, IBTSIZEOF
14502  EXTERNAL ALLPASS, LSAME, IBTMYPROC, IBTNPROCS, IBTSIZEOF
14503 * ..
14504 * .. External Subroutines ..
14505  EXTERNAL blacs_gridinfo, igamx2d
14506  EXTERNAL iinitmat, ichkpad, ibtcheckin
14507 * ..
14508 * .. Local Scalars ..
14509  CHARACTER*1 SCOPE, TOP
14510  LOGICAL INGRID, TESTOK, ALLRCV
14511  INTEGER APTR, CAPTR, CDEST, CDEST2, CONTEXT, ERRDPTR, ERRIPTR, I,
14512  $ IAM, ICHECKVAL, IDE, IGR, IMA, IPAD, IPOST, IPRE, ISC,
14513  $ ISIZE, ISTART, ISTOP, ITC, ITC1, ITC2, ITO, ITR, ITR1,
14514  $ ITR2, J, K, LDA, LDADST, LDASRC, LDI, M, MAXERR, MYCOL,
14515  $ MYROW, N, NERR, NFAIL, NPCOL, NPROW, NSKIP, PREAPTR,
14516  $ RAPTR, RDEST, RDEST2, SETWHAT, TESTNUM, VALPTR
14517  INTEGER CHECKVAL
14518 * ..
14519 * .. Executable Statements ..
14520 *
14521 * Choose padding value, and make it unique
14522 *
14523  CHECKVAL = -911
14524  iam = ibtmyproc()
14525  checkval = iam * checkval
14526  isize = ibtsizeof('I')
14527  icheckval = -iam
14528 *
14529 * Verify file parameters
14530 *
14531  IF( iam .EQ. 0 ) THEN
14532  WRITE(outnum, *) ' '
14533  WRITE(outnum, *) ' '
14534  WRITE(outnum, 1000 )
14535  IF( verb .GT. 0 ) THEN
14536  WRITE(outnum,*) ' '
14537  WRITE(outnum, 2000) 'NSCOPE:', nscope
14538  WRITE(outnum, 3000) ' SCOPE:', ( scope0(i), i = 1, nscope )
14539  WRITE(outnum, 2000) 'TReps :', topsrepeat
14540  WRITE(outnum, 2000) 'TCohr :', topscohrnt
14541  WRITE(outnum, 2000) 'NTOP :', ntop
14542  WRITE(outnum, 3000) ' TOP :', ( top0(i), i = 1, ntop )
14543  WRITE(outnum, 2000) 'NMAT :', nmat
14544  WRITE(outnum, 2000) ' M :', ( m0(i), i = 1, nmat )
14545  WRITE(outnum, 2000) ' N :', ( n0(i), i = 1, nmat )
14546  WRITE(outnum, 2000) ' LDAS :', ( ldas0(i), i = 1, nmat )
14547  WRITE(outnum, 2000) ' LDAD :', ( ldad0(i), i = 1, nmat )
14548  WRITE(outnum, 2000) ' LDI :', ( ldi0(i), i = 1, nmat )
14549  WRITE(outnum, 2000) 'NDEST :', ndest
14550  WRITE(outnum, 2000) ' RDEST:',( rdest0(i), i = 1, ndest )
14551  WRITE(outnum, 2000) ' CDEST:',( cdest0(i), i = 1, ndest )
14552  WRITE(outnum, 2000) 'NGRIDS:', ngrid
14553  WRITE(outnum, 2000) ' P :', ( p0(i), i = 1, ngrid )
14554  WRITE(outnum, 2000) ' Q :', ( q0(i), i = 1, ngrid )
14555  WRITE(outnum, 2000) 'VERB :', verb
14556  WRITE(outnum,*) ' '
14557  END IF
14558  IF( verb .GT. 1 ) THEN
14559  WRITE(outnum,4000)
14560  WRITE(outnum,5000)
14561  END IF
14562  END IF
14563  IF (topsrepeat.EQ.0) THEN
14564  itr1 = 0
14565  itr2 = 0
14566  ELSE IF (topsrepeat.EQ.1) THEN
14567  itr1 = 1
14568  itr2 = 1
14569  ELSE
14570  itr1 = 0
14571  itr2 = 1
14572  END IF
14573 *
14574 * Find biggest matrix, so we know where to stick error info
14575 *
14576  i = 0
14577  DO 10 ima = 1, nmat
14578  ipad = 4 * m0(ima)
14579  k = n0(ima) * max0( ldas0(ima), ldad0(ima) ) + ipad
14580  IF( k .GT. i ) i = k
14581  10 CONTINUE
14582  i = i + ibtnprocs()
14583  maxerr = ( isize * (memlen-i) ) / ( isize*2 + isize*6 )
14584  IF( maxerr .LT. 1 ) THEN
14585  WRITE(outnum,*) 'ERROR: Not enough memory to run MAX tests.'
14586  CALL blacs_abort(-1, 1)
14587  END IF
14588  errdptr = i + 1
14589  erriptr = errdptr + maxerr
14590  nerr = 0
14591  testnum = 0
14592  nfail = 0
14593  nskip = 0
14594 *
14595 * Loop over grids of matrix
14596 *
14597  DO 90 igr = 1, ngrid
14598 *
14599 * allocate process grid for the next batch of tests
14600 *
14601  context = context0(igr)
14602  CALL blacs_gridinfo( context, nprow, npcol, myrow, mycol )
14603  ingrid = ( (myrow.LT.nprow) .AND. (mycol.LT.npcol) )
14604 *
14605  DO 80 isc = 1, nscope
14606  scope = scope0(isc)
14607  DO 70 ito = 1, ntop
14608  top = top0(ito)
14609 *
14610 * If testing multiring ('M') or general tree ('T'), need to
14611 * loop over calls to BLACS_SET to do full test
14612 *
14613  IF( lsame(top, 'M') ) THEN
14614  setwhat = 13
14615  IF( scope .EQ. 'R' ) THEN
14616  istart = -(npcol - 1)
14617  istop = -istart
14618  ELSE IF (scope .EQ. 'C') THEN
14619  istart = -(nprow - 1)
14620  istop = -istart
14621  ELSE
14622  istart = -(nprow*npcol - 1)
14623  istop = -istart
14624  ENDIF
14625  ELSE IF( lsame(top, 'T') ) THEN
14626  setwhat = 14
14627  istart = 1
14628  IF( scope .EQ. 'R' ) THEN
14629  istop = npcol - 1
14630  ELSE IF (scope .EQ. 'C') THEN
14631  istop = nprow - 1
14632  ELSE
14633  istop = nprow*npcol - 1
14634  ENDIF
14635  ELSE
14636  setwhat = 0
14637  istart = 1
14638  istop = 1
14639  ENDIF
14640  DO 60 ima = 1, nmat
14641  m = m0(ima)
14642  n = n0(ima)
14643  ldasrc = ldas0(ima)
14644  ldadst = ldad0(ima)
14645  ldi = ldi0(ima)
14646  ipre = 2 * m
14647  ipost = ipre
14648  preaptr = 1
14649  aptr = preaptr + ipre
14650 *
14651  DO 50 ide = 1, ndest
14652  testnum = testnum + 1
14653  rdest2 = rdest0(ide)
14654  cdest2 = cdest0(ide)
14655 *
14656 * If everyone gets the answer, create some bogus rdest/cdest
14657 * so IF's are easier
14658 *
14659  allrcv = ( (rdest2.EQ.-1) .OR. (cdest2.EQ.-1) )
14660  IF( allrcv ) THEN
14661  rdest = nprow - 1
14662  cdest = npcol - 1
14663  IF (topscohrnt.EQ.0) THEN
14664  itr1 = 0
14665  itr2 = 0
14666  ELSE IF (topscohrnt.EQ.1) THEN
14667  itr1 = 1
14668  itr2 = 1
14669  ELSE
14670  itr1 = 0
14671  itr2 = 1
14672  END IF
14673  ELSE
14674  rdest = rdest2
14675  cdest = cdest2
14676  itc1 = 0
14677  itc2 = 0
14678  END IF
14679  IF( rdest.GE.p0(igr) .OR. cdest.GE.q0(igr) ) THEN
14680  nskip = nskip + 1
14681  GOTO 50
14682  END IF
14683 *
14684  IF( myrow.EQ.rdest .AND. mycol.EQ.cdest ) THEN
14685  lda = ldadst
14686  ELSE
14687  lda = ldasrc
14688  END IF
14689  valptr = aptr + ipost + n * lda
14690  IF( verb .GT. 1 ) THEN
14691  IF( iam .EQ. 0 ) THEN
14692  WRITE(outnum, 6000)
14693  $ testnum, 'RUNNING', scope, top, m, n,
14694  $ ldasrc, ldadst, ldi, rdest2, cdest2,
14695  $ nprow, npcol
14696  END IF
14697  END IF
14698 *
14699 * If I am in scope
14700 *
14701  testok = .true.
14702  IF( ingrid ) THEN
14703  IF( (myrow.EQ.rdest .AND. scope.EQ.'R') .OR.
14704  $ (mycol.EQ.cdest .AND. scope.EQ.'C') .OR.
14705  $ (scope .EQ. 'A') ) THEN
14706 *
14707  k = nerr
14708  DO 40 itr = itr1, itr2
14709  CALL blacs_set(context, 15, itr)
14710  DO 35 itc = itc1, itc2
14711  CALL blacs_set(context, 16, itc)
14712  DO 30 j = istart, istop
14713  IF( j.EQ.0) GOTO 30
14714  IF( setwhat.NE.0 )
14715  $ CALL blacs_set(context, setwhat, j)
14716 *
14717 *
14718 * generate and pad matrix A
14719 *
14720  CALL iinitmat('G','-', m, n, mem(preaptr),
14721  $ lda, ipre, ipost,
14722  $ checkval, testnum,
14723  $ myrow, mycol )
14724 *
14725 * If they exist, pad RA and CA arrays
14726 *
14727  IF( ldi .NE. -1 ) THEN
14728  DO 15 i = 1, n*ldi + ipre + ipost
14729  rmem(i) = icheckval
14730  cmem(i) = icheckval
14731  15 CONTINUE
14732  raptr = 1 + ipre
14733  captr = 1 + ipre
14734  ELSE
14735  DO 20 i = 1, ipre+ipost
14736  rmem(i) = icheckval
14737  cmem(i) = icheckval
14738  20 CONTINUE
14739  raptr = 1
14740  captr = 1
14741  END IF
14742 *
14743  CALL igamx2d(context, scope, top, m, n,
14744  $ mem(aptr), lda, rmem(raptr),
14745  $ cmem(captr), ldi,
14746  $ rdest2, cdest2)
14747 *
14748 * If I've got the answer, check for errors in
14749 * matrix or padding
14750 *
14751  IF( (myrow.EQ.rdest .AND. mycol.EQ.cdest)
14752  $ .OR. allrcv ) THEN
14753  CALL ichkpad('G','-', m, n,
14754  $ mem(preaptr), lda, rdest,
14755  $ cdest, myrow, mycol,
14756  $ ipre, ipost, checkval,
14757  $ testnum, maxerr, nerr,
14758  $ mem(erriptr),mem(errdptr))
14759  CALL ichkamx(scope, context, m, n,
14760  $ mem(aptr), lda,
14761  $ rmem(raptr), cmem(captr),
14762  $ ldi, testnum, maxerr,nerr,
14763  $ mem(erriptr),mem(errdptr),
14764  $ iseed, mem(valptr))
14765  CALL ircchk(ipre, ipost, icheckval,
14766  $ m, n, rmem, cmem, ldi,
14767  $ myrow, mycol, testnum,
14768  $ maxerr, nerr,
14769  $ mem(erriptr), mem(errdptr))
14770  END IF
14771  30 CONTINUE
14772  CALL blacs_set(context, 16, 0)
14773  35 CONTINUE
14774  CALL blacs_set(context, 15, 0)
14775  40 CONTINUE
14776  testok = ( k .EQ. nerr )
14777  END IF
14778  END IF
14779 *
14780  IF( verb .GT. 1 ) THEN
14781  i = nerr
14782  CALL ibtcheckin(0, outnum, maxerr, nerr,
14783  $ mem(erriptr), mem(errdptr), iseed)
14784  IF( iam .EQ. 0 ) THEN
14785  IF( testok .AND. nerr.EQ.i ) THEN
14786  WRITE(outnum,6000)testnum,'PASSED ',
14787  $ scope, top, m, n, ldasrc,
14788  $ ldadst, ldi, rdest2, cdest2,
14789  $ nprow, npcol
14790  ELSE
14791  nfail = nfail + 1
14792  WRITE(outnum,6000)testnum,'FAILED ',
14793  $ scope, top, m, n, ldasrc,
14794  $ ldadst, ldi, rdest2, cdest2,
14795  $ nprow, npcol
14796  END IF
14797  END IF
14798 *
14799 * Once we've printed out errors, can re-use buf space
14800 *
14801  nerr = 0
14802  END IF
14803  50 CONTINUE
14804  60 CONTINUE
14805  70 CONTINUE
14806  80 CONTINUE
14807  90 CONTINUE
14808 *
14809  IF( verb .LT. 2 ) THEN
14810  nfail = testnum
14811  CALL ibtcheckin( nfail, outnum, maxerr, nerr, mem(erriptr),
14812  $ mem(errdptr), iseed )
14813  END IF
14814  IF( iam .EQ. 0 ) THEN
14815  IF( verb .GT. 1 ) WRITE(outnum,*) ' '
14816  IF( nfail+nskip .EQ. 0 ) THEN
14817  WRITE(outnum, 7000 ) testnum
14818  ELSE
14819  WRITE(outnum, 8000 ) testnum, testnum-nskip-nfail,
14820  $ nskip, nfail
14821  END IF
14822  END IF
14823 *
14824 * Log whether their were any failures
14825 *
14826  testok = allpass( (nfail.EQ.0) )
14827 *
14828  1000 FORMAT('INTEGER AMX TESTS: BEGIN.' )
14829  2000 FORMAT(1x,a7,3x,10i6)
14830  3000 FORMAT(1x,a7,3x,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,
14831  $ 5x,a1,5x,a1)
14832  4000 FORMAT(' TEST# STATUS SCOPE TOP M N LDAS LDAD LDI ',
14833  $ 'RDEST CDEST P Q')
14834  5000 FORMAT(' ----- ------- ----- --- ----- ----- ----- ----- ----- ',
14835  $ '----- ----- ---- ----')
14836  6000 FORMAT(i6,1x,a7,5x,a1,3x,a1,7i6,2i5)
14837  7000 FORMAT('INTEGER AMX TESTS: PASSED ALL',
14838  $ i5, ' TESTS.')
14839  8000 FORMAT('INTEGER AMX TESTS:',i5,' TESTS;',i5,' PASSED,',
14840  $ i5,' SKIPPED,',i5,' FAILED.')
14841 *
14842  RETURN
14843 *
14844 * End of ITESTAMX.
14845 *
14846  END
14847 *
14848  SUBROUTINE ibtspcoord( SCOPE, PNUM, MYROW, MYCOL, NPCOL,
14849  $ PROW, PCOL )
14850  CHARACTER*1 SCOPE
14851  INTEGER PNUM, MYROW, MYCOL, NPCOL, PROW, PCOL
14852 *
14853  IF( scope .EQ. 'R' ) THEN
14854  prow = myrow
14855  pcol = pnum
14856  ELSE IF( scope .EQ. 'C' ) THEN
14857  prow = pnum
14858  pcol = mycol
14859  ELSE
14860  prow = pnum / npcol
14861  pcol = mod( pnum, npcol )
14862  END IF
14863  RETURN
14864 *
14865 * End of ibtspcoord
14866 *
14867  END
14868 *
14869  INTEGER FUNCTION ibtspnum( SCOPE, PROW, PCOL, NPCOL )
14870  CHARACTER*1 scope
14871  INTEGER prow, pcol, npcol
14872  if( scope .EQ. 'R' ) then
14873  ibtspnum = pcol
14874  ELSE IF( scope .EQ. 'C' ) THEN
14875  ibtspnum = prow
14876  ELSE
14877  ibtspnum = prow*npcol + pcol
14878  END IF
14879 *
14880  RETURN
14881 *
14882 * End of ibtscpnum
14883 *
14884  END
14885 *
14886  SUBROUTINE ircchk( IPRE, IPOST, PADVAL, M, N, RA, CA, LDI, MYROW,
14887  $ MYCOL, TESTNUM, MAXERR, NERR,
14888  $ ERRIBUF, ERRDBUF )
14889 *
14890 * .. Scalar Arguments ..
14891  INTEGER IPRE, IPOST, PADVAL, M, N, LDI, MYROW, MYCOL, TESTNUM
14892  INTEGER MAXERR, NERR
14893 * ..
14894 * .. Array Arguments ..
14895  INTEGER RA(*), CA(*), ERRIBUF(6, MAXERR)
14896  INTEGER ERRDBUF(2, MAXERR)
14897 * ..
14898 * .. Parameters ..
14899  INTEGER ERR_PRE, ERR_POST, ERR_GAP, ERR_TRI, ERR_MAT
14900  PARAMETER( ERR_PRE = 1, err_post = 2, err_gap = 3, err_tri = 4 )
14901  parameter( err_mat = 5 )
14902 * ..
14903 * .. External Functions ..
14904  INTEGER IBTNPROCS
14905  EXTERNAL ibtnprocs
14906 * ..
14907 * .. Local Scalars ..
14908  INTEGER I, J, K, IAM
14909 * ..
14910 * .. Executable Statements ..
14911 *
14912  iam = myrow * ibtnprocs() + mycol
14913 *
14914 * Check pre padding
14915 *
14916  IF( ldi .NE. -1 ) THEN
14917  IF( ipre .GT. 0 ) THEN
14918  DO 10 i = 1, ipre
14919  IF( ra(i) .NE. padval ) THEN
14920  nerr = nerr + 1
14921  IF( nerr .LE. maxerr ) THEN
14922  erribuf(1, nerr) = testnum
14923  erribuf(2, nerr) = ldi
14924  erribuf(3, nerr) = iam
14925  erribuf(4, nerr) = i
14926  erribuf(5, nerr) = ipre - i + 1
14927  erribuf(6, nerr) = -err_pre
14928  errdbuf(1, nerr) = int( ra(i) )
14929  errdbuf(2, nerr) = int( padval )
14930  END IF
14931  ENDIF
14932  IF( ca(i) .NE. padval ) THEN
14933  nerr = nerr + 1
14934  IF( nerr .LE. maxerr ) THEN
14935  erribuf(1, nerr) = testnum
14936  erribuf(2, nerr) = ldi
14937  erribuf(3, nerr) = iam
14938  erribuf(4, nerr) = i
14939  erribuf(5, nerr) = ipre - i + 1
14940  erribuf(6, nerr) = -10 - err_pre
14941  errdbuf(1, nerr) = int( ca(i) )
14942  errdbuf(2, nerr) = int( padval )
14943  END IF
14944  ENDIF
14945  10 CONTINUE
14946  END IF
14947 *
14948 * Check post padding
14949 *
14950  IF( ipost .GT. 0 ) THEN
14951  k = ipre + ldi*n
14952  DO 20 i = k+1, k+ipost
14953  IF( ra(i) .NE. padval ) THEN
14954  nerr = nerr + 1
14955  IF( nerr .LE. maxerr ) THEN
14956  erribuf(1, nerr) = testnum
14957  erribuf(2, nerr) = ldi
14958  erribuf(3, nerr) = iam
14959  erribuf(4, nerr) = i - k
14960  erribuf(5, nerr) = i
14961  erribuf(6, nerr) = -err_post
14962  errdbuf(1, nerr) = int( ra(i) )
14963  errdbuf(2, nerr) = int( padval )
14964  END IF
14965  ENDIF
14966  IF( ca(i) .NE. padval ) THEN
14967  nerr = nerr + 1
14968  IF( nerr .LE. maxerr ) THEN
14969  erribuf(1, nerr) = testnum
14970  erribuf(2, nerr) = ldi
14971  erribuf(3, nerr) = iam
14972  erribuf(4, nerr) = i - k
14973  erribuf(5, nerr) = i
14974  erribuf(6, nerr) = -10 - err_post
14975  errdbuf(1, nerr) = int( ca(i) )
14976  errdbuf(2, nerr) = int( padval )
14977  END IF
14978  ENDIF
14979  20 CONTINUE
14980  END IF
14981 *
14982 * Check all (LDI-M) gaps
14983 *
14984  IF( ldi .GT. m ) THEN
14985  k = ipre + m + 1
14986  DO 40 j = 1, n
14987  DO 30 i = m+1, ldi
14988  k = ipre + (j-1)*ldi + i
14989  IF( ra(k) .NE. padval) THEN
14990  nerr = nerr + 1
14991  IF( nerr .LE. maxerr ) THEN
14992  erribuf(1, nerr) = testnum
14993  erribuf(2, nerr) = ldi
14994  erribuf(3, nerr) = iam
14995  erribuf(4, nerr) = i
14996  erribuf(5, nerr) = j
14997  erribuf(6, nerr) = -err_gap
14998  errdbuf(1, nerr) = int( ra(k) )
14999  errdbuf(2, nerr) = int( padval )
15000  END IF
15001  END IF
15002  IF( ca(k) .NE. padval) THEN
15003  nerr = nerr + 1
15004  IF( nerr .LE. maxerr ) THEN
15005  erribuf(1, nerr) = testnum
15006  erribuf(2, nerr) = ldi
15007  erribuf(3, nerr) = iam
15008  erribuf(4, nerr) = i
15009  erribuf(5, nerr) = j
15010  erribuf(6, nerr) = -10 - err_gap
15011  errdbuf(1, nerr) = int( ca(k) )
15012  errdbuf(2, nerr) = int( padval )
15013  END IF
15014  END IF
15015  30 CONTINUE
15016  40 CONTINUE
15017  END IF
15018 *
15019 * if RA and CA don't exist, buffs better be untouched
15020 *
15021  ELSE
15022  DO 50 i = 1, ipre+ipost
15023  IF( ra(i) .NE. padval) THEN
15024  nerr = nerr + 1
15025  IF( nerr .LE. maxerr ) THEN
15026  erribuf(1, nerr) = testnum
15027  erribuf(2, nerr) = ldi
15028  erribuf(3, nerr) = iam
15029  erribuf(4, nerr) = i
15030  erribuf(5, nerr) = ipre+ipost
15031  erribuf(6, nerr) = -err_pre
15032  errdbuf(1, nerr) = int( ra(i) )
15033  errdbuf(2, nerr) = int( padval )
15034  END IF
15035  END IF
15036  IF( ca(i) .NE. padval) THEN
15037  nerr = nerr + 1
15038  IF( nerr .LE. maxerr ) THEN
15039  erribuf(1, nerr) = testnum
15040  erribuf(2, nerr) = ldi
15041  erribuf(3, nerr) = iam
15042  erribuf(4, nerr) = i
15043  erribuf(5, nerr) = ipre+ipost
15044  erribuf(6, nerr) = -10 - err_pre
15045  errdbuf(1, nerr) = int( ca(i) )
15046  errdbuf(2, nerr) = int( padval )
15047  END IF
15048  END IF
15049  50 CONTINUE
15050  ENDIF
15051 *
15052  RETURN
15053  END
15054 *
15055  SUBROUTINE ichkamx( SCOPE, ICTXT, M, N, A, LDA, RA, CA, LDI,
15056  $ TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF,
15057  $ ISEED, VALS )
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 *
15227  END
15228 *
15229 *
15230  SUBROUTINE samxtest( OUTNUM, VERB, TOPSREPEAT, TOPSCOHRNT, NSCOPE,
15231  $ SCOPE0, NTOP, TOP0, NMAT, M0, N0, LDAS0,
15232  $ LDAD0, LDI0, NDEST, RDEST0, CDEST0, NGRID,
15233  $ CONTEXT0, P0, Q0, ISEED, RMEM, CMEM, RCLEN,
15234  $ MEM, MEMLEN )
15235 *
15236 * -- BLACS tester (version 1.0) --
15237 * University of Tennessee
15238 * December 15, 1994
15239 *
15240 *
15241 * .. Scalar Arguments ..
15242  INTEGER MEMLEN, NDEST, NGRID, NMAT, NSCOPE, NTOP, OUTNUM, RCLEN,
15243  $ topscohrnt, topsrepeat, verb
15244 * ..
15245 * .. Array Arguments ..
15246  CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP)
15247  INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT), LDI0(NMAT)
15248  INTEGER RDEST0(NDEST), CDEST0(NDEST), CONTEXT0(NGRID)
15249  INTEGER P0(NGRID), Q0(NGRID), ISEED(*), RMEM(RCLEN), CMEM(RCLEN)
15250  REAL MEM(MEMLEN)
15251 * ..
15252 *
15253 * Purpose
15254 * =======
15255 * STESTAMX: Test real AMX COMBINE
15256 *
15257 * Arguments
15258 * =========
15259 * OUTNUM (input) INTEGER
15260 * The device number to write output to.
15261 *
15262 * VERB (input) INTEGER
15263 * The level of verbosity (how much printing to do).
15264 *
15265 * NSCOPE (input) INTEGER
15266 * The number of scopes to be tested.
15267 *
15268 * SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE)
15269 * Values of the scopes to be tested.
15270 *
15271 * NTOP (input) INTEGER
15272 * The number of topologies to be tested.
15273 *
15274 * TOP0 (input) CHARACTER*1 array of dimension (NTOP)
15275 * Values of the topologies to be tested.
15276 *
15277 * NMAT (input) INTEGER
15278 * The number of matrices to be tested.
15279 *
15280 * M0 (input) INTEGER array of dimension (NMAT)
15281 * Values of M to be tested.
15282 *
15283 * M0 (input) INTEGER array of dimension (NMAT)
15284 * Values of M to be tested.
15285 *
15286 * N0 (input) INTEGER array of dimension (NMAT)
15287 * Values of N to be tested.
15288 *
15289 * LDAS0 (input) INTEGER array of dimension (NMAT)
15290 * Values of LDAS (leading dimension of A on source process)
15291 * to be tested.
15292 *
15293 * LDAD0 (input) INTEGER array of dimension (NMAT)
15294 * Values of LDAD (leading dimension of A on destination
15295 * process) to be tested.
15296 * LDI0 (input) INTEGER array of dimension (NMAT)
15297 * Values of LDI (leading dimension of RA/CA) to be tested.
15298 * If LDI == -1, these RA/CA should not be accessed.
15299 *
15300 * NDEST (input) INTEGER
15301 * The number of destinations to be tested.
15302 *
15303 * RDEST0 (input) INTEGER array of dimension (NNDEST)
15304 * Values of RDEST (row coordinate of destination) to be
15305 * tested.
15306 *
15307 * CDEST0 (input) INTEGER array of dimension (NNDEST)
15308 * Values of CDEST (column coordinate of destination) to be
15309 * tested.
15310 *
15311 * NGRID (input) INTEGER
15312 * The number of process grids to be tested.
15313 *
15314 * CONTEXT0 (input) INTEGER array of dimension (NGRID)
15315 * The BLACS context handles corresponding to the grids.
15316 *
15317 * P0 (input) INTEGER array of dimension (NGRID)
15318 * Values of P (number of process rows, NPROW).
15319 *
15320 * Q0 (input) INTEGER array of dimension (NGRID)
15321 * Values of Q (number of process columns, NPCOL).
15322 *
15323 * ISEED (workspace) INTEGER array of dimension ( MAX(NPROCS, NTESTS) )
15324 * Workspace used to hold each process's random number SEED.
15325 * This requires NPROCS (number of processor) elements.
15326 * If VERB < 2, this workspace also serves to indicate which
15327 * tests fail. This requires workspace of NTESTS
15328 * (number of tests performed).
15329 *
15330 * RMEM (workspace) INTEGER array of dimension (RCLEN)
15331 * Used for all RA arrays, and their pre and post padding.
15332 *
15333 * CMEM (workspace) INTEGER array of dimension (RCLEN)
15334 * Used for all CA arrays, and their pre and post padding.
15335 *
15336 * RCLEN (input) INTEGER
15337 * The length, in elements, of RMEM and CMEM.
15338 *
15339 * MEM (workspace) REAL array of dimension (MEMLEN)
15340 * Used for all other workspaces, including the matrix A,
15341 * and its pre and post padding.
15342 *
15343 * MEMLEN (input) INTEGER
15344 * The length, in elements, of MEM.
15345 *
15346 * =====================================================================
15347 *
15348 * .. External Functions ..
15349  LOGICAL ALLPASS, LSAME
15350  INTEGER IBTMYPROC, IBTNPROCS, IBTSIZEOF
15351  EXTERNAL ALLPASS, LSAME, IBTMYPROC, IBTNPROCS, IBTSIZEOF
15352 * ..
15353 * .. External Subroutines ..
15354  EXTERNAL BLACS_GRIDINFO, SGAMX2D
15355  EXTERNAL SINITMAT, SCHKPAD, SBTCHECKIN
15356 * ..
15357 * .. Local Scalars ..
15358  CHARACTER*1 SCOPE, TOP
15359  LOGICAL INGRID, TESTOK, ALLRCV
15360  INTEGER APTR, CAPTR, CDEST, CDEST2, CONTEXT, ERRDPTR, ERRIPTR, I,
15361  $ iam, icheckval, ide, igr, ima, ipad, ipost, ipre, isc,
15362  $ isize, istart, istop, itc, itc1, itc2, ito, itr, itr1,
15363  $ itr2, j, k, lda, ldadst, ldasrc, ldi, m, maxerr, mycol,
15364  $ myrow, n, nerr, nfail, npcol, nprow, nskip, preaptr,
15365  $ raptr, rdest, rdest2, setwhat, ssize, testnum, valptr
15366  REAL CHECKVAL
15367 * ..
15368 * .. Executable Statements ..
15369 *
15370 * Choose padding value, and make it unique
15371 *
15372  checkval = -0.61e0
15373  iam = ibtmyproc()
15374  checkval = iam * checkval
15375  isize = ibtsizeof('I')
15376  ssize = ibtsizeof('S')
15377  icheckval = -iam
15378 *
15379 * Verify file parameters
15380 *
15381  IF( iam .EQ. 0 ) THEN
15382  WRITE(outnum, *) ' '
15383  WRITE(outnum, *) ' '
15384  WRITE(outnum, 1000 )
15385  IF( verb .GT. 0 ) THEN
15386  WRITE(outnum,*) ' '
15387  WRITE(outnum, 2000) 'NSCOPE:', nscope
15388  WRITE(outnum, 3000) ' SCOPE:', ( scope0(i), i = 1, nscope )
15389  WRITE(outnum, 2000) 'TReps :', topsrepeat
15390  WRITE(outnum, 2000) 'TCohr :', topscohrnt
15391  WRITE(outnum, 2000) 'NTOP :', ntop
15392  WRITE(outnum, 3000) ' TOP :', ( top0(i), i = 1, ntop )
15393  WRITE(outnum, 2000) 'NMAT :', nmat
15394  WRITE(outnum, 2000) ' M :', ( m0(i), i = 1, nmat )
15395  WRITE(outnum, 2000) ' N :', ( n0(i), i = 1, nmat )
15396  WRITE(outnum, 2000) ' LDAS :', ( ldas0(i), i = 1, nmat )
15397  WRITE(outnum, 2000) ' LDAD :', ( ldad0(i), i = 1, nmat )
15398  WRITE(outnum, 2000) ' LDI :', ( ldi0(i), i = 1, nmat )
15399  WRITE(outnum, 2000) 'NDEST :', ndest
15400  WRITE(outnum, 2000) ' RDEST:',( rdest0(i), i = 1, ndest )
15401  WRITE(outnum, 2000) ' CDEST:',( cdest0(i), i = 1, ndest )
15402  WRITE(outnum, 2000) 'NGRIDS:', ngrid
15403  WRITE(outnum, 2000) ' P :', ( p0(i), i = 1, ngrid )
15404  WRITE(outnum, 2000) ' Q :', ( q0(i), i = 1, ngrid )
15405  WRITE(outnum, 2000) 'VERB :', verb
15406  WRITE(outnum,*) ' '
15407  END IF
15408  IF( verb .GT. 1 ) THEN
15409  WRITE(outnum,4000)
15410  WRITE(outnum,5000)
15411  END IF
15412  END IF
15413  IF (topsrepeat.EQ.0) THEN
15414  itr1 = 0
15415  itr2 = 0
15416  ELSE IF (topsrepeat.EQ.1) THEN
15417  itr1 = 1
15418  itr2 = 1
15419  ELSE
15420  itr1 = 0
15421  itr2 = 1
15422  END IF
15423 *
15424 * Find biggest matrix, so we know where to stick error info
15425 *
15426  i = 0
15427  DO 10 ima = 1, nmat
15428  ipad = 4 * m0(ima)
15429  k = n0(ima) * max0( ldas0(ima), ldad0(ima) ) + ipad
15430  IF( k .GT. i ) i = k
15431  10 CONTINUE
15432  i = i + ibtnprocs()
15433  maxerr = ( ssize * (memlen-i) ) / ( ssize*2 + isize*6 )
15434  IF( maxerr .LT. 1 ) THEN
15435  WRITE(outnum,*) 'ERROR: Not enough memory to run MAX tests.'
15436  CALL blacs_abort(-1, 1)
15437  END IF
15438  errdptr = i + 1
15439  erriptr = errdptr + maxerr
15440  nerr = 0
15441  testnum = 0
15442  nfail = 0
15443  nskip = 0
15444 *
15445 * Loop over grids of matrix
15446 *
15447  DO 90 igr = 1, ngrid
15448 *
15449 * allocate process grid for the next batch of tests
15450 *
15451  context = context0(igr)
15452  CALL blacs_gridinfo( context, nprow, npcol, myrow, mycol )
15453  ingrid = ( (myrow.LT.nprow) .AND. (mycol.LT.npcol) )
15454 *
15455  DO 80 isc = 1, nscope
15456  scope = scope0(isc)
15457  DO 70 ito = 1, ntop
15458  top = top0(ito)
15459 *
15460 * If testing multiring ('M') or general tree ('T'), need to
15461 * loop over calls to BLACS_SET to do full test
15462 *
15463  IF( lsame(top, 'M') ) THEN
15464  setwhat = 13
15465  IF( scope .EQ. 'R' ) THEN
15466  istart = -(npcol - 1)
15467  istop = -istart
15468  ELSE IF (scope .EQ. 'C') THEN
15469  istart = -(nprow - 1)
15470  istop = -istart
15471  ELSE
15472  istart = -(nprow*npcol - 1)
15473  istop = -istart
15474  ENDIF
15475  ELSE IF( lsame(top, 'T') ) THEN
15476  setwhat = 14
15477  istart = 1
15478  IF( scope .EQ. 'R' ) THEN
15479  istop = npcol - 1
15480  ELSE IF (scope .EQ. 'C') THEN
15481  istop = nprow - 1
15482  ELSE
15483  istop = nprow*npcol - 1
15484  ENDIF
15485  ELSE
15486  setwhat = 0
15487  istart = 1
15488  istop = 1
15489  ENDIF
15490  DO 60 ima = 1, nmat
15491  m = m0(ima)
15492  n = n0(ima)
15493  ldasrc = ldas0(ima)
15494  ldadst = ldad0(ima)
15495  ldi = ldi0(ima)
15496  ipre = 2 * m
15497  ipost = ipre
15498  preaptr = 1
15499  aptr = preaptr + ipre
15500 *
15501  DO 50 ide = 1, ndest
15502  testnum = testnum + 1
15503  rdest2 = rdest0(ide)
15504  cdest2 = cdest0(ide)
15505 *
15506 * If everyone gets the answer, create some bogus rdest/cdest
15507 * so IF's are easier
15508 *
15509  allrcv = ( (rdest2.EQ.-1) .OR. (cdest2.EQ.-1) )
15510  IF( allrcv ) THEN
15511  rdest = nprow - 1
15512  cdest = npcol - 1
15513  IF (topscohrnt.EQ.0) THEN
15514  itr1 = 0
15515  itr2 = 0
15516  ELSE IF (topscohrnt.EQ.1) THEN
15517  itr1 = 1
15518  itr2 = 1
15519  ELSE
15520  itr1 = 0
15521  itr2 = 1
15522  END IF
15523  ELSE
15524  rdest = rdest2
15525  cdest = cdest2
15526  itc1 = 0
15527  itc2 = 0
15528  END IF
15529  IF( rdest.GE.p0(igr) .OR. cdest.GE.q0(igr) ) THEN
15530  nskip = nskip + 1
15531  GOTO 50
15532  END IF
15533 *
15534  IF( myrow.EQ.rdest .AND. mycol.EQ.cdest ) THEN
15535  lda = ldadst
15536  ELSE
15537  lda = ldasrc
15538  END IF
15539  valptr = aptr + ipost + n * lda
15540  IF( verb .GT. 1 ) THEN
15541  IF( iam .EQ. 0 ) THEN
15542  WRITE(outnum, 6000)
15543  $ testnum, 'RUNNING', scope, top, m, n,
15544  $ ldasrc, ldadst, ldi, rdest2, cdest2,
15545  $ nprow, npcol
15546  END IF
15547  END IF
15548 *
15549 * If I am in scope
15550 *
15551  testok = .true.
15552  IF( ingrid ) THEN
15553  IF( (myrow.EQ.rdest .AND. scope.EQ.'R') .OR.
15554  $ (mycol.EQ.cdest .AND. scope.EQ.'C') .OR.
15555  $ (scope .EQ. 'A') ) THEN
15556 *
15557  k = nerr
15558  DO 40 itr = itr1, itr2
15559  CALL blacs_set(context, 15, itr)
15560  DO 35 itc = itc1, itc2
15561  CALL blacs_set(context, 16, itc)
15562  DO 30 j = istart, istop
15563  IF( j.EQ.0) GOTO 30
15564  IF( setwhat.NE.0 )
15565  $ CALL blacs_set(context, setwhat, j)
15566 *
15567 *
15568 * generate and pad matrix A
15569 *
15570  CALL sinitmat('G','-', m, n, mem(preaptr),
15571  $ lda, ipre, ipost,
15572  $ checkval, testnum,
15573  $ myrow, mycol )
15574 *
15575 * If they exist, pad RA and CA arrays
15576 *
15577  IF( ldi .NE. -1 ) THEN
15578  DO 15 i = 1, n*ldi + ipre + ipost
15579  rmem(i) = icheckval
15580  cmem(i) = icheckval
15581  15 CONTINUE
15582  raptr = 1 + ipre
15583  captr = 1 + ipre
15584  ELSE
15585  DO 20 i = 1, ipre+ipost
15586  rmem(i) = icheckval
15587  cmem(i) = icheckval
15588  20 CONTINUE
15589  raptr = 1
15590  captr = 1
15591  END IF
15592 *
15593  CALL sgamx2d(context, scope, top, m, n,
15594  $ mem(aptr), lda, rmem(raptr),
15595  $ cmem(captr), ldi,
15596  $ rdest2, cdest2)
15597 *
15598 * If I've got the answer, check for errors in
15599 * matrix or padding
15600 *
15601  IF( (myrow.EQ.rdest .AND. mycol.EQ.cdest)
15602  $ .OR. allrcv ) THEN
15603  CALL schkpad('G','-', m, n,
15604  $ mem(preaptr), lda, rdest,
15605  $ cdest, myrow, mycol,
15606  $ ipre, ipost, checkval,
15607  $ testnum, maxerr, nerr,
15608  $ mem(erriptr),mem(errdptr))
15609  CALL schkamx(scope, context, m, n,
15610  $ mem(aptr), lda,
15611  $ rmem(raptr), cmem(captr),
15612  $ ldi, testnum, maxerr,nerr,
15613  $ mem(erriptr),mem(errdptr),
15614  $ iseed, mem(valptr))
15615  CALL srcchk(ipre, ipost, icheckval,
15616  $ m, n, rmem, cmem, ldi,
15617  $ myrow, mycol, testnum,
15618  $ maxerr, nerr,
15619  $ mem(erriptr), mem(errdptr))
15620  END IF
15621  30 CONTINUE
15622  CALL blacs_set(context, 16, 0)
15623  35 CONTINUE
15624  CALL blacs_set(context, 15, 0)
15625  40 CONTINUE
15626  testok = ( k .EQ. nerr )
15627  END IF
15628  END IF
15629 *
15630  IF( verb .GT. 1 ) THEN
15631  i = nerr
15632  CALL sbtcheckin(0, outnum, maxerr, nerr,
15633  $ mem(erriptr), mem(errdptr), iseed)
15634  IF( iam .EQ. 0 ) THEN
15635  IF( testok .AND. nerr.EQ.i ) THEN
15636  WRITE(outnum,6000)testnum,'PASSED ',
15637  $ scope, top, m, n, ldasrc,
15638  $ ldadst, ldi, rdest2, cdest2,
15639  $ nprow, npcol
15640  ELSE
15641  nfail = nfail + 1
15642  WRITE(outnum,6000)testnum,'FAILED ',
15643  $ scope, top, m, n, ldasrc,
15644  $ ldadst, ldi, rdest2, cdest2,
15645  $ nprow, npcol
15646  END IF
15647  END IF
15648 *
15649 * Once we've printed out errors, can re-use buf space
15650 *
15651  nerr = 0
15652  END IF
15653  50 CONTINUE
15654  60 CONTINUE
15655  70 CONTINUE
15656  80 CONTINUE
15657  90 CONTINUE
15658 *
15659  IF( verb .LT. 2 ) THEN
15660  nfail = testnum
15661  CALL sbtcheckin( nfail, outnum, maxerr, nerr, mem(erriptr),
15662  $ mem(errdptr), iseed )
15663  END IF
15664  IF( iam .EQ. 0 ) THEN
15665  IF( verb .GT. 1 ) WRITE(outnum,*) ' '
15666  IF( nfail+nskip .EQ. 0 ) THEN
15667  WRITE(outnum, 7000 ) testnum
15668  ELSE
15669  WRITE(outnum, 8000 ) testnum, testnum-nskip-nfail,
15670  $ nskip, nfail
15671  END IF
15672  END IF
15673 *
15674 * Log whether their were any failures
15675 *
15676  testok = allpass( (nfail.EQ.0) )
15677 *
15678  1000 FORMAT('REAL AMX TESTS: BEGIN.' )
15679  2000 FORMAT(1x,a7,3x,10i6)
15680  3000 FORMAT(1x,a7,3x,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,
15681  $ 5x,a1,5x,a1)
15682  4000 FORMAT(' TEST# STATUS SCOPE TOP M N LDAS LDAD LDI ',
15683  $ 'RDEST CDEST P Q')
15684  5000 FORMAT(' ----- ------- ----- --- ----- ----- ----- ----- ----- ',
15685  $ '----- ----- ---- ----')
15686  6000 FORMAT(i6,1x,a7,5x,a1,3x,a1,7i6,2i5)
15687  7000 FORMAT('REAL AMX TESTS: PASSED ALL',
15688  $ i5, ' TESTS.')
15689  8000 FORMAT('REAL AMX TESTS:',i5,' TESTS;',i5,' PASSED,',
15690  $ i5,' SKIPPED,',i5,' FAILED.')
15691 *
15692  RETURN
15693 *
15694 * End of STESTAMX.
15695 *
15696  END
15697 *
15698  SUBROUTINE srcchk( IPRE, IPOST, PADVAL, M, N, RA, CA, LDI, MYROW,
15699  $ MYCOL, TESTNUM, MAXERR, NERR,
15700  $ ERRIBUF, ERRDBUF )
15701 *
15702 * .. Scalar Arguments ..
15703  INTEGER IPRE, IPOST, PADVAL, M, N, LDI, MYROW, MYCOL, TESTNUM
15704  INTEGER MAXERR, NERR
15705 * ..
15706 * .. Array Arguments ..
15707  INTEGER RA(*), CA(*), ERRIBUF(6, MAXERR)
15708  REAL ERRDBUF(2, MAXERR)
15709 * ..
15710 * .. Parameters ..
15711  INTEGER ERR_PRE, ERR_POST, ERR_GAP, ERR_TRI, ERR_MAT
15712  parameter( err_pre = 1, err_post = 2, err_gap = 3, err_tri = 4 )
15713  parameter( err_mat = 5 )
15714 * ..
15715 * .. External Functions ..
15716  INTEGER IBTNPROCS
15717  EXTERNAL IBTNPROCS
15718 * ..
15719 * .. Local Scalars ..
15720  INTEGER I, J, K, IAM
15721 * ..
15722 * .. Executable Statements ..
15723 *
15724  iam = myrow * ibtnprocs() + mycol
15725 *
15726 * Check pre padding
15727 *
15728  IF( ldi .NE. -1 ) THEN
15729  IF( ipre .GT. 0 ) THEN
15730  DO 10 i = 1, ipre
15731  IF( ra(i) .NE. padval ) THEN
15732  nerr = nerr + 1
15733  IF( nerr .LE. maxerr ) THEN
15734  erribuf(1, nerr) = testnum
15735  erribuf(2, nerr) = ldi
15736  erribuf(3, nerr) = iam
15737  erribuf(4, nerr) = i
15738  erribuf(5, nerr) = ipre - i + 1
15739  erribuf(6, nerr) = -err_pre
15740  errdbuf(1, nerr) = real( ra(i) )
15741  errdbuf(2, nerr) = real( padval )
15742  END IF
15743  ENDIF
15744  IF( ca(i) .NE. padval ) THEN
15745  nerr = nerr + 1
15746  IF( nerr .LE. maxerr ) THEN
15747  erribuf(1, nerr) = testnum
15748  erribuf(2, nerr) = ldi
15749  erribuf(3, nerr) = iam
15750  erribuf(4, nerr) = i
15751  erribuf(5, nerr) = ipre - i + 1
15752  erribuf(6, nerr) = -10 - err_pre
15753  errdbuf(1, nerr) = real( ca(i) )
15754  errdbuf(2, nerr) = real( padval )
15755  END IF
15756  ENDIF
15757  10 CONTINUE
15758  END IF
15759 *
15760 * Check post padding
15761 *
15762  IF( ipost .GT. 0 ) THEN
15763  k = ipre + ldi*n
15764  DO 20 i = k+1, k+ipost
15765  IF( ra(i) .NE. padval ) THEN
15766  nerr = nerr + 1
15767  IF( nerr .LE. maxerr ) THEN
15768  erribuf(1, nerr) = testnum
15769  erribuf(2, nerr) = ldi
15770  erribuf(3, nerr) = iam
15771  erribuf(4, nerr) = i - k
15772  erribuf(5, nerr) = i
15773  erribuf(6, nerr) = -err_post
15774  errdbuf(1, nerr) = real( ra(i) )
15775  errdbuf(2, nerr) = real( padval )
15776  END IF
15777  ENDIF
15778  IF( ca(i) .NE. padval ) THEN
15779  nerr = nerr + 1
15780  IF( nerr .LE. maxerr ) THEN
15781  erribuf(1, nerr) = testnum
15782  erribuf(2, nerr) = ldi
15783  erribuf(3, nerr) = iam
15784  erribuf(4, nerr) = i - k
15785  erribuf(5, nerr) = i
15786  erribuf(6, nerr) = -10 - err_post
15787  errdbuf(1, nerr) = real( ca(i) )
15788  errdbuf(2, nerr) = real( padval )
15789  END IF
15790  ENDIF
15791  20 CONTINUE
15792  END IF
15793 *
15794 * Check all (LDI-M) gaps
15795 *
15796  IF( ldi .GT. m ) THEN
15797  k = ipre + m + 1
15798  DO 40 j = 1, n
15799  DO 30 i = m+1, ldi
15800  k = ipre + (j-1)*ldi + i
15801  IF( ra(k) .NE. padval) THEN
15802  nerr = nerr + 1
15803  IF( nerr .LE. maxerr ) THEN
15804  erribuf(1, nerr) = testnum
15805  erribuf(2, nerr) = ldi
15806  erribuf(3, nerr) = iam
15807  erribuf(4, nerr) = i
15808  erribuf(5, nerr) = j
15809  erribuf(6, nerr) = -err_gap
15810  errdbuf(1, nerr) = real( ra(k) )
15811  errdbuf(2, nerr) = real( padval )
15812  END IF
15813  END IF
15814  IF( ca(k) .NE. padval) THEN
15815  nerr = nerr + 1
15816  IF( nerr .LE. maxerr ) THEN
15817  erribuf(1, nerr) = testnum
15818  erribuf(2, nerr) = ldi
15819  erribuf(3, nerr) = iam
15820  erribuf(4, nerr) = i
15821  erribuf(5, nerr) = j
15822  erribuf(6, nerr) = -10 - err_gap
15823  errdbuf(1, nerr) = real( ca(k) )
15824  errdbuf(2, nerr) = real( padval )
15825  END IF
15826  END IF
15827  30 CONTINUE
15828  40 CONTINUE
15829  END IF
15830 *
15831 * if RA and CA don't exist, buffs better be untouched
15832 *
15833  ELSE
15834  DO 50 i = 1, ipre+ipost
15835  IF( ra(i) .NE. padval) THEN
15836  nerr = nerr + 1
15837  IF( nerr .LE. maxerr ) THEN
15838  erribuf(1, nerr) = testnum
15839  erribuf(2, nerr) = ldi
15840  erribuf(3, nerr) = iam
15841  erribuf(4, nerr) = i
15842  erribuf(5, nerr) = ipre+ipost
15843  erribuf(6, nerr) = -err_pre
15844  errdbuf(1, nerr) = real( ra(i) )
15845  errdbuf(2, nerr) = real( padval )
15846  END IF
15847  END IF
15848  IF( ca(i) .NE. padval) THEN
15849  nerr = nerr + 1
15850  IF( nerr .LE. maxerr ) THEN
15851  erribuf(1, nerr) = testnum
15852  erribuf(2, nerr) = ldi
15853  erribuf(3, nerr) = iam
15854  erribuf(4, nerr) = i
15855  erribuf(5, nerr) = ipre+ipost
15856  erribuf(6, nerr) = -10 - err_pre
15857  errdbuf(1, nerr) = real( ca(i) )
15858  errdbuf(2, nerr) = real( padval )
15859  END IF
15860  END IF
15861  50 CONTINUE
15862  ENDIF
15863 *
15864  RETURN
15865  END
15866 *
15867  SUBROUTINE schkamx( SCOPE, ICTXT, M, N, A, LDA, RA, CA, LDI,
15868  $ TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF,
15869  $ ISEED, VALS )
15870 *
15871 * .. Scalar Arguments ..
15872  CHARACTER*1 SCOPE
15873  INTEGER ICTXT, M, N, LDA, LDI, TESTNUM, MAXERR, NERR
15874 * ..
15875 * .. Array Arguments ..
15876  INTEGER RA(*), CA(*), ERRIBUF(6, MAXERR), ISEED(*)
15877  REAL A(LDA,*), ERRDBUF(2, MAXERR), VALS(*)
15878 * ..
15879 * .. External Functions ..
15880  INTEGER IBTMYPROC, IBTNPROCS, IBTSPNUM
15881  REAL SBTEPS, SBTABS
15882  REAL SBTRAN
15883  EXTERNAL IBTMYPROC, IBTNPROCS, IBTSPNUM, SBTRAN, SBTEPS, SBTABS
15884 * ..
15885 * .. External Subroutines ..
15886  EXTERNAL ibtspcoord
15887 * ..
15888 * .. Local Scalars ..
15889  LOGICAL ERROR
15890  INTEGER NPROCS, NNODES, NPROW, NPCOL, MYROW, MYCOL, RAMX, CAMX
15891  INTEGER IAMX, I, J, K, H, DEST, NODE
15892  REAL EPS
15893 * ..
15894 * .. Executable Statements ..
15895 *
15896  nprocs = ibtnprocs()
15897  eps = sbteps()
15898  CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
15899  dest = myrow*nprocs + mycol
15900 *
15901 * Set up seeds to match those used by each proc's genmat call
15902 *
15903  IF( scope .EQ. 'R' ) THEN
15904  nnodes = npcol
15905  DO 10 i = 0, nnodes-1
15906  node = myrow * nprocs + i
15907  iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
15908  iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
15909  iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
15910  iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
15911  10 CONTINUE
15912  ELSE IF( scope .EQ. 'C' ) THEN
15913  nnodes = nprow
15914  DO 20 i = 0, nnodes-1
15915  node = i * nprocs + mycol
15916  iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
15917  iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
15918  iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
15919  iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
15920  20 CONTINUE
15921  ELSE
15922  nnodes = nprow * npcol
15923  DO 30 i = 0, nnodes-1
15924  node = (i / npcol) * nprocs + mod(i, npcol)
15925  iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
15926  iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
15927  iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
15928  iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
15929  30 CONTINUE
15930  END IF
15931 *
15932  DO 100 j = 1, n
15933  DO 90 i = 1, m
15934  h = (j-1)*ldi + i
15935  vals(1) = sbtran( iseed )
15936  iamx = 1
15937  IF( nnodes .GT. 1 ) THEN
15938  DO 40 k = 1, nnodes-1
15939  vals(k+1) = sbtran( iseed(k*4+1) )
15940  IF( sbtabs( vals(k+1) ) .GT. sbtabs( vals(iamx) ) )
15941  $ iamx = k + 1
15942  40 CONTINUE
15943  END IF
15944 *
15945 * If BLACS have not returned same value we've chosen
15946 *
15947  IF( a(i,j) .NE. vals(iamx) ) THEN
15948 *
15949 * If we have RA and CA arrays
15950 *
15951  IF( ldi .NE. -1 ) THEN
15952 *
15953 * Any number having the same absolute value is a valid max
15954 *
15955  k = ibtspnum( scope, ra(h), ca(h), npcol ) + 1
15956  IF( k.GT.0 .AND. k.LE.nnodes ) THEN
15957  error = sbtabs( vals(k) ).NE.sbtabs( vals(iamx) )
15958  IF( .NOT.error ) iamx = k
15959  ELSE
15960  error = .true.
15961  END IF
15962  ELSE
15963 *
15964 * Error if BLACS answer not same absolute value, or if it
15965 * was not really in the numbers being compared
15966 *
15967  error = ( sbtabs( a(i,j) ) .NE. sbtabs( vals(iamx) ) )
15968  IF( .NOT.error ) THEN
15969  DO 50 k = 1, nnodes
15970  IF( vals(k) .EQ. a(i,j) ) GOTO 60
15971  50 CONTINUE
15972  error = .true.
15973  60 CONTINUE
15974  ENDIF
15975  END IF
15976 *
15977 * If the value is in error
15978 *
15979  IF( error ) THEN
15980  nerr = nerr + 1
15981  erribuf(1, nerr) = testnum
15982  erribuf(2, nerr) = nnodes
15983  erribuf(3, nerr) = dest
15984  erribuf(4, nerr) = i
15985  erribuf(5, nerr) = j
15986  erribuf(6, nerr) = 5
15987  errdbuf(1, nerr) = a(i,j)
15988  errdbuf(2, nerr) = vals(iamx)
15989  END IF
15990  END IF
15991 *
15992 * If they are defined, make sure coordinate entries are OK
15993 *
15994  IF( ldi .NE. -1 ) THEN
15995  k = ibtspnum( scope, ra(h), ca(h), npcol ) + 1
15996  IF( k.NE.iamx ) THEN
15997 *
15998 * Make sure more than one proc doesn't have exact same value
15999 * (and therefore there may be more than one valid coordinate
16000 * for a single value)
16001 *
16002  IF( k.GT.nnodes .OR. k.LT.1 ) THEN
16003  error = .true.
16004  ELSE
16005  error = ( vals(k) .NE. vals(iamx) )
16006  END IF
16007  IF( error ) THEN
16008  CALL ibtspcoord( scope, iamx-1, myrow, mycol,
16009  $ npcol, ramx, camx )
16010  IF( ramx .NE. ra(h) ) THEN
16011  nerr = nerr + 1
16012  erribuf(1, nerr) = testnum
16013  erribuf(2, nerr) = nnodes
16014  erribuf(3, nerr) = dest
16015  erribuf(4, nerr) = i
16016  erribuf(5, nerr) = j
16017  erribuf(6, nerr) = -5
16018  errdbuf(1, nerr) = ra(h)
16019  errdbuf(2, nerr) = ramx
16020  END IF
16021  IF( camx .NE. ca(h) ) THEN
16022  nerr = nerr + 1
16023  erribuf(1, nerr) = testnum
16024  erribuf(2, nerr) = nnodes
16025  erribuf(3, nerr) = dest
16026  erribuf(4, nerr) = i
16027  erribuf(5, nerr) = j
16028  erribuf(6, nerr) = -15
16029  errdbuf(1, nerr) = ca(h)
16030  errdbuf(2, nerr) = camx
16031  END IF
16032  END IF
16033  END IF
16034  END IF
16035  90 CONTINUE
16036  100 CONTINUE
16037 *
16038  RETURN
16039 *
16040 * End of SCHKAMX
16041 *
16042  END
16043 *
16044 *
16045  SUBROUTINE damxtest( OUTNUM, VERB, TOPSREPEAT, TOPSCOHRNT, NSCOPE,
16046  $ SCOPE0, NTOP, TOP0, NMAT, M0, N0, LDAS0,
16047  $ LDAD0, LDI0, NDEST, RDEST0, CDEST0, NGRID,
16048  $ CONTEXT0, P0, Q0, ISEED, RMEM, CMEM, RCLEN,
16049  $ MEM, MEMLEN )
16050 *
16051 * -- BLACS tester (version 1.0) --
16052 * University of Tennessee
16053 * December 15, 1994
16054 *
16055 *
16056 * .. Scalar Arguments ..
16057  INTEGER MEMLEN, NDEST, NGRID, NMAT, NSCOPE, NTOP, OUTNUM, RCLEN,
16058  $ TOPSCOHRNT, TOPSREPEAT, VERB
16059 * ..
16060 * .. Array Arguments ..
16061  CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP)
16062  INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT), LDI0(NMAT)
16063  INTEGER RDEST0(NDEST), CDEST0(NDEST), CONTEXT0(NGRID)
16064  INTEGER P0(NGRID), Q0(NGRID), ISEED(*), RMEM(RCLEN), CMEM(RCLEN)
16065  DOUBLE PRECISION MEM(MEMLEN)
16066 * ..
16067 *
16068 * Purpose
16069 * =======
16070 * DTESTAMX: Test double precision AMX COMBINE
16071 *
16072 * Arguments
16073 * =========
16074 * OUTNUM (input) INTEGER
16075 * The device number to write output to.
16076 *
16077 * VERB (input) INTEGER
16078 * The level of verbosity (how much printing to do).
16079 *
16080 * NSCOPE (input) INTEGER
16081 * The number of scopes to be tested.
16082 *
16083 * SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE)
16084 * Values of the scopes to be tested.
16085 *
16086 * NTOP (input) INTEGER
16087 * The number of topologies to be tested.
16088 *
16089 * TOP0 (input) CHARACTER*1 array of dimension (NTOP)
16090 * Values of the topologies to be tested.
16091 *
16092 * NMAT (input) INTEGER
16093 * The number of matrices to be tested.
16094 *
16095 * M0 (input) INTEGER array of dimension (NMAT)
16096 * Values of M to be tested.
16097 *
16098 * M0 (input) INTEGER array of dimension (NMAT)
16099 * Values of M to be tested.
16100 *
16101 * N0 (input) INTEGER array of dimension (NMAT)
16102 * Values of N to be tested.
16103 *
16104 * LDAS0 (input) INTEGER array of dimension (NMAT)
16105 * Values of LDAS (leading dimension of A on source process)
16106 * to be tested.
16107 *
16108 * LDAD0 (input) INTEGER array of dimension (NMAT)
16109 * Values of LDAD (leading dimension of A on destination
16110 * process) to be tested.
16111 * LDI0 (input) INTEGER array of dimension (NMAT)
16112 * Values of LDI (leading dimension of RA/CA) to be tested.
16113 * If LDI == -1, these RA/CA should not be accessed.
16114 *
16115 * NDEST (input) INTEGER
16116 * The number of destinations to be tested.
16117 *
16118 * RDEST0 (input) INTEGER array of dimension (NNDEST)
16119 * Values of RDEST (row coordinate of destination) to be
16120 * tested.
16121 *
16122 * CDEST0 (input) INTEGER array of dimension (NNDEST)
16123 * Values of CDEST (column coordinate of destination) to be
16124 * tested.
16125 *
16126 * NGRID (input) INTEGER
16127 * The number of process grids to be tested.
16128 *
16129 * CONTEXT0 (input) INTEGER array of dimension (NGRID)
16130 * The BLACS context handles corresponding to the grids.
16131 *
16132 * P0 (input) INTEGER array of dimension (NGRID)
16133 * Values of P (number of process rows, NPROW).
16134 *
16135 * Q0 (input) INTEGER array of dimension (NGRID)
16136 * Values of Q (number of process columns, NPCOL).
16137 *
16138 * ISEED (workspace) INTEGER array of dimension ( MAX(NPROCS, NTESTS) )
16139 * Workspace used to hold each process's random number SEED.
16140 * This requires NPROCS (number of processor) elements.
16141 * If VERB < 2, this workspace also serves to indicate which
16142 * tests fail. This requires workspace of NTESTS
16143 * (number of tests performed).
16144 *
16145 * RMEM (workspace) INTEGER array of dimension (RCLEN)
16146 * Used for all RA arrays, and their pre and post padding.
16147 *
16148 * CMEM (workspace) INTEGER array of dimension (RCLEN)
16149 * Used for all CA arrays, and their pre and post padding.
16150 *
16151 * RCLEN (input) INTEGER
16152 * The length, in elements, of RMEM and CMEM.
16153 *
16154 * MEM (workspace) DOUBLE PRECISION array of dimension (MEMLEN)
16155 * Used for all other workspaces, including the matrix A,
16156 * and its pre and post padding.
16157 *
16158 * MEMLEN (input) INTEGER
16159 * The length, in elements, of MEM.
16160 *
16161 * =====================================================================
16162 *
16163 * .. External Functions ..
16164  LOGICAL ALLPASS, LSAME
16165  INTEGER IBTMYPROC, IBTNPROCS, IBTSIZEOF
16166  EXTERNAL ALLPASS, LSAME, IBTMYPROC, IBTNPROCS, IBTSIZEOF
16167 * ..
16168 * .. External Subroutines ..
16169  EXTERNAL blacs_gridinfo, dgamx2d
16170  EXTERNAL dinitmat, dchkpad, dbtcheckin
16171 * ..
16172 * .. Local Scalars ..
16173  CHARACTER*1 SCOPE, TOP
16174  LOGICAL INGRID, TESTOK, ALLRCV
16175  INTEGER APTR, CAPTR, CDEST, CDEST2, CONTEXT, DSIZE, ERRDPTR,
16176  $ ERRIPTR, I, IAM, ICHECKVAL, IDE, IGR, IMA, IPAD, IPOST,
16177  $ IPRE, ISC, ISIZE, ISTART, ISTOP, ITC, ITC1, ITC2, ITO,
16178  $ ITR, ITR1, ITR2, J, K, LDA, LDADST, LDASRC, LDI, M,
16179  $ MAXERR, MYCOL, MYROW, N, NERR, NFAIL, NPCOL, NPROW, NSKIP,
16180  $ PREAPTR, RAPTR, RDEST, RDEST2, SETWHAT, TESTNUM, VALPTR
16181  DOUBLE PRECISION CHECKVAL
16182 * ..
16183 * .. Executable Statements ..
16184 *
16185 * Choose padding value, and make it unique
16186 *
16187  checkval = -0.81d0
16188  iam = ibtmyproc()
16189  checkval = iam * checkval
16190  isize = ibtsizeof('I')
16191  dsize = ibtsizeof('D')
16192  icheckval = -iam
16193 *
16194 * Verify file parameters
16195 *
16196  IF( iam .EQ. 0 ) THEN
16197  WRITE(outnum, *) ' '
16198  WRITE(outnum, *) ' '
16199  WRITE(outnum, 1000 )
16200  IF( verb .GT. 0 ) THEN
16201  WRITE(outnum,*) ' '
16202  WRITE(outnum, 2000) 'NSCOPE:', nscope
16203  WRITE(outnum, 3000) ' SCOPE:', ( scope0(i), i = 1, nscope )
16204  WRITE(outnum, 2000) 'TReps :', topsrepeat
16205  WRITE(outnum, 2000) 'TCohr :', topscohrnt
16206  WRITE(outnum, 2000) 'NTOP :', ntop
16207  WRITE(outnum, 3000) ' TOP :', ( top0(i), i = 1, ntop )
16208  WRITE(outnum, 2000) 'NMAT :', nmat
16209  WRITE(outnum, 2000) ' M :', ( m0(i), i = 1, nmat )
16210  WRITE(outnum, 2000) ' N :', ( n0(i), i = 1, nmat )
16211  WRITE(outnum, 2000) ' LDAS :', ( ldas0(i), i = 1, nmat )
16212  WRITE(outnum, 2000) ' LDAD :', ( ldad0(i), i = 1, nmat )
16213  WRITE(outnum, 2000) ' LDI :', ( ldi0(i), i = 1, nmat )
16214  WRITE(outnum, 2000) 'NDEST :', ndest
16215  WRITE(outnum, 2000) ' RDEST:',( rdest0(i), i = 1, ndest )
16216  WRITE(outnum, 2000) ' CDEST:',( cdest0(i), i = 1, ndest )
16217  WRITE(outnum, 2000) 'NGRIDS:', ngrid
16218  WRITE(outnum, 2000) ' P :', ( p0(i), i = 1, ngrid )
16219  WRITE(outnum, 2000) ' Q :', ( q0(i), i = 1, ngrid )
16220  WRITE(outnum, 2000) 'VERB :', verb
16221  WRITE(outnum,*) ' '
16222  END IF
16223  IF( verb .GT. 1 ) THEN
16224  WRITE(outnum,4000)
16225  WRITE(outnum,5000)
16226  END IF
16227  END IF
16228  IF (topsrepeat.EQ.0) THEN
16229  itr1 = 0
16230  itr2 = 0
16231  ELSE IF (topsrepeat.EQ.1) THEN
16232  itr1 = 1
16233  itr2 = 1
16234  ELSE
16235  itr1 = 0
16236  itr2 = 1
16237  END IF
16238 *
16239 * Find biggest matrix, so we know where to stick error info
16240 *
16241  i = 0
16242  DO 10 ima = 1, nmat
16243  ipad = 4 * m0(ima)
16244  k = n0(ima) * max0( ldas0(ima), ldad0(ima) ) + ipad
16245  IF( k .GT. i ) i = k
16246  10 CONTINUE
16247  i = i + ibtnprocs()
16248  maxerr = ( dsize * (memlen-i) ) / ( dsize*2 + isize*6 )
16249  IF( maxerr .LT. 1 ) THEN
16250  WRITE(outnum,*) 'ERROR: Not enough memory to run MAX tests.'
16251  CALL blacs_abort(-1, 1)
16252  END IF
16253  errdptr = i + 1
16254  erriptr = errdptr + maxerr
16255  nerr = 0
16256  testnum = 0
16257  nfail = 0
16258  nskip = 0
16259 *
16260 * Loop over grids of matrix
16261 *
16262  DO 90 igr = 1, ngrid
16263 *
16264 * allocate process grid for the next batch of tests
16265 *
16266  context = context0(igr)
16267  CALL blacs_gridinfo( context, nprow, npcol, myrow, mycol )
16268  ingrid = ( (myrow.LT.nprow) .AND. (mycol.LT.npcol) )
16269 *
16270  DO 80 isc = 1, nscope
16271  scope = scope0(isc)
16272  DO 70 ito = 1, ntop
16273  top = top0(ito)
16274 *
16275 * If testing multiring ('M') or general tree ('T'), need to
16276 * loop over calls to BLACS_SET to do full test
16277 *
16278  IF( lsame(top, 'M') ) THEN
16279  setwhat = 13
16280  IF( scope .EQ. 'R' ) THEN
16281  istart = -(npcol - 1)
16282  istop = -istart
16283  ELSE IF (scope .EQ. 'C') THEN
16284  istart = -(nprow - 1)
16285  istop = -istart
16286  ELSE
16287  istart = -(nprow*npcol - 1)
16288  istop = -istart
16289  ENDIF
16290  ELSE IF( lsame(top, 'T') ) THEN
16291  setwhat = 14
16292  istart = 1
16293  IF( scope .EQ. 'R' ) THEN
16294  istop = npcol - 1
16295  ELSE IF (scope .EQ. 'C') THEN
16296  istop = nprow - 1
16297  ELSE
16298  istop = nprow*npcol - 1
16299  ENDIF
16300  ELSE
16301  setwhat = 0
16302  istart = 1
16303  istop = 1
16304  ENDIF
16305  DO 60 ima = 1, nmat
16306  m = m0(ima)
16307  n = n0(ima)
16308  ldasrc = ldas0(ima)
16309  ldadst = ldad0(ima)
16310  ldi = ldi0(ima)
16311  ipre = 2 * m
16312  ipost = ipre
16313  preaptr = 1
16314  aptr = preaptr + ipre
16315 *
16316  DO 50 ide = 1, ndest
16317  testnum = testnum + 1
16318  rdest2 = rdest0(ide)
16319  cdest2 = cdest0(ide)
16320 *
16321 * If everyone gets the answer, create some bogus rdest/cdest
16322 * so IF's are easier
16323 *
16324  allrcv = ( (rdest2.EQ.-1) .OR. (cdest2.EQ.-1) )
16325  IF( allrcv ) THEN
16326  rdest = nprow - 1
16327  cdest = npcol - 1
16328  IF (topscohrnt.EQ.0) THEN
16329  itr1 = 0
16330  itr2 = 0
16331  ELSE IF (topscohrnt.EQ.1) THEN
16332  itr1 = 1
16333  itr2 = 1
16334  ELSE
16335  itr1 = 0
16336  itr2 = 1
16337  END IF
16338  ELSE
16339  rdest = rdest2
16340  cdest = cdest2
16341  itc1 = 0
16342  itc2 = 0
16343  END IF
16344  IF( rdest.GE.p0(igr) .OR. cdest.GE.q0(igr) ) THEN
16345  nskip = nskip + 1
16346  GOTO 50
16347  END IF
16348 *
16349  IF( myrow.EQ.rdest .AND. mycol.EQ.cdest ) THEN
16350  lda = ldadst
16351  ELSE
16352  lda = ldasrc
16353  END IF
16354  valptr = aptr + ipost + n * lda
16355  IF( verb .GT. 1 ) THEN
16356  IF( iam .EQ. 0 ) THEN
16357  WRITE(outnum, 6000)
16358  $ testnum, 'RUNNING', scope, top, m, n,
16359  $ ldasrc, ldadst, ldi, rdest2, cdest2,
16360  $ nprow, npcol
16361  END IF
16362  END IF
16363 *
16364 * If I am in scope
16365 *
16366  testok = .true.
16367  IF( ingrid ) THEN
16368  IF( (myrow.EQ.rdest .AND. scope.EQ.'R') .OR.
16369  $ (mycol.EQ.cdest .AND. scope.EQ.'C') .OR.
16370  $ (scope .EQ. 'A') ) THEN
16371 *
16372  k = nerr
16373  DO 40 itr = itr1, itr2
16374  CALL blacs_set(context, 15, itr)
16375  DO 35 itc = itc1, itc2
16376  CALL blacs_set(context, 16, itc)
16377  DO 30 j = istart, istop
16378  IF( j.EQ.0) GOTO 30
16379  IF( setwhat.NE.0 )
16380  $ CALL blacs_set(context, setwhat, j)
16381 *
16382 *
16383 * generate and pad matrix A
16384 *
16385  CALL dinitmat('G','-', m, n, mem(preaptr),
16386  $ lda, ipre, ipost,
16387  $ checkval, testnum,
16388  $ myrow, mycol )
16389 *
16390 * If they exist, pad RA and CA arrays
16391 *
16392  IF( ldi .NE. -1 ) THEN
16393  DO 15 i = 1, n*ldi + ipre + ipost
16394  rmem(i) = icheckval
16395  cmem(i) = icheckval
16396  15 CONTINUE
16397  raptr = 1 + ipre
16398  captr = 1 + ipre
16399  ELSE
16400  DO 20 i = 1, ipre+ipost
16401  rmem(i) = icheckval
16402  cmem(i) = icheckval
16403  20 CONTINUE
16404  raptr = 1
16405  captr = 1
16406  END IF
16407 *
16408  CALL dgamx2d(context, scope, top, m, n,
16409  $ mem(aptr), lda, rmem(raptr),
16410  $ cmem(captr), ldi,
16411  $ rdest2, cdest2)
16412 *
16413 * If I've got the answer, check for errors in
16414 * matrix or padding
16415 *
16416  IF( (myrow.EQ.rdest .AND. mycol.EQ.cdest)
16417  $ .OR. allrcv ) THEN
16418  CALL dchkpad('G','-', m, n,
16419  $ mem(preaptr), lda, rdest,
16420  $ cdest, myrow, mycol,
16421  $ ipre, ipost, checkval,
16422  $ testnum, maxerr, nerr,
16423  $ mem(erriptr),mem(errdptr))
16424  CALL dchkamx(scope, context, m, n,
16425  $ mem(aptr), lda,
16426  $ rmem(raptr), cmem(captr),
16427  $ ldi, testnum, maxerr,nerr,
16428  $ mem(erriptr),mem(errdptr),
16429  $ iseed, mem(valptr))
16430  CALL drcchk(ipre, ipost, icheckval,
16431  $ m, n, rmem, cmem, ldi,
16432  $ myrow, mycol, testnum,
16433  $ maxerr, nerr,
16434  $ mem(erriptr), mem(errdptr))
16435  END IF
16436  30 CONTINUE
16437  CALL blacs_set(context, 16, 0)
16438  35 CONTINUE
16439  CALL blacs_set(context, 15, 0)
16440  40 CONTINUE
16441  testok = ( k .EQ. nerr )
16442  END IF
16443  END IF
16444 *
16445  IF( verb .GT. 1 ) THEN
16446  i = nerr
16447  CALL dbtcheckin(0, outnum, maxerr, nerr,
16448  $ mem(erriptr), mem(errdptr), iseed)
16449  IF( iam .EQ. 0 ) THEN
16450  IF( testok .AND. nerr.EQ.i ) THEN
16451  WRITE(outnum,6000)testnum,'PASSED ',
16452  $ scope, top, m, n, ldasrc,
16453  $ ldadst, ldi, rdest2, cdest2,
16454  $ nprow, npcol
16455  ELSE
16456  nfail = nfail + 1
16457  WRITE(outnum,6000)testnum,'FAILED ',
16458  $ scope, top, m, n, ldasrc,
16459  $ ldadst, ldi, rdest2, cdest2,
16460  $ nprow, npcol
16461  END IF
16462  END IF
16463 *
16464 * Once we've printed out errors, can re-use buf space
16465 *
16466  nerr = 0
16467  END IF
16468  50 CONTINUE
16469  60 CONTINUE
16470  70 CONTINUE
16471  80 CONTINUE
16472  90 CONTINUE
16473 *
16474  IF( verb .LT. 2 ) THEN
16475  nfail = testnum
16476  CALL dbtcheckin( nfail, outnum, maxerr, nerr, mem(erriptr),
16477  $ mem(errdptr), iseed )
16478  END IF
16479  IF( iam .EQ. 0 ) THEN
16480  IF( verb .GT. 1 ) WRITE(outnum,*) ' '
16481  IF( nfail+nskip .EQ. 0 ) THEN
16482  WRITE(outnum, 7000 ) testnum
16483  ELSE
16484  WRITE(outnum, 8000 ) testnum, testnum-nskip-nfail,
16485  $ nskip, nfail
16486  END IF
16487  END IF
16488 *
16489 * Log whether their were any failures
16490 *
16491  testok = allpass( (nfail.EQ.0) )
16492 *
16493  1000 FORMAT('DOUBLE PRECISION AMX TESTS: BEGIN.' )
16494  2000 FORMAT(1x,a7,3x,10i6)
16495  3000 FORMAT(1x,a7,3x,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,
16496  $ 5x,a1,5x,a1)
16497  4000 FORMAT(' TEST# STATUS SCOPE TOP M N LDAS LDAD LDI ',
16498  $ 'RDEST CDEST P Q')
16499  5000 FORMAT(' ----- ------- ----- --- ----- ----- ----- ----- ----- ',
16500  $ '----- ----- ---- ----')
16501  6000 FORMAT(i6,1x,a7,5x,a1,3x,a1,7i6,2i5)
16502  7000 FORMAT('DOUBLE PRECISION AMX TESTS: PASSED ALL',
16503  $ i5, ' TESTS.')
16504  8000 FORMAT('DOUBLE PRECISION AMX TESTS:',i5,' TESTS;',i5,' PASSED,',
16505  $ i5,' SKIPPED,',i5,' FAILED.')
16506 *
16507  RETURN
16508 *
16509 * End of DTESTAMX.
16510 *
16511  END
16512 *
16513  SUBROUTINE drcchk( IPRE, IPOST, PADVAL, M, N, RA, CA, LDI, MYROW,
16514  $ MYCOL, TESTNUM, MAXERR, NERR,
16515  $ ERRIBUF, ERRDBUF )
16516 *
16517 * .. Scalar Arguments ..
16518  INTEGER IPRE, IPOST, PADVAL, M, N, LDI, MYROW, MYCOL, TESTNUM
16519  INTEGER MAXERR, NERR
16520 * ..
16521 * .. Array Arguments ..
16522  INTEGER RA(*), CA(*), ERRIBUF(6, MAXERR)
16523  DOUBLE PRECISION ERRDBUF(2, MAXERR)
16524 * ..
16525 * .. Parameters ..
16526  INTEGER ERR_PRE, ERR_POST, ERR_GAP, ERR_TRI, ERR_MAT
16527  parameter( err_pre = 1, err_post = 2, err_gap = 3, err_tri = 4 )
16528  parameter( err_mat = 5 )
16529 * ..
16530 * .. External Functions ..
16531  INTEGER IBTNPROCS
16532  EXTERNAL ibtnprocs
16533 * ..
16534 * .. Local Scalars ..
16535  INTEGER I, J, K, IAM
16536 * ..
16537 * .. Executable Statements ..
16538 *
16539  iam = myrow * ibtnprocs() + mycol
16540 *
16541 * Check pre padding
16542 *
16543  IF( ldi .NE. -1 ) THEN
16544  IF( ipre .GT. 0 ) THEN
16545  DO 10 i = 1, ipre
16546  IF( ra(i) .NE. padval ) THEN
16547  nerr = nerr + 1
16548  IF( nerr .LE. maxerr ) THEN
16549  erribuf(1, nerr) = testnum
16550  erribuf(2, nerr) = ldi
16551  erribuf(3, nerr) = iam
16552  erribuf(4, nerr) = i
16553  erribuf(5, nerr) = ipre - i + 1
16554  erribuf(6, nerr) = -err_pre
16555  errdbuf(1, nerr) = dble( ra(i) )
16556  errdbuf(2, nerr) = dble( padval )
16557  END IF
16558  ENDIF
16559  IF( ca(i) .NE. padval ) THEN
16560  nerr = nerr + 1
16561  IF( nerr .LE. maxerr ) THEN
16562  erribuf(1, nerr) = testnum
16563  erribuf(2, nerr) = ldi
16564  erribuf(3, nerr) = iam
16565  erribuf(4, nerr) = i
16566  erribuf(5, nerr) = ipre - i + 1
16567  erribuf(6, nerr) = -10 - err_pre
16568  errdbuf(1, nerr) = dble( ca(i) )
16569  errdbuf(2, nerr) = dble( padval )
16570  END IF
16571  ENDIF
16572  10 CONTINUE
16573  END IF
16574 *
16575 * Check post padding
16576 *
16577  IF( ipost .GT. 0 ) THEN
16578  k = ipre + ldi*n
16579  DO 20 i = k+1, k+ipost
16580  IF( ra(i) .NE. padval ) THEN
16581  nerr = nerr + 1
16582  IF( nerr .LE. maxerr ) THEN
16583  erribuf(1, nerr) = testnum
16584  erribuf(2, nerr) = ldi
16585  erribuf(3, nerr) = iam
16586  erribuf(4, nerr) = i - k
16587  erribuf(5, nerr) = i
16588  erribuf(6, nerr) = -err_post
16589  errdbuf(1, nerr) = dble( ra(i) )
16590  errdbuf(2, nerr) = dble( padval )
16591  END IF
16592  ENDIF
16593  IF( ca(i) .NE. padval ) THEN
16594  nerr = nerr + 1
16595  IF( nerr .LE. maxerr ) THEN
16596  erribuf(1, nerr) = testnum
16597  erribuf(2, nerr) = ldi
16598  erribuf(3, nerr) = iam
16599  erribuf(4, nerr) = i - k
16600  erribuf(5, nerr) = i
16601  erribuf(6, nerr) = -10 - err_post
16602  errdbuf(1, nerr) = dble( ca(i) )
16603  errdbuf(2, nerr) = dble( padval )
16604  END IF
16605  ENDIF
16606  20 CONTINUE
16607  END IF
16608 *
16609 * Check all (LDI-M) gaps
16610 *
16611  IF( ldi .GT. m ) THEN
16612  k = ipre + m + 1
16613  DO 40 j = 1, n
16614  DO 30 i = m+1, ldi
16615  k = ipre + (j-1)*ldi + i
16616  IF( ra(k) .NE. padval) THEN
16617  nerr = nerr + 1
16618  IF( nerr .LE. maxerr ) THEN
16619  erribuf(1, nerr) = testnum
16620  erribuf(2, nerr) = ldi
16621  erribuf(3, nerr) = iam
16622  erribuf(4, nerr) = i
16623  erribuf(5, nerr) = j
16624  erribuf(6, nerr) = -err_gap
16625  errdbuf(1, nerr) = dble( ra(k) )
16626  errdbuf(2, nerr) = dble( padval )
16627  END IF
16628  END IF
16629  IF( ca(k) .NE. padval) THEN
16630  nerr = nerr + 1
16631  IF( nerr .LE. maxerr ) THEN
16632  erribuf(1, nerr) = testnum
16633  erribuf(2, nerr) = ldi
16634  erribuf(3, nerr) = iam
16635  erribuf(4, nerr) = i
16636  erribuf(5, nerr) = j
16637  erribuf(6, nerr) = -10 - err_gap
16638  errdbuf(1, nerr) = dble( ca(k) )
16639  errdbuf(2, nerr) = dble( padval )
16640  END IF
16641  END IF
16642  30 CONTINUE
16643  40 CONTINUE
16644  END IF
16645 *
16646 * if RA and CA don't exist, buffs better be untouched
16647 *
16648  ELSE
16649  DO 50 i = 1, ipre+ipost
16650  IF( ra(i) .NE. padval) THEN
16651  nerr = nerr + 1
16652  IF( nerr .LE. maxerr ) THEN
16653  erribuf(1, nerr) = testnum
16654  erribuf(2, nerr) = ldi
16655  erribuf(3, nerr) = iam
16656  erribuf(4, nerr) = i
16657  erribuf(5, nerr) = ipre+ipost
16658  erribuf(6, nerr) = -err_pre
16659  errdbuf(1, nerr) = dble( ra(i) )
16660  errdbuf(2, nerr) = dble( padval )
16661  END IF
16662  END IF
16663  IF( ca(i) .NE. padval) THEN
16664  nerr = nerr + 1
16665  IF( nerr .LE. maxerr ) THEN
16666  erribuf(1, nerr) = testnum
16667  erribuf(2, nerr) = ldi
16668  erribuf(3, nerr) = iam
16669  erribuf(4, nerr) = i
16670  erribuf(5, nerr) = ipre+ipost
16671  erribuf(6, nerr) = -10 - err_pre
16672  errdbuf(1, nerr) = dble( ca(i) )
16673  errdbuf(2, nerr) = dble( padval )
16674  END IF
16675  END IF
16676  50 CONTINUE
16677  ENDIF
16678 *
16679  RETURN
16680  END
16681 *
16682  SUBROUTINE dchkamx( SCOPE, ICTXT, M, N, A, LDA, RA, CA, LDI,
16683  $ TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF,
16684  $ ISEED, VALS )
16685 *
16686 * .. Scalar Arguments ..
16687  CHARACTER*1 SCOPE
16688  INTEGER ICTXT, M, N, LDA, LDI, TESTNUM, MAXERR, NERR
16689 * ..
16690 * .. Array Arguments ..
16691  INTEGER RA(*), CA(*), ERRIBUF(6, MAXERR), ISEED(*)
16692  DOUBLE PRECISION A(LDA,*), ERRDBUF(2, MAXERR), VALS(*)
16693 * ..
16694 * .. External Functions ..
16695  INTEGER IBTMYPROC, IBTNPROCS, IBTSPNUM
16696  DOUBLE PRECISION DBTEPS, DBTABS
16697  DOUBLE PRECISION DBTRAN
16698  EXTERNAL ibtmyproc, ibtnprocs, ibtspnum, dbtran, dbteps, dbtabs
16699 * ..
16700 * .. External Subroutines ..
16701  EXTERNAL ibtspcoord
16702 * ..
16703 * .. Local Scalars ..
16704  LOGICAL ERROR
16705  INTEGER NPROCS, NNODES, NPROW, NPCOL, MYROW, MYCOL, RAMX, CAMX
16706  INTEGER IAMX, I, J, K, H, DEST, NODE
16707  DOUBLE PRECISION EPS
16708 * ..
16709 * .. Executable Statements ..
16710 *
16711  nprocs = ibtnprocs()
16712  eps = dbteps()
16713  CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
16714  dest = myrow*nprocs + mycol
16715 *
16716 * Set up seeds to match those used by each proc's genmat call
16717 *
16718  IF( scope .EQ. 'R' ) THEN
16719  nnodes = npcol
16720  DO 10 i = 0, nnodes-1
16721  node = myrow * nprocs + i
16722  iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
16723  iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
16724  iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
16725  iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
16726  10 CONTINUE
16727  ELSE IF( scope .EQ. 'C' ) THEN
16728  nnodes = nprow
16729  DO 20 i = 0, nnodes-1
16730  node = i * nprocs + mycol
16731  iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
16732  iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
16733  iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
16734  iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
16735  20 CONTINUE
16736  ELSE
16737  nnodes = nprow * npcol
16738  DO 30 i = 0, nnodes-1
16739  node = (i / npcol) * nprocs + mod(i, npcol)
16740  iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
16741  iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
16742  iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
16743  iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
16744  30 CONTINUE
16745  END IF
16746 *
16747  DO 100 j = 1, n
16748  DO 90 i = 1, m
16749  h = (j-1)*ldi + i
16750  vals(1) = dbtran( iseed )
16751  iamx = 1
16752  IF( nnodes .GT. 1 ) THEN
16753  DO 40 k = 1, nnodes-1
16754  vals(k+1) = dbtran( iseed(k*4+1) )
16755  IF( dbtabs( vals(k+1) ) .GT. dbtabs( vals(iamx) ) )
16756  $ iamx = k + 1
16757  40 CONTINUE
16758  END IF
16759 *
16760 * If BLACS have not returned same value we've chosen
16761 *
16762  IF( a(i,j) .NE. vals(iamx) ) THEN
16763 *
16764 * If we have RA and CA arrays
16765 *
16766  IF( ldi .NE. -1 ) THEN
16767 *
16768 * Any number having the same absolute value is a valid max
16769 *
16770  k = ibtspnum( scope, ra(h), ca(h), npcol ) + 1
16771  IF( k.GT.0 .AND. k.LE.nnodes ) THEN
16772  error = dbtabs( vals(k) ).NE.dbtabs( vals(iamx) )
16773  IF( .NOT.error ) iamx = k
16774  ELSE
16775  error = .true.
16776  END IF
16777  ELSE
16778 *
16779 * Error if BLACS answer not same absolute value, or if it
16780 * was not really in the numbers being compared
16781 *
16782  error = ( dbtabs( a(i,j) ) .NE. dbtabs( vals(iamx) ) )
16783  IF( .NOT.error ) THEN
16784  DO 50 k = 1, nnodes
16785  IF( vals(k) .EQ. a(i,j) ) GOTO 60
16786  50 CONTINUE
16787  error = .true.
16788  60 CONTINUE
16789  ENDIF
16790  END IF
16791 *
16792 * If the value is in error
16793 *
16794  IF( error ) THEN
16795  nerr = nerr + 1
16796  erribuf(1, nerr) = testnum
16797  erribuf(2, nerr) = nnodes
16798  erribuf(3, nerr) = dest
16799  erribuf(4, nerr) = i
16800  erribuf(5, nerr) = j
16801  erribuf(6, nerr) = 5
16802  errdbuf(1, nerr) = a(i,j)
16803  errdbuf(2, nerr) = vals(iamx)
16804  END IF
16805  END IF
16806 *
16807 * If they are defined, make sure coordinate entries are OK
16808 *
16809  IF( ldi .NE. -1 ) THEN
16810  k = ibtspnum( scope, ra(h), ca(h), npcol ) + 1
16811  IF( k.NE.iamx ) THEN
16812 *
16813 * Make sure more than one proc doesn't have exact same value
16814 * (and therefore there may be more than one valid coordinate
16815 * for a single value)
16816 *
16817  IF( k.GT.nnodes .OR. k.LT.1 ) THEN
16818  error = .true.
16819  ELSE
16820  error = ( vals(k) .NE. vals(iamx) )
16821  END IF
16822  IF( error ) THEN
16823  CALL ibtspcoord( scope, iamx-1, myrow, mycol,
16824  $ npcol, ramx, camx )
16825  IF( ramx .NE. ra(h) ) THEN
16826  nerr = nerr + 1
16827  erribuf(1, nerr) = testnum
16828  erribuf(2, nerr) = nnodes
16829  erribuf(3, nerr) = dest
16830  erribuf(4, nerr) = i
16831  erribuf(5, nerr) = j
16832  erribuf(6, nerr) = -5
16833  errdbuf(1, nerr) = ra(h)
16834  errdbuf(2, nerr) = ramx
16835  END IF
16836  IF( camx .NE. ca(h) ) THEN
16837  nerr = nerr + 1
16838  erribuf(1, nerr) = testnum
16839  erribuf(2, nerr) = nnodes
16840  erribuf(3, nerr) = dest
16841  erribuf(4, nerr) = i
16842  erribuf(5, nerr) = j
16843  erribuf(6, nerr) = -15
16844  errdbuf(1, nerr) = ca(h)
16845  errdbuf(2, nerr) = camx
16846  END IF
16847  END IF
16848  END IF
16849  END IF
16850  90 CONTINUE
16851  100 CONTINUE
16852 *
16853  RETURN
16854 *
16855 * End of DCHKAMX
16856 *
16857  END
16858 *
16859 *
16860  SUBROUTINE camxtest( OUTNUM, VERB, TOPSREPEAT, TOPSCOHRNT, NSCOPE,
16861  $ SCOPE0, NTOP, TOP0, NMAT, M0, N0, LDAS0,
16862  $ LDAD0, LDI0, NDEST, RDEST0, CDEST0, NGRID,
16863  $ CONTEXT0, P0, Q0, ISEED, RMEM, CMEM, RCLEN,
16864  $ MEM, MEMLEN )
16865 *
16866 * -- BLACS tester (version 1.0) --
16867 * University of Tennessee
16868 * December 15, 1994
16869 *
16870 *
16871 * .. Scalar Arguments ..
16872  INTEGER MEMLEN, NDEST, NGRID, NMAT, NSCOPE, NTOP, OUTNUM, RCLEN,
16873  $ topscohrnt, topsrepeat, verb
16874 * ..
16875 * .. Array Arguments ..
16876  CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP)
16877  INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT), LDI0(NMAT)
16878  INTEGER RDEST0(NDEST), CDEST0(NDEST), CONTEXT0(NGRID)
16879  INTEGER P0(NGRID), Q0(NGRID), ISEED(*), RMEM(RCLEN), CMEM(RCLEN)
16880  COMPLEX MEM(MEMLEN)
16881 * ..
16882 *
16883 * Purpose
16884 * =======
16885 * CTESTAMX: Test complex AMX COMBINE
16886 *
16887 * Arguments
16888 * =========
16889 * OUTNUM (input) INTEGER
16890 * The device number to write output to.
16891 *
16892 * VERB (input) INTEGER
16893 * The level of verbosity (how much printing to do).
16894 *
16895 * NSCOPE (input) INTEGER
16896 * The number of scopes to be tested.
16897 *
16898 * SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE)
16899 * Values of the scopes to be tested.
16900 *
16901 * NTOP (input) INTEGER
16902 * The number of topologies to be tested.
16903 *
16904 * TOP0 (input) CHARACTER*1 array of dimension (NTOP)
16905 * Values of the topologies to be tested.
16906 *
16907 * NMAT (input) INTEGER
16908 * The number of matrices to be tested.
16909 *
16910 * M0 (input) INTEGER array of dimension (NMAT)
16911 * Values of M to be tested.
16912 *
16913 * M0 (input) INTEGER array of dimension (NMAT)
16914 * Values of M to be tested.
16915 *
16916 * N0 (input) INTEGER array of dimension (NMAT)
16917 * Values of N to be tested.
16918 *
16919 * LDAS0 (input) INTEGER array of dimension (NMAT)
16920 * Values of LDAS (leading dimension of A on source process)
16921 * to be tested.
16922 *
16923 * LDAD0 (input) INTEGER array of dimension (NMAT)
16924 * Values of LDAD (leading dimension of A on destination
16925 * process) to be tested.
16926 * LDI0 (input) INTEGER array of dimension (NMAT)
16927 * Values of LDI (leading dimension of RA/CA) to be tested.
16928 * If LDI == -1, these RA/CA should not be accessed.
16929 *
16930 * NDEST (input) INTEGER
16931 * The number of destinations to be tested.
16932 *
16933 * RDEST0 (input) INTEGER array of dimension (NNDEST)
16934 * Values of RDEST (row coordinate of destination) to be
16935 * tested.
16936 *
16937 * CDEST0 (input) INTEGER array of dimension (NNDEST)
16938 * Values of CDEST (column coordinate of destination) to be
16939 * tested.
16940 *
16941 * NGRID (input) INTEGER
16942 * The number of process grids to be tested.
16943 *
16944 * CONTEXT0 (input) INTEGER array of dimension (NGRID)
16945 * The BLACS context handles corresponding to the grids.
16946 *
16947 * P0 (input) INTEGER array of dimension (NGRID)
16948 * Values of P (number of process rows, NPROW).
16949 *
16950 * Q0 (input) INTEGER array of dimension (NGRID)
16951 * Values of Q (number of process columns, NPCOL).
16952 *
16953 * ISEED (workspace) INTEGER array of dimension ( MAX(NPROCS, NTESTS) )
16954 * Workspace used to hold each process's random number SEED.
16955 * This requires NPROCS (number of processor) elements.
16956 * If VERB < 2, this workspace also serves to indicate which
16957 * tests fail. This requires workspace of NTESTS
16958 * (number of tests performed).
16959 *
16960 * RMEM (workspace) INTEGER array of dimension (RCLEN)
16961 * Used for all RA arrays, and their pre and post padding.
16962 *
16963 * CMEM (workspace) INTEGER array of dimension (RCLEN)
16964 * Used for all CA arrays, and their pre and post padding.
16965 *
16966 * RCLEN (input) INTEGER
16967 * The length, in elements, of RMEM and CMEM.
16968 *
16969 * MEM (workspace) COMPLEX array of dimension (MEMLEN)
16970 * Used for all other workspaces, including the matrix A,
16971 * and its pre and post padding.
16972 *
16973 * MEMLEN (input) INTEGER
16974 * The length, in elements, of MEM.
16975 *
16976 * =====================================================================
16977 *
16978 * .. External Functions ..
16979  LOGICAL ALLPASS, LSAME
16980  INTEGER IBTMYPROC, IBTNPROCS, IBTSIZEOF
16981  EXTERNAL allpass, lsame, ibtmyproc, ibtnprocs, ibtsizeof
16982 * ..
16983 * .. External Subroutines ..
16984  EXTERNAL blacs_gridinfo, cgamx2d
16985  EXTERNAL cinitmat, cchkpad, cbtcheckin
16986 * ..
16987 * .. Local Scalars ..
16988  CHARACTER*1 SCOPE, TOP
16989  LOGICAL INGRID, TESTOK, ALLRCV
16990  INTEGER APTR, CAPTR, CDEST, CDEST2, CONTEXT, CSIZE, ERRDPTR,
16991  $ ERRIPTR, I, IAM, ICHECKVAL, IDE, IGR, IMA, IPAD, IPOST,
16992  $ ipre, isc, isize, istart, istop, itc, itc1, itc2, ito,
16993  $ itr, itr1, itr2, j, k, lda, ldadst, ldasrc, ldi, m,
16994  $ maxerr, mycol, myrow, n, nerr, nfail, npcol, nprow, nskip,
16995  $ preaptr, raptr, rdest, rdest2, setwhat, testnum, valptr
16996  COMPLEX CHECKVAL
16997 * ..
16998 * .. Executable Statements ..
16999 *
17000 * Choose padding value, and make it unique
17001 *
17002  CHECKVAL = cmplx( -0.91e0, -0.71e0 )
17003  iam = ibtmyproc()
17004  checkval = iam * checkval
17005  isize = ibtsizeof('I')
17006  csize = ibtsizeof('C')
17007  icheckval = -iam
17008 *
17009 * Verify file parameters
17010 *
17011  IF( iam .EQ. 0 ) THEN
17012  WRITE(outnum, *) ' '
17013  WRITE(outnum, *) ' '
17014  WRITE(outnum, 1000 )
17015  IF( verb .GT. 0 ) THEN
17016  WRITE(outnum,*) ' '
17017  WRITE(outnum, 2000) 'NSCOPE:', nscope
17018  WRITE(outnum, 3000) ' SCOPE:', ( scope0(i), i = 1, nscope )
17019  WRITE(outnum, 2000) 'TReps :', topsrepeat
17020  WRITE(outnum, 2000) 'TCohr :', topscohrnt
17021  WRITE(outnum, 2000) 'NTOP :', ntop
17022  WRITE(outnum, 3000) ' TOP :', ( top0(i), i = 1, ntop )
17023  WRITE(outnum, 2000) 'NMAT :', nmat
17024  WRITE(outnum, 2000) ' M :', ( m0(i), i = 1, nmat )
17025  WRITE(outnum, 2000) ' N :', ( n0(i), i = 1, nmat )
17026  WRITE(outnum, 2000) ' LDAS :', ( ldas0(i), i = 1, nmat )
17027  WRITE(outnum, 2000) ' LDAD :', ( ldad0(i), i = 1, nmat )
17028  WRITE(outnum, 2000) ' LDI :', ( ldi0(i), i = 1, nmat )
17029  WRITE(outnum, 2000) 'NDEST :', ndest
17030  WRITE(outnum, 2000) ' RDEST:',( rdest0(i), i = 1, ndest )
17031  WRITE(outnum, 2000) ' CDEST:',( cdest0(i), i = 1, ndest )
17032  WRITE(outnum, 2000) 'NGRIDS:', ngrid
17033  WRITE(outnum, 2000) ' P :', ( p0(i), i = 1, ngrid )
17034  WRITE(outnum, 2000) ' Q :', ( q0(i), i = 1, ngrid )
17035  WRITE(outnum, 2000) 'VERB :', verb
17036  WRITE(outnum,*) ' '
17037  END IF
17038  IF( verb .GT. 1 ) THEN
17039  WRITE(outnum,4000)
17040  WRITE(outnum,5000)
17041  END IF
17042  END IF
17043  IF (topsrepeat.EQ.0) THEN
17044  itr1 = 0
17045  itr2 = 0
17046  ELSE IF (topsrepeat.EQ.1) THEN
17047  itr1 = 1
17048  itr2 = 1
17049  ELSE
17050  itr1 = 0
17051  itr2 = 1
17052  END IF
17053 *
17054 * Find biggest matrix, so we know where to stick error info
17055 *
17056  i = 0
17057  DO 10 ima = 1, nmat
17058  ipad = 4 * m0(ima)
17059  k = n0(ima) * max0( ldas0(ima), ldad0(ima) ) + ipad
17060  IF( k .GT. i ) i = k
17061  10 CONTINUE
17062  i = i + ibtnprocs()
17063  maxerr = ( csize * (memlen-i) ) / ( csize*2 + isize*6 )
17064  IF( maxerr .LT. 1 ) THEN
17065  WRITE(outnum,*) 'ERROR: Not enough memory to run MAX tests.'
17066  CALL blacs_abort(-1, 1)
17067  END IF
17068  errdptr = i + 1
17069  erriptr = errdptr + maxerr
17070  nerr = 0
17071  testnum = 0
17072  nfail = 0
17073  nskip = 0
17074 *
17075 * Loop over grids of matrix
17076 *
17077  DO 90 igr = 1, ngrid
17078 *
17079 * allocate process grid for the next batch of tests
17080 *
17081  context = context0(igr)
17082  CALL blacs_gridinfo( context, nprow, npcol, myrow, mycol )
17083  ingrid = ( (myrow.LT.nprow) .AND. (mycol.LT.npcol) )
17084 *
17085  DO 80 isc = 1, nscope
17086  scope = scope0(isc)
17087  DO 70 ito = 1, ntop
17088  top = top0(ito)
17089 *
17090 * If testing multiring ('M') or general tree ('T'), need to
17091 * loop over calls to BLACS_SET to do full test
17092 *
17093  IF( lsame(top, 'M') ) THEN
17094  setwhat = 13
17095  IF( scope .EQ. 'R' ) THEN
17096  istart = -(npcol - 1)
17097  istop = -istart
17098  ELSE IF (scope .EQ. 'C') THEN
17099  istart = -(nprow - 1)
17100  istop = -istart
17101  ELSE
17102  istart = -(nprow*npcol - 1)
17103  istop = -istart
17104  ENDIF
17105  ELSE IF( lsame(top, 'T') ) THEN
17106  setwhat = 14
17107  istart = 1
17108  IF( scope .EQ. 'R' ) THEN
17109  istop = npcol - 1
17110  ELSE IF (scope .EQ. 'C') THEN
17111  istop = nprow - 1
17112  ELSE
17113  istop = nprow*npcol - 1
17114  ENDIF
17115  ELSE
17116  setwhat = 0
17117  istart = 1
17118  istop = 1
17119  ENDIF
17120  DO 60 ima = 1, nmat
17121  m = m0(ima)
17122  n = n0(ima)
17123  ldasrc = ldas0(ima)
17124  ldadst = ldad0(ima)
17125  ldi = ldi0(ima)
17126  ipre = 2 * m
17127  ipost = ipre
17128  preaptr = 1
17129  aptr = preaptr + ipre
17130 *
17131  DO 50 ide = 1, ndest
17132  testnum = testnum + 1
17133  rdest2 = rdest0(ide)
17134  cdest2 = cdest0(ide)
17135 *
17136 * If everyone gets the answer, create some bogus rdest/cdest
17137 * so IF's are easier
17138 *
17139  allrcv = ( (rdest2.EQ.-1) .OR. (cdest2.EQ.-1) )
17140  IF( allrcv ) THEN
17141  rdest = nprow - 1
17142  cdest = npcol - 1
17143  IF (topscohrnt.EQ.0) THEN
17144  itr1 = 0
17145  itr2 = 0
17146  ELSE IF (topscohrnt.EQ.1) THEN
17147  itr1 = 1
17148  itr2 = 1
17149  ELSE
17150  itr1 = 0
17151  itr2 = 1
17152  END IF
17153  ELSE
17154  rdest = rdest2
17155  cdest = cdest2
17156  itc1 = 0
17157  itc2 = 0
17158  END IF
17159  IF( rdest.GE.p0(igr) .OR. cdest.GE.q0(igr) ) THEN
17160  nskip = nskip + 1
17161  GOTO 50
17162  END IF
17163 *
17164  IF( myrow.EQ.rdest .AND. mycol.EQ.cdest ) THEN
17165  lda = ldadst
17166  ELSE
17167  lda = ldasrc
17168  END IF
17169  valptr = aptr + ipost + n * lda
17170  IF( verb .GT. 1 ) THEN
17171  IF( iam .EQ. 0 ) THEN
17172  WRITE(outnum, 6000)
17173  $ testnum, 'RUNNING', scope, top, m, n,
17174  $ ldasrc, ldadst, ldi, rdest2, cdest2,
17175  $ nprow, npcol
17176  END IF
17177  END IF
17178 *
17179 * If I am in scope
17180 *
17181  testok = .true.
17182  IF( ingrid ) THEN
17183  IF( (myrow.EQ.rdest .AND. scope.EQ.'R') .OR.
17184  $ (mycol.EQ.cdest .AND. scope.EQ.'C') .OR.
17185  $ (scope .EQ. 'A') ) THEN
17186 *
17187  k = nerr
17188  DO 40 itr = itr1, itr2
17189  CALL blacs_set(context, 15, itr)
17190  DO 35 itc = itc1, itc2
17191  CALL blacs_set(context, 16, itc)
17192  DO 30 j = istart, istop
17193  IF( j.EQ.0) GOTO 30
17194  IF( setwhat.NE.0 )
17195  $ CALL blacs_set(context, setwhat, j)
17196 *
17197 *
17198 * generate and pad matrix A
17199 *
17200  CALL cinitmat('G','-', m, n, mem(preaptr),
17201  $ lda, ipre, ipost,
17202  $ checkval, testnum,
17203  $ myrow, mycol )
17204 *
17205 * If they exist, pad RA and CA arrays
17206 *
17207  IF( ldi .NE. -1 ) THEN
17208  DO 15 i = 1, n*ldi + ipre + ipost
17209  rmem(i) = icheckval
17210  cmem(i) = icheckval
17211  15 CONTINUE
17212  raptr = 1 + ipre
17213  captr = 1 + ipre
17214  ELSE
17215  DO 20 i = 1, ipre+ipost
17216  rmem(i) = icheckval
17217  cmem(i) = icheckval
17218  20 CONTINUE
17219  raptr = 1
17220  captr = 1
17221  END IF
17222 *
17223  CALL cgamx2d(context, scope, top, m, n,
17224  $ mem(aptr), lda, rmem(raptr),
17225  $ cmem(captr), ldi,
17226  $ rdest2, cdest2)
17227 *
17228 * If I've got the answer, check for errors in
17229 * matrix or padding
17230 *
17231  IF( (myrow.EQ.rdest .AND. mycol.EQ.cdest)
17232  $ .OR. allrcv ) THEN
17233  CALL cchkpad('G','-', m, n,
17234  $ mem(preaptr), lda, rdest,
17235  $ cdest, myrow, mycol,
17236  $ ipre, ipost, checkval,
17237  $ testnum, maxerr, nerr,
17238  $ mem(erriptr),mem(errdptr))
17239  CALL cchkamx(scope, context, m, n,
17240  $ mem(aptr), lda,
17241  $ rmem(raptr), cmem(captr),
17242  $ ldi, testnum, maxerr,nerr,
17243  $ mem(erriptr),mem(errdptr),
17244  $ iseed, mem(valptr))
17245  CALL crcchk(ipre, ipost, icheckval,
17246  $ m, n, rmem, cmem, ldi,
17247  $ myrow, mycol, testnum,
17248  $ maxerr, nerr,
17249  $ mem(erriptr), mem(errdptr))
17250  END IF
17251  30 CONTINUE
17252  CALL blacs_set(context, 16, 0)
17253  35 CONTINUE
17254  CALL blacs_set(context, 15, 0)
17255  40 CONTINUE
17256  testok = ( k .EQ. nerr )
17257  END IF
17258  END IF
17259 *
17260  IF( verb .GT. 1 ) THEN
17261  i = nerr
17262  CALL cbtcheckin(0, outnum, maxerr, nerr,
17263  $ mem(erriptr), mem(errdptr), iseed)
17264  IF( iam .EQ. 0 ) THEN
17265  IF( testok .AND. nerr.EQ.i ) THEN
17266  WRITE(outnum,6000)testnum,'PASSED ',
17267  $ scope, top, m, n, ldasrc,
17268  $ ldadst, ldi, rdest2, cdest2,
17269  $ nprow, npcol
17270  ELSE
17271  nfail = nfail + 1
17272  WRITE(outnum,6000)testnum,'FAILED ',
17273  $ scope, top, m, n, ldasrc,
17274  $ ldadst, ldi, rdest2, cdest2,
17275  $ nprow, npcol
17276  END IF
17277  END IF
17278 *
17279 * Once we've printed out errors, can re-use buf space
17280 *
17281  nerr = 0
17282  END IF
17283  50 CONTINUE
17284  60 CONTINUE
17285  70 CONTINUE
17286  80 CONTINUE
17287  90 CONTINUE
17288 *
17289  IF( verb .LT. 2 ) THEN
17290  nfail = testnum
17291  CALL cbtcheckin( nfail, outnum, maxerr, nerr, mem(erriptr),
17292  $ mem(errdptr), iseed )
17293  END IF
17294  IF( iam .EQ. 0 ) THEN
17295  IF( verb .GT. 1 ) WRITE(outnum,*) ' '
17296  IF( nfail+nskip .EQ. 0 ) THEN
17297  WRITE(outnum, 7000 ) testnum
17298  ELSE
17299  WRITE(outnum, 8000 ) testnum, testnum-nskip-nfail,
17300  $ nskip, nfail
17301  END IF
17302  END IF
17303 *
17304 * Log whether their were any failures
17305 *
17306  testok = allpass( (nfail.EQ.0) )
17307 *
17308  1000 FORMAT('COMPLEX AMX TESTS: BEGIN.' )
17309  2000 FORMAT(1x,a7,3x,10i6)
17310  3000 FORMAT(1x,a7,3x,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,
17311  $ 5x,a1,5x,a1)
17312  4000 FORMAT(' TEST# STATUS SCOPE TOP M N LDAS LDAD LDI ',
17313  $ 'RDEST CDEST P Q')
17314  5000 FORMAT(' ----- ------- ----- --- ----- ----- ----- ----- ----- ',
17315  $ '----- ----- ---- ----')
17316  6000 FORMAT(i6,1x,a7,5x,a1,3x,a1,7i6,2i5)
17317  7000 FORMAT('COMPLEX AMX TESTS: PASSED ALL',
17318  $ i5, ' TESTS.')
17319  8000 FORMAT('COMPLEX AMX TESTS:',i5,' TESTS;',i5,' PASSED,',
17320  $ i5,' SKIPPED,',i5,' FAILED.')
17321 *
17322  RETURN
17323 *
17324 * End of CTESTAMX.
17325 *
17326  END
17327 *
17328  SUBROUTINE crcchk( IPRE, IPOST, PADVAL, M, N, RA, CA, LDI, MYROW,
17329  $ MYCOL, TESTNUM, MAXERR, NERR,
17330  $ ERRIBUF, ERRDBUF )
17331 *
17332 * .. Scalar Arguments ..
17333  INTEGER IPRE, IPOST, PADVAL, M, N, LDI, MYROW, MYCOL, TESTNUM
17334  INTEGER MAXERR, NERR
17335 * ..
17336 * .. Array Arguments ..
17337  INTEGER RA(*), CA(*), ERRIBUF(6, MAXERR)
17338  COMPLEX ERRDBUF(2, MAXERR)
17339 * ..
17340 * .. Parameters ..
17341  INTEGER ERR_PRE, ERR_POST, ERR_GAP, ERR_TRI, ERR_MAT
17342  PARAMETER( ERR_PRE = 1, err_post = 2, err_gap = 3, err_tri = 4 )
17343  parameter( err_mat = 5 )
17344 * ..
17345 * .. External Functions ..
17346  INTEGER IBTNPROCS
17347  EXTERNAL ibtnprocs
17348 * ..
17349 * .. Local Scalars ..
17350  INTEGER I, J, K, IAM
17351 * ..
17352 * .. Executable Statements ..
17353 *
17354  iam = myrow * ibtnprocs() + mycol
17355 *
17356 * Check pre padding
17357 *
17358  IF( ldi .NE. -1 ) THEN
17359  IF( ipre .GT. 0 ) THEN
17360  DO 10 i = 1, ipre
17361  IF( ra(i) .NE. padval ) THEN
17362  nerr = nerr + 1
17363  IF( nerr .LE. maxerr ) THEN
17364  erribuf(1, nerr) = testnum
17365  erribuf(2, nerr) = ldi
17366  erribuf(3, nerr) = iam
17367  erribuf(4, nerr) = i
17368  erribuf(5, nerr) = ipre - i + 1
17369  erribuf(6, nerr) = -err_pre
17370  errdbuf(1, nerr) = cmplx( ra(i) )
17371  errdbuf(2, nerr) = cmplx( padval )
17372  END IF
17373  ENDIF
17374  IF( ca(i) .NE. padval ) THEN
17375  nerr = nerr + 1
17376  IF( nerr .LE. maxerr ) THEN
17377  erribuf(1, nerr) = testnum
17378  erribuf(2, nerr) = ldi
17379  erribuf(3, nerr) = iam
17380  erribuf(4, nerr) = i
17381  erribuf(5, nerr) = ipre - i + 1
17382  erribuf(6, nerr) = -10 - err_pre
17383  errdbuf(1, nerr) = cmplx( ca(i) )
17384  errdbuf(2, nerr) = cmplx( padval )
17385  END IF
17386  ENDIF
17387  10 CONTINUE
17388  END IF
17389 *
17390 * Check post padding
17391 *
17392  IF( ipost .GT. 0 ) THEN
17393  k = ipre + ldi*n
17394  DO 20 i = k+1, k+ipost
17395  IF( ra(i) .NE. padval ) THEN
17396  nerr = nerr + 1
17397  IF( nerr .LE. maxerr ) THEN
17398  erribuf(1, nerr) = testnum
17399  erribuf(2, nerr) = ldi
17400  erribuf(3, nerr) = iam
17401  erribuf(4, nerr) = i - k
17402  erribuf(5, nerr) = i
17403  erribuf(6, nerr) = -err_post
17404  errdbuf(1, nerr) = cmplx( ra(i) )
17405  errdbuf(2, nerr) = cmplx( padval )
17406  END IF
17407  ENDIF
17408  IF( ca(i) .NE. padval ) THEN
17409  nerr = nerr + 1
17410  IF( nerr .LE. maxerr ) THEN
17411  erribuf(1, nerr) = testnum
17412  erribuf(2, nerr) = ldi
17413  erribuf(3, nerr) = iam
17414  erribuf(4, nerr) = i - k
17415  erribuf(5, nerr) = i
17416  erribuf(6, nerr) = -10 - err_post
17417  errdbuf(1, nerr) = cmplx( ca(i) )
17418  errdbuf(2, nerr) = cmplx( padval )
17419  END IF
17420  ENDIF
17421  20 CONTINUE
17422  END IF
17423 *
17424 * Check all (LDI-M) gaps
17425 *
17426  IF( ldi .GT. m ) THEN
17427  k = ipre + m + 1
17428  DO 40 j = 1, n
17429  DO 30 i = m+1, ldi
17430  k = ipre + (j-1)*ldi + i
17431  IF( ra(k) .NE. padval) THEN
17432  nerr = nerr + 1
17433  IF( nerr .LE. maxerr ) THEN
17434  erribuf(1, nerr) = testnum
17435  erribuf(2, nerr) = ldi
17436  erribuf(3, nerr) = iam
17437  erribuf(4, nerr) = i
17438  erribuf(5, nerr) = j
17439  erribuf(6, nerr) = -err_gap
17440  errdbuf(1, nerr) = cmplx( ra(k) )
17441  errdbuf(2, nerr) = cmplx( padval )
17442  END IF
17443  END IF
17444  IF( ca(k) .NE. padval) THEN
17445  nerr = nerr + 1
17446  IF( nerr .LE. maxerr ) THEN
17447  erribuf(1, nerr) = testnum
17448  erribuf(2, nerr) = ldi
17449  erribuf(3, nerr) = iam
17450  erribuf(4, nerr) = i
17451  erribuf(5, nerr) = j
17452  erribuf(6, nerr) = -10 - err_gap
17453  errdbuf(1, nerr) = cmplx( ca(k) )
17454  errdbuf(2, nerr) = cmplx( padval )
17455  END IF
17456  END IF
17457  30 CONTINUE
17458  40 CONTINUE
17459  END IF
17460 *
17461 * if RA and CA don't exist, buffs better be untouched
17462 *
17463  ELSE
17464  DO 50 i = 1, ipre+ipost
17465  IF( ra(i) .NE. padval) THEN
17466  nerr = nerr + 1
17467  IF( nerr .LE. maxerr ) THEN
17468  erribuf(1, nerr) = testnum
17469  erribuf(2, nerr) = ldi
17470  erribuf(3, nerr) = iam
17471  erribuf(4, nerr) = i
17472  erribuf(5, nerr) = ipre+ipost
17473  erribuf(6, nerr) = -err_pre
17474  errdbuf(1, nerr) = cmplx( ra(i) )
17475  errdbuf(2, nerr) = cmplx( padval )
17476  END IF
17477  END IF
17478  IF( ca(i) .NE. padval) THEN
17479  nerr = nerr + 1
17480  IF( nerr .LE. maxerr ) THEN
17481  erribuf(1, nerr) = testnum
17482  erribuf(2, nerr) = ldi
17483  erribuf(3, nerr) = iam
17484  erribuf(4, nerr) = i
17485  erribuf(5, nerr) = ipre+ipost
17486  erribuf(6, nerr) = -10 - err_pre
17487  errdbuf(1, nerr) = cmplx( ca(i) )
17488  errdbuf(2, nerr) = cmplx( padval )
17489  END IF
17490  END IF
17491  50 CONTINUE
17492  ENDIF
17493 *
17494  RETURN
17495  END
17496 *
17497  SUBROUTINE cchkamx( SCOPE, ICTXT, M, N, A, LDA, RA, CA, LDI,
17498  $ TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF,
17499  $ ISEED, VALS )
17500 *
17501 * .. Scalar Arguments ..
17502  CHARACTER*1 SCOPE
17503  INTEGER ICTXT, M, N, LDA, LDI, TESTNUM, MAXERR, NERR
17504 * ..
17505 * .. Array Arguments ..
17506  INTEGER RA(*), CA(*), ERRIBUF(6, MAXERR), ISEED(*)
17507  COMPLEX A(LDA,*), ERRDBUF(2, MAXERR), VALS(*)
17508 * ..
17509 * .. External Functions ..
17510  INTEGER IBTMYPROC, IBTNPROCS, IBTSPNUM
17511  REAL SBTEPS, CBTABS
17512  COMPLEX CBTRAN
17513  EXTERNAL ibtmyproc, ibtnprocs, ibtspnum, cbtran, sbteps, cbtabs
17514 * ..
17515 * .. External Subroutines ..
17516  EXTERNAL ibtspcoord
17517 * ..
17518 * .. Local Scalars ..
17519  LOGICAL ERROR
17520  INTEGER NPROCS, NNODES, NPROW, NPCOL, MYROW, MYCOL, RAMX, CAMX
17521  INTEGER IAMX, I, J, K, H, DEST, NODE
17522  REAL EPS
17523 * ..
17524 * .. Executable Statements ..
17525 *
17526  nprocs = ibtnprocs()
17527  eps = sbteps()
17528  CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
17529  dest = myrow*nprocs + mycol
17530 *
17531 * Set up seeds to match those used by each proc's genmat call
17532 *
17533  IF( scope .EQ. 'R' ) THEN
17534  nnodes = npcol
17535  DO 10 i = 0, nnodes-1
17536  node = myrow * nprocs + i
17537  iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
17538  iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
17539  iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
17540  iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
17541  10 CONTINUE
17542  ELSE IF( scope .EQ. 'C' ) THEN
17543  nnodes = nprow
17544  DO 20 i = 0, nnodes-1
17545  node = i * nprocs + mycol
17546  iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
17547  iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
17548  iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
17549  iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
17550  20 CONTINUE
17551  ELSE
17552  nnodes = nprow * npcol
17553  DO 30 i = 0, nnodes-1
17554  node = (i / npcol) * nprocs + mod(i, npcol)
17555  iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
17556  iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
17557  iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
17558  iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
17559  30 CONTINUE
17560  END IF
17561 *
17562  DO 100 j = 1, n
17563  DO 90 i = 1, m
17564  h = (j-1)*ldi + i
17565  vals(1) = cbtran( iseed )
17566  iamx = 1
17567  IF( nnodes .GT. 1 ) THEN
17568  DO 40 k = 1, nnodes-1
17569  vals(k+1) = cbtran( iseed(k*4+1) )
17570  IF( cbtabs( vals(k+1) ) .GT. cbtabs( vals(iamx) ) )
17571  $ iamx = k + 1
17572  40 CONTINUE
17573  END IF
17574 *
17575 * If BLACS have not returned same value we've chosen
17576 *
17577  IF( a(i,j) .NE. vals(iamx) ) THEN
17578 *
17579 * If we have RA and CA arrays
17580 *
17581  IF( ldi .NE. -1 ) THEN
17582 *
17583 * Any number having the same absolute value is a valid max
17584 *
17585  k = ibtspnum( scope, ra(h), ca(h), npcol ) + 1
17586  IF( k.GT.0 .AND. k.LE.nnodes ) THEN
17587  error = abs( cbtabs(vals(k)) - cbtabs(vals(iamx)) )
17588  $ .GT. 3*eps
17589  IF( .NOT.error ) iamx = k
17590  ELSE
17591  error = .true.
17592  END IF
17593  ELSE
17594 *
17595 * Error if BLACS answer not same absolute value, or if it
17596 * was not really in the numbers being compared
17597 *
17598  error = abs( cbtabs(a(i,j)) - cbtabs(vals(iamx)) )
17599  $ .GT. 3*eps
17600  IF( .NOT.error ) THEN
17601  DO 50 k = 1, nnodes
17602  IF( vals(k) .EQ. a(i,j) ) GOTO 60
17603  50 CONTINUE
17604  error = .true.
17605  60 CONTINUE
17606  ENDIF
17607  END IF
17608 *
17609 * If the value is in error
17610 *
17611  IF( error ) THEN
17612  nerr = nerr + 1
17613  erribuf(1, nerr) = testnum
17614  erribuf(2, nerr) = nnodes
17615  erribuf(3, nerr) = dest
17616  erribuf(4, nerr) = i
17617  erribuf(5, nerr) = j
17618  erribuf(6, nerr) = 5
17619  errdbuf(1, nerr) = a(i,j)
17620  errdbuf(2, nerr) = vals(iamx)
17621  END IF
17622  END IF
17623 *
17624 * If they are defined, make sure coordinate entries are OK
17625 *
17626  IF( ldi .NE. -1 ) THEN
17627  k = ibtspnum( scope, ra(h), ca(h), npcol ) + 1
17628  IF( k.NE.iamx ) THEN
17629 *
17630 * Make sure more than one proc doesn't have exact same value
17631 * (and therefore there may be more than one valid coordinate
17632 * for a single value)
17633 *
17634  IF( k.GT.nnodes .OR. k.LT.1 ) THEN
17635  error = .true.
17636  ELSE
17637  error = ( vals(k) .NE. vals(iamx) )
17638  END IF
17639  IF( error ) THEN
17640  CALL ibtspcoord( scope, iamx-1, myrow, mycol,
17641  $ npcol, ramx, camx )
17642  IF( ramx .NE. ra(h) ) THEN
17643  nerr = nerr + 1
17644  erribuf(1, nerr) = testnum
17645  erribuf(2, nerr) = nnodes
17646  erribuf(3, nerr) = dest
17647  erribuf(4, nerr) = i
17648  erribuf(5, nerr) = j
17649  erribuf(6, nerr) = -5
17650  errdbuf(1, nerr) = ra(h)
17651  errdbuf(2, nerr) = ramx
17652  END IF
17653  IF( camx .NE. ca(h) ) THEN
17654  nerr = nerr + 1
17655  erribuf(1, nerr) = testnum
17656  erribuf(2, nerr) = nnodes
17657  erribuf(3, nerr) = dest
17658  erribuf(4, nerr) = i
17659  erribuf(5, nerr) = j
17660  erribuf(6, nerr) = -15
17661  errdbuf(1, nerr) = ca(h)
17662  errdbuf(2, nerr) = camx
17663  END IF
17664  END IF
17665  END IF
17666  END IF
17667  90 CONTINUE
17668  100 CONTINUE
17669 *
17670  RETURN
17671 *
17672 * End of CCHKAMX
17673 *
17674  END
17675 *
17676 *
17677  SUBROUTINE zamxtest( OUTNUM, VERB, TOPSREPEAT, TOPSCOHRNT, NSCOPE,
17678  $ SCOPE0, NTOP, TOP0, NMAT, M0, N0, LDAS0,
17679  $ LDAD0, LDI0, NDEST, RDEST0, CDEST0, NGRID,
17680  $ CONTEXT0, P0, Q0, ISEED, RMEM, CMEM, RCLEN,
17681  $ MEM, MEMLEN )
17682 *
17683 * -- BLACS tester (version 1.0) --
17684 * University of Tennessee
17685 * December 15, 1994
17686 *
17687 *
17688 * .. Scalar Arguments ..
17689  INTEGER MEMLEN, NDEST, NGRID, NMAT, NSCOPE, NTOP, OUTNUM, RCLEN,
17690  $ topscohrnt, topsrepeat, verb
17691 * ..
17692 * .. Array Arguments ..
17693  CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP)
17694  INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT), LDI0(NMAT)
17695  INTEGER RDEST0(NDEST), CDEST0(NDEST), CONTEXT0(NGRID)
17696  INTEGER P0(NGRID), Q0(NGRID), ISEED(*), RMEM(RCLEN), CMEM(RCLEN)
17697  DOUBLE COMPLEX MEM(MEMLEN)
17698 * ..
17699 *
17700 * Purpose
17701 * =======
17702 * ZTESTAMX: Test double complex AMX COMBINE
17703 *
17704 * Arguments
17705 * =========
17706 * OUTNUM (input) INTEGER
17707 * The device number to write output to.
17708 *
17709 * VERB (input) INTEGER
17710 * The level of verbosity (how much printing to do).
17711 *
17712 * NSCOPE (input) INTEGER
17713 * The number of scopes to be tested.
17714 *
17715 * SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE)
17716 * Values of the scopes to be tested.
17717 *
17718 * NTOP (input) INTEGER
17719 * The number of topologies to be tested.
17720 *
17721 * TOP0 (input) CHARACTER*1 array of dimension (NTOP)
17722 * Values of the topologies to be tested.
17723 *
17724 * NMAT (input) INTEGER
17725 * The number of matrices to be tested.
17726 *
17727 * M0 (input) INTEGER array of dimension (NMAT)
17728 * Values of M to be tested.
17729 *
17730 * M0 (input) INTEGER array of dimension (NMAT)
17731 * Values of M to be tested.
17732 *
17733 * N0 (input) INTEGER array of dimension (NMAT)
17734 * Values of N to be tested.
17735 *
17736 * LDAS0 (input) INTEGER array of dimension (NMAT)
17737 * Values of LDAS (leading dimension of A on source process)
17738 * to be tested.
17739 *
17740 * LDAD0 (input) INTEGER array of dimension (NMAT)
17741 * Values of LDAD (leading dimension of A on destination
17742 * process) to be tested.
17743 * LDI0 (input) INTEGER array of dimension (NMAT)
17744 * Values of LDI (leading dimension of RA/CA) to be tested.
17745 * If LDI == -1, these RA/CA should not be accessed.
17746 *
17747 * NDEST (input) INTEGER
17748 * The number of destinations to be tested.
17749 *
17750 * RDEST0 (input) INTEGER array of dimension (NNDEST)
17751 * Values of RDEST (row coordinate of destination) to be
17752 * tested.
17753 *
17754 * CDEST0 (input) INTEGER array of dimension (NNDEST)
17755 * Values of CDEST (column coordinate of destination) to be
17756 * tested.
17757 *
17758 * NGRID (input) INTEGER
17759 * The number of process grids to be tested.
17760 *
17761 * CONTEXT0 (input) INTEGER array of dimension (NGRID)
17762 * The BLACS context handles corresponding to the grids.
17763 *
17764 * P0 (input) INTEGER array of dimension (NGRID)
17765 * Values of P (number of process rows, NPROW).
17766 *
17767 * Q0 (input) INTEGER array of dimension (NGRID)
17768 * Values of Q (number of process columns, NPCOL).
17769 *
17770 * ISEED (workspace) INTEGER array of dimension ( MAX(NPROCS, NTESTS) )
17771 * Workspace used to hold each process's random number SEED.
17772 * This requires NPROCS (number of processor) elements.
17773 * If VERB < 2, this workspace also serves to indicate which
17774 * tests fail. This requires workspace of NTESTS
17775 * (number of tests performed).
17776 *
17777 * RMEM (workspace) INTEGER array of dimension (RCLEN)
17778 * Used for all RA arrays, and their pre and post padding.
17779 *
17780 * CMEM (workspace) INTEGER array of dimension (RCLEN)
17781 * Used for all CA arrays, and their pre and post padding.
17782 *
17783 * RCLEN (input) INTEGER
17784 * The length, in elements, of RMEM and CMEM.
17785 *
17786 * MEM (workspace) DOUBLE COMPLEX array of dimension (MEMLEN)
17787 * Used for all other workspaces, including the matrix A,
17788 * and its pre and post padding.
17789 *
17790 * MEMLEN (input) INTEGER
17791 * The length, in elements, of MEM.
17792 *
17793 * =====================================================================
17794 *
17795 * .. External Functions ..
17796  LOGICAL ALLPASS, LSAME
17797  INTEGER IBTMYPROC, IBTNPROCS, IBTSIZEOF
17798  EXTERNAL allpass, lsame, ibtmyproc, ibtnprocs, ibtsizeof
17799 * ..
17800 * .. External Subroutines ..
17801  EXTERNAL blacs_gridinfo, zgamx2d
17802  EXTERNAL zinitmat, zchkpad, zbtcheckin
17803 * ..
17804 * .. Local Scalars ..
17805  CHARACTER*1 SCOPE, TOP
17806  LOGICAL INGRID, TESTOK, ALLRCV
17807  INTEGER APTR, CAPTR, CDEST, CDEST2, CONTEXT, ERRDPTR, ERRIPTR, I,
17808  $ iam, icheckval, ide, igr, ima, ipad, ipost, ipre, isc,
17809  $ isize, istart, istop, itc, itc1, itc2, ito, itr, itr1,
17810  $ itr2, j, k, lda, ldadst, ldasrc, ldi, m, maxerr, mycol,
17811  $ myrow, n, nerr, nfail, npcol, nprow, nskip, preaptr,
17812  $ raptr, rdest, rdest2, setwhat, testnum, valptr, zsize
17813  DOUBLE COMPLEX CHECKVAL
17814 * ..
17815 * .. Executable Statements ..
17816 *
17817 * Choose padding value, and make it unique
17818 *
17819  checkval = dcmplx( -9.11d0, -9.21d0 )
17820  iam = ibtmyproc()
17821  checkval = iam * checkval
17822  isize = ibtsizeof('I')
17823  zsize = ibtsizeof('Z')
17824  icheckval = -iam
17825 *
17826 * Verify file parameters
17827 *
17828  IF( iam .EQ. 0 ) THEN
17829  WRITE(outnum, *) ' '
17830  WRITE(outnum, *) ' '
17831  WRITE(outnum, 1000 )
17832  IF( verb .GT. 0 ) THEN
17833  WRITE(outnum,*) ' '
17834  WRITE(outnum, 2000) 'NSCOPE:', nscope
17835  WRITE(outnum, 3000) ' SCOPE:', ( scope0(i), i = 1, nscope )
17836  WRITE(outnum, 2000) 'TReps :', topsrepeat
17837  WRITE(outnum, 2000) 'TCohr :', topscohrnt
17838  WRITE(outnum, 2000) 'NTOP :', ntop
17839  WRITE(outnum, 3000) ' TOP :', ( top0(i), i = 1, ntop )
17840  WRITE(outnum, 2000) 'NMAT :', nmat
17841  WRITE(outnum, 2000) ' M :', ( m0(i), i = 1, nmat )
17842  WRITE(outnum, 2000) ' N :', ( n0(i), i = 1, nmat )
17843  WRITE(outnum, 2000) ' LDAS :', ( ldas0(i), i = 1, nmat )
17844  WRITE(outnum, 2000) ' LDAD :', ( ldad0(i), i = 1, nmat )
17845  WRITE(outnum, 2000) ' LDI :', ( ldi0(i), i = 1, nmat )
17846  WRITE(outnum, 2000) 'NDEST :', ndest
17847  WRITE(outnum, 2000) ' RDEST:',( rdest0(i), i = 1, ndest )
17848  WRITE(outnum, 2000) ' CDEST:',( cdest0(i), i = 1, ndest )
17849  WRITE(outnum, 2000) 'NGRIDS:', ngrid
17850  WRITE(outnum, 2000) ' P :', ( p0(i), i = 1, ngrid )
17851  WRITE(outnum, 2000) ' Q :', ( q0(i), i = 1, ngrid )
17852  WRITE(outnum, 2000) 'VERB :', verb
17853  WRITE(outnum,*) ' '
17854  END IF
17855  IF( verb .GT. 1 ) THEN
17856  WRITE(outnum,4000)
17857  WRITE(outnum,5000)
17858  END IF
17859  END IF
17860  IF (topsrepeat.EQ.0) THEN
17861  itr1 = 0
17862  itr2 = 0
17863  ELSE IF (topsrepeat.EQ.1) THEN
17864  itr1 = 1
17865  itr2 = 1
17866  ELSE
17867  itr1 = 0
17868  itr2 = 1
17869  END IF
17870 *
17871 * Find biggest matrix, so we know where to stick error info
17872 *
17873  i = 0
17874  DO 10 ima = 1, nmat
17875  ipad = 4 * m0(ima)
17876  k = n0(ima) * max0( ldas0(ima), ldad0(ima) ) + ipad
17877  IF( k .GT. i ) i = k
17878  10 CONTINUE
17879  i = i + ibtnprocs()
17880  maxerr = ( zsize * (memlen-i) ) / ( zsize*2 + isize*6 )
17881  IF( maxerr .LT. 1 ) THEN
17882  WRITE(outnum,*) 'ERROR: Not enough memory to run MAX tests.'
17883  CALL blacs_abort(-1, 1)
17884  END IF
17885  errdptr = i + 1
17886  erriptr = errdptr + maxerr
17887  nerr = 0
17888  testnum = 0
17889  nfail = 0
17890  nskip = 0
17891 *
17892 * Loop over grids of matrix
17893 *
17894  DO 90 igr = 1, ngrid
17895 *
17896 * allocate process grid for the next batch of tests
17897 *
17898  context = context0(igr)
17899  CALL blacs_gridinfo( context, nprow, npcol, myrow, mycol )
17900  ingrid = ( (myrow.LT.nprow) .AND. (mycol.LT.npcol) )
17901 *
17902  DO 80 isc = 1, nscope
17903  scope = scope0(isc)
17904  DO 70 ito = 1, ntop
17905  top = top0(ito)
17906 *
17907 * If testing multiring ('M') or general tree ('T'), need to
17908 * loop over calls to BLACS_SET to do full test
17909 *
17910  IF( lsame(top, 'M') ) THEN
17911  setwhat = 13
17912  IF( scope .EQ. 'R' ) THEN
17913  istart = -(npcol - 1)
17914  istop = -istart
17915  ELSE IF (scope .EQ. 'C') THEN
17916  istart = -(nprow - 1)
17917  istop = -istart
17918  ELSE
17919  istart = -(nprow*npcol - 1)
17920  istop = -istart
17921  ENDIF
17922  ELSE IF( lsame(top, 'T') ) THEN
17923  setwhat = 14
17924  istart = 1
17925  IF( scope .EQ. 'R' ) THEN
17926  istop = npcol - 1
17927  ELSE IF (scope .EQ. 'C') THEN
17928  istop = nprow - 1
17929  ELSE
17930  istop = nprow*npcol - 1
17931  ENDIF
17932  ELSE
17933  setwhat = 0
17934  istart = 1
17935  istop = 1
17936  ENDIF
17937  DO 60 ima = 1, nmat
17938  m = m0(ima)
17939  n = n0(ima)
17940  ldasrc = ldas0(ima)
17941  ldadst = ldad0(ima)
17942  ldi = ldi0(ima)
17943  ipre = 2 * m
17944  ipost = ipre
17945  preaptr = 1
17946  aptr = preaptr + ipre
17947 *
17948  DO 50 ide = 1, ndest
17949  testnum = testnum + 1
17950  rdest2 = rdest0(ide)
17951  cdest2 = cdest0(ide)
17952 *
17953 * If everyone gets the answer, create some bogus rdest/cdest
17954 * so IF's are easier
17955 *
17956  allrcv = ( (rdest2.EQ.-1) .OR. (cdest2.EQ.-1) )
17957  IF( allrcv ) THEN
17958  rdest = nprow - 1
17959  cdest = npcol - 1
17960  IF (topscohrnt.EQ.0) THEN
17961  itr1 = 0
17962  itr2 = 0
17963  ELSE IF (topscohrnt.EQ.1) THEN
17964  itr1 = 1
17965  itr2 = 1
17966  ELSE
17967  itr1 = 0
17968  itr2 = 1
17969  END IF
17970  ELSE
17971  rdest = rdest2
17972  cdest = cdest2
17973  itc1 = 0
17974  itc2 = 0
17975  END IF
17976  IF( rdest.GE.p0(igr) .OR. cdest.GE.q0(igr) ) THEN
17977  nskip = nskip + 1
17978  GOTO 50
17979  END IF
17980 *
17981  IF( myrow.EQ.rdest .AND. mycol.EQ.cdest ) THEN
17982  lda = ldadst
17983  ELSE
17984  lda = ldasrc
17985  END IF
17986  valptr = aptr + ipost + n * lda
17987  IF( verb .GT. 1 ) THEN
17988  IF( iam .EQ. 0 ) THEN
17989  WRITE(outnum, 6000)
17990  $ testnum, 'RUNNING', scope, top, m, n,
17991  $ ldasrc, ldadst, ldi, rdest2, cdest2,
17992  $ nprow, npcol
17993  END IF
17994  END IF
17995 *
17996 * If I am in scope
17997 *
17998  testok = .true.
17999  IF( ingrid ) THEN
18000  IF( (myrow.EQ.rdest .AND. scope.EQ.'R') .OR.
18001  $ (mycol.EQ.cdest .AND. scope.EQ.'C') .OR.
18002  $ (scope .EQ. 'A') ) THEN
18003 *
18004  k = nerr
18005  DO 40 itr = itr1, itr2
18006  CALL blacs_set(context, 15, itr)
18007  DO 35 itc = itc1, itc2
18008  CALL blacs_set(context, 16, itc)
18009  DO 30 j = istart, istop
18010  IF( j.EQ.0) GOTO 30
18011  IF( setwhat.NE.0 )
18012  $ CALL blacs_set(context, setwhat, j)
18013 *
18014 *
18015 * generate and pad matrix A
18016 *
18017  CALL zinitmat('G','-', m, n, mem(preaptr),
18018  $ lda, ipre, ipost,
18019  $ checkval, testnum,
18020  $ myrow, mycol )
18021 *
18022 * If they exist, pad RA and CA arrays
18023 *
18024  IF( ldi .NE. -1 ) THEN
18025  DO 15 i = 1, n*ldi + ipre + ipost
18026  rmem(i) = icheckval
18027  cmem(i) = icheckval
18028  15 CONTINUE
18029  raptr = 1 + ipre
18030  captr = 1 + ipre
18031  ELSE
18032  DO 20 i = 1, ipre+ipost
18033  rmem(i) = icheckval
18034  cmem(i) = icheckval
18035  20 CONTINUE
18036  raptr = 1
18037  captr = 1
18038  END IF
18039 *
18040  CALL zgamx2d(context, scope, top, m, n,
18041  $ mem(aptr), lda, rmem(raptr),
18042  $ cmem(captr), ldi,
18043  $ rdest2, cdest2)
18044 *
18045 * If I've got the answer, check for errors in
18046 * matrix or padding
18047 *
18048  IF( (myrow.EQ.rdest .AND. mycol.EQ.cdest)
18049  $ .OR. allrcv ) THEN
18050  CALL zchkpad('G','-', m, n,
18051  $ mem(preaptr), lda, rdest,
18052  $ cdest, myrow, mycol,
18053  $ ipre, ipost, checkval,
18054  $ testnum, maxerr, nerr,
18055  $ mem(erriptr),mem(errdptr))
18056  CALL zchkamx(scope, context, m, n,
18057  $ mem(aptr), lda,
18058  $ rmem(raptr), cmem(captr),
18059  $ ldi, testnum, maxerr,nerr,
18060  $ mem(erriptr),mem(errdptr),
18061  $ iseed, mem(valptr))
18062  CALL zrcchk(ipre, ipost, icheckval,
18063  $ m, n, rmem, cmem, ldi,
18064  $ myrow, mycol, testnum,
18065  $ maxerr, nerr,
18066  $ mem(erriptr), mem(errdptr))
18067  END IF
18068  30 CONTINUE
18069  CALL blacs_set(context, 16, 0)
18070  35 CONTINUE
18071  CALL blacs_set(context, 15, 0)
18072  40 CONTINUE
18073  testok = ( k .EQ. nerr )
18074  END IF
18075  END IF
18076 *
18077  IF( verb .GT. 1 ) THEN
18078  i = nerr
18079  CALL zbtcheckin(0, outnum, maxerr, nerr,
18080  $ mem(erriptr), mem(errdptr), iseed)
18081  IF( iam .EQ. 0 ) THEN
18082  IF( testok .AND. nerr.EQ.i ) THEN
18083  WRITE(outnum,6000)testnum,'PASSED ',
18084  $ scope, top, m, n, ldasrc,
18085  $ ldadst, ldi, rdest2, cdest2,
18086  $ nprow, npcol
18087  ELSE
18088  nfail = nfail + 1
18089  WRITE(outnum,6000)testnum,'FAILED ',
18090  $ scope, top, m, n, ldasrc,
18091  $ ldadst, ldi, rdest2, cdest2,
18092  $ nprow, npcol
18093  END IF
18094  END IF
18095 *
18096 * Once we've printed out errors, can re-use buf space
18097 *
18098  nerr = 0
18099  END IF
18100  50 CONTINUE
18101  60 CONTINUE
18102  70 CONTINUE
18103  80 CONTINUE
18104  90 CONTINUE
18105 *
18106  IF( verb .LT. 2 ) THEN
18107  nfail = testnum
18108  CALL zbtcheckin( nfail, outnum, maxerr, nerr, mem(erriptr),
18109  $ mem(errdptr), iseed )
18110  END IF
18111  IF( iam .EQ. 0 ) THEN
18112  IF( verb .GT. 1 ) WRITE(outnum,*) ' '
18113  IF( nfail+nskip .EQ. 0 ) THEN
18114  WRITE(outnum, 7000 ) testnum
18115  ELSE
18116  WRITE(outnum, 8000 ) testnum, testnum-nskip-nfail,
18117  $ nskip, nfail
18118  END IF
18119  END IF
18120 *
18121 * Log whether their were any failures
18122 *
18123  testok = allpass( (nfail.EQ.0) )
18124 *
18125  1000 FORMAT('DOUBLE COMPLEX AMX TESTS: BEGIN.' )
18126  2000 FORMAT(1x,a7,3x,10i6)
18127  3000 FORMAT(1x,a7,3x,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,
18128  $ 5x,a1,5x,a1)
18129  4000 FORMAT(' TEST# STATUS SCOPE TOP M N LDAS LDAD LDI ',
18130  $ 'RDEST CDEST P Q')
18131  5000 FORMAT(' ----- ------- ----- --- ----- ----- ----- ----- ----- ',
18132  $ '----- ----- ---- ----')
18133  6000 FORMAT(i6,1x,a7,5x,a1,3x,a1,7i6,2i5)
18134  7000 FORMAT('DOUBLE COMPLEX AMX TESTS: PASSED ALL',
18135  $ i5, ' TESTS.')
18136  8000 FORMAT('DOUBLE COMPLEX AMX TESTS:',i5,' TESTS;',i5,' PASSED,',
18137  $ i5,' SKIPPED,',i5,' FAILED.')
18138 *
18139  RETURN
18140 *
18141 * End of ZTESTAMX.
18142 *
18143  END
18144 *
18145  SUBROUTINE zrcchk( IPRE, IPOST, PADVAL, M, N, RA, CA, LDI, MYROW,
18146  $ MYCOL, TESTNUM, MAXERR, NERR,
18147  $ ERRIBUF, ERRDBUF )
18148 *
18149 * .. Scalar Arguments ..
18150  INTEGER IPRE, IPOST, PADVAL, M, N, LDI, MYROW, MYCOL, TESTNUM
18151  INTEGER MAXERR, NERR
18152 * ..
18153 * .. Array Arguments ..
18154  INTEGER RA(*), CA(*), ERRIBUF(6, MAXERR)
18155  DOUBLE COMPLEX ERRDBUF(2, MAXERR)
18156 * ..
18157 * .. Parameters ..
18158  INTEGER ERR_PRE, ERR_POST, ERR_GAP, ERR_TRI, ERR_MAT
18159  PARAMETER( ERR_PRE = 1, err_post = 2, err_gap = 3, err_tri = 4 )
18160  parameter( err_mat = 5 )
18161 * ..
18162 * .. External Functions ..
18163  INTEGER IBTNPROCS
18164  EXTERNAL IBTNPROCS
18165 * ..
18166 * .. Local Scalars ..
18167  INTEGER I, J, K, IAM
18168 * ..
18169 * .. Executable Statements ..
18170 *
18171  iam = myrow * ibtnprocs() + mycol
18172 *
18173 * Check pre padding
18174 *
18175  IF( ldi .NE. -1 ) THEN
18176  IF( ipre .GT. 0 ) THEN
18177  DO 10 i = 1, ipre
18178  IF( ra(i) .NE. padval ) THEN
18179  nerr = nerr + 1
18180  IF( nerr .LE. maxerr ) THEN
18181  erribuf(1, nerr) = testnum
18182  erribuf(2, nerr) = ldi
18183  erribuf(3, nerr) = iam
18184  erribuf(4, nerr) = i
18185  erribuf(5, nerr) = ipre - i + 1
18186  erribuf(6, nerr) = -err_pre
18187  errdbuf(1, nerr) = dcmplx( ra(i) )
18188  errdbuf(2, nerr) = dcmplx( padval )
18189  END IF
18190  ENDIF
18191  IF( ca(i) .NE. padval ) THEN
18192  nerr = nerr + 1
18193  IF( nerr .LE. maxerr ) THEN
18194  erribuf(1, nerr) = testnum
18195  erribuf(2, nerr) = ldi
18196  erribuf(3, nerr) = iam
18197  erribuf(4, nerr) = i
18198  erribuf(5, nerr) = ipre - i + 1
18199  erribuf(6, nerr) = -10 - err_pre
18200  errdbuf(1, nerr) = dcmplx( ca(i) )
18201  errdbuf(2, nerr) = dcmplx( padval )
18202  END IF
18203  ENDIF
18204  10 CONTINUE
18205  END IF
18206 *
18207 * Check post padding
18208 *
18209  IF( ipost .GT. 0 ) THEN
18210  k = ipre + ldi*n
18211  DO 20 i = k+1, k+ipost
18212  IF( ra(i) .NE. padval ) THEN
18213  nerr = nerr + 1
18214  IF( nerr .LE. maxerr ) THEN
18215  erribuf(1, nerr) = testnum
18216  erribuf(2, nerr) = ldi
18217  erribuf(3, nerr) = iam
18218  erribuf(4, nerr) = i - k
18219  erribuf(5, nerr) = i
18220  erribuf(6, nerr) = -err_post
18221  errdbuf(1, nerr) = dcmplx( ra(i) )
18222  errdbuf(2, nerr) = dcmplx( padval )
18223  END IF
18224  ENDIF
18225  IF( ca(i) .NE. padval ) THEN
18226  nerr = nerr + 1
18227  IF( nerr .LE. maxerr ) THEN
18228  erribuf(1, nerr) = testnum
18229  erribuf(2, nerr) = ldi
18230  erribuf(3, nerr) = iam
18231  erribuf(4, nerr) = i - k
18232  erribuf(5, nerr) = i
18233  erribuf(6, nerr) = -10 - err_post
18234  errdbuf(1, nerr) = dcmplx( ca(i) )
18235  errdbuf(2, nerr) = dcmplx( padval )
18236  END IF
18237  ENDIF
18238  20 CONTINUE
18239  END IF
18240 *
18241 * Check all (LDI-M) gaps
18242 *
18243  IF( ldi .GT. m ) THEN
18244  k = ipre + m + 1
18245  DO 40 j = 1, n
18246  DO 30 i = m+1, ldi
18247  k = ipre + (j-1)*ldi + i
18248  IF( ra(k) .NE. padval) THEN
18249  nerr = nerr + 1
18250  IF( nerr .LE. maxerr ) THEN
18251  erribuf(1, nerr) = testnum
18252  erribuf(2, nerr) = ldi
18253  erribuf(3, nerr) = iam
18254  erribuf(4, nerr) = i
18255  erribuf(5, nerr) = j
18256  erribuf(6, nerr) = -err_gap
18257  errdbuf(1, nerr) = dcmplx( ra(k) )
18258  errdbuf(2, nerr) = dcmplx( padval )
18259  END IF
18260  END IF
18261  IF( ca(k) .NE. padval) THEN
18262  nerr = nerr + 1
18263  IF( nerr .LE. maxerr ) THEN
18264  erribuf(1, nerr) = testnum
18265  erribuf(2, nerr) = ldi
18266  erribuf(3, nerr) = iam
18267  erribuf(4, nerr) = i
18268  erribuf(5, nerr) = j
18269  erribuf(6, nerr) = -10 - err_gap
18270  errdbuf(1, nerr) = dcmplx( ca(k) )
18271  errdbuf(2, nerr) = dcmplx( padval )
18272  END IF
18273  END IF
18274  30 CONTINUE
18275  40 CONTINUE
18276  END IF
18277 *
18278 * if RA and CA don't exist, buffs better be untouched
18279 *
18280  ELSE
18281  DO 50 i = 1, ipre+ipost
18282  IF( ra(i) .NE. padval) THEN
18283  nerr = nerr + 1
18284  IF( nerr .LE. maxerr ) THEN
18285  erribuf(1, nerr) = testnum
18286  erribuf(2, nerr) = ldi
18287  erribuf(3, nerr) = iam
18288  erribuf(4, nerr) = i
18289  erribuf(5, nerr) = ipre+ipost
18290  erribuf(6, nerr) = -err_pre
18291  errdbuf(1, nerr) = dcmplx( ra(i) )
18292  errdbuf(2, nerr) = dcmplx( padval )
18293  END IF
18294  END IF
18295  IF( ca(i) .NE. padval) THEN
18296  nerr = nerr + 1
18297  IF( nerr .LE. maxerr ) THEN
18298  erribuf(1, nerr) = testnum
18299  erribuf(2, nerr) = ldi
18300  erribuf(3, nerr) = iam
18301  erribuf(4, nerr) = i
18302  erribuf(5, nerr) = ipre+ipost
18303  erribuf(6, nerr) = -10 - err_pre
18304  errdbuf(1, nerr) = dcmplx( ca(i) )
18305  errdbuf(2, nerr) = dcmplx( padval )
18306  END IF
18307  END IF
18308  50 CONTINUE
18309  ENDIF
18310 *
18311  RETURN
18312  END
18313 *
18314  SUBROUTINE zchkamx( SCOPE, ICTXT, M, N, A, LDA, RA, CA, LDI,
18315  $ TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF,
18316  $ ISEED, VALS )
18317 *
18318 * .. Scalar Arguments ..
18319  CHARACTER*1 SCOPE
18320  INTEGER ICTXT, M, N, LDA, LDI, TESTNUM, MAXERR, NERR
18321 * ..
18322 * .. Array Arguments ..
18323  INTEGER RA(*), CA(*), ERRIBUF(6, MAXERR), ISEED(*)
18324  DOUBLE COMPLEX A(LDA,*), ERRDBUF(2, MAXERR), VALS(*)
18325 * ..
18326 * .. External Functions ..
18327  INTEGER IBTMYPROC, IBTNPROCS, IBTSPNUM
18328  DOUBLE PRECISION DBTEPS, ZBTABS
18329  DOUBLE COMPLEX ZBTRAN
18330  EXTERNAL ibtmyproc, ibtnprocs, ibtspnum, zbtran, dbteps, zbtabs
18331 * ..
18332 * .. External Subroutines ..
18333  EXTERNAL ibtspcoord
18334 * ..
18335 * .. Local Scalars ..
18336  LOGICAL ERROR
18337  INTEGER NPROCS, NNODES, NPROW, NPCOL, MYROW, MYCOL, RAMX, CAMX
18338  INTEGER IAMX, I, J, K, H, DEST, NODE
18339  DOUBLE PRECISION EPS
18340 * ..
18341 * .. Executable Statements ..
18342 *
18343  nprocs = ibtnprocs()
18344  eps = dbteps()
18345  CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
18346  dest = myrow*nprocs + mycol
18347 *
18348 * Set up seeds to match those used by each proc's genmat call
18349 *
18350  IF( scope .EQ. 'R' ) THEN
18351  nnodes = npcol
18352  DO 10 i = 0, nnodes-1
18353  node = myrow * nprocs + i
18354  iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
18355  iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
18356  iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
18357  iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
18358  10 CONTINUE
18359  ELSE IF( scope .EQ. 'C' ) THEN
18360  nnodes = nprow
18361  DO 20 i = 0, nnodes-1
18362  node = i * nprocs + mycol
18363  iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
18364  iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
18365  iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
18366  iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
18367  20 CONTINUE
18368  ELSE
18369  nnodes = nprow * npcol
18370  DO 30 i = 0, nnodes-1
18371  node = (i / npcol) * nprocs + mod(i, npcol)
18372  iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
18373  iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
18374  iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
18375  iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
18376  30 CONTINUE
18377  END IF
18378 *
18379  DO 100 j = 1, n
18380  DO 90 i = 1, m
18381  h = (j-1)*ldi + i
18382  vals(1) = zbtran( iseed )
18383  iamx = 1
18384  IF( nnodes .GT. 1 ) THEN
18385  DO 40 k = 1, nnodes-1
18386  vals(k+1) = zbtran( iseed(k*4+1) )
18387  IF( zbtabs( vals(k+1) ) .GT. zbtabs( vals(iamx) ) )
18388  $ iamx = k + 1
18389  40 CONTINUE
18390  END IF
18391 *
18392 * If BLACS have not returned same value we've chosen
18393 *
18394  IF( a(i,j) .NE. vals(iamx) ) THEN
18395 *
18396 * If we have RA and CA arrays
18397 *
18398  IF( ldi .NE. -1 ) THEN
18399 *
18400 * Any number having the same absolute value is a valid max
18401 *
18402  k = ibtspnum( scope, ra(h), ca(h), npcol ) + 1
18403  IF( k.GT.0 .AND. k.LE.nnodes ) THEN
18404  error = abs( zbtabs(vals(k)) - zbtabs(vals(iamx)) )
18405  $ .GT. 3*eps
18406  IF( .NOT.error ) iamx = k
18407  ELSE
18408  error = .true.
18409  END IF
18410  ELSE
18411 *
18412 * Error if BLACS answer not same absolute value, or if it
18413 * was not really in the numbers being compared
18414 *
18415  error = abs( zbtabs(a(i,j)) - zbtabs(vals(iamx)) )
18416  $ .GT. 3*eps
18417  IF( .NOT.error ) THEN
18418  DO 50 k = 1, nnodes
18419  IF( vals(k) .EQ. a(i,j) ) GOTO 60
18420  50 CONTINUE
18421  error = .true.
18422  60 CONTINUE
18423  ENDIF
18424  END IF
18425 *
18426 * If the value is in error
18427 *
18428  IF( error ) THEN
18429  nerr = nerr + 1
18430  erribuf(1, nerr) = testnum
18431  erribuf(2, nerr) = nnodes
18432  erribuf(3, nerr) = dest
18433  erribuf(4, nerr) = i
18434  erribuf(5, nerr) = j
18435  erribuf(6, nerr) = 5
18436  errdbuf(1, nerr) = a(i,j)
18437  errdbuf(2, nerr) = vals(iamx)
18438  END IF
18439  END IF
18440 *
18441 * If they are defined, make sure coordinate entries are OK
18442 *
18443  IF( ldi .NE. -1 ) THEN
18444  k = ibtspnum( scope, ra(h), ca(h), npcol ) + 1
18445  IF( k.NE.iamx ) THEN
18446 *
18447 * Make sure more than one proc doesn't have exact same value
18448 * (and therefore there may be more than one valid coordinate
18449 * for a single value)
18450 *
18451  IF( k.GT.nnodes .OR. k.LT.1 ) THEN
18452  error = .true.
18453  ELSE
18454  error = ( vals(k) .NE. vals(iamx) )
18455  END IF
18456  IF( error ) THEN
18457  CALL ibtspcoord( scope, iamx-1, myrow, mycol,
18458  $ npcol, ramx, camx )
18459  IF( ramx .NE. ra(h) ) THEN
18460  nerr = nerr + 1
18461  erribuf(1, nerr) = testnum
18462  erribuf(2, nerr) = nnodes
18463  erribuf(3, nerr) = dest
18464  erribuf(4, nerr) = i
18465  erribuf(5, nerr) = j
18466  erribuf(6, nerr) = -5
18467  errdbuf(1, nerr) = ra(h)
18468  errdbuf(2, nerr) = ramx
18469  END IF
18470  IF( camx .NE. ca(h) ) THEN
18471  nerr = nerr + 1
18472  erribuf(1, nerr) = testnum
18473  erribuf(2, nerr) = nnodes
18474  erribuf(3, nerr) = dest
18475  erribuf(4, nerr) = i
18476  erribuf(5, nerr) = j
18477  erribuf(6, nerr) = -15
18478  errdbuf(1, nerr) = ca(h)
18479  errdbuf(2, nerr) = camx
18480  END IF
18481  END IF
18482  END IF
18483  END IF
18484  90 CONTINUE
18485  100 CONTINUE
18486 *
18487  RETURN
18488 *
18489 * End of ZCHKAMX
18490 *
18491  END
18492 *
18493 *
18494  SUBROUTINE iamntest( OUTNUM, VERB, TOPSREPEAT, TOPSCOHRNT, NSCOPE,
18495  $ SCOPE0, NTOP, TOP0, NMAT, M0, N0, LDAS0,
18496  $ LDAD0, LDI0, NDEST, RDEST0, CDEST0, NGRID,
18497  $ CONTEXT0, P0, Q0, ISEED, RMEM, CMEM, RCLEN,
18498  $ MEM, MEMLEN )
18499 *
18500 * -- BLACS tester (version 1.0) --
18501 * University of Tennessee
18502 * December 15, 1994
18503 *
18504 *
18505 * .. Scalar Arguments ..
18506  INTEGER MEMLEN, NDEST, NGRID, NMAT, NSCOPE, NTOP, OUTNUM, RCLEN,
18507  $ topscohrnt, topsrepeat, verb
18508 * ..
18509 * .. Array Arguments ..
18510  CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP)
18511  INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT), LDI0(NMAT)
18512  INTEGER RDEST0(NDEST), CDEST0(NDEST), CONTEXT0(NGRID)
18513  INTEGER P0(NGRID), Q0(NGRID), ISEED(*), RMEM(RCLEN), CMEM(RCLEN)
18514  INTEGER MEM(MEMLEN)
18515 * ..
18516 *
18517 * Purpose
18518 * =======
18519 * ITESTAMN: Test integer AMN COMBINE
18520 *
18521 * Arguments
18522 * =========
18523 * OUTNUM (input) INTEGER
18524 * The device number to write output to.
18525 *
18526 * VERB (input) INTEGER
18527 * The level of verbosity (how much printing to do).
18528 *
18529 * NSCOPE (input) INTEGER
18530 * The number of scopes to be tested.
18531 *
18532 * SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE)
18533 * Values of the scopes to be tested.
18534 *
18535 * NTOP (input) INTEGER
18536 * The number of topologies to be tested.
18537 *
18538 * TOP0 (input) CHARACTER*1 array of dimension (NTOP)
18539 * Values of the topologies to be tested.
18540 *
18541 * NMAT (input) INTEGER
18542 * The number of matrices to be tested.
18543 *
18544 * M0 (input) INTEGER array of dimension (NMAT)
18545 * Values of M to be tested.
18546 *
18547 * M0 (input) INTEGER array of dimension (NMAT)
18548 * Values of M to be tested.
18549 *
18550 * N0 (input) INTEGER array of dimension (NMAT)
18551 * Values of N to be tested.
18552 *
18553 * LDAS0 (input) INTEGER array of dimension (NMAT)
18554 * Values of LDAS (leading dimension of A on source process)
18555 * to be tested.
18556 *
18557 * LDAD0 (input) INTEGER array of dimension (NMAT)
18558 * Values of LDAD (leading dimension of A on destination
18559 * process) to be tested.
18560 * LDI0 (input) INTEGER array of dimension (NMAT)
18561 * Values of LDI (leading dimension of RA/CA) to be tested.
18562 * If LDI == -1, these RA/CA should not be accessed.
18563 *
18564 * NDEST (input) INTEGER
18565 * The number of destinations to be tested.
18566 *
18567 * RDEST0 (input) INTEGER array of dimension (NNDEST)
18568 * Values of RDEST (row coordinate of destination) to be
18569 * tested.
18570 *
18571 * CDEST0 (input) INTEGER array of dimension (NNDEST)
18572 * Values of CDEST (column coordinate of destination) to be
18573 * tested.
18574 *
18575 * NGRID (input) INTEGER
18576 * The number of process grids to be tested.
18577 *
18578 * CONTEXT0 (input) INTEGER array of dimension (NGRID)
18579 * The BLACS context handles corresponding to the grids.
18580 *
18581 * P0 (input) INTEGER array of dimension (NGRID)
18582 * Values of P (number of process rows, NPROW).
18583 *
18584 * Q0 (input) INTEGER array of dimension (NGRID)
18585 * Values of Q (number of process columns, NPCOL).
18586 *
18587 * ISEED (workspace) INTEGER array of dimension ( MAX(NPROCS, NTESTS) )
18588 * Workspace used to hold each process's random number SEED.
18589 * This requires NPROCS (number of processor) elements.
18590 * If VERB < 2, this workspace also serves to indicate which
18591 * tests fail. This requires workspace of NTESTS
18592 * (number of tests performed).
18593 *
18594 * RMEM (workspace) INTEGER array of dimension (RCLEN)
18595 * Used for all RA arrays, and their pre and post padding.
18596 *
18597 * CMEM (workspace) INTEGER array of dimension (RCLEN)
18598 * Used for all CA arrays, and their pre and post padding.
18599 *
18600 * RCLEN (input) INTEGER
18601 * The length, in elements, of RMEM and CMEM.
18602 *
18603 * MEM (workspace) INTEGER array of dimension (MEMLEN)
18604 * Used for all other workspaces, including the matrix A,
18605 * and its pre and post padding.
18606 *
18607 * MEMLEN (input) INTEGER
18608 * The length, in elements, of MEM.
18609 *
18610 * =====================================================================
18611 *
18612 * .. External Functions ..
18613  LOGICAL ALLPASS, LSAME
18614  INTEGER IBTMYPROC, IBTNPROCS, IBTSIZEOF
18615  EXTERNAL allpass, lsame, ibtmyproc, ibtnprocs, ibtsizeof
18616 * ..
18617 * .. External Subroutines ..
18618  EXTERNAL blacs_gridinfo, igamn2d
18619  EXTERNAL iinitmat, ichkpad, ibtcheckin
18620 * ..
18621 * .. Local Scalars ..
18622  CHARACTER*1 SCOPE, TOP
18623  LOGICAL INGRID, TESTOK, ALLRCV
18624  INTEGER APTR, CAPTR, CDEST, CDEST2, CONTEXT, ERRDPTR, ERRIPTR, I,
18625  $ iam, icheckval, ide, igr, ima, ipad, ipost, ipre, isc,
18626  $ isize, istart, istop, itc, itc1, itc2, ito, itr, itr1,
18627  $ itr2, j, k, lda, ldadst, ldasrc, ldi, m, maxerr, mycol,
18628  $ myrow, n, nerr, nfail, npcol, nprow, nskip, preaptr,
18629  $ raptr, rdest, rdest2, setwhat, testnum, valptr
18630  INTEGER CHECKVAL
18631 * ..
18632 * .. Executable Statements ..
18633 *
18634 * Choose padding value, and make it unique
18635 *
18636  checkval = -911
18637  iam = ibtmyproc()
18638  checkval = iam * checkval
18639  isize = ibtsizeof('I')
18640  icheckval = -iam
18641 *
18642 * Verify file parameters
18643 *
18644  IF( iam .EQ. 0 ) THEN
18645  WRITE(outnum, *) ' '
18646  WRITE(outnum, *) ' '
18647  WRITE(outnum, 1000 )
18648  IF( verb .GT. 0 ) THEN
18649  WRITE(outnum,*) ' '
18650  WRITE(outnum, 2000) 'NSCOPE:', nscope
18651  WRITE(outnum, 3000) ' SCOPE:', ( scope0(i), i = 1, nscope )
18652  WRITE(outnum, 2000) 'TReps :', topsrepeat
18653  WRITE(outnum, 2000) 'TCohr :', topscohrnt
18654  WRITE(outnum, 2000) 'NTOP :', ntop
18655  WRITE(outnum, 3000) ' TOP :', ( top0(i), i = 1, ntop )
18656  WRITE(outnum, 2000) 'NMAT :', nmat
18657  WRITE(outnum, 2000) ' M :', ( m0(i), i = 1, nmat )
18658  WRITE(outnum, 2000) ' N :', ( n0(i), i = 1, nmat )
18659  WRITE(outnum, 2000) ' LDAS :', ( ldas0(i), i = 1, nmat )
18660  WRITE(outnum, 2000) ' LDAD :', ( ldad0(i), i = 1, nmat )
18661  WRITE(outnum, 2000) ' LDI :', ( ldi0(i), i = 1, nmat )
18662  WRITE(outnum, 2000) 'NDEST :', ndest
18663  WRITE(outnum, 2000) ' RDEST:',( rdest0(i), i = 1, ndest )
18664  WRITE(outnum, 2000) ' CDEST:',( cdest0(i), i = 1, ndest )
18665  WRITE(outnum, 2000) 'NGRIDS:', ngrid
18666  WRITE(outnum, 2000) ' P :', ( p0(i), i = 1, ngrid )
18667  WRITE(outnum, 2000) ' Q :', ( q0(i), i = 1, ngrid )
18668  WRITE(outnum, 2000) 'VERB :', verb
18669  WRITE(outnum,*) ' '
18670  END IF
18671  IF( verb .GT. 1 ) THEN
18672  WRITE(outnum,4000)
18673  WRITE(outnum,5000)
18674  END IF
18675  END IF
18676  IF (topsrepeat.EQ.0) THEN
18677  itr1 = 0
18678  itr2 = 0
18679  ELSE IF (topsrepeat.EQ.1) THEN
18680  itr1 = 1
18681  itr2 = 1
18682  ELSE
18683  itr1 = 0
18684  itr2 = 1
18685  END IF
18686 *
18687 * Find biggest matrix, so we know where to stick error info
18688 *
18689  i = 0
18690  DO 10 ima = 1, nmat
18691  ipad = 4 * m0(ima)
18692  k = n0(ima) * max0( ldas0(ima), ldad0(ima) ) + ipad
18693  IF( k .GT. i ) i = k
18694  10 CONTINUE
18695  i = i + ibtnprocs()
18696  maxerr = ( isize * (memlen-i) ) / ( isize*2 + isize*6 )
18697  IF( maxerr .LT. 1 ) THEN
18698  WRITE(outnum,*) 'ERROR: Not enough memory to run MIN tests.'
18699  CALL blacs_abort(-1, 1)
18700  END IF
18701  errdptr = i + 1
18702  erriptr = errdptr + maxerr
18703  nerr = 0
18704  testnum = 0
18705  nfail = 0
18706  nskip = 0
18707 *
18708 * Loop over grids of matrix
18709 *
18710  DO 90 igr = 1, ngrid
18711 *
18712 * allocate process grid for the next batch of tests
18713 *
18714  context = context0(igr)
18715  CALL blacs_gridinfo( context, nprow, npcol, myrow, mycol )
18716  ingrid = ( (myrow.LT.nprow) .AND. (mycol.LT.npcol) )
18717 *
18718  DO 80 isc = 1, nscope
18719  scope = scope0(isc)
18720  DO 70 ito = 1, ntop
18721  top = top0(ito)
18722 *
18723 * If testing multiring ('M') or general tree ('T'), need to
18724 * loop over calls to BLACS_SET to do full test
18725 *
18726  IF( lsame(top, 'M') ) THEN
18727  setwhat = 13
18728  IF( scope .EQ. 'R' ) THEN
18729  istart = -(npcol - 1)
18730  istop = -istart
18731  ELSE IF (scope .EQ. 'C') THEN
18732  istart = -(nprow - 1)
18733  istop = -istart
18734  ELSE
18735  istart = -(nprow*npcol - 1)
18736  istop = -istart
18737  ENDIF
18738  ELSE IF( lsame(top, 'T') ) THEN
18739  setwhat = 14
18740  istart = 1
18741  IF( scope .EQ. 'R' ) THEN
18742  istop = npcol - 1
18743  ELSE IF (scope .EQ. 'C') THEN
18744  istop = nprow - 1
18745  ELSE
18746  istop = nprow*npcol - 1
18747  ENDIF
18748  ELSE
18749  setwhat = 0
18750  istart = 1
18751  istop = 1
18752  ENDIF
18753  DO 60 ima = 1, nmat
18754  m = m0(ima)
18755  n = n0(ima)
18756  ldasrc = ldas0(ima)
18757  ldadst = ldad0(ima)
18758  ldi = ldi0(ima)
18759  ipre = 2 * m
18760  ipost = ipre
18761  preaptr = 1
18762  aptr = preaptr + ipre
18763 *
18764  DO 50 ide = 1, ndest
18765  testnum = testnum + 1
18766  rdest2 = rdest0(ide)
18767  cdest2 = cdest0(ide)
18768 *
18769 * If everyone gets the answer, create some bogus rdest/cdest
18770 * so IF's are easier
18771 *
18772  allrcv = ( (rdest2.EQ.-1) .OR. (cdest2.EQ.-1) )
18773  IF( allrcv ) THEN
18774  rdest = nprow - 1
18775  cdest = npcol - 1
18776  IF (topscohrnt.EQ.0) THEN
18777  itr1 = 0
18778  itr2 = 0
18779  ELSE IF (topscohrnt.EQ.1) THEN
18780  itr1 = 1
18781  itr2 = 1
18782  ELSE
18783  itr1 = 0
18784  itr2 = 1
18785  END IF
18786  ELSE
18787  rdest = rdest2
18788  cdest = cdest2
18789  itc1 = 0
18790  itc2 = 0
18791  END IF
18792  IF( rdest.GE.p0(igr) .OR. cdest.GE.q0(igr) ) THEN
18793  nskip = nskip + 1
18794  GOTO 50
18795  END IF
18796 *
18797  IF( myrow.EQ.rdest .AND. mycol.EQ.cdest ) THEN
18798  lda = ldadst
18799  ELSE
18800  lda = ldasrc
18801  END IF
18802  valptr = aptr + ipost + n * lda
18803  IF( verb .GT. 1 ) THEN
18804  IF( iam .EQ. 0 ) THEN
18805  WRITE(outnum, 6000)
18806  $ testnum, 'RUNNING', scope, top, m, n,
18807  $ ldasrc, ldadst, ldi, rdest2, cdest2,
18808  $ nprow, npcol
18809  END IF
18810  END IF
18811 *
18812 * If I am in scope
18813 *
18814  testok = .true.
18815  IF( ingrid ) THEN
18816  IF( (myrow.EQ.rdest .AND. scope.EQ.'R') .OR.
18817  $ (mycol.EQ.cdest .AND. scope.EQ.'C') .OR.
18818  $ (scope .EQ. 'A') ) THEN
18819 *
18820  k = nerr
18821  DO 40 itr = itr1, itr2
18822  CALL blacs_set(context, 15, itr)
18823  DO 35 itc = itc1, itc2
18824  CALL blacs_set(context, 16, itc)
18825  DO 30 j = istart, istop
18826  IF( j.EQ.0) GOTO 30
18827  IF( setwhat.NE.0 )
18828  $ CALL blacs_set(context, setwhat, j)
18829 *
18830 *
18831 * generate and pad matrix A
18832 *
18833  CALL iinitmat('G','-', m, n, mem(preaptr),
18834  $ lda, ipre, ipost,
18835  $ checkval, testnum,
18836  $ myrow, mycol )
18837 *
18838 * If they exist, pad RA and CA arrays
18839 *
18840  IF( ldi .NE. -1 ) THEN
18841  DO 15 i = 1, n*ldi + ipre + ipost
18842  rmem(i) = icheckval
18843  cmem(i) = icheckval
18844  15 CONTINUE
18845  raptr = 1 + ipre
18846  captr = 1 + ipre
18847  ELSE
18848  DO 20 i = 1, ipre+ipost
18849  rmem(i) = icheckval
18850  cmem(i) = icheckval
18851  20 CONTINUE
18852  raptr = 1
18853  captr = 1
18854  END IF
18855 *
18856  CALL igamn2d(context, scope, top, m, n,
18857  $ mem(aptr), lda, rmem(raptr),
18858  $ cmem(captr), ldi,
18859  $ rdest2, cdest2)
18860 *
18861 * If I've got the answer, check for errors in
18862 * matrix or padding
18863 *
18864  IF( (myrow.EQ.rdest .AND. mycol.EQ.cdest)
18865  $ .OR. allrcv ) THEN
18866  CALL ichkpad('G','-', m, n,
18867  $ mem(preaptr), lda, rdest,
18868  $ cdest, myrow, mycol,
18869  $ ipre, ipost, checkval,
18870  $ testnum, maxerr, nerr,
18871  $ mem(erriptr),mem(errdptr))
18872  CALL ichkamn(scope, context, m, n,
18873  $ mem(aptr), lda,
18874  $ rmem(raptr), cmem(captr),
18875  $ ldi, testnum, maxerr,nerr,
18876  $ mem(erriptr),mem(errdptr),
18877  $ iseed, mem(valptr))
18878  CALL ircchk(ipre, ipost, icheckval,
18879  $ m, n, rmem, cmem, ldi,
18880  $ myrow, mycol, testnum,
18881  $ maxerr, nerr,
18882  $ mem(erriptr), mem(errdptr))
18883  END IF
18884  30 CONTINUE
18885  CALL blacs_set(context, 16, 0)
18886  35 CONTINUE
18887  CALL blacs_set(context, 15, 0)
18888  40 CONTINUE
18889  testok = ( k .EQ. nerr )
18890  END IF
18891  END IF
18892 *
18893  IF( verb .GT. 1 ) THEN
18894  i = nerr
18895  CALL ibtcheckin(0, outnum, maxerr, nerr,
18896  $ mem(erriptr), mem(errdptr), iseed)
18897  IF( iam .EQ. 0 ) THEN
18898  IF( testok .AND. nerr.EQ.i ) THEN
18899  WRITE(outnum,6000)testnum,'PASSED ',
18900  $ scope, top, m, n, ldasrc,
18901  $ ldadst, ldi, rdest2, cdest2,
18902  $ nprow, npcol
18903  ELSE
18904  nfail = nfail + 1
18905  WRITE(outnum,6000)testnum,'FAILED ',
18906  $ scope, top, m, n, ldasrc,
18907  $ ldadst, ldi, rdest2, cdest2,
18908  $ nprow, npcol
18909  END IF
18910  END IF
18911 *
18912 * Once we've printed out errors, can re-use buf space
18913 *
18914  nerr = 0
18915  END IF
18916  50 CONTINUE
18917  60 CONTINUE
18918  70 CONTINUE
18919  80 CONTINUE
18920  90 CONTINUE
18921 *
18922  IF( verb .LT. 2 ) THEN
18923  nfail = testnum
18924  CALL ibtcheckin( nfail, outnum, maxerr, nerr, mem(erriptr),
18925  $ mem(errdptr), iseed )
18926  END IF
18927  IF( iam .EQ. 0 ) THEN
18928  IF( verb .GT. 1 ) WRITE(outnum,*) ' '
18929  IF( nfail+nskip .EQ. 0 ) THEN
18930  WRITE(outnum, 7000 ) testnum
18931  ELSE
18932  WRITE(outnum, 8000 ) testnum, testnum-nskip-nfail,
18933  $ nskip, nfail
18934  END IF
18935  END IF
18936 *
18937 * Log whether their were any failures
18938 *
18939  testok = allpass( (nfail.EQ.0) )
18940 *
18941  1000 FORMAT('INTEGER AMN TESTS: BEGIN.' )
18942  2000 FORMAT(1x,a7,3x,10i6)
18943  3000 FORMAT(1x,a7,3x,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,
18944  $ 5x,a1,5x,a1)
18945  4000 FORMAT(' TEST# STATUS SCOPE TOP M N LDAS LDAD LDI ',
18946  $ 'RDEST CDEST P Q')
18947  5000 FORMAT(' ----- ------- ----- --- ----- ----- ----- ----- ----- ',
18948  $ '----- ----- ---- ----')
18949  6000 FORMAT(i6,1x,a7,5x,a1,3x,a1,7i6,2i5)
18950  7000 FORMAT('INTEGER AMN TESTS: PASSED ALL',
18951  $ i5, ' TESTS.')
18952  8000 FORMAT('INTEGER AMN TESTS:',i5,' TESTS;',i5,' PASSED,',
18953  $ i5,' SKIPPED,',i5,' FAILED.')
18954 *
18955  RETURN
18956 *
18957 * End of ITESTAMN.
18958 *
18959  END
18960 *
18961  SUBROUTINE ichkamn( SCOPE, ICTXT, M, N, A, LDA, RA, CA, LDI,
18962  $ TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF,
18963  $ ISEED, VALS )
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 *
19133  END
19134 *
19135 *
19136  SUBROUTINE samntest( OUTNUM, VERB, TOPSREPEAT, TOPSCOHRNT, NSCOPE,
19137  $ SCOPE0, NTOP, TOP0, NMAT, M0, N0, LDAS0,
19138  $ LDAD0, LDI0, NDEST, RDEST0, CDEST0, NGRID,
19139  $ CONTEXT0, P0, Q0, ISEED, RMEM, CMEM, RCLEN,
19140  $ MEM, MEMLEN )
19141 *
19142 * -- BLACS tester (version 1.0) --
19143 * University of Tennessee
19144 * December 15, 1994
19145 *
19146 *
19147 * .. Scalar Arguments ..
19148  INTEGER MEMLEN, NDEST, NGRID, NMAT, NSCOPE, NTOP, OUTNUM, RCLEN,
19149  $ TOPSCOHRNT, TOPSREPEAT, VERB
19150 * ..
19151 * .. Array Arguments ..
19152  CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP)
19153  INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT), LDI0(NMAT)
19154  INTEGER RDEST0(NDEST), CDEST0(NDEST), CONTEXT0(NGRID)
19155  INTEGER P0(NGRID), Q0(NGRID), ISEED(*), RMEM(RCLEN), CMEM(RCLEN)
19156  REAL MEM(MEMLEN)
19157 * ..
19158 *
19159 * Purpose
19160 * =======
19161 * STESTAMN: Test real AMN COMBINE
19162 *
19163 * Arguments
19164 * =========
19165 * OUTNUM (input) INTEGER
19166 * The device number to write output to.
19167 *
19168 * VERB (input) INTEGER
19169 * The level of verbosity (how much printing to do).
19170 *
19171 * NSCOPE (input) INTEGER
19172 * The number of scopes to be tested.
19173 *
19174 * SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE)
19175 * Values of the scopes to be tested.
19176 *
19177 * NTOP (input) INTEGER
19178 * The number of topologies to be tested.
19179 *
19180 * TOP0 (input) CHARACTER*1 array of dimension (NTOP)
19181 * Values of the topologies to be tested.
19182 *
19183 * NMAT (input) INTEGER
19184 * The number of matrices to be tested.
19185 *
19186 * M0 (input) INTEGER array of dimension (NMAT)
19187 * Values of M to be tested.
19188 *
19189 * M0 (input) INTEGER array of dimension (NMAT)
19190 * Values of M to be tested.
19191 *
19192 * N0 (input) INTEGER array of dimension (NMAT)
19193 * Values of N to be tested.
19194 *
19195 * LDAS0 (input) INTEGER array of dimension (NMAT)
19196 * Values of LDAS (leading dimension of A on source process)
19197 * to be tested.
19198 *
19199 * LDAD0 (input) INTEGER array of dimension (NMAT)
19200 * Values of LDAD (leading dimension of A on destination
19201 * process) to be tested.
19202 * LDI0 (input) INTEGER array of dimension (NMAT)
19203 * Values of LDI (leading dimension of RA/CA) to be tested.
19204 * If LDI == -1, these RA/CA should not be accessed.
19205 *
19206 * NDEST (input) INTEGER
19207 * The number of destinations to be tested.
19208 *
19209 * RDEST0 (input) INTEGER array of dimension (NNDEST)
19210 * Values of RDEST (row coordinate of destination) to be
19211 * tested.
19212 *
19213 * CDEST0 (input) INTEGER array of dimension (NNDEST)
19214 * Values of CDEST (column coordinate of destination) to be
19215 * tested.
19216 *
19217 * NGRID (input) INTEGER
19218 * The number of process grids to be tested.
19219 *
19220 * CONTEXT0 (input) INTEGER array of dimension (NGRID)
19221 * The BLACS context handles corresponding to the grids.
19222 *
19223 * P0 (input) INTEGER array of dimension (NGRID)
19224 * Values of P (number of process rows, NPROW).
19225 *
19226 * Q0 (input) INTEGER array of dimension (NGRID)
19227 * Values of Q (number of process columns, NPCOL).
19228 *
19229 * ISEED (workspace) INTEGER array of dimension ( MAX(NPROCS, NTESTS) )
19230 * Workspace used to hold each process's random number SEED.
19231 * This requires NPROCS (number of processor) elements.
19232 * If VERB < 2, this workspace also serves to indicate which
19233 * tests fail. This requires workspace of NTESTS
19234 * (number of tests performed).
19235 *
19236 * RMEM (workspace) INTEGER array of dimension (RCLEN)
19237 * Used for all RA arrays, and their pre and post padding.
19238 *
19239 * CMEM (workspace) INTEGER array of dimension (RCLEN)
19240 * Used for all CA arrays, and their pre and post padding.
19241 *
19242 * RCLEN (input) INTEGER
19243 * The length, in elements, of RMEM and CMEM.
19244 *
19245 * MEM (workspace) REAL array of dimension (MEMLEN)
19246 * Used for all other workspaces, including the matrix A,
19247 * and its pre and post padding.
19248 *
19249 * MEMLEN (input) INTEGER
19250 * The length, in elements, of MEM.
19251 *
19252 * =====================================================================
19253 *
19254 * .. External Functions ..
19255  LOGICAL ALLPASS, LSAME
19256  INTEGER IBTMYPROC, IBTNPROCS, IBTSIZEOF
19257  EXTERNAL ALLPASS, LSAME, IBTMYPROC, IBTNPROCS, IBTSIZEOF
19258 * ..
19259 * .. External Subroutines ..
19260  EXTERNAL blacs_gridinfo, sgamn2d
19261  EXTERNAL sinitmat, schkpad, sbtcheckin
19262 * ..
19263 * .. Local Scalars ..
19264  CHARACTER*1 SCOPE, TOP
19265  LOGICAL INGRID, TESTOK, ALLRCV
19266  INTEGER APTR, CAPTR, CDEST, CDEST2, CONTEXT, ERRDPTR, ERRIPTR, I,
19267  $ iam, icheckval, ide, igr, ima, ipad, ipost, ipre, isc,
19268  $ isize, istart, istop, itc, itc1, itc2, ito, itr, itr1,
19269  $ itr2, j, k, lda, ldadst, ldasrc, ldi, m, maxerr, mycol,
19270  $ myrow, n, nerr, nfail, npcol, nprow, nskip, preaptr,
19271  $ raptr, rdest, rdest2, setwhat, ssize, testnum, valptr
19272  REAL CHECKVAL
19273 * ..
19274 * .. Executable Statements ..
19275 *
19276 * Choose padding value, and make it unique
19277 *
19278  checkval = -0.61e0
19279  iam = ibtmyproc()
19280  checkval = iam * checkval
19281  isize = ibtsizeof('I')
19282  ssize = ibtsizeof('S')
19283  icheckval = -iam
19284 *
19285 * Verify file parameters
19286 *
19287  IF( iam .EQ. 0 ) THEN
19288  WRITE(outnum, *) ' '
19289  WRITE(outnum, *) ' '
19290  WRITE(outnum, 1000 )
19291  IF( verb .GT. 0 ) THEN
19292  WRITE(outnum,*) ' '
19293  WRITE(outnum, 2000) 'NSCOPE:', nscope
19294  WRITE(outnum, 3000) ' SCOPE:', ( scope0(i), i = 1, nscope )
19295  WRITE(outnum, 2000) 'TReps :', topsrepeat
19296  WRITE(outnum, 2000) 'TCohr :', topscohrnt
19297  WRITE(outnum, 2000) 'NTOP :', ntop
19298  WRITE(outnum, 3000) ' TOP :', ( top0(i), i = 1, ntop )
19299  WRITE(outnum, 2000) 'NMAT :', nmat
19300  WRITE(outnum, 2000) ' M :', ( m0(i), i = 1, nmat )
19301  WRITE(outnum, 2000) ' N :', ( n0(i), i = 1, nmat )
19302  WRITE(outnum, 2000) ' LDAS :', ( ldas0(i), i = 1, nmat )
19303  WRITE(outnum, 2000) ' LDAD :', ( ldad0(i), i = 1, nmat )
19304  WRITE(outnum, 2000) ' LDI :', ( ldi0(i), i = 1, nmat )
19305  WRITE(outnum, 2000) 'NDEST :', ndest
19306  WRITE(outnum, 2000) ' RDEST:',( rdest0(i), i = 1, ndest )
19307  WRITE(outnum, 2000) ' CDEST:',( cdest0(i), i = 1, ndest )
19308  WRITE(outnum, 2000) 'NGRIDS:', ngrid
19309  WRITE(outnum, 2000) ' P :', ( p0(i), i = 1, ngrid )
19310  WRITE(outnum, 2000) ' Q :', ( q0(i), i = 1, ngrid )
19311  WRITE(outnum, 2000) 'VERB :', verb
19312  WRITE(outnum,*) ' '
19313  END IF
19314  IF( verb .GT. 1 ) THEN
19315  WRITE(outnum,4000)
19316  WRITE(outnum,5000)
19317  END IF
19318  END IF
19319  IF (topsrepeat.EQ.0) THEN
19320  itr1 = 0
19321  itr2 = 0
19322  ELSE IF (topsrepeat.EQ.1) THEN
19323  itr1 = 1
19324  itr2 = 1
19325  ELSE
19326  itr1 = 0
19327  itr2 = 1
19328  END IF
19329 *
19330 * Find biggest matrix, so we know where to stick error info
19331 *
19332  i = 0
19333  DO 10 ima = 1, nmat
19334  ipad = 4 * m0(ima)
19335  k = n0(ima) * max0( ldas0(ima), ldad0(ima) ) + ipad
19336  IF( k .GT. i ) i = k
19337  10 CONTINUE
19338  i = i + ibtnprocs()
19339  maxerr = ( ssize * (memlen-i) ) / ( ssize*2 + isize*6 )
19340  IF( maxerr .LT. 1 ) THEN
19341  WRITE(outnum,*) 'ERROR: Not enough memory to run MIN tests.'
19342  CALL blacs_abort(-1, 1)
19343  END IF
19344  errdptr = i + 1
19345  erriptr = errdptr + maxerr
19346  nerr = 0
19347  testnum = 0
19348  nfail = 0
19349  nskip = 0
19350 *
19351 * Loop over grids of matrix
19352 *
19353  DO 90 igr = 1, ngrid
19354 *
19355 * allocate process grid for the next batch of tests
19356 *
19357  context = context0(igr)
19358  CALL blacs_gridinfo( context, nprow, npcol, myrow, mycol )
19359  ingrid = ( (myrow.LT.nprow) .AND. (mycol.LT.npcol) )
19360 *
19361  DO 80 isc = 1, nscope
19362  scope = scope0(isc)
19363  DO 70 ito = 1, ntop
19364  top = top0(ito)
19365 *
19366 * If testing multiring ('M') or general tree ('T'), need to
19367 * loop over calls to BLACS_SET to do full test
19368 *
19369  IF( lsame(top, 'M') ) THEN
19370  setwhat = 13
19371  IF( scope .EQ. 'R' ) THEN
19372  istart = -(npcol - 1)
19373  istop = -istart
19374  ELSE IF (scope .EQ. 'C') THEN
19375  istart = -(nprow - 1)
19376  istop = -istart
19377  ELSE
19378  istart = -(nprow*npcol - 1)
19379  istop = -istart
19380  ENDIF
19381  ELSE IF( lsame(top, 'T') ) THEN
19382  setwhat = 14
19383  istart = 1
19384  IF( scope .EQ. 'R' ) THEN
19385  istop = npcol - 1
19386  ELSE IF (scope .EQ. 'C') THEN
19387  istop = nprow - 1
19388  ELSE
19389  istop = nprow*npcol - 1
19390  ENDIF
19391  ELSE
19392  setwhat = 0
19393  istart = 1
19394  istop = 1
19395  ENDIF
19396  DO 60 ima = 1, nmat
19397  m = m0(ima)
19398  n = n0(ima)
19399  ldasrc = ldas0(ima)
19400  ldadst = ldad0(ima)
19401  ldi = ldi0(ima)
19402  ipre = 2 * m
19403  ipost = ipre
19404  preaptr = 1
19405  aptr = preaptr + ipre
19406 *
19407  DO 50 ide = 1, ndest
19408  testnum = testnum + 1
19409  rdest2 = rdest0(ide)
19410  cdest2 = cdest0(ide)
19411 *
19412 * If everyone gets the answer, create some bogus rdest/cdest
19413 * so IF's are easier
19414 *
19415  allrcv = ( (rdest2.EQ.-1) .OR. (cdest2.EQ.-1) )
19416  IF( allrcv ) THEN
19417  rdest = nprow - 1
19418  cdest = npcol - 1
19419  IF (topscohrnt.EQ.0) THEN
19420  itr1 = 0
19421  itr2 = 0
19422  ELSE IF (topscohrnt.EQ.1) THEN
19423  itr1 = 1
19424  itr2 = 1
19425  ELSE
19426  itr1 = 0
19427  itr2 = 1
19428  END IF
19429  ELSE
19430  rdest = rdest2
19431  cdest = cdest2
19432  itc1 = 0
19433  itc2 = 0
19434  END IF
19435  IF( rdest.GE.p0(igr) .OR. cdest.GE.q0(igr) ) THEN
19436  nskip = nskip + 1
19437  GOTO 50
19438  END IF
19439 *
19440  IF( myrow.EQ.rdest .AND. mycol.EQ.cdest ) THEN
19441  lda = ldadst
19442  ELSE
19443  lda = ldasrc
19444  END IF
19445  valptr = aptr + ipost + n * lda
19446  IF( verb .GT. 1 ) THEN
19447  IF( iam .EQ. 0 ) THEN
19448  WRITE(outnum, 6000)
19449  $ testnum, 'RUNNING', scope, top, m, n,
19450  $ ldasrc, ldadst, ldi, rdest2, cdest2,
19451  $ nprow, npcol
19452  END IF
19453  END IF
19454 *
19455 * If I am in scope
19456 *
19457  testok = .true.
19458  IF( ingrid ) THEN
19459  IF( (myrow.EQ.rdest .AND. scope.EQ.'R') .OR.
19460  $ (mycol.EQ.cdest .AND. scope.EQ.'C') .OR.
19461  $ (scope .EQ. 'A') ) THEN
19462 *
19463  k = nerr
19464  DO 40 itr = itr1, itr2
19465  CALL blacs_set(context, 15, itr)
19466  DO 35 itc = itc1, itc2
19467  CALL blacs_set(context, 16, itc)
19468  DO 30 j = istart, istop
19469  IF( j.EQ.0) GOTO 30
19470  IF( setwhat.NE.0 )
19471  $ CALL blacs_set(context, setwhat, j)
19472 *
19473 *
19474 * generate and pad matrix A
19475 *
19476  CALL sinitmat('G','-', m, n, mem(preaptr),
19477  $ lda, ipre, ipost,
19478  $ checkval, testnum,
19479  $ myrow, mycol )
19480 *
19481 * If they exist, pad RA and CA arrays
19482 *
19483  IF( ldi .NE. -1 ) THEN
19484  DO 15 i = 1, n*ldi + ipre + ipost
19485  rmem(i) = icheckval
19486  cmem(i) = icheckval
19487  15 CONTINUE
19488  raptr = 1 + ipre
19489  captr = 1 + ipre
19490  ELSE
19491  DO 20 i = 1, ipre+ipost
19492  rmem(i) = icheckval
19493  cmem(i) = icheckval
19494  20 CONTINUE
19495  raptr = 1
19496  captr = 1
19497  END IF
19498 *
19499  CALL sgamn2d(context, scope, top, m, n,
19500  $ mem(aptr), lda, rmem(raptr),
19501  $ cmem(captr), ldi,
19502  $ rdest2, cdest2)
19503 *
19504 * If I've got the answer, check for errors in
19505 * matrix or padding
19506 *
19507  IF( (myrow.EQ.rdest .AND. mycol.EQ.cdest)
19508  $ .OR. allrcv ) THEN
19509  CALL schkpad('G','-', m, n,
19510  $ mem(preaptr), lda, rdest,
19511  $ cdest, myrow, mycol,
19512  $ ipre, ipost, checkval,
19513  $ testnum, maxerr, nerr,
19514  $ mem(erriptr),mem(errdptr))
19515  CALL schkamn(scope, context, m, n,
19516  $ mem(aptr), lda,
19517  $ rmem(raptr), cmem(captr),
19518  $ ldi, testnum, maxerr,nerr,
19519  $ mem(erriptr),mem(errdptr),
19520  $ iseed, mem(valptr))
19521  CALL srcchk(ipre, ipost, icheckval,
19522  $ m, n, rmem, cmem, ldi,
19523  $ myrow, mycol, testnum,
19524  $ maxerr, nerr,
19525  $ mem(erriptr), mem(errdptr))
19526  END IF
19527  30 CONTINUE
19528  CALL blacs_set(context, 16, 0)
19529  35 CONTINUE
19530  CALL blacs_set(context, 15, 0)
19531  40 CONTINUE
19532  testok = ( k .EQ. nerr )
19533  END IF
19534  END IF
19535 *
19536  IF( verb .GT. 1 ) THEN
19537  i = nerr
19538  CALL sbtcheckin(0, outnum, maxerr, nerr,
19539  $ mem(erriptr), mem(errdptr), iseed)
19540  IF( iam .EQ. 0 ) THEN
19541  IF( testok .AND. nerr.EQ.i ) THEN
19542  WRITE(outnum,6000)testnum,'PASSED ',
19543  $ scope, top, m, n, ldasrc,
19544  $ ldadst, ldi, rdest2, cdest2,
19545  $ nprow, npcol
19546  ELSE
19547  nfail = nfail + 1
19548  WRITE(outnum,6000)testnum,'FAILED ',
19549  $ scope, top, m, n, ldasrc,
19550  $ ldadst, ldi, rdest2, cdest2,
19551  $ nprow, npcol
19552  END IF
19553  END IF
19554 *
19555 * Once we've printed out errors, can re-use buf space
19556 *
19557  nerr = 0
19558  END IF
19559  50 CONTINUE
19560  60 CONTINUE
19561  70 CONTINUE
19562  80 CONTINUE
19563  90 CONTINUE
19564 *
19565  IF( verb .LT. 2 ) THEN
19566  nfail = testnum
19567  CALL sbtcheckin( nfail, outnum, maxerr, nerr, mem(erriptr),
19568  $ mem(errdptr), iseed )
19569  END IF
19570  IF( iam .EQ. 0 ) THEN
19571  IF( verb .GT. 1 ) WRITE(outnum,*) ' '
19572  IF( nfail+nskip .EQ. 0 ) THEN
19573  WRITE(outnum, 7000 ) testnum
19574  ELSE
19575  WRITE(outnum, 8000 ) testnum, testnum-nskip-nfail,
19576  $ nskip, nfail
19577  END IF
19578  END IF
19579 *
19580 * Log whether their were any failures
19581 *
19582  testok = allpass( (nfail.EQ.0) )
19583 *
19584  1000 FORMAT('REAL AMN TESTS: BEGIN.' )
19585  2000 FORMAT(1x,a7,3x,10i6)
19586  3000 FORMAT(1x,a7,3x,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,
19587  $ 5x,a1,5x,a1)
19588  4000 FORMAT(' TEST# STATUS SCOPE TOP M N LDAS LDAD LDI ',
19589  $ 'RDEST CDEST P Q')
19590  5000 FORMAT(' ----- ------- ----- --- ----- ----- ----- ----- ----- ',
19591  $ '----- ----- ---- ----')
19592  6000 FORMAT(i6,1x,a7,5x,a1,3x,a1,7i6,2i5)
19593  7000 FORMAT('REAL AMN TESTS: PASSED ALL',
19594  $ i5, ' TESTS.')
19595  8000 FORMAT('REAL AMN TESTS:',i5,' TESTS;',i5,' PASSED,',
19596  $ i5,' SKIPPED,',i5,' FAILED.')
19597 *
19598  RETURN
19599 *
19600 * End of STESTAMN.
19601 *
19602  END
19603 *
19604  SUBROUTINE schkamn( SCOPE, ICTXT, M, N, A, LDA, RA, CA, LDI,
19605  $ TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF,
19606  $ ISEED, VALS )
19607 *
19608 * .. Scalar Arguments ..
19609  CHARACTER*1 SCOPE
19610  INTEGER ICTXT, M, N, LDA, LDI, TESTNUM, MAXERR, NERR
19611 * ..
19612 * .. Array Arguments ..
19613  INTEGER RA(*), CA(*), ERRIBUF(6, MAXERR), ISEED(*)
19614  REAL A(LDA,*), ERRDBUF(2, MAXERR), VALS(*)
19615 * ..
19616 * .. External Functions ..
19617  INTEGER IBTMYPROC, IBTNPROCS, IBTSPNUM
19618  REAL SBTEPS, SBTABS
19619  REAL SBTRAN
19620  EXTERNAL IBTMYPROC, IBTNPROCS, IBTSPNUM, SBTRAN, SBTEPS, SBTABS
19621 * ..
19622 * .. External Subroutines ..
19623  EXTERNAL ibtspcoord
19624 * ..
19625 * .. Local Scalars ..
19626  LOGICAL ERROR
19627  INTEGER NPROCS, NNODES, NPROW, NPCOL, MYROW, MYCOL, RAMN, CAMN
19628  INTEGER IAMN, I, J, K, H, DEST, NODE
19629  REAL EPS
19630 * ..
19631 * .. Executable Statements ..
19632 *
19633  NPROCS = ibtnprocs()
19634  eps = sbteps()
19635  CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
19636  dest = myrow*nprocs + mycol
19637 *
19638 * Set up seeds to match those used by each proc's genmat call
19639 *
19640  IF( scope .EQ. 'R' ) THEN
19641  nnodes = npcol
19642  DO 10 i = 0, nnodes-1
19643  node = myrow * nprocs + i
19644  iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
19645  iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
19646  iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
19647  iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
19648  10 CONTINUE
19649  ELSE IF( scope .EQ. 'C' ) THEN
19650  nnodes = nprow
19651  DO 20 i = 0, nnodes-1
19652  node = i * nprocs + mycol
19653  iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
19654  iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
19655  iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
19656  iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
19657  20 CONTINUE
19658  ELSE
19659  nnodes = nprow * npcol
19660  DO 30 i = 0, nnodes-1
19661  node = (i / npcol) * nprocs + mod(i, npcol)
19662  iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
19663  iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
19664  iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
19665  iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
19666  30 CONTINUE
19667  END IF
19668 *
19669  DO 100 j = 1, n
19670  DO 90 i = 1, m
19671  h = (j-1)*ldi + i
19672  vals(1) = sbtran( iseed )
19673  iamn = 1
19674  IF( nnodes .GT. 1 ) THEN
19675  DO 40 k = 1, nnodes-1
19676  vals(k+1) = sbtran( iseed(k*4+1) )
19677  IF( sbtabs( vals(k+1) ) .LT. sbtabs( vals(iamn) ) )
19678  $ iamn = k + 1
19679  40 CONTINUE
19680  END IF
19681 *
19682 * If BLACS have not returned same value we've chosen
19683 *
19684  IF( a(i,j) .NE. vals(iamn) ) THEN
19685 *
19686 * If we have RA and CA arrays
19687 *
19688  IF( ldi .NE. -1 ) THEN
19689 *
19690 * Any number having the same absolute value is a valid max
19691 *
19692  k = ibtspnum( scope, ra(h), ca(h), npcol ) + 1
19693  IF( k.GT.0 .AND. k.LE.nnodes ) THEN
19694  error = sbtabs( vals(k) ).NE.sbtabs( vals(iamn) )
19695  IF( .NOT.error ) iamn = k
19696  ELSE
19697  error = .true.
19698  END IF
19699  ELSE
19700 *
19701 * Error if BLACS answer not same absolute value, or if it
19702 * was not really in the numbers being compared
19703 *
19704  error = ( sbtabs( a(i,j) ) .NE. sbtabs( vals(iamn) ) )
19705  IF( .NOT.error ) THEN
19706  DO 50 k = 1, nnodes
19707  IF( vals(k) .EQ. a(i,j) ) GOTO 60
19708  50 CONTINUE
19709  error = .true.
19710  60 CONTINUE
19711  ENDIF
19712  END IF
19713 *
19714 * If the value is in error
19715 *
19716  IF( error ) THEN
19717  nerr = nerr + 1
19718  erribuf(1, nerr) = testnum
19719  erribuf(2, nerr) = nnodes
19720  erribuf(3, nerr) = dest
19721  erribuf(4, nerr) = i
19722  erribuf(5, nerr) = j
19723  erribuf(6, nerr) = 5
19724  errdbuf(1, nerr) = a(i,j)
19725  errdbuf(2, nerr) = vals(iamn)
19726  END IF
19727  END IF
19728 *
19729 * If they are defined, make sure coordinate entries are OK
19730 *
19731  IF( ldi .NE. -1 ) THEN
19732  k = ibtspnum( scope, ra(h), ca(h), npcol ) + 1
19733  IF( k.NE.iamn ) THEN
19734 *
19735 * Make sure more than one proc doesn't have exact same value
19736 * (and therefore there may be more than one valid coordinate
19737 * for a single value)
19738 *
19739  IF( k.GT.nnodes .OR. k.LT.1 ) THEN
19740  error = .true.
19741  ELSE
19742  error = ( vals(k) .NE. vals(iamn) )
19743  END IF
19744  IF( error ) THEN
19745  CALL ibtspcoord( scope, iamn-1, myrow, mycol,
19746  $ npcol, ramn, camn )
19747  IF( ramn .NE. ra(h) ) THEN
19748  nerr = nerr + 1
19749  erribuf(1, nerr) = testnum
19750  erribuf(2, nerr) = nnodes
19751  erribuf(3, nerr) = dest
19752  erribuf(4, nerr) = i
19753  erribuf(5, nerr) = j
19754  erribuf(6, nerr) = -5
19755  errdbuf(1, nerr) = ra(h)
19756  errdbuf(2, nerr) = ramn
19757  END IF
19758  IF( camn .NE. ca(h) ) THEN
19759  nerr = nerr + 1
19760  erribuf(1, nerr) = testnum
19761  erribuf(2, nerr) = nnodes
19762  erribuf(3, nerr) = dest
19763  erribuf(4, nerr) = i
19764  erribuf(5, nerr) = j
19765  erribuf(6, nerr) = -15
19766  errdbuf(1, nerr) = ca(h)
19767  errdbuf(2, nerr) = camn
19768  END IF
19769  END IF
19770  END IF
19771  END IF
19772  90 CONTINUE
19773  100 CONTINUE
19774 *
19775  RETURN
19776 *
19777 * End of SCHKAMN
19778 *
19779  END
19780 *
19781 *
19782  SUBROUTINE damntest( OUTNUM, VERB, TOPSREPEAT, TOPSCOHRNT, NSCOPE,
19783  $ SCOPE0, NTOP, TOP0, NMAT, M0, N0, LDAS0,
19784  $ LDAD0, LDI0, NDEST, RDEST0, CDEST0, NGRID,
19785  $ CONTEXT0, P0, Q0, ISEED, RMEM, CMEM, RCLEN,
19786  $ MEM, MEMLEN )
19787 *
19788 * -- BLACS tester (version 1.0) --
19789 * University of Tennessee
19790 * December 15, 1994
19791 *
19792 *
19793 * .. Scalar Arguments ..
19794  INTEGER MEMLEN, NDEST, NGRID, NMAT, NSCOPE, NTOP, OUTNUM, RCLEN,
19795  $ TOPSCOHRNT, TOPSREPEAT, VERB
19796 * ..
19797 * .. Array Arguments ..
19798  CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP)
19799  INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT), LDI0(NMAT)
19800  INTEGER RDEST0(NDEST), CDEST0(NDEST), CONTEXT0(NGRID)
19801  INTEGER P0(NGRID), Q0(NGRID), ISEED(*), RMEM(RCLEN), CMEM(RCLEN)
19802  DOUBLE PRECISION MEM(MEMLEN)
19803 * ..
19804 *
19805 * Purpose
19806 * =======
19807 * DTESTAMN: Test double precision AMN COMBINE
19808 *
19809 * Arguments
19810 * =========
19811 * OUTNUM (input) INTEGER
19812 * The device number to write output to.
19813 *
19814 * VERB (input) INTEGER
19815 * The level of verbosity (how much printing to do).
19816 *
19817 * NSCOPE (input) INTEGER
19818 * The number of scopes to be tested.
19819 *
19820 * SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE)
19821 * Values of the scopes to be tested.
19822 *
19823 * NTOP (input) INTEGER
19824 * The number of topologies to be tested.
19825 *
19826 * TOP0 (input) CHARACTER*1 array of dimension (NTOP)
19827 * Values of the topologies to be tested.
19828 *
19829 * NMAT (input) INTEGER
19830 * The number of matrices to be tested.
19831 *
19832 * M0 (input) INTEGER array of dimension (NMAT)
19833 * Values of M to be tested.
19834 *
19835 * M0 (input) INTEGER array of dimension (NMAT)
19836 * Values of M to be tested.
19837 *
19838 * N0 (input) INTEGER array of dimension (NMAT)
19839 * Values of N to be tested.
19840 *
19841 * LDAS0 (input) INTEGER array of dimension (NMAT)
19842 * Values of LDAS (leading dimension of A on source process)
19843 * to be tested.
19844 *
19845 * LDAD0 (input) INTEGER array of dimension (NMAT)
19846 * Values of LDAD (leading dimension of A on destination
19847 * process) to be tested.
19848 * LDI0 (input) INTEGER array of dimension (NMAT)
19849 * Values of LDI (leading dimension of RA/CA) to be tested.
19850 * If LDI == -1, these RA/CA should not be accessed.
19851 *
19852 * NDEST (input) INTEGER
19853 * The number of destinations to be tested.
19854 *
19855 * RDEST0 (input) INTEGER array of dimension (NNDEST)
19856 * Values of RDEST (row coordinate of destination) to be
19857 * tested.
19858 *
19859 * CDEST0 (input) INTEGER array of dimension (NNDEST)
19860 * Values of CDEST (column coordinate of destination) to be
19861 * tested.
19862 *
19863 * NGRID (input) INTEGER
19864 * The number of process grids to be tested.
19865 *
19866 * CONTEXT0 (input) INTEGER array of dimension (NGRID)
19867 * The BLACS context handles corresponding to the grids.
19868 *
19869 * P0 (input) INTEGER array of dimension (NGRID)
19870 * Values of P (number of process rows, NPROW).
19871 *
19872 * Q0 (input) INTEGER array of dimension (NGRID)
19873 * Values of Q (number of process columns, NPCOL).
19874 *
19875 * ISEED (workspace) INTEGER array of dimension ( MAX(NPROCS, NTESTS) )
19876 * Workspace used to hold each process's random number SEED.
19877 * This requires NPROCS (number of processor) elements.
19878 * If VERB < 2, this workspace also serves to indicate which
19879 * tests fail. This requires workspace of NTESTS
19880 * (number of tests performed).
19881 *
19882 * RMEM (workspace) INTEGER array of dimension (RCLEN)
19883 * Used for all RA arrays, and their pre and post padding.
19884 *
19885 * CMEM (workspace) INTEGER array of dimension (RCLEN)
19886 * Used for all CA arrays, and their pre and post padding.
19887 *
19888 * RCLEN (input) INTEGER
19889 * The length, in elements, of RMEM and CMEM.
19890 *
19891 * MEM (workspace) DOUBLE PRECISION array of dimension (MEMLEN)
19892 * Used for all other workspaces, including the matrix A,
19893 * and its pre and post padding.
19894 *
19895 * MEMLEN (input) INTEGER
19896 * The length, in elements, of MEM.
19897 *
19898 * =====================================================================
19899 *
19900 * .. External Functions ..
19901  LOGICAL ALLPASS, LSAME
19902  INTEGER IBTMYPROC, IBTNPROCS, IBTSIZEOF
19903  EXTERNAL allpass, lsame, ibtmyproc, ibtnprocs, ibtsizeof
19904 * ..
19905 * .. External Subroutines ..
19906  EXTERNAL blacs_gridinfo, dgamn2d
19907  EXTERNAL dinitmat, dchkpad, dbtcheckin
19908 * ..
19909 * .. Local Scalars ..
19910  CHARACTER*1 SCOPE, TOP
19911  LOGICAL INGRID, TESTOK, ALLRCV
19912  INTEGER APTR, CAPTR, CDEST, CDEST2, CONTEXT, DSIZE, ERRDPTR,
19913  $ erriptr, i, iam, icheckval, ide, igr, ima, ipad, ipost,
19914  $ ipre, isc, isize, istart, istop, itc, itc1, itc2, ito,
19915  $ itr, itr1, itr2, j, k, lda, ldadst, ldasrc, ldi, m,
19916  $ maxerr, mycol, myrow, n, nerr, nfail, npcol, nprow, nskip,
19917  $ preaptr, raptr, rdest, rdest2, setwhat, testnum, valptr
19918  DOUBLE PRECISION CHECKVAL
19919 * ..
19920 * .. Executable Statements ..
19921 *
19922 * Choose padding value, and make it unique
19923 *
19924  checkval = -0.81d0
19925  iam = ibtmyproc()
19926  checkval = iam * checkval
19927  isize = ibtsizeof('I')
19928  dsize = ibtsizeof('D')
19929  icheckval = -iam
19930 *
19931 * Verify file parameters
19932 *
19933  IF( iam .EQ. 0 ) THEN
19934  WRITE(outnum, *) ' '
19935  WRITE(outnum, *) ' '
19936  WRITE(outnum, 1000 )
19937  IF( verb .GT. 0 ) THEN
19938  WRITE(outnum,*) ' '
19939  WRITE(outnum, 2000) 'NSCOPE:', nscope
19940  WRITE(outnum, 3000) ' SCOPE:', ( scope0(i), i = 1, nscope )
19941  WRITE(outnum, 2000) 'TReps :', topsrepeat
19942  WRITE(outnum, 2000) 'TCohr :', topscohrnt
19943  WRITE(outnum, 2000) 'NTOP :', ntop
19944  WRITE(outnum, 3000) ' TOP :', ( top0(i), i = 1, ntop )
19945  WRITE(outnum, 2000) 'NMAT :', nmat
19946  WRITE(outnum, 2000) ' M :', ( m0(i), i = 1, nmat )
19947  WRITE(outnum, 2000) ' N :', ( n0(i), i = 1, nmat )
19948  WRITE(outnum, 2000) ' LDAS :', ( ldas0(i), i = 1, nmat )
19949  WRITE(outnum, 2000) ' LDAD :', ( ldad0(i), i = 1, nmat )
19950  WRITE(outnum, 2000) ' LDI :', ( ldi0(i), i = 1, nmat )
19951  WRITE(outnum, 2000) 'NDEST :', ndest
19952  WRITE(outnum, 2000) ' RDEST:',( rdest0(i), i = 1, ndest )
19953  WRITE(outnum, 2000) ' CDEST:',( cdest0(i), i = 1, ndest )
19954  WRITE(outnum, 2000) 'NGRIDS:', ngrid
19955  WRITE(outnum, 2000) ' P :', ( p0(i), i = 1, ngrid )
19956  WRITE(outnum, 2000) ' Q :', ( q0(i), i = 1, ngrid )
19957  WRITE(outnum, 2000) 'VERB :', verb
19958  WRITE(outnum,*) ' '
19959  END IF
19960  IF( verb .GT. 1 ) THEN
19961  WRITE(outnum,4000)
19962  WRITE(outnum,5000)
19963  END IF
19964  END IF
19965  IF (topsrepeat.EQ.0) THEN
19966  itr1 = 0
19967  itr2 = 0
19968  ELSE IF (topsrepeat.EQ.1) THEN
19969  itr1 = 1
19970  itr2 = 1
19971  ELSE
19972  itr1 = 0
19973  itr2 = 1
19974  END IF
19975 *
19976 * Find biggest matrix, so we know where to stick error info
19977 *
19978  i = 0
19979  DO 10 ima = 1, nmat
19980  ipad = 4 * m0(ima)
19981  k = n0(ima) * max0( ldas0(ima), ldad0(ima) ) + ipad
19982  IF( k .GT. i ) i = k
19983  10 CONTINUE
19984  i = i + ibtnprocs()
19985  maxerr = ( dsize * (memlen-i) ) / ( dsize*2 + isize*6 )
19986  IF( maxerr .LT. 1 ) THEN
19987  WRITE(outnum,*) 'ERROR: Not enough memory to run MIN tests.'
19988  CALL blacs_abort(-1, 1)
19989  END IF
19990  errdptr = i + 1
19991  erriptr = errdptr + maxerr
19992  nerr = 0
19993  testnum = 0
19994  nfail = 0
19995  nskip = 0
19996 *
19997 * Loop over grids of matrix
19998 *
19999  DO 90 igr = 1, ngrid
20000 *
20001 * allocate process grid for the next batch of tests
20002 *
20003  context = context0(igr)
20004  CALL blacs_gridinfo( context, nprow, npcol, myrow, mycol )
20005  ingrid = ( (myrow.LT.nprow) .AND. (mycol.LT.npcol) )
20006 *
20007  DO 80 isc = 1, nscope
20008  scope = scope0(isc)
20009  DO 70 ito = 1, ntop
20010  top = top0(ito)
20011 *
20012 * If testing multiring ('M') or general tree ('T'), need to
20013 * loop over calls to BLACS_SET to do full test
20014 *
20015  IF( lsame(top, 'M') ) THEN
20016  setwhat = 13
20017  IF( scope .EQ. 'R' ) THEN
20018  istart = -(npcol - 1)
20019  istop = -istart
20020  ELSE IF (scope .EQ. 'C') THEN
20021  istart = -(nprow - 1)
20022  istop = -istart
20023  ELSE
20024  istart = -(nprow*npcol - 1)
20025  istop = -istart
20026  ENDIF
20027  ELSE IF( lsame(top, 'T') ) THEN
20028  setwhat = 14
20029  istart = 1
20030  IF( scope .EQ. 'R' ) THEN
20031  istop = npcol - 1
20032  ELSE IF (scope .EQ. 'C') THEN
20033  istop = nprow - 1
20034  ELSE
20035  istop = nprow*npcol - 1
20036  ENDIF
20037  ELSE
20038  setwhat = 0
20039  istart = 1
20040  istop = 1
20041  ENDIF
20042  DO 60 ima = 1, nmat
20043  m = m0(ima)
20044  n = n0(ima)
20045  ldasrc = ldas0(ima)
20046  ldadst = ldad0(ima)
20047  ldi = ldi0(ima)
20048  ipre = 2 * m
20049  ipost = ipre
20050  preaptr = 1
20051  aptr = preaptr + ipre
20052 *
20053  DO 50 ide = 1, ndest
20054  testnum = testnum + 1
20055  rdest2 = rdest0(ide)
20056  cdest2 = cdest0(ide)
20057 *
20058 * If everyone gets the answer, create some bogus rdest/cdest
20059 * so IF's are easier
20060 *
20061  allrcv = ( (rdest2.EQ.-1) .OR. (cdest2.EQ.-1) )
20062  IF( allrcv ) THEN
20063  rdest = nprow - 1
20064  cdest = npcol - 1
20065  IF (topscohrnt.EQ.0) THEN
20066  itr1 = 0
20067  itr2 = 0
20068  ELSE IF (topscohrnt.EQ.1) THEN
20069  itr1 = 1
20070  itr2 = 1
20071  ELSE
20072  itr1 = 0
20073  itr2 = 1
20074  END IF
20075  ELSE
20076  rdest = rdest2
20077  cdest = cdest2
20078  itc1 = 0
20079  itc2 = 0
20080  END IF
20081  IF( rdest.GE.p0(igr) .OR. cdest.GE.q0(igr) ) THEN
20082  nskip = nskip + 1
20083  GOTO 50
20084  END IF
20085 *
20086  IF( myrow.EQ.rdest .AND. mycol.EQ.cdest ) THEN
20087  lda = ldadst
20088  ELSE
20089  lda = ldasrc
20090  END IF
20091  valptr = aptr + ipost + n * lda
20092  IF( verb .GT. 1 ) THEN
20093  IF( iam .EQ. 0 ) THEN
20094  WRITE(outnum, 6000)
20095  $ testnum, 'RUNNING', scope, top, m, n,
20096  $ ldasrc, ldadst, ldi, rdest2, cdest2,
20097  $ nprow, npcol
20098  END IF
20099  END IF
20100 *
20101 * If I am in scope
20102 *
20103  testok = .true.
20104  IF( ingrid ) THEN
20105  IF( (myrow.EQ.rdest .AND. scope.EQ.'R') .OR.
20106  $ (mycol.EQ.cdest .AND. scope.EQ.'C') .OR.
20107  $ (scope .EQ. 'A') ) THEN
20108 *
20109  k = nerr
20110  DO 40 itr = itr1, itr2
20111  CALL blacs_set(context, 15, itr)
20112  DO 35 itc = itc1, itc2
20113  CALL blacs_set(context, 16, itc)
20114  DO 30 j = istart, istop
20115  IF( j.EQ.0) GOTO 30
20116  IF( setwhat.NE.0 )
20117  $ CALL blacs_set(context, setwhat, j)
20118 *
20119 *
20120 * generate and pad matrix A
20121 *
20122  CALL dinitmat('G','-', m, n, mem(preaptr),
20123  $ lda, ipre, ipost,
20124  $ checkval, testnum,
20125  $ myrow, mycol )
20126 *
20127 * If they exist, pad RA and CA arrays
20128 *
20129  IF( ldi .NE. -1 ) THEN
20130  DO 15 i = 1, n*ldi + ipre + ipost
20131  rmem(i) = icheckval
20132  cmem(i) = icheckval
20133  15 CONTINUE
20134  raptr = 1 + ipre
20135  captr = 1 + ipre
20136  ELSE
20137  DO 20 i = 1, ipre+ipost
20138  rmem(i) = icheckval
20139  cmem(i) = icheckval
20140  20 CONTINUE
20141  raptr = 1
20142  captr = 1
20143  END IF
20144 *
20145  CALL dgamn2d(context, scope, top, m, n,
20146  $ mem(aptr), lda, rmem(raptr),
20147  $ cmem(captr), ldi,
20148  $ rdest2, cdest2)
20149 *
20150 * If I've got the answer, check for errors in
20151 * matrix or padding
20152 *
20153  IF( (myrow.EQ.rdest .AND. mycol.EQ.cdest)
20154  $ .OR. allrcv ) THEN
20155  CALL dchkpad('G','-', m, n,
20156  $ mem(preaptr), lda, rdest,
20157  $ cdest, myrow, mycol,
20158  $ ipre, ipost, checkval,
20159  $ testnum, maxerr, nerr,
20160  $ mem(erriptr),mem(errdptr))
20161  CALL dchkamn(scope, context, m, n,
20162  $ mem(aptr), lda,
20163  $ rmem(raptr), cmem(captr),
20164  $ ldi, testnum, maxerr,nerr,
20165  $ mem(erriptr),mem(errdptr),
20166  $ iseed, mem(valptr))
20167  CALL drcchk(ipre, ipost, icheckval,
20168  $ m, n, rmem, cmem, ldi,
20169  $ myrow, mycol, testnum,
20170  $ maxerr, nerr,
20171  $ mem(erriptr), mem(errdptr))
20172  END IF
20173  30 CONTINUE
20174  CALL blacs_set(context, 16, 0)
20175  35 CONTINUE
20176  CALL blacs_set(context, 15, 0)
20177  40 CONTINUE
20178  testok = ( k .EQ. nerr )
20179  END IF
20180  END IF
20181 *
20182  IF( verb .GT. 1 ) THEN
20183  i = nerr
20184  CALL dbtcheckin(0, outnum, maxerr, nerr,
20185  $ mem(erriptr), mem(errdptr), iseed)
20186  IF( iam .EQ. 0 ) THEN
20187  IF( testok .AND. nerr.EQ.i ) THEN
20188  WRITE(outnum,6000)testnum,'PASSED ',
20189  $ scope, top, m, n, ldasrc,
20190  $ ldadst, ldi, rdest2, cdest2,
20191  $ nprow, npcol
20192  ELSE
20193  nfail = nfail + 1
20194  WRITE(outnum,6000)testnum,'FAILED ',
20195  $ scope, top, m, n, ldasrc,
20196  $ ldadst, ldi, rdest2, cdest2,
20197  $ nprow, npcol
20198  END IF
20199  END IF
20200 *
20201 * Once we've printed out errors, can re-use buf space
20202 *
20203  nerr = 0
20204  END IF
20205  50 CONTINUE
20206  60 CONTINUE
20207  70 CONTINUE
20208  80 CONTINUE
20209  90 CONTINUE
20210 *
20211  IF( verb .LT. 2 ) THEN
20212  nfail = testnum
20213  CALL dbtcheckin( nfail, outnum, maxerr, nerr, mem(erriptr),
20214  $ mem(errdptr), iseed )
20215  END IF
20216  IF( iam .EQ. 0 ) THEN
20217  IF( verb .GT. 1 ) WRITE(outnum,*) ' '
20218  IF( nfail+nskip .EQ. 0 ) THEN
20219  WRITE(outnum, 7000 ) testnum
20220  ELSE
20221  WRITE(outnum, 8000 ) testnum, testnum-nskip-nfail,
20222  $ nskip, nfail
20223  END IF
20224  END IF
20225 *
20226 * Log whether their were any failures
20227 *
20228  testok = allpass( (nfail.EQ.0) )
20229 *
20230  1000 FORMAT('DOUBLE PRECISION AMN TESTS: BEGIN.' )
20231  2000 FORMAT(1x,a7,3x,10i6)
20232  3000 FORMAT(1x,a7,3x,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,
20233  $ 5x,a1,5x,a1)
20234  4000 FORMAT(' TEST# STATUS SCOPE TOP M N LDAS LDAD LDI ',
20235  $ 'RDEST CDEST P Q')
20236  5000 FORMAT(' ----- ------- ----- --- ----- ----- ----- ----- ----- ',
20237  $ '----- ----- ---- ----')
20238  6000 FORMAT(i6,1x,a7,5x,a1,3x,a1,7i6,2i5)
20239  7000 FORMAT('DOUBLE PRECISION AMN TESTS: PASSED ALL',
20240  $ i5, ' TESTS.')
20241  8000 FORMAT('DOUBLE PRECISION AMN TESTS:',i5,' TESTS;',i5,' PASSED,',
20242  $ i5,' SKIPPED,',i5,' FAILED.')
20243 *
20244  RETURN
20245 *
20246 * End of DTESTAMN.
20247 *
20248  END
20249 *
20250  SUBROUTINE dchkamn( SCOPE, ICTXT, M, N, A, LDA, RA, CA, LDI,
20251  $ TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF,
20252  $ ISEED, VALS )
20253 *
20254 * .. Scalar Arguments ..
20255  CHARACTER*1 SCOPE
20256  INTEGER ICTXT, M, N, LDA, LDI, TESTNUM, MAXERR, NERR
20257 * ..
20258 * .. Array Arguments ..
20259  INTEGER RA(*), CA(*), ERRIBUF(6, MAXERR), ISEED(*)
20260  DOUBLE PRECISION A(LDA,*), ERRDBUF(2, MAXERR), VALS(*)
20261 * ..
20262 * .. External Functions ..
20263  INTEGER IBTMYPROC, IBTNPROCS, IBTSPNUM
20264  DOUBLE PRECISION DBTEPS, DBTABS
20265  DOUBLE PRECISION DBTRAN
20266  EXTERNAL IBTMYPROC, IBTNPROCS, IBTSPNUM, DBTRAN, DBTEPS, DBTABS
20267 * ..
20268 * .. External Subroutines ..
20269  EXTERNAL ibtspcoord
20270 * ..
20271 * .. Local Scalars ..
20272  LOGICAL ERROR
20273  INTEGER NPROCS, NNODES, NPROW, NPCOL, MYROW, MYCOL, RAMN, CAMN
20274  INTEGER IAMN, I, J, K, H, DEST, NODE
20275  DOUBLE PRECISION EPS
20276 * ..
20277 * .. Executable Statements ..
20278 *
20279  nprocs = ibtnprocs()
20280  eps = dbteps()
20281  CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
20282  dest = myrow*nprocs + mycol
20283 *
20284 * Set up seeds to match those used by each proc's genmat call
20285 *
20286  IF( scope .EQ. 'R' ) THEN
20287  nnodes = npcol
20288  DO 10 i = 0, nnodes-1
20289  node = myrow * nprocs + i
20290  iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
20291  iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
20292  iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
20293  iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
20294  10 CONTINUE
20295  ELSE IF( scope .EQ. 'C' ) THEN
20296  nnodes = nprow
20297  DO 20 i = 0, nnodes-1
20298  node = i * nprocs + mycol
20299  iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
20300  iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
20301  iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
20302  iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
20303  20 CONTINUE
20304  ELSE
20305  nnodes = nprow * npcol
20306  DO 30 i = 0, nnodes-1
20307  node = (i / npcol) * nprocs + mod(i, npcol)
20308  iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
20309  iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
20310  iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
20311  iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
20312  30 CONTINUE
20313  END IF
20314 *
20315  DO 100 j = 1, n
20316  DO 90 i = 1, m
20317  h = (j-1)*ldi + i
20318  vals(1) = dbtran( iseed )
20319  iamn = 1
20320  IF( nnodes .GT. 1 ) THEN
20321  DO 40 k = 1, nnodes-1
20322  vals(k+1) = dbtran( iseed(k*4+1) )
20323  IF( dbtabs( vals(k+1) ) .LT. dbtabs( vals(iamn) ) )
20324  $ iamn = k + 1
20325  40 CONTINUE
20326  END IF
20327 *
20328 * If BLACS have not returned same value we've chosen
20329 *
20330  IF( a(i,j) .NE. vals(iamn) ) THEN
20331 *
20332 * If we have RA and CA arrays
20333 *
20334  IF( ldi .NE. -1 ) THEN
20335 *
20336 * Any number having the same absolute value is a valid max
20337 *
20338  k = ibtspnum( scope, ra(h), ca(h), npcol ) + 1
20339  IF( k.GT.0 .AND. k.LE.nnodes ) THEN
20340  error = dbtabs( vals(k) ).NE.dbtabs( vals(iamn) )
20341  IF( .NOT.error ) iamn = k
20342  ELSE
20343  error = .true.
20344  END IF
20345  ELSE
20346 *
20347 * Error if BLACS answer not same absolute value, or if it
20348 * was not really in the numbers being compared
20349 *
20350  error = ( dbtabs( a(i,j) ) .NE. dbtabs( vals(iamn) ) )
20351  IF( .NOT.error ) THEN
20352  DO 50 k = 1, nnodes
20353  IF( vals(k) .EQ. a(i,j) ) GOTO 60
20354  50 CONTINUE
20355  error = .true.
20356  60 CONTINUE
20357  ENDIF
20358  END IF
20359 *
20360 * If the value is in error
20361 *
20362  IF( error ) THEN
20363  nerr = nerr + 1
20364  erribuf(1, nerr) = testnum
20365  erribuf(2, nerr) = nnodes
20366  erribuf(3, nerr) = dest
20367  erribuf(4, nerr) = i
20368  erribuf(5, nerr) = j
20369  erribuf(6, nerr) = 5
20370  errdbuf(1, nerr) = a(i,j)
20371  errdbuf(2, nerr) = vals(iamn)
20372  END IF
20373  END IF
20374 *
20375 * If they are defined, make sure coordinate entries are OK
20376 *
20377  IF( ldi .NE. -1 ) THEN
20378  k = ibtspnum( scope, ra(h), ca(h), npcol ) + 1
20379  IF( k.NE.iamn ) THEN
20380 *
20381 * Make sure more than one proc doesn't have exact same value
20382 * (and therefore there may be more than one valid coordinate
20383 * for a single value)
20384 *
20385  IF( k.GT.nnodes .OR. k.LT.1 ) THEN
20386  error = .true.
20387  ELSE
20388  error = ( vals(k) .NE. vals(iamn) )
20389  END IF
20390  IF( error ) THEN
20391  CALL ibtspcoord( scope, iamn-1, myrow, mycol,
20392  $ npcol, ramn, camn )
20393  IF( ramn .NE. ra(h) ) THEN
20394  nerr = nerr + 1
20395  erribuf(1, nerr) = testnum
20396  erribuf(2, nerr) = nnodes
20397  erribuf(3, nerr) = dest
20398  erribuf(4, nerr) = i
20399  erribuf(5, nerr) = j
20400  erribuf(6, nerr) = -5
20401  errdbuf(1, nerr) = ra(h)
20402  errdbuf(2, nerr) = ramn
20403  END IF
20404  IF( camn .NE. ca(h) ) THEN
20405  nerr = nerr + 1
20406  erribuf(1, nerr) = testnum
20407  erribuf(2, nerr) = nnodes
20408  erribuf(3, nerr) = dest
20409  erribuf(4, nerr) = i
20410  erribuf(5, nerr) = j
20411  erribuf(6, nerr) = -15
20412  errdbuf(1, nerr) = ca(h)
20413  errdbuf(2, nerr) = camn
20414  END IF
20415  END IF
20416  END IF
20417  END IF
20418  90 CONTINUE
20419  100 CONTINUE
20420 *
20421  RETURN
20422 *
20423 * End of DCHKAMN
20424 *
20425  END
20426 *
20427 *
20428  SUBROUTINE camntest( OUTNUM, VERB, TOPSREPEAT, TOPSCOHRNT, NSCOPE,
20429  $ SCOPE0, NTOP, TOP0, NMAT, M0, N0, LDAS0,
20430  $ LDAD0, LDI0, NDEST, RDEST0, CDEST0, NGRID,
20431  $ CONTEXT0, P0, Q0, ISEED, RMEM, CMEM, RCLEN,
20432  $ MEM, MEMLEN )
20433 *
20434 * -- BLACS tester (version 1.0) --
20435 * University of Tennessee
20436 * December 15, 1994
20437 *
20438 *
20439 * .. Scalar Arguments ..
20440  INTEGER MEMLEN, NDEST, NGRID, NMAT, NSCOPE, NTOP, OUTNUM, RCLEN,
20441  $ topscohrnt, topsrepeat, verb
20442 * ..
20443 * .. Array Arguments ..
20444  CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP)
20445  INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT), LDI0(NMAT)
20446  INTEGER RDEST0(NDEST), CDEST0(NDEST), CONTEXT0(NGRID)
20447  INTEGER P0(NGRID), Q0(NGRID), ISEED(*), RMEM(RCLEN), CMEM(RCLEN)
20448  COMPLEX MEM(MEMLEN)
20449 * ..
20450 *
20451 * Purpose
20452 * =======
20453 * CTESTAMN: Test complex AMN COMBINE
20454 *
20455 * Arguments
20456 * =========
20457 * OUTNUM (input) INTEGER
20458 * The device number to write output to.
20459 *
20460 * VERB (input) INTEGER
20461 * The level of verbosity (how much printing to do).
20462 *
20463 * NSCOPE (input) INTEGER
20464 * The number of scopes to be tested.
20465 *
20466 * SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE)
20467 * Values of the scopes to be tested.
20468 *
20469 * NTOP (input) INTEGER
20470 * The number of topologies to be tested.
20471 *
20472 * TOP0 (input) CHARACTER*1 array of dimension (NTOP)
20473 * Values of the topologies to be tested.
20474 *
20475 * NMAT (input) INTEGER
20476 * The number of matrices to be tested.
20477 *
20478 * M0 (input) INTEGER array of dimension (NMAT)
20479 * Values of M to be tested.
20480 *
20481 * M0 (input) INTEGER array of dimension (NMAT)
20482 * Values of M to be tested.
20483 *
20484 * N0 (input) INTEGER array of dimension (NMAT)
20485 * Values of N to be tested.
20486 *
20487 * LDAS0 (input) INTEGER array of dimension (NMAT)
20488 * Values of LDAS (leading dimension of A on source process)
20489 * to be tested.
20490 *
20491 * LDAD0 (input) INTEGER array of dimension (NMAT)
20492 * Values of LDAD (leading dimension of A on destination
20493 * process) to be tested.
20494 * LDI0 (input) INTEGER array of dimension (NMAT)
20495 * Values of LDI (leading dimension of RA/CA) to be tested.
20496 * If LDI == -1, these RA/CA should not be accessed.
20497 *
20498 * NDEST (input) INTEGER
20499 * The number of destinations to be tested.
20500 *
20501 * RDEST0 (input) INTEGER array of dimension (NNDEST)
20502 * Values of RDEST (row coordinate of destination) to be
20503 * tested.
20504 *
20505 * CDEST0 (input) INTEGER array of dimension (NNDEST)
20506 * Values of CDEST (column coordinate of destination) to be
20507 * tested.
20508 *
20509 * NGRID (input) INTEGER
20510 * The number of process grids to be tested.
20511 *
20512 * CONTEXT0 (input) INTEGER array of dimension (NGRID)
20513 * The BLACS context handles corresponding to the grids.
20514 *
20515 * P0 (input) INTEGER array of dimension (NGRID)
20516 * Values of P (number of process rows, NPROW).
20517 *
20518 * Q0 (input) INTEGER array of dimension (NGRID)
20519 * Values of Q (number of process columns, NPCOL).
20520 *
20521 * ISEED (workspace) INTEGER array of dimension ( MAX(NPROCS, NTESTS) )
20522 * Workspace used to hold each process's random number SEED.
20523 * This requires NPROCS (number of processor) elements.
20524 * If VERB < 2, this workspace also serves to indicate which
20525 * tests fail. This requires workspace of NTESTS
20526 * (number of tests performed).
20527 *
20528 * RMEM (workspace) INTEGER array of dimension (RCLEN)
20529 * Used for all RA arrays, and their pre and post padding.
20530 *
20531 * CMEM (workspace) INTEGER array of dimension (RCLEN)
20532 * Used for all CA arrays, and their pre and post padding.
20533 *
20534 * RCLEN (input) INTEGER
20535 * The length, in elements, of RMEM and CMEM.
20536 *
20537 * MEM (workspace) COMPLEX array of dimension (MEMLEN)
20538 * Used for all other workspaces, including the matrix A,
20539 * and its pre and post padding.
20540 *
20541 * MEMLEN (input) INTEGER
20542 * The length, in elements, of MEM.
20543 *
20544 * =====================================================================
20545 *
20546 * .. External Functions ..
20547  LOGICAL ALLPASS, LSAME
20548  INTEGER IBTMYPROC, IBTNPROCS, IBTSIZEOF
20549  EXTERNAL ALLPASS, LSAME, IBTMYPROC, IBTNPROCS, IBTSIZEOF
20550 * ..
20551 * .. External Subroutines ..
20552  EXTERNAL BLACS_GRIDINFO, CGAMN2D
20553  EXTERNAL CINITMAT, CCHKPAD, CBTCHECKIN
20554 * ..
20555 * .. Local Scalars ..
20556  CHARACTER*1 SCOPE, TOP
20557  LOGICAL INGRID, TESTOK, ALLRCV
20558  INTEGER APTR, CAPTR, CDEST, CDEST2, CONTEXT, CSIZE, ERRDPTR,
20559  $ erriptr, i, iam, icheckval, ide, igr, ima, ipad, ipost,
20560  $ ipre, isc, isize, istart, istop, itc, itc1, itc2, ito,
20561  $ itr, itr1, itr2, j, k, lda, ldadst, ldasrc, ldi, m,
20562  $ maxerr, mycol, myrow, n, nerr, nfail, npcol, nprow, nskip,
20563  $ preaptr, raptr, rdest, rdest2, setwhat, testnum, valptr
20564  COMPLEX CHECKVAL
20565 * ..
20566 * .. Executable Statements ..
20567 *
20568 * Choose padding value, and make it unique
20569 *
20570  checkval = cmplx( -0.91e0, -0.71e0 )
20571  iam = ibtmyproc()
20572  checkval = iam * checkval
20573  isize = ibtsizeof('I')
20574  csize = ibtsizeof('C')
20575  icheckval = -iam
20576 *
20577 * Verify file parameters
20578 *
20579  IF( iam .EQ. 0 ) THEN
20580  WRITE(outnum, *) ' '
20581  WRITE(outnum, *) ' '
20582  WRITE(outnum, 1000 )
20583  IF( verb .GT. 0 ) THEN
20584  WRITE(outnum,*) ' '
20585  WRITE(outnum, 2000) 'NSCOPE:', nscope
20586  WRITE(outnum, 3000) ' SCOPE:', ( scope0(i), i = 1, nscope )
20587  WRITE(outnum, 2000) 'TReps :', topsrepeat
20588  WRITE(outnum, 2000) 'TCohr :', topscohrnt
20589  WRITE(outnum, 2000) 'NTOP :', ntop
20590  WRITE(outnum, 3000) ' TOP :', ( top0(i), i = 1, ntop )
20591  WRITE(outnum, 2000) 'NMAT :', nmat
20592  WRITE(outnum, 2000) ' M :', ( m0(i), i = 1, nmat )
20593  WRITE(outnum, 2000) ' N :', ( n0(i), i = 1, nmat )
20594  WRITE(outnum, 2000) ' LDAS :', ( ldas0(i), i = 1, nmat )
20595  WRITE(outnum, 2000) ' LDAD :', ( ldad0(i), i = 1, nmat )
20596  WRITE(outnum, 2000) ' LDI :', ( ldi0(i), i = 1, nmat )
20597  WRITE(outnum, 2000) 'NDEST :', ndest
20598  WRITE(outnum, 2000) ' RDEST:',( rdest0(i), i = 1, ndest )
20599  WRITE(outnum, 2000) ' CDEST:',( cdest0(i), i = 1, ndest )
20600  WRITE(outnum, 2000) 'NGRIDS:', ngrid
20601  WRITE(outnum, 2000) ' P :', ( p0(i), i = 1, ngrid )
20602  WRITE(outnum, 2000) ' Q :', ( q0(i), i = 1, ngrid )
20603  WRITE(outnum, 2000) 'VERB :', verb
20604  WRITE(outnum,*) ' '
20605  END IF
20606  IF( verb .GT. 1 ) THEN
20607  WRITE(outnum,4000)
20608  WRITE(outnum,5000)
20609  END IF
20610  END IF
20611  IF (topsrepeat.EQ.0) THEN
20612  itr1 = 0
20613  itr2 = 0
20614  ELSE IF (topsrepeat.EQ.1) THEN
20615  itr1 = 1
20616  itr2 = 1
20617  ELSE
20618  itr1 = 0
20619  itr2 = 1
20620  END IF
20621 *
20622 * Find biggest matrix, so we know where to stick error info
20623 *
20624  i = 0
20625  DO 10 ima = 1, nmat
20626  ipad = 4 * m0(ima)
20627  k = n0(ima) * max0( ldas0(ima), ldad0(ima) ) + ipad
20628  IF( k .GT. i ) i = k
20629  10 CONTINUE
20630  i = i + ibtnprocs()
20631  maxerr = ( csize * (memlen-i) ) / ( csize*2 + isize*6 )
20632  IF( maxerr .LT. 1 ) THEN
20633  WRITE(outnum,*) 'ERROR: Not enough memory to run MIN tests.'
20634  CALL blacs_abort(-1, 1)
20635  END IF
20636  errdptr = i + 1
20637  erriptr = errdptr + maxerr
20638  nerr = 0
20639  testnum = 0
20640  nfail = 0
20641  nskip = 0
20642 *
20643 * Loop over grids of matrix
20644 *
20645  DO 90 igr = 1, ngrid
20646 *
20647 * allocate process grid for the next batch of tests
20648 *
20649  context = context0(igr)
20650  CALL blacs_gridinfo( context, nprow, npcol, myrow, mycol )
20651  ingrid = ( (myrow.LT.nprow) .AND. (mycol.LT.npcol) )
20652 *
20653  DO 80 isc = 1, nscope
20654  scope = scope0(isc)
20655  DO 70 ito = 1, ntop
20656  top = top0(ito)
20657 *
20658 * If testing multiring ('M') or general tree ('T'), need to
20659 * loop over calls to BLACS_SET to do full test
20660 *
20661  IF( lsame(top, 'M') ) THEN
20662  setwhat = 13
20663  IF( scope .EQ. 'R' ) THEN
20664  istart = -(npcol - 1)
20665  istop = -istart
20666  ELSE IF (scope .EQ. 'C') THEN
20667  istart = -(nprow - 1)
20668  istop = -istart
20669  ELSE
20670  istart = -(nprow*npcol - 1)
20671  istop = -istart
20672  ENDIF
20673  ELSE IF( lsame(top, 'T') ) THEN
20674  setwhat = 14
20675  istart = 1
20676  IF( scope .EQ. 'R' ) THEN
20677  istop = npcol - 1
20678  ELSE IF (scope .EQ. 'C') THEN
20679  istop = nprow - 1
20680  ELSE
20681  istop = nprow*npcol - 1
20682  ENDIF
20683  ELSE
20684  setwhat = 0
20685  istart = 1
20686  istop = 1
20687  ENDIF
20688  DO 60 ima = 1, nmat
20689  m = m0(ima)
20690  n = n0(ima)
20691  ldasrc = ldas0(ima)
20692  ldadst = ldad0(ima)
20693  ldi = ldi0(ima)
20694  ipre = 2 * m
20695  ipost = ipre
20696  preaptr = 1
20697  aptr = preaptr + ipre
20698 *
20699  DO 50 ide = 1, ndest
20700  testnum = testnum + 1
20701  rdest2 = rdest0(ide)
20702  cdest2 = cdest0(ide)
20703 *
20704 * If everyone gets the answer, create some bogus rdest/cdest
20705 * so IF's are easier
20706 *
20707  allrcv = ( (rdest2.EQ.-1) .OR. (cdest2.EQ.-1) )
20708  IF( allrcv ) THEN
20709  rdest = nprow - 1
20710  cdest = npcol - 1
20711  IF (topscohrnt.EQ.0) THEN
20712  itr1 = 0
20713  itr2 = 0
20714  ELSE IF (topscohrnt.EQ.1) THEN
20715  itr1 = 1
20716  itr2 = 1
20717  ELSE
20718  itr1 = 0
20719  itr2 = 1
20720  END IF
20721  ELSE
20722  rdest = rdest2
20723  cdest = cdest2
20724  itc1 = 0
20725  itc2 = 0
20726  END IF
20727  IF( rdest.GE.p0(igr) .OR. cdest.GE.q0(igr) ) THEN
20728  nskip = nskip + 1
20729  GOTO 50
20730  END IF
20731 *
20732  IF( myrow.EQ.rdest .AND. mycol.EQ.cdest ) THEN
20733  lda = ldadst
20734  ELSE
20735  lda = ldasrc
20736  END IF
20737  valptr = aptr + ipost + n * lda
20738  IF( verb .GT. 1 ) THEN
20739  IF( iam .EQ. 0 ) THEN
20740  WRITE(outnum, 6000)
20741  $ testnum, 'RUNNING', scope, top, m, n,
20742  $ ldasrc, ldadst, ldi, rdest2, cdest2,
20743  $ nprow, npcol
20744  END IF
20745  END IF
20746 *
20747 * If I am in scope
20748 *
20749  testok = .true.
20750  IF( ingrid ) THEN
20751  IF( (myrow.EQ.rdest .AND. scope.EQ.'R') .OR.
20752  $ (mycol.EQ.cdest .AND. scope.EQ.'C') .OR.
20753  $ (scope .EQ. 'A') ) THEN
20754 *
20755  k = nerr
20756  DO 40 itr = itr1, itr2
20757  CALL blacs_set(context, 15, itr)
20758  DO 35 itc = itc1, itc2
20759  CALL blacs_set(context, 16, itc)
20760  DO 30 j = istart, istop
20761  IF( j.EQ.0) GOTO 30
20762  IF( setwhat.NE.0 )
20763  $ CALL blacs_set(context, setwhat, j)
20764 *
20765 *
20766 * generate and pad matrix A
20767 *
20768  CALL cinitmat('G','-', m, n, mem(preaptr),
20769  $ lda, ipre, ipost,
20770  $ checkval, testnum,
20771  $ myrow, mycol )
20772 *
20773 * If they exist, pad RA and CA arrays
20774 *
20775  IF( ldi .NE. -1 ) THEN
20776  DO 15 i = 1, n*ldi + ipre + ipost
20777  rmem(i) = icheckval
20778  cmem(i) = icheckval
20779  15 CONTINUE
20780  raptr = 1 + ipre
20781  captr = 1 + ipre
20782  ELSE
20783  DO 20 i = 1, ipre+ipost
20784  rmem(i) = icheckval
20785  cmem(i) = icheckval
20786  20 CONTINUE
20787  raptr = 1
20788  captr = 1
20789  END IF
20790 *
20791  CALL cgamn2d(context, scope, top, m, n,
20792  $ mem(aptr), lda, rmem(raptr),
20793  $ cmem(captr), ldi,
20794  $ rdest2, cdest2)
20795 *
20796 * If I've got the answer, check for errors in
20797 * matrix or padding
20798 *
20799  IF( (myrow.EQ.rdest .AND. mycol.EQ.cdest)
20800  $ .OR. allrcv ) THEN
20801  CALL cchkpad('G','-', m, n,
20802  $ mem(preaptr), lda, rdest,
20803  $ cdest, myrow, mycol,
20804  $ ipre, ipost, checkval,
20805  $ testnum, maxerr, nerr,
20806  $ mem(erriptr),mem(errdptr))
20807  CALL cchkamn(scope, context, m, n,
20808  $ mem(aptr), lda,
20809  $ rmem(raptr), cmem(captr),
20810  $ ldi, testnum, maxerr,nerr,
20811  $ mem(erriptr),mem(errdptr),
20812  $ iseed, mem(valptr))
20813  CALL crcchk(ipre, ipost, icheckval,
20814  $ m, n, rmem, cmem, ldi,
20815  $ myrow, mycol, testnum,
20816  $ maxerr, nerr,
20817  $ mem(erriptr), mem(errdptr))
20818  END IF
20819  30 CONTINUE
20820  CALL blacs_set(context, 16, 0)
20821  35 CONTINUE
20822  CALL blacs_set(context, 15, 0)
20823  40 CONTINUE
20824  testok = ( k .EQ. nerr )
20825  END IF
20826  END IF
20827 *
20828  IF( verb .GT. 1 ) THEN
20829  i = nerr
20830  CALL cbtcheckin(0, outnum, maxerr, nerr,
20831  $ mem(erriptr), mem(errdptr), iseed)
20832  IF( iam .EQ. 0 ) THEN
20833  IF( testok .AND. nerr.EQ.i ) THEN
20834  WRITE(outnum,6000)testnum,'PASSED ',
20835  $ scope, top, m, n, ldasrc,
20836  $ ldadst, ldi, rdest2, cdest2,
20837  $ nprow, npcol
20838  ELSE
20839  nfail = nfail + 1
20840  WRITE(outnum,6000)testnum,'FAILED ',
20841  $ scope, top, m, n, ldasrc,
20842  $ ldadst, ldi, rdest2, cdest2,
20843  $ nprow, npcol
20844  END IF
20845  END IF
20846 *
20847 * Once we've printed out errors, can re-use buf space
20848 *
20849  nerr = 0
20850  END IF
20851  50 CONTINUE
20852  60 CONTINUE
20853  70 CONTINUE
20854  80 CONTINUE
20855  90 CONTINUE
20856 *
20857  IF( verb .LT. 2 ) THEN
20858  nfail = testnum
20859  CALL cbtcheckin( nfail, outnum, maxerr, nerr, mem(erriptr),
20860  $ mem(errdptr), iseed )
20861  END IF
20862  IF( iam .EQ. 0 ) THEN
20863  IF( verb .GT. 1 ) WRITE(outnum,*) ' '
20864  IF( nfail+nskip .EQ. 0 ) THEN
20865  WRITE(outnum, 7000 ) testnum
20866  ELSE
20867  WRITE(outnum, 8000 ) testnum, testnum-nskip-nfail,
20868  $ nskip, nfail
20869  END IF
20870  END IF
20871 *
20872 * Log whether their were any failures
20873 *
20874  testok = allpass( (nfail.EQ.0) )
20875 *
20876  1000 FORMAT('COMPLEX AMN TESTS: BEGIN.' )
20877  2000 FORMAT(1x,a7,3x,10i6)
20878  3000 FORMAT(1x,a7,3x,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,
20879  $ 5x,a1,5x,a1)
20880  4000 FORMAT(' TEST# STATUS SCOPE TOP M N LDAS LDAD LDI ',
20881  $ 'RDEST CDEST P Q')
20882  5000 FORMAT(' ----- ------- ----- --- ----- ----- ----- ----- ----- ',
20883  $ '----- ----- ---- ----')
20884  6000 FORMAT(i6,1x,a7,5x,a1,3x,a1,7i6,2i5)
20885  7000 FORMAT('COMPLEX AMN TESTS: PASSED ALL',
20886  $ i5, ' TESTS.')
20887  8000 FORMAT('COMPLEX AMN TESTS:',i5,' TESTS;',i5,' PASSED,',
20888  $ i5,' SKIPPED,',i5,' FAILED.')
20889 *
20890  RETURN
20891 *
20892 * End of CTESTAMN.
20893 *
20894  END
20895 *
20896  SUBROUTINE cchkamn( SCOPE, ICTXT, M, N, A, LDA, RA, CA, LDI,
20897  $ TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF,
20898  $ ISEED, VALS )
20899 *
20900 * .. Scalar Arguments ..
20901  CHARACTER*1 SCOPE
20902  INTEGER ICTXT, M, N, LDA, LDI, TESTNUM, MAXERR, NERR
20903 * ..
20904 * .. Array Arguments ..
20905  INTEGER RA(*), CA(*), ERRIBUF(6, MAXERR), ISEED(*)
20906  COMPLEX A(LDA,*), ERRDBUF(2, MAXERR), VALS(*)
20907 * ..
20908 * .. External Functions ..
20909  INTEGER IBTMYPROC, IBTNPROCS, IBTSPNUM
20910  REAL SBTEPS, CBTABS
20911  COMPLEX CBTRAN
20912  EXTERNAL IBTMYPROC, IBTNPROCS, IBTSPNUM, CBTRAN, SBTEPS, CBTABS
20913 * ..
20914 * .. External Subroutines ..
20915  EXTERNAL ibtspcoord
20916 * ..
20917 * .. Local Scalars ..
20918  LOGICAL ERROR
20919  INTEGER NPROCS, NNODES, NPROW, NPCOL, MYROW, MYCOL, RAMN, CAMN
20920  INTEGER IAMN, I, J, K, H, DEST, NODE
20921  REAL EPS
20922 * ..
20923 * .. Executable Statements ..
20924 *
20925  nprocs = ibtnprocs()
20926  eps = sbteps()
20927  CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
20928  dest = myrow*nprocs + mycol
20929 *
20930 * Set up seeds to match those used by each proc's genmat call
20931 *
20932  IF( scope .EQ. 'R' ) THEN
20933  nnodes = npcol
20934  DO 10 i = 0, nnodes-1
20935  node = myrow * nprocs + i
20936  iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
20937  iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
20938  iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
20939  iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
20940  10 CONTINUE
20941  ELSE IF( scope .EQ. 'C' ) THEN
20942  nnodes = nprow
20943  DO 20 i = 0, nnodes-1
20944  node = i * nprocs + mycol
20945  iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
20946  iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
20947  iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
20948  iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
20949  20 CONTINUE
20950  ELSE
20951  nnodes = nprow * npcol
20952  DO 30 i = 0, nnodes-1
20953  node = (i / npcol) * nprocs + mod(i, npcol)
20954  iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
20955  iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
20956  iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
20957  iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
20958  30 CONTINUE
20959  END IF
20960 *
20961  DO 100 j = 1, n
20962  DO 90 i = 1, m
20963  h = (j-1)*ldi + i
20964  vals(1) = cbtran( iseed )
20965  iamn = 1
20966  IF( nnodes .GT. 1 ) THEN
20967  DO 40 k = 1, nnodes-1
20968  vals(k+1) = cbtran( iseed(k*4+1) )
20969  IF( cbtabs( vals(k+1) ) .LT. cbtabs( vals(iamn) ) )
20970  $ iamn = k + 1
20971  40 CONTINUE
20972  END IF
20973 *
20974 * If BLACS have not returned same value we've chosen
20975 *
20976  IF( a(i,j) .NE. vals(iamn) ) THEN
20977 *
20978 * If we have RA and CA arrays
20979 *
20980  IF( ldi .NE. -1 ) THEN
20981 *
20982 * Any number having the same absolute value is a valid max
20983 *
20984  k = ibtspnum( scope, ra(h), ca(h), npcol ) + 1
20985  IF( k.GT.0 .AND. k.LE.nnodes ) THEN
20986  error = abs( cbtabs(vals(k)) - cbtabs(vals(iamn)) )
20987  $ .GT. 3*eps
20988  IF( .NOT.error ) iamn = k
20989  ELSE
20990  error = .true.
20991  END IF
20992  ELSE
20993 *
20994 * Error if BLACS answer not same absolute value, or if it
20995 * was not really in the numbers being compared
20996 *
20997  error = abs( cbtabs(a(i,j)) - cbtabs(vals(iamn)) )
20998  $ .GT. 3*eps
20999  IF( .NOT.error ) THEN
21000  DO 50 k = 1, nnodes
21001  IF( vals(k) .EQ. a(i,j) ) GOTO 60
21002  50 CONTINUE
21003  error = .true.
21004  60 CONTINUE
21005  ENDIF
21006  END IF
21007 *
21008 * If the value is in error
21009 *
21010  IF( error ) THEN
21011  nerr = nerr + 1
21012  erribuf(1, nerr) = testnum
21013  erribuf(2, nerr) = nnodes
21014  erribuf(3, nerr) = dest
21015  erribuf(4, nerr) = i
21016  erribuf(5, nerr) = j
21017  erribuf(6, nerr) = 5
21018  errdbuf(1, nerr) = a(i,j)
21019  errdbuf(2, nerr) = vals(iamn)
21020  END IF
21021  END IF
21022 *
21023 * If they are defined, make sure coordinate entries are OK
21024 *
21025  IF( ldi .NE. -1 ) THEN
21026  k = ibtspnum( scope, ra(h), ca(h), npcol ) + 1
21027  IF( k.NE.iamn ) THEN
21028 *
21029 * Make sure more than one proc doesn't have exact same value
21030 * (and therefore there may be more than one valid coordinate
21031 * for a single value)
21032 *
21033  IF( k.GT.nnodes .OR. k.LT.1 ) THEN
21034  error = .true.
21035  ELSE
21036  error = ( vals(k) .NE. vals(iamn) )
21037  END IF
21038  IF( error ) THEN
21039  CALL ibtspcoord( scope, iamn-1, myrow, mycol,
21040  $ npcol, ramn, camn )
21041  IF( ramn .NE. ra(h) ) THEN
21042  nerr = nerr + 1
21043  erribuf(1, nerr) = testnum
21044  erribuf(2, nerr) = nnodes
21045  erribuf(3, nerr) = dest
21046  erribuf(4, nerr) = i
21047  erribuf(5, nerr) = j
21048  erribuf(6, nerr) = -5
21049  errdbuf(1, nerr) = ra(h)
21050  errdbuf(2, nerr) = ramn
21051  END IF
21052  IF( camn .NE. ca(h) ) THEN
21053  nerr = nerr + 1
21054  erribuf(1, nerr) = testnum
21055  erribuf(2, nerr) = nnodes
21056  erribuf(3, nerr) = dest
21057  erribuf(4, nerr) = i
21058  erribuf(5, nerr) = j
21059  erribuf(6, nerr) = -15
21060  errdbuf(1, nerr) = ca(h)
21061  errdbuf(2, nerr) = camn
21062  END IF
21063  END IF
21064  END IF
21065  END IF
21066  90 CONTINUE
21067  100 CONTINUE
21068 *
21069  RETURN
21070 *
21071 * End of CCHKAMN
21072 *
21073  END
21074 *
21075 *
21076  SUBROUTINE zamntest( OUTNUM, VERB, TOPSREPEAT, TOPSCOHRNT, NSCOPE,
21077  $ SCOPE0, NTOP, TOP0, NMAT, M0, N0, LDAS0,
21078  $ LDAD0, LDI0, NDEST, RDEST0, CDEST0, NGRID,
21079  $ CONTEXT0, P0, Q0, ISEED, RMEM, CMEM, RCLEN,
21080  $ MEM, MEMLEN )
21081 *
21082 * -- BLACS tester (version 1.0) --
21083 * University of Tennessee
21084 * December 15, 1994
21085 *
21086 *
21087 * .. Scalar Arguments ..
21088  INTEGER MEMLEN, NDEST, NGRID, NMAT, NSCOPE, NTOP, OUTNUM, RCLEN,
21089  $ TOPSCOHRNT, TOPSREPEAT, VERB
21090 * ..
21091 * .. Array Arguments ..
21092  CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP)
21093  INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT), LDI0(NMAT)
21094  INTEGER RDEST0(NDEST), CDEST0(NDEST), CONTEXT0(NGRID)
21095  INTEGER P0(NGRID), Q0(NGRID), ISEED(*), RMEM(RCLEN), CMEM(RCLEN)
21096  DOUBLE COMPLEX MEM(MEMLEN)
21097 * ..
21098 *
21099 * Purpose
21100 * =======
21101 * ZTESTAMN: Test double complex AMN COMBINE
21102 *
21103 * Arguments
21104 * =========
21105 * OUTNUM (input) INTEGER
21106 * The device number to write output to.
21107 *
21108 * VERB (input) INTEGER
21109 * The level of verbosity (how much printing to do).
21110 *
21111 * NSCOPE (input) INTEGER
21112 * The number of scopes to be tested.
21113 *
21114 * SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE)
21115 * Values of the scopes to be tested.
21116 *
21117 * NTOP (input) INTEGER
21118 * The number of topologies to be tested.
21119 *
21120 * TOP0 (input) CHARACTER*1 array of dimension (NTOP)
21121 * Values of the topologies to be tested.
21122 *
21123 * NMAT (input) INTEGER
21124 * The number of matrices to be tested.
21125 *
21126 * M0 (input) INTEGER array of dimension (NMAT)
21127 * Values of M to be tested.
21128 *
21129 * M0 (input) INTEGER array of dimension (NMAT)
21130 * Values of M to be tested.
21131 *
21132 * N0 (input) INTEGER array of dimension (NMAT)
21133 * Values of N to be tested.
21134 *
21135 * LDAS0 (input) INTEGER array of dimension (NMAT)
21136 * Values of LDAS (leading dimension of A on source process)
21137 * to be tested.
21138 *
21139 * LDAD0 (input) INTEGER array of dimension (NMAT)
21140 * Values of LDAD (leading dimension of A on destination
21141 * process) to be tested.
21142 * LDI0 (input) INTEGER array of dimension (NMAT)
21143 * Values of LDI (leading dimension of RA/CA) to be tested.
21144 * If LDI == -1, these RA/CA should not be accessed.
21145 *
21146 * NDEST (input) INTEGER
21147 * The number of destinations to be tested.
21148 *
21149 * RDEST0 (input) INTEGER array of dimension (NNDEST)
21150 * Values of RDEST (row coordinate of destination) to be
21151 * tested.
21152 *
21153 * CDEST0 (input) INTEGER array of dimension (NNDEST)
21154 * Values of CDEST (column coordinate of destination) to be
21155 * tested.
21156 *
21157 * NGRID (input) INTEGER
21158 * The number of process grids to be tested.
21159 *
21160 * CONTEXT0 (input) INTEGER array of dimension (NGRID)
21161 * The BLACS context handles corresponding to the grids.
21162 *
21163 * P0 (input) INTEGER array of dimension (NGRID)
21164 * Values of P (number of process rows, NPROW).
21165 *
21166 * Q0 (input) INTEGER array of dimension (NGRID)
21167 * Values of Q (number of process columns, NPCOL).
21168 *
21169 * ISEED (workspace) INTEGER array of dimension ( MAX(NPROCS, NTESTS) )
21170 * Workspace used to hold each process's random number SEED.
21171 * This requires NPROCS (number of processor) elements.
21172 * If VERB < 2, this workspace also serves to indicate which
21173 * tests fail. This requires workspace of NTESTS
21174 * (number of tests performed).
21175 *
21176 * RMEM (workspace) INTEGER array of dimension (RCLEN)
21177 * Used for all RA arrays, and their pre and post padding.
21178 *
21179 * CMEM (workspace) INTEGER array of dimension (RCLEN)
21180 * Used for all CA arrays, and their pre and post padding.
21181 *
21182 * RCLEN (input) INTEGER
21183 * The length, in elements, of RMEM and CMEM.
21184 *
21185 * MEM (workspace) DOUBLE COMPLEX array of dimension (MEMLEN)
21186 * Used for all other workspaces, including the matrix A,
21187 * and its pre and post padding.
21188 *
21189 * MEMLEN (input) INTEGER
21190 * The length, in elements, of MEM.
21191 *
21192 * =====================================================================
21193 *
21194 * .. External Functions ..
21195  LOGICAL ALLPASS, LSAME
21196  INTEGER IBTMYPROC, IBTNPROCS, IBTSIZEOF
21197  EXTERNAL ALLPASS, LSAME, IBTMYPROC, IBTNPROCS, IBTSIZEOF
21198 * ..
21199 * .. External Subroutines ..
21200  EXTERNAL blacs_gridinfo, zgamn2d
21201  EXTERNAL zinitmat, zchkpad, zbtcheckin
21202 * ..
21203 * .. Local Scalars ..
21204  CHARACTER*1 SCOPE, TOP
21205  LOGICAL INGRID, TESTOK, ALLRCV
21206  INTEGER APTR, CAPTR, CDEST, CDEST2, CONTEXT, ERRDPTR, ERRIPTR, I,
21207  $ IAM, ICHECKVAL, IDE, IGR, IMA, IPAD, IPOST, IPRE, ISC,
21208  $ isize, istart, istop, itc, itc1, itc2, ito, itr, itr1,
21209  $ itr2, j, k, lda, ldadst, ldasrc, ldi, m, maxerr, mycol,
21210  $ myrow, n, nerr, nfail, npcol, nprow, nskip, preaptr,
21211  $ raptr, rdest, rdest2, setwhat, testnum, valptr, zsize
21212  DOUBLE COMPLEX CHECKVAL
21213 * ..
21214 * .. Executable Statements ..
21215 *
21216 * Choose padding value, and make it unique
21217 *
21218  checkval = dcmplx( -9.11d0, -9.21d0 )
21219  iam = ibtmyproc()
21220  checkval = iam * checkval
21221  isize = ibtsizeof('I')
21222  zsize = ibtsizeof('Z')
21223  icheckval = -iam
21224 *
21225 * Verify file parameters
21226 *
21227  IF( iam .EQ. 0 ) THEN
21228  WRITE(outnum, *) ' '
21229  WRITE(outnum, *) ' '
21230  WRITE(outnum, 1000 )
21231  IF( verb .GT. 0 ) THEN
21232  WRITE(outnum,*) ' '
21233  WRITE(outnum, 2000) 'NSCOPE:', nscope
21234  WRITE(outnum, 3000) ' SCOPE:', ( scope0(i), i = 1, nscope )
21235  WRITE(outnum, 2000) 'TReps :', topsrepeat
21236  WRITE(outnum, 2000) 'TCohr :', topscohrnt
21237  WRITE(outnum, 2000) 'NTOP :', ntop
21238  WRITE(outnum, 3000) ' TOP :', ( top0(i), i = 1, ntop )
21239  WRITE(outnum, 2000) 'NMAT :', nmat
21240  WRITE(outnum, 2000) ' M :', ( m0(i), i = 1, nmat )
21241  WRITE(outnum, 2000) ' N :', ( n0(i), i = 1, nmat )
21242  WRITE(outnum, 2000) ' LDAS :', ( ldas0(i), i = 1, nmat )
21243  WRITE(outnum, 2000) ' LDAD :', ( ldad0(i), i = 1, nmat )
21244  WRITE(outnum, 2000) ' LDI :', ( ldi0(i), i = 1, nmat )
21245  WRITE(outnum, 2000) 'NDEST :', ndest
21246  WRITE(outnum, 2000) ' RDEST:',( rdest0(i), i = 1, ndest )
21247  WRITE(outnum, 2000) ' CDEST:',( cdest0(i), i = 1, ndest )
21248  WRITE(outnum, 2000) 'NGRIDS:', ngrid
21249  WRITE(outnum, 2000) ' P :', ( p0(i), i = 1, ngrid )
21250  WRITE(outnum, 2000) ' Q :', ( q0(i), i = 1, ngrid )
21251  WRITE(outnum, 2000) 'VERB :', verb
21252  WRITE(outnum,*) ' '
21253  END IF
21254  IF( verb .GT. 1 ) THEN
21255  WRITE(outnum,4000)
21256  WRITE(outnum,5000)
21257  END IF
21258  END IF
21259  IF (topsrepeat.EQ.0) THEN
21260  itr1 = 0
21261  itr2 = 0
21262  ELSE IF (topsrepeat.EQ.1) THEN
21263  itr1 = 1
21264  itr2 = 1
21265  ELSE
21266  itr1 = 0
21267  itr2 = 1
21268  END IF
21269 *
21270 * Find biggest matrix, so we know where to stick error info
21271 *
21272  i = 0
21273  DO 10 ima = 1, nmat
21274  ipad = 4 * m0(ima)
21275  k = n0(ima) * max0( ldas0(ima), ldad0(ima) ) + ipad
21276  IF( k .GT. i ) i = k
21277  10 CONTINUE
21278  i = i + ibtnprocs()
21279  maxerr = ( zsize * (memlen-i) ) / ( zsize*2 + isize*6 )
21280  IF( maxerr .LT. 1 ) THEN
21281  WRITE(outnum,*) 'ERROR: Not enough memory to run MIN tests.'
21282  CALL blacs_abort(-1, 1)
21283  END IF
21284  errdptr = i + 1
21285  erriptr = errdptr + maxerr
21286  nerr = 0
21287  testnum = 0
21288  nfail = 0
21289  nskip = 0
21290 *
21291 * Loop over grids of matrix
21292 *
21293  DO 90 igr = 1, ngrid
21294 *
21295 * allocate process grid for the next batch of tests
21296 *
21297  context = context0(igr)
21298  CALL blacs_gridinfo( context, nprow, npcol, myrow, mycol )
21299  ingrid = ( (myrow.LT.nprow) .AND. (mycol.LT.npcol) )
21300 *
21301  DO 80 isc = 1, nscope
21302  scope = scope0(isc)
21303  DO 70 ito = 1, ntop
21304  top = top0(ito)
21305 *
21306 * If testing multiring ('M') or general tree ('T'), need to
21307 * loop over calls to BLACS_SET to do full test
21308 *
21309  IF( lsame(top, 'M') ) THEN
21310  setwhat = 13
21311  IF( scope .EQ. 'R' ) THEN
21312  istart = -(npcol - 1)
21313  istop = -istart
21314  ELSE IF (scope .EQ. 'C') THEN
21315  istart = -(nprow - 1)
21316  istop = -istart
21317  ELSE
21318  istart = -(nprow*npcol - 1)
21319  istop = -istart
21320  ENDIF
21321  ELSE IF( lsame(top, 'T') ) THEN
21322  setwhat = 14
21323  istart = 1
21324  IF( scope .EQ. 'R' ) THEN
21325  istop = npcol - 1
21326  ELSE IF (scope .EQ. 'C') THEN
21327  istop = nprow - 1
21328  ELSE
21329  istop = nprow*npcol - 1
21330  ENDIF
21331  ELSE
21332  setwhat = 0
21333  istart = 1
21334  istop = 1
21335  ENDIF
21336  DO 60 ima = 1, nmat
21337  m = m0(ima)
21338  n = n0(ima)
21339  ldasrc = ldas0(ima)
21340  ldadst = ldad0(ima)
21341  ldi = ldi0(ima)
21342  ipre = 2 * m
21343  ipost = ipre
21344  preaptr = 1
21345  aptr = preaptr + ipre
21346 *
21347  DO 50 ide = 1, ndest
21348  testnum = testnum + 1
21349  rdest2 = rdest0(ide)
21350  cdest2 = cdest0(ide)
21351 *
21352 * If everyone gets the answer, create some bogus rdest/cdest
21353 * so IF's are easier
21354 *
21355  allrcv = ( (rdest2.EQ.-1) .OR. (cdest2.EQ.-1) )
21356  IF( allrcv ) THEN
21357  rdest = nprow - 1
21358  cdest = npcol - 1
21359  IF (topscohrnt.EQ.0) THEN
21360  itr1 = 0
21361  itr2 = 0
21362  ELSE IF (topscohrnt.EQ.1) THEN
21363  itr1 = 1
21364  itr2 = 1
21365  ELSE
21366  itr1 = 0
21367  itr2 = 1
21368  END IF
21369  ELSE
21370  rdest = rdest2
21371  cdest = cdest2
21372  itc1 = 0
21373  itc2 = 0
21374  END IF
21375  IF( rdest.GE.p0(igr) .OR. cdest.GE.q0(igr) ) THEN
21376  nskip = nskip + 1
21377  GOTO 50
21378  END IF
21379 *
21380  IF( myrow.EQ.rdest .AND. mycol.EQ.cdest ) THEN
21381  lda = ldadst
21382  ELSE
21383  lda = ldasrc
21384  END IF
21385  valptr = aptr + ipost + n * lda
21386  IF( verb .GT. 1 ) THEN
21387  IF( iam .EQ. 0 ) THEN
21388  WRITE(outnum, 6000)
21389  $ testnum, 'RUNNING', scope, top, m, n,
21390  $ ldasrc, ldadst, ldi, rdest2, cdest2,
21391  $ nprow, npcol
21392  END IF
21393  END IF
21394 *
21395 * If I am in scope
21396 *
21397  testok = .true.
21398  IF( ingrid ) THEN
21399  IF( (myrow.EQ.rdest .AND. scope.EQ.'R') .OR.
21400  $ (mycol.EQ.cdest .AND. scope.EQ.'C') .OR.
21401  $ (scope .EQ. 'A') ) THEN
21402 *
21403  k = nerr
21404  DO 40 itr = itr1, itr2
21405  CALL blacs_set(context, 15, itr)
21406  DO 35 itc = itc1, itc2
21407  CALL blacs_set(context, 16, itc)
21408  DO 30 j = istart, istop
21409  IF( j.EQ.0) GOTO 30
21410  IF( setwhat.NE.0 )
21411  $ CALL blacs_set(context, setwhat, j)
21412 *
21413 *
21414 * generate and pad matrix A
21415 *
21416  CALL zinitmat('G','-', m, n, mem(preaptr),
21417  $ lda, ipre, ipost,
21418  $ checkval, testnum,
21419  $ myrow, mycol )
21420 *
21421 * If they exist, pad RA and CA arrays
21422 *
21423  IF( ldi .NE. -1 ) THEN
21424  DO 15 i = 1, n*ldi + ipre + ipost
21425  rmem(i) = icheckval
21426  cmem(i) = icheckval
21427  15 CONTINUE
21428  raptr = 1 + ipre
21429  captr = 1 + ipre
21430  ELSE
21431  DO 20 i = 1, ipre+ipost
21432  rmem(i) = icheckval
21433  cmem(i) = icheckval
21434  20 CONTINUE
21435  raptr = 1
21436  captr = 1
21437  END IF
21438 *
21439  CALL zgamn2d(context, scope, top, m, n,
21440  $ mem(aptr), lda, rmem(raptr),
21441  $ cmem(captr), ldi,
21442  $ rdest2, cdest2)
21443 *
21444 * If I've got the answer, check for errors in
21445 * matrix or padding
21446 *
21447  IF( (myrow.EQ.rdest .AND. mycol.EQ.cdest)
21448  $ .OR. allrcv ) THEN
21449  CALL zchkpad('G','-', m, n,
21450  $ mem(preaptr), lda, rdest,
21451  $ cdest, myrow, mycol,
21452  $ ipre, ipost, checkval,
21453  $ testnum, maxerr, nerr,
21454  $ mem(erriptr),mem(errdptr))
21455  CALL zchkamn(scope, context, m, n,
21456  $ mem(aptr), lda,
21457  $ rmem(raptr), cmem(captr),
21458  $ ldi, testnum, maxerr,nerr,
21459  $ mem(erriptr),mem(errdptr),
21460  $ iseed, mem(valptr))
21461  CALL zrcchk(ipre, ipost, icheckval,
21462  $ m, n, rmem, cmem, ldi,
21463  $ myrow, mycol, testnum,
21464  $ maxerr, nerr,
21465  $ mem(erriptr), mem(errdptr))
21466  END IF
21467  30 CONTINUE
21468  CALL blacs_set(context, 16, 0)
21469  35 CONTINUE
21470  CALL blacs_set(context, 15, 0)
21471  40 CONTINUE
21472  testok = ( k .EQ. nerr )
21473  END IF
21474  END IF
21475 *
21476  IF( verb .GT. 1 ) THEN
21477  i = nerr
21478  CALL zbtcheckin(0, outnum, maxerr, nerr,
21479  $ mem(erriptr), mem(errdptr), iseed)
21480  IF( iam .EQ. 0 ) THEN
21481  IF( testok .AND. nerr.EQ.i ) THEN
21482  WRITE(outnum,6000)testnum,'PASSED ',
21483  $ scope, top, m, n, ldasrc,
21484  $ ldadst, ldi, rdest2, cdest2,
21485  $ nprow, npcol
21486  ELSE
21487  nfail = nfail + 1
21488  WRITE(outnum,6000)testnum,'FAILED ',
21489  $ scope, top, m, n, ldasrc,
21490  $ ldadst, ldi, rdest2, cdest2,
21491  $ nprow, npcol
21492  END IF
21493  END IF
21494 *
21495 * Once we've printed out errors, can re-use buf space
21496 *
21497  nerr = 0
21498  END IF
21499  50 CONTINUE
21500  60 CONTINUE
21501  70 CONTINUE
21502  80 CONTINUE
21503  90 CONTINUE
21504 *
21505  IF( verb .LT. 2 ) THEN
21506  nfail = testnum
21507  CALL zbtcheckin( nfail, outnum, maxerr, nerr, mem(erriptr),
21508  $ mem(errdptr), iseed )
21509  END IF
21510  IF( iam .EQ. 0 ) THEN
21511  IF( verb .GT. 1 ) WRITE(outnum,*) ' '
21512  IF( nfail+nskip .EQ. 0 ) THEN
21513  WRITE(outnum, 7000 ) testnum
21514  ELSE
21515  WRITE(outnum, 8000 ) testnum, testnum-nskip-nfail,
21516  $ nskip, nfail
21517  END IF
21518  END IF
21519 *
21520 * Log whether their were any failures
21521 *
21522  testok = allpass( (nfail.EQ.0) )
21523 *
21524  1000 FORMAT('DOUBLE COMPLEX AMN TESTS: BEGIN.' )
21525  2000 FORMAT(1x,a7,3x,10i6)
21526  3000 FORMAT(1x,a7,3x,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,
21527  $ 5x,a1,5x,a1)
21528  4000 FORMAT(' TEST# STATUS SCOPE TOP M N LDAS LDAD LDI ',
21529  $ 'RDEST CDEST P Q')
21530  5000 FORMAT(' ----- ------- ----- --- ----- ----- ----- ----- ----- ',
21531  $ '----- ----- ---- ----')
21532  6000 FORMAT(i6,1x,a7,5x,a1,3x,a1,7i6,2i5)
21533  7000 FORMAT('DOUBLE COMPLEX AMN TESTS: PASSED ALL',
21534  $ i5, ' TESTS.')
21535  8000 FORMAT('DOUBLE COMPLEX AMN TESTS:',i5,' TESTS;',i5,' PASSED,',
21536  $ i5,' SKIPPED,',i5,' FAILED.')
21537 *
21538  RETURN
21539 *
21540 * End of ZTESTAMN.
21541 *
21542  END
21543 *
21544  SUBROUTINE zchkamn( SCOPE, ICTXT, M, N, A, LDA, RA, CA, LDI,
21545  $ TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF,
21546  $ ISEED, VALS )
21547 *
21548 * .. Scalar Arguments ..
21549  CHARACTER*1 SCOPE
21550  INTEGER ICTXT, M, N, LDA, LDI, TESTNUM, MAXERR, NERR
21551 * ..
21552 * .. Array Arguments ..
21553  INTEGER RA(*), CA(*), ERRIBUF(6, MAXERR), ISEED(*)
21554  DOUBLE COMPLEX A(LDA,*), ERRDBUF(2, MAXERR), VALS(*)
21555 * ..
21556 * .. External Functions ..
21557  INTEGER IBTMYPROC, IBTNPROCS, IBTSPNUM
21558  DOUBLE PRECISION DBTEPS, ZBTABS
21559  DOUBLE COMPLEX ZBTRAN
21560  EXTERNAL ibtmyproc, ibtnprocs, ibtspnum, zbtran, dbteps, zbtabs
21561 * ..
21562 * .. External Subroutines ..
21563  EXTERNAL ibtspcoord
21564 * ..
21565 * .. Local Scalars ..
21566  LOGICAL ERROR
21567  INTEGER NPROCS, NNODES, NPROW, NPCOL, MYROW, MYCOL, RAMN, CAMN
21568  INTEGER IAMN, I, J, K, H, DEST, NODE
21569  DOUBLE PRECISION EPS
21570 * ..
21571 * .. Executable Statements ..
21572 *
21573  nprocs = ibtnprocs()
21574  eps = dbteps()
21575  CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
21576  dest = myrow*nprocs + mycol
21577 *
21578 * Set up seeds to match those used by each proc's genmat call
21579 *
21580  IF( scope .EQ. 'R' ) THEN
21581  nnodes = npcol
21582  DO 10 i = 0, nnodes-1
21583  node = myrow * nprocs + i
21584  iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
21585  iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
21586  iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
21587  iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
21588  10 CONTINUE
21589  ELSE IF( scope .EQ. 'C' ) THEN
21590  nnodes = nprow
21591  DO 20 i = 0, nnodes-1
21592  node = i * nprocs + mycol
21593  iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
21594  iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
21595  iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
21596  iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
21597  20 CONTINUE
21598  ELSE
21599  nnodes = nprow * npcol
21600  DO 30 i = 0, nnodes-1
21601  node = (i / npcol) * nprocs + mod(i, npcol)
21602  iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
21603  iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
21604  iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
21605  iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
21606  30 CONTINUE
21607  END IF
21608 *
21609  DO 100 j = 1, n
21610  DO 90 i = 1, m
21611  h = (j-1)*ldi + i
21612  vals(1) = zbtran( iseed )
21613  iamn = 1
21614  IF( nnodes .GT. 1 ) THEN
21615  DO 40 k = 1, nnodes-1
21616  vals(k+1) = zbtran( iseed(k*4+1) )
21617  IF( zbtabs( vals(k+1) ) .LT. zbtabs( vals(iamn) ) )
21618  $ iamn = k + 1
21619  40 CONTINUE
21620  END IF
21621 *
21622 * If BLACS have not returned same value we've chosen
21623 *
21624  IF( a(i,j) .NE. vals(iamn) ) THEN
21625 *
21626 * If we have RA and CA arrays
21627 *
21628  IF( ldi .NE. -1 ) THEN
21629 *
21630 * Any number having the same absolute value is a valid max
21631 *
21632  k = ibtspnum( scope, ra(h), ca(h), npcol ) + 1
21633  IF( k.GT.0 .AND. k.LE.nnodes ) THEN
21634  error = abs( zbtabs(vals(k)) - zbtabs(vals(iamn)) )
21635  $ .GT. 3*eps
21636  IF( .NOT.error ) iamn = k
21637  ELSE
21638  error = .true.
21639  END IF
21640  ELSE
21641 *
21642 * Error if BLACS answer not same absolute value, or if it
21643 * was not really in the numbers being compared
21644 *
21645  error = abs( zbtabs(a(i,j)) - zbtabs(vals(iamn)) )
21646  $ .GT. 3*eps
21647  IF( .NOT.error ) THEN
21648  DO 50 k = 1, nnodes
21649  IF( vals(k) .EQ. a(i,j) ) GOTO 60
21650  50 CONTINUE
21651  error = .true.
21652  60 CONTINUE
21653  ENDIF
21654  END IF
21655 *
21656 * If the value is in error
21657 *
21658  IF( error ) THEN
21659  nerr = nerr + 1
21660  erribuf(1, nerr) = testnum
21661  erribuf(2, nerr) = nnodes
21662  erribuf(3, nerr) = dest
21663  erribuf(4, nerr) = i
21664  erribuf(5, nerr) = j
21665  erribuf(6, nerr) = 5
21666  errdbuf(1, nerr) = a(i,j)
21667  errdbuf(2, nerr) = vals(iamn)
21668  END IF
21669  END IF
21670 *
21671 * If they are defined, make sure coordinate entries are OK
21672 *
21673  IF( ldi .NE. -1 ) THEN
21674  k = ibtspnum( scope, ra(h), ca(h), npcol ) + 1
21675  IF( k.NE.iamn ) THEN
21676 *
21677 * Make sure more than one proc doesn't have exact same value
21678 * (and therefore there may be more than one valid coordinate
21679 * for a single value)
21680 *
21681  IF( k.GT.nnodes .OR. k.LT.1 ) THEN
21682  error = .true.
21683  ELSE
21684  error = ( vals(k) .NE. vals(iamn) )
21685  END IF
21686  IF( error ) THEN
21687  CALL ibtspcoord( scope, iamn-1, myrow, mycol,
21688  $ npcol, ramn, camn )
21689  IF( ramn .NE. ra(h) ) THEN
21690  nerr = nerr + 1
21691  erribuf(1, nerr) = testnum
21692  erribuf(2, nerr) = nnodes
21693  erribuf(3, nerr) = dest
21694  erribuf(4, nerr) = i
21695  erribuf(5, nerr) = j
21696  erribuf(6, nerr) = -5
21697  errdbuf(1, nerr) = ra(h)
21698  errdbuf(2, nerr) = ramn
21699  END IF
21700  IF( camn .NE. ca(h) ) THEN
21701  nerr = nerr + 1
21702  erribuf(1, nerr) = testnum
21703  erribuf(2, nerr) = nnodes
21704  erribuf(3, nerr) = dest
21705  erribuf(4, nerr) = i
21706  erribuf(5, nerr) = j
21707  erribuf(6, nerr) = -15
21708  errdbuf(1, nerr) = ca(h)
21709  errdbuf(2, nerr) = camn
21710  END IF
21711  END IF
21712  END IF
21713  END IF
21714  90 CONTINUE
21715  100 CONTINUE
21716 *
21717  RETURN
21718 *
21719 * End of ZCHKAMN
21720 *
21721  END
21722 *
cmplx
float cmplx[2]
Definition: pblas.h:132
cbtabs
real function cbtabs(VAL)
Definition: blacstest.f:13708
max
#define max(A, B)
Definition: pcgemr.c:180
bttranschar
subroutine bttranschar(TRANSTO, N, CMEM, IMEM)
Definition: blacstest.f:1039
csdrvtest
subroutine csdrvtest(OUTNUM, VERB, NSHAPE, UPLO0, DIAG0, NMAT, M0, N0, LDAS0, LDAD0, NSRC, RSRC0, CSRC0, RDEST0, CDEST0, NGRID, CONTEXT0, P0, Q0, TFAIL, MEM, MEMLEN)
Definition: blacstest.f:3237
dbsbrtest
subroutine dbsbrtest(OUTNUM, VERB, NSCOPE, SCOPE0, NTOP, TOP0, NSHAPE, UPLO0, DIAG0, NMAT, M0, N0, LDAS0, LDAD0, NSRC, RSRC0, CSRC0, NGRID, CONTEXT0, P0, Q0, TFAIL, MEM, MEMLEN)
Definition: blacstest.f:4755
iamntest
subroutine iamntest(OUTNUM, VERB, TOPSREPEAT, TOPSCOHRNT, NSCOPE, SCOPE0, NTOP, TOP0, NMAT, M0, N0, LDAS0, LDAD0, LDI0, NDEST, RDEST0, CDEST0, NGRID, CONTEXT0, P0, Q0, ISEED, RMEM, CMEM, RCLEN, MEM, MEMLEN)
Definition: blacstest.f:18499
iinitmat
subroutine iinitmat(UPLO, DIAG, M, N, MEM, LDA, IPRE, IPOST, CHECKVAL, TESTNUM, MYROW, MYCOL)
Definition: blacstest.f:6394
zrcchk
subroutine zrcchk(IPRE, IPOST, PADVAL, M, N, RA, CA, LDI, MYROW, MYCOL, TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF)
Definition: blacstest.f:18148
rdcomb
subroutine rdcomb(MEMUSED, MEM, MEMLEN, CMEMUSED, CMEM, CMEMLEN, OUTNUM)
Definition: blacstest.f:5998
zchkamx
subroutine zchkamx(SCOPE, ICTXT, M, N, A, LDA, RA, CA, LDI, TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF, ISEED, VALS)
Definition: blacstest.f:18317
ibtspcoord
subroutine ibtspcoord(SCOPE, PNUM, MYROW, MYCOL, NPCOL, PROW, PCOL)
Definition: blacstest.f:14850
spadmat
subroutine spadmat(UPLO, DIAG, M, N, MEM, LDA, IPRE, IPOST, CHECKVAL)
Definition: blacstest.f:7572
srcchk
subroutine srcchk(IPRE, IPOST, PADVAL, M, N, RA, CA, LDI, MYROW, MYCOL, TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF)
Definition: blacstest.f:15701
ichkpad
subroutine ichkpad(UPLO, DIAG, M, N, MEM, LDA, RSRC, CSRC, MYROW, MYCOL, IPRE, IPOST, CHECKVAL, TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF)
Definition: blacstest.f:6682
schkamn
subroutine schkamn(SCOPE, ICTXT, M, N, A, LDA, RA, CA, LDI, TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF, ISEED, VALS)
Definition: blacstest.f:19607
zbtran
double complex function zbtran(ISEED)
Definition: blacstest.f:10751
dbteps
double precision function dbteps()
Definition: blacstest.f:13136
ibtmyproc
integer function ibtmyproc()
Definition: btprim.f:47
cchkpad
subroutine cchkpad(UPLO, DIAG, M, N, MEM, LDA, RSRC, CSRC, MYROW, MYCOL, IPRE, IPOST, CHECKVAL, TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF)
Definition: blacstest.f:9872
sbtran
real function sbtran(ISEED)
Definition: blacstest.f:7555
dgenmat
subroutine dgenmat(M, N, A, LDA, TESTNUM, MYROW, MYCOL)
Definition: blacstest.f:8544
damxtest
subroutine damxtest(OUTNUM, VERB, TOPSREPEAT, TOPSCOHRNT, NSCOPE, SCOPE0, NTOP, TOP0, NMAT, M0, N0, LDAS0, LDAD0, LDI0, NDEST, RDEST0, CDEST0, NGRID, CONTEXT0, P0, Q0, ISEED, RMEM, CMEM, RCLEN, MEM, MEMLEN)
Definition: blacstest.f:16050
isdrvtest
subroutine isdrvtest(OUTNUM, VERB, NSHAPE, UPLO0, DIAG0, NMAT, M0, N0, LDAS0, LDAD0, NSRC, RSRC0, CSRC0, RDEST0, CDEST0, NGRID, CONTEXT0, P0, Q0, TFAIL, MEM, MEMLEN)
Definition: blacstest.f:2205
lsame
logical function lsame(CA, CB)
Definition: tools.f:1724
cgenmat
subroutine cgenmat(M, N, A, LDA, TESTNUM, MYROW, MYCOL)
Definition: blacstest.f:9608
zlarnd
double complex function zlarnd(IDIST, ISEED)
Definition: tools.f:1899
cchksum
subroutine cchksum(SCOPE, ICTXT, M, N, A, LDA, TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF, ISEED)
Definition: blacstest.f:13715
btrecv
subroutine btrecv(DTYPE, N, BUFF, SRC, MSGID)
Definition: btprim.f:207
zsdrvtest
subroutine zsdrvtest(OUTNUM, VERB, NSHAPE, UPLO0, DIAG0, NMAT, M0, N0, LDAS0, LDAD0, NSRC, RSRC0, CSRC0, RDEST0, CDEST0, NGRID, CONTEXT0, P0, Q0, TFAIL, MEM, MEMLEN)
Definition: blacstest.f:3581
runtests
subroutine runtests(MEM, MEMLEN, CMEM, CMEMLEN, PREC, NPREC, OUTNUM, VERB, TESTSDRV, TESTBSBR, TESTCOMB, TESTAUX)
Definition: blacstest.f:181
zprinterrs
subroutine zprinterrs(OUTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF, COUNTING, TFAILED)
Definition: blacstest.f:11406
freegrids
subroutine freegrids(NGRIDS, CONTEXTS)
Definition: blacstest.f:668
ichkamx
subroutine ichkamx(SCOPE, ICTXT, M, N, A, LDA, RA, CA, LDI, TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF, ISEED, VALS)
Definition: blacstest.f:15058
dchkamx
subroutine dchkamx(SCOPE, ICTXT, M, N, A, LDA, RA, CA, LDI, TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF, ISEED, VALS)
Definition: blacstest.f:16685
dlamch
double precision function dlamch(CMACH)
Definition: tools.f:10
btinfo
subroutine btinfo(TEST, MEMUSED, MEM, MEMLEN, CMEMUSED, CMEM, CMEMLEN, OUTNUM, NOP, NSCOPE, TREP, TCOH, NTOP, NSHAPE, NMAT, NSRC, NGRID, OPPTR, SCOPEPTR, TOPPTR, UPLOPTR, DIAGPTR, MPTR, NPTR, LDSPTR, LDDPTR, LDIPTR, RSRCPTR, CSRCPTR, RDESTPTR, CDESTPTR, PPTR, QPTR)
Definition: blacstest.f:1063
zchksum
subroutine zchksum(SCOPE, ICTXT, M, N, A, LDA, TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF, ISEED)
Definition: blacstest.f:14264
sbtcheckin
subroutine sbtcheckin(NFTESTS, OUTNUM, MAXERR, NERR, IERR, SVAL, TFAILED)
Definition: blacstest.f:7341
ibtmsgid
integer function ibtmsgid()
Definition: blacstest.f:1361
makegrids
subroutine makegrids(CONTEXTS, OUTNUM, NGRIDS, P, Q)
Definition: blacstest.f:640
slamch
real function slamch(CMACH)
Definition: tools.f:867
dprinterrs
subroutine dprinterrs(OUTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF, COUNTING, TFAILED)
Definition: blacstest.f:9276
ichkamn
subroutine ichkamn(SCOPE, ICTXT, M, N, A, LDA, RA, CA, LDI, TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF, ISEED, VALS)
Definition: blacstest.f:18964
zchkmat
subroutine zchkmat(UPLO, DIAG, M, N, A, LDA, RSRC, CSRC, MYROW, MYCOL, TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF)
Definition: blacstest.f:11201
dpadmat
subroutine dpadmat(UPLO, DIAG, M, N, MEM, LDA, IPRE, IPOST, CHECKVAL)
Definition: blacstest.f:8636
dchkmat
subroutine dchkmat(UPLO, DIAG, M, N, A, LDA, RSRC, CSRC, MYROW, MYCOL, TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF)
Definition: blacstest.f:9071
zbtabs
double precision function zbtabs(VAL)
Definition: blacstest.f:14257
rdbsbr
subroutine rdbsbr(MEMUSED, MEM, MEMLEN, CMEMUSED, CMEM, CMEMLEN, OUTNUM)
Definition: blacstest.f:1914
chkmatdat
subroutine chkmatdat(NOUT, INFILE, TSTFLAG, NMAT, M0, N0, LDAS0, LDAD0, LDI0)
Definition: blacstest.f:1791
dinitmat
subroutine dinitmat(UPLO, DIAG, M, N, MEM, LDA, IPRE, IPOST, CHECKVAL, TESTNUM, MYROW, MYCOL)
Definition: blacstest.f:8527
cinitmat
subroutine cinitmat(UPLO, DIAG, M, N, MEM, LDA, IPRE, IPOST, CHECKVAL, TESTNUM, MYROW, MYCOL)
Definition: blacstest.f:9591
zgenmat
subroutine zgenmat(M, N, A, LDA, TESTNUM, MYROW, MYCOL)
Definition: blacstest.f:10676
dlarnd
double precision function dlarnd(IDIST, ISEED)
Definition: tools.f:1811
sbtabs
real function sbtabs(VAL)
Definition: blacstest.f:12552
ibtran
integer function ibtran(ISEED)
Definition: blacstest.f:6486
crcchk
subroutine crcchk(IPRE, IPOST, PADVAL, M, N, RA, CA, LDI, MYROW, MYCOL, TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF)
Definition: blacstest.f:17331
ibtcheckin
subroutine ibtcheckin(NFTESTS, OUTNUM, MAXERR, NERR, IERR, IVAL, TFAILED)
Definition: blacstest.f:6272
csumtest
subroutine csumtest(OUTNUM, VERB, TOPSREPEAT, TOPSCOHRNT, NSCOPE, SCOPE0, NTOP, TOP0, NMAT, M0, N0, LDAS0, LDAD0, NDEST, RDEST0, CDEST0, NGRID, CONTEXT0, P0, Q0, ISEED, MEM, MEMLEN)
Definition: blacstest.f:13287
btunpack
subroutine btunpack(TEST, MEM, MEMLEN, NOP, NSCOPE, TREP, TCOH, NTOP, NSHAPE, NMAT, NSRC, NGRID, OPPTR, SCOPEPTR, TOPPTR, UPLOPTR, DIAGPTR, MPTR, NPTR, LDSPTR, LDDPTR, LDIPTR, RSRCPTR, CSRCPTR, RDESTPTR, CDESTPTR, PPTR, QPTR)
Definition: blacstest.f:1397
btsend
subroutine btsend(DTYPE, N, BUFF, DEST, MSGID)
Definition: btprim.f:115
cbtcheckin
subroutine cbtcheckin(NFTESTS, OUTNUM, MAXERR, NERR, IERR, CVAL, TFAILED)
Definition: blacstest.f:9469
auxtest
subroutine auxtest(OUTNUM, MEM, MEMLEN)
Definition: blacstest.f:681
zpadmat
subroutine zpadmat(UPLO, DIAG, M, N, MEM, LDA, IPRE, IPOST, CHECKVAL)
Definition: blacstest.f:10766
safeindex
integer function safeindex(INDX, SIZE1, SIZE2)
Definition: blacstest.f:1517
ipadmat
subroutine ipadmat(UPLO, DIAG, M, N, MEM, LDA, IPRE, IPOST, CHECKVAL)
Definition: blacstest.f:6508
zchkamn
subroutine zchkamn(SCOPE, ICTXT, M, N, A, LDA, RA, CA, LDI, TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF, ISEED, VALS)
Definition: blacstest.f:21547
cchkamx
subroutine cchkamx(SCOPE, ICTXT, M, N, A, LDA, RA, CA, LDI, TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF, ISEED, VALS)
Definition: blacstest.f:17500
iprinterrs
subroutine iprinterrs(OUTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF, COUNTING, TFAILED)
Definition: blacstest.f:7148
schkpad
subroutine schkpad(UPLO, DIAG, M, N, MEM, LDA, RSRC, CSRC, MYROW, MYCOL, IPRE, IPOST, CHECKVAL, TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF)
Definition: blacstest.f:7746
schkmat
subroutine schkmat(UPLO, DIAG, M, N, A, LDA, RSRC, CSRC, MYROW, MYCOL, TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF)
Definition: blacstest.f:8007
ichksum
subroutine ichksum(SCOPE, ICTXT, M, N, A, LDA, TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF, ISEED)
Definition: blacstest.f:12034
ibtabs
integer function ibtabs(VAL)
Definition: blacstest.f:12027
ssdrvtest
subroutine ssdrvtest(OUTNUM, VERB, NSHAPE, UPLO0, DIAG0, NMAT, M0, N0, LDAS0, LDAD0, NSRC, RSRC0, CSRC0, RDEST0, CDEST0, NGRID, CONTEXT0, P0, Q0, TFAIL, MEM, MEMLEN)
Definition: blacstest.f:2549
rdbtin
subroutine rdbtin(TESTSDRV, TESTBSBR, TESTCOMB, TESTAUX, NPREC, PREC, VERB, OUTNUM)
Definition: blacstest.f:1145
zinitmat
subroutine zinitmat(UPLO, DIAG, M, N, MEM, LDA, IPRE, IPOST, CHECKVAL, TESTNUM, MYROW, MYCOL)
Definition: blacstest.f:10659
zbtcheckin
subroutine zbtcheckin(NFTESTS, OUTNUM, MAXERR, NERR, IERR, ZVAL, TFAILED)
Definition: blacstest.f:10537
zsumtest
subroutine zsumtest(OUTNUM, VERB, TOPSREPEAT, TOPSCOHRNT, NSCOPE, SCOPE0, NTOP, TOP0, NMAT, M0, N0, LDAS0, LDAD0, NDEST, RDEST0, CDEST0, NGRID, CONTEXT0, P0, Q0, ISEED, MEM, MEMLEN)
Definition: blacstest.f:13836
damntest
subroutine damntest(OUTNUM, VERB, TOPSREPEAT, TOPSCOHRNT, NSCOPE, SCOPE0, NTOP, TOP0, NMAT, M0, N0, LDAS0, LDAD0, LDI0, NDEST, RDEST0, CDEST0, NGRID, CONTEXT0, P0, Q0, ISEED, RMEM, CMEM, RCLEN, MEM, MEMLEN)
Definition: blacstest.f:19787
zamxtest
subroutine zamxtest(OUTNUM, VERB, TOPSREPEAT, TOPSCOHRNT, NSCOPE, SCOPE0, NTOP, TOP0, NMAT, M0, N0, LDAS0, LDAD0, LDI0, NDEST, RDEST0, CDEST0, NGRID, CONTEXT0, P0, Q0, ISEED, RMEM, CMEM, RCLEN, MEM, MEMLEN)
Definition: blacstest.f:17682
blacstest
program blacstest
Definition: blacstest.f:1
sinitmat
subroutine sinitmat(UPLO, DIAG, M, N, MEM, LDA, IPRE, IPOST, CHECKVAL, TESTNUM, MYROW, MYCOL)
Definition: blacstest.f:7463
zchkpad
subroutine zchkpad(UPLO, DIAG, M, N, MEM, LDA, RSRC, CSRC, MYROW, MYCOL, IPRE, IPOST, CHECKVAL, TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF)
Definition: blacstest.f:10940
btsetup
subroutine btsetup(MEM, MEMLEN, CMEM, CMEMLEN, OUTNUM, TESTSDRV, TESTBSBR, TESTCOMB, TESTAUX, IAM, NNODES)
Definition: btprim.f:4
dsdrvtest
subroutine dsdrvtest(OUTNUM, VERB, NSHAPE, UPLO0, DIAG0, NMAT, M0, N0, LDAS0, LDAD0, NSRC, RSRC0, CSRC0, RDEST0, CDEST0, NGRID, CONTEXT0, P0, Q0, TFAIL, MEM, MEMLEN)
Definition: blacstest.f:2893
ibtspnum
integer function ibtspnum(SCOPE, PROW, PCOL, NPCOL)
Definition: blacstest.f:14870
igenmat
subroutine igenmat(M, N, A, LDA, TESTNUM, MYROW, MYCOL)
Definition: blacstest.f:6411
sgenmat
subroutine sgenmat(M, N, A, LDA, TESTNUM, MYROW, MYCOL)
Definition: blacstest.f:7480
drcchk
subroutine drcchk(IPRE, IPOST, PADVAL, M, N, RA, CA, LDI, MYROW, MYCOL, TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF)
Definition: blacstest.f:16516
zamntest
subroutine zamntest(OUTNUM, VERB, TOPSREPEAT, TOPSCOHRNT, NSCOPE, SCOPE0, NTOP, TOP0, NMAT, M0, N0, LDAS0, LDAD0, LDI0, NDEST, RDEST0, CDEST0, NGRID, CONTEXT0, P0, Q0, ISEED, RMEM, CMEM, RCLEN, MEM, MEMLEN)
Definition: blacstest.f:21081
ibsbrtest
subroutine ibsbrtest(OUTNUM, VERB, NSCOPE, SCOPE0, NTOP, TOP0, NSHAPE, UPLO0, DIAG0, NMAT, M0, N0, LDAS0, LDAD0, NSRC, RSRC0, CSRC0, NGRID, CONTEXT0, P0, Q0, TFAIL, MEM, MEMLEN)
Definition: blacstest.f:3925
ircchk
subroutine ircchk(IPRE, IPOST, PADVAL, M, N, RA, CA, LDI, MYROW, MYCOL, TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF)
Definition: blacstest.f:14889
sprinterrs
subroutine sprinterrs(OUTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF, COUNTING, TFAILED)
Definition: blacstest.f:8212
cchkmat
subroutine cchkmat(UPLO, DIAG, M, N, A, LDA, RSRC, CSRC, MYROW, MYCOL, TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF)
Definition: blacstest.f:10133
schksum
subroutine schksum(SCOPE, ICTXT, M, N, A, LDA, TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF, ISEED)
Definition: blacstest.f:12601
ichkmat
subroutine ichkmat(UPLO, DIAG, M, N, A, LDA, RSRC, CSRC, MYROW, MYCOL, TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF)
Definition: blacstest.f:6943
dbtcheckin
subroutine dbtcheckin(NFTESTS, OUTNUM, MAXERR, NERR, IERR, DVAL, TFAILED)
Definition: blacstest.f:8405
samntest
subroutine samntest(OUTNUM, VERB, TOPSREPEAT, TOPSCOHRNT, NSCOPE, SCOPE0, NTOP, TOP0, NMAT, M0, N0, LDAS0, LDAD0, LDI0, NDEST, RDEST0, CDEST0, NGRID, CONTEXT0, P0, Q0, ISEED, RMEM, CMEM, RCLEN, MEM, MEMLEN)
Definition: blacstest.f:19141
cpadmat
subroutine cpadmat(UPLO, DIAG, M, N, MEM, LDA, IPRE, IPOST, CHECKVAL)
Definition: blacstest.f:9698
zbsbrtest
subroutine zbsbrtest(OUTNUM, VERB, NSCOPE, SCOPE0, NTOP, TOP0, NSHAPE, UPLO0, DIAG0, NMAT, M0, N0, LDAS0, LDAD0, NSRC, RSRC0, CSRC0, NGRID, CONTEXT0, P0, Q0, TFAIL, MEM, MEMLEN)
Definition: blacstest.f:5585
allpass
logical function allpass(THISTEST)
Definition: blacstest.f:1881
schkamx
subroutine schkamx(SCOPE, ICTXT, M, N, A, LDA, RA, CA, LDI, TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF, ISEED, VALS)
Definition: blacstest.f:15870
sbteps
real function sbteps()
Definition: blacstest.f:12558
dchkamn
subroutine dchkamn(SCOPE, ICTXT, M, N, A, LDA, RA, CA, LDI, TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF, ISEED, VALS)
Definition: blacstest.f:20253
dchksum
subroutine dchksum(SCOPE, ICTXT, M, N, A, LDA, TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF, ISEED)
Definition: blacstest.f:13179
dsumtest
subroutine dsumtest(OUTNUM, VERB, TOPSREPEAT, TOPSCOHRNT, NSCOPE, SCOPE0, NTOP, TOP0, NMAT, M0, N0, LDAS0, LDAD0, NDEST, RDEST0, CDEST0, NGRID, CONTEXT0, P0, Q0, ISEED, MEM, MEMLEN)
Definition: blacstest.f:12709
dbtabs
double precision function dbtabs(VAL)
Definition: blacstest.f:13130
cbtran
complex function cbtran(ISEED)
Definition: blacstest.f:9683
samxtest
subroutine samxtest(OUTNUM, VERB, TOPSREPEAT, TOPSCOHRNT, NSCOPE, SCOPE0, NTOP, TOP0, NMAT, M0, N0, LDAS0, LDAD0, LDI0, NDEST, RDEST0, CDEST0, NGRID, CONTEXT0, P0, Q0, ISEED, RMEM, CMEM, RCLEN, MEM, MEMLEN)
Definition: blacstest.f:15235
iamxtest
subroutine iamxtest(OUTNUM, VERB, TOPSREPEAT, TOPSCOHRNT, NSCOPE, SCOPE0, NTOP, TOP0, NMAT, M0, N0, LDAS0, LDAD0, LDI0, NDEST, RDEST0, CDEST0, NGRID, CONTEXT0, P0, Q0, ISEED, RMEM, CMEM, RCLEN, MEM, MEMLEN)
Definition: blacstest.f:14386
cchkamn
subroutine cchkamn(SCOPE, ICTXT, M, N, A, LDA, RA, CA, LDI, TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF, ISEED, VALS)
Definition: blacstest.f:20899
camxtest
subroutine camxtest(OUTNUM, VERB, TOPSREPEAT, TOPSCOHRNT, NSCOPE, SCOPE0, NTOP, TOP0, NMAT, M0, N0, LDAS0, LDAD0, LDI0, NDEST, RDEST0, CDEST0, NGRID, CONTEXT0, P0, Q0, ISEED, RMEM, CMEM, RCLEN, MEM, MEMLEN)
Definition: blacstest.f:16865
ibtsizeof
integer function ibtsizeof(TYPE)
Definition: btprim.f:286
dchkpad
subroutine dchkpad(UPLO, DIAG, M, N, MEM, LDA, RSRC, CSRC, MYROW, MYCOL, IPRE, IPOST, CHECKVAL, TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF)
Definition: blacstest.f:8810
cprinterrs
subroutine cprinterrs(OUTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF, COUNTING, TFAILED)
Definition: blacstest.f:10338
min
#define min(A, B)
Definition: pcgemr.c:181
rdsdrv
subroutine rdsdrv(MEMUSED, MEM, MEMLEN, CMEMUSED, CMEM, CMEMLEN, OUTNUM)
Definition: blacstest.f:1548
camntest
subroutine camntest(OUTNUM, VERB, TOPSREPEAT, TOPSCOHRNT, NSCOPE, SCOPE0, NTOP, TOP0, NMAT, M0, N0, LDAS0, LDAD0, LDI0, NDEST, RDEST0, CDEST0, NGRID, CONTEXT0, P0, Q0, ISEED, RMEM, CMEM, RCLEN, MEM, MEMLEN)
Definition: blacstest.f:20433
dbtran
double precision function dbtran(ISEED)
Definition: blacstest.f:8619
ssumtest
subroutine ssumtest(OUTNUM, VERB, TOPSREPEAT, TOPSCOHRNT, NSCOPE, SCOPE0, NTOP, TOP0, NMAT, M0, N0, LDAS0, LDAD0, NDEST, RDEST0, CDEST0, NGRID, CONTEXT0, P0, Q0, ISEED, MEM, MEMLEN)
Definition: blacstest.f:12131
isumtest
subroutine isumtest(OUTNUM, VERB, TOPSREPEAT, TOPSCOHRNT, NSCOPE, SCOPE0, NTOP, TOP0, NMAT, M0, N0, LDAS0, LDAD0, NDEST, RDEST0, CDEST0, NGRID, CONTEXT0, P0, Q0, ISEED, MEM, MEMLEN)
Definition: blacstest.f:11607
cbsbrtest
subroutine cbsbrtest(OUTNUM, VERB, NSCOPE, SCOPE0, NTOP, TOP0, NSHAPE, UPLO0, DIAG0, NMAT, M0, N0, LDAS0, LDAD0, NSRC, RSRC0, CSRC0, NGRID, CONTEXT0, P0, Q0, TFAIL, MEM, MEMLEN)
Definition: blacstest.f:5170
sbsbrtest
subroutine sbsbrtest(OUTNUM, VERB, NSCOPE, SCOPE0, NTOP, TOP0, NSHAPE, UPLO0, DIAG0, NMAT, M0, N0, LDAS0, LDAD0, NSRC, RSRC0, CSRC0, NGRID, CONTEXT0, P0, Q0, TFAIL, MEM, MEMLEN)
Definition: blacstest.f:4340
ibtnprocs
integer function ibtnprocs()
Definition: btprim.f:81