1* 2* $Id$ 3* 4 5* *********************************** 6* * * 7* * Balance_Init * 8* * * 9* *********************************** 10 11 subroutine Balance_Init(maxsize0,nidb,nidb_out) 12 implicit none 13 integer maxsize0 14 integer nidb(0:maxsize0-1) 15 integer nidb_out(0:maxsize0-1) 16 17#include "bafdecls.fh" 18#include "balance_common.fh" 19#include "errquit.fh" 20 21* **** local variables **** 22 logical value 23 integer nb,np,taskid 24 integer nwave,nwave_out 25 integer dum(2) 26 27 28 maxsize = maxsize0 29 call Parallel2d_np_i(np) 30 call Parallel2d_taskid_i(taskid) 31 32* **** allocate balance memory **** 33 value = BA_alloc_get(mt_int,2*maxsize, 34 > 'psizea_list', 35 > packet_size_list(2), 36 > packet_size_list(1)) 37 value = value.and. 38 > BA_alloc_get(mt_int,2*maxsize, 39 > 'indxsa_list', 40 > indx_start_list(2), 41 > indx_start_list(1)) 42 value = value.and. 43 > BA_alloc_get(mt_int,2*maxsize, 44 > 'prctoa_list', 45 > proc_to_list(2), 46 > proc_to_list(1)) 47 value = value.and. 48 > BA_alloc_get(mt_int,2*maxsize, 49 > 'prcfra_list', 50 > proc_from_list(2), 51 > proc_from_list(1)) 52 53 value = value.and. 54 > BA_alloc_get(mt_int,maxsize, 55 > 'npacket_list', 56 > npacket_list(2), 57 > npacket_list(1)) 58 value = value.and. 59 > BA_alloc_get(mt_log,maxsize, 60 > 'receiver_list', 61 > receiver_list(2), 62 > receiver_list(1)) 63 value = value.and. 64 > BA_alloc_get(mt_log,maxsize, 65 > 'sender_list', 66 > sender_list(2), 67 > sender_list(1)) 68 69 do nb=0,maxsize-1 70 71* **** allocate balance memory **** 72 value = value.and. 73 > BA_alloc_get(mt_int,np, 74 > 'psizea',dum(2),dum(1)) 75 int_mb(packet_size_list(1)+2*nb ) = dum(1) 76 int_mb(packet_size_list(1)+2*nb+1) = dum(2) 77 78 value = value.and. 79 > BA_alloc_get(mt_int,np, 80 > 'indxsa',dum(2),dum(1)) 81 int_mb(indx_start_list(1)+2*nb ) = dum(1) 82 int_mb(indx_start_list(1)+2*nb+1) = dum(2) 83 84 value = value.and. 85 > BA_alloc_get(mt_int,np, 86 > 'prctoa',dum(2),dum(1)) 87 int_mb(proc_to_list(1)+2*nb ) = dum(1) 88 int_mb(proc_to_list(1)+2*nb+1) = dum(2) 89 90 value = value.and. 91 > BA_alloc_get(mt_int,np, 92 > 'prcfra',dum(2),dum(1)) 93 int_mb(proc_from_list(1)+2*nb ) = dum(1) 94 int_mb(proc_from_list(1)+2*nb+1) = dum(2) 95 96 end do 97 98 if (.not. value) 99 > call errquit('Balance_init: out of heap memory',0, MA_ERR) 100 101 102 103 do nb=0,maxsize-1 104 nwave = nidb(nb) 105 call Balance_Init_a(nwave,np,taskid,nwave_out, 106 > int_mb(npacket_list(1) +nb), 107 > log_mb(receiver_list(1)+nb), 108 > log_mb(sender_list(1) +nb), 109 > int_mb(int_mb(proc_to_list(1) +2*nb)), 110 > int_mb(int_mb(proc_from_list(1) +2*nb)), 111 > int_mb(int_mb(packet_size_list(1)+2*nb)), 112 > int_mb(int_mb(indx_start_list(1) +2*nb))) 113 114 nidb_out(nb) = nidb(nb) + (nwave_out-nwave) 115 end do 116 117 return 118 end 119 120 121* *********************************** 122* * * 123* * Balance_End * 124* * * 125* *********************************** 126 127 subroutine Balance_End() 128 implicit none 129 130#include "bafdecls.fh" 131#include "balance_common.fh" 132#include "errquit.fh" 133 134 135* **** local variables **** 136 logical value 137 integer nb,dum2 138 139 value = .true. 140 do nb=0,maxsize-1 141 142 dum2 = int_mb(packet_size_list(1)+2*nb+1) 143 value = value.and.BA_free_heap(dum2) 144 145 dum2 = int_mb(indx_start_list(1)+2*nb+1) 146 value = value.and.BA_free_heap(dum2) 147 148 dum2 = int_mb(proc_to_list(1)+2*nb+1) 149 value = value.and.BA_free_heap(dum2) 150 151 dum2 = int_mb(proc_from_list(1)+2*nb+1) 152 value = value.and.BA_free_heap(dum2) 153 154 end do 155 156 value = value.and.BA_free_heap(packet_size_list(2)) 157 value = value.and.BA_free_heap(indx_start_list(2)) 158 value = value.and.BA_free_heap(proc_to_list(2)) 159 value = value.and.BA_free_heap(proc_from_list(2)) 160 161 value = value.and.BA_free_heap(npacket_list(2)) 162 value = value.and.BA_free_heap(receiver_list(2)) 163 value = value.and.BA_free_heap(sender_list(2)) 164 if (.not. value) 165 > call errquit('Balance_end: error freeing heap memory',0, MA_ERR) 166 167 return 168 end 169 170* *********************************** 171* * * 172* * Balance_Init_a * 173* * * 174* *********************************** 175* This routine defines the balance data structure 176 177 subroutine Balance_Init_a(nwave,np,taskid, 178 > nwave_out, 179 > npacket,receiver,sender, 180 > proc_to,proc_from, 181 > packet_size,indx_start) 182 implicit none 183 integer nwave,np,taskid 184 integer nwave_out 185 186 integer npacket 187 logical receiver,sender 188 integer proc_to(*),proc_from(*) 189 integer packet_size(*) 190 integer indx_start(*) 191 192#include "bafdecls.fh" 193#include "errquit.fh" 194 195* ***** local variables **** 196 logical done,value 197 integer i,j 198 integer ave,short,long 199 integer above,below 200 201c integer nwave2(0:(np-1)) 202c integer indx(0:(np-1)) 203 integer nwave2(2),indx(2) 204 205* **** allocate nwave2 and indx off the stack **** 206 value = BA_push_get(mt_int,(np), 207 > 'nwave2',nwave2(2),nwave2(1)) 208 value = value.and. 209 > BA_push_get(mt_int,(np), 210 > 'indx',indx(2),indx(1)) 211 if (.not. value) 212 > call errquit('Balance_init_a:out of stack memory',0, MA_ERR) 213 214* **** define nwave2 **** 215 do i=0,np-1 216c nwave2(i) = 0 217 int_mb(nwave2(1)+i) = 0 218 end do 219c nwave2(taskid) = nwave 220 int_mb(nwave2(1)+taskid) = nwave 221c call D3dB_Vector_ISumAll(np,nwave2) 222 call D3dB_Vector_ISumAll(np,int_mb(nwave2(1))) 223 224* **** get the sorting index **** 225c call nwave2_sort(np,nwave2,indx) 226 call nwave2_sort(np,int_mb(nwave2(1)),int_mb(indx(1))) 227 228* ***** get the average **** 229 ave = 0 230 do i=0,np-1 231c ave = ave + nwave2(i) 232 ave = ave + int_mb(nwave2(1)+i) 233 end do 234 ave = ave/np 235 236* ***** get below *** 237 below = -1 238 do while (int_mb(nwave2(1) + int_mb(indx(1)+below+1)).lt.ave) 239 below = below + 1 240 end do 241 242* ***** get above *** 243 above = np 244 do while (int_mb(nwave2(1) + int_mb(indx(1)+above-1)).gt.ave) 245 above = above - 1 246 end do 247 248 249 npacket = 0 250 receiver = .false. 251 sender = .false. 252 253 if (np.gt.1) then 254 i = 0 255 j = np-1 256 done = .false. 257 if (i .gt. below) done = .true. 258 if (j .lt. above) done = .true. 259 do while (.not. done) 260 short = ave - int_mb(nwave2(1)+int_mb(indx(1)+i)) 261 long = int_mb(nwave2(1)+int_mb(indx(1)+j)) - ave 262 263 if (taskid.eq.int_mb(indx(1)+i)) then 264 npacket = npacket + 1 265 proc_from(npacket) = int_mb(indx(1)+j) 266 receiver = .true. 267 end if 268 269 if (taskid.eq.int_mb(indx(1)+j)) then 270 npacket = npacket + 1 271 proc_to(npacket) = int_mb(indx(1)+i) 272 sender = .true. 273 end if 274 275 276 if (short.eq.long) then 277 278 if (taskid.eq.int_mb(indx(1)+i)) then 279 packet_size(npacket) = short 280 indx_start(npacket) = 281 > int_mb(nwave2(1)+int_mb(indx(1)+i)) + 1 282 end if 283 284 if (taskid.eq.int_mb(indx(1)+j)) then 285 packet_size(npacket) = long 286 indx_start(npacket) = 287 > int_mb(nwave2(1)+int_mb(indx(1)+j)) - long + 1 288 end if 289 290 int_mb(nwave2(1)+int_mb(indx(1)+i)) = 291 > int_mb(nwave2(1)+int_mb(indx(1)+i)) + short 292 int_mb(nwave2(1)+int_mb(indx(1)+j)) = 293 > int_mb(nwave2(1)+int_mb(indx(1)+j)) - long 294 i = i + 1 295 j = j - 1 296 297 298 else if (short.lt.long) then 299 300 if (taskid.eq.int_mb(indx(1)+i)) then 301 packet_size(npacket) = short 302 indx_start(npacket) = 303 > int_mb(nwave2(1)+int_mb(indx(1)+i)) + 1 304 end if 305 306 if (taskid.eq.int_mb(indx(1)+j)) then 307 packet_size(npacket) = short 308 indx_start(npacket) = 309 > int_mb(nwave2(1)+int_mb(indx(1)+j)) - short + 1 310 end if 311 312 int_mb(nwave2(1)+int_mb(indx(1)+i)) = 313 > int_mb(nwave2(1)+int_mb(indx(1)+i)) + short 314 int_mb(nwave2(1)+int_mb(indx(1)+j)) = 315 > int_mb(nwave2(1)+int_mb(indx(1)+j)) - short 316 i = i + 1 317 318 319 else if (short.gt.long) then 320 if (taskid.eq.int_mb(indx(1)+i)) then 321 packet_size(npacket) = long 322 indx_start(npacket) = 323 > int_mb(nwave2(1)+int_mb(indx(1)+i)) + 1 324 end if 325 326 if (taskid.eq.int_mb(indx(1)+j)) then 327 packet_size(npacket) = long 328 indx_start(npacket) = 329 > int_mb(nwave2(1)+int_mb(indx(1)+j)) - long + 1 330 end if 331 332 int_mb(nwave2(1)+int_mb(indx(1)+i)) = 333 > int_mb(nwave2(1)+int_mb(indx(1)+i)) + long 334 int_mb(nwave2(1)+int_mb(indx(1)+j)) = 335 > int_mb(nwave2(1)+int_mb(indx(1)+j)) - long 336 j = j - 1 337 338 end if 339 340 if (i .gt. below) done = .true. 341 if (j .lt. above) done = .true. 342 343 end do 344 345 end if 346 347 nwave_out = int_mb(nwave2(1)+taskid) 348 349 value = BA_pop_stack(indx(2)) 350 value = value.and.BA_pop_stack(nwave2(2)) 351 if (.not. value) 352 > call errquit('Balance_init_a:error freeing stack memory',0, 353 & MA_ERR) 354 355 356 return 357 end 358 359 subroutine nwave2_sort(n,f,indx) 360 integer n 361 integer f(0:(n-1)) 362 integer indx(0:(n-1)) 363 364 integer i,j,idum 365 do i=0,n-1 366 indx(i) = i 367 end do 368 do i=0,(n-2) 369 do j=i+1,(n-1) 370 if (f(indx(j)).lt.f(indx(i))) then 371 idum = indx(i) 372 indx(i) = indx(j) 373 indx(j) = idum 374 end if 375 end do 376 end do 377 378 return 379 end 380 381* ************************************ 382* * * 383* * Balance_c_balance * 384* * * 385* ************************************ 386c!!!!!!!! Needs to be changed to MPI !!!!!!!!!!!!!!!! 387 388 subroutine Balance_c_balance(nb,A) 389 implicit none 390 integer nb 391 complex*16 A(*) 392 393#include "bafdecls.fh" 394#include "tcgmsg.fh" 395#include "msgtypesf.h" 396#include "balance_common.fh" 397 398* **** local variables **** 399 integer rcv_len,rcv_proc 400 integer j 401 integer pto,pfrom,msglen,indx 402 403* **** external functions **** 404 integer Parallel2d_convert_taskid_i 405 external Parallel2d_convert_taskid_i 406 407!$OMP MASTER 408 if (log_mb(sender_list(1)+nb)) then 409 do j=1,int_mb(npacket_list(1)+nb) 410 pto = int_mb(int_mb(proc_to_list(1) +2*nb)+j-1) 411 msglen = int_mb(int_mb(packet_size_list(1)+2*nb)+j-1) 412 indx = int_mb(int_mb(indx_start_list(1) +2*nb)+j-1) 413c send data.... 414 if (msglen.gt.0) then 415 call SND(9+MSGDBL, 416 > A(indx), 417 > mdtob(2*msglen), 418 > Parallel2d_convert_taskid_i(pto), 419 > 1) 420 end if 421 422 423 end do 424 end if 425 426 if (log_mb(receiver_list(1)+nb)) then 427 do j=1,int_mb(npacket_list(1)+nb) 428 pfrom = int_mb(int_mb(proc_from_list(1) +2*nb)+j-1) 429 msglen = int_mb(int_mb(packet_size_list(1)+2*nb)+j-1) 430 indx = int_mb(int_mb(indx_start_list(1) +2*nb)+j-1) 431c recieve data.... 432 if (msglen.gt.0) then 433 call RCV(9+MSGDBL, 434 > A(indx), 435 > mdtob(2*msglen),rcv_len, 436 > Parallel2d_convert_taskid_i(pfrom), 437 > rcv_proc,1) 438 end if 439 440 end do 441 end if 442!$OMP END MASTER 443!$OMP BARRIER 444 445 return 446 end 447 448* ************************************ 449* * * 450* * Balances_c_balance * 451* * * 452* ************************************ 453c!!!!!!!! Needs to be changed to MPI !!!!!!!!!!!!!!!! 454 455 subroutine Balances_c_balance(nb,A) 456 implicit none 457 integer nb 458 complex A(*) 459 460#include "bafdecls.fh" 461#include "tcgmsg.fh" 462#include "msgtypesf.h" 463#include "balance_common.fh" 464 465* **** local variables **** 466 integer rcv_len,rcv_proc 467 integer j 468 integer pto,pfrom,msglen,indx 469 470* **** external functions **** 471 integer Parallel2d_convert_taskid_i 472 external Parallel2d_convert_taskid_i 473 474!$OMP MASTER 475 if (log_mb(sender_list(1)+nb)) then 476 do j=1,int_mb(npacket_list(1)+nb) 477 pto = int_mb(int_mb(proc_to_list(1) +2*nb)+j-1) 478 msglen = int_mb(int_mb(packet_size_list(1)+2*nb)+j-1) 479 indx = int_mb(int_mb(indx_start_list(1) +2*nb)+j-1) 480c send data.... 481 if (msglen.gt.0) then 482 call SND(9+MSGDBL, 483 > A(indx), 484 > mdtob(msglen), 485 > Parallel2d_convert_taskid_i(pto), 486 > 1) 487 end if 488 489 490 end do 491 end if 492 493 if (log_mb(receiver_list(1)+nb)) then 494 do j=1,int_mb(npacket_list(1)+nb) 495 pfrom = int_mb(int_mb(proc_from_list(1) +2*nb)+j-1) 496 msglen = int_mb(int_mb(packet_size_list(1)+2*nb)+j-1) 497 indx = int_mb(int_mb(indx_start_list(1) +2*nb)+j-1) 498c recieve data.... 499 if (msglen.gt.0) then 500 call RCV(9+MSGDBL, 501 > A(indx), 502 > mdtob(msglen),rcv_len, 503 > Parallel2d_convert_taskid_i(pfrom), 504 > rcv_proc,1) 505 end if 506 507 end do 508 end if 509!$OMP END MASTER 510!$OMP BARRIER 511 512 return 513 end 514 515 516 517 518 519* ************************************ 520* * * 521* * Balance_t_balance * 522* * * 523* ************************************ 524c!!!!!!!! Needs to be changed to MPI !!!!!!!!!!!!!!!! 525 526 subroutine Balance_t_balance(nb,A) 527 implicit none 528 integer nb 529 real*8 A(*) 530 531#include "bafdecls.fh" 532#include "tcgmsg.fh" 533#include "msgtypesf.h" 534#include "balance_common.fh" 535 536* **** local variables **** 537 integer rcv_len,rcv_proc 538 integer j 539 integer pto,pfrom,msglen,indx 540 541* **** external functions **** 542 integer Parallel2d_convert_taskid_i 543 external Parallel2d_convert_taskid_i 544 545!$OMP MASTER 546 if (log_mb(sender_list(1)+nb)) then 547 do j=1,int_mb(npacket_list(1)+nb) 548 pto = int_mb(int_mb(proc_to_list(1) +2*nb)+j-1) 549 msglen = int_mb(int_mb(packet_size_list(1)+2*nb)+j-1) 550 indx = int_mb(int_mb(indx_start_list(1) +2*nb)+j-1) 551c send data.... 552 if (msglen.gt.0) then 553 call SND(9+MSGDBL, 554 > A(indx), 555 > mdtob(msglen), 556 > Parallel2d_convert_taskid_i(pto), 557 > 1) 558 end if 559 560 561 end do 562 end if 563 564 if (log_mb(receiver_list(1)+nb)) then 565 do j=1,int_mb(npacket_list(1)+nb) 566 pfrom = int_mb(int_mb(proc_from_list(1) +2*nb)+j-1) 567 msglen = int_mb(int_mb(packet_size_list(1)+2*nb)+j-1) 568 indx = int_mb(int_mb(indx_start_list(1) +2*nb)+j-1) 569c recieve data.... 570 if (msglen.gt.0) then 571 call RCV(9+MSGDBL, 572 > A(indx), 573 > mdtob(msglen),rcv_len, 574 > Parallel2d_convert_taskid_i(pfrom), 575 > rcv_proc,1) 576 end if 577 578 579 end do 580 end if 581!$OMP END MASTER 582!$OMP BARRIER 583 584 return 585 end 586 587 588* ************************************ 589* * * 590* * Balances_t_balance * 591* * * 592* ************************************ 593c!!!!!!!! Needs to be changed to MPI !!!!!!!!!!!!!!!! 594 595 subroutine Balances_t_balance(nb,A) 596 implicit none 597 integer nb 598 real A(*) 599 600#include "bafdecls.fh" 601#include "tcgmsg.fh" 602#include "msgtypesf.h" 603#include "balance_common.fh" 604 605* **** local variables **** 606 integer rcv_len,rcv_proc 607 integer j 608 integer pto,pfrom,msglen,indx 609 610* **** external functions **** 611 integer Parallel2d_convert_taskid_i 612 external Parallel2d_convert_taskid_i 613 614!$OMP MASTER 615 if (log_mb(sender_list(1)+nb)) then 616 do j=1,int_mb(npacket_list(1)+nb) 617 pto = int_mb(int_mb(proc_to_list(1) +2*nb)+j-1) 618 msglen = int_mb(int_mb(packet_size_list(1)+2*nb)+j-1) 619 indx = int_mb(int_mb(indx_start_list(1) +2*nb)+j-1) 620c send data.... 621 if (msglen.gt.0) then 622 call SND(9+MSGDBL, 623 > A(indx), 624 > mdtob(msglen)/2, 625 > Parallel2d_convert_taskid_i(pto), 626 > 1) 627 end if 628 629 630 end do 631 end if 632 633 if (log_mb(receiver_list(1)+nb)) then 634 do j=1,int_mb(npacket_list(1)+nb) 635 pfrom = int_mb(int_mb(proc_from_list(1) +2*nb)+j-1) 636 msglen = int_mb(int_mb(packet_size_list(1)+2*nb)+j-1) 637 indx = int_mb(int_mb(indx_start_list(1) +2*nb)+j-1) 638c recieve data.... 639 if (msglen.gt.0) then 640 call RCV(9+MSGDBL, 641 > A(indx), 642 > mdtob(msglen)/2,rcv_len, 643 > Parallel2d_convert_taskid_i(pfrom), 644 > rcv_proc,1) 645 end if 646 647 648 end do 649 end if 650!$OMP END MASTER 651!$OMP BARRIER 652 653 return 654 end 655 656 657 658 659 660* ************************************ 661* * * 662* * Balance_c_unbalance * 663* * * 664* ************************************ 665c!!!!!!!! Needs to be changed to MPI !!!!!!!!!!!!!!!! 666 667 subroutine Balance_c_unbalance(nb,A) 668 implicit none 669 integer nb 670 complex*16 A(*) 671 672#include "bafdecls.fh" 673#include "tcgmsg.fh" 674#include "msgtypesf.h" 675#include "balance_common.fh" 676 677* **** local variables **** 678 integer rcv_len,rcv_proc 679 integer j 680 integer pto,pfrom,msglen,indx 681 682* **** external functions **** 683 integer Parallel2d_convert_taskid_i 684 external Parallel2d_convert_taskid_i 685 686!$OMP MASTER 687 if (log_mb(sender_list(1)+nb)) then 688 do j=1,int_mb(npacket_list(1)+nb) 689 pfrom = int_mb(int_mb(proc_to_list(1) +2*nb)+j-1) 690 msglen = int_mb(int_mb(packet_size_list(1)+2*nb)+j-1) 691 indx = int_mb(int_mb(indx_start_list(1) +2*nb)+j-1) 692c recieve data.... 693 if (msglen.gt.0) then 694 call RCV(9+MSGDBL, 695 > A(indx), 696 > mdtob(2*msglen),rcv_len, 697 > Parallel2d_convert_taskid_i(pfrom), 698 > rcv_proc,1) 699 end if 700 701 end do 702 end if 703 704 if (log_mb(receiver_list(1)+nb)) then 705 do j=1,int_mb(npacket_list(1)+nb) 706 pto = int_mb(int_mb(proc_from_list(1) +2*nb)+j-1) 707 msglen = int_mb(int_mb(packet_size_list(1)+2*nb)+j-1) 708 indx = int_mb(int_mb(indx_start_list(1) +2*nb)+j-1) 709c send data.... 710 if (msglen.gt.0) then 711 call SND(9+MSGDBL, 712 > A(indx), 713 > mdtob(2*msglen), 714 > Parallel2d_convert_taskid_i(pto),1) 715 end if 716 717 end do 718 end if 719!$OMP END MASTER 720!$OMP BARRIER 721 722 return 723 end 724 725* ************************************ 726* * * 727* * Balances_c_unbalance * 728* * * 729* ************************************ 730c!!!!!!!! Needs to be changed to MPI !!!!!!!!!!!!!!!! 731 732 subroutine Balances_c_unbalance(nb,A) 733 implicit none 734 integer nb 735 complex A(*) 736 737#include "bafdecls.fh" 738#include "tcgmsg.fh" 739#include "msgtypesf.h" 740#include "balance_common.fh" 741 742* **** local variables **** 743 integer rcv_len,rcv_proc 744 integer j 745 integer pto,pfrom,msglen,indx 746 747* **** external functions **** 748 integer Parallel2d_convert_taskid_i 749 external Parallel2d_convert_taskid_i 750 751!$OMP MASTER 752 if (log_mb(sender_list(1)+nb)) then 753 do j=1,int_mb(npacket_list(1)+nb) 754 pfrom = int_mb(int_mb(proc_to_list(1) +2*nb)+j-1) 755 msglen = int_mb(int_mb(packet_size_list(1)+2*nb)+j-1) 756 indx = int_mb(int_mb(indx_start_list(1) +2*nb)+j-1) 757c recieve data.... 758 if (msglen.gt.0) then 759 call RCV(9+MSGDBL, 760 > A(indx), 761 > mdtob(msglen),rcv_len, 762 > Parallel2d_convert_taskid_i(pfrom), 763 > rcv_proc,1) 764 end if 765 766 end do 767 end if 768 769 if (log_mb(receiver_list(1)+nb)) then 770 do j=1,int_mb(npacket_list(1)+nb) 771 pto = int_mb(int_mb(proc_from_list(1) +2*nb)+j-1) 772 msglen = int_mb(int_mb(packet_size_list(1)+2*nb)+j-1) 773 indx = int_mb(int_mb(indx_start_list(1) +2*nb)+j-1) 774c send data.... 775 if (msglen.gt.0) then 776 call SND(9+MSGDBL, 777 > A(indx), 778 > mdtob(msglen), 779 > Parallel2d_convert_taskid_i(pto),1) 780 end if 781 782 end do 783 end if 784!$OMP END MASTER 785!$OMP BARRIER 786 787 return 788 end 789 790 791* ************************************ 792* * * 793* * Balance_i_balance * 794* * * 795* ************************************ 796c!!!!!!!! Needs to be changed to MPI !!!!!!!!!!!!!!!! 797 798 subroutine Balance_i_balance(nb,A) 799 implicit none 800 integer nb 801 integer A(*) 802 803#include "bafdecls.fh" 804#include "tcgmsg.fh" 805#include "msgtypesf.h" 806#include "balance_common.fh" 807 808* **** local variables **** 809 integer rcv_len,rcv_proc 810 integer j 811 integer pto,pfrom,msglen,indx 812 813* **** external functions **** 814 integer Parallel2d_convert_taskid_i 815 external Parallel2d_convert_taskid_i 816 817 if (log_mb(sender_list(1)+nb)) then 818 do j=1,int_mb(npacket_list(1)+nb) 819 pto = int_mb(int_mb(proc_to_list(1) +2*nb)+j-1) 820 msglen = int_mb(int_mb(packet_size_list(1)+2*nb)+j-1) 821 indx = int_mb(int_mb(indx_start_list(1) +2*nb)+j-1) 822c send data.... 823 if (msglen.gt.0) then 824 call SND(9+MSGINT, 825 > A(indx), 826 > mitob(msglen), 827 > Parallel2d_convert_taskid_i(pto),1) 828 end if 829 830 831 end do 832 end if 833 834 if (log_mb(receiver_list(1)+nb)) then 835 do j=1,int_mb(npacket_list(1)+nb) 836 pfrom = int_mb(int_mb(proc_from_list(1) +2*nb)+j-1) 837 msglen = int_mb(int_mb(packet_size_list(1)+2*nb)+j-1) 838 indx = int_mb(int_mb(indx_start_list(1) +2*nb)+j-1) 839c recieve data.... 840 if (msglen.gt.0) then 841 call RCV(9+MSGINT, 842 > A(indx), 843 > mitob(msglen),rcv_len, 844 > Parallel2d_convert_taskid_i(pfrom), 845 > rcv_proc,1) 846 end if 847 848 end do 849 end if 850 851 return 852 end 853 854