SCALAPACK 2.2.2
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches
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
1027110 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 (',i8,') to handle',i4,' ',a20)
1779 2000 FORMAT('Must have at least one ',a20)
1780 3000 FORMAT('UNRECOGNIZABLE ',a5,' ''', a1, '''.')
1781 4000 FORMAT('Illegal process grid: {',i3,',',i3,'}.')
1782*
1783 RETURN
1784*
1785* End of RDSDRV.
1786*
1787 END
1788*
1789 SUBROUTINE chkmatdat( NOUT, INFILE, TSTFLAG, NMAT, M0, N0,
1790 $ LDAS0, LDAD0, LDI0 )
1791*
1792* -- BLACS tester (version 1.0) --
1793* University of Tennessee
1794* December 15, 1994
1795*
1796*
1797* .. Scalar Arguments ..
1798 LOGICAL TSTFLAG
1799 INTEGER NOUT, NMAT
1800* ..
1801* .. Array Arguments ..
1802 CHARACTER*8 INFILE
1803 INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT), LDI0(NMAT)
1804* ..
1805* Purpose
1806* =======
1807* CHKMATDAT: Checks that matrix data is correct.
1808*
1809* Arguments
1810* =========
1811* NOUT (input) INTEGER
1812* The device number to write output to.
1813*
1814* INFILE (input) CHARACTER*8
1815* The name of the input file where matrix values came from.
1816*
1817* TSTFLAG (input) LOGICAL
1818* Whether to test RCFLAG (LDI) values or not.
1819*
1820* NMAT (input) INTEGER
1821* The number of matrices to be tested.
1822*
1823* M0 (input) INTEGER array of dimension (NMAT)
1824* Values of M to be tested.
1825*
1826* M0 (input) INTEGER array of dimension (NMAT)
1827* Values of M to be tested.
1828*
1829* N0 (input) INTEGER array of dimension (NMAT)
1830* Values of N to be tested.
1831*
1832* LDAS0 (input) INTEGER array of dimension (NMAT)
1833* Values of LDAS (leading dimension of A on source process)
1834* to be tested.
1835*
1836* LDAD0 (input) INTEGER array of dimension (NMAT)
1837* Values of LDAD (leading dimension of A on destination
1838* process) to be tested.
1839*
1840* ====================================================================
1841*
1842* .. Local Scalars ..
1843 LOGICAL MATOK
1844 INTEGER I
1845* ..
1846* .. Executable Statements ..
1847 MATOK = .true.
1848 DO 10 i = 1, nmat
1849 IF( m0(i) .LT. 0 ) THEN
1850 WRITE(nout,1000) infile, 'M', m0(i)
1851 matok = .false.
1852 ELSE IF( n0(i) .LT. 0 ) THEN
1853 WRITE(nout,1000) infile, 'N', n0(i)
1854 matok = .false.
1855 ELSE IF( ldas0(i) .LT. m0(i) ) THEN
1856 WRITE(nout,2000) infile, 'LDASRC', ldas0(i), m0(i)
1857 matok = .false.
1858 ELSE IF( ldad0(i) .LT. m0(i) ) THEN
1859 WRITE(nout,2000) infile, 'LDADST', ldad0(i), m0(i)
1860 matok = .false.
1861 ELSE IF( tstflag ) THEN
1862 IF( (ldi0(i).LT.m0(i)) .AND. (ldi0(i).NE.-1) ) THEN
1863 WRITE(nout,2000) infile, 'RCFLAG', ldi0(i), m0(i)
1864 matok = .false.
1865 END IF
1866 END IF
1867 10 CONTINUE
1868*
1869 IF( .NOT.matok ) THEN
1870 IF( nout .NE. 6 .AND. nout .NE. 0 ) CLOSE(nout)
1871 CALL blacs_abort(-1, 1)
1872 END IF
1873*
1874 1000 FORMAT(a8,' INPUT ERROR: Illegal ',a1,'; value=',i6,'.')
1875 2000 FORMAT(a8,' INPUT ERROR: Illegal ',a6,'; value=',i6,', but M=',i6)
1876*
1877 RETURN
1878 END
1879*
1880 LOGICAL FUNCTION allpass( THISTEST )
1881*
1882* -- BLACS tester (version 1.0) --
1883* University of Tennessee
1884* December 15, 1994
1885*
1886*
1887* .. Scalar Arguments ..
1888 LOGICAL thistest
1889* ..
1890* Purpose
1891* =======
1892* ALLPASS: Returns whether all tests have passed so far.
1893*
1894* =====================================================================
1895*
1896* .. Local Scalars ..
1897 LOGICAL passhist
1898* ..
1899* .. Save Statement ..
1900 SAVE passhist
1901* ..
1902* .. Data Statements ..
1903 DATA passhist /.true./
1904* ..
1905* .. Executable Statements ..
1906 passhist = (passhist .AND. thistest)
1907 allpass = passhist
1908*
1909 RETURN
1910 END
1911*
1912 SUBROUTINE rdbsbr( MEMUSED, MEM, MEMLEN, CMEMUSED, CMEM, CMEMLEN,
1913 $ OUTNUM )
1914*
1915* -- BLACS tester (version 1.0) --
1916* University of Tennessee
1917* December 15, 1994
1918*
1919*
1920* .. Scalar Arguments ..
1921 INTEGER MEMUSED, MEMLEN, CMEMUSED, CMEMLEN, OUTNUM
1922* ..
1923* .. Array Arguments ..
1924 CHARACTER*1 CMEM(CMEMLEN)
1925 INTEGER MEM(MEMLEN)
1926* ..
1927*
1928* Purpose
1929* =======
1930* RDBSBR: Read and process the input file BSBR.dat.
1931*
1932* Arguments
1933* =========
1934* MEMUSED (output) INTEGER
1935* Number of elements in MEM that this subroutine ends up using.
1936*
1937* MEM (output) INTEGER array of dimension memlen
1938* On output, holds information read in from sdrv.dat.
1939*
1940* MEMLEN (input) INTEGER
1941* Number of elements of MEM that this subroutine
1942* may safely write into.
1943*
1944* CMEMUSED (output) INTEGER
1945* Number of elements in CMEM that this subroutine ends up using.
1946*
1947* CMEM (output) CHARACTER*1 array of dimension cmemlen
1948* On output, holds the values for UPLO and DIAG.
1949*
1950* CMEMLEN (input) INTEGER
1951* Number of elements of CMEM that this subroutine
1952* may safely write into.
1953*
1954* OUTNUM (input) INTEGER
1955* Unit number of the output file.
1956*
1957* =================================================================
1958*
1959* .. Parameters ..
1960 INTEGER SDIN
1961 PARAMETER( SDIN = 12 )
1962* ..
1963* .. External Functions ..
1964 logical lsame
1965 EXTERNAL lsame
1966* ..
1967* .. Local Scalars ..
1968 INTEGER NSCOPE, NTOP, NSHAPE, NMAT, NSRC, NGRID, I, J
1969 INTEGER SCOPEPTR, TOPPTR, UPLOPTR, DIAGPTR, MPTR, NPTR
1970 INTEGER LDSPTR, LDDPTR, RSRCPTR, CSRCPTR, PPTR, QPTR
1971* ..
1972* .. Executable Statements
1973*
1974* Open and read the file bsbr.dat. The expected format is
1975* below.
1976*
1977*------
1978*integer Number of scopes
1979*array of CHAR*1's Values for Scopes
1980*integer Number of topologies
1981*array of CHAR*1's Values for TOP
1982*integer number of shapes of the matrix
1983*array of CHAR*1's UPLO
1984*array of CHAR*1's DIAG: unit diagonal or not?
1985*integer number of nmat
1986*array of integers M: number of rows in matrix
1987*array of integers N: number of columns in matrix
1988*integer LDA: leading dimension on source proc
1989*integer LDA: leading dimension on dest proc
1990*integer number of source/dest pairs
1991*array of integers RSRC: process row of message source
1992*array of integers CSRC: process column of msg. src.
1993*integer Number of grids
1994*array of integers NPROW: number of rows in process grid
1995*array of integers NPCOL: number of col's in proc. grid
1996*------
1997* note: UPLO stands for 'upper or lower trapezoidal or general
1998* rectangular.'
1999* note: the text descriptions as shown above are present in
2000* the sample bsbr.dat included with this distribution,
2001* but are not required.
2002*
2003* Read input file
2004*
2005 memused = 1
2006 cmemused = 1
2007 OPEN(unit = sdin, file = 'bsbr.dat', status = 'OLD')
2008*
2009* Read in scopes and topologies
2010*
2011 READ(sdin, *) nscope
2012 scopeptr = cmemused
2013 cmemused = scopeptr + nscope
2014 IF ( cmemused .GT. cmemlen ) THEN
2015 WRITE(outnum, 1000) cmemlen, nscope, 'SCOPES.'
2016 IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE(outnum)
2017 stop
2018 ELSE IF( nscope .LT. 1 ) THEN
2019 WRITE(outnum, 2000) 'SCOPE.'
2020 IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE(outnum)
2021 stop
2022 END IF
2023*
2024 READ(sdin, *) ( cmem(scopeptr+i), i = 0, nscope-1 )
2025 DO 20 i = 0, nscope-1
2026 IF( lsame(cmem(scopeptr+i), 'R') ) THEN
2027 cmem(scopeptr+i) = 'R'
2028 ELSE IF( lsame(cmem(scopeptr+i), 'C') ) THEN
2029 cmem(scopeptr+i) = 'C'
2030 ELSE IF( lsame(cmem(scopeptr+i), 'A') ) THEN
2031 cmem(scopeptr+i) = 'A'
2032 ELSE
2033 WRITE(outnum, 3000) 'SCOPE', cmem(scopeptr+i)
2034 IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE(outnum)
2035 stop
2036 END IF
2037 20 CONTINUE
2038*
2039 READ(sdin, *) ntop
2040 topptr = cmemused
2041 cmemused = topptr + ntop
2042 IF ( cmemused .GT. cmemlen ) THEN
2043 WRITE(outnum, 1000) cmemlen, ntop, 'TOPOLOGIES.'
2044 IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE(outnum)
2045 stop
2046 ELSE IF( ntop .LT. 1 ) THEN
2047 WRITE(outnum, 2000) 'TOPOLOGY.'
2048 IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE(outnum)
2049 stop
2050 END IF
2051 READ(sdin, *) ( cmem(topptr+i), i = 0, ntop-1 )
2052*
2053*
2054* Read in number of shapes, and values of UPLO and DIAG
2055*
2056 READ(sdin, *) nshape
2057 uploptr = cmemused
2058 diagptr = uploptr + nshape
2059 cmemused = diagptr + nshape
2060 IF ( cmemused .GT. cmemlen ) THEN
2061 WRITE(outnum, 1000) cmemlen, nshape, 'MATRIX SHAPES.'
2062 IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE(outnum)
2063 stop
2064 ELSE IF( nshape .LT. 1 ) THEN
2065 WRITE(outnum, 2000) 'MATRIX SHAPE.'
2066 IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE(outnum)
2067 stop
2068 END IF
2069*
2070* Read in, upcase, and fatal error if UPLO/DIAG not recognized
2071*
2072 READ(sdin, *) ( cmem(uploptr+i), i = 0, nshape-1 )
2073 DO 30 i = 0, nshape-1
2074 IF( lsame(cmem(uploptr+i), 'G') ) THEN
2075 cmem(uploptr+i) = 'G'
2076 ELSE IF( lsame(cmem(uploptr+i), 'U') ) THEN
2077 cmem(uploptr+i) = 'U'
2078 ELSE IF( lsame(cmem(uploptr+i), 'L') ) THEN
2079 cmem(uploptr+i) = 'L'
2080 ELSE
2081 WRITE(outnum, 3000) 'UPLO ', cmem(uploptr+i)
2082 IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE(outnum)
2083 stop
2084 END IF
2085 30 CONTINUE
2086*
2087 READ(sdin, *) ( cmem(diagptr+i), i = 0, nshape-1 )
2088 DO 40 i = 0, nshape-1
2089 IF( cmem(uploptr+i) .NE. 'G' ) THEN
2090 IF( lsame(cmem(diagptr+i), 'U') ) THEN
2091 cmem( diagptr+i ) = 'U'
2092 ELSE IF( lsame(cmem(diagptr+i), 'N') ) THEN
2093 cmem(diagptr+i) = 'N'
2094 ELSE
2095 WRITE(outnum, 3000) 'DIAG ', cmem(diagptr+i)
2096 IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE(outnum)
2097 stop
2098 END IF
2099 END IF
2100 40 CONTINUE
2101*
2102* Read in number of matrices, and values for M, N, LDASRC, and LDADEST
2103*
2104 READ(sdin, *) nmat
2105 mptr = memused
2106 nptr = mptr + nmat
2107 ldsptr = nptr + nmat
2108 lddptr = ldsptr + nmat
2109 memused = lddptr + nmat
2110 IF( memused .GT. memlen ) THEN
2111 WRITE(outnum, 1000) memlen, nmat, 'MATRICES.'
2112 IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE(outnum)
2113 stop
2114 ELSE IF( nmat .LT. 1 ) THEN
2115 WRITE(outnum, 2000) 'MATRIX.'
2116 IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE(outnum)
2117 stop
2118 END IF
2119 READ(sdin, *) ( mem( mptr+i ), i = 0, nmat-1 )
2120 READ(sdin, *) ( mem( nptr+i ), i = 0, nmat-1 )
2121 READ(sdin, *) ( mem( ldsptr+i ), i = 0, nmat-1 )
2122 READ(sdin, *) ( mem( lddptr+i ), i = 0, nmat-1 )
2123*
2124* Make sure matrix values are legal
2125*
2126 CALL chkmatdat( outnum, 'BSBR.dat', .false., nmat, mem(mptr),
2127 $ mem(nptr), mem(ldsptr), mem(lddptr), mem(lddptr) )
2128*
2129* Read in number of src pairs, and values of src
2130*
2131 READ(sdin, *) nsrc
2132 rsrcptr = memused
2133 csrcptr = rsrcptr + nsrc
2134 memused = csrcptr + nsrc
2135 IF( memused .GT. memlen ) THEN
2136 WRITE(outnum, 1000) memlen, nmat, 'SRC.'
2137 IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE(outnum)
2138 stop
2139 ELSE IF( nsrc .LT. 1 ) THEN
2140 WRITE(outnum, 2000) 'SRC.'
2141 IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE(outnum)
2142 stop
2143 END IF
2144 READ(sdin, *) ( mem(rsrcptr+i), i = 0, nsrc-1 )
2145 READ(sdin, *) ( mem(csrcptr+i), i = 0, nsrc-1 )
2146*
2147* Read in number of grids pairs, and values of P (process rows) and
2148* Q (process columns)
2149*
2150 READ(sdin, *) ngrid
2151 pptr = memused
2152 qptr = pptr + ngrid
2153 memused = qptr + ngrid
2154 IF( memused .GT. memlen ) THEN
2155 WRITE(outnum, 1000) memlen, ngrid, 'PROCESS GRIDS.'
2156 IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE(outnum)
2157 stop
2158 ELSE IF( ngrid .LT. 1 ) THEN
2159 WRITE(outnum, 2000) 'PROCESS GRID'
2160 IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE( outnum )
2161 stop
2162 END IF
2163*
2164 READ(sdin, *) ( mem(pptr+i), i = 0, ngrid-1 )
2165 READ(sdin, *) ( mem(qptr+i), i = 0, ngrid-1 )
2166 IF( sdin .NE. 6 .AND. sdin .NE. 0 ) CLOSE( sdin )
2167*
2168* Fatal error if we've got an illegal grid
2169*
2170 DO 70 j = 0, ngrid-1
2171 IF( mem(pptr+j).LT.1 .OR. mem(qptr+j).LT.1 ) THEN
2172 WRITE(outnum, 4000) mem(pptr+j), mem(qptr+j)
2173 IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE(outnum)
2174 stop
2175 END IF
2176 70 CONTINUE
2177*
2178* Prepare output variables
2179*
2180 mem(memused) = nscope
2181 mem(memused+1) = ntop
2182 mem(memused+2) = nshape
2183 mem(memused+3) = nmat
2184 mem(memused+4) = nsrc
2185 mem(memused+5) = ngrid
2186 memused = memused + 5
2187 cmemused = cmemused - 1
2188*
2189 1000 FORMAT('Mem too short (',i4,') to handle',i4,' ',a20)
2190 2000 FORMAT('Must have at least one ',a20)
2191 3000 FORMAT('UNRECOGNIZABLE ',a5,' ''', a1, '''.')
2192 4000 FORMAT('Illegal process grid: {',i3,',',i3,'}.')
2193*
2194 RETURN
2195*
2196* End of RDBSBR.
2197*
2198 END
2199*
2200*
2201 SUBROUTINE isdrvtest( OUTNUM, VERB, NSHAPE, UPLO0, DIAG0,
2202 $ NMAT, M0, N0, LDAS0, LDAD0, NSRC, RSRC0,
2203 $ CSRC0, RDEST0, CDEST0, NGRID, CONTEXT0,
2204 $ P0, Q0, TFAIL, MEM, MEMLEN )
2205*
2206* -- BLACS tester (version 1.0) --
2207* University of Tennessee
2208* December 15, 1994
2209*
2210*
2211* .. Scalar Arguments ..
2212 INTEGER OUTNUM, VERB, NSHAPE, NMAT, NSRC, NGRID, MEMLEN
2213* ..
2214* .. Array Arguments ..
2215 CHARACTER*1 UPLO0(NSHAPE), DIAG0(NSHAPE)
2216 INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT)
2217 INTEGER RSRC0(NSRC), CSRC0(NSRC), RDEST0(NSRC), CDEST0(NSRC)
2218 INTEGER CONTEXT0(NGRID), P0(NGRID), Q0(NGRID), TFAIL(*)
2219 INTEGER MEM(MEMLEN)
2220* ..
2221*
2222* Purpose
2223* =======
2224* ITESTSDRV: Test integer send/recv
2225*
2226* Arguments
2227* =========
2228* OUTNUM (input) INTEGER
2229* The device number to write output to.
2230*
2231* VERB (input) INTEGER
2232* The level of verbosity (how much printing to do).
2233*
2234* NSHAPE (input) INTEGER
2235* The number of matrix shapes to be tested.
2236*
2237* UPLO0 (input) CHARACTER*1 array of dimension (NSHAPE)
2238* Values of UPLO to be tested.
2239*
2240* DIAG0 (input) CHARACTER*1 array of dimension (NSHAPE)
2241* Values of DIAG to be tested.
2242*
2243* NMAT (input) INTEGER
2244* The number of matrices to be tested.
2245*
2246* M0 (input) INTEGER array of dimension (NMAT)
2247* Values of M to be tested.
2248*
2249* M0 (input) INTEGER array of dimension (NMAT)
2250* Values of M to be tested.
2251*
2252* N0 (input) INTEGER array of dimension (NMAT)
2253* Values of N to be tested.
2254*
2255* LDAS0 (input) INTEGER array of dimension (NMAT)
2256* Values of LDAS (leading dimension of A on source process)
2257* to be tested.
2258*
2259* LDAD0 (input) INTEGER array of dimension (NMAT)
2260* Values of LDAD (leading dimension of A on destination
2261* process) to be tested.
2262* NSRC (input) INTEGER
2263* The number of sources to be tested.
2264*
2265* RSRC0 (input) INTEGER array of dimension (NDEST)
2266* Values of RSRC (row coordinate of source) to be tested.
2267*
2268* CSRC0 (input) INTEGER array of dimension (NDEST)
2269* Values of CSRC (column coordinate of source) to be tested.
2270*
2271* RDEST0 (input) INTEGER array of dimension (NNSRC)
2272* Values of RDEST (row coordinate of destination) to be
2273* tested.
2274*
2275* CDEST0 (input) INTEGER array of dimension (NNSRC)
2276* Values of CDEST (column coordinate of destination) to be
2277* tested.
2278*
2279* NGRID (input) INTEGER
2280* The number of process grids to be tested.
2281*
2282* CONTEXT0 (input) INTEGER array of dimension (NGRID)
2283* The BLACS context handles corresponding to the grids.
2284*
2285* P0 (input) INTEGER array of dimension (NGRID)
2286* Values of P (number of process rows, NPROW).
2287*
2288* Q0 (input) INTEGER array of dimension (NGRID)
2289* Values of Q (number of process columns, NPCOL).
2290*
2291* TFAIL (workspace) INTEGER array of dimension (NTESTS)
2292* If VERB < 2, serves to indicate which tests fail. This
2293* requires workspace of NTESTS (number of tests performed).
2294*
2295* MEM (workspace) INTEGER array of dimension (MEMLEN)
2296* Used for all other workspaces, including the matrix A,
2297* and its pre and post padding.
2298*
2299* MEMLEN (input) INTEGER
2300* The length, in elements, of MEM.
2301*
2302* =====================================================================
2303*
2304* .. External Functions ..
2305 LOGICAL ALLPASS
2306 INTEGER IBTMYPROC, IBTSIZEOF
2307 EXTERNAL ALLPASS, IBTMYPROC, IBTSIZEOF
2308* ..
2309* .. External Subroutines ..
2310 EXTERNAL BLACS_GRIDINFO
2311 EXTERNAL ITRSD2D, IGESD2D, ITRRV2D, IGERV2D
2312 EXTERNAL IINITMAT, ICHKMAT, ICHKPAD, IBTCHECKIN
2313* ..
2314* .. Local Scalars ..
2315 CHARACTER*1 UPLO, DIAG
2316 LOGICAL TESTOK
2317 INTEGER IAM, I, K, IGR, ISH, IMA, ISO, MYROW, MYCOL, IPRE, IPOST
2318 INTEGER M, N, NPROW, NPCOL, RSRC, CSRC, RDEST, CDEST
2319 INTEGER NERR, NSKIP, NFAIL, TESTNUM, CONTEXT, MAXERR, LDASRC
2320 INTEGER LDADST, ERRDPTR, APTR, ERRIPTR, ISIZE
2321 INTEGER SCHECKVAL, RCHECKVAL
2322* ..
2323* .. Executable Statements ..
2324*
2325 scheckval = -1
2326 rcheckval = -2
2327*
2328 iam = ibtmyproc()
2329 isize = ibtsizeof('I')
2330 isize = ibtsizeof('I')
2331*
2332* Verify file parameters
2333*
2334 IF( iam .EQ. 0 ) THEN
2335 WRITE(outnum, *) ' '
2336 WRITE(outnum, *) ' '
2337 WRITE(outnum, 1000 )
2338 IF( verb .GT. 0 ) THEN
2339 WRITE(outnum,*) ' '
2340 WRITE(outnum, 2000) 'NSHAPE:', nshape
2341 WRITE(outnum, 3000) ' UPLO :', ( uplo0(i), i = 1, nshape )
2342 WRITE(outnum, 3000) ' DIAG :', ( diag0(i), i = 1, nshape )
2343 WRITE(outnum, 2000) 'NMAT :', nmat
2344 WRITE(outnum, 2000) ' M :', ( m0(i), i = 1, nmat )
2345 WRITE(outnum, 2000) ' N :', ( n0(i), i = 1, nmat )
2346 WRITE(outnum, 2000) ' LDAS :', ( ldas0(i), i = 1, nmat )
2347 WRITE(outnum, 2000) ' LDAD :', ( ldad0(i), i = 1, nmat )
2348 WRITE(outnum, 2000) 'NSRC :', nsrc
2349 WRITE(outnum, 2000) ' RSRC :',( rsrc0(i), i = 1, nsrc )
2350 WRITE(outnum, 2000) ' CSRC :',( csrc0(i), i = 1, nsrc )
2351 WRITE(outnum, 2000) ' RDEST:',( rdest0(i), i = 1, nsrc )
2352 WRITE(outnum, 2000) ' CDEST:',( cdest0(i), i = 1, nsrc )
2353 WRITE(outnum, 2000) 'NGRIDS:', ngrid
2354 WRITE(outnum, 2000) ' P :', ( p0(i), i = 1, ngrid )
2355 WRITE(outnum, 2000) ' Q :', ( q0(i), i = 1, ngrid )
2356 WRITE(outnum, 2000) 'VERB :', verb
2357 WRITE(outnum,*) ' '
2358 END IF
2359 IF( verb .GT. 1 ) THEN
2360 WRITE(outnum,5000)
2361 WRITE(outnum,6000)
2362 END IF
2363 END IF
2364*
2365* Find biggest matrix, so we know where to stick error info
2366*
2367 i = 0
2368 DO 10 ima = 1, nmat
2369 k = n0(ima) * max0( ldas0(ima), ldad0(ima) ) + 4 * m0(ima)
2370 IF( k .GT. i ) i = k
2371 10 CONTINUE
2372 maxerr = ( isize * (memlen-i) ) / ( isize*2 + isize*6 )
2373 IF( maxerr .LT. 1 ) THEN
2374 WRITE(outnum,*) 'ERROR: Not enough memory to run SDRV tests.'
2375 CALL blacs_abort(-1, 1)
2376 END IF
2377 errdptr = i + 1
2378 erriptr = errdptr + maxerr
2379 nerr = 0
2380 testnum = 0
2381 nfail = 0
2382 nskip = 0
2383*
2384* Loop over grids of matrix
2385*
2386 DO 110 igr = 1, ngrid
2387*
2388 context = context0(igr)
2389 CALL blacs_gridinfo( context, nprow, npcol, myrow, mycol )
2390*
2391 DO 80 ish = 1, nshape
2392 uplo = uplo0(ish)
2393 diag = diag0(ish)
2394*
2395 DO 70 ima = 1, nmat
2396 m = m0(ima)
2397 n = n0(ima)
2398 ldasrc = ldas0(ima)
2399 ldadst = ldad0(ima)
2400*
2401 DO 60 iso = 1, nsrc
2402 testnum = testnum + 1
2403 rsrc = rsrc0(iso)
2404 csrc = csrc0(iso)
2405 IF( rsrc.GE.p0(igr) .OR. csrc.GE.q0(igr) ) THEN
2406 nskip = nskip + 1
2407 GOTO 60
2408 END IF
2409 rdest = rdest0(iso)
2410 cdest = cdest0(iso)
2411 IF( rdest.GE.p0(igr) .OR. cdest.GE.q0(igr) ) THEN
2412 nskip = nskip + 1
2413 GOTO 60
2414 END IF
2415*
2416 IF( verb .GT. 1 ) THEN
2417 IF( iam .EQ. 0 ) THEN
2418 WRITE(outnum, 7000) testnum, 'RUNNING',
2419 $ uplo, diag, m, n,
2420 $ ldasrc, ldadst, rsrc, csrc,
2421 $ rdest, cdest, nprow, npcol
2422 END IF
2423 END IF
2424*
2425 testok = .true.
2426 ipre = 2 * m
2427 ipost = ipre
2428 aptr = ipre + 1
2429*
2430* source process generates matrix and sends it
2431*
2432 IF( myrow .EQ. rsrc .AND. mycol .EQ. csrc ) THEN
2433 CALL iinitmat( uplo, diag, m, n, mem, ldasrc,
2434 $ ipre, ipost, scheckval, testnum,
2435 $ myrow, mycol )
2436*
2437 IF( uplo .EQ. 'U' .OR. uplo .EQ. 'L' ) THEN
2438 CALL itrsd2d( context, uplo, diag, m, n,
2439 $ mem(aptr), ldasrc, rdest, cdest )
2440 ELSE
2441 CALL igesd2d( context, m, n, mem(aptr),
2442 $ ldasrc, rdest, cdest )
2443 END IF
2444 END IF
2445*
2446 IF( myrow .EQ. rdest .AND. mycol .EQ. cdest ) THEN
2447*
2448* Pad entire matrix area
2449*
2450 DO 50 k = 1, ipre+ipost+ldadst*n
2451 mem(k) = rcheckval
2452 50 CONTINUE
2453*
2454* Receive matrix
2455*
2456 IF( uplo .EQ. 'U' .OR. uplo .EQ. 'L' ) THEN
2457 CALL itrrv2d( context, uplo, diag, m, n,
2458 $ mem(aptr), ldadst, rsrc, csrc )
2459 ELSE
2460 CALL igerv2d( context, m, n, mem(aptr),
2461 $ ldadst, rsrc, csrc )
2462 END IF
2463*
2464* Check for errors in matrix or padding
2465*
2466 i = nerr
2467 CALL ichkmat( uplo, diag, m, n, mem(aptr), ldadst,
2468 $ rsrc, csrc, myrow, mycol, testnum, maxerr,
2469 $ nerr, mem(erriptr), mem(errdptr) )
2470*
2471 CALL ichkpad( uplo, diag, m, n, mem, ldadst,
2472 $ rsrc, csrc, myrow, mycol, ipre, ipost,
2473 $ rcheckval, testnum, maxerr, nerr,
2474 $ mem(erriptr), mem(errdptr) )
2475 testok = i .EQ. nerr
2476 END IF
2477*
2478 IF( verb .GT. 1 ) THEN
2479 i = nerr
2480 CALL ibtcheckin( 0, outnum, maxerr, nerr,
2481 $ mem(erriptr), mem(errdptr),
2482 $ tfail )
2483 IF( iam .EQ. 0 ) THEN
2484 IF( testok .AND. i.EQ.nerr ) THEN
2485 WRITE(outnum, 7000) testnum, 'PASSED ',
2486 $ uplo, diag, m, n, ldasrc, ldadst,
2487 $ rsrc, csrc, rdest, cdest, nprow, npcol
2488 ELSE
2489 nfail = nfail + 1
2490 WRITE(outnum, 7000) testnum, 'FAILED ',
2491 $ uplo, diag, m, n, ldasrc, ldadst,
2492 $ rsrc, csrc, rdest, cdest, nprow, npcol
2493 ENDIF
2494 END IF
2495*
2496* Once we've printed out errors, can re-use buf space
2497*
2498 nerr = 0
2499 END IF
2500 60 CONTINUE
2501 70 CONTINUE
2502 80 CONTINUE
2503 110 CONTINUE
2504*
2505 IF( verb .LT. 2 ) THEN
2506 nfail = testnum
2507 CALL ibtcheckin( nfail, outnum, maxerr, nerr, mem(erriptr),
2508 $ mem(errdptr), tfail )
2509 END IF
2510 IF( iam .EQ. 0 ) THEN
2511 IF( verb .GT. 1 ) WRITE(outnum,*) ' '
2512 IF( nfail+nskip .EQ. 0 ) THEN
2513 WRITE(outnum, 8000 ) testnum
2514 ELSE
2515 WRITE(outnum, 9000 ) testnum, testnum-nskip-nfail,
2516 $ nskip, nfail
2517 END IF
2518 END IF
2519*
2520* Log whether their were any failures
2521*
2522 testok = allpass( (nfail.EQ.0) )
2523*
2524 1000 FORMAT('INTEGER SDRV TESTS: BEGIN.' )
2525 2000 FORMAT(1x,a7,3x,10i6)
2526 3000 FORMAT(1x,a7,3x,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,
2527 $ 5x,a1,5x,a1)
2528 5000 FORMAT(' TEST# STATUS UPLO DIA M N LDAS LDAD RSRC ',
2529 $ 'CSRC RDEST CDEST P Q')
2530 6000 FORMAT(' ----- ------- ---- --- ----- ----- ----- ----- ---- ',
2531 $ '---- ----- ----- ---- ----')
2532 7000 FORMAT(i6,1x,a7,4x,a1,3x,a1,4i6,2i5,2i6,2i5)
2533 8000 FORMAT('INTEGER SDRV TESTS: PASSED ALL',
2534 $ i5, ' TESTS.')
2535 9000 FORMAT('INTEGER SDRV TESTS:',i5,' TESTS;',i5,' PASSED,',
2536 $ i5,' SKIPPED,',i5,' FAILED.')
2537*
2538 RETURN
2539*
2540* End of ISDRVTEST.
2541*
2542 END
2543*
2544*
2545 SUBROUTINE ssdrvtest( OUTNUM, VERB, NSHAPE, UPLO0, DIAG0,
2546 $ NMAT, M0, N0, LDAS0, LDAD0, NSRC, RSRC0,
2547 $ CSRC0, RDEST0, CDEST0, NGRID, CONTEXT0,
2548 $ P0, Q0, TFAIL, MEM, MEMLEN )
2549*
2550* -- BLACS tester (version 1.0) --
2551* University of Tennessee
2552* December 15, 1994
2553*
2554*
2555* .. Scalar Arguments ..
2556 INTEGER OUTNUM, VERB, NSHAPE, NMAT, NSRC, NGRID, MEMLEN
2557* ..
2558* .. Array Arguments ..
2559 CHARACTER*1 UPLO0(NSHAPE), DIAG0(NSHAPE)
2560 INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT)
2561 INTEGER RSRC0(NSRC), CSRC0(NSRC), RDEST0(NSRC), CDEST0(NSRC)
2562 INTEGER CONTEXT0(NGRID), P0(NGRID), Q0(NGRID), TFAIL(*)
2563 REAL MEM(MEMLEN)
2564* ..
2565*
2566* Purpose
2567* =======
2568* STESTSDRV: Test real send/recv
2569*
2570* Arguments
2571* =========
2572* OUTNUM (input) INTEGER
2573* The device number to write output to.
2574*
2575* VERB (input) INTEGER
2576* The level of verbosity (how much printing to do).
2577*
2578* NSHAPE (input) INTEGER
2579* The number of matrix shapes to be tested.
2580*
2581* UPLO0 (input) CHARACTER*1 array of dimension (NSHAPE)
2582* Values of UPLO to be tested.
2583*
2584* DIAG0 (input) CHARACTER*1 array of dimension (NSHAPE)
2585* Values of DIAG to be tested.
2586*
2587* NMAT (input) INTEGER
2588* The number of matrices to be tested.
2589*
2590* M0 (input) INTEGER array of dimension (NMAT)
2591* Values of M to be tested.
2592*
2593* M0 (input) INTEGER array of dimension (NMAT)
2594* Values of M to be tested.
2595*
2596* N0 (input) INTEGER array of dimension (NMAT)
2597* Values of N to be tested.
2598*
2599* LDAS0 (input) INTEGER array of dimension (NMAT)
2600* Values of LDAS (leading dimension of A on source process)
2601* to be tested.
2602*
2603* LDAD0 (input) INTEGER array of dimension (NMAT)
2604* Values of LDAD (leading dimension of A on destination
2605* process) to be tested.
2606* NSRC (input) INTEGER
2607* The number of sources to be tested.
2608*
2609* RSRC0 (input) INTEGER array of dimension (NDEST)
2610* Values of RSRC (row coordinate of source) to be tested.
2611*
2612* CSRC0 (input) INTEGER array of dimension (NDEST)
2613* Values of CSRC (column coordinate of source) to be tested.
2614*
2615* RDEST0 (input) INTEGER array of dimension (NNSRC)
2616* Values of RDEST (row coordinate of destination) to be
2617* tested.
2618*
2619* CDEST0 (input) INTEGER array of dimension (NNSRC)
2620* Values of CDEST (column coordinate of destination) to be
2621* tested.
2622*
2623* NGRID (input) INTEGER
2624* The number of process grids to be tested.
2625*
2626* CONTEXT0 (input) INTEGER array of dimension (NGRID)
2627* The BLACS context handles corresponding to the grids.
2628*
2629* P0 (input) INTEGER array of dimension (NGRID)
2630* Values of P (number of process rows, NPROW).
2631*
2632* Q0 (input) INTEGER array of dimension (NGRID)
2633* Values of Q (number of process columns, NPCOL).
2634*
2635* TFAIL (workspace) INTEGER array of dimension (NTESTS)
2636* If VERB < 2, serves to indicate which tests fail. This
2637* requires workspace of NTESTS (number of tests performed).
2638*
2639* MEM (workspace) REAL array of dimension (MEMLEN)
2640* Used for all other workspaces, including the matrix A,
2641* and its pre and post padding.
2642*
2643* MEMLEN (input) INTEGER
2644* The length, in elements, of MEM.
2645*
2646* =====================================================================
2647*
2648* .. External Functions ..
2649 LOGICAL ALLPASS
2650 INTEGER IBTMYPROC, IBTSIZEOF
2651 EXTERNAL ALLPASS, IBTMYPROC, IBTSIZEOF
2652* ..
2653* .. External Subroutines ..
2654 EXTERNAL BLACS_GRIDINFO
2655 EXTERNAL STRSD2D, SGESD2D, STRRV2D, SGERV2D
2656 EXTERNAL SINITMAT, SCHKMAT, SCHKPAD, SBTCHECKIN
2657* ..
2658* .. Local Scalars ..
2659 CHARACTER*1 UPLO, DIAG
2660 LOGICAL TESTOK
2661 INTEGER IAM, I, K, IGR, ISH, IMA, ISO, MYROW, MYCOL, IPRE, IPOST
2662 INTEGER M, N, NPROW, NPCOL, RSRC, CSRC, RDEST, CDEST
2663 INTEGER NERR, NSKIP, NFAIL, TESTNUM, CONTEXT, MAXERR, LDASRC
2664 INTEGER LDADST, ERRDPTR, APTR, ERRIPTR, ISIZE, SSIZE
2665 REAL SCHECKVAL, RCHECKVAL
2666* ..
2667* .. Executable Statements ..
2668*
2669 SCHECKVAL = -0.01e0
2670 rcheckval = -0.02e0
2671*
2672 iam = ibtmyproc()
2673 isize = ibtsizeof('I')
2674 ssize = ibtsizeof('S')
2675*
2676* Verify file parameters
2677*
2678 IF( iam .EQ. 0 ) THEN
2679 WRITE(outnum, *) ' '
2680 WRITE(outnum, *) ' '
2681 WRITE(outnum, 1000 )
2682 IF( verb .GT. 0 ) THEN
2683 WRITE(outnum,*) ' '
2684 WRITE(outnum, 2000) 'NSHAPE:', nshape
2685 WRITE(outnum, 3000) ' UPLO :', ( uplo0(i), i = 1, nshape )
2686 WRITE(outnum, 3000) ' DIAG :', ( diag0(i), i = 1, nshape )
2687 WRITE(outnum, 2000) 'NMAT :', nmat
2688 WRITE(outnum, 2000) ' M :', ( m0(i), i = 1, nmat )
2689 WRITE(outnum, 2000) ' N :', ( n0(i), i = 1, nmat )
2690 WRITE(outnum, 2000) ' LDAS :', ( ldas0(i), i = 1, nmat )
2691 WRITE(outnum, 2000) ' LDAD :', ( ldad0(i), i = 1, nmat )
2692 WRITE(outnum, 2000) 'NSRC :', nsrc
2693 WRITE(outnum, 2000) ' RSRC :',( rsrc0(i), i = 1, nsrc )
2694 WRITE(outnum, 2000) ' CSRC :',( csrc0(i), i = 1, nsrc )
2695 WRITE(outnum, 2000) ' RDEST:',( rdest0(i), i = 1, nsrc )
2696 WRITE(outnum, 2000) ' CDEST:',( cdest0(i), i = 1, nsrc )
2697 WRITE(outnum, 2000) 'NGRIDS:', ngrid
2698 WRITE(outnum, 2000) ' P :', ( p0(i), i = 1, ngrid )
2699 WRITE(outnum, 2000) ' Q :', ( q0(i), i = 1, ngrid )
2700 WRITE(outnum, 2000) 'VERB :', verb
2701 WRITE(outnum,*) ' '
2702 END IF
2703 IF( verb .GT. 1 ) THEN
2704 WRITE(outnum,5000)
2705 WRITE(outnum,6000)
2706 END IF
2707 END IF
2708*
2709* Find biggest matrix, so we know where to stick error info
2710*
2711 i = 0
2712 DO 10 ima = 1, nmat
2713 k = n0(ima) * max0( ldas0(ima), ldad0(ima) ) + 4 * m0(ima)
2714 IF( k .GT. i ) i = k
2715 10 CONTINUE
2716 maxerr = ( ssize * (memlen-i) ) / ( ssize*2 + isize*6 )
2717 IF( maxerr .LT. 1 ) THEN
2718 WRITE(outnum,*) 'ERROR: Not enough memory to run SDRV tests.'
2719 CALL blacs_abort(-1, 1)
2720 END IF
2721 errdptr = i + 1
2722 erriptr = errdptr + maxerr
2723 nerr = 0
2724 testnum = 0
2725 nfail = 0
2726 nskip = 0
2727*
2728* Loop over grids of matrix
2729*
2730 DO 110 igr = 1, ngrid
2731*
2732 context = context0(igr)
2733 CALL blacs_gridinfo( context, nprow, npcol, myrow, mycol )
2734*
2735 DO 80 ish = 1, nshape
2736 uplo = uplo0(ish)
2737 diag = diag0(ish)
2738*
2739 DO 70 ima = 1, nmat
2740 m = m0(ima)
2741 n = n0(ima)
2742 ldasrc = ldas0(ima)
2743 ldadst = ldad0(ima)
2744*
2745 DO 60 iso = 1, nsrc
2746 testnum = testnum + 1
2747 rsrc = rsrc0(iso)
2748 csrc = csrc0(iso)
2749 IF( rsrc.GE.p0(igr) .OR. csrc.GE.q0(igr) ) THEN
2750 nskip = nskip + 1
2751 GOTO 60
2752 END IF
2753 rdest = rdest0(iso)
2754 cdest = cdest0(iso)
2755 IF( rdest.GE.p0(igr) .OR. cdest.GE.q0(igr) ) THEN
2756 nskip = nskip + 1
2757 GOTO 60
2758 END IF
2759*
2760 IF( verb .GT. 1 ) THEN
2761 IF( iam .EQ. 0 ) THEN
2762 WRITE(outnum, 7000) testnum, 'RUNNING',
2763 $ uplo, diag, m, n,
2764 $ ldasrc, ldadst, rsrc, csrc,
2765 $ rdest, cdest, nprow, npcol
2766 END IF
2767 END IF
2768*
2769 testok = .true.
2770 ipre = 2 * m
2771 ipost = ipre
2772 aptr = ipre + 1
2773*
2774* source process generates matrix and sends it
2775*
2776 IF( myrow .EQ. rsrc .AND. mycol .EQ. csrc ) THEN
2777 CALL sinitmat( uplo, diag, m, n, mem, ldasrc,
2778 $ ipre, ipost, scheckval, testnum,
2779 $ myrow, mycol )
2780*
2781 IF( uplo .EQ. 'U' .OR. uplo .EQ. 'L' ) THEN
2782 CALL strsd2d( context, uplo, diag, m, n,
2783 $ mem(aptr), ldasrc, rdest, cdest )
2784 ELSE
2785 CALL sgesd2d( context, m, n, mem(aptr),
2786 $ ldasrc, rdest, cdest )
2787 END IF
2788 END IF
2789*
2790 IF( myrow .EQ. rdest .AND. mycol .EQ. cdest ) THEN
2791*
2792* Pad entire matrix area
2793*
2794 DO 50 k = 1, ipre+ipost+ldadst*n
2795 mem(k) = rcheckval
2796 50 CONTINUE
2797*
2798* Receive matrix
2799*
2800 IF( uplo .EQ. 'U' .OR. uplo .EQ. 'L' ) THEN
2801 CALL strrv2d( context, uplo, diag, m, n,
2802 $ mem(aptr), ldadst, rsrc, csrc )
2803 ELSE
2804 CALL sgerv2d( context, m, n, mem(aptr),
2805 $ ldadst, rsrc, csrc )
2806 END IF
2807*
2808* Check for errors in matrix or padding
2809*
2810 i = nerr
2811 CALL schkmat( uplo, diag, m, n, mem(aptr), ldadst,
2812 $ rsrc, csrc, myrow, mycol, testnum, maxerr,
2813 $ nerr, mem(erriptr), mem(errdptr) )
2814*
2815 CALL schkpad( uplo, diag, m, n, mem, ldadst,
2816 $ rsrc, csrc, myrow, mycol, ipre, ipost,
2817 $ rcheckval, testnum, maxerr, nerr,
2818 $ mem(erriptr), mem(errdptr) )
2819 testok = i .EQ. nerr
2820 END IF
2821*
2822 IF( verb .GT. 1 ) THEN
2823 i = nerr
2824 CALL sbtcheckin( 0, outnum, maxerr, nerr,
2825 $ mem(erriptr), mem(errdptr),
2826 $ tfail )
2827 IF( iam .EQ. 0 ) THEN
2828 IF( testok .AND. i.EQ.nerr ) THEN
2829 WRITE(outnum, 7000) testnum, 'PASSED ',
2830 $ uplo, diag, m, n, ldasrc, ldadst,
2831 $ rsrc, csrc, rdest, cdest, nprow, npcol
2832 ELSE
2833 nfail = nfail + 1
2834 WRITE(outnum, 7000) testnum, 'FAILED ',
2835 $ uplo, diag, m, n, ldasrc, ldadst,
2836 $ rsrc, csrc, rdest, cdest, nprow, npcol
2837 ENDIF
2838 END IF
2839*
2840* Once we've printed out errors, can re-use buf space
2841*
2842 nerr = 0
2843 END IF
2844 60 CONTINUE
2845 70 CONTINUE
2846 80 CONTINUE
2847 110 CONTINUE
2848*
2849 IF( verb .LT. 2 ) THEN
2850 nfail = testnum
2851 CALL sbtcheckin( nfail, outnum, maxerr, nerr, mem(erriptr),
2852 $ mem(errdptr), tfail )
2853 END IF
2854 IF( iam .EQ. 0 ) THEN
2855 IF( verb .GT. 1 ) WRITE(outnum,*) ' '
2856 IF( nfail+nskip .EQ. 0 ) THEN
2857 WRITE(outnum, 8000 ) testnum
2858 ELSE
2859 WRITE(outnum, 9000 ) testnum, testnum-nskip-nfail,
2860 $ nskip, nfail
2861 END IF
2862 END IF
2863*
2864* Log whether their were any failures
2865*
2866 testok = allpass( (nfail.EQ.0) )
2867*
2868 1000 FORMAT('REAL SDRV TESTS: BEGIN.' )
2869 2000 FORMAT(1x,a7,3x,10i6)
2870 3000 FORMAT(1x,a7,3x,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,
2871 $ 5x,a1,5x,a1)
2872 5000 FORMAT(' TEST# STATUS UPLO DIA M N LDAS LDAD RSRC ',
2873 $ 'CSRC RDEST CDEST P Q')
2874 6000 FORMAT(' ----- ------- ---- --- ----- ----- ----- ----- ---- ',
2875 $ '---- ----- ----- ---- ----')
2876 7000 FORMAT(i6,1x,a7,4x,a1,3x,a1,4i6,2i5,2i6,2i5)
2877 8000 FORMAT('REAL SDRV TESTS: PASSED ALL',
2878 $ i5, ' TESTS.')
2879 9000 FORMAT('REAL SDRV TESTS:',i5,' TESTS;',i5,' PASSED,',
2880 $ i5,' SKIPPED,',i5,' FAILED.')
2881*
2882 RETURN
2883*
2884* End of SSDRVTEST.
2885*
2886 END
2887*
2888*
2889 SUBROUTINE dsdrvtest( OUTNUM, VERB, NSHAPE, UPLO0, DIAG0,
2890 $ NMAT, M0, N0, LDAS0, LDAD0, NSRC, RSRC0,
2891 $ CSRC0, RDEST0, CDEST0, NGRID, CONTEXT0,
2892 $ P0, Q0, TFAIL, MEM, MEMLEN )
2893*
2894* -- BLACS tester (version 1.0) --
2895* University of Tennessee
2896* December 15, 1994
2897*
2898*
2899* .. Scalar Arguments ..
2900 INTEGER OUTNUM, VERB, NSHAPE, NMAT, NSRC, NGRID, MEMLEN
2901* ..
2902* .. Array Arguments ..
2903 CHARACTER*1 UPLO0(NSHAPE), DIAG0(NSHAPE)
2904 INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT)
2905 INTEGER RSRC0(NSRC), CSRC0(NSRC), RDEST0(NSRC), CDEST0(NSRC)
2906 INTEGER CONTEXT0(NGRID), P0(NGRID), Q0(NGRID), TFAIL(*)
2907 DOUBLE PRECISION MEM(MEMLEN)
2908* ..
2909*
2910* Purpose
2911* =======
2912* DTESTSDRV: Test double precision send/recv
2913*
2914* Arguments
2915* =========
2916* OUTNUM (input) INTEGER
2917* The device number to write output to.
2918*
2919* VERB (input) INTEGER
2920* The level of verbosity (how much printing to do).
2921*
2922* NSHAPE (input) INTEGER
2923* The number of matrix shapes to be tested.
2924*
2925* UPLO0 (input) CHARACTER*1 array of dimension (NSHAPE)
2926* Values of UPLO to be tested.
2927*
2928* DIAG0 (input) CHARACTER*1 array of dimension (NSHAPE)
2929* Values of DIAG to be tested.
2930*
2931* NMAT (input) INTEGER
2932* The number of matrices to be tested.
2933*
2934* M0 (input) INTEGER array of dimension (NMAT)
2935* Values of M to be tested.
2936*
2937* M0 (input) INTEGER array of dimension (NMAT)
2938* Values of M to be tested.
2939*
2940* N0 (input) INTEGER array of dimension (NMAT)
2941* Values of N to be tested.
2942*
2943* LDAS0 (input) INTEGER array of dimension (NMAT)
2944* Values of LDAS (leading dimension of A on source process)
2945* to be tested.
2946*
2947* LDAD0 (input) INTEGER array of dimension (NMAT)
2948* Values of LDAD (leading dimension of A on destination
2949* process) to be tested.
2950* NSRC (input) INTEGER
2951* The number of sources to be tested.
2952*
2953* RSRC0 (input) INTEGER array of dimension (NDEST)
2954* Values of RSRC (row coordinate of source) to be tested.
2955*
2956* CSRC0 (input) INTEGER array of dimension (NDEST)
2957* Values of CSRC (column coordinate of source) to be tested.
2958*
2959* RDEST0 (input) INTEGER array of dimension (NNSRC)
2960* Values of RDEST (row coordinate of destination) to be
2961* tested.
2962*
2963* CDEST0 (input) INTEGER array of dimension (NNSRC)
2964* Values of CDEST (column coordinate of destination) to be
2965* tested.
2966*
2967* NGRID (input) INTEGER
2968* The number of process grids to be tested.
2969*
2970* CONTEXT0 (input) INTEGER array of dimension (NGRID)
2971* The BLACS context handles corresponding to the grids.
2972*
2973* P0 (input) INTEGER array of dimension (NGRID)
2974* Values of P (number of process rows, NPROW).
2975*
2976* Q0 (input) INTEGER array of dimension (NGRID)
2977* Values of Q (number of process columns, NPCOL).
2978*
2979* TFAIL (workspace) INTEGER array of dimension (NTESTS)
2980* If VERB < 2, serves to indicate which tests fail. This
2981* requires workspace of NTESTS (number of tests performed).
2982*
2983* MEM (workspace) DOUBLE PRECISION array of dimension (MEMLEN)
2984* Used for all other workspaces, including the matrix A,
2985* and its pre and post padding.
2986*
2987* MEMLEN (input) INTEGER
2988* The length, in elements, of MEM.
2989*
2990* =====================================================================
2991*
2992* .. External Functions ..
2993 LOGICAL ALLPASS
2994 INTEGER IBTMYPROC, IBTSIZEOF
2995 EXTERNAL ALLPASS, IBTMYPROC, IBTSIZEOF
2996* ..
2997* .. External Subroutines ..
2998 EXTERNAL BLACS_GRIDINFO
2999 EXTERNAL DTRSD2D, DGESD2D, DTRRV2D, DGERV2D
3000 EXTERNAL DINITMAT, DCHKMAT, DCHKPAD, DBTCHECKIN
3001* ..
3002* .. Local Scalars ..
3003 CHARACTER*1 UPLO, DIAG
3004 LOGICAL TESTOK
3005 INTEGER IAM, I, K, IGR, ISH, IMA, ISO, MYROW, MYCOL, IPRE, IPOST
3006 INTEGER M, N, NPROW, NPCOL, RSRC, CSRC, RDEST, CDEST
3007 INTEGER NERR, NSKIP, NFAIL, TESTNUM, CONTEXT, MAXERR, LDASRC
3008 INTEGER LDADST, ERRDPTR, APTR, ERRIPTR, ISIZE, DSIZE
3009 DOUBLE PRECISION SCHECKVAL, RCHECKVAL
3010* ..
3011* .. Executable Statements ..
3012*
3013 SCHECKVAL = -0.01d0
3014 rcheckval = -0.02d0
3015*
3016 iam = ibtmyproc()
3017 isize = ibtsizeof('I')
3018 dsize = ibtsizeof('D')
3019*
3020* Verify file parameters
3021*
3022 IF( iam .EQ. 0 ) THEN
3023 WRITE(outnum, *) ' '
3024 WRITE(outnum, *) ' '
3025 WRITE(outnum, 1000 )
3026 IF( verb .GT. 0 ) THEN
3027 WRITE(outnum,*) ' '
3028 WRITE(outnum, 2000) 'NSHAPE:', nshape
3029 WRITE(outnum, 3000) ' UPLO :', ( uplo0(i), i = 1, nshape )
3030 WRITE(outnum, 3000) ' DIAG :', ( diag0(i), i = 1, nshape )
3031 WRITE(outnum, 2000) 'NMAT :', nmat
3032 WRITE(outnum, 2000) ' M :', ( m0(i), i = 1, nmat )
3033 WRITE(outnum, 2000) ' N :', ( n0(i), i = 1, nmat )
3034 WRITE(outnum, 2000) ' LDAS :', ( ldas0(i), i = 1, nmat )
3035 WRITE(outnum, 2000) ' LDAD :', ( ldad0(i), i = 1, nmat )
3036 WRITE(outnum, 2000) 'NSRC :', nsrc
3037 WRITE(outnum, 2000) ' RSRC :',( rsrc0(i), i = 1, nsrc )
3038 WRITE(outnum, 2000) ' CSRC :',( csrc0(i), i = 1, nsrc )
3039 WRITE(outnum, 2000) ' RDEST:',( rdest0(i), i = 1, nsrc )
3040 WRITE(outnum, 2000) ' CDEST:',( cdest0(i), i = 1, nsrc )
3041 WRITE(outnum, 2000) 'NGRIDS:', ngrid
3042 WRITE(outnum, 2000) ' P :', ( p0(i), i = 1, ngrid )
3043 WRITE(outnum, 2000) ' Q :', ( q0(i), i = 1, ngrid )
3044 WRITE(outnum, 2000) 'VERB :', verb
3045 WRITE(outnum,*) ' '
3046 END IF
3047 IF( verb .GT. 1 ) THEN
3048 WRITE(outnum,5000)
3049 WRITE(outnum,6000)
3050 END IF
3051 END IF
3052*
3053* Find biggest matrix, so we know where to stick error info
3054*
3055 i = 0
3056 DO 10 ima = 1, nmat
3057 k = n0(ima) * max0( ldas0(ima), ldad0(ima) ) + 4 * m0(ima)
3058 IF( k .GT. i ) i = k
3059 10 CONTINUE
3060 maxerr = ( dsize * (memlen-i) ) / ( dsize*2 + isize*6 )
3061 IF( maxerr .LT. 1 ) THEN
3062 WRITE(outnum,*) 'ERROR: Not enough memory to run SDRV tests.'
3063 CALL blacs_abort(-1, 1)
3064 END IF
3065 errdptr = i + 1
3066 erriptr = errdptr + maxerr
3067 nerr = 0
3068 testnum = 0
3069 nfail = 0
3070 nskip = 0
3071*
3072* Loop over grids of matrix
3073*
3074 DO 110 igr = 1, ngrid
3075*
3076 context = context0(igr)
3077 CALL blacs_gridinfo( context, nprow, npcol, myrow, mycol )
3078*
3079 DO 80 ish = 1, nshape
3080 uplo = uplo0(ish)
3081 diag = diag0(ish)
3082*
3083 DO 70 ima = 1, nmat
3084 m = m0(ima)
3085 n = n0(ima)
3086 ldasrc = ldas0(ima)
3087 ldadst = ldad0(ima)
3088*
3089 DO 60 iso = 1, nsrc
3090 testnum = testnum + 1
3091 rsrc = rsrc0(iso)
3092 csrc = csrc0(iso)
3093 IF( rsrc.GE.p0(igr) .OR. csrc.GE.q0(igr) ) THEN
3094 nskip = nskip + 1
3095 GOTO 60
3096 END IF
3097 rdest = rdest0(iso)
3098 cdest = cdest0(iso)
3099 IF( rdest.GE.p0(igr) .OR. cdest.GE.q0(igr) ) THEN
3100 nskip = nskip + 1
3101 GOTO 60
3102 END IF
3103*
3104 IF( verb .GT. 1 ) THEN
3105 IF( iam .EQ. 0 ) THEN
3106 WRITE(outnum, 7000) testnum, 'RUNNING',
3107 $ uplo, diag, m, n,
3108 $ ldasrc, ldadst, rsrc, csrc,
3109 $ rdest, cdest, nprow, npcol
3110 END IF
3111 END IF
3112*
3113 testok = .true.
3114 ipre = 2 * m
3115 ipost = ipre
3116 aptr = ipre + 1
3117*
3118* source process generates matrix and sends it
3119*
3120 IF( myrow .EQ. rsrc .AND. mycol .EQ. csrc ) THEN
3121 CALL dinitmat( uplo, diag, m, n, mem, ldasrc,
3122 $ ipre, ipost, scheckval, testnum,
3123 $ myrow, mycol )
3124*
3125 IF( uplo .EQ. 'U' .OR. uplo .EQ. 'L' ) THEN
3126 CALL dtrsd2d( context, uplo, diag, m, n,
3127 $ mem(aptr), ldasrc, rdest, cdest )
3128 ELSE
3129 CALL dgesd2d( context, m, n, mem(aptr),
3130 $ ldasrc, rdest, cdest )
3131 END IF
3132 END IF
3133*
3134 IF( myrow .EQ. rdest .AND. mycol .EQ. cdest ) THEN
3135*
3136* Pad entire matrix area
3137*
3138 DO 50 k = 1, ipre+ipost+ldadst*n
3139 mem(k) = rcheckval
3140 50 CONTINUE
3141*
3142* Receive matrix
3143*
3144 IF( uplo .EQ. 'U' .OR. uplo .EQ. 'L' ) THEN
3145 CALL dtrrv2d( context, uplo, diag, m, n,
3146 $ mem(aptr), ldadst, rsrc, csrc )
3147 ELSE
3148 CALL dgerv2d( context, m, n, mem(aptr),
3149 $ ldadst, rsrc, csrc )
3150 END IF
3151*
3152* Check for errors in matrix or padding
3153*
3154 i = nerr
3155 CALL dchkmat( uplo, diag, m, n, mem(aptr), ldadst,
3156 $ rsrc, csrc, myrow, mycol, testnum, maxerr,
3157 $ nerr, mem(erriptr), mem(errdptr) )
3158*
3159 CALL dchkpad( uplo, diag, m, n, mem, ldadst,
3160 $ rsrc, csrc, myrow, mycol, ipre, ipost,
3161 $ rcheckval, testnum, maxerr, nerr,
3162 $ mem(erriptr), mem(errdptr) )
3163 testok = i .EQ. nerr
3164 END IF
3165*
3166 IF( verb .GT. 1 ) THEN
3167 i = nerr
3168 CALL dbtcheckin( 0, outnum, maxerr, nerr,
3169 $ mem(erriptr), mem(errdptr),
3170 $ tfail )
3171 IF( iam .EQ. 0 ) THEN
3172 IF( testok .AND. i.EQ.nerr ) THEN
3173 WRITE(outnum, 7000) testnum, 'PASSED ',
3174 $ uplo, diag, m, n, ldasrc, ldadst,
3175 $ rsrc, csrc, rdest, cdest, nprow, npcol
3176 ELSE
3177 nfail = nfail + 1
3178 WRITE(outnum, 7000) testnum, 'FAILED ',
3179 $ uplo, diag, m, n, ldasrc, ldadst,
3180 $ rsrc, csrc, rdest, cdest, nprow, npcol
3181 ENDIF
3182 END IF
3183*
3184* Once we've printed out errors, can re-use buf space
3185*
3186 nerr = 0
3187 END IF
3188 60 CONTINUE
3189 70 CONTINUE
3190 80 CONTINUE
3191 110 CONTINUE
3192*
3193 IF( verb .LT. 2 ) THEN
3194 nfail = testnum
3195 CALL dbtcheckin( nfail, outnum, maxerr, nerr, mem(erriptr),
3196 $ mem(errdptr), tfail )
3197 END IF
3198 IF( iam .EQ. 0 ) THEN
3199 IF( verb .GT. 1 ) WRITE(outnum,*) ' '
3200 IF( nfail+nskip .EQ. 0 ) THEN
3201 WRITE(outnum, 8000 ) testnum
3202 ELSE
3203 WRITE(outnum, 9000 ) testnum, testnum-nskip-nfail,
3204 $ nskip, nfail
3205 END IF
3206 END IF
3207*
3208* Log whether their were any failures
3209*
3210 testok = allpass( (nfail.EQ.0) )
3211*
3212 1000 FORMAT('DOUBLE PRECISION SDRV TESTS: BEGIN.' )
3213 2000 FORMAT(1x,a7,3x,10i6)
3214 3000 FORMAT(1x,a7,3x,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,
3215 $ 5x,a1,5x,a1)
3216 5000 FORMAT(' TEST# STATUS UPLO DIA M N LDAS LDAD RSRC ',
3217 $ 'CSRC RDEST CDEST P Q')
3218 6000 FORMAT(' ----- ------- ---- --- ----- ----- ----- ----- ---- ',
3219 $ '---- ----- ----- ---- ----')
3220 7000 FORMAT(i6,1x,a7,4x,a1,3x,a1,4i6,2i5,2i6,2i5)
3221 8000 FORMAT('DOUBLE PRECISION SDRV TESTS: PASSED ALL',
3222 $ i5, ' TESTS.')
3223 9000 FORMAT('DOUBLE PRECISION SDRV TESTS:',i5,' TESTS;',i5,' PASSED,',
3224 $ i5,' SKIPPED,',i5,' FAILED.')
3225*
3226 RETURN
3227*
3228* End of DSDRVTEST.
3229*
3230 END
3231*
3232*
3233 SUBROUTINE csdrvtest( OUTNUM, VERB, NSHAPE, UPLO0, DIAG0,
3234 $ NMAT, M0, N0, LDAS0, LDAD0, NSRC, RSRC0,
3235 $ CSRC0, RDEST0, CDEST0, NGRID, CONTEXT0,
3236 $ P0, Q0, TFAIL, MEM, MEMLEN )
3237*
3238* -- BLACS tester (version 1.0) --
3239* University of Tennessee
3240* December 15, 1994
3241*
3242*
3243* .. Scalar Arguments ..
3244 INTEGER OUTNUM, VERB, NSHAPE, NMAT, NSRC, NGRID, MEMLEN
3245* ..
3246* .. Array Arguments ..
3247 CHARACTER*1 UPLO0(NSHAPE), DIAG0(NSHAPE)
3248 INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT)
3249 INTEGER RSRC0(NSRC), CSRC0(NSRC), RDEST0(NSRC), CDEST0(NSRC)
3250 INTEGER CONTEXT0(NGRID), P0(NGRID), Q0(NGRID), TFAIL(*)
3251 COMPLEX MEM(MEMLEN)
3252* ..
3253*
3254* Purpose
3255* =======
3256* CTESTSDRV: Test complex send/recv
3257*
3258* Arguments
3259* =========
3260* OUTNUM (input) INTEGER
3261* The device number to write output to.
3262*
3263* VERB (input) INTEGER
3264* The level of verbosity (how much printing to do).
3265*
3266* NSHAPE (input) INTEGER
3267* The number of matrix shapes to be tested.
3268*
3269* UPLO0 (input) CHARACTER*1 array of dimension (NSHAPE)
3270* Values of UPLO to be tested.
3271*
3272* DIAG0 (input) CHARACTER*1 array of dimension (NSHAPE)
3273* Values of DIAG to be tested.
3274*
3275* NMAT (input) INTEGER
3276* The number of matrices to be tested.
3277*
3278* M0 (input) INTEGER array of dimension (NMAT)
3279* Values of M to be tested.
3280*
3281* M0 (input) INTEGER array of dimension (NMAT)
3282* Values of M to be tested.
3283*
3284* N0 (input) INTEGER array of dimension (NMAT)
3285* Values of N to be tested.
3286*
3287* LDAS0 (input) INTEGER array of dimension (NMAT)
3288* Values of LDAS (leading dimension of A on source process)
3289* to be tested.
3290*
3291* LDAD0 (input) INTEGER array of dimension (NMAT)
3292* Values of LDAD (leading dimension of A on destination
3293* process) to be tested.
3294* NSRC (input) INTEGER
3295* The number of sources to be tested.
3296*
3297* RSRC0 (input) INTEGER array of dimension (NDEST)
3298* Values of RSRC (row coordinate of source) to be tested.
3299*
3300* CSRC0 (input) INTEGER array of dimension (NDEST)
3301* Values of CSRC (column coordinate of source) to be tested.
3302*
3303* RDEST0 (input) INTEGER array of dimension (NNSRC)
3304* Values of RDEST (row coordinate of destination) to be
3305* tested.
3306*
3307* CDEST0 (input) INTEGER array of dimension (NNSRC)
3308* Values of CDEST (column coordinate of destination) to be
3309* tested.
3310*
3311* NGRID (input) INTEGER
3312* The number of process grids to be tested.
3313*
3314* CONTEXT0 (input) INTEGER array of dimension (NGRID)
3315* The BLACS context handles corresponding to the grids.
3316*
3317* P0 (input) INTEGER array of dimension (NGRID)
3318* Values of P (number of process rows, NPROW).
3319*
3320* Q0 (input) INTEGER array of dimension (NGRID)
3321* Values of Q (number of process columns, NPCOL).
3322*
3323* TFAIL (workspace) INTEGER array of dimension (NTESTS)
3324* If VERB < 2, serves to indicate which tests fail. This
3325* requires workspace of NTESTS (number of tests performed).
3326*
3327* MEM (workspace) COMPLEX array of dimension (MEMLEN)
3328* Used for all other workspaces, including the matrix A,
3329* and its pre and post padding.
3330*
3331* MEMLEN (input) INTEGER
3332* The length, in elements, of MEM.
3333*
3334* =====================================================================
3335*
3336* .. External Functions ..
3337 LOGICAL ALLPASS
3338 INTEGER IBTMYPROC, IBTSIZEOF
3339 EXTERNAL ALLPASS, IBTMYPROC, IBTSIZEOF
3340* ..
3341* .. External Subroutines ..
3342 EXTERNAL BLACS_GRIDINFO
3343 EXTERNAL CTRSD2D, CGESD2D, CTRRV2D, CGERV2D
3344 EXTERNAL CINITMAT, CCHKMAT, CCHKPAD, CBTCHECKIN
3345* ..
3346* .. Local Scalars ..
3347 CHARACTER*1 UPLO, DIAG
3348 LOGICAL TESTOK
3349 INTEGER IAM, I, K, IGR, ISH, IMA, ISO, MYROW, MYCOL, IPRE, IPOST
3350 INTEGER M, N, NPROW, NPCOL, RSRC, CSRC, RDEST, CDEST
3351 INTEGER NERR, NSKIP, NFAIL, TESTNUM, CONTEXT, MAXERR, LDASRC
3352 INTEGER LDADST, ERRDPTR, APTR, ERRIPTR, ISIZE, CSIZE
3353 COMPLEX SCHECKVAL, RCHECKVAL
3354* ..
3355* .. Executable Statements ..
3356*
3357 SCHECKVAL = cmplx( -0.01, -0.01 )
3358 rcheckval = cmplx( -0.02, -0.02 )
3359*
3360 iam = ibtmyproc()
3361 isize = ibtsizeof('I')
3362 csize = ibtsizeof('C')
3363*
3364* Verify file parameters
3365*
3366 IF( iam .EQ. 0 ) THEN
3367 WRITE(outnum, *) ' '
3368 WRITE(outnum, *) ' '
3369 WRITE(outnum, 1000 )
3370 IF( verb .GT. 0 ) THEN
3371 WRITE(outnum,*) ' '
3372 WRITE(outnum, 2000) 'NSHAPE:', nshape
3373 WRITE(outnum, 3000) ' UPLO :', ( uplo0(i), i = 1, nshape )
3374 WRITE(outnum, 3000) ' DIAG :', ( diag0(i), i = 1, nshape )
3375 WRITE(outnum, 2000) 'NMAT :', nmat
3376 WRITE(outnum, 2000) ' M :', ( m0(i), i = 1, nmat )
3377 WRITE(outnum, 2000) ' N :', ( n0(i), i = 1, nmat )
3378 WRITE(outnum, 2000) ' LDAS :', ( ldas0(i), i = 1, nmat )
3379 WRITE(outnum, 2000) ' LDAD :', ( ldad0(i), i = 1, nmat )
3380 WRITE(outnum, 2000) 'NSRC :', nsrc
3381 WRITE(outnum, 2000) ' RSRC :',( rsrc0(i), i = 1, nsrc )
3382 WRITE(outnum, 2000) ' CSRC :',( csrc0(i), i = 1, nsrc )
3383 WRITE(outnum, 2000) ' RDEST:',( rdest0(i), i = 1, nsrc )
3384 WRITE(outnum, 2000) ' CDEST:',( cdest0(i), i = 1, nsrc )
3385 WRITE(outnum, 2000) 'NGRIDS:', ngrid
3386 WRITE(outnum, 2000) ' P :', ( p0(i), i = 1, ngrid )
3387 WRITE(outnum, 2000) ' Q :', ( q0(i), i = 1, ngrid )
3388 WRITE(outnum, 2000) 'VERB :', verb
3389 WRITE(outnum,*) ' '
3390 END IF
3391 IF( verb .GT. 1 ) THEN
3392 WRITE(outnum,5000)
3393 WRITE(outnum,6000)
3394 END IF
3395 END IF
3396*
3397* Find biggest matrix, so we know where to stick error info
3398*
3399 i = 0
3400 DO 10 ima = 1, nmat
3401 k = n0(ima) * max0( ldas0(ima), ldad0(ima) ) + 4 * m0(ima)
3402 IF( k .GT. i ) i = k
3403 10 CONTINUE
3404 maxerr = ( csize * (memlen-i) ) / ( csize*2 + isize*6 )
3405 IF( maxerr .LT. 1 ) THEN
3406 WRITE(outnum,*) 'ERROR: Not enough memory to run SDRV tests.'
3407 CALL blacs_abort(-1, 1)
3408 END IF
3409 errdptr = i + 1
3410 erriptr = errdptr + maxerr
3411 nerr = 0
3412 testnum = 0
3413 nfail = 0
3414 nskip = 0
3415*
3416* Loop over grids of matrix
3417*
3418 DO 110 igr = 1, ngrid
3419*
3420 context = context0(igr)
3421 CALL blacs_gridinfo( context, nprow, npcol, myrow, mycol )
3422*
3423 DO 80 ish = 1, nshape
3424 uplo = uplo0(ish)
3425 diag = diag0(ish)
3426*
3427 DO 70 ima = 1, nmat
3428 m = m0(ima)
3429 n = n0(ima)
3430 ldasrc = ldas0(ima)
3431 ldadst = ldad0(ima)
3432*
3433 DO 60 iso = 1, nsrc
3434 testnum = testnum + 1
3435 rsrc = rsrc0(iso)
3436 csrc = csrc0(iso)
3437 IF( rsrc.GE.p0(igr) .OR. csrc.GE.q0(igr) ) THEN
3438 nskip = nskip + 1
3439 GOTO 60
3440 END IF
3441 rdest = rdest0(iso)
3442 cdest = cdest0(iso)
3443 IF( rdest.GE.p0(igr) .OR. cdest.GE.q0(igr) ) THEN
3444 nskip = nskip + 1
3445 GOTO 60
3446 END IF
3447*
3448 IF( verb .GT. 1 ) THEN
3449 IF( iam .EQ. 0 ) THEN
3450 WRITE(outnum, 7000) testnum, 'RUNNING',
3451 $ uplo, diag, m, n,
3452 $ ldasrc, ldadst, rsrc, csrc,
3453 $ rdest, cdest, nprow, npcol
3454 END IF
3455 END IF
3456*
3457 testok = .true.
3458 ipre = 2 * m
3459 ipost = ipre
3460 aptr = ipre + 1
3461*
3462* source process generates matrix and sends it
3463*
3464 IF( myrow .EQ. rsrc .AND. mycol .EQ. csrc ) THEN
3465 CALL cinitmat( uplo, diag, m, n, mem, ldasrc,
3466 $ ipre, ipost, scheckval, testnum,
3467 $ myrow, mycol )
3468*
3469 IF( uplo .EQ. 'U' .OR. uplo .EQ. 'L' ) THEN
3470 CALL ctrsd2d( context, uplo, diag, m, n,
3471 $ mem(aptr), ldasrc, rdest, cdest )
3472 ELSE
3473 CALL cgesd2d( context, m, n, mem(aptr),
3474 $ ldasrc, rdest, cdest )
3475 END IF
3476 END IF
3477*
3478 IF( myrow .EQ. rdest .AND. mycol .EQ. cdest ) THEN
3479*
3480* Pad entire matrix area
3481*
3482 DO 50 k = 1, ipre+ipost+ldadst*n
3483 mem(k) = rcheckval
3484 50 CONTINUE
3485*
3486* Receive matrix
3487*
3488 IF( uplo .EQ. 'U' .OR. uplo .EQ. 'L' ) THEN
3489 CALL ctrrv2d( context, uplo, diag, m, n,
3490 $ mem(aptr), ldadst, rsrc, csrc )
3491 ELSE
3492 CALL cgerv2d( context, m, n, mem(aptr),
3493 $ ldadst, rsrc, csrc )
3494 END IF
3495*
3496* Check for errors in matrix or padding
3497*
3498 i = nerr
3499 CALL cchkmat( uplo, diag, m, n, mem(aptr), ldadst,
3500 $ rsrc, csrc, myrow, mycol, testnum, maxerr,
3501 $ nerr, mem(erriptr), mem(errdptr) )
3502*
3503 CALL cchkpad( uplo, diag, m, n, mem, ldadst,
3504 $ rsrc, csrc, myrow, mycol, ipre, ipost,
3505 $ rcheckval, testnum, maxerr, nerr,
3506 $ mem(erriptr), mem(errdptr) )
3507 testok = i .EQ. nerr
3508 END IF
3509*
3510 IF( verb .GT. 1 ) THEN
3511 i = nerr
3512 CALL cbtcheckin( 0, outnum, maxerr, nerr,
3513 $ mem(erriptr), mem(errdptr),
3514 $ tfail )
3515 IF( iam .EQ. 0 ) THEN
3516 IF( testok .AND. i.EQ.nerr ) THEN
3517 WRITE(outnum, 7000) testnum, 'PASSED ',
3518 $ uplo, diag, m, n, ldasrc, ldadst,
3519 $ rsrc, csrc, rdest, cdest, nprow, npcol
3520 ELSE
3521 nfail = nfail + 1
3522 WRITE(outnum, 7000) testnum, 'FAILED ',
3523 $ uplo, diag, m, n, ldasrc, ldadst,
3524 $ rsrc, csrc, rdest, cdest, nprow, npcol
3525 ENDIF
3526 END IF
3527*
3528* Once we've printed out errors, can re-use buf space
3529*
3530 nerr = 0
3531 END IF
3532 60 CONTINUE
3533 70 CONTINUE
3534 80 CONTINUE
3535 110 CONTINUE
3536*
3537 IF( verb .LT. 2 ) THEN
3538 nfail = testnum
3539 CALL cbtcheckin( nfail, outnum, maxerr, nerr, mem(erriptr),
3540 $ mem(errdptr), tfail )
3541 END IF
3542 IF( iam .EQ. 0 ) THEN
3543 IF( verb .GT. 1 ) WRITE(outnum,*) ' '
3544 IF( nfail+nskip .EQ. 0 ) THEN
3545 WRITE(outnum, 8000 ) testnum
3546 ELSE
3547 WRITE(outnum, 9000 ) testnum, testnum-nskip-nfail,
3548 $ nskip, nfail
3549 END IF
3550 END IF
3551*
3552* Log whether their were any failures
3553*
3554 testok = allpass( (nfail.EQ.0) )
3555*
3556 1000 FORMAT('COMPLEX SDRV TESTS: BEGIN.' )
3557 2000 FORMAT(1x,a7,3x,10i6)
3558 3000 FORMAT(1x,a7,3x,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,
3559 $ 5x,a1,5x,a1)
3560 5000 FORMAT(' TEST# STATUS UPLO DIA M N LDAS LDAD RSRC ',
3561 $ 'CSRC RDEST CDEST P Q')
3562 6000 FORMAT(' ----- ------- ---- --- ----- ----- ----- ----- ---- ',
3563 $ '---- ----- ----- ---- ----')
3564 7000 FORMAT(i6,1x,a7,4x,a1,3x,a1,4i6,2i5,2i6,2i5)
3565 8000 FORMAT('COMPLEX SDRV TESTS: PASSED ALL',
3566 $ i5, ' TESTS.')
3567 9000 FORMAT('COMPLEX SDRV TESTS:',i5,' TESTS;',i5,' PASSED,',
3568 $ i5,' SKIPPED,',i5,' FAILED.')
3569*
3570 RETURN
3571*
3572* End of CSDRVTEST.
3573*
3574 END
3575*
3576*
3577 SUBROUTINE zsdrvtest( OUTNUM, VERB, NSHAPE, UPLO0, DIAG0,
3578 $ NMAT, M0, N0, LDAS0, LDAD0, NSRC, RSRC0,
3579 $ CSRC0, RDEST0, CDEST0, NGRID, CONTEXT0,
3580 $ P0, Q0, TFAIL, MEM, MEMLEN )
3581*
3582* -- BLACS tester (version 1.0) --
3583* University of Tennessee
3584* December 15, 1994
3585*
3586*
3587* .. Scalar Arguments ..
3588 INTEGER OUTNUM, VERB, NSHAPE, NMAT, NSRC, NGRID, MEMLEN
3589* ..
3590* .. Array Arguments ..
3591 CHARACTER*1 UPLO0(NSHAPE), DIAG0(NSHAPE)
3592 INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT)
3593 INTEGER RSRC0(NSRC), CSRC0(NSRC), RDEST0(NSRC), CDEST0(NSRC)
3594 INTEGER CONTEXT0(NGRID), P0(NGRID), Q0(NGRID), TFAIL(*)
3595 DOUBLE COMPLEX MEM(MEMLEN)
3596* ..
3597*
3598* Purpose
3599* =======
3600* ZTESTSDRV: Test double complex send/recv
3601*
3602* Arguments
3603* =========
3604* OUTNUM (input) INTEGER
3605* The device number to write output to.
3606*
3607* VERB (input) INTEGER
3608* The level of verbosity (how much printing to do).
3609*
3610* NSHAPE (input) INTEGER
3611* The number of matrix shapes to be tested.
3612*
3613* UPLO0 (input) CHARACTER*1 array of dimension (NSHAPE)
3614* Values of UPLO to be tested.
3615*
3616* DIAG0 (input) CHARACTER*1 array of dimension (NSHAPE)
3617* Values of DIAG to be tested.
3618*
3619* NMAT (input) INTEGER
3620* The number of matrices to be tested.
3621*
3622* M0 (input) INTEGER array of dimension (NMAT)
3623* Values of M to be tested.
3624*
3625* M0 (input) INTEGER array of dimension (NMAT)
3626* Values of M to be tested.
3627*
3628* N0 (input) INTEGER array of dimension (NMAT)
3629* Values of N to be tested.
3630*
3631* LDAS0 (input) INTEGER array of dimension (NMAT)
3632* Values of LDAS (leading dimension of A on source process)
3633* to be tested.
3634*
3635* LDAD0 (input) INTEGER array of dimension (NMAT)
3636* Values of LDAD (leading dimension of A on destination
3637* process) to be tested.
3638* NSRC (input) INTEGER
3639* The number of sources to be tested.
3640*
3641* RSRC0 (input) INTEGER array of dimension (NDEST)
3642* Values of RSRC (row coordinate of source) to be tested.
3643*
3644* CSRC0 (input) INTEGER array of dimension (NDEST)
3645* Values of CSRC (column coordinate of source) to be tested.
3646*
3647* RDEST0 (input) INTEGER array of dimension (NNSRC)
3648* Values of RDEST (row coordinate of destination) to be
3649* tested.
3650*
3651* CDEST0 (input) INTEGER array of dimension (NNSRC)
3652* Values of CDEST (column coordinate of destination) to be
3653* tested.
3654*
3655* NGRID (input) INTEGER
3656* The number of process grids to be tested.
3657*
3658* CONTEXT0 (input) INTEGER array of dimension (NGRID)
3659* The BLACS context handles corresponding to the grids.
3660*
3661* P0 (input) INTEGER array of dimension (NGRID)
3662* Values of P (number of process rows, NPROW).
3663*
3664* Q0 (input) INTEGER array of dimension (NGRID)
3665* Values of Q (number of process columns, NPCOL).
3666*
3667* TFAIL (workspace) INTEGER array of dimension (NTESTS)
3668* If VERB < 2, serves to indicate which tests fail. This
3669* requires workspace of NTESTS (number of tests performed).
3670*
3671* MEM (workspace) DOUBLE COMPLEX array of dimension (MEMLEN)
3672* Used for all other workspaces, including the matrix A,
3673* and its pre and post padding.
3674*
3675* MEMLEN (input) INTEGER
3676* The length, in elements, of MEM.
3677*
3678* =====================================================================
3679*
3680* .. External Functions ..
3681 LOGICAL ALLPASS
3682 INTEGER IBTMYPROC, IBTSIZEOF
3683 EXTERNAL ALLPASS, IBTMYPROC, IBTSIZEOF
3684* ..
3685* .. External Subroutines ..
3686 EXTERNAL BLACS_GRIDINFO
3687 EXTERNAL ZTRSD2D, ZGESD2D, ZTRRV2D, ZGERV2D
3688 EXTERNAL ZINITMAT, ZCHKMAT, ZCHKPAD, ZBTCHECKIN
3689* ..
3690* .. Local Scalars ..
3691 CHARACTER*1 UPLO, DIAG
3692 LOGICAL TESTOK
3693 INTEGER IAM, I, K, IGR, ISH, IMA, ISO, MYROW, MYCOL, IPRE, IPOST
3694 INTEGER M, N, NPROW, NPCOL, RSRC, CSRC, RDEST, CDEST
3695 INTEGER NERR, NSKIP, NFAIL, TESTNUM, CONTEXT, MAXERR, LDASRC
3696 INTEGER LDADST, ERRDPTR, APTR, ERRIPTR, ISIZE, ZSIZE
3697 DOUBLE COMPLEX SCHECKVAL, RCHECKVAL
3698* ..
3699* .. Executable Statements ..
3700*
3701 SCHECKVAL = dcmplx( -0.01d0, -0.01d0 )
3702 rcheckval = dcmplx( -0.02d0, -0.02d0 )
3703*
3704 iam = ibtmyproc()
3705 isize = ibtsizeof('I')
3706 zsize = ibtsizeof('Z')
3707*
3708* Verify file parameters
3709*
3710 IF( iam .EQ. 0 ) THEN
3711 WRITE(outnum, *) ' '
3712 WRITE(outnum, *) ' '
3713 WRITE(outnum, 1000 )
3714 IF( verb .GT. 0 ) THEN
3715 WRITE(outnum,*) ' '
3716 WRITE(outnum, 2000) 'NSHAPE:', nshape
3717 WRITE(outnum, 3000) ' UPLO :', ( uplo0(i), i = 1, nshape )
3718 WRITE(outnum, 3000) ' DIAG :', ( diag0(i), i = 1, nshape )
3719 WRITE(outnum, 2000) 'NMAT :', nmat
3720 WRITE(outnum, 2000) ' M :', ( m0(i), i = 1, nmat )
3721 WRITE(outnum, 2000) ' N :', ( n0(i), i = 1, nmat )
3722 WRITE(outnum, 2000) ' LDAS :', ( ldas0(i), i = 1, nmat )
3723 WRITE(outnum, 2000) ' LDAD :', ( ldad0(i), i = 1, nmat )
3724 WRITE(outnum, 2000) 'NSRC :', nsrc
3725 WRITE(outnum, 2000) ' RSRC :',( rsrc0(i), i = 1, nsrc )
3726 WRITE(outnum, 2000) ' CSRC :',( csrc0(i), i = 1, nsrc )
3727 WRITE(outnum, 2000) ' RDEST:',( rdest0(i), i = 1, nsrc )
3728 WRITE(outnum, 2000) ' CDEST:',( cdest0(i), i = 1, nsrc )
3729 WRITE(outnum, 2000) 'NGRIDS:', ngrid
3730 WRITE(outnum, 2000) ' P :', ( p0(i), i = 1, ngrid )
3731 WRITE(outnum, 2000) ' Q :', ( q0(i), i = 1, ngrid )
3732 WRITE(outnum, 2000) 'VERB :', verb
3733 WRITE(outnum,*) ' '
3734 END IF
3735 IF( verb .GT. 1 ) THEN
3736 WRITE(outnum,5000)
3737 WRITE(outnum,6000)
3738 END IF
3739 END IF
3740*
3741* Find biggest matrix, so we know where to stick error info
3742*
3743 i = 0
3744 DO 10 ima = 1, nmat
3745 k = n0(ima) * max0( ldas0(ima), ldad0(ima) ) + 4 * m0(ima)
3746 IF( k .GT. i ) i = k
3747 10 CONTINUE
3748 maxerr = ( zsize * (memlen-i) ) / ( zsize*2 + isize*6 )
3749 IF( maxerr .LT. 1 ) THEN
3750 WRITE(outnum,*) 'ERROR: Not enough memory to run SDRV tests.'
3751 CALL blacs_abort(-1, 1)
3752 END IF
3753 errdptr = i + 1
3754 erriptr = errdptr + maxerr
3755 nerr = 0
3756 testnum = 0
3757 nfail = 0
3758 nskip = 0
3759*
3760* Loop over grids of matrix
3761*
3762 DO 110 igr = 1, ngrid
3763*
3764 context = context0(igr)
3765 CALL blacs_gridinfo( context, nprow, npcol, myrow, mycol )
3766*
3767 DO 80 ish = 1, nshape
3768 uplo = uplo0(ish)
3769 diag = diag0(ish)
3770*
3771 DO 70 ima = 1, nmat
3772 m = m0(ima)
3773 n = n0(ima)
3774 ldasrc = ldas0(ima)
3775 ldadst = ldad0(ima)
3776*
3777 DO 60 iso = 1, nsrc
3778 testnum = testnum + 1
3779 rsrc = rsrc0(iso)
3780 csrc = csrc0(iso)
3781 IF( rsrc.GE.p0(igr) .OR. csrc.GE.q0(igr) ) THEN
3782 nskip = nskip + 1
3783 GOTO 60
3784 END IF
3785 rdest = rdest0(iso)
3786 cdest = cdest0(iso)
3787 IF( rdest.GE.p0(igr) .OR. cdest.GE.q0(igr) ) THEN
3788 nskip = nskip + 1
3789 GOTO 60
3790 END IF
3791*
3792 IF( verb .GT. 1 ) THEN
3793 IF( iam .EQ. 0 ) THEN
3794 WRITE(outnum, 7000) testnum, 'RUNNING',
3795 $ uplo, diag, m, n,
3796 $ ldasrc, ldadst, rsrc, csrc,
3797 $ rdest, cdest, nprow, npcol
3798 END IF
3799 END IF
3800*
3801 testok = .true.
3802 ipre = 2 * m
3803 ipost = ipre
3804 aptr = ipre + 1
3805*
3806* source process generates matrix and sends it
3807*
3808 IF( myrow .EQ. rsrc .AND. mycol .EQ. csrc ) THEN
3809 CALL zinitmat( uplo, diag, m, n, mem, ldasrc,
3810 $ ipre, ipost, scheckval, testnum,
3811 $ myrow, mycol )
3812*
3813 IF( uplo .EQ. 'U' .OR. uplo .EQ. 'L' ) THEN
3814 CALL ztrsd2d( context, uplo, diag, m, n,
3815 $ mem(aptr), ldasrc, rdest, cdest )
3816 ELSE
3817 CALL zgesd2d( context, m, n, mem(aptr),
3818 $ ldasrc, rdest, cdest )
3819 END IF
3820 END IF
3821*
3822 IF( myrow .EQ. rdest .AND. mycol .EQ. cdest ) THEN
3823*
3824* Pad entire matrix area
3825*
3826 DO 50 k = 1, ipre+ipost+ldadst*n
3827 mem(k) = rcheckval
3828 50 CONTINUE
3829*
3830* Receive matrix
3831*
3832 IF( uplo .EQ. 'U' .OR. uplo .EQ. 'L' ) THEN
3833 CALL ztrrv2d( context, uplo, diag, m, n,
3834 $ mem(aptr), ldadst, rsrc, csrc )
3835 ELSE
3836 CALL zgerv2d( context, m, n, mem(aptr),
3837 $ ldadst, rsrc, csrc )
3838 END IF
3839*
3840* Check for errors in matrix or padding
3841*
3842 i = nerr
3843 CALL zchkmat( uplo, diag, m, n, mem(aptr), ldadst,
3844 $ rsrc, csrc, myrow, mycol, testnum, maxerr,
3845 $ nerr, mem(erriptr), mem(errdptr) )
3846*
3847 CALL zchkpad( uplo, diag, m, n, mem, ldadst,
3848 $ rsrc, csrc, myrow, mycol, ipre, ipost,
3849 $ rcheckval, testnum, maxerr, nerr,
3850 $ mem(erriptr), mem(errdptr) )
3851 testok = i .EQ. nerr
3852 END IF
3853*
3854 IF( verb .GT. 1 ) THEN
3855 i = nerr
3856 CALL zbtcheckin( 0, outnum, maxerr, nerr,
3857 $ mem(erriptr), mem(errdptr),
3858 $ tfail )
3859 IF( iam .EQ. 0 ) THEN
3860 IF( testok .AND. i.EQ.nerr ) THEN
3861 WRITE(outnum, 7000) testnum, 'PASSED ',
3862 $ uplo, diag, m, n, ldasrc, ldadst,
3863 $ rsrc, csrc, rdest, cdest, nprow, npcol
3864 ELSE
3865 nfail = nfail + 1
3866 WRITE(outnum, 7000) testnum, 'FAILED ',
3867 $ uplo, diag, m, n, ldasrc, ldadst,
3868 $ rsrc, csrc, rdest, cdest, nprow, npcol
3869 ENDIF
3870 END IF
3871*
3872* Once we've printed out errors, can re-use buf space
3873*
3874 nerr = 0
3875 END IF
3876 60 CONTINUE
3877 70 CONTINUE
3878 80 CONTINUE
3879 110 CONTINUE
3880*
3881 IF( verb .LT. 2 ) THEN
3882 nfail = testnum
3883 CALL zbtcheckin( nfail, outnum, maxerr, nerr, mem(erriptr),
3884 $ mem(errdptr), tfail )
3885 END IF
3886 IF( iam .EQ. 0 ) THEN
3887 IF( verb .GT. 1 ) WRITE(outnum,*) ' '
3888 IF( nfail+nskip .EQ. 0 ) THEN
3889 WRITE(outnum, 8000 ) testnum
3890 ELSE
3891 WRITE(outnum, 9000 ) testnum, testnum-nskip-nfail,
3892 $ nskip, nfail
3893 END IF
3894 END IF
3895*
3896* Log whether their were any failures
3897*
3898 testok = allpass( (nfail.EQ.0) )
3899*
3900 1000 FORMAT('DOUBLE COMPLEX SDRV TESTS: BEGIN.' )
3901 2000 FORMAT(1x,a7,3x,10i6)
3902 3000 FORMAT(1x,a7,3x,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,
3903 $ 5x,a1,5x,a1)
3904 5000 FORMAT(' TEST# STATUS UPLO DIA M N LDAS LDAD RSRC ',
3905 $ 'CSRC RDEST CDEST P Q')
3906 6000 FORMAT(' ----- ------- ---- --- ----- ----- ----- ----- ---- ',
3907 $ '---- ----- ----- ---- ----')
3908 7000 FORMAT(i6,1x,a7,4x,a1,3x,a1,4i6,2i5,2i6,2i5)
3909 8000 FORMAT('DOUBLE COMPLEX SDRV TESTS: PASSED ALL',
3910 $ i5, ' TESTS.')
3911 9000 FORMAT('DOUBLE COMPLEX SDRV TESTS:',i5,' TESTS;',i5,' PASSED,',
3912 $ i5,' SKIPPED,',i5,' FAILED.')
3913*
3914 RETURN
3915*
3916* End of ZSDRVTEST.
3917*
3918 END
3919*
3920*
3921 SUBROUTINE ibsbrtest( OUTNUM, VERB, NSCOPE, SCOPE0, NTOP, TOP0,
3922 $ NSHAPE, UPLO0, DIAG0, NMAT, M0, N0, LDAS0,
3923 $ LDAD0, NSRC, RSRC0, CSRC0, NGRID, CONTEXT0,
3924 $ P0, Q0, TFAIL, MEM, MEMLEN )
3925*
3926* -- BLACS tester (version 1.0) --
3927* University of Tennessee
3928* December 15, 1994
3929*
3930*
3931* .. Scalar Arguments ..
3932 INTEGER OUTNUM, VERB, NSCOPE, NTOP, NSHAPE, NMAT, NSRC, NGRID
3933 INTEGER MEMLEN
3934* ..
3935* .. Array Arguments ..
3936 CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP)
3937 CHARACTER*1 UPLO0(NSHAPE), DIAG0(NSHAPE)
3938 INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT)
3939 INTEGER RSRC0(NSRC), CSRC0(NSRC), CONTEXT0(NGRID)
3940 INTEGER P0(NGRID), Q0(NGRID), TFAIL(*)
3941 INTEGER MEM(MEMLEN)
3942* ..
3943*
3944* Purpose
3945* =======
3946* ITESTBSBR: Test integer broadcast
3947*
3948* Arguments
3949* =========
3950* OUTNUM (input) INTEGER
3951* The device number to write output to.
3952*
3953* VERB (input) INTEGER
3954* The level of verbosity (how much printing to do).
3955*
3956* NSCOPE (input) INTEGER
3957* The number of scopes to be tested.
3958*
3959* SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE)
3960* Values of the scopes to be tested.
3961*
3962* NTOP (input) INTEGER
3963* The number of topologies to be tested.
3964*
3965* TOP0 (input) CHARACTER*1 array of dimension (NTOP)
3966* Values of the topologies to be tested.
3967*
3968* NSHAPE (input) INTEGER
3969* The number of matrix shapes to be tested.
3970*
3971* UPLO0 (input) CHARACTER*1 array of dimension (NSHAPE)
3972* Values of UPLO to be tested.
3973*
3974* DIAG0 (input) CHARACTER*1 array of dimension (NSHAPE)
3975* Values of DIAG to be tested.
3976*
3977* NMAT (input) INTEGER
3978* The number of matrices to be tested.
3979*
3980* M0 (input) INTEGER array of dimension (NMAT)
3981* Values of M to be tested.
3982*
3983* M0 (input) INTEGER array of dimension (NMAT)
3984* Values of M to be tested.
3985*
3986* N0 (input) INTEGER array of dimension (NMAT)
3987* Values of N to be tested.
3988*
3989* LDAS0 (input) INTEGER array of dimension (NMAT)
3990* Values of LDAS (leading dimension of A on source process)
3991* to be tested.
3992*
3993* LDAD0 (input) INTEGER array of dimension (NMAT)
3994* Values of LDAD (leading dimension of A on destination
3995* process) to be tested.
3996* NSRC (input) INTEGER
3997* The number of sources to be tested.
3998*
3999* RSRC0 (input) INTEGER array of dimension (NDEST)
4000* Values of RSRC (row coordinate of source) to be tested.
4001*
4002* CSRC0 (input) INTEGER array of dimension (NDEST)
4003* Values of CSRC (column coordinate of source) to be tested.
4004*
4005* NGRID (input) INTEGER
4006* The number of process grids to be tested.
4007*
4008* CONTEXT0 (input) INTEGER array of dimension (NGRID)
4009* The BLACS context handles corresponding to the grids.
4010*
4011* P0 (input) INTEGER array of dimension (NGRID)
4012* Values of P (number of process rows, NPROW).
4013*
4014* Q0 (input) INTEGER array of dimension (NGRID)
4015* Values of Q (number of process columns, NPCOL).
4016*
4017* TFAIL (workspace) INTEGER array of dimension (NTESTS)
4018* If VERB < 2, serves to indicate which tests fail. This
4019* requires workspace of NTESTS (number of tests performed).
4020*
4021* MEM (workspace) INTEGER array of dimension (MEMLEN)
4022* Used for all other workspaces, including the matrix A,
4023* and its pre and post padding.
4024*
4025* MEMLEN (input) INTEGER
4026* The length, in elements, of MEM.
4027*
4028* =====================================================================
4029*
4030* .. External Functions ..
4031 LOGICAL ALLPASS, LSAME
4032 INTEGER IBTMYPROC, IBTSIZEOF
4033 EXTERNAL ALLPASS, LSAME, IBTMYPROC, IBTSIZEOF
4034* ..
4035* .. External Subroutines ..
4036 EXTERNAL BLACS_GRIDINFO
4037 EXTERNAL ITRBS2D, IGEBS2D, ITRBR2D, IGEBR2D
4038 EXTERNAL IINITMAT, ICHKMAT, ICHKPAD, IBTCHECKIN
4039* ..
4040* .. Local Scalars ..
4041 CHARACTER*1 SCOPE, TOP, UPLO, DIAG
4042 LOGICAL TESTOK, INGRID
4043 INTEGER IAM, I, K, J, IGR, ISH, IMA, ISO, ISC, ITO
4044 INTEGER M, N, NPROW, NPCOL, MYROW, MYCOL, RSRC, CSRC
4045 INTEGER ISTART, ISTOP, IPRE, IPOST, SETWHAT
4046 INTEGER NERR, NSKIP, NFAIL, TESTNUM, CONTEXT, MAXERR, LDASRC
4047 INTEGER LDADST, ERRDPTR, APTR, ERRIPTR, ISIZE
4048 INTEGER SCHECKVAL, RCHECKVAL
4049* ..
4050* .. Executable Statements ..
4051*
4052 SCHECKVAL = -1
4053 rcheckval = -2
4054*
4055 iam = ibtmyproc()
4056 isize = ibtsizeof('I')
4057 isize = ibtsizeof('I')
4058*
4059* Verify file parameters
4060*
4061 IF( iam .EQ. 0 ) THEN
4062 WRITE(outnum, *) ' '
4063 WRITE(outnum, *) ' '
4064 WRITE(outnum, 1000 )
4065 IF( verb .GT. 0 ) THEN
4066 WRITE(outnum,*) ' '
4067 WRITE(outnum, 2000) 'NSCOPE:', nscope
4068 WRITE(outnum, 3000) ' SCOPE:', ( scope0(i), i = 1, nscope )
4069 WRITE(outnum, 2000) 'NTOP :', ntop
4070 WRITE(outnum, 3000) ' TOP :', ( top0(i), i = 1, ntop )
4071 WRITE(outnum, 2000) 'NSHAPE:', nshape
4072 WRITE(outnum, 3000) ' UPLO :', ( uplo0(i), i = 1, nshape )
4073 WRITE(outnum, 3000) ' DIAG :', ( diag0(i), i = 1, nshape )
4074 WRITE(outnum, 2000) 'NMAT :', nmat
4075 WRITE(outnum, 2000) ' M :', ( m0(i), i = 1, nmat )
4076 WRITE(outnum, 2000) ' N :', ( n0(i), i = 1, nmat )
4077 WRITE(outnum, 2000) ' LDAS :', ( ldas0(i), i = 1, nmat )
4078 WRITE(outnum, 2000) ' LDAD :', ( ldad0(i), i = 1, nmat )
4079 WRITE(outnum, 2000) 'NSRC :', nsrc
4080 WRITE(outnum, 2000) ' RSRC :',( rsrc0(i), i = 1, nsrc )
4081 WRITE(outnum, 2000) ' CSRC :',( csrc0(i), i = 1, nsrc )
4082 WRITE(outnum, 2000) 'NGRIDS:', ngrid
4083 WRITE(outnum, 2000) ' P :', ( p0(i), i = 1, ngrid )
4084 WRITE(outnum, 2000) ' Q :', ( q0(i), i = 1, ngrid )
4085 WRITE(outnum, 2000) 'VERB :', verb
4086 WRITE(outnum,*) ' '
4087 END IF
4088 IF( verb .GT. 1 ) THEN
4089 WRITE(outnum,5000)
4090 WRITE(outnum,6000)
4091 END IF
4092 END IF
4093*
4094* Find biggest matrix, so we know where to stick error info
4095*
4096 i = 0
4097 DO 10 ima = 1, nmat
4098 k = n0(ima) * max0( ldas0(ima), ldad0(ima) ) + 4 * m0(ima)
4099 IF( k .GT. i ) i = k
4100 10 CONTINUE
4101 maxerr = ( isize * (memlen-i) ) / ( isize*2 + isize*6 )
4102 IF( maxerr .LT. 1 ) THEN
4103 WRITE(outnum,*) 'ERROR: Not enough memory to run BSBR tests.'
4104 CALL blacs_abort(-1, 1)
4105 END IF
4106 errdptr = i + 1
4107 erriptr = errdptr + maxerr
4108 nerr = 0
4109 testnum = 0
4110 nfail = 0
4111 nskip = 0
4112*
4113* Loop over grids of matrix
4114*
4115 DO 110 igr = 1, ngrid
4116*
4117 context = context0(igr)
4118 CALL blacs_gridinfo( context, nprow, npcol, myrow, mycol )
4119*
4120 ingrid = ( nprow .GT. 0 )
4121*
4122 DO 100 isc = 1, nscope
4123 scope = scope0(isc)
4124 DO 90 ito = 1, ntop
4125 top = top0(ito)
4126*
4127* If testing multipath ('M') or general tree ('T'),
4128* need to loop over calls to BLACS_SET
4129*
4130 IF( lsame(top, 'M') ) THEN
4131 setwhat = 11
4132 IF( scope .EQ. 'R' ) THEN
4133 istart = -(npcol - 1)
4134 istop = -istart
4135 ELSE IF (scope .EQ. 'C') THEN
4136 istart = -(nprow - 1)
4137 istop = -istart
4138 ELSE
4139 istart = -(nprow*npcol - 1)
4140 istop = -istart
4141 ENDIF
4142 ELSE IF( lsame(top, 'T') ) THEN
4143 setwhat = 12
4144 istart = 1
4145 IF( scope .EQ. 'R' ) THEN
4146 istop = npcol - 1
4147 ELSE IF (scope .EQ. 'C') THEN
4148 istop = nprow - 1
4149 ELSE
4150 istop = nprow*npcol - 1
4151 ENDIF
4152 ELSE
4153 setwhat = 0
4154 istart = 1
4155 istop = 1
4156 ENDIF
4157 DO 80 ish = 1, nshape
4158 uplo = uplo0(ish)
4159 diag = diag0(ish)
4160*
4161 DO 70 ima = 1, nmat
4162 m = m0(ima)
4163 n = n0(ima)
4164 ldasrc = ldas0(ima)
4165 ldadst = ldad0(ima)
4166*
4167 DO 60 iso = 1, nsrc
4168 testnum = testnum + 1
4169 rsrc = rsrc0(iso)
4170 csrc = csrc0(iso)
4171 IF( rsrc.GE.p0(igr) .OR. csrc.GE.q0(igr) ) THEN
4172 nskip = nskip + 1
4173 GOTO 60
4174 END IF
4175 IF( verb .GT. 1 ) THEN
4176 IF( iam .EQ. 0 ) THEN
4177 WRITE(outnum, 7000)
4178 $ testnum, 'RUNNING',scope, top, uplo, diag,
4179 $ m, n, ldasrc, ldadst, rsrc, csrc,
4180 $ nprow, npcol
4181 END IF
4182 END IF
4183*
4184 testok = .true.
4185 ipre = 2 * m
4186 ipost = ipre
4187 aptr = ipre + 1
4188*
4189* If I am in scope
4190*
4191 IF( (myrow.EQ.rsrc .AND. scope.EQ.'R') .OR.
4192 $ (mycol.EQ.csrc .AND. scope.EQ.'C') .OR.
4193 $ (scope .EQ. 'A') ) THEN
4194*
4195* source process generates matrix and sends it
4196*
4197 IF( myrow.EQ.rsrc .AND. mycol.EQ.csrc ) THEN
4198 CALL iinitmat(uplo, diag, m, n, mem,
4199 $ ldasrc, ipre, ipost,
4200 $ scheckval, testnum,
4201 $ myrow, mycol )
4202*
4203 DO 20 j = istart, istop
4204 IF( j.EQ.0 ) GOTO 20
4205 IF( setwhat.NE.0 )
4206 $ CALL blacs_set(context, setwhat, j)
4207 IF( uplo.EQ.'U' .OR. uplo.EQ.'L' ) THEN
4208 CALL itrbs2d(context, scope, top,
4209 $ uplo, diag, m, n,
4210 $ mem(aptr), ldasrc )
4211 ELSE
4212 CALL igebs2d(context, scope, top,
4213 $ m, n, mem(aptr),
4214 $ ldasrc )
4215 END IF
4216 20 CONTINUE
4217*
4218* Destination processes
4219*
4220 ELSE IF( ingrid ) THEN
4221 DO 40 j = istart, istop
4222 IF( j.EQ.0 ) GOTO 40
4223 IF( setwhat.NE.0 )
4224 $ CALL blacs_set(context, setwhat, j)
4225*
4226* Pad entire matrix area
4227*
4228 DO 30 k = 1, ipre+ipost+ldadst*n
4229 mem(k) = rcheckval
4230 30 CONTINUE
4231*
4232* Receive matrix
4233*
4234 IF( uplo.EQ.'U' .OR. uplo.EQ.'L' ) THEN
4235 CALL itrbr2d(context, scope, top,
4236 $ uplo, diag, m, n,
4237 $ mem(aptr), ldadst,
4238 $ rsrc, csrc)
4239 ELSE
4240 CALL igebr2d(context, scope, top,
4241 $ m, n, mem(aptr),
4242 $ ldadst, rsrc, csrc)
4243 END IF
4244*
4245* Check for errors in matrix or padding
4246*
4247 i = nerr
4248 CALL ichkmat(uplo, diag, m, n,
4249 $ mem(aptr), ldadst, rsrc, csrc,
4250 $ myrow, mycol, testnum, maxerr,
4251 $ nerr, mem(erriptr),
4252 $ mem(errdptr))
4253*
4254 CALL ichkpad(uplo, diag, m, n, mem,
4255 $ ldadst, rsrc, csrc, myrow,
4256 $ mycol, ipre, ipost, rcheckval,
4257 $ testnum, maxerr, nerr,
4258 $ mem(erriptr), mem(errdptr))
4259 40 CONTINUE
4260 testok = ( i .EQ. nerr )
4261 END IF
4262 END IF
4263*
4264 IF( verb .GT. 1 ) THEN
4265 i = nerr
4266 CALL ibtcheckin(0, outnum, maxerr, nerr,
4267 $ mem(erriptr), mem(errdptr),
4268 $ tfail)
4269 IF( iam .EQ. 0 ) THEN
4270 testok = ( testok .AND. (i.EQ.nerr) )
4271 IF( testok ) THEN
4272 WRITE(outnum,7000)testnum,'PASSED ',
4273 $ scope, top, uplo, diag, m, n,
4274 $ ldasrc, ldadst, rsrc, csrc,
4275 $ nprow, npcol
4276 ELSE
4277 nfail = nfail + 1
4278 WRITE(outnum,7000)testnum,'FAILED ',
4279 $ scope, top, uplo, diag, m, n,
4280 $ ldasrc, ldadst, rsrc, csrc,
4281 $ nprow, npcol
4282 END IF
4283 END IF
4284*
4285* Once we've printed out errors, can re-use buf space
4286*
4287 nerr = 0
4288 END IF
4289 60 CONTINUE
4290 70 CONTINUE
4291 80 CONTINUE
4292 90 CONTINUE
4293 100 CONTINUE
4294 110 CONTINUE
4295*
4296 IF( verb .LT. 2 ) THEN
4297 nfail = testnum
4298 CALL ibtcheckin( nfail, outnum, maxerr, nerr, mem(erriptr),
4299 $ mem(errdptr), tfail )
4300 END IF
4301 IF( iam .EQ. 0 ) THEN
4302 IF( verb .GT. 1 ) WRITE(outnum,*) ' '
4303 IF( nfail+nskip .EQ. 0 ) THEN
4304 WRITE(outnum, 8000 ) testnum
4305 ELSE
4306 WRITE(outnum, 9000 ) testnum, testnum-nskip-nfail,
4307 $ nskip, nfail
4308 END IF
4309 END IF
4310*
4311* Log whether their were any failures
4312*
4313 testok = allpass( (nfail.EQ.0) )
4314*
4315 1000 FORMAT('INTEGER BSBR TESTS: BEGIN.' )
4316 2000 FORMAT(1x,a7,3x,10i6)
4317 3000 FORMAT(1x,a7,3x,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,
4318 $ 5x,a1,5x,a1)
4319 5000 FORMAT(' TEST# STATUS SCOPE TOP UPLO DIAG M N LDAS ',
4320 $ ' LDAD RSRC CSRC P Q')
4321 6000 FORMAT(' ----- ------- ----- --- ---- ---- ----- ----- ----- ',
4322 $ '----- ---- ---- ---- ----')
4323 7000 FORMAT(i6,1x,a7,5x,a1,3x,a1,2(4x,a1), 4i6, 4i5)
4324 8000 FORMAT('INTEGER BSBR TESTS: PASSED ALL',
4325 $ i5, ' TESTS.')
4326 9000 FORMAT('INTEGER BSBR TESTS:',i5,' TESTS;',i5,' PASSED,',
4327 $ i5,' SKIPPED,',i5,' FAILED.')
4328*
4329 RETURN
4330*
4331* End of IBSBRTEST.
4332*
4333 END
4334*
4335*
4336 SUBROUTINE sbsbrtest( OUTNUM, VERB, NSCOPE, SCOPE0, NTOP, TOP0,
4337 $ NSHAPE, UPLO0, DIAG0, NMAT, M0, N0, LDAS0,
4338 $ LDAD0, NSRC, RSRC0, CSRC0, NGRID, CONTEXT0,
4339 $ P0, Q0, TFAIL, MEM, MEMLEN )
4340*
4341* -- BLACS tester (version 1.0) --
4342* University of Tennessee
4343* December 15, 1994
4344*
4345*
4346* .. Scalar Arguments ..
4347 INTEGER OUTNUM, VERB, NSCOPE, NTOP, NSHAPE, NMAT, NSRC, NGRID
4348 INTEGER MEMLEN
4349* ..
4350* .. Array Arguments ..
4351 CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP)
4352 CHARACTER*1 UPLO0(NSHAPE), DIAG0(NSHAPE)
4353 INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT)
4354 INTEGER RSRC0(NSRC), CSRC0(NSRC), CONTEXT0(NGRID)
4355 INTEGER P0(NGRID), Q0(NGRID), TFAIL(*)
4356 REAL MEM(MEMLEN)
4357* ..
4358*
4359* Purpose
4360* =======
4361* STESTBSBR: Test real broadcast
4362*
4363* Arguments
4364* =========
4365* OUTNUM (input) INTEGER
4366* The device number to write output to.
4367*
4368* VERB (input) INTEGER
4369* The level of verbosity (how much printing to do).
4370*
4371* NSCOPE (input) INTEGER
4372* The number of scopes to be tested.
4373*
4374* SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE)
4375* Values of the scopes to be tested.
4376*
4377* NTOP (input) INTEGER
4378* The number of topologies to be tested.
4379*
4380* TOP0 (input) CHARACTER*1 array of dimension (NTOP)
4381* Values of the topologies to be tested.
4382*
4383* NSHAPE (input) INTEGER
4384* The number of matrix shapes to be tested.
4385*
4386* UPLO0 (input) CHARACTER*1 array of dimension (NSHAPE)
4387* Values of UPLO to be tested.
4388*
4389* DIAG0 (input) CHARACTER*1 array of dimension (NSHAPE)
4390* Values of DIAG to be tested.
4391*
4392* NMAT (input) INTEGER
4393* The number of matrices to be tested.
4394*
4395* M0 (input) INTEGER array of dimension (NMAT)
4396* Values of M to be tested.
4397*
4398* M0 (input) INTEGER array of dimension (NMAT)
4399* Values of M to be tested.
4400*
4401* N0 (input) INTEGER array of dimension (NMAT)
4402* Values of N to be tested.
4403*
4404* LDAS0 (input) INTEGER array of dimension (NMAT)
4405* Values of LDAS (leading dimension of A on source process)
4406* to be tested.
4407*
4408* LDAD0 (input) INTEGER array of dimension (NMAT)
4409* Values of LDAD (leading dimension of A on destination
4410* process) to be tested.
4411* NSRC (input) INTEGER
4412* The number of sources to be tested.
4413*
4414* RSRC0 (input) INTEGER array of dimension (NDEST)
4415* Values of RSRC (row coordinate of source) to be tested.
4416*
4417* CSRC0 (input) INTEGER array of dimension (NDEST)
4418* Values of CSRC (column coordinate of source) to be tested.
4419*
4420* NGRID (input) INTEGER
4421* The number of process grids to be tested.
4422*
4423* CONTEXT0 (input) INTEGER array of dimension (NGRID)
4424* The BLACS context handles corresponding to the grids.
4425*
4426* P0 (input) INTEGER array of dimension (NGRID)
4427* Values of P (number of process rows, NPROW).
4428*
4429* Q0 (input) INTEGER array of dimension (NGRID)
4430* Values of Q (number of process columns, NPCOL).
4431*
4432* TFAIL (workspace) INTEGER array of dimension (NTESTS)
4433* If VERB < 2, serves to indicate which tests fail. This
4434* requires workspace of NTESTS (number of tests performed).
4435*
4436* MEM (workspace) REAL array of dimension (MEMLEN)
4437* Used for all other workspaces, including the matrix A,
4438* and its pre and post padding.
4439*
4440* MEMLEN (input) INTEGER
4441* The length, in elements, of MEM.
4442*
4443* =====================================================================
4444*
4445* .. External Functions ..
4446 LOGICAL ALLPASS, LSAME
4447 INTEGER IBTMYPROC, IBTSIZEOF
4448 EXTERNAL ALLPASS, LSAME, IBTMYPROC, IBTSIZEOF
4449* ..
4450* .. External Subroutines ..
4451 EXTERNAL BLACS_GRIDINFO
4452 EXTERNAL STRBS2D, SGEBS2D, STRBR2D, SGEBR2D
4453 EXTERNAL SINITMAT, SCHKMAT, SCHKPAD, SBTCHECKIN
4454* ..
4455* .. Local Scalars ..
4456 CHARACTER*1 SCOPE, TOP, UPLO, DIAG
4457 LOGICAL TESTOK, INGRID
4458 INTEGER IAM, I, K, J, IGR, ISH, IMA, ISO, ISC, ITO
4459 INTEGER M, N, NPROW, NPCOL, MYROW, MYCOL, RSRC, CSRC
4460 INTEGER ISTART, ISTOP, IPRE, IPOST, SETWHAT
4461 INTEGER NERR, NSKIP, NFAIL, TESTNUM, CONTEXT, MAXERR, LDASRC
4462 INTEGER LDADST, ERRDPTR, APTR, ERRIPTR, ISIZE, SSIZE
4463 REAL SCHECKVAL, RCHECKVAL
4464* ..
4465* .. Executable Statements ..
4466*
4467 SCHECKVAL = -0.01e0
4468 rcheckval = -0.02e0
4469*
4470 iam = ibtmyproc()
4471 isize = ibtsizeof('I')
4472 ssize = ibtsizeof('S')
4473*
4474* Verify file parameters
4475*
4476 IF( iam .EQ. 0 ) THEN
4477 WRITE(outnum, *) ' '
4478 WRITE(outnum, *) ' '
4479 WRITE(outnum, 1000 )
4480 IF( verb .GT. 0 ) THEN
4481 WRITE(outnum,*) ' '
4482 WRITE(outnum, 2000) 'NSCOPE:', nscope
4483 WRITE(outnum, 3000) ' SCOPE:', ( scope0(i), i = 1, nscope )
4484 WRITE(outnum, 2000) 'NTOP :', ntop
4485 WRITE(outnum, 3000) ' TOP :', ( top0(i), i = 1, ntop )
4486 WRITE(outnum, 2000) 'NSHAPE:', nshape
4487 WRITE(outnum, 3000) ' UPLO :', ( uplo0(i), i = 1, nshape )
4488 WRITE(outnum, 3000) ' DIAG :', ( diag0(i), i = 1, nshape )
4489 WRITE(outnum, 2000) 'NMAT :', nmat
4490 WRITE(outnum, 2000) ' M :', ( m0(i), i = 1, nmat )
4491 WRITE(outnum, 2000) ' N :', ( n0(i), i = 1, nmat )
4492 WRITE(outnum, 2000) ' LDAS :', ( ldas0(i), i = 1, nmat )
4493 WRITE(outnum, 2000) ' LDAD :', ( ldad0(i), i = 1, nmat )
4494 WRITE(outnum, 2000) 'NSRC :', nsrc
4495 WRITE(outnum, 2000) ' RSRC :',( rsrc0(i), i = 1, nsrc )
4496 WRITE(outnum, 2000) ' CSRC :',( csrc0(i), i = 1, nsrc )
4497 WRITE(outnum, 2000) 'NGRIDS:', ngrid
4498 WRITE(outnum, 2000) ' P :', ( p0(i), i = 1, ngrid )
4499 WRITE(outnum, 2000) ' Q :', ( q0(i), i = 1, ngrid )
4500 WRITE(outnum, 2000) 'VERB :', verb
4501 WRITE(outnum,*) ' '
4502 END IF
4503 IF( verb .GT. 1 ) THEN
4504 WRITE(outnum,5000)
4505 WRITE(outnum,6000)
4506 END IF
4507 END IF
4508*
4509* Find biggest matrix, so we know where to stick error info
4510*
4511 i = 0
4512 DO 10 ima = 1, nmat
4513 k = n0(ima) * max0( ldas0(ima), ldad0(ima) ) + 4 * m0(ima)
4514 IF( k .GT. i ) i = k
4515 10 CONTINUE
4516 maxerr = ( ssize * (memlen-i) ) / ( ssize*2 + isize*6 )
4517 IF( maxerr .LT. 1 ) THEN
4518 WRITE(outnum,*) 'ERROR: Not enough memory to run BSBR tests.'
4519 CALL blacs_abort(-1, 1)
4520 END IF
4521 errdptr = i + 1
4522 erriptr = errdptr + maxerr
4523 nerr = 0
4524 testnum = 0
4525 nfail = 0
4526 nskip = 0
4527*
4528* Loop over grids of matrix
4529*
4530 DO 110 igr = 1, ngrid
4531*
4532 context = context0(igr)
4533 CALL blacs_gridinfo( context, nprow, npcol, myrow, mycol )
4534*
4535 ingrid = ( nprow .GT. 0 )
4536*
4537 DO 100 isc = 1, nscope
4538 scope = scope0(isc)
4539 DO 90 ito = 1, ntop
4540 top = top0(ito)
4541*
4542* If testing multipath ('M') or general tree ('T'),
4543* need to loop over calls to BLACS_SET
4544*
4545 IF( lsame(top, 'M') ) THEN
4546 setwhat = 11
4547 IF( scope .EQ. 'R' ) THEN
4548 istart = -(npcol - 1)
4549 istop = -istart
4550 ELSE IF (scope .EQ. 'C') THEN
4551 istart = -(nprow - 1)
4552 istop = -istart
4553 ELSE
4554 istart = -(nprow*npcol - 1)
4555 istop = -istart
4556 ENDIF
4557 ELSE IF( lsame(top, 'T') ) THEN
4558 setwhat = 12
4559 istart = 1
4560 IF( scope .EQ. 'R' ) THEN
4561 istop = npcol - 1
4562 ELSE IF (scope .EQ. 'C') THEN
4563 istop = nprow - 1
4564 ELSE
4565 istop = nprow*npcol - 1
4566 ENDIF
4567 ELSE
4568 setwhat = 0
4569 istart = 1
4570 istop = 1
4571 ENDIF
4572 DO 80 ish = 1, nshape
4573 uplo = uplo0(ish)
4574 diag = diag0(ish)
4575*
4576 DO 70 ima = 1, nmat
4577 m = m0(ima)
4578 n = n0(ima)
4579 ldasrc = ldas0(ima)
4580 ldadst = ldad0(ima)
4581*
4582 DO 60 iso = 1, nsrc
4583 testnum = testnum + 1
4584 rsrc = rsrc0(iso)
4585 csrc = csrc0(iso)
4586 IF( rsrc.GE.p0(igr) .OR. csrc.GE.q0(igr) ) THEN
4587 nskip = nskip + 1
4588 GOTO 60
4589 END IF
4590 IF( verb .GT. 1 ) THEN
4591 IF( iam .EQ. 0 ) THEN
4592 WRITE(outnum, 7000)
4593 $ testnum, 'RUNNING',scope, top, uplo, diag,
4594 $ m, n, ldasrc, ldadst, rsrc, csrc,
4595 $ nprow, npcol
4596 END IF
4597 END IF
4598*
4599 testok = .true.
4600 ipre = 2 * m
4601 ipost = ipre
4602 aptr = ipre + 1
4603*
4604* If I am in scope
4605*
4606 IF( (myrow.EQ.rsrc .AND. scope.EQ.'R') .OR.
4607 $ (mycol.EQ.csrc .AND. scope.EQ.'C') .OR.
4608 $ (scope .EQ. 'A') ) THEN
4609*
4610* source process generates matrix and sends it
4611*
4612 IF( myrow.EQ.rsrc .AND. mycol.EQ.csrc ) THEN
4613 CALL sinitmat(uplo, diag, m, n, mem,
4614 $ ldasrc, ipre, ipost,
4615 $ scheckval, testnum,
4616 $ myrow, mycol )
4617*
4618 DO 20 j = istart, istop
4619 IF( j.EQ.0 ) GOTO 20
4620 IF( setwhat.NE.0 )
4621 $ CALL blacs_set(context, setwhat, j)
4622 IF( uplo.EQ.'U' .OR. uplo.EQ.'L' ) THEN
4623 CALL strbs2d(context, scope, top,
4624 $ uplo, diag, m, n,
4625 $ mem(aptr), ldasrc )
4626 ELSE
4627 CALL sgebs2d(context, scope, top,
4628 $ m, n, mem(aptr),
4629 $ ldasrc )
4630 END IF
4631 20 CONTINUE
4632*
4633* Destination processes
4634*
4635 ELSE IF( ingrid ) THEN
4636 DO 40 j = istart, istop
4637 IF( j.EQ.0 ) GOTO 40
4638 IF( setwhat.NE.0 )
4639 $ CALL blacs_set(context, setwhat, j)
4640*
4641* Pad entire matrix area
4642*
4643 DO 30 k = 1, ipre+ipost+ldadst*n
4644 mem(k) = rcheckval
4645 30 CONTINUE
4646*
4647* Receive matrix
4648*
4649 IF( uplo.EQ.'U' .OR. uplo.EQ.'L' ) THEN
4650 CALL strbr2d(context, scope, top,
4651 $ uplo, diag, m, n,
4652 $ mem(aptr), ldadst,
4653 $ rsrc, csrc)
4654 ELSE
4655 CALL sgebr2d(context, scope, top,
4656 $ m, n, mem(aptr),
4657 $ ldadst, rsrc, csrc)
4658 END IF
4659*
4660* Check for errors in matrix or padding
4661*
4662 i = nerr
4663 CALL schkmat(uplo, diag, m, n,
4664 $ mem(aptr), ldadst, rsrc, csrc,
4665 $ myrow, mycol, testnum, maxerr,
4666 $ nerr, mem(erriptr),
4667 $ mem(errdptr))
4668*
4669 CALL schkpad(uplo, diag, m, n, mem,
4670 $ ldadst, rsrc, csrc, myrow,
4671 $ mycol, ipre, ipost, rcheckval,
4672 $ testnum, maxerr, nerr,
4673 $ mem(erriptr), mem(errdptr))
4674 40 CONTINUE
4675 testok = ( i .EQ. nerr )
4676 END IF
4677 END IF
4678*
4679 IF( verb .GT. 1 ) THEN
4680 i = nerr
4681 CALL sbtcheckin(0, outnum, maxerr, nerr,
4682 $ mem(erriptr), mem(errdptr),
4683 $ tfail)
4684 IF( iam .EQ. 0 ) THEN
4685 testok = ( testok .AND. (i.EQ.nerr) )
4686 IF( testok ) THEN
4687 WRITE(outnum,7000)testnum,'PASSED ',
4688 $ scope, top, uplo, diag, m, n,
4689 $ ldasrc, ldadst, rsrc, csrc,
4690 $ nprow, npcol
4691 ELSE
4692 nfail = nfail + 1
4693 WRITE(outnum,7000)testnum,'FAILED ',
4694 $ scope, top, uplo, diag, m, n,
4695 $ ldasrc, ldadst, rsrc, csrc,
4696 $ nprow, npcol
4697 END IF
4698 END IF
4699*
4700* Once we've printed out errors, can re-use buf space
4701*
4702 nerr = 0
4703 END IF
4704 60 CONTINUE
4705 70 CONTINUE
4706 80 CONTINUE
4707 90 CONTINUE
4708 100 CONTINUE
4709 110 CONTINUE
4710*
4711 IF( verb .LT. 2 ) THEN
4712 nfail = testnum
4713 CALL sbtcheckin( nfail, outnum, maxerr, nerr, mem(erriptr),
4714 $ mem(errdptr), tfail )
4715 END IF
4716 IF( iam .EQ. 0 ) THEN
4717 IF( verb .GT. 1 ) WRITE(outnum,*) ' '
4718 IF( nfail+nskip .EQ. 0 ) THEN
4719 WRITE(outnum, 8000 ) testnum
4720 ELSE
4721 WRITE(outnum, 9000 ) testnum, testnum-nskip-nfail,
4722 $ nskip, nfail
4723 END IF
4724 END IF
4725*
4726* Log whether their were any failures
4727*
4728 testok = allpass( (nfail.EQ.0) )
4729*
4730 1000 FORMAT('REAL BSBR TESTS: BEGIN.' )
4731 2000 FORMAT(1x,a7,3x,10i6)
4732 3000 FORMAT(1x,a7,3x,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,
4733 $ 5x,a1,5x,a1)
4734 5000 FORMAT(' TEST# STATUS SCOPE TOP UPLO DIAG M N LDAS ',
4735 $ ' LDAD RSRC CSRC P Q')
4736 6000 FORMAT(' ----- ------- ----- --- ---- ---- ----- ----- ----- ',
4737 $ '----- ---- ---- ---- ----')
4738 7000 FORMAT(i6,1x,a7,5x,a1,3x,a1,2(4x,a1), 4i6, 4i5)
4739 8000 FORMAT('REAL BSBR TESTS: PASSED ALL',
4740 $ i5, ' TESTS.')
4741 9000 FORMAT('REAL BSBR TESTS:',i5,' TESTS;',i5,' PASSED,',
4742 $ i5,' SKIPPED,',i5,' FAILED.')
4743*
4744 RETURN
4745*
4746* End of SBSBRTEST.
4747*
4748 END
4749*
4750*
4751 SUBROUTINE dbsbrtest( OUTNUM, VERB, NSCOPE, SCOPE0, NTOP, TOP0,
4752 $ NSHAPE, UPLO0, DIAG0, NMAT, M0, N0, LDAS0,
4753 $ LDAD0, NSRC, RSRC0, CSRC0, NGRID, CONTEXT0,
4754 $ P0, Q0, TFAIL, MEM, MEMLEN )
4755*
4756* -- BLACS tester (version 1.0) --
4757* University of Tennessee
4758* December 15, 1994
4759*
4760*
4761* .. Scalar Arguments ..
4762 INTEGER OUTNUM, VERB, NSCOPE, NTOP, NSHAPE, NMAT, NSRC, NGRID
4763 INTEGER MEMLEN
4764* ..
4765* .. Array Arguments ..
4766 CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP)
4767 CHARACTER*1 UPLO0(NSHAPE), DIAG0(NSHAPE)
4768 INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT)
4769 INTEGER RSRC0(NSRC), CSRC0(NSRC), CONTEXT0(NGRID)
4770 INTEGER P0(NGRID), Q0(NGRID), TFAIL(*)
4771 DOUBLE PRECISION MEM(MEMLEN)
4772* ..
4773*
4774* Purpose
4775* =======
4776* DTESTBSBR: Test double precision broadcast
4777*
4778* Arguments
4779* =========
4780* OUTNUM (input) INTEGER
4781* The device number to write output to.
4782*
4783* VERB (input) INTEGER
4784* The level of verbosity (how much printing to do).
4785*
4786* NSCOPE (input) INTEGER
4787* The number of scopes to be tested.
4788*
4789* SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE)
4790* Values of the scopes to be tested.
4791*
4792* NTOP (input) INTEGER
4793* The number of topologies to be tested.
4794*
4795* TOP0 (input) CHARACTER*1 array of dimension (NTOP)
4796* Values of the topologies to be tested.
4797*
4798* NSHAPE (input) INTEGER
4799* The number of matrix shapes to be tested.
4800*
4801* UPLO0 (input) CHARACTER*1 array of dimension (NSHAPE)
4802* Values of UPLO to be tested.
4803*
4804* DIAG0 (input) CHARACTER*1 array of dimension (NSHAPE)
4805* Values of DIAG to be tested.
4806*
4807* NMAT (input) INTEGER
4808* The number of matrices to be tested.
4809*
4810* M0 (input) INTEGER array of dimension (NMAT)
4811* Values of M to be tested.
4812*
4813* M0 (input) INTEGER array of dimension (NMAT)
4814* Values of M to be tested.
4815*
4816* N0 (input) INTEGER array of dimension (NMAT)
4817* Values of N to be tested.
4818*
4819* LDAS0 (input) INTEGER array of dimension (NMAT)
4820* Values of LDAS (leading dimension of A on source process)
4821* to be tested.
4822*
4823* LDAD0 (input) INTEGER array of dimension (NMAT)
4824* Values of LDAD (leading dimension of A on destination
4825* process) to be tested.
4826* NSRC (input) INTEGER
4827* The number of sources to be tested.
4828*
4829* RSRC0 (input) INTEGER array of dimension (NDEST)
4830* Values of RSRC (row coordinate of source) to be tested.
4831*
4832* CSRC0 (input) INTEGER array of dimension (NDEST)
4833* Values of CSRC (column coordinate of source) to be tested.
4834*
4835* NGRID (input) INTEGER
4836* The number of process grids to be tested.
4837*
4838* CONTEXT0 (input) INTEGER array of dimension (NGRID)
4839* The BLACS context handles corresponding to the grids.
4840*
4841* P0 (input) INTEGER array of dimension (NGRID)
4842* Values of P (number of process rows, NPROW).
4843*
4844* Q0 (input) INTEGER array of dimension (NGRID)
4845* Values of Q (number of process columns, NPCOL).
4846*
4847* TFAIL (workspace) INTEGER array of dimension (NTESTS)
4848* If VERB < 2, serves to indicate which tests fail. This
4849* requires workspace of NTESTS (number of tests performed).
4850*
4851* MEM (workspace) DOUBLE PRECISION array of dimension (MEMLEN)
4852* Used for all other workspaces, including the matrix A,
4853* and its pre and post padding.
4854*
4855* MEMLEN (input) INTEGER
4856* The length, in elements, of MEM.
4857*
4858* =====================================================================
4859*
4860* .. External Functions ..
4861 LOGICAL ALLPASS, LSAME
4862 INTEGER IBTMYPROC, IBTSIZEOF
4863 EXTERNAL ALLPASS, LSAME, IBTMYPROC, IBTSIZEOF
4864* ..
4865* .. External Subroutines ..
4866 EXTERNAL BLACS_GRIDINFO
4867 EXTERNAL DTRBS2D, DGEBS2D, DTRBR2D, DGEBR2D
4868 EXTERNAL DINITMAT, DCHKMAT, DCHKPAD, DBTCHECKIN
4869* ..
4870* .. Local Scalars ..
4871 CHARACTER*1 SCOPE, TOP, UPLO, DIAG
4872 LOGICAL TESTOK, INGRID
4873 INTEGER IAM, I, K, J, IGR, ISH, IMA, ISO, ISC, ITO
4874 INTEGER M, N, NPROW, NPCOL, MYROW, MYCOL, RSRC, CSRC
4875 INTEGER ISTART, ISTOP, IPRE, IPOST, SETWHAT
4876 INTEGER NERR, NSKIP, NFAIL, TESTNUM, CONTEXT, MAXERR, LDASRC
4877 INTEGER LDADST, ERRDPTR, APTR, ERRIPTR, ISIZE, DSIZE
4878 DOUBLE PRECISION SCHECKVAL, RCHECKVAL
4879* ..
4880* .. Executable Statements ..
4881*
4882 SCHECKVAL = -0.01d0
4883 rcheckval = -0.02d0
4884*
4885 iam = ibtmyproc()
4886 isize = ibtsizeof('I')
4887 dsize = ibtsizeof('D')
4888*
4889* Verify file parameters
4890*
4891 IF( iam .EQ. 0 ) THEN
4892 WRITE(outnum, *) ' '
4893 WRITE(outnum, *) ' '
4894 WRITE(outnum, 1000 )
4895 IF( verb .GT. 0 ) THEN
4896 WRITE(outnum,*) ' '
4897 WRITE(outnum, 2000) 'NSCOPE:', nscope
4898 WRITE(outnum, 3000) ' SCOPE:', ( scope0(i), i = 1, nscope )
4899 WRITE(outnum, 2000) 'NTOP :', ntop
4900 WRITE(outnum, 3000) ' TOP :', ( top0(i), i = 1, ntop )
4901 WRITE(outnum, 2000) 'NSHAPE:', nshape
4902 WRITE(outnum, 3000) ' UPLO :', ( uplo0(i), i = 1, nshape )
4903 WRITE(outnum, 3000) ' DIAG :', ( diag0(i), i = 1, nshape )
4904 WRITE(outnum, 2000) 'NMAT :', nmat
4905 WRITE(outnum, 2000) ' M :', ( m0(i), i = 1, nmat )
4906 WRITE(outnum, 2000) ' N :', ( n0(i), i = 1, nmat )
4907 WRITE(outnum, 2000) ' LDAS :', ( ldas0(i), i = 1, nmat )
4908 WRITE(outnum, 2000) ' LDAD :', ( ldad0(i), i = 1, nmat )
4909 WRITE(outnum, 2000) 'NSRC :', nsrc
4910 WRITE(outnum, 2000) ' RSRC :',( rsrc0(i), i = 1, nsrc )
4911 WRITE(outnum, 2000) ' CSRC :',( csrc0(i), i = 1, nsrc )
4912 WRITE(outnum, 2000) 'NGRIDS:', ngrid
4913 WRITE(outnum, 2000) ' P :', ( p0(i), i = 1, ngrid )
4914 WRITE(outnum, 2000) ' Q :', ( q0(i), i = 1, ngrid )
4915 WRITE(outnum, 2000) 'VERB :', verb
4916 WRITE(outnum,*) ' '
4917 END IF
4918 IF( verb .GT. 1 ) THEN
4919 WRITE(outnum,5000)
4920 WRITE(outnum,6000)
4921 END IF
4922 END IF
4923*
4924* Find biggest matrix, so we know where to stick error info
4925*
4926 i = 0
4927 DO 10 ima = 1, nmat
4928 k = n0(ima) * max0( ldas0(ima), ldad0(ima) ) + 4 * m0(ima)
4929 IF( k .GT. i ) i = k
4930 10 CONTINUE
4931 maxerr = ( dsize * (memlen-i) ) / ( dsize*2 + isize*6 )
4932 IF( maxerr .LT. 1 ) THEN
4933 WRITE(outnum,*) 'ERROR: Not enough memory to run BSBR tests.'
4934 CALL blacs_abort(-1, 1)
4935 END IF
4936 errdptr = i + 1
4937 erriptr = errdptr + maxerr
4938 nerr = 0
4939 testnum = 0
4940 nfail = 0
4941 nskip = 0
4942*
4943* Loop over grids of matrix
4944*
4945 DO 110 igr = 1, ngrid
4946*
4947 context = context0(igr)
4948 CALL blacs_gridinfo( context, nprow, npcol, myrow, mycol )
4949*
4950 ingrid = ( nprow .GT. 0 )
4951*
4952 DO 100 isc = 1, nscope
4953 scope = scope0(isc)
4954 DO 90 ito = 1, ntop
4955 top = top0(ito)
4956*
4957* If testing multipath ('M') or general tree ('T'),
4958* need to loop over calls to BLACS_SET
4959*
4960 IF( lsame(top, 'M') ) THEN
4961 setwhat = 11
4962 IF( scope .EQ. 'R' ) THEN
4963 istart = -(npcol - 1)
4964 istop = -istart
4965 ELSE IF (scope .EQ. 'C') THEN
4966 istart = -(nprow - 1)
4967 istop = -istart
4968 ELSE
4969 istart = -(nprow*npcol - 1)
4970 istop = -istart
4971 ENDIF
4972 ELSE IF( lsame(top, 'T') ) THEN
4973 setwhat = 12
4974 istart = 1
4975 IF( scope .EQ. 'R' ) THEN
4976 istop = npcol - 1
4977 ELSE IF (scope .EQ. 'C') THEN
4978 istop = nprow - 1
4979 ELSE
4980 istop = nprow*npcol - 1
4981 ENDIF
4982 ELSE
4983 setwhat = 0
4984 istart = 1
4985 istop = 1
4986 ENDIF
4987 DO 80 ish = 1, nshape
4988 uplo = uplo0(ish)
4989 diag = diag0(ish)
4990*
4991 DO 70 ima = 1, nmat
4992 m = m0(ima)
4993 n = n0(ima)
4994 ldasrc = ldas0(ima)
4995 ldadst = ldad0(ima)
4996*
4997 DO 60 iso = 1, nsrc
4998 testnum = testnum + 1
4999 rsrc = rsrc0(iso)
5000 csrc = csrc0(iso)
5001 IF( rsrc.GE.p0(igr) .OR. csrc.GE.q0(igr) ) THEN
5002 nskip = nskip + 1
5003 GOTO 60
5004 END IF
5005 IF( verb .GT. 1 ) THEN
5006 IF( iam .EQ. 0 ) THEN
5007 WRITE(outnum, 7000)
5008 $ testnum, 'RUNNING',scope, top, uplo, diag,
5009 $ m, n, ldasrc, ldadst, rsrc, csrc,
5010 $ nprow, npcol
5011 END IF
5012 END IF
5013*
5014 testok = .true.
5015 ipre = 2 * m
5016 ipost = ipre
5017 aptr = ipre + 1
5018*
5019* If I am in scope
5020*
5021 IF( (myrow.EQ.rsrc .AND. scope.EQ.'R') .OR.
5022 $ (mycol.EQ.csrc .AND. scope.EQ.'C') .OR.
5023 $ (scope .EQ. 'A') ) THEN
5024*
5025* source process generates matrix and sends it
5026*
5027 IF( myrow.EQ.rsrc .AND. mycol.EQ.csrc ) THEN
5028 CALL dinitmat(uplo, diag, m, n, mem,
5029 $ ldasrc, ipre, ipost,
5030 $ scheckval, testnum,
5031 $ myrow, mycol )
5032*
5033 DO 20 j = istart, istop
5034 IF( j.EQ.0 ) GOTO 20
5035 IF( setwhat.NE.0 )
5036 $ CALL blacs_set(context, setwhat, j)
5037 IF( uplo.EQ.'U' .OR. uplo.EQ.'L' ) THEN
5038 CALL dtrbs2d(context, scope, top,
5039 $ uplo, diag, m, n,
5040 $ mem(aptr), ldasrc )
5041 ELSE
5042 CALL dgebs2d(context, scope, top,
5043 $ m, n, mem(aptr),
5044 $ ldasrc )
5045 END IF
5046 20 CONTINUE
5047*
5048* Destination processes
5049*
5050 ELSE IF( ingrid ) THEN
5051 DO 40 j = istart, istop
5052 IF( j.EQ.0 ) GOTO 40
5053 IF( setwhat.NE.0 )
5054 $ CALL blacs_set(context, setwhat, j)
5055*
5056* Pad entire matrix area
5057*
5058 DO 30 k = 1, ipre+ipost+ldadst*n
5059 mem(k) = rcheckval
5060 30 CONTINUE
5061*
5062* Receive matrix
5063*
5064 IF( uplo.EQ.'U' .OR. uplo.EQ.'L' ) THEN
5065 CALL dtrbr2d(context, scope, top,
5066 $ uplo, diag, m, n,
5067 $ mem(aptr), ldadst,
5068 $ rsrc, csrc)
5069 ELSE
5070 CALL dgebr2d(context, scope, top,
5071 $ m, n, mem(aptr),
5072 $ ldadst, rsrc, csrc)
5073 END IF
5074*
5075* Check for errors in matrix or padding
5076*
5077 i = nerr
5078 CALL dchkmat(uplo, diag, m, n,
5079 $ mem(aptr), ldadst, rsrc, csrc,
5080 $ myrow, mycol, testnum, maxerr,
5081 $ nerr, mem(erriptr),
5082 $ mem(errdptr))
5083*
5084 CALL dchkpad(uplo, diag, m, n, mem,
5085 $ ldadst, rsrc, csrc, myrow,
5086 $ mycol, ipre, ipost, rcheckval,
5087 $ testnum, maxerr, nerr,
5088 $ mem(erriptr), mem(errdptr))
5089 40 CONTINUE
5090 testok = ( i .EQ. nerr )
5091 END IF
5092 END IF
5093*
5094 IF( verb .GT. 1 ) THEN
5095 i = nerr
5096 CALL dbtcheckin(0, outnum, maxerr, nerr,
5097 $ mem(erriptr), mem(errdptr),
5098 $ tfail)
5099 IF( iam .EQ. 0 ) THEN
5100 testok = ( testok .AND. (i.EQ.nerr) )
5101 IF( testok ) THEN
5102 WRITE(outnum,7000)testnum,'PASSED ',
5103 $ scope, top, uplo, diag, m, n,
5104 $ ldasrc, ldadst, rsrc, csrc,
5105 $ nprow, npcol
5106 ELSE
5107 nfail = nfail + 1
5108 WRITE(outnum,7000)testnum,'FAILED ',
5109 $ scope, top, uplo, diag, m, n,
5110 $ ldasrc, ldadst, rsrc, csrc,
5111 $ nprow, npcol
5112 END IF
5113 END IF
5114*
5115* Once we've printed out errors, can re-use buf space
5116*
5117 nerr = 0
5118 END IF
5119 60 CONTINUE
5120 70 CONTINUE
5121 80 CONTINUE
5122 90 CONTINUE
5123 100 CONTINUE
5124 110 CONTINUE
5125*
5126 IF( verb .LT. 2 ) THEN
5127 nfail = testnum
5128 CALL dbtcheckin( nfail, outnum, maxerr, nerr, mem(erriptr),
5129 $ mem(errdptr), tfail )
5130 END IF
5131 IF( iam .EQ. 0 ) THEN
5132 IF( verb .GT. 1 ) WRITE(outnum,*) ' '
5133 IF( nfail+nskip .EQ. 0 ) THEN
5134 WRITE(outnum, 8000 ) testnum
5135 ELSE
5136 WRITE(outnum, 9000 ) testnum, testnum-nskip-nfail,
5137 $ nskip, nfail
5138 END IF
5139 END IF
5140*
5141* Log whether their were any failures
5142*
5143 testok = allpass( (nfail.EQ.0) )
5144*
5145 1000 FORMAT('DOUBLE PRECISION BSBR TESTS: BEGIN.' )
5146 2000 FORMAT(1x,a7,3x,10i6)
5147 3000 FORMAT(1x,a7,3x,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,
5148 $ 5x,a1,5x,a1)
5149 5000 FORMAT(' TEST# STATUS SCOPE TOP UPLO DIAG M N LDAS ',
5150 $ ' LDAD RSRC CSRC P Q')
5151 6000 FORMAT(' ----- ------- ----- --- ---- ---- ----- ----- ----- ',
5152 $ '----- ---- ---- ---- ----')
5153 7000 FORMAT(i6,1x,a7,5x,a1,3x,a1,2(4x,a1), 4i6, 4i5)
5154 8000 FORMAT('DOUBLE PRECISION BSBR TESTS: PASSED ALL',
5155 $ i5, ' TESTS.')
5156 9000 FORMAT('DOUBLE PRECISION BSBR TESTS:',i5,' TESTS;',i5,' PASSED,',
5157 $ i5,' SKIPPED,',i5,' FAILED.')
5158*
5159 RETURN
5160*
5161* End of DBSBRTEST.
5162*
5163 END
5164*
5165*
5166 SUBROUTINE cbsbrtest( OUTNUM, VERB, NSCOPE, SCOPE0, NTOP, TOP0,
5167 $ NSHAPE, UPLO0, DIAG0, NMAT, M0, N0, LDAS0,
5168 $ LDAD0, NSRC, RSRC0, CSRC0, NGRID, CONTEXT0,
5169 $ P0, Q0, TFAIL, MEM, MEMLEN )
5170*
5171* -- BLACS tester (version 1.0) --
5172* University of Tennessee
5173* December 15, 1994
5174*
5175*
5176* .. Scalar Arguments ..
5177 INTEGER OUTNUM, VERB, NSCOPE, NTOP, NSHAPE, NMAT, NSRC, NGRID
5178 INTEGER MEMLEN
5179* ..
5180* .. Array Arguments ..
5181 CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP)
5182 CHARACTER*1 UPLO0(NSHAPE), DIAG0(NSHAPE)
5183 INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT)
5184 INTEGER RSRC0(NSRC), CSRC0(NSRC), CONTEXT0(NGRID)
5185 INTEGER P0(NGRID), Q0(NGRID), TFAIL(*)
5186 COMPLEX MEM(MEMLEN)
5187* ..
5188*
5189* Purpose
5190* =======
5191* CTESTBSBR: Test complex broadcast
5192*
5193* Arguments
5194* =========
5195* OUTNUM (input) INTEGER
5196* The device number to write output to.
5197*
5198* VERB (input) INTEGER
5199* The level of verbosity (how much printing to do).
5200*
5201* NSCOPE (input) INTEGER
5202* The number of scopes to be tested.
5203*
5204* SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE)
5205* Values of the scopes to be tested.
5206*
5207* NTOP (input) INTEGER
5208* The number of topologies to be tested.
5209*
5210* TOP0 (input) CHARACTER*1 array of dimension (NTOP)
5211* Values of the topologies to be tested.
5212*
5213* NSHAPE (input) INTEGER
5214* The number of matrix shapes to be tested.
5215*
5216* UPLO0 (input) CHARACTER*1 array of dimension (NSHAPE)
5217* Values of UPLO to be tested.
5218*
5219* DIAG0 (input) CHARACTER*1 array of dimension (NSHAPE)
5220* Values of DIAG to be tested.
5221*
5222* NMAT (input) INTEGER
5223* The number of matrices to be tested.
5224*
5225* M0 (input) INTEGER array of dimension (NMAT)
5226* Values of M to be tested.
5227*
5228* M0 (input) INTEGER array of dimension (NMAT)
5229* Values of M to be tested.
5230*
5231* N0 (input) INTEGER array of dimension (NMAT)
5232* Values of N to be tested.
5233*
5234* LDAS0 (input) INTEGER array of dimension (NMAT)
5235* Values of LDAS (leading dimension of A on source process)
5236* to be tested.
5237*
5238* LDAD0 (input) INTEGER array of dimension (NMAT)
5239* Values of LDAD (leading dimension of A on destination
5240* process) to be tested.
5241* NSRC (input) INTEGER
5242* The number of sources to be tested.
5243*
5244* RSRC0 (input) INTEGER array of dimension (NDEST)
5245* Values of RSRC (row coordinate of source) to be tested.
5246*
5247* CSRC0 (input) INTEGER array of dimension (NDEST)
5248* Values of CSRC (column coordinate of source) to be tested.
5249*
5250* NGRID (input) INTEGER
5251* The number of process grids to be tested.
5252*
5253* CONTEXT0 (input) INTEGER array of dimension (NGRID)
5254* The BLACS context handles corresponding to the grids.
5255*
5256* P0 (input) INTEGER array of dimension (NGRID)
5257* Values of P (number of process rows, NPROW).
5258*
5259* Q0 (input) INTEGER array of dimension (NGRID)
5260* Values of Q (number of process columns, NPCOL).
5261*
5262* TFAIL (workspace) INTEGER array of dimension (NTESTS)
5263* If VERB < 2, serves to indicate which tests fail. This
5264* requires workspace of NTESTS (number of tests performed).
5265*
5266* MEM (workspace) COMPLEX array of dimension (MEMLEN)
5267* Used for all other workspaces, including the matrix A,
5268* and its pre and post padding.
5269*
5270* MEMLEN (input) INTEGER
5271* The length, in elements, of MEM.
5272*
5273* =====================================================================
5274*
5275* .. External Functions ..
5276 LOGICAL ALLPASS, LSAME
5277 INTEGER IBTMYPROC, IBTSIZEOF
5278 EXTERNAL ALLPASS, LSAME, IBTMYPROC, IBTSIZEOF
5279* ..
5280* .. External Subroutines ..
5281 EXTERNAL BLACS_GRIDINFO
5282 EXTERNAL CTRBS2D, CGEBS2D, CTRBR2D, CGEBR2D
5283 EXTERNAL CINITMAT, CCHKMAT, CCHKPAD, CBTCHECKIN
5284* ..
5285* .. Local Scalars ..
5286 CHARACTER*1 SCOPE, TOP, UPLO, DIAG
5287 LOGICAL TESTOK, INGRID
5288 INTEGER IAM, I, K, J, IGR, ISH, IMA, ISO, ISC, ITO
5289 INTEGER M, N, NPROW, NPCOL, MYROW, MYCOL, RSRC, CSRC
5290 INTEGER ISTART, ISTOP, IPRE, IPOST, SETWHAT
5291 INTEGER NERR, NSKIP, NFAIL, TESTNUM, CONTEXT, MAXERR, LDASRC
5292 INTEGER LDADST, ERRDPTR, APTR, ERRIPTR, ISIZE, CSIZE
5293 COMPLEX SCHECKVAL, RCHECKVAL
5294* ..
5295* .. Executable Statements ..
5296*
5297 SCHECKVAL = cmplx( -0.01, -0.01 )
5298 rcheckval = cmplx( -0.02, -0.02 )
5299*
5300 iam = ibtmyproc()
5301 isize = ibtsizeof('I')
5302 csize = ibtsizeof('C')
5303*
5304* Verify file parameters
5305*
5306 IF( iam .EQ. 0 ) THEN
5307 WRITE(outnum, *) ' '
5308 WRITE(outnum, *) ' '
5309 WRITE(outnum, 1000 )
5310 IF( verb .GT. 0 ) THEN
5311 WRITE(outnum,*) ' '
5312 WRITE(outnum, 2000) 'NSCOPE:', nscope
5313 WRITE(outnum, 3000) ' SCOPE:', ( scope0(i), i = 1, nscope )
5314 WRITE(outnum, 2000) 'NTOP :', ntop
5315 WRITE(outnum, 3000) ' TOP :', ( top0(i), i = 1, ntop )
5316 WRITE(outnum, 2000) 'NSHAPE:', nshape
5317 WRITE(outnum, 3000) ' UPLO :', ( uplo0(i), i = 1, nshape )
5318 WRITE(outnum, 3000) ' DIAG :', ( diag0(i), i = 1, nshape )
5319 WRITE(outnum, 2000) 'NMAT :', nmat
5320 WRITE(outnum, 2000) ' M :', ( m0(i), i = 1, nmat )
5321 WRITE(outnum, 2000) ' N :', ( n0(i), i = 1, nmat )
5322 WRITE(outnum, 2000) ' LDAS :', ( ldas0(i), i = 1, nmat )
5323 WRITE(outnum, 2000) ' LDAD :', ( ldad0(i), i = 1, nmat )
5324 WRITE(outnum, 2000) 'NSRC :', nsrc
5325 WRITE(outnum, 2000) ' RSRC :',( rsrc0(i), i = 1, nsrc )
5326 WRITE(outnum, 2000) ' CSRC :',( csrc0(i), i = 1, nsrc )
5327 WRITE(outnum, 2000) 'NGRIDS:', ngrid
5328 WRITE(outnum, 2000) ' P :', ( p0(i), i = 1, ngrid )
5329 WRITE(outnum, 2000) ' Q :', ( q0(i), i = 1, ngrid )
5330 WRITE(outnum, 2000) 'VERB :', verb
5331 WRITE(outnum,*) ' '
5332 END IF
5333 IF( verb .GT. 1 ) THEN
5334 WRITE(outnum,5000)
5335 WRITE(outnum,6000)
5336 END IF
5337 END IF
5338*
5339* Find biggest matrix, so we know where to stick error info
5340*
5341 i = 0
5342 DO 10 ima = 1, nmat
5343 k = n0(ima) * max0( ldas0(ima), ldad0(ima) ) + 4 * m0(ima)
5344 IF( k .GT. i ) i = k
5345 10 CONTINUE
5346 maxerr = ( csize * (memlen-i) ) / ( csize*2 + isize*6 )
5347 IF( maxerr .LT. 1 ) THEN
5348 WRITE(outnum,*) 'ERROR: Not enough memory to run BSBR tests.'
5349 CALL blacs_abort(-1, 1)
5350 END IF
5351 errdptr = i + 1
5352 erriptr = errdptr + maxerr
5353 nerr = 0
5354 testnum = 0
5355 nfail = 0
5356 nskip = 0
5357*
5358* Loop over grids of matrix
5359*
5360 DO 110 igr = 1, ngrid
5361*
5362 context = context0(igr)
5363 CALL blacs_gridinfo( context, nprow, npcol, myrow, mycol )
5364*
5365 ingrid = ( nprow .GT. 0 )
5366*
5367 DO 100 isc = 1, nscope
5368 scope = scope0(isc)
5369 DO 90 ito = 1, ntop
5370 top = top0(ito)
5371*
5372* If testing multipath ('M') or general tree ('T'),
5373* need to loop over calls to BLACS_SET
5374*
5375 IF( lsame(top, 'M') ) THEN
5376 setwhat = 11
5377 IF( scope .EQ. 'R' ) THEN
5378 istart = -(npcol - 1)
5379 istop = -istart
5380 ELSE IF (scope .EQ. 'C') THEN
5381 istart = -(nprow - 1)
5382 istop = -istart
5383 ELSE
5384 istart = -(nprow*npcol - 1)
5385 istop = -istart
5386 ENDIF
5387 ELSE IF( lsame(top, 'T') ) THEN
5388 setwhat = 12
5389 istart = 1
5390 IF( scope .EQ. 'R' ) THEN
5391 istop = npcol - 1
5392 ELSE IF (scope .EQ. 'C') THEN
5393 istop = nprow - 1
5394 ELSE
5395 istop = nprow*npcol - 1
5396 ENDIF
5397 ELSE
5398 setwhat = 0
5399 istart = 1
5400 istop = 1
5401 ENDIF
5402 DO 80 ish = 1, nshape
5403 uplo = uplo0(ish)
5404 diag = diag0(ish)
5405*
5406 DO 70 ima = 1, nmat
5407 m = m0(ima)
5408 n = n0(ima)
5409 ldasrc = ldas0(ima)
5410 ldadst = ldad0(ima)
5411*
5412 DO 60 iso = 1, nsrc
5413 testnum = testnum + 1
5414 rsrc = rsrc0(iso)
5415 csrc = csrc0(iso)
5416 IF( rsrc.GE.p0(igr) .OR. csrc.GE.q0(igr) ) THEN
5417 nskip = nskip + 1
5418 GOTO 60
5419 END IF
5420 IF( verb .GT. 1 ) THEN
5421 IF( iam .EQ. 0 ) THEN
5422 WRITE(outnum, 7000)
5423 $ testnum, 'RUNNING',scope, top, uplo, diag,
5424 $ m, n, ldasrc, ldadst, rsrc, csrc,
5425 $ nprow, npcol
5426 END IF
5427 END IF
5428*
5429 testok = .true.
5430 ipre = 2 * m
5431 ipost = ipre
5432 aptr = ipre + 1
5433*
5434* If I am in scope
5435*
5436 IF( (myrow.EQ.rsrc .AND. scope.EQ.'R') .OR.
5437 $ (mycol.EQ.csrc .AND. scope.EQ.'C') .OR.
5438 $ (scope .EQ. 'A') ) THEN
5439*
5440* source process generates matrix and sends it
5441*
5442 IF( myrow.EQ.rsrc .AND. mycol.EQ.csrc ) THEN
5443 CALL cinitmat(uplo, diag, m, n, mem,
5444 $ ldasrc, ipre, ipost,
5445 $ scheckval, testnum,
5446 $ myrow, mycol )
5447*
5448 DO 20 j = istart, istop
5449 IF( j.EQ.0 ) GOTO 20
5450 IF( setwhat.NE.0 )
5451 $ CALL blacs_set(context, setwhat, j)
5452 IF( uplo.EQ.'U' .OR. uplo.EQ.'L' ) THEN
5453 CALL ctrbs2d(context, scope, top,
5454 $ uplo, diag, m, n,
5455 $ mem(aptr), ldasrc )
5456 ELSE
5457 CALL cgebs2d(context, scope, top,
5458 $ m, n, mem(aptr),
5459 $ ldasrc )
5460 END IF
5461 20 CONTINUE
5462*
5463* Destination processes
5464*
5465 ELSE IF( ingrid ) THEN
5466 DO 40 j = istart, istop
5467 IF( j.EQ.0 ) GOTO 40
5468 IF( setwhat.NE.0 )
5469 $ CALL blacs_set(context, setwhat, j)
5470*
5471* Pad entire matrix area
5472*
5473 DO 30 k = 1, ipre+ipost+ldadst*n
5474 mem(k) = rcheckval
5475 30 CONTINUE
5476*
5477* Receive matrix
5478*
5479 IF( uplo.EQ.'U' .OR. uplo.EQ.'L' ) THEN
5480 CALL ctrbr2d(context, scope, top,
5481 $ uplo, diag, m, n,
5482 $ mem(aptr), ldadst,
5483 $ rsrc, csrc)
5484 ELSE
5485 CALL cgebr2d(context, scope, top,
5486 $ m, n, mem(aptr),
5487 $ ldadst, rsrc, csrc)
5488 END IF
5489*
5490* Check for errors in matrix or padding
5491*
5492 i = nerr
5493 CALL cchkmat(uplo, diag, m, n,
5494 $ mem(aptr), ldadst, rsrc, csrc,
5495 $ myrow, mycol, testnum, maxerr,
5496 $ nerr, mem(erriptr),
5497 $ mem(errdptr))
5498*
5499 CALL cchkpad(uplo, diag, m, n, mem,
5500 $ ldadst, rsrc, csrc, myrow,
5501 $ mycol, ipre, ipost, rcheckval,
5502 $ testnum, maxerr, nerr,
5503 $ mem(erriptr), mem(errdptr))
5504 40 CONTINUE
5505 testok = ( i .EQ. nerr )
5506 END IF
5507 END IF
5508*
5509 IF( verb .GT. 1 ) THEN
5510 i = nerr
5511 CALL cbtcheckin(0, outnum, maxerr, nerr,
5512 $ mem(erriptr), mem(errdptr),
5513 $ tfail)
5514 IF( iam .EQ. 0 ) THEN
5515 testok = ( testok .AND. (i.EQ.nerr) )
5516 IF( testok ) THEN
5517 WRITE(outnum,7000)testnum,'PASSED ',
5518 $ scope, top, uplo, diag, m, n,
5519 $ ldasrc, ldadst, rsrc, csrc,
5520 $ nprow, npcol
5521 ELSE
5522 nfail = nfail + 1
5523 WRITE(outnum,7000)testnum,'FAILED ',
5524 $ scope, top, uplo, diag, m, n,
5525 $ ldasrc, ldadst, rsrc, csrc,
5526 $ nprow, npcol
5527 END IF
5528 END IF
5529*
5530* Once we've printed out errors, can re-use buf space
5531*
5532 nerr = 0
5533 END IF
5534 60 CONTINUE
5535 70 CONTINUE
5536 80 CONTINUE
5537 90 CONTINUE
5538 100 CONTINUE
5539 110 CONTINUE
5540*
5541 IF( verb .LT. 2 ) THEN
5542 nfail = testnum
5543 CALL cbtcheckin( nfail, outnum, maxerr, nerr, mem(erriptr),
5544 $ mem(errdptr), tfail )
5545 END IF
5546 IF( iam .EQ. 0 ) THEN
5547 IF( verb .GT. 1 ) WRITE(outnum,*) ' '
5548 IF( nfail+nskip .EQ. 0 ) THEN
5549 WRITE(outnum, 8000 ) testnum
5550 ELSE
5551 WRITE(outnum, 9000 ) testnum, testnum-nskip-nfail,
5552 $ nskip, nfail
5553 END IF
5554 END IF
5555*
5556* Log whether their were any failures
5557*
5558 testok = allpass( (nfail.EQ.0) )
5559*
5560 1000 FORMAT('COMPLEX BSBR TESTS: BEGIN.' )
5561 2000 FORMAT(1x,a7,3x,10i6)
5562 3000 FORMAT(1x,a7,3x,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,
5563 $ 5x,a1,5x,a1)
5564 5000 FORMAT(' TEST# STATUS SCOPE TOP UPLO DIAG M N LDAS ',
5565 $ ' LDAD RSRC CSRC P Q')
5566 6000 FORMAT(' ----- ------- ----- --- ---- ---- ----- ----- ----- ',
5567 $ '----- ---- ---- ---- ----')
5568 7000 FORMAT(i6,1x,a7,5x,a1,3x,a1,2(4x,a1), 4i6, 4i5)
5569 8000 FORMAT('COMPLEX BSBR TESTS: PASSED ALL',
5570 $ i5, ' TESTS.')
5571 9000 FORMAT('COMPLEX BSBR TESTS:',i5,' TESTS;',i5,' PASSED,',
5572 $ i5,' SKIPPED,',i5,' FAILED.')
5573*
5574 RETURN
5575*
5576* End of CBSBRTEST.
5577*
5578 END
5579*
5580*
5581 SUBROUTINE zbsbrtest( OUTNUM, VERB, NSCOPE, SCOPE0, NTOP, TOP0,
5582 $ NSHAPE, UPLO0, DIAG0, NMAT, M0, N0, LDAS0,
5583 $ LDAD0, NSRC, RSRC0, CSRC0, NGRID, CONTEXT0,
5584 $ P0, Q0, TFAIL, MEM, MEMLEN )
5585*
5586* -- BLACS tester (version 1.0) --
5587* University of Tennessee
5588* December 15, 1994
5589*
5590*
5591* .. Scalar Arguments ..
5592 INTEGER OUTNUM, VERB, NSCOPE, NTOP, NSHAPE, NMAT, NSRC, NGRID
5593 INTEGER MEMLEN
5594* ..
5595* .. Array Arguments ..
5596 CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP)
5597 CHARACTER*1 UPLO0(NSHAPE), DIAG0(NSHAPE)
5598 INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT)
5599 INTEGER RSRC0(NSRC), CSRC0(NSRC), CONTEXT0(NGRID)
5600 INTEGER P0(NGRID), Q0(NGRID), TFAIL(*)
5601 DOUBLE COMPLEX MEM(MEMLEN)
5602* ..
5603*
5604* Purpose
5605* =======
5606* ZTESTBSBR: Test double complex broadcast
5607*
5608* Arguments
5609* =========
5610* OUTNUM (input) INTEGER
5611* The device number to write output to.
5612*
5613* VERB (input) INTEGER
5614* The level of verbosity (how much printing to do).
5615*
5616* NSCOPE (input) INTEGER
5617* The number of scopes to be tested.
5618*
5619* SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE)
5620* Values of the scopes to be tested.
5621*
5622* NTOP (input) INTEGER
5623* The number of topologies to be tested.
5624*
5625* TOP0 (input) CHARACTER*1 array of dimension (NTOP)
5626* Values of the topologies to be tested.
5627*
5628* NSHAPE (input) INTEGER
5629* The number of matrix shapes to be tested.
5630*
5631* UPLO0 (input) CHARACTER*1 array of dimension (NSHAPE)
5632* Values of UPLO to be tested.
5633*
5634* DIAG0 (input) CHARACTER*1 array of dimension (NSHAPE)
5635* Values of DIAG to be tested.
5636*
5637* NMAT (input) INTEGER
5638* The number of matrices to be tested.
5639*
5640* M0 (input) INTEGER array of dimension (NMAT)
5641* Values of M to be tested.
5642*
5643* M0 (input) INTEGER array of dimension (NMAT)
5644* Values of M to be tested.
5645*
5646* N0 (input) INTEGER array of dimension (NMAT)
5647* Values of N to be tested.
5648*
5649* LDAS0 (input) INTEGER array of dimension (NMAT)
5650* Values of LDAS (leading dimension of A on source process)
5651* to be tested.
5652*
5653* LDAD0 (input) INTEGER array of dimension (NMAT)
5654* Values of LDAD (leading dimension of A on destination
5655* process) to be tested.
5656* NSRC (input) INTEGER
5657* The number of sources to be tested.
5658*
5659* RSRC0 (input) INTEGER array of dimension (NDEST)
5660* Values of RSRC (row coordinate of source) to be tested.
5661*
5662* CSRC0 (input) INTEGER array of dimension (NDEST)
5663* Values of CSRC (column coordinate of source) to be tested.
5664*
5665* NGRID (input) INTEGER
5666* The number of process grids to be tested.
5667*
5668* CONTEXT0 (input) INTEGER array of dimension (NGRID)
5669* The BLACS context handles corresponding to the grids.
5670*
5671* P0 (input) INTEGER array of dimension (NGRID)
5672* Values of P (number of process rows, NPROW).
5673*
5674* Q0 (input) INTEGER array of dimension (NGRID)
5675* Values of Q (number of process columns, NPCOL).
5676*
5677* TFAIL (workspace) INTEGER array of dimension (NTESTS)
5678* If VERB < 2, serves to indicate which tests fail. This
5679* requires workspace of NTESTS (number of tests performed).
5680*
5681* MEM (workspace) DOUBLE COMPLEX array of dimension (MEMLEN)
5682* Used for all other workspaces, including the matrix A,
5683* and its pre and post padding.
5684*
5685* MEMLEN (input) INTEGER
5686* The length, in elements, of MEM.
5687*
5688* =====================================================================
5689*
5690* .. External Functions ..
5691 LOGICAL ALLPASS, LSAME
5692 INTEGER IBTMYPROC, IBTSIZEOF
5693 EXTERNAL ALLPASS, LSAME, IBTMYPROC, IBTSIZEOF
5694* ..
5695* .. External Subroutines ..
5696 EXTERNAL BLACS_GRIDINFO
5697 EXTERNAL ZTRBS2D, ZGEBS2D, ZTRBR2D, ZGEBR2D
5698 EXTERNAL ZINITMAT, ZCHKMAT, ZCHKPAD, ZBTCHECKIN
5699* ..
5700* .. Local Scalars ..
5701 CHARACTER*1 SCOPE, TOP, UPLO, DIAG
5702 LOGICAL TESTOK, INGRID
5703 INTEGER IAM, I, K, J, IGR, ISH, IMA, ISO, ISC, ITO
5704 INTEGER M, N, NPROW, NPCOL, MYROW, MYCOL, RSRC, CSRC
5705 INTEGER ISTART, ISTOP, IPRE, IPOST, SETWHAT
5706 INTEGER NERR, NSKIP, NFAIL, TESTNUM, CONTEXT, MAXERR, LDASRC
5707 INTEGER LDADST, ERRDPTR, APTR, ERRIPTR, ISIZE, ZSIZE
5708 DOUBLE COMPLEX SCHECKVAL, RCHECKVAL
5709* ..
5710* .. Executable Statements ..
5711*
5712 SCHECKVAL = dcmplx( -0.01d0, -0.01d0 )
5713 rcheckval = dcmplx( -0.02d0, -0.02d0 )
5714*
5715 iam = ibtmyproc()
5716 isize = ibtsizeof('I')
5717 zsize = ibtsizeof('Z')
5718*
5719* Verify file parameters
5720*
5721 IF( iam .EQ. 0 ) THEN
5722 WRITE(outnum, *) ' '
5723 WRITE(outnum, *) ' '
5724 WRITE(outnum, 1000 )
5725 IF( verb .GT. 0 ) THEN
5726 WRITE(outnum,*) ' '
5727 WRITE(outnum, 2000) 'NSCOPE:', nscope
5728 WRITE(outnum, 3000) ' SCOPE:', ( scope0(i), i = 1, nscope )
5729 WRITE(outnum, 2000) 'NTOP :', ntop
5730 WRITE(outnum, 3000) ' TOP :', ( top0(i), i = 1, ntop )
5731 WRITE(outnum, 2000) 'NSHAPE:', nshape
5732 WRITE(outnum, 3000) ' UPLO :', ( uplo0(i), i = 1, nshape )
5733 WRITE(outnum, 3000) ' DIAG :', ( diag0(i), i = 1, nshape )
5734 WRITE(outnum, 2000) 'NMAT :', nmat
5735 WRITE(outnum, 2000) ' M :', ( m0(i), i = 1, nmat )
5736 WRITE(outnum, 2000) ' N :', ( n0(i), i = 1, nmat )
5737 WRITE(outnum, 2000) ' LDAS :', ( ldas0(i), i = 1, nmat )
5738 WRITE(outnum, 2000) ' LDAD :', ( ldad0(i), i = 1, nmat )
5739 WRITE(outnum, 2000) 'NSRC :', nsrc
5740 WRITE(outnum, 2000) ' RSRC :',( rsrc0(i), i = 1, nsrc )
5741 WRITE(outnum, 2000) ' CSRC :',( csrc0(i), i = 1, nsrc )
5742 WRITE(outnum, 2000) 'NGRIDS:', ngrid
5743 WRITE(outnum, 2000) ' P :', ( p0(i), i = 1, ngrid )
5744 WRITE(outnum, 2000) ' Q :', ( q0(i), i = 1, ngrid )
5745 WRITE(outnum, 2000) 'VERB :', verb
5746 WRITE(outnum,*) ' '
5747 END IF
5748 IF( verb .GT. 1 ) THEN
5749 WRITE(outnum,5000)
5750 WRITE(outnum,6000)
5751 END IF
5752 END IF
5753*
5754* Find biggest matrix, so we know where to stick error info
5755*
5756 i = 0
5757 DO 10 ima = 1, nmat
5758 k = n0(ima) * max0( ldas0(ima), ldad0(ima) ) + 4 * m0(ima)
5759 IF( k .GT. i ) i = k
5760 10 CONTINUE
5761 maxerr = ( zsize * (memlen-i) ) / ( zsize*2 + isize*6 )
5762 IF( maxerr .LT. 1 ) THEN
5763 WRITE(outnum,*) 'ERROR: Not enough memory to run BSBR tests.'
5764 CALL blacs_abort(-1, 1)
5765 END IF
5766 errdptr = i + 1
5767 erriptr = errdptr + maxerr
5768 nerr = 0
5769 testnum = 0
5770 nfail = 0
5771 nskip = 0
5772*
5773* Loop over grids of matrix
5774*
5775 DO 110 igr = 1, ngrid
5776*
5777 context = context0(igr)
5778 CALL blacs_gridinfo( context, nprow, npcol, myrow, mycol )
5779*
5780 ingrid = ( nprow .GT. 0 )
5781*
5782 DO 100 isc = 1, nscope
5783 scope = scope0(isc)
5784 DO 90 ito = 1, ntop
5785 top = top0(ito)
5786*
5787* If testing multipath ('M') or general tree ('T'),
5788* need to loop over calls to BLACS_SET
5789*
5790 IF( lsame(top, 'M') ) THEN
5791 setwhat = 11
5792 IF( scope .EQ. 'R' ) THEN
5793 istart = -(npcol - 1)
5794 istop = -istart
5795 ELSE IF (scope .EQ. 'C') THEN
5796 istart = -(nprow - 1)
5797 istop = -istart
5798 ELSE
5799 istart = -(nprow*npcol - 1)
5800 istop = -istart
5801 ENDIF
5802 ELSE IF( lsame(top, 'T') ) THEN
5803 setwhat = 12
5804 istart = 1
5805 IF( scope .EQ. 'R' ) THEN
5806 istop = npcol - 1
5807 ELSE IF (scope .EQ. 'C') THEN
5808 istop = nprow - 1
5809 ELSE
5810 istop = nprow*npcol - 1
5811 ENDIF
5812 ELSE
5813 setwhat = 0
5814 istart = 1
5815 istop = 1
5816 ENDIF
5817 DO 80 ish = 1, nshape
5818 uplo = uplo0(ish)
5819 diag = diag0(ish)
5820*
5821 DO 70 ima = 1, nmat
5822 m = m0(ima)
5823 n = n0(ima)
5824 ldasrc = ldas0(ima)
5825 ldadst = ldad0(ima)
5826*
5827 DO 60 iso = 1, nsrc
5828 testnum = testnum + 1
5829 rsrc = rsrc0(iso)
5830 csrc = csrc0(iso)
5831 IF( rsrc.GE.p0(igr) .OR. csrc.GE.q0(igr) ) THEN
5832 nskip = nskip + 1
5833 GOTO 60
5834 END IF
5835 IF( verb .GT. 1 ) THEN
5836 IF( iam .EQ. 0 ) THEN
5837 WRITE(outnum, 7000)
5838 $ testnum, 'RUNNING',scope, top, uplo, diag,
5839 $ m, n, ldasrc, ldadst, rsrc, csrc,
5840 $ nprow, npcol
5841 END IF
5842 END IF
5843*
5844 testok = .true.
5845 ipre = 2 * m
5846 ipost = ipre
5847 aptr = ipre + 1
5848*
5849* If I am in scope
5850*
5851 IF( (myrow.EQ.rsrc .AND. scope.EQ.'R') .OR.
5852 $ (mycol.EQ.csrc .AND. scope.EQ.'C') .OR.
5853 $ (scope .EQ. 'A') ) THEN
5854*
5855* source process generates matrix and sends it
5856*
5857 IF( myrow.EQ.rsrc .AND. mycol.EQ.csrc ) THEN
5858 CALL zinitmat(uplo, diag, m, n, mem,
5859 $ ldasrc, ipre, ipost,
5860 $ scheckval, testnum,
5861 $ myrow, mycol )
5862*
5863 DO 20 j = istart, istop
5864 IF( j.EQ.0 ) GOTO 20
5865 IF( setwhat.NE.0 )
5866 $ CALL blacs_set(context, setwhat, j)
5867 IF( uplo.EQ.'U' .OR. uplo.EQ.'L' ) THEN
5868 CALL ztrbs2d(context, scope, top,
5869 $ uplo, diag, m, n,
5870 $ mem(aptr), ldasrc )
5871 ELSE
5872 CALL zgebs2d(context, scope, top,
5873 $ m, n, mem(aptr),
5874 $ ldasrc )
5875 END IF
5876 20 CONTINUE
5877*
5878* Destination processes
5879*
5880 ELSE IF( ingrid ) THEN
5881 DO 40 j = istart, istop
5882 IF( j.EQ.0 ) GOTO 40
5883 IF( setwhat.NE.0 )
5884 $ CALL blacs_set(context, setwhat, j)
5885*
5886* Pad entire matrix area
5887*
5888 DO 30 k = 1, ipre+ipost+ldadst*n
5889 mem(k) = rcheckval
5890 30 CONTINUE
5891*
5892* Receive matrix
5893*
5894 IF( uplo.EQ.'U' .OR. uplo.EQ.'L' ) THEN
5895 CALL ztrbr2d(context, scope, top,
5896 $ uplo, diag, m, n,
5897 $ mem(aptr), ldadst,
5898 $ rsrc, csrc)
5899 ELSE
5900 CALL zgebr2d(context, scope, top,
5901 $ m, n, mem(aptr),
5902 $ ldadst, rsrc, csrc)
5903 END IF
5904*
5905* Check for errors in matrix or padding
5906*
5907 i = nerr
5908 CALL zchkmat(uplo, diag, m, n,
5909 $ mem(aptr), ldadst, rsrc, csrc,
5910 $ myrow, mycol, testnum, maxerr,
5911 $ nerr, mem(erriptr),
5912 $ mem(errdptr))
5913*
5914 CALL zchkpad(uplo, diag, m, n, mem,
5915 $ ldadst, rsrc, csrc, myrow,
5916 $ mycol, ipre, ipost, rcheckval,
5917 $ testnum, maxerr, nerr,
5918 $ mem(erriptr), mem(errdptr))
5919 40 CONTINUE
5920 testok = ( i .EQ. nerr )
5921 END IF
5922 END IF
5923*
5924 IF( verb .GT. 1 ) THEN
5925 i = nerr
5926 CALL zbtcheckin(0, outnum, maxerr, nerr,
5927 $ mem(erriptr), mem(errdptr),
5928 $ tfail)
5929 IF( iam .EQ. 0 ) THEN
5930 testok = ( testok .AND. (i.EQ.nerr) )
5931 IF( testok ) THEN
5932 WRITE(outnum,7000)testnum,'PASSED ',
5933 $ scope, top, uplo, diag, m, n,
5934 $ ldasrc, ldadst, rsrc, csrc,
5935 $ nprow, npcol
5936 ELSE
5937 nfail = nfail + 1
5938 WRITE(outnum,7000)testnum,'FAILED ',
5939 $ scope, top, uplo, diag, m, n,
5940 $ ldasrc, ldadst, rsrc, csrc,
5941 $ nprow, npcol
5942 END IF
5943 END IF
5944*
5945* Once we've printed out errors, can re-use buf space
5946*
5947 nerr = 0
5948 END IF
5949 60 CONTINUE
5950 70 CONTINUE
5951 80 CONTINUE
5952 90 CONTINUE
5953 100 CONTINUE
5954 110 CONTINUE
5955*
5956 IF( verb .LT. 2 ) THEN
5957 nfail = testnum
5958 CALL zbtcheckin( nfail, outnum, maxerr, nerr, mem(erriptr),
5959 $ mem(errdptr), tfail )
5960 END IF
5961 IF( iam .EQ. 0 ) THEN
5962 IF( verb .GT. 1 ) WRITE(outnum,*) ' '
5963 IF( nfail+nskip .EQ. 0 ) THEN
5964 WRITE(outnum, 8000 ) testnum
5965 ELSE
5966 WRITE(outnum, 9000 ) testnum, testnum-nskip-nfail,
5967 $ nskip, nfail
5968 END IF
5969 END IF
5970*
5971* Log whether their were any failures
5972*
5973 testok = allpass( (nfail.EQ.0) )
5974*
5975 1000 FORMAT('DOUBLE COMPLEX BSBR TESTS: BEGIN.' )
5976 2000 FORMAT(1x,a7,3x,10i6)
5977 3000 FORMAT(1x,a7,3x,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,
5978 $ 5x,a1,5x,a1)
5979 5000 FORMAT(' TEST# STATUS SCOPE TOP UPLO DIAG M N LDAS ',
5980 $ ' LDAD RSRC CSRC P Q')
5981 6000 FORMAT(' ----- ------- ----- --- ---- ---- ----- ----- ----- ',
5982 $ '----- ---- ---- ---- ----')
5983 7000 FORMAT(i6,1x,a7,5x,a1,3x,a1,2(4x,a1), 4i6, 4i5)
5984 8000 FORMAT('DOUBLE COMPLEX BSBR TESTS: PASSED ALL',
5985 $ i5, ' TESTS.')
5986 9000 FORMAT('DOUBLE COMPLEX BSBR TESTS:',i5,' TESTS;',i5,' PASSED,',
5987 $ i5,' SKIPPED,',i5,' FAILED.')
5988*
5989 RETURN
5990*
5991* End of ZBSBRTEST.
5992*
5993 END
5994*
5995*
5996 SUBROUTINE rdcomb( MEMUSED, MEM, MEMLEN, CMEMUSED, CMEM, CMEMLEN,
5997 $ OUTNUM )
5998*
5999* -- BLACS tester (version 1.0) --
6000* University of Tennessee
6001* December 15, 1994
6002*
6003*
6004* .. Scalar Arguments ..
6005 INTEGER MEMUSED, MEMLEN, CMEMUSED, CMEMLEN, OUTNUM
6006* ..
6007* .. Array Arguments ..
6008 CHARACTER*1 CMEM(CMEMLEN)
6009 INTEGER MEM(MEMLEN)
6010* ..
6011*
6012* Purpose
6013* =======
6014* RDCOMB: Read and process the input file COMB.dat.
6015*
6016* Arguments
6017* =========
6018* MEMUSED (output) INTEGER
6019* Number of elements in MEM that this subroutine ends up using.
6020*
6021* MEM (output) INTEGER array of dimension memlen
6022* On output, holds information read in from sdrv.dat.
6023*
6024* MEMLEN (input) INTEGER
6025* Number of elements of MEM that this subroutine
6026* may safely write into.
6027*
6028* CMEMUSED (output) INTEGER
6029* Number of elements in CMEM that this subroutine ends up using.
6030*
6031* CMEM (output) CHARACTER*1 array of dimension cmemlen
6032* On output, holds the values for UPLO and DIAG.
6033*
6034* CMEMLEN (input) INTEGER
6035* Number of elements of CMEM that this subroutine
6036* may safely write into.
6037*
6038* OUTNUM (input) INTEGER
6039* Unit number of the output file.
6040*
6041* =================================================================
6042*
6043* .. Parameters ..
6044 INTEGER SDIN
6045 PARAMETER( SDIN = 12 )
6046* ..
6047* .. External Functions ..
6048 logical lsame
6049 EXTERNAL lsame
6050* ..
6051* .. Local Scalars ..
6052 INTEGER TOPSREPEAT, TOPSCOHRNT, NOPS, NSCOPE, NTOP, NMAT, NDEST
6053 INTEGER NGRID, I, J, OPPTR, SCOPEPTR, TOPPTR, MPTR, NPTR
6054 INTEGER LDSPTR, LDDPTR, LDIPTR, RDESTPTR, CDESTPTR, PPTR, QPTR
6055* ..
6056* .. Executable Statements
6057*
6058* Open and read the file comb.dat. The expected format is
6059* below.
6060*
6061*------
6062*integer Number of operations
6063*array of CHAR*1's OPs: '+', '>', '<'
6064*integer Number of scopes
6065*array of CHAR*1's Values for Scopes
6066*HAR*1 Repeatability flag ('R', 'N', 'B')
6067*HAR*1 Coherency flag ('C', 'N', 'B')
6068*integer Number of topologies
6069*array of CHAR*1's Values for TOP
6070*integer number of nmat
6071*array of integers M: number of rows in matrix
6072*array of integers N: number of columns in matrix
6073*integer LDA: leading dimension on source proc
6074*integer LDA: leading dimension on dest proc
6075*integer number of source/dest pairs
6076*array of integers RDEST: process row of msg. dest.
6077*array of integers CDEST: process column of msg. dest.
6078*integer Number of grids
6079*array of integers NPROW: number of rows in process grid
6080*array of integers NPCOL: number of col's in proc. grid
6081*------
6082* note: the text descriptions as shown above are present in
6083* the sample comb.dat included with this distribution,
6084* but are not required.
6085*
6086* Read input file
6087*
6088 memused = 1
6089 cmemused = 1
6090 OPEN(unit = sdin, file = 'comb.dat', status = 'OLD')
6091*
6092* Get what operations to test (+, >, <)
6093*
6094 READ(sdin, *) nops
6095 opptr = cmemused
6096 cmemused = opptr + nops
6097 IF ( cmemused .GT. cmemlen ) THEN
6098 WRITE(outnum, 1000) cmemlen, nops, 'OPERATIONS.'
6099 IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE(outnum)
6100 stop
6101 ELSE IF( nops .LT. 1 ) THEN
6102 WRITE(outnum, 2000) 'OPERATIONS.'
6103 IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE(outnum)
6104 stop
6105 END IF
6106*
6107 READ(sdin, *) ( cmem(opptr+i), i = 0, nops-1 )
6108 DO 10 i = 0, nops-1
6109 IF( (cmem(opptr+i).NE.'+') .AND. (cmem(opptr+i).NE.'>') .AND.
6110 $ (cmem(opptr+i).NE.'<') ) THEN
6111 WRITE(outnum,5000) cmem(opptr+i)
6112 IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE(outnum)
6113 stop
6114 END IF
6115 10 CONTINUE
6116*
6117* Read in scopes and topologies
6118*
6119 READ(sdin, *) nscope
6120 scopeptr = cmemused
6121 cmemused = scopeptr + nscope
6122 IF ( cmemused .GT. cmemlen ) THEN
6123 WRITE(outnum, 1000) cmemlen, nscope, 'SCOPES.'
6124 IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE(outnum)
6125 stop
6126 ELSE IF( nscope .LT. 1 ) THEN
6127 WRITE(outnum, 2000) 'SCOPE.'
6128 IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE(outnum)
6129 stop
6130 END IF
6131*
6132 READ(sdin, *) ( cmem(scopeptr+i), i = 0, nscope-1 )
6133 DO 20 i = 0, nscope-1
6134 IF( lsame(cmem(scopeptr+i), 'R') ) THEN
6135 cmem(scopeptr+i) = 'R'
6136 ELSE IF( lsame(cmem(scopeptr+i), 'C') ) THEN
6137 cmem(scopeptr+i) = 'C'
6138 ELSE IF( lsame(cmem(scopeptr+i), 'A') ) THEN
6139 cmem(scopeptr+i) = 'A'
6140 ELSE
6141 WRITE(outnum, 3000) 'SCOPE', cmem(scopeptr+i)
6142 IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE(outnum)
6143 stop
6144 END IF
6145 20 CONTINUE
6146*
6147 READ(sdin, *) topsrepeat
6148 READ(sdin, *) topscohrnt
6149*
6150 READ(sdin, *) ntop
6151 topptr = cmemused
6152 cmemused = topptr + ntop
6153 IF ( cmemused .GT. cmemlen ) THEN
6154 WRITE(outnum, 1000) cmemlen, ntop, 'TOPOLOGIES.'
6155 IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE(outnum)
6156 stop
6157 ELSE IF( ntop .LT. 1 ) THEN
6158 WRITE(outnum, 2000) 'TOPOLOGY.'
6159 IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE(outnum)
6160 stop
6161 END IF
6162 READ(sdin, *) ( cmem(topptr+i), i = 0, ntop-1 )
6163*
6164*
6165* Read in number of matrices, and values for M, N, LDASRC, and LDADEST
6166*
6167 READ(sdin, *) nmat
6168 mptr = memused
6169 nptr = mptr + nmat
6170 ldsptr = nptr + nmat
6171 lddptr = ldsptr + nmat
6172 ldiptr = lddptr + nmat
6173 memused = ldiptr + nmat
6174 IF( memused .GT. memlen ) THEN
6175 WRITE(outnum, 1000) memlen, nmat, 'MATRICES.'
6176 IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE(outnum)
6177 stop
6178 ELSE IF( nmat .LT. 1 ) THEN
6179 WRITE(outnum, 2000) 'MATRIX.'
6180 IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE(outnum)
6181 stop
6182 END IF
6183 READ(sdin, *) ( mem( mptr+i ), i = 0, nmat-1 )
6184 READ(sdin, *) ( mem( nptr+i ), i = 0, nmat-1 )
6185 READ(sdin, *) ( mem( ldsptr+i ), i = 0, nmat-1 )
6186 READ(sdin, *) ( mem( lddptr+i ), i = 0, nmat-1 )
6187 READ(sdin, *) ( mem( ldiptr+i ), i = 0, nmat-1 )
6188*
6189* Make sure matrix values are legal
6190*
6191 CALL chkmatdat( outnum, 'COMB.dat', .true., nmat, mem(mptr),
6192 $ mem(nptr), mem(ldsptr), mem(lddptr), mem(ldiptr) )
6193*
6194* Read in number of dest pairs, and values of dest
6195*
6196 READ(sdin, *) ndest
6197 rdestptr = memused
6198 cdestptr = rdestptr + ndest
6199 memused = cdestptr + ndest
6200 IF( memused .GT. memlen ) THEN
6201 WRITE(outnum, 1000) memlen, nmat, 'DEST.'
6202 IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE(outnum)
6203 stop
6204 ELSE IF( ndest .LT. 1 ) THEN
6205 WRITE(outnum, 2000) 'DEST.'
6206 IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE(outnum)
6207 stop
6208 END IF
6209 READ(sdin, *) ( mem(rdestptr+i), i = 0, ndest-1 )
6210 READ(sdin, *) ( mem(cdestptr+i), i = 0, ndest-1 )
6211*
6212* Read in number of grids pairs, and values of P (process rows) and
6213* Q (process columns)
6214*
6215 READ(sdin, *) ngrid
6216 pptr = memused
6217 qptr = pptr + ngrid
6218 memused = qptr + ngrid
6219 IF( memused .GT. memlen ) THEN
6220 WRITE(outnum, 1000) memlen, ngrid, 'PROCESS GRIDS.'
6221 IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE(outnum)
6222 stop
6223 ELSE IF( ngrid .LT. 1 ) THEN
6224 WRITE(outnum, 2000) 'PROCESS GRID'
6225 IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE( outnum )
6226 stop
6227 END IF
6228*
6229 READ(sdin, *) ( mem(pptr+i), i = 0, ngrid-1 )
6230 READ(sdin, *) ( mem(qptr+i), i = 0, ngrid-1 )
6231 IF( sdin .NE. 6 .AND. sdin .NE. 0 ) CLOSE( sdin )
6232*
6233* Fatal error if we've got an illegal grid
6234*
6235 DO 70 j = 0, ngrid-1
6236 IF( mem(pptr+j).LT.1 .OR. mem(qptr+j).LT.1 ) THEN
6237 WRITE(outnum, 4000) mem(pptr+j), mem(qptr+j)
6238 IF( outnum .NE. 6 .AND. outnum .NE. 0 ) CLOSE(outnum)
6239 stop
6240 END IF
6241 70 CONTINUE
6242*
6243* Prepare output variables
6244*
6245 mem(memused) = nops
6246 mem(memused+1) = nscope
6247 mem(memused+2) = topsrepeat
6248 mem(memused+3) = topscohrnt
6249 mem(memused+4) = ntop
6250 mem(memused+5) = nmat
6251 mem(memused+6) = ndest
6252 mem(memused+7) = ngrid
6253 memused = memused + 7
6254 cmemused = cmemused - 1
6255*
6256 1000 FORMAT('Mem too short (',i4,') to handle',i4,' ',a20)
6257 2000 FORMAT('Must have at least one ',a20)
6258 3000 FORMAT('UNRECOGNIZABLE ',a5,' ''', a1, '''.')
6259 4000 FORMAT('Illegal process grid: {',i3,',',i3,'}.')
6260 5000 FORMAT('Illegal OP value ''',a1,''':, expected ''+'' (SUM),',
6261 $ ' ''>'' (MAX), or ''<'' (MIN).')
6262*
6263 RETURN
6264*
6265* End of RDCOMB.
6266*
6267 END
6268*
6269*
6270 SUBROUTINE ibtcheckin( NFTESTS, OUTNUM, MAXERR, NERR, IERR,
6271 $ IVAL, TFAILED )
6272 INTEGER NFTESTS, OUTNUM, MAXERR, NERR
6273 INTEGER IERR(*), TFAILED(*)
6274 INTEGER IVAL(*)
6275*
6276* Purpose
6277* =======
6278* IBTCHECKIN: Process 0 receives error report from all processes.
6279*
6280* Arguments
6281* =========
6282* NFTESTS (input/output) INTEGER
6283* if NFTESTS is <= 0 upon entry, NFTESTS is not written to.
6284* Otherwise, on entry it specifies the total number of tests
6285* run, and on exit it is the number of tests which failed.
6286*
6287* OUTNUM (input) INTEGER
6288* Device number for output.
6289*
6290* MAXERR (input) INTEGER
6291* Max number of errors that can be stored in ERRIBUFF or
6292* ERRIBUFF
6293*
6294* NERR (output) INTEGER
6295* The number of errors that have been found.
6296*
6297* ERRIBUF (output) INTEGER array, dimension (6,MAXERRS)
6298* Buffer in which to store integer error information. It will
6299* be built up in the following format for the call to TSEND.
6300* All integer information is recorded in the following 6-tuple
6301* {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured:
6302* SRC = RSRC * NPROCS + CSRC
6303* DEST = RDEST * NPROCS + CDEST
6304* WHAT
6305* = 1 : Error in pre-padding
6306* = 2 : Error in post-padding
6307* = 3 : Error in LDA-M gap
6308* = 4 : Error in complementory triangle
6309* ELSE: Error in matrix
6310* If there are more errors than can fit in the error buffer,
6311* the error number will indicate the actual number of errors
6312* found, but the buffer will be truncated to the maximum
6313* number of errors which can fit.
6314*
6315* ERRDBUF (output) @(doctype) array, dimension (2, MAXERRS)
6316* Buffer in which to store error data information.
6317* {Incorrect, Predicted}
6318*
6319* TFAILED (workspace) INTEGER array, dimension NFTESTS
6320* Workspace used to keep track of which tests failed.
6321* If input of NFTESTS < 1, this array not accessed.
6322*
6323* ===================================================================
6324*
6325* .. External Functions ..
6326 INTEGER IBTMYPROC, IBTNPROCS, IBTMSGID
6327 EXTERNAL IBTMYPROC, IBTNPROCS, IBTMSGID
6328* ..
6329* .. Local Scalars ..
6330 LOGICAL COUNTING
6331 INTEGER K, NERR2, IAM, NPROCS, NTESTS
6332*
6333* Proc 0 collects error info from everyone
6334*
6335 IAM = ibtmyproc()
6336 nprocs = ibtnprocs()
6337*
6338 IF( iam .EQ. 0 ) THEN
6339*
6340* If we are finding out how many failed tests there are, initialize
6341* the total number of tests (NTESTS), and zero the test failed array
6342*
6343 counting = nftests .GT. 0
6344 IF( counting ) THEN
6345 ntests = nftests
6346 DO 10 k = 1, ntests
6347 tfailed(k) = 0
6348 10 CONTINUE
6349 END IF
6350*
6351 CALL iprinterrs(outnum, maxerr, nerr, ierr, ival, counting,
6352 $ tfailed)
6353*
6354 DO 20 k = 1, nprocs-1
6355 CALL btsend(3, 0, k, k, ibtmsgid()+50)
6356 CALL btrecv(3, 1, nerr2, k, ibtmsgid()+50)
6357 IF( nerr2 .GT. 0 ) THEN
6358 nerr = nerr + nerr2
6359 CALL btrecv(3, nerr2*6, ierr, k, ibtmsgid()+51)
6360 CALL btrecv(3, nerr2*2, ival, k, ibtmsgid()+51)
6361 CALL iprinterrs(outnum, maxerr, nerr2, ierr, ival,
6362 $ counting, tfailed)
6363 END IF
6364 20 CONTINUE
6365*
6366* Count up number of tests that failed
6367*
6368 IF( counting ) THEN
6369 nftests = 0
6370 DO 30 k = 1, ntests
6371 nftests = nftests + tfailed(k)
6372 30 CONTINUE
6373 END IF
6374*
6375* Send my error info to proc 0
6376*
6377 ELSE
6378 CALL btrecv(3, 0, k, 0, ibtmsgid()+50)
6379 CALL btsend(3, 1, nerr, 0, ibtmsgid()+50)
6380 IF( nerr .GT. 0 ) THEN
6381 CALL btsend(3, nerr*6, ierr, 0, ibtmsgid()+51)
6382 CALL btsend(3, nerr*2, ival, 0, ibtmsgid()+51)
6383 END IF
6384 ENDIF
6385*
6386 RETURN
6387*
6388* End of IBTCHECKIN
6389*
6390 END
6391*
6392 SUBROUTINE iinitmat(UPLO, DIAG, M, N, MEM, LDA, IPRE, IPOST,
6393 $ CHECKVAL, TESTNUM, MYROW, MYCOL)
6394 CHARACTER*1 UPLO, DIAG
6395 INTEGER M, N, LDA, IPRE, IPOST, TESTNUM, MYROW, MYCOL
6396 INTEGER CHECKVAL
6397 INTEGER MEM(*)
6398*
6399* .. External Subroutines ..
6400 EXTERNAL igenmat, ipadmat
6401* ..
6402* .. Executable Statements ..
6403*
6404 CALL igenmat( m, n, mem(ipre+1), lda, testnum, myrow, mycol )
6405 CALL ipadmat( uplo, diag, m, n, mem, lda, ipre, ipost, checkval )
6406*
6407 RETURN
6408 END
6409*
6410 SUBROUTINE igenmat( M, N, A, LDA, TESTNUM, MYROW, MYCOL )
6411*
6412* -- BLACS tester (version 1.0) --
6413* University of Tennessee
6414* December 15, 1994
6415*
6416*
6417* .. Scalar Arguments ..
6418 INTEGER M, N, LDA, TESTNUM, MYROW, MYCOL
6419* ..
6420* .. Array Arguments ..
6421 INTEGER A(LDA,N)
6422* ..
6423*
6424* Purpose
6425* =======
6426* IGENMAT: Generates an M-by-N matrix filled with random elements.
6427*
6428* Arguments
6429* =========
6430* M (input) INTEGER
6431* The number of rows of the matrix A. M >= 0.
6432*
6433* N (input) INTEGER
6434* The number of columns of the matrix A. N >= 0.
6435*
6436* A (output) @up@(doctype) array, dimension (LDA,N)
6437* The m by n matrix A. Fortran77 (column-major) storage
6438* assumed.
6439*
6440* LDA (input) INTEGER
6441* The leading dimension of the array A. LDA >= max(1, M).
6442*
6443* TESTNUM (input) INTEGER
6444* Unique number for this test case, used as a basis for
6445* the random seeds.
6446*
6447* ====================================================================
6448*
6449* .. External Functions ..
6450 INTEGER IBTNPROCS
6451 INTEGER IBTRAN
6452 EXTERNAL ibtran, ibtnprocs
6453* ..
6454* .. Local Scalars ..
6455 INTEGER I, J, NPROCS, SRC
6456* ..
6457* .. Local Arrays ..
6458 INTEGER ISEED(4)
6459* ..
6460* .. Executable Statements ..
6461*
6462* ISEED's four values must be positive integers less than 4096,
6463* fourth one has to be odd. (see _LARND). Use some goofy
6464* functions to come up with seed values which together should
6465* be unique.
6466*
6467 nprocs = ibtnprocs()
6468 src = myrow * nprocs + mycol
6469 iseed(1) = mod( 1002 + testnum*5 + src*3, 4096 )
6470 iseed(2) = mod( 2027 + testnum*7 + src, 4096 )
6471 iseed(3) = mod( 1234 + testnum + src*3, 4096 )
6472 iseed(4) = mod( 4311 + testnum*10 + src*2, 4096 )
6473*
6474 DO 10 j = 1, n
6475 DO 10 i = 1, m
6476 a(i, j) = ibtran( iseed )
6477 10 CONTINUE
6478*
6479 RETURN
6480*
6481* End of IGENMAT.
6482*
6483 END
6484*
6485 INTEGER FUNCTION ibtran(ISEED)
6486 INTEGER iseed(*)
6487*
6488* .. External Functions ..
6489 DOUBLE PRECISION dlarnd
6490 EXTERNAL dlarnd
6491* ..
6492* .. Local Scalars ..
6493 DOUBLE PRECISION dval
6494* ..
6495* .. Executable Statements ..
6496*
6497 dval = 1.0d6 * dlarnd(2, iseed)
6498 ibtran = int(dval)
6499*
6500 RETURN
6501*
6502* End of Ibtran
6503*
6504 END
6505*
6506 SUBROUTINE ipadmat( UPLO, DIAG, M, N, MEM, LDA, IPRE, IPOST,
6507 $ CHECKVAL )
6508*
6509* -- BLACS tester (version 1.0) --
6510* University of Tennessee
6511* December 15, 1994
6512*
6513* .. Scalar Arguments ..
6514 CHARACTER*1 UPLO, DIAG
6515 INTEGER M, N, LDA, IPRE, IPOST
6516 INTEGER CHECKVAL
6517* ..
6518* .. Array Arguments ..
6519 INTEGER MEM( * )
6520* ..
6521*
6522* Purpose
6523* =======
6524*
6525* IPADMAT: Pad Matrix.
6526* This routines surrounds a matrix with a guardzone initialized to the
6527* value CHECKVAL. There are three distinct guardzones:
6528* - A contiguous zone of size IPRE immediately before the start
6529* of the matrix.
6530* - A contiguous zone of size IPOST immedately after the end of the
6531* matrix.
6532* - Interstitial zones within each column of the matrix, in the
6533* elements A( M+1:LDA, J ).
6534*
6535* Arguments
6536* =========
6537* UPLO (input) CHARACTER*1
6538* Is the matrix A 'U'pper or 'L'ower trapezoidal, or 'G'eneral
6539* rectangular?
6540*
6541* DIAG (input) CHARACTER*1
6542* For trapezoidal matrices, is the main diagonal included
6543* ('N') or not ('U')?
6544*
6545* M (input) INTEGER
6546* The number of rows of the matrix A. M >= 0.
6547*
6548* N (input) INTEGER
6549* The number of columns of the matrix A. N >= 0.
6550*
6551* MEM (output) integer array, dimension (IPRE+IPOST+LDA*N)
6552* The address IPRE elements ahead of the matrix A you want to
6553* pad, which is then of dimension (LDA,N).
6554*
6555* IPRE (input) INTEGER
6556* The size of the guard zone ahead of the matrix A.
6557*
6558* IPOST (input) INTEGER
6559* The size of the guard zone behind the matrix A.
6560*
6561* CHECKVAL (input) integer
6562* The value to insert into the guard zones.
6563*
6564* ====================================================================
6565*
6566* .. Local Scalars ..
6567 INTEGER I, J, K
6568* ..
6569* .. Executable Statements ..
6570*
6571* Put check buffer in front of A
6572*
6573 IF( ipre .GT. 0 ) THEN
6574 DO 10 i = 1, ipre
6575 mem( i ) = checkval
6576 10 CONTINUE
6577 END IF
6578*
6579* Put check buffer in back of A
6580*
6581 IF( ipost .GT. 0 ) THEN
6582 j = ipre + lda*n + 1
6583 DO 20 i = j, j+ipost-1
6584 mem( i ) = checkval
6585 20 CONTINUE
6586 END IF
6587*
6588* Put check buffer in all (LDA-M) gaps
6589*
6590 IF( lda .GT. m ) THEN
6591 k = ipre + m + 1
6592 DO 40 j = 1, n
6593 DO 30 i = k, k+lda-m-1
6594 mem( i ) = checkval
6595 30 CONTINUE
6596 k = k + lda
6597 40 CONTINUE
6598 END IF
6599*
6600* If the matrix is upper or lower trapezoidal, calculate the
6601* additional triangular area which needs to be padded, Each
6602* element referred to is in the Ith row and the Jth column.
6603*
6604 IF( uplo .EQ. 'U' ) THEN
6605 IF( m .LE. n ) THEN
6606 IF( diag .EQ. 'U' ) THEN
6607 DO 41 i = 1, m
6608 DO 42 j = 1, i
6609 k = ipre + i + (j-1)*lda
6610 mem( k ) = checkval
6611 42 CONTINUE
6612 41 CONTINUE
6613 ELSE
6614 DO 43 i = 2, m
6615 DO 44 j = 1, i-1
6616 k = ipre + i + (j-1)*lda
6617 mem( k ) = checkval
6618 44 CONTINUE
6619 43 CONTINUE
6620 END IF
6621 ELSE
6622 IF( diag .EQ. 'U' ) THEN
6623 DO 45 i = m-n+1, m
6624 DO 46 j = 1, i-(m-n)
6625 k = ipre + i + (j-1)*lda
6626 mem( k ) = checkval
6627 46 CONTINUE
6628 45 CONTINUE
6629 ELSE
6630 DO 47 i = m-n+2, m
6631 DO 48 j = 1, i-(m-n)-1
6632 k = ipre + i + (j-1)*lda
6633 mem( k ) = checkval
6634 48 CONTINUE
6635 47 CONTINUE
6636 END IF
6637 END IF
6638 ELSE IF( uplo .EQ. 'L' ) THEN
6639 IF( m .LE. n ) THEN
6640 IF( diag .EQ. 'U' ) THEN
6641 DO 49 i = 1, m
6642 DO 50 j = n-m+i, n
6643 k = ipre + i + (j-1)*lda
6644 mem( k ) = checkval
6645 50 CONTINUE
6646 49 CONTINUE
6647 ELSE
6648 DO 51 i = 1, m-1
6649 DO 52 j = n-m+i+1, n
6650 k = ipre + i + (j-1)*lda
6651 mem( k ) = checkval
6652 52 CONTINUE
6653 51 CONTINUE
6654 END IF
6655 ELSE
6656 IF( uplo .EQ. 'U' ) THEN
6657 DO 53 i = 1, n
6658 DO 54 j = i, n
6659 k = ipre + i + (j-1)*lda
6660 mem( k ) = checkval
6661 54 CONTINUE
6662 53 CONTINUE
6663 ELSE
6664 DO 55 i = 1, n-1
6665 DO 56 j = i+1, n
6666 k = ipre + i + (j-1)*lda
6667 mem( k ) = checkval
6668 56 CONTINUE
6669 55 CONTINUE
6670 END IF
6671 END IF
6672 END IF
6673*
6674* End of IPADMAT.
6675*
6676 RETURN
6677 END
6678*
6679 SUBROUTINE ichkpad( UPLO, DIAG, M, N, MEM, LDA, RSRC, CSRC,
6680 $ MYROW, MYCOL, IPRE, IPOST, CHECKVAL,
6681 $ TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF )
6682*
6683* -- BLACS tester (version 1.0) --
6684* University of Tennessee
6685* December 15, 1994
6686*
6687*
6688* .. Scalar Arguments ..
6689 CHARACTER*1 UPLO, DIAG
6690 INTEGER M, N, LDA, RSRC, CSRC, MYROW, MYCOL, IPRE, IPOST
6691 INTEGER TESTNUM, MAXERR, NERR
6692 INTEGER CHECKVAL
6693* ..
6694* .. Array Arguments ..
6695 INTEGER ERRIBUF(6, MAXERR)
6696 INTEGER MEM(*), ERRDBUF(2, MAXERR)
6697* ..
6698*
6699* Purpose
6700* =======
6701* ICHKPAD: Check padding put in by PADMAT.
6702* Checks that padding around target matrix has not been overwritten
6703* by the previous point-to-point or broadcast send.
6704*
6705* Arguments
6706* =========
6707* UPLO (input) CHARACTER*1
6708* Is the matrix A 'U'pper or 'L'ower trapezoidal, or 'G'eneral
6709* rectangular?
6710*
6711* DIAG (input) CHARACTER*1
6712* For trapezoidal matrices, is the main diagonal included
6713* ('N') or not ('U')?
6714*
6715* M (input) INTEGER
6716* The number of rows of the matrix A. M >= 0.
6717*
6718* N (input) INTEGER
6719* The number of columns of the matrix A. N >= 0.
6720*
6721* MEM (input) integer array, dimension(IPRE+IPOST+LDA*N).
6722* Memory location IPRE elements in front of the matrix A.
6723*
6724* LDA (input) INTEGER
6725* The leading dimension of the array A. LDA >= max(1, M).
6726*
6727* RSRC (input) INTEGER
6728* The process row of the source of the matrix.
6729*
6730* CSRC (input) INTEGER
6731* The process column of the source of the matrix.
6732*
6733* MYROW (input) INTEGER
6734* Row of this process in the process grid.
6735*
6736* MYCOL (input) INTEGER
6737* Column of this process in the process grid.
6738*
6739* IPRE (input) INTEGER
6740* The size of the guard zone before the start of A.
6741*
6742* IPOST (input) INTEGER
6743* The size of guard zone after A.
6744*
6745* CHECKVAL (input) integer
6746* The value to pad matrix with.
6747*
6748* TESTNUM (input) INTEGER
6749* The number of the test being checked.
6750*
6751* MAXERR (input) INTEGER
6752* Max number of errors that can be stored in ERRIBUFF or
6753* ERRIBUFF
6754*
6755* NERR (output) INTEGER
6756* The number of errors that have been found.
6757*
6758* ERRIBUF (output) INTEGER array, dimension (6,MAXERRS)
6759* Buffer in which to store integer error information. It will
6760* be built up in the following format for the call to TSEND.
6761* All integer information is recorded in the following 6-tuple
6762* {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured:
6763* SRC = RSRC * NPROCS + CSRC
6764* DEST = RDEST * NPROCS + CDEST
6765* WHAT
6766* = 1 : Error in pre-padding
6767* = 2 : Error in post-padding
6768* = 3 : Error in LDA-M gap
6769* = 4 : Error in complementory triangle
6770* ELSE: Error in matrix
6771* If there are more errors than can fit in the error buffer,
6772* the error number will indicate the actual number of errors
6773* found, but the buffer will be truncated to the maximum
6774* number of errors which can fit.
6775*
6776* ERRDBUF (output) @(doctype) array, dimension (2, MAXERRS)
6777* Buffer in which to store error data information.
6778* {Incorrect, Predicted}
6779*
6780* ===================================================================
6781*
6782* .. Parameters ..
6783 INTEGER ERR_PRE, ERR_POST, ERR_GAP, ERR_TRI, ERR_MAT
6784 PARAMETER( ERR_PRE = 1, err_post = 2, err_gap = 3, err_tri = 4 )
6785 parameter( err_mat = 5 )
6786* ..
6787* .. External Functions ..
6788 INTEGER IBTNPROCS
6789 EXTERNAL IBTNPROCS
6790* ..
6791* .. Local Scalars ..
6792 LOGICAL ISTRAP
6793 INTEGER I, J, K, IRST, IRND, ICST, ICND, SRC, DEST
6794 INTEGER NPROCS
6795* ..
6796* .. Executable Statements ..
6797*
6798 NPROCS = ibtnprocs()
6799 src = rsrc * nprocs + csrc
6800 dest = myrow * nprocs + mycol
6801*
6802* Check buffer in front of A
6803*
6804 IF( ipre .GT. 0 ) THEN
6805 DO 10 i = 1, ipre
6806 IF( mem(i) .NE. checkval ) THEN
6807 nerr = nerr + 1
6808 IF( nerr .LE. maxerr ) THEN
6809 erribuf(1, nerr) = testnum
6810 erribuf(2, nerr) = src
6811 erribuf(3, nerr) = dest
6812 erribuf(4, nerr) = i
6813 erribuf(5, nerr) = ipre - i + 1
6814 erribuf(6, nerr) = err_pre
6815 errdbuf(1, nerr) = mem(i)
6816 errdbuf(2, nerr) = checkval
6817 END IF
6818 END IF
6819 10 CONTINUE
6820 END IF
6821*
6822* Check buffer behind A
6823*
6824 IF( ipost .GT. 0 ) THEN
6825 j = ipre + lda*n + 1
6826 DO 20 i = j, j+ipost-1
6827 IF( mem(i) .NE. checkval ) THEN
6828 nerr = nerr + 1
6829 IF( nerr .LE. maxerr ) THEN
6830 erribuf(1, nerr) = testnum
6831 erribuf(2, nerr) = src
6832 erribuf(3, nerr) = dest
6833 erribuf(4, nerr) = i - j + 1
6834 erribuf(5, nerr) = j
6835 erribuf(6, nerr) = err_post
6836 errdbuf(1, nerr) = mem(i)
6837 errdbuf(2, nerr) = checkval
6838 END IF
6839 END IF
6840 20 CONTINUE
6841 END IF
6842*
6843* Check all (LDA-M) gaps
6844*
6845 IF( lda .GT. m ) THEN
6846 DO 40 j = 1, n
6847 DO 30 i = m+1, lda
6848 k = ipre + (j-1)*lda + i
6849 IF( mem(k) .NE. checkval) THEN
6850 nerr = nerr + 1
6851 IF( nerr .LE. maxerr ) THEN
6852 erribuf(1, nerr) = testnum
6853 erribuf(2, nerr) = src
6854 erribuf(3, nerr) = dest
6855 erribuf(4, nerr) = i
6856 erribuf(5, nerr) = j
6857 erribuf(6, nerr) = err_gap
6858 errdbuf(1, nerr) = mem(k)
6859 errdbuf(2, nerr) = checkval
6860 END IF
6861 END IF
6862 30 CONTINUE
6863 40 CONTINUE
6864 END IF
6865*
6866* Determine limits of trapezoidal matrix
6867*
6868 istrap = .false.
6869 IF( uplo .EQ. 'U' ) THEN
6870 istrap = .true.
6871 IF( m .LE. n ) THEN
6872 irst = 2
6873 irnd = m
6874 icst = 1
6875 icnd = m - 1
6876 ELSEIF( m .GT. n ) THEN
6877 irst = ( m-n ) + 2
6878 irnd = m
6879 icst = 1
6880 icnd = n - 1
6881 ENDIF
6882 IF( diag .EQ. 'U' ) THEN
6883 irst = irst - 1
6884 icnd = icnd + 1
6885 ENDIF
6886 ELSE IF( uplo .EQ. 'L' ) THEN
6887 istrap = .true.
6888 IF( m .LE. n ) THEN
6889 irst = 1
6890 irnd = 1
6891 icst = ( n-m ) + 2
6892 icnd = n
6893 ELSEIF( m .GT. n ) THEN
6894 irst = 1
6895 irnd = 1
6896 icst = 2
6897 icnd = n
6898 ENDIF
6899 IF( diag .EQ. 'U' ) THEN
6900 icst = icst - 1
6901 ENDIF
6902 ENDIF
6903*
6904* Check elements and report any errors
6905*
6906 IF( istrap ) THEN
6907 DO 100 j = icst, icnd
6908 DO 105 i = irst, irnd
6909 IF( mem( ipre + (j-1)*lda + i ) .NE. checkval ) THEN
6910 nerr = nerr + 1
6911 IF( nerr .LE. maxerr ) THEN
6912 erribuf(1, nerr) = testnum
6913 erribuf(2, nerr) = src
6914 erribuf(3, nerr) = dest
6915 erribuf(4, nerr) = i
6916 erribuf(5, nerr) = j
6917 erribuf(6, nerr) = err_tri
6918 errdbuf(1, nerr) = mem( ipre + (j-1)*lda + i )
6919 errdbuf(2, nerr) = checkval
6920 END IF
6921 END IF
6922 105 CONTINUE
6923*
6924* Update the limits to allow filling in padding
6925*
6926 IF( uplo .EQ. 'U' ) THEN
6927 irst = irst + 1
6928 ELSE
6929 irnd = irnd + 1
6930 ENDIF
6931 100 CONTINUE
6932 END IF
6933*
6934 RETURN
6935*
6936* End of ICHKPAD.
6937*
6938 END
6939*
6940 SUBROUTINE ichkmat( UPLO, DIAG, M, N, A, LDA, RSRC, CSRC,
6941 $ MYROW, MYCOL, TESTNUM, MAXERR, NERR,
6942 $ ERRIBUF, ERRDBUF )
6943*
6944* -- BLACS tester (version 1.0) --
6945* University of Tennessee
6946* December 15, 1994
6947*
6948*
6949* .. Scalar Arguments ..
6950 CHARACTER*1 UPLO, DIAG
6951 INTEGER M, N, LDA, RSRC, CSRC, MYROW, MYCOL, TESTNUM
6952 INTEGER MAXERR, NERR
6953* ..
6954* .. Array Arguments ..
6955 INTEGER ERRIBUF(6, MAXERR)
6956 INTEGER A(LDA,N), ERRDBUF(2, MAXERR)
6957* ..
6958*
6959* Purpose
6960* =======
6961* iCHKMAT: Check matrix to see whether there were any transmission
6962* errors.
6963*
6964* Arguments
6965* =========
6966* UPLO (input) CHARACTER*1
6967* Is the matrix A 'U'pper or 'L'ower trapezoidal, or 'G'eneral
6968* rectangular?
6969*
6970* DIAG (input) CHARACTER*1
6971* For trapezoidal matrices, is the main diagonal included
6972* ('N') or not ('U')?
6973*
6974* M (input) INTEGER
6975* The number of rows of the matrix A. M >= 0.
6976*
6977* N (input) INTEGER
6978* The number of columns of the matrix A. N >= 0.
6979*
6980* A (input) @up@(doctype) array, dimension (LDA,N)
6981* The m by n matrix A. Fortran77 (column-major) storage
6982* assumed.
6983*
6984* LDA (input) INTEGER
6985* The leading dimension of the array A. LDA >= max(1, M).
6986*
6987* RSRC (input) INTEGER
6988* The process row of the source of the matrix.
6989*
6990* CSRC (input) INTEGER
6991* The process column of the source of the matrix.
6992*
6993* MYROW (input) INTEGER
6994* Row of this process in the process grid.
6995*
6996* MYCOL (input) INTEGER
6997* Column of this process in the process grid.
6998*
6999*
7000* TESTNUM (input) INTEGER
7001* The number of the test being checked.
7002*
7003* MAXERR (input) INTEGER
7004* Max number of errors that can be stored in ERRIBUFF or
7005* ERRIBUFF
7006*
7007* NERR (output) INTEGER
7008* The number of errors that have been found.
7009*
7010* ERRIBUF (output) INTEGER array, dimension (6,MAXERRS)
7011* Buffer in which to store integer error information. It will
7012* be built up in the following format for the call to TSEND.
7013* All integer information is recorded in the following 6-tuple
7014* {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured:
7015* SRC = RSRC * NPROCS + CSRC
7016* DEST = RDEST * NPROCS + CDEST
7017* WHAT
7018* = 1 : Error in pre-padding
7019* = 2 : Error in post-padding
7020* = 3 : Error in LDA-M gap
7021* = 4 : Error in complementory triangle
7022* ELSE: Error in matrix
7023* If there are more errors than can fit in the error buffer,
7024* the error number will indicate the actual number of errors
7025* found, but the buffer will be truncated to the maximum
7026* number of errors which can fit.
7027*
7028* ERRDBUF (output) @(doctype) array, dimension (2, MAXERRS)
7029* Buffer in which to store error data information.
7030* {Incorrect, Predicted}
7031*
7032* ===================================================================
7033*
7034* .. Local Scalars ..
7035 INTEGER I, J, NPROCS, SRC, DEST
7036 LOGICAL USEIT
7037 INTEGER COMPVAL
7038* ..
7039* .. Local Arrays ..
7040 INTEGER ISEED(4)
7041* ..
7042* .. External Functions ..
7043 INTEGER IBTNPROCS
7044 INTEGER IBTRAN
7045 EXTERNAL IBTRAN, IBTNPROCS
7046* ..
7047* .. Executable Statements ..
7048*
7049 NPROCS = ibtnprocs()
7050 src = rsrc * nprocs + csrc
7051 dest = myrow * nprocs + mycol
7052*
7053* Initialize ISEED with the same values as used in IGENMAT.
7054*
7055 iseed(1) = mod( 1002 + testnum*5 + src*3, 4096 )
7056 iseed(2) = mod( 2027 + testnum*7 + src, 4096 )
7057 iseed(3) = mod( 1234 + testnum + src*3, 4096 )
7058 iseed(4) = mod( 4311 + testnum*10 + src*2, 4096 )
7059*
7060* Generate the elements randomly with the same method used in GENMAT.
7061* Note that for trapezoidal matrices, we generate all elements in the
7062* enclosing rectangle and then ignore the complementary triangle.
7063*
7064 DO 100 j = 1, n
7065 DO 105 i = 1, m
7066 compval = ibtran( iseed )
7067*
7068* Now determine whether we actually need this value. The
7069* strategy is to chop out the proper triangle based on what
7070* particular kind of trapezoidal matrix we're dealing with.
7071*
7072 useit = .true.
7073 IF( uplo .EQ. 'U' ) THEN
7074 IF( m .LE. n ) THEN
7075 IF( diag .EQ. 'U' ) THEN
7076 IF( i .GE. j ) THEN
7077 useit = .false.
7078 END IF
7079 ELSE
7080 IF( i .GT. j ) THEN
7081 useit = .false.
7082 END IF
7083 END IF
7084 ELSE
7085 IF( diag .EQ. 'U' ) THEN
7086 IF( i .GE. m-n+j ) THEN
7087 useit = .false.
7088 END IF
7089 ELSE
7090 IF( i .GT. m-n+j ) THEN
7091 useit = .false.
7092 END IF
7093 END IF
7094 END IF
7095 ELSE IF( uplo .EQ. 'L' ) THEN
7096 IF( m .LE. n ) THEN
7097 IF( diag .EQ. 'U' ) THEN
7098 IF( j. ge. i+(n-m) ) THEN
7099 useit = .false.
7100 END IF
7101 ELSE
7102 IF( j .GT. i+(n-m) ) THEN
7103 useit = .false.
7104 END IF
7105 END IF
7106 ELSE
7107 IF( diag .EQ. 'U' ) THEN
7108 IF( j .GE. i ) THEN
7109 useit = .false.
7110 END IF
7111 ELSE
7112 IF( j .GT. i ) THEN
7113 useit = .false.
7114 END IF
7115 END IF
7116 END IF
7117 END IF
7118*
7119* Compare the generated value to the one that's in the
7120* received matrix. If they don't match, tack another
7121* error record onto what's already there.
7122*
7123 IF( useit ) THEN
7124 IF( a(i,j) .NE. compval ) THEN
7125 nerr = nerr + 1
7126 IF( nerr .LE. maxerr ) THEN
7127 erribuf(1, nerr) = testnum
7128 erribuf(2, nerr) = src
7129 erribuf(3, nerr) = dest
7130 erribuf(4, nerr) = i
7131 erribuf(5, nerr) = j
7132 erribuf(6, nerr) = 5
7133 errdbuf(1, nerr) = a(i, j)
7134 errdbuf(2, nerr) = compval
7135 END IF
7136 END IF
7137 END IF
7138 105 CONTINUE
7139 100 CONTINUE
7140 RETURN
7141*
7142* End of ICHKMAT.
7143*
7144 END
7145*
7146 SUBROUTINE iprinterrs( OUTNUM, MAXERR, NERR,
7147 $ ERRIBUF, ERRDBUF, COUNTING, TFAILED )
7148*
7149* -- BLACS tester (version 1.0) --
7150* University of Tennessee
7151* December 15, 1994
7152*
7153*
7154* .. Scalar Arguments ..
7155 LOGICAL COUNTING
7156 INTEGER OUTNUM, MAXERR, NERR
7157* ..
7158* .. Array Arguments ..
7159 INTEGER ERRIBUF(6, MAXERR), TFAILED(*)
7160 INTEGER ERRDBUF(2, MAXERR)
7161* ..
7162*
7163* Purpose
7164* =======
7165* IPRINTERRS: Print errors that have been recorded
7166*
7167* Arguments
7168* =========
7169* OUTNUM (input) INTEGER
7170* Device number for output.
7171*
7172* MAXERR (input) INTEGER
7173* Max number of errors that can be stored in ERRIBUFF or
7174* ERRIBUFF
7175*
7176* NERR (output) INTEGER
7177* The number of errors that have been found.
7178*
7179* ERRIBUF (output) INTEGER array, dimension (6,MAXERRS)
7180* Buffer in which to store integer error information. It will
7181* be built up in the following format for the call to TSEND.
7182* All integer information is recorded in the following 6-tuple
7183* {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured:
7184* SRC = RSRC * NPROCS + CSRC
7185* DEST = RDEST * NPROCS + CDEST
7186* WHAT
7187* = 1 : Error in pre-padding
7188* = 2 : Error in post-padding
7189* = 3 : Error in LDA-M gap
7190* = 4 : Error in complementory triangle
7191* ELSE: Error in matrix
7192* If there are more errors than can fit in the error buffer,
7193* the error number will indicate the actual number of errors
7194* found, but the buffer will be truncated to the maximum
7195* number of errors which can fit.
7196*
7197* ERRDBUF (output) @(doctype) array, dimension (2, MAXERRS)
7198* Buffer in which to store error data information.
7199* {Incorrect, Predicted}
7200*
7201* TFAILED (input/ourput) INTEGER array, dimension NTESTS
7202* Workspace used to keep track of which tests failed.
7203* This array not accessed unless COUNTING is true.
7204*
7205* ===================================================================
7206*
7207* .. Parameters ..
7208 INTEGER ERR_PRE, ERR_POST, ERR_GAP, ERR_TRI, ERR_MAT
7209 parameter( err_pre = 1, err_post = 2, err_gap = 3, err_tri = 4 )
7210 parameter( err_mat = 5 )
7211* ..
7212* .. External Functions ..
7213 INTEGER IBTMYPROC, IBTNPROCS
7214 EXTERNAL ibtmyproc, ibtnprocs
7215* ..
7216* .. Local Scalars ..
7217 CHARACTER*1 MAT
7218 LOGICAL MATISINT
7219 INTEGER OLDTEST, NPROCS, PROW, PCOL, I, ERRTYPE
7220* ..
7221* .. Executable Statements ..
7222*
7223 IF( (IBTMYPROC().NE.0) .OR. (NERR.LE.0) ) RETURN
7224 OLDTEST = -1
7225 nprocs = ibtnprocs()
7226 prow = erribuf(3,1) / nprocs
7227 pcol = mod( erribuf(3,1), nprocs )
7228 IF( nerr .GT. maxerr ) WRITE(outnum,13000)
7229*
7230 DO 20 i = 1, min( nerr, maxerr )
7231 IF( erribuf(1,i) .NE. oldtest ) THEN
7232 IF( oldtest .NE. -1 )
7233 $ WRITE(outnum,12000) prow, pcol, oldtest
7234 WRITE(outnum,*) ' '
7235 WRITE(outnum,1000) prow, pcol, erribuf(1,i)
7236 IF( counting ) tfailed( erribuf(1,i) ) = 1
7237 oldtest = erribuf(1, i)
7238 END IF
7239*
7240* Print out error message depending on type of error
7241*
7242 errtype = erribuf(6, i)
7243 IF( errtype .LT. -10 ) THEN
7244 errtype = -errtype - 10
7245 mat = 'C'
7246 matisint = .true.
7247 ELSE IF( errtype .LT. 0 ) THEN
7248 errtype = -errtype
7249 mat = 'R'
7250 matisint = .true.
7251 ELSE
7252 matisint = .false.
7253 END IF
7254*
7255* RA/CA arrays from MAX/MIN have different printing protocol
7256*
7257 IF( matisint ) THEN
7258 IF( erribuf(2, i) .EQ. -1 ) THEN
7259 WRITE(outnum,11000) erribuf(4,i), erribuf(5,i), mat,
7260 $ int( errdbuf(2,i) ), int( errdbuf(1,i) )
7261 ELSE IF( errtype .EQ. err_pre ) THEN
7262 WRITE(outnum,7000) erribuf(5,i), mat,
7263 $ int( errdbuf(2,i) ), int( errdbuf(1,i) )
7264 ELSE IF( errtype .EQ. err_post ) THEN
7265 WRITE(outnum,8000) erribuf(4,i), mat,
7266 $ int( errdbuf(2,i) ), int( errdbuf(1,i) )
7267 ELSE IF( errtype .EQ. err_gap ) THEN
7268 WRITE(outnum,9000) mat, erribuf(4,i), erribuf(5,i),
7269 $ int( errdbuf(2,i) ), int( errdbuf(1,i) )
7270 ELSE
7271 WRITE(outnum,10000) mat, erribuf(4,i), erribuf(5,i),
7272 $ int( errdbuf(2,i) ),
7273 $ int( errdbuf(1,i) )
7274 END IF
7275*
7276* Have memory overwrites in matrix A
7277*
7278 ELSE
7279 IF( errtype .EQ. err_pre ) THEN
7280 WRITE(outnum,2000) erribuf(5,i), errdbuf(2,i),
7281 $ errdbuf(1,i)
7282 ELSE IF( errtype .EQ. err_post ) THEN
7283 WRITE(outnum,3000) erribuf(4,i), errdbuf(2,i),
7284 $ errdbuf(1,i)
7285 ELSE IF( errtype .EQ. err_gap ) THEN
7286 WRITE(outnum,4000) erribuf(4,i), erribuf(5,i),
7287 $ errdbuf(2,i), errdbuf(1,i)
7288 ELSE IF( errtype .EQ. err_tri ) THEN
7289 WRITE(outnum,5000) erribuf(4,i), erribuf(5,i),
7290 $ errdbuf(2,i), errdbuf(1,i)
7291 ELSE
7292 WRITE(outnum,6000) erribuf(4,i), erribuf(5,i),
7293 $ errdbuf(2,i), errdbuf(1,i)
7294 END IF
7295 END IF
7296 20 CONTINUE
7297 WRITE(outnum,12000) prow, pcol, oldtest
7298*
7299 1000 FORMAT('PROCESS {',i4,',',i4,'} REPORTS ERRORS IN TEST#',i6,':')
7300 2000 FORMAT(' Buffer overwrite ',i4,
7301 $ ' elements before the start of A:',/,
7302 $ ' Expected=',i12,
7303 $ '; Received=',i12)
7304 3000 FORMAT(' Buffer overwrite ',i4,' elements after the end of A:',
7305 $ /,' Expected=',i12,
7306 $ '; Received=',i12)
7307 4000 FORMAT(' LDA-M gap overwrite at postion (',i4,',',i4,'):',/,
7308 $ ' Expected=',i12,
7309 $ '; Received=',i12)
7310 5000 FORMAT(' Complementory triangle overwrite at A(',i4,',',i4,
7311 $ '):',/,' Expected=',i12,
7312 $ '; Received=',i12)
7313 6000 FORMAT(' Invalid element at A(',i4,',',i4,'):',/,
7314 $ ' Expected=',i12,
7315 $ '; Received=',i12)
7316 7000 FORMAT(' Buffer overwrite ',i4,' elements before the start of ',
7317 $ a1,'A:',/,' Expected=',i12,'; Received=',i12)
7318 8000 FORMAT(' Buffer overwrite ',i4,' elements after the end of ',
7319 $ a1,'A:',/,' Expected=',i12,'; Received=',i12)
7320*
7321 9000 FORMAT(' LD',a1,'A-M gap overwrite at postion (',i4,',',i4,'):'
7322 $ ,/,' Expected=',i12,'; Received=',i12)
7323*
732410000 FORMAT(' Invalid element at ',a1,'A(',i4,',',i4,'):',/,
7325 $ ' Expected=',i12,'; Received=',i12)
732611000 FORMAT(' Overwrite at position (',i4,',',i4,') of non-existent '
7327 $ ,a1,'A array.',/,' Expected=',i12,'; Received=',i12)
732812000 FORMAT('PROCESS {',i4,',',i4,'} DONE ERROR REPORT FOR TEST#',
7329 $ i6,'.')
733013000 FORMAT('WARNING: There were more errors than could be recorded.',
7331 $ /,'Increase MEMELTS to get complete listing.')
7332 RETURN
7333*
7334* End IPRINTERRS
7335*
7336 END
7337*
7338*
7339 SUBROUTINE sbtcheckin( NFTESTS, OUTNUM, MAXERR, NERR, IERR,
7340 $ SVAL, TFAILED )
7341 INTEGER NFTESTS, OUTNUM, MAXERR, NERR
7342 INTEGER IERR(*), TFAILED(*)
7343 REAL SVAL(*)
7344*
7345* Purpose
7346* =======
7347* SBTCHECKIN: Process 0 receives error report from all processes.
7348*
7349* Arguments
7350* =========
7351* NFTESTS (input/output) INTEGER
7352* if NFTESTS is <= 0 upon entry, NFTESTS is not written to.
7353* Otherwise, on entry it specifies the total number of tests
7354* run, and on exit it is the number of tests which failed.
7355*
7356* OUTNUM (input) INTEGER
7357* Device number for output.
7358*
7359* MAXERR (input) INTEGER
7360* Max number of errors that can be stored in ERRIBUFF or
7361* ERRSBUFF
7362*
7363* NERR (output) INTEGER
7364* The number of errors that have been found.
7365*
7366* ERRIBUF (output) INTEGER array, dimension (6,MAXERRS)
7367* Buffer in which to store integer error information. It will
7368* be built up in the following format for the call to TSEND.
7369* All integer information is recorded in the following 6-tuple
7370* {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured:
7371* SRC = RSRC * NPROCS + CSRC
7372* DEST = RDEST * NPROCS + CDEST
7373* WHAT
7374* = 1 : Error in pre-padding
7375* = 2 : Error in post-padding
7376* = 3 : Error in LDA-M gap
7377* = 4 : Error in complementory triangle
7378* ELSE: Error in matrix
7379* If there are more errors than can fit in the error buffer,
7380* the error number will indicate the actual number of errors
7381* found, but the buffer will be truncated to the maximum
7382* number of errors which can fit.
7383*
7384* ERRDBUF (output) @(doctype) array, dimension (2, MAXERRS)
7385* Buffer in which to store error data information.
7386* {Incorrect, Predicted}
7387*
7388* TFAILED (workspace) INTEGER array, dimension NFTESTS
7389* Workspace used to keep track of which tests failed.
7390* If input of NFTESTS < 1, this array not accessed.
7391*
7392* ===================================================================
7393*
7394* .. External Functions ..
7395 INTEGER IBTMYPROC, IBTNPROCS, IBTMSGID
7396 EXTERNAL ibtmyproc, ibtnprocs, ibtmsgid
7397* ..
7398* .. Local Scalars ..
7399 LOGICAL COUNTING
7400 INTEGER K, NERR2, IAM, NPROCS, NTESTS
7401*
7402* Proc 0 collects error info from everyone
7403*
7404 IAM = ibtmyproc()
7405 nprocs = ibtnprocs()
7406*
7407 IF( iam .EQ. 0 ) THEN
7408*
7409* If we are finding out how many failed tests there are, initialize
7410* the total number of tests (NTESTS), and zero the test failed array
7411*
7412 counting = nftests .GT. 0
7413 IF( counting ) THEN
7414 ntests = nftests
7415 DO 10 k = 1, ntests
7416 tfailed(k) = 0
7417 10 CONTINUE
7418 END IF
7419*
7420 CALL sprinterrs(outnum, maxerr, nerr, ierr, sval, counting,
7421 $ tfailed)
7422*
7423 DO 20 k = 1, nprocs-1
7424 CALL btsend(3, 0, k, k, ibtmsgid()+50)
7425 CALL btrecv(3, 1, nerr2, k, ibtmsgid()+50)
7426 IF( nerr2 .GT. 0 ) THEN
7427 nerr = nerr + nerr2
7428 CALL btrecv(3, nerr2*6, ierr, k, ibtmsgid()+51)
7429 CALL btrecv(4, nerr2*2, sval, k, ibtmsgid()+51)
7430 CALL sprinterrs(outnum, maxerr, nerr2, ierr, sval,
7431 $ counting, tfailed)
7432 END IF
7433 20 CONTINUE
7434*
7435* Count up number of tests that failed
7436*
7437 IF( counting ) THEN
7438 nftests = 0
7439 DO 30 k = 1, ntests
7440 nftests = nftests + tfailed(k)
7441 30 CONTINUE
7442 END IF
7443*
7444* Send my error info to proc 0
7445*
7446 ELSE
7447 CALL btrecv(3, 0, k, 0, ibtmsgid()+50)
7448 CALL btsend(3, 1, nerr, 0, ibtmsgid()+50)
7449 IF( nerr .GT. 0 ) THEN
7450 CALL btsend(3, nerr*6, ierr, 0, ibtmsgid()+51)
7451 CALL btsend(4, nerr*2, sval, 0, ibtmsgid()+51)
7452 END IF
7453 ENDIF
7454*
7455 RETURN
7456*
7457* End of SBTCHECKIN
7458*
7459 END
7460*
7461 SUBROUTINE sinitmat(UPLO, DIAG, M, N, MEM, LDA, IPRE, IPOST,
7462 $ CHECKVAL, TESTNUM, MYROW, MYCOL)
7463 CHARACTER*1 UPLO, DIAG
7464 INTEGER M, N, LDA, IPRE, IPOST, TESTNUM, MYROW, MYCOL
7465 REAL CHECKVAL
7466 REAL MEM(*)
7467*
7468* .. External Subroutines ..
7469 EXTERNAL sgenmat, spadmat
7470* ..
7471* .. Executable Statements ..
7472*
7473 CALL sgenmat( m, n, mem(ipre+1), lda, testnum, myrow, mycol )
7474 CALL spadmat( uplo, diag, m, n, mem, lda, ipre, ipost, checkval )
7475*
7476 RETURN
7477 END
7478*
7479 SUBROUTINE sgenmat( M, N, A, LDA, TESTNUM, MYROW, MYCOL )
7480*
7481* -- BLACS tester (version 1.0) --
7482* University of Tennessee
7483* December 15, 1994
7484*
7485*
7486* .. Scalar Arguments ..
7487 INTEGER M, N, LDA, TESTNUM, MYROW, MYCOL
7488* ..
7489* .. Array Arguments ..
7490 REAL A(LDA,N)
7491* ..
7492*
7493* Purpose
7494* =======
7495* SGENMAT: Generates an M-by-N matrix filled with random elements.
7496*
7497* Arguments
7498* =========
7499* M (input) INTEGER
7500* The number of rows of the matrix A. M >= 0.
7501*
7502* N (input) INTEGER
7503* The number of columns of the matrix A. N >= 0.
7504*
7505* A (output) @up@(doctype) array, dimension (LDA,N)
7506* The m by n matrix A. Fortran77 (column-major) storage
7507* assumed.
7508*
7509* LDA (input) INTEGER
7510* The leading dimension of the array A. LDA >= max(1, M).
7511*
7512* TESTNUM (input) INTEGER
7513* Unique number for this test case, used as a basis for
7514* the random seeds.
7515*
7516* ====================================================================
7517*
7518* .. External Functions ..
7519 INTEGER IBTNPROCS
7520 REAL SBTRAN
7521 EXTERNAL sbtran, ibtnprocs
7522* ..
7523* .. Local Scalars ..
7524 INTEGER I, J, NPROCS, SRC
7525* ..
7526* .. Local Arrays ..
7527 INTEGER ISEED(4)
7528* ..
7529* .. Executable Statements ..
7530*
7531* ISEED's four values must be positive integers less than 4096,
7532* fourth one has to be odd. (see _LARND). Use some goofy
7533* functions to come up with seed values which together should
7534* be unique.
7535*
7536 nprocs = ibtnprocs()
7537 src = myrow * nprocs + mycol
7538 iseed(1) = mod( 1002 + testnum*5 + src*3, 4096 )
7539 iseed(2) = mod( 2027 + testnum*7 + src, 4096 )
7540 iseed(3) = mod( 1234 + testnum + src*3, 4096 )
7541 iseed(4) = mod( 4311 + testnum*10 + src*2, 4096 )
7542*
7543 DO 10 j = 1, n
7544 DO 10 i = 1, m
7545 a(i, j) = sbtran( iseed )
7546 10 CONTINUE
7547*
7548 RETURN
7549*
7550* End of SGENMAT.
7551*
7552 END
7553*
7554 REAL function sbtran(iseed)
7555 INTEGER iseed(*)
7556*
7557* .. External Functions ..
7558 DOUBLE PRECISION dlarnd
7559 EXTERNAL dlarnd
7560* .. Executable Statements ..
7561*
7562 sbtran = real( dlarnd(2, iseed) )
7563*
7564 RETURN
7565*
7566* End of Sbtran
7567*
7568 END
7569*
7570 SUBROUTINE spadmat( UPLO, DIAG, M, N, MEM, LDA, IPRE, IPOST,
7571 $ CHECKVAL )
7572*
7573* -- BLACS tester (version 1.0) --
7574* University of Tennessee
7575* December 15, 1994
7576*
7577* .. Scalar Arguments ..
7578 CHARACTER*1 UPLO, DIAG
7579 INTEGER M, N, LDA, IPRE, IPOST
7580 REAL CHECKVAL
7581* ..
7582* .. Array Arguments ..
7583 REAL MEM( * )
7584* ..
7585*
7586* Purpose
7587* =======
7588*
7589* SPADMAT: Pad Matrix.
7590* This routines surrounds a matrix with a guardzone initialized to the
7591* value CHECKVAL. There are three distinct guardzones:
7592* - A contiguous zone of size IPRE immediately before the start
7593* of the matrix.
7594* - A contiguous zone of size IPOST immedately after the end of the
7595* matrix.
7596* - Interstitial zones within each column of the matrix, in the
7597* elements A( M+1:LDA, J ).
7598*
7599* Arguments
7600* =========
7601* UPLO (input) CHARACTER*1
7602* Is the matrix A 'U'pper or 'L'ower trapezoidal, or 'G'eneral
7603* rectangular?
7604*
7605* DIAG (input) CHARACTER*1
7606* For trapezoidal matrices, is the main diagonal included
7607* ('N') or not ('U')?
7608*
7609* M (input) INTEGER
7610* The number of rows of the matrix A. M >= 0.
7611*
7612* N (input) INTEGER
7613* The number of columns of the matrix A. N >= 0.
7614*
7615* MEM (output) real array, dimension (IPRE+IPOST+LDA*N)
7616* The address IPRE elements ahead of the matrix A you want to
7617* pad, which is then of dimension (LDA,N).
7618*
7619* IPRE (input) INTEGER
7620* The size of the guard zone ahead of the matrix A.
7621*
7622* IPOST (input) INTEGER
7623* The size of the guard zone behind the matrix A.
7624*
7625* CHECKVAL (input) real
7626* The value to insert into the guard zones.
7627*
7628* ====================================================================
7629*
7630* .. Local Scalars ..
7631 INTEGER I, J, K
7632* ..
7633* .. Executable Statements ..
7634*
7635* Put check buffer in front of A
7636*
7637 IF( ipre .GT. 0 ) THEN
7638 DO 10 i = 1, ipre
7639 mem( i ) = checkval
7640 10 CONTINUE
7641 END IF
7642*
7643* Put check buffer in back of A
7644*
7645 IF( ipost .GT. 0 ) THEN
7646 j = ipre + lda*n + 1
7647 DO 20 i = j, j+ipost-1
7648 mem( i ) = checkval
7649 20 CONTINUE
7650 END IF
7651*
7652* Put check buffer in all (LDA-M) gaps
7653*
7654 IF( lda .GT. m ) THEN
7655 k = ipre + m + 1
7656 DO 40 j = 1, n
7657 DO 30 i = k, k+lda-m-1
7658 mem( i ) = checkval
7659 30 CONTINUE
7660 k = k + lda
7661 40 CONTINUE
7662 END IF
7663*
7664* If the matrix is upper or lower trapezoidal, calculate the
7665* additional triangular area which needs to be padded, Each
7666* element referred to is in the Ith row and the Jth column.
7667*
7668 IF( uplo .EQ. 'U' ) THEN
7669 IF( m .LE. n ) THEN
7670 IF( diag .EQ. 'U' ) THEN
7671 DO 41 i = 1, m
7672 DO 42 j = 1, i
7673 k = ipre + i + (j-1)*lda
7674 mem( k ) = checkval
7675 42 CONTINUE
7676 41 CONTINUE
7677 ELSE
7678 DO 43 i = 2, m
7679 DO 44 j = 1, i-1
7680 k = ipre + i + (j-1)*lda
7681 mem( k ) = checkval
7682 44 CONTINUE
7683 43 CONTINUE
7684 END IF
7685 ELSE
7686 IF( diag .EQ. 'U' ) THEN
7687 DO 45 i = m-n+1, m
7688 DO 46 j = 1, i-(m-n)
7689 k = ipre + i + (j-1)*lda
7690 mem( k ) = checkval
7691 46 CONTINUE
7692 45 CONTINUE
7693 ELSE
7694 DO 47 i = m-n+2, m
7695 DO 48 j = 1, i-(m-n)-1
7696 k = ipre + i + (j-1)*lda
7697 mem( k ) = checkval
7698 48 CONTINUE
7699 47 CONTINUE
7700 END IF
7701 END IF
7702 ELSE IF( uplo .EQ. 'L' ) THEN
7703 IF( m .LE. n ) THEN
7704 IF( diag .EQ. 'U' ) THEN
7705 DO 49 i = 1, m
7706 DO 50 j = n-m+i, n
7707 k = ipre + i + (j-1)*lda
7708 mem( k ) = checkval
7709 50 CONTINUE
7710 49 CONTINUE
7711 ELSE
7712 DO 51 i = 1, m-1
7713 DO 52 j = n-m+i+1, n
7714 k = ipre + i + (j-1)*lda
7715 mem( k ) = checkval
7716 52 CONTINUE
7717 51 CONTINUE
7718 END IF
7719 ELSE
7720 IF( uplo .EQ. 'U' ) THEN
7721 DO 53 i = 1, n
7722 DO 54 j = i, n
7723 k = ipre + i + (j-1)*lda
7724 mem( k ) = checkval
7725 54 CONTINUE
7726 53 CONTINUE
7727 ELSE
7728 DO 55 i = 1, n-1
7729 DO 56 j = i+1, n
7730 k = ipre + i + (j-1)*lda
7731 mem( k ) = checkval
7732 56 CONTINUE
7733 55 CONTINUE
7734 END IF
7735 END IF
7736 END IF
7737*
7738* End of SPADMAT.
7739*
7740 RETURN
7741 END
7742*
7743 SUBROUTINE schkpad( UPLO, DIAG, M, N, MEM, LDA, RSRC, CSRC,
7744 $ MYROW, MYCOL, IPRE, IPOST, CHECKVAL,
7745 $ TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF )
7746*
7747* -- BLACS tester (version 1.0) --
7748* University of Tennessee
7749* December 15, 1994
7750*
7751*
7752* .. Scalar Arguments ..
7753 CHARACTER*1 UPLO, DIAG
7754 INTEGER M, N, LDA, RSRC, CSRC, MYROW, MYCOL, IPRE, IPOST
7755 INTEGER TESTNUM, MAXERR, NERR
7756 REAL CHECKVAL
7757* ..
7758* .. Array Arguments ..
7759 INTEGER ERRIBUF(6, MAXERR)
7760 REAL MEM(*), ERRDBUF(2, MAXERR)
7761* ..
7762*
7763* Purpose
7764* =======
7765* SCHKPAD: Check padding put in by PADMAT.
7766* Checks that padding around target matrix has not been overwritten
7767* by the previous point-to-point or broadcast send.
7768*
7769* Arguments
7770* =========
7771* UPLO (input) CHARACTER*1
7772* Is the matrix A 'U'pper or 'L'ower trapezoidal, or 'G'eneral
7773* rectangular?
7774*
7775* DIAG (input) CHARACTER*1
7776* For trapezoidal matrices, is the main diagonal included
7777* ('N') or not ('U')?
7778*
7779* M (input) INTEGER
7780* The number of rows of the matrix A. M >= 0.
7781*
7782* N (input) INTEGER
7783* The number of columns of the matrix A. N >= 0.
7784*
7785* MEM (input) real array, dimension(IPRE+IPOST+LDA*N).
7786* Memory location IPRE elements in front of the matrix A.
7787*
7788* LDA (input) INTEGER
7789* The leading dimension of the array A. LDA >= max(1, M).
7790*
7791* RSRC (input) INTEGER
7792* The process row of the source of the matrix.
7793*
7794* CSRC (input) INTEGER
7795* The process column of the source of the matrix.
7796*
7797* MYROW (input) INTEGER
7798* Row of this process in the process grid.
7799*
7800* MYCOL (input) INTEGER
7801* Column of this process in the process grid.
7802*
7803* IPRE (input) INTEGER
7804* The size of the guard zone before the start of A.
7805*
7806* IPOST (input) INTEGER
7807* The size of guard zone after A.
7808*
7809* CHECKVAL (input) real
7810* The value to pad matrix with.
7811*
7812* TESTNUM (input) INTEGER
7813* The number of the test being checked.
7814*
7815* MAXERR (input) INTEGER
7816* Max number of errors that can be stored in ERRIBUFF or
7817* ERRSBUFF
7818*
7819* NERR (output) INTEGER
7820* The number of errors that have been found.
7821*
7822* ERRIBUF (output) INTEGER array, dimension (6,MAXERRS)
7823* Buffer in which to store integer error information. It will
7824* be built up in the following format for the call to TSEND.
7825* All integer information is recorded in the following 6-tuple
7826* {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured:
7827* SRC = RSRC * NPROCS + CSRC
7828* DEST = RDEST * NPROCS + CDEST
7829* WHAT
7830* = 1 : Error in pre-padding
7831* = 2 : Error in post-padding
7832* = 3 : Error in LDA-M gap
7833* = 4 : Error in complementory triangle
7834* ELSE: Error in matrix
7835* If there are more errors than can fit in the error buffer,
7836* the error number will indicate the actual number of errors
7837* found, but the buffer will be truncated to the maximum
7838* number of errors which can fit.
7839*
7840* ERRDBUF (output) @(doctype) array, dimension (2, MAXERRS)
7841* Buffer in which to store error data information.
7842* {Incorrect, Predicted}
7843*
7844* ===================================================================
7845*
7846* .. Parameters ..
7847 INTEGER ERR_PRE, ERR_POST, ERR_GAP, ERR_TRI, ERR_MAT
7848 PARAMETER( ERR_PRE = 1, err_post = 2, err_gap = 3, err_tri = 4 )
7849 parameter( err_mat = 5 )
7850* ..
7851* .. External Functions ..
7852 INTEGER IBTNPROCS
7853 EXTERNAL IBTNPROCS
7854* ..
7855* .. Local Scalars ..
7856 LOGICAL ISTRAP
7857 INTEGER I, J, K, IRST, IRND, ICST, ICND, SRC, DEST
7858 INTEGER NPROCS
7859* ..
7860* .. Executable Statements ..
7861*
7862 NPROCS = ibtnprocs()
7863 src = rsrc * nprocs + csrc
7864 dest = myrow * nprocs + mycol
7865*
7866* Check buffer in front of A
7867*
7868 IF( ipre .GT. 0 ) THEN
7869 DO 10 i = 1, ipre
7870 IF( mem(i) .NE. checkval ) THEN
7871 nerr = nerr + 1
7872 IF( nerr .LE. maxerr ) THEN
7873 erribuf(1, nerr) = testnum
7874 erribuf(2, nerr) = src
7875 erribuf(3, nerr) = dest
7876 erribuf(4, nerr) = i
7877 erribuf(5, nerr) = ipre - i + 1
7878 erribuf(6, nerr) = err_pre
7879 errdbuf(1, nerr) = mem(i)
7880 errdbuf(2, nerr) = checkval
7881 END IF
7882 END IF
7883 10 CONTINUE
7884 END IF
7885*
7886* Check buffer behind A
7887*
7888 IF( ipost .GT. 0 ) THEN
7889 j = ipre + lda*n + 1
7890 DO 20 i = j, j+ipost-1
7891 IF( mem(i) .NE. checkval ) THEN
7892 nerr = nerr + 1
7893 IF( nerr .LE. maxerr ) THEN
7894 erribuf(1, nerr) = testnum
7895 erribuf(2, nerr) = src
7896 erribuf(3, nerr) = dest
7897 erribuf(4, nerr) = i - j + 1
7898 erribuf(5, nerr) = j
7899 erribuf(6, nerr) = err_post
7900 errdbuf(1, nerr) = mem(i)
7901 errdbuf(2, nerr) = checkval
7902 END IF
7903 END IF
7904 20 CONTINUE
7905 END IF
7906*
7907* Check all (LDA-M) gaps
7908*
7909 IF( lda .GT. m ) THEN
7910 DO 40 j = 1, n
7911 DO 30 i = m+1, lda
7912 k = ipre + (j-1)*lda + i
7913 IF( mem(k) .NE. checkval) THEN
7914 nerr = nerr + 1
7915 IF( nerr .LE. maxerr ) THEN
7916 erribuf(1, nerr) = testnum
7917 erribuf(2, nerr) = src
7918 erribuf(3, nerr) = dest
7919 erribuf(4, nerr) = i
7920 erribuf(5, nerr) = j
7921 erribuf(6, nerr) = err_gap
7922 errdbuf(1, nerr) = mem(k)
7923 errdbuf(2, nerr) = checkval
7924 END IF
7925 END IF
7926 30 CONTINUE
7927 40 CONTINUE
7928 END IF
7929*
7930* Determine limits of trapezoidal matrix
7931*
7932 istrap = .false.
7933 IF( uplo .EQ. 'U' ) THEN
7934 istrap = .true.
7935 IF( m .LE. n ) THEN
7936 irst = 2
7937 irnd = m
7938 icst = 1
7939 icnd = m - 1
7940 ELSEIF( m .GT. n ) THEN
7941 irst = ( m-n ) + 2
7942 irnd = m
7943 icst = 1
7944 icnd = n - 1
7945 ENDIF
7946 IF( diag .EQ. 'U' ) THEN
7947 irst = irst - 1
7948 icnd = icnd + 1
7949 ENDIF
7950 ELSE IF( uplo .EQ. 'L' ) THEN
7951 istrap = .true.
7952 IF( m .LE. n ) THEN
7953 irst = 1
7954 irnd = 1
7955 icst = ( n-m ) + 2
7956 icnd = n
7957 ELSEIF( m .GT. n ) THEN
7958 irst = 1
7959 irnd = 1
7960 icst = 2
7961 icnd = n
7962 ENDIF
7963 IF( diag .EQ. 'U' ) THEN
7964 icst = icst - 1
7965 ENDIF
7966 ENDIF
7967*
7968* Check elements and report any errors
7969*
7970 IF( istrap ) THEN
7971 DO 100 j = icst, icnd
7972 DO 105 i = irst, irnd
7973 IF( mem( ipre + (j-1)*lda + i ) .NE. checkval ) THEN
7974 nerr = nerr + 1
7975 IF( nerr .LE. maxerr ) THEN
7976 erribuf(1, nerr) = testnum
7977 erribuf(2, nerr) = src
7978 erribuf(3, nerr) = dest
7979 erribuf(4, nerr) = i
7980 erribuf(5, nerr) = j
7981 erribuf(6, nerr) = err_tri
7982 errdbuf(1, nerr) = mem( ipre + (j-1)*lda + i )
7983 errdbuf(2, nerr) = checkval
7984 END IF
7985 END IF
7986 105 CONTINUE
7987*
7988* Update the limits to allow filling in padding
7989*
7990 IF( uplo .EQ. 'U' ) THEN
7991 irst = irst + 1
7992 ELSE
7993 irnd = irnd + 1
7994 ENDIF
7995 100 CONTINUE
7996 END IF
7997*
7998 RETURN
7999*
8000* End of SCHKPAD.
8001*
8002 END
8003*
8004 SUBROUTINE schkmat( UPLO, DIAG, M, N, A, LDA, RSRC, CSRC,
8005 $ MYROW, MYCOL, TESTNUM, MAXERR, NERR,
8006 $ ERRIBUF, ERRDBUF )
8007*
8008* -- BLACS tester (version 1.0) --
8009* University of Tennessee
8010* December 15, 1994
8011*
8012*
8013* .. Scalar Arguments ..
8014 CHARACTER*1 UPLO, DIAG
8015 INTEGER M, N, LDA, RSRC, CSRC, MYROW, MYCOL, TESTNUM
8016 INTEGER MAXERR, NERR
8017* ..
8018* .. Array Arguments ..
8019 INTEGER ERRIBUF(6, MAXERR)
8020 REAL A(LDA,N), ERRDBUF(2, MAXERR)
8021* ..
8022*
8023* Purpose
8024* =======
8025* sCHKMAT: Check matrix to see whether there were any transmission
8026* errors.
8027*
8028* Arguments
8029* =========
8030* UPLO (input) CHARACTER*1
8031* Is the matrix A 'U'pper or 'L'ower trapezoidal, or 'G'eneral
8032* rectangular?
8033*
8034* DIAG (input) CHARACTER*1
8035* For trapezoidal matrices, is the main diagonal included
8036* ('N') or not ('U')?
8037*
8038* M (input) INTEGER
8039* The number of rows of the matrix A. M >= 0.
8040*
8041* N (input) INTEGER
8042* The number of columns of the matrix A. N >= 0.
8043*
8044* A (input) @up@(doctype) array, dimension (LDA,N)
8045* The m by n matrix A. Fortran77 (column-major) storage
8046* assumed.
8047*
8048* LDA (input) INTEGER
8049* The leading dimension of the array A. LDA >= max(1, M).
8050*
8051* RSRC (input) INTEGER
8052* The process row of the source of the matrix.
8053*
8054* CSRC (input) INTEGER
8055* The process column of the source of the matrix.
8056*
8057* MYROW (input) INTEGER
8058* Row of this process in the process grid.
8059*
8060* MYCOL (input) INTEGER
8061* Column of this process in the process grid.
8062*
8063*
8064* TESTNUM (input) INTEGER
8065* The number of the test being checked.
8066*
8067* MAXERR (input) INTEGER
8068* Max number of errors that can be stored in ERRIBUFF or
8069* ERRSBUFF
8070*
8071* NERR (output) INTEGER
8072* The number of errors that have been found.
8073*
8074* ERRIBUF (output) INTEGER array, dimension (6,MAXERRS)
8075* Buffer in which to store integer error information. It will
8076* be built up in the following format for the call to TSEND.
8077* All integer information is recorded in the following 6-tuple
8078* {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured:
8079* SRC = RSRC * NPROCS + CSRC
8080* DEST = RDEST * NPROCS + CDEST
8081* WHAT
8082* = 1 : Error in pre-padding
8083* = 2 : Error in post-padding
8084* = 3 : Error in LDA-M gap
8085* = 4 : Error in complementory triangle
8086* ELSE: Error in matrix
8087* If there are more errors than can fit in the error buffer,
8088* the error number will indicate the actual number of errors
8089* found, but the buffer will be truncated to the maximum
8090* number of errors which can fit.
8091*
8092* ERRDBUF (output) @(doctype) array, dimension (2, MAXERRS)
8093* Buffer in which to store error data information.
8094* {Incorrect, Predicted}
8095*
8096* ===================================================================
8097*
8098* .. Local Scalars ..
8099 INTEGER I, J, NPROCS, SRC, DEST
8100 LOGICAL USEIT
8101 REAL COMPVAL
8102* ..
8103* .. Local Arrays ..
8104 INTEGER ISEED(4)
8105* ..
8106* .. External Functions ..
8107 INTEGER IBTNPROCS
8108 REAL SBTRAN
8109 EXTERNAL SBTRAN, IBTNPROCS
8110* ..
8111* .. Executable Statements ..
8112*
8113 NPROCS = ibtnprocs()
8114 src = rsrc * nprocs + csrc
8115 dest = myrow * nprocs + mycol
8116*
8117* Initialize ISEED with the same values as used in SGENMAT.
8118*
8119 iseed(1) = mod( 1002 + testnum*5 + src*3, 4096 )
8120 iseed(2) = mod( 2027 + testnum*7 + src, 4096 )
8121 iseed(3) = mod( 1234 + testnum + src*3, 4096 )
8122 iseed(4) = mod( 4311 + testnum*10 + src*2, 4096 )
8123*
8124* Generate the elements randomly with the same method used in GENMAT.
8125* Note that for trapezoidal matrices, we generate all elements in the
8126* enclosing rectangle and then ignore the complementary triangle.
8127*
8128 DO 100 j = 1, n
8129 DO 105 i = 1, m
8130 compval = sbtran( iseed )
8131*
8132* Now determine whether we actually need this value. The
8133* strategy is to chop out the proper triangle based on what
8134* particular kind of trapezoidal matrix we're dealing with.
8135*
8136 useit = .true.
8137 IF( uplo .EQ. 'U' ) THEN
8138 IF( m .LE. n ) THEN
8139 IF( diag .EQ. 'U' ) THEN
8140 IF( i .GE. j ) THEN
8141 useit = .false.
8142 END IF
8143 ELSE
8144 IF( i .GT. j ) THEN
8145 useit = .false.
8146 END IF
8147 END IF
8148 ELSE
8149 IF( diag .EQ. 'U' ) THEN
8150 IF( i .GE. m-n+j ) THEN
8151 useit = .false.
8152 END IF
8153 ELSE
8154 IF( i .GT. m-n+j ) THEN
8155 useit = .false.
8156 END IF
8157 END IF
8158 END IF
8159 ELSE IF( uplo .EQ. 'L' ) THEN
8160 IF( m .LE. n ) THEN
8161 IF( diag .EQ. 'U' ) THEN
8162 IF( j. ge. i+(n-m) ) THEN
8163 useit = .false.
8164 END IF
8165 ELSE
8166 IF( j .GT. i+(n-m) ) THEN
8167 useit = .false.
8168 END IF
8169 END IF
8170 ELSE
8171 IF( diag .EQ. 'U' ) THEN
8172 IF( j .GE. i ) THEN
8173 useit = .false.
8174 END IF
8175 ELSE
8176 IF( j .GT. i ) THEN
8177 useit = .false.
8178 END IF
8179 END IF
8180 END IF
8181 END IF
8182*
8183* Compare the generated value to the one that's in the
8184* received matrix. If they don't match, tack another
8185* error record onto what's already there.
8186*
8187 IF( useit ) THEN
8188 IF( a(i,j) .NE. compval ) THEN
8189 nerr = nerr + 1
8190 IF( nerr .LE. maxerr ) THEN
8191 erribuf(1, nerr) = testnum
8192 erribuf(2, nerr) = src
8193 erribuf(3, nerr) = dest
8194 erribuf(4, nerr) = i
8195 erribuf(5, nerr) = j
8196 erribuf(6, nerr) = 5
8197 errdbuf(1, nerr) = a(i, j)
8198 errdbuf(2, nerr) = compval
8199 END IF
8200 END IF
8201 END IF
8202 105 CONTINUE
8203 100 CONTINUE
8204 RETURN
8205*
8206* End of SCHKMAT.
8207*
8208 END
8209*
8210 SUBROUTINE sprinterrs( OUTNUM, MAXERR, NERR,
8211 $ ERRIBUF, ERRDBUF, COUNTING, TFAILED )
8212*
8213* -- BLACS tester (version 1.0) --
8214* University of Tennessee
8215* December 15, 1994
8216*
8217*
8218* .. Scalar Arguments ..
8219 LOGICAL COUNTING
8220 INTEGER OUTNUM, MAXERR, NERR
8221* ..
8222* .. Array Arguments ..
8223 INTEGER ERRIBUF(6, MAXERR), TFAILED(*)
8224 REAL ERRDBUF(2, MAXERR)
8225* ..
8226*
8227* Purpose
8228* =======
8229* SPRINTERRS: Print errors that have been recorded
8230*
8231* Arguments
8232* =========
8233* OUTNUM (input) INTEGER
8234* Device number for output.
8235*
8236* MAXERR (input) INTEGER
8237* Max number of errors that can be stored in ERRIBUFF or
8238* ERRSBUFF
8239*
8240* NERR (output) INTEGER
8241* The number of errors that have been found.
8242*
8243* ERRIBUF (output) INTEGER array, dimension (6,MAXERRS)
8244* Buffer in which to store integer error information. It will
8245* be built up in the following format for the call to TSEND.
8246* All integer information is recorded in the following 6-tuple
8247* {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured:
8248* SRC = RSRC * NPROCS + CSRC
8249* DEST = RDEST * NPROCS + CDEST
8250* WHAT
8251* = 1 : Error in pre-padding
8252* = 2 : Error in post-padding
8253* = 3 : Error in LDA-M gap
8254* = 4 : Error in complementory triangle
8255* ELSE: Error in matrix
8256* If there are more errors than can fit in the error buffer,
8257* the error number will indicate the actual number of errors
8258* found, but the buffer will be truncated to the maximum
8259* number of errors which can fit.
8260*
8261* ERRDBUF (output) @(doctype) array, dimension (2, MAXERRS)
8262* Buffer in which to store error data information.
8263* {Incorrect, Predicted}
8264*
8265* TFAILED (input/ourput) INTEGER array, dimension NTESTS
8266* Workspace used to keep track of which tests failed.
8267* This array not accessed unless COUNTING is true.
8268*
8269* ===================================================================
8270*
8271* .. Parameters ..
8272 INTEGER ERR_PRE, ERR_POST, ERR_GAP, ERR_TRI, ERR_MAT
8273 PARAMETER( ERR_PRE = 1, err_post = 2, err_gap = 3, err_tri = 4 )
8274 parameter( err_mat = 5 )
8275* ..
8276* .. External Functions ..
8277 INTEGER IBTMYPROC, IBTNPROCS
8278 EXTERNAL IBTMYPROC, IBTNPROCS
8279* ..
8280* .. Local Scalars ..
8281 CHARACTER*1 MAT
8282 LOGICAL MATISINT
8283 INTEGER OLDTEST, NPROCS, PROW, PCOL, I, ERRTYPE
8284* ..
8285* .. Executable Statements ..
8286*
8287 IF( (ibtmyproc().NE.0) .OR. (nerr.LE.0) ) RETURN
8288 oldtest = -1
8289 nprocs = ibtnprocs()
8290 prow = erribuf(3,1) / nprocs
8291 pcol = mod( erribuf(3,1), nprocs )
8292 IF( nerr .GT. maxerr ) WRITE(outnum,13000)
8293*
8294 DO 20 i = 1, min( nerr, maxerr )
8295 IF( erribuf(1,i) .NE. oldtest ) THEN
8296 IF( oldtest .NE. -1 )
8297 $ WRITE(outnum,12000) prow, pcol, oldtest
8298 WRITE(outnum,*) ' '
8299 WRITE(outnum,1000) prow, pcol, erribuf(1,i)
8300 IF( counting ) tfailed( erribuf(1,i) ) = 1
8301 oldtest = erribuf(1, i)
8302 END IF
8303*
8304* Print out error message depending on type of error
8305*
8306 errtype = erribuf(6, i)
8307 IF( errtype .LT. -10 ) THEN
8308 errtype = -errtype - 10
8309 mat = 'C'
8310 matisint = .true.
8311 ELSE IF( errtype .LT. 0 ) THEN
8312 errtype = -errtype
8313 mat = 'R'
8314 matisint = .true.
8315 ELSE
8316 matisint = .false.
8317 END IF
8318*
8319* RA/CA arrays from MAX/MIN have different printing protocol
8320*
8321 IF( matisint ) THEN
8322 IF( erribuf(2, i) .EQ. -1 ) THEN
8323 WRITE(outnum,11000) erribuf(4,i), erribuf(5,i), mat,
8324 $ int( errdbuf(2,i) ), int( errdbuf(1,i) )
8325 ELSE IF( errtype .EQ. err_pre ) THEN
8326 WRITE(outnum,7000) erribuf(5,i), mat,
8327 $ int( errdbuf(2,i) ), int( errdbuf(1,i) )
8328 ELSE IF( errtype .EQ. err_post ) THEN
8329 WRITE(outnum,8000) erribuf(4,i), mat,
8330 $ int( errdbuf(2,i) ), int( errdbuf(1,i) )
8331 ELSE IF( errtype .EQ. err_gap ) THEN
8332 WRITE(outnum,9000) mat, erribuf(4,i), erribuf(5,i),
8333 $ int( errdbuf(2,i) ), int( errdbuf(1,i) )
8334 ELSE
8335 WRITE(outnum,10000) mat, erribuf(4,i), erribuf(5,i),
8336 $ int( errdbuf(2,i) ),
8337 $ int( errdbuf(1,i) )
8338 END IF
8339*
8340* Have memory overwrites in matrix A
8341*
8342 ELSE
8343 IF( errtype .EQ. err_pre ) THEN
8344 WRITE(outnum,2000) erribuf(5,i), errdbuf(2,i),
8345 $ errdbuf(1,i)
8346 ELSE IF( errtype .EQ. err_post ) THEN
8347 WRITE(outnum,3000) erribuf(4,i), errdbuf(2,i),
8348 $ errdbuf(1,i)
8349 ELSE IF( errtype .EQ. err_gap ) THEN
8350 WRITE(outnum,4000) erribuf(4,i), erribuf(5,i),
8351 $ errdbuf(2,i), errdbuf(1,i)
8352 ELSE IF( errtype .EQ. err_tri ) THEN
8353 WRITE(outnum,5000) erribuf(4,i), erribuf(5,i),
8354 $ errdbuf(2,i), errdbuf(1,i)
8355 ELSE
8356 WRITE(outnum,6000) erribuf(4,i), erribuf(5,i),
8357 $ errdbuf(2,i), errdbuf(1,i)
8358 END IF
8359 END IF
8360 20 CONTINUE
8361 WRITE(outnum,12000) prow, pcol, oldtest
8362*
8363 1000 FORMAT('PROCESS {',i4,',',i4,'} REPORTS ERRORS IN TEST#',i6,':')
8364 2000 FORMAT(' Buffer overwrite ',i4,
8365 $ ' elements before the start of A:',/,
8366 $ ' Expected=',g15.8,
8367 $ '; Received=',g15.8)
8368 3000 FORMAT(' Buffer overwrite ',i4,' elements after the end of A:',
8369 $ /,' Expected=',g15.8,
8370 $ '; Received=',g15.8)
8371 4000 FORMAT(' LDA-M gap overwrite at postion (',i4,',',i4,'):',/,
8372 $ ' Expected=',g15.8,
8373 $ '; Received=',g15.8)
8374 5000 FORMAT(' Complementory triangle overwrite at A(',i4,',',i4,
8375 $ '):',/,' Expected=',g15.8,
8376 $ '; Received=',g15.8)
8377 6000 FORMAT(' Invalid element at A(',i4,',',i4,'):',/,
8378 $ ' Expected=',g15.8,
8379 $ '; Received=',g15.8)
8380 7000 FORMAT(' Buffer overwrite ',i4,' elements before the start of ',
8381 $ a1,'A:',/,' Expected=',i12,'; Received=',i12)
8382 8000 FORMAT(' Buffer overwrite ',i4,' elements after the end of ',
8383 $ a1,'A:',/,' Expected=',i12,'; Received=',i12)
8384*
8385 9000 FORMAT(' LD',a1,'A-M gap overwrite at postion (',i4,',',i4,'):'
8386 $ ,/,' Expected=',i12,'; Received=',i12)
8387*
838810000 FORMAT(' Invalid element at ',a1,'A(',i4,',',i4,'):',/,
8389 $ ' Expected=',i12,'; Received=',i12)
839011000 FORMAT(' Overwrite at position (',i4,',',i4,') of non-existent '
8391 $ ,a1,'A array.',/,' Expected=',i12,'; Received=',i12)
839212000 FORMAT('PROCESS {',i4,',',i4,'} DONE ERROR REPORT FOR TEST#',
8393 $ i6,'.')
839413000 FORMAT('WARNING: There were more errors than could be recorded.',
8395 $ /,'Increase MEMELTS to get complete listing.')
8396 RETURN
8397*
8398* End SPRINTERRS
8399*
8400 END
8401*
8402*
8403 SUBROUTINE dbtcheckin( NFTESTS, OUTNUM, MAXERR, NERR, IERR,
8404 $ DVAL, TFAILED )
8405 INTEGER NFTESTS, OUTNUM, MAXERR, NERR
8406 INTEGER IERR(*), TFAILED(*)
8407 DOUBLE PRECISION DVAL(*)
8408*
8409* Purpose
8410* =======
8411* DBTCHECKIN: Process 0 receives error report from all processes.
8412*
8413* Arguments
8414* =========
8415* NFTESTS (input/output) INTEGER
8416* if NFTESTS is <= 0 upon entry, NFTESTS is not written to.
8417* Otherwise, on entry it specifies the total number of tests
8418* run, and on exit it is the number of tests which failed.
8419*
8420* OUTNUM (input) INTEGER
8421* Device number for output.
8422*
8423* MAXERR (input) INTEGER
8424* Max number of errors that can be stored in ERRIBUFF or
8425* ERRDBUFF
8426*
8427* NERR (output) INTEGER
8428* The number of errors that have been found.
8429*
8430* ERRIBUF (output) INTEGER array, dimension (6,MAXERRS)
8431* Buffer in which to store integer error information. It will
8432* be built up in the following format for the call to TSEND.
8433* All integer information is recorded in the following 6-tuple
8434* {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured:
8435* SRC = RSRC * NPROCS + CSRC
8436* DEST = RDEST * NPROCS + CDEST
8437* WHAT
8438* = 1 : Error in pre-padding
8439* = 2 : Error in post-padding
8440* = 3 : Error in LDA-M gap
8441* = 4 : Error in complementory triangle
8442* ELSE: Error in matrix
8443* If there are more errors than can fit in the error buffer,
8444* the error number will indicate the actual number of errors
8445* found, but the buffer will be truncated to the maximum
8446* number of errors which can fit.
8447*
8448* ERRDBUF (output) @(doctype) array, dimension (2, MAXERRS)
8449* Buffer in which to store error data information.
8450* {Incorrect, Predicted}
8451*
8452* TFAILED (workspace) INTEGER array, dimension NFTESTS
8453* Workspace used to keep track of which tests failed.
8454* If input of NFTESTS < 1, this array not accessed.
8455*
8456* ===================================================================
8457*
8458* .. External Functions ..
8459 INTEGER IBTMYPROC, IBTNPROCS, IBTMSGID
8460 EXTERNAL IBTMYPROC, IBTNPROCS, IBTMSGID
8461* ..
8462* .. Local Scalars ..
8463 LOGICAL COUNTING
8464 INTEGER K, NERR2, IAM, NPROCS, NTESTS
8465*
8466* Proc 0 collects error info from everyone
8467*
8468 iam = ibtmyproc()
8469 nprocs = ibtnprocs()
8470*
8471 IF( iam .EQ. 0 ) THEN
8472*
8473* If we are finding out how many failed tests there are, initialize
8474* the total number of tests (NTESTS), and zero the test failed array
8475*
8476 counting = nftests .GT. 0
8477 IF( counting ) THEN
8478 ntests = nftests
8479 DO 10 k = 1, ntests
8480 tfailed(k) = 0
8481 10 CONTINUE
8482 END IF
8483*
8484 CALL dprinterrs(outnum, maxerr, nerr, ierr, dval, counting,
8485 $ tfailed)
8486*
8487 DO 20 k = 1, nprocs-1
8488 CALL btsend(3, 0, k, k, ibtmsgid()+50)
8489 CALL btrecv(3, 1, nerr2, k, ibtmsgid()+50)
8490 IF( nerr2 .GT. 0 ) THEN
8491 nerr = nerr + nerr2
8492 CALL btrecv(3, nerr2*6, ierr, k, ibtmsgid()+51)
8493 CALL btrecv(6, nerr2*2, dval, k, ibtmsgid()+51)
8494 CALL dprinterrs(outnum, maxerr, nerr2, ierr, dval,
8495 $ counting, tfailed)
8496 END IF
8497 20 CONTINUE
8498*
8499* Count up number of tests that failed
8500*
8501 IF( counting ) THEN
8502 nftests = 0
8503 DO 30 k = 1, ntests
8504 nftests = nftests + tfailed(k)
8505 30 CONTINUE
8506 END IF
8507*
8508* Send my error info to proc 0
8509*
8510 ELSE
8511 CALL btrecv(3, 0, k, 0, ibtmsgid()+50)
8512 CALL btsend(3, 1, nerr, 0, ibtmsgid()+50)
8513 IF( nerr .GT. 0 ) THEN
8514 CALL btsend(3, nerr*6, ierr, 0, ibtmsgid()+51)
8515 CALL btsend(6, nerr*2, dval, 0, ibtmsgid()+51)
8516 END IF
8517 ENDIF
8518*
8519 RETURN
8520*
8521* End of DBTCHECKIN
8522*
8523 END
8524*
8525 SUBROUTINE dinitmat(UPLO, DIAG, M, N, MEM, LDA, IPRE, IPOST,
8526 $ CHECKVAL, TESTNUM, MYROW, MYCOL)
8527 CHARACTER*1 UPLO, DIAG
8528 INTEGER M, N, LDA, IPRE, IPOST, TESTNUM, MYROW, MYCOL
8529 DOUBLE PRECISION CHECKVAL
8530 DOUBLE PRECISION MEM(*)
8531*
8532* .. External Subroutines ..
8533 EXTERNAL dgenmat, dpadmat
8534* ..
8535* .. Executable Statements ..
8536*
8537 CALL dgenmat( m, n, mem(ipre+1), lda, testnum, myrow, mycol )
8538 CALL dpadmat( uplo, diag, m, n, mem, lda, ipre, ipost, checkval )
8539*
8540 RETURN
8541 END
8542*
8543 SUBROUTINE dgenmat( M, N, A, LDA, TESTNUM, MYROW, MYCOL )
8544*
8545* -- BLACS tester (version 1.0) --
8546* University of Tennessee
8547* December 15, 1994
8548*
8549*
8550* .. Scalar Arguments ..
8551 INTEGER M, N, LDA, TESTNUM, MYROW, MYCOL
8552* ..
8553* .. Array Arguments ..
8554 DOUBLE PRECISION A(LDA,N)
8555* ..
8556*
8557* Purpose
8558* =======
8559* DGENMAT: Generates an M-by-N matrix filled with random elements.
8560*
8561* Arguments
8562* =========
8563* M (input) INTEGER
8564* The number of rows of the matrix A. M >= 0.
8565*
8566* N (input) INTEGER
8567* The number of columns of the matrix A. N >= 0.
8568*
8569* A (output) @up@(doctype) array, dimension (LDA,N)
8570* The m by n matrix A. Fortran77 (column-major) storage
8571* assumed.
8572*
8573* LDA (input) INTEGER
8574* The leading dimension of the array A. LDA >= max(1, M).
8575*
8576* TESTNUM (input) INTEGER
8577* Unique number for this test case, used as a basis for
8578* the random seeds.
8579*
8580* ====================================================================
8581*
8582* .. External Functions ..
8583 INTEGER IBTNPROCS
8584 DOUBLE PRECISION DBTRAN
8585 EXTERNAL DBTRAN, IBTNPROCS
8586* ..
8587* .. Local Scalars ..
8588 INTEGER I, J, NPROCS, SRC
8589* ..
8590* .. Local Arrays ..
8591 INTEGER ISEED(4)
8592* ..
8593* .. Executable Statements ..
8594*
8595* ISEED's four values must be positive integers less than 4096,
8596* fourth one has to be odd. (see _LARND). Use some goofy
8597* functions to come up with seed values which together should
8598* be unique.
8599*
8600 nprocs = ibtnprocs()
8601 src = myrow * nprocs + mycol
8602 iseed(1) = mod( 1002 + testnum*5 + src*3, 4096 )
8603 iseed(2) = mod( 2027 + testnum*7 + src, 4096 )
8604 iseed(3) = mod( 1234 + testnum + src*3, 4096 )
8605 iseed(4) = mod( 4311 + testnum*10 + src*2, 4096 )
8606*
8607 DO 10 j = 1, n
8608 DO 10 i = 1, m
8609 a(i, j) = dbtran( iseed )
8610 10 CONTINUE
8611*
8612 RETURN
8613*
8614* End of DGENMAT.
8615*
8616 END
8617*
8618 DOUBLE PRECISION FUNCTION dbtran(ISEED)
8619 INTEGER iseed(*)
8620*
8621* .. External Functions ..
8622 DOUBLE PRECISION dlarnd
8623 EXTERNAL dlarnd
8624* .. Executable Statements ..
8625*
8626 dbtran = dlarnd(2, iseed)
8627*
8628 RETURN
8629*
8630* End of Dbtran
8631*
8632 END
8633*
8634 SUBROUTINE dpadmat( UPLO, DIAG, M, N, MEM, LDA, IPRE, IPOST,
8635 $ CHECKVAL )
8636*
8637* -- BLACS tester (version 1.0) --
8638* University of Tennessee
8639* December 15, 1994
8640*
8641* .. Scalar Arguments ..
8642 CHARACTER*1 UPLO, DIAG
8643 INTEGER M, N, LDA, IPRE, IPOST
8644 DOUBLE PRECISION CHECKVAL
8645* ..
8646* .. Array Arguments ..
8647 DOUBLE PRECISION MEM( * )
8648* ..
8649*
8650* Purpose
8651* =======
8652*
8653* DPADMAT: Pad Matrix.
8654* This routines surrounds a matrix with a guardzone initialized to the
8655* value CHECKVAL. There are three distinct guardzones:
8656* - A contiguous zone of size IPRE immediately before the start
8657* of the matrix.
8658* - A contiguous zone of size IPOST immedately after the end of the
8659* matrix.
8660* - Interstitial zones within each column of the matrix, in the
8661* elements A( M+1:LDA, J ).
8662*
8663* Arguments
8664* =========
8665* UPLO (input) CHARACTER*1
8666* Is the matrix A 'U'pper or 'L'ower trapezoidal, or 'G'eneral
8667* rectangular?
8668*
8669* DIAG (input) CHARACTER*1
8670* For trapezoidal matrices, is the main diagonal included
8671* ('N') or not ('U')?
8672*
8673* M (input) INTEGER
8674* The number of rows of the matrix A. M >= 0.
8675*
8676* N (input) INTEGER
8677* The number of columns of the matrix A. N >= 0.
8678*
8679* MEM (output) double precision array, dimension (IPRE+IPOST+LDA*N)
8680* The address IPRE elements ahead of the matrix A you want to
8681* pad, which is then of dimension (LDA,N).
8682*
8683* IPRE (input) INTEGER
8684* The size of the guard zone ahead of the matrix A.
8685*
8686* IPOST (input) INTEGER
8687* The size of the guard zone behind the matrix A.
8688*
8689* CHECKVAL (input) double precision
8690* The value to insert into the guard zones.
8691*
8692* ====================================================================
8693*
8694* .. Local Scalars ..
8695 INTEGER I, J, K
8696* ..
8697* .. Executable Statements ..
8698*
8699* Put check buffer in front of A
8700*
8701 IF( ipre .GT. 0 ) THEN
8702 DO 10 i = 1, ipre
8703 mem( i ) = checkval
8704 10 CONTINUE
8705 END IF
8706*
8707* Put check buffer in back of A
8708*
8709 IF( ipost .GT. 0 ) THEN
8710 j = ipre + lda*n + 1
8711 DO 20 i = j, j+ipost-1
8712 mem( i ) = checkval
8713 20 CONTINUE
8714 END IF
8715*
8716* Put check buffer in all (LDA-M) gaps
8717*
8718 IF( lda .GT. m ) THEN
8719 k = ipre + m + 1
8720 DO 40 j = 1, n
8721 DO 30 i = k, k+lda-m-1
8722 mem( i ) = checkval
8723 30 CONTINUE
8724 k = k + lda
8725 40 CONTINUE
8726 END IF
8727*
8728* If the matrix is upper or lower trapezoidal, calculate the
8729* additional triangular area which needs to be padded, Each
8730* element referred to is in the Ith row and the Jth column.
8731*
8732 IF( uplo .EQ. 'U' ) THEN
8733 IF( m .LE. n ) THEN
8734 IF( diag .EQ. 'U' ) THEN
8735 DO 41 i = 1, m
8736 DO 42 j = 1, i
8737 k = ipre + i + (j-1)*lda
8738 mem( k ) = checkval
8739 42 CONTINUE
8740 41 CONTINUE
8741 ELSE
8742 DO 43 i = 2, m
8743 DO 44 j = 1, i-1
8744 k = ipre + i + (j-1)*lda
8745 mem( k ) = checkval
8746 44 CONTINUE
8747 43 CONTINUE
8748 END IF
8749 ELSE
8750 IF( diag .EQ. 'U' ) THEN
8751 DO 45 i = m-n+1, m
8752 DO 46 j = 1, i-(m-n)
8753 k = ipre + i + (j-1)*lda
8754 mem( k ) = checkval
8755 46 CONTINUE
8756 45 CONTINUE
8757 ELSE
8758 DO 47 i = m-n+2, m
8759 DO 48 j = 1, i-(m-n)-1
8760 k = ipre + i + (j-1)*lda
8761 mem( k ) = checkval
8762 48 CONTINUE
8763 47 CONTINUE
8764 END IF
8765 END IF
8766 ELSE IF( uplo .EQ. 'L' ) THEN
8767 IF( m .LE. n ) THEN
8768 IF( diag .EQ. 'U' ) THEN
8769 DO 49 i = 1, m
8770 DO 50 j = n-m+i, n
8771 k = ipre + i + (j-1)*lda
8772 mem( k ) = checkval
8773 50 CONTINUE
8774 49 CONTINUE
8775 ELSE
8776 DO 51 i = 1, m-1
8777 DO 52 j = n-m+i+1, n
8778 k = ipre + i + (j-1)*lda
8779 mem( k ) = checkval
8780 52 CONTINUE
8781 51 CONTINUE
8782 END IF
8783 ELSE
8784 IF( uplo .EQ. 'U' ) THEN
8785 DO 53 i = 1, n
8786 DO 54 j = i, n
8787 k = ipre + i + (j-1)*lda
8788 mem( k ) = checkval
8789 54 CONTINUE
8790 53 CONTINUE
8791 ELSE
8792 DO 55 i = 1, n-1
8793 DO 56 j = i+1, n
8794 k = ipre + i + (j-1)*lda
8795 mem( k ) = checkval
8796 56 CONTINUE
8797 55 CONTINUE
8798 END IF
8799 END IF
8800 END IF
8801*
8802* End of DPADMAT.
8803*
8804 RETURN
8805 END
8806*
8807 SUBROUTINE dchkpad( UPLO, DIAG, M, N, MEM, LDA, RSRC, CSRC,
8808 $ MYROW, MYCOL, IPRE, IPOST, CHECKVAL,
8809 $ TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF )
8810*
8811* -- BLACS tester (version 1.0) --
8812* University of Tennessee
8813* December 15, 1994
8814*
8815*
8816* .. Scalar Arguments ..
8817 CHARACTER*1 UPLO, DIAG
8818 INTEGER M, N, LDA, RSRC, CSRC, MYROW, MYCOL, IPRE, IPOST
8819 INTEGER TESTNUM, MAXERR, NERR
8820 DOUBLE PRECISION CHECKVAL
8821* ..
8822* .. Array Arguments ..
8823 INTEGER ERRIBUF(6, MAXERR)
8824 DOUBLE PRECISION MEM(*), ERRDBUF(2, MAXERR)
8825* ..
8826*
8827* Purpose
8828* =======
8829* DCHKPAD: Check padding put in by PADMAT.
8830* Checks that padding around target matrix has not been overwritten
8831* by the previous point-to-point or broadcast send.
8832*
8833* Arguments
8834* =========
8835* UPLO (input) CHARACTER*1
8836* Is the matrix A 'U'pper or 'L'ower trapezoidal, or 'G'eneral
8837* rectangular?
8838*
8839* DIAG (input) CHARACTER*1
8840* For trapezoidal matrices, is the main diagonal included
8841* ('N') or not ('U')?
8842*
8843* M (input) INTEGER
8844* The number of rows of the matrix A. M >= 0.
8845*
8846* N (input) INTEGER
8847* The number of columns of the matrix A. N >= 0.
8848*
8849* MEM (input) double precision array, dimension(IPRE+IPOST+LDA*N).
8850* Memory location IPRE elements in front of the matrix A.
8851*
8852* LDA (input) INTEGER
8853* The leading dimension of the array A. LDA >= max(1, M).
8854*
8855* RSRC (input) INTEGER
8856* The process row of the source of the matrix.
8857*
8858* CSRC (input) INTEGER
8859* The process column of the source of the matrix.
8860*
8861* MYROW (input) INTEGER
8862* Row of this process in the process grid.
8863*
8864* MYCOL (input) INTEGER
8865* Column of this process in the process grid.
8866*
8867* IPRE (input) INTEGER
8868* The size of the guard zone before the start of A.
8869*
8870* IPOST (input) INTEGER
8871* The size of guard zone after A.
8872*
8873* CHECKVAL (input) double precision
8874* The value to pad matrix with.
8875*
8876* TESTNUM (input) INTEGER
8877* The number of the test being checked.
8878*
8879* MAXERR (input) INTEGER
8880* Max number of errors that can be stored in ERRIBUFF or
8881* ERRDBUFF
8882*
8883* NERR (output) INTEGER
8884* The number of errors that have been found.
8885*
8886* ERRIBUF (output) INTEGER array, dimension (6,MAXERRS)
8887* Buffer in which to store integer error information. It will
8888* be built up in the following format for the call to TSEND.
8889* All integer information is recorded in the following 6-tuple
8890* {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured:
8891* SRC = RSRC * NPROCS + CSRC
8892* DEST = RDEST * NPROCS + CDEST
8893* WHAT
8894* = 1 : Error in pre-padding
8895* = 2 : Error in post-padding
8896* = 3 : Error in LDA-M gap
8897* = 4 : Error in complementory triangle
8898* ELSE: Error in matrix
8899* If there are more errors than can fit in the error buffer,
8900* the error number will indicate the actual number of errors
8901* found, but the buffer will be truncated to the maximum
8902* number of errors which can fit.
8903*
8904* ERRDBUF (output) @(doctype) array, dimension (2, MAXERRS)
8905* Buffer in which to store error data information.
8906* {Incorrect, Predicted}
8907*
8908* ===================================================================
8909*
8910* .. Parameters ..
8911 INTEGER ERR_PRE, ERR_POST, ERR_GAP, ERR_TRI, ERR_MAT
8912 PARAMETER( ERR_PRE = 1, err_post = 2, err_gap = 3, err_tri = 4 )
8913 parameter( err_mat = 5 )
8914* ..
8915* .. External Functions ..
8916 INTEGER IBTNPROCS
8917 EXTERNAL IBTNPROCS
8918* ..
8919* .. Local Scalars ..
8920 LOGICAL ISTRAP
8921 INTEGER I, J, K, IRST, IRND, ICST, ICND, SRC, DEST
8922 INTEGER NPROCS
8923* ..
8924* .. Executable Statements ..
8925*
8926 NPROCS = ibtnprocs()
8927 src = rsrc * nprocs + csrc
8928 dest = myrow * nprocs + mycol
8929*
8930* Check buffer in front of A
8931*
8932 IF( ipre .GT. 0 ) THEN
8933 DO 10 i = 1, ipre
8934 IF( mem(i) .NE. checkval ) THEN
8935 nerr = nerr + 1
8936 IF( nerr .LE. maxerr ) THEN
8937 erribuf(1, nerr) = testnum
8938 erribuf(2, nerr) = src
8939 erribuf(3, nerr) = dest
8940 erribuf(4, nerr) = i
8941 erribuf(5, nerr) = ipre - i + 1
8942 erribuf(6, nerr) = err_pre
8943 errdbuf(1, nerr) = mem(i)
8944 errdbuf(2, nerr) = checkval
8945 END IF
8946 END IF
8947 10 CONTINUE
8948 END IF
8949*
8950* Check buffer behind A
8951*
8952 IF( ipost .GT. 0 ) THEN
8953 j = ipre + lda*n + 1
8954 DO 20 i = j, j+ipost-1
8955 IF( mem(i) .NE. checkval ) THEN
8956 nerr = nerr + 1
8957 IF( nerr .LE. maxerr ) THEN
8958 erribuf(1, nerr) = testnum
8959 erribuf(2, nerr) = src
8960 erribuf(3, nerr) = dest
8961 erribuf(4, nerr) = i - j + 1
8962 erribuf(5, nerr) = j
8963 erribuf(6, nerr) = err_post
8964 errdbuf(1, nerr) = mem(i)
8965 errdbuf(2, nerr) = checkval
8966 END IF
8967 END IF
8968 20 CONTINUE
8969 END IF
8970*
8971* Check all (LDA-M) gaps
8972*
8973 IF( lda .GT. m ) THEN
8974 DO 40 j = 1, n
8975 DO 30 i = m+1, lda
8976 k = ipre + (j-1)*lda + i
8977 IF( mem(k) .NE. checkval) THEN
8978 nerr = nerr + 1
8979 IF( nerr .LE. maxerr ) THEN
8980 erribuf(1, nerr) = testnum
8981 erribuf(2, nerr) = src
8982 erribuf(3, nerr) = dest
8983 erribuf(4, nerr) = i
8984 erribuf(5, nerr) = j
8985 erribuf(6, nerr) = err_gap
8986 errdbuf(1, nerr) = mem(k)
8987 errdbuf(2, nerr) = checkval
8988 END IF
8989 END IF
8990 30 CONTINUE
8991 40 CONTINUE
8992 END IF
8993*
8994* Determine limits of trapezoidal matrix
8995*
8996 istrap = .false.
8997 IF( uplo .EQ. 'U' ) THEN
8998 istrap = .true.
8999 IF( m .LE. n ) THEN
9000 irst = 2
9001 irnd = m
9002 icst = 1
9003 icnd = m - 1
9004 ELSEIF( m .GT. n ) THEN
9005 irst = ( m-n ) + 2
9006 irnd = m
9007 icst = 1
9008 icnd = n - 1
9009 ENDIF
9010 IF( diag .EQ. 'U' ) THEN
9011 irst = irst - 1
9012 icnd = icnd + 1
9013 ENDIF
9014 ELSE IF( uplo .EQ. 'L' ) THEN
9015 istrap = .true.
9016 IF( m .LE. n ) THEN
9017 irst = 1
9018 irnd = 1
9019 icst = ( n-m ) + 2
9020 icnd = n
9021 ELSEIF( m .GT. n ) THEN
9022 irst = 1
9023 irnd = 1
9024 icst = 2
9025 icnd = n
9026 ENDIF
9027 IF( diag .EQ. 'U' ) THEN
9028 icst = icst - 1
9029 ENDIF
9030 ENDIF
9031*
9032* Check elements and report any errors
9033*
9034 IF( istrap ) THEN
9035 DO 100 j = icst, icnd
9036 DO 105 i = irst, irnd
9037 IF( mem( ipre + (j-1)*lda + i ) .NE. checkval ) THEN
9038 nerr = nerr + 1
9039 IF( nerr .LE. maxerr ) THEN
9040 erribuf(1, nerr) = testnum
9041 erribuf(2, nerr) = src
9042 erribuf(3, nerr) = dest
9043 erribuf(4, nerr) = i
9044 erribuf(5, nerr) = j
9045 erribuf(6, nerr) = err_tri
9046 errdbuf(1, nerr) = mem( ipre + (j-1)*lda + i )
9047 errdbuf(2, nerr) = checkval
9048 END IF
9049 END IF
9050 105 CONTINUE
9051*
9052* Update the limits to allow filling in padding
9053*
9054 IF( uplo .EQ. 'U' ) THEN
9055 irst = irst + 1
9056 ELSE
9057 irnd = irnd + 1
9058 ENDIF
9059 100 CONTINUE
9060 END IF
9061*
9062 RETURN
9063*
9064* End of DCHKPAD.
9065*
9066 END
9067*
9068 SUBROUTINE dchkmat( UPLO, DIAG, M, N, A, LDA, RSRC, CSRC,
9069 $ MYROW, MYCOL, TESTNUM, MAXERR, NERR,
9070 $ ERRIBUF, ERRDBUF )
9071*
9072* -- BLACS tester (version 1.0) --
9073* University of Tennessee
9074* December 15, 1994
9075*
9076*
9077* .. Scalar Arguments ..
9078 CHARACTER*1 UPLO, DIAG
9079 INTEGER M, N, LDA, RSRC, CSRC, MYROW, MYCOL, TESTNUM
9080 INTEGER MAXERR, NERR
9081* ..
9082* .. Array Arguments ..
9083 INTEGER ERRIBUF(6, MAXERR)
9084 DOUBLE PRECISION A(LDA,N), ERRDBUF(2, MAXERR)
9085* ..
9086*
9087* Purpose
9088* =======
9089* dCHKMAT: Check matrix to see whether there were any transmission
9090* errors.
9091*
9092* Arguments
9093* =========
9094* UPLO (input) CHARACTER*1
9095* Is the matrix A 'U'pper or 'L'ower trapezoidal, or 'G'eneral
9096* rectangular?
9097*
9098* DIAG (input) CHARACTER*1
9099* For trapezoidal matrices, is the main diagonal included
9100* ('N') or not ('U')?
9101*
9102* M (input) INTEGER
9103* The number of rows of the matrix A. M >= 0.
9104*
9105* N (input) INTEGER
9106* The number of columns of the matrix A. N >= 0.
9107*
9108* A (input) @up@(doctype) array, dimension (LDA,N)
9109* The m by n matrix A. Fortran77 (column-major) storage
9110* assumed.
9111*
9112* LDA (input) INTEGER
9113* The leading dimension of the array A. LDA >= max(1, M).
9114*
9115* RSRC (input) INTEGER
9116* The process row of the source of the matrix.
9117*
9118* CSRC (input) INTEGER
9119* The process column of the source of the matrix.
9120*
9121* MYROW (input) INTEGER
9122* Row of this process in the process grid.
9123*
9124* MYCOL (input) INTEGER
9125* Column of this process in the process grid.
9126*
9127*
9128* TESTNUM (input) INTEGER
9129* The number of the test being checked.
9130*
9131* MAXERR (input) INTEGER
9132* Max number of errors that can be stored in ERRIBUFF or
9133* ERRDBUFF
9134*
9135* NERR (output) INTEGER
9136* The number of errors that have been found.
9137*
9138* ERRIBUF (output) INTEGER array, dimension (6,MAXERRS)
9139* Buffer in which to store integer error information. It will
9140* be built up in the following format for the call to TSEND.
9141* All integer information is recorded in the following 6-tuple
9142* {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured:
9143* SRC = RSRC * NPROCS + CSRC
9144* DEST = RDEST * NPROCS + CDEST
9145* WHAT
9146* = 1 : Error in pre-padding
9147* = 2 : Error in post-padding
9148* = 3 : Error in LDA-M gap
9149* = 4 : Error in complementory triangle
9150* ELSE: Error in matrix
9151* If there are more errors than can fit in the error buffer,
9152* the error number will indicate the actual number of errors
9153* found, but the buffer will be truncated to the maximum
9154* number of errors which can fit.
9155*
9156* ERRDBUF (output) @(doctype) array, dimension (2, MAXERRS)
9157* Buffer in which to store error data information.
9158* {Incorrect, Predicted}
9159*
9160* ===================================================================
9161*
9162* .. Local Scalars ..
9163 INTEGER I, J, NPROCS, SRC, DEST
9164 LOGICAL USEIT
9165 DOUBLE PRECISION COMPVAL
9166* ..
9167* .. Local Arrays ..
9168 INTEGER ISEED(4)
9169* ..
9170* .. External Functions ..
9171 INTEGER IBTNPROCS
9172 DOUBLE PRECISION DBTRAN
9173 EXTERNAL DBTRAN, IBTNPROCS
9174* ..
9175* .. Executable Statements ..
9176*
9177 NPROCS = ibtnprocs()
9178 src = rsrc * nprocs + csrc
9179 dest = myrow * nprocs + mycol
9180*
9181* Initialize ISEED with the same values as used in DGENMAT.
9182*
9183 iseed(1) = mod( 1002 + testnum*5 + src*3, 4096 )
9184 iseed(2) = mod( 2027 + testnum*7 + src, 4096 )
9185 iseed(3) = mod( 1234 + testnum + src*3, 4096 )
9186 iseed(4) = mod( 4311 + testnum*10 + src*2, 4096 )
9187*
9188* Generate the elements randomly with the same method used in GENMAT.
9189* Note that for trapezoidal matrices, we generate all elements in the
9190* enclosing rectangle and then ignore the complementary triangle.
9191*
9192 DO 100 j = 1, n
9193 DO 105 i = 1, m
9194 compval = dbtran( iseed )
9195*
9196* Now determine whether we actually need this value. The
9197* strategy is to chop out the proper triangle based on what
9198* particular kind of trapezoidal matrix we're dealing with.
9199*
9200 useit = .true.
9201 IF( uplo .EQ. 'U' ) THEN
9202 IF( m .LE. n ) THEN
9203 IF( diag .EQ. 'U' ) THEN
9204 IF( i .GE. j ) THEN
9205 useit = .false.
9206 END IF
9207 ELSE
9208 IF( i .GT. j ) THEN
9209 useit = .false.
9210 END IF
9211 END IF
9212 ELSE
9213 IF( diag .EQ. 'U' ) THEN
9214 IF( i .GE. m-n+j ) THEN
9215 useit = .false.
9216 END IF
9217 ELSE
9218 IF( i .GT. m-n+j ) THEN
9219 useit = .false.
9220 END IF
9221 END IF
9222 END IF
9223 ELSE IF( uplo .EQ. 'L' ) THEN
9224 IF( m .LE. n ) THEN
9225 IF( diag .EQ. 'U' ) THEN
9226 IF( j. ge. i+(n-m) ) THEN
9227 useit = .false.
9228 END IF
9229 ELSE
9230 IF( j .GT. i+(n-m) ) THEN
9231 useit = .false.
9232 END IF
9233 END IF
9234 ELSE
9235 IF( diag .EQ. 'U' ) THEN
9236 IF( j .GE. i ) THEN
9237 useit = .false.
9238 END IF
9239 ELSE
9240 IF( j .GT. i ) THEN
9241 useit = .false.
9242 END IF
9243 END IF
9244 END IF
9245 END IF
9246*
9247* Compare the generated value to the one that's in the
9248* received matrix. If they don't match, tack another
9249* error record onto what's already there.
9250*
9251 IF( useit ) THEN
9252 IF( a(i,j) .NE. compval ) THEN
9253 nerr = nerr + 1
9254 IF( nerr .LE. maxerr ) THEN
9255 erribuf(1, nerr) = testnum
9256 erribuf(2, nerr) = src
9257 erribuf(3, nerr) = dest
9258 erribuf(4, nerr) = i
9259 erribuf(5, nerr) = j
9260 erribuf(6, nerr) = 5
9261 errdbuf(1, nerr) = a(i, j)
9262 errdbuf(2, nerr) = compval
9263 END IF
9264 END IF
9265 END IF
9266 105 CONTINUE
9267 100 CONTINUE
9268 RETURN
9269*
9270* End of DCHKMAT.
9271*
9272 END
9273*
9274 SUBROUTINE dprinterrs( OUTNUM, MAXERR, NERR,
9275 $ ERRIBUF, ERRDBUF, COUNTING, TFAILED )
9276*
9277* -- BLACS tester (version 1.0) --
9278* University of Tennessee
9279* December 15, 1994
9280*
9281*
9282* .. Scalar Arguments ..
9283 LOGICAL COUNTING
9284 INTEGER OUTNUM, MAXERR, NERR
9285* ..
9286* .. Array Arguments ..
9287 INTEGER ERRIBUF(6, MAXERR), TFAILED(*)
9288 DOUBLE PRECISION ERRDBUF(2, MAXERR)
9289* ..
9290*
9291* Purpose
9292* =======
9293* DPRINTERRS: Print errors that have been recorded
9294*
9295* Arguments
9296* =========
9297* OUTNUM (input) INTEGER
9298* Device number for output.
9299*
9300* MAXERR (input) INTEGER
9301* Max number of errors that can be stored in ERRIBUFF or
9302* ERRDBUFF
9303*
9304* NERR (output) INTEGER
9305* The number of errors that have been found.
9306*
9307* ERRIBUF (output) INTEGER array, dimension (6,MAXERRS)
9308* Buffer in which to store integer error information. It will
9309* be built up in the following format for the call to TSEND.
9310* All integer information is recorded in the following 6-tuple
9311* {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured:
9312* SRC = RSRC * NPROCS + CSRC
9313* DEST = RDEST * NPROCS + CDEST
9314* WHAT
9315* = 1 : Error in pre-padding
9316* = 2 : Error in post-padding
9317* = 3 : Error in LDA-M gap
9318* = 4 : Error in complementory triangle
9319* ELSE: Error in matrix
9320* If there are more errors than can fit in the error buffer,
9321* the error number will indicate the actual number of errors
9322* found, but the buffer will be truncated to the maximum
9323* number of errors which can fit.
9324*
9325* ERRDBUF (output) @(doctype) array, dimension (2, MAXERRS)
9326* Buffer in which to store error data information.
9327* {Incorrect, Predicted}
9328*
9329* TFAILED (input/ourput) INTEGER array, dimension NTESTS
9330* Workspace used to keep track of which tests failed.
9331* This array not accessed unless COUNTING is true.
9332*
9333* ===================================================================
9334*
9335* .. Parameters ..
9336 INTEGER ERR_PRE, ERR_POST, ERR_GAP, ERR_TRI, ERR_MAT
9337 parameter( err_pre = 1, err_post = 2, err_gap = 3, err_tri = 4 )
9338 parameter( err_mat = 5 )
9339* ..
9340* .. External Functions ..
9341 INTEGER IBTMYPROC, IBTNPROCS
9342 EXTERNAL ibtmyproc, ibtnprocs
9343* ..
9344* .. Local Scalars ..
9345 CHARACTER*1 MAT
9346 LOGICAL MATISINT
9347 INTEGER OLDTEST, NPROCS, PROW, PCOL, I, ERRTYPE
9348* ..
9349* .. Executable Statements ..
9350*
9351 IF( (IBTMYPROC().NE.0) .OR. (NERR.LE.0) ) RETURN
9352 OLDTEST = -1
9353 nprocs = ibtnprocs()
9354 prow = erribuf(3,1) / nprocs
9355 pcol = mod( erribuf(3,1), nprocs )
9356 IF( nerr .GT. maxerr ) WRITE(outnum,13000)
9357*
9358 DO 20 i = 1, min( nerr, maxerr )
9359 IF( erribuf(1,i) .NE. oldtest ) THEN
9360 IF( oldtest .NE. -1 )
9361 $ WRITE(outnum,12000) prow, pcol, oldtest
9362 WRITE(outnum,*) ' '
9363 WRITE(outnum,1000) prow, pcol, erribuf(1,i)
9364 IF( counting ) tfailed( erribuf(1,i) ) = 1
9365 oldtest = erribuf(1, i)
9366 END IF
9367*
9368* Print out error message depending on type of error
9369*
9370 errtype = erribuf(6, i)
9371 IF( errtype .LT. -10 ) THEN
9372 errtype = -errtype - 10
9373 mat = 'C'
9374 matisint = .true.
9375 ELSE IF( errtype .LT. 0 ) THEN
9376 errtype = -errtype
9377 mat = 'R'
9378 matisint = .true.
9379 ELSE
9380 matisint = .false.
9381 END IF
9382*
9383* RA/CA arrays from MAX/MIN have different printing protocol
9384*
9385 IF( matisint ) THEN
9386 IF( erribuf(2, i) .EQ. -1 ) THEN
9387 WRITE(outnum,11000) erribuf(4,i), erribuf(5,i), mat,
9388 $ int( errdbuf(2,i) ), int( errdbuf(1,i) )
9389 ELSE IF( errtype .EQ. err_pre ) THEN
9390 WRITE(outnum,7000) erribuf(5,i), mat,
9391 $ int( errdbuf(2,i) ), int( errdbuf(1,i) )
9392 ELSE IF( errtype .EQ. err_post ) THEN
9393 WRITE(outnum,8000) erribuf(4,i), mat,
9394 $ int( errdbuf(2,i) ), int( errdbuf(1,i) )
9395 ELSE IF( errtype .EQ. err_gap ) THEN
9396 WRITE(outnum,9000) mat, erribuf(4,i), erribuf(5,i),
9397 $ int( errdbuf(2,i) ), int( errdbuf(1,i) )
9398 ELSE
9399 WRITE(outnum,10000) mat, erribuf(4,i), erribuf(5,i),
9400 $ int( errdbuf(2,i) ),
9401 $ int( errdbuf(1,i) )
9402 END IF
9403*
9404* Have memory overwrites in matrix A
9405*
9406 ELSE
9407 IF( errtype .EQ. err_pre ) THEN
9408 WRITE(outnum,2000) erribuf(5,i), errdbuf(2,i),
9409 $ errdbuf(1,i)
9410 ELSE IF( errtype .EQ. err_post ) THEN
9411 WRITE(outnum,3000) erribuf(4,i), errdbuf(2,i),
9412 $ errdbuf(1,i)
9413 ELSE IF( errtype .EQ. err_gap ) THEN
9414 WRITE(outnum,4000) erribuf(4,i), erribuf(5,i),
9415 $ errdbuf(2,i), errdbuf(1,i)
9416 ELSE IF( errtype .EQ. err_tri ) THEN
9417 WRITE(outnum,5000) erribuf(4,i), erribuf(5,i),
9418 $ errdbuf(2,i), errdbuf(1,i)
9419 ELSE
9420 WRITE(outnum,6000) erribuf(4,i), erribuf(5,i),
9421 $ errdbuf(2,i), errdbuf(1,i)
9422 END IF
9423 END IF
9424 20 CONTINUE
9425 WRITE(outnum,12000) prow, pcol, oldtest
9426*
9427 1000 FORMAT('PROCESS {',i4,',',i4,'} REPORTS ERRORS IN TEST#',i6,':')
9428 2000 FORMAT(' Buffer overwrite ',i4,
9429 $ ' elements before the start of A:',/,
9430 $ ' Expected=',g22.15,
9431 $ '; Received=',g22.15)
9432 3000 FORMAT(' Buffer overwrite ',i4,' elements after the end of A:',
9433 $ /,' Expected=',g22.15,
9434 $ '; Received=',g22.15)
9435 4000 FORMAT(' LDA-M gap overwrite at postion (',i4,',',i4,'):',/,
9436 $ ' Expected=',g22.15,
9437 $ '; Received=',g22.15)
9438 5000 FORMAT(' Complementory triangle overwrite at A(',i4,',',i4,
9439 $ '):',/,' Expected=',g22.15,
9440 $ '; Received=',g22.15)
9441 6000 FORMAT(' Invalid element at A(',i4,',',i4,'):',/,
9442 $ ' Expected=',g22.15,
9443 $ '; Received=',g22.15)
9444 7000 FORMAT(' Buffer overwrite ',i4,' elements before the start of ',
9445 $ a1,'A:',/,' Expected=',i12,'; Received=',i12)
9446 8000 FORMAT(' Buffer overwrite ',i4,' elements after the end of ',
9447 $ a1,'A:',/,' Expected=',i12,'; Received=',i12)
9448*
9449 9000 FORMAT(' LD',a1,'A-M gap overwrite at postion (',i4,',',i4,'):'
9450 $ ,/,' Expected=',i12,'; Received=',i12)
9451*
945210000 FORMAT(' Invalid element at ',a1,'A(',i4,',',i4,'):',/,
9453 $ ' Expected=',i12,'; Received=',i12)
945411000 FORMAT(' Overwrite at position (',i4,',',i4,') of non-existent '
9455 $ ,a1,'A array.',/,' Expected=',i12,'; Received=',i12)
945612000 FORMAT('PROCESS {',i4,',',i4,'} DONE ERROR REPORT FOR TEST#',
9457 $ i6,'.')
945813000 FORMAT('WARNING: There were more errors than could be recorded.',
9459 $ /,'Increase MEMELTS to get complete listing.')
9460 RETURN
9461*
9462* End DPRINTERRS
9463*
9464 END
9465*
9466*
9467 SUBROUTINE cbtcheckin( NFTESTS, OUTNUM, MAXERR, NERR, IERR,
9468 $ CVAL, TFAILED )
9469 INTEGER NFTESTS, OUTNUM, MAXERR, NERR
9470 INTEGER IERR(*), TFAILED(*)
9471 COMPLEX CVAL(*)
9472*
9473* Purpose
9474* =======
9475* CBTCHECKIN: Process 0 receives error report from all processes.
9476*
9477* Arguments
9478* =========
9479* NFTESTS (input/output) INTEGER
9480* if NFTESTS is <= 0 upon entry, NFTESTS is not written to.
9481* Otherwise, on entry it specifies the total number of tests
9482* run, and on exit it is the number of tests which failed.
9483*
9484* OUTNUM (input) INTEGER
9485* Device number for output.
9486*
9487* MAXERR (input) INTEGER
9488* Max number of errors that can be stored in ERRIBUFF or
9489* ERRCBUFF
9490*
9491* NERR (output) INTEGER
9492* The number of errors that have been found.
9493*
9494* ERRIBUF (output) INTEGER array, dimension (6,MAXERRS)
9495* Buffer in which to store integer error information. It will
9496* be built up in the following format for the call to TSEND.
9497* All integer information is recorded in the following 6-tuple
9498* {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured:
9499* SRC = RSRC * NPROCS + CSRC
9500* DEST = RDEST * NPROCS + CDEST
9501* WHAT
9502* = 1 : Error in pre-padding
9503* = 2 : Error in post-padding
9504* = 3 : Error in LDA-M gap
9505* = 4 : Error in complementory triangle
9506* ELSE: Error in matrix
9507* If there are more errors than can fit in the error buffer,
9508* the error number will indicate the actual number of errors
9509* found, but the buffer will be truncated to the maximum
9510* number of errors which can fit.
9511*
9512* ERRDBUF (output) @(doctype) array, dimension (2, MAXERRS)
9513* Buffer in which to store error data information.
9514* {Incorrect, Predicted}
9515*
9516* TFAILED (workspace) INTEGER array, dimension NFTESTS
9517* Workspace used to keep track of which tests failed.
9518* If input of NFTESTS < 1, this array not accessed.
9519*
9520* ===================================================================
9521*
9522* .. External Functions ..
9523 INTEGER IBTMYPROC, IBTNPROCS, IBTMSGID
9524 EXTERNAL IBTMYPROC, IBTNPROCS, IBTMSGID
9525* ..
9526* .. Local Scalars ..
9527 LOGICAL COUNTING
9528 INTEGER K, NERR2, IAM, NPROCS, NTESTS
9529*
9530* Proc 0 collects error info from everyone
9531*
9532 iam = ibtmyproc()
9533 nprocs = ibtnprocs()
9534*
9535 IF( iam .EQ. 0 ) THEN
9536*
9537* If we are finding out how many failed tests there are, initialize
9538* the total number of tests (NTESTS), and zero the test failed array
9539*
9540 counting = nftests .GT. 0
9541 IF( counting ) THEN
9542 ntests = nftests
9543 DO 10 k = 1, ntests
9544 tfailed(k) = 0
9545 10 CONTINUE
9546 END IF
9547*
9548 CALL cprinterrs(outnum, maxerr, nerr, ierr, cval, counting,
9549 $ tfailed)
9550*
9551 DO 20 k = 1, nprocs-1
9552 CALL btsend(3, 0, k, k, ibtmsgid()+50)
9553 CALL btrecv(3, 1, nerr2, k, ibtmsgid()+50)
9554 IF( nerr2 .GT. 0 ) THEN
9555 nerr = nerr + nerr2
9556 CALL btrecv(3, nerr2*6, ierr, k, ibtmsgid()+51)
9557 CALL btrecv(5, nerr2*2, cval, k, ibtmsgid()+51)
9558 CALL cprinterrs(outnum, maxerr, nerr2, ierr, cval,
9559 $ counting, tfailed)
9560 END IF
9561 20 CONTINUE
9562*
9563* Count up number of tests that failed
9564*
9565 IF( counting ) THEN
9566 nftests = 0
9567 DO 30 k = 1, ntests
9568 nftests = nftests + tfailed(k)
9569 30 CONTINUE
9570 END IF
9571*
9572* Send my error info to proc 0
9573*
9574 ELSE
9575 CALL btrecv(3, 0, k, 0, ibtmsgid()+50)
9576 CALL btsend(3, 1, nerr, 0, ibtmsgid()+50)
9577 IF( nerr .GT. 0 ) THEN
9578 CALL btsend(3, nerr*6, ierr, 0, ibtmsgid()+51)
9579 CALL btsend(5, nerr*2, cval, 0, ibtmsgid()+51)
9580 END IF
9581 ENDIF
9582*
9583 RETURN
9584*
9585* End of CBTCHECKIN
9586*
9587 END
9588*
9589 SUBROUTINE cinitmat(UPLO, DIAG, M, N, MEM, LDA, IPRE, IPOST,
9590 $ CHECKVAL, TESTNUM, MYROW, MYCOL)
9591 CHARACTER*1 UPLO, DIAG
9592 INTEGER M, N, LDA, IPRE, IPOST, TESTNUM, MYROW, MYCOL
9593 COMPLEX CHECKVAL
9594 COMPLEX MEM(*)
9595*
9596* .. External Subroutines ..
9597 EXTERNAL cgenmat, cpadmat
9598* ..
9599* .. Executable Statements ..
9600*
9601 CALL cgenmat( m, n, mem(ipre+1), lda, testnum, myrow, mycol )
9602 CALL cpadmat( uplo, diag, m, n, mem, lda, ipre, ipost, checkval )
9603*
9604 RETURN
9605 END
9606*
9607 SUBROUTINE cgenmat( M, N, A, LDA, TESTNUM, MYROW, MYCOL )
9608*
9609* -- BLACS tester (version 1.0) --
9610* University of Tennessee
9611* December 15, 1994
9612*
9613*
9614* .. Scalar Arguments ..
9615 INTEGER M, N, LDA, TESTNUM, MYROW, MYCOL
9616* ..
9617* .. Array Arguments ..
9618 COMPLEX A(LDA,N)
9619* ..
9620*
9621* Purpose
9622* =======
9623* CGENMAT: Generates an M-by-N matrix filled with random elements.
9624*
9625* Arguments
9626* =========
9627* M (input) INTEGER
9628* The number of rows of the matrix A. M >= 0.
9629*
9630* N (input) INTEGER
9631* The number of columns of the matrix A. N >= 0.
9632*
9633* A (output) @up@(doctype) array, dimension (LDA,N)
9634* The m by n matrix A. Fortran77 (column-major) storage
9635* assumed.
9636*
9637* LDA (input) INTEGER
9638* The leading dimension of the array A. LDA >= max(1, M).
9639*
9640* TESTNUM (input) INTEGER
9641* Unique number for this test case, used as a basis for
9642* the random seeds.
9643*
9644* ====================================================================
9645*
9646* .. External Functions ..
9647 INTEGER IBTNPROCS
9648 COMPLEX CBTRAN
9649 EXTERNAL cbtran, ibtnprocs
9650* ..
9651* .. Local Scalars ..
9652 INTEGER I, J, NPROCS, SRC
9653* ..
9654* .. Local Arrays ..
9655 INTEGER ISEED(4)
9656* ..
9657* .. Executable Statements ..
9658*
9659* ISEED's four values must be positive integers less than 4096,
9660* fourth one has to be odd. (see _LARND). Use some goofy
9661* functions to come up with seed values which together should
9662* be unique.
9663*
9664 nprocs = ibtnprocs()
9665 src = myrow * nprocs + mycol
9666 iseed(1) = mod( 1002 + testnum*5 + src*3, 4096 )
9667 iseed(2) = mod( 2027 + testnum*7 + src, 4096 )
9668 iseed(3) = mod( 1234 + testnum + src*3, 4096 )
9669 iseed(4) = mod( 4311 + testnum*10 + src*2, 4096 )
9670*
9671 DO 10 j = 1, n
9672 DO 10 i = 1, m
9673 a(i, j) = cbtran( iseed )
9674 10 CONTINUE
9675*
9676 RETURN
9677*
9678* End of CGENMAT.
9679*
9680 END
9681*
9682 COMPLEX FUNCTION cbtran(ISEED)
9683 INTEGER iseed(*)
9684*
9685* .. External Functions ..
9686 DOUBLE COMPLEX zlarnd
9687 EXTERNAL zlarnd
9688 cbtran = cmplx( zlarnd(2, iseed) )
9689*
9690 RETURN
9691*
9692* End of Cbtran
9693*
9694 END
9695*
9696 SUBROUTINE cpadmat( UPLO, DIAG, M, N, MEM, LDA, IPRE, IPOST,
9697 $ CHECKVAL )
9698*
9699* -- BLACS tester (version 1.0) --
9700* University of Tennessee
9701* December 15, 1994
9702*
9703* .. Scalar Arguments ..
9704 CHARACTER*1 UPLO, DIAG
9705 INTEGER M, N, LDA, IPRE, IPOST
9706 COMPLEX CHECKVAL
9707* ..
9708* .. Array Arguments ..
9709 COMPLEX MEM( * )
9710* ..
9711*
9712* Purpose
9713* =======
9714*
9715* CPADMAT: Pad Matrix.
9716* This routines surrounds a matrix with a guardzone initialized to the
9717* value CHECKVAL. There are three distinct guardzones:
9718* - A contiguous zone of size IPRE immediately before the start
9719* of the matrix.
9720* - A contiguous zone of size IPOST immedately after the end of the
9721* matrix.
9722* - Interstitial zones within each column of the matrix, in the
9723* elements A( M+1:LDA, J ).
9724*
9725* Arguments
9726* =========
9727* UPLO (input) CHARACTER*1
9728* Is the matrix A 'U'pper or 'L'ower trapezoidal, or 'G'eneral
9729* rectangular?
9730*
9731* DIAG (input) CHARACTER*1
9732* For trapezoidal matrices, is the main diagonal included
9733* ('N') or not ('U')?
9734*
9735* M (input) INTEGER
9736* The number of rows of the matrix A. M >= 0.
9737*
9738* N (input) INTEGER
9739* The number of columns of the matrix A. N >= 0.
9740*
9741* MEM (output) complex array, dimension (IPRE+IPOST+LDA*N)
9742* The address IPRE elements ahead of the matrix A you want to
9743* pad, which is then of dimension (LDA,N).
9744*
9745* IPRE (input) INTEGER
9746* The size of the guard zone ahead of the matrix A.
9747*
9748* IPOST (input) INTEGER
9749* The size of the guard zone behind the matrix A.
9750*
9751* CHECKVAL (input) complex
9752* The value to insert into the guard zones.
9753*
9754* ====================================================================
9755*
9756* .. Local Scalars ..
9757 INTEGER I, J, K
9758* ..
9759* .. Executable Statements ..
9760*
9761* Put check buffer in front of A
9762*
9763 IF( ipre .GT. 0 ) THEN
9764 DO 10 i = 1, ipre
9765 mem( i ) = checkval
9766 10 CONTINUE
9767 END IF
9768*
9769* Put check buffer in back of A
9770*
9771 IF( ipost .GT. 0 ) THEN
9772 j = ipre + lda*n + 1
9773 DO 20 i = j, j+ipost-1
9774 mem( i ) = checkval
9775 20 CONTINUE
9776 END IF
9777*
9778* Put check buffer in all (LDA-M) gaps
9779*
9780 IF( lda .GT. m ) THEN
9781 k = ipre + m + 1
9782 DO 40 j = 1, n
9783 DO 30 i = k, k+lda-m-1
9784 mem( i ) = checkval
9785 30 CONTINUE
9786 k = k + lda
9787 40 CONTINUE
9788 END IF
9789*
9790* If the matrix is upper or lower trapezoidal, calculate the
9791* additional triangular area which needs to be padded, Each
9792* element referred to is in the Ith row and the Jth column.
9793*
9794 IF( uplo .EQ. 'U' ) THEN
9795 IF( m .LE. n ) THEN
9796 IF( diag .EQ. 'U' ) THEN
9797 DO 41 i = 1, m
9798 DO 42 j = 1, i
9799 k = ipre + i + (j-1)*lda
9800 mem( k ) = checkval
9801 42 CONTINUE
9802 41 CONTINUE
9803 ELSE
9804 DO 43 i = 2, m
9805 DO 44 j = 1, i-1
9806 k = ipre + i + (j-1)*lda
9807 mem( k ) = checkval
9808 44 CONTINUE
9809 43 CONTINUE
9810 END IF
9811 ELSE
9812 IF( diag .EQ. 'U' ) THEN
9813 DO 45 i = m-n+1, m
9814 DO 46 j = 1, i-(m-n)
9815 k = ipre + i + (j-1)*lda
9816 mem( k ) = checkval
9817 46 CONTINUE
9818 45 CONTINUE
9819 ELSE
9820 DO 47 i = m-n+2, m
9821 DO 48 j = 1, i-(m-n)-1
9822 k = ipre + i + (j-1)*lda
9823 mem( k ) = checkval
9824 48 CONTINUE
9825 47 CONTINUE
9826 END IF
9827 END IF
9828 ELSE IF( uplo .EQ. 'L' ) THEN
9829 IF( m .LE. n ) THEN
9830 IF( diag .EQ. 'U' ) THEN
9831 DO 49 i = 1, m
9832 DO 50 j = n-m+i, n
9833 k = ipre + i + (j-1)*lda
9834 mem( k ) = checkval
9835 50 CONTINUE
9836 49 CONTINUE
9837 ELSE
9838 DO 51 i = 1, m-1
9839 DO 52 j = n-m+i+1, n
9840 k = ipre + i + (j-1)*lda
9841 mem( k ) = checkval
9842 52 CONTINUE
9843 51 CONTINUE
9844 END IF
9845 ELSE
9846 IF( uplo .EQ. 'U' ) THEN
9847 DO 53 i = 1, n
9848 DO 54 j = i, n
9849 k = ipre + i + (j-1)*lda
9850 mem( k ) = checkval
9851 54 CONTINUE
9852 53 CONTINUE
9853 ELSE
9854 DO 55 i = 1, n-1
9855 DO 56 j = i+1, n
9856 k = ipre + i + (j-1)*lda
9857 mem( k ) = checkval
9858 56 CONTINUE
9859 55 CONTINUE
9860 END IF
9861 END IF
9862 END IF
9863*
9864* End of CPADMAT.
9865*
9866 RETURN
9867 END
9868*
9869 SUBROUTINE cchkpad( UPLO, DIAG, M, N, MEM, LDA, RSRC, CSRC,
9870 $ MYROW, MYCOL, IPRE, IPOST, CHECKVAL,
9871 $ TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF )
9872*
9873* -- BLACS tester (version 1.0) --
9874* University of Tennessee
9875* December 15, 1994
9876*
9877*
9878* .. Scalar Arguments ..
9879 CHARACTER*1 UPLO, DIAG
9880 INTEGER M, N, LDA, RSRC, CSRC, MYROW, MYCOL, IPRE, IPOST
9881 INTEGER TESTNUM, MAXERR, NERR
9882 COMPLEX CHECKVAL
9883* ..
9884* .. Array Arguments ..
9885 INTEGER ERRIBUF(6, MAXERR)
9886 COMPLEX MEM(*), ERRDBUF(2, MAXERR)
9887* ..
9888*
9889* Purpose
9890* =======
9891* CCHKPAD: Check padding put in by PADMAT.
9892* Checks that padding around target matrix has not been overwritten
9893* by the previous point-to-point or broadcast send.
9894*
9895* Arguments
9896* =========
9897* UPLO (input) CHARACTER*1
9898* Is the matrix A 'U'pper or 'L'ower trapezoidal, or 'G'eneral
9899* rectangular?
9900*
9901* DIAG (input) CHARACTER*1
9902* For trapezoidal matrices, is the main diagonal included
9903* ('N') or not ('U')?
9904*
9905* M (input) INTEGER
9906* The number of rows of the matrix A. M >= 0.
9907*
9908* N (input) INTEGER
9909* The number of columns of the matrix A. N >= 0.
9910*
9911* MEM (input) complex array, dimension(IPRE+IPOST+LDA*N).
9912* Memory location IPRE elements in front of the matrix A.
9913*
9914* LDA (input) INTEGER
9915* The leading dimension of the array A. LDA >= max(1, M).
9916*
9917* RSRC (input) INTEGER
9918* The process row of the source of the matrix.
9919*
9920* CSRC (input) INTEGER
9921* The process column of the source of the matrix.
9922*
9923* MYROW (input) INTEGER
9924* Row of this process in the process grid.
9925*
9926* MYCOL (input) INTEGER
9927* Column of this process in the process grid.
9928*
9929* IPRE (input) INTEGER
9930* The size of the guard zone before the start of A.
9931*
9932* IPOST (input) INTEGER
9933* The size of guard zone after A.
9934*
9935* CHECKVAL (input) complex
9936* The value to pad matrix with.
9937*
9938* TESTNUM (input) INTEGER
9939* The number of the test being checked.
9940*
9941* MAXERR (input) INTEGER
9942* Max number of errors that can be stored in ERRIBUFF or
9943* ERRCBUFF
9944*
9945* NERR (output) INTEGER
9946* The number of errors that have been found.
9947*
9948* ERRIBUF (output) INTEGER array, dimension (6,MAXERRS)
9949* Buffer in which to store integer error information. It will
9950* be built up in the following format for the call to TSEND.
9951* All integer information is recorded in the following 6-tuple
9952* {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured:
9953* SRC = RSRC * NPROCS + CSRC
9954* DEST = RDEST * NPROCS + CDEST
9955* WHAT
9956* = 1 : Error in pre-padding
9957* = 2 : Error in post-padding
9958* = 3 : Error in LDA-M gap
9959* = 4 : Error in complementory triangle
9960* ELSE: Error in matrix
9961* If there are more errors than can fit in the error buffer,
9962* the error number will indicate the actual number of errors
9963* found, but the buffer will be truncated to the maximum
9964* number of errors which can fit.
9965*
9966* ERRDBUF (output) @(doctype) array, dimension (2, MAXERRS)
9967* Buffer in which to store error data information.
9968* {Incorrect, Predicted}
9969*
9970* ===================================================================
9971*
9972* .. Parameters ..
9973 INTEGER ERR_PRE, ERR_POST, ERR_GAP, ERR_TRI, ERR_MAT
9974 PARAMETER( ERR_PRE = 1, err_post = 2, err_gap = 3, err_tri = 4 )
9975 parameter( err_mat = 5 )
9976* ..
9977* .. External Functions ..
9978 INTEGER IBTNPROCS
9979 EXTERNAL IBTNPROCS
9980* ..
9981* .. Local Scalars ..
9982 LOGICAL ISTRAP
9983 INTEGER I, J, K, IRST, IRND, ICST, ICND, SRC, DEST
9984 INTEGER NPROCS
9985* ..
9986* .. Executable Statements ..
9987*
9988 NPROCS = ibtnprocs()
9989 src = rsrc * nprocs + csrc
9990 dest = myrow * nprocs + mycol
9991*
9992* Check buffer in front of A
9993*
9994 IF( ipre .GT. 0 ) THEN
9995 DO 10 i = 1, ipre
9996 IF( mem(i) .NE. checkval ) THEN
9997 nerr = nerr + 1
9998 IF( nerr .LE. maxerr ) THEN
9999 erribuf(1, nerr) = testnum
10000 erribuf(2, nerr) = src
10001 erribuf(3, nerr) = dest
10002 erribuf(4, nerr) = i
10003 erribuf(5, nerr) = ipre - i + 1
10004 erribuf(6, nerr) = err_pre
10005 errdbuf(1, nerr) = mem(i)
10006 errdbuf(2, nerr) = checkval
10007 END IF
10008 END IF
10009 10 CONTINUE
10010 END IF
10011*
10012* Check buffer behind A
10013*
10014 IF( ipost .GT. 0 ) THEN
10015 j = ipre + lda*n + 1
10016 DO 20 i = j, j+ipost-1
10017 IF( mem(i) .NE. checkval ) THEN
10018 nerr = nerr + 1
10019 IF( nerr .LE. maxerr ) THEN
10020 erribuf(1, nerr) = testnum
10021 erribuf(2, nerr) = src
10022 erribuf(3, nerr) = dest
10023 erribuf(4, nerr) = i - j + 1
10024 erribuf(5, nerr) = j
10025 erribuf(6, nerr) = err_post
10026 errdbuf(1, nerr) = mem(i)
10027 errdbuf(2, nerr) = checkval
10028 END IF
10029 END IF
10030 20 CONTINUE
10031 END IF
10032*
10033* Check all (LDA-M) gaps
10034*
10035 IF( lda .GT. m ) THEN
10036 DO 40 j = 1, n
10037 DO 30 i = m+1, lda
10038 k = ipre + (j-1)*lda + i
10039 IF( mem(k) .NE. checkval) THEN
10040 nerr = nerr + 1
10041 IF( nerr .LE. maxerr ) THEN
10042 erribuf(1, nerr) = testnum
10043 erribuf(2, nerr) = src
10044 erribuf(3, nerr) = dest
10045 erribuf(4, nerr) = i
10046 erribuf(5, nerr) = j
10047 erribuf(6, nerr) = err_gap
10048 errdbuf(1, nerr) = mem(k)
10049 errdbuf(2, nerr) = checkval
10050 END IF
10051 END IF
10052 30 CONTINUE
10053 40 CONTINUE
10054 END IF
10055*
10056* Determine limits of trapezoidal matrix
10057*
10058 istrap = .false.
10059 IF( uplo .EQ. 'U' ) THEN
10060 istrap = .true.
10061 IF( m .LE. n ) THEN
10062 irst = 2
10063 irnd = m
10064 icst = 1
10065 icnd = m - 1
10066 ELSEIF( m .GT. n ) THEN
10067 irst = ( m-n ) + 2
10068 irnd = m
10069 icst = 1
10070 icnd = n - 1
10071 ENDIF
10072 IF( diag .EQ. 'U' ) THEN
10073 irst = irst - 1
10074 icnd = icnd + 1
10075 ENDIF
10076 ELSE IF( uplo .EQ. 'L' ) THEN
10077 istrap = .true.
10078 IF( m .LE. n ) THEN
10079 irst = 1
10080 irnd = 1
10081 icst = ( n-m ) + 2
10082 icnd = n
10083 ELSEIF( m .GT. n ) THEN
10084 irst = 1
10085 irnd = 1
10086 icst = 2
10087 icnd = n
10088 ENDIF
10089 IF( diag .EQ. 'U' ) THEN
10090 icst = icst - 1
10091 ENDIF
10092 ENDIF
10093*
10094* Check elements and report any errors
10095*
10096 IF( istrap ) THEN
10097 DO 100 j = icst, icnd
10098 DO 105 i = irst, irnd
10099 IF( mem( ipre + (j-1)*lda + i ) .NE. checkval ) THEN
10100 nerr = nerr + 1
10101 IF( nerr .LE. maxerr ) THEN
10102 erribuf(1, nerr) = testnum
10103 erribuf(2, nerr) = src
10104 erribuf(3, nerr) = dest
10105 erribuf(4, nerr) = i
10106 erribuf(5, nerr) = j
10107 erribuf(6, nerr) = err_tri
10108 errdbuf(1, nerr) = mem( ipre + (j-1)*lda + i )
10109 errdbuf(2, nerr) = checkval
10110 END IF
10111 END IF
10112 105 CONTINUE
10113*
10114* Update the limits to allow filling in padding
10115*
10116 IF( uplo .EQ. 'U' ) THEN
10117 irst = irst + 1
10118 ELSE
10119 irnd = irnd + 1
10120 ENDIF
10121 100 CONTINUE
10122 END IF
10123*
10124 RETURN
10125*
10126* End of CCHKPAD.
10127*
10128 END
10129*
10130 SUBROUTINE cchkmat( UPLO, DIAG, M, N, A, LDA, RSRC, CSRC,
10131 $ MYROW, MYCOL, TESTNUM, MAXERR, NERR,
10132 $ ERRIBUF, ERRDBUF )
10133*
10134* -- BLACS tester (version 1.0) --
10135* University of Tennessee
10136* December 15, 1994
10137*
10138*
10139* .. Scalar Arguments ..
10140 CHARACTER*1 UPLO, DIAG
10141 INTEGER M, N, LDA, RSRC, CSRC, MYROW, MYCOL, TESTNUM
10142 INTEGER MAXERR, NERR
10143* ..
10144* .. Array Arguments ..
10145 INTEGER ERRIBUF(6, MAXERR)
10146 COMPLEX A(LDA,N), ERRDBUF(2, MAXERR)
10147* ..
10148*
10149* Purpose
10150* =======
10151* cCHKMAT: Check matrix to see whether there were any transmission
10152* errors.
10153*
10154* Arguments
10155* =========
10156* UPLO (input) CHARACTER*1
10157* Is the matrix A 'U'pper or 'L'ower trapezoidal, or 'G'eneral
10158* rectangular?
10159*
10160* DIAG (input) CHARACTER*1
10161* For trapezoidal matrices, is the main diagonal included
10162* ('N') or not ('U')?
10163*
10164* M (input) INTEGER
10165* The number of rows of the matrix A. M >= 0.
10166*
10167* N (input) INTEGER
10168* The number of columns of the matrix A. N >= 0.
10169*
10170* A (input) @up@(doctype) array, dimension (LDA,N)
10171* The m by n matrix A. Fortran77 (column-major) storage
10172* assumed.
10173*
10174* LDA (input) INTEGER
10175* The leading dimension of the array A. LDA >= max(1, M).
10176*
10177* RSRC (input) INTEGER
10178* The process row of the source of the matrix.
10179*
10180* CSRC (input) INTEGER
10181* The process column of the source of the matrix.
10182*
10183* MYROW (input) INTEGER
10184* Row of this process in the process grid.
10185*
10186* MYCOL (input) INTEGER
10187* Column of this process in the process grid.
10188*
10189*
10190* TESTNUM (input) INTEGER
10191* The number of the test being checked.
10192*
10193* MAXERR (input) INTEGER
10194* Max number of errors that can be stored in ERRIBUFF or
10195* ERRCBUFF
10196*
10197* NERR (output) INTEGER
10198* The number of errors that have been found.
10199*
10200* ERRIBUF (output) INTEGER array, dimension (6,MAXERRS)
10201* Buffer in which to store integer error information. It will
10202* be built up in the following format for the call to TSEND.
10203* All integer information is recorded in the following 6-tuple
10204* {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured:
10205* SRC = RSRC * NPROCS + CSRC
10206* DEST = RDEST * NPROCS + CDEST
10207* WHAT
10208* = 1 : Error in pre-padding
10209* = 2 : Error in post-padding
10210* = 3 : Error in LDA-M gap
10211* = 4 : Error in complementory triangle
10212* ELSE: Error in matrix
10213* If there are more errors than can fit in the error buffer,
10214* the error number will indicate the actual number of errors
10215* found, but the buffer will be truncated to the maximum
10216* number of errors which can fit.
10217*
10218* ERRDBUF (output) @(doctype) array, dimension (2, MAXERRS)
10219* Buffer in which to store error data information.
10220* {Incorrect, Predicted}
10221*
10222* ===================================================================
10223*
10224* .. Local Scalars ..
10225 INTEGER I, J, NPROCS, SRC, DEST
10226 LOGICAL USEIT
10227 COMPLEX COMPVAL
10228* ..
10229* .. Local Arrays ..
10230 INTEGER ISEED(4)
10231* ..
10232* .. External Functions ..
10233 INTEGER IBTNPROCS
10234 COMPLEX CBTRAN
10235 EXTERNAL CBTRAN, IBTNPROCS
10236* ..
10237* .. Executable Statements ..
10238*
10239 NPROCS = ibtnprocs()
10240 src = rsrc * nprocs + csrc
10241 dest = myrow * nprocs + mycol
10242*
10243* Initialize ISEED with the same values as used in CGENMAT.
10244*
10245 iseed(1) = mod( 1002 + testnum*5 + src*3, 4096 )
10246 iseed(2) = mod( 2027 + testnum*7 + src, 4096 )
10247 iseed(3) = mod( 1234 + testnum + src*3, 4096 )
10248 iseed(4) = mod( 4311 + testnum*10 + src*2, 4096 )
10249*
10250* Generate the elements randomly with the same method used in GENMAT.
10251* Note that for trapezoidal matrices, we generate all elements in the
10252* enclosing rectangle and then ignore the complementary triangle.
10253*
10254 DO 100 j = 1, n
10255 DO 105 i = 1, m
10256 compval = cbtran( iseed )
10257*
10258* Now determine whether we actually need this value. The
10259* strategy is to chop out the proper triangle based on what
10260* particular kind of trapezoidal matrix we're dealing with.
10261*
10262 useit = .true.
10263 IF( uplo .EQ. 'U' ) THEN
10264 IF( m .LE. n ) THEN
10265 IF( diag .EQ. 'U' ) THEN
10266 IF( i .GE. j ) THEN
10267 useit = .false.
10268 END IF
10269 ELSE
10270 IF( i .GT. j ) THEN
10271 useit = .false.
10272 END IF
10273 END IF
10274 ELSE
10275 IF( diag .EQ. 'U' ) THEN
10276 IF( i .GE. m-n+j ) THEN
10277 useit = .false.
10278 END IF
10279 ELSE
10280 IF( i .GT. m-n+j ) THEN
10281 useit = .false.
10282 END IF
10283 END IF
10284 END IF
10285 ELSE IF( uplo .EQ. 'L' ) THEN
10286 IF( m .LE. n ) THEN
10287 IF( diag .EQ. 'U' ) THEN
10288 IF( j. ge. i+(n-m) ) THEN
10289 useit = .false.
10290 END IF
10291 ELSE
10292 IF( j .GT. i+(n-m) ) THEN
10293 useit = .false.
10294 END IF
10295 END IF
10296 ELSE
10297 IF( diag .EQ. 'U' ) THEN
10298 IF( j .GE. i ) THEN
10299 useit = .false.
10300 END IF
10301 ELSE
10302 IF( j .GT. i ) THEN
10303 useit = .false.
10304 END IF
10305 END IF
10306 END IF
10307 END IF
10308*
10309* Compare the generated value to the one that's in the
10310* received matrix. If they don't match, tack another
10311* error record onto what's already there.
10312*
10313 IF( useit ) THEN
10314 IF( a(i,j) .NE. compval ) THEN
10315 nerr = nerr + 1
10316 IF( nerr .LE. maxerr ) THEN
10317 erribuf(1, nerr) = testnum
10318 erribuf(2, nerr) = src
10319 erribuf(3, nerr) = dest
10320 erribuf(4, nerr) = i
10321 erribuf(5, nerr) = j
10322 erribuf(6, nerr) = 5
10323 errdbuf(1, nerr) = a(i, j)
10324 errdbuf(2, nerr) = compval
10325 END IF
10326 END IF
10327 END IF
10328 105 CONTINUE
10329 100 CONTINUE
10330 RETURN
10331*
10332* End of CCHKMAT.
10333*
10334 END
10335*
10336 SUBROUTINE cprinterrs( OUTNUM, MAXERR, NERR,
10337 $ ERRIBUF, ERRDBUF, COUNTING, TFAILED )
10338*
10339* -- BLACS tester (version 1.0) --
10340* University of Tennessee
10341* December 15, 1994
10342*
10343*
10344* .. Scalar Arguments ..
10345 LOGICAL COUNTING
10346 INTEGER OUTNUM, MAXERR, NERR
10347* ..
10348* .. Array Arguments ..
10349 INTEGER ERRIBUF(6, MAXERR), TFAILED(*)
10350 COMPLEX ERRDBUF(2, MAXERR)
10351* ..
10352*
10353* Purpose
10354* =======
10355* CPRINTERRS: Print errors that have been recorded
10356*
10357* Arguments
10358* =========
10359* OUTNUM (input) INTEGER
10360* Device number for output.
10361*
10362* MAXERR (input) INTEGER
10363* Max number of errors that can be stored in ERRIBUFF or
10364* ERRCBUFF
10365*
10366* NERR (output) INTEGER
10367* The number of errors that have been found.
10368*
10369* ERRIBUF (output) INTEGER array, dimension (6,MAXERRS)
10370* Buffer in which to store integer error information. It will
10371* be built up in the following format for the call to TSEND.
10372* All integer information is recorded in the following 6-tuple
10373* {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured:
10374* SRC = RSRC * NPROCS + CSRC
10375* DEST = RDEST * NPROCS + CDEST
10376* WHAT
10377* = 1 : Error in pre-padding
10378* = 2 : Error in post-padding
10379* = 3 : Error in LDA-M gap
10380* = 4 : Error in complementory triangle
10381* ELSE: Error in matrix
10382* If there are more errors than can fit in the error buffer,
10383* the error number will indicate the actual number of errors
10384* found, but the buffer will be truncated to the maximum
10385* number of errors which can fit.
10386*
10387* ERRDBUF (output) @(doctype) array, dimension (2, MAXERRS)
10388* Buffer in which to store error data information.
10389* {Incorrect, Predicted}
10390*
10391* TFAILED (input/ourput) INTEGER array, dimension NTESTS
10392* Workspace used to keep track of which tests failed.
10393* This array not accessed unless COUNTING is true.
10394*
10395* ===================================================================
10396*
10397* .. Parameters ..
10398 INTEGER ERR_PRE, ERR_POST, ERR_GAP, ERR_TRI, ERR_MAT
10399 parameter( err_pre = 1, err_post = 2, err_gap = 3, err_tri = 4 )
10400 parameter( err_mat = 5 )
10401* ..
10402* .. External Functions ..
10403 INTEGER IBTMYPROC, IBTNPROCS
10404 EXTERNAL ibtmyproc, ibtnprocs
10405* ..
10406* .. Local Scalars ..
10407 CHARACTER*1 MAT
10408 LOGICAL MATISINT
10409 INTEGER OLDTEST, NPROCS, PROW, PCOL, I, ERRTYPE
10410* ..
10411* .. Executable Statements ..
10412*
10413 IF( (ibtmyproc().NE.0) .OR. (nerr.LE.0) ) RETURN
10414 oldtest = -1
10415 nprocs = ibtnprocs()
10416 prow = erribuf(3,1) / nprocs
10417 pcol = mod( erribuf(3,1), nprocs )
10418 IF( nerr .GT. maxerr ) WRITE(outnum,13000)
10419*
10420 DO 20 i = 1, min( nerr, maxerr )
10421 IF( erribuf(1,i) .NE. oldtest ) THEN
10422 IF( oldtest .NE. -1 )
10423 $ WRITE(outnum,12000) prow, pcol, oldtest
10424 WRITE(outnum,*) ' '
10425 WRITE(outnum,1000) prow, pcol, erribuf(1,i)
10426 IF( counting ) tfailed( erribuf(1,i) ) = 1
10427 oldtest = erribuf(1, i)
10428 END IF
10429*
10430* Print out error message depending on type of error
10431*
10432 errtype = erribuf(6, i)
10433 IF( errtype .LT. -10 ) THEN
10434 errtype = -errtype - 10
10435 mat = 'C'
10436 matisint = .true.
10437 ELSE IF( errtype .LT. 0 ) THEN
10438 errtype = -errtype
10439 mat = 'R'
10440 matisint = .true.
10441 ELSE
10442 matisint = .false.
10443 END IF
10444*
10445* RA/CA arrays from MAX/MIN have different printing protocol
10446*
10447 IF( matisint ) THEN
10448 IF( erribuf(2, i) .EQ. -1 ) THEN
10449 WRITE(outnum,11000) erribuf(4,i), erribuf(5,i), mat,
10450 $ int( errdbuf(2,i) ), int( errdbuf(1,i) )
10451 ELSE IF( errtype .EQ. err_pre ) THEN
10452 WRITE(outnum,7000) erribuf(5,i), mat,
10453 $ int( errdbuf(2,i) ), int( errdbuf(1,i) )
10454 ELSE IF( errtype .EQ. err_post ) THEN
10455 WRITE(outnum,8000) erribuf(4,i), mat,
10456 $ int( errdbuf(2,i) ), int( errdbuf(1,i) )
10457 ELSE IF( errtype .EQ. err_gap ) THEN
10458 WRITE(outnum,9000) mat, erribuf(4,i), erribuf(5,i),
10459 $ int( errdbuf(2,i) ), int( errdbuf(1,i) )
10460 ELSE
10461 WRITE(outnum,10000) mat, erribuf(4,i), erribuf(5,i),
10462 $ int( errdbuf(2,i) ),
10463 $ int( errdbuf(1,i) )
10464 END IF
10465*
10466* Have memory overwrites in matrix A
10467*
10468 ELSE
10469 IF( errtype .EQ. err_pre ) THEN
10470 WRITE(outnum,2000) erribuf(5,i),
10471 $ real( errdbuf(2,i) ), aimag( errdbuf(2,i) ),
10472 $ real( errdbuf(1,i) ), aimag( errdbuf(1,i) )
10473 ELSE IF( errtype .EQ. err_post ) THEN
10474 WRITE(outnum,3000) erribuf(4,i),
10475 $ real( errdbuf(2,i) ), aimag( errdbuf(2,i) ),
10476 $ real( errdbuf(1,i) ), aimag( errdbuf(1,i) )
10477 ELSE IF( errtype .EQ. err_gap ) THEN
10478 WRITE(outnum,4000)
10479 $ erribuf(4,i), erribuf(5,i),
10480 $ real( errdbuf(2,i) ), aimag( errdbuf(2,i) ),
10481 $ real( errdbuf(1,i) ), aimag( errdbuf(1,i) )
10482 ELSE IF( errtype .EQ. err_tri ) THEN
10483 WRITE(outnum,5000) erribuf(4,i), erribuf(5,i),
10484 $ real( errdbuf(2,i) ), aimag( errdbuf(2,i) ),
10485 $ real( errdbuf(1,i) ), aimag( errdbuf(1,i) )
10486 ELSE
10487 WRITE(outnum,6000) erribuf(4,i), erribuf(5,i),
10488 $ real( errdbuf(2,i) ), aimag( errdbuf(2,i) ),
10489 $ real( errdbuf(1,i) ), aimag( errdbuf(1,i) )
10490 END IF
10491 END IF
10492 20 CONTINUE
10493 WRITE(outnum,12000) prow, pcol, oldtest
10494*
10495 1000 FORMAT('PROCESS {',i4,',',i4,'} REPORTS ERRORS IN TEST#',i6,':')
10496 2000 FORMAT(' Buffer overwrite ',i4,
10497 $ ' elements before the start of A:',/,
10498 $ ' Expected=','[',g15.8,',',g15.8,']',
10499 $ '; Received=','[',g15.8,',',g15.8,']')
10500 3000 FORMAT(' Buffer overwrite ',i4,' elements after the end of A:',
10501 $ /,' Expected=','[',g15.8,',',g15.8,']',
10502 $ '; Received=','[',g15.8,',',g15.8,']')
10503 4000 FORMAT(' LDA-M gap overwrite at postion (',i4,',',i4,'):',/,
10504 $ ' Expected=','[',g15.8,',',g15.8,']',
10505 $ '; Received=','[',g15.8,',',g15.8,']')
10506 5000 FORMAT(' Complementory triangle overwrite at A(',i4,',',i4,
10507 $ '):',/,' Expected=','[',g15.8,',',g15.8,']',
10508 $ '; Received=','[',g15.8,',',g15.8,']')
10509 6000 FORMAT(' Invalid element at A(',i4,',',i4,'):',/,
10510 $ ' Expected=','[',g15.8,',',g15.8,']',
10511 $ '; Received=','[',g15.8,',',g15.8,']')
10512 7000 FORMAT(' Buffer overwrite ',i4,' elements before the start of ',
10513 $ a1,'A:',/,' Expected=',i12,'; Received=',i12)
10514 8000 FORMAT(' Buffer overwrite ',i4,' elements after the end of ',
10515 $ a1,'A:',/,' Expected=',i12,'; Received=',i12)
10516*
10517 9000 FORMAT(' LD',a1,'A-M gap overwrite at postion (',i4,',',i4,'):'
10518 $ ,/,' Expected=',i12,'; Received=',i12)
10519*
1052010000 FORMAT(' Invalid element at ',a1,'A(',i4,',',i4,'):',/,
10521 $ ' Expected=',i12,'; Received=',i12)
1052211000 FORMAT(' Overwrite at position (',i4,',',i4,') of non-existent '
10523 $ ,a1,'A array.',/,' Expected=',i12,'; Received=',i12)
1052412000 FORMAT('PROCESS {',i4,',',i4,'} DONE ERROR REPORT FOR TEST#',
10525 $ i6,'.')
1052613000 FORMAT('WARNING: There were more errors than could be recorded.',
10527 $ /,'Increase MEMELTS to get complete listing.')
10528 RETURN
10529*
10530* End CPRINTERRS
10531*
10532 END
10533*
10534*
10535 SUBROUTINE zbtcheckin( NFTESTS, OUTNUM, MAXERR, NERR, IERR,
10536 $ ZVAL, TFAILED )
10537 INTEGER NFTESTS, OUTNUM, MAXERR, NERR
10538 INTEGER IERR(*), TFAILED(*)
10539 DOUBLE COMPLEX ZVAL(*)
10540*
10541* Purpose
10542* =======
10543* ZBTCHECKIN: Process 0 receives error report from all processes.
10544*
10545* Arguments
10546* =========
10547* NFTESTS (input/output) INTEGER
10548* if NFTESTS is <= 0 upon entry, NFTESTS is not written to.
10549* Otherwise, on entry it specifies the total number of tests
10550* run, and on exit it is the number of tests which failed.
10551*
10552* OUTNUM (input) INTEGER
10553* Device number for output.
10554*
10555* MAXERR (input) INTEGER
10556* Max number of errors that can be stored in ERRIBUFF or
10557* ERRZBUFF
10558*
10559* NERR (output) INTEGER
10560* The number of errors that have been found.
10561*
10562* ERRIBUF (output) INTEGER array, dimension (6,MAXERRS)
10563* Buffer in which to store integer error information. It will
10564* be built up in the following format for the call to TSEND.
10565* All integer information is recorded in the following 6-tuple
10566* {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured:
10567* SRC = RSRC * NPROCS + CSRC
10568* DEST = RDEST * NPROCS + CDEST
10569* WHAT
10570* = 1 : Error in pre-padding
10571* = 2 : Error in post-padding
10572* = 3 : Error in LDA-M gap
10573* = 4 : Error in complementory triangle
10574* ELSE: Error in matrix
10575* If there are more errors than can fit in the error buffer,
10576* the error number will indicate the actual number of errors
10577* found, but the buffer will be truncated to the maximum
10578* number of errors which can fit.
10579*
10580* ERRDBUF (output) @(doctype) array, dimension (2, MAXERRS)
10581* Buffer in which to store error data information.
10582* {Incorrect, Predicted}
10583*
10584* TFAILED (workspace) INTEGER array, dimension NFTESTS
10585* Workspace used to keep track of which tests failed.
10586* If input of NFTESTS < 1, this array not accessed.
10587*
10588* ===================================================================
10589*
10590* .. External Functions ..
10591 INTEGER IBTMYPROC, IBTNPROCS, IBTMSGID
10592 EXTERNAL IBTMYPROC, IBTNPROCS, IBTMSGID
10593* ..
10594* .. Local Scalars ..
10595 LOGICAL COUNTING
10596 INTEGER K, NERR2, IAM, NPROCS, NTESTS
10597*
10598* Proc 0 collects error info from everyone
10599*
10600 iam = ibtmyproc()
10601 nprocs = ibtnprocs()
10602*
10603 IF( iam .EQ. 0 ) THEN
10604*
10605* If we are finding out how many failed tests there are, initialize
10606* the total number of tests (NTESTS), and zero the test failed array
10607*
10608 counting = nftests .GT. 0
10609 IF( counting ) THEN
10610 ntests = nftests
10611 DO 10 k = 1, ntests
10612 tfailed(k) = 0
10613 10 CONTINUE
10614 END IF
10615*
10616 CALL zprinterrs(outnum, maxerr, nerr, ierr, zval, counting,
10617 $ tfailed)
10618*
10619 DO 20 k = 1, nprocs-1
10620 CALL btsend(3, 0, k, k, ibtmsgid()+50)
10621 CALL btrecv(3, 1, nerr2, k, ibtmsgid()+50)
10622 IF( nerr2 .GT. 0 ) THEN
10623 nerr = nerr + nerr2
10624 CALL btrecv(3, nerr2*6, ierr, k, ibtmsgid()+51)
10625 CALL btrecv(7, nerr2*2, zval, k, ibtmsgid()+51)
10626 CALL zprinterrs(outnum, maxerr, nerr2, ierr, zval,
10627 $ counting, tfailed)
10628 END IF
10629 20 CONTINUE
10630*
10631* Count up number of tests that failed
10632*
10633 IF( counting ) THEN
10634 nftests = 0
10635 DO 30 k = 1, ntests
10636 nftests = nftests + tfailed(k)
10637 30 CONTINUE
10638 END IF
10639*
10640* Send my error info to proc 0
10641*
10642 ELSE
10643 CALL btrecv(3, 0, k, 0, ibtmsgid()+50)
10644 CALL btsend(3, 1, nerr, 0, ibtmsgid()+50)
10645 IF( nerr .GT. 0 ) THEN
10646 CALL btsend(3, nerr*6, ierr, 0, ibtmsgid()+51)
10647 CALL btsend(7, nerr*2, zval, 0, ibtmsgid()+51)
10648 END IF
10649 ENDIF
10650*
10651 RETURN
10652*
10653* End of ZBTCHECKIN
10654*
10655 END
10656*
10657 SUBROUTINE zinitmat(UPLO, DIAG, M, N, MEM, LDA, IPRE, IPOST,
10658 $ CHECKVAL, TESTNUM, MYROW, MYCOL)
10659 CHARACTER*1 UPLO, DIAG
10660 INTEGER M, N, LDA, IPRE, IPOST, TESTNUM, MYROW, MYCOL
10661 DOUBLE COMPLEX CHECKVAL
10662 DOUBLE COMPLEX MEM(*)
10663*
10664* .. External Subroutines ..
10665 EXTERNAL ZGENMAT, ZPADMAT
10666* ..
10667* .. Executable Statements ..
10668*
10669 CALL ZGENMAT( M, N, MEM(IPRE+1), LDA, TESTNUM, MYROW, MYCOL )
10670 CALL ZPADMAT( UPLO, DIAG, M, N, MEM, LDA, IPRE, IPOST, CHECKVAL )
10671*
10672 RETURN
10673 END
10674*
10675 SUBROUTINE zgenmat( M, N, A, LDA, TESTNUM, MYROW, MYCOL )
10676*
10677* -- BLACS tester (version 1.0) --
10678* University of Tennessee
10679* December 15, 1994
10680*
10681*
10682* .. Scalar Arguments ..
10683 INTEGER M, N, LDA, TESTNUM, MYROW, MYCOL
10684* ..
10685* .. Array Arguments ..
10686 DOUBLE COMPLEX A(LDA,N)
10687* ..
10688*
10689* Purpose
10690* =======
10691* ZGENMAT: Generates an M-by-N matrix filled with random elements.
10692*
10693* Arguments
10694* =========
10695* M (input) INTEGER
10696* The number of rows of the matrix A. M >= 0.
10697*
10698* N (input) INTEGER
10699* The number of columns of the matrix A. N >= 0.
10700*
10701* A (output) @up@(doctype) array, dimension (LDA,N)
10702* The m by n matrix A. Fortran77 (column-major) storage
10703* assumed.
10704*
10705* LDA (input) INTEGER
10706* The leading dimension of the array A. LDA >= max(1, M).
10707*
10708* TESTNUM (input) INTEGER
10709* Unique number for this test case, used as a basis for
10710* the random seeds.
10711*
10712* ====================================================================
10713*
10714* .. External Functions ..
10715 INTEGER IBTNPROCS
10716 DOUBLE COMPLEX ZBTRAN
10717 EXTERNAL zbtran, ibtnprocs
10718* ..
10719* .. Local Scalars ..
10720 INTEGER I, J, NPROCS, SRC
10721* ..
10722* .. Local Arrays ..
10723 INTEGER ISEED(4)
10724* ..
10725* .. Executable Statements ..
10726*
10727* ISEED's four values must be positive integers less than 4096,
10728* fourth one has to be odd. (see _LARND). Use some goofy
10729* functions to come up with seed values which together should
10730* be unique.
10731*
10732 nprocs = ibtnprocs()
10733 src = myrow * nprocs + mycol
10734 iseed(1) = mod( 1002 + testnum*5 + src*3, 4096 )
10735 iseed(2) = mod( 2027 + testnum*7 + src, 4096 )
10736 iseed(3) = mod( 1234 + testnum + src*3, 4096 )
10737 iseed(4) = mod( 4311 + testnum*10 + src*2, 4096 )
10738*
10739 DO 10 j = 1, n
10740 DO 10 i = 1, m
10741 a(i, j) = zbtran( iseed )
10742 10 CONTINUE
10743*
10744 RETURN
10745*
10746* End of ZGENMAT.
10747*
10748 END
10749*
10750 DOUBLE COMPLEX FUNCTION zbtran(ISEED)
10751 INTEGER iseed(*)
10752*
10753* .. External Functions ..
10754 DOUBLE COMPLEX zlarnd
10755 EXTERNAL zlarnd
10756 zbtran = zlarnd(2, iseed)
10757*
10758 RETURN
10759*
10760* End of Zbtran
10761*
10762 END
10763*
10764 SUBROUTINE zpadmat( UPLO, DIAG, M, N, MEM, LDA, IPRE, IPOST,
10765 $ CHECKVAL )
10766*
10767* -- BLACS tester (version 1.0) --
10768* University of Tennessee
10769* December 15, 1994
10770*
10771* .. Scalar Arguments ..
10772 CHARACTER*1 UPLO, DIAG
10773 INTEGER M, N, LDA, IPRE, IPOST
10774 DOUBLE COMPLEX CHECKVAL
10775* ..
10776* .. Array Arguments ..
10777 DOUBLE COMPLEX MEM( * )
10778* ..
10779*
10780* Purpose
10781* =======
10782*
10783* ZPADMAT: Pad Matrix.
10784* This routines surrounds a matrix with a guardzone initialized to the
10785* value CHECKVAL. There are three distinct guardzones:
10786* - A contiguous zone of size IPRE immediately before the start
10787* of the matrix.
10788* - A contiguous zone of size IPOST immedately after the end of the
10789* matrix.
10790* - Interstitial zones within each column of the matrix, in the
10791* elements A( M+1:LDA, J ).
10792*
10793* Arguments
10794* =========
10795* UPLO (input) CHARACTER*1
10796* Is the matrix A 'U'pper or 'L'ower trapezoidal, or 'G'eneral
10797* rectangular?
10798*
10799* DIAG (input) CHARACTER*1
10800* For trapezoidal matrices, is the main diagonal included
10801* ('N') or not ('U')?
10802*
10803* M (input) INTEGER
10804* The number of rows of the matrix A. M >= 0.
10805*
10806* N (input) INTEGER
10807* The number of columns of the matrix A. N >= 0.
10808*
10809* MEM (output) double complex array, dimension (IPRE+IPOST+LDA*N)
10810* The address IPRE elements ahead of the matrix A you want to
10811* pad, which is then of dimension (LDA,N).
10812*
10813* IPRE (input) INTEGER
10814* The size of the guard zone ahead of the matrix A.
10815*
10816* IPOST (input) INTEGER
10817* The size of the guard zone behind the matrix A.
10818*
10819* CHECKVAL (input) double complex
10820* The value to insert into the guard zones.
10821*
10822* ====================================================================
10823*
10824* .. Local Scalars ..
10825 INTEGER I, J, K
10826* ..
10827* .. Executable Statements ..
10828*
10829* Put check buffer in front of A
10830*
10831 IF( ipre .GT. 0 ) THEN
10832 DO 10 i = 1, ipre
10833 mem( i ) = checkval
10834 10 CONTINUE
10835 END IF
10836*
10837* Put check buffer in back of A
10838*
10839 IF( ipost .GT. 0 ) THEN
10840 j = ipre + lda*n + 1
10841 DO 20 i = j, j+ipost-1
10842 mem( i ) = checkval
10843 20 CONTINUE
10844 END IF
10845*
10846* Put check buffer in all (LDA-M) gaps
10847*
10848 IF( lda .GT. m ) THEN
10849 k = ipre + m + 1
10850 DO 40 j = 1, n
10851 DO 30 i = k, k+lda-m-1
10852 mem( i ) = checkval
10853 30 CONTINUE
10854 k = k + lda
10855 40 CONTINUE
10856 END IF
10857*
10858* If the matrix is upper or lower trapezoidal, calculate the
10859* additional triangular area which needs to be padded, Each
10860* element referred to is in the Ith row and the Jth column.
10861*
10862 IF( uplo .EQ. 'U' ) THEN
10863 IF( m .LE. n ) THEN
10864 IF( diag .EQ. 'U' ) THEN
10865 DO 41 i = 1, m
10866 DO 42 j = 1, i
10867 k = ipre + i + (j-1)*lda
10868 mem( k ) = checkval
10869 42 CONTINUE
10870 41 CONTINUE
10871 ELSE
10872 DO 43 i = 2, m
10873 DO 44 j = 1, i-1
10874 k = ipre + i + (j-1)*lda
10875 mem( k ) = checkval
10876 44 CONTINUE
10877 43 CONTINUE
10878 END IF
10879 ELSE
10880 IF( diag .EQ. 'U' ) THEN
10881 DO 45 i = m-n+1, m
10882 DO 46 j = 1, i-(m-n)
10883 k = ipre + i + (j-1)*lda
10884 mem( k ) = checkval
10885 46 CONTINUE
10886 45 CONTINUE
10887 ELSE
10888 DO 47 i = m-n+2, m
10889 DO 48 j = 1, i-(m-n)-1
10890 k = ipre + i + (j-1)*lda
10891 mem( k ) = checkval
10892 48 CONTINUE
10893 47 CONTINUE
10894 END IF
10895 END IF
10896 ELSE IF( uplo .EQ. 'L' ) THEN
10897 IF( m .LE. n ) THEN
10898 IF( diag .EQ. 'U' ) THEN
10899 DO 49 i = 1, m
10900 DO 50 j = n-m+i, n
10901 k = ipre + i + (j-1)*lda
10902 mem( k ) = checkval
10903 50 CONTINUE
10904 49 CONTINUE
10905 ELSE
10906 DO 51 i = 1, m-1
10907 DO 52 j = n-m+i+1, n
10908 k = ipre + i + (j-1)*lda
10909 mem( k ) = checkval
10910 52 CONTINUE
10911 51 CONTINUE
10912 END IF
10913 ELSE
10914 IF( uplo .EQ. 'U' ) THEN
10915 DO 53 i = 1, n
10916 DO 54 j = i, n
10917 k = ipre + i + (j-1)*lda
10918 mem( k ) = checkval
10919 54 CONTINUE
10920 53 CONTINUE
10921 ELSE
10922 DO 55 i = 1, n-1
10923 DO 56 j = i+1, n
10924 k = ipre + i + (j-1)*lda
10925 mem( k ) = checkval
10926 56 CONTINUE
10927 55 CONTINUE
10928 END IF
10929 END IF
10930 END IF
10931*
10932* End of ZPADMAT.
10933*
10934 RETURN
10935 END
10936*
10937 SUBROUTINE zchkpad( UPLO, DIAG, M, N, MEM, LDA, RSRC, CSRC,
10938 $ MYROW, MYCOL, IPRE, IPOST, CHECKVAL,
10939 $ TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF )
10940*
10941* -- BLACS tester (version 1.0) --
10942* University of Tennessee
10943* December 15, 1994
10944*
10945*
10946* .. Scalar Arguments ..
10947 CHARACTER*1 UPLO, DIAG
10948 INTEGER M, N, LDA, RSRC, CSRC, MYROW, MYCOL, IPRE, IPOST
10949 INTEGER TESTNUM, MAXERR, NERR
10950 DOUBLE COMPLEX CHECKVAL
10951* ..
10952* .. Array Arguments ..
10953 INTEGER ERRIBUF(6, MAXERR)
10954 DOUBLE COMPLEX MEM(*), ERRDBUF(2, MAXERR)
10955* ..
10956*
10957* Purpose
10958* =======
10959* ZCHKPAD: Check padding put in by PADMAT.
10960* Checks that padding around target matrix has not been overwritten
10961* by the previous point-to-point or broadcast send.
10962*
10963* Arguments
10964* =========
10965* UPLO (input) CHARACTER*1
10966* Is the matrix A 'U'pper or 'L'ower trapezoidal, or 'G'eneral
10967* rectangular?
10968*
10969* DIAG (input) CHARACTER*1
10970* For trapezoidal matrices, is the main diagonal included
10971* ('N') or not ('U')?
10972*
10973* M (input) INTEGER
10974* The number of rows of the matrix A. M >= 0.
10975*
10976* N (input) INTEGER
10977* The number of columns of the matrix A. N >= 0.
10978*
10979* MEM (input) double complex array, dimension(IPRE+IPOST+LDA*N).
10980* Memory location IPRE elements in front of the matrix A.
10981*
10982* LDA (input) INTEGER
10983* The leading dimension of the array A. LDA >= max(1, M).
10984*
10985* RSRC (input) INTEGER
10986* The process row of the source of the matrix.
10987*
10988* CSRC (input) INTEGER
10989* The process column of the source of the matrix.
10990*
10991* MYROW (input) INTEGER
10992* Row of this process in the process grid.
10993*
10994* MYCOL (input) INTEGER
10995* Column of this process in the process grid.
10996*
10997* IPRE (input) INTEGER
10998* The size of the guard zone before the start of A.
10999*
11000* IPOST (input) INTEGER
11001* The size of guard zone after A.
11002*
11003* CHECKVAL (input) double complex
11004* The value to pad matrix with.
11005*
11006* TESTNUM (input) INTEGER
11007* The number of the test being checked.
11008*
11009* MAXERR (input) INTEGER
11010* Max number of errors that can be stored in ERRIBUFF or
11011* ERRZBUFF
11012*
11013* NERR (output) INTEGER
11014* The number of errors that have been found.
11015*
11016* ERRIBUF (output) INTEGER array, dimension (6,MAXERRS)
11017* Buffer in which to store integer error information. It will
11018* be built up in the following format for the call to TSEND.
11019* All integer information is recorded in the following 6-tuple
11020* {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured:
11021* SRC = RSRC * NPROCS + CSRC
11022* DEST = RDEST * NPROCS + CDEST
11023* WHAT
11024* = 1 : Error in pre-padding
11025* = 2 : Error in post-padding
11026* = 3 : Error in LDA-M gap
11027* = 4 : Error in complementory triangle
11028* ELSE: Error in matrix
11029* If there are more errors than can fit in the error buffer,
11030* the error number will indicate the actual number of errors
11031* found, but the buffer will be truncated to the maximum
11032* number of errors which can fit.
11033*
11034* ERRDBUF (output) @(doctype) array, dimension (2, MAXERRS)
11035* Buffer in which to store error data information.
11036* {Incorrect, Predicted}
11037*
11038* ===================================================================
11039*
11040* .. Parameters ..
11041 INTEGER ERR_PRE, ERR_POST, ERR_GAP, ERR_TRI, ERR_MAT
11042 PARAMETER( ERR_PRE = 1, err_post = 2, err_gap = 3, err_tri = 4 )
11043 parameter( err_mat = 5 )
11044* ..
11045* .. External Functions ..
11046 INTEGER IBTNPROCS
11047 EXTERNAL IBTNPROCS
11048* ..
11049* .. Local Scalars ..
11050 LOGICAL ISTRAP
11051 INTEGER I, J, K, IRST, IRND, ICST, ICND, SRC, DEST
11052 INTEGER NPROCS
11053* ..
11054* .. Executable Statements ..
11055*
11056 NPROCS = ibtnprocs()
11057 src = rsrc * nprocs + csrc
11058 dest = myrow * nprocs + mycol
11059*
11060* Check buffer in front of A
11061*
11062 IF( ipre .GT. 0 ) THEN
11063 DO 10 i = 1, ipre
11064 IF( mem(i) .NE. checkval ) THEN
11065 nerr = nerr + 1
11066 IF( nerr .LE. maxerr ) THEN
11067 erribuf(1, nerr) = testnum
11068 erribuf(2, nerr) = src
11069 erribuf(3, nerr) = dest
11070 erribuf(4, nerr) = i
11071 erribuf(5, nerr) = ipre - i + 1
11072 erribuf(6, nerr) = err_pre
11073 errdbuf(1, nerr) = mem(i)
11074 errdbuf(2, nerr) = checkval
11075 END IF
11076 END IF
11077 10 CONTINUE
11078 END IF
11079*
11080* Check buffer behind A
11081*
11082 IF( ipost .GT. 0 ) THEN
11083 j = ipre + lda*n + 1
11084 DO 20 i = j, j+ipost-1
11085 IF( mem(i) .NE. checkval ) THEN
11086 nerr = nerr + 1
11087 IF( nerr .LE. maxerr ) THEN
11088 erribuf(1, nerr) = testnum
11089 erribuf(2, nerr) = src
11090 erribuf(3, nerr) = dest
11091 erribuf(4, nerr) = i - j + 1
11092 erribuf(5, nerr) = j
11093 erribuf(6, nerr) = err_post
11094 errdbuf(1, nerr) = mem(i)
11095 errdbuf(2, nerr) = checkval
11096 END IF
11097 END IF
11098 20 CONTINUE
11099 END IF
11100*
11101* Check all (LDA-M) gaps
11102*
11103 IF( lda .GT. m ) THEN
11104 DO 40 j = 1, n
11105 DO 30 i = m+1, lda
11106 k = ipre + (j-1)*lda + i
11107 IF( mem(k) .NE. checkval) THEN
11108 nerr = nerr + 1
11109 IF( nerr .LE. maxerr ) THEN
11110 erribuf(1, nerr) = testnum
11111 erribuf(2, nerr) = src
11112 erribuf(3, nerr) = dest
11113 erribuf(4, nerr) = i
11114 erribuf(5, nerr) = j
11115 erribuf(6, nerr) = err_gap
11116 errdbuf(1, nerr) = mem(k)
11117 errdbuf(2, nerr) = checkval
11118 END IF
11119 END IF
11120 30 CONTINUE
11121 40 CONTINUE
11122 END IF
11123*
11124* Determine limits of trapezoidal matrix
11125*
11126 istrap = .false.
11127 IF( uplo .EQ. 'U' ) THEN
11128 istrap = .true.
11129 IF( m .LE. n ) THEN
11130 irst = 2
11131 irnd = m
11132 icst = 1
11133 icnd = m - 1
11134 ELSEIF( m .GT. n ) THEN
11135 irst = ( m-n ) + 2
11136 irnd = m
11137 icst = 1
11138 icnd = n - 1
11139 ENDIF
11140 IF( diag .EQ. 'U' ) THEN
11141 irst = irst - 1
11142 icnd = icnd + 1
11143 ENDIF
11144 ELSE IF( uplo .EQ. 'L' ) THEN
11145 istrap = .true.
11146 IF( m .LE. n ) THEN
11147 irst = 1
11148 irnd = 1
11149 icst = ( n-m ) + 2
11150 icnd = n
11151 ELSEIF( m .GT. n ) THEN
11152 irst = 1
11153 irnd = 1
11154 icst = 2
11155 icnd = n
11156 ENDIF
11157 IF( diag .EQ. 'U' ) THEN
11158 icst = icst - 1
11159 ENDIF
11160 ENDIF
11161*
11162* Check elements and report any errors
11163*
11164 IF( istrap ) THEN
11165 DO 100 j = icst, icnd
11166 DO 105 i = irst, irnd
11167 IF( mem( ipre + (j-1)*lda + i ) .NE. checkval ) THEN
11168 nerr = nerr + 1
11169 IF( nerr .LE. maxerr ) THEN
11170 erribuf(1, nerr) = testnum
11171 erribuf(2, nerr) = src
11172 erribuf(3, nerr) = dest
11173 erribuf(4, nerr) = i
11174 erribuf(5, nerr) = j
11175 erribuf(6, nerr) = err_tri
11176 errdbuf(1, nerr) = mem( ipre + (j-1)*lda + i )
11177 errdbuf(2, nerr) = checkval
11178 END IF
11179 END IF
11180 105 CONTINUE
11181*
11182* Update the limits to allow filling in padding
11183*
11184 IF( uplo .EQ. 'U' ) THEN
11185 irst = irst + 1
11186 ELSE
11187 irnd = irnd + 1
11188 ENDIF
11189 100 CONTINUE
11190 END IF
11191*
11192 RETURN
11193*
11194* End of ZCHKPAD.
11195*
11196 END
11197*
11198 SUBROUTINE zchkmat( UPLO, DIAG, M, N, A, LDA, RSRC, CSRC,
11199 $ MYROW, MYCOL, TESTNUM, MAXERR, NERR,
11200 $ ERRIBUF, ERRDBUF )
11201*
11202* -- BLACS tester (version 1.0) --
11203* University of Tennessee
11204* December 15, 1994
11205*
11206*
11207* .. Scalar Arguments ..
11208 CHARACTER*1 UPLO, DIAG
11209 INTEGER M, N, LDA, RSRC, CSRC, MYROW, MYCOL, TESTNUM
11210 INTEGER MAXERR, NERR
11211* ..
11212* .. Array Arguments ..
11213 INTEGER ERRIBUF(6, MAXERR)
11214 DOUBLE COMPLEX A(LDA,N), ERRDBUF(2, MAXERR)
11215* ..
11216*
11217* Purpose
11218* =======
11219* zCHKMAT: Check matrix to see whether there were any transmission
11220* errors.
11221*
11222* Arguments
11223* =========
11224* UPLO (input) CHARACTER*1
11225* Is the matrix A 'U'pper or 'L'ower trapezoidal, or 'G'eneral
11226* rectangular?
11227*
11228* DIAG (input) CHARACTER*1
11229* For trapezoidal matrices, is the main diagonal included
11230* ('N') or not ('U')?
11231*
11232* M (input) INTEGER
11233* The number of rows of the matrix A. M >= 0.
11234*
11235* N (input) INTEGER
11236* The number of columns of the matrix A. N >= 0.
11237*
11238* A (input) @up@(doctype) array, dimension (LDA,N)
11239* The m by n matrix A. Fortran77 (column-major) storage
11240* assumed.
11241*
11242* LDA (input) INTEGER
11243* The leading dimension of the array A. LDA >= max(1, M).
11244*
11245* RSRC (input) INTEGER
11246* The process row of the source of the matrix.
11247*
11248* CSRC (input) INTEGER
11249* The process column of the source of the matrix.
11250*
11251* MYROW (input) INTEGER
11252* Row of this process in the process grid.
11253*
11254* MYCOL (input) INTEGER
11255* Column of this process in the process grid.
11256*
11257*
11258* TESTNUM (input) INTEGER
11259* The number of the test being checked.
11260*
11261* MAXERR (input) INTEGER
11262* Max number of errors that can be stored in ERRIBUFF or
11263* ERRZBUFF
11264*
11265* NERR (output) INTEGER
11266* The number of errors that have been found.
11267*
11268* ERRIBUF (output) INTEGER array, dimension (6,MAXERRS)
11269* Buffer in which to store integer error information. It will
11270* be built up in the following format for the call to TSEND.
11271* All integer information is recorded in the following 6-tuple
11272* {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured:
11273* SRC = RSRC * NPROCS + CSRC
11274* DEST = RDEST * NPROCS + CDEST
11275* WHAT
11276* = 1 : Error in pre-padding
11277* = 2 : Error in post-padding
11278* = 3 : Error in LDA-M gap
11279* = 4 : Error in complementory triangle
11280* ELSE: Error in matrix
11281* If there are more errors than can fit in the error buffer,
11282* the error number will indicate the actual number of errors
11283* found, but the buffer will be truncated to the maximum
11284* number of errors which can fit.
11285*
11286* ERRDBUF (output) @(doctype) array, dimension (2, MAXERRS)
11287* Buffer in which to store error data information.
11288* {Incorrect, Predicted}
11289*
11290* ===================================================================
11291*
11292* .. Local Scalars ..
11293 INTEGER I, J, NPROCS, SRC, DEST
11294 LOGICAL USEIT
11295 DOUBLE COMPLEX COMPVAL
11296* ..
11297* .. Local Arrays ..
11298 INTEGER ISEED(4)
11299* ..
11300* .. External Functions ..
11301 INTEGER IBTNPROCS
11302 DOUBLE COMPLEX ZBTRAN
11303 EXTERNAL ZBTRAN, IBTNPROCS
11304* ..
11305* .. Executable Statements ..
11306*
11307 NPROCS = ibtnprocs()
11308 src = rsrc * nprocs + csrc
11309 dest = myrow * nprocs + mycol
11310*
11311* Initialize ISEED with the same values as used in ZGENMAT.
11312*
11313 iseed(1) = mod( 1002 + testnum*5 + src*3, 4096 )
11314 iseed(2) = mod( 2027 + testnum*7 + src, 4096 )
11315 iseed(3) = mod( 1234 + testnum + src*3, 4096 )
11316 iseed(4) = mod( 4311 + testnum*10 + src*2, 4096 )
11317*
11318* Generate the elements randomly with the same method used in GENMAT.
11319* Note that for trapezoidal matrices, we generate all elements in the
11320* enclosing rectangle and then ignore the complementary triangle.
11321*
11322 DO 100 j = 1, n
11323 DO 105 i = 1, m
11324 compval = zbtran( iseed )
11325*
11326* Now determine whether we actually need this value. The
11327* strategy is to chop out the proper triangle based on what
11328* particular kind of trapezoidal matrix we're dealing with.
11329*
11330 useit = .true.
11331 IF( uplo .EQ. 'U' ) THEN
11332 IF( m .LE. n ) THEN
11333 IF( diag .EQ. 'U' ) THEN
11334 IF( i .GE. j ) THEN
11335 useit = .false.
11336 END IF
11337 ELSE
11338 IF( i .GT. j ) THEN
11339 useit = .false.
11340 END IF
11341 END IF
11342 ELSE
11343 IF( diag .EQ. 'U' ) THEN
11344 IF( i .GE. m-n+j ) THEN
11345 useit = .false.
11346 END IF
11347 ELSE
11348 IF( i .GT. m-n+j ) THEN
11349 useit = .false.
11350 END IF
11351 END IF
11352 END IF
11353 ELSE IF( uplo .EQ. 'L' ) THEN
11354 IF( m .LE. n ) THEN
11355 IF( diag .EQ. 'U' ) THEN
11356 IF( j. ge. i+(n-m) ) THEN
11357 useit = .false.
11358 END IF
11359 ELSE
11360 IF( j .GT. i+(n-m) ) THEN
11361 useit = .false.
11362 END IF
11363 END IF
11364 ELSE
11365 IF( diag .EQ. 'U' ) THEN
11366 IF( j .GE. i ) THEN
11367 useit = .false.
11368 END IF
11369 ELSE
11370 IF( j .GT. i ) THEN
11371 useit = .false.
11372 END IF
11373 END IF
11374 END IF
11375 END IF
11376*
11377* Compare the generated value to the one that's in the
11378* received matrix. If they don't match, tack another
11379* error record onto what's already there.
11380*
11381 IF( useit ) THEN
11382 IF( a(i,j) .NE. compval ) THEN
11383 nerr = nerr + 1
11384 IF( nerr .LE. maxerr ) THEN
11385 erribuf(1, nerr) = testnum
11386 erribuf(2, nerr) = src
11387 erribuf(3, nerr) = dest
11388 erribuf(4, nerr) = i
11389 erribuf(5, nerr) = j
11390 erribuf(6, nerr) = 5
11391 errdbuf(1, nerr) = a(i, j)
11392 errdbuf(2, nerr) = compval
11393 END IF
11394 END IF
11395 END IF
11396 105 CONTINUE
11397 100 CONTINUE
11398 RETURN
11399*
11400* End of ZCHKMAT.
11401*
11402 END
11403*
11404 SUBROUTINE zprinterrs( OUTNUM, MAXERR, NERR,
11405 $ ERRIBUF, ERRDBUF, COUNTING, TFAILED )
11406*
11407* -- BLACS tester (version 1.0) --
11408* University of Tennessee
11409* December 15, 1994
11410*
11411*
11412* .. Scalar Arguments ..
11413 LOGICAL COUNTING
11414 INTEGER OUTNUM, MAXERR, NERR
11415* ..
11416* .. Array Arguments ..
11417 INTEGER ERRIBUF(6, MAXERR), TFAILED(*)
11418 DOUBLE COMPLEX ERRDBUF(2, MAXERR)
11419* ..
11420*
11421* Purpose
11422* =======
11423* ZPRINTERRS: Print errors that have been recorded
11424*
11425* Arguments
11426* =========
11427* OUTNUM (input) INTEGER
11428* Device number for output.
11429*
11430* MAXERR (input) INTEGER
11431* Max number of errors that can be stored in ERRIBUFF or
11432* ERRZBUFF
11433*
11434* NERR (output) INTEGER
11435* The number of errors that have been found.
11436*
11437* ERRIBUF (output) INTEGER array, dimension (6,MAXERRS)
11438* Buffer in which to store integer error information. It will
11439* be built up in the following format for the call to TSEND.
11440* All integer information is recorded in the following 6-tuple
11441* {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured:
11442* SRC = RSRC * NPROCS + CSRC
11443* DEST = RDEST * NPROCS + CDEST
11444* WHAT
11445* = 1 : Error in pre-padding
11446* = 2 : Error in post-padding
11447* = 3 : Error in LDA-M gap
11448* = 4 : Error in complementory triangle
11449* ELSE: Error in matrix
11450* If there are more errors than can fit in the error buffer,
11451* the error number will indicate the actual number of errors
11452* found, but the buffer will be truncated to the maximum
11453* number of errors which can fit.
11454*
11455* ERRDBUF (output) @(doctype) array, dimension (2, MAXERRS)
11456* Buffer in which to store error data information.
11457* {Incorrect, Predicted}
11458*
11459* TFAILED (input/ourput) INTEGER array, dimension NTESTS
11460* Workspace used to keep track of which tests failed.
11461* This array not accessed unless COUNTING is true.
11462*
11463* ===================================================================
11464*
11465* .. Parameters ..
11466 INTEGER ERR_PRE, ERR_POST, ERR_GAP, ERR_TRI, ERR_MAT
11467 parameter( err_pre = 1, err_post = 2, err_gap = 3, err_tri = 4 )
11468 parameter( err_mat = 5 )
11469* ..
11470* .. External Functions ..
11471 INTEGER IBTMYPROC, IBTNPROCS
11472 EXTERNAL ibtmyproc, ibtnprocs
11473* ..
11474* .. Local Scalars ..
11475 CHARACTER*1 MAT
11476 LOGICAL MATISINT
11477 INTEGER OLDTEST, NPROCS, PROW, PCOL, I, ERRTYPE
11478* ..
11479* .. Executable Statements ..
11480*
11481 IF( (ibtmyproc().NE.0) .OR. (nerr.LE.0) ) RETURN
11482 oldtest = -1
11483 nprocs = ibtnprocs()
11484 prow = erribuf(3,1) / nprocs
11485 pcol = mod( erribuf(3,1), nprocs )
11486 IF( nerr .GT. maxerr ) WRITE(outnum,13000)
11487*
11488 DO 20 i = 1, min( nerr, maxerr )
11489 IF( erribuf(1,i) .NE. oldtest ) THEN
11490 IF( oldtest .NE. -1 )
11491 $ WRITE(outnum,12000) prow, pcol, oldtest
11492 WRITE(outnum,*) ' '
11493 WRITE(outnum,1000) prow, pcol, erribuf(1,i)
11494 IF( counting ) tfailed( erribuf(1,i) ) = 1
11495 oldtest = erribuf(1, i)
11496 END IF
11497*
11498* Print out error message depending on type of error
11499*
11500 errtype = erribuf(6, i)
11501 IF( errtype .LT. -10 ) THEN
11502 errtype = -errtype - 10
11503 mat = 'C'
11504 matisint = .true.
11505 ELSE IF( errtype .LT. 0 ) THEN
11506 errtype = -errtype
11507 mat = 'R'
11508 matisint = .true.
11509 ELSE
11510 matisint = .false.
11511 END IF
11512*
11513* RA/CA arrays from MAX/MIN have different printing protocol
11514*
11515 IF( matisint ) THEN
11516 IF( erribuf(2, i) .EQ. -1 ) THEN
11517 WRITE(outnum,11000) erribuf(4,i), erribuf(5,i), mat,
11518 $ int( errdbuf(2,i) ), int( errdbuf(1,i) )
11519 ELSE IF( errtype .EQ. err_pre ) THEN
11520 WRITE(outnum,7000) erribuf(5,i), mat,
11521 $ int( errdbuf(2,i) ), int( errdbuf(1,i) )
11522 ELSE IF( errtype .EQ. err_post ) THEN
11523 WRITE(outnum,8000) erribuf(4,i), mat,
11524 $ int( errdbuf(2,i) ), int( errdbuf(1,i) )
11525 ELSE IF( errtype .EQ. err_gap ) THEN
11526 WRITE(outnum,9000) mat, erribuf(4,i), erribuf(5,i),
11527 $ int( errdbuf(2,i) ), int( errdbuf(1,i) )
11528 ELSE
11529 WRITE(outnum,10000) mat, erribuf(4,i), erribuf(5,i),
11530 $ int( errdbuf(2,i) ),
11531 $ int( errdbuf(1,i) )
11532 END IF
11533*
11534* Have memory overwrites in matrix A
11535*
11536 ELSE
11537 IF( errtype .EQ. err_pre ) THEN
11538 WRITE(outnum,2000) erribuf(5,i),
11539 $ real( errdbuf(2,i) ), dimag( errdbuf(2,i) ),
11540 $ real( errdbuf(1,i) ), dimag( errdbuf(1,i) )
11541 ELSE IF( errtype .EQ. err_post ) THEN
11542 WRITE(outnum,3000) erribuf(4,i),
11543 $ real( errdbuf(2,i) ), dimag( errdbuf(2,i) ),
11544 $ real( errdbuf(1,i) ), dimag( errdbuf(1,i) )
11545 ELSE IF( errtype .EQ. err_gap ) THEN
11546 WRITE(outnum,4000)
11547 $ erribuf(4,i), erribuf(5,i),
11548 $ real( errdbuf(2,i) ), dimag( errdbuf(2,i) ),
11549 $ real( errdbuf(1,i) ), dimag( errdbuf(1,i) )
11550 ELSE IF( errtype .EQ. err_tri ) THEN
11551 WRITE(outnum,5000) erribuf(4,i), erribuf(5,i),
11552 $ real( errdbuf(2,i) ), dimag( errdbuf(2,i) ),
11553 $ real( errdbuf(1,i) ), dimag( errdbuf(1,i) )
11554 ELSE
11555 WRITE(outnum,6000) erribuf(4,i), erribuf(5,i),
11556 $ real( errdbuf(2,i) ), dimag( errdbuf(2,i) ),
11557 $ real( errdbuf(1,i) ), dimag( errdbuf(1,i) )
11558 END IF
11559 END IF
11560 20 CONTINUE
11561 WRITE(outnum,12000) prow, pcol, oldtest
11562*
11563 1000 FORMAT('PROCESS {',i4,',',i4,'} REPORTS ERRORS IN TEST#',i6,':')
11564 2000 FORMAT(' Buffer overwrite ',i4,
11565 $ ' elements before the start of A:',/,
11566 $ ' Expected=','[',g22.15,',',g22.15,']',
11567 $ '; Received=','[',g22.15,',',g22.15,']')
11568 3000 FORMAT(' Buffer overwrite ',i4,' elements after the end of A:',
11569 $ /,' Expected=','[',g22.15,',',g22.15,']',
11570 $ '; Received=','[',g22.15,',',g22.15,']')
11571 4000 FORMAT(' LDA-M gap overwrite at postion (',i4,',',i4,'):',/,
11572 $ ' Expected=','[',g22.15,',',g22.15,']',
11573 $ '; Received=','[',g22.15,',',g22.15,']')
11574 5000 FORMAT(' Complementory triangle overwrite at A(',i4,',',i4,
11575 $ '):',/,' Expected=','[',g22.15,',',g22.15,']',
11576 $ '; Received=','[',g22.15,',',g22.15,']')
11577 6000 FORMAT(' Invalid element at A(',i4,',',i4,'):',/,
11578 $ ' Expected=','[',g22.15,',',g22.15,']',
11579 $ '; Received=','[',g22.15,',',g22.15,']')
11580 7000 FORMAT(' Buffer overwrite ',i4,' elements before the start of ',
11581 $ a1,'A:',/,' Expected=',i12,'; Received=',i12)
11582 8000 FORMAT(' Buffer overwrite ',i4,' elements after the end of ',
11583 $ a1,'A:',/,' Expected=',i12,'; Received=',i12)
11584*
11585 9000 FORMAT(' LD',a1,'A-M gap overwrite at postion (',i4,',',i4,'):'
11586 $ ,/,' Expected=',i12,'; Received=',i12)
11587*
1158810000 FORMAT(' Invalid element at ',a1,'A(',i4,',',i4,'):',/,
11589 $ ' Expected=',i12,'; Received=',i12)
1159011000 FORMAT(' Overwrite at position (',i4,',',i4,') of non-existent '
11591 $ ,a1,'A array.',/,' Expected=',i12,'; Received=',i12)
1159212000 FORMAT('PROCESS {',i4,',',i4,'} DONE ERROR REPORT FOR TEST#',
11593 $ i6,'.')
1159413000 FORMAT('WARNING: There were more errors than could be recorded.',
11595 $ /,'Increase MEMELTS to get complete listing.')
11596 RETURN
11597*
11598* End ZPRINTERRS
11599*
11600 END
11601*
11602*
11603 SUBROUTINE isumtest( OUTNUM, VERB, TOPSREPEAT, TOPSCOHRNT, NSCOPE,
11604 $ SCOPE0, NTOP, TOP0, NMAT, M0, N0, LDAS0,
11605 $ LDAD0, NDEST, RDEST0, CDEST0, NGRID,
11606 $ CONTEXT0, P0, Q0, ISEED, MEM, MEMLEN )
11607*
11608* -- BLACS tester (version 1.0) --
11609* University of Tennessee
11610* December 15, 1994
11611*
11612*
11613* .. Scalar Arguments ..
11614 INTEGER MEMLEN, NDEST, NGRID, NMAT, NSCOPE, NTOP, OUTNUM,
11615 $ topscohrnt, topsrepeat, verb
11616* ..
11617* .. Array Arguments ..
11618 CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP)
11619 INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT)
11620 INTEGER RDEST0(NDEST), CDEST0(NDEST), CONTEXT0(NGRID)
11621 INTEGER P0(NGRID), Q0(NGRID), ISEED(*)
11622 INTEGER MEM(MEMLEN)
11623* ..
11624*
11625* Purpose
11626* =======
11627* ITESTSUM: Test integer SUM COMBINE
11628*
11629* Arguments
11630* =========
11631* OUTNUM (input) INTEGER
11632* The device number to write output to.
11633*
11634* VERB (input) INTEGER
11635* The level of verbosity (how much printing to do).
11636*
11637* NSCOPE (input) INTEGER
11638* The number of scopes to be tested.
11639*
11640* SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE)
11641* Values of the scopes to be tested.
11642*
11643* NTOP (input) INTEGER
11644* The number of topologies to be tested.
11645*
11646* TOP0 (input) CHARACTER*1 array of dimension (NTOP)
11647* Values of the topologies to be tested.
11648*
11649* NMAT (input) INTEGER
11650* The number of matrices to be tested.
11651*
11652* M0 (input) INTEGER array of dimension (NMAT)
11653* Values of M to be tested.
11654*
11655* M0 (input) INTEGER array of dimension (NMAT)
11656* Values of M to be tested.
11657*
11658* N0 (input) INTEGER array of dimension (NMAT)
11659* Values of N to be tested.
11660*
11661* LDAS0 (input) INTEGER array of dimension (NMAT)
11662* Values of LDAS (leading dimension of A on source process)
11663* to be tested.
11664*
11665* LDAD0 (input) INTEGER array of dimension (NMAT)
11666* Values of LDAD (leading dimension of A on destination
11667* process) to be tested.
11668* NDEST (input) INTEGER
11669* The number of destinations to be tested.
11670*
11671* RDEST0 (input) INTEGER array of dimension (NNDEST)
11672* Values of RDEST (row coordinate of destination) to be
11673* tested.
11674*
11675* CDEST0 (input) INTEGER array of dimension (NNDEST)
11676* Values of CDEST (column coordinate of destination) to be
11677* tested.
11678*
11679* NGRID (input) INTEGER
11680* The number of process grids to be tested.
11681*
11682* CONTEXT0 (input) INTEGER array of dimension (NGRID)
11683* The BLACS context handles corresponding to the grids.
11684*
11685* P0 (input) INTEGER array of dimension (NGRID)
11686* Values of P (number of process rows, NPROW).
11687*
11688* Q0 (input) INTEGER array of dimension (NGRID)
11689* Values of Q (number of process columns, NPCOL).
11690*
11691* ISEED (workspace) INTEGER array of dimension ( MAX(NPROCS, NTESTS) )
11692* Workspace used to hold each process's random number SEED.
11693* This requires NPROCS (number of processor) elements.
11694* If VERB < 2, this workspace also serves to indicate which
11695* tests fail. This requires workspace of NTESTS
11696* (number of tests performed).
11697*
11698* MEM (workspace) INTEGER array of dimension (MEMLEN)
11699* Used for all other workspaces, including the matrix A,
11700* and its pre and post padding.
11701*
11702* MEMLEN (input) INTEGER
11703* The length, in elements, of MEM.
11704*
11705* =====================================================================
11706*
11707* .. External Functions ..
11708 LOGICAL ALLPASS, LSAME
11709 INTEGER IBTMYPROC, IBTNPROCS, IBTSIZEOF
11710 EXTERNAL allpass, lsame, ibtmyproc, ibtnprocs, ibtsizeof
11711* ..
11712* .. External Subroutines ..
11713 EXTERNAL blacs_gridinfo, igsum2d
11714 EXTERNAL iinitmat, ichkpad, ibtcheckin
11715* ..
11716* .. Local Scalars ..
11717 CHARACTER*1 SCOPE, TOP
11718 LOGICAL INGRID, TESTOK, ALLRCV
11719 INTEGER APTR, CDEST, CDEST2, CONTEXT, ERRDPTR, ERRIPTR, I, IAM,
11720 $ IDE, IGR, IMA, IPAD, IPOST, IPRE, ISC, ISIZE, ISTART,
11721 $ ISTOP, ITC, ITC1, ITC2, ITO, ITR, ITR1, ITR2, J, K, LDA,
11722 $ LDADST, LDASRC, M, MAXERR, MYCOL, MYROW, N, NERR, NFAIL,
11723 $ NPCOL, NPROW, NSKIP, PREAPTR, RDEST, RDEST2, SETWHAT,
11724 $ TESTNUM
11725 INTEGER CHECKVAL
11726* ..
11727* .. Executable Statements ..
11728*
11729* Choose padding value, and make it unique
11730*
11731 CHECKVAL = -911
11732 iam = ibtmyproc()
11733 checkval = iam * checkval
11734 isize = ibtsizeof('I')
11735*
11736* Verify file parameters
11737*
11738 IF( iam .EQ. 0 ) THEN
11739 WRITE(outnum, *) ' '
11740 WRITE(outnum, *) ' '
11741 WRITE(outnum, 1000 )
11742 IF( verb .GT. 0 ) THEN
11743 WRITE(outnum,*) ' '
11744 WRITE(outnum, 2000) 'NSCOPE:', nscope
11745 WRITE(outnum, 3000) ' SCOPE:', ( scope0(i), i = 1, nscope )
11746 WRITE(outnum, 2000) 'TReps :', topsrepeat
11747 WRITE(outnum, 2000) 'TCohr :', topscohrnt
11748 WRITE(outnum, 2000) 'NTOP :', ntop
11749 WRITE(outnum, 3000) ' TOP :', ( top0(i), i = 1, ntop )
11750 WRITE(outnum, 2000) 'NMAT :', nmat
11751 WRITE(outnum, 2000) ' M :', ( m0(i), i = 1, nmat )
11752 WRITE(outnum, 2000) ' N :', ( n0(i), i = 1, nmat )
11753 WRITE(outnum, 2000) ' LDAS :', ( ldas0(i), i = 1, nmat )
11754 WRITE(outnum, 2000) ' LDAD :', ( ldad0(i), i = 1, nmat )
11755 WRITE(outnum, 2000) 'NDEST :', ndest
11756 WRITE(outnum, 2000) ' RDEST:',( rdest0(i), i = 1, ndest )
11757 WRITE(outnum, 2000) ' CDEST:',( cdest0(i), i = 1, ndest )
11758 WRITE(outnum, 2000) 'NGRIDS:', ngrid
11759 WRITE(outnum, 2000) ' P :', ( p0(i), i = 1, ngrid )
11760 WRITE(outnum, 2000) ' Q :', ( q0(i), i = 1, ngrid )
11761 WRITE(outnum, 2000) 'VERB :', verb
11762 WRITE(outnum,*) ' '
11763 END IF
11764 IF( verb .GT. 1 ) THEN
11765 WRITE(outnum,4000)
11766 WRITE(outnum,5000)
11767 END IF
11768 END IF
11769 IF (topsrepeat.EQ.0) THEN
11770 itr1 = 0
11771 itr2 = 0
11772 ELSE IF (topsrepeat.EQ.1) THEN
11773 itr1 = 1
11774 itr2 = 1
11775 ELSE
11776 itr1 = 0
11777 itr2 = 1
11778 END IF
11779*
11780* Find biggest matrix, so we know where to stick error info
11781*
11782 i = 0
11783 DO 10 ima = 1, nmat
11784 ipad = 4 * m0(ima)
11785 k = n0(ima) * max0( ldas0(ima), ldad0(ima) ) + ipad
11786 IF( k .GT. i ) i = k
11787 10 CONTINUE
11788 maxerr = ( isize * (memlen-i) ) / ( isize*2 + isize*6 )
11789 IF( maxerr .LT. 1 ) THEN
11790 WRITE(outnum,*) 'ERROR: Not enough memory to run SUM tests.'
11791 CALL blacs_abort(-1, 1)
11792 END IF
11793 errdptr = i + 1
11794 erriptr = errdptr + maxerr
11795 nerr = 0
11796 testnum = 0
11797 nfail = 0
11798 nskip = 0
11799*
11800* Loop over grids of matrix
11801*
11802 DO 90 igr = 1, ngrid
11803*
11804* allocate process grid for the next batch of tests
11805*
11806 context = context0(igr)
11807 CALL blacs_gridinfo( context, nprow, npcol, myrow, mycol )
11808 ingrid = ( (myrow.LT.nprow) .AND. (mycol.LT.npcol) )
11809*
11810 DO 80 isc = 1, nscope
11811 scope = scope0(isc)
11812 DO 70 ito = 1, ntop
11813 top = top0(ito)
11814*
11815* If testing multiring ('M') or general tree ('T'), need to
11816* loop over calls to BLACS_SET to do full test
11817*
11818 IF( lsame(top, 'M') ) THEN
11819 setwhat = 13
11820 IF( scope .EQ. 'R' ) THEN
11821 istart = -(npcol - 1)
11822 istop = -istart
11823 ELSE IF (scope .EQ. 'C') THEN
11824 istart = -(nprow - 1)
11825 istop = -istart
11826 ELSE
11827 istart = -(nprow*npcol - 1)
11828 istop = -istart
11829 ENDIF
11830 ELSE IF( lsame(top, 'T') ) THEN
11831 setwhat = 14
11832 istart = 1
11833 IF( scope .EQ. 'R' ) THEN
11834 istop = npcol - 1
11835 ELSE IF (scope .EQ. 'C') THEN
11836 istop = nprow - 1
11837 ELSE
11838 istop = nprow*npcol - 1
11839 ENDIF
11840 ELSE
11841 setwhat = 0
11842 istart = 1
11843 istop = 1
11844 ENDIF
11845 DO 60 ima = 1, nmat
11846 m = m0(ima)
11847 n = n0(ima)
11848 ldasrc = ldas0(ima)
11849 ldadst = ldad0(ima)
11850 ipre = 2 * m
11851 ipost = ipre
11852 preaptr = 1
11853 aptr = preaptr + ipre
11854*
11855 DO 50 ide = 1, ndest
11856 testnum = testnum + 1
11857 rdest2 = rdest0(ide)
11858 cdest2 = cdest0(ide)
11859*
11860* If everyone gets the answer, create some bogus rdest/cdest
11861* so IF's are easier
11862*
11863 allrcv = ( (rdest2.EQ.-1) .OR. (cdest2.EQ.-1) )
11864 IF( allrcv ) THEN
11865 rdest = nprow - 1
11866 cdest = npcol - 1
11867 IF (topscohrnt.EQ.0) THEN
11868 itr1 = 0
11869 itr2 = 0
11870 ELSE IF (topscohrnt.EQ.1) THEN
11871 itr1 = 1
11872 itr2 = 1
11873 ELSE
11874 itr1 = 0
11875 itr2 = 1
11876 END IF
11877 ELSE
11878 rdest = rdest2
11879 cdest = cdest2
11880 itc1 = 0
11881 itc2 = 0
11882 END IF
11883 IF( rdest.GE.p0(igr) .OR. cdest.GE.q0(igr) ) THEN
11884 nskip = nskip + 1
11885 GOTO 50
11886 END IF
11887*
11888 IF( myrow.EQ.rdest .AND. mycol.EQ.cdest ) THEN
11889 lda = ldadst
11890 ELSE
11891 lda = ldasrc
11892 END IF
11893 IF( verb .GT. 1 ) THEN
11894 IF( iam .EQ. 0 ) THEN
11895 WRITE(outnum, 6000)
11896 $ testnum, 'RUNNING', scope, top, m, n,
11897 $ ldasrc, ldadst, rdest2, cdest2,
11898 $ nprow, npcol
11899 END IF
11900 END IF
11901*
11902* If I am in scope
11903*
11904 testok = .true.
11905 IF( ingrid ) THEN
11906 IF( (myrow.EQ.rdest .AND. scope.EQ.'R') .OR.
11907 $ (mycol.EQ.cdest .AND. scope.EQ.'C') .OR.
11908 $ (scope .EQ. 'A') ) THEN
11909*
11910 k = nerr
11911 DO 40 itr = itr1, itr2
11912 CALL blacs_set(context, 15, itr)
11913 DO 35 itc = itc1, itc2
11914 CALL blacs_set(context, 16, itc)
11915 DO 30 j = istart, istop
11916 IF( j.EQ.0) GOTO 30
11917 IF( setwhat.NE.0 )
11918 $ CALL blacs_set(context, setwhat, j)
11919*
11920*
11921* generate and pad matrix A
11922*
11923 CALL iinitmat('G','-', m, n, mem(preaptr),
11924 $ lda, ipre, ipost,
11925 $ checkval, testnum,
11926 $ myrow, mycol )
11927*
11928 CALL igsum2d(context, scope, top, m, n,
11929 $ mem(aptr), lda, rdest2,
11930 $ cdest2)
11931*
11932* If I've got the answer, check for errors in
11933* matrix or padding
11934*
11935 IF( (myrow.EQ.rdest .AND. mycol.EQ.cdest)
11936 $ .OR. allrcv ) THEN
11937 CALL ichkpad('G','-', m, n,
11938 $ mem(preaptr), lda, rdest,
11939 $ cdest, myrow, mycol,
11940 $ ipre, ipost, checkval,
11941 $ testnum, maxerr, nerr,
11942 $ mem(erriptr),mem(errdptr))
11943 CALL ichksum(scope, context, m, n,
11944 $ mem(aptr), lda,
11945 $ testnum, maxerr, nerr,
11946 $ mem(erriptr),mem(errdptr),
11947 $ iseed)
11948 END IF
11949 30 CONTINUE
11950 CALL blacs_set(context, 16, 0)
11951 35 CONTINUE
11952 CALL blacs_set(context, 15, 0)
11953 40 CONTINUE
11954 testok = ( k .EQ. nerr )
11955 END IF
11956 END IF
11957*
11958 IF( verb .GT. 1 ) THEN
11959 i = nerr
11960 CALL ibtcheckin(0, outnum, maxerr, nerr,
11961 $ mem(erriptr), mem(errdptr), iseed)
11962 IF( iam .EQ. 0 ) THEN
11963 IF( testok .AND. nerr.EQ.i ) THEN
11964 WRITE(outnum,6000)testnum,'PASSED ',
11965 $ scope, top, m, n, ldasrc,
11966 $ ldadst, rdest2, cdest2,
11967 $ nprow, npcol
11968 ELSE
11969 nfail = nfail + 1
11970 WRITE(outnum,6000)testnum,'FAILED ',
11971 $ scope, top, m, n, ldasrc,
11972 $ ldadst, rdest2, cdest2,
11973 $ nprow, npcol
11974 END IF
11975 END IF
11976*
11977* Once we've printed out errors, can re-use buf space
11978*
11979 nerr = 0
11980 END IF
11981 50 CONTINUE
11982 60 CONTINUE
11983 70 CONTINUE
11984 80 CONTINUE
11985 90 CONTINUE
11986*
11987 IF( verb .LT. 2 ) THEN
11988 nfail = testnum
11989 CALL ibtcheckin( nfail, outnum, maxerr, nerr, mem(erriptr),
11990 $ mem(errdptr), iseed )
11991 END IF
11992 IF( iam .EQ. 0 ) THEN
11993 IF( verb .GT. 1 ) WRITE(outnum,*) ' '
11994 IF( nfail+nskip .EQ. 0 ) THEN
11995 WRITE(outnum, 7000 ) testnum
11996 ELSE
11997 WRITE(outnum, 8000 ) testnum, testnum-nskip-nfail,
11998 $ nskip, nfail
11999 END IF
12000 END IF
12001*
12002* Log whether their were any failures
12003*
12004 testok = allpass( (nfail.EQ.0) )
12005*
12006 1000 FORMAT('INTEGER SUM TESTS: BEGIN.' )
12007 2000 FORMAT(1x,a7,3x,10i6)
12008 3000 FORMAT(1x,a7,3x,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,
12009 $ 5x,a1,5x,a1)
12010 4000 FORMAT(' TEST# STATUS SCOPE TOP M N LDAS LDAD ',
12011 $ 'RDEST CDEST P Q')
12012 5000 FORMAT(' ----- ------- ----- --- ----- ----- ----- ----- ',
12013 $ '----- ----- ---- ----')
12014 6000 FORMAT(i6,1x,a7,5x,a1,3x,a1,6i6,2i5)
12015 7000 FORMAT('INTEGER SUM TESTS: PASSED ALL',
12016 $ i5, ' TESTS.')
12017 8000 FORMAT('INTEGER SUM TESTS:',i5,' TESTS;',i5,' PASSED,',
12018 $ i5,' SKIPPED,',i5,' FAILED.')
12019*
12020 RETURN
12021*
12022* End of ITESTSUM.
12023*
12024 END
12025*
12026 INTEGER FUNCTION ibtabs(VAL)
12027 INTEGER val
12028 ibtabs = abs(val)
12029 RETURN
12030 END
12031*
12032 SUBROUTINE ichksum( SCOPE, ICTXT, M, N, A, LDA, TESTNUM, MAXERR,
12033 $ NERR, ERRIBUF, ERRDBUF, ISEED )
12034*
12035* .. Scalar Arguments ..
12036 CHARACTER*1 SCOPE
12037 INTEGER ICTXT, M, N, LDA, TESTNUM, MAXERR, NERR
12038* ..
12039* .. Array Arguments ..
12040 INTEGER ERRIBUF(6, MAXERR), ISEED(*)
12041 INTEGER A(LDA,*), ERRDBUF(2, MAXERR)
12042* ..
12043* .. External Functions ..
12044 INTEGER IBTMYPROC, IBTNPROCS
12045 INTEGER IBTRAN
12046 EXTERNAL ibtmyproc, ibtnprocs, ibtran
12047* ..
12048* .. Local Scalars ..
12049 INTEGER NPROCS, NPROW, NPCOL, MYROW, MYCOL, NODE, NNODES, DEST
12050 INTEGER I, J, K
12051 INTEGER ANS
12052* ..
12053* .. Executable Statements ..
12054*
12055 nprocs = ibtnprocs()
12056 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
12057 dest = myrow*nprocs + mycol
12058*
12059* Set up seeds to match those used by each proc's genmat call
12060*
12061 IF( scope .EQ. 'R' ) THEN
12062 nnodes = npcol
12063 DO 10 i = 0, nnodes-1
12064 node = myrow * nprocs + i
12065 iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
12066 iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
12067 iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
12068 iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
12069 10 CONTINUE
12070 ELSE IF( scope .EQ. 'C' ) THEN
12071 nnodes = nprow
12072 DO 20 i = 0, nnodes-1
12073 node = i * nprocs + mycol
12074 iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
12075 iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
12076 iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
12077 iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
12078 20 CONTINUE
12079 ELSE
12080 nnodes = nprow * npcol
12081 DO 30 i = 0, nnodes-1
12082 node = (i / npcol) * nprocs + mod(i, npcol)
12083 iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
12084 iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
12085 iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
12086 iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
12087 30 CONTINUE
12088 END IF
12089*
12090 DO 100 j = 1, n
12091 DO 90 i = 1, m
12092 ans = 0
12093 DO 40 k = 0, nnodes-1
12094 ans = ans + ibtran( iseed(k*4+1) )
12095 40 CONTINUE
12096*
12097* The error bound is figured by
12098* 2 * eps * (nnodes-1) * max(|max element|, |ans|).
12099* The 2 allows for errors in the distributed _AND_ local result.
12100* The eps is machine epsilon. The number of floating point adds
12101* is (nnodes - 1). We use the fact that 0.5 is the maximum element
12102* in order to save ourselves some computation.
12103*
12104 IF( ans .NE. a(i,j) ) THEN
12105 nerr = nerr + 1
12106 IF( nerr .LE. maxerr ) THEN
12107 erribuf(1, nerr) = testnum
12108 erribuf(2, nerr) = nnodes
12109 erribuf(3, nerr) = dest
12110 erribuf(4, nerr) = i
12111 erribuf(5, nerr) = j
12112 erribuf(6, nerr) = 5
12113 errdbuf(1, nerr) = a(i,j)
12114 errdbuf(2, nerr) = ans
12115 END IF
12116 END IF
12117 90 CONTINUE
12118 100 CONTINUE
12119*
12120 RETURN
12121*
12122* End of ICHKSUM
12123*
12124 END
12125*
12126*
12127 SUBROUTINE ssumtest( OUTNUM, VERB, TOPSREPEAT, TOPSCOHRNT, NSCOPE,
12128 $ SCOPE0, NTOP, TOP0, NMAT, M0, N0, LDAS0,
12129 $ LDAD0, NDEST, RDEST0, CDEST0, NGRID,
12130 $ CONTEXT0, P0, Q0, ISEED, MEM, MEMLEN )
12131*
12132* -- BLACS tester (version 1.0) --
12133* University of Tennessee
12134* December 15, 1994
12135*
12136*
12137* .. Scalar Arguments ..
12138 INTEGER MEMLEN, NDEST, NGRID, NMAT, NSCOPE, NTOP, OUTNUM,
12139 $ topscohrnt, topsrepeat, verb
12140* ..
12141* .. Array Arguments ..
12142 CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP)
12143 INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT)
12144 INTEGER RDEST0(NDEST), CDEST0(NDEST), CONTEXT0(NGRID)
12145 INTEGER P0(NGRID), Q0(NGRID), ISEED(*)
12146 REAL MEM(MEMLEN)
12147* ..
12148*
12149* Purpose
12150* =======
12151* STESTSUM: Test real SUM COMBINE
12152*
12153* Arguments
12154* =========
12155* OUTNUM (input) INTEGER
12156* The device number to write output to.
12157*
12158* VERB (input) INTEGER
12159* The level of verbosity (how much printing to do).
12160*
12161* NSCOPE (input) INTEGER
12162* The number of scopes to be tested.
12163*
12164* SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE)
12165* Values of the scopes to be tested.
12166*
12167* NTOP (input) INTEGER
12168* The number of topologies to be tested.
12169*
12170* TOP0 (input) CHARACTER*1 array of dimension (NTOP)
12171* Values of the topologies to be tested.
12172*
12173* NMAT (input) INTEGER
12174* The number of matrices to be tested.
12175*
12176* M0 (input) INTEGER array of dimension (NMAT)
12177* Values of M to be tested.
12178*
12179* M0 (input) INTEGER array of dimension (NMAT)
12180* Values of M to be tested.
12181*
12182* N0 (input) INTEGER array of dimension (NMAT)
12183* Values of N to be tested.
12184*
12185* LDAS0 (input) INTEGER array of dimension (NMAT)
12186* Values of LDAS (leading dimension of A on source process)
12187* to be tested.
12188*
12189* LDAD0 (input) INTEGER array of dimension (NMAT)
12190* Values of LDAD (leading dimension of A on destination
12191* process) to be tested.
12192* NDEST (input) INTEGER
12193* The number of destinations to be tested.
12194*
12195* RDEST0 (input) INTEGER array of dimension (NNDEST)
12196* Values of RDEST (row coordinate of destination) to be
12197* tested.
12198*
12199* CDEST0 (input) INTEGER array of dimension (NNDEST)
12200* Values of CDEST (column coordinate of destination) to be
12201* tested.
12202*
12203* NGRID (input) INTEGER
12204* The number of process grids to be tested.
12205*
12206* CONTEXT0 (input) INTEGER array of dimension (NGRID)
12207* The BLACS context handles corresponding to the grids.
12208*
12209* P0 (input) INTEGER array of dimension (NGRID)
12210* Values of P (number of process rows, NPROW).
12211*
12212* Q0 (input) INTEGER array of dimension (NGRID)
12213* Values of Q (number of process columns, NPCOL).
12214*
12215* ISEED (workspace) INTEGER array of dimension ( MAX(NPROCS, NTESTS) )
12216* Workspace used to hold each process's random number SEED.
12217* This requires NPROCS (number of processor) elements.
12218* If VERB < 2, this workspace also serves to indicate which
12219* tests fail. This requires workspace of NTESTS
12220* (number of tests performed).
12221*
12222* MEM (workspace) REAL array of dimension (MEMLEN)
12223* Used for all other workspaces, including the matrix A,
12224* and its pre and post padding.
12225*
12226* MEMLEN (input) INTEGER
12227* The length, in elements, of MEM.
12228*
12229* =====================================================================
12230*
12231* .. External Functions ..
12232 LOGICAL ALLPASS, LSAME
12233 INTEGER IBTMYPROC, IBTNPROCS, IBTSIZEOF
12234 EXTERNAL ALLPASS, LSAME, IBTMYPROC, IBTNPROCS, IBTSIZEOF
12235* ..
12236* .. External Subroutines ..
12237 EXTERNAL blacs_gridinfo, sgsum2d
12238 EXTERNAL sinitmat, schkpad, sbtcheckin
12239* ..
12240* .. Local Scalars ..
12241 CHARACTER*1 SCOPE, TOP
12242 LOGICAL INGRID, TESTOK, ALLRCV
12243 INTEGER APTR, CDEST, CDEST2, CONTEXT, ERRDPTR, ERRIPTR, I, IAM,
12244 $ IDE, IGR, IMA, IPAD, IPOST, IPRE, ISC, ISIZE, ISTART,
12245 $ ISTOP, ITC, ITC1, ITC2, ITO, ITR, ITR1, ITR2, J, K, LDA,
12246 $ LDADST, LDASRC, M, MAXERR, MYCOL, MYROW, N, NERR, NFAIL,
12247 $ NPCOL, NPROW, NSKIP, PREAPTR, RDEST, RDEST2, SETWHAT,
12248 $ SSIZE, TESTNUM
12249 REAL CHECKVAL
12250* ..
12251* .. Executable Statements ..
12252*
12253* Choose padding value, and make it unique
12254*
12255 CHECKVAL = -0.61e0
12256 iam = ibtmyproc()
12257 checkval = iam * checkval
12258 isize = ibtsizeof('I')
12259 ssize = ibtsizeof('S')
12260*
12261* Verify file parameters
12262*
12263 IF( iam .EQ. 0 ) THEN
12264 WRITE(outnum, *) ' '
12265 WRITE(outnum, *) ' '
12266 WRITE(outnum, 1000 )
12267 IF( verb .GT. 0 ) THEN
12268 WRITE(outnum,*) ' '
12269 WRITE(outnum, 2000) 'NSCOPE:', nscope
12270 WRITE(outnum, 3000) ' SCOPE:', ( scope0(i), i = 1, nscope )
12271 WRITE(outnum, 2000) 'TReps :', topsrepeat
12272 WRITE(outnum, 2000) 'TCohr :', topscohrnt
12273 WRITE(outnum, 2000) 'NTOP :', ntop
12274 WRITE(outnum, 3000) ' TOP :', ( top0(i), i = 1, ntop )
12275 WRITE(outnum, 2000) 'NMAT :', nmat
12276 WRITE(outnum, 2000) ' M :', ( m0(i), i = 1, nmat )
12277 WRITE(outnum, 2000) ' N :', ( n0(i), i = 1, nmat )
12278 WRITE(outnum, 2000) ' LDAS :', ( ldas0(i), i = 1, nmat )
12279 WRITE(outnum, 2000) ' LDAD :', ( ldad0(i), i = 1, nmat )
12280 WRITE(outnum, 2000) 'NDEST :', ndest
12281 WRITE(outnum, 2000) ' RDEST:',( rdest0(i), i = 1, ndest )
12282 WRITE(outnum, 2000) ' CDEST:',( cdest0(i), i = 1, ndest )
12283 WRITE(outnum, 2000) 'NGRIDS:', ngrid
12284 WRITE(outnum, 2000) ' P :', ( p0(i), i = 1, ngrid )
12285 WRITE(outnum, 2000) ' Q :', ( q0(i), i = 1, ngrid )
12286 WRITE(outnum, 2000) 'VERB :', verb
12287 WRITE(outnum,*) ' '
12288 END IF
12289 IF( verb .GT. 1 ) THEN
12290 WRITE(outnum,4000)
12291 WRITE(outnum,5000)
12292 END IF
12293 END IF
12294 IF (topsrepeat.EQ.0) THEN
12295 itr1 = 0
12296 itr2 = 0
12297 ELSE IF (topsrepeat.EQ.1) THEN
12298 itr1 = 1
12299 itr2 = 1
12300 ELSE
12301 itr1 = 0
12302 itr2 = 1
12303 END IF
12304*
12305* Find biggest matrix, so we know where to stick error info
12306*
12307 i = 0
12308 DO 10 ima = 1, nmat
12309 ipad = 4 * m0(ima)
12310 k = n0(ima) * max0( ldas0(ima), ldad0(ima) ) + ipad
12311 IF( k .GT. i ) i = k
12312 10 CONTINUE
12313 maxerr = ( ssize * (memlen-i) ) / ( ssize*2 + isize*6 )
12314 IF( maxerr .LT. 1 ) THEN
12315 WRITE(outnum,*) 'ERROR: Not enough memory to run SUM tests.'
12316 CALL blacs_abort(-1, 1)
12317 END IF
12318 errdptr = i + 1
12319 erriptr = errdptr + maxerr
12320 nerr = 0
12321 testnum = 0
12322 nfail = 0
12323 nskip = 0
12324*
12325* Loop over grids of matrix
12326*
12327 DO 90 igr = 1, ngrid
12328*
12329* allocate process grid for the next batch of tests
12330*
12331 context = context0(igr)
12332 CALL blacs_gridinfo( context, nprow, npcol, myrow, mycol )
12333 ingrid = ( (myrow.LT.nprow) .AND. (mycol.LT.npcol) )
12334*
12335 DO 80 isc = 1, nscope
12336 scope = scope0(isc)
12337 DO 70 ito = 1, ntop
12338 top = top0(ito)
12339*
12340* If testing multiring ('M') or general tree ('T'), need to
12341* loop over calls to BLACS_SET to do full test
12342*
12343 IF( lsame(top, 'M') ) THEN
12344 setwhat = 13
12345 IF( scope .EQ. 'R' ) THEN
12346 istart = -(npcol - 1)
12347 istop = -istart
12348 ELSE IF (scope .EQ. 'C') THEN
12349 istart = -(nprow - 1)
12350 istop = -istart
12351 ELSE
12352 istart = -(nprow*npcol - 1)
12353 istop = -istart
12354 ENDIF
12355 ELSE IF( lsame(top, 'T') ) THEN
12356 setwhat = 14
12357 istart = 1
12358 IF( scope .EQ. 'R' ) THEN
12359 istop = npcol - 1
12360 ELSE IF (scope .EQ. 'C') THEN
12361 istop = nprow - 1
12362 ELSE
12363 istop = nprow*npcol - 1
12364 ENDIF
12365 ELSE
12366 setwhat = 0
12367 istart = 1
12368 istop = 1
12369 ENDIF
12370 DO 60 ima = 1, nmat
12371 m = m0(ima)
12372 n = n0(ima)
12373 ldasrc = ldas0(ima)
12374 ldadst = ldad0(ima)
12375 ipre = 2 * m
12376 ipost = ipre
12377 preaptr = 1
12378 aptr = preaptr + ipre
12379*
12380 DO 50 ide = 1, ndest
12381 testnum = testnum + 1
12382 rdest2 = rdest0(ide)
12383 cdest2 = cdest0(ide)
12384*
12385* If everyone gets the answer, create some bogus rdest/cdest
12386* so IF's are easier
12387*
12388 allrcv = ( (rdest2.EQ.-1) .OR. (cdest2.EQ.-1) )
12389 IF( allrcv ) THEN
12390 rdest = nprow - 1
12391 cdest = npcol - 1
12392 IF (topscohrnt.EQ.0) THEN
12393 itr1 = 0
12394 itr2 = 0
12395 ELSE IF (topscohrnt.EQ.1) THEN
12396 itr1 = 1
12397 itr2 = 1
12398 ELSE
12399 itr1 = 0
12400 itr2 = 1
12401 END IF
12402 ELSE
12403 rdest = rdest2
12404 cdest = cdest2
12405 itc1 = 0
12406 itc2 = 0
12407 END IF
12408 IF( rdest.GE.p0(igr) .OR. cdest.GE.q0(igr) ) THEN
12409 nskip = nskip + 1
12410 GOTO 50
12411 END IF
12412*
12413 IF( myrow.EQ.rdest .AND. mycol.EQ.cdest ) THEN
12414 lda = ldadst
12415 ELSE
12416 lda = ldasrc
12417 END IF
12418 IF( verb .GT. 1 ) THEN
12419 IF( iam .EQ. 0 ) THEN
12420 WRITE(outnum, 6000)
12421 $ testnum, 'RUNNING', scope, top, m, n,
12422 $ ldasrc, ldadst, rdest2, cdest2,
12423 $ nprow, npcol
12424 END IF
12425 END IF
12426*
12427* If I am in scope
12428*
12429 testok = .true.
12430 IF( ingrid ) THEN
12431 IF( (myrow.EQ.rdest .AND. scope.EQ.'R') .OR.
12432 $ (mycol.EQ.cdest .AND. scope.EQ.'C') .OR.
12433 $ (scope .EQ. 'A') ) THEN
12434*
12435 k = nerr
12436 DO 40 itr = itr1, itr2
12437 CALL blacs_set(context, 15, itr)
12438 DO 35 itc = itc1, itc2
12439 CALL blacs_set(context, 16, itc)
12440 DO 30 j = istart, istop
12441 IF( j.EQ.0) GOTO 30
12442 IF( setwhat.NE.0 )
12443 $ CALL blacs_set(context, setwhat, j)
12444*
12445*
12446* generate and pad matrix A
12447*
12448 CALL sinitmat('G','-', m, n, mem(preaptr),
12449 $ lda, ipre, ipost,
12450 $ checkval, testnum,
12451 $ myrow, mycol )
12452*
12453 CALL sgsum2d(context, scope, top, m, n,
12454 $ mem(aptr), lda, rdest2,
12455 $ cdest2)
12456*
12457* If I've got the answer, check for errors in
12458* matrix or padding
12459*
12460 IF( (myrow.EQ.rdest .AND. mycol.EQ.cdest)
12461 $ .OR. allrcv ) THEN
12462 CALL schkpad('G','-', m, n,
12463 $ mem(preaptr), lda, rdest,
12464 $ cdest, myrow, mycol,
12465 $ ipre, ipost, checkval,
12466 $ testnum, maxerr, nerr,
12467 $ mem(erriptr),mem(errdptr))
12468 CALL schksum(scope, context, m, n,
12469 $ mem(aptr), lda,
12470 $ testnum, maxerr, nerr,
12471 $ mem(erriptr),mem(errdptr),
12472 $ iseed)
12473 END IF
12474 30 CONTINUE
12475 CALL blacs_set(context, 16, 0)
12476 35 CONTINUE
12477 CALL blacs_set(context, 15, 0)
12478 40 CONTINUE
12479 testok = ( k .EQ. nerr )
12480 END IF
12481 END IF
12482*
12483 IF( verb .GT. 1 ) THEN
12484 i = nerr
12485 CALL sbtcheckin(0, outnum, maxerr, nerr,
12486 $ mem(erriptr), mem(errdptr), iseed)
12487 IF( iam .EQ. 0 ) THEN
12488 IF( testok .AND. nerr.EQ.i ) THEN
12489 WRITE(outnum,6000)testnum,'PASSED ',
12490 $ scope, top, m, n, ldasrc,
12491 $ ldadst, rdest2, cdest2,
12492 $ nprow, npcol
12493 ELSE
12494 nfail = nfail + 1
12495 WRITE(outnum,6000)testnum,'FAILED ',
12496 $ scope, top, m, n, ldasrc,
12497 $ ldadst, rdest2, cdest2,
12498 $ nprow, npcol
12499 END IF
12500 END IF
12501*
12502* Once we've printed out errors, can re-use buf space
12503*
12504 nerr = 0
12505 END IF
12506 50 CONTINUE
12507 60 CONTINUE
12508 70 CONTINUE
12509 80 CONTINUE
12510 90 CONTINUE
12511*
12512 IF( verb .LT. 2 ) THEN
12513 nfail = testnum
12514 CALL sbtcheckin( nfail, outnum, maxerr, nerr, mem(erriptr),
12515 $ mem(errdptr), iseed )
12516 END IF
12517 IF( iam .EQ. 0 ) THEN
12518 IF( verb .GT. 1 ) WRITE(outnum,*) ' '
12519 IF( nfail+nskip .EQ. 0 ) THEN
12520 WRITE(outnum, 7000 ) testnum
12521 ELSE
12522 WRITE(outnum, 8000 ) testnum, testnum-nskip-nfail,
12523 $ nskip, nfail
12524 END IF
12525 END IF
12526*
12527* Log whether their were any failures
12528*
12529 testok = allpass( (nfail.EQ.0) )
12530*
12531 1000 FORMAT('REAL SUM TESTS: BEGIN.' )
12532 2000 FORMAT(1x,a7,3x,10i6)
12533 3000 FORMAT(1x,a7,3x,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,
12534 $ 5x,a1,5x,a1)
12535 4000 FORMAT(' TEST# STATUS SCOPE TOP M N LDAS LDAD ',
12536 $ 'RDEST CDEST P Q')
12537 5000 FORMAT(' ----- ------- ----- --- ----- ----- ----- ----- ',
12538 $ '----- ----- ---- ----')
12539 6000 FORMAT(i6,1x,a7,5x,a1,3x,a1,6i6,2i5)
12540 7000 FORMAT('REAL SUM TESTS: PASSED ALL',
12541 $ i5, ' TESTS.')
12542 8000 FORMAT('REAL SUM TESTS:',i5,' TESTS;',i5,' PASSED,',
12543 $ i5,' SKIPPED,',i5,' FAILED.')
12544*
12545 RETURN
12546*
12547* End of STESTSUM.
12548*
12549 END
12550*
12551 REAL function sbtabs(val)
12552 REAL val
12553 sbtabs = abs(val)
12554 RETURN
12555 END
12556*
12557 REAL function sbteps()
12558*
12559* .. External Functions ..
12560 INTEGER ibtmyproc, ibtnprocs, ibtmsgid
12561 REAL slamch
12562 EXTERNAL ibtmyproc, ibtnprocs, ibtmsgid, slamch
12563* ..
12564* .. Local Scalars ..
12565 INTEGER i, iam, nnodes
12566 REAL eps, eps2
12567 SAVE eps
12568 DATA eps /-22.0e0/
12569* ..
12570* .. Executable Statements ..
12571*
12572* First time called, must get max epsilon possessed by any
12573* participating process
12574*
12575 IF( eps .EQ. -22.0e0 ) THEN
12576 iam = ibtmyproc()
12577 nnodes = ibtnprocs()
12578 eps = slamch('epsilon')
12579 IF( iam .EQ. 0 ) THEN
12580 IF( nnodes .GT. 1 ) THEN
12581 DO 10 i = 1, nnodes-1
12582 CALL btrecv( 4, 1, eps2, i, ibtmsgid()+20 )
12583 IF( eps .LT. eps2 ) eps = eps2
12584 10 CONTINUE
12585 END IF
12586 CALL btsend( 4, 1, eps, -1, ibtmsgid()+20 )
12587 ELSE
12588 CALL btsend( 4, 1, eps, 0, ibtmsgid()+20 )
12589 CALL btrecv( 4, 1, eps, 0, ibtmsgid()+20 )
12590 ENDIF
12591 END IF
12592 sbteps = eps
12593 RETURN
12594*
12595* End SBTEPS
12596*
12597 END
12598*
12599 SUBROUTINE schksum( SCOPE, ICTXT, M, N, A, LDA, TESTNUM, MAXERR,
12600 $ NERR, ERRIBUF, ERRDBUF, ISEED )
12601*
12602* .. Scalar Arguments ..
12603 CHARACTER*1 SCOPE
12604 INTEGER ICTXT, M, N, LDA, TESTNUM, MAXERR, NERR
12605* ..
12606* .. Array Arguments ..
12607 INTEGER ERRIBUF(6, MAXERR), ISEED(*)
12608 REAL A(LDA,*), ERRDBUF(2, MAXERR)
12609* ..
12610* .. External Functions ..
12611 INTEGER IBTMYPROC, IBTNPROCS
12612 REAL SBTEPS
12613 REAL SBTRAN
12614 EXTERNAL ibtmyproc, ibtnprocs, sbteps, sbtran
12615* ..
12616* .. Local Scalars ..
12617 INTEGER NPROCS, NPROW, NPCOL, MYROW, MYCOL, NODE, NNODES, DEST
12618 INTEGER I, J, K
12619 REAL ANS, EPS, ERRBND, POSNUM, NEGNUM, TMP
12620* ..
12621* .. Executable Statements ..
12622*
12623 nprocs = ibtnprocs()
12624 eps = sbteps()
12625 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
12626 dest = myrow*nprocs + mycol
12627*
12628* Set up seeds to match those used by each proc's genmat call
12629*
12630 IF( scope .EQ. 'R' ) THEN
12631 nnodes = npcol
12632 DO 10 i = 0, nnodes-1
12633 node = myrow * nprocs + i
12634 iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
12635 iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
12636 iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
12637 iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
12638 10 CONTINUE
12639 ELSE IF( scope .EQ. 'C' ) THEN
12640 nnodes = nprow
12641 DO 20 i = 0, nnodes-1
12642 node = i * nprocs + mycol
12643 iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
12644 iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
12645 iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
12646 iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
12647 20 CONTINUE
12648 ELSE
12649 nnodes = nprow * npcol
12650 DO 30 i = 0, nnodes-1
12651 node = (i / npcol) * nprocs + mod(i, npcol)
12652 iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
12653 iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
12654 iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
12655 iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
12656 30 CONTINUE
12657 END IF
12658*
12659 DO 100 j = 1, n
12660 DO 90 i = 1, m
12661 ans = 0
12662 posnum = 0
12663 negnum = 0
12664 DO 40 k = 0, nnodes-1
12665 tmp = sbtran( iseed(k*4+1) )
12666 IF( tmp .LT. 0 ) THEN
12667 negnum = negnum + tmp
12668 ELSE
12669 posnum = posnum + tmp
12670 END IF
12671 ans = ans + tmp
12672 40 CONTINUE
12673*
12674* The error bound is figured by
12675* 2 * eps * (nnodes-1) * max(|max element|, |ans|).
12676* The 2 allows for errors in the distributed _AND_ local result.
12677* The eps is machine epsilon. The number of floating point adds
12678* is (nnodes - 1). We use the fact that 0.5 is the maximum element
12679* in order to save ourselves some computation.
12680*
12681 errbnd = 2 * eps * nnodes * max( posnum, -negnum )
12682 IF( abs( ans - a(i,j) ) .GT. errbnd ) THEN
12683 nerr = nerr + 1
12684 IF( nerr .LE. maxerr ) THEN
12685 erribuf(1, nerr) = testnum
12686 erribuf(2, nerr) = nnodes
12687 erribuf(3, nerr) = dest
12688 erribuf(4, nerr) = i
12689 erribuf(5, nerr) = j
12690 erribuf(6, nerr) = 5
12691 errdbuf(1, nerr) = a(i,j)
12692 errdbuf(2, nerr) = ans
12693 END IF
12694 END IF
12695 90 CONTINUE
12696 100 CONTINUE
12697*
12698 RETURN
12699*
12700* End of SCHKSUM
12701*
12702 END
12703*
12704*
12705 SUBROUTINE dsumtest( OUTNUM, VERB, TOPSREPEAT, TOPSCOHRNT, NSCOPE,
12706 $ SCOPE0, NTOP, TOP0, NMAT, M0, N0, LDAS0,
12707 $ LDAD0, NDEST, RDEST0, CDEST0, NGRID,
12708 $ CONTEXT0, P0, Q0, ISEED, MEM, MEMLEN )
12709*
12710* -- BLACS tester (version 1.0) --
12711* University of Tennessee
12712* December 15, 1994
12713*
12714*
12715* .. Scalar Arguments ..
12716 INTEGER MEMLEN, NDEST, NGRID, NMAT, NSCOPE, NTOP, OUTNUM,
12717 $ TOPSCOHRNT, TOPSREPEAT, VERB
12718* ..
12719* .. Array Arguments ..
12720 CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP)
12721 INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT)
12722 INTEGER RDEST0(NDEST), CDEST0(NDEST), CONTEXT0(NGRID)
12723 INTEGER P0(NGRID), Q0(NGRID), ISEED(*)
12724 DOUBLE PRECISION MEM(MEMLEN)
12725* ..
12726*
12727* Purpose
12728* =======
12729* DTESTSUM: Test double precision SUM COMBINE
12730*
12731* Arguments
12732* =========
12733* OUTNUM (input) INTEGER
12734* The device number to write output to.
12735*
12736* VERB (input) INTEGER
12737* The level of verbosity (how much printing to do).
12738*
12739* NSCOPE (input) INTEGER
12740* The number of scopes to be tested.
12741*
12742* SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE)
12743* Values of the scopes to be tested.
12744*
12745* NTOP (input) INTEGER
12746* The number of topologies to be tested.
12747*
12748* TOP0 (input) CHARACTER*1 array of dimension (NTOP)
12749* Values of the topologies to be tested.
12750*
12751* NMAT (input) INTEGER
12752* The number of matrices to be tested.
12753*
12754* M0 (input) INTEGER array of dimension (NMAT)
12755* Values of M to be tested.
12756*
12757* M0 (input) INTEGER array of dimension (NMAT)
12758* Values of M to be tested.
12759*
12760* N0 (input) INTEGER array of dimension (NMAT)
12761* Values of N to be tested.
12762*
12763* LDAS0 (input) INTEGER array of dimension (NMAT)
12764* Values of LDAS (leading dimension of A on source process)
12765* to be tested.
12766*
12767* LDAD0 (input) INTEGER array of dimension (NMAT)
12768* Values of LDAD (leading dimension of A on destination
12769* process) to be tested.
12770* NDEST (input) INTEGER
12771* The number of destinations to be tested.
12772*
12773* RDEST0 (input) INTEGER array of dimension (NNDEST)
12774* Values of RDEST (row coordinate of destination) to be
12775* tested.
12776*
12777* CDEST0 (input) INTEGER array of dimension (NNDEST)
12778* Values of CDEST (column coordinate of destination) to be
12779* tested.
12780*
12781* NGRID (input) INTEGER
12782* The number of process grids to be tested.
12783*
12784* CONTEXT0 (input) INTEGER array of dimension (NGRID)
12785* The BLACS context handles corresponding to the grids.
12786*
12787* P0 (input) INTEGER array of dimension (NGRID)
12788* Values of P (number of process rows, NPROW).
12789*
12790* Q0 (input) INTEGER array of dimension (NGRID)
12791* Values of Q (number of process columns, NPCOL).
12792*
12793* ISEED (workspace) INTEGER array of dimension ( MAX(NPROCS, NTESTS) )
12794* Workspace used to hold each process's random number SEED.
12795* This requires NPROCS (number of processor) elements.
12796* If VERB < 2, this workspace also serves to indicate which
12797* tests fail. This requires workspace of NTESTS
12798* (number of tests performed).
12799*
12800* MEM (workspace) DOUBLE PRECISION array of dimension (MEMLEN)
12801* Used for all other workspaces, including the matrix A,
12802* and its pre and post padding.
12803*
12804* MEMLEN (input) INTEGER
12805* The length, in elements, of MEM.
12806*
12807* =====================================================================
12808*
12809* .. External Functions ..
12810 LOGICAL ALLPASS, LSAME
12811 INTEGER IBTMYPROC, IBTNPROCS, IBTSIZEOF
12812 EXTERNAL ALLPASS, LSAME, IBTMYPROC, IBTNPROCS, IBTSIZEOF
12813* ..
12814* .. External Subroutines ..
12815 EXTERNAL blacs_gridinfo, dgsum2d
12816 EXTERNAL dinitmat, dchkpad, dbtcheckin
12817* ..
12818* .. Local Scalars ..
12819 CHARACTER*1 SCOPE, TOP
12820 LOGICAL INGRID, TESTOK, ALLRCV
12821 INTEGER APTR, CDEST, CDEST2, CONTEXT, DSIZE, ERRDPTR, ERRIPTR, I,
12822 $ IAM, IDE, IGR, IMA, IPAD, IPOST, IPRE, ISC, ISIZE, ISTART,
12823 $ ISTOP, ITC, ITC1, ITC2, ITO, ITR, ITR1, ITR2, J, K, LDA,
12824 $ LDADST, LDASRC, M, MAXERR, MYCOL, MYROW, N, NERR, NFAIL,
12825 $ NPCOL, NPROW, NSKIP, PREAPTR, RDEST, RDEST2, SETWHAT,
12826 $ TESTNUM
12827 DOUBLE PRECISION CHECKVAL
12828* ..
12829* .. Executable Statements ..
12830*
12831* Choose padding value, and make it unique
12832*
12833 CHECKVAL = -0.81d0
12834 iam = ibtmyproc()
12835 checkval = iam * checkval
12836 isize = ibtsizeof('I')
12837 dsize = ibtsizeof('D')
12838*
12839* Verify file parameters
12840*
12841 IF( iam .EQ. 0 ) THEN
12842 WRITE(outnum, *) ' '
12843 WRITE(outnum, *) ' '
12844 WRITE(outnum, 1000 )
12845 IF( verb .GT. 0 ) THEN
12846 WRITE(outnum,*) ' '
12847 WRITE(outnum, 2000) 'NSCOPE:', nscope
12848 WRITE(outnum, 3000) ' SCOPE:', ( scope0(i), i = 1, nscope )
12849 WRITE(outnum, 2000) 'TReps :', topsrepeat
12850 WRITE(outnum, 2000) 'TCohr :', topscohrnt
12851 WRITE(outnum, 2000) 'NTOP :', ntop
12852 WRITE(outnum, 3000) ' TOP :', ( top0(i), i = 1, ntop )
12853 WRITE(outnum, 2000) 'NMAT :', nmat
12854 WRITE(outnum, 2000) ' M :', ( m0(i), i = 1, nmat )
12855 WRITE(outnum, 2000) ' N :', ( n0(i), i = 1, nmat )
12856 WRITE(outnum, 2000) ' LDAS :', ( ldas0(i), i = 1, nmat )
12857 WRITE(outnum, 2000) ' LDAD :', ( ldad0(i), i = 1, nmat )
12858 WRITE(outnum, 2000) 'NDEST :', ndest
12859 WRITE(outnum, 2000) ' RDEST:',( rdest0(i), i = 1, ndest )
12860 WRITE(outnum, 2000) ' CDEST:',( cdest0(i), i = 1, ndest )
12861 WRITE(outnum, 2000) 'NGRIDS:', ngrid
12862 WRITE(outnum, 2000) ' P :', ( p0(i), i = 1, ngrid )
12863 WRITE(outnum, 2000) ' Q :', ( q0(i), i = 1, ngrid )
12864 WRITE(outnum, 2000) 'VERB :', verb
12865 WRITE(outnum,*) ' '
12866 END IF
12867 IF( verb .GT. 1 ) THEN
12868 WRITE(outnum,4000)
12869 WRITE(outnum,5000)
12870 END IF
12871 END IF
12872 IF (topsrepeat.EQ.0) THEN
12873 itr1 = 0
12874 itr2 = 0
12875 ELSE IF (topsrepeat.EQ.1) THEN
12876 itr1 = 1
12877 itr2 = 1
12878 ELSE
12879 itr1 = 0
12880 itr2 = 1
12881 END IF
12882*
12883* Find biggest matrix, so we know where to stick error info
12884*
12885 i = 0
12886 DO 10 ima = 1, nmat
12887 ipad = 4 * m0(ima)
12888 k = n0(ima) * max0( ldas0(ima), ldad0(ima) ) + ipad
12889 IF( k .GT. i ) i = k
12890 10 CONTINUE
12891 maxerr = ( dsize * (memlen-i) ) / ( dsize*2 + isize*6 )
12892 IF( maxerr .LT. 1 ) THEN
12893 WRITE(outnum,*) 'ERROR: Not enough memory to run SUM tests.'
12894 CALL blacs_abort(-1, 1)
12895 END IF
12896 errdptr = i + 1
12897 erriptr = errdptr + maxerr
12898 nerr = 0
12899 testnum = 0
12900 nfail = 0
12901 nskip = 0
12902*
12903* Loop over grids of matrix
12904*
12905 DO 90 igr = 1, ngrid
12906*
12907* allocate process grid for the next batch of tests
12908*
12909 context = context0(igr)
12910 CALL blacs_gridinfo( context, nprow, npcol, myrow, mycol )
12911 ingrid = ( (myrow.LT.nprow) .AND. (mycol.LT.npcol) )
12912*
12913 DO 80 isc = 1, nscope
12914 scope = scope0(isc)
12915 DO 70 ito = 1, ntop
12916 top = top0(ito)
12917*
12918* If testing multiring ('M') or general tree ('T'), need to
12919* loop over calls to BLACS_SET to do full test
12920*
12921 IF( lsame(top, 'M') ) THEN
12922 setwhat = 13
12923 IF( scope .EQ. 'R' ) THEN
12924 istart = -(npcol - 1)
12925 istop = -istart
12926 ELSE IF (scope .EQ. 'C') THEN
12927 istart = -(nprow - 1)
12928 istop = -istart
12929 ELSE
12930 istart = -(nprow*npcol - 1)
12931 istop = -istart
12932 ENDIF
12933 ELSE IF( lsame(top, 'T') ) THEN
12934 setwhat = 14
12935 istart = 1
12936 IF( scope .EQ. 'R' ) THEN
12937 istop = npcol - 1
12938 ELSE IF (scope .EQ. 'C') THEN
12939 istop = nprow - 1
12940 ELSE
12941 istop = nprow*npcol - 1
12942 ENDIF
12943 ELSE
12944 setwhat = 0
12945 istart = 1
12946 istop = 1
12947 ENDIF
12948 DO 60 ima = 1, nmat
12949 m = m0(ima)
12950 n = n0(ima)
12951 ldasrc = ldas0(ima)
12952 ldadst = ldad0(ima)
12953 ipre = 2 * m
12954 ipost = ipre
12955 preaptr = 1
12956 aptr = preaptr + ipre
12957*
12958 DO 50 ide = 1, ndest
12959 testnum = testnum + 1
12960 rdest2 = rdest0(ide)
12961 cdest2 = cdest0(ide)
12962*
12963* If everyone gets the answer, create some bogus rdest/cdest
12964* so IF's are easier
12965*
12966 allrcv = ( (rdest2.EQ.-1) .OR. (cdest2.EQ.-1) )
12967 IF( allrcv ) THEN
12968 rdest = nprow - 1
12969 cdest = npcol - 1
12970 IF (topscohrnt.EQ.0) THEN
12971 itr1 = 0
12972 itr2 = 0
12973 ELSE IF (topscohrnt.EQ.1) THEN
12974 itr1 = 1
12975 itr2 = 1
12976 ELSE
12977 itr1 = 0
12978 itr2 = 1
12979 END IF
12980 ELSE
12981 rdest = rdest2
12982 cdest = cdest2
12983 itc1 = 0
12984 itc2 = 0
12985 END IF
12986 IF( rdest.GE.p0(igr) .OR. cdest.GE.q0(igr) ) THEN
12987 nskip = nskip + 1
12988 GOTO 50
12989 END IF
12990*
12991 IF( myrow.EQ.rdest .AND. mycol.EQ.cdest ) THEN
12992 lda = ldadst
12993 ELSE
12994 lda = ldasrc
12995 END IF
12996 IF( verb .GT. 1 ) THEN
12997 IF( iam .EQ. 0 ) THEN
12998 WRITE(outnum, 6000)
12999 $ testnum, 'RUNNING', scope, top, m, n,
13000 $ ldasrc, ldadst, rdest2, cdest2,
13001 $ nprow, npcol
13002 END IF
13003 END IF
13004*
13005* If I am in scope
13006*
13007 testok = .true.
13008 IF( ingrid ) THEN
13009 IF( (myrow.EQ.rdest .AND. scope.EQ.'R') .OR.
13010 $ (mycol.EQ.cdest .AND. scope.EQ.'C') .OR.
13011 $ (scope .EQ. 'A') ) THEN
13012*
13013 k = nerr
13014 DO 40 itr = itr1, itr2
13015 CALL blacs_set(context, 15, itr)
13016 DO 35 itc = itc1, itc2
13017 CALL blacs_set(context, 16, itc)
13018 DO 30 j = istart, istop
13019 IF( j.EQ.0) GOTO 30
13020 IF( setwhat.NE.0 )
13021 $ CALL blacs_set(context, setwhat, j)
13022*
13023*
13024* generate and pad matrix A
13025*
13026 CALL dinitmat('G','-', m, n, mem(preaptr),
13027 $ lda, ipre, ipost,
13028 $ checkval, testnum,
13029 $ myrow, mycol )
13030*
13031 CALL dgsum2d(context, scope, top, m, n,
13032 $ mem(aptr), lda, rdest2,
13033 $ cdest2)
13034*
13035* If I've got the answer, check for errors in
13036* matrix or padding
13037*
13038 IF( (myrow.EQ.rdest .AND. mycol.EQ.cdest)
13039 $ .OR. allrcv ) THEN
13040 CALL dchkpad('G','-', m, n,
13041 $ mem(preaptr), lda, rdest,
13042 $ cdest, myrow, mycol,
13043 $ ipre, ipost, checkval,
13044 $ testnum, maxerr, nerr,
13045 $ mem(erriptr),mem(errdptr))
13046 CALL dchksum(scope, context, m, n,
13047 $ mem(aptr), lda,
13048 $ testnum, maxerr, nerr,
13049 $ mem(erriptr),mem(errdptr),
13050 $ iseed)
13051 END IF
13052 30 CONTINUE
13053 CALL blacs_set(context, 16, 0)
13054 35 CONTINUE
13055 CALL blacs_set(context, 15, 0)
13056 40 CONTINUE
13057 testok = ( k .EQ. nerr )
13058 END IF
13059 END IF
13060*
13061 IF( verb .GT. 1 ) THEN
13062 i = nerr
13063 CALL dbtcheckin(0, outnum, maxerr, nerr,
13064 $ mem(erriptr), mem(errdptr), iseed)
13065 IF( iam .EQ. 0 ) THEN
13066 IF( testok .AND. nerr.EQ.i ) THEN
13067 WRITE(outnum,6000)testnum,'PASSED ',
13068 $ scope, top, m, n, ldasrc,
13069 $ ldadst, rdest2, cdest2,
13070 $ nprow, npcol
13071 ELSE
13072 nfail = nfail + 1
13073 WRITE(outnum,6000)testnum,'FAILED ',
13074 $ scope, top, m, n, ldasrc,
13075 $ ldadst, rdest2, cdest2,
13076 $ nprow, npcol
13077 END IF
13078 END IF
13079*
13080* Once we've printed out errors, can re-use buf space
13081*
13082 nerr = 0
13083 END IF
13084 50 CONTINUE
13085 60 CONTINUE
13086 70 CONTINUE
13087 80 CONTINUE
13088 90 CONTINUE
13089*
13090 IF( verb .LT. 2 ) THEN
13091 nfail = testnum
13092 CALL dbtcheckin( nfail, outnum, maxerr, nerr, mem(erriptr),
13093 $ mem(errdptr), iseed )
13094 END IF
13095 IF( iam .EQ. 0 ) THEN
13096 IF( verb .GT. 1 ) WRITE(outnum,*) ' '
13097 IF( nfail+nskip .EQ. 0 ) THEN
13098 WRITE(outnum, 7000 ) testnum
13099 ELSE
13100 WRITE(outnum, 8000 ) testnum, testnum-nskip-nfail,
13101 $ nskip, nfail
13102 END IF
13103 END IF
13104*
13105* Log whether their were any failures
13106*
13107 testok = allpass( (nfail.EQ.0) )
13108*
13109 1000 FORMAT('DOUBLE PRECISION SUM TESTS: BEGIN.' )
13110 2000 FORMAT(1x,a7,3x,10i6)
13111 3000 FORMAT(1x,a7,3x,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,
13112 $ 5x,a1,5x,a1)
13113 4000 FORMAT(' TEST# STATUS SCOPE TOP M N LDAS LDAD ',
13114 $ 'RDEST CDEST P Q')
13115 5000 FORMAT(' ----- ------- ----- --- ----- ----- ----- ----- ',
13116 $ '----- ----- ---- ----')
13117 6000 FORMAT(i6,1x,a7,5x,a1,3x,a1,6i6,2i5)
13118 7000 FORMAT('DOUBLE PRECISION SUM TESTS: PASSED ALL',
13119 $ i5, ' TESTS.')
13120 8000 FORMAT('DOUBLE PRECISION SUM TESTS:',i5,' TESTS;',i5,' PASSED,',
13121 $ i5,' SKIPPED,',i5,' FAILED.')
13122*
13123 RETURN
13124*
13125* End of DTESTSUM.
13126*
13127 END
13128*
13129 DOUBLE PRECISION FUNCTION dbtabs(VAL)
13130 DOUBLE PRECISION val
13131 dbtabs = abs(val)
13132 RETURN
13133 END
13134*
13135 DOUBLE PRECISION FUNCTION dbteps()
13136*
13137* .. External Functions ..
13138 INTEGER ibtmyproc, ibtnprocs, ibtmsgid
13139 DOUBLE PRECISION dlamch
13140 EXTERNAL ibtmyproc, ibtnprocs, ibtmsgid, dlamch
13141* ..
13142* .. Local Scalars ..
13143 INTEGER i, iam, nnodes
13144 DOUBLE PRECISION eps, eps2
13145 SAVE eps
13146 data eps /-22.0d0/
13147* ..
13148* .. Executable Statements ..
13149*
13150* First time called, must get max epsilon possessed by any
13151* participating process
13152*
13153 IF( eps .EQ. -22.0d0 ) THEN
13154 iam = ibtmyproc()
13155 nnodes = ibtnprocs()
13156 eps = dlamch('epsilon')
13157 IF( iam .EQ. 0 ) THEN
13158 IF( nnodes .GT. 1 ) THEN
13159 DO 10 i = 1, nnodes-1
13160 CALL btrecv( 6, 1, eps2, i, ibtmsgid()+20 )
13161 IF( eps .LT. eps2 ) eps = eps2
13162 10 CONTINUE
13163 END IF
13164 CALL btsend( 6, 1, eps, -1, ibtmsgid()+20 )
13165 ELSE
13166 CALL btsend( 6, 1, eps, 0, ibtmsgid()+20 )
13167 CALL btrecv( 6, 1, eps, 0, ibtmsgid()+20 )
13168 ENDIF
13169 END IF
13170 dbteps = eps
13171 RETURN
13172*
13173* End DBTEPS
13174*
13175 END
13176*
13177 SUBROUTINE dchksum( SCOPE, ICTXT, M, N, A, LDA, TESTNUM, MAXERR,
13178 $ NERR, ERRIBUF, ERRDBUF, ISEED )
13179*
13180* .. Scalar Arguments ..
13181 CHARACTER*1 SCOPE
13182 INTEGER ICTXT, M, N, LDA, TESTNUM, MAXERR, NERR
13183* ..
13184* .. Array Arguments ..
13185 INTEGER ERRIBUF(6, MAXERR), ISEED(*)
13186 DOUBLE PRECISION A(LDA,*), ERRDBUF(2, MAXERR)
13187* ..
13188* .. External Functions ..
13189 INTEGER IBTMYPROC, IBTNPROCS
13190 DOUBLE PRECISION DBTEPS
13191 DOUBLE PRECISION DBTRAN
13192 EXTERNAL ibtmyproc, ibtnprocs, dbteps, dbtran
13193* ..
13194* .. Local Scalars ..
13195 INTEGER NPROCS, NPROW, NPCOL, MYROW, MYCOL, NODE, NNODES, DEST
13196 INTEGER I, J, K
13197 DOUBLE PRECISION ANS, EPS, ERRBND, POSNUM, NEGNUM, TMP
13198* ..
13199* .. Executable Statements ..
13200*
13201 nprocs = ibtnprocs()
13202 eps = dbteps()
13203 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
13204 dest = myrow*nprocs + mycol
13205*
13206* Set up seeds to match those used by each proc's genmat call
13207*
13208 IF( scope .EQ. 'R' ) THEN
13209 nnodes = npcol
13210 DO 10 i = 0, nnodes-1
13211 node = myrow * nprocs + i
13212 iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
13213 iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
13214 iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
13215 iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
13216 10 CONTINUE
13217 ELSE IF( scope .EQ. 'C' ) THEN
13218 nnodes = nprow
13219 DO 20 i = 0, nnodes-1
13220 node = i * nprocs + mycol
13221 iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
13222 iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
13223 iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
13224 iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
13225 20 CONTINUE
13226 ELSE
13227 nnodes = nprow * npcol
13228 DO 30 i = 0, nnodes-1
13229 node = (i / npcol) * nprocs + mod(i, npcol)
13230 iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
13231 iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
13232 iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
13233 iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
13234 30 CONTINUE
13235 END IF
13236*
13237 DO 100 j = 1, n
13238 DO 90 i = 1, m
13239 ans = 0
13240 posnum = 0
13241 negnum = 0
13242 DO 40 k = 0, nnodes-1
13243 tmp = dbtran( iseed(k*4+1) )
13244 IF( tmp .LT. 0 ) THEN
13245 negnum = negnum + tmp
13246 ELSE
13247 posnum = posnum + tmp
13248 END IF
13249 ans = ans + tmp
13250 40 CONTINUE
13251*
13252* The error bound is figured by
13253* 2 * eps * (nnodes-1) * max(|max element|, |ans|).
13254* The 2 allows for errors in the distributed _AND_ local result.
13255* The eps is machine epsilon. The number of floating point adds
13256* is (nnodes - 1). We use the fact that 0.5 is the maximum element
13257* in order to save ourselves some computation.
13258*
13259 errbnd = 2 * eps * nnodes * max( posnum, -negnum )
13260 IF( abs( ans - a(i,j) ) .GT. errbnd ) THEN
13261 nerr = nerr + 1
13262 IF( nerr .LE. maxerr ) THEN
13263 erribuf(1, nerr) = testnum
13264 erribuf(2, nerr) = nnodes
13265 erribuf(3, nerr) = dest
13266 erribuf(4, nerr) = i
13267 erribuf(5, nerr) = j
13268 erribuf(6, nerr) = 5
13269 errdbuf(1, nerr) = a(i,j)
13270 errdbuf(2, nerr) = ans
13271 END IF
13272 END IF
13273 90 CONTINUE
13274 100 CONTINUE
13275*
13276 RETURN
13277*
13278* End of DCHKSUM
13279*
13280 END
13281*
13282*
13283 SUBROUTINE csumtest( OUTNUM, VERB, TOPSREPEAT, TOPSCOHRNT, NSCOPE,
13284 $ SCOPE0, NTOP, TOP0, NMAT, M0, N0, LDAS0,
13285 $ LDAD0, NDEST, RDEST0, CDEST0, NGRID,
13286 $ CONTEXT0, P0, Q0, ISEED, MEM, MEMLEN )
13287*
13288* -- BLACS tester (version 1.0) --
13289* University of Tennessee
13290* December 15, 1994
13291*
13292*
13293* .. Scalar Arguments ..
13294 INTEGER MEMLEN, NDEST, NGRID, NMAT, NSCOPE, NTOP, OUTNUM,
13295 $ TOPSCOHRNT, TOPSREPEAT, VERB
13296* ..
13297* .. Array Arguments ..
13298 CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP)
13299 INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT)
13300 INTEGER RDEST0(NDEST), CDEST0(NDEST), CONTEXT0(NGRID)
13301 INTEGER P0(NGRID), Q0(NGRID), ISEED(*)
13302 COMPLEX MEM(MEMLEN)
13303* ..
13304*
13305* Purpose
13306* =======
13307* CTESTSUM: Test complex SUM COMBINE
13308*
13309* Arguments
13310* =========
13311* OUTNUM (input) INTEGER
13312* The device number to write output to.
13313*
13314* VERB (input) INTEGER
13315* The level of verbosity (how much printing to do).
13316*
13317* NSCOPE (input) INTEGER
13318* The number of scopes to be tested.
13319*
13320* SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE)
13321* Values of the scopes to be tested.
13322*
13323* NTOP (input) INTEGER
13324* The number of topologies to be tested.
13325*
13326* TOP0 (input) CHARACTER*1 array of dimension (NTOP)
13327* Values of the topologies to be tested.
13328*
13329* NMAT (input) INTEGER
13330* The number of matrices to be tested.
13331*
13332* M0 (input) INTEGER array of dimension (NMAT)
13333* Values of M to be tested.
13334*
13335* M0 (input) INTEGER array of dimension (NMAT)
13336* Values of M to be tested.
13337*
13338* N0 (input) INTEGER array of dimension (NMAT)
13339* Values of N to be tested.
13340*
13341* LDAS0 (input) INTEGER array of dimension (NMAT)
13342* Values of LDAS (leading dimension of A on source process)
13343* to be tested.
13344*
13345* LDAD0 (input) INTEGER array of dimension (NMAT)
13346* Values of LDAD (leading dimension of A on destination
13347* process) to be tested.
13348* NDEST (input) INTEGER
13349* The number of destinations to be tested.
13350*
13351* RDEST0 (input) INTEGER array of dimension (NNDEST)
13352* Values of RDEST (row coordinate of destination) to be
13353* tested.
13354*
13355* CDEST0 (input) INTEGER array of dimension (NNDEST)
13356* Values of CDEST (column coordinate of destination) to be
13357* tested.
13358*
13359* NGRID (input) INTEGER
13360* The number of process grids to be tested.
13361*
13362* CONTEXT0 (input) INTEGER array of dimension (NGRID)
13363* The BLACS context handles corresponding to the grids.
13364*
13365* P0 (input) INTEGER array of dimension (NGRID)
13366* Values of P (number of process rows, NPROW).
13367*
13368* Q0 (input) INTEGER array of dimension (NGRID)
13369* Values of Q (number of process columns, NPCOL).
13370*
13371* ISEED (workspace) INTEGER array of dimension ( MAX(NPROCS, NTESTS) )
13372* Workspace used to hold each process's random number SEED.
13373* This requires NPROCS (number of processor) elements.
13374* If VERB < 2, this workspace also serves to indicate which
13375* tests fail. This requires workspace of NTESTS
13376* (number of tests performed).
13377*
13378* MEM (workspace) COMPLEX array of dimension (MEMLEN)
13379* Used for all other workspaces, including the matrix A,
13380* and its pre and post padding.
13381*
13382* MEMLEN (input) INTEGER
13383* The length, in elements, of MEM.
13384*
13385* =====================================================================
13386*
13387* .. External Functions ..
13388 LOGICAL ALLPASS, LSAME
13389 INTEGER IBTMYPROC, IBTNPROCS, IBTSIZEOF
13390 EXTERNAL ALLPASS, LSAME, IBTMYPROC, IBTNPROCS, IBTSIZEOF
13391* ..
13392* .. External Subroutines ..
13393 EXTERNAL BLACS_GRIDINFO, CGSUM2D
13394 EXTERNAL CINITMAT, CCHKPAD, CBTCHECKIN
13395* ..
13396* .. Local Scalars ..
13397 CHARACTER*1 SCOPE, TOP
13398 LOGICAL INGRID, TESTOK, ALLRCV
13399 INTEGER APTR, CDEST, CDEST2, CONTEXT, CSIZE, ERRDPTR, ERRIPTR, I,
13400 $ iam, ide, igr, ima, ipad, ipost, ipre, isc, isize, istart,
13401 $ istop, itc, itc1, itc2, ito, itr, itr1, itr2, j, k, lda,
13402 $ ldadst, ldasrc, m, maxerr, mycol, myrow, n, nerr, nfail,
13403 $ npcol, nprow, nskip, preaptr, rdest, rdest2, setwhat,
13404 $ testnum
13405 COMPLEX CHECKVAL
13406* ..
13407* .. Executable Statements ..
13408*
13409* Choose padding value, and make it unique
13410*
13411 CHECKVAL = cmplx( -0.91e0, -0.71e0 )
13412 iam = ibtmyproc()
13413 checkval = iam * checkval
13414 isize = ibtsizeof('I')
13415 csize = ibtsizeof('C')
13416*
13417* Verify file parameters
13418*
13419 IF( iam .EQ. 0 ) THEN
13420 WRITE(outnum, *) ' '
13421 WRITE(outnum, *) ' '
13422 WRITE(outnum, 1000 )
13423 IF( verb .GT. 0 ) THEN
13424 WRITE(outnum,*) ' '
13425 WRITE(outnum, 2000) 'NSCOPE:', nscope
13426 WRITE(outnum, 3000) ' SCOPE:', ( scope0(i), i = 1, nscope )
13427 WRITE(outnum, 2000) 'TReps :', topsrepeat
13428 WRITE(outnum, 2000) 'TCohr :', topscohrnt
13429 WRITE(outnum, 2000) 'NTOP :', ntop
13430 WRITE(outnum, 3000) ' TOP :', ( top0(i), i = 1, ntop )
13431 WRITE(outnum, 2000) 'NMAT :', nmat
13432 WRITE(outnum, 2000) ' M :', ( m0(i), i = 1, nmat )
13433 WRITE(outnum, 2000) ' N :', ( n0(i), i = 1, nmat )
13434 WRITE(outnum, 2000) ' LDAS :', ( ldas0(i), i = 1, nmat )
13435 WRITE(outnum, 2000) ' LDAD :', ( ldad0(i), i = 1, nmat )
13436 WRITE(outnum, 2000) 'NDEST :', ndest
13437 WRITE(outnum, 2000) ' RDEST:',( rdest0(i), i = 1, ndest )
13438 WRITE(outnum, 2000) ' CDEST:',( cdest0(i), i = 1, ndest )
13439 WRITE(outnum, 2000) 'NGRIDS:', ngrid
13440 WRITE(outnum, 2000) ' P :', ( p0(i), i = 1, ngrid )
13441 WRITE(outnum, 2000) ' Q :', ( q0(i), i = 1, ngrid )
13442 WRITE(outnum, 2000) 'VERB :', verb
13443 WRITE(outnum,*) ' '
13444 END IF
13445 IF( verb .GT. 1 ) THEN
13446 WRITE(outnum,4000)
13447 WRITE(outnum,5000)
13448 END IF
13449 END IF
13450 IF (topsrepeat.EQ.0) THEN
13451 itr1 = 0
13452 itr2 = 0
13453 ELSE IF (topsrepeat.EQ.1) THEN
13454 itr1 = 1
13455 itr2 = 1
13456 ELSE
13457 itr1 = 0
13458 itr2 = 1
13459 END IF
13460*
13461* Find biggest matrix, so we know where to stick error info
13462*
13463 i = 0
13464 DO 10 ima = 1, nmat
13465 ipad = 4 * m0(ima)
13466 k = n0(ima) * max0( ldas0(ima), ldad0(ima) ) + ipad
13467 IF( k .GT. i ) i = k
13468 10 CONTINUE
13469 maxerr = ( csize * (memlen-i) ) / ( csize*2 + isize*6 )
13470 IF( maxerr .LT. 1 ) THEN
13471 WRITE(outnum,*) 'ERROR: Not enough memory to run SUM tests.'
13472 CALL blacs_abort(-1, 1)
13473 END IF
13474 errdptr = i + 1
13475 erriptr = errdptr + maxerr
13476 nerr = 0
13477 testnum = 0
13478 nfail = 0
13479 nskip = 0
13480*
13481* Loop over grids of matrix
13482*
13483 DO 90 igr = 1, ngrid
13484*
13485* allocate process grid for the next batch of tests
13486*
13487 context = context0(igr)
13488 CALL blacs_gridinfo( context, nprow, npcol, myrow, mycol )
13489 ingrid = ( (myrow.LT.nprow) .AND. (mycol.LT.npcol) )
13490*
13491 DO 80 isc = 1, nscope
13492 scope = scope0(isc)
13493 DO 70 ito = 1, ntop
13494 top = top0(ito)
13495*
13496* If testing multiring ('M') or general tree ('T'), need to
13497* loop over calls to BLACS_SET to do full test
13498*
13499 IF( lsame(top, 'M') ) THEN
13500 setwhat = 13
13501 IF( scope .EQ. 'R' ) THEN
13502 istart = -(npcol - 1)
13503 istop = -istart
13504 ELSE IF (scope .EQ. 'C') THEN
13505 istart = -(nprow - 1)
13506 istop = -istart
13507 ELSE
13508 istart = -(nprow*npcol - 1)
13509 istop = -istart
13510 ENDIF
13511 ELSE IF( lsame(top, 'T') ) THEN
13512 setwhat = 14
13513 istart = 1
13514 IF( scope .EQ. 'R' ) THEN
13515 istop = npcol - 1
13516 ELSE IF (scope .EQ. 'C') THEN
13517 istop = nprow - 1
13518 ELSE
13519 istop = nprow*npcol - 1
13520 ENDIF
13521 ELSE
13522 setwhat = 0
13523 istart = 1
13524 istop = 1
13525 ENDIF
13526 DO 60 ima = 1, nmat
13527 m = m0(ima)
13528 n = n0(ima)
13529 ldasrc = ldas0(ima)
13530 ldadst = ldad0(ima)
13531 ipre = 2 * m
13532 ipost = ipre
13533 preaptr = 1
13534 aptr = preaptr + ipre
13535*
13536 DO 50 ide = 1, ndest
13537 testnum = testnum + 1
13538 rdest2 = rdest0(ide)
13539 cdest2 = cdest0(ide)
13540*
13541* If everyone gets the answer, create some bogus rdest/cdest
13542* so IF's are easier
13543*
13544 allrcv = ( (rdest2.EQ.-1) .OR. (cdest2.EQ.-1) )
13545 IF( allrcv ) THEN
13546 rdest = nprow - 1
13547 cdest = npcol - 1
13548 IF (topscohrnt.EQ.0) THEN
13549 itr1 = 0
13550 itr2 = 0
13551 ELSE IF (topscohrnt.EQ.1) THEN
13552 itr1 = 1
13553 itr2 = 1
13554 ELSE
13555 itr1 = 0
13556 itr2 = 1
13557 END IF
13558 ELSE
13559 rdest = rdest2
13560 cdest = cdest2
13561 itc1 = 0
13562 itc2 = 0
13563 END IF
13564 IF( rdest.GE.p0(igr) .OR. cdest.GE.q0(igr) ) THEN
13565 nskip = nskip + 1
13566 GOTO 50
13567 END IF
13568*
13569 IF( myrow.EQ.rdest .AND. mycol.EQ.cdest ) THEN
13570 lda = ldadst
13571 ELSE
13572 lda = ldasrc
13573 END IF
13574 IF( verb .GT. 1 ) THEN
13575 IF( iam .EQ. 0 ) THEN
13576 WRITE(outnum, 6000)
13577 $ testnum, 'RUNNING', scope, top, m, n,
13578 $ ldasrc, ldadst, rdest2, cdest2,
13579 $ nprow, npcol
13580 END IF
13581 END IF
13582*
13583* If I am in scope
13584*
13585 testok = .true.
13586 IF( ingrid ) THEN
13587 IF( (myrow.EQ.rdest .AND. scope.EQ.'R') .OR.
13588 $ (mycol.EQ.cdest .AND. scope.EQ.'C') .OR.
13589 $ (scope .EQ. 'A') ) THEN
13590*
13591 k = nerr
13592 DO 40 itr = itr1, itr2
13593 CALL blacs_set(context, 15, itr)
13594 DO 35 itc = itc1, itc2
13595 CALL blacs_set(context, 16, itc)
13596 DO 30 j = istart, istop
13597 IF( j.EQ.0) GOTO 30
13598 IF( setwhat.NE.0 )
13599 $ CALL blacs_set(context, setwhat, j)
13600*
13601*
13602* generate and pad matrix A
13603*
13604 CALL cinitmat('G','-', m, n, mem(preaptr),
13605 $ lda, ipre, ipost,
13606 $ checkval, testnum,
13607 $ myrow, mycol )
13608*
13609 CALL cgsum2d(context, scope, top, m, n,
13610 $ mem(aptr), lda, rdest2,
13611 $ cdest2)
13612*
13613* If I've got the answer, check for errors in
13614* matrix or padding
13615*
13616 IF( (myrow.EQ.rdest .AND. mycol.EQ.cdest)
13617 $ .OR. allrcv ) THEN
13618 CALL cchkpad('G','-', m, n,
13619 $ mem(preaptr), lda, rdest,
13620 $ cdest, myrow, mycol,
13621 $ ipre, ipost, checkval,
13622 $ testnum, maxerr, nerr,
13623 $ mem(erriptr),mem(errdptr))
13624 CALL cchksum(scope, context, m, n,
13625 $ mem(aptr), lda,
13626 $ testnum, maxerr, nerr,
13627 $ mem(erriptr),mem(errdptr),
13628 $ iseed)
13629 END IF
13630 30 CONTINUE
13631 CALL blacs_set(context, 16, 0)
13632 35 CONTINUE
13633 CALL blacs_set(context, 15, 0)
13634 40 CONTINUE
13635 testok = ( k .EQ. nerr )
13636 END IF
13637 END IF
13638*
13639 IF( verb .GT. 1 ) THEN
13640 i = nerr
13641 CALL cbtcheckin(0, outnum, maxerr, nerr,
13642 $ mem(erriptr), mem(errdptr), iseed)
13643 IF( iam .EQ. 0 ) THEN
13644 IF( testok .AND. nerr.EQ.i ) THEN
13645 WRITE(outnum,6000)testnum,'PASSED ',
13646 $ scope, top, m, n, ldasrc,
13647 $ ldadst, rdest2, cdest2,
13648 $ nprow, npcol
13649 ELSE
13650 nfail = nfail + 1
13651 WRITE(outnum,6000)testnum,'FAILED ',
13652 $ scope, top, m, n, ldasrc,
13653 $ ldadst, rdest2, cdest2,
13654 $ nprow, npcol
13655 END IF
13656 END IF
13657*
13658* Once we've printed out errors, can re-use buf space
13659*
13660 nerr = 0
13661 END IF
13662 50 CONTINUE
13663 60 CONTINUE
13664 70 CONTINUE
13665 80 CONTINUE
13666 90 CONTINUE
13667*
13668 IF( verb .LT. 2 ) THEN
13669 nfail = testnum
13670 CALL cbtcheckin( nfail, outnum, maxerr, nerr, mem(erriptr),
13671 $ mem(errdptr), iseed )
13672 END IF
13673 IF( iam .EQ. 0 ) THEN
13674 IF( verb .GT. 1 ) WRITE(outnum,*) ' '
13675 IF( nfail+nskip .EQ. 0 ) THEN
13676 WRITE(outnum, 7000 ) testnum
13677 ELSE
13678 WRITE(outnum, 8000 ) testnum, testnum-nskip-nfail,
13679 $ nskip, nfail
13680 END IF
13681 END IF
13682*
13683* Log whether their were any failures
13684*
13685 testok = allpass( (nfail.EQ.0) )
13686*
13687 1000 FORMAT('COMPLEX SUM TESTS: BEGIN.' )
13688 2000 FORMAT(1x,a7,3x,10i6)
13689 3000 FORMAT(1x,a7,3x,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,
13690 $ 5x,a1,5x,a1)
13691 4000 FORMAT(' TEST# STATUS SCOPE TOP M N LDAS LDAD ',
13692 $ 'RDEST CDEST P Q')
13693 5000 FORMAT(' ----- ------- ----- --- ----- ----- ----- ----- ',
13694 $ '----- ----- ---- ----')
13695 6000 FORMAT(i6,1x,a7,5x,a1,3x,a1,6i6,2i5)
13696 7000 FORMAT('COMPLEX SUM TESTS: PASSED ALL',
13697 $ i5, ' TESTS.')
13698 8000 FORMAT('COMPLEX SUM TESTS:',i5,' TESTS;',i5,' PASSED,',
13699 $ i5,' SKIPPED,',i5,' FAILED.')
13700*
13701 RETURN
13702*
13703* End of CTESTSUM.
13704*
13705 END
13706*
13707 REAL function cbtabs(val)
13708 COMPLEX val
13709 cbtabs = abs( real(val) ) + abs( aimag(val) )
13710 RETURN
13711 END
13712*
13713 SUBROUTINE cchksum( SCOPE, ICTXT, M, N, A, LDA, TESTNUM, MAXERR,
13714 $ NERR, ERRIBUF, ERRDBUF, ISEED )
13715*
13716* .. Scalar Arguments ..
13717 CHARACTER*1 SCOPE
13718 INTEGER ICTXT, M, N, LDA, TESTNUM, MAXERR, NERR
13719* ..
13720* .. Array Arguments ..
13721 INTEGER ERRIBUF(6, MAXERR), ISEED(*)
13722 COMPLEX A(LDA,*), ERRDBUF(2, MAXERR)
13723* ..
13724* .. External Functions ..
13725 INTEGER IBTMYPROC, IBTNPROCS
13726 REAL SBTEPS
13727 COMPLEX CBTRAN
13728 EXTERNAL IBTMYPROC, IBTNPROCS, SBTEPS, CBTRAN
13729* ..
13730* .. Local Scalars ..
13731 LOGICAL NUMOK
13732 INTEGER NPROCS, NPROW, NPCOL, MYROW, MYCOL, NODE, NNODES, DEST
13733 INTEGER I, J, K
13734 COMPLEX ANS, TMP
13735 REAL EPS, ERRBND, RPOSNUM, RNEGNUM, IPOSNUM, INEGNUM
13736* ..
13737* .. Executable Statements ..
13738*
13739 nprocs = ibtnprocs()
13740 eps = sbteps()
13741 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
13742 dest = myrow*nprocs + mycol
13743*
13744* Set up seeds to match those used by each proc's genmat call
13745*
13746 IF( scope .EQ. 'R' ) THEN
13747 nnodes = npcol
13748 DO 10 i = 0, nnodes-1
13749 node = myrow * nprocs + i
13750 iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
13751 iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
13752 iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
13753 iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
13754 10 CONTINUE
13755 ELSE IF( scope .EQ. 'C' ) THEN
13756 nnodes = nprow
13757 DO 20 i = 0, nnodes-1
13758 node = i * nprocs + mycol
13759 iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
13760 iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
13761 iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
13762 iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
13763 20 CONTINUE
13764 ELSE
13765 nnodes = nprow * npcol
13766 DO 30 i = 0, nnodes-1
13767 node = (i / npcol) * nprocs + mod(i, npcol)
13768 iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
13769 iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
13770 iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
13771 iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
13772 30 CONTINUE
13773 END IF
13774*
13775 DO 100 j = 1, n
13776 DO 90 i = 1, m
13777 ans = 0
13778 rposnum = 0
13779 rnegnum = 0
13780 iposnum = 0
13781 inegnum = 0
13782 DO 40 k = 0, nnodes-1
13783 tmp = cbtran( iseed(k*4+1) )
13784 IF( real( tmp ) .LT. 0 ) THEN
13785 rnegnum = rnegnum + real( tmp )
13786 ELSE
13787 rposnum = rposnum + real( tmp )
13788 END IF
13789 IF( aimag( tmp ) .LT. 0 ) THEN
13790 inegnum = inegnum + aimag( tmp )
13791 ELSE
13792 iposnum = iposnum + aimag( tmp )
13793 END IF
13794 ans = ans + tmp
13795 40 CONTINUE
13796*
13797* The error bound is figured by
13798* 2 * eps * (nnodes-1) * max(|max element|, |ans|).
13799* The 2 allows for errors in the distributed _AND_ local result.
13800* The eps is machine epsilon. The number of floating point adds
13801* is (nnodes - 1). We use the fact that 0.5 is the maximum element
13802* in order to save ourselves some computation.
13803*
13804 tmp = ans - a(i,j)
13805 errbnd = 2 * eps * nnodes * max( rposnum, -rnegnum )
13806 numok = ( real(tmp) .LE. errbnd )
13807 errbnd = 2 * eps * nnodes * max( iposnum, -inegnum )
13808 numok = numok .AND. ( aimag(tmp) .LE. errbnd )
13809 IF( .NOT.numok ) THEN
13810 nerr = nerr + 1
13811 IF( nerr .LE. maxerr ) THEN
13812 erribuf(1, nerr) = testnum
13813 erribuf(2, nerr) = nnodes
13814 erribuf(3, nerr) = dest
13815 erribuf(4, nerr) = i
13816 erribuf(5, nerr) = j
13817 erribuf(6, nerr) = 5
13818 errdbuf(1, nerr) = a(i,j)
13819 errdbuf(2, nerr) = ans
13820 END IF
13821 END IF
13822 90 CONTINUE
13823 100 CONTINUE
13824*
13825 RETURN
13826*
13827* End of CCHKSUM
13828*
13829 END
13830*
13831*
13832 SUBROUTINE zsumtest( OUTNUM, VERB, TOPSREPEAT, TOPSCOHRNT, NSCOPE,
13833 $ SCOPE0, NTOP, TOP0, NMAT, M0, N0, LDAS0,
13834 $ LDAD0, NDEST, RDEST0, CDEST0, NGRID,
13835 $ CONTEXT0, P0, Q0, ISEED, MEM, MEMLEN )
13836*
13837* -- BLACS tester (version 1.0) --
13838* University of Tennessee
13839* December 15, 1994
13840*
13841*
13842* .. Scalar Arguments ..
13843 INTEGER MEMLEN, NDEST, NGRID, NMAT, NSCOPE, NTOP, OUTNUM,
13844 $ topscohrnt, topsrepeat, verb
13845* ..
13846* .. Array Arguments ..
13847 CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP)
13848 INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT)
13849 INTEGER RDEST0(NDEST), CDEST0(NDEST), CONTEXT0(NGRID)
13850 INTEGER P0(NGRID), Q0(NGRID), ISEED(*)
13851 DOUBLE COMPLEX MEM(MEMLEN)
13852* ..
13853*
13854* Purpose
13855* =======
13856* ZTESTSUM: Test double complex SUM COMBINE
13857*
13858* Arguments
13859* =========
13860* OUTNUM (input) INTEGER
13861* The device number to write output to.
13862*
13863* VERB (input) INTEGER
13864* The level of verbosity (how much printing to do).
13865*
13866* NSCOPE (input) INTEGER
13867* The number of scopes to be tested.
13868*
13869* SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE)
13870* Values of the scopes to be tested.
13871*
13872* NTOP (input) INTEGER
13873* The number of topologies to be tested.
13874*
13875* TOP0 (input) CHARACTER*1 array of dimension (NTOP)
13876* Values of the topologies to be tested.
13877*
13878* NMAT (input) INTEGER
13879* The number of matrices to be tested.
13880*
13881* M0 (input) INTEGER array of dimension (NMAT)
13882* Values of M to be tested.
13883*
13884* M0 (input) INTEGER array of dimension (NMAT)
13885* Values of M to be tested.
13886*
13887* N0 (input) INTEGER array of dimension (NMAT)
13888* Values of N to be tested.
13889*
13890* LDAS0 (input) INTEGER array of dimension (NMAT)
13891* Values of LDAS (leading dimension of A on source process)
13892* to be tested.
13893*
13894* LDAD0 (input) INTEGER array of dimension (NMAT)
13895* Values of LDAD (leading dimension of A on destination
13896* process) to be tested.
13897* NDEST (input) INTEGER
13898* The number of destinations to be tested.
13899*
13900* RDEST0 (input) INTEGER array of dimension (NNDEST)
13901* Values of RDEST (row coordinate of destination) to be
13902* tested.
13903*
13904* CDEST0 (input) INTEGER array of dimension (NNDEST)
13905* Values of CDEST (column coordinate of destination) to be
13906* tested.
13907*
13908* NGRID (input) INTEGER
13909* The number of process grids to be tested.
13910*
13911* CONTEXT0 (input) INTEGER array of dimension (NGRID)
13912* The BLACS context handles corresponding to the grids.
13913*
13914* P0 (input) INTEGER array of dimension (NGRID)
13915* Values of P (number of process rows, NPROW).
13916*
13917* Q0 (input) INTEGER array of dimension (NGRID)
13918* Values of Q (number of process columns, NPCOL).
13919*
13920* ISEED (workspace) INTEGER array of dimension ( MAX(NPROCS, NTESTS) )
13921* Workspace used to hold each process's random number SEED.
13922* This requires NPROCS (number of processor) elements.
13923* If VERB < 2, this workspace also serves to indicate which
13924* tests fail. This requires workspace of NTESTS
13925* (number of tests performed).
13926*
13927* MEM (workspace) DOUBLE COMPLEX array of dimension (MEMLEN)
13928* Used for all other workspaces, including the matrix A,
13929* and its pre and post padding.
13930*
13931* MEMLEN (input) INTEGER
13932* The length, in elements, of MEM.
13933*
13934* =====================================================================
13935*
13936* .. External Functions ..
13937 LOGICAL ALLPASS, LSAME
13938 INTEGER IBTMYPROC, IBTNPROCS, IBTSIZEOF
13939 EXTERNAL ALLPASS, LSAME, IBTMYPROC, IBTNPROCS, IBTSIZEOF
13940* ..
13941* .. External Subroutines ..
13942 EXTERNAL BLACS_GRIDINFO, ZGSUM2D
13943 EXTERNAL ZINITMAT, ZCHKPAD, ZBTCHECKIN
13944* ..
13945* .. Local Scalars ..
13946 CHARACTER*1 SCOPE, TOP
13947 LOGICAL INGRID, TESTOK, ALLRCV
13948 INTEGER APTR, CDEST, CDEST2, CONTEXT, ERRDPTR, ERRIPTR, I, IAM,
13949 $ IDE, IGR, IMA, IPAD, IPOST, IPRE, ISC, ISIZE, ISTART,
13950 $ ISTOP, ITC, ITC1, ITC2, ITO, ITR, ITR1, ITR2, J, K, LDA,
13951 $ LDADST, LDASRC, M, MAXERR, MYCOL, MYROW, N, NERR, NFAIL,
13952 $ npcol, nprow, nskip, preaptr, rdest, rdest2, setwhat,
13953 $ testnum, zsize
13954 DOUBLE COMPLEX CHECKVAL
13955* ..
13956* .. Executable Statements ..
13957*
13958* Choose padding value, and make it unique
13959*
13960 checkval = dcmplx( -9.11d0, -9.21d0 )
13961 iam = ibtmyproc()
13962 checkval = iam * checkval
13963 isize = ibtsizeof('I')
13964 zsize = ibtsizeof('Z')
13965*
13966* Verify file parameters
13967*
13968 IF( iam .EQ. 0 ) THEN
13969 WRITE(outnum, *) ' '
13970 WRITE(outnum, *) ' '
13971 WRITE(outnum, 1000 )
13972 IF( verb .GT. 0 ) THEN
13973 WRITE(outnum,*) ' '
13974 WRITE(outnum, 2000) 'NSCOPE:', nscope
13975 WRITE(outnum, 3000) ' SCOPE:', ( scope0(i), i = 1, nscope )
13976 WRITE(outnum, 2000) 'TReps :', topsrepeat
13977 WRITE(outnum, 2000) 'TCohr :', topscohrnt
13978 WRITE(outnum, 2000) 'NTOP :', ntop
13979 WRITE(outnum, 3000) ' TOP :', ( top0(i), i = 1, ntop )
13980 WRITE(outnum, 2000) 'NMAT :', nmat
13981 WRITE(outnum, 2000) ' M :', ( m0(i), i = 1, nmat )
13982 WRITE(outnum, 2000) ' N :', ( n0(i), i = 1, nmat )
13983 WRITE(outnum, 2000) ' LDAS :', ( ldas0(i), i = 1, nmat )
13984 WRITE(outnum, 2000) ' LDAD :', ( ldad0(i), i = 1, nmat )
13985 WRITE(outnum, 2000) 'NDEST :', ndest
13986 WRITE(outnum, 2000) ' RDEST:',( rdest0(i), i = 1, ndest )
13987 WRITE(outnum, 2000) ' CDEST:',( cdest0(i), i = 1, ndest )
13988 WRITE(outnum, 2000) 'NGRIDS:', ngrid
13989 WRITE(outnum, 2000) ' P :', ( p0(i), i = 1, ngrid )
13990 WRITE(outnum, 2000) ' Q :', ( q0(i), i = 1, ngrid )
13991 WRITE(outnum, 2000) 'VERB :', verb
13992 WRITE(outnum,*) ' '
13993 END IF
13994 IF( verb .GT. 1 ) THEN
13995 WRITE(outnum,4000)
13996 WRITE(outnum,5000)
13997 END IF
13998 END IF
13999 IF (topsrepeat.EQ.0) THEN
14000 itr1 = 0
14001 itr2 = 0
14002 ELSE IF (topsrepeat.EQ.1) THEN
14003 itr1 = 1
14004 itr2 = 1
14005 ELSE
14006 itr1 = 0
14007 itr2 = 1
14008 END IF
14009*
14010* Find biggest matrix, so we know where to stick error info
14011*
14012 i = 0
14013 DO 10 ima = 1, nmat
14014 ipad = 4 * m0(ima)
14015 k = n0(ima) * max0( ldas0(ima), ldad0(ima) ) + ipad
14016 IF( k .GT. i ) i = k
14017 10 CONTINUE
14018 maxerr = ( zsize * (memlen-i) ) / ( zsize*2 + isize*6 )
14019 IF( maxerr .LT. 1 ) THEN
14020 WRITE(outnum,*) 'ERROR: Not enough memory to run SUM tests.'
14021 CALL blacs_abort(-1, 1)
14022 END IF
14023 errdptr = i + 1
14024 erriptr = errdptr + maxerr
14025 nerr = 0
14026 testnum = 0
14027 nfail = 0
14028 nskip = 0
14029*
14030* Loop over grids of matrix
14031*
14032 DO 90 igr = 1, ngrid
14033*
14034* allocate process grid for the next batch of tests
14035*
14036 context = context0(igr)
14037 CALL blacs_gridinfo( context, nprow, npcol, myrow, mycol )
14038 ingrid = ( (myrow.LT.nprow) .AND. (mycol.LT.npcol) )
14039*
14040 DO 80 isc = 1, nscope
14041 scope = scope0(isc)
14042 DO 70 ito = 1, ntop
14043 top = top0(ito)
14044*
14045* If testing multiring ('M') or general tree ('T'), need to
14046* loop over calls to BLACS_SET to do full test
14047*
14048 IF( lsame(top, 'M') ) THEN
14049 setwhat = 13
14050 IF( scope .EQ. 'R' ) THEN
14051 istart = -(npcol - 1)
14052 istop = -istart
14053 ELSE IF (scope .EQ. 'C') THEN
14054 istart = -(nprow - 1)
14055 istop = -istart
14056 ELSE
14057 istart = -(nprow*npcol - 1)
14058 istop = -istart
14059 ENDIF
14060 ELSE IF( lsame(top, 'T') ) THEN
14061 setwhat = 14
14062 istart = 1
14063 IF( scope .EQ. 'R' ) THEN
14064 istop = npcol - 1
14065 ELSE IF (scope .EQ. 'C') THEN
14066 istop = nprow - 1
14067 ELSE
14068 istop = nprow*npcol - 1
14069 ENDIF
14070 ELSE
14071 setwhat = 0
14072 istart = 1
14073 istop = 1
14074 ENDIF
14075 DO 60 ima = 1, nmat
14076 m = m0(ima)
14077 n = n0(ima)
14078 ldasrc = ldas0(ima)
14079 ldadst = ldad0(ima)
14080 ipre = 2 * m
14081 ipost = ipre
14082 preaptr = 1
14083 aptr = preaptr + ipre
14084*
14085 DO 50 ide = 1, ndest
14086 testnum = testnum + 1
14087 rdest2 = rdest0(ide)
14088 cdest2 = cdest0(ide)
14089*
14090* If everyone gets the answer, create some bogus rdest/cdest
14091* so IF's are easier
14092*
14093 allrcv = ( (rdest2.EQ.-1) .OR. (cdest2.EQ.-1) )
14094 IF( allrcv ) THEN
14095 rdest = nprow - 1
14096 cdest = npcol - 1
14097 IF (topscohrnt.EQ.0) THEN
14098 itr1 = 0
14099 itr2 = 0
14100 ELSE IF (topscohrnt.EQ.1) THEN
14101 itr1 = 1
14102 itr2 = 1
14103 ELSE
14104 itr1 = 0
14105 itr2 = 1
14106 END IF
14107 ELSE
14108 rdest = rdest2
14109 cdest = cdest2
14110 itc1 = 0
14111 itc2 = 0
14112 END IF
14113 IF( rdest.GE.p0(igr) .OR. cdest.GE.q0(igr) ) THEN
14114 nskip = nskip + 1
14115 GOTO 50
14116 END IF
14117*
14118 IF( myrow.EQ.rdest .AND. mycol.EQ.cdest ) THEN
14119 lda = ldadst
14120 ELSE
14121 lda = ldasrc
14122 END IF
14123 IF( verb .GT. 1 ) THEN
14124 IF( iam .EQ. 0 ) THEN
14125 WRITE(outnum, 6000)
14126 $ testnum, 'RUNNING', scope, top, m, n,
14127 $ ldasrc, ldadst, rdest2, cdest2,
14128 $ nprow, npcol
14129 END IF
14130 END IF
14131*
14132* If I am in scope
14133*
14134 testok = .true.
14135 IF( ingrid ) THEN
14136 IF( (myrow.EQ.rdest .AND. scope.EQ.'R') .OR.
14137 $ (mycol.EQ.cdest .AND. scope.EQ.'C') .OR.
14138 $ (scope .EQ. 'A') ) THEN
14139*
14140 k = nerr
14141 DO 40 itr = itr1, itr2
14142 CALL blacs_set(context, 15, itr)
14143 DO 35 itc = itc1, itc2
14144 CALL blacs_set(context, 16, itc)
14145 DO 30 j = istart, istop
14146 IF( j.EQ.0) GOTO 30
14147 IF( setwhat.NE.0 )
14148 $ CALL blacs_set(context, setwhat, j)
14149*
14150*
14151* generate and pad matrix A
14152*
14153 CALL zinitmat('G','-', m, n, mem(preaptr),
14154 $ lda, ipre, ipost,
14155 $ checkval, testnum,
14156 $ myrow, mycol )
14157*
14158 CALL zgsum2d(context, scope, top, m, n,
14159 $ mem(aptr), lda, rdest2,
14160 $ cdest2)
14161*
14162* If I've got the answer, check for errors in
14163* matrix or padding
14164*
14165 IF( (myrow.EQ.rdest .AND. mycol.EQ.cdest)
14166 $ .OR. allrcv ) THEN
14167 CALL zchkpad('G','-', m, n,
14168 $ mem(preaptr), lda, rdest,
14169 $ cdest, myrow, mycol,
14170 $ ipre, ipost, checkval,
14171 $ testnum, maxerr, nerr,
14172 $ mem(erriptr),mem(errdptr))
14173 CALL zchksum(scope, context, m, n,
14174 $ mem(aptr), lda,
14175 $ testnum, maxerr, nerr,
14176 $ mem(erriptr),mem(errdptr),
14177 $ iseed)
14178 END IF
14179 30 CONTINUE
14180 CALL blacs_set(context, 16, 0)
14181 35 CONTINUE
14182 CALL blacs_set(context, 15, 0)
14183 40 CONTINUE
14184 testok = ( k .EQ. nerr )
14185 END IF
14186 END IF
14187*
14188 IF( verb .GT. 1 ) THEN
14189 i = nerr
14190 CALL zbtcheckin(0, outnum, maxerr, nerr,
14191 $ mem(erriptr), mem(errdptr), iseed)
14192 IF( iam .EQ. 0 ) THEN
14193 IF( testok .AND. nerr.EQ.i ) THEN
14194 WRITE(outnum,6000)testnum,'PASSED ',
14195 $ scope, top, m, n, ldasrc,
14196 $ ldadst, rdest2, cdest2,
14197 $ nprow, npcol
14198 ELSE
14199 nfail = nfail + 1
14200 WRITE(outnum,6000)testnum,'FAILED ',
14201 $ scope, top, m, n, ldasrc,
14202 $ ldadst, rdest2, cdest2,
14203 $ nprow, npcol
14204 END IF
14205 END IF
14206*
14207* Once we've printed out errors, can re-use buf space
14208*
14209 nerr = 0
14210 END IF
14211 50 CONTINUE
14212 60 CONTINUE
14213 70 CONTINUE
14214 80 CONTINUE
14215 90 CONTINUE
14216*
14217 IF( verb .LT. 2 ) THEN
14218 nfail = testnum
14219 CALL zbtcheckin( nfail, outnum, maxerr, nerr, mem(erriptr),
14220 $ mem(errdptr), iseed )
14221 END IF
14222 IF( iam .EQ. 0 ) THEN
14223 IF( verb .GT. 1 ) WRITE(outnum,*) ' '
14224 IF( nfail+nskip .EQ. 0 ) THEN
14225 WRITE(outnum, 7000 ) testnum
14226 ELSE
14227 WRITE(outnum, 8000 ) testnum, testnum-nskip-nfail,
14228 $ nskip, nfail
14229 END IF
14230 END IF
14231*
14232* Log whether their were any failures
14233*
14234 testok = allpass( (nfail.EQ.0) )
14235*
14236 1000 FORMAT('DOUBLE COMPLEX SUM TESTS: BEGIN.' )
14237 2000 FORMAT(1x,a7,3x,10i6)
14238 3000 FORMAT(1x,a7,3x,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,
14239 $ 5x,a1,5x,a1)
14240 4000 FORMAT(' TEST# STATUS SCOPE TOP M N LDAS LDAD ',
14241 $ 'RDEST CDEST P Q')
14242 5000 FORMAT(' ----- ------- ----- --- ----- ----- ----- ----- ',
14243 $ '----- ----- ---- ----')
14244 6000 FORMAT(i6,1x,a7,5x,a1,3x,a1,6i6,2i5)
14245 7000 FORMAT('DOUBLE COMPLEX SUM TESTS: PASSED ALL',
14246 $ i5, ' TESTS.')
14247 8000 FORMAT('DOUBLE COMPLEX SUM TESTS:',i5,' TESTS;',i5,' PASSED,',
14248 $ i5,' SKIPPED,',i5,' FAILED.')
14249*
14250 RETURN
14251*
14252* End of ZTESTSUM.
14253*
14254 END
14255*
14256 DOUBLE PRECISION FUNCTION zbtabs(VAL)
14257 DOUBLE COMPLEX val
14258 zbtabs = abs( dble(val) ) + abs( dimag(val) )
14259 RETURN
14260 END
14261*
14262 SUBROUTINE zchksum( SCOPE, ICTXT, M, N, A, LDA, TESTNUM, MAXERR,
14263 $ NERR, ERRIBUF, ERRDBUF, ISEED )
14264*
14265* .. Scalar Arguments ..
14266 CHARACTER*1 SCOPE
14267 INTEGER ICTXT, M, N, LDA, TESTNUM, MAXERR, NERR
14268* ..
14269* .. Array Arguments ..
14270 INTEGER ERRIBUF(6, MAXERR), ISEED(*)
14271 DOUBLE COMPLEX A(LDA,*), ERRDBUF(2, MAXERR)
14272* ..
14273* .. External Functions ..
14274 INTEGER IBTMYPROC, IBTNPROCS
14275 DOUBLE PRECISION DBTEPS
14276 DOUBLE COMPLEX ZBTRAN
14277 EXTERNAL IBTMYPROC, IBTNPROCS, DBTEPS, ZBTRAN
14278* ..
14279* .. Local Scalars ..
14280 LOGICAL NUMOK
14281 INTEGER NPROCS, NPROW, NPCOL, MYROW, MYCOL, NODE, NNODES, DEST
14282 INTEGER I, J, K
14283 DOUBLE COMPLEX ANS, TMP
14284 DOUBLE PRECISION EPS, ERRBND, RPOSNUM, RNEGNUM, IPOSNUM, INEGNUM
14285* ..
14286* .. Executable Statements ..
14287*
14288 nprocs = ibtnprocs()
14289 eps = dbteps()
14290 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
14291 dest = myrow*nprocs + mycol
14292*
14293* Set up seeds to match those used by each proc's genmat call
14294*
14295 IF( scope .EQ. 'R' ) THEN
14296 nnodes = npcol
14297 DO 10 i = 0, nnodes-1
14298 node = myrow * nprocs + i
14299 iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
14300 iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
14301 iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
14302 iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
14303 10 CONTINUE
14304 ELSE IF( scope .EQ. 'C' ) THEN
14305 nnodes = nprow
14306 DO 20 i = 0, nnodes-1
14307 node = i * nprocs + mycol
14308 iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
14309 iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
14310 iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
14311 iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
14312 20 CONTINUE
14313 ELSE
14314 nnodes = nprow * npcol
14315 DO 30 i = 0, nnodes-1
14316 node = (i / npcol) * nprocs + mod(i, npcol)
14317 iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
14318 iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
14319 iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
14320 iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
14321 30 CONTINUE
14322 END IF
14323*
14324 DO 100 j = 1, n
14325 DO 90 i = 1, m
14326 ans = 0
14327 rposnum = 0
14328 rnegnum = 0
14329 iposnum = 0
14330 inegnum = 0
14331 DO 40 k = 0, nnodes-1
14332 tmp = zbtran( iseed(k*4+1) )
14333 IF( dble( tmp ) .LT. 0 ) THEN
14334 rnegnum = rnegnum + dble( tmp )
14335 ELSE
14336 rposnum = rposnum + dble( tmp )
14337 END IF
14338 IF( dimag( tmp ) .LT. 0 ) THEN
14339 inegnum = inegnum + dimag( tmp )
14340 ELSE
14341 iposnum = iposnum + dimag( tmp )
14342 END IF
14343 ans = ans + tmp
14344 40 CONTINUE
14345*
14346* The error bound is figured by
14347* 2 * eps * (nnodes-1) * max(|max element|, |ans|).
14348* The 2 allows for errors in the distributed _AND_ local result.
14349* The eps is machine epsilon. The number of floating point adds
14350* is (nnodes - 1). We use the fact that 0.5 is the maximum element
14351* in order to save ourselves some computation.
14352*
14353 tmp = ans - a(i,j)
14354 errbnd = 2 * eps * nnodes * max( rposnum, -rnegnum )
14355 numok = ( dble(tmp) .LE. errbnd )
14356 errbnd = 2 * eps * nnodes * max( iposnum, -inegnum )
14357 numok = numok .AND. ( dimag(tmp) .LE. errbnd )
14358 IF( .NOT.numok ) THEN
14359 nerr = nerr + 1
14360 IF( nerr .LE. maxerr ) THEN
14361 erribuf(1, nerr) = testnum
14362 erribuf(2, nerr) = nnodes
14363 erribuf(3, nerr) = dest
14364 erribuf(4, nerr) = i
14365 erribuf(5, nerr) = j
14366 erribuf(6, nerr) = 5
14367 errdbuf(1, nerr) = a(i,j)
14368 errdbuf(2, nerr) = ans
14369 END IF
14370 END IF
14371 90 CONTINUE
14372 100 CONTINUE
14373*
14374 RETURN
14375*
14376* End of ZCHKSUM
14377*
14378 END
14379*
14380*
14381 SUBROUTINE iamxtest( OUTNUM, VERB, TOPSREPEAT, TOPSCOHRNT, NSCOPE,
14382 $ SCOPE0, NTOP, TOP0, NMAT, M0, N0, LDAS0,
14383 $ LDAD0, LDI0, NDEST, RDEST0, CDEST0, NGRID,
14384 $ CONTEXT0, P0, Q0, ISEED, RMEM, CMEM, RCLEN,
14385 $ MEM, MEMLEN )
14386*
14387* -- BLACS tester (version 1.0) --
14388* University of Tennessee
14389* December 15, 1994
14390*
14391*
14392* .. Scalar Arguments ..
14393 INTEGER MEMLEN, NDEST, NGRID, NMAT, NSCOPE, NTOP, OUTNUM, RCLEN,
14394 $ topscohrnt, topsrepeat, verb
14395* ..
14396* .. Array Arguments ..
14397 CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP)
14398 INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT), LDI0(NMAT)
14399 INTEGER RDEST0(NDEST), CDEST0(NDEST), CONTEXT0(NGRID)
14400 INTEGER P0(NGRID), Q0(NGRID), ISEED(*), RMEM(RCLEN), CMEM(RCLEN)
14401 INTEGER MEM(MEMLEN)
14402* ..
14403*
14404* Purpose
14405* =======
14406* ITESTAMX: Test integer AMX COMBINE
14407*
14408* Arguments
14409* =========
14410* OUTNUM (input) INTEGER
14411* The device number to write output to.
14412*
14413* VERB (input) INTEGER
14414* The level of verbosity (how much printing to do).
14415*
14416* NSCOPE (input) INTEGER
14417* The number of scopes to be tested.
14418*
14419* SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE)
14420* Values of the scopes to be tested.
14421*
14422* NTOP (input) INTEGER
14423* The number of topologies to be tested.
14424*
14425* TOP0 (input) CHARACTER*1 array of dimension (NTOP)
14426* Values of the topologies to be tested.
14427*
14428* NMAT (input) INTEGER
14429* The number of matrices to be tested.
14430*
14431* M0 (input) INTEGER array of dimension (NMAT)
14432* Values of M to be tested.
14433*
14434* M0 (input) INTEGER array of dimension (NMAT)
14435* Values of M to be tested.
14436*
14437* N0 (input) INTEGER array of dimension (NMAT)
14438* Values of N to be tested.
14439*
14440* LDAS0 (input) INTEGER array of dimension (NMAT)
14441* Values of LDAS (leading dimension of A on source process)
14442* to be tested.
14443*
14444* LDAD0 (input) INTEGER array of dimension (NMAT)
14445* Values of LDAD (leading dimension of A on destination
14446* process) to be tested.
14447* LDI0 (input) INTEGER array of dimension (NMAT)
14448* Values of LDI (leading dimension of RA/CA) to be tested.
14449* If LDI == -1, these RA/CA should not be accessed.
14450*
14451* NDEST (input) INTEGER
14452* The number of destinations to be tested.
14453*
14454* RDEST0 (input) INTEGER array of dimension (NNDEST)
14455* Values of RDEST (row coordinate of destination) to be
14456* tested.
14457*
14458* CDEST0 (input) INTEGER array of dimension (NNDEST)
14459* Values of CDEST (column coordinate of destination) to be
14460* tested.
14461*
14462* NGRID (input) INTEGER
14463* The number of process grids to be tested.
14464*
14465* CONTEXT0 (input) INTEGER array of dimension (NGRID)
14466* The BLACS context handles corresponding to the grids.
14467*
14468* P0 (input) INTEGER array of dimension (NGRID)
14469* Values of P (number of process rows, NPROW).
14470*
14471* Q0 (input) INTEGER array of dimension (NGRID)
14472* Values of Q (number of process columns, NPCOL).
14473*
14474* ISEED (workspace) INTEGER array of dimension ( MAX(NPROCS, NTESTS) )
14475* Workspace used to hold each process's random number SEED.
14476* This requires NPROCS (number of processor) elements.
14477* If VERB < 2, this workspace also serves to indicate which
14478* tests fail. This requires workspace of NTESTS
14479* (number of tests performed).
14480*
14481* RMEM (workspace) INTEGER array of dimension (RCLEN)
14482* Used for all RA arrays, and their pre and post padding.
14483*
14484* CMEM (workspace) INTEGER array of dimension (RCLEN)
14485* Used for all CA arrays, and their pre and post padding.
14486*
14487* RCLEN (input) INTEGER
14488* The length, in elements, of RMEM and CMEM.
14489*
14490* MEM (workspace) INTEGER array of dimension (MEMLEN)
14491* Used for all other workspaces, including the matrix A,
14492* and its pre and post padding.
14493*
14494* MEMLEN (input) INTEGER
14495* The length, in elements, of MEM.
14496*
14497* =====================================================================
14498*
14499* .. External Functions ..
14500 LOGICAL ALLPASS, LSAME
14501 INTEGER IBTMYPROC, IBTNPROCS, IBTSIZEOF
14502 EXTERNAL ALLPASS, LSAME, IBTMYPROC, IBTNPROCS, IBTSIZEOF
14503* ..
14504* .. External Subroutines ..
14505 EXTERNAL blacs_gridinfo, igamx2d
14506 EXTERNAL iinitmat, ichkpad, ibtcheckin
14507* ..
14508* .. Local Scalars ..
14509 CHARACTER*1 SCOPE, TOP
14510 LOGICAL INGRID, TESTOK, ALLRCV
14511 INTEGER APTR, CAPTR, CDEST, CDEST2, CONTEXT, ERRDPTR, ERRIPTR, I,
14512 $ IAM, ICHECKVAL, IDE, IGR, IMA, IPAD, IPOST, IPRE, ISC,
14513 $ ISIZE, ISTART, ISTOP, ITC, ITC1, ITC2, ITO, ITR, ITR1,
14514 $ ITR2, J, K, LDA, LDADST, LDASRC, LDI, M, MAXERR, MYCOL,
14515 $ MYROW, N, NERR, NFAIL, NPCOL, NPROW, NSKIP, PREAPTR,
14516 $ RAPTR, RDEST, RDEST2, SETWHAT, TESTNUM, VALPTR
14517 INTEGER CHECKVAL
14518* ..
14519* .. Executable Statements ..
14520*
14521* Choose padding value, and make it unique
14522*
14523 CHECKVAL = -911
14524 iam = ibtmyproc()
14525 checkval = iam * checkval
14526 isize = ibtsizeof('I')
14527 icheckval = -iam
14528*
14529* Verify file parameters
14530*
14531 IF( iam .EQ. 0 ) THEN
14532 WRITE(outnum, *) ' '
14533 WRITE(outnum, *) ' '
14534 WRITE(outnum, 1000 )
14535 IF( verb .GT. 0 ) THEN
14536 WRITE(outnum,*) ' '
14537 WRITE(outnum, 2000) 'NSCOPE:', nscope
14538 WRITE(outnum, 3000) ' SCOPE:', ( scope0(i), i = 1, nscope )
14539 WRITE(outnum, 2000) 'TReps :', topsrepeat
14540 WRITE(outnum, 2000) 'TCohr :', topscohrnt
14541 WRITE(outnum, 2000) 'NTOP :', ntop
14542 WRITE(outnum, 3000) ' TOP :', ( top0(i), i = 1, ntop )
14543 WRITE(outnum, 2000) 'NMAT :', nmat
14544 WRITE(outnum, 2000) ' M :', ( m0(i), i = 1, nmat )
14545 WRITE(outnum, 2000) ' N :', ( n0(i), i = 1, nmat )
14546 WRITE(outnum, 2000) ' LDAS :', ( ldas0(i), i = 1, nmat )
14547 WRITE(outnum, 2000) ' LDAD :', ( ldad0(i), i = 1, nmat )
14548 WRITE(outnum, 2000) ' LDI :', ( ldi0(i), i = 1, nmat )
14549 WRITE(outnum, 2000) 'NDEST :', ndest
14550 WRITE(outnum, 2000) ' RDEST:',( rdest0(i), i = 1, ndest )
14551 WRITE(outnum, 2000) ' CDEST:',( cdest0(i), i = 1, ndest )
14552 WRITE(outnum, 2000) 'NGRIDS:', ngrid
14553 WRITE(outnum, 2000) ' P :', ( p0(i), i = 1, ngrid )
14554 WRITE(outnum, 2000) ' Q :', ( q0(i), i = 1, ngrid )
14555 WRITE(outnum, 2000) 'VERB :', verb
14556 WRITE(outnum,*) ' '
14557 END IF
14558 IF( verb .GT. 1 ) THEN
14559 WRITE(outnum,4000)
14560 WRITE(outnum,5000)
14561 END IF
14562 END IF
14563 IF (topsrepeat.EQ.0) THEN
14564 itr1 = 0
14565 itr2 = 0
14566 ELSE IF (topsrepeat.EQ.1) THEN
14567 itr1 = 1
14568 itr2 = 1
14569 ELSE
14570 itr1 = 0
14571 itr2 = 1
14572 END IF
14573*
14574* Find biggest matrix, so we know where to stick error info
14575*
14576 i = 0
14577 DO 10 ima = 1, nmat
14578 ipad = 4 * m0(ima)
14579 k = n0(ima) * max0( ldas0(ima), ldad0(ima) ) + ipad
14580 IF( k .GT. i ) i = k
14581 10 CONTINUE
14582 i = i + ibtnprocs()
14583 maxerr = ( isize * (memlen-i) ) / ( isize*2 + isize*6 )
14584 IF( maxerr .LT. 1 ) THEN
14585 WRITE(outnum,*) 'ERROR: Not enough memory to run MAX tests.'
14586 CALL blacs_abort(-1, 1)
14587 END IF
14588 errdptr = i + 1
14589 erriptr = errdptr + maxerr
14590 nerr = 0
14591 testnum = 0
14592 nfail = 0
14593 nskip = 0
14594*
14595* Loop over grids of matrix
14596*
14597 DO 90 igr = 1, ngrid
14598*
14599* allocate process grid for the next batch of tests
14600*
14601 context = context0(igr)
14602 CALL blacs_gridinfo( context, nprow, npcol, myrow, mycol )
14603 ingrid = ( (myrow.LT.nprow) .AND. (mycol.LT.npcol) )
14604*
14605 DO 80 isc = 1, nscope
14606 scope = scope0(isc)
14607 DO 70 ito = 1, ntop
14608 top = top0(ito)
14609*
14610* If testing multiring ('M') or general tree ('T'), need to
14611* loop over calls to BLACS_SET to do full test
14612*
14613 IF( lsame(top, 'M') ) THEN
14614 setwhat = 13
14615 IF( scope .EQ. 'R' ) THEN
14616 istart = -(npcol - 1)
14617 istop = -istart
14618 ELSE IF (scope .EQ. 'C') THEN
14619 istart = -(nprow - 1)
14620 istop = -istart
14621 ELSE
14622 istart = -(nprow*npcol - 1)
14623 istop = -istart
14624 ENDIF
14625 ELSE IF( lsame(top, 'T') ) THEN
14626 setwhat = 14
14627 istart = 1
14628 IF( scope .EQ. 'R' ) THEN
14629 istop = npcol - 1
14630 ELSE IF (scope .EQ. 'C') THEN
14631 istop = nprow - 1
14632 ELSE
14633 istop = nprow*npcol - 1
14634 ENDIF
14635 ELSE
14636 setwhat = 0
14637 istart = 1
14638 istop = 1
14639 ENDIF
14640 DO 60 ima = 1, nmat
14641 m = m0(ima)
14642 n = n0(ima)
14643 ldasrc = ldas0(ima)
14644 ldadst = ldad0(ima)
14645 ldi = ldi0(ima)
14646 ipre = 2 * m
14647 ipost = ipre
14648 preaptr = 1
14649 aptr = preaptr + ipre
14650*
14651 DO 50 ide = 1, ndest
14652 testnum = testnum + 1
14653 rdest2 = rdest0(ide)
14654 cdest2 = cdest0(ide)
14655*
14656* If everyone gets the answer, create some bogus rdest/cdest
14657* so IF's are easier
14658*
14659 allrcv = ( (rdest2.EQ.-1) .OR. (cdest2.EQ.-1) )
14660 IF( allrcv ) THEN
14661 rdest = nprow - 1
14662 cdest = npcol - 1
14663 IF (topscohrnt.EQ.0) THEN
14664 itr1 = 0
14665 itr2 = 0
14666 ELSE IF (topscohrnt.EQ.1) THEN
14667 itr1 = 1
14668 itr2 = 1
14669 ELSE
14670 itr1 = 0
14671 itr2 = 1
14672 END IF
14673 ELSE
14674 rdest = rdest2
14675 cdest = cdest2
14676 itc1 = 0
14677 itc2 = 0
14678 END IF
14679 IF( rdest.GE.p0(igr) .OR. cdest.GE.q0(igr) ) THEN
14680 nskip = nskip + 1
14681 GOTO 50
14682 END IF
14683*
14684 IF( myrow.EQ.rdest .AND. mycol.EQ.cdest ) THEN
14685 lda = ldadst
14686 ELSE
14687 lda = ldasrc
14688 END IF
14689 valptr = aptr + ipost + n * lda
14690 IF( verb .GT. 1 ) THEN
14691 IF( iam .EQ. 0 ) THEN
14692 WRITE(outnum, 6000)
14693 $ testnum, 'RUNNING', scope, top, m, n,
14694 $ ldasrc, ldadst, ldi, rdest2, cdest2,
14695 $ nprow, npcol
14696 END IF
14697 END IF
14698*
14699* If I am in scope
14700*
14701 testok = .true.
14702 IF( ingrid ) THEN
14703 IF( (myrow.EQ.rdest .AND. scope.EQ.'R') .OR.
14704 $ (mycol.EQ.cdest .AND. scope.EQ.'C') .OR.
14705 $ (scope .EQ. 'A') ) THEN
14706*
14707 k = nerr
14708 DO 40 itr = itr1, itr2
14709 CALL blacs_set(context, 15, itr)
14710 DO 35 itc = itc1, itc2
14711 CALL blacs_set(context, 16, itc)
14712 DO 30 j = istart, istop
14713 IF( j.EQ.0) GOTO 30
14714 IF( setwhat.NE.0 )
14715 $ CALL blacs_set(context, setwhat, j)
14716*
14717*
14718* generate and pad matrix A
14719*
14720 CALL iinitmat('G','-', m, n, mem(preaptr),
14721 $ lda, ipre, ipost,
14722 $ checkval, testnum,
14723 $ myrow, mycol )
14724*
14725* If they exist, pad RA and CA arrays
14726*
14727 IF( ldi .NE. -1 ) THEN
14728 DO 15 i = 1, n*ldi + ipre + ipost
14729 rmem(i) = icheckval
14730 cmem(i) = icheckval
14731 15 CONTINUE
14732 raptr = 1 + ipre
14733 captr = 1 + ipre
14734 ELSE
14735 DO 20 i = 1, ipre+ipost
14736 rmem(i) = icheckval
14737 cmem(i) = icheckval
14738 20 CONTINUE
14739 raptr = 1
14740 captr = 1
14741 END IF
14742*
14743 CALL igamx2d(context, scope, top, m, n,
14744 $ mem(aptr), lda, rmem(raptr),
14745 $ cmem(captr), ldi,
14746 $ rdest2, cdest2)
14747*
14748* If I've got the answer, check for errors in
14749* matrix or padding
14750*
14751 IF( (myrow.EQ.rdest .AND. mycol.EQ.cdest)
14752 $ .OR. allrcv ) THEN
14753 CALL ichkpad('G','-', m, n,
14754 $ mem(preaptr), lda, rdest,
14755 $ cdest, myrow, mycol,
14756 $ ipre, ipost, checkval,
14757 $ testnum, maxerr, nerr,
14758 $ mem(erriptr),mem(errdptr))
14759 CALL ichkamx(scope, context, m, n,
14760 $ mem(aptr), lda,
14761 $ rmem(raptr), cmem(captr),
14762 $ ldi, testnum, maxerr,nerr,
14763 $ mem(erriptr),mem(errdptr),
14764 $ iseed, mem(valptr))
14765 CALL ircchk(ipre, ipost, icheckval,
14766 $ m, n, rmem, cmem, ldi,
14767 $ myrow, mycol, testnum,
14768 $ maxerr, nerr,
14769 $ mem(erriptr), mem(errdptr))
14770 END IF
14771 30 CONTINUE
14772 CALL blacs_set(context, 16, 0)
14773 35 CONTINUE
14774 CALL blacs_set(context, 15, 0)
14775 40 CONTINUE
14776 testok = ( k .EQ. nerr )
14777 END IF
14778 END IF
14779*
14780 IF( verb .GT. 1 ) THEN
14781 i = nerr
14782 CALL ibtcheckin(0, outnum, maxerr, nerr,
14783 $ mem(erriptr), mem(errdptr), iseed)
14784 IF( iam .EQ. 0 ) THEN
14785 IF( testok .AND. nerr.EQ.i ) THEN
14786 WRITE(outnum,6000)testnum,'PASSED ',
14787 $ scope, top, m, n, ldasrc,
14788 $ ldadst, ldi, rdest2, cdest2,
14789 $ nprow, npcol
14790 ELSE
14791 nfail = nfail + 1
14792 WRITE(outnum,6000)testnum,'FAILED ',
14793 $ scope, top, m, n, ldasrc,
14794 $ ldadst, ldi, rdest2, cdest2,
14795 $ nprow, npcol
14796 END IF
14797 END IF
14798*
14799* Once we've printed out errors, can re-use buf space
14800*
14801 nerr = 0
14802 END IF
14803 50 CONTINUE
14804 60 CONTINUE
14805 70 CONTINUE
14806 80 CONTINUE
14807 90 CONTINUE
14808*
14809 IF( verb .LT. 2 ) THEN
14810 nfail = testnum
14811 CALL ibtcheckin( nfail, outnum, maxerr, nerr, mem(erriptr),
14812 $ mem(errdptr), iseed )
14813 END IF
14814 IF( iam .EQ. 0 ) THEN
14815 IF( verb .GT. 1 ) WRITE(outnum,*) ' '
14816 IF( nfail+nskip .EQ. 0 ) THEN
14817 WRITE(outnum, 7000 ) testnum
14818 ELSE
14819 WRITE(outnum, 8000 ) testnum, testnum-nskip-nfail,
14820 $ nskip, nfail
14821 END IF
14822 END IF
14823*
14824* Log whether their were any failures
14825*
14826 testok = allpass( (nfail.EQ.0) )
14827*
14828 1000 FORMAT('INTEGER AMX TESTS: BEGIN.' )
14829 2000 FORMAT(1x,a7,3x,10i6)
14830 3000 FORMAT(1x,a7,3x,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,
14831 $ 5x,a1,5x,a1)
14832 4000 FORMAT(' TEST# STATUS SCOPE TOP M N LDAS LDAD LDI ',
14833 $ 'RDEST CDEST P Q')
14834 5000 FORMAT(' ----- ------- ----- --- ----- ----- ----- ----- ----- ',
14835 $ '----- ----- ---- ----')
14836 6000 FORMAT(i6,1x,a7,5x,a1,3x,a1,7i6,2i5)
14837 7000 FORMAT('INTEGER AMX TESTS: PASSED ALL',
14838 $ i5, ' TESTS.')
14839 8000 FORMAT('INTEGER AMX TESTS:',i5,' TESTS;',i5,' PASSED,',
14840 $ i5,' SKIPPED,',i5,' FAILED.')
14841*
14842 RETURN
14843*
14844* End of ITESTAMX.
14845*
14846 END
14847*
14848 SUBROUTINE ibtspcoord( SCOPE, PNUM, MYROW, MYCOL, NPCOL,
14849 $ PROW, PCOL )
14850 CHARACTER*1 SCOPE
14851 INTEGER PNUM, MYROW, MYCOL, NPCOL, PROW, PCOL
14852*
14853 IF( scope .EQ. 'R' ) THEN
14854 prow = myrow
14855 pcol = pnum
14856 ELSE IF( scope .EQ. 'C' ) THEN
14857 prow = pnum
14858 pcol = mycol
14859 ELSE
14860 prow = pnum / npcol
14861 pcol = mod( pnum, npcol )
14862 END IF
14863 RETURN
14864*
14865* End of ibtspcoord
14866*
14867 END
14868*
14869 INTEGER FUNCTION ibtspnum( SCOPE, PROW, PCOL, NPCOL )
14870 CHARACTER*1 scope
14871 INTEGER prow, pcol, npcol
14872 if( scope .EQ. 'R' ) then
14873 ibtspnum = pcol
14874 ELSE IF( scope .EQ. 'C' ) THEN
14875 ibtspnum = prow
14876 ELSE
14877 ibtspnum = prow*npcol + pcol
14878 END IF
14879*
14880 RETURN
14881*
14882* End of ibtscpnum
14883*
14884 END
14885*
14886 SUBROUTINE ircchk( IPRE, IPOST, PADVAL, M, N, RA, CA, LDI, MYROW,
14887 $ MYCOL, TESTNUM, MAXERR, NERR,
14888 $ ERRIBUF, ERRDBUF )
14889*
14890* .. Scalar Arguments ..
14891 INTEGER IPRE, IPOST, PADVAL, M, N, LDI, MYROW, MYCOL, TESTNUM
14892 INTEGER MAXERR, NERR
14893* ..
14894* .. Array Arguments ..
14895 INTEGER RA(*), CA(*), ERRIBUF(6, MAXERR)
14896 INTEGER ERRDBUF(2, MAXERR)
14897* ..
14898* .. Parameters ..
14899 INTEGER ERR_PRE, ERR_POST, ERR_GAP, ERR_TRI, ERR_MAT
14900 PARAMETER( ERR_PRE = 1, err_post = 2, err_gap = 3, err_tri = 4 )
14901 parameter( err_mat = 5 )
14902* ..
14903* .. External Functions ..
14904 INTEGER IBTNPROCS
14905 EXTERNAL ibtnprocs
14906* ..
14907* .. Local Scalars ..
14908 INTEGER I, J, K, IAM
14909* ..
14910* .. Executable Statements ..
14911*
14912 iam = myrow * ibtnprocs() + mycol
14913*
14914* Check pre padding
14915*
14916 IF( ldi .NE. -1 ) THEN
14917 IF( ipre .GT. 0 ) THEN
14918 DO 10 i = 1, ipre
14919 IF( ra(i) .NE. padval ) THEN
14920 nerr = nerr + 1
14921 IF( nerr .LE. maxerr ) THEN
14922 erribuf(1, nerr) = testnum
14923 erribuf(2, nerr) = ldi
14924 erribuf(3, nerr) = iam
14925 erribuf(4, nerr) = i
14926 erribuf(5, nerr) = ipre - i + 1
14927 erribuf(6, nerr) = -err_pre
14928 errdbuf(1, nerr) = int( ra(i) )
14929 errdbuf(2, nerr) = int( padval )
14930 END IF
14931 ENDIF
14932 IF( ca(i) .NE. padval ) THEN
14933 nerr = nerr + 1
14934 IF( nerr .LE. maxerr ) THEN
14935 erribuf(1, nerr) = testnum
14936 erribuf(2, nerr) = ldi
14937 erribuf(3, nerr) = iam
14938 erribuf(4, nerr) = i
14939 erribuf(5, nerr) = ipre - i + 1
14940 erribuf(6, nerr) = -10 - err_pre
14941 errdbuf(1, nerr) = int( ca(i) )
14942 errdbuf(2, nerr) = int( padval )
14943 END IF
14944 ENDIF
14945 10 CONTINUE
14946 END IF
14947*
14948* Check post padding
14949*
14950 IF( ipost .GT. 0 ) THEN
14951 k = ipre + ldi*n
14952 DO 20 i = k+1, k+ipost
14953 IF( ra(i) .NE. padval ) THEN
14954 nerr = nerr + 1
14955 IF( nerr .LE. maxerr ) THEN
14956 erribuf(1, nerr) = testnum
14957 erribuf(2, nerr) = ldi
14958 erribuf(3, nerr) = iam
14959 erribuf(4, nerr) = i - k
14960 erribuf(5, nerr) = i
14961 erribuf(6, nerr) = -err_post
14962 errdbuf(1, nerr) = int( ra(i) )
14963 errdbuf(2, nerr) = int( padval )
14964 END IF
14965 ENDIF
14966 IF( ca(i) .NE. padval ) THEN
14967 nerr = nerr + 1
14968 IF( nerr .LE. maxerr ) THEN
14969 erribuf(1, nerr) = testnum
14970 erribuf(2, nerr) = ldi
14971 erribuf(3, nerr) = iam
14972 erribuf(4, nerr) = i - k
14973 erribuf(5, nerr) = i
14974 erribuf(6, nerr) = -10 - err_post
14975 errdbuf(1, nerr) = int( ca(i) )
14976 errdbuf(2, nerr) = int( padval )
14977 END IF
14978 ENDIF
14979 20 CONTINUE
14980 END IF
14981*
14982* Check all (LDI-M) gaps
14983*
14984 IF( ldi .GT. m ) THEN
14985 k = ipre + m + 1
14986 DO 40 j = 1, n
14987 DO 30 i = m+1, ldi
14988 k = ipre + (j-1)*ldi + i
14989 IF( ra(k) .NE. padval) THEN
14990 nerr = nerr + 1
14991 IF( nerr .LE. maxerr ) THEN
14992 erribuf(1, nerr) = testnum
14993 erribuf(2, nerr) = ldi
14994 erribuf(3, nerr) = iam
14995 erribuf(4, nerr) = i
14996 erribuf(5, nerr) = j
14997 erribuf(6, nerr) = -err_gap
14998 errdbuf(1, nerr) = int( ra(k) )
14999 errdbuf(2, nerr) = int( padval )
15000 END IF
15001 END IF
15002 IF( ca(k) .NE. padval) THEN
15003 nerr = nerr + 1
15004 IF( nerr .LE. maxerr ) THEN
15005 erribuf(1, nerr) = testnum
15006 erribuf(2, nerr) = ldi
15007 erribuf(3, nerr) = iam
15008 erribuf(4, nerr) = i
15009 erribuf(5, nerr) = j
15010 erribuf(6, nerr) = -10 - err_gap
15011 errdbuf(1, nerr) = int( ca(k) )
15012 errdbuf(2, nerr) = int( padval )
15013 END IF
15014 END IF
15015 30 CONTINUE
15016 40 CONTINUE
15017 END IF
15018*
15019* if RA and CA don't exist, buffs better be untouched
15020*
15021 ELSE
15022 DO 50 i = 1, ipre+ipost
15023 IF( ra(i) .NE. padval) THEN
15024 nerr = nerr + 1
15025 IF( nerr .LE. maxerr ) THEN
15026 erribuf(1, nerr) = testnum
15027 erribuf(2, nerr) = ldi
15028 erribuf(3, nerr) = iam
15029 erribuf(4, nerr) = i
15030 erribuf(5, nerr) = ipre+ipost
15031 erribuf(6, nerr) = -err_pre
15032 errdbuf(1, nerr) = int( ra(i) )
15033 errdbuf(2, nerr) = int( padval )
15034 END IF
15035 END IF
15036 IF( ca(i) .NE. padval) THEN
15037 nerr = nerr + 1
15038 IF( nerr .LE. maxerr ) THEN
15039 erribuf(1, nerr) = testnum
15040 erribuf(2, nerr) = ldi
15041 erribuf(3, nerr) = iam
15042 erribuf(4, nerr) = i
15043 erribuf(5, nerr) = ipre+ipost
15044 erribuf(6, nerr) = -10 - err_pre
15045 errdbuf(1, nerr) = int( ca(i) )
15046 errdbuf(2, nerr) = int( padval )
15047 END IF
15048 END IF
15049 50 CONTINUE
15050 ENDIF
15051*
15052 RETURN
15053 END
15054*
15055 SUBROUTINE ichkamx( SCOPE, ICTXT, M, N, A, LDA, RA, CA, LDI,
15056 $ TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF,
15057 $ ISEED, VALS )
15058*
15059* .. Scalar Arguments ..
15060 CHARACTER*1 SCOPE
15061 INTEGER ICTXT, M, N, LDA, LDI, TESTNUM, MAXERR, NERR
15062* ..
15063* .. Array Arguments ..
15064 INTEGER RA(*), CA(*), ERRIBUF(6, MAXERR), ISEED(*)
15065 INTEGER A(LDA,*), ERRDBUF(2, MAXERR), VALS(*)
15066* ..
15067* .. External Functions ..
15068 INTEGER IBTMYPROC, IBTNPROCS, IBTSPNUM, IBTRAN, IBTABS
15069 EXTERNAL ibtmyproc, ibtnprocs, ibtspnum, ibtran
15070 EXTERNAL ibtabs
15071* ..
15072* .. External Subroutines ..
15073 EXTERNAL ibtspcoord
15074* ..
15075* .. Local Scalars ..
15076 LOGICAL ERROR
15077 INTEGER NPROCS, NNODES, NPROW, NPCOL, MYROW, MYCOL, RAMX, CAMX
15078 INTEGER IAMX, I, J, K, H, DEST, NODE
15079* ..
15080* .. Executable Statements ..
15081*
15082 nprocs = ibtnprocs()
15083 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
15084 dest = myrow*nprocs + mycol
15085*
15086* Set up seeds to match those used by each proc's genmat call
15087*
15088 IF( scope .EQ. 'R' ) THEN
15089 nnodes = npcol
15090 DO 10 i = 0, nnodes-1
15091 node = myrow * nprocs + i
15092 iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
15093 iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
15094 iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
15095 iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
15096 10 CONTINUE
15097 ELSE IF( scope .EQ. 'C' ) THEN
15098 nnodes = nprow
15099 DO 20 i = 0, nnodes-1
15100 node = i * nprocs + mycol
15101 iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
15102 iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
15103 iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
15104 iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
15105 20 CONTINUE
15106 ELSE
15107 nnodes = nprow * npcol
15108 DO 30 i = 0, nnodes-1
15109 node = (i / npcol) * nprocs + mod(i, npcol)
15110 iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
15111 iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
15112 iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
15113 iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
15114 30 CONTINUE
15115 END IF
15116*
15117 DO 100 j = 1, n
15118 DO 90 i = 1, m
15119 h = (j-1)*ldi + i
15120 vals(1) = ibtran( iseed )
15121 iamx = 1
15122 IF( nnodes .GT. 1 ) THEN
15123 DO 40 k = 1, nnodes-1
15124 vals(k+1) = ibtran( iseed(k*4+1) )
15125 IF( ibtabs( vals(k+1) ) .GT. ibtabs( vals(iamx) ) )
15126 $ iamx = k + 1
15127 40 CONTINUE
15128 END IF
15129*
15130* If BLACS have not returned same value we've chosen
15131*
15132 IF( a(i,j) .NE. vals(iamx) ) THEN
15133*
15134* If we have RA and CA arrays
15135*
15136 IF( ldi .NE. -1 ) THEN
15137*
15138* Any number having the same absolute value is a valid max
15139*
15140 k = ibtspnum( scope, ra(h), ca(h), npcol ) + 1
15141 IF( k.GT.0 .AND. k.LE.nnodes ) THEN
15142 error = ibtabs( vals(k) ).NE.ibtabs( vals(iamx) )
15143 IF( .NOT.error ) iamx = k
15144 ELSE
15145 error = .true.
15146 END IF
15147 ELSE
15148*
15149* Error if BLACS answer not same absolute value, or if it
15150* was not really in the numbers being compared
15151*
15152 error = ( ibtabs( a(i,j) ) .NE. ibtabs( vals(iamx) ) )
15153 IF( .NOT.error ) THEN
15154 DO 50 k = 1, nnodes
15155 IF( vals(k) .EQ. a(i,j) ) GOTO 60
15156 50 CONTINUE
15157 error = .true.
15158 60 CONTINUE
15159 ENDIF
15160 END IF
15161*
15162* If the value is in error
15163*
15164 IF( error ) THEN
15165 nerr = nerr + 1
15166 erribuf(1, nerr) = testnum
15167 erribuf(2, nerr) = nnodes
15168 erribuf(3, nerr) = dest
15169 erribuf(4, nerr) = i
15170 erribuf(5, nerr) = j
15171 erribuf(6, nerr) = 5
15172 errdbuf(1, nerr) = a(i,j)
15173 errdbuf(2, nerr) = vals(iamx)
15174 END IF
15175 END IF
15176*
15177* If they are defined, make sure coordinate entries are OK
15178*
15179 IF( ldi .NE. -1 ) THEN
15180 k = ibtspnum( scope, ra(h), ca(h), npcol ) + 1
15181 IF( k.NE.iamx ) THEN
15182*
15183* Make sure more than one proc doesn't have exact same value
15184* (and therefore there may be more than one valid coordinate
15185* for a single value)
15186*
15187 IF( k.GT.nnodes .OR. k.LT.1 ) THEN
15188 error = .true.
15189 ELSE
15190 error = ( vals(k) .NE. vals(iamx) )
15191 END IF
15192 IF( error ) THEN
15193 CALL ibtspcoord( scope, iamx-1, myrow, mycol,
15194 $ npcol, ramx, camx )
15195 IF( ramx .NE. ra(h) ) THEN
15196 nerr = nerr + 1
15197 erribuf(1, nerr) = testnum
15198 erribuf(2, nerr) = nnodes
15199 erribuf(3, nerr) = dest
15200 erribuf(4, nerr) = i
15201 erribuf(5, nerr) = j
15202 erribuf(6, nerr) = -5
15203 errdbuf(1, nerr) = ra(h)
15204 errdbuf(2, nerr) = ramx
15205 END IF
15206 IF( camx .NE. ca(h) ) THEN
15207 nerr = nerr + 1
15208 erribuf(1, nerr) = testnum
15209 erribuf(2, nerr) = nnodes
15210 erribuf(3, nerr) = dest
15211 erribuf(4, nerr) = i
15212 erribuf(5, nerr) = j
15213 erribuf(6, nerr) = -15
15214 errdbuf(1, nerr) = ca(h)
15215 errdbuf(2, nerr) = camx
15216 END IF
15217 END IF
15218 END IF
15219 END IF
15220 90 CONTINUE
15221 100 CONTINUE
15222*
15223 RETURN
15224*
15225* End of ICHKAMX
15226*
15227 END
15228*
15229*
15230 SUBROUTINE samxtest( OUTNUM, VERB, TOPSREPEAT, TOPSCOHRNT, NSCOPE,
15231 $ SCOPE0, NTOP, TOP0, NMAT, M0, N0, LDAS0,
15232 $ LDAD0, LDI0, NDEST, RDEST0, CDEST0, NGRID,
15233 $ CONTEXT0, P0, Q0, ISEED, RMEM, CMEM, RCLEN,
15234 $ MEM, MEMLEN )
15235*
15236* -- BLACS tester (version 1.0) --
15237* University of Tennessee
15238* December 15, 1994
15239*
15240*
15241* .. Scalar Arguments ..
15242 INTEGER MEMLEN, NDEST, NGRID, NMAT, NSCOPE, NTOP, OUTNUM, RCLEN,
15243 $ topscohrnt, topsrepeat, verb
15244* ..
15245* .. Array Arguments ..
15246 CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP)
15247 INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT), LDI0(NMAT)
15248 INTEGER RDEST0(NDEST), CDEST0(NDEST), CONTEXT0(NGRID)
15249 INTEGER P0(NGRID), Q0(NGRID), ISEED(*), RMEM(RCLEN), CMEM(RCLEN)
15250 REAL MEM(MEMLEN)
15251* ..
15252*
15253* Purpose
15254* =======
15255* STESTAMX: Test real AMX COMBINE
15256*
15257* Arguments
15258* =========
15259* OUTNUM (input) INTEGER
15260* The device number to write output to.
15261*
15262* VERB (input) INTEGER
15263* The level of verbosity (how much printing to do).
15264*
15265* NSCOPE (input) INTEGER
15266* The number of scopes to be tested.
15267*
15268* SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE)
15269* Values of the scopes to be tested.
15270*
15271* NTOP (input) INTEGER
15272* The number of topologies to be tested.
15273*
15274* TOP0 (input) CHARACTER*1 array of dimension (NTOP)
15275* Values of the topologies to be tested.
15276*
15277* NMAT (input) INTEGER
15278* The number of matrices to be tested.
15279*
15280* M0 (input) INTEGER array of dimension (NMAT)
15281* Values of M to be tested.
15282*
15283* M0 (input) INTEGER array of dimension (NMAT)
15284* Values of M to be tested.
15285*
15286* N0 (input) INTEGER array of dimension (NMAT)
15287* Values of N to be tested.
15288*
15289* LDAS0 (input) INTEGER array of dimension (NMAT)
15290* Values of LDAS (leading dimension of A on source process)
15291* to be tested.
15292*
15293* LDAD0 (input) INTEGER array of dimension (NMAT)
15294* Values of LDAD (leading dimension of A on destination
15295* process) to be tested.
15296* LDI0 (input) INTEGER array of dimension (NMAT)
15297* Values of LDI (leading dimension of RA/CA) to be tested.
15298* If LDI == -1, these RA/CA should not be accessed.
15299*
15300* NDEST (input) INTEGER
15301* The number of destinations to be tested.
15302*
15303* RDEST0 (input) INTEGER array of dimension (NNDEST)
15304* Values of RDEST (row coordinate of destination) to be
15305* tested.
15306*
15307* CDEST0 (input) INTEGER array of dimension (NNDEST)
15308* Values of CDEST (column coordinate of destination) to be
15309* tested.
15310*
15311* NGRID (input) INTEGER
15312* The number of process grids to be tested.
15313*
15314* CONTEXT0 (input) INTEGER array of dimension (NGRID)
15315* The BLACS context handles corresponding to the grids.
15316*
15317* P0 (input) INTEGER array of dimension (NGRID)
15318* Values of P (number of process rows, NPROW).
15319*
15320* Q0 (input) INTEGER array of dimension (NGRID)
15321* Values of Q (number of process columns, NPCOL).
15322*
15323* ISEED (workspace) INTEGER array of dimension ( MAX(NPROCS, NTESTS) )
15324* Workspace used to hold each process's random number SEED.
15325* This requires NPROCS (number of processor) elements.
15326* If VERB < 2, this workspace also serves to indicate which
15327* tests fail. This requires workspace of NTESTS
15328* (number of tests performed).
15329*
15330* RMEM (workspace) INTEGER array of dimension (RCLEN)
15331* Used for all RA arrays, and their pre and post padding.
15332*
15333* CMEM (workspace) INTEGER array of dimension (RCLEN)
15334* Used for all CA arrays, and their pre and post padding.
15335*
15336* RCLEN (input) INTEGER
15337* The length, in elements, of RMEM and CMEM.
15338*
15339* MEM (workspace) REAL array of dimension (MEMLEN)
15340* Used for all other workspaces, including the matrix A,
15341* and its pre and post padding.
15342*
15343* MEMLEN (input) INTEGER
15344* The length, in elements, of MEM.
15345*
15346* =====================================================================
15347*
15348* .. External Functions ..
15349 LOGICAL ALLPASS, LSAME
15350 INTEGER IBTMYPROC, IBTNPROCS, IBTSIZEOF
15351 EXTERNAL ALLPASS, LSAME, IBTMYPROC, IBTNPROCS, IBTSIZEOF
15352* ..
15353* .. External Subroutines ..
15354 EXTERNAL BLACS_GRIDINFO, SGAMX2D
15355 EXTERNAL SINITMAT, SCHKPAD, SBTCHECKIN
15356* ..
15357* .. Local Scalars ..
15358 CHARACTER*1 SCOPE, TOP
15359 LOGICAL INGRID, TESTOK, ALLRCV
15360 INTEGER APTR, CAPTR, CDEST, CDEST2, CONTEXT, ERRDPTR, ERRIPTR, I,
15361 $ iam, icheckval, ide, igr, ima, ipad, ipost, ipre, isc,
15362 $ isize, istart, istop, itc, itc1, itc2, ito, itr, itr1,
15363 $ itr2, j, k, lda, ldadst, ldasrc, ldi, m, maxerr, mycol,
15364 $ myrow, n, nerr, nfail, npcol, nprow, nskip, preaptr,
15365 $ raptr, rdest, rdest2, setwhat, ssize, testnum, valptr
15366 REAL CHECKVAL
15367* ..
15368* .. Executable Statements ..
15369*
15370* Choose padding value, and make it unique
15371*
15372 checkval = -0.61e0
15373 iam = ibtmyproc()
15374 checkval = iam * checkval
15375 isize = ibtsizeof('I')
15376 ssize = ibtsizeof('S')
15377 icheckval = -iam
15378*
15379* Verify file parameters
15380*
15381 IF( iam .EQ. 0 ) THEN
15382 WRITE(outnum, *) ' '
15383 WRITE(outnum, *) ' '
15384 WRITE(outnum, 1000 )
15385 IF( verb .GT. 0 ) THEN
15386 WRITE(outnum,*) ' '
15387 WRITE(outnum, 2000) 'NSCOPE:', nscope
15388 WRITE(outnum, 3000) ' SCOPE:', ( scope0(i), i = 1, nscope )
15389 WRITE(outnum, 2000) 'TReps :', topsrepeat
15390 WRITE(outnum, 2000) 'TCohr :', topscohrnt
15391 WRITE(outnum, 2000) 'NTOP :', ntop
15392 WRITE(outnum, 3000) ' TOP :', ( top0(i), i = 1, ntop )
15393 WRITE(outnum, 2000) 'NMAT :', nmat
15394 WRITE(outnum, 2000) ' M :', ( m0(i), i = 1, nmat )
15395 WRITE(outnum, 2000) ' N :', ( n0(i), i = 1, nmat )
15396 WRITE(outnum, 2000) ' LDAS :', ( ldas0(i), i = 1, nmat )
15397 WRITE(outnum, 2000) ' LDAD :', ( ldad0(i), i = 1, nmat )
15398 WRITE(outnum, 2000) ' LDI :', ( ldi0(i), i = 1, nmat )
15399 WRITE(outnum, 2000) 'NDEST :', ndest
15400 WRITE(outnum, 2000) ' RDEST:',( rdest0(i), i = 1, ndest )
15401 WRITE(outnum, 2000) ' CDEST:',( cdest0(i), i = 1, ndest )
15402 WRITE(outnum, 2000) 'NGRIDS:', ngrid
15403 WRITE(outnum, 2000) ' P :', ( p0(i), i = 1, ngrid )
15404 WRITE(outnum, 2000) ' Q :', ( q0(i), i = 1, ngrid )
15405 WRITE(outnum, 2000) 'VERB :', verb
15406 WRITE(outnum,*) ' '
15407 END IF
15408 IF( verb .GT. 1 ) THEN
15409 WRITE(outnum,4000)
15410 WRITE(outnum,5000)
15411 END IF
15412 END IF
15413 IF (topsrepeat.EQ.0) THEN
15414 itr1 = 0
15415 itr2 = 0
15416 ELSE IF (topsrepeat.EQ.1) THEN
15417 itr1 = 1
15418 itr2 = 1
15419 ELSE
15420 itr1 = 0
15421 itr2 = 1
15422 END IF
15423*
15424* Find biggest matrix, so we know where to stick error info
15425*
15426 i = 0
15427 DO 10 ima = 1, nmat
15428 ipad = 4 * m0(ima)
15429 k = n0(ima) * max0( ldas0(ima), ldad0(ima) ) + ipad
15430 IF( k .GT. i ) i = k
15431 10 CONTINUE
15432 i = i + ibtnprocs()
15433 maxerr = ( ssize * (memlen-i) ) / ( ssize*2 + isize*6 )
15434 IF( maxerr .LT. 1 ) THEN
15435 WRITE(outnum,*) 'ERROR: Not enough memory to run MAX tests.'
15436 CALL blacs_abort(-1, 1)
15437 END IF
15438 errdptr = i + 1
15439 erriptr = errdptr + maxerr
15440 nerr = 0
15441 testnum = 0
15442 nfail = 0
15443 nskip = 0
15444*
15445* Loop over grids of matrix
15446*
15447 DO 90 igr = 1, ngrid
15448*
15449* allocate process grid for the next batch of tests
15450*
15451 context = context0(igr)
15452 CALL blacs_gridinfo( context, nprow, npcol, myrow, mycol )
15453 ingrid = ( (myrow.LT.nprow) .AND. (mycol.LT.npcol) )
15454*
15455 DO 80 isc = 1, nscope
15456 scope = scope0(isc)
15457 DO 70 ito = 1, ntop
15458 top = top0(ito)
15459*
15460* If testing multiring ('M') or general tree ('T'), need to
15461* loop over calls to BLACS_SET to do full test
15462*
15463 IF( lsame(top, 'M') ) THEN
15464 setwhat = 13
15465 IF( scope .EQ. 'R' ) THEN
15466 istart = -(npcol - 1)
15467 istop = -istart
15468 ELSE IF (scope .EQ. 'C') THEN
15469 istart = -(nprow - 1)
15470 istop = -istart
15471 ELSE
15472 istart = -(nprow*npcol - 1)
15473 istop = -istart
15474 ENDIF
15475 ELSE IF( lsame(top, 'T') ) THEN
15476 setwhat = 14
15477 istart = 1
15478 IF( scope .EQ. 'R' ) THEN
15479 istop = npcol - 1
15480 ELSE IF (scope .EQ. 'C') THEN
15481 istop = nprow - 1
15482 ELSE
15483 istop = nprow*npcol - 1
15484 ENDIF
15485 ELSE
15486 setwhat = 0
15487 istart = 1
15488 istop = 1
15489 ENDIF
15490 DO 60 ima = 1, nmat
15491 m = m0(ima)
15492 n = n0(ima)
15493 ldasrc = ldas0(ima)
15494 ldadst = ldad0(ima)
15495 ldi = ldi0(ima)
15496 ipre = 2 * m
15497 ipost = ipre
15498 preaptr = 1
15499 aptr = preaptr + ipre
15500*
15501 DO 50 ide = 1, ndest
15502 testnum = testnum + 1
15503 rdest2 = rdest0(ide)
15504 cdest2 = cdest0(ide)
15505*
15506* If everyone gets the answer, create some bogus rdest/cdest
15507* so IF's are easier
15508*
15509 allrcv = ( (rdest2.EQ.-1) .OR. (cdest2.EQ.-1) )
15510 IF( allrcv ) THEN
15511 rdest = nprow - 1
15512 cdest = npcol - 1
15513 IF (topscohrnt.EQ.0) THEN
15514 itr1 = 0
15515 itr2 = 0
15516 ELSE IF (topscohrnt.EQ.1) THEN
15517 itr1 = 1
15518 itr2 = 1
15519 ELSE
15520 itr1 = 0
15521 itr2 = 1
15522 END IF
15523 ELSE
15524 rdest = rdest2
15525 cdest = cdest2
15526 itc1 = 0
15527 itc2 = 0
15528 END IF
15529 IF( rdest.GE.p0(igr) .OR. cdest.GE.q0(igr) ) THEN
15530 nskip = nskip + 1
15531 GOTO 50
15532 END IF
15533*
15534 IF( myrow.EQ.rdest .AND. mycol.EQ.cdest ) THEN
15535 lda = ldadst
15536 ELSE
15537 lda = ldasrc
15538 END IF
15539 valptr = aptr + ipost + n * lda
15540 IF( verb .GT. 1 ) THEN
15541 IF( iam .EQ. 0 ) THEN
15542 WRITE(outnum, 6000)
15543 $ testnum, 'RUNNING', scope, top, m, n,
15544 $ ldasrc, ldadst, ldi, rdest2, cdest2,
15545 $ nprow, npcol
15546 END IF
15547 END IF
15548*
15549* If I am in scope
15550*
15551 testok = .true.
15552 IF( ingrid ) THEN
15553 IF( (myrow.EQ.rdest .AND. scope.EQ.'R') .OR.
15554 $ (mycol.EQ.cdest .AND. scope.EQ.'C') .OR.
15555 $ (scope .EQ. 'A') ) THEN
15556*
15557 k = nerr
15558 DO 40 itr = itr1, itr2
15559 CALL blacs_set(context, 15, itr)
15560 DO 35 itc = itc1, itc2
15561 CALL blacs_set(context, 16, itc)
15562 DO 30 j = istart, istop
15563 IF( j.EQ.0) GOTO 30
15564 IF( setwhat.NE.0 )
15565 $ CALL blacs_set(context, setwhat, j)
15566*
15567*
15568* generate and pad matrix A
15569*
15570 CALL sinitmat('G','-', m, n, mem(preaptr),
15571 $ lda, ipre, ipost,
15572 $ checkval, testnum,
15573 $ myrow, mycol )
15574*
15575* If they exist, pad RA and CA arrays
15576*
15577 IF( ldi .NE. -1 ) THEN
15578 DO 15 i = 1, n*ldi + ipre + ipost
15579 rmem(i) = icheckval
15580 cmem(i) = icheckval
15581 15 CONTINUE
15582 raptr = 1 + ipre
15583 captr = 1 + ipre
15584 ELSE
15585 DO 20 i = 1, ipre+ipost
15586 rmem(i) = icheckval
15587 cmem(i) = icheckval
15588 20 CONTINUE
15589 raptr = 1
15590 captr = 1
15591 END IF
15592*
15593 CALL sgamx2d(context, scope, top, m, n,
15594 $ mem(aptr), lda, rmem(raptr),
15595 $ cmem(captr), ldi,
15596 $ rdest2, cdest2)
15597*
15598* If I've got the answer, check for errors in
15599* matrix or padding
15600*
15601 IF( (myrow.EQ.rdest .AND. mycol.EQ.cdest)
15602 $ .OR. allrcv ) THEN
15603 CALL schkpad('G','-', m, n,
15604 $ mem(preaptr), lda, rdest,
15605 $ cdest, myrow, mycol,
15606 $ ipre, ipost, checkval,
15607 $ testnum, maxerr, nerr,
15608 $ mem(erriptr),mem(errdptr))
15609 CALL schkamx(scope, context, m, n,
15610 $ mem(aptr), lda,
15611 $ rmem(raptr), cmem(captr),
15612 $ ldi, testnum, maxerr,nerr,
15613 $ mem(erriptr),mem(errdptr),
15614 $ iseed, mem(valptr))
15615 CALL srcchk(ipre, ipost, icheckval,
15616 $ m, n, rmem, cmem, ldi,
15617 $ myrow, mycol, testnum,
15618 $ maxerr, nerr,
15619 $ mem(erriptr), mem(errdptr))
15620 END IF
15621 30 CONTINUE
15622 CALL blacs_set(context, 16, 0)
15623 35 CONTINUE
15624 CALL blacs_set(context, 15, 0)
15625 40 CONTINUE
15626 testok = ( k .EQ. nerr )
15627 END IF
15628 END IF
15629*
15630 IF( verb .GT. 1 ) THEN
15631 i = nerr
15632 CALL sbtcheckin(0, outnum, maxerr, nerr,
15633 $ mem(erriptr), mem(errdptr), iseed)
15634 IF( iam .EQ. 0 ) THEN
15635 IF( testok .AND. nerr.EQ.i ) THEN
15636 WRITE(outnum,6000)testnum,'PASSED ',
15637 $ scope, top, m, n, ldasrc,
15638 $ ldadst, ldi, rdest2, cdest2,
15639 $ nprow, npcol
15640 ELSE
15641 nfail = nfail + 1
15642 WRITE(outnum,6000)testnum,'FAILED ',
15643 $ scope, top, m, n, ldasrc,
15644 $ ldadst, ldi, rdest2, cdest2,
15645 $ nprow, npcol
15646 END IF
15647 END IF
15648*
15649* Once we've printed out errors, can re-use buf space
15650*
15651 nerr = 0
15652 END IF
15653 50 CONTINUE
15654 60 CONTINUE
15655 70 CONTINUE
15656 80 CONTINUE
15657 90 CONTINUE
15658*
15659 IF( verb .LT. 2 ) THEN
15660 nfail = testnum
15661 CALL sbtcheckin( nfail, outnum, maxerr, nerr, mem(erriptr),
15662 $ mem(errdptr), iseed )
15663 END IF
15664 IF( iam .EQ. 0 ) THEN
15665 IF( verb .GT. 1 ) WRITE(outnum,*) ' '
15666 IF( nfail+nskip .EQ. 0 ) THEN
15667 WRITE(outnum, 7000 ) testnum
15668 ELSE
15669 WRITE(outnum, 8000 ) testnum, testnum-nskip-nfail,
15670 $ nskip, nfail
15671 END IF
15672 END IF
15673*
15674* Log whether their were any failures
15675*
15676 testok = allpass( (nfail.EQ.0) )
15677*
15678 1000 FORMAT('REAL AMX TESTS: BEGIN.' )
15679 2000 FORMAT(1x,a7,3x,10i6)
15680 3000 FORMAT(1x,a7,3x,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,
15681 $ 5x,a1,5x,a1)
15682 4000 FORMAT(' TEST# STATUS SCOPE TOP M N LDAS LDAD LDI ',
15683 $ 'RDEST CDEST P Q')
15684 5000 FORMAT(' ----- ------- ----- --- ----- ----- ----- ----- ----- ',
15685 $ '----- ----- ---- ----')
15686 6000 FORMAT(i6,1x,a7,5x,a1,3x,a1,7i6,2i5)
15687 7000 FORMAT('REAL AMX TESTS: PASSED ALL',
15688 $ i5, ' TESTS.')
15689 8000 FORMAT('REAL AMX TESTS:',i5,' TESTS;',i5,' PASSED,',
15690 $ i5,' SKIPPED,',i5,' FAILED.')
15691*
15692 RETURN
15693*
15694* End of STESTAMX.
15695*
15696 END
15697*
15698 SUBROUTINE srcchk( IPRE, IPOST, PADVAL, M, N, RA, CA, LDI, MYROW,
15699 $ MYCOL, TESTNUM, MAXERR, NERR,
15700 $ ERRIBUF, ERRDBUF )
15701*
15702* .. Scalar Arguments ..
15703 INTEGER IPRE, IPOST, PADVAL, M, N, LDI, MYROW, MYCOL, TESTNUM
15704 INTEGER MAXERR, NERR
15705* ..
15706* .. Array Arguments ..
15707 INTEGER RA(*), CA(*), ERRIBUF(6, MAXERR)
15708 REAL ERRDBUF(2, MAXERR)
15709* ..
15710* .. Parameters ..
15711 INTEGER ERR_PRE, ERR_POST, ERR_GAP, ERR_TRI, ERR_MAT
15712 parameter( err_pre = 1, err_post = 2, err_gap = 3, err_tri = 4 )
15713 parameter( err_mat = 5 )
15714* ..
15715* .. External Functions ..
15716 INTEGER IBTNPROCS
15717 EXTERNAL IBTNPROCS
15718* ..
15719* .. Local Scalars ..
15720 INTEGER I, J, K, IAM
15721* ..
15722* .. Executable Statements ..
15723*
15724 iam = myrow * ibtnprocs() + mycol
15725*
15726* Check pre padding
15727*
15728 IF( ldi .NE. -1 ) THEN
15729 IF( ipre .GT. 0 ) THEN
15730 DO 10 i = 1, ipre
15731 IF( ra(i) .NE. padval ) THEN
15732 nerr = nerr + 1
15733 IF( nerr .LE. maxerr ) THEN
15734 erribuf(1, nerr) = testnum
15735 erribuf(2, nerr) = ldi
15736 erribuf(3, nerr) = iam
15737 erribuf(4, nerr) = i
15738 erribuf(5, nerr) = ipre - i + 1
15739 erribuf(6, nerr) = -err_pre
15740 errdbuf(1, nerr) = real( ra(i) )
15741 errdbuf(2, nerr) = real( padval )
15742 END IF
15743 ENDIF
15744 IF( ca(i) .NE. padval ) THEN
15745 nerr = nerr + 1
15746 IF( nerr .LE. maxerr ) THEN
15747 erribuf(1, nerr) = testnum
15748 erribuf(2, nerr) = ldi
15749 erribuf(3, nerr) = iam
15750 erribuf(4, nerr) = i
15751 erribuf(5, nerr) = ipre - i + 1
15752 erribuf(6, nerr) = -10 - err_pre
15753 errdbuf(1, nerr) = real( ca(i) )
15754 errdbuf(2, nerr) = real( padval )
15755 END IF
15756 ENDIF
15757 10 CONTINUE
15758 END IF
15759*
15760* Check post padding
15761*
15762 IF( ipost .GT. 0 ) THEN
15763 k = ipre + ldi*n
15764 DO 20 i = k+1, k+ipost
15765 IF( ra(i) .NE. padval ) THEN
15766 nerr = nerr + 1
15767 IF( nerr .LE. maxerr ) THEN
15768 erribuf(1, nerr) = testnum
15769 erribuf(2, nerr) = ldi
15770 erribuf(3, nerr) = iam
15771 erribuf(4, nerr) = i - k
15772 erribuf(5, nerr) = i
15773 erribuf(6, nerr) = -err_post
15774 errdbuf(1, nerr) = real( ra(i) )
15775 errdbuf(2, nerr) = real( padval )
15776 END IF
15777 ENDIF
15778 IF( ca(i) .NE. padval ) THEN
15779 nerr = nerr + 1
15780 IF( nerr .LE. maxerr ) THEN
15781 erribuf(1, nerr) = testnum
15782 erribuf(2, nerr) = ldi
15783 erribuf(3, nerr) = iam
15784 erribuf(4, nerr) = i - k
15785 erribuf(5, nerr) = i
15786 erribuf(6, nerr) = -10 - err_post
15787 errdbuf(1, nerr) = real( ca(i) )
15788 errdbuf(2, nerr) = real( padval )
15789 END IF
15790 ENDIF
15791 20 CONTINUE
15792 END IF
15793*
15794* Check all (LDI-M) gaps
15795*
15796 IF( ldi .GT. m ) THEN
15797 k = ipre + m + 1
15798 DO 40 j = 1, n
15799 DO 30 i = m+1, ldi
15800 k = ipre + (j-1)*ldi + i
15801 IF( ra(k) .NE. padval) THEN
15802 nerr = nerr + 1
15803 IF( nerr .LE. maxerr ) THEN
15804 erribuf(1, nerr) = testnum
15805 erribuf(2, nerr) = ldi
15806 erribuf(3, nerr) = iam
15807 erribuf(4, nerr) = i
15808 erribuf(5, nerr) = j
15809 erribuf(6, nerr) = -err_gap
15810 errdbuf(1, nerr) = real( ra(k) )
15811 errdbuf(2, nerr) = real( padval )
15812 END IF
15813 END IF
15814 IF( ca(k) .NE. padval) THEN
15815 nerr = nerr + 1
15816 IF( nerr .LE. maxerr ) THEN
15817 erribuf(1, nerr) = testnum
15818 erribuf(2, nerr) = ldi
15819 erribuf(3, nerr) = iam
15820 erribuf(4, nerr) = i
15821 erribuf(5, nerr) = j
15822 erribuf(6, nerr) = -10 - err_gap
15823 errdbuf(1, nerr) = real( ca(k) )
15824 errdbuf(2, nerr) = real( padval )
15825 END IF
15826 END IF
15827 30 CONTINUE
15828 40 CONTINUE
15829 END IF
15830*
15831* if RA and CA don't exist, buffs better be untouched
15832*
15833 ELSE
15834 DO 50 i = 1, ipre+ipost
15835 IF( ra(i) .NE. padval) THEN
15836 nerr = nerr + 1
15837 IF( nerr .LE. maxerr ) THEN
15838 erribuf(1, nerr) = testnum
15839 erribuf(2, nerr) = ldi
15840 erribuf(3, nerr) = iam
15841 erribuf(4, nerr) = i
15842 erribuf(5, nerr) = ipre+ipost
15843 erribuf(6, nerr) = -err_pre
15844 errdbuf(1, nerr) = real( ra(i) )
15845 errdbuf(2, nerr) = real( padval )
15846 END IF
15847 END IF
15848 IF( ca(i) .NE. padval) THEN
15849 nerr = nerr + 1
15850 IF( nerr .LE. maxerr ) THEN
15851 erribuf(1, nerr) = testnum
15852 erribuf(2, nerr) = ldi
15853 erribuf(3, nerr) = iam
15854 erribuf(4, nerr) = i
15855 erribuf(5, nerr) = ipre+ipost
15856 erribuf(6, nerr) = -10 - err_pre
15857 errdbuf(1, nerr) = real( ca(i) )
15858 errdbuf(2, nerr) = real( padval )
15859 END IF
15860 END IF
15861 50 CONTINUE
15862 ENDIF
15863*
15864 RETURN
15865 END
15866*
15867 SUBROUTINE schkamx( SCOPE, ICTXT, M, N, A, LDA, RA, CA, LDI,
15868 $ TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF,
15869 $ ISEED, VALS )
15870*
15871* .. Scalar Arguments ..
15872 CHARACTER*1 SCOPE
15873 INTEGER ICTXT, M, N, LDA, LDI, TESTNUM, MAXERR, NERR
15874* ..
15875* .. Array Arguments ..
15876 INTEGER RA(*), CA(*), ERRIBUF(6, MAXERR), ISEED(*)
15877 REAL A(LDA,*), ERRDBUF(2, MAXERR), VALS(*)
15878* ..
15879* .. External Functions ..
15880 INTEGER IBTMYPROC, IBTNPROCS, IBTSPNUM
15881 REAL SBTEPS, SBTABS
15882 REAL SBTRAN
15883 EXTERNAL IBTMYPROC, IBTNPROCS, IBTSPNUM, SBTRAN, SBTEPS, SBTABS
15884* ..
15885* .. External Subroutines ..
15886 EXTERNAL ibtspcoord
15887* ..
15888* .. Local Scalars ..
15889 LOGICAL ERROR
15890 INTEGER NPROCS, NNODES, NPROW, NPCOL, MYROW, MYCOL, RAMX, CAMX
15891 INTEGER IAMX, I, J, K, H, DEST, NODE
15892 REAL EPS
15893* ..
15894* .. Executable Statements ..
15895*
15896 nprocs = ibtnprocs()
15897 eps = sbteps()
15898 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
15899 dest = myrow*nprocs + mycol
15900*
15901* Set up seeds to match those used by each proc's genmat call
15902*
15903 IF( scope .EQ. 'R' ) THEN
15904 nnodes = npcol
15905 DO 10 i = 0, nnodes-1
15906 node = myrow * nprocs + i
15907 iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
15908 iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
15909 iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
15910 iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
15911 10 CONTINUE
15912 ELSE IF( scope .EQ. 'C' ) THEN
15913 nnodes = nprow
15914 DO 20 i = 0, nnodes-1
15915 node = i * nprocs + mycol
15916 iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
15917 iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
15918 iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
15919 iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
15920 20 CONTINUE
15921 ELSE
15922 nnodes = nprow * npcol
15923 DO 30 i = 0, nnodes-1
15924 node = (i / npcol) * nprocs + mod(i, npcol)
15925 iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
15926 iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
15927 iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
15928 iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
15929 30 CONTINUE
15930 END IF
15931*
15932 DO 100 j = 1, n
15933 DO 90 i = 1, m
15934 h = (j-1)*ldi + i
15935 vals(1) = sbtran( iseed )
15936 iamx = 1
15937 IF( nnodes .GT. 1 ) THEN
15938 DO 40 k = 1, nnodes-1
15939 vals(k+1) = sbtran( iseed(k*4+1) )
15940 IF( sbtabs( vals(k+1) ) .GT. sbtabs( vals(iamx) ) )
15941 $ iamx = k + 1
15942 40 CONTINUE
15943 END IF
15944*
15945* If BLACS have not returned same value we've chosen
15946*
15947 IF( a(i,j) .NE. vals(iamx) ) THEN
15948*
15949* If we have RA and CA arrays
15950*
15951 IF( ldi .NE. -1 ) THEN
15952*
15953* Any number having the same absolute value is a valid max
15954*
15955 k = ibtspnum( scope, ra(h), ca(h), npcol ) + 1
15956 IF( k.GT.0 .AND. k.LE.nnodes ) THEN
15957 error = sbtabs( vals(k) ).NE.sbtabs( vals(iamx) )
15958 IF( .NOT.error ) iamx = k
15959 ELSE
15960 error = .true.
15961 END IF
15962 ELSE
15963*
15964* Error if BLACS answer not same absolute value, or if it
15965* was not really in the numbers being compared
15966*
15967 error = ( sbtabs( a(i,j) ) .NE. sbtabs( vals(iamx) ) )
15968 IF( .NOT.error ) THEN
15969 DO 50 k = 1, nnodes
15970 IF( vals(k) .EQ. a(i,j) ) GOTO 60
15971 50 CONTINUE
15972 error = .true.
15973 60 CONTINUE
15974 ENDIF
15975 END IF
15976*
15977* If the value is in error
15978*
15979 IF( error ) THEN
15980 nerr = nerr + 1
15981 erribuf(1, nerr) = testnum
15982 erribuf(2, nerr) = nnodes
15983 erribuf(3, nerr) = dest
15984 erribuf(4, nerr) = i
15985 erribuf(5, nerr) = j
15986 erribuf(6, nerr) = 5
15987 errdbuf(1, nerr) = a(i,j)
15988 errdbuf(2, nerr) = vals(iamx)
15989 END IF
15990 END IF
15991*
15992* If they are defined, make sure coordinate entries are OK
15993*
15994 IF( ldi .NE. -1 ) THEN
15995 k = ibtspnum( scope, ra(h), ca(h), npcol ) + 1
15996 IF( k.NE.iamx ) THEN
15997*
15998* Make sure more than one proc doesn't have exact same value
15999* (and therefore there may be more than one valid coordinate
16000* for a single value)
16001*
16002 IF( k.GT.nnodes .OR. k.LT.1 ) THEN
16003 error = .true.
16004 ELSE
16005 error = ( vals(k) .NE. vals(iamx) )
16006 END IF
16007 IF( error ) THEN
16008 CALL ibtspcoord( scope, iamx-1, myrow, mycol,
16009 $ npcol, ramx, camx )
16010 IF( ramx .NE. ra(h) ) THEN
16011 nerr = nerr + 1
16012 erribuf(1, nerr) = testnum
16013 erribuf(2, nerr) = nnodes
16014 erribuf(3, nerr) = dest
16015 erribuf(4, nerr) = i
16016 erribuf(5, nerr) = j
16017 erribuf(6, nerr) = -5
16018 errdbuf(1, nerr) = ra(h)
16019 errdbuf(2, nerr) = ramx
16020 END IF
16021 IF( camx .NE. ca(h) ) THEN
16022 nerr = nerr + 1
16023 erribuf(1, nerr) = testnum
16024 erribuf(2, nerr) = nnodes
16025 erribuf(3, nerr) = dest
16026 erribuf(4, nerr) = i
16027 erribuf(5, nerr) = j
16028 erribuf(6, nerr) = -15
16029 errdbuf(1, nerr) = ca(h)
16030 errdbuf(2, nerr) = camx
16031 END IF
16032 END IF
16033 END IF
16034 END IF
16035 90 CONTINUE
16036 100 CONTINUE
16037*
16038 RETURN
16039*
16040* End of SCHKAMX
16041*
16042 END
16043*
16044*
16045 SUBROUTINE damxtest( OUTNUM, VERB, TOPSREPEAT, TOPSCOHRNT, NSCOPE,
16046 $ SCOPE0, NTOP, TOP0, NMAT, M0, N0, LDAS0,
16047 $ LDAD0, LDI0, NDEST, RDEST0, CDEST0, NGRID,
16048 $ CONTEXT0, P0, Q0, ISEED, RMEM, CMEM, RCLEN,
16049 $ MEM, MEMLEN )
16050*
16051* -- BLACS tester (version 1.0) --
16052* University of Tennessee
16053* December 15, 1994
16054*
16055*
16056* .. Scalar Arguments ..
16057 INTEGER MEMLEN, NDEST, NGRID, NMAT, NSCOPE, NTOP, OUTNUM, RCLEN,
16058 $ TOPSCOHRNT, TOPSREPEAT, VERB
16059* ..
16060* .. Array Arguments ..
16061 CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP)
16062 INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT), LDI0(NMAT)
16063 INTEGER RDEST0(NDEST), CDEST0(NDEST), CONTEXT0(NGRID)
16064 INTEGER P0(NGRID), Q0(NGRID), ISEED(*), RMEM(RCLEN), CMEM(RCLEN)
16065 DOUBLE PRECISION MEM(MEMLEN)
16066* ..
16067*
16068* Purpose
16069* =======
16070* DTESTAMX: Test double precision AMX COMBINE
16071*
16072* Arguments
16073* =========
16074* OUTNUM (input) INTEGER
16075* The device number to write output to.
16076*
16077* VERB (input) INTEGER
16078* The level of verbosity (how much printing to do).
16079*
16080* NSCOPE (input) INTEGER
16081* The number of scopes to be tested.
16082*
16083* SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE)
16084* Values of the scopes to be tested.
16085*
16086* NTOP (input) INTEGER
16087* The number of topologies to be tested.
16088*
16089* TOP0 (input) CHARACTER*1 array of dimension (NTOP)
16090* Values of the topologies to be tested.
16091*
16092* NMAT (input) INTEGER
16093* The number of matrices to be tested.
16094*
16095* M0 (input) INTEGER array of dimension (NMAT)
16096* Values of M to be tested.
16097*
16098* M0 (input) INTEGER array of dimension (NMAT)
16099* Values of M to be tested.
16100*
16101* N0 (input) INTEGER array of dimension (NMAT)
16102* Values of N to be tested.
16103*
16104* LDAS0 (input) INTEGER array of dimension (NMAT)
16105* Values of LDAS (leading dimension of A on source process)
16106* to be tested.
16107*
16108* LDAD0 (input) INTEGER array of dimension (NMAT)
16109* Values of LDAD (leading dimension of A on destination
16110* process) to be tested.
16111* LDI0 (input) INTEGER array of dimension (NMAT)
16112* Values of LDI (leading dimension of RA/CA) to be tested.
16113* If LDI == -1, these RA/CA should not be accessed.
16114*
16115* NDEST (input) INTEGER
16116* The number of destinations to be tested.
16117*
16118* RDEST0 (input) INTEGER array of dimension (NNDEST)
16119* Values of RDEST (row coordinate of destination) to be
16120* tested.
16121*
16122* CDEST0 (input) INTEGER array of dimension (NNDEST)
16123* Values of CDEST (column coordinate of destination) to be
16124* tested.
16125*
16126* NGRID (input) INTEGER
16127* The number of process grids to be tested.
16128*
16129* CONTEXT0 (input) INTEGER array of dimension (NGRID)
16130* The BLACS context handles corresponding to the grids.
16131*
16132* P0 (input) INTEGER array of dimension (NGRID)
16133* Values of P (number of process rows, NPROW).
16134*
16135* Q0 (input) INTEGER array of dimension (NGRID)
16136* Values of Q (number of process columns, NPCOL).
16137*
16138* ISEED (workspace) INTEGER array of dimension ( MAX(NPROCS, NTESTS) )
16139* Workspace used to hold each process's random number SEED.
16140* This requires NPROCS (number of processor) elements.
16141* If VERB < 2, this workspace also serves to indicate which
16142* tests fail. This requires workspace of NTESTS
16143* (number of tests performed).
16144*
16145* RMEM (workspace) INTEGER array of dimension (RCLEN)
16146* Used for all RA arrays, and their pre and post padding.
16147*
16148* CMEM (workspace) INTEGER array of dimension (RCLEN)
16149* Used for all CA arrays, and their pre and post padding.
16150*
16151* RCLEN (input) INTEGER
16152* The length, in elements, of RMEM and CMEM.
16153*
16154* MEM (workspace) DOUBLE PRECISION array of dimension (MEMLEN)
16155* Used for all other workspaces, including the matrix A,
16156* and its pre and post padding.
16157*
16158* MEMLEN (input) INTEGER
16159* The length, in elements, of MEM.
16160*
16161* =====================================================================
16162*
16163* .. External Functions ..
16164 LOGICAL ALLPASS, LSAME
16165 INTEGER IBTMYPROC, IBTNPROCS, IBTSIZEOF
16166 EXTERNAL ALLPASS, LSAME, IBTMYPROC, IBTNPROCS, IBTSIZEOF
16167* ..
16168* .. External Subroutines ..
16169 EXTERNAL blacs_gridinfo, dgamx2d
16170 EXTERNAL dinitmat, dchkpad, dbtcheckin
16171* ..
16172* .. Local Scalars ..
16173 CHARACTER*1 SCOPE, TOP
16174 LOGICAL INGRID, TESTOK, ALLRCV
16175 INTEGER APTR, CAPTR, CDEST, CDEST2, CONTEXT, DSIZE, ERRDPTR,
16176 $ ERRIPTR, I, IAM, ICHECKVAL, IDE, IGR, IMA, IPAD, IPOST,
16177 $ IPRE, ISC, ISIZE, ISTART, ISTOP, ITC, ITC1, ITC2, ITO,
16178 $ ITR, ITR1, ITR2, J, K, LDA, LDADST, LDASRC, LDI, M,
16179 $ MAXERR, MYCOL, MYROW, N, NERR, NFAIL, NPCOL, NPROW, NSKIP,
16180 $ PREAPTR, RAPTR, RDEST, RDEST2, SETWHAT, TESTNUM, VALPTR
16181 DOUBLE PRECISION CHECKVAL
16182* ..
16183* .. Executable Statements ..
16184*
16185* Choose padding value, and make it unique
16186*
16187 checkval = -0.81d0
16188 iam = ibtmyproc()
16189 checkval = iam * checkval
16190 isize = ibtsizeof('I')
16191 dsize = ibtsizeof('D')
16192 icheckval = -iam
16193*
16194* Verify file parameters
16195*
16196 IF( iam .EQ. 0 ) THEN
16197 WRITE(outnum, *) ' '
16198 WRITE(outnum, *) ' '
16199 WRITE(outnum, 1000 )
16200 IF( verb .GT. 0 ) THEN
16201 WRITE(outnum,*) ' '
16202 WRITE(outnum, 2000) 'NSCOPE:', nscope
16203 WRITE(outnum, 3000) ' SCOPE:', ( scope0(i), i = 1, nscope )
16204 WRITE(outnum, 2000) 'TReps :', topsrepeat
16205 WRITE(outnum, 2000) 'TCohr :', topscohrnt
16206 WRITE(outnum, 2000) 'NTOP :', ntop
16207 WRITE(outnum, 3000) ' TOP :', ( top0(i), i = 1, ntop )
16208 WRITE(outnum, 2000) 'NMAT :', nmat
16209 WRITE(outnum, 2000) ' M :', ( m0(i), i = 1, nmat )
16210 WRITE(outnum, 2000) ' N :', ( n0(i), i = 1, nmat )
16211 WRITE(outnum, 2000) ' LDAS :', ( ldas0(i), i = 1, nmat )
16212 WRITE(outnum, 2000) ' LDAD :', ( ldad0(i), i = 1, nmat )
16213 WRITE(outnum, 2000) ' LDI :', ( ldi0(i), i = 1, nmat )
16214 WRITE(outnum, 2000) 'NDEST :', ndest
16215 WRITE(outnum, 2000) ' RDEST:',( rdest0(i), i = 1, ndest )
16216 WRITE(outnum, 2000) ' CDEST:',( cdest0(i), i = 1, ndest )
16217 WRITE(outnum, 2000) 'NGRIDS:', ngrid
16218 WRITE(outnum, 2000) ' P :', ( p0(i), i = 1, ngrid )
16219 WRITE(outnum, 2000) ' Q :', ( q0(i), i = 1, ngrid )
16220 WRITE(outnum, 2000) 'VERB :', verb
16221 WRITE(outnum,*) ' '
16222 END IF
16223 IF( verb .GT. 1 ) THEN
16224 WRITE(outnum,4000)
16225 WRITE(outnum,5000)
16226 END IF
16227 END IF
16228 IF (topsrepeat.EQ.0) THEN
16229 itr1 = 0
16230 itr2 = 0
16231 ELSE IF (topsrepeat.EQ.1) THEN
16232 itr1 = 1
16233 itr2 = 1
16234 ELSE
16235 itr1 = 0
16236 itr2 = 1
16237 END IF
16238*
16239* Find biggest matrix, so we know where to stick error info
16240*
16241 i = 0
16242 DO 10 ima = 1, nmat
16243 ipad = 4 * m0(ima)
16244 k = n0(ima) * max0( ldas0(ima), ldad0(ima) ) + ipad
16245 IF( k .GT. i ) i = k
16246 10 CONTINUE
16247 i = i + ibtnprocs()
16248 maxerr = ( dsize * (memlen-i) ) / ( dsize*2 + isize*6 )
16249 IF( maxerr .LT. 1 ) THEN
16250 WRITE(outnum,*) 'ERROR: Not enough memory to run MAX tests.'
16251 CALL blacs_abort(-1, 1)
16252 END IF
16253 errdptr = i + 1
16254 erriptr = errdptr + maxerr
16255 nerr = 0
16256 testnum = 0
16257 nfail = 0
16258 nskip = 0
16259*
16260* Loop over grids of matrix
16261*
16262 DO 90 igr = 1, ngrid
16263*
16264* allocate process grid for the next batch of tests
16265*
16266 context = context0(igr)
16267 CALL blacs_gridinfo( context, nprow, npcol, myrow, mycol )
16268 ingrid = ( (myrow.LT.nprow) .AND. (mycol.LT.npcol) )
16269*
16270 DO 80 isc = 1, nscope
16271 scope = scope0(isc)
16272 DO 70 ito = 1, ntop
16273 top = top0(ito)
16274*
16275* If testing multiring ('M') or general tree ('T'), need to
16276* loop over calls to BLACS_SET to do full test
16277*
16278 IF( lsame(top, 'M') ) THEN
16279 setwhat = 13
16280 IF( scope .EQ. 'R' ) THEN
16281 istart = -(npcol - 1)
16282 istop = -istart
16283 ELSE IF (scope .EQ. 'C') THEN
16284 istart = -(nprow - 1)
16285 istop = -istart
16286 ELSE
16287 istart = -(nprow*npcol - 1)
16288 istop = -istart
16289 ENDIF
16290 ELSE IF( lsame(top, 'T') ) THEN
16291 setwhat = 14
16292 istart = 1
16293 IF( scope .EQ. 'R' ) THEN
16294 istop = npcol - 1
16295 ELSE IF (scope .EQ. 'C') THEN
16296 istop = nprow - 1
16297 ELSE
16298 istop = nprow*npcol - 1
16299 ENDIF
16300 ELSE
16301 setwhat = 0
16302 istart = 1
16303 istop = 1
16304 ENDIF
16305 DO 60 ima = 1, nmat
16306 m = m0(ima)
16307 n = n0(ima)
16308 ldasrc = ldas0(ima)
16309 ldadst = ldad0(ima)
16310 ldi = ldi0(ima)
16311 ipre = 2 * m
16312 ipost = ipre
16313 preaptr = 1
16314 aptr = preaptr + ipre
16315*
16316 DO 50 ide = 1, ndest
16317 testnum = testnum + 1
16318 rdest2 = rdest0(ide)
16319 cdest2 = cdest0(ide)
16320*
16321* If everyone gets the answer, create some bogus rdest/cdest
16322* so IF's are easier
16323*
16324 allrcv = ( (rdest2.EQ.-1) .OR. (cdest2.EQ.-1) )
16325 IF( allrcv ) THEN
16326 rdest = nprow - 1
16327 cdest = npcol - 1
16328 IF (topscohrnt.EQ.0) THEN
16329 itr1 = 0
16330 itr2 = 0
16331 ELSE IF (topscohrnt.EQ.1) THEN
16332 itr1 = 1
16333 itr2 = 1
16334 ELSE
16335 itr1 = 0
16336 itr2 = 1
16337 END IF
16338 ELSE
16339 rdest = rdest2
16340 cdest = cdest2
16341 itc1 = 0
16342 itc2 = 0
16343 END IF
16344 IF( rdest.GE.p0(igr) .OR. cdest.GE.q0(igr) ) THEN
16345 nskip = nskip + 1
16346 GOTO 50
16347 END IF
16348*
16349 IF( myrow.EQ.rdest .AND. mycol.EQ.cdest ) THEN
16350 lda = ldadst
16351 ELSE
16352 lda = ldasrc
16353 END IF
16354 valptr = aptr + ipost + n * lda
16355 IF( verb .GT. 1 ) THEN
16356 IF( iam .EQ. 0 ) THEN
16357 WRITE(outnum, 6000)
16358 $ testnum, 'RUNNING', scope, top, m, n,
16359 $ ldasrc, ldadst, ldi, rdest2, cdest2,
16360 $ nprow, npcol
16361 END IF
16362 END IF
16363*
16364* If I am in scope
16365*
16366 testok = .true.
16367 IF( ingrid ) THEN
16368 IF( (myrow.EQ.rdest .AND. scope.EQ.'R') .OR.
16369 $ (mycol.EQ.cdest .AND. scope.EQ.'C') .OR.
16370 $ (scope .EQ. 'A') ) THEN
16371*
16372 k = nerr
16373 DO 40 itr = itr1, itr2
16374 CALL blacs_set(context, 15, itr)
16375 DO 35 itc = itc1, itc2
16376 CALL blacs_set(context, 16, itc)
16377 DO 30 j = istart, istop
16378 IF( j.EQ.0) GOTO 30
16379 IF( setwhat.NE.0 )
16380 $ CALL blacs_set(context, setwhat, j)
16381*
16382*
16383* generate and pad matrix A
16384*
16385 CALL dinitmat('G','-', m, n, mem(preaptr),
16386 $ lda, ipre, ipost,
16387 $ checkval, testnum,
16388 $ myrow, mycol )
16389*
16390* If they exist, pad RA and CA arrays
16391*
16392 IF( ldi .NE. -1 ) THEN
16393 DO 15 i = 1, n*ldi + ipre + ipost
16394 rmem(i) = icheckval
16395 cmem(i) = icheckval
16396 15 CONTINUE
16397 raptr = 1 + ipre
16398 captr = 1 + ipre
16399 ELSE
16400 DO 20 i = 1, ipre+ipost
16401 rmem(i) = icheckval
16402 cmem(i) = icheckval
16403 20 CONTINUE
16404 raptr = 1
16405 captr = 1
16406 END IF
16407*
16408 CALL dgamx2d(context, scope, top, m, n,
16409 $ mem(aptr), lda, rmem(raptr),
16410 $ cmem(captr), ldi,
16411 $ rdest2, cdest2)
16412*
16413* If I've got the answer, check for errors in
16414* matrix or padding
16415*
16416 IF( (myrow.EQ.rdest .AND. mycol.EQ.cdest)
16417 $ .OR. allrcv ) THEN
16418 CALL dchkpad('G','-', m, n,
16419 $ mem(preaptr), lda, rdest,
16420 $ cdest, myrow, mycol,
16421 $ ipre, ipost, checkval,
16422 $ testnum, maxerr, nerr,
16423 $ mem(erriptr),mem(errdptr))
16424 CALL dchkamx(scope, context, m, n,
16425 $ mem(aptr), lda,
16426 $ rmem(raptr), cmem(captr),
16427 $ ldi, testnum, maxerr,nerr,
16428 $ mem(erriptr),mem(errdptr),
16429 $ iseed, mem(valptr))
16430 CALL drcchk(ipre, ipost, icheckval,
16431 $ m, n, rmem, cmem, ldi,
16432 $ myrow, mycol, testnum,
16433 $ maxerr, nerr,
16434 $ mem(erriptr), mem(errdptr))
16435 END IF
16436 30 CONTINUE
16437 CALL blacs_set(context, 16, 0)
16438 35 CONTINUE
16439 CALL blacs_set(context, 15, 0)
16440 40 CONTINUE
16441 testok = ( k .EQ. nerr )
16442 END IF
16443 END IF
16444*
16445 IF( verb .GT. 1 ) THEN
16446 i = nerr
16447 CALL dbtcheckin(0, outnum, maxerr, nerr,
16448 $ mem(erriptr), mem(errdptr), iseed)
16449 IF( iam .EQ. 0 ) THEN
16450 IF( testok .AND. nerr.EQ.i ) THEN
16451 WRITE(outnum,6000)testnum,'PASSED ',
16452 $ scope, top, m, n, ldasrc,
16453 $ ldadst, ldi, rdest2, cdest2,
16454 $ nprow, npcol
16455 ELSE
16456 nfail = nfail + 1
16457 WRITE(outnum,6000)testnum,'FAILED ',
16458 $ scope, top, m, n, ldasrc,
16459 $ ldadst, ldi, rdest2, cdest2,
16460 $ nprow, npcol
16461 END IF
16462 END IF
16463*
16464* Once we've printed out errors, can re-use buf space
16465*
16466 nerr = 0
16467 END IF
16468 50 CONTINUE
16469 60 CONTINUE
16470 70 CONTINUE
16471 80 CONTINUE
16472 90 CONTINUE
16473*
16474 IF( verb .LT. 2 ) THEN
16475 nfail = testnum
16476 CALL dbtcheckin( nfail, outnum, maxerr, nerr, mem(erriptr),
16477 $ mem(errdptr), iseed )
16478 END IF
16479 IF( iam .EQ. 0 ) THEN
16480 IF( verb .GT. 1 ) WRITE(outnum,*) ' '
16481 IF( nfail+nskip .EQ. 0 ) THEN
16482 WRITE(outnum, 7000 ) testnum
16483 ELSE
16484 WRITE(outnum, 8000 ) testnum, testnum-nskip-nfail,
16485 $ nskip, nfail
16486 END IF
16487 END IF
16488*
16489* Log whether their were any failures
16490*
16491 testok = allpass( (nfail.EQ.0) )
16492*
16493 1000 FORMAT('DOUBLE PRECISION AMX TESTS: BEGIN.' )
16494 2000 FORMAT(1x,a7,3x,10i6)
16495 3000 FORMAT(1x,a7,3x,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,
16496 $ 5x,a1,5x,a1)
16497 4000 FORMAT(' TEST# STATUS SCOPE TOP M N LDAS LDAD LDI ',
16498 $ 'RDEST CDEST P Q')
16499 5000 FORMAT(' ----- ------- ----- --- ----- ----- ----- ----- ----- ',
16500 $ '----- ----- ---- ----')
16501 6000 FORMAT(i6,1x,a7,5x,a1,3x,a1,7i6,2i5)
16502 7000 FORMAT('DOUBLE PRECISION AMX TESTS: PASSED ALL',
16503 $ i5, ' TESTS.')
16504 8000 FORMAT('DOUBLE PRECISION AMX TESTS:',i5,' TESTS;',i5,' PASSED,',
16505 $ i5,' SKIPPED,',i5,' FAILED.')
16506*
16507 RETURN
16508*
16509* End of DTESTAMX.
16510*
16511 END
16512*
16513 SUBROUTINE drcchk( IPRE, IPOST, PADVAL, M, N, RA, CA, LDI, MYROW,
16514 $ MYCOL, TESTNUM, MAXERR, NERR,
16515 $ ERRIBUF, ERRDBUF )
16516*
16517* .. Scalar Arguments ..
16518 INTEGER IPRE, IPOST, PADVAL, M, N, LDI, MYROW, MYCOL, TESTNUM
16519 INTEGER MAXERR, NERR
16520* ..
16521* .. Array Arguments ..
16522 INTEGER RA(*), CA(*), ERRIBUF(6, MAXERR)
16523 DOUBLE PRECISION ERRDBUF(2, MAXERR)
16524* ..
16525* .. Parameters ..
16526 INTEGER ERR_PRE, ERR_POST, ERR_GAP, ERR_TRI, ERR_MAT
16527 parameter( err_pre = 1, err_post = 2, err_gap = 3, err_tri = 4 )
16528 parameter( err_mat = 5 )
16529* ..
16530* .. External Functions ..
16531 INTEGER IBTNPROCS
16532 EXTERNAL ibtnprocs
16533* ..
16534* .. Local Scalars ..
16535 INTEGER I, J, K, IAM
16536* ..
16537* .. Executable Statements ..
16538*
16539 iam = myrow * ibtnprocs() + mycol
16540*
16541* Check pre padding
16542*
16543 IF( ldi .NE. -1 ) THEN
16544 IF( ipre .GT. 0 ) THEN
16545 DO 10 i = 1, ipre
16546 IF( ra(i) .NE. padval ) THEN
16547 nerr = nerr + 1
16548 IF( nerr .LE. maxerr ) THEN
16549 erribuf(1, nerr) = testnum
16550 erribuf(2, nerr) = ldi
16551 erribuf(3, nerr) = iam
16552 erribuf(4, nerr) = i
16553 erribuf(5, nerr) = ipre - i + 1
16554 erribuf(6, nerr) = -err_pre
16555 errdbuf(1, nerr) = dble( ra(i) )
16556 errdbuf(2, nerr) = dble( padval )
16557 END IF
16558 ENDIF
16559 IF( ca(i) .NE. padval ) THEN
16560 nerr = nerr + 1
16561 IF( nerr .LE. maxerr ) THEN
16562 erribuf(1, nerr) = testnum
16563 erribuf(2, nerr) = ldi
16564 erribuf(3, nerr) = iam
16565 erribuf(4, nerr) = i
16566 erribuf(5, nerr) = ipre - i + 1
16567 erribuf(6, nerr) = -10 - err_pre
16568 errdbuf(1, nerr) = dble( ca(i) )
16569 errdbuf(2, nerr) = dble( padval )
16570 END IF
16571 ENDIF
16572 10 CONTINUE
16573 END IF
16574*
16575* Check post padding
16576*
16577 IF( ipost .GT. 0 ) THEN
16578 k = ipre + ldi*n
16579 DO 20 i = k+1, k+ipost
16580 IF( ra(i) .NE. padval ) THEN
16581 nerr = nerr + 1
16582 IF( nerr .LE. maxerr ) THEN
16583 erribuf(1, nerr) = testnum
16584 erribuf(2, nerr) = ldi
16585 erribuf(3, nerr) = iam
16586 erribuf(4, nerr) = i - k
16587 erribuf(5, nerr) = i
16588 erribuf(6, nerr) = -err_post
16589 errdbuf(1, nerr) = dble( ra(i) )
16590 errdbuf(2, nerr) = dble( padval )
16591 END IF
16592 ENDIF
16593 IF( ca(i) .NE. padval ) THEN
16594 nerr = nerr + 1
16595 IF( nerr .LE. maxerr ) THEN
16596 erribuf(1, nerr) = testnum
16597 erribuf(2, nerr) = ldi
16598 erribuf(3, nerr) = iam
16599 erribuf(4, nerr) = i - k
16600 erribuf(5, nerr) = i
16601 erribuf(6, nerr) = -10 - err_post
16602 errdbuf(1, nerr) = dble( ca(i) )
16603 errdbuf(2, nerr) = dble( padval )
16604 END IF
16605 ENDIF
16606 20 CONTINUE
16607 END IF
16608*
16609* Check all (LDI-M) gaps
16610*
16611 IF( ldi .GT. m ) THEN
16612 k = ipre + m + 1
16613 DO 40 j = 1, n
16614 DO 30 i = m+1, ldi
16615 k = ipre + (j-1)*ldi + i
16616 IF( ra(k) .NE. padval) THEN
16617 nerr = nerr + 1
16618 IF( nerr .LE. maxerr ) THEN
16619 erribuf(1, nerr) = testnum
16620 erribuf(2, nerr) = ldi
16621 erribuf(3, nerr) = iam
16622 erribuf(4, nerr) = i
16623 erribuf(5, nerr) = j
16624 erribuf(6, nerr) = -err_gap
16625 errdbuf(1, nerr) = dble( ra(k) )
16626 errdbuf(2, nerr) = dble( padval )
16627 END IF
16628 END IF
16629 IF( ca(k) .NE. padval) THEN
16630 nerr = nerr + 1
16631 IF( nerr .LE. maxerr ) THEN
16632 erribuf(1, nerr) = testnum
16633 erribuf(2, nerr) = ldi
16634 erribuf(3, nerr) = iam
16635 erribuf(4, nerr) = i
16636 erribuf(5, nerr) = j
16637 erribuf(6, nerr) = -10 - err_gap
16638 errdbuf(1, nerr) = dble( ca(k) )
16639 errdbuf(2, nerr) = dble( padval )
16640 END IF
16641 END IF
16642 30 CONTINUE
16643 40 CONTINUE
16644 END IF
16645*
16646* if RA and CA don't exist, buffs better be untouched
16647*
16648 ELSE
16649 DO 50 i = 1, ipre+ipost
16650 IF( ra(i) .NE. padval) THEN
16651 nerr = nerr + 1
16652 IF( nerr .LE. maxerr ) THEN
16653 erribuf(1, nerr) = testnum
16654 erribuf(2, nerr) = ldi
16655 erribuf(3, nerr) = iam
16656 erribuf(4, nerr) = i
16657 erribuf(5, nerr) = ipre+ipost
16658 erribuf(6, nerr) = -err_pre
16659 errdbuf(1, nerr) = dble( ra(i) )
16660 errdbuf(2, nerr) = dble( padval )
16661 END IF
16662 END IF
16663 IF( ca(i) .NE. padval) THEN
16664 nerr = nerr + 1
16665 IF( nerr .LE. maxerr ) THEN
16666 erribuf(1, nerr) = testnum
16667 erribuf(2, nerr) = ldi
16668 erribuf(3, nerr) = iam
16669 erribuf(4, nerr) = i
16670 erribuf(5, nerr) = ipre+ipost
16671 erribuf(6, nerr) = -10 - err_pre
16672 errdbuf(1, nerr) = dble( ca(i) )
16673 errdbuf(2, nerr) = dble( padval )
16674 END IF
16675 END IF
16676 50 CONTINUE
16677 ENDIF
16678*
16679 RETURN
16680 END
16681*
16682 SUBROUTINE dchkamx( SCOPE, ICTXT, M, N, A, LDA, RA, CA, LDI,
16683 $ TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF,
16684 $ ISEED, VALS )
16685*
16686* .. Scalar Arguments ..
16687 CHARACTER*1 SCOPE
16688 INTEGER ICTXT, M, N, LDA, LDI, TESTNUM, MAXERR, NERR
16689* ..
16690* .. Array Arguments ..
16691 INTEGER RA(*), CA(*), ERRIBUF(6, MAXERR), ISEED(*)
16692 DOUBLE PRECISION A(LDA,*), ERRDBUF(2, MAXERR), VALS(*)
16693* ..
16694* .. External Functions ..
16695 INTEGER IBTMYPROC, IBTNPROCS, IBTSPNUM
16696 DOUBLE PRECISION DBTEPS, DBTABS
16697 DOUBLE PRECISION DBTRAN
16698 EXTERNAL ibtmyproc, ibtnprocs, ibtspnum, dbtran, dbteps, dbtabs
16699* ..
16700* .. External Subroutines ..
16701 EXTERNAL ibtspcoord
16702* ..
16703* .. Local Scalars ..
16704 LOGICAL ERROR
16705 INTEGER NPROCS, NNODES, NPROW, NPCOL, MYROW, MYCOL, RAMX, CAMX
16706 INTEGER IAMX, I, J, K, H, DEST, NODE
16707 DOUBLE PRECISION EPS
16708* ..
16709* .. Executable Statements ..
16710*
16711 nprocs = ibtnprocs()
16712 eps = dbteps()
16713 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
16714 dest = myrow*nprocs + mycol
16715*
16716* Set up seeds to match those used by each proc's genmat call
16717*
16718 IF( scope .EQ. 'R' ) THEN
16719 nnodes = npcol
16720 DO 10 i = 0, nnodes-1
16721 node = myrow * nprocs + i
16722 iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
16723 iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
16724 iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
16725 iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
16726 10 CONTINUE
16727 ELSE IF( scope .EQ. 'C' ) THEN
16728 nnodes = nprow
16729 DO 20 i = 0, nnodes-1
16730 node = i * nprocs + mycol
16731 iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
16732 iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
16733 iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
16734 iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
16735 20 CONTINUE
16736 ELSE
16737 nnodes = nprow * npcol
16738 DO 30 i = 0, nnodes-1
16739 node = (i / npcol) * nprocs + mod(i, npcol)
16740 iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
16741 iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
16742 iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
16743 iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
16744 30 CONTINUE
16745 END IF
16746*
16747 DO 100 j = 1, n
16748 DO 90 i = 1, m
16749 h = (j-1)*ldi + i
16750 vals(1) = dbtran( iseed )
16751 iamx = 1
16752 IF( nnodes .GT. 1 ) THEN
16753 DO 40 k = 1, nnodes-1
16754 vals(k+1) = dbtran( iseed(k*4+1) )
16755 IF( dbtabs( vals(k+1) ) .GT. dbtabs( vals(iamx) ) )
16756 $ iamx = k + 1
16757 40 CONTINUE
16758 END IF
16759*
16760* If BLACS have not returned same value we've chosen
16761*
16762 IF( a(i,j) .NE. vals(iamx) ) THEN
16763*
16764* If we have RA and CA arrays
16765*
16766 IF( ldi .NE. -1 ) THEN
16767*
16768* Any number having the same absolute value is a valid max
16769*
16770 k = ibtspnum( scope, ra(h), ca(h), npcol ) + 1
16771 IF( k.GT.0 .AND. k.LE.nnodes ) THEN
16772 error = dbtabs( vals(k) ).NE.dbtabs( vals(iamx) )
16773 IF( .NOT.error ) iamx = k
16774 ELSE
16775 error = .true.
16776 END IF
16777 ELSE
16778*
16779* Error if BLACS answer not same absolute value, or if it
16780* was not really in the numbers being compared
16781*
16782 error = ( dbtabs( a(i,j) ) .NE. dbtabs( vals(iamx) ) )
16783 IF( .NOT.error ) THEN
16784 DO 50 k = 1, nnodes
16785 IF( vals(k) .EQ. a(i,j) ) GOTO 60
16786 50 CONTINUE
16787 error = .true.
16788 60 CONTINUE
16789 ENDIF
16790 END IF
16791*
16792* If the value is in error
16793*
16794 IF( error ) THEN
16795 nerr = nerr + 1
16796 erribuf(1, nerr) = testnum
16797 erribuf(2, nerr) = nnodes
16798 erribuf(3, nerr) = dest
16799 erribuf(4, nerr) = i
16800 erribuf(5, nerr) = j
16801 erribuf(6, nerr) = 5
16802 errdbuf(1, nerr) = a(i,j)
16803 errdbuf(2, nerr) = vals(iamx)
16804 END IF
16805 END IF
16806*
16807* If they are defined, make sure coordinate entries are OK
16808*
16809 IF( ldi .NE. -1 ) THEN
16810 k = ibtspnum( scope, ra(h), ca(h), npcol ) + 1
16811 IF( k.NE.iamx ) THEN
16812*
16813* Make sure more than one proc doesn't have exact same value
16814* (and therefore there may be more than one valid coordinate
16815* for a single value)
16816*
16817 IF( k.GT.nnodes .OR. k.LT.1 ) THEN
16818 error = .true.
16819 ELSE
16820 error = ( vals(k) .NE. vals(iamx) )
16821 END IF
16822 IF( error ) THEN
16823 CALL ibtspcoord( scope, iamx-1, myrow, mycol,
16824 $ npcol, ramx, camx )
16825 IF( ramx .NE. ra(h) ) THEN
16826 nerr = nerr + 1
16827 erribuf(1, nerr) = testnum
16828 erribuf(2, nerr) = nnodes
16829 erribuf(3, nerr) = dest
16830 erribuf(4, nerr) = i
16831 erribuf(5, nerr) = j
16832 erribuf(6, nerr) = -5
16833 errdbuf(1, nerr) = ra(h)
16834 errdbuf(2, nerr) = ramx
16835 END IF
16836 IF( camx .NE. ca(h) ) THEN
16837 nerr = nerr + 1
16838 erribuf(1, nerr) = testnum
16839 erribuf(2, nerr) = nnodes
16840 erribuf(3, nerr) = dest
16841 erribuf(4, nerr) = i
16842 erribuf(5, nerr) = j
16843 erribuf(6, nerr) = -15
16844 errdbuf(1, nerr) = ca(h)
16845 errdbuf(2, nerr) = camx
16846 END IF
16847 END IF
16848 END IF
16849 END IF
16850 90 CONTINUE
16851 100 CONTINUE
16852*
16853 RETURN
16854*
16855* End of DCHKAMX
16856*
16857 END
16858*
16859*
16860 SUBROUTINE camxtest( OUTNUM, VERB, TOPSREPEAT, TOPSCOHRNT, NSCOPE,
16861 $ SCOPE0, NTOP, TOP0, NMAT, M0, N0, LDAS0,
16862 $ LDAD0, LDI0, NDEST, RDEST0, CDEST0, NGRID,
16863 $ CONTEXT0, P0, Q0, ISEED, RMEM, CMEM, RCLEN,
16864 $ MEM, MEMLEN )
16865*
16866* -- BLACS tester (version 1.0) --
16867* University of Tennessee
16868* December 15, 1994
16869*
16870*
16871* .. Scalar Arguments ..
16872 INTEGER MEMLEN, NDEST, NGRID, NMAT, NSCOPE, NTOP, OUTNUM, RCLEN,
16873 $ topscohrnt, topsrepeat, verb
16874* ..
16875* .. Array Arguments ..
16876 CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP)
16877 INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT), LDI0(NMAT)
16878 INTEGER RDEST0(NDEST), CDEST0(NDEST), CONTEXT0(NGRID)
16879 INTEGER P0(NGRID), Q0(NGRID), ISEED(*), RMEM(RCLEN), CMEM(RCLEN)
16880 COMPLEX MEM(MEMLEN)
16881* ..
16882*
16883* Purpose
16884* =======
16885* CTESTAMX: Test complex AMX COMBINE
16886*
16887* Arguments
16888* =========
16889* OUTNUM (input) INTEGER
16890* The device number to write output to.
16891*
16892* VERB (input) INTEGER
16893* The level of verbosity (how much printing to do).
16894*
16895* NSCOPE (input) INTEGER
16896* The number of scopes to be tested.
16897*
16898* SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE)
16899* Values of the scopes to be tested.
16900*
16901* NTOP (input) INTEGER
16902* The number of topologies to be tested.
16903*
16904* TOP0 (input) CHARACTER*1 array of dimension (NTOP)
16905* Values of the topologies to be tested.
16906*
16907* NMAT (input) INTEGER
16908* The number of matrices to be tested.
16909*
16910* M0 (input) INTEGER array of dimension (NMAT)
16911* Values of M to be tested.
16912*
16913* M0 (input) INTEGER array of dimension (NMAT)
16914* Values of M to be tested.
16915*
16916* N0 (input) INTEGER array of dimension (NMAT)
16917* Values of N to be tested.
16918*
16919* LDAS0 (input) INTEGER array of dimension (NMAT)
16920* Values of LDAS (leading dimension of A on source process)
16921* to be tested.
16922*
16923* LDAD0 (input) INTEGER array of dimension (NMAT)
16924* Values of LDAD (leading dimension of A on destination
16925* process) to be tested.
16926* LDI0 (input) INTEGER array of dimension (NMAT)
16927* Values of LDI (leading dimension of RA/CA) to be tested.
16928* If LDI == -1, these RA/CA should not be accessed.
16929*
16930* NDEST (input) INTEGER
16931* The number of destinations to be tested.
16932*
16933* RDEST0 (input) INTEGER array of dimension (NNDEST)
16934* Values of RDEST (row coordinate of destination) to be
16935* tested.
16936*
16937* CDEST0 (input) INTEGER array of dimension (NNDEST)
16938* Values of CDEST (column coordinate of destination) to be
16939* tested.
16940*
16941* NGRID (input) INTEGER
16942* The number of process grids to be tested.
16943*
16944* CONTEXT0 (input) INTEGER array of dimension (NGRID)
16945* The BLACS context handles corresponding to the grids.
16946*
16947* P0 (input) INTEGER array of dimension (NGRID)
16948* Values of P (number of process rows, NPROW).
16949*
16950* Q0 (input) INTEGER array of dimension (NGRID)
16951* Values of Q (number of process columns, NPCOL).
16952*
16953* ISEED (workspace) INTEGER array of dimension ( MAX(NPROCS, NTESTS) )
16954* Workspace used to hold each process's random number SEED.
16955* This requires NPROCS (number of processor) elements.
16956* If VERB < 2, this workspace also serves to indicate which
16957* tests fail. This requires workspace of NTESTS
16958* (number of tests performed).
16959*
16960* RMEM (workspace) INTEGER array of dimension (RCLEN)
16961* Used for all RA arrays, and their pre and post padding.
16962*
16963* CMEM (workspace) INTEGER array of dimension (RCLEN)
16964* Used for all CA arrays, and their pre and post padding.
16965*
16966* RCLEN (input) INTEGER
16967* The length, in elements, of RMEM and CMEM.
16968*
16969* MEM (workspace) COMPLEX array of dimension (MEMLEN)
16970* Used for all other workspaces, including the matrix A,
16971* and its pre and post padding.
16972*
16973* MEMLEN (input) INTEGER
16974* The length, in elements, of MEM.
16975*
16976* =====================================================================
16977*
16978* .. External Functions ..
16979 LOGICAL ALLPASS, LSAME
16980 INTEGER IBTMYPROC, IBTNPROCS, IBTSIZEOF
16981 EXTERNAL allpass, lsame, ibtmyproc, ibtnprocs, ibtsizeof
16982* ..
16983* .. External Subroutines ..
16984 EXTERNAL blacs_gridinfo, cgamx2d
16985 EXTERNAL cinitmat, cchkpad, cbtcheckin
16986* ..
16987* .. Local Scalars ..
16988 CHARACTER*1 SCOPE, TOP
16989 LOGICAL INGRID, TESTOK, ALLRCV
16990 INTEGER APTR, CAPTR, CDEST, CDEST2, CONTEXT, CSIZE, ERRDPTR,
16991 $ ERRIPTR, I, IAM, ICHECKVAL, IDE, IGR, IMA, IPAD, IPOST,
16992 $ ipre, isc, isize, istart, istop, itc, itc1, itc2, ito,
16993 $ itr, itr1, itr2, j, k, lda, ldadst, ldasrc, ldi, m,
16994 $ maxerr, mycol, myrow, n, nerr, nfail, npcol, nprow, nskip,
16995 $ preaptr, raptr, rdest, rdest2, setwhat, testnum, valptr
16996 COMPLEX CHECKVAL
16997* ..
16998* .. Executable Statements ..
16999*
17000* Choose padding value, and make it unique
17001*
17002 CHECKVAL = cmplx( -0.91e0, -0.71e0 )
17003 iam = ibtmyproc()
17004 checkval = iam * checkval
17005 isize = ibtsizeof('I')
17006 csize = ibtsizeof('C')
17007 icheckval = -iam
17008*
17009* Verify file parameters
17010*
17011 IF( iam .EQ. 0 ) THEN
17012 WRITE(outnum, *) ' '
17013 WRITE(outnum, *) ' '
17014 WRITE(outnum, 1000 )
17015 IF( verb .GT. 0 ) THEN
17016 WRITE(outnum,*) ' '
17017 WRITE(outnum, 2000) 'NSCOPE:', nscope
17018 WRITE(outnum, 3000) ' SCOPE:', ( scope0(i), i = 1, nscope )
17019 WRITE(outnum, 2000) 'TReps :', topsrepeat
17020 WRITE(outnum, 2000) 'TCohr :', topscohrnt
17021 WRITE(outnum, 2000) 'NTOP :', ntop
17022 WRITE(outnum, 3000) ' TOP :', ( top0(i), i = 1, ntop )
17023 WRITE(outnum, 2000) 'NMAT :', nmat
17024 WRITE(outnum, 2000) ' M :', ( m0(i), i = 1, nmat )
17025 WRITE(outnum, 2000) ' N :', ( n0(i), i = 1, nmat )
17026 WRITE(outnum, 2000) ' LDAS :', ( ldas0(i), i = 1, nmat )
17027 WRITE(outnum, 2000) ' LDAD :', ( ldad0(i), i = 1, nmat )
17028 WRITE(outnum, 2000) ' LDI :', ( ldi0(i), i = 1, nmat )
17029 WRITE(outnum, 2000) 'NDEST :', ndest
17030 WRITE(outnum, 2000) ' RDEST:',( rdest0(i), i = 1, ndest )
17031 WRITE(outnum, 2000) ' CDEST:',( cdest0(i), i = 1, ndest )
17032 WRITE(outnum, 2000) 'NGRIDS:', ngrid
17033 WRITE(outnum, 2000) ' P :', ( p0(i), i = 1, ngrid )
17034 WRITE(outnum, 2000) ' Q :', ( q0(i), i = 1, ngrid )
17035 WRITE(outnum, 2000) 'VERB :', verb
17036 WRITE(outnum,*) ' '
17037 END IF
17038 IF( verb .GT. 1 ) THEN
17039 WRITE(outnum,4000)
17040 WRITE(outnum,5000)
17041 END IF
17042 END IF
17043 IF (topsrepeat.EQ.0) THEN
17044 itr1 = 0
17045 itr2 = 0
17046 ELSE IF (topsrepeat.EQ.1) THEN
17047 itr1 = 1
17048 itr2 = 1
17049 ELSE
17050 itr1 = 0
17051 itr2 = 1
17052 END IF
17053*
17054* Find biggest matrix, so we know where to stick error info
17055*
17056 i = 0
17057 DO 10 ima = 1, nmat
17058 ipad = 4 * m0(ima)
17059 k = n0(ima) * max0( ldas0(ima), ldad0(ima) ) + ipad
17060 IF( k .GT. i ) i = k
17061 10 CONTINUE
17062 i = i + ibtnprocs()
17063 maxerr = ( csize * (memlen-i) ) / ( csize*2 + isize*6 )
17064 IF( maxerr .LT. 1 ) THEN
17065 WRITE(outnum,*) 'ERROR: Not enough memory to run MAX tests.'
17066 CALL blacs_abort(-1, 1)
17067 END IF
17068 errdptr = i + 1
17069 erriptr = errdptr + maxerr
17070 nerr = 0
17071 testnum = 0
17072 nfail = 0
17073 nskip = 0
17074*
17075* Loop over grids of matrix
17076*
17077 DO 90 igr = 1, ngrid
17078*
17079* allocate process grid for the next batch of tests
17080*
17081 context = context0(igr)
17082 CALL blacs_gridinfo( context, nprow, npcol, myrow, mycol )
17083 ingrid = ( (myrow.LT.nprow) .AND. (mycol.LT.npcol) )
17084*
17085 DO 80 isc = 1, nscope
17086 scope = scope0(isc)
17087 DO 70 ito = 1, ntop
17088 top = top0(ito)
17089*
17090* If testing multiring ('M') or general tree ('T'), need to
17091* loop over calls to BLACS_SET to do full test
17092*
17093 IF( lsame(top, 'M') ) THEN
17094 setwhat = 13
17095 IF( scope .EQ. 'R' ) THEN
17096 istart = -(npcol - 1)
17097 istop = -istart
17098 ELSE IF (scope .EQ. 'C') THEN
17099 istart = -(nprow - 1)
17100 istop = -istart
17101 ELSE
17102 istart = -(nprow*npcol - 1)
17103 istop = -istart
17104 ENDIF
17105 ELSE IF( lsame(top, 'T') ) THEN
17106 setwhat = 14
17107 istart = 1
17108 IF( scope .EQ. 'R' ) THEN
17109 istop = npcol - 1
17110 ELSE IF (scope .EQ. 'C') THEN
17111 istop = nprow - 1
17112 ELSE
17113 istop = nprow*npcol - 1
17114 ENDIF
17115 ELSE
17116 setwhat = 0
17117 istart = 1
17118 istop = 1
17119 ENDIF
17120 DO 60 ima = 1, nmat
17121 m = m0(ima)
17122 n = n0(ima)
17123 ldasrc = ldas0(ima)
17124 ldadst = ldad0(ima)
17125 ldi = ldi0(ima)
17126 ipre = 2 * m
17127 ipost = ipre
17128 preaptr = 1
17129 aptr = preaptr + ipre
17130*
17131 DO 50 ide = 1, ndest
17132 testnum = testnum + 1
17133 rdest2 = rdest0(ide)
17134 cdest2 = cdest0(ide)
17135*
17136* If everyone gets the answer, create some bogus rdest/cdest
17137* so IF's are easier
17138*
17139 allrcv = ( (rdest2.EQ.-1) .OR. (cdest2.EQ.-1) )
17140 IF( allrcv ) THEN
17141 rdest = nprow - 1
17142 cdest = npcol - 1
17143 IF (topscohrnt.EQ.0) THEN
17144 itr1 = 0
17145 itr2 = 0
17146 ELSE IF (topscohrnt.EQ.1) THEN
17147 itr1 = 1
17148 itr2 = 1
17149 ELSE
17150 itr1 = 0
17151 itr2 = 1
17152 END IF
17153 ELSE
17154 rdest = rdest2
17155 cdest = cdest2
17156 itc1 = 0
17157 itc2 = 0
17158 END IF
17159 IF( rdest.GE.p0(igr) .OR. cdest.GE.q0(igr) ) THEN
17160 nskip = nskip + 1
17161 GOTO 50
17162 END IF
17163*
17164 IF( myrow.EQ.rdest .AND. mycol.EQ.cdest ) THEN
17165 lda = ldadst
17166 ELSE
17167 lda = ldasrc
17168 END IF
17169 valptr = aptr + ipost + n * lda
17170 IF( verb .GT. 1 ) THEN
17171 IF( iam .EQ. 0 ) THEN
17172 WRITE(outnum, 6000)
17173 $ testnum, 'RUNNING', scope, top, m, n,
17174 $ ldasrc, ldadst, ldi, rdest2, cdest2,
17175 $ nprow, npcol
17176 END IF
17177 END IF
17178*
17179* If I am in scope
17180*
17181 testok = .true.
17182 IF( ingrid ) THEN
17183 IF( (myrow.EQ.rdest .AND. scope.EQ.'R') .OR.
17184 $ (mycol.EQ.cdest .AND. scope.EQ.'C') .OR.
17185 $ (scope .EQ. 'A') ) THEN
17186*
17187 k = nerr
17188 DO 40 itr = itr1, itr2
17189 CALL blacs_set(context, 15, itr)
17190 DO 35 itc = itc1, itc2
17191 CALL blacs_set(context, 16, itc)
17192 DO 30 j = istart, istop
17193 IF( j.EQ.0) GOTO 30
17194 IF( setwhat.NE.0 )
17195 $ CALL blacs_set(context, setwhat, j)
17196*
17197*
17198* generate and pad matrix A
17199*
17200 CALL cinitmat('G','-', m, n, mem(preaptr),
17201 $ lda, ipre, ipost,
17202 $ checkval, testnum,
17203 $ myrow, mycol )
17204*
17205* If they exist, pad RA and CA arrays
17206*
17207 IF( ldi .NE. -1 ) THEN
17208 DO 15 i = 1, n*ldi + ipre + ipost
17209 rmem(i) = icheckval
17210 cmem(i) = icheckval
17211 15 CONTINUE
17212 raptr = 1 + ipre
17213 captr = 1 + ipre
17214 ELSE
17215 DO 20 i = 1, ipre+ipost
17216 rmem(i) = icheckval
17217 cmem(i) = icheckval
17218 20 CONTINUE
17219 raptr = 1
17220 captr = 1
17221 END IF
17222*
17223 CALL cgamx2d(context, scope, top, m, n,
17224 $ mem(aptr), lda, rmem(raptr),
17225 $ cmem(captr), ldi,
17226 $ rdest2, cdest2)
17227*
17228* If I've got the answer, check for errors in
17229* matrix or padding
17230*
17231 IF( (myrow.EQ.rdest .AND. mycol.EQ.cdest)
17232 $ .OR. allrcv ) THEN
17233 CALL cchkpad('G','-', m, n,
17234 $ mem(preaptr), lda, rdest,
17235 $ cdest, myrow, mycol,
17236 $ ipre, ipost, checkval,
17237 $ testnum, maxerr, nerr,
17238 $ mem(erriptr),mem(errdptr))
17239 CALL cchkamx(scope, context, m, n,
17240 $ mem(aptr), lda,
17241 $ rmem(raptr), cmem(captr),
17242 $ ldi, testnum, maxerr,nerr,
17243 $ mem(erriptr),mem(errdptr),
17244 $ iseed, mem(valptr))
17245 CALL crcchk(ipre, ipost, icheckval,
17246 $ m, n, rmem, cmem, ldi,
17247 $ myrow, mycol, testnum,
17248 $ maxerr, nerr,
17249 $ mem(erriptr), mem(errdptr))
17250 END IF
17251 30 CONTINUE
17252 CALL blacs_set(context, 16, 0)
17253 35 CONTINUE
17254 CALL blacs_set(context, 15, 0)
17255 40 CONTINUE
17256 testok = ( k .EQ. nerr )
17257 END IF
17258 END IF
17259*
17260 IF( verb .GT. 1 ) THEN
17261 i = nerr
17262 CALL cbtcheckin(0, outnum, maxerr, nerr,
17263 $ mem(erriptr), mem(errdptr), iseed)
17264 IF( iam .EQ. 0 ) THEN
17265 IF( testok .AND. nerr.EQ.i ) THEN
17266 WRITE(outnum,6000)testnum,'PASSED ',
17267 $ scope, top, m, n, ldasrc,
17268 $ ldadst, ldi, rdest2, cdest2,
17269 $ nprow, npcol
17270 ELSE
17271 nfail = nfail + 1
17272 WRITE(outnum,6000)testnum,'FAILED ',
17273 $ scope, top, m, n, ldasrc,
17274 $ ldadst, ldi, rdest2, cdest2,
17275 $ nprow, npcol
17276 END IF
17277 END IF
17278*
17279* Once we've printed out errors, can re-use buf space
17280*
17281 nerr = 0
17282 END IF
17283 50 CONTINUE
17284 60 CONTINUE
17285 70 CONTINUE
17286 80 CONTINUE
17287 90 CONTINUE
17288*
17289 IF( verb .LT. 2 ) THEN
17290 nfail = testnum
17291 CALL cbtcheckin( nfail, outnum, maxerr, nerr, mem(erriptr),
17292 $ mem(errdptr), iseed )
17293 END IF
17294 IF( iam .EQ. 0 ) THEN
17295 IF( verb .GT. 1 ) WRITE(outnum,*) ' '
17296 IF( nfail+nskip .EQ. 0 ) THEN
17297 WRITE(outnum, 7000 ) testnum
17298 ELSE
17299 WRITE(outnum, 8000 ) testnum, testnum-nskip-nfail,
17300 $ nskip, nfail
17301 END IF
17302 END IF
17303*
17304* Log whether their were any failures
17305*
17306 testok = allpass( (nfail.EQ.0) )
17307*
17308 1000 FORMAT('COMPLEX AMX TESTS: BEGIN.' )
17309 2000 FORMAT(1x,a7,3x,10i6)
17310 3000 FORMAT(1x,a7,3x,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,
17311 $ 5x,a1,5x,a1)
17312 4000 FORMAT(' TEST# STATUS SCOPE TOP M N LDAS LDAD LDI ',
17313 $ 'RDEST CDEST P Q')
17314 5000 FORMAT(' ----- ------- ----- --- ----- ----- ----- ----- ----- ',
17315 $ '----- ----- ---- ----')
17316 6000 FORMAT(i6,1x,a7,5x,a1,3x,a1,7i6,2i5)
17317 7000 FORMAT('COMPLEX AMX TESTS: PASSED ALL',
17318 $ i5, ' TESTS.')
17319 8000 FORMAT('COMPLEX AMX TESTS:',i5,' TESTS;',i5,' PASSED,',
17320 $ i5,' SKIPPED,',i5,' FAILED.')
17321*
17322 RETURN
17323*
17324* End of CTESTAMX.
17325*
17326 END
17327*
17328 SUBROUTINE crcchk( IPRE, IPOST, PADVAL, M, N, RA, CA, LDI, MYROW,
17329 $ MYCOL, TESTNUM, MAXERR, NERR,
17330 $ ERRIBUF, ERRDBUF )
17331*
17332* .. Scalar Arguments ..
17333 INTEGER IPRE, IPOST, PADVAL, M, N, LDI, MYROW, MYCOL, TESTNUM
17334 INTEGER MAXERR, NERR
17335* ..
17336* .. Array Arguments ..
17337 INTEGER RA(*), CA(*), ERRIBUF(6, MAXERR)
17338 COMPLEX ERRDBUF(2, MAXERR)
17339* ..
17340* .. Parameters ..
17341 INTEGER ERR_PRE, ERR_POST, ERR_GAP, ERR_TRI, ERR_MAT
17342 PARAMETER( ERR_PRE = 1, err_post = 2, err_gap = 3, err_tri = 4 )
17343 parameter( err_mat = 5 )
17344* ..
17345* .. External Functions ..
17346 INTEGER IBTNPROCS
17347 EXTERNAL ibtnprocs
17348* ..
17349* .. Local Scalars ..
17350 INTEGER I, J, K, IAM
17351* ..
17352* .. Executable Statements ..
17353*
17354 iam = myrow * ibtnprocs() + mycol
17355*
17356* Check pre padding
17357*
17358 IF( ldi .NE. -1 ) THEN
17359 IF( ipre .GT. 0 ) THEN
17360 DO 10 i = 1, ipre
17361 IF( ra(i) .NE. padval ) THEN
17362 nerr = nerr + 1
17363 IF( nerr .LE. maxerr ) THEN
17364 erribuf(1, nerr) = testnum
17365 erribuf(2, nerr) = ldi
17366 erribuf(3, nerr) = iam
17367 erribuf(4, nerr) = i
17368 erribuf(5, nerr) = ipre - i + 1
17369 erribuf(6, nerr) = -err_pre
17370 errdbuf(1, nerr) = cmplx( ra(i) )
17371 errdbuf(2, nerr) = cmplx( padval )
17372 END IF
17373 ENDIF
17374 IF( ca(i) .NE. padval ) THEN
17375 nerr = nerr + 1
17376 IF( nerr .LE. maxerr ) THEN
17377 erribuf(1, nerr) = testnum
17378 erribuf(2, nerr) = ldi
17379 erribuf(3, nerr) = iam
17380 erribuf(4, nerr) = i
17381 erribuf(5, nerr) = ipre - i + 1
17382 erribuf(6, nerr) = -10 - err_pre
17383 errdbuf(1, nerr) = cmplx( ca(i) )
17384 errdbuf(2, nerr) = cmplx( padval )
17385 END IF
17386 ENDIF
17387 10 CONTINUE
17388 END IF
17389*
17390* Check post padding
17391*
17392 IF( ipost .GT. 0 ) THEN
17393 k = ipre + ldi*n
17394 DO 20 i = k+1, k+ipost
17395 IF( ra(i) .NE. padval ) THEN
17396 nerr = nerr + 1
17397 IF( nerr .LE. maxerr ) THEN
17398 erribuf(1, nerr) = testnum
17399 erribuf(2, nerr) = ldi
17400 erribuf(3, nerr) = iam
17401 erribuf(4, nerr) = i - k
17402 erribuf(5, nerr) = i
17403 erribuf(6, nerr) = -err_post
17404 errdbuf(1, nerr) = cmplx( ra(i) )
17405 errdbuf(2, nerr) = cmplx( padval )
17406 END IF
17407 ENDIF
17408 IF( ca(i) .NE. padval ) THEN
17409 nerr = nerr + 1
17410 IF( nerr .LE. maxerr ) THEN
17411 erribuf(1, nerr) = testnum
17412 erribuf(2, nerr) = ldi
17413 erribuf(3, nerr) = iam
17414 erribuf(4, nerr) = i - k
17415 erribuf(5, nerr) = i
17416 erribuf(6, nerr) = -10 - err_post
17417 errdbuf(1, nerr) = cmplx( ca(i) )
17418 errdbuf(2, nerr) = cmplx( padval )
17419 END IF
17420 ENDIF
17421 20 CONTINUE
17422 END IF
17423*
17424* Check all (LDI-M) gaps
17425*
17426 IF( ldi .GT. m ) THEN
17427 k = ipre + m + 1
17428 DO 40 j = 1, n
17429 DO 30 i = m+1, ldi
17430 k = ipre + (j-1)*ldi + i
17431 IF( ra(k) .NE. padval) THEN
17432 nerr = nerr + 1
17433 IF( nerr .LE. maxerr ) THEN
17434 erribuf(1, nerr) = testnum
17435 erribuf(2, nerr) = ldi
17436 erribuf(3, nerr) = iam
17437 erribuf(4, nerr) = i
17438 erribuf(5, nerr) = j
17439 erribuf(6, nerr) = -err_gap
17440 errdbuf(1, nerr) = cmplx( ra(k) )
17441 errdbuf(2, nerr) = cmplx( padval )
17442 END IF
17443 END IF
17444 IF( ca(k) .NE. padval) THEN
17445 nerr = nerr + 1
17446 IF( nerr .LE. maxerr ) THEN
17447 erribuf(1, nerr) = testnum
17448 erribuf(2, nerr) = ldi
17449 erribuf(3, nerr) = iam
17450 erribuf(4, nerr) = i
17451 erribuf(5, nerr) = j
17452 erribuf(6, nerr) = -10 - err_gap
17453 errdbuf(1, nerr) = cmplx( ca(k) )
17454 errdbuf(2, nerr) = cmplx( padval )
17455 END IF
17456 END IF
17457 30 CONTINUE
17458 40 CONTINUE
17459 END IF
17460*
17461* if RA and CA don't exist, buffs better be untouched
17462*
17463 ELSE
17464 DO 50 i = 1, ipre+ipost
17465 IF( ra(i) .NE. padval) THEN
17466 nerr = nerr + 1
17467 IF( nerr .LE. maxerr ) THEN
17468 erribuf(1, nerr) = testnum
17469 erribuf(2, nerr) = ldi
17470 erribuf(3, nerr) = iam
17471 erribuf(4, nerr) = i
17472 erribuf(5, nerr) = ipre+ipost
17473 erribuf(6, nerr) = -err_pre
17474 errdbuf(1, nerr) = cmplx( ra(i) )
17475 errdbuf(2, nerr) = cmplx( padval )
17476 END IF
17477 END IF
17478 IF( ca(i) .NE. padval) THEN
17479 nerr = nerr + 1
17480 IF( nerr .LE. maxerr ) THEN
17481 erribuf(1, nerr) = testnum
17482 erribuf(2, nerr) = ldi
17483 erribuf(3, nerr) = iam
17484 erribuf(4, nerr) = i
17485 erribuf(5, nerr) = ipre+ipost
17486 erribuf(6, nerr) = -10 - err_pre
17487 errdbuf(1, nerr) = cmplx( ca(i) )
17488 errdbuf(2, nerr) = cmplx( padval )
17489 END IF
17490 END IF
17491 50 CONTINUE
17492 ENDIF
17493*
17494 RETURN
17495 END
17496*
17497 SUBROUTINE cchkamx( SCOPE, ICTXT, M, N, A, LDA, RA, CA, LDI,
17498 $ TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF,
17499 $ ISEED, VALS )
17500*
17501* .. Scalar Arguments ..
17502 CHARACTER*1 SCOPE
17503 INTEGER ICTXT, M, N, LDA, LDI, TESTNUM, MAXERR, NERR
17504* ..
17505* .. Array Arguments ..
17506 INTEGER RA(*), CA(*), ERRIBUF(6, MAXERR), ISEED(*)
17507 COMPLEX A(LDA,*), ERRDBUF(2, MAXERR), VALS(*)
17508* ..
17509* .. External Functions ..
17510 INTEGER IBTMYPROC, IBTNPROCS, IBTSPNUM
17511 REAL SBTEPS, CBTABS
17512 COMPLEX CBTRAN
17513 EXTERNAL ibtmyproc, ibtnprocs, ibtspnum, cbtran, sbteps, cbtabs
17514* ..
17515* .. External Subroutines ..
17516 EXTERNAL ibtspcoord
17517* ..
17518* .. Local Scalars ..
17519 LOGICAL ERROR
17520 INTEGER NPROCS, NNODES, NPROW, NPCOL, MYROW, MYCOL, RAMX, CAMX
17521 INTEGER IAMX, I, J, K, H, DEST, NODE
17522 REAL EPS
17523* ..
17524* .. Executable Statements ..
17525*
17526 nprocs = ibtnprocs()
17527 eps = sbteps()
17528 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
17529 dest = myrow*nprocs + mycol
17530*
17531* Set up seeds to match those used by each proc's genmat call
17532*
17533 IF( scope .EQ. 'R' ) THEN
17534 nnodes = npcol
17535 DO 10 i = 0, nnodes-1
17536 node = myrow * nprocs + i
17537 iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
17538 iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
17539 iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
17540 iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
17541 10 CONTINUE
17542 ELSE IF( scope .EQ. 'C' ) THEN
17543 nnodes = nprow
17544 DO 20 i = 0, nnodes-1
17545 node = i * nprocs + mycol
17546 iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
17547 iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
17548 iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
17549 iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
17550 20 CONTINUE
17551 ELSE
17552 nnodes = nprow * npcol
17553 DO 30 i = 0, nnodes-1
17554 node = (i / npcol) * nprocs + mod(i, npcol)
17555 iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
17556 iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
17557 iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
17558 iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
17559 30 CONTINUE
17560 END IF
17561*
17562 DO 100 j = 1, n
17563 DO 90 i = 1, m
17564 h = (j-1)*ldi + i
17565 vals(1) = cbtran( iseed )
17566 iamx = 1
17567 IF( nnodes .GT. 1 ) THEN
17568 DO 40 k = 1, nnodes-1
17569 vals(k+1) = cbtran( iseed(k*4+1) )
17570 IF( cbtabs( vals(k+1) ) .GT. cbtabs( vals(iamx) ) )
17571 $ iamx = k + 1
17572 40 CONTINUE
17573 END IF
17574*
17575* If BLACS have not returned same value we've chosen
17576*
17577 IF( a(i,j) .NE. vals(iamx) ) THEN
17578*
17579* If we have RA and CA arrays
17580*
17581 IF( ldi .NE. -1 ) THEN
17582*
17583* Any number having the same absolute value is a valid max
17584*
17585 k = ibtspnum( scope, ra(h), ca(h), npcol ) + 1
17586 IF( k.GT.0 .AND. k.LE.nnodes ) THEN
17587 error = abs( cbtabs(vals(k)) - cbtabs(vals(iamx)) )
17588 $ .GT. 3*eps
17589 IF( .NOT.error ) iamx = k
17590 ELSE
17591 error = .true.
17592 END IF
17593 ELSE
17594*
17595* Error if BLACS answer not same absolute value, or if it
17596* was not really in the numbers being compared
17597*
17598 error = abs( cbtabs(a(i,j)) - cbtabs(vals(iamx)) )
17599 $ .GT. 3*eps
17600 IF( .NOT.error ) THEN
17601 DO 50 k = 1, nnodes
17602 IF( vals(k) .EQ. a(i,j) ) GOTO 60
17603 50 CONTINUE
17604 error = .true.
17605 60 CONTINUE
17606 ENDIF
17607 END IF
17608*
17609* If the value is in error
17610*
17611 IF( error ) THEN
17612 nerr = nerr + 1
17613 erribuf(1, nerr) = testnum
17614 erribuf(2, nerr) = nnodes
17615 erribuf(3, nerr) = dest
17616 erribuf(4, nerr) = i
17617 erribuf(5, nerr) = j
17618 erribuf(6, nerr) = 5
17619 errdbuf(1, nerr) = a(i,j)
17620 errdbuf(2, nerr) = vals(iamx)
17621 END IF
17622 END IF
17623*
17624* If they are defined, make sure coordinate entries are OK
17625*
17626 IF( ldi .NE. -1 ) THEN
17627 k = ibtspnum( scope, ra(h), ca(h), npcol ) + 1
17628 IF( k.NE.iamx ) THEN
17629*
17630* Make sure more than one proc doesn't have exact same value
17631* (and therefore there may be more than one valid coordinate
17632* for a single value)
17633*
17634 IF( k.GT.nnodes .OR. k.LT.1 ) THEN
17635 error = .true.
17636 ELSE
17637 error = ( vals(k) .NE. vals(iamx) )
17638 END IF
17639 IF( error ) THEN
17640 CALL ibtspcoord( scope, iamx-1, myrow, mycol,
17641 $ npcol, ramx, camx )
17642 IF( ramx .NE. ra(h) ) THEN
17643 nerr = nerr + 1
17644 erribuf(1, nerr) = testnum
17645 erribuf(2, nerr) = nnodes
17646 erribuf(3, nerr) = dest
17647 erribuf(4, nerr) = i
17648 erribuf(5, nerr) = j
17649 erribuf(6, nerr) = -5
17650 errdbuf(1, nerr) = ra(h)
17651 errdbuf(2, nerr) = ramx
17652 END IF
17653 IF( camx .NE. ca(h) ) THEN
17654 nerr = nerr + 1
17655 erribuf(1, nerr) = testnum
17656 erribuf(2, nerr) = nnodes
17657 erribuf(3, nerr) = dest
17658 erribuf(4, nerr) = i
17659 erribuf(5, nerr) = j
17660 erribuf(6, nerr) = -15
17661 errdbuf(1, nerr) = ca(h)
17662 errdbuf(2, nerr) = camx
17663 END IF
17664 END IF
17665 END IF
17666 END IF
17667 90 CONTINUE
17668 100 CONTINUE
17669*
17670 RETURN
17671*
17672* End of CCHKAMX
17673*
17674 END
17675*
17676*
17677 SUBROUTINE zamxtest( OUTNUM, VERB, TOPSREPEAT, TOPSCOHRNT, NSCOPE,
17678 $ SCOPE0, NTOP, TOP0, NMAT, M0, N0, LDAS0,
17679 $ LDAD0, LDI0, NDEST, RDEST0, CDEST0, NGRID,
17680 $ CONTEXT0, P0, Q0, ISEED, RMEM, CMEM, RCLEN,
17681 $ MEM, MEMLEN )
17682*
17683* -- BLACS tester (version 1.0) --
17684* University of Tennessee
17685* December 15, 1994
17686*
17687*
17688* .. Scalar Arguments ..
17689 INTEGER MEMLEN, NDEST, NGRID, NMAT, NSCOPE, NTOP, OUTNUM, RCLEN,
17690 $ topscohrnt, topsrepeat, verb
17691* ..
17692* .. Array Arguments ..
17693 CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP)
17694 INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT), LDI0(NMAT)
17695 INTEGER RDEST0(NDEST), CDEST0(NDEST), CONTEXT0(NGRID)
17696 INTEGER P0(NGRID), Q0(NGRID), ISEED(*), RMEM(RCLEN), CMEM(RCLEN)
17697 DOUBLE COMPLEX MEM(MEMLEN)
17698* ..
17699*
17700* Purpose
17701* =======
17702* ZTESTAMX: Test double complex AMX COMBINE
17703*
17704* Arguments
17705* =========
17706* OUTNUM (input) INTEGER
17707* The device number to write output to.
17708*
17709* VERB (input) INTEGER
17710* The level of verbosity (how much printing to do).
17711*
17712* NSCOPE (input) INTEGER
17713* The number of scopes to be tested.
17714*
17715* SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE)
17716* Values of the scopes to be tested.
17717*
17718* NTOP (input) INTEGER
17719* The number of topologies to be tested.
17720*
17721* TOP0 (input) CHARACTER*1 array of dimension (NTOP)
17722* Values of the topologies to be tested.
17723*
17724* NMAT (input) INTEGER
17725* The number of matrices to be tested.
17726*
17727* M0 (input) INTEGER array of dimension (NMAT)
17728* Values of M to be tested.
17729*
17730* M0 (input) INTEGER array of dimension (NMAT)
17731* Values of M to be tested.
17732*
17733* N0 (input) INTEGER array of dimension (NMAT)
17734* Values of N to be tested.
17735*
17736* LDAS0 (input) INTEGER array of dimension (NMAT)
17737* Values of LDAS (leading dimension of A on source process)
17738* to be tested.
17739*
17740* LDAD0 (input) INTEGER array of dimension (NMAT)
17741* Values of LDAD (leading dimension of A on destination
17742* process) to be tested.
17743* LDI0 (input) INTEGER array of dimension (NMAT)
17744* Values of LDI (leading dimension of RA/CA) to be tested.
17745* If LDI == -1, these RA/CA should not be accessed.
17746*
17747* NDEST (input) INTEGER
17748* The number of destinations to be tested.
17749*
17750* RDEST0 (input) INTEGER array of dimension (NNDEST)
17751* Values of RDEST (row coordinate of destination) to be
17752* tested.
17753*
17754* CDEST0 (input) INTEGER array of dimension (NNDEST)
17755* Values of CDEST (column coordinate of destination) to be
17756* tested.
17757*
17758* NGRID (input) INTEGER
17759* The number of process grids to be tested.
17760*
17761* CONTEXT0 (input) INTEGER array of dimension (NGRID)
17762* The BLACS context handles corresponding to the grids.
17763*
17764* P0 (input) INTEGER array of dimension (NGRID)
17765* Values of P (number of process rows, NPROW).
17766*
17767* Q0 (input) INTEGER array of dimension (NGRID)
17768* Values of Q (number of process columns, NPCOL).
17769*
17770* ISEED (workspace) INTEGER array of dimension ( MAX(NPROCS, NTESTS) )
17771* Workspace used to hold each process's random number SEED.
17772* This requires NPROCS (number of processor) elements.
17773* If VERB < 2, this workspace also serves to indicate which
17774* tests fail. This requires workspace of NTESTS
17775* (number of tests performed).
17776*
17777* RMEM (workspace) INTEGER array of dimension (RCLEN)
17778* Used for all RA arrays, and their pre and post padding.
17779*
17780* CMEM (workspace) INTEGER array of dimension (RCLEN)
17781* Used for all CA arrays, and their pre and post padding.
17782*
17783* RCLEN (input) INTEGER
17784* The length, in elements, of RMEM and CMEM.
17785*
17786* MEM (workspace) DOUBLE COMPLEX array of dimension (MEMLEN)
17787* Used for all other workspaces, including the matrix A,
17788* and its pre and post padding.
17789*
17790* MEMLEN (input) INTEGER
17791* The length, in elements, of MEM.
17792*
17793* =====================================================================
17794*
17795* .. External Functions ..
17796 LOGICAL ALLPASS, LSAME
17797 INTEGER IBTMYPROC, IBTNPROCS, IBTSIZEOF
17798 EXTERNAL allpass, lsame, ibtmyproc, ibtnprocs, ibtsizeof
17799* ..
17800* .. External Subroutines ..
17801 EXTERNAL blacs_gridinfo, zgamx2d
17802 EXTERNAL zinitmat, zchkpad, zbtcheckin
17803* ..
17804* .. Local Scalars ..
17805 CHARACTER*1 SCOPE, TOP
17806 LOGICAL INGRID, TESTOK, ALLRCV
17807 INTEGER APTR, CAPTR, CDEST, CDEST2, CONTEXT, ERRDPTR, ERRIPTR, I,
17808 $ iam, icheckval, ide, igr, ima, ipad, ipost, ipre, isc,
17809 $ isize, istart, istop, itc, itc1, itc2, ito, itr, itr1,
17810 $ itr2, j, k, lda, ldadst, ldasrc, ldi, m, maxerr, mycol,
17811 $ myrow, n, nerr, nfail, npcol, nprow, nskip, preaptr,
17812 $ raptr, rdest, rdest2, setwhat, testnum, valptr, zsize
17813 DOUBLE COMPLEX CHECKVAL
17814* ..
17815* .. Executable Statements ..
17816*
17817* Choose padding value, and make it unique
17818*
17819 checkval = dcmplx( -9.11d0, -9.21d0 )
17820 iam = ibtmyproc()
17821 checkval = iam * checkval
17822 isize = ibtsizeof('I')
17823 zsize = ibtsizeof('Z')
17824 icheckval = -iam
17825*
17826* Verify file parameters
17827*
17828 IF( iam .EQ. 0 ) THEN
17829 WRITE(outnum, *) ' '
17830 WRITE(outnum, *) ' '
17831 WRITE(outnum, 1000 )
17832 IF( verb .GT. 0 ) THEN
17833 WRITE(outnum,*) ' '
17834 WRITE(outnum, 2000) 'NSCOPE:', nscope
17835 WRITE(outnum, 3000) ' SCOPE:', ( scope0(i), i = 1, nscope )
17836 WRITE(outnum, 2000) 'TReps :', topsrepeat
17837 WRITE(outnum, 2000) 'TCohr :', topscohrnt
17838 WRITE(outnum, 2000) 'NTOP :', ntop
17839 WRITE(outnum, 3000) ' TOP :', ( top0(i), i = 1, ntop )
17840 WRITE(outnum, 2000) 'NMAT :', nmat
17841 WRITE(outnum, 2000) ' M :', ( m0(i), i = 1, nmat )
17842 WRITE(outnum, 2000) ' N :', ( n0(i), i = 1, nmat )
17843 WRITE(outnum, 2000) ' LDAS :', ( ldas0(i), i = 1, nmat )
17844 WRITE(outnum, 2000) ' LDAD :', ( ldad0(i), i = 1, nmat )
17845 WRITE(outnum, 2000) ' LDI :', ( ldi0(i), i = 1, nmat )
17846 WRITE(outnum, 2000) 'NDEST :', ndest
17847 WRITE(outnum, 2000) ' RDEST:',( rdest0(i), i = 1, ndest )
17848 WRITE(outnum, 2000) ' CDEST:',( cdest0(i), i = 1, ndest )
17849 WRITE(outnum, 2000) 'NGRIDS:', ngrid
17850 WRITE(outnum, 2000) ' P :', ( p0(i), i = 1, ngrid )
17851 WRITE(outnum, 2000) ' Q :', ( q0(i), i = 1, ngrid )
17852 WRITE(outnum, 2000) 'VERB :', verb
17853 WRITE(outnum,*) ' '
17854 END IF
17855 IF( verb .GT. 1 ) THEN
17856 WRITE(outnum,4000)
17857 WRITE(outnum,5000)
17858 END IF
17859 END IF
17860 IF (topsrepeat.EQ.0) THEN
17861 itr1 = 0
17862 itr2 = 0
17863 ELSE IF (topsrepeat.EQ.1) THEN
17864 itr1 = 1
17865 itr2 = 1
17866 ELSE
17867 itr1 = 0
17868 itr2 = 1
17869 END IF
17870*
17871* Find biggest matrix, so we know where to stick error info
17872*
17873 i = 0
17874 DO 10 ima = 1, nmat
17875 ipad = 4 * m0(ima)
17876 k = n0(ima) * max0( ldas0(ima), ldad0(ima) ) + ipad
17877 IF( k .GT. i ) i = k
17878 10 CONTINUE
17879 i = i + ibtnprocs()
17880 maxerr = ( zsize * (memlen-i) ) / ( zsize*2 + isize*6 )
17881 IF( maxerr .LT. 1 ) THEN
17882 WRITE(outnum,*) 'ERROR: Not enough memory to run MAX tests.'
17883 CALL blacs_abort(-1, 1)
17884 END IF
17885 errdptr = i + 1
17886 erriptr = errdptr + maxerr
17887 nerr = 0
17888 testnum = 0
17889 nfail = 0
17890 nskip = 0
17891*
17892* Loop over grids of matrix
17893*
17894 DO 90 igr = 1, ngrid
17895*
17896* allocate process grid for the next batch of tests
17897*
17898 context = context0(igr)
17899 CALL blacs_gridinfo( context, nprow, npcol, myrow, mycol )
17900 ingrid = ( (myrow.LT.nprow) .AND. (mycol.LT.npcol) )
17901*
17902 DO 80 isc = 1, nscope
17903 scope = scope0(isc)
17904 DO 70 ito = 1, ntop
17905 top = top0(ito)
17906*
17907* If testing multiring ('M') or general tree ('T'), need to
17908* loop over calls to BLACS_SET to do full test
17909*
17910 IF( lsame(top, 'M') ) THEN
17911 setwhat = 13
17912 IF( scope .EQ. 'R' ) THEN
17913 istart = -(npcol - 1)
17914 istop = -istart
17915 ELSE IF (scope .EQ. 'C') THEN
17916 istart = -(nprow - 1)
17917 istop = -istart
17918 ELSE
17919 istart = -(nprow*npcol - 1)
17920 istop = -istart
17921 ENDIF
17922 ELSE IF( lsame(top, 'T') ) THEN
17923 setwhat = 14
17924 istart = 1
17925 IF( scope .EQ. 'R' ) THEN
17926 istop = npcol - 1
17927 ELSE IF (scope .EQ. 'C') THEN
17928 istop = nprow - 1
17929 ELSE
17930 istop = nprow*npcol - 1
17931 ENDIF
17932 ELSE
17933 setwhat = 0
17934 istart = 1
17935 istop = 1
17936 ENDIF
17937 DO 60 ima = 1, nmat
17938 m = m0(ima)
17939 n = n0(ima)
17940 ldasrc = ldas0(ima)
17941 ldadst = ldad0(ima)
17942 ldi = ldi0(ima)
17943 ipre = 2 * m
17944 ipost = ipre
17945 preaptr = 1
17946 aptr = preaptr + ipre
17947*
17948 DO 50 ide = 1, ndest
17949 testnum = testnum + 1
17950 rdest2 = rdest0(ide)
17951 cdest2 = cdest0(ide)
17952*
17953* If everyone gets the answer, create some bogus rdest/cdest
17954* so IF's are easier
17955*
17956 allrcv = ( (rdest2.EQ.-1) .OR. (cdest2.EQ.-1) )
17957 IF( allrcv ) THEN
17958 rdest = nprow - 1
17959 cdest = npcol - 1
17960 IF (topscohrnt.EQ.0) THEN
17961 itr1 = 0
17962 itr2 = 0
17963 ELSE IF (topscohrnt.EQ.1) THEN
17964 itr1 = 1
17965 itr2 = 1
17966 ELSE
17967 itr1 = 0
17968 itr2 = 1
17969 END IF
17970 ELSE
17971 rdest = rdest2
17972 cdest = cdest2
17973 itc1 = 0
17974 itc2 = 0
17975 END IF
17976 IF( rdest.GE.p0(igr) .OR. cdest.GE.q0(igr) ) THEN
17977 nskip = nskip + 1
17978 GOTO 50
17979 END IF
17980*
17981 IF( myrow.EQ.rdest .AND. mycol.EQ.cdest ) THEN
17982 lda = ldadst
17983 ELSE
17984 lda = ldasrc
17985 END IF
17986 valptr = aptr + ipost + n * lda
17987 IF( verb .GT. 1 ) THEN
17988 IF( iam .EQ. 0 ) THEN
17989 WRITE(outnum, 6000)
17990 $ testnum, 'RUNNING', scope, top, m, n,
17991 $ ldasrc, ldadst, ldi, rdest2, cdest2,
17992 $ nprow, npcol
17993 END IF
17994 END IF
17995*
17996* If I am in scope
17997*
17998 testok = .true.
17999 IF( ingrid ) THEN
18000 IF( (myrow.EQ.rdest .AND. scope.EQ.'R') .OR.
18001 $ (mycol.EQ.cdest .AND. scope.EQ.'C') .OR.
18002 $ (scope .EQ. 'A') ) THEN
18003*
18004 k = nerr
18005 DO 40 itr = itr1, itr2
18006 CALL blacs_set(context, 15, itr)
18007 DO 35 itc = itc1, itc2
18008 CALL blacs_set(context, 16, itc)
18009 DO 30 j = istart, istop
18010 IF( j.EQ.0) GOTO 30
18011 IF( setwhat.NE.0 )
18012 $ CALL blacs_set(context, setwhat, j)
18013*
18014*
18015* generate and pad matrix A
18016*
18017 CALL zinitmat('G','-', m, n, mem(preaptr),
18018 $ lda, ipre, ipost,
18019 $ checkval, testnum,
18020 $ myrow, mycol )
18021*
18022* If they exist, pad RA and CA arrays
18023*
18024 IF( ldi .NE. -1 ) THEN
18025 DO 15 i = 1, n*ldi + ipre + ipost
18026 rmem(i) = icheckval
18027 cmem(i) = icheckval
18028 15 CONTINUE
18029 raptr = 1 + ipre
18030 captr = 1 + ipre
18031 ELSE
18032 DO 20 i = 1, ipre+ipost
18033 rmem(i) = icheckval
18034 cmem(i) = icheckval
18035 20 CONTINUE
18036 raptr = 1
18037 captr = 1
18038 END IF
18039*
18040 CALL zgamx2d(context, scope, top, m, n,
18041 $ mem(aptr), lda, rmem(raptr),
18042 $ cmem(captr), ldi,
18043 $ rdest2, cdest2)
18044*
18045* If I've got the answer, check for errors in
18046* matrix or padding
18047*
18048 IF( (myrow.EQ.rdest .AND. mycol.EQ.cdest)
18049 $ .OR. allrcv ) THEN
18050 CALL zchkpad('G','-', m, n,
18051 $ mem(preaptr), lda, rdest,
18052 $ cdest, myrow, mycol,
18053 $ ipre, ipost, checkval,
18054 $ testnum, maxerr, nerr,
18055 $ mem(erriptr),mem(errdptr))
18056 CALL zchkamx(scope, context, m, n,
18057 $ mem(aptr), lda,
18058 $ rmem(raptr), cmem(captr),
18059 $ ldi, testnum, maxerr,nerr,
18060 $ mem(erriptr),mem(errdptr),
18061 $ iseed, mem(valptr))
18062 CALL zrcchk(ipre, ipost, icheckval,
18063 $ m, n, rmem, cmem, ldi,
18064 $ myrow, mycol, testnum,
18065 $ maxerr, nerr,
18066 $ mem(erriptr), mem(errdptr))
18067 END IF
18068 30 CONTINUE
18069 CALL blacs_set(context, 16, 0)
18070 35 CONTINUE
18071 CALL blacs_set(context, 15, 0)
18072 40 CONTINUE
18073 testok = ( k .EQ. nerr )
18074 END IF
18075 END IF
18076*
18077 IF( verb .GT. 1 ) THEN
18078 i = nerr
18079 CALL zbtcheckin(0, outnum, maxerr, nerr,
18080 $ mem(erriptr), mem(errdptr), iseed)
18081 IF( iam .EQ. 0 ) THEN
18082 IF( testok .AND. nerr.EQ.i ) THEN
18083 WRITE(outnum,6000)testnum,'PASSED ',
18084 $ scope, top, m, n, ldasrc,
18085 $ ldadst, ldi, rdest2, cdest2,
18086 $ nprow, npcol
18087 ELSE
18088 nfail = nfail + 1
18089 WRITE(outnum,6000)testnum,'FAILED ',
18090 $ scope, top, m, n, ldasrc,
18091 $ ldadst, ldi, rdest2, cdest2,
18092 $ nprow, npcol
18093 END IF
18094 END IF
18095*
18096* Once we've printed out errors, can re-use buf space
18097*
18098 nerr = 0
18099 END IF
18100 50 CONTINUE
18101 60 CONTINUE
18102 70 CONTINUE
18103 80 CONTINUE
18104 90 CONTINUE
18105*
18106 IF( verb .LT. 2 ) THEN
18107 nfail = testnum
18108 CALL zbtcheckin( nfail, outnum, maxerr, nerr, mem(erriptr),
18109 $ mem(errdptr), iseed )
18110 END IF
18111 IF( iam .EQ. 0 ) THEN
18112 IF( verb .GT. 1 ) WRITE(outnum,*) ' '
18113 IF( nfail+nskip .EQ. 0 ) THEN
18114 WRITE(outnum, 7000 ) testnum
18115 ELSE
18116 WRITE(outnum, 8000 ) testnum, testnum-nskip-nfail,
18117 $ nskip, nfail
18118 END IF
18119 END IF
18120*
18121* Log whether their were any failures
18122*
18123 testok = allpass( (nfail.EQ.0) )
18124*
18125 1000 FORMAT('DOUBLE COMPLEX AMX TESTS: BEGIN.' )
18126 2000 FORMAT(1x,a7,3x,10i6)
18127 3000 FORMAT(1x,a7,3x,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,
18128 $ 5x,a1,5x,a1)
18129 4000 FORMAT(' TEST# STATUS SCOPE TOP M N LDAS LDAD LDI ',
18130 $ 'RDEST CDEST P Q')
18131 5000 FORMAT(' ----- ------- ----- --- ----- ----- ----- ----- ----- ',
18132 $ '----- ----- ---- ----')
18133 6000 FORMAT(i6,1x,a7,5x,a1,3x,a1,7i6,2i5)
18134 7000 FORMAT('DOUBLE COMPLEX AMX TESTS: PASSED ALL',
18135 $ i5, ' TESTS.')
18136 8000 FORMAT('DOUBLE COMPLEX AMX TESTS:',i5,' TESTS;',i5,' PASSED,',
18137 $ i5,' SKIPPED,',i5,' FAILED.')
18138*
18139 RETURN
18140*
18141* End of ZTESTAMX.
18142*
18143 END
18144*
18145 SUBROUTINE zrcchk( IPRE, IPOST, PADVAL, M, N, RA, CA, LDI, MYROW,
18146 $ MYCOL, TESTNUM, MAXERR, NERR,
18147 $ ERRIBUF, ERRDBUF )
18148*
18149* .. Scalar Arguments ..
18150 INTEGER IPRE, IPOST, PADVAL, M, N, LDI, MYROW, MYCOL, TESTNUM
18151 INTEGER MAXERR, NERR
18152* ..
18153* .. Array Arguments ..
18154 INTEGER RA(*), CA(*), ERRIBUF(6, MAXERR)
18155 DOUBLE COMPLEX ERRDBUF(2, MAXERR)
18156* ..
18157* .. Parameters ..
18158 INTEGER ERR_PRE, ERR_POST, ERR_GAP, ERR_TRI, ERR_MAT
18159 PARAMETER( ERR_PRE = 1, err_post = 2, err_gap = 3, err_tri = 4 )
18160 parameter( err_mat = 5 )
18161* ..
18162* .. External Functions ..
18163 INTEGER IBTNPROCS
18164 EXTERNAL IBTNPROCS
18165* ..
18166* .. Local Scalars ..
18167 INTEGER I, J, K, IAM
18168* ..
18169* .. Executable Statements ..
18170*
18171 iam = myrow * ibtnprocs() + mycol
18172*
18173* Check pre padding
18174*
18175 IF( ldi .NE. -1 ) THEN
18176 IF( ipre .GT. 0 ) THEN
18177 DO 10 i = 1, ipre
18178 IF( ra(i) .NE. padval ) THEN
18179 nerr = nerr + 1
18180 IF( nerr .LE. maxerr ) THEN
18181 erribuf(1, nerr) = testnum
18182 erribuf(2, nerr) = ldi
18183 erribuf(3, nerr) = iam
18184 erribuf(4, nerr) = i
18185 erribuf(5, nerr) = ipre - i + 1
18186 erribuf(6, nerr) = -err_pre
18187 errdbuf(1, nerr) = dcmplx( ra(i) )
18188 errdbuf(2, nerr) = dcmplx( padval )
18189 END IF
18190 ENDIF
18191 IF( ca(i) .NE. padval ) THEN
18192 nerr = nerr + 1
18193 IF( nerr .LE. maxerr ) THEN
18194 erribuf(1, nerr) = testnum
18195 erribuf(2, nerr) = ldi
18196 erribuf(3, nerr) = iam
18197 erribuf(4, nerr) = i
18198 erribuf(5, nerr) = ipre - i + 1
18199 erribuf(6, nerr) = -10 - err_pre
18200 errdbuf(1, nerr) = dcmplx( ca(i) )
18201 errdbuf(2, nerr) = dcmplx( padval )
18202 END IF
18203 ENDIF
18204 10 CONTINUE
18205 END IF
18206*
18207* Check post padding
18208*
18209 IF( ipost .GT. 0 ) THEN
18210 k = ipre + ldi*n
18211 DO 20 i = k+1, k+ipost
18212 IF( ra(i) .NE. padval ) THEN
18213 nerr = nerr + 1
18214 IF( nerr .LE. maxerr ) THEN
18215 erribuf(1, nerr) = testnum
18216 erribuf(2, nerr) = ldi
18217 erribuf(3, nerr) = iam
18218 erribuf(4, nerr) = i - k
18219 erribuf(5, nerr) = i
18220 erribuf(6, nerr) = -err_post
18221 errdbuf(1, nerr) = dcmplx( ra(i) )
18222 errdbuf(2, nerr) = dcmplx( padval )
18223 END IF
18224 ENDIF
18225 IF( ca(i) .NE. padval ) THEN
18226 nerr = nerr + 1
18227 IF( nerr .LE. maxerr ) THEN
18228 erribuf(1, nerr) = testnum
18229 erribuf(2, nerr) = ldi
18230 erribuf(3, nerr) = iam
18231 erribuf(4, nerr) = i - k
18232 erribuf(5, nerr) = i
18233 erribuf(6, nerr) = -10 - err_post
18234 errdbuf(1, nerr) = dcmplx( ca(i) )
18235 errdbuf(2, nerr) = dcmplx( padval )
18236 END IF
18237 ENDIF
18238 20 CONTINUE
18239 END IF
18240*
18241* Check all (LDI-M) gaps
18242*
18243 IF( ldi .GT. m ) THEN
18244 k = ipre + m + 1
18245 DO 40 j = 1, n
18246 DO 30 i = m+1, ldi
18247 k = ipre + (j-1)*ldi + i
18248 IF( ra(k) .NE. padval) THEN
18249 nerr = nerr + 1
18250 IF( nerr .LE. maxerr ) THEN
18251 erribuf(1, nerr) = testnum
18252 erribuf(2, nerr) = ldi
18253 erribuf(3, nerr) = iam
18254 erribuf(4, nerr) = i
18255 erribuf(5, nerr) = j
18256 erribuf(6, nerr) = -err_gap
18257 errdbuf(1, nerr) = dcmplx( ra(k) )
18258 errdbuf(2, nerr) = dcmplx( padval )
18259 END IF
18260 END IF
18261 IF( ca(k) .NE. padval) THEN
18262 nerr = nerr + 1
18263 IF( nerr .LE. maxerr ) THEN
18264 erribuf(1, nerr) = testnum
18265 erribuf(2, nerr) = ldi
18266 erribuf(3, nerr) = iam
18267 erribuf(4, nerr) = i
18268 erribuf(5, nerr) = j
18269 erribuf(6, nerr) = -10 - err_gap
18270 errdbuf(1, nerr) = dcmplx( ca(k) )
18271 errdbuf(2, nerr) = dcmplx( padval )
18272 END IF
18273 END IF
18274 30 CONTINUE
18275 40 CONTINUE
18276 END IF
18277*
18278* if RA and CA don't exist, buffs better be untouched
18279*
18280 ELSE
18281 DO 50 i = 1, ipre+ipost
18282 IF( ra(i) .NE. padval) THEN
18283 nerr = nerr + 1
18284 IF( nerr .LE. maxerr ) THEN
18285 erribuf(1, nerr) = testnum
18286 erribuf(2, nerr) = ldi
18287 erribuf(3, nerr) = iam
18288 erribuf(4, nerr) = i
18289 erribuf(5, nerr) = ipre+ipost
18290 erribuf(6, nerr) = -err_pre
18291 errdbuf(1, nerr) = dcmplx( ra(i) )
18292 errdbuf(2, nerr) = dcmplx( padval )
18293 END IF
18294 END IF
18295 IF( ca(i) .NE. padval) THEN
18296 nerr = nerr + 1
18297 IF( nerr .LE. maxerr ) THEN
18298 erribuf(1, nerr) = testnum
18299 erribuf(2, nerr) = ldi
18300 erribuf(3, nerr) = iam
18301 erribuf(4, nerr) = i
18302 erribuf(5, nerr) = ipre+ipost
18303 erribuf(6, nerr) = -10 - err_pre
18304 errdbuf(1, nerr) = dcmplx( ca(i) )
18305 errdbuf(2, nerr) = dcmplx( padval )
18306 END IF
18307 END IF
18308 50 CONTINUE
18309 ENDIF
18310*
18311 RETURN
18312 END
18313*
18314 SUBROUTINE zchkamx( SCOPE, ICTXT, M, N, A, LDA, RA, CA, LDI,
18315 $ TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF,
18316 $ ISEED, VALS )
18317*
18318* .. Scalar Arguments ..
18319 CHARACTER*1 SCOPE
18320 INTEGER ICTXT, M, N, LDA, LDI, TESTNUM, MAXERR, NERR
18321* ..
18322* .. Array Arguments ..
18323 INTEGER RA(*), CA(*), ERRIBUF(6, MAXERR), ISEED(*)
18324 DOUBLE COMPLEX A(LDA,*), ERRDBUF(2, MAXERR), VALS(*)
18325* ..
18326* .. External Functions ..
18327 INTEGER IBTMYPROC, IBTNPROCS, IBTSPNUM
18328 DOUBLE PRECISION DBTEPS, ZBTABS
18329 DOUBLE COMPLEX ZBTRAN
18330 EXTERNAL ibtmyproc, ibtnprocs, ibtspnum, zbtran, dbteps, zbtabs
18331* ..
18332* .. External Subroutines ..
18333 EXTERNAL ibtspcoord
18334* ..
18335* .. Local Scalars ..
18336 LOGICAL ERROR
18337 INTEGER NPROCS, NNODES, NPROW, NPCOL, MYROW, MYCOL, RAMX, CAMX
18338 INTEGER IAMX, I, J, K, H, DEST, NODE
18339 DOUBLE PRECISION EPS
18340* ..
18341* .. Executable Statements ..
18342*
18343 nprocs = ibtnprocs()
18344 eps = dbteps()
18345 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
18346 dest = myrow*nprocs + mycol
18347*
18348* Set up seeds to match those used by each proc's genmat call
18349*
18350 IF( scope .EQ. 'R' ) THEN
18351 nnodes = npcol
18352 DO 10 i = 0, nnodes-1
18353 node = myrow * nprocs + i
18354 iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
18355 iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
18356 iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
18357 iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
18358 10 CONTINUE
18359 ELSE IF( scope .EQ. 'C' ) THEN
18360 nnodes = nprow
18361 DO 20 i = 0, nnodes-1
18362 node = i * nprocs + mycol
18363 iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
18364 iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
18365 iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
18366 iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
18367 20 CONTINUE
18368 ELSE
18369 nnodes = nprow * npcol
18370 DO 30 i = 0, nnodes-1
18371 node = (i / npcol) * nprocs + mod(i, npcol)
18372 iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
18373 iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
18374 iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
18375 iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
18376 30 CONTINUE
18377 END IF
18378*
18379 DO 100 j = 1, n
18380 DO 90 i = 1, m
18381 h = (j-1)*ldi + i
18382 vals(1) = zbtran( iseed )
18383 iamx = 1
18384 IF( nnodes .GT. 1 ) THEN
18385 DO 40 k = 1, nnodes-1
18386 vals(k+1) = zbtran( iseed(k*4+1) )
18387 IF( zbtabs( vals(k+1) ) .GT. zbtabs( vals(iamx) ) )
18388 $ iamx = k + 1
18389 40 CONTINUE
18390 END IF
18391*
18392* If BLACS have not returned same value we've chosen
18393*
18394 IF( a(i,j) .NE. vals(iamx) ) THEN
18395*
18396* If we have RA and CA arrays
18397*
18398 IF( ldi .NE. -1 ) THEN
18399*
18400* Any number having the same absolute value is a valid max
18401*
18402 k = ibtspnum( scope, ra(h), ca(h), npcol ) + 1
18403 IF( k.GT.0 .AND. k.LE.nnodes ) THEN
18404 error = abs( zbtabs(vals(k)) - zbtabs(vals(iamx)) )
18405 $ .GT. 3*eps
18406 IF( .NOT.error ) iamx = k
18407 ELSE
18408 error = .true.
18409 END IF
18410 ELSE
18411*
18412* Error if BLACS answer not same absolute value, or if it
18413* was not really in the numbers being compared
18414*
18415 error = abs( zbtabs(a(i,j)) - zbtabs(vals(iamx)) )
18416 $ .GT. 3*eps
18417 IF( .NOT.error ) THEN
18418 DO 50 k = 1, nnodes
18419 IF( vals(k) .EQ. a(i,j) ) GOTO 60
18420 50 CONTINUE
18421 error = .true.
18422 60 CONTINUE
18423 ENDIF
18424 END IF
18425*
18426* If the value is in error
18427*
18428 IF( error ) THEN
18429 nerr = nerr + 1
18430 erribuf(1, nerr) = testnum
18431 erribuf(2, nerr) = nnodes
18432 erribuf(3, nerr) = dest
18433 erribuf(4, nerr) = i
18434 erribuf(5, nerr) = j
18435 erribuf(6, nerr) = 5
18436 errdbuf(1, nerr) = a(i,j)
18437 errdbuf(2, nerr) = vals(iamx)
18438 END IF
18439 END IF
18440*
18441* If they are defined, make sure coordinate entries are OK
18442*
18443 IF( ldi .NE. -1 ) THEN
18444 k = ibtspnum( scope, ra(h), ca(h), npcol ) + 1
18445 IF( k.NE.iamx ) THEN
18446*
18447* Make sure more than one proc doesn't have exact same value
18448* (and therefore there may be more than one valid coordinate
18449* for a single value)
18450*
18451 IF( k.GT.nnodes .OR. k.LT.1 ) THEN
18452 error = .true.
18453 ELSE
18454 error = ( vals(k) .NE. vals(iamx) )
18455 END IF
18456 IF( error ) THEN
18457 CALL ibtspcoord( scope, iamx-1, myrow, mycol,
18458 $ npcol, ramx, camx )
18459 IF( ramx .NE. ra(h) ) THEN
18460 nerr = nerr + 1
18461 erribuf(1, nerr) = testnum
18462 erribuf(2, nerr) = nnodes
18463 erribuf(3, nerr) = dest
18464 erribuf(4, nerr) = i
18465 erribuf(5, nerr) = j
18466 erribuf(6, nerr) = -5
18467 errdbuf(1, nerr) = ra(h)
18468 errdbuf(2, nerr) = ramx
18469 END IF
18470 IF( camx .NE. ca(h) ) THEN
18471 nerr = nerr + 1
18472 erribuf(1, nerr) = testnum
18473 erribuf(2, nerr) = nnodes
18474 erribuf(3, nerr) = dest
18475 erribuf(4, nerr) = i
18476 erribuf(5, nerr) = j
18477 erribuf(6, nerr) = -15
18478 errdbuf(1, nerr) = ca(h)
18479 errdbuf(2, nerr) = camx
18480 END IF
18481 END IF
18482 END IF
18483 END IF
18484 90 CONTINUE
18485 100 CONTINUE
18486*
18487 RETURN
18488*
18489* End of ZCHKAMX
18490*
18491 END
18492*
18493*
18494 SUBROUTINE iamntest( OUTNUM, VERB, TOPSREPEAT, TOPSCOHRNT, NSCOPE,
18495 $ SCOPE0, NTOP, TOP0, NMAT, M0, N0, LDAS0,
18496 $ LDAD0, LDI0, NDEST, RDEST0, CDEST0, NGRID,
18497 $ CONTEXT0, P0, Q0, ISEED, RMEM, CMEM, RCLEN,
18498 $ MEM, MEMLEN )
18499*
18500* -- BLACS tester (version 1.0) --
18501* University of Tennessee
18502* December 15, 1994
18503*
18504*
18505* .. Scalar Arguments ..
18506 INTEGER MEMLEN, NDEST, NGRID, NMAT, NSCOPE, NTOP, OUTNUM, RCLEN,
18507 $ topscohrnt, topsrepeat, verb
18508* ..
18509* .. Array Arguments ..
18510 CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP)
18511 INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT), LDI0(NMAT)
18512 INTEGER RDEST0(NDEST), CDEST0(NDEST), CONTEXT0(NGRID)
18513 INTEGER P0(NGRID), Q0(NGRID), ISEED(*), RMEM(RCLEN), CMEM(RCLEN)
18514 INTEGER MEM(MEMLEN)
18515* ..
18516*
18517* Purpose
18518* =======
18519* ITESTAMN: Test integer AMN COMBINE
18520*
18521* Arguments
18522* =========
18523* OUTNUM (input) INTEGER
18524* The device number to write output to.
18525*
18526* VERB (input) INTEGER
18527* The level of verbosity (how much printing to do).
18528*
18529* NSCOPE (input) INTEGER
18530* The number of scopes to be tested.
18531*
18532* SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE)
18533* Values of the scopes to be tested.
18534*
18535* NTOP (input) INTEGER
18536* The number of topologies to be tested.
18537*
18538* TOP0 (input) CHARACTER*1 array of dimension (NTOP)
18539* Values of the topologies to be tested.
18540*
18541* NMAT (input) INTEGER
18542* The number of matrices to be tested.
18543*
18544* M0 (input) INTEGER array of dimension (NMAT)
18545* Values of M to be tested.
18546*
18547* M0 (input) INTEGER array of dimension (NMAT)
18548* Values of M to be tested.
18549*
18550* N0 (input) INTEGER array of dimension (NMAT)
18551* Values of N to be tested.
18552*
18553* LDAS0 (input) INTEGER array of dimension (NMAT)
18554* Values of LDAS (leading dimension of A on source process)
18555* to be tested.
18556*
18557* LDAD0 (input) INTEGER array of dimension (NMAT)
18558* Values of LDAD (leading dimension of A on destination
18559* process) to be tested.
18560* LDI0 (input) INTEGER array of dimension (NMAT)
18561* Values of LDI (leading dimension of RA/CA) to be tested.
18562* If LDI == -1, these RA/CA should not be accessed.
18563*
18564* NDEST (input) INTEGER
18565* The number of destinations to be tested.
18566*
18567* RDEST0 (input) INTEGER array of dimension (NNDEST)
18568* Values of RDEST (row coordinate of destination) to be
18569* tested.
18570*
18571* CDEST0 (input) INTEGER array of dimension (NNDEST)
18572* Values of CDEST (column coordinate of destination) to be
18573* tested.
18574*
18575* NGRID (input) INTEGER
18576* The number of process grids to be tested.
18577*
18578* CONTEXT0 (input) INTEGER array of dimension (NGRID)
18579* The BLACS context handles corresponding to the grids.
18580*
18581* P0 (input) INTEGER array of dimension (NGRID)
18582* Values of P (number of process rows, NPROW).
18583*
18584* Q0 (input) INTEGER array of dimension (NGRID)
18585* Values of Q (number of process columns, NPCOL).
18586*
18587* ISEED (workspace) INTEGER array of dimension ( MAX(NPROCS, NTESTS) )
18588* Workspace used to hold each process's random number SEED.
18589* This requires NPROCS (number of processor) elements.
18590* If VERB < 2, this workspace also serves to indicate which
18591* tests fail. This requires workspace of NTESTS
18592* (number of tests performed).
18593*
18594* RMEM (workspace) INTEGER array of dimension (RCLEN)
18595* Used for all RA arrays, and their pre and post padding.
18596*
18597* CMEM (workspace) INTEGER array of dimension (RCLEN)
18598* Used for all CA arrays, and their pre and post padding.
18599*
18600* RCLEN (input) INTEGER
18601* The length, in elements, of RMEM and CMEM.
18602*
18603* MEM (workspace) INTEGER array of dimension (MEMLEN)
18604* Used for all other workspaces, including the matrix A,
18605* and its pre and post padding.
18606*
18607* MEMLEN (input) INTEGER
18608* The length, in elements, of MEM.
18609*
18610* =====================================================================
18611*
18612* .. External Functions ..
18613 LOGICAL ALLPASS, LSAME
18614 INTEGER IBTMYPROC, IBTNPROCS, IBTSIZEOF
18615 EXTERNAL allpass, lsame, ibtmyproc, ibtnprocs, ibtsizeof
18616* ..
18617* .. External Subroutines ..
18618 EXTERNAL blacs_gridinfo, igamn2d
18619 EXTERNAL iinitmat, ichkpad, ibtcheckin
18620* ..
18621* .. Local Scalars ..
18622 CHARACTER*1 SCOPE, TOP
18623 LOGICAL INGRID, TESTOK, ALLRCV
18624 INTEGER APTR, CAPTR, CDEST, CDEST2, CONTEXT, ERRDPTR, ERRIPTR, I,
18625 $ iam, icheckval, ide, igr, ima, ipad, ipost, ipre, isc,
18626 $ isize, istart, istop, itc, itc1, itc2, ito, itr, itr1,
18627 $ itr2, j, k, lda, ldadst, ldasrc, ldi, m, maxerr, mycol,
18628 $ myrow, n, nerr, nfail, npcol, nprow, nskip, preaptr,
18629 $ raptr, rdest, rdest2, setwhat, testnum, valptr
18630 INTEGER CHECKVAL
18631* ..
18632* .. Executable Statements ..
18633*
18634* Choose padding value, and make it unique
18635*
18636 checkval = -911
18637 iam = ibtmyproc()
18638 checkval = iam * checkval
18639 isize = ibtsizeof('I')
18640 icheckval = -iam
18641*
18642* Verify file parameters
18643*
18644 IF( iam .EQ. 0 ) THEN
18645 WRITE(outnum, *) ' '
18646 WRITE(outnum, *) ' '
18647 WRITE(outnum, 1000 )
18648 IF( verb .GT. 0 ) THEN
18649 WRITE(outnum,*) ' '
18650 WRITE(outnum, 2000) 'NSCOPE:', nscope
18651 WRITE(outnum, 3000) ' SCOPE:', ( scope0(i), i = 1, nscope )
18652 WRITE(outnum, 2000) 'TReps :', topsrepeat
18653 WRITE(outnum, 2000) 'TCohr :', topscohrnt
18654 WRITE(outnum, 2000) 'NTOP :', ntop
18655 WRITE(outnum, 3000) ' TOP :', ( top0(i), i = 1, ntop )
18656 WRITE(outnum, 2000) 'NMAT :', nmat
18657 WRITE(outnum, 2000) ' M :', ( m0(i), i = 1, nmat )
18658 WRITE(outnum, 2000) ' N :', ( n0(i), i = 1, nmat )
18659 WRITE(outnum, 2000) ' LDAS :', ( ldas0(i), i = 1, nmat )
18660 WRITE(outnum, 2000) ' LDAD :', ( ldad0(i), i = 1, nmat )
18661 WRITE(outnum, 2000) ' LDI :', ( ldi0(i), i = 1, nmat )
18662 WRITE(outnum, 2000) 'NDEST :', ndest
18663 WRITE(outnum, 2000) ' RDEST:',( rdest0(i), i = 1, ndest )
18664 WRITE(outnum, 2000) ' CDEST:',( cdest0(i), i = 1, ndest )
18665 WRITE(outnum, 2000) 'NGRIDS:', ngrid
18666 WRITE(outnum, 2000) ' P :', ( p0(i), i = 1, ngrid )
18667 WRITE(outnum, 2000) ' Q :', ( q0(i), i = 1, ngrid )
18668 WRITE(outnum, 2000) 'VERB :', verb
18669 WRITE(outnum,*) ' '
18670 END IF
18671 IF( verb .GT. 1 ) THEN
18672 WRITE(outnum,4000)
18673 WRITE(outnum,5000)
18674 END IF
18675 END IF
18676 IF (topsrepeat.EQ.0) THEN
18677 itr1 = 0
18678 itr2 = 0
18679 ELSE IF (topsrepeat.EQ.1) THEN
18680 itr1 = 1
18681 itr2 = 1
18682 ELSE
18683 itr1 = 0
18684 itr2 = 1
18685 END IF
18686*
18687* Find biggest matrix, so we know where to stick error info
18688*
18689 i = 0
18690 DO 10 ima = 1, nmat
18691 ipad = 4 * m0(ima)
18692 k = n0(ima) * max0( ldas0(ima), ldad0(ima) ) + ipad
18693 IF( k .GT. i ) i = k
18694 10 CONTINUE
18695 i = i + ibtnprocs()
18696 maxerr = ( isize * (memlen-i) ) / ( isize*2 + isize*6 )
18697 IF( maxerr .LT. 1 ) THEN
18698 WRITE(outnum,*) 'ERROR: Not enough memory to run MIN tests.'
18699 CALL blacs_abort(-1, 1)
18700 END IF
18701 errdptr = i + 1
18702 erriptr = errdptr + maxerr
18703 nerr = 0
18704 testnum = 0
18705 nfail = 0
18706 nskip = 0
18707*
18708* Loop over grids of matrix
18709*
18710 DO 90 igr = 1, ngrid
18711*
18712* allocate process grid for the next batch of tests
18713*
18714 context = context0(igr)
18715 CALL blacs_gridinfo( context, nprow, npcol, myrow, mycol )
18716 ingrid = ( (myrow.LT.nprow) .AND. (mycol.LT.npcol) )
18717*
18718 DO 80 isc = 1, nscope
18719 scope = scope0(isc)
18720 DO 70 ito = 1, ntop
18721 top = top0(ito)
18722*
18723* If testing multiring ('M') or general tree ('T'), need to
18724* loop over calls to BLACS_SET to do full test
18725*
18726 IF( lsame(top, 'M') ) THEN
18727 setwhat = 13
18728 IF( scope .EQ. 'R' ) THEN
18729 istart = -(npcol - 1)
18730 istop = -istart
18731 ELSE IF (scope .EQ. 'C') THEN
18732 istart = -(nprow - 1)
18733 istop = -istart
18734 ELSE
18735 istart = -(nprow*npcol - 1)
18736 istop = -istart
18737 ENDIF
18738 ELSE IF( lsame(top, 'T') ) THEN
18739 setwhat = 14
18740 istart = 1
18741 IF( scope .EQ. 'R' ) THEN
18742 istop = npcol - 1
18743 ELSE IF (scope .EQ. 'C') THEN
18744 istop = nprow - 1
18745 ELSE
18746 istop = nprow*npcol - 1
18747 ENDIF
18748 ELSE
18749 setwhat = 0
18750 istart = 1
18751 istop = 1
18752 ENDIF
18753 DO 60 ima = 1, nmat
18754 m = m0(ima)
18755 n = n0(ima)
18756 ldasrc = ldas0(ima)
18757 ldadst = ldad0(ima)
18758 ldi = ldi0(ima)
18759 ipre = 2 * m
18760 ipost = ipre
18761 preaptr = 1
18762 aptr = preaptr + ipre
18763*
18764 DO 50 ide = 1, ndest
18765 testnum = testnum + 1
18766 rdest2 = rdest0(ide)
18767 cdest2 = cdest0(ide)
18768*
18769* If everyone gets the answer, create some bogus rdest/cdest
18770* so IF's are easier
18771*
18772 allrcv = ( (rdest2.EQ.-1) .OR. (cdest2.EQ.-1) )
18773 IF( allrcv ) THEN
18774 rdest = nprow - 1
18775 cdest = npcol - 1
18776 IF (topscohrnt.EQ.0) THEN
18777 itr1 = 0
18778 itr2 = 0
18779 ELSE IF (topscohrnt.EQ.1) THEN
18780 itr1 = 1
18781 itr2 = 1
18782 ELSE
18783 itr1 = 0
18784 itr2 = 1
18785 END IF
18786 ELSE
18787 rdest = rdest2
18788 cdest = cdest2
18789 itc1 = 0
18790 itc2 = 0
18791 END IF
18792 IF( rdest.GE.p0(igr) .OR. cdest.GE.q0(igr) ) THEN
18793 nskip = nskip + 1
18794 GOTO 50
18795 END IF
18796*
18797 IF( myrow.EQ.rdest .AND. mycol.EQ.cdest ) THEN
18798 lda = ldadst
18799 ELSE
18800 lda = ldasrc
18801 END IF
18802 valptr = aptr + ipost + n * lda
18803 IF( verb .GT. 1 ) THEN
18804 IF( iam .EQ. 0 ) THEN
18805 WRITE(outnum, 6000)
18806 $ testnum, 'RUNNING', scope, top, m, n,
18807 $ ldasrc, ldadst, ldi, rdest2, cdest2,
18808 $ nprow, npcol
18809 END IF
18810 END IF
18811*
18812* If I am in scope
18813*
18814 testok = .true.
18815 IF( ingrid ) THEN
18816 IF( (myrow.EQ.rdest .AND. scope.EQ.'R') .OR.
18817 $ (mycol.EQ.cdest .AND. scope.EQ.'C') .OR.
18818 $ (scope .EQ. 'A') ) THEN
18819*
18820 k = nerr
18821 DO 40 itr = itr1, itr2
18822 CALL blacs_set(context, 15, itr)
18823 DO 35 itc = itc1, itc2
18824 CALL blacs_set(context, 16, itc)
18825 DO 30 j = istart, istop
18826 IF( j.EQ.0) GOTO 30
18827 IF( setwhat.NE.0 )
18828 $ CALL blacs_set(context, setwhat, j)
18829*
18830*
18831* generate and pad matrix A
18832*
18833 CALL iinitmat('G','-', m, n, mem(preaptr),
18834 $ lda, ipre, ipost,
18835 $ checkval, testnum,
18836 $ myrow, mycol )
18837*
18838* If they exist, pad RA and CA arrays
18839*
18840 IF( ldi .NE. -1 ) THEN
18841 DO 15 i = 1, n*ldi + ipre + ipost
18842 rmem(i) = icheckval
18843 cmem(i) = icheckval
18844 15 CONTINUE
18845 raptr = 1 + ipre
18846 captr = 1 + ipre
18847 ELSE
18848 DO 20 i = 1, ipre+ipost
18849 rmem(i) = icheckval
18850 cmem(i) = icheckval
18851 20 CONTINUE
18852 raptr = 1
18853 captr = 1
18854 END IF
18855*
18856 CALL igamn2d(context, scope, top, m, n,
18857 $ mem(aptr), lda, rmem(raptr),
18858 $ cmem(captr), ldi,
18859 $ rdest2, cdest2)
18860*
18861* If I've got the answer, check for errors in
18862* matrix or padding
18863*
18864 IF( (myrow.EQ.rdest .AND. mycol.EQ.cdest)
18865 $ .OR. allrcv ) THEN
18866 CALL ichkpad('G','-', m, n,
18867 $ mem(preaptr), lda, rdest,
18868 $ cdest, myrow, mycol,
18869 $ ipre, ipost, checkval,
18870 $ testnum, maxerr, nerr,
18871 $ mem(erriptr),mem(errdptr))
18872 CALL ichkamn(scope, context, m, n,
18873 $ mem(aptr), lda,
18874 $ rmem(raptr), cmem(captr),
18875 $ ldi, testnum, maxerr,nerr,
18876 $ mem(erriptr),mem(errdptr),
18877 $ iseed, mem(valptr))
18878 CALL ircchk(ipre, ipost, icheckval,
18879 $ m, n, rmem, cmem, ldi,
18880 $ myrow, mycol, testnum,
18881 $ maxerr, nerr,
18882 $ mem(erriptr), mem(errdptr))
18883 END IF
18884 30 CONTINUE
18885 CALL blacs_set(context, 16, 0)
18886 35 CONTINUE
18887 CALL blacs_set(context, 15, 0)
18888 40 CONTINUE
18889 testok = ( k .EQ. nerr )
18890 END IF
18891 END IF
18892*
18893 IF( verb .GT. 1 ) THEN
18894 i = nerr
18895 CALL ibtcheckin(0, outnum, maxerr, nerr,
18896 $ mem(erriptr), mem(errdptr), iseed)
18897 IF( iam .EQ. 0 ) THEN
18898 IF( testok .AND. nerr.EQ.i ) THEN
18899 WRITE(outnum,6000)testnum,'PASSED ',
18900 $ scope, top, m, n, ldasrc,
18901 $ ldadst, ldi, rdest2, cdest2,
18902 $ nprow, npcol
18903 ELSE
18904 nfail = nfail + 1
18905 WRITE(outnum,6000)testnum,'FAILED ',
18906 $ scope, top, m, n, ldasrc,
18907 $ ldadst, ldi, rdest2, cdest2,
18908 $ nprow, npcol
18909 END IF
18910 END IF
18911*
18912* Once we've printed out errors, can re-use buf space
18913*
18914 nerr = 0
18915 END IF
18916 50 CONTINUE
18917 60 CONTINUE
18918 70 CONTINUE
18919 80 CONTINUE
18920 90 CONTINUE
18921*
18922 IF( verb .LT. 2 ) THEN
18923 nfail = testnum
18924 CALL ibtcheckin( nfail, outnum, maxerr, nerr, mem(erriptr),
18925 $ mem(errdptr), iseed )
18926 END IF
18927 IF( iam .EQ. 0 ) THEN
18928 IF( verb .GT. 1 ) WRITE(outnum,*) ' '
18929 IF( nfail+nskip .EQ. 0 ) THEN
18930 WRITE(outnum, 7000 ) testnum
18931 ELSE
18932 WRITE(outnum, 8000 ) testnum, testnum-nskip-nfail,
18933 $ nskip, nfail
18934 END IF
18935 END IF
18936*
18937* Log whether their were any failures
18938*
18939 testok = allpass( (nfail.EQ.0) )
18940*
18941 1000 FORMAT('INTEGER AMN TESTS: BEGIN.' )
18942 2000 FORMAT(1x,a7,3x,10i6)
18943 3000 FORMAT(1x,a7,3x,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,
18944 $ 5x,a1,5x,a1)
18945 4000 FORMAT(' TEST# STATUS SCOPE TOP M N LDAS LDAD LDI ',
18946 $ 'RDEST CDEST P Q')
18947 5000 FORMAT(' ----- ------- ----- --- ----- ----- ----- ----- ----- ',
18948 $ '----- ----- ---- ----')
18949 6000 FORMAT(i6,1x,a7,5x,a1,3x,a1,7i6,2i5)
18950 7000 FORMAT('INTEGER AMN TESTS: PASSED ALL',
18951 $ i5, ' TESTS.')
18952 8000 FORMAT('INTEGER AMN TESTS:',i5,' TESTS;',i5,' PASSED,',
18953 $ i5,' SKIPPED,',i5,' FAILED.')
18954*
18955 RETURN
18956*
18957* End of ITESTAMN.
18958*
18959 END
18960*
18961 SUBROUTINE ichkamn( SCOPE, ICTXT, M, N, A, LDA, RA, CA, LDI,
18962 $ TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF,
18963 $ ISEED, VALS )
18964*
18965* .. Scalar Arguments ..
18966 CHARACTER*1 SCOPE
18967 INTEGER ICTXT, M, N, LDA, LDI, TESTNUM, MAXERR, NERR
18968* ..
18969* .. Array Arguments ..
18970 INTEGER RA(*), CA(*), ERRIBUF(6, MAXERR), ISEED(*)
18971 INTEGER A(LDA,*), ERRDBUF(2, MAXERR), VALS(*)
18972* ..
18973* .. External Functions ..
18974 INTEGER IBTMYPROC, IBTNPROCS, IBTSPNUM, IBTRAN, IBTABS
18975 EXTERNAL ibtmyproc, ibtnprocs, ibtspnum, ibtran
18976 EXTERNAL ibtabs
18977* ..
18978* .. External Subroutines ..
18979 EXTERNAL ibtspcoord
18980* ..
18981* .. Local Scalars ..
18982 LOGICAL ERROR
18983 INTEGER NPROCS, NNODES, NPROW, NPCOL, MYROW, MYCOL, RAMN, CAMN
18984 INTEGER IAMN, I, J, K, H, DEST, NODE
18985* ..
18986* .. Executable Statements ..
18987*
18988 nprocs = ibtnprocs()
18989 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
18990 dest = myrow*nprocs + mycol
18991*
18992* Set up seeds to match those used by each proc's genmat call
18993*
18994 IF( scope .EQ. 'R' ) THEN
18995 nnodes = npcol
18996 DO 10 i = 0, nnodes-1
18997 node = myrow * nprocs + i
18998 iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
18999 iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
19000 iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
19001 iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
19002 10 CONTINUE
19003 ELSE IF( scope .EQ. 'C' ) THEN
19004 nnodes = nprow
19005 DO 20 i = 0, nnodes-1
19006 node = i * nprocs + mycol
19007 iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
19008 iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
19009 iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
19010 iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
19011 20 CONTINUE
19012 ELSE
19013 nnodes = nprow * npcol
19014 DO 30 i = 0, nnodes-1
19015 node = (i / npcol) * nprocs + mod(i, npcol)
19016 iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
19017 iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
19018 iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
19019 iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
19020 30 CONTINUE
19021 END IF
19022*
19023 DO 100 j = 1, n
19024 DO 90 i = 1, m
19025 h = (j-1)*ldi + i
19026 vals(1) = ibtran( iseed )
19027 iamn = 1
19028 IF( nnodes .GT. 1 ) THEN
19029 DO 40 k = 1, nnodes-1
19030 vals(k+1) = ibtran( iseed(k*4+1) )
19031 IF( ibtabs( vals(k+1) ) .LT. ibtabs( vals(iamn) ) )
19032 $ iamn = k + 1
19033 40 CONTINUE
19034 END IF
19035*
19036* If BLACS have not returned same value we've chosen
19037*
19038 IF( a(i,j) .NE. vals(iamn) ) THEN
19039*
19040* If we have RA and CA arrays
19041*
19042 IF( ldi .NE. -1 ) THEN
19043*
19044* Any number having the same absolute value is a valid max
19045*
19046 k = ibtspnum( scope, ra(h), ca(h), npcol ) + 1
19047 IF( k.GT.0 .AND. k.LE.nnodes ) THEN
19048 error = ibtabs( vals(k) ).NE.ibtabs( vals(iamn) )
19049 IF( .NOT.error ) iamn = k
19050 ELSE
19051 error = .true.
19052 END IF
19053 ELSE
19054*
19055* Error if BLACS answer not same absolute value, or if it
19056* was not really in the numbers being compared
19057*
19058 error = ( ibtabs( a(i,j) ) .NE. ibtabs( vals(iamn) ) )
19059 IF( .NOT.error ) THEN
19060 DO 50 k = 1, nnodes
19061 IF( vals(k) .EQ. a(i,j) ) GOTO 60
19062 50 CONTINUE
19063 error = .true.
19064 60 CONTINUE
19065 ENDIF
19066 END IF
19067*
19068* If the value is in error
19069*
19070 IF( error ) THEN
19071 nerr = nerr + 1
19072 erribuf(1, nerr) = testnum
19073 erribuf(2, nerr) = nnodes
19074 erribuf(3, nerr) = dest
19075 erribuf(4, nerr) = i
19076 erribuf(5, nerr) = j
19077 erribuf(6, nerr) = 5
19078 errdbuf(1, nerr) = a(i,j)
19079 errdbuf(2, nerr) = vals(iamn)
19080 END IF
19081 END IF
19082*
19083* If they are defined, make sure coordinate entries are OK
19084*
19085 IF( ldi .NE. -1 ) THEN
19086 k = ibtspnum( scope, ra(h), ca(h), npcol ) + 1
19087 IF( k.NE.iamn ) THEN
19088*
19089* Make sure more than one proc doesn't have exact same value
19090* (and therefore there may be more than one valid coordinate
19091* for a single value)
19092*
19093 IF( k.GT.nnodes .OR. k.LT.1 ) THEN
19094 error = .true.
19095 ELSE
19096 error = ( vals(k) .NE. vals(iamn) )
19097 END IF
19098 IF( error ) THEN
19099 CALL ibtspcoord( scope, iamn-1, myrow, mycol,
19100 $ npcol, ramn, camn )
19101 IF( ramn .NE. ra(h) ) THEN
19102 nerr = nerr + 1
19103 erribuf(1, nerr) = testnum
19104 erribuf(2, nerr) = nnodes
19105 erribuf(3, nerr) = dest
19106 erribuf(4, nerr) = i
19107 erribuf(5, nerr) = j
19108 erribuf(6, nerr) = -5
19109 errdbuf(1, nerr) = ra(h)
19110 errdbuf(2, nerr) = ramn
19111 END IF
19112 IF( camn .NE. ca(h) ) THEN
19113 nerr = nerr + 1
19114 erribuf(1, nerr) = testnum
19115 erribuf(2, nerr) = nnodes
19116 erribuf(3, nerr) = dest
19117 erribuf(4, nerr) = i
19118 erribuf(5, nerr) = j
19119 erribuf(6, nerr) = -15
19120 errdbuf(1, nerr) = ca(h)
19121 errdbuf(2, nerr) = camn
19122 END IF
19123 END IF
19124 END IF
19125 END IF
19126 90 CONTINUE
19127 100 CONTINUE
19128*
19129 RETURN
19130*
19131* End of ICHKAMN
19132*
19133 END
19134*
19135*
19136 SUBROUTINE samntest( OUTNUM, VERB, TOPSREPEAT, TOPSCOHRNT, NSCOPE,
19137 $ SCOPE0, NTOP, TOP0, NMAT, M0, N0, LDAS0,
19138 $ LDAD0, LDI0, NDEST, RDEST0, CDEST0, NGRID,
19139 $ CONTEXT0, P0, Q0, ISEED, RMEM, CMEM, RCLEN,
19140 $ MEM, MEMLEN )
19141*
19142* -- BLACS tester (version 1.0) --
19143* University of Tennessee
19144* December 15, 1994
19145*
19146*
19147* .. Scalar Arguments ..
19148 INTEGER MEMLEN, NDEST, NGRID, NMAT, NSCOPE, NTOP, OUTNUM, RCLEN,
19149 $ TOPSCOHRNT, TOPSREPEAT, VERB
19150* ..
19151* .. Array Arguments ..
19152 CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP)
19153 INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT), LDI0(NMAT)
19154 INTEGER RDEST0(NDEST), CDEST0(NDEST), CONTEXT0(NGRID)
19155 INTEGER P0(NGRID), Q0(NGRID), ISEED(*), RMEM(RCLEN), CMEM(RCLEN)
19156 REAL MEM(MEMLEN)
19157* ..
19158*
19159* Purpose
19160* =======
19161* STESTAMN: Test real AMN COMBINE
19162*
19163* Arguments
19164* =========
19165* OUTNUM (input) INTEGER
19166* The device number to write output to.
19167*
19168* VERB (input) INTEGER
19169* The level of verbosity (how much printing to do).
19170*
19171* NSCOPE (input) INTEGER
19172* The number of scopes to be tested.
19173*
19174* SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE)
19175* Values of the scopes to be tested.
19176*
19177* NTOP (input) INTEGER
19178* The number of topologies to be tested.
19179*
19180* TOP0 (input) CHARACTER*1 array of dimension (NTOP)
19181* Values of the topologies to be tested.
19182*
19183* NMAT (input) INTEGER
19184* The number of matrices to be tested.
19185*
19186* M0 (input) INTEGER array of dimension (NMAT)
19187* Values of M to be tested.
19188*
19189* M0 (input) INTEGER array of dimension (NMAT)
19190* Values of M to be tested.
19191*
19192* N0 (input) INTEGER array of dimension (NMAT)
19193* Values of N to be tested.
19194*
19195* LDAS0 (input) INTEGER array of dimension (NMAT)
19196* Values of LDAS (leading dimension of A on source process)
19197* to be tested.
19198*
19199* LDAD0 (input) INTEGER array of dimension (NMAT)
19200* Values of LDAD (leading dimension of A on destination
19201* process) to be tested.
19202* LDI0 (input) INTEGER array of dimension (NMAT)
19203* Values of LDI (leading dimension of RA/CA) to be tested.
19204* If LDI == -1, these RA/CA should not be accessed.
19205*
19206* NDEST (input) INTEGER
19207* The number of destinations to be tested.
19208*
19209* RDEST0 (input) INTEGER array of dimension (NNDEST)
19210* Values of RDEST (row coordinate of destination) to be
19211* tested.
19212*
19213* CDEST0 (input) INTEGER array of dimension (NNDEST)
19214* Values of CDEST (column coordinate of destination) to be
19215* tested.
19216*
19217* NGRID (input) INTEGER
19218* The number of process grids to be tested.
19219*
19220* CONTEXT0 (input) INTEGER array of dimension (NGRID)
19221* The BLACS context handles corresponding to the grids.
19222*
19223* P0 (input) INTEGER array of dimension (NGRID)
19224* Values of P (number of process rows, NPROW).
19225*
19226* Q0 (input) INTEGER array of dimension (NGRID)
19227* Values of Q (number of process columns, NPCOL).
19228*
19229* ISEED (workspace) INTEGER array of dimension ( MAX(NPROCS, NTESTS) )
19230* Workspace used to hold each process's random number SEED.
19231* This requires NPROCS (number of processor) elements.
19232* If VERB < 2, this workspace also serves to indicate which
19233* tests fail. This requires workspace of NTESTS
19234* (number of tests performed).
19235*
19236* RMEM (workspace) INTEGER array of dimension (RCLEN)
19237* Used for all RA arrays, and their pre and post padding.
19238*
19239* CMEM (workspace) INTEGER array of dimension (RCLEN)
19240* Used for all CA arrays, and their pre and post padding.
19241*
19242* RCLEN (input) INTEGER
19243* The length, in elements, of RMEM and CMEM.
19244*
19245* MEM (workspace) REAL array of dimension (MEMLEN)
19246* Used for all other workspaces, including the matrix A,
19247* and its pre and post padding.
19248*
19249* MEMLEN (input) INTEGER
19250* The length, in elements, of MEM.
19251*
19252* =====================================================================
19253*
19254* .. External Functions ..
19255 LOGICAL ALLPASS, LSAME
19256 INTEGER IBTMYPROC, IBTNPROCS, IBTSIZEOF
19257 EXTERNAL ALLPASS, LSAME, IBTMYPROC, IBTNPROCS, IBTSIZEOF
19258* ..
19259* .. External Subroutines ..
19260 EXTERNAL blacs_gridinfo, sgamn2d
19261 EXTERNAL sinitmat, schkpad, sbtcheckin
19262* ..
19263* .. Local Scalars ..
19264 CHARACTER*1 SCOPE, TOP
19265 LOGICAL INGRID, TESTOK, ALLRCV
19266 INTEGER APTR, CAPTR, CDEST, CDEST2, CONTEXT, ERRDPTR, ERRIPTR, I,
19267 $ iam, icheckval, ide, igr, ima, ipad, ipost, ipre, isc,
19268 $ isize, istart, istop, itc, itc1, itc2, ito, itr, itr1,
19269 $ itr2, j, k, lda, ldadst, ldasrc, ldi, m, maxerr, mycol,
19270 $ myrow, n, nerr, nfail, npcol, nprow, nskip, preaptr,
19271 $ raptr, rdest, rdest2, setwhat, ssize, testnum, valptr
19272 REAL CHECKVAL
19273* ..
19274* .. Executable Statements ..
19275*
19276* Choose padding value, and make it unique
19277*
19278 checkval = -0.61e0
19279 iam = ibtmyproc()
19280 checkval = iam * checkval
19281 isize = ibtsizeof('I')
19282 ssize = ibtsizeof('S')
19283 icheckval = -iam
19284*
19285* Verify file parameters
19286*
19287 IF( iam .EQ. 0 ) THEN
19288 WRITE(outnum, *) ' '
19289 WRITE(outnum, *) ' '
19290 WRITE(outnum, 1000 )
19291 IF( verb .GT. 0 ) THEN
19292 WRITE(outnum,*) ' '
19293 WRITE(outnum, 2000) 'NSCOPE:', nscope
19294 WRITE(outnum, 3000) ' SCOPE:', ( scope0(i), i = 1, nscope )
19295 WRITE(outnum, 2000) 'TReps :', topsrepeat
19296 WRITE(outnum, 2000) 'TCohr :', topscohrnt
19297 WRITE(outnum, 2000) 'NTOP :', ntop
19298 WRITE(outnum, 3000) ' TOP :', ( top0(i), i = 1, ntop )
19299 WRITE(outnum, 2000) 'NMAT :', nmat
19300 WRITE(outnum, 2000) ' M :', ( m0(i), i = 1, nmat )
19301 WRITE(outnum, 2000) ' N :', ( n0(i), i = 1, nmat )
19302 WRITE(outnum, 2000) ' LDAS :', ( ldas0(i), i = 1, nmat )
19303 WRITE(outnum, 2000) ' LDAD :', ( ldad0(i), i = 1, nmat )
19304 WRITE(outnum, 2000) ' LDI :', ( ldi0(i), i = 1, nmat )
19305 WRITE(outnum, 2000) 'NDEST :', ndest
19306 WRITE(outnum, 2000) ' RDEST:',( rdest0(i), i = 1, ndest )
19307 WRITE(outnum, 2000) ' CDEST:',( cdest0(i), i = 1, ndest )
19308 WRITE(outnum, 2000) 'NGRIDS:', ngrid
19309 WRITE(outnum, 2000) ' P :', ( p0(i), i = 1, ngrid )
19310 WRITE(outnum, 2000) ' Q :', ( q0(i), i = 1, ngrid )
19311 WRITE(outnum, 2000) 'VERB :', verb
19312 WRITE(outnum,*) ' '
19313 END IF
19314 IF( verb .GT. 1 ) THEN
19315 WRITE(outnum,4000)
19316 WRITE(outnum,5000)
19317 END IF
19318 END IF
19319 IF (topsrepeat.EQ.0) THEN
19320 itr1 = 0
19321 itr2 = 0
19322 ELSE IF (topsrepeat.EQ.1) THEN
19323 itr1 = 1
19324 itr2 = 1
19325 ELSE
19326 itr1 = 0
19327 itr2 = 1
19328 END IF
19329*
19330* Find biggest matrix, so we know where to stick error info
19331*
19332 i = 0
19333 DO 10 ima = 1, nmat
19334 ipad = 4 * m0(ima)
19335 k = n0(ima) * max0( ldas0(ima), ldad0(ima) ) + ipad
19336 IF( k .GT. i ) i = k
19337 10 CONTINUE
19338 i = i + ibtnprocs()
19339 maxerr = ( ssize * (memlen-i) ) / ( ssize*2 + isize*6 )
19340 IF( maxerr .LT. 1 ) THEN
19341 WRITE(outnum,*) 'ERROR: Not enough memory to run MIN tests.'
19342 CALL blacs_abort(-1, 1)
19343 END IF
19344 errdptr = i + 1
19345 erriptr = errdptr + maxerr
19346 nerr = 0
19347 testnum = 0
19348 nfail = 0
19349 nskip = 0
19350*
19351* Loop over grids of matrix
19352*
19353 DO 90 igr = 1, ngrid
19354*
19355* allocate process grid for the next batch of tests
19356*
19357 context = context0(igr)
19358 CALL blacs_gridinfo( context, nprow, npcol, myrow, mycol )
19359 ingrid = ( (myrow.LT.nprow) .AND. (mycol.LT.npcol) )
19360*
19361 DO 80 isc = 1, nscope
19362 scope = scope0(isc)
19363 DO 70 ito = 1, ntop
19364 top = top0(ito)
19365*
19366* If testing multiring ('M') or general tree ('T'), need to
19367* loop over calls to BLACS_SET to do full test
19368*
19369 IF( lsame(top, 'M') ) THEN
19370 setwhat = 13
19371 IF( scope .EQ. 'R' ) THEN
19372 istart = -(npcol - 1)
19373 istop = -istart
19374 ELSE IF (scope .EQ. 'C') THEN
19375 istart = -(nprow - 1)
19376 istop = -istart
19377 ELSE
19378 istart = -(nprow*npcol - 1)
19379 istop = -istart
19380 ENDIF
19381 ELSE IF( lsame(top, 'T') ) THEN
19382 setwhat = 14
19383 istart = 1
19384 IF( scope .EQ. 'R' ) THEN
19385 istop = npcol - 1
19386 ELSE IF (scope .EQ. 'C') THEN
19387 istop = nprow - 1
19388 ELSE
19389 istop = nprow*npcol - 1
19390 ENDIF
19391 ELSE
19392 setwhat = 0
19393 istart = 1
19394 istop = 1
19395 ENDIF
19396 DO 60 ima = 1, nmat
19397 m = m0(ima)
19398 n = n0(ima)
19399 ldasrc = ldas0(ima)
19400 ldadst = ldad0(ima)
19401 ldi = ldi0(ima)
19402 ipre = 2 * m
19403 ipost = ipre
19404 preaptr = 1
19405 aptr = preaptr + ipre
19406*
19407 DO 50 ide = 1, ndest
19408 testnum = testnum + 1
19409 rdest2 = rdest0(ide)
19410 cdest2 = cdest0(ide)
19411*
19412* If everyone gets the answer, create some bogus rdest/cdest
19413* so IF's are easier
19414*
19415 allrcv = ( (rdest2.EQ.-1) .OR. (cdest2.EQ.-1) )
19416 IF( allrcv ) THEN
19417 rdest = nprow - 1
19418 cdest = npcol - 1
19419 IF (topscohrnt.EQ.0) THEN
19420 itr1 = 0
19421 itr2 = 0
19422 ELSE IF (topscohrnt.EQ.1) THEN
19423 itr1 = 1
19424 itr2 = 1
19425 ELSE
19426 itr1 = 0
19427 itr2 = 1
19428 END IF
19429 ELSE
19430 rdest = rdest2
19431 cdest = cdest2
19432 itc1 = 0
19433 itc2 = 0
19434 END IF
19435 IF( rdest.GE.p0(igr) .OR. cdest.GE.q0(igr) ) THEN
19436 nskip = nskip + 1
19437 GOTO 50
19438 END IF
19439*
19440 IF( myrow.EQ.rdest .AND. mycol.EQ.cdest ) THEN
19441 lda = ldadst
19442 ELSE
19443 lda = ldasrc
19444 END IF
19445 valptr = aptr + ipost + n * lda
19446 IF( verb .GT. 1 ) THEN
19447 IF( iam .EQ. 0 ) THEN
19448 WRITE(outnum, 6000)
19449 $ testnum, 'RUNNING', scope, top, m, n,
19450 $ ldasrc, ldadst, ldi, rdest2, cdest2,
19451 $ nprow, npcol
19452 END IF
19453 END IF
19454*
19455* If I am in scope
19456*
19457 testok = .true.
19458 IF( ingrid ) THEN
19459 IF( (myrow.EQ.rdest .AND. scope.EQ.'R') .OR.
19460 $ (mycol.EQ.cdest .AND. scope.EQ.'C') .OR.
19461 $ (scope .EQ. 'A') ) THEN
19462*
19463 k = nerr
19464 DO 40 itr = itr1, itr2
19465 CALL blacs_set(context, 15, itr)
19466 DO 35 itc = itc1, itc2
19467 CALL blacs_set(context, 16, itc)
19468 DO 30 j = istart, istop
19469 IF( j.EQ.0) GOTO 30
19470 IF( setwhat.NE.0 )
19471 $ CALL blacs_set(context, setwhat, j)
19472*
19473*
19474* generate and pad matrix A
19475*
19476 CALL sinitmat('G','-', m, n, mem(preaptr),
19477 $ lda, ipre, ipost,
19478 $ checkval, testnum,
19479 $ myrow, mycol )
19480*
19481* If they exist, pad RA and CA arrays
19482*
19483 IF( ldi .NE. -1 ) THEN
19484 DO 15 i = 1, n*ldi + ipre + ipost
19485 rmem(i) = icheckval
19486 cmem(i) = icheckval
19487 15 CONTINUE
19488 raptr = 1 + ipre
19489 captr = 1 + ipre
19490 ELSE
19491 DO 20 i = 1, ipre+ipost
19492 rmem(i) = icheckval
19493 cmem(i) = icheckval
19494 20 CONTINUE
19495 raptr = 1
19496 captr = 1
19497 END IF
19498*
19499 CALL sgamn2d(context, scope, top, m, n,
19500 $ mem(aptr), lda, rmem(raptr),
19501 $ cmem(captr), ldi,
19502 $ rdest2, cdest2)
19503*
19504* If I've got the answer, check for errors in
19505* matrix or padding
19506*
19507 IF( (myrow.EQ.rdest .AND. mycol.EQ.cdest)
19508 $ .OR. allrcv ) THEN
19509 CALL schkpad('G','-', m, n,
19510 $ mem(preaptr), lda, rdest,
19511 $ cdest, myrow, mycol,
19512 $ ipre, ipost, checkval,
19513 $ testnum, maxerr, nerr,
19514 $ mem(erriptr),mem(errdptr))
19515 CALL schkamn(scope, context, m, n,
19516 $ mem(aptr), lda,
19517 $ rmem(raptr), cmem(captr),
19518 $ ldi, testnum, maxerr,nerr,
19519 $ mem(erriptr),mem(errdptr),
19520 $ iseed, mem(valptr))
19521 CALL srcchk(ipre, ipost, icheckval,
19522 $ m, n, rmem, cmem, ldi,
19523 $ myrow, mycol, testnum,
19524 $ maxerr, nerr,
19525 $ mem(erriptr), mem(errdptr))
19526 END IF
19527 30 CONTINUE
19528 CALL blacs_set(context, 16, 0)
19529 35 CONTINUE
19530 CALL blacs_set(context, 15, 0)
19531 40 CONTINUE
19532 testok = ( k .EQ. nerr )
19533 END IF
19534 END IF
19535*
19536 IF( verb .GT. 1 ) THEN
19537 i = nerr
19538 CALL sbtcheckin(0, outnum, maxerr, nerr,
19539 $ mem(erriptr), mem(errdptr), iseed)
19540 IF( iam .EQ. 0 ) THEN
19541 IF( testok .AND. nerr.EQ.i ) THEN
19542 WRITE(outnum,6000)testnum,'PASSED ',
19543 $ scope, top, m, n, ldasrc,
19544 $ ldadst, ldi, rdest2, cdest2,
19545 $ nprow, npcol
19546 ELSE
19547 nfail = nfail + 1
19548 WRITE(outnum,6000)testnum,'FAILED ',
19549 $ scope, top, m, n, ldasrc,
19550 $ ldadst, ldi, rdest2, cdest2,
19551 $ nprow, npcol
19552 END IF
19553 END IF
19554*
19555* Once we've printed out errors, can re-use buf space
19556*
19557 nerr = 0
19558 END IF
19559 50 CONTINUE
19560 60 CONTINUE
19561 70 CONTINUE
19562 80 CONTINUE
19563 90 CONTINUE
19564*
19565 IF( verb .LT. 2 ) THEN
19566 nfail = testnum
19567 CALL sbtcheckin( nfail, outnum, maxerr, nerr, mem(erriptr),
19568 $ mem(errdptr), iseed )
19569 END IF
19570 IF( iam .EQ. 0 ) THEN
19571 IF( verb .GT. 1 ) WRITE(outnum,*) ' '
19572 IF( nfail+nskip .EQ. 0 ) THEN
19573 WRITE(outnum, 7000 ) testnum
19574 ELSE
19575 WRITE(outnum, 8000 ) testnum, testnum-nskip-nfail,
19576 $ nskip, nfail
19577 END IF
19578 END IF
19579*
19580* Log whether their were any failures
19581*
19582 testok = allpass( (nfail.EQ.0) )
19583*
19584 1000 FORMAT('REAL AMN TESTS: BEGIN.' )
19585 2000 FORMAT(1x,a7,3x,10i6)
19586 3000 FORMAT(1x,a7,3x,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,
19587 $ 5x,a1,5x,a1)
19588 4000 FORMAT(' TEST# STATUS SCOPE TOP M N LDAS LDAD LDI ',
19589 $ 'RDEST CDEST P Q')
19590 5000 FORMAT(' ----- ------- ----- --- ----- ----- ----- ----- ----- ',
19591 $ '----- ----- ---- ----')
19592 6000 FORMAT(i6,1x,a7,5x,a1,3x,a1,7i6,2i5)
19593 7000 FORMAT('REAL AMN TESTS: PASSED ALL',
19594 $ i5, ' TESTS.')
19595 8000 FORMAT('REAL AMN TESTS:',i5,' TESTS;',i5,' PASSED,',
19596 $ i5,' SKIPPED,',i5,' FAILED.')
19597*
19598 RETURN
19599*
19600* End of STESTAMN.
19601*
19602 END
19603*
19604 SUBROUTINE schkamn( SCOPE, ICTXT, M, N, A, LDA, RA, CA, LDI,
19605 $ TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF,
19606 $ ISEED, VALS )
19607*
19608* .. Scalar Arguments ..
19609 CHARACTER*1 SCOPE
19610 INTEGER ICTXT, M, N, LDA, LDI, TESTNUM, MAXERR, NERR
19611* ..
19612* .. Array Arguments ..
19613 INTEGER RA(*), CA(*), ERRIBUF(6, MAXERR), ISEED(*)
19614 REAL A(LDA,*), ERRDBUF(2, MAXERR), VALS(*)
19615* ..
19616* .. External Functions ..
19617 INTEGER IBTMYPROC, IBTNPROCS, IBTSPNUM
19618 REAL SBTEPS, SBTABS
19619 REAL SBTRAN
19620 EXTERNAL IBTMYPROC, IBTNPROCS, IBTSPNUM, SBTRAN, SBTEPS, SBTABS
19621* ..
19622* .. External Subroutines ..
19623 EXTERNAL ibtspcoord
19624* ..
19625* .. Local Scalars ..
19626 LOGICAL ERROR
19627 INTEGER NPROCS, NNODES, NPROW, NPCOL, MYROW, MYCOL, RAMN, CAMN
19628 INTEGER IAMN, I, J, K, H, DEST, NODE
19629 REAL EPS
19630* ..
19631* .. Executable Statements ..
19632*
19633 NPROCS = ibtnprocs()
19634 eps = sbteps()
19635 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
19636 dest = myrow*nprocs + mycol
19637*
19638* Set up seeds to match those used by each proc's genmat call
19639*
19640 IF( scope .EQ. 'R' ) THEN
19641 nnodes = npcol
19642 DO 10 i = 0, nnodes-1
19643 node = myrow * nprocs + i
19644 iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
19645 iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
19646 iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
19647 iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
19648 10 CONTINUE
19649 ELSE IF( scope .EQ. 'C' ) THEN
19650 nnodes = nprow
19651 DO 20 i = 0, nnodes-1
19652 node = i * nprocs + mycol
19653 iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
19654 iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
19655 iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
19656 iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
19657 20 CONTINUE
19658 ELSE
19659 nnodes = nprow * npcol
19660 DO 30 i = 0, nnodes-1
19661 node = (i / npcol) * nprocs + mod(i, npcol)
19662 iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
19663 iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
19664 iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
19665 iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
19666 30 CONTINUE
19667 END IF
19668*
19669 DO 100 j = 1, n
19670 DO 90 i = 1, m
19671 h = (j-1)*ldi + i
19672 vals(1) = sbtran( iseed )
19673 iamn = 1
19674 IF( nnodes .GT. 1 ) THEN
19675 DO 40 k = 1, nnodes-1
19676 vals(k+1) = sbtran( iseed(k*4+1) )
19677 IF( sbtabs( vals(k+1) ) .LT. sbtabs( vals(iamn) ) )
19678 $ iamn = k + 1
19679 40 CONTINUE
19680 END IF
19681*
19682* If BLACS have not returned same value we've chosen
19683*
19684 IF( a(i,j) .NE. vals(iamn) ) THEN
19685*
19686* If we have RA and CA arrays
19687*
19688 IF( ldi .NE. -1 ) THEN
19689*
19690* Any number having the same absolute value is a valid max
19691*
19692 k = ibtspnum( scope, ra(h), ca(h), npcol ) + 1
19693 IF( k.GT.0 .AND. k.LE.nnodes ) THEN
19694 error = sbtabs( vals(k) ).NE.sbtabs( vals(iamn) )
19695 IF( .NOT.error ) iamn = k
19696 ELSE
19697 error = .true.
19698 END IF
19699 ELSE
19700*
19701* Error if BLACS answer not same absolute value, or if it
19702* was not really in the numbers being compared
19703*
19704 error = ( sbtabs( a(i,j) ) .NE. sbtabs( vals(iamn) ) )
19705 IF( .NOT.error ) THEN
19706 DO 50 k = 1, nnodes
19707 IF( vals(k) .EQ. a(i,j) ) GOTO 60
19708 50 CONTINUE
19709 error = .true.
19710 60 CONTINUE
19711 ENDIF
19712 END IF
19713*
19714* If the value is in error
19715*
19716 IF( error ) THEN
19717 nerr = nerr + 1
19718 erribuf(1, nerr) = testnum
19719 erribuf(2, nerr) = nnodes
19720 erribuf(3, nerr) = dest
19721 erribuf(4, nerr) = i
19722 erribuf(5, nerr) = j
19723 erribuf(6, nerr) = 5
19724 errdbuf(1, nerr) = a(i,j)
19725 errdbuf(2, nerr) = vals(iamn)
19726 END IF
19727 END IF
19728*
19729* If they are defined, make sure coordinate entries are OK
19730*
19731 IF( ldi .NE. -1 ) THEN
19732 k = ibtspnum( scope, ra(h), ca(h), npcol ) + 1
19733 IF( k.NE.iamn ) THEN
19734*
19735* Make sure more than one proc doesn't have exact same value
19736* (and therefore there may be more than one valid coordinate
19737* for a single value)
19738*
19739 IF( k.GT.nnodes .OR. k.LT.1 ) THEN
19740 error = .true.
19741 ELSE
19742 error = ( vals(k) .NE. vals(iamn) )
19743 END IF
19744 IF( error ) THEN
19745 CALL ibtspcoord( scope, iamn-1, myrow, mycol,
19746 $ npcol, ramn, camn )
19747 IF( ramn .NE. ra(h) ) THEN
19748 nerr = nerr + 1
19749 erribuf(1, nerr) = testnum
19750 erribuf(2, nerr) = nnodes
19751 erribuf(3, nerr) = dest
19752 erribuf(4, nerr) = i
19753 erribuf(5, nerr) = j
19754 erribuf(6, nerr) = -5
19755 errdbuf(1, nerr) = ra(h)
19756 errdbuf(2, nerr) = ramn
19757 END IF
19758 IF( camn .NE. ca(h) ) THEN
19759 nerr = nerr + 1
19760 erribuf(1, nerr) = testnum
19761 erribuf(2, nerr) = nnodes
19762 erribuf(3, nerr) = dest
19763 erribuf(4, nerr) = i
19764 erribuf(5, nerr) = j
19765 erribuf(6, nerr) = -15
19766 errdbuf(1, nerr) = ca(h)
19767 errdbuf(2, nerr) = camn
19768 END IF
19769 END IF
19770 END IF
19771 END IF
19772 90 CONTINUE
19773 100 CONTINUE
19774*
19775 RETURN
19776*
19777* End of SCHKAMN
19778*
19779 END
19780*
19781*
19782 SUBROUTINE damntest( OUTNUM, VERB, TOPSREPEAT, TOPSCOHRNT, NSCOPE,
19783 $ SCOPE0, NTOP, TOP0, NMAT, M0, N0, LDAS0,
19784 $ LDAD0, LDI0, NDEST, RDEST0, CDEST0, NGRID,
19785 $ CONTEXT0, P0, Q0, ISEED, RMEM, CMEM, RCLEN,
19786 $ MEM, MEMLEN )
19787*
19788* -- BLACS tester (version 1.0) --
19789* University of Tennessee
19790* December 15, 1994
19791*
19792*
19793* .. Scalar Arguments ..
19794 INTEGER MEMLEN, NDEST, NGRID, NMAT, NSCOPE, NTOP, OUTNUM, RCLEN,
19795 $ TOPSCOHRNT, TOPSREPEAT, VERB
19796* ..
19797* .. Array Arguments ..
19798 CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP)
19799 INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT), LDI0(NMAT)
19800 INTEGER RDEST0(NDEST), CDEST0(NDEST), CONTEXT0(NGRID)
19801 INTEGER P0(NGRID), Q0(NGRID), ISEED(*), RMEM(RCLEN), CMEM(RCLEN)
19802 DOUBLE PRECISION MEM(MEMLEN)
19803* ..
19804*
19805* Purpose
19806* =======
19807* DTESTAMN: Test double precision AMN COMBINE
19808*
19809* Arguments
19810* =========
19811* OUTNUM (input) INTEGER
19812* The device number to write output to.
19813*
19814* VERB (input) INTEGER
19815* The level of verbosity (how much printing to do).
19816*
19817* NSCOPE (input) INTEGER
19818* The number of scopes to be tested.
19819*
19820* SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE)
19821* Values of the scopes to be tested.
19822*
19823* NTOP (input) INTEGER
19824* The number of topologies to be tested.
19825*
19826* TOP0 (input) CHARACTER*1 array of dimension (NTOP)
19827* Values of the topologies to be tested.
19828*
19829* NMAT (input) INTEGER
19830* The number of matrices to be tested.
19831*
19832* M0 (input) INTEGER array of dimension (NMAT)
19833* Values of M to be tested.
19834*
19835* M0 (input) INTEGER array of dimension (NMAT)
19836* Values of M to be tested.
19837*
19838* N0 (input) INTEGER array of dimension (NMAT)
19839* Values of N to be tested.
19840*
19841* LDAS0 (input) INTEGER array of dimension (NMAT)
19842* Values of LDAS (leading dimension of A on source process)
19843* to be tested.
19844*
19845* LDAD0 (input) INTEGER array of dimension (NMAT)
19846* Values of LDAD (leading dimension of A on destination
19847* process) to be tested.
19848* LDI0 (input) INTEGER array of dimension (NMAT)
19849* Values of LDI (leading dimension of RA/CA) to be tested.
19850* If LDI == -1, these RA/CA should not be accessed.
19851*
19852* NDEST (input) INTEGER
19853* The number of destinations to be tested.
19854*
19855* RDEST0 (input) INTEGER array of dimension (NNDEST)
19856* Values of RDEST (row coordinate of destination) to be
19857* tested.
19858*
19859* CDEST0 (input) INTEGER array of dimension (NNDEST)
19860* Values of CDEST (column coordinate of destination) to be
19861* tested.
19862*
19863* NGRID (input) INTEGER
19864* The number of process grids to be tested.
19865*
19866* CONTEXT0 (input) INTEGER array of dimension (NGRID)
19867* The BLACS context handles corresponding to the grids.
19868*
19869* P0 (input) INTEGER array of dimension (NGRID)
19870* Values of P (number of process rows, NPROW).
19871*
19872* Q0 (input) INTEGER array of dimension (NGRID)
19873* Values of Q (number of process columns, NPCOL).
19874*
19875* ISEED (workspace) INTEGER array of dimension ( MAX(NPROCS, NTESTS) )
19876* Workspace used to hold each process's random number SEED.
19877* This requires NPROCS (number of processor) elements.
19878* If VERB < 2, this workspace also serves to indicate which
19879* tests fail. This requires workspace of NTESTS
19880* (number of tests performed).
19881*
19882* RMEM (workspace) INTEGER array of dimension (RCLEN)
19883* Used for all RA arrays, and their pre and post padding.
19884*
19885* CMEM (workspace) INTEGER array of dimension (RCLEN)
19886* Used for all CA arrays, and their pre and post padding.
19887*
19888* RCLEN (input) INTEGER
19889* The length, in elements, of RMEM and CMEM.
19890*
19891* MEM (workspace) DOUBLE PRECISION array of dimension (MEMLEN)
19892* Used for all other workspaces, including the matrix A,
19893* and its pre and post padding.
19894*
19895* MEMLEN (input) INTEGER
19896* The length, in elements, of MEM.
19897*
19898* =====================================================================
19899*
19900* .. External Functions ..
19901 LOGICAL ALLPASS, LSAME
19902 INTEGER IBTMYPROC, IBTNPROCS, IBTSIZEOF
19903 EXTERNAL allpass, lsame, ibtmyproc, ibtnprocs, ibtsizeof
19904* ..
19905* .. External Subroutines ..
19906 EXTERNAL blacs_gridinfo, dgamn2d
19907 EXTERNAL dinitmat, dchkpad, dbtcheckin
19908* ..
19909* .. Local Scalars ..
19910 CHARACTER*1 SCOPE, TOP
19911 LOGICAL INGRID, TESTOK, ALLRCV
19912 INTEGER APTR, CAPTR, CDEST, CDEST2, CONTEXT, DSIZE, ERRDPTR,
19913 $ erriptr, i, iam, icheckval, ide, igr, ima, ipad, ipost,
19914 $ ipre, isc, isize, istart, istop, itc, itc1, itc2, ito,
19915 $ itr, itr1, itr2, j, k, lda, ldadst, ldasrc, ldi, m,
19916 $ maxerr, mycol, myrow, n, nerr, nfail, npcol, nprow, nskip,
19917 $ preaptr, raptr, rdest, rdest2, setwhat, testnum, valptr
19918 DOUBLE PRECISION CHECKVAL
19919* ..
19920* .. Executable Statements ..
19921*
19922* Choose padding value, and make it unique
19923*
19924 checkval = -0.81d0
19925 iam = ibtmyproc()
19926 checkval = iam * checkval
19927 isize = ibtsizeof('I')
19928 dsize = ibtsizeof('D')
19929 icheckval = -iam
19930*
19931* Verify file parameters
19932*
19933 IF( iam .EQ. 0 ) THEN
19934 WRITE(outnum, *) ' '
19935 WRITE(outnum, *) ' '
19936 WRITE(outnum, 1000 )
19937 IF( verb .GT. 0 ) THEN
19938 WRITE(outnum,*) ' '
19939 WRITE(outnum, 2000) 'NSCOPE:', nscope
19940 WRITE(outnum, 3000) ' SCOPE:', ( scope0(i), i = 1, nscope )
19941 WRITE(outnum, 2000) 'TReps :', topsrepeat
19942 WRITE(outnum, 2000) 'TCohr :', topscohrnt
19943 WRITE(outnum, 2000) 'NTOP :', ntop
19944 WRITE(outnum, 3000) ' TOP :', ( top0(i), i = 1, ntop )
19945 WRITE(outnum, 2000) 'NMAT :', nmat
19946 WRITE(outnum, 2000) ' M :', ( m0(i), i = 1, nmat )
19947 WRITE(outnum, 2000) ' N :', ( n0(i), i = 1, nmat )
19948 WRITE(outnum, 2000) ' LDAS :', ( ldas0(i), i = 1, nmat )
19949 WRITE(outnum, 2000) ' LDAD :', ( ldad0(i), i = 1, nmat )
19950 WRITE(outnum, 2000) ' LDI :', ( ldi0(i), i = 1, nmat )
19951 WRITE(outnum, 2000) 'NDEST :', ndest
19952 WRITE(outnum, 2000) ' RDEST:',( rdest0(i), i = 1, ndest )
19953 WRITE(outnum, 2000) ' CDEST:',( cdest0(i), i = 1, ndest )
19954 WRITE(outnum, 2000) 'NGRIDS:', ngrid
19955 WRITE(outnum, 2000) ' P :', ( p0(i), i = 1, ngrid )
19956 WRITE(outnum, 2000) ' Q :', ( q0(i), i = 1, ngrid )
19957 WRITE(outnum, 2000) 'VERB :', verb
19958 WRITE(outnum,*) ' '
19959 END IF
19960 IF( verb .GT. 1 ) THEN
19961 WRITE(outnum,4000)
19962 WRITE(outnum,5000)
19963 END IF
19964 END IF
19965 IF (topsrepeat.EQ.0) THEN
19966 itr1 = 0
19967 itr2 = 0
19968 ELSE IF (topsrepeat.EQ.1) THEN
19969 itr1 = 1
19970 itr2 = 1
19971 ELSE
19972 itr1 = 0
19973 itr2 = 1
19974 END IF
19975*
19976* Find biggest matrix, so we know where to stick error info
19977*
19978 i = 0
19979 DO 10 ima = 1, nmat
19980 ipad = 4 * m0(ima)
19981 k = n0(ima) * max0( ldas0(ima), ldad0(ima) ) + ipad
19982 IF( k .GT. i ) i = k
19983 10 CONTINUE
19984 i = i + ibtnprocs()
19985 maxerr = ( dsize * (memlen-i) ) / ( dsize*2 + isize*6 )
19986 IF( maxerr .LT. 1 ) THEN
19987 WRITE(outnum,*) 'ERROR: Not enough memory to run MIN tests.'
19988 CALL blacs_abort(-1, 1)
19989 END IF
19990 errdptr = i + 1
19991 erriptr = errdptr + maxerr
19992 nerr = 0
19993 testnum = 0
19994 nfail = 0
19995 nskip = 0
19996*
19997* Loop over grids of matrix
19998*
19999 DO 90 igr = 1, ngrid
20000*
20001* allocate process grid for the next batch of tests
20002*
20003 context = context0(igr)
20004 CALL blacs_gridinfo( context, nprow, npcol, myrow, mycol )
20005 ingrid = ( (myrow.LT.nprow) .AND. (mycol.LT.npcol) )
20006*
20007 DO 80 isc = 1, nscope
20008 scope = scope0(isc)
20009 DO 70 ito = 1, ntop
20010 top = top0(ito)
20011*
20012* If testing multiring ('M') or general tree ('T'), need to
20013* loop over calls to BLACS_SET to do full test
20014*
20015 IF( lsame(top, 'M') ) THEN
20016 setwhat = 13
20017 IF( scope .EQ. 'R' ) THEN
20018 istart = -(npcol - 1)
20019 istop = -istart
20020 ELSE IF (scope .EQ. 'C') THEN
20021 istart = -(nprow - 1)
20022 istop = -istart
20023 ELSE
20024 istart = -(nprow*npcol - 1)
20025 istop = -istart
20026 ENDIF
20027 ELSE IF( lsame(top, 'T') ) THEN
20028 setwhat = 14
20029 istart = 1
20030 IF( scope .EQ. 'R' ) THEN
20031 istop = npcol - 1
20032 ELSE IF (scope .EQ. 'C') THEN
20033 istop = nprow - 1
20034 ELSE
20035 istop = nprow*npcol - 1
20036 ENDIF
20037 ELSE
20038 setwhat = 0
20039 istart = 1
20040 istop = 1
20041 ENDIF
20042 DO 60 ima = 1, nmat
20043 m = m0(ima)
20044 n = n0(ima)
20045 ldasrc = ldas0(ima)
20046 ldadst = ldad0(ima)
20047 ldi = ldi0(ima)
20048 ipre = 2 * m
20049 ipost = ipre
20050 preaptr = 1
20051 aptr = preaptr + ipre
20052*
20053 DO 50 ide = 1, ndest
20054 testnum = testnum + 1
20055 rdest2 = rdest0(ide)
20056 cdest2 = cdest0(ide)
20057*
20058* If everyone gets the answer, create some bogus rdest/cdest
20059* so IF's are easier
20060*
20061 allrcv = ( (rdest2.EQ.-1) .OR. (cdest2.EQ.-1) )
20062 IF( allrcv ) THEN
20063 rdest = nprow - 1
20064 cdest = npcol - 1
20065 IF (topscohrnt.EQ.0) THEN
20066 itr1 = 0
20067 itr2 = 0
20068 ELSE IF (topscohrnt.EQ.1) THEN
20069 itr1 = 1
20070 itr2 = 1
20071 ELSE
20072 itr1 = 0
20073 itr2 = 1
20074 END IF
20075 ELSE
20076 rdest = rdest2
20077 cdest = cdest2
20078 itc1 = 0
20079 itc2 = 0
20080 END IF
20081 IF( rdest.GE.p0(igr) .OR. cdest.GE.q0(igr) ) THEN
20082 nskip = nskip + 1
20083 GOTO 50
20084 END IF
20085*
20086 IF( myrow.EQ.rdest .AND. mycol.EQ.cdest ) THEN
20087 lda = ldadst
20088 ELSE
20089 lda = ldasrc
20090 END IF
20091 valptr = aptr + ipost + n * lda
20092 IF( verb .GT. 1 ) THEN
20093 IF( iam .EQ. 0 ) THEN
20094 WRITE(outnum, 6000)
20095 $ testnum, 'RUNNING', scope, top, m, n,
20096 $ ldasrc, ldadst, ldi, rdest2, cdest2,
20097 $ nprow, npcol
20098 END IF
20099 END IF
20100*
20101* If I am in scope
20102*
20103 testok = .true.
20104 IF( ingrid ) THEN
20105 IF( (myrow.EQ.rdest .AND. scope.EQ.'R') .OR.
20106 $ (mycol.EQ.cdest .AND. scope.EQ.'C') .OR.
20107 $ (scope .EQ. 'A') ) THEN
20108*
20109 k = nerr
20110 DO 40 itr = itr1, itr2
20111 CALL blacs_set(context, 15, itr)
20112 DO 35 itc = itc1, itc2
20113 CALL blacs_set(context, 16, itc)
20114 DO 30 j = istart, istop
20115 IF( j.EQ.0) GOTO 30
20116 IF( setwhat.NE.0 )
20117 $ CALL blacs_set(context, setwhat, j)
20118*
20119*
20120* generate and pad matrix A
20121*
20122 CALL dinitmat('G','-', m, n, mem(preaptr),
20123 $ lda, ipre, ipost,
20124 $ checkval, testnum,
20125 $ myrow, mycol )
20126*
20127* If they exist, pad RA and CA arrays
20128*
20129 IF( ldi .NE. -1 ) THEN
20130 DO 15 i = 1, n*ldi + ipre + ipost
20131 rmem(i) = icheckval
20132 cmem(i) = icheckval
20133 15 CONTINUE
20134 raptr = 1 + ipre
20135 captr = 1 + ipre
20136 ELSE
20137 DO 20 i = 1, ipre+ipost
20138 rmem(i) = icheckval
20139 cmem(i) = icheckval
20140 20 CONTINUE
20141 raptr = 1
20142 captr = 1
20143 END IF
20144*
20145 CALL dgamn2d(context, scope, top, m, n,
20146 $ mem(aptr), lda, rmem(raptr),
20147 $ cmem(captr), ldi,
20148 $ rdest2, cdest2)
20149*
20150* If I've got the answer, check for errors in
20151* matrix or padding
20152*
20153 IF( (myrow.EQ.rdest .AND. mycol.EQ.cdest)
20154 $ .OR. allrcv ) THEN
20155 CALL dchkpad('G','-', m, n,
20156 $ mem(preaptr), lda, rdest,
20157 $ cdest, myrow, mycol,
20158 $ ipre, ipost, checkval,
20159 $ testnum, maxerr, nerr,
20160 $ mem(erriptr),mem(errdptr))
20161 CALL dchkamn(scope, context, m, n,
20162 $ mem(aptr), lda,
20163 $ rmem(raptr), cmem(captr),
20164 $ ldi, testnum, maxerr,nerr,
20165 $ mem(erriptr),mem(errdptr),
20166 $ iseed, mem(valptr))
20167 CALL drcchk(ipre, ipost, icheckval,
20168 $ m, n, rmem, cmem, ldi,
20169 $ myrow, mycol, testnum,
20170 $ maxerr, nerr,
20171 $ mem(erriptr), mem(errdptr))
20172 END IF
20173 30 CONTINUE
20174 CALL blacs_set(context, 16, 0)
20175 35 CONTINUE
20176 CALL blacs_set(context, 15, 0)
20177 40 CONTINUE
20178 testok = ( k .EQ. nerr )
20179 END IF
20180 END IF
20181*
20182 IF( verb .GT. 1 ) THEN
20183 i = nerr
20184 CALL dbtcheckin(0, outnum, maxerr, nerr,
20185 $ mem(erriptr), mem(errdptr), iseed)
20186 IF( iam .EQ. 0 ) THEN
20187 IF( testok .AND. nerr.EQ.i ) THEN
20188 WRITE(outnum,6000)testnum,'PASSED ',
20189 $ scope, top, m, n, ldasrc,
20190 $ ldadst, ldi, rdest2, cdest2,
20191 $ nprow, npcol
20192 ELSE
20193 nfail = nfail + 1
20194 WRITE(outnum,6000)testnum,'FAILED ',
20195 $ scope, top, m, n, ldasrc,
20196 $ ldadst, ldi, rdest2, cdest2,
20197 $ nprow, npcol
20198 END IF
20199 END IF
20200*
20201* Once we've printed out errors, can re-use buf space
20202*
20203 nerr = 0
20204 END IF
20205 50 CONTINUE
20206 60 CONTINUE
20207 70 CONTINUE
20208 80 CONTINUE
20209 90 CONTINUE
20210*
20211 IF( verb .LT. 2 ) THEN
20212 nfail = testnum
20213 CALL dbtcheckin( nfail, outnum, maxerr, nerr, mem(erriptr),
20214 $ mem(errdptr), iseed )
20215 END IF
20216 IF( iam .EQ. 0 ) THEN
20217 IF( verb .GT. 1 ) WRITE(outnum,*) ' '
20218 IF( nfail+nskip .EQ. 0 ) THEN
20219 WRITE(outnum, 7000 ) testnum
20220 ELSE
20221 WRITE(outnum, 8000 ) testnum, testnum-nskip-nfail,
20222 $ nskip, nfail
20223 END IF
20224 END IF
20225*
20226* Log whether their were any failures
20227*
20228 testok = allpass( (nfail.EQ.0) )
20229*
20230 1000 FORMAT('DOUBLE PRECISION AMN TESTS: BEGIN.' )
20231 2000 FORMAT(1x,a7,3x,10i6)
20232 3000 FORMAT(1x,a7,3x,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,
20233 $ 5x,a1,5x,a1)
20234 4000 FORMAT(' TEST# STATUS SCOPE TOP M N LDAS LDAD LDI ',
20235 $ 'RDEST CDEST P Q')
20236 5000 FORMAT(' ----- ------- ----- --- ----- ----- ----- ----- ----- ',
20237 $ '----- ----- ---- ----')
20238 6000 FORMAT(i6,1x,a7,5x,a1,3x,a1,7i6,2i5)
20239 7000 FORMAT('DOUBLE PRECISION AMN TESTS: PASSED ALL',
20240 $ i5, ' TESTS.')
20241 8000 FORMAT('DOUBLE PRECISION AMN TESTS:',i5,' TESTS;',i5,' PASSED,',
20242 $ i5,' SKIPPED,',i5,' FAILED.')
20243*
20244 RETURN
20245*
20246* End of DTESTAMN.
20247*
20248 END
20249*
20250 SUBROUTINE dchkamn( SCOPE, ICTXT, M, N, A, LDA, RA, CA, LDI,
20251 $ TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF,
20252 $ ISEED, VALS )
20253*
20254* .. Scalar Arguments ..
20255 CHARACTER*1 SCOPE
20256 INTEGER ICTXT, M, N, LDA, LDI, TESTNUM, MAXERR, NERR
20257* ..
20258* .. Array Arguments ..
20259 INTEGER RA(*), CA(*), ERRIBUF(6, MAXERR), ISEED(*)
20260 DOUBLE PRECISION A(LDA,*), ERRDBUF(2, MAXERR), VALS(*)
20261* ..
20262* .. External Functions ..
20263 INTEGER IBTMYPROC, IBTNPROCS, IBTSPNUM
20264 DOUBLE PRECISION DBTEPS, DBTABS
20265 DOUBLE PRECISION DBTRAN
20266 EXTERNAL IBTMYPROC, IBTNPROCS, IBTSPNUM, DBTRAN, DBTEPS, DBTABS
20267* ..
20268* .. External Subroutines ..
20269 EXTERNAL ibtspcoord
20270* ..
20271* .. Local Scalars ..
20272 LOGICAL ERROR
20273 INTEGER NPROCS, NNODES, NPROW, NPCOL, MYROW, MYCOL, RAMN, CAMN
20274 INTEGER IAMN, I, J, K, H, DEST, NODE
20275 DOUBLE PRECISION EPS
20276* ..
20277* .. Executable Statements ..
20278*
20279 nprocs = ibtnprocs()
20280 eps = dbteps()
20281 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
20282 dest = myrow*nprocs + mycol
20283*
20284* Set up seeds to match those used by each proc's genmat call
20285*
20286 IF( scope .EQ. 'R' ) THEN
20287 nnodes = npcol
20288 DO 10 i = 0, nnodes-1
20289 node = myrow * nprocs + i
20290 iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
20291 iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
20292 iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
20293 iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
20294 10 CONTINUE
20295 ELSE IF( scope .EQ. 'C' ) THEN
20296 nnodes = nprow
20297 DO 20 i = 0, nnodes-1
20298 node = i * nprocs + mycol
20299 iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
20300 iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
20301 iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
20302 iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
20303 20 CONTINUE
20304 ELSE
20305 nnodes = nprow * npcol
20306 DO 30 i = 0, nnodes-1
20307 node = (i / npcol) * nprocs + mod(i, npcol)
20308 iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
20309 iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
20310 iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
20311 iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
20312 30 CONTINUE
20313 END IF
20314*
20315 DO 100 j = 1, n
20316 DO 90 i = 1, m
20317 h = (j-1)*ldi + i
20318 vals(1) = dbtran( iseed )
20319 iamn = 1
20320 IF( nnodes .GT. 1 ) THEN
20321 DO 40 k = 1, nnodes-1
20322 vals(k+1) = dbtran( iseed(k*4+1) )
20323 IF( dbtabs( vals(k+1) ) .LT. dbtabs( vals(iamn) ) )
20324 $ iamn = k + 1
20325 40 CONTINUE
20326 END IF
20327*
20328* If BLACS have not returned same value we've chosen
20329*
20330 IF( a(i,j) .NE. vals(iamn) ) THEN
20331*
20332* If we have RA and CA arrays
20333*
20334 IF( ldi .NE. -1 ) THEN
20335*
20336* Any number having the same absolute value is a valid max
20337*
20338 k = ibtspnum( scope, ra(h), ca(h), npcol ) + 1
20339 IF( k.GT.0 .AND. k.LE.nnodes ) THEN
20340 error = dbtabs( vals(k) ).NE.dbtabs( vals(iamn) )
20341 IF( .NOT.error ) iamn = k
20342 ELSE
20343 error = .true.
20344 END IF
20345 ELSE
20346*
20347* Error if BLACS answer not same absolute value, or if it
20348* was not really in the numbers being compared
20349*
20350 error = ( dbtabs( a(i,j) ) .NE. dbtabs( vals(iamn) ) )
20351 IF( .NOT.error ) THEN
20352 DO 50 k = 1, nnodes
20353 IF( vals(k) .EQ. a(i,j) ) GOTO 60
20354 50 CONTINUE
20355 error = .true.
20356 60 CONTINUE
20357 ENDIF
20358 END IF
20359*
20360* If the value is in error
20361*
20362 IF( error ) THEN
20363 nerr = nerr + 1
20364 erribuf(1, nerr) = testnum
20365 erribuf(2, nerr) = nnodes
20366 erribuf(3, nerr) = dest
20367 erribuf(4, nerr) = i
20368 erribuf(5, nerr) = j
20369 erribuf(6, nerr) = 5
20370 errdbuf(1, nerr) = a(i,j)
20371 errdbuf(2, nerr) = vals(iamn)
20372 END IF
20373 END IF
20374*
20375* If they are defined, make sure coordinate entries are OK
20376*
20377 IF( ldi .NE. -1 ) THEN
20378 k = ibtspnum( scope, ra(h), ca(h), npcol ) + 1
20379 IF( k.NE.iamn ) THEN
20380*
20381* Make sure more than one proc doesn't have exact same value
20382* (and therefore there may be more than one valid coordinate
20383* for a single value)
20384*
20385 IF( k.GT.nnodes .OR. k.LT.1 ) THEN
20386 error = .true.
20387 ELSE
20388 error = ( vals(k) .NE. vals(iamn) )
20389 END IF
20390 IF( error ) THEN
20391 CALL ibtspcoord( scope, iamn-1, myrow, mycol,
20392 $ npcol, ramn, camn )
20393 IF( ramn .NE. ra(h) ) THEN
20394 nerr = nerr + 1
20395 erribuf(1, nerr) = testnum
20396 erribuf(2, nerr) = nnodes
20397 erribuf(3, nerr) = dest
20398 erribuf(4, nerr) = i
20399 erribuf(5, nerr) = j
20400 erribuf(6, nerr) = -5
20401 errdbuf(1, nerr) = ra(h)
20402 errdbuf(2, nerr) = ramn
20403 END IF
20404 IF( camn .NE. ca(h) ) THEN
20405 nerr = nerr + 1
20406 erribuf(1, nerr) = testnum
20407 erribuf(2, nerr) = nnodes
20408 erribuf(3, nerr) = dest
20409 erribuf(4, nerr) = i
20410 erribuf(5, nerr) = j
20411 erribuf(6, nerr) = -15
20412 errdbuf(1, nerr) = ca(h)
20413 errdbuf(2, nerr) = camn
20414 END IF
20415 END IF
20416 END IF
20417 END IF
20418 90 CONTINUE
20419 100 CONTINUE
20420*
20421 RETURN
20422*
20423* End of DCHKAMN
20424*
20425 END
20426*
20427*
20428 SUBROUTINE camntest( OUTNUM, VERB, TOPSREPEAT, TOPSCOHRNT, NSCOPE,
20429 $ SCOPE0, NTOP, TOP0, NMAT, M0, N0, LDAS0,
20430 $ LDAD0, LDI0, NDEST, RDEST0, CDEST0, NGRID,
20431 $ CONTEXT0, P0, Q0, ISEED, RMEM, CMEM, RCLEN,
20432 $ MEM, MEMLEN )
20433*
20434* -- BLACS tester (version 1.0) --
20435* University of Tennessee
20436* December 15, 1994
20437*
20438*
20439* .. Scalar Arguments ..
20440 INTEGER MEMLEN, NDEST, NGRID, NMAT, NSCOPE, NTOP, OUTNUM, RCLEN,
20441 $ topscohrnt, topsrepeat, verb
20442* ..
20443* .. Array Arguments ..
20444 CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP)
20445 INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT), LDI0(NMAT)
20446 INTEGER RDEST0(NDEST), CDEST0(NDEST), CONTEXT0(NGRID)
20447 INTEGER P0(NGRID), Q0(NGRID), ISEED(*), RMEM(RCLEN), CMEM(RCLEN)
20448 COMPLEX MEM(MEMLEN)
20449* ..
20450*
20451* Purpose
20452* =======
20453* CTESTAMN: Test complex AMN COMBINE
20454*
20455* Arguments
20456* =========
20457* OUTNUM (input) INTEGER
20458* The device number to write output to.
20459*
20460* VERB (input) INTEGER
20461* The level of verbosity (how much printing to do).
20462*
20463* NSCOPE (input) INTEGER
20464* The number of scopes to be tested.
20465*
20466* SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE)
20467* Values of the scopes to be tested.
20468*
20469* NTOP (input) INTEGER
20470* The number of topologies to be tested.
20471*
20472* TOP0 (input) CHARACTER*1 array of dimension (NTOP)
20473* Values of the topologies to be tested.
20474*
20475* NMAT (input) INTEGER
20476* The number of matrices to be tested.
20477*
20478* M0 (input) INTEGER array of dimension (NMAT)
20479* Values of M to be tested.
20480*
20481* M0 (input) INTEGER array of dimension (NMAT)
20482* Values of M to be tested.
20483*
20484* N0 (input) INTEGER array of dimension (NMAT)
20485* Values of N to be tested.
20486*
20487* LDAS0 (input) INTEGER array of dimension (NMAT)
20488* Values of LDAS (leading dimension of A on source process)
20489* to be tested.
20490*
20491* LDAD0 (input) INTEGER array of dimension (NMAT)
20492* Values of LDAD (leading dimension of A on destination
20493* process) to be tested.
20494* LDI0 (input) INTEGER array of dimension (NMAT)
20495* Values of LDI (leading dimension of RA/CA) to be tested.
20496* If LDI == -1, these RA/CA should not be accessed.
20497*
20498* NDEST (input) INTEGER
20499* The number of destinations to be tested.
20500*
20501* RDEST0 (input) INTEGER array of dimension (NNDEST)
20502* Values of RDEST (row coordinate of destination) to be
20503* tested.
20504*
20505* CDEST0 (input) INTEGER array of dimension (NNDEST)
20506* Values of CDEST (column coordinate of destination) to be
20507* tested.
20508*
20509* NGRID (input) INTEGER
20510* The number of process grids to be tested.
20511*
20512* CONTEXT0 (input) INTEGER array of dimension (NGRID)
20513* The BLACS context handles corresponding to the grids.
20514*
20515* P0 (input) INTEGER array of dimension (NGRID)
20516* Values of P (number of process rows, NPROW).
20517*
20518* Q0 (input) INTEGER array of dimension (NGRID)
20519* Values of Q (number of process columns, NPCOL).
20520*
20521* ISEED (workspace) INTEGER array of dimension ( MAX(NPROCS, NTESTS) )
20522* Workspace used to hold each process's random number SEED.
20523* This requires NPROCS (number of processor) elements.
20524* If VERB < 2, this workspace also serves to indicate which
20525* tests fail. This requires workspace of NTESTS
20526* (number of tests performed).
20527*
20528* RMEM (workspace) INTEGER array of dimension (RCLEN)
20529* Used for all RA arrays, and their pre and post padding.
20530*
20531* CMEM (workspace) INTEGER array of dimension (RCLEN)
20532* Used for all CA arrays, and their pre and post padding.
20533*
20534* RCLEN (input) INTEGER
20535* The length, in elements, of RMEM and CMEM.
20536*
20537* MEM (workspace) COMPLEX array of dimension (MEMLEN)
20538* Used for all other workspaces, including the matrix A,
20539* and its pre and post padding.
20540*
20541* MEMLEN (input) INTEGER
20542* The length, in elements, of MEM.
20543*
20544* =====================================================================
20545*
20546* .. External Functions ..
20547 LOGICAL ALLPASS, LSAME
20548 INTEGER IBTMYPROC, IBTNPROCS, IBTSIZEOF
20549 EXTERNAL ALLPASS, LSAME, IBTMYPROC, IBTNPROCS, IBTSIZEOF
20550* ..
20551* .. External Subroutines ..
20552 EXTERNAL BLACS_GRIDINFO, CGAMN2D
20553 EXTERNAL CINITMAT, CCHKPAD, CBTCHECKIN
20554* ..
20555* .. Local Scalars ..
20556 CHARACTER*1 SCOPE, TOP
20557 LOGICAL INGRID, TESTOK, ALLRCV
20558 INTEGER APTR, CAPTR, CDEST, CDEST2, CONTEXT, CSIZE, ERRDPTR,
20559 $ erriptr, i, iam, icheckval, ide, igr, ima, ipad, ipost,
20560 $ ipre, isc, isize, istart, istop, itc, itc1, itc2, ito,
20561 $ itr, itr1, itr2, j, k, lda, ldadst, ldasrc, ldi, m,
20562 $ maxerr, mycol, myrow, n, nerr, nfail, npcol, nprow, nskip,
20563 $ preaptr, raptr, rdest, rdest2, setwhat, testnum, valptr
20564 COMPLEX CHECKVAL
20565* ..
20566* .. Executable Statements ..
20567*
20568* Choose padding value, and make it unique
20569*
20570 checkval = cmplx( -0.91e0, -0.71e0 )
20571 iam = ibtmyproc()
20572 checkval = iam * checkval
20573 isize = ibtsizeof('I')
20574 csize = ibtsizeof('C')
20575 icheckval = -iam
20576*
20577* Verify file parameters
20578*
20579 IF( iam .EQ. 0 ) THEN
20580 WRITE(outnum, *) ' '
20581 WRITE(outnum, *) ' '
20582 WRITE(outnum, 1000 )
20583 IF( verb .GT. 0 ) THEN
20584 WRITE(outnum,*) ' '
20585 WRITE(outnum, 2000) 'NSCOPE:', nscope
20586 WRITE(outnum, 3000) ' SCOPE:', ( scope0(i), i = 1, nscope )
20587 WRITE(outnum, 2000) 'TReps :', topsrepeat
20588 WRITE(outnum, 2000) 'TCohr :', topscohrnt
20589 WRITE(outnum, 2000) 'NTOP :', ntop
20590 WRITE(outnum, 3000) ' TOP :', ( top0(i), i = 1, ntop )
20591 WRITE(outnum, 2000) 'NMAT :', nmat
20592 WRITE(outnum, 2000) ' M :', ( m0(i), i = 1, nmat )
20593 WRITE(outnum, 2000) ' N :', ( n0(i), i = 1, nmat )
20594 WRITE(outnum, 2000) ' LDAS :', ( ldas0(i), i = 1, nmat )
20595 WRITE(outnum, 2000) ' LDAD :', ( ldad0(i), i = 1, nmat )
20596 WRITE(outnum, 2000) ' LDI :', ( ldi0(i), i = 1, nmat )
20597 WRITE(outnum, 2000) 'NDEST :', ndest
20598 WRITE(outnum, 2000) ' RDEST:',( rdest0(i), i = 1, ndest )
20599 WRITE(outnum, 2000) ' CDEST:',( cdest0(i), i = 1, ndest )
20600 WRITE(outnum, 2000) 'NGRIDS:', ngrid
20601 WRITE(outnum, 2000) ' P :', ( p0(i), i = 1, ngrid )
20602 WRITE(outnum, 2000) ' Q :', ( q0(i), i = 1, ngrid )
20603 WRITE(outnum, 2000) 'VERB :', verb
20604 WRITE(outnum,*) ' '
20605 END IF
20606 IF( verb .GT. 1 ) THEN
20607 WRITE(outnum,4000)
20608 WRITE(outnum,5000)
20609 END IF
20610 END IF
20611 IF (topsrepeat.EQ.0) THEN
20612 itr1 = 0
20613 itr2 = 0
20614 ELSE IF (topsrepeat.EQ.1) THEN
20615 itr1 = 1
20616 itr2 = 1
20617 ELSE
20618 itr1 = 0
20619 itr2 = 1
20620 END IF
20621*
20622* Find biggest matrix, so we know where to stick error info
20623*
20624 i = 0
20625 DO 10 ima = 1, nmat
20626 ipad = 4 * m0(ima)
20627 k = n0(ima) * max0( ldas0(ima), ldad0(ima) ) + ipad
20628 IF( k .GT. i ) i = k
20629 10 CONTINUE
20630 i = i + ibtnprocs()
20631 maxerr = ( csize * (memlen-i) ) / ( csize*2 + isize*6 )
20632 IF( maxerr .LT. 1 ) THEN
20633 WRITE(outnum,*) 'ERROR: Not enough memory to run MIN tests.'
20634 CALL blacs_abort(-1, 1)
20635 END IF
20636 errdptr = i + 1
20637 erriptr = errdptr + maxerr
20638 nerr = 0
20639 testnum = 0
20640 nfail = 0
20641 nskip = 0
20642*
20643* Loop over grids of matrix
20644*
20645 DO 90 igr = 1, ngrid
20646*
20647* allocate process grid for the next batch of tests
20648*
20649 context = context0(igr)
20650 CALL blacs_gridinfo( context, nprow, npcol, myrow, mycol )
20651 ingrid = ( (myrow.LT.nprow) .AND. (mycol.LT.npcol) )
20652*
20653 DO 80 isc = 1, nscope
20654 scope = scope0(isc)
20655 DO 70 ito = 1, ntop
20656 top = top0(ito)
20657*
20658* If testing multiring ('M') or general tree ('T'), need to
20659* loop over calls to BLACS_SET to do full test
20660*
20661 IF( lsame(top, 'M') ) THEN
20662 setwhat = 13
20663 IF( scope .EQ. 'R' ) THEN
20664 istart = -(npcol - 1)
20665 istop = -istart
20666 ELSE IF (scope .EQ. 'C') THEN
20667 istart = -(nprow - 1)
20668 istop = -istart
20669 ELSE
20670 istart = -(nprow*npcol - 1)
20671 istop = -istart
20672 ENDIF
20673 ELSE IF( lsame(top, 'T') ) THEN
20674 setwhat = 14
20675 istart = 1
20676 IF( scope .EQ. 'R' ) THEN
20677 istop = npcol - 1
20678 ELSE IF (scope .EQ. 'C') THEN
20679 istop = nprow - 1
20680 ELSE
20681 istop = nprow*npcol - 1
20682 ENDIF
20683 ELSE
20684 setwhat = 0
20685 istart = 1
20686 istop = 1
20687 ENDIF
20688 DO 60 ima = 1, nmat
20689 m = m0(ima)
20690 n = n0(ima)
20691 ldasrc = ldas0(ima)
20692 ldadst = ldad0(ima)
20693 ldi = ldi0(ima)
20694 ipre = 2 * m
20695 ipost = ipre
20696 preaptr = 1
20697 aptr = preaptr + ipre
20698*
20699 DO 50 ide = 1, ndest
20700 testnum = testnum + 1
20701 rdest2 = rdest0(ide)
20702 cdest2 = cdest0(ide)
20703*
20704* If everyone gets the answer, create some bogus rdest/cdest
20705* so IF's are easier
20706*
20707 allrcv = ( (rdest2.EQ.-1) .OR. (cdest2.EQ.-1) )
20708 IF( allrcv ) THEN
20709 rdest = nprow - 1
20710 cdest = npcol - 1
20711 IF (topscohrnt.EQ.0) THEN
20712 itr1 = 0
20713 itr2 = 0
20714 ELSE IF (topscohrnt.EQ.1) THEN
20715 itr1 = 1
20716 itr2 = 1
20717 ELSE
20718 itr1 = 0
20719 itr2 = 1
20720 END IF
20721 ELSE
20722 rdest = rdest2
20723 cdest = cdest2
20724 itc1 = 0
20725 itc2 = 0
20726 END IF
20727 IF( rdest.GE.p0(igr) .OR. cdest.GE.q0(igr) ) THEN
20728 nskip = nskip + 1
20729 GOTO 50
20730 END IF
20731*
20732 IF( myrow.EQ.rdest .AND. mycol.EQ.cdest ) THEN
20733 lda = ldadst
20734 ELSE
20735 lda = ldasrc
20736 END IF
20737 valptr = aptr + ipost + n * lda
20738 IF( verb .GT. 1 ) THEN
20739 IF( iam .EQ. 0 ) THEN
20740 WRITE(outnum, 6000)
20741 $ testnum, 'RUNNING', scope, top, m, n,
20742 $ ldasrc, ldadst, ldi, rdest2, cdest2,
20743 $ nprow, npcol
20744 END IF
20745 END IF
20746*
20747* If I am in scope
20748*
20749 testok = .true.
20750 IF( ingrid ) THEN
20751 IF( (myrow.EQ.rdest .AND. scope.EQ.'R') .OR.
20752 $ (mycol.EQ.cdest .AND. scope.EQ.'C') .OR.
20753 $ (scope .EQ. 'A') ) THEN
20754*
20755 k = nerr
20756 DO 40 itr = itr1, itr2
20757 CALL blacs_set(context, 15, itr)
20758 DO 35 itc = itc1, itc2
20759 CALL blacs_set(context, 16, itc)
20760 DO 30 j = istart, istop
20761 IF( j.EQ.0) GOTO 30
20762 IF( setwhat.NE.0 )
20763 $ CALL blacs_set(context, setwhat, j)
20764*
20765*
20766* generate and pad matrix A
20767*
20768 CALL cinitmat('G','-', m, n, mem(preaptr),
20769 $ lda, ipre, ipost,
20770 $ checkval, testnum,
20771 $ myrow, mycol )
20772*
20773* If they exist, pad RA and CA arrays
20774*
20775 IF( ldi .NE. -1 ) THEN
20776 DO 15 i = 1, n*ldi + ipre + ipost
20777 rmem(i) = icheckval
20778 cmem(i) = icheckval
20779 15 CONTINUE
20780 raptr = 1 + ipre
20781 captr = 1 + ipre
20782 ELSE
20783 DO 20 i = 1, ipre+ipost
20784 rmem(i) = icheckval
20785 cmem(i) = icheckval
20786 20 CONTINUE
20787 raptr = 1
20788 captr = 1
20789 END IF
20790*
20791 CALL cgamn2d(context, scope, top, m, n,
20792 $ mem(aptr), lda, rmem(raptr),
20793 $ cmem(captr), ldi,
20794 $ rdest2, cdest2)
20795*
20796* If I've got the answer, check for errors in
20797* matrix or padding
20798*
20799 IF( (myrow.EQ.rdest .AND. mycol.EQ.cdest)
20800 $ .OR. allrcv ) THEN
20801 CALL cchkpad('G','-', m, n,
20802 $ mem(preaptr), lda, rdest,
20803 $ cdest, myrow, mycol,
20804 $ ipre, ipost, checkval,
20805 $ testnum, maxerr, nerr,
20806 $ mem(erriptr),mem(errdptr))
20807 CALL cchkamn(scope, context, m, n,
20808 $ mem(aptr), lda,
20809 $ rmem(raptr), cmem(captr),
20810 $ ldi, testnum, maxerr,nerr,
20811 $ mem(erriptr),mem(errdptr),
20812 $ iseed, mem(valptr))
20813 CALL crcchk(ipre, ipost, icheckval,
20814 $ m, n, rmem, cmem, ldi,
20815 $ myrow, mycol, testnum,
20816 $ maxerr, nerr,
20817 $ mem(erriptr), mem(errdptr))
20818 END IF
20819 30 CONTINUE
20820 CALL blacs_set(context, 16, 0)
20821 35 CONTINUE
20822 CALL blacs_set(context, 15, 0)
20823 40 CONTINUE
20824 testok = ( k .EQ. nerr )
20825 END IF
20826 END IF
20827*
20828 IF( verb .GT. 1 ) THEN
20829 i = nerr
20830 CALL cbtcheckin(0, outnum, maxerr, nerr,
20831 $ mem(erriptr), mem(errdptr), iseed)
20832 IF( iam .EQ. 0 ) THEN
20833 IF( testok .AND. nerr.EQ.i ) THEN
20834 WRITE(outnum,6000)testnum,'PASSED ',
20835 $ scope, top, m, n, ldasrc,
20836 $ ldadst, ldi, rdest2, cdest2,
20837 $ nprow, npcol
20838 ELSE
20839 nfail = nfail + 1
20840 WRITE(outnum,6000)testnum,'FAILED ',
20841 $ scope, top, m, n, ldasrc,
20842 $ ldadst, ldi, rdest2, cdest2,
20843 $ nprow, npcol
20844 END IF
20845 END IF
20846*
20847* Once we've printed out errors, can re-use buf space
20848*
20849 nerr = 0
20850 END IF
20851 50 CONTINUE
20852 60 CONTINUE
20853 70 CONTINUE
20854 80 CONTINUE
20855 90 CONTINUE
20856*
20857 IF( verb .LT. 2 ) THEN
20858 nfail = testnum
20859 CALL cbtcheckin( nfail, outnum, maxerr, nerr, mem(erriptr),
20860 $ mem(errdptr), iseed )
20861 END IF
20862 IF( iam .EQ. 0 ) THEN
20863 IF( verb .GT. 1 ) WRITE(outnum,*) ' '
20864 IF( nfail+nskip .EQ. 0 ) THEN
20865 WRITE(outnum, 7000 ) testnum
20866 ELSE
20867 WRITE(outnum, 8000 ) testnum, testnum-nskip-nfail,
20868 $ nskip, nfail
20869 END IF
20870 END IF
20871*
20872* Log whether their were any failures
20873*
20874 testok = allpass( (nfail.EQ.0) )
20875*
20876 1000 FORMAT('COMPLEX AMN TESTS: BEGIN.' )
20877 2000 FORMAT(1x,a7,3x,10i6)
20878 3000 FORMAT(1x,a7,3x,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,
20879 $ 5x,a1,5x,a1)
20880 4000 FORMAT(' TEST# STATUS SCOPE TOP M N LDAS LDAD LDI ',
20881 $ 'RDEST CDEST P Q')
20882 5000 FORMAT(' ----- ------- ----- --- ----- ----- ----- ----- ----- ',
20883 $ '----- ----- ---- ----')
20884 6000 FORMAT(i6,1x,a7,5x,a1,3x,a1,7i6,2i5)
20885 7000 FORMAT('COMPLEX AMN TESTS: PASSED ALL',
20886 $ i5, ' TESTS.')
20887 8000 FORMAT('COMPLEX AMN TESTS:',i5,' TESTS;',i5,' PASSED,',
20888 $ i5,' SKIPPED,',i5,' FAILED.')
20889*
20890 RETURN
20891*
20892* End of CTESTAMN.
20893*
20894 END
20895*
20896 SUBROUTINE cchkamn( SCOPE, ICTXT, M, N, A, LDA, RA, CA, LDI,
20897 $ TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF,
20898 $ ISEED, VALS )
20899*
20900* .. Scalar Arguments ..
20901 CHARACTER*1 SCOPE
20902 INTEGER ICTXT, M, N, LDA, LDI, TESTNUM, MAXERR, NERR
20903* ..
20904* .. Array Arguments ..
20905 INTEGER RA(*), CA(*), ERRIBUF(6, MAXERR), ISEED(*)
20906 COMPLEX A(LDA,*), ERRDBUF(2, MAXERR), VALS(*)
20907* ..
20908* .. External Functions ..
20909 INTEGER IBTMYPROC, IBTNPROCS, IBTSPNUM
20910 REAL SBTEPS, CBTABS
20911 COMPLEX CBTRAN
20912 EXTERNAL IBTMYPROC, IBTNPROCS, IBTSPNUM, CBTRAN, SBTEPS, CBTABS
20913* ..
20914* .. External Subroutines ..
20915 EXTERNAL ibtspcoord
20916* ..
20917* .. Local Scalars ..
20918 LOGICAL ERROR
20919 INTEGER NPROCS, NNODES, NPROW, NPCOL, MYROW, MYCOL, RAMN, CAMN
20920 INTEGER IAMN, I, J, K, H, DEST, NODE
20921 REAL EPS
20922* ..
20923* .. Executable Statements ..
20924*
20925 nprocs = ibtnprocs()
20926 eps = sbteps()
20927 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
20928 dest = myrow*nprocs + mycol
20929*
20930* Set up seeds to match those used by each proc's genmat call
20931*
20932 IF( scope .EQ. 'R' ) THEN
20933 nnodes = npcol
20934 DO 10 i = 0, nnodes-1
20935 node = myrow * nprocs + i
20936 iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
20937 iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
20938 iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
20939 iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
20940 10 CONTINUE
20941 ELSE IF( scope .EQ. 'C' ) THEN
20942 nnodes = nprow
20943 DO 20 i = 0, nnodes-1
20944 node = i * nprocs + mycol
20945 iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
20946 iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
20947 iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
20948 iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
20949 20 CONTINUE
20950 ELSE
20951 nnodes = nprow * npcol
20952 DO 30 i = 0, nnodes-1
20953 node = (i / npcol) * nprocs + mod(i, npcol)
20954 iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
20955 iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
20956 iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
20957 iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
20958 30 CONTINUE
20959 END IF
20960*
20961 DO 100 j = 1, n
20962 DO 90 i = 1, m
20963 h = (j-1)*ldi + i
20964 vals(1) = cbtran( iseed )
20965 iamn = 1
20966 IF( nnodes .GT. 1 ) THEN
20967 DO 40 k = 1, nnodes-1
20968 vals(k+1) = cbtran( iseed(k*4+1) )
20969 IF( cbtabs( vals(k+1) ) .LT. cbtabs( vals(iamn) ) )
20970 $ iamn = k + 1
20971 40 CONTINUE
20972 END IF
20973*
20974* If BLACS have not returned same value we've chosen
20975*
20976 IF( a(i,j) .NE. vals(iamn) ) THEN
20977*
20978* If we have RA and CA arrays
20979*
20980 IF( ldi .NE. -1 ) THEN
20981*
20982* Any number having the same absolute value is a valid max
20983*
20984 k = ibtspnum( scope, ra(h), ca(h), npcol ) + 1
20985 IF( k.GT.0 .AND. k.LE.nnodes ) THEN
20986 error = abs( cbtabs(vals(k)) - cbtabs(vals(iamn)) )
20987 $ .GT. 3*eps
20988 IF( .NOT.error ) iamn = k
20989 ELSE
20990 error = .true.
20991 END IF
20992 ELSE
20993*
20994* Error if BLACS answer not same absolute value, or if it
20995* was not really in the numbers being compared
20996*
20997 error = abs( cbtabs(a(i,j)) - cbtabs(vals(iamn)) )
20998 $ .GT. 3*eps
20999 IF( .NOT.error ) THEN
21000 DO 50 k = 1, nnodes
21001 IF( vals(k) .EQ. a(i,j) ) GOTO 60
21002 50 CONTINUE
21003 error = .true.
21004 60 CONTINUE
21005 ENDIF
21006 END IF
21007*
21008* If the value is in error
21009*
21010 IF( error ) THEN
21011 nerr = nerr + 1
21012 erribuf(1, nerr) = testnum
21013 erribuf(2, nerr) = nnodes
21014 erribuf(3, nerr) = dest
21015 erribuf(4, nerr) = i
21016 erribuf(5, nerr) = j
21017 erribuf(6, nerr) = 5
21018 errdbuf(1, nerr) = a(i,j)
21019 errdbuf(2, nerr) = vals(iamn)
21020 END IF
21021 END IF
21022*
21023* If they are defined, make sure coordinate entries are OK
21024*
21025 IF( ldi .NE. -1 ) THEN
21026 k = ibtspnum( scope, ra(h), ca(h), npcol ) + 1
21027 IF( k.NE.iamn ) THEN
21028*
21029* Make sure more than one proc doesn't have exact same value
21030* (and therefore there may be more than one valid coordinate
21031* for a single value)
21032*
21033 IF( k.GT.nnodes .OR. k.LT.1 ) THEN
21034 error = .true.
21035 ELSE
21036 error = ( vals(k) .NE. vals(iamn) )
21037 END IF
21038 IF( error ) THEN
21039 CALL ibtspcoord( scope, iamn-1, myrow, mycol,
21040 $ npcol, ramn, camn )
21041 IF( ramn .NE. ra(h) ) THEN
21042 nerr = nerr + 1
21043 erribuf(1, nerr) = testnum
21044 erribuf(2, nerr) = nnodes
21045 erribuf(3, nerr) = dest
21046 erribuf(4, nerr) = i
21047 erribuf(5, nerr) = j
21048 erribuf(6, nerr) = -5
21049 errdbuf(1, nerr) = ra(h)
21050 errdbuf(2, nerr) = ramn
21051 END IF
21052 IF( camn .NE. ca(h) ) THEN
21053 nerr = nerr + 1
21054 erribuf(1, nerr) = testnum
21055 erribuf(2, nerr) = nnodes
21056 erribuf(3, nerr) = dest
21057 erribuf(4, nerr) = i
21058 erribuf(5, nerr) = j
21059 erribuf(6, nerr) = -15
21060 errdbuf(1, nerr) = ca(h)
21061 errdbuf(2, nerr) = camn
21062 END IF
21063 END IF
21064 END IF
21065 END IF
21066 90 CONTINUE
21067 100 CONTINUE
21068*
21069 RETURN
21070*
21071* End of CCHKAMN
21072*
21073 END
21074*
21075*
21076 SUBROUTINE zamntest( OUTNUM, VERB, TOPSREPEAT, TOPSCOHRNT, NSCOPE,
21077 $ SCOPE0, NTOP, TOP0, NMAT, M0, N0, LDAS0,
21078 $ LDAD0, LDI0, NDEST, RDEST0, CDEST0, NGRID,
21079 $ CONTEXT0, P0, Q0, ISEED, RMEM, CMEM, RCLEN,
21080 $ MEM, MEMLEN )
21081*
21082* -- BLACS tester (version 1.0) --
21083* University of Tennessee
21084* December 15, 1994
21085*
21086*
21087* .. Scalar Arguments ..
21088 INTEGER MEMLEN, NDEST, NGRID, NMAT, NSCOPE, NTOP, OUTNUM, RCLEN,
21089 $ TOPSCOHRNT, TOPSREPEAT, VERB
21090* ..
21091* .. Array Arguments ..
21092 CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP)
21093 INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT), LDI0(NMAT)
21094 INTEGER RDEST0(NDEST), CDEST0(NDEST), CONTEXT0(NGRID)
21095 INTEGER P0(NGRID), Q0(NGRID), ISEED(*), RMEM(RCLEN), CMEM(RCLEN)
21096 DOUBLE COMPLEX MEM(MEMLEN)
21097* ..
21098*
21099* Purpose
21100* =======
21101* ZTESTAMN: Test double complex AMN COMBINE
21102*
21103* Arguments
21104* =========
21105* OUTNUM (input) INTEGER
21106* The device number to write output to.
21107*
21108* VERB (input) INTEGER
21109* The level of verbosity (how much printing to do).
21110*
21111* NSCOPE (input) INTEGER
21112* The number of scopes to be tested.
21113*
21114* SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE)
21115* Values of the scopes to be tested.
21116*
21117* NTOP (input) INTEGER
21118* The number of topologies to be tested.
21119*
21120* TOP0 (input) CHARACTER*1 array of dimension (NTOP)
21121* Values of the topologies to be tested.
21122*
21123* NMAT (input) INTEGER
21124* The number of matrices to be tested.
21125*
21126* M0 (input) INTEGER array of dimension (NMAT)
21127* Values of M to be tested.
21128*
21129* M0 (input) INTEGER array of dimension (NMAT)
21130* Values of M to be tested.
21131*
21132* N0 (input) INTEGER array of dimension (NMAT)
21133* Values of N to be tested.
21134*
21135* LDAS0 (input) INTEGER array of dimension (NMAT)
21136* Values of LDAS (leading dimension of A on source process)
21137* to be tested.
21138*
21139* LDAD0 (input) INTEGER array of dimension (NMAT)
21140* Values of LDAD (leading dimension of A on destination
21141* process) to be tested.
21142* LDI0 (input) INTEGER array of dimension (NMAT)
21143* Values of LDI (leading dimension of RA/CA) to be tested.
21144* If LDI == -1, these RA/CA should not be accessed.
21145*
21146* NDEST (input) INTEGER
21147* The number of destinations to be tested.
21148*
21149* RDEST0 (input) INTEGER array of dimension (NNDEST)
21150* Values of RDEST (row coordinate of destination) to be
21151* tested.
21152*
21153* CDEST0 (input) INTEGER array of dimension (NNDEST)
21154* Values of CDEST (column coordinate of destination) to be
21155* tested.
21156*
21157* NGRID (input) INTEGER
21158* The number of process grids to be tested.
21159*
21160* CONTEXT0 (input) INTEGER array of dimension (NGRID)
21161* The BLACS context handles corresponding to the grids.
21162*
21163* P0 (input) INTEGER array of dimension (NGRID)
21164* Values of P (number of process rows, NPROW).
21165*
21166* Q0 (input) INTEGER array of dimension (NGRID)
21167* Values of Q (number of process columns, NPCOL).
21168*
21169* ISEED (workspace) INTEGER array of dimension ( MAX(NPROCS, NTESTS) )
21170* Workspace used to hold each process's random number SEED.
21171* This requires NPROCS (number of processor) elements.
21172* If VERB < 2, this workspace also serves to indicate which
21173* tests fail. This requires workspace of NTESTS
21174* (number of tests performed).
21175*
21176* RMEM (workspace) INTEGER array of dimension (RCLEN)
21177* Used for all RA arrays, and their pre and post padding.
21178*
21179* CMEM (workspace) INTEGER array of dimension (RCLEN)
21180* Used for all CA arrays, and their pre and post padding.
21181*
21182* RCLEN (input) INTEGER
21183* The length, in elements, of RMEM and CMEM.
21184*
21185* MEM (workspace) DOUBLE COMPLEX array of dimension (MEMLEN)
21186* Used for all other workspaces, including the matrix A,
21187* and its pre and post padding.
21188*
21189* MEMLEN (input) INTEGER
21190* The length, in elements, of MEM.
21191*
21192* =====================================================================
21193*
21194* .. External Functions ..
21195 LOGICAL ALLPASS, LSAME
21196 INTEGER IBTMYPROC, IBTNPROCS, IBTSIZEOF
21197 EXTERNAL ALLPASS, LSAME, IBTMYPROC, IBTNPROCS, IBTSIZEOF
21198* ..
21199* .. External Subroutines ..
21200 EXTERNAL blacs_gridinfo, zgamn2d
21201 EXTERNAL zinitmat, zchkpad, zbtcheckin
21202* ..
21203* .. Local Scalars ..
21204 CHARACTER*1 SCOPE, TOP
21205 LOGICAL INGRID, TESTOK, ALLRCV
21206 INTEGER APTR, CAPTR, CDEST, CDEST2, CONTEXT, ERRDPTR, ERRIPTR, I,
21207 $ IAM, ICHECKVAL, IDE, IGR, IMA, IPAD, IPOST, IPRE, ISC,
21208 $ isize, istart, istop, itc, itc1, itc2, ito, itr, itr1,
21209 $ itr2, j, k, lda, ldadst, ldasrc, ldi, m, maxerr, mycol,
21210 $ myrow, n, nerr, nfail, npcol, nprow, nskip, preaptr,
21211 $ raptr, rdest, rdest2, setwhat, testnum, valptr, zsize
21212 DOUBLE COMPLEX CHECKVAL
21213* ..
21214* .. Executable Statements ..
21215*
21216* Choose padding value, and make it unique
21217*
21218 checkval = dcmplx( -9.11d0, -9.21d0 )
21219 iam = ibtmyproc()
21220 checkval = iam * checkval
21221 isize = ibtsizeof('I')
21222 zsize = ibtsizeof('Z')
21223 icheckval = -iam
21224*
21225* Verify file parameters
21226*
21227 IF( iam .EQ. 0 ) THEN
21228 WRITE(outnum, *) ' '
21229 WRITE(outnum, *) ' '
21230 WRITE(outnum, 1000 )
21231 IF( verb .GT. 0 ) THEN
21232 WRITE(outnum,*) ' '
21233 WRITE(outnum, 2000) 'NSCOPE:', nscope
21234 WRITE(outnum, 3000) ' SCOPE:', ( scope0(i), i = 1, nscope )
21235 WRITE(outnum, 2000) 'TReps :', topsrepeat
21236 WRITE(outnum, 2000) 'TCohr :', topscohrnt
21237 WRITE(outnum, 2000) 'NTOP :', ntop
21238 WRITE(outnum, 3000) ' TOP :', ( top0(i), i = 1, ntop )
21239 WRITE(outnum, 2000) 'NMAT :', nmat
21240 WRITE(outnum, 2000) ' M :', ( m0(i), i = 1, nmat )
21241 WRITE(outnum, 2000) ' N :', ( n0(i), i = 1, nmat )
21242 WRITE(outnum, 2000) ' LDAS :', ( ldas0(i), i = 1, nmat )
21243 WRITE(outnum, 2000) ' LDAD :', ( ldad0(i), i = 1, nmat )
21244 WRITE(outnum, 2000) ' LDI :', ( ldi0(i), i = 1, nmat )
21245 WRITE(outnum, 2000) 'NDEST :', ndest
21246 WRITE(outnum, 2000) ' RDEST:',( rdest0(i), i = 1, ndest )
21247 WRITE(outnum, 2000) ' CDEST:',( cdest0(i), i = 1, ndest )
21248 WRITE(outnum, 2000) 'NGRIDS:', ngrid
21249 WRITE(outnum, 2000) ' P :', ( p0(i), i = 1, ngrid )
21250 WRITE(outnum, 2000) ' Q :', ( q0(i), i = 1, ngrid )
21251 WRITE(outnum, 2000) 'VERB :', verb
21252 WRITE(outnum,*) ' '
21253 END IF
21254 IF( verb .GT. 1 ) THEN
21255 WRITE(outnum,4000)
21256 WRITE(outnum,5000)
21257 END IF
21258 END IF
21259 IF (topsrepeat.EQ.0) THEN
21260 itr1 = 0
21261 itr2 = 0
21262 ELSE IF (topsrepeat.EQ.1) THEN
21263 itr1 = 1
21264 itr2 = 1
21265 ELSE
21266 itr1 = 0
21267 itr2 = 1
21268 END IF
21269*
21270* Find biggest matrix, so we know where to stick error info
21271*
21272 i = 0
21273 DO 10 ima = 1, nmat
21274 ipad = 4 * m0(ima)
21275 k = n0(ima) * max0( ldas0(ima), ldad0(ima) ) + ipad
21276 IF( k .GT. i ) i = k
21277 10 CONTINUE
21278 i = i + ibtnprocs()
21279 maxerr = ( zsize * (memlen-i) ) / ( zsize*2 + isize*6 )
21280 IF( maxerr .LT. 1 ) THEN
21281 WRITE(outnum,*) 'ERROR: Not enough memory to run MIN tests.'
21282 CALL blacs_abort(-1, 1)
21283 END IF
21284 errdptr = i + 1
21285 erriptr = errdptr + maxerr
21286 nerr = 0
21287 testnum = 0
21288 nfail = 0
21289 nskip = 0
21290*
21291* Loop over grids of matrix
21292*
21293 DO 90 igr = 1, ngrid
21294*
21295* allocate process grid for the next batch of tests
21296*
21297 context = context0(igr)
21298 CALL blacs_gridinfo( context, nprow, npcol, myrow, mycol )
21299 ingrid = ( (myrow.LT.nprow) .AND. (mycol.LT.npcol) )
21300*
21301 DO 80 isc = 1, nscope
21302 scope = scope0(isc)
21303 DO 70 ito = 1, ntop
21304 top = top0(ito)
21305*
21306* If testing multiring ('M') or general tree ('T'), need to
21307* loop over calls to BLACS_SET to do full test
21308*
21309 IF( lsame(top, 'M') ) THEN
21310 setwhat = 13
21311 IF( scope .EQ. 'R' ) THEN
21312 istart = -(npcol - 1)
21313 istop = -istart
21314 ELSE IF (scope .EQ. 'C') THEN
21315 istart = -(nprow - 1)
21316 istop = -istart
21317 ELSE
21318 istart = -(nprow*npcol - 1)
21319 istop = -istart
21320 ENDIF
21321 ELSE IF( lsame(top, 'T') ) THEN
21322 setwhat = 14
21323 istart = 1
21324 IF( scope .EQ. 'R' ) THEN
21325 istop = npcol - 1
21326 ELSE IF (scope .EQ. 'C') THEN
21327 istop = nprow - 1
21328 ELSE
21329 istop = nprow*npcol - 1
21330 ENDIF
21331 ELSE
21332 setwhat = 0
21333 istart = 1
21334 istop = 1
21335 ENDIF
21336 DO 60 ima = 1, nmat
21337 m = m0(ima)
21338 n = n0(ima)
21339 ldasrc = ldas0(ima)
21340 ldadst = ldad0(ima)
21341 ldi = ldi0(ima)
21342 ipre = 2 * m
21343 ipost = ipre
21344 preaptr = 1
21345 aptr = preaptr + ipre
21346*
21347 DO 50 ide = 1, ndest
21348 testnum = testnum + 1
21349 rdest2 = rdest0(ide)
21350 cdest2 = cdest0(ide)
21351*
21352* If everyone gets the answer, create some bogus rdest/cdest
21353* so IF's are easier
21354*
21355 allrcv = ( (rdest2.EQ.-1) .OR. (cdest2.EQ.-1) )
21356 IF( allrcv ) THEN
21357 rdest = nprow - 1
21358 cdest = npcol - 1
21359 IF (topscohrnt.EQ.0) THEN
21360 itr1 = 0
21361 itr2 = 0
21362 ELSE IF (topscohrnt.EQ.1) THEN
21363 itr1 = 1
21364 itr2 = 1
21365 ELSE
21366 itr1 = 0
21367 itr2 = 1
21368 END IF
21369 ELSE
21370 rdest = rdest2
21371 cdest = cdest2
21372 itc1 = 0
21373 itc2 = 0
21374 END IF
21375 IF( rdest.GE.p0(igr) .OR. cdest.GE.q0(igr) ) THEN
21376 nskip = nskip + 1
21377 GOTO 50
21378 END IF
21379*
21380 IF( myrow.EQ.rdest .AND. mycol.EQ.cdest ) THEN
21381 lda = ldadst
21382 ELSE
21383 lda = ldasrc
21384 END IF
21385 valptr = aptr + ipost + n * lda
21386 IF( verb .GT. 1 ) THEN
21387 IF( iam .EQ. 0 ) THEN
21388 WRITE(outnum, 6000)
21389 $ testnum, 'RUNNING', scope, top, m, n,
21390 $ ldasrc, ldadst, ldi, rdest2, cdest2,
21391 $ nprow, npcol
21392 END IF
21393 END IF
21394*
21395* If I am in scope
21396*
21397 testok = .true.
21398 IF( ingrid ) THEN
21399 IF( (myrow.EQ.rdest .AND. scope.EQ.'R') .OR.
21400 $ (mycol.EQ.cdest .AND. scope.EQ.'C') .OR.
21401 $ (scope .EQ. 'A') ) THEN
21402*
21403 k = nerr
21404 DO 40 itr = itr1, itr2
21405 CALL blacs_set(context, 15, itr)
21406 DO 35 itc = itc1, itc2
21407 CALL blacs_set(context, 16, itc)
21408 DO 30 j = istart, istop
21409 IF( j.EQ.0) GOTO 30
21410 IF( setwhat.NE.0 )
21411 $ CALL blacs_set(context, setwhat, j)
21412*
21413*
21414* generate and pad matrix A
21415*
21416 CALL zinitmat('G','-', m, n, mem(preaptr),
21417 $ lda, ipre, ipost,
21418 $ checkval, testnum,
21419 $ myrow, mycol )
21420*
21421* If they exist, pad RA and CA arrays
21422*
21423 IF( ldi .NE. -1 ) THEN
21424 DO 15 i = 1, n*ldi + ipre + ipost
21425 rmem(i) = icheckval
21426 cmem(i) = icheckval
21427 15 CONTINUE
21428 raptr = 1 + ipre
21429 captr = 1 + ipre
21430 ELSE
21431 DO 20 i = 1, ipre+ipost
21432 rmem(i) = icheckval
21433 cmem(i) = icheckval
21434 20 CONTINUE
21435 raptr = 1
21436 captr = 1
21437 END IF
21438*
21439 CALL zgamn2d(context, scope, top, m, n,
21440 $ mem(aptr), lda, rmem(raptr),
21441 $ cmem(captr), ldi,
21442 $ rdest2, cdest2)
21443*
21444* If I've got the answer, check for errors in
21445* matrix or padding
21446*
21447 IF( (myrow.EQ.rdest .AND. mycol.EQ.cdest)
21448 $ .OR. allrcv ) THEN
21449 CALL zchkpad('G','-', m, n,
21450 $ mem(preaptr), lda, rdest,
21451 $ cdest, myrow, mycol,
21452 $ ipre, ipost, checkval,
21453 $ testnum, maxerr, nerr,
21454 $ mem(erriptr),mem(errdptr))
21455 CALL zchkamn(scope, context, m, n,
21456 $ mem(aptr), lda,
21457 $ rmem(raptr), cmem(captr),
21458 $ ldi, testnum, maxerr,nerr,
21459 $ mem(erriptr),mem(errdptr),
21460 $ iseed, mem(valptr))
21461 CALL zrcchk(ipre, ipost, icheckval,
21462 $ m, n, rmem, cmem, ldi,
21463 $ myrow, mycol, testnum,
21464 $ maxerr, nerr,
21465 $ mem(erriptr), mem(errdptr))
21466 END IF
21467 30 CONTINUE
21468 CALL blacs_set(context, 16, 0)
21469 35 CONTINUE
21470 CALL blacs_set(context, 15, 0)
21471 40 CONTINUE
21472 testok = ( k .EQ. nerr )
21473 END IF
21474 END IF
21475*
21476 IF( verb .GT. 1 ) THEN
21477 i = nerr
21478 CALL zbtcheckin(0, outnum, maxerr, nerr,
21479 $ mem(erriptr), mem(errdptr), iseed)
21480 IF( iam .EQ. 0 ) THEN
21481 IF( testok .AND. nerr.EQ.i ) THEN
21482 WRITE(outnum,6000)testnum,'PASSED ',
21483 $ scope, top, m, n, ldasrc,
21484 $ ldadst, ldi, rdest2, cdest2,
21485 $ nprow, npcol
21486 ELSE
21487 nfail = nfail + 1
21488 WRITE(outnum,6000)testnum,'FAILED ',
21489 $ scope, top, m, n, ldasrc,
21490 $ ldadst, ldi, rdest2, cdest2,
21491 $ nprow, npcol
21492 END IF
21493 END IF
21494*
21495* Once we've printed out errors, can re-use buf space
21496*
21497 nerr = 0
21498 END IF
21499 50 CONTINUE
21500 60 CONTINUE
21501 70 CONTINUE
21502 80 CONTINUE
21503 90 CONTINUE
21504*
21505 IF( verb .LT. 2 ) THEN
21506 nfail = testnum
21507 CALL zbtcheckin( nfail, outnum, maxerr, nerr, mem(erriptr),
21508 $ mem(errdptr), iseed )
21509 END IF
21510 IF( iam .EQ. 0 ) THEN
21511 IF( verb .GT. 1 ) WRITE(outnum,*) ' '
21512 IF( nfail+nskip .EQ. 0 ) THEN
21513 WRITE(outnum, 7000 ) testnum
21514 ELSE
21515 WRITE(outnum, 8000 ) testnum, testnum-nskip-nfail,
21516 $ nskip, nfail
21517 END IF
21518 END IF
21519*
21520* Log whether their were any failures
21521*
21522 testok = allpass( (nfail.EQ.0) )
21523*
21524 1000 FORMAT('DOUBLE COMPLEX AMN TESTS: BEGIN.' )
21525 2000 FORMAT(1x,a7,3x,10i6)
21526 3000 FORMAT(1x,a7,3x,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,5x,a1,
21527 $ 5x,a1,5x,a1)
21528 4000 FORMAT(' TEST# STATUS SCOPE TOP M N LDAS LDAD LDI ',
21529 $ 'RDEST CDEST P Q')
21530 5000 FORMAT(' ----- ------- ----- --- ----- ----- ----- ----- ----- ',
21531 $ '----- ----- ---- ----')
21532 6000 FORMAT(i6,1x,a7,5x,a1,3x,a1,7i6,2i5)
21533 7000 FORMAT('DOUBLE COMPLEX AMN TESTS: PASSED ALL',
21534 $ i5, ' TESTS.')
21535 8000 FORMAT('DOUBLE COMPLEX AMN TESTS:',i5,' TESTS;',i5,' PASSED,',
21536 $ i5,' SKIPPED,',i5,' FAILED.')
21537*
21538 RETURN
21539*
21540* End of ZTESTAMN.
21541*
21542 END
21543*
21544 SUBROUTINE zchkamn( SCOPE, ICTXT, M, N, A, LDA, RA, CA, LDI,
21545 $ TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF,
21546 $ ISEED, VALS )
21547*
21548* .. Scalar Arguments ..
21549 CHARACTER*1 SCOPE
21550 INTEGER ICTXT, M, N, LDA, LDI, TESTNUM, MAXERR, NERR
21551* ..
21552* .. Array Arguments ..
21553 INTEGER RA(*), CA(*), ERRIBUF(6, MAXERR), ISEED(*)
21554 DOUBLE COMPLEX A(LDA,*), ERRDBUF(2, MAXERR), VALS(*)
21555* ..
21556* .. External Functions ..
21557 INTEGER IBTMYPROC, IBTNPROCS, IBTSPNUM
21558 DOUBLE PRECISION DBTEPS, ZBTABS
21559 DOUBLE COMPLEX ZBTRAN
21560 EXTERNAL ibtmyproc, ibtnprocs, ibtspnum, zbtran, dbteps, zbtabs
21561* ..
21562* .. External Subroutines ..
21563 EXTERNAL ibtspcoord
21564* ..
21565* .. Local Scalars ..
21566 LOGICAL ERROR
21567 INTEGER NPROCS, NNODES, NPROW, NPCOL, MYROW, MYCOL, RAMN, CAMN
21568 INTEGER IAMN, I, J, K, H, DEST, NODE
21569 DOUBLE PRECISION EPS
21570* ..
21571* .. Executable Statements ..
21572*
21573 nprocs = ibtnprocs()
21574 eps = dbteps()
21575 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
21576 dest = myrow*nprocs + mycol
21577*
21578* Set up seeds to match those used by each proc's genmat call
21579*
21580 IF( scope .EQ. 'R' ) THEN
21581 nnodes = npcol
21582 DO 10 i = 0, nnodes-1
21583 node = myrow * nprocs + i
21584 iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
21585 iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
21586 iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
21587 iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
21588 10 CONTINUE
21589 ELSE IF( scope .EQ. 'C' ) THEN
21590 nnodes = nprow
21591 DO 20 i = 0, nnodes-1
21592 node = i * nprocs + mycol
21593 iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
21594 iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
21595 iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
21596 iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
21597 20 CONTINUE
21598 ELSE
21599 nnodes = nprow * npcol
21600 DO 30 i = 0, nnodes-1
21601 node = (i / npcol) * nprocs + mod(i, npcol)
21602 iseed(i*4+1) = mod( 1002 + testnum*5 + node*3, 4096 )
21603 iseed(i*4+2) = mod( 2027 + testnum*7 + node, 4096 )
21604 iseed(i*4+3) = mod( 1234 + testnum + node*3, 4096 )
21605 iseed(i*4+4) = mod( 4311 + testnum*10 + node*2, 4096 )
21606 30 CONTINUE
21607 END IF
21608*
21609 DO 100 j = 1, n
21610 DO 90 i = 1, m
21611 h = (j-1)*ldi + i
21612 vals(1) = zbtran( iseed )
21613 iamn = 1
21614 IF( nnodes .GT. 1 ) THEN
21615 DO 40 k = 1, nnodes-1
21616 vals(k+1) = zbtran( iseed(k*4+1) )
21617 IF( zbtabs( vals(k+1) ) .LT. zbtabs( vals(iamn) ) )
21618 $ iamn = k + 1
21619 40 CONTINUE
21620 END IF
21621*
21622* If BLACS have not returned same value we've chosen
21623*
21624 IF( a(i,j) .NE. vals(iamn) ) THEN
21625*
21626* If we have RA and CA arrays
21627*
21628 IF( ldi .NE. -1 ) THEN
21629*
21630* Any number having the same absolute value is a valid max
21631*
21632 k = ibtspnum( scope, ra(h), ca(h), npcol ) + 1
21633 IF( k.GT.0 .AND. k.LE.nnodes ) THEN
21634 error = abs( zbtabs(vals(k)) - zbtabs(vals(iamn)) )
21635 $ .GT. 3*eps
21636 IF( .NOT.error ) iamn = k
21637 ELSE
21638 error = .true.
21639 END IF
21640 ELSE
21641*
21642* Error if BLACS answer not same absolute value, or if it
21643* was not really in the numbers being compared
21644*
21645 error = abs( zbtabs(a(i,j)) - zbtabs(vals(iamn)) )
21646 $ .GT. 3*eps
21647 IF( .NOT.error ) THEN
21648 DO 50 k = 1, nnodes
21649 IF( vals(k) .EQ. a(i,j) ) GOTO 60
21650 50 CONTINUE
21651 error = .true.
21652 60 CONTINUE
21653 ENDIF
21654 END IF
21655*
21656* If the value is in error
21657*
21658 IF( error ) THEN
21659 nerr = nerr + 1
21660 erribuf(1, nerr) = testnum
21661 erribuf(2, nerr) = nnodes
21662 erribuf(3, nerr) = dest
21663 erribuf(4, nerr) = i
21664 erribuf(5, nerr) = j
21665 erribuf(6, nerr) = 5
21666 errdbuf(1, nerr) = a(i,j)
21667 errdbuf(2, nerr) = vals(iamn)
21668 END IF
21669 END IF
21670*
21671* If they are defined, make sure coordinate entries are OK
21672*
21673 IF( ldi .NE. -1 ) THEN
21674 k = ibtspnum( scope, ra(h), ca(h), npcol ) + 1
21675 IF( k.NE.iamn ) THEN
21676*
21677* Make sure more than one proc doesn't have exact same value
21678* (and therefore there may be more than one valid coordinate
21679* for a single value)
21680*
21681 IF( k.GT.nnodes .OR. k.LT.1 ) THEN
21682 error = .true.
21683 ELSE
21684 error = ( vals(k) .NE. vals(iamn) )
21685 END IF
21686 IF( error ) THEN
21687 CALL ibtspcoord( scope, iamn-1, myrow, mycol,
21688 $ npcol, ramn, camn )
21689 IF( ramn .NE. ra(h) ) THEN
21690 nerr = nerr + 1
21691 erribuf(1, nerr) = testnum
21692 erribuf(2, nerr) = nnodes
21693 erribuf(3, nerr) = dest
21694 erribuf(4, nerr) = i
21695 erribuf(5, nerr) = j
21696 erribuf(6, nerr) = -5
21697 errdbuf(1, nerr) = ra(h)
21698 errdbuf(2, nerr) = ramn
21699 END IF
21700 IF( camn .NE. ca(h) ) THEN
21701 nerr = nerr + 1
21702 erribuf(1, nerr) = testnum
21703 erribuf(2, nerr) = nnodes
21704 erribuf(3, nerr) = dest
21705 erribuf(4, nerr) = i
21706 erribuf(5, nerr) = j
21707 erribuf(6, nerr) = -15
21708 errdbuf(1, nerr) = ca(h)
21709 errdbuf(2, nerr) = camn
21710 END IF
21711 END IF
21712 END IF
21713 END IF
21714 90 CONTINUE
21715 100 CONTINUE
21716*
21717 RETURN
21718*
21719* End of ZCHKAMN
21720*
21721 END
21722*
cmplx
float cmplx[2]
Definition pblas.h:136
isdrvtest
subroutine isdrvtest(outnum, verb, nshape, uplo0, diag0, nmat, m0, n0, ldas0, ldad0, nsrc, rsrc0, csrc0, rdest0, cdest0, ngrid, context0, p0, q0, tfail, mem, memlen)
Definition blacstest.f:2205
sbtcheckin
subroutine sbtcheckin(nftests, outnum, maxerr, nerr, ierr, sval, tfailed)
Definition blacstest.f:7341
dchkmat
subroutine dchkmat(uplo, diag, m, n, a, lda, rsrc, csrc, myrow, mycol, testnum, maxerr, nerr, erribuf, errdbuf)
Definition blacstest.f:9071
cbtran
complex function cbtran(iseed)
Definition blacstest.f:9683
dprinterrs
subroutine dprinterrs(outnum, maxerr, nerr, erribuf, errdbuf, counting, tfailed)
Definition blacstest.f:9276
ssdrvtest
subroutine ssdrvtest(outnum, verb, nshape, uplo0, diag0, nmat, m0, n0, ldas0, ldad0, nsrc, rsrc0, csrc0, rdest0, cdest0, ngrid, context0, p0, q0, tfail, mem, memlen)
Definition blacstest.f:2549
crcchk
subroutine crcchk(ipre, ipost, padval, m, n, ra, ca, ldi, myrow, mycol, testnum, maxerr, nerr, erribuf, errdbuf)
Definition blacstest.f:17331
cchkpad
subroutine cchkpad(uplo, diag, m, n, mem, lda, rsrc, csrc, myrow, mycol, ipre, ipost, checkval, testnum, maxerr, nerr, erribuf, errdbuf)
Definition blacstest.f:9872
schkpad
subroutine schkpad(uplo, diag, m, n, mem, lda, rsrc, csrc, myrow, mycol, ipre, ipost, checkval, testnum, maxerr, nerr, erribuf, errdbuf)
Definition blacstest.f:7746
schkamn
subroutine schkamn(scope, ictxt, m, n, a, lda, ra, ca, ldi, testnum, maxerr, nerr, erribuf, errdbuf, iseed, vals)
Definition blacstest.f:19607
csumtest
subroutine csumtest(outnum, verb, topsrepeat, topscohrnt, nscope, scope0, ntop, top0, nmat, m0, n0, ldas0, ldad0, ndest, rdest0, cdest0, ngrid, context0, p0, q0, iseed, mem, memlen)
Definition blacstest.f:13287
zrcchk
subroutine zrcchk(ipre, ipost, padval, m, n, ra, ca, ldi, myrow, mycol, testnum, maxerr, nerr, erribuf, errdbuf)
Definition blacstest.f:18148
zsumtest
subroutine zsumtest(outnum, verb, topsrepeat, topscohrnt, nscope, scope0, ntop, top0, nmat, m0, n0, ldas0, ldad0, ndest, rdest0, cdest0, ngrid, context0, p0, q0, iseed, mem, memlen)
Definition blacstest.f:13836
allpass
logical function allpass(thistest)
Definition blacstest.f:1881
cinitmat
subroutine cinitmat(uplo, diag, m, n, mem, lda, ipre, ipost, checkval, testnum, myrow, mycol)
Definition blacstest.f:9591
samxtest
subroutine samxtest(outnum, verb, topsrepeat, topscohrnt, nscope, scope0, ntop, top0, nmat, m0, n0, ldas0, ldad0, ldi0, ndest, rdest0, cdest0, ngrid, context0, p0, q0, iseed, rmem, cmem, rclen, mem, memlen)
Definition blacstest.f:15235
dsumtest
subroutine dsumtest(outnum, verb, topsrepeat, topscohrnt, nscope, scope0, ntop, top0, nmat, m0, n0, ldas0, ldad0, ndest, rdest0, cdest0, ngrid, context0, p0, q0, iseed, mem, memlen)
Definition blacstest.f:12709
zbtran
double complex function zbtran(iseed)
Definition blacstest.f:10751
zchkamx
subroutine zchkamx(scope, ictxt, m, n, a, lda, ra, ca, ldi, testnum, maxerr, nerr, erribuf, errdbuf, iseed, vals)
Definition blacstest.f:18317
ibtspcoord
subroutine ibtspcoord(scope, pnum, myrow, mycol, npcol, prow, pcol)
Definition blacstest.f:14850
camntest
subroutine camntest(outnum, verb, topsrepeat, topscohrnt, nscope, scope0, ntop, top0, nmat, m0, n0, ldas0, ldad0, ldi0, ndest, rdest0, cdest0, ngrid, context0, p0, q0, iseed, rmem, cmem, rclen, mem, memlen)
Definition blacstest.f:20433
ichkamx
subroutine ichkamx(scope, ictxt, m, n, a, lda, ra, ca, ldi, testnum, maxerr, nerr, erribuf, errdbuf, iseed, vals)
Definition blacstest.f:15058
cpadmat
subroutine cpadmat(uplo, diag, m, n, mem, lda, ipre, ipost, checkval)
Definition blacstest.f:9698
isumtest
subroutine isumtest(outnum, verb, topsrepeat, topscohrnt, nscope, scope0, ntop, top0, nmat, m0, n0, ldas0, ldad0, ndest, rdest0, cdest0, ngrid, context0, p0, q0, iseed, mem, memlen)
Definition blacstest.f:11607
dchksum
subroutine dchksum(scope, ictxt, m, n, a, lda, testnum, maxerr, nerr, erribuf, errdbuf, iseed)
Definition blacstest.f:13179
cchksum
subroutine cchksum(scope, ictxt, m, n, a, lda, testnum, maxerr, nerr, erribuf, errdbuf, iseed)
Definition blacstest.f:13715
ibtran
integer function ibtran(iseed)
Definition blacstest.f:6486
blacstest
program blacstest
Definition blacstest.f:1
dchkamx
subroutine dchkamx(scope, ictxt, m, n, a, lda, ra, ca, ldi, testnum, maxerr, nerr, erribuf, errdbuf, iseed, vals)
Definition blacstest.f:16685
iamxtest
subroutine iamxtest(outnum, verb, topsrepeat, topscohrnt, nscope, scope0, ntop, top0, nmat, m0, n0, ldas0, ldad0, ldi0, ndest, rdest0, cdest0, ngrid, context0, p0, q0, iseed, rmem, cmem, rclen, mem, memlen)
Definition blacstest.f:14386
ichkmat
subroutine ichkmat(uplo, diag, m, n, a, lda, rsrc, csrc, myrow, mycol, testnum, maxerr, nerr, erribuf, errdbuf)
Definition blacstest.f:6943
ibtabs
integer function ibtabs(val)
Definition blacstest.f:12027
cbtabs
real function cbtabs(val)
Definition blacstest.f:13708
ircchk
subroutine ircchk(ipre, ipost, padval, m, n, ra, ca, ldi, myrow, mycol, testnum, maxerr, nerr, erribuf, errdbuf)
Definition blacstest.f:14889
sprinterrs
subroutine sprinterrs(outnum, maxerr, nerr, erribuf, errdbuf, counting, tfailed)
Definition blacstest.f:8212
damntest
subroutine damntest(outnum, verb, topsrepeat, topscohrnt, nscope, scope0, ntop, top0, nmat, m0, n0, ldas0, ldad0, ldi0, ndest, rdest0, cdest0, ngrid, context0, p0, q0, iseed, rmem, cmem, rclen, mem, memlen)
Definition blacstest.f:19787
damxtest
subroutine damxtest(outnum, verb, topsrepeat, topscohrnt, nscope, scope0, ntop, top0, nmat, m0, n0, ldas0, ldad0, ldi0, ndest, rdest0, cdest0, ngrid, context0, p0, q0, iseed, rmem, cmem, rclen, mem, memlen)
Definition blacstest.f:16050
ichksum
subroutine ichksum(scope, ictxt, m, n, a, lda, testnum, maxerr, nerr, erribuf, errdbuf, iseed)
Definition blacstest.f:12034
dbtabs
double precision function dbtabs(val)
Definition blacstest.f:13130
iinitmat
subroutine iinitmat(uplo, diag, m, n, mem, lda, ipre, ipost, checkval, testnum, myrow, mycol)
Definition blacstest.f:6394
cchkamx
subroutine cchkamx(scope, ictxt, m, n, a, lda, ra, ca, ldi, testnum, maxerr, nerr, erribuf, errdbuf, iseed, vals)
Definition blacstest.f:17500
dgenmat
subroutine dgenmat(m, n, a, lda, testnum, myrow, mycol)
Definition blacstest.f:8544
zamxtest
subroutine zamxtest(outnum, verb, topsrepeat, topscohrnt, nscope, scope0, ntop, top0, nmat, m0, n0, ldas0, ldad0, ldi0, ndest, rdest0, cdest0, ngrid, context0, p0, q0, iseed, rmem, cmem, rclen, mem, memlen)
Definition blacstest.f:17682
samntest
subroutine samntest(outnum, verb, topsrepeat, topscohrnt, nscope, scope0, ntop, top0, nmat, m0, n0, ldas0, ldad0, ldi0, ndest, rdest0, cdest0, ngrid, context0, p0, q0, iseed, rmem, cmem, rclen, mem, memlen)
Definition blacstest.f:19141
cprinterrs
subroutine cprinterrs(outnum, maxerr, nerr, erribuf, errdbuf, counting, tfailed)
Definition blacstest.f:10338
btunpack
subroutine btunpack(test, mem, memlen, nop, nscope, trep, tcoh, ntop, nshape, nmat, nsrc, ngrid, opptr, scopeptr, topptr, uploptr, diagptr, mptr, nptr, ldsptr, lddptr, ldiptr, rsrcptr, csrcptr, rdestptr, cdestptr, pptr, qptr)
Definition blacstest.f:1397
zchkmat
subroutine zchkmat(uplo, diag, m, n, a, lda, rsrc, csrc, myrow, mycol, testnum, maxerr, nerr, erribuf, errdbuf)
Definition blacstest.f:11201
igenmat
subroutine igenmat(m, n, a, lda, testnum, myrow, mycol)
Definition blacstest.f:6411
makegrids
subroutine makegrids(contexts, outnum, ngrids, p, q)
Definition blacstest.f:640
freegrids
subroutine freegrids(ngrids, contexts)
Definition blacstest.f:668
safeindex
integer function safeindex(indx, size1, size2)
Definition blacstest.f:1517
btinfo
subroutine btinfo(test, memused, mem, memlen, cmemused, cmem, cmemlen, outnum, nop, nscope, trep, tcoh, ntop, nshape, nmat, nsrc, ngrid, opptr, scopeptr, topptr, uploptr, diagptr, mptr, nptr, ldsptr, lddptr, ldiptr, rsrcptr, csrcptr, rdestptr, cdestptr, pptr, qptr)
Definition blacstest.f:1063
schksum
subroutine schksum(scope, ictxt, m, n, a, lda, testnum, maxerr, nerr, erribuf, errdbuf, iseed)
Definition blacstest.f:12601
schkamx
subroutine schkamx(scope, ictxt, m, n, a, lda, ra, ca, ldi, testnum, maxerr, nerr, erribuf, errdbuf, iseed, vals)
Definition blacstest.f:15870
ichkamn
subroutine ichkamn(scope, ictxt, m, n, a, lda, ra, ca, ldi, testnum, maxerr, nerr, erribuf, errdbuf, iseed, vals)
Definition blacstest.f:18964
dchkpad
subroutine dchkpad(uplo, diag, m, n, mem, lda, rsrc, csrc, myrow, mycol, ipre, ipost, checkval, testnum, maxerr, nerr, erribuf, errdbuf)
Definition blacstest.f:8810
ibtspnum
integer function ibtspnum(scope, prow, pcol, npcol)
Definition blacstest.f:14870
rdsdrv
subroutine rdsdrv(memused, mem, memlen, cmemused, cmem, cmemlen, outnum)
Definition blacstest.f:1548
dbsbrtest
subroutine dbsbrtest(outnum, verb, nscope, scope0, ntop, top0, nshape, uplo0, diag0, nmat, m0, n0, ldas0, ldad0, nsrc, rsrc0, csrc0, ngrid, context0, p0, q0, tfail, mem, memlen)
Definition blacstest.f:4755
bttranschar
subroutine bttranschar(transto, n, cmem, imem)
Definition blacstest.f:1039
zpadmat
subroutine zpadmat(uplo, diag, m, n, mem, lda, ipre, ipost, checkval)
Definition blacstest.f:10766
ibsbrtest
subroutine ibsbrtest(outnum, verb, nscope, scope0, ntop, top0, nshape, uplo0, diag0, nmat, m0, n0, ldas0, ldad0, nsrc, rsrc0, csrc0, ngrid, context0, p0, q0, tfail, mem, memlen)
Definition blacstest.f:3925
zbtabs
double precision function zbtabs(val)
Definition blacstest.f:14257
chkmatdat
subroutine chkmatdat(nout, infile, tstflag, nmat, m0, n0, ldas0, ldad0, ldi0)
Definition blacstest.f:1791
dbteps
double precision function dbteps()
Definition blacstest.f:13136
spadmat
subroutine spadmat(uplo, diag, m, n, mem, lda, ipre, ipost, checkval)
Definition blacstest.f:7572
zamntest
subroutine zamntest(outnum, verb, topsrepeat, topscohrnt, nscope, scope0, ntop, top0, nmat, m0, n0, ldas0, ldad0, ldi0, ndest, rdest0, cdest0, ngrid, context0, p0, q0, iseed, rmem, cmem, rclen, mem, memlen)
Definition blacstest.f:21081
zchksum
subroutine zchksum(scope, ictxt, m, n, a, lda, testnum, maxerr, nerr, erribuf, errdbuf, iseed)
Definition blacstest.f:14264
zgenmat
subroutine zgenmat(m, n, a, lda, testnum, myrow, mycol)
Definition blacstest.f:10676
sinitmat
subroutine sinitmat(uplo, diag, m, n, mem, lda, ipre, ipost, checkval, testnum, myrow, mycol)
Definition blacstest.f:7463
ipadmat
subroutine ipadmat(uplo, diag, m, n, mem, lda, ipre, ipost, checkval)
Definition blacstest.f:6508
cbtcheckin
subroutine cbtcheckin(nftests, outnum, maxerr, nerr, ierr, cval, tfailed)
Definition blacstest.f:9469
drcchk
subroutine drcchk(ipre, ipost, padval, m, n, ra, ca, ldi, myrow, mycol, testnum, maxerr, nerr, erribuf, errdbuf)
Definition blacstest.f:16516
sbtran
real function sbtran(iseed)
Definition blacstest.f:7555
zchkamn
subroutine zchkamn(scope, ictxt, m, n, a, lda, ra, ca, ldi, testnum, maxerr, nerr, erribuf, errdbuf, iseed, vals)
Definition blacstest.f:21547
sbsbrtest
subroutine sbsbrtest(outnum, verb, nscope, scope0, ntop, top0, nshape, uplo0, diag0, nmat, m0, n0, ldas0, ldad0, nsrc, rsrc0, csrc0, ngrid, context0, p0, q0, tfail, mem, memlen)
Definition blacstest.f:4340
camxtest
subroutine camxtest(outnum, verb, topsrepeat, topscohrnt, nscope, scope0, ntop, top0, nmat, m0, n0, ldas0, ldad0, ldi0, ndest, rdest0, cdest0, ngrid, context0, p0, q0, iseed, rmem, cmem, rclen, mem, memlen)
Definition blacstest.f:16865
csdrvtest
subroutine csdrvtest(outnum, verb, nshape, uplo0, diag0, nmat, m0, n0, ldas0, ldad0, nsrc, rsrc0, csrc0, rdest0, cdest0, ngrid, context0, p0, q0, tfail, mem, memlen)
Definition blacstest.f:3237
auxtest
subroutine auxtest(outnum, mem, memlen)
Definition blacstest.f:681
schkmat
subroutine schkmat(uplo, diag, m, n, a, lda, rsrc, csrc, myrow, mycol, testnum, maxerr, nerr, erribuf, errdbuf)
Definition blacstest.f:8007
zinitmat
subroutine zinitmat(uplo, diag, m, n, mem, lda, ipre, ipost, checkval, testnum, myrow, mycol)
Definition blacstest.f:10659
dbtran
double precision function dbtran(iseed)
Definition blacstest.f:8619
sgenmat
subroutine sgenmat(m, n, a, lda, testnum, myrow, mycol)
Definition blacstest.f:7480
dinitmat
subroutine dinitmat(uplo, diag, m, n, mem, lda, ipre, ipost, checkval, testnum, myrow, mycol)
Definition blacstest.f:8527
runtests
subroutine runtests(mem, memlen, cmem, cmemlen, prec, nprec, outnum, verb, testsdrv, testbsbr, testcomb, testaux)
Definition blacstest.f:181
zprinterrs
subroutine zprinterrs(outnum, maxerr, nerr, erribuf, errdbuf, counting, tfailed)
Definition blacstest.f:11406
cchkamn
subroutine cchkamn(scope, ictxt, m, n, a, lda, ra, ca, ldi, testnum, maxerr, nerr, erribuf, errdbuf, iseed, vals)
Definition blacstest.f:20899
zchkpad
subroutine zchkpad(uplo, diag, m, n, mem, lda, rsrc, csrc, myrow, mycol, ipre, ipost, checkval, testnum, maxerr, nerr, erribuf, errdbuf)
Definition blacstest.f:10940
sbtabs
real function sbtabs(val)
Definition blacstest.f:12552
cgenmat
subroutine cgenmat(m, n, a, lda, testnum, myrow, mycol)
Definition blacstest.f:9608
zbsbrtest
subroutine zbsbrtest(outnum, verb, nscope, scope0, ntop, top0, nshape, uplo0, diag0, nmat, m0, n0, ldas0, ldad0, nsrc, rsrc0, csrc0, ngrid, context0, p0, q0, tfail, mem, memlen)
Definition blacstest.f:5585
iprinterrs
subroutine iprinterrs(outnum, maxerr, nerr, erribuf, errdbuf, counting, tfailed)
Definition blacstest.f:7148
dsdrvtest
subroutine dsdrvtest(outnum, verb, nshape, uplo0, diag0, nmat, m0, n0, ldas0, ldad0, nsrc, rsrc0, csrc0, rdest0, cdest0, ngrid, context0, p0, q0, tfail, mem, memlen)
Definition blacstest.f:2893
cchkmat
subroutine cchkmat(uplo, diag, m, n, a, lda, rsrc, csrc, myrow, mycol, testnum, maxerr, nerr, erribuf, errdbuf)
Definition blacstest.f:10133
rdbsbr
subroutine rdbsbr(memused, mem, memlen, cmemused, cmem, cmemlen, outnum)
Definition blacstest.f:1914
dchkamn
subroutine dchkamn(scope, ictxt, m, n, a, lda, ra, ca, ldi, testnum, maxerr, nerr, erribuf, errdbuf, iseed, vals)
Definition blacstest.f:20253
rdcomb
subroutine rdcomb(memused, mem, memlen, cmemused, cmem, cmemlen, outnum)
Definition blacstest.f:5998
iamntest
subroutine iamntest(outnum, verb, topsrepeat, topscohrnt, nscope, scope0, ntop, top0, nmat, m0, n0, ldas0, ldad0, ldi0, ndest, rdest0, cdest0, ngrid, context0, p0, q0, iseed, rmem, cmem, rclen, mem, memlen)
Definition blacstest.f:18499
ibtcheckin
subroutine ibtcheckin(nftests, outnum, maxerr, nerr, ierr, ival, tfailed)
Definition blacstest.f:6272
cbsbrtest
subroutine cbsbrtest(outnum, verb, nscope, scope0, ntop, top0, nshape, uplo0, diag0, nmat, m0, n0, ldas0, ldad0, nsrc, rsrc0, csrc0, ngrid, context0, p0, q0, tfail, mem, memlen)
Definition blacstest.f:5170
srcchk
subroutine srcchk(ipre, ipost, padval, m, n, ra, ca, ldi, myrow, mycol, testnum, maxerr, nerr, erribuf, errdbuf)
Definition blacstest.f:15701
zbtcheckin
subroutine zbtcheckin(nftests, outnum, maxerr, nerr, ierr, zval, tfailed)
Definition blacstest.f:10537
rdbtin
subroutine rdbtin(testsdrv, testbsbr, testcomb, testaux, nprec, prec, verb, outnum)
Definition blacstest.f:1145
zsdrvtest
subroutine zsdrvtest(outnum, verb, nshape, uplo0, diag0, nmat, m0, n0, ldas0, ldad0, nsrc, rsrc0, csrc0, rdest0, cdest0, ngrid, context0, p0, q0, tfail, mem, memlen)
Definition blacstest.f:3581
dpadmat
subroutine dpadmat(uplo, diag, m, n, mem, lda, ipre, ipost, checkval)
Definition blacstest.f:8636
dbtcheckin
subroutine dbtcheckin(nftests, outnum, maxerr, nerr, ierr, dval, tfailed)
Definition blacstest.f:8405
ibtmsgid
integer function ibtmsgid()
Definition blacstest.f:1361
ichkpad
subroutine ichkpad(uplo, diag, m, n, mem, lda, rsrc, csrc, myrow, mycol, ipre, ipost, checkval, testnum, maxerr, nerr, erribuf, errdbuf)
Definition blacstest.f:6682
ssumtest
subroutine ssumtest(outnum, verb, topsrepeat, topscohrnt, nscope, scope0, ntop, top0, nmat, m0, n0, ldas0, ldad0, ndest, rdest0, cdest0, ngrid, context0, p0, q0, iseed, mem, memlen)
Definition blacstest.f:12131
sbteps
real function sbteps()
Definition blacstest.f:12558
btrecv
subroutine btrecv(dtype, n, buff, src, msgid)
Definition btprim.f:207
btsetup
subroutine btsetup(mem, memlen, cmem, cmemlen, outnum, testsdrv, testbsbr, testcomb, testaux, iam, nnodes)
Definition btprim.f:4
ibtnprocs
integer function ibtnprocs()
Definition btprim.f:81
ibtmyproc
integer function ibtmyproc()
Definition btprim.f:47
btsend
subroutine btsend(dtype, n, buff, dest, msgid)
Definition btprim.f:115
ibtsizeof
integer function ibtsizeof(type)
Definition btprim.f:286
max
#define max(A, B)
Definition pcgemr.c:180
min
#define min(A, B)
Definition pcgemr.c:181
zlarnd
double complex function zlarnd(idist, iseed)
Definition tools.f:1899
dlarnd
double precision function dlarnd(idist, iseed)
Definition tools.f:1811
lsame
logical function lsame(ca, cb)
Definition tools.f:1724
slamch
real function slamch(cmach)
Definition tools.f:867
dlamch
double precision function dlamch(cmach)
Definition tools.f:10