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

◆ pcbla2tstinfo()

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

Definition at line 1139 of file pcblas2tst.f.

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