]>
Commit | Line | Data |
---|---|---|
fe4da5cc | 1 | *CMZ : 08/23/94 15.20.00 by John Apostolakis CERN GP-MIMD 2 |
2 | *-- Author : | |
3 | subroutine GPSUMHR( idh, file, chopt ) | |
4 | c | |
5 | c Saves histograms into a single RZ file, putting each | |
6 | c process' histogram into a subdirectory, as well as saving the | |
7 | c running total in the subdirectory 'totals'. At the end the | |
8 | c directory 'totals' will contain the sum total of all | |
9 | c contributions from all processes. | |
10 | c | |
11 | c ( A 'replacement' for hrput for parallel Geant.) | |
12 | c | |
13 | c. Implementation notes: | |
14 | c. | |
15 | c. Currently chopt is ignored! | |
16 | c. | |
17 | c------------------------------------------------------------------------- | |
18 | #if defined(CERNLIB_PARA) | |
19 | IMPLICIT NONE | |
20 | INTEGER idh | |
21 | CHARACTER*(*) file, chopt | |
22 | ||
23 | INTEGER myid | |
24 | character*13 myname | |
25 | #include "geant321/mpifinc.inc" | |
26 | #include "geant321/multiprox.inc" | |
27 | C | |
28 | INTEGER istat, icycle, lunhist | |
29 | C | |
30 | integer iquest(100), nrec, itag | |
31 | integer npstat(MPI_STATUS_SIZE), ierr | |
32 | integer idebgsvh, npnext, nfirst, indivout | |
33 | character*1 filemode | |
34 | common /quest/ iquest | |
35 | data nrec / 1024 / | |
36 | data itag / 1001 / | |
37 | data idebgsvh / 1 / | |
38 | data indivout / 1 / | |
39 | data lunhist / 29 / | |
40 | parameter (nfirst=0) | |
41 | c---------------------------------------------------------------------- | |
42 | c J. Apostolakis: Use a directory for each process and a | |
43 | c a directory called 'totals' for totals, | |
44 | c v0.1 February 9, 1994 using mvlock/mvunlock | |
45 | c v0.2 August 4, 1994 using mpi_{send,recv} | |
46 | c | |
47 | c Node 0 creates the file, others wait their turn (a message goes | |
48 | c around that each node receives, does its stuff and sends on) | |
49 | c [ Older idea was to use a barrier: call mpi_barrier( MPI_COMM_WORLD ) ] | |
50 | c | |
51 | c Notes: | |
52 | c x The current scheme is not robust, but has worked well. | |
53 | c x The potential problem is if one node fails before getting to | |
54 | c x this point or during its call to gpsumhr. The former could be | |
55 | c x handled by replacing the current method with a robust scheme | |
56 | c x capable of handling node failures, by using lockf/unlockf to | |
57 | c x lock the file ... | |
58 | c x | |
59 | c x For file creation, having all nodes try to create a new hbook | |
60 | c x file will not work, since one will overwrite another ... | |
61 | c | |
62 | if( nprank .eq. nfirst ) then | |
63 | filemode= 'N' | |
64 | nrec= 1024 | |
65 | else | |
66 | filemode= 'U' | |
67 | nrec= 0 | |
68 | c | |
69 | c Wait here until the previous node is finished ! | |
70 | c | |
71 | call mpi_recv( istat, 1, MPI_INTEGER, | |
72 | & nprank-1, itag, MPI_COMM_WORLD, npstat, ierr ) | |
73 | endif | |
74 | ||
75 | CALL HROPEN ( LUNHIST, 'OUTPUT', file, filemode, nrec, istat) | |
76 | ||
77 | if(istat.ne.0) then | |
78 | print *, ' HROPEN of ', file, ' on node ', nprank, | |
79 | & ' failed in gpsumhr. Istat = ', istat | |
80 | else | |
81 | print *, ' HROPEN of ', file, ' on node ', nprank, | |
82 | & ' succeeded and gave nrec=', nrec | |
83 | endif | |
84 | ||
85 | myid = nprank | |
86 | if( myid.ge.10000 ) then | |
87 | print *, 'Warning in gpsumhr: The id (',myid, | |
88 | & ')is too big to be used in gpsumhr.f' | |
89 | myid = mod(myid, 10000) | |
90 | endif | |
91 | write (myname, '(a7,i6)') 'process',myid+10000 | |
92 | myname(8:8)='0' | |
93 | ||
94 | if( idebgsvh .eq. 1 ) then | |
95 | call hldir ( '//PAWC', ' ' ) | |
96 | call hldir ( '//OUTPUT', 't' ) | |
97 | endif | |
98 | ||
99 | call hcdir ( '//OUTPUT', ' ' ) | |
100 | ||
101 | c Could make 'indivout' an option: it creates subdirectories with | |
102 | c each node's output. | |
103 | if( indivout .eq. 1 ) then | |
104 | call hmdir ( myname, ' ' ) | |
105 | call hcdir ( myname, ' ' ) ! if it has been created already ... | |
106 | CALL HROUT ( idh, icycle,' ') | |
107 | endif | |
108 | ||
109 | if( nprank .eq. nfirst ) then | |
110 | call hmdir ( '//OUTPUT/TOTALS','S') | |
111 | else | |
112 | call hcdir ( '//OUTPUT/TOTALS',' ') | |
113 | CALL HRIN ( idh, 888888, 99999) | |
114 | endif | |
115 | c ! 99999 is an undocumented feature => it adds | |
116 | c the histograms to the ones in memory | |
117 | c ------------------------------------------------------------------ | |
118 | call hrout ( idh, icycle, 'T') | |
119 | ||
120 | CALL HREND ('OUTPUT') | |
121 | close( LUNHIST ) | |
122 | c | |
123 | c Send a message to the next node, which is waiting until this one | |
124 | c is finished ! | |
125 | c | |
126 | npnext = nprank+1 | |
127 | if ( npnext .ge. npsize ) npnext = npnext - npsize | |
128 | call mpi_send( istat, 1, MPI_INTEGER, | |
129 | & npnext, itag, MPI_COMM_WORLD, ierr ) | |
130 | ||
131 | c | |
132 | c Finally have the first node receive the last node's message! | |
133 | c | |
134 | if( nprank .eq. nfirst ) then | |
135 | call mpi_recv( istat, 1, MPI_INTEGER, | |
136 | & npsize-1, itag, MPI_COMM_WORLD, npstat, ierr ) | |
137 | endif | |
138 | c----------------------------------------------------------------------- | |
139 | ||
140 | RETURN | |
141 | END | |
142 | #endif |