SCALAPACK 2.2.2
LAPACK: Linear Algebra PACKage
•All Classes Files Functions Variables Typedefs Macros
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
btrecv
subroutine btrecv(dtype, n, buff, src, msgid)
Definition btprim.f:207
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
ibtnprocs
integer function ibtnprocs()
Definition btprim.f:81
ibtmyproc
integer function ibtmyproc()
Definition btprim.f:47
btsend
subroutine btsend(dtype, n, buff, dest, msgid)
Definition btprim.f:115
ibtsizeof
integer function ibtsizeof(type)
Definition btprim.f:286
lsame
logical function lsame(ca, cb)
Definition tools.f:1724