1      block data initial_smd_group_data
2      implicit none
3#include "smd_group_data.fh"
4c
5      data  smd_ngroup /-1/
6      data  smd_group_nproc /-1/
7      data  smd_group_id /-1/
8      data  smd_group_handle /-1/
9      data smd_group_rtdb_reuse /.false./
10
11      end
12      subroutine smd_group_init(rtdb)
13      implicit none
14#include "errquit.fh"
15#include "inp.fh"
16#include "mafdecls.fh"
17#include "rtdb.fh"
18#include "util.fh"
19#include "global.fh"
20#include "smd_group_data.fh"
21c
22      integer rtdb
23c
24      integer ngroups
25      integer i1
26
27      character*255 buffer, buffer1
28      if (.not.rtdb_get(rtdb, 'subgroups_number', mt_int, 1,
29     &   ngroups))
30     $  call errquit('define number of groups', 0, RTDB_ERR)
31      call ga_sync()
32
33      if(.not.rtdb_getfname(rtdb,smd_group_rtdb_world))
34     $  call errquit('rtdb_getfname', 0, RTDB_ERR)
35
36      call ga_sync()
37      if(.not.rtdb_close(rtdb, 'keep'))
38     + call errquit('Failed to close group rtdb',0, GEOM_ERR)
39
40      call smd_group_create_simple(ngroups)
41
42c      call util_file_prefix_get(buffer)
43c      i1 = inp_strlen(buffer)
44c      write(buffer1,'(A,I4.4)')
45c     >    buffer(1:i1),smd_group_id
46c      call util_file_prefix_set(buffer1)
47c
48c      call util_file_prefix_get(smd_group_prefix_world)
49c      i1 = inp_strlen(smd_group_prefix_world)
50c      write(smd_group_prefix,'(A,I4.4)')
51c     >    smd_group_prefix_world(1:i1),smd_group_id
52c      call util_file_prefix_set(smd_group_prefix)
53
54
55      return
56      end
57      subroutine smd_group_prefix_set(im)
58      implicit none
59#include "errquit.fh"
60#include "inp.fh"
61#include "mafdecls.fh"
62#include "rtdb.fh"
63#include "util.fh"
64#include "global.fh"
65#include "smd_group_data.fh"
66c
67      integer im
68      integer rtdb
69c
70      character*255 buffer,buffer1
71      integer i1
72
73      call util_file_prefix_get(buffer)
74      i1 = inp_strlen(buffer)
75      write(buffer1,'(A,I4.4)')
76     >    buffer(1:i1),im
77      call util_file_prefix_set(buffer1)
78
79      if(ga_nodeid().eq.0)
80     > call util_flush(6)
81      call ga_sync(ga_pgroup_get_world())
82      if(smd_group_id.eq.1.and.ga_nodeid().eq.0) then
83        write(*,*) "GROUP INFORMATION"
84        call util_flush(6)
85      end if
86      if(ga_nodeid().eq.0) then
87       write(*,*) "Group id, nprocs",smd_group_id,smd_group_nproc
88       call util_flush(6)
89      end if
90      call ga_sync(ga_pgroup_get_world())
91
92      return
93      end
94      subroutine smd_group_end(rtdb)
95      implicit none
96#include "errquit.fh"
97#include "inp.fh"
98#include "mafdecls.fh"
99#include "rtdb.fh"
100#include "util.fh"
101#include "global.fh"
102#include "smd_group_data.fh"
103c
104      integer rtdb
105c
106      integer ngroups
107
108      character*36 buffer
109
110      call ga_pgroup_set_default(ga_pgroup_get_world())
111      if(.not. ga_pgroup_destroy(smd_group_handle))
112     + call errquit('Failed to destroy group',0, 0)
113      call ga_sync()
114      if(.not.rtdb_open(smd_group_rtdb_world,'old',rtdb))
115     + call errquit('Failed to open world rtdb',0, 0)
116
117      smd_ngroup =-1
118      smd_group_nproc =-1
119      smd_group_id =-1
120      smd_group_handle =-1
121
122      return
123      end
124
125      subroutine smd_group_rtdb_clone1()
126      implicit none
127#include "errquit.fh"
128#include "inp.fh"
129#include "mafdecls.fh"
130#include "util.fh"
131#include "global.fh"
132#include "smd_group_data.fh"
133c
134      character*72 buffer
135      integer i1,i2
136      logical result
137      buffer = " "
138c      i1 = 0
139c10    if (inp_strtok(smd_group_rtdb_world, '/',i1,i2)) then
140c      buffer = smd_group_rtdb_world(i1:i2)
141c      goto 10
142c      endif
143c
144c      write(smd_group_rtdb,'(a,I4.4)')
145c     >          buffer(1:inp_strlen(buffer)),
146c     >          smd_group_id
147
148      write(smd_group_rtdb,'(I4.4,A3)')
149     >          smd_group_id,".db"
150
151      buffer = smd_group_rtdb
152      call util_file_name(buffer,.true.,.false.,smd_group_rtdb)
153      if(ga_nodeid().eq.0) then
154        inquire(file=smd_group_rtdb_world,exist=result)
155        if(.not.result) then
156          call errquit("cannot find world rtdb"//
157     >                 smd_group_rtdb_world,
158     >                 0,0)
159        end if
160        call util_file_copy(smd_group_rtdb_world,
161     >                      smd_group_rtdb)
162        inquire(file=smd_group_rtdb,exist=result)
163        if(.not.result) then
164          call errquit("cannot find group rtdb"//
165     >                 smd_group_rtdb,
166     >                 0,0)
167        end if
168
169      end if
170      return
171      end
172
173      subroutine smd_group_rtdb_clone2(rtdb,im)
174      implicit none
175#include "errquit.fh"
176#include "inp.fh"
177#include "mafdecls.fh"
178#include "util.fh"
179#include "global.fh"
180#include "smd_group_data.fh"
181#include "rtdb.fh"
182      integer rtdb
183      integer im
184c
185      character*255 buffer,buffer1
186      integer i1,i2
187      logical result
188c
189      call ga_sync()
190c
191      buffer = ""
192      write(buffer,'(I4.4,A3)')
193     >          im,".db"
194
195      call util_file_prefix(buffer,smd_group_rtdb)
196      if(ga_nodeid().eq.0) then
197        if(smd_group_rtdb_reuse) then
198        buffer = smd_group_rtdb
199        call util_file_name_resolve(buffer,.false.)
200        inquire(file=buffer,exist=result)
201        else
202        result = .false.
203        end if
204        if(.not.result) then
205          buffer = smd_group_rtdb_world
206        end if
207        buffer1 = smd_group_rtdb
208        call util_file_name_resolve(buffer1,.true.)
209        write(*,*) "copying rtdb from",buffer(1:inp_strlen(buffer))
210        call util_file_copy(buffer,buffer1)
211      end if
212
213      if(.not.rtdb_open(buffer1,"old",rtdb))
214     + call errquit('Failed to open group rtdb',0, GEOM_ERR)
215
216      smd_group_rtdb_reuse = .true.
217
218      return
219      end
220
221      subroutine smd_group_rtdb_clone(rtdb)
222      implicit none
223#include "errquit.fh"
224#include "inp.fh"
225#include "mafdecls.fh"
226#include "util.fh"
227#include "global.fh"
228#include "smd_group_data.fh"
229#include "rtdb.fh"
230      integer rtdb
231c
232      character*72 buffer
233      integer i1,i2
234      logical result
235c
236      call ga_sync()
237c
238      write(smd_group_rtdb,'(I4.4,A3)')
239     >          smd_group_id,".db"
240
241      buffer = smd_group_rtdb
242      call util_file_name(buffer,.true.,.false.,smd_group_rtdb)
243      if(ga_nodeid().eq.0) then
244        inquire(file=smd_group_rtdb_world,exist=result)
245        if(.not.result) then
246          call errquit("cannot find world rtdb"//
247     >                 smd_group_rtdb_world,
248     >                 0,0)
249        end if
250        call util_file_copy(smd_group_rtdb_world,
251     >                      smd_group_rtdb)
252        inquire(file=smd_group_rtdb,exist=result)
253        if(.not.result) then
254          call errquit("cannot find group rtdb"//
255     >                 smd_group_rtdb,
256     >                 0,0)
257        end if
258
259      end if
260
261      if(.not.rtdb_open(smd_group_rtdb,"old",rtdb))
262     + call errquit('Failed to open group rtdb',0, GEOM_ERR)
263
264      return
265      end
266
267      subroutine smd_group_rtdb_release(rtdb)
268      implicit none
269#include "errquit.fh"
270#include "inp.fh"
271#include "mafdecls.fh"
272#include "util.fh"
273#include "global.fh"
274#include "smd_group_data.fh"
275#include "rtdb.fh"
276      integer rtdb
277c
278      character*72 buffer
279      integer i1,i2
280      logical result
281c
282      if(.not.rtdb_close(rtdb, 'delete'))
283     + call errquit('Failed to close group rtdb',0, GEOM_ERR)
284c
285      smd_group_rtdb = " "
286
287
288      return
289      end
290
291      subroutine smd_group_rtdb_release1(rtdb)
292      implicit none
293#include "errquit.fh"
294#include "inp.fh"
295#include "mafdecls.fh"
296#include "util.fh"
297#include "global.fh"
298#include "smd_group_data.fh"
299#include "rtdb.fh"
300      integer rtdb
301c
302      character*255 buffer,buffer1
303      integer i1,i2
304      logical result
305
306      if(.not.rtdb_getfname(rtdb,buffer))
307     $  call errquit('rtdb_getfname', 0, RTDB_ERR)
308c
309c
310      if(ga_nodeid().eq.0) then
311        buffer1 = smd_group_rtdb
312        call util_file_name_resolve(buffer1,.false.)
313        call util_file_copy(buffer,buffer1)
314      end if
315
316c
317      if(.not.rtdb_close(rtdb, 'delete'))
318     + call errquit('Failed to close group rtdb',0, GEOM_ERR)
319c
320      smd_group_rtdb = " "
321
322
323      return
324      end
325
326      subroutine smd_group_inquire(rtdb,result)
327      implicit none
328#include "errquit.fh"
329#include "inp.fh"
330#include "mafdecls.fh"
331#include "rtdb.fh"
332#include "util.fh"
333#include "global.fh"
334c
335      logical util_sgstart
336      external util_sgstart
337c
338      integer rtdb
339      logical result
340c
341      integer ngroup
342
343      if (.not.rtdb_get(rtdb, 'subgroup_number', mt_int, 1,
344     &   ngroup)) ngroup = 1
345
346      result = ngroup.gt.1
347
348      end
349
350      subroutine smd_group_create_simple(group_want)
351      implicit none
352#include "global.fh"
353#include "mafdecls.fh"
354#include "errquit.fh"
355#include "smd_group_data.fh"
356c
357c     Create subgroup of a constant size
358c
359      integer group_want
360      integer nproc,myproc,nchunkq,nremainq,i,j,n
361      integer num_proc
362      integer i_l,nl,h_l
363
364      character*30 pname
365c
366      pname = "smd_group_create_simple"
367c
368      smd_ngroup = group_want
369c
370      nproc = ga_nnodes()
371      myproc = ga_nodeid()
372
373      nchunkq=nproc/smd_ngroup
374      nremainq=mod(nproc,smd_ngroup)
375
376      nl = nchunkq+nremainq
377      if(.not.ma_push_get(mt_int,nl,'proclist',h_l,i_l))
378     + call errquit(pname//'Failed to allocate memory for i_l',
379     + nl, MA_ERR)
380
381      call ifill(nl,-1,int_mb(i_l),1)
382
383      n = 0
384      do i=1,smd_ngroup
385         num_proc = nchunkq
386         if(i .le. nremainq) num_proc = num_proc + 1
387         do j=1,num_proc
388            int_mb(i_l+j-1)=n
389            if (n .eq. myproc) smd_group_id = i
390            n=n+1
391         enddo
392         if (smd_group_id .eq. i) then
393            smd_group_handle = ga_pgroup_create(int_mb(i_l), num_proc)
394            smd_group_nproc = num_proc
395         endif
396      enddo
397
398c set the group
399
400      call ga_pgroup_set_default(smd_group_handle)
401
402      return
403      end
404
405      subroutine smd_group_ngroup_get(ngroup)
406      implicit none
407#include "smd_group_data.fh"
408      integer  ngroup
409      ngroup = smd_ngroup
410      return
411      end
412
413      subroutine smd_group_id_get(group_id)
414      implicit none
415#include "smd_group_data.fh"
416      integer  group_id
417      group_id = smd_group_id
418      return
419      end
420
421      subroutine smd_group_nproc_get(group_nproc)
422      implicit none
423#include "smd_group_data.fh"
424      integer  group_nproc
425      group_nproc = smd_group_nproc
426      return
427      end
428
429
430c $Id$
431