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