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 trunca