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

◆ pzbla1tstinfo()

subroutine pzbla1tstinfo ( character*( * )  summry,
integer  nout,
integer  nmat,
integer, dimension( ldval )  nval,
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,
logical, dimension( * )  ltest,
logical  sof,
logical  tee,
integer  iam,
integer  igap,
integer  iverb,
integer  nprocs,
complex*16  alpha,
integer, dimension( * )  work 
)

Definition at line 793 of file pzblas1tst.f.

802*
803* -- PBLAS test routine (version 2.0) --
804* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
805* and University of California, Berkeley.
806* April 1, 1998
807*
808* .. Scalar Arguments ..
809 LOGICAL SOF, TEE
810 INTEGER IAM, IGAP, IVERB, LDPVAL, LDQVAL, LDVAL,
811 $ NGRIDS, NMAT, NOUT, NPROCS
812 COMPLEX*16 ALPHA
813* ..
814* .. Array Arguments ..
815 CHARACTER*( * ) SUMMRY
816 LOGICAL LTEST( * )
817 INTEGER CSCXVAL( LDVAL ), CSCYVAL( LDVAL ),
818 $ IMBXVAL( LDVAL ), IMBYVAL( LDVAL ),
819 $ INBXVAL( LDVAL ), INBYVAL( LDVAL ),
820 $ INCXVAL( LDVAL ), INCYVAL( LDVAL ),
821 $ IXVAL( LDVAL ), IYVAL( LDVAL ), JXVAL( LDVAL ),
822 $ JYVAL( LDVAL ), MBXVAL( LDVAL ),
823 $ MBYVAL( LDVAL ), MXVAL( LDVAL ),
824 $ MYVAL( LDVAL ), NBXVAL( LDVAL ),
825 $ NBYVAL( LDVAL ), NVAL( LDVAL ), NXVAL( LDVAL ),
826 $ NYVAL( LDVAL ), PVAL( LDPVAL ), QVAL( LDQVAL ),
827 $ RSCXVAL( LDVAL ), RSCYVAL( LDVAL ), WORK( * )
828* ..
829*
830* Purpose
831* =======
832*
833* PZBLA1TSTINFO get the needed startup information for testing various
834* Level 1 PBLAS routines, and transmits it to all processes.
835*
836* Notes
837* =====
838*
839* For packing the information we assumed that the length in bytes of an
840* integer is equal to the length in bytes of a real single precision.
841*
842* Arguments
843* =========
844*
845* SUMMRY (global output) CHARACTER*(*)
846* On exit, SUMMRY is the name of output (summary) file (if
847* any). SUMMRY is only defined for process 0.
848*
849* NOUT (global output) INTEGER
850* On exit, NOUT specifies the unit number for the output file.
851* When NOUT is 6, output to screen, when NOUT is 0, output to
852* stderr. NOUT is only defined for process 0.
853*
854* NMAT (global output) INTEGER
855* On exit, NMAT specifies the number of different test cases.
856*
857* NVAL (global output) INTEGER array
858* On entry, NVAL is an array of dimension LDVAL. On exit, this
859* array contains the values of N to run the code with.
860*
861* MXVAL (global output) INTEGER array
862* On entry, MXVAL is an array of dimension LDVAL. On exit, this
863* array contains the values of DESCX( M_ ) to run the code
864* with.
865*
866* NXVAL (global output) INTEGER array
867* On entry, NXVAL is an array of dimension LDVAL. On exit, this
868* array contains the values of DESCX( N_ ) to run the code
869* with.
870*
871* IMBXVAL (global output) INTEGER array
872* On entry, IMBXVAL is an array of dimension LDVAL. On exit,
873* this array contains the values of DESCX( IMB_ ) to run the
874* code with.
875*
876* MBXVAL (global output) INTEGER array
877* On entry, MBXVAL is an array of dimension LDVAL. On exit,
878* this array contains the values of DESCX( MB_ ) to run the
879* code with.
880*
881* INBXVAL (global output) INTEGER array
882* On entry, INBXVAL is an array of dimension LDVAL. On exit,
883* this array contains the values of DESCX( INB_ ) to run the
884* code with.
885*
886* NBXVAL (global output) INTEGER array
887* On entry, NBXVAL is an array of dimension LDVAL. On exit,
888* this array contains the values of DESCX( NB_ ) to run the
889* code with.
890*
891* RSCXVAL (global output) INTEGER array
892* On entry, RSCXVAL is an array of dimension LDVAL. On exit,
893* this array contains the values of DESCX( RSRC_ ) to run the
894* code with.
895*
896* CSCXVAL (global output) INTEGER array
897* On entry, CSCXVAL is an array of dimension LDVAL. On exit,
898* this array contains the values of DESCX( CSRC_ ) to run the
899* code with.
900*
901* IXVAL (global output) INTEGER array
902* On entry, IXVAL is an array of dimension LDVAL. On exit, this
903* array contains the values of IX to run the code with.
904*
905* JXVAL (global output) INTEGER array
906* On entry, JXVAL is an array of dimension LDVAL. On exit, this
907* array contains the values of JX to run the code with.
908*
909* INCXVAL (global output) INTEGER array
910* On entry, INCXVAL is an array of dimension LDVAL. On exit,
911* this array contains the values of INCX to run the code with.
912*
913* MYVAL (global output) INTEGER array
914* On entry, MYVAL is an array of dimension LDVAL. On exit, this
915* array contains the values of DESCY( M_ ) to run the code
916* with.
917*
918* NYVAL (global output) INTEGER array
919* On entry, NYVAL is an array of dimension LDVAL. On exit, this
920* array contains the values of DESCY( N_ ) to run the code
921* with.
922*
923* IMBYVAL (global output) INTEGER array
924* On entry, IMBYVAL is an array of dimension LDVAL. On exit,
925* this array contains the values of DESCY( IMB_ ) to run the
926* code with.
927*
928* MBYVAL (global output) INTEGER array
929* On entry, MBYVAL is an array of dimension LDVAL. On exit,
930* this array contains the values of DESCY( MB_ ) to run the
931* code with.
932*
933* INBYVAL (global output) INTEGER array
934* On entry, INBYVAL is an array of dimension LDVAL. On exit,
935* this array contains the values of DESCY( INB_ ) to run the
936* code with.
937*
938* NBYVAL (global output) INTEGER array
939* On entry, NBYVAL is an array of dimension LDVAL. On exit,
940* this array contains the values of DESCY( NB_ ) to run the
941* code with.
942*
943* RSCYVAL (global output) INTEGER array
944* On entry, RSCYVAL is an array of dimension LDVAL. On exit,
945* this array contains the values of DESCY( RSRC_ ) to run the
946* code with.
947*
948* CSCYVAL (global output) INTEGER array
949* On entry, CSCYVAL is an array of dimension LDVAL. On exit,
950* this array contains the values of DESCY( CSRC_ ) to run the
951* code with.
952*
953* IYVAL (global output) INTEGER array
954* On entry, IYVAL is an array of dimension LDVAL. On exit, this
955* array contains the values of IY to run the code with.
956*
957* JYVAL (global output) INTEGER array
958* On entry, JYVAL is an array of dimension LDVAL. On exit, this
959* array contains the values of JY to run the code with.
960*
961* INCYVAL (global output) INTEGER array
962* On entry, INCYVAL is an array of dimension LDVAL. On exit,
963* this array contains the values of INCY to run the code with.
964*
965* LDVAL (global input) INTEGER
966* On entry, LDVAL specifies the maximum number of different va-
967* lues that can be used for DESCX(:), IX, JX, INCX, DESCY(:),
968* IY, JY and INCY. This is also the maximum number of test
969* cases.
970*
971* NGRIDS (global output) INTEGER
972* On exit, NGRIDS specifies the number of different values that
973* can be used for P and Q.
974*
975* PVAL (global output) INTEGER array
976* On entry, PVAL is an array of dimension LDPVAL. On exit, this
977* array contains the values of P to run the code with.
978*
979* LDPVAL (global input) INTEGER
980* On entry, LDPVAL specifies the maximum number of different
981* values that can be used for P.
982*
983* QVAL (global output) INTEGER array
984* On entry, QVAL is an array of dimension LDQVAL. On exit, this
985* array contains the values of Q to run the code with.
986*
987* LDQVAL (global input) INTEGER
988* On entry, LDQVAL specifies the maximum number of different
989* values that can be used for Q.
990*
991* LTEST (global output) LOGICAL array
992* On entry, LTEST is an array of dimension at least ten. On
993* exit, if LTEST( i ) is .TRUE., the i-th Level 1 PBLAS routine
994* will be tested. See the input file for the ordering of the
995* routines.
996*
997* SOF (global output) LOGICAL
998* On exit, if SOF is .TRUE., the tester will stop on the first
999* detected failure. Otherwise, it won't.
1000*
1001* TEE (global output) LOGICAL
1002* On exit, if TEE is .TRUE., the tester will perform the error
1003* exit tests. These tests won't be performed otherwise.
1004*
1005* IAM (local input) INTEGER
1006* On entry, IAM specifies the number of the process executing
1007* this routine.
1008*
1009* IGAP (global output) INTEGER
1010* On exit, IGAP specifies the user-specified gap used for pad-
1011* ding. IGAP must be at least zero.
1012*
1013* IVERB (global output) INTEGER
1014* On exit, IVERB specifies the output verbosity level: 0 for
1015* pass/fail, 1, 2 or 3 for matrix dump on errors.
1016*
1017* NPROCS (global input) INTEGER
1018* On entry, NPROCS specifies the total number of processes.
1019*
1020* ALPHA (global output) COMPLEX*16
1021* On exit, ALPHA specifies the value of alpha to be used in all
1022* the test cases.
1023*
1024* WORK (local workspace) INTEGER array
1025* On entry, WORK is an array of dimension at least
1026* MAX( 2, 2*NGRIDS+23*NMAT+NSUBS+4 ) with NSUBS equal to 10.
1027* This array is used to pack all output arrays in order to send
1028* the information in one message.
1029*
1030* -- Written on April 1, 1998 by
1031* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
1032*
1033* =====================================================================
1034*
1035* .. Parameters ..
1036 INTEGER NIN, NSUBS
1037 parameter( nin = 11, nsubs = 10 )
1038* ..
1039* .. Local Scalars ..
1040 LOGICAL LTESTT
1041 INTEGER I, ICTXT, J
1042 DOUBLE PRECISION EPS
1043* ..
1044* .. Local Arrays ..
1045 CHARACTER*7 SNAMET
1046 CHARACTER*79 USRINFO
1047* ..
1048* .. External Subroutines ..
1049 EXTERNAL blacs_abort, blacs_get, blacs_gridexit,
1050 $ blacs_gridinit, blacs_setup, icopy, igebr2d,
1051 $ igebs2d, sgebr2d, sgebs2d, zgebr2d, zgebs2d
1052* ..
1053* .. External Functions ..
1054 DOUBLE PRECISION PDLAMCH
1055 EXTERNAL pdlamch
1056* ..
1057* .. Intrinsic Functions ..
1058 INTRINSIC max, min
1059* ..
1060* .. Common Blocks ..
1061 CHARACTER*7 SNAMES( NSUBS )
1062 COMMON /snamec/snames
1063* ..
1064* .. Executable Statements ..
1065*
1066* Process 0 reads the input data, broadcasts to other processes and
1067* writes needed information to NOUT
1068*
1069 IF( iam.EQ.0 ) THEN
1070*
1071* Open file and skip data file header
1072*
1073 OPEN( nin, file='PZBLAS1TST.dat', status='OLD' )
1074 READ( nin, fmt = * ) summry
1075 summry = ' '
1076*
1077* Read in user-supplied info about machine type, compiler, etc.
1078*
1079 READ( nin, fmt = 9999 ) usrinfo
1080*
1081* Read name and unit number for summary output file
1082*
1083 READ( nin, fmt = * ) summry
1084 READ( nin, fmt = * ) nout
1085 IF( nout.NE.0 .AND. nout.NE.6 )
1086 $ OPEN( nout, file = summry, status = 'UNKNOWN' )
1087*
1088* Read and check the parameter values for the tests.
1089*
1090* Read the flag that indicates if Stop on Failure
1091*
1092 READ( nin, fmt = * ) sof
1093*
1094* Read the flag that indicates if Test Error Exits
1095*
1096 READ( nin, fmt = * ) tee
1097*
1098* Read the verbosity level
1099*
1100 READ( nin, fmt = * ) iverb
1101 IF( iverb.LT.0 .OR. iverb.GT.3 )
1102 $ iverb = 0
1103*
1104* Read the leading dimension gap
1105*
1106 READ( nin, fmt = * ) igap
1107 IF( igap.LT.0 )
1108 $ igap = 0
1109*
1110* Get number of grids
1111*
1112 READ( nin, fmt = * ) ngrids
1113 IF( ngrids.LT.1 .OR. ngrids.GT.ldpval ) THEN
1114 WRITE( nout, fmt = 9998 ) 'Grids', ldpval
1115 GO TO 100
1116 ELSE IF( ngrids.GT.ldqval ) THEN
1117 WRITE( nout, fmt = 9998 ) 'Grids', ldqval
1118 GO TO 100
1119 END IF
1120*
1121* Get values of P and Q
1122*
1123 READ( nin, fmt = * ) ( pval( i ), i = 1, ngrids )
1124 READ( nin, fmt = * ) ( qval( i ), i = 1, ngrids )
1125*
1126* Read ALPHA
1127*
1128 READ( nin, fmt = * ) alpha
1129*
1130* Read number of tests.
1131*
1132 READ( nin, fmt = * ) nmat
1133 IF( nmat.LT.1 .OR. nmat.GT.ldval ) THEN
1134 WRITE( nout, fmt = 9998 ) 'Tests', ldval
1135 GO TO 100
1136 END IF
1137*
1138* Read in input data into arrays.
1139*
1140 READ( nin, fmt = * ) ( nval( i ), i = 1, nmat )
1141 READ( nin, fmt = * ) ( mxval( i ), i = 1, nmat )
1142 READ( nin, fmt = * ) ( nxval( i ), i = 1, nmat )
1143 READ( nin, fmt = * ) ( imbxval( i ), i = 1, nmat )
1144 READ( nin, fmt = * ) ( inbxval( i ), i = 1, nmat )
1145 READ( nin, fmt = * ) ( mbxval( i ), i = 1, nmat )
1146 READ( nin, fmt = * ) ( nbxval( i ), i = 1, nmat )
1147 READ( nin, fmt = * ) ( rscxval( i ), i = 1, nmat )
1148 READ( nin, fmt = * ) ( cscxval( i ), i = 1, nmat )
1149 READ( nin, fmt = * ) ( ixval( i ), i = 1, nmat )
1150 READ( nin, fmt = * ) ( jxval( i ), i = 1, nmat )
1151 READ( nin, fmt = * ) ( incxval( i ), i = 1, nmat )
1152 READ( nin, fmt = * ) ( myval( i ), i = 1, nmat )
1153 READ( nin, fmt = * ) ( nyval( i ), i = 1, nmat )
1154 READ( nin, fmt = * ) ( imbyval( i ), i = 1, nmat )
1155 READ( nin, fmt = * ) ( inbyval( i ), i = 1, nmat )
1156 READ( nin, fmt = * ) ( mbyval( i ), i = 1, nmat )
1157 READ( nin, fmt = * ) ( nbyval( i ), i = 1, nmat )
1158 READ( nin, fmt = * ) ( rscyval( i ), i = 1, nmat )
1159 READ( nin, fmt = * ) ( cscyval( i ), i = 1, nmat )
1160 READ( nin, fmt = * ) ( iyval( i ), i = 1, nmat )
1161 READ( nin, fmt = * ) ( jyval( i ), i = 1, nmat )
1162 READ( nin, fmt = * ) ( incyval( i ), i = 1, nmat )
1163*
1164* Read names of subroutines and flags which indicate
1165* whether they are to be tested.
1166*
1167 DO 10 i = 1, nsubs
1168 ltest( i ) = .false.
1169 10 CONTINUE
1170 20 CONTINUE
1171 READ( nin, fmt = 9996, END = 50 ) SNAMET, ltestt
1172 DO 30 i = 1, nsubs
1173 IF( snamet.EQ.snames( i ) )
1174 $ GO TO 40
1175 30 CONTINUE
1176*
1177 WRITE( nout, fmt = 9995 )snamet
1178 GO TO 100
1179*
1180 40 CONTINUE
1181 ltest( i ) = ltestt
1182 GO TO 20
1183*
1184 50 CONTINUE
1185*
1186* Close input file
1187*
1188 CLOSE ( nin )
1189*
1190* For pvm only: if virtual machine not set up, allocate it and
1191* spawn the correct number of processes.
1192*
1193 IF( nprocs.LT.1 ) THEN
1194 nprocs = 0
1195 DO 60 i = 1, ngrids
1196 nprocs = max( nprocs, pval( i )*qval( i ) )
1197 60 CONTINUE
1198 CALL blacs_setup( iam, nprocs )
1199 END IF
1200*
1201* Temporarily define blacs grid to include all processes so
1202* information can be broadcast to all processes
1203*
1204 CALL blacs_get( -1, 0, ictxt )
1205 CALL blacs_gridinit( ictxt, 'Row-major', 1, nprocs )
1206*
1207* Compute machine epsilon
1208*
1209 eps = pdlamch( ictxt, 'eps' )
1210*
1211* Pack information arrays and broadcast
1212*
1213 CALL zgebs2d( ictxt, 'All', ' ', 1, 1, alpha, 1 )
1214*
1215 work( 1 ) = ngrids
1216 work( 2 ) = nmat
1217 CALL igebs2d( ictxt, 'All', ' ', 2, 1, work, 2 )
1218*
1219 i = 1
1220 IF( sof ) THEN
1221 work( i ) = 1
1222 ELSE
1223 work( i ) = 0
1224 END IF
1225 i = i + 1
1226 IF( tee ) THEN
1227 work( i ) = 1
1228 ELSE
1229 work( i ) = 0
1230 END IF
1231 i = i + 1
1232 work( i ) = iverb
1233 i = i + 1
1234 work( i ) = igap
1235 i = i + 1
1236 CALL icopy( ngrids, pval, 1, work( i ), 1 )
1237 i = i + ngrids
1238 CALL icopy( ngrids, qval, 1, work( i ), 1 )
1239 i = i + ngrids
1240 CALL icopy( nmat, nval, 1, work( i ), 1 )
1241 i = i + nmat
1242 CALL icopy( nmat, mxval, 1, work( i ), 1 )
1243 i = i + nmat
1244 CALL icopy( nmat, nxval, 1, work( i ), 1 )
1245 i = i + nmat
1246 CALL icopy( nmat, imbxval, 1, work( i ), 1 )
1247 i = i + nmat
1248 CALL icopy( nmat, inbxval, 1, work( i ), 1 )
1249 i = i + nmat
1250 CALL icopy( nmat, mbxval, 1, work( i ), 1 )
1251 i = i + nmat
1252 CALL icopy( nmat, nbxval, 1, work( i ), 1 )
1253 i = i + nmat
1254 CALL icopy( nmat, rscxval, 1, work( i ), 1 )
1255 i = i + nmat
1256 CALL icopy( nmat, cscxval, 1, work( i ), 1 )
1257 i = i + nmat
1258 CALL icopy( nmat, ixval, 1, work( i ), 1 )
1259 i = i + nmat
1260 CALL icopy( nmat, jxval, 1, work( i ), 1 )
1261 i = i + nmat
1262 CALL icopy( nmat, incxval, 1, work( i ), 1 )
1263 i = i + nmat
1264 CALL icopy( nmat, myval, 1, work( i ), 1 )
1265 i = i + nmat
1266 CALL icopy( nmat, nyval, 1, work( i ), 1 )
1267 i = i + nmat
1268 CALL icopy( nmat, imbyval, 1, work( i ), 1 )
1269 i = i + nmat
1270 CALL icopy( nmat, inbyval, 1, work( i ), 1 )
1271 i = i + nmat
1272 CALL icopy( nmat, mbyval, 1, work( i ), 1 )
1273 i = i + nmat
1274 CALL icopy( nmat, nbyval, 1, work( i ), 1 )
1275 i = i + nmat
1276 CALL icopy( nmat, rscyval, 1, work( i ), 1 )
1277 i = i + nmat
1278 CALL icopy( nmat, cscyval, 1, work( i ), 1 )
1279 i = i + nmat
1280 CALL icopy( nmat, iyval, 1, work( i ), 1 )
1281 i = i + nmat
1282 CALL icopy( nmat, jyval, 1, work( i ), 1 )
1283 i = i + nmat
1284 CALL icopy( nmat, incyval, 1, work( i ), 1 )
1285 i = i + nmat
1286*
1287 DO 70 j = 1, nsubs
1288 IF( ltest( j ) ) THEN
1289 work( i ) = 1
1290 ELSE
1291 work( i ) = 0
1292 END IF
1293 i = i + 1
1294 70 CONTINUE
1295 i = i - 1
1296 CALL igebs2d( ictxt, 'All', ' ', i, 1, work, i )
1297*
1298* regurgitate input
1299*
1300 WRITE( nout, fmt = 9999 ) 'Level 1 PBLAS testing program.'
1301 WRITE( nout, fmt = 9999 ) usrinfo
1302 WRITE( nout, fmt = * )
1303 WRITE( nout, fmt = 9999 )
1304 $ 'Tests of the complex double precision '//
1305 $ 'Level 1 PBLAS'
1306 WRITE( nout, fmt = * )
1307 WRITE( nout, fmt = 9999 )
1308 $ 'The following parameter values will be used:'
1309 WRITE( nout, fmt = * )
1310 WRITE( nout, fmt = 9993 ) nmat
1311 WRITE( nout, fmt = 9992 ) ngrids
1312 WRITE( nout, fmt = 9990 )
1313 $ 'P', ( pval(i), i = 1, min(ngrids, 5) )
1314 IF( ngrids.GT.5 )
1315 $ WRITE( nout, fmt = 9991 ) ( pval(i), i = 6,
1316 $ min( 10, ngrids ) )
1317 IF( ngrids.GT.10 )
1318 $ WRITE( nout, fmt = 9991 ) ( pval(i), i = 11,
1319 $ min( 15, ngrids ) )
1320 IF( ngrids.GT.15 )
1321 $ WRITE( nout, fmt = 9991 ) ( pval(i), i = 16, ngrids )
1322 WRITE( nout, fmt = 9990 )
1323 $ 'Q', ( qval(i), i = 1, min(ngrids, 5) )
1324 IF( ngrids.GT.5 )
1325 $ WRITE( nout, fmt = 9991 ) ( qval(i), i = 6,
1326 $ min( 10, ngrids ) )
1327 IF( ngrids.GT.10 )
1328 $ WRITE( nout, fmt = 9991 ) ( qval(i), i = 11,
1329 $ min( 15, ngrids ) )
1330 IF( ngrids.GT.15 )
1331 $ WRITE( nout, fmt = 9991 ) ( qval(i), i = 16, ngrids )
1332 WRITE( nout, fmt = 9988 ) sof
1333 WRITE( nout, fmt = 9987 ) tee
1334 WRITE( nout, fmt = 9983 ) igap
1335 WRITE( nout, fmt = 9986 ) iverb
1336 WRITE( nout, fmt = 9982 ) alpha
1337 IF( ltest( 1 ) ) THEN
1338 WRITE( nout, fmt = 9985 ) snames( 1 ), ' ... Yes'
1339 ELSE
1340 WRITE( nout, fmt = 9985 ) snames( 1 ), ' ... No '
1341 END IF
1342 DO 80 i = 2, nsubs
1343 IF( ltest( i ) ) THEN
1344 WRITE( nout, fmt = 9984 ) snames( i ), ' ... Yes'
1345 ELSE
1346 WRITE( nout, fmt = 9984 ) snames( i ), ' ... No '
1347 END IF
1348 80 CONTINUE
1349 WRITE( nout, fmt = 9994 ) eps
1350 WRITE( nout, fmt = * )
1351*
1352 ELSE
1353*
1354* If in pvm, must participate setting up virtual machine
1355*
1356 IF( nprocs.LT.1 )
1357 $ CALL blacs_setup( iam, nprocs )
1358*
1359* Temporarily define blacs grid to include all processes so
1360* information can be broadcast to all processes
1361*
1362 CALL blacs_get( -1, 0, ictxt )
1363 CALL blacs_gridinit( ictxt, 'Row-major', 1, nprocs )
1364*
1365* Compute machine epsilon
1366*
1367 eps = pdlamch( ictxt, 'eps' )
1368*
1369 CALL zgebr2d( ictxt, 'All', ' ', 1, 1, alpha, 1, 0, 0 )
1370*
1371 CALL igebr2d( ictxt, 'All', ' ', 2, 1, work, 2, 0, 0 )
1372 ngrids = work( 1 )
1373 nmat = work( 2 )
1374*
1375 i = 2*ngrids + 23*nmat + nsubs + 4
1376 CALL igebr2d( ictxt, 'All', ' ', i, 1, work, i, 0, 0 )
1377*
1378 i = 1
1379 IF( work( i ).EQ.1 ) THEN
1380 sof = .true.
1381 ELSE
1382 sof = .false.
1383 END IF
1384 i = i + 1
1385 IF( work( i ).EQ.1 ) THEN
1386 tee = .true.
1387 ELSE
1388 tee = .false.
1389 END IF
1390 i = i + 1
1391 iverb = work( i )
1392 i = i + 1
1393 igap = work( i )
1394 i = i + 1
1395 CALL icopy( ngrids, work( i ), 1, pval, 1 )
1396 i = i + ngrids
1397 CALL icopy( ngrids, work( i ), 1, qval, 1 )
1398 i = i + ngrids
1399 CALL icopy( nmat, work( i ), 1, nval, 1 )
1400 i = i + nmat
1401 CALL icopy( nmat, work( i ), 1, mxval, 1 )
1402 i = i + nmat
1403 CALL icopy( nmat, work( i ), 1, nxval, 1 )
1404 i = i + nmat
1405 CALL icopy( nmat, work( i ), 1, imbxval, 1 )
1406 i = i + nmat
1407 CALL icopy( nmat, work( i ), 1, inbxval, 1 )
1408 i = i + nmat
1409 CALL icopy( nmat, work( i ), 1, mbxval, 1 )
1410 i = i + nmat
1411 CALL icopy( nmat, work( i ), 1, nbxval, 1 )
1412 i = i + nmat
1413 CALL icopy( nmat, work( i ), 1, rscxval, 1 )
1414 i = i + nmat
1415 CALL icopy( nmat, work( i ), 1, cscxval, 1 )
1416 i = i + nmat
1417 CALL icopy( nmat, work( i ), 1, ixval, 1 )
1418 i = i + nmat
1419 CALL icopy( nmat, work( i ), 1, jxval, 1 )
1420 i = i + nmat
1421 CALL icopy( nmat, work( i ), 1, incxval, 1 )
1422 i = i + nmat
1423 CALL icopy( nmat, work( i ), 1, myval, 1 )
1424 i = i + nmat
1425 CALL icopy( nmat, work( i ), 1, nyval, 1 )
1426 i = i + nmat
1427 CALL icopy( nmat, work( i ), 1, imbyval, 1 )
1428 i = i + nmat
1429 CALL icopy( nmat, work( i ), 1, inbyval, 1 )
1430 i = i + nmat
1431 CALL icopy( nmat, work( i ), 1, mbyval, 1 )
1432 i = i + nmat
1433 CALL icopy( nmat, work( i ), 1, nbyval, 1 )
1434 i = i + nmat
1435 CALL icopy( nmat, work( i ), 1, rscyval, 1 )
1436 i = i + nmat
1437 CALL icopy( nmat, work( i ), 1, cscyval, 1 )
1438 i = i + nmat
1439 CALL icopy( nmat, work( i ), 1, iyval, 1 )
1440 i = i + nmat
1441 CALL icopy( nmat, work( i ), 1, jyval, 1 )
1442 i = i + nmat
1443 CALL icopy( nmat, work( i ), 1, incyval, 1 )
1444 i = i + nmat
1445*
1446 DO 90 j = 1, nsubs
1447 IF( work( i ).EQ.1 ) THEN
1448 ltest( j ) = .true.
1449 ELSE
1450 ltest( j ) = .false.
1451 END IF
1452 i = i + 1
1453 90 CONTINUE
1454*
1455 END IF
1456*
1457 CALL blacs_gridexit( ictxt )
1458*
1459 RETURN
1460*
1461 100 WRITE( nout, fmt = 9997 )
1462 CLOSE( nin )
1463 IF( nout.NE.6 .AND. nout.NE.0 )
1464 $ CLOSE( nout )
1465 CALL blacs_abort( ictxt, 1 )
1466*
1467 stop
1468*
1469 9999 FORMAT( a )
1470 9998 FORMAT( ' Number of values of ',5a, ' is less than 1 or greater ',
1471 $ 'than ', i2 )
1472 9997 FORMAT( ' Illegal input in file ',40a,'. Aborting run.' )
1473 9996 FORMAT( a7, l2 )
1474 9995 FORMAT( ' Subprogram name ', a7, ' not recognized',
1475 $ /' ******* TESTS ABANDONED *******' )
1476 9994 FORMAT( 2x, 'Relative machine precision (eps) is taken to be ',
1477 $ e18.6 )
1478 9993 FORMAT( 2x, 'Number of Tests : ', i6 )
1479 9992 FORMAT( 2x, 'Number of process grids : ', i6 )
1480 9991 FORMAT( 2x, ' : ', 5i6 )
1481 9990 FORMAT( 2x, a1, ' : ', 5i6 )
1482 9988 FORMAT( 2x, 'Stop on failure flag : ', l6 )
1483 9987 FORMAT( 2x, 'Test for error exits flag : ', l6 )
1484 9986 FORMAT( 2x, 'Verbosity level : ', i6 )
1485 9985 FORMAT( 2x, 'Routines to be tested : ', a, a8 )
1486 9984 FORMAT( 2x, ' ', a, a8 )
1487 9983 FORMAT( 2x, 'Leading dimension gap : ', i6 )
1488 9982 FORMAT( 2x, 'Alpha : (', g16.6,
1489 $ ',', g16.6, ')' )
1490*
1491* End of PZBLA1TSTINFO
1492*
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: