source: project/release/4/mpi/trunk/tests/run.scm @ 14411

Last change on this file since 14411 was 14411, checked in by Ivan Raikov, 11 years ago

mpi ported to Chicken 4

File size: 25.1 KB
Line 
1;;
2;;
3;; Chicken MPI regression test
4;;
5;; Based on the Caml/MPI interface by Xavier Leroy.
6;;
7;; Copyright 2007-2009 Ivan Raikov and the Okinawa Institute of Science and Technology
8;;
9;; This program is free software: you can redistribute it and/or
10;; modify it under the terms of the GNU General Public License as
11;; published by the Free Software Foundation, either version 3 of the
12;; License, or (at your option) any later version.
13;;
14;; This program is distributed in the hope that it will be useful, but
15;; WITHOUT ANY WARRANTY; without even the implied warranty of
16;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
17;; General Public License for more details.
18;;
19;; A full copy of the GPL license can be found at
20;; <http://www.gnu.org/licenses/>.
21;;
22
23(require-extension posix srfi-4 srfi-13 srfi-14 mpi test)
24
25(define (land . args)
26  (if (null? args) #t
27      (and (car args) (apply land (cdr args)))))
28
29(define (lor . args)
30  (if (null? args) #f
31      (or (car args) (apply lor (cdr args)))))
32
33(define (eval-op op args)
34  (apply
35   (cond ((= op MPI:i_max)   max)
36         ((= op MPI:i_min)   min)
37         ((= op MPI:i_sum)   +)
38         ((= op MPI:i_prod)  *)
39         ((= op MPI:i_land)  land)
40         ((= op MPI:i_lor)   lor)
41         ((= op MPI:i_xor)   fxxor)
42         ((= op MPI:f_max)   max)
43         ((= op MPI:f_min)   min)
44         ((= op MPI:f_sum)   +)
45         ((= op MPI:f_prod)  *)
46         (else (error 'eval-op "unknown op " op)))
47   args))
48
49(define (blob-range x i j) 
50  (string->blob (string-copy (blob->string x) i j)))
51
52(define (make-srfi4-vector-map makev vlen vset! vref)
53  (lambda (v f)
54    (let loop ((v v) (newv (makev (vlen v))) (n (- (vlen v) 1)))
55      (if (>= n 0)
56          (let ((x (f (vref v n))))
57            (vset! newv n x)
58            (loop v newv (- n 1)))
59          (begin
60            newv)))))
61
62(define (make-srfi4-vector-range makev vlen vset! vref)
63  (lambda (v i j)
64    (and (and (positive? j) (or (zero? i) (positive? i)) (< i j) (< (- j i) (vlen v)))
65         (let loop ((v v) (newv (makev (- j i))) (n 0) (i i))
66           (if (< i j)
67               (let ((x (vref v i)))
68                 (vset! newv n x)
69                 (loop v newv (+ n 1) (+ i 1)))
70               newv)))))
71
72
73(define u8vector-map (make-srfi4-vector-map make-u8vector
74                                            u8vector-length
75                                            u8vector-set!
76                                            u8vector-ref))
77
78(define s8vector-map (make-srfi4-vector-map make-s8vector
79                                            s8vector-length
80                                            s8vector-set!
81                                            s8vector-ref))
82
83(define u16vector-map (make-srfi4-vector-map make-u16vector
84                                             u16vector-length
85                                             u16vector-set!
86                                             u16vector-ref))
87
88(define s16vector-map (make-srfi4-vector-map make-s16vector
89                                             s16vector-length
90                                             s16vector-set!
91                                             s16vector-ref))
92
93(define u32vector-map (make-srfi4-vector-map make-u32vector
94                                             u32vector-length
95                                             u32vector-set!
96                                             u32vector-ref))
97
98(define s32vector-map (make-srfi4-vector-map make-s32vector
99                                             s32vector-length
100                                             s32vector-set!
101                                             s32vector-ref))
102
103(define f32vector-map (make-srfi4-vector-map make-f32vector
104                                             f32vector-length
105                                             f32vector-set!
106                                             f32vector-ref))
107
108(define f64vector-map (make-srfi4-vector-map make-f64vector
109                                             f64vector-length
110                                             f64vector-set!
111                                             f64vector-ref))
112
113
114
115(define u8vector-range (make-srfi4-vector-range make-u8vector
116                                                u8vector-length
117                                                u8vector-set!
118                                                u8vector-ref))
119
120(define s8vector-range (make-srfi4-vector-range make-s8vector
121                                                s8vector-length
122                                                s8vector-set!
123                                                s8vector-ref))
124
125(define u16vector-range (make-srfi4-vector-range make-u16vector
126                                                 u16vector-length
127                                                 u16vector-set!
128                                                 u16vector-ref))
129
130(define s16vector-range (make-srfi4-vector-range make-s16vector
131                                                 s16vector-length
132                                                 s16vector-set!
133                                                 s16vector-ref))
134
135(define u32vector-range (make-srfi4-vector-range make-u32vector
136                                                 u32vector-length
137                                                 u32vector-set!
138                                                 u32vector-ref))
139
140
141(define s32vector-range (make-srfi4-vector-range make-s32vector
142                                                 s32vector-length
143                                                 s32vector-set!
144                                                 s32vector-ref))
145
146(define f32vector-range (make-srfi4-vector-range make-f32vector
147                                                 f32vector-length
148                                                 f32vector-set!
149                                                 f32vector-ref))
150
151(define f64vector-range (make-srfi4-vector-range make-f64vector
152                                                 f64vector-length
153                                                 f64vector-set!
154                                                 f64vector-ref))
155
156(define (check-string rank n c size)
157  (print "rank = " rank " n = " n " size = " size)
158  (and (= (length (string->list n)) (+ 1 size))
159       (every (lambda (x) (char=? x c)) (string->list n))))
160
161(MPI:init)
162
163(print "Host " (get-host-name))
164
165(define comm-world  (MPI:get-comm-world))
166(define size        (MPI:comm-size comm-world))
167(define myrank      (MPI:comm-rank comm-world))
168(define vsize       3)
169(define intdata     (list-tabulate size (lambda (i) (* 10 i))))
170(define flodata     (list-tabulate size (lambda (i) (* 0.1 i))))
171(define vsdata      (list-tabulate size (lambda (i) 
172                                          (list->string (list-tabulate vsize 
173                                                                          (lambda (j) (integer->char (+ i 97))))))))
174(define vvsdata     (list-tabulate size (lambda (i) 
175                                          (list->string (list-tabulate (+ i 1) 
176                                                                       (lambda (j) (integer->char (+ i 97))))))))
177(define vintdata    (list-tabulate size (lambda (i) (list-tabulate vsize (lambda (j) (+ (* 10 i) j))))))
178(define vflodata    (list-tabulate size (lambda (i) (list-tabulate vsize (lambda (j) (+ i (* 0.1 j)))))))
179(define vvintdata   (list-tabulate size (lambda (i) (list-tabulate (+ i 1) (lambda (j) (+ (* 10 i) j))))))
180(define vvflodata   (list-tabulate size (lambda (i) (list-tabulate (+ i 1) (lambda (j) (+ i (* 0.1 j)))))))
181
182
183(test-group "MPI test"
184
185  (if (zero? myrank)
186      (let ((data  "aa"))
187        (print myrank ": sending " data)
188        (MPI:send (string->blob data) 1 0 comm-world)
189        (let ((n (blob->string (MPI:receive MPI:any-source MPI:any-tag comm-world))))
190          (print myrank ": received " n)
191          (test-assert (check-string myrank n #\a size))))
192      (let* ((n   (blob->string (MPI:receive MPI:any-source MPI:any-tag comm-world)))
193             (n1  (string-append n "a")))
194        (print myrank ": received " n ", resending " n1)
195        (MPI:send (string->blob n1) (modulo (+ myrank 1) size) 0 comm-world)
196        (test-assert (check-string myrank n #\a myrank))
197        ))
198
199  ;; Barrier
200  (MPI:barrier comm-world)
201 
202  (if (zero? myrank)
203      (let ((data1  "aa")
204            (data2  "bb"))
205        (print myrank ": sending (tag 0) " data1)
206        (MPI:send (string->blob data1) 1 0 comm-world)
207        (print myrank ": sending (tag 1) " data2)
208        (MPI:send (string->blob data2) 1 1 comm-world)
209        (let-values (((n src tag)  (MPI:receive-with-status MPI:any-source MPI:any-tag comm-world)))
210                    (print myrank ": received " (blob->string n) " (tag " tag ")" " from " src)
211                    (if (zero? tag) 
212                        (test-assert (check-string myrank (blob->string n) #\a size))
213                        (test-assert (check-string myrank (blob->string n) #\b size)))
214         (let-values (((n src tag)  (MPI:receive-with-status MPI:any-source MPI:any-tag comm-world)))
215                     (print myrank ": received " (blob->string n) " (tag " tag ")" " from " src)
216                     (if (zero? tag) 
217                         (test-assert (check-string myrank (blob->string n) #\a size))
218                         (test-assert (check-string myrank (blob->string n) #\b size))))))
219      (let-values (((n1 src tag1)  (MPI:receive-with-status MPI:any-source 0 comm-world)))
220          (let* ((n1   (blob->string n1))
221                 (nn1  (if (zero? tag1) (string-append n1 "a") (string-append n1 "b"))))
222             (print myrank ": received " n1 " (tag " tag1 ")" " from " src
223                    ", resending " nn1)
224             (if (zero? tag1)
225                 (test-assert (check-string myrank n1 #\a myrank))
226                 (test-assert (check-string myrank n1 #\b myrank)))
227             (let-values (((n2 src tag2)  (MPI:receive-with-status MPI:any-source MPI:any-tag comm-world)))
228                         (let* ((n2   (blob->string n2))
229                                (nn2  (if (zero? tag2) (string-append n2 "a") (string-append n2 "b"))))
230                           (if (zero? tag2)
231                               (test-assert (check-string myrank n2 #\a myrank))
232                               (test-assert (check-string myrank n2 #\b myrank)))
233                           (print myrank ": received " n2 " (tag " tag2 ")" " from " src
234                                  ", resending " nn2)
235                           (MPI:send (string->blob nn1) (modulo (+ 1 myrank) size) tag1 comm-world)
236                           (MPI:send (string->blob nn2) (modulo (+ 1 myrank) size) tag2 comm-world))))))
237 
238  ;; Barrier
239  (MPI:barrier comm-world)
240
241   (let ((test-send-recv
242          (lambda (sendfun recvfun transf data)
243           (if (zero? myrank)
244               (begin
245                 (print myrank ": test-send-recv: data = " data) 
246                 (print myrank ": test-send-recv: size = " size) 
247                 (let loop ((lst data) (i 1))
248                   (if (and (not (null? lst)) (< i size))
249                       (begin
250                         (print myrank ": sending " (car lst) " to " i)
251                         (sendfun (car lst) i 0 comm-world)
252                         (loop (cdr lst) (+ 1 i)))))
253                 (let loop ((i size))
254                   (if (positive? (- i 1))
255                       (let ((x (recvfun (- i 1) 0 comm-world)))
256                         (print myrank ": received " x)
257                         (test-assert (any (lambda (y) (equal? x y)) (map transf data)))
258                         (loop (- i 1))))))
259               (let ((x (recvfun 0 0 comm-world)))
260                 (print myrank ": received " x)
261                 (test-assert (member x data))
262                 (let ((y (transf x)))
263                   (sendfun y 0 0 comm-world))))
264           (MPI:barrier comm-world))))
265     (test-send-recv MPI:send-fixnum MPI:receive-fixnum (lambda (x) (+ 1 x)) intdata)
266     (test-send-recv MPI:send-int MPI:receive-int (lambda (x) (+ 1 x)) intdata)
267     (test-send-recv MPI:send-flonum MPI:receive-flonum (lambda (x) (* 2 x)) flodata)
268    (let ((srfi4-test-send-recv
269           (lambda (len vsend vreceive vmap list->vector)
270             (lambda (data)
271               (test-send-recv vsend
272                               (lambda (src tag comm) (vreceive len src tag comm))
273                               (lambda (v) (vmap v (lambda (x) (+ 1 x))))
274                               (map list->vector data))))))
275      ((srfi4-test-send-recv vsize MPI:send-u8vector MPI:receive-u8vector u8vector-map list->u8vector)
276       vintdata)
277       ((srfi4-test-send-recv vsize MPI:send-s8vector MPI:receive-s8vector s8vector-map list->s8vector)
278        vintdata)
279       ((srfi4-test-send-recv vsize MPI:send-u16vector MPI:receive-u16vector u16vector-map list->u16vector)
280        vintdata)
281       ((srfi4-test-send-recv vsize MPI:send-s16vector MPI:receive-s16vector s16vector-map list->s16vector)
282        vintdata)
283       ((srfi4-test-send-recv vsize MPI:send-u32vector MPI:receive-u32vector u32vector-map list->u32vector)
284        vintdata)
285       ((srfi4-test-send-recv vsize MPI:send-s32vector MPI:receive-s32vector s32vector-map list->s32vector)
286        vintdata)
287       ((srfi4-test-send-recv vsize MPI:send-f32vector MPI:receive-f32vector f32vector-map list->f32vector)
288        vflodata)
289       ((srfi4-test-send-recv vsize MPI:send-f64vector MPI:receive-f64vector f64vector-map list->f64vector)
290        vflodata)
291      ))
292
293   (begin
294     (if (positive? myrank)
295         (sleep myrank))
296     (print myrank ": hitting barrier")
297     (MPI:barrier comm-world)
298     (if (zero? myrank)
299         (print "jumped barrier")))
300
301    ;;  Broadcast
302   (let* ((test-broadcast
303           (lambda (bcast data)
304             (if (zero? myrank)
305                 (print myrank ": broadcasting " data))
306             (let ((res (bcast data 0 comm-world)))
307               (print myrank ": received " (if (blob? res) (blob->string res) res))
308               (test-assert (equal? res data))
309               (MPI:barrier comm-world)))))
310     (test-broadcast MPI:broadcast-bytevector (string->blob "Hello!"))
311     (test-broadcast MPI:broadcast-int 123456)
312     (test-broadcast MPI:broadcast-flonum 3.141592654)
313     (let ((intdata  (list 12 45 78))
314           (flodata  (list 3.14 2.718 0.578))
315           (srfi4-test-broadcast
316            (lambda (bcast list->vector data)
317              (test-broadcast bcast (list->vector data)))))
318       (srfi4-test-broadcast MPI:broadcast-s8vector  list->s8vector  intdata)
319       (srfi4-test-broadcast MPI:broadcast-u8vector  list->u8vector  intdata)
320       (srfi4-test-broadcast MPI:broadcast-s16vector list->s16vector intdata)
321       (srfi4-test-broadcast MPI:broadcast-u16vector list->u16vector intdata)
322       (srfi4-test-broadcast MPI:broadcast-s32vector list->s32vector intdata)
323       (srfi4-test-broadcast MPI:broadcast-u32vector list->u32vector intdata)
324       (srfi4-test-broadcast MPI:broadcast-f32vector list->f32vector flodata)
325       (srfi4-test-broadcast MPI:broadcast-f64vector list->f64vector flodata)))
326
327  ;; Scatter
328   (let* ((test-scatter
329           (lambda (scatter vrange data)
330             (if (zero? myrank)
331                 (print myrank ": scatter " (if (blob? data) (blob->string data) data)))
332             (let ((res (scatter data 3 0 comm-world)))
333               (print myrank ": received (scatter) " (if (blob? res) (blob->string res) res))
334                (test-assert
335                 (equal? res (vrange data (* myrank vsize) (+ vsize (* myrank vsize))))))
336             (MPI:barrier comm-world))))
337     (test-scatter MPI:scatter-bytevector blob-range (string->blob (string-concatenate vsdata)))
338     (let ((srfi4-test-scatter
339            (lambda (scatter vrange list->vector data)
340              (test-scatter scatter vrange (list->vector (concatenate data))))))
341        (srfi4-test-scatter MPI:scatter-s8vector  s8vector-range  list->s8vector  vintdata)
342        (srfi4-test-scatter MPI:scatter-u8vector  u8vector-range  list->u8vector  vintdata)
343        (srfi4-test-scatter MPI:scatter-s16vector s16vector-range list->s16vector vintdata)
344        (srfi4-test-scatter MPI:scatter-u16vector u16vector-range list->u16vector vintdata)
345        (srfi4-test-scatter MPI:scatter-s32vector s32vector-range list->s32vector vintdata)
346        (srfi4-test-scatter MPI:scatter-u32vector u32vector-range list->u32vector vintdata)
347        (srfi4-test-scatter MPI:scatter-f32vector f32vector-range list->f32vector vflodata)
348        (srfi4-test-scatter MPI:scatter-f64vector f64vector-range list->f64vector vflodata)))
349     
350 ;;  Scatterv
351   (let* ((test-scatterv
352           (lambda (scatterv data)
353             (if (zero? myrank)
354                 (print myrank ": scatterv " data))
355             (let ((res (scatterv data 0 comm-world)))
356               (print myrank ": received (scatterv) " res)
357                (test res (list-ref data myrank)))
358             (MPI:barrier comm-world))))
359     (test-scatterv MPI:scatterv-bytevector (map string->blob vvsdata))
360     (let ((srfi4-test-scatterv
361            (lambda (scatterv list->vector data)
362              (test-scatterv scatterv (map list->vector data)))))
363       (srfi4-test-scatterv MPI:scatterv-s8vector   list->s8vector  vvintdata)
364       (srfi4-test-scatterv MPI:scatterv-u8vector   list->u8vector  vvintdata)
365       (srfi4-test-scatterv MPI:scatterv-s16vector  list->s16vector vvintdata)
366       (srfi4-test-scatterv MPI:scatterv-u16vector  list->u16vector vvintdata)
367       (srfi4-test-scatterv MPI:scatterv-s32vector  list->s32vector vvintdata)
368       (srfi4-test-scatterv MPI:scatterv-u32vector  list->u32vector vvintdata)
369       (srfi4-test-scatterv MPI:scatterv-f32vector  list->f32vector vvflodata)
370       (srfi4-test-scatterv MPI:scatterv-f64vector  list->f64vector vvflodata)))
371
372  ;; Gather
373   (let* ((test-gather
374           (lambda (gather data total)
375             (print myrank ": gather " (if (blob? data) (blob->string data) data))
376             (let ((res (gather data 3 0 comm-world)))
377               (if (zero? myrank)
378                   (begin
379                     (print myrank ": received (gather) " (if (blob? res) (blob->string res) res))
380                     (test res total))))
381               (MPI:barrier comm-world))))
382     (test-gather MPI:gather-bytevector (string->blob (list-ref vsdata myrank)) 
383                  (string->blob (string-concatenate vsdata)))
384     (test-gather MPI:gather-s8vector   (list->s8vector (list-ref vintdata myrank))
385                  (list->s8vector (concatenate vintdata)))
386     (test-gather MPI:gather-u8vector   (list->u8vector (list-ref vintdata myrank))
387                  (list->u8vector (concatenate vintdata)))
388     (test-gather MPI:gather-s16vector  (list->s16vector (list-ref vintdata myrank))
389                  (list->s16vector (concatenate vintdata)))
390     (test-gather MPI:gather-u16vector  (list->u16vector (list-ref vintdata myrank))
391                  (list->u16vector (concatenate vintdata)))
392     (test-gather MPI:gather-s32vector  (list->s32vector (list-ref vintdata myrank))
393                  (list->s32vector (concatenate vintdata)))
394     (test-gather MPI:gather-u32vector  (list->u32vector (list-ref vintdata myrank))
395                  (list->u32vector (concatenate vintdata)))
396     (test-gather MPI:gather-f32vector  (list->f32vector (list-ref vflodata myrank))
397                  (list->f32vector (concatenate vflodata)))
398     (test-gather MPI:gather-f64vector  (list->f64vector (list-ref vflodata myrank))
399                  (list->f64vector (concatenate vflodata))))
400
401
402  ;; Gatherv
403   (let* ((test-gatherv
404           (lambda (gatherv data total)
405             (print myrank ": gatherv " (if (blob? data) (blob->string data) data))
406             (let ((res (gatherv data 0 comm-world)))
407               (if (zero? myrank)
408                   (begin
409                     (print myrank ": received (gatherv) " 
410                            (map (lambda (x) (if (blob? x) (blob->string x) x)) res))
411                     (test res total))))
412               (MPI:barrier comm-world))))
413     (test-gatherv MPI:gatherv-bytevector (string->blob (list-ref vvsdata myrank))
414                   (map string->blob vvsdata))
415     (test-gatherv MPI:gatherv-s8vector   (list->s8vector (list-ref vvintdata myrank))
416                   (map list->s8vector vvintdata))
417     (test-gatherv MPI:gatherv-u8vector   (list->u8vector (list-ref vvintdata myrank))
418                   (map list->u8vector vvintdata))
419     (test-gatherv MPI:gatherv-s16vector  (list->s16vector (list-ref vvintdata myrank))
420                   (map list->s16vector vvintdata))
421     (test-gatherv MPI:gatherv-u16vector  (list->u16vector (list-ref vvintdata myrank))
422                   (map list->u16vector vvintdata))
423     (test-gatherv MPI:gatherv-s32vector  (list->s32vector (list-ref vvintdata myrank))
424                   (map list->s32vector vvintdata))
425     (test-gatherv MPI:gatherv-u32vector  (list->u32vector (list-ref vvintdata myrank))
426                   (map list->u32vector vvintdata))
427     (test-gatherv MPI:gatherv-f32vector  (list->f32vector (list-ref vvflodata myrank))
428                   (map list->f32vector vvflodata))
429     (test-gatherv MPI:gatherv-f64vector  (list->f64vector (list-ref vvflodata myrank))
430                   (map list->f64vector vvflodata)))
431
432
433  ;; Gather to all
434   (let* ((test-allgather 
435           (lambda (allgather data total)
436             (print myrank ": allgather " data)
437             (let ((res (allgather data 0 comm-world)))
438               (print myrank ": received (allgather) " 
439                      (map (lambda (x) (if (blob? x) (blob->string x) x)) res))
440               (test res total))
441             (MPI:barrier comm-world))))
442     (test-allgather MPI:allgather-bytevector (string->blob (list-ref vvsdata myrank))
443                   (map string->blob vvsdata))
444     (test-allgather MPI:allgather-s8vector   (list->s8vector (list-ref vvintdata myrank))
445                   (map list->s8vector vvintdata))
446     (test-allgather MPI:allgather-u8vector   (list->u8vector (list-ref vvintdata myrank))
447                   (map list->u8vector vvintdata))
448     (test-allgather MPI:allgather-s16vector  (list->s16vector (list-ref vvintdata myrank))
449                   (map list->s16vector vvintdata))
450     (test-allgather MPI:allgather-u16vector  (list->u16vector (list-ref vvintdata myrank))
451                   (map list->u16vector vvintdata))
452     (test-allgather MPI:allgather-s32vector  (list->s32vector (list-ref vvintdata myrank))
453                   (map list->s32vector vvintdata))
454     (test-allgather MPI:allgather-u32vector  (list->u32vector (list-ref vvintdata myrank))
455                   (map list->u32vector vvintdata))
456     (test-allgather MPI:allgather-f32vector  (list->f32vector (list-ref vvflodata myrank))
457                   (map list->f32vector vvflodata))
458     (test-allgather MPI:allgather-f64vector  (list->f64vector (list-ref vvflodata myrank))
459                   (map list->f64vector vvflodata)))
460
461
462  ;; Reduce
463   (let* ((test-reduce 
464          (lambda (reducefun reduceops data)
465            (for-each (lambda (op)
466                        (print myrank ": reduce")
467                        (let ((res (reducefun data op 0 comm-world)))
468                          (if (zero? myrank)
469                              (begin
470                                (print myrank ": the result of reduction " op " is " res)
471                                (test-assert res)
472                                ))
473                          (MPI:barrier comm-world)
474                          ))
475                      reduceops)
476            (MPI:barrier comm-world))))
477    (test-reduce MPI:reduce-int
478                 (list MPI:i_max MPI:i_min MPI:i_sum MPI:i_prod )
479                 (+ 1 myrank))
480    (test-reduce MPI:reduce-flonum
481                 (list MPI:f_max MPI:f_min MPI:f_sum MPI:f_prod )
482                 (+ 1 myrank))
483    (test-reduce MPI:reduce-s8vector 
484                 (list MPI:i_max MPI:i_min MPI:i_sum MPI:i_prod )
485                 (s8vector (* 2 myrank) (+ 1 (* 2 myrank)) (+ 2 (* 2 myrank))))
486    (test-reduce MPI:reduce-u8vector 
487                 (list MPI:i_max MPI:i_min MPI:i_sum MPI:i_prod )
488                 (u8vector (* 2 myrank) (+ 1 (* 2 myrank)) (+ 2 (* 2 myrank))))
489    (test-reduce MPI:reduce-s16vector 
490                 (list MPI:i_max MPI:i_min MPI:i_sum MPI:i_prod )
491                 (s16vector (* 2 myrank) (+ 1 (* 2 myrank)) (+ 2 (* 2 myrank))))
492    (test-reduce MPI:reduce-u16vector 
493                 (list MPI:i_max MPI:i_min MPI:i_sum MPI:i_prod )
494                 (u16vector (* 2 myrank) (+ 1 (* 2 myrank)) (+ 2 (* 2 myrank))))
495    (test-reduce MPI:reduce-s32vector 
496                 (list MPI:i_max MPI:i_min MPI:i_sum MPI:i_prod )
497                 (s32vector (* 2 myrank) (+ 1 (* 2 myrank)) (+ 2 (* 2 myrank))))
498    (test-reduce MPI:reduce-u32vector 
499                 (list MPI:i_max MPI:i_min MPI:i_sum MPI:i_prod )
500                 (u32vector (* 2 myrank) (+ 1 (* 2 myrank)) (+ 2 (* 2 myrank))))
501    (test-reduce MPI:reduce-f32vector 
502                 (list MPI:f_max MPI:f_min MPI:f_sum MPI:f_prod )
503                 (f32vector (* 2 myrank) (+ 0.1 (* 2 myrank)) (+ 0.2 (* 2 myrank))))
504    (test-reduce MPI:reduce-f64vector 
505                 (list MPI:f_max MPI:f_min MPI:f_sum MPI:f_prod )
506                 (f64vector (* 2 myrank) (+ 0.1 (* 2 myrank)) (+ 0.2 (* 2 myrank))))
507    )
508
509  ;; Reduce all
510   (let* ((test-allreduce
511          (lambda (allreducefun reduceop data)
512            (print myrank ": data is " data)
513            (let ((res (allreducefun data reduceop comm-world)))
514              (MPI:barrier comm-world)
515              (print myrank ": the result of reduction " reduceop " is " res)
516              (test-assert res)
517              (MPI:barrier comm-world)))))
518    (test-allreduce MPI:allreduce-int MPI:i_sum (+ 1 myrank))
519    (test-allreduce MPI:allreduce-flonum MPI:f_prod (+ 1.0 myrank))
520    (test-allreduce MPI:allreduce-s8vector MPI:i_sum
521                    (s8vector (* 2 myrank) (+ 1 (* 2 myrank)) (+ 2 (* 2 myrank))))
522    (test-allreduce MPI:allreduce-u8vector MPI:i_sum
523                    (u8vector (* 2 myrank) (+ 1 (* 2 myrank)) (+ 2 (* 2 myrank))))
524    (test-allreduce MPI:allreduce-s16vector MPI:i_sum
525                    (s16vector (* 2 myrank) (+ 1 (* 2 myrank)) (+ 2 (* 2 myrank))))
526    (test-allreduce MPI:allreduce-u16vector MPI:i_sum
527                    (u16vector (* 2 myrank) (+ 1 (* 2 myrank)) (+ 2 (* 2 myrank))))
528    (test-allreduce MPI:allreduce-s32vector MPI:i_sum
529                    (s32vector (* 2 myrank) (+ 1 (* 2 myrank)) (+ 2 (* 2 myrank))))
530    (test-allreduce MPI:allreduce-u32vector MPI:i_sum
531                    (u32vector (* 2 myrank) (+ 1 (* 2 myrank)) (+ 2 (* 2 myrank))))
532    (test-allreduce MPI:allreduce-f32vector MPI:f_sum 
533                    (f32vector (* 2 myrank) (+ 0.1 (* 2 myrank)) (+ 0.2 (* 2 myrank))))
534    (test-allreduce MPI:allreduce-f64vector MPI:f_sum 
535                    (f64vector (* 2 myrank) (+ 0.1 (* 2 myrank)) (+ 0.2 (* 2 myrank)))))
536   
537   ;; Scan
538   (let* ((test-scan
539          (lambda (scanfun reduceop data)
540            (print myrank ": data is " data)
541            (let ((res (scanfun data reduceop comm-world)))
542              (MPI:barrier comm-world)
543              (print myrank ": the result of scan " reduceop " is " res)
544              (test-assert res))
545              (MPI:barrier comm-world))))
546    (test-scan MPI:scan-int MPI:i_sum (+ 1 myrank))
547    (test-scan MPI:scan-flonum MPI:f_prod (+ 1.0 myrank))
548    (test-scan MPI:scan-s8vector MPI:i_sum
549               (s8vector (* 2 myrank) (+ 1 (* 2 myrank)) (+ 2 (* 2 myrank))))
550    (test-scan MPI:scan-u8vector MPI:i_sum
551               (u8vector (* 2 myrank) (+ 1 (* 2 myrank)) (+ 2 (* 2 myrank))))
552    (test-scan MPI:scan-s16vector MPI:i_sum
553               (s16vector (* 2 myrank) (+ 1 (* 2 myrank)) (+ 2 (* 2 myrank))))
554    (test-scan MPI:scan-u16vector MPI:i_sum
555               (u16vector (* 2 myrank) (+ 1 (* 2 myrank)) (+ 2 (* 2 myrank))))
556    (test-scan MPI:scan-s32vector MPI:i_sum
557               (s32vector (* 2 myrank) (+ 1 (* 2 myrank)) (+ 2 (* 2 myrank))))
558    (test-scan MPI:scan-u32vector MPI:i_sum
559               (u32vector (* 2 myrank) (+ 1 (* 2 myrank)) (+ 2 (* 2 myrank))))
560    (test-scan MPI:scan-f32vector MPI:f_sum 
561               (f32vector (* 2 myrank) (+ 0.1 (* 2 myrank)) (+ 0.2 (* 2 myrank))))
562    (test-scan MPI:scan-f64vector MPI:f_sum 
563               (f64vector (* 2 myrank) (+ 0.1 (* 2 myrank)) (+ 0.2 (* 2 myrank)))))
564
565  ;; Comm split
566   (let ((send-in-comm
567         (lambda (c init incr)
568           (let ((rank-in-c (MPI:comm-rank c))
569                 (size-of-c (MPI:comm-size c)))
570             (if (zero? rank-in-c)
571                 (begin
572                   (print rank-in-c "[" myrank "]: sending " init)
573                   (MPI:send init 1 0 c)
574                   (let ((n (MPI:receive MPI:any-source MPI:any-tag c)))
575                     (print rank-in-c "[" myrank "]: received " n)))
576                 (let ((n (MPI:receive MPI:any-source MPI:any-tag c)))
577                   (let ((n1 (string->blob (string-append (blob->string n) incr))))
578                     (print rank-in-c "[" myrank "]: received " n ", resending " n1)
579                     (MPI:send n1 (modulo (+ 1 rank-in-c) size-of-c) 0 c))))
580             (MPI:barrier comm-world)))))
581    (let ((c (MPI:comm-split comm-world (modulo myrank 2) 0)))
582      (if (zero? (modulo myrank 2))
583          (send-in-comm c (string->blob "aa") "a")
584          (send-in-comm c (string->blob "bb") "b"))))
585
586  ;; Cartesian topology
587   (let ((cart (MPI:make-cart comm-world (u32vector 2 2) (u32vector 0 0) #t))
588        (test-dims-create 
589         (lambda (n hints)
590           (print "make-dims " n " " hints " = " (MPI:make-dims n hints)))))
591    (if (zero? myrank)
592        (begin
593          (print "ranks = " (map (lambda (x) (cons x (MPI:cart-rank cart x)))
594                                 (list
595                                  (u32vector 0 0) (u32vector 1 0)
596                                  (u32vector 1 0) (u32vector 1 1))))
597          (print "coords = " (list-tabulate (MPI:comm-size cart)
598                                            (lambda (n) (cons n (MPI:cart-coords cart n)))))
599          (test-dims-create 60 (u32vector 0 0 0))
600          (test-dims-create 60 (u32vector 3 0 0))
601          (test-dims-create 60 (u32vector 0 4 0))
602          (test-dims-create 60 (u32vector 3 0 5))
603          )))
604
605  (MPI:barrier comm-world)
606
607  ;;   Wtime
608  (print myrank ": wtime is "  (MPI:wtime))
609
610  )
Note: See TracBrowser for help on using the repository browser.