MODULE icblbc !!====================================================================== !! *** MODULE icblbc *** !! Ocean physics: routines to handle boundary exchanges for icebergs !!====================================================================== !! History : 3.3.1 ! 2010-01 (Martin&Adcroft) Original code !! - ! 2011-03 (Madec) Part conversion to NEMO form !! - ! Removal of mapping from another grid !! - ! 2011-04 (Alderson) Split into separate modules !! - ! 2011-05 (Alderson) MPP exchanges written based on lib_mpp !! - ! 2011-05 (Alderson) MPP and single processor boundary !! - ! conditions added !!---------------------------------------------------------------------- !!---------------------------------------------------------------------- !! icb_lbc : - Pass icebergs across cyclic boundaries !! icb_lbc_mpp : - In MPP pass icebergs from linked list between processors !! as they advect around !! - Lagrangian processes cannot be handled by existing NEMO MPP !! routines because they do not lie on regular jpi,jpj grids !! - Processor exchanges are handled as in lib_mpp whenever icebergs step !! across boundary of interior domain (nicbdi-nicbei, nicbdj-nicbej) !! so that iceberg does not exist in more than one processor !! - North fold exchanges controlled by three arrays: !! nicbflddest - unique processor numbers that current one exchanges with !! nicbfldproc - processor number that current grid point exchanges with !! nicbfldpts - packed i,j point in exchanging processor !!---------------------------------------------------------------------- USE par_oce ! ocean parameters USE dom_oce ! ocean domain USE in_out_manager ! IO parameters USE lib_mpp ! MPI code and lk_mpp in particular USE icb_oce ! define iceberg arrays USE icbutl ! iceberg utility routines IMPLICIT NONE PRIVATE #if defined key_mpp_mpi !$AGRIF_DO_NOT_TREAT INCLUDE 'mpif.h' !$AGRIF_END_DO_NOT_TREAT TYPE, PUBLIC :: buffer INTEGER :: size=0 REAL(wp), DIMENSION(:,:), POINTER :: data END TYPE buffer TYPE(buffer), POINTER :: obuffer_n=>NULL() , ibuffer_n=>NULL() TYPE(buffer), POINTER :: obuffer_s=>NULL() , ibuffer_s=>NULL() TYPE(buffer), POINTER :: obuffer_e=>NULL() , ibuffer_e=>NULL() TYPE(buffer), POINTER :: obuffer_w=>NULL() , ibuffer_w=>NULL() ! north fold exchange buffers TYPE(buffer), POINTER :: obuffer_f=>NULL() , ibuffer_f=>NULL() INTEGER, PARAMETER, PRIVATE :: jp_delta_buf = 25 ! Size by which to increment buffers INTEGER, PARAMETER, PRIVATE :: jp_buffer_width = 15+nkounts ! items to store for each berg #endif PUBLIC icb_lbc PUBLIC icb_lbc_mpp !!---------------------------------------------------------------------- !! NEMO/OPA 3.3 , NEMO Consortium (2011) !! $Id: icblbc.F90 2355 2015-05-20 07:11:50Z ufla $ !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) !!---------------------------------------------------------------------- CONTAINS SUBROUTINE icb_lbc() !!---------------------------------------------------------------------- !! *** SUBROUTINE icb_lbc *** !! !! ** Purpose : in non-mpp case need to deal with cyclic conditions !! including north-fold !!---------------------------------------------------------------------- TYPE(iceberg), POINTER :: this TYPE(point) , POINTER :: pt INTEGER :: iine !!---------------------------------------------------------------------- !! periodic east/west boundaries !! ============================= IF( nperio == 1 .OR. nperio == 4 .OR. nperio == 6 ) THEN this => first_berg DO WHILE( ASSOCIATED(this) ) pt => this%current_point iine = INT( pt%xi + 0.5 ) IF( iine > mig(nicbei) ) THEN pt%xi = ricb_right + MOD(pt%xi, 1._wp ) - 1._wp ELSE IF( iine < mig(nicbdi) ) THEN pt%xi = ricb_left + MOD(pt%xi, 1._wp ) ENDIF this => this%next END DO ! ENDIF !! north/south boundaries !! ====================== ! south symmetric IF( nperio == 2 ) CALL ctl_stop(' south symmetric condition not implemented for icebergs') ! north fold IF( nperio == 3 .OR. nperio == 4 .OR. nperio == 5 .OR. nperio == 6 ) CALL icb_lbc_nfld() ! END SUBROUTINE icb_lbc SUBROUTINE icb_lbc_nfld() !!---------------------------------------------------------------------- !! *** SUBROUTINE icb_lbc_nfld *** !! !! ** Purpose : single processor north fold exchange !!---------------------------------------------------------------------- TYPE(iceberg), POINTER :: this TYPE(point) , POINTER :: pt INTEGER :: iine, ijne, ipts INTEGER :: iiglo, ijglo !!---------------------------------------------------------------------- ! this => first_berg DO WHILE( ASSOCIATED(this) ) pt => this%current_point ijne = INT( pt%yj + 0.5 ) IF( ijne .GT. mjg(nicbej) ) THEN ! iine = INT( pt%xi + 0.5 ) ipts = nicbfldpts (mi1(iine)) ! ! moving across the cut line means both position and ! velocity must change ijglo = INT( ipts/nicbpack ) iiglo = ipts - nicbpack*ijglo pt%xi = iiglo - ( pt%xi - REAL(iine,wp) ) pt%yj = ijglo - ( pt%yj - REAL(ijne,wp) ) pt%uvel = -1._wp * pt%uvel pt%vvel = -1._wp * pt%vvel ENDIF this => this%next END DO ! END SUBROUTINE icb_lbc_nfld #if defined key_mpp_mpi !!---------------------------------------------------------------------- !! 'key_mpp_mpi' MPI massively parallel processing library !!---------------------------------------------------------------------- SUBROUTINE icb_lbc_mpp() !!---------------------------------------------------------------------- !! *** SUBROUTINE icb_lbc_mpp *** !! !! ** Purpose : multi processor exchange !! !! ** Method : identify direction for exchange, pack into a buffer !! which is basically a real array and delete from linked list !! length of buffer is exchanged first with receiving processor !! then buffer is sent if necessary !!---------------------------------------------------------------------- TYPE(iceberg) , POINTER :: tmpberg, this TYPE(point) , POINTER :: pt INTEGER :: ibergs_to_send_e, ibergs_to_send_w INTEGER :: ibergs_to_send_n, ibergs_to_send_s INTEGER :: ibergs_rcvd_from_e, ibergs_rcvd_from_w INTEGER :: ibergs_rcvd_from_n, ibergs_rcvd_from_s INTEGER :: i, ibergs_start, ibergs_end INTEGER :: iine, ijne INTEGER :: ipe_N, ipe_S, ipe_W, ipe_E REAL(wp), DIMENSION(2) :: zewbergs, zwebergs, znsbergs, zsnbergs INTEGER :: iml_req1, iml_req2, iml_req3, iml_req4 INTEGER :: iml_req5, iml_req6, iml_req7, iml_req8, iml_err INTEGER, DIMENSION(MPI_STATUS_SIZE) :: iml_stat ! set up indices of neighbouring processors ipe_N = -1 ipe_S = -1 ipe_W = -1 ipe_E = -1 IF( nbondi .EQ. 0 .OR. nbondi .EQ. 1) ipe_W = nowe IF( nbondi .EQ. -1 .OR. nbondi .EQ. 0) ipe_E = noea IF( nbondj .EQ. 0 .OR. nbondj .EQ. 1) ipe_S = noso IF( nbondj .EQ. -1 .OR. nbondj .EQ. 0) ipe_N = nono ! ! at northern line of processors with north fold handle bergs differently IF( npolj > 0 ) ipe_N = -1 ! if there's only one processor in x direction then don't let mpp try to handle periodicity IF( jpni == 1 ) THEN ipe_E = -1 ipe_W = -1 ENDIF IF( nn_verbose_level >= 2 ) THEN WRITE(numicb,*) 'processor west : ', ipe_W WRITE(numicb,*) 'processor east : ', ipe_E WRITE(numicb,*) 'processor north : ', ipe_N WRITE(numicb,*) 'processor south : ', ipe_S WRITE(numicb,*) 'processor nimpp : ', nimpp WRITE(numicb,*) 'processor njmpp : ', njmpp WRITE(numicb,*) 'processor nbondi: ', nbondi WRITE(numicb,*) 'processor nbondj: ', nbondj CALL flush( numicb ) ENDIF ! periodicity is handled here when using mpp when there is more than one processor in ! the i direction, but it also has to happen when jpni=1 case so this is dealt with ! in icb_lbc and called here IF( jpni == 1 ) CALL icb_lbc() ! Note that xi is adjusted when swapping because of periodic condition IF( nn_verbose_level > 0 ) THEN ! store the number of icebergs on this processor at start ibergs_start = icb_utl_count() ENDIF ibergs_to_send_e = 0 ibergs_to_send_w = 0 ibergs_to_send_n = 0 ibergs_to_send_s = 0 ibergs_rcvd_from_e = 0 ibergs_rcvd_from_w = 0 ibergs_rcvd_from_n = 0 ibergs_rcvd_from_s = 0 IF( ASSOCIATED(first_berg) ) THEN ! Find number of bergs that headed east/west this => first_berg DO WHILE (ASSOCIATED(this)) pt => this%current_point iine = INT( pt%xi + 0.5 ) IF( ipe_E >= 0 .AND. iine > mig(nicbei) ) THEN tmpberg => this this => this%next ibergs_to_send_e = ibergs_to_send_e + 1 IF( nn_verbose_level >= 4 ) THEN WRITE(numicb,*) 'bergstep ',nktberg,' packing berg ',tmpberg%number(:),' for transfer to east' CALL flush( numicb ) ENDIF ! deal with periodic case tmpberg%current_point%xi = ricb_right + MOD(tmpberg%current_point%xi, 1._wp ) - 1._wp ! now pack it into buffer and delete from list CALL icb_pack_into_buffer( tmpberg, obuffer_e, ibergs_to_send_e) CALL icb_utl_delete(first_berg, tmpberg) ELSE IF( ipe_W >= 0 .AND. iine < mig(nicbdi) ) THEN tmpberg => this this => this%next ibergs_to_send_w = ibergs_to_send_w + 1 IF( nn_verbose_level >= 4 ) THEN WRITE(numicb,*) 'bergstep ',nktberg,' packing berg ',tmpberg%number(:),' for transfer to west' CALL flush( numicb ) ENDIF ! deal with periodic case tmpberg%current_point%xi = ricb_left + MOD(tmpberg%current_point%xi, 1._wp ) ! now pack it into buffer and delete from list CALL icb_pack_into_buffer( tmpberg, obuffer_w, ibergs_to_send_w) CALL icb_utl_delete(first_berg, tmpberg) ELSE this => this%next ENDIF END DO ENDIF IF( nn_verbose_level >= 3) THEN WRITE(numicb,*) 'bergstep ',nktberg,' send ew: ', ibergs_to_send_e, ibergs_to_send_w CALL flush(numicb) ENDIF ! send bergs east and receive bergs from west (ie ones that were sent east) and vice versa ! pattern here is copied from lib_mpp code SELECT CASE ( nbondi ) CASE( -1 ) zwebergs(1) = ibergs_to_send_e CALL mppsend( 12, zwebergs(1), 1, ipe_E, iml_req1) CALL mpprecv( 11, zewbergs(2), 1, ipe_E ) IF( l_isend ) CALL mpi_wait( iml_req1, iml_stat, iml_err ) ibergs_rcvd_from_e = INT( zewbergs(2) ) CASE( 0 ) zewbergs(1) = ibergs_to_send_w zwebergs(1) = ibergs_to_send_e CALL mppsend( 11, zewbergs(1), 1, ipe_W, iml_req2) CALL mppsend( 12, zwebergs(1), 1, ipe_E, iml_req3) CALL mpprecv( 11, zewbergs(2), 1, ipe_E ) CALL mpprecv( 12, zwebergs(2), 1, ipe_W ) IF( l_isend ) CALL mpi_wait( iml_req2, iml_stat, iml_err ) IF( l_isend ) CALL mpi_wait( iml_req3, iml_stat, iml_err ) ibergs_rcvd_from_e = INT( zewbergs(2) ) ibergs_rcvd_from_w = INT( zwebergs(2) ) CASE( 1 ) zewbergs(1) = ibergs_to_send_w CALL mppsend( 11, zewbergs(1), 1, ipe_W, iml_req4) CALL mpprecv( 12, zwebergs(2), 1, ipe_W ) IF( l_isend ) CALL mpi_wait( iml_req4, iml_stat, iml_err ) ibergs_rcvd_from_w = INT( zwebergs(2) ) END SELECT IF( nn_verbose_level >= 3) THEN WRITE(numicb,*) 'bergstep ',nktberg,' recv ew: ', ibergs_rcvd_from_w, ibergs_rcvd_from_e CALL flush(numicb) ENDIF SELECT CASE ( nbondi ) CASE( -1 ) IF( ibergs_to_send_e > 0 ) CALL mppsend( 14, obuffer_e%data, ibergs_to_send_e*jp_buffer_width, ipe_E, iml_req1 ) IF( ibergs_rcvd_from_e > 0 ) THEN CALL icb_increase_ibuffer(ibuffer_e, ibergs_rcvd_from_e) CALL mpprecv( 13, ibuffer_e%data, ibergs_rcvd_from_e*jp_buffer_width ) ENDIF IF( ibergs_to_send_e > 0 .AND. l_isend ) CALL mpi_wait( iml_req1, iml_stat, iml_err ) DO i = 1, ibergs_rcvd_from_e IF( nn_verbose_level >= 4 ) THEN WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_e%data(16,i)),' from east' CALL flush( numicb ) ENDIF CALL icb_unpack_from_buffer(first_berg, ibuffer_e, i) ENDDO CASE( 0 ) IF( ibergs_to_send_w > 0 ) CALL mppsend( 13, obuffer_w%data, ibergs_to_send_w*jp_buffer_width, ipe_W, iml_req2 ) IF( ibergs_to_send_e > 0 ) CALL mppsend( 14, obuffer_e%data, ibergs_to_send_e*jp_buffer_width, ipe_E, iml_req3 ) IF( ibergs_rcvd_from_e > 0 ) THEN CALL icb_increase_ibuffer(ibuffer_e, ibergs_rcvd_from_e) CALL mpprecv( 13, ibuffer_e%data, ibergs_rcvd_from_e*jp_buffer_width ) ENDIF IF( ibergs_rcvd_from_w > 0 ) THEN CALL icb_increase_ibuffer(ibuffer_w, ibergs_rcvd_from_w) CALL mpprecv( 14, ibuffer_w%data, ibergs_rcvd_from_w*jp_buffer_width ) ENDIF IF( ibergs_to_send_w > 0 .AND. l_isend ) CALL mpi_wait( iml_req2, iml_stat, iml_err ) IF( ibergs_to_send_e > 0 .AND. l_isend ) CALL mpi_wait( iml_req3, iml_stat, iml_err ) DO i = 1, ibergs_rcvd_from_e IF( nn_verbose_level >= 4 ) THEN WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_e%data(16,i)),' from east' CALL flush( numicb ) ENDIF CALL icb_unpack_from_buffer(first_berg, ibuffer_e, i) END DO DO i = 1, ibergs_rcvd_from_w IF( nn_verbose_level >= 4 ) THEN WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_w%data(16,i)),' from west' CALL flush( numicb ) ENDIF CALL icb_unpack_from_buffer(first_berg, ibuffer_w, i) ENDDO CASE( 1 ) IF( ibergs_to_send_w > 0 ) CALL mppsend( 13, obuffer_w%data, ibergs_to_send_w*jp_buffer_width, ipe_W, iml_req4 ) IF( ibergs_rcvd_from_w > 0 ) THEN CALL icb_increase_ibuffer(ibuffer_w, ibergs_rcvd_from_w) CALL mpprecv( 14, ibuffer_w%data, ibergs_rcvd_from_w*jp_buffer_width ) ENDIF IF( ibergs_to_send_w > 0 .AND. l_isend ) CALL mpi_wait( iml_req4, iml_stat, iml_err ) DO i = 1, ibergs_rcvd_from_w IF( nn_verbose_level >= 4 ) THEN WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_w%data(16,i)),' from west' CALL flush( numicb ) ENDIF CALL icb_unpack_from_buffer(first_berg, ibuffer_w, i) END DO END SELECT ! Find number of bergs that headed north/south ! (note: this block should technically go ahead of the E/W recv block above ! to handle arbitrary orientation of PEs. But for simplicity, it is ! here to accomodate diagonal transfer of bergs between PEs -AJA) IF( ASSOCIATED(first_berg) ) THEN this => first_berg DO WHILE (ASSOCIATED(this)) pt => this%current_point ijne = INT( pt%yj + 0.5 ) IF( ipe_N >= 0 .AND. ijne .GT. mjg(nicbej) ) THEN tmpberg => this this => this%next ibergs_to_send_n = ibergs_to_send_n + 1 IF( nn_verbose_level >= 4 ) THEN WRITE(numicb,*) 'bergstep ',nktberg,' packing berg ',tmpberg%number(:),' for transfer to north' CALL flush( numicb ) ENDIF CALL icb_pack_into_buffer( tmpberg, obuffer_n, ibergs_to_send_n) CALL icb_utl_delete(first_berg, tmpberg) ELSE IF( ipe_S >= 0 .AND. ijne .LT. mjg(nicbdj) ) THEN tmpberg => this this => this%next ibergs_to_send_s = ibergs_to_send_s + 1 IF( nn_verbose_level >= 4 ) THEN WRITE(numicb,*) 'bergstep ',nktberg,' packing berg ',tmpberg%number(:),' for transfer to south' CALL flush( numicb ) ENDIF CALL icb_pack_into_buffer( tmpberg, obuffer_s, ibergs_to_send_s) CALL icb_utl_delete(first_berg, tmpberg) ELSE this => this%next ENDIF END DO ENDIF if( nn_verbose_level >= 3) then write(numicb,*) 'bergstep ',nktberg,' send ns: ', ibergs_to_send_n, ibergs_to_send_s call flush(numicb) endif ! send bergs north ! and receive bergs from south (ie ones sent north) SELECT CASE ( nbondj ) CASE( -1 ) zsnbergs(1) = ibergs_to_send_n CALL mppsend( 16, zsnbergs(1), 1, ipe_N, iml_req1) CALL mpprecv( 15, znsbergs(2), 1, ipe_N ) IF( l_isend ) CALL mpi_wait( iml_req1, iml_stat, iml_err ) ibergs_rcvd_from_n = INT( znsbergs(2) ) CASE( 0 ) znsbergs(1) = ibergs_to_send_s zsnbergs(1) = ibergs_to_send_n CALL mppsend( 15, znsbergs(1), 1, ipe_S, iml_req2) CALL mppsend( 16, zsnbergs(1), 1, ipe_N, iml_req3) CALL mpprecv( 15, znsbergs(2), 1, ipe_N ) CALL mpprecv( 16, zsnbergs(2), 1, ipe_S ) IF( l_isend ) CALL mpi_wait( iml_req2, iml_stat, iml_err ) IF( l_isend ) CALL mpi_wait( iml_req3, iml_stat, iml_err ) ibergs_rcvd_from_n = INT( znsbergs(2) ) ibergs_rcvd_from_s = INT( zsnbergs(2) ) CASE( 1 ) znsbergs(1) = ibergs_to_send_s CALL mppsend( 15, znsbergs(1), 1, ipe_S, iml_req4) CALL mpprecv( 16, zsnbergs(2), 1, ipe_S ) IF( l_isend ) CALL mpi_wait( iml_req4, iml_stat, iml_err ) ibergs_rcvd_from_s = INT( zsnbergs(2) ) END SELECT if( nn_verbose_level >= 3) then write(numicb,*) 'bergstep ',nktberg,' recv ns: ', ibergs_rcvd_from_s, ibergs_rcvd_from_n call flush(numicb) endif SELECT CASE ( nbondj ) CASE( -1 ) IF( ibergs_to_send_n > 0 ) CALL mppsend( 18, obuffer_n%data, ibergs_to_send_n*jp_buffer_width, ipe_N, iml_req1 ) IF( ibergs_rcvd_from_n > 0 ) THEN CALL icb_increase_ibuffer(ibuffer_n, ibergs_rcvd_from_n) CALL mpprecv( 17, ibuffer_n%data, ibergs_rcvd_from_n*jp_buffer_width ) ENDIF IF( ibergs_to_send_n > 0 .AND. l_isend ) CALL mpi_wait( iml_req1, iml_stat, iml_err ) DO i = 1, ibergs_rcvd_from_n IF( nn_verbose_level >= 4 ) THEN WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_n%data(16,i)),' from north' CALL flush( numicb ) ENDIF CALL icb_unpack_from_buffer(first_berg, ibuffer_n, i) END DO CASE( 0 ) IF( ibergs_to_send_s > 0 ) CALL mppsend( 17, obuffer_s%data, ibergs_to_send_s*jp_buffer_width, ipe_S, iml_req2 ) IF( ibergs_to_send_n > 0 ) CALL mppsend( 18, obuffer_n%data, ibergs_to_send_n*jp_buffer_width, ipe_N, iml_req3 ) IF( ibergs_rcvd_from_n > 0 ) THEN CALL icb_increase_ibuffer(ibuffer_n, ibergs_rcvd_from_n) CALL mpprecv( 17, ibuffer_n%data, ibergs_rcvd_from_n*jp_buffer_width ) ENDIF IF( ibergs_rcvd_from_s > 0 ) THEN CALL icb_increase_ibuffer(ibuffer_s, ibergs_rcvd_from_s) CALL mpprecv( 18, ibuffer_s%data, ibergs_rcvd_from_s*jp_buffer_width ) ENDIF IF( ibergs_to_send_s > 0 .AND. l_isend ) CALL mpi_wait( iml_req2, iml_stat, iml_err ) IF( ibergs_to_send_n > 0 .AND. l_isend ) CALL mpi_wait( iml_req3, iml_stat, iml_err ) DO i = 1, ibergs_rcvd_from_n IF( nn_verbose_level >= 4 ) THEN WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_n%data(16,i)),' from north' CALL flush( numicb ) ENDIF CALL icb_unpack_from_buffer(first_berg, ibuffer_n, i) END DO DO i = 1, ibergs_rcvd_from_s IF( nn_verbose_level >= 4 ) THEN WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_s%data(16,i)),' from south' CALL flush( numicb ) ENDIF CALL icb_unpack_from_buffer(first_berg, ibuffer_s, i) ENDDO CASE( 1 ) IF( ibergs_to_send_s > 0 ) CALL mppsend( 17, obuffer_s%data, ibergs_to_send_s*jp_buffer_width, ipe_S, iml_req4 ) IF( ibergs_rcvd_from_s > 0 ) THEN CALL icb_increase_ibuffer(ibuffer_s, ibergs_rcvd_from_s) CALL mpprecv( 18, ibuffer_s%data, ibergs_rcvd_from_s*jp_buffer_width ) ENDIF IF( ibergs_to_send_s > 0 .AND. l_isend ) CALL mpi_wait( iml_req4, iml_stat, iml_err ) DO i = 1, ibergs_rcvd_from_s IF( nn_verbose_level >= 4 ) THEN WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_s%data(16,i)),' from south' CALL flush( numicb ) ENDIF CALL icb_unpack_from_buffer(first_berg, ibuffer_s, i) END DO END SELECT IF( nn_verbose_level > 0 ) THEN ! compare the number of icebergs on this processor from the start to the end ibergs_end = icb_utl_count() i = ( ibergs_rcvd_from_n + ibergs_rcvd_from_s + ibergs_rcvd_from_e + ibergs_rcvd_from_w ) - & ( ibergs_to_send_n + ibergs_to_send_s + ibergs_to_send_e + ibergs_to_send_w ) IF( ibergs_end-(ibergs_start+i) .NE. 0 ) THEN WRITE( numicb,* ) 'send_bergs_to_other_pes: net change in number of icebergs' WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_end=', & ibergs_end,' on PE',narea WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_start=', & ibergs_start,' on PE',narea WRITE( numicb,1000) 'send_bergs_to_other_pes: delta=', & i,' on PE',narea WRITE( numicb,1000) 'send_bergs_to_other_pes: error=', & ibergs_end-(ibergs_start+i),' on PE',narea WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_to_send_n=', & ibergs_to_send_n,' on PE',narea WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_to_send_s=', & ibergs_to_send_s,' on PE',narea WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_to_send_e=', & ibergs_to_send_e,' on PE',narea WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_to_send_w=', & ibergs_to_send_w,' on PE',narea WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_rcvd_from_n=', & ibergs_rcvd_from_n,' on PE',narea WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_rcvd_from_s=', & ibergs_rcvd_from_s,' on PE',narea WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_rcvd_from_e=', & ibergs_rcvd_from_e,' on PE',narea WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_rcvd_from_w=', & ibergs_rcvd_from_w,' on PE',narea 1000 FORMAT(a,i5,a,i4) CALL ctl_stop('send_bergs_to_other_pes: lost or gained an iceberg or two') ENDIF ENDIF ! deal with north fold if we necessary when there is more than one top row processor ! note that for jpni=1 north fold has been dealt with above in call to icb_lbc IF( npolj /= 0 .AND. jpni > 1 ) CALL icb_lbc_mpp_nfld( ) IF( nn_verbose_level > 0 ) THEN i = 0 this => first_berg DO WHILE (ASSOCIATED(this)) pt => this%current_point iine = INT( pt%xi + 0.5 ) ijne = INT( pt%yj + 0.5 ) IF( iine .LT. mig(nicbdi) .OR. & iine .GT. mig(nicbei) .OR. & ijne .LT. mjg(nicbdj) .OR. & ijne .GT. mjg(nicbej)) THEN i = i + 1 WRITE(numicb,*) 'berg lost in halo: ', this%number(:),iine,ijne WRITE(numicb,*) ' ', nimpp, njmpp WRITE(numicb,*) ' ', nicbdi, nicbei, nicbdj, nicbej CALL flush( numicb ) ENDIF this => this%next ENDDO ! WHILE CALL mpp_sum(i) IF( i .GT. 0 ) THEN WRITE( numicb,'(a,i4)') 'send_bergs_to_other_pes: # of bergs outside computational domain = ',i CALL ctl_stop('send_bergs_to_other_pes: there are bergs still in halos!') ENDIF ! root_pe ENDIF ! debug ! CALL mppsync() ! END SUBROUTINE icb_lbc_mpp SUBROUTINE icb_lbc_mpp_nfld() !!---------------------------------------------------------------------- !! *** SUBROUTINE icb_lbc_mpp_nfld *** !! !! ** Purpose : north fold treatment in multi processor exchange !! !! ** Method : !!---------------------------------------------------------------------- TYPE(iceberg) , POINTER :: tmpberg, this TYPE(point) , POINTER :: pt INTEGER :: ibergs_to_send INTEGER :: ibergs_to_rcv INTEGER :: iiglo, ijglo, jk, jn INTEGER :: ifldproc, iproc, ipts INTEGER :: iine, ijne INTEGER :: jjn REAL(wp), DIMENSION(0:3) :: zsbergs, znbergs INTEGER :: iml_req1, iml_req2, iml_err INTEGER, DIMENSION(MPI_STATUS_SIZE) :: iml_stat ! set up indices of neighbouring processors ! nicbfldproc is a list of unique processor numbers that this processor ! exchanges with (including itself), so we loop over this array; since ! its of fixed size, the first -1 marks end of list of processors ! nicbfldnsend(:) = 0 nicbfldexpect(:) = 0 nicbfldreq(:) = 0 ! ! Since each processor may be communicating with more than one northern ! neighbour, cycle through the sends so that the receive order can be ! controlled. ! ! First compute how many icebergs each active neighbour should expect DO jn = 1, jpni IF( nicbfldproc(jn) /= -1 ) THEN ifldproc = nicbfldproc(jn) nicbfldnsend(jn) = 0 ! Find number of bergs that need to be exchanged ! Pick out exchanges with processor ifldproc ! if ifldproc is this processor then don't send ! IF( ASSOCIATED(first_berg) ) THEN this => first_berg DO WHILE (ASSOCIATED(this)) pt => this%current_point iine = INT( pt%xi + 0.5 ) ijne = INT( pt%yj + 0.5 ) iproc = nicbflddest(mi1(iine)) IF( ijne .GT. mjg(nicbej) ) THEN IF( iproc == ifldproc ) THEN ! IF( iproc /= narea ) THEN tmpberg => this nicbfldnsend(jn) = nicbfldnsend(jn) + 1 ENDIF ! ENDIF ENDIF this => this%next END DO ENDIF ! ENDIF ! END DO ! ! Now tell each active neighbour how many icebergs to expect DO jn = 1, jpni IF( nicbfldproc(jn) /= -1 ) THEN ifldproc = nicbfldproc(jn) IF( ifldproc == narea ) CYCLE zsbergs(0) = narea zsbergs(1) = nicbfldnsend(jn) !IF ( nicbfldnsend(jn) .GT. 0) write(numicb,*) 'ICB sending ',nicbfldnsend(jn),' to ', ifldproc CALL mppsend( 21, zsbergs(0:1), 2, ifldproc-1, nicbfldreq(jn)) ENDIF ! END DO ! ! and receive the heads-up from active neighbours preparing to send DO jn = 1, jpni IF( nicbfldproc(jn) /= -1 ) THEN ifldproc = nicbfldproc(jn) IF( ifldproc == narea ) CYCLE CALL mpprecv( 21, znbergs(1:2), 2 ) DO jjn = 1,jpni IF( nicbfldproc(jjn) .eq. INT(znbergs(1)) ) EXIT END DO IF( jjn .GT. jpni ) write(numicb,*) 'ICB ERROR' nicbfldexpect(jjn) = INT( znbergs(2) ) !IF ( nicbfldexpect(jjn) .GT. 0) write(numicb,*) 'ICB expecting ',nicbfldexpect(jjn),' from ', nicbfldproc(jjn) !CALL FLUSH(numicb) ENDIF ! END DO ! ! post the mpi waits if using immediate send protocol DO jn = 1, jpni IF( nicbfldproc(jn) /= -1 ) THEN ifldproc = nicbfldproc(jn) IF( ifldproc == narea ) CYCLE IF( l_isend ) CALL mpi_wait( nicbfldreq(jn), iml_stat, iml_err ) ENDIF ! END DO ! ! Cycle through the icebergs again, this time packing and sending any ! going through the north fold. They will be expected. DO jn = 1, jpni IF( nicbfldproc(jn) /= -1 ) THEN ifldproc = nicbfldproc(jn) ibergs_to_send = 0 ! Find number of bergs that need to be exchanged ! Pick out exchanges with processor ifldproc ! if ifldproc is this processor then don't send ! IF( ASSOCIATED(first_berg) ) THEN this => first_berg DO WHILE (ASSOCIATED(this)) pt => this%current_point iine = INT( pt%xi + 0.5 ) ijne = INT( pt%yj + 0.5 ) ipts = nicbfldpts (mi1(iine)) iproc = nicbflddest(mi1(iine)) IF( ijne .GT. mjg(nicbej) ) THEN IF( iproc == ifldproc ) THEN ! ! moving across the cut line means both position and ! velocity must change ijglo = INT( ipts/nicbpack ) iiglo = ipts - nicbpack*ijglo pt%xi = iiglo - ( pt%xi - REAL(iine,wp) ) pt%yj = ijglo - ( pt%yj - REAL(ijne,wp) ) pt%uvel = -1._wp * pt%uvel pt%vvel = -1._wp * pt%vvel ! ! now remove berg from list and pack it into a buffer IF( iproc /= narea ) THEN tmpberg => this ibergs_to_send = ibergs_to_send + 1 IF( nn_verbose_level >= 4 ) THEN WRITE(numicb,*) 'bergstep ',nktberg,' packing berg ',tmpberg%number(:),' for north fold' CALL flush( numicb ) ENDIF CALL icb_pack_into_buffer( tmpberg, obuffer_f, ibergs_to_send) CALL icb_utl_delete(first_berg, tmpberg) ENDIF ! ENDIF ENDIF this => this%next END DO ENDIF if( nn_verbose_level >= 3) then write(numicb,*) 'bergstep ',nktberg,' send nfld: ', ibergs_to_send call flush(numicb) endif ! ! if we're in this processor, then we've done everything we need to ! so go on to next element of loop IF( ifldproc == narea ) CYCLE ! send bergs IF( ibergs_to_send > 0 ) & CALL mppsend( 12, obuffer_f%data, ibergs_to_send*jp_buffer_width, ifldproc-1, nicbfldreq(jn) ) ! ENDIF ! END DO ! ! Now receive the expected number of bergs from the active neighbours DO jn = 1, jpni IF( nicbfldproc(jn) /= -1 ) THEN ifldproc = nicbfldproc(jn) IF( ifldproc == narea ) CYCLE ibergs_to_rcv = nicbfldexpect(jn) IF( ibergs_to_rcv > 0 ) THEN CALL icb_increase_ibuffer(ibuffer_f, ibergs_to_rcv) CALL mpprecv( 12, ibuffer_f%data, ibergs_to_rcv*jp_buffer_width, ifldproc-1 ) ENDIF ! DO jk = 1, ibergs_to_rcv IF( nn_verbose_level >= 4 ) THEN WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_f%data(16,jk)),' from north fold' CALL flush( numicb ) ENDIF CALL icb_unpack_from_buffer(first_berg, ibuffer_f, jk ) END DO ENDIF ! END DO ! ! Finally post the mpi waits if using immediate send protocol DO jn = 1, jpni IF( nicbfldproc(jn) /= -1 ) THEN ifldproc = nicbfldproc(jn) IF( ifldproc == narea ) CYCLE IF( l_isend ) CALL mpi_wait( nicbfldreq(jn), iml_stat, iml_err ) ENDIF ! END DO ! END SUBROUTINE icb_lbc_mpp_nfld SUBROUTINE icb_pack_into_buffer( berg, pbuff, kb ) !!---------------------------------------------------------------------- !!---------------------------------------------------------------------- TYPE(iceberg), POINTER :: berg TYPE(buffer) , POINTER :: pbuff INTEGER , INTENT(in) :: kb ! INTEGER :: k ! local integer !!---------------------------------------------------------------------- ! IF( .NOT. ASSOCIATED(pbuff) ) CALL icb_increase_buffer( pbuff, jp_delta_buf ) IF( kb .GT. pbuff%size ) CALL icb_increase_buffer( pbuff, jp_delta_buf ) !! pack points into buffer pbuff%data( 1,kb) = berg%current_point%lon pbuff%data( 2,kb) = berg%current_point%lat pbuff%data( 3,kb) = berg%current_point%uvel pbuff%data( 4,kb) = berg%current_point%vvel pbuff%data( 5,kb) = berg%current_point%xi pbuff%data( 6,kb) = berg%current_point%yj pbuff%data( 7,kb) = float(berg%current_point%year) pbuff%data( 8,kb) = berg%current_point%day pbuff%data( 9,kb) = berg%current_point%mass pbuff%data(10,kb) = berg%current_point%thickness pbuff%data(11,kb) = berg%current_point%width pbuff%data(12,kb) = berg%current_point%length pbuff%data(13,kb) = berg%current_point%mass_of_bits pbuff%data(14,kb) = berg%current_point%heat_density pbuff%data(15,kb) = berg%mass_scaling DO k=1,nkounts pbuff%data(15+k,kb) = REAL( berg%number(k), wp ) END DO ! END SUBROUTINE icb_pack_into_buffer SUBROUTINE icb_unpack_from_buffer(first, pbuff, kb) !!---------------------------------------------------------------------- !!---------------------------------------------------------------------- TYPE(iceberg), POINTER :: first TYPE(buffer) , POINTER :: pbuff INTEGER , INTENT(in) :: kb ! TYPE(iceberg) :: currentberg TYPE(point) :: pt INTEGER :: ik !!---------------------------------------------------------------------- ! pt%lon = pbuff%data( 1,kb) pt%lat = pbuff%data( 2,kb) pt%uvel = pbuff%data( 3,kb) pt%vvel = pbuff%data( 4,kb) pt%xi = pbuff%data( 5,kb) pt%yj = pbuff%data( 6,kb) pt%year = INT( pbuff%data( 7,kb) ) pt%day = pbuff%data( 8,kb) pt%mass = pbuff%data( 9,kb) pt%thickness = pbuff%data(10,kb) pt%width = pbuff%data(11,kb) pt%length = pbuff%data(12,kb) pt%mass_of_bits = pbuff%data(13,kb) pt%heat_density = pbuff%data(14,kb) currentberg%mass_scaling = pbuff%data(15,kb) DO ik = 1, nkounts currentberg%number(ik) = INT( pbuff%data(15+ik,kb) ) END DO ! CALL icb_utl_add(currentberg, pt ) ! END SUBROUTINE icb_unpack_from_buffer SUBROUTINE icb_increase_buffer(old,kdelta) !!---------------------------------------------------------------------- TYPE(buffer), POINTER :: old INTEGER , INTENT(in) :: kdelta ! TYPE(buffer), POINTER :: new INTEGER :: inew_size !!---------------------------------------------------------------------- ! IF( .NOT. ASSOCIATED(old) ) THEN ; inew_size = kdelta ELSE ; inew_size = old%size + kdelta ENDIF ALLOCATE( new ) ALLOCATE( new%data( jp_buffer_width, inew_size) ) new%size = inew_size IF( ASSOCIATED(old) ) THEN new%data(:,1:old%size) = old%data(:,1:old%size) DEALLOCATE(old%data) DEALLOCATE(old) ENDIF old => new ! END SUBROUTINE icb_increase_buffer SUBROUTINE icb_increase_ibuffer(old,kdelta) !!---------------------------------------------------------------------- !!---------------------------------------------------------------------- TYPE(buffer), POINTER :: old INTEGER , INTENT(in) :: kdelta ! TYPE(buffer), POINTER :: new INTEGER :: inew_size, iold_size !!---------------------------------------------------------------------- IF( .NOT. ASSOCIATED(old) ) THEN inew_size = kdelta + jp_delta_buf iold_size = 0 ELSE iold_size = old%size IF( kdelta .LT. old%size ) THEN inew_size = old%size + kdelta ELSE inew_size = kdelta + jp_delta_buf ENDIF ENDIF IF( iold_size .NE. inew_size ) THEN ALLOCATE( new ) ALLOCATE( new%data( jp_buffer_width, inew_size) ) new%size = inew_size IF( ASSOCIATED(old) ) THEN new%data(:,1:old%size) = old%data(:,1:old%size) DEALLOCATE(old%data) DEALLOCATE(old) ENDIF old => new !WRITE( numicb,*) 'icb_increase_ibuffer',narea,' increased to',inew_size ENDIF ! END SUBROUTINE icb_increase_ibuffer #else !!---------------------------------------------------------------------- !! Default case: Dummy module share memory computing !!---------------------------------------------------------------------- SUBROUTINE icb_lbc_mpp() WRITE(numout,*) 'icb_lbc_mpp: You should not have seen this message!!' END SUBROUTINE icb_lbc_mpp #endif !!====================================================================== END MODULE icblbc