33 INTEGER cmemsiz, memelts
34 parameter( memelts = 250000 )
35 parameter( cmemsiz = 10000 )
48 INTEGER i, iam, nnodes, verb, outnum, memlen, nprec, isize, dsize
49 LOGICAL testsdrv, testbsbr, testcomb, testaux
52 CHARACTER*1 cmem(cmemsiz), prec(9)
53 INTEGER iprec(9), itmp(2)
54 DOUBLE PRECISION mem(memelts)
63 CALL blacs_pinfo( iam, nnodes )
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)
78 $
CALL rdbtin( testsdrv, testbsbr, testcomb, testaux, nprec,
79 $ prec, verb, outnum )
81 memlen = (memelts * dsize) / isize
86 CALL btsetup( mem, memlen, cmem, cmemsiz, outnum, testsdrv,
87 $ testbsbr, testcomb, testaux, iam, nnodes )
102 IF( prec(i) .EQ.
'I' )
THEN
104 ELSE IF( prec(i) .EQ.
'S' )
THEN
106 ELSE IF( prec(i) .EQ.
'D' )
THEN
108 ELSE IF( prec(i) .EQ.
'C' )
THEN
110 ELSE IF( prec(i) .EQ.
'Z' )
THEN
114 IF( testsdrv ) iprec(6) = 1
115 IF( testbsbr ) iprec(7) = 1
116 IF( testcomb ) iprec(8) = 1
117 IF( testaux ) iprec(9) = 1
125 IF( iprec(i) .EQ. 1 )
THEN
127 ELSE IF( iprec(i) .EQ. 2 )
THEN
129 ELSE IF( iprec(i) .EQ. 3 )
THEN
131 ELSE IF( iprec(i) .EQ. 4 )
THEN
133 ELSE IF( iprec(i) .EQ. 5 )
THEN
137 testsdrv = ( iprec(6) .EQ. 1 )
138 testbsbr = ( iprec(7) .EQ. 1 )
139 testcomb = ( iprec(8) .EQ. 1 )
140 testaux = ( iprec(9) .EQ. 1 )
143 IF( testsdrv .OR. testbsbr .OR. testcomb .OR. testaux )
THEN
150 CALL runtests( mem, memlen, cmem, cmemsiz, prec, nprec, outnum,
151 $ verb, testsdrv, testbsbr, testcomb, testaux )
155 IF( iam .EQ. 0 )
THEN
160 WRITE(outnum,2000)
'NO'
162 WRITE(outnum,2000)
' '
166 IF( outnum.NE.0 .AND. outnum.NE.6 )
CLOSE(outnum)
170 1000
FORMAT(
'=======================================')
171 2000
FORMAT(
'THERE WERE ',a2,
' FAILURES IN THIS TEST RUN')
178 SUBROUTINE runtests( MEM, MEMLEN, CMEM, CMEMLEN, PREC, NPREC,
179 $ OUTNUM, VERB, TESTSDRV, TESTBSBR, TESTCOMB,
183 INTEGER MEMLEN, CMEMLEN, NPREC, OUTNUM, VERB, IAM, NNODES
184 LOGICAL TESTSDRV, TESTBSBR, TESTCOMB, TESTAUX
187 CHARACTER*1 CMEM(CMEMLEN), PREC(NPREC)
191 INTEGER IBTNPROCS, IBTMYPROC, IBTMSGID, IBTSIZEOF, SAFEINDEX
192 EXTERNAL IBTNPROCS, IBTMYPROC, IBTMSGID, IBTSIZEOF, SAFEINDEX
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
218 isize = ibtsizeof(
'I')
219 ssize = ibtsizeof(
'S')
220 dsize = ibtsizeof(
'D')
221 csize = ibtsizeof(
'C')
222 zsize = ibtsizeof(
'Z')
225 CALL blacs_get( 0, 2, i )
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
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
251 CALL btsend( 3, 4, itmp, 0, ibtmsgid()+2 )
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 )
271 ctxtptr = memused + 1
272 iseedptr = ctxtptr + ngrid
273 memused = iseedptr - 1
275 $ memused = memused + nshape * nmat * nsrc * ngrid
277 CALL makegrids( mem(ctxtptr), outnum, ngrid, mem(pptr),
283 IF( prec(i) .EQ.
'I' )
THEN
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)
295 ELSE IF( prec(i) .EQ.
'S' )
THEN
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)
307 ELSE IF( prec(i) .EQ.
'D' )
THEN
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)
319 ELSE IF( prec(i) .EQ.
'C' )
THEN
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)
331 ELSE IF( prec(i) .EQ.
'Z' )
THEN
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)
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 )
361 ctxtptr = memused + 1
362 iseedptr = ctxtptr + ngrid
363 memused = iseedptr - 1
365 $ memused = memused + nscope*ntop*nshape*nmat*nsrc*ngrid
367 CALL makegrids( mem(ctxtptr), outnum, ngrid, mem(pptr),
373 IF( prec(i) .EQ.
'I' )
THEN
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)
385 ELSE IF( prec(i) .EQ.
'S' )
THEN
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)
397 ELSE IF( prec(i) .EQ.
'D' )
THEN
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)
409 ELSE IF( prec(i) .EQ.
'C' )
THEN
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)
421 ELSE IF( prec(i) .EQ.
'Z' )
THEN
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)
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
455 IF( cmem(opptr+j).EQ.
'>' .OR. cmem(opptr+j).EQ.
'<' )
THEN
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) +
475 IF( verb.LT.2 ) i = nscope * ntop * nmat * ndest * ngrid
476 memused = iseedptr +
max( 4*nnodes, i )
478 CALL makegrids( mem(ctxtptr), outnum, ngrid, mem(pptr),
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),
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)
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),
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)
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),
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)
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),
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)
624 CALL auxtest( outnum, mem, memlen )
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(
'==============================================')
639 SUBROUTINE makegrids( CONTEXTS, OUTNUM, NGRIDS, P, Q )
640 INTEGER NGRIDS, OUTNUM
641 INTEGER CONTEXTS(NGRIDS), P(NGRIDS), Q(NGRIDS)
644 INTEGER NPROW, NPCOL, MYROW, MYCOL, I
647 CALL blacs_get( 0, 0, contexts(i) )
648 CALL blacs_gridinit( contexts(i),
'r', p(i), q(i) )
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
657 IF( outnum .NE. 6 .AND. outnum .NE. 0 )
CLOSE(outnum)
658 CALL blacs_abort( contexts(i), -1 )
663 1000
FORMAT(
'Grid creation error trying to create grid #',i3)
669 INTEGER CONTEXTS(NGRIDS)
670 INTEGER I, NPROW, NPCOL, MYROW, MYCOL
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) )
680 SUBROUTINE auxtest( OUTNUM, MEM, MEMLEN )
683 INTEGER OUTNUM, MEMLEN
690 INTEGER IBTMYPROC, IBTMSGID, BLACS_PNUM
691 DOUBLE PRECISION DWALLTIME00
692 EXTERNAL allpass, ibtmyproc, ibtmsgid, blacs_pnum
696 EXTERNAL blacs_pinfo, blacs_gridinit, blacs_gridmap
697 EXTERNAL blacs_freebuff, blacs_gridexit, blacs_abort
698 EXTERNAL blacs_gridinfo, blacs_pcoord, blacs_barrier
702 LOGICAL AUXPASSED, PASSED, IPRINT
703 INTEGER NPROCS, NPROW, NPCOL, MYROW, MYCOL, CTXT, CTXT2, LDA
705 DOUBLE PRECISION DTIME, DEPS
708 DOUBLE PRECISION START(2), STST(2), KEEP(2)
712 iprint = ( ibtmyproc() .EQ. 0 )
718 CALL blacs_pinfo( i, nprocs )
719 IF( nprocs .LT. 2 )
THEN
721 $
WRITE(outnum,*)
'NOT ENOUGH PROCESSES TO PERFORM AUXTESTS'
729 WRITE(outnum,*)
'RUNNING BLACS_PNUM/BLACS_PCOORD TEST'
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
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 )
744 CALL igsum2d( ctxt,
'a',
' ', 1, 1, k, 1, -1, 0 )
745 passed = ( k .EQ. 0 )
749 WRITE(outnum,*)
'PASSED BLACS_PNUM/BLACS_PCOORD TEST'
751 WRITE(outnum,*)
'FAILED BLACS_PNUM/BLACS_PCOORD TEST'
761 IF( iprint )
WRITE(outnum,*)
'RUNNING REPEATABLE SUM TEST'
768 start(1) = start(1) / 2.0d0
769 stst(1) = 1.0d0 + start(1)
770 IF (stst(1) .NE. 1.0d0)
GOTO 15
772 start(1) = deps / dble(npcol-1)
773 IF (mycol .EQ. 3) start(1) = 1.0d0
774 start(2) = 7.00005d0 * npcol
777 CALL blacs_set(ctxt, 15, j)
778 CALL dgsum2d(ctxt,
'a',
'f', 2, 1, stst, 2, -1, 0)
785 IF (mycol .EQ. i)
THEN
786 dtime = dwalltime00()
788 IF (dwalltime00() - dtime .LT. 2.0d0)
GOTO 20
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)) )
798 CALL igsum2d( ctxt,
'a',
' ', 1, 1, k, 1, -1, 0 )
801 IF (.NOT.passed)
THEN
804 ELSE IF( iprint )
THEN
805 WRITE(outnum,*)
'SKIPPED REPEATABLE SUM TEST'
811 auxpassed = auxpassed .AND. passed
814 WRITE(outnum,*)
'PASSED REPEATABLE SUM TEST'
816 WRITE(outnum,*)
'FAILED REPEATABLE SUM TEST'
826 IF( iprint )
WRITE(outnum,*)
'RUNNING BLACS_GRIDMAP TEST'
828 npcol = nprocs / nprow
829 DO 40 i = 0, nprocs-1
830 mem(i+1) = blacs_pnum( ctxt, 0, mod(i+npcol, nprocs) )
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 )
840 k = blacs_pnum( ctxt2, myrow, mycol )
841 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
THEN
844 IF( i.NE.0 .OR. j.NE.0 )
845 $
CALL igerv2d( ctxt2, 1, 1, k, 1, i, j )
847 $ passed = ( k .EQ. blacs_pnum(ctxt2, i, j) )
851 CALL igesd2d( ctxt2, 1, 1, k, 1, 0, 0 )
856 CALL igsum2d( ctxt,
'a',
' ', 1, 1, k, 1, -1, 0 )
857 passed = ( k .EQ. 0 )
858 auxpassed = auxpassed .AND. passed
861 WRITE(outnum,*)
'PASSED BLACS_GRIDMAP TEST'
863 WRITE(outnum,*)
'FAILED BLACS_GRIDMAP TEST'
868 IF( iprint )
WRITE(outnum,*)
'CALL BLACS_FREEBUFF'
869 CALL blacs_freebuff( ctxt, 0 )
870 CALL blacs_freebuff( ctxt, 1 )
872 CALL igsum2d( ctxt2,
'All',
' ', 1, 1, j, 1, -1, mycol )
874 WRITE(outnum,*)
'DONE BLACS_FREEBUFF'
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')
891 CALL igsum2d( ctxt2,
'All',
' ', 1, 1, j, 1, -1, mycol )
893 WRITE(outnum,*)
'DONE BARRIER'
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'
904 k =
min( memlen, 50000 )
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 )
928 CALL igsum2d( ctxt2,
'All',
' ', 1, 1, j, 1, -1, mycol )
930 $
WRITE(outnum,*)
'PASSED LOCALLY-BLOCKING CONTIGUOUS SEND TEST'
936 i =
max( 2, lda / 4 )
938 $
WRITE(outnum,*)
'RUNNING LOCALLY-BLOCKING NON-CONTIGUOUS '//
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 )
955 CALL igsum2d( ctxt2,
'All',
' ', 1, 1, j, 1, -1, mycol )
957 WRITE(outnum,*)
'PASSED LOCALLY-BLOCKING NON-CONTIGUOUS '//
965 IF( iprint )
WRITE(outnum,*)
'RUNNING BLACS_SET/BLACS_GET TESTS'
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
982 CALL igsum2d( ctxt2,
'All',
' ', 1, 1, j, 1, -1, mycol )
984 auxpassed = auxpassed .AND. passed
987 WRITE(outnum,*)
'PASSED BLACS_SET/BLACS_GET TESTS'
989 WRITE(outnum,*)
'FAILED BLACS_SET/BLACS_GET TESTS'
994 IF( iprint )
WRITE(outnum,*)
'CALL BLACS_GRIDEXIT'
995 CALL blacs_gridexit(ctxt)
996 CALL blacs_gridexit(ctxt2)
998 WRITE(outnum,*)
'DONE BLACS_GRIDEXIT'
1004 passed = allpass(auxpassed)
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.'
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 )
1020 IF( myrow.EQ.nprow/2 .AND. mycol.EQ.npcol/2 )
THEN
1021 CALL blacs_abort( ctxt, -1 )
1031 IF( i.EQ.1 )
GOTO 110
1034 1000
FORMAT(
'AUXILIARY TESTS: BEGIN.')
1045 IF( transto .EQ.
'I' )
THEN
1047 imem(i) = ichar( cmem(i) )
1051 cmem(i) = char( imem(i) )
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 )
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,
1073 CHARACTER*1 CMEM(CMEMLEN)
1077 INTEGER IBTMYPROC, IBTMSGID, IBTSIZEOF
1078 EXTERNAL IBTMYPROC, IBTMSGID, IBTSIZEOF
1081 INTEGER IAM, ISIZE, DSIZE
1089 IF( iam .EQ. 0 )
THEN
1090 IF( test .EQ.
'S' )
THEN
1091 CALL rdsdrv( memused, mem, memlen, cmemused, cmem, cmemlen,
1093 ELSE IF( test .EQ.
'B' )
THEN
1094 CALL rdbsbr( memused, mem, memlen, cmemused, cmem, cmemlen,
1097 CALL rdcomb( memused, mem, memlen, cmemused, cmem, cmemlen,
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) )
1106 isize = ibtsizeof(
'I')
1107 dsize = ibtsizeof(
'D')
1108 WRITE(outnum,1000) ( (memused+cmemused)*isize + dsize-1 )
1110 CALL blacs_abort(-1, -1)
1112 CALL btsend( 3, memused+cmemused, mem, -1, ibtmsgid()+4 )
1114 CALL btrecv( 3, 2, itmp, 0, ibtmsgid()+3 )
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) )
1121 isize = ibtsizeof(
'I')
1122 dsize = ibtsizeof(
'D')
1123 WRITE(outnum,1000) ( (memused+cmemused)*isize + dsize-1 )
1125 CALL blacs_abort(-1, -1)
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,
1134 1000
FORMAT(
'MEM array too short to pack CMEM; increase to at least',
1143 SUBROUTINE rdbtin( TESTSDRV, TESTBSBR, TESTCOMB, TESTAUX, NPREC,
1144 $ PREC, VERB, OUTNUM )
1152 LOGICAL TESTSDRV, TESTBSBR, TESTCOMB, TESTAUX
1153 INTEGER NPREC, OUTNUM, VERB
1199 INTEGER PRECMAX, VERBMAX, IN
1200 PARAMETER ( PRECMAX = 5, verbmax = 2, in = 11 )
1208 CHARACTER*80 HEADER, OUTNAME
1244 OPEN( unit = in, file =
'bt.dat', status =
'OLD' )
1251 IF( outnum.NE.6 .AND. outnum.NE.0 )
1252 $
OPEN( unit = outnum, file = outname, status =
'UNKNOWN' )
1253 WRITE(outnum, *) header
1258 IF( lsame(ch,
'T') )
THEN
1260 ELSE IF( lsame(ch,
'F') )
THEN
1263 WRITE(outnum, 1000)
'SDRV', ch
1268 IF( lsame(ch,
'T') )
THEN
1270 ELSE IF(lsame( ch,
'F') )
THEN
1273 WRITE(outnum, 1000)
'BSBR', ch
1278 IF( lsame(ch,
'T') )
THEN
1280 ELSE IF( lsame(ch,
'F') )
THEN
1283 WRITE(outnum, 1000)
'COMB', ch
1288 IF( lsame(ch,
'T') )
THEN
1290 ELSE IF( lsame(ch,
'F') )
THEN
1293 WRITE(outnum, 1000)
'AUX ', ch
1300 IF( nprec .LT. 0 )
THEN
1302 ELSE IF( nprec. gt. precmax )
THEN
1303 WRITE(outnum, 2000) nprec, precmax, precmax
1307 READ(in, *) ( prec(i), i = 1, nprec )
1309 IF( lsame(prec(i),
'C') )
THEN
1311 ELSE IF( lsame(prec(i),
'D') )
THEN
1313 ELSE IF( lsame(prec(i),
'I') )
THEN
1315 ELSE IF( lsame(prec(i),
'S') )
THEN
1317 ELSE IF( lsame(prec(i),
'Z') )
THEN
1320 WRITE(outnum, 3000) prec(i)
1327 IF( verb .GT. verbmax )
THEN
1328 WRITE(outnum, 4000) verb, verbmax, verbmax
1330 ELSE IF( verb .LT. 0 )
THEN
1331 WRITE(outnum, 5000) verb
1337 IF( readerror )
THEN
1339 IF( outnum .NE. 6 .AND. outnum .NE. 0 )
CLOSE( outnum )
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.' )
1378 if (minid .EQ. -1) then
1379 CALL blacs_get( -1, 1, itmp )
1381 itmp(1) = itmp(1) + 1000
1382 CALL blacs_set( -1, 1, itmp )
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)
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
1446 IF( TEST .EQ.
'S' ) THEN
1448 nshape = mem(memlen-3)
1453 nmat = mem(memlen-2)
1455 nsrc = mem(memlen-1)
1462 ELSE IF ( test .EQ.
'B' )
THEN
1464 nscope = mem(memlen-5)
1467 ntop = mem(memlen-4)
1468 nshape = mem(memlen-3)
1469 nmat = mem(memlen-2)
1471 nsrc = mem(memlen-1)
1480 nscope = mem(memlen-6)
1481 trep = mem(memlen-5)
1482 tcoh = mem(memlen-4)
1483 ntop = mem(memlen-3)
1485 nmat = mem(memlen-2)
1488 ndest = mem(memlen-1)
1493 scopeptr = opptr + nop
1494 topptr = scopeptr + nscope
1495 uploptr = topptr + ntop
1496 diagptr = uploptr + nshape
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
1508 IF( nsrc .EQ. 0 ) nsrc = ndest
1516 INTEGER FUNCTION safeindex(INDX, SIZE1, SIZE2)
1519 INTEGER indx, size1, size2
1535 IF( mod(i*size1, size2) .EQ. 0 )
GOTO 20
1546 SUBROUTINE rdsdrv( MEMUSED, MEM, MEMLEN, CMEMUSED, CMEM, CMEMLEN,
1555 INTEGER MEMUSED, MEMLEN, CMEMUSED, CMEMLEN, OUTNUM
1558 CHARACTER*1 CMEM(CMEMLEN)
1595 PARAMETER( SDIN = 12 )
1602 INTEGER NSHAPE, NMAT, NSRC, NGRID, I, J
1603 INTEGER UPLOPTR, DIAGPTR, MPTR, NPTR, LDSPTR, LDDPTR, RSRCPTR
1604 INTEGER CSRCPTR, RDESTPTR, CDESTPTR, PPTR, QPTR
1639 OPEN(unit = sdin, file =
'sdrv.dat', status =
'OLD')
1643 READ(sdin, *) nshape
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)
1651 ELSE IF( nshape .LT. 1 )
THEN
1652 WRITE(outnum, 2000)
'MATRIX SHAPE.'
1653 IF( outnum .NE. 6 .AND. outnum .NE. 0 )
CLOSE(outnum)
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'
1668 WRITE(outnum, 3000)
'UPLO ', cmem(uploptr+i)
1669 IF( outnum .NE. 6 .AND. outnum .NE. 0 )
CLOSE(outnum)
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'
1682 WRITE(outnum, 3000)
'DIAG ', cmem(diagptr+i)
1683 IF( outnum .NE. 6 .AND. outnum .NE. 0 )
CLOSE(outnum)
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)
1701 ELSE IF( nmat .LT. 1 )
THEN
1702 WRITE(outnum, 2000)
'MATRIX.'
1703 IF( outnum .NE. 6 .AND. outnum .NE. 0 )
CLOSE(outnum)
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 )
1713 CALL chkmatdat( outnum,
'SDRV.dat', .false., nmat, mem(mptr),
1714 $ mem(nptr), mem(ldsptr), mem(lddptr), mem(lddptr) )
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)
1728 ELSE IF( nsrc .LT. 1 )
THEN
1729 WRITE(outnum, 2000)
'SRC/DEST.'
1730 IF( outnum .NE. 6 .AND. outnum .NE. 0 )
CLOSE(outnum)
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 )
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)
1749 ELSE IF( ngrid .LT. 1 )
THEN
1750 WRITE(outnum, 2000)
'PROCESS GRID'
1751 IF( outnum .NE. 6 .AND. outnum .NE. 0 )
CLOSE( outnum )
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 )
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)
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
1778 1000
FORMAT(
'Mem too short (',i4,
') to handle',i4,
' ',a20)
1779 2000
FORMAT(
'Must have at least one ',a20)
1780 3000
FORMAT(
'UNRECOGNIZABLE ',a5,
' ''', a1,
'''.')
1781 4000
FORMAT(
'Illegal process grid: {',i3,
',',i3,
'}.')
1789 SUBROUTINE chkmatdat( NOUT, INFILE, TSTFLAG, NMAT, M0, N0,
1790 $ LDAS0, LDAD0, LDI0 )
1803 INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT), LDI0(NMAT)
1849 IF( m0(i) .LT. 0 )
THEN
1850 WRITE(nout,1000) infile,
'M', m0(i)
1852 ELSE IF( n0(i) .LT. 0 )
THEN
1853 WRITE(nout,1000) infile,
'N', n0(i)
1855 ELSE IF( ldas0(i) .LT. m0(i) )
THEN
1856 WRITE(nout,2000) infile,
'LDASRC', ldas0(i), m0(i)
1858 ELSE IF( ldad0(i) .LT. m0(i) )
THEN
1859 WRITE(nout,2000) infile,
'LDADST', ldad0(i), m0(i)
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)
1869 IF( .NOT.matok )
THEN
1870 IF( nout .NE. 6 .AND. nout .NE. 0 )
CLOSE(nout)
1871 CALL blacs_abort(-1, 1)
1874 1000
FORMAT(a8,
' INPUT ERROR: Illegal ',a1,
'; value=',i6,
'.')
1875 2000
FORMAT(a8,
' INPUT ERROR: Illegal ',a6,
'; value=',i6,
', but M=',i6)
1880 LOGICAL FUNCTION allpass( THISTEST )
1903 DATA passhist /.true./
1906 passhist = (passhist .AND. thistest)
1912 SUBROUTINE rdbsbr( MEMUSED, MEM, MEMLEN, CMEMUSED, CMEM, CMEMLEN,
1921 INTEGER MEMUSED, MEMLEN, CMEMUSED, CMEMLEN, OUTNUM
1924 CHARACTER*1 CMEM(CMEMLEN)
1961 PARAMETER( SDIN = 12 )
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
2007 OPEN(unit = sdin, file =
'bsbr.dat', status =
'OLD')
2011 READ(sdin, *) nscope
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)
2018 ELSE IF( nscope .LT. 1 )
THEN
2019 WRITE(outnum, 2000)
'SCOPE.'
2020 IF( outnum .NE. 6 .AND. outnum .NE. 0 )
CLOSE(outnum)
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'
2033 WRITE(outnum, 3000)
'SCOPE', cmem(scopeptr+i)
2034 IF( outnum .NE. 6 .AND. outnum .NE. 0 )
CLOSE(outnum)
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)
2046 ELSE IF( ntop .LT. 1 )
THEN
2047 WRITE(outnum, 2000)
'TOPOLOGY.'
2048 IF( outnum .NE. 6 .AND. outnum .NE. 0 )
CLOSE(outnum)
2051 READ(sdin, *) ( cmem(topptr+i), i = 0, ntop-1 )
2056 READ(sdin, *) nshape
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)
2064 ELSE IF( nshape .LT. 1 )
THEN
2065 WRITE(outnum, 2000)
'MATRIX SHAPE.'
2066 IF( outnum .NE. 6 .AND. outnum .NE. 0 )
CLOSE(outnum)
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'
2081 WRITE(outnum, 3000)
'UPLO ', cmem(uploptr+i)
2082 IF( outnum .NE. 6 .AND. outnum .NE. 0 )
CLOSE(outnum)
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'
2095 WRITE(outnum, 3000)
'DIAG ', cmem(diagptr+i)
2096 IF( outnum .NE. 6 .AND. outnum .NE. 0 )
CLOSE(outnum)
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)
2114 ELSE IF( nmat .LT. 1 )
THEN
2115 WRITE(outnum, 2000)
'MATRIX.'
2116 IF( outnum .NE. 6 .AND. outnum .NE. 0 )
CLOSE(outnum)
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 )
2126 CALL chkmatdat( outnum,
'BSBR.dat', .false., nmat, mem(mptr),
2127 $ mem(nptr), mem(ldsptr), mem(lddptr), mem(lddptr) )
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)
2139 ELSE IF( nsrc .LT. 1 )
THEN
2140 WRITE(outnum, 2000)
'SRC.'
2141 IF( outnum .NE. 6 .AND. outnum .NE. 0 )
CLOSE(outnum)
2144 READ(sdin, *) ( mem(rsrcptr+i), i = 0, nsrc-1 )
2145 READ(sdin, *) ( mem(csrcptr+i), i = 0, nsrc-1 )
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)
2158 ELSE IF( ngrid .LT. 1 )
THEN
2159 WRITE(outnum, 2000)
'PROCESS GRID'
2160 IF( outnum .NE. 6 .AND. outnum .NE. 0 )
CLOSE( outnum )
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 )
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)
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
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,
'}.')
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 )
2212 INTEGER OUTNUM, VERB, NSHAPE, NMAT, NSRC, NGRID, MEMLEN
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(*)
2306 INTEGER IBTMYPROC, IBTSIZEOF
2307 EXTERNAL ALLPASS, IBTMYPROC, IBTSIZEOF
2310 EXTERNAL BLACS_GRIDINFO
2311 EXTERNAL ITRSD2D, IGESD2D, ITRRV2D, IGERV2D
2312 EXTERNAL IINITMAT, ICHKMAT, ICHKPAD, IBTCHECKIN
2315 CHARACTER*1 UPLO, DIAG
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
2329 isize = ibtsizeof(
'I')
2330 isize = ibtsizeof(
'I')
2334 IF( iam .EQ. 0 )
THEN
2335 WRITE(outnum, *)
' '
2336 WRITE(outnum, *)
' '
2337 WRITE(outnum, 1000 )
2338 IF( verb .GT. 0 )
THEN
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
2359 IF( verb .GT. 1 )
THEN
2369 k = n0(ima) * max0( ldas0(ima), ldad0(ima) ) + 4 * m0(ima)
2370 IF( k .GT. i ) i = k
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)
2378 erriptr = errdptr + maxerr
2386 DO 110 igr = 1, ngrid
2388 context = context0(igr)
2389 CALL blacs_gridinfo( context, nprow, npcol, myrow, mycol )
2391 DO 80 ish = 1, nshape
2402 testnum = testnum + 1
2405 IF( rsrc.GE.p0(igr) .OR. csrc.GE.q0(igr) )
THEN
2411 IF( rdest.GE.p0(igr) .OR. cdest.GE.q0(igr) )
THEN
2416 IF( verb .GT. 1 )
THEN
2417 IF( iam .EQ. 0 )
THEN
2418 WRITE(outnum, 7000) testnum,
'RUNNING',
2420 $ ldasrc, ldadst, rsrc, csrc,
2421 $ rdest, cdest, nprow, npcol
2432 IF( myrow .EQ. rsrc .AND. mycol .EQ. csrc )
THEN
2433 CALL iinitmat( uplo, diag, m, n, mem, ldasrc,
2434 $ ipre, ipost, scheckval, testnum,
2437 IF( uplo .EQ.
'U' .OR. uplo .EQ.
'L' )
THEN
2438 CALL itrsd2d( context, uplo, diag, m, n,
2439 $ mem(aptr), ldasrc, rdest, cdest )
2441 CALL igesd2d( context, m, n, mem(aptr),
2442 $ ldasrc, rdest, cdest )
2446 IF( myrow .EQ. rdest .AND. mycol .EQ. cdest )
THEN
2450 DO 50 k = 1, ipre+ipost+ldadst*n
2456 IF( uplo .EQ.
'U' .OR. uplo .EQ.
'L' )
THEN
2457 CALL itrrv2d( context, uplo, diag, m, n,
2458 $ mem(aptr), ldadst, rsrc, csrc )
2460 CALL igerv2d( context, m, n, mem(aptr),
2461 $ ldadst, rsrc, csrc )
2467 CALL ichkmat( uplo, diag, m, n, mem(aptr), ldadst,
2468 $ rsrc, csrc, myrow, mycol, testnum, maxerr,
2469 $ nerr, mem(erriptr), mem(errdptr) )
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
2478 IF( verb .GT. 1 )
THEN
2480 CALL ibtcheckin( 0, outnum, maxerr, nerr,
2481 $ mem(erriptr), mem(errdptr),
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
2490 WRITE(outnum, 7000) testnum,
'FAILED ',
2491 $ uplo, diag, m, n, ldasrc, ldadst,
2492 $ rsrc, csrc, rdest, cdest, nprow, npcol
2505 IF( verb .LT. 2 )
THEN
2507 CALL ibtcheckin( nfail, outnum, maxerr, nerr, mem(erriptr),
2508 $ mem(errdptr), tfail )
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
2515 WRITE(outnum, 9000 ) testnum, testnum-nskip-nfail,
2522 testok = allpass( (nfail.EQ.0) )
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,
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',
2535 9000
FORMAT(
'INTEGER SDRV TESTS:',i5,
' TESTS;',i5,
' PASSED,',
2536 $ i5,
' SKIPPED,',i5,
' FAILED.')
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 )
2556 INTEGER OUTNUM, VERB, NSHAPE, NMAT, NSRC, NGRID, MEMLEN
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(*)
2650 INTEGER IBTMYPROC, IBTSIZEOF
2651 EXTERNAL ALLPASS, IBTMYPROC, IBTSIZEOF
2654 EXTERNAL BLACS_GRIDINFO
2655 EXTERNAL STRSD2D, SGESD2D, STRRV2D, SGERV2D
2656 EXTERNAL SINITMAT, SCHKMAT, SCHKPAD, SBTCHECKIN
2659 CHARACTER*1 UPLO, DIAG
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
2673 isize = ibtsizeof(
'I')
2674 ssize = ibtsizeof(
'S')
2678 IF( iam .EQ. 0 )
THEN
2679 WRITE(outnum, *)
' '
2680 WRITE(outnum, *)
' '
2681 WRITE(outnum, 1000 )
2682 IF( verb .GT. 0 )
THEN
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
2703 IF( verb .GT. 1 )
THEN
2713 k = n0(ima) * max0( ldas0(ima), ldad0(ima) ) + 4 * m0(ima)
2714 IF( k .GT. i ) i = k
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)
2722 erriptr = errdptr + maxerr
2730 DO 110 igr = 1, ngrid
2732 context = context0(igr)
2733 CALL blacs_gridinfo( context, nprow, npcol, myrow, mycol )
2735 DO 80 ish = 1, nshape
2746 testnum = testnum + 1
2749 IF( rsrc.GE.p0(igr) .OR. csrc.GE.q0(igr) )
THEN
2755 IF( rdest.GE.p0(igr) .OR. cdest.GE.q0(igr) )
THEN
2760 IF( verb .GT. 1 )
THEN
2761 IF( iam .EQ. 0 )
THEN
2762 WRITE(outnum, 7000) testnum,
'RUNNING',
2764 $ ldasrc, ldadst, rsrc, csrc,
2765 $ rdest, cdest, nprow, npcol
2776 IF( myrow .EQ. rsrc .AND. mycol .EQ. csrc )
THEN
2777 CALL sinitmat( uplo, diag, m, n, mem, ldasrc,
2778 $ ipre, ipost, scheckval, testnum,
2781 IF( uplo .EQ.
'U' .OR. uplo .EQ.
'L' )
THEN
2782 CALL strsd2d( context, uplo, diag, m, n,
2783 $ mem(aptr), ldasrc, rdest, cdest )
2785 CALL sgesd2d( context, m, n, mem(aptr),
2786 $ ldasrc, rdest, cdest )
2790 IF( myrow .EQ. rdest .AND. mycol .EQ. cdest )
THEN
2794 DO 50 k = 1, ipre+ipost+ldadst*n
2800 IF( uplo .EQ.
'U' .OR. uplo .EQ.
'L' )
THEN
2801 CALL strrv2d( context, uplo, diag, m, n,
2802 $ mem(aptr), ldadst, rsrc, csrc )
2804 CALL sgerv2d( context, m, n, mem(aptr),
2805 $ ldadst, rsrc, csrc )
2811 CALL schkmat( uplo, diag, m, n, mem(aptr), ldadst,
2812 $ rsrc, csrc, myrow, mycol, testnum, maxerr,
2813 $ nerr, mem(erriptr), mem(errdptr) )
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
2822 IF( verb .GT. 1 )
THEN
2824 CALL sbtcheckin( 0, outnum, maxerr, nerr,
2825 $ mem(erriptr), mem(errdptr),
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
2834 WRITE(outnum, 7000) testnum,
'FAILED ',
2835 $ uplo, diag, m, n, ldasrc, ldadst,
2836 $ rsrc, csrc, rdest, cdest, nprow, npcol
2849 IF( verb .LT. 2 )
THEN
2851 CALL sbtcheckin( nfail, outnum, maxerr, nerr, mem(erriptr),
2852 $ mem(errdptr), tfail )
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
2859 WRITE(outnum, 9000 ) testnum, testnum-nskip-nfail,
2866 testok = allpass( (nfail.EQ.0) )
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,
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',
2879 9000
FORMAT(
'REAL SDRV TESTS:',i5,
' TESTS;',i5,
' PASSED,',
2880 $ i5,
' SKIPPED,',i5,
' FAILED.')
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 )
2900 INTEGER OUTNUM, VERB, NSHAPE, NMAT, NSRC, NGRID, MEMLEN
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)
2994 INTEGER IBTMYPROC, IBTSIZEOF
2995 EXTERNAL ALLPASS, IBTMYPROC, IBTSIZEOF
2998 EXTERNAL BLACS_GRIDINFO
2999 EXTERNAL DTRSD2D, DGESD2D, DTRRV2D, DGERV2D
3000 EXTERNAL DINITMAT, DCHKMAT, DCHKPAD, DBTCHECKIN
3003 CHARACTER*1 UPLO, DIAG
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
3017 isize = ibtsizeof(
'I')
3018 dsize = ibtsizeof(
'D')
3022 IF( iam .EQ. 0 )
THEN
3023 WRITE(outnum, *)
' '
3024 WRITE(outnum, *)
' '
3025 WRITE(outnum, 1000 )
3026 IF( verb .GT. 0 )
THEN
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
3047 IF( verb .GT. 1 )
THEN
3057 k = n0(ima) * max0( ldas0(ima), ldad0(ima) ) + 4 * m0(ima)
3058 IF( k .GT. i ) i = k
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)
3066 erriptr = errdptr + maxerr
3074 DO 110 igr = 1, ngrid
3076 context = context0(igr)
3077 CALL blacs_gridinfo( context, nprow, npcol, myrow, mycol )
3079 DO 80 ish = 1, nshape
3090 testnum = testnum + 1
3093 IF( rsrc.GE.p0(igr) .OR. csrc.GE.q0(igr) )
THEN
3099 IF( rdest.GE.p0(igr) .OR. cdest.GE.q0(igr) )
THEN
3104 IF( verb .GT. 1 )
THEN
3105 IF( iam .EQ. 0 )
THEN
3106 WRITE(outnum, 7000) testnum,
'RUNNING',
3108 $ ldasrc, ldadst, rsrc, csrc,
3109 $ rdest, cdest, nprow, npcol
3120 IF( myrow .EQ. rsrc .AND. mycol .EQ. csrc )
THEN
3121 CALL dinitmat( uplo, diag, m, n, mem, ldasrc,
3122 $ ipre, ipost, scheckval, testnum,
3125 IF( uplo .EQ.
'U' .OR. uplo .EQ.
'L' )
THEN
3126 CALL dtrsd2d( context, uplo, diag, m, n,
3127 $ mem(aptr), ldasrc, rdest, cdest )
3129 CALL dgesd2d( context, m, n, mem(aptr),
3130 $ ldasrc, rdest, cdest )
3134 IF( myrow .EQ. rdest .AND. mycol .EQ. cdest )
THEN
3138 DO 50 k = 1, ipre+ipost+ldadst*n
3144 IF( uplo .EQ.
'U' .OR. uplo .EQ.
'L' )
THEN
3145 CALL dtrrv2d( context, uplo, diag, m, n,
3146 $ mem(aptr), ldadst, rsrc, csrc )
3148 CALL dgerv2d( context, m, n, mem(aptr),
3149 $ ldadst, rsrc, csrc )
3155 CALL dchkmat( uplo, diag, m, n, mem(aptr), ldadst,
3156 $ rsrc, csrc, myrow, mycol, testnum, maxerr,
3157 $ nerr, mem(erriptr), mem(errdptr) )
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
3166 IF( verb .GT. 1 )
THEN
3168 CALL dbtcheckin( 0, outnum, maxerr, nerr,
3169 $ mem(erriptr), mem(errdptr),
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
3178 WRITE(outnum, 7000) testnum,
'FAILED ',
3179 $ uplo, diag, m, n, ldasrc, ldadst,
3180 $ rsrc, csrc, rdest, cdest, nprow, npcol
3193 IF( verb .LT. 2 )
THEN
3195 CALL dbtcheckin( nfail, outnum, maxerr, nerr, mem(erriptr),
3196 $ mem(errdptr), tfail )
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
3203 WRITE(outnum, 9000 ) testnum, testnum-nskip-nfail,
3210 testok = allpass( (nfail.EQ.0) )
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,
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',
3223 9000
FORMAT(
'DOUBLE PRECISION SDRV TESTS:',i5,
' TESTS;',i5,
' PASSED,',
3224 $ i5,
' SKIPPED,',i5,
' FAILED.')
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 )
3244 INTEGER OUTNUM, VERB, NSHAPE, NMAT, NSRC, NGRID, MEMLEN
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(*)
3338 INTEGER IBTMYPROC, IBTSIZEOF
3339 EXTERNAL ALLPASS, IBTMYPROC, IBTSIZEOF
3342 EXTERNAL BLACS_GRIDINFO
3343 EXTERNAL CTRSD2D, CGESD2D, CTRRV2D, CGERV2D
3344 EXTERNAL CINITMAT, CCHKMAT, CCHKPAD, CBTCHECKIN
3347 CHARACTER*1 UPLO, DIAG
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
3357 SCHECKVAL =
cmplx( -0.01, -0.01 )
3358 rcheckval =
cmplx( -0.02, -0.02 )
3361 isize = ibtsizeof(
'I')
3362 csize = ibtsizeof(
'C')
3366 IF( iam .EQ. 0 )
THEN
3367 WRITE(outnum, *)
' '
3368 WRITE(outnum, *)
' '
3369 WRITE(outnum, 1000 )
3370 IF( verb .GT. 0 )
THEN
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
3391 IF( verb .GT. 1 )
THEN
3401 k = n0(ima) * max0( ldas0(ima), ldad0(ima) ) + 4 * m0(ima)
3402 IF( k .GT. i ) i = k
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)
3410 erriptr = errdptr + maxerr
3418 DO 110 igr = 1, ngrid
3420 context = context0(igr)
3421 CALL blacs_gridinfo( context, nprow, npcol, myrow, mycol )
3423 DO 80 ish = 1, nshape
3434 testnum = testnum + 1
3437 IF( rsrc.GE.p0(igr) .OR. csrc.GE.q0(igr) )
THEN
3443 IF( rdest.GE.p0(igr) .OR. cdest.GE.q0(igr) )
THEN
3448 IF( verb .GT. 1 )
THEN
3449 IF( iam .EQ. 0 )
THEN
3450 WRITE(outnum, 7000) testnum,
'RUNNING',
3452 $ ldasrc, ldadst, rsrc, csrc,
3453 $ rdest, cdest, nprow, npcol
3464 IF( myrow .EQ. rsrc .AND. mycol .EQ. csrc )
THEN
3465 CALL cinitmat( uplo, diag, m, n, mem, ldasrc,
3466 $ ipre, ipost, scheckval, testnum,
3469 IF( uplo .EQ.
'U' .OR. uplo .EQ.
'L' )
THEN
3470 CALL ctrsd2d( context, uplo, diag, m, n,
3471 $ mem(aptr), ldasrc, rdest, cdest )
3473 CALL cgesd2d( context, m, n, mem(aptr),
3474 $ ldasrc, rdest, cdest )
3478 IF( myrow .EQ. rdest .AND. mycol .EQ. cdest )
THEN
3482 DO 50 k = 1, ipre+ipost+ldadst*n
3488 IF( uplo .EQ.
'U' .OR. uplo .EQ.
'L' )
THEN
3489 CALL ctrrv2d( context, uplo, diag, m, n,
3490 $ mem(aptr), ldadst, rsrc, csrc )
3492 CALL cgerv2d( context, m, n, mem(aptr),
3493 $ ldadst, rsrc, csrc )
3499 CALL cchkmat( uplo, diag, m, n, mem(aptr), ldadst,
3500 $ rsrc, csrc, myrow, mycol, testnum, maxerr,
3501 $ nerr, mem(erriptr), mem(errdptr) )
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
3510 IF( verb .GT. 1 )
THEN
3512 CALL cbtcheckin( 0, outnum, maxerr, nerr,
3513 $ mem(erriptr), mem(errdptr),
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
3522 WRITE(outnum, 7000) testnum,
'FAILED ',
3523 $ uplo, diag, m, n, ldasrc, ldadst,
3524 $ rsrc, csrc, rdest, cdest, nprow, npcol
3537 IF( verb .LT. 2 )
THEN
3539 CALL cbtcheckin( nfail, outnum, maxerr, nerr, mem(erriptr),
3540 $ mem(errdptr), tfail )
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
3547 WRITE(outnum, 9000 ) testnum, testnum-nskip-nfail,
3554 testok = allpass( (nfail.EQ.0) )
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,
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',
3567 9000
FORMAT(
'COMPLEX SDRV TESTS:',i5,
' TESTS;',i5,
' PASSED,',
3568 $ i5,
' SKIPPED,',i5,
' FAILED.')
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 )
3588 INTEGER OUTNUM, VERB, NSHAPE, NMAT, NSRC, NGRID, MEMLEN
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)
3682 INTEGER IBTMYPROC, IBTSIZEOF
3683 EXTERNAL ALLPASS, IBTMYPROC, IBTSIZEOF
3686 EXTERNAL BLACS_GRIDINFO
3687 EXTERNAL ZTRSD2D, ZGESD2D, ZTRRV2D, ZGERV2D
3688 EXTERNAL ZINITMAT, ZCHKMAT, ZCHKPAD, ZBTCHECKIN
3691 CHARACTER*1 UPLO, DIAG
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
3701 SCHECKVAL = dcmplx( -0.01d0, -0.01d0 )
3702 rcheckval = dcmplx( -0.02d0, -0.02d0 )
3705 isize = ibtsizeof(
'I')
3706 zsize = ibtsizeof(
'Z')
3710 IF( iam .EQ. 0 )
THEN
3711 WRITE(outnum, *)
' '
3712 WRITE(outnum, *)
' '
3713 WRITE(outnum, 1000 )
3714 IF( verb .GT. 0 )
THEN
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
3735 IF( verb .GT. 1 )
THEN
3745 k = n0(ima) * max0( ldas0(ima), ldad0(ima) ) + 4 * m0(ima)
3746 IF( k .GT. i ) i = k
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)
3754 erriptr = errdptr + maxerr
3762 DO 110 igr = 1, ngrid
3764 context = context0(igr)
3765 CALL blacs_gridinfo( context, nprow, npcol, myrow, mycol )
3767 DO 80 ish = 1, nshape
3778 testnum = testnum + 1
3781 IF( rsrc.GE.p0(igr) .OR. csrc.GE.q0(igr) )
THEN
3787 IF( rdest.GE.p0(igr) .OR. cdest.GE.q0(igr) )
THEN
3792 IF( verb .GT. 1 )
THEN
3793 IF( iam .EQ. 0 )
THEN
3794 WRITE(outnum, 7000) testnum,
'RUNNING',
3796 $ ldasrc, ldadst, rsrc, csrc,
3797 $ rdest, cdest, nprow, npcol
3808 IF( myrow .EQ. rsrc .AND. mycol .EQ. csrc )
THEN
3809 CALL zinitmat( uplo, diag, m, n, mem, ldasrc,
3810 $ ipre, ipost, scheckval, testnum,
3813 IF( uplo .EQ.
'U' .OR. uplo .EQ.
'L' )
THEN
3814 CALL ztrsd2d( context, uplo, diag, m, n,
3815 $ mem(aptr), ldasrc, rdest, cdest )
3817 CALL zgesd2d( context, m, n, mem(aptr),
3818 $ ldasrc, rdest, cdest )
3822 IF( myrow .EQ. rdest .AND. mycol .EQ. cdest )
THEN
3826 DO 50 k = 1, ipre+ipost+ldadst*n
3832 IF( uplo .EQ.
'U' .OR. uplo .EQ.
'L' )
THEN
3833 CALL ztrrv2d( context, uplo, diag, m, n,
3834 $ mem(aptr), ldadst, rsrc, csrc )
3836 CALL zgerv2d( context, m, n, mem(aptr),
3837 $ ldadst, rsrc, csrc )
3843 CALL zchkmat( uplo, diag, m, n, mem(aptr), ldadst,
3844 $ rsrc, csrc, myrow, mycol, testnum, maxerr,
3845 $ nerr, mem(erriptr), mem(errdptr) )
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
3854 IF( verb .GT. 1 )
THEN
3856 CALL zbtcheckin( 0, outnum, maxerr, nerr,
3857 $ mem(erriptr), mem(errdptr),
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
3866 WRITE(outnum, 7000) testnum,
'FAILED ',
3867 $ uplo, diag, m, n, ldasrc, ldadst,
3868 $ rsrc, csrc, rdest, cdest, nprow, npcol
3881 IF( verb .LT. 2 )
THEN
3883 CALL zbtcheckin( nfail, outnum, maxerr, nerr, mem(erriptr),
3884 $ mem(errdptr), tfail )
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
3891 WRITE(outnum, 9000 ) testnum, testnum-nskip-nfail,
3898 testok = allpass( (nfail.EQ.0) )
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,
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',
3911 9000
FORMAT(
'DOUBLE COMPLEX SDRV TESTS:',i5,
' TESTS;',i5,
' PASSED,',
3912 $ i5,
' SKIPPED,',i5,
' FAILED.')
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 )
3932 INTEGER OUTNUM, VERB, NSCOPE, NTOP, NSHAPE, NMAT, NSRC, NGRID
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(*)
4031 LOGICAL ALLPASS, LSAME
4032 INTEGER IBTMYPROC, IBTSIZEOF
4033 EXTERNAL ALLPASS, LSAME, IBTMYPROC, IBTSIZEOF
4036 EXTERNAL BLACS_GRIDINFO
4037 EXTERNAL ITRBS2D, IGEBS2D, ITRBR2D, IGEBR2D
4038 EXTERNAL IINITMAT, ICHKMAT, ICHKPAD, IBTCHECKIN
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
4056 isize = ibtsizeof(
'I')
4057 isize = ibtsizeof(
'I')
4061 IF( iam .EQ. 0 )
THEN
4062 WRITE(outnum, *)
' '
4063 WRITE(outnum, *)
' '
4064 WRITE(outnum, 1000 )
4065 IF( verb .GT. 0 )
THEN
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
4088 IF( verb .GT. 1 )
THEN
4098 k = n0(ima) * max0( ldas0(ima), ldad0(ima) ) + 4 * m0(ima)
4099 IF( k .GT. i ) i = k
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)
4107 erriptr = errdptr + maxerr
4115 DO 110 igr = 1, ngrid
4117 context = context0(igr)
4118 CALL blacs_gridinfo( context, nprow, npcol, myrow, mycol )
4120 ingrid = ( nprow .GT. 0 )
4122 DO 100 isc = 1, nscope
4130 IF( lsame(top,
'M') )
THEN
4132 IF( scope .EQ.
'R' )
THEN
4133 istart = -(npcol - 1)
4135 ELSE IF (scope .EQ.
'C')
THEN
4136 istart = -(nprow - 1)
4139 istart = -(nprow*npcol - 1)
4142 ELSE IF( lsame(top,
'T') )
THEN
4145 IF( scope .EQ.
'R' )
THEN
4147 ELSE IF (scope .EQ.
'C')
THEN
4150 istop = nprow*npcol - 1
4157 DO 80 ish = 1, nshape
4168 testnum = testnum + 1
4171 IF( rsrc.GE.p0(igr) .OR. csrc.GE.q0(igr) )
THEN
4175 IF( verb .GT. 1 )
THEN
4176 IF( iam .EQ. 0 )
THEN
4178 $ testnum,
'RUNNING',scope, top, uplo, diag,
4179 $ m, n, ldasrc, ldadst, rsrc, csrc,
4191 IF( (myrow.EQ.rsrc .AND. scope.EQ.
'R') .OR.
4192 $ (mycol.EQ.csrc .AND. scope.EQ.
'C') .OR.
4193 $ (scope .EQ.
'A') )
THEN
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,
4203 DO 20 j = istart, istop
4204 IF( j.EQ.0 )
GOTO 20
4206 $
CALL blacs_set(context, setwhat, j)
4207 IF( uplo.EQ.
'U' .OR. uplo.EQ.
'L' )
THEN
4208 CALL itrbs2d(context, scope, top,
4210 $ mem(aptr), ldasrc )
4212 CALL igebs2d(context, scope, top,
4220 ELSE IF( ingrid )
THEN
4221 DO 40 j = istart, istop
4222 IF( j.EQ.0 )
GOTO 40
4224 $
CALL blacs_set(context, setwhat, j)
4228 DO 30 k = 1, ipre+ipost+ldadst*n
4234 IF( uplo.EQ.
'U' .OR. uplo.EQ.
'L' )
THEN
4235 CALL itrbr2d(context, scope, top,
4237 $ mem(aptr), ldadst,
4240 CALL igebr2d(context, scope, top,
4242 $ ldadst, rsrc, csrc)
4248 CALL ichkmat(uplo, diag, m, n,
4249 $ mem(aptr), ldadst, rsrc, csrc,
4250 $ myrow, mycol, testnum, maxerr,
4251 $ nerr, mem(erriptr),
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))
4260 testok = ( i .EQ. nerr )
4264 IF( verb .GT. 1 )
THEN
4266 CALL ibtcheckin(0, outnum, maxerr, nerr,
4267 $ mem(erriptr), mem(errdptr),
4269 IF( iam .EQ. 0 )
THEN
4270 testok = ( testok .AND. (i.EQ.nerr) )
4272 WRITE(outnum,7000)testnum,
'PASSED ',
4273 $ scope, top, uplo, diag, m, n,
4274 $ ldasrc, ldadst, rsrc, csrc,
4278 WRITE(outnum,7000)testnum,
'FAILED ',
4279 $ scope, top, uplo, diag, m, n,
4280 $ ldasrc, ldadst, rsrc, csrc,
4296 IF( verb .LT. 2 )
THEN
4298 CALL ibtcheckin( nfail, outnum, maxerr, nerr, mem(erriptr),
4299 $ mem(errdptr), tfail )
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
4306 WRITE(outnum, 9000 ) testnum, testnum-nskip-nfail,
4313 testok = allpass( (nfail.EQ.0) )
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,
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',
4326 9000
FORMAT(
'INTEGER BSBR TESTS:',i5,
' TESTS;',i5,
' PASSED,',
4327 $ i5,
' SKIPPED,',i5,
' FAILED.')
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 )
4347 INTEGER OUTNUM, VERB, NSCOPE, NTOP, NSHAPE, NMAT, NSRC, NGRID
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(*)
4446 LOGICAL ALLPASS, LSAME
4447 INTEGER IBTMYPROC, IBTSIZEOF
4448 EXTERNAL ALLPASS, LSAME, IBTMYPROC, IBTSIZEOF
4451 EXTERNAL BLACS_GRIDINFO
4452 EXTERNAL STRBS2D, SGEBS2D, STRBR2D, SGEBR2D
4453 EXTERNAL SINITMAT, SCHKMAT, SCHKPAD, SBTCHECKIN
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
4471 isize = ibtsizeof(
'I')
4472 ssize = ibtsizeof(
'S')
4476 IF( iam .EQ. 0 )
THEN
4477 WRITE(outnum, *)
' '
4478 WRITE(outnum, *)
' '
4479 WRITE(outnum, 1000 )
4480 IF( verb .GT. 0 )
THEN
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
4503 IF( verb .GT. 1 )
THEN
4513 k = n0(ima) * max0( ldas0(ima), ldad0(ima) ) + 4 * m0(ima)
4514 IF( k .GT. i ) i = k
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)
4522 erriptr = errdptr + maxerr
4530 DO 110 igr = 1, ngrid
4532 context = context0(igr)
4533 CALL blacs_gridinfo( context, nprow, npcol, myrow, mycol )
4535 ingrid = ( nprow .GT. 0 )
4537 DO 100 isc = 1, nscope
4545 IF( lsame(top,
'M') )
THEN
4547 IF( scope .EQ.
'R' )
THEN
4548 istart = -(npcol - 1)
4550 ELSE IF (scope .EQ.
'C')
THEN
4551 istart = -(nprow - 1)
4554 istart = -(nprow*npcol - 1)
4557 ELSE IF( lsame(top,
'T') )
THEN
4560 IF( scope .EQ.
'R' )
THEN
4562 ELSE IF (scope .EQ.
'C')
THEN
4565 istop = nprow*npcol - 1
4572 DO 80 ish = 1, nshape
4583 testnum = testnum + 1
4586 IF( rsrc.GE.p0(igr) .OR. csrc.GE.q0(igr) )
THEN
4590 IF( verb .GT. 1 )
THEN
4591 IF( iam .EQ. 0 )
THEN
4593 $ testnum,
'RUNNING',scope, top, uplo, diag,
4594 $ m, n, ldasrc, ldadst, rsrc, csrc,
4606 IF( (myrow.EQ.rsrc .AND. scope.EQ.
'R') .OR.
4607 $ (mycol.EQ.csrc .AND. scope.EQ.
'C') .OR.
4608 $ (scope .EQ.
'A') )
THEN
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,
4618 DO 20 j = istart, istop
4619 IF( j.EQ.0 )
GOTO 20
4621 $
CALL blacs_set(context, setwhat, j)
4622 IF( uplo.EQ.
'U' .OR. uplo.EQ.
'L' )
THEN
4623 CALL strbs2d(context, scope, top,
4625 $ mem(aptr), ldasrc )
4627 CALL sgebs2d(context, scope, top,
4635 ELSE IF( ingrid )
THEN
4636 DO 40 j = istart, istop
4637 IF( j.EQ.0 )
GOTO 40
4639 $
CALL blacs_set(context, setwhat, j)
4643 DO 30 k = 1, ipre+ipost+ldadst*n
4649 IF( uplo.EQ.
'U' .OR. uplo.EQ.
'L' )
THEN
4650 CALL strbr2d(context, scope, top,
4652 $ mem(aptr), ldadst,
4655 CALL sgebr2d(context, scope, top,
4657 $ ldadst, rsrc, csrc)
4663 CALL schkmat(uplo, diag, m, n,
4664 $ mem(aptr), ldadst, rsrc, csrc,
4665 $ myrow, mycol, testnum, maxerr,
4666 $ nerr, mem(erriptr),
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))
4675 testok = ( i .EQ. nerr )
4679 IF( verb .GT. 1 )
THEN
4681 CALL sbtcheckin(0, outnum, maxerr, nerr,
4682 $ mem(erriptr), mem(errdptr),
4684 IF( iam .EQ. 0 )
THEN
4685 testok = ( testok .AND. (i.EQ.nerr) )
4687 WRITE(outnum,7000)testnum,
'PASSED ',
4688 $ scope, top, uplo, diag, m, n,
4689 $ ldasrc, ldadst, rsrc, csrc,
4693 WRITE(outnum,7000)testnum,
'FAILED ',
4694 $ scope, top, uplo, diag, m, n,
4695 $ ldasrc, ldadst, rsrc, csrc,
4711 IF( verb .LT. 2 )
THEN
4713 CALL sbtcheckin( nfail, outnum, maxerr, nerr, mem(erriptr),
4714 $ mem(errdptr), tfail )
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
4721 WRITE(outnum, 9000 ) testnum, testnum-nskip-nfail,
4728 testok = allpass( (nfail.EQ.0) )
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,
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',
4741 9000
FORMAT(
'REAL BSBR TESTS:',i5,
' TESTS;',i5,
' PASSED,',
4742 $ i5,
' SKIPPED,',i5,
' FAILED.')
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 )
4762 INTEGER OUTNUM, VERB, NSCOPE, NTOP, NSHAPE, NMAT, NSRC, NGRID
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)
4861 LOGICAL ALLPASS, LSAME
4862 INTEGER IBTMYPROC, IBTSIZEOF
4863 EXTERNAL ALLPASS, LSAME, IBTMYPROC, IBTSIZEOF
4866 EXTERNAL BLACS_GRIDINFO
4867 EXTERNAL DTRBS2D, DGEBS2D, DTRBR2D, DGEBR2D
4868 EXTERNAL DINITMAT, DCHKMAT, DCHKPAD, DBTCHECKIN
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
4886 isize = ibtsizeof(
'I')
4887 dsize = ibtsizeof(
'D')
4891 IF( iam .EQ. 0 )
THEN
4892 WRITE(outnum, *)
' '
4893 WRITE(outnum, *)
' '
4894 WRITE(outnum, 1000 )
4895 IF( verb .GT. 0 )
THEN
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
4918 IF( verb .GT. 1 )
THEN
4928 k = n0(ima) * max0( ldas0(ima), ldad0(ima) ) + 4 * m0(ima)
4929 IF( k .GT. i ) i = k
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)
4937 erriptr = errdptr + maxerr
4945 DO 110 igr = 1, ngrid
4947 context = context0(igr)
4948 CALL blacs_gridinfo( context, nprow, npcol, myrow, mycol )
4950 ingrid = ( nprow .GT. 0 )
4952 DO 100 isc = 1, nscope
4960 IF( lsame(top,
'M') )
THEN
4962 IF( scope .EQ.
'R' )
THEN
4963 istart = -(npcol - 1)
4965 ELSE IF (scope .EQ.
'C')
THEN
4966 istart = -(nprow - 1)
4969 istart = -(nprow*npcol - 1)
4972 ELSE IF( lsame(top,
'T') )
THEN
4975 IF( scope .EQ.
'R' )
THEN
4977 ELSE IF (scope .EQ.
'C')
THEN
4980 istop = nprow*npcol - 1
4987 DO 80 ish = 1, nshape
4998 testnum = testnum + 1
5001 IF( rsrc.GE.p0(igr) .OR. csrc.GE.q0(igr) )
THEN
5005 IF( verb .GT. 1 )
THEN
5006 IF( iam .EQ. 0 )
THEN
5008 $ testnum,
'RUNNING',scope, top, uplo, diag,
5009 $ m, n, ldasrc, ldadst, rsrc, csrc,
5021 IF( (myrow.EQ.rsrc .AND. scope.EQ.
'R') .OR.
5022 $ (mycol.EQ.csrc .AND. scope.EQ.
'C') .OR.
5023 $ (scope .EQ.
'A') )
THEN
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,
5033 DO 20 j = istart, istop
5034 IF( j.EQ.0 )
GOTO 20
5036 $
CALL blacs_set(context, setwhat, j)
5037 IF( uplo.EQ.
'U' .OR. uplo.EQ.
'L' )
THEN
5038 CALL dtrbs2d(context, scope, top,
5040 $ mem(aptr), ldasrc )
5042 CALL dgebs2d(context, scope, top,
5050 ELSE IF( ingrid )
THEN
5051 DO 40 j = istart, istop
5052 IF( j.EQ.0 )
GOTO 40
5054 $
CALL blacs_set(context, setwhat, j)
5058 DO 30 k = 1, ipre+ipost+ldadst*n
5064 IF( uplo.EQ.
'U' .OR. uplo.EQ.
'L' )
THEN
5065 CALL dtrbr2d(context, scope, top,
5067 $ mem(aptr), ldadst,
5070 CALL dgebr2d(context, scope, top,
5072 $ ldadst, rsrc, csrc)
5078 CALL dchkmat(uplo, diag, m, n,
5079 $ mem(aptr), ldadst, rsrc, csrc,
5080 $ myrow, mycol, testnum, maxerr,
5081 $ nerr, mem(erriptr),
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))
5090 testok = ( i .EQ. nerr )
5094 IF( verb .GT. 1 )
THEN
5096 CALL dbtcheckin(0, outnum, maxerr, nerr,
5097 $ mem(erriptr), mem(errdptr),
5099 IF( iam .EQ. 0 )
THEN
5100 testok = ( testok .AND. (i.EQ.nerr) )
5102 WRITE(outnum,7000)testnum,
'PASSED ',
5103 $ scope, top, uplo, diag, m, n,
5104 $ ldasrc, ldadst, rsrc, csrc,
5108 WRITE(outnum,7000)testnum,
'FAILED ',
5109 $ scope, top, uplo, diag, m, n,
5110 $ ldasrc, ldadst, rsrc, csrc,
5126 IF( verb .LT. 2 )
THEN
5128 CALL dbtcheckin( nfail, outnum, maxerr, nerr, mem(erriptr),
5129 $ mem(errdptr), tfail )
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
5136 WRITE(outnum, 9000 ) testnum, testnum-nskip-nfail,
5143 testok = allpass( (nfail.EQ.0) )
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,
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',
5156 9000
FORMAT(
'DOUBLE PRECISION BSBR TESTS:',i5,
' TESTS;',i5,
' PASSED,',
5157 $ i5,
' SKIPPED,',i5,
' FAILED.')
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 )
5177 INTEGER OUTNUM, VERB, NSCOPE, NTOP, NSHAPE, NMAT, NSRC, NGRID
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(*)
5276 LOGICAL ALLPASS, LSAME
5277 INTEGER IBTMYPROC, IBTSIZEOF
5278 EXTERNAL ALLPASS, LSAME, IBTMYPROC, IBTSIZEOF
5281 EXTERNAL BLACS_GRIDINFO
5282 EXTERNAL CTRBS2D, CGEBS2D, CTRBR2D, CGEBR2D
5283 EXTERNAL CINITMAT, CCHKMAT, CCHKPAD, CBTCHECKIN
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
5297 SCHECKVAL =
cmplx( -0.01, -0.01 )
5298 rcheckval =
cmplx( -0.02, -0.02 )
5301 isize = ibtsizeof(
'I')
5302 csize = ibtsizeof(
'C')
5306 IF( iam .EQ. 0 )
THEN
5307 WRITE(outnum, *)
' '
5308 WRITE(outnum, *)
' '
5309 WRITE(outnum, 1000 )
5310 IF( verb .GT. 0 )
THEN
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
5333 IF( verb .GT. 1 )
THEN
5343 k = n0(ima) * max0( ldas0(ima), ldad0(ima) ) + 4 * m0(ima)
5344 IF( k .GT. i ) i = k
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)
5352 erriptr = errdptr + maxerr
5360 DO 110 igr = 1, ngrid
5362 context = context0(igr)
5363 CALL blacs_gridinfo( context, nprow, npcol, myrow, mycol )
5365 ingrid = ( nprow .GT. 0 )
5367 DO 100 isc = 1, nscope
5375 IF( lsame(top,
'M') )
THEN
5377 IF( scope .EQ.
'R' )
THEN
5378 istart = -(npcol - 1)
5380 ELSE IF (scope .EQ.
'C')
THEN
5381 istart = -(nprow - 1)
5384 istart = -(nprow*npcol - 1)
5387 ELSE IF( lsame(top,
'T') )
THEN
5390 IF( scope .EQ.
'R' )
THEN
5392 ELSE IF (scope .EQ.
'C')
THEN
5395 istop = nprow*npcol - 1
5402 DO 80 ish = 1, nshape
5413 testnum = testnum + 1
5416 IF( rsrc.GE.p0(igr) .OR. csrc.GE.q0(igr) )
THEN
5420 IF( verb .GT. 1 )
THEN
5421 IF( iam .EQ. 0 )
THEN
5423 $ testnum,
'RUNNING',scope, top, uplo, diag,
5424 $ m, n, ldasrc, ldadst, rsrc, csrc,
5436 IF( (myrow.EQ.rsrc .AND. scope.EQ.
'R') .OR.
5437 $ (mycol.EQ.csrc .AND. scope.EQ.
'C') .OR.
5438 $ (scope .EQ.
'A') )
THEN
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,
5448 DO 20 j = istart, istop
5449 IF( j.EQ.0 )
GOTO 20
5451 $
CALL blacs_set(context, setwhat, j)
5452 IF( uplo.EQ.
'U' .OR. uplo.EQ.
'L' )
THEN
5453 CALL ctrbs2d(context, scope, top,
5455 $ mem(aptr), ldasrc )
5457 CALL cgebs2d(context, scope, top,
5465 ELSE IF( ingrid )
THEN
5466 DO 40 j = istart, istop
5467 IF( j.EQ.0 )
GOTO 40
5469 $
CALL blacs_set(context, setwhat, j)
5473 DO 30 k = 1, ipre+ipost+ldadst*n
5479 IF( uplo.EQ.
'U' .OR. uplo.EQ.
'L' )
THEN
5480 CALL ctrbr2d(context, scope, top,
5482 $ mem(aptr), ldadst,
5485 CALL cgebr2d(context, scope, top,
5487 $ ldadst, rsrc, csrc)
5493 CALL cchkmat(uplo, diag, m, n,
5494 $ mem(aptr), ldadst, rsrc, csrc,
5495 $ myrow, mycol, testnum, maxerr,
5496 $ nerr, mem(erriptr),
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))
5505 testok = ( i .EQ. nerr )
5509 IF( verb .GT. 1 )
THEN
5511 CALL cbtcheckin(0, outnum, maxerr, nerr,
5512 $ mem(erriptr), mem(errdptr),
5514 IF( iam .EQ. 0 )
THEN
5515 testok = ( testok .AND. (i.EQ.nerr) )
5517 WRITE(outnum,7000)testnum,
'PASSED ',
5518 $ scope, top, uplo, diag, m, n,
5519 $ ldasrc, ldadst, rsrc, csrc,
5523 WRITE(outnum,7000)testnum,
'FAILED ',
5524 $ scope, top, uplo, diag, m, n,
5525 $ ldasrc, ldadst, rsrc, csrc,
5541 IF( verb .LT. 2 )
THEN
5543 CALL cbtcheckin( nfail, outnum, maxerr, nerr, mem(erriptr),
5544 $ mem(errdptr), tfail )
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
5551 WRITE(outnum, 9000 ) testnum, testnum-nskip-nfail,
5558 testok = allpass( (nfail.EQ.0) )
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,
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',
5571 9000
FORMAT(
'COMPLEX BSBR TESTS:',i5,
' TESTS;',i5,
' PASSED,',
5572 $ i5,
' SKIPPED,',i5,
' FAILED.')
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 )
5592 INTEGER OUTNUM, VERB, NSCOPE, NTOP, NSHAPE, NMAT, NSRC, NGRID
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)
5691 LOGICAL ALLPASS, LSAME
5692 INTEGER IBTMYPROC, IBTSIZEOF
5693 EXTERNAL ALLPASS, LSAME, IBTMYPROC, IBTSIZEOF
5696 EXTERNAL BLACS_GRIDINFO
5697 EXTERNAL ZTRBS2D, ZGEBS2D, ZTRBR2D, ZGEBR2D
5698 EXTERNAL ZINITMAT, ZCHKMAT, ZCHKPAD, ZBTCHECKIN
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
5712 SCHECKVAL = dcmplx( -0.01d0, -0.01d0 )
5713 rcheckval = dcmplx( -0.02d0, -0.02d0 )
5716 isize = ibtsizeof(
'I')
5717 zsize = ibtsizeof(
'Z')
5721 IF( iam .EQ. 0 )
THEN
5722 WRITE(outnum, *)
' '
5723 WRITE(outnum, *)
' '
5724 WRITE(outnum, 1000 )
5725 IF( verb .GT. 0 )
THEN
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
5748 IF( verb .GT. 1 )
THEN
5758 k = n0(ima) * max0( ldas0(ima), ldad0(ima) ) + 4 * m0(ima)
5759 IF( k .GT. i ) i = k
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)
5767 erriptr = errdptr + maxerr
5775 DO 110 igr = 1, ngrid
5777 context = context0(igr)
5778 CALL blacs_gridinfo( context, nprow, npcol, myrow, mycol )
5780 ingrid = ( nprow .GT. 0 )
5782 DO 100 isc = 1, nscope
5790 IF( lsame(top,
'M') )
THEN
5792 IF( scope .EQ.
'R' )
THEN
5793 istart = -(npcol - 1)
5795 ELSE IF (scope .EQ.
'C')
THEN
5796 istart = -(nprow - 1)
5799 istart = -(nprow*npcol - 1)
5802 ELSE IF( lsame(top,
'T') )
THEN
5805 IF( scope .EQ.
'R' )
THEN
5807 ELSE IF (scope .EQ.
'C')
THEN
5810 istop = nprow*npcol - 1
5817 DO 80 ish = 1, nshape
5828 testnum = testnum + 1
5831 IF( rsrc.GE.p0(igr) .OR. csrc.GE.q0(igr) )
THEN
5835 IF( verb .GT. 1 )
THEN
5836 IF( iam .EQ. 0 )
THEN
5838 $ testnum,
'RUNNING',scope, top, uplo, diag,
5839 $ m, n, ldasrc, ldadst, rsrc, csrc,
5851 IF( (myrow.EQ.rsrc .AND. scope.EQ.
'R') .OR.
5852 $ (mycol.EQ.csrc .AND. scope.EQ.
'C') .OR.
5853 $ (scope .EQ.
'A') )
THEN
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,
5863 DO 20 j = istart, istop
5864 IF( j.EQ.0 )
GOTO 20
5866 $
CALL blacs_set(context, setwhat, j)
5867 IF( uplo.EQ.
'U' .OR. uplo.EQ.
'L' )
THEN
5868 CALL ztrbs2d(context, scope, top,
5870 $ mem(aptr), ldasrc )
5872 CALL zgebs2d(context, scope, top,
5880 ELSE IF( ingrid )
THEN
5881 DO 40 j = istart, istop
5882 IF( j.EQ.0 )
GOTO 40
5884 $
CALL blacs_set(context, setwhat, j)
5888 DO 30 k = 1, ipre+ipost+ldadst*n
5894 IF( uplo.EQ.
'U' .OR. uplo.EQ.
'L' )
THEN
5895 CALL ztrbr2d(context, scope, top,
5897 $ mem(aptr), ldadst,
5900 CALL zgebr2d(context, scope, top,
5902 $ ldadst, rsrc, csrc)
5908 CALL zchkmat(uplo, diag, m, n,
5909 $ mem(aptr), ldadst, rsrc, csrc,
5910 $ myrow, mycol, testnum, maxerr,
5911 $ nerr, mem(erriptr),
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))
5920 testok = ( i .EQ. nerr )
5924 IF( verb .GT. 1 )
THEN
5926 CALL zbtcheckin(0, outnum, maxerr, nerr,
5927 $ mem(erriptr), mem(errdptr),
5929 IF( iam .EQ. 0 )
THEN
5930 testok = ( testok .AND. (i.EQ.nerr) )
5932 WRITE(outnum,7000)testnum,
'PASSED ',
5933 $ scope, top, uplo, diag, m, n,
5934 $ ldasrc, ldadst, rsrc, csrc,
5938 WRITE(outnum,7000)testnum,
'FAILED ',
5939 $ scope, top, uplo, diag, m, n,
5940 $ ldasrc, ldadst, rsrc, csrc,
5956 IF( verb .LT. 2 )
THEN
5958 CALL zbtcheckin( nfail, outnum, maxerr, nerr, mem(erriptr),
5959 $ mem(errdptr), tfail )
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
5966 WRITE(outnum, 9000 ) testnum, testnum-nskip-nfail,
5973 testok = allpass( (nfail.EQ.0) )
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,
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',
5986 9000
FORMAT(
'DOUBLE COMPLEX BSBR TESTS:',i5,
' TESTS;',i5,
' PASSED,',
5987 $ i5,
' SKIPPED,',i5,
' FAILED.')
5996 SUBROUTINE rdcomb( MEMUSED, MEM, MEMLEN, CMEMUSED, CMEM, CMEMLEN,
6005 INTEGER MEMUSED, MEMLEN, CMEMUSED, CMEMLEN, OUTNUM
6008 CHARACTER*1 CMEM(CMEMLEN)
6045 PARAMETER( SDIN = 12 )
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
6090 OPEN(unit = sdin, file =
'comb.dat', status =
'OLD')
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)
6101 ELSE IF( nops .LT. 1 )
THEN
6102 WRITE(outnum, 2000)
'OPERATIONS.'
6103 IF( outnum .NE. 6 .AND. outnum .NE. 0 )
CLOSE(outnum)
6107 READ(sdin, *) ( cmem(opptr+i), 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)
6119 READ(sdin, *) nscope
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)
6126 ELSE IF( nscope .LT. 1 )
THEN
6127 WRITE(outnum, 2000)
'SCOPE.'
6128 IF( outnum .NE. 6 .AND. outnum .NE. 0 )
CLOSE(outnum)
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'
6141 WRITE(outnum, 3000)
'SCOPE', cmem(scopeptr+i)
6142 IF( outnum .NE. 6 .AND. outnum .NE. 0 )
CLOSE(outnum)
6147 READ(sdin, *) topsrepeat
6148 READ(sdin, *) topscohrnt
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)
6157 ELSE IF( ntop .LT. 1 )
THEN
6158 WRITE(outnum, 2000)
'TOPOLOGY.'
6159 IF( outnum .NE. 6 .AND. outnum .NE. 0 )
CLOSE(outnum)
6162 READ(sdin, *) ( cmem(topptr+i), i = 0, ntop-1 )
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)
6178 ELSE IF( nmat .LT. 1 )
THEN
6179 WRITE(outnum, 2000)
'MATRIX.'
6180 IF( outnum .NE. 6 .AND. outnum .NE. 0 )
CLOSE(outnum)
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 )
6191 CALL chkmatdat( outnum,
'COMB.dat', .true., nmat, mem(mptr),
6192 $ mem(nptr), mem(ldsptr), mem(lddptr), mem(ldiptr) )
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)
6204 ELSE IF( ndest .LT. 1 )
THEN
6205 WRITE(outnum, 2000)
'DEST.'
6206 IF( outnum .NE. 6 .AND. outnum .NE. 0 )
CLOSE(outnum)
6209 READ(sdin, *) ( mem(rdestptr+i), i = 0, ndest-1 )
6210 READ(sdin, *) ( mem(cdestptr+i), i = 0, ndest-1 )
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)
6223 ELSE IF( ngrid .LT. 1 )
THEN
6224 WRITE(outnum, 2000)
'PROCESS GRID'
6225 IF( outnum .NE. 6 .AND. outnum .NE. 0 )
CLOSE( outnum )
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 )
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)
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
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).')
6270 SUBROUTINE ibtcheckin( NFTESTS, OUTNUM, MAXERR, NERR, IERR,
6272 INTEGER NFTESTS, OUTNUM, MAXERR, NERR
6273 INTEGER IERR(*), TFAILED(*)
6326 INTEGER IBTMYPROC, IBTNPROCS, IBTMSGID
6327 EXTERNAL IBTMYPROC, IBTNPROCS, IBTMSGID
6331 INTEGER K, NERR2, IAM, NPROCS, NTESTS
6336 nprocs = ibtnprocs()
6338 IF( iam .EQ. 0 )
THEN
6343 counting = nftests .GT. 0
6351 CALL iprinterrs(outnum, maxerr, nerr, ierr, ival, counting,
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
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)
6371 nftests = nftests + tfailed(k)
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)
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
6404 CALL igenmat( m, n, mem(ipre+1), lda, testnum, myrow, mycol )
6405 CALL ipadmat( uplo, diag, m, n, mem, lda, ipre, ipost, checkval )
6410 SUBROUTINE igenmat( M, N, A, LDA, TESTNUM, MYROW, MYCOL )
6418 INTEGER M, N, LDA, TESTNUM, MYROW, MYCOL
6452 EXTERNAL ibtran, ibtnprocs
6455 INTEGER I, J, NPROCS, SRC
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 )
6476 a(i, j) = ibtran( iseed )
6485 INTEGER FUNCTION ibtran(ISEED)
6493 DOUBLE PRECISION dval
6497 dval = 1.0d6 *
dlarnd(2, iseed)
6506 SUBROUTINE ipadmat( UPLO, DIAG, M, N, MEM, LDA, IPRE, IPOST,
6514 CHARACTER*1 UPLO, DIAG
6515 INTEGER M, N, LDA, IPRE, IPOST
6573 IF( ipre .GT. 0 )
THEN
6581 IF( ipost .GT. 0 )
THEN
6582 j = ipre + lda*n + 1
6583 DO 20 i = j, j+ipost-1
6590 IF( lda .GT. m )
THEN
6593 DO 30 i = k, k+lda-m-1
6604 IF( uplo .EQ.
'U' )
THEN
6606 IF( diag .EQ.
'U' )
THEN
6609 k = ipre + i + (j-1)*lda
6616 k = ipre + i + (j-1)*lda
6622 IF( diag .EQ.
'U' )
THEN
6624 DO 46 j = 1, i-(m-n)
6625 k = ipre + i + (j-1)*lda
6631 DO 48 j = 1, i-(m-n)-1
6632 k = ipre + i + (j-1)*lda
6638 ELSE IF( uplo .EQ.
'L' )
THEN
6640 IF( diag .EQ.
'U' )
THEN
6643 k = ipre + i + (j-1)*lda
6649 DO 52 j = n-m+i+1, n
6650 k = ipre + i + (j-1)*lda
6656 IF( uplo .EQ.
'U' )
THEN
6659 k = ipre + i + (j-1)*lda
6666 k = ipre + i + (j-1)*lda
6679 SUBROUTINE ichkpad( UPLO, DIAG, M, N, MEM, LDA, RSRC, CSRC,
6680 $ MYROW, MYCOL, IPRE, IPOST, CHECKVAL,
6681 $ TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF )
6689 CHARACTER*1 UPLO, DIAG
6690 INTEGER M, N, LDA, RSRC, CSRC, MYROW, MYCOL, IPRE, IPOST
6691 INTEGER TESTNUM, MAXERR, NERR
6695 INTEGER ERRIBUF(6, MAXERR)
6696 INTEGER MEM(*), ERRDBUF(2, MAXERR)