GEANT321/gparal/gpsumhr.F

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