1 SUBROUTINE BTSETUP( MEM, MEMLEN, CMEM, CMEMLEN, OUTNUM, 2 $ TESTSDRV, TESTBSBR, TESTCOMB, TESTAUX, 3 $ IAM, NNODES ) 4* 5* -- BLACS tester (version 1.0) -- 6* University of Tennessee 7* December 15, 1994 8* 9* .. Scalar Arguments .. 10 LOGICAL TESTSDRV, TESTBSBR, TESTCOMB, TESTAUX 11 INTEGER MEMLEN, CMEMLEN, OUTNUM, IAM, NNODES 12* .. 13* .. Array Arguments .. 14 INTEGER MEM(MEMLEN) 15 CHARACTER*1 CMEM(CMEMLEN) 16* .. 17* 18* Purpose 19* ======= 20* BTSETUP: Fills in process number array, and sets up machine on 21* dynamic systems. 22* 23* Arguments 24* ========= 25* MEM (input) INTEGER array, dimension MEMSIZE 26* Scratch pad memory area. 27* 28* MEMLEN (input) INTEGER 29* Number of safe elements in MEM. 30* 31* CMEM (input) CHARACTER array, dimension CMEMSIZE 32* Scratch pad memory area. 33* 34* CMEMLEN (input) INTEGER 35* Number of safe elements in MEM. 36* 37* OUTNUM (input/output) INTEGER 38* Unit number of output file for top level error information. 39* Input for process 0. Set to zero as output for all other 40* processes as a safety precaution. 41* 42* TESTSDRV (input) LOGICAL 43* Will there be point-to-point tests in this test run? 44* 45* TESTBSBR (input) LOGICAL 46* Will there be broadcast tests in this test run? 47* 48* TESTCOMB (input) LOGICAL 49* Will there be combine-operator tests in this test run? 50* 51* TESTAUX (input) LOGICAL 52* Will there be auxiliary tests in this test run? 53* 54* IAM (input/output) INTEGER 55* This process's node number. 56* 57* NNODES (input/output) INTEGER 58* Number of processes that are started up by this subroutine. 59* 60* ==================================================================== 61* 62* .. Local Scalars .. 63 INTEGER I, CONTEXT, MEMUSED, CMEMUSED, NGRID, PPTR, QPTR 64* .. 65* .. External Functions .. 66 INTEGER BLACS_PNUM 67 EXTERNAL BLACS_PNUM 68* .. 69* .. External Subroutines .. 70 EXTERNAL BLACS_SETUP, BLACS_GRIDINIT, BLACS_GRIDEXIT 71* .. 72* .. Common blocks .. 73 COMMON /BTPNUM/ BTPNUMS 74* .. 75* .. Arrays in Common .. 76 INTEGER BTPNUMS(0:999) 77* .. 78* .. Executable Statements .. 79* 80 IF( NNODES .GT. 0 ) RETURN 81 IF ( IAM .EQ. 0 ) THEN 82 IF ( TESTSDRV ) THEN 83* 84* Determine the max number of nodes required by a SDRV tests 85* 86 CALL RDSDRV( MEMUSED, MEM, MEMLEN, CMEMUSED, CMEM, CMEMLEN, 87 $ OUTNUM ) 88 IF( (MEMUSED + 24) .GT. MEMLEN ) THEN 89 WRITE(OUTNUM, *) 'Not enough memory to read in sdrv.dat' 90 STOP 91 END IF 92* 93 I = MEMUSED + 1 94 CALL BTUNPACK( 'SDRV', MEM, MEMUSED, MEM(I+1), MEM(I+2), 95 $ MEM(I+22), MEM(I+23), MEM(I+12), MEM(I+20), 96 $ MEM(I+3), MEM(I+13), NGRID, MEM(I+4), 97 $ MEM(I+14), MEM(I+21), MEM(I+5), MEM(I+15), 98 $ MEM(I+6), MEM(I+16), MEM(I+7), MEM(I+17), 99 $ MEM(I+8), MEM(I+18), MEM(I+9), MEM(I+19), 100 $ MEM(I+11), PPTR, QPTR ) 101* 102 DO 10 I = 0, NGRID-1 103 NNODES = MAX0( MEM(PPTR+I) * MEM(QPTR+I), NNODES ) 104 10 CONTINUE 105 END IF 106 IF( TESTBSBR ) THEN 107* 108* Determine the maximum number of nodes required by a 109* broadcast test case 110* 111 CALL RDBSBR( MEMUSED, MEM, MEMLEN, CMEMUSED, CMEM, CMEMLEN, 112 $ OUTNUM ) 113 I = MEMUSED + 1 114 CALL BTUNPACK( 'BSBR', MEM, MEMUSED, MEM(I+1), MEM(I+2), 115 $ MEM(I+22), MEM(I+23), MEM(I+12), MEM(I+20), 116 $ MEM(I+3), MEM(I+13), NGRID, MEM(I+4), 117 $ MEM(I+14), MEM(I+21), MEM(I+5), MEM(I+15), 118 $ MEM(I+6), MEM(I+16), MEM(I+7), MEM(I+17), 119 $ MEM(I+8), MEM(I+18), MEM(I+9), MEM(I+19), 120 $ MEM(I+11), PPTR, QPTR ) 121 DO 20 I = 0, NGRID-1 122 NNODES = MAX0( MEM(PPTR+I) * MEM(QPTR+I), NNODES ) 123 20 CONTINUE 124* 125 END IF 126 IF( TESTCOMB ) THEN 127* 128* Determine the maximum number of nodes required by a 129* combine test case 130* 131 CALL RDCOMB( MEMUSED, MEM, MEMLEN, CMEMUSED, CMEM, CMEMLEN, 132 $ OUTNUM ) 133 I = MEMUSED + 1 134 CALL BTUNPACK( 'COMB', MEM, MEMUSED, MEM(I+1), MEM(I+2), 135 $ MEM(I+22), MEM(I+23), MEM(I+12), MEM(I+20), 136 $ MEM(I+3), MEM(I+13), NGRID, MEM(I+4), 137 $ MEM(I+14), MEM(I+21), MEM(I+5), MEM(I+15), 138 $ MEM(I+6), MEM(I+16), MEM(I+7), MEM(I+17), 139 $ MEM(I+8), MEM(I+18), MEM(I+9), MEM(I+19), 140 $ MEM(I+11), PPTR, QPTR ) 141* 142 DO 30 I = 0, NGRID-1 143 NNODES = MAX0( MEM(PPTR+I) * MEM(QPTR+I), NNODES ) 144 30 CONTINUE 145 END IF 146 END IF 147* 148* If we run auxiliary tests, must have at least two nodes, 149* otherwise, minimum is 1 150* 151 IF( TESTAUX ) THEN 152 NNODES = MAX0( NNODES, 2 ) 153 ELSE 154 NNODES = MAX0( NNODES, 1 ) 155 END IF 156* 157 CALL BLACS_SETUP( IAM, NNODES ) 158* 159* We've buried a PNUM array in the common block above, and here 160* we initialize it. The reason for carrying this along is so that 161* the TSEND and TRECV subroutines can report test results back to 162* the first process, which can then be the sole process 163* writing output files. 164* 165 CALL BLACS_GET( 0, 0, CONTEXT ) 166 CALL BLACS_GRIDINIT( CONTEXT, 'r', 1, NNODES ) 167* 168 DO 40 I = 0, NNODES-1 169 BTPNUMS(I) = BLACS_PNUM( CONTEXT, 0, I ) 170 40 CONTINUE 171* 172 CALL BLACS_GRIDEXIT( CONTEXT ) 173* 174 RETURN 175* 176* End of BTSETUP. 177* 178 END 179* 180 INTEGER FUNCTION IBTMYPROC() 181* 182* -- BLACS tester (version 1.0) -- 183* University of Tennessee 184* December 15, 1994 185* 186* Purpose 187* ======= 188* IBTMYPROC: returns a process number between 0 .. NPROCS-1. On 189* systems not natively in this numbering scheme, translates to it. 190* 191* ==================================================================== 192* 193* .. External Functions .. 194 INTEGER IBTNPROCS 195 EXTERNAL IBTNPROCS 196* .. 197* .. Common blocks .. 198 COMMON /BTPNUM/ BTPNUMS 199* .. 200* .. Arrays in Common .. 201 INTEGER BTPNUMS(0:999) 202* .. 203* .. Local Scalars .. 204 INTEGER IAM, I, K 205* .. 206* .. Save statement .. 207 SAVE IAM 208* .. 209* .. Data statements .. 210 DATA IAM /-1/ 211* .. 212* .. Executable Statements .. 213* 214 IF (IAM .EQ. -1) THEN 215 CALL PVMFMYTID(K) 216 DO 10 I = 0, IBTNPROCS()-1 217 IF( K .EQ. BTPNUMS(I) ) IAM = I 218 10 CONTINUE 219 END IF 220* 221 IBTMYPROC = IAM 222 RETURN 223* 224* End of IBTMYPROC 225* 226 END 227* 228 INTEGER FUNCTION IBTNPROCS() 229* 230* -- BLACS tester (version 1.0) -- 231* University of Tennessee 232* December 15, 1994 233* 234* Purpose 235* ======= 236* IBTNPROCS: returns the number of processes in the machine. 237* 238* ==================================================================== 239* .. Local Scalars .. 240 INTEGER IAM, NNODES 241* .. 242* 243* Got to use BLACS, since it set up the machine . . . 244* 245 CALL BLACS_PINFO(IAM, NNODES) 246 IBTNPROCS = NNODES 247* 248 RETURN 249* 250* End of IBTNPROCS 251* 252 END 253* 254 SUBROUTINE BTSEND(DTYPE, N, BUFF, DEST, MSGID) 255* 256* -- BLACS tester (version 1.0) -- 257* University of Tennessee 258* December 15, 1994 259* 260* .. Scalar Arguments .. 261 INTEGER N, DTYPE, DEST, MSGID 262* .. 263* .. Array Arguments .. 264 REAL BUFF(*) 265* .. 266* 267* PURPOSE 268* ======= 269* BTSEND: Communication primitive used to send messages independent 270* of the BLACS. May safely be either locally or globally blocking. 271* 272* Arguments 273* ========= 274* DTYPE (input) INTEGER 275* Indicates what data type BUFF is (same as PVM): 276* 1 = RAW BYTES 277* 3 = INTEGER 278* 4 = SINGLE PRECISION REAL 279* 6 = DOUBLE PRECISION REAL 280* 5 = SINGLE PRECISION COMPLEX 281* 7 = DOUBLE PRECISION COMPLEX 282* 283* N (input) INTEGER 284* The number of elements of type DTYPE in BUFF. 285* 286* BUFF (input) accepted as INTEGER array 287* The array to be communicated. Its true data type is 288* indicated by DTYPE. 289* 290* DEST (input) INTEGER 291* The destination of the message. 292* 293* MSGID (input) INTEGER 294* The message ID (AKA message tag or type). 295* 296* ===================================================================== 297* .. External Functions .. 298 INTEGER IBTNPROCS 299 EXTERNAL IBTNPROCS 300* .. 301* .. Common blocks .. 302 COMMON /BTPNUM/ BTPNUMS 303* .. 304* .. Arrays in Common .. 305 INTEGER BTPNUMS(0:999) 306* .. 307* .. Include Files .. 308 INCLUDE 'fpvm3.h' 309* .. 310* .. Local Scalars .. 311 INTEGER INFO, PVMTYPE 312* .. 313* .. Executable Statements .. 314* 315* Map internal type parameters to PVM 316* 317 IF( DTYPE .EQ. 1 ) THEN 318 PVMTYPE = BYTE1 319 ELSE IF( DTYPE .EQ. 3 ) THEN 320 PVMTYPE = INTEGER4 321 ELSE IF( DTYPE .EQ. 4 ) THEN 322 PVMTYPE = REAL4 323 ELSE IF( DTYPE .EQ. 5 ) THEN 324 PVMTYPE = COMPLEX8 325 ELSE IF( DTYPE .EQ. 6 ) THEN 326 PVMTYPE = REAL8 327 ELSE IF( DTYPE .EQ. 7 ) THEN 328 PVMTYPE = COMPLEX16 329 END IF 330* 331* pack and send data to specified process 332* 333 CALL PVMFINITSEND(PVMDATADEFAULT, INFO) 334 CALL PVMFPACK(DTYPE, BUFF, N, 1, INFO) 335 IF( DEST .EQ. -1 ) THEN 336 CALL PVMFMCAST(IBTNPROCS(), BTPNUMS, MSGID, INFO) 337 ELSE 338 CALL PVMFSEND(BTPNUMS(DEST) , MSGID, INFO) 339 ENDIF 340* 341 RETURN 342* 343* End BTSEND 344* 345 END 346* 347 SUBROUTINE BTRECV(DTYPE, N, BUFF, SRC, MSGID) 348* 349* -- BLACS tester (version 1.0) -- 350* University of Tennessee 351* December 15, 1994 352* 353* 354* .. Scalar Arguments .. 355 INTEGER N, DTYPE, SRC, MSGID 356* .. 357* .. Array Arguments .. 358 REAL BUFF(*) 359* .. 360* 361* PURPOSE 362* ======= 363* BTRECV: Globally blocking receive. 364* 365* Arguments 366* ========= 367* DTYPE (input) INTEGER 368* Indicates what data type BUFF is: 369* 1 = RAW BYTES 370* 3 = INTEGER 371* 4 = SINGLE PRECISION REAL 372* 6 = DOUBLE PRECISION REAL 373* 5 = SINGLE PRECISION COMPLEX 374* 7 = DOUBLE PRECISION COMPLEX 375* 376* N (input) INTEGER 377* The number of elements of type DTYPE in BUFF. 378* 379* BUFF (output) INTEGER 380* The buffer to receive into. 381* 382* SRC (input) INTEGER 383* The source of the message. 384* 385* MSGID (input) INTEGER 386* The message ID. 387* 388* ===================================================================== 389* 390* .. Common blocks .. 391 COMMON /BTPNUM/ BTPNUMS 392* .. 393* .. Arrays in Common .. 394 INTEGER BTPNUMS(0:999) 395* .. 396* .. Include Files .. 397 INCLUDE 'fpvm3.h' 398* .. 399* .. Local Scalars .. 400 INTEGER INFO, PVMTYPE 401* .. 402* .. Executable Statements .. 403* 404* Map internal type parameters to PVM 405* 406 IF( DTYPE .EQ. 1 ) THEN 407 PVMTYPE = BYTE1 408 ELSE IF( DTYPE .EQ. 3 ) THEN 409 PVMTYPE = INTEGER4 410 ELSE IF( DTYPE .EQ. 4 ) THEN 411 PVMTYPE = REAL4 412 ELSE IF( DTYPE .EQ. 5 ) THEN 413 PVMTYPE = COMPLEX8 414 ELSE IF( DTYPE .EQ. 6 ) THEN 415 PVMTYPE = REAL8 416 ELSE IF( DTYPE .EQ. 7 ) THEN 417 PVMTYPE = COMPLEX16 418 END IF 419 CALL PVMFRECV(BTPNUMS(SRC), MSGID, INFO) 420 CALL PVMFUNPACK(DTYPE, BUFF, N, 1, INFO) 421* .. 422* .. Local Scalars .. 423* 424 RETURN 425* 426* End of BTRECV 427* 428 END 429* 430 INTEGER FUNCTION IBTSIZEOF(TYPE) 431* 432* -- BLACS tester (version 1.0) -- 433* University of Tennessee 434* December 15, 1994 435* 436* .. Scalar Arguments .. 437 CHARACTER*1 TYPE 438* .. 439* 440* Purpose 441* ======= 442* IBTSIZEOF: Returns the size, in bytes, of the 5 data types. 443* If your platform has a different size for DOUBLE PRECISION, you must 444* change the parameter statement in BLACSTEST as well. 445* 446* Arguments 447* ========= 448* TYPE (input) CHARACTER*1 449* The data type who's size is to be determined: 450* 'I' : INTEGER 451* 'S' : SINGLE PRECISION REAL 452* 'D' : DOUBLE PRECISION REAL 453* 'C' : SINGLE PRECISION COMPLEX 454* 'Z' : DOUBLE PRECISION COMPLEX 455* 456* ===================================================================== 457* 458* .. External Functions .. 459 LOGICAL LSAME 460 EXTERNAL LSAME 461* .. 462* .. Local Scalars .. 463 INTEGER LENGTH 464* .. 465* .. Executable Statements .. 466* 467 IF( LSAME(TYPE, 'I') ) THEN 468 LENGTH = 4 469 ELSE IF( LSAME(TYPE, 'S') ) THEN 470 LENGTH = 4 471 ELSE IF( LSAME(TYPE, 'D') ) THEN 472 LENGTH = 8 473 ELSE IF( LSAME(TYPE, 'C') ) THEN 474 LENGTH = 8 475 ELSE IF( LSAME(TYPE, 'Z') ) THEN 476 LENGTH = 16 477 END IF 478 IBTSIZEOF = LENGTH 479* 480 RETURN 481 END 482