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

◆ psbla2tstinfo()

subroutine psbla2tstinfo ( 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,
real  alpha,
real  beta,
integer, dimension( * )  work 
)

Definition at line 1107 of file psblas2tst.f.

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