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

◆ pzbla2tstinfo()

subroutine pzbla2tstinfo ( character*( * )  summry,
integer  nout,
integer  nmat,
character*1, dimension( ldval )  diagval,
character*1, dimension( ldval )  tranval,
character*1, dimension( ldval )  uploval,
integer, dimension( ldval )  mval,
integer, dimension( ldval )  nval,
integer, dimension( ldval )  maval,
integer, dimension( ldval )  naval,
integer, dimension( ldval )  imbaval,
integer, dimension( ldval )  mbaval,
integer, dimension( ldval )  inbaval,
integer, dimension( ldval )  nbaval,
integer, dimension( ldval )  rscaval,
integer, dimension( ldval )  cscaval,
integer, dimension( ldval )  iaval,
integer, dimension( ldval )  javal,
integer, dimension( ldval )  mxval,
integer, dimension( ldval )  nxval,
integer, dimension( ldval )  imbxval,
integer, dimension( ldval )  mbxval,
integer, dimension( ldval )  inbxval,
integer, dimension( ldval )  nbxval,
integer, dimension( ldval )  rscxval,
integer, dimension( ldval )  cscxval,
integer, dimension( ldval )  ixval,
integer, dimension( ldval )  jxval,
integer, dimension( ldval )  incxval,
integer, dimension( ldval )  myval,
integer, dimension( ldval )  nyval,
integer, dimension( ldval )  imbyval,
integer, dimension( ldval )  mbyval,
integer, dimension( ldval )  inbyval,
integer, dimension( ldval )  nbyval,
integer, dimension( ldval )  rscyval,
integer, dimension( ldval )  cscyval,
integer, dimension( ldval )  iyval,
integer, dimension( ldval )  jyval,
integer, dimension( ldval )  incyval,
integer  ldval,
integer  ngrids,
integer, dimension( ldpval )  pval,
integer  ldpval,
integer, dimension( ldqval )  qval,
integer  ldqval,
integer  nblog,
logical, dimension( * )  ltest,
logical  sof,
logical  tee,
integer  iam,
integer  igap,
integer  iverb,
integer  nprocs,
real  thresh,
complex*16  alpha,
complex*16  beta,
integer, dimension( * )  work 
)

Definition at line 1138 of file pzblas2tst.f.

