MODULE exchmod USE par_oce, ONLY: wp, jpiglo, jpjglo, jpkdta, jpi, jpj, jpk, jpkorig #if defined key_mpp_mpi USE mpi ! For better interface checking #endif #if ( defined DEBUG && defined DEBUG_EXCHANGE ) || defined DEBUG_COMMS USE dom_oce, ONLY: narea #endif USE profile ! USE timing, ONLY: timing_start, timing_stop ! Make some key parameters from mapcomm_mod available to all who ! USE this module USE mapcomm_mod, ONLY: Iminus, Iplus, Jminus, Jplus, NONE, & jeub IMPLICIT none !!#define DEBUG_COMMS PRIVATE ! Module containing variables to support the automatic allocation ! of tags and flags for the exchange and collective communications ! routines. ! indexs, indexr- Array indexes for send and receive flags. ! max_flags - The number of slots in the flag arrays ! i.e. the maximum number of simultaneous communications ! current_tag - The current (last assigned) tag value ! This is shared between exchanges and global operations ! to avoid conflicts by the use of the same tag value. ! min_tag - The minimum or starting tag value. ! max_tag - The maximum tag value. When tags reach this value ! they start again from the minimum. ! max_tag_used - Records the largest tag value actually used. ! n_tag_cycles - Number of cycles round the range min_tag to max_tag. ! first_mod - First time flag for use of this module. ! Set of arrays for exchange operations. ! exch_flags - Array of flag arrays for exchanges ! exch_flags1d - Array of only the current MPI receive operations ! exch_tag - The tag value associated with this exchange ! exch_busy - Indicates whether a slot in the flag array is being used INTEGER, PARAMETER :: indexs=1,indexr=2 INTEGER, PARAMETER :: max_flags=40 INTEGER, PARAMETER :: min_tag=0 INTEGER :: current_tag,max_tag_used,max_tag,n_tag_cycles=0 LOGICAL :: first_mod=.TRUE. INTEGER, ALLOCATABLE, DIMENSION(:,:,:), SAVE :: exch_flags INTEGER, ALLOCATABLE, DIMENSION(:), SAVE :: exch_tag, exch_flags1d LOGICAL, ALLOCATABLE, DIMENSION(:), SAVE :: exch_busy ! variables used in case of north fold condition in mpp_mpi ! with jpni > 1 INTEGER, SAVE :: & ! ngrp_world, & ! group ID for the world processors ngrp_north, & ! group ID for the northern processors (to be fold) ncomm_north, & ! communicator made by the processors belonging to ngrp_north ndim_rank_north ! number of 'sea' processor in the northern line (can be /= jpni !) INTEGER, SAVE :: north_root ! number (in the comm_opa) of proc 0 in the northern comm INTEGER, DIMENSION(:), ALLOCATABLE, SAVE :: nrank_north ! dim. ndim_rank_north, number ! of the procs belonging to ncomm_north LOGICAL, SAVE :: do_nfold ! Whether this PE contributes to N-fold exchange ! - takes domain trimming into account. INTEGER, PARAMETER :: num_nfold_rows = 4 ! No. of rows at the top of the ! global domain to use in applying ! the north-fold condition (no value ! other than 4 currently tested) INTEGER, DIMENSION(:), ALLOCATABLE, SAVE :: nfold_npts ! How many points each ! northern proc contrib ! to nfold exchange !FTRANS r3dptr :I :I :z !FTRANS i3dptr :I :I :z TYPE exch_item INTEGER :: halo_width INTEGER, DIMENSION(4) :: dirn INTEGER :: isgn CHARACTER(LEN=1) :: grid LOGICAL :: lfill INTEGER, DIMENSION(:,:), POINTER :: i2dptr INTEGER, DIMENSION(:,:,:), POINTER :: i3dptr REAL(wp), DIMENSION(:,:), POINTER :: r2dptr REAL(wp), DIMENSION(:,:,:), POINTER :: r3dptr END TYPE exch_item TYPE (exch_item), ALLOCATABLE, SAVE :: exch_list(:) INTEGER, SAVE :: nextFreeExchItem, maxExchItems ! Buffer for doing halo-exchange. ! For a 3D array, halos are 2D slabs but copied into these buffers ! as 1D vectors. 2nd dimension refers to the direction of the ! communication. ! For a 2D array, halos are 1D vectors anyway. REAL(wp), DIMENSION(:,:), ALLOCATABLE, SAVE :: sendBuff, recvBuff INTEGER , DIMENSION(:,:), ALLOCATABLE, SAVE :: sendIBuff, recvIBuff INTERFACE bound_exch MODULE PROCEDURE bound_exch2, bound_exch2i, & bound_exch3, bound_exch3i END INTERFACE bound_exch INTERFACE apply_north_fold MODULE PROCEDURE apply_north_fold2, apply_north_fold2i, & apply_north_fold3, apply_north_fold3i END INTERFACE apply_north_fold INTERFACE mpp_lbc_north MODULE PROCEDURE mpp_lbc_north_3d, mpp_lbc_north_i3d, & mpp_lbc_north_2d, mpp_lbc_north_i2d END INTERFACE PUBLIC get_exch_handle, free_exch_handle, bound_exch, & exch_tag, exch_flags, indexs, indexr, & nrank_north, north_root, ndim_rank_north, & ngrp_north, ngrp_world, ncomm_north, & num_nfold_rows, do_nfold, nfold_npts, & exchmod_alloc, add_exch, bound_exch_list, & Iminus, Iplus, Jminus, Jplus, NONE, & lbc_exch3, lbc_exch2 #if defined key_mpp_mpi PUBLIC MPI_COMM_WORLD, MPI_Wtime #endif ! MPI only !!$#if defined key_mpp_mpi !!$ INCLUDE "mpif.h" !!$#endif !!$#if defined ARPVAMPIR !!$# include "vampir_sym_defs.inc" !!$#endif CONTAINS INTEGER FUNCTION exchmod_alloc() USE mapcomm_mod, Only: MaxComm IMPLICIT none ! Locals INTEGER :: ierr, ii ! Since halos are broken up into wet-point-only patches we ! allocate the send and receive buffers on a per-PE basis once we ! know the sizes of the patches (in exchs_generic). maxExchItems = 20 ALLOCATE(exch_list(maxExchItems), & exch_flags(max_flags,MaxComm,2), & exch_flags1d(MaxComm), & exch_busy(max_flags), & exch_tag(max_flags), & STAT=ierr) IF(ierr .eq. 0)THEN DO ii=1,maxExchItems,1 NULLIFY(exch_list(ii)%r2dptr, exch_list(ii)%r3dptr, & exch_list(ii)%i2dptr, exch_list(ii)%i3dptr) END DO exch_busy = .FALSE. ELSE maxExchItems = 0 END IF nextFreeExchItem = 1 ! Pass back the allocation status flag exchmod_alloc = ierr END FUNCTION exchmod_alloc INTEGER FUNCTION get_exch_handle ( ) ! --------------------------------------------------------------- ! Gets a new exchange handle ! --------------------------------------------------------------- !!$#if defined DEBUG || defined DEBUG_COMMS !!$ USE in_out_manager, ONLY: numout, lwp !!$ USE dom_oce, ONLY: narea !!$#endif USE mapcomm_mod, ONLY: MaxCommDir IMPLICIT NONE ! Local variables. INTEGER :: h,ierr LOGICAL :: got IF ( first_mod ) THEN ! First time in the module (i.e. exch or glob) set up the tags. ! Set the maximum tag value. got = .FALSE. #if defined key_mpp_mpi CALL MPI_attr_get(MPI_comm_world,MPI_tag_ub,max_tag,got,ierr) IF ( ierr.NE.0 ) CALL abort () #endif /* key_mpp_mpi */ IF ( .NOT.got ) THEN ! If no value was returned use the minimum possible tag max. ! (p. 28 of Version 2.1 of the MPI standard or p. 19 of V.1 of the standard.) max_tag = 32767 ENDIF #ifdef DEBUG IF ( lwp ) WRITE (numout,*) 'MAX_TAG: set to ',max_tag #endif ! Set the current tag to the minimum. current_tag = min_tag max_tag_used = current_tag first_mod = .FALSE. ENDIF ! Look for a free location in the flags array. flag_search : DO h=1,max_flags IF ( .NOT.exch_busy(h) ) EXIT flag_search ENDDO flag_search IF ( h.GT.max_flags ) THEN ! If no free flags array was found, flag an error. STOP 'ERROR: get_exch_handle: no free flag array' ELSE ! Assign a new tag. exch_busy(h) = .TRUE. IF ( current_tag.GE.(max_tag-MaxCommDir) ) THEN ! Wrap around. current_tag = min_tag n_tag_cycles = n_tag_cycles+1 ELSE current_tag = current_tag + MaxCommDir ENDIF max_tag_used = MAX(max_tag_used,current_tag) exch_tag(h) = current_tag !!$#if ( defined DEBUG && defined DEBUG_EXCHANGE ) || defined DEBUG_COMMS !!$ IF ( lwp ) THEN !!$ WRITE (numout,'(1x,a,i6,a,i8,a,i3,a,i3,a)') & !!$ 'Process ',narea-1,' exch tag ',exch_tag(h) & !!$ ,' assigned flags ',h,' (',COUNT(exch_busy),' busy)' !!$ CALL flush (numout) !!$ ENDIF !!$#endif ENDIF get_exch_handle = h RETURN END FUNCTION get_exch_handle ! --------------------------------------------------------------- SUBROUTINE free_exch_handle ( h ) ! Frees exchange handle, h. !!$#if ( defined DEBUG && defined DEBUG_EXCHANGE ) || defined DEBUG_COMMS !!$ USE in_out_manager, ONLY: numout, lwp !!$ USE dom_oce, ONLY: narea !!$#endif IMPLICIT NONE ! Subroutine arguments. INTEGER :: h ! Handle to be free'd ! Free the flags array. IF ( h.GT.0 .AND. h.LE.max_flags ) THEN exch_busy(h) = .FALSE. !!$#if ( defined DEBUG && defined DEBUG_EXCHANGE ) || defined DEBUG_COMMS !!$ IF ( lwp ) THEN !!$ WRITE (numout,'(1x,a,i6,a,i8,a,i3)') 'Process ',narea-1,' exch tag ',exch_tag(h) ,' freed flags ',h !!$ CALL flush (numout) !!$ ENDIF !!$#endif ELSE WRITE (*,*) 'free_exch_handle: invalid handle ',h ENDIF END SUBROUTINE free_exch_handle ! ------------------------------------------------------------------------ SUBROUTINE bound_exch_generic ( b2, ib2, b3, ib3, nhalo, nhexch, & comm1, comm2, comm3, comm4, & cd_type, lfill, pval, isgn, lzero ) USE par_oce, ONLY: wp, jpreci, jprecj, jpim1 USE dom_oce, ONLY: nlci, nlcj, nldi, nlei, nldj, nlej, & nperio, nbondi, npolj, narea, jpkf USE mapcomm_mod, ONLY: Iminus, Iplus, NONE, ilbext, iubext, cyclic_bc USE mapcomm_mod, ONLY: trimmed, eidx, widx IMPLICIT none INTEGER, INTENT(in) :: nhalo,nhexch !FTRANS b3 :I :I :z !FTRANS ib3 :I :I :z REAL(wp),OPTIONAL, INTENT(inout), DIMENSION(:,:) :: b2 INTEGER, OPTIONAL, INTENT(inout), DIMENSION(:,:) :: ib2 REAL(wp),OPTIONAL, INTENT(inout), DIMENSION(:,:,:) :: b3 INTEGER, OPTIONAL, INTENT(inout), DIMENSION(:,:,:) :: ib3 INTEGER, INTENT(in) :: comm1, comm2, comm3, comm4 CHARACTER(len=1), INTENT(in) :: cd_type LOGICAL, OPTIONAL, INTENT(in) :: lfill REAL(wp),OPTIONAL, INTENT(in) :: pval ! background value (used at closed boundaries) INTEGER, OPTIONAL, INTENT(in) :: isgn LOGICAL, OPTIONAL, INTENT(in) :: lzero ! Whether to set halo values on closed boundaries ! Local arguments INTEGER :: itag ! Communication handle INTEGER :: isgnarg INTEGER :: ii, jj, jk, ji ! Loop indices INTEGER :: ileft, iright ! First and last x-coord of internal points INTEGER :: kdim1 INTEGER :: iland ! Land values - zero by default unless pval passed in. REAL(wp) :: zland ! " " LOGICAL :: lfillarg, lzeroarg !!-------------------------------------------------------------------- #if ! defined key_mpp_rkpart RETURN #endif ! CALL prof_region_begin(ARPCOMMS, "IndivComms", iprofStat) ! CALL timing_start('bound_exch_generic') ! Deal with optional routine arguments lzeroarg = .TRUE. lfillarg = .FALSE. isgnarg = 1 zland = 0.0_wp IF( PRESENT(lfill) ) lfillarg = lfill IF( PRESENT(isgn) ) isgnarg = isgn IF( PRESENT(lzero) ) lzeroarg = lzero IF( PRESENT(pval) ) zland = pval iland=INT(zland) ! Find out the size of 3rd dimension of the array kdim1 = 1 IF ( PRESENT(b3) ) THEN #if defined key_z_first kdim1 = SIZE(b3,dim=1) #else kdim1 = SIZE(b3,dim=3) #endif ! If we've been passed a 'standard' 3D array then ! we can limit the length of our z loops to the ! no. of levels above the ocean floor. IF(kdim1 == jpkorig)kdim1 = jpkf ELSEIF ( PRESENT(ib3) ) THEN #if defined key_z_first kdim1 = SIZE(ib3,dim=1) #else kdim1 = SIZE(ib3,dim=3) #endif ! If we've been passed a 'standard' 3D array then ! we can limit the length of our z loops to the ! no. of levels above the ocean floor. IF(kdim1 == jpk)kdim1 = jpkf ELSEIF ( PRESENT(b2) ) THEN kdim1 = SIZE(b2,dim=2) ELSEIF ( PRESENT(ib2) ) THEN kdim1 = SIZE(ib2,dim=2) ENDIF IF( lfillarg ) THEN ! (nldi,nlej) is only a valid TL corner point if we're not on ! an external boundary. If we are then we need nldi+1 if we ! have cyclic E-W boundary conditions. ileft = nldi IF( (ilbext .AND. (.NOT. trimmed(widx,narea))) .AND. cyclic_bc) & ileft = ileft + 1 iright = nlei IF( (iubext .AND. (.NOT. trimmed(eidx,narea))) .AND. cyclic_bc) & iright = iright - 1 IF ( PRESENT(b2) ) THEN DO jj = 1, jprecj, 1 ! only fill extra allows last line b2(nldi:nlei , jj) = b2(nldi:nlei, nldj) b2(1:jpreci , jj) = b2(ileft, nldj) ! Bottom-left corner points b2(nlci:jpi, jj) = b2(iright, nldj) ! Bottom-right corner points END DO DO jj = nlej+1, jpj, 1 ! only fill extra allows last line b2(nldi:nlei , jj) = b2(nldi:nlei, nlej) b2(1:jpreci , jj) = b2(ileft, nlej) ! Top-left corner points b2(nlci:jpi, jj) = b2(iright, nlej)! Top-right corner points END DO DO jj = nldj,nlej,1 ! Left halo columns b2(1: jpreci , jj ) = b2(ileft, jj ) END DO DO jj = nldj, nlej, 1 ! Right halo columns b2(nlci:jpi , jj ) = b2(iright, jj ) END DO ELSE IF ( PRESENT(ib2) ) THEN DO jj = 1, jprecj ! only fill extra allows last line ib2(nldi:nlei , jj) = ib2(nldi:nlei, nldj) ib2( 1:jpreci, jj) = ib2(ileft , nldj) ! Bottom-left corner points ib2(nlci:jpi , jj) = ib2(iright , nldj) ! Bottom-right corner points END DO DO jj = nlej+1, jpj ib2(nldi:nlei, jj) = ib2(nldi:nlei, nlej) ib2(1:jpreci , jj) = ib2(ileft , nlej) ! Top-left corner points ib2(nlci:jpi , jj) = ib2(iright , nlej) ! Top-right corner points END DO DO jj = nldj,nlej,1 ! West-most columns ib2(1:jpreci, jj) = ib2(ileft, jj) END DO DO jj = nldj, nlej, 1 ! East-most columns ib2(nlci:jpi, jj) = ib2(iright, jj) END DO ELSE IF ( PRESENT(b3) ) THEN #if defined key_z_first DO jj = 1, jprecj, 1 ! Bottom rows DO ii = nldi, nlei, 1 b3(ii, jj, 1:kdim1) = b3(ii, nldj, 1:kdim1) ! Bottom rows END DO DO ii = 1, jpreci, 1 b3(ii, jj, 1:kdim1) = b3(ileft ,nldj,1:kdim1) ! Bottom-L corner END DO DO ii = nlci, jpi, 1 b3(ii, jj, 1:kdim1) = b3(iright ,nldj,1:kdim1) ! Bottom-R corner END DO END DO DO jj = nlej+1, jpj, 1 ! Top rows DO ii = 1, jpreci, 1 b3(ii, jj,1:kdim1) = b3(ileft,nlej,1:kdim1) ! Top-L corner pts END DO DO ii = nldi, nlei, 1 b3(ii, jj,1:kdim1) = b3(ii,nlej,1:kdim1) ! Top rows END DO DO ii = nlci, jpi, 1 b3(ii , jj,1:kdim1) = b3(iright,nlej,1:kdim1) ! Top-R corner pts END DO END DO DO jj = nldj, nlej, 1 ! E-most columns DO ii = nlci, jpi, 1 b3(ii, jj, 1:kdim1) = b3(iright, jj, 1:kdim1) END DO END DO DO jj = nldj, nlej, 1 ! W-most columns DO ii = 1, jpreci, 1 b3(ii, jj, 1:kdim1) = b3(ileft, jj, 1:kdim1) END DO END DO #else jk_loop: DO jk = 1,kdim1,1 DO jj = 1, jprecj, 1 ! Bottom rows b3(nldi:nlei, jj, jk) = b3(nldi:nlei,nldj,jk) ! Bottom rows b3(1:jpreci , jj, jk) = b3(ileft ,nldj,jk) ! Bottom-L corner b3(nlci:jpi , jj, jk) = b3(iright ,nldj,jk) ! Bottom-R corner END DO DO jj = nlej+1, jpj, 1 ! Top rows b3(nldi:nlei, jj,jk) = b3(nldi:nlei,nlej,jk) ! Top rows b3(1:jpreci , jj,jk) = b3(ileft ,nlej,jk) ! Top-L corner pts b3(nlci:jpi , jj,jk) = b3(iright ,nlej,jk) ! Top-R corner pts END DO DO jj = nldj, nlej, 1 ! E-most columns b3(nlci:jpi, jj, jk) = b3(iright, jj, jk) END DO DO jj = nldj, nlej, 1 ! W-most columns b3(1:jpreci, jj, jk) = b3(ileft, jj, jk) END DO END DO jk_loop #endif ELSE IF ( PRESENT(ib3) ) THEN #if defined key_z_first ! ARPDBG - do I need to make ii loops explicit and appropriately ordered? DO jj = 1,jprecj ! Bottom rows DO jk = 1,kdim1,1 ib3(nldi:nlei, jj, jk) = ib3(nldi:nlei,nldj,jk) ! Bottom rows ib3(1:jpreci, jj, jk) = ib3(ileft ,nldj,jk) ! Bottom-L corner ib3(nlci:jpi,jj, jk) = ib3(iright ,nldj,jk) ! Bottom-R corner END DO END DO DO jj = nlej+1, jpj ! Top rows DO jk = 1,kdim1,1 ib3(nldi:nlei,jj,jk) = ib3(nldi:nlei,nlej,jk) ! Top rows ib3(1:jpreci ,jj,jk) = ib3(ileft ,nlej,jk) ! Top-L corner pts ib3(nlci:jpi ,jj,jk) = ib3(iright ,nlej,jk) ! Top-R corner pts END DO END DO DO jj = nldj,nlej, 1 ! E-most columns DO jk = 1,kdim1,1 ib3(nlci:jpi, jj, jk) = ib3(iright, jj, jk) END DO END DO DO jj = nldj,nlej,1 ! W-most columns DO jk = 1,kdim1,1 ib3(1:jpreci, jj, jk) = ib3(ileft, jj, jk) END DO END DO #else DO jk = 1,kdim1,1 DO jj = 1,jprecj ! Bottom rows ib3(nldi:nlei, jj, jk) = ib3(nldi:nlei,nldj,jk) ! Bottom rows ib3(1:jpreci, jj, jk) = ib3(ileft ,nldj,jk) ! Bottom-L corner ib3(nlci:jpi,jj, jk) = ib3(iright ,nldj,jk) ! Bottom-R corner END DO DO jj = nlej+1, jpj ! Top rows ib3(nldi:nlei,jj,jk) = ib3(nldi:nlei,nlej,jk) ! Top rows ib3(1:jpreci ,jj,jk) = ib3(ileft ,nlej,jk) ! Top-L corner pts ib3(nlci:jpi ,jj,jk) = ib3(iright ,nlej,jk) ! Top-R corner pts END DO DO jj = nldj,nlej, 1 ! E-most columns ib3(nlci:jpi, jj, jk) = ib3(iright, jj, jk) END DO DO jj = nldj,nlej,1 ! W-most columns ib3(1:jpreci, jj, jk) = ib3(ileft, jj, jk) END DO END DO #endif END IF ELSE ! lfillarg is .FALSE. - standard closed or cyclic treatment ! ! East-West boundaries ! ! ==================== ! nbondi == 2 when a single sub-domain spans the whole width ! of the global domain IF( nbondi == 2 .AND. & ! Cyclic east-west & (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN IF ( PRESENT(b2) ) THEN b2( 1 ,:) = b2(jpim1,:) ! Set west halo to last valid east value b2(jpi,:) = b2(nldi ,:) ! east halo to first valid west value ELSE IF ( PRESENT(ib2) ) THEN ib2( 1 ,:) = ib2(jpim1,:) ib2(jpi,:) = ib2(nldi ,:) ELSE IF ( PRESENT(b3) ) THEN #if defined key_z_first DO jj = 1,jpj,1 DO jk = 1,kdim1,1 b3( 1, jj, jk) = b3(jpim1, jj, jk) b3(jpi,jj, jk) = b3( 2, jj, jk) END DO END DO #else b3( 1, :, 1:kdim1) = b3(jpim1, :, 1:kdim1) b3(jpi,:, 1:kdim1) = b3( 2, :, 1:kdim1) #endif ELSE IF ( PRESENT(ib3) ) THEN ib3( 1, :, 1:kdim1) = ib3(jpim1, :, 1:kdim1) ib3(jpi,:, 1:kdim1) = ib3( 2, :, 1:kdim1) END IF ELSE ! ... closed East-West boundaries IF( lzeroarg )THEN IF ( PRESENT(b2) ) THEN SELECT CASE ( cd_type ) CASE ( 'T', 'U', 'V', 'W' , 'I' ) b2(1:jpreci , :) = zland ! Western halo b2(nlci-jpreci+1:jpi, :) = zland ! Eastern halo CASE ( 'F' ) b2(nlci-jpreci+1:jpi, :) = zland ! Eastern halo END SELECT ELSE IF ( PRESENT(ib2) ) THEN SELECT CASE ( cd_type ) CASE ( 'T', 'U', 'V', 'W' , 'I' ) ib2(1:jpreci , :) = iland ! Western halo ib2(nlci-jpreci+1:jpi, :) = iland ! Eastern halo CASE ( 'F' ) ib2(nlci-jpreci+1:jpi, :) = iland ! Eastern halo END SELECT ELSE IF ( PRESENT(b3) ) THEN SELECT CASE ( cd_type ) CASE ( 'T', 'U', 'V', 'W' ) #if defined key_z_first DO jj=1,jpj,1 DO ji=1,jpreci,1 DO jk=1,kdim1,1 b3(ji, jj, jk) = zland END DO END DO DO ji=nlci-jpreci+1,jpi,1 DO jk=1,kdim1,1 b3(ji, jj, jk) = zland END DO END DO END DO #else b3(1:jpreci , :, 1:kdim1) = zland b3(nlci-jpreci+1:jpi, :, 1:kdim1) = zland #endif CASE ( 'F' ) #if defined key_z_first DO jj=1,jpj,1 DO ji = nlci-jpreci+1,jpi,1 DO jk = 1,kdim1,1 b3(ji, jj, jk) = zland END DO END DO END DO #else b3(nlci-jpreci+1:jpi, :, 1:kdim1) = zland #endif END SELECT ELSE IF ( PRESENT(ib3) ) THEN SELECT CASE ( cd_type ) CASE ( 'T', 'U', 'V', 'W' ) ib3(1:jpreci , :, 1:kdim1) = iland ib3(nlci-jpreci+1:jpi, :, 1:kdim1) = iland CASE ( 'F' ) ib3(nlci-jpreci+1:jpi, :, 1:kdim1) = iland END SELECT END IF END IF ! lzeroarg END IF IF( lzeroarg )THEN ! ! North-South boundaries (always closed) ! ! ====================== IF ( PRESENT(b2) ) THEN SELECT CASE ( cd_type ) CASE ( 'T', 'U', 'V', 'W' , 'I' ) !b2(:,1:nldj-1 ) = zland ! Below is what is done in original lib_mpp.F90 b2(:,1:jprecj ) = zland b2(:,nlcj-jprecj+1:jpj) = zland CASE ( 'F' ) b2(:,nlcj-jprecj+1:jpj) = zland END SELECT ELSE IF ( PRESENT(ib2) ) THEN SELECT CASE ( cd_type ) CASE ( 'T', 'U', 'V', 'W' , 'I' ) ib2(:,1:jprecj ) = iland ib2(:,nlcj-jprecj+1:jpj) = iland CASE ( 'F' ) ib2(:,nlcj-jprecj+1:jpj) = iland END SELECT ELSE IF ( PRESENT(b3) ) THEN SELECT CASE ( cd_type ) CASE ( 'T', 'U', 'V', 'W' ) #if defined key_z_first DO jj=1,jprecj,1 DO ji=1,jpi,1 DO jk = 1,kdim1,1 b3(ji, jj, jk) = zland END DO END DO END DO DO jj=nlcj-jprecj+1,jpj,1 DO ji=1,jpi,1 DO jk = 1,kdim1,1 b3(ji, jj, jk) = zland END DO END DO END DO #else b3(:, 1:jprecj , 1:kdim1) = zland b3(:, nlcj-jprecj+1:jpj, 1:kdim1) = zland #endif CASE ( 'F' ) #if defined key_z_first DO jj=nlcj-jprecj+1,jpj,1 DO ji=1,jpi,1 DO jk = 1,kdim1,1 b3(ji, jj, jk) = zland END DO END DO END DO #else b3(:, nlcj-jprecj+1:jpj, 1:kdim1) = zland #endif END SELECT ELSE IF ( PRESENT(ib3) ) THEN SELECT CASE ( cd_type ) CASE ( 'T', 'U', 'V', 'W' ) ib3(:, 1:jprecj , 1:kdim1) = iland ib3(:, nlcj-jprecj+1:jpj, 1:kdim1) = iland CASE ( 'F' ) ib3(:, nlcj-jprecj+1:jpj, 1:kdim1) = iland END SELECT END IF END IF ! lzeroarg END IF ! lfillarg ! Do East-West and North-South exchanges CALL exchs_generic ( b2=b2,ib2=ib2,b3=b3,ib3=ib3, nhalo=nhalo, & nhexch=nhexch, handle=itag, & comm1=comm1,comm2=comm2,comm3=comm3,comm4=comm4, & cd_type=cd_type, lfill=lfillarg) !CALL exchr_generic (b2=b2,ib2=ib2,b3=b3,ib3=ib3,nhalo=nhalo, & ! nhexch=nhexch, handle=itag, & ! comm1=comm1,comm2=comm2,comm3=comm3,comm4=comm4 ) ! Apply north-fold condition IF(.not. lfillarg)THEN IF(PRESENT(b2))THEN CALL apply_north_fold(b2, isgnarg, cd_type) ELSE IF(PRESENT(ib2))THEN CALL apply_north_fold(ib2, isgnarg, cd_type) ELSE IF(PRESENT(b3))THEN CALL apply_north_fold(b3, isgnarg, cd_type) ELSE IF(PRESENT(ib3))THEN CALL apply_north_fold(ib3, isgnarg, cd_type) ELSE STOP 'ARPDBG: ERROR - no matching version of apply_north_fold!' END IF !WRITE (*,*) 'ARPDBG: bound_exch_generic: npolj = ',npolj ! We only need to repeat the East and West halo swap if there ! IS a north-fold in the configuration. !SELECT CASE (npolj) !CASE ( 3, 4, 5, 6 ) IF(ndim_rank_north > 0)THEN ! Update East and West halos as required - no data sent north ! as it's only the northern-most PEs that have been affected ! by the north-fold condition. ! ARPDBG - inefficient since all PEs do halo swap and only ! those affected by the north fold actually need to - can ! this be done within apply_north_fold? CALL exchs_generic (b2=b2,ib2=ib2,b3=b3,ib3=ib3, nhalo=nhalo, & nhexch=nhexch, handle=itag, & comm1=Iplus,comm2=Iminus,comm3=Jplus,comm4=Jminus, & cd_type=cd_type, lfill=lfillarg) END IF ! ndim_rank_north > 0 !END SELECT ! npolj END IF ! CALL prof_region_end(ARPCOMMS, iprofStat) ! CALL timing_stop('bound_exch_generic','section') END SUBROUTINE bound_exch_generic ! ------------------------------------------------------------------------ SUBROUTINE bound_exch_list () USE par_oce, ONLY: wp, jpreci, jprecj, jpim1 USE dom_oce, ONLY: nlci, nlcj, nldi, nlei, nldj, nlej, & nperio, nbondi USE mapcomm_mod, ONLY: Iminus, Iplus, NONE, ilbext, iubext, cyclic_bc IMPLICIT none ! Local arguments INTEGER :: ii, jj, jk, ifield ! Loop indices INTEGER :: ileft, iright ! First and last x-coord of internal points INTEGER :: kdim1 INTEGER :: nfields !FTRANS b3 :I :I :z !FTRANS ib3 :I :I :z INTEGER, DIMENSION(:,:), POINTER :: ib2 INTEGER, DIMENSION(:,:,:), POINTER :: ib3 REAL, DIMENSION(:,:), POINTER :: b2 REAL, DIMENSION(:,:,:), POINTER :: b3 !!---------------------------------------------------------------------- #if ! defined key_mpp_rkpart RETURN #endif NULLIFY(ib2, ib3, b2, b3) nfields = nextFreeExchItem - 1 CALL prof_region_begin(ARPLISTCOMMS, "ListComms", iprofStat) DO ifield=1, nfields, 1 ! Find out the size of 3rd dimension of the array kdim1 = 1 IF ( ASSOCIATED(exch_list(ifield)%r3dptr) ) THEN b3 => exch_list(ifield)%r3dptr #if defined key_z_first kdim1 = SIZE(b3,dim=1) #else kdim1 = SIZE(b3,dim=3) #endif ELSEIF ( ASSOCIATED(exch_list(ifield)%i3dptr) ) THEN ib3 => exch_list(ifield)%i3dptr #if defined key_z_first kdim1 = SIZE(ib3,dim=1) #else kdim1 = SIZE(ib3,dim=3) #endif ELSEIF ( ASSOCIATED(exch_list(ifield)%r2dptr) ) THEN b2 => exch_list(ifield)%r2dptr kdim1 = SIZE(b2,dim=2) ELSEIF ( ASSOCIATED(exch_list(ifield)%i2dptr) ) THEN ib2 => exch_list(ifield)%i2dptr kdim1 = SIZE(ib2,dim=2) ENDIF IF( exch_list(ifield)%lfill ) THEN ! (nldi,nlej) is only a valid TL corner point if we're not on an ! external boundary. If we are AND we have cyclic E-W boundary ! conditions then we need nldi+1. ileft = nldi IF(ilbext .AND. cyclic_bc)ileft = ileft + 1 iright = nlei IF(iubext .AND. cyclic_bc)iright = iright - 1 IF ( ASSOCIATED(b2) ) THEN DO jj = 1, jprecj, 1 ! only fill extra allows last line b2(nldi:nlei , jj) = b2(nldi:nlei, nldj) b2(1:jpreci , jj) = b2(ileft, nldj) ! Bottom-left corner points b2(nlci:jpi, jj) = b2(iright, nldj) ! Bottom-right corner points END DO DO jj = nlej+1, jpj, 1 ! only fill extra allows last line b2(nldi:nlei , jj) = b2(nldi:nlei, nlej) b2(1:jpreci , jj) = b2(ileft, nlej) ! Top-left corner points b2(nlci:jpi, jj) = b2(iright, nlej)! Top-right corner points END DO DO jj = nldj,nlej,1 ! Left halo columns b2(1: jpreci , jj ) = b2(ileft, jj ) END DO DO jj = nldj, nlej, 1 ! Right halo columns b2(nlci:jpi , jj ) = b2(iright, jj ) END DO ELSE IF ( ASSOCIATED(ib2) ) THEN DO jj = 1, jprecj ! only fill extra allows last line ib2(nldi:nlei , jj) = ib2(nldi:nlei, nldj) ib2( 1:jpreci, jj) = ib2(ileft , nldj) ! Bottom-left corner points ib2(nlci:jpi , jj) = ib2(iright , nldj) ! Bottom-right corner points END DO DO jj = nlej+1, jpj ib2(nldi:nlei, jj) = ib2(nldi:nlei, nlej) ib2(1:jpreci , jj) = ib2(ileft , nlej) ! Top-left corner points ib2(nlci:jpi , jj) = ib2(iright , nlej) ! Top-right corner points END DO DO jj = nldj,nlej,1 ! West-most columns ib2(1:jpreci, jj) = ib2(ileft, jj) END DO DO jj = nldj, nlej, 1 ! East-most columns ib2(nlci:jpi, jj) = ib2(iright, jj) END DO ELSE IF ( ASSOCIATED(b3) ) THEN #if defined key_z_first DO jj = 1, jprecj, 1 ! Bottom rows DO ii = nldi, nlei, 1 DO jk = 1,kdim1,1 b3(ii, jj, jk) = b3(ii,nldj,jk) ! Bottom rows END DO END DO DO ii = 1, jpreci, 1 DO jk = 1,kdim1,1 b3(ii , jj, jk) = b3(ileft ,nldj,jk) ! Bottom-L corner END DO END DO DO ii = nlci, jpi, 1 DO jk = 1,kdim1,1 b3(ii , jj, jk) = b3(iright ,nldj,jk) ! Bottom-R corner END DO END DO END DO DO jj = nlej+1, jpj, 1 ! Top rows DO ii = nldi, nlei, 1 DO jk = 1,kdim1,1 b3(ii, jj,jk) = b3(ii,nlej,jk) ! Top rows END DO END DO DO ii = 1, jpreci, 1 DO jk = 1,kdim1,1 b3(ii, jj,jk) = b3(ileft,nlej,jk) ! Top-L corner pts END DO END DO DO ii = nlci, jpi, 1 DO jk = 1,kdim1,1 b3(ii,jj,jk) = b3(iright,nlej,jk) ! Top-R corner pts END DO END DO END DO DO jj = nldj, nlej, 1 ! E-most columns DO ii = nlci, jpi, 1 DO jk = 1,kdim1,1 b3(ii, jj, jk) = b3(iright, jj, jk) END DO END DO ! W-most columns DO ii = 1, jpreci, 1 DO jk = 1,kdim1,1 b3(ii, jj, jk) = b3(ileft, jj, jk) END DO END DO END DO #else jk_loop: DO jk = 1,kdim1,1 DO jj = 1, jprecj, 1 ! Bottom rows b3(nldi:nlei, jj, jk) = b3(nldi:nlei,nldj,jk) ! Bottom rows b3(1:jpreci , jj, jk) = b3(ileft ,nldj,jk) ! Bottom-L corner b3(nlci:jpi , jj, jk) = b3(iright ,nldj,jk) ! Bottom-R corner END DO DO jj = nlej+1, jpj, 1 ! Top rows b3(nldi:nlei, jj,jk) = b3(nldi:nlei,nlej,jk) ! Top rows b3(1:jpreci , jj,jk) = b3(ileft ,nlej,jk) ! Top-L corner pts b3(nlci:jpi , jj,jk) = b3(iright ,nlej,jk) ! Top-R corner pts END DO DO jj = nldj, nlej, 1 ! E-most columns b3(nlci:jpi, jj, jk) = b3(iright, jj, jk) END DO DO jj = nldj, nlej, 1 ! W-most columns b3(1:jpreci, jj, jk) = b3(ileft, jj, jk) END DO END DO jk_loop #endif ELSE IF ( ASSOCIATED(ib3) ) THEN #if defined key_z_first ! ARPDBG need make loops over i explicit for optimum performance DO jj = 1,jprecj ! Bottom rows DO jk = 1,kdim1,1 ib3(nldi:nlei, jj, jk) = ib3(nldi:nlei,nldj,jk) ! Bottom rows ib3(1:jpreci, jj, jk) = ib3(ileft ,nldj,jk) ! Bottom-L corner ib3(nlci:jpi,jj, jk) = ib3(iright ,nldj,jk) ! Bottom-R corner END DO END DO DO jj = nlej+1, jpj ! Top rows DO jk = 1,kdim1,1 ib3(nldi:nlei,jj,jk) = ib3(nldi:nlei,nlej,jk) ! Top rows ib3(1:jpreci ,jj,jk) = ib3(ileft ,nlej,jk) ! Top-L corner pts ib3(nlci:jpi ,jj,jk) = ib3(iright ,nlej,jk) ! Top-R corner pts END DO END DO DO jj = nldj,nlej, 1 ! E-most columns DO jk = 1,kdim1,1 ib3(nlci:jpi, jj, jk) = ib3(iright, jj, jk) END DO END DO DO jj = nldj,nlej,1 ! W-most columns DO jk = 1,kdim1,1 ib3(1:jpreci, jj, jk) = ib3(ileft, jj, jk) END DO END DO #else DO jk = 1,kdim1,1 DO jj = 1,jprecj ! Bottom rows ib3(nldi:nlei, jj, jk) = ib3(nldi:nlei,nldj,jk) ! Bottom rows ib3(1:jpreci, jj, jk) = ib3(ileft ,nldj,jk) ! Bottom-L corner ib3(nlci:jpi,jj, jk) = ib3(iright ,nldj,jk) ! Bottom-R corner END DO DO jj = nlej+1, jpj ! Top rows ib3(nldi:nlei,jj,jk) = ib3(nldi:nlei,nlej,jk) ! Top rows ib3(1:jpreci ,jj,jk) = ib3(ileft ,nlej,jk) ! Top-L corner pts ib3(nlci:jpi ,jj,jk) = ib3(iright ,nlej,jk) ! Top-R corner pts END DO DO jj = nldj,nlej, 1 ! E-most columns ib3(nlci:jpi, jj, jk) = ib3(iright, jj, jk) END DO DO jj = nldj,nlej,1 ! W-most columns ib3(1:jpreci, jj, jk) = ib3(ileft, jj, jk) END DO END DO #endif END IF ELSE ! lfill is .FALSE. for this field ! ! East-West boundaries ! ! ==================== IF( nbondi == 2 .AND. & ! Cyclic east-west & (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN IF ( ASSOCIATED(b2) ) THEN b2( 1 ,:) = b2(jpim1,:) ! Set west halo to last valid east value b2(jpi,:) = b2(nldi ,:) ! east halo to first valid west value ELSE IF ( ASSOCIATED(ib2) ) THEN ib2( 1 ,:) = ib2(jpim1,:) ib2(jpi,:) = ib2(nldi ,:) ELSE IF ( ASSOCIATED(b3) ) THEN b3( 1, :, :) = b3(jpim1, :, :) b3(jpi,:, :) = b3( 2, :, :) ELSE IF ( ASSOCIATED(ib3) ) THEN ib3( 1, :, :) = ib3(jpim1, :, :) ib3(jpi,:, :) = ib3( 2, :, :) END IF ELSE ! ... closed END IF ! ! North-South boundaries ! ! ====================== IF ( ASSOCIATED(b2) ) THEN SELECT CASE ( exch_list(ifield)%grid ) CASE ( 'T', 'U', 'V', 'W' , 'I' ) b2(:,1:jprecj ) = 0.0_wp b2(:,nlcj-jprecj+1:jpj) = 0.0_wp CASE ( 'F' ) b2(:,nlcj-jprecj+1:jpj) = 0.0_wp END SELECT ELSE IF ( ASSOCIATED(ib2) ) THEN SELECT CASE ( exch_list(ifield)%grid ) CASE ( 'T', 'U', 'V', 'W' , 'I' ) ib2(:,1:jprecj ) = 0 ib2(:,nlcj-jprecj+1:jpj) = 0 CASE ( 'F' ) ib2(:,nlcj-jprecj+1:jpj) = 0 END SELECT ELSE IF ( ASSOCIATED(b3) ) THEN SELECT CASE ( exch_list(ifield)%grid ) CASE ( 'T', 'U', 'V', 'W' ) b3(:, 1:jprecj , :) = 0.0_wp b3(:, nlcj-jprecj+1:jpj, :) = 0.0_wp CASE ( 'F' ) b3(:, nlcj-jprecj+1:jpj, :) = 0.0_wp END SELECT ELSE IF ( ASSOCIATED(ib3) ) THEN SELECT CASE ( exch_list(ifield)%grid ) CASE ( 'T', 'U', 'V', 'W' ) ib3(:, 1:jprecj , :) = 0 ib3(:, nlcj-jprecj+1:jpj, :) = 0 CASE ( 'F' ) ib3(:, nlcj-jprecj+1:jpj, :) = 0 END SELECT END IF END IF ! lfillarg END DO ! loop over fields ! Do East-West and North-South exchanges CALL exchs_generic_list ( exch_list, nfields ) ! Apply north-fold condition to those fields that need it and delete the ! others from the list CALL apply_north_fold_list(exch_list, nfields) ! Update East and West halos on those fields that have just had the ! north-fold condition applied (will be the only ones left in the list ! as the others are removed within apply_north_fold_list.) ! ARPDBG - inefficient - can this be done within apply_north_fold? CALL exchs_generic_list (exch_list, nfields) CALL prof_region_end(ARPLISTCOMMS, iprofStat) DO ifield=1,nfields,1 NULLIFY(exch_list(ifield)%r2dptr, exch_list(ifield)%r3dptr, & exch_list(ifield)%i2dptr, exch_list(ifield)%i3dptr) END DO nextFreeExchItem = 1 END SUBROUTINE bound_exch_list !========================================================================= SUBROUTINE apply_north_fold_list(list, nfields) USE par_oce, ONLY: wp, jpni, jpk USE dom_oce, ONLY: npolj IMPLICIT none ! Subroutine arguments. TYPE (exch_item), DIMENSION(:), INTENT(inout) :: list INTEGER, INTENT(in) :: nfields ! Local variables INTEGER :: ifield INTEGER :: icount icount = 0 DO ifield = 1, nfields, 1 IF(list(ifield)%lfill)THEN ! This field doesn't have north-fold condition applied to it ! so wipe its entry... CALL wipe_exch(list(ifield)) icount = icount + 1 ! ...and don't do any more with it CYCLE END IF END DO ! Check whether any of the fields need the north-fold condition ! applied IF(icount .eq. nfields)RETURN ! Treatment without exchange (jpni odd) SELECT CASE ( jpni ) CASE ( 1 ) ! only one proc along i, no mpp exchange DO ifield = 1, nfields, 1 IF(ASSOCIATED(list(ifield)%r2dptr))THEN CALL apply_north_fold_jpni1_2dr(list(ifield)) ELSE IF(ASSOCIATED(list(ifield)%r3dptr))THEN CALL apply_north_fold_jpni1_3dr(list(ifield)) ELSE IF(ASSOCIATED(list(ifield)%i2dptr))THEN CALL apply_north_fold_jpni1_2di(list(ifield)) ELSE IF(ASSOCIATED(list(ifield)%i3dptr))THEN CALL apply_north_fold_jpni1_3di(list(ifield)) END IF END DO ! Loop over fields CASE DEFAULT ! more than 1 proc along I DO ifield = 1, nfields, 1 IF( npolj /= 0 .AND. do_nfold )THEN ! only for northern procs. IF(ASSOCIATED(list(ifield)%r2dptr))THEN CALL mpp_lbc_north( list(ifield)%r2dptr, list(ifield)%grid, & REAL(list(ifield)%isgn,wp) ) ELSE IF(ASSOCIATED(list(ifield)%r3dptr))THEN CALL mpp_lbc_north( list(ifield)%r3dptr, list(ifield)%grid, & REAL(list(ifield)%isgn,wp) ) ELSE IF(ASSOCIATED(list(ifield)%i2dptr))THEN CALL mpp_lbc_north( list(ifield)%i2dptr, list(ifield)%grid, & list(ifield)%isgn ) ELSE IF(ASSOCIATED(list(ifield)%i3dptr))THEN CALL mpp_lbc_north( list(ifield)%i3dptr, list(ifield)%grid, & list(ifield)%isgn ) END IF END IF END DO !!$ IF( npolj /= 0 .AND. do_nfold ) CALL mpp_lbc_north_list( list, nfields ) ! only for northern procs. END SELECT ! jpni END SUBROUTINE apply_north_fold_list !========================================================================= SUBROUTINE apply_north_fold_jpni1_2dr(item) USE dom_oce, ONLY: npolj, nlci, nlcj, nimpp USE lib_mpp, ONLY: ctl_stop IMPLICIT None TYPE (exch_item), INTENT(inout) :: item ! Locals INTEGER :: iloc, ji, ijt, iju REAL(wp) :: psgn REAL(wp), DIMENSION(:,:), POINTER :: b2 !#if defined key_z_first ! CALL ctl_stop('STOP', & ! 'apply_north_fold_jpni1_2dr: key_z_first not implemented for north fold') ! RETURN !#endif psgn = REAL(item%isgn, wp) b2 => item%r2dptr SELECT CASE ( npolj ) CASE ( 3 , 4 ) ! T pivot iloc = jpiglo - 2 * ( nimpp - 1 ) SELECT CASE ( item%grid ) CASE ( 'T' , 'S', 'W' ) DO ji = 2, nlci ijt=iloc-ji+2 b2(ji,nlcj) = psgn * b2(ijt,nlcj-2) END DO DO ji = nlci/2+1, nlci ijt=iloc-ji+2 b2(ji,nlcj-1) = psgn * b2(ijt,nlcj-1) END DO CASE ( 'U' ) DO ji = 1, nlci-1 iju=iloc-ji+1 b2(ji,nlcj) = psgn * b2(iju,nlcj-2) END DO DO ji = nlci/2, nlci-1 iju=iloc-ji+1 b2(ji,nlcj-1) = psgn * b2(iju,nlcj-1) END DO CASE ( 'V' ) DO ji = 2, nlci ijt=iloc-ji+2 b2(ji,nlcj-1) = psgn * b2(ijt,nlcj-2) b2(ji,nlcj ) = psgn * b2(ijt,nlcj-3) END DO CASE ( 'F', 'G' ) DO ji = 1, nlci-1 iju=iloc-ji+1 b2(ji,nlcj-1) = psgn * b2(iju,nlcj-2) b2(ji,nlcj ) = psgn * b2(iju,nlcj-3) END DO CASE ( 'I' ) ! ice U-V point b2(2,nlcj) = psgn * b2(3,nlcj-1) DO ji = 3, nlci iju = iloc - ji + 3 b2(ji,nlcj) = psgn * b2(iju,nlcj-1) END DO END SELECT CASE ( 5 , 6 ) ! F pivot iloc=jpiglo-2*(nimpp-1) SELECT CASE (item%grid) CASE ( 'T', 'S', 'W' ) DO ji = 1, nlci ijt=iloc-ji+1 b2(ji,nlcj) = psgn * b2(ijt,nlcj-1) END DO CASE ( 'U' ) DO ji = 1, nlci-1 iju=iloc-ji b2(ji,nlcj) = psgn * b2(iju,nlcj-1) END DO CASE ( 'V' ) DO ji = 1, nlci ijt=iloc-ji+1 b2(ji,nlcj ) = psgn * b2(ijt,nlcj-2) END DO DO ji = nlci/2+1, nlci ijt=iloc-ji+1 b2(ji,nlcj-1) = psgn * b2(ijt,nlcj-1) END DO CASE ( 'F', 'G' ) DO ji = 1, nlci-1 iju=iloc-ji b2(ji,nlcj) = psgn * b2(iju,nlcj-2) END DO DO ji = nlci/2+1, nlci-1 iju=iloc-ji b2(ji,nlcj-1) = psgn * b2(iju,nlcj-1) END DO CASE ( 'I' ) ! ice U-V point b2( 2 ,nlcj) = 0._wp DO ji = 2 , nlci-1 ijt = iloc - ji + 2 b2(ji,nlcj)= 0.5 * ( b2(ji,nlcj-1) + psgn * b2(ijt,nlcj-1) ) END DO END SELECT ! cd_type END SELECT ! npolj END SUBROUTINE apply_north_fold_jpni1_2dr !========================================================================= SUBROUTINE apply_north_fold_jpni1_3dr(item) USE dom_oce, ONLY: npolj, nlci, nlcj, nimpp USE lib_mpp, ONLY: ctl_stop IMPLICIT None TYPE (exch_item), INTENT(inout) :: item !FTRANS b3 :I :I :z ! Locals INTEGER :: iloc, ji, jk, ijt, iju REAL(wp) :: psgn REAL(wp), DIMENSION(:,:,:), POINTER :: b3 !#if defined key_z_first ! CALL ctl_stop('STOP', & ! 'apply_north_fold_jpni1_3dr: key_z_first not implemented for north fold') ! RETURN !#endif psgn = REAL(item%isgn, wp) b3 => item%r3dptr SELECT CASE ( npolj ) CASE ( 3 , 4 ) ! T pivot iloc = jpiglo - 2 * ( nimpp - 1 ) SELECT CASE ( item%grid ) CASE ( 'T' , 'S', 'W' ) #if defined key_z_first DO ji = 2, nlci DO jk = 1, jpk ijt=iloc-ji+2 b3(ji,nlcj,jk) = psgn * b3(ijt,nlcj-2,jk) END DO END DO DO ji = nlci/2+1, nlci DO jk = 1, jpk ijt=iloc-ji+2 b3(ji,nlcj-1,jk) = psgn * b3(ijt,nlcj-1,jk) END DO END DO #else DO jk = 1, jpk DO ji = 2, nlci ijt=iloc-ji+2 b3(ji,nlcj,jk) = psgn * b3(ijt,nlcj-2,jk) END DO DO ji = nlci/2+1, nlci ijt=iloc-ji+2 b3(ji,nlcj-1,jk) = psgn * b3(ijt,nlcj-1,jk) END DO END DO #endif CASE ( 'U' ) #if defined key_z_first DO ji = 1, nlci-1 DO jk = 1, jpk iju=iloc-ji+1 b3(ji,nlcj,jk) = psgn * b3(iju,nlcj-2,jk) END DO END DO DO ji = nlci/2, nlci-1 DO jk = 1, jpk iju=iloc-ji+1 b3(ji,nlcj-1,jk) = psgn * b3(iju,nlcj-1,jk) END DO END DO #else DO jk = 1, jpk DO ji = 1, nlci-1 iju=iloc-ji+1 b3(ji,nlcj,jk) = psgn * b3(iju,nlcj-2,jk) END DO DO ji = nlci/2, nlci-1 iju=iloc-ji+1 b3(ji,nlcj-1,jk) = psgn * b3(iju,nlcj-1,jk) END DO END DO #endif CASE ( 'V' ) #if defined key_z_first DO ji = 2, nlci DO jk = 1, jpk #else DO jk = 1, jpk DO ji = 2, nlci #endif ijt=iloc-ji+2 b3(ji,nlcj-1,jk) = psgn * b3(ijt,nlcj-2,jk) b3(ji,nlcj ,jk) = psgn * b3(ijt,nlcj-3,jk) END DO END DO CASE ( 'F', 'G' ) #if defined key_z_first DO ji = 1, nlci-1 DO jk = 1, jpk #else DO jk = 1, jpk DO ji = 1, nlci-1 #endif iju=iloc-ji+1 b3(ji,nlcj-1,jk) = psgn * b3(iju,nlcj-2,jk) b3(ji,nlcj ,jk) = psgn * b3(iju,nlcj-3,jk) END DO END DO END SELECT CASE ( 5 , 6 ) ! F pivot iloc=jpiglo-2*(nimpp-1) SELECT CASE ( item%grid ) CASE ( 'T' , 'S', 'W' ) #if defined key_z_first DO ji = 1, nlci DO jk = 1, jpk #else DO jk = 1, jpk DO ji = 1, nlci #endif ijt=iloc-ji+1 b3(ji,nlcj,jk) = psgn * b3(ijt,nlcj-1,jk) END DO END DO CASE ( 'U' ) #if defined key_z_first DO ji = 1, nlci-1 DO jk = 1, jpk #else DO jk = 1, jpk DO ji = 1, nlci-1 #endif iju=iloc-ji b3(ji,nlcj,jk) = psgn * b3(iju,nlcj-1,jk) END DO END DO CASE ( 'V' ) #if defined key_z_first DO ji = 1, nlci DO jk = 1, jpk ijt=iloc-ji+1 b3(ji,nlcj ,jk) = psgn * b3(ijt,nlcj-2,jk) END DO END DO DO ji = nlci/2+1, nlci DO jk = 1, jpk ijt=iloc-ji+1 b3(ji,nlcj-1,jk) = psgn * b3(ijt,nlcj-1,jk) END DO END DO #else DO jk = 1, jpk DO ji = 1, nlci ijt=iloc-ji+1 b3(ji,nlcj ,jk) = psgn * b3(ijt,nlcj-2,jk) END DO DO ji = nlci/2+1, nlci ijt=iloc-ji+1 b3(ji,nlcj-1,jk) = psgn * b3(ijt,nlcj-1,jk) END DO END DO #endif CASE ( 'F', 'G' ) #if defined key_z_first DO ji = 1, nlci-1 DO jk = 1, jpk iju=iloc-ji b3(ji,nlcj,jk) = psgn * b3(iju,nlcj-2,jk) END DO END DO DO ji = nlci/2+1, nlci-1 DO jk = 1, jpk iju=iloc-ji b3(ji,nlcj-1,jk) = psgn * b3(iju,nlcj-1,jk) END DO END DO #else DO jk = 1, jpk DO ji = 1, nlci-1 iju=iloc-ji b3(ji,nlcj,jk) = psgn * b3(iju,nlcj-2,jk) END DO DO ji = nlci/2+1, nlci-1 iju=iloc-ji b3(ji,nlcj-1,jk) = psgn * b3(iju,nlcj-1,jk) END DO END DO #endif END SELECT ! item%grid type END SELECT ! npolj END SUBROUTINE apply_north_fold_jpni1_3dr !========================================================================= SUBROUTINE apply_north_fold_jpni1_2di(item) USE dom_oce, ONLY: npolj, nlci, nlcj, nimpp USE lib_mpp, ONLY: ctl_stop IMPLICIT None TYPE (exch_item), INTENT(inout) :: item ! Locals INTEGER :: iloc, ji, ijt, iju INTEGER :: isgn INTEGER, DIMENSION(:,:), POINTER :: ib2 isgn = item%isgn ib2 => item%i2dptr SELECT CASE ( npolj ) CASE ( 3 , 4 ) ! T pivot iloc = jpiglo - 2 * ( nimpp - 1 ) SELECT CASE ( item%grid ) CASE ( 'T' , 'S', 'W' ) DO ji = 2, nlci ijt=iloc-ji+2 ib2(ji,nlcj) = isgn * ib2(ijt,nlcj-2) END DO DO ji = nlci/2+1, nlci ijt=iloc-ji+2 ib2(ji,nlcj-1) = isgn * ib2(ijt,nlcj-1) END DO CASE ( 'U' ) DO ji = 1, nlci-1 iju=iloc-ji+1 ib2(ji,nlcj) = isgn * ib2(iju,nlcj-2) END DO DO ji = nlci/2, nlci-1 iju=iloc-ji+1 ib2(ji,nlcj-1) = isgn * ib2(iju,nlcj-1) END DO CASE ( 'V' ) DO ji = 2, nlci ijt=iloc-ji+2 ib2(ji,nlcj-1) = isgn * ib2(ijt,nlcj-2) ib2(ji,nlcj ) = isgn * ib2(ijt,nlcj-3) END DO CASE ( 'F', 'G' ) DO ji = 1, nlci-1 iju=iloc-ji+1 ib2(ji,nlcj-1) = isgn * ib2(iju,nlcj-2) ib2(ji,nlcj ) = isgn * ib2(iju,nlcj-3) END DO CASE ( 'I' ) ! ice U-V point ib2(2,nlcj) = isgn * ib2(3,nlcj-1) DO ji = 3, nlci iju = iloc - ji + 3 ib2(ji,nlcj) = isgn * ib2(iju,nlcj-1) END DO END SELECT CASE ( 5 , 6 ) ! F pivot iloc=jpiglo-2*(nimpp-1) SELECT CASE (item%grid) CASE ( 'T', 'S', 'W' ) DO ji = 1, nlci ijt=iloc-ji+1 ib2(ji,nlcj) = isgn * ib2(ijt,nlcj-1) END DO CASE ( 'U' ) DO ji = 1, nlci-1 iju=iloc-ji ib2(ji,nlcj) = isgn * ib2(iju,nlcj-1) END DO CASE ( 'V' ) DO ji = 1, nlci ijt=iloc-ji+1 ib2(ji,nlcj ) = isgn * ib2(ijt,nlcj-2) END DO DO ji = nlci/2+1, nlci ijt=iloc-ji+1 ib2(ji,nlcj-1) = isgn * ib2(ijt,nlcj-1) END DO CASE ( 'F', 'G' ) DO ji = 1, nlci-1 iju=iloc-ji ib2(ji,nlcj) = isgn * ib2(iju,nlcj-2) END DO DO ji = nlci/2+1, nlci-1 iju=iloc-ji ib2(ji,nlcj-1) = isgn * ib2(iju,nlcj-1) END DO CASE ( 'I' ) ! ice U-V point ib2( 2 ,nlcj) = 0._wp DO ji = 2 , nlci-1 ijt = iloc - ji + 2 ib2(ji,nlcj)= INT(0.5 * ( ib2(ji,nlcj-1) + isgn * ib2(ijt,nlcj-1) )) END DO END SELECT ! cd_type END SELECT ! npolj END SUBROUTINE apply_north_fold_jpni1_2di !========================================================================= SUBROUTINE apply_north_fold_jpni1_3di(item) USE dom_oce, ONLY: npolj, nlci, nlcj, nimpp USE lib_mpp, ONLY: ctl_stop IMPLICIT None TYPE (exch_item), INTENT(inout) :: item !FTRANS ib3 :I :I :z ! Locals INTEGER :: iloc, ji, ijt, iju, jk INTEGER :: isgn INTEGER, DIMENSION(:,:,:), POINTER :: ib3 isgn = item%isgn ib3 => item%i3dptr SELECT CASE ( npolj ) CASE ( 3 , 4 ) ! T pivot iloc = jpiglo - 2 * ( nimpp - 1 ) SELECT CASE ( item%grid ) CASE ( 'T' , 'S', 'W' ) #if defined key_z_first DO ji = 2, nlci DO jk = 1, jpk ijt=iloc-ji+2 ib3(ji,nlcj,jk) = isgn * ib3(ijt,nlcj-2,jk) END DO END DO DO ji = nlci/2+1, nlci DO jk = 1, jpk ijt=iloc-ji+2 ib3(ji,nlcj-1,jk) = isgn * ib3(ijt,nlcj-1,jk) END DO END DO #else DO jk = 1, jpk DO ji = 2, nlci ijt=iloc-ji+2 ib3(ji,nlcj,jk) = isgn * ib3(ijt,nlcj-2,jk) END DO DO ji = nlci/2+1, nlci ijt=iloc-ji+2 ib3(ji,nlcj-1,jk) = isgn * ib3(ijt,nlcj-1,jk) END DO END DO #endif CASE ( 'U' ) #if defined key_z_first DO ji = 1, nlci-1 DO jk = 1, jpk iju=iloc-ji+1 ib3(ji,nlcj,jk) = isgn * ib3(iju,nlcj-2,jk) END DO END DO DO ji = nlci/2, nlci-1 DO jk = 1, jpk iju=iloc-ji+1 ib3(ji,nlcj-1,jk) = isgn * ib3(iju,nlcj-1,jk) END DO END DO #else DO jk = 1, jpk DO ji = 1, nlci-1 iju=iloc-ji+1 ib3(ji,nlcj,jk) = isgn * ib3(iju,nlcj-2,jk) END DO DO ji = nlci/2, nlci-1 iju=iloc-ji+1 ib3(ji,nlcj-1,jk) = isgn * ib3(iju,nlcj-1,jk) END DO END DO #endif CASE ( 'V' ) #if defined key_z_first DO ji = 2, nlci DO jk = 1, jpk #else DO jk = 1, jpk DO ji = 2, nlci #endif ijt=iloc-ji+2 ib3(ji,nlcj-1,jk) = isgn * ib3(ijt,nlcj-2,jk) ib3(ji,nlcj ,jk) = isgn * ib3(ijt,nlcj-3,jk) END DO END DO CASE ( 'F', 'G' ) #if defined key_z_first DO ji = 1, nlci-1 DO jk = 1, jpk #else DO jk = 1, jpk DO ji = 1, nlci-1 #endif iju=iloc-ji+1 ib3(ji,nlcj-1,jk) = isgn * ib3(iju,nlcj-2,jk) ib3(ji,nlcj ,jk) = isgn * ib3(iju,nlcj-3,jk) END DO END DO END SELECT CASE ( 5 , 6 ) ! F pivot iloc=jpiglo-2*(nimpp-1) SELECT CASE ( item%grid ) CASE ( 'T' , 'S', 'W' ) #if defined key_z_first DO ji = 1, nlci DO jk = 1, jpk #else DO jk = 1, jpk DO ji = 1, nlci #endif ijt=iloc-ji+1 ib3(ji,nlcj,jk) = isgn * ib3(ijt,nlcj-1,jk) END DO END DO CASE ( 'U' ) #if defined key_z_first DO ji = 1, nlci-1 DO jk = 1, jpk #else DO jk = 1, jpk DO ji = 1, nlci-1 #endif iju=iloc-ji ib3(ji,nlcj,jk) = isgn * ib3(iju,nlcj-1,jk) END DO END DO CASE ( 'V' ) #if defined key_z_first DO ji = 1, nlci DO jk = 1, jpk ijt=iloc-ji+1 ib3(ji,nlcj ,jk) = isgn * ib3(ijt,nlcj-2,jk) END DO END DO DO ji = nlci/2+1, nlci DO jk = 1, jpk ijt=iloc-ji+1 ib3(ji,nlcj-1,jk) = isgn * ib3(ijt,nlcj-1,jk) END DO END DO #else DO jk = 1, jpk DO ji = 1, nlci ijt=iloc-ji+1 ib3(ji,nlcj ,jk) = isgn * ib3(ijt,nlcj-2,jk) END DO DO ji = nlci/2+1, nlci ijt=iloc-ji+1 ib3(ji,nlcj-1,jk) = isgn * ib3(ijt,nlcj-1,jk) END DO END DO #endif CASE ( 'F', 'G' ) #if defined key_z_first DO ji = 1, nlci-1 DO jk = 1, jpk iju=iloc-ji ib3(ji,nlcj,jk) = isgn * ib3(iju,nlcj-2,jk) END DO END DO DO ji = nlci/2+1, nlci-1 DO jk = 1, jpk iju=iloc-ji ib3(ji,nlcj-1,jk) = isgn * ib3(iju,nlcj-1,jk) END DO END DO #else DO jk = 1, jpk DO ji = 1, nlci-1 iju=iloc-ji ib3(ji,nlcj,jk) = isgn * ib3(iju,nlcj-2,jk) END DO DO ji = nlci/2+1, nlci-1 iju=iloc-ji ib3(ji,nlcj-1,jk) = isgn * ib3(iju,nlcj-1,jk) END DO END DO #endif END SELECT ! item%grid type END SELECT ! npolj END SUBROUTINE apply_north_fold_jpni1_3di !========================================================================= SUBROUTINE apply_north_fold2(b2, isgn, cd_type) USE par_oce, ONLY: wp, jpni, jpk USE dom_oce, ONLY: npolj, nlci, nlcj, nimpp USE lib_mpp, ONLY: ctl_stop IMPLICIT none REAL(wp),OPTIONAL, INTENT(inout), DIMENSION(1:, 1:) :: b2 INTEGER, INTENT(in) :: isgn CHARACTER (LEN=1), INTENT(in) :: cd_type ! Local variables INTEGER :: ji, ijt, iju, iloc REAL(wp) :: psgn psgn = REAL(isgn, wp) ! Treatment without exchange (jpni odd) SELECT CASE ( jpni ) CASE ( 1 ) ! only one proc along I, no mpp exchange SELECT CASE ( npolj ) CASE ( 3 , 4 ) ! T pivot iloc = jpiglo - 2 * ( nimpp - 1 ) SELECT CASE ( cd_type ) CASE ( 'T' , 'S', 'W' ) DO ji = 2, nlci ijt=iloc-ji+2 b2(ji,nlcj) = psgn * b2(ijt,nlcj-2) END DO DO ji = nlci/2+1, nlci ijt=iloc-ji+2 b2(ji,nlcj-1) = psgn * b2(ijt,nlcj-1) END DO CASE ( 'U' ) DO ji = 1, nlci-1 iju=iloc-ji+1 b2(ji,nlcj) = psgn * b2(iju,nlcj-2) END DO DO ji = nlci/2, nlci-1 iju=iloc-ji+1 b2(ji,nlcj-1) = psgn * b2(iju,nlcj-1) END DO CASE ( 'V' ) DO ji = 2, nlci ijt=iloc-ji+2 b2(ji,nlcj-1) = psgn * b2(ijt,nlcj-2) b2(ji,nlcj ) = psgn * b2(ijt,nlcj-3) END DO CASE ( 'F', 'G' ) DO ji = 1, nlci-1 iju=iloc-ji+1 b2(ji,nlcj-1) = psgn * b2(iju,nlcj-2) b2(ji,nlcj ) = psgn * b2(iju,nlcj-3) END DO CASE ( 'I' ) ! ice U-V point b2(2,nlcj) = psgn * b2(3,nlcj-1) DO ji = 3, nlci iju = iloc - ji + 3 b2(ji,nlcj) = psgn * b2(iju,nlcj-1) END DO END SELECT CASE ( 5 , 6 ) ! F pivot iloc=jpiglo-2*(nimpp-1) SELECT CASE (cd_type ) CASE ( 'T', 'S', 'W' ) DO ji = 1, nlci ijt=iloc-ji+1 b2(ji,nlcj) = psgn * b2(ijt,nlcj-1) END DO CASE ( 'U' ) DO ji = 1, nlci-1 iju=iloc-ji b2(ji,nlcj) = psgn * b2(iju,nlcj-1) END DO CASE ( 'V' ) DO ji = 1, nlci ijt=iloc-ji+1 b2(ji,nlcj ) = psgn * b2(ijt,nlcj-2) END DO DO ji = nlci/2+1, nlci ijt=iloc-ji+1 b2(ji,nlcj-1) = psgn * b2(ijt,nlcj-1) END DO CASE ( 'F', 'G' ) DO ji = 1, nlci-1 iju=iloc-ji b2(ji,nlcj) = psgn * b2(iju,nlcj-2) END DO DO ji = nlci/2+1, nlci-1 iju=iloc-ji b2(ji,nlcj-1) = psgn * b2(iju,nlcj-1) END DO CASE ( 'I' ) ! ice U-V point b2( 2 ,nlcj) = 0._wp DO ji = 2 , nlci-1 ijt = iloc - ji + 2 b2(ji,nlcj)= 0.5 * ( b2(ji,nlcj-1) + psgn * b2(ijt,nlcj-1) ) END DO END SELECT ! cd_type END SELECT ! npolj CASE DEFAULT ! more than 1 proc along I IF( npolj /= 0 .AND. do_nfold ) CALL mpp_lbc_north( b2, cd_type, psgn ) ! only for northern procs. END SELECT ! jpni END SUBROUTINE apply_north_fold2 !========================================================================= SUBROUTINE apply_north_fold2i(ib2, isgn, cd_type) USE par_oce, ONLY: wp, jpni, jpk USE dom_oce, ONLY: npolj, nlci, nlcj, nimpp USE lib_mpp, ONLY: ctl_stop IMPLICIT none INTEGER, INTENT(inout), DIMENSION(1:, 1:) :: ib2 INTEGER, INTENT(in) :: isgn CHARACTER (LEN=1), INTENT(in) :: cd_type ! Local variables INTEGER :: ji, ijt, iju, iloc #if defined key_z_first CALL ctl_stop('STOP', & 'apply_north_fold2i: key_z_first not implemented for north fold') RETURN #endif ! Treatment without exchange (jpni odd) SELECT CASE ( jpni ) CASE ( 1 ) ! only one proc along I, no mpp exchange SELECT CASE ( npolj ) CASE ( 3 , 4 ) ! T pivot iloc = jpiglo - 2 * ( nimpp - 1 ) SELECT CASE ( cd_type ) CASE ( 'T' , 'S', 'W' ) DO ji = 2, nlci ijt=iloc-ji+2 ib2(ji,nlcj) = isgn * ib2(ijt,nlcj-2) END DO DO ji = nlci/2+1, nlci ijt=iloc-ji+2 ib2(ji,nlcj-1) = isgn * ib2(ijt,nlcj-1) END DO CASE ( 'U' ) DO ji = 1, nlci-1 iju=iloc-ji+1 ib2(ji,nlcj) = isgn * ib2(iju,nlcj-2) END DO DO ji = nlci/2, nlci-1 iju=iloc-ji+1 ib2(ji,nlcj-1) = isgn * ib2(iju,nlcj-1) END DO CASE ( 'V' ) DO ji = 2, nlci ijt=iloc-ji+2 ib2(ji,nlcj-1) = isgn * ib2(ijt,nlcj-2) ib2(ji,nlcj ) = isgn * ib2(ijt,nlcj-3) END DO CASE ( 'F', 'G' ) DO ji = 1, nlci-1 iju=iloc-ji+1 ib2(ji,nlcj-1) = isgn * ib2(iju,nlcj-2) ib2(ji,nlcj ) = isgn * ib2(iju,nlcj-3) END DO CASE ( 'I' ) ! ice U-V point ib2(2,nlcj) = isgn * ib2(3,nlcj-1) DO ji = 3, nlci iju = iloc - ji + 3 ib2(ji,nlcj) = isgn * ib2(iju,nlcj-1) END DO END SELECT CASE ( 5 , 6 ) ! F pivot iloc=jpiglo-2*(nimpp-1) SELECT CASE (cd_type ) CASE ( 'T', 'S', 'W' ) DO ji = 1, nlci ijt=iloc-ji+1 ib2(ji,nlcj) = isgn * ib2(ijt,nlcj-1) END DO CASE ( 'U' ) DO ji = 1, nlci-1 iju=iloc-ji ib2(ji,nlcj) = isgn * ib2(iju,nlcj-1) END DO CASE ( 'V' ) DO ji = 1, nlci ijt=iloc-ji+1 ib2(ji,nlcj ) = isgn * ib2(ijt,nlcj-2) END DO DO ji = nlci/2+1, nlci ijt=iloc-ji+1 ib2(ji,nlcj-1) = isgn * ib2(ijt,nlcj-1) END DO CASE ( 'F', 'G' ) DO ji = 1, nlci-1 iju=iloc-ji ib2(ji,nlcj) = isgn * ib2(iju,nlcj-2) END DO DO ji = nlci/2+1, nlci-1 iju=iloc-ji ib2(ji,nlcj-1) = isgn * ib2(iju,nlcj-1) END DO CASE ( 'I' ) ! ice U-V point ib2( 2 ,nlcj) = 0._wp DO ji = 2 , nlci-1 ijt = iloc - ji + 2 ib2(ji,nlcj)= INT(0.5 * ( ib2(ji,nlcj-1) + isgn * ib2(ijt,nlcj-1) )) END DO END SELECT ! cd_type END SELECT ! npolj CASE DEFAULT ! more than 1 proc along I IF( npolj /= 0 .AND. do_nfold) CALL mpp_lbc_north( ib2, cd_type, isgn ) ! only for northern procs. END SELECT ! jpni END SUBROUTINE apply_north_fold2i !========================================================================= SUBROUTINE apply_north_fold3(b3, isgn, cd_type) USE par_oce, ONLY: wp, jpni, jpk USE dom_oce, ONLY: npolj, nlci, nlcj, nimpp USE lib_mpp, ONLY: ctl_stop IMPLICIT none !FTRANS b3 :I :I :z REAL(wp), INTENT(inout), DIMENSION(1:, 1:, 1:) :: b3 INTEGER, INTENT(in) :: isgn CHARACTER (LEN=1), INTENT(in) :: cd_type ! Local variables INTEGER :: ji, jk, ijt, iju, iloc REAL(wp) :: psgn !!---------------------------------------------------------------------- psgn = REAL(isgn, wp) ! Treatment without exchange (jpni odd) ! T-point pivot SELECT CASE ( jpni ) CASE ( 1 ) ! only one proc along I, no mpp exchange SELECT CASE ( npolj ) CASE ( 3 , 4 ) ! T pivot iloc = jpiglo - 2 * ( nimpp - 1 ) SELECT CASE ( cd_type ) CASE ( 'T' , 'S', 'W' ) #if defined key_z_first DO ji = 2, nlci DO jk = 1, jpk ijt=iloc-ji+2 b3(ji,nlcj,jk) = psgn * b3(ijt,nlcj-2,jk) END DO END DO DO ji = nlci/2+1, nlci DO jk = 1, jpk ijt=iloc-ji+2 b3(ji,nlcj-1,jk) = psgn * b3(ijt,nlcj-1,jk) END DO END DO #else DO jk = 1, jpk DO ji = 2, nlci ijt=iloc-ji+2 b3(ji,nlcj,jk) = psgn * b3(ijt,nlcj-2,jk) END DO DO ji = nlci/2+1, nlci ijt=iloc-ji+2 b3(ji,nlcj-1,jk) = psgn * b3(ijt,nlcj-1,jk) END DO END DO #endif CASE ( 'U' ) #if defined key_z_first DO ji = 1, nlci-1 DO jk = 1, jpk iju=iloc-ji+1 b3(ji,nlcj,jk) = psgn * b3(iju,nlcj-2,jk) END DO END DO DO ji = nlci/2, nlci-1 DO jk = 1, jpk iju=iloc-ji+1 b3(ji,nlcj-1,jk) = psgn * b3(iju,nlcj-1,jk) END DO END DO #else DO jk = 1, jpk DO ji = 1, nlci-1 iju=iloc-ji+1 b3(ji,nlcj,jk) = psgn * b3(iju,nlcj-2,jk) END DO DO ji = nlci/2, nlci-1 iju=iloc-ji+1 b3(ji,nlcj-1,jk) = psgn * b3(iju,nlcj-1,jk) END DO END DO #endif CASE ( 'V' ) #if defined key_z_first DO ji = 2, nlci DO jk = 1, jpk #else DO jk = 1, jpk DO ji = 2, nlci #endif ijt=iloc-ji+2 b3(ji,nlcj-1,jk) = psgn * b3(ijt,nlcj-2,jk) b3(ji,nlcj ,jk) = psgn * b3(ijt,nlcj-3,jk) END DO END DO CASE ( 'F', 'G' ) #if defined key_z_first DO ji = 1, nlci-1 DO jk = 1, jpk #else DO jk = 1, jpk DO ji = 1, nlci-1 #endif iju=iloc-ji+1 b3(ji,nlcj-1,jk) = psgn * b3(iju,nlcj-2,jk) b3(ji,nlcj ,jk) = psgn * b3(iju,nlcj-3,jk) END DO END DO END SELECT CASE ( 5 , 6 ) ! F pivot iloc=jpiglo-2*(nimpp-1) SELECT CASE ( cd_type ) CASE ( 'T' , 'S', 'W' ) #if defined key_z_first DO ji = 1, nlci DO jk = 1, jpk #else DO jk = 1, jpk DO ji = 1, nlci #endif ijt=iloc-ji+1 b3(ji,nlcj,jk) = psgn * b3(ijt,nlcj-1,jk) END DO END DO CASE ( 'U' ) #if defined key_z_first DO ji = 1, nlci-1 DO jk = 1, jpk #else DO jk = 1, jpk DO ji = 1, nlci-1 #endif iju=iloc-ji b3(ji,nlcj,jk) = psgn * b3(iju,nlcj-1,jk) END DO END DO CASE ( 'V' ) #if defined key_z_first DO ji = 1, nlci DO jk = 1, jpk ijt=iloc-ji+1 b3(ji,nlcj ,jk) = psgn * b3(ijt,nlcj-2,jk) END DO END DO DO ji = nlci/2+1, nlci DO jk = 1, jpk ijt=iloc-ji+1 b3(ji,nlcj-1,jk) = psgn * b3(ijt,nlcj-1,jk) END DO END DO #else DO jk = 1, jpk DO ji = 1, nlci ijt=iloc-ji+1 b3(ji,nlcj ,jk) = psgn * b3(ijt,nlcj-2,jk) END DO DO ji = nlci/2+1, nlci ijt=iloc-ji+1 b3(ji,nlcj-1,jk) = psgn * b3(ijt,nlcj-1,jk) END DO END DO #endif CASE ( 'F', 'G' ) #if defined key_z_first DO ji = 1, nlci-1 DO jk = 1, jpk iju=iloc-ji b3(ji,nlcj,jk) = psgn * b3(iju,nlcj-2,jk) END DO END DO DO ji = nlci/2+1, nlci-1 DO jk = 1, jpk iju=iloc-ji b3(ji,nlcj-1,jk) = psgn * b3(iju,nlcj-1,jk) END DO END DO #else DO jk = 1, jpk DO ji = 1, nlci-1 iju=iloc-ji b3(ji,nlcj,jk) = psgn * b3(iju,nlcj-2,jk) END DO DO ji = nlci/2+1, nlci-1 iju=iloc-ji b3(ji,nlcj-1,jk) = psgn * b3(iju,nlcj-1,jk) END DO END DO #endif END SELECT ! cd_type END SELECT ! npolj CASE DEFAULT ! more than 1 proc along I IF ( npolj /= 0 .AND. do_nfold) CALL mpp_lbc_north (b3, cd_type, psgn) ! only for northern procs. END SELECT ! jpni END SUBROUTINE apply_north_fold3 !========================================================================= SUBROUTINE apply_north_fold3i(ib3, isgn, cd_type) USE par_oce, ONLY: wp, jpni, jpk USE dom_oce, ONLY: npolj, nlci, nlcj, nimpp USE lib_mpp, ONLY: ctl_stop IMPLICIT none !FTRANS ib3 :I :I :z INTEGER, INTENT(inout), DIMENSION(1:, 1:, :) :: ib3 INTEGER, INTENT(in) :: isgn CHARACTER (LEN=1), INTENT(in) :: cd_type ! Local variables INTEGER :: ji, jk, ijt, iju, iloc ! 4.1 treatment without exchange (jpni odd) ! T-point pivot SELECT CASE ( jpni ) CASE ( 1 ) ! only one proc along I, no mpp exchange SELECT CASE ( npolj ) CASE ( 3 , 4 ) ! T pivot iloc = jpiglo - 2 * ( nimpp - 1 ) SELECT CASE ( cd_type ) CASE ( 'T' , 'S', 'W' ) #if defined key_z_first DO ji = 2, nlci DO jk = 1, jpk ijt=iloc-ji+2 ib3(ji,nlcj,jk) = isgn * ib3(ijt,nlcj-2,jk) END DO END DO DO ji = nlci/2+1, nlci DO jk = 1, jpk ijt=iloc-ji+2 ib3(ji,nlcj-1,jk) = isgn * ib3(ijt,nlcj-1,jk) END DO END DO #else DO jk = 1, jpk DO ji = 2, nlci ijt=iloc-ji+2 ib3(ji,nlcj,jk) = isgn * ib3(ijt,nlcj-2,jk) END DO DO ji = nlci/2+1, nlci ijt=iloc-ji+2 ib3(ji,nlcj-1,jk) = isgn * ib3(ijt,nlcj-1,jk) END DO END DO #endif CASE ( 'U' ) #if defined key_z_first DO ji = 1, nlci-1 DO jk = 1, jpk iju=iloc-ji+1 ib3(ji,nlcj,jk) = isgn * ib3(iju,nlcj-2,jk) END DO END DO DO ji = nlci/2, nlci-1 DO jk = 1, jpk iju=iloc-ji+1 ib3(ji,nlcj-1,jk) = isgn * ib3(iju,nlcj-1,jk) END DO END DO #else DO jk = 1, jpk DO ji = 1, nlci-1 iju=iloc-ji+1 ib3(ji,nlcj,jk) = isgn * ib3(iju,nlcj-2,jk) END DO DO ji = nlci/2, nlci-1 iju=iloc-ji+1 ib3(ji,nlcj-1,jk) = isgn * ib3(iju,nlcj-1,jk) END DO END DO #endif CASE ( 'V' ) #if defined key_z_first DO ji = 2, nlci DO jk = 1, jpk #else DO jk = 1, jpk DO ji = 2, nlci #endif ijt=iloc-ji+2 ib3(ji,nlcj-1,jk) = isgn * ib3(ijt,nlcj-2,jk) ib3(ji,nlcj ,jk) = isgn * ib3(ijt,nlcj-3,jk) END DO END DO CASE ( 'F', 'G' ) #if defined key_z_first DO ji = 1, nlci-1 DO jk = 1, jpk #else DO jk = 1, jpk DO ji = 1, nlci-1 #endif iju=iloc-ji+1 ib3(ji,nlcj-1,jk) = isgn * ib3(iju,nlcj-2,jk) ib3(ji,nlcj ,jk) = isgn * ib3(iju,nlcj-3,jk) END DO END DO END SELECT CASE ( 5 , 6 ) ! F pivot iloc=jpiglo-2*(nimpp-1) SELECT CASE ( cd_type ) CASE ( 'T' , 'S', 'W' ) #if defined key_z_first DO ji = 1, nlci DO jk = 1, jpk #else DO jk = 1, jpk DO ji = 1, nlci #endif ijt=iloc-ji+1 ib3(ji,nlcj,jk) = isgn * ib3(ijt,nlcj-1,jk) END DO END DO CASE ( 'U' ) #if defined key_z_first DO ji = 1, nlci-1 DO jk = 1, jpk #else DO jk = 1, jpk DO ji = 1, nlci-1 #endif iju=iloc-ji ib3(ji,nlcj,jk) = isgn * ib3(iju,nlcj-1,jk) END DO END DO CASE ( 'V' ) #if defined key_z_first DO ji = 1, nlci DO jk = 1, jpk ijt=iloc-ji+1 ib3(ji,nlcj ,jk) = isgn * ib3(ijt,nlcj-2,jk) END DO END DO DO ji = nlci/2+1, nlci DO jk = 1, jpk ijt=iloc-ji+1 ib3(ji,nlcj-1,jk) = isgn * ib3(ijt,nlcj-1,jk) END DO END DO #else DO jk = 1, jpk DO ji = 1, nlci ijt=iloc-ji+1 ib3(ji,nlcj ,jk) = isgn * ib3(ijt,nlcj-2,jk) END DO DO ji = nlci/2+1, nlci ijt=iloc-ji+1 ib3(ji,nlcj-1,jk) = isgn * ib3(ijt,nlcj-1,jk) END DO END DO #endif CASE ( 'F', 'G' ) #if defined key_z_first DO ji = 1, nlci-1 DO jk = 1, jpk iju=iloc-ji ib3(ji,nlcj,jk) = isgn * ib3(iju,nlcj-2,jk) END DO END DO DO ji = nlci/2+1, nlci-1 DO jk = 1, jpk iju=iloc-ji ib3(ji,nlcj-1,jk) = isgn * ib3(iju,nlcj-1,jk) END DO END DO #else DO jk = 1, jpk DO ji = 1, nlci-1 iju=iloc-ji ib3(ji,nlcj,jk) = isgn * ib3(iju,nlcj-2,jk) END DO DO ji = nlci/2+1, nlci-1 iju=iloc-ji ib3(ji,nlcj-1,jk) = isgn * ib3(iju,nlcj-1,jk) END DO END DO #endif END SELECT ! cd_type END SELECT ! npolj CASE DEFAULT ! more than 1 proc along I IF ( npolj /= 0 .AND. do_nfold) CALL mpp_lbc_north ( ib3, cd_type, isgn) ! only for northern procs. END SELECT ! jpni END SUBROUTINE apply_north_fold3i !================================================================ SUBROUTINE add_exch(iwidth, grid, dirn1, & dirn2, dirn3, dirn4, & r2d, r3d, i2d, i3d, isgn, lfill) USE lib_mpp, ONLY: ctl_stop IMPLICIT none ! Arguments INTEGER :: iwidth, dirn1, dirn2, dirn3, dirn4 CHARACTER (LEN=1) :: grid REAL(wp), DIMENSION(:,:), TARGET, OPTIONAL :: r2d REAL(wp), DIMENSION(:,:,:), TARGET, OPTIONAL :: r3d INTEGER, DIMENSION(:,:), TARGET, OPTIONAL :: i2d INTEGER, DIMENSION(:,:,:), TARGET, OPTIONAL :: i3d INTEGER, OPTIONAL :: isgn LOGICAL, OPTIONAL :: lfill ! Local vars !!-------------------------------------------------------------------- #if ! defined key_mpp_rkpart RETURN #endif IF(nextFreeExchItem > maxExchItems)THEN CALL ctl_stop('STOP','ARPDBG: implement reallocate in add_exch') RETURN END IF exch_list(nextFreeExchItem)%halo_width = iwidth exch_list(nextFreeExchItem)%dirn(1) = dirn1 exch_list(nextFreeExchItem)%dirn(2) = dirn2 exch_list(nextFreeExchItem)%dirn(3) = dirn3 exch_list(nextFreeExchItem)%dirn(4) = dirn4 exch_list(nextFreeExchItem)%grid = grid IF(PRESENT(isgn))THEN exch_list(nextFreeExchItem)%isgn = isgn ELSE exch_list(nextFreeExchItem)%isgn = 1 END IF NULLIFY( exch_list(nextFreeExchItem)%r2dptr, & exch_list(nextFreeExchItem)%r3dptr, & exch_list(nextFreeExchItem)%i2dptr, & exch_list(nextFreeExchItem)%i3dptr ) IF(PRESENT(r2d))THEN exch_list(nextFreeExchItem)%r2dptr => r2d ELSE IF(PRESENT(r3d))THEN exch_list(nextFreeExchItem)%r3dptr => r3d ELSE IF(PRESENT(i2d))THEN exch_list(nextFreeExchItem)%i2dptr => i2d ELSE IF(PRESENT(i3d))THEN exch_list(nextFreeExchItem)%i3dptr => i3d ELSE ! This section is both for error checking and allows me to be lazy in the ! testing code - I don't have to check which arrays I've been passed ! before I call this routine. WRITE (*,*) 'WARNING: add_exch called without a ptr to an array - will be ignored' RETURN END IF IF(PRESENT(lfill))THEN exch_list(nextFreeExchItem)%lfill = lfill ELSE exch_list(nextFreeExchItem)%lfill = .false. END IF nextFreeExchItem = nextFreeExchItem + 1 END SUBROUTINE add_exch !================================================================ SUBROUTINE wipe_exch(item) IMPLICIT none ! Arguments TYPE (exch_item), INTENT(inout) :: item NULLIFY(item%i2dptr, item%r2dptr, item%i3dptr, item%r3dptr) item%isgn = 1 END SUBROUTINE wipe_exch !================================================================ SUBROUTINE bound_exch2 (b, nhalo, nhexch, & comm1, comm2, comm3, comm4, & cd_type, lfill, pval, isgn, lzero ) !!---------------------------------------------------------------------- !!---------------------------------------------------------------------- USE par_oce, ONLY : wp IMPLICIT none REAL(wp), INTENT(inout), DIMENSION(:,:) :: b INTEGER, INTENT(in) :: nhalo,nhexch INTEGER, INTENT(in) :: comm1, comm2, comm3, comm4 CHARACTER (LEN=1), INTENT(in) :: cd_type LOGICAL, OPTIONAL, INTENT(in) :: lfill INTEGER, OPTIONAL, INTENT(in) :: isgn LOGICAL, OPTIONAL, INTENT(in) :: lzero REAL(wp),OPTIONAL, INTENT(in) :: pval CALL bound_exch_generic( b2=b,nhalo=nhalo,nhexch=nhexch, & comm1=comm1,comm2=comm2,comm3=comm3,comm4=comm4, & cd_type=cd_type, lfill=lfill, pval=pval, & isgn=isgn, lzero=lzero ) RETURN END SUBROUTINE bound_exch2 SUBROUTINE bound_exch2i (b, nhalo, nhexch, comm1, comm2, comm3, comm4, & cd_type, lfill, pval, isgn, lzero ) !!---------------------------------------------------------------------- !!---------------------------------------------------------------------- USE par_oce, ONLY: wp IMPLICIT none INTEGER, INTENT(inout), DIMENSION(:,:) :: b INTEGER, INTENT(in) :: nhalo,nhexch INTEGER, INTENT(in) :: comm1, comm2, comm3, comm4 CHARACTER (LEN=1), INTENT(in) :: cd_type LOGICAL, OPTIONAL, INTENT(in) :: lfill INTEGER, OPTIONAL, INTENT(in) :: isgn LOGICAL, OPTIONAL, INTENT(in) :: lzero REAL(wp),OPTIONAL, INTENT(in) :: pval CALL bound_exch_generic (ib2=b,nhalo=nhalo,nhexch=nhexch, & comm1=comm1,comm2=comm2,comm3=comm3,comm4=comm4, & cd_type=cd_type, lfill=lfill, pval=pval, & isgn=isgn, lzero=lzero ) RETURN END SUBROUTINE bound_exch2i SUBROUTINE bound_exch3 (b, nhalo, nhexch, comm1, comm2, comm3, & comm4, cd_type, lfill, pval, isgn, lzero) !!---------------------------------------------------------------------- !!---------------------------------------------------------------------- USE par_oce, ONLY: wp IMPLICIT none REAL(wp), INTENT(inout), DIMENSION(:,:,:) :: b INTEGER, INTENT(in) :: nhalo,nhexch INTEGER, INTENT(in) :: comm1, comm2, comm3, comm4 CHARACTER (LEN=1), INTENT(in) :: cd_type LOGICAL, OPTIONAL, INTENT(in) :: lfill INTEGER, OPTIONAL, INTENT(in) :: isgn LOGICAL, OPTIONAL, INTENT(in) :: lzero REAL(wp),OPTIONAL, INTENT(in) :: pval CALL bound_exch_generic ( b3=b,nhalo=nhalo,nhexch=nhexch,& comm1=comm1,comm2=comm2,comm3=comm3,comm4=comm4, & cd_type=cd_type, lfill=lfill, pval=pval, & isgn=isgn, lzero=lzero ) RETURN END SUBROUTINE bound_exch3 SUBROUTINE bound_exch3i (b, nhalo, nhexch, comm1, comm2, comm3, & comm4, cd_type, lfill, pval, isgn, lzero) !!---------------------------------------------------------------------- !!---------------------------------------------------------------------- IMPLICIT none INTEGER, INTENT(inout), DIMENSION(:,:,:) :: b INTEGER, INTENT(in) :: nhalo,nhexch INTEGER, INTENT(in) :: comm1, comm2, comm3, comm4 CHARACTER (LEN=1), INTENT(in) :: cd_type LOGICAL, OPTIONAL, INTENT(in) :: lfill INTEGER, OPTIONAL, INTENT(in) :: isgn LOGICAL, OPTIONAL, INTENT(in) :: lzero REAL(wp),OPTIONAL, INTENT(in) :: pval CALL bound_exch_generic ( ib3=b,nhalo=nhalo,nhexch=nhexch, & comm1=comm1,comm2=comm2,comm3=comm3,comm4=comm4, & cd_type=cd_type, lfill=lfill, pval=pval, & isgn=isgn, lzero=lzero ) END SUBROUTINE bound_exch3i SUBROUTINE lbc_exch2( pt2d, cd_type, psgn, cd_mpp, pval, lzero ) USE par_oce, ONLY: wp, jpreci USE lib_mpp, ONLY : ctl_stop IMPLICIT none !!---------------------------------------------------------------------- !! *** routine mpp_lnk_2d *** !! !! ** Purpose : Message passing management for 2d array !! !! ** Method : Use bound_exch_generic to update halos on neighbouring !! processes. !! !!---------------------------------------------------------------------- REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pt2d ! 2D array on which the boundary condition is applied CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points ! ! = T , U , V , F , W and I points REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary ! ! = 1. , the sign is kept CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries) LOGICAL, OPTIONAL , INTENT(in ) :: lzero ! Whether to zero halos on closed boundaries ! Locals LOGICAL :: lfill lfill = .FALSE. IF(PRESENT(cd_mpp))THEN lfill = .TRUE. END IF CALL bound_exch_generic( b2=pt2d,nhalo=jpreci,nhexch=jpreci, & comm1=Iplus,comm2=Iminus,comm3=Jplus,comm4=Jminus, & cd_type=cd_type, lfill=lfill, pval=pval, isgn=INT(psgn), & lzero=lzero ) END SUBROUTINE lbc_exch2 SUBROUTINE lbc_exch3( ptab3d, cd_type, psgn, cd_mpp, pval, lzero ) USE par_oce, ONLY: wp, jpreci USE lib_mpp, ONLY : ctl_stop IMPLICIT none !!---------------------------------------------------------------------- !!---------------------------------------------------------------------- !FTRANS ptab3d :I :I :z REAL(wp), INTENT(inout) :: ptab3d(:,:,:) CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points ! ! = T , U , V , F , W points REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary ! ! = 1. , the sign is kept CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries) LOGICAL, OPTIONAL , INTENT(in ) :: lzero ! Whether to zero halos on closed boundaries ! Locals LOGICAL :: lfill lfill = .FALSE. IF(PRESENT(cd_mpp))THEN lfill = .TRUE. END IF CALL bound_exch_generic ( b3=ptab3d,nhalo=jpreci,nhexch=jpreci, & comm1=Iplus,comm2=Iminus,comm3=Jplus,comm4=Jminus, & cd_type=cd_type, lfill=lfill, pval=pval, isgn=INT(psgn), & lzero=lzero ) END SUBROUTINE lbc_exch3 ! **************************************************************************** SUBROUTINE exchs_generic_list (list, nfields) ! ************************************************************************** ! Send boundary data elements to adjacent sub-domains. ! ! handle int output Exchange handle. ! comm1 int input Send in direction comm1. ! comm2 int input Send in direction comm2. ! comm3 int input Send in direction comm3. ! comm4 int input Send in direction comm4. ! cd_type char input Nature of array grid-points ! = T , U , V , F , W points ! = S : T-point, north fold treatment? ! = G : F-point, north fold treatment? ! lfill logical input Whether to simply fill ! overlap region or apply b.c.'s ! ! Mike Ashworth, CCLRC, March 2005. ! Andrew Porter, STFC, January 2008 ! ************************************************************************** USE par_oce, ONLY: wp, jpreci, jprecj, jpni USE mapcomm_mod, ONLY: Iplus, Jplus, Iminus, Jminus, IplusJplus, & IminusJminus, IplusJminus, IminusJplus, & nsend, nxsend, nysend, nxsendp,nysendp,nzsendp, & nsendp, & destination,dirsend, dirrecv, & isrcsendp,jsrcsendp, idesrecvp, jdesrecvp, & nrecv, & nxrecvp,nyrecvp,nzrecvp, nrecvp, nrecvp2d, & source, iesub, jesub, & MaxCommDir, MaxComm, cyclic_bc, & nrecvp, npatchsend, npatchrecv USE lib_mpp, ONLY: ctl_stop #if defined key_mpp_mpi USE lib_mpp, ONLY: mpi_comm_opa #endif #if ( defined DEBUG && defined DEBUG_EXCHANGE ) || defined DEBUG_COMMS USE dom_oce, ONLY: narea #endif IMPLICIT none ! Subroutine arguments. TYPE (exch_item), DIMENSION(:), INTENT(inout) :: list INTEGER, INTENT(in) :: nfields ! Local variables. LOGICAL :: enabled(0:MaxCommDir, maxExchItems) INTEGER :: ides, ierr, irecv, isend, & isrc, jdes, jsrc, tag, tag_orig, & ibeg, iend, jbeg, jend INTEGER :: i, j, k, ic, ifield, ipatch ! Loop counters ! No. of array elements packed INTEGER :: npacked INTEGER :: handle #if defined key_mpp_mpi INTEGER :: status(MPI_status_size) INTEGER :: astatus(MPI_status_size,MaxComm) #endif INTEGER :: r2dcount, r3dcount, i2dcount, i3dcount ! Indices into int and real copy buffers INTEGER :: istart, rstart ! Max no. of points to send/recv (for alloc'ing buffers) INTEGER :: maxrecvpts, maxsendpts LOGICAL, SAVE :: first_time = .TRUE. LOGICAL :: have_real_field, have_int_field ! Required size of buffer for current send INTEGER :: newSize ! The current size (in array elements) of the send buffer INTEGER, SAVE :: sendIBuffSize = 0 INTEGER, SAVE :: sendBuffSize = 0 #if defined key_z_first INTEGER, PARAMETER :: index_z = 1 #else INTEGER, PARAMETER :: index_z = 3 #endif !!-------------------------------------------------------------------- #if ! defined key_mpp_rkpart RETURN #endif !CALL prof_region_begin(ARPEXCHS_LIST, "Exchs_list", iprofStat) ! Allocate a communications tag/handle and a flags array. handle = get_exch_handle() tag_orig = exch_tag(handle) have_real_field = .FALSE. have_int_field = .FALSE. ! Set enabled flags according to the field details. DO ifield = 1, nfields, 1 ! Check halo width is in range. IF ( list(ifield)%halo_width.GT.jpreci ) THEN CALL ctl_stop('STOP', & 'exchs_generic_list: halo width greater than maximum') RETURN ENDIF enabled(Iplus, ifield ) = .FALSE. enabled(Jplus, ifield ) = .FALSE. enabled(Iminus, ifield) = .FALSE. enabled(Jminus, ifield) = .FALSE. enabled(list(ifield)%dirn(1), ifield) = list(ifield)%dirn(1).GT.0 enabled(list(ifield)%dirn(2), ifield) = list(ifield)%dirn(2).GT.0 enabled(list(ifield)%dirn(3), ifield) = list(ifield)%dirn(3).GT.0 enabled(list(ifield)%dirn(4), ifield) = list(ifield)%dirn(4).GT.0 ! Set diagonal communications according to the non-diagonal flags. enabled(IplusJplus, ifield ) = enabled(Iplus, ifield ).AND.enabled(Jplus, ifield ) enabled(IminusJminus,ifield ) = enabled(Iminus, ifield ).AND.enabled(Jminus, ifield ) enabled(IplusJminus, ifield ) = enabled(Iplus, ifield ).AND.enabled(Jminus, ifield ) enabled(IminusJplus, ifield ) = enabled(Iminus, ifield ).AND.enabled(Jplus, ifield ) have_real_field = have_real_field .OR. & ( ASSOCIATED(list(ifield)%r2dptr) .OR. & ASSOCIATED(list(ifield)%r3dptr) ) have_int_field = have_int_field .OR. & ( ASSOCIATED(list(ifield)%i2dptr) .OR. & ASSOCIATED(list(ifield)%i3dptr) ) END DO ! Loop over fields ! Main communications loop. #if defined key_mpp_mpi ierr = 0 maxrecvpts = MAXVAL(nrecvp(1:nrecv,1)) maxsendpts = MAXVAL(nsendp(1:nsend,1)) !WRITE(*,"('maxrecvpts = ',I4,' maxsendpts = ',I4)") maxrecvpts, maxsendpts IF( have_real_field )THEN ALLOCATE(recvBuff(maxrecvpts*nfields,nrecv),stat=ierr) !WRITE(*,"('Allocated ',I7,' reals for recv buff')") & ! jpkdta*maxrecvpts*nfields !!$ IF(.NOT. ALLOCATED(sendBuff))THEN !!$ ! Only allocate the sendBuff once !!$ ALLOCATE(recvBuff(jpkdta*maxrecvpts*nfields,nrecv), & !!$ sendBuff(jpkdta*maxsendpts*nfields,nsend),stat=ierr) !!$ WRITE(*,"('Allocated ',I7,' reals for recv buff')") jpkdta*maxrecvpts*nfields !!$ WRITE(*,"('Allocated ',I7,' reals for send buff')") jpkdta*maxsendpts*nfields !!$ WRITE(*,"('nfields = ',I2,' jpkdta = ',I3)"), nfields, jpkdta !!$ ELSE !!$ ALLOCATE(recvBuff(jpkdta*maxrecvpts*nfields,nrecv),stat=ierr) !!$ END IF END IF IF( have_int_field .AND. (ierr == 0) )THEN ALLOCATE(recvIBuff(maxrecvpts*nfields,nrecv),stat=ierr) !WRITE(*,"('Allocated ',I7,' ints for recv buff')") & ! jpkdta*maxrecvpts*nfields !!$ IF(.NOT. ALLOCATED(sendIBuff))THEN !!$ ALLOCATE(recvIBuff(jpkdta*maxrecvpts*nfields,nrecv), & !!$ sendIBuff(jpkdta*maxsendpts*nfields,nsend),stat=ierr) !!$ ELSE !!$ ALLOCATE(recvIBuff(jpkdta*maxrecvpts*nfields,nrecv),stat=ierr) !!$ END IF END IF IF (ierr .ne. 0) THEN WRITE(*,*) 'ARPDBG: failed to allocate recv buf' CALL ctl_stop('STOP','exchs_generic_list: unable to allocate recv buffs') END IF ! Initiate receives in case posting them first improves ! performance. exch_flags(handle,1:nrecv,indexr) = MPI_REQUEST_NULL DO irecv=1, nrecv, 1 r2dcount = 0 r3dcount = 0 i2dcount = 0 i3dcount = 0 IF( source(irecv).GE.0 .AND. & ( (nrecvp(irecv,1) > 0) .OR. (nrecvp2d(irecv,1) > 0) ) ) THEN ! This loop is to allow for different fields to have different ! direction requirements (possibly unecessary) DO ifield=1,nfields,1 IF ( enabled(dirrecv(irecv), ifield) ) THEN IF( ASSOCIATED(list(ifield)%r2dptr) )THEN r2dcount = r2dcount + nrecvp2d(irecv,1) ELSE IF( ASSOCIATED(list(ifield)%i2dptr) )THEN i2dcount = i2dcount + nrecvp2d(irecv,1) ELSE IF( ASSOCIATED(list(ifield)%r3dptr) )THEN ! Allow for varying size of third dimension r3dcount = r3dcount + nrecvp(irecv,1) ELSE IF( ASSOCIATED(list(ifield)%i3dptr) )THEN ! Allow for varying size of third dimension i3dcount = i3dcount + nrecvp(irecv,1) END IF END IF END DO tag = tag_orig + dirrecv(irecv) #if ( defined DEBUG && defined DEBUG_EXCHANGE ) || defined DEBUG_COMMS WRITE (*,FMT="(I4,': tag ',I4,' ireceiving from ',I4,' data ',I4)") & narea-1,tag ,source(irecv), nrecvp(irecv,1) #endif IF ( r2dcount > 0 .OR. r3dcount > 0 ) THEN CALL MPI_irecv (recvBuff(1,irecv),(r2dcount+r3dcount), & MPI_DOUBLE_PRECISION, source(irecv), tag, mpi_comm_opa, & exch_flags(handle,irecv,indexr), ierr) END IF IF ( i2dcount > 0 .OR. i3dcount > 0 ) THEN CALL MPI_irecv (recvIBuff(1,irecv),(i2dcount+i3dcount), & MPI_INTEGER, source(irecv),tag, mpi_comm_opa, & exch_flags(handle,irecv,indexr),ierr) END IF !!$#if defined DEBUG_COMMS !!$ WRITE (*,FMT="(I4,': exchs post recv : hand = ',I2,' dirn = ',I1,' opp dirn = ',I1,' src = ',I3,' tag = ',I4,' flag = ',I3)") & !!$ narea-1,handle,dirrecv(irecv), & !!$ opp_dirn(dirrecv(irecv)),source(irecv), & !!$ tag, exch_flags(handle,irecv,indexr) !!$#endif END IF ENDDO ! Loop over receives ! Check that all sends from previous call have completed before ! we continue and modify the send buffers IF (.not. first_time) THEN CALL MPI_waitall(nsend, exch_flags1d, astatus, ierr) IF ( ierr.NE.0 ) CALL MPI_abort(mpi_comm_opa,1,ierr) ELSE first_time = .FALSE. END IF ! .not. first_time ! Now allocate/reallocate SEND buffers ierr = 0 newSize = maxsendpts*nfields IF( have_real_field .AND. newSize > sendBuffSize)THEN sendBuffSize=newSize IF(ALLOCATED(sendBuff))DEALLOCATE(sendBuff) ALLOCATE(sendBuff(sendBuffSize,nsend),stat=ierr) !WRITE(*,"('Allocated ',I7,' reals for send buff')") sendBuffSize !WRITE(*,"('nfields = ',I2,' jpkdta = ',I3)") nfields, jpkdta END IF IF( have_int_field .AND. newSize > sendIBuffSize)THEN sendIBuffSize = newSize IF(ALLOCATED(sendIBuff))DEALLOCATE(sendIBuff) ALLOCATE(sendIBuff(sendIBuffSize,nsend),stat=ierr) END IF IF (ierr .ne. 0) THEN CALL ctl_stop('STOP','exchs_generic_list: unable to allocate send buff') END IF ! Send all messages in the communications list. exch_flags(handle,1:nsend,indexs) = MPI_REQUEST_NULL DO isend=1, nsend, 1 rstart = 1 istart = 1 r2dcount = 0 r3dcount = 0 i2dcount = 0 i3dcount = 0 IF ( destination(isend).GE.0 .AND. nxsend(isend).GT.0 ) THEN ! Loop over the fields for which we are going to exchange halos ! and pack the data to send into a buffer DO ifield=1, nfields, 1 IF( enabled(dirsend(isend), ifield) )THEN tag = tag_orig + dirsend(isend) !!$#if ( defined DEBUG && defined DEBUG_EXCHANGE ) || defined DEBUG_COMMS !!$ WRITE (*,FMT="(I4,': handle ',I4,' tag ',I4,' sending to ',I4,' data ',I4,' direction ',I3)") & !!$ narea-1, handle, tag, destination(isend),nsendp(isend,1)*XXX,dirsend(isend) !!$#endif ! Copy the data into the send buffer and send it. The ! performance of this copy matters! IF ( ASSOCIATED(list(ifield)%r2dptr) )THEN ic = rstart - 1 pack_patches2r: DO ipatch=1, npatchsend(isend,1), 1 ibeg = isrcsendp(ipatch,isend,1) iend = ibeg + nxsendp(ipatch,isend,1)-1 jbeg = jsrcsendp(ipatch,isend,1) jend = jbeg + nysendp(ipatch,isend,1)-1 DO j=jbeg, jend, 1 DO i=ibeg, iend, 1 ic = ic + 1 sendBuff(ic, isend) = list(ifield)%r2dptr(i,j) END DO END DO npacked = nxsendp(ipatch,isend,1) * & nysendp(ipatch,isend,1) rstart = rstart + npacked r2dcount = r2dcount + npacked END DO pack_patches2r ELSE IF ( ASSOCIATED(list(ifield)%i2dptr) ) THEN ic = istart - 1 pack_patches2i: DO ipatch=1, npatchsend(isend,1), 1 jbeg = jsrcsendp(ipatch,isend,1) ibeg = isrcsendp(ipatch,isend,1) jend = jbeg + nysendp(ipatch,isend,1)-1 iend = ibeg + nxsendp(ipatch,isend,1)-1 DO j=jbeg, jend, 1 DO i=ibeg, iend, 1 ic = ic + 1 sendIBuff(ic,isend) = list(ifield)%i2dptr(i,j) END DO END DO npacked = nxsendp(ipatch,isend,1) * & nysendp(ipatch,isend,1) istart = istart + npacked i2dcount = i2dcount + npacked END DO pack_patches2i ELSE IF ( ASSOCIATED(list(ifield)%r3dptr) )THEN ic = rstart - 1 pack_patches3r: DO ipatch=1, npatchsend(isend,1), 1 ! WRITE(*,"('Field = ',I2,' patch = ',I2,' ic = ',I4)") & ! ifield, ipatch, ic jbeg = jsrcsendp(ipatch,isend,1) ibeg = isrcsendp(ipatch,isend,1) jend = jbeg + nysendp(ipatch,isend,1)-1 iend = ibeg + nxsendp(ipatch,isend,1)-1 #if defined key_z_first DO j=jbeg, jend, 1 DO i=ibeg, iend, 1 !DO k=1, SIZE(list(ifield)%r3dptr, index_z), 1 DO k=1, nzsendp(ipatch,isend,1), 1 #else !DO k=1, SIZE(list(ifield)%r3dptr, index_z), 1 DO k=1, nzsendp(ipatch,isend,1), 1 DO j=jbeg, jend, 1 DO i=ibeg, iend, 1 #endif ic = ic + 1 sendBuff(ic, isend) = list(ifield)%r3dptr(i,j,k) END DO END DO END DO npacked = nxsendp(ipatch,isend,1) * & nysendp(ipatch,isend,1) * & nzsendp(ipatch,isend,1) rstart = rstart + npacked r3dcount = r3dcount + npacked END DO pack_patches3r ELSEIF ( ASSOCIATED(list(ifield)%i3dptr) ) THEN ic = istart - 1 pack_patches3i: DO ipatch = 1, npatchsend(isend, 1), 1 jbeg = jsrcsendp(ipatch,isend,1) ibeg = isrcsendp(ipatch,isend,1) jend = jbeg + nysendp(ipatch,isend,1)-1 iend = ibeg + nxsendp(ipatch,isend,1)-1 #if defined key_z_first DO j=jbeg, jend, 1 DO i=ibeg, iend, 1 !DO k=1, SIZE(list(ifield)%i3dptr, index_z),1 DO k=1, nzsendp(ipatch,isend,1), 1 #else !DO k=1, SIZE(list(ifield)%i3dptr, index_z),1 DO k=1, nzsendp(ipatch,isend,1), 1 DO j=jbeg, jend, 1 DO i=ibeg, iend, 1 #endif ic = ic + 1 sendIBuff(ic, isend) = list(ifield)%i3dptr(i,j,k) END DO END DO END DO npacked = nxsendp(ipatch,isend,1)* & nysendp(ipatch,isend,1)* & nzsendp(ipatch,isend,1) istart = istart + npacked i3dcount = i3dcount + npacked END DO pack_patches3i ENDIF #if defined DEBUG_COMMS WRITE (*,FMT="(I4,': Isend to ',I3,' has flag ',I3)") & narea-1, destination(isend), exch_flags(handle,isend,indexs) #endif END IF ! Direction enabled for this field END DO ! Loop over fields ! Now do the send(s) for all fields IF(r2dcount > 0 .OR. r3dcount > 0 )THEN CALL MPI_Isend(sendBuff(1,isend),(r2dcount+r3dcount), & MPI_DOUBLE_PRECISION, & destination(isend),tag,mpi_comm_opa, & exch_flags(handle,isend,indexs),ierr) END IF IF(i2dcount > 0 .OR. i3dcount > 0 )THEN CALL MPI_Isend(sendIBuff(1,isend),(i2dcount+i3dcount), & MPI_INTEGER, destination(isend),tag, & mpi_comm_opa, exch_flags(handle,isend,indexs),& ierr) END IF ENDIF ! direction is enabled and have something to send ENDDO ! Loop over sends #if ( defined DEBUG && defined DEBUG_EXCHANGE ) || defined DEBUG_COMMS WRITE (*,FMT="(I3,': exch tag ',I4,' finished all sends')") narea-1,tag #endif ! Wait on the receives that were posted earlier ! Copy just the set of flags we're interested in for passing to MPI_waitany exch_flags1d(1:nrecv) = exch_flags(handle, 1:nrecv, indexr) CALL MPI_waitany (nrecv, exch_flags1d, irecv, status, ierr) IF ( ierr.NE.0 ) CALL MPI_abort(mpi_comm_opa,1,ierr) DO WHILE(irecv .ne. MPI_UNDEFINED) istart = 1 rstart = 1 DO ifield = 1, nfields, 1 IF ( ASSOCIATED(list(ifield)%r2dptr) ) THEN ! Copy received data back into array ic = rstart - 1 unpack_patches2r: DO ipatch=1, npatchrecv(irecv,1), 1 jbeg = jdesrecvp(ipatch,irecv,1) jend = jbeg + nyrecvp(ipatch,irecv,1)-1 ibeg = idesrecvp(ipatch,irecv,1) iend = ibeg + nxrecvp(ipatch,irecv,1)-1 DO j=jbeg, jend, 1 DO i=ibeg, iend, 1 ic = ic + 1 list(ifield)%r2dptr(i,j) = recvBuff(ic,irecv) END DO END DO END DO unpack_patches2r ! Increment starting index for next field data in buffer rstart = ic + 1 !rstart + nrecvp(irecv,1) ELSE IF ( ASSOCIATED(list(ifield)%i2dptr) ) THEN ! Copy received data back into array ic = istart - 1 unpack_patches2i: DO ipatch = 1, npatchrecv(irecv,1), 1 jbeg = jdesrecvp(ipatch,irecv,1) jend = jbeg + nyrecvp(ipatch,irecv,1)-1 ibeg = idesrecvp(ipatch,irecv,1) iend = ibeg + nxrecvp(ipatch,irecv,1)-1 DO j=jbeg, jend, 1 DO i=ibeg, iend, 1 ic = ic + 1 list(ifield)%i2dptr(i,j) = recvIBuff(ic,irecv) END DO END DO END DO unpack_patches2i ! Increment starting index for next field data in buffer istart = ic + 1 !istart + nrecvp(irecv,1) ELSE IF (ASSOCIATED(list(ifield)%r3dptr) ) THEN ic = rstart - 1 unpack_patches3r: DO ipatch=1,npatchrecv(irecv,1) jbeg = jdesrecvp(ipatch,irecv,1) jend = jbeg + nyrecvp(ipatch,irecv,1)-1 ibeg = idesrecvp(ipatch,irecv,1) iend = ibeg + nxrecvp(ipatch,irecv,1)-1 #if defined key_z_first DO j=jbeg, jend, 1 DO i=ibeg, iend, 1 DO k=1, nzrecvp(ipatch,irecv,1), 1 #else DO k=1, nzrecvp(ipatch,irecv,1), 1 DO j=jbeg, jend, 1 DO i=ibeg, iend, 1 #endif ic = ic + 1 list(ifield)%r3dptr(i,j,k) = recvBuff(ic,irecv) END DO END DO END DO END DO unpack_patches3r ! Increment starting index for next field data in buffer rstart = ic + 1 ! rstart + nrecvp(irecv,1) !*SIZE(list(ifield)%r3dptr,index_z) ELSE IF ( ASSOCIATED(list(ifield)%i3dptr) ) THEN ic = istart - 1 unpack_patches3i: DO ipatch=1,npatchrecv(irecv,1) jbeg = jdesrecvp(ipatch,irecv,1) jend = jbeg+nyrecvp(ipatch,irecv,1)-1 ibeg = idesrecvp(ipatch,irecv,1) iend = ibeg+nxrecvp(ipatch,irecv,1)-1 #if defined key_z_first DO j=jbeg, jend, 1 DO i=ibeg, iend, 1 DO k=1,nzrecvp(ipatch,irecv,1),1 #else DO k=1,nzrecvp(ipatch,irecv,1),1 DO j=jbeg, jend, 1 DO i=ibeg, iend, 1 #endif ic = ic + 1 list(ifield)%i3dptr(i,j,k) = recvIBuff(ic,irecv) END DO END DO END DO END DO unpack_patches3i ! Increment starting index for next field data in buffer istart = ic + 1 !istart + nrecvp(irecv,1) !*SIZE(list(ifield)%i3dptr,index_z) END IF END DO ! Loop over fields ! Wait for the next received message (if any) CALL MPI_waitany (nrecv, exch_flags1d, irecv, status, ierr) IF ( ierr.NE.0 ) CALL MPI_abort(mpi_comm_opa,1,ierr) END DO ! while irecv != MPI_UNDEFINED ! All receives done and unpacked - can deallocate the recv buffer now IF(ALLOCATED(recvBuff))DEALLOCATE(recvBuff) IF(ALLOCATED(recvIBuff))DEALLOCATE(recvIBuff) #endif /* key_mpp_mpi */ ! Periodic boundary condition using internal copy. ! This is performed after all data has been received so that we can ! also copy boundary points and avoid some diagonal communication. ! Since this is just a copy we don't worry about the 'patches' of ! wet points here. ! ARPDBG - fairly certain this code is not yet correct :-( IF ( cyclic_bc .AND. (jpni.EQ.1) ) THEN DO ifield=1,nfields,1 IF ( enabled(Iplus,ifield) ) THEN DO j=1,jesub+list(ifield)%halo_width DO i=1,list(ifield)%halo_width IF ( ASSOCIATED(list(ifield)%r2dptr) ) THEN list(ifield)%r2dptr(iesub+i,j) = list(ifield)%r2dptr(i,j) ELSE IF ( ASSOCIATED(list(ifield)%i2dptr) ) THEN list(ifield)%i2dptr(iesub+i,j) = list(ifield)%i2dptr(i,j) ELSE IF ( ASSOCIATED(list(ifield)%r3dptr) ) THEN DO k=1,SIZE(list(ifield)%r3dptr, index_z) list(ifield)%r3dptr(iesub+i,j,k) = list(ifield)%r3dptr(i,j,k) ENDDO ELSE IF ( ASSOCIATED(list(ifield)%i3dptr) ) THEN DO k=1,SIZE(list(ifield)%i3dptr, index_z) list(ifield)%i3dptr(iesub+i,j,k) = list(ifield)%i3dptr(i,j,k) ENDDO END IF ENDDO ENDDO END IF IF ( enabled(Iminus,ifield) ) THEN !ARPDBG DO j=1,jesub,1 DO j=1,jesub+list(ifield)%halo_width DO i=1, list(ifield)%halo_width IF ( ASSOCIATED(list(ifield)%r2dptr) ) THEN !ARPDBG b2(i,j) = b2(iesub-i+1,j) list(ifield)%r2dptr(i,j) = list(ifield)%r2dptr(iesub-i+1,j) ELSE IF ( ASSOCIATED(list(ifield)%i2dptr) ) THEN !ARPDBG ib2(i,j) = ib2(iesub-i+1,j) list(ifield)%i2dptr(i,j) = list(ifield)%i2dptr(iesub-i+1,j) ELSE IF ( ASSOCIATED(list(ifield)%r3dptr) ) THEN DO k=1,SIZE(list(ifield)%r3dptr,index_z),1 !ARPDBG b3(k,i,j) = b3(k,iesub-i+1,j) list(ifield)%r3dptr(i,j,k) = list(ifield)%r3dptr(iesub-i+1,j,k) ENDDO ELSE IF ( ASSOCIATED(list(ifield)%i3dptr) ) THEN DO k=1,SIZE(list(ifield)%i3dptr,index_z), 1 !ARPDBG ib3(k,i,j) = ib3(k,iesub-i+1,j) list(ifield)%i3dptr(i,j,k) = list(ifield)%i3dptr(iesub-i+1,j,k) END DO END IF END DO END DO END IF END DO ! Loop over fields ENDIF ! cyclic_bc .AND. jpni==1 ! Copy just the set of flags we're interested in for passing to ! MPI_waitall next time around exch_flags1d(1:nsend) = exch_flags(handle, 1:nsend, indexs) ! Free the exchange communications handle. CALL free_exch_handle(handle) !CALL prof_region_end(ARPEXCHS_LIST, iprofStat) END SUBROUTINE exchs_generic_list ! ********************************************************************* SUBROUTINE exchs_generic ( b2, ib2, b3, ib3, nhalo, nhexch, & handle, comm1, comm2, comm3, comm4, & cd_type, lfill) ! ******************************************************************* ! Send boundary data elements to adjacent sub-domains. ! b2(:,:) real input 2D real*8 local array. ! ib2(:,:) int input 2D integer local array. ! b3(:,:,:) real input 3D real*8 local array. ! ib3(:,:,:) int input 3D integer local array. ! nhalo int input Width of halo. ! nhexch int input Number of halo ! rows/cols to exchange. ! handle int output Exchange handle. ! comm1 int input Send in direction comm1. ! comm2 int input Send in direction comm2. ! comm3 int input Send in direction comm3. ! comm4 int input Send in direction comm4. ! cd_type char input Nature of array grid-points ! = T , U , V , F , W points ! = S : T-point, north fold treatment? ! = G : F-point, north fold treatment? ! lfill logical input Whether to simply fill ! overlap region or apply b.c.'s ! ! Mike Ashworth, CCLRC, March 2005. ! Andrew Porter, STFC, January 2008 ! ******************************************************************* USE par_oce, ONLY: wp, jpreci, jprecj, jpni, jpkdta USE mapcomm_mod, ONLY: Iplus, Jplus, Iminus, Jminus, IplusJplus, & IminusJminus, IplusJminus, IminusJplus, & nrecv, nsend, nrecvp, nsendp, & nrecvp2d, nsendp2d, nxsend, nysend, & destination,dirsend, dirrecv, & isrcsend, jsrcsend, idesrecv, jdesrecv, & isrcsendp,jsrcsendp,idesrecvp,jdesrecvp, & nxrecv,source, iesub, jesub, & MaxCommDir, MaxComm, idessend, jdessend, & nxsendp, nysendp, nzsendp, & nxrecvp, nyrecvp, nzrecvp, & npatchsend, npatchrecv, cyclic_bc USE lib_mpp, ONLY: ctl_stop #if defined key_mpp_mpi USE lib_mpp, ONLY: mpi_comm_opa #endif USE dom_oce, ONLY: narea USE in_out_manager, ONLY: numout IMPLICIT none ! Subroutine arguments. INTEGER, INTENT(in) :: nhalo,nhexch INTEGER, INTENT(out) :: handle !FTRANS b3 :I :I :z !FTRANS ib3 :I :I :z REAL(wp),OPTIONAL, INTENT(inout), DIMENSION(:,:) :: b2 INTEGER, OPTIONAL, INTENT(inout), DIMENSION(:,:) :: ib2 REAL(wp),OPTIONAL, INTENT(inout), DIMENSION(:,:,:) :: b3 INTEGER, OPTIONAL, INTENT(inout), DIMENSION(:,:,:) :: ib3 INTEGER, INTENT(in) :: comm1, comm2, comm3, comm4 CHARACTER(len=1), INTENT(in) :: cd_type LOGICAL, INTENT(in) :: lfill ! Local variables. LOGICAL :: enabled(0:MaxCommDir) INTEGER :: ierr, irecv, ircvdt, isend, isnddt, & isrc, jsrc, kdim1, & ! ides, jdes, nxr, nyr, & nxs, nys, tag, tag_orig INTEGER :: maxrecvpts, maxsendpts ! Max no. of grid points involved in ! any one halo exchange INTEGER :: i, j, k, ic, ipatch ! Loop counters INTEGER :: istart, iend, jstart, jend INTEGER :: index ! To hold index returned from MPI_waitany INTEGER, DIMENSION(3) :: isubsizes, istarts ! isizes #if defined key_mpp_mpi INTEGER :: status(MPI_status_size) INTEGER :: astatus(MPI_status_size,MaxComm) #endif LOGICAL, SAVE :: first_time = .TRUE. #if defined key_z_first INTEGER, PARAMETER :: index_z = 1 #else INTEGER, PARAMETER :: index_z = 3 #endif !!-------------------------------------------------------------------- #if ! defined key_mpp_rkpart RETURN #endif !CALL prof_region_begin(ARPEXCHS_GENERIC, "Exchs_indiv", iprofStat) !CALL timing_start('exchs_generic') ierr = 0 ! Check nhexch is in range. IF ( nhexch.GT.jpreci ) THEN CALL ctl_stop('STOP','exchs: halo width greater than maximum') ENDIF ! Allocate a communications tag/handle and a flags array. handle = get_exch_handle() tag_orig = exch_tag(handle) ! Set enabled flags according to the subroutine arguments. enabled(Iplus ) = .FALSE. enabled(Jplus ) = .FALSE. enabled(Iminus) = .FALSE. enabled(Jminus) = .FALSE. enabled(comm1) = comm1.GT.0 enabled(comm2) = comm2.GT.0 enabled(comm3) = comm3.GT.0 enabled(comm4) = comm4.GT.0 ! Set diagonal communications according to the non-diagonal flags. enabled(IplusJplus ) = enabled(Iplus ).AND.enabled(Jplus ) enabled(IminusJminus)= enabled(Iminus).AND.enabled(Jminus) enabled(IplusJminus) = enabled(Iplus ).AND.enabled(Jminus) enabled(IminusJplus )= enabled(Iminus).AND.enabled(Jplus ) ! Main communications loop. #if defined key_mpp_mpi maxrecvpts = MAXVAL(nrecvp(1:nrecv,1)) maxsendpts = MAXVAL(nsendp(1:nsend,1)) IF(PRESENT(b2) .OR. PRESENT(b3))THEN IF(.NOT. ALLOCATED(sendBuff))THEN ! Only allocate the sendBuff once ALLOCATE(recvBuff(maxrecvpts,nrecv), & sendBuff(maxsendpts,nsend),stat=ierr) ELSE ALLOCATE(recvBuff(maxrecvpts,nrecv),stat=ierr) END IF ELSE IF(PRESENT(ib2) .OR. PRESENT(ib3))THEN IF(.NOT. ALLOCATED(sendIBuff))THEN ALLOCATE(recvIBuff(maxrecvpts,nrecv), & sendIBuff(maxsendpts,nsend),stat=ierr) ELSE ALLOCATE(recvIBuff(maxrecvpts,nrecv),stat=ierr) END IF END IF IF (ierr .ne. 0) THEN CALL ctl_stop('STOP','exchs_generic: unable to allocate send/recvBuffs') END IF ! Initiate receives in case posting them first improves ! performance. DO irecv=1,nrecv IF ( enabled(dirrecv(irecv)) .AND. & source(irecv).GE.0 .AND. nxrecv(irecv).GT.0 ) THEN tag = tag_orig + dirrecv(irecv) #if ( defined DEBUG && defined DEBUG_EXCHANGE ) || defined DEBUG_COMMS WRITE (*,FMT="(I4,': tag ',I4,' ireceiving from ',I4,' data ',I4)") narea-1,tag ,source(irecv), nrecvp(irecv,1) #endif ! ARPDBG - nrecvp second rank is for multiple halo widths but ! that isn't used IF ( PRESENT(b2) ) THEN CALL MPI_irecv (recvBuff(1,irecv),nrecvp2d(irecv,1), & MPI_DOUBLE_PRECISION, source(irecv), & tag, mpi_comm_opa, & exch_flags(handle,irecv,indexr), ierr) ELSEIF ( PRESENT(ib2) ) THEN CALL MPI_irecv (recvIBuff(1,irecv),nrecvp2d(irecv,1), & MPI_INTEGER, source(irecv), & tag, mpi_comm_opa, & exch_flags(handle,irecv,indexr),ierr) ELSEIF ( PRESENT(b3) ) THEN CALL MPI_irecv (recvBuff(1,irecv),nrecvp(irecv,1), & MPI_DOUBLE_PRECISION, source(irecv), & tag, mpi_comm_opa, & exch_flags(handle,irecv,indexr),ierr) ELSEIF ( PRESENT(ib3) ) THEN CALL MPI_irecv (recvIBuff(1,irecv),nrecvp(irecv,1), & MPI_INTEGER, source(irecv), & tag, mpi_comm_opa, & exch_flags(handle,irecv,indexr),ierr) ENDIF ! No point checking for MPI errors because default MPI error handler ! aborts run without returning control to calling program. !IF ( ierr.NE.0 ) THEN ! WRITE (numout,*) 'ARPDBG - irecv hit error' ! CALL flush(numout) ! CALL MPI_abort(mpi_comm_opa,1,ierr) !END IF #if defined DEBUG_COMMS WRITE (*,FMT="(I4,': exchs post recv : hand = ',I2,' dirn = ',I1,' src = ',I3,' tag = ',I4,' npoints = ',I6)") & narea-1,handle,dirrecv(irecv), & source(irecv), tag, nrecvp(irecv,1) #endif ELSE exch_flags(handle,irecv,indexr) = MPI_REQUEST_NULL END IF ENDDO IF (.not. first_time) THEN ! Check that all sends from previous call have completed before ! we continue to modify the send buffers CALL MPI_waitall(nsend, exch_flags1d, astatus, ierr) IF ( ierr.NE.0 ) CALL MPI_abort(mpi_comm_opa,1,ierr) ELSE first_time = .FALSE. END IF ! .not. first_time ! Send all messages in the communications list. ! CALL timing_start('mpi_sends') DO isend=1,nsend IF ( enabled(dirsend(isend)) .AND. & destination(isend) >= 0 .AND. nxsend(isend) > 0 ) THEN isrc = isrcsend(isend) jsrc = jsrcsend(isend) nxs = nxsend(isend) nys = nysend(isend) tag = tag_orig + dirsend(isend) #if ( defined DEBUG && defined DEBUG_EXCHANGE ) || defined DEBUG_COMMS IF(PRESENT(b3))THEN WRITE (*,FMT="(I4,': handle ',I4,' tag ',I4,' sending to ',I4,' data ',I4,' direction ',I3)") & narea-1, handle, tag, destination(isend),nsendp(isend,1),dirsend(isend) ELSE IF(PRESENT(b2))THEN WRITE (*,FMT="(I4,': handle ',I4,' tag ',I4,' sending to ',I4,' data ',I4,' direction ',I3)") & narea-1, handle, tag, destination(isend),nsendp2d(isend,1),dirsend(isend) END IF #endif ! Copy the data into the send buffer and send it... IF ( PRESENT(b2) )THEN ! CALL timing_start('2dr_pack') ic = 0 pack_patches2r: DO ipatch=1,npatchsend(isend,1) istart = isrcsendp(ipatch,isend,1) iend = istart+nxsendp(ipatch,isend,1)-1 jstart = jsrcsendp(ipatch,isend,1) jend = jstart+nysendp(ipatch,isend,1)-1 DO j=jstart, jend, 1 DO i=istart, iend, 1 ic = ic + 1 sendBuff(ic,isend) = b2(i,j) END DO END DO !!$ ! For 'stupid' compiler that refuses to do a memcpy for above !!$ CALL do_real8_copy( nxsendp(patch,isend,1)*nysendp(patch,isend,1), & !!$ b2(istart,jstart), & !!$ sendBuff(ic,isend) ) !!$ ic = ic + nxsendp(patch,isend,1)*nysendp(patch,isend,1) END DO pack_patches2r ! CALL timing_stop('2dr_pack') CALL MPI_Isend(sendBuff(1,isend),ic,MPI_DOUBLE_PRECISION, & destination(isend),tag,mpi_comm_opa, & exch_flags(handle,isend,indexs),ierr) ELSEIF ( PRESENT(ib2) ) THEN ic = 0 pack_patches2i: DO ipatch=1, npatchsend(isend,1), 1 jstart = jsrcsendp(ipatch,isend,1) istart = isrcsendp(ipatch,isend,1) jend = jstart+nysendp(ipatch,isend,1)-1 iend = istart+nxsendp(ipatch,isend,1)-1 DO j=jstart, jend, 1 DO i=istart, iend, 1 ic = ic + 1 sendIBuff(ic,isend) = ib2(i,j) END DO END DO END DO pack_patches2i CALL MPI_Isend(sendIBuff(1,isend),ic, MPI_INTEGER, & destination(isend),tag,mpi_comm_opa,& exch_flags(handle,isend,indexs),ierr) ELSEIF ( PRESENT(b3) )THEN ! CALL timing_start('3dr_pack') ic = 0 pack_patches3r: DO ipatch=1,npatchsend(isend,1) jstart = jsrcsendp(ipatch,isend,1) istart = isrcsendp(ipatch,isend,1) jend = jstart+nysendp(ipatch,isend,1)-1 iend = istart+nxsendp(ipatch,isend,1)-1 #if defined key_z_first DO j=jstart, jend, 1 DO i=istart, iend, 1 DO k=1,nzsendp(ipatch,isend,1),1 #else DO k=1,nzsendp(ipatch,isend,1),1 DO j=jstart, jend, 1 DO i=istart, iend, 1 #endif ic = ic + 1 sendBuff(ic, isend) = b3(i,j,k) END DO END DO END DO END DO pack_patches3r ! CALL timing_stop('3dr_pack') CALL MPI_Isend(sendBuff(1,isend),ic, & MPI_DOUBLE_PRECISION, & destination(isend), tag, mpi_comm_opa, & exch_flags(handle,isend,indexs),ierr) #if defined DEBUG_COMMS WRITE (*,FMT="(I4,': Isend of ',I3,' patches, ',I6,' points, to ',I3)") & narea-1, npatchsend(isend,1),ic, & destination(isend) #endif ELSEIF ( PRESENT(ib3) ) THEN ic = 0 pack_patches3i: DO ipatch=1,npatchsend(isend,1) jstart = jsrcsendp(ipatch,isend,1) !+nhalo istart = isrcsendp(ipatch,isend,1) !+nhalo jend = jstart+nysendp(ipatch,isend,1)-1 iend = istart+nxsendp(ipatch,isend,1)-1 #if defined key_z_first DO j=jstart, jend, 1 DO i=istart, iend, 1 DO k=1,nzsendp(ipatch,isend,1),1 #else DO k=1,nzsendp(ipatch,isend,1),1 DO j=jstart, jend, 1 DO i=istart, iend, 1 #endif ic = ic + 1 sendIBuff(ic, isend) = ib3(i,j,k) END DO END DO END DO END DO pack_patches3i CALL MPI_Isend(sendIBuff(1,isend),ic, & MPI_INTEGER, & destination(isend),tag,mpi_comm_opa, & exch_flags(handle,isend,indexs),ierr) ENDIF !IF ( ierr.NE.0 ) CALL MPI_abort(mpi_comm_opa,1,ierr) ELSE exch_flags(handle,isend,indexs) = MPI_REQUEST_NULL ENDIF ! direction is enabled and have something to send ENDDO ! Loop over sends ! CALL timing_stop('mpi_sends') #if ( defined DEBUG && defined DEBUG_EXCHANGE ) || defined DEBUG_COMMS WRITE (*,FMT="(I3,': exch tag ',I4,' finished all sends')") narea-1,tag #endif ! Wait on the receives that were posted earlier ! CALL timing_start('mpi_recvs') ! Copy just the set of flags we're interested in for passing ! to MPI_waitany exch_flags1d(1:nrecv) = exch_flags(handle, 1:nrecv, indexr) #if defined DEBUG_COMMS WRITE(*,"(I3,': Doing waitany: nrecv =',I3,' handle = ',I3)") & narea-1, nrecv,handle #endif CALL MPI_waitany (nrecv, exch_flags1d, irecv, status, ierr) IF ( ierr .NE. MPI_SUCCESS ) THEN IF(ierr .EQ. MPI_ERR_REQUEST)THEN WRITE (*,"(I3,': ERROR: exchs_generic: MPI_waitany returned MPI_ERR_REQUEST')") narea-1 ELSE IF(ierr .EQ. MPI_ERR_ARG)THEN WRITE (*,"(I3,': ERROR: exchs_generic: MPI_waitany returned MPI_ERR_ARG')") narea-1 ELSE WRITE (*,"(I3,': ERROR: exchs_generic: MPI_waitany returned unrecognised error')") narea-1 END IF CALL ctl_stop('STOP','exchs_generic: MPI_waitany returned error') END IF DO WHILE(irecv .ne. MPI_UNDEFINED) IF ( PRESENT(b2) ) THEN ! CALL timing_start('2dr_unpack') ! Copy received data back into array ic = 0 unpack_patches2r: DO ipatch=1,npatchrecv(irecv,nhexch) jstart = jdesrecvp(ipatch,irecv,1)!+nhalo jend = jstart+nyrecvp(ipatch,irecv,1)-1 istart = idesrecvp(ipatch,irecv,1)!+nhalo iend = istart+nxrecvp(ipatch,irecv,1)-1 DO j=jstart, jend, 1 DO i=istart, iend, 1 ic = ic + 1 b2(i,j) = recvBuff(ic,irecv) END DO END DO END DO unpack_patches2r ! CALL timing_stop('2dr_unpack') ELSE IF ( PRESENT(ib2) ) THEN ! Copy received data back into array ic = 0 unpack_patches2i: DO ipatch=1,npatchrecv(irecv,nhexch),1 jstart = jdesrecvp(ipatch,irecv,1) jend = jstart+nyrecvp(ipatch,irecv,1)-1 istart = idesrecvp(ipatch,irecv,1) iend = istart+nxrecvp(ipatch,irecv,1)-1 DO j=jstart, jend, 1 DO i=istart, iend, 1 ic = ic + 1 ib2(i,j) = recvIBuff(ic,irecv) END DO END DO END DO unpack_patches2i ELSE IF (PRESENT(b3) ) THEN ! CALL timing_start('3dr_unpack') ic = 0 unpack_patches3r: DO ipatch=1,npatchrecv(irecv,nhexch) jstart = jdesrecvp(ipatch,irecv,1)!+nhalo jend = jstart+nyrecvp(ipatch,irecv,1)-1 istart = idesrecvp(ipatch,irecv,1)!+nhalo iend = istart+nxrecvp(ipatch,irecv,1)-1 #if defined key_z_first DO j=jstart, jend, 1 DO i=istart, iend, 1 DO k=1,nzrecvp(ipatch,irecv,1),1 #else DO k=1,nzrecvp(ipatch,irecv,1),1 DO j=jstart, jend, 1 DO i=istart, iend, 1 #endif ic = ic + 1 b3(i,j,k) = recvBuff(ic,irecv) END DO #if defined key_z_first ! ARPDBG - wipe anything below the ocean bottom DO k=nzrecvp(ipatch,irecv,1)+1,jpk,1 b3(i,j,k) = 0.0_wp END DO #endif END DO END DO ! ARPDBG - wipe anything below the ocean bottom #if ! defined key_z_first DO k=nzrecvp(ipatch,irecv,1)+1,jpk,1 DO j=jstart, jend, 1 DO i=istart, iend, 1 b3(i,j,k) = 0.0_wp END DO END DO END DO #endif END DO unpack_patches3r ! CALL timing_stop('3dr_unpack') ELSEIF ( PRESENT(ib3) ) THEN ic = 0 unpack_patches3i: DO ipatch=1,npatchrecv(irecv,nhexch),1 jstart = jdesrecvp(ipatch,irecv,1)!+nhalo jend = jstart+nyrecvp(ipatch,irecv,1)-1 istart = idesrecvp(ipatch,irecv,1)!+nhalo iend = istart+nxrecvp(ipatch,irecv,1)-1 #if defined key_z_first DO j=jstart, jend, 1 DO i=istart, iend, 1 DO k=1,nzrecvp(ipatch,irecv,1),1 #else DO k=1,nzrecvp(ipatch,irecv,1),1 DO j=jstart, jend, 1 DO i=istart, iend, 1 #endif ic = ic + 1 ib3(i,j,k) = recvIBuff(ic,irecv) END DO END DO END DO END DO unpack_patches3i END IF CALL MPI_waitany (nrecv, exch_flags1d, irecv, status, ierr) !IF ( ierr.NE.0 ) CALL MPI_abort(mpi_comm_opa,1,ierr) END DO ! while irecv != MPI_UNDEFINED ! CALL timing_stop('mpi_recvs') ! All receives done and unpacked so can deallocate the associated ! buffers !IF(ALLOCATED(recvBuff ))DEALLOCATE(recvBuff) !IF(ALLOCATED(recvIBuff))DEALLOCATE(recvIBuff) #if defined DEBUG_COMMS WRITE(*,"(I3,': Finished all ',I3,' receives for handle ',I3)") & narea-1, nrecv, handle #endif #endif /* key_mpp_mpi */ ! Periodic boundary condition using internal copy. ! This is performed after all data has been received so that we can ! also copy boundary points and avoid some diagonal communication. ! ! ARPDBG - performance issue: need to hoist IF block outside nested ! loop! IF ( cyclic_bc .AND. (jpni.EQ.1) ) THEN ! Find out the sizes of the arrays. kdim1 = 1 IF ( PRESENT(b3) ) THEN kdim1 = SIZE(b3,dim=index_z) ELSEIF ( PRESENT(ib3) ) THEN kdim1 = SIZE(ib3,dim=index_z) ENDIF IF ( enabled(Iplus) ) THEN !ARPDBG DO j=1,jesub,1 ! ARPDBG - nemo halos included in jesub DO j=1,jesub+jpreci !ARPDBG DO i=nhexch,1,-1 DO i=1,jpreci IF ( PRESENT(b2) ) THEN !ARPDBG b2(iesub-i+1,j) = b2(i,j) b2(iesub+i,j) = b2(i,j) ELSEIF ( PRESENT(ib2) ) THEN !ARPDBG ib2(iesub-i+1,j) = ib2(i,j) ib2(iesub+i,j) = ib2(i,j) ELSEIF ( PRESENT(b3) ) THEN ! dir$ unroll DO k=1,kdim1 !ARPDBG b3(k,iesub-i+1,j) = b3(k,i,j) b3(k,iesub+i,j) = b3(k,i,j) ENDDO ELSEIF ( PRESENT(ib3) ) THEN ! dir$ unroll DO k=1,kdim1 !ARPDBG ib3(k,iesub-i+1,j) = ib3(k,i,j) ib3(k,iesub+i,j) = ib3(k,i,j) ENDDO ENDIF ENDDO ENDDO ENDIF IF ( enabled(Iminus) ) THEN !ARPDBG DO j=1,jesub,1 DO j=1,jesub+jpreci DO i=1,jpreci IF ( PRESENT(b2) ) THEN !ARPDBG b2(i,j) = b2(iesub-i+1,j) b2(1-i,j) = b2(iesub-i+1,j) ELSEIF ( PRESENT(ib2) ) THEN !ARPDBG ib2(i,j) = ib2(iesub-i+1,j) ib2(1-i,j) = ib2(iesub-i+1,j) ELSEIF ( PRESENT(b3) ) THEN ! dir$ unroll DO k=1,kdim1 !ARPDBG b3(k,i,j) = b3(k,iesub-i+1,j) b3(1-i,j,k) = b3(iesub-i+1,j,k) ENDDO ELSEIF ( PRESENT(ib3) ) THEN ! dir$ unroll DO k=1,kdim1 !ARPDBG ib3(k,i,j) = ib3(k,iesub-i+1,j) ib3(1-i,j,k) = ib3(iesub-i+1,j,k) ENDDO ENDIF ENDDO ENDDO ENDIF ENDIF ! cyclic_bc .AND. jpni == 1 ! Copy just the set of flags we're interested in for passing to ! MPI_waitall next time around exch_flags1d(1:nsend) = exch_flags(handle, 1:nsend, indexs) ! Free the exchange communications handle. CALL free_exch_handle(handle) ! All receives done so we can safely free the MPI receive buffers IF( ALLOCATED(recvBuff) ) DEALLOCATE(recvBuff) IF( ALLOCATED(recvIBuff) )DEALLOCATE(recvIBuff) ! CALL timing_stop('exchs_generic') !CALL prof_region_end(ARPEXCHS_GENERIC, iprofStat) END SUBROUTINE exchs_generic ! ******************************************************************** !!$ SUBROUTINE exchr_generic ( b2, ib2, b3, ib3, nhalo, nhexch, & !!$ handle, comm1, comm2, comm3, comm4 ) !!$ !!$ ! ****************************************************************** !!$ !!$ ! Receive boundary data elements from adjacent sub-domains. !!$ !!$ ! b2(1-nhalo:,1-nhalo:) real input 2D real*8 local array. !!$ ! ib2(1-nhalo:,1-nhalo:) int input 2D integer local array. !!$ ! b3(:,1-nhalo:,1-nhalo:) real input 3D real*8 local array. !!$ ! ib3(:,1-nhalo:,1-nhalo:) int input 3D integer local array. !!$ ! nhalo int input Width of halo. !!$ ! nhexch int input Number of halo !!$ ! rows/cols to exchange. !!$ ! handle int input Exchange handle. !!$ ! comm1 int input Send in direction comm1. !!$ ! comm2 int input Send in direction comm2. !!$ ! comm3 int input Send in direction comm3. !!$ ! comm4 int input Send in direction comm4. !!$ !!$ ! Mike Ashworth, CCLRC, March 2005. !!$ !!$ ! ****************************************************************** !!$ USE mapcomm_mod, ONLY: iesub,jesub,MaxCommDir,Iplus,Jplus,Iminus, & !!$ Jminus, IplusJplus,IminusJminus,IplusJminus, & !!$ IminusJplus, nrecv, nxrecv,nyrecv, source, dirrecv, & !!$ idesrecv, jdesrecv, cyclic_bc, destination, & !!$ nsend, nxsend, dirsend !!$ !ARPDBG: do_exchanges below is debug only !!$ USE par_oce, ONLY: jpni, jpreci, wp, do_exchanges !!$ USE lib_mpp, ONLY: mpi_comm_opa !!$ USE dom_oce, ONLY: narea !!$#ifdef WITH_LIBHMD !!$ USE in_out_manager, ONLY: lwp !!$#endif !!$ IMPLICIT NONE !!$ !!$ INTEGER :: status(MPI_status_size) !!$ !!$ ! Subroutine arguments. !!$!xxFTRANS b3 :I :I :z !!$!xxFTRANS ib3 :I :I :z !!$ INTEGER, INTENT(In) :: nhalo,nhexch,handle !!$ REAL(wp), INTENT(inout), OPTIONAL, DIMENSION(:,:) :: b2 !!$ INTEGER, INTENT(inout), OPTIONAL, DIMENSION(:,:) :: ib2 !!$ REAL(wp), INTENT(inout), OPTIONAL, DIMENSION(:,:,:) :: b3 !!$ INTEGER, INTENT(inout), OPTIONAL, DIMENSION(:,:,:) :: ib3 !!$ INTEGER, INTENT(in) :: comm1, comm2, comm3, comm4 !!$ !!$ ! Local variables. !!$ !!$ LOGICAL :: enabled(0:MaxCommDir) !!$ INTEGER :: i, ides, ierr, irecv, isend, j, jdes, k, & !!$ kdim1, nxr, nyr !!$ !!$#ifdef PARALLEL_STATS !!$ LOGICAL :: probe !!$ INTEGER :: nbpw !!$#endif !!$ !!$ IF(.not. do_exchanges)THEN !!$ WRITE (*,*) 'ARPDBG: exchr_generic: do_exchanges is FALSE' !!$ RETURN ! ARPDBG !!$ END IF !!$ !!$#ifdef PARALLEL_STATS !!$ IF ( PRESENT(b2) .OR. PRESENT(b3) ) THEN !!$ nbpw = 8 !!$ ELSE !!$ nbpw = nbpi !!$ ENDIF !!$#endif !!$ !!$ ! Find out the sizes of the arrays. !!$ !!$ kdim1 = 1 !!$ IF ( PRESENT(b3) ) THEN !!$!! DCSE_NEMO - bug here in original code? !!$! Code used to say kdim1 = SIZE(b3,dim=1) whereas ARP thinks it should !!$! have had dim=3. Ditto for ib3 below. !!$#if defined key_z_first !!$ kdim1 = SIZE(b3,dim=1) !!$#else !!$ kdim1 = SIZE(b3,dim=3) !!$#endif !!$! isizes(3) = kdim1 !!$! isizes(2) = SIZE(b3,dim=2) !!$! isizes(1) = SIZE(b3,dim=1) !!$ ELSEIF ( PRESENT(ib3) ) THEN !!$#if defined key_z_first !!$ kdim1 = SIZE(ib3,dim=1) !!$#else !!$ kdim1 = SIZE(ib3,dim=3) !!$#endif !!$! isizes(3) = kdim1 !!$! isizes(2) = SIZE(ib3,dim=2) !!$! isizes(1) = SIZE(ib3,dim=1) !!$ ENDIF !!$ !!$ ! Check nhexch is in range. !!$ !!$ IF ( nhexch.GT.jpreci ) THEN !!$ STOP 'exchr: halo width greater than maximum' !!$ ENDIF !!$ !!$ ! Set enabled flags according to the subroutine arguments. !!$ !!$ enabled(Iplus ) = .FALSE. !!$ enabled(Jplus ) = .FALSE. !!$ enabled(Iminus) = .FALSE. !!$ enabled(Jminus) = .FALSE. !!$ enabled(comm1) = comm1.GT.0 !!$ enabled(comm2) = comm2.GT.0 !!$ enabled(comm3) = comm3.GT.0 !!$ enabled(comm4) = comm4.GT.0 !!$ !!$ ! Set diagonal communications according to the non-diagonal flags. !!$ !!$ enabled(IplusJplus ) = enabled(Iplus ).AND.enabled(Jplus ) !!$ enabled(IminusJminus)= enabled(Iminus).AND.enabled(Jminus) !!$ enabled(IplusJminus) = enabled(Iplus ).AND.enabled(Jminus) !!$ enabled(IminusJplus )= enabled(Iminus).AND.enabled(Jplus ) !!$ !!$ ! Main communications loop. !!$ !!$ ! Receive all messages in the communications list. !!$ !!$ DO irecv=1,nrecv !!$ !!$ IF ( enabled(dirrecv(irecv)) .AND. source(irecv).GE.0 & !!$! .AND. nxrecv(irecv,nhexch).GT.0 ) THEN !!$ .AND. nxrecv(irecv).GT.0 ) THEN !!$ !!$! ides = idesrecv(irecv,nhexch) !!$! jdes = jdesrecv(irecv,nhexch) !!$! nxr = nxrecv(irecv,nhexch) !!$! nyr = nyrecv(irecv,nhexch) !!$ ides = idesrecv(irecv) !!$ jdes = jdesrecv(irecv) !!$ nxr = nxrecv(irecv) !!$ nyr = nyrecv(irecv) !!$ !!$ ! Wait on the receives that were actually posted in the send routine !!$ !!$#if ( defined DEBUG && defined DEBUG_EXCHANGE ) || defined DEBUG_COMMS !!$ WRITE (*,FMT="(I4,': test for recv from ',I3,' data ',I3,' x ',I3,' to ',I3,I3)") narea-1,source(irecv),nxr,nyr,ides,jdes !!$ WRITE (*,FMT="(I4,': test flag = ',I3)") narea-1, & !!$ exch_flags(handle,irecv,indexr) !!$#endif !!$ !!$#ifdef PARALLEL_STATS !!$ CALL MPI_test (exch_flags(handle,irecv,indexr),probe,status,ierr) !!$ IF ( ierr.NE.0 ) CALL MPI_abort(mpi_comm_opa,1,ierr) !!$ IF ( .NOT.probe ) THEN !!$ nmwait = nmwait+1 !!$ ENDIF !!$#endif /* PARALLEL_STATS */ !!$ CALL MPI_wait (exch_flags(handle,irecv,indexr),status,ierr) !!$ IF ( ierr.NE.0 ) CALL MPI_abort(mpi_comm_opa,1,ierr) !!$ !!$#ifdef PARALLEL_STATS !!$ nmrecv = nmrecv + 1 !!$ nbrecv = nbrecv + kdim1*nbpw*nxr*nyr !!$ !!$#endif /* PARALLEL_STATS */ !!$ ENDIF !!$ !!$ ENDDO !!$ !!$ ! Periodic boundary condition using internal copy. !!$ ! This is performed after all data has been received so that we can !!$ ! also copy boundary points and avoid some diagonal communication. !!$ !!$ IF ( cyclic_bc .AND. jpni.EQ.1 ) THEN !!$ !!$ IF ( enabled(Iplus) ) THEN !!$ !ARPDBG DO j=1,jesub,1 ! ARPDBG - nemo halos included in jesub !!$!ARPDBG - broken? Loop over j is used as 3rd index in 3D arrays !!$!ARPDBG but kdim1 is correctly(?) set to extent of first dimension !!$ DO j=1,jesub+jpreci !!$ !ARPDBG DO i=nhexch,1,-1 !!$ DO i=1,jpreci !!$ IF ( PRESENT(b2) ) THEN !!$ !ARPDBG b2(iesub-i+1,j) = b2(i,j) !!$ b2(iesub+i,j) = b2(i,j) !!$ ELSEIF ( PRESENT(ib2) ) THEN !!$ !ARPDBG ib2(iesub-i+1,j) = ib2(i,j) !!$ ib2(iesub+i,j) = ib2(i,j) !!$ ELSEIF ( PRESENT(b3) ) THEN !!$ ! dir$ unroll !!$ DO k=1,kdim1 !!$ !ARPDBG b3(k,iesub-i+1,j) = b3(k,i,j) !!$ b3(k,iesub+i,j) = b3(k,i,j) !!$ ENDDO !!$ ELSEIF ( PRESENT(ib3) ) THEN !!$ ! dir$ unroll !!$ DO k=1,kdim1 !!$ !ARPDBG ib3(k,iesub-i+1,j) = ib3(k,i,j) !!$ ib3(k,iesub+i,j) = ib3(k,i,j) !!$ ENDDO !!$ ENDIF !!$ ENDDO !!$ ENDDO !!$ ENDIF !!$ !!$ IF ( enabled(Iminus) ) THEN !!$ !ARPDBG DO j=1,jesub,1 !!$ DO j=1,jesub+jpreci !!$ DO i=1,jpreci !!$ IF ( PRESENT(b2) ) THEN !!$ !ARPDBG b2(i,j) = b2(iesub-i+1,j) !!$ b2(1-i,j) = b2(iesub-i+1,j) !!$ ELSEIF ( PRESENT(ib2) ) THEN !!$ !ARPDBG ib2(i,j) = ib2(iesub-i+1,j) !!$ ib2(1-i,j) = ib2(iesub-i+1,j) !!$ ELSEIF ( PRESENT(b3) ) THEN !!$ ! dir$ unroll !!$ DO k=1,kdim1 !!$ !ARPDBG b3(k,i,j) = b3(k,iesub-i+1,j) !!$ b3(1-i,j,k) = b3(iesub-i+1,j,k) !!$ ENDDO !!$ ELSEIF ( PRESENT(ib3) ) THEN !!$ ! dir$ unroll !!$ DO k=1,kdim1 !!$ !ARPDBG ib3(k,i,j) = ib3(k,iesub-i+1,j) !!$ ib3(1-i,j,k) = ib3(iesub-i+1,j,k) !!$ ENDDO !!$ ENDIF !!$ ENDDO !!$ ENDDO !!$ ENDIF !!$ !!$ ENDIF !!$ !!$ IF ( immed ) THEN !!$ !!$ ! Check completion for immediate sends. !!$ !!$ DO isend=1,nsend !!$ !!$ IF (enabled(dirsend(isend)) .AND. & !!$ destination(isend).GE.0 .AND. nxsend(isend,nhexch).GT.0 ) THEN !!$ !!$ CALL MPI_wait (exch_flags(handle,isend,indexs),status,ierr) !!$ IF ( ierr.NE.0 ) CALL MPI_abort(mpi_comm_opa,1,ierr) !!$ !!$ ENDIF !!$ !!$ ENDDO !!$ !!$ ENDIF !!$ !!$ ! Free the exchange communications handle. !!$ !!$ CALL free_exch_handle(handle) !!$ !!$ END SUBROUTINE exchr_generic !======================================================================= SUBROUTINE mpp_lbc_north_list(list, nfields) USE par_oce, ONLY : jpni, jpi, jpj USE dom_oce, ONLY : nldi, nlei, npolj, nldit, nleit, narea, nlcj, & nwidthmax USE mapcomm_mod, ONLY : pielb, piesub USE lib_mpp, ONLY : ctl_stop IMPLICIT none ! Subroutine arguments. TYPE (exch_item), DIMENSION(:), INTENT(inout) :: list INTEGER, INTENT(in) :: nfields !! * Local declarations INTEGER :: ijpj ! No. of rows to operate upon INTEGER :: ii, ji, jj, jk, jji, jjr, jr, jproc, klimit INTEGER :: ierr, ifield, ishifti, ishiftr INTEGER :: ildi,ilei,iilb INTEGER :: ij,ijt,iju, isgn INTEGER :: itaille !FTRANS ztab :I :I :z !FTRANS iztab :I :I :z !FTRANS znorthgloio :I :I :z : !FTRANS iznorthgloio :I :I :z : !FTRANS znorthloc :I :I :z !FTRANS iznorthloc :I :I :z INTEGER, DIMENSION(:,:,:), ALLOCATABLE, SAVE :: iztab INTEGER, DIMENSION(:,:,:,:), ALLOCATABLE, SAVE :: iznorthgloio INTEGER, DIMENSION(:,:,:), ALLOCATABLE, SAVE :: iznorthloc REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, SAVE :: ztab REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE, SAVE :: znorthgloio REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, SAVE :: znorthloc REAL(wp) :: psgn ! control of the sign change LOGICAL :: field_is_real, fields_all_real, fields_all_int LOGICAL :: fields_all_3d, fields_all_2d !!---------------------------------------------------------------------- CALL prof_region_begin(ARPNORTHLISTCOMMS, "NorthList", iprofStat) #if defined key_mpp_mpi ! If we get into this routine it's because : North fold condition and mpp ! with more than one PE across i : we deal only with the North condition ! Set no. of rows from a module parameter that is also used in exchtestmod ! and mpp_ini_north ijpj = num_nfold_rows ! Allocate work-space arrays IF(.not. ALLOCATED(ztab))THEN ALLOCATE(ztab(jpiglo,maxExchItems*ijpj,jpkorig), & iztab(jpiglo,maxExchItems*ijpj,jpkorig), & znorthgloio(nwidthmax,maxExchItems*ijpj,jpkorig,jpni), & znorthloc(nwidthmax,maxExchItems*ijpj,jpkorig), & iznorthgloio(nwidthmax,maxExchItems*ijpj,jpkorig,jpni), & iznorthloc(nwidthmax,maxExchItems*ijpj,jpkorig), & STAT=ierr) IF(ierr .ne. 0)THEN CALL ctl_stop('STOP','mpp_lbc_north_list: memory allocation failed') RETURN END IF END IF ! put the last ijpj jlines of each real field into znorthloc ! znorthloc(:,:,:) = 0_wp ! because of padding for nwidthmax ! iznorthloc(:,:,:) = 0 ishiftr = 0 ishifti = 0 fields_all_real = .TRUE. fields_all_int = .TRUE. fields_all_3d = .TRUE. fields_all_2d = .TRUE. CALL prof_region_begin(NORTHLISTGATHER, "NorthListGather", iprofStat) DO ifield=1,nfields,1 IF(ASSOCIATED(list(ifield)%r2dptr))THEN DO ij = 1, ijpj, 1 jj = nlcj - ijpj + ij znorthloc(nldi:nlei,ij+ishiftr,1) = & list(ifield)%r2dptr(nldi:nlei,jj) END DO ishiftr = ishiftr + ijpj fields_all_int = .FALSE. fields_all_3d = .FALSE. ELSE IF(ASSOCIATED(list(ifield)%r3dptr))THEN #if defined key_z_first DO ij = 1, ijpj, 1 jj = nlcj - ijpj + ij DO ii = nldi, nlei, 1 DO jk = 1, jpk #else DO jk = 1, jpk DO ij = 1, ijpj, 1 jj = nlcj - ijpj + ij DO ii = nldi, nlei, 1 #endif znorthloc(ii,ij+ishiftr,jk) = & list(ifield)%r3dptr(ii,jj,jk) END DO END DO END DO ishiftr = ishiftr + ijpj fields_all_int = .FALSE. fields_all_2d = .FALSE. ELSE IF(ASSOCIATED(list(ifield)%i2dptr))THEN DO ij = 1, ijpj, 1 jj = nlcj - ijpj + ij iznorthloc(nldi:nlei,ij+ishifti,1) = & list(ifield)%i2dptr(nldi:nlei,jj) END DO ishifti = ishifti + ijpj fields_all_real = .FALSE. fields_all_3d = .FALSE. ELSE IF(ASSOCIATED(list(ifield)%i3dptr))THEN #if defined key_z_first DO ij = 1, ijpj, 1 jj = nlcj - ijpj + ij DO ii = nldi, nlei, 1 DO jk = 1, jpk #else DO jk = 1, jpk DO ij = 1, ijpj, 1 jj = nlcj - ijpj + ij DO ii = nldi, nlei, 1 #endif iznorthloc(ii,ij+ishifti,jk) = & list(ifield)%i3dptr(ii,jj,jk) END DO END DO END DO ishifti = ishifti + ijpj fields_all_real = .FALSE. fields_all_2d = .FALSE. END IF END DO ! loop over fields klimit = 1 IF(.not. fields_all_2d)klimit = jpk IF (npolj /= 0 ) THEN IF(.NOT. fields_all_int )THEN ! Build znorthgloio on proc 0 of ncomm_north !znorthgloio(:,:,:,:) = 0_wp itaille=nwidthmax*ishiftr*klimit #if defined key_mpp_mpi CALL MPI_GATHER(znorthloc,itaille,MPI_DOUBLE_PRECISION, & znorthgloio,itaille,MPI_DOUBLE_PRECISION, & 0, ncomm_north, ierr) #endif END IF IF(.NOT. fields_all_real )THEN ! Build iznorthgloio on proc 0 of ncomm_north !iznorthgloio(:,:,:,:) = 0 itaille=nwidthmax*ishifti*klimit #if defined key_mpp_mpi CALL MPI_GATHER(iznorthloc,itaille,MPI_INTEGER, & iznorthgloio,itaille,MPI_INTEGER,& 0, ncomm_north, ierr) #endif END IF ENDIF CALL prof_region_end(NORTHLISTGATHER, iprofStat) CALL prof_region_begin(ARPNORTHAPPLYSYMM, "NorthListApplySymm", iprofStat) IF (narea == north_root+1 ) THEN ! recover the global north array for every field ! ztab(:,:,:) = 0_wp ! iztab(:,:,:) = 0_wp IF( .NOT. fields_all_int )THEN DO jr = 1, ndim_rank_north jproc = nrank_north(jr) + 1 ildi = nldit (jproc) ilei = nleit (jproc) iilb = pielb(jproc) ztab(iilb:iilb+piesub(jproc)-1,1:ishiftr,1:jpk) = & znorthgloio(ildi:ilei,1:ishiftr,1:jpk,jr) END DO END IF IF( .NOT. fields_all_real )THEN DO jr = 1, ndim_rank_north jproc = nrank_north(jr) + 1 ildi = nldit (jproc) ilei = nleit (jproc) iilb = pielb(jproc) iztab(iilb:iilb+piesub(jproc)-1,1:ishifti,1:jpk) = & iznorthgloio(ildi:ilei,1:ishifti,1:jpk,jr) END DO END IF ! Horizontal slab ! =============== jji = ijpj jjr = ijpj ! 2. North-Fold boundary conditions ! ---------------------------------- SELECT CASE ( npolj ) CASE ( 3, 4 ) ! * North fold T-point pivot DO ifield=1, nfields, 1 ! Set-up stuff dependent on whether this field is real or integer field_is_real = .FALSE. IF(ASSOCIATED(list(ifield)%r3dptr) .OR. & ASSOCIATED(list(ifield)%r2dptr) )field_is_real = .TRUE. isgn = list(ifield)%isgn psgn = REAL(isgn, wp) ! Set up stuff dependent on whether this field is 2- or 3-dimensional IF(fields_all_3d)THEN klimit=jpk ELSE IF(fields_all_2d)THEN klimit = 1 ELSE IF(ASSOCIATED(list(ifield)%r3dptr) .OR. & ASSOCIATED(list(ifield)%i3dptr) )THEN klimit=jpk ELSE klimit = 1 END IF END IF IF(field_is_real)THEN ztab( 1 , jjr, 1:klimit) = 0._wp ztab(jpiglo, jjr, 1:klimit) = 0._wp ELSE iztab( 1 , jji, 1:klimit) = 0 iztab(jpiglo, jji, 1:klimit) = 0 END IF SELECT CASE ( list(ifield)%grid ) CASE ( 'T' , 'W' , 'S' ) ! T-, W-point IF(field_is_real)THEN #if defined key_z_first DO ji = 2, jpiglo/2 ijt = jpiglo-ji+2 DO jk = 1,klimit,1 ztab(ji,jjr,jk) = psgn * ztab(ijt,jjr-2,jk) END DO END DO DO ji = jpiglo/2+1, jpiglo ijt = jpiglo-ji+2 DO jk = 1,klimit,1 ztab(ji,jjr-1,jk) = psgn * ztab(ijt,jjr-1,jk) ztab(ji,jjr, jk) = psgn * ztab(ijt,jjr-2,jk) END DO END DO #else DO jk = 1,klimit,1 DO ji = 2, jpiglo/2 ijt = jpiglo-ji+2 ztab(ji,jjr,jk) = psgn * ztab(ijt,jjr-2,jk) END DO DO ji = jpiglo/2+1, jpiglo ijt = jpiglo-ji+2 ztab(ji,jjr-1,jk) = psgn * ztab(ijt,jjr-1,jk) ztab(ji,jjr, jk) = psgn * ztab(ijt,jjr-2,jk) END DO END DO #endif ELSE #if defined key_z_first DO ji = 2, jpiglo ijt = jpiglo-ji+2 DO jk=1,klimit,1 iztab(ji,jji,jk) = isgn * iztab(ijt,jji-2,jk) END DO END DO DO ji = jpiglo/2+1, jpiglo ijt = jpiglo-ji+2 DO jk=1,klimit,1 iztab(ji,jji-1,jk) = isgn * iztab(ijt,jji-1,jk) END DO END DO #else DO jk=1,klimit,1 DO ji = 2, jpiglo ijt = jpiglo-ji+2 iztab(ji,jji,jk) = isgn * iztab(ijt,jji-2,jk) END DO DO ji = jpiglo/2+1, jpiglo ijt = jpiglo-ji+2 iztab(ji,jji-1,jk) = isgn * iztab(ijt,jji-1,jk) END DO END DO #endif END IF CASE ( 'U' ) ! U-point IF(field_is_real)THEN #if defined key_z_first DO ji = 1, jpiglo-1 iju = jpiglo-ji+1 DO jk=1,klimit,1 ztab(ji,jjr,jk) = psgn * ztab(iju,jjr-2,jk) END DO END DO DO ji = jpiglo/2, jpiglo-1 iju = jpiglo-ji+1 DO jk=1,klimit,1 ztab(ji,jjr-1,jk) = psgn * ztab(iju,jjr-1,jk) END DO END DO #else DO jk=1,klimit,1 DO ji = 1, jpiglo-1 iju = jpiglo-ji+1 ztab(ji,jjr,jk) = psgn * ztab(iju,jjr-2,jk) END DO DO ji = jpiglo/2, jpiglo-1 iju = jpiglo-ji+1 ztab(ji,jjr-1,jk) = psgn * ztab(iju,jjr-1,jk) END DO END DO #endif ELSE #if defined key_z_first DO ji = 1, jpiglo-1 iju = jpiglo-ji+1 DO jk=1,klimit,1 iztab(ji,jji,jk) = isgn * iztab(iju,jji-2,jk) END DO END DO DO ji = jpiglo/2, jpiglo-1 iju = jpiglo-ji+1 DO jk=1,klimit,1 iztab(ji,jji-1,jk) = isgn * iztab(iju,jji-1,jk) END DO END DO #else DO jk=1,klimit,1 DO ji = 1, jpiglo-1 iju = jpiglo-ji+1 iztab(ji,jji,jk) = isgn * iztab(iju,jji-2,jk) END DO DO ji = jpiglo/2, jpiglo-1 iju = jpiglo-ji+1 iztab(ji,jji-1,jk) = isgn * iztab(iju,jji-1,jk) END DO END DO #endif END IF CASE ( 'V' ) ! V-point IF(field_is_real)THEN #if defined key_z_first DO ji = 2, jpiglo ijt = jpiglo-ji+2 DO jk=1,klimit,1 #else DO jk=1,klimit,1 DO ji = 2, jpiglo ijt = jpiglo-ji+2 #endif ztab(ji,jjr-1,jk) = psgn * ztab(ijt,jjr-2,jk) ztab(ji,jjr ,jk) = psgn * ztab(ijt,jjr-3,jk) END DO END DO ELSE #if defined key_z_first DO ji = 2, jpiglo ijt = jpiglo-ji+2 DO jk=1,klimit,1 #else DO jk=1,klimit,1 DO ji = 2, jpiglo ijt = jpiglo-ji+2 #endif iztab(ji,jji-1,jk) = isgn * iztab(ijt,jji-2,jk) iztab(ji,jji ,jk) = isgn * iztab(ijt,jji-3,jk) END DO END DO END IF CASE ( 'F' , 'G' ) ! F-point IF(field_is_real)THEN #if defined key_z_first DO ji = 1, jpiglo-1 iju = jpiglo-ji+1 DO jk=1,klimit,1 #else DO jk=1,klimit,1 DO ji = 1, jpiglo-1 iju = jpiglo-ji+1 #endif ztab(ji,jjr-1,jk) = psgn * ztab(iju,jjr-2,jk) ztab(ji,jjr ,jk) = psgn * ztab(iju,jjr-3,jk) END DO END DO ELSE #if defined key_z_first DO ji = 1, jpiglo-1 iju = jpiglo-ji+1 DO jk=1,klimit,1 #else DO jk=1,klimit,1 DO ji = 1, jpiglo-1 iju = jpiglo-ji+1 #endif iztab(ji,jji-1,jk) = isgn * iztab(iju,jji-2,jk) iztab(ji,jji ,jk) = isgn * iztab(iju,jji-3,jk) END DO END DO END IF CASE ( 'I' ) ! ice U-V point IF(field_is_real)THEN #if defined key_z_first DO jk=1,klimit,1 ztab(2,jjr,jk) = psgn * ztab(3,jjr-1,jk) END DO DO ji = 3, jpiglo iju = jpiglo - ji + 3 DO jk=1,klimit,1 #else DO jk=1,klimit,1 ztab(2,jjr,jk) = psgn * ztab(3,jjr-1,jk) DO ji = 3, jpiglo iju = jpiglo - ji + 3 #endif ztab(ji,jjr,jk) = psgn * ztab(iju,jjr-1,jk) END DO END DO ELSE #if defined key_z_first DO jk=1,klimit,1 iztab(2,jji,jk) = isgn * iztab(3,jji-1,jk) END DO DO ji = 3, jpiglo iju = jpiglo - ji + 3 DO jk=1,klimit,1 #else DO jk=1,klimit,1 iztab(2,jji,jk) = isgn * iztab(3,jji-1,jk) DO ji = 3, jpiglo iju = jpiglo - ji + 3 #endif iztab(ji,jji,jk) = isgn * iztab(iju,jji-1,jk) END DO END DO END IF END SELECT ! Move to the next set of ijpj rows corresponding to the next field jjr = jjr + ijpj jji = jji + ijpj END DO ! Loop over fields CASE ( 5, 6 ) ! * North fold F-point pivot DO ifield=1, nfields, 1 ! Set-up stuff dependent on whether this field is real or integer field_is_real = .FALSE. IF(ASSOCIATED(list(ifield)%r3dptr) .OR. & ASSOCIATED(list(ifield)%r2dptr) )field_is_real = .TRUE. isgn = list(ifield)%isgn psgn=REAL(isgn, wp) ! Set up stuff dependent on whether this field is 2- or 3-dimensional IF(fields_all_3d)THEN klimit=jpk ELSE IF(fields_all_2d)THEN klimit = 1 ELSE IF(ASSOCIATED(list(ifield)%r3dptr) .OR. & ASSOCIATED(list(ifield)%i3dptr) )THEN klimit=jpk ELSE klimit = 1 END IF END IF IF(field_is_real)THEN DO jk = 1, klimit, 1 ztab( 1 ,jjr,jk) = 0.0_wp ztab(jpiglo,jjr,jk) = 0.0_wp END DO ELSE DO jk = 1, klimit, 1 iztab( 1 ,jji,jk) = 0 iztab(jpiglo,jji,jk) = 0 END DO END IF SELECT CASE ( list(ifield)%grid ) CASE ( 'T' , 'W' ,'S' ) ! T-, W-point IF(field_is_real)THEN #if defined key_z_first DO ji = 1, jpiglo ijt = jpiglo-ji+1 DO jk = 1,klimit,1 #else DO jk = 1,klimit,1 DO ji = 1, jpiglo ijt = jpiglo-ji+1 #endif ztab(ji,jjr,jk) = psgn * ztab(ijt,jjr-1,jk) END DO END DO ELSE #if defined key_z_first DO ji = 1, jpiglo ijt = jpiglo-ji+1 DO jk=1,klimit,1 #else DO jk=1,klimit,1 DO ji = 1, jpiglo ijt = jpiglo-ji+1 #endif iztab(ji,jji,jk) = isgn * iztab(ijt,jji-1,jk) END DO END DO END IF CASE ( 'U' ) ! U-point IF(field_is_real)THEN #if defined key_z_first DO ji = 1, jpiglo-1 iju = jpiglo-ji DO jk=1,klimit,1 #else DO jk=1,klimit,1 DO ji = 1, jpiglo-1 iju = jpiglo-ji #endif ztab(ji,jjr,jk) = psgn * ztab(iju,jjr-1,jk) END DO END DO ELSE #if defined key_z_first DO ji = 1, jpiglo-1 iju = jpiglo-ji DO jk=1,klimit,1 #else DO jk=1,klimit,1 DO ji = 1, jpiglo-1 iju = jpiglo-ji #endif iztab(ji,jji,jk) = isgn * iztab(iju,jji-1,jk) END DO END DO END IF CASE ( 'V' ) ! V-point IF(field_is_real)THEN #if defined key_z_first DO ji = 1, jpiglo ijt = jpiglo-ji+1 DO jk=1,klimit,1 ztab(ji,jjr,jk) = psgn * ztab(ijt,jjr-2,jk) END DO END DO DO ji = jpiglo/2+1, jpiglo ijt = jpiglo-ji+1 DO jk=1,klimit,1 ztab(ji,jjr-1,jk) = psgn * ztab(ijt,jjr-1,jk) END DO END DO #else DO jk=1,klimit,1 DO ji = 1, jpiglo ijt = jpiglo-ji+1 ztab(ji,jjr,jk) = psgn * ztab(ijt,jjr-2,jk) END DO DO ji = jpiglo/2+1, jpiglo ijt = jpiglo-ji+1 ztab(ji,jjr-1,jk) = psgn * ztab(ijt,jjr-1,jk) END DO END DO #endif ELSE #if defined key_z_first DO ji = 1, jpiglo ijt = jpiglo-ji+1 DO jk=1,klimit,1 iztab(ji,jji,jk) = isgn * iztab(ijt,jji-2,jk) END DO END DO DO ji = jpiglo/2+1, jpiglo ijt = jpiglo-ji+1 DO jk=1,klimit,1 iztab(ji,jji-1,jk) = isgn * iztab(ijt,jji-1,jk) END DO END DO #else DO jk=1,klimit,1 DO ji = 1, jpiglo ijt = jpiglo-ji+1 iztab(ji,jji,jk) = isgn * iztab(ijt,jji-2,jk) END DO DO ji = jpiglo/2+1, jpiglo ijt = jpiglo-ji+1 iztab(ji,jji-1,jk) = isgn * iztab(ijt,jji-1,jk) END DO END DO #endif END IF CASE ( 'F' , 'G' ) ! F-point IF(field_is_real)THEN #if defined key_z_first DO ji = 1, jpiglo-1 iju = jpiglo-ji DO jk=1,klimit,1 ztab(ji,jjr ,jk) = psgn * ztab(iju,jjr-2,jk) END DO END DO DO ji = jpiglo/2+1, jpiglo-1 iju = jpiglo-ji DO jk=1,klimit,1 ztab(ji,jjr-1,jk) = psgn * ztab(iju,jjr-1,jk) END DO END DO #else DO jk=1,klimit,1 DO ji = 1, jpiglo-1 iju = jpiglo-ji ztab(ji,jjr ,jk) = psgn * ztab(iju,jjr-2,jk) END DO DO ji = jpiglo/2+1, jpiglo-1 iju = jpiglo-ji ztab(ji,jjr-1,jk) = psgn * ztab(iju,jjr-1,jk) END DO END DO #endif ELSE #if defined key_z_first DO ji = 1, jpiglo-1 iju = jpiglo-ji DO jk=1,klimit,1 iztab(ji,jji ,jk) = isgn * iztab(iju,jji-2,jk) END DO END DO DO ji = jpiglo/2+1, jpiglo-1 iju = jpiglo-ji DO jk=1,klimit,1 iztab(ji,jji-1,jk) = isgn * iztab(iju,jji-1,jk) END DO END DO #else DO jk=1,klimit,1 DO ji = 1, jpiglo-1 iju = jpiglo-ji iztab(ji,jji ,jk) = isgn * iztab(iju,jji-2,jk) END DO DO ji = jpiglo/2+1, jpiglo-1 iju = jpiglo-ji iztab(ji,jji-1,jk) = isgn * iztab(iju,jji-1,jk) END DO END DO #endif END IF CASE ( 'I' ) ! ice U-V point IF(field_is_real)THEN #if defined key_z_first DO jk=1,klimit,1 ztab( 2 ,jjr,jk) = 0._wp END DO DO ji = 2 , jpiglo-1 ijt = jpiglo - ji + 2 DO jk=1,klimit,1 ztab(ji,jjr,jk)= 0.5 * ( ztab(ji,jjr-1,jk) + & psgn * ztab(ijt,jjr-1,jk) ) END DO END DO #else DO jk=1,klimit,1 ztab( 2 ,jjr,jk) = 0._wp DO ji = 2 , jpiglo-1 ijt = jpiglo - ji + 2 ztab(ji,jjr,jk)= 0.5 * ( ztab(ji,jjr-1,jk) + & psgn * ztab(ijt,jjr-1,jk) ) END DO END DO #endif ELSE #if defined key_z_first DO jk=1,klimit,1 iztab( 2 ,jji,jk) = 0 END DO DO ji = 2 , jpiglo-1 ijt = jpiglo - ji + 2 DO jk=1,klimit,1 iztab(ji,jji,jk)= 0.5 * ( iztab(ji,jji-1,jk) + & isgn * iztab(ijt,jji-1,jk) ) END DO END DO #else DO jk=1,klimit,1 iztab( 2 ,jji,jk) = 0 DO ji = 2 , jpiglo-1 ijt = jpiglo - ji + 2 iztab(ji,jji,jk)= 0.5 * ( iztab(ji,jji-1,jk) + & isgn * iztab(ijt,jji-1,jk) ) END DO END DO #endif END IF END SELECT ! Move to the next set of ijpj rows corresponding to the next field jjr = jjr + ijpj jji = jji + ijpj END DO ! loop over fields CASE DEFAULT ! * closed : the code probably never go through DO ifield=1, nfields, 1 ! Set-up stuff dependent on whether this field is real or integer field_is_real = .FALSE. IF(ASSOCIATED(list(ifield)%r3dptr) .OR. & ASSOCIATED(list(ifield)%r2dptr) )field_is_real = .TRUE. ! Set up stuff dependent on whether this field is ! 2- or 3-dimensional IF(fields_all_3d)THEN klimit=jpk ELSE IF(fields_all_2d)THEN klimit = 1 ELSE IF(ASSOCIATED(list(ifield)%r3dptr) .OR. & ASSOCIATED(list(ifield)%i3dptr) )THEN klimit=jpk ELSE klimit = 1 END IF END IF SELECT CASE ( list(ifield)%grid) CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points IF(field_is_real)THEN #if defined key_z_first DO ii = 1, jpiglo, 1 DO jk = 1, klimit, 1 #else DO jk = 1, klimit, 1 DO ii = 1, jpiglo, 1 #endif ztab(ii, 1 , jk) = 0_wp ztab(ii,jjr, jk) = 0_wp END DO END DO ELSE #if defined key_z_first DO ii = 1, jpiglo, 1 DO jk = 1, klimit, 1 #else DO jk = 1, klimit, 1 DO ii = 1, jpiglo, 1 #endif iztab(ii, 1 ,jk) = 0 iztab(ii,jji,jk) = 0 END DO END DO END IF CASE ( 'F' ) ! F-point IF(field_is_real)THEN ztab(:,jjr,1:klimit) = 0_wp ELSE iztab(:,jji,1:klimit) = 0 END IF CASE ( 'I' ) ! ice U-V point IF(field_is_real)THEN #if defined key_z_first DO ii = 1, jpiglo, 1 DO jk = 1, klimit, 1 #else DO jk = 1, klimit, 1 DO ii = 1, jpiglo, 1 #endif ztab(ii, 1 ,jk) = 0_wp ztab(ii,jjr,jk) = 0_wp END DO END DO ELSE #if defined key_z_first DO ii = 1, jpiglo, 1 DO jk = 1, klimit, 1 #else DO jk = 1, klimit, 1 DO ii = 1, jpiglo, 1 #endif iztab(ii, 1 ,jk) = 0 iztab(ii,jji,jk) = 0 END DO END DO END IF END SELECT ! Move to the next set of ijpj rows corresponding to the next field jjr = jjr + ijpj jji = jji + ijpj END DO ! loop over fields END SELECT ! End of slab ! =========== !! Scatter back to original array(s) !!$ DO jr = 1, ndim_rank_north !!$ jproc=nrank_north(jr)+1 !!$ ildi=nldit (jproc) !!$ ilei=nleit (jproc) !!$ iilb=pielb(jproc) !!$ IF(.NOT. fields_all_int)THEN !!$ znorthgloio(ildi:ilei,1:ishiftr,1:klimit,jr) = & !!$ ztab(iilb:iilb+piesub(jproc)-1,1:ishiftr,1:klimit) !!$ END IF !!$ IF(.NOT. fields_all_real)THEN !!$ iznorthgloio(ildi:ilei,1:ishifti,1:klimit,jr) = & !!$ iztab(iilb:iilb+piesub(jproc)-1,1:ishifti,1:klimit) !!$ END IF !!$ END DO IF(fields_all_int)THEN DO jr = 1, ndim_rank_north jproc=nrank_north(jr)+1 ildi=nldit (jproc) ilei=nleit (jproc) iilb=pielb(jproc) ! ARPDBG - make loop ordering explicit for performance? iznorthgloio(ildi:ilei,1:ishifti,1:klimit,jr) = & iztab(iilb:iilb+piesub(jproc)-1,1:ishifti,1:klimit) END DO ELSE IF(fields_all_real)THEN DO jr = 1, ndim_rank_north jproc=nrank_north(jr)+1 ildi=nldit (jproc) ilei=nleit (jproc) iilb=pielb(jproc) ! ARPDBG - make loop ordering explicit for performance? znorthgloio(ildi:ilei,1:ishiftr,1:klimit,jr) = & ztab(iilb:iilb+piesub(jproc)-1,1:ishiftr,1:klimit) END DO ELSE ! Have some real and some integer fields DO jr = 1, ndim_rank_north jproc=nrank_north(jr)+1 ildi=nldit (jproc) ilei=nleit (jproc) iilb=pielb(jproc) ! ARPDBG - make loop ordering explicit for performance? znorthgloio(ildi:ilei,1:ishiftr,1:klimit,jr) = & ztab(iilb:iilb+piesub(jproc)-1,1:ishiftr,1:klimit) iznorthgloio(ildi:ilei,1:ishifti,1:klimit,jr) = & iztab(iilb:iilb+piesub(jproc)-1,1:ishifti,1:klimit) END DO END IF ENDIF ! only done on proc 0 of ncomm_north CALL prof_region_end(ARPNORTHAPPLYSYMM, iprofStat) CALL prof_region_begin(NORTHLISTSCATTER, "NorthListScatter", iprofStat) IF ( npolj /= 0 ) THEN IF(.NOT. fields_all_int)THEN itaille=nwidthmax*ishiftr*klimit CALL MPI_SCATTER(znorthgloio,itaille,MPI_DOUBLE_PRECISION, & znorthloc, itaille,MPI_DOUBLE_PRECISION, & 0, ncomm_north,ierr) END IF IF(.NOT. fields_all_real)THEN itaille=nwidthmax*ishifti*klimit CALL MPI_SCATTER(iznorthgloio,itaille,MPI_INTEGER, & iznorthloc, itaille,MPI_INTEGER, & 0, ncomm_north,ierr) END IF ENDIF ! put back the last ijpj jlines of each field ishiftr = 0 ishifti = 0 DO ifield=1,nfields,1 IF(ASSOCIATED(list(ifield)%r2dptr))THEN DO ij = 1, ijpj, 1 jj = nlcj - ijpj + ij list(ifield)%r2dptr(nldi:nlei,jj)= znorthloc(nldi:nlei,ij+ishiftr,1) END DO ishiftr = ishiftr + ijpj ELSE IF(ASSOCIATED(list(ifield)%r3dptr))THEN #if defined key_z_first DO ij = 1, ijpj, 1 jj = nlcj - ijpj + ij DO jk = 1, jpk #else DO jk = 1, jpk DO ij = 1, ijpj, 1 jj = nlcj - ijpj + ij #endif ! ARPDBG Make loop over i explicit for performance? list(ifield)%r3dptr(nldi:nlei,jj,jk)= znorthloc(nldi:nlei,ij+ishiftr,jk) END DO END DO ishiftr = ishiftr + ijpj ELSE IF(ASSOCIATED(list(ifield)%i2dptr))THEN DO ij = 1, ijpj, 1 jj = nlcj - ijpj + ij list(ifield)%i2dptr(nldi:nlei,jj)= iznorthloc(nldi:nlei,ij+ishifti,1) END DO ishifti = ishifti + ijpj ELSE IF(ASSOCIATED(list(ifield)%i3dptr))THEN #if defined key_z_first DO ij = 1, ijpj, 1 jj = nlcj - ijpj + ij DO jk = 1, jpk #else DO jk = 1, jpk DO ij = 1, ijpj, 1 jj = nlcj - ijpj + ij #endif ! ARPDBG Make loop over i explicit for performance? list(ifield)%i3dptr(nldi:nlei,jj,jk)= iznorthloc(nldi:nlei,ij+ishifti,jk) END DO END DO ishifti = ishifti + ijpj END IF END DO ! loop over fields CALL prof_region_end(NORTHLISTSCATTER, iprofStat) #endif /* key_mpp_mpi */ CALL prof_region_end(ARPNORTHLISTCOMMS, iprofStat) END SUBROUTINE mpp_lbc_north_list !============================================================================ SUBROUTINE mpp_lbc_north_2d ( pt2d, cd_type, psgn) !!--------------------------------------------------------------------- !! *** routine mpp_lbc_north_2d *** !! !! ** Purpose : !! Ensure proper north fold horizontal bondary condition in mpp !! configuration in case of jpn1 > 1 (for 2d array ) !! !! ** Method : !! Gather the 4 northern lines of the global domain on 1 processor and !! apply lbc north-fold on this sub array. Then scatter the fold array !! back to the processors. !! !! History : !! 8.5 ! 03-09 (J.M. Molines ) For mpp folding condition at north !! from lbc routine !! 9.0 ! 03-12 (J.M. Molines ) encapsulation into lib_mpp, coding !! rules of lbc_lnk !!---------------------------------------------------------------------- USE par_oce, ONLY : jpni, jpi, jpj USE dom_oce, ONLY : nldi, nlei, npolj, nldit, nleit, narea, nlcj, & nwidthmax USE mapcomm_mod, ONLY : pielb, piesub USE lib_mpp, ONLY : ctl_stop USE arpdebugging, ONLY: dump_array IMPLICIT none !! * Arguments CHARACTER(len=1), INTENT( in ) :: & cd_type ! nature of pt2d grid-points ! ! = T , U , V , F or W gridpoints REAL(wp), DIMENSION(jpi,jpj), INTENT( inout ) :: & pt2d ! 2D array on which the boundary condition is applied REAL(wp), INTENT( in ) :: & psgn ! control of the sign change ! ! = -1. , the sign is changed if north fold boundary ! ! = 1. , the sign is kept if north fold boundary !! * Local declarations INTEGER :: ijpj INTEGER :: ji, jj, jr, jproc INTEGER :: ierr INTEGER :: ildi,ilei,iilb INTEGER :: ijpjm1,ij,ijt,iju INTEGER :: itaille REAL(wp), DIMENSION(:,:), ALLOCATABLE, SAVE :: ztab2 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, SAVE :: znorthgloio2 REAL(wp), DIMENSION(:,:), ALLOCATABLE, SAVE :: znorthloc2 !!---------------------------------------------------------------------- !! OPA 8.5, LODYC-IPSL (2002) !!---------------------------------------------------------------------- ! If we get in this routine it's because : North fold condition and mpp ! with more than one PE across i : we deal only with the North condition ! Set local from public PARAMETER ijpj = num_nfold_rows CALL prof_region_begin(ARPNORTHCOMMS2D, "North2D", iprofStat) #if defined key_mpp_mpi IF(.not. ALLOCATED(ztab2))THEN ALLOCATE(ztab2(jpiglo,ijpj), & znorthgloio2(nwidthmax,ijpj,ndim_rank_north), & znorthloc2(nwidthmax,ijpj), & STAT=ierr) IF(ierr .ne. 0)THEN CALL ctl_stop('STOP','mpp_lbc_north_2d: memory allocation failed' ) END IF END IF ! 0. Sign setting ! --------------- ijpjm1=ijpj-1 ! put the last ijpj jlines of pt2d into znorthloc2 znorthloc2(:,:) = 0_wp ! because of padding for nwidthmax ! jeub is the upper j limit of current domain in global coords ! ! |======================= jpjglo ^ ! | /|\ ! |----------------------- jpjglo-1 | ! | | ! |---------jeub-------------------------------- ! | | j ! |-------------------------------------------- ! | | | ! |-------------------------------------------- | ! ! No. of trimmed rows = jpjglo - jeub ! No. of valid rows for n-fold = ijpj - ! = ijpj - jpjglo + jeub ! Need an iterator that ends with max value ijpj and has (ijpj-jpjglo+jeub) ! distinct values so start point must be: ! ij_start = ijpj - (ijpj-jpjglo+jeub) + 1 = jpjglo - jeub + 1 ! => if jeub == jpjglo then we recover a starting value of 1. ! if jeub == jpjglo - 10 then ij_start = 11 so no loop iterations ! will be performed. #if defined NO_NFOLD_GATHER ! Post receives for other PE's north-fold data DO iproc = 1, ndim_rank_north, 1 IF( iproc-1 == nrank_north(iproc) ) CYCLE ! Skip this PE CALL MPI_IRecv(znorthgloio2(), north_pts(iproc), MPI_DOUBLE_PRECISION, & nrank_north(iproc), iproc, tag, ncomm_north, & nexch_flag(iproc) ) END DO #endif DO ij = jpjglo - jeub + 1, ijpj, 1 jj = nlcj - ijpj + ij znorthloc2(nldi:nlei,ij)=pt2d(nldi:nlei,jj) END DO ! CALL dump_array(0,'znorthloc2',znorthloc2,withHalos=.TRUE.,toGlobal=.FALSE.) IF (npolj /= 0 ) THEN ! Build in proc 0 of ncomm_north the znorthgloio2 znorthgloio2(:,:,:) = 0_wp itaille=nwidthmax*ijpj CALL MPI_GATHER(znorthloc2,itaille,MPI_DOUBLE_PRECISION, & znorthgloio2,itaille,MPI_DOUBLE_PRECISION, & 0, ncomm_north, ierr) ENDIF IF (narea == north_root+1 ) THEN ! recover the global north array ! ztab2 has full width of global domain ztab2(:,:) = 0_wp DO jr = 1, ndim_rank_north jproc=nrank_north(jr)+1 ildi=nldit(jproc) ilei=nleit(jproc) iilb=pielb(jproc) ztab2(iilb:iilb+piesub(jproc)-1,1:ijpj)= & znorthgloio2(ildi:ilei,1:ijpj,jr) END DO ! CALL dump_array(0,'ztab2',ztab2,withHalos=.TRUE.,toGlobal=.FALSE.) ! 2. North-Fold boundary conditions ! ---------------------------------- SELECT CASE ( npolj ) CASE ( 3, 4 ) ! * North fold T-point pivot ztab2( 1 ,ijpj) = 0._wp ztab2(jpiglo,ijpj) = 0._wp SELECT CASE ( cd_type ) CASE ( 'T' , 'W' , 'S' ) ! T-, W-point DO ji = 2, jpiglo ijt = jpiglo-ji+2 ztab2(ji,ijpj) = psgn * ztab2(ijt,ijpj-2) END DO DO ji = jpiglo/2+1, jpiglo ijt = jpiglo-ji+2 ztab2(ji,ijpjm1) = psgn * ztab2(ijt,ijpjm1) END DO CASE ( 'U' ) ! U-point DO ji = 1, jpiglo-1 iju = jpiglo-ji+1 ztab2(ji,ijpj) = psgn * ztab2(iju,ijpj-2) END DO DO ji = jpiglo/2, jpiglo-1 iju = jpiglo-ji+1 ztab2(ji,ijpjm1) = psgn * ztab2(iju,ijpjm1) END DO CASE ( 'V' ) ! V-point DO ji = 2, jpiglo ijt = jpiglo-ji+2 ztab2(ji,ijpj-1) = psgn * ztab2(ijt,ijpj-2) ztab2(ji,ijpj ) = psgn * ztab2(ijt,ijpj-3) END DO CASE ( 'F' , 'G' ) ! F-point DO ji = 1, jpiglo-1 iju = jpiglo-ji+1 ztab2(ji,ijpj-1) = psgn * ztab2(iju,ijpj-2) ztab2(ji,ijpj ) = psgn * ztab2(iju,ijpj-3) END DO CASE ( 'I' ) ! ice U-V point ztab2(2,ijpj) = psgn * ztab2(3,ijpj-1) DO ji = 3, jpiglo iju = jpiglo - ji + 3 ztab2(ji,ijpj) = psgn * ztab2(iju,ijpj-1) END DO END SELECT CASE ( 5, 6 ) ! * North fold F-point pivot ztab2( 1 ,ijpj) = 0._wp ztab2(jpiglo,ijpj) = 0._wp SELECT CASE ( cd_type ) CASE ( 'T' , 'W' ,'S' ) ! T-, W-point DO ji = 1, jpiglo ijt = jpiglo-ji+1 ztab2(ji,ijpj) = psgn * ztab2(ijt,ijpj-1) END DO CASE ( 'U' ) ! U-point DO ji = 1, jpiglo-1 iju = jpiglo-ji ztab2(ji,ijpj) = psgn * ztab2(iju,ijpj-1) END DO CASE ( 'V' ) ! V-point DO ji = 1, jpiglo ijt = jpiglo-ji+1 ztab2(ji,ijpj) = psgn * ztab2(ijt,ijpj-2) END DO DO ji = jpiglo/2+1, jpiglo ijt = jpiglo-ji+1 ztab2(ji,ijpjm1) = psgn * ztab2(ijt,ijpjm1) END DO CASE ( 'F' , 'G' ) ! F-point DO ji = 1, jpiglo-1 iju = jpiglo-ji ztab2(ji,ijpj ) = psgn * ztab2(iju,ijpj-2) END DO DO ji = jpiglo/2+1, jpiglo-1 iju = jpiglo-ji ztab2(ji,ijpjm1) = psgn * ztab2(iju,ijpjm1) END DO CASE ( 'I' ) ! ice U-V point ztab2( 2 ,ijpj) = 0.e0 DO ji = 2 , jpiglo-1 ijt = jpiglo - ji + 2 ztab2(ji,ijpj)= 0.5 * ( ztab2(ji,ijpj-1) + psgn * ztab2(ijt,ijpj-1) ) END DO END SELECT CASE DEFAULT ! * closed : the code probably never go through SELECT CASE ( cd_type) CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points ztab2(:, 1 ) = 0._wp ztab2(:,ijpj) = 0._wp CASE ( 'F' ) ! F-point ztab2(:,ijpj) = 0._wp CASE ( 'I' ) ! ice U-V point ztab2(:, 1 ) = 0._wp ztab2(:,ijpj) = 0._wp END SELECT END SELECT ! End of slab ! =========== !! Scatter back to pt2d DO jr = 1, ndim_rank_north jproc=nrank_north(jr)+1 ildi=nldit (jproc) ilei=nleit (jproc) iilb=pielb(jproc) znorthgloio2(ildi:ilei,1:ijpj,jr)= & ztab2(iilb:iilb+piesub(jproc)-1,1:ijpj) END DO ENDIF ! only done on proc 0 of ncomm_north IF ( npolj /= 0 ) THEN itaille=nwidthmax*ijpj CALL MPI_SCATTER(znorthgloio2,itaille,MPI_DOUBLE_PRECISION, & znorthloc2, itaille,MPI_DOUBLE_PRECISION, & 0,ncomm_north,ierr) ENDIF ! Put the last ijpj jlines of pt2d into znorthloc2 while allowing ! for any trimming of domain (see earlier comments and diagram) DO ij = jpjglo - jeub + 1, ijpj, 1 jj = nlcj - ijpj + ij pt2d(nldi:nlei,jj)= znorthloc2(nldi:nlei,ij) END DO #endif /* key_mpp_mpi */ CALL prof_region_end(ARPNORTHCOMMS2D, iprofStat) END SUBROUTINE mpp_lbc_north_2d !==================================================================== SUBROUTINE mpp_lbc_north_i2d ( ib2, cd_type, isgn) !!--------------------------------------------------------------------- !! *** routine mpp_lbc_north_2d *** !! !! ** Purpose : !! Ensure proper north fold horizontal bondary condition in mpp !! configuration in case of jpn1 > 1 (for 2d array ) !! !! ** Method : !! Gather the 4 northern lines of the global domain on 1 processor and !! apply lbc north-fold on this sub array. Then scatter the fold array !! back to the processors. !! !! History : !! 8.5 ! 03-09 (J.M. Molines ) For mpp folding condition at north !! from lbc routine !! 9.0 ! 03-12 (J.M. Molines ) encapsulation into lib_mpp, !! coding rules of lbc_lnk !!---------------------------------------------------------------------- USE par_oce, ONLY : jpni, jpi, jpj USE dom_oce, ONLY : nldi, nlei, npolj, nldit, nleit, narea, & nlcj, nwidthmax USE mapcomm_mod, ONLY : pielb, piesub USE lib_mpp, ONLY : ctl_stop IMPLICIT none !! * Arguments CHARACTER(len=1), INTENT( in ) :: & cd_type ! nature of ib2 grid-points ! ! = T , U , V , F or W gridpoints INTEGER, DIMENSION(jpi,jpj), INTENT( inout ) :: & ib2 ! 2D array on which the boundary condition is applied INTEGER, INTENT( in ) :: & isgn ! control of the sign change ! ! = -1. , the sign is changed if north fold boundary ! ! = 1. , the sign is kept if north fold boundary !! * Local declarations INTEGER :: ijpj INTEGER :: ji, jj, jr, jproc INTEGER :: ierr INTEGER :: ildi,ilei,iilb INTEGER :: ijpjm1,ij,ijt,iju INTEGER :: itaille INTEGER, DIMENSION(:,:), ALLOCATABLE :: ztab2 INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: znorthgloio2 INTEGER, DIMENSION(:,:), ALLOCATABLE :: znorthloc2 !!---------------------------------------------------------------------- !! OPA 8.5, LODYC-IPSL (2002) !!---------------------------------------------------------------------- ! If we get in this routine it's because : North fold condition and mpp ! with more than one PE across i : we deal only with the North condition #if defined key_mpp_mpi ijpj = num_nfold_rows ijpjm1=ijpj - 1 IF(.not. ALLOCATED(ztab2))THEN ALLOCATE(ztab2(jpiglo,ijpj), & znorthgloio2(nwidthmax,ijpj,jpni), & znorthloc2(nwidthmax,ijpj), & STAT=ierr) IF(ierr .ne. 0)THEN CALL ctl_stop('STOP','mpp_lbc_north_i2d: memory allocation failed') END IF END IF ! 0. Sign setting ! --------------- ! Put the last ijpj jlines of ib2 into znorthloc2 while allowing ! for any trimming of domain (see earlier comments and diagram in ! mpp_lbc_north_2d). znorthloc2(:,:) = 0 ! because of padding for nwidthmax DO ij = jpjglo - jeub + 1, ijpj, 1 jj = nlcj - ijpj + ij znorthloc2(nldi:nlei,ij)=ib2(nldi:nlei,jj) END DO IF (npolj /= 0 ) THEN ! Build in proc 0 of ncomm_north the znorthgloio2 znorthgloio2(:,:,:) = 0 itaille=nwidthmax*ijpj CALL MPI_GATHER(znorthloc2,itaille,MPI_INTEGER, & znorthgloio2,itaille,MPI_INTEGER,0,& ncomm_north,ierr) ENDIF IF (narea == north_root+1 ) THEN ! recover the global north array ztab2(:,:) = 0 DO jr = 1, ndim_rank_north jproc=nrank_north(jr)+1 ildi=nldit (jproc) ilei=nleit (jproc) iilb=pielb(jproc) !WRITE (*,*)'ARPDBG, jproc = ',jproc,' ildi, ilei, iilb and ijpj = ',& ! ildi, ilei, iilb, ijpj ztab2(iilb:iilb+piesub(jproc)-1,1:ijpj) = & znorthgloio2(ildi:ilei,1:ijpj,jr) END DO ! 2. North-Fold boundary conditions ! ---------------------------------- SELECT CASE ( npolj ) CASE ( 3, 4 ) ! * North fold T-point pivot ztab2( 1 ,ijpj) = 0 ztab2(jpiglo,ijpj) = 0 SELECT CASE ( cd_type ) CASE ( 'T' , 'W' , 'S' ) ! T-, W-point DO ji = 2, jpiglo ijt = jpiglo-ji+2 ztab2(ji,ijpj) = isgn * ztab2(ijt,ijpj-2) END DO DO ji = jpiglo/2+1, jpiglo ijt = jpiglo-ji+2 ztab2(ji,ijpjm1) = isgn * ztab2(ijt,ijpjm1) END DO CASE ( 'U' ) ! U-point DO ji = 1, jpiglo-1 iju = jpiglo-ji+1 ztab2(ji,ijpj) = isgn * ztab2(iju,ijpj-2) END DO DO ji = jpiglo/2, jpiglo-1 iju = jpiglo-ji+1 ztab2(ji,ijpjm1) = isgn * ztab2(iju,ijpjm1) END DO CASE ( 'V' ) ! V-point DO ji = 2, jpiglo ijt = jpiglo-ji+2 ztab2(ji,ijpj-1) = isgn * ztab2(ijt,ijpj-2) ztab2(ji,ijpj ) = isgn * ztab2(ijt,ijpj-3) END DO CASE ( 'F' , 'G' ) ! F-point DO ji = 1, jpiglo-1 iju = jpiglo-ji+1 ztab2(ji,ijpj-1) = isgn * ztab2(iju,ijpj-2) ztab2(ji,ijpj ) = isgn * ztab2(iju,ijpj-3) END DO CASE ( 'I' ) ! ice U-V point ztab2(2,ijpj) = isgn * ztab2(3,ijpj-1) DO ji = 3, jpiglo iju = jpiglo - ji + 3 ztab2(ji,ijpj) = isgn * ztab2(iju,ijpj-1) END DO END SELECT CASE ( 5, 6 ) ! * North fold F-point pivot ztab2( 1 ,ijpj) = 0 ztab2(jpiglo,ijpj) = 0 SELECT CASE ( cd_type ) CASE ( 'T' , 'W' ,'S' ) ! T-, W-point DO ji = 1, jpiglo ijt = jpiglo-ji+1 ztab2(ji,ijpj) = isgn * ztab2(ijt,ijpj-1) END DO CASE ( 'U' ) ! U-point DO ji = 1, jpiglo-1 iju = jpiglo-ji ztab2(ji,ijpj) = isgn * ztab2(iju,ijpj-1) END DO CASE ( 'V' ) ! V-point DO ji = 1, jpiglo ijt = jpiglo-ji+1 ztab2(ji,ijpj) = isgn * ztab2(ijt,ijpj-2) END DO DO ji = jpiglo/2+1, jpiglo ijt = jpiglo-ji+1 ztab2(ji,ijpjm1) = isgn * ztab2(ijt,ijpjm1) END DO CASE ( 'F' , 'G' ) ! F-point DO ji = 1, jpiglo-1 iju = jpiglo-ji ztab2(ji,ijpj ) = isgn * ztab2(iju,ijpj-2) END DO DO ji = jpiglo/2+1, jpiglo-1 iju = jpiglo-ji ztab2(ji,ijpjm1) = isgn * ztab2(iju,ijpjm1) END DO CASE ( 'I' ) ! ice U-V point ztab2( 2 ,ijpj) = 0 DO ji = 2 , jpiglo-1 ijt = jpiglo - ji + 2 ztab2(ji,ijpj)= NINT(0.5 * ( ztab2(ji,ijpj-1) + & isgn * ztab2(ijt,ijpj-1) )) END DO END SELECT CASE DEFAULT ! * closed : the code probably never go through SELECT CASE ( cd_type) CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points ztab2(:, 1 ) = 0 ztab2(:,ijpj) = 0 CASE ( 'F' ) ! F-point ztab2(:,ijpj) = 0 CASE ( 'I' ) ! ice U-V point ztab2(:, 1 ) = 0 ztab2(:,ijpj) = 0 END SELECT END SELECT ! End of slab ! =========== !! Scatter back to ib2 DO jr = 1, ndim_rank_north jproc=nrank_north(jr)+1 ildi=nldit (jproc) ilei=nleit (jproc) iilb=pielb(jproc) znorthgloio2(ildi:ilei,1:ijpj,jr) = & ztab2(iilb:iilb+piesub(jproc)-1,1:ijpj) END DO ENDIF ! only done on proc 0 of ncomm_north IF ( npolj /= 0 ) THEN itaille=nwidthmax*ijpj CALL MPI_SCATTER(znorthgloio2,itaille,MPI_INTEGER, & znorthloc2, itaille,MPI_INTEGER, & 0, ncomm_north, ierr) ENDIF ! put in the last ijpj jlines of ib2 from znorthloc2 while allowing ! for any trimming of domain (see earlier comments and diagram in ! mpp_lbc_north_2d). DO ij = jpjglo - jeub + 1, ijpj, 1 jj = nlcj - ijpj + ij ib2(nldi:nlei,jj)= znorthloc2(nldi:nlei,ij) END DO WRITE(*,*) 'ARPDBG: finished in mpp_lbc_north_i2d' #endif /* key_mpp_mpi */ END SUBROUTINE mpp_lbc_north_i2d !================================================================= SUBROUTINE mpp_lbc_north_3d ( pt3d, cd_type, psgn ) !!--------------------------------------------------------------------- !! *** routine mpp_lbc_north_3d *** !! !! ** Purpose : !! Ensure proper north fold horizontal bondary condition in mpp !! configuration in case of jpn1 > 1 !! !! ** Method : !! Gather the 4 northern lines of the global domain on 1 processor !! and apply lbc north-fold on this sub array. Then scatter the !! fold array back to the processors. !! !! History : !! 8.5 ! 03-09 (J.M. Molines ) For mpp folding condition at north !! from lbc routine !! 9.0 ! 03-12 (J.M. Molines ) encapsulation into lib_mpp, !! coding rules of lbc_lnk !!---------------------------------------------------------------------- USE par_oce, ONLY : jpni USE dom_oce, ONLY : nldi, nlei, nlcj, npolj, narea, nldit, nleit, nwidthmax USE mapcomm_mod, ONLY : pielb, piesub USE lib_mpp, ONLY : ctl_stop IMPLICIT none !! * Arguments CHARACTER(len=1), INTENT( in ) :: cd_type ! nature of pt3d grid-points ! ! = T, U, V, F or W gridp'ts REAL(wp), DIMENSION(:,:,:), INTENT( inout ) :: & pt3d ! 3D array on which the boundary condition is applied REAL(wp), INTENT( in ) :: & psgn ! control of the sign change ! ! = -1. , the sign is changed if north fold boundary ! ! = 1. , the sign is kept if north fold boundary !! * Local declarations INTEGER :: ijpj INTEGER :: ji, jj, jk, jr, jproc INTEGER :: ierr INTEGER :: ildi,ilei,iilb INTEGER :: ijpjm1,ij,ijt,iju INTEGER :: itaille !FTRANS ztab :I :I :z !FTRANS znorthgloio :I :I :z : !FTRANS znorthloc :I :I :z REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: ztab REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: znorthgloio REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: znorthloc !!---------------------------------------------------------------------- ! If we get in this routine it's because : North fold condition and ! mpp with more than one proc across i : we deal only with the North ! condition #if defined key_mpp_mpi ijpj = num_nfold_rows ijpjm1=ijpj - 1 IF(.not. ALLOCATED(ztab))THEN ALLOCATE(ztab(jpiglo,ijpj,jpkorig), & znorthgloio(nwidthmax,ijpj,jpkorig,jpni), & znorthloc(nwidthmax,ijpj,jpkorig), & STAT=ierr) IF(ierr .ne. 0)THEN CALL ctl_stop( ' mpp_lbc_north_3d: memory allocation failed' ) #if defined key_mpp_mpi CALL mpi_finalize( ierr ) #endif STOP END IF END IF CALL prof_region_begin(NORTH3DGATHER, "North3DGather", iprofStat) ! 0. Sign setting ! --------------- ! Put the last ijpj jlines of pt3d into znorthloc while allowing ! for any trimming of domain (see earlier comments and diagram in ! mpp_lbc_north_2d). ! Have to initialise all to zero in case chunks are missing due to domain ! trimming znorthloc(:,:,:) = 0.0_wp #if defined key_z_first DO ij = jpjglo - jeub + 1, ijpj, 1 jj = nlcj - ijpj + ij DO jk = 1, jpk #else DO jk = 1, jpk DO ij = jpjglo - jeub + 1, ijpj, 1 jj = nlcj - ijpj + ij #endif znorthloc(nldi:nlei,ij,jk) = pt3d(nldi:nlei,jj,jk) END DO END DO IF (npolj /= 0 ) THEN ! Build in proc 0 of ncomm_north the znorthgloio #ifdef key_mpp_shmem not done : compiler error #elif defined key_mpp_mpi itaille=nwidthmax*jpkorig*ijpj CALL MPI_GATHER(znorthloc,itaille,MPI_DOUBLE_PRECISION, & znorthgloio,itaille,MPI_DOUBLE_PRECISION, & 0,ncomm_north,ierr) #endif ENDIF CALL prof_region_end(NORTH3DGATHER, iprofStat) CALL prof_region_begin(NORTH3DAPPSYMM, "North3DApplySymm", iprofStat) IF (narea == north_root+1 ) THEN ! recover the global north array ztab(:,:,:) = 0_wp DO jr = 1, ndim_rank_north jproc = nrank_north(jr) + 1 ildi = nldit (jproc) ilei = nleit (jproc) iilb = pielb(jproc) ztab(iilb:iilb+piesub(jproc)-1,1:ijpj,1:jpk) = & znorthgloio(ildi:ilei,1:ijpj,1:jpk,jr) END DO ! Horizontal slab ! =============== #if defined key_z_first ! 2. North-Fold boundary conditions ! ---------------------------------- SELECT CASE ( npolj ) CASE ( 3, 4 ) ! * North fold T-point pivot DO jk = 1, jpk ztab( 1 ,ijpj,jk) = 0.0_wp ztab(jpiglo,ijpj,jk) = 0.0_wp END DO SELECT CASE ( cd_type ) CASE ( 'T' , 'S' , 'W' ) ! T-, W-point DO ji = 2, jpiglo ijt = jpiglo-ji+2 DO jk = 1, jpk ztab(ji,ijpj,jk) = psgn * ztab(ijt,ijpj-2,jk) END DO END DO DO ji = jpiglo/2+1, jpiglo ijt = jpiglo-ji+2 DO jk = 1, jpk, 1 ztab(ji,ijpjm1,jk) = psgn * ztab(ijt,ijpjm1,jk) END DO END DO CASE ( 'U' ) ! U-point DO ji = 1, jpiglo-1 iju = jpiglo-ji+1 DO jk = 1, jpk, 1 ztab(ji,ijpj,jk) = psgn * ztab(iju,ijpj-2,jk) END DO END DO DO ji = jpiglo/2, jpiglo-1 iju = jpiglo-ji+1 DO jk = 1, jpk, 1 ztab(ji,ijpjm1,jk) = psgn * ztab(iju,ijpjm1,jk) END DO END DO CASE ( 'V' ) ! V-point DO ji = 2, jpiglo ijt = jpiglo-ji+2 DO jk = 1, jpk, 1 ztab(ji,ijpj-1,jk) = psgn * ztab(ijt,ijpj-2,jk) ztab(ji,ijpj ,jk) = psgn * ztab(ijt,ijpj-3,jk) END DO END DO CASE ( 'F' , 'G' ) ! F-point DO ji = 1, jpiglo-1 iju = jpiglo-ji+1 DO jk = 1, jpk, 1 ztab(ji,ijpj-1,jk) = psgn * ztab(iju,ijpj-2,jk) ztab(ji,ijpj ,jk) = psgn * ztab(iju,ijpj-3,jk) END DO END DO END SELECT CASE ( 5, 6 ) ! * North fold F-point pivot DO jk = 1, jpk, 1 ztab( 1 ,ijpj,jk) = 0._wp ztab(jpiglo,ijpj,jk) = 0._wp END DO SELECT CASE ( cd_type ) CASE ( 'T' , 'S' , 'W' ) ! T-, W-point DO ji = 1, jpiglo ijt = jpiglo-ji+1 DO jk = 1, jpk, 1 ztab(ji,ijpj,jk) = psgn * ztab(ijt,ijpj-1,jk) END DO END DO CASE ( 'U' ) ! U-point DO ji = 1, jpiglo-1 iju = jpiglo-ji DO jk = 1, jpk, 1 ztab(ji,ijpj,jk) = psgn * ztab(iju,ijpj-1,jk) END DO END DO CASE ( 'V' ) ! V-point DO ji = 1, jpiglo ijt = jpiglo-ji+1 DO jk = 1, jpk, 1 ztab(ji,ijpj,jk) = psgn * ztab(ijt,ijpj-2,jk) END DO END DO DO ji = jpiglo/2+1, jpiglo ijt = jpiglo-ji+1 DO jk = 1, jpk, 1 ztab(ji,ijpjm1,jk) = psgn * ztab(ijt,ijpjm1,jk) END DO END DO CASE ( 'F' , 'G' ) ! F-point DO ji = 1, jpiglo-1 iju = jpiglo-ji DO jk = 1, jpk, 1 ztab(ji,ijpj ,jk) = psgn * ztab(iju,ijpj-2,jk) END DO END DO DO ji = jpiglo/2+1, jpiglo-1 iju = jpiglo-ji DO jk = 1, jpk, 1 ztab(ji,ijpjm1,jk) = psgn * ztab(iju,ijpjm1,jk) END DO END DO END SELECT CASE DEFAULT ! * closed SELECT CASE ( cd_type) CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points DO ji = 1, jpiglo, 1 DO jk = 1, jpk, 1 ztab(ji, 1 ,jk) = 0.0_wp ztab(ji,ijpj,jk) = 0.0_wp END DO END DO CASE ( 'F' ) ! F-point DO ji = 1, jpiglo, 1 DO jk = 1, jpk, 1 ztab(ji,ijpj,jk) = 0.0_wp END DO END DO END SELECT END SELECT ! End of slab ! =========== #else DO jk = 1, jpk ! 2. North-Fold boundary conditions ! ---------------------------------- SELECT CASE ( npolj ) CASE ( 3, 4 ) ! * North fold T-point pivot ztab( 1 ,ijpj,jk) = 0.0_wp ztab(jpiglo,ijpj,jk) = 0.0_wp SELECT CASE ( cd_type ) CASE ( 'T' , 'S' , 'W' ) ! T-, W-point DO ji = 2, jpiglo ijt = jpiglo-ji+2 ztab(ji,ijpj,jk) = psgn * ztab(ijt,ijpj-2,jk) END DO DO ji = jpiglo/2+1, jpiglo ijt = jpiglo-ji+2 ztab(ji,ijpjm1,jk) = psgn * ztab(ijt,ijpjm1,jk) END DO CASE ( 'U' ) ! U-point DO ji = 1, jpiglo-1 iju = jpiglo-ji+1 ztab(ji,ijpj,jk) = psgn * ztab(iju,ijpj-2,jk) END DO DO ji = jpiglo/2, jpiglo-1 iju = jpiglo-ji+1 ztab(ji,ijpjm1,jk) = psgn * ztab(iju,ijpjm1,jk) END DO CASE ( 'V' ) ! V-point DO ji = 2, jpiglo ijt = jpiglo-ji+2 ztab(ji,ijpj-1,jk) = psgn * ztab(ijt,ijpj-2,jk) ztab(ji,ijpj ,jk) = psgn * ztab(ijt,ijpj-3,jk) END DO CASE ( 'F' , 'G' ) ! F-point DO ji = 1, jpiglo-1 iju = jpiglo-ji+1 ztab(ji,ijpj-1,jk) = psgn * ztab(iju,ijpj-2,jk) ztab(ji,ijpj ,jk) = psgn * ztab(iju,ijpj-3,jk) END DO END SELECT CASE ( 5, 6 ) ! * North fold F-point pivot ztab( 1 ,ijpj,jk) = 0._wp ztab(jpiglo,ijpj,jk) = 0._wp SELECT CASE ( cd_type ) CASE ( 'T' , 'S' , 'W' ) ! T-, W-point DO ji = 1, jpiglo ijt = jpiglo-ji+1 ztab(ji,ijpj,jk) = psgn * ztab(ijt,ijpj-1,jk) END DO CASE ( 'U' ) ! U-point DO ji = 1, jpiglo-1 iju = jpiglo-ji ztab(ji,ijpj,jk) = psgn * ztab(iju,ijpj-1,jk) END DO CASE ( 'V' ) ! V-point DO ji = 1, jpiglo ijt = jpiglo-ji+1 ztab(ji,ijpj,jk) = psgn * ztab(ijt,ijpj-2,jk) END DO DO ji = jpiglo/2+1, jpiglo ijt = jpiglo-ji+1 ztab(ji,ijpjm1,jk) = psgn * ztab(ijt,ijpjm1,jk) END DO CASE ( 'F' , 'G' ) ! F-point DO ji = 1, jpiglo-1 iju = jpiglo-ji ztab(ji,ijpj ,jk) = psgn * ztab(iju,ijpj-2,jk) END DO DO ji = jpiglo/2+1, jpiglo-1 iju = jpiglo-ji ztab(ji,ijpjm1,jk) = psgn * ztab(iju,ijpjm1,jk) END DO END SELECT CASE DEFAULT ! * closed SELECT CASE ( cd_type) CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points ztab(:, 1 ,jk) = 0.0_wp ztab(:,ijpj,jk) = 0.0_wp CASE ( 'F' ) ! F-point ztab(:,ijpj,jk) = 0.0_wp END SELECT END SELECT ! End of slab ! =========== END DO #endif !! Scatter back to pt3d DO jr = 1, ndim_rank_north jproc=nrank_north(jr)+1 ildi=nldit (jproc) ilei=nleit (jproc) iilb=pielb(jproc) !ARPDBG - make loops explicit for performance? znorthgloio(ildi:ilei,1:ijpj,1:jpk,jr) = & ztab(iilb:iilb+piesub(jproc)-1,1:ijpj,1:jpk) END DO ENDIF ! only done on proc 0 of ncomm_north CALL prof_region_end(NORTH3DAPPSYMM, iprofStat) !ARPDBG - could do above on every 'northern' pe and then don't have to ! do scatter below... CALL prof_region_begin(NORTH3DSCATTER, "North3DScatter", iprofStat) #ifdef key_mpp_shmem not done yet in shmem : compiler error #elif key_mpp_mpi IF ( npolj /= 0 ) THEN itaille=nwidthmax*jpkorig*ijpj CALL MPI_SCATTER(znorthgloio,itaille,MPI_DOUBLE_PRECISION, & znorthloc, itaille,MPI_DOUBLE_PRECISION, & 0,ncomm_north,ierr) ENDIF #endif ! put in the last ijpj jlines of pt3d znorthloc while allowing ! for any trimming of domain (see earlier comments and diagram in ! mpp_lbc_north_2d). #if defined key_z_first DO ij = jpjglo - jeub + 1, ijpj, 1 jj = nlcj - ijpj + ij DO jk = 1 , jpk #else DO jk = 1 , jpk DO ij = jpjglo - jeub + 1, ijpj, 1 jj = nlcj - ijpj + ij #endif pt3d(nldi:nlei,jj,jk)= znorthloc(nldi:nlei,ij,jk) END DO END DO CALL prof_region_end(NORTH3DSCATTER, iprofStat) #endif /* key_mpp_mpi */ END SUBROUTINE mpp_lbc_north_3d !=================================================================== SUBROUTINE mpp_lbc_north_i3d ( ib3, cd_type, isgn ) !!--------------------------------------------------------------------- !! *** routine mpp_lbc_north_3d *** !! !! ** Purpose : !! Ensure proper north fold horizontal bondary condition in mpp !! configuration in case of jpn1 > 1 !! !! ** Method : !! Gather the 4 northern lines of the global domain on 1 processor !! and apply lbc north-fold on this sub array. Then scatter the !! fold array back to the processors. !! !! History : !! 8.5 ! 03-09 (J.M. Molines ) For mpp folding condition at north !! from lbc routine !! 9.0 ! 03-12 (J.M. Molines ) encapsulation into lib_mpp, coding !! rules of lbc_lnk !!---------------------------------------------------------------------- USE par_oce, ONLY : jpni USE dom_oce, ONLY : nldi, nlei, nlcj, npolj, narea, nldit, nleit, & nwidthmax USE mapcomm_mod, ONLY : pielb, piesub USE lib_mpp, ONLY : ctl_stop IMPLICIT none !! * Arguments CHARACTER(len=1), INTENT( in ) :: cd_type ! nature of pt3d grid-points ! ! = T, U, V, F or W gridp'ts INTEGER, DIMENSION(:,:,:), INTENT( inout ) :: & ib3 ! 3D array on which the boundary condition is applied INTEGER, INTENT( in ) :: & isgn ! control of the sign change ! ! = -1. , the sign is changed if north fold boundary ! ! = 1. , the sign is kept if north fold boundary !! * Local declarations INTEGER :: ijpj INTEGER :: ijpjm1 INTEGER :: ii, ji, jj, jk, jr, jproc INTEGER :: ierr INTEGER :: ildi,ilei,iilb INTEGER :: ij,ijt,iju INTEGER :: itaille !FTRANS ztab :I :I :z !FTRANS znorthgloio :I :I :z : !FTRANS znorthloc :I :I :z INTEGER, DIMENSION(:,:,:) , ALLOCATABLE :: ztab INTEGER, DIMENSION(:,:,:,:), ALLOCATABLE :: znorthgloio INTEGER, DIMENSION(:,:,:) , ALLOCATABLE :: znorthloc !!---------------------------------------------------------------------- ! If we get in this routine it s because : North fold condition and ! mpp with more than one proc across i : we deal only with the North ! condition ijpj = num_nfold_rows ijpjm1 = ijpj - 1 IF(.not. ALLOCATED(ztab))THEN ALLOCATE(ztab(jpiglo,ijpj,jpkorig), & znorthgloio(nwidthmax,ijpj,jpkorig,jpni), & znorthloc(nwidthmax,ijpj,jpkorig), & STAT=ierr) IF(ierr .ne. 0)THEN CALL ctl_stop('STOP','mpp_lbc_north_i3d: memory allocation failed' ) END IF END IF ! 0. Sign setting ! --------------- ! put in znorthloc the last ijpj jlines of pt3d while allowing ! for any trimming of domain (see earlier comments and diagram in ! mpp_lbc_north_2d). znorthloc(:,:,:) = 0 ! because of padding for nwidthmax and domain ! trimming #if defined key_z_first DO ij = jpjglo - jeub + 1, ijpj, 1 jj = nlcj - ijpj + ij DO jk = 1, jpk #else DO jk = 1, jpk DO ij = jpjglo - jeub + 1, ijpj, 1 jj = nlcj - ijpj + ij #endif znorthloc(nldi:nlei,ij,jk) = ib3(nldi:nlei,jj,jk) END DO END DO IF (npolj /= 0 ) THEN ! Build in proc 0 of ncomm_north the znorthgloio znorthgloio(:,:,:,:) = 0 #ifdef key_mpp_shmem not done : compiler error #elif defined key_mpp_mpi ! All domains send this number of elements. Narrower domains ! therefore send data padded with zeros itaille=nwidthmax*jpk*ijpj CALL MPI_GATHER(znorthloc, itaille,MPI_INTEGER, & znorthgloio,itaille,MPI_INTEGER, & 0, ncomm_north, ierr) #endif ENDIF IF (narea == north_root+1 ) THEN ! recover the global north array ztab(:,:,:) = 0 DO jr = 1, ndim_rank_north jproc = nrank_north(jr) + 1 ildi = nldit (jproc) ilei = nleit (jproc) iilb = pielb(jproc) ! ARPDBG explicit loops for performance? ztab(iilb:iilb+piesub(jproc)-1,1:ijpj,1:jpk) = & znorthgloio(ildi:ilei,1:ijpj,1:jpk,jr) END DO #if defined key_z_first ! 2. North-Fold boundary conditions ! ---------------------------------- SELECT CASE ( npolj ) CASE ( 3, 4 ) ! * North fold T-point pivot DO jk = 1, jpk, 1 ztab( 1 ,ijpj,jk) = 0 ztab(jpiglo,ijpj,jk) = 0 END DO SELECT CASE ( cd_type ) CASE ( 'T' , 'S' , 'W' ) ! T-, W-point DO ji = 2, jpiglo ijt = jpiglo-ji+2 DO jk = 1, jpk, 1 ztab(ji,ijpj,jk) = isgn * ztab(ijt,ijpj-2,jk) END DO END DO DO ji = jpiglo/2+1, jpiglo ijt = jpiglo-ji+2 DO jk = 1, jpk, 1 ztab(ji,ijpjm1,jk) = isgn * ztab(ijt,ijpjm1,jk) END DO END DO CASE ( 'U' ) ! U-point DO ji = 1, jpiglo-1 iju = jpiglo-ji+1 DO jk = 1, jpk, 1 ztab(ji,ijpj,jk) = isgn * ztab(iju,ijpj-2,jk) END DO END DO DO ji = jpiglo/2, jpiglo-1 iju = jpiglo-ji+1 DO jk = 1, jpk, 1 ztab(ji,ijpjm1,jk) = isgn * ztab(iju,ijpjm1,jk) END DO END DO CASE ( 'V' ) ! V-point DO ji = 2, jpiglo ijt = jpiglo-ji+2 DO jk = 1, jpk, 1 ztab(ji,ijpj-1,jk) = isgn * ztab(ijt,ijpj-2,jk) ztab(ji,ijpj ,jk) = isgn * ztab(ijt,ijpj-3,jk) END DO END DO CASE ( 'F' , 'G' ) ! F-point DO ji = 1, jpiglo-1 iju = jpiglo-ji+1 DO jk = 1, jpk, 1 ztab(ji,ijpj-1,jk) = isgn * ztab(iju,ijpj-2,jk) ztab(ji,ijpj ,jk) = isgn * ztab(iju,ijpj-3,jk) END DO END DO END SELECT CASE ( 5, 6 ) ! * North fold F-point pivot DO jk = 1, jpk, 1 ztab( 1 ,ijpj,jk) = 0 ztab(jpiglo,ijpj,jk) = 0 END DO SELECT CASE ( cd_type ) CASE ( 'T' , 'S' , 'W' ) ! T-, W-point DO ji = 1, jpiglo ijt = jpiglo-ji+1 DO jk = 1, jpk, 1 ztab(ji,ijpj,jk) = isgn * ztab(ijt,ijpj-1,jk) END DO END DO CASE ( 'U' ) ! U-point DO ji = 1, jpiglo-1 iju = jpiglo-ji DO jk = 1, jpk, 1 ztab(ji,ijpj,jk) = isgn * ztab(iju,ijpj-1,jk) END DO END DO CASE ( 'V' ) ! V-point DO ji = 1, jpiglo ijt = jpiglo-ji+1 DO jk = 1, jpk, 1 ztab(ji,ijpj,jk) = isgn * ztab(ijt,ijpj-2,jk) END DO END DO DO ji = jpiglo/2+1, jpiglo ijt = jpiglo-ji+1 DO jk = 1, jpk, 1 ztab(ji,ijpjm1,jk) = isgn * ztab(ijt,ijpjm1,jk) END DO END DO CASE ( 'F' , 'G' ) ! F-point DO ji = 1, jpiglo-1 iju = jpiglo-ji DO jk = 1, jpk, 1 ztab(ji,ijpj ,jk) = isgn * ztab(iju,ijpj-2,jk) END DO END DO DO ji = jpiglo/2+1, jpiglo-1 iju = jpiglo-ji DO jk = 1, jpk, 1 ztab(ji,ijpjm1,jk) = isgn * ztab(iju,ijpjm1,jk) END DO END DO END SELECT CASE DEFAULT ! * closed SELECT CASE ( cd_type) CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points DO ji = 1, jpiglo, 1 DO jk = 1, jpk, 1 ztab(ji, 1 ,jk) = 0 ztab(ji,ijpj,jk) = 0 END DO END DO CASE ( 'F' ) ! F-point DO ji = 1, jpiglo, 1 DO jk = 1, jpk, 1 ztab(ji,ijpj,jk) = 0 END DO END DO END SELECT END SELECT ! End of slab ! =========== #else ! Horizontal slab ! =============== DO jk = 1, jpk ! 2. North-Fold boundary conditions ! ---------------------------------- SELECT CASE ( npolj ) CASE ( 3, 4 ) ! * North fold T-point pivot ztab( 1 ,ijpj,jk) = 0 ztab(jpiglo,ijpj,jk) = 0 SELECT CASE ( cd_type ) CASE ( 'T' , 'S' , 'W' ) ! T-, W-point DO ji = 2, jpiglo ijt = jpiglo-ji+2 ztab(ji,ijpj,jk) = isgn * ztab(ijt,ijpj-2,jk) END DO DO ji = jpiglo/2+1, jpiglo ijt = jpiglo-ji+2 ztab(ji,ijpjm1,jk) = isgn * ztab(ijt,ijpjm1,jk) END DO CASE ( 'U' ) ! U-point DO ji = 1, jpiglo-1 iju = jpiglo-ji+1 ztab(ji,ijpj,jk) = isgn * ztab(iju,ijpj-2,jk) END DO DO ji = jpiglo/2, jpiglo-1 iju = jpiglo-ji+1 ztab(ji,ijpjm1,jk) = isgn * ztab(iju,ijpjm1,jk) END DO CASE ( 'V' ) ! V-point DO ji = 2, jpiglo ijt = jpiglo-ji+2 ztab(ji,ijpj-1,jk) = isgn * ztab(ijt,ijpj-2,jk) ztab(ji,ijpj ,jk) = isgn * ztab(ijt,ijpj-3,jk) END DO CASE ( 'F' , 'G' ) ! F-point DO ji = 1, jpiglo-1 iju = jpiglo-ji+1 ztab(ji,ijpj-1,jk) = isgn * ztab(iju,ijpj-2,jk) ztab(ji,ijpj ,jk) = isgn * ztab(iju,ijpj-3,jk) END DO END SELECT CASE ( 5, 6 ) ! * North fold F-point pivot ztab( 1 ,ijpj,jk) = 0 ztab(jpiglo,ijpj,jk) = 0 SELECT CASE ( cd_type ) CASE ( 'T' , 'S' , 'W' ) ! T-, W-point DO ji = 1, jpiglo ijt = jpiglo-ji+1 ztab(ji,ijpj,jk) = isgn * ztab(ijt,ijpj-1,jk) END DO CASE ( 'U' ) ! U-point DO ji = 1, jpiglo-1 iju = jpiglo-ji ztab(ji,ijpj,jk) = isgn * ztab(iju,ijpj-1,jk) END DO CASE ( 'V' ) ! V-point DO ji = 1, jpiglo ijt = jpiglo-ji+1 ztab(ji,ijpj,jk) = isgn * ztab(ijt,ijpj-2,jk) END DO DO ji = jpiglo/2+1, jpiglo ijt = jpiglo-ji+1 ztab(ji,ijpjm1,jk) = isgn * ztab(ijt,ijpjm1,jk) END DO CASE ( 'F' , 'G' ) ! F-point DO ji = 1, jpiglo-1 iju = jpiglo-ji ztab(ji,ijpj ,jk) = isgn * ztab(iju,ijpj-2,jk) END DO DO ji = jpiglo/2+1, jpiglo-1 iju = jpiglo-ji ztab(ji,ijpjm1,jk) = isgn * ztab(iju,ijpjm1,jk) END DO END SELECT CASE DEFAULT ! * closed SELECT CASE ( cd_type) CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points ztab(:, 1 ,jk) = 0 ztab(:,ijpj,jk) = 0 CASE ( 'F' ) ! F-point ztab(:,ijpj,jk) = 0 END SELECT END SELECT ! End of slab ! =========== END DO #endif !! Scatter back to pt3d DO jr = 1, ndim_rank_north jproc=nrank_north(jr)+1 ildi=nldit (jproc) ilei=nleit (jproc) iilb=pielb(jproc) ! DO jk= 1, jpk ! DO jj=1,ijpj ! DO ji=ildi,ilei ! znorthgloio(ji,jj,jk,jr)=ztab(ji+iilb-1,jj,jk) ! END DO ! END DO ! END DO ! ARPDBG - what about halos? znorthgloio(ildi:ilei,1:ijpj,1:jpk,jr) = & ztab(iilb:iilb+piesub(jproc)-1,1:ijpj,1:jpk) END DO ENDIF ! only done on proc 0 of ncomm_north #ifdef key_mpp_shmem not done yet in shmem : compiler error #elif key_mpp_mpi IF ( npolj /= 0 ) THEN itaille=nwidthmax*jpk*ijpj CALL MPI_SCATTER(znorthgloio,itaille,MPI_INTEGER, & znorthloc, itaille,MPI_INTEGER, & 0, ncomm_north, ierr) ENDIF #endif ! put in the last ijpj jlines of pt3d znorthloc while allowing ! for any trimming of domain (see earlier comments and diagram in ! mpp_lbc_north_2d). #if defined key_z_first DO ij = jpjglo - jeub + 1, ijpj, 1 jj = nlcj - ijpj + ij DO ii = nldi, nlei, 1 DO jk = 1 , jpk #else DO jk = 1 , jpk DO ij = jpjglo - jeub + 1, ijpj, 1 jj = nlcj - ijpj + ij DO ii = nldi, nlei, 1 #endif ib3(ii,jj,jk)= znorthloc(ii,ij,jk) END DO END DO END DO END SUBROUTINE mpp_lbc_north_i3d !==================================================================== END MODULE exchmod ! Copy n contiguous real*8 elements from a to b. ! We expect the compiler to optimise this into a call ! to the system memory copy routine. SUBROUTINE do_real8_copy( n, a, b ) IMPLICIT none ! arguments INTEGER, INTENT(in) :: n REAL*8, dimension(n), INTENT(in ) :: a REAL*8, DIMENSION(n), INTENT(out) :: b ! local variables integer :: i do i=1,n b(i) = a(i) end do END SUBROUTINE do_real8_copy