root / synthbench / euroben-dm / mod1i / .svn / text-base / dddot2.f.svn-base @ 0:839f52ef7657
History | View | Annotate | Download (2.6 kB)
1 |
Function dddot2( k, n, x, y ) Result( dotres ) |
---|---|
2 |
! --------------------------------------------------------------------- |
3 |
Use dist_module |
4 |
Use numerics |
5 |
Implicit None |
6 |
Integer :: k, n |
7 |
Real(l_) :: x(n), y(n), dotres |
8 |
|
9 |
Include 'mpif.h' |
10 |
|
11 |
Integer :: comm, datype, tag |
12 |
Integer :: ierr, status(MPI_Status_Size) |
13 |
Integer :: i, left, right, up, maxup |
14 |
Real(l_) :: s, sleft, sright |
15 |
! --------------------------------------------------------------------- |
16 |
! --- Do local part of dotproduct. |
17 |
|
18 |
s = 0.0_l_ |
19 |
Do i = 1, n |
20 |
s = s + x(i)*y(i) |
21 |
End Do |
22 |
! --------------------------------------------------------------------- |
23 |
! --- If on 1 processor we are done: Return. |
24 |
|
25 |
If ( me == 0 ) dotres = s |
26 |
If ( k == 1 ) Return |
27 |
! --------------------------------------------------------------------- |
28 |
! --- Combine partial results on processor 1. |
29 |
|
30 |
datype = MPI_Real8 |
31 |
tag = 1 |
32 |
comm = MPI_Comm_World |
33 |
|
34 |
right = 2*(me + 1) |
35 |
left = right - 1 |
36 |
up = (me - 1)/2 |
37 |
maxup = (k - 2)/2 |
38 |
|
39 |
If ( right < k ) Then |
40 |
Call MPI_Recv( sright, 1, datype, right, tag, comm, |
41 |
& status, ierr ) |
42 |
Call MPI_Recv( sleft, 1, datype, left, tag, comm, |
43 |
& status, ierr ) |
44 |
s = s + sleft + sright |
45 |
Else If ( left < k ) Then |
46 |
Call MPI_Recv( sleft, 1, datype, left, tag, comm, |
47 |
& status, ierr ) |
48 |
s = s + sleft |
49 |
End If |
50 |
If ( me > 0 .AND. me < k ) Then |
51 |
Call MPI_Send( s, 1, datype, up, tag, comm, ierr ) |
52 |
End If |
53 |
If ( me == 0 ) dotres = s |
54 |
! --------------------------------------------------------------------- |
55 |
! --- Send sum to all processors. |
56 |
|
57 |
If ( me == 0 ) Then |
58 |
Call MPI_Send( dotres, 1, datype, left, tag, comm, ierr) |
59 |
If ( right < k ) Then |
60 |
Call MPI_Send( dotres, 1, datype, right, tag, comm, ierr ) |
61 |
End If |
62 |
Else |
63 |
If ( up <= maxup ) Then |
64 |
Call MPI_Recv( dotres, 1, datype, up, tag, comm, status, |
65 |
& ierr ) |
66 |
End If |
67 |
If ( right < k ) Then |
68 |
Call MPI_Send( dotres, 1, datype, right, tag, comm, ierr ) |
69 |
Call MPI_Send( dotres, 1, datype, left , tag, comm, ierr ) |
70 |
Else If ( left < k ) Then |
71 |
Call MPI_Send( dotres, 1, datype, left , tag, comm, ierr ) |
72 |
End If |
73 |
End If |
74 |
! --------------------------------------------------------------------- |
75 |
End Function dddot2 |