OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
psblas2tst.f File Reference

Go to the source code of this file.

Functions/Subroutines

program psbla2tst
subroutine psbla2tstinfo (summry, nout, nmat, diagval, tranval, uploval, mval, nval, maval, naval, imbaval, mbaval, inbaval, nbaval, rscaval, cscaval, iaval, javal, mxval, nxval, imbxval, mbxval, inbxval, nbxval, rscxval, cscxval, ixval, jxval, incxval, myval, nyval, imbyval, mbyval, inbyval, nbyval, rscyval, cscyval, iyval, jyval, incyval, ldval, ngrids, pval, ldpval, qval, ldqval, nblog, ltest, sof, tee, iam, igap, iverb, nprocs, thresh, alpha, beta, work)
subroutine psblas2tstchke (ltest, inout, nprocs)
subroutine pschkarg2 (ictxt, nout, sname, uplo, trans, diag, m, n, alpha, ia, ja, desca, ix, jx, descx, incx, beta, iy, jy, descy, incy, info)
subroutine psblas2tstchk (ictxt, nout, nrout, uplo, trans, diag, m, n, alpha, a, pa, ia, ja, desca, x, px, ix, jx, descx, incx, beta, y, py, iy, jy, descy, incy, thresh, rogue, work, info)

Function/Subroutine Documentation

◆ psbla2tst()

program psbla2tst

Definition at line 11 of file psblas2tst.f.

◆ 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*
alpha
#define alpha
Definition eval.h:35
icopy
subroutine icopy(n, sx, incx, sy, incy)
ICOPY
Definition icopy.f:75
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21
sgebs2d
subroutine sgebs2d(contxt, scope, top, m, n, a, lda)
Definition mpi.f:1072
blacs_gridinit
subroutine blacs_gridinit(cntxt, c, nprow, npcol)
Definition mpi.f:745
sgebr2d
subroutine sgebr2d(contxt, scope, top, m, n, a, lda)
Definition mpi.f:1113
blacs_gridexit
subroutine blacs_gridexit(cntxt)
Definition mpi.f:762
pslamch
real function pslamch(ictxt, cmach)
Definition pcblastst.f:7455

◆ psblas2tstchk()

subroutine psblas2tstchk ( integer ictxt,
integer nout,
integer nrout,
character*1 uplo,
character*1 trans,
character*1 diag,
integer m,
integer n,
real alpha,
real, dimension( * ) a,
real, dimension( * ) pa,
integer ia,
integer ja,
integer, dimension( * ) desca,
real, dimension( * ) x,
real, dimension( * ) px,
integer ix,
integer jx,
integer, dimension( * ) descx,
integer incx,
real beta,
real, dimension( * ) y,
real, dimension( * ) py,
integer iy,
integer jy,
integer, dimension( * ) descy,
integer incy,
real thresh,
real rogue,
real, dimension( * ) work,
integer info )

Definition at line 2518 of file psblas2tst.f.

