1C> \ingroup selci
2C> @{
3      subroutine selci_stool(iconf,ept,ept_mp,enew,ptnorm,ptnorm_mp,
4     &     nroot,irange,nrange,iwpt,
5     &     noconfi,ioconf,nintpo,nconmx,ncold)
6*
7* $Id$
8*
9      implicit real*8 (a-h,o-z), integer(i-n)
10#include "errquit.fh"
11c
12c     collect info from the other processes for restart
13c
14      dimension ioconf(nintpo,nconmx),irange(nrange),
15     &     ept(nroot),enew(nroot),ptnorm(nroot),
16     &     ept_mp(nroot),ptnorm_mp(nroot)
17c
18c     spare arrays needed
19c
20      dimension eptn(50), enewn(50), ptnormn(50), irangen(21)
21      dimension eptn_mp(50), ptnormn_mp(50)
22      integer pmap(0:1023)      ! 1024 max process count
23c
24c     irest = unit for restart tape 'selci.r.?'
25c     ? is 1 or 2
26c     istde = standard error
27c     istdo = standard output
28c
29      parameter(irest = 69)
30      parameter(istde=0,istdo=6)
31#include "cselcifiles.fh"
32#include "global.fh"
33      integer icall
34      data icall/0/
35c
36      its = mtime()
37      if (nroot.gt.50) call errquit('STOOL: hard dimension fail',
38     $     nroot, INPUT_ERR)
39      me = ga_nodeid()
40      master = 0
41      if (ga_nnodes() .gt. 1024) call errquit('ptidy: too many procs',
42     $     0, INPUT_ERR)
43      call ga_list_nodeid(pmap, ga_nnodes()) ! Map to msg passing layer
44*     write(6,*) ga_nodeid(),' processor map ',
45*     $     (pmap(i),i=0,ga_nnodes()-1)
46      node0 = pmap(0)
47c
48c     check existence of file
49c     The following two lines are to take care of compiler warnings.
50c
51      ifile  = 1
52      idfile = 2
53
54      if (me.eq.master) then
55         icall = icall + 1
56         ifile  = 1
57         idfile = 2
58         if(mod(icall,2).eq.0) then
59            ifile  = 2
60            idfile = 1
61         endif
62      endif
63c
64c     do not update vector length
65c     if a crash occurs then node 0 (master) will
66c     hold all results of previous work.
67c
68      noconf = noconfi
69      isync = 1
70      if (me.ne.master) then
71         call snd(21, (noconf-ncold), mitob(1), node0, isync)
72         call snd(22, ioconf(1,ncold+1),mitob(nintpo*(noconf-ncold)),
73     &        node0,isync)
74         call snd(23, ept, mdtob(nroot), node0, isync)
75         call snd(24, enew, mdtob(nroot), node0, isync)
76         call snd(25, ptnorm, mdtob(nroot), node0, isync)
77         call snd(26, irange, mitob(21), node0, isync)
78         call snd(27, ept_mp, mdtob(nroot), node0, isync)
79         call snd(28, ptnorm_mp, mdtob(nroot), node0, isync)
80         call dfill(nroot,0.0d0,ept,1)
81         call dfill(nroot,0.0d0,ept_mp,1)
82         call dfill(nroot,0.0d0,enew,1)
83         call dfill(nroot,0.0d0,ptnorm,1)
84         call dfill(nroot,0.0d0,ptnorm_mp,1)
85         call ifill(21,0,irange,1)
86      else
87         ipt = noconf+1
88         do iislave=1,ga_nnodes()-1
89            islave = pmap(iislave)
90            call rcv(21, new, mitob(1), len, islave, node, isync)
91            noconf = noconf + new
92            if (noconf.le.nconmx) then
93               call rcv(22, ioconf(1,ipt), mitob(nintpo*new), len,
94     $              islave, node, isync)
95               ipt = ipt + new
96            else
97               call errquit(' stool: noconf exceeded nconmx ',
98     &              noconf, INPUT_ERR)
99            endif
100            call rcv(23, eptn, mdtob(nroot), len, islave, node,
101     &           isync)
102            call rcv(24, enewn, mdtob(nroot), len, islave, node,
103     &           isync)
104            call rcv(25, ptnormn, mdtob(nroot), len, islave, node,
105     &           isync)
106            call rcv(26, irangen, mitob(nrange), len, islave, node,
107     &           isync)
108            call rcv(27, eptn_mp, mdtob(nroot), len, islave, node,
109     &           isync)
110            call rcv(28, ptnormn_mp, mdtob(nroot), len, islave, node,
111     &           isync)
112            do i = 1,nroot
113               ept(i) = ept(i) + eptn(i)
114               ept_mp(i) = ept_mp(i) + eptn_mp(i)
115               enew(i) = enew(i) + enewn(i)
116               ptnorm(i) = ptnorm(i) + ptnormn(i)
117               ptnorm_mp(i) = ptnorm_mp(i) + ptnormn_mp(i)
118            enddo
119            do i = 1,nrange
120               irange(i) = irange(i) + irangen(i)
121            enddo
122         enddo
123         open(unit=irest,file=names(ifile),access='sequential',
124     &        form='unformatted',status='unknown',
125     &        err=90911)
126         close(unit=irest,status='delete')
127         open(unit=irest,file=names(ifile),access='sequential',
128     &        form='unformatted',status='unknown',
129     &        err=90911)
130         rewind irest
131c
132         write(irest)iconf,ncold,nroot,nrange,noconf,nintpo,nconmx,
133     $        iwpt
134         write(irest)(irange(ii),ii=1,nrange)
135         write(irest)(ept(ii),ii=1,nroot)
136         write(irest)(ept_mp(ii),ii=1,nroot)
137         write(irest)(enew(ii),ii=1,nroot)
138         write(irest)(ptnorm(ii),ii=1,nroot)
139         write(irest)(ptnorm_mp(ii),ii=1,nroot)
140         nloop = noconf
141         do jj = 1,nloop
142            write(irest)(ioconf(ii,jj),ii=1,nintpo)
143         enddo
144         write(istdo,'(a,i6,a,i6)')
145     &        ' checkpointed at iconf = ',iconf,' of ',ncold
146c
147c     close restart tape
148c
149         close(unit=irest,status='keep')
150         if(me.eq.0)call util_flush(istdo)
151c
152c     delete other restart tape
153c
154         open(unit=irest,file=names(idfile),access='sequential',
155     &        form='unformatted',status='unknown',
156     &        err=90912)
157         close(unit=irest,status='delete')
158         itf = mtime()
159      endif
160c
161      call ga_sync()
162c
163      return
164c
16590911 call errquit('stool: error opening restart file',0, DISK_ERR)
16690912 call errquit('stool: error opening restart file',0, DISK_ERR)
167c
168      end
169C> @}
170