ScaLAPACK 2.1  2.1
ScaLAPACK: Scalable Linear Algebra PACKage
btprim.f
Go to the documentation of this file.
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: Sets up communicator and initiliazes MPI if needed.
21 *
22 * ====================================================================
23 *
24 * ..
25 * .. Local Scalars
26  LOGICAL INIT
27 * ..
28 * .. Include Files ..
29  include 'mpif.h'
30 * ..
31 * .. Common Blocks ..
32  COMMON /btmpi/ btcomm, ierr
33  INTEGER BTCOMM, IERR
34 * ..
35 * .. Executable Statements ..
36 *
37  ierr = 0
38  CALL mpi_initialized(init, ierr)
39  IF (.NOT.init) CALL mpi_init(ierr)
40  IF (ierr.NE.0) CALL btmpierr("mpi_init", ierr)
41  CALL mpi_comm_dup(mpi_comm_world, btcomm, ierr)
42  IF (ierr.NE.0) CALL btmpierr("MPI_COMM_DUP", ierr)
43 *
44  RETURN
45  END
46  INTEGER FUNCTION ibtmyproc()
47 *
48 * -- BLACS tester (version 1.0) --
49 * University of Tennessee
50 * December 15, 1994
51 *
52 * Purpose
53 * =======
54 * IBTMYPROC: returns a process number between 0 .. NPROCS-1. On
55 * systems not natively in this numbering scheme, translates to it.
56 *
57 * ====================================================================
58 * ..
59 * .. Include Files ..
60  include 'mpif.h'
61 * ..
62 * .. Local Scalars ..
63  INTEGER rank
64 * ..
65 * .. Common Blocks ..
66  COMMON /btmpi/ btcomm, ierr
67  INTEGER btcomm, ierr
68 * ..
69 * .. Executable Statements ..
70 *
71  CALL mpi_comm_rank(btcomm, rank, ierr)
72  IF (ierr.NE.0) CALL btmpierr("MPI_COMM_RANK", ierr)
73  ibtmyproc = rank
74  RETURN
75 *
76 * End of IBTMYPROC
77 *
78  END
79 *
80  INTEGER FUNCTION ibtnprocs()
81 *
82 * -- BLACS tester (version 1.0) --
83 * University of Tennessee
84 * December 15, 1994
85 *
86 * Purpose
87 * =======
88 * IBTNPROCS: returns the number of processes in the machine.
89 *
90 * ====================================================================
91 * ..
92 * .. Include Files ..
93  include 'mpif.h'
94 * ..
95 * .. Local Scalars ..
96  INTEGER nproc
97 * ..
98 * .. Common Blocks ..
99  COMMON /btmpi/ btcomm, ierr
100  INTEGER btcomm, ierr
101 * ..
102 * .. Executable Statements ..
103 *
104  CALL mpi_comm_size(btcomm, nproc, ierr)
105  IF (ierr.NE.0) CALL btmpierr("MPI_COMM_SIZE", ierr)
106  ibtnprocs = nproc
107 *
108  RETURN
109 *
110 * End of IBTNPROCS
111 *
112  END
113 *
114  SUBROUTINE btsend(DTYPE, N, BUFF, DEST, MSGID)
115 *
116 * -- BLACS tester (version 1.0) --
117 * University of Tennessee
118 * December 15, 1994
119 *
120 * .. Scalar Arguments ..
121  INTEGER N, DTYPE, DEST, MSGID
122 * ..
123 * .. Array Arguments ..
124  REAL BUFF(*)
125 * ..
126 *
127 * PURPOSE
128 * =======
129 * BTSEND: Communication primitive used to send messages independent
130 * of the BLACS. May safely be either locally or globally blocking.
131 *
132 * Arguments
133 * =========
134 * DTYPE (input) INTEGER
135 * Indicates what data type BUFF is (same as PVM):
136 * 1 = RAW BYTES
137 * 3 = INTEGER
138 * 4 = SINGLE PRECISION REAL
139 * 6 = DOUBLE PRECISION REAL
140 * 5 = SINGLE PRECISION COMPLEX
141 * 7 = DOUBLE PRECISION COMPLEX
142 *
143 * N (input) INTEGER
144 * The number of elements of type DTYPE in BUFF.
145 *
146 * BUFF (input) accepted as INTEGER array
147 * The array to be communicated. Its true data type is
148 * indicated by DTYPE.
149 *
150 * DEST (input) INTEGER
151 * The destination of the message.
152 *
153 * MSGID (input) INTEGER
154 * The message ID (AKA message tag or type).
155 *
156 * =====================================================================
157 * .. External Functions ..
158  INTEGER IBTMYPROC, IBTNPROCS, IBTSIZEOF
159  EXTERNAL IBTMYPROC, IBTNPROCS, IBTSIZEOF
160 * ..
161 * .. Local Scalars ..
162  INTEGER I, IAM, MPIDTYPE
163 * ..
164 * .. Include Files ..
165  include 'mpif.h'
166 * ..
167 * .. Common Blocks ..
168  COMMON /btmpi/ btcomm, ierr
169  INTEGER BTCOMM, IERR
170 *
171  IF( dtype .EQ. 1 ) THEN
172  mpidtype = mpi_byte
173  ELSE IF( dtype .EQ. 3 ) THEN
174  mpidtype = mpi_integer
175  ELSE IF( dtype .EQ. 4 ) THEN
176  mpidtype = mpi_real
177  ELSE IF( dtype .EQ. 5 ) THEN
178  mpidtype = mpi_complex
179  ELSE IF( dtype .EQ. 6 ) THEN
180  mpidtype = mpi_double_precision
181  ELSE IF( dtype .EQ. 7 ) THEN
182  mpidtype = mpi_double_complex
183  END IF
184 *
185 * Send the message
186 *
187  IF( dest .EQ. -1 ) THEN
188  iam = ibtmyproc()
189  DO 10 i = 0, ibtnprocs()-1
190  IF( i .NE. iam ) THEN
191  CALL mpi_send(buff, n, mpidtype, i, 0, btcomm, ierr)
192  IF (ierr.NE.0) CALL btmpierr("MPI_SEND", ierr)
193  END IF
194  10 CONTINUE
195  ELSE
196  CALL mpi_send(buff, n, mpidtype, dest, 0, btcomm, ierr)
197  IF (ierr.NE.0) CALL btmpierr("MPI_SEND", ierr)
198  END IF
199 *
200  RETURN
201 *
202 * End BTSEND
203 *
204  END
205 *
206  SUBROUTINE btrecv(DTYPE, N, BUFF, SRC, MSGID)
207 *
208 * -- BLACS tester (version 1.0) --
209 * University of Tennessee
210 * December 15, 1994
211 *
212 *
213 * .. Scalar Arguments ..
214  INTEGER N, DTYPE, SRC, MSGID
215 * ..
216 * .. Array Arguments ..
217  REAL BUFF(*)
218 * ..
219 *
220 * PURPOSE
221 * =======
222 * BTRECV: Globally blocking receive.
223 *
224 * Arguments
225 * =========
226 * DTYPE (input) INTEGER
227 * Indicates what data type BUFF is:
228 * 1 = RAW BYTES
229 * 3 = INTEGER
230 * 4 = SINGLE PRECISION REAL
231 * 6 = DOUBLE PRECISION REAL
232 * 5 = SINGLE PRECISION COMPLEX
233 * 7 = DOUBLE PRECISION COMPLEX
234 *
235 * N (input) INTEGER
236 * The number of elements of type DTYPE in BUFF.
237 *
238 * BUFF (output) INTEGER
239 * The buffer to receive into.
240 *
241 * SRC (input) INTEGER
242 * The source of the message.
243 *
244 * MSGID (input) INTEGER
245 * The message ID.
246 *
247 * =====================================================================
248 * ..
249 * .. Local Scalars ..
250  INTEGER MPIDTYPE
251 * ..
252 * .. Include Files ..
253  include 'mpif.h'
254 * ..
255 * .. Local Arrays ..
256  INTEGER STAT(MPI_STATUS_SIZE)
257 * ..
258 * .. Common Blocks ..
259  COMMON /btmpi/ btcomm, ierr
260  INTEGER BTCOMM, IERR
261 *
262  IF( dtype .EQ. 1 ) THEN
263  mpidtype = mpi_byte
264  ELSE IF( dtype .EQ. 3 ) THEN
265  mpidtype = mpi_integer
266  ELSE IF( dtype .EQ. 4 ) THEN
267  mpidtype = mpi_real
268  ELSE IF( dtype .EQ. 5 ) THEN
269  mpidtype = mpi_complex
270  ELSE IF( dtype .EQ. 6 ) THEN
271  mpidtype = mpi_double_precision
272  ELSE IF( dtype .EQ. 7 ) THEN
273  mpidtype = mpi_double_complex
274  END IF
275 *
276  CALL mpi_recv( buff, n, mpidtype, src, 0, btcomm, stat, ierr )
277  IF (ierr.NE.0) CALL btmpierr("MPI_RECV", ierr)
278 *
279  RETURN
280 *
281 * End of BTRECV
282 *
283  END
284 *
285  INTEGER FUNCTION ibtsizeof(TYPE)
286 *
287 * -- BLACS tester (version 1.0) --
288 * University of Tennessee
289 * December 15, 1994
290 *
291 * .. Scalar Arguments ..
292  CHARACTER*1 type
293 * ..
294 *
295 * Purpose
296 * =======
297 * IBTSIZEOF: Returns the size, in bytes, of the 5 data types.
298 * If your platform has a different size for DOUBLE PRECISION, you must
299 * change the parameter statement in BLACSTEST as well.
300 *
301 * Arguments
302 * =========
303 * TYPE (input) CHARACTER*1
304 * The data type who's size is to be determined:
305 * 'I' : INTEGER
306 * 'S' : SINGLE PRECISION REAL
307 * 'D' : DOUBLE PRECISION REAL
308 * 'C' : SINGLE PRECISION COMPLEX
309 * 'Z' : DOUBLE PRECISION COMPLEX
310 *
311 * =====================================================================
312 *
313 * .. External Functions ..
314  LOGICAL lsame
315  EXTERNAL lsame
316 * ..
317 * .. Include Files ..
318  include 'mpif.h'
319 * ..
320 * .. Common Blocks ..
321  COMMON /btmpi/ btcomm, ierr
322  INTEGER btcomm, ierr
323 * ..
324 * .. Local Scalars ..
325  INTEGER length
326  LOGICAL init
327  DATA init /.false./
328 * ..
329 * .. Executable Statements ..
330 *
331 *
332 * Initialize MPI, if necessary
333 *
334  IF (.NOT.init) THEN
335  CALL mpi_initialized(init, ierr)
336  IF (.NOT.init) CALL mpi_init(ierr)
337  IF (ierr.NE.0) CALL btmpierr("mpi_init", ierr)
338  init = .true.
339  END IF
340 *
341  IF( lsame(TYPE, 'I') ) then
342  call mpi_type_size( mpi_integer, length, ierr )
343  IF (ierr.NE.0) CALL btmpierr("MPI_TYPE_SIZE", ierr)
344  ELSE IF( lsame(TYPE, 'S') ) then
345  CALL mpi_type_size( mpi_real, length, ierr )
346  IF (ierr.NE.0) CALL btmpierr("MPI_TYPE_SIZE", ierr)
347  ELSE IF( lsame(TYPE, 'D') ) then
348  CALL mpi_type_size( mpi_double_precision, length, ierr )
349  IF (ierr.NE.0) CALL btmpierr("MPI_TYPE_SIZE", ierr)
350  ELSE IF( lsame(TYPE, 'C') ) then
351  CALL mpi_type_size( mpi_complex, length, ierr )
352  IF (ierr.NE.0) CALL btmpierr("MPI_TYPE_SIZE", ierr)
353  ELSE IF( lsame(TYPE, 'Z') ) then
354  CALL mpi_type_size( mpi_double_complex, length, ierr )
355  IF (ierr.NE.0) CALL btmpierr("MPI_TYPE_SIZE", ierr)
356  END IF
357  ibtsizeof = length
358 *
359  RETURN
360  END
361  SUBROUTINE btmpierr(ROUT, IERR0)
362  CHARACTER*(*) rout
363  INTEGER ierr0
364 * ..
365 * .. Include Files ..
366  include 'mpif.h'
367 * ..
368 * .. Common Blocks ..
369  COMMON /btmpi/ btcomm, ierr
370  INTEGER btcomm, ierr
371 *
372  WRITE(*,1000) rout, ierr
373  CALL mpi_abort(btcomm, ierr0, ierr)
374 *
375  1000 FORMAT('Error #',i20,' from routine ',a)
376  RETURN
377  END
ibtmyproc
integer function ibtmyproc()
Definition: btprim.f:47
lsame
logical function lsame(CA, CB)
Definition: tools.f:1724
btrecv
subroutine btrecv(DTYPE, N, BUFF, SRC, MSGID)
Definition: btprim.f:207
btsend
subroutine btsend(DTYPE, N, BUFF, DEST, MSGID)
Definition: btprim.f:115
btsetup
subroutine btsetup(MEM, MEMLEN, CMEM, CMEMLEN, OUTNUM, TESTSDRV, TESTBSBR, TESTCOMB, TESTAUX, IAM, NNODES)
Definition: btprim.f:4
btmpierr
subroutine btmpierr(ROUT, IERR0)
Definition: btprim.f:362
ibtsizeof
integer function ibtsizeof(TYPE)
Definition: btprim.f:286
ibtnprocs
integer function ibtnprocs()
Definition: btprim.f:81