2523*
2524* -- PBLAS test routine (version 2.0) --
2525* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
2526* and University of California, Berkeley.
2527* April 1, 1998
2528*
2529* .. Scalar Arguments ..
2530 CHARACTER*1 DIAG, TRANS, UPLO
2531 INTEGER IA, ICTXT, INCX, INCY, INFO, IX, IY, JA, JX,
2532 $ JY, M, N, NOUT, NROUT
2533 REAL ALPHA, BETA, ROGUE, THRESH
2534* ..
2535* .. Array Arguments ..
2536 INTEGER DESCA( * ), DESCX( * ), DESCY( * )
2537 REAL A( * ), PA( * ), PX( * ), PY( * ), WORK( * ),
2538 $ X( * ), Y( * )
2539* ..
2540*
2541* Purpose
2542* =======
2543*
2544* PSBLAS2TSTCHK performs the computational tests of the Level 2 PBLAS.
2545*
2546* Notes
2547* =====
2548*
2549* A description vector is associated with each 2D block-cyclicly dis-
2550* tributed matrix. This vector stores the information required to
2551* establish the mapping between a matrix entry and its corresponding
2552* process and memory location.
2553*
2554* In the following comments, the character _ should be read as
2555* "of the distributed matrix". Let A be a generic term for any 2D
2556* block cyclicly distributed matrix. Its description vector is DESCA:
2557*
2558* NOTATION STORED IN EXPLANATION
2559* ---------------- --------------- ------------------------------------
2560* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
2561* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
2562* the NPROW x NPCOL BLACS process grid
2563* A is distributed over. The context
2564* itself is global, but the handle
2565* (the integer value) may vary.
2566* M_A (global) DESCA( M_ ) The number of rows in the distribu-
2567* ted matrix A, M_A >= 0.
2568* N_A (global) DESCA( N_ ) The number of columns in the distri-
2569* buted matrix A, N_A >= 0.
2570* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
2571* block of the matrix A, IMB_A > 0.
2572* INB_A (global) DESCA( INB_ ) The number of columns of the upper
2573* left block of the matrix A,
2574* INB_A > 0.
2575* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
2576* bute the last M_A-IMB_A rows of A,
2577* MB_A > 0.
2578* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
2579* bute the last N_A-INB_A columns of
2580* A, NB_A > 0.
2581* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
2582* row of the matrix A is distributed,
2583* NPROW > RSRC_A >= 0.
2584* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
2585* first column of A is distributed.
2586* NPCOL > CSRC_A >= 0.
2587* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
2588* array storing the local blocks of
2589* the distributed matrix A,
2590* IF( Lc( 1, N_A ) > 0 )
2591* LLD_A >= MAX( 1, Lr( 1, M_A ) )
2592* ELSE
2593* LLD_A >= 1.
2594*
2595* Let K be the number of rows of a matrix A starting at the global in-
2596* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
2597* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
2598* receive if these K rows were distributed over NPROW processes. If K
2599* is the number of columns of a matrix A starting at the global index
2600* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
2601* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
2602* these K columns were distributed over NPCOL processes.
2603*
2604* The values of Lr() and Lc() may be determined via a call to the func-
2605* tion PB_NUMROC:
2606* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
2607* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
2608*
2609* Arguments
2610* =========
2611*
2612* ICTXT (local input) INTEGER
2613* On entry, ICTXT specifies the BLACS context handle, indica-
2614* ting the global context of the operation. The context itself
2615* is global, but the value of ICTXT is local.
2616*
2617* NOUT (global input) INTEGER
2618* On entry, NOUT specifies the unit number for the output file.
2619* When NOUT is 6, output to screen, when NOUT is 0, output to
2620* stderr. NOUT is only defined for process 0.
2621*
2622* NROUT (global input) INTEGER
2623* On entry, NROUT specifies which routine will be tested as
2624* follows:
2625* If NROUT = 1, PSGEMV will be tested;
2626* else if NROUT = 2, PSSYMV will be tested;
2627* else if NROUT = 3, PSTRMV will be tested;
2628* else if NROUT = 4, PSTRSV will be tested;
2629* else if NROUT = 5, PSGER will be tested;
2630* else if NROUT = 6, PSSYR will be tested;
2631* else if NROUT = 7, PSSYR2 will be tested;
2632*
2633* UPLO (global input) CHARACTER*1
2634* On entry, UPLO specifies if the upper or lower part of the
2635* matrix operand is to be referenced.
2636*
2637* TRANS (global input) CHARACTER*1
2638* On entry, TRANS specifies if the matrix operand A is to be
2639* transposed.
2640*
2641* DIAG (global input) CHARACTER*1
2642* On entry, DIAG specifies if the triangular matrix operand is
2643* unit or non-unit.
2644*
2645* M (global input) INTEGER
2646* On entry, M specifies the number of rows of A.
2647*
2648* N (global input) INTEGER
2649* On entry, N specifies the number of columns of A.
2650*
2651* ALPHA (global input) REAL
2652* On entry, ALPHA specifies the scalar alpha.
2653*
2654* A (local input/local output) REAL array
2655* On entry, A is an array of dimension (DESCA( M_ ),*). This
2656* array contains a local copy of the initial entire matrix PA.
2657*
2658* PA (local input) REAL array
2659* On entry, PA is an array of dimension (DESCA( LLD_ ),*). This
2660* array contains the local entries of the matrix PA.
2661*
2662* IA (global input) INTEGER
2663* On entry, IA specifies A's global row index, which points to
2664* the beginning of the submatrix sub( A ).
2665*
2666* JA (global input) INTEGER
2667* On entry, JA specifies A's global column index, which points
2668* to the beginning of the submatrix sub( A ).
2669*
2670* DESCA (global and local input) INTEGER array
2671* On entry, DESCA is an integer array of dimension DLEN_. This
2672* is the array descriptor for the matrix A.
2673*
2674* X (local input/local output) REAL array
2675* On entry, X is an array of dimension (DESCX( M_ ),*). This
2676* array contains a local copy of the initial entire matrix PX.
2677*
2678* PX (local input) REAL array
2679* On entry, PX is an array of dimension (DESCX( LLD_ ),*). This
2680* array contains the local entries of the matrix PX.
2681*
2682* IX (global input) INTEGER
2683* On entry, IX specifies X's global row index, which points to
2684* the beginning of the submatrix sub( X ).
2685*
2686* JX (global input) INTEGER
2687* On entry, JX specifies X's global column index, which points
2688* to the beginning of the submatrix sub( X ).
2689*
2690* DESCX (global and local input) INTEGER array
2691* On entry, DESCX is an integer array of dimension DLEN_. This
2692* is the array descriptor for the matrix X.
2693*
2694* INCX (global input) INTEGER
2695* On entry, INCX specifies the global increment for the
2696* elements of X. Only two values of INCX are supported in
2697* this version, namely 1 and M_X. INCX must not be zero.
2698*
2699* BETA (global input) REAL
2700* On entry, BETA specifies the scalar beta.
2701*
2702* Y (local input/local output) REAL array
2703* On entry, Y is an array of dimension (DESCY( M_ ),*). This
2704* array contains a local copy of the initial entire matrix PY.
2705*
2706* PY (local input) REAL array
2707* On entry, PY is an array of dimension (DESCY( LLD_ ),*). This
2708* array contains the local entries of the matrix PY.
2709*
2710* IY (global input) INTEGER
2711* On entry, IY specifies Y's global row index, which points to
2712* the beginning of the submatrix sub( Y ).
2713*
2714* JY (global input) INTEGER
2715* On entry, JY specifies Y's global column index, which points
2716* to the beginning of the submatrix sub( Y ).
2717*
2718* DESCY (global and local input) INTEGER array
2719* On entry, DESCY is an integer array of dimension DLEN_. This
2720* is the array descriptor for the matrix Y.
2721*
2722* INCY (global input) INTEGER
2723* On entry, INCY specifies the global increment for the
2724* elements of Y. Only two values of INCY are supported in
2725* this version, namely 1 and M_Y. INCY must not be zero.
2726*
2727* THRESH (global input) REAL
2728* On entry, THRESH is the threshold value for the test ratio.
2729*
2730* ROGUE (global input) REAL
2731* On entry, ROGUE specifies the constant used to pad the
2732* non-referenced part of triangular or symmetric matrices.
2733*
2734* WORK (workspace) REAL array
2735* On entry, WORK is an array of dimension LWORK where LWORK is
2736* at least MAX( M, N ). This array is used to store the compu-
2737* ted gauges (see PSMVCH).
2738*
2739* INFO (global output) INTEGER
2740* On exit, if INFO = 0, no error has been found, otherwise
2741* if( MOD( INFO, 2 ) = 1 ) then an error on A has been found,
2742* if( MOD( INFO/2, 2 ) = 1 ) then an error on X has been found,
2743* if( MOD( INFO/4, 2 ) = 1 ) then an error on Y has been found.
2744*
2745* -- Written on April 1, 1998 by
2746* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
2747*
2748* =====================================================================
2749*
2750* .. Parameters ..
2751 REAL ONE, ZERO
2752 parameter( one = 1.0e+0, zero = 0.0e+0 )
2753 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
2754 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
2755 $ RSRC_
2756 parameter( block_cyclic_2d_inb = 2, dlen_ = 11,
2757 $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
2758 $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
2759 $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
2760* ..
2761* .. Local Scalars ..
2762 INTEGER I, MYCOL, MYROW, NPCOL, NPROW
2763 REAL ERR
2764* ..
2765* .. Local Arrays ..
2766 INTEGER IERR( 3 )
2767* ..
2768* .. External Subroutines ..
2769 EXTERNAL blacs_gridinfo, pb_slaset, pschkmin, pschkvin,
2770 $ psmvch, pstrmv, psvmch, psvmch2, strsv
2771* ..
2772* .. External Functions ..
2773 LOGICAL LSAME
2774 EXTERNAL lsame
2775* ..
2776* .. Executable Statements ..
2777*
2778 info = 0
2779*
2780* Quick return if possible
2781*
2782 IF( ( m.LE.0 ).OR.( n.LE.0 ) )
2783 $ RETURN
2784*
2785* Start the operations
2786*
2787 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
2788*
2789 DO 10 i = 1, 3
2790 ierr( i ) = 0
2791 10 CONTINUE
2792*
2793 IF( nrout.EQ.1 ) THEN
2794*
2795* Test PSGEMV
2796*
2797* Check the resulting vector Y
2798*
2799 CALL psmvch( ictxt, trans, m, n, alpha, a, ia, ja, desca, x,
2800 $ ix, jx, descx, incx, beta, y, py, iy, jy, descy,
2801 $ incy, work, err, ierr( 3 ) )
2802*
2803 IF( ierr( 3 ).NE.0 ) THEN
2804 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
2805 $ WRITE( nout, fmt = 9997 )
2806 ELSE IF( err.GT.thresh ) THEN
2807 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
2808 $ WRITE( nout, fmt = 9996 ) err
2809 END IF
2810*
2811* Check the input-only arguments
2812*
2813 CALL pschkmin( err, m, n, a, pa, ia, ja, desca, ierr( 1 ) )
2814 IF( lsame( trans, 'N' ) ) THEN
2815 CALL pschkvin( err, n, x, px, ix, jx, descx, incx,
2816 $ ierr( 2 ) )
2817 ELSE
2818 CALL pschkvin( err, m, x, px, ix, jx, descx, incx,
2819 $ ierr( 2 ) )
2820 END IF
2821*
2822 ELSE IF( nrout.EQ.2 ) THEN
2823*
2824* Test PSSYMV
2825*
2826* Check the resulting vector Y
2827*
2828 CALL psmvch( ictxt, 'No transpose', n, n, alpha, a, ia, ja,
2829 $ desca, x, ix, jx, descx, incx, beta, y, py, iy,
2830 $ jy, descy, incy, work, err, ierr( 3 ) )
2831*
2832 IF( ierr( 3 ).NE.0 ) THEN
2833 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
2834 $ WRITE( nout, fmt = 9997 )
2835 ELSE IF( err.GT.thresh ) THEN
2836 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
2837 $ WRITE( nout, fmt = 9996 ) err
2838 END IF
2839*
2840* Check the input-only arguments
2841*
2842 IF( lsame( uplo, 'L' ) ) THEN
2843 CALL pb_slaset( 'Upper', n-1, n-1, 0, rogue, rogue,
2844 $ a( ia+ja*desca( m_ ) ), desca( m_ ) )
2845 ELSE
2846 CALL pb_slaset( 'Lower', n-1, n-1, 0, rogue, rogue,
2847 $ a( ia+1+(ja-1)*desca( m_ ) ), desca( m_ ) )
2848 END IF
2849 CALL pschkmin( err, n, n, a, pa, ia, ja, desca, ierr( 1 ) )
2850 CALL pschkvin( err, n, x, px, ix, jx, descx, incx, ierr( 2 ) )
2851*
2852 ELSE IF( nrout.EQ.3 ) THEN
2853*
2854* Test PSTRMV
2855*
2856* Check the resulting vector X
2857*
2858 CALL psmvch( ictxt, trans, n, n, one, a, ia, ja, desca, y, ix,
2859 $ jx, descx, incx, zero, x, px, ix, jx, descx, incx,
2860 $ work, err, ierr( 2 ) )
2861*
2862 IF( ierr( 2 ).NE.0 ) THEN
2863 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
2864 $ WRITE( nout, fmt = 9997 )
2865 ELSE IF( err.GT.thresh ) THEN
2866 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
2867 $ WRITE( nout, fmt = 9996 ) err
2868 END IF
2869*
2870* Check the input-only arguments
2871*
2872 IF( lsame( uplo, 'L' ) ) THEN
2873 IF( lsame( diag, 'N' ) ) THEN
2874 CALL pb_slaset( 'Upper', n-1, n-1, 0, rogue, rogue,
2875 $ a( ia+ja*desca( m_ ) ), desca( m_ ) )
2876 ELSE
2877 CALL pb_slaset( 'Upper', n, n, 0, rogue, one,
2878 $ a( ia+(ja-1)*desca( m_ ) ), desca( m_ ) )
2879 END IF
2880 ELSE
2881 IF( lsame( diag, 'N' ) ) THEN
2882 CALL pb_slaset( 'Lower', n-1, n-1, 0, rogue, rogue,
2883 $ a( ia+1+(ja-1)*desca( m_ ) ),
2884 $ desca( m_ ) )
2885 ELSE
2886 CALL pb_slaset( 'Lower', n, n, 0, rogue, one,
2887 $ a( ia+(ja-1)*desca( m_ ) ), desca( m_ ) )
2888 END IF
2889 END IF
2890 CALL pschkmin( err, n, n, a, pa, ia, ja, desca, ierr( 1 ) )
2891*
2892 ELSE IF( nrout.EQ.4 ) THEN
2893*
2894* Test PSTRSV
2895*
2896* Check the resulting vector X
2897*
2898 CALL strsv( uplo, trans, diag, n, a( ia+(ja-1)*desca( m_ ) ),
2899 $ desca( m_ ), x( ix+(jx-1)*descx( m_ ) ), incx )
2900 CALL pstrmv( uplo, trans, diag, n, pa, ia, ja, desca, px, ix,
2901 $ jx, descx, incx )
2902 CALL psmvch( ictxt, trans, n, n, one, a, ia, ja, desca, x, ix,
2903 $ jx, descx, incx, zero, y, px, ix, jx, descx, incx,
2904 $ work, err, ierr( 2 ) )
2905*
2906 IF( ierr( 2 ).NE.0 ) THEN
2907 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
2908 $ WRITE( nout, fmt = 9997 )
2909 ELSE IF( err.GT.thresh ) THEN
2910 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
2911 $ WRITE( nout, fmt = 9996 ) err
2912 END IF
2913*
2914* Check the input-only arguments
2915*
2916 IF( lsame( uplo, 'L' ) ) THEN
2917 IF( lsame( diag, 'N' ) ) THEN
2918 CALL pb_slaset( 'upper', N-1, N-1, 0, ROGUE, ROGUE,
2919 $ A( IA+JA*DESCA( M_ ) ), DESCA( M_ ) )
2920 ELSE
2921 CALL PB_SLASET( 'upper', N, N, 0, ROGUE, ONE,
2922 $ A( IA+(JA-1)*DESCA( M_ ) ), DESCA( M_ ) )
2923 END IF
2924 ELSE
2925 IF( LSAME( DIAG, 'n' ) ) THEN
2926 CALL PB_SLASET( 'lower', N-1, N-1, 0, ROGUE, ROGUE,
2927 $ A( IA+1+(JA-1)*DESCA( M_ ) ),
2928 $ DESCA( M_ ) )
2929 ELSE
2930 CALL PB_SLASET( 'lower', N, N, 0, ROGUE, ONE,
2931 $ A( IA+(JA-1)*DESCA( M_ ) ), DESCA( M_ ) )
2932 END IF
2933 END IF
2934 CALL PSCHKMIN( ERR, N, N, A, PA, IA, JA, DESCA, IERR( 1 ) )
2935*
2936.EQ. ELSE IF( NROUT5 ) THEN
2937*
2938* Test PSGER
2939*
2940* Check the resulting matrix A
2941*
2942 CALL PSVMCH( ICTXT, 'ge', M, N, ALPHA, X, IX, JX, DESCX,
2943 $ INCX, Y, IY, JY, DESCY, INCY, A, PA, IA, JA,
2944 $ DESCA, WORK, ERR, IERR( 1 ) )
2945.NE. IF( IERR( 1 )0 ) THEN
2946.EQ..AND..EQ. IF( MYROW0 MYCOL0 )
2947 $ WRITE( NOUT, FMT = 9997 )
2948.GT. ELSE IF( ERRTHRESH ) THEN
2949.EQ..AND..EQ. IF( MYROW0 MYCOL0 )
2950 $ WRITE( NOUT, FMT = 9996 ) ERR
2951 END IF
2952*
2953* Check the input-only arguments
2954*
2955 CALL PSCHKVIN( ERR, M, X, PX, IX, JX, DESCX, INCX, IERR( 2 ) )
2956 CALL PSCHKVIN( ERR, N, Y, PY, IY, JY, DESCY, INCY, IERR( 3 ) )
2957*
2958.EQ. ELSE IF( NROUT6 ) THEN
2959*
2960* Test PSSYR
2961*
2962* Check the resulting matrix A
2963*
2964 CALL PSVMCH( ICTXT, UPLO, N, N, ALPHA, X, IX, JX, DESCX,
2965 $ INCX, X, IX, JX, DESCX, INCX, A, PA, IA, JA,
2966 $ DESCA, WORK, ERR, IERR( 1 ) )
2967.NE. IF( IERR( 1 )0 ) THEN
2968.EQ..AND..EQ. IF( MYROW0 MYCOL0 )
2969 $ WRITE( NOUT, FMT = 9997 )
2970.GT. ELSE IF( ERRTHRESH ) THEN
2971.EQ..AND..EQ. IF( MYROW0 MYCOL0 )
2972 $ WRITE( NOUT, FMT = 9996 ) ERR
2973 END IF
2974*
2975* Check the input-only arguments
2976*
2977 CALL PSCHKVIN( ERR, N, X, PX, IX, JX, DESCX, INCX, IERR( 2 ) )
2978*
2979.EQ. ELSE IF( NROUT7 ) THEN
2980*
2981* Test PSSYR2
2982*
2983* Check the resulting matrix A
2984*
2985 CALL PSVMCH2( ICTXT, UPLO, N, N, ALPHA, X, IX, JX, DESCX, INCX,
2986 $ Y, IY, JY, DESCY, INCY, A, PA, IA, JA, DESCA,
2987 $ WORK, ERR, IERR( 1 ) )
2988.NE. IF( IERR( 1 )0 ) THEN
2989.EQ..AND..EQ. IF( MYROW0 MYCOL0 )
2990 $ WRITE( NOUT, FMT = 9997 )
2991.GT. ELSE IF( ERRTHRESH ) THEN
2992.EQ..AND..EQ. IF( MYROW0 MYCOL0 )
2993 $ WRITE( NOUT, FMT = 9996 ) ERR
2994 END IF
2995*
2996* Check the input-only arguments
2997*
2998 CALL PSCHKVIN( ERR, N, X, PX, IX, JX, DESCX, INCX, IERR( 2 ) )
2999 CALL PSCHKVIN( ERR, N, Y, PY, IY, JY, DESCY, INCY, IERR( 3 ) )
3000*
3001 END IF
3002*
3003.NE. IF( IERR( 1 )0 ) THEN
3004 INFO = INFO + 1
3005.EQ..AND..EQ. IF( MYROW0 MYCOL0 )
3006 $ WRITE( NOUT, FMT = 9999 ) 'a'
3007 END IF
3008*
3009.NE. IF( IERR( 2 )0 ) THEN
3010 INFO = INFO + 2
3011.EQ..AND..EQ. IF( MYROW0 MYCOL0 )
3012 $ WRITE( NOUT, FMT = 9998 ) 'x'
3013 END IF
3014*
3015.NE. IF( IERR( 3 )0 ) THEN
3016 INFO = INFO + 4
3017.EQ..AND..EQ. IF( MYROW0 MYCOL0 )
3018 $ WRITE( NOUT, FMT = 9998 ) 'y'
3019 END IF
3020*
3021 9999 FORMAT( 2X, ' ***** error: matrix operand ', A,
3022 $ ' is incorrect.' )
3023 9998 FORMAT( 2x, ' ***** ERROR: Vector operand ', a,
3024 $ ' is incorrect.' )
3025 9997 FORMAT( 2x, ' ***** FATAL ERROR - Computed result is less ',
3026 $ 'than half accurate *****' )
3027 9996 FORMAT( 2x, ' ***** Test completed with maximum test ratio: ',
3028 $ f11.5, ' SUSPECT *****' )
3029*
3030 RETURN
3031*
3032* End of PSBLAS2TSTCHK
3033*
lsame
logical function lsame(ca, cb)
LSAME
Definition lsame.f:53
strsv
subroutine strsv(uplo, trans, diag, n, a, lda, x, incx)
STRSV
Definition strsv.f:149
blacs_gridinfo
subroutine blacs_gridinfo(cntxt, nprow, npcol, myrow, mycol)
Definition mpi.f:754
pschkmin
subroutine pschkmin(errmax, m, n, a, pa, ia, ja, desca, info)
Definition psblastst.f:3326
pschkvin
subroutine pschkvin(errmax, n, x, px, ix, jx, descx, incx, info)
Definition psblastst.f:2576
pb_slaset
subroutine pb_slaset(uplo, m, n, ioffd, alpha, beta, a, lda)
Definition psblastst.f:9361
psvmch
subroutine psvmch(ictxt, uplo, m, n, alpha, x, ix, jx, descx, incx, y, iy, jy, descy, incy, a, pa, ia, ja, desca, g, err, info)
Definition psblastst.f:4570
psmvch
subroutine psmvch(ictxt, trans, m, n, alpha, a, ia, ja, desca, x, ix, jx, descx, incx, beta, y, py, iy, jy, descy, incy, g, err, info)
Definition psblastst.f:4157
psvmch2
subroutine psvmch2(ictxt, uplo, m, n, alpha, x, ix, jx, descx, incx, y, iy, jy, descy, incy, a, pa, ia, ja, desca, g, err, info)
Definition psblastst.f:4919

◆ psblas2tstchke()

subroutine psblas2tstchke ( logical, dimension( * ) ltest,
integer inout,
integer nprocs )

Definition at line 1988 of file psblas2tst.f.

1989*
1990* -- PBLAS test routine (version 2.0) --
1991* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
1992* and University of California, Berkeley.
1993* April 1, 1998
1994*
1995* .. Scalar Arguments ..
1996 INTEGER INOUT, NPROCS
1997* ..
1998* .. Array Arguments ..
1999 LOGICAL LTEST( * )
2000* ..
2001*
2002* Purpose
2003* =======
2004*
2005* PSBLAS2TSTCHKE tests the error exits of the Level 2 PBLAS.
2006*
2007* Arguments
2008* =========
2009*
2010* LTEST (global input) LOGICAL array
2011* On entry, LTEST is an array of dimension at least 7 (NSUBS).
2012* If LTEST( 1 ) is .TRUE., PSGEMV will be tested;
2013* If LTEST( 2 ) is .TRUE., PSSYMV will be tested;
2014* If LTEST( 3 ) is .TRUE., PSTRMV will be tested;
2015* If LTEST( 4 ) is .TRUE., PSTRSV will be tested;
2016* If LTEST( 5 ) is .TRUE., PSGER will be tested;
2017* If LTEST( 6 ) is .TRUE., PSSYR will be tested;
2018* If LTEST( 7 ) is .TRUE., PSSYR2 will be tested;
2019*
2020* INOUT (global input) INTEGER
2021* On entry, INOUT specifies the unit number for output file.
2022* When INOUT is 6, output to screen, when INOUT = 0, output to
2023* stderr. INOUT is only defined in process 0.
2024*
2025* NPROCS (global input) INTEGER
2026* On entry, NPROCS specifies the total number of processes cal-
2027* ling this routine.
2028*
2029* Calling sequence encodings
2030* ==========================
2031*
2032* code Formal argument list Examples
2033*
2034* 11 (n, v1,v2) _SWAP, _COPY
2035* 12 (n,s1, v1 ) _SCAL, _SCAL
2036* 13 (n,s1, v1,v2) _AXPY, _DOT_
2037* 14 (n,s1,i1,v1 ) _AMAX
2038* 15 (n,u1, v1 ) _ASUM, _NRM2
2039*
2040* 21 ( trans, m,n,s1,m1,v1,s2,v2) _GEMV
2041* 22 (uplo, n,s1,m1,v1,s2,v2) _SYMV, _HEMV
2042* 23 (uplo,trans,diag, n, m1,v1 ) _TRMV, _TRSV
2043* 24 ( m,n,s1,v1,v2,m1) _GER_
2044* 25 (uplo, n,s1,v1, m1) _SYR
2045* 26 (uplo, n,u1,v1, m1) _HER
2046* 27 (uplo, n,s1,v1,v2,m1) _SYR2, _HER2
2047*
2048* 31 ( transa,transb, m,n,k,s1,m1,m2,s2,m3) _GEMM
2049* 32 (side,uplo, m,n, s1,m1,m2,s2,m3) _SYMM, _HEMM
2050* 33 ( uplo,trans, n,k,s1,m1, s2,m3) _SYRK
2051* 34 ( uplo,trans, n,k,u1,m1, u2,m3) _HERK
2052* 35 ( uplo,trans, n,k,s1,m1,m2,s2,m3) _SYR2K
2053* 36 ( uplo,trans, n,k,s1,m1,m2,u2,m3) _HER2K
2054* 37 ( m,n, s1,m1, s2,m3) _TRAN_
2055* 38 (side,uplo,transa, diag,m,n, s1,m1,m2 ) _TRMM, _TRSM
2056* 39 ( trans, m,n, s1,m1, s2,m3) _GEADD
2057* 40 ( uplo,trans, m,n, s1,m1, s2,m3) _TRADD
2058*
2059* -- Written on April 1, 1998 by
2060* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
2061*
2062* =====================================================================
2063*
2064* .. Parameters ..
2065 INTEGER NSUBS
2066 parameter( nsubs = 7 )
2067* ..
2068* .. Local Scalars ..
2069 LOGICAL ABRTSAV
2070 INTEGER I, ICTXT, MYCOL, MYROW, NPCOL, NPROW
2071* ..
2072* .. Local Arrays ..
2073 INTEGER SCODE( NSUBS )
2074* ..
2075* .. External Subroutines ..
2076 EXTERNAL blacs_get, blacs_gridexit, blacs_gridinfo,
2077 $ blacs_gridinit, psdimee, psgemv, psger,
2078 $ psmatee, psoptee, pssymv, pssyr, pssyr2,
2079 $ pstrmv, pstrsv, psvecee
2080* ..
2081* .. Common Blocks ..
2082 LOGICAL ABRTFLG
2083 INTEGER NOUT
2084 CHARACTER*7 SNAMES( NSUBS )
2085 COMMON /snamec/snames
2086 COMMON /pberrorc/nout, abrtflg
2087* ..
2088* .. Data Statements ..
2089 DATA scode/21, 22, 23, 23, 24, 25, 27/
2090* ..
2091* .. Executable Statements ..
2092*
2093* Temporarily define blacs grid to include all processes so
2094* information can be broadcast to all processes.
2095*
2096 CALL blacs_get( -1, 0, ictxt )
2097 CALL blacs_gridinit( ictxt, 'Row-major', 1, nprocs )
2098 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
2099*
2100* Set ABRTFLG to FALSE so that the PBLAS error handler won't abort
2101* on errors during these tests and set the output device unit for
2102* it.
2103*
2104 abrtsav = abrtflg
2105 abrtflg = .false.
2106 nout = inout
2107*
2108* Test PSGEMV
2109*
2110 i = 1
2111 IF( ltest( i ) ) THEN
2112 CALL psoptee( ictxt, nout, psgemv, scode( i ), snames( i ) )
2113 CALL psdimee( ictxt, nout, psgemv, scode( i ), snames( i ) )
2114 CALL psmatee( ictxt, nout, psgemv, scode( i ), snames( i ) )
2115 CALL psvecee( ictxt, nout, psgemv, scode( i ), snames( i ) )
2116 END IF
2117*
2118* Test PSSYMV
2119*
2120 i = i + 1
2121 IF( ltest( i ) ) THEN
2122 CALL psoptee( ictxt, nout, pssymv, scode( i ), snames( i ) )
2123 CALL psdimee( ictxt, nout, pssymv, scode( i ), snames( i ) )
2124 CALL psmatee( ictxt, nout, pssymv, scode( i ), snames( i ) )
2125 CALL psvecee( ictxt, nout, pssymv, scode( i ), snames( i ) )
2126 END IF
2127*
2128* Test PSTRMV
2129*
2130 i = i + 1
2131 IF( ltest( i ) ) THEN
2132 CALL psoptee( ictxt, nout, pstrmv, scode( i ), snames( i ) )
2133 CALL psdimee( ictxt, nout, pstrmv, scode( i ), snames( i ) )
2134 CALL psmatee( ictxt, nout, pstrmv, scode( i ), snames( i ) )
2135 CALL psvecee( ictxt, nout, pstrmv, scode( i ), snames( i ) )
2136 END IF
2137*
2138* Test PSTRSV
2139*
2140 i = i + 1
2141 IF( ltest( i ) ) THEN
2142 CALL psoptee( ictxt, nout, pstrsv, scode( i ), snames( i ) )
2143 CALL psdimee( ictxt, nout, pstrsv, scode( i ), snames( i ) )
2144 CALL psmatee( ictxt, nout, pstrsv, scode( i ), snames( i ) )
2145 CALL psvecee( ictxt, nout, pstrsv, scode( i ), snames( i ) )
2146 END IF
2147*
2148* Test PSGER
2149*
2150 i = i + 1
2151 IF( ltest( i ) ) THEN
2152 CALL psdimee( ictxt, nout, psger, scode( i ), snames( i ) )
2153 CALL psvecee( ictxt, nout, psger, scode( i ), snames( i ) )
2154 CALL psmatee( ictxt, nout, psger, scode( i ), snames( i ) )
2155 END IF
2156*
2157* Test PSSYR
2158*
2159 i = i + 1
2160 IF( ltest( i ) ) THEN
2161 CALL psoptee( ictxt, nout, pssyr, scode( i ), snames( i ) )
2162 CALL psdimee( ictxt, nout, pssyr, scode( i ), snames( i ) )
2163 CALL psvecee( ictxt, nout, pssyr, scode( i ), snames( i ) )
2164 CALL psmatee( ictxt, nout, pssyr, scode( i ), snames( i ) )
2165 END IF
2166*
2167* Test PSSYR2
2168*
2169 i = i + 1
2170 IF( ltest( i ) ) THEN
2171 CALL psoptee( ictxt, nout, pssyr2, scode( i ), snames( i ) )
2172 CALL psdimee( ictxt, nout, pssyr2, scode( i ), snames( i ) )
2173 CALL psvecee( ictxt, nout, pssyr2, scode( i ), snames( i ) )
2174 CALL psmatee( ictxt, nout, pssyr2, scode( i ), snames( i ) )
2175 END IF
2176*
2177 IF( myrow.EQ.0 .AND. mycol.EQ.0 )
2178 $ WRITE( nout, fmt = 9999 )
2179*
2180 CALL blacs_gridexit( ictxt )
2181*
2182* Reset ABRTFLG to the value it had before calling this routine
2183*
2184 abrtflg = abrtsav
2185*
2186 9999 FORMAT( 2x, 'Error-exit tests completed.' )
2187*
2188 RETURN
2189*
2190* End of PSBLAS2TSTCHKE
2191*
psdimee
subroutine psdimee(ictxt, nout, subptr, scode, sname)
Definition psblastst.f:455
psvecee
subroutine psvecee(ictxt, nout, subptr, scode, sname)
Definition psblastst.f:936
psoptee
subroutine psoptee(ictxt, nout, subptr, scode, sname)
Definition psblastst.f:2
psmatee
subroutine psmatee(ictxt, nout, subptr, scode, sname)
Definition psblastst.f:1190

◆ pschkarg2()

subroutine pschkarg2 ( integer ictxt,
integer nout,
character*(*) sname,
character*1 uplo,
character*1 trans,
character*1 diag,
integer m,
integer n,
real alpha,
integer ia,
integer ja,
integer, dimension( * ) desca,
integer ix,
integer jx,
integer, dimension( * ) descx,
integer incx,
real beta,
integer iy,
integer jy,
integer, dimension( * ) descy,
integer incy,
integer info )

Definition at line 2193 of file psblas2tst.f.

2196*
2197* -- PBLAS test routine (version 2.0) --
2198* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
2199* and University of California, Berkeley.
2200* April 1, 1998
2201*
2202* .. Scalar Arguments ..
2203 CHARACTER*1 DIAG, TRANS, UPLO
2204 INTEGER IA, ICTXT, INCX, INCY, INFO, IX, IY, JA, JX,
2205 $ JY, M, N, NOUT
2206 REAL ALPHA, BETA
2207* ..
2208* .. Array Arguments ..
2209 CHARACTER*(*) SNAME
2210 INTEGER DESCA( * ), DESCX( * ), DESCY( * )
2211* ..
2212*
2213* Purpose
2214* =======
2215*
2216* PSCHKARG2 checks the input-only arguments of the Level 2 PBLAS. When
2217* INFO = 0, this routine makes a copy of its arguments (which are INPUT
2218* only arguments to PBLAS routines). Otherwise, it verifies the values
2219* of these arguments against the saved copies.
2220*
2221* Arguments
2222* =========
2223*
2224* ICTXT (local input) INTEGER
2225* On entry, ICTXT specifies the BLACS context handle, indica-
2226* ting the global context of the operation. The context itself
2227* is global, but the value of ICTXT is local.
2228*
2229* NOUT (global input) INTEGER
2230* On entry, NOUT specifies the unit number for the output file.
2231* When NOUT is 6, output to screen, when NOUT is 0, output to
2232* stderr. NOUT is only defined for process 0.
2233*
2234* SNAME (global input) CHARACTER*(*)
2235* On entry, SNAME specifies the subroutine name calling this
2236* subprogram.
2237*
2238* UPLO (global input) CHARACTER*1
2239* On entry, UPLO specifies the UPLO option in the Level 2 PBLAS
2240* operation.
2241*
2242* TRANS (global input) CHARACTER*1
2243* On entry, TRANS specifies the TRANS option in the Level 2
2244* PBLAS operation.
2245*
2246* DIAG (global input) CHARACTER*1
2247* On entry, DIAG specifies the DIAG option in the Level 2 PBLAS
2248* operation.
2249*
2250* M (global input) INTEGER
2251* On entry, M specifies the dimension of the submatrix ope-
2252* rands.
2253*
2254* N (global input) INTEGER
2255* On entry, N specifies the dimension of the submatrix ope-
2256* rands.
2257*
2258* ALPHA (global input) REAL
2259* On entry, ALPHA specifies the scalar alpha.
2260*
2261* IA (global input) INTEGER
2262* On entry, IA specifies A's global row index, which points to
2263* the beginning of the submatrix sub( A ).
2264*
2265* JA (global input) INTEGER
2266* On entry, JA specifies A's global column index, which points
2267* to the beginning of the submatrix sub( A ).
2268*
2269* DESCA (global and local input) INTEGER array
2270* On entry, DESCA is an integer array of dimension DLEN_. This
2271* is the array descriptor for the matrix A.
2272*
2273* IX (global input) INTEGER
2274* On entry, IX specifies X's global row index, which points to
2275* the beginning of the submatrix sub( X ).
2276*
2277* JX (global input) INTEGER
2278* On entry, JX specifies X's global column index, which points
2279* to the beginning of the submatrix sub( X ).
2280*
2281* DESCX (global and local input) INTEGER array
2282* On entry, DESCX is an integer array of dimension DLEN_. This
2283* is the array descriptor for the matrix X.
2284*
2285* INCX (global input) INTEGER
2286* On entry, INCX specifies the global increment for the
2287* elements of X. Only two values of INCX are supported in
2288* this version, namely 1 and M_X. INCX must not be zero.
2289*
2290* BETA (global input) REAL
2291* On entry, BETA specifies the scalar beta.
2292*
2293* IY (global input) INTEGER
2294* On entry, IY specifies Y's global row index, which points to
2295* the beginning of the submatrix sub( Y ).
2296*
2297* JY (global input) INTEGER
2298* On entry, JY specifies Y's global column index, which points
2299* to the beginning of the submatrix sub( Y ).
2300*
2301* DESCY (global and local input) INTEGER array
2302* On entry, DESCY is an integer array of dimension DLEN_. This
2303* is the array descriptor for the matrix Y.
2304*
2305* INCY (global input) INTEGER
2306* On entry, INCY specifies the global increment for the
2307* elements of Y. Only two values of INCY are supported in
2308* this version, namely 1 and M_Y. INCY must not be zero.
2309*
2310* INFO (global input/global output) INTEGER
2311* When INFO = 0 on entry, the values of the arguments which are
2312* INPUT only arguments to a PBLAS routine are copied into sta-
2313* tic variables and INFO is unchanged on exit. Otherwise, the
2314* values of the arguments are compared against the saved co-
2315* pies. In case no error has been found INFO is zero on return,
2316* otherwise it is non zero.
2317*
2318* -- Written on April 1, 1998 by
2319* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
2320*
2321* =====================================================================
2322*
2323* .. Parameters ..
2324 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
2325 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
2326 $ RSRC_
2327 parameter( block_cyclic_2d_inb = 2, dlen_ = 11,
2328 $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
2329 $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
2330 $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
2331* ..
2332* .. Local Scalars ..
2333 CHARACTER*1 DIAGREF, TRANSREF, UPLOREF
2334 INTEGER I, IAREF, INCXREF, INCYREF, IXREF, IYREF,
2335 $ JAREF, JXREF, JYREF, MREF, MYCOL, MYROW, NPCOL,
2336 $ NPROW, NREF
2337 REAL ALPHAREF, BETAREF
2338* ..
2339* .. Local Arrays ..
2340 CHARACTER*15 ARGNAME
2341 INTEGER DESCAREF( DLEN_ ), DESCXREF( DLEN_ ),
2342 $ DESCYREF( DLEN_ )
2343* ..
2344* .. External Subroutines ..
2345 EXTERNAL blacs_gridinfo, igsum2d
2346* ..
2347* .. External Functions ..
2348 LOGICAL LSAME
2349 EXTERNAL lsame
2350* ..
2351* .. Save Statements ..
2352 SAVE
2353* ..
2354* .. Executable Statements ..
2355*
2356* Get grid parameters
2357*
2358 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
2359*
2360* Check if first call. If yes, then save.
2361*
2362 IF( info.EQ.0 ) THEN
2363*
2364 diagref = diag
2365 transref = trans
2366 uploref = uplo
2367 mref = m
2368 nref = n
2369 alpharef = alpha
2370 iaref = ia
2371 jaref = ja
2372 DO 10 i = 1, dlen_
2373 descaref( i ) = desca( i )
2374 10 CONTINUE
2375 ixref = ix
2376 jxref = jx
2377 DO 20 i = 1, dlen_
2378 descxref( i ) = descx( i )
2379 20 CONTINUE
2380 incxref = incx
2381 betaref = beta
2382 iyref = iy
2383 jyref = jy
2384 DO 30 i = 1, dlen_
2385 descyref( i ) = descy( i )
2386 30 CONTINUE
2387 incyref = incy
2388*
2389 ELSE
2390*
2391* Test saved args. Return with first mismatch.
2392*
2393 argname = ' '
2394.NOT. IF( LSAME( DIAG, DIAGREF ) ) THEN
2395 WRITE( ARGNAME, FMT = '(a)' ) 'diag'
2396.NOT. ELSE IF( LSAME( TRANS, TRANSREF ) ) THEN
2397 WRITE( ARGNAME, FMT = '(a)' ) 'TRANS'
2398 ELSE IF( .NOT. lsame( uplo, uploref ) ) THEN
2399 WRITE( argname, fmt = '(A)' ) 'UPLO'
2400 ELSE IF( m.NE.mref ) THEN
2401 WRITE( argname, fmt = '(A)' ) 'M'
2402 ELSE IF( n.NE.nref ) THEN
2403 WRITE( argname, fmt = '(A)' ) 'N'
2404 ELSE IF( alpha.NE.alpharef ) THEN
2405 WRITE( argname, fmt = '(A)' ) 'ALPHA'
2406 ELSE IF( ia.NE.iaref ) THEN
2407 WRITE( argname, fmt = '(A)' ) 'IA'
2408 ELSE IF( ja.NE.jaref ) THEN
2409 WRITE( argname, fmt = '(A)' ) 'JA'
2410 ELSE IF( desca( dtype_ ).NE.descaref( dtype_ ) ) THEN
2411 WRITE( argname, fmt = '(A)' ) 'desca( dtype_ )'
2412.NE. ELSE IF( DESCA( M_ )DESCAREF( M_ ) ) THEN
2413 WRITE( ARGNAME, FMT = '(a)' ) 'desca( m_ )'
2414.NE. ELSE IF( DESCA( N_ )DESCAREF( N_ ) ) THEN
2415 WRITE( ARGNAME, FMT = '(a)' ) 'desca( n_ )'
2416.NE. ELSE IF( DESCA( IMB_ )DESCAREF( IMB_ ) ) THEN
2417 WRITE( ARGNAME, FMT = '(a)' ) 'desca( imb_ )'
2418.NE. ELSE IF( DESCA( INB_ )DESCAREF( INB_ ) ) THEN
2419 WRITE( ARGNAME, FMT = '(a)' ) 'desca( inb_ )'
2420.NE. ELSE IF( DESCA( MB_ )DESCAREF( MB_ ) ) THEN
2421 WRITE( ARGNAME, FMT = '(a)' ) 'desca( mb_ )'
2422.NE. ELSE IF( DESCA( NB_ )DESCAREF( NB_ ) ) THEN
2423 WRITE( ARGNAME, FMT = '(a)' ) 'desca( nb_ )'
2424.NE. ELSE IF( DESCA( RSRC_ )DESCAREF( RSRC_ ) ) THEN
2425 WRITE( ARGNAME, FMT = '(a)' ) 'desca( rsrc_ )'
2426.NE. ELSE IF( DESCA( CSRC_ )DESCAREF( CSRC_ ) ) THEN
2427 WRITE( ARGNAME, FMT = '(a)' ) 'desca( csrc_ )'
2428 ELSE IF( desca( ctxt_ ).NE.descaref( ctxt_ ) ) THEN
2429 WRITE( argname, fmt = '(A)' ) 'DESCA( CTXT_ )'
2430 ELSE IF( desca( lld_ ).NE.descaref( lld_ ) ) THEN
2431 WRITE( argname, fmt = '(A)' ) 'DESCA( LLD_ )'
2432 ELSE IF( ix.NE.ixref ) THEN
2433 WRITE( argname, fmt = '(A)' ) 'IX'
2434 ELSE IF( jx.NE.jxref ) THEN
2435 WRITE( argname, fmt = '(A)' ) 'JX'
2436 ELSE IF( descx( dtype_ ).NE.descxref( dtype_ ) ) THEN
2437 WRITE( argname, fmt = '(A)' ) 'DESCX( DTYPE_ )'
2438 ELSE IF( descx( m_ ).NE.descxref( m_ ) ) THEN
2439 WRITE( argname, fmt = '(A)' ) 'DESCX( M_ )'
2440 ELSE IF( descx( n_ ).NE.descxref( n_ ) ) THEN
2441 WRITE( argname, fmt = '(A)' ) 'DESCX( N_ )'
2442 ELSE IF( descx( imb_ ).NE.descxref( imb_ ) ) THEN
2443 WRITE( argname, fmt = '(A)' ) 'DESCX( IMB_ )'
2444 ELSE IF( descx( inb_ ).NE.descxref( inb_ ) ) THEN
2445 WRITE( argname, fmt = '(A)' ) 'DESCX( INB_ )'
2446 ELSE IF( descx( mb_ ).NE.descxref( mb_ ) ) THEN
2447 WRITE( argname, fmt = '(A)' ) 'DESCX( MB_ )'
2448 ELSE IF( descx( nb_ ).NE.descxref( nb_ ) ) THEN
2449 WRITE( argname, fmt = '(A)' ) 'DESCX( NB_ )'
2450 ELSE IF( descx( rsrc_ ).NE.descxref( rsrc_ ) ) THEN
2451 WRITE( argname, fmt = '(A)' ) 'DESCX( RSRC_ )'
2452 ELSE IF( descx( csrc_ ).NE.descxref( csrc_ ) ) THEN
2453 WRITE( argname, fmt = '(A)' ) 'DESCX( CSRC_ )'
2454 ELSE IF( descx( ctxt_ ).NE.descxref( ctxt_ ) ) THEN
2455 WRITE( argname, fmt = '(A)' ) 'DESCX( CTXT_ )'
2456 ELSE IF( descx( lld_ ).NE.descxref( lld_ ) ) THEN
2457 WRITE( argname, fmt = '(A)' ) 'DESCX( LLD_ )'
2458 ELSE IF( incx.NE.incxref ) THEN
2459 WRITE( argname, fmt = '(A)' ) 'INCX'
2460 ELSE IF( beta.NE.betaref ) THEN
2461 WRITE( argname, fmt = '(A)' ) 'BETA'
2462 ELSE IF( iy.NE.iyref ) THEN
2463 WRITE( argname, fmt = '(A)' ) 'IY'
2464 ELSE IF( jy.NE.jyref ) THEN
2465 WRITE( argname, fmt = '(A)' ) 'JY'
2466 ELSE IF( descy( dtype_ ).NE.descyref( dtype_ ) ) THEN
2467 WRITE( argname, fmt = '(A)' ) 'DESCY( DTYPE_ )'
2468 ELSE IF( descy( m_ ).NE.descyref( m_ ) ) THEN
2469 WRITE( argname, fmt = '(A)' ) 'DESCY( M_ )'
2470 ELSE IF( descy( n_ ).NE.descyref( n_ ) ) THEN
2471 WRITE( argname, fmt = '(A)' ) 'DESCY( N_ )'
2472 ELSE IF( descy( imb_ ).NE.descyref( imb_ ) ) THEN
2473 WRITE( argname, fmt = '(A)' ) 'DESCY( IMB_ )'
2474 ELSE IF( descy( inb_ ).NE.descyref( inb_ ) ) THEN
2475 WRITE( argname, fmt = '(A)' ) 'DESCY( INB_ )'
2476 ELSE IF( descy( mb_ ).NE.descyref( mb_ ) ) THEN
2477 WRITE( argname, fmt = '(A)' ) 'DESCY( MB_ )'
2478 ELSE IF( descy( nb_ ).NE.descyref( nb_ ) ) THEN
2479 WRITE( argname, fmt = '(A)' ) 'DESCY( NB_ )'
2480 ELSE IF( descy( rsrc_ ).NE.descyref( rsrc_ ) ) THEN
2481 WRITE( argname, fmt = '(A)' ) 'DESCY( RSRC_ )'
2482 ELSE IF( descy( csrc_ ).NE.descyref( csrc_ ) ) THEN
2483 WRITE( argname, fmt = '(A)' ) 'DESCY( CSRC_ )'
2484 ELSE IF( descy( ctxt_ ).NE.descyref( ctxt_ ) ) THEN
2485 WRITE( argname, fmt = '(A)' ) 'DESCY( CTXT_ )'
2486 ELSE IF( descy( lld_ ).NE.descyref( lld_ ) ) THEN
2487 WRITE( argname, fmt = '(A)' ) 'DESCY( LLD_ )'
2488 ELSE IF( incy.NE.incyref ) THEN
2489 WRITE( argname, fmt = '(A)' ) 'INCY'
2490 ELSE
2491 info = 0
2492 END IF
2493*
2494 CALL igsum2d( ictxt, 'All', ' ', 1, 1, info, 1, -1, 0 )
2495*
2496 IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
2497*
2498 IF( info.NE.0 ) THEN
2499 WRITE( nout, fmt = 9999 ) argname, sname
2500 ELSE
2501 WRITE( nout, fmt = 9998 ) sname
2502 END IF
2503*
2504 END IF
2505*
2506 END IF
2507*
2508 9999 FORMAT( 2x, ' ***** Input-only parameter check: ', a,
2509 $ ' FAILED changed ', a, ' *****' )
2510 9998 FORMAT( 2x, ' ***** Input-only parameter check: ', a,
2511 $ ' PASSED *****' )
2512*
2513 RETURN
2514*
2515* End of PSCHKARG2
2516*