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

◆ pdbla2tstinfo()

subroutine pdbla2tstinfo ( 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,
double precision  alpha,
double precision  beta,
integer, dimension( * )  work 
)

Definition at line 1108 of file pdblas2tst.f.

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