1151*
1152* -- PBLAS test routine (version 2.0) --
1153* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
1154* and University of California, Berkeley.
1155* April 1, 1998
1156*
1157* .. Scalar Arguments ..
1158 LOGICAL SOF, TEE
1159 INTEGER IAM, IGAP, IVERB, LDPVAL, LDQVAL, LDVAL, NBLOG,
1160 $ NGRIDS, NMAT, NOUT, NPROCS
1161 REAL THRESH
1162 COMPLEX*16 ALPHA, BETA
1163* ..
1164* .. Array Arguments ..
1165 CHARACTER*( * ) SUMMRY
1166 CHARACTER*1 DIAGVAL( LDVAL ), TRANVAL( LDVAL ),
1167 $ UPLOVAL( LDVAL )
1168 LOGICAL LTEST( * )
1169 INTEGER CSCAVAL( LDVAL ), CSCXVAL( LDVAL ),
1170 $ CSCYVAL( LDVAL ), IAVAL( LDVAL ),
1171 $ IMBAVAL( LDVAL ), IMBXVAL( LDVAL ),
1172 $ IMBYVAL( LDVAL ), INBAVAL( LDVAL ),
1173 $ INBXVAL( LDVAL ), INBYVAL( LDVAL ),
1174 $ INCXVAL( LDVAL ), INCYVAL( LDVAL ),
1175 $ IXVAL( LDVAL ), IYVAL( LDVAL ), JAVAL( LDVAL ),
1176 $ JXVAL( LDVAL ), JYVAL( LDVAL ), MAVAL( LDVAL ),
1177 $ MBAVAL( LDVAL ), MBXVAL( LDVAL ),
1178 $ MBYVAL( LDVAL ), MVAL( LDVAL ), MXVAL( LDVAL ),
1179 $ MYVAL( LDVAL ), NAVAL( LDVAL ),
1180 $ NBAVAL( LDVAL ), NBXVAL( LDVAL ),
1181 $ NBYVAL( LDVAL ), NVAL( LDVAL ), NXVAL( LDVAL ),
1182 $ NYVAL( LDVAL ), PVAL( LDPVAL ), QVAL( LDQVAL ),
1183 $ RSCAVAL( LDVAL ), RSCXVAL( LDVAL ),
1184 $ RSCYVAL( LDVAL ), WORK( * )
1185* ..
1186*
1187* Purpose
1188* =======
1189*
1190* PZBLA2TSTINFO get the needed startup information for testing various
1191* Level 2 PBLAS routines, and transmits it to all processes.
1192*
1193* Notes
1194* =====
1195*
1196* For packing the information we assumed that the length in bytes of an
1197* integer is equal to the length in bytes of a real single precision.
1198*
1199* Arguments
1200* =========
1201*
1202* SUMMRY (global output) CHARACTER*(*)
1203* On exit, SUMMRY is the name of output (summary) file (if
1204* any). SUMMRY is only defined for process 0.
1205*
1206* NOUT (global output) INTEGER
1207* On exit, NOUT specifies the unit number for the output file.
1208* When NOUT is 6, output to screen, when NOUT is 0, output to
1209* stderr. NOUT is only defined for process 0.
1210*
1211* NMAT (global output) INTEGER
1212* On exit, NMAT specifies the number of different test cases.
1213*
1214* DIAGVAL (global output) CHARACTER array
1215* On entry, DIAGVAL is an array of dimension LDVAL. On exit,
1216* this array contains the values of DIAG to run the code with.
1217*
1218* TRANVAL (global output) CHARACTER array
1219* On entry, TRANVAL is an array of dimension LDVAL. On exit,
1220* this array contains the values of TRANS to run the code
1221* with.
1222*
1223* UPLOVAL (global output) CHARACTER array
1224* On entry, UPLOVAL is an array of dimension LDVAL. On exit,
1225* this array contains the values of UPLO to run the code with.
1226*
1227* MVAL (global output) INTEGER array
1228* On entry, MVAL is an array of dimension LDVAL. On exit, this
1229* array contains the values of M to run the code with.
1230*
1231* NVAL (global output) INTEGER array
1232* On entry, NVAL is an array of dimension LDVAL. On exit, this
1233* array contains the values of N to run the code with.
1234*
1235* MAVAL (global output) INTEGER array
1236* On entry, MAVAL is an array of dimension LDVAL. On exit, this
1237* array contains the values of DESCA( M_ ) to run the code
1238* with.
1239*
1240* NAVAL (global output) INTEGER array
1241* On entry, NAVAL is an array of dimension LDVAL. On exit, this
1242* array contains the values of DESCA( N_ ) to run the code
1243* with.
1244*
1245* IMBAVAL (global output) INTEGER array
1246* On entry, IMBAVAL is an array of dimension LDVAL. On exit,
1247* this array contains the values of DESCA( IMB_ ) to run the
1248* code with.
1249*
1250* MBAVAL (global output) INTEGER array
1251* On entry, MBAVAL is an array of dimension LDVAL. On exit,
1252* this array contains the values of DESCA( MB_ ) to run the
1253* code with.
1254*
1255* INBAVAL (global output) INTEGER array
1256* On entry, INBAVAL is an array of dimension LDVAL. On exit,
1257* this array contains the values of DESCA( INB_ ) to run the
1258* code with.
1259*
1260* NBAVAL (global output) INTEGER array
1261* On entry, NBAVAL is an array of dimension LDVAL. On exit,
1262* this array contains the values of DESCA( NB_ ) to run the
1263* code with.
1264*
1265* RSCAVAL (global output) INTEGER array
1266* On entry, RSCAVAL is an array of dimension LDVAL. On exit,
1267* this array contains the values of DESCA( RSRC_ ) to run the
1268* code with.
1269*
1270* CSCAVAL (global output) INTEGER array
1271* On entry, CSCAVAL is an array of dimension LDVAL. On exit,
1272* this array contains the values of DESCA( CSRC_ ) to run the
1273* code with.
1274*
1275* IAVAL (global output) INTEGER array
1276* On entry, IAVAL is an array of dimension LDVAL. On exit, this
1277* array contains the values of IA to run the code with.
1278*
1279* JAVAL (global output) INTEGER array
1280* On entry, JAVAL is an array of dimension LDVAL. On exit, this
1281* array contains the values of JA to run the code with.
1282*
1283* MXVAL (global output) INTEGER array
1284* On entry, MXVAL is an array of dimension LDVAL. On exit, this
1285* array contains the values of DESCX( M_ ) to run the code
1286* with.
1287*
1288* NXVAL (global output) INTEGER array
1289* On entry, NXVAL is an array of dimension LDVAL. On exit, this
1290* array contains the values of DESCX( N_ ) to run the code
1291* with.
1292*
1293* IMBXVAL (global output) INTEGER array
1294* On entry, IMBXVAL is an array of dimension LDVAL. On exit,
1295* this array contains the values of DESCX( IMB_ ) to run the
1296* code with.
1297*
1298* MBXVAL (global output) INTEGER array
1299* On entry, MBXVAL is an array of dimension LDVAL. On exit,
1300* this array contains the values of DESCX( MB_ ) to run the
1301* code with.
1302*
1303* INBXVAL (global output) INTEGER array
1304* On entry, INBXVAL is an array of dimension LDVAL. On exit,
1305* this array contains the values of DESCX( INB_ ) to run the
1306* code with.
1307*
1308* NBXVAL (global output) INTEGER array
1309* On entry, NBXVAL is an array of dimension LDVAL. On exit,
1310* this array contains the values of DESCX( NB_ ) to run the
1311* code with.
1312*
1313* RSCXVAL (global output) INTEGER array
1314* On entry, RSCXVAL is an array of dimension LDVAL. On exit,
1315* this array contains the values of DESCX( RSRC_ ) to run the
1316* code with.
1317*
1318* CSCXVAL (global output) INTEGER array
1319* On entry, CSCXVAL is an array of dimension LDVAL. On exit,
1320* this array contains the values of DESCX( CSRC_ ) to run the
1321* code with.
1322*
1323* IXVAL (global output) INTEGER array
1324* On entry, IXVAL is an array of dimension LDVAL. On exit, this
1325* array contains the values of IX to run the code with.
1326*
1327* JXVAL (global output) INTEGER array
1328* On entry, JXVAL is an array of dimension LDVAL. On exit, this
1329* array contains the values of JX to run the code with.
1330*
1331* INCXVAL (global output) INTEGER array
1332* On entry, INCXVAL is an array of dimension LDVAL. On exit,
1333* this array contains the values of INCX to run the code with.
1334*
1335* MYVAL (global output) INTEGER array
1336* On entry, MYVAL is an array of dimension LDVAL. On exit, this
1337* array contains the values of DESCY( M_ ) to run the code
1338* with.
1339*
1340* NYVAL (global output) INTEGER array
1341* On entry, NYVAL is an array of dimension LDVAL. On exit, this
1342* array contains the values of DESCY( N_ ) to run the code
1343* with.
1344*
1345* IMBYVAL (global output) INTEGER array
1346* On entry, IMBYVAL is an array of dimension LDVAL. On exit,
1347* this array contains the values of DESCY( IMB_ ) to run the
1348* code with.
1349*
1350* MBYVAL (global output) INTEGER array
1351* On entry, MBYVAL is an array of dimension LDVAL. On exit,
1352* this array contains the values of DESCY( MB_ ) to run the
1353* code with.
1354*
1355* INBYVAL (global output) INTEGER array
1356* On entry, INBYVAL is an array of dimension LDVAL. On exit,
1357* this array contains the values of DESCY( INB_ ) to run the
1358* code with.
1359*
1360* NBYVAL (global output) INTEGER array
1361* On entry, NBYVAL is an array of dimension LDVAL. On exit,
1362* this array contains the values of DESCY( NB_ ) to run the
1363* code with.
1364*
1365* RSCYVAL (global output) INTEGER array
1366* On entry, RSCYVAL is an array of dimension LDVAL. On exit,
1367* this array contains the values of DESCY( RSRC_ ) to run the
1368* code with.
1369*
1370* CSCYVAL (global output) INTEGER array
1371* On entry, CSCYVAL is an array of dimension LDVAL. On exit,
1372* this array contains the values of DESCY( CSRC_ ) to run the
1373* code with.
1374*
1375* IYVAL (global output) INTEGER array
1376* On entry, IYVAL is an array of dimension LDVAL. On exit, this
1377* array contains the values of IY to run the code with.
1378*
1379* JYVAL (global output) INTEGER array
1380* On entry, JYVAL is an array of dimension LDVAL. On exit, this
1381* array contains the values of JY to run the code with.
1382*
1383* INCYVAL (global output) INTEGER array
1384* On entry, INCYVAL is an array of dimension LDVAL. On exit,
1385* this array contains the values of INCY to run the code with.
1386*
1387* LDVAL (global input) INTEGER
1388* On entry, LDVAL specifies the maximum number of different va-
1389* lues that can be used for DIAG, TRANS, UPLO, M, N, DESCA(:),
1390* IA, JA, DESCX(:), IX, JX, INCX, DESCY(:), IY, JY and INCY.
1391* This is also the maximum number of test cases.
1392*
1393* NGRIDS (global output) INTEGER
1394* On exit, NGRIDS specifies the number of different values that
1395* can be used for P and Q.
1396*
1397* PVAL (global output) INTEGER array
1398* On entry, PVAL is an array of dimension LDPVAL. On exit, this
1399* array contains the values of P to run the code with.
1400*
1401* LDPVAL (global input) INTEGER
1402* On entry, LDPVAL specifies the maximum number of different
1403* values that can be used for P.
1404*
1405* QVAL (global output) INTEGER array
1406* On entry, QVAL is an array of dimension LDQVAL. On exit, this
1407* array contains the values of Q to run the code with.
1408*
1409* LDQVAL (global input) INTEGER
1410* On entry, LDQVAL specifies the maximum number of different
1411* values that can be used for Q.
1412*
1413* NBLOG (global output) INTEGER
1414* On exit, NBLOG specifies the logical computational block size
1415* to run the tests with. NBLOG must be at least one.
1416*
1417* LTEST (global output) LOGICAL array
1418* On entry, LTEST is an array of dimension at least eight. On
1419* exit, if LTEST( i ) is .TRUE., the i-th Level 2 PBLAS routine
1420* will be tested. See the input file for the ordering of the
1421* routines.
1422*
1423* SOF (global output) LOGICAL
1424* On exit, if SOF is .TRUE., the tester will stop on the first
1425* detected failure. Otherwise, it won't.
1426*
1427* TEE (global output) LOGICAL
1428* On exit, if TEE is .TRUE., the tester will perform the error
1429* exit tests. These tests won't be performed otherwise.
1430*
1431* IAM (local input) INTEGER
1432* On entry, IAM specifies the number of the process executing
1433* this routine.
1434*
1435* IGAP (global output) INTEGER
1436* On exit, IGAP specifies the user-specified gap used for pad-
1437* ding. IGAP must be at least zero.
1438*
1439* IVERB (global output) INTEGER
1440* On exit, IVERB specifies the output verbosity level: 0 for
1441* pass/fail, 1, 2 or 3 for matrix dump on errors.
1442*
1443* NPROCS (global input) INTEGER
1444* On entry, NPROCS specifies the total number of processes.
1445*
1446* THRESH (global output) REAL
1447* On exit, THRESH specifies the threshhold value for the test
1448* ratio.
1449*
1450* ALPHA (global output) COMPLEX*16
1451* On exit, ALPHA specifies the value of alpha to be used in all
1452* the test cases.
1453*
1454* BETA (global output) COMPLEX*16
1455* On exit, BETA specifies the value of beta to be used in all
1456* the test cases.
1457*
1458* WORK (local workspace) INTEGER array
1459* On entry, WORK is an array of dimension at least
1460* MAX( 3, 2*NGRIDS+37*NMAT+NSUBS+4 ) with NSUBS equal to 8.
1461* This array is used to pack all output arrays in order to send
1462* the information in one message.
1463*
1464* -- Written on April 1, 1998 by
1465* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
1466*
1467* =====================================================================
1468*
1469* .. Parameters ..
1470 INTEGER NIN, NSUBS
1471 parameter( nin = 11, nsubs = 8 )
1472* ..
1473* .. Local Scalars ..
1474 LOGICAL LTESTT
1475 INTEGER I, ICTXT, J
1476 DOUBLE PRECISION EPS
1477* ..
1478* .. Local Arrays ..
1479 CHARACTER*7 SNAMET
1480 CHARACTER*79 USRINFO
1481* ..
1482* .. External Subroutines ..
1483 EXTERNAL blacs_abort, blacs_get, blacs_gridexit,
1484 $ blacs_gridinit, blacs_setup, icopy, igebr2d,
1485 $ igebs2d, sgebr2d, sgebs2d, zgebr2d, zgebs2d
1486*ype real dble cplx zplx
1487* ..
1488* .. External Functions ..
1489 DOUBLE PRECISION PDLAMCH
1490 EXTERNAL pdlamch
1491* ..
1492* .. Intrinsic Functions ..
1493 INTRINSIC char, ichar, max, min
1494* ..
1495* .. Common Blocks ..
1496 CHARACTER*7 SNAMES( NSUBS )
1497 COMMON /snamec/snames
1498* ..
1499* .. Executable Statements ..
1500*
1501* Process 0 reads the input data, broadcasts to other processes and
1502* writes needed information to NOUT
1503*
1504 IF( iam.EQ.0 ) THEN
1505*
1506* Open file and skip data file header
1507*
1508 OPEN( nin, file='PZBLAS2TST.dat', status='OLD' )
1509 READ( nin, fmt = * ) summry
1510 summry = ' '
1511*
1512* Read in user-supplied info about machine type, compiler, etc.
1513*
1514 READ( nin, fmt = 9999 ) usrinfo
1515*
1516* Read name and unit number for summary output file
1517*
1518 READ( nin, fmt = * ) summry
1519 READ( nin, fmt = * ) nout
1520 IF( nout.NE.0 .AND. nout.NE.6 )
1521 $ OPEN( nout, file = summry, status = 'UNKNOWN' )
1522*
1523* Read and check the parameter values for the tests.
1524*
1525* Read the flag that indicates if Stop on Failure
1526*
1527 READ( nin, fmt = * ) sof
1528*
1529* Read the flag that indicates if Test Error Exits
1530*
1531 READ( nin, fmt = * ) tee
1532*
1533* Read the verbosity level
1534*
1535 READ( nin, fmt = * ) iverb
1536 IF( iverb.LT.0 .OR. iverb.GT.3 )
1537 $ iverb = 0
1538*
1539* Read the leading dimension gap
1540*
1541 READ( nin, fmt = * ) igap
1542 IF( igap.LT.0 )
1543 $ igap = 0
1544*
1545* Read the threshold value for test ratio
1546*
1547 READ( nin, fmt = * ) thresh
1548 IF( thresh.LT.0.0 )
1549 $ thresh = 16.0
1550*
1551* Get logical computational block size
1552*
1553 READ( nin, fmt = * ) nblog
1554 IF( nblog.LT.1 )
1555 $ nblog = 32
1556*
1557* Get number of grids
1558*
1559 READ( nin, fmt = * ) ngrids
1560 IF( ngrids.LT.1 .OR. ngrids.GT.ldpval ) THEN
1561 WRITE( nout, fmt = 9998 ) 'Grids', ldpval
1562 GO TO 120
1563 ELSE IF( ngrids.GT.ldqval ) THEN
1564 WRITE( nout, fmt = 9998 ) 'Grids', ldqval
1565 GO TO 120
1566 END IF
1567*
1568* Get values of P and Q
1569*
1570 READ( nin, fmt = * ) ( pval( i ), i = 1, ngrids )
1571 READ( nin, fmt = * ) ( qval( i ), i = 1, ngrids )
1572*
1573* Read ALPHA, BETA
1574*
1575 READ( nin, fmt = * ) alpha
1576 READ( nin, fmt = * ) beta
1577*
1578* Read number of tests.
1579*
1580 READ( nin, fmt = * ) nmat
1581 IF( nmat.LT.1 .OR. nmat.GT.ldval ) THEN
1582 WRITE( nout, fmt = 9998 ) 'Tests', ldval
1583 GO TO 120
1584 ENDIF
1585*
1586* Read in input data into arrays.
1587*
1588 READ( nin, fmt = * ) ( uploval( i ), i = 1, nmat )
1589 READ( nin, fmt = * ) ( tranval( i ), i = 1, nmat )
1590 READ( nin, fmt = * ) ( diagval( i ), i = 1, nmat )
1591 READ( nin, fmt = * ) ( mval( i ), i = 1, nmat )
1592 READ( nin, fmt = * ) ( nval( i ), i = 1, nmat )
1593 READ( nin, fmt = * ) ( maval( i ), i = 1, nmat )
1594 READ( nin, fmt = * ) ( naval( i ), i = 1, nmat )
1595 READ( nin, fmt = * ) ( imbaval( i ), i = 1, nmat )
1596 READ( nin, fmt = * ) ( inbaval( i ), i = 1, nmat )
1597 READ( nin, fmt = * ) ( mbaval( i ), i = 1, nmat )
1598 READ( nin, fmt = * ) ( nbaval( i ), i = 1, nmat )
1599 READ( nin, fmt = * ) ( rscaval( i ), i = 1, nmat )
1600 READ( nin, fmt = * ) ( cscaval( i ), i = 1, nmat )
1601 READ( nin, fmt = * ) ( iaval( i ), i = 1, nmat )
1602 READ( nin, fmt = * ) ( javal( i ), i = 1, nmat )
1603 READ( nin, fmt = * ) ( mxval( i ), i = 1, nmat )
1604 READ( nin, fmt = * ) ( nxval( i ), i = 1, nmat )
1605 READ( nin, fmt = * ) ( imbxval( i ), i = 1, nmat )
1606 READ( nin, fmt = * ) ( inbxval( i ), i = 1, nmat )
1607 READ( nin, fmt = * ) ( mbxval( i ), i = 1, nmat )
1608 READ( nin, fmt = * ) ( nbxval( i ), i = 1, nmat )
1609 READ( nin, fmt = * ) ( rscxval( i ), i = 1, nmat )
1610 READ( nin, fmt = * ) ( cscxval( i ), i = 1, nmat )
1611 READ( nin, fmt = * ) ( ixval( i ), i = 1, nmat )
1612 READ( nin, fmt = * ) ( jxval( i ), i = 1, nmat )
1613 READ( nin, fmt = * ) ( incxval( i ), i = 1, nmat )
1614 READ( nin, fmt = * ) ( myval( i ), i = 1, nmat )
1615 READ( nin, fmt = * ) ( nyval( i ), i = 1, nmat )
1616 READ( nin, fmt = * ) ( imbyval( i ), i = 1, nmat )
1617 READ( nin, fmt = * ) ( inbyval( i ), i = 1, nmat )
1618 READ( nin, fmt = * ) ( mbyval( i ), i = 1, nmat )
1619 READ( nin, fmt = * ) ( nbyval( i ), i = 1, nmat )
1620 READ( nin, fmt = * ) ( rscyval( i ), i = 1, nmat )
1621 READ( nin, fmt = * ) ( cscyval( i ), i = 1, nmat )
1622 READ( nin, fmt = * ) ( iyval( i ), i = 1, nmat )
1623 READ( nin, fmt = * ) ( jyval( i ), i = 1, nmat )
1624 READ( nin, fmt = * ) ( incyval( i ), i = 1, nmat )
1625*
1626* Read names of subroutines and flags which indicate
1627* whether they are to be tested.
1628*
1629 DO 10 i = 1, nsubs
1630 ltest( i ) = .false.
1631 10 CONTINUE
1632 20 CONTINUE
1633 READ( nin, fmt = 9996, END = 50 ) SNAMET, ltestt
1634 DO 30 i = 1, nsubs
1635 IF( snamet.EQ.snames( i ) )
1636 $ GO TO 40
1637 30 CONTINUE
1638*
1639 WRITE( nout, fmt = 9995 )snamet
1640 GO TO 120
1641*
1642 40 CONTINUE
1643 ltest( i ) = ltestt
1644 GO TO 20
1645*
1646 50 CONTINUE
1647*
1648* Close input file
1649*
1650 CLOSE ( nin )
1651*
1652* For pvm only: if virtual machine not set up, allocate it and
1653* spawn the correct number of processes.
1654*
1655 IF( nprocs.LT.1 ) THEN
1656 nprocs = 0
1657 DO 60 i = 1, ngrids
1658 nprocs = max( nprocs, pval( i )*qval( i ) )
1659 60 CONTINUE
1660 CALL blacs_setup( iam, nprocs )
1661 END IF
1662*
1663* Temporarily define blacs grid to include all processes so
1664* information can be broadcast to all processes
1665*
1666 CALL blacs_get( -1, 0, ictxt )
1667 CALL blacs_gridinit( ictxt, 'Row-major', 1, nprocs )
1668*
1669* Compute machine epsilon
1670*
1671 eps = pdlamch( ictxt, 'eps' )
1672*
1673* Pack information arrays and broadcast
1674*
1675 CALL sgebs2d( ictxt, 'All', ' ', 1, 1, thresh, 1 )
1676 CALL zgebs2d( ictxt, 'All', ' ', 1, 1, alpha, 1 )
1677 CALL zgebs2d( ictxt, 'All', ' ', 1, 1, beta, 1 )
1678*
1679 work( 1 ) = ngrids
1680 work( 2 ) = nmat
1681 work( 3 ) = nblog
1682 CALL igebs2d( ictxt, 'All', ' ', 3, 1, work, 3 )
1683*
1684 i = 1
1685 IF( sof ) THEN
1686 work( i ) = 1
1687 ELSE
1688 work( i ) = 0
1689 END IF
1690 i = i + 1
1691 IF( tee ) THEN
1692 work( i ) = 1
1693 ELSE
1694 work( i ) = 0
1695 END IF
1696 i = i + 1
1697 work( i ) = iverb
1698 i = i + 1
1699 work( i ) = igap
1700 i = i + 1
1701 DO 70 j = 1, nmat
1702 work( i ) = ichar( diagval( j ) )
1703 work( i+1 ) = ichar( tranval( j ) )
1704 work( i+2 ) = ichar( uploval( j ) )
1705 i = i + 3
1706 70 CONTINUE
1707 CALL icopy( ngrids, pval, 1, work( i ), 1 )
1708 i = i + ngrids
1709 CALL icopy( ngrids, qval, 1, work( i ), 1 )
1710 i = i + ngrids
1711 CALL icopy( nmat, mval, 1, work( i ), 1 )
1712 i = i + nmat
1713 CALL icopy( nmat, nval, 1, work( i ), 1 )
1714 i = i + nmat
1715 CALL icopy( nmat, maval, 1, work( i ), 1 )
1716 i = i + nmat
1717 CALL icopy( nmat, naval, 1, work( i ), 1 )
1718 i = i + nmat
1719 CALL icopy( nmat, imbaval, 1, work( i ), 1 )
1720 i = i + nmat
1721 CALL icopy( nmat, inbaval, 1, work( i ), 1 )
1722 i = i + nmat
1723 CALL icopy( nmat, mbaval, 1, work( i ), 1 )
1724 i = i + nmat
1725 CALL icopy( nmat, nbaval, 1, work( i ), 1 )
1726 i = i + nmat
1727 CALL icopy( nmat, rscaval, 1, work( i ), 1 )
1728 i = i + nmat
1729 CALL icopy( nmat, cscaval, 1, work( i ), 1 )
1730 i = i + nmat
1731 CALL icopy( nmat, iaval, 1, work( i ), 1 )
1732 i = i + nmat
1733 CALL icopy( nmat, javal, 1, work( i ), 1 )
1734 i = i + nmat
1735 CALL icopy( nmat, mxval, 1, work( i ), 1 )
1736 i = i + nmat
1737 CALL icopy( nmat, nxval, 1, work( i ), 1 )
1738 i = i + nmat
1739 CALL icopy( nmat, imbxval, 1, work( i ), 1 )
1740 i = i + nmat
1741 CALL icopy( nmat, inbxval, 1, work( i ), 1 )
1742 i = i + nmat
1743 CALL icopy( nmat, mbxval, 1, work( i ), 1 )
1744 i = i + nmat
1745 CALL icopy( nmat, nbxval, 1, work( i ), 1 )
1746 i = i + nmat
1747 CALL icopy( nmat, rscxval, 1, work( i ), 1 )
1748 i = i + nmat
1749 CALL icopy( nmat, cscxval, 1, work( i ), 1 )
1750 i = i + nmat
1751 CALL icopy( nmat, ixval, 1, work( i ), 1 )
1752 i = i + nmat
1753 CALL icopy( nmat, jxval, 1, work( i ), 1 )
1754 i = i + nmat
1755 CALL icopy( nmat, incxval, 1, work( i ), 1 )
1756 i = i + nmat
1757 CALL icopy( nmat, myval, 1, work( i ), 1 )
1758 i = i + nmat
1759 CALL icopy( nmat, nyval, 1, work( i ), 1 )
1760 i = i + nmat
1761 CALL icopy( nmat, imbyval, 1, work( i ), 1 )
1762 i = i + nmat
1763 CALL icopy( nmat, inbyval, 1, work( i ), 1 )
1764 i = i + nmat
1765 CALL icopy( nmat, mbyval, 1, work( i ), 1 )
1766 i = i + nmat
1767 CALL icopy( nmat, nbyval, 1, work( i ), 1 )
1768 i = i + nmat
1769 CALL icopy( nmat, rscyval, 1, work( i ), 1 )
1770 i = i + nmat
1771 CALL icopy( nmat, cscyval, 1, work( i ), 1 )
1772 i = i + nmat
1773 CALL icopy( nmat, iyval, 1, work( i ), 1 )
1774 i = i + nmat
1775 CALL icopy( nmat, jyval, 1, work( i ), 1 )
1776 i = i + nmat
1777 CALL icopy( nmat, incyval, 1, work( i ), 1 )
1778 i = i + nmat
1779*
1780 DO 80 j = 1, nsubs
1781 IF( ltest( j ) ) THEN
1782 work( i ) = 1
1783 ELSE
1784 work( i ) = 0
1785 END IF
1786 i = i + 1
1787 80 CONTINUE
1788 i = i - 1
1789 CALL igebs2d( ictxt, 'All', ' ', i, 1, work, i )
1790*
1791* regurgitate input
1792*
1793 WRITE( nout, fmt = 9999 ) 'Level 2 PBLAS testing program.'
1794 WRITE( nout, fmt = 9999 ) usrinfo
1795 WRITE( nout, fmt = * )
1796 WRITE( nout, fmt = 9999 )
1797 $ 'Tests of the complex double precision '//
1798 $ 'Level 2 PBLAS'
1799 WRITE( nout, fmt = * )
1800 WRITE( nout, fmt = 9993 ) nmat
1801 WRITE( nout, fmt = 9979 ) nblog
1802 WRITE( nout, fmt = 9992 ) ngrids
1803 WRITE( nout, fmt = 9990 )
1804 $ 'P', ( pval(i), i = 1, min(ngrids, 5) )
1805 IF( ngrids.GT.5 )
1806 $ WRITE( nout, fmt = 9991 ) ( pval(i), i = 6,
1807 $ min( 10, ngrids ) )
1808 IF( ngrids.GT.10 )
1809 $ WRITE( nout, fmt = 9991 ) ( pval(i), i = 11,
1810 $ min( 15, ngrids ) )
1811 IF( ngrids.GT.15 )
1812 $ WRITE( nout, fmt = 9991 ) ( pval(i), i = 16, ngrids )
1813 WRITE( nout, fmt = 9990 )
1814 $ 'Q', ( qval(i), i = 1, min(ngrids, 5) )
1815 IF( ngrids.GT.5 )
1816 $ WRITE( nout, fmt = 9991 ) ( qval(i), i = 6,
1817 $ min( 10, ngrids ) )
1818 IF( ngrids.GT.10 )
1819 $ WRITE( nout, fmt = 9991 ) ( qval(i), i = 11,
1820 $ min( 15, ngrids ) )
1821 IF( ngrids.GT.15 )
1822 $ WRITE( nout, fmt = 9991 ) ( qval(i), i = 16, ngrids )
1823 WRITE( nout, fmt = 9988 ) sof
1824 WRITE( nout, fmt = 9987 ) tee
1825 WRITE( nout, fmt = 9983 ) igap
1826 WRITE( nout, fmt = 9986 ) iverb
1827 WRITE( nout, fmt = 9980 ) thresh
1828 WRITE( nout, fmt = 9982 ) alpha
1829 WRITE( nout, fmt = 9981 ) beta
1830 IF( ltest( 1 ) ) THEN
1831 WRITE( nout, fmt = 9985 ) snames( 1 ), ' ... Yes'
1832 ELSE
1833 WRITE( nout, fmt = 9985 ) snames( 1 ), ' ... No '
1834 END IF
1835 DO 90 i = 2, nsubs
1836 IF( ltest( i ) ) THEN
1837 WRITE( nout, fmt = 9984 ) snames( i ), ' ... Yes'
1838 ELSE
1839 WRITE( nout, fmt = 9984 ) snames( i ), ' ... No '
1840 END IF
1841 90 CONTINUE
1842 WRITE( nout, fmt = 9994 ) eps
1843 WRITE( nout, fmt = * )
1844*
1845 ELSE
1846*
1847* If in pvm, must participate setting up virtual machine
1848*
1849 IF( nprocs.LT.1 )
1850 $ CALL blacs_setup( iam, nprocs )
1851*
1852* Temporarily define blacs grid to include all processes so
1853* information can be broadcast to all processes
1854*
1855 CALL blacs_get( -1, 0, ictxt )
1856 CALL blacs_gridinit( ictxt, 'Row-major', 1, nprocs )
1857*
1858* Compute machine epsilon
1859*
1860 eps = pdlamch( ictxt, 'eps' )
1861*
1862 CALL sgebr2d( ictxt, 'All', ' ', 1, 1, thresh, 1, 0, 0 )
1863 CALL zgebr2d( ictxt, 'All', ' ', 1, 1, alpha, 1, 0, 0 )
1864 CALL zgebr2d( ictxt, 'All', ' ', 1, 1, beta, 1, 0, 0 )
1865*
1866 CALL igebr2d( ictxt, 'All', ' ', 3, 1, work, 3, 0, 0 )
1867 ngrids = work( 1 )
1868 nmat = work( 2 )
1869 nblog = work( 3 )
1870*
1871 i = 2*ngrids + 37*nmat + nsubs + 4
1872 CALL igebr2d( ictxt, 'All', ' ', i, 1, work, i, 0, 0 )
1873*
1874 i = 1
1875 IF( work( i ).EQ.1 ) THEN
1876 sof = .true.
1877 ELSE
1878 sof = .false.
1879 END IF
1880 i = i + 1
1881 IF( work( i ).EQ.1 ) THEN
1882 tee = .true.
1883 ELSE
1884 tee = .false.
1885 END IF
1886 i = i + 1
1887 iverb = work( i )
1888 i = i + 1
1889 igap = work( i )
1890 i = i + 1
1891 DO 100 j = 1, nmat
1892 diagval( j ) = char( work( i ) )
1893 tranval( j ) = char( work( i+1 ) )
1894 uploval( j ) = char( work( i+2 ) )
1895 i = i + 3
1896 100 CONTINUE
1897 CALL icopy( ngrids, work( i ), 1, pval, 1 )
1898 i = i + ngrids
1899 CALL icopy( ngrids, work( i ), 1, qval, 1 )
1900 i = i + ngrids
1901 CALL icopy( nmat, work( i ), 1, mval, 1 )
1902 i = i + nmat
1903 CALL icopy( nmat, work( i ), 1, nval, 1 )
1904 i = i + nmat
1905 CALL icopy( nmat, work( i ), 1, maval, 1 )
1906 i = i + nmat
1907 CALL icopy( nmat, work( i ), 1, naval, 1 )
1908 i = i + nmat
1909 CALL icopy( nmat, work( i ), 1, imbaval, 1 )
1910 i = i + nmat
1911 CALL icopy( nmat, work( i ), 1, inbaval, 1 )
1912 i = i + nmat
1913 CALL icopy( nmat, work( i ), 1, mbaval, 1 )
1914 i = i + nmat
1915 CALL icopy( nmat, work( i ), 1, nbaval, 1 )
1916 i = i + nmat
1917 CALL icopy( nmat, work( i ), 1, rscaval, 1 )
1918 i = i + nmat
1919 CALL icopy( nmat, work( i ), 1, cscaval, 1 )
1920 i = i + nmat
1921 CALL icopy( nmat, work( i ), 1, iaval, 1 )
1922 i = i + nmat
1923 CALL icopy( nmat, work( i ), 1, javal, 1 )
1924 i = i + nmat
1925 CALL icopy( nmat, work( i ), 1, mxval, 1 )
1926 i = i + nmat
1927 CALL icopy( nmat, work( i ), 1, nxval, 1 )
1928 i = i + nmat
1929 CALL icopy( nmat, work( i ), 1, imbxval, 1 )
1930 i = i + nmat
1931 CALL icopy( nmat, work( i ), 1, inbxval, 1 )
1932 i = i + nmat
1933 CALL icopy( nmat, work( i ), 1, mbxval, 1 )
1934 i = i + nmat
1935 CALL icopy( nmat, work( i ), 1, nbxval, 1 )
1936 i = i + nmat
1937 CALL icopy( nmat, work( i ), 1, rscxval, 1 )
1938 i = i + nmat
1939 CALL icopy( nmat, work( i ), 1, cscxval, 1 )
1940 i = i + nmat
1941 CALL icopy( nmat, work( i ), 1, ixval, 1 )
1942 i = i + nmat
1943 CALL icopy( nmat, work( i ), 1, jxval, 1 )
1944 i = i + nmat
1945 CALL icopy( nmat, work( i ), 1, incxval, 1 )
1946 i = i + nmat
1947 CALL icopy( nmat, work( i ), 1, myval, 1 )
1948 i = i + nmat
1949 CALL icopy( nmat, work( i ), 1, nyval, 1 )
1950 i = i + nmat
1951 CALL icopy( nmat, work( i ), 1, imbyval, 1 )
1952 i = i + nmat
1953 CALL icopy( nmat, work( i ), 1, inbyval, 1 )
1954 i = i + nmat
1955 CALL icopy( nmat, work( i ), 1, mbyval, 1 )
1956 i = i + nmat
1957 CALL icopy( nmat, work( i ), 1, nbyval, 1 )
1958 i = i + nmat
1959 CALL icopy( nmat, work( i ), 1, rscyval, 1 )
1960 i = i + nmat
1961 CALL icopy( nmat, work( i ), 1, cscyval, 1 )
1962 i = i + nmat
1963 CALL icopy( nmat, work( i ), 1, iyval, 1 )
1964 i = i + nmat
1965 CALL icopy( nmat, work( i ), 1, jyval, 1 )
1966 i = i + nmat
1967 CALL icopy( nmat, work( i ), 1, incyval, 1 )
1968 i = i + nmat
1969*
1970 DO 110 j = 1, nsubs
1971 IF( work( i ).EQ.1 ) THEN
1972 ltest( j ) = .true.
1973 ELSE
1974 ltest( j ) = .false.
1975 END IF
1976 i = i + 1
1977 110 CONTINUE
1978*
1979 END IF
1980*
1981 CALL blacs_gridexit( ictxt )
1982*
1983 RETURN
1984*
1985 120 WRITE( nout, fmt = 9997 )
1986 CLOSE( nin )
1987 IF( nout.NE.6 .AND. nout.NE.0 )
1988 $ CLOSE( nout )
1989 CALL blacs_abort( ictxt, 1 )
1990*
1991 stop
1992*
1993 9999 FORMAT( a )
1994 9998 FORMAT( ' Number of values of ',5a, ' is less than 1 or greater ',
1995 $ 'than ', i2 )
1996 9997 FORMAT( ' Illegal input in file ',40a,'. Aborting run.' )
1997 9996 FORMAT( a7, l2 )
1998 9995 FORMAT( ' Subprogram name ', a7, ' not recognized',
1999 $ /' ******* TESTS ABANDONED *******' )
2000 9994 FORMAT( 2x, 'Relative machine precision (eps) is taken to be ',
2001 $ e18.6 )
2002 9993 FORMAT( 2x, 'Number of Tests : ', i6 )
2003 9992 FORMAT( 2x, 'Number of process grids : ', i6 )
2004 9991 FORMAT( 2x, ' : ', 5i6 )
2005 9990 FORMAT( 2x, a1, ' : ', 5i6 )
2006 9988 FORMAT( 2x, 'Stop on failure flag : ', l6 )
2007 9987 FORMAT( 2x, 'Test for error exits flag : ', l6 )
2008 9986 FORMAT( 2x, 'Verbosity level : ', i6 )
2009 9985 FORMAT( 2x, 'Routines to be tested : ', a, a8 )
2010 9984 FORMAT( 2x, ' ', a, a8 )
2011 9983 FORMAT( 2x, 'Leading dimension gap : ', i6 )
2012 9982 FORMAT( 2x, 'Alpha : (', g16.6,
2013 $ ',', g16.6, ')' )
2014 9981 FORMAT( 2x, 'Beta : (', g16.6,
2015 $ ',', g16.6, ')' )
2016 9980 FORMAT( 2x, 'Threshold value : ', g16.6 )
2017 9979 FORMAT( 2x, 'Logical block size : ', i6 )
2018*
2019* End of PZBLA2TSTINFO
2020*
icopy
subroutine icopy(n, sx, incx, sy, incy)
Definition pblastst.f:1525
max
#define max(A, B)
Definition pcgemr.c:180
min
#define min(A, B)
Definition pcgemr.c:181
pdlamch
double precision function pdlamch(ictxt, cmach)
Definition pdblastst.f:6769
Here is the call graph for this function:
Here is the caller graph for this function: