root / synthbench / euroben-dm / mod1i / .svn / text-base / dddot1.f.svn-base @ 0:839f52ef7657
History | View | Annotate | Download (2.3 kB)
1 |
Function dddot1( 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, Parameter :: maxnod = 2048 |
12 |
Integer :: comm, datype, i, ierr, length, |
13 |
& status(MPI_Status_Size), tag |
14 |
Real(l_) :: s, spart(0:maxnod-1) |
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 |
dotres = s |
23 |
! --------------------------------------------------------------------- |
24 |
! --- If on 1 processor we are done: Return. |
25 |
|
26 |
If ( k == 1 ) Return |
27 |
! --------------------------------------------------------------------- |
28 |
! --- Send partial results from all other processors to processor 1. |
29 |
|
30 |
|
31 |
datype = Mpi_Real8 |
32 |
length = 1 |
33 |
tag = 1 |
34 |
comm = MPI_Comm_World |
35 |
|
36 |
If ( me > 0 .AND. me < k ) Then |
37 |
Call MPI_Send( s, length, datype , 0, tag, comm, ierr ) |
38 |
Else If ( me == 0 ) Then |
39 |
! --------------------------------------------------------------------- |
40 |
! --- Receive partial results (blocking) on processor 1. |
41 |
|
42 |
Do i = 1, k - 1 |
43 |
Call MPI_Recv( spart(i), length, datype, i, tag, comm, |
44 |
& status, ierr ) |
45 |
End Do |
46 |
End If |
47 |
! --------------------------------------------------------------------- |
48 |
! --- Combine partial results. |
49 |
|
50 |
If ( me == 0 ) Then |
51 |
Do i = 1, k - 1 |
52 |
dotres = dotres + spart(i) |
53 |
End Do |
54 |
End If |
55 |
! --------------------------------------------------------------------- |
56 |
! --- Send sum to all processors. |
57 |
|
58 |
If ( me == 0 ) Then |
59 |
Do i = 1, k - 1 |
60 |
Call MPI_Send( dotres, length, datype, i, tag, comm, |
61 |
& ierr ) |
62 |
End Do |
63 |
Else If ( me > 0 .AND. me < k ) Then |
64 |
Call MPI_Recv( dotres, length, datype, 0, tag, comm, |
65 |
& status, ierr ) |
66 |
End If |
67 |
! --------------------------------------------------------------------- |
68 |
End Function dddot1 |