- Timestamp:
- 2016-01-08T10:35:19+01:00 (8 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2014/dev_r4704_NOC5_MPP_BDY_UPDATE/NEMOGCM/NEMO/OPA_SRC/ICB/icblbc.F90
- Property svn:keywords set to Id
r3614 r6225 67 67 !!---------------------------------------------------------------------- 68 68 !! NEMO/OPA 3.3 , NEMO Consortium (2011) 69 !! $Id :$69 !! $Id$ 70 70 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 71 71 !!---------------------------------------------------------------------- … … 280 280 zwebergs(1) = ibergs_to_send_e 281 281 CALL mppsend( 12, zwebergs(1), 1, ipe_E, iml_req1) 282 CALL mpprecv( 11, zewbergs(2), 1 )282 CALL mpprecv( 11, zewbergs(2), 1, ipe_E ) 283 283 IF( l_isend ) CALL mpi_wait( iml_req1, iml_stat, iml_err ) 284 284 ibergs_rcvd_from_e = INT( zewbergs(2) ) … … 288 288 CALL mppsend( 11, zewbergs(1), 1, ipe_W, iml_req2) 289 289 CALL mppsend( 12, zwebergs(1), 1, ipe_E, iml_req3) 290 CALL mpprecv( 11, zewbergs(2), 1 )291 CALL mpprecv( 12, zwebergs(2), 1 )290 CALL mpprecv( 11, zewbergs(2), 1, ipe_E ) 291 CALL mpprecv( 12, zwebergs(2), 1, ipe_W ) 292 292 IF( l_isend ) CALL mpi_wait( iml_req2, iml_stat, iml_err ) 293 293 IF( l_isend ) CALL mpi_wait( iml_req3, iml_stat, iml_err ) … … 297 297 zewbergs(1) = ibergs_to_send_w 298 298 CALL mppsend( 11, zewbergs(1), 1, ipe_W, iml_req4) 299 CALL mpprecv( 12, zwebergs(2), 1 )299 CALL mpprecv( 12, zwebergs(2), 1, ipe_W ) 300 300 IF( l_isend ) CALL mpi_wait( iml_req4, iml_stat, iml_err ) 301 301 ibergs_rcvd_from_w = INT( zwebergs(2) ) … … 411 411 zsnbergs(1) = ibergs_to_send_n 412 412 CALL mppsend( 16, zsnbergs(1), 1, ipe_N, iml_req1) 413 CALL mpprecv( 15, znsbergs(2), 1 )413 CALL mpprecv( 15, znsbergs(2), 1, ipe_N ) 414 414 IF( l_isend ) CALL mpi_wait( iml_req1, iml_stat, iml_err ) 415 415 ibergs_rcvd_from_n = INT( znsbergs(2) ) … … 419 419 CALL mppsend( 15, znsbergs(1), 1, ipe_S, iml_req2) 420 420 CALL mppsend( 16, zsnbergs(1), 1, ipe_N, iml_req3) 421 CALL mpprecv( 15, znsbergs(2), 1 )422 CALL mpprecv( 16, zsnbergs(2), 1 )421 CALL mpprecv( 15, znsbergs(2), 1, ipe_N ) 422 CALL mpprecv( 16, zsnbergs(2), 1, ipe_S ) 423 423 IF( l_isend ) CALL mpi_wait( iml_req2, iml_stat, iml_err ) 424 424 IF( l_isend ) CALL mpi_wait( iml_req3, iml_stat, iml_err ) … … 428 428 znsbergs(1) = ibergs_to_send_s 429 429 CALL mppsend( 15, znsbergs(1), 1, ipe_S, iml_req4) 430 CALL mpprecv( 16, zsnbergs(2), 1 )430 CALL mpprecv( 16, zsnbergs(2), 1, ipe_S ) 431 431 IF( l_isend ) CALL mpi_wait( iml_req4, iml_stat, iml_err ) 432 432 ibergs_rcvd_from_s = INT( zsnbergs(2) ) … … 581 581 INTEGER :: ifldproc, iproc, ipts 582 582 INTEGER :: iine, ijne 583 REAL(wp), DIMENSION(2) :: zsbergs, znbergs 583 INTEGER :: jjn 584 REAL(wp), DIMENSION(0:3) :: zsbergs, znbergs 584 585 INTEGER :: iml_req1, iml_req2, iml_err 585 586 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: iml_stat … … 591 592 ! its of fixed size, the first -1 marks end of list of processors 592 593 ! 594 nicbfldnsend(:) = 0 595 nicbfldexpect(:) = 0 596 nicbfldreq(:) = 0 597 ! 598 ! Since each processor may be communicating with more than one northern 599 ! neighbour, cycle through the sends so that the receive order can be 600 ! controlled. 601 ! 602 ! First compute how many icebergs each active neighbour should expect 603 DO jn = 1, jpni 604 IF( nicbfldproc(jn) /= -1 ) THEN 605 ifldproc = nicbfldproc(jn) 606 nicbfldnsend(jn) = 0 607 608 ! Find number of bergs that need to be exchanged 609 ! Pick out exchanges with processor ifldproc 610 ! if ifldproc is this processor then don't send 611 ! 612 IF( ASSOCIATED(first_berg) ) THEN 613 this => first_berg 614 DO WHILE (ASSOCIATED(this)) 615 pt => this%current_point 616 iine = INT( pt%xi + 0.5 ) 617 ijne = INT( pt%yj + 0.5 ) 618 iproc = nicbflddest(mi1(iine)) 619 IF( ijne .GT. mjg(nicbej) ) THEN 620 IF( iproc == ifldproc ) THEN 621 ! 622 IF( iproc /= narea ) THEN 623 tmpberg => this 624 nicbfldnsend(jn) = nicbfldnsend(jn) + 1 625 ENDIF 626 ! 627 ENDIF 628 ENDIF 629 this => this%next 630 END DO 631 ENDIF 632 ! 633 ENDIF 634 ! 635 END DO 636 ! 637 ! Now tell each active neighbour how many icebergs to expect 638 DO jn = 1, jpni 639 IF( nicbfldproc(jn) /= -1 ) THEN 640 ifldproc = nicbfldproc(jn) 641 IF( ifldproc == narea ) CYCLE 642 643 zsbergs(0) = narea 644 zsbergs(1) = nicbfldnsend(jn) 645 !IF ( nicbfldnsend(jn) .GT. 0) write(numicb,*) 'ICB sending ',nicbfldnsend(jn),' to ', ifldproc 646 CALL mppsend( 21, zsbergs(0:1), 2, ifldproc-1, nicbfldreq(jn)) 647 ENDIF 648 ! 649 END DO 650 ! 651 ! and receive the heads-up from active neighbours preparing to send 652 DO jn = 1, jpni 653 IF( nicbfldproc(jn) /= -1 ) THEN 654 ifldproc = nicbfldproc(jn) 655 IF( ifldproc == narea ) CYCLE 656 657 CALL mpprecv( 21, znbergs(1:2), 2 ) 658 DO jjn = 1,jpni 659 IF( nicbfldproc(jjn) .eq. INT(znbergs(1)) ) EXIT 660 END DO 661 IF( jjn .GT. jpni ) write(numicb,*) 'ICB ERROR' 662 nicbfldexpect(jjn) = INT( znbergs(2) ) 663 !IF ( nicbfldexpect(jjn) .GT. 0) write(numicb,*) 'ICB expecting ',nicbfldexpect(jjn),' from ', nicbfldproc(jjn) 664 !CALL FLUSH(numicb) 665 ENDIF 666 ! 667 END DO 668 ! 669 ! post the mpi waits if using immediate send protocol 670 DO jn = 1, jpni 671 IF( nicbfldproc(jn) /= -1 ) THEN 672 ifldproc = nicbfldproc(jn) 673 IF( ifldproc == narea ) CYCLE 674 675 IF( l_isend ) CALL mpi_wait( nicbfldreq(jn), iml_stat, iml_err ) 676 ENDIF 677 ! 678 END DO 679 680 ! 681 ! Cycle through the icebergs again, this time packing and sending any 682 ! going through the north fold. They will be expected. 593 683 DO jn = 1, jpni 594 684 IF( nicbfldproc(jn) /= -1 ) THEN … … 646 736 IF( ifldproc == narea ) CYCLE 647 737 648 zsbergs(1) = ibergs_to_send649 CALL mppsend( 21, zsbergs(1), 1, ifldproc-1, iml_req1)650 CALL mpprecv( 21, znbergs(2), 1 )651 IF( l_isend ) CALL mpi_wait( iml_req1, iml_stat, iml_err )652 ibergs_to_rcv = INT( znbergs(2) )653 654 738 ! send bergs 655 739 656 740 IF( ibergs_to_send > 0 ) & 657 CALL mppsend( 12, obuffer_f%data, ibergs_to_send*jp_buffer_width, ifldproc-1, iml_req2 ) 741 CALL mppsend( 12, obuffer_f%data, ibergs_to_send*jp_buffer_width, ifldproc-1, nicbfldreq(jn) ) 742 ! 743 ENDIF 744 ! 745 END DO 746 ! 747 ! Now receive the expected number of bergs from the active neighbours 748 DO jn = 1, jpni 749 IF( nicbfldproc(jn) /= -1 ) THEN 750 ifldproc = nicbfldproc(jn) 751 IF( ifldproc == narea ) CYCLE 752 ibergs_to_rcv = nicbfldexpect(jn) 753 658 754 IF( ibergs_to_rcv > 0 ) THEN 659 755 CALL icb_increase_ibuffer(ibuffer_f, ibergs_to_rcv) 660 CALL mpprecv( 12, ibuffer_f%data, ibergs_to_rcv*jp_buffer_width )661 ENDIF 662 IF( ibergs_to_send > 0 .AND. l_isend ) CALL mpi_wait( iml_req2, iml_stat, iml_err )756 CALL mpprecv( 12, ibuffer_f%data, ibergs_to_rcv*jp_buffer_width, ifldproc-1 ) 757 ENDIF 758 ! 663 759 DO jk = 1, ibergs_to_rcv 664 760 IF( nn_verbose_level >= 4 ) THEN … … 668 764 CALL icb_unpack_from_buffer(first_berg, ibuffer_f, jk ) 669 765 END DO 670 ! 766 ENDIF 767 ! 768 END DO 769 ! 770 ! Finally post the mpi waits if using immediate send protocol 771 DO jn = 1, jpni 772 IF( nicbfldproc(jn) /= -1 ) THEN 773 ifldproc = nicbfldproc(jn) 774 IF( ifldproc == narea ) CYCLE 775 776 IF( l_isend ) CALL mpi_wait( nicbfldreq(jn), iml_stat, iml_err ) 671 777 ENDIF 672 778 !
Note: See TracChangeset
for help on using the changeset viewer.
