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